ボールがうじゃうじゃ

画面内をボールが動き回るだけの、よくあるプログラムです。

module Main where

import Graphics.HGL

-- スクリーン情報
width::Int
width  = 320
height::Int
height = 240
widthF::Float
widthF  = 320.0
heightF::Float
heightF = 240.0

-- ボールオブジェクト
data BallObj = BallObj {
    x, y   :: Float,
    dx, dy :: Float
}

-- ボールから座標を取得
toPos::BallObj -> Point
toPos ball = (round $ x ball, round $ y ball)

-- 色定義
color = RGB 255 255 0

-- 描画関数を返す
drawball:: Point -> Graphic
drawball (x,y) =
    do withRGB color $ ellipse (x-10, y-10) (x+10, y+10)

-- 描画
draw::[BallObj] -> Graphic
draw balls =
    do mapM_ drawball $ map toPos balls

-- 移動
moveBall:: BallObj -> BallObj
moveBall ball =
    BallObj {
        x  = (x ball) + (dx ball),
        y  = (y ball) + (dy ball),
        dx = (dx ball),
        dy = (dy ball) }

-- 状態の更新
updateState::[BallObj] -> [BallObj]
updateState balls = (map boundBall (map moveBall balls))

-- 初速
speed0 = 0.5
-- ボール達
balls= [
    BallObj{dx=  speed0*4, dy=  speed0,   x=0,      y=0},
    BallObj{dx= -speed0,   dy=  speed0*4, x=widthF, y=0},
    BallObj{dx= -speed0*2, dy= -speed0*3, x=widthF, y=heightF},
    BallObj{dx=  speed0*3, dy= -speed0*2, x=0,      y=heightF} ]

-- 跳ね返り
boundBall::BallObj -> BallObj
boundBall ball =
    let
        px = x ball
        py = y ball
        vx = if px < -3 || px > widthF+3
                then -(dx ball) -- 反転
                else dx ball
        vy = if py < -3 || py > heightF+3
                then -(dy ball) -- 反転
                else dy ball
    in
        BallObj {
            x  = px,
            y  = py,
            dx = vx,
            dy = vy }

-- ゲームループ
-- ウィドウ -> ボールオブジェクト
loopGame::Window -> [BallObj] -> IO()
loopGame w balls =
    do e <- maybeGetWindowEvent w
       -- イベント処理
       case e of
        Just(Char {char=c}) ->
            -- ESCキー
            if c == '\ESC'
                then closeWindow w
                else loopGame w balls
        Nothing -> do
            -- 描画処理
            setGraphic w $ do
                draw balls
            getWindowTick w
            loopGame w (updateState balls)
        _ -> loopGame w balls

-- エントリポイント
main::IO()
main = runGraphics $ do
    w <- openWindowEx "test" Nothing (width, height) DoubleBuffered (Just 33)
    -- ループ開始
    loopGame w balls