bitterharvest’s diary

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

Netwireでゲームを作成する(11)

14.壁面で跳ね返す

前回の記事の四角いボックスは、キーが押された時、x軸に沿って等速度で左あるいは右に移動した。しかし、側面に壁がないため、いくらでも左あるいは右に進むことができた。この単純なゲームを、もう少し現実的なゲームにするため、両脇に壁を設け、四角いボックスが壁面で跳ね返るようにする。また、キーが押されたときは、速度ではなく、加速度を与えて、スピード感を持たせる。

キーA,Dが押された時、それぞれ、左、右方向に加速度を与えるプログラムは、前回の速度を与えたプログラムをそのまま利用して次のようにする。

acceleration :: (Monoid e) => Wire s e IO a Double
acceleration =  pure ( 0)   . isKeyDown (CharKey 'A') . isKeyDown (CharKey 'D') 
            <|> pure (-0.5) . isKeyDown (CharKey 'A') 
            <|> pure ( 0.5) . isKeyDown (CharKey 'D') 
            <|> pure ( 0) 

ところで、今回のゲームは、両脇に壁面が設けられている。従って、速度を求めようとすると、壁面に当たったかどうかで判断しなければならない。もし、壁面に当たったのであれば、加速度の方向を逆にして速度を求める必要がある。

Netwireではこのような要求にこたえるために関数integralWithを用意している。integralWithの型シグネチャは次のようになっている。

integralWith :: (Fractional a, HasTime t s) => (w -> a -> a) -> a -> Wire s e m (a, w) a

integralWithは二つの入力を受け付ける。一つは関数(w -> a -> a)で、残りの一つはaである。このうち、後者は積分での定数項である。前者の(w -> a -> a)で、wはワールド値(world value)と呼ばれる。aの方は少し込み入っている。

一般に、定数項\(a_0\)をした時、\(a(t)\)の積分は次の式で求めることができる。
\begin{eqnarray}
a_0 + \int_0^s x(t) dt & = & \\
a_0 && + a(\frac{1}{s}) \times dt + a(\frac{2}{s}) \times dt + ... \\
&& + a(\frac{i}{s}) \times dt + a(\frac{i+1}{s}) \times dt + ... \\
&& + a(\frac{n}{s}) \times dt
\end{eqnarray}
ただし、\(dt = \frac{s}{n}\)
ここで、\(i\)番目までの項を加えたものを\(v_i\)とすると、\(i+1\)番目までの項を加えたものは\(v_i + a(\frac{i+1}{s}) \times dt \)で求めることができる。漸化式になるので、\(i\)が\(n\)になるまで求めればよい。

ところで、計算の途中で衝突が起きたとする。例えば、\(i+1\)の前で衝突が起きたとする。この時、速度が反対になるので、\(v_i\)を\(-v_i\)にする必要がある。

integralWithの定義を見ると次のようになっている。

integralWith ::
    (Fractional a, HasTime t s)
    => (w -> a -> a)  -- ^ Correction function.
    -> a              -- ^ Integration constant (aka start value).
    -> Wire s e m (a, w) a
integralWith correct = loop
    where
    loop x' =
        mkPure $ \ds (dx, w) ->
            let dt = realToFrac (dtime ds)
                x  = correct w (x' + dt*dx)
            in x' `seq` (Right x', loop x)

上の説明とは少し異なっていて、衝突が起きた場所を正確には反映されずに、最初の\(i=0\)から衝突があったものとしている(一つのセッションが微小であるとするとこのように仮定しても問題はない)。従って、衝突が起きた場合には、最初から速度の方向を逆転させて計算している。

aについて込み入った話をしたが、衝突があった場合には速度を反転させるということなので、プログラムは次のようになる。

integralWithを用いると、速度は次のように求めることができる。

velocity ::  (Monad m, HasTime t s, Monoid e) => Wire s e m (Double, Bool) Double
velocity = integralWith bounce 0
             where bounce c v 
                     | c         = -v
                     | otherwise = v

上のプログラムで、bounceが加速度aから、速度vを出力するプログラムである。bounceの入力の一つは先ほど出てきた速度\(v_i\)で、もう一つの入力は衝突の有無を知らせるcである。加速度aと衝突の有無cは、velocityの型シグネチャでの(Double, Bool)で入力されることが分かる。bounceは、衝突がなければ、この加速度aから速度vを得るが、衝突があるときはその速度vを反転させる。

次に、位置を示すプログラムは、次の位置を出力するとともに、その時、衝突したかどうかを教える必要がある。そこで、積分の関数integralを改造して、衝突したかどうかの情報も一緒に出力する関数integralWith'を用意する。これは次のようになる。

integralWith' :: (Fractional a, HasTime t s) => (a -> (a, o)) -> a -> Wire s e m a (a, o)
integralWith' correct = loop
  where
    loop x' =
        mkPure $ \ds dx ->
            let dt = realToFrac (dtime ds)
                (x,b)  = correct (x' + dt*dx)
            in x' `seq` (Right (x', b), loop x)

