Scaling exampe

Scaling exampe

module Main where

import Data.Traversable (for)

import Control.Monad.Eff
import Control.Monad.Eff.DOM
import Control.Monad.Eff.Ref

import Graphics.Canvas

import Debug.Trace

render :: forall eff. Number -> Context2D -> Eff (canvas :: Canvas | eff) Context2D
render count ctx = do
  setFillStyle "#FFFFFF" ctx

  fillPath ctx $ rect ctx
    { x: 0
    , y: 0
    , w: 600
    , h: 600
    }

  setFillStyle "#00FF00" ctx

  withContext ctx $ do
    let newScale = Math.sin (count * Math.pi / 4) + 1.5

    translate { translateX:  300, translateY:  300 } ctx
    rotate (count * Math.pi / 18) ctx
    scale { scaleX: newScale, scaleY: newScale } ctx
    translate { translateX: -100, translateY: -100 } ctx

    fillPath ctx $ rect ctx
      { x: 0
      , y: 0
      , w: 200
      , h: 200
      }

main = do
  canvas <- getCanvasElementById "canvas"
  ctx <- getContext2D canvas

  clickCount <- newRef 0

  render 0 ctx

  node <- querySelector "#canvas"
  for node $ addEventListener "click" $ do
    trace "Mouse clicked!"

    modifyRef clickCount (\count -> count + 1)

    count <- readRef clickCount

    render count ctx

    return unit

module Main where

import Data.Traversable (for)

import Control.Monad.Eff
import Control.Monad.Eff.DOM
import Control.Monad.Eff.Ref

import Graphics.Canvas

import Debug.Trace

main = do
  canvas <- getCanvasElementById "canvas"
  ctx <- getContext2D canvas

  clickCount <- newRef 0

  node <- querySelector "#canvas"
  for node $ addEventListener "click" $ do
    trace "Mouse clicked!"

    modifyRef clickCount (\count -> count + 1)

    count <- readRef clickCount

    setFillStyle "#FFFFFF" ctx

    fillPath ctx $ rect ctx
      { x: 0
      , y: 0
      , w: 600
      , h: 600
      }

    setFillStyle "#00FF00" ctx

    withContext ctx $ do
      translate { translateX:  300, translateY:  300 } ctx
      rotate (count * Math.pi / 18) ctx
      translate { translateX: -100, translateY: -100 } ctx

      fillPath ctx $ rect ctx
        { x: 0
        , y: 0
        , w: 200
        , h: 200
        }

    return unit


