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: , ,

6 Responses to “HPong 0.1.2”

  1. Ian Duncan Says:

    What does the Template Haskell line of code that says:
    $( deriveAccessors ”Game )
    do?

  2. Remco Niemeijer Says:

    It turns all the fields in the Game data type that end in an underscore into accessors with the same same (without the underscore).

    The reason for using accessors is that you can turn a standard not-too-pretty record update like
    \g -> g { scorePlayer = succ $ scorePlayer g }
    into
    scorePlayer ^: succ

  3. Alan Says:

    For anyone who tries to run this on OS X but can’t get the window to accept focus, you need to put the binary in an application bundle. I’m not sure why you have to do this, but making a C++ Carbon project in Xcode called hpong and replacing the executable with the hpong installed by cabal works.

  4. Predrag Radovic Says:

    I had to apply this patch to be able to build and run it:

    — HPong.hs- 2011-04-12 22:51:14.830000005 +0200
    +++ HPong.hs 2011-04-12 22:56:55.296666672 +0200
    @@ -8,6 +8,8 @@
    import Graphics.Rendering.OpenGL
    import Graphics.UI.GLFW

    +import Unsafe.Coerce
    +
    data Game = Game { scorePlayer_ :: Int, scoreCPU_ :: Int,
    playerY_ :: Double, cpuY_ :: Double,
    ballX_ :: Double, ballY_ :: Double,
    @@ -112,9 +114,9 @@
    color $ color3 1 1 1
    rectangle bx by ballSize ballSize
    preservingMatrix $ do
    – translate $ Vector3 50 350 (0 :: Float)
    + translate $ Vector3 (toGLdouble 50) (toGLdouble 350) (toGLdouble 0)
    renderString Fixed8x16 . (“You: ” ++) $ show ps
    – translate $ Vector3 450 0 (0 :: Float)
    + translate $ Vector3 (toGLdouble 450) (toGLdouble 0) (toGLdouble 0)
    renderString Fixed8x16 . (“CPU: ” ++) $ show cs

    displayFPS :: Double -> IO ()
    @@ -129,8 +131,11 @@
    [(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
    +color3 :: Double -> Double -> Double -> Color3 GLdouble
    +color3 r g b = Color3 (toGLdouble r) (toGLdouble g) (toGLdouble b)
    +
    +vert2D :: (Double, Double) -> Vertex3 GLdouble
    +vert2D (x,y) = Vertex3 (toGLdouble x) (toGLdouble y) (toGLdouble 0)

    -vert2D :: (Double, Double) -> Vertex3 Double
    -vert2D (x,y) = Vertex3 x y 0
    \ No newline at end of file
    +toGLdouble :: Double -> GLdouble
    +toGLdouble = unsafeCoerce

  5. Bogdan Grumezescu Says:

    Not in scope: `windowParam’
    Failed, modules loaded: none.

    Why does not work man?

  6. Remco Niemeijer Says:

    It appears they removed windowParam from the GLFW package in version 0.5.0.0. Try installing version 0.4.2 and it should work.

Leave a Reply

Fill in your details below or click an icon to log in:

WordPress.com Logo

You are commenting using your WordPress.com account. Log Out / Change )

Twitter picture

You are commenting using your Twitter account. Log Out / Change )

Facebook photo

You are commenting using your Facebook account. Log Out / Change )

Google+ photo

You are commenting using your Google+ account. Log Out / Change )

Connecting to %s


Follow

Get every new post delivered to your Inbox.

Join 35 other followers

%d bloggers like this: