Netwireでゲームを作成する（１２）

１５．ラケットでピンポン玉を跳ね返す問題の解

Netwireの紹介で、最初に与えた問題は次のようになっていた。

問題：Netwireで次のゲームを実現しなさい。

仕様：ピンポン玉が空中に投げ出されたとする。この時、ピンポン玉が落ちないように、水平に移動するラケットで反射させなさい。また、左右には壁があるものとし、ピンポン玉は壁にぶつかった時、跳ね返るものとする。なお、ピンポン玉はニュートン力学に従って運動するものとし、壁、および、ラケットの反射係数は1としなさい。

このゲームは図に示すと以下のようになる。

この手の問題は、Agileによるソフトウェア開発の手法をとるならば、一番難しそうな部分から解決するのが一番よい。これさえ解決できれば、もう解決したようなものである。

この問題で登場してくるのは、ラケットとピンオン玉である。ラケットは水平にしか動かないので、それほど難しそうな問題ではないので、ピンポン玉の方から解決することとする。

ピンポン玉は、ニュートン力学に従って落下運動をする。従って、垂直方向（y軸）に沿って重力の影響を受ける。水平方向（x軸）は、最初に与えられた速度を維持する。また、ピンポン玉は壁面に当たった時は水平方向の速度が反転し、ラケットに当たった時は垂直方向の速度が反転する。

上記の点を考慮して、前回の記事の四角いボックスの例を参考にしながらプログラムを作成すると以下のようになる。下のプログラムでballがピンポン玉の動きである。

import Control.Wire
import Linear.V2

import Utilities
import Configure
import Racket()

gravity :: (HasTime t s, Monad m) => (V2 Double) -> Wire s () m a (V2 Double) 
gravity g = pure g

velocity ::  (HasTime t s, Monad m) => (V2 Double) -> Wire s () m (V2 Double, V2 Bool) (V2 Double)
velocity v = integralWith' bounce v
             where bounce (V2 bx by) v'@(V2 x y) 
                     | bx        = V2 (-x) y
                     | by        = V2 x    (-y)
                     | otherwise = v'

position :: (HasTime t s, Monad m) => (V2 Double) -> Wire s () m (V2 Double, Racket) (V2 Double, V2 Bool)  
position p = integralWith'' clamp p    
 where    
  clamp (Racket (V2 x1 y1) (V2 x2 y2)) p'@(V2 x y) 
    | x < - wall && y > y1 = 
        ((V2 (- wall * 2 - x) y), 
          V2 True  False)
    | x >   wall && y > y1 = 
        ((V2 (  wall * 2 - x) y), 
          V2 True  False)  
    | y > y1 && y < (y1 + y2)  && x > x1 && x < x1 + x2 =
        ((V2 x ( (y1 + y2)   * 2 - y)), 
          V2 False True ) 
    | otherwise = (p', V2 False False)

dynamics :: (HasTime t s) => (V2 Double) -> (V2 Double) -> (V2 Double) -> Wire s () IO Racket (V2 Double) 
dynamics g0 v0 p0 = proc racket -> do
  rec g <- gravity g0  -< undefined
      v <- velocity v0 -< (g, b)
      (p, b) <- position p0 -< (v, racket)
  returnA -< p

ball :: (HasTime t s) => Double -> (V2 Double) -> (V2 Double) -> (V2 Double) -> Wire s () IO Racket Ball
ball r g0 v0 p0 = proc racket -> do
    pos <- dynamics g0 v0 p0 -< racket
    returnA -< makeBall pos
  where makeBall :: V2 Double -> Ball
        makeBall p = Ball p r

なお、上記のプログラムで用いた積分関係の関数は次のようになる。

{-# LANGUAGE Arrows #-}
module Utilities (integral', integralWith', integralWith'') where

import Prelude hiding ((.),)
import Control.Wire
import FRP.Netwire
import Linear.V2

import Configure

integral' :: (HasTime t s) => V2 Double -> Wire s e m (V2 Double) (V2 Double)
integral' x' =
    mkPure $ \ds dx ->
        let dt = realToFrac (dtime ds)
        in x' `seq` (Right x', integral' (x' + dt*dx))

