diff --git a/Chipmunk2D/src/cpSpace.c b/Chipmunk2D/src/cpSpace.c --- a/Chipmunk2D/src/cpSpace.c +++ b/Chipmunk2D/src/cpSpace.c @@ -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 diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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 `: ### 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. diff --git a/apecs-physics.cabal b/apecs-physics.cabal --- a/apecs-physics.cabal +++ b/apecs-physics.cabal @@ -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 diff --git a/src/Apecs/Physics.hs b/src/Apecs/Physics.hs --- a/src/Apecs/Physics.hs +++ b/src/Apecs/Physics.hs @@ -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, diff --git a/src/Apecs/Physics/Body.hs b/src/Apecs/Physics/Body.hs --- a/src/Apecs/Physics/Body.hs +++ b/src/Apecs/Physics/Body.hs @@ -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 diff --git a/src/Apecs/Physics/Collision.hs b/src/Apecs/Physics/Collision.hs --- a/src/Apecs/Physics/Collision.hs +++ b/src/Apecs/Physics/Collision.hs @@ -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 diff --git a/src/Apecs/Physics/Constraint.hs b/src/Apecs/Physics/Constraint.hs --- a/src/Apecs/Physics/Constraint.hs +++ b/src/Apecs/Physics/Constraint.hs @@ -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 diff --git a/src/Apecs/Physics/Shape.hs b/src/Apecs/Physics/Shape.hs --- a/src/Apecs/Physics/Shape.hs +++ b/src/Apecs/Physics/Shape.hs @@ -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 diff --git a/src/Apecs/Physics/Types.hs b/src/Apecs/Physics/Types.hs --- a/src/Apecs/Physics/Types.hs +++ b/src/Apecs/Physics/Types.hs @@ -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) -