シューティングゲーム手習い：投石プログラムを整理する

１．投石ゲーム

原始的だが、投石で鳥を落下させるゲームの設計を目指して、基本的な部分を作成する。まずは、前回の記事で作成したプログラムを整理する。
一つは、位置、速度、加速度はそれぞれ\(x\)方向と\(y\)方向を別々に記述していたが、プログラムを見やすくするために、タプルを用いて対で表すこととする。
二つ目はシグナル関数の実行部分をmainSFを用いて一括りで表していた部分の修正である。この部分を入力・検出、処理、出力に分け、それぞれをシグナル関数とし、直列に実行するようにする。これにより、細かな処理が可能になる。

整理したプログラムの全体を示す。前回のプログラムと比較して欲しい。

{-# 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, Double)
type Vel = (Double, Double)
type R = GLdouble

fallingBall :: Pos -> Vel -> SF () (Pos, Vel)
fallingBall pos0 vel0 = proc input -> do
  vel <- (vel0 ^+^) ^<< integral -< (0, -9.81)
  pos <- (pos0 ^+^) ^<< integral -< vel
  returnA -< (pos, vel)

bouncingBall :: Pos -> Vel -> SF () (Pos, Vel)
bouncingBall pos0 vel0 = switch (bb pos0 vel0) (\ (pos, vel) -> if abs (snd vel) <= 1 then constant ((fst pos, 0), (0, 0)) else bouncingBall pos ((fst vel), (- (snd vel)) * 0.6))
  where bb pos0' vel0' = proc input -> do
          (pos, vel) <- fallingBall pos0' vel0' -< input
          event <- edge -< snd 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) 
resizeScene s@(Size width height) = do
  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

clearAndRender :: (Pos, Vel) -> IO ()
clearAndRender (pos, vel) = do
    clear [ ColorBuffer, DepthBuffer ]
    loadIdentity
    renderPlayer $ vector3 (unsafeCoerce (fst pos)) (unsafeCoerce (snd 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)

main :: IO ()
main = do
    oldTime <- newIORef (0 :: Int)
    rh <- reactInit (initGL >> return NoEvent) (\_ _ b -> b >> return False) simulate
    displayCallback $= return ()
    idleCallback $= Just (idle  oldTime rh)
    oldTime' <- get elapsedTime
    writeIORef oldTime oldTime' 
    mainLoop

idle :: IORef Int -> ReactHandle (Event ()) (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 ()

simulate :: SF (Event ()) (IO ())
simulate = discardInputs >>> update >>> draw

discardInputs :: SF (Event ()) ()
discardInputs = arr $ const ()

update :: SF () (Pos, Vel)
update = proc () -> do
  (pos, vel) <- bouncingBall ((-8), 0) (4, 10) -< ()
  returnA  -<  (pos, vel)


draw :: SF (Pos, Vel) (IO ())
draw = arr clearAndRender

上記のプログラムで、mainSFはsimulateになっている。simulateは、simulate = discardInputs >>> update >>> drawの三つのシグナル関数から成り立っている。シグナル関数は、マウスやキーボードの信号を検知するが、ここでは何もしないものとする。updateの部分が処理の部分で、前のサンプリング時点から現在のサンプリング時点までの変化を反映させる。上記のプログラムでは、投げられた石の現在の位置を計算する。drawは出力で、現時点での石の位置をスクリーン上に描く。drawは関数clearAndRenderをシグナル関数にして描画を行う。