Full swept AABB collision and resolution

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

1
.dir-locals.el Normal file
View file

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

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": {

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'

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

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

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

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

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

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

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)

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

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

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

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

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