Periodically Demo

Main.purs

module Main where

import Prelude

import Concur.Core.Types (Widget)
import Concur.Core.FRP (Signal, hold, dyn, display, loopW, loopS)
import Concur.React (HTML)
import Concur.React.DOM (div') as D
import Concur.React.Props as P
import Concur.React.SVG as S
import Concur.React.Run (runWidgetInDom)
import Data.Array (filter, fromFoldable, length)
import Data.Function.Uncurried (runFn2)
import Data.Int (round, toNumber)
import Data.Map (Map, empty, insert, values, lookup)
import Data.Maybe (Maybe (..), fromMaybe, maybe)
import Data.Time.Duration (Milliseconds(..))
import Data.Traversable (minimum)
import Data.Tuple.Nested ((/\), type (/\))
import Effect (Effect)
import Effect.Aff (Aff, delay)
import Effect.Aff.Class (liftAff)
import Math (cos, sin)
import Prim.Row (class Lacks, class Cons, class Nub, class Union)
import Prim.RowList (Cons, Nil, kind RowList)
import Record (get, delete,merge)
import Record (insert) as Record
import Record.Extra (class MapRecord, class SequenceRecord, class ZipRecord, class Keys, sequenceRecord, mapRecord, zipRecord, pickFn, keys)
import Type.Prelude (class IsSymbol, class RowToList, RLProxy(RLProxy), SProxy(SProxy), reflectSymbol)

-- | Geometric SVG Setup

type Color = String
type Coord = Int /\ Int
type Line = { ptA :: Coord, ptB :: Coord, color :: Color}

black = "#000000" :: Color
blue = "#0000FF" :: Color
red = "#FF0000" :: Color
green = "#00FF00" :: Color

line :: forall a. Line ->  Widget HTML a
line {ptA: x1/\y1, ptB: x2/\y2, color} = 
  S.line  [ P.unsafeMkProp "x1" x1
              , P.unsafeMkProp "y1" y1
              , P.unsafeMkProp "x2" x2
              , P.unsafeMkProp "y2" y2
              , P.stroke color
              ]
        [] 

type Angle = Number

rot :: Coord -> Angle -> Coord -> Coord
rot (cx/\cy) a (x/\y) =
  let ncx/\ncy = toNumber cx /\ toNumber cy
      nx/\ny = toNumber x /\ toNumber y
  in (round $ ncx + (nx-ncx) * cos a - (ny-ncy) * sin a)
  /\  (round $ ncy + (nx-ncx) * sin a + (ny-ncy) * cos a)

lines :: forall a. Color -> Int -> Coord -> Angle -> Array (Widget HTML a)
lines color t0 pt1 a1 =
  let pt2 = (50)/\50
      pt3 = (100)/\50
      pt4 = (50)/\100
      r = rot pt1 a1
      t (x/\y) = (x+t0)/\y
      ptA = t $r pt2
      ptB = t $r pt3
      ptC = t $ r pt4
  in [ line { ptA
            , ptB
            , color
            }
      , line  { ptA
              , ptB: ptC
              , color
              }      
      , line  { ptA: ptC
              , ptB
              , color
              }      
      ]
      
-- | End of Geometric SVG Setup

-- | Library

class HomogeneousRecord (row ∷ # Type) (list ∷ RowList) a | list → row
  where
    toMapImpl ∷ RLProxy list → Record row → Map String a

instance homogeneousRecordNil ∷ HomogeneousRecord () Nil a where
  toMapImpl _ _ = empty

instance homogeneousRecordCons ∷
  ( RowToList row list
  , IsSymbol l
  , Lacks l row'
  , Cons l a row' row
  , RowToList row' list'
  , HomogeneousRecord row' list' a
  )
  ⇒ HomogeneousRecord row (Cons l a list') a where
  toMapImpl _ record = insert key value (toMapImpl (RLProxy ∷ RLProxy list') record')
    where
      keyS = SProxy ∷ SProxy l
      key = reflectSymbol keyS
      value = get keyS record
      record' :: Record row'
      record' = delete keyS record

toMap ∷ ∀ row list a
           . RowToList row list
           ⇒ HomogeneousRecord row list a
           ⇒ Record row
           → Map String a
toMap = toMapImpl (RLProxy :: RLProxy list)

minPos :: forall p ps
  . RowToList p ps
  => HomogeneousRecord p ps Number 
  => Record p -> Number
minPos onset = 
  fromMaybe 0.0 $ minimum $ filter (not <<< (_ == 0.0)) 
                $ fromFoldable $ values $ toMap onset  

modulo :: Number -> Number -> Number
modulo x m  | x < 0.0   = modulo (x + m) m
            | x >= m    = modulo (x - m) m
            | otherwise = x

allNaught :: forall rec rs seq ss ms. 
    RowToList ms ss
    => SequenceRecord ss ms () seq Maybe 
    => RowToList rec rs
    => MapRecord rs rec Number (Maybe Boolean) () ms 
    => Record rec -> Boolean
allNaught rec =
  let m = sequenceRecord
            $ mapRecord (\v -> 
                if v == 0.0
                  then Just true
                  else Nothing) rec
    in maybe false (const true) m 

filterNaught :: forall ms from to
  . RowToList from ms 
  => Keys ms
  => HomogeneousRecord from ms Number
  => Record from -> Record to /\ Int
filterNaught rec = 
  let m = toMap rec
      ks = fromFoldable $ keys rec
      fs = filter (\k -> maybe false (_ == 0.0) $ lookup k m) ks
    in runFn2 pickFn fs rec /\ length fs
      
trim :: forall ms ss seq rec zs z rs
  . RowToList ms ss
  => SequenceRecord ss ms () seq Maybe 
  => MapRecord rs rec Number (Maybe Boolean) () ms
  => HomogeneousRecord rec rs Number 
  => RowToList rec rs
  => HomogeneousRecord rec rs Number 
  => RowToList z zs 
  => MapRecord zs z (Number /\ Number) Number () rec
  => ZipRecord rs rec rs rec () z
  => Record rec -> Record rec -> Record rec /\ Number
trim period onset =
  if allNaught onset
      then trim period period
  else 
    let mp = minPos period
        mo = minPos onset
        m = min mp mo
    in 
      mapRecord (\(o/\p) -> modulo (o - m) p) (zipRecord onset period)
     /\ m

select :: forall mask ms from to
  . RowToList mask ms 
  => Keys ms
  => Record mask -> Record from -> Record to
select mask from = 
  runFn2 pickFn (fromFoldable $ keys mask) from

class Applyable fs rf xs rx ry | -> ry where
  recordApply' :: Number -> RLProxy fs -> Record rf -> RLProxy xs -> Record rx -> Record ry
 
instance applyNil 
  :: Applyable Nil rf Nil ry ry where
  recordApply' _ _ _ _ rec = rec
  
instance applyCons ::
  ( IsSymbol k
  , Applyable fst rft xst rxt ryt
  , Cons k xtyp rxt rx
  , Lacks k rxt
  , Cons k (xtyp -> Number -> ytyp) rft rf
  , Lacks k rft
  , Cons k ytyp ryt ry
  , Lacks k ryt
  ) => Applyable (Cons k (xtyp -> Number -> ytyp) fst) rf 
                 (Cons k xtyp xst) rx ry where
  recordApply' n fs recf xs recx =
    let nextf = delete (SProxy :: _ k) recf :: Record rft
        nextx = delete (SProxy :: _ k) recx :: Record rxt
        itr = recordApply' n (RLProxy :: RLProxy fst) nextf 
                           (RLProxy :: RLProxy xst) nextx :: Record ryt
    in Record.insert (SProxy :: _ k) 
              (get (SProxy :: _ k) recf (get (SProxy :: _ k) recx) n) itr :: Record ry

recordApply
  :: forall fs rf xs rx ry 
   . Applyable fs rf xs rx ry 
   => RowToList rf fs
   => RowToList rx xs
   => Number -> Record rf -> Record rx -> Record ry
recordApply n recf recx = recordApply' n (RLProxy :: RLProxy fs) recf 
                                     (RLProxy :: RLProxy xs) recx

periodically :: forall r p ps z zs s ss ms seq mss f fs affs affss affseq s'
  . RowToList ms mss 
  => SequenceRecord mss ms () seq Maybe 
  => MapRecord ps p Number (Maybe Boolean) () ms 
  => HomogeneousRecord p ps Number 
  => RowToList p ps 
  => RowToList z zs 
  => MapRecord zs z (Number /\ Number) Number () p
  => ZipRecord ps p ps p () z
  => Keys ps
  => RowToList affs affss 
  => SequenceRecord affss affs () affseq Aff 
  => Applyable fs f ss s affs
  => RowToList f fs
  => RowToList s ss 
  => Union s s s'
  => Nub s' s
  => Record f -> Record p -> { sample :: Record s, period :: Record p | r} 
    -> Signal HTML { sample :: Record s, period :: Record p | r}

periodically fs period model = do
  let t /\ sn = trim period model.period
  let (zeroTags :: Record p) /\ n = filterNaught t
  if n > 0 
        then 
          do
            updated <- hold (select zeroTags model.sample) 
                  $ liftAff
                  $ select zeroTags 
                           <$> 
                           (sequenceRecord $ 
                            recordApply (sn / toNumber n) fs
                               model.sample) 
                              
            pure model { sample = merge (updated :: Record s) model.sample
                       , period = t}
        else pure model {period = t}

-- | End of Library

-- | Initial solution

tickerSignal0 :: Int -> Number -> Signal HTML Int
tickerSignal0 t del = loopW t \t' -> do
  liftAff $ delay $ Milliseconds del
  pure $ 
    if t' < 400
      then t' + 2
      else 150

tickerSignal1 :: Angle -> Number -> Signal HTML Angle
tickerSignal1 r del = loopW r \r' -> do
  liftAff $ delay $ Milliseconds del
  pure $ r' - 0.1

widget1 :: forall a. Widget HTML a
widget1 = dyn $ do
  
  t <- tickerSignal0 0   15.0
  r <- tickerSignal1 0.0 12.0
  
  let init = { sample: { t, r}, period: { t: 0.0, r: 0.0} } 
  loopS init \model -> do
     
    m <- pure { sample: {t, r}, period: {t: 0.0, r}}
  
    display $ D.div'
      [S.svg [ P.width "500"
              , P.height "150"
              ]
        $ lines black m.sample.t (100/\100) m.sample.r
      ]
    pure m

widget2 :: forall a. Widget HTML a
widget2 = dyn $ do
  
  t <- tickerSignal0 0   15.0
  r <- tickerSignal1 0.0 22.0
  
  let init = { sample: { t, r}, period: { t: 0.0, r: 0.0} } 
  loopS init \model -> do
   
    m <- pure { sample: {t, r}, period: {t: 0.0, r}}
  
    display $ D.div'
      [S.svg [ P.width "500"
              , P.height "150"
              ]
        $ lines black m.sample.t (100/\100) m.sample.r
      ]
    pure m

-- | End of Initial Solution

-- | New solution

type PAff a = a -> Number -> Aff a

type Update =   { t :: PAff Int, r :: PAff Angle }
type Movement = { t :: Int     , r :: Angle }
type Onset =    { t :: Number  , r :: Number }
  
type Model
  = { sample :: Movement 
    , period :: Onset
    }

tickerAff0 :: PAff Int
tickerAff0 t del = do
  delay $ Milliseconds del
  pure $ 
    if t < 400
      then t + 2
      else 150

tickerAff1 :: PAff Angle
tickerAff1 r del = do
  delay $ Milliseconds del
  pure $ r - 0.1

widget3 :: forall a. Widget HTML a
widget3 = dyn $ do
  
  let init = { sample: { t: 0, r: 0.0}, period: { t: 0.0, r: 0.0} } 
  loopS init \model -> do
  
    m <- periodically { t: tickerAff0, r: tickerAff1} { t: 15.0, r: 12.0} model
  
    display $ D.div'
      [S.svg [ P.width "500"
              , P.height "200"
              ]
        $ lines black m.sample.t (100/\100) m.sample.r
      ]
    pure m

main :: Effect Unit
main = runWidgetInDom "main" $
        D.div' 
          [ widget1
          , widget2
          , widget3
          ]