Fixed moving a piece to also remove highlighted square as control is handed to other player

module Checkers.Main where

import Control.Monad.Eff
import Control.Monad.ST
import Control.MonadPlus
import Data.Array
import Data.DOM.Simple.Document
import Data.DOM.Simple.Element
import Data.DOM.Simple.Events
import Data.DOM.Simple.Types
import Data.DOM.Simple.Unsafe.Events
import Data.DOM.Simple.Window
import Data.Int
import Data.Maybe
import Data.Maybe.Unsafe
import Data.Tuple
import DOM
import Graphics.Canvas
import Math (pi)
import Prelude

import Checkers.Constants
import Checkers.Types

createPiece :: Player -> Piece
createPiece player =
  { player: player,
    color:  if player == playerOne then colorPlayerOne else colorPlayerTwo,
    king:   false }

createGrid :: Pixel -> Int -> Int -> Int -> Grid
createGrid offset width height layers = { width: width, height: height, squares: squares }
  where
    squares = do
      x <- 0 .. (width - 1)
      y <- 0 .. (height - 1)
      let rx = (toNumber x) * renderSize
          ry = (toNumber y) * renderSize
          isPieceSquare = ((even x) && (odd y)) || ((even y) && (odd x))
          color = if isPieceSquare then colorSquareOne else colorSquareTwo
          piece = if isPieceSquare && (y < layers)
                  then Just (createPiece playerOne)
                  else if isPieceSquare && (y >= height - layers)
                       then Just (createPiece playerTwo)
                       else Nothing
      return { offset:     offset,
               coordinate: (Tuple x y),
               render:     (Tuple rx ry),
               color:      color,
               piece:      piece }

createState :: Pixel -> Int -> Int -> Int -> State
createState offset width height layers =
  { grid:                  createGrid offset width height layers,
    currentPlayer:         playerOne,
    selectedCoordinate:    Nothing,
    highlightedCoordinate: Nothing }

setPiece :: Maybe Piece -> Square -> Square
setPiece piece square = square { piece = piece }

isValid :: Grid -> Coordinate -> Boolean
isValid grid (Tuple x y) = x >= 0 && x < grid.width && y >= 0 && y < grid.height

hasPlayer :: Player -> Piece -> Boolean
hasPlayer player piece = piece.player == player

hasCoordinate :: Coordinate -> Square -> Boolean
hasCoordinate coordinate square = coordinate == square.coordinate

getSquare :: Array Square -> Coordinate -> Maybe Square
getSquare squares coordinate =
  fromMaybe Nothing $ (squares !!) <$> (findIndex (hasCoordinate coordinate) squares)

hasPlayerPiece :: Array Square -> Coordinate -> Player -> Boolean
hasPlayerPiece squares coordinate player =
  case getSquare squares coordinate of
    Nothing -> false
    Just square -> fromMaybe false $ (hasPlayer player) <$> square.piece

hasPiece :: Array Square -> Coordinate -> Boolean
hasPiece squares coordinate =
  hasPlayerPiece squares coordinate playerOne ||
  hasPlayerPiece squares coordinate playerTwo

getDiagonalSquares :: Coordinate -> Array Coordinate
getDiagonalSquares (Tuple x y) = do
  i <- -2 : (-1 : (1 : (singleton 2)))
  j <- -2 : (-1 : (1 : (singleton 2)))
  return (Tuple (x + i) (y + j))

isOnSquare :: Pixel -> Square -> Boolean
isOnSquare (Tuple x y) square =
  let px = square.render + square.offset
      px' = px + (Tuple renderSize renderSize)
  in fst px < x && x < fst px' && snd px < y && y < snd px'

isOnActiveSquare :: Grid -> Player -> Pixel -> Square -> Boolean
isOnActiveSquare grid player pixel square =
  let moves = getMoves grid player square.coordinate
  in isOnSquare pixel square && not (null moves)

getActiveCoordinate :: Grid -> Player -> Pixel -> Maybe Coordinate
getActiveCoordinate grid player pixel =
  case findIndex (isOnActiveSquare grid player pixel) grid.squares of
    Just index -> _.coordinate <$> grid.squares !! index
    Nothing    -> Nothing

findCoordinate :: Grid -> Player -> Pixel -> Maybe Coordinate
findCoordinate grid player pixel =
  case findIndex (isOnSquare pixel) grid.squares of
    Just index -> _.coordinate <$> grid.squares !! index
    Nothing    -> Nothing

getHighlightCoordinate :: State -> Pixel -> Maybe Coordinate
getHighlightCoordinate state pixel =
  case findCoordinate state.grid state.currentPlayer pixel of
    Nothing -> Nothing
    Just to -> do
      case state.selectedCoordinate of
        Nothing -> getActiveCoordinate state.grid state.currentPlayer pixel
        Just from ->
          if isValidMove state.grid state.currentPlayer from to
          then Just to
          else getActiveCoordinate state.grid state.currentPlayer pixel

isValidMove :: Grid -> Player -> Coordinate -> Coordinate -> Boolean
isValidMove grid player from to =
  let d1 = from + Tuple   1    1
      d2 = from + Tuple (-1)   1
      d3 = from + Tuple   1  (-1)
      d4 = from + Tuple (-1) (-1)
      d5 = from + Tuple   2    2
      d6 = from + Tuple (-2)   2
      d7 = from + Tuple   2  (-2)
      d8 = from + Tuple (-2) (-2)
      p1 = player == playerOne && ((d1 == to) || (d2 == to) ||
                                   (d5 == to && hasPlayerPiece grid.squares d1 playerTwo) ||
                                   (d6 == to && hasPlayerPiece grid.squares d2 playerTwo))
      p2 = player == playerTwo && ((d3 == to) || (d4 == to) ||
                                   (d7 == to && hasPlayerPiece grid.squares d3 playerOne) ||
                                   (d8 == to && hasPlayerPiece grid.squares d4 playerOne))
  in isValid grid to && not hasPiece grid.squares to && (p1 || p2)

getMoves :: Grid -> Player -> Coordinate -> Array Coordinate
getMoves grid player coordinate = do
  guard $ hasPlayerPiece grid.squares coordinate player
  potential <- getDiagonalSquares coordinate
  guard $ isValidMove grid player coordinate potential
  return potential

alterPiece :: Maybe Piece -> Coordinate -> Grid -> Grid
alterPiece piece coordinate grid = grid { squares = newSquares }
  where
    index = fromJust (findIndex (hasCoordinate coordinate) grid.squares)
    newSquares = fromJust (modifyAt index (setPiece piece) grid.squares)

removePiece :: Coordinate -> Grid -> Grid
removePiece = alterPiece Nothing

movePiece :: Coordinate -> Coordinate -> Grid -> Grid
movePiece from to grid = removePiece from (alterPiece originalSquare.piece to grid)
    where
      fromIndex = fromJust (findIndex (hasCoordinate from) grid.squares)
      originalSquare = fromJust (grid.squares !! fromIndex)

otherPlayer :: Player -> Player
otherPlayer (Player 1) = Player 2
otherPlayer (Player 2) = Player 1
otherPlayer _          = Player 1

renderSquare :: forall e.
                  Context2D ->
                  Unit ->
                  Square ->
                  Eff (canvas :: Canvas, dom :: DOM | e) Unit
renderSquare ctx _ square = do
  setFillStyle square.color ctx
  fillRect ctx { x: fst square.render,
                 y: snd square.render,
                 w: renderSize,
                 h: renderSize }
  return unit

renderPiece :: forall e.
                 State ->
                 Context2D ->
                 Unit ->
                 Square ->
                 Eff (canvas :: Canvas, dom :: DOM | e) Unit
renderPiece state ctx _ square = do
  case square.piece of
    Just piece -> do
      setFillStyle piece.color ctx
      let arcPiece = { x: fst square.render + 0.5 * renderSize,
                       y: snd square.render + 0.5 * renderSize,
                       r: (renderSize / 2.0) * 0.8,
                       start: 0.0,
                       end: 2.0 * pi }
      fillPath ctx $ arc ctx arcPiece
      return unit
    _ -> return unit

renderBorder :: forall e. Context2D -> Grid -> Eff (canvas :: Canvas | e) Unit
renderBorder ctx grid = do
  let border = { x: 0.5,
                 y: 0.5,
                 w: (toNumber grid.width) * renderSize - 0.5,
                 h: (toNumber grid.height) * renderSize - 0.5 }
  setStrokeStyle colorBorder ctx
  strokeRect ctx border
  return unit

