Redo drawing system using Intervals

Redo drawing system using Intervals

module Genetics.Browser.Track.Backend where

import Prelude

import Color (Color, black)
import Color.Scheme.Clrs (aqua, blue, fuchsia, green, lime, maroon, navy, olive, orange, purple, red, teal, yellow)
import Control.Alt ((<|>))
import Control.Monad.Aff (Aff)
import Control.Monad.Eff.Exception (error)
import Control.Monad.Error.Class (throwError)
import Control.Monad.Reader (class MonadReader, ask)
import Data.Argonaut (Json, _Array, _Number, _Object, _String)
import Data.Array ((:))
import Data.Array as Array
import Data.Bifunctor (bimap)
import Data.BigInt (BigInt)
import Data.BigInt as BigInt
import Data.Filterable (class Filterable, filterMap)
import Data.Foldable (class Foldable, fold, foldMap, foldl, maximum, sum)
import Data.FunctorWithIndex (mapWithIndex)
import Data.Int as Int
import Data.Lens (united, (^?))
import Data.Lens.Index (ix)
import Data.List (List)
import Data.List as List
import Data.Map (Map)
import Data.Map as Map
import Data.Maybe (Maybe(Just, Nothing), fromMaybe)
import Data.Monoid (class Monoid, mempty)
import Data.Monoid.Additive (Additive(..))
import Data.Newtype (class Newtype, ala, alaF, unwrap)
import Data.Ord.Max (Max(..))
import Data.Ratio (Ratio(..), denominator, numerator, (%))
import Data.Ratio as Ratio
import Data.Record as Record
import Data.Symbol (SProxy(..))
import Data.Traversable (scanl, traverse)
import Data.Tuple (Tuple(..), fst, snd, uncurry)
import Data.Variant (class Contractable, Variant)
import Data.Variant as Variant
import Genetics.Browser.Types (Bp(Bp), BrowserPoint, ChrId(ChrId), ChrInterval, CoordSys(CoordSys), Interval, Point, intervalToScreen, viewIntervals)
import Genetics.Browser.View (Pixels)
import Graphics.Drawing (Drawing, circle, fillColor, filled, lineWidth, outlineColor, outlined, rectangle, scale, translate)
import Graphics.Drawing as Drawing
import Graphics.Drawing.Font (font, sansSerif)
import Network.HTTP.Affjax as Affjax
import Type.Prelude (class IsSymbol, class RowLacks)
import Unsafe.Coerce (unsafeCoerce)

type Frame a = { padding :: Pixels, width :: Pixels, contents :: a }

type ChrCtx r = Map ChrId (Record r)

-- totalSize :: forall r.
--              ChrCtx (size :: Bp | r)
--           -> Bp
-- totalSize chrCtx = alaF Additive foldMap _.size chrCtx

newtype Normalized a = Normalized a

derive instance newtypeNormalized :: Newtype (Normalized a) _

normalizePoint :: { width :: Number
                  , height :: Number }
               -> Point
               -> Normalized Point
normalizePoint {width, height} {x, y} = Normalized { x: x', y: y' }
  where x' = x / width
        y' = y / height

normPoint :: Point -> Maybe (Normalized Point)
normPoint p@{x, y}
  | x < 0.0 || x > 1.0 = Nothing
  | y < 0.0 || y > 1.0 = Nothing
  | otherwise = Just $ Normalized p

nPointToFrame :: Pixels -> Pixels -> Normalized Point -> Point
nPointToFrame w h (Normalized p) = {x: p.x * w, y: p.y * h}

-- A renderer draws a single value to a normalized "canvas",
-- i.e. the whole chromosome is located in x = (0.0, 1.0),
-- and the whole track height in y = (0.0, 1.0).
-- It can fail if the given feature for some reason cannot be rendered,
-- either because the feature lacks information, or because the context lacks something.

type PureRenderer a = a -> Maybe { drawing :: Drawing
                                 , point   :: Normalized Point
                                 }

-- Drawings are not entirely pure. They can depend on the width of the
-- frame, if they something that spans across a range of the genome.
-- So, the `drawing` field should really have type
--   Pixels -> Drawing
-- where the `Pixels` is the width of the frame. Renderers already
-- have access to the chr size when created, so the width is all that's needed.
type PureRenderer' a = a -> Maybe { drawing :: Pixels -> Drawing
                                  , point   :: Normalized Point
                                  }

-- tagRenderer :: forall a sym r1 r2.
--                RowCons sym a r1 r2
--             => IsSymbol sym
--             => SProxy sym
--             -> PureRenderer a
--             -> PureRenderer (Variant r2)
-- tagRenderer sym renderer var = Variant.prj sym var >>= renderer

-- combineRenderers :: forall r1 r2 r3.
--                     Union r1 r2 r3
--                  => Contractable r3 r1
--                  => Contractable r3 r2
--                  => PureRenderer (Variant r1)
--                  -> PureRenderer (Variant r2)
--                  -> PureRenderer (Variant r3)
-- combineRenderers r1 r2 var = (Variant.contract var >>= r1) <|>
--                              (Variant.contract var >>= r2)

type GWASFeature r = { score :: Number
                     , pos :: Bp
                     , chrId :: ChrId | r }

mkGwasRenderer :: forall m rf rctx.
                  MonadReader (ChrCtx (size :: Bp, color :: Color | rctx)) m
               -- => MonadError Unit m
               => {min :: Number, max :: Number}
               -> m (PureRenderer (GWASFeature rf))
mkGwasRenderer {min, max} = do
  ctx <- ask
  let renderer f = do
        size <- _.size <$> Map.lookup f.chrId ctx
        color <- _.color <$> Map.lookup f.chrId ctx
        let r = 2.2
            x = unwrap $ f.pos / size
            y = (f.score - min) / (max - min)
            c = circle x y r
            out = outlined (outlineColor color) c
            fill = filled (fillColor color) c
            drawing = out <> fill

        point <- normPoint {x, y}
        pure { drawing, point }

  pure renderer

pureRender :: forall f a.
              Filterable f
           => PureRenderer a
           -> f a
           -> f { drawing :: Drawing, point :: Normalized Point }
pureRender r as = filterMap r as

-- csysFrames :: forall i c.
--               { interval :: Interval BrowserPoint, chrSize :: Bp }
--            -> Pixels
--            ->

drawPureInterval :: forall f r .
                    Foldable f
                 => { height :: Pixels | r }
                 -> f { drawing :: Drawing, point :: Normalized Point }
                 -> { width :: Pixels, offset :: Pixels }
                 -> Drawing
drawPureInterval {height} ds {width, offset} = foldMap render' ds
  where render' {drawing, point} =
          let {x,y} = nPointToFrame width height $ point
          in translate (x + offset) y drawing

drawPureIntervals :: forall r.
                     { height :: Pixels | r }
                  -> Array (Tuple (Array { drawing :: Drawing, point :: Normalized Point })
                            { width :: Pixels, offset :: Pixels })
                  -> Drawing
drawPureIntervals h frames = foldMap (uncurry $ drawPureInterval h) frames

drawDataIv :: forall i f a r.
              Ord i
           => Foldable f
           => Filterable f
           => CoordSys i BrowserPoint
           -> { width :: Pixels, height :: Pixels, yOffset :: Pixels }
           -> PureRenderer a
           -> Map i (f a)
           -> Interval BrowserPoint
           -> Drawing
drawDataIv cs@(CoordSys s) canvasBox renderer dat =
  let drawings :: Map i (Array { drawing :: _, point :: _ })
      drawings = map (Array.fromFoldable <<< pureRender renderer) dat

      -- 1. get the relevant browser intervals from the current view;
      --    i.e. filter from coordsys
      ivalsInView :: Interval BrowserPoint -> Array (Tuple i (ChrInterval BrowserPoint))
      ivalsInView v = fromMaybe [] $ viewIntervals cs v

      -- 2. big money
      toDraw :: Interval BrowserPoint -> Array (Tuple (Array _) _)
      toDraw vw = map (bimap f g) $ ivalsInView vw
        where f :: i -> Array {drawing :: Drawing, point :: _}
              f i = fromMaybe [] $ Map.lookup i drawings
              g :: ChrInterval BrowserPoint -> {width :: Number, offset :: Number}
              g = intervalToScreen s.padding canvasBox.width vw <<< _.interval

  in \view -> translate 0.0 (canvasBox.height - canvasBox.yOffset)
                $ scale 1.0 (-1.0)
                $ drawPureIntervals canvasBox (toDraw view)

-- TODO simplify these two functions by extracting `padding` and `height` to another argument;
-- after all, only `width` changes per frame
drawPureFrame :: forall f r.
                 Foldable f
              => f { drawing :: Drawing, point :: Normalized Point | r }
              -> { width :: Pixels, padding :: Pixels, height :: Pixels }
              -> Drawing
drawPureFrame fs { width, padding, height } = foldMap render' fs
  where render' {drawing, point} =
            let {x,y} = nPointToFrame (width - padding * 2.0) height $ point
            in translate (x + padding) y drawing

-- Draw a collection of , lined up one after another
drawPureFrames :: forall a.
                  Array (Tuple (Array { drawing :: Drawing, point :: Normalized Point })
                               { width :: Pixels, padding :: Pixels, height :: Pixels })
               -> Drawing
drawPureFrames frames = fold $ Array.zipWith (\o -> translate o 0.0) os drawings'
  where os = framesOffsets $ snd <$> frames
        drawings' = map (uncurry drawPureFrame) frames

framesOffsets :: forall r.
                 Array { width :: Pixels | r }
              -> Array Pixels
framesOffsets fs = 0.0 : scanl (\o {width} -> width + o) 0.0 fs
    -- add 0.0 since scanl in framesOffsets doesn't include seed

shiftRendererMinY :: forall rf.
                      RowLacks "minY" rf
                   => Number
                   -> { min :: Number, max :: Number }
                   -> PureRenderer (Record rf)
                   -> PureRenderer (Record (minY :: Number | rf))
shiftRendererMinY dist s render f = do
  {drawing, point} <- render (Record.delete (SProxy :: SProxy "minY") f)
  let {x,y} = unwrap point
      normY = (f.minY - s.min) / (s.max - s.min)
      y' = min (normY + dist) 0.95

  point' <- normPoint {x, y: y'}
  pure {drawing, point: point'}

intersection :: forall k a b.
                Ord k
             => Map k a
             -> Map k b
             -> Map k a
intersection a b = Map.filterKeys (flip Map.member b) a

zipMaps :: forall k a b.
           Ord k
        => Map k a
        -> Map k b
        -> Map k (Tuple a b)
zipMaps a b =
  let kas = Array.unzip $ Map.toAscUnfoldable $ a `intersection` b
      kbs = Array.unzip $ Map.toAscUnfoldable $ b `intersection` a
      kabs = uncurry Array.zip $ map (Array.zip (snd kas)) kbs
  in Map.fromFoldable kabs

zipMapsWith :: forall k a b c.
               Ord k
            => (a -> b -> c)
            -> Map k a
            -> Map k b
            -> Map k c
zipMapsWith f a b = uncurry f <$> zipMaps a b

groupToChrs :: forall a f rData.
               Monoid (f {chrId :: ChrId | rData})
            => Foldable f
            => Applicative f
            => f { chrId :: ChrId | rData }
            -> Map ChrId (f { chrId :: ChrId | rData })
groupToChrs = foldl (\chrs r@{chrId} -> Map.alter (add r) chrId chrs ) mempty
  where add x Nothing   = Just $ pure x
        add x (Just xs) = Just $ pure x <> xs

fetchJSON :: forall a.
             (Json -> Maybe a)
          -> String
          -> Aff _ (Array a)
fetchJSON p url = do
  json <- _.response <$> Affjax.get url

  case json ^? _Array of
    Nothing -> throwError $ error "Parse error: JSON is not an array"
    Just as -> case traverse p as of
      Nothing -> throwError $ error "Failed to parse JSON features"
      Just fs -> pure $ fs

gemmaJSONParse :: Json -> Maybe (GWASFeature ())
gemmaJSONParse j = do
  obj <- j ^? _Object
  chrId <- ChrId <$> obj ^? ix "chr" <<< _String
  pos   <- Bp    <$> obj ^? ix "ps"  <<< _Number
  score <-           obj ^? ix "af"  <<< _Number
  pure {pos, score, chrId}

fetchGemmaJSON :: String -> Aff _ (Array (GWASFeature ()))
fetchGemmaJSON = fetchJSON gemmaJSONParse

type GeneRow r = ( geneID :: String
                 , desc :: String
                 , start :: Bp
                 , end :: Bp
                 , name :: String
                 , chrId :: ChrId | r )

type Gene r = Record (GeneRow r)

geneJSONParse :: Json -> Maybe (Gene ())
geneJSONParse j = do
  obj    <- j ^? _Object
  geneID <- obj ^? ix "Gene stable ID" <<< _String
  desc   <- obj ^? ix "Gene description" <<< _String
  name   <- obj ^? ix "Gene name" <<< _String
  start  <- Bp    <$> obj ^? ix "Gene start (bp)"  <<< _Number
  end    <- Bp    <$> obj ^? ix "Gene end (bp)"  <<< _Number
  chrId  <- ChrId <$> obj ^? ix "ChrId" <<< _String
  pure {geneID, desc, name, start, end, chrId}

fetchGeneJSON :: String -> Aff _ (Array (Gene ()))
fetchGeneJSON = fetchJSON geneJSONParse

type AnnotRow r = ( geneID :: String
                  , desc :: String
                  , pos :: Bp
                  , name :: String
                  , chrId :: ChrId | r )

type Annot r = Record (AnnotRow r)

mkAnnotRenderer :: forall m rf rctx.
                   MonadReader (ChrCtx (size :: Bp | rctx)) m
                => m (PureRenderer (Annot rf))
mkAnnotRenderer = do
  ctx <- ask
  let font' = font sansSerif 12 mempty
  let renderer f = do
        size <- _.size <$> Map.lookup f.chrId ctx

        let rad = 5.0
            x = unwrap $ f.pos / size
            y = 0.0
            c = circle x y rad
            out  = outlined (outlineColor maroon <> lineWidth 3.0) c
            fill = filled   (fillColor red) c
            -- the canvas is flipped so y-axis increases upward, need to flip the text too
            text' = scale 1.0 (-1.0)
                    $ Drawing.text font' (x+7.5) (y+2.5) (fillColor black) f.name
            drawing = out <> fill <> text'

        point <- normPoint {x, y}
        pure { drawing, point }

  pure renderer

fetchAnnotJSON :: String -> Aff _ (Array (Annot ()))
fetchAnnotJSON str = map toAnnot <$> fetchJSON geneJSONParse str
  where toAnnot :: Gene () -> Annot ()
        toAnnot gene = { geneID: gene.geneID
                       , desc: gene.desc
                       , pos: gene.start
                       , name: gene.name
                       , chrId: gene.chrId }

bumpAnnots :: forall rAnnot rGWAS.
             RowLacks "minY" (AnnotRow rAnnot)
          => Bp
          -> Map ChrId (List (GWASFeature rGWAS))
          -> Map ChrId (List (Annot rAnnot))
          -> Map ChrId (List (Annot (minY :: Number | rAnnot)))
bumpAnnots radius = zipMapsWith (map <<< bumpAnnot)
  where maxScoreIn :: Bp -> Bp -> List (GWASFeature rGWAS) -> Number
        maxScoreIn l r gwas = fromMaybe 0.5 $ maximum
                              $ map (\g -> if g.pos >= l && g.pos <= r
                                           then g.score else 0.0) gwas
        bumpAnnot :: List (GWASFeature rGWAS) -> Annot rAnnot -> Annot (minY :: Number | rAnnot)
        bumpAnnot l g = let minY = maxScoreIn (g.pos - radius) (g.pos + radius) l
                       in Record.insert (SProxy :: SProxy "minY") minY g

getDataDemo :: { gwas :: String
               , annots :: String }
            -> Aff _ { gwas  :: Map ChrId (List (GWASFeature ()       ))
                     , annots :: Map ChrId (List (Annot (minY :: Number)))
                     }
getDataDemo urls = do
  gwas <- fetchGemmaJSON urls.gwas
  annots' <- fetchAnnotJSON urls.annots
  -- Divide data by chromosomes
  let gwasChr :: Map ChrId (List (GWASFeature ()))
      gwasChr = List.fromFoldable <$> groupToChrs gwas
  let annotsChr :: Map ChrId (List (Annot ()))
      annotsChr = List.fromFoldable <$> groupToChrs annots'
  let bumpedAnnots :: Map ChrId (List (Annot (minY :: Number)))
      bumpedAnnots = bumpAnnots (Bp 1000000.0) gwasChr annotsChr

  pure { gwas: gwasChr, annots: bumpedAnnots }

renderersDemo :: { min :: Number, max :: Number }
              -> { gwas  :: PureRenderer (GWASFeature ()       )
                 , annots :: PureRenderer (Annot (minY :: Number)) }
renderersDemo s = { gwas, annots }
  where colorsCtx = zipMapsWith (\r {color} -> Record.insert (SProxy :: SProxy "color") color r)
                      mouseChrCtx mouseColors
        gwas :: PureRenderer (GWASFeature ())
        gwas = mkGwasRenderer s colorsCtx

        annots :: PureRenderer (Annot (minY :: Number))
        annots = shiftRendererMinY 0.06 s $ mkAnnotRenderer mouseChrCtx

ruler :: forall r.
         { min :: Number, max :: Number }
      -> Number
      -> Color
      -> { width :: Pixels, height :: Pixels, yOffset :: Pixels | r}
      -> Drawing
ruler {min, max} val color f = outlined outline rulerDrawing
  where normY = (val - min) / (max - min)
        y = f.height - (normY * f.height + f.yOffset)
        outline = outlineColor color
        rulerDrawing = Drawing.path [{x: 0.0, y}, {x: f.width, y}]

drawDemo :: forall f.
            Foldable f
         => Filterable f
         => { min :: Number, max :: Number }
         -> Number
         -> { width :: Pixels, height :: Pixels, padding :: Pixels, yOffset :: Pixels }
         -> { gwas :: Map ChrId (f (GWASFeature ()))
            , annots :: Map ChrId (f (Annot (minY :: Number))) }
         -> Array ChrId
         -> Drawing
drawDemo s sig f {gwas, annots} =
  let renderers = renderersDemo s
      ruler' = ruler s sig red
      drawGwas   = drawData f mouseChrCtx renderers.gwas   gwas
      drawAnnots = drawData f mouseChrCtx renderers.annots annots
  in \chrs -> (drawGwas chrs) <> (drawAnnots chrs) <> ruler' f

drawDemo' :: forall f.
            Foldable f
         => Filterable f
         => CoordSys _ _
         -> { min :: Number, max :: Number }
         -> Number
         -> { width :: Pixels, height :: Pixels, yOffset :: Pixels }
         -> { gwas :: Map ChrId (f (GWASFeature ()))
            , annots :: Map ChrId (f (Annot (minY :: Number))) }
         -> Interval BrowserPoint
         -> Drawing
drawDemo' cs s sig canvasBox {gwas, annots} =
  let renderers = renderersDemo s
      ruler' = ruler s sig red
      drawGwas   = drawDataIv cs canvasBox renderers.gwas gwas
      drawAnnots = drawDataIv cs canvasBox renderers.annots annots
  in \view -> (drawGwas view) <> (drawAnnots view) <> ruler' canvasBox

-- Draw data by rendering it only once
drawData :: forall f a r.
            Foldable f
         => Filterable f
         -- NOTE! the width is the canvas width, not frame. Same w/ yOffset
         => { width :: Pixels, height :: Pixels, padding :: Pixels, yOffset :: Pixels }
         -> Map ChrId { size :: Bp | r}
         -> PureRenderer a
         -> Map ChrId (f a)
         -> Array ChrId
         -> Drawing
drawData frameBox chrCtx renderer dat =
  let drawings :: Map ChrId (Array {drawing :: Drawing, point :: _})
      drawings = map (Array.fromFoldable <<< pureRender renderer) dat

      mkFrame :: Array ChrId -> ChrId -> Maybe {width :: _, height :: _, padding :: _}
      mkFrame chrs' chr = do
        {size} <- Map.lookup chr chrCtx
        let total = sum $ filterMap (\c -> _.size <$> Map.lookup c chrCtx) chrs'
            width = (unwrap $ size / total) * frameBox.width
        pure { height: frameBox.height - frameBox.yOffset, padding: frameBox.padding, width }

      frames :: Array ChrId -> Array (Tuple (Array _) (_))
      frames chrs' = Array.zip (map (\c -> fromMaybe [] $ Map.lookup c drawings) chrs')
                               (filterMap (mkFrame chrs') chrs')

  in \chrs -> translate 0.0 (frameBox.height - frameBox.yOffset)
                $ scale 1.0 (-1.0)
                $ drawPureFrames (frames chrs)

mouseChrIds :: Array ChrId
mouseChrIds =
            [ (ChrId "1")
            , (ChrId "2")
            , (ChrId "3")
            , (ChrId "4")
            , (ChrId "5")
            , (ChrId "6")
            , (ChrId "7")
            , (ChrId "8")
            , (ChrId "9")
            , (ChrId "10")
            , (ChrId "11")
            , (ChrId "12")
            , (ChrId "13")
            , (ChrId "14")
            , (ChrId "15")
            , (ChrId "16")
            , (ChrId "17")
            , (ChrId "18")
            , (ChrId "19")
            , (ChrId "X")
            , (ChrId "Y")
            ]

mouseChrs :: Map ChrId Bp
mouseChrs = Map.fromFoldable $ Array.zip mouseChrIds $
            [ (Bp 195471971.0)
            , (Bp 182113224.0)
            , (Bp 160039680.0)
            , (Bp 156508116.0)
            , (Bp 151834684.0)
            , (Bp 149736546.0)
            , (Bp 145441459.0)
            , (Bp 129401213.0)
            , (Bp 124595110.0)
            , (Bp 130694993.0)
            , (Bp 122082543.0)
            , (Bp 120129022.0)
            , (Bp 120421639.0)
            , (Bp 124902244.0)
            , (Bp 104043685.0)
            , (Bp 98207768.0)
            , (Bp 94987271.0)
            , (Bp 90702639.0)
            , (Bp 61431566.0)
            , (Bp 17103129.0)
            , (Bp 9174469.0)
            ]

mouseColors :: ChrCtx (color :: Color)
mouseColors = Map.fromFoldable $ Array.zip mouseChrIds $ map (\x -> {color: x})
              [ navy, blue, aqua, teal, olive
              , green, lime, yellow, orange, red
              , maroon, fuchsia, purple, navy, blue
              , aqua, teal, olive, green, lime
              , yellow ]

mouseChrCtx :: ChrCtx (size :: Bp)
mouseChrCtx = map (\size -> { size }) mouseChrs

module Genetics.Browser.Track.Backend where

import Prelude

import Color (Color, black)
import Color.Scheme.Clrs (aqua, blue, fuchsia, green, lime, maroon, navy, olive, orange, purple, red, teal, yellow)
import Control.Alt ((<|>))
import Control.Monad.Aff (Aff)
import Control.Monad.Eff.Exception (error)
import Control.Monad.Error.Class (throwError)
import Control.Monad.Reader (class MonadReader, ask)
import Data.Argonaut (Json, _Array, _Number, _Object, _String)
import Data.Array ((:))
import Data.Array as Array
import Data.BigInt (BigInt)
import Data.BigInt as BigInt
import Data.Filterable (class Filterable, filterMap)
import Data.Foldable (class Foldable, fold, foldMap, foldl, maximum, sum)
import Data.FunctorWithIndex (mapWithIndex)
import Data.Int as Int
import Data.Lens (united, (^?))
import Data.Lens.Index (ix)
import Data.List (List)
import Data.List as List
import Data.Map (Map)
import Data.Map as Map
import Data.Maybe (Maybe(Just, Nothing), fromMaybe)
import Data.Monoid (class Monoid, mempty)
import Data.Monoid.Additive (Additive(..))
import Data.Newtype (class Newtype, ala, alaF, unwrap)
import Data.Ord.Max (Max(..))
import Data.Ratio (Ratio(..), denominator, numerator, (%))
import Data.Ratio as Ratio
import Data.Record as Record
import Data.Symbol (SProxy(..))
import Data.Traversable (scanl, traverse)
import Data.Tuple (Tuple(..), fst, snd, uncurry)
import Data.Variant (class Contractable, Variant)
import Data.Variant as Variant
import Genetics.Browser.Types (Bp(Bp), BrowserPoint, ChrId(ChrId), ChrInterval, CoordSys(..), Interval(..), Point, intervalSeenFromCanvas, viewIntervals)
import Genetics.Browser.View (Pixels)
import Graphics.Drawing (Drawing, circle, fillColor, filled, lineWidth, outlineColor, outlined, rectangle, scale, translate)
import Graphics.Drawing as Drawing
import Graphics.Drawing.Font (font, sansSerif)
import Network.HTTP.Affjax as Affjax
import Type.Prelude (class IsSymbol, class RowLacks)
import Unsafe.Coerce (unsafeCoerce)

type Frame a = { padding :: Pixels, width :: Pixels, contents :: a }

type ChrCtx r = Map ChrId (Record r)

-- totalSize :: forall r.
--              ChrCtx (size :: Bp | r)
--           -> Bp
-- totalSize chrCtx = alaF Additive foldMap _.size chrCtx

newtype Normalized a = Normalized a

derive instance newtypeNormalized :: Newtype (Normalized a) _

normalizePoint :: { width :: Number
                  , height :: Number }
               -> Point
               -> Normalized Point
normalizePoint {width, height} {x, y} = Normalized { x: x', y: y' }
  where x' = x / width
        y' = y / height

normPoint :: Point -> Maybe (Normalized Point)
normPoint p@{x, y}
  | x < 0.0 || x > 1.0 = Nothing
  | y < 0.0 || y > 1.0 = Nothing
  | otherwise = Just $ Normalized p

nPointToFrame :: Pixels -> Pixels -> Normalized Point -> Point
nPointToFrame w h (Normalized p) = {x: p.x * w, y: p.y * h}

-- A renderer draws a single value to a normalized "canvas",
-- i.e. the whole chromosome is located in x = (0.0, 1.0),
-- and the whole track height in y = (0.0, 1.0).
-- It can fail if the given feature for some reason cannot be rendered,
-- either because the feature lacks information, or because the context lacks something.

type PureRenderer a = a -> Maybe { drawing :: Drawing
                                 , point   :: Normalized Point
                                 }

-- Drawings are not entirely pure. They can depend on the width of the
-- frame, if they something that spans across a range of the genome.
-- So, the `drawing` field should really have type
--   Pixels -> Drawing
-- where the `Pixels` is the width of the frame. Renderers already
-- have access to the chr size when created, so the width is all that's needed.
type PureRenderer' a = a -> Maybe { drawing :: Pixels -> Drawing
                                  , point   :: Normalized Point
                                  }

-- tagRenderer :: forall a sym r1 r2.
--                RowCons sym a r1 r2
--             => IsSymbol sym
--             => SProxy sym
--             -> PureRenderer a
--             -> PureRenderer (Variant r2)
-- tagRenderer sym renderer var = Variant.prj sym var >>= renderer

-- combineRenderers :: forall r1 r2 r3.
--                     Union r1 r2 r3
--                  => Contractable r3 r1
--                  => Contractable r3 r2
--                  => PureRenderer (Variant r1)
--                  -> PureRenderer (Variant r2)
--                  -> PureRenderer (Variant r3)
-- combineRenderers r1 r2 var = (Variant.contract var >>= r1) <|>
--                              (Variant.contract var >>= r2)

type GWASFeature r = { score :: Number
                     , pos :: Bp
                     , chrId :: ChrId | r }

mkGwasRenderer :: forall m rf rctx.
                  MonadReader (ChrCtx (size :: Bp, color :: Color | rctx)) m
               -- => MonadError Unit m
               => {min :: Number, max :: Number}
               -> m (PureRenderer (GWASFeature rf))
mkGwasRenderer {min, max} = do
  ctx <- ask
  let renderer f = do
        size <- _.size <$> Map.lookup f.chrId ctx
        color <- _.color <$> Map.lookup f.chrId ctx
        let r = 2.2
            x = unwrap $ f.pos / size
            y = (f.score - min) / (max - min)
            c = circle x y r
            out = outlined (outlineColor color) c
            fill = filled (fillColor color) c
            drawing = out <> fill

        point <- normPoint {x, y}
        pure { drawing, point }

  pure renderer

pureRender :: forall f a.
              Filterable f
           => PureRenderer a
           -> f a
           -> f { drawing :: Drawing, point :: Normalized Point }
pureRender r as = filterMap r as

-- csysFrames :: forall i c.
--               { interval :: Interval BrowserPoint, chrSize :: Bp }
--            -> Pixels
--            ->

-- TODO simplify these two functions by extracting `padding` and `height` to another argument;
-- after all, only `width` changes per frame
drawPureFrame :: forall f r.
                 Foldable f
              => f { drawing :: Drawing, point :: Normalized Point | r }
              -> { width :: Pixels, padding :: Pixels, height :: Pixels }
              -> Drawing
drawPureFrame fs { width, padding, height } = foldMap render' fs
  where render' {drawing, point} =
            let {x,y} = nPointToFrame (width - padding * 2.0) height $ point
            in translate (x + padding) y drawing

-- Draw a collection of , lined up one after another
drawPureFrames :: forall a.
                  Array (Tuple (Array { drawing :: Drawing, point :: Normalized Point })
                               { width :: Pixels, padding :: Pixels, height :: Pixels })
               -> Drawing
drawPureFrames frames = fold $ Array.zipWith (\o -> translate o 0.0) os drawings'
  where os = framesOffsets $ snd <$> frames
        drawings' = map (uncurry drawPureFrame) frames

framesOffsets :: forall r.
                 Array { width :: Pixels | r }
              -> Array Pixels
framesOffsets fs = 0.0 : scanl (\o {width} -> width + o) 0.0 fs
    -- add 0.0 since scanl in framesOffsets doesn't include seed

shiftRendererMinY :: forall rf.
                      RowLacks "minY" rf
                   => Number
                   -> { min :: Number, max :: Number }
                   -> PureRenderer (Record rf)
                   -> PureRenderer (Record (minY :: Number | rf))
shiftRendererMinY dist s render f = do
  {drawing, point} <- render (Record.delete (SProxy :: SProxy "minY") f)
  let {x,y} = unwrap point
      normY = (f.minY - s.min) / (s.max - s.min)
      y' = min (normY + dist) 0.95

  point' <- normPoint {x, y: y'}
  pure {drawing, point: point'}

intersection :: forall k a b.
                Ord k
             => Map k a
             -> Map k b
             -> Map k a
intersection a b = Map.filterKeys (flip Map.member b) a

zipMaps :: forall k a b.
           Ord k
        => Map k a
        -> Map k b
        -> Map k (Tuple a b)
zipMaps a b =
  let kas = Array.unzip $ Map.toAscUnfoldable $ a `intersection` b
      kbs = Array.unzip $ Map.toAscUnfoldable $ b `intersection` a
      kabs = uncurry Array.zip $ map (Array.zip (snd kas)) kbs
  in Map.fromFoldable kabs

zipMapsWith :: forall k a b c.
               Ord k
            => (a -> b -> c)
            -> Map k a
            -> Map k b
            -> Map k c
zipMapsWith f a b = uncurry f <$> zipMaps a b

groupToChrs :: forall a f rData.
               Monoid (f {chrId :: ChrId | rData})
            => Foldable f
            => Applicative f
            => f { chrId :: ChrId | rData }
            -> Map ChrId (f { chrId :: ChrId | rData })
groupToChrs = foldl (\chrs r@{chrId} -> Map.alter (add r) chrId chrs ) mempty
  where add x Nothing   = Just $ pure x
        add x (Just xs) = Just $ pure x <> xs

fetchJSON :: forall a.
             (Json -> Maybe a)
          -> String
          -> Aff _ (Array a)
fetchJSON p url = do
  json <- _.response <$> Affjax.get url

  case json ^? _Array of
    Nothing -> throwError $ error "Parse error: JSON is not an array"
    Just as -> case traverse p as of
      Nothing -> throwError $ error "Failed to parse JSON features"
      Just fs -> pure $ fs

gemmaJSONParse :: Json -> Maybe (GWASFeature ())
gemmaJSONParse j = do
  obj <- j ^? _Object
  chrId <- ChrId <$> obj ^? ix "chr" <<< _String
  pos   <- Bp    <$> obj ^? ix "ps"  <<< _Number
  score <-           obj ^? ix "af"  <<< _Number
  pure {pos, score, chrId}

fetchGemmaJSON :: String -> Aff _ (Array (GWASFeature ()))
fetchGemmaJSON = fetchJSON gemmaJSONParse

type GeneRow r = ( geneID :: String
                 , desc :: String
                 , start :: Bp
                 , end :: Bp
                 , name :: String
                 , chrId :: ChrId | r )

type Gene r = Record (GeneRow r)

geneJSONParse :: Json -> Maybe (Gene ())
geneJSONParse j = do
  obj    <- j ^? _Object
  geneID <- obj ^? ix "Gene stable ID" <<< _String
  desc   <- obj ^? ix "Gene description" <<< _String
  name   <- obj ^? ix "Gene name" <<< _String
  start  <- Bp    <$> obj ^? ix "Gene start (bp)"  <<< _Number
  end    <- Bp    <$> obj ^? ix "Gene end (bp)"  <<< _Number
  chrId  <- ChrId <$> obj ^? ix "ChrId" <<< _String
  pure {geneID, desc, name, start, end, chrId}

fetchGeneJSON :: String -> Aff _ (Array (Gene ()))
fetchGeneJSON = fetchJSON geneJSONParse

type AnnotRow r = ( geneID :: String
                  , desc :: String
                  , pos :: Bp
                  , name :: String
                  , chrId :: ChrId | r )

type Annot r = Record (AnnotRow r)

mkAnnotRenderer :: forall m rf rctx.
                   MonadReader (ChrCtx (size :: Bp | rctx)) m
                => m (PureRenderer (Annot rf))
mkAnnotRenderer = do
  ctx <- ask
  let font' = font sansSerif 12 mempty
  let renderer f = do
        size <- _.size <$> Map.lookup f.chrId ctx

        let rad = 5.0
            x = unwrap $ f.pos / size
            y = 0.0
            c = circle x y rad
            out  = outlined (outlineColor maroon <> lineWidth 3.0) c
            fill = filled   (fillColor red) c
            -- the canvas is flipped so y-axis increases upward, need to flip the text too
            text' = scale 1.0 (-1.0)
                    $ Drawing.text font' (x+7.5) (y+2.5) (fillColor black) f.name
            drawing = out <> fill <> text'

        point <- normPoint {x, y}
        pure { drawing, point }

  pure renderer

fetchAnnotJSON :: String -> Aff _ (Array (Annot ()))
fetchAnnotJSON str = map toAnnot <$> fetchJSON geneJSONParse str
  where toAnnot :: Gene () -> Annot ()
        toAnnot gene = { geneID: gene.geneID
                       , desc: gene.desc
                       , pos: gene.start
                       , name: gene.name
                       , chrId: gene.chrId }

bumpAnnots :: forall rAnnot rGWAS.
             RowLacks "minY" (AnnotRow rAnnot)
          => Bp
          -> Map ChrId (List (GWASFeature rGWAS))
          -> Map ChrId (List (Annot rAnnot))
          -> Map ChrId (List (Annot (minY :: Number | rAnnot)))
bumpAnnots radius = zipMapsWith (map <<< bumpAnnot)
  where maxScoreIn :: Bp -> Bp -> List (GWASFeature rGWAS) -> Number
        maxScoreIn l r gwas = fromMaybe 0.5 $ maximum
                              $ map (\g -> if g.pos >= l && g.pos <= r
                                           then g.score else 0.0) gwas
        bumpAnnot :: List (GWASFeature rGWAS) -> Annot rAnnot -> Annot (minY :: Number | rAnnot)
        bumpAnnot l g = let minY = maxScoreIn (g.pos - radius) (g.pos + radius) l
                       in Record.insert (SProxy :: SProxy "minY") minY g

getDataDemo :: { gwas :: String
               , annots :: String }
            -> Aff _ { gwas  :: Map ChrId (List (GWASFeature ()       ))
                     , annots :: Map ChrId (List (Annot (minY :: Number)))
                     }
getDataDemo urls = do
  gwas <- fetchGemmaJSON urls.gwas
  annots' <- fetchAnnotJSON urls.annots
  -- Divide data by chromosomes
  let gwasChr :: Map ChrId (List (GWASFeature ()))
      gwasChr = List.fromFoldable <$> groupToChrs gwas
  let annotsChr :: Map ChrId (List (Annot ()))
      annotsChr = List.fromFoldable <$> groupToChrs annots'
  let bumpedAnnots :: Map ChrId (List (Annot (minY :: Number)))
      bumpedAnnots = bumpAnnots (Bp 1000000.0) gwasChr annotsChr

  pure { gwas: gwasChr, annots: bumpedAnnots }

renderersDemo :: { min :: Number, max :: Number }
              -> { gwas  :: PureRenderer (GWASFeature ()       )
                 , annots :: PureRenderer (Annot (minY :: Number)) }
renderersDemo s = { gwas, annots }
  where colorsCtx = zipMapsWith (\r {color} -> Record.insert (SProxy :: SProxy "color") color r)
                      mouseChrCtx mouseColors
        gwas :: PureRenderer (GWASFeature ())
        gwas = mkGwasRenderer s colorsCtx

        annots :: PureRenderer (Annot (minY :: Number))
        annots = shiftRendererMinY 0.06 s $ mkAnnotRenderer mouseChrCtx

ruler :: forall r.
         { min :: Number, max :: Number }
      -> Number
      -> Color
      -> { width :: Pixels, height :: Pixels, yOffset :: Pixels | r}
      -> Drawing
ruler {min, max} val color f = outlined outline rulerDrawing
  where normY = (val - min) / (max - min)
        y = f.height - (normY * f.height + f.yOffset)
        outline = outlineColor color
        rulerDrawing = Drawing.path [{x: 0.0, y}, {x: f.width, y}]

drawDemo :: forall f.
            Foldable f
         => Filterable f
         => { min :: Number, max :: Number }
         -> Number
         -> { width :: Pixels, height :: Pixels, padding :: Pixels, yOffset :: Pixels }
         -> { gwas :: Map ChrId (f (GWASFeature ()))
            , annots :: Map ChrId (f (Annot (minY :: Number))) }
         -> Array ChrId
         -> Drawing
drawDemo s sig f {gwas, annots} =
  let renderers = renderersDemo s
      ruler' = ruler s sig red
      drawGwas   = drawData f mouseChrCtx renderers.gwas   gwas
      drawAnnots = drawData f mouseChrCtx renderers.annots annots
  in \chrs -> (drawGwas chrs) <> (drawAnnots chrs) <> ruler' f

drawDemo' :: _
drawDemo' = unsafeCoerce

mkFrame :: forall r i.
           { width :: Pixels, height :: Pixels | r }
        -> Interval BrowserPoint
        -> Interval BrowserPoint
        -> { width :: Pixels, height :: Pixels, offset :: Pixels }
mkFrame canvasSize interval view@(Interval l r) =
  let (Interval l r) = intervalSeenFromCanvas canvasSize interval view
      width = r - l
      offset = l
  in { width, height: canvasSize.height, offset }

mkFrames :: forall i c r.
            { width :: Pixels, height :: Pixels | r }
         -> Array (Interval BrowserPoint)
         -> Interval BrowserPoint
         -> Array ( {width :: Pixels, height :: Pixels, offset :: Pixels} )
mkFrames canvasSize ivals view = map (mkFrame canvasSize view) ivals

drawData' :: forall i f a r.
             Ord i
          => Foldable f
          => Filterable f
          => CoordSys i BrowserPoint
          -> { width :: Pixels, height :: Pixels, padding :: Pixels, yOffset :: Pixels }
          -> PureRenderer a
          -> Map i (f a)
          -> Interval BrowserPoint
          -> Drawing
drawData' cs canvasBox renderer dat =
  let drawings :: Map i (Array {drawing :: Drawing, point :: _})
      drawings = map (Array.fromFoldable <<< pureRender renderer) dat

      fIvals :: _
      fIvals v' = (map <<< map) _.interval $ viewIntervals cs v'

      -- mkFrame :: Array i -> i -> Maybe {width :: _, height :: _, padding :: _}
      -- mkFrame chrs' chr = do
      --   {size} <- Map.lookup chr chrCtx
      --   let total = sum $ filterMap (\c -> _.size <$> Map.lookup c chrCtx) chrs'
      --       width = (unwrap $ size / total) * frameBox.width
      --   pure { height: frameBox.height - frameBox.yOffset, padding: frameBox.padding, width }

      -- frames :: Array ChrId -> Array (Tuple (Array _) (_))
      -- frames chrs' = Array.zip (map (\c -> fromMaybe [] $ Map.lookup c drawings) chrs')
      --                          (filterMap (mkFrame chrs') chrs')

      mkFrames' :: Interval BrowserPoint -> Array { | _ }
      mkFrames' v = mkFrames canvasBox (fromMaybe [] $ fIvals v) v

      frames :: Interval BrowserPoint -> Array (Tuple (Array _) (_))
      frames v = Array.zip (unsafeCoerce unit) (mkFrames' v)

  in \view -> translate 0.0 (canvasBox.height - canvasBox.yOffset)
                $ scale 1.0 (-1.0)
                $ drawPureFrames (frames view)

-- Draw data by rendering it only once
drawData :: forall f a r.
            Foldable f
         => Filterable f
         -- NOTE! the width is the canvas width, not frame. Same w/ yOffset
         => { width :: Pixels, height :: Pixels, padding :: Pixels, yOffset :: Pixels }
         -> Map ChrId { size :: Bp | r}
         -> PureRenderer a
         -> Map ChrId (f a)
         -> Array ChrId
         -> Drawing
drawData frameBox chrCtx renderer dat =
  let drawings :: Map ChrId (Array {drawing :: Drawing, point :: _})
      drawings = map (Array.fromFoldable <<< pureRender renderer) dat

      mkFrame :: Array ChrId -> ChrId -> Maybe {width :: _, height :: _, padding :: _}
      mkFrame chrs' chr = do
        {size} <- Map.lookup chr chrCtx
        let total = sum $ filterMap (\c -> _.size <$> Map.lookup c chrCtx) chrs'
            width = (unwrap $ size / total) * frameBox.width
        pure { height: frameBox.height - frameBox.yOffset, padding: frameBox.padding, width }

      frames :: Array ChrId -> Array (Tuple (Array _) (_))
      frames chrs' = Array.zip (map (\c -> fromMaybe [] $ Map.lookup c drawings) chrs')
                               (filterMap (mkFrame chrs') chrs')

  in \chrs -> translate 0.0 (frameBox.height - frameBox.yOffset)
                $ scale 1.0 (-1.0)
                $ drawPureFrames (frames chrs)

mouseChrIds :: Array ChrId
mouseChrIds =
            [ (ChrId "1")
            , (ChrId "2")
            , (ChrId "3")
            , (ChrId "4")
            , (ChrId "5")
            , (ChrId "6")
            , (ChrId "7")
            , (ChrId "8")
            , (ChrId "9")
            , (ChrId "10")
            , (ChrId "11")
            , (ChrId "12")
            , (ChrId "13")
            , (ChrId "14")
            , (ChrId "15")
            , (ChrId "16")
            , (ChrId "17")
            , (ChrId "18")
            , (ChrId "19")
            , (ChrId "X")
            , (ChrId "Y")
            ]

mouseChrs :: Map ChrId Bp
mouseChrs = Map.fromFoldable $ Array.zip mouseChrIds $
            [ (Bp 195471971.0)
            , (Bp 182113224.0)
            , (Bp 160039680.0)
            , (Bp 156508116.0)
            , (Bp 151834684.0)
            , (Bp 149736546.0)
            , (Bp 145441459.0)
            , (Bp 129401213.0)
            , (Bp 124595110.0)
            , (Bp 130694993.0)
            , (Bp 122082543.0)
            , (Bp 120129022.0)
            , (Bp 120421639.0)
            , (Bp 124902244.0)
            , (Bp 104043685.0)
            , (Bp 98207768.0)
            , (Bp 94987271.0)
            , (Bp 90702639.0)
            , (Bp 61431566.0)
            , (Bp 17103129.0)
            , (Bp 9174469.0)
            ]

mouseColors :: ChrCtx (color :: Color)
mouseColors = Map.fromFoldable $ Array.zip mouseChrIds $ map (\x -> {color: x})
              [ navy, blue, aqua, teal, olive
              , green, lime, yellow, orange, red
              , maroon, fuchsia, purple, navy, blue
              , aqua, teal, olive, green, lime
              , yellow ]

mouseChrCtx :: ChrCtx (size :: Bp)
mouseChrCtx = map (\size -> { size }) mouseChrs


refine double y-axes tooltip and color

refine double y-axes tooltip and color

{-
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.Chart.BuildOptions.Area where

import SlamData.Prelude

import Data.Argonaut (JCursor)
import Data.Array ((!!), cons)
import Data.Array as A
import Data.Foldable as F
import Data.Function (on)
import Data.Int as Int
import Data.Lens (view)
import Data.List (List(..), replicate, length, zip, range)
import Data.List as L
import Data.Map (Map)
import Data.Map as M
import Data.String as Str

import ECharts as EC

import SlamData.Form.Select (_value)
import SlamData.Workspace.Card.Chart.Aggregation (Aggregation(..), runAggregation)
import SlamData.Workspace.Card.Chart.Axis as Ax
import SlamData.Workspace.Card.Chart.ChartConfiguration (ChartConfiguration)
import SlamData.Workspace.Card.Chart.BuildOptions.Common (Key, ChartAxises, commonNameMap, keyCategory, colors, mixAxisLabelAngleAndFontSize, buildChartAxises, mkKey, getShadeColor, toRGBAString)

import Math as Math

import Utils (stringToNumber)
import Utils.DOM (getTextWidthPure)

type LabeledPointPairs = M.Map Key (Tuple (Array Number) (Array Number))
type LineData = L.List (Tuple Key (Tuple Number Number))

lineData ∷ ChartAxises → LineData
lineData axises =
  let
    lr =
      lineRawData
        dimensions
        firstSeries
        secondSeries
        firstValues
        secondValues
        M.empty
  in
    aggregatePairs firstAgg secondAgg lr
  where
  firstAgg ∷ Aggregation
  firstAgg = fromMaybe Sum $ join (axises.aggregations !! 0)

  secondAgg ∷ Aggregation
  secondAgg = fromMaybe Sum $ join (axises.aggregations !! 1)

  dimensions ∷ List (Maybe String)
  dimensions = fromMaybe Nil $ axises.dimensions !! 0

  firstValues ∷ List (Maybe Number)
  firstValues = fromMaybe Nil $ axises.measures !! 0

  firstSeries ∷ List (Maybe String)
  firstSeries = fromMaybe nothings $ axises.series !! 0

  secondSeries ∷ List (Maybe String)
  secondSeries = fromMaybe nothings $ axises.series !! 1

  secondValues ∷ List (Maybe Number)
  secondValues = fromMaybe nothings $ axises.measures !! 1

  nothings ∷ ∀ a. List (Maybe a)
  nothings = flip replicate Nothing $ maxLen firstValues dimensions

  maxLen ∷ ∀ a b. List a → List b → Int
  maxLen lstA lstB =
    let lA = length lstA
        lB = length lstB
    in if lA > lB then lA else lB

lineRawData
  ∷ List (Maybe String)
   → List (Maybe String)
   → List (Maybe String)
   → List (Maybe Number)
   → List (Maybe Number)
   → LabeledPointPairs
   → LabeledPointPairs
lineRawData Nil _ _ _ _ acc = acc
lineRawData _ Nil _ _ _ acc = acc
lineRawData _ _ Nil _ _ acc = acc
lineRawData _ _ _ Nil _ acc = acc
lineRawData _ _ _ _ Nil acc = acc
lineRawData (Cons Nothing _) _ _ _ _ acc = acc
lineRawData
  (Cons (Just dimension) dims)
  (Cons mbFirstSerie firstSeries)
  (Cons mbSecondSerie secondSeries)
  (Cons mbFirstValue firstValues)
  (Cons mbSecondValue secondValues)
  acc =
    lineRawData dims firstSeries secondSeries firstValues secondValues
    $ M.alter (alterFn $ Tuple firstVal secondVal) key acc
  where
  firstVal ∷ Number
  firstVal = fromMaybe zero mbFirstValue

  secondVal ∷ Number
  secondVal = fromMaybe zero mbSecondValue

  key ∷ Key
  key = mkKey dimension mbFirstSerie mbSecondSerie

  alterFn
    ∷ Tuple Number Number → Maybe (Tuple (Array Number) (Array Number))
    → Maybe (Tuple (Array Number) (Array Number))
  alterFn (Tuple v1 v2) acc =
    case fromMaybe (Tuple [] []) acc of
      Tuple v1s v2s → pure $ Tuple (cons v1 v1s) (cons v2 v2s)

aggregatePairs ∷ Aggregation → Aggregation → LabeledPointPairs → LineData
aggregatePairs fAgg sAgg lp =
  M.toList $ map (bimap (runAggregation fAgg) (runAggregation sAgg)) lp

buildArea
  ∷ M.Map JCursor Ax.Axis
   → Int
   → Int
   → Boolean
   → Boolean
   → ChartConfiguration
   → EC.Option
buildArea axises angle size stacked smooth conf = case preSeries of
  xAxis × series × longestCat →
    EC.Option EC.optionDefault
      { series = Just $ map Just series
      , xAxis =
          Just $ EC.OneAxis $ EC.Axis
          $ mixAxisLabelAngleAndFontSize angle size xAxis
      , yAxis = Just yAxis
      , tooltip = Just tooltip
      , legend = Just $ mkLegend series
      , color = Just colors
      , grid = Just $ EC.Grid EC.gridDefault
          { y2 = Just $ EC.Pixel $ labelHeight $ fromMaybe "" longestCat
          }
      }
  where
  labelHeight ∷ String → Number
  labelHeight longestCat =
    let
      width = getTextWidthPure longestCat $ "normal " <> show size <> "px Ubuntu"
    in
      add 24.0
        $ Math.max (Int.toNumber size + 2.0)
        $ Math.abs
        $ width
        * Math.sin (Int.toNumber angle / 180.0 * Math.pi)

  mkLegend ∷ Array EC.Series → EC.Legend
  mkLegend ss =
    EC.Legend EC.legendDefault
      { "data" = Just $ map EC.legendItemDefault $ extractNames ss
      , textStyle = Just $ EC.TextStyle EC.textStyleDefault
          { fontFamily = Just "Ubuntu" }
      }

  tooltip ∷ EC.Tooltip
  tooltip = EC.Tooltip $ EC.tooltipDefault
    { trigger = Just EC.TriggerAxis
    , textStyle = Just $ EC.TextStyle EC.textStyleDefault
        { fontFamily = Just "Ubuntu"
        , fontSize = Just 12.0
        }
    , axisPointer = Just $ EC.TooltipAxisPointer EC.tooltipAxisPointerDefault
        { "type" = Just $ EC.LinePointer
        , lineStyle = Just $ EC.LineStyle EC.lineStyleDefault
            { color = Just "rgba(170,170,170,0.8)"
            , width = Just 1.0
            , "type" = Just $ EC.Solid
            }
        }
    }

  extractNames ∷ Array EC.Series → Array String
  extractNames ss = A.nub $ A.catMaybes $ map extractName ss

  extractName ∷ EC.Series → Maybe String
  extractName (EC.LineSeries r) = r.common.name
  extractName _ = Nothing

  xAxisConfig ∷ Tuple EC.AxisType (Maybe EC.Interval)
  xAxisConfig = getXAxisConfig axises conf

  extracted ∷ LineData
  extracted =
    L.sortBy (mkSortFn `on` (fst ⋙ keyCategory))
      $ lineData $ buildChartAxises axises conf

  mkSortFn
    ∷ String → String → Ordering
  mkSortFn =
    case (conf.dimensions !! 0) >>= view _value >>= flip M.lookup axises of
      Just (Ax.ValAxis _) → compare `on` stringToNumber
      _ → compare

  yAxis ∷ EC.Axises
  yAxis =
    if needTwoAxises axises conf
    then EC.TwoAxises yAxis' yAxis'
    else EC.OneAxis yAxis'

  yAxis' ∷ EC.Axis
  yAxis' =
    EC.Axis EC.axisDefault
      { "type" = Just EC.ValueAxis
      , axisLabel = Just $ EC.AxisLabel EC.axisLabelDefault
        { textStyle = Just $ EC.TextStyle EC.textStyleDefault
          { fontFamily = Just "Ubuntu"
          , fontSize = Just $ Int.toNumber size
          }
        }
      , axisLine = Just $ EC.AxisLine EC.axisLineDefault
        { lineStyle = Just $ EC.AxisLineStyle EC.axisLineStyleDefault
            { color = Just ([Tuple 1.0 "rgba(184,184,184,0.8)"])
            , width = Just 1.0
            }
        }
      , splitLine = Just $ EC.AxisSplitLine EC.axisSplitLineDefault
        { lineStyle = Just $ EC.LineStyle EC.lineStyleDefault
          { color = Just "rgba(204,204,204,0.2)"
          , width = Just 1.0
          }
         }
      }

  preSeries ∷ EC.AxisRec × (Array EC.Series) × (Maybe String)
  preSeries = mkSeries (needTwoAxises axises conf) xAxisConfig extracted stacked smooth

needTwoAxises ∷ M.Map JCursor Ax.Axis → ChartConfiguration → Boolean
needTwoAxises axises conf =
  isJust $ (conf.measures !! 1) >>= view _value >>= flip M.lookup axises

getXAxisConfig
  ∷ M.Map JCursor Ax.Axis
  → ChartConfiguration
  → Tuple EC.AxisType (Maybe EC.Interval)
getXAxisConfig axises conf =
  case (conf.dimensions !! 0) >>= view _value >>= flip M.lookup axises of
    Just (Ax.TimeAxis _) → Tuple EC.TimeAxis $ Just $ EC.Custom zero
    Just (Ax.ValAxis _) → Tuple EC.CategoryAxis Nothing
    _ → Tuple EC.CategoryAxis $ Just EC.Auto

mkSeries
  ∷ Boolean
   → Tuple EC.AxisType (Maybe EC.Interval)
   → LineData
   → Boolean
   → Boolean
   → EC.AxisRec × (Array EC.Series) × (Maybe String)
mkSeries needTwoAxis (Tuple ty interval_) lData stacked smooth =
  xAxis × series × longestCat
  where
  longestCat ∷ Maybe String
  longestCat =
    F.maximumBy (\a b → compare (Str.length a) (Str.length b)) catVals

  xAxis ∷ EC.AxisRec
  xAxis =
    EC.axisDefault
      { "type" = Just ty
      , "data" = Just $ map EC.CommonAxisData catVals
      , boundaryGap = Just $ EC.CatBoundaryGap false
      , axisTick = Just $ EC.AxisTick EC.axisTickDefault
        { interval = interval_
        , length = Just $ 2.0
        , lineStyle = Just $ EC.LineStyle EC.lineStyleDefault
          { color = Just "rgba(184,184,184,0.8)"
          , width = Just 1.0
          }
        }
      , axisLine = Just $ EC.AxisLine EC.axisLineDefault
        { lineStyle = Just $ EC.AxisLineStyle EC.axisLineStyleDefault
          { color = Just ([Tuple 1.0 "rgba(184,184,184,0.8)"])
          , width = Just 1.0
          }
        }
      , splitLine = Just $ EC.AxisSplitLine EC.axisSplitLineDefault
        { lineStyle = Just $ EC.LineStyle EC.lineStyleDefault
          { color = Just "rgba(204,204,204,0.2)"
          , width = Just 1.0
          }
        }
      }

  catVals ∷ Array String
  catVals = A.nub $ map keyCategory keysArray

  keysArray ∷ Array Key
  keysArray = F.foldMap (pure ∘ fst) lData

  series ∷ Array EC.Series
  series = case group of
    Tuple firsts seconds →
      L.fromList $
      (map firstSerie $ zip (range 0 ((length (M.toList firsts))-1)) (M.toList firsts))
      <> (if needTwoAxis
          then map secondSerie $ zip (range 0 ((length (M.toList seconds))-1)) (M.toList seconds)
          else Nil
         )

  group ∷ Tuple (Map String (Array Number)) (Map String (Array Number))
  group = bimap nameMap nameMap $ splitSeries $ L.fromList lData

  splitSeries
    ∷ Array (Tuple Key (Tuple Number Number))
    → Tuple (Array (Tuple Key Number)) (Array (Tuple Key Number))
  splitSeries src =
    foldl (\(Tuple firsts seconds) (Tuple k (Tuple f s)) →
            Tuple (A.cons (Tuple k f) firsts) (A.cons (Tuple k s) seconds))
    (Tuple [] []) src

  nameMap ∷ Array (Tuple Key Number) → Map String (Array Number)
  nameMap = commonNameMap fillEmpties catVals

  arrKeys ∷ Array (Map String Number) → Array String
  arrKeys ms = A.nub $ A.concat (L.fromList ∘ M.keys <$> ms)

  fillEmpties ∷ Array (Map String Number) → Array (Map String Number)
  fillEmpties ms =
    let ks = arrKeys ms
    in map (\m → foldl fill m ks) ms

  fill ∷ Map String Number → String → Map String Number
  fill m key = M.alter (maybe (Just 0.0) Just) key m

  firstSerie ∷ Tuple Int (Tuple String (Array Number)) → EC.Series
  firstSerie = serie 0.0

  secondSerie ∷ Tuple Int (Tuple String (Array Number)) → EC.Series
  secondSerie = serie 1.0

  serie ∷ Number → Tuple Int (Tuple String (Array Number)) → EC.Series
  serie ix (Tuple ind (Tuple name nums)) =
    EC.LineSeries
      { common: EC.universalSeriesDefault
        { name = if name ≡ ""
                 then if needTwoAxis
                      then if ix ≡ 0.0
                           then Just $ "Left"
                           else Just $ "Right"
                      else Nothing
                 else if needTwoAxis
                      then if ix ≡ 0.0
                           then Just $ "Left: " <> name
                           else Just $ "Right: " <> name
                      else Just name
        , itemStyle = Just $ EC.ItemStyle EC.itemStyleDefault
            { normal = Just $ EC.IStyle EC.istyleDefault
              { color = Just $ EC.SimpleColor $
                  fromMaybe "#000000" $ colors !!
                    ( (Int.round ix) * ((A.length colors)-1) +
                        (1-2*(Int.round ix)) * (mod ind (A.length colors)) )
              , lineStyle = Just $ EC.LineStyle EC.lineStyleDefault
                  { width = Just 2.0 }
              , areaStyle = Just $ EC.AreaStyle $ toRGBAString $ getShadeColor
                  (fromMaybe "#000000" $ colors !!
                    ( (Int.round ix) * ((A.length colors)-1) +
                        (1-2*(Int.round ix)) * (mod ind (A.length colors)) )
                  )
                  (if stacked then 1.0 else 0.5)
              }
            }
        }
      , lineSeries: EC.lineSeriesDefault
          { "data" = Just $ map simpleData nums
          , yAxisIndex = Just ix
          , symbol = Just $ EC.Circle
          , symbolSize = Just $ EC.Size 0.0
          , stack = if stacked then Just $ "stacked on" ++ (show ix) else Nothing
          , smooth = Just smooth
          }
      }

  simpleData ∷ Number → EC.ItemData
  simpleData n = EC.Value $ EC.Simple n

{-
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.Chart.BuildOptions.Area where

import SlamData.Prelude

import Data.Argonaut (JCursor)
import Data.Array ((!!), cons)
import Data.Array as A
import Data.Foldable as F
import Data.Function (on)
import Data.Int as Int
import Data.Lens (view)
import Data.List (List(..), replicate, length, zip, range)
import Data.List as L
import Data.Map (Map)
import Data.Map as M
import Data.String as Str

import ECharts as EC

import SlamData.Form.Select (_value)
import SlamData.Workspace.Card.Chart.Aggregation (Aggregation(..), runAggregation)
import SlamData.Workspace.Card.Chart.Axis as Ax
import SlamData.Workspace.Card.Chart.ChartConfiguration (ChartConfiguration)
import SlamData.Workspace.Card.Chart.BuildOptions.Common (Key, ChartAxises, commonNameMap, keyCategory, colors, mixAxisLabelAngleAndFontSize, buildChartAxises, mkKey, getShadeColor, toRGBAString)

import Math as Math

import Utils (stringToNumber)
import Utils.DOM (getTextWidthPure)

type LabeledPointPairs = M.Map Key (Tuple (Array Number) (Array Number))
type LineData = L.List (Tuple Key (Tuple Number Number))

lineData ∷ ChartAxises → LineData
lineData axises =
  let
    lr =
      lineRawData
        dimensions
        firstSeries
        secondSeries
        firstValues
        secondValues
        M.empty
  in
    aggregatePairs firstAgg secondAgg lr
  where
  firstAgg ∷ Aggregation
  firstAgg = fromMaybe Sum $ join (axises.aggregations !! 0)

  secondAgg ∷ Aggregation
  secondAgg = fromMaybe Sum $ join (axises.aggregations !! 1)

  dimensions ∷ List (Maybe String)
  dimensions = fromMaybe Nil $ axises.dimensions !! 0

  firstValues ∷ List (Maybe Number)
  firstValues = fromMaybe Nil $ axises.measures !! 0

  firstSeries ∷ List (Maybe String)
  firstSeries = fromMaybe nothings $ axises.series !! 0

  secondSeries ∷ List (Maybe String)
  secondSeries = fromMaybe nothings $ axises.series !! 1

  secondValues ∷ List (Maybe Number)
  secondValues = fromMaybe nothings $ axises.measures !! 1

  nothings ∷ ∀ a. List (Maybe a)
  nothings = flip replicate Nothing $ maxLen firstValues dimensions

  maxLen ∷ ∀ a b. List a → List b → Int
  maxLen lstA lstB =
    let lA = length lstA
        lB = length lstB
    in if lA > lB then lA else lB

lineRawData
  ∷ List (Maybe String)
   → List (Maybe String)
   → List (Maybe String)
   → List (Maybe Number)
   → List (Maybe Number)
   → LabeledPointPairs
   → LabeledPointPairs
lineRawData Nil _ _ _ _ acc = acc
lineRawData _ Nil _ _ _ acc = acc
lineRawData _ _ Nil _ _ acc = acc
lineRawData _ _ _ Nil _ acc = acc
lineRawData _ _ _ _ Nil acc = acc
lineRawData (Cons Nothing _) _ _ _ _ acc = acc
lineRawData
  (Cons (Just dimension) dims)
  (Cons mbFirstSerie firstSeries)
  (Cons mbSecondSerie secondSeries)
  (Cons mbFirstValue firstValues)
  (Cons mbSecondValue secondValues)
  acc =
    lineRawData dims firstSeries secondSeries firstValues secondValues
    $ M.alter (alterFn $ Tuple firstVal secondVal) key acc
  where
  firstVal ∷ Number
  firstVal = fromMaybe zero mbFirstValue

  secondVal ∷ Number
  secondVal = fromMaybe zero mbSecondValue

  key ∷ Key
  key = mkKey dimension mbFirstSerie mbSecondSerie

  alterFn
    ∷ Tuple Number Number → Maybe (Tuple (Array Number) (Array Number))
    → Maybe (Tuple (Array Number) (Array Number))
  alterFn (Tuple v1 v2) acc =
    case fromMaybe (Tuple [] []) acc of
      Tuple v1s v2s → pure $ Tuple (cons v1 v1s) (cons v2 v2s)

aggregatePairs ∷ Aggregation → Aggregation → LabeledPointPairs → LineData
aggregatePairs fAgg sAgg lp =
  M.toList $ map (bimap (runAggregation fAgg) (runAggregation sAgg)) lp

buildArea
  ∷ M.Map JCursor Ax.Axis
   → Int
   → Int
   → Boolean
   → Boolean
   → ChartConfiguration
   → EC.Option
buildArea axises angle size stacked smooth conf = case preSeries of
  xAxis × series × longestCat →
    EC.Option EC.optionDefault
      { series = Just $ map Just series
      , xAxis =
          Just $ EC.OneAxis $ EC.Axis
          $ mixAxisLabelAngleAndFontSize angle size xAxis
      , yAxis = Just yAxis
      , tooltip = Just tooltip
      , legend = Just $ mkLegend series
      , color = Just colors
      , grid = Just $ EC.Grid EC.gridDefault
          { y2 = Just $ EC.Pixel $ labelHeight $ fromMaybe "" longestCat
          }
      }
  where
  labelHeight ∷ String → Number
  labelHeight longestCat =
    let
      width = getTextWidthPure longestCat $ "normal " <> show size <> "px Ubuntu"
    in
      add 24.0
        $ Math.max (Int.toNumber size + 2.0)
        $ Math.abs
        $ width
        * Math.sin (Int.toNumber angle / 180.0 * Math.pi)

  mkLegend ∷ Array EC.Series → EC.Legend
  mkLegend ss =
    EC.Legend EC.legendDefault
      { "data" = Just $ map EC.legendItemDefault $ extractNames ss
      , textStyle = Just $ EC.TextStyle EC.textStyleDefault
          { fontFamily = Just "Ubuntu" }
      }

  tooltip ∷ EC.Tooltip
  tooltip = EC.Tooltip $ EC.tooltipDefault
    { trigger = Just EC.TriggerAxis
    , textStyle = Just $ EC.TextStyle EC.textStyleDefault
        { fontFamily = Just "Ubuntu"
        , fontSize = Just 12.0
        }
    , axisPointer = Just $ EC.TooltipAxisPointer EC.tooltipAxisPointerDefault
        { "type" = Just $ EC.LinePointer
        , lineStyle = Just $ EC.LineStyle EC.lineStyleDefault
            { color = Just "rgba(170,170,170,0.8)"
            , width = Just 1.0
            , "type" = Just $ EC.Solid
            }
        }
    }

  extractNames ∷ Array EC.Series → Array String
  extractNames ss = A.nub $ A.catMaybes $ map extractName ss

  extractName ∷ EC.Series → Maybe String
  extractName (EC.LineSeries r) = r.common.name
  extractName _ = Nothing

  xAxisConfig ∷ Tuple EC.AxisType (Maybe EC.Interval)
  xAxisConfig = getXAxisConfig axises conf

  extracted ∷ LineData
  extracted =
    L.sortBy (mkSortFn `on` (fst ⋙ keyCategory))
      $ lineData $ buildChartAxises axises conf

  mkSortFn
    ∷ String → String → Ordering
  mkSortFn =
    case (conf.dimensions !! 0) >>= view _value >>= flip M.lookup axises of
      Just (Ax.ValAxis _) → compare `on` stringToNumber
      _ → compare

  yAxis ∷ EC.Axises
  yAxis =
    if needTwoAxises axises conf
    then EC.TwoAxises yAxis' yAxis'
    else EC.OneAxis yAxis'

  yAxis' ∷ EC.Axis
  yAxis' =
    EC.Axis EC.axisDefault
      { "type" = Just EC.ValueAxis
      , axisLabel = Just $ EC.AxisLabel EC.axisLabelDefault
        { textStyle = Just $ EC.TextStyle EC.textStyleDefault
          { fontFamily = Just "Ubuntu"
          , fontSize = Just $ Int.toNumber size
          }
        }
      , axisLine = Just $ EC.AxisLine EC.axisLineDefault
        { lineStyle = Just $ EC.AxisLineStyle EC.axisLineStyleDefault
            { color = Just ([Tuple 1.0 "rgba(184,184,184,0.8)"])
            , width = Just 1.0
            }
        }
      , splitLine = Just $ EC.AxisSplitLine EC.axisSplitLineDefault
        { lineStyle = Just $ EC.LineStyle EC.lineStyleDefault
          { color = Just "rgba(204,204,204,0.2)"
          , width = Just 1.0
          }
         }
      }

  preSeries ∷ EC.AxisRec × (Array EC.Series) × (Maybe String)
  preSeries = mkSeries (needTwoAxises axises conf) xAxisConfig extracted stacked smooth

needTwoAxises ∷ M.Map JCursor Ax.Axis → ChartConfiguration → Boolean
needTwoAxises axises conf =
  isJust $ (conf.measures !! 1) >>= view _value >>= flip M.lookup axises

getXAxisConfig
  ∷ M.Map JCursor Ax.Axis
  → ChartConfiguration
  → Tuple EC.AxisType (Maybe EC.Interval)
getXAxisConfig axises conf =
  case (conf.dimensions !! 0) >>= view _value >>= flip M.lookup axises of
    Just (Ax.TimeAxis _) → Tuple EC.TimeAxis $ Just $ EC.Custom zero
    Just (Ax.ValAxis _) → Tuple EC.CategoryAxis Nothing
    _ → Tuple EC.CategoryAxis $ Just EC.Auto

mkSeries
  ∷ Boolean
   → Tuple EC.AxisType (Maybe EC.Interval)
   → LineData
   → Boolean
   → Boolean
   → EC.AxisRec × (Array EC.Series) × (Maybe String)
mkSeries needTwoAxis (Tuple ty interval_) lData stacked smooth =
  xAxis × series × longestCat
  where
  longestCat ∷ Maybe String
  longestCat =
    F.maximumBy (\a b → compare (Str.length a) (Str.length b)) catVals

  xAxis ∷ EC.AxisRec
  xAxis =
    EC.axisDefault
      { "type" = Just ty
      , "data" = Just $ map EC.CommonAxisData catVals
      , boundaryGap = Just $ EC.CatBoundaryGap false
      , axisTick = Just $ EC.AxisTick EC.axisTickDefault
        { interval = interval_
        , length = Just $ 2.0
        , lineStyle = Just $ EC.LineStyle EC.lineStyleDefault
          { color = Just "rgba(184,184,184,0.8)"
          , width = Just 1.0
          }
        }
      , axisLine = Just $ EC.AxisLine EC.axisLineDefault
        { lineStyle = Just $ EC.AxisLineStyle EC.axisLineStyleDefault
          { color = Just ([Tuple 1.0 "rgba(184,184,184,0.8)"])
          , width = Just 1.0
          }
        }
      , splitLine = Just $ EC.AxisSplitLine EC.axisSplitLineDefault
        { lineStyle = Just $ EC.LineStyle EC.lineStyleDefault
          { color = Just "rgba(204,204,204,0.2)"
          , width = Just 1.0
          }
        }
      }

  catVals ∷ Array String
  catVals = A.nub $ map keyCategory keysArray

  keysArray ∷ Array Key
  keysArray = F.foldMap (pure ∘ fst) lData

  series ∷ Array EC.Series
  series = case group of
    Tuple firsts seconds →
      L.fromList $
      (map firstSerie $ zip (range 0 ((length (M.toList firsts))-1)) (M.toList firsts))
      <> (if needTwoAxis
          then map secondSerie $ zip (range ((length (M.toList seconds))-1) 0) (M.toList seconds)
          else Nil
         )

  group ∷ Tuple (Map String (Array Number)) (Map String (Array Number))
  group = bimap nameMap nameMap $ splitSeries $ L.fromList lData

  splitSeries
    ∷ Array (Tuple Key (Tuple Number Number))
    → Tuple (Array (Tuple Key Number)) (Array (Tuple Key Number))
  splitSeries src =
    foldl (\(Tuple firsts seconds) (Tuple k (Tuple f s)) →
            Tuple (A.cons (Tuple k f) firsts) (A.cons (Tuple k s) seconds))
    (Tuple [] []) src

  nameMap ∷ Array (Tuple Key Number) → Map String (Array Number)
  nameMap = commonNameMap fillEmpties catVals

  arrKeys ∷ Array (Map String Number) → Array String
  arrKeys ms = A.nub $ A.concat (L.fromList ∘ M.keys <$> ms)

  fillEmpties ∷ Array (Map String Number) → Array (Map String Number)
  fillEmpties ms =
    let ks = arrKeys ms
    in map (\m → foldl fill m ks) ms

  fill ∷ Map String Number → String → Map String Number
  fill m key = M.alter (maybe (Just 0.0) Just) key m

  firstSerie ∷ Tuple Int (Tuple String (Array Number)) → EC.Series
  firstSerie = serie 0.0

  secondSerie ∷ Tuple Int (Tuple String (Array Number)) → EC.Series
  secondSerie = serie 1.0

  serie ∷ Number → Tuple Int (Tuple String (Array Number)) → EC.Series
  serie ix (Tuple ind (Tuple name nums)) =
    EC.LineSeries
      { common: EC.universalSeriesDefault
        { name = if name ≡ ""
                 then Nothing
                 else if needTwoAxis
                      then if ix ≡ 0.0
                           then Just $ "Left: " <> name
                           else Just $ "Right: " <> name
                      else Just name
        , itemStyle = Just $ EC.ItemStyle EC.itemStyleDefault
            { normal = Just $ EC.IStyle EC.istyleDefault
              { color = Just $ EC.SimpleColor $
                  (fromMaybe "#000000" (colors !! (mod ind (A.length colors))))
              , lineStyle = Just $ EC.LineStyle EC.lineStyleDefault
                  { width = Just 2.0 }
              , areaStyle = Just $ EC.AreaStyle $ toRGBAString $ getShadeColor
                  (fromMaybe "#000000" (colors !! (mod ind (A.length colors))))
                  (if stacked then 1.0 else 0.5)
              }
            }
        }
      , lineSeries: EC.lineSeriesDefault
          { "data" = Just $ map simpleData nums
          , yAxisIndex = Just ix
          , symbol = Just $ EC.Circle
          , symbolSize = Just $ EC.Size 0.0
          , stack = if stacked then Just $ "stacked on" ++ (show ix) else Nothing
          , smooth = Just smooth
          }
      }

  simpleData ∷ Number → EC.ItemData
  simpleData n = EC.Value $ EC.Simple n


More fine grained hoist function

More fine grained hoist function

module Database.PostgreSQL.PG
( module Row
, module Value
, module PostgreSQL
, PG
, command
, execute
, hoist
, hoistWith
, query
, onIntegrityError
, scalar
, withConnection
, withTransaction
) where

import Prelude

import Control.Monad.Error.Class (catchError, throwError)
import Control.Monad.Except (ExceptT(..))
import Control.Monad.Except.Trans (ExceptT, runExceptT)
import Data.Either (Either(..))
import Data.Maybe (Maybe(..))
import Database.PostgreSQL (Connection, PGError(..), Pool, Query)
import Database.PostgreSQL (class FromSQLRow, class FromSQLValue, class ToSQLRow, class ToSQLValue, Connection, Database, PGError(..), PGErrorDetail, Pool, PoolConfiguration, Query(..), Row0(..), Row1(..), Row10(..), Row11(..), Row12(..), Row13(..), Row14(..), Row15(..), Row16(..), Row17(..), Row18(..), Row19(..), Row2(..), Row3(..), Row4(..), Row5(..), Row6(..), Row7(..), Row8(..), Row9(..), defaultPoolConfiguration, fromSQLRow, fromSQLValue, instantFromString, instantToString, newPool, null, toSQLRow, toSQLValue, unsafeIsBuffer) as PostgreSQL
import Database.PostgreSQL (command, execute, query, scalar, withConnection, withTransaction) as P
import Database.PostgreSQL.Row (class FromSQLRow, class ToSQLRow, Row0(..), Row1(..), Row10(..), Row11(..), Row12(..), Row13(..), Row14(..), Row15(..), Row16(..), Row17(..), Row18(..), Row19(..), Row2(..), Row3(..), Row4(..), Row5(..), Row6(..), Row7(..), Row8(..), Row9(..), fromSQLRow, toSQLRow) as Row
import Database.PostgreSQL.Row (class FromSQLRow, class ToSQLRow, Row1)
import Database.PostgreSQL.Value (class FromSQLValue)
import Database.PostgreSQL.Value (class FromSQLValue, class ToSQLValue, fromSQLValue, instantFromString, instantToString, null, toSQLValue, unsafeIsBuffer) as Value
import Effect.Aff (Aff)
import Effect.Aff.Class (class MonadAff, liftAff)

type Database = String

-- | PostgreSQL computations run in the `PG` monad. It's just `Aff` stacked with
-- | `ExceptT` to provide error handling.
-- |
-- | Errors originating from database queries or connection to the database are
-- | modeled with the `PGError` type. Use `runExceptT` from
-- | `Control.Monad.Except.Trans` to turn a `PG a` action into `Aff (Either
-- | PGError a)`.
type PG a = ExceptT PGError Aff a

hoistWith :: forall e m. MonadAff m => (PGError -> e) -> PG ~> ExceptT e m
hoistWith f m = ExceptT $ liftAff $
  runExceptT m >>= case _ of
    Right a -> pure (Right a)
    Left pgError -> pure (Left (f pgError))

hoist :: forall m. MonadAff m => PG ~> ExceptT PGError m
hoist = hoistWith identity

-- | Run an action with a connection. The connection is released to the pool
-- | when the action returns.
withConnection
    :: forall a
     . Pool
    -> (Connection -> PG a)
    -> PG a
withConnection p k = ExceptT $ P.withConnection p case _ of
  Right conn -> runExceptT $ k conn
  Left pgErr -> pure (Left pgErr)

-- | Run an action within a transaction. The transaction is committed if the
-- | action returns cleanly, and rolled back if the action throws (either a
-- | `PGError` or a JavaScript exception in PG context). If you want to
-- | change the transaction mode, issue a separate `SET TRANSACTION` statement
-- | within the transaction.
withTransaction
    :: forall a
     . Connection
    -> PG a
    -> PG a
withTransaction conn action =
  ExceptT $ join <$> P.withTransaction conn (runExceptT action)

-- | Execute a PostgreSQL query and discard its results.
execute
    :: forall i o
     . (ToSQLRow i)
    => Connection
    -> Query i o
    -> i
    -> PG Unit
execute conn sql values = ExceptT $ P.execute conn sql values >>= case _ of
  Just pgErr -> pure (Left pgErr)
  Nothing -> pure (Right unit)

-- | Execute a PostgreSQL query and return its results.
query
    :: forall i o
     . ToSQLRow i
    => FromSQLRow o
    => Connection
    -> Query i o
    -> i
    -> PG (Array o)
query conn sql = ExceptT <<< P.query conn sql

-- | Execute a PostgreSQL query and return the first field of the first row in
-- | the result.
scalar
    :: forall i o
     . ToSQLRow i
    => FromSQLValue o
    => Connection
    -> Query i (Row1 o)
    -> i
    -> PG (Maybe o)
scalar conn sql = ExceptT <<< P.scalar conn sql

-- | Execute a PostgreSQL query and return its command tag value
-- | (how many rows were affected by the query). This may be useful
-- | for example with `DELETE` or `UPDATE` queries.
command
    :: forall i
     . ToSQLRow i
    => Connection
    -> Query i Int
    -> i
    -> PG Int
command conn sql = ExceptT <<< P.command conn sql

onIntegrityError :: forall a. PG a -> PG a -> PG a
onIntegrityError errorResult db =
    catchError db handleError
    where
    handleError e =
        case e of
            IntegrityError _ -> errorResult
            _ -> throwError e

module Database.PostgreSQL.PG
( module Row
, module Value
, module PostgreSQL
, PG
, command
, execute
, hoistPG
, query
, onIntegrityError
, scalar
, withConnection
, withTransaction
) where

import Prelude

import Control.Monad.Error.Class (catchError, throwError)
import Control.Monad.Except (ExceptT(..))
import Control.Monad.Except.Trans (ExceptT, runExceptT)
import Data.Either (Either(..))
import Data.Maybe (Maybe(..))
import Database.PostgreSQL (Connection, PGError(..), Pool, Query)
import Database.PostgreSQL (class FromSQLRow, class FromSQLValue, class ToSQLRow, class ToSQLValue, Connection, Database, PGError(..), PGErrorDetail, Pool, PoolConfiguration, Query(..), Row0(..), Row1(..), Row10(..), Row11(..), Row12(..), Row13(..), Row14(..), Row15(..), Row16(..), Row17(..), Row18(..), Row19(..), Row2(..), Row3(..), Row4(..), Row5(..), Row6(..), Row7(..), Row8(..), Row9(..), defaultPoolConfiguration, fromSQLRow, fromSQLValue, instantFromString, instantToString, newPool, null, toSQLRow, toSQLValue, unsafeIsBuffer) as PostgreSQL
import Database.PostgreSQL (command, execute, query, scalar, withConnection, withTransaction) as P
import Database.PostgreSQL.Row (class FromSQLRow, class ToSQLRow, Row0(..), Row1(..), Row10(..), Row11(..), Row12(..), Row13(..), Row14(..), Row15(..), Row16(..), Row17(..), Row18(..), Row19(..), Row2(..), Row3(..), Row4(..), Row5(..), Row6(..), Row7(..), Row8(..), Row9(..), fromSQLRow, toSQLRow) as Row
import Database.PostgreSQL.Row (class FromSQLRow, class ToSQLRow, Row1)
import Database.PostgreSQL.Value (class FromSQLValue)
import Database.PostgreSQL.Value (class FromSQLValue, class ToSQLValue, fromSQLValue, instantFromString, instantToString, null, toSQLValue, unsafeIsBuffer) as Value
import Effect.Aff (Aff)
import Effect.Aff.Class (class MonadAff, liftAff)

type Database = String

-- | PostgreSQL computations run in the `PG` monad. It's just `Aff` stacked with
-- | `ExceptT` to provide error handling.
-- |
-- | Errors originating from database queries or connection to the database are
-- | modeled with the `PGError` type. Use `runExceptT` from
-- | `Control.Monad.Except.Trans` to turn a `PG a` action into `Aff (Either
-- | PGError a)`.
type PG a = ExceptT PGError Aff a

hoistPG :: forall m. MonadAff m => PG ~> ExceptT PGError m
hoistPG m = ExceptT $ liftAff $
  runExceptT m >>= case _ of
    Right a -> pure (Right a)
    Left pgError -> pure (Left pgError)

-- | Run an action with a connection. The connection is released to the pool
-- | when the action returns.
withConnection
    :: forall a
     . Pool
    -> (Connection -> PG a)
    -> PG a
withConnection p k = ExceptT $ P.withConnection p case _ of
  Right conn -> runExceptT $ k conn
  Left pgErr -> pure (Left pgErr)

-- | Run an action within a transaction. The transaction is committed if the
-- | action returns cleanly, and rolled back if the action throws (either a
-- | `PGError` or a JavaScript exception in PG context). If you want to
-- | change the transaction mode, issue a separate `SET TRANSACTION` statement
-- | within the transaction.
withTransaction
    :: forall a
     . Connection
    -> PG a
    -> PG a
withTransaction conn action =
  ExceptT $ join <$> P.withTransaction conn (runExceptT action)

-- | Execute a PostgreSQL query and discard its results.
execute
    :: forall i o
     . (ToSQLRow i)
    => Connection
    -> Query i o
    -> i
    -> PG Unit
execute conn sql values = ExceptT $ P.execute conn sql values >>= case _ of
  Just pgErr -> pure (Left pgErr)
  Nothing -> pure (Right unit)

-- | Execute a PostgreSQL query and return its results.
query
    :: forall i o
     . ToSQLRow i
    => FromSQLRow o
    => Connection
    -> Query i o
    -> i
    -> PG (Array o)
query conn sql = ExceptT <<< P.query conn sql

-- | Execute a PostgreSQL query and return the first field of the first row in
-- | the result.
scalar
    :: forall i o
     . ToSQLRow i
    => FromSQLValue o
    => Connection
    -> Query i (Row1 o)
    -> i
    -> PG (Maybe o)
scalar conn sql = ExceptT <<< P.scalar conn sql

-- | Execute a PostgreSQL query and return its command tag value
-- | (how many rows were affected by the query). This may be useful
-- | for example with `DELETE` or `UPDATE` queries.
command
    :: forall i
     . ToSQLRow i
    => Connection
    -> Query i Int
    -> i
    -> PG Int
command conn sql = ExceptT <<< P.command conn sql

onIntegrityError :: forall a. PG a -> PG a -> PG a
onIntegrityError errorResult db =
    catchError db handleError
    where
    handleError e =
        case e of
            IntegrityError _ -> errorResult
            _ -> throwError e


improve types, add new type representing how track renders

module Genetics.Browser.Track where

import Prelude

import Control.Monad.Aff (Aff)
import Control.Monad.Aff.AVar (AVar, makeVar, takeVar)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Rec.Class (forever)
import Control.Monad.State (StateT(..))
import Control.Monad.State as State
import Control.Monad.Trans.Class (lift)
import Data.Foldable (for_)
import Data.Maybe (Maybe(..))
import Data.Traversable (traverse_)
import Data.Tuple (Tuple(..))
import Genetics.Browser.DataSource (DataSource)
import Genetics.Browser.Glyph (Glyph, circle)
import Genetics.Browser.GlyphF.Canvas (renderGlyph)
import Genetics.Browser.Types (Bp(..), BpPerPixel(..), Chr, ChrId(..), Point, Range, bpToPixels)
import Genetics.Browser.UI.Native (getScreenSize)
import Genetics.Browser.UI.Native.View as View
import Genetics.Browser.View (View, Pixels)
import Graphics.Canvas (CanvasElement, Context2D, getCanvasHeight, getContext2D, setCanvasWidth)
import Graphics.Canvas as C

type Track aff eff a = { source :: DataSource aff a
                       , render :: Array a -> Eff eff Unit
                       , getPoint :: Point -> Array a
                       , chrSize :: Chr -> Bp
                       }

{-

Have a way to "prepare" data per-chromosome for rendering.

Then have a way to actually render that prepared data,
given some extra information such as offset, height scaling, etc.

Also need to map clicks backward, but that should be doable.

Maybe render to an offscreen canvas and copyImage.
Not sure that makes sense either
-}

newtype ChrRenderParams =
  ChrRenderParams
    (Maybe { xOffset :: Pixels
           , yOffset :: Pixels
           , height :: Pixels })

-- A Renderer maps data attached to a chromosome id to
-- a way to render said data,
-- when provided some extra information on where and how to render it
type Renderer eff a = { chrId :: ChrId, features :: Array a }
                   -> ChrRenderParams -> Eff eff Unit

-- I get the feeling using all of these renderers is going to be a hylomorphism...

chrRenderParams :: { xOffset :: Number, xDist :: Number }
                -> (ChrId -> Number)
                -> ChrId
                -> ChrRenderParams
chrRenderParams { xOffset, xDist } chrIndex chrId = ChrRenderParams $
  Just { xOffset: xOffset+xDist*(chrIndex chrId), yOffset: 0.0, height: 0.0 }

-- given a position on the chromosome, the size of the chromosome,
-- and the scale,
-- return the canvas X-coordinate
posPixelsX :: Bp
           -> Bp
           -> BpPerPixel
           -> Pixels
posPixelsX pos size scale = bpToPixels scale (pos / size)

-- given a position relative to the track where 0.0 = bottom, 1.0 = top,
-- information about where the track will be drawn and how,
-- return the canvas Y-coordinate
posPixelsY :: Number
           -> Pixels
           -> Pixels
           -> Pixels
posPixelsY rel height offset = rel * height + offset

data RenderType eff a =
    SingleGlyph (a -> { translateX :: Number, translateY :: Number }) (Eff eff Unit)
  | ManyGlyphs (a -> { translateX :: Number, translateY :: Number }) (a -> Eff eff Unit)
  | Connected (Array a -> Eff eff Unit)

-- Given a score range,
-- size of the current chr + scale (scale should be somewhere else...)
-- vertical size of the track
-- we can produce a mapping from canvases to SingleGlyph renderers
renderGWAS :: forall r.
              { minScore :: Number, maxScore :: Number }
           -> { size :: Bp, scale :: BpPerPixel }
           -> { trackHeight :: Pixels, trackYOffset :: Pixels }
           -> Context2D
           -> RenderType _ {score :: Number, pos :: Bp | r }
renderGWAS scoreRange hInfo vInfo ctx = SingleGlyph t f
  where f = renderGlyph ctx (circle { x: 0.0, y: 0.0 } 3.0 )
        t {pos,score} = let translateX = posPixelsX pos hInfo.size hInfo.scale
                            translateY = posPixelsY ((score - scoreRange.minScore) /
                                              (scoreRange.maxScore - scoreRange.minScore))
                                          vInfo.trackHeight vInfo.trackYOffset
                        in {translateX, translateY}

-- this one's weird, since the context changes... but close enough for now
renderChr :: forall a.
             RenderType _ a
          -> Context2D
          -> Array a
          -> Eff _ Unit
renderChr (SingleGlyph t draw) ctx =
  traverse_ (\a -> C.withContext ctx (C.translate (t a) ctx *> draw))
renderChr (ManyGlyphs t f) ctx =
  traverse_ (\a -> C.withContext ctx (C.translate (t a) ctx *> f a))
renderChr (Connected f) _ = f

{- note:
  check purescript-drawings out.

wait, aren't these basically the same

(         a -> (Translation, Eff _ Unit))
(Identity a -> (Translation, Eff _ Unit))

(       f a ->  g           (Eff _ Unit))
(       f a ->  Identity    (Eff _ Unit))
-}

-- Commands the renderer thread can receive
data RenderCmds a =
    Render (Array { chrId :: ChrId, features :: Array a})
  | SetView View
  | Scroll Pixels

type RenderBackend = { canvas :: CanvasElement
                     , backCanvas :: CanvasElement
                     }

renderer :: forall eff a.
            RenderBackend
         -> Renderer eff a
         -> AVar (RenderCmds a)
         -> StateT View (Aff _) Unit
renderer cvs r cmdVar = forever do
  cmd <- lift $ takeVar cmdVar
  case cmd of
    Render fs -> do
      -- let toRender :: Array (RenderParams -> Eff _ Unit)
      --     toRender = map r fs
      -- Use current (or provided?) View to derive RenderParams for each
      pure unit

    Scroll n -> do
      pure unit

    SetView v -> do
      State.put v
      pure unit

fetchTrack :: forall r a.
              Track _ _ a
           -> Range r
           -> Aff _ (Array a)
fetchTrack track r = track.source.fetch r.lHand r.rHand

{-
trackEvents :: _
trackEvents = viewB
  where cDrag = canvasDrag canvas
        lefts = case _ of
          Left x -> Just x
          Right _ -> Nothing
        -- the alt operator <|> combines the two event streams,
        -- resulting in an event of both button-click scrolls
        -- and canvas-drag scrolls

        dragScroll = filterMap (map (ScrollPixels <<< _.x) <<< lefts) cDrag
        updateViews = btnScroll (Bp 500.0)
                  <|> dragScroll
                  <|> btnZoom (wrap <<< (_ * 0.8) <<< unwrap)
                              (wrap <<< (_ * 1.2) <<< unwrap)
                  <|> scrollZoom canvas
        viewB = FRP.fold foldView updateViews v
-}

-- a `Track` is the more or less abstract representation of the track;
-- it needs to be run to do anything.

-- TODO it also needs to be able to receive messages and send messages

runTrack :: forall a r.
            View
         -> Track _ _ a
         -> Aff _ Unit
runTrack opts { source, render, getPoint, chrSize } = do
  -- ctx <- liftEff $ getContext2D opts.canvas

  -- {w,h} <- liftEff do
  --   {w} <- getScreenSize
  --   h <- getCanvasHeight opts.canvas
  --   _ <- setCanvasWidth (w-2.0) opts.canvas
  --   pure {w, h}

  -- trackState <- makeVar

  -- -- TODO handle resize
  -- let v = View.fromCanvasWidth chrSize opts

  -- feats <- fetch
  pure unit

{-

browser :: Aff _ Unit
browser uri = do
  canvas <- liftEff $ unsafePartial $ fromJust <$> getCanvasElementById "canvas"
  ctx <- liftEff $ getContext2D canvas

  {w,h} <- liftEff do
    {w} <- getScreenSize
    h <- getCanvasHeight canvas
    _ <- setCanvasWidth (w-2.0) canvas
    pure {w, h}

  backCanvas <- liftEff $ newCanvas {w,h}
  browserState <- makeVar

  let minView = Bp 0.0
      maxView = Bp 15000000.0
      v = View.fromCanvasWidth w { min: minView, max: maxView }
      f :: View -> Fetch _
      f = fileFetch uri

  fs <- f v

  let renderer :: View -> Array _ -> _
      renderer = renderGlyphs (browserTransform h) ctx
      fetch :: View -> Aff _ _
      fetch v = do

        let gs = glyphifyFeatures fs v
            annGs = zip fs gs
        let gs' = filterFeatures v annGs

        putVar browserState { annotatedGlyphs: annGs
                            , view: v }
        liftEff do
          clearCanvas canvas
          renderer v gs'

  let cDrag = canvasDrag canvas
      lefts = case _ of
        Left x -> Just x
        Right _ -> Nothing
      -- the alt operator <|> combines the two event streams,
      -- resulting in an event of both button-click scrolls
      -- and canvas-drag scrolls

      dragScroll = filterMap (map (ScrollPixels <<< _.x) <<< lefts) cDrag
      updateViews = btnScroll (Bp 500.0)
                <|> dragScroll
                <|> btnZoom (wrap <<< (_ * 0.8) <<< unwrap)
                            (wrap <<< (_ * 1.2) <<< unwrap)
                <|> scrollZoom canvas
      viewB = FRP.fold foldView updateViews v

  _ <- liftEff $ unsafeCoerceEff $ FRP.subscribe cDrag $ case _ of
    Left _      -> pure unit
    Right {x,y} -> scrollCanvas backCanvas canvas {x: -x, y: 0.0}

  _ <- liftEff $ unsafeCoerceEff $ FRP.subscribe viewB \v' -> do
    _ <- launchAff $ fetch v'

  fetch v
  -}

module Genetics.Browser.Track where

import Prelude

import Control.Monad.Aff (Aff)
import Control.Monad.Aff.AVar (AVar, makeVar, takeVar)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Rec.Class (forever)
import Control.Monad.State (StateT(..))
import Control.Monad.State as State
import Control.Monad.Trans.Class (lift)
import Data.Foldable (for_)
import Data.Maybe (Maybe(..))
import Data.Tuple (Tuple(..))
import Genetics.Browser.DataSource (DataSource)
import Genetics.Browser.Glyph (Glyph, circle)
import Genetics.Browser.GlyphF.Canvas (renderGlyph)
import Genetics.Browser.Types (Bp(..), BpPerPixel(..), Chr, ChrId(..), Point, Range, bpToPixels)
import Genetics.Browser.UI.Native (getScreenSize)
import Genetics.Browser.UI.Native.View as View
import Genetics.Browser.View (View, Pixels)
import Graphics.Canvas (CanvasElement, Context2D, getCanvasHeight, getContext2D, setCanvasWidth)
import Graphics.Canvas as C

type Track aff eff a = { source :: DataSource aff a
                       , render :: Array a -> Eff eff Unit
                       , getPoint :: Point -> Array a
                       , chrSize :: Chr -> Bp
                       }

{-

Have a way to "prepare" data per-chromosome for rendering.

Then have a way to actually render that prepared data,
given some extra information such as offset, height scaling, etc.

Also need to map clicks backward, but that should be doable.

Maybe render to an offscreen canvas and copyImage.
Not sure that makes sense either
-}

newtype RenderParams =
  RenderParams
    (Maybe { xOffset :: Pixels
           , yOffset :: Pixels
           , height :: Pixels })

-- A Renderer maps data attached to a chromosome id to
-- a way to render said data,
-- when provided some extra information on where and how to render it
type Renderer eff a = { chrId :: ChrId, features :: Array a }
                   -> RenderParams -> Eff eff Unit

-- I get the feeling using all of these renderers is going to be a hylomorphism...

-- the center of a glyph is assumed to be at {0, 0},
-- glyphs are be placed by translating the canvas
render1 :: Context2D
        -> Glyph Unit
        -> RenderParams
        -> Eff _ Unit
render1 _ g   (RenderParams  Nothing) = pure unit
render1 ctx g (RenderParams (Just p)) = C.withContext ctx do
  -- translate by p.x,y
  _ <- C.translate { translateX: p.xOffset
                   , translateY: p.yOffset } ctx

  -- translate by height
  _ <- C.translate { translateX: 0.0
                   , translateY: p.height } ctx

  renderGlyph ctx g

-- given a way to create a glyph from a feature,
-- and a way to create a RenderParam offset from a feature,
-- we create a function that takes a bunch of features,
-- a chr-wide renderparam,
-- and renders a whole chromosome.
render1Chr :: forall a.
              Context2D
           -> (a -> { glyph :: Glyph Unit, rp :: RenderParams } )
           -> Array a
           -> RenderParams
           -> Eff _ Unit
render1Chr ctx _ _ (RenderParams Nothing) = pure unit
render1Chr ctx toG features (RenderParams (Just p)) = C.withContext ctx do
  -- translate to Chr position
  _ <- C.translate { translateX: p.xOffset
                   , translateY: p.yOffset } ctx

  for_ features (\a -> let {glyph, rp} = toG a
                       in render1 ctx glyph rp)

-- given an array of chromosomes that can be constructed,
-- and a way to create a render offset from a chrId,
-- we can render a bunch of chrs at once.
renderManyChrs :: forall a.
                  Context2D
               -> (ChrId -> RenderParams)
               -> Array { chrId :: ChrId
                        , chrRenderer :: RenderParams -> Eff _ Unit }
               -> RenderParams -> Eff _ Unit
renderManyChrs ctx toRP chrs ( RenderParams Nothing) = pure unit
renderManyChrs ctx toRP chrs (RenderParams (Just p)) = C.withContext ctx do
  _ <- C.translate { translateX: p.xOffset
                   , translateY: p.yOffset } ctx

  for_ chrs (\{chrId, chrRenderer} -> chrRenderer (toRP chrId))

chrRenderParams :: { xOffset :: Number, xDist :: Number }
                -> (ChrId -> Number)
                -> ChrId
                -> RenderParams
chrRenderParams { xOffset, xDist } chrIndex chrId = RenderParams $
  Just { xOffset: xOffset+xDist*(chrIndex chrId), yOffset: 0.0, height: 0.0 }

posInPixels :: Bp
            -> Bp
            -> BpPerPixel
            -> Pixels
posInPixels pos size scale = bpToPixels scale (pos / size)

placeGwas :: forall a r.
             Bp
          -> BpPerPixel
          -> { pos :: Bp, height :: Pixels }
          -> a
          -> { glyph :: a, rp :: RenderParams }
placeGwas size scale { pos, height } glyph = { glyph, rp }
  where rp = RenderParams $ Just { xOffset: posInPixels pos size scale
                                 , yOffset: 0.0
                                 , height
                                 }

renderGwas :: Array (Tuple ChrId { pos :: Bp, height :: Pixels } )
           -> Context2D
           -> Eff _ Unit
renderGwas arr ctx = do
  let toG = const $ circle {x: 0.0, y: 0.0} 3.0

  pure unit

-- Commands the renderer thread can receive
data RenderCmds a =
    Render (Array { chrId :: ChrId, features :: Array a})
  | SetView View
  | Scroll Pixels

type RenderBackend = { canvas :: CanvasElement
                     , backCanvas :: CanvasElement
                     }

renderer :: forall eff a.
            RenderBackend
         -> Renderer eff a
         -> AVar (RenderCmds a)
         -> StateT View (Aff _) Unit
renderer cvs r cmdVar = forever do
  cmd <- lift $ takeVar cmdVar
  case cmd of
    Render fs -> do
      let toRender :: Array (RenderParams -> Eff _ Unit)
          toRender = map r fs
      -- Use current (or provided?) View to derive RenderParams for each
      pure unit

    Scroll n -> do
      pure unit

    SetView v -> do
      State.put v
      pure unit

fetchTrack :: forall r a.
              Track _ _ a
           -> Range r
           -> Aff _ (Array a)
fetchTrack track r = track.source.fetch r.lHand r.rHand

{-
trackEvents :: _
trackEvents = viewB
  where cDrag = canvasDrag canvas
        lefts = case _ of
          Left x -> Just x
          Right _ -> Nothing
        -- the alt operator <|> combines the two event streams,
        -- resulting in an event of both button-click scrolls
        -- and canvas-drag scrolls

        dragScroll = filterMap (map (ScrollPixels <<< _.x) <<< lefts) cDrag
        updateViews = btnScroll (Bp 500.0)
                  <|> dragScroll
                  <|> btnZoom (wrap <<< (_ * 0.8) <<< unwrap)
                              (wrap <<< (_ * 1.2) <<< unwrap)
                  <|> scrollZoom canvas
        viewB = FRP.fold foldView updateViews v
-}

-- a `Track` is the more or less abstract representation of the track;
-- it needs to be run to do anything.

-- TODO it also needs to be able to receive messages and send messages

runTrack :: forall a r.
            View
         -> Track _ _ a
         -> Aff _ Unit
runTrack opts { source, render, getPoint, chrSize } = do
  -- ctx <- liftEff $ getContext2D opts.canvas

  -- {w,h} <- liftEff do
  --   {w} <- getScreenSize
  --   h <- getCanvasHeight opts.canvas
  --   _ <- setCanvasWidth (w-2.0) opts.canvas
  --   pure {w, h}

  -- trackState <- makeVar

  -- -- TODO handle resize
  -- let v = View.fromCanvasWidth chrSize opts

  -- feats <- fetch
  pure unit

{-

browser :: Aff _ Unit
browser uri = do
  canvas <- liftEff $ unsafePartial $ fromJust <$> getCanvasElementById "canvas"
  ctx <- liftEff $ getContext2D canvas

  {w,h} <- liftEff do
    {w} <- getScreenSize
    h <- getCanvasHeight canvas
    _ <- setCanvasWidth (w-2.0) canvas
    pure {w, h}

  backCanvas <- liftEff $ newCanvas {w,h}
  browserState <- makeVar

  let minView = Bp 0.0
      maxView = Bp 15000000.0
      v = View.fromCanvasWidth w { min: minView, max: maxView }
      f :: View -> Fetch _
      f = fileFetch uri

  fs <- f v

  let renderer :: View -> Array _ -> _
      renderer = renderGlyphs (browserTransform h) ctx
      fetch :: View -> Aff _ _
      fetch v = do

        let gs = glyphifyFeatures fs v
            annGs = zip fs gs
        let gs' = filterFeatures v annGs

        putVar browserState { annotatedGlyphs: annGs
                            , view: v }
        liftEff do
          clearCanvas canvas
          renderer v gs'

  let cDrag = canvasDrag canvas
      lefts = case _ of
        Left x -> Just x
        Right _ -> Nothing
      -- the alt operator <|> combines the two event streams,
      -- resulting in an event of both button-click scrolls
      -- and canvas-drag scrolls

      dragScroll = filterMap (map (ScrollPixels <<< _.x) <<< lefts) cDrag
      updateViews = btnScroll (Bp 500.0)
                <|> dragScroll
                <|> btnZoom (wrap <<< (_ * 0.8) <<< unwrap)
                            (wrap <<< (_ * 1.2) <<< unwrap)
                <|> scrollZoom canvas
      viewB = FRP.fold foldView updateViews v

  _ <- liftEff $ unsafeCoerceEff $ FRP.subscribe cDrag $ case _ of
    Left _      -> pure unit
    Right {x,y} -> scrollCanvas backCanvas canvas {x: -x, y: 0.0}

  _ <- liftEff $ unsafeCoerceEff $ FRP.subscribe viewB \v' -> do
    _ <- launchAff $ fetch v'

  fetch v
  -}