mirror of
https://git.sr.ht/~magic_rb/haskell-games
synced 2024-11-21 07:14:21 +01:00
Full swept AABB collision and resolution
Signed-off-by: magic_rb <richard@brezak.sk>
This commit is contained in:
parent
19c8af10ce
commit
e485fe4a7b
1
.dir-locals.el
Normal file
1
.dir-locals.el
Normal file
|
|
@ -0,0 +1 @@
|
|||
((haskell-mode . ((apheleia-formatter . fourmolu) (apheleia-mode . t))))
|
||||
|
|
@ -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": {
|
||||
|
|
|
|||
|
|
@ -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
51
fourmolu.yaml
Normal 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
7
rpg/minkowski/Main.hs
Normal file
|
|
@ -0,0 +1,7 @@
|
|||
module Main where
|
||||
|
||||
import Executables.Minkowski
|
||||
|
||||
main = do
|
||||
print "test"
|
||||
main'
|
||||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -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
|
||||
}
|
||||
)
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
47
rpg/src/Effectful/Accessor.hs
Normal 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)
|
||||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
213
rpg/src/Executables/Minkowski.hs
Normal 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
231
rpg/src/Lib.hs
|
|
@ -1,56 +1,56 @@
|
|||
{-# LANGUAGE ImportQualifiedPost #-}
|
||||
{-# LANGUAGE BlockArguments #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE ImportQualifiedPost #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE TypeData #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
|
||||
module Lib
|
||||
( 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
390
rpg/src/Pong.hs
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 ->
|
||||
|
||||
|
|
|
|||
|
|
@ -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: []
|
||||
|
||||
|
|
|
|||
Loading…
Reference in a new issue