renderHighlight :: forall e.
                     Context2D ->
                     Array Square ->
                     Maybe Coordinate ->
                     Eff (canvas :: Canvas, dom :: DOM | e) Unit
renderHighlight ctx squares selection = do
  case selection of
    Nothing -> return unit
    Just coordinate -> do
      let square = fromJust (getSquare squares coordinate)
          arcPiece = { x:     fst square.render + 0.5 * renderSize,
                       y:     snd square.render + 0.5 * renderSize,
                       r:     (renderSize / 2.0) * 0.8,
                       start: 0.0,
                       end:   2.0 * pi }
      setLineWidth highlightWidth ctx
      strokePath ctx $ arc ctx arcPiece
      return unit

render :: forall s e.
            Context2D ->
            STRef s State ->
            Eff (st :: ST s, canvas :: Canvas, dom :: DOM | e) Unit
render ctx st = do
  state <- readSTRef st
  withContext ctx $ do
    foldM (renderSquare ctx) unit state.grid.squares
  withContext ctx $ do
    foldM (renderPiece state ctx) unit state.grid.squares
  withContext ctx $ do
    renderBorder ctx state.grid
  withContext ctx $ do
    renderHighlight ctx state.grid.squares state.selectedCoordinate
  withContext ctx $ do
    renderHighlight ctx state.grid.squares state.highlightedCoordinate
  return unit

renderPage :: forall s e.
                STRef s State ->
                Eff (st :: ST s, canvas :: Canvas, dom :: DOM | e) Unit
renderPage st = do
  element <- getCanvasElementById "canvas"
  case element of
    Just canvas -> do
      setCanvasDimensions renderDimension canvas
      ctx <- getContext2D canvas
      render ctx st
      return unit
    _ -> return unit
  return unit

moveListener :: forall s e.
                  STRef s State ->
                  DOMEvent ->
                  Eff (st :: ST s, canvas :: Canvas, dom :: DOM | e) Unit
moveListener st e = do
  ux <- unsafeEventNumberProp "clientX" e
  uy <- unsafeEventNumberProp "clientY" e
  state <- readSTRef st
  let pixel = (Tuple (toNumber ux) (toNumber uy))
      highlightedCoordinate = getHighlightCoordinate state pixel
  writeSTRef st $ state { highlightedCoordinate = highlightedCoordinate }
  renderPage st
  return unit

clickListener :: forall s e.
                   STRef s State ->
                   DOMEvent ->
                   Eff (st :: ST s, canvas :: Canvas, dom :: DOM | e) Unit
clickListener st e = do
  element <- getCanvasElementById "canvas"
  case element of
    Just canvas -> do
      state <- readSTRef st
      ux <- unsafeEventNumberProp "clientX" e
      uy <- unsafeEventNumberProp "clientY" e
      let pixel = Tuple (toNumber ux) (toNumber uy)
          toCoordinate = getHighlightCoordinate state pixel
      case toCoordinate of
        Nothing -> return unit
        Just to -> do
          case state.selectedCoordinate of
            Nothing -> do
              writeSTRef st $ state { selectedCoordinate = Just to }
              renderPage st
              return unit
            Just from -> do
              case isValidMove state.grid state.currentPlayer from to of
                false -> do
                  writeSTRef st $ state { selectedCoordinate = if to == from
                                                               then Nothing
                                                               else Just to }
                  renderPage st
                  return unit
                true -> do
                  writeSTRef st $ state { highlightedCoordinate = Nothing,
                                          selectedCoordinate = Nothing,
                                          grid = movePiece from to state.grid,
                                          currentPlayer = otherPlayer state.currentPlayer }
                  renderPage st
                  return unit
    _ -> return unit
  return unit

main :: forall s e. Eff (st :: ST s, canvas :: Canvas, dom :: DOM | e) Unit
main = do
  doc <- document globalWindow
  mcanvas <- getElementById "canvas" doc
  case mcanvas of
    Just canvas -> do
      x <- offsetLeft canvas
      y <- offsetTop canvas
      let offset = (Tuple (toNumber x) (toNumber y))
      st <- newSTRef (createState offset defaultWidth defaultHeight layerCount)
      addMouseEventListener MouseMoveEvent (moveListener st) canvas
      addMouseEventListener MouseClickEvent (clickListener st) canvas
      renderPage st
      return unit
    _ -> return unit

module Checkers.Main where

import Control.Monad.Eff
import Control.Monad.ST
import Control.MonadPlus
import Data.Array
import Data.DOM.Simple.Document
import Data.DOM.Simple.Element
import Data.DOM.Simple.Events
import Data.DOM.Simple.Types
import Data.DOM.Simple.Unsafe.Events
import Data.DOM.Simple.Window
import Data.Int
import Data.Maybe
import Data.Maybe.Unsafe
import Data.Tuple
import DOM
import Graphics.Canvas
import Math (pi)
import Prelude

import Checkers.Constants
import Checkers.Types

createPiece :: Player -> Piece
createPiece player =
  { player: player,
    color:  if player == playerOne then colorPlayerOne else colorPlayerTwo,
    king:   false }

createGrid :: Pixel -> Int -> Int -> Int -> Grid
createGrid offset width height layers = { width: width, height: height, squares: squares }
  where
    squares = do
      x <- 0 .. (width - 1)
      y <- 0 .. (height - 1)
      let rx = (toNumber x) * renderSize
          ry = (toNumber y) * renderSize
          isPieceSquare = ((even x) && (odd y)) || ((even y) && (odd x))
          color = if isPieceSquare then colorSquareOne else colorSquareTwo
          piece = if isPieceSquare && (y < layers)
                  then Just (createPiece playerOne)
                  else if isPieceSquare && (y >= height - layers)
                       then Just (createPiece playerTwo)
                       else Nothing
      return { offset:     offset,
               coordinate: (Tuple x y),
               render:     (Tuple rx ry),
               color:      color,
               piece:      piece }

createState :: Pixel -> Int -> Int -> Int -> State
createState offset width height layers =
  { grid:                  createGrid offset width height layers,
    currentPlayer:         playerOne,
    selectedCoordinate:    Nothing,
    highlightedCoordinate: Nothing }

setPiece :: Maybe Piece -> Square -> Square
setPiece piece square = square { piece = piece }

isValid :: Grid -> Coordinate -> Boolean
isValid grid (Tuple x y) = x >= 0 && x < grid.width && y >= 0 && y < grid.height

hasPlayer :: Player -> Piece -> Boolean
hasPlayer player piece = piece.player == player

hasCoordinate :: Coordinate -> Square -> Boolean
hasCoordinate coordinate square = coordinate == square.coordinate

getSquare :: Array Square -> Coordinate -> Maybe Square
getSquare squares coordinate =
  fromMaybe Nothing $ (squares !!) <$> (findIndex (hasCoordinate coordinate) squares)

hasPlayerPiece :: Array Square -> Coordinate -> Player -> Boolean
hasPlayerPiece squares coordinate player =
  case getSquare squares coordinate of
    Nothing -> false
    Just square -> fromMaybe false $ (hasPlayer player) <$> square.piece

hasPiece :: Array Square -> Coordinate -> Boolean
hasPiece squares coordinate =
  hasPlayerPiece squares coordinate playerOne ||
  hasPlayerPiece squares coordinate playerTwo

getDiagonalSquares :: Coordinate -> Array Coordinate
getDiagonalSquares (Tuple x y) = do
  i <- -2 : (-1 : (1 : (singleton 2)))
  j <- -2 : (-1 : (1 : (singleton 2)))
  return (Tuple (x + i) (y + j))

isOnSquare :: Pixel -> Square -> Boolean
isOnSquare (Tuple x y) square =
  let px = square.render + square.offset
      px' = px + (Tuple renderSize renderSize)
  in fst px < x && x < fst px' && snd px < y && y < snd px'

isOnActiveSquare :: Grid -> Player -> Pixel -> Square -> Boolean
isOnActiveSquare grid player pixel square =
  let moves = getMoves grid player square.coordinate
  in isOnSquare pixel square && not (null moves)

getActiveCoordinate :: Grid -> Player -> Pixel -> Maybe Coordinate
getActiveCoordinate grid player pixel =
  case findIndex (isOnActiveSquare grid player pixel) grid.squares of
    Just index -> _.coordinate <$> grid.squares !! index
    Nothing    -> Nothing

