Fix jumpiness when scrolling by locking view width

module Genetics.Browser.Track.UI where

import Prelude

import Color (black)
import Control.Coroutine (Consumer, Process, runProcess, ($$))
import Control.Coroutine as Co
import Control.Monad.Aff (Aff, Fiber, Milliseconds, delay, finally, forkAff, killFiber, launchAff, launchAff_)
import Control.Monad.Aff.AVar (AVar, makeEmptyVar, makeVar, putVar, readVar, takeVar, tryTakeVar)
import Control.Monad.Eff (Eff, foreachE)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Exception (error)
import Control.Monad.Eff.Uncurried (EffFn4, runEffFn4)
import Control.Monad.Error.Class (throwError)
import Control.Monad.Rec.Class (forever)
import DOM.Classy.Node (toNode)
import DOM.Classy.ParentNode (toParentNode)
import DOM.HTML (window) as DOM
import DOM.HTML.Types (htmlDocumentToDocument) as DOM
import DOM.HTML.Window (document) as DOM
import DOM.Node.Element as DOM
import DOM.Node.Node (appendChild) as DOM
import DOM.Node.ParentNode (querySelector) as DOM
import DOM.Node.Types (Element, Node)
import Data.Argonaut (Json, _Number, _Object, _String)
import Data.Array as Array
import Data.Bifunctor (bimap)
import Data.BigInt (BigInt)
import Data.BigInt as BigInt
import Data.Either (Either(..), note)
import Data.Filterable (filter)
import Data.Foldable (class Foldable, foldMap, for_, null)
import Data.Lens (to, (^.), (^?))
import Data.Lens.Index (ix)
import Data.List (List)
import Data.List as List
import Data.Map (Map)
import Data.Maybe (Maybe(Just, Nothing), fromJust, fromMaybe)
import Data.Monoid (class Monoid, mempty)
import Data.Newtype (wrap)
import Data.Nullable (Nullable, toMaybe)
import Data.Pair (Pair(..))
import Data.Symbol (SProxy(..))
import Data.Traversable (traverse, traverse_)
import Data.Tuple (Tuple(Tuple))
import Genetics.Browser.Track.Backend (Padding, RenderedTrack, browser, bumpFeatures, zipMapsWith)
import Genetics.Browser.Track.Demo (BedFeature, GWASFeature, Annot, annotLegendTest, demoTracksBed, getAnnotations, getBedGenes, getGWAS, produceAnnots, produceGWAS, produceGenes)
import Genetics.Browser.Types (Bp(..), ChrId(ChrId), Point)
import Genetics.Browser.Types.Coordinates (CoordSys, _TotalSize, coordSys, pairSize, scalePairBy, translatePairBy)
import Graphics.Canvas (CanvasElement, Context2D, getContext2D)
import Graphics.Canvas as Canvas
import Graphics.Drawing (Drawing, fillColor, filled, rectangle, white)
import Graphics.Drawing as Drawing
import Partial.Unsafe (unsafeCrashWith, unsafePartial)
import Unsafe.Coerce (unsafeCoerce)

foreign import getScreenSize :: forall eff. Eff eff { width :: Number, height :: Number }

-- 1st element is a backbuffer, 2nd the one shown on screen
foreign import scrollCanvas :: forall eff.
                               CanvasElement
                            -> CanvasElement
                            -> Point
                            -> Eff eff Unit

foreign import canvasDragImpl :: forall eff.
                                 CanvasElement
                              -> ( { during :: Nullable Point
                                   , total :: Nullable Point } -> Eff eff Unit )
                              -> Eff eff Unit

canvasDrag :: (Either Point Point -> Eff _ Unit)
           -> CanvasElement
           -> Eff _ Unit
canvasDrag f el =
  let toEither g {during, total} = case toMaybe during of
        Just p  -> g $ Right p
        Nothing -> g $ Left $ fromMaybe {x:zero, y:zero} $ toMaybe total
  in canvasDragImpl el (toEither f)

-- creates a new CanvasElement, not attached to the DOM and thus not visible
foreign import newCanvas :: forall eff.
                            { width :: Number, height :: Number }
                         -> Eff eff CanvasElement

-- set an event to fire on the given button id

foreign import buttonEvent :: forall eff.
                              String
                           -> Eff eff Unit
                           -> Eff eff Unit

foreign import setViewUI :: forall eff. String -> Eff eff Unit

type ViewRange = Pair BigInt

data UpdateView =
    ScrollView Number
  | ZoomView Number
  | ModView (ViewRange -> ViewRange)

instance showUpdateView :: Show UpdateView where
  show (ScrollView x) = "(Scroll by " <> show x <> ")"
  show (ZoomView s) = "(Zoom by " <> show s <> ")"
  show _ = "(ModView)"

    -- TODO idk if this instance makes sense??? whatevs
instance semigroupUpdateView :: Semigroup UpdateView where
  append (ScrollView x1) (ScrollView x2) = ScrollView (x1 + x2)
  append (ZoomView s1)   (ZoomView s2)   = ZoomView   (s1 * s2)
  append _ y = y

instance monoidUpdateView :: Monoid UpdateView where
  mempty = ModView id

updateViewFold :: UpdateView
               -> ViewRange
               -> ViewRange
updateViewFold uv iv@(Pair l r) = case uv of
  ZoomView   x -> iv `scalePairBy`     x
  ScrollView x -> iv `translatePairBy` x
  ModView f    -> f iv

queueCmd :: AVar UpdateView -> UpdateView -> Eff _ Unit
queueCmd av cmd = launchAff_ $ putVar cmd av

btnScroll :: Number -> AVar UpdateView -> Eff _ Unit
btnScroll x av = do
  buttonEvent "scrollLeft"  $ queueCmd av $ ScrollView (-x)
  buttonEvent "scrollRight" $ queueCmd av $ ScrollView   x

btnZoom :: Number -> AVar UpdateView -> Eff _ Unit
btnZoom x av = do
  buttonEvent "zoomOut" $ queueCmd av $ ZoomView $ 1.0 + x
  buttonEvent "zoomIn"  $ queueCmd av $ ZoomView $ 1.0 - x

-- TODO handle normalization of view
-- TODO sync up graphical canvas-scrolling with actual browser viewstate
dragScroll :: Number
           -> BrowserCanvas
           -> AVar UpdateView
           -> Eff _ Unit
dragScroll width cnv av =
  let f = case _ of
        Left  {x,y} -> queueCmd av $ ScrollView $ g (-x)
        Right {x,y} -> scrollCanvas cnv.buffer cnv.track {x: -x, y: zero}
      g x = x / width
  in canvasDrag f cnv.overlay

foreign import canvasWheelCBImpl :: forall eff.
                                    CanvasElement
                                 -> (Number -> Eff eff Unit)
                                 -> Eff eff Unit

wheelZoom :: Number
           -> AVar UpdateView
           -> CanvasElement
           -> Eff _ Unit
wheelZoom scale av cv =
  canvasWheelCBImpl cv \dY ->
    queueCmd av $ ZoomView $ 1.0 + (scale * dY)

-- TODO differentiate scroll buffer & rendering buffer
type BrowserCanvas = { buffer  :: CanvasElement
                     , track   :: CanvasElement
                     , overlay :: CanvasElement
                     }

createBrowserCanvas :: Element
                    -> { width :: Number, height :: Number }
                    -> Canvas.TranslateTransform
                    -> Eff _ BrowserCanvas
createBrowserCanvas el dim trackTT = do
  let node :: CanvasElement -> Node
      node = unsafeCoerce
      element :: CanvasElement -> Element
      element = unsafeCoerce

  buffer  <- newCanvas dim
  track   <- newCanvas dim
  -- Translate the origin of the Track canvas;
  -- useful to place the origin within the vertical padding and horizontal UI elements
  void $ Canvas.getContext2D track >>= Canvas.translate trackTT

  overlay <- newCanvas dim

  DOM.setId (wrap "buffer")  (element buffer)
  DOM.setId (wrap "track")   (element track)
  DOM.setId (wrap "overlay") (element overlay)

  DOM.setAttribute "style" (   "width: "  <> show dim.width  <> "px"
                          <> "; height: " <> show dim.height <> "px"
                          <> "; position:relative"
                          <> "; border: 1px solid black; display: block; margin: 0; padding: 0"
                          ) el

  let css i = "position:absolute; z-index: " <> i

  DOM.setAttribute "style" (css "1") (element track)
  DOM.setAttribute "style" (css "2") (element overlay)

  _ <- DOM.appendChild (node track)   (toNode el)
  _ <- DOM.appendChild (node overlay) (toNode el)

  pure { buffer, track, overlay }

cSys :: CoordSys ChrId BigInt
cSys = coordSys mouseChrSizes

mouseChrSizes :: Array (Tuple ChrId BigInt)
mouseChrSizes =
  unsafePartial
  $ map (bimap ChrId (fromJust <<< BigInt.fromString))
      [ Tuple "1"   "195471971"
      , Tuple "2"   "182113224"
      , Tuple "3"   "160039680"
      , Tuple "4"   "156508116"
      , Tuple "5"   "151834684"
      , Tuple "6"   "149736546"
      , Tuple "7"   "145441459"
      , Tuple "8"   "129401213"
      , Tuple "9"   "124595110"
      , Tuple "10"  "130694993"
      , Tuple "11"  "122082543"
      , Tuple "12"  "120129022"
      , Tuple "13"  "120421639"
      , Tuple "14"  "124902244"
      , Tuple "15"  "104043685"
      , Tuple "16"  "98207768"
      , Tuple "17"  "94987271"
      , Tuple "18"  "90702639"
      , Tuple "19"  "61431566"
      , Tuple "X"   "171031299"
      , Tuple "Y"   "91744698"
      ]

type DataURLs = { gwas        :: Maybe String
                , annotations :: Maybe String
                , genes       :: Maybe String
                }

type Conf = { browserHeight :: Number
            , padding :: Padding
            , score :: { min :: Number, max :: Number, sig :: Number }
            , urls :: DataURLs
            }

foreign import timeFun :: forall eff a. (Unit -> a) -> Eff eff Unit

foreign import drawImageMany :: forall eff a.
                                EffFn4 eff
                                CanvasElement
                                Context2D
                                { width :: Number, height :: Number }
                                (Array Point)
                                Unit

renderBatch :: CanvasElement
            -> { drawing :: Drawing, points :: Array Point }
            -> Context2D
            -> Eff _ Unit
renderBatch buffer {drawing, points} ctx = do
  -- hardcoded glyph sizes for now.
  let r = 13.0
      d = r * 2.0
      dim = { width: 100.0, height: d }
                          -- width even more hardcoded to deal with long text!
  _ <- Canvas.setCanvasDimensions dim buffer
  bfrCtx <- Canvas.getContext2D buffer
  Drawing.render bfrCtx $ Drawing.translate r r drawing
  let img = Canvas.canvasElementToImageSource buffer
  runEffFn4 drawImageMany buffer ctx dim points

viewMachine :: forall r.
               CoordSys _ _
            -> Milliseconds
            -> { viewRange :: AVar ViewRange
               , viewCmds :: AVar UpdateView | r }
            -> AVar Unit
            -> Aff _ Unit
viewMachine cs timeout { viewRange, viewCmds } ready = do

  curCmdVar <- makeVar mempty

  let limL = zero
      limR = cs ^. _TotalSize

      loop' updater = do
        cmd <- takeVar viewCmds

        killFiber (error "Resetting view update") updater

        curCmd <- takeVar curCmdVar
        let cmd' = curCmd <> cmd
        putVar cmd' curCmdVar

        updater' <- forkAff do
            delay timeout

            vr <- takeVar viewRange
                -- update view using received cmd, limiting view to provided boundaries
            let (Pair l' r') = updateViewFold cmd' vr
                -- arbitrary minimum of 400 units shown, so things don't go too crazy when zoomed in
                -- TODO bake into updateViewFold or handle at a better place/in a nicer way
                len = r' - l'
                vr' = case l' < limL, r' > limR of
                        true, false  -> Pair limL len
                        false, true  -> Pair (limR - len) limR
                        true, true   -> Pair limL limR
                        false, false -> Pair l' r'

            putVar vr' viewRange
            putVar unit ready
            takeVar curCmdVar *> putVar mempty curCmdVar

        loop' updater'

  loop' (pure unit)

renderLoop :: CoordSys _ _
           -> { tracks     :: Pair BigInt -> List (Array RenderedTrack)
              , relativeUI :: Pair BigInt -> Drawing
              , fixedUI :: Drawing }
           -> Number
           -> BrowserCanvas
           -> { viewRange   :: AVar ViewRange
              , viewCmds    :: AVar UpdateView
              , renderFiber :: AVar (Fiber _ Unit) }
           -> AVar Unit
           -> Aff _ Unit
