How a Haskell programmer wrote a tris in Purescript

This was written as a response to shiraeeshi's "How a Java Programmer Wrote Console Tetris in Haskell". The point was to show how you could do this from scratch in Haskell. I also ended up trying out Purescript for the first time.

You can play it here if it works on your browser, it responds to keyboard arrow keys after you click it:

Download the source code: tris.zip

There's a little lie in the title of this post. I'm not a Haskell programmer. Though, we start the work with Haskell and finish it in Purescript. I did this because wanted to show the results in front of this post and Haskell itself doesn't translate well to Javascript whereas Purescript is meant to run on Javascript.

Right after I finished the work I felt like shitting bricks. Purescript has tried to do things "better" than Haskell but they fall short of it in several ways that ends up being infuriating.

2020-08-24 update: Miles Frain told me that the Tris would be a fun example to include in purescript-cookbook and provided me a pull request to look at before committing the code in. I have approved the use. The example is "SignalTrisJs" and demonstrates, well, how to write a tris in Purescript. I saw it uses signals and a random number generator with a seed instead of what I did here. The code there is much cleaner than here and addresses some of the issues I've picked up.

10/10, I would criticize again, though from now on I promise to be much more gentle than I was here. I learned that good criticism takes responsibility for recipient's feelings.

Purescript issues

2020-08-08: There is something that I should've written right from the beginning here. I really appreciate that I have something to criticize here. I appreciate the work you've put into to make Purescript work. There were plenty of things right for things to get into this point. If you keep reading, read with that in mind.

The first thing that caught me off guard is Purescript's lack of tuples. They got a "Data.Tuple", but there's no infix syntax for declaring tuples. I ended up rewriting everything in records and that resulted in pages-long type errors that required me to scroll upwards while Purescript's emitted warnings about implicitly imported variables before them.

Also, what's the deal with number literals? In Haskell the type signatures for number literals 3 and 3.0 are Num t => t and Fractional t => t. In purescript they are Int and Number... I continue and try this with other things.

> :t 3
Int
> :t 3.0
Number
> :t "foo"
String
> :t [1,2]
Array Int

You're serious about this? Overloadable literals are some of the best stuff that Haskell has to offer and you did not implement them into this language? Come on! Why would anybody want to use it in this way?!!

> :t (+)
forall a. Semiring a => a -> a -> a

At least they got...

Semiring Number

I feel pissed. When you write "Semiring", it means it must satisfy certain rules for semirings. Floating point addition is not associative. Why did you do this when you didn't abstract the literals? This is translating to Javascript's double right? "What Every Computer Scientist Should Know About Floating-Point Arithmetic", just wow.

The another thing I really don't like is how much stuff is off the Prelude. Look at all this stuff I had to import into my program.

module Main where

import Data.Array ((..), index)
import Data.Either (Either(..))
import Data.Foldable
import Data.FoldableWithIndex
import Data.Int (toNumber)
import Data.Map (Map, insert, union, intersection, keys, empty)
import Data.Maybe (Maybe(..))
import Data.Number.Format (toString)
import Data.Set (size, filter)
import Data.Traversable (sequence, sequence_)
import Effect.Aff (Aff, delay, Milliseconds(..), launchAff_)
import Effect.Class (liftEffect)
import Effect.Console (log)
import Effect (Effect)
import Effect.Random (randomInt)
import Effect.Ref (Ref, new, read, write)
import Graphics.Canvas
import Prelude
import Web.DOM.Document (toNonElementParentNode)
import Web.DOM.Element (toEventTarget)
import Web.DOM.NonElementParentNode
import Web.Event.Event
import Web.Event.EventTarget
import Web.HTML.HTMLDocument (toDocument)
import Web.HTML (window)
import Web.HTML.Window (Window, document, requestAnimationFrame)
import Web.UIEvent.KeyboardEvent

How come I need to import arrays, number formatting, foldables, traversables, either or maybe? Why the rest of the stuff is divided into so many modules? There are like more than 5 modules for accessing HTML elements. Also I'm a bit annoyed when I see things like this:

addEventListener :: EventType -> EventListener -> Boolean -> EventTarget -> Effect Unit

