chart-svg-various 0.0.1 → 0.0.2

raw patch · 2 files changed

+161/−5 lines, 2 filesdep ~boxdep ~box-csvdep ~box-socketPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: box, box-csv, box-socket, web-rep

API changes (from Hackage documentation)

Files

• chart-svg-various.cabal +6/−5
• src/Chart/Serve.hs +155/−0

@@ -1,6 +1,6 @@ cabal-version: 2.4 name:          chart-svg-various-version:       0.0.1+version:       0.0.2 synopsis: See readme.md description: See readme.md for description. category: project@@ -31,9 +31,9 @@     -Wredundant-constraints   build-depends:     base >=4.7 && <5,-    box >= 0.5 && < 0.6,-    box-csv >= 0.0.1 && < 0.1,-    box-socket >= 0.0.1 && < 0.1,+    box >= 0.6 && < 0.7,+    box-csv >= 0.0.2 && < 0.1,+    box-socket >= 0.0.2 && < 0.1,     chart-svg >= 0.1.1 && < 0.2,     concurrency >= 1.11,     foldl >= 1.4,@@ -47,8 +47,9 @@     time >= 1.9 && < 1.10,     transformers >= 0.5,     unordered-containers,-    web-rep >= 0.6 && < 0.7,+    web-rep >= 0.7 && < 0.8,   exposed-modules:+    Chart.Serve     Chart.Various   other-modules:   default-language: Haskell2010

@@ -0,0 +1,155 @@+{-# 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 (defaultSConfig & #frameRate .~ 1000) frameStamp+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 = (<>)++-- | charts+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)++-- * wranglers+-- svgs <- runCont $ toListE <$> chartEmitter defaultSConfig (defaultAnimation defaultSConfig)+-- zipWithM_ (\x svg -> writeFile ("other/" <> show x <> ".svg") svg) [1..199] svgs+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)))++-- | One of the joys of box is you get great support for adhoc low-level testing+--+-- > glue toStdout . fmap show <$.> carousel (defaultSConfig & #frameRate .~ 100)+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)]+          ]+      )