renderLoop cSys browser trackDisplayWidth canvases state ready = forever do

  _ <- takeVar ready

  visible <- readVar state.viewRange
  -- if there's a rendering fiber running, we kill it
  traverse_ (killFiber (error "Resetting renderer"))
    =<< tryTakeVar state.renderFiber

  let scale = BigInt.toNumber (pairSize visible) / trackDisplayWidth
      (Pair l _ ) = visible
      offset = BigInt.toNumber l / scale
      tracks = browser.tracks visible

  -- fork a new renderFiber
  renderFiber <- forkAff $ renderGlyphs visible scale tracks canvases
  putVar renderFiber state.renderFiber

  liftEff $ do
    trackCtx   <- getContext2D canvases.track
    overlayCtx <- getContext2D canvases.overlay

    -- Shift canvas so we render to the visible part
    -- this shit ugly af tho, all of this gotta get redone~~
    void $ Canvas.withContext trackCtx do
      void $ Canvas.translate
        { translateX: (-offset), translateY: zero } trackCtx
      Drawing.render trackCtx $ browser.relativeUI visible

    Drawing.render overlayCtx browser.fixedUI

renderGlyphs :: Pair BigInt
             -> Number
             -> List (Array RenderedTrack)
             -> BrowserCanvas
             -> Aff _ Unit
renderGlyphs vw@(Pair l _) viewScale ts canvases = do

  -- Blank out the track canvas and get its context
  trackCtx <- liftEff do
    {width, height} <- Canvas.getCanvasDimensions canvases.track
    trackCtx <- getContext2D canvases.track
    Drawing.render trackCtx
      $ filled (fillColor white) $ rectangle 0.0 0.0 width height
    pure trackCtx

  let offset = BigInt.toNumber l / viewScale
      vw'@(Pair pxL pxR) = map (\x -> (BigInt.toNumber x / viewScale)) vw

  -- Predicates to filter out glyphs that would not be visible on screen
     -- Hack to render more of the canvas just to be sure
      pxL' = pxL - (pxR - pxL)
      pxR' = pxR + (pxR - pxL)
      predB p = p.x - 10.0 > pxL'
             && p.x + 10.0 < pxR'
      predS s = s.width >= one
             && s.point.x - s.width > pxL'
             && s.point.x + s.width < pxR'

      shiftView x =
        void $ liftEff $ Canvas.translate { translateX: x, translateY: zero } trackCtx

  -- Shift canvas so we render to the visible part
  shiftView (-offset)

  -- Make sure we unshift even if renderer is killed
  finally (shiftView offset) do

    for_ ts \track -> do
      for_ track \t -> do
        case t of
          Left {drawing, points}  -> do
            let points' = filter predB points
            liftEff $
              renderBatch canvases.buffer {drawing, points: points'} trackCtx

          Right gs -> do
            let gs' = filter predS gs
            liftEff $ foreachE gs' \s ->
              Drawing.render trackCtx
                $ Drawing.translate s.point.x s.point.y
                $ s.drawing

        -- delay to give the UI thread a moment
        delay (wrap 3.0)

-- TODO this could almost certainly be done better
chunkConsumer :: forall m a.
                 Foldable m
              => Monoid (m a)
              => AVar (m a)
              -> Consumer (m a) (Aff _) Unit
chunkConsumer av = Co.consumer \m ->
  if null m
     then pure $ Just unit
     else do
       sofar <- takeVar av

       let new = sofar <> m

       putVar new av
       delay (wrap 20.0)

       pure Nothing

type TrackVar a = AVar (Map ChrId (Array a))

-- | Starts threads that fetch & parse each of the provided tracks,
-- | filling an AVar over time per track, which can be used by other parts of the application
-- | (read only, should be a newtype)
fetchLoop :: CoordSys ChrId BigInt
          -> DataURLs
          -> Aff _
               { gwas :: TrackVar (GWASFeature ())
               , genes :: TrackVar BedFeature
               , annotations :: TrackVar (Annot ())
               }
fetchLoop cs urls = do
  gwasProd   <- traverse (produceGWAS cs) urls.gwas
  annotsProd <- traverse (produceAnnots cs) urls.annotations
  genesProd  <- traverse (produceGenes cs) urls.genes

  gwas        <- makeVar mempty
  annotations <- makeVar mempty
  genes       <- makeVar mempty

  let gwasProc :: Maybe (Process (Aff _) Unit)
      gwasProc   = (_ $$ chunkConsumer gwas)   <$> gwasProd
      annotsProc = (_ $$ chunkConsumer annotations) <$> annotsProd
      genesProc  = (_ $$ chunkConsumer genes)  <$> genesProd

  _ <- traverse forkAff (runProcess <$> gwasProc)
  _ <- traverse forkAff (runProcess <$> annotsProc)
  _ <- traverse forkAff (runProcess <$> genesProc)

  pure { gwas, annotations, genes }

runBrowser :: Conf -> Eff _ _
runBrowser config = launchAff $ do

  {width} <- liftEff $ getScreenSize

  let height = config.browserHeight
      browserDimensions = {width, height}
      vScaleWidth = 60.0
      legendWidth = 120.0
      trackWidth = width - (vScaleWidth + legendWidth)

  bCanvas <- do
    doc <- liftEff $ DOM.htmlDocumentToDocument
           <$> (DOM.document =<< DOM.window)
    cont <- liftEff $ DOM.querySelector (wrap "#browser") (toParentNode doc)

    case cont of
      Nothing -> throwError $ error "Could not find browser element"
      Just el -> liftEff do
        createBrowserCanvas
          el browserDimensions
          { translateX: vScaleWidth
          , translateY: zero }

  trackData <- do
    genes <- traverse (getBedGenes cSys) config.urls.genes
    gwas  <- traverse (getGWAS  cSys) config.urls.gwas
    rawAnnotations <-
      traverse (getAnnotations cSys) config.urls.annotations

    let annotations = zipMapsWith
                       (bumpFeatures (to _.score) (SProxy :: SProxy "score")
                         (Bp 1000000.0))
                       <$> gwas <*> rawAnnotations

    pure { genes, gwas, annotations }

  let initialView :: Pair BigInt
      initialView = Pair zero (cSys^._TotalSize)

  viewCmds <- makeEmptyVar
  liftEff $ do
    btnScroll 0.05 viewCmds
    btnZoom   0.10 viewCmds
    dragScroll trackWidth bCanvas viewCmds
    wheelZoom 0.02 viewCmds bCanvas.overlay

  viewRange <- makeVar initialView

  renderFiber <- makeEmptyVar

  let
      entries = foldMap annotLegendTest trackData.annotations
      legend = { width: legendWidth, entries }
      s = config.score
      vscale = { width: vScaleWidth, color: black
               , min: s.min, max: s.max, sig: s.sig }
      tracks = demoTracksBed vscale trackData
      mainBrowser = browser cSys browserDimensions config.padding {legend, vscale} tracks
      viewTimeout = wrap 100.0

  viewReady <- makeVar unit

  _ <- forkAff $ viewMachine cSys viewTimeout {viewRange, viewCmds} viewReady
  _ <- forkAff $ renderLoop cSys mainBrowser trackWidth bCanvas { viewCmds, viewRange, renderFiber } viewReady

  pure unit

-- TODO do this parsing better. good enough for now, but jesus.
--              do it applicative. semiring or at least semigroup
parseConfig :: Json -> Either String Conf
parseConfig j = do
  obj <- note "Provide a JSON object as configuration" $ j ^? _Object
  browserHeight <-
    note "`browserHeight` should be a Number" $ obj ^? ix "browserHeight" <<< _Number

  padding <- do
    p <- note "`padding` should be an object" $ obj ^? ix "padding" <<< _Object
    vertical <-
      note "`padding.vertical` should be a Number" $ p ^? ix "vertical" <<< _Number
    horizontal <-
      note "`padding.horizontal` should be a Number" $ p ^? ix "horizontal" <<< _Number
    pure {vertical, horizontal}

  score <- do
    s <- note "`score` should be an object" $ obj ^? ix "score" <<< _Object
    min <-
      note "`score.min` should be a Number" $ s ^? ix "min" <<< _Number
    max <-
      note "`score.max` should be a Number" $ s ^? ix "max" <<< _Number
    sig <-
      note "`score.sig` should be a Number" $ s ^? ix "sig" <<< _Number

    pure {min, max, sig}

  urls <- do
    u <- note "`urls` should be an object" $ obj ^? ix "urls" <<< _Object

    let gwas = u ^? ix "gwas" <<< _String
        annotations = u ^? ix "annotations" <<< _String
        genes = u ^? ix "genes" <<< _String

    pure {gwas, annotations, genes}

  pure {browserHeight, padding, score, urls}

initBrowser :: Json -> Eff _ _
initBrowser conf = do

  case parseConfig conf of
    Left err -> unsafeCrashWith err
    Right c  -> runBrowser c

module Genetics.Browser.Track.UI where

import Prelude

import Color (black)
import Control.Coroutine (Consumer, Process, runProcess, ($$))
import Control.Coroutine as Co
import Control.Monad.Aff (Aff, Fiber, Milliseconds, delay, finally, forkAff, killFiber, launchAff, launchAff_)
import Control.Monad.Aff.AVar (AVar, makeEmptyVar, makeVar, putVar, readVar, takeVar, tryTakeVar)
import Control.Monad.Eff (Eff, foreachE)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Exception (error)
import Control.Monad.Eff.Uncurried (EffFn4, runEffFn4)
import Control.Monad.Error.Class (throwError)
import Control.Monad.Rec.Class (forever)
import DOM.Classy.Node (toNode)
import DOM.Classy.ParentNode (toParentNode)
import DOM.HTML (window) as DOM
import DOM.HTML.Types (htmlDocumentToDocument) as DOM
import DOM.HTML.Window (document) as DOM
import DOM.Node.Element as DOM
import DOM.Node.Node (appendChild) as DOM
import DOM.Node.ParentNode (querySelector) as DOM
import DOM.Node.Types (Element, Node)
import Data.Argonaut (Json, _Number, _Object, _String)
import Data.Array as Array
import Data.Bifunctor (bimap)
import Data.BigInt (BigInt)
import Data.BigInt as BigInt
import Data.Either (Either(..), note)
import Data.Filterable (filter)
import Data.Foldable (class Foldable, foldMap, for_, null)
import Data.Lens (to, (^.), (^?))
import Data.Lens.Index (ix)
import Data.List (List)
import Data.List as List
import Data.Map (Map)
import Data.Maybe (Maybe(Just, Nothing), fromJust, fromMaybe)
import Data.Monoid (class Monoid, mempty)
import Data.Newtype (wrap)
import Data.Nullable (Nullable, toMaybe)
import Data.Pair (Pair(..))
import Data.Symbol (SProxy(..))
import Data.Traversable (traverse, traverse_)
import Data.Tuple (Tuple(Tuple))
import Genetics.Browser.Track.Backend (Padding, RenderedTrack, browser, bumpFeatures, zipMapsWith)
import Genetics.Browser.Track.Demo (BedFeature, GWASFeature, Annot, annotLegendTest, demoTracksBed, getAnnotations, getBedGenes, getGWAS, produceAnnots, produceGWAS, produceGenes)
import Genetics.Browser.Types (Bp(..), ChrId(ChrId), Point)
import Genetics.Browser.Types.Coordinates (CoordSys, _TotalSize, coordSys, pairSize, scalePairBy, translatePairBy)
import Graphics.Canvas (CanvasElement, Context2D, getContext2D)
import Graphics.Canvas as Canvas
import Graphics.Drawing (Drawing, fillColor, filled, rectangle, white)
import Graphics.Drawing as Drawing
import Partial.Unsafe (unsafeCrashWith, unsafePartial)
import Unsafe.Coerce (unsafeCoerce)

foreign import getScreenSize :: forall eff. Eff eff { width :: Number, height :: Number }

-- 1st element is a backbuffer, 2nd the one shown on screen
foreign import scrollCanvas :: forall eff.
                               CanvasElement
                            -> CanvasElement
                            -> Point
                            -> Eff eff Unit

foreign import canvasDragImpl :: forall eff.
                                 CanvasElement
                              -> ( { during :: Nullable Point
                                   , total :: Nullable Point } -> Eff eff Unit )
                              -> Eff eff Unit

canvasDrag :: (Either Point Point -> Eff _ Unit)
           -> CanvasElement
           -> Eff _ Unit
canvasDrag f el =
  let toEither g {during, total} = case toMaybe during of
        Just p  -> g $ Right p
        Nothing -> g $ Left $ fromMaybe {x:zero, y:zero} $ toMaybe total
  in canvasDragImpl el (toEither f)

-- creates a new CanvasElement, not attached to the DOM and thus not visible
foreign import newCanvas :: forall eff.
                            { width :: Number, height :: Number }
                         -> Eff eff CanvasElement

-- set an event to fire on the given button id

foreign import buttonEvent :: forall eff.
                              String
                           -> Eff eff Unit
                           -> Eff eff Unit

foreign import setViewUI :: forall eff. String -> Eff eff Unit

type ViewRange = Pair BigInt

data UpdateView =
    ScrollView Number
  | ZoomView Number
  | ModView (ViewRange -> ViewRange)

instance showUpdateView :: Show UpdateView where
  show (ScrollView x) = "(Scroll by " <> show x <> ")"
  show (ZoomView s) = "(Zoom by " <> show s <> ")"
  show _ = "(ModView)"

    -- TODO idk if this instance makes sense??? whatevs
instance semigroupUpdateView :: Semigroup UpdateView where
  append (ScrollView x1) (ScrollView x2) = ScrollView (x1 + x2)
  append (ZoomView s1)   (ZoomView s2)   = ZoomView   (s1 * s2)
  append _ y = y

instance monoidUpdateView :: Monoid UpdateView where
  mempty = ModView id

updateViewFold :: UpdateView
               -> ViewRange
               -> ViewRange
updateViewFold uv iv@(Pair l r) = case uv of
  ZoomView   x -> iv `scalePairBy`     x
  ScrollView x -> iv `translatePairBy` x
  ModView f    -> f iv

queueCmd :: AVar UpdateView -> UpdateView -> Eff _ Unit
queueCmd av cmd = launchAff_ $ putVar cmd av

btnScroll :: Number -> AVar UpdateView -> Eff _ Unit
btnScroll x av = do
  buttonEvent "scrollLeft"  $ queueCmd av $ ScrollView (-x)
  buttonEvent "scrollRight" $ queueCmd av $ ScrollView   x

btnZoom :: Number -> AVar UpdateView -> Eff _ Unit
btnZoom x av = do
  buttonEvent "zoomOut" $ queueCmd av $ ZoomView $ 1.0 + x
  buttonEvent "zoomIn"  $ queueCmd av $ ZoomView $ 1.0 - x

-- TODO handle normalization of view
-- TODO sync up graphical canvas-scrolling with actual browser viewstate
dragScroll :: Number
           -> BrowserCanvas
           -> AVar UpdateView
           -> Eff _ Unit
dragScroll width cnv av =
  let f = case _ of
        Left  {x,y} -> queueCmd av $ ScrollView $ g (-x)
        Right {x,y} -> scrollCanvas cnv.buffer cnv.track {x: -x, y: zero}
      g x = x / width
  in canvasDrag f cnv.overlay

foreign import canvasWheelCBImpl :: forall eff.
                                    CanvasElement
                                 -> (Number -> Eff eff Unit)
                                 -> Eff eff Unit

wheelZoom :: Number
           -> AVar UpdateView
           -> CanvasElement
           -> Eff _ Unit
wheelZoom scale av cv =
  canvasWheelCBImpl cv \dY ->
    queueCmd av $ ZoomView $ 1.0 + (scale * dY)

-- TODO differentiate scroll buffer & rendering buffer
type BrowserCanvas = { buffer  :: CanvasElement
                     , track   :: CanvasElement
                     , overlay :: CanvasElement
                     }

createBrowserCanvas :: Element
                    -> { width :: Number, height :: Number }
                    -> Canvas.TranslateTransform
                    -> Eff _ BrowserCanvas
createBrowserCanvas el dim trackTT = do
  let node :: CanvasElement -> Node
      node = unsafeCoerce
      element :: CanvasElement -> Element
      element = unsafeCoerce

  buffer  <- newCanvas dim
  track   <- newCanvas dim
  -- Translate the origin of the Track canvas;
  -- useful to place the origin within the vertical padding and horizontal UI elements
  void $ Canvas.getContext2D track >>= Canvas.translate trackTT

  overlay <- newCanvas dim

  DOM.setId (wrap "buffer")  (element buffer)
  DOM.setId (wrap "track")   (element track)
  DOM.setId (wrap "overlay") (element overlay)

  DOM.setAttribute "style" (   "width: "  <> show dim.width  <> "px"
                          <> "; height: " <> show dim.height <> "px"
                          <> "; position:relative"
                          <> "; border: 1px solid black; display: block; margin: 0; padding: 0"
                          ) el

  let css i = "position:absolute; z-index: " <> i

  DOM.setAttribute "style" (css "1") (element track)
  DOM.setAttribute "style" (css "2") (element overlay)

  _ <- DOM.appendChild (node track)   (toNode el)
  _ <- DOM.appendChild (node overlay) (toNode el)

  pure { buffer, track, overlay }

cSys :: CoordSys ChrId BigInt
cSys = coordSys mouseChrSizes

mouseChrSizes :: Array (Tuple ChrId BigInt)
mouseChrSizes =
  unsafePartial
  $ map (bimap ChrId (fromJust <<< BigInt.fromString))
      [ Tuple "1"   "195471971"
      , Tuple "2"   "182113224"
      , Tuple "3"   "160039680"
      , Tuple "4"   "156508116"
      , Tuple "5"   "151834684"
      , Tuple "6"   "149736546"
      , Tuple "7"   "145441459"
      , Tuple "8"   "129401213"
      , Tuple "9"   "124595110"
      , Tuple "10"  "130694993"
      , Tuple "11"  "122082543"
      , Tuple "12"  "120129022"
      , Tuple "13"  "120421639"
      , Tuple "14"  "124902244"
      , Tuple "15"  "104043685"
      , Tuple "16"  "98207768"
      , Tuple "17"  "94987271"
      , Tuple "18"  "90702639"
      , Tuple "19"  "61431566"
      , Tuple "X"   "17103129"
      , Tuple "Y"   "9174469"
      ]

type DataURLs = { gwas        :: Maybe String
                , annotations :: Maybe String
                , genes       :: Maybe String
                }

type Conf = { browserHeight :: Number
            , padding :: Padding
            , score :: { min :: Number, max :: Number, sig :: Number }
            , urls :: DataURLs
            }

foreign import timeFun :: forall eff a. (Unit -> a) -> Eff eff Unit

foreign import drawImageMany :: forall eff a.
                                EffFn4 eff
                                CanvasElement
                                Context2D
                                { width :: Number, height :: Number }
                                (Array Point)
                                Unit

renderBatch :: CanvasElement
            -> { drawing :: Drawing, points :: Array Point }
            -> Context2D
            -> Eff _ Unit
renderBatch buffer {drawing, points} ctx = do
  -- hardcoded glyph sizes for now.
  let r = 13.0
      d = r * 2.0
      dim = { width: 100.0, height: d }
                          -- width even more hardcoded to deal with long text!
  _ <- Canvas.setCanvasDimensions dim buffer
  bfrCtx <- Canvas.getContext2D buffer
  Drawing.render bfrCtx $ Drawing.translate r r drawing
  let img = Canvas.canvasElementToImageSource buffer
  runEffFn4 drawImageMany buffer ctx dim points

type BrowserState = { visible  :: ViewRange }
                    -- , rendered :: ViewRange }

