ボールの衝突をFunctional Reactive Programmingで表現する（７）

８．一直線上で衝突するボール（完成編）

８．１　微小間隔時間をパラメータで引き渡す

前の記事では、計算の時間間隔を値で与えたが、この値は、コンピュータの速度やプログラム内部の設定などで変わる可能性があるので、プログラムの中でパラメータとして渡せるようにする。そこで、ボールのデータ型を変更して名前、半径、現在の速度、現在の位置、微小な時間間隔\(dt\)を与えることとする。

data Ball = Ball String Double (V2 Double) (V2 Double) (V2 Double) deriving (Eq, Show, Read)

なお、\(dt\)は、速度や場所と同じく2次元のベクトルである。また、二つのベクトルV2 a1 b1とV2 a2 b2の積(V2 a1 b1)* (V2 a2 b2)はV2 a1*a2 b1*b2である。

時間間隔\(dt\)をボールに設定するのは、positionでボールの値を設定するときとし、ballの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, dt) <- position p0 -< (vel, self, collision)
    returnA -< makeBall name vel pos dt
  where makeBall :: String -> V2 Double -> V2 Double -> V2 Double -> Ball
        makeBall n v p dt = Ball n r v p dt

これに伴って、positionのWireも以下のように変更する。

position :: (HasTime t s, Monad m) => (V2 Double) -> Wire s () m (V2 Double, String, Collision) (V2 Double, V2 Double)
position pInit = integralWith' collide' pInit
  where 
    collide' self (Collision b (Ball n1 r1 (V2 vx1 vy1) (V2 x1 y1) (V2 dt1 dt1')) (Ball n2 r2 (V2 vx2 vy2) (V2 x2 y2) (V2 dt2 dt2'))) 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, 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', dt), loop x)

また、collisionのWireも次のように変更となる。

collision :: (HasTime t s) => Wire s () IO (Ball, Ball) Collision
collision = proc (b1@(Ball name1 r1 (V2 vx1 vy1) (V2 x1 y1) (V2 dt1 dt1')), b2@(Ball name2 r2 (V2 vx2 vy2) (V2 x2 y2) (V2 dt2 dt2'))) -> do
    if abs ((x1 + vx1 * dt1) - (x2 + vx2 * dt2)) > 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 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) (V2 dt dt')) = 
  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) (V2 dt1 dt1')) (Ball n2 r2 (V2 vx2 vy2) (V2 x2 y2) (V2 dt2 dt2'))))
            | 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, V2 Double)
position pInit = integralWith' collide' pInit
  where 
    collide' self (Collision b (Ball n1 r1 (V2 vx1 vy1) (V2 x1 y1) (V2 dt1 dt1')) (Ball n2 r2 (V2 vx2 vy2) (V2 x2 y2) (V2 dt2 dt2'))) 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, 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', dt), 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, dt) <- position p0 -< (vel, self, collision)
    returnA -< makeBall name vel pos dt
  where makeBall :: String -> V2 Double -> V2 Double -> V2 Double -> Ball
        makeBall n v p dt = Ball n r v p dt

衝突に関する部分は次のようになる。

{-# 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) (V2 dt1 dt1')), b2@(Ball name2 r2 (V2 vx2 vy2) (V2 x2 y2) (V2 dt2 dt2'))) -> do
    if abs ((x1 + vx1 * dt1) - (x2 + vx2 * dt2)) > 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

-- one unit is equal to 10 meters
data Ball = Ball String Double (V2 Double) (V2 Double) (V2 Double) deriving (Eq, Show, Read)


radius :: Double
radius = 0.05

pInit1 :: V2 Double
pInit1 = V2 (-0.5) 0

vInit1 :: V2 Double
vInit1 = V2 0.1 0

pInit2 :: V2 Double
pInit2 = V2 (-0.75) 0

vInit2 :: V2 Double
vInit2 = V2 0.2 0

{-
pInit1 :: V2 Double
pInit1 = V2 (0.75) 0

vInit1 :: V2 Double
vInit1 = V2 (-0.2) 0

pInit2 :: V2 Double
pInit2 = V2 (0.5) 0

vInit2 :: V2 Double
vInit2 = V2 (-0.1) 0
-}
{-
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)