So.. I need to convert things into EventTarget when I use this function. Also how come EventType doesn't determine the EventListener's shape? I got some slight Elm vibes from this. At least there are typeclasses but why does this seem otherwise so conservative when it comes to type level stuff?

There's also a thing that I don't like at all about in Purescript. It's the foreign function interface. This is how you expose stuff to Purescript. First you write a module in Javascript:

exports.diagonal = function(w) {
    return function(h) {
        return Math.sqrt(w * w + h * h);
    };
};

Then you describe this for the Purescript:

foreign import diagonal :: Number -> Number -> Number

Why are the types Purescript when it's Javascript on the other side? What I suspect is happening is that "imports" are doing nothing here. It's just exposing how purescript compiles to javascript. It might happen like this, for instance:

codegen :: Term env type -> Javascript
codegen (Var index) = lookup index
codegen (Lambda fn) = do
    (arg, body) <- abstract (codegen fn)
    pure ("function(" <> arg <> "){" <> block body <> "}")
codegen (App f x)
    = codegen f <> "(" <> codegen x <> ")"

This is what you might like to do if you want to get some abstract machine, such as Javascript, to evaluate lambda calculus. It's inevitable that the implementation produces some type there but why is it exposed? Also is that why there are record types with row polymorphism? Did you do the dumbest thing you can do there and copy the implementation details into the syntax of your language? It seems a lot like it:

Purescript | Javascript
-----------+-----------
Boolean    | Boolean
String     | String
Int,Number | Number
Array      | Array
Record     | Object

There's an additional layer that'd belong here you know...

1. Javascript's values are just valid structures that your language can carry around. There's no need to pretend that you couldn't pass plain untyped Javascript values as such.
2. Your source language's types should not mix with Javascript's types. They are separate entities and you aren't supposed to reveal how they're implemented. It varies by how the language is implemented.
3. You can construct structures that relate javascript values into your language's types. It would be much more pleasant to use.

This isn't too hard to do if you're building a new language. For instance, you could do it all through a separate module that you import to declare things.

import FFI.Javascript (Function, Double, Inline)

diagonal :: Number -> Number -> Number
foreign diagonal (Function [Double, Double] Double)
    (Inline "function(x,y){ return Math.sqrt(x*x + y*y); }")

Also don't expect that we'd want only one implementation!

import FFI.C (Function, Double)
import FFI.C.So (SharedObject, Win32, Linux)

foreign diagonal (Function [Double, Double] Double)
    SharedObject
        [Linux "libDiagonal.so", Win32 "libDiagonal.dll"]
        "diagonal"

When it comes to typed languages it would be almost like I am the only one who understands this: The datatypes presented by the language do not need to correspond to hardware datatypes or implementation datatypes. They also do not need to stay same representation during the code generation step.

Overall the experience of Purescript is not bad enough that I'd have stopped and forgotten about this whole thing. That's already an achievement.

Lets get to trying this thing. It compiles to Javascript. That's neat?

What's a tris?

Tris is a tile-matching video game where a player moves tiles to a board in order to make them disappear. Tiles are commonly tetrominoes, mathematical shapes arranged by placing 4 square tiles together. Tiles drop in one-by-one and fuse to the board when it cannot move further down. Player loses when the tiles eventually reach the top. There are conditions for when a player may destroy tiles on a board, if he does so he scores. The game speeds up as it's being played.

Why reiterate this even if the game's already running above for you? Well this is how you write any game: Just like when logic programming, you ask yourself what is that thing you're trying to write. We start with Haskell here so that the title has some justification.

Mathematical model of a tris

Boards and tiles are sets of points, decorated with something on top. I don't see why to distinguish between anything so I call everything a board. There's a neat structure for constructing sets with decorations called a map.

type Point = (Integer, Integer)
type Board a = Map Point a

a is going to stand for a decoration, in our case it'll be a String, but we don't let it affect the game mechanics. Guess what, we get bunch of interesting commands straight away! The union and intersection are granted. The 'union' can be used directly. When a tile is fused to the board we can do it like this:

union tile board

The union prioritizes values from the left side, so the tile ends up "above" the board.

The intersection is also directly useful, we can combine it with 'null' to check whether two boards collide.

null (intersection tile board)

Tiles are moving elements, so we're still short of a command to move them. But guess what else we can do? We can transform boards by mapping their keys.

