never executed always true always false

    1 module Reanimate.Chiphunk
    2   ( simulate
    3   , BodyStore
    4   , newBodyStore
    5   , addToBodyStore
    6   , spaceFreeRecursive
    7   , polyShapesToBody
    8   , polygonsToBody
    9   ) where
   10 
   11 import           Chiphunk.Low
   12 import           Control.Monad
   13 import           Data.IORef
   14 import           Data.Map            (Map)
   15 import qualified Data.Map            as Map
   16 import qualified Data.Vector         as V
   17 import qualified Data.Vector.Mutable as V
   18 import           Foreign.Ptr
   19 import           Graphics.SvgTree    (Tree)
   20 import           Linear.V2 (V2(..))
   21 import           Reanimate.Animation
   22 import           Reanimate.PolyShape
   23 import           Reanimate.Svg.Constructors
   24 
   25 type BodyStore = IORef (Map WordPtr Tree)
   26 
   27 newBodyStore :: IO BodyStore
   28 newBodyStore = newIORef Map.empty
   29 
   30 addToBodyStore :: BodyStore -> Body -> Tree -> IO ()
   31 addToBodyStore store body svg = do
   32   key <- atomicModifyIORef' store $ \m ->
   33           case Map.maxViewWithKey m of
   34             Nothing -> (Map.singleton 1 svg, 1)
   35             Just ((maxKey,_),_) ->
   36               (Map.insert (maxKey+1) svg m, maxKey+1)
   37   bodyUserData body $= wordPtrToPtr key
   38 
   39 renderBodyStore :: Space -> BodyStore -> IO Tree
   40 renderBodyStore space store = do
   41   m <- readIORef store
   42   lst <- newIORef []
   43   spaceEachBody space (\body _dat -> do
   44     key <- get (bodyUserData body)
   45     case Map.lookup (ptrToWordPtr key) m of
   46       Nothing -> putStrLn "Body doesn't have an associated SVG"
   47       Just svg -> do
   48         Vect posX posY <- get $ bodyPosition body
   49         angle <- get $ bodyAngle body
   50         let bodySvg =
   51               translate posX posY $
   52               rotate (angle/pi*180)
   53               svg
   54         modifyIORef lst (bodySvg:)
   55     ) nullPtr
   56   result <- readIORef lst
   57   return $ mkGroup result
   58 
   59 
   60 simulate :: Space -> BodyStore -> Double -> Int -> Double -> IO Animation
   61 simulate space store fps stepsPerFrame dur = do
   62   let timeStep = 1/(fps*fromIntegral stepsPerFrame)
   63       frames = round (dur * fps)
   64   v <- V.new frames
   65   forM_ [0..frames-1] $ \nth -> do
   66     svg <- renderBodyStore space store
   67     V.write v nth svg
   68     replicateM_ stepsPerFrame $ spaceStep space timeStep
   69   frozen <- V.unsafeFreeze v
   70   return $ mkAnimation dur $ \t ->
   71     let key = round (t * fromIntegral (frames-1))
   72     in frozen V.! key
   73 
   74 polyShapesToBody :: Space -> [PolyShape] -> IO Body
   75 polyShapesToBody space poly =
   76     polygonsToBody space (map (map toVect) $ plDecompose poly)
   77   where
   78     toVect (V2 x y) = Vect x y
   79 
   80 polygonsToBody :: Space -> [[Vect]] -> IO Body
   81 polygonsToBody space polygons = do
   82   plBody <- bodyNew 0 0
   83   spaceAddBody space plBody
   84 
   85   forM_ polygons $ \vects -> do
   86     polyShape <- polyShapeNewRaw plBody vects 0.00
   87     shapeDensity polyShape $= 1
   88     spaceAddShape space polyShape
   89     shapeFriction polyShape $= 0.7
   90     shapeElasticity polyShape $= 0.5
   91   return plBody
   92 
   93 spaceFreeRecursive :: Space -> IO ()
   94 spaceFreeRecursive space = do
   95   spaceEachBody space (\body _ -> bodyFree body) nullPtr
   96   spaceEachShape space (\shape _ -> shapeFree shape) nullPtr
   97   spaceFree space