bitterharvest’s diary

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

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

Functional Reactive Programming

５．すり抜けるボール

衝突するプログラムをいきなり設計するのは、少し、手ごわいので、易しいものから、順番に組み立てていく。まずは、衝突を検知しないプログラムを作成する。これは、二つのボールが正しく動くことを確認するためのプログラムである。

５．１　メインプログラム

まず、定番だが、画面の表示用のプログラムをOpenGLを用いて作成する。このプログラムでは、二つのボールを表示する。ボールは円として表示することとし、これを多角形で近似する。半径\(r\)、中心\(x,y\)の円を、0.2ラジアンの刻みで、多角形として表し、その頂点のリストを求めるプログラムは次のようになる。

generatePointsForBall :: Ball -> Polygon 
generatePointsForBall (Ball r (V2 x y)) = 
  map (\t -> (x+r*cos (t), y+r*sin (t))) [0,0.2..(2*pi)]

また、多角形の型は次のように定める。

type Point = (Double, Double)
type Polygon = [Point]

点をレンダリングするプログラムは次のようになる。

renderPoint :: Point -> IO () 
renderPoint (x, y) = vertex $ Vertex2 (realToFrac x :: GLfloat) (realToFrac y :: GLfloat)


多角形をレンダリングする関数はrenderPrimitive Polygonである。多角形をレンダリングするときは、多角形の各点をレンダリングしたものをこれに与えればよいので、ボールb1は次の関数で描画される。

renderPrimitive Polygon $ mapM_ renderPoint $ generatePointsForBall b1

ここまでできたら、シミュレーションを表示してくれるrunNetworkに二つのボールをレンダリングする部分を組み込み、表示を可能にする。これにより、セッションごとに画面を作成し、アニメーションとしての動画が可能になる。

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を実際に呼び出し、上記のアニメーションを実際に動かしてくれるmainのプログラムを作成する。

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

simulationの関数は、二つのボールの動きを作成するがこれは次のようになる。

simulation :: HasTime t s => Wire s () IO a (Ball, Ball)
simulation = proc _ -> do
    b1 <- ball radius vInit1 pInit1 -< ()
    b2 <- ball radius vInit2 pInit2 -< ()
    returnA -< (b1, b2)

上記のプログラムで、radius, vInit, pInitはそれぞれ、ボールの半径、速度、開始場所である。

ここまでで、大枠はできたので、ここからはボールの動きを示すプログラムの作成に移る。

５．２　ボールの振舞い

これから説明する多くのプログラムは、Wireという型を用いて実現される。WireはNetwireを特徴づける関数で、時間を変数に有する。経過する時間の中で、現時点での振舞いを出力してくれる。Wireはs e m a bの型引数をとる。これらの中で、それぞれの時点での、aは入力であり、bが出力である。

最初に作成するプログラムは、ボールの位置を示すpositionである。ボールの位置は、開始場所を\(x_0\)、速度を\(v_0\)とすると、\(x = x_0 + \int v_0 dt \)で与えられるが、これをNetwireで表すと、

position :: (HasTime t s, Monad m) => (V2 Double) -> (V2 Double) -> Wire s () m (V2 Double) (V2 Double)  
position x0 v0 = integral x0 . pure v0

となる。positionがそれぞれの時点で受け付ける入力は、Wireの4番目の型引数(V2 Double)である。この入力はそれぞれの時点での速度を入力するために利用する。例えば、落下しているものの速度は変化するので、ここで与える。また、5番目の型引数(V2 Double)はそれぞれの時点での出力である。先ほどの入力を受けて、出力する。ここでの出力はその時点での位置である。この関数を用いるときは、アロー記法を用いて、p <- pasition x0 <- vのような形で書く。ここで、その時点での、pが出力、vが入力である。なお、上のプログラムでは、速度は変わらないので、pure v0で与えている。なお、衝突を入れると速度が変化するので、この部分も変更になる。

integralは、FRE.Netwire.Moveで提供されているライブラリ関数であるが、これは次のようになっている。

integral ::
    (Fractional a, HasTime t s)
    => a  -- 開始場所
    -> Wire s e m a a
integral x' =
    mkPure $ \ds dx ->
        let dt = realToFrac (dtime ds)
        in x' `seq` (Right x', integral (x' + dt*dx))

この関数は、時間間隔\(dt\)毎に積分の部分をx'+dx*dtで(dx配置を求めている場合であれば速度)計算する。一番最初に出力されるのは開始場所x0,次にx0+dx*dt,さらに(x0+dx*dt)+dx*d,(x0+dx*dt+dx)*d+dx*d...と出力される。出力している部分は、x' `seq` (Right x', integral (x' + dt*dx))であるが、a `seq` bは、aを計算した後でbを計算し、bを出力とするという意味なので、出力の部分で実際に出力されてくるのは、Right x'である。Right x'についての詳しい説明は省くが、x'が正しく出力されると理解しておけばよい。

ボールの位置が時間の間隔ごとに与えられるようになったので、現時点でのボールの状態を出力するための関数ballを定義する。

ball :: (HasTime t s) => Double -> (V2 Double) -> (V2 Double) -> Wire s () IO () Ball
ball r v0 p0 = proc _ -> do
    pos <- position v0 p0 -< undefined
    returnA -< makeBall pos
  where makeBall :: V2 Double -> Ball
        makeBall p = Ball r p

後で説明するが、この関数はボールの開始位置と速度を得て、現時点でのボールの状態を出力する。

５．３　ボールのデータ型を用意し実行する

ボールの状態を示すために、ボールの型を用意する。

data Ball = Ball 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

プログラムを実行してみる。ボールが二つ思った通りに動くことが確認できる。

所期の目的は達成したので、次の記事で衝突時の処理を加えることとする。

５．４　プログラム

今までのプログラムをまとめると次のようになっている。メインの部分のMain.hsは、次の通りである。

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

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 r (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
    b1 <- ball radius vInit1 pInit1 -< ()
    b2 <- ball radius vInit2 pInit2 -< ()
    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

ボールの動きを示す部分のBall.hsは、次の通りである。

{-# LANGUAGE Arrows #-}
module Ball (ball) where

import Prelude hiding ((.),)
import Control.Wire
import FRP.Netwire.Move
import Linear.V2
import Configure

position :: (HasTime t s, Monad m) => (V2 Double) -> (V2 Double) -> Wire s () m (V2 Double) (V2 Double)  
position vInit pInit = integral pInit . pure vInit 

ball :: (HasTime t s) => Double -> (V2 Double) -> (V2 Double) -> Wire s () IO () Ball
ball r v0 p0 = proc _ -> do
    pos <- position v0 p0 -< undefined
    returnA -< makeBall pos
  where makeBall :: V2 Double -> Ball
        makeBall p = Ball r p

システムの構成を定めている部分のConfigure.hsは次の通りである。

{-# LANGUAGE Arrows #-}
module Configure where

import Linear.V2

data Ball = Ball 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