Simple Animation using diagrams

explainRad.hs

-- | This is crud emulation of:
-- <https://upload.wikimedia.org/wikipedia/commons/4/4e/Circle_radians.gif>
--
-- Idea from the diagrams projects page:
-- <https://wiki.haskell.org/Diagrams/Projects>
--
-- Simple command line to build new gif
-- rm test*; runhaskell gif.hs --width 500 --height 500 -o test.png; convert *.png test.gif
-- requires imagemagick
{-# LANGUAGE NoMonomorphismRestriction #-}
import Diagrams.Prelude hiding ((->>))
import Diagrams.TwoD
import Diagrams.TwoD.Polygons
import Diagrams.Backend.SVG
import Data.List
import Graphics.SVGFonts

import Diagrams.TwoD.Offset

import Diagrams.Backend.Cairo.CmdLine

import Diagrams.Backend.Canvas hiding (defaultMain)
import Diagrams.Backend.Canvas.CmdLine hiding (defaultMain)
import qualified Diagrams.Backend.Canvas.CmdLine as Canvas

{- needed to render to canvas see bottom of file for more.
import qualified Graphics.Blank               as BC
import qualified Graphics.Blank.Style         as S
-}

import Control.Lens ((^.), (^?), re)

import Control.Monad (forM_)
import Control.Concurrent (threadDelay)

-- | Change the meaning of ->> from the default def so that it renders latter
-- animations on top of past animations.
infixr 5 ->>
(->>) :: Semigroup a => Active a -> Active a -> Active a
a1 ->> a2 = (a2 `after` a1) <> a1

-- | A variable length line with dots put at each end
redDottedLine len =
    let line = fromOffsets [ len * unitX ]
        dots = decoratePath line (repeat $ circle 0.5 # fc red # lcA transparent)
    in dots `atop` lc red line

-- | Grow a line from the origin to the full radius of the circle
growLine =  mkActive 0 1 $ \t ->
    redDottedLine (10 * fromTime t)

-- | Rotate line 90 degrees to be tangential to the circle.
rotateLine = mkActive 0 1 $ \t ->
    translate (10 * unitX) . rotate ((fromTime (-t) / 4) ^. re turn) $ redDottedLine (-10)

-- | Rotate line around the origin used with arcCircle to draw the circle used
-- through out the animation
circleRotateLine = mkActive 0 1 $ \t ->
    rotate (fromTime t ^. re turn) (redDottedLine 10)

-- | This draws the blue circle
arcCircle = mkActive 0 1 $ \t ->
    arc' 10 (0 ^. re turn) (fromTime t ^. re turn) # lc blue

lineToArc = mkActive 0.01 1 $ \t ->
    let x = fromTime t
        line = arcBetween (10 ^& 0) ( (10 ^& 10) .+^ (rotate (1 ^. re rad) (10 ^& 0) ^-^ (10 ^& 10)) # scale x) ((-x)*1.22417)
        dots = decoratePath line (repeat $ circle 0.5 # fc red # lcA transparent)
    in dots `atop` line # lc red

oneRadArc color = mkActive 0 1 $ \t ->
    let x = fromTime t
        line = arc' 10 (x ^. re rad) ((x + 1) ^. re rad)
        dots = decoratePath line (repeat $ circle 0.5 # fc color # lcA transparent)
    in dots `atop` line # lc color

twoRadToPiArc color = mkActive 0 1 $ \t ->
    let x = fromTime t
        line = arc' 10 ((2 + x) ^. re rad) ((3 + (pi-3)*x) ^. re rad)
        dots = decoratePath line (repeat $ circle 0.5 # fc color # lcA transparent)
    in dots `atop` line # lc color

onePiArc color = mkActive 0 1 $ \t ->
    let x = fromTime t
        line = arc' 10 ((pi * x) ^. re rad) ((pi * (x + 1)) ^. re rad)
        dots = decoratePath line (repeat $ circle 0.5 # fc color # lcA transparent)
    in dots `atop` line # lc color

-- | Used to temporarily labels the radius after it grows to full length
rLabel = text "r" # scale 3 # moveTo (5 ^& 2)

-- | Used to label the number of rads in the green arc.
radLabel n = text (n ++ " rad") # scale 3 # moveTo (2 ^& (-2))

-- | Util to fade a diagram in
fadeIn color  = mkActive 0 1 . flip (fcA . withOpacity color . fromTime)

-- | Util to fade a diagram out
fadeOut color = mkActive 0 1 . flip (fcA . withOpacity color . fromTime . (1-))

-- | Serves as the background that everything ahppens on
bgeve = square 50 # fc white # lc white

-- | Crud x y axis for circle
crudeAxis = centerXY (fromOffsets [-25*unitX, 25*unitX])
         <> centerXY (fromOffsets [-25*unitY, 25*unitY])

-- | Rough animation
--
-- todo
-- * Seperate out Label animation and overlay with the rest of the animation
-- * The background circle should be seperated out so that the green arcs can
-- be `trim`ed and replaced with one arc.
-- * The syntax used right now is very similar to do notation try that instead.
-- * Pleaty of other simplifications possible
radExplain = animEnvelope' 0.01 $ fmap (`atop` (crudeAxis `atop` bgeve)) $
    mempty ->>
    trim growLine ->>
    liftA2 atop (trim circleRotateLine) (clamp arcCircle)     ->>
    trim (fmap (<> activeEnd growLine) . fadeIn red $ rLabel) ->>
    trim (fmap (<> activeEnd growLine) . fadeOut red $ rLabel) ->>
    trim rotateLine ->>
    trim lineToArc ->>

    let one = trimBefore . mkActive 0 1 . const . activeStart . oneRadArc in
    let fadinOne = fadeIn green (radLabel "1") in
    let steadyOne = trimBefore . mkActive 0 1 . const . activeEnd $ fadeIn green (radLabel "1") in
    -- let one = trimBefore . snapshot 0 . oneRadArc in
    trim (one red <> fadinOne) ->>
    trim (oneRadArc red <> steadyOne) <> (trimBefore . one $ green) ->>

    let two = trimBefore . mkActive 0 1 . const . activeEnd . oneRadArc in
    let rotateRad = rotate (1 ^. re rad) in
    fmap rotateRad  (trim (oneRadArc red) <> one green) <> trim (fadeIn green (radLabel "2")) ->>

    trim (twoRadToPiArc red) <> fmap (rotateRad . rotateRad) (one green) <> trim (fadeIn green (radLabel "3")) ->>


    let threeToPi = trimBefore . mkActive 0 1 . const . activeEnd . twoRadToPiArc in
    threeToPi green <> trim (fadeIn green (radLabel "pi"))

main = animMain radExplain


{- Code to render to canvas from a simple scotty server using commet.
 - This incrementaly sends frames from the server to the browser.
 -
 - Great for previewing an animation instead of using imagemagick to render a
 - gif.
animRenderCanvas :: Int -> SizeSpec2D -> Active (Diagram Canvas R2) -> IO ()
animRenderCanvas port sizeSpec anim = BC.blankCanvas (fromIntegral port) animImg
    where
      frames = simulate 10 anim
      d = head frames
      animImg context = do
          putStrLn "start"
          putStrLn $ "frame len: " ++ show (length frames)
          forM_ frames $ \frame -> do
              putStrLn "start"
              BC.send context $ do
                  BC.save()
                  BC.clearRect (0, 0, BC.width context, BC.height context)
                  renderDia Canvas (CanvasOptions sizeSpec) frame
                  BC.restore()
              putStrLn "delay"
              threadDelay (100*1000)
              putStrLn "delay end"
      img = renderDia Canvas (CanvasOptions sizeSpec) d

mainWorkingCanvas = animRenderCanvas 5000 (Width 300) radExplain

main = mainWorkingCanvas
-}