Minor code changes to use dollar sign

Minor code changes to use dollar sign

module Checkers.Main where

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

import Checkers.Constants
import Checkers.Types

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

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

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

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

getCoordinateIndex :: Coordinate -> Array Square -> Maybe Int
getCoordinateIndex coordinate = findIndex (\s -> s.coordinate == coordinate)

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

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

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

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

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

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

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

isValidMove :: Grid -> Player -> Coordinate -> Coordinate -> Boolean
isValidMove grid player from to = not hasPiece grid.squares to &&
  ((player == playerOne && snd to > snd from) ||
   (player == playerTwo && snd to < snd from))

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

movePiece :: Coordinate -> Coordinate -> Grid -> Grid
movePiece from to grid = grid { squares = newSquares }
    where
      fromIndex = fromJust (getCoordinateIndex from grid.squares)
      toIndex = fromJust (getCoordinateIndex to grid.squares)
      originalSquare = fromJust (grid.squares !! fromIndex)
      afterMove = fromJust (modifyAt toIndex (setPiece originalSquare.piece) grid.squares)
      newSquares = fromJust (modifyAt fromIndex (setPiece Nothing) afterMove)

renderSquare :: forall e.
                  Context2D ->
                  Maybe DOMEvent ->
                  Unit ->
                  Square ->
                  Eff (canvas :: Canvas, dom :: DOM | e) Unit
renderSquare ctx event _ 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 ->
                 Maybe DOMEvent ->
                 Unit ->
                 Square ->
                 Eff (canvas :: Canvas, dom :: DOM | e) Unit
renderPiece state ctx event _ square =
  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
      case event of
        Nothing -> return unit
        Just e -> do
          ux <- unsafeEventNumberProp "clientX" e
          uy <- unsafeEventNumberProp "clientY" e
          let pixel = Tuple (toNumber ux) (toNumber uy)
          case isOnActiveSquare state.grid state.currentPlayer pixel square of
            true -> renderHighlight ctx state.grid.squares (Just square.coordinate)
            false -> return unit
          return unit
      return unit
    _ -> return unit

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

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

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

renderPage :: forall s e.
                STRef s State ->
                Maybe DOMEvent ->
                Eff (st :: ST s, canvas :: Canvas, dom :: DOM | e) Unit
renderPage st event = do
  element <- getCanvasElementById "canvas"
  case element of
    Just canvas -> do
      setCanvasDimensions renderDimension canvas
      ctx <- getContext2D canvas
      render ctx st event
      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 = renderPage st (Just e)

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)
          activeCoordinate = getActiveCoordinate state.grid state.currentPlayer pixel
      writeSTRef st $ state { selectedCoordinate = activeCoordinate }
      renderPage st (Just e)
      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 Nothing
      return unit
    _ -> return unit

module Checkers.Main where

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

import Checkers.Constants
import Checkers.Types

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

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

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

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

getCoordinateIndex :: Coordinate -> Array Square -> Maybe Int
getCoordinateIndex coordinate = findIndex (\s -> s.coordinate == coordinate)

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

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

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

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

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

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

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

isValidMove :: Grid -> Player -> Coordinate -> Coordinate -> Boolean
isValidMove grid player from to = not hasPiece grid.squares to &&
  ((player == playerOne && snd to > snd from) ||
   (player == playerTwo && snd to < snd from))

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

movePiece :: Coordinate -> Coordinate -> Grid -> Grid
movePiece from to grid = grid { squares = newSquares }
    where
      fromIndex = fromJust (getCoordinateIndex from grid.squares)
      toIndex = fromJust (getCoordinateIndex to grid.squares)
      originalSquare = fromJust (grid.squares !! fromIndex)
      afterMove = fromJust (modifyAt toIndex (setPiece originalSquare.piece) grid.squares)
      newSquares = fromJust (modifyAt fromIndex (setPiece Nothing) afterMove)

renderSquare :: forall e.
                  Context2D ->
                  Maybe DOMEvent ->
                  Unit ->
                  Square ->
                  Eff (canvas :: Canvas, dom :: DOM | e) Unit
renderSquare ctx event _ 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 ->
                 Maybe DOMEvent ->
                 Unit ->
                 Square ->
                 Eff (canvas :: Canvas, dom :: DOM | e) Unit
renderPiece state ctx event _ square =
  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
      case event of
        Nothing -> return unit
        Just e -> do
          ux <- unsafeEventNumberProp "clientX" e
          uy <- unsafeEventNumberProp "clientY" e
          let pixel = Tuple (toNumber ux) (toNumber uy)
          case isOnActiveSquare state.grid state.currentPlayer pixel square of
            true -> renderHighlight ctx state.grid.squares (Just square.coordinate)
            false -> return unit
          return unit
      return unit
    _ -> return unit

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

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

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

renderPage :: forall s e.
                STRef s State ->
                Maybe DOMEvent ->
                Eff (st :: ST s, canvas :: Canvas, dom :: DOM | e) Unit
renderPage st event = do
  element <- getCanvasElementById "canvas"
  case element of
    Just canvas -> do
      setCanvasDimensions renderDimension canvas
      ctx <- getContext2D canvas
      render ctx st event
      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 = renderPage st (Just e)

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)
          activeCoordinate = getActiveCoordinate state.grid state.currentPlayer pixel
      writeSTRef st $ state { selectedCoordinate = activeCoordinate }
      renderPage st (Just e)
      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 Nothing
      return unit
    _ -> return unit


Refactored several functions to use Pixel in its type

module Checkers.Main where

import Control.Monad.Eff
import Control.Monad.ST
import Control.MonadPlus (guard)
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 (unsafeEventNumberProp)
import Data.DOM.Simple.Window
import Data.Int (even, odd, toNumber)
import Data.Maybe
import Data.Maybe.Unsafe
import Data.Tuple
import DOM
import Graphics.Canvas
import Math (pi)
import Prelude

import Checkers.Constants
import Checkers.Types

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

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

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

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

getCoordinateIndex :: Array Square -> Coordinate -> Maybe Int
getCoordinateIndex squares coordinate = findIndex (\s -> s.coordinate == coordinate) squares

hasPlayerPiece :: Array Square -> Coordinate -> Player -> Boolean
hasPlayerPiece squares coordinate player =
  case getCoordinateIndex squares coordinate of
    Nothing -> false
    Just index ->
      case (fromJust (squares !! index)).piece of
        Nothing -> false
        Just p -> p.player == player

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

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

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

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

isValidMove :: Grid -> Player -> Coordinate -> Coordinate -> Boolean
isValidMove grid player from to = not hasPiece grid.squares to &&
  ((player == playerOne && snd to > snd from) ||
   (player == playerTwo && snd to < snd from))

getMoves :: Grid -> Player -> Coordinate -> Array Coordinate
getMoves grid player coordinate = do
  potential <- getDiagonalSquares coordinate
  guard $ (isValid grid potential && isValidMove grid player coordinate potential)
  return potential

movePiece :: Coordinate -> Coordinate -> Grid -> Grid
movePiece from to grid = grid { squares = newSquares }
    where
      fromIndex = fromJust (getCoordinateIndex grid.squares from)
      toIndex = fromJust (getCoordinateIndex grid.squares to)
      originalSquare = fromJust (grid.squares !! fromIndex)
      afterMove = fromJust (modifyAt toIndex (setPiece originalSquare.piece) grid.squares)
      newSquares = fromJust (modifyAt fromIndex (setPiece Nothing) afterMove)

renderSquare :: forall e.
                  Context2D ->
                  Maybe DOMEvent ->
                  Unit ->
                  Square ->
                  Eff (canvas :: Canvas, dom :: DOM | e) Unit
renderSquare ctx event _ 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 ->
                 Maybe DOMEvent ->
                 Unit ->
                 Square ->
                 Eff (canvas :: Canvas, dom :: DOM | e) Unit
renderPiece state ctx event _ square =
  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
      case event of
        Nothing -> return unit
        Just e -> do
          ux <- unsafeEventNumberProp "clientX" e
          uy <- unsafeEventNumberProp "clientY" e
          let pixel = Tuple (toNumber ux) (toNumber uy)
          case isOnActiveSquare state.grid state.currentPlayer square pixel of
            true -> do
              setLineWidth highlightWidth ctx
              strokePath ctx $ arc ctx arcPiece
              return unit
            false -> return unit
          return unit
      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 "black" ctx
  strokeRect ctx border
  return unit

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

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

