Add `expand` for `IProp`

Add `expand` for `IProp`

-- | A closed signature of type-indexed (refined) HTML properties; these can be
-- | used to ensure correctness by construction, and then erased into the
-- | standard unrefined versions.
module Halogen.HTML.Properties
  ( IProp(..)
  , prop
  , attr
  , attrNS
  , ref
  , expand

  , alt
  , charset
  , class_, classes
  , cols
  , rows
  , colSpan
  , rowSpan
  , for
  , height
  , width
  , href
  , id_
  , name
  , rel
  , src
  , target
  , title
  , download

  , method
  , action
  , enctype
  , noValidate

  , type_
  , value
  , min
  , max
  , step
  , disabled
  , enabled
  , required
  , readOnly
  , spellcheck
  , checked
  , selected
  , placeholder
  , autocomplete
  , list
  , autofocus
  , multiple
  , pattern
  , accept

  , autoplay
  , controls
  , loop
  , muted
  , poster
  , preload

  , draggable
  , tabIndex

  , module I
  ) where

import Prelude

import DOM.HTML.Indexed (CSSPixel) as I
import DOM.HTML.Indexed.ButtonType (ButtonType(..)) as I
import DOM.HTML.Indexed.FormMethod (FormMethod(..)) as I
import DOM.HTML.Indexed.InputAcceptType (InputAcceptType(..)) as I
import DOM.HTML.Indexed.InputType (InputType(..)) as I
import DOM.HTML.Indexed.MenuType (MenuType(..)) as I
import DOM.HTML.Indexed.MenuitemType (MenuitemType(..)) as I
import DOM.HTML.Indexed.OnOff (OnOff(..)) as I
import DOM.HTML.Indexed.OrderedListType (OrderedListType(..)) as I
import DOM.HTML.Indexed.PreloadValue (PreloadValue(..)) as I
import DOM.HTML.Indexed.StepValue (StepValue(..)) as I
import Data.Maybe (Maybe(..))
import Data.MediaType (MediaType)
import Data.Newtype (class Newtype, unwrap)
import Data.String (joinWith)
import Halogen.HTML.Core (class IsProp, AttrName(..), ClassName, Namespace, PropName(..), Prop)
import Halogen.HTML.Core as Core
import Halogen.Query.Input (Input(..), RefLabel)
import Prim.Row as Row
import Unsafe.Coerce (unsafeCoerce)
import Web.DOM.Element (Element)

