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

Random stuff, preparing for Minkowski difference physics

Browse source 
Signed-off-by: magic_rb <richard@brezak.sk>
This commit is contained in:
magic_rb 2023-10-29 14:30:54 +01:00
parent ee69651f5a
commit 19c8af10ce
No known key found for this signature in database
GPG key ID: 08D5287CC5DDCA0E
15 changed files with 529 additions and 155 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

4
rpg/rpg.cabal
View file

@ -30,11 +30,15 @@ library
Component.Body
Component.Box
Component.Camera
Component.Collision
Component.Player
Component.Position
Component.TextBox
Component.Velocity
Effectful.Raylib
Effectful.Reader.Static.State
Effectful.State.Static.Local.Lens
Engine
Lib
Pong
System.Physics

34
rpg/src/Common.hs
View file

@ -1,11 +1,14 @@
{-# LANGUAGE AllowAmbiguousTypes #-}
module Common ( getCamera ) where
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
import Control.Lens
import Effectful.Raylib
getCamera
:: forall w es .
@ -18,10 +21,35 @@ getCamera
-> Eff es RL.Camera2D
getCamera eff (dimX, dimY) = do
entity <- eff
(c, p) <- AE.get @w @(CameraComponent, PositionComponent) entity
(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 (p.x + fst c.offset) (p.y + snd c.offset)
, 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
, AE.ECS w :> es
, AE.Get w VelocityComponent
)
=> AE.Entity
-> ( RL.KeyboardKey
, RL.KeyboardKey
, RL.KeyboardKey
, RL.KeyboardKey
)
-> Float
-> 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) )
]
let movement = foldl (+) (V2 0 0) $ map snd $ filter fst directions
AE.modify @w @() @VelocityComponent player (\() -> Velocity (movement ^. _x) (movement ^. _y))

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

@ -19,7 +19,7 @@ data AABBComponent
instance Component AABBComponent where type Storage AABBComponent = Map AABBComponent
aabbBounds :: PositionComponent -> AABBComponent -> V4 Float
aabbBounds (Position posX posY) (AABB (V2 sizeX sizeY) (V2 offsetX offsetY)) =
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)

10
rpg/src/Component/Body.hs
View file

