tag annotation labels w/ gravity to attempt to avoid collisions

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.Backend (DrawingN, DrawingV, Feature, LegendEntry, NPoint, OldRenderer, RenderedTrack, featureNormX, groupToMap, mkIcon, trackLegend)
import Genetics.Browser.Track.Bed (ParsedLine, chunkProducer, fetchBed, fetchForeignChunks, parsedLineTransformer)
import Genetics.Browser.Track.UI.Canvas (Label, LabelPlace(..))
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

type Peak x y r = { covers :: Pair x
                  , y :: y
                  , elements :: Array r }

peak1 :: ∀ rS.
         Bp
      -> Array (SNP rS)
      -> Maybe (Tuple (Peak _ _ (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)))

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  }

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.Backend (DrawingN, DrawingV, Feature, Label, LegendEntry, NPoint, OldRenderer, RenderedTrack, featureNormX, groupToMap, mkIcon, trackLegend)
import Genetics.Browser.Track.Bed (ParsedLine, chunkProducer, fetchBed, fetchForeignChunks, parsedLineTransformer)
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

type Peak x y r = { covers :: Pair x
                  , y :: y
                  , elements :: Array r }

peak1 :: ∀ rS.
         Bp
      -> Array (SNP rS)
      -> Maybe (Tuple (Peak _ _ (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)))

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

      drawing :: Peak Number Number (Annotation r2)
              -> DrawingN
      drawing aPeak = { drawing: tail <> icons
                      , points: [{x, y: aPeak.y }] }
        where (Pair l r) = aPeak.covers
              x = l + 0.5 * (r - l)
              icon' = _.icon <<< annotationLegendEntry
              icons = Drawing.translate 0.0 (-tailPixels)
                      $ foldr (\a d -> Drawing.translate 0.0 iconYOffset
                                     $ icon' a <> 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 }]

      drawings :: Map ChrId (Array (Peak Number Number (Annotation r2)))
               -> Array DrawingN
      drawings = foldMap (map drawing)

      label :: Peak Number Number (Annotation r2) -> Array Label
      label aPeak = Tuple.snd
                    $ foldr f (Tuple y0 mempty) aPeak.elements
        where y0 = aPeak.y - tailPixels + (4.0 * iconYOffset)
              (Pair l r) = aPeak.covers
              x = l + 0.5 * (r - l)
              f a (Tuple y ls) = Tuple (y + labelOffset)
                                    $ Array.snoc ls -- TODO this use of snoc is probably reaaaal slow
                                         { text: fromMaybe a.feature.name a.feature.gene
                                         , point: { x, y } }

      -- 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 = 14.0 -- hardcoded height
              h = gH * length aPeak.elements
              y = aPeak.y - h

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

              icon' = _.icon <<< annotationLegendEntry
              icons = Drawing.translate 0.0 (-tailPixels)
                      $ foldr (\a d -> Drawing.translate 0.0 iconYOffset
                                     $ icon' a <> 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 }] }

              dC = drawingCovers aPeak

                    -- hardcoded test to see if a few lines of labels fit above
              labelX0 =
                if (drawingCovers aPeak).y > 55.0
                    then x
                    else x + 1.5 * dC.w

              labelY0 = aPeak.y - tailPixels + (4.0 * iconYOffset)

              label' = Tuple.snd $ foldr f (Tuple labelY0 mempty) aPeak.elements
              f a (Tuple y ls) = Tuple (y + labelOffset)
                                    $ Array.snoc ls
                                         { text: fromMaybe a.feature.name a.feature.gene
                                         , point: { x: labelX0, y } }

      labels :: Map ChrId (Array (Peak Number Number (Annotation r2)))
             -> Array Label
      labels = foldMap (foldMap label)

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

      overlaps :: Number -> Point -> Array (Annotation r2)
      overlaps r p = mempty

  in \segs -> let curPeaks = curAnnotPeaks segs
              in { features
                 , drawings: drawings curPeaks
                 , labels: labels curPeaks
                 , overlaps: overlaps  }


Switched to simple generic JSON encoding for toURLPiece

{--
  This file contains code copied from the purescript-affjax project from slamdata.
  It is therefore licensed under Apache License version 2.0.
--}
module Servant.PureScript.Settings where

import Prelude

import Data.Argonaut.Core (Json())
import Data.Argonaut.Generic.Aeson as Aeson
import Data.Argonaut.Generic.Util (stripModulePath)
import Data.Generic (class Generic, GenericSpine(SArray, SChar, SString, SNumber, SInt, SBoolean, SRecord, SProd, SUnit), toSpine)
import Data.Either (Either)
import Data.Array (null)
import Data.String (joinWith)

-- | WARNING: encodeJson, decodeJson, toURLPiece: currently ignored due to compiler bug:
--   https://github.com/purescript/purescript/issues/1957
newtype SPSettings_ params = SPSettings_ {
    encodeJson :: forall a. Generic a => a -> Json -- Currently not used (does not work - compiler bug: )
  , decodeJson :: forall a. Generic a => Json -> Either String a
  , toURLPiece :: forall a. Generic a => a -> URLPiece
  , params :: params
  }

type URLPiece = String

gDefaultToURLPiece :: forall a. Generic a => a -> URLPiece
gDefaultToURLPiece = gToURLPiece <<< toSpine
  where
    gToURLPiece :: GenericSpine -> String
    gToURLPiece (SProd s arr) = genericShowPrec 0 $ SProd (stripModulePath s) arr
    gToURLPiece s = genericShowPrec 0 s

defaultSettings :: forall params. params -> SPSettings_ params
defaultSettings params = SPSettings_ {
    encodeJson : Aeson.encodeJson
  , decodeJson : Aeson.decodeJson
  , toURLPiece : show <<< Aeson.encodeJson -- Just use the robust JSON format.
  , params : params
}

genericShowPrec :: Int -> GenericSpine -> String
genericShowPrec d (SProd s arr) =
    if null arr
    then s
    else showParen (d > 10) $ s <> " " <> joinWith " " (map (\x -> genericShowPrec 11 (x unit)) arr)
  where showParen false x = x
        showParen true  x = "(" <> x <> ")"

genericShowPrec d (SRecord xs) = "{" <> joinWith ", " (map (\x -> x.recLabel <> ": " <> genericShowPrec 0 (x.recValue unit)) xs) <> "}"
genericShowPrec d (SBoolean x) = show x
genericShowPrec d (SInt x)     = show x
genericShowPrec d (SNumber x)  = show x
genericShowPrec d (SString x)  = show x
genericShowPrec d (SChar x)    = show x
genericShowPrec d (SArray xs)  = "[" <> joinWith ", "  (map (\x -> genericShowPrec 0 (x unit)) xs) <> "]"
genericShowPrec d SUnit        = show unit

{--
  This file contains code copied from the purescript-affjax project from slamdata.
  It is therefore licensed under Apache License version 2.0.
--}
module Servant.PureScript.Settings where

import Prelude

import Data.Argonaut.Core (Json())
import Data.Argonaut.Generic.Aeson as Aeson
import Data.Argonaut.Generic.Util (stripModulePath)
import Data.Generic (class Generic, GenericSpine(SArray, SChar, SString, SNumber, SInt, SBoolean, SRecord, SProd, SUnit), toSpine)
import Data.Either (Either)
import Data.Array (null)
import Data.String (joinWith)

-- | WARNING: encodeJson, decodeJson, toURLPiece: currently ignored due to compiler bug:
--   https://github.com/purescript/purescript/issues/1957
newtype SPSettings_ params = SPSettings_ {
    encodeJson :: forall a. Generic a => a -> Json -- Currently not used (does not work - compiler bug: )
  , decodeJson :: forall a. Generic a => Json -> Either String a
  , toURLPiece :: forall a. Generic a => a -> URLPiece
  , params :: params
  }

type URLPiece = String

gDefaultToURLPiece :: forall a. Generic a => a -> URLPiece
gDefaultToURLPiece = gToURLPiece <<< toSpine
  where
    gToURLPiece :: GenericSpine -> String
    gToURLPiece (SProd s arr) = genericShowPrec 0 $ SProd (stripModulePath s) arr
    gToURLPiece s = genericShowPrec 0 s

defaultSettings :: forall params. params -> SPSettings_ params
defaultSettings params = SPSettings_ {
    encodeJson : Aeson.encodeJson
  , decodeJson : Aeson.decodeJson
  , toURLPiece : gDefaultToURLPiece
  , params : params
}

genericShowPrec :: Int -> GenericSpine -> String
genericShowPrec d (SProd s arr) =
    if null arr
    then s
    else showParen (d > 10) $ s <> " " <> joinWith " " (map (\x -> genericShowPrec 11 (x unit)) arr)
  where showParen false x = x
        showParen true  x = "(" <> x <> ")"

genericShowPrec d (SRecord xs) = "{" <> joinWith ", " (map (\x -> x.recLabel <> ": " <> genericShowPrec 0 (x.recValue unit)) xs) <> "}"
genericShowPrec d (SBoolean x) = show x
genericShowPrec d (SInt x)     = show x
genericShowPrec d (SNumber x)  = show x
genericShowPrec d (SString x)  = show x
genericShowPrec d (SChar x)    = show x
genericShowPrec d (SArray xs)  = "[" <> joinWith ", "  (map (\x -> genericShowPrec 0 (x unit)) xs) <> "]"
genericShowPrec d SUnit        = show unit


Reduced code needed to express moving a piece

module Checkers.Main where

import Control.Monad.Eff
import Control.Monad.ST
import Control.MonadPlus
import Data.Array
import Data.DOM.Simple.Document
import Data.DOM.Simple.Element
import Data.DOM.Simple.Events
import Data.DOM.Simple.Types
import Data.DOM.Simple.Unsafe.Events
import Data.DOM.Simple.Window
import Data.Int
import Data.Maybe
import Data.Maybe.Unsafe
import Data.Tuple
import DOM
import Graphics.Canvas
import Math (abs, max, pi)
import Prelude

import Checkers.Constants
import Checkers.Types

createPiece :: Player -> Piece
createPiece player =
  { player: player,
    color:  if player == playerOne then colorPlayerOne else colorPlayerTwo,
    king:   false }

createGrid :: Pixel -> Int -> Int -> Int -> Grid
createGrid offset width height layers = { width: width, height: height, squares: squares }
  where
    squares = do
      x <- 0 .. (width - 1)
      y <- 0 .. (height - 1)
      let rx = (toNumber x) * renderSize
          ry = (toNumber y) * renderSize
          isPieceSquare = ((even x) && (odd y)) || ((even y) && (odd x))
          color = if isPieceSquare then colorSquareOne else colorSquareTwo
          piece = if isPieceSquare && (y < layers)
                  then Just (createPiece playerOne)
                  else if isPieceSquare && (y >= height - layers)
                       then Just (createPiece playerTwo)
                       else Nothing
      return { offset:     offset,
               coordinate: (Tuple x y),
               render:     (Tuple rx ry),
               color:      color,
               piece:      piece }

createState :: Pixel -> Int -> Int -> Int -> State
createState offset width height layers =
  { grid:                  createGrid offset width height layers,
    currentPlayer:         playerOne,
    selectedCoordinate:    Nothing,
    highlightedCoordinate: Nothing }

setPiece :: Maybe Piece -> Square -> Square
setPiece piece square = square { piece = piece }

isValid :: Grid -> Coordinate -> Boolean
isValid grid (Tuple x y) = x >= 0 && x < grid.width && y >= 0 && y < grid.height

hasPlayer :: Player -> Piece -> Boolean
hasPlayer player piece = piece.player == player

hasCoordinate :: Coordinate -> Square -> Boolean
hasCoordinate coordinate square = coordinate == square.coordinate

findSquare :: Array Square -> Coordinate -> Maybe Int
findSquare squares coordinate = findIndex (hasCoordinate coordinate) squares

getSquare :: Array Square -> Coordinate -> Maybe Square
getSquare squares coordinate =
  fromMaybe Nothing $ (squares !!) <$> findSquare squares coordinate

squareHasPiece :: Player -> Square -> Boolean
squareHasPiece player square = fromMaybe false $ (hasPlayer player) <$> square.piece

hasPlayerPiece :: Array Square -> Player -> Coordinate -> Boolean
hasPlayerPiece squares player coordinate =
  case getSquare squares coordinate of
    Nothing -> false
    Just square -> squareHasPiece player square

hasPiece :: Array Square -> Coordinate -> Boolean
hasPiece squares coordinate =
  hasPlayerPiece squares playerOne coordinate ||
  hasPlayerPiece squares playerTwo coordinate

getDiagonalSquares :: Coordinate -> Array Coordinate
getDiagonalSquares (Tuple x y) = do
  i <- -1 : (singleton 1)
  j <- -1 : (singleton 1)
  offset <- 1 : (singleton 2)
  return (Tuple (x + i * offset) (y + j * offset))

isOnSquare :: Pixel -> Square -> Boolean
isOnSquare (Tuple x y) square =
  let px = square.render + square.offset
      px' = px + (Tuple renderSize renderSize)
  in fst px < x && x < fst px' && snd px < y && y < snd px'

isOnActiveSquare :: Grid -> Player -> Pixel -> Square -> Boolean
isOnActiveSquare grid player pixel square =
  let moves = getMoves grid player square.coordinate
  in isOnSquare pixel square && not (null moves)

searchGrid :: Grid -> (Square -> Boolean) -> Maybe Coordinate
searchGrid grid predicate =
  case findIndex predicate grid.squares of
    Just index -> _.coordinate <$> grid.squares !! index
    Nothing    -> Nothing

getActiveCoordinate :: Grid -> Player -> Pixel -> Maybe Coordinate
getActiveCoordinate grid player pixel = searchGrid grid (isOnActiveSquare grid player pixel)

getHighlightCoordinate :: State -> Pixel -> Maybe Coordinate
getHighlightCoordinate state pixel =
  case searchGrid state.grid (isOnSquare pixel) of
    Nothing -> Nothing
    Just to -> do
      case state.selectedCoordinate of
        Nothing -> getActiveCoordinate state.grid state.currentPlayer pixel
        Just from ->
          if isValidMove state.grid state.currentPlayer from to
          then Just to
          else getActiveCoordinate state.grid state.currentPlayer pixel

isRegularMove :: Player -> Coordinate -> Coordinate -> Boolean
isRegularMove (Player 1) from to =
  let d1 = from + Tuple   1    1
      d2 = from + Tuple (-1)   1
  in d1 == to || d2 == to
isRegularMove _ from to =
  let d3 = from + Tuple   1  (-1)
      d4 = from + Tuple (-1) (-1)
  in d3 == to || d4 == to

isJumpMove :: Grid -> Player -> Coordinate -> Coordinate -> Boolean
isJumpMove grid (Player 1) from to =
  let d1 = from + Tuple   1    1
      d2 = from + Tuple (-1)   1
      d5 = from + Tuple   2    2
      d6 = from + Tuple (-2)   2
      f = hasPlayerPiece grid.squares playerTwo
  in d5 == to && f d1 || d6 == to && f d2
isJumpMove grid _ from to =
  let d3 = from + Tuple   1  (-1)
      d4 = from + Tuple (-1) (-1)
      d7 = from + Tuple   2  (-2)
      d8 = from + Tuple (-2) (-2)
      f = hasPlayerPiece grid.squares playerOne
  in d7 == to && f d3 || d8 == to && f d4

isValidMove :: Grid -> Player -> Coordinate -> Coordinate -> Boolean
isValidMove grid player from to = isJust (elemIndex to (getMoves grid player from))

getMoves :: Grid -> Player -> Coordinate -> Array Coordinate
getMoves grid player coordinate = do
    guard $ hasPlayerPiece grid.squares player coordinate
    potential <- getDiagonalSquares coordinate
    guard $ isValidMove' grid player coordinate potential
    return potential
  where
    isValidMove' :: Grid -> Player -> Coordinate -> Coordinate -> Boolean
    isValidMove' grid player from to =
      isValid grid to && not hasPiece grid.squares to &&
      (isRegularMove player from to || isJumpMove grid player from to)

alterPiece :: Maybe Piece -> Coordinate -> Grid -> Grid
alterPiece piece coordinate grid = grid { squares = newSquares }
  where
    index = fromJust (findSquare grid.squares coordinate)
    newSquares = fromJust (modifyAt index (setPiece piece) grid.squares)

removePiece :: Coordinate -> Grid -> Grid
removePiece = alterPiece Nothing

movePiece :: Coordinate -> Coordinate -> Grid -> Grid
movePiece from to grid =
  let fromIndex = fromJust (findSquare grid.squares from)
      originalSquare = fromJust (grid.squares !! fromIndex)

      getMiddle :: Coordinate -> Coordinate -> Maybe Coordinate
      getMiddle (Tuple x1 y1) (Tuple x2 y2) =
        if abs (toNumber (y1 - y2)) == 2.0
        then
          let f v w = floor (max (toNumber v) (toNumber w) - 1.0)
          in Just (Tuple (f x1 x2) (f y1 y2))
        else Nothing
      gridAfterMove = removePiece from $ alterPiece originalSquare.piece to grid
  in
    case getMiddle from to of
      Nothing -> gridAfterMove
      Just middle -> removePiece middle gridAfterMove

otherPlayer :: Player -> Player
otherPlayer (Player 1) = Player 2
otherPlayer (Player 2) = Player 1
otherPlayer _          = Player 1

renderSquare :: forall e.
                  Context2D ->
                  Unit ->
                  Square ->
                  Eff (canvas :: Canvas, dom :: DOM | e) Unit
renderSquare ctx _ square = do
  setFillStyle square.color ctx
  fillRect ctx { x: fst square.render,
                 y: snd square.render,
                 w: renderSize,
                 h: renderSize }
  return unit

renderPiece :: forall e.
                 State ->
                 Context2D ->
                 Unit ->
                 Square ->
                 Eff (canvas :: Canvas, dom :: DOM | e) Unit
renderPiece state ctx _ square = do
  case square.piece of
    Just piece -> do
      setFillStyle piece.color ctx
      let arcPiece = { x: fst square.render + 0.5 * renderSize,
                       y: snd square.render + 0.5 * renderSize,
                       r: (renderSize / 2.0) * 0.8,
                       start: 0.0,
                       end: 2.0 * pi }
      fillPath ctx $ arc ctx arcPiece
      return unit
    _ -> return unit

renderBorder :: forall e. Context2D -> Grid -> Eff (canvas :: Canvas | e) Unit
renderBorder ctx grid = do
  let border = { x: 0.5,
                 y: 0.5,
                 w: (toNumber grid.width) * renderSize - 0.5,
                 h: (toNumber grid.height) * renderSize - 0.5 }
  setStrokeStyle colorBorder ctx
  strokeRect ctx border
  return unit

renderHighlight :: forall e.
                     Context2D ->
                     Array Square ->
                     Maybe Coordinate ->
                     Eff (canvas :: Canvas, dom :: DOM | e) Unit
renderHighlight ctx squares selection = do
  case selection of
    Nothing -> return unit
    Just coordinate -> do
      let square = fromJust (getSquare squares coordinate)
          arcPiece = { x:     fst square.render + 0.5 * renderSize,
                       y:     snd square.render + 0.5 * renderSize,
                       r:     (renderSize / 2.0) * 0.8,
                       start: 0.0,
                       end:   2.0 * pi }
      setLineWidth highlightWidth ctx
      strokePath ctx $ arc ctx arcPiece
      return unit

renderCurrentPlayer :: forall e.
                        State ->
                        Eff (dom :: DOM | e) Unit
renderCurrentPlayer state = do
  doc <- document globalWindow
  playerIndicator <- getElementById "player" doc
  case playerIndicator of
    Just indicator -> do
      setInnerHTML (if state.currentPlayer == playerOne
                    then colorPlayerOne
                    else colorPlayerTwo) indicator
      return unit
    _ -> return unit

render :: forall s e.
            Context2D ->
            STRef s State ->
            Eff (st :: ST s, canvas :: Canvas, dom :: DOM | e) Unit
render ctx st = do
  state <- readSTRef st
  withContext ctx $ do
    foldM (renderSquare ctx) unit state.grid.squares
  withContext ctx $ do
    foldM (renderPiece state ctx) unit state.grid.squares
  withContext ctx $ do
    renderBorder ctx state.grid
  withContext ctx $ do
    renderHighlight ctx state.grid.squares state.selectedCoordinate
  withContext ctx $ do
    renderHighlight ctx state.grid.squares state.highlightedCoordinate
  renderCurrentPlayer state
  return unit

renderPage :: forall s e.
                STRef s State ->
                Eff (st :: ST s, canvas :: Canvas, dom :: DOM | e) Unit
renderPage st = do
  element <- getCanvasElementById "canvas"
  case element of
    Just canvas -> do
      setCanvasDimensions renderDimension canvas
      ctx <- getContext2D canvas
      render ctx st
      return unit
    _ -> return unit
  return unit

moveListener :: forall s e.
                  STRef s State ->
                  DOMEvent ->
                  Eff (st :: ST s, canvas :: Canvas, dom :: DOM | e) Unit
moveListener st e = do
  ux <- unsafeEventNumberProp "clientX" e
  uy <- unsafeEventNumberProp "clientY" e
  state <- readSTRef st
  let pixel = (Tuple (toNumber ux) (toNumber uy))
      highlightedCoordinate = getHighlightCoordinate state pixel
  writeSTRef st $ state { highlightedCoordinate = highlightedCoordinate }
  renderPage st
  return unit

clickListener :: forall s e.
                   STRef s State ->
                   DOMEvent ->
                   Eff (st :: ST s, canvas :: Canvas, dom :: DOM | e) Unit
clickListener st e = do
  element <- getCanvasElementById "canvas"
  case element of
    Just canvas -> do
      state <- readSTRef st
      ux <- unsafeEventNumberProp "clientX" e
      uy <- unsafeEventNumberProp "clientY" e
      let pixel = Tuple (toNumber ux) (toNumber uy)
          toCoordinate = getHighlightCoordinate state pixel
      case toCoordinate of
        Nothing -> return unit
        Just to -> do
          case state.selectedCoordinate of
            Nothing -> do
              writeSTRef st $ state { selectedCoordinate = Just to }
              renderPage st
              return unit
            Just from -> do
              case isValidMove state.grid state.currentPlayer from to of
                false -> do
                  writeSTRef st $ state { selectedCoordinate = if to == from
                                                               then Nothing
                                                               else Just to }
                  renderPage st
                  return unit
                true -> do
                  writeSTRef st $ state { highlightedCoordinate = Nothing,
                                          selectedCoordinate = Nothing,
                                          grid = movePiece from to state.grid,
                                          currentPlayer = otherPlayer state.currentPlayer }
                  renderPage st
                  return unit
    _ -> return unit
  return unit

main :: forall s e. Eff (st :: ST s, canvas :: Canvas, dom :: DOM | e) Unit
main = do
  doc <- document globalWindow
  mcanvas <- getElementById "canvas" doc
  case mcanvas of
    Just canvas -> do
      x <- offsetLeft canvas
      y <- offsetTop canvas
      let offset = (Tuple (toNumber x) (toNumber y))
      st <- newSTRef (createState offset defaultWidth defaultHeight layerCount)
      addMouseEventListener MouseMoveEvent (moveListener st) canvas
      addMouseEventListener MouseClickEvent (clickListener st) canvas
      renderPage st
      return unit
    _ -> return unit

module Checkers.Main where

import Control.Monad.Eff
import Control.Monad.ST
import Control.MonadPlus
import Data.Array
import Data.DOM.Simple.Document
import Data.DOM.Simple.Element
import Data.DOM.Simple.Events
import Data.DOM.Simple.Types
import Data.DOM.Simple.Unsafe.Events
import Data.DOM.Simple.Window
import Data.Int
import Data.Maybe
import Data.Maybe.Unsafe
import Data.Tuple
import DOM
import Graphics.Canvas
import Math (abs, max, pi)
import Prelude

import Checkers.Constants
import Checkers.Types

createPiece :: Player -> Piece
createPiece player =
  { player: player,
    color:  if player == playerOne then colorPlayerOne else colorPlayerTwo,
    king:   false }

createGrid :: Pixel -> Int -> Int -> Int -> Grid
createGrid offset width height layers = { width: width, height: height, squares: squares }
  where
    squares = do
      x <- 0 .. (width - 1)
      y <- 0 .. (height - 1)
      let rx = (toNumber x) * renderSize
          ry = (toNumber y) * renderSize
          isPieceSquare = ((even x) && (odd y)) || ((even y) && (odd x))
          color = if isPieceSquare then colorSquareOne else colorSquareTwo
          piece = if isPieceSquare && (y < layers)
                  then Just (createPiece playerOne)
                  else if isPieceSquare && (y >= height - layers)
                       then Just (createPiece playerTwo)
                       else Nothing
      return { offset:     offset,
               coordinate: (Tuple x y),
               render:     (Tuple rx ry),
               color:      color,
               piece:      piece }

createState :: Pixel -> Int -> Int -> Int -> State
createState offset width height layers =
  { grid:                  createGrid offset width height layers,
    currentPlayer:         playerOne,
    selectedCoordinate:    Nothing,
    highlightedCoordinate: Nothing }

setPiece :: Maybe Piece -> Square -> Square
setPiece piece square = square { piece = piece }

isValid :: Grid -> Coordinate -> Boolean
isValid grid (Tuple x y) = x >= 0 && x < grid.width && y >= 0 && y < grid.height

hasPlayer :: Player -> Piece -> Boolean
hasPlayer player piece = piece.player == player

hasCoordinate :: Coordinate -> Square -> Boolean
hasCoordinate coordinate square = coordinate == square.coordinate

findSquare :: Array Square -> Coordinate -> Maybe Int
findSquare squares coordinate = findIndex (hasCoordinate coordinate) squares

getSquare :: Array Square -> Coordinate -> Maybe Square
getSquare squares coordinate =
  fromMaybe Nothing $ (squares !!) <$> findSquare squares coordinate

squareHasPiece :: Player -> Square -> Boolean
squareHasPiece player square = fromMaybe false $ (hasPlayer player) <$> square.piece

hasPlayerPiece :: Array Square -> Player -> Coordinate -> Boolean
hasPlayerPiece squares player coordinate =
  case getSquare squares coordinate of
    Nothing -> false
    Just square -> squareHasPiece player square

hasPiece :: Array Square -> Coordinate -> Boolean
hasPiece squares coordinate =
  hasPlayerPiece squares playerOne coordinate ||
  hasPlayerPiece squares playerTwo coordinate

getDiagonalSquares :: Coordinate -> Array Coordinate
getDiagonalSquares (Tuple x y) = do
  i <- -1 : (singleton 1)
  j <- -1 : (singleton 1)
  offset <- 1 : (singleton 2)
  return (Tuple (x + i * offset) (y + j * offset))

isOnSquare :: Pixel -> Square -> Boolean
isOnSquare (Tuple x y) square =
  let px = square.render + square.offset
      px' = px + (Tuple renderSize renderSize)
  in fst px < x && x < fst px' && snd px < y && y < snd px'

isOnActiveSquare :: Grid -> Player -> Pixel -> Square -> Boolean
isOnActiveSquare grid player pixel square =
  let moves = getMoves grid player square.coordinate
  in isOnSquare pixel square && not (null moves)

searchGrid :: Grid -> (Square -> Boolean) -> Maybe Coordinate
searchGrid grid predicate =
  case findIndex predicate grid.squares of
    Just index -> _.coordinate <$> grid.squares !! index
    Nothing    -> Nothing

getActiveCoordinate :: Grid -> Player -> Pixel -> Maybe Coordinate
getActiveCoordinate grid player pixel = searchGrid grid (isOnActiveSquare grid player pixel)

getHighlightCoordinate :: State -> Pixel -> Maybe Coordinate
getHighlightCoordinate state pixel =
  case searchGrid state.grid (isOnSquare pixel) of
    Nothing -> Nothing
    Just to -> do
      case state.selectedCoordinate of
        Nothing -> getActiveCoordinate state.grid state.currentPlayer pixel
        Just from ->
          if isValidMove state.grid state.currentPlayer from to
          then Just to
          else getActiveCoordinate state.grid state.currentPlayer pixel

isRegularMove :: Player -> Coordinate -> Coordinate -> Boolean
isRegularMove (Player 1) from to =
  let d1 = from + Tuple   1    1
      d2 = from + Tuple (-1)   1
  in d1 == to || d2 == to
isRegularMove _ from to =
  let d3 = from + Tuple   1  (-1)
      d4 = from + Tuple (-1) (-1)
  in d3 == to || d4 == to

isJumpMove :: Grid -> Player -> Coordinate -> Coordinate -> Boolean
isJumpMove grid (Player 1) from to =
  let d1 = from + Tuple   1    1
      d2 = from + Tuple (-1)   1
      d5 = from + Tuple   2    2
      d6 = from + Tuple (-2)   2
      f = hasPlayerPiece grid.squares playerTwo
  in d5 == to && f d1 || d6 == to && f d2
isJumpMove grid _ from to =
  let d3 = from + Tuple   1  (-1)
      d4 = from + Tuple (-1) (-1)
      d7 = from + Tuple   2  (-2)
      d8 = from + Tuple (-2) (-2)
      f = hasPlayerPiece grid.squares playerOne
  in d7 == to && f d3 || d8 == to && f d4

isValidMove :: Grid -> Player -> Coordinate -> Coordinate -> Boolean
isValidMove grid player from to = isJust (elemIndex to (getMoves grid player from))

getMoves :: Grid -> Player -> Coordinate -> Array Coordinate
getMoves grid player coordinate = do
    guard $ hasPlayerPiece grid.squares player coordinate
    potential <- getDiagonalSquares coordinate
    guard $ isValidMove' grid player coordinate potential
    return potential
  where
    isValidMove' :: Grid -> Player -> Coordinate -> Coordinate -> Boolean
    isValidMove' grid player from to =
      isValid grid to && not hasPiece grid.squares to &&
      (isRegularMove player from to || isJumpMove grid player from to)

alterPiece :: Maybe Piece -> Coordinate -> Grid -> Grid
alterPiece piece coordinate grid = grid { squares = newSquares }
  where
    index = fromJust (findSquare grid.squares coordinate)
    newSquares = fromJust (modifyAt index (setPiece piece) grid.squares)

removePiece :: Coordinate -> Grid -> Grid
removePiece = alterPiece Nothing

movePiece :: Coordinate -> Coordinate -> Grid -> Grid
movePiece from to grid =
  let fromIndex = fromJust (findSquare grid.squares from)
      originalSquare = fromJust (grid.squares !! fromIndex)

      getMiddle :: Coordinate -> Coordinate -> Maybe Coordinate
      getMiddle (Tuple x1 y1) (Tuple x2 y2) =
        if abs (toNumber (y1 - y2)) == 2.0
        then
          let n1 = floor (max (toNumber x1) (toNumber x2) - 1.0)
              n2 = floor (max (toNumber y1) (toNumber y2) - 1.0)
          in Just (Tuple n1 n2)
        else Nothing
  in
    case getMiddle from to of
      Nothing -> removePiece from (alterPiece originalSquare.piece to grid)
      Just middle -> removePiece middle (removePiece from (alterPiece originalSquare.piece to grid))

otherPlayer :: Player -> Player
otherPlayer (Player 1) = Player 2
otherPlayer (Player 2) = Player 1
otherPlayer _          = Player 1

renderSquare :: forall e.
                  Context2D ->
                  Unit ->
                  Square ->
                  Eff (canvas :: Canvas, dom :: DOM | e) Unit
renderSquare ctx _ square = do
  setFillStyle square.color ctx
  fillRect ctx { x: fst square.render,
                 y: snd square.render,
                 w: renderSize,
                 h: renderSize }
  return unit

renderPiece :: forall e.
                 State ->
                 Context2D ->
                 Unit ->
                 Square ->
                 Eff (canvas :: Canvas, dom :: DOM | e) Unit
renderPiece state ctx _ square = do
  case square.piece of
    Just piece -> do
      setFillStyle piece.color ctx
      let arcPiece = { x: fst square.render + 0.5 * renderSize,
                       y: snd square.render + 0.5 * renderSize,
                       r: (renderSize / 2.0) * 0.8,
                       start: 0.0,
                       end: 2.0 * pi }
      fillPath ctx $ arc ctx arcPiece
      return unit
    _ -> return unit

renderBorder :: forall e. Context2D -> Grid -> Eff (canvas :: Canvas | e) Unit
renderBorder ctx grid = do
  let border = { x: 0.5,
                 y: 0.5,
                 w: (toNumber grid.width) * renderSize - 0.5,
                 h: (toNumber grid.height) * renderSize - 0.5 }
  setStrokeStyle colorBorder ctx
  strokeRect ctx border
  return unit

renderHighlight :: forall e.
                     Context2D ->
                     Array Square ->
                     Maybe Coordinate ->
                     Eff (canvas :: Canvas, dom :: DOM | e) Unit
renderHighlight ctx squares selection = do
  case selection of
    Nothing -> return unit
    Just coordinate -> do
      let square = fromJust (getSquare squares coordinate)
          arcPiece = { x:     fst square.render + 0.5 * renderSize,
                       y:     snd square.render + 0.5 * renderSize,
                       r:     (renderSize / 2.0) * 0.8,
                       start: 0.0,
                       end:   2.0 * pi }
      setLineWidth highlightWidth ctx
      strokePath ctx $ arc ctx arcPiece
      return unit

renderCurrentPlayer :: forall e.
                        State ->
                        Eff (dom :: DOM | e) Unit
renderCurrentPlayer state = do
  doc <- document globalWindow
  playerIndicator <- getElementById "player" doc
  case playerIndicator of
    Just indicator -> do
      setInnerHTML (if state.currentPlayer == playerOne
                    then colorPlayerOne
                    else colorPlayerTwo) indicator
      return unit
    _ -> return unit

render :: forall s e.
            Context2D ->
            STRef s State ->
            Eff (st :: ST s, canvas :: Canvas, dom :: DOM | e) Unit
render ctx st = do
  state <- readSTRef st
  withContext ctx $ do
    foldM (renderSquare ctx) unit state.grid.squares
  withContext ctx $ do
    foldM (renderPiece state ctx) unit state.grid.squares
  withContext ctx $ do
    renderBorder ctx state.grid
  withContext ctx $ do
    renderHighlight ctx state.grid.squares state.selectedCoordinate
  withContext ctx $ do
    renderHighlight ctx state.grid.squares state.highlightedCoordinate
  renderCurrentPlayer state
  return unit

renderPage :: forall s e.
                STRef s State ->
                Eff (st :: ST s, canvas :: Canvas, dom :: DOM | e) Unit
renderPage st = do
  element <- getCanvasElementById "canvas"
  case element of
    Just canvas -> do
      setCanvasDimensions renderDimension canvas
      ctx <- getContext2D canvas
      render ctx st
      return unit
    _ -> return unit
  return unit

moveListener :: forall s e.
                  STRef s State ->
                  DOMEvent ->
                  Eff (st :: ST s, canvas :: Canvas, dom :: DOM | e) Unit
moveListener st e = do
  ux <- unsafeEventNumberProp "clientX" e
  uy <- unsafeEventNumberProp "clientY" e
  state <- readSTRef st
  let pixel = (Tuple (toNumber ux) (toNumber uy))
      highlightedCoordinate = getHighlightCoordinate state pixel
  writeSTRef st $ state { highlightedCoordinate = highlightedCoordinate }
  renderPage st
  return unit

clickListener :: forall s e.
                   STRef s State ->
                   DOMEvent ->
                   Eff (st :: ST s, canvas :: Canvas, dom :: DOM | e) Unit
clickListener st e = do
  element <- getCanvasElementById "canvas"
  case element of
    Just canvas -> do
      state <- readSTRef st
      ux <- unsafeEventNumberProp "clientX" e
      uy <- unsafeEventNumberProp "clientY" e
      let pixel = Tuple (toNumber ux) (toNumber uy)
          toCoordinate = getHighlightCoordinate state pixel
      case toCoordinate of
        Nothing -> return unit
        Just to -> do
          case state.selectedCoordinate of
            Nothing -> do
              writeSTRef st $ state { selectedCoordinate = Just to }
              renderPage st
              return unit
            Just from -> do
              case isValidMove state.grid state.currentPlayer from to of
                false -> do
                  writeSTRef st $ state { selectedCoordinate = if to == from
                                                               then Nothing
                                                               else Just to }
                  renderPage st
                  return unit
                true -> do
                  writeSTRef st $ state { highlightedCoordinate = Nothing,
                                          selectedCoordinate = Nothing,
                                          grid = movePiece from to state.grid,
                                          currentPlayer = otherPlayer state.currentPlayer }
                  renderPage st
                  return unit
    _ -> return unit
  return unit

main :: forall s e. Eff (st :: ST s, canvas :: Canvas, dom :: DOM | e) Unit
main = do
  doc <- document globalWindow
  mcanvas <- getElementById "canvas" doc
  case mcanvas of
    Just canvas -> do
      x <- offsetLeft canvas
      y <- offsetTop canvas
      let offset = (Tuple (toNumber x) (toNumber y))
      st <- newSTRef (createState offset defaultWidth defaultHeight layerCount)
      addMouseEventListener MouseMoveEvent (moveListener st) canvas
      addMouseEventListener MouseClickEvent (clickListener st) canvas
      renderPage st
      return unit
    _ -> return unit


Fix pokeSTArray, some optimizations

Fix pokeSTArray, some optimizations

-- | Helper functions for working with mutable arrays using the `ST` effect.
-- |
-- | This module can be used when performance is important and mutation is a local effect.

module Data.Array.ST
  ( STArray(..)
  , Assoc()
  , runSTArray
  , emptySTArray
  , peekSTArray
  , pokeSTArray
  , pushSTArray
  , pushAllSTArray
  , spliceSTArray
  , freeze, thaw
  , toAssocArray
  ) where

import Data.Maybe
import Data.Function

import Control.Monad.Eff
import Control.Monad.ST (ST())

-- | A reference to a mutable array.
-- |
-- | The first type parameter represents the memory region which the array belongs to.
-- | The second type parameter defines the type of elements of the mutable array.
-- |
-- | The runtime representation of a value of type `STArray h a` is the same as that of `[a]`,
-- | except that mutation is allowed.
foreign import data STArray :: * -> * -> *

-- | An element and its index
type Assoc a = { value :: a, index :: Number }

-- | Freeze a mutable array, creating an immutable array. Use this function as you would use
-- | `runST` to freeze a mutable reference.
-- |
-- | The rank-2 type prevents the reference from escaping the scope of `runSTArray`.
foreign import runSTArray """
  function runSTArray(f) {
    return f;
  }""" :: forall a r. (forall h. Eff (st :: ST h | r) (STArray h a)) -> Eff r [a]

-- | Create an empty mutable array.
foreign import emptySTArray """
  function emptySTArray() {
    return [];
  }""" :: forall a h r. Eff (st :: ST h | r) (STArray h a)

foreign import peekSTArrayImpl """
  function peekSTArrayImpl(just, nothing, arr, i) {
    return function() {
      var index = i >>> 0;
      var len = arr.length >>> 0;
      return index < len? just(arr[index]) : nothing;
    };
  }""" :: forall a h e r. Fn4 (a -> r)
                              r
                              (STArray h a)
                              Number
                              (Eff (st :: ST h | e) r)

-- | Read the value at the specified index in a mutable array.
peekSTArray :: forall a h r. STArray h a -> Number -> Eff (st :: ST h | r) (Maybe a)
peekSTArray = runFn4 peekSTArrayImpl Just Nothing

foreign import pokeSTArrayImpl """
  function pokeSTArrayImpl(arr, i, a) {
    return function() {
      var index = i >>> 0;
      var len = arr.length >>> 0;
      var ret = index < len;
      if (ret)
        arr[index] = a;
      return ret;
    };
  }""" :: forall a h e. Fn3 (STArray h a)
                            Number
                            a
                            (Eff (st :: ST h | e) Boolean)

-- | Change the value at the specified index in a mutable array.
pokeSTArray :: forall a h r. STArray h a -> Number -> a -> Eff (st :: ST h | r) Boolean
pokeSTArray = runFn3 pokeSTArrayImpl

foreign import pushAllSTArrayImpl """
  function pushAllSTArrayImpl(arr, as) {
    return function(){
      return arr.push.apply(arr, as);
    };
  }""" :: forall a h r. Fn2 (STArray h a)
                            [a]
                            (Eff (st :: ST h | r) Number)

-- | Append the values in an immutable array to the end of a mutable array.
pushAllSTArray :: forall a h r. STArray h a -> [a] -> Eff (st :: ST h | r) Number
pushAllSTArray = runFn2 pushAllSTArrayImpl

-- | Append an element to the end of a mutable array.
pushSTArray :: forall a h r. STArray h a -> a -> Eff (st :: ST h | r) Number
pushSTArray arr a = pushAllSTArray arr [a]

foreign import spliceSTArrayImpl """
  function spliceSTArrayImpl(arr, index, howMany, bs) {
    return function(){
      return arr.splice.apply(arr, [index, howMany].concat(bs));
    };
  }""" :: forall a h r. Fn4 (STArray h a)
                            Number
                            Number
                            [a]
                            (Eff (st :: ST h | r) [a])

-- | Remove and/or insert elements from/into a mutable array at the specified index.
spliceSTArray :: forall a h r. STArray h a -> Number -> Number -> [a] -> Eff (st :: ST h | r) [a]
spliceSTArray = runFn4 spliceSTArrayImpl

foreign import copyImpl """
  function copyImpl(arr) {
    return function(){
      var n = arr.length >>> 0;
      var as = new Array(n);
      for (var i = 0 >>> 0; i < n; i++)
        as[i] = arr[i];
      return as;
    };
  }""" :: forall a b h r. a -> Eff (st :: ST h | r) b

-- | Create an immutable copy of a mutable array.
freeze :: forall a h r. STArray h a -> Eff (st :: ST h | r) [a]
freeze = copyImpl

-- | Create a mutable copy of an immutable array.
thaw :: forall a h r. [a] -> Eff (st :: ST h | r) (STArray h a)
thaw = copyImpl

-- | Create an immutable copy of a mutable array, where each element
-- | is labelled with its index in the original array.
foreign import toAssocArray """
  function toAssocArray(arr) {
    return function(){
      var n = arr.length >>> 0;
      var as = new Array(n);
      for (var i = 0 >>> 0; i < n; i++)
        as[i] = {value: arr[i], index: i};
      return as;
    };
  }""" :: forall a h r. STArray h a -> Eff (st :: ST h | r) [Assoc a]

-- | Helper functions for working with mutable arrays using the `ST` effect.
-- |
-- | This module can be used when performance is important and mutation is a local effect.

module Data.Array.ST
  ( STArray(..)
  , Assoc()
  , runSTArray
  , emptySTArray
  , peekSTArray
  , pokeSTArray
  , pushSTArray
  , pushAllSTArray
  , spliceSTArray
  , freeze, thaw
  , toAssocArray
  ) where

import Data.Maybe
import Data.Function

import Control.Monad.Eff
import Control.Monad.ST (ST())

-- | A reference to a mutable array.
-- |
-- | The first type parameter represents the memory region which the array belongs to.
-- | The second type parameter defines the type of elements of the mutable array.
-- |
-- | The runtime representation of a value of type `STArray h a` is the same as that of `[a]`,
-- | except that mutation is allowed.
foreign import data STArray :: * -> * -> *

-- | An element and its index
type Assoc a = { value :: a, index :: Number }

-- | Freeze a mutable array, creating an immutable array. Use this function as you would use
-- | `runST` to freeze a mutable reference.
-- |
-- | The rank-2 type prevents the reference from escaping the scope of `runSTArray`.
foreign import runSTArray """
  function runSTArray(f) {
    return f;
  }""" :: forall a r. (forall h. Eff (st :: ST h | r) (STArray h a)) -> Eff r [a]

-- | Create an empty mutable array.
foreign import emptySTArray """
  function emptySTArray() {
    return [];
  }""" :: forall a h r. Eff (st :: ST h | r) (STArray h a)

foreign import peekSTArrayImpl """
  function peekSTArrayImpl(arr, i, s, f) {
    return function() {
      var index = ~~i;
      if (0 <= index && index < arr.length) {
        return s(arr[index]);
      } else {
        return f;
      }
    };
  }""" :: forall a h e r. Fn4 (STArray h a)
                              Number
                              (a -> r)
                              r
                              (Eff (st :: ST h | e) r)

-- | Read the value at the specified index in a mutable array.
peekSTArray :: forall a h r. STArray h a -> Number -> Eff (st :: ST h | r) (Maybe a)
peekSTArray arr i = runFn4 peekSTArrayImpl arr i Just Nothing

foreign import pokeSTArrayImpl """
  function pokeSTArrayImpl(arr, i, a) {
    return function() {
      var index = ~~i;
      if (0 <= index && index <= arr.length) {
        arr[index] = a;
        return true;
      }
      return false;
    };
  }""" :: forall a h e. Fn3 (STArray h a)
                            Number
                            a
                            (Eff (st :: ST h | e) Boolean)

-- | Change the value at the specified index in a mutable array.
pokeSTArray :: forall a h r. STArray h a -> Number -> a -> Eff (st :: ST h | r) Boolean
pokeSTArray arr i a = runFn3 pokeSTArrayImpl arr i a

foreign import pushAllSTArrayImpl """
  function pushAllSTArrayImpl(arr, as) {
    return function(){
      return arr.push.apply(arr, as);
    };
  }""" :: forall a h r. Fn2 (STArray h a)
                            [a]
                            (Eff (st :: ST h | r) Number)

-- | Append the values in an immutable array to the end of a mutable array.
pushAllSTArray :: forall a h r. STArray h a -> [a] -> Eff (st :: ST h | r) Number
pushAllSTArray = runFn2 pushAllSTArrayImpl

-- | Append an element to the end of a mutable array.
pushSTArray :: forall a h r. STArray h a -> a -> Eff (st :: ST h | r) Number
pushSTArray arr a = pushAllSTArray arr [a]

foreign import spliceSTArrayImpl """
  function spliceSTArrayImpl(arr, index, howMany, bs) {
    return function(){
      return arr.splice.apply(arr, [index, howMany].concat(bs));
    };
  }""" :: forall a h r. Fn4 (STArray h a)
                            Number
                            Number
                            [a]
                            (Eff (st :: ST h | r) [a])

-- | Remove and/or insert elements from/into a mutable array at the specified index.
spliceSTArray :: forall a h r. STArray h a -> Number -> Number -> [a] -> Eff (st :: ST h | r) [a]
spliceSTArray = runFn4 spliceSTArrayImpl

foreign import copyImpl """
  function copyImpl(arr) {
    return function(){
      var as = [];
      var i = -1;
      var n = arr.length;
      while(++i < n) {
        as[i] = arr[i];
      }
      return as;
    };
  }""" :: forall a b h r. a -> Eff (st :: ST h | r) b

-- | Create an immutable copy of a mutable array.
freeze :: forall a h r. STArray h a -> Eff (st :: ST h | r) [a]
freeze = copyImpl

-- | Create a mutable copy of an immutable array.
thaw :: forall a h r. [a] -> Eff (st :: ST h | r) (STArray h a)
thaw = copyImpl

-- | Create an immutable copy of a mutable array, where each element
-- | is labelled with its index in the original array.
foreign import toAssocArray """
  function toAssocArray(arr) {
    return function(){
      var as = [];
      var i = -1;
      var n = arr.length;
      while(++i < n) {
        as[i] = {value: arr[i], index: i};
      }
      return as;
    };
  }""" :: forall a h r. STArray h a -> Eff (st :: ST h | r) [Assoc a]