Skip to content

Instantly share code, notes, and snippets.

@nomeata

nomeata/GC-Anim.hs

Last active Aug 29, 2015
Embed
What would you like to do?
GC animation
{-# LANGUAGE ViewPatterns, GeneralizedNewtypeDeriving, DeriveDataTypeable#-}
import Diagrams.Prelude
import Diagrams.Backend.Cairo.CmdLine
import Diagrams.TwoD.Vector
import Diagrams.Core.Types
import qualified Data.Monoid.MList
import Data.Monoid.Coproduct
import Data.Typeable
import Data.Maybe
import Debug.Trace
import Control.Lens (set, ix, itraversed, indices, _1, _2, _3, _4, _5)
import Control.Arrow (first)
{-
getStyle :: Subdiagram b v m -> Style v
getStyle (Subdiagram _ (Option (Just a), _)) = killL a
-}
clWidth = 100
clHeight = 20
arrow_protrude = 25
arrow_extra = 6
closureField :: Int -> Maybe String -> Diagram B R2
closureField w mbs = (rect clWidth clHeight <> desc) # lw none # named (WordN w)
where desc = case mbs of Nothing -> circle 3
Just s -> text s # fontSizeL 12
closure :: [Maybe String] -> Colour Double -> Diagram B R2
closure words c = translateY (-0.5*clHeight) $ lc c $
r # stroke # lw thick # clipped r # alignB <>
(vcat $ reverse $ zipWith closureField [0..] words) # alignB
where
w = clWidth
h = fromIntegral (length words) * clHeight
r = rect w h
cons :: Colour Double -> Diagram B R2
cons = closure [Just "Cons", Nothing, Nothing]
ind :: Colour Double -> Diagram B R2
ind = closure [Just "Ind", Nothing]
char :: Char -> Colour Double -> Diagram B R2
char c = closure [Just "Char", Just $ "'" ++ [c] ++ "'"]
nil :: Colour Double -> Diagram B R2
nil = closure [Just "Nil"]
heap :: Diagram B R2
heap = vcat [phantom (nil grey) # named (Offset n) | n <- reverse [0..12]]
positionFor :: Int -> Int -> Diagram B R2 -> Diagram B R2
positionFor n c d = phantom d # named (positionAt n c)
positionAt :: Int -> Int -> Name
positionAt n c = toName (TP (n,c))
cellName :: Int -> Int -> Name
cellName n w = Closure n .> WordN w
realN :: Int -> Diagram B R2 -> Diagram B R2
realN n d = toName (Closure n) |> d
oldHeap :: Diagram B R2
oldHeap = Heap 1 |> heap
newHeap :: Diagram B R2
newHeap = Heap 2 |> heap
staticArea :: Diagram B R2
staticArea = Heap 3 |> heap
newtype TimePos = TP (Int, Int) deriving (Show, Ord, Eq, Typeable )
instance IsName TimePos
-- Names
newtype Heap = Heap Int deriving (Show, Ord, Eq, Typeable)
instance IsName Heap
newtype Offset = Offset Int deriving (Show, Ord, Eq, Typeable)
instance IsName Main.Offset
newtype Closure = Closure Int deriving (Show, Ord, Eq, Typeable)
instance IsName Closure
newtype WordN = WordN Int deriving (Show, Ord, Eq, Typeable)
instance IsName WordN
hPos :: Int -> Int -> Name
hPos n w = Heap n |> toName (Offset w)
data VH = V | H | P Double Double | PR Double Double -- horizontal first, verticla first, or following a path (with extra spacing and possibly reversed)
data Position
= At Double Name
| MoveFromTo Name Name VH Double
| NotShown
animate :: Active a -> [a -> Active a] -> Active a
animate x [] = x
animate x (f:fs) = animate (x |>> f (activeEnd x)) fs
doWait :: a -> Active a
doWait x = x <$ ui
doMoveTo :: Name -> VH -> Position -> Active Position
doMoveTo to vert p = MoveFromTo (endPos p) to vert <$> clamp ui
inBoth :: Applicative f => (a -> f a) -> (a, a) -> f (a, a)
inBoth f (p1,p2) = (,) <$> f p1 <*> f p2
endPos :: Position -> Name
endPos (At _ n) = n
endPos (MoveFromTo _ n _ _) = n
endPos NotShown = error "moveTo when not shown"
startAt :: Name -> Position
startAt = At 1
-- This is a hack. We want something that takes now time, but changes endPos
doJumpTo :: Name -> Position -> Active Position
doJumpTo to _ = At 1 to <$ interval 0 0.01
fadeInAt :: Name -> Position -> Active Position
fadeInAt to _ = At <$> clamp ui <*> pure to
fadeIn :: Position -> Active Position
fadeIn p = At <$> clamp ui <*> pure (endPos p)
fadeOut :: Position -> Active Position
fadeOut p = At <$> backwards (clamp ui) <*> pure (endPos p)
type Arrow = (Double, Double, Colour Double, Name, Position)
type Scene = ([(Diagram B R2, Position)], [Arrow], Position)
startSpec :: Scene
startSpec =
( zipWith (first . realN) [1..] $
[ (cons yellow, startAt (hPos 1 10))
, (char 'K' purple, startAt (hPos 1 8))
, (cons green, startAt (hPos 1 5))
, (char 'F' blue, startAt (hPos 1 3))
, (cons brown, startAt (hPos 1 0))
, (ind grey, NotShown)
, (ind grey, NotShown)
, (ind grey, NotShown)
, (nil brown, startAt (hPos 3 0))
]
, [ (2, 0, yellow, cellName 1 1, startAt $ hPos 1 8)
, (3, 0, yellow, cellName 1 2, startAt $ hPos 3 0)
, (0, -1, green, cellName 3 1, startAt $ hPos 1 8)
, (1, 0, green, cellName 3 2, startAt $ hPos 1 10)
, (0, 0, brown, cellName 5 1, startAt $ hPos 1 3)
, (1, 0, brown, cellName 5 2, startAt $ hPos 1 5)
, (4, 1, grey, cellName 6 1, startAt $ cellName 3 0)
, (5, 1, grey, cellName 7 1, startAt $ cellName 2 0)
, (6, 1, grey, cellName 8 1, startAt $ cellName 1 0)
, (0, -1, black, toName "live set", startAt $ cellName 3 0)
]
, startAt (toName "live set"))
positionSpec :: Active Scene
positionSpec = animate (doWait startSpec)
[ _3 $ doMoveTo (cellName 3 0) V
, _1 . ix 2 . _2 $ doMoveTo (hPos 2 0) H
, mapPair3A ( ix 5 . _2 $ fadeInAt (hPos 1 5)
, ix 6 . _5 $ fadeIn
, pure)
, _3 $ doMoveTo (cellName 3 1) H
, _3 $ doMoveTo (cellName 2 0) (P 0 (-1))
, _2 . ix 2 . _5 $ doJumpTo (cellName 2 0)
, _1 . ix 1 . _2 $ doMoveTo (hPos 2 3) H
, mapPair3A ( ix 6 . _2 $ fadeInAt (hPos 1 8)
, ix 7 . _5 $ fadeIn
, pure)
, _3 $ doMoveTo (cellName 3 1) (PR 0 (-1))
, _3 $ doMoveTo (cellName 3 2) V
, _3 $ doMoveTo (cellName 1 0) (P 1 0)
, _2 . ix 3 . _5 $ doJumpTo (cellName 1 0)
, _1 . ix 0 . _2 $ doMoveTo (hPos 2 5) H
, mapPair3A ( ix 7 . _2 $ fadeInAt (hPos 1 10)
, ix 8 . _5 $ fadeIn
, pure)
, _3 $ doMoveTo (cellName 1 1) H
, _3 $ doMoveTo (cellName 7 0) (P 3 0)
, (\f (a,b,c) -> (,,) <$> pure a <*> (ix 0 . _5) f b <*> f c) -- is this possible in a nicer way?
$ doMoveTo (cellName 7 1) V
, (\f (a,b,c) -> (,,) <$> pure a <*> (ix 0 . _5) f b <*> f c)
$ doMoveTo (cellName 2 0) (P 5 1)
, _3 $ doMoveTo (cellName 1 1) (PR 3 0)
, _3 $ doMoveTo (cellName 1 2) V
, doWait
, doWait
, doWait
, mapPair3A ( itraversed . indices (`elem` [3,4,5,6,7]) . _2 $ fadeOut
, itraversed . indices (`elem` [4,5,6,7,8]) . _5 $ fadeOut
, fadeOut )
]
gcStar :: Diagram B R2
gcStar = star (StarSkip 2) (polygon (with & polyType .~ (PolyRegular 5 20))) # stroke # fc red # lw none
movements spec =
applyAll $ reverse $
[ d # moveToPos pos | (d, pos) <- objectSpec ] ++
[ posToName pos $ \n2 ->
myArrow ex exV (fc c . lc c . opacity (posOpacity pos)) n1 n2
| (ex, exV, c, n1, pos) <- arrows] ++
[ gcStar # moveToPos starSpec ]
where
(objectSpec, arrows, starSpec) = spec
posToName :: Position -> (Name -> Diagram B R2 -> Diagram B R2) -> (Diagram B R2 -> Diagram B R2)
posToName (At o i) cont = cont i
posToName NotShown cont = id
posToName (MoveFromTo i1 i2 _ r) cont | r <= 0 = cont i1
posToName (MoveFromTo i1 i2 _ r) cont | r >= 1 = cont i2
posToName (MoveFromTo i1 i2 hv r) cont =
fromToTrail i1 i2 hv $ \trail ->
let pos = trail `atParam` r
in cont (toName ()) . namePoint (const pos) ()
fromToTrail :: Name -> Name -> VH ->
(Located (Trail R2) -> Diagram B R2 -> Diagram B R2) ->
(Diagram B R2 -> Diagram B R2)
fromToTrail i1 i2 (P x xV) cont = arrowTrail x xV i1 i2 cont
fromToTrail i1 i2 (PR x xV) cont = arrowTrail x xV i2 i1 (cont . reverseLocTrail)
fromToTrail i1 i2 vh cont =
withName i1 $ \sub1 ->
withName i2 $ \sub2 ->
let pos1 = location sub1
pos2 | V <- vh = pos1 |- pos3
| H <- vh = pos1 -| pos3
pos3 = location sub2
trail = fromVertices [pos1, pos2, pos3] :: Located (Trail R2)
in (cont trail)
moveToPos :: Position -> Diagram B R2 -> (Diagram B R2 -> Diagram B R2)
moveToPos (At o i) d =
withName i $ \sub -> atop $ d # opacity o # moveTo (location sub)
moveToPos (MoveFromTo i1 i2 vh r) d =
fromToTrail i1 i2 vh $ \trail -> atop $ d # moveTo (trail `atParam` r)
moveToPos NotShown d = id
posOpacity :: Position -> Double
posOpacity (At o _) = o
posOpacity _ = 1
heaps :: Diagram B R2
heaps = hcat' (with & sep .~ clWidth)
[ alignT $ strutY clHeight # named "live set"
===
(strutY clHeight <> text "live set" # fontSizeL 12)
, alignB $ oldHeap # alignB === (strutY clHeight <> text "old heap" # fontSizeL 12)
, alignB $ newHeap # alignB === (strutY clHeight <> text "new heap" # fontSizeL 12)
, translateY (-2 * clHeight) $
alignB $ staticArea # alignB === (strutY clHeight <> text "static area" # fontSizeL 12)
]
x ## f = f <$> x
infixl 8 ##
stableImage :: Animation B R2 -> Animation B R2
stableImage anim =
anim ## withEnvelope (activeStart anim) ## frame 30 ## bg white
activeImage :: Animation B R2
activeImage = (movements <$> positionSpec <*> pure heaps) # stableImage ## font "Sans"
arrowTrail :: (IsName n1, IsName n2) => Double -> Double -> n1 -> n2 ->
(Located (Trail R2) -> Diagram B R2 -> Diagram B R2) -> (Diagram B R2 -> Diagram B R2)
arrowTrail extra extraV n1 n2 cont =
withName n1 $ \sub1 ->
withName n2 $ \sub2 ->
let s = location sub1
e = location sub2 .+^ (extraV * arrow_extra) *^ unitY
prod = (arrow_protrude + extra * arrow_extra) *^ unitX
s2 = maybe s (.+^ prod) $ maxTraceP s unitX sub1
fromRight = leftTurn unitY (e .-. s2)
e3 | fromRight = fromMaybe e (maxTraceP e unitX sub2)
| otherwise = fromMaybe e (maxTraceP e unit_X sub2)
e2 = s2 |- e3
in cont (fromVertices [s,s2,e2,e3])
myArrow :: (IsName n1, IsName n2) => Double -> Double -> (Diagram B R2 -> Diagram B R2) -> n1 -> n2 -> Diagram B R2 -> Diagram B R2
myArrow extra extraV style n1 n2 =
arrowTrail extra extraV n1 n2 $ \trail -> atop $ mconcat
[ circle 3 # moveTo (atStart trail) # stroke
, trail # strokeLocTrail
-- a bit hackish, normalAtEnd would be the clean solution
, arrowBetween' (with & shaftStyle %~ lw none) (trail `atParam` 0.99) (atEnd trail)
] # style
(|-) :: P2 -> P2 -> P2
(unp2 -> (x,_)) |- (unp2 -> (_,y)) = p2 (x,y)
(-|) :: P2 -> P2 -> P2
(unp2 -> (_,y)) -| (unp2 -> (x,_)) = p2 (x,y)
mapPair3A :: Applicative f =>
(a -> f a', b -> f b', c -> f c') -> (a, b, c) -> f (a', b', c')
mapPair3A (f1, f2, f3) (a, b, c) = (,,) <$> f1 a <*> f2 b <*> f3 c
main :: IO ()
main = mainWith activeImage
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
You can’t perform that action at this time.