@ -1,10 +1,16 @@
{-# LANGUAGE TypeFamilies #-}
module Component.Body (BodyComponent(..)) where
module Component.Body (BodyComponent(..), previousPosition) where
import Apecs.Effectful
import Linear.V2
import Control.Lens
data BodyComponent
= Body
{ }
{ previousPosition :: V2 Float
}
deriving Show
instance Component BodyComponent where type Storage BodyComponent = Map BodyComponent
makeLensesFor
[ ("previousPosition", "previousPosition")
] ''BodyComponent

25
rpg/src/Component/Collision.hs Normal file
View file

@ -0,0 +1,25 @@
{-# LANGUAGE TypeFamilies #-}
module Component.Collision
( CollisionComponent(..)
, Collider(..)
) where
import qualified Apecs.Effectful as AE
import Linear.V2
data Collider
= Collider
{ other :: AE.Entity
, overlap :: V2 Float
, offset :: V2 Float
, normal :: V2 Float
}
deriving (Eq, Show)
data CollisionComponent
= Collision
{ colliders :: [Collider]
}
deriving Show
instance AE.Component CollisionComponent where type Storage CollisionComponent = AE.Map CollisionComponent

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

@ -3,12 +3,9 @@
module Component.Position (PositionComponent(..)) where
import Apecs.Effectful
import Linear.V2
data PositionComponent
= Position
{ x :: Float
, y :: Float
}
newtype PositionComponent
= Position (V2 Float)
deriving Show
instance Component PositionComponent where type Storage PositionComponent = Map PositionComponent

20
rpg/src/Component/TextBox.hs Normal file
View file

@ -0,0 +1,20 @@
{-# LANGUAGE TypeFamilies #-}
module Component.TextBox
( TextBoxComponent(..)
) where
import qualified Apecs.Effectful as AE
import qualified Raylib.Types as RL
import Data.Text (Text)
data TextBoxComponent
= TextBox
{ font :: RL.Font
, text :: Text
, fontSize :: Float
, spacing :: Float
, color :: RL.Color
}
deriving Show
instance AE.Component TextBoxComponent where type Storage TextBoxComponent = AE.Map TextBoxComponent

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

@ -3,10 +3,12 @@
module Effectful.Raylib
( setTargetFPS
, windowShouldClose
, getFontDefault
, isKeyDown
, runDraw
, clearBackground
, runDraw2D
, measureText
, drawText
, drawRectangle
, drawLine
@ -24,11 +26,12 @@ 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 GHC.Float
import Linear (V2 (..))
data Raylib :: Effect where
SetTargetFPS :: Int -> Raylib (Eff es) ()
WindowShouldClose :: Raylib (Eff es) Bool
GetFontDefault :: Raylib (Eff es) RL.Font
IsKeyDown :: RL.KeyboardKey -> Raylib (Eff es) Bool
RunDraw :: (IOE :> es) => Eff (RaylibDraw : es) a -> Raylib (Eff es) a
type instance DispatchOf Raylib = Dynamic
@ -39,7 +42,8 @@ data RaylibDraw :: Effect where
type instance DispatchOf RaylibDraw = Dynamic
data RaylibDraw2D :: Effect where
DrawText :: Text -> Int -> Int -> Int -> RL.Color -> RaylibDraw2D (Eff es) ()
MeasureText :: RL.Font -> Text -> Float -> Float -> RaylibDraw2D (Eff es) (V2 Float)
DrawText :: RL.Font -> Text -> V2 Float -> Float -> Float -> RL.Color -> RaylibDraw2D (Eff es) ()
DrawRectangle :: Float -> Float -> Float -> Float -> RL.Color -> RaylibDraw2D (Eff es) ()
DrawLine :: Float -> Float -> Float -> Float -> RL.Color -> RaylibDraw2D (Eff es) ()
type instance DispatchOf RaylibDraw2D = Dynamic
@ -50,6 +54,9 @@ setTargetFPS fps = send (SetTargetFPS fps)
windowShouldClose :: (HasCallStack, Raylib :> es) => Eff es Bool
windowShouldClose = send WindowShouldClose
getFontDefault :: (HasCallStack, Raylib :> es) => Eff es RL.Font
getFontDefault = send GetFontDefault
isKeyDown :: (HasCallStack, Raylib :> es) => RL.KeyboardKey -> Eff es Bool
isKeyDown key = send (IsKeyDown key)
@ -62,8 +69,11 @@ clearBackground color = send (ClearBackground color)
runDraw2D :: (HasCallStack, IOE :> es, RaylibDraw :> es) => RL.Camera2D -> Eff (RaylibDraw2D : es) a -> Eff es a
runDraw2D camera effect = send (RunDraw2D camera effect)
drawText :: (HasCallStack, RaylibDraw2D :> es) => Text -> Int -> Int -> Int -> RL.Color -> Eff es ()
drawText text posX posY fontSize color = send (DrawText text posX posY fontSize color)
measureText :: (HasCallStack, RaylibDraw2D :> es) => RL.Font -> Text -> Float -> Float -> Eff es (V2 Float)
measureText font text fontSize spacing = send $ MeasureText font text fontSize spacing
drawText :: (HasCallStack, RaylibDraw2D :> es) => RL.Font -> Text -> V2 Float -> Float -> Float -> RL.Color -> Eff es ()
drawText font text position fontSize spacing color = send (DrawText font text position fontSize spacing color)
drawRectangle :: (HasCallStack, RaylibDraw2D :> es) => Float -> Float -> Float -> Float -> RL.Color -> Eff es ()
drawRectangle posX posY width height color = send (DrawRectangle posX posY width height color)
@ -77,7 +87,8 @@ runRaylibWindow width height name effect = do
interpret' effect $ \env eff -> localSeqUnlift env \unlift ->
case eff of
WindowShouldClose -> liftIO $ RL.windowShouldClose
WindowShouldClose -> liftIO RL.windowShouldClose
GetFontDefault -> liftIO RL.getFontDefault
SetTargetFPS fps -> liftIO $ RL.setTargetFPS fps
IsKeyDown key -> liftIO $ RL.isKeyDown key
RunDraw drawEffect -> unlift $ runRaylibDrawing drawEffect
@ -99,7 +110,11 @@ runRaylibWindow width height name effect = do
liftIO (RL.beginMode2D camera)
res <- interpret' effect' $ \env eff -> localSeqUnlift env \unlift ->
case eff of
DrawText text posX posY fontSize color -> liftIO $ RL.drawText (T.unpack text) posX posY fontSize color
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

25
rpg/src/Effectful/Reader/Static/State.hs Normal file
View file

@ -0,0 +1,25 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeFamilies #-}
module Effectful.Reader.Static.State
( Reads
, Effectful.Reader.Static.State.read
, Effectful.Reader.Static.State.reads
, readsM
) where
import Effectful
import Effectful.Dispatch.Dynamic
data Reads r :: Effect where
Reads :: (r -> m a) -> (Reads r) m a
type instance DispatchOf (Reads r) = Dynamic
read :: (HasCallStack, Reads r :> es) => Eff es r
read = send $ Reads pure
reads :: (HasCallStack, Reads r :> es) => (r -> a) -> Eff es a
reads reader = send $ Reads (pure . reader)
readsM :: (HasCallStack, Reads r :> es) => (r -> Eff es a) -> Eff es a
readsM reader = send $ Reads reader

63
rpg/src/Engine.hs Normal file
View file

@ -0,0 +1,63 @@
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE UndecidableInstances #-}
module Engine ( Engine(..), runEngine ) where
import Effectful
import System.Physics
import World
import qualified Apecs.Effectful as AE
import qualified Raylib.Types as RL
import System.Renderer
import Effectful.Raylib
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
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
)
=> a
-> Eff es ()
runEngine engine = do
engineInput engine
applyVelocity @w
collisionAABB @w
resolveAABB @w
enginePhysics engine
c <- engineGetCamera engine
runDraw . runDraw2D c $ do
color <- inject $ engineClearColor engine
clearBackground color
inject $ engineRendering engine
render @w
renderOrigins @w
renderBoundingBoxes @w
renderCollision @w

82
rpg/src/Lib.hs
View file

@ -10,6 +10,7 @@
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE UndecidableInstances #-}
module Lib
( runGame
@ -41,6 +42,7 @@ import System.Renderer
import Common
import Linear.V2
import System.Physics
import Engine
data GameConfig
= GameConfig
@ -69,7 +71,14 @@ spawnPlayer
:: ( AE.ECS World :> es )
=> RL.Color
-> Eff es AE.Entity
spawnPlayer color = AE.newEntity @World (Player, Position 0 2, Camera 10 (0, 0), AABB (V2 1 1) (V2 0 0), Body, Box color (0, 0) (1, 1))
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)
)
movePlayer
:: ( AE.ECS World :> es )
@ -78,8 +87,8 @@ movePlayer
-> Eff es ()
movePlayer eff (x, y) = do
entity <- eff
AE.modify @World @PositionComponent @PositionComponent entity (\p -> Position (p.x + x) (p.y + y))
AE.modify @World @() @VelocityComponent entity (\() -> Velocity x y)
-- AE.modify @World @PositionComponent @PositionComponent entity (\(Position p) -> Position $ V2 (p ^. _x + x) (p ^. _y + y))
spawnBox
:: ( AE.ECS World :> es )
@ -87,7 +96,11 @@ spawnBox
-> RL.Color
-> (Float, Float)
-> Eff es AE.Entity
spawnBox (posx, posy) color size = AE.newEntity @World (Box color size (0, 0), Position posx posy, AABB (V2 1 1) (V2 0 0))
spawnBox (posx, posy) color size = AE.newEntity @World
( Box color (0, 0) size
, Position $ V2 posx posy
, AABB (V2 1 1) (V2 0 0)
)
initialise
:: ( Raylib :> es
@ -101,13 +114,46 @@ initialise = do
playerEntity .= player
cameraEntity .= player
box1 <- AE.newEntity @World (Box RL.gray (0,0) (1,1), Position 0 0, AABB (V2 1 1) (V2 0 0))
-- box2 <- AE.newEntity @World (Box RL.gray (0,0) (1,1), Position 2 0, AABB (V2 1 1) (V2 0 0))
boxes .= [box1--, box2
]
_ <- spawnBox (0, 0) RL.gray (1, 1)
_ <- spawnBox (2, 0) RL.gray (1, 1)
_ <- spawnBox (3, 0) RL.gray (1, 1)
_ <- spawnBox (3, 1) RL.gray (1, 1)
boxes .= []
pure ()
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
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
runGame :: IO ()
runGame = do
let gameConfig
@ -124,26 +170,8 @@ runGame = do
RL.setTraceLogLevel RL.LogWarning
runEff . AE.runECS initWorld . evalState gameState . runReader gameConfig . runRaylibWindow gameState.dimX gameState.dimY "App" $ initialise >> whileM do
collisionAABB @World
isKeyDown RL.KeyA >>= flip when (movePlayer (gets @GameState (\s -> s.playerEntity)) (-0.1, 0))
isKeyDown RL.KeyD >>= flip when (movePlayer (gets @GameState (\s -> s.playerEntity)) (0.1, 0))
isKeyDown RL.KeyS >>= flip when (movePlayer (gets @GameState (\s -> s.playerEntity)) (0, 0.1))
isKeyDown RL.KeyW >>= flip when (movePlayer (gets @GameState (\s -> s.playerEntity)) (0, -0.11))
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}))
dims <- gets @GameState (\s -> (s.dimX, s.dimY))
c <- getCamera @World (gets @GameState (\s -> s.cameraEntity)) dims
runDraw . runDraw2D c $ do
clearBackground RL.rayWhite
render @World
renderOrigins @World
renderBoundingBoxes @World
runEngine @World RPGEngine
not <$> windowShouldClose
pure ()

