１．FRPを本格的に
今回のプログラムを実行すると次のように動きます。
今まで書いたプログラムでは、落下する物体は地面をも突き破ってどんどんと地下のほうに落ちていく。これでは非現実的なので地表面で跳ね返るようにする。即ち、\(y=0\)の時、\(v_t\)は\(-v_t\)に代わるものとする。
FRPでは、このような現象をswitchで表すことができる。switchの概念図は以下のとおりである。
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では次のようになっている。
いくつかを型シグネチャで示すと次のようになる。
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はシグナル関数である。
２．糖衣構文で記述する
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 #-}
３．ボールを跳ね返らせる
ボールが地表面で跳ね返るようにする。まず、跳ね返るボールを表すためのシグナル関数を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))
４．現実的に
地表面の反発係数が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 ()