mapKeys (transform x y) tile

The transform is the first function that needs to be defined:

transform :: Point -> Point -> Point
transform (ix,iy) (x,y) = (x+ix, y+iy)

The player needs to rotate tiles and some people who know their linear algebra, or are game developers (though included in the guys who know linear algebra), can guess what we do next. You may recall a rotation is a linear transform, which means it can be represented with a matrix.

type Matrix = Point -> Point

I doubt the evaluator is able to fold this but you're not going to rotate the piece so many times that it'd become a problem.

Matrices have an identity element, you may guess that's an identity function. Function composition works well as the matrix multiplication.

The rotation can be simply represented as y moves to the left and x moves upwards. We take those transforms and sum them.

rotate90d :: Matrix
rotate90d (x,y) = (-y, x)

Here's how we can now rotate a piece:

angle . rotate90d

Now we're able to represent the tile in player's hand:

mapKeys (transform x y . angle) tile

Now we're ready to model the game. There's usually some environment that tells which pieces the game may give.

newtype GameEnv a = GameEnv {getPieces :: [Board a]}

When the game's running, we got player's state, the point is where player's board is, the matrix tells how to rotate it, and finally we got a board at hand. The second board stores the next board shown in a small box.

type GameState a = Either (GameOver a) (Running a)
type Running a = (Player a, Board a, Integer)
type Player a = (Point, Matrix, Board a, Board a)
type GameOver a = (Board a, Integer)

When the game's not running, we leave the board and score around.

Next lets sketch the rules of the game. We got player motions to shift and rotate the pieces.

stepShift :: Integer -> GameEnv a -> Running a -> Running a
stepRotate :: GameEnv a -> Running a -> Running a

These are carried through only if the motion is noncolliding with anything. To represent that we got a way to check whether the run is affordable. Affordability requires checking that the thing's inside the playing area.

affordable :: Running a -> Bool
in_board :: Integer -> Integer -> Point -> Bool

Next there's the only way to end the game. The step-down fuses pieces to the board if it can't move them ahead. Player may also step-down with the down key himself.

stepDown :: GameEnv a -> Running a -> GameState a

There's also the condition for clearing the board. I did it by counting items on each line and removing rows that ended up being filled.

That would be about 80 lines of fairly easy to understand code. We are going to fix that next.

Purescript - game code

We are outright in a bad situation because we were using tuples for everything. First they're translated to records because why not leak some implementation details into your code?

type GameEnv a =
    { pieces :: Array (Board a)
    , width :: Int
    , height :: Int }
type GameState a = Either (GameOver a) (Running a)
type Running a =
    { player :: Player a
    , board :: Board a
    , score :: Int }
type Player a =
    { offset :: Point
    , orient :: Matrix
    , tile :: Board a
    , nextTile :: Board a }
type GameOver a =
    { board :: Board a
    , score :: Int }
type Point = {x :: Int, y :: Int}
type Matrix = Point -> Point
type Board a = Map Point a

transform :: Point -> Point -> Point
transform i j = {x: i.x + j.x, y: i.y + j.y}

rotate90d :: Matrix
rotate90d p = {x: -p.y, y: p.x}

The game requires bit of randomness that we're going to get through Javascript. Mainly we have to choose the next tile randomly.

randomTile :: forall a. GameEnv a -> Effect (Board a)
randomTile env = do
    i <- randomInt 0 (length env.pieces - 1)
    case index env.pieces i of
        Just tile -> pure tile
        Nothing   -> pure empty

To break the game rather than bug out I'll return an empty tile when the list is empty, because why not make it a hassle to use partial functions when false total functions are so convenient to create?

The next part is game initialization, well, the abstract parts. The initPlayer is separate because it's used to initiate a new turn.

initPlayer :: forall a. GameEnv a -> Board a -> Effect (Player a)
initPlayer env tile = do
    nextTile <- randomTile env
    pure
      { offset: {x: 6, y: 0}
      , orient: (\i -> i)
      , tile: tile
      , nextTile: nextTile }

initGame :: forall a. GameEnv a -> Effect (Running a)
initGame env = do
    player <- randomTile env >>= initPlayer env
    pure { player: player, board: empty, score: 0 }