viewMachine :: forall r.
               CoordSys _ _
            -> Milliseconds
            -> { viewRange :: AVar ViewRange
               , viewCmds :: AVar UpdateView | r }
            -> AVar Unit
            -> Aff _ Unit
viewMachine cs timeout { viewRange, viewCmds } ready = do

  curCmdVar <- makeVar mempty

  let limL = zero
      limR = cs ^. _TotalSize

      loop' updater = do
        cmd <- takeVar viewCmds

        killFiber (error "Resetting view update") updater

        curCmd <- takeVar curCmdVar
        let cmd' = curCmd <> cmd
        putVar cmd' curCmdVar

        updater' <- forkAff do
            delay timeout
            vr <- takeVar viewRange
                -- update view using received cmd, limiting view to provided boundaries
            let (Pair l' r') = updateViewFold cmd' vr
                -- arbitrary minimum of 400 units shown, so things don't go too crazy when zoomed in
                -- TODO bake into updateViewFold or handle at a better place/in a nicer way
                vr' = Pair (max limL l')
                           (min (max r' (l' + BigInt.fromInt 400))
                                limR)

            putVar vr' viewRange
            putVar unit ready
            takeVar curCmdVar *> putVar mempty curCmdVar

        loop' updater'

  loop' (pure unit)

renderLoop :: CoordSys _ _
           -> { tracks     :: Pair BigInt -> List (Array RenderedTrack)
              , relativeUI :: Pair BigInt -> Drawing
              , fixedUI :: Drawing }
           -> Number
           -> BrowserCanvas
           -> { viewRange   :: AVar ViewRange
              , viewCmds    :: AVar UpdateView
              , renderFiber :: AVar (Fiber _ Unit) }
           -> AVar Unit
           -> Aff _ Unit
renderLoop cSys browser trackDisplayWidth canvases state ready = forever do

  _ <- takeVar ready

  visible <- readVar state.viewRange
  -- if there's a rendering fiber running, we kill it
  traverse_ (killFiber (error "Resetting renderer"))
    =<< tryTakeVar state.renderFiber

  let scale = BigInt.toNumber (pairSize visible) / trackDisplayWidth
      (Pair l _ ) = visible
      offset = BigInt.toNumber l / scale
      tracks = browser.tracks visible

  -- fork a new renderFiber
  renderFiber <- forkAff $ renderGlyphs visible scale tracks canvases
  putVar renderFiber state.renderFiber

  liftEff $ do
    trackCtx   <- getContext2D canvases.track
    overlayCtx <- getContext2D canvases.overlay

    -- Shift canvas so we render to the visible part
    -- this shit ugly af tho, all of this gotta get redone~~
    void $ Canvas.withContext trackCtx do
      void $ Canvas.translate
        { translateX: (-offset), translateY: zero } trackCtx
      Drawing.render trackCtx $ browser.relativeUI visible

    Drawing.render overlayCtx browser.fixedUI

renderGlyphs :: Pair BigInt
             -> Number
             -> List (Array RenderedTrack)
             -> BrowserCanvas
             -> Aff _ Unit