-- | The phantom row `r` can be thought of as a context which is synthesized in
-- | the course of constructing a refined HTML expression.
newtype IProp (r :: # Type) i = IProp (Prop (Input i))

derive instance newtypeIProp :: Newtype (IProp r i) _
derive instance functorIProp :: Functor (IProp r)

-- | Creates an indexed HTML property.
prop
  :: forall value r i
   . IsProp value
  => PropName value
  -> value
  -> IProp r i
prop = (unsafeCoerce :: (PropName value -> value -> Prop (Input i)) -> PropName value -> value -> IProp r i) Core.prop

-- | Creates an indexed HTML attribute.
attr :: forall r i. AttrName -> String -> IProp r i
attr =
  Core.attr Nothing #
    (unsafeCoerce
      :: (AttrName -> String -> Prop (Input i))
      -> AttrName
      -> String
      -> IProp r i)

-- | Creates an indexed HTML attribute.
attrNS :: forall r i. Namespace -> AttrName -> String -> IProp r i
attrNS =
  pure >>> Core.attr >>>
    (unsafeCoerce
      :: (AttrName -> String -> Prop (Input i))
      -> AttrName
      -> String
      -> IProp r i)

-- | The `ref` property allows an input to be raised once a `HTMLElement` has
-- | been created or destroyed in the DOM for the element that the property is
-- | attached to.
ref :: forall r i. RefLabel -> IProp r i
ref = (unsafeCoerce :: ((Maybe Element -> Maybe (Input i)) -> Prop (Input i)) -> (Maybe Element -> Maybe (Input i)) -> IProp r i) Core.ref <<< go
  where
  go :: RefLabel -> Maybe Element -> Maybe (Input i)
  go p mel = Just (RefUpdate p mel)

-- | Every `IProp lt i` can be cast to some `IProp gt i` as long as `lt` is a
-- | subset of `gt`.
expand ∷ ∀ lt gt a i. Row.Union lt a gt ⇒ IProp lt i → IProp gt i
expand = unsafeCoerce

alt :: forall r i. String -> IProp (alt :: String | r) i
alt = prop (PropName "alt")

charset :: forall r i. String -> IProp (charset :: String | r) i
charset = prop (PropName "charset")

class_ :: forall r i. ClassName -> IProp (class :: String | r) i
class_ = prop (PropName "className") <<< unwrap

classes :: forall r i. Array ClassName -> IProp (class :: String | r) i
classes = prop (PropName "className") <<< joinWith " " <<< map unwrap

cols :: forall r i. Int -> IProp (cols :: Int | r) i
cols = prop (PropName "cols")

rows :: forall r i. Int -> IProp (rows :: Int | r) i
rows = prop (PropName "rows")

colSpan :: forall r i. Int -> IProp (colSpan :: Int | r) i
colSpan = prop (PropName "colSpan")

rowSpan :: forall r i. Int -> IProp (rowSpan :: Int | r) i
rowSpan = prop (PropName "rowSpan")

for :: forall r i. String -> IProp (for :: String | r) i
for = prop (PropName "htmlFor")

height :: forall r i. I.CSSPixel -> IProp (height :: I.CSSPixel | r) i
height = prop (PropName "height")

width :: forall r i. I.CSSPixel -> IProp (width :: I.CSSPixel | r) i
width = prop (PropName "width")

href :: forall r i. String -> IProp (href :: String | r) i
href = prop (PropName "href")

id_ :: forall r i. String -> IProp (id :: String | r) i
id_ = prop (PropName "id")

name :: forall r i. String -> IProp (name :: String | r) i
name = prop (PropName "name")

rel :: forall r i. String -> IProp (rel :: String | r) i
rel = prop (PropName "rel")

src :: forall r i. String -> IProp (src :: String | r) i
src = prop (PropName "src")

target :: forall r i. String -> IProp (target :: String | r) i
target = prop (PropName "target")

title :: forall r i. String -> IProp (title :: String | r) i
title = prop (PropName "title")

download :: ∀ r i. String -> IProp (download :: String | r) i
download = prop (PropName "download")

method :: forall r i. I.FormMethod -> IProp (method :: I.FormMethod | r) i
method = prop (PropName "method")

action :: forall r i. String -> IProp (action :: String | r) i
action = prop (PropName "action")

enctype :: forall r i. MediaType -> IProp (enctype :: MediaType | r) i
enctype = prop (PropName "enctype")

noValidate :: forall r i. Boolean -> IProp (noValidate :: Boolean | r) i
noValidate = prop (PropName "noValidate")

type_ :: forall r i value. IsProp value => value -> IProp (type :: value | r) i
type_ = prop (PropName "type")

value :: forall r i. String -> IProp (value :: String | r) i
value = prop (PropName "value")

min :: forall r i. Number -> IProp (min :: Number | r) i
min = prop (PropName "min")

max :: forall r i. Number -> IProp (max :: Number | r) i
max = prop (PropName "max")

step :: forall r i. I.StepValue -> IProp (step :: I.StepValue | r) i
step = prop (PropName "step")

enabled :: forall r i. Boolean -> IProp (disabled :: Boolean | r) i
enabled = disabled <<< not

disabled :: forall r i. Boolean -> IProp (disabled :: Boolean | r) i
disabled = prop (PropName "disabled")

required :: forall r i. Boolean -> IProp (required :: Boolean | r) i
required = prop (PropName "required")

readOnly :: forall r i. Boolean -> IProp (readOnly :: Boolean | r) i
readOnly = prop (PropName "readOnly")

spellcheck :: forall r i. Boolean -> IProp (spellcheck :: Boolean | r) i
spellcheck = prop (PropName "spellcheck")

checked :: forall r i. Boolean -> IProp (checked :: Boolean | r) i
checked = prop (PropName "checked")

selected :: forall r i. Boolean -> IProp (selected :: Boolean | r) i
selected = prop (PropName "selected")

placeholder :: forall r i. String -> IProp (placeholder :: String | r) i
placeholder = prop (PropName "placeholder")

autocomplete :: forall r i. Boolean -> IProp (autocomplete :: I.OnOff | r) i
autocomplete = prop (PropName "autocomplete") <<< (\b -> if b then I.On else I.Off)

list :: forall r i. String -> IProp (list :: String | r) i
list = attr (AttrName "list")

autofocus :: forall r i. Boolean -> IProp (autofocus :: Boolean | r) i
autofocus = prop (PropName "autofocus")

multiple :: forall r i. Boolean -> IProp (multiple :: Boolean | r) i
multiple = prop (PropName "multiple")

accept :: forall r i. I.InputAcceptType -> IProp (accept :: I.InputAcceptType | r) i
accept = prop (PropName "accept")

pattern :: forall r i. String -> IProp (pattern :: String | r) i
pattern = prop (PropName "pattern")

autoplay :: forall r i. Boolean -> IProp (autoplay :: Boolean | r) i
autoplay = prop (PropName "autoplay")

controls :: forall r i. Boolean -> IProp (controls :: Boolean | r) i
controls = prop (PropName "controls")

loop :: forall r i. Boolean -> IProp (loop :: Boolean | r) i
loop = prop (PropName "loop")

muted :: forall r i. Boolean -> IProp (muted :: Boolean | r) i
muted = prop (PropName "muted")

poster :: forall r i. String -> IProp (poster :: String | r) i
poster = prop (PropName "poster")

preload :: forall r i. I.PreloadValue -> IProp (preload :: I.PreloadValue | r) i
preload = prop (PropName "preload")

draggable :: forall r i. Boolean -> IProp (draggable :: Boolean | r) i
draggable = prop (PropName "draggable")

tabIndex :: forall r i. Int -> IProp (tabIndex :: Int | r) i
tabIndex = prop (PropName "tabIndex")

-- | A closed signature of type-indexed (refined) HTML properties; these can be
-- | used to ensure correctness by construction, and then erased into the
-- | standard unrefined versions.
module Halogen.HTML.Properties
  ( IProp(..)
  , prop
  , attr
  , attrNS
  , ref

  , alt
  , charset
  , class_, classes
  , cols
  , rows
  , colSpan
  , rowSpan
  , for
  , height
  , width
  , href
  , id_
  , name
  , rel
  , src
  , target
  , title
  , download

  , method
  , action
  , enctype
  , noValidate

  , type_
  , value
  , min
  , max
  , step
  , disabled
  , enabled
  , required
  , readOnly
  , spellcheck
  , checked
  , selected
  , placeholder
  , autocomplete
  , list
  , autofocus
  , multiple
  , pattern
  , accept

  , autoplay
  , controls
  , loop
  , muted
  , poster
  , preload

  , draggable
  , tabIndex

  , module I
  ) where

import Prelude

import DOM.HTML.Indexed (CSSPixel) as I
import DOM.HTML.Indexed.ButtonType (ButtonType(..)) as I
import DOM.HTML.Indexed.FormMethod (FormMethod(..)) as I
import DOM.HTML.Indexed.InputAcceptType (InputAcceptType(..)) as I
import DOM.HTML.Indexed.InputType (InputType(..)) as I
import DOM.HTML.Indexed.MenuType (MenuType(..)) as I
import DOM.HTML.Indexed.MenuitemType (MenuitemType(..)) as I
import DOM.HTML.Indexed.OnOff (OnOff(..)) as I
import DOM.HTML.Indexed.OrderedListType (OrderedListType(..)) as I
import DOM.HTML.Indexed.PreloadValue (PreloadValue(..)) as I
import DOM.HTML.Indexed.StepValue (StepValue(..)) as I
import Data.Maybe (Maybe(..))
import Data.MediaType (MediaType)
import Data.Newtype (class Newtype, unwrap)
import Data.String (joinWith)
import Halogen.HTML.Core (class IsProp, AttrName(..), ClassName, Namespace, PropName(..), Prop)
import Halogen.HTML.Core as Core
import Halogen.Query.Input (Input(..), RefLabel)
import Unsafe.Coerce (unsafeCoerce)
import Web.DOM.Element (Element)

-- | The phantom row `r` can be thought of as a context which is synthesized in
-- | the course of constructing a refined HTML expression.
newtype IProp (r :: # Type) i = IProp (Prop (Input i))

derive instance newtypeIProp :: Newtype (IProp r i) _
derive instance functorIProp :: Functor (IProp r)

-- | Creates an indexed HTML property.
prop
  :: forall value r i
   . IsProp value
  => PropName value
  -> value
  -> IProp r i
prop = (unsafeCoerce :: (PropName value -> value -> Prop (Input i)) -> PropName value -> value -> IProp r i) Core.prop

-- | Creates an indexed HTML attribute.
attr :: forall r i. AttrName -> String -> IProp r i
attr =
  Core.attr Nothing #
    (unsafeCoerce
      :: (AttrName -> String -> Prop (Input i))
      -> AttrName
      -> String
      -> IProp r i)

-- | Creates an indexed HTML attribute.
attrNS :: forall r i. Namespace -> AttrName -> String -> IProp r i
attrNS =
  pure >>> Core.attr >>>
    (unsafeCoerce
      :: (AttrName -> String -> Prop (Input i))
      -> AttrName
      -> String
      -> IProp r i)

-- | The `ref` property allows an input to be raised once a `HTMLElement` has
-- | been created or destroyed in the DOM for the element that the property is
-- | attached to.
ref :: forall r i. RefLabel -> IProp r i
ref = (unsafeCoerce :: ((Maybe Element -> Maybe (Input i)) -> Prop (Input i)) -> (Maybe Element -> Maybe (Input i)) -> IProp r i) Core.ref <<< go
  where
  go :: RefLabel -> Maybe Element -> Maybe (Input i)
  go p mel = Just (RefUpdate p mel)

alt :: forall r i. String -> IProp (alt :: String | r) i
alt = prop (PropName "alt")

charset :: forall r i. String -> IProp (charset :: String | r) i
charset = prop (PropName "charset")

class_ :: forall r i. ClassName -> IProp (class :: String | r) i
class_ = prop (PropName "className") <<< unwrap

classes :: forall r i. Array ClassName -> IProp (class :: String | r) i
classes = prop (PropName "className") <<< joinWith " " <<< map unwrap

cols :: forall r i. Int -> IProp (cols :: Int | r) i
cols = prop (PropName "cols")

rows :: forall r i. Int -> IProp (rows :: Int | r) i
rows = prop (PropName "rows")

colSpan :: forall r i. Int -> IProp (colSpan :: Int | r) i
colSpan = prop (PropName "colSpan")

rowSpan :: forall r i. Int -> IProp (rowSpan :: Int | r) i
rowSpan = prop (PropName "rowSpan")

for :: forall r i. String -> IProp (for :: String | r) i
for = prop (PropName "htmlFor")

height :: forall r i. I.CSSPixel -> IProp (height :: I.CSSPixel | r) i
height = prop (PropName "height")

width :: forall r i. I.CSSPixel -> IProp (width :: I.CSSPixel | r) i
width = prop (PropName "width")

href :: forall r i. String -> IProp (href :: String | r) i
href = prop (PropName "href")

id_ :: forall r i. String -> IProp (id :: String | r) i
id_ = prop (PropName "id")

name :: forall r i. String -> IProp (name :: String | r) i
name = prop (PropName "name")

rel :: forall r i. String -> IProp (rel :: String | r) i
rel = prop (PropName "rel")

src :: forall r i. String -> IProp (src :: String | r) i
src = prop (PropName "src")

target :: forall r i. String -> IProp (target :: String | r) i
target = prop (PropName "target")

title :: forall r i. String -> IProp (title :: String | r) i
title = prop (PropName "title")

download :: ∀ r i. String -> IProp (download :: String | r) i
download = prop (PropName "download")

method :: forall r i. I.FormMethod -> IProp (method :: I.FormMethod | r) i
method = prop (PropName "method")

action :: forall r i. String -> IProp (action :: String | r) i
action = prop (PropName "action")

enctype :: forall r i. MediaType -> IProp (enctype :: MediaType | r) i
enctype = prop (PropName "enctype")

noValidate :: forall r i. Boolean -> IProp (noValidate :: Boolean | r) i
noValidate = prop (PropName "noValidate")

type_ :: forall r i value. IsProp value => value -> IProp (type :: value | r) i
type_ = prop (PropName "type")

value :: forall r i. String -> IProp (value :: String | r) i
value = prop (PropName "value")

min :: forall r i. Number -> IProp (min :: Number | r) i
min = prop (PropName "min")

max :: forall r i. Number -> IProp (max :: Number | r) i
max = prop (PropName "max")

step :: forall r i. I.StepValue -> IProp (step :: I.StepValue | r) i
step = prop (PropName "step")

enabled :: forall r i. Boolean -> IProp (disabled :: Boolean | r) i
enabled = disabled <<< not

disabled :: forall r i. Boolean -> IProp (disabled :: Boolean | r) i
disabled = prop (PropName "disabled")

required :: forall r i. Boolean -> IProp (required :: Boolean | r) i
required = prop (PropName "required")

readOnly :: forall r i. Boolean -> IProp (readOnly :: Boolean | r) i
readOnly = prop (PropName "readOnly")

spellcheck :: forall r i. Boolean -> IProp (spellcheck :: Boolean | r) i
spellcheck = prop (PropName "spellcheck")

checked :: forall r i. Boolean -> IProp (checked :: Boolean | r) i
checked = prop (PropName "checked")

selected :: forall r i. Boolean -> IProp (selected :: Boolean | r) i
selected = prop (PropName "selected")

placeholder :: forall r i. String -> IProp (placeholder :: String | r) i
placeholder = prop (PropName "placeholder")

autocomplete :: forall r i. Boolean -> IProp (autocomplete :: I.OnOff | r) i
autocomplete = prop (PropName "autocomplete") <<< (\b -> if b then I.On else I.Off)

list :: forall r i. String -> IProp (list :: String | r) i
list = attr (AttrName "list")

autofocus :: forall r i. Boolean -> IProp (autofocus :: Boolean | r) i
autofocus = prop (PropName "autofocus")

multiple :: forall r i. Boolean -> IProp (multiple :: Boolean | r) i
multiple = prop (PropName "multiple")

accept :: forall r i. I.InputAcceptType -> IProp (accept :: I.InputAcceptType | r) i
accept = prop (PropName "accept")

pattern :: forall r i. String -> IProp (pattern :: String | r) i
pattern = prop (PropName "pattern")

autoplay :: forall r i. Boolean -> IProp (autoplay :: Boolean | r) i
autoplay = prop (PropName "autoplay")

controls :: forall r i. Boolean -> IProp (controls :: Boolean | r) i
controls = prop (PropName "controls")

loop :: forall r i. Boolean -> IProp (loop :: Boolean | r) i
loop = prop (PropName "loop")

muted :: forall r i. Boolean -> IProp (muted :: Boolean | r) i
muted = prop (PropName "muted")

poster :: forall r i. String -> IProp (poster :: String | r) i
poster = prop (PropName "poster")

preload :: forall r i. I.PreloadValue -> IProp (preload :: I.PreloadValue | r) i
preload = prop (PropName "preload")

draggable :: forall r i. Boolean -> IProp (draggable :: Boolean | r) i
draggable = prop (PropName "draggable")

tabIndex :: forall r i. Int -> IProp (tabIndex :: Int | r) i
tabIndex = prop (PropName "tabIndex")


First try at mapping between canvas & other coords (half working) in UI

module Genetics.Browser.Track.UI where

import Prelude

import Control.Alt ((<|>))
import Control.Alternative (empty, (<*>))
import Control.Monad.Aff (Aff, launchAff)
import Control.Monad.Aff.AVar (makeVar, putVar, tryPeekVar)
import Control.Monad.Eff (Eff, foreachE)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Console (log)
import Control.Monad.Eff.Exception (error)
import Control.Monad.Eff.Unsafe (unsafeCoerceEff)
import Control.Monad.Error.Class (throwError)
import DOM.HTML.Types (HTMLElement)
import Data.Argonaut (Json, _Array, _Number, _Object, _String)
import Data.Array (take, zip)
import Data.Array as Array
import Data.BigInt (BigInt)
import Data.BigInt as BigInt
import Data.Either (Either(..))
import Data.Filterable (class Filterable, filter, filterMap)
import Data.Filterable as Filterable
import Data.Foldable (class Foldable, foldMap, for_, length, maximum, maximumBy, sum)
import Data.Int (round)
import Data.Int as Int
import Data.Lens (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(..), fromJust, fromMaybe)
import Data.Monoid (mempty)
import Data.Newtype (ala, alaF, over, unwrap, wrap)
import Data.Nullable (Nullable, toMaybe)
import Data.Ord.Max (Max(..))
import Data.Ratio (Ratio, (%))
import Data.Ratio as Ratio
import Data.Semigroup.Foldable (foldMap1)
import Data.Traversable (traverse, traverse_)
import Data.Tuple (Tuple(..), fst, snd)
import Debug.Trace (traceShow)
import FRP.Event (Event)
import FRP.Event as Event
import FRP.Event as FRP
import Genetics.Browser.Track.Backend (GWASFeature, Gene, drawDemo, getDataDemo, mouseChrIds)
import Genetics.Browser.Types (Bp(..), ChrId(..), Point)
import Genetics.Browser.View (Pixels)
import Global as Global
import Global.Unsafe (unsafeStringify)
import Graphics.Canvas (CanvasElement, Context2D, Transform, TranslateTransform, getCanvasElementById, getCanvasHeight, getContext2D, setCanvasWidth, transform, translate, withContext)
import Graphics.Drawing (Drawing, fillColor, filled, rectangle, white)
import Graphics.Drawing as Drawing
import Math as Math
import Network.HTTP.Affjax as Affjax
import Partial.Unsafe (unsafePartial)
import Unsafe.Coerce (unsafeCoerce)

foreign import getScreenSize :: forall eff. Eff eff { w :: Number, h :: Number }

-- 1st element is a backbuffer, 2nd the one shown on screen
-- foreign import scrollCanvas :: forall eff.
--                                CanvasElement
--                             -> CanvasElement
--                             -> Point
--                             -> Eff eff Unit

-- creates a new CanvasElement, not attached to the DOM and thus not visible
-- foreign import newCanvas :: forall eff.
--                             { w :: Number, h :: Number }
--                          -> Eff eff CanvasElement

foreign import clearCanvas :: forall eff. CanvasElement -> Eff eff Unit

-- set an event to fire on the given button id
foreign import buttonEvent :: String
                           -> Event Unit

-- foreign import canvasDragImpl :: CanvasElement -> Event { during :: Nullable Point
--                                                         , total :: Nullable Point }

foreign import canvasEvent :: String -> CanvasElement -> Event Point

foreign import setViewUI :: forall eff. String -> Eff eff Unit

type View = { lHand :: ChrId, rHand :: ChrId }

type ZipperRange a =
  { left  :: List a
  , focus :: List a
  , right :: List a
  }

zipSlideLeft :: forall a.
                ZipperRange a
             -> ZipperRange a
zipSlideLeft zr@{left, focus, right} = case List.uncons left, List.unsnoc focus of
    Nothing, _  -> zr
    _ , Nothing -> zr
    Just l, Just f ->
      let left'  = l.tail
          focus' = l.head : f.init
          right' = f.last : right
      in {left: left', focus: focus', right: right'}

zipSlideRight :: forall a.
                 ZipperRange a
              -> ZipperRange a
zipSlideRight zr@{left, focus, right} = case List.uncons focus, List.uncons right of
    Nothing, _  -> zr
    _ , Nothing -> zr
    Just f, Just r ->
      let left'  = f.head : left
          focus' = f.tail <> List.singleton r.head
          right' = r.tail
      in {left: left', focus: focus', right: right'}

zipZoomIn :: forall a.
             ZipperRange a
          -> ZipperRange a
zipZoomIn zr@{left, focus, right} = case List.uncons focus of
  Nothing -> zr
  Just {head, tail} -> case List.unsnoc tail of
    Nothing -> zr
    Just {init, last} ->
      let left'  = head : left
          focus' = init
          right' = last : right
      in {left: left', focus: focus', right: right'}

zipZoomOut :: forall a.
              ZipperRange a
           -> ZipperRange a
zipZoomOut zr@{left, focus, right} = case List.uncons left, List.uncons right of
  Nothing, Nothing -> zr
  Nothing, Just r ->
    let focus' = focus <> List.singleton r.head
        right' = r.tail
    in zr { focus = focus', right = right' }
  Just l, Nothing ->
    let left' = l.tail
        focus' = l.head : focus
    in zr { focus = focus', left = left' }
  Just l, Just r ->
    let left' = l.tail
        focus' = l.head : focus <> List.singleton r.head
        right' = r.tail
    in { left: left', focus: focus', right: right' }

focusArray :: forall a.
              ZipperRange a
           -> Array a
focusArray {focus} = Array.fromFoldable focus

unfocusArray :: forall a.
                Array a
             -> ZipperRange a
unfocusArray arr = { left: Nil
                   , focus: List.fromFoldable arr
                   , right: Nil
                   }

data UpdateView =
    GoLeft
  | GoRight
  | Out
  | In
  | NoOp

btnScroll :: Event UpdateView
btnScroll = const GoLeft  <$> buttonEvent "scrollLeft" <|>
            const GoRight <$> buttonEvent "scrollRight"

btnZoom :: Event UpdateView
btnZoom = const Out <$> buttonEvent "zoomOut" <|>
          const In  <$> buttonEvent "zoomIn"

btnUpdateView :: Event UpdateView
btnUpdateView = btnScroll <|> btnZoom <|> (const NoOp <$> buttonEvent "redraw")

mkFoldView :: UpdateView
           -> ZipperRange ChrId
           -> ZipperRange ChrId
mkFoldView uv zr = case uv of
  GoLeft  -> zipSlideLeft zr
  GoRight -> zipSlideRight zr
  Out     -> zipZoomOut zr
  In      -> zipZoomIn zr
  NoOp    -> zr

chrZREvent :: Array ChrId
           -> Event UpdateView
           -> Event (ZipperRange ChrId)
chrZREvent chrs uv = Event.fold mkFoldView uv (unfocusArray chrs)

chrsArrayEvent :: Event (ZipperRange ChrId)
               -> Event (Array ChrId)
chrsArrayEvent = map (Array.fromFoldable <<< _.focus)

drawingEvent :: { min :: Number, max :: Number }
             -> { width :: Pixels, height :: Pixels, padding :: Pixels, yOffset :: Pixels }
             -> { gwas  :: Map ChrId (List _)
                , annots :: Map ChrId (List _) }
             -> Event (Array ChrId)
             -> Event (Drawing)
drawingEvent s box dat = let dd = drawDemo s 0.25 box dat
                         in map dd

newtype CanvasX = CX Number

newtype ViewX = ViewX (Ratio BigInt)

canvasToView :: Pixels
             -> CanvasX
             -> ViewX
canvasToView w (CX x) = ViewX $ x' % w'
  where w' = BigInt.fromInt $ Int.round w
        x' = BigInt.fromInt $ Int.round x

newtype BrowserX = BX BigInt

viewToGlobal :: Tuple BrowserX BrowserX
             -> ViewX
             -> BrowserX
viewToGlobal (Tuple (BX l) (BX r)) (ViewX p) =
  let p' = p * ((r - l) % one)
  in BX $ (Ratio.numerator p') / (Ratio.denominator p')

-- findInterval :: Array (Tuple ChrId (Tuple BigInt BigInt))

findInterval :: Array (Tuple ChrId (Tuple BigInt BigInt))
             -> BigInt
             -> Maybe (Tuple ChrId (Tuple BigInt BigInt))
findInterval ivals p =
  Array.find (\(Tuple i (Tuple l r)) -> l <= p && p <= r) intervals

-- this could be done in a more generic manner by extracting the view interval
-- using the applicative on (->)
globalToFrame :: Array (Tuple ChrId (Tuple BigInt BigInt))
              -> BrowserX
              -> Maybe (Tuple ChrId ViewX)
globalToFrame ivals (BX p) = do
  (Tuple i (Tuple l r)) <- findInterval ivals p

  pure $ Tuple i $ ViewX $ (p - l) % (r - l)

frameToChr :: Array (Tuple ChrId BigInt)
           -> Tuple ChrId ViewX
           -> Maybe (Tuple ChrId BigInt)
frameToChr chrs (Tuple i (ViewX x)) = do
  (Tuple _ size) <- Array.find ((==) i <<< fst) chrs
  let x' = x * (size % one)
  pure $ Tuple i $ Ratio.numerator x'

chrsToView :: Array (Tuple ChrId (Tuple BigInt BigInt))
           -> Array ChrId
           -> Tuple BrowserX BrowserX
chrsToView chrs view = fromMaybe (Tuple (BX zero) (BX one)) $ do
  f <- Array.head view
  l <- Array.last view
  (Tuple _ (Tuple start _)) <- Array.find ((==) f <<< fst) chrs
  (Tuple _ (Tuple _ end)) <- Array.find ((==) l <<< fst) chrs

  pure $ Tuple (BX start) (BX end)

viewRange :: Array (Tuple ChrId (Tuple BigInt BigInt))
          -> Event (Array ChrId)
          -> Event (Tuple BrowserX BrowserX)
viewRange chrs = map (chrsToView chrs)

clickEvent :: forall r.
              CanvasElement
           -> Event CanvasX
clickEvent el = (CX <<< _.x)<$> canvasEvent "mousedown" el

viewClick :: forall r.
             { width :: Pixels | r}
          -> Event CanvasX
          -> Event ViewX
viewClick {width} = map (canvasToView width)

globalClick :: Event (Tuple BrowserX BrowserX)
            -> Event ViewX
            -> Event BrowserX
globalClick vs vx = viewToGlobal <$> vs <*> vx

frameClick :: Array (Tuple ChrId (Tuple BigInt BigInt))
           -> Event BrowserX
           -- -> Event ViewX
           -> Event (Maybe (Tuple ChrId ViewX))
frameClick ivals = map (globalToFrame ivals)

chrClick :: Array (Tuple ChrId BigInt)
         -> Event (Maybe (Tuple ChrId ViewX))
         -> Event (Maybe (Tuple ChrId BigInt))
chrClick chrs ev = (frameToChr chrs =<< _) <$> ev

showView :: Tuple BrowserX BrowserX -> String
showView (Tuple (BX l) (BX r)) = "< " <> show l <> " -- " <> show r <> " >"

main :: Eff _ _
main = launchAff do

  canvas <- liftEff $ unsafePartial $ fromJust <$> getCanvasElementById "canvas"
  ctx <- liftEff $ getContext2D canvas

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

  let height = h
      offset = 0.0
      yInfo = { height, offset }

      chrIds = mouseChrIds

  let viewEvent :: Event (Array ChrId)
      viewEvent = chrsArrayEvent $ chrZREvent mouseChrIds btnUpdateView

      viewEv' :: Event (Tuple BrowserX BrowserX)
      viewEv' = viewRange intervals viewEvent

      click :: Event CanvasX
      click = clickEvent canvas

      vClick :: Event ViewX
      vClick = viewClick {width: w} click

      gClick :: Event BrowserX
      gClick = globalClick viewEv' vClick

      fClick :: Event (Maybe (Tuple ChrId ViewX))
      fClick = frameClick intervals gClick

      cClick :: Event (Maybe (Tuple ChrId BigInt))
      cClick = chrClick mouseChrSizes fClick

      clickEvs :: Event { view :: _
                        , canvasClick :: _
                        , vClick :: _
                        , gClick :: _
                        , fClick :: _
                        , cClick :: _ }
      clickEvs = { view: _, canvasClick: _, vClick: _
                 , gClick: _, fClick: _, cClick: _ }
                 <$> viewEv' <*> click <*> vClick
                 <*> gClick <*> fClick <*> cClick

      showVX :: ViewX -> String
      showVX (ViewX x) = (BigInt.toString $ Ratio.numerator   x) <> "/"
                      <> (BigInt.toString $ Ratio.denominator x)

  void $ liftEff $ Event.subscribe clickEvs
       (\ev -> do
           let sC (CX x)    = "
Canvas click: " <> show x <> "
"
               sV x         = "
View click: " <> showVX x <> "
"
               sG (BX x)    = "
Global click: " <> BigInt.toString x <> "
"
               sF :: _
               sF = show <<< (map <<< map) showVX
               sChr :: _
               sChr = show <<< (map <<< map) BigInt.toString

           setViewUI $ "
" <> showView ev.view <> "
"
                    <> sC ev.canvasClick
                    <> sV ev.vClick
                    <> sG ev.gClick
                    <> "
Frame click: " <> sF ev.fClick <> "
"
                    <> "
Chr click: " <> sChr ev.cClick <> "
"
           )

  dat <- getDataDemo { gwas: "./gwas.json"
                     , annots: "./annots_fake.json" }

  let sizes = {width: w, height: h, padding: 10.0, yOffset: 5.0}
      score = {min: 0.125, max: 0.42}

  let ev' = drawingEvent score sizes dat viewEvent
      bg = filled (fillColor white) $ rectangle 0.0 0.0 w h

  void $ liftEff $ Event.subscribe ev' (\d -> Drawing.render ctx (bg <> d))

mouseChrSizes :: Array (Tuple ChrId BigInt)
mouseChrSizes =
            [ Tuple (ChrId "1")   (unsafePartial $ fromJust $ BigInt.fromString "195471971")
            , Tuple (ChrId "2")   (unsafePartial $ fromJust $ BigInt.fromString "182113224")
            , Tuple (ChrId "3")   (unsafePartial $ fromJust $ BigInt.fromString "160039680")
            , Tuple (ChrId "4")   (unsafePartial $ fromJust $ BigInt.fromString "156508116")
            , Tuple (ChrId "5")   (unsafePartial $ fromJust $ BigInt.fromString "151834684")
            , Tuple (ChrId "6")   (unsafePartial $ fromJust $ BigInt.fromString "149736546")
            , Tuple (ChrId "7")   (unsafePartial $ fromJust $ BigInt.fromString "145441459")
            , Tuple (ChrId "8")   (unsafePartial $ fromJust $ BigInt.fromString "129401213")
            , Tuple (ChrId "9")   (unsafePartial $ fromJust $ BigInt.fromString "124595110")
            , Tuple (ChrId "10")  (unsafePartial $ fromJust $ BigInt.fromString "130694993")
            , Tuple (ChrId "11")  (unsafePartial $ fromJust $ BigInt.fromString "122082543")
            , Tuple (ChrId "12")  (unsafePartial $ fromJust $ BigInt.fromString "120129022")
            , Tuple (ChrId "13")  (unsafePartial $ fromJust $ BigInt.fromString "120421639")
            , Tuple (ChrId "14")  (unsafePartial $ fromJust $ BigInt.fromString "124902244")
            , Tuple (ChrId "15")  (unsafePartial $ fromJust $ BigInt.fromString "104043685")
            , Tuple (ChrId "16")  (unsafePartial $ fromJust $ BigInt.fromString "98207768")
            , Tuple (ChrId "17")  (unsafePartial $ fromJust $ BigInt.fromString "94987271")
            , Tuple (ChrId "18")  (unsafePartial $ fromJust $ BigInt.fromString "90702639")
            , Tuple (ChrId "19")  (unsafePartial $ fromJust $ BigInt.fromString "61431566")
            , Tuple (ChrId "X")   (unsafePartial $ fromJust $ BigInt.fromString "17103129")
            , Tuple (ChrId "Y")   (unsafePartial $ fromJust $ BigInt.fromString "9174469")
            ]

intervals :: Array (Tuple ChrId (Tuple BigInt BigInt))
intervals = Array.zip ids $ Array.zip (zero `Array.cons` os) os
  where (Tuple ids sizes) = Array.unzip mouseChrSizes
        os = Array.scanl (+) zero sizes

-- mkIntervals :: Array BigInt
--             -> Array (Tuple BigInt BigInt)
-- mkIntervals bps = Array.zip (zero `Array.cons` os) os
--   where os :: Array BigInt
--         os = Array.scanl (+) zero bps

module Genetics.Browser.Track.UI where

import Prelude

import Control.Alt ((<|>))
import Control.Monad.Aff (Aff, launchAff)
import Control.Monad.Aff.AVar (makeVar, putVar, tryPeekVar)
import Control.Monad.Eff (Eff, foreachE)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Console (log)
import Control.Monad.Eff.Exception (error)
import Control.Monad.Eff.Unsafe (unsafeCoerceEff)
import Control.Monad.Error.Class (throwError)
import DOM.HTML.Types (HTMLElement)
import Data.Argonaut (Json, _Array, _Number, _Object, _String)
import Data.Array (take, zip)
import Data.Array as Array
import Data.Either (Either(..))
import Data.Filterable (class Filterable, filter, filterMap)
import Data.Filterable as Filterable
import Data.Foldable (class Foldable, foldMap, for_, length, maximum, maximumBy, sum)
import Data.Int (round)
import Data.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(..), fromJust, fromMaybe)
import Data.Monoid (mempty)
import Data.Newtype (ala, alaF, over, unwrap, wrap)
import Data.Nullable (Nullable, toMaybe)
import Data.Ord.Max (Max(..))
import Data.Semigroup.Foldable (foldMap1)
import Data.Traversable (traverse, traverse_)
import Data.Tuple (Tuple(..), fst, snd)
import Debug.Trace (traceShow)
import FRP.Event (Event)
import FRP.Event as Event
import FRP.Event as FRP
import Genetics.Browser.Track.Backend (GWASFeature, Gene, drawDemo, getDataDemo, mouseChrIds)
import Genetics.Browser.Types (Bp(..), ChrId(..))
import Genetics.Browser.View (Pixels)
import Global as Global
import Global.Unsafe (unsafeStringify)
import Graphics.Canvas (CanvasElement, Context2D, TranslateTransform, Transform, getCanvasElementById, getCanvasHeight, getContext2D, setCanvasWidth, transform, translate, withContext)
import Graphics.Drawing (Drawing, fillColor, filled, rectangle, white)
import Graphics.Drawing as Drawing
import Math as Math
import Network.HTTP.Affjax as Affjax
import Partial.Unsafe (unsafePartial)
import Unsafe.Coerce (unsafeCoerce)

foreign import getScreenSize :: forall eff. Eff eff { w :: Number, h :: Number }

-- 1st element is a backbuffer, 2nd the one shown on screen
-- foreign import scrollCanvas :: forall eff.
--                                CanvasElement
--                             -> CanvasElement
--                             -> Point
--                             -> Eff eff Unit

-- creates a new CanvasElement, not attached to the DOM and thus not visible
-- foreign import newCanvas :: forall eff.
--                             { w :: Number, h :: Number }
--                          -> Eff eff CanvasElement

foreign import clearCanvas :: forall eff. CanvasElement -> Eff eff Unit

-- set an event to fire on the given button id
foreign import buttonEvent :: String
                           -> Event Unit

-- foreign import canvasDragImpl :: CanvasElement -> Event { during :: Nullable Point
--                                                         , total :: Nullable Point }

-- foreign import canvasEvent :: String -> CanvasElement -> Event Point

foreign import setViewUI :: forall eff. String -> Eff eff Unit

type View = { lHand :: ChrId, rHand :: ChrId }

type ZipperRange a =
  { left  :: List a
  , focus :: List a
  , right :: List a
  }

zipSlideLeft :: forall a.
                ZipperRange a
             -> ZipperRange a
zipSlideLeft zr@{left, focus, right} = case List.uncons left, List.unsnoc focus of
    Nothing, _  -> zr
    _ , Nothing -> zr
    Just l, Just f ->
      let left'  = l.tail
          focus' = l.head : f.init
          right' = f.last : right
      in {left: left', focus: focus', right: right'}

zipSlideRight :: forall a.
                 ZipperRange a
              -> ZipperRange a
zipSlideRight zr@{left, focus, right} = case List.uncons focus, List.uncons right of
    Nothing, _  -> zr
    _ , Nothing -> zr
    Just f, Just r ->
      let left'  = f.head : left
          focus' = f.tail <> List.singleton r.head
          right' = r.tail
      in {left: left', focus: focus', right: right'}

zipZoomIn :: forall a.
             ZipperRange a
          -> ZipperRange a
zipZoomIn zr@{left, focus, right} = case List.uncons focus of
  Nothing -> zr
  Just {head, tail} -> case List.unsnoc tail of
    Nothing -> zr
    Just {init, last} ->
      let left'  = head : left
          focus' = init
          right' = last : right
      in {left: left', focus: focus', right: right'}

zipZoomOut :: forall a.
              ZipperRange a
           -> ZipperRange a
zipZoomOut zr@{left, focus, right} = case List.uncons left, List.uncons right of
  Nothing, Nothing -> zr
  Nothing, Just r ->
    let focus' = focus <> List.singleton r.head
        right' = r.tail
    in zr { focus = focus', right = right' }
  Just l, Nothing ->
    let left' = l.tail
        focus' = l.head : focus
    in zr { focus = focus', left = left' }
  Just l, Just r ->
    let left' = l.tail
        focus' = l.head : focus <> List.singleton r.head
        right' = r.tail
    in { left: left', focus: focus', right: right' }

focusArray :: forall a.
              ZipperRange a
           -> Array a
focusArray {focus} = Array.fromFoldable focus

unfocusArray :: forall a.
                Array a
             -> ZipperRange a
unfocusArray arr = { left: Nil
                   , focus: List.fromFoldable arr
                   , right: Nil
                   }

data UpdateView =
    GoLeft
  | GoRight
  | Out
  | In
  | NoOp

btnScroll :: Event UpdateView
btnScroll = const GoLeft  <$> buttonEvent "scrollLeft" <|>
            const GoRight <$> buttonEvent "scrollRight"

btnZoom :: Event UpdateView
btnZoom = const Out <$> buttonEvent "zoomOut" <|>
          const In  <$> buttonEvent "zoomIn"

btnUpdateView :: Event UpdateView
btnUpdateView = btnScroll <|> btnZoom <|> (const NoOp <$> buttonEvent "redraw")

mkFoldView :: UpdateView
           -> ZipperRange ChrId
           -> ZipperRange ChrId
mkFoldView uv zr = case uv of
  GoLeft  -> zipSlideLeft zr
  GoRight -> zipSlideRight zr
  Out     -> zipZoomOut zr
  In      -> zipZoomIn zr
  NoOp    -> zr

chrZREvent :: Array ChrId
           -> Event UpdateView
           -> Event (ZipperRange ChrId)
chrZREvent chrs uv = Event.fold mkFoldView uv (unfocusArray chrs)

chrsArrayEvent :: Event (ZipperRange ChrId)
               -> Event (Array ChrId)
chrsArrayEvent = map (Array.fromFoldable <<< _.focus)

drawingEvent :: { min :: Number, max :: Number }
             -> { width :: Pixels, height :: Pixels, padding :: Pixels, yOffset :: Pixels }
             -> { gwas  :: Map ChrId (List _)
                , annots :: Map ChrId (List _) }
             -> Event (Array ChrId)
             -> Event (Drawing)
drawingEvent s box dat = let dd = drawDemo s 0.25 box dat
                         in map dd

main :: Eff _ _
main = launchAff do

  canvas <- liftEff $ unsafePartial $ fromJust <$> getCanvasElementById "canvas"
  ctx <- liftEff $ getContext2D canvas

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

  let height = h
      offset = 0.0
      yInfo = { height, offset }

      chrIds = mouseChrIds

  let viewEvent = chrsArrayEvent $ chrZREvent mouseChrIds btnUpdateView

  void $ liftEff $ Event.subscribe viewEvent
       (\arr -> do
           let l = fromMaybe "N/A" $ show <$> Array.head arr
               r = fromMaybe "N/A" $ show <$> Array.last arr
           setViewUI $ l <> "\tto\t" <> r)

  dat <- getDataDemo { gwas: "./gwas.json"
                     , annots: "./annots_fake.json" }

  let sizes = {width: w, height: h, padding: 10.0, yOffset: 5.0}
      score = {min: 0.125, max: 0.42}

  let ev' = drawingEvent score sizes dat viewEvent
      bg = filled (fillColor white) $ rectangle 0.0 0.0 w h

  void $ liftEff $ Event.subscribe ev' (\d -> Drawing.render ctx (bg <> d))


and this

and this

module Model where

import Prelude

import Data.Foreign
import Data.Foreign.Class

type ArticleId = Int

data Page = BlogPage  | AboutPage | PongPage

type BlogState = {articles :: Array {title :: String, contents :: String, id :: ArticleId}}

data Article = Article {contents :: String, visible :: Boolean, title :: String, id :: ArticleId}

initialPage :: Page
initialPage = BlogPage

initialBlog :: BlogState
initialBlog = {articles : []}

initialArticle :: ArticleId -> String -> String -> Article
initialArticle i t c =
  Article {title : t, visible : false, contents : c, id : i}

instance articleIsForeign :: IsForeign Article where
  read value = do
    id <- readProp "id" value
    title <- readProp "title" value
    contents <- readProp "content" value
    pure $ Article {contents: contents, visible: false, title: title, id: id}

module Model where

import Prelude

import Data.Foreign
import Data.Foreign.Class

type ArticleId = Int

data Page = BlogPage  | AboutPage | PongPage

type Blog = {articles :: Array {title :: String, contents :: String, id :: ArticleId}}

data Article = Article {contents :: String, visible :: Boolean, title :: String, id :: ArticleId}

initialPage :: Page
initialPage = BlogPage

initialBlog :: Blog
initialBlog = {articles : []}

initialArticle :: ArticleId -> String -> String -> Article
initialArticle i t c =
  Article {title : t, visible : false, contents : c, id : i}

instance articleIsForeign :: IsForeign Article where
  read value = do
    id <- readProp "id" value
    title <- readProp "title" value
    contents <- readProp "content" value
    pure $ Article {contents: contents, visible: false, title: title, id: id}


Reset score

Reset score

module Pong where

import Prelude
import CSS (green)
import Control.Category ((<<<))
import Control.Monad.Eff (Eff)
import Data.Maybe (Maybe(..))
import Graphics.Canvas (clearRect, getContext2D, getCanvasElementById, CANVAS)
import Graphics.Drawing (fillColor, Drawing, render, rectangle, filled, black)

type BatState = {pos :: Number, dir :: Move}

type BallState = { x :: Number, y :: Number, dir :: BallDir }

data DirX = Left | Right
data DirY = Up | Down
data BallDir = BallDir DirX DirY

newtype PongState = PongState { p1 :: BatState
                              , p2 :: BatState
                              , ball :: BallState
                              , score :: {one :: Int, two :: Int}}

data Player = One | Two
data Move = Direction DirY | Stop
data PongCommand = MovePlayer {player :: Player, move :: Move} | Step

newRound :: forall t10.
  t10
  -> { p1 :: BatState
     , p2 :: BatState
     , ball :: BallState
     , score :: t10
     }
newRound score = { p1: {pos:0.0, dir: Stop}
                 , p2: {pos:0.0, dir: Stop}
                 , ball: {x: 10.0, y: 10.0, dir: BallDir Right Down}
                 , score: score}

initial :: PongState
initial = PongState  (newRound {one: 0, two: 0})

sendCommand :: PongCommand -> PongState -> PongState
sendCommand (MovePlayer {player, move}) (PongState s) = PongState (
   case player of
     One -> s {p1 = s.p1 {dir = move}}
     Two -> s {p2 = s.p2 {dir = move}})

sendCommand Step (PongState s) = PongState (
  updateScore (s { p1 = updateBat s.p1
    , p2 = updateBat s.p2
    , ball = updateBall s}))

updateScore :: { ball :: { x :: Number
          , y :: Number
          , dir :: BallDir
          }
, score :: { one :: Int
           , two :: Int
           }
, p1 :: { pos :: Number
        , dir :: Move
        }
, p2 :: { pos :: Number
        , dir :: Move
        }
}
-> { p1 :: { pos :: Number
           , dir :: Move
           }
   , p2 :: { pos :: Number
           , dir :: Move
           }
   , ball :: { x :: Number
             , y :: Number
             , dir :: BallDir
             }
   , score :: { one :: Int
              , two :: Int
              }
   }
updateScore s
  | s.ball.x + ballSize.w > canvasSize.w = newRound { one: s.score.one + 1
                                                    , two: s.score.two}
  | s.ball.x < 0.0 = newRound {one: s.score.one
                            , two: s.score.two + 1}
  | otherwise = s

updateBall :: forall g .
  { ball :: BallState
  , p1 :: BatState
  , p2 :: BatState
  | g
  }
  -> BallState
updateBall {p1, p2, ball:ball@{x, y, dir:(BallDir dx dy)}} =
  let nx = newX in
  let ny = newY in
  ball { x = nx.p
       , y = ny.p
       , dir = BallDir nx.d ny.d}
  where
    s = 5.0
    f :: forall d . (d -> d) -> Number -> Number -> (Number -> Boolean) -> d -> {p :: Number, d :: d}
    f flip o n c d =
         if (c n)
         then {p: o, d: flip d}
         else {p: n, d: d}
    fX = f flipX x
    fY = f flipY y
    newX = case dx of
      Left ->
        fX (x - s) (\p -> p <= batSize.w && y >= p1.pos && y <= p1.pos + batSize.h) Left
      Right -> fX (x + s) (\p -> p + ballSize.w >= canvasSize.w - batSize.w && y >= p2.pos && y <= p2.pos + batSize.h) Right
    newY = case dy of
      Up ->
        fY (y - s) (\p -> p <= 0.0) Up
      Down -> fY (y + s) (\p -> p + ballSize.h >= canvasSize.h) Down

flipX :: DirX -> DirX
flipX Left = Right
flipX Right = Left

flipY :: DirY -> DirY
flipY Up = Down
flipY Down = Up

updateBat :: BatState -> BatState
updateBat bs@{pos, dir} =
  let s = 5.0 in
  case dir of
    Stop -> bs
    Direction Up -> bs {pos = pos - s}
    Direction Down -> bs {pos = pos + s}

renderPong :: String -> PongState -> Eff (canvas :: CANVAS) Unit
renderPong id (PongState s) =  do
  mCanvas <- getCanvasElementById id
  case mCanvas of
    Just canvas -> do
      ctx <- getContext2D canvas
      clearRect ctx {x: 0.0, y: 0.0, w: canvasSize.w, h: canvasSize.h}
      render ctx $ batDrawing 0.0 s.p1.pos
      render ctx $ batDrawing (canvasSize.w - batSize.w) s.p2.pos
      render ctx $ ballDrawing s.ball
      pure unit
    Nothing -> pure unit

batDrawing :: Number -> Number -> Drawing
batDrawing x y = filled (fillColor black) (rectangle x y batSize.w batSize.h)

ballDrawing :: BallState -> Drawing
ballDrawing {x, y} = filled (fillColor green) (rectangle x y ballSize.w ballSize.h)

type Dimension = {h :: Number, w :: Number}

canvasSize :: Dimension
canvasSize = {h: 300.0, w: 500.0}

batSize :: Dimension
batSize = {h: 70.0, w: 10.0}

ballSize :: Dimension
ballSize = {h: 20.0, w: 20.0}

module Pong where

import Prelude
import CSS (green)
import Control.Monad.Eff (Eff)
import Data.Maybe (Maybe(..))
import Graphics.Canvas (clearRect, getContext2D, getCanvasElementById, CANVAS)
import Graphics.Drawing (fillColor, Drawing, render, rectangle, filled, black)

type BatState = {pos :: Number, dir :: Move}

type BallState = { x :: Number, y :: Number, dir :: BallDir }

data DirX = Left | Right
data DirY = Up | Down
data BallDir = BallDir DirX DirY

newtype PongState = PongState { p1 :: BatState
                              , p2 :: BatState
                              , ball :: BallState}

data Player = One | Two
data Move = Direction DirY | Stop
data PongCommand = MovePlayer {player :: Player, move :: Move} | Step

initial :: PongState
initial = PongState {p1: {pos:0.0, dir: Stop}, p2: {pos:0.0, dir: Stop}, ball: {x: 10.0, y: 10.0, dir: BallDir Right Down}}

sendCommand :: PongCommand -> PongState -> PongState
sendCommand (MovePlayer {player, move}) (PongState s) = PongState (
   case player of
     One -> s {p1 = s.p1 {dir = move}}
     Two -> s {p2 = s.p2 {dir = move}})

sendCommand Step (PongState s) = PongState (
  s { p1 = updateBat s.p1
    , p2 = updateBat s.p2
    , ball = updateBall s})

updateBall :: forall g .
  { ball :: BallState
  , p1 :: BatState
  , p2 :: BatState
  | g
  }
  -> BallState
updateBall {p1, p2, ball:ball@{x, y, dir:(BallDir dx dy)}} =
  let nx = newX in
  let ny = newY in
  ball { x = nx.p
       , y = ny.p
       , dir = BallDir nx.d ny.d}
  where
    s = 5.0
    f :: forall d . (d -> d) -> Number -> Number -> (Number -> Boolean) -> d -> {p :: Number, d :: d}
    f flip o n c d =
         if (c n)
         then {p: o, d: flip d}
         else {p: n, d: d}
    fX = f flipX x
    fY = f flipY y
    newX = case dx of
      Left ->
        fX (x - s) (\p -> p <= batSize.w && y >= p1.pos && y <= p1.pos + batSize.h) Left
      Right -> fX (x + s) (\p -> p + ballSize.w >= canvasSize.w - batSize.w && y >= p2.pos && y <= p2.pos + batSize.h) Right
    newY = case dy of
      Up ->
        fY (y - s) (\p -> p <= 0.0) Up
      Down -> fY (y + s) (\p -> p + ballSize.h >= canvasSize.h) Down

flipX :: DirX -> DirX
flipX Left = Right
flipX Right = Left

flipY :: DirY -> DirY
flipY Up = Down
flipY Down = Up

updateBat :: BatState -> BatState
updateBat bs@{pos, dir} =
  let s = 5.0 in
  case dir of
    Stop -> bs
    Direction Up -> bs {pos = pos - s}
    Direction Down -> bs {pos = pos + s}

renderPong :: String -> PongState -> Eff (canvas :: CANVAS) Unit
renderPong id (PongState s) =  do
  mCanvas <- getCanvasElementById id
  case mCanvas of
    Just canvas -> do
      ctx <- getContext2D canvas
      clearRect ctx {x: 0.0, y: 0.0, w: canvasSize.w, h: canvasSize.h}
      render ctx $ batDrawing 0.0 s.p1.pos
      render ctx $ batDrawing (canvasSize.w - batSize.w) s.p2.pos
      render ctx $ ballDrawing s.ball
      pure unit
    Nothing -> pure unit

batDrawing :: Number -> Number -> Drawing
batDrawing x y = filled (fillColor black) (rectangle x y batSize.w batSize.h)

ballDrawing :: BallState -> Drawing
ballDrawing {x, y} = filled (fillColor green) (rectangle x y ballSize.w ballSize.h)

type Dimension = {h :: Number, w :: Number}

canvasSize :: Dimension
canvasSize = {h: 300.0, w: 500.0}

batSize :: Dimension
batSize = {h: 70.0, w: 10.0}

ballSize :: Dimension
ballSize = {h: 20.0, w: 20.0}


Corrected license notice image (#1879)

Corrected license notice image (#1879)

{-
Copyright 2017 SlamData, Inc.

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

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

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

module SlamData.Dialog.License where

import SlamData.Prelude

import Halogen.HTML as H
import Halogen.HTML.Properties as HP

import SlamData.Render.ClassName as CN
import SlamData.Dialog.Render as DR

data LaunchedBy = App | Other

advancedLicenseExpired ∷ ∀ f p. H.HTML p (f Unit)
advancedLicenseExpired =
  H.div
    [ HP.classes [ H.ClassName "deck-dialog", H.ClassName "license-dialog" ] ]
    [ H.div_
        [ H.img [ HP.src "img/logo-center.svg" ]
        , DR.modalHeader "Your license has expired"
        , DR.modalBody
            $ H.div_
                [ H.p_
                    [ H.text "Thanks for using SlamData Advanced!" ]
                , H.p_
                    [ H.text "Get in touch with us today to purchase SlamData Advanced or an extended trial period with raining for your team, configuration and optimization assistance and support ith queries, sharing and distribution." ]
              ]
        , DR.modalFooter
            [ H.a
                [ HP.classes [ CN.btn, CN.btnPrimary ]
                , HP.href "https://slamdata.com/contact-us/"
                ]
                [ H.text "Contact SlamData" ]
            , H.a
                [ HP.classes [ CN.btn, CN.btnDefault ]
                , HP.href "https://slamdata.com/slamdata-jump-start/"
                ]
                [ H.text "Request training" ]
            ]
        ]
  ]

advancedTrialLicenseExpired ∷ ∀ f p. H.HTML p (f Unit)
advancedTrialLicenseExpired =
  H.div
    [ HP.classes [ H.ClassName "deck-dialog", H.ClassName "license-dialog" ] ]
    [ H.div_
        [ H.img [ HP.src "img/logo-center.svg" ]
        , DR.modalHeader "Your trial has expired"
        , DR.modalBody
            $ H.div_
                [ H.p_
                    [ H.text "Thanks for trying SlamData Advanced!" ]
                , H.p_
                    [ H.text "Get in touch with us today to purchase a SlamData license or an extended trial period with training for your team, configuration, query optimization and support." ]
              ]
        , DR.modalFooter
            [ H.a
                [ HP.classes [ CN.btn, CN.btnPrimary ]
                , HP.href "https://slamdata.com/contact-us/"
                ]
                [ H.text "Contact SlamData" ]
            , H.a
                [ HP.classes [ CN.btn, CN.btnDefault ]
                , HP.href "https://slamdata.com/slamdata-jump-start/"
                ]
                [ H.text "Request training" ]
            ]
        ]
  ]

licenseInvalid ∷ ∀ f p. H.HTML p (f Unit)
licenseInvalid =
  H.div
    [ HP.classes [ H.ClassName "deck-dialog", H.ClassName "license-dialog" ] ]
    [ H.div_
        [ H.img [ HP.src "img/logo-center.svg" ]
        , DR.modalHeader "Your license is invalid"
        , DR.modalBody
            $ H.div_
                [ H.p_
                    [ H.text
                        $ "Try double checking your license information and "
                        <> howToFix App
                        <> " before restarting SlamData. If you are still experiencing problems with your license after trying this please contact support." ]
              ]
        , DR.modalFooter
            [ H.a
                [ HP.classes [ CN.btn, CN.btnPrimary ]
                , HP.href "https://slamdata.com/contact-us/"
                ]
                [ H.text "Contact SlamData" ]
            , H.a
                [ HP.classes [ CN.btn, CN.btnDefault ]
                , HP.href "https://slamdata.com/slamdata-jump-start/"
                ]
                [ H.text "Request training" ]
            ]
        ]
    ]
  where
  howToFix ∷ LaunchedBy → String
  howToFix = case _ of
    App → "reinstalling"
    Other → "providing your Java system properties"

{-
Copyright 2017 SlamData, Inc.

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

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

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

module SlamData.Dialog.License where

import SlamData.Prelude

import Halogen.HTML as H
import Halogen.HTML.Properties as HP

import SlamData.Render.ClassName as CN
import SlamData.Dialog.Render as DR

data LaunchedBy = App | Other

advancedLicenseExpired ∷ ∀ f p. H.HTML p (f Unit)
advancedLicenseExpired =
  H.div
    [ HP.classes [ H.ClassName "deck-dialog", H.ClassName "license-dialog" ] ]
    [ H.div_
        [ H.img [ HP.src "img/features.png" ]
        , DR.modalHeader "Your license has expired"
        , DR.modalBody
            $ H.div_
                [ H.p_
                    [ H.text "Thanks for using SlamData Advanced!" ]
                , H.p_
                    [ H.text "Get in touch with us today to purchase SlamData Advanced or an extended trial period with raining for your team, configuration and optimization assistance and support ith queries, sharing and distribution." ]
              ]
        , DR.modalFooter
            [ H.a
                [ HP.classes [ CN.btn, CN.btnPrimary ]
                , HP.href "https://slamdata.com/contact-us/"
                ]
                [ H.text "Contact SlamData" ]
            , H.a
                [ HP.classes [ CN.btn, CN.btnDefault ]
                , HP.href "https://slamdata.com/slamdata-jump-start/"
                ]
                [ H.text "Request training" ]
            ]
        ]
  ]

advancedTrialLicenseExpired ∷ ∀ f p. H.HTML p (f Unit)
advancedTrialLicenseExpired =
  H.div
    [ HP.classes [ H.ClassName "deck-dialog", H.ClassName "license-dialog" ] ]
    [ H.div_
        [ H.img [ HP.src "img/features.png" ]
        , DR.modalHeader "Your trial has expired"
        , DR.modalBody
            $ H.div_
                [ H.p_
                    [ H.text "Thanks for trying SlamData Advanced!" ]
                , H.p_
                    [ H.text "Get in touch with us today to purchase a SlamData license or an extended trial period with training for your team, configuration, query optimization and support." ]
              ]
        , DR.modalFooter
            [ H.a
                [ HP.classes [ CN.btn, CN.btnPrimary ]
                , HP.href "https://slamdata.com/contact-us/"
                ]
                [ H.text "Contact SlamData" ]
            , H.a
                [ HP.classes [ CN.btn, CN.btnDefault ]
                , HP.href "https://slamdata.com/slamdata-jump-start/"
                ]
                [ H.text "Request training" ]
            ]
        ]
  ]

licenseInvalid ∷ ∀ f p. H.HTML p (f Unit)
licenseInvalid =
  H.div
    [ HP.classes [ H.ClassName "deck-dialog", H.ClassName "license-dialog" ] ]
    [ H.div_
        [ H.img [ HP.src "img/features.png" ]
        , DR.modalHeader "Your license is invalid"
        , DR.modalBody
            $ H.div_
                [ H.p_
                    [ H.text
                        $ "Try double checking your license information and "
                        <> howToFix App
                        <> " before restarting SlamData. If you are still experiencing problems with your license after trying this please contact support." ]
              ]
        , DR.modalFooter
            [ H.a
                [ HP.classes [ CN.btn, CN.btnPrimary ]
                , HP.href "https://slamdata.com/contact-us/"
                ]
                [ H.text "Contact SlamData" ]
            , H.a
                [ HP.classes [ CN.btn, CN.btnDefault ]
                , HP.href "https://slamdata.com/slamdata-jump-start/"
                ]
                [ H.text "Request training" ]
            ]
        ]
    ]
  where
  howToFix ∷ LaunchedBy → String
  howToFix = case _ of
    App → "reinstalling"
    Other → "providing your Java system properties"


Use a doc-comment for `withArray`

Use a doc-comment for `withArray`

-- | 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
  , withArray
  , emptySTArray
  , peekSTArray
  , pokeSTArray
  , pushSTArray
  , modifySTArray
  , pushAllSTArray
  , spliceSTArray
  , freeze, thaw
  , unsafeFreeze
  , toAssocArray
  ) where

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

import Data.Maybe (Maybe(..))
import Unsafe.Coerce (unsafeCoerce)

-- | 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 `Array a`,
-- | except that mutation is allowed.
foreign import data STArray :: Type -> Type -> Type

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

-- | **DEPRECATED**: Use `unsafeFreeze` together with `runST` instead.
-- |
-- | 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
  :: forall a r
   . (forall h. Eff (st :: ST h | r) (STArray h a))
  -> Eff r (Array a)

-- | Perform an effect requiring a mutable array on a copy of an immutable array,
-- | safely returning the result as an immutable array.
withArray
  :: forall a b r h
   . (STArray h a -> Eff (st :: ST h | r) b)
   -> Array a
   -> Eff (st :: ST h | r) (Array a)
withArray f xs = do
  result <- thaw xs
  _ <- f result
  unsafeFreeze result

-- | O(1). Convert a mutable array to an immutable array, without copying. The mutable
-- | array must not be mutated afterwards.
unsafeFreeze :: forall a r h. STArray h a -> Eff (st :: ST h | r) (Array a)
unsafeFreeze = pure <<< (unsafeCoerce :: STArray h a -> Array a)

-- | Create an empty mutable array.
foreign import emptySTArray :: forall a h r. Eff (st :: ST h | r) (STArray h a)

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

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

foreign import copyImpl :: forall a b h r. a -> Eff (st :: ST h | r) b

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

foreign import peekSTArrayImpl
  :: forall a h e r
   . (a -> r)
  -> r
  -> (STArray h a)
  -> Int
  -> (Eff (st :: ST h | e) r)

-- | Change the value at the specified index in a mutable array.
foreign import pokeSTArray
  :: forall a h r
   . STArray h a -> Int -> a -> Eff (st :: ST h | r) Boolean

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

-- | Append the values in an immutable array to the end of a mutable array.
foreign import pushAllSTArray
  :: forall a h r
   . STArray h a
  -> Array a
  -> Eff (st :: ST h | r) Int

-- | Mutate the element at the specified index using the supplied function.
modifySTArray :: forall a h r. STArray h a -> Int -> (a -> a) -> Eff (st :: ST h | r) Boolean
modifySTArray xs i f = do
  entry <- peekSTArray xs i
  case entry of
    Just x  -> pokeSTArray xs i (f x)
    Nothing -> pure false

-- | Remove and/or insert elements from/into a mutable array at the specified index.
foreign import spliceSTArray
  :: forall a h r
   . STArray h a
  -> Int
  -> Int
  -> Array a
  -> Eff (st :: ST h | r) (Array a)

-- | Create an immutable copy of a mutable array, where each element
-- | is labelled with its index in the original array.
foreign import toAssocArray
  :: forall a h r
   . STArray h a
  -> Eff (st :: ST h | r) (Array (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
  , withArray
  , emptySTArray
  , peekSTArray
  , pokeSTArray
  , pushSTArray
  , modifySTArray
  , pushAllSTArray
  , spliceSTArray
  , freeze, thaw
  , unsafeFreeze
  , toAssocArray
  ) where

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

import Data.Maybe (Maybe(..))
import Unsafe.Coerce (unsafeCoerce)

-- | 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 `Array a`,
-- | except that mutation is allowed.
foreign import data STArray :: Type -> Type -> Type

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

-- | **DEPRECATED**: Use `unsafeFreeze` together with `runST` instead.
-- |
-- | 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
  :: forall a r
   . (forall h. Eff (st :: ST h | r) (STArray h a))
  -> Eff r (Array a)

-- Perform an effect requiring a mutable array on a copy of an immutable array,
-- safely returning the result as an immutable array.
withArray
  :: forall a b r h
   . (STArray h a -> Eff (st :: ST h | r) b)
   -> Array a
   -> Eff (st :: ST h | r) (Array a)
withArray f xs = do
  result <- thaw xs
  _ <- f result
  unsafeFreeze result

-- | O(1). Convert a mutable array to an immutable array, without copying. The mutable
-- | array must not be mutated afterwards.
unsafeFreeze :: forall a r h. STArray h a -> Eff (st :: ST h | r) (Array a)
unsafeFreeze = pure <<< (unsafeCoerce :: STArray h a -> Array a)

-- | Create an empty mutable array.
foreign import emptySTArray :: forall a h r. Eff (st :: ST h | r) (STArray h a)

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

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

foreign import copyImpl :: forall a b h r. a -> Eff (st :: ST h | r) b

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

foreign import peekSTArrayImpl
  :: forall a h e r
   . (a -> r)
  -> r
  -> (STArray h a)
  -> Int
  -> (Eff (st :: ST h | e) r)

-- | Change the value at the specified index in a mutable array.
foreign import pokeSTArray
  :: forall a h r
   . STArray h a -> Int -> a -> Eff (st :: ST h | r) Boolean

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

-- | Append the values in an immutable array to the end of a mutable array.
foreign import pushAllSTArray
  :: forall a h r
   . STArray h a
  -> Array a
  -> Eff (st :: ST h | r) Int

-- | Mutate the element at the specified index using the supplied function.
modifySTArray :: forall a h r. STArray h a -> Int -> (a -> a) -> Eff (st :: ST h | r) Boolean
modifySTArray xs i f = do
  entry <- peekSTArray xs i
  case entry of
    Just x  -> pokeSTArray xs i (f x)
    Nothing -> pure false

-- | Remove and/or insert elements from/into a mutable array at the specified index.
foreign import spliceSTArray
  :: forall a h r
   . STArray h a
  -> Int
  -> Int
  -> Array a
  -> Eff (st :: ST h | r) (Array a)

-- | Create an immutable copy of a mutable array, where each element
-- | is labelled with its index in the original array.
foreign import toAssocArray
  :: forall a h r
   . STArray h a
  -> Eff (st :: ST h | r) (Array (Assoc a))