199
rpg/src/Pong.hs
View file

@ -11,13 +11,15 @@ import Effectful.Raylib
import Control.Monad.Extra
import World
import qualified Raylib.Util.Colors as RL
import Common
import Common hiding (playerMovement)
import Effectful.State.Static.Local.Lens
import Control.Lens hiding ((.=), (%=))
import System.Renderer
import GHC.Float
import System.Physics
import Linear.V2
import qualified Linear as L
import qualified Data.Text as T
data GameState
= GameState
@ -31,17 +33,33 @@ data GameState
, goal2 :: AE.Entity
, bottom :: AE.Entity
, top :: AE.Entity
, separator :: AE.Entity
, score :: (Int, Int)
}
deriving Show
makeLensesFor [("dimX", "dimX"), ("dimY", "dimY"), ("camera", "camera"), ("player1", "player1"), ("player2", "player2"), ("ball", "ball"), ("goal1", "goal1"), ("goal2", "goal2"), ("bottom", "bottom"), ("top", "top"), ("score", "score")] ''GameState
makeLensesFor
[ ("dimX", "dimX")
, ("dimY", "dimY")
, ("camera", "camera")
, ("player1", "player1")
, ("player2", "player2")
, ("ball", "ball")
, ("goal1", "goal1")
, ("goal2", "goal2")
, ("bottom", "bottom")
, ("top", "top")
, ("separator", "separator")
, ("score", "score")
] ''GameState
data GameConfig
= GameConfig
{ playArea :: Int
}
deriving Show
makeLensesFor [("playArea", "playArea")] ''GameConfig
makeLensesFor
[ ("playArea", "playArea")
] ''GameConfig
playerMovement
:: forall w es .
@ -58,33 +76,30 @@ playerMovement
playerMovement (up, upSpeed) (down, downSpeed) entity = do
playArea <- asks @GameConfig (\c -> c.playArea)
isKeyDown up >>= flip when
(entity >>= flip (AE.modify @w @PositionComponent) (\p -> clampPosition playArea $ Position p.x (p.y + upSpeed)))
(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) (\p -> clampPosition playArea $ Position p.x (p.y + downSpeed)))
(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 x y)
| y > int2Float playArea / 2 - 1 = Position x (int2Float playArea / 2 - 1)
| y < int2Float playArea / 2 * (-1) + 1 = Position x (int2Float playArea / 2 * (-1) + 1)
| otherwise = Position x y
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
, Reader GameConfig :> es
)
=> Eff es Int
-> Eff es AE.Entity
=> Eff es AE.Entity
-> Eff es AE.Entity
-> Eff es AE.Entity
-> Eff es AE.Entity
-> Eff es AE.Entity
-> Eff es ()
ballMovement playArea player1 player2 ball top bottom = do
playArea' <- playArea
ballMovement player1 player2 ball top bottom = do
player1' <- player1
player2' <- player2
ball' <- ball
@ -93,16 +108,13 @@ ballMovement playArea player1 player2 ball top bottom = do
ballVelocity <- ball >>= AE.get @World
newVelocity <- ballMovement'
playArea'
ballMovement'
ball'
player1'
player2'
ball'
bottom'
top'
ballVelocity
ball >>= \ballEntity -> AE.set @World ballEntity newVelocity
ballVelocity >>= AE.set @World ball'
where
invertYVelocity
@ -116,26 +128,31 @@ ballMovement playArea player1 player2 ball top bottom = do
invertXVelocity (Velocity x y) = Velocity (-x) y
ballMovement'
:: ( AE.ECS World :> es
)
=> Int
-> AE.Entity
:: AE.Entity
-> AE.Entity
-> AE.Entity
-> AE.Entity
-> AE.Entity
-> VelocityComponent
-> Eff es VelocityComponent
ballMovement' playArea player1 player2 ball bottom top ballVelocity = do
player1Collision <- collidesEntities @World (pure player1) (pure ball)
player2Collision <- collidesEntities @World (pure player2) (pure ball)
bottomCollision <- collidesEntities @World (pure bottom) (pure ball)
topCollision <- collidesEntities @World (pure top) (pure ball)
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
let ret
| player1Collision || player2Collision = invertXVelocity ballVelocity
| bottomCollision || topCollision = invertYVelocity ballVelocity
| otherwise = ballVelocity
pure ret
@ -150,17 +167,17 @@ ballRespawn
-> Eff es ()
ballRespawn goal1 goal2 ball = do
goal1' <- goal1
ball' <- ball
goal2' <- goal2
ball' <- ball
goal1Collision <- collidesEntities @World (pure goal1') (pure ball')
goal2Collision <- collidesEntities @World (pure goal2') (pure ball')
goal1c <- testEntityCollision @World ball' goal1'
goal2c <- testEntityCollision @World ball' goal2'
let
respawn = AE.set @World ball' (Position 0 0)
respawn = AE.set @World ball' (Position $ V2 0 0)
ret
| goal1Collision = (score . _1) %= (+) 1 >> respawn
| goal2Collision = (score . _2) %= (+) 1 >> respawn
| goal1c = (score . _1) %= (+) 1 >> respawn
| goal2c = (score . _2) %= (+) 1 >> respawn
| otherwise = pure ()
ret
@ -175,28 +192,71 @@ initialise = do
setTargetFPS 60
playArea <- asks @GameConfig (\s -> s.playArea)
cameraEntity <- AE.newEntity @World (Camera playArea (0, 0), Position 0 0)
cameraEntity <- AE.newEntity @World
( Camera playArea (0, 0)
, Position $ V2 0 0
)
camera .= cameraEntity
player1Entity <- AE.newEntity @World (Player, Position (-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 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 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))
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)
)
ball .= ballEntity
goal1Entity <- AE.newEntity @World (Position (int2Float (-playArea) / 2 - 1) 0, AABB (V2 0.1 (int2Float playArea)) (V2 0 0))
goal2Entity <- AE.newEntity @World (Position (int2Float playArea / 2 + 1) 0, AABB (V2 0.1 (int2Float playArea)) (V2 0 0))
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 0 (int2Float (-playArea) / 2), AABB (V2 (int2Float playArea + 2) 0.1) (V2 0 0))
bottomEntity <- AE.newEntity @World (Position 0 (int2Float playArea / 2), AABB (V2 (int2Float playArea + 2) 0.1) (V2 0 0))
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
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
)
separator .= separatorEntity
pure ()
pongGame :: IO ()
@ -213,6 +273,7 @@ pongGame = do
, goal2 = undefined
, top = undefined
, bottom = undefined
, separator = undefined
, score = (0, 0)
}
gameConfig
@ -221,21 +282,6 @@ pongGame = do
}
-- RL.setTraceLogLevel RL.LogWarning
runEff . AE.runECS initWorld . evalState gameState . runReader gameConfig . runRaylibWindow gameState.dimX gameState.dimY "App" $ initialise >> whileM do
ballRespawn
(gets @GameState (\s -> s.goal2))
(gets @GameState (\s -> s.goal1))
(gets @GameState (\s -> s.ball))
ballMovement
(asks @GameConfig (\c -> c.playArea))
(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))
applyVelocity @World
playerMovement @World
(RL.KeyW, -0.2)
(RL.KeyS, 0.2)
@ -246,14 +292,37 @@ pongGame = do
(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))
ballRespawn
(gets @GameState (\s -> s.goal2))
(gets @GameState (\s -> s.goal1))
(gets @GameState (\s -> s.ball))
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)
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
(gets @GameState (\s -> s.score)) >>= liftIO . print
-- (gets @GameState (\s -> s.score)) >>= liftIO . print
render @World
-- renderOrigins @World
-- renderBoundingBoxes @World
renderOrigins @World
renderBoundingBoxes @World
not <$> windowShouldClose

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