上記の型シグネチャで、最初の入力(a -> (a, o))が、衝突したかどうかを判定する関数である。この関数は、次の位置aと衝突が生じたかどうかの真理値を返す。二番目の入力aは定数項である。

左と右の壁面の(x軸上の)位置をlSide,rSideとすると、位置position'は次のようになる。下記のプログラムで、clampが壁面に衝突しているかどうかを判定している。また、衝突した場合には、衝突後の正しい位置を求めている。

position' :: (Monad m, HasTime t s) => Wire s e m Double (Double, Bool)  
position' = integralWith' clamp 0    
  where    
    clamp p | p < lSide = (lSide * 2 - p, True)
            | p > rSide = (rSide * 2 - p, True)    
            | otherwise = (p, False)

速度の関数は、加速度と位置の関数から値を受け取り、位置の関数は速度から値を受け取る。このため、相互に再帰的になっている。このような関数を実行するときは、これらが並行して動けるようにするためrecを用いる。そこで、bouncingという関数を用意して、次のように、acceletion, velocity, position'が並行で動けるようにした。

bouncing :: (HasTime t s) => Wire s () IO a Double 
bouncing = proc _ -> do
  rec a <- acceleration -< ()
      v <- velocity -< (a, c)
      (p, c) <- position' -< v
  returnA -< p

これでプログラムは完成である。後は、OpenGLで定められた枠組みの中に組み込むだけである。
実行の様子を示したのが以下のビデオである。

プログラム全体は次のようになる。

 {-# LANGUAGE Arrows #-} 
import Graphics.Rendering.OpenGL 
import Graphics.UI.GLFW 
import Data.IORef 
import Prelude hiding ((.)) 
import Control.Wire 
import FRP.Netwire 


isKeyDown :: (Enum k, Monoid e) => k -> Wire s e IO a e 
isKeyDown k = mkGen_ $ \_ -> do 
  input <- getKey k 
  return $ case input of 
    Press -> Right mempty
    Release -> Left mempty


acceleration :: (Monoid e) => Wire s e IO a Double
acceleration =  pure ( 0)   . isKeyDown (CharKey 'A') . isKeyDown (CharKey 'D') 
            <|> pure (-0.5) . isKeyDown (CharKey 'A') 
            <|> pure ( 0.5) . isKeyDown (CharKey 'D') 
            <|> pure ( 0) 


velocity ::  (Monad m, HasTime t s, Monoid e) => Wire s e m (Double, Bool) Double
velocity = integralWith bounce 0
             where bounce c v 
                     | c         = -v
                     | otherwise = v

integralWith' :: (Fractional a, HasTime t s) => (a -> (a, o)) -> a -> Wire s e m a (a, o)
integralWith' correct = loop
  where
    loop x' =
        mkPure $ \ds dx ->
            let dt = realToFrac (dtime ds)
                (x,b)  = correct (x' + dt*dx)
            in x' `seq` (Right (x', b), loop x)

lSide = -0.8
rSide = 0.8

position' :: (Monad m, HasTime t s) => Wire s e m Double (Double, Bool)  
position' = integralWith' clamp 0    
  where    
    clamp p | p < lSide = (lSide * 2 - p, True)
            | p > rSide = (rSide * 2 - p, True)    
            | otherwise = (p, False)

bouncing :: (HasTime t s) => Wire s () IO a Double 
bouncing = proc _ -> do
  rec a <- acceleration -< ()
      v <- velocity -< (a, c)
      (p, c) <- position' -< v
  returnA -< p
 
s :: Double 
s = 0.05 
y :: Double 
y = 0.0

renderPoint :: (Double, Double) -> IO () 
renderPoint (x, y) = vertex $ Vertex2 (realToFrac x :: GLfloat) (realToFrac y :: GLfloat)

generatePoints :: Double -> Double -> Double -> [(Double, Double)] 
generatePoints x y s = 
  [ (x - s, y - s) 
  , (x + s, y - s) 
  , (x + s, y + s) 
  , (x - s, y + s) ] 


runNetwork :: (HasTime t s) => IORef Bool -> Session IO s -> Wire s e IO a Double -> IO () 
runNetwork closedRef session wire = do 
  pollEvents 
  closed <- readIORef closedRef 
  if closed 
    then return () 
    else do
      (st , session') <- stepSession session 
      (wt', wire' ) <- stepWire wire st $ Right undefined 
      case wt' of 
        Left _ -> return () 
        Right x -> do 
          clear [ColorBuffer] 
          renderPrimitive Quads $ 
            mapM_ renderPoint $ generatePoints x y s 
          swapBuffers 
          runNetwork closedRef session' wire' 



main :: IO () 
main = do
  initialize 
  openWindow (Size 1024 512) [DisplayRGBBits 8 8 8, DisplayAlphaBits 8, DisplayDepthBits 24] Window
 
  closedRef <- newIORef False 
  windowCloseCallback $= do 
    writeIORef closedRef True 
    return True 
  runNetwork closedRef clockSession_ bouncing
  closeWindow