Next the stepShift, stepRotate and stepDown like it was planned. There's a minor change in the stepDown because we had to randomize the results whenever the game progresses.

stepShift :: forall a. Int -> GameEnv a -> Running a -> Running a
stepShift x env prev = let
    run = prev { player = prev.player { offset = transform {x:x,y:0} prev.player.offset } }
    in if affordable env run then run else prev

stepRotate :: forall a. GameEnv a -> Running a -> Running a
stepRotate env prev = let
    run = prev { player = prev.player { orient = prev.player.orient >>> rotate90d } }
    in if affordable env run then run else prev

stepDown :: forall a. GameEnv a -> Running a -> Either (GameOver a) (Effect (Running a))
stepDown env prev = let
    run = {
        player: { offset: transform {x:0,y:1} prev.player.offset
                , orient: prev.player.orient
                , tile: prev.player.tile
                , nextTile: prev.player.nextTile }
        , board: prev.board
        , score: prev.score }
    in (if affordable env run then pure (pure run) else nextTurn)
    where nextTurn = let
             fl = flushBoard env.width env.height
                $ { board: union (currentTile prev.player) prev.board
                  , score: 1 }
             in if any (\p -> p.y <= 2) (keys fl.board)
                then (Left {board: fl.board, score: prev.score + fl.score})
                else pure $ do
                  player <- initPlayer env prev.player.nextTile
                  (pure {player: player, board: fl.board, score: prev.score + fl.score})

The board flushing mechanims was a bit more convoluted than I thought. The flushBoard goes through the whole playing field, applying flushRow to each row. The countRow takes care of counting the items on a row and then collapse removes a row.

flushBoard :: forall a. Int -> Int
           -> {board::Board a, score::Int}
           -> {board::Board a, score::Int}
flushBoard w h = foldl (>>>) (\a -> a) (map (flushRow w) (2 .. (h-1)))

flushRow :: forall a. Int -> Int
         -> {board::Board a, score::Int}
         -> {board::Board a, score::Int}
