7．一直線状で衝突するボール（基本部分）
７．１ 基本的な考え方
衝突するボールでは、二つのボールが存在する。そこで、\(t\)の時間での二つのボールの値をb1,b2で表すこととする。また、ボールの値を作り出してくれるWireをballとする。
また、ボールが衝突するかどうかを示す値をcで表すこととし、その値を作り出してくれるWireをcollisionとする。なお、ｃの値は、現時点\(t\)での衝突を表しているのではなく、現時点\(t\)から（微小な時間間隔\(dt\)が経過した）次の計算時間\(t+dt\)までに衝突が生じるかどうかを示す。
\(t\)の時間でのボールの値b1,b2と衝突の値cは、ball, collisionを用いて次のように表すことができる。
rec b1 <- ball "ball1" radius vInit1 pInit1 -< ("ball1", c) b2 <- ball "ball2" radius vInit2 pInit2 -< ("ball2", c) c <- collision -< (b1, b2)
前の記事での跳ね返るボールと同じように、現時点\(t\)から\(dt\)が経過する(次の計算時間)までに衝突するかどうかがcによって示され、この値がそれぞれのボールの次の計算時間での正しい速度と位置を計算するために使われる。従って、この式により、時間の経過とともに、ボールの正しい位置が得られることが保証されている。
７．２ ボールと衝突のデータ型
ボールのデータ型には、どのボールであるかを示すための名前、半径、現時点\(t\)での速度と位置を持たせた。
data Ball = Ball String Double (V2 Double) (V2 Double) deriving (Eq, Show, Read)
衝突のデータ型には、与えられた二つのボールにおいて、次の計算時間に衝突が生じるかどうかを示すブール値と、二つのボールのそれぞれの名前を持たせた。
data Collision = Collision Bool Ball Ball deriving (Eq, Show, Read)
７．３ ボールのために用意したWire
ボールに対するWireは次のようになる。
ball :: (HasTime t s) => String -> Double -> (V2 Double) -> (V2 Double) -> Wire s () IO (String, Collision) Ball ball name r v0 p0 = proc (self, collision) -> do vel <- velocity v0 -< (self, collision) pos <- position p0 -< (vel, self, collision) returnA -< makeBall name vel pos where makeBall :: String -> V2 Double -> V2 Double -> Ball makeBall n v p = Ball n r v p
ボールのWireは、速度velocityと位置positionを示すWireとボールの値を作成するmakeBallという関数で構成される。
velocityという関数は、現時点\(t\)での速度velを出力するとともに、self, collisionを入力する。この入力を得て次の時間での速度を用意する。selfは自分自身が誰であるかを示す値である。collisionは次に衝突が発生するかどうかを示す値である。なお、v0は最初の速度であり、一番最初に出力される初期値である。
positionという関数は、現時点\(t\)での位置posを出力するとともに、vel, self, collisionを入力する。この入力を得て次の時間での位置を用意する。velは現時点での速度であり、selfは自分自身が誰であるかを示す値である。collisionは次に衝突が発生するかどうかを示す値である。なお、p0は最初の位置であり、一番最初に出力される初期値である。
makeBallは、自身の名前nameと現時点での速度velと位置posを入力して現在のボールの値を返す。
７．４ ボールのWireを構成するWire
先ほど見てきたようにボールのWireは速度velocityと位置positionで構成されている。velocityは次のようになっている。
velocity :: (HasTime t s, Monad m) => (V2 Double) -> Wire s () m (String, Collision) (V2 Double) velocity vInit = constWith collide vInit where collide (self, (Collision b (Ball n1 r1 (V2 vx1 vy1) (V2 x1 y1)) (Ball n2 r2 (V2 vx2 vy2) (V2 x2 y2)))) | b && self == n1 = (V2 vx2 vy2) | b = (V2 vx1 vy1) | self == n1 = (V2 vx1 vy1) | otherwise = (V2 vx2 vy2) constWith :: (Fractional a, HasTime t s)=> (w -> a) -> a -> Wire s e m w a constWith correct = loop where loop x' = mkPure $ \ds w -> let dt = realToFrac (dtime ds) x = correct w in x' `seq` (Right x', loop x)
この関数では、現時点での速度はRight x’から出力されるが、次の時点での速度はxとして用意される。このxはcollideという関数により定まる。関数collideは、衝突が生じないときはこれまでの速度を、生じたときは衝突相手の速度を出力する。
positionは次のようになっている。
position :: (HasTime t s, Monad m) => (V2 Double) -> Wire s () m (V2 Double, String, Collision) (V2 Double) position pInit = integralWith' collide' pInit where collide' self (Collision b (Ball n1 r1 (V2 vx1 vy1) (V2 x1 y1)) (Ball n2 r2 (V2 vx2 vy2) (V2 x2 y2))) pos | b && self == n1 = if x1 > x2 then V2 (x2 + (r1 + r2)) y2 else V2 (x2 - (r1 + r2)) y2 | b = if x2 > x1 then V2 (x1 + (r1 + r2)) y1 else V2 (x1 - (r1 + r2)) y1 | otherwise = pos integralWith' :: (Fractional a, HasTime t s) => (b -> w -> a -> a) -> a -> Wire s e m (a, b, w) a integralWith' correct = loop where loop x' = mkPure $ \ds (vel, n, c) -> let dt = realToFrac (dtime ds) x = correct n c (x' + dt*vel) in x' `seq` (Right x', loop x)
この関数では、現時点での位置はRight x’から出力されるが、次の時点での位置はxとして用意される。このxはcollide'という関数により定まる。関数collide'は、衝突が生じないときはこれまでの速度から得た位置を、生じたときは前の記事で示した計算に基づいて位置を出力する。
７．５ 衝突のためのWire
衝突が発生するかどうかを示すcollisionは次のようになる。
collision :: (HasTime t s) => Wire s () IO (Ball, Ball) Collision collision = proc (b1@(Ball name1 r1 (V2 vx1 vy1) (V2 x1 y1)), b2@(Ball name2 r2 (V2 vx2 vy2) (V2 x2 y2))) -> do if abs ((x1 + vx1 * 0.000001) - (x2 + vx2 * 0.000001)) > r1 + r2 then returnA -< makeCollision False b1 b2 else returnA -< makeCollision True b1 b2 where makeCollision :: Bool -> Ball -> Ball -> Collision makeCollision b b1 b2 = Collision b b1 b2
このWireは二つのボールの現在の速度と位置を得て、\(dt\)時間経過するまでに衝突するかどうかを調べる。
clockSessionを用いてシミュレーションをすると、dtの時間間隔はおおよそ1ミリ秒になっているようだ。ここでは、もっと細かいdt=0.000001秒にして、それぞれのボールの次の位置を求め、衝突したかどうかを調べることとする。dtはコンピュータによって異なるので、次の記事ではdtをパラメータとして入力できるようにするが、ここでは、とりあえず動くかどうかを確認するためにこの値を用いる。
７．６ 実行する
それではプログラムを実行する。ここでは正面衝突するときの動画を示す。
７．７ プログラム
メインのプログラムは次のようになっている。
{-# LANGUAGE Arrows #-} -- module Main where import Prelude hiding ((.),) import Control.Wire import Control.Monad.IO.Class import FRP.Netwire import Graphics.Rendering.OpenGL import Graphics.UI.GLFW import Data.IORef import Linear.V2 import Ball import Configure import Collision type Point = (Double, Double) type Polygon = [Point] renderPoint :: Point -> IO () renderPoint (x, y) = vertex $ Vertex2 (realToFrac x :: GLfloat) (realToFrac y :: GLfloat) generatePointsForBall :: Ball -> Polygon generatePointsForBall (Ball name r (V2 vx vy) (V2 x y)) = map (\t -> (x+r*cos (t), y+r*sin (t))) [0,0.2..(2*pi)] runNetwork :: (HasTime t s) => IORef Bool -> Session IO s -> Wire s e IO a (Ball, Ball) -> IO () runNetwork closedRef session wire = do pollEvents let color3f r g b = color $ Color3 r g (b :: GLfloat) closed <- readIORef closedRef if closed then return () else do (st , session') <- stepSession session (wt', wire' ) <- stepWire wire st $ Right undefined case wt' of Left _ -> return () Right (b1,b2) -> do clear [ColorBuffer] color3f 1.0 0.8 0.6 renderPrimitive Polygon $ mapM_ renderPoint $ generatePointsForBall b1 color3f 0.8 0.2 0.2 renderPrimitive Polygon $ mapM_ renderPoint $ generatePointsForBall b2 swapBuffers runNetwork closedRef session' wire' simulation :: HasTime t s => Wire s () IO a (Ball, Ball) simulation = proc _ -> do rec b1 <- ball "ball1" radius vInit1 pInit1 -< ("ball1", c) b2 <- ball "ball2" radius vInit2 pInit2 -< ("ball2", c) c <- collision -< (b1, b2) returnA -< (b1, b2) main :: IO () main = do initialize openWindow (Size 640 640) [DisplayRGBBits 8 8 8, DisplayAlphaBits 8, DisplayDepthBits 24] Window closedRef <- newIORef False windowCloseCallback $= do writeIORef closedRef True return True runNetwork closedRef clockSession_ simulation closeWindow
ボールのプログラムは次のようになっている。
{-# LANGUAGE Arrows #-} module Ball (ball) where import Prelude hiding ((.),) import Control.Wire import FRP.Netwire.Move import Linear.V2 import Configure import Collision velocity :: (HasTime t s, Monad m) => (V2 Double) -> Wire s () m (String, Collision) (V2 Double) velocity vInit = constWith collide vInit where collide (self, (Collision b (Ball n1 r1 (V2 vx1 vy1) (V2 x1 y1)) (Ball n2 r2 (V2 vx2 vy2) (V2 x2 y2)))) | b && self == n1 = (V2 vx2 vy2) | b = (V2 vx1 vy1) | self == n1 = (V2 vx1 vy1) | otherwise = (V2 vx2 vy2) constWith :: (Fractional a, HasTime t s)=> (w -> a) -> a -> Wire s e m w a constWith correct = loop where loop x' = mkPure $ \ds w -> let dt = realToFrac (dtime ds) x = correct w in x' `seq` (Right x', loop x) position :: (HasTime t s, Monad m) => (V2 Double) -> Wire s () m (V2 Double, String, Collision) (V2 Double) position pInit = integralWith' collide' pInit where collide' self (Collision b (Ball n1 r1 (V2 vx1 vy1) (V2 x1 y1)) (Ball n2 r2 (V2 vx2 vy2) (V2 x2 y2))) pos | b && self == n1 = if x1 > x2 then V2 (x2 + (r1 + r2)) y2 else V2 (x2 - (r1 + r2)) y2 | b = if x2 > x1 then V2 (x1 + (r1 + r2)) y1 else V2 (x1 - (r1 + r2)) y1 | otherwise = pos integralWith' :: (Fractional a, HasTime t s) => (b -> w -> a -> a) -> a -> Wire s e m (a, b, w) a integralWith' correct = loop where loop x' = mkPure $ \ds (vel, n, c) -> let dt = realToFrac (dtime ds) x = correct n c (x' + dt*vel) in x' `seq` (Right x', loop x) ball :: (HasTime t s) => String -> Double -> (V2 Double) -> (V2 Double) -> Wire s () IO (String, Collision) Ball ball name r v0 p0 = proc (self, collision) -> do vel <- velocity v0 -< (self, collision) pos <- position p0 -< (vel, self, collision) returnA -< makeBall name vel pos where makeBall :: String -> V2 Double -> V2 Double -> Ball makeBall n v p = Ball n r v p||< 衝突のプログラムは次のようになっている。 >|haskell| {-# LANGUAGE Arrows #-} module Collision (collision) where import Prelude hiding ((.),) import Control.Wire import Control.Monad.IO.Class() import FRP.Netwire() import Linear.V2 import Configure collision :: (HasTime t s) => Wire s () IO (Ball, Ball) Collision collision = proc (b1@(Ball name1 r1 (V2 vx1 vy1) (V2 x1 y1)), b2@(Ball name2 r2 (V2 vx2 vy2) (V2 x2 y2))) -> do if abs ((x1 + vx1 * 0.000001) - (x2 + vx2 * 0.000001)) > r1 + r2 then returnA -< makeCollision False b1 b2 else returnA -< makeCollision True b1 b2 where makeCollision :: Bool -> Ball -> Ball -> Collision makeCollision b b1 b2 = Collision b b1 b2
初期値などを与えるプログラムは次のようになっている。
{-# LANGUAGE Arrows #-} module Configure where import Linear.V2 data Ball = Ball String Double (V2 Double) (V2 Double) deriving (Eq, Show, Read) radius :: Double radius = 0.05 pInit1 :: V2 Double pInit1 = V2 (-0.75) 0 vInit1 :: V2 Double vInit1 = V2 0.2 0 pInit2 :: V2 Double pInit2 = V2 0.75 0 vInit2 :: V2 Double vInit2 = V2 (-0.1) 0 data Collision = Collision Bool Ball Ball deriving (Eq, Show, Read)
