hashirama/reanimate
Watch
1
0
Fork
You've already forked reanimate
 0
mirror of https://github.com/reanimate/reanimate.git synced 2026-09-18 03:12:40 +00:00
Code Issues Projects Releases Wiki Activity

Feature params (#24)

Browse source 
* Vars and Sprites.

* Bump reanimate-svg dependency.

* Don't memo raster images.

* Feature: svgAsPngFile :: Tree -> FilePath

Former-commit-id: 96681be8f654a1a1638ac778031e76b575782dbd
This commit is contained in:
David Himmelstrup 2019-10-14 18:53:53 +08:00 • committed by GitHub
commit 8648b7fee0
9 changed files with 462 additions and 65 deletions
Download patch file Download diff file Expand all files Collapse all files

231
videos/sorting-algorithms/sorting-algorithms.hs
View file

@ -10,6 +10,7 @@ import Codec.Picture.Types
import Data.Fixed
import Control.Monad
import Data.List
import Data.Ord (comparing)
import qualified Data.Text as T
import qualified Geom2D.CubicBezier as Bezier
import Graphics.SvgTree (Number (..), Tree)
@ -34,7 +35,10 @@ digitWidth = screenWidth/10
digitCount = 10
main :: IO ()
main = reanimate $ fixed bg $ pauseAtEnd 1 $ sceneAnimation (simpleSort lst)
main = reanimate $ fixed bg $ pauseAtEnd 1 $
-- sceneAnimation (bubbleSort lst) `seqA` sceneAnimation (simpleSort lst)
-- sceneAnimation (simpleSort_ lst)
sceneAnimation (quicksort__ lst)
-- mkAnimation 5 $ \t ->
-- withFillColor "white" $ translate (negate $ digitWidth*digitCount/2) 0 $
-- sortingTransition (zip [9,0,1,2,3,4,5,6,8,7] squares) s
@ -49,7 +53,7 @@ main = reanimate $ fixed bg $ pauseAtEnd 1 $ sceneAnimation (simpleSort lst)
bg = mkBackground "black"
msg = "0 1 2 3 4 5 6 7 8 9"
digits =
map (withStrokeColor "black" . withStrokeWidth 0) $
map (withStrokeColor "black" . withStrokeWidth 0.01 . withFillColor "white") $
map (lowerTransformations . scale 1 . pathify . center . latex . T.pack . show) [0..9]
squares = map center [ withFillColorPixel (promotePixel $ viridis (n/9)) $
mkRect (digitWidth*1.00) digitWidth | n <- [0..9]]
@ -221,6 +225,14 @@ sortingTransition elts s = mkGroup
(target,_) = elts !! next
in signum (next-target) == signum (from-to) && canMoveDirectly next to
moveDigit :: Int -> Int -> Double -> Tree -> Animation
moveDigit fromX toX dir t =
signalA (curveS 2) $ animate $ \time ->
translate (fromToS fromPos toPos time) (sin (time*pi)*digitWidth*dir) t
where
fromPos = fromIntegral (fromX-5) * digitWidth + digitWidth/2
toPos = fromIntegral (toX-5) * digitWidth + digitWidth/2
simpleSort :: [(Int, Tree)] -> Scene s ()
simpleSort lst = do
objs <- replicateM 10 newObject
@ -237,15 +249,218 @@ simpleSort lst = do
worker dir rest
worker dir ((i, (nth,t)):rest) = do
z <- round <$> queryNow
let obj = objs!!nth
fromX = fromIntegral (i-5) * digitWidth + digitWidth/2
toX = fromIntegral (nth-5) * digitWidth + digitWidth/2
withObject obj $
fork $ playZ (10+z) $ signalA (curveS 2) $ animate $ \time ->
translate (fromToS fromX toX time) (sin (time*pi)*digitWidth*dir) t
withObject (objs!!nth) $
fork $ playZ (10+z) $ moveDigit i nth dir t
wait 0.5
worker (negate dir) $ yoink nth rest
waitAll $ worker 1 (zip [0..] lst)
forM_ objs dropObject
simpleSort_ :: [(Int, Tree)] -> Scene s ()
simpleSort_ lst = do
params <- forM (zip [0..] lst) newBlock
wait 1
let worker _ [] = return ()
worker dir ((i, (nth,t)):rest) | i == nth =
worker dir rest
worker dir ((i, (nth,t)):rest) = do
z <- round <$> queryNow
fork $ tweenParam (params!!i) 1 $ \t (x,y,elt) ->
let s = curveS 2 t in
(fromToS x (fromIntegral nth) s, y+sin (pi*s )*dir, elt)
wait 0.5
worker (negate dir) $ yoink nth rest
waitAll $ worker 1 (zip [0..] lst)
where
newBlock (i, elt) = simpleParam render (i, 0, elt)
render (i, y, (_, t)) =
translate (-digitWidth*5 + i*digitWidth + digitWidth/2)
(y*digitWidth) t
quicksort_ :: [(Int, Tree)] -> Scene s ()
quicksort_ lst = do
params <- liftST $ V.new (length lst)
forM_ (zip [0..] lst) $ \(i, elt) -> do
block <- newBlock (fromIntegral i, elt)
liftST $ V.write params i block
let partition pivot lo hi = do
loValP <- liftST (V.read params lo)
loVal <- readParam loValP
hiValP <- liftST (V.read params hi)
hiVal <- readParam hiValP
if getKey loVal < getKey pivot
then partition pivot (lo+1) hi
else if getKey hiVal > getKey pivot
then partition pivot lo (hi-1)
else if lo >= hi
then return hi
else do
liftST $ V.write params lo hiValP
liftST $ V.write params hi loValP
fork $ tweenParam hiValP 1 $ \t (x,y,elt) ->
let s = curveS 2 t in
(fromToS x (getPos loVal) s, y+sin (pi*s), elt)
fork $ tweenParam loValP 1 $ \t (x,y,elt) ->
let s = curveS 2 t in
(fromToS x (getPos hiVal) s, y-sin (pi*s), elt)
wait 1
partition pivot (lo+1) (hi-1)
let worker lo hi | lo >= hi = return ()
worker lo hi = do
pivotP <- getPivot params lo hi
pivot <- readParam pivotP
tweenParam pivotP 1 $ \t (x,y,elt) ->
let s = curveS 2 t in
(x, y-s/2, elt)
p <- partition pivot lo hi
tweenParam pivotP 1 $ \t (x,y,elt) ->
let s = curveS 2 t in
(x, y+s/2, elt)
fork $ worker lo p
fork $ worker (p+1) hi
worker 0 (length lst-1)
where
getPivot params lo hi = do
let middle = lo + (hi-lo) `div` 2
indices = filter (< hi) $ filter (>= lo) [middle-1,middle,middle+1]
selected <- forM indices $ \idx -> liftST (V.read params idx)
keys <- mapM readParam selected
return $ head $ drop (length indices `div` 2) $ map snd $ sortBy (comparing fst) $ zip (map getKey keys) selected
getPos (x, _, _) = x
getKey (_x, _y, (i, _)) = i
newBlock (i, elt) = simpleParam render (i, 0, elt)
render (i, y, (_, t)) =
translate (-digitWidth*5 + i*digitWidth + digitWidth/2)
(y*digitWidth) t
quicksort__ :: [(Int, Tree)] -> Scene s ()
quicksort__ lst = do
vars <- mapM newBlock (zip [0..] lst)
forM_ vars $ \var -> newSprite $ do
varT <- freezeVar var
return $ \realT _d _t ->
render (varT realT)
let getNth nth = findVar (\obj -> round (getPos obj) == nth) vars
getPivot lo hi = do
let middle = lo + (hi-lo) `div` 2
getNth middle
let partition pivot lo hi = do
loValP <- getNth lo
loVal <- readVar loValP
hiValP <- getNth hi
hiVal <- readVar hiValP
if getKey loVal < getKey pivot
then partition pivot (lo+1) hi
else if getKey hiVal > getKey pivot
then partition pivot lo (hi-1)
else if lo >= hi
then return hi
else do
tweenVar hiValP 1 $ \t (x,y,elt) ->
let s = curveS 2 t in
(fromToS x (getPos loVal) s, y+sin (pi*s), elt)
tweenVar loValP 1 $ \t (x,y,elt) ->
let s = curveS 2 t in
(fromToS x (getPos hiVal) s, y-sin (pi*s), elt)
wait 1
partition pivot (lo+1) (hi-1)
let preshuffle lo hi = do
let middle = lo + (hi-lo) `div` 2
targets = nub [lo, middle, hi]
selected <- sortBy (comparing getKey) <$> (mapM readVar =<< mapM getNth targets)
let toMove = [ (target, origX) | (target, origX) <- zip selected targets]
unless (null toMove) $ do
forM_ toMove $ \(target,_) -> do
var <- getNth (round (getPos target))
tweenVar var 1 $ \t (x,y,elt) ->
let s = curveS 2 t in
(x, y+s/2, elt)
wait 1
forM_ toMove $ \(target,origX) ->
when (round (getPos target) /= origX) $ do
var <- getNth (round (getPos target))
tweenVar var 1 $ \t (x,y,elt) ->
let s = curveS 2 t in
(fromToS x (fromIntegral origX) s, y+sin (pi*s)/2, elt)
forM_ toMove $ \(target,_) -> do
var <- getNth (round (getPos target))
tweenVar var 1 $ \t (x,y,elt) ->
let s = curveS 2 t in
(x, y-s/2, elt)
wait 1
let worker lo hi | lo >= hi = return ()
worker lo hi | hi-lo <= 2 =
preshuffle lo hi
worker lo hi = do
preshuffle lo hi
pivotP <- getPivot lo hi
pivot <- readVar pivotP
tweenVar pivotP 1 $ \t (x,y,elt) ->
let s = curveS 2 t in
(x, y-s/2, elt)
wait 1
p <- partition pivot lo hi
tweenVar pivotP 1 $ \t (x,y,elt) ->
let s = curveS 2 t in
(x, y+s/2, elt)
wait 1
worker lo (p-1)
worker (p+1) hi
worker 0 (length lst-1)
where
getPos (x, _, _) = x
getKey (_x, _y, (i, _)) = i
newBlock (x, (i, elt)) = newVar (x, 0, (i, elt))
render (i, y, (_, t)) =
translate (-digitWidth*5 + i*digitWidth + digitWidth/2)
(y*digitWidth) t
bubbleSort :: [(Int, Tree)] -> Scene s ()
bubbleSort lst = do
objs <- replicateM (length lst) newObject
forM_ (zip [0..] lst) $ \(i, (nth, t)) -> do
withObject (objs!!nth) $
fork $ playZ 0 $ animate $ const $
translate (-digitWidth*5 + fromIntegral i*digitWidth + digitWidth/2) 0 t
wait 1
v <- liftST $ V.new (length lst)
liftST $ mapM_ (\(i,e) -> V.write v i e) (zip [0..] lst)
let worker n c | n+1 >= length lst =
when c $ worker 0 False
worker n c = do
(nth1, t1) <- liftST $ V.read v n
(nth2, t2) <- liftST $ V.read v (n+1)
when (nth1 > nth2) $ waitAll $ do
liftST $ V.write v n (nth2, t2)
liftST $ V.write v (n+1) (nth1, t1)
withObject (objs!!nth1) $
fork $ playZ 1 $ moveDigit n (n+1) (0.5) t1
withObject (objs!!nth2) $
fork $ playZ 1 $ moveDigit (n+1) n (-0.5) t2
worker (n+1) (c || nth1 > nth2)
worker 0 False
forM_ objs dropObject
highlightPair :: Int -> Int -> Animation
highlightPair fromX toX = animate $ \t ->
withStrokeWidth 0.1 $
withStrokeColor "white" $
mkLinePath
[ (xPos t,yPos-0.3)
, (xPos t,yPos)
, (xPos t+digitWidth, yPos)
, (xPos t+digitWidth, yPos-0.3)]
where
yPos = digitWidth*1.1
xPos = fromToS fromPos toPos
fromPos = fromIntegral (fromX-5) * digitWidth + digitWidth/2
toPos = fromIntegral (toX-5) * digitWidth + digitWidth/2