@ -1,7 +1,6 @@
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE MonoLocalBinds #-}
module System.Physics (applyVelocity, collides, collisionAABB, collidesEntities) where
module System.Physics (applyVelocity, testEntityCollision, getEntityCollision, collides, collisionAABB, resolveAABB) where
import World
import qualified Apecs.Effectful as AE
@ -14,6 +13,7 @@ import qualified Apecs
import qualified Apecs.Core
import Apecs.Components (EntityStore)
import Control.Monad.Extra
import qualified Debug.Trace as Debut.Trace
applyVelocity
:: forall w es .
@ -25,54 +25,114 @@ applyVelocity
=> Eff es ()
applyVelocity = do
AE.cmap @w @(PositionComponent, VelocityComponent) @_
\(position, velocity) -> Position (position.x + velocity.x) (position.y + velocity.y)
\(Position position, velocity) -> Position $ V2 (position ^. _x + velocity.x) (position ^. _y + velocity.y)
collides
:: PositionComponent -> AABBComponent
:: AE.Entity
-> PositionComponent -> AABBComponent
-> Bool
collides positionA aabbA positionB aabbB = do
-> PositionComponent -> AABBComponent
-> Maybe Collider
collides bEntity (Position positionA) aabbA (Position positionB) aabbB = do
-- V4 x -x y -y
let boundsA = aabbBounds positionA aabbA
boundsB = aabbBounds positionB aabbB
let boundsA = aabbBounds (Position positionA) aabbA
boundsB = aabbBounds (Position positionB) aabbB
case (boundsA ^. _x > boundsB ^. _y, boundsB ^. _x > boundsA ^. _y, boundsA ^. _z > boundsB ^. _w, boundsB ^. _z > boundsA ^. _w) of
(True, True, True, True) -> True
_ -> False
case (boundsA ^. _y - boundsB ^. _x <= 0, boundsA ^. _x - boundsB ^. _y >= 0, boundsB ^. _w - boundsA ^. _z <= 0, boundsB ^. _z - boundsA ^. _w >= 0) of
(True, True, True, True) ->
let
offsetX = (positionB ^. _x - positionA ^. _x)
offsetY = (positionB ^. _y - positionA ^. _y)
offset = V2 (positionB ^. _x - positionA ^. _x) (positionB ^. _y - positionA ^. _y)
normalize' num
| num < 0 = -1
| otherwise = 1
-- 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
}
_ -> Nothing
collidesEntities
testEntityCollision
:: forall w es .
( AE.Get w PositionComponent
, AE.Get w AABBComponent
( AE.Get w CollisionComponent
, AE.ECS w :> es )
=> Eff es AE.Entity
-> Eff es AE.Entity
=> AE.Entity
-> AE.Entity
-> Eff es Bool
collidesEntities a b = do
a' <- a
b' <- b
positionA <- AE.get @w a'
aabbA <- AE.get @w a'
positionB <- AE.get @w b'
aabbB <- AE.get @w b'
pure $ collides positionA aabbA positionB aabbB
testEntityCollision a b = getEntityCollision @w a b <&> \case Just _ -> True ; Nothing -> False
getEntityCollision
:: 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
collisionAABB
:: forall w es .
( AE.Get w PositionComponent
, AE.Get w VelocityComponent
, AE.Get w BodyComponent
, AE.Get w AABBComponent
, AE.Get w CollisionComponent
, AE.ECS w :> es
)
=> Eff es ()
collisionAABB =
AE.cmapM @w @(AE.Entity, PositionComponent, BodyComponent, AABBComponent)
\(bodyEntity, bodyPosition, bodyBody, bodyAABB) ->
AE.cmapM @w @(AE.Entity, PositionComponent, AABBComponent)
\(colliderEntity, colliderPosition, colliderAABB) -> when (bodyEntity /= colliderEntity) do
let collision = collides bodyPosition bodyAABB colliderPosition colliderAABB
unsafeEff_ $ print collision
pure ()
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 }
resolveAABB
:: forall w es .
( AE.Get w PositionComponent
, AE.Get w BodyComponent
, AE.Get w CollisionComponent
, AE.ECS w :> es
, IOE :> es
)
=> Eff es ()
resolveAABB = do
void $ AE.cmapM @w @(PositionComponent, BodyComponent, CollisionComponent) @PositionComponent
\(Position position, Body previousPosition, collision) ->
case collision.colliders of
(_:_) -> 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

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