flushRow w y bs = if w == countRow y bs.board
    then {board: mapKeys' (collapse y) bs.board, score: bs.score+w}
    else bs

countRow :: forall a. Int -> Board a -> Int
countRow y board = size (filter (\p -> p.y == y) (keys board))

collapse :: Int -> Point -> Maybe Point
collapse y p | (p.y == y) = Nothing
collapse y p | (p.y < y)  = Just {x: p.x, y: p.y + 1}
collapse y p              = Just p

The affordable and in_board came out like planned.

affordable :: forall a. GameEnv a -> Running a -> Boolean
affordable env run = let
    tile = currentTile run.player
    in null (intersection tile run.board)
    && all (in_board env.width env.height) (keys tile)

in_board :: Int -> Int -> Point -> Boolean
in_board w h p =
  (0 <= p.x) && (p.x < w)
  && (0 <= p.y) && (p.y < h)

In addition I have a convenience function to retrieve the current player's tile pre-transformed, and a little function to retrieve the transform for the player.

currentTile :: forall a. Player a -> Board a
currentTile player = mapKeys (pt player) player.tile

pt :: forall a. Player a -> Point -> Point
pt player = transform player.offset <<< player.orient

Next we look at the game initialization.

Purescript - game environment

Color hexadecimal codes are coming in here. The piece is an assistive function to build the tetrominoes list.

initGameEnv :: GameEnv String 
initGameEnv = { pieces: tetrominoes, width: 14, height: 25 }

tetrominoes :: Array (Board String)
tetrominoes =
  [ piece
    [ {x: 0, y: 0}, {x:  1, y: 0}, {x: 2, y: 0}, {x: -1, y: 0}
    ] "#800"
  , piece
    [ {x: 0, y: 0} , {x: 1, y: 0} , {x: 0, y: 1} , {x: 1, y: 1}
    ] "#080"
  , piece
    [ {x: -1, y: 0} , {x: 0, y: 0} , {x: 1, y: 0} , {x: 1, y: 1}
    ] "#00C"
  , piece
    [ {x: -1, y: 0} , {x: 0, y: 0} , {x: 1, y: 0} , {x: 0, y: 1}
    ] "#088"
  , piece
    [ {x: -1, y: 0} , {x: 0, y: 0} , {x: 1, y: 1} , {x: 0, y: 1}
    ] "#808"
  ]

piece :: Array {x :: Int, y :: Int} -> String -> Board String
piece indices color = foldl
  (\m p -> insert p color m)
  empty
  indices

Purescript - Entry point

The following code sets up the game display, stepping and key events. Note: The game environment is initialized into a reference and passed around into every routine that's doing something wit it.

main :: Effect Unit
main = do
  w <- window
  d <- document w
  let env = initGameEnv
  gameRef <- initGame env >>= (new <<< Right)
  keyEvent <- eventListener (onKeyEvent env gameRef <<< fromEvent)
  canvas_elem <- getCanvasElementById "tris"
  case canvas_elem of
    Just canvas -> do
      ctx <- getContext2D canvas
      _ <- requestAnimationFrame (read gameRef >>= display w ctx gameRef) w
      launchAff_ (gameStep env gameRef)
      pure unit
    Nothing -> do
      pure unit
  kbElem <- getElementById "tris" (toNonElementParentNode (toDocument d))
  case kbElem of
    Just kb -> do
      addEventListener (EventType "keydown") keyEvent true (toEventTarget kb)
    Nothing -> do
      pure unit

I especially love the horrors of setting up event listeners in Purescript. They figured Javascript's object-oriented event interface would be neat to use if you had difficulty juggling with representations of objects. It took several hours to figure out how to get this main entry point and the stuff below to work, especially with code scantily clad of documentation. We also can't afford using typeclasses in addEventListener, nope.

onKeyEvent :: GameEnv String -> Ref (GameState String) -> Maybe KeyboardEvent -> Effect Unit
onKeyEvent env gameRef (Just ev) = case key ev of
    "ArrowLeft"  -> do
        game <- read gameRef
        write (map (stepShift (-1) env) game) gameRef
        preventDefault (toEvent ev)
    "ArrowRight" -> do
        game <- read gameRef
        write (map (stepShift 1 env) game) gameRef
        preventDefault (toEvent ev)
    "ArrowUp"    -> do
        game <- read gameRef
        write (map (stepRotate env) game) gameRef
        preventDefault (toEvent ev)
    "ArrowDown"  -> do
        game <- read gameRef
        game' <- sequence (game >>= stepDown env)
        write game' gameRef
        preventDefault (toEvent ev)
    _ -> pure unit
onKeyEvent env gameRef Nothing = pure unit

The gamestepping here is actually something better than you'd get in javascript, except that it's like telling your face looks prettier than weeks old roadkill.

gameStep :: GameEnv String -> Ref (GameState String) -> Aff Unit
gameStep env gameRef = do
    speed <- liftEffect $ map gameSpeed (read gameRef)
    delay $ Milliseconds speed
    game <- liftEffect $ read gameRef
    game' <- liftEffect $ sequence (game >>= stepDown env)
    liftEffect $ write game' gameRef
    case game' of
      Left _ -> pure unit
      Right _ -> gameStep env gameRef

Lets define the game speedup as you score, the produced number is a milliseconds between the game steps. This is probably badly selected table, also note that I was lazy and Vimed it out.

gameSpeed :: forall a. GameState a -> Number
gameSpeed (Right g) | g.score < 20  = 700.0
gameSpeed (Right g) | g.score < 40  = 600.0
gameSpeed (Right g) | g.score < 60  = 500.0
gameSpeed (Right g) | g.score < 80  = 400.0
gameSpeed (Right g) | g.score < 100 = 300.0
gameSpeed (Right g) | g.score < 120 = 200.0
gameSpeed (Right g) | g.score < 140 = 100.0
gameSpeed (Right g) | g.score < 160 = 90.0
gameSpeed (Right g) | g.score < 180 = 80.0
gameSpeed (Right g) | g.score < 200 = 70.0
gameSpeed (Right g) | g.score < 220 = 60.0
gameSpeed g                         = 50.0

Purescript - Display on canvas

Now it's time to show the mess on the screen. Both the game over and the game running. Here's the display routine.

display :: Window
        -> Context2D
        -> Ref (GameState String)
        -> GameState String
        -> Effect Unit
display w ctx game (Left over) = do
  displayBackground ctx over.board
  setTextAlign ctx AlignLeft
  setFillStyle ctx "#FFF"
  fillText ctx (toString (toNumber over.score)) (3.0 * 16.0) 425.0
  setTextAlign ctx AlignLeft
  fillText ctx ("game over") (3.0 * 16.0) 440.0
display w ctx game (Right run) = do
  displayBackground ctx run.board
  displayPlayer ctx run.player
  displayNextTile ctx run.player.nextTile
  setFillStyle ctx "#FFF"
  setTextAlign ctx AlignLeft
  fillText ctx (toString (toNumber  run.score)) (3.0 * 16.0) 425.0
  _ <- requestAnimationFrame (read game >>= display w ctx game) w
  pure unit

displayBackground :: Context2D -> Board String -> Effect Unit
displayBackground ctx board = do
  setFillStyle ctx "#333"
  fillPath ctx $ rect ctx
    { x: 0.0
    , y: 0.0
    , width: 320.0
    , height: 480.0
    }
  setFillStyle ctx "#000"
  fillPath ctx $ rect ctx
    { x: 3.0 * 16.0
    , y: 0.0
    , width: 16.0 * 14.0
    , height: 16.0 * 25.0
    }
  setFillStyle ctx "#000"
  fillPath ctx $ rect ctx
    { x: 12.0 * 16.0
    , y: 26.0 * 16.0
    , width: 16.0 * 5.0
    , height: 16.0 * 2.0
    }
  foldlWithIndex
    (\p m c -> m >>= \_ -> plot ctx p c)
    (pure unit)
    board

displayPlayer :: Context2D -> Player String -> Effect Unit
displayPlayer ctx player = do
  foldlWithIndex
    (\p m c -> m >>= \_ -> plot ctx (pt player p) c)
    (pure unit)
    player.tile

displayNextTile :: Context2D -> Board String -> Effect Unit
displayNextTile ctx tile = do
  foldlWithIndex
    (\p m c -> m >>= \_ -> plot ctx (transform {x:11,y:26} p) c)
    (pure unit)
    tile

plot :: Context2D -> Point -> String -> Effect Unit
plot ctx p color = do
  setFillStyle ctx color
  fillPath ctx $ rect ctx
    { x: toNumber (p.x+3) * 16.0 + 1.0
    , y: toNumber p.y     * 16.0 + 1.0
    , width: 14.0
    , height: 14.0
    }

The main trick there was to convert the maps into folds so they could be plot-drawn to the screen. Overall that was not too bad.

Purecript - stuff that was supposed to be out there but wasn't

I thought the pursuitfursuit had the mapKeys but I didn't manage to import it. Instead I had to write it out as a fold that rebuilds the map. Likewise I added function that'd allow me to discard keys and named it mapKeys' in lack of better name.

mapKeys :: forall j k v. Ord j => Ord k => (k -> j) -> Map k v -> Map j v
mapKeys f m = foldlWithIndex
    (\k out v -> insert (f k) v out)
    empty
    m

mapKeys' :: forall j k v. Ord j => Ord k => (k -> Maybe j) -> Map k v -> Map j v
mapKeys' f m = foldlWithIndex
    (\k out v -> case f k of
        Just k' -> insert k' v out
        Nothing -> out)
    empty
    m

Fortunately they were easy to build up after some digging around.

That's how you do it

That's how you'd do it if you were to start straight off from Haskell or Purescript. Here's a recap:

1. Think about what you're supposed to do.
2. Turn it to propositions of what the result or outcome is supposed to be like, eg. graph that has no cycles innit.
3. Convert the propositions into mathematical logic, those become your types.
4. Insult your tools (can be omitted by a beginner, this a difficult task to do well)
5. Spend hours to days trying to find out which way you should do the simplest things such as drawing to a canvas, catching events from your keyboard or setting things off after a set duration.

The results were achieved by going from abstract to concrete. Hardened-enough wizard buttocks shape even the hardest mediums and leave lasting indents.

Similar posts

• Indies vs. Gamers entry: PeacefulForest
• Game Mechanics Taxonomy
• Wasteland 2
• Modeling of Chess in Prolog
• The things you're going to ask with UE4 VR