integralWith' :: (HasTime t s) => (V2 Bool -> V2 Double -> V2 Double) -> V2 Double -> Wire s e m (V2 Double, V2 Bool) (V2 Double)
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)

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

次はラケットのプログラムであるが、これは等速運動の時の四角いボックスと同様なので、次のようになる。

{-# LANGUAGE Arrows #-}

module Racket (racket) where

import Graphics.Rendering.OpenGL 
import Graphics.UI.GLFW 
import Prelude hiding ((.))
import Control.Wire 
import FRP.Netwire 
import Data.IORef 
import Linear.V2

import Configure

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

velocity' :: Wire s () IO a (V2 Double) 
velocity' = 
     pure (V2   0  0) .
      isKeyDown (CharKey 'A') . 
      isKeyDown (CharKey 'D') 
 <|> pure (V2 (-5) 0) . 
      isKeyDown (CharKey 'A') 
 <|> pure (V2   5  0) . 
      isKeyDown (CharKey 'D') 
 <|> pure (V2   0  0) 

event :: (HasTime t s) => (V2 Double) -> Wire s () IO a (V2 Double) 
event p0 = integral p0 . velocity'

racket :: (HasTime t s) => (V2 Double) -> (V2 Double) -> Wire s () IO a Racket
racket p0 wh = proc _ -> do
    p <- event p0 -< undefined
    returnA -< makeRacket p wh
  where makeRacket :: V2 Double -> 
         V2 Double -> Racket
        makeRacket p' wh'= Racket p' wh'

プログラムを実行するに先立って、壁面の位置、ラケットの大きさ、ピンポン玉の半径など必要な値を与える。

{-# LANGUAGE Arrows #-}
module Configure where

import Linear.V2

wall :: Double
wall  = 50

ground :: Double
ground = 0

data Racket = Racket (V2 Double) (V2 Double)  
              deriving (Eq, Show, Read)

corner :: V2 Double
corner = V2 0 0

boundary  :: V2 Double
boundary = V2 50 0.1

data Ball = Ball (V2 Double) Double  deriving (Eq, Show, Read)

pInit :: V2 Double
pInit = V2 0 100

gInit :: V2 Double
gInit = V2 0 9.8

vInit :: V2 Double
vInit = V2 10 0

radius :: Double
radius = 0.1

次のプログラムで、取り敢えず動いているかどうかを数値を出力させて確認する。

{-# LANGUAGE Arrows #-}
module Main where

import Prelude hiding ((.),)
import Control.Wire
import Control.Monad.IO.Class

import Ball
import Racket
import Configure

game :: HasTime t s => Wire s () IO a (Ball, Racket)
game = proc _ -> do
    r <- racket corner boundary   -< ()
    b <- ball radius gInit vInit pInit -< r
    returnA -< (b, r)

main :: IO () 
main = testWireM liftIO clockSession_ game

プログラムを実行するとボールとラケットの位置が出力される。

*Main> main

(Ball (V2 0.0 100.0) 0.1,Racket (V2 0.0 0.0) (V2 50.0 0.1))[K
(Ball (V2 0.0 100.0) 0.1,Racket (V2 0.0 0.0) (V2 50.0 0.1))[K
(Ball (V2 0.0 100.0) 0.1,Racket (V2 0.0 0.0) (V2 50.0 0.1))[K
(Ball (V2 0.0 100.0) 0.1,Racket (V2 0.0 0.0) (V2 50.0 0.1))[K
(Ball (V2 0.0 100.0) 0.1,Racket (V2 0.0 0.0) (V2 50.0 0.1))[K
(Ball (V2 0.0 100.0) 0.1,Racket (V2 0.0 0.0) (V2 50.0 0.1))[K

プログラムが正しく動いているらしいので、グラフィックスの部分を加えて完成させれば、めでたし、めでたしとなる。