Skip to content

Instantly share code, notes, and snippets.

@Davorak
Last active August 29, 2015 14:14
Show Gist options
  • Save Davorak/b25e9288c11f8d482292 to your computer and use it in GitHub Desktop.
Save Davorak/b25e9288c11f8d482292 to your computer and use it in GitHub Desktop.
Simple Animation using diagrams
-- | 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
-}
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment