mirror of
https://github.com/reanimate/reanimate.git
synced 2026-09-14 09:32:22 +00:00
120 lines
11 KiB
HTML
120 lines
11 KiB
HTML
<html>
|
|
<head>
|
|
<meta http-equiv="Content-Type" content="text/html; charset=UTF-8">
|
|
<style type="text/css">
|
|
span.lineno { color: white; background: #aaaaaa; border-right: solid white 12px }
|
|
span.nottickedoff { background: yellow}
|
|
span.istickedoff { background: white }
|
|
span.tickonlyfalse { margin: -1px; border: 1px solid #f20913; background: #f20913 }
|
|
span.tickonlytrue { margin: -1px; border: 1px solid #60de51; background: #60de51 }
|
|
span.funcount { font-size: small; color: orange; z-index: 2; position: absolute; right: 20 }
|
|
span.decl { font-weight: bold }
|
|
span.spaces { background: white }
|
|
</style>
|
|
</head>
|
|
<body>
|
|
<pre>
|
|
<span class="decl"><span class="nottickedoff">never executed</span> <span class="tickonlytrue">always true</span> <span class="tickonlyfalse">always false</span></span>
|
|
</pre>
|
|
<pre>
|
|
<span class="lineno"> 1 </span>module Reanimate.Chiphunk
|
|
<span class="lineno"> 2 </span> ( simulate
|
|
<span class="lineno"> 3 </span> , BodyStore
|
|
<span class="lineno"> 4 </span> , newBodyStore
|
|
<span class="lineno"> 5 </span> , addToBodyStore
|
|
<span class="lineno"> 6 </span> , spaceFreeRecursive
|
|
<span class="lineno"> 7 </span> , polyShapesToBody
|
|
<span class="lineno"> 8 </span> , polygonsToBody
|
|
<span class="lineno"> 9 </span> ) where
|
|
<span class="lineno"> 10 </span>
|
|
<span class="lineno"> 11 </span>import Chiphunk.Low
|
|
<span class="lineno"> 12 </span>import Control.Monad
|
|
<span class="lineno"> 13 </span>import Data.IORef
|
|
<span class="lineno"> 14 </span>import Data.Map (Map)
|
|
<span class="lineno"> 15 </span>import qualified Data.Map as Map
|
|
<span class="lineno"> 16 </span>import qualified Data.Vector as V
|
|
<span class="lineno"> 17 </span>import qualified Data.Vector.Mutable as V
|
|
<span class="lineno"> 18 </span>import Foreign.Ptr
|
|
<span class="lineno"> 19 </span>import Graphics.SvgTree (Tree)
|
|
<span class="lineno"> 20 </span>import Linear.V2 (V2(..))
|
|
<span class="lineno"> 21 </span>import Reanimate.Animation
|
|
<span class="lineno"> 22 </span>import Reanimate.PolyShape
|
|
<span class="lineno"> 23 </span>import Reanimate.Svg.Constructors
|
|
<span class="lineno"> 24 </span>
|
|
<span class="lineno"> 25 </span>type BodyStore = IORef (Map WordPtr Tree)
|
|
<span class="lineno"> 26 </span>
|
|
<span class="lineno"> 27 </span>newBodyStore :: IO BodyStore
|
|
<span class="lineno"> 28 </span><span class="decl"><span class="istickedoff">newBodyStore = newIORef Map.empty</span></span>
|
|
<span class="lineno"> 29 </span>
|
|
<span class="lineno"> 30 </span>addToBodyStore :: BodyStore -> Body -> Tree -> IO ()
|
|
<span class="lineno"> 31 </span><span class="decl"><span class="istickedoff">addToBodyStore store body svg = do</span>
|
|
<span class="lineno"> 32 </span><span class="spaces"> </span><span class="istickedoff">key <- atomicModifyIORef' store $ \m -></span>
|
|
<span class="lineno"> 33 </span><span class="spaces"> </span><span class="istickedoff">case Map.maxViewWithKey m of</span>
|
|
<span class="lineno"> 34 </span><span class="spaces"> </span><span class="istickedoff">Nothing -> (Map.singleton 1 svg, 1)</span>
|
|
<span class="lineno"> 35 </span><span class="spaces"> </span><span class="istickedoff">Just ((maxKey,_),_) -></span>
|
|
<span class="lineno"> 36 </span><span class="spaces"> </span><span class="istickedoff"><span class="nottickedoff">(Map.insert (maxKey+1) svg m, maxKey+1)</span></span>
|
|
<span class="lineno"> 37 </span><span class="spaces"> </span><span class="istickedoff">bodyUserData body $= wordPtrToPtr key</span></span>
|
|
<span class="lineno"> 38 </span>
|
|
<span class="lineno"> 39 </span>renderBodyStore :: Space -> BodyStore -> IO Tree
|
|
<span class="lineno"> 40 </span><span class="decl"><span class="istickedoff">renderBodyStore space store = do</span>
|
|
<span class="lineno"> 41 </span><span class="spaces"> </span><span class="istickedoff">m <- readIORef store</span>
|
|
<span class="lineno"> 42 </span><span class="spaces"> </span><span class="istickedoff">lst <- newIORef []</span>
|
|
<span class="lineno"> 43 </span><span class="spaces"> </span><span class="istickedoff">spaceEachBody space (\body _dat -> do</span>
|
|
<span class="lineno"> 44 </span><span class="spaces"> </span><span class="istickedoff">key <- get (bodyUserData body)</span>
|
|
<span class="lineno"> 45 </span><span class="spaces"> </span><span class="istickedoff">case Map.lookup (ptrToWordPtr key) m of</span>
|
|
<span class="lineno"> 46 </span><span class="spaces"> </span><span class="istickedoff">Nothing -> <span class="nottickedoff">putStrLn "Body doesn't have an associated SVG"</span></span>
|
|
<span class="lineno"> 47 </span><span class="spaces"> </span><span class="istickedoff">Just svg -> do</span>
|
|
<span class="lineno"> 48 </span><span class="spaces"> </span><span class="istickedoff">Vect posX posY <- get $ bodyPosition body</span>
|
|
<span class="lineno"> 49 </span><span class="spaces"> </span><span class="istickedoff">angle <- get $ bodyAngle body</span>
|
|
<span class="lineno"> 50 </span><span class="spaces"> </span><span class="istickedoff">let bodySvg =</span>
|
|
<span class="lineno"> 51 </span><span class="spaces"> </span><span class="istickedoff">translate posX posY $</span>
|
|
<span class="lineno"> 52 </span><span class="spaces"> </span><span class="istickedoff">rotate (angle/pi*180)</span>
|
|
<span class="lineno"> 53 </span><span class="spaces"> </span><span class="istickedoff">svg</span>
|
|
<span class="lineno"> 54 </span><span class="spaces"> </span><span class="istickedoff">modifyIORef lst (bodySvg:)</span>
|
|
<span class="lineno"> 55 </span><span class="spaces"> </span><span class="istickedoff">) nullPtr</span>
|
|
<span class="lineno"> 56 </span><span class="spaces"> </span><span class="istickedoff">result <- readIORef lst</span>
|
|
<span class="lineno"> 57 </span><span class="spaces"> </span><span class="istickedoff">return $ mkGroup result</span></span>
|
|
<span class="lineno"> 58 </span>
|
|
<span class="lineno"> 59 </span>
|
|
<span class="lineno"> 60 </span>simulate :: Space -> BodyStore -> Double -> Int -> Double -> IO Animation
|
|
<span class="lineno"> 61 </span><span class="decl"><span class="istickedoff">simulate space store fps stepsPerFrame dur = do</span>
|
|
<span class="lineno"> 62 </span><span class="spaces"> </span><span class="istickedoff">let timeStep = 1/(fps*fromIntegral stepsPerFrame)</span>
|
|
<span class="lineno"> 63 </span><span class="spaces"> </span><span class="istickedoff">frames = round (dur * fps)</span>
|
|
<span class="lineno"> 64 </span><span class="spaces"> </span><span class="istickedoff">v <- V.new frames</span>
|
|
<span class="lineno"> 65 </span><span class="spaces"> </span><span class="istickedoff">forM_ [0..frames-1] $ \nth -> do</span>
|
|
<span class="lineno"> 66 </span><span class="spaces"> </span><span class="istickedoff">svg <- renderBodyStore space store</span>
|
|
<span class="lineno"> 67 </span><span class="spaces"> </span><span class="istickedoff">V.write v nth svg</span>
|
|
<span class="lineno"> 68 </span><span class="spaces"> </span><span class="istickedoff">replicateM_ stepsPerFrame $ spaceStep space timeStep</span>
|
|
<span class="lineno"> 69 </span><span class="spaces"> </span><span class="istickedoff">frozen <- V.unsafeFreeze v</span>
|
|
<span class="lineno"> 70 </span><span class="spaces"> </span><span class="istickedoff">return $ mkAnimation dur $ \t -></span>
|
|
<span class="lineno"> 71 </span><span class="spaces"> </span><span class="istickedoff">let key = round (t * fromIntegral (frames-1))</span>
|
|
<span class="lineno"> 72 </span><span class="spaces"> </span><span class="istickedoff">in frozen V.! key</span></span>
|
|
<span class="lineno"> 73 </span>
|
|
<span class="lineno"> 74 </span>polyShapesToBody :: Space -> [PolyShape] -> IO Body
|
|
<span class="lineno"> 75 </span><span class="decl"><span class="nottickedoff">polyShapesToBody space poly =</span>
|
|
<span class="lineno"> 76 </span><span class="spaces"> </span><span class="nottickedoff">polygonsToBody space (map (map toVect) $ plDecompose poly)</span>
|
|
<span class="lineno"> 77 </span><span class="spaces"> </span><span class="nottickedoff">where</span>
|
|
<span class="lineno"> 78 </span><span class="spaces"> </span><span class="nottickedoff">toVect (V2 x y) = Vect x y</span></span>
|
|
<span class="lineno"> 79 </span>
|
|
<span class="lineno"> 80 </span>polygonsToBody :: Space -> [[Vect]] -> IO Body
|
|
<span class="lineno"> 81 </span><span class="decl"><span class="nottickedoff">polygonsToBody space polygons = do</span>
|
|
<span class="lineno"> 82 </span><span class="spaces"> </span><span class="nottickedoff">plBody <- bodyNew 0 0</span>
|
|
<span class="lineno"> 83 </span><span class="spaces"> </span><span class="nottickedoff">spaceAddBody space plBody</span>
|
|
<span class="lineno"> 84 </span><span class="spaces"></span><span class="nottickedoff"></span>
|
|
<span class="lineno"> 85 </span><span class="spaces"> </span><span class="nottickedoff">forM_ polygons $ \vects -> do</span>
|
|
<span class="lineno"> 86 </span><span class="spaces"> </span><span class="nottickedoff">polyShape <- polyShapeNewRaw plBody vects 0.00</span>
|
|
<span class="lineno"> 87 </span><span class="spaces"> </span><span class="nottickedoff">shapeDensity polyShape $= 1</span>
|
|
<span class="lineno"> 88 </span><span class="spaces"> </span><span class="nottickedoff">spaceAddShape space polyShape</span>
|
|
<span class="lineno"> 89 </span><span class="spaces"> </span><span class="nottickedoff">shapeFriction polyShape $= 0.7</span>
|
|
<span class="lineno"> 90 </span><span class="spaces"> </span><span class="nottickedoff">shapeElasticity polyShape $= 0.5</span>
|
|
<span class="lineno"> 91 </span><span class="spaces"> </span><span class="nottickedoff">return plBody</span></span>
|
|
<span class="lineno"> 92 </span>
|
|
<span class="lineno"> 93 </span>spaceFreeRecursive :: Space -> IO ()
|
|
<span class="lineno"> 94 </span><span class="decl"><span class="nottickedoff">spaceFreeRecursive space = do</span>
|
|
<span class="lineno"> 95 </span><span class="spaces"> </span><span class="nottickedoff">spaceEachBody space (\body _ -> bodyFree body) nullPtr</span>
|
|
<span class="lineno"> 96 </span><span class="spaces"> </span><span class="nottickedoff">spaceEachShape space (\shape _ -> shapeFree shape) nullPtr</span>
|
|
<span class="lineno"> 97 </span><span class="spaces"> </span><span class="nottickedoff">spaceFree space</span></span>
|
|
|
|
</pre>
|
|
</body>
|
|
</html>
|