HPong 0.1.2

About two days ago the beta version of the Haskell Platform was released. Since it comes with an OpenGL library, it is now trivially easy to start making OpenGL programs with Haskell. To test this, I decided to make a simple Pong clone for two reasons:

• To experiment with making an OpenGL game
• I chose to use the GLFW instead of the GLUT library because GLUT doesn’t respond to closing a window with the close button very well. However, I could only find one piece of sample code for GLFW. Because of that, I decided to make a small game that others can use as a starting point for their own games.

The controls are very simple: The up and down arrow keys move your paddle and Esc quits the game.

Below is the complete code for HPong; 136 lines, including blank lines. Basic concepts include rendering the game, showing FPS and responding to keyboard input. The code is published as GPL and available from Hackage here. Have fun making your own games!

{-# 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

About these ads

Tags: game, Haskell, HPong