clickListener :: forall s e.
                   STRef s State ->
                   DOMEvent ->
                   Eff (st :: ST s, canvas :: Canvas, dom :: DOM | e) Unit
clickListener st event = do
  element <- getCanvasElementById "canvas"
  case element of
    Just canvas -> do
      renderPage st (Just event)
      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 (\e -> renderPage st (Just e)) canvas
      addMouseEventListener MouseClickEvent (\e -> clickListener st e) canvas
      renderPage st Nothing
      return unit
    _ -> return unit

module Checkers.Main where

import Control.Monad.Eff
import Control.Monad.ST
import Control.MonadPlus (guard)
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 (unsafeEventNumberProp)
import Data.DOM.Simple.Window
import Data.Int (even, odd, toNumber)
import Data.Maybe
import Data.Maybe.Unsafe
import Data.Tuple
import DOM
import Graphics.Canvas
import Math (pi)
import Prelude

import Checkers.Constants
import Checkers.Types

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

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

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

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

getCoordinateIndex :: Array Square -> Coordinate -> Maybe Int
getCoordinateIndex squares coordinate = findIndex (\s -> s.coordinate == coordinate) squares

hasPlayerPiece :: Array Square -> Coordinate -> Player -> Boolean
hasPlayerPiece squares coordinate player =
  case getCoordinateIndex squares coordinate of
    Nothing -> false
    Just index ->
      case (fromJust (squares !! index)).piece of
        Nothing -> false
        Just p -> p.player == player

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

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

isOnSquare :: Square -> Number -> Number -> Boolean
isOnSquare square x y =
  let vx = fst square.render + fst square.offset
      vy = snd square.render + snd square.offset
  in vx < x && x < vx + renderSize && vy < y && y < vy + renderSize

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

isValidMove :: Grid -> Player -> Coordinate -> Coordinate -> Boolean
isValidMove grid player from to = not hasPiece grid.squares to &&
  ((player == playerOne && snd to > snd from) ||
   (player == playerTwo && snd to < snd from))

getMoves :: Grid -> Player -> Coordinate -> Array Coordinate
getMoves grid player coordinate = do
  potential <- getDiagonalSquares coordinate
  guard $ (isValid grid potential && isValidMove grid player coordinate potential)
  return potential

movePiece :: Coordinate -> Coordinate -> Grid -> Grid
movePiece from to grid = grid { squares = newSquares }
    where
      fromIndex = fromJust (getCoordinateIndex grid.squares from)
      toIndex = fromJust (getCoordinateIndex grid.squares to)
      originalSquare = fromJust (grid.squares !! fromIndex)
      afterMove = fromJust (modifyAt toIndex (setPiece originalSquare.piece) grid.squares)
      newSquares = fromJust (modifyAt fromIndex (setPiece Nothing) afterMove)

renderSquare :: forall e.
                  Context2D ->
                  Maybe DOMEvent ->
                  Unit ->
                  Square ->
                  Eff (canvas :: Canvas, dom :: DOM | e) Unit
renderSquare ctx event _ 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 ->
                 Maybe DOMEvent ->
                 Unit ->
                 Square ->
                 Eff (canvas :: Canvas, dom :: DOM | e) Unit
renderPiece state ctx event _ square =
  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
      case event of
        Nothing -> return unit
        Just e -> do
          ux <- unsafeEventNumberProp "clientX" e
          uy <- unsafeEventNumberProp "clientY" e
          case isOnActiveSquare state.grid state.currentPlayer square (toNumber ux) (toNumber uy) of
            true -> do
              setLineWidth highlightWidth ctx
              strokePath ctx $ arc ctx arcPiece
              return unit
            false -> return unit
          return unit
      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 "black" ctx
  strokeRect ctx border
  return unit

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

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

clickListener :: forall s e.
                   STRef s State ->
                   DOMEvent ->
                   Eff (st :: ST s, canvas :: Canvas, dom :: DOM | e) Unit
clickListener st event = do
  element <- getCanvasElementById "canvas"
  case element of
    Just canvas -> do
      renderPage st (Just event)
      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 (\e -> renderPage st (Just e)) canvas
      addMouseEventListener MouseClickEvent (\e -> clickListener st e) canvas
      renderPage st Nothing
      return unit
    _ -> return unit


Update TryPureScript.purs

Update TryPureScript.purs

module TryPureScript
  ( Inline
  , Doc
  , DOM
  , text
  , p
  , link
  , code
  , h1
  , h2
  , h3
  , h4
  , h5
  , h6
  , list
  , indent
  , render
  , withConsole
  ) where

import Prelude
import Control.Monad.Eff (kind Effect, Eff)
import Data.Foldable (class Foldable, foldMap)
import Data.String (joinWith)
import Data.Monoid (class Monoid)

foreign import data DOM :: Effect

foreign import setInnerHTML
  :: forall eff
   . String
  -> Eff (dom :: DOM | eff) Unit

foreign import encode :: String -> String

foreign import withConsoleImpl
  :: forall eff a
   . Eff eff a
  -> Eff eff (Array String)

withConsole
  :: forall eff a
   . Eff eff a
  -> Eff eff Doc
withConsole f = map toDoc (withConsoleImpl f) where
  toDoc = Doc <<< tag' "pre" <<< tag' "code" <<< joinWith "\n"

tag :: String -> String -> String -> String
tag open close html = "<" <> open <> ">" <> html <> "</" <> close <> ">"

tag' :: String -> String -> String
tag' open = tag open open

newtype Inline = Inline String

unInline :: Inline -> String
unInline (Inline html) = html

derive newtype instance semigroupInline :: Semigroup Inline
derive newtype instance monoidInline :: Monoid Inline

text :: String -> Inline
text = Inline <<< encode

link :: String -> Inline -> Inline
link url (Inline html) = Inline (tag ("a href=\"" <> encode url <> "\" target=\"_top\"") "a" html)

