ゲームをつくろう その4 オブジェクトの移動

IORefを使って値の保存が出来ることがわかった。なので、ゲームっぽくオブジェクトを移動させてみる。
プログラム的にはライフゲームのものとくらべて特に新しいものはないなぁ。

-- 籠の中のボール
import Graphics.UI.GLUT
import Graphics.Rendering.OpenGL.GLU
import System
import Data.IORef

timerInterval = 16

type Point = (GLdouble, GLdouble)
type Vec2 = (GLdouble, GLdouble)

data GameObject = Ball{pos::Point, velocity::Vec2} |
                  Box {center::Point, width::GLdouble, height::GLdouble}

updateBall :: GameObject -> GameObject
updateBall (Ball{pos=p, velocity=vel}) = 
    let (x, y) = p
        (vx, vy) = vel
    in Ball (x + vx, y + vy) (vx, vy)

detect :: GameObject -> GameObject -> GameObject
detect (Ball{pos=p, velocity=vel}) (Box{center=cn, width=w, height=h}) = 
    let (x, y) = p
        (vx, vy) = vel
        (wx, wy) = cn
        nx = x + vx
        ny = y + vy
        nvx = if ((wx - (w * 0.5)) < nx) && (nx < (wx + (w * 0.5)))
              then vx
              else vx * (-1.0)
        nvy = if ((wy - (h * 0.5)) < ny) && (ny < (wy + (h * 0.5)))
              then vy
              else vy * (-1.0)
    in Ball (x, y) (nvx, nvy)
      
detectBallWithBox :: GameObject -> [GameObject] -> GameObject
detectBallWithBox Ball{pos=p, velocity=vel} [] = Ball p vel
detectBallWithBox b gs = foldl detect b gs

update :: [GameObject] -> [GameObject]
update gs = 
    let ball = head $ filter (\o -> case o of 
                                      Ball{} -> True
                                      _ -> False) gs
        box = filter (\o -> case o of
                                Box{} -> True
                                _ -> False) gs
    in [updateBall $ detectBallWithBox ball box] ++ box


renderGameObject :: GameObject -> IO()
renderGameObject (Ball{pos=p}) = do
  let (x, y) = p
  preservingMatrix $ do
    translate (Vector3 x y 0 :: Vector3 GLdouble)
    renderObject Solid (Sphere' 0.5 10 10)
renderGameObject (Box{center=cn, width=w, height=h}) = do
  let (x, y) = cn
  renderPrimitive LineStrip $ mapM_ vertex [
                Vertex3 (x + w/2.0) (y + h/2.0) 0.0,
                Vertex3 (x + w/2.0) (y - h/2.0) 0.0,
                Vertex3 (x - w/2.0) (y - h/2.0) 0.0,
                Vertex3 (x - w/2.0) (y + h/2.0) 0.0,
                Vertex3 (x + w/2.0) (y + h/2.0) (0.0 :: GLdouble) ]

main :: IO()
main = do
  gameObjects <- newIORef [ Ball (0.0, 0.0) (0.2, 0.2),
                            Box (0.0, 0.0) 30 40 ]

  initialDisplayMode $= [RGBAMode, DoubleBuffered, WithDepthBuffer]
  initialWindowSize $= Size 640 480
  getArgsAndInitialize
  -- 窓の生成
  createWindow "Reflect Ball"
  -- 描画コールバックの登録
  keyboardMouseCallback $= Just keyboardProc
  displayCallback $= (display gameObjects)
  -- ウィンドウサイズが変更された時に呼ぶコールバック関数の指定
  reshapeCallback $= Just reshape
  -- タイマー関数の登録
  addTimerCallback timerInterval $ timer (display gameObjects)
  -- GLUTのメインループへ
  mainLoop

display gameObjects = do
  modifyIORef gameObjects update
  -- 背景を黒で塗り潰し
  clearColor $= Color4 1.0 1.0 1.0 0.0
  clear [ColorBuffer, DepthBuffer] 
  -- 単位行列の読み込み
  loadIdentity
  -- 表示
  gs <- readIORef gameObjects
  mapM_ renderGameObject gs
  swapBuffers

timer act = do
  act
  addTimerCallback timerInterval $ timer act

reshape size@(Size w h) = do
  viewport $= (Position 0 0, size)
  matrixMode $= Projection
  loadIdentity
  -- fov アスペクト比 ニアクリップ ファークリップ
  perspective 80 (fromIntegral w / fromIntegral h) 0.1 200.0
  -- 視点 注視点 カメラの上方向
  lookAt (Vertex3 0.0 0.0 30.0) (Vertex3 0.0 0.0 0.0) (Vector3 0.0 1.0 0.0)
  matrixMode $= Modelview 0

  -- ライト設定
  lighting $= Enabled
  -- ディフューズ
  position (Light 0) $= Vertex4 0.0 (-100.0) 100.0 1.0
  diffuse (Light 0) $= Color4 0.0 0.0 1.0 1.0
  light (Light 0) $= Enabled
  materialDiffuse FrontAndBack $= Color4 1.0 1.0 1.0 1.0

  -- これをしないとDepthバッファが有効にならない
  depthFunc $= Just Less

keyboardProc ch state _ _
    | ch     == Char 'q'              = exitWith ExitSuccess        --qが押されたら終了
    | otherwise                       = return ()

箱のなかでボールが反射するだけ。