-->

Tuesday, September 18, 2012

Breakout

Hi, welcome to the 5th article of this blog.

I am very exited! In the last Post we wrote a Pong like ... well ... let's call it javascript application. In this post I have expanded it by the following properties:

  • The game does not start until you hit enter.
  • There are blocks that can be hit by the ball and disappear.
  • There are even blocks with 2 lives (dark blue) that turn into normal blocks on the first hit.
  • The game stops when the ball leaves the canvas downward.

This means, there is a goal and there is a game over situation. So at this point one could actually call it a game. And it even has a start screen ... did I mention that I am exitied? /,anma But, now, as always, here is a preview. As always you have to click the canvas to get input focus. If you are not viewing this blog article on blogspot and the application does not work, try the original article page.

Note: This currently only works if you are viewing this article only (not in the flow of the complete blog). I am working on the problem ...

But let me tell you how I did it :).

By the way, this post assumes that you have read the last Post.

More Coroutine helpers

There are two aspects of this game (yes, game!)

  • The blocks are a dynamic set of objects, that disappear as the game progresses
  • There are different "game states" (the start screen and the actual game)

So this has been added to Coroutine.hs

-- manages a set of coroutines which are deletet when returning Nothing
manager :: [Coroutine a (Maybe b)] -> Coroutine [a] [b]
manager cos = Coroutine $ \is ->
  let res  = map (\(co, i) -> runC co i) $ zip cos is
      res' = filter (isJust . fst) res
      (result, cos') = unzip res'
  in (catMaybes result, manager cos')

-- switcher, starts with a specific coroutine and switches whenever a new coroutine is send via an event
switch :: Coroutine a b -> Coroutine (Event (Coroutine a b), a) b
switch init = Coroutine $ \(e,i) ->
  let init' = last $ init : e --the last coroutine sent through
      (o, init'') = runC init' i
  in  (o, switch init'')

-- replace the contents of an event
(<$) :: Event a -> b -> Event b      
(<$) events content = map (\_ -> content) events

manager: The manger is for managing the blocks. Every blocks state is produced by a coroutine, and in the beginning there is a set of blocks in the game (first parameter to manager). The manager distributes its input to all its coroutines. So the input list should have the same length. The output if each coroutines are collected in a list which is the output of the manager.

Every block Coroutine returns "Nothing" when the block is destroyed, the manager than removes the block from the set.

Note that at present there is no way of inserting new blocks in the manager, it is not needed in this game.

switch: Switch allows us to switch between different game states, which all are described by coroutines of the same type.

Initially switch behaves as the init Coroutine (its first parameter) with an extra parameter holding events with other Coroutines. Whenever one of these events occurs, switch switches to the coroutine carried in the event.

<$: This is a operator. When applied to an event it replaces the contents of the event with the second parameter. We need this to replace the content of the KeyDown event with the main Coroutine when the start key is pressed. You will see!

From Pong to Breakout

All very exiting, but the real excitement start now. The main source file Breakout.hs is based on the last posts Pong.hs. Here I will go over the differences.

Definitions

The game state needs to reflect the blocks and the start screen. It has changed to:

data PlayerState = PlayerState {xPos :: Double}
data BallState = BallState {ballPos :: Vector}
data BlockState = BlockState {blockPos :: Vector, blockLives :: Int}

data GameState = GameState {player :: PlayerState,
                            ball :: BallState,
                            blocks :: [BlockState]}
                 | StartScreen

data BallCollision = LeftBounce | RightBounce | UpBounce | DownBounce
data BlockCollision = BlockCollision
data Rect = Rect { x::Double, y::Double, width ::Double, height::Double}

The BlockState has been added, which contains the block position and the number of lives (1 or 2) of the block. The GameState has been expanded by a list of BlockStates AND can be just the start screen (when the game has not started).

BlockCollision is a type for creating Events where the block collides with the ball. A type synonym to () would also work, but I choose this more verbose way.

blockWidth = 60.0
blockHeight = 20.0
blockColor1live = "blue"
blockColor2live = "darkblue"

initBlockStates = [BlockState (x,y) lives | x <- [20.0, 140.0, 240.0, 340.0, 440.0, 520.0], (y, lives) <- [(60.0,2), (100.0,1), (140.0,2), (180.0,1), (220.0,1), (260.0,1)]]

restartKeyCode = 32
canvasName = "canvas3"

The color of the blocks depend if they have 1 or 2 lives. initBlockStates describes the blocks as the game starts. They are evenly spaced, 6 in x and 6 in y directions. 2 of the y rows have 2 lives, the rest 1.

The restartKeyCode is the key code of the enter bar and the canvasName is the name of the canvas in the html code of this blog.

Drawing

draw :: GameState -> IO ()
draw StartScreen = do
  ctx <- getContext2d canvasName
  clear ctx
  -- draw the text
  setFillColor ctx "black"
  fillText ctx "Press Enter to start --- (click the canvas for input focus)" (screenWidth/2.0 - 100.0) (screenHeight/2.0)

draw (GameState playerState ballState blockStates) = do
  ctx <- getContext2d canvasName
  clear ctx
  -- draw player
  setFillColor ctx playerColor
  let pRect = playerRect playerState
  fillRect ctx (x pRect) (y pRect) (width pRect) (height pRect)
  --draw blocks
  mapM_ (drawBlock ctx) $ blockStates
  --draw ball
  setFillColor ctx ballColor
  let (x,y) = ballPos ballState
  fillCircle ctx x y ballRadius

drawBlock :: Context2D -> BlockState -> IO ()
drawBlock ctx bs = do
  setFillColor ctx (if blockLives bs == 1 then blockColor1live else blockColor2live)
  let r = blockRect bs
  fillRect ctx (x r) (y r) (width r) (height r)

draw pattern matches its argument, to test if it is the start screen. If so, a short message telling the player to press enter is displayed (see fillText in some javascript documentation).

helpers

gameOver :: GameState -> Bool
gameOver (GameState _ (BallState (_, by)) _) = by > screenHeight
gameOver _ = False

blockRect :: BlockState -> Rect
blockRect (BlockState (bx,by) _) = Rect bx by blockWidth blockHeight

gameOver is a little helper function to test if the ball has left the canvas. It returns False on the start screen.

blockRect returns the rectangle occupied by a block.

Main coroutine

mainCoroutine :: MainCoroutineType
mainCoroutine = proc inEvents -> do
  rec
    let startEvent = filter (\ke -> ke == KeyUp restartKeyCode) inEvents <$ mainGameCoroutine
        stopEvent  = if gameOver oldState then [mainStartScreenCoroutine] else []
    state <- switch mainStartScreenCoroutine -< (startEvent ++ stopEvent, inEvents)
    oldState <- delay StartScreen -< state
  returnA -< state

mainStartScreenCoroutine :: MainCoroutineType
mainStartScreenCoroutine = arr $ const StartScreen

mainGameCoroutine :: MainCoroutineType
mainGameCoroutine = proc inEvents -> do
  plState <- playerState -< inEvents
  rec
    let (ballBlockColls, blockColls) = ballBlocksCollisions oldBallState oldBlockStates
    let colls = (ballWallCollisions oldBallState) ++ (ballPlayerCollisions plState oldBallState) ++ ballBlockColls
    currBallState   <- ballState            -< colls --long names ...
    currBlockStates <- blockStates          -< blockColls
    oldBallState    <- delay initBallState  -< currBallState
    oldBlockStates  <- delay initBlockStates-< currBlockStates
  returnA -< GameState plState currBallState currBlockStates

The original main coroutine has been renamed to mainGameCoroutine. There is a new "main coroutine" mainStartScreenCoroutine which is used while in the start screen. The new mainCoroutine switches between these two coroutine when the player pressed enter, or the game is over.

Remember, the <$ operator replaces the contents of an event with its second parameter (here the mainGameCoroutine) and switch receives events containing coroutines to which it switches.

mainGameCoroutine has been extended by the blocks. ballBlocksCollisions, as we will see later, returns a tuple with the ballCollisions events due to collisions with the blocks, and a list of BlockCollision events. This list has the same length as the list of blocks (in oldBlockStates). The n-th element of this list are the collisions with the n-th block.

The block collisions are than passed to the blockStates arrow while the ballCollisions are added to the collisions passed to ballState.

I dislike the long names like "currBallState" here. I would have called it ballState, but there is already an arrow with the same name. I wonder if there is a less clumsy way of doing this ...

Ball-Block collisions

ballBlocksCollisions :: BallState -> [BlockState] -> (Event BallCollision, [Event BlockCollision])
ballBlocksCollisions ballState blockStates =
  let ballR = ballRect ballState
      foldStep (ballC, blockC) blockState =
        if rectOverlap ballR (blockRect blockState) then
          (ballRectCollisions ballState (blockRect blockState) ++ ballC, blockC ++ [[BlockCollision]])
        else
          (ballC, blockC ++ [[]])
  in foldl' foldStep ([],[]) blockStates

In my opinion, this is the most complicated function. It takes the ball state and the block states (as a list) and produces ball collisions events, and a list of block collision events, which has the same length as the input block state list.

The foldStep function takes the next block, tests it for collision and updates the list of ball and block collisions. Here the ball collision events are only expanded when a collision happens. The list of block collision events is always expanded. By an empty event (empty list) when no collision happens, and by a BlockCollision event in case of collision. This is because the position in this list reflects the block that will receive it.

Updating the block state

blockState :: BlockState -> Coroutine (Event BlockCollision) (Maybe BlockState)
blockState initState = scanE update (Just initState)
  where
  update :: Maybe BlockState -> BlockCollision -> Maybe BlockState
  update Nothing   _ = Nothing
  update (Just bs) _ = if (blockLives bs == 1) then Nothing else Just $ bs{blockLives=1}

blockStates :: Coroutine ([Event BlockCollision]) ([BlockState])
blockStates = manager $ map blockState initBlockStates

Every block has its own coroutine, which receives block collision events. In case of such an event, the number of lives is reduced or the block is removed (if there are no lives left). The coroutines return a Maybe data type, because they are inserted into the manager. Nothing is returned if the block should be deleted.

blockStates uses the manager to manage all "living" blocks.

Compiling

The compilation is the same as for Pong int the last post.

Haste

For haste make sure the newest version is installed. Because we use vector-space we need to install it for haste.

vector space is needed, see the last post.

Now put Breakout.hs, Coroutine.hs, the haste version of JavaScript.hs and the javascript helper functions helpers.js in a directory and compile with

hastec Breakout.hs --start=asap --with-js=helpers.js

You should receive a file "Breakout.js" which can be included in a html file, like this one: haste html

UHC

With UHC it is a little bit more work. UHC does not support arrow syntax, so we must translate the haskell file with arrowp:

cabal install arrowp
arrowp Breakout.hs > BreakoutNA.hs

I choose the name BreakoutNA.hs for "Breakout no arrows". For some reason I also can not get vector space to compile with UHC. Luckily we have not used much of vector space, only the + operator. So edit PongNA.hs and replace the line

import Data.VectorSpace

with

(^+^) :: Num a => (a,a) -> (a,a) -> (a,a)
(^+^) (a1,a2) (b1,b2) = (a1+b1, a2+b2)

Now copy Coroutine.hs and JavaScript.hs (the UHC version) into the directory and compile with

uhc -tjs BreakoutNA.hs -iuhc 

The canvas needs to be added to the generated html file, so add

<canvas height="400" id="canvas3" style="background-color: white;" width="600" tabindex="1"></canvas>

Since we do not need any additional javascript functions, the generated html page should work!

Conclusion

Well that is it. At places I find it a bit clumpsy and I wonder if another FRP library like Reactive Banana or elerea would help. I will look into these!

Creative Commons License
Writing JavaScript games in Haskell by Nathan Hüsken is licensed under a Creative Commons Attribution 3.0 Germany License.

Monday, September 17, 2012

Pong

In the last Post we wrote the first interactive javascript application in haskell where a paddle on the bottom of the canvas could be moved via keyboard input.
In this next step we will add ball (a moving circle) that can bounce of the paddle and the walls.
Here is a preview (again, click on the canvas to get input focus). If you are not viewing this blog article on blogspot and the application does not work, try the original article page.
** Note: ** This currently only works if you are viewing this article only (not in the flow of the complete blog). I am working on the problem ...

But first we will need some perquisites. I will utilize Functional Reactive Programming (FRP) using the functions defined here: Purely Functional, Declarative Game Logic Using Reactive Programming. I take the terminus "coroutine" from that blog article. I like to think of a coroutine as "state full function". The output of the coroutine does not only depend on its input but also on the input passed to it in previous calls. So make sure you read and understand that blog article. The resulting code can be found here: Coroutine.hs.
So, let us get started!

Imports and definitions

I follow the source file Pong.hs and therefor start with the imports and some definitions used later in the game.
{-# LANGUAGE Arrows #-}

module Main where

import JavaScript
import Coroutine
import Data.IORef
import Control.Arrow

import Data.VectorSpace

-- input data
data Input = KeyUp Int | KeyDown Int deriving (Eq)

-- Game data
type Vector = (Double, Double)

data PlayerState = PlayerState {xPos :: Double}
data BallState = BallState {pos :: Vector2D}

data GameState = GameState {player :: PlayerState,
                            ball :: BallState}

data BallCollision = LeftBounce | RightBounce | UpBounce | DownBounce
data Rect = Rect { x::Double, y::Double, width ::Double, height::Double}
We will use Arrow Syntax and tell the compiler that we do. Actually UHC does not support Arrow Syntax (yet?), but more about that later.
We import Data.VectorSpace allowing us to use some basic vector operation with tuples of Doubles. Here we only need addition, but if we need more VectorSpace is handy.
The input data will be a series of Keyboard up and down events with corresponding key codes. BallCollision describes a collision of the ball with the wall or the paddle in a certain direction.
The rest is types we need in the game and should be self explaining.
Next we will declare some values defining subtleties of the game.
-- game values
screenWidth = 600.0
screenHeight = 400.0
playerColor = "black"
ballColor = "red"
playerYPos = screenHeight - playerHeight
playerHeight = 15.0
playerWidth = 40.0
ballRadius = 5.0

initBallState = BallState ((screenWidth / 2.0), (screenHeight - 50.0))
initBallSpeed = (3.0, -3.0)

initPlayerState = PlayerState ((screenWidth - playerWidth) / 2.0)

playerSpeed = 5.0

-- technical values
leftKeyCode = 37
rightKeyCode = 39
canvasName = "canvas2"
Again, these should be relatively self explaining. Keycode 37 and 39 correspond to the arrow keys. canvas2 is the name of the canvas defined in the html code of this blog.

Entry point and callbacks

In difference to the last blog article we will not use a javascript function to save and store global objects. Instead the objects will be stored in IORefs which are passed to the callbacks.
-- entry point
main = setOnLoad initilize

initilize = do
  state <- newIORef mainCoroutine
  input <- newIORef ([] :: [Input])
  setOnKeyDown canvasName (onKeyDown input)
  setOnKeyUp   canvasName (onKeyUp input)
  setInterval 20.0 (update state input)

-- input
onKeyDown :: IORef [Input] -> Int-> IO ()
onKeyDown input keyCode = do
  i <- readIORef input
  let i' = i ++ [KeyDown keyCode]
  writeIORef input i'

onKeyUp :: IORef [Input] -> Int-> IO ()
onKeyUp input keyCode = do
  i <- readIORef input
  let i' = i ++ [KeyUp keyCode]
  writeIORef input i'
So main sets the initilize function to be called then the window is loaded. initilize creates 2 IORefs, one for the main coroutine (which will be defined later) and one for the input stream, which is a list of input events.
The main coroutine is the place where the game logic happens. The output of the main coroutine is the current game state. Because the current main coroutine depends on the previous calls to it, it must be stored between game updates.
onKeyDown and onKeyUp are called when a key is pressed or released and expand the input stream.
update is set to be called every 20 milliseconds with the state and input IORefs passed to it.

Updating and drawing the game sate

Next we will draw the game state (the output of the main coroutine). This is basicly the same as what we did in the last blog article, only that now we also need to draw a circle for the ball.
-- draw a gamestate
draw :: GameState -> IO ()
draw gs = do
  ctx <- getContext2d canvasName
  clear ctx
  -- draw player
  setFillColor ctx playerColor
  let pRect = playerRect . player $ gs
  fillRect ctx (x pRect) (y pRect) (width pRect) (height pRect)
  --draw ball
  setFillColor ctx ballColor
  let (x,y) = pos . ball $ gs
  fillCircle ctx x y ballRadius

-- update function
update :: IORef MainCoroutineType -> IORef (Event Input) -> IO ()
update state input = do
  co <- readIORef state
  i <- readIORef input
  writeIORef input ([] :: [Input])
  let (gs, co') = runC co i
  draw gs
  writeIORef state co'
The draw function should be self explaining. If not, read my last blog articles. Some javascript functions have been added, but they all follow the same principle as in the last blog article.
The update function reads the current main coroutine and input stream. The coroutine is updated and the new game state is obtained by calling the coroutine with the current input stream. Finally the game state is drawn and the new coroutine is saved.

Some helper functions

Before the main game logic a few helper functions are defined.
-- helper functions
keyDown :: Int -> Coroutine (Event Input) Bool
keyDown code = scanE step False
  where
  step old input
    | input == KeyUp code   = False
    | input == KeyDown code = True
    | otherwise             = old

rectOverlap :: Rect -> Rect -> Bool
rectOverlap r1 r2 
  | x r1 >= x r2 + width r2 = False
  | x r2 >= x r1 + width r1 = False
  | y r1 >= y r2 + height r2 = False
  | y r2 >= y r1 + height r1 = False
  | otherwise                = True
  
playerRect :: PlayerState -> Rect
playerRect (PlayerState px) = Rect px playerYPos playerWidth playerHeight

ballRect :: BallState -> Rect
ballRect (BallState (bx,by)) = Rect (bx - ballRadius) (by - ballRadius) (2.0 * ballRadius) (2.0 * ballRadius)
keyDown takes a keycode and outputs a coroutine indicating at all times if the given key is down given the input stream (The Event type comes from Coroutine.hs). We will need this because the paddle is supposed to be moving as long as an arrow key is pressed.
Note that this is a little different that what we did in the last post. Actually there it only worked because javascript fires continuous "keyDown" events when a key is hold down, but that is a platform dependent behavior and we do not want to rely on it. Also this firing of key down events does not immediately start when a key is pressed. There is a short break. If you go back on that post and try the application, you will note that the paddle does not start moving immediately, but there is a short delay after pressing a key.
rectOverlap tests two rectangles if they overlap (used for collision detection). playerRect and ballRect return the rectangle occupied by the paddle and ball respectively.

The main Coroutine

The main coroutine takes input events as input and outputs the game state. The type synonym MainCoroutineType is introduced for verbosity. Earlier it allowed us to create the IORef for the main coroutine in a more readable way (in my opinion).
-- Game logic
type MainCoroutineType = Coroutine (Event Input) GameState

mainCoroutine :: MainCoroutineType
mainCoroutine = proc inEvents -> do
  plState <- playerState -< inEvents
  rec
    let colls = (ballWallCollisions oldBlState) ++ (ballPlayerCollisions plState oldBlState)
    blState <- ballState -< colls
    oldBlState <- delay initBallState -< blState
  returnA -< GameState plState blState
The player state is computed with the input events. The collisions of the ball with player and wall solely depend on the previous ball state. ballWallCollisions and ballPlayerCollisions can therefore be pure functions and not coroutines. That is why "colls" is defined in a let expression. The new ballState is calculated using this collisions information.
The construct with "rec" and "delay" is needed because the ball state from the last frame is required. This construct is explained in Purely Functional, Declarative Game Logic Using Reactive Programming.

The Player

The player is moved with the arrow keys without crossing the bounding of the game.
playerState :: Coroutine (Event Input) PlayerState
playerState = proc inEvents -> do
  vel <- playerVelocity -< inEvents
  xPos <- boundedIntegrate (0.0,screenWidth-playerWidth) (xPos initPlayerState)  -< vel
  returnA -< PlayerState xPos

playerVelocity :: Coroutine (Event Input) Double
playerVelocity = proc inEvents -> do
  leftDown <- keyDown leftKeyCode -< inEvents
  rightDown <- keyDown rightKeyCode -< inEvents
  returnA -< if leftDown then -playerSpeed else (if rightDown then playerSpeed else 0.0)
boundedIntegrate is a coroutine defined in Coroutine.hs which integrates the input and clips it to a given range.

The Ball state

Collisions

The ball state needs the collision events as input (see the main coroutine).
ballWallCollisions :: BallState -> (Event BallCollision)
ballWallCollisions (BallState (bx,by)) =
  map snd . filter fst $ [(bx < ballRadius,                LeftBounce),
                          (bx > screenWidth - ballRadius,  RightBounce),
                          (by < ballRadius, UpBounce)]

ballRectCollisions :: BallState -> Rect -> (Event BallCollision)
ballRectCollisions (BallState (bx, by)) (Rect rx ry rw rh) =
  map snd . filter fst $ [(bx <= rx,       RightBounce),
                          (bx >= rx + rw, LeftBounce),
                          (by <= ry,       DownBounce),
                          (by >= ry + rh, UpBounce)]

ballPlayerCollisions :: PlayerState -> BallState -> (Event BallCollision)
ballPlayerCollisions playerState ballState =
  if rectOverlap (playerRect playerState) (ballRect ballState)
  then ballRectCollisions ballState (playerRect playerState)
  else []

Updating the ball state

Using this collisions events the ball is updated by moving and bouncing according to the collision events.
ballState :: Coroutine (Event BallCollision) BallState
ballState = proc collEvents -> do
  vel <- ballVelocity -< collEvents
  pos <- scan (^+^) (pos initBallState) -< vel
  returnA -< BallState pos

ballVelocity :: Coroutine (Event BallCollision) Vector2D
ballVelocity = scanE bounce initBallSpeed
  where
    bounce :: Vector2D -> BallCollision -> Vector2D
    bounce (vx,vy) coll = case coll of
      LeftBounce -> (abs(vx), vy)
      RightBounce -> (-abs(vx), vy)
      UpBounce -> (vx, abs(vy))
      DownBounce -> (vx, -abs(vy))
The + operator is defined in the vector space package and adds two vectors (in our case tuples of doubles).

Compiling

That it. Now we need to compile ...

haste

For haste make sure the newest version is installed. Because we use vector-space we need to install it for haste.
First install vector space via cabal:
cabal install vector-space
Now unpack vector-space with cabal, and install AdditiveGroup.jsmod.
cabal unpack vector-space
cd vector-space-0.8.2/src
hastec --libinstall -O2 Data.VectorSpace Data.AdditiveGroup
That it! Now put Pong.hs, Coroutine.hs, the haste version of JavaScript.hs and the javascript helper functions helpers.js in a directory and compile with
hastec Pong.hs --start=asap --with-js=helpers.js
You should receive a file "Pong.js" which can be included in a html file, like this one: haste html

UHC

With UHC it is a little bit more work. UHC does not support arrow syntax, so we must translate the haskell file with arrowp:
cabal install arrowp
arrowp Pong.hs > PongNA.hs
I choose the name PongNA.hs for "Pong no arrows". For some reason I also can not get vector space to compile with UHC. Luckily we have not used much of vector space, only the + operator. So edit PongNA.hs and replace the line
import Data.VectorSpace
with
(^+^) :: Num a => (a,a) -> (a,a) -> (a,a)
(^+^) (a1,a2) (b1,b2) = (a1+b1, a2+b2)
Now copy Coroutine.hs and JavaScript.hs (the UHC version) into the directory and compile with
uhc -tjs PongNA.hs -iuhc 
The canvas needs to be added to the generated html file, so add
<canvas height="400" id="canvas2" style="background-color: white;" width="600" tabindex="1"></canvas>
Since we do not need any additional javascript functions, the generated html page should work!

Conclusion

I have little experience with FRP (this blog article is my first attempt to write a FRP application). I would have liked to use Reactive Banana for this, but at present I am unable to compile Reactive Banana with UHC or haste.
According to this Reactive Banana has been compiled with UHC, but in the new version, support for UHC will be dropped.
haste failed to compile Reactive Banana because of missing PrimOps. According to the maintainer of haste, that is a solvable problem and will be fixed in the future.
In the next article, we will add "blocks" that can collide with the ball and disappear to have a breakout like game.
Creative Commons License
Writing JavaScript games in Haskell by Nathan Hüsken is licensed under a Creative Commons Attribution 3.0 Germany License.