apecs-physics 0.2.0.0 → 0.3.0

raw patch · 9 files changed

+174/−184 lines, 9 filesdep ~apecsPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: apecs

API changes (from Hackage documentation)

Files

• Chipmunk2D/src/cpSpace.c +2/−2
• README.md +13/−13
• apecs-physics.cabal +3/−6
• src/Apecs/Physics.hs +4/−3
• src/Apecs/Physics/Body.hs +58/−29
• src/Apecs/Physics/Collision.hs +5/−3
• src/Apecs/Physics/Constraint.hs +22/−44
• src/Apecs/Physics/Shape.hs +27/−51
• src/Apecs/Physics/Types.hs +40/−33

@@ -123,8 +123,8 @@ #ifndef NDEBUG 	static cpBool done = cpFalse; 	if(!done){-		printf("phycs: Initializing new Space, Chipmunk v%s (Debug Enabled)\n", cpVersionString);-		printf("phycs: Compile with the -frelease (cabal) or --flag phycs:release (stack) to disable debug mode and runtime assertion checks\n");+		printf("apecs-physics: Initializing new Space, Chipmunk v%s (Debug Enabled)\n", cpVersionString);+		printf("apecs-physics: Compile with the -frelease (cabal) or --flag apecs-physics:release (stack) to disable debug mode and runtime assertion checks\n"); 		done = cpTrue; 	} #endif

@@ -1,16 +1,16 @@-# apecs-physics [![Build Status](https://travis-ci.org/jonascarpay/apecs-physics.svg?branch=master)](https://travis-ci.org/jonascarpay/apecs-physics)+# apecs-physics  2D physics library for apecs.-Uses [Chipmunk](https://github.com/slembcke/Chipmunk2D) for C-speed physics.-The [apecs-physics-gloss](https://github.com/jonascarpay/apecs-physics/tree/master/apecs-physics-gloss) package provides a simple optional [gloss](https://github.com/benl23x5/gloss)-based renderer.+Uses the [Chipmunk](https://github.com/slembcke/Chipmunk2D) physics engine.+The [apecs-gloss](../apecs-gloss) package provides a simple optional [gloss](https://github.com/benl23x5/gloss)-based renderer.  Feel free to create an issue or PR for suggestions/questions/requests/critiques/spelling fixes/etc.-See [TODO.md](https://github.com/jonascarpay/apecs-physics/blob/master/TODO.md) for suggestions if you want to help out with the code.+See [TODO.md](TODO.md) for suggestions if you want to help out with the code.  The examples directory contains a number of examples, each can be run with `stack build && stack <examplename>`:  ### helloworld-![Screenshot](https://raw.githubusercontent.com/jonascarpay/apecs-physics/master/examples/helloworld.png)+![Screenshot](helloworld.png)  ```haskell makeWorld "World" [''Physics, ''BodyPicture, ''Camera]@@ -22,11 +22,11 @@  ```haskell initialize = do-  setGlobal ( Camera (V2 0 1) 60-            , earthGravity )+  set global ( Camera (V2 0 1) 60+             , earthGravity ) ```-`setGlobal` comes from apecs, and is pretty straightforward.-`earthGravity = V2 0 (-9.81)`, normal earth surface gravity if we assume units to be mks.+Globals can be set with any entity argument, `global` is just an alias for -1.+`earthGravity = V2 0 (-9.81)`, normal earth surface gravity if we assume normal MKS units. Note that the positive y-axis points upwards.  ```haskell@@ -75,13 +75,13 @@ You can find its definition in `Apecs.Physics.Gloss`, in case you want to change the rendering behavior.  ### tumbler-![Screenshot](https://raw.githubusercontent.com/jonascarpay/apecs-physics/master/examples/tumbler.png)+![Screenshot](tumbler.png)  ```haskell initialize :: System World () initialize = do-  setGlobal ( Camera 0 50-            , earthGravity )+  set global ( Camera 0 50+             , earthGravity )    let sides = toEdges $ cRectangle 5   tumbler <- newEntity ( KinematicBody@@ -134,7 +134,7 @@ Finally, we randomly add a bunch of balls.  ### constraints-![Screenshot](https://raw.githubusercontent.com/jonascarpay/apecs-physics/master/examples/constraints.png)+![Screenshot](constraints.png)  The final example is a gallery of (some of) the available constraints. Drag shapes around with the left mouse button, create a new box with the right.

@@ -1,5 +1,5 @@ name:                apecs-physics-version:             0.2.0.0+version:             0.3.0 synopsis:            2D physics for apecs description:         2D physics for apecs. Uses Chipmunk physics library under the hood. homepage:            https://github.com/jonascarpay/apecs-physics#readme@@ -45,9 +45,6 @@   Chipmunk2D/include/chipmunk/cpPolyShape.h,   Chipmunk2D/include/chipmunk/cpPivotJoint.h --- source-repository HEAD   type:     git   location: git://github.com/jonascarpay/apecs.git@@ -80,7 +77,7 @@     Apecs.Physics.Query   build-depends:     base >= 4.7 && < 4.13,-    apecs >= 0.5.0.0,+    apecs,     containers,     inline-c,     linear,@@ -88,7 +85,7 @@     vector   ghc-options:     -Wall-    -O2+    -- -O2     -Wno-orphans     -Wno-unused-do-bind     -Wno-name-shadowing

@@ -12,12 +12,12 @@    -- * Body   Body (..), Position (..), Velocity (..), Angle (..), AngularVelocity (..), Force (..),-  BodyMass (..), Moment (..), CenterOfGravity (..), Torque (..),+  BodyMass (..), Moment (..), CenterOfGravity (..), Torque (..), ShapeList (..), ConstraintList (..),    -- * Shape-  Convex (..), Shape (Shape, ShapeExtend),+  Convex (..), Shape (..),   Mass (..), Density (..), Sensor (..), Friction (..), Elasticity (..), SurfaceVelocity (..), CollisionFilter (..),-  maskAll, maskNone, maskList, defaultFilter, boxShape,+  Bitmask (..), maskAll, maskNone, maskList, defaultFilter, boxShape,    -- * Constraint   Constraint (..), ConstraintType (..), MaxForce (..), MaxBias (..), ErrorBias (..), CollideBodies (..),@@ -33,6 +33,7 @@    -- * Geometry   module Apecs.Physics.Geometry,+  BVec, WVec,    module Apecs,   module Linear.V2,

@@ -56,9 +56,6 @@   cpSpaceRemoveBody($(cpSpace* space), body);   cpBodyFree(body); }|] -fromBodyPtr :: Ptr Body -> BodyRecord-fromBodyPtr ptr = BodyRecord ptr mempty mempty- instance Component Body where   type Storage Body = Space Body @@ -69,10 +66,12 @@   explSet (Space bMap _ _ _ spcPtr) ety btype = do     rd <- M.lookup ety <$> readIORef bMap     bdyPtr <- case rd of-                Just (BodyRecord bdyPtr _ _) -> return bdyPtr+                Just (BodyRecord bdyPtr _ _ _) -> return bdyPtr                 Nothing -> do                   bdyPtr <- newBody spcPtr ety-                  modifyIORef' bMap (M.insert ety $ fromBodyPtr bdyPtr)+                  bsMap <- newIORef mempty+                  bcMap <- newIORef mempty+                  modifyIORef' bMap (M.insert ety $ BodyRecord bdyPtr btype bsMap bcMap)                   return bdyPtr     setBodyType bdyPtr btype @@ -80,9 +79,9 @@   explDestroy sp@(Space bMap _ _ _ spc) ety = do     rd <- M.lookup ety <$> readIORef bMap     modifyIORef' bMap (M.delete ety)-    forM_ rd $ \(BodyRecord bPtr shapes constraints) -> do-      forM_ (S.toList shapes) $ \s -> explDestroy (cast sp :: Space Shape) s-      forM_ (S.toList constraints) $ \s -> explDestroy (cast sp :: Space Constraint) s+    forM_ rd $ \(BodyRecord bPtr _ shapes constraints) -> do+      readIORef shapes      >>= mapM_ (explDestroy (cast sp :: Space Shape))      . S.toList+      readIORef constraints >>= mapM_ (explDestroy (cast sp :: Space Constraint)) . S.toList       destroyBody spc bPtr  instance ExplMembers IO (Space Body) where@@ -90,10 +89,9 @@  instance ExplGet IO (Space Body) where   explExists (Space bMap _ _ _ _) ety = M.member ety <$> readIORef bMap-   explGet (Space bMap _ _ _ _) ety = do-    Just (BodyRecord b _ _) <- M.lookup ety <$> readIORef bMap-    getBodyType b+    Just (BodyRecord _ b _ _) <- M.lookup ety <$> readIORef bMap+    return b  -- Position getPosition :: Ptr Body -> IO (V2 Double)@@ -123,12 +121,12 @@ instance ExplSet IO (Space Position) where   explSet (Space bMap _ _ _ _) ety (Position pos) = do     rd <- M.lookup ety <$> readIORef bMap-    forM_ rd$ \(BodyRecord b _ _) -> setPosition b pos+    forM_ rd$ \(BodyRecord b _ _ _) -> setPosition b pos  instance ExplGet IO (Space Position) where   explExists s ety = explExists (cast s :: Space Body) ety   explGet (Space bMap _ _ _ _) ety = do-    Just (BodyRecord b _ _) <- M.lookup ety <$> readIORef bMap+    Just (BodyRecord b _ _ _) <- M.lookup ety <$> readIORef bMap     Position <$> getPosition b  -- Velocity@@ -156,12 +154,12 @@ instance ExplSet IO (Space Velocity) where   explSet (Space bMap _ _ _ _) ety (Velocity vel) = do     rd <- M.lookup ety <$> readIORef bMap-    forM_ rd$ \(BodyRecord b _ _) -> setVelocity b vel+    forM_ rd$ \(BodyRecord b _ _ _) -> setVelocity b vel  instance ExplGet IO (Space Velocity) where   explExists s ety = explExists (cast s :: Space Body) ety   explGet (Space bMap _ _ _ _) ety = do-    Just (BodyRecord b _ _) <- M.lookup ety <$> readIORef bMap+    Just (BodyRecord b _ _ _) <- M.lookup ety <$> readIORef bMap     Velocity <$> getVelocity b  -- Angle@@ -191,12 +189,12 @@ instance ExplSet IO (Space Angle) where   explSet (Space bMap _ _ _ _) ety (Angle angle) = do     rd <- M.lookup ety <$> readIORef bMap-    forM_ rd $ \(BodyRecord b _ _) -> setAngle b angle+    forM_ rd $ \(BodyRecord b _ _ _) -> setAngle b angle  instance ExplGet IO (Space Angle) where   explExists s ety = explExists (cast s :: Space Body) ety   explGet (Space bMap _ _ _ _) ety = do-    Just (BodyRecord b _ _) <- M.lookup ety <$> readIORef bMap+    Just (BodyRecord b _ _ _) <- M.lookup ety <$> readIORef bMap     Angle <$> getAngle b  -- AngularVelocity@@ -226,12 +224,12 @@ instance ExplSet IO (Space AngularVelocity) where   explSet (Space bMap _ _ _ _) ety (AngularVelocity angle) = do     rd <- M.lookup ety <$> readIORef bMap-    forM_ rd $ \(BodyRecord b _ _) -> setAngularVelocity b angle+    forM_ rd $ \(BodyRecord b _ _ _) -> setAngularVelocity b angle  instance ExplGet IO (Space AngularVelocity) where   explExists s ety = explExists (cast s :: Space Body) ety   explGet (Space bMap _ _ _ _) ety = do-    Just (BodyRecord b _ _) <- M.lookup ety <$> readIORef bMap+    Just (BodyRecord b _ _ _) <- M.lookup ety <$> readIORef bMap     AngularVelocity <$> getAngularVelocity b  -- Force@@ -259,12 +257,12 @@ instance ExplSet IO (Space Force) where   explSet (Space bMap _ _ _ _) ety (Force frc) = do     rd <- M.lookup ety <$> readIORef bMap-    forM_ rd$ \(BodyRecord b _ _) -> setForce b frc+    forM_ rd$ \(BodyRecord b _ _ _) -> setForce b frc  instance ExplGet IO (Space Force) where   explExists s ety = explExists (cast s :: Space Body) ety   explGet (Space bMap _ _ _ _) ety = do-    Just (BodyRecord b _ _) <- M.lookup ety <$> readIORef bMap+    Just (BodyRecord b _ _ _) <- M.lookup ety <$> readIORef bMap     Force <$> getForce b  -- BodyMass@@ -294,12 +292,12 @@ instance ExplSet IO (Space BodyMass) where   explSet (Space bMap _ _ _ _) ety (BodyMass angle) = do     rd <- M.lookup ety <$> readIORef bMap-    forM_ rd $ \(BodyRecord b _ _) -> setBodyMass b angle+    forM_ rd $ \(BodyRecord b _ _ _) -> setBodyMass b angle  instance ExplGet IO (Space BodyMass) where   explExists s ety = explExists (cast s :: Space Body) ety   explGet (Space bMap _ _ _ _) ety = do-    Just (BodyRecord b _ _) <- M.lookup ety <$> readIORef bMap+    Just (BodyRecord b _ _ _) <- M.lookup ety <$> readIORef bMap     BodyMass <$> getBodyMass b  -- Moment@@ -329,12 +327,12 @@ instance ExplSet IO (Space Moment) where   explSet (Space bMap _ _ _ _) ety (Moment angle) = do     rd <- M.lookup ety <$> readIORef bMap-    forM_ rd $ \(BodyRecord b _ _) -> setMoment b angle+    forM_ rd $ \(BodyRecord b _ _ _) -> setMoment b angle  instance ExplGet IO (Space Moment) where   explExists s ety = explExists (cast s :: Space Body) ety   explGet (Space bMap _ _ _ _) ety = do-    Just (BodyRecord b _ _) <- M.lookup ety <$> readIORef bMap+    Just (BodyRecord b _ _ _) <- M.lookup ety <$> readIORef bMap     Moment <$> getMoment b  -- Torque@@ -364,12 +362,12 @@ instance ExplSet IO (Space Torque) where   explSet (Space bMap _ _ _ _) ety (Torque angle) = do     rd <- M.lookup ety <$> readIORef bMap-    forM_ rd $ \(BodyRecord b _ _) -> setTorque b angle+    forM_ rd $ \(BodyRecord b _ _ _) -> setTorque b angle  instance ExplGet IO (Space Torque) where   explExists s ety = explExists (cast s :: Space Body) ety   explGet (Space bMap _ _ _ _) ety = do-    Just (BodyRecord b _ _) <- M.lookup ety <$> readIORef bMap+    Just (BodyRecord b _ _ _) <- M.lookup ety <$> readIORef bMap     Torque <$> getTorque b  -- CenterOfGravity@@ -397,11 +395,42 @@ instance ExplSet IO (Space CenterOfGravity) where   explSet (Space bMap _ _ _ _) ety (CenterOfGravity vel) = do     rd <- M.lookup ety <$> readIORef bMap-    forM_ rd$ \(BodyRecord b _ _) -> setCenterOfGravity b vel+    forM_ rd$ \(BodyRecord b _ _ _) -> setCenterOfGravity b vel  instance ExplGet IO (Space CenterOfGravity) where   explExists s ety = explExists (cast s :: Space Body) ety   explGet (Space bMap _ _ _ _) ety = do-    Just (BodyRecord b _ _) <- M.lookup ety <$> readIORef bMap+    Just (BodyRecord b _ _ _) <- M.lookup ety <$> readIORef bMap     CenterOfGravity <$> getCenterOfGravity b +-- ShapeList+instance Component ShapeList where+  type Storage ShapeList = Space ShapeList++instance Has w IO Physics => Has w IO ShapeList where+  getStore = (cast :: Space Physics -> Space ShapeList) <$> getStore++instance ExplMembers IO (Space ShapeList) where+  explMembers s = explMembers (cast s :: Space Body)++instance ExplGet IO (Space ShapeList) where+  explExists s ety = explExists (cast s :: Space Body) ety+  explGet (Space bMap _ _ _ _) ety = do+    Just (BodyRecord _ _ sPtr _) <- M.lookup ety <$> readIORef bMap+    ShapeList . fmap Entity . S.toList <$> readIORef sPtr++-- ConstraintList+instance Component ConstraintList where+  type Storage ConstraintList = Space ConstraintList++instance Has w IO Physics => Has w IO ConstraintList where+  getStore = (cast :: Space Physics -> Space ConstraintList) <$> getStore++instance ExplMembers IO (Space ConstraintList) where+  explMembers s = explMembers (cast s :: Space Body)++instance ExplGet IO (Space ConstraintList) where+  explExists s ety = explExists (cast s :: Space Body) ety+  explGet (Space bMap _ _ _ _) ety = do+    Just (BodyRecord _ _ sPtr _) <- M.lookup ety <$> readIORef bMap+    ConstraintList . fmap Entity . S.toList <$> readIORef sPtr

