物理的なモデルに基づいてゲームを開発する：ボールを投げる

１．落下するボールのプログラムを応用する

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

落下するボールのプログラムができれば、シューティングゲームなど幅広い分野に応用することができる。ここでは、ボールを投げたときの軌跡を求める。

今、ボールを\(x\)方向、\(y\)方向の速度成分が\(v_{x_0}\),\(v_{y_0}\)となるようにで投げたとする。即ち、角度が\(\theta =tan^{-1} \frac{v_{y_0}}{v_{x_0}}\)で速度が\(\sqrt{v_{x_0}^2 + v_{y_0}^2}\)でボールを投げたとする。この時の軌跡は、
\begin{eqnarray}
v_x & = & v_{x_0} \\
x_t & = & x_0 + \int_0^t v_x dt \\
v_{y_t} & = & v_{y_0} - \int_0^t g dt \\
y_t & = & y_0 + \int_0^t v_{y_t} dt
\end{eqnarray}
となる。なお、\(x_0\),\(y_0\)は投げた地点である。

１．ボールを投げたときの軌跡

上記の式をプログラムにすると次のようになる。

{-# 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 -> Pos -> Vel -> Vel -> SF () (Pos, Pos, Vel, Vel)
fallingBall x0 y0 vx0 vy0 = proc input -> do
  x <- integral >>^ (+ x0) -< vx0
  vy <- integral >>^ (+ vy0) -< -9.81
  y <- integral >>^ (+ y0) -< vy
  returnA -< (x, y, vx0, vy)

bouncingBall :: Pos -> Pos -> Vel -> Vel -> SF () (Pos, Pos, Vel, Vel)
bouncingBall x0 y0 vx0 xy0 = switch (bb x0 y0 vx0 xy0) (\ (posx, posy, velx, vely) -> if abs vely <= 1 then constant (posx, 0, 0, 0) else bouncingBall posx posy velx ((-vely) * 0.6))
  where bb x0' y0' vx0' xy0' = proc input -> do
                                 (posx, posy, velx, vely) <- fallingBall x0' y0' vx0' xy0' -< input
                                 event <- edge -< posy <= 0
                                 returnA -< ((posx, posy, velx, vely), event `tag` (posx, posy, velx, vely))

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 -> Pos -> IO ()
draw posx posy = do
    clear [ ColorBuffer, DepthBuffer ]
    loadIdentity
    renderPlayer $ vector3 (unsafeCoerce posx) (unsafeCoerce posy) (-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 (-8) 0 4 10) >>^ (\ (posx, posy, velx, vely) -> putStrLn ("pos: " ++ show posx ++ ", " ++ show posy ++ ", vel: " ++ show velx ++ ", " ++ show vely) >> draw posx posy)

-- | 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 ()