Find & show associated annotation when SNP is clicked (if applicable)

module Genetics.Browser.Track.UI where

import Prelude

import Color (black)
import Color.Scheme.Clrs (blue)
import Control.Coroutine (Consumer, Producer, connect, runProcess)
import Control.Coroutine as Co
import Control.Monad.Aff (Aff, Fiber, Milliseconds, delay, forkAff, killFiber, launchAff, launchAff_)
import Control.Monad.Aff.AVar (AVar, makeEmptyVar, makeVar, putVar, readVar, takeVar, tryTakeVar)
import Control.Monad.Aff.AVar as AVar
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Console (log)
import Control.Monad.Eff.Exception (error)
import Control.Monad.Eff.Random (randomRange)
import Control.Monad.Rec.Class (forever)
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.ParentNode (querySelector) as DOM
import Data.Array as Array
import Data.Bifunctor (bimap)
import Data.BigInt (BigInt)
import Data.BigInt as BigInt
import Data.Either (Either(Right, Left))
import Data.Foldable (class Foldable, foldMap, length, null, oneOf)
import Data.Foreign (Foreign, MultipleErrors, renderForeignError)
import Data.Lens (Iso', iso, re, to, united, (^.))
import Data.Lens.Iso.Newtype (_Newtype)
import Data.List (List)
import Data.Map (Map)
import Data.Map as Map
import Data.Maybe (Maybe(..), fromJust, fromMaybe)
import Data.Monoid (class Monoid, mempty)
import Data.Newtype (over, unwrap, wrap)
import Data.Pair (Pair(..))
import Data.Pair as Pair
import Data.Symbol (SProxy(..))
import Data.Traversable (for, for_, traverse, traverse_)
import Data.Tuple (Tuple(Tuple))
import Genetics.Browser.Track.Backend (Rendered, RenderedTrack, browser, bumpFeatures, zipMapsWith)
import Genetics.Browser.Track.Demo (Annot, BedFeature, GWASFeature, annotLegendTest, demoTracks, getAnnotations, getGWAS, getGenes, gwasDraw, produceAnnots, produceGWAS, produceGenes, renderAnnot, renderGWAS)
import Genetics.Browser.Track.UI.Canvas (BrowserCanvas, TrackPadding, blankTrack, browserCanvas, browserOnClick, debugBrowserCanvas, dragScroll, drawOnTrack, flipTrack, renderBatchGlyphs, renderBrowser', renderBrowser'', renderTrack, subtractPadding, trackDimensions, trackViewScale, uiSlots, wheelZoom)
import Genetics.Browser.Types (Bp(Bp), ChrId(ChrId))
import Genetics.Browser.Types.Coordinates (CoordSys, CoordSysView(CoordSysView), ViewScale, _TotalSize, aroundPair, coordSys, normalizeView, pairSize, pairsOverlap, pixelsView, scaleViewBy, showViewScale, translateViewBy)
import Global.Unsafe (unsafeStringify)
import Graphics.Canvas (fillRect, setFillStyle)
import Graphics.Canvas as Canvas
import Graphics.Drawing (Drawing, Point)
import Graphics.Drawing as Drawing
import Math as Math
import Partial.Unsafe (unsafePartial)
import Simple.JSON (read)

foreign import windowInnerSize :: forall e.
                                  Eff e Canvas.Dimensions

-- | Set an event to fire on the given button id
foreign import buttonEvent :: forall eff.
                              String
                           -> Eff eff Unit
                           -> Eff eff Unit

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

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
               -> CoordSysView
               -> CoordSysView
updateViewFold uv iv = case uv of
  ZoomView   x -> iv `scaleViewBy`     x
  ScrollView x -> iv `translateViewBy` x
  ModView f    -> over CoordSysView 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

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"
      ]

-- runs console.time() with the provided string, returns the effect to stop the timer
foreign import timeEff :: forall eff. String -> Eff eff (Eff eff Unit)

type UIState e = { view :: AVar CoordSysView
                 , viewCmd :: AVar UpdateView
                 , viewReady :: AVar Unit
                 , renderFiber :: AVar (Fiber e Unit)
                 , cachedTracks :: AVar { cachedScale :: ViewScale
                                        , glyphs :: List (Array RenderedTrack) }
                 , lastOverlaps :: AVar (Number -> Point -> { gwas :: Array (GWASFeature ()) } )
                 }

diffView :: CoordSysView -> CoordSysView -> CoordSysView
diffView v1 v2 =
  let (Pair l1 r1) = unwrap v1
      (Pair l2 r2) = unwrap v2
  in wrap $ Pair (l2 - l1) (r2 - r1)

showView :: CoordSysView -> String
showView (CoordSysView (Pair l r)) = BigInt.toString l <> " - " <> BigInt.toString r

_PairRec :: forall a. Iso' (Pair a) { l :: a, r :: a }
_PairRec = iso (\(Pair l r) -> {l, r}) (\ {l, r} -> Pair l r)

debugView :: UIState _
          -> Eff _ { get :: _
                   , set :: _ }
debugView s = do
  let get name = launchAff_ do
         view <- AVar.tryReadVar s.view
         liftEff case view of
           Nothing -> do
             log "CoordSysView state empty"
             setWindow name unit
           Just (v :: _)  -> do
             log $ "CoordSysView: " <> showView v
             setWindow name $ unwrap v ^. _PairRec

  let set lr = launchAff_ do
         view <- AVar.tryTakeVar s.view
         case view of
           Nothing -> pure unit
           Just _  -> do
             let v' = wrap $ lr ^. re _PairRec
             _ <- AVar.tryPutVar unit s.viewReady
             AVar.putVar v' s.view

  pure {get, set}

uiViewUpdate :: forall r.
                CoordSys _ BigInt
             -> Milliseconds
             -> { view :: AVar CoordSysView
                , viewCmd :: AVar UpdateView
                , viewReady :: AVar Unit| r }
             -> Aff _ Unit
uiViewUpdate cs timeout { view, viewCmd, viewReady } = do
  curCmdVar <- makeVar mempty

  let normView = normalizeView cs (BigInt.fromInt 200000)
      loop' updater = do
        cmd <- takeVar viewCmd

        killFiber (error "Resetting view update") updater
        liftEff $ log $ "forking view update"

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

        updater' <- forkAff do
            delay timeout
            liftEff $ log "Running view update"
            vr <- takeVar view

            let vr' = normView $ updateViewFold cmd' vr

            putVar vr' view

            putVar unit viewReady
            takeVar curCmdVar *> putVar mempty curCmdVar

        loop' updater'

  loop' (pure unit)

{-
renderLoop :: CoordSys _ _
           -> { tracks     :: Pair BigInt -> List (Array RenderedTrack)
              , relativeUI :: Pair BigInt -> Drawing
              , fixedUI :: Drawing }
           -> BrowserCanvas
           -> UIState _
           -> Aff _ Unit
renderLoop cSys browser canvas state = forever do

  _ <- takeVar state.viewReady

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

  let uiScale = trackViewScale canvas csView

  -- if the view scale is unchanged, use the cached glyphs
  tracks' <- do
    cache <- AVar.tryTakeVar state.cachedTracks
    case cache of
      Just ct
        | ct.cachedScale == uiScale -> do
            AVar.putVar ct state.cachedTracks
            pure ct.glyphs
      _ -> do
        let cachedScale = uiScale
            glyphs = browser.tracks (unwrap csView)

        AVar.putVar {cachedScale, glyphs} state.cachedTracks
        pure glyphs

  -- fork a new renderFiber

  let (Pair offset _) = pixelsView uiScale csView

      relativeUI = browser.relativeUI (unwrap csView)
      fixedUI = browser.fixedUI

      ui ::  { tracks     :: List (Array RenderedTrack)
             , relativeUI :: Drawing
             , fixedUI :: Drawing }
      ui = { tracks: tracks'
           , relativeUI, fixedUI }

  renderFiber <- forkAff
                 $ renderBrowser (wrap 3.0) canvas offset ui

  putVar renderFiber state.renderFiber
-}

renderLoop' :: CoordSys _ _
           -> { tracks     :: Pair BigInt -> { gwas :: Rendered (GWASFeature ())
                                             , annotations :: Rendered (Annot (score :: Number)) }
              , relativeUI :: Pair BigInt -> Drawing
              , fixedUI :: Drawing }
           -> BrowserCanvas
           -> UIState _
           -> Aff _ Unit
renderLoop' cSys browser canvas state = forever do

  _ <- takeVar state.viewReady

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

  let uiScale = trackViewScale canvas csView

  liftEff $ log $ "view scale is: " <> showViewScale uiScale

  {-

  -- if the view scale is unchanged, use the cached glyphs
  tracks' <- do
    cache <- AVar.tryTakeVar state.cachedTracks
    case cache of
      Just ct
        | ct.cachedScale == uiScale -> do
            AVar.putVar ct state.cachedTracks
            pure ct.glyphs
      _ -> do
        let cachedScale = uiScale
            glyphs = browser.tracks (unwrap csView)

        AVar.putVar {cachedScale, glyphs} state.cachedTracks
        pure glyphs

  -}

  let tracks' = browser.tracks (unwrap csView)

  -- fork a new renderFiber

  let (Pair offset _) = pixelsView uiScale csView

      relativeUI = browser.relativeUI (unwrap csView)
      fixedUI = browser.fixedUI

      ui ::  { tracks     :: _
             , relativeUI :: Drawing
             , fixedUI :: Drawing }
      ui = { tracks: tracks'
           , relativeUI, fixedUI }

  _ <- AVar.tryTakeVar state.lastOverlaps
                    -- offset the click by the current canvas translation
  AVar.putVar (\n r -> let r' = {x: r.x + offset, y: r.y }
                       in { gwas: tracks'.gwas.overlaps n r' }) state.lastOverlaps

  renderFiber <- forkAff
                 $ renderBrowser'' (wrap 2.0) canvas offset ui

  putVar renderFiber state.renderFiber

printSNPInfo :: forall r. Array (GWASFeature r) -> Eff _ Unit
printSNPInfo fs = do
  let n = length fs :: Int
      m = 5

      showSnp f = do
        log $ f.feature.name <> " - "
           <> unwrap f.feature.chrId <> " @ "
           <> show (map show f.position)

  log $ "showing " <> show n <> " clicked glyphs"
  for_ (Array.take m fs) showSnp

snpInfoHTML :: forall r. GWASFeature r -> String
snpInfoHTML { position, feature } =
    "
SNP: "   <> feature.name <> "
"
 <> "
Chr: "   <> show feature.chrId <> "
"
 <> "
Pos: "   <> show (Pair.fst position) <> "
"
 <> "
Score: " <> show feature.score <> "
"

snpInfoHTML' :: forall rA rS.
                (GWASFeature rS -> Maybe (Annot rA))
             -> GWASFeature rS
             -> String
snpInfoHTML' assocAnnot snp =
   snpInfoHTML snp <> case assocAnnot snp of
     Nothing -> "
No annotation found
"
     Just a  -> "
Annotation: " <> show a.feature.name <> "
"

annotForSnp :: forall rA rS.
               Map ChrId (Array (Annot rA))
            -> GWASFeature rS
            -> Maybe (Annot rA)
annotForSnp annotations {position, feature} = do
  let radius = Bp 10000000.0
  chr <- Map.lookup feature.chrId annotations
  Array.find (\a -> ((radius `aroundPair` a.position) `pairsOverlap` position)) chr

foreign import setInfoBoxVisibility :: forall e. String -> Eff e Unit
foreign import setInfoBoxContents :: forall e. String -> Eff e Unit

foreign import initDebugDiv :: forall e. Number -> Eff e Unit

foreign import setDebugDivVisibility :: forall e.
                                        String -> Eff e Unit

foreign import setDebugDivPoint :: forall e.
                                   Point -> Eff e Unit

-- TODO configure UI widths
runBrowser :: Conf -> BrowserCanvas -> Eff _ _
runBrowser config bc = launchAff $ do

  let clickRadius = 1.0

  liftEff $ initDebugDiv clickRadius

  let browserDimensions = (unwrap bc).dimensions

  {width} <- liftEff $ windowInnerSize

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

  let cSys :: CoordSys ChrId BigInt
      cSys = coordSys mouseChrSizes

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

    let annotations = zipMapsWith
                       (bumpFeatures (to (\s -> s.feature.score + 0.02)) (SProxy :: SProxy "score")
                         (Bp 1000000.0))
                       <$> gwas <*> rawAnnotations

    pure { genes, gwas, annotations }

  let initialView :: CoordSysView
      initialView = wrap $ Pair zero (cSys^._TotalSize)

  viewCmd <- makeEmptyVar
  liftEff $ do
    btnScroll 0.05 viewCmd
    btnZoom   0.10 viewCmd

    let dragCB {x,y} =
          when (Math.abs x >= one)
          $ queueCmd viewCmd $ ScrollView $ (-x) / (trackDimensions bc).width
    dragScroll bc dragCB

    let scrollZoomScale = 0.06
        wheelCB dY =
          queueCmd viewCmd $ ZoomView $ 1.0 + scrollZoomScale * dY
    wheelZoom bc wheelCB

  view <- makeVar initialView
  viewReady <- makeVar unit
  renderFiber <- makeEmptyVar
  cachedTracks <- AVar.makeEmptyVar
  lastOverlaps <- AVar.makeEmptyVar

  let initState :: UIState _
      initState = { view, viewCmd, viewReady, renderFiber, cachedTracks, lastOverlaps }

  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 = demoTracks vscale trackData

      padding = { horizontal: config.trackPadding.left
                , vertical: config.trackPadding.top }

      mainBrowser :: _
      mainBrowser = browser cSys
                     (trackDimensions bc) browserDimensions
                     (uiSlots bc) {legend, vscale}
                     { gwas: renderGWAS vscale
                     , annotations: renderAnnot vscale }
                     { gwas: fromMaybe mempty trackData.gwas
                     , annotations: fromMaybe mempty trackData.annotations }

      viewTimeout :: Milliseconds
      viewTimeout = wrap 100.0

  liftEff do
    setWindow "mainBrowser" mainBrowser
    setWindow "debugView" (debugView initState)

    let findAnnot = annotForSnp $ fromMaybe mempty trackData.annotations

    let glyphClick :: _
        glyphClick p = launchAff_ do
          AVar.tryReadVar lastOverlaps >>= case _ of
             Nothing -> liftEff do
               log "clicked no glyphs"
               setInfoBoxVisibility "hidden"

             Just gs -> liftEff do
               let clicked = (gs clickRadius p).gwas
               printSNPInfo clicked
               case Array.head clicked of
                 Nothing -> setInfoBoxVisibility "hidden"
                 Just g  -> do
                   setInfoBoxContents $ snpInfoHTML' findAnnot g
                   setInfoBoxVisibility "visible"

    ovCtx <- Canvas.getContext2D (unwrap bc).overlay

    let overlayDebug :: _
        overlayDebug p = do
          let pad = (unwrap bc).trackPadding
              dim = (unwrap bc).dimensions

          setDebugDivVisibility "visible"
          setDebugDivPoint p

    browserOnClick bc
      { overlay: \_ -> pure unit
      , track:   glyphClick }

  _ <- forkAff $ uiViewUpdate cSys viewTimeout initState

  _ <- forkAff $ renderLoop' cSys mainBrowser bc initState

  pure unit

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

type Conf = { browserHeight :: Number
            , trackPadding :: TrackPadding
            , score :: { min :: Number, max :: Number, sig :: Number }
            , urls :: DataURLs
            }

foreign import setWindow :: forall e a. String -> a -> Eff e Unit

initBrowser :: Foreign -> Eff _ _
initBrowser rawConfig = do

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

  case read rawConfig :: Either MultipleErrors Conf of
    Left errs -> traverse_ (log <<< renderForeignError) errs
    Right c   -> do
      case el' of
        Nothing -> log "Could not find element '#browser'"
        Just el -> do

          {width} <- windowInnerSize
          let dimensions = { width, height: c.browserHeight }
          bc <- browserCanvas dimensions c.trackPadding el

          debugBrowserCanvas "debugBC" bc

          log $ unsafeStringify c
          void $ runBrowser c bc

-- 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
       putVar (sofar <> m) av
       delay (wrap 20.0)
       pure Nothing

type TrackVar a = AVar (Map ChrId (Array a))
type TrackProducer eff a = Producer (Map ChrId (Array a)) (Aff eff) Unit

-- Feels like this one takes care of a bit too much...
fetchLoop1 :: forall a.
              (Maybe (Aff _ (TrackProducer _ a)))
           -> Aff _ (TrackVar a)
fetchLoop1 Nothing = AVar.makeEmptyVar
fetchLoop1 (Just startProd) = do
  prod <- startProd
  avar <- makeVar mempty
  _ <- forkAff $ runProcess $ prod `connect` chunkConsumer avar
  pure avar

-- | 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
  gwas <-        fetchLoop1 $ produceGWAS   cs <$> urls.gwas
  annotations <- fetchLoop1 $ produceAnnots cs <$> urls.annotations
  genes <-       fetchLoop1 $ produceGenes  cs <$> urls.genes
  pure { gwas, genes, annotations }

module Genetics.Browser.Track.UI where

import Prelude

import Color (black)
import Color.Scheme.Clrs (blue)
import Control.Coroutine (Consumer, Producer, connect, runProcess)
import Control.Coroutine as Co
import Control.Monad.Aff (Aff, Fiber, Milliseconds, delay, forkAff, killFiber, launchAff, launchAff_)
import Control.Monad.Aff.AVar (AVar, makeEmptyVar, makeVar, putVar, readVar, takeVar, tryTakeVar)
import Control.Monad.Aff.AVar as AVar
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Console (log)
import Control.Monad.Eff.Exception (error)
import Control.Monad.Eff.Random (randomRange)
import Control.Monad.Rec.Class (forever)
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.ParentNode (querySelector) as DOM
import Data.Array as Array
import Data.Bifunctor (bimap)
import Data.BigInt (BigInt)
import Data.BigInt as BigInt
import Data.Either (Either(Right, Left))
import Data.Foldable (class Foldable, foldMap, length, null, oneOf)
import Data.Foreign (Foreign, MultipleErrors, renderForeignError)
import Data.Lens (Iso', iso, re, to, united, (^.))
import Data.Lens.Iso.Newtype (_Newtype)
import Data.List (List)
import Data.Map (Map)
import Data.Maybe (Maybe(..), fromJust, fromMaybe)
import Data.Monoid (class Monoid, mempty)
import Data.Newtype (over, unwrap, wrap)
import Data.Pair (Pair(..))
import Data.Pair as Pair
import Data.Symbol (SProxy(..))
import Data.Traversable (for, for_, traverse, traverse_)
import Data.Tuple (Tuple(Tuple))
import Genetics.Browser.Track.Backend (Rendered, RenderedTrack, browser, bumpFeatures, zipMapsWith)
import Genetics.Browser.Track.Demo (Annot, BedFeature, GWASFeature, annotLegendTest, demoTracks, getAnnotations, getGWAS, getGenes, gwasDraw, produceAnnots, produceGWAS, produceGenes, renderAnnot, renderGWAS)
import Genetics.Browser.Track.UI.Canvas (BrowserCanvas, TrackPadding, blankTrack, browserCanvas, browserOnClick, debugBrowserCanvas, dragScroll, drawOnTrack, flipTrack, renderBatchGlyphs, renderBrowser', renderBrowser'', renderTrack, subtractPadding, trackDimensions, trackViewScale, uiSlots, wheelZoom)
import Genetics.Browser.Types (Bp(Bp), ChrId(ChrId))
import Genetics.Browser.Types.Coordinates (CoordSys, CoordSysView(CoordSysView), ViewScale, _TotalSize, coordSys, normalizeView, pairSize, pixelsView, scaleViewBy, showViewScale, translateViewBy)
import Global.Unsafe (unsafeStringify)
import Graphics.Canvas (fillRect, setFillStyle)
import Graphics.Canvas as Canvas
import Graphics.Drawing (Drawing, Point)
import Graphics.Drawing as Drawing
import Math as Math
import Partial.Unsafe (unsafePartial)
import Simple.JSON (read)

foreign import windowInnerSize :: forall e.
                                  Eff e Canvas.Dimensions

-- | Set an event to fire on the given button id
foreign import buttonEvent :: forall eff.
                              String
                           -> Eff eff Unit
                           -> Eff eff Unit

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

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
               -> CoordSysView
               -> CoordSysView
updateViewFold uv iv = case uv of
  ZoomView   x -> iv `scaleViewBy`     x
  ScrollView x -> iv `translateViewBy` x
  ModView f    -> over CoordSysView 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

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"
      ]

-- runs console.time() with the provided string, returns the effect to stop the timer
foreign import timeEff :: forall eff. String -> Eff eff (Eff eff Unit)

type UIState e = { view :: AVar CoordSysView
                 , viewCmd :: AVar UpdateView
                 , viewReady :: AVar Unit
                 , renderFiber :: AVar (Fiber e Unit)
                 , cachedTracks :: AVar { cachedScale :: ViewScale
                                        , glyphs :: List (Array RenderedTrack) }
                 , lastOverlaps :: AVar (Number -> Point -> { gwas :: Array (GWASFeature ()) } )
                 }

diffView :: CoordSysView -> CoordSysView -> CoordSysView
diffView v1 v2 =
  let (Pair l1 r1) = unwrap v1
      (Pair l2 r2) = unwrap v2
  in wrap $ Pair (l2 - l1) (r2 - r1)

showView :: CoordSysView -> String
showView (CoordSysView (Pair l r)) = BigInt.toString l <> " - " <> BigInt.toString r

_PairRec :: forall a. Iso' (Pair a) { l :: a, r :: a }
_PairRec = iso (\(Pair l r) -> {l, r}) (\ {l, r} -> Pair l r)

debugView :: UIState _
          -> Eff _ { get :: _
                   , set :: _ }
debugView s = do
  let get name = launchAff_ do
         view <- AVar.tryReadVar s.view
         liftEff case view of
           Nothing -> do
             log "CoordSysView state empty"
             setWindow name unit
           Just (v :: _)  -> do
             log $ "CoordSysView: " <> showView v
             setWindow name $ unwrap v ^. _PairRec

  let set lr = launchAff_ do
         view <- AVar.tryTakeVar s.view
         case view of
           Nothing -> pure unit
           Just _  -> do
             let v' = wrap $ lr ^. re _PairRec
             _ <- AVar.tryPutVar unit s.viewReady
             AVar.putVar v' s.view

  pure {get, set}

uiViewUpdate :: forall r.
                CoordSys _ BigInt
             -> Milliseconds
             -> { view :: AVar CoordSysView
                , viewCmd :: AVar UpdateView
                , viewReady :: AVar Unit| r }
             -> Aff _ Unit
uiViewUpdate cs timeout { view, viewCmd, viewReady } = do
  curCmdVar <- makeVar mempty

  let normView = normalizeView cs (BigInt.fromInt 200000)
      loop' updater = do
        cmd <- takeVar viewCmd

        killFiber (error "Resetting view update") updater
        liftEff $ log $ "forking view update"

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

        updater' <- forkAff do
            delay timeout
            liftEff $ log "Running view update"
            vr <- takeVar view

            let vr' = normView $ updateViewFold cmd' vr

            putVar vr' view

            putVar unit viewReady
            takeVar curCmdVar *> putVar mempty curCmdVar

        loop' updater'

  loop' (pure unit)

{-
renderLoop :: CoordSys _ _
           -> { tracks     :: Pair BigInt -> List (Array RenderedTrack)
              , relativeUI :: Pair BigInt -> Drawing
              , fixedUI :: Drawing }
           -> BrowserCanvas
           -> UIState _
           -> Aff _ Unit
renderLoop cSys browser canvas state = forever do

  _ <- takeVar state.viewReady

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

  let uiScale = trackViewScale canvas csView

  -- if the view scale is unchanged, use the cached glyphs
  tracks' <- do
    cache <- AVar.tryTakeVar state.cachedTracks
    case cache of
      Just ct
        | ct.cachedScale == uiScale -> do
            AVar.putVar ct state.cachedTracks
            pure ct.glyphs
      _ -> do
        let cachedScale = uiScale
            glyphs = browser.tracks (unwrap csView)

        AVar.putVar {cachedScale, glyphs} state.cachedTracks
        pure glyphs

  -- fork a new renderFiber

  let (Pair offset _) = pixelsView uiScale csView

      relativeUI = browser.relativeUI (unwrap csView)
      fixedUI = browser.fixedUI

      ui ::  { tracks     :: List (Array RenderedTrack)
             , relativeUI :: Drawing
             , fixedUI :: Drawing }
      ui = { tracks: tracks'
           , relativeUI, fixedUI }

  renderFiber <- forkAff
                 $ renderBrowser (wrap 3.0) canvas offset ui

  putVar renderFiber state.renderFiber
-}

renderLoop' :: CoordSys _ _
           -> { tracks     :: Pair BigInt -> { gwas :: Rendered (GWASFeature ())
                                             , annotations :: Rendered (Annot (score :: Number)) }
              , relativeUI :: Pair BigInt -> Drawing
              , fixedUI :: Drawing }
           -> BrowserCanvas
           -> UIState _
           -> Aff _ Unit
renderLoop' cSys browser canvas state = forever do

  _ <- takeVar state.viewReady

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

  let uiScale = trackViewScale canvas csView

  liftEff $ log $ "view scale is: " <> showViewScale uiScale

  {-

  -- if the view scale is unchanged, use the cached glyphs
  tracks' <- do
    cache <- AVar.tryTakeVar state.cachedTracks
    case cache of
      Just ct
        | ct.cachedScale == uiScale -> do
            AVar.putVar ct state.cachedTracks
            pure ct.glyphs
      _ -> do
        let cachedScale = uiScale
            glyphs = browser.tracks (unwrap csView)

        AVar.putVar {cachedScale, glyphs} state.cachedTracks
        pure glyphs

  -}

  let tracks' = browser.tracks (unwrap csView)

  -- fork a new renderFiber

  let (Pair offset _) = pixelsView uiScale csView

      relativeUI = browser.relativeUI (unwrap csView)
      fixedUI = browser.fixedUI

      ui ::  { tracks     :: _
             , relativeUI :: Drawing
             , fixedUI :: Drawing }
      ui = { tracks: tracks'
           , relativeUI, fixedUI }

  _ <- AVar.tryTakeVar state.lastOverlaps
                    -- offset the click by the current canvas translation
  AVar.putVar (\n r -> let r' = {x: r.x + offset, y: r.y }
                       in { gwas: tracks'.gwas.overlaps n r' }) state.lastOverlaps

  renderFiber <- forkAff
                 $ renderBrowser'' (wrap 2.0) canvas offset ui

  putVar renderFiber state.renderFiber

printSNPInfo :: forall r. Array (GWASFeature r) -> Eff _ Unit
printSNPInfo fs = do
  let n = length fs :: Int
      m = 5

      showSnp f = do
        log $ f.feature.name <> " - "
           <> unwrap f.feature.chrId <> " @ "
           <> show (map show f.position)

  log $ "showing " <> show n <> " clicked glyphs"
  for_ (Array.take m fs) showSnp

snpInfoHTML :: forall r. GWASFeature r -> String
snpInfoHTML { position, feature } =
    "
SNP: "   <> feature.name <> "
"
 <> "
Chr: "   <> show feature.chrId <> "
"
 <> "
Pos: "   <> show (Pair.fst position) <> "
"
 <> "
Score: " <> show feature.score <> "
"

foreign import setInfoBoxVisibility :: forall e. String -> Eff e Unit
foreign import setInfoBoxContents :: forall e. String -> Eff e Unit

foreign import initDebugDiv :: forall e. Number -> Eff e Unit

foreign import setDebugDivVisibility :: forall e.
                                        String -> Eff e Unit

foreign import setDebugDivPoint :: forall e.
                                   Point -> Eff e Unit

-- TODO configure UI widths
runBrowser :: Conf -> BrowserCanvas -> Eff _ _
runBrowser config bc = launchAff $ do

  let clickRadius = 1.0

  liftEff $ initDebugDiv clickRadius

  let browserDimensions = (unwrap bc).dimensions

  {width} <- liftEff $ windowInnerSize

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

  let cSys :: CoordSys ChrId BigInt
      cSys = coordSys mouseChrSizes

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

    let annotations = zipMapsWith
                       (bumpFeatures (to (\s -> s.feature.score + 0.02)) (SProxy :: SProxy "score")
                         (Bp 1000000.0))
                       <$> gwas <*> rawAnnotations

    pure { genes, gwas, annotations }

  let initialView :: CoordSysView
      initialView = wrap $ Pair zero (cSys^._TotalSize)

  viewCmd <- makeEmptyVar
  liftEff $ do
    btnScroll 0.05 viewCmd
    btnZoom   0.10 viewCmd

    let dragCB {x,y} =
          when (Math.abs x >= one)
          $ queueCmd viewCmd $ ScrollView $ (-x) / (trackDimensions bc).width
    dragScroll bc dragCB

    let scrollZoomScale = 0.06
        wheelCB dY =
          queueCmd viewCmd $ ZoomView $ 1.0 + scrollZoomScale * dY
    wheelZoom bc wheelCB

  view <- makeVar initialView
  viewReady <- makeVar unit
  renderFiber <- makeEmptyVar
  cachedTracks <- AVar.makeEmptyVar
  lastOverlaps <- AVar.makeEmptyVar

  let initState :: UIState _
      initState = { view, viewCmd, viewReady, renderFiber, cachedTracks, lastOverlaps }

  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 = demoTracks vscale trackData

      padding = { horizontal: config.trackPadding.left
                , vertical: config.trackPadding.top }

      mainBrowser :: _
      mainBrowser = browser cSys
                     (trackDimensions bc) browserDimensions
                     (uiSlots bc) {legend, vscale}
                     { gwas: renderGWAS vscale
                     , annotations: renderAnnot vscale }
                     { gwas: fromMaybe mempty trackData.gwas
                     , annotations: fromMaybe mempty trackData.annotations }

      viewTimeout :: Milliseconds
      viewTimeout = wrap 100.0

  liftEff do
    setWindow "mainBrowser" mainBrowser
    setWindow "debugView" (debugView initState)

    let glyphClick :: _
        glyphClick p = launchAff_ do
          AVar.tryReadVar lastOverlaps >>= case _ of
             Nothing -> liftEff do
               log "clicked no glyphs"
               setInfoBoxVisibility "hidden"

             Just gs -> liftEff do
               let clicked = (gs clickRadius p).gwas
               printSNPInfo clicked
               case Array.head clicked of
                 Nothing -> setInfoBoxVisibility "hidden"
                 Just g  -> do
                   setInfoBoxContents $ snpInfoHTML g
                   setInfoBoxVisibility "visible"

    ovCtx <- Canvas.getContext2D (unwrap bc).overlay

    let overlayDebug :: _
        overlayDebug p = do
          let pad = (unwrap bc).trackPadding
              dim = (unwrap bc).dimensions

          setDebugDivVisibility "visible"
          setDebugDivPoint p

    browserOnClick bc
      { overlay: \_ -> pure unit
      , track:   glyphClick }

  _ <- forkAff $ uiViewUpdate cSys viewTimeout initState

  _ <- forkAff $ renderLoop' cSys mainBrowser bc initState

  pure unit

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

type Conf = { browserHeight :: Number
            , trackPadding :: TrackPadding
            , score :: { min :: Number, max :: Number, sig :: Number }
            , urls :: DataURLs
            }

foreign import setWindow :: forall e a. String -> a -> Eff e Unit

initBrowser :: Foreign -> Eff _ _
initBrowser rawConfig = do

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

  case read rawConfig :: Either MultipleErrors Conf of
    Left errs -> traverse_ (log <<< renderForeignError) errs
    Right c   -> do
      case el' of
        Nothing -> log "Could not find element '#browser'"
        Just el -> do

          {width} <- windowInnerSize
          let dimensions = { width, height: c.browserHeight }
          bc <- browserCanvas dimensions c.trackPadding el

          debugBrowserCanvas "debugBC" bc

          log $ unsafeStringify c
          void $ runBrowser c bc

-- 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
       putVar (sofar <> m) av
       delay (wrap 20.0)
       pure Nothing

type TrackVar a = AVar (Map ChrId (Array a))
type TrackProducer eff a = Producer (Map ChrId (Array a)) (Aff eff) Unit

-- Feels like this one takes care of a bit too much...
fetchLoop1 :: forall a.
              (Maybe (Aff _ (TrackProducer _ a)))
           -> Aff _ (TrackVar a)
fetchLoop1 Nothing = AVar.makeEmptyVar
fetchLoop1 (Just startProd) = do
  prod <- startProd
  avar <- makeVar mempty
  _ <- forkAff $ runProcess $ prod `connect` chunkConsumer avar
  pure avar

-- | 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
  gwas <-        fetchLoop1 $ produceGWAS   cs <$> urls.gwas
  annotations <- fetchLoop1 $ produceAnnots cs <$> urls.annotations
  genes <-       fetchLoop1 $ produceGenes  cs <$> urls.genes
  pure { gwas, genes, annotations }


Prevent card title flickering in draftboard

{-
Copyright 2016 SlamData, Inc.

Licensed under the Apache License, Version 2.0 (the "License");
you may not use this file except in compliance with the License.
You may obtain a copy of the License at

    http://www.apache.org/licenses/LICENSE-2.0

Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS,
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
See the License for the specific language governing permissions and
limitations under the License.
-}

module SlamData.Workspace.Card.Draftboard.Component.State
  ( State
  , StateP
  , SplitOpts
  , SplitLocation
  , ResizeLocation
  , MoveLocation(..)
  , initialState
  , initialRect
  , modelFromState
  , stateFromModel
  , childSlots
  , recalc
  , updateRect
  , updateLayout
  ) where

import SlamData.Prelude
import Data.Function (on)
import Data.List as List
import Data.Map as Map
import Data.Ordering (invert)
import Data.Rational (Rational)
import DOM.HTML.Types (HTMLElement)

import Halogen as H

import SlamData.Monad (Slam)
import SlamData.Workspace.Card.Draftboard.Component.Query (QueryC)
import SlamData.Workspace.Card.Draftboard.Layout (SplitBias, Rect, Edge, Cell)
import SlamData.Workspace.Card.Draftboard.Layout as Layout
import SlamData.Workspace.Card.Draftboard.Model (Model)
import SlamData.Workspace.Card.Draftboard.Orientation (Orientation)
import SlamData.Workspace.Card.Draftboard.Pane (Pane(..), Cursor, walkWithCursor)
import SlamData.Workspace.Deck.Component.Nested.Query as DNQ
import SlamData.Workspace.Deck.Component.Nested.State as DNS
import SlamData.Workspace.Deck.DeckId (DeckId)

type StateP = H.ParentState State DNS.State QueryC DNQ.QueryP Slam DeckId

data MoveLocation
  = Floating Number Number
  | Move (Cell (Maybe DeckId) Number)
  | Group (Cell (Maybe DeckId) Number) Orientation SplitBias

type State =
  { layout ∷ Pane (Maybe DeckId)
  , splitOpts ∷ Maybe SplitOpts
  , splitLocation ∷ Maybe SplitLocation
  , resizeLocation ∷ Maybe ResizeLocation
  , moveLocation ∷ Maybe MoveLocation
  , root ∷ Maybe HTMLElement
  , rootRect ∷ Rect Number
  , cellLayout ∷ List.List (Cell (Maybe DeckId) Number)
  , edgeLayout ∷ List.List (Edge Number)
  , cursors ∷ Map.Map DeckId Cursor
  , inserting ∷ Boolean
  }

type SplitOpts =
  { orientation ∷ Orientation
  , bias ∷ SplitBias
  , root ∷ Boolean
  }

type SplitLocation =
  { orientation ∷ Orientation
  , bias ∷ SplitBias
  , cursor ∷ Cursor
  , ratio ∷ Rational
  , valid ∷ Boolean
  , x ∷ Number
  , y ∷ Number
  , z ∷ Number
  }

type ResizeLocation =
  { edge ∷ Edge Number
  , ratio ∷ Rational
  , valid ∷ Boolean
  , collapse ∷ Maybe SplitBias
  , initial ∷ Number
  , offset ∷ Number
  }

initialState ∷ State
initialState =
  { layout: Cell Nothing
  , splitOpts: Nothing
  , splitLocation: Nothing
  , resizeLocation: Nothing
  , moveLocation: Nothing
  , root: Nothing
  , rootRect: initialRect
  , cellLayout: mempty
  , edgeLayout: mempty
  , cursors: mempty
  , inserting: false
  }

initialRect ∷ Rect Number
initialRect =
  { top: 0.0
  , left: 0.0
  , width: 0.0
  , height: 0.0
  }

modelFromState ∷ State → Model
modelFromState { layout } = { layout }

stateFromModel ∷ Model → State
stateFromModel { layout } = initialState { layout = layout }

childSlots ∷ State → List.List DeckId
childSlots = Map.keys ∘ _.cursors

recalc
  ∷ Rect Number
  → Pane (Maybe DeckId)
  → State
  → State
recalc rect layout = _
  { rootRect = rect
  , layout = layout
  , cellLayout = List.sortBy (icompare `on` _.value) (Layout.absoluteCells rect (Layout.cells layout))
  , edgeLayout = Layout.absoluteEdges rect (Layout.edges layout)
  , cursors = walkWithCursor goCursors mempty layout
  }
  where
  goCursors c m (Cell (Just deckId)) = Map.insert deckId c m
  goCursors _ m _ = m

  icompare a b = invert (compare a b)

updateRect ∷ Rect Number → State → State
updateRect rect st = recalc rect st.layout st

updateLayout ∷ Pane (Maybe DeckId) → State → State
updateLayout layout st = recalc st.rootRect layout st

{-
Copyright 2016 SlamData, Inc.

Licensed under the Apache License, Version 2.0 (the "License");
you may not use this file except in compliance with the License.
You may obtain a copy of the License at

    http://www.apache.org/licenses/LICENSE-2.0

Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS,
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
See the License for the specific language governing permissions and
limitations under the License.
-}

module SlamData.Workspace.Card.Draftboard.Component.State
  ( State
  , StateP
  , SplitOpts
  , SplitLocation
  , ResizeLocation
  , MoveLocation(..)
  , initialState
  , initialRect
  , modelFromState
  , stateFromModel
  , childSlots
  , recalc
  , updateRect
  , updateLayout
  ) where

import SlamData.Prelude
import Data.List as List
import Data.Map as Map
import Data.Rational (Rational)
import DOM.HTML.Types (HTMLElement)

import Halogen as H

import SlamData.Monad (Slam)
import SlamData.Workspace.Card.Draftboard.Component.Query (QueryC)
import SlamData.Workspace.Card.Draftboard.Layout (SplitBias, Rect, Edge, Cell)
import SlamData.Workspace.Card.Draftboard.Layout as Layout
import SlamData.Workspace.Card.Draftboard.Model (Model)
import SlamData.Workspace.Card.Draftboard.Orientation (Orientation)
import SlamData.Workspace.Card.Draftboard.Pane (Pane(..), Cursor, walkWithCursor)
import SlamData.Workspace.Deck.Component.Nested.Query as DNQ
import SlamData.Workspace.Deck.Component.Nested.State as DNS
import SlamData.Workspace.Deck.DeckId (DeckId)

type StateP = H.ParentState State DNS.State QueryC DNQ.QueryP Slam DeckId

data MoveLocation
  = Floating Number Number
  | Move (Cell (Maybe DeckId) Number)
  | Group (Cell (Maybe DeckId) Number) Orientation SplitBias

type State =
  { layout ∷ Pane (Maybe DeckId)
  , splitOpts ∷ Maybe SplitOpts
  , splitLocation ∷ Maybe SplitLocation
  , resizeLocation ∷ Maybe ResizeLocation
  , moveLocation ∷ Maybe MoveLocation
  , root ∷ Maybe HTMLElement
  , rootRect ∷ Rect Number
  , cellLayout ∷ List.List (Cell (Maybe DeckId) Number)
  , edgeLayout ∷ List.List (Edge Number)
  , cursors ∷ Map.Map DeckId Cursor
  , inserting ∷ Boolean
  }

type SplitOpts =
  { orientation ∷ Orientation
  , bias ∷ SplitBias
  , root ∷ Boolean
  }

type SplitLocation =
  { orientation ∷ Orientation
  , bias ∷ SplitBias
  , cursor ∷ Cursor
  , ratio ∷ Rational
  , valid ∷ Boolean
  , x ∷ Number
  , y ∷ Number
  , z ∷ Number
  }

type ResizeLocation =
  { edge ∷ Edge Number
  , ratio ∷ Rational
  , valid ∷ Boolean
  , collapse ∷ Maybe SplitBias
  , initial ∷ Number
  , offset ∷ Number
  }

initialState ∷ State
initialState =
  { layout: Cell Nothing
  , splitOpts: Nothing
  , splitLocation: Nothing
  , resizeLocation: Nothing
  , moveLocation: Nothing
  , root: Nothing
  , rootRect: initialRect
  , cellLayout: mempty
  , edgeLayout: mempty
  , cursors: mempty
  , inserting: false
  }

initialRect ∷ Rect Number
initialRect =
  { top: 0.0
  , left: 0.0
  , width: 0.0
  , height: 0.0
  }

modelFromState ∷ State → Model
modelFromState { layout } = { layout }

stateFromModel ∷ Model → State
stateFromModel { layout } = initialState { layout = layout }

childSlots ∷ State → List.List DeckId
childSlots = Map.keys ∘ _.cursors

recalc
  ∷ Rect Number
  → Pane (Maybe DeckId)
  → State
  → State
recalc rect layout = _
  { rootRect = rect
  , layout = layout
  , cellLayout = Layout.absoluteCells rect (Layout.cells layout)
  , edgeLayout = Layout.absoluteEdges rect (Layout.edges layout)
  , cursors = walkWithCursor goCursors mempty layout
  }
  where
  goCursors c m (Cell (Just deckId)) = Map.insert deckId c m
  goCursors _ m _ = m

updateRect ∷ Rect Number → State → State
updateRect rect st = recalc rect st.layout st

updateLayout ∷ Pane (Maybe DeckId) → State → State
updateLayout layout st = recalc st.rootRect layout st


Better `fix` definition

Better `fix` definition

Resolves #48

module Control.Lazy where

import Data.Unit (Unit, unit)

-- | The `Lazy` class represents types which allow evaluation of values
-- | to be _deferred_.
-- |
-- | Usually, this means that a type contains a function arrow which can
-- | be used to delay evaluation.
class Lazy l where
  defer :: (Unit -> l) -> l

instance lazyFn :: Lazy (a -> b) where
  defer f = \x -> f unit x

instance lazyUnit :: Lazy Unit where
  defer _ = unit

-- | `fix` defines a value as the fixed point of a function.
-- |
-- | The `Lazy` instance allows us to generate the result lazily.
fix :: forall l. Lazy l => (l -> l) -> l
fix f = go
  where
    go = defer \_ -> f go

module Control.Lazy where

import Data.Unit (Unit, unit)

-- | The `Lazy` class represents types which allow evaluation of values
-- | to be _deferred_.
-- |
-- | Usually, this means that a type contains a function arrow which can
-- | be used to delay evaluation.
class Lazy l where
  defer :: (Unit -> l) -> l

instance lazyFn :: Lazy (a -> b) where
  defer f = \x -> f unit x

instance lazyUnit :: Lazy Unit where
  defer _ = unit

-- | `fix` defines a value as the fixed point of a function.
-- |
-- | The `Lazy` instance allows us to generate the result lazily.
fix :: forall l. Lazy l => (l -> l) -> l
fix f = defer (\_ -> f (fix f))


Corrections to emulate disabling and reenabling of display, and timer resets every gpu mode switch

module Gpu
  ( resetScreen
  , gpuStep
  , gpuRd8
  , gpuWr8
  , wrVRam
  , cleanGpu
  , module Graphics.Canvas
  ) where

import Prelude
import Control.Bind
import Control.Monad
import Control.Monad.Eff
import Control.Monad.Eff.Console
import Data.Int
import Data.Int.Bits
import Data.Foldable
import Data.Array as A
import Data.Sequence as S
import Data.Maybe
import Graphics.Canvas

import Types
import Utils
import Debug

foreign import setScreen :: forall e. Array I8 -> Context2D
                       -> Eff (canvas :: Canvas | e) Unit

modeDuration :: GpuMode -> Int
modeDuration = case _ of
  HBlank -> 51
  VBlank -> 114
  VramScan -> 43
  OamScan -> 20

cleanTile :: Tile
cleanTile = Tile $ S.fromFoldable $ A.replicate 64 0

getCanvas :: forall e. Eff (canvas :: Canvas | e) Context2D
getCanvas = do
  Just canvasElem <- getCanvasElementById "screen"
  getContext2D canvasElem

resetScreen :: forall e. Eff (canvas :: Canvas | e) Unit
resetScreen = setScreen arr =<< getCanvas
 where
  arr = A.replicate (160*144*4) 255

cleanGpu :: Gpu
cleanGpu =
  { mTimer : modeDuration VBlank - 16
  , dispOn : true
  , bgOn : true
  , bgMap1 : false
  , bgSet1 : true
  , scrBuf : S.empty
  , vblFinish : true
  , currLine : pixHeight + 10 - 1
  , currPos : 0
  , yScroll : 0
  , xScroll : 0
  , vblIntrr : false
  , palette : S.fromFoldable $ A.replicate 4 cleanColor
  , mode : VBlank
  , tiles : S.fromFoldable $ A.replicate 384 cleanTile
  , regs : S.fromFoldable $ A.replicate 0x40 0
  , vram : S.fromFoldable $ A.replicate 8192 0
  , oam  : S.fromFoldable $ A.replicate 160 0
  }

cleanColor :: Color
cleanColor = {a:0,r:0,g:0,b:0}

--NOTE consider doing nothing if dispOn is false
gpuStep :: forall e. I8 -> Gpu -> Eff (canvas :: Canvas | e) Gpu
gpuStep _ gpu@{dispOn = false} = return gpu

gpuStep mReg gpu@{mTimer,mode,currLine,currPos,scrBuf,vblFinish} =
  map hblCurrLineEarlyReset gpu'
 where
  mTimer' = mTimer + mReg

  gpu' = if mTimer' < modeDuration mode
    then return gpu { mTimer = mTimer' }
    else case mode of
      --TODO set True least significant interrupt flags bit
      HBlank ->
        let doOnLastLine gp = if currLine /= pixHeight - 1 then return gp
              else do
                setScreen (seqToArray scrBuf) =<< getCanvas
                return $ gp { scrBuf = S.empty :: S.Seq I8 --psc forces me
                            , mode = VBlank
                            , vblIntrr = true
                            }
         in doOnLastLine $ gpu { mTimer = mTimer' - modeDuration HBlank
                             , currLine = currLine + 1
                             , currPos = currPos + bytesWidth
                             , mode = OamScan
                             }

      VBlank -> do
        let setOnLastLine =
              if vblFinish
                -- 10 increments after last line of 143
                then _ { vblFinish = false
                       , currLine = 0
                       , currPos = 0
                       , mode = OamScan
                       }
                else id
        return $ setOnLastLine gpu { mTimer = mTimer' - modeDuration VBlank , currLine = currLine + 1 }
      OamScan -> return gpu { mTimer = mTimer' - modeDuration OamScan, mode = VramScan }
      VramScan ->
        let renderOrNot = if gpu.dispOn && gpu.bgOn then renderLine else id
        in return $ renderOrNot gpu { mTimer = mTimer' - modeDuration VramScan, mode = HBlank }

hblCurrLineEarlyReset :: Gpu -> Gpu
hblCurrLineEarlyReset gpu@{mTimer = mTimer', currLine, mode} =
  if mode == VBlank && mTimer' >= 4 && currLine == pixHeight + 10 - 1
    then gpu { currLine = 0, vblFinish = true }
    else gpu

--Change condition of renderOrNot once object rendering is added
--And perhaps rename the current renderLine to renderBG and have renderLine
--be what calls renderBG and renderFG
renderLine :: Gpu -> Gpu
renderLine gpu = gpu { scrBuf = foldRes.scrBuf }
 where
  foldRes = foldl updateCanvas
                  { scrBuf:gpu.scrBuf, tho:tileHorizOff
                  , mho:memHorizOff, tix:tileIx }
                  (0 A... (pixWidth-1))
  tileIx = getTileIx gpu tileIxAddr
  tileIxAddr = bgMapOff + memVertOff + memHorizOff
  --map #0 9800-9BFF, map #1 9C00-9FFF
  bgMapOff = if gpu.bgMap1 then 0x1C00 else 0x1800
  --Each tile's height is 3 bits long,
  --and each map row of tiles is 5 bits (32 tiles wide)
  memVertOff = (pixelVertOff `zshr` 3) `shl` 5
  --The map's height is 256 pixels long
  pixelVertOff = 255 .&. (gpu.currLine + gpu.yScroll)
  -- the map is 32 tiles wide
  memHorizOff = 31 .&. (gpu.xScroll `zshr` 3)
  --tile height is 8 pixels / 3 bits long
  tileVertOff = 7 .&. (gpu.currLine + gpu.yScroll)
  --tile width is 8 pixels / 3 bits wide
  tileHorizOff = 7 .&. gpu.xScroll

  updateCanvas {scrBuf,tho,mho,tix} i =
    {scrBuf:scrBuf',tho:tho',mho:mho',tix:tix'}
   where
    --Would've rewritten with a single 'if', if PureScript had supported
    --pattern matching in where clause
    tix' = if lastTileRowPixel
      then getTileIx gpu $ bgMapOff + memVertOff + mho'
      else tix
    tho' = if lastTileRowPixel
      then 0
      else tho + 1
    mho' = if lastTileRowPixel
      then 31 .&. (1 + mho)
      else mho
    lastTileRowPixel = tho == 7

    {--cnvsOff' = cnvsOff + 4--}
    scrBuf' = foldl S.snoc scrBuf [color.a,color.r,color.g,color.b]

    --NOTE trace error, if invalid color ix
    color = getFromSeq cleanColor colorIx gpu.palette
    colorIx = getTilePixel tho tileVertOff $ getTile tileIx gpu.tiles

--NOTE: Is it necessary to check tix < 128? doesn't map tile #1 always
--use set #1? (which is from -128 to 127)
getTileIx :: Gpu -> I16 -> I8
getTileIx { vram, bgSet1 } addr =
  if (not bgSet1) then tix + 256 else tix
 where tix = vram !! addr

--TODO add a generic register sequence
gpuRd8 :: I16 -> Gpu -> I8
gpuRd8 addr gpu = case addr of
  0xFF40 -> getCtrlFlags gpu
  0xFF42 -> gpu.yScroll
  0xFF43 -> gpu.xScroll
  0xFF44 -> gpu.currLine
  0xFF47 -> -1 --NOTE log this, if needed implement getPalette Seq{argb}->I8
  otherwise -> gpu.regs !! addr - 0xFF40

gpuWr8 :: I8 -> I16 -> Gpu -> Gpu
gpuWr8 i8 addr gpu = setRegs $ case addr of
  0xFF40 -> setCtrlFlags i8 gpu
  0xFF42 -> gpu { yScroll = i8 }
  0xFF43 -> gpu { xScroll = i8 }
  0xFF44 -> gpu { currLine = i8 }
  0xFF47 -> setPalette
  otherwise -> gpu
 where
  setRegs = _ { regs = S.replace i8 (addr - 0xFF40) gpu.regs }
  setPalette = gpu { palette = foldl stPl S.empty (0 A... 3) }
  --Every color is 2 bits wide
  --NOTE should this be reversed?
  stPl plt i = case (i8 `zshr` (i*2)) .&. 3 of
    0 -> S.snoc plt {a:255,r:255,g:255,b:255}
    1 -> S.snoc plt {a:192,r:192,g:192,b:255}
    2 -> S.snoc plt {a:96 ,r:96 ,g:96 ,b:255}
    3 -> S.snoc plt {a:0  ,r:0  ,g:0  ,b:255}
    otherwise -> plt -- NOTE log this

getCtrlFlags :: Gpu -> I8
getCtrlFlags gpu =  cf gpu.bgOn   0x01
                .|. cf gpu.bgMap1 0x08
                .|. cf gpu.bgSet1 0x10
                .|. cf gpu.dispOn 0x80
 where cf bool flag = if bool then flag else 0x00

setCtrlFlags :: I8 -> Gpu -> Gpu
setCtrlFlags ctrlFlags gpu = enableDisableOrNot gpu.dispOn dispOn' $
  gpu
    { bgOn   = isFlagSet 0x01
    , bgMap1 = isFlagSet 0x08
    , bgSet1 = isFlagSet 0x10
    , dispOn = dispOn'
    }
 where
  isFlagSet flag = (flag .&. ctrlFlags) /= 0
  dispOn' = isFlagSet 0x80

  enableDisableOrNot true false = disableGpu
  enableDisableOrNot false true = enableGpu
  enableDisableOrNot _ _ = id

disableGpu :: Gpu -> Gpu
disableGpu gpu = gpu
  { mTimer = 0
  , currLine = 0
  , mode = HBlank
  , vblFinish = false
  , dispOn = false
  }

enableGpu :: Gpu -> Gpu
enableGpu gpu = gpu
  { mTimer = 0
  , mode = OamScan
  , dispOn = true
  }

wrVRam :: I8 -> I16 -> Gpu -> Gpu
wrVRam i8 addr gpu@{vram,tiles} = gpu { vram = vram', tiles = tiles' }
 where
  vram' = S.replace i8 addr' vram
  tiles' = vramWriteToTiles addr' vram' tiles
  addr' = 0x1FFF .&. addr

--------------TILE--------    R O W
-- b    b b b b    b b b b    b b b b
--Each tile is 8 * 8 pixels * 2 bits per pixel = 16 bytes
--Each row is 8 pixels * 2 bits per pixel = 16 bits = 2 bytes

--Total of 384 TILES from 0x8000 to 0x97FF

--NOTE:potential problem if we write from 0x9800 to 0x9FFF
--which is not the tiles. It is the 2 tile maps.
vramWriteToTiles :: I16 -> S.Seq I8 -> Tiles -> Tiles
vramWriteToTiles addr vram tiles = setTile tile' tileIx tiles
 where
  tile' = foldr updateColor tile (0 A... 7)
  tile = getTile tileIx tiles
  -- Doesn't matter if a byte of LOWER color bit of 8 pixels or HIGHER have
  -- changed, I have to update those 8 pixels colors just the same.
  addr' = addr - (addr .&. 1)
  tileIx = (addr `zshr` 4) .&. 511
  y = (addr `zshr` 1) .&. 7

  updateColor :: Int -> Tile -> Tile
  updateColor x t = setTilePixel c x y t
   where
    shiftMask = 1 `shl` (7-x)
    highColors = vram !! addr + 1
    lowColors = vram !! addr
    c =  (if (shiftMask .&. highColors) /= 0 then 2 else 0)
     .|. (if (shiftMask .&. lowColors) /= 0 then 1 else 0)

--NOTE Add a check that tile index is valid (0<=i<384)

setTile :: Tile -> Int -> Tiles -> Tiles
setTile t i ts = S.replace t i ts

--NOTES  replace fromMaybe with something that will log invalid indices
getTile :: Int -> Tiles -> Tile
getTile ix = getFromSeq cleanTile ix

getTilePixel :: Int -> Int -> Tile -> Int
getTilePixel x y (Tile s) = s !! (y*8 + x)

--NOTE Add a check that indices and color are valid (0<=i<8) (0<=c<4)
setTilePixel :: Int -> Int -> Int -> Tile -> Tile
setTilePixel c x y (Tile s) = Tile $ S.replace c (y*8 + x) s

pixWidth :: Int
pixWidth = 160

bytesWidth :: Int
bytesWidth = 160*4

pixHeight :: Int
pixHeight = 144

module Gpu
  ( resetScreen
  , gpuStep
  , gpuRd8
  , gpuWr8
  , wrVRam
  , cleanGpu
  , module Graphics.Canvas
  ) where

import Prelude
import Control.Bind
import Control.Monad
import Control.Monad.Eff
import Control.Monad.Eff.Console
import Data.Int
import Data.Int.Bits
import Data.Foldable
import Data.Array as A
import Data.Sequence as S
import Data.Maybe
import Graphics.Canvas

import Types
import Utils
import Debug

foreign import setScreen :: forall e. Array I8 -> Context2D
                       -> Eff (canvas :: Canvas | e) Unit

modeDuration :: GpuMode -> Int
modeDuration = case _ of
  HBlank -> 51
  VBlank -> 114
  VramScan -> 43
  OamScan -> 20

cleanTile :: Tile
cleanTile = Tile $ S.fromFoldable $ A.replicate 64 0

getCanvas :: forall e. Eff (canvas :: Canvas | e) Context2D
getCanvas = do
  Just canvasElem <- getCanvasElementById "screen"
  getContext2D canvasElem

resetScreen :: forall e. Eff (canvas :: Canvas | e) Unit
resetScreen = setScreen arr =<< getCanvas
 where
  arr = A.replicate (160*144*4) 255

cleanGpu :: Gpu
cleanGpu =
  { mTimer : modeDuration VBlank - 16
  , dispOn : true
  , bgOn : true
  , bgMap1 : false
  , bgSet1 : true
  , scrBuf : S.empty
  , vblFinish : true
  , currLine : pixHeight + 10 - 1
  , currPos : 0
  , yScroll : 0
  , xScroll : 0
  , vblIntrr : false
  , palette : S.fromFoldable $ A.replicate 4 cleanColor
  , mode : VBlank
  , tiles : S.fromFoldable $ A.replicate 384 cleanTile
  , regs : S.fromFoldable $ A.replicate 0x40 0
  , vram : S.fromFoldable $ A.replicate 8192 0
  , oam  : S.fromFoldable $ A.replicate 160 0
  }

cleanColor :: Color
cleanColor = {a:0,r:0,g:0,b:0}

getCtrlFlags :: Gpu -> I8
getCtrlFlags gpu =  cf gpu.bgOn   0x01
                .|. cf gpu.bgMap1 0x08
                .|. cf gpu.bgSet1 0x10
                .|. cf gpu.dispOn 0x80
 where cf bool flag = if bool then flag else 0x00

gpuStep :: forall e. I8 -> Gpu -> Eff (canvas :: Canvas | e) Gpu
gpuStep mReg gpu@{mTimer,mode,currLine,currPos,scrBuf} = gpu'
 where
  mTimer' = mTimer + mReg

  gpu' = if mTimer' < modeDuration mode
    then return gpu { mTimer = mTimer' }
    else case mode of
      --TODO set True least significant interrupt flags bit
      HBlank ->
        let doOnLastLine gp = if currLine /= pixHeight - 1 then return gp
              else do
                setScreen (seqToArray scrBuf) =<< getCanvas
                return $ gp { scrBuf = S.empty :: S.Seq I8 --psc forces me
                            , mode = VBlank
                            , vblIntrr = true
                            }
         in doOnLastLine gpu { mTimer = 0
                             , currLine = currLine + 1
                             , currPos = currPos + bytesWidth
                             , mode = OamScan
                             }

      VBlank -> do
        let setOnLastLine =
              if currLine == pixHeight + 10 - 1
                -- 10 increments after last line of 143
                then _ { mTimer = 0
                       , currLine = 0
                       , currPos = 0
                       , mode = OamScan
                       }
                else id
        return $ setOnLastLine gpu { mTimer = 0 , currLine = currLine + 1 }
      OamScan -> return gpu { mTimer = 0, mode = VramScan }
      VramScan -> return $ renderLine gpu { mTimer = 0, mode = HBlank }

renderLine :: Gpu -> Gpu
renderLine gpu = gpu { scrBuf = foldRes.scrBuf }
  {--canvas <- getCanvas--}
  {--setLine (seqToArray foldRes.cnvsLine) gpu.currLine canvas--}
 where
  foldRes = foldl updateCanvas
                  { scrBuf:gpu.scrBuf, tho:tileHorizOff
                  , mho:memHorizOff, tix:tileIx }
                  (0 A... (pixWidth-1))
  tileIx = getTileIx gpu tileIxAddr
  tileIxAddr = bgMapOff + memVertOff + memHorizOff
  --map #0 9800-9BFF, map #1 9C00-9FFF
  bgMapOff = if gpu.bgMap1 then 0x1C00 else 0x1800
  --Each tile's height is 3 bits long,
  --and each map row of tiles is 5 bits (32 tiles wide)
  memVertOff = (pixelVertOff `zshr` 3) `shl` 5
  --The map's height is 256 pixels long
  pixelVertOff = 255 .&. (gpu.currLine + gpu.yScroll)
  -- the map is 32 tiles wide
  memHorizOff = 31 .&. (gpu.xScroll `zshr` 3)
  --tile height is 8 pixels / 3 bits long
  tileVertOff = 7 .&. (gpu.currLine + gpu.yScroll)
  --tile width is 8 pixels / 3 bits wide
  tileHorizOff = 7 .&. gpu.xScroll

  updateCanvas {scrBuf,tho,mho,tix} i =
    {scrBuf:scrBuf',tho:tho',mho:mho',tix:tix'}
   where
    --Would've rewritten with a single 'if', if PureScript had supported
    --pattern matching in where clause
    tix' = if lastTileRowPixel
      then getTileIx gpu $ bgMapOff + memVertOff + mho'
      else tix
    tho' = if lastTileRowPixel
      then 0
      else tho + 1
    mho' = if lastTileRowPixel
      then 31 .&. (1 + mho)
      else mho
    lastTileRowPixel = tho == 7

    {--cnvsOff' = cnvsOff + 4--}
    scrBuf' = foldl S.snoc scrBuf [color.a,color.r,color.g,color.b]

    --NOTE trace error, if invalid color ix
    color = getFromSeq cleanColor colorIx gpu.palette
    colorIx = getTilePixel tho tileVertOff $ getTile tileIx gpu.tiles

--NOTE: Is it necessary to check tix < 128? doesn't map tile #1 always
--use set #1? (which is from -128 to 127)
getTileIx :: Gpu -> I16 -> I8
getTileIx { vram, bgSet1 } addr =
  if bgSet1 && tix < 128 then tix + 256 else tix
 where tix = vram !! addr

--TODO add a generic register sequence
gpuRd8 :: I16 -> Gpu -> I8
gpuRd8 addr gpu = case addr of
  0xFF40 -> getCtrlFlags gpu
  0xFF42 -> gpu.yScroll
  0xFF43 -> gpu.xScroll
  0xFF44 -> gpu.currLine
  0xFF47 -> -1 --NOTE log this, if needed implement getPalette Seq{argb}->I8
  otherwise -> gpu.regs !! addr - 0xFF40

gpuWr8 :: I8 -> I16 -> Gpu -> Gpu
gpuWr8 i8 addr gpu = setRegs $ case addr of
  0xFF40 -> setCtrlFlags
  0xFF42 -> gpu { yScroll = i8 }
  0xFF43 -> gpu { xScroll = i8 }
  0xFF44 -> gpu { currLine = i8 }
  0xFF47 -> setPalette
  otherwise -> gpu
 where
  --NOTE: Might be redundant, consider moving this to otherwise case
  --if it helps performance.
  setRegs = _ { regs = S.replace i8 (addr - 0xFF40) gpu.regs }

  setCtrlFlags = gpu
    { bgOn   = isFlagSet 0x01
    , bgMap1 = isFlagSet 0x08
    , bgSet1 = isFlagSet 0x10
    , dispOn = isFlagSet 0x80
    }
  isFlagSet flag = (flag .&. i8) /= 0

  setPalette = gpu { palette = foldl stPl S.empty (0 A... 3) }
  --Every color is 2 bits wide
  --NOTE should this be reversed?
  stPl plt i = case (i8 `zshr` (i*2)) .&. 3 of
    0 -> S.snoc plt {a:255,r:255,g:255,b:255}
    1 -> S.snoc plt {a:192,r:192,g:192,b:255}
    2 -> S.snoc plt {a:96 ,r:96 ,g:96 ,b:255}
    3 -> S.snoc plt {a:0  ,r:0  ,g:0  ,b:255}
    otherwise -> plt -- NOTE log this

--NOTE gpuwr8 should call this function depending on the addr prefix
wrVRam :: I8 -> I16 -> Gpu -> Gpu
wrVRam i8 addr gpu@{vram,tiles} = gpu { vram = vram', tiles = tiles' }
 where
  vram' = S.replace i8 addr' vram
  tiles' = vramWriteToTiles addr' vram' tiles
  addr' = 0x1FFF .&. addr

--------------TILE--------    R O W
-- b    b b b b    b b b b    b b b b
--Each tile is 8 * 8 pixels * 2 bits per pixel = 16 bytes
--Each row is 8 pixels * 2 bits per pixel = 16 bits = 2 bytes

--Total of 384 TILES from 0x8000 to 0x97FF

--NOTE:potential problem if we write from 0x9800 to 0x9FFF
--which is not the tiles. It is the 2 tile maps.
vramWriteToTiles :: I16 -> S.Seq I8 -> Tiles -> Tiles
vramWriteToTiles addr vram tiles = setTile tile' tileIx tiles
 where
  tile' = foldr updateColor tile (0 A... 7)
  tile = getTile tileIx tiles
  -- Doesn't matter if a byte of LOWER color bit of 8 pixels or HIGHER have
  -- changed, I have to update those 8 pixels colors just the same.
  addr' = addr - (addr .&. 1)
  tileIx = (addr `zshr` 4) .&. 511
  y = (addr `zshr` 1) .&. 7

  updateColor :: Int -> Tile -> Tile
  updateColor x t = setTilePixel c x y t
   where
    shiftMask = 1 `shl` (7-x)
    highColors = vram !! addr + 1
    lowColors = vram !! addr
    c =  (if (shiftMask .&. highColors) /= 0 then 2 else 0)
     .|. (if (shiftMask .&. lowColors) /= 0 then 1 else 0)

--NOTE Add a check that tile index is valid (0<=i<384)

setTile :: Tile -> Int -> Tiles -> Tiles
setTile t i ts = S.replace t i ts

--NOTES  replace fromMaybe with something that will log invalid indices
getTile :: Int -> Tiles -> Tile
getTile ix = getFromSeq cleanTile ix

getTilePixel :: Int -> Int -> Tile -> Int
getTilePixel x y (Tile s) = s !! (y*8 + x)

--NOTE Add a check that indices and color are valid (0<=i<8) (0<=c<4)
setTilePixel :: Int -> Int -> Int -> Tile -> Tile
setTilePixel c x y (Tile s) = Tile $ S.replace c (y*8 + x) s

pixWidth :: Int
pixWidth = 160

bytesWidth :: Int
bytesWidth = 160*4

pixHeight :: Int
pixHeight = 144


Uses bootstrap pager for navigation

Uses bootstrap pager for navigation

module Components.Lessons where

import Prelude
import React as R
import React.DOM as RD
import React.DOM.Props as RP
import Thermite as T
import Data.Lens (Lens, over, set, lens)

-- State

type LessonsState =
  { lessonNumber   :: Int
  }

lessonNumber :: forall a b r. Lens { lessonNumber :: a | r } { lessonNumber :: b | r } a b
lessonNumber = lens _.lessonNumber (_ { lessonNumber = _ })

-- Actions

data LessonsAction
  = First
  | Back
  | Next
  | Last

numberOfLessons :: Int
numberOfLessons = 2

first :: LessonsState -> LessonsState
first = set lessonNumber 0

next :: LessonsState -> LessonsState
next = over lessonNumber ((_ `mod` numberOfLessons) <<< add 1)

back :: LessonsState -> LessonsState
back = over lessonNumber ((_ `mod` numberOfLessons) <<< add (numberOfLessons - 1))

last :: LessonsState -> LessonsState
last = set lessonNumber (numberOfLessons - 1)

initialState :: LessonsState
initialState =
  { lessonNumber : 0 }

render :: forall props. T.Render LessonsState props LessonsAction
render dispatch _ _ _ =
  [ RD.ul [ RP.className "pager" ]
          [ RD.li' [ RD.a [ RP.href "#"
                          , RP.onClick \_ -> dispatch First
                          ]
                          [ RD.text "⇦ First" ]
                   ]
          , RD.li' [ RD.a [ RP.href "#"
                          , RP.onClick \_ -> dispatch Back
                          ]
                          [ RD.text "← Prev" ]
                   ]
          , RD.li' [ RD.a [ RP.href "#"
                          , RP.onClick \_ -> dispatch Next
                          ]
                          [ RD.text "→ Next" ]
                   ]
          , RD.li' [ RD.a [ RP.href "#"
                          , RP.onClick \_ -> dispatch Last
                          ]
                          [ RD.text "⇨ Last" ]
                   ]
          ]
  ]

performAction :: forall props eff. T.PerformAction eff LessonsState props LessonsAction
performAction First _ _ = void $ T.modifyState first
performAction Back  _ _ = void $ T.modifyState back
performAction Next  _ _ = void $ T.modifyState next
performAction Last  _ _ = void $ T.modifyState last
performAction _ _ _ = pure unit

spec :: forall props eff. T.Spec eff LessonsState props LessonsAction
spec = T.simpleSpec performAction render

module Components.Lessons where

import Prelude

import Data.Lens (Prism', Lens, _1, _2, _Left, _Right, only, over, set, prism, lens)
import React as R
import React.DOM as RD
import React.DOM.Props as RP
import Thermite as T

-- Thermite components define a type of states.
-- As a first example, we will create a component which uses a
-- state of type Int:

type LessonsState =
  { lessonNumber   :: Int
  }

lessonNumber :: forall a b r. Lens { lessonNumber :: a | r } { lessonNumber :: b | r } a b
lessonNumber = lens _.lessonNumber (_ { lessonNumber = _ })

-- Here is the action type associated with our component:

data LessonsAction
  = First
  | Back
  | Next
  | Last

numberOfLessons :: Int
numberOfLessons = 2

first :: LessonsState -> LessonsState
first = set lessonNumber 0

next :: LessonsState -> LessonsState
next = over lessonNumber ((_ `mod` numberOfLessons) <<< add 1)

back :: LessonsState -> LessonsState
back = over lessonNumber ((_ `mod` numberOfLessons) <<< add (numberOfLessons - 1))

last :: LessonsState -> LessonsState
last = set lessonNumber (numberOfLessons - 1)

-- A component needs an initial state:

initialState :: LessonsState
initialState =
  { lessonNumber : 0 }

-- The state is available to the render function:

render :: forall props. T.Render LessonsState props LessonsAction
render dispatch _ _ _ =
  [ RD.nav' [ RD.a [ RP.href "#"
                    , RP.onClick \_ -> dispatch First
                    ]
                    [ RD.text "⇦" ]
            , RD.a [ RP.href "#"
                    , RP.onClick \_ -> dispatch Back
                    ]
                    [ RD.text "←" ]
            , RD.a [ RP.href "#"
                    , RP.onClick \_ -> dispatch Next
                    ]
                    [ RD.text "→" ]
            , RD.a [ RP.href "#"
                    , RP.onClick \_ -> dispatch Last
                    ]
                    [ RD.text "⇨" ]
            ]
  ]

performAction :: forall props eff. T.PerformAction eff LessonsState props LessonsAction
performAction First _ _ = void $ T.modifyState first
performAction Back  _ _ = void $ T.modifyState back
performAction Next  _ _ = void $ T.modifyState next
performAction Last  _ _ = void $ T.modifyState last
performAction _ _ _ = pure unit

-- A more interesting component allows the user to modify its state.
-- We will see how Thermite supports this via "actions" in the next
-- lesson.

spec :: forall props eff. T.Spec eff LessonsState props LessonsAction
spec = T.simpleSpec performAction render


Chooser less-stupid names

Chooser less-stupid names

module AppState(AppState(..)) where

import Control.Monad.JQuery(JQuery(..))

data AppState = AppState
  { adderButton    :: JQuery
  , adderTable     :: JQuery
  , cardHolder     :: JQuery
  , cardNumSpinner :: JQuery
  , nameInput      :: JQuery
  , pickButton     :: JQuery
  , playerNums     :: [Number]
  }

module AppState(AppState(..)) where

import Control.Monad.JQuery(JQuery(..))

data AppState = AppState
  { adderBtn       :: JQuery
  , adderTable     :: JQuery
  , cardHolder     :: JQuery
  , cardNumSpinner :: JQuery
  , nameInput      :: JQuery
  , pickBtn        :: JQuery
  , playerNums     :: [Number]
  }


Using the new multiline strings!

Using the new multiline strings!

module JQueryUI where

import Control.Monad.Eff
import Control.Monad.JQuery(DOM(..), JQuery(..))

-- .accordion(config)
foreign import accordion
  """
  function accordion(config) {
    return function(ob) {
      return function() {
        ob.accordion(config);
      };
    };
  }
  """ :: forall eff r. { | r } -> JQuery -> Eff (dom :: DOM | eff) JQuery

-- .button()
foreign import button
  """
  function button(ob) {
    return function() {
      ob.button();
    };
  }
  """ :: forall eff. JQuery -> Eff (dom :: DOM | eff) JQuery

-- .buttonset()
foreign import buttonset
  """
  function buttonset(ob) {
    return function() {
      ob.buttonset();
    };
  }
  """ :: forall eff. JQuery -> Eff (dom :: DOM | eff) JQuery

-- .change()
foreign import change
  """
  function change(ob) {
    return function() {
      ob.change();
    };
  }
  """ :: forall eff. JQuery -> Eff (dom :: DOM | eff) JQuery

-- .click(f)
foreign import click
  """
  function click(f) {
    return function(ob) {
      return function() {
        ob.click(f);
      };
    };
  }
  """ :: forall eff a. (Unit -> Eff eff a) -> JQuery -> Eff (dom :: DOM | eff) JQuery

-- .each(f)
foreign import each
  """
  function each(f) {
    return function(ob) {
      return function() {
        ob.each(f);
      };
    };
  }
  """ :: forall eff a. (Unit -> Eff eff a) -> JQuery -> Eff (dom :: DOM | eff) JQuery

-- x[0].checked = !x[0].checked
foreign import flipChecked
  """
  function flipChecked(ob) {
    return function () {
      ob[0].checked = !ob[0].checked;
    };
  }
  """ :: forall eff. JQuery -> Eff (dom :: DOM | eff) Unit

-- .button('refresh')
foreign import refreshButton
  """
  function refreshButton(ob) {
    return function() {
      ob.button('refresh');
    };
  }
  """ :: forall eff. JQuery -> Eff (dom :: DOM | eff) Unit

-- .siblings(filterStr)
foreign import siblings
  """
  function siblings(filterStr) {
    return function(ob) {
      return function() {
        ob.siblings(filterStr);
      };
    };
  }
  """ :: forall eff. String -> JQuery -> Eff (dom :: DOM | eff) JQuery

-- .spinner()
foreign import spinner
  """
  function spinner(ob) {
    return function() {
      ob.spinner();
    };
  }
  """ :: forall eff. JQuery -> Eff (dom :: DOM | eff) JQuery

-- .tabs()
foreign import tabs
  """
  function tabs(ob) {
    return function() {
      ob.tabs();
    };
  }
  """ :: forall eff. JQuery -> Eff (dom :: DOM | eff) JQuery

-- .val(newVal)
foreign import val
  """
  function val(newVal) {
    return function(ob) {
      return function() {
        ob.val(newVal);
      };
    };
  }
  """ :: forall eff. String -> JQuery -> Eff (dom :: DOM | eff) JQuery

-- $(this)
foreign import selectThis
  """
  function selectThis() {
    return jQuery(this);
  }
  """ :: forall eff. Eff (dom :: DOM | eff) JQuery

module JQueryUI where

import Control.Monad.Eff
import Control.Monad.JQuery(DOM(..), JQuery(..))

-- .accordion(config)
foreign import accordion
  "function accordion(config) { \
  \  return function(ob) { \
  \    return function() { \
  \      ob.accordion(config); \
  \    }; \
  \  }; \
  \}" :: forall eff r. { | r } -> JQuery -> Eff (dom :: DOM | eff) JQuery

-- .button()
foreign import button
  "function button(ob) { \
  \  return function() { \
  \    ob.button(); \
  \  }; \
  \}" :: forall eff. JQuery -> Eff (dom :: DOM | eff) JQuery

-- .buttonset()
foreign import buttonset
  "function buttonset(ob) { \
  \  return function() { \
  \    ob.buttonset(); \
  \  }; \
  \}" :: forall eff. JQuery -> Eff (dom :: DOM | eff) JQuery

-- .change()
foreign import change
  "function change(ob) { \
  \  return function() { \
  \    ob.change(); \
  \  }; \
  \}" :: forall eff. JQuery -> Eff (dom :: DOM | eff) JQuery

-- .click(f)
foreign import click
  "function click(f) { \
  \  return function(ob) { \
  \    return function() { \
  \      ob.click(f); \
  \    }; \
  \  }; \
  \}" :: forall eff a. (Unit -> Eff eff a) -> JQuery -> Eff (dom :: DOM | eff) JQuery

-- .each(f)
foreign import each
  "function each(f) { \
  \  return function(ob) { \
  \    return function() { \
  \      ob.each(f); \
  \    }; \
  \  }; \
  \}" :: forall eff a. (Unit -> Eff eff a) -> JQuery -> Eff (dom :: DOM | eff) JQuery

-- x[0].checked = !x[0].checked
foreign import flipChecked
  "function flipChecked(ob) { \
  \  return function () { \
  \    ob[0].checked = !ob[0].checked; \
  \  }; \
  \}" :: forall eff. JQuery -> Eff (dom :: DOM | eff) Unit

-- .button('refresh')
foreign import refreshButton
  "function refreshButton(ob) { \
  \  return function() { \
  \    ob.button('refresh'); \
  \  }; \
  \}" :: forall eff. JQuery -> Eff (dom :: DOM | eff) Unit

-- .siblings(filterStr)
foreign import siblings
  "function siblings(filterStr) { \
  \  return function(ob) { \
  \    return function() { \
  \      ob.siblings(filterStr); \
  \    }; \
  \  }; \
  \}" :: forall eff. String -> JQuery -> Eff (dom :: DOM | eff) JQuery

-- .spinner()
foreign import spinner
  "function spinner(ob) { \
  \  return function() { \
  \    ob.spinner(); \
  \  }; \
  \}" :: forall eff. JQuery -> Eff (dom :: DOM | eff) JQuery

-- .tabs()
foreign import tabs
  "function tabs(ob) { \
  \  return function() { \
  \    ob.tabs(); \
  \  }; \
  \}" :: forall eff. JQuery -> Eff (dom :: DOM | eff) JQuery

-- .val(newVal)
foreign import val
  "function val(newVal) { \
  \  return function(ob) { \
  \    return function() { \
  \      ob.val(newVal); \
  \    }; \
  \  }; \
  \}" :: forall eff. String -> JQuery -> Eff (dom :: DOM | eff) JQuery

-- $(this)
foreign import selectThis
  "function selectThis() { \
  \  return jQuery(this); \
  \}" :: forall eff. Eff (dom :: DOM | eff) JQuery


Add comment to clarify source of HTMLHyperlinkElementUtils.

-- The `URLUtils` interface, referenced in https://www.w3.org/TR/html50/infrastructure.html#urlutils
--   now documented at https://html.spec.whatwg.org/multipage/links.html#htmlhyperlinkelementutils
module DOM.HTML.HTMLHyperlinkElementUtils where

import Prelude (Unit)

import Control.Monad.Eff (Eff)

import DOM (DOM)
import DOM.HTML.Types (HTMLHyperlinkElementUtils)

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

foreign import origin :: forall eff. HTMLHyperlinkElementUtils -> Eff (dom :: DOM | eff) String

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

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

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

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

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

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

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

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

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

-- https://html.spec.whatwg.org/multipage/links.html#htmlhyperlinkelementutils
module DOM.HTML.HTMLHyperlinkElementUtils where

import Prelude (Unit)

import Control.Monad.Eff (Eff)

import DOM (DOM)
import DOM.HTML.Types (HTMLHyperlinkElementUtils)

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

foreign import origin :: forall eff. HTMLHyperlinkElementUtils -> Eff (dom :: DOM | eff) String

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

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

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

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

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

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

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

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

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