Bug fix. The screen buffer was emptied every line, instead of every frame

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 : 0
  , dispOn : false
  , bgOn : false
  , bgMap1 : false
  , bgSet1 : false
  , scrBuf : S.empty
  , currLine : 0
  , currPos : 0
  , yScroll : 0
  , xScroll : 0
  , palette : S.fromFoldable $ A.replicate 4 cleanColor
  , mode : OamScan
  , 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
                            }
         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 = (trs "vbl" (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

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 : 0
  , dispOn : false
  , bgOn : false
  , bgMap1 : false
  , bgSet1 : false
  , scrBuf : S.empty
  , currLine : 0
  , currPos : 0
  , yScroll : 0
  , xScroll : 0
  , palette : S.fromFoldable $ A.replicate 4 cleanColor
  , mode : OamScan
  , 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
      HBlank -> do --TODO set True least significant interrupt flags bit
        when ((trs "currLine" currLine) == pixHeight - 1)
          $ setScreen (seqToArray scrBuf) =<< getCanvas
        return gpu { mTimer = 0
                   , scrBuf = S.empty :: S.Seq I8 --psc forces me here
                   , currLine = currLine + 1
                   , currPos = currPos + bytesWidth
                   , mode = if currLine == pixHeight - 1 then VBlank
                                                         else 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 = (trs "vbl" (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


code style fixes

code style fixes

{-
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.Next.Component
 ( nextCardComponent
 , module SlamData.Workspace.Card.Next.Component.State
 , module SlamData.Workspace.Card.Next.Component.Query
 ) where

import SlamData.Prelude

import Data.Foldable as F
import Data.Lens ((.~))
import Data.String as Str

import Halogen as H
import Halogen.HTML.Events.Indexed as HE
import Halogen.HTML.Indexed as HH
import Halogen.HTML.Properties.Indexed as HP
import Halogen.HTML.Properties.Indexed.ARIA as ARIA
import Halogen.Themes.Bootstrap3 as B
import Halogen.Component.Utils as HU

import SlamData.Monad (Slam)
import SlamData.Render.Common (glyph)
import SlamData.Guide as Guide
import SlamData.Workspace.Card.CardType as CT
import SlamData.Workspace.Card.Component as CC
import SlamData.Workspace.Card.Model as Card
import SlamData.Workspace.Card.Next.NextAction as NA
import SlamData.Workspace.Card.Next.Component.Query (QueryP, Query(..), _AddCardType, _PresentReason)
import SlamData.Workspace.Card.Next.Component.State (State)
import SlamData.Workspace.Card.Next.Component.State as State
import SlamData.Workspace.Card.Port as Port
import SlamData.Workspace.Card.InsertableCardType as ICT

import Utils.LocalStorage as LocalStorage

type NextHTML = H.ComponentHTML QueryP
type NextDSL = H.ComponentDSL State QueryP Slam

nextCardComponent ∷ CC.CardComponent
nextCardComponent = CC.makeCardComponent
  { cardType: CT.NextAction
  , component:
      H.lifecycleComponent
        { render
        , eval
        , initializer: Just (right $ H.action Init)
        , finalizer: Nothing
        }
  , initialState: State.initialState
  , _State: CC._NextState
  , _Query: CC.makeQueryPrism CC._NextQuery
  }

render ∷ State → NextHTML
render state =
  HH.div_
    $ (guard (not state.presentAddCardGuide) $>
      HH.form_
        [ HH.div_
            [ HH.input
                [ HP.value state.filterString
                , HE.onValueInput (HE.input (\s → right ∘ UpdateFilter s))
                , ARIA.label "Filter next actions"
                , HP.placeholder "Filter actions"
                ]
            , HH.button
                [ HP.buttonType HP.ButtonButton
                , HE.onClick (HE.input_ (right ∘ UpdateFilter ""))
                ]
                [ glyph B.glyphiconRemove ]
            ]
        ])
    ⊕ (guard state.presentAddCardGuide $>
        Guide.render
          Guide.DownArrow
          (HH.className "sd-add-card-guide")
          (right ∘ DismissAddCardGuide)
          (addCardGuideText state.input))
    ⊕ [ HH.ul_ $ map nextButton state.actions ]
  where

  filterString ∷ String
  filterString = Str.toLower state.filterString

  cardTitle ∷ NA.NextAction → String
  cardTitle (NA.Insert cty) = "Insert a " ⊕ CT.cardName cty ⊕ " card"
  cardTitle (NA.FindOutHowToInsert cty) = "Find out how to insert a " ⊕ CT.cardName cty ⊕ " card"
  cardTitle (NA.Drill name _ _) = "Select " ⊕ name ⊕ " card category"
  cardTitle (NA.GoBack) = "Go back"

  nextButton ∷ NA.NextAction → NextHTML
  nextButton action =
    HH.li_
      [ HH.button attrs
          [ NA.actionGlyph action
          , HH.p_ [ HH.text $ NA.actionLabel action ]
          ]
      ]
    where
    enabled ∷ Boolean
    enabled = case action of
      NA.GoBack → true
      _ → F.any (Str.contains filterString ∘ Str.toLower) $ NA.searchFilters action

    attrs =
      [ HP.title $ cardTitle action
      , HP.disabled $ not enabled
      , ARIA.label $ cardTitle action
      , HP.classes classes
      ] ⊕ (guard
            (NA.isInsert action ∨ NA.isDrill action)
            $> HE.onClick (HE.input_ (right ∘ Selected action)))

    classes ∷ Array HH.ClassName
    classes = case action of
      NA.FindOutHowToInsert _ →
        nonInsertableClassNames
      NA.Drill _ _ actions | not (F.any NA.isInsert actions) →
        nonInsertableClassNames
      _ →
        insertableClassNames

    insertableClassNames =
      [ HH.className "sd-button" ]

    nonInsertableClassNames =
        [ HH.className "sd-button", HH.className "sd-button-warning" ]

  addCardGuideTextEmptyDeck = "To get this deck started press one of these buttons to add a card."
  addCardGuideTextNonEmptyDeck = "To do more with this deck press one of these buttons to add a card."
  addCardGuideText = maybe addCardGuideTextEmptyDeck (const addCardGuideTextNonEmptyDeck)

eval ∷ QueryP ~> NextDSL
eval = coproduct cardEval nextEval

cardEval ∷ CC.CardEvalQuery ~> NextDSL
cardEval = case _ of
  CC.EvalCard value output next →
    (H.modify
       $ (State._input .~ value.input)
       ∘ (State._actions .~ NA.fromMaybePort value.input))
       $> next
  CC.Activate next →
    pure next
  CC.Deactivate next →
    pure next
  CC.Save k →
    pure $ k Card.NextAction
  CC.Load _ next →
    pure next
  CC.SetDimensions _ next →
    pure next
  CC.ModelUpdated _ next →
    pure next
  CC.ZoomIn next →
    pure next

takesInput ∷ Maybe Port.Port → CT.CardType → Boolean
takesInput input =
  maybe false (ICT.takesInput $ ICT.fromMaybePort input) ∘ ICT.fromCardType

possibleToGetTo ∷ Maybe Port.Port → CT.CardType → Boolean
possibleToGetTo input =
  maybe false (ICT.possibleToGetTo $ ICT.fromMaybePort input) ∘ ICT.fromCardType

dismissedAddCardGuideKey ∷ String
dismissedAddCardGuideKey = "dismissedAddCardGuide"

getDismissedAddCardGuideBefore ∷ NextDSL Boolean
getDismissedAddCardGuideBefore =
  H.liftH
    $ either (const $ false) id
    <$> LocalStorage.getLocalStorage dismissedAddCardGuideKey

storeDismissedAddCardGuide ∷ NextDSL Unit
storeDismissedAddCardGuide =
  H.liftH $ LocalStorage.setLocalStorage dismissedAddCardGuideKey true

dismissAddCardGuide ∷ NextDSL Unit
dismissAddCardGuide =
  H.modify (State._presentAddCardGuide .~ false)
    *> storeDismissedAddCardGuide

nextEval ∷ Query ~> NextDSL
nextEval (Init next) =
  H.modify (\st → st { actions = NA.fromMaybePort st.input })
    $> next
nextEval (AddCard _ next) = dismissAddCardGuide $> next
nextEval (PresentReason io card next) = pure next
nextEval (UpdateFilter str next) =
  H.modify (State._filterString .~ str) $> next
nextEval (DismissAddCardGuide next) = dismissAddCardGuide $> next
nextEval (PresentAddCardGuide next) =
  (H.modify
     ∘ (State._presentAddCardGuide .~ _)
     ∘ not =<< getDismissedAddCardGuideBefore)
     $> next
nextEval (Selected action next) = do
  st ← H.get
  case action of
    NA.Insert cardType →
      HU.raise $ right $ H.action $ AddCard cardType
    NA.FindOutHowToInsert cardType →
      HU.raise $ right $ H.action $ PresentReason st.input cardType
    NA.Drill _ _ actions →
      H.modify $ (State._actions .~ actions) ∘ (State._previousActions .~ st.actions)
    NA.GoBack →
      H.modify
        $ (State._actions .~ st.previousActions)
        ∘ (State._previousActions .~ [ ])
  pure next

{-
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.Next.Component
 ( nextCardComponent
 , module SlamData.Workspace.Card.Next.Component.State
 , module SlamData.Workspace.Card.Next.Component.Query
 ) where

import SlamData.Prelude

import Data.Foldable as F
import Data.Lens ((.~))
import Data.String as Str

import Halogen as H
import Halogen.HTML.Events.Indexed as HE
import Halogen.HTML.Indexed as HH
import Halogen.HTML.Properties.Indexed as HP
import Halogen.HTML.Properties.Indexed.ARIA as ARIA
import Halogen.Themes.Bootstrap3 as B
import Halogen.Component.Utils as HU

import SlamData.Monad (Slam)
import SlamData.Render.Common (glyph)
import SlamData.Guide as Guide
import SlamData.Workspace.Card.CardType as CT
import SlamData.Workspace.Card.Component as CC
import SlamData.Workspace.Card.Model as Card
import SlamData.Workspace.Card.Next.NextAction as NA
import SlamData.Workspace.Card.Next.Component.Query (QueryP, Query(..), _AddCardType, _PresentReason)
import SlamData.Workspace.Card.Next.Component.State (State)
import SlamData.Workspace.Card.Next.Component.State as State
import SlamData.Workspace.Card.Port as Port
import SlamData.Workspace.Card.InsertableCardType as ICT

import Utils.LocalStorage as LocalStorage

type NextHTML = H.ComponentHTML QueryP
type NextDSL = H.ComponentDSL State QueryP Slam

nextCardComponent ∷ CC.CardComponent
nextCardComponent = CC.makeCardComponent
  { cardType: CT.NextAction
  , component:
      H.lifecycleComponent
        { render
        , eval
        , initializer: Just (right $ H.action Init)
        , finalizer: Nothing
        }
  , initialState: State.initialState
  , _State: CC._NextState
  , _Query: CC.makeQueryPrism CC._NextQuery
  }

render ∷ State → NextHTML
render state =
  HH.div_
    $ (guard (not state.presentAddCardGuide) $>
      HH.form_
        [ HH.div_
            [ HH.input
                [ HP.value state.filterString
                , HE.onValueInput (HE.input (\s → right ∘ UpdateFilter s))
                , ARIA.label "Filter next actions"
                , HP.placeholder "Filter actions"
                ]
            , HH.button
                [ HP.buttonType HP.ButtonButton
                , HE.onClick (HE.input_ (right ∘ UpdateFilter ""))
                ]
                [ glyph B.glyphiconRemove ]
            ]
        ])
    ⊕ (guard state.presentAddCardGuide $>
        Guide.render
          Guide.DownArrow
          (HH.className "sd-add-card-guide")
          (right ∘ DismissAddCardGuide)
          (addCardGuideText state.input))
    ⊕ [ HH.ul_ $ map nextButton state.actions ]
  where

  filterString ∷ String
  filterString = Str.toLower state.filterString

  cardTitle ∷ NA.NextAction → String
  cardTitle (NA.Insert cty) = "Insert a " ⊕ CT.cardName cty ⊕ " card"
  cardTitle (NA.FindOutHowToInsert cty) = "Find out how to insert a " ⊕ CT.cardName cty ⊕ " card"
  cardTitle (NA.Drill name _ _) = "Select " ⊕ name ⊕ " card category"
  cardTitle (NA.GoBack) = "Go back"

  nextButton ∷ NA.NextAction → NextHTML
  nextButton action =
    HH.li_
      [ HH.button attrs
          [ NA.actionGlyph action
          , HH.p_ [ HH.text $ NA.actionLabel action ]
          ]
      ]
    where
    enabled ∷ Boolean
    enabled = case action of
      NA.GoBack → true
      _ → F.any (Str.contains filterString ∘ Str.toLower) $ NA.searchFilters action

    attrs =
      [ HP.title $ cardTitle action
      , HP.disabled $ not enabled
      , ARIA.label $ cardTitle action
      , HP.classes classes
      ] ⊕ (guard
            (NA.isInsert action ∨ NA.isDrill action)
            $> HE.onClick (HE.input_ (right ∘ Selected action)))

    classes ∷ Array HH.ClassName
    classes = case action of
      NA.FindOutHowToInsert _ →
        nonInsertableClassNames
      NA.Drill _ _ actions →
        if F.any NA.isInsert actions then insertableClassNames else nonInsertableClassNames
      _ →
        insertableClassNames

    insertableClassNames =
      [ HH.className "sd-button" ]

    nonInsertableClassNames =
        [ HH.className "sd-button", HH.className "sd-button-warning" ]

  addCardGuideTextEmptyDeck = "To get this deck started press one of these buttons to add a card."
  addCardGuideTextNonEmptyDeck = "To do more with this deck press one of these buttons to add a card."
  addCardGuideText = maybe addCardGuideTextEmptyDeck (const addCardGuideTextNonEmptyDeck)

eval ∷ QueryP ~> NextDSL
eval = coproduct cardEval nextEval

cardEval ∷ CC.CardEvalQuery ~> NextDSL
cardEval = case _ of
  CC.EvalCard value output next →
    H.modify
      ((State._input .~ value.input) ∘ (State._actions .~ NA.fromMaybePort value.input))
      $> next
  CC.Activate next →
    pure next
  CC.Deactivate next →
    pure next
  CC.Save k →
    pure $ k Card.NextAction
  CC.Load _ next →
    pure next
  CC.SetDimensions _ next →
    pure next
  CC.ModelUpdated _ next →
    pure next
  CC.ZoomIn next →
    pure next

takesInput ∷ Maybe Port.Port → CT.CardType → Boolean
takesInput input =
  maybe false (ICT.takesInput $ ICT.fromMaybePort input) ∘ ICT.fromCardType

possibleToGetTo ∷ Maybe Port.Port → CT.CardType → Boolean
possibleToGetTo input =
  maybe false (ICT.possibleToGetTo $ ICT.fromMaybePort input) ∘ ICT.fromCardType

dismissedAddCardGuideKey ∷ String
dismissedAddCardGuideKey = "dismissedAddCardGuide"

getDismissedAddCardGuideBefore ∷ NextDSL Boolean
getDismissedAddCardGuideBefore =
  H.liftH
    $ either (const $ false) id
    <$> LocalStorage.getLocalStorage dismissedAddCardGuideKey

storeDismissedAddCardGuide ∷ NextDSL Unit
storeDismissedAddCardGuide =
  H.liftH $ LocalStorage.setLocalStorage dismissedAddCardGuideKey true

dismissAddCardGuide ∷ NextDSL Unit
dismissAddCardGuide =
  H.modify (State._presentAddCardGuide .~ false) *> storeDismissedAddCardGuide

nextEval ∷ Query ~> NextDSL
nextEval (Init next) =
  (H.modify $ (\st → st { actions = NA.fromMaybePort st.input })) $> next
nextEval (AddCard _ next) = dismissAddCardGuide $> next
nextEval (PresentReason io card next) = pure next
nextEval (UpdateFilter str next) = do
  (H.modify $ (State._filterString .~ str)) $> next
nextEval (DismissAddCardGuide next) = dismissAddCardGuide $> next
nextEval (PresentAddCardGuide next) = do
  H.modify ∘ (State._presentAddCardGuide .~ _) ∘ not =<< getDismissedAddCardGuideBefore
  pure next
nextEval (Selected action next) = do
  st ← H.get
  case action of
    NA.Insert cardType →
      HU.raise $ right $ H.action $ AddCard cardType
    NA.FindOutHowToInsert cardType →
      void $ HU.raise $ right $ H.action $ PresentReason st.input cardType
    NA.Drill _ _ actions →
      H.modify $ (State._actions .~ actions) ∘ (State._previousActions .~ st.actions)
    NA.GoBack →
      H.modify $ (State._actions .~ st.previousActions) ∘ (State._previousActions .~ [ ])
  pure next


Simplify example

Simplify example

module Main (main) where

import Data.Function

import qualified Thermite as T
import qualified Thermite.Html as T
import qualified Thermite.Html.Elements as T
import qualified Thermite.Html.Attributes as A
import qualified Thermite.Action as T
import qualified Thermite.Events as T
import qualified Thermite.Types as T

data Action = Increment | Decrement

type State = { counter :: Number }

initialState :: State
initialState = { counter: 0 }

render :: T.Render State _ Action
render ctx s _ = T.div' [counter, buttons]
  where
  counter :: T.Html _
  counter =
    T.p'
      [ T.text "Value: "
      , T.text $ show s.counter
      ]

  buttons :: T.Html _
  buttons =
    T.p'
      [ T.button [ T.onClick ctx (\_ -> Increment) ]
                 [ T.text "Increment" ]
      , T.button [ T.onClick ctx (\_ -> Decrement) ]
                 [ T.text "Decrement" ]
      ]

performAction :: T.PerformAction _ Action (T.Action _ State)
performAction _ Increment = T.modifyState \o -> { counter: o.counter + 1 }
performAction _ Decrement = T.modifyState \o -> { counter: o.counter - 1 }

spec :: T.Spec _ State _ Action
spec = T.Spec { initialState: initialState
              , performAction: performAction
              , render: render
              }

main = do
  let component = T.createClass spec
  T.render component {}

module Main (main) where

import Data.Function

import qualified Thermite as T
import qualified Thermite.Html as T
import qualified Thermite.Html.Elements as T
import qualified Thermite.Html.Attributes as A
import qualified Thermite.Action as T
import qualified Thermite.Events as T
import qualified Thermite.Types as T

data Action = TextChanged String | ClearText

data State = State { name :: String }

data Props = Props { greeting :: String }

foreign import unsafeStringValue
  "function unsafeStringValue(e) {\
  \  return e.target.value;\
  \}" :: T.FormEvent -> String

initialState :: State
initialState = State { name: "" }

render :: T.Render State Props Action
render ctx (State s) (Props p) = T.div' $ welcome : response s.name
  where
  welcome :: T.Html _
  welcome =
    T.div'
      [ T.input [ A.value s.name
                , A.placeholder "What is your name?"
                , T.onChange ctx (TextChanged <<< unsafeStringValue)
                ] []
      , T.button [ T.onClick ctx (\_ -> TextChanged "") ]
                 [ T.text "Clear" ]
      ]

  response :: String -> [T.Html _]
  response "" = []
  response s =
    [ T.div'
      [ T.text p.greeting
      , T.text s
      ]
    ]

performAction :: T.PerformAction Props Action (T.Action _ State)
performAction _ (TextChanged s) = T.setState $ State { name: s }

spec :: T.Spec _ State Props Action
spec = T.Spec { initialState: initialState
              , performAction: performAction
              , render: render
              }

main = do
  let component = T.createClass spec
  T.render component (Props { greeting: "Hello, " })


Another helper function for coordinate intervals~~

module Genetics.Browser.Types where
       -- ( Point
       -- , Pos
       -- , Range
       -- , Bp(..)
       -- , MBp(..)
       -- , class HCoordinate
       -- , bp
       -- , mbp
       -- , _Bp
       -- , _MBp
       -- , _BpMBp
       -- , ChrId(..)
       -- , _ChrId
       -- , toScreen
       -- , BpPerPixel(..)
       -- , bpToPixels
       -- , pixelsToBp
       -- , Chr
       -- , ChrInterval
       -- , BrowserPoint(..)
       -- , LocalPoint(..)
       -- , IntervalPoint
       -- , Interval(..)
       -- , CoordSys(..)
       -- , mkCoordSys
       -- , findInterval
       -- , localToGlobal
       -- , globalToLocal
       -- , canvasToView
       -- , globalToFrame
       -- , intervalToChr
       -- , frameToChr
       -- , intervalSize
       -- , canvasToBrowserOffset
       -- ) where

import Prelude

import Control.Alternative (empty)
import Control.MonadPlus (guard)
import Data.Array as Array
import Data.Bifunctor (bimap)
import Data.BigInt (BigInt)
import Data.BigInt as BigInt
import Data.Foldable (length, sum)
import Data.Foreign.Class (class Decode, class Encode)
import Data.Int as Int
import Data.Lens (APrism', Iso', Lens', Prism', iso, lens, prism', takeBoth, (^.))
import Data.Lens.Iso.Newtype (_Newtype)
import Data.Lens.Types (Iso')
import Data.Maybe (Maybe(..))
import Data.Newtype (class Newtype, unwrap, wrap)
import Data.Profunctor.Choice (fanin)
import Data.Profunctor.Strong (fanout, splitStrong)
import Data.Ratio (Ratio, (%))
import Data.Ratio as Ratio
import Data.Tuple (Tuple(..), fst, snd, uncurry)
import Unsafe.Coerce (unsafeCoerce)
-- import Genetics.Browser.Units (Bp(..), ChrId(..))

type Point = { x :: Number, y :: Number}

type Pos = { chrId :: ChrId, bp :: Bp }

type Chr = { chrId :: ChrId, size :: Bp }

type Range r = { lHand :: Pos, rHand :: Pos  | r}

-- | Newtype wrapper for a basepair location
newtype Bp = Bp Number
derive instance newtypeBp :: Newtype Bp _
derive newtype instance eqBp :: Eq Bp
derive newtype instance ordBp :: Ord Bp
derive newtype instance fieldBp :: Field Bp
derive newtype instance euclideanRingBp :: EuclideanRing Bp
derive newtype instance commutativeRingBp :: CommutativeRing Bp
derive newtype instance semiringBp :: Semiring Bp
derive newtype instance ringBp :: Ring Bp
derive newtype instance encodeBp :: Encode Bp
derive newtype instance decodeBp :: Decode Bp

instance showBp :: Show Bp where
  show (Bp n) = show n <> "Bp"

_Bp :: Iso' Bp Number
_Bp = _Newtype

_MBp :: Iso' MBp Number
_MBp = _Newtype

-- probably not actually an isomorphism due to floating point inaccuracies
_BpMBp :: Iso' Bp MBp
_BpMBp = iso mbp bp

-- | Newtype wrapper for a megabasepair location
newtype MBp = MBp Number
derive instance newtypeMBp :: Newtype MBp _
derive newtype instance eqMBp :: Eq MBp
derive newtype instance ordMBp :: Ord MBp
derive newtype instance fieldMBp :: Field MBp
derive newtype instance euclideanRingMBp :: EuclideanRing MBp
derive newtype instance commutativeRingMBp :: CommutativeRing MBp
derive newtype instance semiringMBp :: Semiring MBp
derive newtype instance ringMBp :: Ring MBp
derive newtype instance encodeMBp :: Encode MBp
derive newtype instance decodeMBp :: Decode MBp

instance showMBp :: Show MBp where
  show (MBp n) = show n <> "MBp"

class Field a <= HCoordinate a where
  bp :: a -> Bp
  mbp :: a -> MBp

toScreen :: ∀ c. HCoordinate c => c -> c -> c -> Number
toScreen offset scale x = unwrap ((x' - offset') * scale')
  where offset' = bp offset
        scale' = bp scale
        x' = bp x

instance hCoordBp :: HCoordinate Bp where
  bp = id
  mbp (Bp x) = MBp (x * 0.000001)

instance hCoordMBp :: HCoordinate MBp where
  bp (MBp x) = Bp (x * 1000000.0)
  mbp  = id

-- | Newtype wrapper for a chromosome identifier
newtype ChrId = ChrId String
derive instance newtypeChrId :: Newtype ChrId _
derive newtype instance eqChrId :: Eq ChrId
derive newtype instance ordChrId :: Ord ChrId
derive newtype instance encodeChrId :: Encode ChrId
derive newtype instance decodeChrId :: Decode ChrId
derive newtype instance showChrId :: Show ChrId

_ChrId :: Iso' ChrId String
_ChrId = _Newtype

-- TODO be *really cool* and represent it as a ratio of bp and pixels
-- i.e. just a tuple!
-- also it doesn't mean anything on its own;
-- or, rather, it's implicit that it only concerns a single chr at origin

newtype BpPerPixel = BpPerPixel Number
derive instance newtypeBpPerPixel :: Newtype BpPerPixel _

bpToPixels :: BpPerPixel -> Bp -> Number
bpToPixels (BpPerPixel s) (Bp p) = p / s

pixelsToBp :: BpPerPixel -> Number -> Bp
pixelsToBp (BpPerPixel s) p = Bp $ p * s

-- newtype BpScale = BpScale (Ratio BigInt BigInt)

-- Describes a number of `a`s per `b` -- `b` is a phantom type;
-- we always assume `b` is 1 in whatever unit it represents.
data UnitRatio a b = UnitRatio a

instance eqUnitRatio :: (Eq a) => Eq (UnitRatio a b) where
  eq (UnitRatio a) (UnitRatio b) = a == b

instance ordUnitRatio :: (Ord a) => Ord (UnitRatio a b) where
  compare (UnitRatio a) (UnitRatio b) = compare a b

type BpPerPixel' = UnitRatio Number Bp

-- pretty much all my problems appear to be solved by this type. nice
-- data Local f c = Local c c (Ratio c)
-- data BrowserWide c = BrowserWide

-- toGlobal :: forall f c.
--             Ord c
--          => EuclideanRing c
--          => Local f c
--          -> Maybe c
-- toGlobal (Local l r p) =
--   let p' = p * ((r - l) % one)
--   in if Ratio.denominator p' == one
--         then pure $ Ratio.numerator p'
--         else Nothing

-- toLocal :: forall f c.
--            Ord c
--         => EuclideanRing c
--         => c
--         -> Tuple c c
--         -> Local f c
-- toLocal c (Tuple l r) = Local l r $ (c - l) % (r - l)

-- The global coordinate system works by taking the sum of the chromosome sizes;
-- we represent it using a BigInt
newtype BrowserPoint = BPoint BigInt

derive instance eqBrowserPoint :: Eq BrowserPoint
derive instance ordBrowserPoint :: Ord BrowserPoint
derive instance newtypeBrowserPoint :: Newtype BrowserPoint _

-- Subsets of the global coordinate system are defined by some interval,
--

data Interval c = Interval c c

inInterval :: forall c.
              Ord c
           => c
           -> Interval c
           -> Boolean
inInterval p (Interval l r) = l <= p && p <= r

_iL :: forall c. Lens' (Interval c) c
_iL = lens (\(Interval l _) -> l) (\(Interval _ r) l -> Interval l r)

_iR :: forall c. Lens' (Interval c) c
_iR = lens (\(Interval _ r) -> r) (\(Interval l _) r -> Interval l r)

-- clunky but works for now
data LocalPoint c = Local (Interval c) (Ratio BigInt)

_lIv :: forall c. Lens' (LocalPoint c) (Interval c)
_lIv = lens (\(Local i _) -> i) (\(Local _ p) i -> Local i p)

_lP :: forall c. Lens' (LocalPoint c) (Ratio BigInt)
_lP = lens (\(Local _ p) -> p) (\(Local i _) p -> Local i p)

-- TODO This is dumb and bad, precision etc.
ratioToNumber :: Ratio BigInt
              -> Number
ratioToNumber r =
  let n = (Ratio.numerator r)
      d = (Ratio.denominator r)
  in (BigInt.toNumber n) / (BigInt.toNumber d)

-- for now we just assume that the given point is in the interval...
globalToLocal :: forall a c.
                 Newtype c BigInt
              => Interval c
              -> c
              -> LocalPoint c
globalToLocal iv@(Interval l r) p =
  let l' = unwrap l
      r' = unwrap r
      p' = ((unwrap p) - l') % (r' - l')
  in Local iv p'

localToGlobal :: forall c.
                 Newtype c BigInt
              => LocalPoint c
              -> c
localToGlobal (Local (Interval l r) p) =
  let r' = (unwrap r) % one
      l' = (unwrap l) % one
      p' = (p * (r' - l')) + l'
  in wrap $ (Ratio.numerator p') / (Ratio.denominator p')

intervalSize :: forall c a.
                Newtype c a
             => Ring a
             => Interval c
             -> a
intervalSize (Interval l r) = (unwrap r) - (unwrap l)

-- | Transform a point in some interval A to the same point in interval B
seenFrom :: forall a b c.
            Newtype c BigInt
         => Newtype b BigInt
         => LocalPoint c
         -> Interval b
         -> LocalPoint b
seenFrom p i =
  let p' = unwrap $ localToGlobal p
  in globalToLocal i (wrap p')

intervalSeenFrom :: forall a b c.
                    Newtype c BigInt
                 => Newtype b BigInt
                 => Interval c
                 -> Interval b
                 -> Interval (Ratio BigInt)
intervalSeenFrom (Interval l r) i2 =
  let pl = globalToLocal i2 (wrap $ unwrap l)
      pr = globalToLocal i2 (wrap $ unwrap r)
  in Interval (pl^._lP) (pr^._lP)

type IntervalPoint = LocalPoint BrowserPoint

type ChrInterval c = { interval :: Interval c, chrSize :: Bp }

newtype CoordSys i c =
  CoordSys { size :: c
           , padding :: c
           -- , intervals :: Array (Tuple i (Interval c))
           , intervals :: Array (Tuple i (ChrInterval c))
           }

-- TODO need to make sure the padding is correctly applied/removed
mkCoordSys :: forall i c.
              Array (Tuple i BigInt)
           -> BigInt
           -> CoordSys i BrowserPoint
mkCoordSys chrs padding = CoordSys { size, padding: wrap padding, intervals }
  where (Tuple ids sizes) = Array.unzip chrs
        os = map BPoint $ Array.scanl (\x y -> padding + x + y) zero sizes
        ivals = Array.zipWith Interval (wrap zero `Array.cons` os) os
        intervals = Array.zip ids $
                    Array.zipWith (\i s -> {interval: i, chrSize:(Bp $ BigInt.toNumber s)}) ivals sizes
        size = wrap $ (sum sizes) + (length sizes * padding)

findInterval :: forall i c.
                Ord c
             => CoordSys i c
             -> c
             -> Maybe (Tuple i (ChrInterval c))
findInterval (CoordSys s) p =
  Array.find (\(Tuple i iv) -> p `inInterval` iv.interval) s.intervals

intervals :: forall i c.
             Ord i
          => CoordSys i c
          -> i
          -> i
          -> Maybe (Array (Tuple i (ChrInterval c)))
intervals (CoordSys s) l r = do
  let l' = min l r
      r' = max l r
  lIndex <- Array.findIndex ((==) l' <<< fst) s.intervals
  rIndex <- Array.findIndex ((==) r' <<< fst) s.intervals
  pure $ Array.slice lIndex rIndex s.intervals

viewIntervals :: forall i c.
                 Ord i
              => Ord c
              => CoordSys i c
              -> Interval c
              -> Maybe (Array (Tuple i (ChrInterval c)))
viewIntervals cs (Interval l r) = do
  lIv <- fst <$> findInterval cs l
  rIv <- fst <$> findInterval cs r

  intervals cs lIv rIv

canvasToView :: forall r.
                { width :: Number | r }
             -> Number
             -> Ratio BigInt
canvasToView {width} x = x' % w'
  where w' = BigInt.fromInt $ Int.round width
        x' = BigInt.fromInt $ Int.round x

canvasToBrowserOffset :: forall r.
                         { width :: Number | r }
                      -> BigInt
                      -> Number
                      -> BrowserPoint
canvasToBrowserOffset w vw x =
  let x' = canvasToView w x
      p' = x' * (vw % one)
  in wrap $ (Ratio.numerator p') / (Ratio.denominator p')

globalToFrame :: forall i c.
                 Eq i
              => CoordSys i BrowserPoint
              -> BrowserPoint
              -> Maybe (Tuple i IntervalPoint)
globalToFrame cs bp@(BPoint p) = do
  (Tuple i iv) <- findInterval cs bp
  pure $ Tuple i $ globalToLocal iv.interval bp

intervalToChr :: BrowserPoint
              -> IntervalPoint
              -> Bp
              -> Maybe Bp
intervalToChr padding (Local (Interval l r) p) chrSize = do
  let padR = (unwrap padding) % (unwrap r - unwrap l)
  -- guard $ p >= padR && p <= one - padR
  let p' = p - padR
      bp = Bp $ (BigInt.toNumber $ Ratio.numerator p') / (BigInt.toNumber $ Ratio.denominator p')

  -- TODO it's dumb that Bp is still a Number newtype
  pure $ bp * chrSize

frameToChr :: forall i c.
              Eq i
           => CoordSys i BrowserPoint
           -> Tuple i IntervalPoint
           -> Maybe Bp
frameToChr (CoordSys s) (Tuple i lp) = do
  iv <- snd <$> Array.find ((==) i <<< fst) s.intervals
  intervalToChr s.padding lp iv.chrSize

intervalToScreen :: BrowserPoint
                 -> Number
                 -> Interval BrowserPoint
                 -> Interval BrowserPoint
                 -> { width :: Number, offset :: Number }
intervalToScreen pad screenWidth reference other = { width, offset }
  where screen :: BigInt
        screen = BigInt.fromInt $ Int.round screenWidth
        padL :: BrowserPoint
        padL = wrap $ (unwrap $ other^._iL) + (unwrap pad)
        padR :: BrowserPoint
        padR = wrap $ (unwrap $ other^._iR) - (unwrap pad)
        -- 1. calculate LHS and RHS of other wrt. reference
        (Interval l r) = (Interval padL padR) `intervalSeenFrom` reference
        l' = ratioToNumber $ l * (screen % one)
        r' = ratioToNumber $ r * (screen % one)
        -- 2. width is obvious
        width :: Number
        width = r' - l'
        -- 3. offset is less so
        offset :: Number
        offset = l'

shiftIntervalBy :: forall c.
                   Newtype c BigInt
                => Interval c
                -> Ratio BigInt
                -> Interval c
shiftIntervalBy (Interval l r) rat =
  let l' = unwrap l
      r' = unwrap r
      diff = ((r' - l') * (Ratio.numerator rat)) / (Ratio.denominator rat)
  in Interval (wrap $ l' - diff) (wrap $ r' - diff)


Two new levels in the first chapter

Two new levels in the first chapter

module Levels.Chapter1 where

import Data.Array
import qualified Data.StrMap as SM

import Helper
import Transformer
import Types

chapter1 :: Chapter
chapter1 = {
    name: "Warm up",

    transformers: SM.fromList [
        "stackEqual" :> {
            name: "stackEqual",
            function: tStackEqual
        },
--        "mapClone" :> {
--            name: "map({X} ↦ {X}{X})",
--            function: map $ concatMap (\x -> [x, x])
--        },
--        "flatten" :> {
--            name: "flatten",
--            function: tFlatten
--        },
        "replaceYbyB" :> {
            name: "map({Yellow} ↦ {Brown})",
            function: tReplace Yellow Brown
        },
        "replaceYbyBY" :> {
            name: "map({Yellow} ↦ {Brown}{Yellow})",
            function: tReplaceMultiple Yellow [Brown, Yellow]
        },
--        "replaceBbyBBB" :> {
--            name: "map({Brown} ↦ {Brown}{Brown}{Brown})",
--            function: tReplaceMultiple Brown [Brown, Brown, Brown]
--        },
        "replaceBbyOO" :> {
            name: "map({Brown} ↦ {Orange}{Orange})",
            function: tReplaceMultiple Brown [Orange, Orange]
        },
        "rejectO" :> {
            name: "reject({Orange})",
            function: map (reject (== Orange)) >>> tClearEmpty
        },
        "filterB" :> {
            name: "reject({Brown})",
            function: map (reject (== Brown)) >>> tClearEmpty
        },
        "pushY" :> {
            name: "map(push({Yellow}))",
            function: map (`snoc` Yellow)
        }
--        "tail" :> {
--            name: "map(tail)",
--            function: tTail
--        }
    ],

    levels: SM.fromList [
        "1_1" :> {
            name: "Filters",
            initial: [[Brown], [Orange], [Orange], [Yellow], [Yellow], [Yellow], [Orange], [Orange], [Brown]],
            target: [[Brown], [Yellow], [Yellow], [Yellow], [Brown]]
        },
        "1_2" :> {
            name: "Maps",
            initial: [[Brown], [Orange], [Orange], [Brown]],
            target: [[Orange, Orange, Orange, Orange], [Orange, Orange], [Orange, Orange], [Orange, Orange, Orange, Orange]]
        },
        "1_3" :> {
            name: "...",
            initial: [[Brown], [Orange], [Orange], [Yellow], [Yellow], [Yellow], [Orange], [Orange], [Brown]],
            target: [[Brown, Brown], [Brown], [Brown, Brown, Brown, Brown], [Brown], [Brown, Brown]]
        },
        "1_4" :> {
            name: "...",
            initial: [[Brown], [Orange], [Orange], [Yellow], [Yellow], [Yellow], [Orange], [Orange], [Brown]],
            target: [[Brown, Brown], [Orange, Brown, Orange, Brown], [Brown, Brown, Brown, Brown, Brown, Brown], [Orange, Brown, Orange, Brown], [Brown, Brown]]
        }
    ]
}

module Levels.Chapter1 where

import Data.Array
import qualified Data.StrMap as SM

import Helper
import Transformer
import Types

chapter1 :: Chapter
chapter1 = {
    name: "Warm up",

    transformers: SM.fromList [
        "stackEqual" :> {
            name: "stackEqual",
            function: tStackEqual
        },
        "mapClone" :> {
            name: "map({X} ↦ {X}{X})",
            function: map $ concatMap (\x -> [x, x])
        },
--        "flatten" :> {
--            name: "flatten",
--            function: tFlatten
--        },
        "replaceYbyB" :> {
            name: "map({Yellow} ↦ {Brown})",
            function: tReplace Yellow Brown
        },
        "replaceYbyBY" :> {
            name: "map({Yellow} ↦ {Brown}{Yellow})",
            function: tReplaceMultiple Yellow [Brown, Yellow]
        },
--        "replaceBbyBBB" :> {
--            name: "map({Brown} ↦ {Brown}{Brown}{Brown})",
--            function: tReplaceMultiple Brown [Brown, Brown, Brown]
--        },
        "replaceBbyOO" :> {
            name: "map({Brown} ↦ {Orange}{Orange})",
            function: tReplaceMultiple Brown [Orange, Orange]
        },
        "rejectO" :> {
            name: "reject({Orange})",
            function: map (reject (== Orange)) >>> tClearEmpty
        },
        "pushY" :> {
            name: "map(push({Yellow}))",
            function: map (`snoc` Yellow)
        }
--        "tail" :> {
--            name: "map(tail)",
--            function: tTail
--        }
    ],

    levels: SM.fromList [
        "1_1" :> {
            name: "Filters",
            initial: [[Brown], [Orange], [Orange], [Yellow], [Yellow], [Yellow], [Orange], [Orange], [Brown]],
            target: [[Brown], [Yellow], [Yellow], [Yellow], [Brown]]
        },
        "1_2" :> {
            name: "Maps",
            initial: [[Brown], [Orange], [Orange], [Brown]],
            target: [[Orange, Orange, Orange, Orange], [Orange, Orange], [Orange, Orange], [Orange, Orange, Orange, Orange]]
        }
    ]
}