findCoordinate :: Grid -> Player -> Pixel -> Maybe Coordinate
findCoordinate grid player pixel =
  case findIndex (isOnSquare pixel) grid.squares of
    Just index -> _.coordinate <$> grid.squares !! index
    Nothing    -> Nothing

getHighlightCoordinate :: State -> Pixel -> Maybe Coordinate
getHighlightCoordinate state pixel =
  case findCoordinate state.grid state.currentPlayer pixel of
    Nothing -> Nothing
    Just to -> do
      case state.selectedCoordinate of
        Nothing -> getActiveCoordinate state.grid state.currentPlayer pixel
        Just from ->
          if isValidMove state.grid state.currentPlayer from to
          then Just to
          else getActiveCoordinate state.grid state.currentPlayer pixel

isValidMove :: Grid -> Player -> Coordinate -> Coordinate -> Boolean
isValidMove grid player from to =
  let d1 = from + Tuple   1    1
      d2 = from + Tuple (-1)   1
      d3 = from + Tuple   1  (-1)
      d4 = from + Tuple (-1) (-1)
      d5 = from + Tuple   2    2
      d6 = from + Tuple (-2)   2
      d7 = from + Tuple   2  (-2)
      d8 = from + Tuple (-2) (-2)
      p1 = player == playerOne && ((d1 == to) || (d2 == to) ||
                                   (d5 == to && hasPlayerPiece grid.squares d1 playerTwo) ||
                                   (d6 == to && hasPlayerPiece grid.squares d2 playerTwo))
      p2 = player == playerTwo && ((d3 == to) || (d4 == to) ||
                                   (d7 == to && hasPlayerPiece grid.squares d3 playerOne) ||
                                   (d8 == to && hasPlayerPiece grid.squares d4 playerOne))
  in isValid grid to && not hasPiece grid.squares to && (p1 || p2)

getMoves :: Grid -> Player -> Coordinate -> Array Coordinate
getMoves grid player coordinate = do
  guard $ hasPlayerPiece grid.squares coordinate player
  potential <- getDiagonalSquares coordinate
  guard $ isValidMove grid player coordinate potential
  return potential

alterPiece :: Maybe Piece -> Coordinate -> Grid -> Grid
alterPiece piece coordinate grid = grid { squares = newSquares }
  where
    index = fromJust (findIndex (hasCoordinate coordinate) grid.squares)
    newSquares = fromJust (modifyAt index (setPiece piece) grid.squares)

removePiece :: Coordinate -> Grid -> Grid
removePiece = alterPiece Nothing

movePiece :: Coordinate -> Coordinate -> Grid -> Grid
movePiece from to grid = removePiece from (alterPiece originalSquare.piece to grid)
    where
      fromIndex = fromJust (findIndex (hasCoordinate from) grid.squares)
      originalSquare = fromJust (grid.squares !! fromIndex)

otherPlayer :: Player -> Player
otherPlayer (Player 1) = Player 2
otherPlayer (Player 2) = Player 1
otherPlayer _          = Player 1

renderSquare :: forall e.
                  Context2D ->
                  Unit ->
                  Square ->
                  Eff (canvas :: Canvas, dom :: DOM | e) Unit
renderSquare ctx _ square = do
  setFillStyle square.color ctx
  fillRect ctx { x: fst square.render,
                 y: snd square.render,
                 w: renderSize,
                 h: renderSize }
  return unit

renderPiece :: forall e.
                 State ->
                 Context2D ->
                 Unit ->
                 Square ->
                 Eff (canvas :: Canvas, dom :: DOM | e) Unit
renderPiece state ctx _ square = do
  case square.piece of
    Just piece -> do
      setFillStyle piece.color ctx
      let arcPiece = { x: fst square.render + 0.5 * renderSize,
                       y: snd square.render + 0.5 * renderSize,
                       r: (renderSize / 2.0) * 0.8,
                       start: 0.0,
                       end: 2.0 * pi }
      fillPath ctx $ arc ctx arcPiece
      return unit
    _ -> return unit

renderBorder :: forall e. Context2D -> Grid -> Eff (canvas :: Canvas | e) Unit
renderBorder ctx grid = do
  let border = { x: 0.5,
                 y: 0.5,
                 w: (toNumber grid.width) * renderSize - 0.5,
                 h: (toNumber grid.height) * renderSize - 0.5 }
  setStrokeStyle colorBorder ctx
  strokeRect ctx border
  return unit

renderHighlight :: forall e.
                     Context2D ->
                     Array Square ->
                     Maybe Coordinate ->
                     Eff (canvas :: Canvas, dom :: DOM | e) Unit
renderHighlight ctx squares selection = do
  case selection of
    Nothing -> return unit
    Just coordinate -> do
      let square = fromJust (getSquare squares coordinate)
          arcPiece = { x:     fst square.render + 0.5 * renderSize,
                       y:     snd square.render + 0.5 * renderSize,
                       r:     (renderSize / 2.0) * 0.8,
                       start: 0.0,
                       end:   2.0 * pi }
      setLineWidth highlightWidth ctx
      strokePath ctx $ arc ctx arcPiece
      return unit

render :: forall s e.
            Context2D ->
            STRef s State ->
            Eff (st :: ST s, canvas :: Canvas, dom :: DOM | e) Unit
render ctx st = do
  state <- readSTRef st
  withContext ctx $ do
    foldM (renderSquare ctx) unit state.grid.squares
  withContext ctx $ do
    foldM (renderPiece state ctx) unit state.grid.squares
  withContext ctx $ do
    renderBorder ctx state.grid
  withContext ctx $ do
    renderHighlight ctx state.grid.squares state.selectedCoordinate
  withContext ctx $ do
    renderHighlight ctx state.grid.squares state.highlightedCoordinate
  return unit

renderPage :: forall s e.
                STRef s State ->
                Eff (st :: ST s, canvas :: Canvas, dom :: DOM | e) Unit
renderPage st = do
  element <- getCanvasElementById "canvas"
  case element of
    Just canvas -> do
      setCanvasDimensions renderDimension canvas
      ctx <- getContext2D canvas
      render ctx st
      return unit
    _ -> return unit
  return unit

moveListener :: forall s e.
                  STRef s State ->
                  DOMEvent ->
                  Eff (st :: ST s, canvas :: Canvas, dom :: DOM | e) Unit
moveListener st e = do
  ux <- unsafeEventNumberProp "clientX" e
  uy <- unsafeEventNumberProp "clientY" e
  state <- readSTRef st
  let pixel = (Tuple (toNumber ux) (toNumber uy))
      highlightedCoordinate = getHighlightCoordinate state pixel
  writeSTRef st $ state { highlightedCoordinate = highlightedCoordinate }
  renderPage st
  return unit

clickListener :: forall s e.
                   STRef s State ->
                   DOMEvent ->
                   Eff (st :: ST s, canvas :: Canvas, dom :: DOM | e) Unit
clickListener st e = do
  element <- getCanvasElementById "canvas"
  case element of
    Just canvas -> do
      state <- readSTRef st
      ux <- unsafeEventNumberProp "clientX" e
      uy <- unsafeEventNumberProp "clientY" e
      let pixel = Tuple (toNumber ux) (toNumber uy)
          toCoordinate = getHighlightCoordinate state pixel
      case toCoordinate of
        Nothing -> return unit
        Just to -> do
          case state.selectedCoordinate of
            Nothing -> do
              writeSTRef st $ state { selectedCoordinate = Just to }
              renderPage st
              return unit
            Just from -> do
              case isValidMove state.grid state.currentPlayer from to of
                false -> do
                  writeSTRef st $ state { selectedCoordinate = if to == from
                                                               then Nothing
                                                               else Just to }
                  renderPage st
                  return unit
                true -> do
                  writeSTRef st $ state { selectedCoordinate = Nothing,
                                          grid = movePiece from to state.grid,
                                          currentPlayer = otherPlayer state.currentPlayer }
                  renderPage st
                  return unit
    _ -> return unit
  return unit

main :: forall s e. Eff (st :: ST s, canvas :: Canvas, dom :: DOM | e) Unit
main = do
  doc <- document globalWindow
  mcanvas <- getElementById "canvas" doc
  case mcanvas of
    Just canvas -> do
      x <- offsetLeft canvas
      y <- offsetTop canvas
      let offset = (Tuple (toNumber x) (toNumber y))
      st <- newSTRef (createState offset defaultWidth defaultHeight layerCount)
      addMouseEventListener MouseMoveEvent (moveListener st) canvas
      addMouseEventListener MouseClickEvent (clickListener st) canvas
      renderPage st
      return unit
    _ -> return unit