@@ -115,17 +115,19 @@   explSet sp@(Space _ _ _ hMap spcPtr) ety handler = do     explDestroy sp ety     hPtr <- newCollisionHandler spcPtr handler ety-    modifyIORef' hMap (M.insert ety hPtr)+    modifyIORef' hMap (M.insert ety (Record hPtr handler))  instance ExplDestroy IO (Space CollisionHandler) where   explDestroy (Space _ _ _ hMap _) ety = do     rd <- M.lookup ety <$> readIORef hMap-    forM_ rd$ \c -> destroyCollisionHandler c >> modifyIORef' hMap (M.delete ety)+    forM_ rd$ \(Record c _) -> destroyCollisionHandler c >> modifyIORef' hMap (M.delete ety)  instance ExplMembers IO (Space CollisionHandler) where   explMembers (Space _ _ _ hMap _) = U.fromList . M.keys <$> readIORef hMap  instance ExplGet IO (Space CollisionHandler) where   explExists (Space _ _ _ hMap _) ety = M.member ety <$> readIORef hMap-  explGet _ _ = return (error "CollisionHandler is a write-only component")+  explGet (Space _ _ _ hMap _) ety = do+    Just (Record _ handler) <- M.lookup ety <$> readIORef hMap+    return handler 

@@ -148,10 +148,7 @@   getStore = (cast :: Space Physics -> Space Constraint) <$> getStore  instance ExplSet IO (Space Constraint) where--  explSet _ _ ConstraintRead = return ()-  explSet s ety (Constraint b ctype) = explSet s ety (ConstraintExtend (Entity ety) b ctype)-  explSet sp@(Space bMap _ cMap _ spcPtr) cEty (ConstraintExtend (Entity bEtyA) (Entity bEtyB) ctype) = do+  explSet sp@(Space bMap _ cMap _ spcPtr) cEty cons@(Constraint (Entity bEtyA) (Entity bEtyB) ctype) = do     explDestroy sp cEty     mBrA <- M.lookup bEtyA <$> readIORef bMap     mBrB <- M.lookup bEtyB <$> readIORef bMap@@ -159,30 +156,21 @@       (Just brA, Just brB) -> do         cPtr <- newConstraint spcPtr (brPtr brA) (brPtr brB) cEty ctype -        let brConstraintsA' = S.insert cEty (brConstraints brA)-            brConstraintsB' = S.insert cEty (brConstraints brB)+        modifyIORef' cMap (M.insert cEty (Record cPtr cons))+        modifyIORef' (brConstraints brA) (S.insert cEty)+        modifyIORef' (brConstraints brB) (S.insert cEty) -        modifyIORef' cMap (M.insert cEty cPtr)-        modifyIORef' bMap ( M.insert bEtyA (brA {brConstraints = brConstraintsA'})-                          . M.insert bEtyB (brB {brConstraints = brConstraintsB'}) )       _ -> return ()  instance ExplDestroy IO (Space Constraint) where   explDestroy (Space bMap _ cMap _ spc) cEty = do     rd <- M.lookup cEty <$> readIORef cMap-    forM_ rd $ \cPtr -> do-      bEtyA <- getBodyA cPtr-      bEtyB <- getBodyB cPtr-      bMapRd <- readIORef bMap--      let Just bRecA = M.lookup bEtyA bMapRd-          Just bRecB = M.lookup bEtyB bMapRd-          brConstraintsA' = S.delete cEty (brConstraints bRecA)-          brConstraintsB' = S.delete cEty (brConstraints bRecB)--      modifyIORef' cMap (M.delete cEty)-      modifyIORef' bMap ( M.insert bEtyA (bRecA {brConstraints = brConstraintsA'})-                        . M.insert bEtyB (bRecB {brConstraints = brConstraintsB'}) )+    forM_ rd $ \(Record cPtr (Constraint (Entity bEtyA) (Entity bEtyB) _)) -> do+      bMap' <- readIORef bMap+      let rmConstraint ref = modifyIORef' (brConstraints ref) (S.delete cEty)+      mapM_ rmConstraint (M.lookup bEtyA bMap')+      mapM_ rmConstraint (M.lookup bEtyB bMap')+      modifyIORef' cMap $ M.delete cEty       destroyConstraint spc cPtr  instance ExplMembers IO (Space Constraint) where@@ -190,23 +178,13 @@  instance ExplGet IO (Space Constraint) where   explExists (Space _ _ cMap _ _) ety = M.member ety <$> readIORef cMap--  explGet _ _ = return ConstraintRead---- BodyAB-getBodyA :: Ptr Constraint -> IO Int-getBodyA c = fromIntegral <$> [C.exp| intptr_t {-  (intptr_t) cpBodyGetUserData(cpConstraintGetBodyA($(cpConstraint* c))) }|]--getBodyB :: Ptr Constraint -> IO Int-getBodyB c = fromIntegral <$> [C.exp| intptr_t {-  (intptr_t) cpBodyGetUserData(cpConstraintGetBodyB($(cpConstraint* c))) }|]+  explGet    (Space _ _ cMap _ _) ety = do+    Just (Record _ cons)  <- M.lookup ety <$> readIORef cMap+    return cons  -- MaxForce getMaxForce :: Ptr Constraint -> IO Double-getMaxForce c = do-  maxForce <- [C.exp| double { cpConstraintGetMaxForce ($(cpConstraint* c)) } |]-  return (realToFrac maxForce)+getMaxForce c = realToFrac <$> [C.exp| double { cpConstraintGetMaxForce ($(cpConstraint* c)) } |]  setMaxForce :: Ptr Constraint -> Double -> IO () setMaxForce c (realToFrac -> maxForce) = [C.exp| void { cpConstraintSetMaxForce($(cpConstraint* c), $(double maxForce)); } |]@@ -225,12 +203,12 @@     rd <- M.lookup ety <$> readIORef cMap     case rd of       Nothing -> return ()-      Just c  -> setMaxForce c vec+      Just (Record c _) -> setMaxForce c vec  instance ExplGet IO (Space MaxForce) where   explExists s ety = explExists (cast s :: Space Constraint) ety   explGet (Space _ _ cMap _ _) ety = do-    Just c <- M.lookup ety <$> readIORef cMap+    Just (Record c _) <- M.lookup ety <$> readIORef cMap     MaxForce <$> getMaxForce c  -- MaxBias@@ -256,11 +234,11 @@     rd <- M.lookup ety <$> readIORef cMap     case rd of       Nothing -> return ()-      Just c  -> setMaxBias c vec+      Just (Record c _) -> setMaxBias c vec  instance ExplGet IO (Space MaxBias) where   explGet (Space _ _ cMap _ _) ety = do-    Just c <- M.lookup ety <$> readIORef cMap+    Just (Record c _) <- M.lookup ety <$> readIORef cMap     MaxBias <$> getMaxBias c   explExists s ety = explExists (cast s :: Space Constraint) ety @@ -287,12 +265,12 @@     rd <- M.lookup ety <$> readIORef cMap     case rd of       Nothing -> return ()-      Just c  -> setErrorBias c vec+      Just (Record c _) -> setErrorBias c vec  instance ExplGet IO (Space ErrorBias) where   explExists s ety = explExists (cast s :: Space Constraint) ety   explGet (Space _ _ cMap _ _) ety = do-    Just c <- M.lookup ety <$> readIORef cMap+    Just (Record c _) <- M.lookup ety <$> readIORef cMap     ErrorBias <$> getErrorBias c  -- CollideBodies@@ -318,10 +296,10 @@     rd <- M.lookup ety <$> readIORef cMap     case rd of       Nothing -> return ()-      Just c  -> setCollideBodies c vec+      Just (Record c _) -> setCollideBodies c vec  instance ExplGet IO (Space CollideBodies) where   explExists s ety = explExists (cast s :: Space Constraint) ety   explGet (Space _ _ cMap _ _) ety = do-    Just c <- M.lookup ety <$> readIORef cMap+    Just (Record c _) <- M.lookup ety <$> readIORef cMap     CollideBodies <$> getCollideBodies c

@@ -35,6 +35,7 @@ maskAll, maskNone :: Bitmask maskAll  = complement zeroBits maskNone = zeroBits+-- | Makes a bitmask from a list of indices maskList :: [Int] -> Bitmask maskList = foldr (flip setBit) maskNone @@ -63,31 +64,25 @@ instance ExplDestroy IO (Space Shape) where   explDestroy (Space bMap sMap _ _ spc) sEty = do     rd <- M.lookup sEty <$> readIORef sMap-    forM_ rd $ \sPtr -> do-      bEty <- fromIntegral <$> getShapeBody sPtr--      Just bRec <- M.lookup bEty <$> readIORef bMap-      let brShapes' = S.delete sEty (brShapes bRec)-+    forM_ rd $ \(Record sPtr (Shape (Entity bEty) _)) -> do+      rd <- M.lookup bEty <$> readIORef bMap+      forM_ rd $ \bRec -> modifyIORef' (brShapes bRec) (S.delete sEty)       modifyIORef' sMap (M.delete sEty)-      modifyIORef' bMap (M.insert bEty (bRec {brShapes = brShapes'}))       destroyShape spc sPtr  instance ExplSet IO (Space Shape) where-  explSet _ _ ShapeRead = return ()-  explSet sp ety (Shape sh) = explSet sp ety (ShapeExtend (Entity ety) sh)--  explSet sp@(Space bMap sMap _ _ spcPtr) sEty (ShapeExtend (Entity bEty) sh) = do+  explSet sp@(Space bMap sMap _ _ spcPtr) sEty shape@(Shape (Entity bEty) sh) = do     explDestroy sp sEty     rd <- M.lookup bEty <$> readIORef bMap     forM_ rd $ \bRec -> do-      s <- newShape spcPtr (brPtr bRec) sh sEty-      let brShapes' = S.insert sEty (brShapes bRec)-      modifyIORef' bMap (M.insert bEty (bRec {brShapes = brShapes'}))-      modifyIORef' sMap (M.insert sEty s)+      shPtr <- newShape spcPtr (brPtr bRec) sh sEty+      modifyIORef' (brShapes bRec) (S.insert sEty)+      modifyIORef' sMap (M.insert sEty (Record shPtr shape))  instance ExplGet IO (Space Shape) where-  explGet _ _ = return ShapeRead+  explGet    (Space _ sMap _ _ _) ety = do+    Just (Record _ s) <- M.lookup ety <$> readIORef sMap+    return s   explExists (Space _ sMap _ _ _) ety = M.member ety <$> readIORef sMap  newShape :: SpacePtr -> Ptr Body -> Convex -> Int -> IO (Ptr Shape)@@ -146,12 +141,12 @@ instance ExplSet IO (Space Sensor) where   explSet (Space _ sMap _ _ _) ety (Sensor vec) = do     rd <- M.lookup ety <$> readIORef sMap-    forM_ rd$ \s -> setSensor s vec+    forM_ rd$ \(Record s _) -> setSensor s vec  instance ExplGet IO (Space Sensor) where   explExists s ety = explExists (cast s :: Space Shape) ety   explGet (Space _ sMap _ _ _) ety = do-    Just s <- M.lookup ety <$> readIORef sMap+    Just (Record s _) <- M.lookup ety <$> readIORef sMap     Sensor <$> getSensor s  -- Elasticity@@ -174,12 +169,12 @@ instance ExplSet IO (Space Elasticity) where   explSet (Space _ sMap _ _ _) ety (Elasticity vec) = do     rd <- M.lookup ety <$> readIORef sMap-    forM_ rd$ \s -> setElasticity s vec+    forM_ rd$ \(Record s _) -> setElasticity s vec  instance ExplGet IO (Space Elasticity) where   explExists s ety = explExists (cast s :: Space Shape) ety   explGet (Space _ sMap _ _ _) ety = do-    Just s <- M.lookup ety <$> readIORef sMap+    Just (Record s _) <- M.lookup ety <$> readIORef sMap     Elasticity <$> getElasticity s  -- Mass@@ -202,12 +197,12 @@ instance ExplSet IO (Space Mass) where   explSet (Space _ sMap _ _ _) ety (Mass vec) = do     rd <- M.lookup ety <$> readIORef sMap-    forM_ rd$ \s -> setMass s vec+    forM_ rd$ \(Record s _) -> setMass s vec  instance ExplGet IO (Space Mass) where   explExists s ety = explExists (cast s :: Space Shape) ety   explGet (Space _ sMap _ _ _) ety = do-    Just s <- M.lookup ety <$> readIORef sMap+    Just (Record s _) <- M.lookup ety <$> readIORef sMap     Mass <$> getMass s  -- Density@@ -230,12 +225,12 @@ instance ExplSet IO (Space Density) where   explSet (Space _ sMap _ _ _) ety (Density vec) = do     rd <- M.lookup ety <$> readIORef sMap-    forM_ rd$ \s -> setDensity s vec+    forM_ rd$ \(Record s _) -> setDensity s vec  instance ExplGet IO (Space Density) where   explExists s ety = explExists (cast s :: Space Shape) ety   explGet (Space _ sMap _ _ _) ety = do-    Just s <- M.lookup ety <$> readIORef sMap+    Just (Record s _) <- M.lookup ety <$> readIORef sMap     Density <$> getDensity s  -- Friction@@ -258,12 +253,12 @@ instance ExplSet IO (Space Friction) where   explSet (Space _ sMap _ _ _) ety (Friction vec) = do     rd <- M.lookup ety <$> readIORef sMap-    forM_ rd$ \s -> setFriction s vec+    forM_ rd$ \(Record s _) -> setFriction s vec  instance ExplGet IO (Space Friction) where   explExists s ety = explExists (cast s :: Space Shape) ety   explGet (Space _ sMap _ _ _) ety = do-    Just s <- M.lookup ety <$> readIORef sMap+    Just (Record s _) <- M.lookup ety <$> readIORef sMap     Friction <$> getFriction s  -- SurfaceVelocity@@ -290,12 +285,12 @@ instance ExplSet IO (Space SurfaceVelocity) where   explSet (Space _ sMap _ _ _) ety (SurfaceVelocity vec) = do     rd <- M.lookup ety <$> readIORef sMap-    forM_ rd$ \s -> setSurfaceVelocity s vec+    forM_ rd$ \(Record s _) -> setSurfaceVelocity s vec  instance ExplGet IO (Space SurfaceVelocity) where   explExists s ety = explExists (cast s :: Space Shape) ety   explGet (Space _ sMap _ _ _) ety = do-    Just s <- M.lookup ety <$> readIORef sMap+    Just (Record s _) <- M.lookup ety <$> readIORef sMap     SurfaceVelocity <$> getSurfaceVelocity s  -- CollisionFilter@@ -326,12 +321,12 @@ instance ExplSet IO (Space CollisionFilter) where   explSet (Space _ sMap _ _ _) ety cfilter = do     rd <- M.lookup ety <$> readIORef sMap-    forM_ rd$ \s -> setFilter s cfilter+    forM_ rd$ \(Record s _) -> setFilter s cfilter  instance ExplGet IO (Space CollisionFilter) where   explExists s ety = explExists (cast s :: Space Shape) ety   explGet (Space _ sMap _ _ _) ety = do-    Just s <- M.lookup ety <$> readIORef sMap+    Just (Record s _) <- M.lookup ety <$> readIORef sMap     getFilter s  -- CollisionType@@ -354,29 +349,10 @@ instance ExplSet IO (Space CollisionType) where   explSet (Space _ sMap _ _ _) ety (CollisionType vec) = do     rd <- M.lookup ety <$> readIORef sMap-    forM_ rd$ \s -> setCollisionType s vec+    forM_ rd$ \(Record s _) -> setCollisionType s vec  instance ExplGet IO (Space CollisionType) where   explExists s ety = explExists (cast s :: Space Shape) ety   explGet (Space _ sMap _ _ _) ety = do-    Just s <- M.lookup ety <$> readIORef sMap+    Just (Record s _) <- M.lookup ety <$> readIORef sMap     CollisionType <$> getCollisionType s---- ShapeBody-getShapeBody :: Ptr Shape -> IO C.CUIntPtr-getShapeBody shape = [C.exp| uintptr_t {-  (intptr_t) cpBodyGetUserData(cpShapeGetBody($(cpShape* shape))) }|]--instance Component ShapeBody where-  type Storage ShapeBody = Space ShapeBody-instance Has w IO Physics => Has w IO ShapeBody where-  getStore = (cast :: Space Physics -> Space ShapeBody) <$> getStore--instance ExplMembers IO (Space ShapeBody) where-  explMembers s = explMembers (cast s :: Space Shape)--instance ExplGet IO (Space ShapeBody) where-  explExists s ety = explExists (cast s :: Space Shape) ety-  explGet (Space _ sMap _ _ _) ety = do-    Just s <- M.lookup ety <$> readIORef sMap-    ShapeBody . Entity . fromIntegral <$> getShapeBody s

@@ -49,7 +49,7 @@   , (C.TypeName "cpSpace",            [t| FrnSpace         |])   ] --- | Uninhabited data type for constructing a world with a chipmunk space.+-- | Uninhabited, should be added to the world as a component to add a physics space. data Physics  -- | Vector type used by the library@@ -75,11 +75,14 @@ newtype AngularVelocity = AngularVelocity Double newtype CenterOfGravity = CenterOfGravity BVec +-- | The @Shape@s belonging to a body. Read-only.+newtype ShapeList = ShapeList [Entity]+-- | The @Constraint@s belonging to a body. Read-only.+newtype ConstraintList = ConstraintList [Entity]+ -- | Shape component. --   Adding a shape to an entity that has no @Body@ is a noop.-data Shape = Shape Convex-           | ShapeExtend Entity Convex-           | ShapeRead -- ^ Shapes are write-only, this is returned when you attempt to read+data Shape = Shape Entity Convex  -- | A convex polygon. --   Consists of a list of vertices, and a radius.@@ -92,7 +95,6 @@ newtype Friction        = Friction        Double     deriving (Eq, Show) newtype SurfaceVelocity = SurfaceVelocity Vec        deriving (Eq, Show) newtype CollisionType   = CollisionType   C.CUIntPtr deriving (Eq, Show)-newtype ShapeBody       = ShapeBody       Entity     deriving (Eq, Show)  type CollisionGroup = CUInt @@ -102,18 +104,19 @@   , filterMask       :: Bitmask   } deriving (Eq, Show) +-- | A bitmask used for collision handling newtype Bitmask = Bitmask CUInt deriving (Eq, Bits) instance Show Bitmask where-  show (Bitmask mask) = "Bitmask " ++ showIntAtBase 2 intToDigit mask ""+  show (Bitmask mask) = "Bitmask 0b" ++ showIntAtBase 2 intToDigit mask ""  data FrnSpace data FrnVec  data Space c = Space   { spBodies      :: IOMap BodyRecord-  , spShapes      :: PtrMap Shape-  , spConstraints :: PtrMap Constraint-  , spHandlers    :: PtrMap CollisionHandler+  , spShapes      :: IOMap (Record Shape)+  , spConstraints :: IOMap (Record Constraint)+  , spHandlers    :: IOMap (Record CollisionHandler)   , spacePtr      :: SpacePtr   } @@ -121,54 +124,59 @@  data BodyRecord = BodyRecord   { brPtr         :: Ptr Body-  , brShapes      :: S.IntSet-  , brConstraints :: S.IntSet+  , brBody        :: Body+  , brShapes      :: IORef S.IntSet+  , brConstraints :: IORef S.IntSet   } +data Record a = Record+  { recPtr :: Ptr a+  , recVal :: a+  }+ type IOMap a = IORef (M.IntMap a) type PtrMap a = IOMap (Ptr a) type SpacePtr = ForeignPtr FrnSpace  -- | Number of iterations per step, global value-newtype Iterations = Iterations Int+newtype Iterations = Iterations Int deriving (Eq, Show) -- | Gravity force vector, global value newtype Gravity = Gravity Vec deriving (Eq, Show) -- | Daming factor, global value-newtype Damping = Damping Double+newtype Damping = Damping Double deriving (Eq, Show) -- | Speed threshold to be considered idle, and a candidate for being put to sleep. Global value-newtype IdleSpeedThreshold = IdleSpeedThreshold Double+newtype IdleSpeedThreshold = IdleSpeedThreshold Double deriving (Eq, Show) -- | Sleep idle time threshold, global value-newtype SleepIdleTime = SleepIdleTime Double+newtype SleepIdleTime = SleepIdleTime Double deriving (Eq, Show) -- | Collision parameter, global value-newtype CollisionSlop = CollisionSlop Double+newtype CollisionSlop = CollisionSlop Double deriving (Eq, Show) -- | Collision parameter, global value-newtype CollisionBias = CollisionBias Double+newtype CollisionBias = CollisionBias Double deriving (Eq, Show)  cast :: Space a -> Space b cast (Space b s c h w) = Space b s c h w  -- Constraint subcomponents-newtype MaxForce      = MaxForce      Double-newtype MaxBias       = MaxBias       Double-newtype ErrorBias     = ErrorBias     Double-newtype CollideBodies = CollideBodies Bool+newtype MaxForce      = MaxForce      Double deriving (Eq, Show)+newtype MaxBias       = MaxBias       Double deriving (Eq, Show)+newtype ErrorBias     = ErrorBias     Double deriving (Eq, Show)+newtype CollideBodies = CollideBodies Bool   deriving (Eq, Show) -data Constraint = Constraint Entity ConstraintType-                | ConstraintExtend Entity Entity ConstraintType-                | ConstraintRead+data Constraint = Constraint Entity Entity ConstraintType deriving (Eq, Show)  data ConstraintType   = PinJoint BVec BVec -- ^ Maintains a fixed distance between two anchor points-  | SlideJoint BVec BVec Double Double -- offsetA offsetB min max+  | SlideJoint BVec BVec Double Double -- ^ A @PinJoint@ with minimum and maximum distance   | PivotJoint WVec -- ^ Creates a pivot point at the given world coordinate   | PivotJoint2 BVec BVec -- ^ Creates a pivot point at the given body coordinates-  | GrooveJoint BVec BVec BVec-  | DampedSpring BVec BVec Double Double Double -- offA offB restlength stiffness damping-  | DampedRotarySpring Double Double Double -- restAngle stiffness damping-  | RotaryLimitJoint Double Double -- min max-  | RatchetJoint Double Double -- phase ratchet-  | GearJoint Double Double -- phase ratio-  | SimpleMotor Double -- rate+  | GrooveJoint BVec BVec BVec -- ^ The first two vectors are the start and end of the groove on body A, the third argument is the anchor point on body B.+  | DampedSpring BVec BVec Double Double Double -- ^ Spring between two anchor points, with given rest length, stiffness, and damping.+  | DampedRotarySpring Double Double Double -- ^ Rotary sping, with given rest angle, stiffness, and damping.+  | RotaryLimitJoint Double Double -- ^ Joint with minimum and maximum angle+  | RatchetJoint Double Double -- ^ Rathet joint with given phase and ratchet (distance between clicks).+  | GearJoint Double Double -- Keeps angular velocity ratio constant. The first argument is phase, the initial offset, the second argument is the ratio+  | SimpleMotor Double -- ^ Keeps relative angular velocity constant+  deriving (Eq, Show)  -- TODO -- getConstraintImpulse@@ -225,4 +233,3 @@   , pqDistance :: Double   , pqGradient :: Double   } deriving (Eq, Show)-