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

bitterharvest’s diary

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

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

7.一直線状で衝突するボール(基本部分)

7.1 基本的な考え方

衝突するボールでは、二つのボールが存在する。そこで、\(t\)の時間での二つのボールの値をb1,b2で表すこととする。また、ボールの値を作り出してくれるWireをballとする。

また、ボールが衝突するかどうかを示す値をcで表すこととし、その値を作り出してくれるWireをcollisionとする。なお、cの値は、現時点\(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によって示され、この値がそれぞれのボールの次の計算時間での正しい速度と位置を計算するために使われる。従って、この式により、時間の経過とともに、ボールの正しい位置が得られることが保証されている。

7.2 ボールと衝突のデータ型

ボールのデータ型には、どのボールであるかを示すための名前、半径、現時点\(t\)での速度と位置を持たせた。

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

衝突のデータ型には、与えられた二つのボールにおいて、次の計算時間に衝突が生じるかどうかを示すブール値と、二つのボールのそれぞれの名前を持たせた。

data Collision = Collision Bool Ball Ball deriving (Eq, Show, Read)

7.3 ボールのために用意した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を入力して現在のボールの値を返す。

7.4 ボールの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'は、衝突が生じないときはこれまでの速度から得た位置を、生じたときは前の記事で示した計算に基づいて位置を出力する。

7.5 衝突のための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をパラメータとして入力できるようにするが、ここでは、とりあえず動くかどうかを確認するためにこの値を用いる。

7.6 実行する

それではプログラムを実行する。ここでは正面衝突するときの動画を示す。

7.7 プログラム

メインのプログラムは次のようになっている。

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