Eval sections to binary

Eval sections to binary

Replace sections with binary operations if they can't be evaluated
directly.

module Evaluator
  ( Path(..)
  , Env()
  , evalPath1
  , defsToEnv
  ) where

import Data.Array    (head, mapMaybe, (!!), updateAt, elemIndex, length, concat, concatMap, nub, (\\), intersect, drop)
import Data.StrMap   (StrMap(), empty, lookup, insert, delete, values)
import Data.Tuple    (Tuple(Tuple), fst, snd)
import Data.Maybe
import Data.Foldable (foldl, foldr, foldMap, any)
import Data.Traversable (zipWithA, traverse)
import Data.Identity
import Data.Either

import Math (pow)

import Control.Apply ((*>))
import Control.Alt ((<|>))
import qualified Control.Plus as P
import Control.Monad.State
import Control.Monad.State.Trans
import Control.Monad.State.Class

import Control.Monad.Writer
import Control.Monad.Writer.Trans
import Control.Monad.Writer.Class

import Control.Monad.Error
import Control.Monad.Error.Trans
import Control.Monad.Error.Class

import Control.Monad.Trans

import AST

type Matching = Tuple Atom Expr

type Evaluator = ErrorT String Identity

runEvalM :: forall a. Evaluator a -> Either String a
runEvalM = runIdentity <<< runErrorT

data Path = Nth Number Path
          | Fst Path
          | Snd Path
          | Thrd Path
          | End

instance showPath :: Show Path where
  show p = case p of
    Nth i p -> "(Nth " ++ show i ++ " " ++ show p ++")"
    Fst   p -> "(Fst " ++ show p ++")"
    Snd   p -> "(Snd " ++ show p ++")"
    Thrd   p -> "(Thrd " ++ show p ++")"
    End     -> "End"

mapWithPath :: Path -> (Expr -> Evaluator Expr) -> Expr -> Evaluator Expr
mapWithPath p f = go p
  where
  go End e     = f e
  go (Fst p) e = case e of
    Binary op e1 e2 -> Binary op <$> go p e1 <*> pure e2
    Unary op e      -> Unary op  <$> go p e
    SectL e op      -> SectL     <$> go p e <*> pure op
    IfExpr ce te ee -> IfExpr <$> go p ce <*> pure te <*> pure ee
    Lambda bs body  -> Lambda bs <$> go p body
    App e es        -> App       <$> go p e <*> pure es
    _               -> throwError $ "Cannot match " ++ show (Fst p) ++ " with " ++ show e
  go (Snd p) e = case e of
    Binary op e1 e2 -> Binary op e1 <$> go p e2
    SectR op e      -> SectR op     <$> go p e
    IfExpr ce te ee -> IfExpr <$> pure ce <*> go p te <*> pure ee
    _               -> throwError $ "Cannot match " ++ show (Snd p) ++ " with " ++ show e
  go (Thrd p) e = case e of
    IfExpr ce te ee -> IfExpr <$> pure ce <*> pure te <*> go p ee
    _               -> throwError $ "Cannot match " ++ show (Thrd p) ++ " with " ++ show e
  go (Nth n p) e = case e of
    List es  -> List  <$> mapIndex n (go p) es
    NTuple es -> NTuple <$> mapIndex n (go p) es
    App e es -> App e <$> mapIndex n (go p) es
    _        -> throwError $ "Cannot match " ++ show (Nth n p) ++ " with " ++ show e

mapIndex :: forall m a. Number -> (a -> Evaluator a) -> [a] -> Evaluator [a]
mapIndex i f as = do
  case as !! i of
    Nothing -> throwError $ "Nothing at index " ++ show i ++ "! (length = " ++ show (length as) ++ ")"
    Just a  -> do
      a' <- f a
      return $ updateAt i a' as

evalPath1 :: Env -> Path -> Expr -> Either String Expr
evalPath1 env path expr = runEvalM $ mapWithPath path (eval1 env) expr

type Env = StrMap [Tuple [Binding] Expr]

defsToEnv :: [Definition] -> Env
defsToEnv = foldl insertDef empty

insertDef :: Env -> Definition -> Env
insertDef env (Def name bindings body) = case lookup name env of
  Nothing   -> insert name [Tuple bindings body] env
  Just defs -> insert name (defs ++ [Tuple bindings body]) env

eval1 :: Env -> Expr -> Evaluator Expr
eval1 env expr = case expr of
  (Binary op e1 e2)                  -> binary op e1 e2
  (Unary op e)                       -> unary op e
  (Atom (Name name))                 -> apply env name []
  (IfExpr (Atom (Bool true)) te _)   -> return te
  (IfExpr (Atom (Bool false)) _ ee)  -> return ee
--  (List (e:es))                      -> return $ Binary Cons e (List es)
  (App (Binary Composition f g) [e]) -> return $ App f [App g [e]]
  (App (Lambda binds body) args)     -> matchls' binds args >>= flip replace' body >>= wrapLambda binds args
  (App (SectL e1 op) [e2])           -> binary op e1 e2 <|> (return $ Binary op e1 e2)
  (App (SectR op e2) [e1])           -> binary op e1 e2 <|> (return $ Binary op e1 e2)
  (App (Prefix op) [e1, e2])         -> binary op e1 e2 <|> (return $ Binary op e1 e2)
  (App (Atom (Name name)) args)      -> apply env name args
  (App (App func es) es')            -> return $ App func (es ++ es')
  _ -> throwError $ "Cannot evaluate " ++ show expr

wrapLambda :: [Binding] -> [Expr] -> Expr -> Evaluator Expr
wrapLambda binds args body =
  case compare (length binds) (length args) of
    EQ -> return body
    GT -> return $ Lambda (drop (length args) binds) body
    LT -> return $ App body (drop (length binds) args)

binary :: Op -> Expr -> Expr -> Evaluator Expr
binary = go
  where
  retA = return <<< Atom
  go Power (Atom (Num i)) (Atom (Num j)) = retA $ Num $ pow i j

  go Mul (Atom (Num i)) (Atom (Num j)) = retA $ Num $ i * j
  go Div (Atom (Num i)) (Atom (Num 0)) = throwError "Division by zero!"
  go Div (Atom (Num i)) (Atom (Num j)) = retA $ Num $ Math.floor (i / j)
  go Mod (Atom (Num i)) (Atom (Num 0)) = throwError "Mod by zero!"
  go Mod (Atom (Num i)) (Atom (Num j)) = retA $ Num $ i % j

  go Add (Atom (Num i)) (Atom (Num j)) = retA $ Num $ i + j
  go Sub (Atom (Num i)) (Atom (Num j)) = retA $ Num $ i - j

  go Cons   e          (List es)  = return $ List $ e:es
  go Append (List es1) (List es2) = return $ List $ es1 ++ es2

  go Eq  (Atom a1) (Atom a2) = retA $ Bool $ a1 == a2
  go Neq (Atom a1) (Atom a2) = retA $ Bool $ a1 /= a2
  go Leq (Atom (Num i)) (Atom (Num j)) = retA $ Bool $ i <= j
  go Lt  (Atom (Num i)) (Atom (Num j)) = retA $ Bool $ i < j
  go Geq (Atom (Num i)) (Atom (Num j)) = retA $ Bool $ i >= j
  go Gt  (Atom (Num i)) (Atom (Num j)) = retA $ Bool $ i > j

  go And (Atom (Bool true))  b = return b
  go And (Atom (Bool false)) _ = retA $ Bool $ false

  go Or  (Atom (Bool true))  _ = retA $ Bool $ true
  go Or  (Atom (Bool false)) b = return b

  go Dollar f e = return $ App f [e]

  go op e1 e2 = throwError $ "Cannot apply operator " ++ show op ++  " to " ++ show e1 ++ " and " ++ show e2

unary :: Op -> Expr -> Evaluator Expr
unary Sub (Atom (Num i)) = return $ Atom $ Num (-i)
unary op e = throwError $ "Cannot apply unary operator " ++ show op ++ " to " ++ show e

