Skip to content

Instantly share code, notes, and snippets.

@dpwiz
Created July 21, 2023 11:30
Show Gist options
  • Save dpwiz/34f195b0aa2191dd4c2f86ebea78814f to your computer and use it in GitHub Desktop.
Save dpwiz/34f195b0aa2191dd4c2f86ebea78814f to your computer and use it in GitHub Desktop.
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
module Main where
import Apecs
import Apecs.Physics
import Control.Concurrent
import Control.Monad
import Data.IORef
import System.IO.Unsafe (unsafePerformIO)
data Moving = Moving
instance Component Moving where
type Storage Moving = Unique Moving
makeWorld "World" [''Physics, ''Moving]
data ObjectCategory
= Player
| Projectile
| Obstacle
deriving (Eq, Ord, Show, Bounded, Enum)
collisionType :: Enum a => a -> CollisionType
collisionType = CollisionType . fromIntegral . (+1) . fromEnum
categories :: Enum a => [a] -> Bitmask
categories = maskList . map (fromIntegral . (+1) . fromEnum)
-- | An object without sub-parts.
pattern SINGLETON :: (Num group, Eq group) => group
pattern SINGLETON = 0
initialize :: System World ()
initialize = do
movingBody <- newEntity
( Moving
, DynamicBody
, Position $ V2 0 0
, Velocity $ V2 30 0
)
_movingShape <- newEntity
( Shape movingBody . cRectangle $ V2 10 10
, collisionType Projectile
, CollisionFilter
{ filterGroup = SINGLETON
, filterCategories = categories [Projectile]
, filterMask = categories [Player, Obstacle]
}
, Mass 10
)
obstacleBody <- newEntity (StaticBody, Position (V2 100 0))
_obstacleShape <- newEntity
( Shape obstacleBody . cRectangle $ V2 10 10
, collisionType Obstacle
, CollisionFilter
{ filterGroup = SINGLETON
, filterCategories = categories [Obstacle]
, filterMask = categories [Player, Projectile]
}
)
handlerProjectileVsObstacle <- createCollisionHandler $
Between (collisionType Projectile) (collisionType Obstacle)
_ <- newEntity handlerProjectileVsObstacle
-- XXX: would not fire - screened off by the previous handler
handlerObstacleVsProjectile <- createCollisionHandler $
Between (collisionType Obstacle) (collisionType Projectile)
_ <- newEntity handlerObstacleVsProjectile
-- XXX: would not fire if a more specific handler was used
handlerObstacleVsAll <- createCollisionHandler $ Wildcard (collisionType Obstacle)
_ <- newEntity handlerObstacleVsAll
handlerProjectileVsAll <- createCollisionHandler $ Wildcard (collisionType Projectile)
_ <- newEntity handlerProjectileVsAll
pure ()
createCollisionHandler :: CollisionSource -> System World CollisionHandler
createCollisionHandler source = do
begin <- mkBeginCB $ \huh -> liftIO $ do
currentStep <- readIORef stepN
bumpCalls
putStrLn $
"begin: " <> show (currentStep, huh)
pure True
separate <- mkSeparateCB $ \huh -> liftIO $ do
currentStep <- readIORef stepN
bumpCalls
putStrLn $
"separate: " <> show (currentStep, huh)
preSolve <- mkPreSolveCB $ \huh -> liftIO $ do
currentStep <- readIORef stepN
bumpCalls
putStrLn $
"preSolve: " <> show (currentStep, huh)
pure True
postSolve <- mkPostSolveCB $ \huh -> liftIO $ do
currentStep <- readIORef stepN
bumpCalls
putStrLn $
"postSolve: " <> show (currentStep, huh)
pure CollisionHandler
{ beginCB = Just begin
, separateCB = Nothing -- Just separate
, preSolveCB = Nothing -- Just preSolve
, postSolveCB = Nothing -- Just postSolve
, source = source
}
main :: IO ()
main = do
w <- initWorld
runWith w $ do
initialize
forM_ [0 .. 300] $ \step -> do
liftIO $ atomicWriteIORef stepN step
stepPhysics (1/60)
numCalls <- readIORef callbackCalls
if numCalls > 0 then
putStrLn $ "Callbacks called: " <> show numCalls
else
fail "Callbacks weren't called"
{-# NOINLINE callbackCalls #-}
callbackCalls :: IORef Int
callbackCalls = unsafePerformIO $ newIORef 0
bumpCalls =
atomicModifyIORef' callbackCalls $ \n ->
(n + 1, ())
{-# NOINLINE stepN #-}
stepN :: IORef Int
stepN = unsafePerformIO $ newIORef 0
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment