From d48ec84ed691e24327b7d08d3357aa0c80a00339 Mon Sep 17 00:00:00 2001
From: David <lemmih@gmail.com>
Date: Thu, 14 Feb 2019 13:14:48 +0100
Subject: [PATCH] Add highlight example.

---
 README.md                    |  2 +
 src/Reanimate/Arrow.hs       |  2 +-
 src/Reanimate/Combinators.hs | 38 ++++++++++++++---
 src/Reanimate/Examples.hs    | 79 +++++++++++++++++++++---------------
 src/SvgViewer.hs             |  2 +-
 5 files changed, 83 insertions(+), 40 deletions(-)

diff --git a/README.md b/README.md
index cd64191..c04b1f6 100644
--- a/README.md
+++ b/README.md
@@ -9,3 +9,5 @@
 ![Morphing wave to circle](gifs/morphwave_circle.gif)
 
 ![Speed modification](gifs/progress.gif)
+
+![Highlight](gifs/lighlight.gif)
diff --git a/src/Reanimate/Arrow.hs b/src/Reanimate/Arrow.hs
index d4c62fd..e756030 100644
--- a/src/Reanimate/Arrow.hs
+++ b/src/Reanimate/Arrow.hs
@@ -31,7 +31,7 @@ duration :: Double -> Animation a ()
 duration duration = Animation duration (\_ _ _ -> pure ())
 
 defineAnimation :: Animation a b -> Animation a b
-defineAnimation (Animation d fn) = Animation d (\_ t -> fn d (t `mod'` d))
+defineAnimation (Animation d fn) = Animation d (\_ t -> fn d (min t d))
 
 animationDuration :: Animation a b -> Double
 animationDuration (Animation d _) = d
diff --git a/src/Reanimate/Combinators.hs b/src/Reanimate/Combinators.hs
index 6392a30..3722190 100644
--- a/src/Reanimate/Combinators.hs
+++ b/src/Reanimate/Combinators.hs
@@ -50,10 +50,10 @@ progress ani = proc () -> do
 
 before :: Ani () -> Ani () -> Ani ()
 before (Animation d1 fn1) (Animation d2 fn2) =
-  Animation (d1+d2) (\t -> if t < d1 then fn1 t else fn2 (t-d1))
+  Animation (d1+d2) (\d t -> if t < d1 then fn1 d t else fn2 d (t-d1))
 
 follow :: [Ani ()] -> Ani ()
-follow = foldr before (arr $ pure ())
+follow lst = foldr before (arr $ pure ()) lst
 
 sim :: [Ani ()] -> Ani ()
 sim = foldr par (arr $ pure ())
@@ -71,12 +71,15 @@ approxFnData steps fn =
   fn 0 : [ fn (fromIntegral n/fromIntegral steps) | n <- [0..steps] ]
 
 renderPath :: Path -> Svg ()
-renderPath ((startX, startY):rest) =
+renderPath dat =
     path_ [stroke_ "white", fill_ "translucent", d_ path]
   where
-    path = T.unlines $
-      ("M " <> pack (show startX) <> " " <> pack (show startY)):
-      [ "L " <> pack (show x) <> " " <> pack (show y) | (x, y) <- rest]
+    path = renderPathText dat
+
+renderPathText :: Path -> Text
+renderPathText ((startX,startY):rest) = T.unlines $
+    ("M " <> pack (show startX) <> " " <> pack (show startY)):
+    [ "L " <> pack (show x) <> " " <> pack (show y) | (x, y) <- rest]
 
 morphPath :: Path -> Path -> Double -> Path
 morphPath src dst idx = zipWith worker src dst
@@ -96,6 +99,21 @@ signal :: Double -> Double -> Ani Double
 signal from to =
   Animation 0 (\dur t () -> pure (from + (to-from)*(t/dur)))
 
+signalSigmoid :: Double -> Double -> Double -> Ani Double
+signalSigmoid steepness from to = proc () -> do
+  s <- signal 0 1 -< ()
+  let s' = (s-0.5)*steepness
+  let sigmoid = exp s' / (exp s'+1)
+      ret = (from + (to-from)*sigmoid)
+  returnA -< ret
+
+signalSCurve :: Double -> Double -> Double -> Ani Double
+signalSCurve steepness from to = proc () -> do
+  s <- signal 0 1 -< ()
+  returnA -< if s < 0.5
+              then 0.5 * (2*s)**steepness
+              else 1-0.5 * (2 - 2*s)**steepness
+
 signalOscillate :: Double -> Double -> Ani Double
 signalOscillate from to = proc () -> do
   s <- signal from (to+diff) -< ()
@@ -107,3 +125,11 @@ signalOscillate from to = proc () -> do
 adjustSpeed :: Double -> Ani a -> Ani a
 adjustSpeed factor (Animation d fn) =
   Animation (d/factor) (\dur t -> fn dur ((t*factor) `mod'` dur))
+
+freeze :: Double -> Ani a -> Ani a
+freeze d (Animation d' fn) =
+  Animation (d+d') (\dur t -> if t > d' then fn dur d' else fn dur t)
+
+loop :: Ani a -> Ani a
+loop (Animation d fn) =
+  Animation d (\dur t -> fn dur (mod' t d))
diff --git a/src/Reanimate/Examples.hs b/src/Reanimate/Examples.hs
index 5e7ff02..c284151 100644
--- a/src/Reanimate/Examples.hs
+++ b/src/Reanimate/Examples.hs
@@ -4,7 +4,7 @@ module Reanimate.Examples where
 import Lucid.Svg
 import Data.Text (Text, pack)
 import Data.Monoid ((<>))
-import Control.Arrow
+import Control.Arrow (returnA)
 
 import Reanimate.Arrow
 import Reanimate.Combinators
@@ -125,7 +125,7 @@ progressMeters = proc () -> do
           , fill_ "white"] "0.5x"
 
 progressMeter :: Ani ()
-progressMeter = defineAnimation $ proc () -> do
+progressMeter = loop $ defineAnimation $ proc () -> do
   duration 5 -< ()
   h <- signal 0 100 -< ()
   emit -< rect_ [ width_ "30", height_ "100", stroke_ "white", stroke_width_ "2", fill_opacity_ "0" ]
@@ -134,34 +134,49 @@ progressMeter = defineAnimation $ proc () -> do
 
 highlight :: Ani ()
 highlight = proc () -> do
-  duration 10 -< ()
-  annotate (g_ [transform_ $ scale 2 2 <> " " <> translate 25 0]) (proc t -> do
-    emit -<
-      g_ [transform_ $ translate 20 20] $
-      g_ [transform_ $ rotateAround 45 10 10] $
-      block "white"
-    emit -<
-      g_ [transform_ $ translate 60 20] $
-      g_ [transform_ $ rotateAround 0 10 10] $
-      block "white"
-    emit -<
-      g_ [transform_ $ translate 20 60] $
-      g_ [transform_ $ rotateAround 0 10 10] $
-      block "white"
-    emit -<
-      g_ [transform_ $ translate 20 60] $
-      g_ [transform_ $ rotateAround 45 10 10] $
-      block "white"
-    emit -<
-      g_ [transform_ $ translate 60 60] $
-      g_ [transform_ $ rotateAround 45 10 10] $
-      block "blue"
-    t <- getTime -< ()
-    emit -<
-      g_ [transform_ $ translate (15 + (55-15)*(t/10)) 15] $
-      rect_ [width_ "30", height_ "30", stroke_ "black", fill_opacity_ "0" ]
-    ) -< ()
-  returnA -< ()
+    emit -< rect_ [width_ "100%", height_ "100%", fill_ "black"]
+    emit -< do
+      path_ (commonAttrs "white" ++ [d_ $ renderPathText rect1])
+      path_ (commonAttrs "white" ++ [d_ $ renderPathText rect2])
+
+      path_ (commonAttrs "white" ++ [d_ $ renderPathText rect3])
+      path_ (commonAttrs "lightblue" ++ [d_ $ renderPathText rect4])
+      path_ (commonAttrs "yellow" ++ [d_ $ renderPathText rect5])
+      path_ (commonAttrs "red" ++ [d_ $ renderPathText rect6])
+
+    follow
+      [ mkTransition highlight1 highlight2
+      , mkTransition highlight2 highlight3
+      , mkTransition highlight3 highlight4
+      , mkTransition highlight4 highlight5
+      , mkTransition highlight5 highlight6
+      , mkTransition highlight6 highlight1
+      ] -< ()
+
   where
-    block c =
-      rect_ [width_ "20", height_ "20", stroke_ "black", fill_ c ]
+    mkTransition from to = freeze 1 $ defineAnimation $ proc () -> do
+      duration 1 -< ()
+      s <- signalSCurve 2 0 1 -< ()
+      let trans = morphPath from to s
+      emit -<
+        path_ (highlightAttrs "green" ++ [d_ $ renderPathText trans <> "Z"])
+    mkRect x y width height =
+      [ (x,y), (x+width, y), (x+width, y+height), (x,y+height) ]
+    rect1 = mkRect margin margin w h
+    rect2 = mkRect (320-margin-w*2) margin (w*2) h
+    rect3 = mkRect margin (180-margin-h) w h
+    rect4 = mkRect (320/3) (180-margin-h) w h
+    rect5 = mkRect (320/3*2-w) (180-margin-h) w h
+    rect6 = mkRect (320-margin-w) (180-margin-h) w h
+    highlight1 = mkRect (margin-b) (margin-b) (w+2*b) (h+2*b)
+    highlight2 = mkRect (320-margin-w*2-b) (margin-b) (w*2+2*b) (h+2*b)
+    highlight3 = mkRect (320-margin-w-b) (180-margin-h-b) (w+2*b) (h+2*b)
+    highlight4 = mkRect (320/3*2-w-b) (180-margin-h-b) (320/3+2*b) (h+2*b)
+    highlight5 = mkRect (320/3-b) (180-margin-h-b) (320/3+2*b) (h+2*b)
+    highlight6 = mkRect (margin-b) (180-margin-h-b) (320/3+2*b) (h+2*b)
+    b = 7
+    margin = 30
+    w = 30
+    h = 30
+    commonAttrs c = [stroke_width_ "2", stroke_ c, fill_ c]
+    highlightAttrs c = [stroke_width_ "2", stroke_ c, fill_opacity_ "0"]
diff --git a/src/SvgViewer.hs b/src/SvgViewer.hs
index 35ba639..15aae6e 100644
--- a/src/SvgViewer.hs
+++ b/src/SvgViewer.hs
@@ -15,7 +15,7 @@ import Data.Time
 import Reanimate.Arrow
 import Reanimate.Examples
 
-animation = progressMeters
+animation = highlight
 
 main :: IO ()
 main = do