Full swept AABB collision and resolution

Signed-off-by: magic_rb <richard@brezak.sk>

.dir-locals.el

@@ -0,0 +1 @@
+((haskell-mode . ((apheleia-formatter . fourmolu) (apheleia-mode . t))))

flake.lock

@@ -2,11 +2,11 @@
   "nodes": {
     "nixpkgs": {
       "locked": {
-        "lastModified": 1695145219,
+        "lastModified": 1700612854,
-        "narHash": "sha256-Eoe9IHbvmo5wEDeJXKFOpKUwxYJIOxKUesounVccNYk=",
+        "narHash": "sha256-yrQ8osMD+vDLGFX7pcwsY/Qr5PUd6OmDMYJZzZi0+zc=",
         "owner": "NixOS",
         "repo": "nixpkgs",
-        "rev": "5ba549eafcf3e33405e5f66decd1a72356632b96",
+        "rev": "19cbff58383a4ae384dea4d1d0c823d72b49d614",
         "type": "github"
       },
       "original": {

flake.nix

@@ -37,6 +37,7 @@
                   buildInputs = with pkgs; [
                     stdenv.cc
                     stack-wrapper
+                    hPkgs.fourmolu
                     hPkgs.ghc
                     hPkgs.implicit-hie
                     hPkgs.haskell-language-server
@@ -53,6 +54,7 @@
                     xorg.libXext
                     xorg.libXdmcp
                     libglvnd
+                    httplz
                     ((raylib.override { includeEverything = true; }).overrideAttrs (old: {
                       patches = [];
                       src = fetchFromGitHub {

fourmolu.yaml

@@ -0,0 +1,51 @@
+# Number of spaces per indentation step
+indentation: 2
+
+# Max line length for automatic line breaking
+column-limit: none
+
+# Styling of arrows in type signatures (choices: trailing, leading, or leading-args)
+function-arrows: leading
+
+# How to place commas in multi-line lists, records, etc. (choices: leading or trailing)
+comma-style: leading
+
+# Styling of import/export lists (choices: leading, trailing, or diff-friendly)
+import-export-style: diff-friendly
+
+# Whether to full-indent or half-indent 'where' bindings past the preceding body
+indent-wheres: false
+
+# Whether to leave a space before an opening record brace
+record-brace-space: false
+
+# Number of spaces between top-level declarations
+newlines-between-decls: 1
+
+# How to print Haddock comments (choices: single-line, multi-line, or multi-line-compact)
+haddock-style: multi-line
+
+# How to print module docstring
+haddock-style-module: null
+
+# Styling of let blocks (choices: auto, inline, newline, or mixed)
+let-style: auto
+
+# How to align the 'in' keyword with respect to the 'let' keyword (choices: left-align, right-align, or no-space)
+in-style: right-align
+
+# Whether to put parentheses around a single constraint (choices: auto, always, or never)
+single-constraint-parens: always
+
+# Output Unicode syntax (choices: detect, always, or never)
+unicode: never
+
+# Give the programmer more choice on where to insert blank lines
+respectful: true
+
+# Fixity information for operators
+fixities: []
+
+# Module reexports Fourmolu should know about
+reexports: []
+

rpg/minkowski/Main.hs

@@ -0,0 +1,7 @@
+module Main where
+
+import Executables.Minkowski
+
+main = do
+  print "test"
+  main'

rpg/package.yaml

@@ -23,6 +23,7 @@ dependencies:
 - base >= 4.7 && < 5
 - h-raylib
 - effectful
+- effectful-core
 - bytestring
 - text
 - lens
@@ -31,6 +32,7 @@ dependencies:
 - linear
 - extra
 - vector
+
 language: GHC2021
 default-extensions:
   - OverloadedStrings
@@ -66,6 +68,16 @@ executables:
     dependencies:
     - rpg
 
+  minkowski:
+    main:                Main.hs
+    source-dirs:         minkowski
+    ghc-options:
+    - -threaded
+    - -rtsopts
+    - -with-rtsopts=-N
+    dependencies:
+    - rpg
+
   pong:
     main:                Main.hs
     source-dirs:         pong

rpg/rpg.cabal

@@ -1,6 +1,6 @@
 cabal-version: 2.2
 
--- This file has been generated from package.yaml by hpack version 0.35.2.
+-- This file has been generated from package.yaml by hpack version 0.36.0.
 --
 -- see: https://github.com/sol/hpack
 
@@ -35,10 +35,12 @@ library
       Component.Position
       Component.TextBox
       Component.Velocity
+      Effectful.Accessor
       Effectful.Raylib
       Effectful.Reader.Static.State
       Effectful.State.Static.Local.Lens
       Engine
+      Executables.Minkowski
       Lib
       Pong
       System.Physics
@@ -65,6 +67,7 @@ library
     , base >=4.7 && <5
     , bytestring
     , effectful
+    , effectful-core
     , extra
     , h-raylib
     , lens
@@ -73,6 +76,39 @@ library
     , vector
   default-language: GHC2021
 
+executable minkowski
+  main-is: Main.hs
+  other-modules:
+      Paths_rpg
+  autogen-modules:
+      Paths_rpg
+  hs-source-dirs:
+      minkowski
+  default-extensions:
+      OverloadedStrings
+      DuplicateRecordFields
+      BlockArguments
+      OverloadedRecordDot
+      NoFieldSelectors
+      TemplateHaskell
+      LambdaCase
+  ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N
+  build-depends:
+      apecs
+    , apecs-effectful
+    , base >=4.7 && <5
+    , bytestring
+    , effectful
+    , effectful-core
+    , extra
+    , h-raylib
+    , lens
+    , linear
+    , rpg
+    , text
+    , vector
+  default-language: GHC2021
+
 executable pong
   main-is: Main.hs
   other-modules:
@@ -96,6 +132,7 @@ executable pong
     , base >=4.7 && <5
     , bytestring
     , effectful
+    , effectful-core
     , extra
     , h-raylib
     , lens
@@ -128,6 +165,7 @@ executable rpg-exe
     , base >=4.7 && <5
     , bytestring
     , effectful
+    , effectful-core
     , extra
     , h-raylib
     , lens
@@ -161,6 +199,7 @@ test-suite rpg-test
     , base >=4.7 && <5
     , bytestring
     , effectful
+    , effectful-core
     , extra
     , h-raylib
     , lens

rpg/src/Common.hs

@@ -1,37 +1,42 @@
 {-# LANGUAGE AllowAmbiguousTypes #-}
-module Common ( getCamera, playerMovement ) where
 
-import qualified Apecs.Effectful as AE
+module Common (getCamera, playerMovement) where
-import World
+
-import Effectful
+import Apecs.Effectful qualified as AE
-import qualified Raylib.Types as RL
-import GHC.Float
-import Linear.V2
 import Control.Lens
+import Effectful
 import Effectful.Raylib
+import GHC.Float
+import Linear (normalize)
+import Linear.V2
+import Raylib.Types qualified as RL
+import World
 
 getCamera
-  :: forall w es .
+  :: forall w es
-     ( AE.Get w CameraComponent
+   . ( AE.Get w CameraComponent
      , AE.Get w PositionComponent
      , AE.ECS w :> es
      )
   => Eff es AE.Entity
+  -- ^ entity to follow
   -> (Int, Int)
+  -- ^ dimensions
   -> Eff es RL.Camera2D
 getCamera eff (dimX, dimY) = do
   entity <- eff
   (c, Position (V2 x y)) <- AE.get @w @(CameraComponent, PositionComponent) entity
-  pure $ RL.Camera2D
+  pure $
-    { RL.camera2D'offset = RL.Vector2 (int2Float dimX / 2) (int2Float dimY / 2)
+    RL.Camera2D
-    , RL.camera2D'target = RL.Vector2 (x + fst c.offset) (y + snd c.offset)
+      { RL.camera2D'offset = RL.Vector2 (int2Float dimX / 2) (int2Float dimY / 2)
-    , RL.camera2D'rotation = 0.0
+      , RL.camera2D'target = RL.Vector2 (x + fst c.offset) (y + snd c.offset)
-    , RL.camera2D'zoom = int2Float (min dimX dimY) / int2Float c.zoom
+      , RL.camera2D'rotation = 0.0
-    }
+      , RL.camera2D'zoom = int2Float (min dimX dimY) / int2Float c.zoom
+      }
 
 playerMovement
-  :: forall w es .
+  :: forall w es
-     ( Raylib :> es
+   . ( Raylib :> es
      , AE.ECS w :> es
      , AE.Get w VelocityComponent
      )
@@ -45,11 +50,12 @@ playerMovement
   -> Eff es ()
 playerMovement player (left, right, up, down) speed = do
   directions <-
-    mapM (\tuple -> fst tuple <&> (, snd tuple))
+    mapM
-    [ ( isKeyDown left, V2 (-speed) 0 )
+      (\tuple -> fst tuple <&> (,snd tuple))
-    , ( isKeyDown right, V2 speed 0 )
+      [ (isKeyDown left, V2 (-1.0) 0)
-    , ( isKeyDown down, V2 0 speed )
+      , (isKeyDown right, V2 1.0 0)
-    , ( isKeyDown up, V2 0 (-speed) )
+      , (isKeyDown down, V2 0 1.0)
-    ]
+      , (isKeyDown up, V2 0 (-1.0))
+      ]
   let movement = foldl (+) (V2 0 0) $ map snd $ filter fst directions
-  AE.modify @w @() @VelocityComponent player (\() -> Velocity (movement ^. _x) (movement ^. _y))
+  AE.set @w @VelocityComponent player (Velocity (normalize movement * pure speed))

rpg/src/Component/AABB.hs

@@ -1,26 +1,76 @@
 {-# LANGUAGE TypeFamilies #-}
 
-module Component.AABB
+module Component.AABB (
-  ( AABBComponent(..)
+  AABBComponent (..),
-  , aabbBounds
+  size,
-  ) where
+  offset,
+  AABBBounds (..),
+  left,
+  right,
+  top,
+  bottom,
+  aabbBounds,
+  aabbFromBounds,
+) where
 
 import Apecs.Effectful
-import Linear.V2
-import Linear.V4
 import Component.Position
+import Control.Lens
+import Linear.V2
 
-data AABBComponent
+data AABBComponent = AABB
-  = AABB
   { size :: V2 Float
   , offset :: V2 Float
   }
-  deriving Show
+  deriving (Show)
 instance Component AABBComponent where type Storage AABBComponent = Map AABBComponent
+makeLensesFor
+  [ ("size", "size")
+  , ("offset", "offset")
+  ]
+  ''AABBComponent
 
-aabbBounds :: PositionComponent -> AABBComponent -> V4 Float
+data AABBBounds = AABBBounds
+  { left :: Float
+  , right :: Float
+  , top :: Float
+  , bottom :: Float
+  }
+  deriving (Show)
+makeLensesFor
+  [ ("left", "left")
+  , ("right", "right")
+  , ("top", "top")
+  , ("bottom", "bottom")
+  ]
+  ''AABBBounds
+
+aabbBounds :: PositionComponent -> AABBComponent -> AABBBounds
 aabbBounds (Position (V2 posX posY)) (AABB (V2 sizeX sizeY) (V2 offsetX offsetY)) =
-  V4 (posX + sizeX / 2 + offsetX)
+  AABBBounds
-     (posX - sizeX / 2 + offsetX)
+    { left = posX - sizeX / 2 + offsetX
-     (posY + sizeY / 2 + offsetY)
+    , right = posX + sizeX / 2 + offsetX
-     (posY - sizeY / 2 + offsetY)
+    , top = posY + sizeY / 2 + offsetY
+    , bottom = posY - sizeY / 2 + offsetY
+    }
+
+aabbFromBounds
+  :: AABBBounds
+  -- ^ AABB bounds
+  -> V2 Float
+  -- ^ the offset of the AABB from its origin
+  -> (PositionComponent, AABBComponent)
+  -- ^ a AABB component
+aabbFromBounds (AABBBounds left right top bottom) offset@(V2 offsetX offsetY) =
+  let
+    width = right - left
+    height = bottom - top
+    posX = left + width / 2 - offsetX
+    posY = top + height / 2 - offsetY
+   in
+    ( Position $ V2 posX posY
+    , AABB
+        { size = V2 width height
+        , offset = offset
+        }
+    )

rpg/src/Component/Position.hs

@@ -1,11 +1,15 @@
 {-# LANGUAGE TypeFamilies #-}
 
-module Component.Position (PositionComponent(..)) where
+module Component.Position (PositionComponent(..), position) where
 
 import Apecs.Effectful
 import Linear.V2
+import Control.Lens
 
 newtype PositionComponent
-  = Position (V2 Float)
+  = Position
+  { position :: V2 Float
+  }
   deriving Show
 instance Component PositionComponent where type Storage PositionComponent = Map PositionComponent
+makeLensesFor [("position", "position")] ''PositionComponent

rpg/src/Component/Velocity.hs

@@ -1,13 +1,13 @@
 {-# LANGUAGE TypeFamilies #-}
-module Component.Velocity (VelocityComponent(..)) where
+
+module Component.Velocity (VelocityComponent (..), unVelocity) where
 
 import Apecs.Effectful
+import Linear.V2
 
-data VelocityComponent
+newtype VelocityComponent = Velocity (V2 Float)
-  = Velocity
+  deriving (Show, Num)
-  { x :: Float
-  , y :: Float
-  }
-  deriving Show
 instance Component VelocityComponent where type Storage VelocityComponent = Map VelocityComponent
 
+unVelocity :: VelocityComponent -> V2 Float
+unVelocity (Velocity v) = v

rpg/src/Effectful/Accessor.hs

@@ -0,0 +1,47 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE AllowAmbiguousTypes #-}
+
+module Effectful.Accessor
+  ( Writes
+  , writeVal
+  , runWrites
+  , Reads
+  , readVal
+  , runReads
+  , runReadsWrites
+  ) where
+
+import Effectful
+import GHC.Exts (Symbol)
+import Effectful.Dispatch.Dynamic
+
+data Writes (name :: Symbol) a :: Effect where
+  WriteVal :: forall name a es . a -> (Writes name a) es ()
+type instance DispatchOf (Writes name a) = Dynamic
+
+writeVal :: forall name a es . ( Writes name a :> es, HasCallStack ) => a -> Eff es ()
+writeVal val = send (WriteVal @name @a val)
+
+runWrites :: forall name a es b . (a -> Eff es ()) -> Eff (Writes name a : es) b -> Eff es b
+runWrites action = interpret \_ -> \case
+  WriteVal a -> inject (action a)
+
+data Reads (name :: Symbol) a :: Effect where
+  ReadVal :: (Reads name a) es a
+type instance DispatchOf (Reads name a) = Dynamic
+
+readVal :: forall name a es . ( Reads name a :> es, HasCallStack ) => Eff es a
+readVal = send (ReadVal @name @a)
+
+runReads :: forall name a es b . Eff es a -> Eff (Reads name a : es) b -> Eff es b
+runReads action = interpret \_ -> \case
+  ReadVal -> inject action
+
+runReadsWrites
+  :: forall name a es b .
+     Eff es a
+  -> (a -> Eff es ())
+  -> Eff (Reads name a : Writes name a : es) b
+  -> Eff es b
+runReadsWrites getter setter = runWrites @name @a setter . runReads @name @a (inject getter)

rpg/src/Effectful/Raylib.hs

@@ -1,32 +1,38 @@
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE TypeFamilies #-}
-module Effectful.Raylib
-  ( setTargetFPS
-  , windowShouldClose
-  , getFontDefault
-  , isKeyDown
-  , runDraw
-  , clearBackground
-  , runDraw2D
-  , measureText
-  , drawText
-  , drawRectangle
-  , drawLine
-  , runRaylibWindow
-  , Raylib
-  , RaylibDraw
-  , RaylibDraw2D
-  ) where
 
-import Effectful
+module Effectful.Raylib (
-import qualified Raylib.Types as RL
+  setTargetFPS,
+  windowShouldClose,
+  getFontDefault,
+  isKeyDown,
+  runDraw,
+  getMousePosition,
+  getScreenToWorld2D,
+  isMouseButtonPressed,
+  isMouseButtonReleased,
+  clearBackground,
+  runDraw2D,
+  measureText,
+  drawText,
+  drawRectangle,
+  drawLine,
+  runRaylibWindow,
+  Raylib,
+  RaylibDraw,
+  RaylibDraw2D,
+) where
+
+import Control.Lens
 import Data.Text (Text)
+import Data.Text qualified as T
+import Effectful
 import Effectful.Dispatch.Dynamic
-import qualified Raylib.Core as RL
-import qualified Data.Text as T
-import qualified Raylib.Core.Text as RL
-import qualified Raylib.Core.Shapes as RL
 import Linear (V2 (..))
+import Raylib.Core qualified as RL
+import Raylib.Core.Shapes qualified as RL
+import Raylib.Core.Text qualified as RL
+import Raylib.Types qualified as RL
 
 data Raylib :: Effect where
   SetTargetFPS :: Int -> Raylib (Eff es) ()
@@ -34,10 +40,14 @@ data Raylib :: Effect where
   GetFontDefault :: Raylib (Eff es) RL.Font
   IsKeyDown :: RL.KeyboardKey -> Raylib (Eff es) Bool
   RunDraw :: (IOE :> es) => Eff (RaylibDraw : es) a -> Raylib (Eff es) a
+  GetMousePosition :: Raylib (Eff es) (V2 Int)
+  GetScreenToWorld2D :: V2 Int -> RL.Camera2D -> Raylib (Eff es) (V2 Float)
+  IsMouseButtonPressed :: RL.MouseButton -> Raylib (Eff es) Bool
+  IsMouseButtonReleased :: RL.MouseButton -> Raylib (Eff es) Bool
 type instance DispatchOf Raylib = Dynamic
 
 data RaylibDraw :: Effect where
-  ClearBackground  :: RL.Color -> RaylibDraw (Eff es) ()
+  ClearBackground :: RL.Color -> RaylibDraw (Eff es) ()
   RunDraw2D :: (IOE :> es) => RL.Camera2D -> Eff (RaylibDraw2D : es) a -> RaylibDraw (Eff es) a
 type instance DispatchOf RaylibDraw = Dynamic
 
@@ -63,6 +73,18 @@ isKeyDown key = send (IsKeyDown key)
 runDraw :: (HasCallStack, IOE :> es, Raylib :> es) => Eff (RaylibDraw : es) a -> Eff es a
 runDraw effect = send (RunDraw effect)
 
+getMousePosition :: (HasCallStack, Raylib :> es) => Eff es (V2 Int)
+getMousePosition = send GetMousePosition
+
+getScreenToWorld2D :: (HasCallStack, Raylib :> es) => V2 Int -> RL.Camera2D -> Eff es (V2 Float)
+getScreenToWorld2D vector camera = send (GetScreenToWorld2D vector camera)
+
+isMouseButtonPressed :: (HasCallStack, Raylib :> es) => RL.MouseButton -> Eff es Bool
+isMouseButtonPressed mouseButton = send (IsMouseButtonPressed mouseButton)
+
+isMouseButtonReleased :: (HasCallStack, Raylib :> es) => RL.MouseButton -> Eff es Bool
+isMouseButtonReleased mouseButton = send (IsMouseButtonReleased mouseButton)
+
 clearBackground :: (HasCallStack, RaylibDraw :> es) => RL.Color -> Eff es ()
 clearBackground color = send (ClearBackground color)
 
@@ -92,37 +114,44 @@ runRaylibWindow width height name effect = do
       SetTargetFPS fps -> liftIO $ RL.setTargetFPS fps
       IsKeyDown key -> liftIO $ RL.isKeyDown key
       RunDraw drawEffect -> unlift $ runRaylibDrawing drawEffect
+      GetMousePosition -> liftIO $ RL.getMousePosition <&> \(RL.Vector2 x y) -> V2 (floor x) (floor y)
+      GetScreenToWorld2D (V2 xi yi) camera ->
+        liftIO $
+          RL.getScreenToWorld2D (RL.Vector2 (fromIntegral xi) (fromIntegral yi)) camera
+            <&> \(RL.Vector2 x y) -> V2 x y
+      IsMouseButtonPressed mouseButton -> liftIO $ RL.isMouseButtonPressed mouseButton
+      IsMouseButtonReleased mouseButton -> liftIO $ RL.isMouseButtonReleased mouseButton
 
   liftIO $ RL.closeWindow window
-   where
+ where
-     runRaylibDrawing :: (IOE :> es) => Eff (RaylibDraw : es) a -> Eff es a
+  runRaylibDrawing :: (IOE :> es) => Eff (RaylibDraw : es) a -> Eff es a
-     runRaylibDrawing effect' = do
+  runRaylibDrawing effect' = do
-       liftIO RL.beginDrawing
+    liftIO RL.beginDrawing
-       res <- interpret' effect' $ \env eff -> localSeqUnlift env \unlift ->
+    res <- interpret' effect' $ \env eff -> localSeqUnlift env \unlift ->
-         case eff of
+      case eff of
-           ClearBackground color -> liftIO $ RL.clearBackground color
+        ClearBackground color -> liftIO $ RL.clearBackground color
-           RunDraw2D camera draw2dEffect -> unlift $ runRaylibDrawing2d camera draw2dEffect
+        RunDraw2D camera draw2dEffect -> unlift $ runRaylibDrawing2d camera draw2dEffect
-       liftIO RL.endDrawing
+    liftIO RL.endDrawing
-       pure res
+    pure res
 
-     runRaylibDrawing2d :: (IOE :> es) => RL.Camera2D -> Eff (RaylibDraw2D : es) a -> Eff es a
+  runRaylibDrawing2d :: (IOE :> es) => RL.Camera2D -> Eff (RaylibDraw2D : es) a -> Eff es a
-     runRaylibDrawing2d camera effect' = do
+  runRaylibDrawing2d camera effect' = do
-       liftIO (RL.beginMode2D camera)
+    liftIO (RL.beginMode2D camera)
-       res <- interpret' effect' $ \env eff -> localSeqUnlift env \unlift ->
+    res <- interpret' effect' $ \env eff -> localSeqUnlift env \unlift ->
-         case eff of
+      case eff of
-           MeasureText font text fontSize spacing -> do
+        MeasureText font text fontSize spacing -> do
-             RL.Vector2 x y <- liftIO $ RL.measureTextEx font (T.unpack text) fontSize spacing
+          RL.Vector2 x y <- liftIO $ RL.measureTextEx font (T.unpack text) fontSize spacing
-             pure (V2 x y)
+          pure (V2 x y)
-           DrawText font text (V2 posX posY) fontSize spacing color ->
+        DrawText font text (V2 posX posY) fontSize spacing color ->
-             liftIO $ RL.drawTextEx font (T.unpack text) (RL.Vector2 posX posY) fontSize spacing color
+          liftIO $ RL.drawTextEx font (T.unpack text) (RL.Vector2 posX posY) fontSize spacing color
-           DrawRectangle posX posY width height color -> liftIO $ RL.drawRectangleV (RL.Vector2 posX posY) (RL.Vector2 width height) color
+        DrawRectangle posX posY width height color -> liftIO $ RL.drawRectangleV (RL.Vector2 posX posY) (RL.Vector2 width height) color
-           DrawLine startX startY endX endY color -> liftIO $ RL.drawLineV (RL.Vector2 startX startY) (RL.Vector2 endX endY) color
+        DrawLine startX startY endX endY color -> liftIO $ RL.drawLineV (RL.Vector2 startX startY) (RL.Vector2 endX endY) color
-       liftIO RL.endMode2D
+    liftIO RL.endMode2D
-       pure res
+    pure res
 
-     interpret'
+  interpret'
-       :: DispatchOf e ~ Dynamic
+    :: (DispatchOf e ~ Dynamic)
-       => Eff (e ': es) a
+    => Eff (e ': es) a
-       -> EffectHandler e es
+    -> EffectHandler e es
-       -> Eff es a
+    -> Eff es a
-     interpret' eff handler = interpret handler eff
+  interpret' eff handler = interpret handler eff

rpg/src/Engine.hs

@@ -1,63 +1,123 @@
 {-# LANGUAGE AllowAmbiguousTypes #-}
 {-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE UndecidableInstances #-}
 
-module Engine ( Engine(..), runEngine ) where
+module Engine (Engine (..), engineInput, enginePhysics, engineRendering, initialEngine, EngineConstraint, startEngine) where
 
+import Apecs.Effectful qualified as AE
+import Data.Kind
 import Effectful
-import System.Physics
+import Effectful.Accessor
-import World
+import Effectful.Dispatch.Dynamic
-import qualified Apecs.Effectful as AE
+import Effectful.Dispatch.Static
-import qualified Raylib.Types as RL
+import Effectful.Internal.Monad
-import System.Renderer
 import Effectful.Raylib
+import GHC.Exts
+import Raylib.Types qualified as RL
+import System.Physics
+import System.Renderer
+import World
 
-class Engine es a where
+data EngineOps es = EngineOps
-  engineInput :: a -> Eff es ()
+  { input :: Eff es ()
-  engineInput _ = pure ()
+  , physics :: Eff es ()
-  enginePhysics :: a -> Eff es ()
+  , rendering :: Eff es ()
-  enginePhysics _ = pure ()
+  }
-  engineRendering :: a -> Eff es ()
-  engineRendering _ = pure ()
-  engineGetCamera :: a -> Eff es RL.Camera2D
-  engineClearColor :: a -> Eff es RL.Color
 
-runEngine
+data Engine :: Effect where
-  :: forall w es a .
+  EngineInput :: Engine (Eff es) ()
-     ( Engine es a
+  EnginePhysics :: Engine (Eff es) ()
-     , AE.Get w PositionComponent
+  EngineRendering :: (SharedSuffix es2 es, RaylibDraw :> es2, RaylibDraw2D :> es2) => (forall r. Eff es2 r -> Eff es r) -> Engine (Eff es) ()
-     , AE.Get w BodyComponent
+type instance DispatchOf Engine = Dynamic
-     , AE.Get w AABBComponent
+
-     , AE.Get w BoxComponent
+engineInput :: (HasCallStack, Engine :> es) => Eff es ()
-     , AE.Get w TextBoxComponent
+engineInput = send EngineInput
-     , AE.Get w CollisionComponent
+
-     , AE.Get w VelocityComponent
+enginePhysics :: (HasCallStack, Engine :> es) => Eff es ()
-     , IOE :> es
+enginePhysics = send EnginePhysics
-     , Raylib :> es
+
-     , AE.ECS w :> es
+engineRendering :: forall es. (HasCallStack, Engine :> es, SharedSuffix es es, RaylibDraw :> es, RaylibDraw2D :> es) => Eff es ()
+engineRendering = unsafeEff $ \env -> (`unEff` env) $ localSeqUnlift @_ @es (LocalEnv env) (\unlift -> send $ EngineRendering unlift)
+
+class EngineConstraints where
+  type EngineConstraint (camera :: Symbol) (backgroundColor :: Symbol) (es :: [Effect]) (w :: Type) :: Constraint
+instance EngineConstraints where
+  type
+    EngineConstraint camera backgroundColor es w =
+      ( AE.Get w PositionComponent
+      , AE.Get w BodyComponent
+      , AE.Get w AABBComponent
+      , AE.Get w BoxComponent
+      , AE.Get w TextBoxComponent
+      , AE.Get w CollisionComponent
+      , AE.Get w VelocityComponent
+      , Reads camera RL.Camera2D :> es
+      , Reads backgroundColor RL.Color :> es
+      , IOE :> es
+      , Raylib :> es
+      , AE.ECS w :> es
+      )
+
+initialEngine
+  :: forall (es :: [Effect])
+   . EngineOps es
+initialEngine =
+  EngineOps
+    { input = pure ()
+    , physics = pure ()
+    , rendering = pure ()
+    }
+
+-- inlineBracket
+--     (consEnv e dummyRelinker es0)
+--     unconsEnv
+--     (\es -> unEff m es)
+
+injectEngine :: forall xs ys. (Subset xs ys) => EngineOps xs -> EngineOps ys
+injectEngine engine =
+  EngineOps
+    { input = inject engine.input
+    , physics = inject engine.physics
+    , rendering = inject engine.rendering
+    }
+
+raiseEngine :: forall e es. EngineOps es -> EngineOps (e : es)
+raiseEngine engine =
+  EngineOps
+    { input = raise engine.input
+    , physics = raise engine.physics
+    , rendering = raise engine.rendering
+    }
+
+startEngine
+  :: forall
+    (camera :: Symbol)
+    (backgroundColor :: Symbol)
+    (w :: Type)
+    es
+   . ( EngineConstraint camera backgroundColor es w
+     , Engine :> es
      )
-  => a
+  => Eff es ()
-  -> Eff es ()
+startEngine = do
-runEngine engine = do
+  engineInput
-  engineInput engine
+  applyVelocity'' @w
-
-  applyVelocity @w
 
   collisionAABB @w
   resolveAABB @w
 
-  enginePhysics engine
+  enginePhysics
 
-  c <- engineGetCamera engine
+  c <- readVal @camera @RL.Camera2D
 
   runDraw . runDraw2D c $ do
-    color <- inject $ engineClearColor engine
+    color <- readVal @backgroundColor @RL.Color
     clearBackground color
 
-    inject $ engineRendering engine
-
     render @w
     renderOrigins @w
     renderBoundingBoxes @w
     renderCollision @w
 
+    engineRendering

rpg/src/Executables/Minkowski.hs

@@ -0,0 +1,213 @@
+{-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+module Executables.Minkowski (main') where
+
+import Apecs.Effectful qualified as AE
+import Common
+import Control.Lens hiding ((%=), (.=))
+import Control.Monad.Extra
+import Data.Maybe (isJust)
+import Effectful
+import Effectful.Accessor
+import Effectful.Dispatch.Dynamic
+import Effectful.Raylib
+import Effectful.Raylib qualified as RL
+import Effectful.Reader.Static
+import Effectful.State.Static.Local
+import Effectful.State.Static.Local.Lens
+import Engine
+import Linear (normalize)
+import Linear.V2 (V2 (..), _x, _y)
+import Raylib.Types qualified as RL
+import Raylib.Util.Colors qualified as RL
+import System.Physics
+import World
+
+data GameState = GameState
+  { cameraEntity :: AE.Entity
+  , windowDimensions :: V2 Int
+  , selectedBox :: Maybe (V2 Float, AE.Entity)
+  , boxes :: (AE.Entity, AE.Entity)
+  , minkowski :: AE.Entity
+  }
+  deriving (Show)
+makeLensesFor
+  [ ("cameraEntity", "cameraEntity")
+  , ("windowDimensions", "windowDimensions")
+  , ("selectedBox", "selectedBox")
+  , ("boxes", "boxes")
+  , ("minkowski", "minkowski")
+  ]
+  ''GameState
+
+data GameConfig = GameConfig
+  { backgroundColor :: RL.Color
+  }
+  deriving (Show)
+makeLensesFor
+  [ ("backgroundColor", "backgroundColor")
+  ]
+  ''GameConfig
+
+runGameState
+  :: (AE.ECS World :> es)
+  => Eff (State GameState : es) ()
+  -> Eff es ()
+runGameState action = do
+  cameraEntity' <-
+    AE.newEntity @World
+      ( Position $ V2 0 0
+      , Camera 10 (0, 0)
+      )
+
+  box1 <-
+    AE.newEntity @World
+      ( Position $ V2 0 0
+      , Box RL.green (0, 0) (1, 1)
+      , AABB (V2 1 1) (V2 0 0)
+      )
+
+  box2 <-
+    AE.newEntity @World
+      ( Position $ V2 2 0
+      , Box RL.green (0, 0) (1, 1)
+      , AABB (V2 1 1) (V2 0 0)
+      )
+
+  minkowski' <-
+    AE.newEntity @World
+      ( Position $ V2 (-2) 0
+      , AABB (V2 2 2) (V2 0 0)
+      )
+
+  flip evalState action $
+    GameState
+      { cameraEntity = cameraEntity'
+      , windowDimensions = V2 640 480
+      , selectedBox = Nothing
+      , boxes = (box1, box2)
+      , minkowski = minkowski'
+      }
+
+runGameConfig
+  :: Eff (Reader GameConfig : es) () -> Eff es ()
+runGameConfig =
+  runReader $
+    GameConfig
+      { backgroundColor = RL.gray
+      }
+
+readsCamera
+  :: ( State GameState :> es
+     , AE.ECS World :> es
+     )
+  => Eff es RL.Camera2D
+readsCamera = do
+  windowDimensions <- gets @GameState \s -> (s ^. windowDimensions . _x, s ^. windowDimensions . _y)
+  camera <- gets @GameState \s -> s.cameraEntity
+  getCamera
+    @World
+    (pure camera)
+    windowDimensions
+
+runEngine :: forall es. (IOE :> es, AE.ECS World :> es, State GameState :> es, Raylib :> es) => Eff (Engine : es) () -> Eff es ()
+runEngine = interpret \env eff ->
+  case eff of
+    EngineInput -> do
+      camera <- readsCamera
+      pos <- getMousePosition >>= \pos -> getScreenToWorld2D pos camera
+
+      isMouseButtonPressed RL.MouseButtonLeft >>= \case
+        True -> do
+          AE.cfold @World @(AE.Entity, PositionComponent, AABBComponent)
+            (\acc (entity, position, aabb) -> (pointCollides pos position aabb <&> (,entity)) : acc)
+            []
+            <&> filter isJust
+            >>= \case
+              Just (offset, entity) : _ -> selectedBox .= Just (offset, entity)
+              _ -> pure ()
+        False -> pure ()
+      isMouseButtonReleased RL.MouseButtonLeft >>= \case
+        True -> do
+          selectedBox' <- gets @GameState \s -> s.selectedBox
+          case selectedBox' of
+            Just (_, boxEntity) ->
+              AE.set @World @VelocityComponent boxEntity (Velocity $ V2 0 0)
+            Nothing -> pure ()
+          selectedBox .= Nothing
+        False -> pure ()
+
+      box <- gets @GameState \s -> s.selectedBox
+      (box1, box2) <- gets @GameState \s -> s.boxes
+      box1' <- AE.get @World @(PositionComponent, AABBComponent) box1
+      box2' <- AE.get @World @(PositionComponent, AABBComponent) box2
+      minkowski' <- gets @GameState \s -> s.minkowski
+
+      case box of
+        Just (_, box') -> do
+          Position bpos <- AE.get @World @PositionComponent box'
+          let offset = pos - bpos
+          let (mpos, maabb) = aabbFromBounds (minkowskiDifference box1' box2') (V2 0 0)
+          -- liftIO $ print (Velocity (offset ^. _x) (offset ^. _y))
+          AE.set @World minkowski' (mpos, maabb)
+          AE.set @World box' (Velocity $ V2 (offset ^. _x) (offset ^. _y))
+        Nothing -> pure ()
+    EnginePhysics -> pure ()
+    EngineRendering unlift' -> do
+      (box1, box2) <- gets @GameState \s -> s.boxes
+      box1Position <- AE.get @World @PositionComponent box1
+      (box2Position, box2AABB) <- AE.get @World @(PositionComponent, AABBComponent) box2
+      let ray = Ray . normalize $ V2 (box1Position ^. position . _x - box2Position ^. position . _x) (box1Position ^. position . _y - box2Position ^. position . _y)
+      let collision = rayCollides box1Position (ray, ray) box2Position box2AABB
+      case collision of
+        Just collision -> localSeqUnlift env \unlift ->
+          unlift . unlift' $ RL.drawLine (box1Position ^. position . _x) (box1Position ^. position . _y) (collision ^. _x) (collision ^. _y) RL.blue
+        Nothing -> pure ()
+
+      minkowski' <- gets @GameState \s -> s.minkowski
+      (minkowskiPosition, minkowskiAABB) <- AE.get @World @(PositionComponent, AABBComponent) minkowski'
+      let ray = Ray . normalize $ V2 (negate (minkowskiPosition ^. position . _x)) (negate (minkowskiPosition ^. position . _y))
+      let collision = rayCollides (Position $ V2 0 0) (ray, ray) minkowskiPosition minkowskiAABB
+      case collision of
+        Just collision -> localSeqUnlift env \unlift ->
+          unlift . unlift' $ RL.drawLine 0 0 (collision ^. _x) (collision ^. _y) RL.blue
+        Nothing -> pure ()
+
+      pure ()
+
+initialize
+  :: (Raylib :> es)
+  => Eff es ()
+initialize = do
+  setTargetFPS 60
+
+main' :: IO ()
+main' = do
+  runEff
+    . AE.runECS initWorld
+    . runGameState
+    . runGameConfig
+    $ gets @GameState (\s -> (s ^. windowDimensions . _x, s ^. windowDimensions . _y)) >>= \(dimX, dimY) ->
+      runRaylibWindow dimX dimY "App"
+        . runEngine
+        $ initialize >> whileM do
+          engineEnv $ startEngine @"state.camera" @"config.backgroundColor" @World
+          not <$> windowShouldClose
+ where
+  readsBackgroundColor
+    :: (Reader GameConfig :> es)
+    => Eff es RL.Color
+  readsBackgroundColor = asks @GameConfig \c -> c.backgroundColor
+  engineEnv
+    :: ( State GameState :> es
+       , AE.ECS World :> es
+       , Reader GameConfig :> es
+       )
+    => Eff (Reads "config.backgroundColor" RL.Color : Reads "state.camera" RL.Camera2D : es) a
+    -> Eff es a
+  engineEnv =
+    runReads @"state.camera" @RL.Camera2D readsCamera
+      . runReads @"config.backgroundColor" @RL.Color readsBackgroundColor

rpg/src/Lib.hs

@@ -1,56 +1,56 @@
-{-# LANGUAGE ImportQualifiedPost #-}
 {-# LANGUAGE BlockArguments #-}
-{-# LANGUAGE GADTs #-}
 {-# LANGUAGE DataKinds #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeOperators #-}
-{-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE ImportQualifiedPost #-}
 {-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeData #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
 {-# LANGUAGE UndecidableInstances #-}
 
-module Lib
+module Lib (
-    ( runGame
+  runGame,
-    ) where
+) where
 
-import Raylib.Core qualified as RL
-import Raylib.Types qualified as RL
-import Raylib.Util.Colors qualified as RL
-import Control.Monad.Extra
-import Control.Lens hiding ((.=))
-import qualified Raylib.Core.Text as RL
-import Effectful
-import Data.Text (Text)
-import Effectful.Dispatch.Dynamic
-import qualified Data.Text as T
-import Effectful.State.Static.Local
-import qualified Raylib.Core.Shapes as RL
 import Apecs.Effectful qualified as AE
-import GHC.Float
+import Common
-import Effectful.Reader.Dynamic
+import Component.Box
-import World
+import Component.Camera
 import Component.Player
 import Component.Position
-import Component.Camera
+import Control.Lens hiding ((.=))
-import Component.Box
+import Control.Monad.Extra
-import Effectful.State.Static.Local.Lens
+import Data.Text (Text)
+import Data.Text qualified as T
+import Effectful
+import Effectful.Accessor
+import Effectful.Dispatch.Dynamic
 import Effectful.Raylib
-import System.Renderer
+import Effectful.Reader.Dynamic
-import Common
+import Effectful.State.Static.Local
-import Linear.V2
+import Effectful.State.Static.Local.Lens
-import System.Physics
 import Engine
+import GHC.Float
+import Linear.V2
+import Raylib.Core qualified as RL
+import Raylib.Core.Shapes qualified as RL
+import Raylib.Core.Text qualified as RL
+import Raylib.Types qualified as RL
+import Raylib.Util.Colors qualified as RL
+import System.Physics
+import System.Renderer
+import World
 
-data GameConfig
+data GameConfig = GameConfig
-  = GameConfig
   {
   }
 
-data GameState
+data GameState = GameState
-  = GameState
   { dimX :: Int
   , dimY :: Int
   , camera :: RL.Camera2D
@@ -58,54 +58,64 @@ data GameState
   , cameraEntity :: AE.Entity
   , boxes :: [AE.Entity]
   }
-  deriving Show
+  deriving (Show)
-makeLensesFor [ ("dimX", "dimX")
+makeLensesFor
-              , ("dimY", "dimY")
+  [ ("dimX", "dimX")
-              , ("camera", "camera")
+  , ("dimY", "dimY")
-              , ("playerEntity", "playerEntity")
+  , ("camera", "camera")
-              , ("cameraEntity", "cameraEntity")
+  , ("playerEntity", "playerEntity")
-              , ("boxes", "boxes")
+  , ("cameraEntity", "cameraEntity")
-              ] ''GameState
+  , ("boxes", "boxes")
+  ]
+  ''GameState
 
 spawnPlayer
-  :: ( AE.ECS World :> es )
+  :: (AE.ECS World :> es)
   => RL.Color
   -> Eff es AE.Entity
-spawnPlayer color = AE.newEntity @World
+spawnPlayer color =
-  ( Player
+  AE.newEntity @World
-  , Position $ V2 0 2
+    ( Player
-  , Camera 10 (0, 0)
+    , Position $ V2 0 2
-  , AABB (V2 1 1) (V2 0 0)
+    , Camera 10 (0, 0)
-  , Body (V2 0 2)
+    , AABB (V2 0.8 0.8) (V2 0 0)
-  , Box color (0, 0) (1, 1)
+    , Body (V2 0 2)
-  )
+    , Box color (0, 0) (0.8, 0.8)
+    )
 
 movePlayer
-  :: ( AE.ECS World :> es )
+  :: (AE.ECS World :> es)
   => Eff es AE.Entity
   -> (Float, Float)
   -> Eff es ()
 movePlayer eff (x, y) = do
   entity <- eff
-  AE.modify @World @() @VelocityComponent entity (\() -> Velocity x y)
+  AE.set @World @VelocityComponent entity (Velocity $ V2 x y)
-  -- AE.modify @World @PositionComponent @PositionComponent entity (\(Position p) -> Position $ V2 (p ^.  _x + x) (p ^.  _y + y))
+
+-- AE.modify @World @PositionComponent @PositionComponent entity (\(Position p) -> Position $ V2 (p ^.  _x + x) (p ^.  _y + y))
 
 spawnBox
-  :: ( AE.ECS World :> es )
+  :: (AE.ECS World :> es, Raylib :> es)
   => (Float, Float)
   -> RL.Color
   -> (Float, Float)
   -> Eff es AE.Entity
-spawnBox (posx, posy) color size = AE.newEntity @World
+spawnBox (posx, posy) color size = do
-  ( Box color (0, 0) size
+  entity <-
-  , Position $ V2 posx posy
+    AE.newEntity @World
-  , AABB (V2 1 1) (V2 0 0)
+      ( Box color (0, 0) size
-  )
+      , Position $ V2 posx posy
+      , AABB (V2 1 1) (V2 0 0)
+      )
+  font <- getFontDefault
+  AE.set @World entity (TextBox font (T.pack $ show (AE.unEntity entity)) 0.3 0.1 RL.yellow)
+  pure entity
 
 initialise
   :: ( Raylib :> es
      , State GameState :> es
-     , AE.ECS World :> es )
+     , AE.ECS World :> es
+     )
   => Eff es ()
 initialise = do
   setTargetFPS 60
@@ -117,7 +127,10 @@ initialise = do
   _ <- spawnBox (0, 0) RL.gray (1, 1)
   _ <- spawnBox (2, 0) RL.gray (1, 1)
   _ <- spawnBox (3, 0) RL.gray (1, 1)
+  _ <- spawnBox (4, 0) RL.gray (1, 1)
   _ <- spawnBox (3, 1) RL.gray (1, 1)
+  _ <- spawnBox (3, -1) RL.gray (1, 1)
+  _ <- spawnBox (3, -3) RL.gray (1, 1)
 
   boxes .= []
 
@@ -125,53 +138,65 @@ initialise = do
 
 data RPGEngine = RPGEngine
 
-instance ( Raylib :> es
+runEngine
-         , AE.ECS World :> es
+  :: forall es
-         , State GameState :> es
+   . ( AE.ECS World :> es
-         , IOE :> es
+     , Raylib :> es
-         ) => Engine es RPGEngine where
+     , State GameState :> es
-  engineInput engine = do
+     )
-    playerEntity <- gets @GameState (\s -> s.playerEntity)
+  => Eff (Engine : es) ()
-    playerMovement @World
+  -> Eff es ()
-      playerEntity
+runEngine = interpret \_ eff ->
-      ( RL.KeyA
+  case eff of
-      , RL.KeyD
+    EngineInput -> do
-      , RL.KeyW
+      playerEntity <- gets @GameState (\s -> s.playerEntity)
-      , RL.KeyS
+      playerMovement @World
-      )
+        playerEntity
-      0.1
+        ( RL.KeyA
+        , RL.KeyD
+        , RL.KeyW
+        , RL.KeyS
+        )
+        0.1
 
-    cameraEntity <- gets @GameState (\s -> s.cameraEntity)
+      cameraEntity <- gets @GameState (\s -> s.cameraEntity)
 
-    isKeyDown RL.KeyKpAdd >>= flip when ( AE.modify @World @CameraComponent @CameraComponent cameraEntity (\c -> c { zoom = c.zoom + 1}))
+      isKeyDown RL.KeyKpAdd >>= flip when (AE.modify @World @CameraComponent @CameraComponent cameraEntity (\c -> c{zoom = c.zoom + 1}))
-    isKeyDown RL.KeyKpSubtract >>= flip when ( AE.modify @World @CameraComponent @CameraComponent cameraEntity (\c -> c { zoom = c.zoom - 1}))
+      isKeyDown RL.KeyKpSubtract >>= flip when (AE.modify @World @CameraComponent @CameraComponent cameraEntity (\c -> c{zoom = c.zoom - 1}))
-    pure ()
+      pure ()
-  enginePhysics _ = pure ()
+    EnginePhysics -> pure ()
-    -- AE.cmapM_ @World @(AE.Entity, PositionComponent, CollisionComponent) \(entity, position, collision) ->
+    EngineRendering unlift -> pure ()
-    --   when (collision.colliders /= []) $ liftIO $ print (show entity <> " with " <> show collision.colliders <> " at " <> show position)
+
-  engineGetCamera engine = do
+-- AE.cmapM_ @World @(AE.Entity, PositionComponent, CollisionComponent) \(entity, position, collision) ->
-    dims <- gets @GameState (\s -> (s.dimX, s.dimY))
+--   when (collision.colliders /= []) $ liftIO $ print (show entity <> " with " <> show collision.colliders <> " at " <> show position)
-    getCamera @World (gets @GameState (\s -> s.cameraEntity)) dims
-  engineClearColor _ = pure RL.white
 
 runGame :: IO ()
 runGame = do
-  let gameConfig
+  let gameConfig =
-        = GameConfig
+        GameConfig
-        {
+          {
-        }
+          }
-      gameState
+      gameState =
-        = GameState
+        GameState
-        { dimX = 800
+          { dimX = 800
-        , dimY = 450
+          , dimY = 450
-        , playerEntity = undefined
+          , playerEntity = undefined
-        , cameraEntity = undefined
+          , cameraEntity = undefined
-        }
+          }
 
   RL.setTraceLogLevel RL.LogWarning
-  runEff . AE.runECS initWorld . evalState gameState . runReader gameConfig . runRaylibWindow gameState.dimX gameState.dimY "App" $ initialise >> whileM do
+  runEff
-
+    . AE.runECS initWorld
-    runEngine @World RPGEngine
+    . evalState gameState
-    not <$> windowShouldClose
+    . runReader gameConfig
+    . runRaylibWindow gameState.dimX gameState.dimY "App"
+    . runReads @"config.camera" @RL.Camera2D do
+      dims <- gets @GameState (\s -> (s.dimX, s.dimY))
+      getCamera @World (gets @GameState (\s -> s.cameraEntity)) dims
+    . runReads @"config.backgroundColor" @RL.Color (pure RL.white)
+    . runEngine
+    $ initialise >> whileM do
+      startEngine @"config.camera" @"config.backgroundColor" @World
+      not <$> windowShouldClose
 
   pure ()

rpg/src/Pong.hs

@@ -1,28 +1,28 @@
 {-# LANGUAGE AllowAmbiguousTypes #-}
+
 module Pong (pongGame) where
 
-import Effectful.State.Static.Local
+import Apecs.Effectful qualified as AE
-import qualified Apecs.Effectful as AE
-import Effectful
-import qualified Raylib.Core as RL
-import qualified Raylib.Types as RL
-import Effectful.Reader.Static
-import Effectful.Raylib
-import Control.Monad.Extra
-import World
-import qualified Raylib.Util.Colors as RL
 import Common hiding (playerMovement)
+import Control.Lens hiding ((%=), (.=))
+import Control.Monad.Extra
+import Data.Text qualified as T
+import Effectful
+import Effectful.Raylib
+import Effectful.Reader.Static
+import Effectful.State.Static.Local
 import Effectful.State.Static.Local.Lens
-import Control.Lens hiding ((.=), (%=))
-import System.Renderer
 import GHC.Float
-import System.Physics
+import Linear qualified as L
 import Linear.V2
-import qualified Linear as L
+import Raylib.Core qualified as RL
-import qualified Data.Text as T
+import Raylib.Types qualified as RL
+import Raylib.Util.Colors qualified as RL
+import System.Physics
+import System.Renderer
+import World
 
-data GameState
+data GameState = GameState
-  = GameState
   { dimX :: Int
   , dimY :: Int
   , camera :: AE.Entity
@@ -31,12 +31,12 @@ data GameState
   , ball :: AE.Entity
   , goal1 :: AE.Entity
   , goal2 :: AE.Entity
-  , bottom :: AE.Entity
+  , bottomBorder :: AE.Entity
-  , top :: AE.Entity
+  , topBorder :: AE.Entity
   , separator :: AE.Entity
   , score :: (Int, Int)
   }
-  deriving Show
+  deriving (Show)
 makeLensesFor
   [ ("dimX", "dimX")
   , ("dimY", "dimY")
@@ -46,24 +46,25 @@ makeLensesFor
   , ("ball", "ball")
   , ("goal1", "goal1")
   , ("goal2", "goal2")
-  , ("bottom", "bottom")
+  , ("bottomBorder", "bottomBorder")
-  , ("top", "top")
+  , ("topBorder", "topBorder")
   , ("separator", "separator")
   , ("score", "score")
-  ] ''GameState
+  ]
+  ''GameState
 
-data GameConfig
+data GameConfig = GameConfig
-  = GameConfig
   { playArea :: Int
   }
-  deriving Show
+  deriving (Show)
 makeLensesFor
   [ ("playArea", "playArea")
-  ] ''GameConfig
+  ]
+  ''GameConfig
 
 playerMovement
-  :: forall w es .
+  :: forall w es
-     ( Raylib :> es
+   . ( Raylib :> es
      , AE.Get w PositionComponent
      , AE.Set w PositionComponent
      , AE.ECS w :> es
@@ -75,23 +76,27 @@ playerMovement
   -> Eff es ()
 playerMovement (up, upSpeed) (down, downSpeed) entity = do
   playArea <- asks @GameConfig (\c -> c.playArea)
-  isKeyDown up >>= flip when
+  isKeyDown up
-    (entity >>= flip (AE.modify @w @PositionComponent) (\(Position p) -> clampPosition playArea . Position $ V2 (p ^. _x) (p ^. _y + upSpeed)))
+    >>= flip
-  isKeyDown down >>= flip when
+      when
-    (entity >>= flip (AE.modify @w @PositionComponent) (\(Position p) -> clampPosition playArea . Position $ V2 (p ^. _x) (p ^. _y + downSpeed)))
+      (entity >>= flip (AE.modify @w @PositionComponent) (\(Position p) -> clampPosition playArea . Position $ V2 (p ^. _x) (p ^. _y + upSpeed)))
-  where
+  isKeyDown down
-    clampPosition
+    >>= flip
-      :: Int
+      when
-      -> PositionComponent
+      (entity >>= flip (AE.modify @w @PositionComponent) (\(Position p) -> clampPosition playArea . Position $ V2 (p ^. _x) (p ^. _y + downSpeed)))
-      -> PositionComponent
+ where
-    clampPosition playArea (Position position)
+  clampPosition
-      | position ^. _y > int2Float playArea / 2 - 1 = Position $ V2 (position ^. _x) (int2Float playArea / 2 - 1)
+    :: Int
-      | position ^. _y < int2Float playArea / 2 * (-1) + 1 =  Position $ V2 (position ^. _x) (int2Float playArea / 2 * (-1) + 1)
+    -> PositionComponent
-      | otherwise = Position position
+    -> PositionComponent
+  clampPosition playArea (Position position)
+    | position ^. _y > int2Float playArea / 2 - 1 = Position $ V2 (position ^. _x) (int2Float playArea / 2 - 1)
+    | position ^. _y < int2Float playArea / 2 * (-1) + 1 = Position $ V2 (position ^. _x) (int2Float playArea / 2 * (-1) + 1)
+    | otherwise = Position position
 
 ballMovement
-  :: forall es .
+  :: forall es
-     ( AE.ECS World :> es
+   . ( AE.ECS World :> es
      )
   => Eff es AE.Entity
   -> Eff es AE.Entity
@@ -114,48 +119,45 @@ ballMovement player1 player2 ball top bottom = do
     player2'
     bottom'
     top'
-    ballVelocity >>= AE.set @World ball'
+    ballVelocity
+    >>= AE.set @World ball'
+ where
+  invertYVelocity
+    :: VelocityComponent
+    -> VelocityComponent
+  invertYVelocity (Velocity (V2 x y)) = Velocity $ V2 x (-y)
 
-  where
+  invertXVelocity
-    invertYVelocity
+    :: VelocityComponent
-      :: VelocityComponent
+    -> VelocityComponent
-      -> VelocityComponent
+  invertXVelocity (Velocity (V2 x y)) = Velocity $ V2 (-x) y
-    invertYVelocity (Velocity x y) = Velocity x (-y)
-
-    invertXVelocity
-      :: VelocityComponent
-      -> VelocityComponent
-    invertXVelocity (Velocity x y) = Velocity (-x) y
-
-    ballMovement'
-      :: AE.Entity
-      -> AE.Entity
-      -> AE.Entity
-      -> AE.Entity
-      -> AE.Entity
-      -> VelocityComponent
-      -> Eff es VelocityComponent
-    ballMovement' ball player1 player2 bottom top ballVelocity = do
-      player1c <- getEntityCollision @World ball player1
-      player2c <- getEntityCollision @World ball player2
-      bottomC <- testEntityCollision @World ball bottom
-      topC <- testEntityCollision @World ball top
-      let ret = case (player1c, player2c) of
-            -- (Just collider, _) -> bounce collider
-            -- (_, Just collider) -> bounce collider
-            _ | bottomC || topC -> invertYVelocity ballVelocity
-            _ -> ballVelocity
-          v2ToVelocity (V2 x y) = Velocity x y
-          bounce collider = ballVelocity -- newVelocity.x (abs newVelocity.y * cloor ballVelocity.y)
-            -- where newVelocity = v2ToVelocity $ L.normalize collider.offset * sqrt 0.02
-            --       cloor f
-            --         | f < 0 = -1
-            --         | f == 0 = 0
-            --         | otherwise = 1
-
-
-      pure ret
 
+  ballMovement'
+    :: AE.Entity
+    -> AE.Entity
+    -> AE.Entity
+    -> AE.Entity
+    -> AE.Entity
+    -> VelocityComponent
+    -> Eff es VelocityComponent
+  ballMovement' ball player1 player2 bottom top ballVelocity = do
+    player1c <- getEntityCollision @World ball player1
+    player2c <- getEntityCollision @World ball player2
+    bottomC <- testEntityCollision @World ball bottom
+    topC <- testEntityCollision @World ball top
+    let ret = case (player1c, player2c) of
+          -- (Just collider, _) -> bounce collider
+          -- (_, Just collider) -> bounce collider
+          _ | bottomC || topC -> invertYVelocity ballVelocity
+          _ -> ballVelocity
+        v2ToVelocity (V2 x y) = Velocity $ V2 x y
+        bounce collider = ballVelocity -- newVelocity.x (abs newVelocity.y * cloor ballVelocity.y)
+        -- where newVelocity = v2ToVelocity $ L.normalize collider.offset * sqrt 0.02
+        --       cloor f
+        --         | f < 0 = -1
+        --         | f == 0 = 0
+        --         | otherwise = 1
+    pure ret
 
 ballRespawn
   :: ( AE.ECS World :> es
@@ -192,137 +194,147 @@ initialise = do
   setTargetFPS 60
   playArea <- asks @GameConfig (\s -> s.playArea)
 
-  cameraEntity <- AE.newEntity @World
+  cameraEntity <-
-    ( Camera playArea (0, 0)
+    AE.newEntity @World
-    , Position $ V2 0 0
+      ( Camera playArea (0, 0)
-    )
+      , Position $ V2 0 0
+      )
   camera .= cameraEntity
 
-  player1Entity <- AE.newEntity @World
+  player1Entity <-
-    ( Player
+    AE.newEntity @World
-    , Position $ V2 (-10) 0
+      ( Player
-    , Box RL.white (0, 0) (0.5, 2)
+      , Position $ V2 (-10) 0
-    , AABB (V2 0.5 2) (V2 0 0)
+      , Box RL.white (0, 0) (0.5, 2)
-    )
+      , AABB (V2 0.5 2) (V2 0 0)
+      )
   player1 .= player1Entity
 
-  player2Entity <- AE.newEntity @World
+  player2Entity <-
-    (Player
+    AE.newEntity @World
-    , Position $ V2 10 0
+      ( Player
-    , Box RL.white (0, 0) (0.5, 2)
+      , Position $ V2 10 0
-    , AABB (V2 0.5 2) (V2 0 0)
+      , Box RL.white (0, 0) (0.5, 2)
-    )
+      , AABB (V2 0.5 2) (V2 0 0)
+      )
   player2 .= player2Entity
 
-  ballEntity <- AE.newEntity @World
+  ballEntity <-
-    ( Position $ V2 0 0
+    AE.newEntity @World
-    , Velocity 0.1 (-0.1)
+      ( Position $ V2 0 0
-    , Box RL.white (0, 0) (0.5, 0.5)
+      , Velocity $ V2 0.1 (-0.1)
-    , AABB (V2 0.5 0.5) (V2 0 0)
+      , Box RL.white (0, 0) (0.5, 0.5)
-    , Body (V2 0 0)
+      , AABB (V2 0.5 0.5) (V2 0 0)
-    )
+      , Body (V2 0 0)
+      )
   ball .= ballEntity
 
-  goal1Entity <- AE.newEntity @World
+  goal1Entity <-
-    ( Position $ V2 (int2Float (-playArea) / 2 - 1) 0
+    AE.newEntity @World
-    , AABB (V2 0.1 (int2Float playArea)) (V2 0 0)
+      ( Position $ V2 (int2Float (-playArea) / 2 - 1) 0
-    , Box RL.red (0, 0) (0.1, int2Float playArea)
+      , AABB (V2 0.1 (int2Float playArea)) (V2 0 0)
-    )
+      , Box RL.red (0, 0) (0.1, int2Float playArea)
-  goal2Entity <- AE.newEntity @World
+      )
-    ( Position $ V2 (int2Float playArea / 2 + 1) 0
+  goal2Entity <-
-    , AABB (V2 0.1 (int2Float playArea)) (V2 0 0)
+    AE.newEntity @World
-    , Box RL.red (0, 0) (0.1, int2Float playArea)
+      ( Position $ V2 (int2Float playArea / 2 + 1) 0
-    )
+      , AABB (V2 0.1 (int2Float playArea)) (V2 0 0)
+      , Box RL.red (0, 0) (0.1, int2Float playArea)
+      )
   goal1 .= goal1Entity
   goal2 .= goal2Entity
 
-  topEntity <- AE.newEntity @World
+  topEntity <-
-    ( Position $ V2 0 (int2Float (-playArea) / 2)
+    AE.newEntity @World
-    , AABB (V2 (int2Float playArea + 2) 0.1) (V2 0 0)
+      ( Position $ V2 0 (int2Float (-playArea) / 2)
-    , Box RL.blue (0, 0) (int2Float playArea + 2, 0.1)
+      , AABB (V2 (int2Float playArea + 2) 0.1) (V2 0 0)
-    )
+      , Box RL.blue (0, 0) (int2Float playArea + 2, 0.1)
-  bottomEntity <- AE.newEntity @World
+      )
-    ( Position $ V2 0 (int2Float playArea / 2)
+  bottomEntity <-
-    , AABB (V2 (int2Float playArea + 2) 0.1) (V2 0 0)
+    AE.newEntity @World
-    , Box RL.green (0, 0) (int2Float playArea + 2, 0.1)
+      ( Position $ V2 0 (int2Float playArea / 2)
-    )
+      , AABB (V2 (int2Float playArea + 2) 0.1) (V2 0 0)
-  top .= topEntity
+      , Box RL.green (0, 0) (int2Float playArea + 2, 0.1)
-  bottom .= bottomEntity
+      )
+  topBorder .= topEntity
+  bottomBorder .= bottomEntity
 
   font <- getFontDefault
-  separatorEntity <- AE.newEntity @World
+  separatorEntity <-
-    ( Position $ V2 0 0
+    AE.newEntity @World
-    , Box RL.darkGray (0, 0) (0.1, int2Float playArea)
+      ( Position $ V2 0 0
-    , TextBox font "" 3 0.1 RL.darkGray
+      , Box RL.darkGray (0, 0) (0.1, int2Float playArea)
-    )
+      , TextBox font "" 3 0.1 RL.darkGray
+      )
   separator .= separatorEntity
 
   pure ()
 
 pongGame :: IO ()
 pongGame = do
-  let gameState
+  let gameState =
-        = GameState
+        GameState
-        { dimX = 600
+          { dimX = 600
-        , dimY = 500
+          , dimY = 500
-        , player1 = undefined
+          , player1 = undefined
-        , player2 = undefined
+          , player2 = undefined
-        , camera = undefined
+          , camera = undefined
-        , ball = undefined
+          , ball = undefined
-        , goal1 = undefined
+          , goal1 = undefined
-        , goal2 = undefined
+          , goal2 = undefined
-        , top = undefined
+          , topBorder = undefined
-        , bottom = undefined
+          , bottomBorder = undefined
-        , separator = undefined
+          , separator = undefined
-        , score = (0, 0)
+          , score = (0, 0)
-        }
+          }
-      gameConfig
+      gameConfig =
-        = GameConfig
+        GameConfig
-        { playArea = 20
+          { playArea = 20
-        }
+          }
   -- RL.setTraceLogLevel RL.LogWarning
-  runEff . AE.runECS initWorld . evalState gameState . runReader gameConfig . runRaylibWindow gameState.dimX gameState.dimY "App" $ initialise >> whileM do
+  runEff . AE.runECS initWorld . evalState gameState . runReader gameConfig . runRaylibWindow gameState.dimX gameState.dimY "App" $
-    playerMovement @World
+    initialise >> whileM do
-      (RL.KeyW, -0.2)
+      playerMovement @World
-      (RL.KeyS, 0.2)
+        (RL.KeyW, -0.2)
-      (gets @GameState (\s -> s.player1))
+        (RL.KeyS, 0.2)
+        (gets @GameState (\s -> s.player1))
 
-    playerMovement @World
+      playerMovement @World
-      (RL.KeyUp, -0.2)
+        (RL.KeyUp, -0.2)
-      (RL.KeyDown, 0.2)
+        (RL.KeyDown, 0.2)
-      (gets @GameState (\s -> s.player2))
+        (gets @GameState (\s -> s.player2))
 
-    -- ballMovement
+      -- ballMovement
-    --   (gets @GameState (\s -> s.player1))
+      --   (gets @GameState (\s -> s.player1))
-    --   (gets @GameState (\s -> s.player2))
+      --   (gets @GameState (\s -> s.player2))
-    --   (gets @GameState (\s -> s.ball))
+      --   (gets @GameState (\s -> s.ball))
-    --   (gets @GameState (\s -> s.bottom))
+      --   (gets @GameState (\s -> s.bottom))
-    --   (gets @GameState (\s -> s.top))
+      --   (gets @GameState (\s -> s.top))
 
-    ballRespawn
+      ballRespawn
-      (gets @GameState (\s -> s.goal2))
+        (gets @GameState (\s -> s.goal2))
-      (gets @GameState (\s -> s.goal1))
+        (gets @GameState (\s -> s.goal1))
-      (gets @GameState (\s -> s.ball))
+        (gets @GameState (\s -> s.ball))
 
-    collisionAABB @World
+      collisionAABB @World
-    applyVelocity @World
+      applyVelocity @World
-    resolveAABB @World
+      resolveAABB @World
 
-    AE.cmapM_ @World @(AE.Entity, PositionComponent, CollisionComponent) \(entity, position, collision) ->
+      AE.cmapM_ @World @(AE.Entity, PositionComponent, CollisionComponent) \(entity, position, collision) ->
-      when (collision.colliders /= []) $ liftIO $ print (show entity <> " with " <> show collision.colliders <> " at " <> show position)
+        when (collision.colliders /= []) $ liftIO $ print (show entity <> " with " <> show collision.colliders <> " at " <> show position)
 
-    score' <- gets @GameState (\s -> s.score)
+      score' <- gets @GameState (\s -> s.score)
-    gets @GameState (\s -> s.separator)>>= flip (AE.modify @World @TextBoxComponent) \textBox ->
+      gets @GameState (\s -> s.separator) >>= flip (AE.modify @World @TextBoxComponent) \textBox ->
-      textBox { text = T.pack $ show score' }
+        textBox{text = T.pack $ show score'}
 
-    dims <- gets @GameState (\s -> (s.dimX, s.dimY))
+      dims <- gets @GameState (\s -> (s.dimX, s.dimY))
-    camera <- getCamera @World (gets @GameState (\s -> s.camera)) dims
+      camera <- getCamera @World (gets @GameState (\s -> s.camera)) dims
-    runDraw . runDraw2D camera $ do
+      runDraw . runDraw2D camera $ do
-      clearBackground RL.gray
+        clearBackground RL.gray
 
-      -- (gets @GameState (\s -> s.score)) >>= liftIO . print
+        -- (gets @GameState (\s -> s.score)) >>= liftIO . print
 
-      render @World
+        render @World
-      renderOrigins @World
+        renderOrigins @World
-      renderBoundingBoxes @World
+        renderBoundingBoxes @World
-    not <$> windowShouldClose
+      not <$> windowShouldClose

rpg/src/System/Physics.hs

@@ -1,43 +1,305 @@
 {-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE DataKinds #-}
 
-module System.Physics (applyVelocity, testEntityCollision, getEntityCollision, collides, collisionAABB, resolveAABB) where
+module System.Physics (
+  applyVelocity,
+  applyVelocity',
+  applyVelocity'',
+  testEntityCollision,
+  getEntityCollision,
+  pointCollides,
+  collides,
+  collisionAABB,
+  resolveAABB,
+  minkowskiDifference,
+  RayComponent (..),
+  direction,
+  rayCollides,
+) where
 
-import World
+import Apecs qualified
-import qualified Apecs.Effectful as AE
-import qualified Apecs.Components as AE (EntityStore)
-import Effectful
-import Linear
-import Control.Lens
-import Effectful.Dispatch.Static (unsafeEff_)
-import qualified Apecs
-import qualified Apecs.Core
 import Apecs.Components (EntityStore)
+import Apecs.Components qualified as AE (EntityStore)
+import Apecs.Core qualified
+import Apecs.Effectful qualified as AE
+import Control.Lens
 import Control.Monad.Extra
-import qualified Debug.Trace as Debut.Trace
+import Data.Foldable (minimumBy)
+import Data.List (nub, subsequences, tails)
+import Data.Maybe (catMaybes, fromMaybe, isJust)
+import Debug.Trace qualified as Debug
+import Effectful
+import Effectful.Dispatch.Static (unsafeEff_)
+import Effectful.Raylib
+import Effectful.State.Static.Local (evalState, get, modify, put)
+import Linear
+import World
+
+data RayComponent = Ray
+  { direction :: V2 Float
+  }
+makeLensesFor [("origin", "origin"), ("direction", "direction")] ''RayComponent
 
 applyVelocity
-  :: forall w es .
+  :: forall w es
-     ( AE.Get w PositionComponent
+   . ( AE.Get w PositionComponent
      , AE.Get w VelocityComponent
+     , AE.Get w AABBComponent
      , AE.Set w PositionComponent
      , AE.ECS w :> es
      )
   => Eff es ()
 applyVelocity = do
-  AE.cmap @w @(PositionComponent, VelocityComponent) @_
+  AE.cmapM @w @(AE.Entity, PositionComponent, VelocityComponent, Maybe AABBComponent) @_
-    \(Position position, velocity) -> Position $ V2 (position ^. _x + velocity.x) (position ^. _y + velocity.y)
+    \(this, Position position, Velocity velocity, aabb') ->
+      case aabb' of
+        Just aabb -> pure . Position $ V2 (position ^. _x + velocity ^. _x) (position ^. _y + velocity ^. _y)
+        Nothing -> pure . Position $ V2 (position ^. _x + velocity ^. _x) (position ^. _y + velocity ^. _y)
+
+applyVelocity'
+  :: forall w es
+   . ( AE.Get w PositionComponent
+     , AE.Get w VelocityComponent
+     , AE.Get w AABBComponent
+     , AE.Set w PositionComponent
+     , AE.ECS w :> es
+     )
+  => Eff es ()
+applyVelocity' = do
+  let
+    pairs :: [AE.Entity] -> [(AE.Entity, [AE.Entity])]
+    pairs xs = map (\x -> (x, filter (/= x) xs)) xs
+
+  entities :: [(AE.Entity, [AE.Entity])] <-
+    AE.cfold @w @(AE.Entity, PositionComponent, Maybe VelocityComponent, AABBComponent)
+      (\acc (this, _, _, _) -> this : acc)
+      []
+      <&> pairs
+
+  forM_ entities \(entity, entities') -> evalState (1.0 :: Float) . evalState (1000 :: Int) $ whileM do
+    (position1, velocity1, aabb1) <- AE.get @w @(PositionComponent, Maybe VelocityComponent, AABBComponent) entity
+    let Velocity velocity1' = fromMaybe (Velocity $ pure 0) velocity1
+
+    fractions <- forM entities' \entity2 -> do
+      (position2, velocity2, aabb2) <- AE.get @w @(PositionComponent, Maybe VelocityComponent, AABBComponent) entity2
+      let
+        Velocity velocity2' = fromMaybe (Velocity $ pure 0) velocity2
+      pure (velocity1' - velocity2', getCollidingVelocityRatio (position1, aabb1, Velocity velocity1') (position2, aabb2, Velocity velocity2'))
+
+    let
+      order (_, a) (_, b) = a `compare` b
+      mapH (a, x)
+        | isNaN x = (a, 1.0)
+        | otherwise = (a, x)
+      h =
+        minimumBy
+          order
+          ( (velocity1', 1.0)
+              : map mapH fractions
+          )
+      h' =
+        if h ^. _2 < 0.01
+          then _2 .~ 0 $ h
+          else h
+      newPosition = Position $ position1.position + (velocity1' * pure (h' ^. _2))
+
+      tangent = normalize (h' ^. _1) ^. _yx & _x %~ negate
+      newVelocity = Velocity $ pure (tangent `dot` velocity1') * tangent
+
+    AE.set @w entity newPosition
+    when (h' ^. _2 /= 1.0) $ AE.set @w entity newVelocity
+
+    remainingTime <- get @Float
+    put @Float $ remainingTime - (h' ^. _2)
+
+    iterations <- get @Int
+    put @Int $ iterations - 1
+
+    when (entity == 0) $ unsafeEff_ $ print (tangent, velocity1', tangent `dot` velocity1')
+    pure (iterations /= 0 && unVelocity newVelocity /= pure 0 && remainingTime > 0)
+
+clampDown :: Float -> Float
+clampDown h
+  | h < 0.01 = 0
+  | otherwise = h
+
+aabbCollisionNormal :: (PositionComponent, AABBComponent) -> (PositionComponent, AABBComponent) -> V2 Float
+aabbCollisionNormal (position1, aabb1) (position2, aabb2) =
+  (^. _1) $
+    minimumBy
+      order
+      [ (V2 (-1) 0, abs $ minDiff ^. left)
+      , (V2 1 0, abs $ minDiff ^. right)
+      , (V2 0 (-1), abs $ minDiff ^. bottom)
+      , (V2 0 1, abs $ minDiff ^. top)
+      ]
+ where
+  order (_, a) (_, b) = a `compare` b
+  minDiff = minkowskiDifference (position1, aabb1) (position2, aabb2)
+
+applyVelocity''
+  :: forall w es
+   . ( AE.Get w PositionComponent
+     , AE.Get w VelocityComponent
+     , AE.Get w AABBComponent
+     , AE.Set w PositionComponent
+     , AE.ECS w :> es
+     )
+  => Eff es ()
+applyVelocity'' = do
+  allEntities <- AE.cfold @w @(AE.Entity, PositionComponent, AABBComponent) (\acc (a, _, _) -> a : acc) []
+  let
+    pairs xs = [(x, y) | (x : ys) <- tails (nub xs), y <- ys]
+    entityPairings = pairs allEntities
+
+  evalState (1.0 :: Float) . evalState (1000 :: Int) . whileM $ do
+    fractions <- forM entityPairings \(entity1, entity2) -> do
+      (position1, velocity1, aabb1) <- AE.get @w @(PositionComponent, Maybe VelocityComponent, AABBComponent) entity1
+      (position2, velocity2, aabb2) <- AE.get @w @(PositionComponent, Maybe VelocityComponent, AABBComponent) entity2
+      let
+        Velocity velocity1' = fromMaybe (Velocity $ pure 0) velocity1
+        Velocity velocity2' = fromMaybe (Velocity $ pure 0) velocity2
+
+      pure
+        ( Just ((entity1, position1, velocity1, aabb1), (entity2, position2, velocity2, aabb2))
+        , getCollidingVelocityRatio (position1, aabb1, Velocity velocity1') (position2, aabb2, Velocity velocity2')
+        )
+
+    let
+      order (_, a) (_, b) = a `compare` b
+      clampedFractions = map (_2 %~ clampDown) fractions
+      fractions' = filter (not . isNaN . (^. _2)) clampedFractions
+      (info, minTime) = minimumBy order ((Nothing, 1.0) : fractions')
+
+    forM_ allEntities \entity1 -> do
+      (position1, velocity1) <- AE.get @w @(PositionComponent, Maybe VelocityComponent) entity1
+      let
+        velocity1' = fromMaybe (Velocity $ pure 0) velocity1
+      AE.set @w entity1 (Position $ position1.position + unVelocity velocity1' * pure (clampDown minTime))
+    case info of
+      Just ((entityA, positionA, velocityA, aabbA), (entityB, positionB, velocityB, aabbB)) -> do
+        do
+          let
+            Velocity velocityA' = fromMaybe (Velocity $ pure 0) velocityA
+            Velocity velocityB' = fromMaybe (Velocity $ pure 0) velocityB
+            normal = aabbCollisionNormal (positionA, aabbA) (positionB, aabbB)
+            alongNormalA = velocityA' `dot` normal
+            alongNormalB = velocityB' `dot` normal
+
+            bouncinessA = 1.0
+            bouncinessB = 1.0
+
+            frictionA = 1.0
+            frictionB = 1.0
+
+            -- friction and bounce
+            newVelocityA' = (pure (-alongNormalA) * normal * pure bouncinessA + velocityA') * frictionA
+            newVelocityB' = (pure (-alongNormalB) * normal * pure bouncinessB + velocityB') * frictionB
+
+          AE.set @w entityA (Velocity newVelocityA')
+          AE.set @w entityB (Velocity newVelocityB')
+          pure ()
+      _ -> pure ()
+
+    remainingTime <- get @Float
+    put @Float $ remainingTime - minTime
+
+    iterations <- get @Int
+    put @Int $ iterations - 1
+
+    pure (iterations - 1 /= 0 && remainingTime - minTime > 0)
+
+getCollidingVelocityRatio
+  :: (PositionComponent, AABBComponent, VelocityComponent)
+  -- ^ collider A
+  -> (PositionComponent, AABBComponent, VelocityComponent)
+  -- ^ collider B
+  -> Float
+  -- ^ (normal, ratio)
+getCollidingVelocityRatio (position1, aabb1, velocity1) (position2, aabb2, velocity2) = percentage
+ where
+  aabbBounds = minkowskiDifference (position1, aabb1) (position2, aabb2)
+  (positionMinkowski, aabbMinkowski) = aabbFromBounds aabbBounds (V2 0 0)
+  Velocity velocityMinkowski = velocity1 - velocity2
+  ray = Ray . negate $ velocityMinkowski
+  collision = rayCollides (Position $ V2 0 0) (ray, ray) positionMinkowski aabbMinkowski
+  percentage = norm (fromMaybe (pure $ 1 / 0) collision) / norm velocityMinkowski
+
+minkowskiDifference :: (PositionComponent, AABBComponent) -> (PositionComponent, AABBComponent) -> AABBBounds
+minkowskiDifference (positionA, aabbA) (positionB, aabbB) =
+  -- V4 x -x y -y
+  let
+    boundsA = aabbBounds positionA aabbA
+    boundsB = aabbBounds positionB aabbB
+   in
+    AABBBounds
+      { left = boundsA.left - boundsB.right
+      , right = boundsA.right - boundsB.left
+      , top = boundsA.top - boundsB.bottom
+      , bottom = boundsA.bottom - boundsB.top
+      }
+
+pointCollides
+  :: V2 Float
+  -> PositionComponent
+  -> AABBComponent
+  -> Maybe (V2 Float)
+pointCollides point position@(Position pos) aabb = do
+  let (V2 x y) = point
+      bounds = aabbBounds position aabb
+   in if bounds ^. left <= x && bounds ^. right >= x && bounds ^. top >= y && bounds ^. bottom <= y
+        then Just (V2 x y - pos)
+        else Nothing
+
+rayCollides
+  :: PositionComponent
+  -- ^ ray origin
+  -> (RayComponent, RayComponent)
+  -- ^ normal and inversed ray
+  -> PositionComponent
+  -- ^ position of target
+  -> AABBComponent
+  -- ^ aabb of target
+  -> Maybe (V2 Float)
+rayCollides (Position origin) (ray, rayInverse) (Position position) aabb =
+  -- https://tavianator.com/2011/ray_box.html
+  let bounds = aabbBounds (Position position) aabb
+      tx1 = (bounds ^. left - origin ^. _x) / ray ^. direction . _x
+      tx2 = (bounds ^. right - origin ^. _x) / ray ^. direction . _x
+
+      tmin' = min tx1 tx2
+      tmax' = max tx1 tx2
+
+      ty1 = (bounds ^. bottom - origin ^. _y) / ray ^. direction . _y
+      ty2 = (bounds ^. top - origin ^. _y) / ray ^. direction . _y
+
+      tmin = max tmin' (min (min ty1 ty2) tmax')
+      tmax = min tmax' (max (max ty1 ty2) tmin')
+   in if tmax > max tmin 0.0
+        then
+          if tmax < 0
+            then Just $ V2 (ray ^. direction . _x * tmax + origin ^. _x) (ray ^. direction . _y * tmax + origin ^. _y)
+            else Just $ V2 (ray ^. direction . _x * tmin + origin ^. _x) (ray ^. direction . _y * tmin + origin ^. _y)
+        else Nothing
 
 collides
   :: AE.Entity
-  -> PositionComponent -> AABBComponent
+  -> PositionComponent
-  -> PositionComponent -> AABBComponent
+  -> AABBComponent
+  -> PositionComponent
+  -> AABBComponent
   -> Maybe Collider
 collides bEntity (Position positionA) aabbA (Position positionB) aabbB = do
   -- V4 x -x y -y
   let boundsA = aabbBounds (Position positionA) aabbA
       boundsB = aabbBounds (Position positionB) aabbB
+      minDiff = minkowskiDifference (Position positionA, aabbA) (Position positionB, aabbB)
 
-  case (boundsA ^. _y - boundsB ^. _x <= 0, boundsA ^. _x - boundsB ^. _y >= 0, boundsB ^. _w - boundsA ^. _z <= 0, boundsB ^. _z - boundsA ^. _w >= 0) of
+  case ( minDiff.left <= 0
+       , minDiff.right >= 0
+       , minDiff.top <= 0
+       , minDiff.bottom >= 0
+       ) of
     (True, True, True, True) ->
       let
         offsetX = (positionB ^. _x - positionA ^. _x)
@@ -49,51 +311,56 @@ collides bEntity (Position positionA) aabbA (Position positionB) aabbB = do
         -- foo :: Float = ((fromIntegral :: Int -> Float) . floor $ (atan2 (offset ^. _x) (offset ^. _y) / 2 * pi * 4)) / 4 * 2 * pi
         -- foo :: Float = 1.5 + (-1)^fromEnum (offsetY > 0) * (0.5 + (fromIntegral . fromEnum $ offsetX > 0))
         foo = case compare (abs offsetX) (abs offsetY) of
-                LT -> V2 0 offsetY
+          LT -> V2 0 offsetY
-                GT -> V2 offsetX 0
+          GT -> V2 offsetX 0
-                EQ -> V2 offsetX 0
+          EQ -> V2 offsetX 0
-      in
+       in
-        Just Collider
+        Just
-        { other = bEntity
+          Collider
-        -- https://stackoverflow.com/questions/9324339/how-much-do-two-rectangles-overlap
+            { other = bEntity
-        , overlap = V2
+            , -- https://stackoverflow.com/questions/9324339/how-much-do-two-rectangles-overlap
-                    ((min (boundsA ^. _x) (boundsB ^. _x) - max (boundsA ^. _y) (boundsB ^. _y)) * normalize' offsetX)
+              overlap =
-                    ((max (boundsA ^. _w) (boundsB ^. _w) - min (boundsA ^. _z) (boundsB ^. _z)) * normalize' offsetY)
+                V2
-        , offset = offset
+                  ((min (boundsA ^. right) (boundsB ^. right) - max (boundsA ^. left) (boundsB ^. left)) * normalize' offsetX)
-        , normal = normalize foo
+                  ((max (boundsA ^. bottom) (boundsB ^. bottom) - min (boundsA ^. top) (boundsB ^. top)) * normalize' offsetY)
-        }
+            , offset = offset
+            , normal = normalize foo
+            }
     _ -> Nothing
 
 testEntityCollision
-  :: forall w es .
+  :: forall w es
-     ( AE.Get w CollisionComponent
+   . ( AE.Get w CollisionComponent
-     , AE.ECS w :> es )
+     , AE.ECS w :> es
+     )
   => AE.Entity
   -> AE.Entity
   -> Eff es Bool
-testEntityCollision a b = getEntityCollision @w a b <&> \case Just _ -> True ; Nothing -> False
+testEntityCollision a b = getEntityCollision @w a b <&> \case Just _ -> True; Nothing -> False
 
 getEntityCollision
-  :: forall w es .
+  :: forall w es
-     ( AE.Get w CollisionComponent
+   . ( AE.Get w CollisionComponent
-     , AE.ECS w :> es )
+     , AE.ECS w :> es
+     )
   => AE.Entity
   -> AE.Entity
   -> Eff es (Maybe Collider)
 getEntityCollision a b =
   AE.tryGet @w @CollisionComponent a >>= \case
     Just collision -> pure $ testEntityCollision' collision b
-    Nothing -> AE.tryGet @w @CollisionComponent b >>= \case
+    Nothing ->
-      Just collision -> pure $ testEntityCollision' collision a
+      AE.tryGet @w @CollisionComponent b >>= \case
-      Nothing -> pure Nothing
+        Just collision -> pure $ testEntityCollision' collision a
-  where
+        Nothing -> pure Nothing
-    testEntityCollision' :: CollisionComponent -> AE.Entity -> Maybe Collider
+ where
-    testEntityCollision' collision other =
+  testEntityCollision' :: CollisionComponent -> AE.Entity -> Maybe Collider
-      foldl (\case Just j -> const $ Just j ; Nothing -> \x -> if x.other == other then Just x else Nothing) Nothing collision.colliders
+  testEntityCollision' collision other =
+    foldl (\case Just j -> const $ Just j; Nothing -> \x -> if x.other == other then Just x else Nothing) Nothing collision.colliders
 
 collisionAABB
-  :: forall w es .
+  :: forall w es
-     ( AE.Get w PositionComponent
+   . ( AE.Get w PositionComponent
      , AE.Get w BodyComponent
      , AE.Get w AABBComponent
      , AE.Get w CollisionComponent
@@ -102,19 +369,19 @@ collisionAABB
   => Eff es ()
 collisionAABB =
   void $ AE.cmapM @w @(AE.Entity, PositionComponent, BodyComponent, AABBComponent) @(CollisionComponent)
-  \(bodyEntity, bodyPosition, _, bodyAABB) -> do
+    \(bodyEntity, bodyPosition, _, bodyAABB) -> do
-    colliders <- flip (AE.cfoldM @w @(AE.Entity, PositionComponent, AABBComponent)) [] \acc (colliderEntity, colliderPosition, colliderAABB) ->
+      colliders <- flip (AE.cfoldM @w @(AE.Entity, PositionComponent, AABBComponent)) [] \acc (colliderEntity, colliderPosition, colliderAABB) ->
-      pure $ if bodyEntity /= colliderEntity then
+        pure $
-        case collides colliderEntity bodyPosition bodyAABB colliderPosition colliderAABB of
+          if bodyEntity /= colliderEntity
-          Just collider -> collider : acc
+            then case collides colliderEntity bodyPosition bodyAABB colliderPosition colliderAABB of
-          Nothing -> acc
+              Just collider -> collider : acc
-       else
+              Nothing -> acc
-         acc
+            else acc
-    pure $ Collision { colliders = colliders }
+      pure $ Collision{colliders = colliders}
 
 resolveAABB
-  :: forall w es .
+  :: forall w es
-     ( AE.Get w PositionComponent
+   . ( AE.Get w PositionComponent
      , AE.Get w BodyComponent
      , AE.Get w CollisionComponent
      , AE.ECS w :> es
@@ -125,14 +392,15 @@ resolveAABB = do
   void $ AE.cmapM @w @(PositionComponent, BodyComponent, CollisionComponent) @PositionComponent
     \(Position position, Body previousPosition, collision) ->
       case collision.colliders of
-        (_:_) -> do
+        (_ : _) -> do
           -- liftIO . print $ foldl (\a c -> a - c.overlap) (head collision.colliders).overlap (tail collision.colliders)
           pure $ Position position
         _ -> pure $ Position position
-      -- pure . Position $ foldl resolve position collision.colliders
+ where
-    where resolve :: V2 Float -> Collider -> V2 Float
+  -- pure . Position $ foldl resolve position collision.colliders
-          resolve position collider =
+  resolve :: V2 Float -> Collider -> V2 Float
-            case collider.overlap of
+  resolve position collider =
-              V2 x y | abs x < abs y -> position & _x %~ flip (-) x
+    case collider.overlap of
-              V2 x y | abs y < abs x -> position & _y %~ (+) y
+      V2 x y | abs x < abs y -> position & _x %~ flip (-) x
-              V2 x _ -> position & _x %~ flip (-) x
+      V2 x y | abs y < abs x -> position & _y %~ (+) y
+      V2 x _ -> position & _x %~ flip (-) x

rpg/src/System/Renderer.hs

@@ -71,10 +71,10 @@ renderBoundingBoxes
 renderBoundingBoxes =
   AE.cmapM_ @w @(PositionComponent, AABBComponent)
     \(pos, aabb) -> do
-      let (V4 x nx y ny) = aabbBounds pos aabb
+      let (AABBBounds left right top bottom) = aabbBounds pos aabb
-      drawLine x y x ny RL.red
+      drawLine right bottom right top RL.red
-      drawLine x ny nx ny RL.red
+      drawLine right top left top RL.red
-      drawLine nx ny nx y RL.red
+      drawLine left top left bottom RL.red
-      drawLine nx y x y RL.red
+      drawLine left bottom right bottom RL.red
-      drawLine x y nx ny RL.red
+      drawLine right bottom left top RL.red
-      drawLine nx y x ny RL.red
+      drawLine left bottom right top RL.red

snake/app/Main.hs

@@ -370,7 +370,7 @@ main =
   in
     bracket (SDL.initialize [ SDL.InitEvents, SDL.InitVideo ]) (const SDL.quit) $ \_ ->
     bracket (SDL.createWindow "Snake" windowConfig) SDL.destroyWindow $ \window ->
-    bracket (SDL.createRenderer window (-1) rendererConfig) SDL.destroyRenderer $ \renderer ->
+    bracket (SDL.createRenderer window 0 rendererConfig) SDL.destroyRenderer $ \renderer ->
     initStdGen >>= \rng ->
     SDLI.loadTexture renderer "textures/atlas.png" >>= \texture ->
 

stack.yaml

@@ -55,6 +55,10 @@ flags:
     detect-platform: false
     platform-nixos: true
 
+# Needed by HLS to display haddocks
+ghc-options:
+  '$everything': -haddock
+
 # Extra package databases containing global packages
 # extra-package-dbs: []