factor out annotation peak-processing from rendering

module Genetics.Browser.Track.Demo where

import Prelude

import Color (Color, black)
import Color.Scheme.Clrs (blue, red)
import Color.Scheme.X11 (darkblue, darkgrey, lightgrey)
import Control.Coroutine (Producer, transform, ($~))
import Control.Monad.Aff (Aff, error, throwError)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Console (log)
import Control.Monad.Except (runExcept)
import Data.Argonaut (Json, _Array)
import Data.Array as Array
import Data.BigInt (BigInt)
import Data.BigInt as BigInt
import Data.Either (Either(..))
import Data.Filterable (filter, filterMap, partition, partitionMap)
import Data.Foldable (class Foldable, fold, foldMap, foldr, length, minimumBy, sequence_)
import Data.FoldableWithIndex (foldMapWithIndex)
import Data.Foreign (F, Foreign, ForeignError(..))
import Data.Foreign (readArray) as Foreign
import Data.Foreign.Index (readProp) as Foreign
import Data.Foreign.Keys (keys) as Foreign
import Data.Function (on)
import Data.FunctorWithIndex (mapWithIndex)
import Data.Lens (re, view, (^.), (^?))
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(..), fromMaybe)
import Data.Monoid (mempty)
import Data.Newtype (unwrap, wrap)
import Data.Pair (Pair(..))
import Data.Pair as Pair
import Data.Profunctor.Strong (fanout)
import Data.Record.Builder (build, insert, modify)
import Data.Record.Extra (class Keys)
import Data.Record.Extra (keys) as Record
import Data.Traversable (for)
import Data.Tuple (Tuple(Tuple))
import Data.Tuple as Tuple
import Data.Unfoldable (unfoldr)
import Data.Variant (inj)
import Genetics.Browser.Track.Backend (DrawingN, DrawingV, Feature, LegendEntry, NPoint, OldRenderer, Peak, RenderedTrack, chrLabelsUI, drawLegendInSlot, drawVScaleInSlot, featureNormX, groupToMap, mkIcon, renderFixedUI, renderTrack, sigLevelRuler, trackLegend)
import Genetics.Browser.Track.Bed (ParsedLine, chunkProducer, fetchBed)
import Genetics.Browser.Track.UI.Canvas (BrowserCanvas, Label, LabelPlace(LLeft, LCenter), UISlotGravity(UIRight, UILeft), _Dimensions, _Track, uiSlots)
import Genetics.Browser.Types (Bp(Bp), ChrId(ChrId), NegLog10(..), _NegLog10)
import Genetics.Browser.Types.Coordinates (CoordSys, CoordSysView, Normalized(Normalized), _Segments, aroundPair, normalize, pairSize, pairsOverlap)
import Graphics.Canvas as Canvas
import Graphics.Drawing (Drawing, Point, circle, fillColor, filled, lineWidth, outlineColor, outlined, rectangle)
import Graphics.Drawing as Drawing
import Graphics.Drawing.Font (font, sansSerif)
import Math as Math
import Network.HTTP.Affjax as Affjax
import Simple.JSON as Simple
import Type.Prelude (class RowToList, SProxy(SProxy))
import Unsafe.Coerce (unsafeCoerce)

type BedFeature = Feature { thickRange :: Pair Bp
                          , blocks :: Array (Pair Bp)
                          , geneId :: String
                          , geneName :: String
                          , chrId :: ChrId }

bedToFeature :: CoordSys ChrId BigInt -> ParsedLine -> Maybe BedFeature
bedToFeature cs pl = do
  seg@(Pair offset _ ) <- cs ^? _Segments <<< ix pl.chrom

  -- TODO validate ranges maybe, idk
  let toBp :: BigInt -> Bp
      toBp = wrap <<< BigInt.toNumber

      frameSize = toBp $ pairSize seg
      position = toBp  <$> Pair pl.chromStart pl.chromEnd
      thickRange = toBp  <$> Pair pl.thickStart pl.thickEnd

      blocks = Array.zipWith
                 (\start size -> map toBp (Pair start size))
                 pl.blockStarts pl.blockSizes

  pure { position
       , frameSize
       , feature: { thickRange
                  , blocks
                  , geneId: pl.geneId
                  , geneName: pl.geneName
                  , chrId: pl.chrom
                  }
       }

getGenes :: CoordSys ChrId BigInt
         -> String
         -> Aff _ (Map ChrId (Array BedFeature))
getGenes cs url = do
  ls <- fetchBed url

  let fs = filterMap (bedToFeature cs) ls

  pure $ groupToMap _.feature.chrId $ fs

bedDraw :: BedFeature
        -> DrawingV
bedDraw gene = inj (SProxy :: SProxy "range") \w ->
  let (Pair l r) = gene.position
      toLocal x = w * (unwrap $ x / gene.frameSize)

      width = toLocal (r - l)

      exon block =
        let p@(Pair exL' size') = toLocal <$> block
            s = rectangle exL' zero size' 30.0
        in (outlined (outlineColor darkgrey <> lineWidth 1.0) s)
        <> (filled (fillColor lightgrey) s)

      introns _ =
        let s = rectangle 1.5 14.0 (width-1.5) 2.0
        in outlined (outlineColor black <> lineWidth 3.0) s
        <> filled   (fillColor black) s

      label _ =
        Drawing.text
          (font sansSerif 12 mempty)
             (2.5) (35.0)
             (fillColor black) gene.feature.geneName

      drawing =
        if width < one
        then mempty
        else \_ -> introns unit
                <> foldMap exon gene.feature.blocks
                <> label unit

  in { drawing, width }

geneRenderer :: OldRenderer BedFeature
geneRenderer = inj (SProxy :: SProxy "single") { draw: bedDraw, horPlace, verPlace: const (Normalized 0.10) }
  where horPlace {position, frameSize} =
          let f p = Normalized (unwrap $ p / frameSize)
          in inj (SProxy :: SProxy "range") $ map f position

fetchJsonChunks :: String
                -> Aff _ (Producer (Array Json) (Aff _) Unit)
fetchJsonChunks url = do
  json <- _.response <$> Affjax.get url

  case json ^? _Array of
    Nothing -> throwError $ error "Parse error: JSON is not an array"
    Just ls -> pure $ chunkProducer 512 ls

featureProd :: ∀ r1 r2.
               String
            -> (Json -> Maybe { feature :: { chrId :: ChrId | r1 } | r2 })
            -> Aff _
                 (Producer
                 (Map ChrId (Array { feature :: { chrId :: ChrId | r1 } | r2 }))
                 (Aff _) Unit)
featureProd url parse = do
  prod <- fetchJsonChunks url
  pure $ prod $~ (transform $ groupToMap _.feature.chrId <<< filterMap parse)

type SNPRow chr score r =
  ( "chrId"  :: chr
  , "name" :: String
  , "score" :: score
  | r )

type SNP r =
  Feature (Record (SNPRow ChrId Number r))

parseSNP :: CoordSys ChrId BigInt
         -> Foreign
         -> F (SNP ())
parseSNP cSys a = do
  raw <- Simple.read' a

  let
      snp :: { chr :: _, ps :: _, p_wald :: _, rs :: _ }
      snp = raw

      feature :: Record (SNPRow ChrId Number ())
      feature =
        { score:      snp.p_wald
        , chrId: wrap snp.chr
        , name:       snp.rs }

      position = (\p -> wrap <$> Pair p p) $ snp.ps

  frameSize <- case Map.lookup feature.chrId (view _Segments cSys) of

    Nothing ->
      throwError $ pure $ ForeignError
                     "Annotation chr not found in coordinate system!"
    Just seg ->
      pure $ Bp $ BigInt.toNumber $ pairSize seg

  pure $ { position
         , frameSize
         , feature }

type AnnotationRow chr pos r =
  ( "chr"  :: chr
  , "pos"  :: pos
  , "name" :: String
  , "url"  :: Maybe String
  , "gene" :: Maybe String
  | r )

type AnnotationField = { field :: String, value :: Foreign }

type Annotation r =
  Feature (Record (AnnotationRow ChrId Bp
                     ( rest :: List AnnotationField | r )))

annotationFields :: ∀ a b rl.
                    Keys rl
                 => RowToList (AnnotationRow a b ()) rl
                 => List String
annotationFields =
  Record.keys (unsafeCoerce unit :: Record (AnnotationRow a b ()))

parseAnnotation :: CoordSys ChrId BigInt
                -> Foreign
                -> F (Annotation ())
parseAnnotation cSys a = do
  raw <- Simple.read' a
  rest <- parseAnnotationRest a

  let
      feature =
        build
         (insert    (SProxy :: SProxy "rest") rest
         >>> modify (SProxy :: SProxy "chr") ChrId
         >>> modify (SProxy :: SProxy "pos") Bp) raw

      position = (\p -> Pair p p) $ feature.pos

  frameSize <- case Map.lookup feature.chr (view _Segments cSys) of

    Nothing ->
      throwError $ pure $ ForeignError
                     "Annotation chr not found in coordinate system!"
    Just seg ->
      pure $ Bp $ BigInt.toNumber $ pairSize seg

  pure $ { position
         , frameSize
         , feature }

-- | Partially parse the parts of the annotation record that are *not* in the Annotation type
parseAnnotationRest :: Foreign
                    -> F (List AnnotationField)
parseAnnotationRest a = do
  allFields <- List.fromFoldable <$> Foreign.keys a

  let restFields = allFields `List.difference` annotationFields

  for restFields \field ->
     { field, value: _ } <$> Foreign.readProp field a

-- | A completely dumb default way of rendering arbitrary annotation fields
showAnnotationField :: AnnotationField -> String
showAnnotationField fv = fv.field <> ": " <> unsafeCoerce fv.value

showAnnotation :: Annotation ()
               -> List String
showAnnotation a = (List.fromFoldable
                    [ name, chr, pos ]) <> (map showAnnotationField annot.rest)
  where annot = a.feature
        name = fromMaybe ("SNP: " <> annot.name)
                         (("Gene: " <> _) <$> annot.gene)
        chr = "Chr: " <> show annot.chr
        pos = "Pos: " <> show annot.pos

getSNPs :: CoordSys ChrId BigInt
        -> String
        -> Aff _ (Map ChrId (Array (SNP ())))
getSNPs cs url = do
  resp <- Affjax.get url

  rawSNPs <-
    case runExcept $ Foreign.readArray resp.response of
           Left err -> throwError $ error "SNP data is not an array"
           Right as -> pure as

  let parsed =
        partitionMap (runExcept <<< parseSNP cs) rawSNPs

  pure $ groupToMap _.feature.chrId
         $ filter (\f -> Pair.fst (f.position) >= wrap zero)
         $ parsed.right

getAnnotations :: CoordSys ChrId BigInt
               -> String
               -> Aff _ (Map ChrId (Array (Annotation ())))
getAnnotations cs url = do
  resp <- Affjax.get url

  rawAnnots <- case runExcept
                    $ Foreign.readArray resp.response of
                 Left err -> throwError $ error "Annotations data is not an array"
                 Right as -> pure as

  let parsed = partitionMap
               (runExcept <<< parseAnnotation cs) rawAnnots

  -- debug/testing stuff
  liftEff do
    log $ "Raw annotations array length: " <> show (Array.length rawAnnots)
    log $ "Could not parse "
        <> show (length parsed.left :: Int)
        <> " annotations."
    log $ "Successfully parsed "
        <> show (length parsed.right :: Int)
        <> " annotations."

    -- logging with unsafeCoerce lets us examine the raw JS object in the console!
    log $ unsafeCoerce (parsed.right)
  case Array.head parsed.right of
    Nothing -> pure unit
    Just an -> liftEff do
      log "first annotation: "
      sequence_ (log <$> (("> " <> _) <$> showAnnotation an))

  pure $ groupToMap _.feature.chr parsed.right