@ -1,5 +1,5 @@
{-# LANGUAGE AllowAmbiguousTypes #-}
module System.Renderer (render, renderOrigins, renderBoundingBoxes) where
module System.Renderer (render, renderOrigins, renderBoundingBoxes, renderCollision) where
import Effectful
import qualified Apecs.Effectful as AE
@ -7,19 +7,46 @@ import World
import Effectful.Raylib
import qualified Raylib.Util.Colors as RL
import Linear.V4
import Linear.V2 (V2(..))
import Control.Lens
import Control.Monad
render
:: forall w es .
( AE.Get w PositionComponent
, AE.Get w BoxComponent
, AE.Get w TextBoxComponent
, AE.ECS w :> es
, RaylibDraw2D :> es )
=> Eff es ()
render = do
AE.cmapM_ @w @(PositionComponent, BoxComponent)
\(pos, Box color offset size) -> drawRectangle (pos.x + fst offset - fst size / 2) (pos.y + snd offset - snd size / 2) (fst size) (snd size) color
\(Position (V2 x y), Box color offset size) -> drawRectangle (x + fst offset - fst size / 2) (y + snd offset - snd size / 2) (fst size) (snd size) color
AE.cmapM_ @w @(PositionComponent, TextBoxComponent)
\(Position position, TextBox font text fontSize spacing color) -> do
size <- measureText font text fontSize spacing
drawText font text (V2 (position ^. _x - size ^. _x / 2) (position ^. _y - size ^. _y / 2)) fontSize spacing color
pure ()
renderCollision
:: forall w es .
( AE.Get w PositionComponent
, AE.Get w CollisionComponent
, AE.Get w BoxComponent
, AE.ECS w :> es
, RaylibDraw2D :> es
)
=> Eff es ()
renderCollision =
AE.cmapM_ @w @(PositionComponent, CollisionComponent, BoxComponent)
\(Position (V2 x y), Collision colliders, _) ->
forM_ colliders
(\(Collider _ (V2 overlapX overlapY) (V2 offsetX offsetY) _) -> do
drawLine x y (x + offsetX) (y + offsetY) RL.green
drawLine (x + offsetX / 2) (y + offsetY / 2) (x + offsetX / 2 + overlapX / 2) (y + offsetY / 2 + overlapY / 2) RL.yellow
drawLine (x + offsetX / 2) (y + offsetY / 2) (x + offsetX / 2 - overlapX / 2) (y + offsetY / 2 - overlapY / 2) RL.orange
)
renderOrigins
:: forall w es .
( AE.Get w PositionComponent
@ -29,8 +56,9 @@ renderOrigins
=> Eff es ()
renderOrigins = do
AE.cmapM_ @w @PositionComponent
\pos -> drawLine (pos.x - 0.1) (pos.y - 0.1) (pos.x + 0.1) (pos.y + 0.1) RL.red >>
drawLine (pos.x + 0.1) (pos.y - 0.1) (pos.x - 0.1) (pos.y + 0.1) RL.red
\(Position (V2 x y)) ->
drawLine (x - 0.1) (y - 0.1) (x + 0.1) (y + 0.1) RL.red >>
drawLine (x + 0.1) (y - 0.1) (x - 0.1) (y + 0.1) RL.red
renderBoundingBoxes
:: forall w es .

12
rpg/src/World.hs
View file

@ -12,6 +12,8 @@ module World
, module Component.Velocity
, module Component.AABB
, module Component.Body
, module Component.Collision
, module Component.TextBox
) where
import Component.Position
@ -21,15 +23,19 @@ import Component.Box
import Component.Velocity
import Component.AABB
import Component.Body
import Component.Collision
import Component.TextBox
import Apecs
import qualified Apecs.Effectful as AE
import Apecs.Core
import Apecs.Components
import Data.Vector.Unboxed
import Control.Monad.IO.Class (MonadIO)
makeWorld "World" [''PositionComponent, ''PlayerComponent, ''CameraComponent, ''BoxComponent, ''VelocityComponent, ''AABBComponent, ''BodyComponent]
makeWorld "World" [''PositionComponent, ''PlayerComponent, ''CameraComponent, ''BoxComponent, ''VelocityComponent, ''AABBComponent, ''BodyComponent, ''CollisionComponent, ''TextBoxComponent]
instance Monad m => ExplMembers m EntityStore where
instance (MonadIO m, Monad m) => ExplMembers m EntityStore where
explMembers :: EntityStore -> m (Vector Int)
explMembers _ = do
pure $ generate 10000 ((-) 1)
pure $ generate 1000 id