magic_rb/haskell-games
1
0
Fork 0
mirror of https://git.sr.ht/~magic_rb/haskell-games synced 2024-11-21 15:24:22 +01:00
Code Issues Packages Projects Releases Wiki Activity

Full swept AABB collision and resolution

Browse source 
Signed-off-by: magic_rb <richard@brezak.sk>
This commit is contained in:
magic_rb 2024-01-01 23:40:23 +01:00
parent 19c8af10ce
commit e485fe4a7b
No known key found for this signature in database
GPG key ID: 08D5287CC5DDCA0E
21 changed files with 1340 additions and 510 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

1
.dir-locals.el Normal file
View file

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

6
flake.lock
View file

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

2
flake.nix
View file

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

51
fourmolu.yaml Normal file
View file

@ -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: []

7
rpg/minkowski/Main.hs Normal file
View file

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

12
rpg/package.yaml
View file

@ -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

41
rpg/rpg.cabal
View file

@ -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

54
rpg/src/Common.hs
View file

@ -1,37 +1,42 @@
{-# LANGUAGE AllowAmbiguousTypes #-}
module Common ( getCamera, playerMovement ) where
import qualified Apecs.Effectful as AE
import World
import Effectful
import qualified Raylib.Types as RL
import GHC.Float
import Linear.V2
module Common (getCamera, playerMovement) where
import Apecs.Effectful qualified as AE
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 .
( AE.Get w CameraComponent
:: forall w es
. ( 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
{ RL.camera2D'offset = RL.Vector2 (int2Float dimX / 2) (int2Float dimY / 2)
, RL.camera2D'target = RL.Vector2 (x + fst c.offset) (y + snd c.offset)
, RL.camera2D'rotation = 0.0
, RL.camera2D'zoom = int2Float (min dimX dimY) / int2Float c.zoom
}
pure $
RL.Camera2D
{ RL.camera2D'offset = RL.Vector2 (int2Float dimX / 2) (int2Float dimY / 2)
, RL.camera2D'target = RL.Vector2 (x + fst c.offset) (y + snd c.offset)
, RL.camera2D'rotation = 0.0
, RL.camera2D'zoom = int2Float (min dimX dimY) / int2Float c.zoom
}
playerMovement
:: forall w es .
( Raylib :> es
:: forall w 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))
[ ( isKeyDown left, V2 (-speed) 0 )
, ( isKeyDown right, V2 speed 0 )
, ( isKeyDown down, V2 0 speed )
, ( isKeyDown up, V2 0 (-speed) )
]
mapM
(\tuple -> fst tuple <&> (,snd tuple))
[ (isKeyDown left, V2 (-1.0) 0)
, (isKeyDown right, V2 1.0 0)
, (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))

78
rpg/src/Component/AABB.hs
View file

@ -1,26 +1,76 @@
{-# LANGUAGE TypeFamilies #-}
module Component.AABB
( AABBComponent(..)
, aabbBounds
) where
module Component.AABB (
AABBComponent (..),
size,
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
= AABB
data AABBComponent = 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)
(posX - sizeX / 2 + offsetX)
(posY + sizeY / 2 + offsetY)
(posY - sizeY / 2 + offsetY)
AABBBounds
{ left = posX - sizeX / 2 + offsetX
, right = posX + sizeX / 2 + offsetX
, 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
}
)

8
rpg/src/Component/Position.hs
View file

@ -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

14
rpg/src/Component/Velocity.hs
View file

@ -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
= Velocity
{ x :: Float
, y :: Float
}
deriving Show
newtype VelocityComponent = Velocity (V2 Float)
deriving (Show, Num)
instance Component VelocityComponent where type Storage VelocityComponent = Map VelocityComponent
unVelocity :: VelocityComponent -> V2 Float
unVelocity (Velocity v) = v

47
rpg/src/Effectful/Accessor.hs Normal file
View file

@ -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)

137
rpg/src/Effectful/Raylib.hs
View file

@ -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
import qualified Raylib.Types as RL
module Effectful.Raylib (
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
runRaylibDrawing :: (IOE :> es) => Eff (RaylibDraw : es) a -> Eff es a
runRaylibDrawing effect' = do
liftIO RL.beginDrawing
res <- interpret' effect' $ \env eff -> localSeqUnlift env \unlift ->
case eff of
ClearBackground color -> liftIO $ RL.clearBackground color
RunDraw2D camera draw2dEffect -> unlift $ runRaylibDrawing2d camera draw2dEffect
liftIO RL.endDrawing
pure res
where
runRaylibDrawing :: (IOE :> es) => Eff (RaylibDraw : es) a -> Eff es a
runRaylibDrawing effect' = do
liftIO RL.beginDrawing
res <- interpret' effect' $ \env eff -> localSeqUnlift env \unlift ->
case eff of
ClearBackground color -> liftIO $ RL.clearBackground color
RunDraw2D camera draw2dEffect -> unlift $ runRaylibDrawing2d camera draw2dEffect
liftIO RL.endDrawing
pure res
runRaylibDrawing2d :: (IOE :> es) => RL.Camera2D -> Eff (RaylibDraw2D : es) a -> Eff es a
runRaylibDrawing2d camera effect' = do
liftIO (RL.beginMode2D camera)
res <- interpret' effect' $ \env eff -> localSeqUnlift env \unlift ->
case eff of
MeasureText font text fontSize spacing -> do
RL.Vector2 x y <- liftIO $ RL.measureTextEx font (T.unpack text) fontSize spacing
pure (V2 x y)
DrawText font text (V2 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
DrawLine startX startY endX endY color -> liftIO $ RL.drawLineV (RL.Vector2 startX startY) (RL.Vector2 endX endY) color
liftIO RL.endMode2D
pure res
runRaylibDrawing2d :: (IOE :> es) => RL.Camera2D -> Eff (RaylibDraw2D : es) a -> Eff es a
runRaylibDrawing2d camera effect' = do
liftIO (RL.beginMode2D camera)
res <- interpret' effect' $ \env eff -> localSeqUnlift env \unlift ->
case eff of
MeasureText font text fontSize spacing -> do
RL.Vector2 x y <- liftIO $ RL.measureTextEx font (T.unpack text) fontSize spacing
pure (V2 x y)
DrawText font text (V2 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
DrawLine startX startY endX endY color -> liftIO $ RL.drawLineV (RL.Vector2 startX startY) (RL.Vector2 endX endY) color
liftIO RL.endMode2D
pure res
interpret'
:: DispatchOf e ~ Dynamic
=> Eff (e ': es) a
-> EffectHandler e es
-> Eff es a
interpret' eff handler = interpret handler eff
interpret'
:: (DispatchOf e ~ Dynamic)
=> Eff (e ': es) a
-> EffectHandler e es
-> Eff es a
interpret' eff handler = interpret handler eff

138
rpg/src/Engine.hs
View file

@ -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 World
import qualified Apecs.Effectful as AE
import qualified Raylib.Types as RL
import System.Renderer
import Effectful.Accessor
import Effectful.Dispatch.Dynamic
import Effectful.Dispatch.Static
import Effectful.Internal.Monad
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
engineInput :: a -> Eff es ()
engineInput _ = pure ()
enginePhysics :: a -> Eff es ()
enginePhysics _ = pure ()
engineRendering :: a -> Eff es ()
engineRendering _ = pure ()
engineGetCamera :: a -> Eff es RL.Camera2D
engineClearColor :: a -> Eff es RL.Color
data EngineOps es = EngineOps
{ input :: Eff es ()
, physics :: Eff es ()
, rendering :: Eff es ()
}
runEngine
:: forall w es a .
( Engine es a
, 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
, IOE :> es
, Raylib :> es
, AE.ECS w :> es
data Engine :: Effect where
EngineInput :: Engine (Eff es) ()
EnginePhysics :: Engine (Eff es) ()
EngineRendering :: (SharedSuffix es2 es, RaylibDraw :> es2, RaylibDraw2D :> es2) => (forall r. Eff es2 r -> Eff es r) -> Engine (Eff es) ()
type instance DispatchOf Engine = Dynamic
engineInput :: (HasCallStack, Engine :> es) => Eff es ()
engineInput = send EngineInput
enginePhysics :: (HasCallStack, Engine :> es) => Eff es ()
enginePhysics = send EnginePhysics
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 ()
runEngine engine = do
engineInput engine
applyVelocity @w
=> Eff es ()
startEngine = do
engineInput
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

213
rpg/src/Executables/Minkowski.hs Normal file
View file

@ -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

231
rpg/src/Lib.hs
View file

@ -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
( runGame
) where
module Lib (
runGame,
) 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 Effectful.Reader.Dynamic
import World
import Common
import Component.Box
import Component.Camera
import Component.Player
import Component.Position
import Component.Camera
import Component.Box
import Effectful.State.Static.Local.Lens
import Control.Lens hiding ((.=))
import Control.Monad.Extra
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 Common
import Linear.V2
import System.Physics
import Effectful.Reader.Dynamic
import Effectful.State.Static.Local
import Effectful.State.Static.Local.Lens
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
= GameConfig
data GameConfig = GameConfig
{
}
data GameState
= GameState
data GameState = GameState
{ dimX :: Int
, dimY :: Int
, camera :: RL.Camera2D
@ -58,54 +58,64 @@ data GameState
, cameraEntity :: AE.Entity
, boxes :: [AE.Entity]
}
deriving Show
makeLensesFor [ ("dimX", "dimX")
, ("dimY", "dimY")
, ("camera", "camera")
, ("playerEntity", "playerEntity")
, ("cameraEntity", "cameraEntity")
, ("boxes", "boxes")
] ''GameState
deriving (Show)
makeLensesFor
[ ("dimX", "dimX")
, ("dimY", "dimY")
, ("camera", "camera")
, ("playerEntity", "playerEntity")
, ("cameraEntity", "cameraEntity")
, ("boxes", "boxes")
]
''GameState
spawnPlayer
:: ( AE.ECS World :> es )
:: (AE.ECS World :> es)
=> RL.Color
-> Eff es AE.Entity
spawnPlayer color = AE.newEntity @World
( Player
, Position $ V2 0 2
, Camera 10 (0, 0)
, AABB (V2 1 1) (V2 0 0)
, Body (V2 0 2)
, Box color (0, 0) (1, 1)
)
spawnPlayer color =
AE.newEntity @World
( Player
, Position $ V2 0 2
, Camera 10 (0, 0)
, AABB (V2 0.8 0.8) (V2 0 0)
, 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.modify @World @PositionComponent @PositionComponent entity (\(Position p) -> Position $ V2 (p ^. _x + x) (p ^. _y + 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))
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
( Box color (0, 0) size
, Position $ V2 posx posy
, AABB (V2 1 1) (V2 0 0)
)
spawnBox (posx, posy) color size = do
entity <-
AE.newEntity @World
( 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
, AE.ECS World :> es
, State GameState :> es
, IOE :> es
) => Engine es RPGEngine where
engineInput engine = do
playerEntity <- gets @GameState (\s -> s.playerEntity)
playerMovement @World
playerEntity
( RL.KeyA
, RL.KeyD
, RL.KeyW
, RL.KeyS
)
0.1
runEngine
:: forall es
. ( AE.ECS World :> es
, Raylib :> es
, State GameState :> es
)
=> Eff (Engine : es) ()
-> Eff es ()
runEngine = interpret \_ eff ->
case eff of
EngineInput -> do
playerEntity <- gets @GameState (\s -> s.playerEntity)
playerMovement @World
playerEntity
( 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.KeyKpSubtract >>= flip when ( AE.modify @World @CameraComponent @CameraComponent cameraEntity (\c -> c { zoom = c.zoom - 1}))
pure ()
enginePhysics _ = pure ()
-- AE.cmapM_ @World @(AE.Entity, PositionComponent, CollisionComponent) \(entity, position, collision) ->
-- when (collision.colliders /= []) $ liftIO $ print (show entity <> " with " <> show collision.colliders <> " at " <> show position)
engineGetCamera engine = do
dims <- gets @GameState (\s -> (s.dimX, s.dimY))
getCamera @World (gets @GameState (\s -> s.cameraEntity)) dims
engineClearColor _ = pure RL.white
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}))
pure ()
EnginePhysics -> pure ()
EngineRendering unlift -> pure ()
-- AE.cmapM_ @World @(AE.Entity, PositionComponent, CollisionComponent) \(entity, position, collision) ->
-- when (collision.colliders /= []) $ liftIO $ print (show entity <> " with " <> show collision.colliders <> " at " <> show position)
runGame :: IO ()
runGame = do
let gameConfig
= GameConfig
{
}
gameState
= GameState
{ dimX = 800
, dimY = 450
, playerEntity = undefined
, cameraEntity = undefined
}
let gameConfig =
GameConfig
{
}
gameState =
GameState
{ dimX = 800
, dimY = 450
, playerEntity = undefined
, cameraEntity = undefined
}
RL.setTraceLogLevel RL.LogWarning
runEff . AE.runECS initWorld . evalState gameState . runReader gameConfig . runRaylibWindow gameState.dimX gameState.dimY "App" $ initialise >> whileM do
runEngine @World RPGEngine
not <$> windowShouldClose
runEff
. AE.runECS initWorld
. evalState gameState
. 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 ()

390
rpg/src/Pong.hs
View file

@ -1,28 +1,28 @@
{-# LANGUAGE AllowAmbiguousTypes #-}
module Pong (pongGame) where
import Effectful.State.Static.Local
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 Apecs.Effectful qualified as AE
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 qualified Data.Text as T
import Raylib.Core 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 GameState
= GameState
data 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
, top :: AE.Entity
, bottomBorder :: 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")
, ("top", "top")
, ("bottomBorder", "bottomBorder")
, ("topBorder", "topBorder")
, ("separator", "separator")
, ("score", "score")
] ''GameState
]
''GameState
data GameConfig
= GameConfig
data GameConfig = GameConfig
{ playArea :: Int
}
deriving Show
deriving (Show)
makeLensesFor
[ ("playArea", "playArea")
] ''GameConfig
]
''GameConfig
playerMovement
:: forall w es .
( Raylib :> es
:: forall w 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
(entity >>= flip (AE.modify @w @PositionComponent) (\(Position p) -> clampPosition playArea . Position $ V2 (p ^. _x) (p ^. _y + upSpeed)))
isKeyDown down >>= flip when
(entity >>= flip (AE.modify @w @PositionComponent) (\(Position p) -> clampPosition playArea . Position $ V2 (p ^. _x) (p ^. _y + downSpeed)))
where
clampPosition
:: Int
-> PositionComponent
-> 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
isKeyDown up
>>= flip
when
(entity >>= flip (AE.modify @w @PositionComponent) (\(Position p) -> clampPosition playArea . Position $ V2 (p ^. _x) (p ^. _y + upSpeed)))
isKeyDown down
>>= flip
when
(entity >>= flip (AE.modify @w @PositionComponent) (\(Position p) -> clampPosition playArea . Position $ V2 (p ^. _x) (p ^. _y + downSpeed)))
where
clampPosition
:: Int
-> PositionComponent
-> 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 .
( AE.ECS World :> es
:: forall 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
invertYVelocity
:: VelocityComponent
-> VelocityComponent
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
invertXVelocity
:: VelocityComponent
-> VelocityComponent
invertXVelocity (Velocity (V2 x y)) = Velocity $ V2 (-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 $ 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
( Camera playArea (0, 0)
, Position $ V2 0 0
)
cameraEntity <-
AE.newEntity @World
( Camera playArea (0, 0)
, Position $ V2 0 0
)
camera .= cameraEntity
player1Entity <- AE.newEntity @World
( Player
, Position $ V2 (-10) 0
, Box RL.white (0, 0) (0.5, 2)
, AABB (V2 0.5 2) (V2 0 0)
)
player1Entity <-
AE.newEntity @World
( Player
, Position $ V2 (-10) 0
, Box RL.white (0, 0) (0.5, 2)
, AABB (V2 0.5 2) (V2 0 0)
)
player1 .= player1Entity
player2Entity <- AE.newEntity @World
(Player
, Position $ V2 10 0
, Box RL.white (0, 0) (0.5, 2)
, AABB (V2 0.5 2) (V2 0 0)
)
player2Entity <-
AE.newEntity @World
( Player
, Position $ V2 10 0
, Box RL.white (0, 0) (0.5, 2)
, AABB (V2 0.5 2) (V2 0 0)
)
player2 .= player2Entity
ballEntity <- AE.newEntity @World
( Position $ V2 0 0
, Velocity 0.1 (-0.1)
, Box RL.white (0, 0) (0.5, 0.5)
, AABB (V2 0.5 0.5) (V2 0 0)
, Body (V2 0 0)
)
ballEntity <-
AE.newEntity @World
( Position $ V2 0 0
, Velocity $ V2 0.1 (-0.1)
, Box RL.white (0, 0) (0.5, 0.5)
, AABB (V2 0.5 0.5) (V2 0 0)
, Body (V2 0 0)
)
ball .= ballEntity
goal1Entity <- AE.newEntity @World
( 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)
)
goal2Entity <- AE.newEntity @World
( 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)
)
goal1Entity <-
AE.newEntity @World
( 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)
)
goal2Entity <-
AE.newEntity @World
( 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
( Position $ V2 0 (int2Float (-playArea) / 2)
, 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)
, AABB (V2 (int2Float playArea + 2) 0.1) (V2 0 0)
, Box RL.green (0, 0) (int2Float playArea + 2, 0.1)
)
top .= topEntity
bottom .= bottomEntity
topEntity <-
AE.newEntity @World
( Position $ V2 0 (int2Float (-playArea) / 2)
, 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)
, AABB (V2 (int2Float playArea + 2) 0.1) (V2 0 0)
, Box RL.green (0, 0) (int2Float playArea + 2, 0.1)
)
topBorder .= topEntity
bottomBorder .= bottomEntity
font <- getFontDefault
separatorEntity <- AE.newEntity @World
( Position $ V2 0 0
, Box RL.darkGray (0, 0) (0.1, int2Float playArea)
, TextBox font "" 3 0.1 RL.darkGray
)
separatorEntity <-
AE.newEntity @World
( Position $ V2 0 0
, 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
= GameState
{ dimX = 600
, dimY = 500
, player1 = undefined
, player2 = undefined
, camera = undefined
, ball = undefined
, goal1 = undefined
, goal2 = undefined
, top = undefined
, bottom = undefined
, separator = undefined
, score = (0, 0)
}
gameConfig
= GameConfig
{ playArea = 20
}
let gameState =
GameState
{ dimX = 600
, dimY = 500
, player1 = undefined
, player2 = undefined
, camera = undefined
, ball = undefined
, goal1 = undefined
, goal2 = undefined
, topBorder = undefined
, bottomBorder = undefined
, separator = undefined
, score = (0, 0)
}
gameConfig =
GameConfig
{ playArea = 20
}
-- RL.setTraceLogLevel RL.LogWarning
runEff . AE.runECS initWorld . evalState gameState . runReader gameConfig . runRaylibWindow gameState.dimX gameState.dimY "App" $ initialise >> whileM do
playerMovement @World
(RL.KeyW, -0.2)
(RL.KeyS, 0.2)
(gets @GameState (\s -> s.player1))
runEff . AE.runECS initWorld . evalState gameState . runReader gameConfig . runRaylibWindow gameState.dimX gameState.dimY "App" $
initialise >> whileM do
playerMovement @World
(RL.KeyW, -0.2)
(RL.KeyS, 0.2)
(gets @GameState (\s -> s.player1))
playerMovement @World
(RL.KeyUp, -0.2)
(RL.KeyDown, 0.2)
(gets @GameState (\s -> s.player2))
playerMovement @World
(RL.KeyUp, -0.2)
(RL.KeyDown, 0.2)
(gets @GameState (\s -> s.player2))
-- ballMovement
-- (gets @GameState (\s -> s.player1))
-- (gets @GameState (\s -> s.player2))
-- (gets @GameState (\s -> s.ball))
-- (gets @GameState (\s -> s.bottom))
-- (gets @GameState (\s -> s.top))
-- ballMovement
-- (gets @GameState (\s -> s.player1))
-- (gets @GameState (\s -> s.player2))
-- (gets @GameState (\s -> s.ball))
-- (gets @GameState (\s -> s.bottom))
-- (gets @GameState (\s -> s.top))
ballRespawn
(gets @GameState (\s -> s.goal2))
(gets @GameState (\s -> s.goal1))
(gets @GameState (\s -> s.ball))
ballRespawn
(gets @GameState (\s -> s.goal2))
(gets @GameState (\s -> s.goal1))
(gets @GameState (\s -> s.ball))
collisionAABB @World
applyVelocity @World
resolveAABB @World
collisionAABB @World
applyVelocity @World
resolveAABB @World
AE.cmapM_ @World @(AE.Entity, PositionComponent, CollisionComponent) \(entity, position, collision) ->
when (collision.colliders /= []) $ liftIO $ print (show entity <> " with " <> show collision.colliders <> " at " <> show position)
AE.cmapM_ @World @(AE.Entity, PositionComponent, CollisionComponent) \(entity, position, collision) ->
when (collision.colliders /= []) $ liftIO $ print (show entity <> " with " <> show collision.colliders <> " at " <> show position)
score' <- gets @GameState (\s -> s.score)
gets @GameState (\s -> s.separator)>>= flip (AE.modify @World @TextBoxComponent) \textBox ->
textBox { text = T.pack $ show score' }
score' <- gets @GameState (\s -> s.score)
gets @GameState (\s -> s.separator) >>= flip (AE.modify @World @TextBoxComponent) \textBox ->
textBox{text = T.pack $ show score'}
dims <- gets @GameState (\s -> (s.dimX, s.dimY))
camera <- getCamera @World (gets @GameState (\s -> s.camera)) dims
runDraw . runDraw2D camera $ do
clearBackground RL.gray
dims <- gets @GameState (\s -> (s.dimX, s.dimY))
camera <- getCamera @World (gets @GameState (\s -> s.camera)) dims
runDraw . runDraw2D camera $ do
clearBackground RL.gray
-- (gets @GameState (\s -> s.score)) >>= liftIO . print
-- (gets @GameState (\s -> s.score)) >>= liftIO . print
render @World
renderOrigins @World
renderBoundingBoxes @World
not <$> windowShouldClose
render @World
renderOrigins @World
renderBoundingBoxes @World
not <$> windowShouldClose

400
rpg/src/System/Physics.hs
View file

@ -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 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 qualified
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 .
( AE.Get w PositionComponent
:: 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
AE.cmap @w @(PositionComponent, VelocityComponent) @_
\(Position position, velocity) -> Position $ V2 (position ^. _x + velocity.x) (position ^. _y + velocity.y)
AE.cmapM @w @(AE.Entity, PositionComponent, VelocityComponent, Maybe AABBComponent) @_
\(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 -> AABBComponent
-> PositionComponent
-> 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
GT -> V2 offsetX 0
EQ -> V2 offsetX 0
in
Just Collider
{ other = bEntity
-- https://stackoverflow.com/questions/9324339/how-much-do-two-rectangles-overlap
, overlap = V2
((min (boundsA ^. _x) (boundsB ^. _x) - max (boundsA ^. _y) (boundsB ^. _y)) * normalize' offsetX)
((max (boundsA ^. _w) (boundsB ^. _w) - min (boundsA ^. _z) (boundsB ^. _z)) * normalize' offsetY)
, offset = offset
, normal = normalize foo
}
LT -> V2 0 offsetY
GT -> V2 offsetX 0
EQ -> V2 offsetX 0
in
Just
Collider
{ other = bEntity
, -- https://stackoverflow.com/questions/9324339/how-much-do-two-rectangles-overlap
overlap =
V2
((min (boundsA ^. right) (boundsB ^. right) - max (boundsA ^. left) (boundsB ^. left)) * normalize' offsetX)
((max (boundsA ^. bottom) (boundsB ^. bottom) - min (boundsA ^. top) (boundsB ^. top)) * normalize' offsetY)
, offset = offset
, normal = normalize foo
}
_ -> Nothing
testEntityCollision
:: forall w es .
( AE.Get w CollisionComponent
, AE.ECS w :> es )
:: forall w es
. ( AE.Get w CollisionComponent
, 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 .
( AE.Get w CollisionComponent
, AE.ECS w :> es )
:: forall w es
. ( AE.Get w CollisionComponent
, 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
Just collision -> pure $ testEntityCollision' collision a
Nothing -> pure Nothing
where
testEntityCollision' :: CollisionComponent -> AE.Entity -> Maybe Collider
testEntityCollision' collision other =
foldl (\case Just j -> const $ Just j ; Nothing -> \x -> if x.other == other then Just x else Nothing) Nothing collision.colliders
Nothing ->
AE.tryGet @w @CollisionComponent b >>= \case
Just collision -> pure $ testEntityCollision' collision a
Nothing -> pure Nothing
where
testEntityCollision' :: CollisionComponent -> AE.Entity -> Maybe Collider
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 .
( AE.Get w PositionComponent
:: forall w es
. ( 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
colliders <- flip (AE.cfoldM @w @(AE.Entity, PositionComponent, AABBComponent)) [] \acc (colliderEntity, colliderPosition, colliderAABB) ->
pure $ if bodyEntity /= colliderEntity then
case collides colliderEntity bodyPosition bodyAABB colliderPosition colliderAABB of
Just collider -> collider : acc
Nothing -> acc
else
acc
pure $ Collision { colliders = colliders }
\(bodyEntity, bodyPosition, _, bodyAABB) -> do
colliders <- flip (AE.cfoldM @w @(AE.Entity, PositionComponent, AABBComponent)) [] \acc (colliderEntity, colliderPosition, colliderAABB) ->
pure $
if bodyEntity /= colliderEntity
then case collides colliderEntity bodyPosition bodyAABB colliderPosition colliderAABB of
Just collider -> collider : acc
Nothing -> acc
else acc
pure $ Collision{colliders = colliders}
resolveAABB
:: forall w es .
( AE.Get w PositionComponent
:: forall w es
. ( 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 resolve :: V2 Float -> Collider -> V2 Float
resolve position collider =
case collider.overlap of
V2 x y | abs x < abs y -> position & _x %~ flip (-) x
V2 x y | abs y < abs x -> position & _y %~ (+) y
V2 x _ -> position & _x %~ flip (-) x
where
-- pure . Position $ foldl resolve position collision.colliders
resolve :: V2 Float -> Collider -> V2 Float
resolve position collider =
case collider.overlap of
V2 x y | abs x < abs y -> position & _x %~ flip (-) x
V2 x y | abs y < abs x -> position & _y %~ (+) y
V2 x _ -> position & _x %~ flip (-) x

14
rpg/src/System/Renderer.hs
View file

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

2
snake/app/Main.hs
View file

@ -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 ->

4
stack.yaml
View file

@ -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: []