Mai.hs

{-# 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