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