code :: Inline -> Inline
code (Inline s) = Inline (tag' "code" s)

newtype Doc = Doc String

unDoc :: Doc -> String
unDoc (Doc html) = html

render :: forall eff. Doc -> Eff (dom :: DOM | eff) Unit
render (Doc html) = setInnerHTML html

derive newtype instance semigroupDoc :: Semigroup Doc
derive newtype instance monoidDoc :: Monoid Doc

p :: Inline -> Doc
p (Inline s) = Doc (tag' "p" s)

h1 :: Inline -> Doc
h1 (Inline s) = Doc (tag' "h1" s)

h2 :: Inline -> Doc
h2 (Inline s) = Doc (tag' "h2" s)

h3 :: Inline -> Doc
h3 (Inline s) = Doc (tag' "h3" s)

h4 :: Inline -> Doc
h4 (Inline s) = Doc (tag' "h4" s)

h5 :: Inline -> Doc
h5 (Inline s) = Doc (tag' "h5" s)

h6 :: Inline -> Doc
h6 (Inline s) = Doc (tag' "h6" s)

indent :: Doc -> Doc
indent (Doc html) = Doc (tag' "blockquote" html)

list :: forall f. Foldable f => f Inline -> Doc
list =
  Doc
  <<< tag' "ul"
  <<< unDoc
  <<< foldMap (Doc <<< tag' "li" <<< unInline)

module TryPureScript
  ( Inline
  , Doc
  , DOM
  , text
  , p
  , link
  , code
  , h1
  , h2
  , h3
  , h4
  , h5
  , h6
  , list
  , indent
  , render
  , withConsole
  ) where

import Prelude
import Control.Monad.Eff (Eff)
import Data.Foldable (class Foldable, foldMap)
import Data.String (joinWith)
import Data.Monoid (class Monoid)

foreign import data DOM :: !

foreign import setInnerHTML
  :: forall eff
   . String
  -> Eff (dom :: DOM | eff) Unit

foreign import encode :: String -> String

foreign import withConsoleImpl
  :: forall eff a
   . Eff eff a
  -> Eff eff (Array String)

withConsole
  :: forall eff a
   . Eff eff a
  -> Eff eff Doc
withConsole f = map toDoc (withConsoleImpl f) where
  toDoc = Doc <<< tag' "pre" <<< tag' "code" <<< joinWith "\n"

tag :: String -> String -> String -> String
tag open close html = "<" <> open <> ">" <> html <> "</" <> close <> ">"

tag' :: String -> String -> String
tag' open = tag open open

newtype Inline = Inline String

unInline :: Inline -> String
unInline (Inline html) = html

derive newtype instance semigroupInline :: Semigroup Inline
derive newtype instance monoidInline :: Monoid Inline

text :: String -> Inline
text = Inline <<< encode

link :: String -> Inline -> Inline
link url (Inline html) = Inline (tag ("a href=\"" <> encode url <> "\" target=\"_top\"") "a" html)

code :: Inline -> Inline
code (Inline s) = Inline (tag' "code" s)

newtype Doc = Doc String

unDoc :: Doc -> String
unDoc (Doc html) = html

render :: forall eff. Doc -> Eff (dom :: DOM | eff) Unit
render (Doc html) = setInnerHTML html

derive newtype instance semigroupDoc :: Semigroup Doc
derive newtype instance monoidDoc :: Monoid Doc

p :: Inline -> Doc
p (Inline s) = Doc (tag' "p" s)

h1 :: Inline -> Doc
h1 (Inline s) = Doc (tag' "h1" s)

h2 :: Inline -> Doc
h2 (Inline s) = Doc (tag' "h2" s)

h3 :: Inline -> Doc
h3 (Inline s) = Doc (tag' "h3" s)

h4 :: Inline -> Doc
h4 (Inline s) = Doc (tag' "h4" s)

h5 :: Inline -> Doc
h5 (Inline s) = Doc (tag' "h5" s)

h6 :: Inline -> Doc
h6 (Inline s) = Doc (tag' "h6" s)

indent :: Doc -> Doc
indent (Doc html) = Doc (tag' "blockquote" html)

list :: forall f. Foldable f => f Inline -> Doc
list =
  Doc
  <<< tag' "ul"
  <<< unDoc
  <<< foldMap (Doc <<< tag' "li" <<< unInline)


Remove warn constraint on array instance of MonadZero

-- | This module is **deprecated** and will be removed in a future release.
-- |
-- | The annihilation law witnessed by `MonadZero` is trivially satisfied by
-- | lawful monads due to parametricity: while evaluating `empty >>= f`, the
-- | function `f` can’t ever be called, since that would require `empty` to
-- | produce a value, which means that `empty >>= f` must be the same as
-- | `empty >>= pure`, which by the monad laws is just `empty`.
-- |
-- | Use `Monad` and `Alternative` constraints instead.

module Control.MonadZero
  ( class MonadZero
  , module Control.Alt
  , module Control.Alternative
  , module Control.Applicative
  , module Control.Apply
  , module Control.Bind
  , module Control.Monad
  , module Control.Plus
  , module Data.Functor
  ) where

import Control.Alt (class Alt, alt, (<|>))
import Control.Alternative (class Alternative, guard)
import Control.Applicative (class Applicative, pure, liftA1, unless, when)
import Control.Apply (class Apply, apply, (*>), (<*), (<*>))
import Control.Bind (class Bind, bind, ifM, join, (<=<), (=<<), (>=>), (>>=))
import Control.Monad (class Monad, ap, liftM1)
import Control.Plus (class Plus, empty)

import Data.Functor (class Functor, map, void, ($>), (<#>), (<$), (<$>))

import Prim.TypeError (class Warn, Text)

-- | The `MonadZero` type class has no members of its own; it just specifies
-- | that the type has both `Monad` and `Alternative` instances.
-- |
-- | Types which have `MonadZero` instances should also satisfy the following
-- | laws:
-- |
-- | - Annihilation: `empty >>= f = empty`
class (Monad m, Alternative m, Warn (Text "'MonadZero' is deprecated, use 'Monad' and 'Alternative' constraints instead")) <= MonadZero m

instance monadZeroArray :: MonadZero Array

-- | This module is **deprecated** and will be removed in a future release.
-- |
-- | The annihilation law witnessed by `MonadZero` is trivially satisfied by
-- | lawful monads due to parametricity: while evaluating `empty >>= f`, the
-- | function `f` can’t ever be called, since that would require `empty` to
-- | produce a value, which means that `empty >>= f` must be the same as
-- | `empty >>= pure`, which by the monad laws is just `empty`.
-- |
-- | Use `Monad` and `Alternative` constraints instead.

module Control.MonadZero
  ( class MonadZero
  , module Control.Alt
  , module Control.Alternative
  , module Control.Applicative
  , module Control.Apply
  , module Control.Bind
  , module Control.Monad
  , module Control.Plus
  , module Data.Functor
  ) where

import Control.Alt (class Alt, alt, (<|>))
import Control.Alternative (class Alternative, guard)
import Control.Applicative (class Applicative, pure, liftA1, unless, when)
import Control.Apply (class Apply, apply, (*>), (<*), (<*>))
import Control.Bind (class Bind, bind, ifM, join, (<=<), (=<<), (>=>), (>>=))
import Control.Monad (class Monad, ap, liftM1)
import Control.Plus (class Plus, empty)

import Data.Functor (class Functor, map, void, ($>), (<#>), (<$), (<$>))

import Prim.TypeError (class Warn, Text)

-- | The `MonadZero` type class has no members of its own; it just specifies
-- | that the type has both `Monad` and `Alternative` instances.
-- |
-- | Types which have `MonadZero` instances should also satisfy the following
-- | laws:
-- |
-- | - Annihilation: `empty >>= f = empty`
class (Monad m, Alternative m, Warn (Text "'MonadZero' is deprecated, use 'Monad' and 'Alternative' constraints instead")) <= MonadZero m

instance monadZeroArray :: Warn (Text "`Array`'s 'MonadZero' is deprecated, use 'Monad' and 'Alternative' constraints instead")) => MonadZero Array


Add cytoscape event handlers etc.

Add cytoscape event handlers etc.

module Genetics.Browser.UI.Container
       where

import Prelude
import Control.Coroutine as CR
import Control.Monad.Aff as Aff
import Control.Monad.Aff.Bus as Bus
import Genetics.Browser.Biodalliance as Biodalliance
import Genetics.Browser.Cytoscape as Cytoscape
import Genetics.Browser.Renderer.GWAS as GWAS
import Genetics.Browser.Renderer.Lineplot as QTL
import Genetics.Browser.UI.Biodalliance as UIBD
import Genetics.Browser.UI.Cytoscape as UICy
import Genetics.Browser.UI.Events.Biodalliance as BDEvents
import Halogen as H
import Halogen.Aff as HA
import Halogen.Component.ChildPath as CP
import Halogen.HTML as HH
import Halogen.HTML.Events as HE
import Control.Monad.Aff (Aff, Canceler(..), forkAff)
import Control.Monad.Aff.AVar (AVAR)
import Control.Monad.Aff.Bus (BusR, BusRW)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Console (CONSOLE, log)
import Control.Monad.Rec.Class (forever)
import DOM.HTML.Types (HTMLElement)
import Data.Argonaut (_Number, _Object, _String)
import Data.Argonaut.Core (JObject)
import Data.Array (null)
import Data.Const (Const)
import Data.Either (Either(..))
import Data.Either.Nested (Either2, Either1)
import Data.Foldable (foldMap)
import Data.Functor.Coproduct.Nested (type (<\/>))
import Data.Lens (re, (^?))
import Data.Lens.Index (ix)
import Data.Maybe (Maybe(Just, Nothing), maybe)
import Data.Newtype (wrap)
import Data.Options (Options, (:=))
import Data.Symbol (SProxy(..))
import Data.Tuple (fst)
import Data.Variant (Variant, case_, default, inj, on)
import Genetics.Browser.Biodalliance (RendererInfo, initBD, renderers, setLocation, sources)
import Genetics.Browser.Config (BrowserConfig(..))
import Genetics.Browser.Config.Track (CyGraphConfig, validateConfigs)
import Genetics.Browser.Cytoscape (ParsedEvent(..))
import Genetics.Browser.Cytoscape.Collection (filter)
import Genetics.Browser.Cytoscape.Types (CY, Cytoscape, Element, elementJObject)
import Genetics.Browser.Events (Event(..), Location, Range)
import Genetics.Browser.Renderer.Lineplot (LinePlotConfig)
import Genetics.Browser.Types (BD, Biodalliance, Renderer)
import Genetics.Browser.Units (Bp(Bp), Chr, _Bp, _BpMBp, _Chr, _MBp, bp)
import Global.Unsafe (unsafeStringify)
import Halogen.VDom.Driver (runUI)
import Unsafe.Coerce (unsafeCoerce)

type BDEventEff eff = (console :: CONSOLE, bd :: BD, avar :: AVAR | eff)

locationHandlerBD :: forall eff. Biodalliance -> Location -> Eff (BDEventEff eff) Unit
locationHandlerBD bd loc = do
  log "bd got location"
  setLocation bd loc.chr (bp loc.pos - Bp 1000000.0) (bp loc.pos + Bp 1000000.0)

rangeHandlerBD :: forall eff. Biodalliance -> Range -> Eff (BDEventEff eff) Unit
rangeHandlerBD bd ran= do
  log "bd got range"
  setLocation bd ran.chr ran.minPos ran.maxPos

type CyEventEff eff = (console :: CONSOLE, cy :: CY, avar :: AVAR | eff)

rangeHandlerCy :: forall eff. Cytoscape -> Range -> Eff (CyEventEff eff) Unit
rangeHandlerCy cy ran = do
  log "cy got range"
  let pred el = case parseLocationElementCy el of
        Nothing -> false
        Just loc -> loc.chr /= ran.chr
  graphColl <- liftEff $ Cytoscape.graphGetCollection cy
  let eles = filter (wrap pred) graphColl
  _ <- liftEff $ Cytoscape.graphRemoveCollection eles
  pure unit

createBDHandler :: forall eff. { location :: Biodalliance -> Location -> Eff _ Unit
                               , range :: Biodalliance -> Range -> Eff _ Unit }
                -> Biodalliance
                -> BusRW (Variant (location :: Location, range :: Range))
                -> Aff _ (Canceler _)
createBDHandler {location, range} bd bus = forkAff $ forever do
  val <- Bus.read bus
  liftEff $ (default (pure unit)
    # on (SProxy :: SProxy "location") (location bd)
    # on (SProxy :: SProxy "range") (range bd)
    ) val

createCyHandler :: forall eff. { range :: Cytoscape -> Range -> Eff _ Unit }
                -> Cytoscape
                -> BusRW (Variant (range :: Range))
                -> Aff _ (Canceler _)
createCyHandler {range} cy bus = forkAff $ forever do
  val <- Bus.read bus
  liftEff $ (default (pure unit)
    # on (SProxy :: SProxy "range") (range cy)
    ) val

parseRangeEventBD :: JObject -> Maybe Range
parseRangeEventBD obj = do
  chr <- obj ^? ix "chr" <<< _String <<< re _Chr
  minPos <- obj ^? ix "min" <<< _Number <<< re _Bp
  maxPos <- obj ^? ix "max" <<< _Number <<< re _Bp
  pure $ {chr, minPos, maxPos}

parseLocationElementCy :: Element -> Maybe Location
parseLocationElementCy el = do
    loc <- elementJObject el ^? ix "data" <<< _Object <<< ix "lrsLoc"
    chr <- loc ^? _Object <<< ix "chr" <<< _String <<< re _Chr
            -- ridiculous.
    pos <- loc ^? _Object <<< ix "pos" <<< _Number
                    <<< re _MBp <<< re _BpMBp
    pure $ { chr, pos }

parseLocationEventCy :: ParsedEvent -> Maybe Location
parseLocationEventCy (ParsedEvent ev) = case ev.target of
  Left el -> parseLocationElementCy el
  Right _ -> Nothing

subscribeBDEvents :: { range :: JObject -> Maybe Range
                     }
                  -> Biodalliance
                  -> BusRW (Variant (range :: Range))
                  -> Eff _ Unit
subscribeBDEvents {range} bd bus =
  Biodalliance.addFeatureListener bd $ \obj -> do
    case range obj of
      Nothing -> pure unit
      Just ran -> do
        liftEff $ log $ "BD sending range: " <> unsafeStringify range
        _ <- Aff.launchAff $ Bus.write (inj (SProxy :: SProxy "range") ran) bus
        pure unit
    -- case location obj of
    --   Nothing -> pure unit
    --   Just loc -> do
    --     _ <- Aff.launchAff $ Bus.write (inj (SProxy :: SProxy "location") loc) bus
    --     pure unit

subscribeCyEvents :: { location :: ParsedEvent -> Maybe Location }
                  -> Cytoscape
                  -> BusRW (Variant (location :: Location))
                  -> Eff _ Unit
subscribeCyEvents {location} cy bus =
  Cytoscape.onClick cy $ \obj -> do
    case location obj of
      Nothing -> pure unit
      Just loc -> do
        liftEff $ log $ "cy sending location: " <> unsafeStringify loc
        _ <- Aff.launchAff $ Bus.write (inj (SProxy :: SProxy "location") loc) bus
        pure unit

qtlGlyphify :: LinePlotConfig -> Renderer
qtlGlyphify = QTL.render

gwasGlyphify :: Renderer
gwasGlyphify = GWAS.render

data Track = BDTrack | CyTrack

type State = Unit

data Query a
  = CreateBD (∀ eff. HTMLElement -> Eff (bd :: BD | eff) Biodalliance) a
  | PropagateMessage Message a
  | BDScroll Bp a
  | BDJump Chr Bp Bp a
  | CreateCy String a
  | ResetCy a

data Message
  = BDInstance Biodalliance
  | CyInstance Cytoscape
  -- | WithCy Cytoscape

type ChildSlot = Either2 UIBD.Slot UICy.Slot

type ChildQuery = UIBD.Query <\/> UICy.Query <\/> Const Void
type Effects eff = UIBD.Effects (UICy.Effects eff)

component :: ∀ eff. H.Component HH.HTML Query Unit Message (Aff (Effects eff))
component =
  H.parentComponent
    { initialState: const initialState
    , render
    , eval
    , receiver: const Nothing
    }
  where

  initialState :: State
  initialState = unit

  render :: State -> H.ParentHTML Query ChildQuery ChildSlot (Aff (Effects eff))
  render state =
    HH.div_
      [ HH.div_
        [ HH.button
          [  HE.onClick (HE.input_ (BDScroll (Bp (-1000000.0))))
          ]
          [ HH.text "Scroll left 1MBp" ]
        , HH.button
          [  HE.onClick (HE.input_ (BDScroll (Bp 1000000.0)))
          ]
          [ HH.text "Scroll right 1MBp" ]
        , HH.button
          [  HE.onClick (HE.input_ ResetCy)
          ]
          [ HH.text "Reset cytoscape" ]
          -- these divs are used to control the sizes of the subcomponents without having to query the children
        , HH.div
            [] [HH.slot' CP.cp1 UIBD.Slot UIBD.component unit handleBDMessage]
        , HH.div
            [] [HH.slot' CP.cp2 UICy.Slot UICy.component unit handleCyMessage]
        ]
      ]

  -- addCyGraph :: Maybe CyGraphConfig -> _
  -- addCyGraph = case _ of
  --   Nothing -> []
  --   Just cy -> [HH.div [] [HH.slot' CP.cp2 UICy.Slot UICy.component unit handleCyMessage]]

  handleBDMessage :: UIBD.Message -> Maybe (Query Unit)
  handleBDMessage UIBD.Initialized = Nothing
  handleBDMessage (UIBD.SendBD bd) = Just $ H.action $ PropagateMessage (BDInstance bd)

  -- TODO the event source track should be handled automatically somehow
  handleCyMessage :: UICy.Output -> Maybe (Query Unit)
  handleCyMessage (UICy.SendCy cy) = Just $ H.action $ PropagateMessage (CyInstance cy)
  handleCyMessage (UICy.SendEvent) = Nothing

  eval :: Query ~> H.ParentDSL State Query ChildQuery ChildSlot Message (Aff (Effects eff))
  eval = case _ of
    CreateBD bd next -> do
      _ <- H.query' CP.cp1 UIBD.Slot $ H.action (UIBD.Initialize bd)
      pure next

    PropagateMessage msg next -> do
      H.raise msg
      pure next

    BDScroll dist next -> do
      _ <- H.query' CP.cp1 UIBD.Slot $ H.action (UIBD.Scroll dist)
      pure next
    BDJump chr xl xr next -> do
      _ <- H.query' CP.cp1 UIBD.Slot $ H.action (UIBD.Jump chr xl xr)
      pure next

    CreateCy div next -> do
      _ <- H.query' CP.cp2 UICy.Slot $ H.action (UICy.Initialize div)
      pure next
    ResetCy next -> do
      _ <- H.query' CP.cp2 UICy.Slot $ H.action UICy.Reset
      pure next

qtlRenderer :: RendererInfo
qtlRenderer = { name: "qtlRenderer"
              , renderer: qtlGlyphify { minScore: 4.0
                                      , maxScore: 6.0
                                      , color: "#ff0000"
                                      }
              , canvasHeight: 200.0
              }

gwasRenderer :: RendererInfo
gwasRenderer = { name: "gwasRenderer"
               , renderer: gwasGlyphify
               , canvasHeight: 300.0
               }

bdOpts :: Options Biodalliance
bdOpts = renderers := [ qtlRenderer, gwasRenderer ]

main :: BrowserConfig -> Eff _ Unit
main (BrowserConfig { wrapRenderer, browser, tracks }) = HA.runHalogenAff do

  let {bdTracks, cyGraphs} = validateConfigs tracks

      opts' = bdOpts <> sources := bdTracks.results

  liftEff $ log $ "BDTrack errors: " <> foldMap ((<>) ", ") bdTracks.errors
  liftEff $ log $ "CyGraph errors: " <> foldMap ((<>) ", ") cyGraphs.errors

  let mkBd :: (∀ eff. HTMLElement -> Eff (bd :: BD | eff) Biodalliance)
      mkBd = initBD opts' wrapRenderer browser

  liftEff $ log "running main"
  HA.awaitLoad
  el <- HA.selectElement (wrap "#psgbHolder")

  case el of
    Nothing -> do
      liftEff $ log "no element for browser!"
    Just el' -> do
      io <- runUI component unit el'
      liftEff $ log "creating BD event buses"
      busToBD <- Bus.make
      busFromBD <- Bus.make
      busToCy <- Bus.make
      busFromCy <- Bus.make

      io.subscribe $ CR.consumer $ case _ of
        BDInstance bd -> do
          liftEff $ log "attaching "
          _ <- createBDHandler { location: locationHandlerBD
                               , range: rangeHandlerBD } bd busToBD
          _ <- liftEff $ subscribeBDEvents { range: parseRangeEventBD } bd busFromBD
          pure Nothing
        _ -> pure $ Just unit

      io.subscribe $ CR.consumer $ case _ of
        CyInstance cy -> do
          _ <- createCyHandler { range: rangeHandlerCy } cy busToCy
          _ <- liftEff $ subscribeCyEvents { location: parseLocationEventCy } cy busFromCy
          pure Nothing
        _ -> pure $ Just unit

      liftEff $ log "creating BD"
      io.query $ H.action (CreateBD mkBd)

      liftEff $ log "created BD!"
      liftEff $ log $ "cytoscape enabled: " <> show (not null cyGraphs.results)
      -- when (not null cyGraphs.results) $ do
      liftEff $ log "creating Cy.js"
      io.query $ H.action (CreateCy "http://localhost:8080/eles.json")
      liftEff $ log "created cy!"

module Genetics.Browser.UI.Container
       where

import Prelude
import Control.Coroutine as CR
import Control.Monad.Aff as Aff
import Control.Monad.Aff.Bus as Bus
import Genetics.Browser.Biodalliance as Biodalliance
import Genetics.Browser.Renderer.GWAS as GWAS
import Genetics.Browser.Renderer.Lineplot as QTL
import Genetics.Browser.UI.Biodalliance as UIBD
import Genetics.Browser.UI.Cytoscape as UICy
import Genetics.Browser.UI.Events.Biodalliance as BDEvents
import Halogen as H
import Halogen.Aff as HA
import Halogen.Component.ChildPath as CP
import Halogen.HTML as HH
import Halogen.HTML.Events as HE
import Control.Monad.Aff (Aff, Canceler(..), forkAff)
import Control.Monad.Aff.AVar (AVAR)
import Control.Monad.Aff.Bus (BusR, BusRW)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Console (CONSOLE, log)
import Control.Monad.Rec.Class (forever)
import DOM.HTML.Types (HTMLElement)
import Data.Argonaut (_Number, _String)
import Data.Argonaut.Core (JObject)
import Data.Array (null)
import Data.Const (Const)
import Data.Either.Nested (Either2, Either1)
import Data.Foldable (foldMap)
import Data.Functor.Coproduct.Nested (type (<\/>))
import Data.Lens (re, (^?))
import Data.Lens.Index (ix)
import Data.Maybe (Maybe(Just, Nothing), maybe)
import Data.Newtype (wrap)
import Data.Options (Options, (:=))
import Data.Symbol (SProxy(..))
import Data.Tuple (fst)
import Data.Variant (Variant, case_, default, inj, on)
import Genetics.Browser.Biodalliance (RendererInfo, initBD, renderers, setLocation, sources)
import Genetics.Browser.Config (BrowserConfig(..))
import Genetics.Browser.Config.Track (CyGraphConfig, validateConfigs)
import Genetics.Browser.Cytoscape.Types (Cytoscape)
import Genetics.Browser.Events (Event(..), Location, Range)
import Genetics.Browser.Renderer.Lineplot (LinePlotConfig)
import Genetics.Browser.Types (BD, Biodalliance, Renderer)
import Genetics.Browser.Units (Bp(Bp), Chr, _Bp, _Chr, bp)
import Global.Unsafe (unsafeStringify)
import Halogen.VDom.Driver (runUI)
import Unsafe.Coerce (unsafeCoerce)

type BDEventEff eff = (console :: CONSOLE, bd :: BD, avar :: AVAR | eff)

locationHandler :: forall eff. Biodalliance -> Location -> Eff (BDEventEff eff) Unit
locationHandler bd loc = do
  log "got location"
  setLocation bd loc.chr (bp loc.pos - Bp 1000000.0) (bp loc.pos + Bp 1000000.0)

rangeHandler :: forall eff. Biodalliance -> Range -> Eff (BDEventEff eff) Unit
rangeHandler bd ran= do
  log "got range"
  setLocation bd ran.chr ran.minPos ran.maxPos

createBDHandler :: forall eff. { location :: Biodalliance -> Location -> Eff _ Unit
                               , range :: Biodalliance -> Range -> Eff _ Unit }
                -> Biodalliance
                -> BusRW (Variant (location :: Location, range :: Range))
                -> Aff _ (Canceler _)
createBDHandler {location, range} bd bus = forkAff $ forever do
  val <- Bus.read bus
  liftEff $ (default (pure unit)
    # on (SProxy :: SProxy "location") (location bd)
    # on (SProxy :: SProxy "range") (range bd)
    ) val

parseRangeEvent :: JObject -> Maybe Range
parseRangeEvent obj = do
  chr <- obj ^? ix "chr" <<< _String <<< re _Chr
  minPos <- obj ^? ix "min" <<< _Number <<< re _Bp
  maxPos <- obj ^? ix "max" <<< _Number <<< re _Bp
  pure $ {chr, minPos, maxPos}

subscribeBDEvents :: { range :: JObject -> Maybe Range
                     }
                  -> Biodalliance
                  -> BusRW (Variant (range :: Range))
                  -> Eff _ Unit
subscribeBDEvents {range} bd bus =
  Biodalliance.addFeatureListener bd $ \obj -> do
    case range obj of
      Nothing -> pure unit
      Just ran -> do
        _ <- Aff.launchAff $ Bus.write (inj (SProxy :: SProxy "range") ran) bus
        pure unit
    -- case location obj of
    --   Nothing -> pure unit
    --   Just loc -> do
    --     _ <- Aff.launchAff $ Bus.write (inj (SProxy :: SProxy "location") loc) bus
    --     pure unit

qtlGlyphify :: LinePlotConfig -> Renderer
qtlGlyphify = QTL.render

gwasGlyphify :: Renderer
gwasGlyphify = GWAS.render

data Track = BDTrack | CyTrack

type State = Unit

data Query a
  = Nop a
  | CreateBD (∀ eff. HTMLElement -> Eff (bd :: BD | eff) Biodalliance) a
  | PropagateMessage Message a
  | BDScroll Bp a
  | BDJump Chr Bp Bp a
  | CreateCy String a
  | ResetCy a

data Message
  = BDInstance Biodalliance
  | CyInstance Cytoscape
  -- | WithCy Cytoscape

type ChildSlot = Either2 UIBD.Slot UICy.Slot

type ChildQuery = UIBD.Query <\/> UICy.Query <\/> Const Void
type Effects eff = UIBD.Effects (UICy.Effects eff)

component :: ∀ eff. H.Component HH.HTML Query Unit Message (Aff (Effects eff))
component =
  H.parentComponent
    { initialState: const initialState
    , render
    , eval
    , receiver: const Nothing
    }
  where

  initialState :: State
  initialState = unit

  render :: State -> H.ParentHTML Query ChildQuery ChildSlot (Aff (Effects eff))
  render state =
    HH.div_
      [ HH.div_
        [ HH.button
          [  HE.onClick (HE.input_ (BDScroll (Bp (-1000000.0))))
          ]
          [ HH.text "Scroll left 1MBp" ]
        , HH.button
          [  HE.onClick (HE.input_ (BDScroll (Bp 1000000.0)))
          ]
          [ HH.text "Scroll right 1MBp" ]
        , HH.button
          [  HE.onClick (HE.input_ ResetCy)
          ]
          [ HH.text "Reset cytoscape" ]
          -- these divs are used to control the sizes of the subcomponents without having to query the children
        , HH.div
            [] [HH.slot' CP.cp1 UIBD.Slot UIBD.component unit handleBDMessage]
        , HH.div
            [] [HH.slot' CP.cp2 UICy.Slot UICy.component unit handleCyMessage]
        ]
      ]

  -- addCyGraph :: Maybe CyGraphConfig -> _
  -- addCyGraph = case _ of
  --   Nothing -> []
  --   Just cy -> [HH.div [] [HH.slot' CP.cp2 UICy.Slot UICy.component unit handleCyMessage]]

  -- handleBDMessage :: UIBD.Message bdm -> Maybe (Query r Unit)
  handleBDMessage :: UIBD.Message -> Maybe (Query Unit)
  -- handleBDMessage UIBD.Initialized = Just $ ResetCy unit
  handleBDMessage (UIBD.SendBD bd) = Just $ H.action $ PropagateMessage (BDInstance bd)
  handleBDMessage _ = Nothing

     -- TODO the event source track should be handled automatically somehow
  handleCyMessage :: _
  handleCyMessage _ = Nothing
  -- handleCyMessage :: UICy.Output cym -> Maybe (Query r Unit)
  -- handleCyMessage (UICy.SendEvent ev) = Just $ DistributeEvent CyTrack ev unit

  eval :: Query ~> H.ParentDSL State Query ChildQuery ChildSlot Message (Aff (Effects eff))
  eval = case _ of
    Nop next -> do
      pure next

    CreateBD bd next -> do
      _ <- H.query' CP.cp1 UIBD.Slot $ H.action (UIBD.Initialize bd)
      pure next

    PropagateMessage msg next -> do
      H.raise msg
      pure next

    BDScroll dist next -> do
      _ <- H.query' CP.cp1 UIBD.Slot $ H.action (UIBD.Scroll dist)
      pure next
    BDJump chr xl xr next -> do
      _ <- H.query' CP.cp1 UIBD.Slot $ H.action (UIBD.Jump chr xl xr)
      pure next

    CreateCy div next -> do
      _ <- H.query' CP.cp2 UICy.Slot $ H.action (UICy.Initialize div)
      pure next
    ResetCy next -> do
      _ <- H.query' CP.cp2 UICy.Slot $ H.action UICy.Reset
      pure next

qtlRenderer :: RendererInfo
qtlRenderer = { name: "qtlRenderer"
              , renderer: qtlGlyphify { minScore: 4.0
                                      , maxScore: 6.0
                                      , color: "#ff0000"
                                      }
              , canvasHeight: 200.0
              }

gwasRenderer :: RendererInfo
gwasRenderer = { name: "gwasRenderer"
               , renderer: gwasGlyphify
               , canvasHeight: 300.0
               }

bdOpts :: Options Biodalliance
bdOpts = renderers := [ qtlRenderer, gwasRenderer ]

main :: BrowserConfig -> Eff _ Unit
main (BrowserConfig { wrapRenderer, browser, tracks }) = HA.runHalogenAff do

  let {bdTracks, cyGraphs} = validateConfigs tracks

      opts' = bdOpts <> sources := bdTracks.results

  liftEff $ log $ "BDTrack errors: " <> foldMap ((<>) ", ") bdTracks.errors
  liftEff $ log $ "CyGraph errors: " <> foldMap ((<>) ", ") cyGraphs.errors

  let mkBd :: (∀ eff. HTMLElement -> Eff (bd :: BD | eff) Biodalliance)
      mkBd = initBD opts' wrapRenderer browser

  liftEff $ log "running main"
  HA.awaitLoad
  el <- HA.selectElement (wrap "#psgbHolder")

  case el of
    Nothing -> do
      liftEff $ log "no element for browser!"
    Just el' -> do
      io <- runUI component unit el'
      liftEff $ log "creating BD event buses"
      busToBD <- Bus.make
      busFromBD <- Bus.make
      io.subscribe $ CR.consumer $ case _ of
        BDInstance bd -> do
          _ <- createBDHandler { location: locationHandler
                               , range: rangeHandler } bd busToBD
          _ <- liftEff $ subscribeBDEvents { range: parseRangeEvent } bd busFromBD
          pure Nothing
        _ -> pure (Just unit)

      liftEff $ log "creating BD"
      io.query $ H.action (CreateBD mkBd)

      liftEff $ log "created BD!"
      liftEff $ log $ "cytoscape enabled: " <> show (not null cyGraphs.results)
      -- when (not null cyGraphs.results) $ do
      liftEff $ log "creating Cy.js"
      io.query $ H.action (CreateCy "http://localhost:8080/eles.json")
      liftEff $ log "created cy!"


Implementation for Signal.distinct

Implementation for Signal.distinct

module Signal where

import Control.Monad.Eff

foreign import data Signal :: * -> *

foreign import constant
  "function constant(initial) {\
  \    var subs = [];\
  \    var val = initial;\
  \    var sig = {\
  \      subscribe: function(sub) {\
  \        subs.push(sub);\
  \      },\
  \      get: function() { return val; },\
  \      set: function(newval) {\
  \        val = newval;\
  \        subs.forEach(function(sub) { sub(newval); });\
  \      }\
  \    };\
  \    return sig;\
  \}" :: forall a. a -> Signal a

foreign import lift
  "function lift(fun) {\
  \  return function(sig) {\
  \    var out = constant(fun(sig.get()));\
  \    sig.subscribe(function(val) { out.set(fun(val)); });\
  \    return out;\
  \  };\
  \}" :: forall a b. (a -> b) -> Signal a -> Signal b

foreign import applySig
  "function applySig(fun) {\
  \  return function(sig) {\
  \    var out = constant(fun.get()(sig.get()));\
  \    var produce = function() { out.set(fun.get()(sig.get())); };\
  \    fun.subscribe(produce);\
  \    sig.subscribe(produce);\
  \    return out;\
  \  };\
  \}" :: forall a b. Signal (a -> b) -> Signal a -> Signal b

foreign import bindSig
  "function bindSig(sig) {\
  \  return function(fun) {\
  \    var sigp = fun(sig.get());\
  \    var out = constant(sigp.get());\
  \    var moar = function(sigp) {\
  \      out.set(sigp.get());\
  \      sigp.subscribe(out.set);\
  \    };\
  \    sig.subscribe(moar);\
  \    return out;\
  \  };\
  \}" :: forall a b. Signal a -> (a -> Signal b) -> Signal b

foreign import merge
  "function merge(sig1) {\
  \  return function(sig2) {\
  \    var out = constant(sig1.get());\
  \    sig1.subscribe(out.set);\
  \    sig2.subscribe(out.set);\
  \    return out;\
  \  };\
  \}" :: forall a. Signal a -> Signal a -> Signal a

foreign import foldp
  "function foldp(fun) {\
  \  return function(seed) {\
  \    return function(sig) {\
  \      var acc = fun(sig.get(), seed);\
  \      var out = constant(acc);\
  \      sig.subscribe(function(val) {\
  \        acc = fun(val, acc);\
  \        out.set(acc);\
  \      });\
  \      return out;\
  \    };\
  \  };\
  \}" :: forall a b. (a -> b -> b) -> b -> Signal a -> Signal b

foreign import sampleOn
  "function sampleOn(sig1) {\
  \  return function(sig2) {\
  \    var out = constant(sig2.get());\
  \    sig1.subscribe(function() {\
  \      out.set(sig2.get());\
  \    });\
  \    return out;\
  \  };\
  \}" :: forall a b. Signal a -> Signal b -> Signal b

foreign import distinct
  "function distinct(eq) {\
  \  return function(sig) {\
  \    var val = sig.get();\
  \    var out = constant(val);\
  \    sig.subscribe(function(newval) {\
  \      if (eq['/='](val, newval)) {\
  \        val = newval;\
  \        out.set(val);\
  \      }\
  \    });\
  \    return out;\
  \  };\
  \}" :: forall a. (Eq a) => Signal a -> Signal a

foreign import runSignal
  "function runSignal(sig) {\
  \  return function() {\
  \    sig.subscribe(function(val) {\
  \      val();\
  \    });\
  \    return {};\
  \  };\
  \}" :: forall e. Signal (Eff e Unit) -> Eff e Unit

foreign import unwrap
  "function unwrap(sig) {\
  \  return function() {\
  \    var out = constant(sig.get()());\
  \    sig.subscribe(function(val) { out.set(val()); });\
  \    return out;\
  \  };\
  \}" :: forall e a. Signal (Eff e a) -> Eff e (Signal a)

instance functorSignal :: Functor Signal where
  (<$>) = lift

instance applySignal :: Apply Signal where
  (<*>) = applySig

instance applicativeSignal :: Applicative Signal where
  pure = constant

instance bindSignal :: Bind Signal where
  (>>=) = bindSig

instance monadSignal :: Monad Signal

instance semigroupSignal :: Semigroup (Signal a) where
  (<>) = merge

infixl 4 <~
(<~) :: forall f a b. (Functor f) => (a -> b) -> f a -> f b
(<~) = (<$>)

infixl 4 ~>
(~>) :: forall f a b. (Functor f) => f a -> (a -> b) -> f b
(~>) = flip (<$>)

infixl 4 ~
(~) :: forall f a b. (Apply f) => f (a -> b) -> f a -> f b
(~) = (<*>)

module Signal where

import Control.Monad.Eff

foreign import data Signal :: * -> *

foreign import constant
  "function constant(initial) {\
  \    var subs = [];\
  \    var val = initial;\
  \    var sig = {\
  \      subscribe: function(sub) {\
  \        subs.push(sub);\
  \      },\
  \      get: function() { return val; },\
  \      set: function(newval) {\
  \        val = newval;\
  \        subs.forEach(function(sub) { sub(newval); });\
  \      }\
  \    };\
  \    return sig;\
  \}" :: forall a. a -> Signal a

foreign import lift
  "function lift(fun) {\
  \  return function(sig) {\
  \    var out = constant(fun(sig.get()));\
  \    sig.subscribe(function(val) { out.set(fun(val)); });\
  \    return out;\
  \  };\
  \}" :: forall a b. (a -> b) -> Signal a -> Signal b

foreign import applySig
  "function applySig(fun) {\
  \  return function(sig) {\
  \    var out = constant(fun.get()(sig.get()));\
  \    var produce = function() { out.set(fun.get()(sig.get())); };\
  \    fun.subscribe(produce);\
  \    sig.subscribe(produce);\
  \    return out;\
  \  };\
  \}" :: forall a b. Signal (a -> b) -> Signal a -> Signal b

foreign import bindSig
  "function bindSig(sig) {\
  \  return function(fun) {\
  \    var sigp = fun(sig.get());\
  \    var out = constant(sigp.get());\
  \    var moar = function(sigp) {\
  \      out.set(sigp.get());\
  \      sigp.subscribe(out.set);\
  \    };\
  \    sig.subscribe(moar);\
  \    return out;\
  \  };\
  \}" :: forall a b. Signal a -> (a -> Signal b) -> Signal b

foreign import merge
  "function merge(sig1) {\
  \  return function(sig2) {\
  \    var out = constant(sig1.get());\
  \    sig1.subscribe(out.set);\
  \    sig2.subscribe(out.set);\
  \    return out;\
  \  };\
  \}" :: forall a. Signal a -> Signal a -> Signal a

foreign import foldp
  "function foldp(fun) {\
  \  return function(seed) {\
  \    return function(sig) {\
  \      var acc = fun(sig.get(), seed);\
  \      var out = constant(acc);\
  \      sig.subscribe(function(val) {\
  \        acc = fun(val, acc);\
  \        out.set(acc);\
  \      });\
  \      return out;\
  \    };\
  \  };\
  \}" :: forall a b. (a -> b -> b) -> b -> Signal a -> Signal b

foreign import sampleOn
  "function sampleOn(sig1) {\
  \  return function(sig2) {\
  \    var out = constant(sig2.get());\
  \    sig1.subscribe(function() {\
  \      out.set(sig2.get());\
  \    });\
  \    return out;\
  \  };\
  \}" :: forall a b. Signal a -> Signal b -> Signal b

-- TODO
-- foreign import distinct
--   "function distinct(sig) {\
--   \  var val = sig.get();\
--   \  var out = constant(val);\
--   \  sig.subscribe(function(val) {\
--   \    console.log(val);\
--   \  });\
--   \}" :: forall a. (Eq a) => Signal a -> Signal a

foreign import runSignal
  "function runSignal(sig) {\
  \  return function() {\
  \    sig.subscribe(function(val) {\
  \      val();\
  \    });\
  \    return {};\
  \  };\
  \}" :: forall e. Signal (Eff e Unit) -> Eff e Unit

foreign import unwrap
  "function unwrap(sig) {\
  \  return function() {\
  \    var out = constant(sig.get()());\
  \    sig.subscribe(function(val) { out.set(val()); });\
  \    return out;\
  \  };\
  \}" :: forall e a. Signal (Eff e a) -> Eff e (Signal a)

instance functorSignal :: Functor Signal where
  (<$>) = lift

instance applySignal :: Apply Signal where
  (<*>) = applySig

instance applicativeSignal :: Applicative Signal where
  pure = constant

instance bindSignal :: Bind Signal where
  (>>=) = bindSig

instance monadSignal :: Monad Signal

instance semigroupSignal :: Semigroup (Signal a) where
  (<>) = merge

infixl 4 <~
(<~) :: forall f a b. (Functor f) => (a -> b) -> f a -> f b
(<~) = (<$>)

infixl 4 ~>
(~>) :: forall f a b. (Functor f) => f a -> (a -> b) -> f b
(~>) = flip (<$>)

infixl 4 ~
(~) :: forall f a b. (Apply f) => f (a -> b) -> f a -> f b
(~) = (<*>)


Sorted newtype

Sorted newtype

module Main where

import Data.Array
import Data.Function (on)
import Data.Foldable (foldr)

import Merge
import Tree

import Test.QuickCheck
import Test.QuickCheck.LCG

isSorted :: forall a. (Ord a) => [a] -> Boolean
isSorted (x1 : t@(x2 : xs)) = x1 <= x2 && isSorted t
isSorted _ = true

isSubarrayOf :: forall a. (Eq a) => [a] -> [a] -> Boolean
isSubarrayOf xs ys = ys `intersect` xs == xs

newtype Sorted a = Sorted [a]

sorted :: forall a. Sorted a -> [a]
sorted (Sorted xs) = xs

instance arbSorted :: (Arbitrary a, Ord a) => Arbitrary (Sorted a) where
  arbitrary = Sorted <<< sort <$> arbitrary

numbers :: [Number] -> [Number]
numbers = id

numberToBool :: (Number -> Boolean) -> Number -> Boolean
numberToBool = id

instance arbTree :: (Arbitrary a, Ord a) => Arbitrary (Tree a) where
  arbitrary = fromArray <<< sorted <$> arbitrary

main = do
  -- Tests for module 'Merge'

  quickCheck $ \xs ys -> isSorted $ merge (sorted xs) (sorted ys)
  quickCheck $ \xs ys -> xs `isSubarrayOf` merge xs ys

  quickCheck $ \xs ys -> isSorted $ numbers $ mergePoly (sorted xs) (sorted ys)
  quickCheck $ \xs ys -> numbers xs `isSubarrayOf` mergePoly xs ys

  quickCheck $ \xs ys f -> isSorted $ map f $ mergeWith (numberToBool f) (sortBy (compare `on` f) xs) (sortBy (compare `on` f) ys)
  quickCheck $ \xs ys f -> xs `isSubarrayOf` mergeWith (numberToBool f) xs ys

  -- Tests for module 'Tree'

  quickCheck $ \t a -> member a $ insert a (t :: Tree Number)
  quickCheck $ \xs -> isSorted $ toArray $ foldr insert Leaf $ numbers xs

module Main where

import Data.Array
import Data.Function (on)
import Data.Foldable (foldr)

import Merge
import Tree

import Test.QuickCheck
import Test.QuickCheck.LCG

isSorted :: forall a. (Ord a) => [a] -> Boolean
isSorted (x1 : t@(x2 : xs)) = x1 <= x2 && isSorted t
isSorted _ = true

isSubarrayOf :: forall a. (Eq a) => [a] -> [a] -> Boolean
isSubarrayOf xs ys = ys `intersect` xs == xs

numbers :: [Number] -> [Number]
numbers = id

numberToBool :: (Number -> Boolean) -> Number -> Boolean
numberToBool = id

instance arbTree :: (Arbitrary a, Ord a) => Arbitrary (Tree a) where
  arbitrary = fromArray <<< sort <$> arbitrary

main = do
  -- Tests for module 'Merge'

  quickCheck $ \xs ys -> isSorted $ merge (sort xs) (sort ys)
  quickCheck $ \xs ys -> xs `isSubarrayOf` merge xs ys

  quickCheck $ \xs ys -> isSorted $ numbers $ mergePoly (sort xs) (sort ys)
  quickCheck $ \xs ys -> numbers xs `isSubarrayOf` mergePoly xs ys

  quickCheck $ \xs ys f -> isSorted $ map f $ mergeWith (numberToBool f) (sortBy (compare `on` f) xs) (sortBy (compare `on` f) ys)
  quickCheck $ \xs ys f -> xs `isSubarrayOf` mergeWith (numberToBool f) xs ys

  -- Tests for module 'Tree'

  quickCheck $ \t a -> member a $ insert a (t :: Tree Number)
  quickCheck $ \xs -> isSorted $ toArray $ foldr insert Leaf $ numbers xs


Drop redundant module

Drop redundant module

module Pux.Routing.Bob.Frame where

import Prelude
import Pux.Router as Pux.Router
import Control.Monad.Aff (liftEff')
import Control.Monad.Eff (Eff)
import DOM (DOM)
import Data.Bifunctor (class Bifunctor)
import Data.Const (getConst, Const(Const))
import Data.Generic (class Generic)
import Data.Identity (Identity(Identity), runIdentity)
import Data.Maybe (Maybe(Nothing, Just))
import Data.String (dropWhile)
import Pux (Update, EffModel, onlyEffects)
import Pux.Html (Attribute, a)
import Pux.Html.Attributes (href)
import Pux.Html.Elements (Html)
import Pux.Html.Events (onClick)
import Pux.Routing.Bob (push)
import Routing.Bob (Router, fromUrl, toUrl)
import Signal (Signal, (~>))

type Path = String
data RoutingError = NotFound String

data RoutingRequest route = Route route | UrlChanged String
data RouterResponse route = Routed route | RoutingError RoutingError

data AppAction route action
  = RouterResponse (RouterResponse route)
  | RawAction action

data Action route action
  = RoutingRequest (RoutingRequest route)
  | AppAction (AppAction route action)

instance bifunctorAction :: Bifunctor Action where
  bimap f _ (RoutingRequest (Route r)) = RoutingRequest (Route (f r))
  bimap f _ (AppAction (RouterResponse (Routed r))) = routed (f r)
  bimap _ g (AppAction (RawAction a)) = rawAction (g a)
  bimap _ _ (RoutingRequest (UrlChanged p)) = RoutingRequest (UrlChanged p)
  bimap _ _ (AppAction (RouterResponse (RoutingError re))) =
    AppAction (RouterResponse (RoutingError re))

rawAction :: forall action route. action -> Action route action
rawAction = AppAction <<< RawAction

routed :: forall action route. route -> Action route action
routed = AppAction <<< RouterResponse <<< Routed

requestRoute :: forall action route. route -> Action route action
requestRoute = RoutingRequest <<< Route

-- types order similar as in Update alias
type ActionUpdate state route action eff =
  action -> state -> EffModel state (Action route action) (dom :: DOM | eff)

type RouteUpdate state route action eff =
  RouterResponse route -> state -> EffModel state (Action route action) (dom :: DOM | eff)

type State route state = { currentRoute :: route | state}

appUpdate :: forall action eff route state.
              Router route ->
              ActionUpdate (State route state) route action eff ->
              RouteUpdate (State route state) route action eff ->
              Update (State route state) (Action route action) (dom :: DOM | eff)
appUpdate router actionUpdate routeUpdate =
  update'
 where
  update' (AppAction (RawAction a)) state = actionUpdate a state
  update' (AppAction (RouterResponse r)) state = routeUpdate r state
  update' (RoutingRequest (Route r)) state =
    let url = toUrl router r
    in onlyEffects state [ liftEff' (push url) >>= (const <<< pure $ routed r) ]
  update' (RoutingRequest (UrlChanged p)) state =
    onlyEffects
      state
      [ case fromUrl router (dropWhile (_ == '/') p) of
          Just r -> pure <<< routed $ r
          Nothing -> pure <<< AppAction <<< RouterResponse <<< RoutingError <<< NotFound $ p
      ]

link :: forall action route.
        (Generic route) =>
        Router route ->
        route ->
        Array (Attribute (Action route action)) ->
        Array (Html (Action route action)) ->
        Html (Action route action)
link router route attrs children =
  let url = toUrl router route
      attrs' = [ href url
               , onClick (const (RoutingRequest <<< Route $ route))
               ] <> attrs
  in a attrs' children

sampleUrl :: forall action route eff.
             Eff (dom :: DOM | eff) (Signal (Action route action))
sampleUrl =
  Pux.Router.sampleUrl >>= pure <<< (_ ~> RoutingRequest <<< UrlChanged)

-- | I've no idea how to preserve simple Functor API,
-- | because inside view we want to call "href (toUrl router route)"
-- | and route has to be "updated" from the outside somehow
-- | in case of component reusability:
--    * we have to allow
type View =
  forall action action' route route' state. (Generic route') =>
    Router route' ->
    (forall b.  (Bifunctor b) =>
      (b route action -> b route' action')) ->
    state ->
    Html (Action route' action')

-- sampleUrl' :: forall route eff. Eff (dom :: DOM | eff) (Signal (RouterAction route))
-- sampleUrl' = Pux.Router.sampleUrl >>= (pure <<< (_ ~> UrlChanged))

-- subroute :: forall action route. Lens subroute route ->
-- makeSubroute subRouteLens subStateLens subroute =
--   subroute'
--  where
--   newSubroute = view lens newRoute
--   subroute' prevRoute newRoute state =
--     if view subRouteLens newRoute == view subRouteLens prevRoute
--       then
--         noEffects state
--       else
--         let result = subroute newSubroute
--         in { set subStateLens state result.state
--            , set su
--