peak1 :: ∀ rS.
         Bp
      -> Array (SNP rS)
      -> Maybe (Tuple (Peak Bp Number (SNP rS))
                      (Array (SNP rS)))
peak1 radius snps = do
  top <- minimumBy (compare `on` _.feature.score) snps

  let covers = radius `aroundPair` top.position
      y = top.feature.score
      {no, yes} = partition (\p -> p.position `pairsOverlap` covers) snps

  pure $ Tuple {covers, y, elements: yes} no

peaks :: ∀ rS.
         Bp
      -> Array (SNP rS)
      -> Array (Peak Bp Number (SNP rS))
peaks r snps = unfoldr (peak1 r) snps

annotationLegendEntry :: ∀ r. Annotation r -> LegendEntry
annotationLegendEntry a =
  case a.feature.gene of
    Nothing -> mkIcon blue "SNP name"
    Just gn -> mkIcon red "Gene name"

annotationLegendTest :: ∀ f r.
                   Foldable f
                => Functor f
                => Map ChrId (f (Annotation r))
                -> Array LegendEntry
annotationLegendTest fs = trackLegend annotationLegendEntry as
  where as = Array.concat
             $ Array.fromFoldable
             $ Array.fromFoldable <$> Map.values fs

------------ new renderers~~~~~~~~~

placeScored :: ∀ r1 r2.
               { min :: Number, max :: Number | r1 }
            -> Feature { score :: Number | r2 }
            -> NPoint
placeScored vs s =
    { x: featureNormX s
    , y: wrap $ normYLogScore vs s.feature.score
    }

normYLogScore s =
  normalize s.min s.max <<< unwrap <<< view _NegLog10

dist :: Point -> Point -> Number
dist p1 p2 = Math.sqrt $ x' `Math.pow` 2.0 + y' `Math.pow` 2.0
  where x' = p1.x - p2.x
        y' = p1.y - p2.y

filterSig :: ∀ r1 r2.
             { sig :: Number | r1 }
          -> Map ChrId (Array (SNP r2))
          -> Map ChrId (Array (SNP r2))
filterSig {sig} = map (filter
  (\snp -> snp.feature.score <= (NegLog10 sig ^. re _NegLog10)))

snpsUI :: ∀ r.
          { min :: Number, max :: Number, sig :: Number, color :: Color | r }
       -> UISlotGravity
       -> BrowserCanvas
       -> Drawing
snpsUI vscale = renderFixedUI (drawVScaleInSlot vscale)

annotationsUI :: ∀ r.
                 { entries :: Array LegendEntry | r }
              -> UISlotGravity
              -> BrowserCanvas
              -> Drawing
annotationsUI legend = renderFixedUI (drawLegendInSlot legend)

renderSNPs :: ∀ r.
              { min :: Number, max :: Number | r }
           -> Canvas.Dimensions
           -> Map ChrId (Array (SNP ()))
           -> Map ChrId (Pair Number)
           -> RenderedTrack (SNP ())
renderSNPs verScale cdim snps =
  let features :: Array (SNP ())
      features = fold snps

      radius = 3.75

      drawing =
          let color = darkblue
              c = circle 0.0 0.0 radius
              out = outlined (outlineColor color) c
              fill = filled (fillColor color) c
          in out <> fill

      drawings :: Array (Tuple (SNP ()) Point) -> Array DrawingN
      drawings pts = let (Tuple _ points) = Array.unzip pts
                     in [{ drawing, points }]

      npointed :: Map ChrId (Array (Tuple (SNP ()) NPoint))
      npointed = (map <<< map)
        (fanout id (\s ->
           { x: featureNormX s
           , y: wrap $ normYLogScore verScale s.feature.score })) snps

      pointed :: Map ChrId (Pair Number)
              -> Array (Tuple (SNP ()) Point)
      pointed = foldMapWithIndex scaleSegs
        where rescale seg@(Pair offset _) npoint =
                  { x: offset + (pairSize seg) * (unwrap npoint.x)
                  , y: cdim.height * (one - unwrap npoint.y) }

              scaleSegs chrId seg = foldMap (map <<< map $ rescale seg)
                                      $ Map.lookup chrId npointed

      overlaps :: Array (Tuple (SNP ()) Point)
               -> Number -> Point
               -> Array (SNP ())
      overlaps pts radius' pt = filterMap covers pts
        where covers :: Tuple (SNP ()) Point -> Maybe (SNP ())
              covers (Tuple f fPt)
                | dist fPt pt <= radius + radius'   = Just f
                | otherwise = Nothing

  in \seg -> let pts = pointed seg
             in { features
                , drawings: drawings pts
                , labels: mempty
                , overlaps: overlaps pts }

annotationsForScale :: ∀ r1 r2 i c.
                       CoordSys i c
                    -> Map ChrId (Array (SNP r1))
                    -> Map ChrId (Array (Annotation r2))
                    -> Map ChrId (Pair Number)
                    -> Map ChrId (Array (Peak Bp Number (Annotation r2)))
annotationsForScale cSys snps annots =
  mapWithIndex \chr seg -> fromMaybe [] do
    segSnps      <- Map.lookup chr snps
    segAnnots    <- Map.lookup chr annots
    frameSize <- _.frameSize <$> Array.head segSnps

    let rad = (wrap 3.75 * frameSize) / (wrap $ pairSize seg)
        f pk = pk { elements = filter
                          (pairsOverlap pk.covers <<< _.position) segAnnots }

    pure $ f <$> peaks rad segSnps

renderAnnotationPeaks :: ∀ r r1 r2.
                         CoordSys ChrId BigInt
                      -> { min :: Number, max :: Number | r1 }
                      -> Map ChrId (Array (Peak Bp Number (Annotation r2)))
                      -> Canvas.Dimensions
                      -> Map ChrId (Pair Number)
                      -> { drawings :: _, labels :: _ }
renderAnnotationPeaks cSys vScale annoPks cdim =
  let

      curAnnotPeaks :: Map ChrId (Pair Number)
                    -> Map ChrId (Array (Peak Number Number (Annotation r2)))
      curAnnotPeaks segs = mapWithIndex f annoPks
        where f :: ChrId -> Array (Peak _ _ _) -> Array (Peak _ _ (Annotation r2))
              f chr pks = fromMaybe [] do
                  frameSize <- (wrap <<< BigInt.toNumber <<< pairSize)
                             <$> (Map.lookup chr $ cSys ^. _Segments)
                  pxSeg@(Pair l _) <- Map.lookup chr segs

                  let rescale pk = pk { covers = (\x -> l + pairSize pxSeg *
                                          (unwrap $ x / frameSize)) <$> pk.covers
                                      , y = cdim.height * (one - normYLogScore vScale pk.y) }

                  pure $ map rescale pks

      tailHeight = 0.06
      tailPixels = tailHeight * cdim.height
      iconYOffset = 6.5
      labelOffset = 8.0

      -- part of the canvas that a given peak will cover when rendered
      drawingCovers :: ∀ a.
                       Peak Number Number a
                    -> Canvas.Rectangle
      drawingCovers aPeak = {x,y,w,h}
        where (Pair x _) = aPeak.covers
              w = 14.0  -- hardcoded glyph width in pixels
              gH = (11.0 - iconYOffset) -- hardcoded height
              h = tailPixels + gH * length aPeak.elements
              y = aPeak.y - h

      drawAndLabel :: Peak Number Number (Annotation r2)
                   -> Tuple (Array DrawingN) (Array Label)
      drawAndLabel aPeak = Tuple [drawing] label
        where
              (Pair l r) = aPeak.covers
              x = l + 0.5 * (r - l)

              icons = Drawing.translate 0.0 (-tailPixels)
                      $ foldr (\a d -> Drawing.translate 0.0 (-iconYOffset)
                                     $ (annotationLegendEntry a).icon <> d)
                          mempty aPeak.elements

              tail = if Array.null aPeak.elements
                then mempty
                else Drawing.outlined (lineWidth 1.3 <> outlineColor black)
                       $ Drawing.path [ {x: 0.0, y: 0.0 }, {x: 0.0, y: -tailPixels }]

              drawing = { drawing: tail <> icons, points: [{x, y: aPeak.y }] }

              -- hardcoded font size because this will be handled by UI.Canvas later
              fontHeight = 14.0
              labelsHeight = length aPeak.elements * fontHeight

              dC = drawingCovers aPeak
                -- if all the labels fit above the icons, they're centered;
                -- otherwise just place them to the left and hope for the best
              {g, y0} = if dC.y > labelsHeight
                then { g: LCenter, y0: dC.y  }
                else { g: LLeft, y0: aPeak.y }

              label = Tuple.snd $ foldr f (Tuple y0 mempty) aPeak.elements
              f a (Tuple y ls) = Tuple (y - labelOffset)
                                    $ Array.snoc ls
                                         { text: fromMaybe a.feature.name a.feature.gene
                                         , point: { x, y }
                                         , gravity: g
                                         }

      drawAndLabelAll :: Map ChrId (Array (Peak _ _ _))
                      -> Tuple (Array DrawingN) (Array Label)
      drawAndLabelAll pks = foldMap (foldMap drawAndLabel) pks

  in \segs -> let (Tuple drawings labels) =
                    drawAndLabelAll $ curAnnotPeaks segs
              in { drawings, labels }

renderAnnotation :: ∀ r r1 r2.
                    CoordSys _ _
                 -> Map ChrId (Array (SNP ()))
                 -> { min :: Number, max :: Number | r }
                 -> Canvas.Dimensions
                 -> Map ChrId (Array (Annotation r2))
                 -> Map ChrId (Pair Number)
                 -> RenderedTrack (Annotation r2)
renderAnnotation cSys sigSnps vScale cdim allAnnots =
  let features = fold allAnnots
      annoPeaks = annotationsForScale cSys sigSnps allAnnots

  in \segs -> let {drawings, labels} =
                    renderAnnotationPeaks cSys vScale (annoPeaks segs) cdim segs
              in { features, overlaps: mempty
                 , drawings, labels }

demoBrowser :: ∀ r.
               CoordSys ChrId BigInt
            -> { score :: { min :: Number, max :: Number, sig :: Number } | r }
            -> { snps        :: Map ChrId (Array _)
               , annotations :: Map ChrId (Array _)
               , genes       :: Map ChrId (Array _) }
            -> BrowserCanvas
            -> CoordSysView
            -> { tracks     :: { snps        :: RenderedTrack (SNP _)
                               , annotations :: RenderedTrack (Annotation _) }
               , relativeUI :: Drawing
               , fixedUI    :: Drawing }
demoBrowser cSys config trackData =
  let
      vscale =
        build (insert (SProxy :: SProxy "color") black)
          $ config.score

      sigSnps = filterSig config.score trackData.snps
      entries = annotationLegendTest trackData.annotations

      snps =
        renderTrack cSys (renderSNPs vscale) trackData.snps

      annotations =
        renderTrack cSys (renderAnnotation cSys sigSnps vscale) trackData.annotations

      relativeUI = chrLabelsUI cSys

  in \bc v ->
    let trackDim = bc ^. _Track <<< _Dimensions
        slots = uiSlots bc
        fixedUI = (snpsUI vscale UILeft bc)
                <> (annotationsUI {entries} UIRight bc)
                <> (Drawing.translate slots.left.size.width slots.top.size.height
                    $ sigLevelRuler vscale red trackDim)

    in { tracks: { snps: snps bc v
                 , annotations: annotations bc v }
       , relativeUI: relativeUI bc v
       , fixedUI }

module Genetics.Browser.Track.Demo where

import Prelude

import Color (black)
import Color.Scheme.Clrs (blue, red)
import Color.Scheme.X11 (darkblue, darkgrey, lightgrey)
import Control.Coroutine (Producer, transform, ($~), (~~))
import Control.Monad.Aff (Aff, error, throwError)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Console (log)
import Control.Monad.Except (runExcept)
import Data.Argonaut (Json, _Array, _Number, _Object, _String)
import Data.Array as Array
import Data.BigInt (BigInt)
import Data.BigInt as BigInt
import Data.Either (Either(..))
import Data.Filterable (filter, filterMap, partition, partitionMap)
import Data.Foldable (class Foldable, fold, foldMap, foldr, length, maximumBy, minimumBy, sequence_)
import Data.FoldableWithIndex (foldMapWithIndex)
import Data.Foreign (F, Foreign, ForeignError(..))
import Data.Foreign (readArray) as Foreign
import Data.Foreign.Index (readProp) as Foreign
import Data.Foreign.Keys (keys) as Foreign
import Data.Function (on)
import Data.FunctorWithIndex (mapWithIndex)
import Data.Lens (Iso', re, view, viewOn, (^.), (^?))
import Data.Lens as Lens
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(..), fromMaybe)
import Data.Monoid (mempty)
import Data.Newtype (under, unwrap, wrap)
import Data.Newtype as Newtype
import Data.Pair (Pair(..))
import Data.Pair as Pair
import Data.Profunctor.Strong (fanout)
import Data.Record.Builder (build, insert, modify)
import Data.Record.Extra (class Keys)
import Data.Record.Extra (keys) as Record
import Data.Traversable (for, traverse)
import Data.Tuple (Tuple(Tuple))
import Data.Tuple as Tuple
import Data.Unfoldable (unfoldr)
import Data.Variant (inj)
import Debug.Trace as Debug
import Genetics.Browser.Track.Bed (ParsedLine, chunkProducer, fetchBed, fetchForeignChunks, parsedLineTransformer)
import Genetics.Browser.Track.UI.Canvas (Label, LabelPlace(..))
import Genetics.Browser.Track.Backend (DrawingN, DrawingV, Feature, LegendEntry, NPoint, OldRenderer, Peak, RenderedTrack, chrLabelsUI, drawLegendInSlot, drawVScaleInSlot, featureNormX, groupToMap, mkIcon, renderFixedUI, renderTrack, sigLevelRuler, trackLegend)
import Genetics.Browser.Types (Bp(Bp), ChrId(ChrId), NegLog10(..), _NegLog10)
import Genetics.Browser.Types.Coordinates (CoordSys, Normalized(Normalized), _Segments, aroundPair, normalize, pairSize, pairsOverlap)
import Graphics.Canvas as Canvas
import Graphics.Drawing (Point, circle, fillColor, filled, lineWidth, outlineColor, outlined, rectangle)
import Graphics.Drawing as Drawing
import Graphics.Drawing.Font (font, sansSerif)
import Math as Math
import Network.HTTP.Affjax as Affjax
import Simple.JSON as Simple
import Type.Prelude (class RowToList, SProxy(SProxy))
import Unsafe.Coerce (unsafeCoerce)

type BedFeature = Feature { thickRange :: Pair Bp
                          , blocks :: Array (Pair Bp)
                          , geneId :: String
                          , geneName :: String
                          , chrId :: ChrId }

bedToFeature :: CoordSys ChrId BigInt -> ParsedLine -> Maybe BedFeature
bedToFeature cs pl = do
  seg@(Pair offset _ ) <- cs ^? _Segments <<< ix pl.chrom

  -- TODO validate ranges maybe, idk
  let toBp :: BigInt -> Bp
      toBp = wrap <<< BigInt.toNumber

      frameSize = toBp $ pairSize seg
      position = toBp  <$> Pair pl.chromStart pl.chromEnd
      thickRange = toBp  <$> Pair pl.thickStart pl.thickEnd

      blocks = Array.zipWith
                 (\start size -> map toBp (Pair start size))
                 pl.blockStarts pl.blockSizes

  pure { position
       , frameSize
       , feature: { thickRange
                  , blocks
                  , geneId: pl.geneId
                  , geneName: pl.geneName
                  , chrId: pl.chrom
                  }
       }

getGenes :: CoordSys ChrId BigInt
         -> String
         -> Aff _ (Map ChrId (Array BedFeature))
getGenes cs url = do
  ls <- fetchBed url

  let fs = filterMap (bedToFeature cs) ls

  pure $ groupToMap _.feature.chrId $ fs

bedDraw :: BedFeature
        -> DrawingV
bedDraw gene = inj (SProxy :: SProxy "range") \w ->
  let (Pair l r) = gene.position
      toLocal x = w * (unwrap $ x / gene.frameSize)

      width = toLocal (r - l)

      exon block =
        let p@(Pair exL' size') = toLocal <$> block
            s = rectangle exL' zero size' 30.0
        in (outlined (outlineColor darkgrey <> lineWidth 1.0) s)
        <> (filled (fillColor lightgrey) s)

      introns _ =
        let s = rectangle 1.5 14.0 (width-1.5) 2.0
        in outlined (outlineColor black <> lineWidth 3.0) s
        <> filled   (fillColor black) s

      label _ =
        Drawing.text
          (font sansSerif 12 mempty)
             (2.5) (35.0)
             (fillColor black) gene.feature.geneName

      drawing =
        if width < one
        then mempty
        else \_ -> introns unit
                <> foldMap exon gene.feature.blocks
                <> label unit

  in { drawing, width }

geneRenderer :: OldRenderer BedFeature
geneRenderer = inj (SProxy :: SProxy "single") { draw: bedDraw, horPlace, verPlace: const (Normalized 0.10) }
  where horPlace {position, frameSize} =
          let f p = Normalized (unwrap $ p / frameSize)
          in inj (SProxy :: SProxy "range") $ map f position

fetchJsonChunks :: String
                -> Aff _ (Producer (Array Json) (Aff _) Unit)
fetchJsonChunks url = do
  json <- _.response <$> Affjax.get url

  case json ^? _Array of
    Nothing -> throwError $ error "Parse error: JSON is not an array"
    Just ls -> pure $ chunkProducer 512 ls

featureProd :: ∀ r1 r2.
               String
            -> (Json -> Maybe { feature :: { chrId :: ChrId | r1 } | r2 })
            -> Aff _
                 (Producer
                 (Map ChrId (Array { feature :: { chrId :: ChrId | r1 } | r2 }))
                 (Aff _) Unit)
featureProd url parse = do
  prod <- fetchJsonChunks url
  pure $ prod $~ (transform $ groupToMap _.feature.chrId <<< filterMap parse)

type SNPRow chr score r =
  ( "chrId"  :: chr
  , "name" :: String
  , "score" :: score
  | r )

type SNP r =
  Feature (Record (SNPRow ChrId Number r))

parseSNP :: CoordSys ChrId BigInt
         -> Foreign
         -> F (SNP ())
parseSNP cSys a = do
  raw <- Simple.read' a

  let
      snp :: { chr :: _, ps :: _, p_wald :: _, rs :: _ }
      snp = raw

      feature :: Record (SNPRow ChrId Number ())
      feature =
        { score:      snp.p_wald
        , chrId: wrap snp.chr
        , name:       snp.rs }

      position = (\p -> wrap <$> Pair p p) $ snp.ps

  frameSize <- case Map.lookup feature.chrId (view _Segments cSys) of

    Nothing ->
      throwError $ pure $ ForeignError
                     "Annotation chr not found in coordinate system!"
    Just seg ->
      pure $ Bp $ BigInt.toNumber $ pairSize seg

  pure $ { position
         , frameSize
         , feature }

type AnnotationRow chr pos r =
  ( "chr"  :: chr
  , "pos"  :: pos
  , "name" :: String
  , "url"  :: Maybe String
  , "gene" :: Maybe String
  | r )

type AnnotationField = { field :: String, value :: Foreign }

type Annotation r =
  Feature (Record (AnnotationRow ChrId Bp
                     ( rest :: List AnnotationField | r )))

annotationFields :: ∀ a b rl.
                    Keys rl
                 => RowToList (AnnotationRow a b ()) rl
                 => List String
annotationFields =
  Record.keys (unsafeCoerce unit :: Record (AnnotationRow a b ()))

parseAnnotation :: CoordSys ChrId BigInt
                -> Foreign
                -> F (Annotation ())
parseAnnotation cSys a = do
  raw <- Simple.read' a
  rest <- parseAnnotationRest a

  let
      feature =
        build
         (insert    (SProxy :: SProxy "rest") rest
         >>> modify (SProxy :: SProxy "chr") ChrId
         >>> modify (SProxy :: SProxy "pos") Bp) raw

      position = (\p -> Pair p p) $ feature.pos

  frameSize <- case Map.lookup feature.chr (view _Segments cSys) of

    Nothing ->
      throwError $ pure $ ForeignError
                     "Annotation chr not found in coordinate system!"
    Just seg ->
      pure $ Bp $ BigInt.toNumber $ pairSize seg

  pure $ { position
         , frameSize
         , feature }

-- | Partially parse the parts of the annotation record that are *not* in the Annotation type
parseAnnotationRest :: Foreign
                    -> F (List AnnotationField)
parseAnnotationRest a = do
  allFields <- List.fromFoldable <$> Foreign.keys a

  let restFields = allFields `List.difference` annotationFields

  for restFields \field ->
     { field, value: _ } <$> Foreign.readProp field a

-- | A completely dumb default way of rendering arbitrary annotation fields
showAnnotationField :: AnnotationField -> String
showAnnotationField fv = fv.field <> ": " <> unsafeCoerce fv.value

showAnnotation :: Annotation ()
               -> List String
showAnnotation a = (List.fromFoldable
                    [ name, chr, pos ]) <> (map showAnnotationField annot.rest)
  where annot = a.feature
        name = fromMaybe ("SNP: " <> annot.name)
                         (("Gene: " <> _) <$> annot.gene)
        chr = "Chr: " <> show annot.chr
        pos = "Pos: " <> show annot.pos

getSNPs :: CoordSys ChrId BigInt
        -> String
        -> Aff _ (Map ChrId (Array (SNP ())))
getSNPs cs url = do
  resp <- Affjax.get url

  rawSNPs <-
    case runExcept $ Foreign.readArray resp.response of
           Left err -> throwError $ error "SNP data is not an array"
           Right as -> pure as

  let parsed =
        partitionMap (runExcept <<< parseSNP cs) rawSNPs

  pure $ groupToMap _.feature.chrId
         $ filter (\f -> Pair.fst (f.position) >= wrap zero)
         $ parsed.right

getAnnotations :: CoordSys ChrId BigInt
               -> String
               -> Aff _ (Map ChrId (Array (Annotation ())))
getAnnotations cs url = do
  resp <- Affjax.get url

  rawAnnots <- case runExcept
                    $ Foreign.readArray resp.response of
                 Left err -> throwError $ error "Annotations data is not an array"
                 Right as -> pure as

  let parsed = partitionMap
               (runExcept <<< parseAnnotation cs) rawAnnots

  -- debug/testing stuff
  liftEff do
    log $ "Raw annotations array length: " <> show (Array.length rawAnnots)
    log $ "Could not parse "
        <> show (length parsed.left :: Int)
        <> " annotations."
    log $ "Successfully parsed "
        <> show (length parsed.right :: Int)
        <> " annotations."

    -- logging with unsafeCoerce lets us examine the raw JS object in the console!
    log $ unsafeCoerce (parsed.right)
  case Array.head parsed.right of
    Nothing -> pure unit
    Just an -> liftEff do
      log "first annotation: "
      sequence_ (log <$> (("> " <> _) <$> showAnnotation an))

  pure $ groupToMap _.feature.chr parsed.right

peak1 :: ∀ rS.
         Bp
      -> Array (SNP rS)
      -> Maybe (Tuple (Peak Bp Number (SNP rS))
                      (Array (SNP rS)))
peak1 radius snps = do
  top <- minimumBy (compare `on` _.feature.score) snps

  let covers = radius `aroundPair` top.position
      y = top.feature.score
      {no, yes} = partition (\p -> p.position `pairsOverlap` covers) snps

  pure $ Tuple {covers, y, elements: yes} no

peaks :: ∀ rS.
         Bp
      -> Array (SNP rS)
      -> Array (Peak Bp Number (SNP rS))
peaks r snps = unfoldr (peak1 r) snps

annotationLegendEntry :: ∀ r. Annotation r -> LegendEntry
annotationLegendEntry a =
  case a.feature.gene of
    Nothing -> mkIcon blue "SNP name"
    Just gn -> mkIcon red "Gene name"

annotationLegendTest :: ∀ f r.
                   Foldable f
                => Functor f
                => Map ChrId (f (Annotation r))
                -> Array LegendEntry
annotationLegendTest fs = trackLegend annotationLegendEntry as
  where as = Array.concat
             $ Array.fromFoldable
             $ Array.fromFoldable <$> Map.values fs

------------ new renderers~~~~~~~~~

placeScored :: ∀ r1 r2.
               { min :: Number, max :: Number | r1 }
            -> Feature { score :: Number | r2 }
            -> NPoint
placeScored vs s =
    { x: featureNormX s
    , y: wrap $ normYLogScore vs s.feature.score
    }

normYLogScore s =
  normalize s.min s.max <<< unwrap <<< view _NegLog10

dist :: Point -> Point -> Number
dist p1 p2 = Math.sqrt $ x' `Math.pow` 2.0 + y' `Math.pow` 2.0
  where x' = p1.x - p2.x
        y' = p1.y - p2.y

filterSig :: ∀ r1 r2.
             { sig :: Number | r1 }
          -> Map ChrId (Array (SNP r2))
          -> Map ChrId (Array (SNP r2))
filterSig {sig} = map (filter
  (\snp -> snp.feature.score <= (NegLog10 sig ^. re _NegLog10)))

snpsUI :: ∀ r.
          { min :: Number, max :: Number, sig :: Number, color :: Color | r }
       -> UISlotGravity
       -> BrowserCanvas
       -> Drawing
snpsUI vscale = renderFixedUI (drawVScaleInSlot vscale)

annotationsUI :: ∀ r.
                 { entries :: Array LegendEntry | r }
              -> UISlotGravity
              -> BrowserCanvas
              -> Drawing
annotationsUI legend = renderFixedUI (drawLegendInSlot legend)

renderSNPs :: ∀ r.
              { min :: Number, max :: Number | r }
           -> Canvas.Dimensions
           -> Map ChrId (Array (SNP ()))
           -> Map ChrId (Pair Number)
           -> RenderedTrack (SNP ())
renderSNPs verScale cdim snps =
  let features :: Array (SNP ())
      features = fold snps

      radius = 3.75

      drawing =
          let color = darkblue
              c = circle 0.0 0.0 radius
              out = outlined (outlineColor color) c
              fill = filled (fillColor color) c
          in out <> fill

      drawings :: Array (Tuple (SNP ()) Point) -> Array DrawingN
      drawings pts = let (Tuple _ points) = Array.unzip pts
                     in [{ drawing, points }]

      npointed :: Map ChrId (Array (Tuple (SNP ()) NPoint))
      npointed = (map <<< map)
        (fanout id (\s ->
           { x: featureNormX s
           , y: wrap $ normYLogScore verScale s.feature.score })) snps

      rescale :: Pair Number -> NPoint -> Point
      rescale seg@(Pair offset _) npoint =
        let x = offset + (pairSize seg) * (unwrap npoint.x)
            y = cdim.height * (one - unwrap npoint.y)
        in {x, y}

      pointed :: Map ChrId (Pair Number)
              -> Array (Tuple (SNP ()) Point)
      pointed segs = foldMapWithIndex f segs
        where f chrId seg = foldMap ((map <<< map) $ rescale seg)
                              $ Map.lookup chrId npointed

      overlaps :: Array (Tuple (SNP ()) Point)
               -> Number -> Point
               -> Array (SNP ())
      overlaps pts radius' pt = filterMap covers pts
        where covers :: Tuple (SNP ()) Point -> Maybe (SNP ())
              covers (Tuple f fPt)
                | dist fPt pt <= radius + radius'   = Just f
                | otherwise = Nothing

  in \seg -> let pts = pointed seg
             in { features
                , drawings: drawings pts
                , labels: mempty
                , overlaps: overlaps pts }

renderAnnotation :: ∀ r r1 r2.
                    CoordSys _ _
                 -> Map ChrId (Array (SNP ()))
                 -> { min :: Number, max :: Number | r }
                 -> Canvas.Dimensions
                 -> Map ChrId (Array (Annotation r2))
                 -> Map ChrId (Pair Number)
                 -> RenderedTrack (Annotation r2)
renderAnnotation cSys sigSnps vScale cdim allAnnots =
  let
      peakAnnots seg@(Pair l _) snps size annots pk = { covers, y, elements }
        where covers = (\x -> l + pairSize seg * (unwrap $ x / size)) <$> pk.covers
              y = cdim.height * (one - normYLogScore vScale pk.y)
              elements = filter (pairsOverlap pk.covers <<< _.position) annots

      curAnnotPeaks :: Map ChrId (Pair Number)
                    -> Map ChrId (Array (Peak Number Number (Annotation r2)))
      curAnnotPeaks = mapWithIndex f
        where f :: ChrId -> Pair Number -> Array (Peak _ _ (Annotation r2))
              f chr seg = fromMaybe [] do
                  snps      <- Map.lookup chr sigSnps
                  annots    <- Map.lookup chr allAnnots
                  frameSize <- _.frameSize <$> Array.head snps

                  let rad = (wrap 3.75 * frameSize) / (wrap $ pairSize seg)

                  pure $ peakAnnots seg snps frameSize annots
                       <$> peaks rad snps

      tailHeight = 0.06
      tailPixels = tailHeight * cdim.height
      iconYOffset = 6.5
      labelOffset = 8.0

      -- part of the canvas that a given peak will cover when rendered
      drawingCovers :: ∀ a.
                       Peak Number Number a
                    -> Canvas.Rectangle
      drawingCovers aPeak = {x,y,w,h}
        where (Pair x _) = aPeak.covers
              w = 14.0  -- hardcoded glyph width in pixels
              gH = (11.0 - iconYOffset) -- hardcoded height
              h = tailPixels + gH * length aPeak.elements
              y = aPeak.y - h

      drawAndLabel :: Peak Number Number (Annotation r2)
                   -> Tuple (Array DrawingN) (Array Label)
      drawAndLabel aPeak = Tuple [drawing] label
        where
              (Pair l r) = aPeak.covers
              x = l + 0.5 * (r - l)

              icons = Drawing.translate 0.0 (-tailPixels)
                      $ foldr (\a d -> Drawing.translate 0.0 (-iconYOffset)
                                     $ (annotationLegendEntry a).icon <> d)
                          mempty aPeak.elements

              tail = if Array.null aPeak.elements
                then mempty
                else Drawing.outlined (lineWidth 1.3 <> outlineColor black)
                       $ Drawing.path [ {x: 0.0, y: 0.0 }, {x: 0.0, y: -tailPixels }]

              drawing = { drawing: tail <> icons, points: [{x, y: aPeak.y }] }

              -- hardcoded font size because this will be handled by UI.Canvas later
              fontHeight = 14.0
              labelsHeight = length aPeak.elements * fontHeight

              dC = drawingCovers aPeak
                -- if all the labels fit above the icons, they're centered;
                -- otherwise just place them to the left and hope for the best
              {g, y0} = if dC.y > labelsHeight
                then { g: LCenter, y0: dC.y  }
                else { g: LLeft, y0: aPeak.y }

              label = Tuple.snd $ foldr f (Tuple y0 mempty) aPeak.elements
              f a (Tuple y ls) = Tuple (y - labelOffset)
                                    $ Array.snoc ls
                                         { text: fromMaybe a.feature.name a.feature.gene
                                         , point: { x, y }
                                         , gravity: g
                                         }

      drawAndLabelAll :: Map ChrId (Array (Peak _ _ _))
                      -> Tuple (Array DrawingN) (Array Label)
      drawAndLabelAll pks = foldMap (foldMap drawAndLabel) pks

      features :: Array (Annotation r2)
      features = fold allAnnots

  in \segs -> let (Tuple drawings labels) =
                    drawAndLabelAll $ curAnnotPeaks segs
              in { features
                 , drawings, labels
                 , overlaps: mempty  }

demoBrowser :: ∀ r.
               CoordSys ChrId BigInt
            -> { score :: { min :: Number, max :: Number, sig :: Number } | r }
            -> { snps        :: Map ChrId (Array _)
               , annotations :: Map ChrId (Array _)
               , genes       :: Map ChrId (Array _) }
            -> BrowserCanvas
            -> CoordSysView
            -> { tracks     :: { snps        :: RenderedTrack (SNP _)
                               , annotations :: RenderedTrack (Annotation _) }
               , relativeUI :: Drawing
               , fixedUI    :: Drawing }
demoBrowser cSys config trackData =
  let
      vscale =
        build (insert (SProxy :: SProxy "color") black)
          $ config.score

      sigSnps = filterSig config.score trackData.snps
      entries = annotationLegendTest trackData.annotations

      snps =
        renderTrack cSys (renderSNPs vscale) trackData.snps

      annotations =
        renderTrack cSys (renderAnnotation cSys sigSnps vscale) trackData.annotations

      relativeUI = chrLabelsUI cSys

  in \bc v ->
    let trackDim = bc ^. _Track <<< _Dimensions
        slots = uiSlots bc
        fixedUI = (snpsUI vscale UILeft bc)
                <> (annotationsUI {entries} UIRight bc)
                <> (Drawing.translate slots.left.size.width slots.top.size.height
                    $ sigLevelRuler vscale red trackDim)

    in { tracks: { snps: snps bc v
                 , annotations: annotations bc v }
       , relativeUI: relativeUI bc v
       , fixedUI }


fix version label

fix version label

module Main where

import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Console (CONSOLE, log)
import Control.Monad.Eff.Exception (EXCEPTION, stack)
import Control.Monad.Eff.Random (RANDOM, randomInt)
import Control.Monad.Rec.Class (Step(..), tailRecM2)
import Control.Safely as Safe
import DOM (DOM)
import DOM.Event.Event (eventPhase, preventDefault)
import Data.Array (cons, deleteAt, filter, findIndex, index, length, mapWithIndex, modifyAt, unsafeIndex, updateAt, (!!))
import Data.Monoid (class Monoid, mempty)
import Data.Traversable (traverse_)
import Data.Maybe (Maybe(..), fromMaybe)
import Debug.Trace as DT
import Prelude hiding (div,id)
import Pux (EffModel, noEffects, start)
import Pux.DOM.Events (DOMEvent, onClick)
import Pux.DOM.HTML (HTML, memoize)
import Pux.Renderer.React (renderToDOM)
import Signal.Channel (CHANNEL)
import Text.Smolder.HTML (a, button, div, h1, span, table, tbody, td, tr)
import Text.Smolder.HTML.Attributes (className, href, selected, type', id)
import Text.Smolder.Markup (attribute, text, (!), (#!))

----------
-- Main Entry

-- | Start and render the app
main :: Eff (dom :: DOM, channel :: CHANNEL, exception :: EXCEPTION, random :: RANDOM, console :: CONSOLE) Unit
main = do
  app <- start
    { initialState: init
    , view
    , foldp
    , inputs: []
    }

  renderToDOM "#app" app.markup app.input

----------
-- State

type State =
  { rows   :: Array Row
  , lastId :: Int }

type Row =
  { rid        :: Int
  , label      :: String
  , isSelected :: Boolean }

init :: State
init =
  { rows: [], lastId: 1 }

----------
-- Events

data Event
  = MergeRows MergeType (Array Row) Int
  | Create MergeType Int DOMEvent
  | UpdateEvery Int DOMEvent
  | Clear DOMEvent
  | Swap Int Int DOMEvent
  | Remove Int DOMEvent
  | Select Int DOMEvent

data MergeType
  = Replace
  | Append

----------
-- Updates

-- | Return a new state (and effects) from each event
foldp :: Event -> State -> EffModel State Event (dom :: DOM, random :: RANDOM, console :: CONSOLE)

-- Write the received N rows over the rows held by the state,
-- and update the last Id to the received index.
foldp (MergeRows Replace arr i) st =
  noEffects $ st { rows = arr, lastId = i }

-- Append the received N rows into the rows held by the state, and update
-- the last Id to the received index.
foldp (MergeRows Append arr i) st =
  noEffects $ st { rows = st.rows <> arr, lastId = i }

-- Clear all rows from the screen and reset the last id to 1
foldp (Clear ev) st =
  { state: st { rows = [], lastId = 1 }, effects: [ liftEff (preventDefault ev) *> pure Nothing] }

-- Create the specified number of rows and prevent the browser
-- from receiving the click event. Depending on the provided
-- merger type (append or replace), return the proper event.
foldp (Create merger i ev) st =
  { state: st
  , effects: [ liftEff $ do
                    preventDefault ev
                    rows <- createRandomNRows i st.lastId
                    pure $ Just $ MergeRows merger rows (st.lastId + i) ] }

-- Update every row at the specified interval by appending three
-- exclamation points.
foldp (UpdateEvery i ev) st =
  { state: st
  , effects: [ liftEff $ do
                    preventDefault ev
                    pure $ Just $ MergeRows Replace (mapWithIndex (updateRowLabel i) st.rows) st.lastId ] }

-- Swap two rows in the view array (standard set to index 4 and 9)
foldp (Swap i0 i1 ev) st =
  { state: st
  , effects: [ liftEff $ do
                  preventDefault ev
                  case swapRows st.rows i0 i1 of
                    Nothing  -> log "Failed to swap rows." *>
                                pure Nothing
                    Just arr -> pure $ Just $ MergeRows Replace arr st.lastId ] }

-- Toggle the selected status of the row at the given index
foldp (Select i ev) st =
  { state: st
  , effects: [ liftEff $ do
                  preventDefault ev
                  pure $ Just $ MergeRows Replace (fromMaybe st.rows $ updateRowSelected i st.rows) st.lastId ] }

-- Toggle the selected status of the row at the given index
foldp (Remove i ev) st =
  { state: st
  , effects: [ liftEff $ do
                  preventDefault ev
                  pure $ Just $ MergeRows Replace (deleteRow i st.rows) st.lastId ] }

-----
-- Update Helpers

-- | Create new batch of random rows
-- | Note: use `tailRecM` to ensure proper tail recursion in monadic code
createRandomNRows :: forall e. Int -> Int -> Eff ( random :: RANDOM | e) (Array Row)
createRandomNRows n lastId = tailRecM2 f [] n
  where
    f arr 0 = pure (Done arr)
    f arr n = do
      str <- selectConcatItems

      let str' = case str of
            Nothing -> ""
            Just s  -> s

      pure (Loop $ { a: (createAndAppendRow arr (n - 1) lastId str')
                   , b: (n - 1) })

-- | Create a single row
createAndAppendRow :: Array Row -> Int -> Int -> String -> Array Row
createAndAppendRow arr index lastId s =
  cons
  ({ rid: lastId + index
    , label: s
    , isSelected: false })
  arr

-- | Select a random element from each array of strings,
-- | and then concatenate them into a string value.
selectConcatItems :: forall e. Eff ( random :: RANDOM | e) (Maybe String)
selectConcatItems = do
  adj <- index adjectives <$> (randomInt 1 $ length adjectives - 1)
  clr <- index colours    <$> (randomInt 1 $ length colours - 1)
  non <- index nouns      <$> (randomInt 1 $ length nouns - 1)

  pure $ adj <> Just " " <> clr <> Just " " <> non

-- | For use in iterating through rows
updateRowLabel :: Int -> Int -> Row -> Row
updateRowLabel interval ix row =
  if ix `mod` interval == 0
  then row { label = row.label <> " !!!" }
  else row

-- | Update the status of a particular row.
--   Only one row is selected at any time
updateRowSelected :: Int -> Array Row -> Maybe (Array Row)
updateRowSelected pos arr = do
  let s' = findIndex (\x -> x.isSelected) arr
  case s' of
    Nothing -> do
      i <- findIndex (\x -> x.rid == pos) arr
      modifyAt i (\x -> x { isSelected = true }) arr
    Just s  -> do
      i <- findIndex (\x -> x.rid == pos) arr
      if s == i
         then pure arr
         else do
            deselect <- modifyAt s (\x -> x { isSelected = false }) arr
            modifyAt i (\x -> x { isSelected = true }) deselect

-- | Remove a status a particular row.
deleteRow :: Int -> Array Row -> Array Row
deleteRow pos arr =
  case rowIndex of
    Nothing -> arr
    Just i  ->
      case deleteAt i arr of
        Nothing   -> arr
        Just arr' -> arr'
  where
    rowIndex = findIndex (\x -> x.rid == pos) arr

-- | Swap two rows in an array, updating their ids
swapRows :: Array Row -> Int -> Int -> Maybe (Array Row)
swapRows arr index1 index2 = do
  rowA <- arr !! index1
  rowB <- arr !! index2

  let diff = index2 - index1
  arrA <- updateAt index1 rowB { rid = rowB.rid - diff } arr
  arrB <- updateAt index2 rowA { rid = rowA.rid + diff } arrA

  pure arrB

----------
-- View

-- | Return markup from the state
view :: State -> HTML Event
view = memoize \st ->
  div ! className "container" $ do

    div ! className "jumbotron" $ do
      div ! className "row" $ do
        div ! className "col-md-6" $ do
          h1 $ text "Pux 11.0.0"
        div ! className "col-md-6" $ do
          traverse_ viewButton buttons

    table ! className "table table-hover table-striped test-data" $ do
      tbody $ do
        Safe.traverse_ viewRow st.rows

viewRow :: Row -> HTML Event
viewRow { rid, label, isSelected } = do
  case isSelected of
    true  -> tr ! selected "true" ! className "danger"
    false -> tr ! selected ""

  $ do
      td ! className "col-md-1" $ text (show rid)
      td ! className "col-md-4" $
         a ! href "#" #! onClick (Select rid) $ text label
      td ! className "col-md-1" $ do
         a ! href "#" $ do
           span ! className "glyphicon glyphicon-remove"
                ! attribute "aria-hidden" "true"
                #! onClick (Remove rid)
                $ text ""
      td ! className "col-md-6" $ text ""

viewButton :: { bid :: String, str :: String, ev :: (DOMEvent -> Event) } -> HTML Event
viewButton { bid, str, ev } =
  div ! className "col-sm-6 smallpad" $ do
    button
      ! type' "button"
      ! className "btn btn-primary btn-block"
      ! id bid
      #! onClick ev
      $ text str

buttons :: Array { bid :: String, str :: String, ev :: (DOMEvent -> Event) }
buttons =
  [ { bid: "run",      str: "Create 1,000 Rows",     ev: Create Replace 1000  }
  , { bid: "runlots",  str: "Create 10,000 Rows",    ev: Create Replace 10000 }
  , { bid: "add",      str: "Append 1,000 Rows",     ev: Create Append  1000  }
  , { bid: "update",   str: "Update Every 10th Row", ev: UpdateEvery 10 }
  , { bid: "clear",    str: "Clear",                 ev: Clear }
  , { bid: "swaprows", str: "Swap Rows",             ev: Swap 4 9 } ]

----------
-- Supporting Data

adjectives :: Array String
adjectives =
    [ "pretty"
    , "large"
    , "big"
    , "small"
    , "tall"
    , "short"
    , "long"
    , "handsome"
    , "plain"
    , "quaint"
    , "clean"
    , "elegant"
    , "easy"
    , "angry"
    , "crazy"
    , "helpful"
    , "mushy"
    , "odd"
    , "unsightly"
    , "adorable"
    , "important"
    , "inexpensive"
    , "cheap"
    , "expensive"
    , "fancy"
    ]

colours :: Array String
colours =
    [ "red"
    , "yellow"
    , "blue"
    , "green"
    , "pink"
    , "brown"
    , "purple"
    , "brown"
    , "white"
    , "black"
    , "orange"
    ]

nouns :: Array String
nouns =
    [ "table"
    , "chair"
    , "house"
    , "bbq"
    , "desk"
    , "car"
    , "pony"
    , "cookie"
    , "sandwich"
    , "burger"
    , "pizza"
    , "mouse"
    , "keyboard"
    ]

module Main where

import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Console (CONSOLE, log)
import Control.Monad.Eff.Exception (EXCEPTION, stack)
import Control.Monad.Eff.Random (RANDOM, randomInt)
import Control.Monad.Rec.Class (Step(..), tailRecM2)
import Control.Safely as Safe
import DOM (DOM)
import DOM.Event.Event (eventPhase, preventDefault)
import Data.Array (cons, deleteAt, filter, findIndex, index, length, mapWithIndex, modifyAt, unsafeIndex, updateAt, (!!))
import Data.Monoid (class Monoid, mempty)
import Data.Traversable (traverse_)
import Data.Maybe (Maybe(..), fromMaybe)
import Debug.Trace as DT
import Prelude hiding (div,id)
import Pux (EffModel, noEffects, start)
import Pux.DOM.Events (DOMEvent, onClick)
import Pux.DOM.HTML (HTML, memoize)
import Pux.Renderer.React (renderToDOM)
import Signal.Channel (CHANNEL)
import Text.Smolder.HTML (a, button, div, h1, span, table, tbody, td, tr)
import Text.Smolder.HTML.Attributes (className, href, selected, type', id)
import Text.Smolder.Markup (attribute, text, (!), (#!))

----------
-- Main Entry

-- | Start and render the app
main :: Eff (dom :: DOM, channel :: CHANNEL, exception :: EXCEPTION, random :: RANDOM, console :: CONSOLE) Unit
main = do
  app <- start
    { initialState: init
    , view
    , foldp
    , inputs: []
    }

  renderToDOM "#app" app.markup app.input

----------
-- State

type State =
  { rows   :: Array Row
  , lastId :: Int }

type Row =
  { rid        :: Int
  , label      :: String
  , isSelected :: Boolean }

init :: State
init =
  { rows: [], lastId: 1 }

----------
-- Events

data Event
  = MergeRows MergeType (Array Row) Int
  | Create MergeType Int DOMEvent
  | UpdateEvery Int DOMEvent
  | Clear DOMEvent
  | Swap Int Int DOMEvent
  | Remove Int DOMEvent
  | Select Int DOMEvent

data MergeType
  = Replace
  | Append

----------
-- Updates

-- | Return a new state (and effects) from each event
foldp :: Event -> State -> EffModel State Event (dom :: DOM, random :: RANDOM, console :: CONSOLE)

-- Write the received N rows over the rows held by the state,
-- and update the last Id to the received index.
foldp (MergeRows Replace arr i) st =
  noEffects $ st { rows = arr, lastId = i }

-- Append the received N rows into the rows held by the state, and update
-- the last Id to the received index.
foldp (MergeRows Append arr i) st =
  noEffects $ st { rows = st.rows <> arr, lastId = i }

-- Clear all rows from the screen and reset the last id to 1
foldp (Clear ev) st =
  { state: st { rows = [], lastId = 1 }, effects: [ liftEff (preventDefault ev) *> pure Nothing] }

-- Create the specified number of rows and prevent the browser
-- from receiving the click event. Depending on the provided
-- merger type (append or replace), return the proper event.
foldp (Create merger i ev) st =
  { state: st
  , effects: [ liftEff $ do
                    preventDefault ev
                    rows <- createRandomNRows i st.lastId
                    pure $ Just $ MergeRows merger rows (st.lastId + i) ] }

-- Update every row at the specified interval by appending three
-- exclamation points.
foldp (UpdateEvery i ev) st =
  { state: st
  , effects: [ liftEff $ do
                    preventDefault ev
                    pure $ Just $ MergeRows Replace (mapWithIndex (updateRowLabel i) st.rows) st.lastId ] }

-- Swap two rows in the view array (standard set to index 4 and 9)
foldp (Swap i0 i1 ev) st =
  { state: st
  , effects: [ liftEff $ do
                  preventDefault ev
                  case swapRows st.rows i0 i1 of
                    Nothing  -> log "Failed to swap rows." *>
                                pure Nothing
                    Just arr -> pure $ Just $ MergeRows Replace arr st.lastId ] }

-- Toggle the selected status of the row at the given index
foldp (Select i ev) st =
  { state: st
  , effects: [ liftEff $ do
                  preventDefault ev
                  pure $ Just $ MergeRows Replace (fromMaybe st.rows $ updateRowSelected i st.rows) st.lastId ] }

-- Toggle the selected status of the row at the given index
foldp (Remove i ev) st =
  { state: st
  , effects: [ liftEff $ do
                  preventDefault ev
                  pure $ Just $ MergeRows Replace (deleteRow i st.rows) st.lastId ] }

-----
-- Update Helpers

-- | Create new batch of random rows
-- | Note: use `tailRecM` to ensure proper tail recursion in monadic code
createRandomNRows :: forall e. Int -> Int -> Eff ( random :: RANDOM | e) (Array Row)
createRandomNRows n lastId = tailRecM2 f [] n
  where
    f arr 0 = pure (Done arr)
    f arr n = do
      str <- selectConcatItems

      let str' = case str of
            Nothing -> ""
            Just s  -> s

      pure (Loop $ { a: (createAndAppendRow arr (n - 1) lastId str')
                   , b: (n - 1) })

-- | Create a single row
createAndAppendRow :: Array Row -> Int -> Int -> String -> Array Row
createAndAppendRow arr index lastId s =
  cons
  ({ rid: lastId + index
    , label: s
    , isSelected: false })
  arr

-- | Select a random element from each array of strings,
-- | and then concatenate them into a string value.
selectConcatItems :: forall e. Eff ( random :: RANDOM | e) (Maybe String)
selectConcatItems = do
  adj <- index adjectives <$> (randomInt 1 $ length adjectives - 1)
  clr <- index colours    <$> (randomInt 1 $ length colours - 1)
  non <- index nouns      <$> (randomInt 1 $ length nouns - 1)

  pure $ adj <> Just " " <> clr <> Just " " <> non

-- | For use in iterating through rows
updateRowLabel :: Int -> Int -> Row -> Row
updateRowLabel interval ix row =
  if ix `mod` interval == 0
  then row { label = row.label <> " !!!" }
  else row

-- | Update the status of a particular row.
--   Only one row is selected at any time
updateRowSelected :: Int -> Array Row -> Maybe (Array Row)
updateRowSelected pos arr = do
  let s' = findIndex (\x -> x.isSelected) arr
  case s' of
    Nothing -> do
      i <- findIndex (\x -> x.rid == pos) arr
      modifyAt i (\x -> x { isSelected = true }) arr
    Just s  -> do
      i <- findIndex (\x -> x.rid == pos) arr
      if s == i
         then pure arr
         else do
            deselect <- modifyAt s (\x -> x { isSelected = false }) arr
            modifyAt i (\x -> x { isSelected = true }) deselect

-- | Remove a status a particular row.
deleteRow :: Int -> Array Row -> Array Row
deleteRow pos arr =
  case rowIndex of
    Nothing -> arr
    Just i  ->
      case deleteAt i arr of
        Nothing   -> arr
        Just arr' -> arr'
  where
    rowIndex = findIndex (\x -> x.rid == pos) arr

-- | Swap two rows in an array, updating their ids
swapRows :: Array Row -> Int -> Int -> Maybe (Array Row)
swapRows arr index1 index2 = do
  rowA <- arr !! index1
  rowB <- arr !! index2

  let diff = index2 - index1
  arrA <- updateAt index1 rowB { rid = rowB.rid - diff } arr
  arrB <- updateAt index2 rowA { rid = rowA.rid + diff } arrA

  pure arrB

----------
-- View

-- | Return markup from the state
view :: State -> HTML Event
view = memoize \st ->
  div ! className "container" $ do

    div ! className "jumbotron" $ do
      div ! className "row" $ do
        div ! className "col-md-6" $ do
          h1 $ text "Pux 10.0.0"
        div ! className "col-md-6" $ do
          traverse_ viewButton buttons

    table ! className "table table-hover table-striped test-data" $ do
      tbody $ do
        Safe.traverse_ viewRow st.rows

viewRow :: Row -> HTML Event
viewRow { rid, label, isSelected } = do
  case isSelected of
    true  -> tr ! selected "true" ! className "danger"
    false -> tr ! selected ""

  $ do
      td ! className "col-md-1" $ text (show rid)
      td ! className "col-md-4" $
         a ! href "#" #! onClick (Select rid) $ text label
      td ! className "col-md-1" $ do
         a ! href "#" $ do
           span ! className "glyphicon glyphicon-remove"
                ! attribute "aria-hidden" "true"
                #! onClick (Remove rid)
                $ text ""
      td ! className "col-md-6" $ text ""

viewButton :: { bid :: String, str :: String, ev :: (DOMEvent -> Event) } -> HTML Event
viewButton { bid, str, ev } =
  div ! className "col-sm-6 smallpad" $ do
    button
      ! type' "button"
      ! className "btn btn-primary btn-block"
      ! id bid
      #! onClick ev
      $ text str

buttons :: Array { bid :: String, str :: String, ev :: (DOMEvent -> Event) }
buttons =
  [ { bid: "run",      str: "Create 1,000 Rows",     ev: Create Replace 1000  }
  , { bid: "runlots",  str: "Create 10,000 Rows",    ev: Create Replace 10000 }
  , { bid: "add",      str: "Append 1,000 Rows",     ev: Create Append  1000  }
  , { bid: "update",   str: "Update Every 10th Row", ev: UpdateEvery 10 }
  , { bid: "clear",    str: "Clear",                 ev: Clear }
  , { bid: "swaprows", str: "Swap Rows",             ev: Swap 4 9 } ]

----------
-- Supporting Data

adjectives :: Array String
adjectives =
    [ "pretty"
    , "large"
    , "big"
    , "small"
    , "tall"
    , "short"
    , "long"
    , "handsome"
    , "plain"
    , "quaint"
    , "clean"
    , "elegant"
    , "easy"
    , "angry"
    , "crazy"
    , "helpful"
    , "mushy"
    , "odd"
    , "unsightly"
    , "adorable"
    , "important"
    , "inexpensive"
    , "cheap"
    , "expensive"
    , "fancy"
    ]

colours :: Array String
colours =
    [ "red"
    , "yellow"
    , "blue"
    , "green"
    , "pink"
    , "brown"
    , "purple"
    , "brown"
    , "white"
    , "black"
    , "orange"
    ]

nouns :: Array String
nouns =
    [ "table"
    , "chair"
    , "house"
    , "bbq"
    , "desk"
    , "car"
    , "pony"
    , "cookie"
    , "sandwich"
    , "burger"
    , "pizza"
    , "mouse"
    , "keyboard"
    ]


more tests

more tests

module Test.Main where

import Control.Monad.Eff
import Data.Eq
import Debug.Trace
import Test.StrongCheck
import Test.StrongCheck.Gen
import Test.StrongCheck.Perturb
import Test.StrongCheck.Landscape
import Control.Monad.Trampoline
import Data.Monoid
import Data.Tuple
import Data.Maybe
import Data.Foldable
import qualified Data.Array as Array
import qualified Math as Math

between :: forall a. (Ord a) => a -> a -> a -> Boolean
between min max = \n -> n >= min && n <= max

data Mega  = Mega {
  arrayOf     :: [Number],
  arrayOf1    :: [Number],
  choose      :: Number,
  chooseInt   :: Number,
  collectAll  :: [Number],
  allInArray  :: [Number],
  allInRange  :: [Number],
  dropGen     :: [Number],
  takeGen     :: [Number],
  elements    :: [String],
  extend      :: [String],
  infinite    :: [String],
  perms       :: [[String]],
  combos      :: [[String]],
  chunked     :: [[String]] }

{- TODO: Remaining cases
  , frequency
  , oneOf
  , perturbGen
  , repeatable
  , resize
  , sample
  , sample'
  , showSample
  , showSample'
  , sized
  , stateful
  , suchThat
  , suchThatMaybe
  , unfoldGen
  , uniform
  , variant
  , vectorOf
  -}

data DetABC = DetABC String

runDetABC :: DetABC -> String
runDetABC (DetABC s) = s

instance arbDetABC :: Arbitrary DetABC where
  arbitrary = DetABC <$> allInArray ["A", "B", "C"]

data OneToTen = OneToTen Number

runOneToTen :: OneToTen -> Number
runOneToTen (OneToTen n) = n

instance arbOneToTen :: Arbitrary OneToTen where
  arbitrary = OneToTen <$> chooseInt 0 10

instance arbMega :: Arbitrary Mega where
  arbitrary = do
    arrayOf'    <- arrayOf (choose 0 10)
    arrayOf1'   <- arrayOf1 (choose 0 10)
    choose'     <- choose 0 10
    chooseInt'  <- chooseInt 0 10
    collectAll' <- collectAll mempty (allInArray [0, 1, 2])
    allInArray' <- collectAll mempty (allInArray [0, 1, 2])
    allInRange' <- collectAll mempty (allInRange 0 10)
    dropGen'    <- collectAll mempty $ dropGen 2 (allInArray [2, 1, -1])
    takeGen'    <- collectAll mempty $ takeGen 2 (allInArray [2, 1, -1])
    elements'   <- arrayOf $ elements "foo" ["bar", "baz"]
    extend'     <- collectAll mempty $ extend 3 (pure "5")
    infinite'   <- collectAll mempty $ takeGen 4 (infinite $ pure "foo")
    perms'      <- collectAll mempty $ perms ["John", "D"]
    combos'     <- collectAll mempty $ nChooseK 2 ["foo", "bar", "baz"]
    chunked'    <- collectAll mempty $ chunked 3 (pure "foo")
    return $ Mega {
      arrayOf:    arrayOf',
      arrayOf1:   (case arrayOf1' of Tuple a as -> a : as),
      choose:     choose',
      chooseInt:  chooseInt',
      collectAll: collectAll',
      allInArray: allInArray',
      allInRange: allInRange',
      dropGen:    dropGen',
      takeGen:    takeGen',
      elements:   elements',
      extend:     extend',
      infinite:   infinite',
      perms:      perms',
      combos:     combos',
      chunked:    chunked' }

verify_gen :: Mega -> Result
verify_gen (Mega m) = fold [
  all (between 0 10) m.arrayOf                        <?> "arrayOf: "     ++ show m.arrayOf,
  Array.length m.arrayOf1 >= 1                        <?> "arrayOf1: "    ++ show m.arrayOf1,
  between 0 10 m.choose                               <?> "choose: "      ++ show m.choose,
  between 0 10 m.chooseInt &&
  Math.floor(m.chooseInt) == m.chooseInt              <?> "chooseInt: "   ++ show m.chooseInt,
  m.collectAll == [0, 1, 2]                           <?> "collectAll: "  ++ show m.collectAll,
  m.allInArray == [0, 1, 2]                           <?> "allInArray: "  ++ show m.allInArray,
  m.allInRange == [0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10]  <?> "allInRange: "  ++ show m.allInRange,
  m.dropGen == [-1]                                   <?> "dropGen: "     ++ show m.dropGen,
  m.takeGen == [2, 1]                                 <?> "takeGen: "     ++ show m.takeGen,
  all (flip elem ["foo", "bar", "baz"]) m.elements    <?> "elements: "    ++ show m.elements,
  Array.take 3 m.extend == ["5", "5", "5"]            <?> "extend: "      ++ show m.extend,
  m.infinite == ["foo", "foo", "foo", "foo"]          <?> "infinite: "    ++ show m.infinite,
  m.perms == ["John", "D"] : ["D", "John"] : []       <?> "perms: "       ++ show m.perms,
  m.combos == ["foo", "bar"] : ["foo", "baz"] :
              ["bar", "baz"] : []                     <?> "combos: "      ++ show m.combos,
  m.chunked == ["foo", "foo", "foo"] : []             <?> "chunked: "     ++ show m.chunked]

main = do
  trace "Gen combinators"
  quickCheck $ verify_gen

  trace "foldGen"
  quickCheck $ (runTrampoline $ foldGen (\a b -> Just $ a + b) 1 mempty (allInArray [1, 2, 3])) == 7

  trace "smallCheck"
  smallCheck $ runDetABC >>> (flip elem ["A", "B", "C"])

  trace "Fair distribution of booleans"
  statCheck (1/2) $ (==) true

  trace "Fair distribution of ints"
  statCheck (1/11) $ runOneToTen >>> ((==) 1)

  trace "search can find another example"
  let found n = Math.abs (n - 36) <= 2
  let v = runTrampoline $ sample 1 $ searchIn found 35.24
  trace $ show v
  assert $ maybe false found (v Array.!! 0)

  trace "creating infinite bool landscape doesn't blow the stack"
  assert $ isJust $ (somewhere 1 :: Maybe (Landscape Boolean))

  trace "sampling 100 values produces 100 values"
  assert $ ((==) 100 <<< Array.length <<< sampleHere 100 <$> (somewhere 1 :: Maybe (Landscape Boolean))) == Just true

  trace "Can move to sampled value"
  assert $ (do  l <- (somewhere 1 :: Maybe (Landscape Boolean))
                x <- Array.head $ Array.drop 50 (sampleHere 100 l)
                l <- moveTo x l
                return true) == Just true


Fix brutal typo that took forever to debug. :-(

Signed-off-by: Ricky Elrod <3de8762d49a778edd8b1aa9f381ea5a9ccb62944@elrod.me>

module Main where

import Control.Monad.Eff
import Data.DOM.Simple.Ajax
import Data.DOM.Simple.Document
import Data.DOM.Simple.Element
import Data.DOM.Simple.Encode
import Data.DOM.Simple.Events hiding (read)
import Data.DOM.Simple.Types
import Data.DOM.Simple.Window
import Data.Either
import Data.Foldable (traverse_)
import Data.Foreign
import Data.Foreign.Class
import Data.Maybe
import Debug.Trace
import DomHelpers
import GMaps.InfoWindow
import GMaps.LatLng
import GMaps.Map
import GMaps.MapOptions
import GMaps.Marker
import GMaps.MVCArray
import GMaps.Polyline
import Global
import qualified Lookangle as L
import MapViewWS
import MomentJS
import WebSocket

setDismissAnnouncement :: forall eff. HTMLDocument -> Eff (dom :: DOM | eff) Unit
setDismissAnnouncement doc = do
  -- TODO: Partial
  Just dismissButton <- getElementById "dismiss_announcement" doc
  Just announcement <- getElementById "announcement" doc
  y <- setDisplayFn announcement "none"
  setOnclick dismissButton y

setAnnouncement :: forall eff. HTMLDocument -> String -> String -> Eff (dom :: DOM | eff) Unit
setAnnouncement doc t c = do
  -- TODO: Partial
  Just announcement <- getElementById "announcement" doc
  Just text <- getElementById "announcement_text" doc
  setInnerHTML t text
  setClass announcement c
  setDisplay announcement "block"

foreign import getData
  "function getData(x) {\
  \  return function() {\
  \    return x.data;\
  \  };\
  \}" :: forall eff. Event -> Eff eff String

main = do
  doc <- document globalWindow
  --setDismissAnnouncement doc
  Just mapE <- getElementById "map-canvas" doc
  startingPoint <- newLatLng 41.714754626155 (-73.726791873574)
  roadmap <- gMap mapE (MapOptions { zoom: 6, center: startingPoint, mapTypeId: "roadmap" })
  mvcA <- newMVCArray :: forall eff. Eff eff (MVCArray LatLng)

  -- Various bits of test data to play with.
  --randomcoord <- newLatLng 41.714754626155 (-73.726791873574)
  --panTo roadmap randomcoord
  --testcoord <- newLatLng 41.714754626155 (-73.726791873574)
  --pushMVCArray mvcA testcoord
  --pushMVCArray mvcA randomcoord

  polyline <- newPolyline (PolylineOptions { geodescic: true
                                           , strokeColor: "#ff0000"
                                           , strokeOpacity: 1.0
                                           , strokeWeight: 2
                                           , map: roadmap
                                           })
  setPolylinePath polyline mvcA

  marker <- newMarker (MarkerOptions { position: startingPoint, map: roadmap, title: "HABP Location" })

  -- TODO: info window.
  --iw <- newInfoWindow (InfoWindowOptions { content: "HABP Location" })
  --openInfoWindow iw roadmap marker

  --let example = "{\"coordinates\":{\"latitude\":43.714754626155,\"longitude\":-64.726791873574},\"altitude\":300,\"time\":\"1234321\"}"
  socket <- newWebSocket "ws://127.0.0.1:9160/"
  addEventListenerWS socket "onmessage" $ (\x -> handleEvent x mvcA polyline marker)
  --sendWS socket example

  nowMoment <- now
  let leet = momentConstructor "January 1, 0678"
  let leet' = createMoment leet
  Just lastupdate <- getElementById "lastupdate" doc
  let str = liftMoment2 momentFrom nowMoment <$> leet'
  let seven = fromMaybe "Unknown" str
  setInnerHTML seven lastupdate

  where
    handleEvent e mvcA polyline marker = do
      --trace "RX from websocket"
      msgData <- getData e
      --trace msgData
      case readJSON msgData :: F WSMessage of
        Left err -> trace $ "Error parsing JSON:\n" ++ show err
        Right (LocationBeacon result) -> do
          --trace $ unsafeShowJSON result
          addToPath mvcA polyline marker result.coordinates
          updateLookangle result.coordinates result.altitude
        Right (BeaconHistory coordinates) -> do
          --trace $ unsafeShowJSON coordinates
          traverse_ (addToPath mvcA polyline marker) coordinates

addToPath ::
  forall eff.
  MVCArray LatLng
  -> Polyline
  -> Marker
  -> Coordinate
  -> Eff eff Unit
addToPath mvcA polyline marker (Coordinate c) = do
  latestLatLng <- newLatLng c.latitude c.longitude
  pushMVCArray mvcA latestLatLng
  setPolylinePath polyline mvcA
  setMarkerPosition marker latestLatLng

updateLookangle ::
  forall eff a.
  Coordinate
  -> Number
  -> Eff (dom :: DOM, trace :: Debug.Trace.Trace | eff) Unit
updateLookangle (Coordinate c) altitude = do
  doc <- document globalWindow
  Just lookangle <- getElementById "lookangle" doc
  Just fLat' <- getElementById "f_lat" doc
  Just fLon' <- getElementById "f_lon" doc
  Just fAlt' <- getElementById "f_alt" doc
  fLat <- readFloat <$> value fLat'
  fLon <- readFloat <$> value fLon'
  fAlt <- readFloat <$> value fAlt'
  let angle = L.lookAngle
              (L.Coordinate fLat fLon fAlt)
              (L.Coordinate c.latitude c.longitude altitude)
  setInnerHTML (show angle) lookangle

module Main where

import Control.Monad.Eff
import Data.DOM.Simple.Ajax
import Data.DOM.Simple.Document
import Data.DOM.Simple.Element
import Data.DOM.Simple.Encode
import Data.DOM.Simple.Events hiding (read)
import Data.DOM.Simple.Types
import Data.DOM.Simple.Window
import Data.Either
import Data.Foldable (traverse_)
import Data.Foreign
import Data.Foreign.Class
import Data.Maybe
import Debug.Trace
import DomHelpers
import GMaps.InfoWindow
import GMaps.LatLng
import GMaps.Map
import GMaps.MapOptions
import GMaps.Marker
import GMaps.MVCArray
import GMaps.Polyline
import Global
import qualified Lookangle as L
import MapViewWS
import MomentJS
import WebSocket

setDismissAnnouncement :: forall eff. HTMLDocument -> Eff (dom :: DOM | eff) Unit
setDismissAnnouncement doc = do
  -- TODO: Partial
  Just dismissButton <- getElementById "dismiss_announcement" doc
  Just announcement <- getElementById "announcement" doc
  y <- setDisplayFn announcement "none"
  setOnclick dismissButton y

setAnnouncement :: forall eff. HTMLDocument -> String -> String -> Eff (dom :: DOM | eff) Unit
setAnnouncement doc t c = do
  -- TODO: Partial
  Just announcement <- getElementById "announcement" doc
  Just text <- getElementById "announcement_text" doc
  setInnerHTML t text
  setClass announcement c
  setDisplay announcement "block"

foreign import getData
  "function getData(x) {\
  \  return function() {\
  \    return x.data;\
  \  };\
  \}" :: forall eff. Event -> Eff eff String

main = do
  doc <- document globalWindow
  --setDismissAnnouncement doc
  Just mapE <- getElementById "map-canvas" doc
  startingPoint <- newLatLng 41.714754626155 (-73.726791873574)
  roadmap <- gMap mapE (MapOptions { zoom: 6, center: startingPoint, mapTypeId: "roadmap" })
  mvcA <- newMVCArray :: forall eff. Eff eff (MVCArray LatLng)

  -- Various bits of test data to play with.
  --randomcoord <- newLatLng 41.714754626155 (-73.726791873574)
  --panTo roadmap randomcoord
  --testcoord <- newLatLng 41.714754626155 (-73.726791873574)
  --pushMVCArray mvcA testcoord
  --pushMVCArray mvcA randomcoord

  polyline <- newPolyline (PolylineOptions { geodescic: true
                                           , strokeColor: "#ff0000"
                                           , strokeOpacity: 1.0
                                           , strokeWeight: 2
                                           , map: roadmap
                                           })
  setPolylinePath polyline mvcA

  marker <- newMarker (MarkerOptions { position: startingPoint, map: roadmap, title: "HABP Location" })

  -- TODO: info window.
  --iw <- newInfoWindow (InfoWindowOptions { content: "HABP Location" })
  --openInfoWindow iw roadmap marker

  --let example = "{\"coordinates\":{\"latitude\":43.714754626155,\"longitude\":-64.726791873574},\"altitude\":300,\"time\":\"1234321\"}"
  socket <- newWebSocket "ws://127.0.0.1:9160/"
  addEventListenerWS socket "onmessage" $ (\x -> handleEvent x mvcA polyline marker)
  --sendWS socket example

  nowMoment <- now
  let leet = momentConstructor "January 1, 0678"
  let leet' = createMoment leet
  Just lastupdate <- getElementById "lastupdate" doc
  let str = liftMoment2 momentFrom nowMoment <$> leet'
  let seven = fromMaybe "Unknown" str
  setInnerHTML seven lastupdate

  where
    handleEvent e mvcA polyline marker = do
      --trace "RX from websocket"
      msgData <- getData e
      --trace msgData
      case readJSON msgData :: F WSMessage of
        Left err -> trace $ "Error parsing JSON:\n" ++ show err
        Right (LocationBeacon result) -> do
          --trace $ unsafeShowJSON result
          addToPath mvcA polyline marker result.coordinates
          updateLookangle result.coordinates result.altitude
        Right (BeaconHistory coordinates) -> do
          --trace $ unsafeShowJSON coordinates
          traverse_ (addToPath mvcA polyline marker) coordinates

addToPath ::
  forall eff.
  MVCArray LatLng
  -> Polyline
  -> Marker
  -> Coordinate
  -> Eff eff Unit
addToPath mvcA polyline marker (Coordinate c) = do
  latestLatLng <- newLatLng c.latitude c.longitude
  pushMVCArray mvcA latestLatLng
  setPolylinePath polyline mvcA
  setMarkerPosition marker latestLatLng

updateLookangle ::
  forall eff a.
  Coordinate
  -> Number
  -> Eff (dom :: DOM, trace :: Debug.Trace.Trace | eff) Unit
updateLookangle (Coordinate c) altitude = do
  doc <- document globalWindow
  Just lookangle <- getElementById "lookangle" doc
  Just fLat' <- getElementById "f_lat" doc
  Just fLon' <- getElementById "f_lon" doc
  Just fAlt' <- getElementById "f_lon" doc
  fLat <- readFloat <$> value fLat'
  fLon <- readFloat <$> value fLon'
  fAlt <- readFloat <$> value fAlt'
  let angle =
        L.lookAngle
        (L.Coordinate fLat fLon fAlt)
        (L.Coordinate c.latitude c.longitude altitude)
  setInnerHTML (show angle) lookangle


Update

Update


Edit error

Edit error

module Main where

import Control.Monad.Aff (delay)
import Control.Monad.Aff.Console (CONSOLE)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Random (RANDOM)
import DOM (DOM)
import Data.Array (fromFoldable)
import Data.Helpers (generateSequence, convertToColors)
import Data.List (List(..), snoc, index, range)
import Data.Maybe (Maybe(..), fromMaybe)
import Data.Sounds (play, SOUND)
import Data.Styles (buttonStyled)
import Data.Time.Duration (Milliseconds(..))
import Prelude hiding (div,id)
import Pux (CoreEffects, EffModel, noEffects, onlyEffects, start)
import Pux.DOM.Events (DOMEvent, onChange, onClick)
import Pux.DOM.HTML (HTML)
import Pux.Renderer.React (renderToDOM)
import Text.Smolder.HTML (button, div, input, label)
import Text.Smolder.HTML.Attributes (type', checked)
import Text.Smolder.Markup (text, (#!), (!), (!?))

data Event
  = Start
  | AnimateColor Number String
  | NewSequence (List String)
  | PlaySequence
  | UserClick String
  | ResetColor
  | Strict DOMEvent

type AppEffects =
  ( random :: RANDOM
  , console :: CONSOLE
  , dom :: DOM
  , sound :: SOUND
  )

type State =
  { sequence :: List String
  , userInput :: List String
  , currentColor :: String
  , count :: Int
  , strict :: Boolean
  }

init :: State
init =
  { sequence: Nil
  , userInput: Nil
  , currentColor: ""
  , count : 0
  , strict: false
  }

generatePlaySequence :: forall e. Applicative e => Int -> List String -> Array (e (Maybe Event))
generatePlaySequence count sequence =
  range 0 (count - 1) #
  map (\v -> pure $ Just $ AnimateColor 300.0 (fromMaybe "" $ index sequence v) ) #
  fromFoldable

foldp :: Event -> State -> EffModel State Event AppEffects
foldp Start state =
  if state.count > 0 then
    noEffects $ state
  else
  { state: state { count = state.count + 1 }
  , effects:
      [ do
          result <- liftEff generateSequence
          let colors = convertToColors result
          pure $ Just $ NewSequence colors
      ]
  }

foldp (NewSequence list) state =
  { state: state { sequence = list }
  , effects: [pure $ Just $ PlaySequence]
  }

foldp (UserClick color) state =
  { state: state { userInput = snoc state.userInput color, currentColor = color }
  , effects: [ pure $ Just $ AnimateColor 300.0 color ]
  }
foldp ResetColor state = noEffects $ state { currentColor = "" }

foldp (AnimateColor time color) state =
  { state: state { currentColor = color },
    effects:
      [ liftEff $ play color *> pure Nothing
      , do
        delay $ Milliseconds time
        pure $ Just $ ResetColor
      ]
  }

foldp PlaySequence state =
  onlyEffects state $ generatePlaySequence state.count state.sequence

foldp (Strict e) state = noEffects $ state { strict = not state.strict }

view :: State -> HTML Event
view state =
  div do
    div do
      div
        ! buttonStyled "red" state.currentColor
        #! onClick (const $ UserClick "red")
        $ text ""
      div
        ! buttonStyled "green" state.currentColor
        #! onClick (const $ UserClick "green")
        $ text ""
      div
        ! buttonStyled "yellow" state.currentColor
        #! onClick (const $ UserClick "yellow")
        $ text ""
      div
        ! buttonStyled "blue" state.currentColor
        #! onClick (const $ UserClick "blue")
        $ text ""
    div do
      text $ "Count" <> show state.count
    div do
      label $ text "Strict"
      (input !? state.strict) (checked "checked") ! type' "checkbox" #! onChange Strict
    button #! onClick (const Start) $ text "Start"

main :: Eff (CoreEffects AppEffects) Unit
main = do
  app <- start
    { initialState: init
    , view
    , foldp
    , inputs: []
    }

  renderToDOM "#app" app.markup app.input

module Main where

import Control.Monad.Aff (delay)
import Control.Monad.Aff.Console (CONSOLE)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Random (RANDOM)
import DOM (DOM)
import Data.Array (fromFoldable)
import Data.Helpers (generateSequence, convertToColors)
import Data.List (List(..), snoc, index, range)
import Data.Maybe (Maybe(..), fromMaybe)
import Data.Sounds (play, SOUND)
import Data.Styles (buttonStyled)
import Data.Time.Duration (Milliseconds(..))
import Prelude hiding (div,id)
import Pux (CoreEffects, EffModel, noEffects, onlyEffects, start)
import Pux.DOM.Events (DOMEvent, onChange, onClick)
import Pux.DOM.HTML (HTML)
import Pux.Renderer.React (renderToDOM)
import Text.Smolder.HTML (button, div, input, label)
import Text.Smolder.HTML.Attributes (type', checked)
import Text.Smolder.Markup (text, (#!), (!), (!?))

data Event
  = Start
  | AnimateColor Number String
  | NewSequence (List String)
  | PlaySequence
  | UserClick String
  | ResetColor
  | Strict DOMEvent

type AppEffects =
  ( random :: RANDOM
  , console :: CONSOLE
  , dom :: DOM
  , sound :: SOUND
  , timer :: TIMER
  )

type State =
  { sequence :: List String
  , userInput :: List String
  , currentColor :: String
  , count :: Int
  , strict :: Boolean
  }

init :: State
init =
  { sequence: Nil
  , userInput: Nil
  , currentColor: ""
  , count : 0
  , strict: false
  }

generatePlaySequence :: forall e. Applicative e => Int -> List String -> Array (e (Maybe Event))
generatePlaySequence count sequence =
  range 0 (count - 1) #
  map (\v -> pure $ Just $ AnimateColor 300.0 (fromMaybe "" $ index sequence v) ) #
  fromFoldable

foldp :: Event -> State -> EffModel State Event AppEffects
foldp Start state =
  if state.count > 0 then
    noEffects $ state
  else
  { state: state { count = state.count + 1 }
  , effects:
      [ do
          result <- liftEff generateSequence
          let colors = convertToColors result
          pure $ Just $ NewSequence colors
      ]
  }

foldp (NewSequence list) state =
  { state: state { sequence = list }
  , effects: [pure $ Just $ PlaySequence]
  }

foldp (UserClick color) state =
  { state: state { userInput = snoc state.userInput color, currentColor = color }
  , effects: [ pure $ Just $ AnimateColor 300.0 color ]
  }
foldp ResetColor state = noEffects $ state { currentColor = "" }

foldp (AnimateColor time color) state =
  { state: state { currentColor = color },
    effects:
      [ liftEff $ play color *> pure Nothing
      , do
        delay $ Milliseconds time
        pure $ Just $ ResetColor
      ]
  }

foldp PlaySequence state =
  onlyEffects state $ generatePlaySequence state.count state.sequence

foldp (Strict e) state = noEffects $ state { strict = not state.strict }

view :: State -> HTML Event
view state =
  div do
    div do
      div
        ! buttonStyled "red" state.currentColor
        #! onClick (const $ UserClick "red")
        $ text ""
      div
        ! buttonStyled "green" state.currentColor
        #! onClick (const $ UserClick "green")
        $ text ""
      div
        ! buttonStyled "yellow" state.currentColor
        #! onClick (const $ UserClick "yellow")
        $ text ""
      div
        ! buttonStyled "blue" state.currentColor
        #! onClick (const $ UserClick "blue")
        $ text ""
    div do
      text $ "Count" <> show state.count
    div do
      label $ text "Strict"
      (input !? state.strict) (checked "checked") ! type' "checkbox" #! onChange Strict
    button #! onClick (const Start) $ text "Start"

main :: Eff (CoreEffects AppEffects) Unit
main = do
  app <- start
    { initialState: init
    , view
    , foldp
    , inputs: []
    }

  renderToDOM "#app" app.markup app.input