Two moving rectangles, purescript-signal + purescript-canvas

Main.purs

module Main where

import Prelude

import Data.Lens
import Data.Array
import Data.Maybe
import Math
import Data.Traversable
import Control.Monad.Eff
import Graphics.Canvas as C
import Signal as S
import Signal.DOM as S

width :: Number
width = 1024.0
height :: Number
height = 800.0

main = do
  Just canvas <- C.getCanvasElementById "canvas"
  context <- C.getContext2D canvas
  frames <- S.animationFrame
  arrowsInputs <- arrows
  let input = const <$> arrowsInputs <*> frames
  let game = S.foldp update initialState input
  S.runSignal (render context <$> game)


arrows = do
  leftInput  <- S.keyPressed leftKeyCode
  rightInput <- S.keyPressed rightKeyCode
  upInput    <- S.keyPressed upKeyCode
  downInput  <- S.keyPressed downKeyCode
  let asNum b = if b then 1.0 else 0.0
  pure $  (\l r u d -> { x: asNum r - asNum l, y: asNum d - asNum u } )
      <$> leftInput
      <*> rightInput
      <*> upInput
      <*> downInput

leftKeyCode = 37
rightKeyCode = 39
upKeyCode = 38
downKeyCode = 40

type State
  = { rects :: Array Rectangle }

initialState = { rects : [rect1, rect2] }

update :: Point -> State -> State
update direction state =
  { rects : map (updateRect direction) state.rects }

render :: C.Context2D -> State -> Eff ( canvas :: C.Canvas | _) Unit
render context state = do
  clearCanvas context
  traverse (renderRect context) state.rects
  pure unit

clearCanvas ctx = do
  C.setFillStyle "#1B1C1B" ctx
  C.fillRect ctx { x: 0.0, y: 0.0, w: 1024.0, h: 800.0 }

--

type Point =
  { x :: Number, y :: Number }

type Rectangle =
  { pos :: Point
  , speed :: Number
  , color :: String
  }

rect1 :: Rectangle
rect1 =
  { pos : { x : width / 2.0 - 15.0, y : height / 2.0 - 15.0 }
  , speed : 8.0
  , color : "#0088DD"
  }

rect2 :: Rectangle
rect2 =
  { pos : { x : width / 2.0 - 15.0, y : height / 2.0 - 15.0 }
  , speed : 1.0
  , color : "#0088DD"
  }

updateRect :: Point -> Rectangle -> Rectangle
updateRect direction rect =
  over (pos <<< y) (+ (direction.y * rect.speed)) <<< over (pos <<< x) (+ (direction.x * rect.speed)) $ rect

renderRect :: C.Context2D -> Rectangle -> Eff ( canvas :: C.Canvas | _) Unit
renderRect ctx state = do
  C.setFillStyle state.color ctx
  C.fillRect ctx { x: state.pos.x
                 , y: state.pos.y
                 , w: 30.0, h: 30.0 }
  pure unit

pos = lens _.pos (_ { pos = _ })
x = lens _.x (_ { x = _ })
y = lens _.y (_ { y = _ })