renderGlyphs vw@(Pair l _) viewScale ts canvases = do

  -- Blank out the track canvas and get its context
  trackCtx <- liftEff do
    {width, height} <- Canvas.getCanvasDimensions canvases.track
    trackCtx <- getContext2D canvases.track
    Drawing.render trackCtx
      $ filled (fillColor white) $ rectangle 0.0 0.0 width height
    pure trackCtx

  let offset = BigInt.toNumber l / viewScale
      vw'@(Pair pxL pxR) = map (\x -> (BigInt.toNumber x / viewScale)) vw

  -- Predicates to filter out glyphs that would not be visible on screen
     -- Hack to render more of the canvas just to be sure
      pxL' = pxL - (pxR - pxL)
      pxR' = pxR + (pxR - pxL)
      predB p = p.x - 10.0 > pxL'
             && p.x + 10.0 < pxR'
      predS s = s.width >= one
             && s.point.x - s.width > pxL'
             && s.point.x + s.width < pxR'

      shiftView x =
        void $ liftEff $ Canvas.translate { translateX: x, translateY: zero } trackCtx

  -- Shift canvas so we render to the visible part
  shiftView (-offset)

  -- Make sure we unshift even if renderer is killed
  finally (shiftView offset) do

    for_ ts \track -> do
      for_ track \t -> do
        case t of
          Left {drawing, points}  -> do
            let points' = filter predB points
            liftEff $
              renderBatch canvases.buffer {drawing, points: points'} trackCtx

          Right gs -> do
            let gs' = filter predS gs
            liftEff $ foreachE gs' \s ->
              Drawing.render trackCtx
                $ Drawing.translate s.point.x s.point.y
                $ s.drawing

        -- delay to give the UI thread a moment
        delay (wrap 3.0)

-- TODO this could almost certainly be done better
chunkConsumer :: forall m a.
                 Foldable m
              => Monoid (m a)
              => AVar (m a)
              -> Consumer (m a) (Aff _) Unit
chunkConsumer av = Co.consumer \m ->
  if null m
     then pure $ Just unit
     else do
       sofar <- takeVar av

       let new = sofar <> m

       putVar new av
       delay (wrap 20.0)

       pure Nothing

type TrackVar a = AVar (Map ChrId (Array a))

-- | Starts threads that fetch & parse each of the provided tracks,
-- | filling an AVar over time per track, which can be used by other parts of the application
-- | (read only, should be a newtype)
fetchLoop :: CoordSys ChrId BigInt
          -> DataURLs
          -> Aff _
               { gwas :: TrackVar (GWASFeature ())
               , genes :: TrackVar BedFeature
               , annotations :: TrackVar (Annot ())
               }
fetchLoop cs urls = do
  gwasProd   <- traverse (produceGWAS cs) urls.gwas
  annotsProd <- traverse (produceAnnots cs) urls.annotations
  genesProd  <- traverse (produceGenes cs) urls.genes

  gwas        <- makeVar mempty
  annotations <- makeVar mempty
  genes       <- makeVar mempty

  let gwasProc :: Maybe (Process (Aff _) Unit)
      gwasProc   = (_ $$ chunkConsumer gwas)   <$> gwasProd
      annotsProc = (_ $$ chunkConsumer annotations) <$> annotsProd
      genesProc  = (_ $$ chunkConsumer genes)  <$> genesProd

  _ <- traverse forkAff (runProcess <$> gwasProc)
  _ <- traverse forkAff (runProcess <$> annotsProc)
  _ <- traverse forkAff (runProcess <$> genesProc)

  pure { gwas, annotations, genes }

runBrowser :: Conf -> Eff _ _
runBrowser config = launchAff $ do

  {width} <- liftEff $ getScreenSize

  let height = config.browserHeight
      browserDimensions = {width, height}
      vScaleWidth = 60.0
      legendWidth = 120.0
      trackWidth = width - (vScaleWidth + legendWidth)

  bCanvas <- do
    doc <- liftEff $ DOM.htmlDocumentToDocument
           <$> (DOM.document =<< DOM.window)
    cont <- liftEff $ DOM.querySelector (wrap "#browser") (toParentNode doc)

    case cont of
      Nothing -> throwError $ error "Could not find browser element"
      Just el -> liftEff do
        createBrowserCanvas
          el browserDimensions
          { translateX: vScaleWidth
          , translateY: zero }

  trackData <- do
    genes <- traverse (getBedGenes cSys) config.urls.genes
    gwas  <- traverse (getGWAS  cSys) config.urls.gwas
    rawAnnotations <-
      traverse (getAnnotations cSys) config.urls.annotations

    let annotations = zipMapsWith
                       (bumpFeatures (to _.score) (SProxy :: SProxy "score")
                         (Bp 1000000.0))
                       <$> gwas <*> rawAnnotations

    pure { genes, gwas, annotations }

  let initialView :: Pair BigInt
      initialView = Pair zero (cSys^._TotalSize)

  viewCmds <- makeEmptyVar
  liftEff $ do
    btnScroll 0.05 viewCmds
    btnZoom   0.10 viewCmds
    dragScroll trackWidth bCanvas viewCmds
    wheelZoom 0.02 viewCmds bCanvas.overlay

  viewRange <- makeVar initialView

  renderFiber <- makeEmptyVar

  let
      entries = foldMap annotLegendTest trackData.annotations
      legend = { width: legendWidth, entries }
      s = config.score
      vscale = { width: vScaleWidth, color: black
               , min: s.min, max: s.max, sig: s.sig }
      tracks = demoTracksBed vscale trackData
      mainBrowser = browser cSys browserDimensions config.padding {legend, vscale} tracks
      viewTimeout = wrap 100.0

  viewReady <- makeVar unit

  _ <- forkAff $ viewMachine cSys viewTimeout {viewRange, viewCmds} viewReady
  _ <- forkAff $ renderLoop cSys mainBrowser trackWidth bCanvas { viewCmds, viewRange, renderFiber } viewReady

  pure unit

-- TODO do this parsing better. good enough for now, but jesus.
--              do it applicative. semiring or at least semigroup
parseConfig :: Json -> Either String Conf
parseConfig j = do
  obj <- note "Provide a JSON object as configuration" $ j ^? _Object
  browserHeight <-
    note "`browserHeight` should be a Number" $ obj ^? ix "browserHeight" <<< _Number

  padding <- do
    p <- note "`padding` should be an object" $ obj ^? ix "padding" <<< _Object
    vertical <-
      note "`padding.vertical` should be a Number" $ p ^? ix "vertical" <<< _Number
    horizontal <-
      note "`padding.horizontal` should be a Number" $ p ^? ix "horizontal" <<< _Number
    pure {vertical, horizontal}

  score <- do
    s <- note "`score` should be an object" $ obj ^? ix "score" <<< _Object
    min <-
      note "`score.min` should be a Number" $ s ^? ix "min" <<< _Number
    max <-
      note "`score.max` should be a Number" $ s ^? ix "max" <<< _Number
    sig <-
      note "`score.sig` should be a Number" $ s ^? ix "sig" <<< _Number

    pure {min, max, sig}

  urls <- do
    u <- note "`urls` should be an object" $ obj ^? ix "urls" <<< _Object

    let gwas = u ^? ix "gwas" <<< _String
        annotations = u ^? ix "annotations" <<< _String
        genes = u ^? ix "genes" <<< _String

    pure {gwas, annotations, genes}

  pure {browserHeight, padding, score, urls}

initBrowser :: Json -> Eff _ _
initBrowser conf = do

  case parseConfig conf of
    Left err -> unsafeCrashWith err
    Right c  -> runBrowser c


at LEAST make this selector an actual button

module Test.SlamData.Feature.XPaths where

import SlamData.Prelude
import XPath as XPath
import Test.SlamData.Feature.Data as Data

aceEditor ∷ String
aceEditor = "*[contains(@class, 'ace_editor') and not(contains(@class, 'ace_autocomplete'))]"

playButton ∷ String
playButton = XPath.anyWithExactAriaLabel "Play"

renameButton ∷ String
renameButton = "button" `XPath.nodeWithExactText` "Rename"

renameDeck ∷ String
renameDeck = XPath.anyWithExactAriaLabel "Rename deck"

refreshButton ∷ String
refreshButton = XPath.anyWithExactAriaLabel "Refresh"

uploadFile ∷ String
uploadFile =
  "input" `XPath.withLabel` XPath.anyWithExactAriaLabel "Upload file"

selectADestinationFolder ∷ String
selectADestinationFolder = XPath.anyWithExactAriaLabel "Select a destination folder"

fileFromInitialFileList ∷ String
fileFromInitialFileList =
  XPath.anyWithExactText Data.fileFromInitialFileList

initialFileList ∷ Array String
initialFileList =
  map XPath.anyWithExactText Data.initialFileList

initialFileListInOrder ∷ String
initialFileListInOrder =
  XPath.inOrder $ map XPath.anyWithExactText Data.initialFileList

eChart ∷ String → String
eChart string =
  ("pre" `XPath.nodeWithExactText` string)

displayMarkdownCardHeader ∷ String
displayMarkdownCardHeader =
  XPath.anyWithExactAriaLabel "Show Markdown card"

troubleshootCardHeader ∷ String
troubleshootCardHeader =
  XPath.anyWithExactAriaLabel "Troubleshoot card"

tableCardHeader ∷ String
tableCardHeader =
  XPath.anyWithExactAriaLabel "Show Table card"

fileSearchInput ∷ String
fileSearchInput =
  XPath.anyWithExactAriaLabel "File search field"

searchStringInput ∷ String
searchStringInput =
  XPath.inputWithExactPlaceholder "Search string"

saveDestinationInput ∷ String
saveDestinationInput =
  XPath.anyWithExactAriaLabel "Cache file destination"

saveSubmitButton ∷ String
saveSubmitButton =
  XPath.anyWithExactAriaLabel "Confirm file destination"

insertCacheCard ∷ String
insertCacheCard =
  XPath.anyWithExactAriaLabel "Insert a Cache card"

insertMdCard ∷ String
insertMdCard =
  XPath.anyWithExactAriaLabel "Insert a Setup Markdown card"

insertSearchCard ∷ String
insertSearchCard =
  XPath.anyWithExactAriaLabel "Insert a Search card"

insertChartOptionsCard ∷ String
insertChartOptionsCard =
  XPath.anyWithExactAriaLabel "Insert a Setup Chart card"

insertDownloadOptionsCard ∷ String
insertDownloadOptionsCard =
  XPath.anyWithExactAriaLabel "Insert a Setup Download card"

insertTroubleshootCard ∷ String
insertTroubleshootCard =
  XPath.anyWithExactAriaLabel "Insert a Troubleshoot card"

insertChartCard ∷ String
insertChartCard =
  XPath.anyWithExactAriaLabel "Insert a Show Chart card"

insertDisplayMarkdownCard ∷ String
insertDisplayMarkdownCard =
  XPath.anyWithExactAriaLabel "Insert a Show Markdown card"

selectBuildChart ∷ String
selectBuildChart =
  XPath.anyWithExactAriaLabel "Select Setup Chart card category"

insertPivotCard ∷ String
insertPivotCard =
  XPath.anyWithExactAriaLabel "Insert a Pivot Table card"

insertBuildBarChartCard ∷ String
insertBuildBarChartCard =
  XPath.anyWithExactAriaLabel "Insert a Bar card"

showFileList ∷ String
showFileList =
  XPath.anyWithExactAriaLabel "Show file list"

hideFileList ∷ String
hideFileList =
  XPath.anyWithExactAriaLabel "Hide file list"

deleteCard ∷ String
deleteCard =
  XPath.anyWithExactAriaLabel "Delete card"

dismissInsertCardMenu ∷ String
dismissInsertCardMenu =
  XPath.anyWithExactAriaLabel "Dismiss insert card menu"

insertCard ∷ String
insertCard =
  XPath.anyWithExactAriaLabel "Insert card"

insertQueryCard ∷ String
insertQueryCard =
  XPath.anyWithExactAriaLabel "Insert a Query card"

insertOpenCard ∷ String
insertOpenCard = XPath.anyWithExactAriaLabel "Insert a Open card"

insertVariablesCard ∷ String
insertVariablesCard =
  XPath.anyWithExactAriaLabel "Insert a Setup Variables card"

insertTableCard ∷ String
insertTableCard =
  XPath.anyWithExactAriaLabel "Insert a Show Table card"

hideCardOptions ∷ String
hideCardOptions =
  XPath.anyWithExactAriaLabel "Hide card options"

showCardOptions ∷ String
showCardOptions =
  XPath.anyWithExactAriaLabel "Show card options"

browseRootFolder ∷ String
browseRootFolder = XPath.anyWithAriaLabel "Browse root folder"

createWorkspace ∷ String
createWorkspace =
  XPath.anyWithExactAriaLabel "Create workspace"

createFolder ∷ String
createFolder =
  XPath.anyWithExactAriaLabel "Create folder"

removeFile ∷ String → String
removeFile name =
  XPath.anyWithExactText name `XPath.following` XPath.anyWithExactAriaLabel "Remove"

editWorkspace ∷ String → String
editWorkspace name =
  XPath.anyWithExactText name `XPath.following` XPath.anyWithExactAriaLabel "Edit"

shareFile ∷ String → String
shareFile name =
  XPath.anyWithExactText name `XPath.following` XPath.anyWithExactAriaLabel "Share"

downloadFile ∷ String → String
downloadFile name =
  XPath.anyWithExactText name `XPath.following` XPath.anyWithExactAriaLabel "Download"

moveFile ∷ String → String
moveFile name =
  XPath.anyWithExactText name `XPath.following` XPath.anyWithExactAriaLabel "Move / rename"

oneErrorMessage ∷ String
oneErrorMessage =
  XPath.anyWithText "1 error during evaluation."

noFileSelectedMessage ∷ String
noFileSelectedMessage =
  XPath.anyWithExactText "No file selected"

fileDoesNotExist ∷ String → String
fileDoesNotExist filename =
  XPath.anyWithExactText $ "File " <> filename <> " does not exist"

selectFileField ∷ String
selectFileField = XPath.inputWithPlaceholder "Select a file"

finishedMessage ∷ String
finishedMessage = XPath.anyWithText "Finished"

mdField ∷ String
mdField = aceEditor

accessMountDatabase ∷ String
accessMountDatabase = XPath.anyWithExactAriaLabel "Mount database"

accessConfigureMount ∷ String
accessConfigureMount = XPath.anyWithExactAriaLabel "Configure mount"

mountName ∷ String
mountName = "input" `XPath.withLabelWithExactText` "Name"

mountType ∷ String
mountType = "select" `XPath.withLabelWithExactText` "Mount type"

mountPort ∷ String
mountPort = "input" `XPath.withLabelWithExactText` "Port"

mountHost ∷ String
mountHost = "input" `XPath.withLabelWithExactText` "Host"

mountDatabase ∷ String
mountDatabase = "input" `XPath.withLabelWithExactText` "Database"

mountButton ∷ String
mountButton = "button" `XPath.nodeWithExactText` "Mount"

downloadButton ∷ String
downloadButton = "button" `XPath.nodeWithExactText` "Download"

cancelButton ∷ String
cancelButton = "button" `XPath.nodeWithExactText` "Cancel"

inputWithLabelAndType ∷ String → String → String
inputWithLabelAndType labelText inputType =
  "input"
    `XPath.withLabelWithExactText` labelText
    `XPath.nodeWithExactAttribute "type"` inputType

nthFile ∷ String
nthFile = "*" `XPath.nodeWithAriaLabel` "Select "

selectFile ∷ String → String
selectFile filename = "*" `XPath.nodeWithExactAriaLabel` ("Select " <> filename)

deselectFile ∷ String → String
deselectFile filename = "*" `XPath.nodeWithExactAriaLabel` ("Deselect " <> filename)

accessFile ∷ String → String
accessFile filename =
  XPath.anyWithExactText filename
    `XPath.withPredicate` ("preceding::" <> XPath.anyWithAriaLabel "Sort files by name")

accessBreadcrumb ∷ String → String
accessBreadcrumb name =
  XPath.anyWithExactText name
    `XPath.withPredicate` ("following::" <> XPath.anyWithAriaLabel "Sort files by name")

cardHeading ∷ String
cardHeading =
  XPath.withPredicate "*"
    $ XPath.anyOfThesePredicates
    $ XPath.ariaLabel
    <$> [ "Query card"
        , "Setup Markdown card"
        , "Open card"
        , "Search card"
        , "Setup Variables card"
        , "Setup Chart card"
        , "Setup Download card"
        ]

tableHeading ∷ String
tableHeading =
  XPath.withPredicate "*"
    $ XPath.ariaLabel "Table card"

sharingUrl ∷ String
sharingUrl = "*" `XPath.nodeWithExactAriaLabel` "Sharing URL"

publishingUrl ∷ String
publishingUrl = "*" `XPath.nodeWithExactAriaLabel` "Published deck URL"

copySharingUrl ∷ String
copySharingUrl = "*" `XPath.nodeWithExactText` "Copy"

showHiddenFiles ∷ String
showHiddenFiles = "*" `XPath.nodeWithExactAriaLabel` "Show hidden files"

hideHiddenFiles ∷ String
hideHiddenFiles = "*" `XPath.nodeWithExactAriaLabel` "Hide hidden files"

variablesCardVariableName ∷ String
variablesCardVariableName =
  XPath.anyWithExactAriaLabel "Variable name"

variablesCardVariableTypeFor ∷ String → String
variablesCardVariableTypeFor name =
  XPath.anyWithExactAriaLabel
    $ "Type of \"" <> name <> "\" variable"

variablesCardDefaultValueFor ∷ String → String
variablesCardDefaultValueFor name =
  XPath.anyWithExactAriaLabel
    $ "Default value for \"" <> name <> "\" variable"

chartCategorySelector ∷ String
chartCategorySelector = XPath.anyWithExactText "Choose category"

chartMeasureSelector ∷ String
chartMeasureSelector = XPath.anyWithExactText "Choose measure"

chartStackSelector ∷ String
chartStackSelector = XPath.anyWithExactText "Choose stack"

chartSwitchToBar ∷ String
chartSwitchToBar = XPath.anyWithExactSrc "img/bar.svg"

chartContainer ∷ String
chartContainer = "div[@_echarts_instance_]"

trashCardAction ∷ String
trashCardAction =
  XPath.anyWithExactAriaLabel "Delete card"

publishDeckAction ∷ String
publishDeckAction =
  XPath.anyWithExactAriaLabel "Publish deck"

embedDeckAction ∷ String
embedDeckAction =
  XPath.anyWithExactAriaLabel "Embed deck"

shareDeckAction ∷ String
shareDeckAction =
  XPath.anyWithExactAriaLabel "Share deck"

resourceOpened ∷ String → String
resourceOpened fn =
  XPath.anyWithExactAriaLabel $ "Selected resource: " ⊕ fn

headerGripper ∷ String
headerGripper =
  XPath.anyWithExactAriaLabel "Show header"

previousCardGripper :: String
previousCardGripper =
  XPath.any
    `XPath.withPredicate` XPath.ariaLabel "Access previous card"

nextCardGripper :: String
nextCardGripper =
  XPath.any
    `XPath.withPredicate` XPath.ariaLabel "Access next card"

enabledPreviousCardGripper :: String
enabledPreviousCardGripper =
  previousCardGripper
    <> "[ancestor-or-self::*[not(@aria-disabled = 'true')]]"

enabledNextCardGripper :: String
enabledNextCardGripper =
  nextCardGripper
    <> "[ancestor-or-self::*[not(@aria-disabled = 'true')]]"

deck :: String
deck =
  XPath.anyWithExactAriaLabel $ "Deck"

followingLastPreviousCardGripper :: String -> String
followingLastPreviousCardGripper = XPath.following lastPreviousCardGripperXPath
  where
  lastPreviousCardGripperXPath = XPath.last $ XPath.anywhere previousCardGripper

module Test.SlamData.Feature.XPaths where

import SlamData.Prelude
import XPath as XPath
import Test.SlamData.Feature.Data as Data

aceEditor ∷ String
aceEditor = "*[contains(@class, 'ace_editor') and not(contains(@class, 'ace_autocomplete'))]"

playButton ∷ String
playButton = XPath.anyWithExactAriaLabel "Play"

renameButton ∷ String
renameButton = XPath.anyWithExactText "Rename"

renameDeck ∷ String
renameDeck = XPath.anyWithExactAriaLabel "Rename deck"

refreshButton ∷ String
refreshButton = XPath.anyWithExactAriaLabel "Refresh"

uploadFile ∷ String
uploadFile =
  "input" `XPath.withLabel` XPath.anyWithExactAriaLabel "Upload file"

selectADestinationFolder ∷ String
selectADestinationFolder = XPath.anyWithExactAriaLabel "Select a destination folder"

fileFromInitialFileList ∷ String
fileFromInitialFileList =
  XPath.anyWithExactText Data.fileFromInitialFileList

initialFileList ∷ Array String
initialFileList =
  map XPath.anyWithExactText Data.initialFileList

initialFileListInOrder ∷ String
initialFileListInOrder =
  XPath.inOrder $ map XPath.anyWithExactText Data.initialFileList

eChart ∷ String → String
eChart string =
  ("pre" `XPath.nodeWithExactText` string)

displayMarkdownCardHeader ∷ String
displayMarkdownCardHeader =
  XPath.anyWithExactAriaLabel "Show Markdown card"

troubleshootCardHeader ∷ String
troubleshootCardHeader =
  XPath.anyWithExactAriaLabel "Troubleshoot card"

tableCardHeader ∷ String
tableCardHeader =
  XPath.anyWithExactAriaLabel "Show Table card"

fileSearchInput ∷ String
fileSearchInput =
  XPath.anyWithExactAriaLabel "File search field"

searchStringInput ∷ String
searchStringInput =
  XPath.inputWithExactPlaceholder "Search string"

saveDestinationInput ∷ String
saveDestinationInput =
  XPath.anyWithExactAriaLabel "Cache file destination"

saveSubmitButton ∷ String
saveSubmitButton =
  XPath.anyWithExactAriaLabel "Confirm file destination"

insertCacheCard ∷ String
insertCacheCard =
  XPath.anyWithExactAriaLabel "Insert a Cache card"

insertMdCard ∷ String
insertMdCard =
  XPath.anyWithExactAriaLabel "Insert a Setup Markdown card"

insertSearchCard ∷ String
insertSearchCard =
  XPath.anyWithExactAriaLabel "Insert a Search card"

insertChartOptionsCard ∷ String
insertChartOptionsCard =
  XPath.anyWithExactAriaLabel "Insert a Setup Chart card"

insertDownloadOptionsCard ∷ String
insertDownloadOptionsCard =
  XPath.anyWithExactAriaLabel "Insert a Setup Download card"

insertTroubleshootCard ∷ String
insertTroubleshootCard =
  XPath.anyWithExactAriaLabel "Insert a Troubleshoot card"

insertChartCard ∷ String
insertChartCard =
  XPath.anyWithExactAriaLabel "Insert a Show Chart card"

insertDisplayMarkdownCard ∷ String
insertDisplayMarkdownCard =
  XPath.anyWithExactAriaLabel "Insert a Show Markdown card"

selectBuildChart ∷ String
selectBuildChart =
  XPath.anyWithExactAriaLabel "Select Setup Chart card category"

insertPivotCard ∷ String
insertPivotCard =
  XPath.anyWithExactAriaLabel "Insert a Pivot Table card"

insertBuildBarChartCard ∷ String
insertBuildBarChartCard =
  XPath.anyWithExactAriaLabel "Insert a Bar card"

showFileList ∷ String
showFileList =
  XPath.anyWithExactAriaLabel "Show file list"

hideFileList ∷ String
hideFileList =
  XPath.anyWithExactAriaLabel "Hide file list"

deleteCard ∷ String
deleteCard =
  XPath.anyWithExactAriaLabel "Delete card"

dismissInsertCardMenu ∷ String
dismissInsertCardMenu =
  XPath.anyWithExactAriaLabel "Dismiss insert card menu"

insertCard ∷ String
insertCard =
  XPath.anyWithExactAriaLabel "Insert card"

insertQueryCard ∷ String
insertQueryCard =
  XPath.anyWithExactAriaLabel "Insert a Query card"

insertOpenCard ∷ String
insertOpenCard = XPath.anyWithExactAriaLabel "Insert a Open card"

insertVariablesCard ∷ String
insertVariablesCard =
  XPath.anyWithExactAriaLabel "Insert a Setup Variables card"

insertTableCard ∷ String
insertTableCard =
  XPath.anyWithExactAriaLabel "Insert a Show Table card"

hideCardOptions ∷ String
hideCardOptions =
  XPath.anyWithExactAriaLabel "Hide card options"

showCardOptions ∷ String
showCardOptions =
  XPath.anyWithExactAriaLabel "Show card options"

browseRootFolder ∷ String
browseRootFolder = XPath.anyWithAriaLabel "Browse root folder"

createWorkspace ∷ String
createWorkspace =
  XPath.anyWithExactAriaLabel "Create workspace"

createFolder ∷ String
createFolder =
  XPath.anyWithExactAriaLabel "Create folder"

removeFile ∷ String → String
removeFile name =
  XPath.anyWithExactText name `XPath.following` XPath.anyWithExactAriaLabel "Remove"

editWorkspace ∷ String → String
editWorkspace name =
  XPath.anyWithExactText name `XPath.following` XPath.anyWithExactAriaLabel "Edit"

shareFile ∷ String → String
shareFile name =
  XPath.anyWithExactText name `XPath.following` XPath.anyWithExactAriaLabel "Share"

downloadFile ∷ String → String
downloadFile name =
  XPath.anyWithExactText name `XPath.following` XPath.anyWithExactAriaLabel "Download"

moveFile ∷ String → String
moveFile name =
  XPath.anyWithExactText name `XPath.following` XPath.anyWithExactAriaLabel "Move / rename"

oneErrorMessage ∷ String
oneErrorMessage =
  XPath.anyWithText "1 error during evaluation."

noFileSelectedMessage ∷ String
noFileSelectedMessage =
  XPath.anyWithExactText "No file selected"

fileDoesNotExist ∷ String → String
fileDoesNotExist filename =
  XPath.anyWithExactText $ "File " <> filename <> " does not exist"

selectFileField ∷ String
selectFileField = XPath.inputWithPlaceholder "Select a file"

finishedMessage ∷ String
finishedMessage = XPath.anyWithText "Finished"

mdField ∷ String
mdField = aceEditor

accessMountDatabase ∷ String
accessMountDatabase = XPath.anyWithExactAriaLabel "Mount database"

accessConfigureMount ∷ String
accessConfigureMount = XPath.anyWithExactAriaLabel "Configure mount"

mountName ∷ String
mountName = "input" `XPath.withLabelWithExactText` "Name"

mountType ∷ String
mountType = "select" `XPath.withLabelWithExactText` "Mount type"

mountPort ∷ String
mountPort = "input" `XPath.withLabelWithExactText` "Port"

mountHost ∷ String
mountHost = "input" `XPath.withLabelWithExactText` "Host"

mountDatabase ∷ String
mountDatabase = "input" `XPath.withLabelWithExactText` "Database"

mountButton ∷ String
mountButton = "button" `XPath.nodeWithExactText` "Mount"

downloadButton ∷ String
downloadButton = "button" `XPath.nodeWithExactText` "Download"

cancelButton ∷ String
cancelButton = "button" `XPath.nodeWithExactText` "Cancel"

inputWithLabelAndType ∷ String → String → String
inputWithLabelAndType labelText inputType =
  "input"
    `XPath.withLabelWithExactText` labelText
    `XPath.nodeWithExactAttribute "type"` inputType

nthFile ∷ String
nthFile = "*" `XPath.nodeWithAriaLabel` "Select "

selectFile ∷ String → String
selectFile filename = "*" `XPath.nodeWithExactAriaLabel` ("Select " <> filename)

deselectFile ∷ String → String
deselectFile filename = "*" `XPath.nodeWithExactAriaLabel` ("Deselect " <> filename)

accessFile ∷ String → String
accessFile filename =
  XPath.anyWithExactText filename
    `XPath.withPredicate` ("preceding::" <> XPath.anyWithAriaLabel "Sort files by name")

accessBreadcrumb ∷ String → String
accessBreadcrumb name =
  XPath.anyWithExactText name
    `XPath.withPredicate` ("following::" <> XPath.anyWithAriaLabel "Sort files by name")

cardHeading ∷ String
cardHeading =
  XPath.withPredicate "*"
    $ XPath.anyOfThesePredicates
    $ XPath.ariaLabel
    <$> [ "Query card"
        , "Setup Markdown card"
        , "Open card"
        , "Search card"
        , "Setup Variables card"
        , "Setup Chart card"
        , "Setup Download card"
        ]

tableHeading ∷ String
tableHeading =
  XPath.withPredicate "*"
    $ XPath.ariaLabel "Table card"

sharingUrl ∷ String
sharingUrl = "*" `XPath.nodeWithExactAriaLabel` "Sharing URL"

publishingUrl ∷ String
publishingUrl = "*" `XPath.nodeWithExactAriaLabel` "Published deck URL"

copySharingUrl ∷ String
copySharingUrl = "*" `XPath.nodeWithExactText` "Copy"

showHiddenFiles ∷ String
showHiddenFiles = "*" `XPath.nodeWithExactAriaLabel` "Show hidden files"

hideHiddenFiles ∷ String
hideHiddenFiles = "*" `XPath.nodeWithExactAriaLabel` "Hide hidden files"

variablesCardVariableName ∷ String
variablesCardVariableName =
  XPath.anyWithExactAriaLabel "Variable name"

variablesCardVariableTypeFor ∷ String → String
variablesCardVariableTypeFor name =
  XPath.anyWithExactAriaLabel
    $ "Type of \"" <> name <> "\" variable"

variablesCardDefaultValueFor ∷ String → String
variablesCardDefaultValueFor name =
  XPath.anyWithExactAriaLabel
    $ "Default value for \"" <> name <> "\" variable"

chartCategorySelector ∷ String
chartCategorySelector = XPath.anyWithExactText "Choose category"

chartMeasureSelector ∷ String
chartMeasureSelector = XPath.anyWithExactText "Choose measure"

chartStackSelector ∷ String
chartStackSelector = XPath.anyWithExactText "Choose stack"

chartSwitchToBar ∷ String
chartSwitchToBar = XPath.anyWithExactSrc "img/bar.svg"

chartContainer ∷ String
chartContainer = "div[@_echarts_instance_]"

trashCardAction ∷ String
trashCardAction =
  XPath.anyWithExactAriaLabel "Delete card"

publishDeckAction ∷ String
publishDeckAction =
  XPath.anyWithExactAriaLabel "Publish deck"

embedDeckAction ∷ String
embedDeckAction =
  XPath.anyWithExactAriaLabel "Embed deck"

shareDeckAction ∷ String
shareDeckAction =
  XPath.anyWithExactAriaLabel "Share deck"

resourceOpened ∷ String → String
resourceOpened fn =
  XPath.anyWithExactAriaLabel $ "Selected resource: " ⊕ fn

headerGripper ∷ String
headerGripper =
  XPath.anyWithExactAriaLabel "Show header"

previousCardGripper :: String
previousCardGripper =
  XPath.any
    `XPath.withPredicate` XPath.ariaLabel "Access previous card"

nextCardGripper :: String
nextCardGripper =
  XPath.any
    `XPath.withPredicate` XPath.ariaLabel "Access next card"

enabledPreviousCardGripper :: String
enabledPreviousCardGripper =
  previousCardGripper
    <> "[ancestor-or-self::*[not(@aria-disabled = 'true')]]"

enabledNextCardGripper :: String
enabledNextCardGripper =
  nextCardGripper
    <> "[ancestor-or-self::*[not(@aria-disabled = 'true')]]"

deck :: String
deck =
  XPath.anyWithExactAriaLabel $ "Deck"

followingLastPreviousCardGripper :: String -> String
followingLastPreviousCardGripper = XPath.following lastPreviousCardGripperXPath
  where
  lastPreviousCardGripperXPath = XPath.last $ XPath.anywhere previousCardGripper


Only reset player direction when respawning

fixes #16

module Game where

import Data.Tuple
import Data.Maybe
import Data.Maybe.Unsafe (fromJust)
import Data.Array ((!!), range, filter, length, take)
import qualified Data.Map as M
import Data.Foldable
import Control.Arrow
import Control.Alt
import Control.Monad
import Control.Monad.Reader.Class
import Control.Lens (LensP(), TraversalP(), lens, at, _Just, _1, _2,
                     (.~), (..), (^.), (%~), (~))
import Math (ceil, floor, pi)

import Types
import LevelMap
import Utils

minPlayers = 2
rampageLength = 180
cooldownLength = 120
respawnLength = 60

-- minimum squared distance that a player needs to be from another player in
-- order to eat them, in blocks.
minEatingQuadrance = 4

-- update signalling

player :: PlayerId -> TraversalP Game Player
player pId = players .. at pId .. _Just

item :: ItemId -> TraversalP Game Item
item iId = items .. at iId .. _Just

applyGameUpdate :: GameUpdate -> Game -> Game
applyGameUpdate u =
  case u of
    GUPU pId PlayerLeft ->
      removePlayer pId
    GUPU pId x ->
      player pId %~ applyPlayerUpdate x
    GUIU iId x ->
      items .. at iId %~ applyItemUpdate x
    ChangedCountdown x ->
      setCountdown x
    GameEnded _ ->
      id
    ChangedRampage r ->
      \g -> g { rampage = r }
  where
  setCountdown x game = game {countdown = x}

applyGameUpdates :: [GameUpdate] -> Game -> Game
applyGameUpdates updates game = foldr applyGameUpdate game updates

removePlayer :: PlayerId -> Game -> Game
removePlayer pId = players .. at pId .~ Nothing

applyPlayerUpdate :: PlayerUpdate -> Player -> Player
applyPlayerUpdate u =
  case u of
    (ChangedPosition p)          -> pPosition .~ p
    (ChangedDirection d)         -> pDirection .~ d
    (ChangedIntendedDirection d) -> pIntendedDirection .~ d
    (ChangedScore s)             -> pScore .~ s
    (ChangedNomIndex a)          -> pNomIndex .~ a
    (ChangedRespawnCounter x)    -> pRespawnCounter .~ x

applyItemUpdate :: ItemUpdate -> Maybe Item -> Maybe Item
applyItemUpdate u =
  case u of
    Eaten -> const Nothing

applyGameUpdateM :: GameUpdate -> GameUpdateM Unit
applyGameUpdateM update = do
  tellGameUpdate update
  modifyGame (applyGameUpdate update)

changePosition :: PlayerId -> Position -> GameUpdateM Unit
changePosition pId p =
  applyGameUpdateM (GUPU pId (ChangedPosition p))

changeDirection :: PlayerId -> Maybe Direction -> GameUpdateM Unit
changeDirection pId d =
  applyGameUpdateM (GUPU pId (ChangedDirection d))

changeIntendedDirection :: PlayerId -> Maybe Direction -> GameUpdateM Unit
changeIntendedDirection pId d =
  applyGameUpdateM (GUPU pId (ChangedIntendedDirection d))

changeScore :: PlayerId -> Number -> GameUpdateM Unit
changeScore pId s =
  applyGameUpdateM (GUPU pId (ChangedScore s))

changeCountdown :: Maybe Number -> GameUpdateM Unit
changeCountdown =
  applyGameUpdateM <<< ChangedCountdown

changeNomIndex :: PlayerId -> Number -> GameUpdateM Unit
changeNomIndex pId i =
  applyGameUpdateM (GUPU pId (ChangedNomIndex i))

eat :: ItemId -> GameUpdateM Unit
eat iId =
  applyGameUpdateM (GUIU iId Eaten)

changeRespawnCounter :: PlayerId -> Maybe Number -> GameUpdateM Unit
changeRespawnCounter pId x =
  applyGameUpdateM (GUPU pId (ChangedRespawnCounter x))

endGame :: GameEndReason -> GameUpdateM Unit
endGame =
  applyGameUpdateM <<< GameEnded

changeRampage :: Maybe Rampage -> GameUpdateM Unit
changeRampage =
  applyGameUpdateM <<< ChangedRampage

initialGame :: Game
initialGame =
  { map: levelmap
  , players: M.fromList $ f <$> starts
  , items:   M.fromList $ zipNumbers $ makeItems levelmap safeZone bigDots
  , countdown: Just 90
  , rampage: Nothing
  , safeZone: safeZone
  }
  where
  levelmap = basicMap2
  f (Tuple pId position) = Tuple pId (mkPlayer position)
  starts =
    [ P1 ~ tilePositionToBlock (Position {x:7, y:7})
    , P2 ~ tilePositionToBlock (Position {x:9, y:7})
    , P3 ~ tilePositionToBlock (Position {x:7, y:8})
    , P4 ~ tilePositionToBlock (Position {x:9, y:8})
    ]
  safeZone = do
    x <- [7,8,9]
    y <- [6,7,8,9]
    return (tilePositionToBlock (Position {x:x, y:y}))
  bigDots = do
    x <- [3, tilesAlongSide - 4]
    y <- [3, tilesAlongSide - 4]
    return (tilePositionToBlock (Position {x:x, y:y}))

stepGame :: Input -> Game -> Tuple Game [GameUpdate]
stepGame input game =
  let actions = [handleInput input, doLogic]
      action = foldl (>>) (return unit) actions
  in  execGameUpdateM game action

handleInput :: Input -> GameUpdateM Unit
handleInput input =
  for_ (M.toList input) $ \(Tuple pId maybeDir) ->
    whenJust maybeDir $ \newDirection ->
      changeIntendedDirection pId (Just newDirection)

doLogic :: GameUpdateM Unit
doLogic = do
  g <- getGame
  case g.countdown of
    Just x -> changeCountdown (decrementOrNothing x)
    Nothing -> do
      eachPlayer updateDirection
      eachPlayer movePlayer
      eachPlayer eatItems
      eachPlayer eatOtherPlayers
      eachPlayer attemptRespawn
      decrementRampageCounter
      checkForGameEnd

decrementOrNothing x =
  let x' = x - 1
  in if x' <= 0
        then Nothing
        else Just x'

updateDirection :: PlayerId -> Player -> GameUpdateM Unit
updateDirection pId p =
  whenJust (p ^.pIntendedDirection) $ tryChangeDirection pId p

movePlayer :: PlayerId -> Player -> GameUpdateM Unit
movePlayer pId p =
  whenJust (p ^. pDirection) $ \dir -> do
    ok <- canMoveInDirection pId p dir
    when ok $ do
      changePosition pId $ moveInDirection dir (p ^. pPosition)
      changeNomIndex pId $ ((p ^. pNomIndex) + 1) % nomIndexMax

isRampage :: PlayerId -> GameUpdateM Boolean
isRampage pId = do
  g <- getGame
  maybe (return false) isRampaging g.rampage
  where
  isRampaging rampage =
    return $ case rampage of
      Rampaging pId' _ -> pId' == pId
      Cooldown _       -> false

eatItems :: PlayerId -> Player -> GameUpdateM Unit
eatItems pId p = do
  g <- getGame
  let mItem = lookupItemByPosition (p ^. pPosition) g
  whenJust mItem $ \(Tuple iId item) -> do
    case item ^. iType of
      LittleDot -> do
        eat iId
        changeScore pId (p ^. pScore + 1)
      BigDot ->
        when (not (isJust g.rampage)) $ do
          eat iId
          changeScore pId (p ^. pScore + 5)
          startRampage pId

eatOtherPlayers :: PlayerId -> Player -> GameUpdateM Unit
eatOtherPlayers pId p = do
  ok <- isRampage pId
  when ok $ do
    eachPlayer $ \pId' p' ->
      when (pId' /= pId && not (isRespawning p')) $ do
        let q = quadrance (p ^. pPosition) (p' ^. pPosition)
        when (q <= minEatingQuadrance) $ do
          changeRespawnCounter pId' $ Just respawnLength
          takeHalfPoints pId p pId' p'
  where
  takeHalfPoints pId p pId' p' = do
    let delta = floor (p' ^. pScore / 2)
    changeScore pId $ p ^. pScore + delta
    changeScore pId' $ p' ^. pScore - delta

decrementRampageCounter :: GameUpdateM Unit
decrementRampageCounter = do
  g <- getGame
  whenJust g.rampage $ \rampage ->
    changeRampage $
      case rampage of
        Rampaging pId ctr ->
          Just $ fromMaybe (Cooldown cooldownLength)
                           (Rampaging pId <$> decrementOrNothing ctr)
        Cooldown ctr ->
          Cooldown <$> decrementOrNothing ctr

startRampage :: PlayerId -> GameUpdateM Unit
startRampage pId =
  changeRampage $ Just $ Rampaging pId rampageLength

checkForGameEnd :: GameUpdateM Unit
checkForGameEnd = do
  g <- getGame
  whenJust (checkEnded g) endGame

tryChangeDirection :: PlayerId -> Player -> Direction -> GameUpdateM Unit
tryChangeDirection pId p d = do
  ok <- canMoveInDirection pId p d
  when ok $ do
    changeDirection pId (Just d)
    changeIntendedDirection pId Nothing

canMoveInDirection :: PlayerId -> Player -> Direction -> GameUpdateM Boolean
canMoveInDirection pId p d =
  let newPosition = moveInDirection d (p ^. pPosition)
      destIsFree game  = isFree game.map newPosition
      immobilised game = isRespawning p || isFleeing game
      isFleeing game   =
        case game.rampage of
          Just (Rampaging pId' count) -> pId' /= pId && count % 3 == 0
          _ -> false
      both (Tuple x y) = x && y

  in  both <<< (destIsFree &&& (not <<< immobilised)) <$> getGame

isRespawning p =
  isJust $ p ^. pRespawnCounter

attemptRespawn :: PlayerId -> Player -> GameUpdateM Unit
attemptRespawn pId p = do
  g <- getGame
  whenJust (p ^. pRespawnCounter) $ \ctr -> do
    let ctr' = decrementOrNothing ctr
    changeRespawnCounter pId ctr'
    when (ctr' == Nothing) $ do
      let mPos = find (\pos -> isFree g.map pos) g.safeZone
      whenJust mPos $ changePosition pId
      changeDirection pId Nothing

inSafeZone :: Game -> Position -> Boolean
inSafeZone g pos = pos `elem` g.safeZone

moveInDirection :: Direction -> Position -> Position
moveInDirection d p = add p (dirToPos d)

isFree :: LevelMap -> Position -> Boolean
isFree levelmap pos =
  let block = getBlockAt pos levelmap
  in  maybe false (not <<< isWall) block

makeItems :: LevelMap -> [Position] -> [Position] -> [Item]
makeItems levelmap safeZone bigDotPositions =
  littleDots <> bigDots
  where
  littleDots = do
    x <- r
    y <- r
    let pos = tilePositionToBlock (Position {x: x, y: y})
    if shouldHaveLittleDot pos
      then [Item { itemType: LittleDot, position: pos }]
      else []

  r = range 0 (tilesAlongSide - 1)

  shouldHaveLittleDot pos =
    isFree levelmap pos &&
      not (elem pos safeZone) &&
      not (elem pos bigDotPositions)

  bigDots =
    (\pos -> Item { itemType: BigDot, position: pos }) <$> bigDotPositions

makeGame :: [PlayerId] -> Game
makeGame pIds =
  let players' =
    deleteWhere (\pId _ -> not (elem pId pIds)) (initialGame.players)
  in initialGame { players = players' }

inCountdown :: Game -> Boolean
inCountdown g = isJust g.countdown

checkEnded :: Game -> Maybe GameEndReason
checkEnded g
  | M.isEmpty g.items && isNothing g.rampage  = Just Completed
  | length (M.values g.players) < minPlayers  = Just TooManyPlayersDisconnected
  | otherwise                                 = Nothing

isEnded = isJust <<< checkEnded

-- TODO: performance
lookupItemByPosition :: Position -> Game -> Maybe (Tuple ItemId Item)
lookupItemByPosition pos g =
  case filter (\i -> (i ^. _2 ^. iPosition) == pos) (M.toList g.items) of
      [i] -> Just i
      []  -> Nothing
      x   -> error $ "lookupItemByPosition: items stacked: " <> show x

module Game where

import Data.Tuple
import Data.Maybe
import Data.Maybe.Unsafe (fromJust)
import Data.Array ((!!), range, filter, length, take)
import qualified Data.Map as M
import Data.Foldable
import Control.Arrow
import Control.Alt
import Control.Monad
import Control.Monad.Reader.Class
import Control.Lens (LensP(), TraversalP(), lens, at, _Just, _1, _2,
                     (.~), (..), (^.), (%~), (~))
import Math (ceil, floor, pi)

import Types
import LevelMap
import Utils

minPlayers = 2
rampageLength = 180
cooldownLength = 120
respawnLength = 60

-- minimum squared distance that a player needs to be from another player in
-- order to eat them, in blocks.
minEatingQuadrance = 4

-- update signalling

player :: PlayerId -> TraversalP Game Player
player pId = players .. at pId .. _Just

item :: ItemId -> TraversalP Game Item
item iId = items .. at iId .. _Just

applyGameUpdate :: GameUpdate -> Game -> Game
applyGameUpdate u =
  case u of
    GUPU pId PlayerLeft ->
      removePlayer pId
    GUPU pId x ->
      player pId %~ applyPlayerUpdate x
    GUIU iId x ->
      items .. at iId %~ applyItemUpdate x
    ChangedCountdown x ->
      setCountdown x
    GameEnded _ ->
      id
    ChangedRampage r ->
      \g -> g { rampage = r }
  where
  setCountdown x game = game {countdown = x}

applyGameUpdates :: [GameUpdate] -> Game -> Game
applyGameUpdates updates game = foldr applyGameUpdate game updates

removePlayer :: PlayerId -> Game -> Game
removePlayer pId = players .. at pId .~ Nothing

applyPlayerUpdate :: PlayerUpdate -> Player -> Player
applyPlayerUpdate u =
  case u of
    (ChangedPosition p)          -> pPosition .~ p
    (ChangedDirection d)         -> pDirection .~ d
    (ChangedIntendedDirection d) -> pIntendedDirection .~ d
    (ChangedScore s)             -> pScore .~ s
    (ChangedNomIndex a)          -> pNomIndex .~ a
    (ChangedRespawnCounter x)    -> pRespawnCounter .~ x

applyItemUpdate :: ItemUpdate -> Maybe Item -> Maybe Item
applyItemUpdate u =
  case u of
    Eaten -> const Nothing

applyGameUpdateM :: GameUpdate -> GameUpdateM Unit
applyGameUpdateM update = do
  tellGameUpdate update
  modifyGame (applyGameUpdate update)

changePosition :: PlayerId -> Position -> GameUpdateM Unit
changePosition pId p =
  applyGameUpdateM (GUPU pId (ChangedPosition p))

changeDirection :: PlayerId -> Maybe Direction -> GameUpdateM Unit
changeDirection pId d =
  applyGameUpdateM (GUPU pId (ChangedDirection d))

changeIntendedDirection :: PlayerId -> Maybe Direction -> GameUpdateM Unit
changeIntendedDirection pId d =
  applyGameUpdateM (GUPU pId (ChangedIntendedDirection d))

changeScore :: PlayerId -> Number -> GameUpdateM Unit
changeScore pId s =
  applyGameUpdateM (GUPU pId (ChangedScore s))

changeCountdown :: Maybe Number -> GameUpdateM Unit
changeCountdown =
  applyGameUpdateM <<< ChangedCountdown

changeNomIndex :: PlayerId -> Number -> GameUpdateM Unit
changeNomIndex pId i =
  applyGameUpdateM (GUPU pId (ChangedNomIndex i))

eat :: ItemId -> GameUpdateM Unit
eat iId =
  applyGameUpdateM (GUIU iId Eaten)

changeRespawnCounter :: PlayerId -> Maybe Number -> GameUpdateM Unit
changeRespawnCounter pId x =
  applyGameUpdateM (GUPU pId (ChangedRespawnCounter x))

endGame :: GameEndReason -> GameUpdateM Unit
endGame =
  applyGameUpdateM <<< GameEnded

changeRampage :: Maybe Rampage -> GameUpdateM Unit
changeRampage =
  applyGameUpdateM <<< ChangedRampage

initialGame :: Game
initialGame =
  { map: levelmap
  , players: M.fromList $ f <$> starts
  , items:   M.fromList $ zipNumbers $ makeItems levelmap safeZone bigDots
  , countdown: Just 90
  , rampage: Nothing
  , safeZone: safeZone
  }
  where
  levelmap = basicMap2
  f (Tuple pId position) = Tuple pId (mkPlayer position)
  starts =
    [ P1 ~ tilePositionToBlock (Position {x:7, y:7})
    , P2 ~ tilePositionToBlock (Position {x:9, y:7})
    , P3 ~ tilePositionToBlock (Position {x:7, y:8})
    , P4 ~ tilePositionToBlock (Position {x:9, y:8})
    ]
  safeZone = do
    x <- [7,8,9]
    y <- [6,7,8,9]
    return (tilePositionToBlock (Position {x:x, y:y}))
  bigDots = do
    x <- [3, tilesAlongSide - 4]
    y <- [3, tilesAlongSide - 4]
    return (tilePositionToBlock (Position {x:x, y:y}))

stepGame :: Input -> Game -> Tuple Game [GameUpdate]
stepGame input game =
  let actions = [handleInput input, doLogic]
      action = foldl (>>) (return unit) actions
  in  execGameUpdateM game action

handleInput :: Input -> GameUpdateM Unit
handleInput input =
  for_ (M.toList input) $ \(Tuple pId maybeDir) ->
    whenJust maybeDir $ \newDirection ->
      changeIntendedDirection pId (Just newDirection)

doLogic :: GameUpdateM Unit
doLogic = do
  g <- getGame
  case g.countdown of
    Just x -> changeCountdown (decrementOrNothing x)
    Nothing -> do
      eachPlayer updateDirection
      eachPlayer movePlayer
      eachPlayer eatItems
      eachPlayer eatOtherPlayers
      eachPlayer attemptRespawn
      decrementRampageCounter
      checkForGameEnd

decrementOrNothing x =
  let x' = x - 1
  in if x' <= 0
        then Nothing
        else Just x'

updateDirection :: PlayerId -> Player -> GameUpdateM Unit
updateDirection pId p =
  whenJust (p ^.pIntendedDirection) $ tryChangeDirection pId p

movePlayer :: PlayerId -> Player -> GameUpdateM Unit
movePlayer pId p =
  whenJust (p ^. pDirection) $ \dir -> do
    ok <- canMoveInDirection pId p dir
    when ok $ do
      changePosition pId $ moveInDirection dir (p ^. pPosition)
      changeNomIndex pId $ ((p ^. pNomIndex) + 1) % nomIndexMax

isRampage :: PlayerId -> GameUpdateM Boolean
isRampage pId = do
  g <- getGame
  maybe (return false) isRampaging g.rampage
  where
  isRampaging rampage =
    return $ case rampage of
      Rampaging pId' _ -> pId' == pId
      Cooldown _       -> false

eatItems :: PlayerId -> Player -> GameUpdateM Unit
eatItems pId p = do
  g <- getGame
  let mItem = lookupItemByPosition (p ^. pPosition) g
  whenJust mItem $ \(Tuple iId item) -> do
    case item ^. iType of
      LittleDot -> do
        eat iId
        changeScore pId (p ^. pScore + 1)
      BigDot ->
        when (not (isJust g.rampage)) $ do
          eat iId
          changeScore pId (p ^. pScore + 5)
          startRampage pId

eatOtherPlayers :: PlayerId -> Player -> GameUpdateM Unit
eatOtherPlayers pId p = do
  ok <- isRampage pId
  when ok $ do
    eachPlayer $ \pId' p' ->
      when (pId' /= pId && not (isRespawning p')) $ do
        let q = quadrance (p ^. pPosition) (p' ^. pPosition)
        when (q <= minEatingQuadrance) $ do
          changeRespawnCounter pId' $ Just respawnLength
          takeHalfPoints pId p pId' p'
          changeDirection pId' Nothing
  where
  takeHalfPoints pId p pId' p' = do
    let delta = floor (p' ^. pScore / 2)
    changeScore pId $ p ^. pScore + delta
    changeScore pId' $ p' ^. pScore - delta

decrementRampageCounter :: GameUpdateM Unit
decrementRampageCounter = do
  g <- getGame
  whenJust g.rampage $ \rampage ->
    changeRampage $
      case rampage of
        Rampaging pId ctr ->
          Just $ fromMaybe (Cooldown cooldownLength)
                           (Rampaging pId <$> decrementOrNothing ctr)
        Cooldown ctr ->
          Cooldown <$> decrementOrNothing ctr

startRampage :: PlayerId -> GameUpdateM Unit
startRampage pId =
  changeRampage $ Just $ Rampaging pId rampageLength

checkForGameEnd :: GameUpdateM Unit
checkForGameEnd = do
  g <- getGame
  whenJust (checkEnded g) endGame

tryChangeDirection :: PlayerId -> Player -> Direction -> GameUpdateM Unit
tryChangeDirection pId p d = do
  ok <- canMoveInDirection pId p d
  when ok $ do
    changeDirection pId (Just d)
    changeIntendedDirection pId Nothing

canMoveInDirection :: PlayerId -> Player -> Direction -> GameUpdateM Boolean
canMoveInDirection pId p d =
  let newPosition = moveInDirection d (p ^. pPosition)
      destIsFree game  = isFree game.map newPosition
      immobilised game = isRespawning p || isFleeing game
      isFleeing game   =
        case game.rampage of
          Just (Rampaging pId' count) -> pId' /= pId && count % 3 == 0
          _ -> false
      both (Tuple x y) = x && y

  in  both <<< (destIsFree &&& (not <<< immobilised)) <$> getGame

isRespawning p =
  isJust $ p ^. pRespawnCounter

attemptRespawn :: PlayerId -> Player -> GameUpdateM Unit
attemptRespawn pId p = do
  g <- getGame
  whenJust (p ^. pRespawnCounter) $ \ctr -> do
    let ctr' = decrementOrNothing ctr
    changeRespawnCounter pId ctr'
    when (ctr' == Nothing) $ do
      let mPos = find (\pos -> isFree g.map pos) g.safeZone
      whenJust mPos $ changePosition pId

inSafeZone :: Game -> Position -> Boolean
inSafeZone g pos = pos `elem` g.safeZone

moveInDirection :: Direction -> Position -> Position
moveInDirection d p = add p (dirToPos d)

isFree :: LevelMap -> Position -> Boolean
isFree levelmap pos =
  let block = getBlockAt pos levelmap
  in  maybe false (not <<< isWall) block

makeItems :: LevelMap -> [Position] -> [Position] -> [Item]
makeItems levelmap safeZone bigDotPositions =
  littleDots <> bigDots
  where
  littleDots = do
    x <- r
    y <- r
    let pos = tilePositionToBlock (Position {x: x, y: y})
    if shouldHaveLittleDot pos
      then [Item { itemType: LittleDot, position: pos }]
      else []

  r = range 0 (tilesAlongSide - 1)

  shouldHaveLittleDot pos =
    isFree levelmap pos &&
      not (elem pos safeZone) &&
      not (elem pos bigDotPositions)

  bigDots =
    (\pos -> Item { itemType: BigDot, position: pos }) <$> bigDotPositions

makeGame :: [PlayerId] -> Game
makeGame pIds =
  let players' =
    deleteWhere (\pId _ -> not (elem pId pIds)) (initialGame.players)
  in initialGame { players = players' }

inCountdown :: Game -> Boolean
inCountdown g = isJust g.countdown

checkEnded :: Game -> Maybe GameEndReason
checkEnded g
  | M.isEmpty g.items && isNothing g.rampage  = Just Completed
  | length (M.values g.players) < minPlayers  = Just TooManyPlayersDisconnected
  | otherwise                                 = Nothing

isEnded = isJust <<< checkEnded

-- TODO: performance
lookupItemByPosition :: Position -> Game -> Maybe (Tuple ItemId Item)
lookupItemByPosition pos g =
  case filter (\i -> (i ^. _2 ^. iPosition) == pos) (M.toList g.items) of
      [i] -> Just i
      []  -> Nothing
      x   -> error $ "lookupItemByPosition: items stacked: " <> show x


Fix order

Fix order

Original commit be245196f029677d9c7ff2cf783384af9181cee6

module Main where

import IR
import IRGraph
import Prelude
import Transformations

import CSharp as CSharp
import Data.Argonaut.Core (Json)
import Data.Argonaut.Core (foldJson) as J
import Data.Argonaut.Decode (decodeJson) as J
import Data.Argonaut.Parser (jsonParser) as J
import Data.Array (find, foldl)
import Data.Array as A
import Data.Either (Either(..), isRight)
import Data.Map as Map
import Data.Maybe (Maybe(..))
import Data.Set as S
import Data.StrMap as StrMap
import Data.String.Util (singular)
import Data.Tuple (Tuple(..))
import Doc as Doc
import Environment (Environment(..))
import Environment as Env
import Golang as Golang
import JsonSchema (JSONSchema, jsonSchemaToIR)
import JsonSchema as JsonSchema
import Math (round)
import Utils (mapM)

type Error = String

type Pipeline = Doc.Renderer -> Json -> Either Error String

renderers :: Array Doc.Renderer
renderers = [CSharp.renderer, Golang.renderer, JsonSchema.renderer]

makeTypeFromJson :: String -> Json -> IR IRType
makeTypeFromJson name json =
    J.foldJson
    (\_ -> pure IRNull)
    (\_ -> pure IRBool)
    (\n -> pure if round n == n then IRInteger else IRDouble)
    (\_ -> pure IRString)
    (\arr -> do
        let typeName = singular name
        IRArray <$> A.foldRecM (unify typeName) IRNothing arr)
    (\obj -> do
        let l1 = StrMap.toUnfoldable obj
        l2 <- mapM toProperty l1
        addClass $ IRClassData { names: S.singleton name, properties: Map.fromFoldable l2 })
    json
    where
        unify typeName t1 j2 = makeTypeFromJson typeName j2 >>= unifyTypes t1
        toProperty (Tuple name json) = Tuple name <$> makeTypeFromJson name json

makeTypeAndUnify :: String -> Json -> IRGraph
makeTypeAndUnify name json = execIR do
    topLevel <- makeTypeFromJson name json
    setTopLevel topLevel
    replaceSimilarClasses
    makeMaps

irFromError :: String -> IR IRType
irFromError err = do
    addClass $ IRClassData { names: S.singleton err, properties: Map.empty }

makeTypeFromSchema :: String -> JSONSchema -> Either Error IRGraph
makeTypeFromSchema name schema = eitherify $ runIR do
    topLevelOrError <- jsonSchemaToIR schema "TopLevel" schema
    case topLevelOrError of
        Left err -> pure $ Just err
        Right topLevel -> do
            setTopLevel topLevel
            pure Nothing
    where
        eitherify (Tuple (Just err) _) = Left err
        eitherify (Tuple Nothing g) = Right g

jsonPipeline :: Pipeline
jsonPipeline renderer json =
    json
    # makeTypeAndUnify "TopLevel"
    # regatherClassNames
    # Doc.runRenderer renderer
    # Right

jsonSchemaPipeline :: Pipeline
jsonSchemaPipeline renderer json =
    json
    # J.decodeJson
    >>= makeTypeFromSchema "TopLevel"
    <#> regatherClassNames
    <#> Doc.runRenderer renderer

pipelines :: Env.Environment -> Array Pipeline
pipelines Env.Development = [jsonSchemaPipeline, jsonPipeline]
pipelines Env.Production = [jsonPipeline]

arrayPipeline :: Array Pipeline -> Pipeline
arrayPipeline pipes renderer json = foldl takeFirstRight (Left "") pipes
    where
        takeFirstRight (Right output) _ = Right output
        takeFirstRight _ pipeline = pipeline renderer json

renderForUI :: Doc.Renderer -> String -> Either Error String
renderForUI renderer json = do
    obj <- J.jsonParser json
    arrayPipeline (pipelines Env.current) renderer obj

module Main where

import IR
import IRGraph
import Prelude
import Transformations

import CSharp as CSharp
import Data.Argonaut.Core (Json)
import Data.Argonaut.Core (foldJson) as J
import Data.Argonaut.Decode (decodeJson) as J
import Data.Argonaut.Parser (jsonParser) as J
import Data.Array (find, foldl)
import Data.Array as A
import Data.Either (Either(..), isRight)
import Data.Map as Map
import Data.Maybe (Maybe(..))
import Data.Set as S
import Data.StrMap as StrMap
import Data.String.Util (singular)
import Data.Tuple (Tuple(..))
import Doc as Doc
import Environment (Environment(..))
import Environment as Env
import Golang as Golang
import JsonSchema (JSONSchema, jsonSchemaToIR)
import JsonSchema as JsonSchema
import Math (round)
import Utils (mapM)

type Error = String

type Pipeline = Doc.Renderer -> Json -> Either Error String

renderers :: Array Doc.Renderer
renderers = [CSharp.renderer, Golang.renderer, JsonSchema.renderer]

makeTypeFromJson :: String -> Json -> IR IRType
makeTypeFromJson name json =
    J.foldJson
    (\_ -> pure IRNull)
    (\_ -> pure IRBool)
    (\n -> pure if round n == n then IRInteger else IRDouble)
    (\_ -> pure IRString)
    (\arr -> do
        let typeName = singular name
        IRArray <$> A.foldRecM (unify typeName) IRNothing arr)
    (\obj -> do
        let l1 = StrMap.toUnfoldable obj
        l2 <- mapM toProperty l1
        addClass $ IRClassData { names: S.singleton name, properties: Map.fromFoldable l2 })
    json
    where
        unify typeName t1 j2 = makeTypeFromJson typeName j2 >>= unifyTypes t1
        toProperty (Tuple name json) = Tuple name <$> makeTypeFromJson name json

makeTypeAndUnify :: String -> Json -> IRGraph
makeTypeAndUnify name json = execIR do
    topLevel <- makeTypeFromJson name json
    setTopLevel topLevel
    replaceSimilarClasses
    makeMaps

irFromError :: String -> IR IRType
irFromError err = do
    addClass $ IRClassData { names: S.singleton err, properties: Map.empty }

makeTypeFromSchema :: String -> JSONSchema -> Either Error IRGraph
makeTypeFromSchema name schema = eitherify $ runIR do
    topLevelOrError <- jsonSchemaToIR schema "TopLevel" schema
    case topLevelOrError of
        Left err -> pure $ Just err
        Right topLevel -> do
            setTopLevel topLevel
            pure Nothing
    where
        eitherify (Tuple (Just err) _) = Left err
        eitherify (Tuple Nothing g) = Right g

jsonPipeline :: Pipeline
jsonPipeline renderer json =
    json
    # makeTypeAndUnify "TopLevel"
    # regatherClassNames
    # Doc.runRenderer renderer
    # Right

jsonSchemaPipeline :: Pipeline
jsonSchemaPipeline renderer json =
    json
    # J.decodeJson
    >>= makeTypeFromSchema "TopLevel"
    <#> regatherClassNames
    <#> Doc.runRenderer renderer

pipelines :: Env.Environment -> Array Pipeline
pipelines Env.Production = [jsonSchemaPipeline, jsonPipeline]
pipelines Env.Development = [jsonPipeline]

arrayPipeline :: Array Pipeline -> Pipeline
arrayPipeline pipes renderer json = foldl takeFirstRight (Left "") pipes
    where
        takeFirstRight (Right output) _ = Right output
        takeFirstRight _ pipeline = pipeline renderer json

renderForUI :: Doc.Renderer -> String -> Either Error String
renderForUI renderer json = do
    obj <- J.jsonParser json
    arrayPipeline (pipelines Env.current) renderer obj