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

bitterharvest’s diary

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

物理的なモデルに基づいてゲームを開発する:落下するボールをバウンドさせる

1.FRPを本格的に

今回のプログラムを実行すると次のように動きます。

今まで書いたプログラムでは、落下する物体は地面をも突き破ってどんどんと地下のほうに落ちていく。これでは非現実的なので地表面で跳ね返るようにする。即ち、\(y=0\)の時、\(v_t\)は\(-v_t\)に代わるものとする。

FRPでは、このような現象をswitchで表すことができる。switchの概念図は以下のとおりである。
f:id:bitterharvest:20141019105504p:plain
switchの型シグネチャは次のようになっている。

switch :: SF in (out, Event t) -> (t -> SF in out) -> SF in out

これは、入力はシグナル関数SF in (out, Event t)と関数(t -> SF in out)で、出力がシグナル関数SF in outである。入力として与えられるシグナル関数では、inとoutとイベントtが与えられる。また、入力として与えられる関数は、tを入力とし、シグナル関数SF in outを出力している。即ち、この関数からは、イベントtが起きた結果として得られるシグナル関数を得ることができる。そして、今得られた関数がswitchの出力となる。簡単に言うと、イベントtが起きた後のシグナル関数を返すことになる。

これまで、FRPでの関数の結合については触れてこなかったが、FRPインプリメントしたYampaでは次のようになっている。
f:id:bitterharvest:20141019114606p:plain

いくつかを型シグネチャで示すと次のようになる。

  arr   :: (a -> b) -> SF a b
  (<<<) :: SF b c -> SF a b -> SF a c
  (>>>) :: SF a b -> SF b c -> SF a c
  (^<<) :: (b -> c) -> SF a b -> SF a c 

また、Yampaではアロー記法(Arrow Syntax)を用いてプログラムを書くことができる。糖衣構文だが、その形式は次のようになっている。

  proc pat -> do
    pat1 <- sfexp1 -< exp1
    pat2 <- sfexp2 -< exp2
    ......................
    patn <- sfexpn -< expn
    returnA -< exp

ここで、procはラムダ式での\(\lambda\)に類似している。patはシグナル変数に束縛されるパターンである。それはシグナル値のexpと照合される。sfexpはシグナル関数である。

2.糖衣構文で記述する

fallingBallを高さに加えて速度を初期値として与え、それをアロー記法で記述すると次のようになる。

fallingBall :: Pos -> Vel -> SF () (Pos, Vel)
fallingBall y0 v0 = proc input -> do
  v <- integral >>^ (+ v0) -< -9.81
  y <- integral >>^ (+ y0) -< v
  returnA -< (y, v)

但し、アロー記法を用いるときはプログラムの最初に次の宣言を加える必要がある。

{-# LANGUAGE Arrows #-}

3.ボールを跳ね返らせる

ボールが地表面で跳ね返るようにする。まず、跳ね返るボールを表すためのシグナル関数をbouncingBallとする。そこで、mainSFのfallingBallをbouningBallで書き換える。

mainSF = (bouncingBall 10.0 0) >>^ (\ (pos, vel)-> putStrLn ("pos: " ++ show pos ++ ", vel: " ++ show vel) >> draw pos)

次にシグナル関数bouncingを実装する。これは、次のようにする。前のサンプル時点での高さと速度を与え、次のサンプル時点での高さと速度を求める。もし、高さが負の値に変化したら、速度の符号をマイナスにする。これを記述すると、Jekorの動画では次のようになっている。

bouncingBall :: Pos -> Vel -> SF () (Pos, Vel)
bouncingBall y0 v0 = switch (bb y0 v0) (\ (pos, vel) -> bouncingBall pos (-vel))
  where bb y0' v0' = proc input -> do
                      (pos, vel) <- fallingBall y0' v0' -< input
                      event <- edge -< pos <= 0
                      returnA -< ((pos, vel), event `tag` (pos, vel))

4.現実的に

地表面の反発係数が1ということはなかなか起こりえないので、0.6とするとプログラムは次のようになる。

bouncingBall :: Pos -> Vel -> SF () (Pos, Vel)
bouncingBall y0 v0 = switch (bb y0 v0) (\ (pos, vel) -> bouncingBall pos ((-vel) * 0.6))
  where bb y0' v0' = proc input -> do
                      (pos, vel) <- fallingBall y0' v0' -< input
                      event <- edge -< pos <= 0
                      returnA -< ((pos, vel), event `tag` (pos, vel))

さらに地表面に近いところでは、高さも速度も強制的に0にすると次のようになる。

bouncingBall :: Pos -> Vel -> SF () (Pos, Vel)
bouncingBall y0 v0 = switch (bb y0 v0) (\ (pos, vel) -> if abs vel <= 1 then constant (0,0) else bouncingBall pos ((-vel) * 0.6))
  where bb y0' v0' = proc input -> do
                      (pos, vel) <- fallingBall y0' v0' -< input
                      event <- edge -< pos <= 0
                      returnA -< ((pos, vel), event `tag` (pos, vel))

最後にプログラムの全体を示す。

{-# LANGUAGE Arrows #-}
import FRP.Yampa
import Control.Concurrent
import FRP.Yampa.Vector3
import FRP.Yampa.Utilities
import Unsafe.Coerce
import Data.IORef

import Graphics.UI.GLUT hiding (Level,Vector3(..),normalize)
import qualified Graphics.UI.GLUT as G(Vector3(..))


type Pos = Double
type Vel = Double
type R = GLdouble


fallingBall :: Pos -> Vel -> SF () (Pos, Vel)
fallingBall y0 v0 = proc input -> do
  v <- integral >>^ (+ v0) -< -9.81
  y <- integral >>^ (+ y0) -< v
  returnA -< (y, v)

bouncingBall :: Pos -> Vel -> SF () (Pos, Vel)
bouncingBall y0 v0 = switch (bb y0 v0) (\ (pos, vel) -> if abs vel <= 1 then constant (0,0) else bouncingBall pos ((-vel) * 0.6))
  where bb y0' v0' = proc input -> do
                      (pos, vel) <- fallingBall y0' v0' -< input
                      event <- edge -< pos <= 0
                      returnA -< ((pos, vel), event `tag` (pos, vel))

initGL :: IO ()
initGL = do
    getArgsAndInitialize
    createWindow "Bounce"
    initialDisplayMode $= [ WithDepthBuffer, DoubleBuffered ]
    depthFunc          $= Just Less
    clearColor         $= Color4 0 0 0 0
    light (Light 0)    $= Enabled
    lighting           $= Enabled
    lightModelAmbient  $= Color4 0.5 0.5 0.5 1
    diffuse (Light 0)  $= Color4 1 1 1 1
    blend              $= Enabled
    blendFunc          $= (SrcAlpha, OneMinusSrcAlpha)
    colorMaterial      $= Just (FrontAndBack, AmbientAndDiffuse)
    reshapeCallback    $= Just resizeScene
    return ()

resizeScene :: Size -> IO ()
resizeScene (Size w 0) = resizeScene (Size w 1) -- prevent divide by zero
resizeScene s@(Size width height) = do
  -- putStrLn "resizeScene"
  viewport   $= (Position 0 0, s)
  matrixMode $= Projection
  loadIdentity
  perspective 45 (w2/h2) 1 1000
  matrixMode $= Modelview 0
 where
   w2 = half width
   h2 = half height
   half z = realToFrac z / 2

draw :: Pos -> IO ()
draw pos = do
    clear [ ColorBuffer, DepthBuffer ]
    loadIdentity
    renderPlayer $ vector3 2 (unsafeCoerce pos) (-30)
    flush
    where size2 :: R
          size2 = (fromInteger $ 6)/2
          green  = Color4 0.8 1.0 0.7 0.9 :: Color4 R
          greenG = Color4 0.8 1.0 0.7 1.0 :: Color4 R
          red    = Color4 1.0 0.7 0.8 1.0 :: Color4 R
          renderShapeAt s p = preservingMatrix $ do
            translate $ G.Vector3 (0.5 - size2 + vector3X p)
                                  (0.5 - size2 + vector3Y p)
                                  (0.5 - size2 + vector3Z p)
            renderObject Solid s
          renderObstacle = (color green >>) . (renderShapeAt $ Cube 1)
          renderPlayer   = (color red >>) . (renderShapeAt $ Sphere' 0.5 20 20)
          renderGoal     =
            (color greenG >>) . (renderShapeAt $ Sphere' 0.5 20 20)

mainSF = (bouncingBall 10.0 0) >>^ (\ (pos, vel)-> putStrLn ("pos: " ++ show pos ++ ", vel: " ++ show vel) >> draw pos)

-- | Main, initializes Yampa and sets up reactimation loop
main :: IO ()
main = do
    oldTime <- newIORef (0 :: Int)
    rh <- reactInit (initGL) (\_ _ b -> b >> return False) 
                    mainSF
    displayCallback $= return ()
    idleCallback $= Just (idle  oldTime rh)
    oldTime' <- get elapsedTime
    writeIORef oldTime oldTime' 
    mainLoop

-- | Reactimation iteration, supplying the input
idle :: IORef Int -> ReactHandle () (IO ()) -> IO ()
idle oldTime rh = do
    newTime'  <- get elapsedTime
    oldTime'  <- get oldTime
    let dt = (fromIntegral $ newTime' - oldTime')/1000
    react rh (dt, Nothing)
    writeIORef oldTime newTime'
    return ()