HPong-0.1: HPong.hs

{-# LANGUAGE TemplateHaskell #-}

import Control.Monad
import Data.Accessor
import Data.Accessor.Basic (T)
import Data.Accessor.Template
import Data.IORef
import Graphics.Rendering.OpenGL
import Graphics.UI.GLFW

data Game = Game { scorePlayer_ :: Int, scoreCPU_ :: Int,
                   playerY_ :: Double, cpuY_ :: Double,
                   ballX_ :: Double, ballY_ :: Double,
                   ballVX_ :: Double, ballVY_ :: Double }
$( deriveAccessors ''Game )

windowW, windowH, paddleW, paddleH, paddleX, ballSize, ballSpeed :: Double
(windowW, windowH) = (640, 400)
(paddleW, paddleH, paddleX) = (20, 100, 50)
(ballSize, ballSpeed) = (20, 2)

main :: IO ()
main = do
    let newGame = resetBall $ Game 0 0 200 200 0 0 1 1
    game <- newIORef newGame
    initGL (floor $ windowW) (floor $ windowH)
    get time >>= newIORef >>= mainLoop game
    closeWindow
    terminate

initGL :: GLsizei -> GLsizei -> IO ()
initGL w h = do
    initialize
    openWindow (Size w h) [DisplayAlphaBits 8] Window
    windowTitle $= "HPong"
    lineSmooth  $= Enabled
    blend       $= Enabled
    blendFunc   $= (SrcAlpha, OneMinusSrcAlpha)
    windowSizeCallback $= windowResize

windowResize :: Size -> IO ()
windowResize s@(Size w h) = do
    viewport   $= (Position 0 0, s)
    matrixMode $= Projection
    loadIdentity
    ortho2D 0 (realToFrac w) 0 (realToFrac h)

mainLoop :: IORef Game -> IORef Double -> IO ()
mainLoop game lastFrame = do
    dt <- liftM2 (-) (get time) (get lastFrame)
    get time >>= writeIORef lastFrame
    
    handleInput (dt * 100) game
    game $~ update (dt * 100)
    render game
    displayFPS dt
    swapBuffers
    unless `pressed` ESC $ do
        sleep 0.001
        windowOpenStatus <- get $ windowParam Opened
        unless (windowOpenStatus == 0) $ mainLoop game lastFrame

handleInput :: Double -> IORef Game -> IO ()
handleInput dt game = do
    when `pressed` UP   $ game $~ movePaddle playerY dt
    when `pressed` DOWN $ game $~ movePaddle playerY (-dt)

movePaddle :: T r Double -> Double -> r -> r
movePaddle p d = p ^: min (windowH - paddleH / 2) . max (paddleH / 2) . (+ d)

update :: Double -> Game -> Game
update dt g = moveAI dt $ checkScore $ bounce $
              ballX ^: (+ g ^. ballVX * ballSpeed * dt) $
              ballY ^: (+ g ^. ballVY * ballSpeed * dt) $ g

moveAI :: Double -> Game -> Game
moveAI dt g = movePaddle cpuY (signum (g ^. ballY - g ^. cpuY) * dt) g

bounce :: Game -> Game
bounce g@(Game _ _ py cy bx by _ _)
    | by < 0       = ballVY ^: negate $ ballY ^= ballSize - by $ g
    | by > windowH = ballVY ^: negate $ ballY ^= 2 * windowH - ballSize - by $ g
    | hitPaddle bx by paddleX py && bx > paddleX
    = ballVX ^: negate $ ballX ^= paddleX + paddleBallDist $ g
    | hitPaddle bx by (windowW - paddleX) cy && bx < (windowW - paddleX)
    = ballVX ^: negate $ ballX ^= windowW - paddleX - paddleBallDist $ g
    | otherwise = g
    where paddleBallDist = paddleW / 2 + ballSize / 2

checkScore :: Game -> Game
checkScore g | g ^. ballX < 0       = resetBall $ scoreCPU ^: succ $ g
             | g ^. ballX > windowW = resetBall $ scorePlayer ^: succ $ g
             | otherwise            = g

hitPaddle :: Double -> Double -> Double -> Double -> Bool
hitPaddle bx by px py = abs (bx - px) <= ballSize / 2 + paddleW / 2 &&
                        abs (by - py) <= ballSize / 2 + paddleH / 2

resetBall :: Game -> Game
resetBall game@(Game sp sc _ _ _ _ _ _) =
    ballX ^= windowW / 2 $ ballY ^= windowH / 2 $
    ballVX ^= fromIntegral (1 - 2 * mod (sp + sc) 2) $ game

render :: IORef Game -> IO ()
render game = do
    (Game ps cs py cy bx by _ _) <- get game
    clear [ColorBuffer, DepthBuffer]
    color $ color3 1 0 0
    rectangle paddleX py paddleW paddleH
    color $ color3 0 0 1
    rectangle (windowW - paddleX) cy paddleW paddleH
    color $ color3 1 1 1
    rectangle bx by ballSize ballSize
    preservingMatrix $ do
        translate $ Vector3 50 350 (0 :: Float)
        renderString Fixed8x16 . ("You: " ++) $ show ps
        translate $ Vector3 450 0 (0 :: Float)
        renderString Fixed8x16 . ("CPU: " ++) $ show cs

displayFPS :: Double -> IO ()
displayFPS dt = do color $ color3 1 1 1
                   renderString Fixed8x16 . ("FPS: " ++) $ show (1 / dt)

pressed :: (Enum a) => (Bool -> b -> IO c) -> a -> b -> IO c
pressed cond key f = getKey key >>= flip cond f . (== Press)

rectangle :: Double -> Double -> Double -> Double -> IO ()
rectangle x y w h = renderPrimitive Quads $ mapM_ (vertex . vert2D)
                        [(x - w / 2, y - h / 2), (x + w / 2, y - h / 2),
                         (x + w / 2, y + h / 2), (x - w / 2, y + h / 2)]

color3 :: Double -> Double -> Double -> Color3 Double
color3 = Color3

vert2D :: (Double, Double) -> Vertex3 Double
vert2D (x,y) = Vertex3 x y 0