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

bitterharvest’s diary

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

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

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

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

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

今、ボールを\(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\)は投げた地点である。

1.ボールを投げたときの軌跡

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

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