{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedLabels #-}
module Chart.Serve where
import Box
import Box.Socket
import Chart
import NumHask.Prelude
import Web.Rep
import Lucid as L
import Control.Lens
data SConfig =
SConfig
{ framerate :: Double,
runtime :: Double,
s1 :: Double,
s2 :: Double,
numglyphs :: Int
} deriving (Eq, Show, Generic)
repSConfig :: (Monad m) => SConfig -> SharedRep m SConfig
repSConfig s = SConfig <$> fr <*> mt <*> s1' <*> s2' <*> ng
where
fr = slider (Just "framerate") 1 200 1.0 (s ^. #framerate)
mt = slider (Just "runtime") 0 1 0.1 (s ^. #runtime)
s1' = slider (Just "s1") 0 1 0.1 (s ^. #s1)
s2' = slider (Just "s2") 0 1 0.1 (s ^. #s2)
ng = sliderI (Just "glyphs") 1 200 1 (s ^. #numglyphs)
totalFrames :: SConfig -> Int
totalFrames cfg = floor $ framerate cfg * runtime cfg
defaultSConfig :: SConfig
defaultSConfig = SConfig 20 10 1 1 100
run :: SConfig -> IO ()
run c = serveSend c (defaultAnimation c)
defaultAnimation :: SConfig -> Animation
defaultAnimation c = mconcat $
[ circle,
circles c,
frameStamp,
stdHud (Rect -1 1 -1 1)
]
circle_ :: Double -> Point Double
circle_ x = Point (sin (2 * pi * x)) (cos (2 * pi * x))
circle :: Animation
circle = Animation $ \x -> (mempty, [Chart (GlyphA defaultGlyphStyle) [PointXY (circle_ x)]])
scale_ :: Double -> Point Double -> Point Double
scale_ s (Point x y) = Point (x*s) (y*s)
circles :: SConfig -> Animation
circles c = Animation $ \x ->
(mempty,
[ Chart
(GlyphA defaultGlyphStyle)
(PointXY . (\s -> scale_ s (circle_ (power x))) <$> xs)])
where
xs = grid InnerPos (Range 0 1) (c ^. #numglyphs)
power x = (c ^. #s1) * x
serveSend :: SConfig -> Animation -> IO ()
serveSend cfg ani =
serveSocketBox defaultSocketConfig chartPage . Box mempty <$.> chartEmitter cfg ani
data Animation = Animation { freeze :: Double -> (HudOptions, [Chart Double]) }
instance Semigroup Animation where
(<>) a b = Animation (\x -> (freeze a x) <> (freeze b x))
instance Monoid Animation where
mempty = Animation (\_ -> (mempty,[]))
mappend = (<>)
frameStamp :: Animation
frameStamp = Animation $ \x -> (mempty & #hudTitles .~ [defaultTitle (fixed (Just 3) x)], [])
cleanHud :: Rect Double -> [Chart Double]
cleanHud r = runHudWith r r (fst $ makeHud r defaultHudOptions) [Chart BlankA [RectXY r]]
stdHud :: Rect Double -> Animation
stdHud r = Animation (\_ -> (mempty, cleanHud r))
square :: Point (Double -> Double -> Double) -> SConfig -> Animation
square (Point fx fy) c =
Animation (\x -> (mempty, [Chart (GlyphA defaultGlyphStyle) (PointXY <$> ps x)]))
where
ps x' = Point <$> (fx x' <$> xs) <*> (fy x' <$> xs)
xs = grid InnerPos (Range 0 1) (c ^. #numglyphs)
line :: Point (Double -> Double -> Double) -> SConfig -> Animation
line (Point fx fy) c =
Animation (\x -> (mempty, [Chart (GlyphA defaultGlyphStyle) (PointXY <$> ps x)]))
where
ps x' = zipWith Point (fx x' <$> xs) (fy x' <$> xs)
xs = grid InnerPos (Range 0 1) (c ^. #numglyphs)
chartEmitter :: SConfig -> Animation -> Cont IO (Emitter IO Text)
chartEmitter c ani =
fmap (outputText ani) <$> carousel c
outputText :: Animation -> Double -> Text
outputText ani x =
code (Replace "output"
(renderHudOptionsChart defaultSvgOptions (fst $ freeze ani x) [] (snd $ freeze ani x)))
carousel :: SConfig -> Cont IO (Emitter IO Double)
carousel cfg = delaylist ts xs
where
ts :: [Double]
ts = replicate (totalFrames cfg) (1/cfg ^. #framerate)
xs = grid InnerPos (Range 0 1) (totalFrames cfg)
delaylist :: [Double] -> [a] -> Cont IO (Emitter IO a)
delaylist ts xs = delay <$> fromListE ts <*> fromListE xs
delay :: Emitter IO Double -> Emitter IO a -> Emitter IO a
delay t e = Emitter $ do
t' <- emit t
e' <- emit e
fromMaybe (pure ()) (sleep <$> t')
pure e'
chartPage :: Page
chartPage =
bootstrapPage
<> socketPage
<> bodyPage
bodyPage :: Page
bodyPage =
mempty & #htmlBody
.~ divClass_
"container"
( mconcat
[ divClass_ "row" $ mconcat $ (\(t, h) -> divClass_ "col" (h2_ (toHtml t) <> L.with div_ [id_ t] h)) <$> [("output", mempty)]
]
)