apply :: Env -> String -> [Expr] -> Evaluator Expr
apply env name args = case lookup name env of
  Nothing    -> throwError $ "Unknown function: " ++ name
  Just cases -> case runEvalM $ foldl (<|>) P.empty (app <$> cases) of
    Right expr -> return expr
    Left msg   -> throwError $ "No matching funnction found for " ++ name ++ "(last reason: " ++ msg ++ ")"
  where
  app :: Tuple [Binding] Expr -> Evaluator Expr
  app (Tuple binds body) | length binds == length args = matchls' binds args >>= flip replace' body
                         | otherwise                   = throwError $ "Wrong number of arguments!"

matchls' :: [Binding] -> [Expr] -> Evaluator (StrMap Expr)
matchls' bs es = execStateT (zipWithA match' bs es) empty

match' :: Binding -> Expr -> StateT (StrMap Expr) Evaluator Unit
match' (Lit (Name name)) e                             = modify (insert name e)
match' (Lit ba)          (Atom ea)          | ba == ea = return unit
match' (ConsLit b bs)    (Binary Cons e es)            = match' b e *> match' bs es
match' (ConsLit b bs)    (List (e:es))                 = match' (ConsLit b bs) (Binary Cons e (List es))
match' (ListLit bs)      (List es)          | length bs == length es = void $ zipWithA match' bs es
match' (ListLit bs)      (Binary Cons e (List es))     = match' (ListLit bs) (List (e:es))
match' (NTupleLit bs)    (NTuple es)        | length bs == length es = void $ zipWithA match' bs es
match' b                 e                             = throwError $ "Cannot match " ++ show b ++ " with " ++ show e

replace' :: StrMap Expr -> Expr -> Evaluator Expr
replace' subs = go
  where
  go expr = case expr of
    a@(Atom (Name name)) -> case lookup name subs of
      Just subExpr -> return subExpr
      Nothing      -> return a
    (List exprs)         -> List <$> (traverse go exprs)
    (NTuple exprs)       -> NTuple <$> (traverse go exprs)
    (Binary op e1 e2)    -> Binary <$> pure op <*> go e1 <*> go e2
    (Unary op e)         -> Unary <$> pure op <*> go e
    (SectL e op)         -> SectL <$> go e <*> pure op
    (SectR op e)         -> SectR <$> pure op <*> go e
    (IfExpr ce te ee)    -> IfExpr <$> go ce <*> go te <*> go ee
    (Lambda binds body)  -> (avoidCapture subs binds) *> (Lambda <$> pure binds <*> replace' (foldr delete subs (boundNames' binds)) body)
    (App func exprs)     -> App <$> go func <*> traverse go exprs
    e                    -> return e

avoidCapture :: StrMap Expr -> [Binding] -> Evaluator Unit
avoidCapture subs binds = case intersect (concatMap freeVariables $ values subs) (boundNames' binds) of
  []       -> return unit
  captures -> throwError $ "Some variables have been captured: " ++ show captures

freeVariables :: Expr -> [String]
freeVariables = nub <<< foldExpr
  (\a -> case a of
    Name name -> [name]
    _         -> [])
  concat
  concat
  (\_ f1 f2 -> f1 ++ f2)
  (\_ f -> f)
  (\f _ -> f)
  (\_ f -> f)
  (\_ -> [])
  (\f1 f2 f3 -> f1 ++ f2 ++ f3)
  (\bs f -> nub f \\ boundNames' bs)
  (\f fs -> f ++ concat fs)

boundNames' :: [Binding] -> [String]
boundNames' = concatMap boundNames

boundNames :: Binding -> [String]
boundNames = go
  where
  go (Lit (Name name)) = [name]
  go (ConsLit b1 b2)   = go b1 ++ go b2
  go (ListLit bs)      = foldMap go bs
  go (NTupleLit bs)    = foldMap go bs

module Evaluator
  ( Path(..)
  , Env()
  , evalPath1
  , defsToEnv
  ) where

import Data.Array    (head, mapMaybe, (!!), updateAt, elemIndex, length, concat, concatMap, nub, (\\), intersect, drop)
import Data.StrMap   (StrMap(), empty, lookup, insert, delete, values)
import Data.Tuple    (Tuple(Tuple), fst, snd)
import Data.Maybe
import Data.Foldable (foldl, foldr, foldMap, any)
import Data.Traversable (zipWithA, traverse)
import Data.Identity
import Data.Either

import Math (pow)

import Control.Apply ((*>))
import Control.Alt ((<|>))
import qualified Control.Plus as P
import Control.Monad.State
import Control.Monad.State.Trans
import Control.Monad.State.Class

import Control.Monad.Writer
import Control.Monad.Writer.Trans
import Control.Monad.Writer.Class

import Control.Monad.Error
import Control.Monad.Error.Trans
import Control.Monad.Error.Class

import Control.Monad.Trans

import AST

type Matching = Tuple Atom Expr

type Evaluator = ErrorT String Identity

runEvalM :: forall a. Evaluator a -> Either String a
runEvalM = runIdentity <<< runErrorT

data Path = Nth Number Path
          | Fst Path
          | Snd Path
          | Thrd Path
          | End

instance showPath :: Show Path where
  show p = case p of
    Nth i p -> "(Nth " ++ show i ++ " " ++ show p ++")"
    Fst   p -> "(Fst " ++ show p ++")"
    Snd   p -> "(Snd " ++ show p ++")"
    Thrd   p -> "(Thrd " ++ show p ++")"
    End     -> "End"

mapWithPath :: Path -> (Expr -> Evaluator Expr) -> Expr -> Evaluator Expr
mapWithPath p f = go p
  where
  go End e     = f e
  go (Fst p) e = case e of
    Binary op e1 e2 -> Binary op <$> go p e1 <*> pure e2
    Unary op e      -> Unary op  <$> go p e
    SectL e op      -> SectL     <$> go p e <*> pure op
    IfExpr ce te ee -> IfExpr <$> go p ce <*> pure te <*> pure ee
    Lambda bs body  -> Lambda bs <$> go p body
    App e es        -> App       <$> go p e <*> pure es
    _               -> throwError $ "Cannot match " ++ show (Fst p) ++ " with " ++ show e
  go (Snd p) e = case e of
    Binary op e1 e2 -> Binary op e1 <$> go p e2
    SectR op e      -> SectR op     <$> go p e
    IfExpr ce te ee -> IfExpr <$> pure ce <*> go p te <*> pure ee
    _               -> throwError $ "Cannot match " ++ show (Snd p) ++ " with " ++ show e
  go (Thrd p) e = case e of
    IfExpr ce te ee -> IfExpr <$> pure ce <*> pure te <*> go p ee
    _               -> throwError $ "Cannot match " ++ show (Thrd p) ++ " with " ++ show e
  go (Nth n p) e = case e of
    List es  -> List  <$> mapIndex n (go p) es
    NTuple es -> NTuple <$> mapIndex n (go p) es
    App e es -> App e <$> mapIndex n (go p) es
    _        -> throwError $ "Cannot match " ++ show (Nth n p) ++ " with " ++ show e

mapIndex :: forall m a. Number -> (a -> Evaluator a) -> [a] -> Evaluator [a]
mapIndex i f as = do
  case as !! i of
    Nothing -> throwError $ "Nothing at index " ++ show i ++ "! (length = " ++ show (length as) ++ ")"
    Just a  -> do
      a' <- f a
      return $ updateAt i a' as

evalPath1 :: Env -> Path -> Expr -> Either String Expr
evalPath1 env path expr = runEvalM $ mapWithPath path (eval1 env) expr

type Env = StrMap [Tuple [Binding] Expr]

defsToEnv :: [Definition] -> Env
defsToEnv = foldl insertDef empty

insertDef :: Env -> Definition -> Env
insertDef env (Def name bindings body) = case lookup name env of
  Nothing   -> insert name [Tuple bindings body] env
  Just defs -> insert name (defs ++ [Tuple bindings body]) env

eval1 :: Env -> Expr -> Evaluator Expr
eval1 env expr = case expr of
  (Binary op e1 e2)                  -> binary op e1 e2
  (Unary op e)                       -> unary op e
  (Atom (Name name))                 -> apply env name []
  (IfExpr (Atom (Bool true)) te _)   -> return te
  (IfExpr (Atom (Bool false)) _ ee)  -> return ee
--  (List (e:es))                      -> return $ Binary Cons e (List es)
  (App (Binary Composition f g) [e]) -> return $ App f [App g [e]]
  (App (Lambda binds body) args)     -> matchls' binds args >>= flip replace' body >>= wrapLambda binds args
  (App (SectL e1 op) [e2])           -> binary op e1 e2 --return $ Binary op e1 e2
  (App (SectR op e2) [e1])           -> binary op e1 e2 --return $ Binary op e1 e2
  (App (Prefix op) [e1, e2])         -> binary op e1 e2 --return $ Binary op e1 e2
  (App (Atom (Name name)) args)      -> apply env name args
  (App (App func es) es')            -> return $ App func (es ++ es')
  _ -> throwError $ "Cannot evaluate " ++ show expr

wrapLambda :: [Binding] -> [Expr] -> Expr -> Evaluator Expr
wrapLambda binds args body =
  case compare (length binds) (length args) of
    EQ -> return body
    GT -> return $ Lambda (drop (length args) binds) body
    LT -> return $ App body (drop (length binds) args)

binary :: Op -> Expr -> Expr -> Evaluator Expr
binary = go
  where
  retA = return <<< Atom
  go Power (Atom (Num i)) (Atom (Num j)) = retA $ Num $ pow i j

  go Mul (Atom (Num i)) (Atom (Num j)) = retA $ Num $ i * j
  go Div (Atom (Num i)) (Atom (Num 0)) = throwError "Division by zero!"
  go Div (Atom (Num i)) (Atom (Num j)) = retA $ Num $ Math.floor (i / j)
  go Mod (Atom (Num i)) (Atom (Num 0)) = throwError "Mod by zero!"
  go Mod (Atom (Num i)) (Atom (Num j)) = retA $ Num $ i % j

  go Add (Atom (Num i)) (Atom (Num j)) = retA $ Num $ i + j
  go Sub (Atom (Num i)) (Atom (Num j)) = retA $ Num $ i - j

  go Cons   e          (List es)  = return $ List $ e:es
  go Append (List es1) (List es2) = return $ List $ es1 ++ es2

  go Eq  (Atom a1) (Atom a2) = retA $ Bool $ a1 == a2
  go Neq (Atom a1) (Atom a2) = retA $ Bool $ a1 /= a2
  go Leq (Atom (Num i)) (Atom (Num j)) = retA $ Bool $ i <= j
  go Lt  (Atom (Num i)) (Atom (Num j)) = retA $ Bool $ i < j
  go Geq (Atom (Num i)) (Atom (Num j)) = retA $ Bool $ i >= j
  go Gt  (Atom (Num i)) (Atom (Num j)) = retA $ Bool $ i > j

  go And (Atom (Bool true))  b = return b
  go And (Atom (Bool false)) _ = retA $ Bool $ false

  go Or  (Atom (Bool true))  _ = retA $ Bool $ true
  go Or  (Atom (Bool false)) b = return b

  go Dollar f e = return $ App f [e]

  go op e1 e2 = throwError $ "Cannot apply operator " ++ show op ++  " to " ++ show e1 ++ " and " ++ show e2

unary :: Op -> Expr -> Evaluator Expr
unary Sub (Atom (Num i)) = return $ Atom $ Num (-i)
unary op e = throwError $ "Cannot apply unary operator " ++ show op ++ " to " ++ show e

apply :: Env -> String -> [Expr] -> Evaluator Expr
apply env name args = case lookup name env of
  Nothing    -> throwError $ "Unknown function: " ++ name
  Just cases -> case runEvalM $ foldl (<|>) P.empty (app <$> cases) of
    Right expr -> return expr
    Left msg   -> throwError $ "No matching funnction found for " ++ name ++ "(last reason: " ++ msg ++ ")"
  where
  app :: Tuple [Binding] Expr -> Evaluator Expr
  app (Tuple binds body) | length binds == length args = matchls' binds args >>= flip replace' body
                         | otherwise                   = throwError $ "Wrong number of arguments!"

matchls' :: [Binding] -> [Expr] -> Evaluator (StrMap Expr)
matchls' bs es = execStateT (zipWithA match' bs es) empty

match' :: Binding -> Expr -> StateT (StrMap Expr) Evaluator Unit
match' (Lit (Name name)) e                             = modify (insert name e)
match' (Lit ba)          (Atom ea)          | ba == ea = return unit
match' (ConsLit b bs)    (Binary Cons e es)            = match' b e *> match' bs es
match' (ConsLit b bs)    (List (e:es))                 = match' (ConsLit b bs) (Binary Cons e (List es))
match' (ListLit bs)      (List es)          | length bs == length es = void $ zipWithA match' bs es
match' (ListLit bs)      (Binary Cons e (List es))     = match' (ListLit bs) (List (e:es))
match' (NTupleLit bs)    (NTuple es)        | length bs == length es = void $ zipWithA match' bs es
match' b                 e                             = throwError $ "Cannot match " ++ show b ++ " with " ++ show e

replace' :: StrMap Expr -> Expr -> Evaluator Expr
replace' subs = go
  where
  go expr = case expr of
    a@(Atom (Name name)) -> case lookup name subs of
      Just subExpr -> return subExpr
      Nothing      -> return a
    (List exprs)         -> List <$> (traverse go exprs)
    (NTuple exprs)       -> NTuple <$> (traverse go exprs)
    (Binary op e1 e2)    -> Binary <$> pure op <*> go e1 <*> go e2
    (Unary op e)         -> Unary <$> pure op <*> go e
    (SectL e op)         -> SectL <$> go e <*> pure op
    (SectR op e)         -> SectR <$> pure op <*> go e
    (IfExpr ce te ee)    -> IfExpr <$> go ce <*> go te <*> go ee
    (Lambda binds body)  -> (avoidCapture subs binds) *> (Lambda <$> pure binds <*> replace' (foldr delete subs (boundNames' binds)) body)
    (App func exprs)     -> App <$> go func <*> traverse go exprs
    e                    -> return e

