読者です 読者をやめる 読者になる 読者になる

bitterharvest’s diary

A Bitter Harvestは小説の題名。作者は豪州のPeter Yeldham。苦闘の末に勝ちえた偏見からの解放は命との引換になったという悲しい物語

ボールの衝突をFunctional Reactive Programmingで表現する(7)

8.一直線上で衝突するボール(完成編)

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

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

8.2 プログラム実行

左側から追いかけての追突の様子を示した動画である。

右側から追いかけての追突の様子を示した動画である。

8.3 プログラム全体

メインプログラムには変更はない。

{-# 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)