If a piece has jump moves then it has no regular moves

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 (abs, max, 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

findSquare :: Array Square -> Coordinate -> Maybe Int
findSquare squares coordinate = findIndex (hasCoordinate coordinate) squares

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

squareHasPiece :: Player -> Square -> Boolean
squareHasPiece player square = fromMaybe false $ (hasPlayer player) <$> square.piece

hasPlayerPiece :: Array Square -> Player -> Coordinate -> Boolean
hasPlayerPiece squares player coordinate =
  case getSquare squares coordinate of
    Nothing -> false
    Just square -> squareHasPiece player square

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

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

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)

searchGrid :: Grid -> (Square -> Boolean) -> Maybe Coordinate
searchGrid grid predicate =
  case findIndex predicate grid.squares of
    Just index -> _.coordinate <$> grid.squares !! index
    Nothing    -> Nothing

getActiveCoordinate :: Grid -> Player -> Pixel -> Maybe Coordinate
getActiveCoordinate grid player pixel = searchGrid grid (isOnActiveSquare grid player pixel)

getHighlightCoordinate :: State -> Pixel -> Maybe Coordinate
getHighlightCoordinate state pixel =
  case searchGrid state.grid (isOnSquare 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

isRegularMove :: Grid -> Player -> Coordinate -> Coordinate -> Boolean
isRegularMove _ (Player 1) from to =
  let d1 = from + Tuple   1    1
      d2 = from + Tuple (-1)   1
  in d1 == to || d2 == to
isRegularMove _ _ from to =
  let d3 = from + Tuple   1  (-1)
      d4 = from + Tuple (-1) (-1)
  in d3 == to || d4 == to

isJumpMove :: Grid -> Player -> Coordinate -> Coordinate -> Boolean
isJumpMove grid (Player 1) from to =
  let d1 = from + Tuple   1    1
      d2 = from + Tuple (-1)   1
      d5 = from + Tuple   2    2
      d6 = from + Tuple (-2)   2
      f = hasPlayerPiece grid.squares playerTwo
  in d5 == to && f d1 || d6 == to && f d2
isJumpMove grid _ from to =
  let d3 = from + Tuple   1  (-1)
      d4 = from + Tuple (-1) (-1)
      d7 = from + Tuple   2  (-2)
      d8 = from + Tuple (-2) (-2)
      f = hasPlayerPiece grid.squares playerOne
  in d7 == to && f d3 || d8 == to && f d4

isValidMove :: Grid -> Player -> Coordinate -> Coordinate -> Boolean
isValidMove grid player from to = isJust (elemIndex to (getMoves grid player from))

getMoves :: Grid -> Player -> Coordinate -> Array Coordinate
getMoves grid player coordinate =
  if null allJumpMoves then allRegularMoves else allJumpMoves
  where
    allRegularMoves = getMoves' isRegularMove
    allJumpMoves = getMoves' isJumpMove

    getMoves' validator = do
      guard $ hasPlayerPiece grid.squares player coordinate
      potential <- getDiagonalSquares coordinate
      guard $ (isValid grid potential &&
               not hasPiece grid.squares potential &&
               validator grid player coordinate potential)
      return potential

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

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

movePiece :: Coordinate -> Coordinate -> Grid -> Grid
movePiece from to grid =
  let fromIndex = fromJust (findSquare grid.squares from)
      originalSquare = fromJust (grid.squares !! fromIndex)

      getMiddle :: Coordinate -> Coordinate -> Maybe Coordinate
      getMiddle (Tuple x1 y1) (Tuple x2 y2) =
        if abs (toNumber (y1 - y2)) == 2.0
        then
          let f v w = floor (max (toNumber v) (toNumber w) - 1.0)
          in Just (Tuple (f x1 x2) (f y1 y2))
        else Nothing
      gridAfterMove = removePiece from $ alterPiece originalSquare.piece to grid
  in
    case getMiddle from to of
      Nothing -> gridAfterMove
      Just middle -> removePiece middle gridAfterMove

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

renderCurrentPlayer :: forall e.
                        State ->
                        Eff (dom :: DOM | e) Unit
renderCurrentPlayer state = do
  doc <- document globalWindow
  playerIndicator <- getElementById "player" doc
  case playerIndicator of
    Just indicator -> do
      setInnerHTML (if state.currentPlayer == playerOne
                    then colorPlayerOne
                    else colorPlayerTwo) indicator
      return unit
    _ -> 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
  renderCurrentPlayer state
  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 (abs, max, 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

findSquare :: Array Square -> Coordinate -> Maybe Int
findSquare squares coordinate = findIndex (hasCoordinate coordinate) squares

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

squareHasPiece :: Player -> Square -> Boolean
squareHasPiece player square = fromMaybe false $ (hasPlayer player) <$> square.piece

hasPlayerPiece :: Array Square -> Player -> Coordinate -> Boolean
hasPlayerPiece squares player coordinate =
  case getSquare squares coordinate of
    Nothing -> false
    Just square -> squareHasPiece player square

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

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

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)

searchGrid :: Grid -> (Square -> Boolean) -> Maybe Coordinate
searchGrid grid predicate =
  case findIndex predicate grid.squares of
    Just index -> _.coordinate <$> grid.squares !! index
    Nothing    -> Nothing

getActiveCoordinate :: Grid -> Player -> Pixel -> Maybe Coordinate
getActiveCoordinate grid player pixel = searchGrid grid (isOnActiveSquare grid player pixel)

getHighlightCoordinate :: State -> Pixel -> Maybe Coordinate
getHighlightCoordinate state pixel =
  case searchGrid state.grid (isOnSquare 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

isRegularMove :: Player -> Coordinate -> Coordinate -> Boolean
isRegularMove (Player 1) from to =
  let d1 = from + Tuple   1    1
      d2 = from + Tuple (-1)   1
  in d1 == to || d2 == to
isRegularMove _ from to =
  let d3 = from + Tuple   1  (-1)
      d4 = from + Tuple (-1) (-1)
  in d3 == to || d4 == to

isJumpMove :: Grid -> Player -> Coordinate -> Coordinate -> Boolean
isJumpMove grid (Player 1) from to =
  let d1 = from + Tuple   1    1
      d2 = from + Tuple (-1)   1
      d5 = from + Tuple   2    2
      d6 = from + Tuple (-2)   2
      f = hasPlayerPiece grid.squares playerTwo
  in d5 == to && f d1 || d6 == to && f d2
isJumpMove grid _ from to =
  let d3 = from + Tuple   1  (-1)
      d4 = from + Tuple (-1) (-1)
      d7 = from + Tuple   2  (-2)
      d8 = from + Tuple (-2) (-2)
      f = hasPlayerPiece grid.squares playerOne
  in d7 == to && f d3 || d8 == to && f d4

isValidMove :: Grid -> Player -> Coordinate -> Coordinate -> Boolean
isValidMove grid player from to = isJust (elemIndex to (getMoves grid player from))

getMoves :: Grid -> Player -> Coordinate -> Array Coordinate
getMoves grid player coordinate = do
    guard $ hasPlayerPiece grid.squares player coordinate
    potential <- getDiagonalSquares coordinate
    guard $ isValidMove' grid player coordinate potential
    return potential
  where
    isValidMove' :: Grid -> Player -> Coordinate -> Coordinate -> Boolean
    isValidMove' grid player from to =
      isValid grid to && not hasPiece grid.squares to &&
      (isRegularMove player from to || isJumpMove grid player from to)

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

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

movePiece :: Coordinate -> Coordinate -> Grid -> Grid
movePiece from to grid =
  let fromIndex = fromJust (findSquare grid.squares from)
      originalSquare = fromJust (grid.squares !! fromIndex)

      getMiddle :: Coordinate -> Coordinate -> Maybe Coordinate
      getMiddle (Tuple x1 y1) (Tuple x2 y2) =
        if abs (toNumber (y1 - y2)) == 2.0
        then
          let f v w = floor (max (toNumber v) (toNumber w) - 1.0)
          in Just (Tuple (f x1 x2) (f y1 y2))
        else Nothing
      gridAfterMove = removePiece from $ alterPiece originalSquare.piece to grid
  in
    case getMiddle from to of
      Nothing -> gridAfterMove
      Just middle -> removePiece middle gridAfterMove

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

renderCurrentPlayer :: forall e.
                        State ->
                        Eff (dom :: DOM | e) Unit
renderCurrentPlayer state = do
  doc <- document globalWindow
  playerIndicator <- getElementById "player" doc
  case playerIndicator of
    Just indicator -> do
      setInnerHTML (if state.currentPlayer == playerOne
                    then colorPlayerOne
                    else colorPlayerTwo) indicator
      return unit
    _ -> 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
  renderCurrentPlayer state
  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


Fix argument replacement in if expression

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])           -> return $ Binary op e1 e2
  (App (SectR op e2) [e1])           -> return $ Binary op e1 e2
  (App (Prefix 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])           -> return $ Binary op e1 e2
  (App (SectR op e2) [e1])           -> return $ Binary op e1 e2
  (App (Prefix 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
    (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 copied node docs

Remove copied node docs

-- | This module defines low-level bindings to the Node HTTP module.

module Node.HTTP
  ( Server
  , Request
  , Response
  , HTTP

  , createServerS
  , SSLOptions
  , handshakeTimeout
  , requestCert
  , rejectUnauthorized
  , npnProtocols
  , alpnProtocols
  , sessionTimeout
  , ticketKeys
  , pfx
  , key
  , passphrase
  , cert
  , ca
  , crl
  , ciphers
  , honorCipherOrder
  , ecdhCurve
  , dhparam
  , secureProtocol
  , secureOptions
  , sessionIdContext

  , createServer
  , listen
  , ListenOptions
  , listenSocket

  , httpVersion
  , requestHeaders
  , requestMethod
  , requestURL
  , requestAsStream

  , setHeader
  , setHeaders
  , setStatusCode
  , setStatusMessage
  , responseAsStream
  ) where

import Prelude

import Control.Monad.Eff (Eff, kind Effect)

import Data.Foreign (Foreign)
import Data.Maybe (Maybe)
import Data.Nullable (Nullable, toNullable)
import Data.Options (Options, Option, options, opt)
import Data.StrMap (StrMap)

import Node.Buffer (Buffer)
import Node.Stream (Writable, Readable)

import Unsafe.Coerce (unsafeCoerce)

-- | The type of a HTTP server object
foreign import data Server :: Type

-- | A HTTP request object
foreign import data Request :: Type

-- | A HTTP response object
foreign import data Response :: Type

-- | The effect associated with using the HTTP module.
foreign import data HTTP :: Effect

-- | Create a HTTP server, given a function to be executed when a request is received.
foreign import createServer :: forall eff. (Request -> Response -> Eff (http :: HTTP | eff) Unit) -> Eff (http :: HTTP | eff) Server

-- | The type of HTTPS server options
data SSLOptions

-- | See the [node docs](https://nodejs.org/api/tls.html#tls_tls_createserver_options_secureconnectionlistener)
handshakeTimeout :: Option SSLOptions Int
handshakeTimeout = opt "handshakeTimeout"

-- | See the [node docs](https://nodejs.org/api/tls.html#tls_tls_createserver_options_secureconnectionlistener)
requestCert :: Option SSLOptions Boolean
requestCert = opt "requestCert"

-- | See the [node docs](https://nodejs.org/api/tls.html#tls_tls_createserver_options_secureconnectionlistener)
rejectUnauthorized :: Option SSLOptions Boolean
rejectUnauthorized = opt "rejectUnauthorized"

-- | The type variable t should be a string[], Buffer[], Uint8Array[], Buffer,
-- | or Uint8Array.
-- | See the [node docs](https://nodejs.org/api/tls.html#tls_tls_createserver_options_secureconnectionlistener)
npnProtocols :: forall t. Option SSLOptions t
npnProtocols = opt "NPNProtocols"

-- | The type variable t should be a string[], Buffer[], Uint8Array[], Buffer,
-- | or Uint8Array.
-- | See the [node docs](https://nodejs.org/api/tls.html#tls_tls_createserver_options_secureconnectionlistener)
alpnProtocols :: forall t. Option SSLOptions t
alpnProtocols = opt "ALPNProtocols"

-- | See the [node docs](https://nodejs.org/api/tls.html#tls_tls_createserver_options_secureconnectionlistener)
sessionTimeout :: Option SSLOptions Int
sessionTimeout = opt "sessionTimeout"

-- | See the [node docs](https://nodejs.org/api/tls.html#tls_tls_createserver_options_secureconnectionlistener)
ticketKeys :: Option SSLOptions Buffer
ticketKeys = opt "ticketKeys"

-- | The type variable t should be a string or Buffer.
-- | See the [node docs](https://nodejs.org/api/tls.html#tls_tls_createsecurecontext_options)
pfx :: forall t. Option SSLOptions t
pfx = opt "pfx"

-- | The type variable t should be a string, string[], Buffer, Buffer[], or
-- | Object[].
-- | See the [node docs](https://nodejs.org/api/tls.html#tls_tls_createsecurecontext_options)
key :: forall t. Option SSLOptions t
key = opt "key"

-- | See the [node docs](https://nodejs.org/api/tls.html#tls_tls_createsecurecontext_options)
passphrase :: Option SSLOptions String
passphrase = opt "passphrase"

-- | The type variable t should be a string, string[], Buffer, or Buffer[].
-- | See the [node docs](https://nodejs.org/api/tls.html#tls_tls_createsecurecontext_options)
cert :: forall t. Option SSLOptions t
cert = opt "cert"

-- | The type variable t should be a string, string[], Buffer, or Buffer[].
-- | See the [node docs](https://nodejs.org/api/tls.html#tls_tls_createsecurecontext_options)
ca :: forall t. Option SSLOptions t
ca = opt "ca"

-- | The type variable t should be a string, string[], Buffer, or Buffer[].
-- | See the [node docs](https://nodejs.org/api/tls.html#tls_tls_createsecurecontext_options)
crl :: forall t. Option SSLOptions t
crl = opt "crl"

-- | See the [node docs](https://nodejs.org/api/tls.html#tls_tls_createsecurecontext_options)
ciphers :: Option SSLOptions String
ciphers = opt "ciphers"

-- | See the [node docs](https://nodejs.org/api/tls.html#tls_tls_createsecurecontext_options)
honorCipherOrder :: Option SSLOptions Boolean
honorCipherOrder = opt "honorCipherOrder"

-- | See the [node docs](https://nodejs.org/api/tls.html#tls_tls_createsecurecontext_options)
ecdhCurve :: Option SSLOptions String
ecdhCurve = opt "ecdhCurve"

-- | The type variable t should be a string or Buffer.
-- | See the [node docs](https://nodejs.org/api/tls.html#tls_tls_createsecurecontext_options)
dhparam :: forall t. Option SSLOptions t
dhparam = opt "dhparam"

-- | See the [node docs](https://nodejs.org/api/tls.html#tls_tls_createsecurecontext_options)
secureProtocol :: Option SSLOptions String
secureProtocol = opt "secureProtocol"

-- | See the [node docs](https://nodejs.org/api/tls.html#tls_tls_createsecurecontext_options)
secureOptions :: Option SSLOptions Int
secureOptions = opt "secureOptions"

-- | See the [node docs](https://nodejs.org/api/tls.html#tls_tls_createsecurecontext_options)
sessionIdContext :: Option SSLOptions String
sessionIdContext = opt "sessionIdContext"

foreign import createServerSImpl ::
  forall eff.
  Foreign ->
  (Request -> Response -> Eff (http :: HTTP | eff) Unit) ->
  Eff (http :: HTTP | eff) Server

-- | Create an HTTPS server, given the SSL options and a function to be executed
-- | when a request is received.
createServerS :: forall eff.
                 Options SSLOptions ->
                 (Request -> Response -> Eff (http :: HTTP | eff) Unit) ->
                 Eff (http :: HTTP | eff) Server
createServerS = createServerSImpl <<< options

foreign import listenImpl :: forall eff. Server -> Int -> String -> Nullable Int -> Eff (http :: HTTP | eff) Unit -> Eff (http :: HTTP | eff) Unit

-- | Listen on a port in order to start accepting HTTP requests. The specified callback will be run when setup is complete.
listen :: forall eff. Server -> ListenOptions -> Eff (http :: HTTP | eff) Unit -> Eff (http :: HTTP | eff) Unit
listen server opts done = listenImpl server opts.port opts.hostname (toNullable opts.backlog) done

-- | Options to be supplied to `listen`. See the [Node API](https://nodejs.org/dist/latest-v6.x/docs/api/http.html#http_server_listen_handle_callback) for detailed information about these.
type ListenOptions =
  { hostname :: String
  , port :: Int
  , backlog :: Maybe Int
  }

-- | Listen on a unix socket. The specified callback will be run when setup is complete.
foreign import listenSocket :: forall eff. Server -> String -> Eff (http :: HTTP | eff) Unit -> Eff (http :: HTTP | eff) Unit

-- | Get the request HTTP version
httpVersion :: Request -> String
httpVersion = _.httpVersion <<< unsafeCoerce

-- | Get the request headers as a hash
requestHeaders :: Request -> StrMap String
requestHeaders = _.headers <<< unsafeCoerce

-- | Get the request method (GET, POST, etc.)
requestMethod :: Request -> String
requestMethod = _.method <<< unsafeCoerce

-- | Get the request URL
requestURL :: Request -> String
requestURL = _.url <<< unsafeCoerce

-- | Coerce the request object into a readable stream.
requestAsStream :: forall eff. Request -> Readable () (http :: HTTP | eff)
requestAsStream = unsafeCoerce

-- | Set a header with a single value.
foreign import setHeader :: forall eff. Response -> String -> String -> Eff (http :: HTTP | eff) Unit

-- | Set a header with multiple values.
foreign import setHeaders :: forall eff. Response -> String -> Array String -> Eff (http :: HTTP | eff) Unit

-- | Set the status code.
foreign import setStatusCode :: forall eff. Response -> Int -> Eff (http :: HTTP | eff) Unit

-- | Set the status message.
foreign import setStatusMessage :: forall eff. Response -> String -> Eff (http :: HTTP | eff) Unit

-- | Coerce the response object into a writable stream.
responseAsStream :: forall eff. Response -> Writable () (http :: HTTP | eff)
responseAsStream = unsafeCoerce

-- | This module defines low-level bindings to the Node HTTP module.

module Node.HTTP
  ( Server
  , Request
  , Response
  , HTTP

  , createServerS
  , SSLOptions
  , handshakeTimeout
  , requestCert
  , rejectUnauthorized
  , npnProtocols
  , alpnProtocols
  , sessionTimeout
  , ticketKeys
  , pfx
  , key
  , passphrase
  , cert
  , ca
  , crl
  , ciphers
  , honorCipherOrder
  , ecdhCurve
  , dhparam
  , secureProtocol
  , secureOptions
  , sessionIdContext

  , createServer
  , listen
  , ListenOptions
  , listenSocket

  , httpVersion
  , requestHeaders
  , requestMethod
  , requestURL
  , requestAsStream

  , setHeader
  , setHeaders
  , setStatusCode
  , setStatusMessage
  , responseAsStream
  ) where

import Prelude

import Control.Monad.Eff (Eff, kind Effect)

import Data.Foreign (Foreign)
import Data.Maybe (Maybe)
import Data.Nullable (Nullable, toNullable)
import Data.Options (Options, Option, options, opt)
import Data.StrMap (StrMap)

import Node.Buffer (Buffer)
import Node.Stream (Writable, Readable)

import Unsafe.Coerce (unsafeCoerce)

-- | The type of a HTTP server object
foreign import data Server :: Type

-- | A HTTP request object
foreign import data Request :: Type

-- | A HTTP response object
foreign import data Response :: Type

-- | The effect associated with using the HTTP module.
foreign import data HTTP :: Effect

-- | Create a HTTP server, given a function to be executed when a request is received.
foreign import createServer :: forall eff. (Request -> Response -> Eff (http :: HTTP | eff) Unit) -> Eff (http :: HTTP | eff) Server

-- | The type of HTTPS server options
data SSLOptions

-- | Abort the connection if the SSL/TLS handshake does not finish in the
-- | specified number of milliseconds. Defaults to 120 seconds. A
-- | 'tlsClientError' is emitted on the tls.Server object whenever a handshake
-- | times out.
-- | See the [node docs](https://nodejs.org/api/tls.html#tls_tls_createserver_options_secureconnectionlistener)
handshakeTimeout :: Option SSLOptions Int
handshakeTimeout = opt "handshakeTimeout"

-- | If true the server will request a certificate from clients that connect and
-- | attempt to verify that certificate. Defaults to false.
-- | See the [node docs](https://nodejs.org/api/tls.html#tls_tls_createserver_options_secureconnectionlistener)
requestCert :: Option SSLOptions Boolean
requestCert = opt "requestCert"

-- | If not false the server will reject any connection which is not authorized
-- | with the list of supplied CAs. This option only has an effect if
-- | requestCert is true. Defaults to true.
-- | See the [node docs](https://nodejs.org/api/tls.html#tls_tls_createserver_options_secureconnectionlistener)
rejectUnauthorized :: Option SSLOptions Boolean
rejectUnauthorized = opt "rejectUnauthorized"

-- | An array of strings, Buffers or Uint8Arrays, or a single Buffer or
-- | Uint8Array containing supported NPN protocols. Buffers should have the
-- | format [len][name][len][name]... e.g. 0x05hello0x05world, where the first
-- | byte is the length of the next protocol name. Passing an array is usually
-- | much simpler, e.g. ['hello', 'world']. (Protocols should be ordered by
-- | their priority.)
-- | The type variable t should be a string[], Buffer[], Uint8Array[], Buffer,
-- | or Uint8Array.
-- | See the [node docs](https://nodejs.org/api/tls.html#tls_tls_createserver_options_secureconnectionlistener)
npnProtocols :: forall t. Option SSLOptions t
npnProtocols = opt "NPNProtocols"

-- | An array of strings, Buffers or Uint8Arrays, or a single Buffer or
-- | Uint8Array containing the supported ALPN protocols. Buffers should have the
-- | format [len][name][len][name]... e.g. 0x05hello0x05world, where the first
-- | byte is the length of the next protocol name. Passing an array is usually
-- | much simpler, e.g. ['hello', 'world']. (Protocols should be ordered by
-- | their priority.) When the server receives both NPN and ALPN extensions from
-- | the client, ALPN takes precedence over NPN and the server does not send an
-- | NPN extension to the client.
-- | The type variable t should be a string[], Buffer[], Uint8Array[], Buffer,
-- | or Uint8Array.
-- | See the [node docs](https://nodejs.org/api/tls.html#tls_tls_createserver_options_secureconnectionlistener)
alpnProtocols :: forall t. Option SSLOptions t
alpnProtocols = opt "ALPNProtocols"

-- | An integer specifying the number of seconds after which the TLS session
-- | identifiers and TLS session tickets created by the server will time out.
-- | See SSL_CTX_set_timeout for more details.
-- | See the [node docs](https://nodejs.org/api/tls.html#tls_tls_createserver_options_secureconnectionlistener)
sessionTimeout :: Option SSLOptions Int
sessionTimeout = opt "sessionTimeout"

-- | A 48-byte Buffer instance consisting of a 16-byte prefix, a 16-byte HMAC
-- | key, and a 16-byte AES key. This can be used to accept TLS session tickets
-- | on multiple instances of the TLS server.
-- | See the [node docs](https://nodejs.org/api/tls.html#tls_tls_createserver_options_secureconnectionlistener)
ticketKeys :: Option SSLOptions Buffer
ticketKeys = opt "ticketKeys"

-- | Optional PFX or PKCS12 encoded private key and certificate chain. pfx is an
-- | alternative to providing key and cert individually. PFX is usually
-- | encrypted, if it is, passphrase will be used to decrypt it.
-- | The type variable t should be a string or Buffer.
-- | See the [node docs](https://nodejs.org/api/tls.html#tls_tls_createsecurecontext_options)
pfx :: forall t. Option SSLOptions t
pfx = opt "pfx"

-- | Optional private keys in PEM format. PEM allows the option of private keys
-- | being encrypted. Encrypted keys will be decrypted with options.passphrase.
-- | Multiple keys using different algorithms can be provided either as an array
-- | of unencrypted key strings or buffers, or an array of objects in the form
-- | {pem: <string|buffer>[, passphrase: <string>]}. The object form can only
-- | occur in an array. object.passphrase is optional. Encrypted keys will be
-- | decrypted with object.passphrase if provided, or options.passphrase if it
-- | is not.
-- | The type variable t should be a string, string[], Buffer, Buffer[], or
-- | Object[].
-- | See the [node docs](https://nodejs.org/api/tls.html#tls_tls_createsecurecontext_options)
key :: forall t. Option SSLOptions t
key = opt "key"

-- | Optional shared passphrase used for a single private key and/or a PFX.
-- | See the [node docs](https://nodejs.org/api/tls.html#tls_tls_createsecurecontext_options)
passphrase :: Option SSLOptions String
passphrase = opt "passphrase"

-- | Optional cert chains in PEM format. One cert chain should be provided per
-- | private key. Each cert chain should consist of the PEM formatted
-- | certificate for a provided private key, followed by the PEM formatted
-- | intermediate certificates (if any), in order, and not including the root CA
-- | (the root CA must be pre-known to the peer, see ca). When providing
-- | multiple cert chains, they do not have to be in the same order as their
-- | private keys in key. If the intermediate certificates are not provided, the
-- | peer will not be able to validate the certificate, and the handshake will
-- | fail.
-- | The type variable t should be a string, string[], Buffer, or Buffer[].
-- | See the [node docs](https://nodejs.org/api/tls.html#tls_tls_createsecurecontext_options)
cert :: forall t. Option SSLOptions t
cert = opt "cert"

-- | Optionally override the trusted CA certificates. Default is to trust the
-- | well-known CAs curated by Mozilla. Mozilla's CAs are completely replaced
-- | when CAs are explicitly specified using this option. The value can be a
-- | string or Buffer, or an Array of strings and/or Buffers. Any string or
-- | Buffer can contain multiple PEM CAs concatenated together. The peer's
-- | certificate must be chainable to a CA trusted by the server for the
-- | connection to be authenticated. When using certificates that are not
-- | chainable to a well-known CA, the certificate's CA must be explicitly
-- | specified as a trusted or the connection will fail to authenticate. If the
-- | peer uses a certificate that doesn't match or chain to one of the default
-- | CAs, use the ca option to provide a CA certificate that the peer's
-- | certificate can match or chain to. For self-signed certificates, the
-- | certificate is its own CA, and must be provided.
-- | The type variable t should be a string, string[], Buffer, or Buffer[].
-- | See the [node docs](https://nodejs.org/api/tls.html#tls_tls_createsecurecontext_options)
ca :: forall t. Option SSLOptions t
ca = opt "ca"

-- | Optional PEM formatted CRLs (Certificate Revocation Lists).
-- | The type variable t should be a string, string[], Buffer, or Buffer[].
-- | See the [node docs](https://nodejs.org/api/tls.html#tls_tls_createsecurecontext_options)
crl :: forall t. Option SSLOptions t
crl = opt "crl"

-- | Optional cipher suite specification, replacing the default. For more
-- | information, see modifying the default cipher suite.
-- | See the [node docs](https://nodejs.org/api/tls.html#tls_tls_createsecurecontext_options)
ciphers :: Option SSLOptions String
ciphers = opt "ciphers"

-- | Attempt to use the server's cipher suite preferences instead of the
-- | client's. When true, causes SSL_OP_CIPHER_SERVER_PREFERENCE to be set in
-- | secureOptions, see OpenSSL Options for more information.
-- | See the [node docs](https://nodejs.org/api/tls.html#tls_tls_createsecurecontext_options)
honorCipherOrder :: Option SSLOptions Boolean
honorCipherOrder = opt "honorCipherOrder"

-- | A string describing a named curve to use for ECDH key agreement or false to
-- | disable ECDH. Defaults to tls.DEFAULT_ECDH_CURVE. Use crypto.getCurves() to
-- | obtain a list of available curve names. On recent releases, openssl ecparam
-- | -list_curves will also display the name and description of each available
-- | elliptic curve.
-- | See the [node docs](https://nodejs.org/api/tls.html#tls_tls_createsecurecontext_options)
ecdhCurve :: Option SSLOptions String
ecdhCurve = opt "ecdhCurve"

-- | Diffie Hellman parameters, required for Perfect Forward Secrecy. Use
-- | openssl dhparam to create the parameters. The key length must be greater
-- | than or equal to 1024 bits, otherwise an error will be thrown. It is
-- | strongly recommended to use 2048 bits or larger for stronger security. If
-- | omitted or invalid, the parameters are silently discarded and DHE ciphers
-- | will not be available.
-- | The type variable t should be a string or Buffer.
-- | See the [node docs](https://nodejs.org/api/tls.html#tls_tls_createsecurecontext_options)
dhparam :: forall t. Option SSLOptions t
dhparam = opt "dhparam"

-- | Optional SSL method to use, default is "SSLv23_method". The possible values
-- | are listed as SSL_METHODS, use the function names as strings. For example,
-- | "SSLv3_method" to force SSL version 3.
-- | See the [node docs](https://nodejs.org/api/tls.html#tls_tls_createsecurecontext_options)
secureProtocol :: Option SSLOptions String
secureProtocol = opt "secureProtocol"

-- | Optionally affect the OpenSSL protocol behavior, which is not usually
-- | necessary. This should be used carefully if at all! Value is a numeric
-- | bitmask of the SSL_OP_* options from OpenSSL Options.
-- | See the [node docs](https://nodejs.org/api/tls.html#tls_tls_createsecurecontext_options)
secureOptions :: Option SSLOptions Int
secureOptions = opt "secureOptions"

-- | Optional opaque identifier used by servers to ensure session state is not
-- | shared between applications. Unused by clients.
-- | See the [node docs](https://nodejs.org/api/tls.html#tls_tls_createsecurecontext_options)
sessionIdContext :: Option SSLOptions String
sessionIdContext = opt "sessionIdContext"

foreign import createServerSImpl ::
  forall eff.
  Foreign ->
  (Request -> Response -> Eff (http :: HTTP | eff) Unit) ->
  Eff (http :: HTTP | eff) Server

-- | Create an HTTPS server, given the SSL options and a function to be executed
-- | when a request is received.
createServerS :: forall eff.
                 Options SSLOptions ->
                 (Request -> Response -> Eff (http :: HTTP | eff) Unit) ->
                 Eff (http :: HTTP | eff) Server
createServerS = createServerSImpl <<< options

foreign import listenImpl :: forall eff. Server -> Int -> String -> Nullable Int -> Eff (http :: HTTP | eff) Unit -> Eff (http :: HTTP | eff) Unit

-- | Listen on a port in order to start accepting HTTP requests. The specified callback will be run when setup is complete.
listen :: forall eff. Server -> ListenOptions -> Eff (http :: HTTP | eff) Unit -> Eff (http :: HTTP | eff) Unit
listen server opts done = listenImpl server opts.port opts.hostname (toNullable opts.backlog) done

-- | Options to be supplied to `listen`. See the [Node API](https://nodejs.org/dist/latest-v6.x/docs/api/http.html#http_server_listen_handle_callback) for detailed information about these.
type ListenOptions =
  { hostname :: String
  , port :: Int
  , backlog :: Maybe Int
  }

-- | Listen on a unix socket. The specified callback will be run when setup is complete.
foreign import listenSocket :: forall eff. Server -> String -> Eff (http :: HTTP | eff) Unit -> Eff (http :: HTTP | eff) Unit

-- | Get the request HTTP version
httpVersion :: Request -> String
httpVersion = _.httpVersion <<< unsafeCoerce

-- | Get the request headers as a hash
requestHeaders :: Request -> StrMap String
requestHeaders = _.headers <<< unsafeCoerce

-- | Get the request method (GET, POST, etc.)
requestMethod :: Request -> String
requestMethod = _.method <<< unsafeCoerce

-- | Get the request URL
requestURL :: Request -> String
requestURL = _.url <<< unsafeCoerce

-- | Coerce the request object into a readable stream.
requestAsStream :: forall eff. Request -> Readable () (http :: HTTP | eff)
requestAsStream = unsafeCoerce

-- | Set a header with a single value.
foreign import setHeader :: forall eff. Response -> String -> String -> Eff (http :: HTTP | eff) Unit

-- | Set a header with multiple values.
foreign import setHeaders :: forall eff. Response -> String -> Array String -> Eff (http :: HTTP | eff) Unit

-- | Set the status code.
foreign import setStatusCode :: forall eff. Response -> Int -> Eff (http :: HTTP | eff) Unit

-- | Set the status message.
foreign import setStatusMessage :: forall eff. Response -> String -> Eff (http :: HTTP | eff) Unit

-- | Coerce the response object into a writable stream.
responseAsStream :: forall eff. Response -> Writable () (http :: HTTP | eff)
responseAsStream = unsafeCoerce


don't keep the previous map there

don't keep the previous map there

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

pxPerTile = 35
pxPerBlock = pxPerTile / tileSize

playerRadius = floor (pxPerTile / 2.2)
littleDotRadius = pxPerBlock

-- parameters for corners of tiles
cornerSize = floor (pxPerTile / 3)
cornerMid = floor (cornerSize / 2)
cornerRadius = cornerMid

fontColour = "#dfd1a5"
backgroundColour = "#34344e"
tileColour = "hsl(200, 80%, 40%)"

littleDotFillStyle = "#eecccc"

fillStyleFor :: PlayerId -> String
fillStyleFor P1 = "hsl(0, 100%, 60%)"
fillStyleFor P2 = "hsl(90, 100%, 60%)"
fillStyleFor P3 = "hsl(180, 100%, 60%)"
fillStyleFor P4 = "hsl(270, 100%, 60%)"

halfBlock :: Number
halfBlock = floor (pxPerBlock / 2)

halfPxPerTile :: Number
halfPxPerTile = floor (pxPerTile / 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})

-- the height and width of the canvas
canvasSize :: Number
canvasSize = pxPerBlock * LevelMap.mapSize

halfCanvas = floor (canvasSize / 2)

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 backgroundColour
  fillRect {x: 0, y: 0, h: canvasSize, w: canvasSize}

foreign import renderMapDebugFFI
  """
  function renderMapDebugFFI(isEmpty, getBlockRect, getTileRect, ctx, map) {
    return function() {
      ctx.strokeStyle = 'hsl(40, 70%, 50%)'
      var t = map.tiles
      for (var i = 0; i < t.length; i++) {
        for (var j = 0; j < t[i].length; j++) {
          var r = getTileRect(i)(j)
          ctx.strokeRect(r.x, r.y, r.w, r.h)
        }
      }

      ctx.fillStyle = 'hsl(320, 20%, 10%)'
      var b = map.blocks
      for (var i = 0; i < b.length; i++) {
        for (var j = 0; j < b[i].length; j++) {
          if (isEmpty(b[i][j])) {
            var r = getBlockRect(i)(j)
            ctx.fillRect(r.x, r.y, r.w, r.h)
          }
        }
      }
    }
  }
  """ :: forall e.
  Fn5
    (Block -> Boolean)
    (Number -> Number -> Rectangle)
    (Number -> Number -> Rectangle)
    Context2D
    LevelMap
    (Eff (canvas :: Canvas | e) Unit)

renderMapDebug :: forall e. LevelMap -> CanvasM e Unit
renderMapDebug map = do
  clearBackground
  liftC $ \ctx ->
    runFn5 renderMapDebugFFI (not .. isWall) getRectAt' getTileRectAt' ctx map

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 tileColour

  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 (fillStyleFor 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 littleDotFillStyle
  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

renderCounter cd = do
  let pt = pxPerTile * 3
  setFont $ show pt <> "pt Ubuntu"
  setTextAlign AlignCenter
  setLineWidth 3
  setFillStyle fontColour
  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 $ do
      when debug $ renderMapDebug game.map
      renderMap game.map

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

renderWaiting :: forall e.
  RenderingContext
  -> Boolean
  -> PlayerId
  -> Eff (canvas :: Canvas | e) Unit
renderWaiting ctx ready pId = do
  runCanvasM ctx.background $
    clearCanvas

  runCanvasM ctx.foreground $ do
    clearCanvas
    renderWaitingMessage ready
    renderYourPlayer pId

setTextStyle = do
  let pt = floor (0.6 * pxPerTile)
  setFont $ show pt <> "pt Ubuntu"
  setFillStyle fontColour

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 })

debug :: Boolean
debug = false

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

pxPerTile = 35
pxPerBlock = pxPerTile / tileSize

playerRadius = floor (pxPerTile / 2.2)
littleDotRadius = pxPerBlock

-- parameters for corners of tiles
cornerSize = floor (pxPerTile / 3)
cornerMid = floor (cornerSize / 2)
cornerRadius = cornerMid

fontColour = "#dfd1a5"
backgroundColour = "#34344e"
tileColour = "hsl(200, 80%, 40%)"

littleDotFillStyle = "#eecccc"

fillStyleFor :: PlayerId -> String
fillStyleFor P1 = "hsl(0, 100%, 60%)"
fillStyleFor P2 = "hsl(90, 100%, 60%)"
fillStyleFor P3 = "hsl(180, 100%, 60%)"
fillStyleFor P4 = "hsl(270, 100%, 60%)"

halfBlock :: Number
halfBlock = floor (pxPerBlock / 2)

halfPxPerTile :: Number
halfPxPerTile = floor (pxPerTile / 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})

-- the height and width of the canvas
canvasSize :: Number
canvasSize = pxPerBlock * LevelMap.mapSize

halfCanvas = floor (canvasSize / 2)

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 backgroundColour
  fillRect {x: 0, y: 0, h: canvasSize, w: canvasSize}

foreign import renderMapDebugFFI
  """
  function renderMapDebugFFI(isEmpty, getBlockRect, getTileRect, ctx, map) {
    return function() {
      ctx.strokeStyle = 'hsl(40, 70%, 50%)'
      var t = map.tiles
      for (var i = 0; i < t.length; i++) {
        for (var j = 0; j < t[i].length; j++) {
          var r = getTileRect(i)(j)
          ctx.strokeRect(r.x, r.y, r.w, r.h)
        }
      }

      ctx.fillStyle = 'hsl(320, 20%, 10%)'
      var b = map.blocks
      for (var i = 0; i < b.length; i++) {
        for (var j = 0; j < b[i].length; j++) {
          if (isEmpty(b[i][j])) {
            var r = getBlockRect(i)(j)
            ctx.fillRect(r.x, r.y, r.w, r.h)
          }
        }
      }
    }
  }
  """ :: forall e.
  Fn5
    (Block -> Boolean)
    (Number -> Number -> Rectangle)
    (Number -> Number -> Rectangle)
    Context2D
    LevelMap
    (Eff (canvas :: Canvas | e) Unit)

renderMapDebug :: forall e. LevelMap -> CanvasM e Unit
renderMapDebug map = do
  clearBackground
  liftC $ \ctx ->
    runFn5 renderMapDebugFFI (not .. isWall) getRectAt' getTileRectAt' ctx map

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 tileColour

  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 (fillStyleFor 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 littleDotFillStyle
  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

renderCounter cd = do
  let pt = pxPerTile * 3
  setFont $ show pt <> "pt Ubuntu"
  setTextAlign AlignCenter
  setLineWidth 3
  setFillStyle fontColour
  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 $ do
      when debug $ renderMapDebug game.map
      renderMap game.map

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

renderWaiting :: forall e.
  RenderingContext
  -> Boolean
  -> PlayerId
  -> Eff (canvas :: Canvas | e) Unit
renderWaiting ctx ready pId = do
  runCanvasM ctx.foreground $ do
    clearCanvas
    renderWaitingMessage ready
    renderYourPlayer pId

setTextStyle = do
  let pt = floor (0.6 * pxPerTile)
  setFont $ show pt <> "pt Ubuntu"
  setFillStyle fontColour

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 })

debug :: Boolean
debug = false