avoidCapture :: StrMap Expr -> [Binding] -> Evaluator Unit
avoidCapture subs binds = case intersect (concatMap freeVariables $ values subs) (boundNames' binds) of
  []       -> return unit
  captures -> throwError $ "Some variables have been captured: " ++ show captures

freeVariables :: Expr -> [String]
freeVariables = nub <<< foldExpr
  (\a -> case a of
    Name name -> [name]
    _         -> [])
  concat
  concat
  (\_ f1 f2 -> f1 ++ f2)
  (\_ f -> f)
  (\f _ -> f)
  (\_ f -> f)
  (\_ -> [])
  (\f1 f2 f3 -> f1 ++ f2 ++ f3)
  (\bs f -> nub f \\ boundNames' bs)
  (\f fs -> f ++ concat fs)

boundNames' :: [Binding] -> [String]
boundNames' = concatMap boundNames

boundNames :: Binding -> [String]
boundNames = go
  where
  go (Lit (Name name)) = [name]
  go (ConsLit b1 b2)   = go b1 ++ go b2
  go (ListLit bs)      = foldMap go bs
  go (NTupleLit bs)    = foldMap go bs


remove unused code

remove unused code

module Rendering where

import Debug.Trace
import Data.Array hiding (map, (..))
import Data.Function
import qualified Data.Map as M
import Data.Tuple
import Data.Maybe
import Data.Foldable
import Graphics.Canvas
  (getContext2D, setCanvasHeight, setCanvasWidth, Rectangle(), Arc(),
  Context2D(), Canvas(), getCanvasElementById, TextAlign(..), LineCap(..))
import Control.Monad.Eff
import Control.Monad (when)
import Control.Monad.Reader.Class (reader)
import Control.Lens ((^.), (..), (~), (^?))
import Math (pi, floor, ceil)

import LevelMap
import Types
import CanvasM
import Utils
import Game
import Style

halfBlock     = floor (pxPerBlock / 2)
halfPxPerTile = floor (pxPerTile / 2)
halfCanvas    = floor (canvasSize / 2)

scaleRect :: Number -> Position -> Rectangle
scaleRect scale (Position p) =
  {x: p.x * scale, y: p.y * scale, h: scale, w: scale}

toPosition :: Rectangle -> Position
toPosition r = Position {x:r.x, y:r.y}

getRectAt :: Position -> Rectangle
getRectAt = scaleRect pxPerBlock

getCentredRectAt :: Position -> Rectangle
getCentredRectAt p =
  let r = getRectAt p
  in  r {x = r.x + halfBlock, y = r.y + halfBlock}

getRectAt' :: Number -> Number -> Rectangle
getRectAt' x y = getRectAt (Position {x: x, y: y})

getTileRectAt :: Position -> Rectangle
getTileRectAt = scaleRect pxPerTile

getTileRectAt' :: Number -> Number -> Rectangle
getTileRectAt' x y = getTileRectAt (Position {x: x, y: y})

setupRendering :: forall e. Eff (canvas :: Canvas | e) RenderingContext
setupRendering = do
  fg <- setupRenderingById "foreground"
  bg <- setupRenderingById "background"
  return { foreground: fg, background: bg }

-- set up a canvas with the correct dimensions and return its context
setupRenderingById :: forall e.
  String -> Eff (canvas :: Canvas | e) Context2D
setupRenderingById elId =
  getCanvasElementById elId
    >>= justOrError
    >>= setCanvasHeight canvasSize
    >>= setCanvasWidth canvasSize
    >>= getContext2D

  where
  justOrError (Just x) = return x
  justOrError Nothing = error $ "no canvas element found with id = " <> elId

clearBackground :: forall e. CanvasM e Unit
clearBackground = do
  setFillStyle backgroundColor
  fillRect {x: 0, y: 0, h: canvasSize, w: canvasSize}

data CornerType
  = CRO -- rounded outer
  | CRI -- rounded inner
  | CSH -- straight horizontal
  | CSV -- straight vertical
  | NON -- nothing (inside a block)

instance showCornerType :: Show CornerType where
  show CRO = "CRO"
  show CRI = "CRI"
  show CSH = "CSH"
  show CSV = "CSV"

type Corners =
  { tl :: CornerType, tr :: CornerType, bl :: CornerType, br :: CornerType }

toBasic :: Tile -> BasicTile
toBasic Inaccessible = W
toBasic _ = E

renderMap :: forall e. LevelMap -> CanvasM e Unit
renderMap map = do
  setStrokeStyle tileColor

  let tileIndices = range 0 (tilesAlongSide - 1)
  let getTile i j = map.tiles !! i >>= (\r -> r !! j)
  let t i j = toBasic <$> getTile i j

  for_ tileIndices $ \i ->
    for_ tileIndices $ \j -> do
      let above      = fromMaybe W $ t i (j-1)
      let aboveRight = fromMaybe W $ t (i+1) (j-1)
      let right      = fromMaybe W $ t (i+1) j
      let belowRight = fromMaybe W $ t (i+1) (j+1)
      let below      = fromMaybe W $ t i (j+1)
      let belowLeft  = fromMaybe W $ t (i-1) (j+1)
      let left       = fromMaybe W $ t (i-1) j
      let aboveLeft  = fromMaybe W $ t (i-1) (j-1)

      case t i j of
        Just W -> do
          let cs = getCorners above aboveRight right belowRight
                              below belowLeft left aboveLeft
          let es = getEdges above right below left
          withContext $ do
            translate { translateX: (i + 0.5) * pxPerTile
                      , translateY: (j + 0.5) * pxPerTile
                      }
            renderCorners cs
            renderEdges es
        _ ->
          return unit

showCorners :: Corners -> String
showCorners cs =
  showRecord "Corners"
    ["tl" .:: cs.tl, "tr" .:: cs.tr, "br" .:: cs.br, "bl" .:: cs.bl]

getCorners above aboveRight right belowRight below belowLeft left aboveLeft =
  { tl: getCorner left above aboveLeft
  , tr: getCorner right above aboveRight
  , br: getCorner right below belowRight
  , bl: getCorner left below belowLeft
  }

-- order is: horizontal vertical corner
getCorner W W E = CRI
getCorner W W W = NON
getCorner W E _ = CSH
getCorner E W _ = CSV
getCorner E E _ = CRO

renderCorners :: forall e.  Corners -> CanvasM e Unit
renderCorners cs = do
  let renderCorner c a t =
    case c of
        CRO ->
          { prep: do
              translate t
              rotate a
          , go:
              arc { start: pi
                  , end:   3*pi/2
                  , x:     cornerMid
                  , y:     cornerMid
                  , r:     cornerRadius
                  }
          }
        CRI ->
          { prep: do
              translate t
              rotate a
          , go:
              arc { start: 0
                  , end:   pi/2
                  , x:     -cornerMid
                  , y:     -cornerMid
                  , r:     cornerRadius
                  }
          }
        CSH ->
          { prep: translate t
          , go: do
              moveTo (-cornerMid -1) 0
              lineTo (cornerMid + 1)  0
          }
        CSV ->
          { prep: translate t
          , go: do
              moveTo 0 (-cornerMid - 1)
              lineTo 0 (cornerMid + 1)
          }
        NON ->
          { prep: return unit
          , go: return unit
          }

  let s = (pxPerTile - cornerSize) / 2
  let cs' =
      [ { c: cs.tl
        , a: 0
        , t: {translateX: -s, translateY: -s}
        },

        { c: cs.tr
        , a: pi/2
        , t: {translateX: s, translateY: -s}
        },

        { c: cs.br
        , a: pi
        , t: {translateX: s, translateY: s}
        },

        { c: cs.bl
        , a: 3*pi/2
        , t: {translateX: -s, translateY: s}
        }
        ]

  for_ cs' $ \c -> do
    withContext $ do
      setLineCap Square
      let r = renderCorner c.c c.a c.t
      r.prep
      beginPath
      r.go
      stroke

getEdges above right below left =
  { t: above, r: right, b: below, l: left }

renderEdges es =
  let s = (pxPerTile / 2) - cornerSize
      x1 = -s - 1
      y1 = -s - (cornerSize / 2)
      x2 = s
      y2 = y1

      renderEdge e =
        when (e == E) $ do
          moveTo x1 y1
          lineTo x2 y2

      es' =
        [ { e: es.t, a: 0 }
        , { e: es.r, a: pi/2 }
        , { e: es.b, a: pi }
        , { e: es.l, a: 3*pi/2 }
        ]

  in
  for_ es' $ \e ->
    withContext $ do
      rotate e.a
      beginPath
      renderEdge e.e
      stroke

renderPlayer :: forall e.
  PlayerId
  -> Player
  -> CanvasM e Unit
renderPlayer pId player = do
  setFillStyle $ playerColor pId
  let r = playerRenderParameters player
  let centre = getCentredRectAt (player ^. pPosition)
  beginPath
  moveTo r.start.x r.start.y
  arc r.arc
  lineTo r.start.x r.start.y
  fill

playerRenderParameters player =
  let centre = getCentredRectAt (player ^. pPosition)
      direction = fromMaybe Left (player ^. pDirection)

      baseAngle = directionToRadians direction
      index = player ^. pNomIndex
      half = floor (nomIndexMax / 2)
      maxAngle = pi / 2
      multiplier = nomIndexMax / maxAngle
      delta = multiplier * (if index <= half
                                then index
                                else (nomIndexMax - index)) + 0.001

      op = dirToPos $ opposite direction
      start = add (scalePos (playerRadius / 2) op) (toPosition centre)
  in
    { arc: { x: centre.x
           , y: centre.y
           , start: (baseAngle + delta)
           , end: (baseAngle - delta)
           , r: playerRadius
           }
    , start: { x: start ^. pX
             , y: start ^. pY
             }
    }

enlargeRect :: Number -> Rectangle -> Rectangle
enlargeRect delta r =
  { x: r.x - delta
  , y: r.y - delta
  , w: r.w + (2 * delta)
  , h: r.h + (2 * delta)
  }

renderItems :: forall e. Game -> CanvasM e Unit
renderItems game =
  eachItem' game renderItem

renderItem :: forall e. Item -> CanvasM e Unit
renderItem item = do
  let centre = getCentredRectAt (item ^. iPosition)
  setFillStyle littleDotColor
  beginPath
  arc { x: centre.x
      , y: centre.y
      , start: 0
      , end: 2 * pi
      , r: littleDotRadius
      }
  fill

renderPlayers :: forall e. Game -> CanvasM e Unit
renderPlayers game =
  eachPlayer' game renderPlayer

clearCanvas :: forall e. CanvasM e Unit
clearCanvas =
  clearRect {x: 0, y: 0, h: canvasSize, w: canvasSize}

renderCountdown :: forall e. Game -> PlayerId -> CanvasM e Unit
renderCountdown game pId = do
  whenJust game.countdown $ \cd -> do
    renderCounter cd
    renderReminderArrow game pId

setFontSize :: forall e. Number -> CanvasM e Unit
setFontSize x =
  setFont $ show x <> "pt " <> fontName

renderCounter cd = do
  setFontSize $ pxPerTile * 3
  setTextAlign AlignCenter
  setLineWidth 3
  setFillStyle fontColor
  setStrokeStyle "black"
  let text = show (ceil (cd / 30))
  let x = halfCanvas
  let y = floor (halfCanvas / 2)
  fillText   text x y
  strokeText text x y

renderReminderArrow game pId = do
  whenJust (game ^? player pId) $ \pl ->
    withContext $ do
      let pos = pl ^. pPosition
      let playerX = pos ^. pX
      let y = pos ^. pY

      let greater = playerX > mapSize / 2
      let d = 1.5 * tileSize
      let x = playerX + (if greater then d else -d)

      let centre = getCentredRectAt (Position {x:x, y:y})

      setLineWidth 1
      beginPath
      arrowPath greater centre.x centre.y 30 10
      fill
      stroke

arrowPath toRight x y length width = do
  let halfLen = floor (length / 2)
  let halfWid = floor (width / 2)
  let f z = if toRight then x + z else x - z

  moveTo (f halfLen)           (y - halfWid)
  lineTo (f (- halfLen))       (y - halfWid)
  lineTo (f (- halfLen))       (y - (2 * halfWid))
  lineTo (f (- (2 * halfLen))) (y)
  lineTo (f (- halfLen))       (y + (2 * halfWid))
  lineTo (f (- halfLen))       (y + halfWid)
  lineTo (f halfLen)           (y + halfWid)
  lineTo (f halfLen)           (y - halfWid)

render :: forall e.
  RenderingContext
  -> Game
  -> PlayerId
  -> Boolean
  -> Eff (canvas :: Canvas | e) Unit
render ctx game pId redrawMap = do
  when redrawMap $ do
    runCanvasM ctx.background $
      renderMap game.map

  runCanvasM ctx.foreground $ do
    clearCanvas
    renderItems game
    renderPlayers game
    renderCountdown game pId

clearBoth :: forall e.
  RenderingContext
  -> Eff (canvas :: Canvas | e) Unit
clearBoth ctx = do
  runCanvasM ctx.background clearCanvas
  runCanvasM ctx.foreground clearCanvas

setTextStyle = do
  setFontSize $ floor (0.6 * pxPerTile)
  setFillStyle fontColor

renderWaitingMessage :: forall e.  Boolean -> CanvasM e Unit
renderWaitingMessage ready = do
  setTextStyle
  setTextAlign AlignCenter
  let message =
      if ready
         then "Waiting for other players..." ~ "ready: ✓"
         else "Press SPACE when you're ready" ~ "ready: ✕"
  let x = 20
  fillText (fst message) halfCanvas (halfCanvas - x)
  fillText (snd message) halfCanvas (halfCanvas + x)

renderYourPlayer :: forall e. PlayerId -> CanvasM e Unit
renderYourPlayer pId = do
  setTextStyle
  setTextAlign AlignRight
  let message = "You are: " <> show pId
  let x = halfCanvas + 40
  let y = halfCanvas + 100
  let d = 10
  fillText message (x-d) y
  renderPlayer pId (mkPlayer $ Position { x:120, y:122 })


Remove broken test

Remove broken test

module Main where

import Prelude
import Control.Monad.Eff
import Control.Monad.ST
import Debug.Trace

test = runSTArray (do
  a <- newSTArray 2 0
  pokeSTArray a 0 1
  pokeSTArray a 1 2
  return a)

fromTo lo hi = runSTArray (do
  arr <- newSTArray (hi - lo + 1) 0
  (let
    go lo hi _ arr | lo > hi = return arr
    go lo hi i arr = do
      pokeSTArray arrr i lo
      go (lo + 1) hi (i + 1) arr
   in go lo hi 0 arr))

main = do
  let t1 = runPure (fromTo 10 20)
  trace "Done"


Add withRep (flipped version of selectRep)

module Lambda.Language.PrettyPrint
  ( Rep(..)
  , ifSugar
  , selectRep
  , withRep
  , toggleRep
  , Doc
  , doc
  , sugar
  , raw
  , class PrettyPrint
  , prettyPrint
  , parensIf
  ) where

import Lambda.Prelude

-- | Either syntactic sugar or raw text.
data Rep
  = Sugar
  | Raw

-- | Project the appropriate `Doc` representation.
selectRep :: forall a. Doc a -> Rep -> a
selectRep (Doc s r) = ifSugar s r

-- | Flipped version of 'selectRep'
withRep :: forall a. Rep -> Doc a -> a
withRep = flip selectRep

-- | Flip `Raw` to `Sugar` and vice-versa.
toggleRep :: Rep -> Rep
toggleRep = ifSugar Raw Sugar

-- | Select the first argument given `Sugar`.
ifSugar :: forall a. a -> a -> Rep -> a
ifSugar s _ Sugar = s
ifSugar _ r Raw = r

-- | Document containing two representations of the same value.
data Doc a = Doc a a

-- | Project both representations out of `Doc`.
runDoc :: forall a. Doc a -> {sugar :: a, raw :: a}
runDoc (Doc s r) = {sugar: s, raw: r}

-- | Smart constructor for `Doc`.
doc :: forall a. {sugar :: a, raw :: a} -> Doc a
doc o = Doc o.sugar o.raw

-- | Project sugared representation out of `Doc`.
sugar :: forall a. Doc a -> a
sugar (Doc s _) = s

-- | Project raw representation out of `Doc`.
raw :: forall a. Doc a -> a
raw (Doc _ r) = r

instance docFunctor :: Functor Doc where
  map f (Doc s d) = Doc (f s) (f d)

instance docApply :: Apply Doc where
  apply (Doc f g) (Doc a b) = Doc (f a) (g b)

instance docApplicative :: Applicative Doc where
  pure a = Doc a a

instance docSemigroup :: Semigroup a => Semigroup (Doc a) where
  append d1 d2 = append <$> d1 <*> d2

instance docMonoid :: Monoid a => Monoid (Doc a) where
  mempty = pure mempty

class PrettyPrint a where
  prettyPrint :: a -> Doc String

-- | Wrap `Doc` in parens if condition is satisfied.
parensIf :: Boolean -> Doc String -> Doc String
parensIf cond d
  | cond      = pure "(" <> d <> pure ")"
  | otherwise = d

module Lambda.Language.PrettyPrint
  ( Rep(..)
  , ifSugar
  , selectRep
  , toggleRep
  , Doc
  , doc
  , sugar
  , raw
  , class PrettyPrint
  , prettyPrint
  , parensIf
  ) where

import Lambda.Prelude

-- | Either syntactic sugar or raw text.
data Rep
  = Sugar
  | Raw

-- | Project the appropriate `Doc` representation.
selectRep :: forall a. Doc a -> Rep -> a
selectRep (Doc s r) = ifSugar s r

-- | Flip `Raw` to `Sugar` and vice-versa.
toggleRep :: Rep -> Rep
toggleRep = ifSugar Raw Sugar

-- | Select the first argument given `Sugar`.
ifSugar :: forall a. a -> a -> Rep -> a
ifSugar s _ Sugar = s
ifSugar _ r Raw = r

-- | Document containing two representations of the same value.
data Doc a = Doc a a

-- | Project both representations out of `Doc`.
runDoc :: forall a. Doc a -> {sugar :: a, raw :: a}
runDoc (Doc s r) = {sugar: s, raw: r}

-- | Smart constructor for `Doc`.
doc :: forall a. {sugar :: a, raw :: a} -> Doc a
doc o = Doc o.sugar o.raw

-- | Project sugared representation out of `Doc`.
sugar :: forall a. Doc a -> a
sugar (Doc s _) = s

-- | Project raw representation out of `Doc`.
raw :: forall a. Doc a -> a
raw (Doc _ r) = r

instance docFunctor :: Functor Doc where
  map f (Doc s d) = Doc (f s) (f d)

instance docApply :: Apply Doc where
  apply (Doc f g) (Doc a b) = Doc (f a) (g b)

instance docApplicative :: Applicative Doc where
  pure a = Doc a a

instance docSemigroup :: Semigroup a => Semigroup (Doc a) where
  append d1 d2 = append <$> d1 <*> d2

instance docMonoid :: Monoid a => Monoid (Doc a) where
  mempty = pure mempty

class PrettyPrint a where
  prettyPrint :: a -> Doc String

-- | Wrap `Doc` in parens if condition is satisfied.
parensIf :: Boolean -> Doc String -> Doc String
parensIf cond d
  | cond      = pure "(" <> d <> pure ")"
  | otherwise = d


Re-enable support for throwing RoutingError in handler