From 841571f062ed0148219ad805c2028f228a611c27 Mon Sep 17 00:00:00 2001
From: David Himmelstrup <lemmih@gmail.com>
Date: Mon, 18 May 2020 20:49:32 +0800
Subject: [PATCH] Add stars example. (#71)

Former-commit-id: cda8a6c63bc5be127c2b06dbab7482f16ed66cdb
---
 README.md              |  3 +-
 examples/demo_stars.hs | 77 ++++++++++++++++++++++++++++++++++++++++++
 reanimate.cabal        |  2 +-
 3 files changed, 80 insertions(+), 2 deletions(-)
 create mode 100755 examples/demo_stars.hs

diff --git a/README.md b/README.md
index a1430fd..b03abb3 100644
--- a/README.md
+++ b/README.md
@@ -33,8 +33,9 @@ main = reanimate $ docEnv $ playThenReverseA drawCircle
 [![Geo JSON](https://i.imgur.com/OrKiOqF.gif)](videos/map-projection/gif.hs)
 [![Object tracing](https://i.imgur.com/Y6NsPWF.gif)](examples/tut_glue_potrace.hs)
 
-## Mathematical typesetting
+## Mathematical typesetting and effects
 [![LaTeX](https://i.imgur.com/e6oO4wz.gif)](examples/tut_glue_latex.hs)
+[![Stars](https://i.imgur.com/yek3v4b.gif)](examples/demo_stars.hs)
 
 ## 2D physics and 3D graphics
 [![2D Physics](https://i.imgur.com/ZHUfWdp.gif)](examples/tut_glue_physics.hs)
diff --git a/examples/demo_stars.hs b/examples/demo_stars.hs
new file mode 100755
index 0000000..ff659e1
--- /dev/null
+++ b/examples/demo_stars.hs
@@ -0,0 +1,77 @@
+#!/usr/bin/env stack
+-- stack runghc --package reanimate
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ParallelListComp #-}
+module Main
+  ( main
+  )
+where
+
+import           Reanimate
+import           Reanimate.Interpolate
+import           Reanimate.Builtin.Documentation
+import           System.Random
+import Data.List
+import Codec.Picture.Types
+import qualified Data.Vector as V
+
+main :: IO ()
+main = reanimate $ sceneAnimation $ do
+  newSpriteSVG_ $ mkBackgroundPixel rtfdBackgroundColor
+  play $ trails 0.05 starAnimation
+
+starAnimation :: Animation
+starAnimation = mkAnimation 10 $ \t ->
+  let camZ = t * 4
+  in  withStrokeWidth 0 $ rotate (t * 360) $ mkGroup
+        [ translate (x / newZ) (y / newZ) $ dot (1 - newZ)
+        | (x, y, z) <-
+          reverse $ take nStars $ dropWhile (\(_, _, z) -> z < camZ) $ allStars
+        , let newZ = z - camZ
+        ]
+ where
+  black = PixelRGB8 0x0 0x0 0x0
+  dot o =
+    withFillColorPixel
+        ( promotePixel
+        $ interpolateRGB8 labComponents (dropTransparency rtfdBackgroundColor) black o
+        )
+      $ mkCircle 0.05
+
+{-# INLINE trails #-}
+trails :: Double -> Animation -> Animation
+trails trailDur raw = mkAnimation (duration raw) $ \t ->
+  let idx = round (t * fromIntegral nFrames)
+  in  construct $ reverse [idx - trailFrames .. idx]
+ where
+  fps = 200
+  construct []     = mkGroup []
+  construct (x:xs) = mkGroup
+    [ withGroupOpacity (fromIntegral trailFrames / fromIntegral (trailFrames + 1))
+      $ construct xs
+    , getFrame x
+    ]
+  trailFrames = round (trailDur * fps)
+  nFrames     = round (duration raw * fps)
+  getFrame idx = frames V.! (idx `mod` nFrames)
+  frames = V.fromList
+    [ frameAt (fromIntegral i / fromIntegral nFrames * duration raw) raw
+    | i <- [0 .. nFrames]
+    ]
+
+nStars :: Int
+nStars = 1000
+
+stars, allStars :: [(Double, Double, Double)]
+allStars = [ (x, y, z + n) | n <- [0 ..], (x, y, z) <- stars ]
+stars = sortOn takeZ $ take nStars
+  [ (x, y, z)
+  | x <- randomRs (-screenWidth/2, screenWidth/2) seedX
+  | y <- randomRs (-screenWidth/2, screenWidth/2) seedY
+  | z <- randomRs (0, 1) seedZ ]
+  where takeZ (_,_,z) = z
+
+seedX, seedY, seedZ :: StdGen
+seedX = mkStdGen 0xDEAFBEEF
+seedY = mkStdGen 0x12345678
+seedZ = mkStdGen 0x87654321
diff --git a/reanimate.cabal b/reanimate.cabal
index 5613ba8..8e55d14 100644
--- a/reanimate.cabal
+++ b/reanimate.cabal
@@ -111,7 +111,7 @@ library
                        containers, reanimate-svg >= 0.9.7.0, xml, bytestring, lens, linear, mtl, matrix,
                        JuicyPixels, attoparsec, parallel,
                        cubicbezier, websockets >= 0.12.7.0,
-                       hashable, fsnotify, open-browser, random-shuffle, base64-bytestring,
+                       hashable, fsnotify, open-browser, random, random-shuffle, base64-bytestring,
                        vector >= 0.12.0.0, colour, cassava, ansi-wl-pprint, here, temporary,
                        optparse-applicative, chiphunk >= 0.1.2.1,
                        geojson, aeson >= 1.3.0.0,