mirror of
https://git.sr.ht/~magic_rb/haskell-games
synced 2024-11-25 17:46:14 +01:00
Compare commits
No commits in common. "885bf8943b7c097254daebd146972d714e7b01de" and "e485fe4a7b6f2af00036ac02f681fe4ef290870f" have entirely different histories.
885bf8943b
...
e485fe4a7b
|
|
@ -53,7 +53,6 @@
|
|||
xorg.libXi
|
||||
xorg.libXext
|
||||
xorg.libXdmcp
|
||||
xorg.libXxf86vm
|
||||
libglvnd
|
||||
httplz
|
||||
((raylib.override { includeEverything = true; }).overrideAttrs (old: {
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
module Main where
|
||||
|
||||
import Executables.RPG
|
||||
import Lib
|
||||
|
||||
main = runGame
|
||||
|
|
@ -32,12 +32,6 @@ dependencies:
|
|||
- linear
|
||||
- extra
|
||||
- vector
|
||||
- mtl
|
||||
- unordered-containers
|
||||
- primitive
|
||||
- containers
|
||||
- GLFW-b
|
||||
- OpenGL
|
||||
|
||||
language: GHC2021
|
||||
default-extensions:
|
||||
|
|
@ -66,7 +60,7 @@ library:
|
|||
executables:
|
||||
rpg-exe:
|
||||
main: Main.hs
|
||||
source-dirs: rpg
|
||||
source-dirs: app
|
||||
ghc-options:
|
||||
- -threaded
|
||||
- -rtsopts
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
module Main where
|
||||
|
||||
import Executables.Pong
|
||||
import Pong
|
||||
|
||||
main :: IO ()
|
||||
main = pongGame
|
||||
|
|
|
|||
|
|
@ -41,12 +41,8 @@ library
|
|||
Effectful.State.Static.Local.Lens
|
||||
Engine
|
||||
Executables.Minkowski
|
||||
Executables.Pong
|
||||
Executables.RPG
|
||||
Noise.Perlin
|
||||
Signals
|
||||
Stores.SparseSet
|
||||
System.OpenGLRenderer
|
||||
Lib
|
||||
Pong
|
||||
System.Physics
|
||||
System.Renderer
|
||||
World
|
||||
|
|
@ -66,23 +62,17 @@ library
|
|||
LambdaCase
|
||||
ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints
|
||||
build-depends:
|
||||
GLFW-b
|
||||
, OpenGL
|
||||
, apecs
|
||||
apecs
|
||||
, apecs-effectful
|
||||
, base >=4.7 && <5
|
||||
, bytestring
|
||||
, containers
|
||||
, effectful
|
||||
, effectful-core
|
||||
, extra
|
||||
, h-raylib
|
||||
, lens
|
||||
, linear
|
||||
, mtl
|
||||
, primitive
|
||||
, text
|
||||
, unordered-containers
|
||||
, vector
|
||||
default-language: GHC2021
|
||||
|
||||
|
|
@ -104,24 +94,18 @@ executable minkowski
|
|||
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:
|
||||
GLFW-b
|
||||
, OpenGL
|
||||
, apecs
|
||||
apecs
|
||||
, apecs-effectful
|
||||
, base >=4.7 && <5
|
||||
, bytestring
|
||||
, containers
|
||||
, effectful
|
||||
, effectful-core
|
||||
, extra
|
||||
, h-raylib
|
||||
, lens
|
||||
, linear
|
||||
, mtl
|
||||
, primitive
|
||||
, rpg
|
||||
, text
|
||||
, unordered-containers
|
||||
, vector
|
||||
default-language: GHC2021
|
||||
|
||||
|
|
@ -143,24 +127,18 @@ executable pong
|
|||
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:
|
||||
GLFW-b
|
||||
, OpenGL
|
||||
, apecs
|
||||
apecs
|
||||
, apecs-effectful
|
||||
, base >=4.7 && <5
|
||||
, bytestring
|
||||
, containers
|
||||
, effectful
|
||||
, effectful-core
|
||||
, extra
|
||||
, h-raylib
|
||||
, lens
|
||||
, linear
|
||||
, mtl
|
||||
, primitive
|
||||
, rpg
|
||||
, text
|
||||
, unordered-containers
|
||||
, vector
|
||||
default-language: GHC2021
|
||||
|
||||
|
|
@ -171,7 +149,7 @@ executable rpg-exe
|
|||
autogen-modules:
|
||||
Paths_rpg
|
||||
hs-source-dirs:
|
||||
rpg
|
||||
app
|
||||
default-extensions:
|
||||
OverloadedStrings
|
||||
DuplicateRecordFields
|
||||
|
|
@ -182,24 +160,18 @@ executable rpg-exe
|
|||
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:
|
||||
GLFW-b
|
||||
, OpenGL
|
||||
, apecs
|
||||
apecs
|
||||
, apecs-effectful
|
||||
, base >=4.7 && <5
|
||||
, bytestring
|
||||
, containers
|
||||
, effectful
|
||||
, effectful-core
|
||||
, extra
|
||||
, h-raylib
|
||||
, lens
|
||||
, linear
|
||||
, mtl
|
||||
, primitive
|
||||
, rpg
|
||||
, text
|
||||
, unordered-containers
|
||||
, vector
|
||||
default-language: GHC2021
|
||||
|
||||
|
|
@ -222,23 +194,17 @@ test-suite rpg-test
|
|||
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:
|
||||
GLFW-b
|
||||
, OpenGL
|
||||
, apecs
|
||||
apecs
|
||||
, apecs-effectful
|
||||
, base >=4.7 && <5
|
||||
, bytestring
|
||||
, containers
|
||||
, effectful
|
||||
, effectful-core
|
||||
, extra
|
||||
, h-raylib
|
||||
, lens
|
||||
, linear
|
||||
, mtl
|
||||
, primitive
|
||||
, rpg
|
||||
, text
|
||||
, unordered-containers
|
||||
, vector
|
||||
default-language: GHC2021
|
||||
|
|
|
|||
|
|
@ -1,21 +1,16 @@
|
|||
{-# LANGUAGE TypeFamilies #-}
|
||||
|
||||
module Component.Body (BodyComponent (..), bounciness, friction, immovable) where
|
||||
|
||||
module Component.Body (BodyComponent(..), previousPosition) where
|
||||
import Apecs.Effectful
|
||||
import Control.Lens
|
||||
import Linear.V2
|
||||
import Control.Lens
|
||||
|
||||
data BodyComponent = Body
|
||||
{ bounciness :: Float
|
||||
, friction :: Float
|
||||
, immovable :: Bool
|
||||
data BodyComponent
|
||||
= Body
|
||||
{ previousPosition :: V2 Float
|
||||
}
|
||||
deriving (Show)
|
||||
deriving Show
|
||||
instance Component BodyComponent where type Storage BodyComponent = Map BodyComponent
|
||||
makeLensesFor
|
||||
[ ("bounciness", "bounciness")
|
||||
, ("friction", "friction")
|
||||
, ("immovable", "immovable")
|
||||
]
|
||||
''BodyComponent
|
||||
[ ("previousPosition", "previousPosition")
|
||||
] ''BodyComponent
|
||||
|
|
|
|||
|
|
@ -1,21 +1,15 @@
|
|||
{-# LANGUAGE DerivingStrategies #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
|
||||
module Component.Position (PositionComponent (..), position) where
|
||||
module Component.Position (PositionComponent(..), position) where
|
||||
|
||||
import Apecs.Core
|
||||
import Control.Lens
|
||||
import Foreign.Storable
|
||||
import Apecs.Effectful
|
||||
import Linear.V2
|
||||
import Stores.SparseSet
|
||||
import Control.Lens
|
||||
|
||||
newtype PositionComponent = Position
|
||||
newtype PositionComponent
|
||||
= Position
|
||||
{ position :: V2 Float
|
||||
}
|
||||
deriving (Show)
|
||||
deriving newtype (Storable)
|
||||
instance Component PositionComponent where type Storage PositionComponent = SparseSet IO PositionComponent
|
||||
deriving Show
|
||||
instance Component PositionComponent where type Storage PositionComponent = Map PositionComponent
|
||||
makeLensesFor [("position", "position")] ''PositionComponent
|
||||
|
||||
instance ComponentDefault PositionComponent where
|
||||
componentDefault = Position (V2 0 0)
|
||||
|
|
|
|||
|
|
@ -1,20 +1,13 @@
|
|||
{-# LANGUAGE DerivingStrategies #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
|
||||
module Component.Velocity (VelocityComponent (..), unVelocity) where
|
||||
|
||||
import Apecs.Effectful
|
||||
import Foreign.Storable
|
||||
import Linear.V2
|
||||
import Stores.SparseSet
|
||||
|
||||
newtype VelocityComponent = Velocity (V2 Float)
|
||||
deriving (Show, Num)
|
||||
deriving newtype (Storable)
|
||||
instance Component VelocityComponent where type Storage VelocityComponent = SparseSet IO VelocityComponent
|
||||
instance Component VelocityComponent where type Storage VelocityComponent = Map VelocityComponent
|
||||
|
||||
unVelocity :: VelocityComponent -> V2 Float
|
||||
unVelocity (Velocity v) = v
|
||||
|
||||
instance ComponentDefault VelocityComponent where
|
||||
componentDefault = Velocity (V2 0 0)
|
||||
|
|
|
|||
|
|
@ -11,7 +11,6 @@ module Effectful.Raylib (
|
|||
getScreenToWorld2D,
|
||||
isMouseButtonPressed,
|
||||
isMouseButtonReleased,
|
||||
getFPS,
|
||||
clearBackground,
|
||||
runDraw2D,
|
||||
measureText,
|
||||
|
|
@ -45,7 +44,6 @@ data Raylib :: Effect where
|
|||
GetScreenToWorld2D :: V2 Int -> RL.Camera2D -> Raylib (Eff es) (V2 Float)
|
||||
IsMouseButtonPressed :: RL.MouseButton -> Raylib (Eff es) Bool
|
||||
IsMouseButtonReleased :: RL.MouseButton -> Raylib (Eff es) Bool
|
||||
GetFPS :: Raylib (Eff es) Int
|
||||
type instance DispatchOf Raylib = Dynamic
|
||||
|
||||
data RaylibDraw :: Effect where
|
||||
|
|
@ -87,9 +85,6 @@ isMouseButtonPressed mouseButton = send (IsMouseButtonPressed mouseButton)
|
|||
isMouseButtonReleased :: (HasCallStack, Raylib :> es) => RL.MouseButton -> Eff es Bool
|
||||
isMouseButtonReleased mouseButton = send (IsMouseButtonReleased mouseButton)
|
||||
|
||||
getFPS :: (HasCallStack, Raylib :> es) => Eff es Int
|
||||
getFPS = send GetFPS
|
||||
|
||||
clearBackground :: (HasCallStack, RaylibDraw :> es) => RL.Color -> Eff es ()
|
||||
clearBackground color = send (ClearBackground color)
|
||||
|
||||
|
|
@ -126,7 +121,6 @@ runRaylibWindow width height name effect = do
|
|||
<&> \(RL.Vector2 x y) -> V2 x y
|
||||
IsMouseButtonPressed mouseButton -> liftIO $ RL.isMouseButtonPressed mouseButton
|
||||
IsMouseButtonReleased mouseButton -> liftIO $ RL.isMouseButtonReleased mouseButton
|
||||
GetFPS -> liftIO RL.getFPS
|
||||
|
||||
liftIO $ RL.closeWindow window
|
||||
where
|
||||
|
|
|
|||
|
|
@ -104,8 +104,8 @@ startEngine = do
|
|||
engineInput
|
||||
applyVelocity'' @w
|
||||
|
||||
-- collisionAABB @w
|
||||
-- resolveAABB @w
|
||||
collisionAABB @w
|
||||
resolveAABB @w
|
||||
|
||||
enginePhysics
|
||||
|
||||
|
|
@ -115,11 +115,9 @@ startEngine = do
|
|||
color <- readVal @backgroundColor @RL.Color
|
||||
clearBackground color
|
||||
|
||||
getFPS >>= unsafeEff_ . print
|
||||
|
||||
render @w
|
||||
-- renderOrigins @w
|
||||
-- renderBoundingBoxes @w
|
||||
-- renderCollision @w
|
||||
renderOrigins @w
|
||||
renderBoundingBoxes @w
|
||||
renderCollision @w
|
||||
|
||||
engineRendering
|
||||
|
|
|
|||
|
|
@ -67,7 +67,6 @@ runGameState action = do
|
|||
AE.newEntity @World
|
||||
( Position $ V2 0 0
|
||||
, Box RL.green (0, 0) (1, 1)
|
||||
, Body 0.0 0.0 False
|
||||
, AABB (V2 1 1) (V2 0 0)
|
||||
)
|
||||
|
||||
|
|
@ -75,7 +74,6 @@ runGameState action = do
|
|||
AE.newEntity @World
|
||||
( Position $ V2 2 0
|
||||
, Box RL.green (0, 0) (1, 1)
|
||||
, Body 0.0 0.0 False
|
||||
, AABB (V2 1 1) (V2 0 0)
|
||||
)
|
||||
|
||||
|
|
@ -153,7 +151,7 @@ runEngine = interpret \env eff ->
|
|||
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 ()
|
||||
|
|
|
|||
|
|
@ -13,7 +13,7 @@
|
|||
{-# LANGUAGE TypeOperators #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
|
||||
module Executables.RPG (
|
||||
module Lib (
|
||||
runGame,
|
||||
) where
|
||||
|
||||
|
|
@ -25,26 +25,27 @@ import Component.Player
|
|||
import Component.Position
|
||||
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.Dispatch.Static
|
||||
import Effectful.Raylib
|
||||
import Effectful.Reader.Dynamic
|
||||
import Effectful.State.Static.Local
|
||||
import Effectful.State.Static.Local.Lens
|
||||
import Engine
|
||||
import GHC.Float (float2Int, floorFloat)
|
||||
import GHC.Float
|
||||
import Linear.V2
|
||||
import Noise.Perlin
|
||||
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
|
||||
|
||||
type LocalWorld = World
|
||||
|
||||
data GameConfig = GameConfig
|
||||
{
|
||||
}
|
||||
|
|
@ -69,54 +70,56 @@ makeLensesFor
|
|||
''GameState
|
||||
|
||||
spawnPlayer
|
||||
:: (AE.ECS LocalWorld :> es)
|
||||
:: (AE.ECS World :> es)
|
||||
=> RL.Color
|
||||
-> Eff es AE.Entity
|
||||
spawnPlayer color =
|
||||
AE.newEntity @LocalWorld
|
||||
AE.newEntity @World
|
||||
( Player
|
||||
, Position $ V2 0 2
|
||||
, Camera 10 (0, 0)
|
||||
, AABB (V2 0.8 0.8) (V2 0 0)
|
||||
, Body 0.0 0.0 False
|
||||
, Body (V2 0 2)
|
||||
, Box color (0, 0) (0.8, 0.8)
|
||||
)
|
||||
|
||||
movePlayer
|
||||
:: (AE.ECS World :> es)
|
||||
=> Eff es AE.Entity
|
||||
-> (Float, Float)
|
||||
-> Eff es ()
|
||||
movePlayer eff (x, y) = do
|
||||
entity <- eff
|
||||
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 LocalWorld :> es, Raylib :> es)
|
||||
:: (AE.ECS World :> es, Raylib :> es)
|
||||
=> (Float, Float)
|
||||
-> RL.Color
|
||||
-> (Float, Float)
|
||||
-> Eff es AE.Entity
|
||||
spawnBox (posx, posy) color size = do
|
||||
entity <-
|
||||
AE.newEntity @LocalWorld
|
||||
AE.newEntity @World
|
||||
( Box color (0, 0) size
|
||||
, Position $ V2 posx posy
|
||||
, Body 0.0 0.0 True
|
||||
, AABB (V2 1 1) (V2 0 0)
|
||||
)
|
||||
font <- getFontDefault
|
||||
AE.set @LocalWorld entity (TextBox font (T.pack $ show (AE.unEntity entity)) 0.3 0.1 RL.yellow)
|
||||
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 LocalWorld :> es
|
||||
, AE.ECS World :> es
|
||||
)
|
||||
=> Eff es ()
|
||||
initialise = do
|
||||
setTargetFPS 60
|
||||
|
||||
forM_ [-32 .. 32] \x -> do
|
||||
forM_ [-32 .. 32] \y -> do
|
||||
let height = floorFloat $ (perlin (x / 5) (y / 5) * 0.5 + 0.5) * 255
|
||||
AE.newEntity_ @LocalWorld
|
||||
( Box (RL.Color height height height 255) (0, 0) (1, 1)
|
||||
, Position $ V2 x y
|
||||
)
|
||||
|
||||
player <- spawnPlayer RL.blue
|
||||
playerEntity .= player
|
||||
cameraEntity .= player
|
||||
|
|
@ -128,33 +131,16 @@ initialise = do
|
|||
_ <- spawnBox (3, 1) RL.gray (1, 1)
|
||||
_ <- spawnBox (3, -1) RL.gray (1, 1)
|
||||
_ <- spawnBox (3, -3) RL.gray (1, 1)
|
||||
AE.newEntity_ @LocalWorld
|
||||
( Box RL.blue (0, 0) (1, 1)
|
||||
, Position $ V2 (-3) 0
|
||||
, Body 0.5 0.0 False
|
||||
, AABB (V2 1 1) (V2 0 0)
|
||||
)
|
||||
AE.newEntity_ @LocalWorld
|
||||
( Box RL.blue (0, 0) (1, 1)
|
||||
, Position $ V2 (-5) 0
|
||||
, Body 0.5 0.0 False
|
||||
, AABB (V2 1 1) (V2 0 0)
|
||||
)
|
||||
|
||||
forM_ [(-3) .. 3] \i -> do
|
||||
void $ spawnBox (-7, i) RL.gray (1, 1)
|
||||
spawnBox (7, i) RL.gray (1, 1)
|
||||
forM_ [(-7) .. 7] \i -> do
|
||||
void $ spawnBox (i, 4) RL.gray (1, 1)
|
||||
spawnBox (i, -4) RL.gray (1, 1)
|
||||
|
||||
boxes .= []
|
||||
|
||||
pure ()
|
||||
|
||||
data RPGEngine = RPGEngine
|
||||
|
||||
runEngine
|
||||
:: forall es
|
||||
. ( AE.ECS LocalWorld :> es
|
||||
. ( AE.ECS World :> es
|
||||
, Raylib :> es
|
||||
, State GameState :> es
|
||||
)
|
||||
|
|
@ -164,11 +150,7 @@ runEngine = interpret \_ eff ->
|
|||
case eff of
|
||||
EngineInput -> do
|
||||
playerEntity <- gets @GameState (\s -> s.playerEntity)
|
||||
-- AE.modify @LocalWorld @(Maybe (TagComponent Int)) @(TagComponent Int) playerEntity \case
|
||||
-- Just (Tag n) -> Tag (n + 1)
|
||||
-- Nothing -> Tag 0
|
||||
-- AE.get @LocalWorld @(TagComponent Int) playerEntity >>= unsafeEff_ . print
|
||||
playerMovement @LocalWorld
|
||||
playerMovement @World
|
||||
playerEntity
|
||||
( RL.KeyA
|
||||
, RL.KeyD
|
||||
|
|
@ -179,12 +161,11 @@ runEngine = interpret \_ eff ->
|
|||
|
||||
cameraEntity <- gets @GameState (\s -> s.cameraEntity)
|
||||
|
||||
isKeyDown RL.KeyKpAdd >>= flip when (AE.modify @LocalWorld @CameraComponent @CameraComponent cameraEntity (\c -> c{zoom = c.zoom + 1}))
|
||||
isKeyDown RL.KeyKpSubtract >>= flip when (AE.modify @LocalWorld @CameraComponent @CameraComponent cameraEntity (\c -> c{zoom = c.zoom - 1}))
|
||||
isKeyDown RL.KeyKpAdd >>= flip when (AE.modify @World @CameraComponent @CameraComponent cameraEntity (\c -> c{zoom = c.zoom + 1}))
|
||||
isKeyDown RL.KeyKpSubtract >>= flip when (AE.modify @World @CameraComponent @CameraComponent cameraEntity (\c -> c{zoom = c.zoom - 1}))
|
||||
pure ()
|
||||
EnginePhysics -> pure ()
|
||||
EngineRendering _ -> do
|
||||
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)
|
||||
|
|
@ -201,12 +182,8 @@ runGame = do
|
|||
, dimY = 450
|
||||
, playerEntity = undefined
|
||||
, cameraEntity = undefined
|
||||
, camera = undefined
|
||||
, boxes = undefined
|
||||
}
|
||||
|
||||
print $ perlin 0 0
|
||||
|
||||
RL.setTraceLogLevel RL.LogWarning
|
||||
runEff
|
||||
. AE.runECS initWorld
|
||||
|
|
@ -215,11 +192,11 @@ runGame = do
|
|||
. runRaylibWindow gameState.dimX gameState.dimY "App"
|
||||
. runReads @"config.camera" @RL.Camera2D do
|
||||
dims <- gets @GameState (\s -> (s.dimX, s.dimY))
|
||||
getCamera @LocalWorld (gets @GameState (\s -> s.cameraEntity)) dims
|
||||
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" @LocalWorld
|
||||
startEngine @"config.camera" @"config.backgroundColor" @World
|
||||
not <$> windowShouldClose
|
||||
|
||||
pure ()
|
||||
|
|
@ -1,70 +0,0 @@
|
|||
module Noise.Perlin (perlin) where
|
||||
|
||||
import Control.Lens
|
||||
import Control.Monad.State
|
||||
import Data.Bits
|
||||
import Debug.Trace
|
||||
import Foreign (Storable (..))
|
||||
import Foreign.C.Types
|
||||
import GHC.Float
|
||||
import Linear.V2
|
||||
|
||||
-- https://adrianb.io/2014/08/09/perlinnoise.html retry with that?
|
||||
|
||||
interpolate :: Float -> Float -> Float -> Float
|
||||
interpolate a0 a1 weight = (a1 - a0) * weight + a0
|
||||
|
||||
randomGradient :: Int -> Int -> V2 Float
|
||||
randomGradient iX iY = v
|
||||
where
|
||||
w :: CUInt
|
||||
w = fromIntegral $ 8 * sizeOf (undefined :: CUInt)
|
||||
s = w `div` 2
|
||||
|
||||
_a :: forall s t a b. (Field1 s t a b) => Lens s t a b
|
||||
_a = _1
|
||||
_b :: forall s t a b. (Field2 s t a b) => Lens s t a b
|
||||
_b = _2
|
||||
deltaWS = w - s
|
||||
(a, b) :: (CUInt, CUInt) = flip execState (fromIntegral iX, fromIntegral iY) $ do
|
||||
_a *= 3284157443
|
||||
(a, _) <- get
|
||||
_b ^= (a .<<. fromIntegral s) .|. (a .>>. fromIntegral deltaWS)
|
||||
_b *= 1911520717
|
||||
(_, b) <- get
|
||||
_a ^= (b .<<. fromIntegral s) .|. (b .>>. fromIntegral deltaWS)
|
||||
_a *= 2048419325
|
||||
|
||||
random = fromIntegral a * (3.14159265 / (fromIntegral . complement $ (complement (0 :: CUInt) `shiftR` 1)))
|
||||
v = V2 (cos random) (sin random)
|
||||
|
||||
dotGridGradient :: Int -> Int -> Float -> Float -> Float
|
||||
dotGridGradient iX iY x y = dx * gradient ^. _x + dy * gradient ^. _y
|
||||
where
|
||||
gradient = randomGradient iX iY
|
||||
|
||||
dx = x - fromIntegral iX
|
||||
dy = y - fromIntegral iY
|
||||
|
||||
perlin :: Float -> Float -> Float
|
||||
perlin x y = value
|
||||
where
|
||||
x0 = floorFloat x
|
||||
x1 = x0 + 1
|
||||
y0 = floorFloat y
|
||||
y1 = y0 + 1
|
||||
|
||||
sx = traceShowId $ x - fromIntegral x0
|
||||
sy = traceShowId $ y - fromIntegral y0
|
||||
|
||||
ix0 = interpolate n0 n1 sx
|
||||
where
|
||||
n0 = dotGridGradient x0 y0 x y
|
||||
n1 = dotGridGradient x1 y0 x y
|
||||
|
||||
ix1 = interpolate n0 n1 sx
|
||||
where
|
||||
n0 = dotGridGradient x0 y1 x y
|
||||
n1 = dotGridGradient x1 y1 x y
|
||||
|
||||
value = interpolate ix0 ix1 sy
|
||||
|
|
@ -1,6 +1,6 @@
|
|||
{-# LANGUAGE AllowAmbiguousTypes #-}
|
||||
|
||||
module Executables.Pong (pongGame) where
|
||||
module Pong (pongGame) where
|
||||
|
||||
import Apecs.Effectful qualified as AE
|
||||
import Common hiding (playerMovement)
|
||||
|
|
@ -8,7 +8,6 @@ import Control.Lens hiding ((%=), (.=))
|
|||
import Control.Monad.Extra
|
||||
import Data.Text qualified as T
|
||||
import Effectful
|
||||
import Effectful.Dispatch.Static
|
||||
import Effectful.Raylib
|
||||
import Effectful.Reader.Static
|
||||
import Effectful.State.Static.Local
|
||||
|
|
@ -67,7 +66,7 @@ playerMovement
|
|||
:: forall w es
|
||||
. ( Raylib :> es
|
||||
, AE.Get w PositionComponent
|
||||
, AE.Set w VelocityComponent
|
||||
, AE.Set w PositionComponent
|
||||
, AE.ECS w :> es
|
||||
, Reader GameConfig :> es
|
||||
)
|
||||
|
|
@ -76,15 +75,89 @@ playerMovement
|
|||
-> Eff es AE.Entity
|
||||
-> Eff es ()
|
||||
playerMovement (up, upSpeed) (down, downSpeed) entity = do
|
||||
entity' <- entity
|
||||
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
|
||||
|
||||
down <- isKeyDown down
|
||||
up <- isKeyDown up
|
||||
AE.set @w entity' $
|
||||
case (down, up) of
|
||||
(True, False) -> Velocity $ V2 0 downSpeed
|
||||
(False, True) -> Velocity $ V2 0 upSpeed
|
||||
(_, _) -> Velocity $ V2 0 0
|
||||
ballMovement
|
||||
:: forall es
|
||||
. ( AE.ECS World :> es
|
||||
)
|
||||
=> Eff es AE.Entity
|
||||
-> Eff es AE.Entity
|
||||
-> Eff es AE.Entity
|
||||
-> Eff es AE.Entity
|
||||
-> Eff es AE.Entity
|
||||
-> Eff es ()
|
||||
ballMovement player1 player2 ball top bottom = do
|
||||
player1' <- player1
|
||||
player2' <- player2
|
||||
ball' <- ball
|
||||
top' <- top
|
||||
bottom' <- bottom
|
||||
|
||||
ballVelocity <- ball >>= AE.get @World
|
||||
|
||||
ballMovement'
|
||||
ball'
|
||||
player1'
|
||||
player2'
|
||||
bottom'
|
||||
top'
|
||||
ballVelocity
|
||||
>>= AE.set @World ball'
|
||||
where
|
||||
invertYVelocity
|
||||
:: VelocityComponent
|
||||
-> VelocityComponent
|
||||
invertYVelocity (Velocity (V2 x y)) = Velocity $ V2 x (-y)
|
||||
|
||||
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
|
||||
|
|
@ -134,11 +207,6 @@ initialise = do
|
|||
, Position $ V2 (-10) 0
|
||||
, Box RL.white (0, 0) (0.5, 2)
|
||||
, AABB (V2 0.5 2) (V2 0 0)
|
||||
, Body
|
||||
{ bounciness = 0.0
|
||||
, friction = 0.0
|
||||
, immovable = False
|
||||
}
|
||||
)
|
||||
player1 .= player1Entity
|
||||
|
||||
|
|
@ -148,11 +216,6 @@ initialise = do
|
|||
, Position $ V2 10 0
|
||||
, Box RL.white (0, 0) (0.5, 2)
|
||||
, AABB (V2 0.5 2) (V2 0 0)
|
||||
, Body
|
||||
{ bounciness = 0.0
|
||||
, friction = 0.0
|
||||
, immovable = False
|
||||
}
|
||||
)
|
||||
player2 .= player2Entity
|
||||
|
||||
|
|
@ -162,11 +225,7 @@ initialise = do
|
|||
, 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
|
||||
{ bounciness = 1.0
|
||||
, friction = 0.0
|
||||
, immovable = False
|
||||
}
|
||||
, Body (V2 0 0)
|
||||
)
|
||||
ball .= ballEntity
|
||||
|
||||
|
|
@ -190,14 +249,12 @@ initialise = do
|
|||
( 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)
|
||||
, Body 0.0 0.0 True
|
||||
)
|
||||
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)
|
||||
, Body 0.0 0.0 True
|
||||
)
|
||||
topBorder .= topEntity
|
||||
bottomBorder .= bottomEntity
|
||||
|
|
@ -260,11 +317,11 @@ pongGame = do
|
|||
(gets @GameState (\s -> s.ball))
|
||||
|
||||
collisionAABB @World
|
||||
applyVelocity'' @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 ->
|
||||
|
|
@ -272,7 +329,6 @@ pongGame = do
|
|||
|
||||
dims <- gets @GameState (\s -> (s.dimX, s.dimY))
|
||||
camera <- getCamera @World (gets @GameState (\s -> s.camera)) dims
|
||||
getFPS >>= unsafeEff_ . print
|
||||
runDraw . runDraw2D camera $ do
|
||||
clearBackground RL.gray
|
||||
|
||||
|
|
@ -1,14 +0,0 @@
|
|||
{-# LANGUAGE AllowAmbiguousTypes #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
|
||||
module Signals () where
|
||||
|
||||
import Apecs.Effectful qualified as AE
|
||||
import Effectful
|
||||
|
||||
class Signal s
|
||||
|
||||
-- signal :: forall s es w. (AE.Set w s, AE.ECS w :> es, Signals :> es) => AE.Entity -> s -> Eff es ()
|
||||
-- signal entity sig = do
|
||||
-- AE.set @w entity sig
|
||||
|
|
@ -1,185 +0,0 @@
|
|||
{-# LANGUAGE TypeFamilies #-}
|
||||
|
||||
module Stores.SparseSet (SparseSet, ComponentDefault (..), empty, exists, insert, remove, elements, members, unsafeElements, unsafeMembers, toPairs) where
|
||||
|
||||
import Apecs.Core
|
||||
import Control.Lens hiding (elements)
|
||||
import Control.Monad
|
||||
import Control.Monad.Except
|
||||
import Control.Monad.Primitive
|
||||
import Data.STRef
|
||||
import Data.Typeable (Typeable, typeRep)
|
||||
import Data.Vector qualified as V
|
||||
import Data.Vector.Generic qualified as VG
|
||||
import Data.Vector.Storable qualified as VS hiding (replicate, take)
|
||||
import Data.Vector.Storable.Mutable qualified as VS
|
||||
import Data.Vector.Unboxed qualified as VU hiding (replicate, take)
|
||||
import Data.Vector.Unboxed.Mutable qualified as VU
|
||||
import Foreign.Storable
|
||||
import Prelude hiding (lookup)
|
||||
|
||||
type SparseSet' s a = (VU.MVector s Int, VU.MVector s Int, VS.MVector s a, Int, Int)
|
||||
newtype SparseSet m a = SparseSet (STRef (PrimState m) (SparseSet' (PrimState m) a))
|
||||
|
||||
ssSparse :: Lens' (SparseSet' s a) (VU.MVector s Int)
|
||||
ssSparse = _1
|
||||
ssDenseIndex :: Lens' (SparseSet' s a) (VU.MVector s Int)
|
||||
ssDenseIndex = _2
|
||||
ssDense :: Lens' (SparseSet' s a) (VS.MVector s a)
|
||||
ssDense = _3
|
||||
ssN :: Lens' (SparseSet' s a) Int
|
||||
ssN = _4
|
||||
ssMax :: Lens' (SparseSet' s a) Int
|
||||
ssMax = _5
|
||||
|
||||
empty :: (PrimMonad m, Storable a) => a -> Int -> m (SparseSet m a)
|
||||
empty defaultValue size = do
|
||||
sparseVector <- VU.replicate size 0
|
||||
denseIndex <- VU.replicate size 0
|
||||
denseStorableVector <- VS.replicate size defaultValue
|
||||
|
||||
stToPrim (newSTRef (sparseVector, denseIndex, denseStorableVector, 0, size)) <&> SparseSet
|
||||
|
||||
-- | Handle the 'Left' constructor of the returned 'Either'
|
||||
onLeft
|
||||
:: forall x m a
|
||||
. ()
|
||||
=> (Monad m)
|
||||
=> (x -> m a)
|
||||
-> m (Either x a)
|
||||
-> m a
|
||||
onLeft g f = f >>= either g pure
|
||||
|
||||
checkBounds :: (Monad m) => Int -> Int -> ExceptT () m ()
|
||||
checkBounds maxN idx = unless (idx >= 0 && idx <= maxN) (throwError ())
|
||||
|
||||
exists :: (PrimMonad m) => SparseSet m a -> Int -> m Bool
|
||||
exists (SparseSet sparseSet') idx = onLeft (const $ pure False) $ runExceptT do
|
||||
sparseSet <- stToPrim $ readSTRef sparseSet'
|
||||
|
||||
checkBounds (sparseSet ^. ssMax) idx
|
||||
|
||||
denseIndex <- VU.read (sparseSet ^. ssSparse) idx
|
||||
sparseIndex <- VU.read (sparseSet ^. ssDenseIndex) denseIndex
|
||||
|
||||
pure $ denseIndex < (sparseSet ^. ssN) && sparseIndex == idx
|
||||
|
||||
lookup :: (Storable a, PrimMonad m) => SparseSet m a -> Int -> m (Maybe a)
|
||||
lookup (SparseSet sparseSet') idx =
|
||||
exists (SparseSet sparseSet') idx
|
||||
>>= \case
|
||||
False -> pure Nothing
|
||||
True -> do
|
||||
sparseSet <- stToPrim $ readSTRef sparseSet'
|
||||
|
||||
denseIndex <- VU.read (sparseSet ^. ssSparse) idx
|
||||
VS.read (sparseSet ^. ssDense) denseIndex <&> Just
|
||||
|
||||
insert :: (Storable a, PrimMonad m) => SparseSet m a -> Int -> a -> m ()
|
||||
insert (SparseSet sparseSet') idx value = do
|
||||
sparseSet <- stToPrim $ readSTRef sparseSet'
|
||||
|
||||
-- expand instead
|
||||
-- checkBounds (sparseSet ^. ssMax) idx
|
||||
when (idx >= sparseSet ^. ssMax) (error "SparseSet expansion not implemented")
|
||||
|
||||
exists (SparseSet sparseSet') idx >>= \case
|
||||
True -> do
|
||||
denseIndex <- VU.read (sparseSet ^. ssSparse) idx
|
||||
VS.write (sparseSet ^. ssDense) denseIndex value
|
||||
False -> do
|
||||
VS.write (sparseSet ^. ssDense) (sparseSet ^. ssN) value
|
||||
VU.write (sparseSet ^. ssDenseIndex) (sparseSet ^. ssN) idx
|
||||
VU.write (sparseSet ^. ssSparse) idx (sparseSet ^. ssN)
|
||||
|
||||
stToPrim $ writeSTRef sparseSet' (sparseSet & ssN %~ (+ 1))
|
||||
|
||||
remove :: (Storable a, PrimMonad m) => SparseSet m a -> Int -> m ()
|
||||
remove (SparseSet sparseSet') idx = do
|
||||
sparseSet <- stToPrim $ readSTRef sparseSet'
|
||||
|
||||
exists (SparseSet sparseSet') idx >>= \case
|
||||
False -> pure ()
|
||||
True -> do
|
||||
let n = (sparseSet ^. ssN) - 1
|
||||
|
||||
denseIndex <- VU.read (sparseSet ^. ssSparse) n
|
||||
sparseIndex <- VU.read (sparseSet ^. ssDenseIndex) n
|
||||
item <- VS.read (sparseSet ^. ssDense) denseIndex
|
||||
|
||||
VS.write (sparseSet ^. ssDense) denseIndex item
|
||||
VU.write (sparseSet ^. ssDenseIndex) denseIndex sparseIndex
|
||||
VU.write (sparseSet ^. ssSparse) sparseIndex denseIndex
|
||||
|
||||
stToPrim $ writeSTRef sparseSet' (sparseSet & ssN .~ n)
|
||||
|
||||
elements :: (Storable a, PrimMonad m) => SparseSet m a -> m (VS.Vector a)
|
||||
elements (SparseSet sparseSet') = do
|
||||
sparseSet <- stToPrim $ readSTRef sparseSet'
|
||||
|
||||
VS.freeze (VS.take (sparseSet ^. ssN) (sparseSet ^. ssDense))
|
||||
|
||||
unsafeElements :: (Storable a, PrimMonad m) => SparseSet m a -> m (VS.Vector a)
|
||||
unsafeElements (SparseSet sparseSet') = do
|
||||
sparseSet <- stToPrim $ readSTRef sparseSet'
|
||||
|
||||
VS.unsafeFreeze (VS.take (sparseSet ^. ssN) (sparseSet ^. ssDense))
|
||||
|
||||
members :: (PrimMonad m) => SparseSet m a -> m (VU.Vector Int)
|
||||
members (SparseSet sparseSet') = do
|
||||
sparseSet <- stToPrim $ readSTRef sparseSet'
|
||||
|
||||
VU.freeze (VU.take (sparseSet ^. ssN) (sparseSet ^. ssDenseIndex))
|
||||
|
||||
unsafeMembers :: (PrimMonad m) => SparseSet m a -> m (VU.Vector Int)
|
||||
unsafeMembers (SparseSet sparseSet') = do
|
||||
sparseSet <- stToPrim $ readSTRef sparseSet'
|
||||
|
||||
VU.unsafeFreeze (VU.take (sparseSet ^. ssN) (sparseSet ^. ssDenseIndex))
|
||||
|
||||
toPairs :: (Storable a, PrimMonad m) => SparseSet m a -> m (V.Vector (Int, a))
|
||||
toPairs sparseSet' = do
|
||||
membersVector <- members sparseSet'
|
||||
elementsVector <- elements sparseSet'
|
||||
|
||||
pure $ VG.zip (VG.convert membersVector) (VG.convert elementsVector)
|
||||
|
||||
type instance Elem (SparseSet m c) = c
|
||||
|
||||
class (Component c) => ComponentDefault c where
|
||||
componentDefault :: c
|
||||
|
||||
instance (PrimMonad m, ComponentDefault a, Storable a) => ExplInit m (SparseSet m a) where
|
||||
explInit :: m (SparseSet m a)
|
||||
explInit = empty componentDefault 5000
|
||||
|
||||
{- FOURMOLU_DISABLE -}
|
||||
instance (PrimMonad m, Typeable a, Storable a) => ExplGet m (SparseSet m a) where
|
||||
{-# INLINE explGet #-}
|
||||
explGet :: SparseSet m a -> Int -> m (Elem (SparseSet m a))
|
||||
explGet sparseSet ety =
|
||||
lookup sparseSet ety >>= \case
|
||||
Just a -> pure a
|
||||
notFound -> error $ unwords
|
||||
[ "Reading non-existent StorableSet component"
|
||||
, show (typeRep notFound)
|
||||
]
|
||||
{-# INLINE explExists #-}
|
||||
explExists :: SparseSet m a -> Int -> m Bool
|
||||
explExists = exists
|
||||
{- FOURMOLU_ENABLE -}
|
||||
|
||||
instance (PrimMonad m, Storable a) => ExplSet m (SparseSet m a) where
|
||||
{-# INLINE explSet #-}
|
||||
explSet :: SparseSet m a -> Int -> Elem (SparseSet m a) -> m ()
|
||||
explSet = insert
|
||||
|
||||
instance (PrimMonad m, Storable a) => ExplDestroy m (SparseSet m a) where
|
||||
{-# INLINE explDestroy #-}
|
||||
explDestroy :: SparseSet m a -> Int -> m ()
|
||||
explDestroy = remove
|
||||
|
||||
instance (PrimMonad m) => ExplMembers m (SparseSet m a) where
|
||||
explMembers :: SparseSet m a -> m (VU.Vector Int)
|
||||
{-# INLINE explMembers #-}
|
||||
explMembers = unsafeMembers
|
||||
|
|
@ -1,19 +0,0 @@
|
|||
{-# LANGUAGE AllowAmbiguousTypes #-}
|
||||
|
||||
module System.OpenGLRenderer where
|
||||
|
||||
import Apecs.Effectful qualified as AE
|
||||
import Effectful
|
||||
import World
|
||||
|
||||
render
|
||||
:: forall w es
|
||||
. ( AE.Get w PositionComponent
|
||||
, AE.Get w BoxComponent
|
||||
, AE.Get w TextBoxComponent
|
||||
, AE.ECS w :> es
|
||||
, IOE :> es
|
||||
)
|
||||
=> Eff es ()
|
||||
render = do
|
||||
pure ()
|
||||
|
|
@ -21,7 +21,6 @@ import Apecs qualified
|
|||
import Apecs.Components (EntityStore)
|
||||
import Apecs.Components qualified as AE (EntityStore)
|
||||
import Apecs.Core qualified
|
||||
import Apecs.Core qualified as Apecs
|
||||
import Apecs.Effectful qualified as AE
|
||||
import Control.Lens
|
||||
import Control.Monad.Extra
|
||||
|
|
@ -31,7 +30,6 @@ import Data.Maybe (catMaybes, fromMaybe, isJust)
|
|||
import Debug.Trace qualified as Debug
|
||||
import Effectful
|
||||
import Effectful.Dispatch.Static (unsafeEff_)
|
||||
import Effectful.Internal.Monad (getStaticRep)
|
||||
import Effectful.Raylib
|
||||
import Effectful.State.Static.Local (evalState, get, modify, put)
|
||||
import Linear
|
||||
|
|
@ -78,7 +76,7 @@ applyVelocity' = do
|
|||
[]
|
||||
<&> pairs
|
||||
|
||||
forM_ entities \(entity, entities') -> evalState (1.0 :: Float) . evalState (100 :: Int) $ whileM do
|
||||
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
|
||||
|
||||
|
|
@ -117,6 +115,7 @@ applyVelocity' = do
|
|||
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
|
||||
|
|
@ -143,28 +142,26 @@ applyVelocity''
|
|||
. ( AE.Get w PositionComponent
|
||||
, AE.Get w VelocityComponent
|
||||
, AE.Get w AABBComponent
|
||||
, AE.Set w BodyComponent
|
||||
, AE.Set w PositionComponent
|
||||
, AE.ECS w :> es
|
||||
)
|
||||
=> Eff es ()
|
||||
applyVelocity'' = do
|
||||
allEntities <- AE.cfold @w @(AE.Entity, PositionComponent, AABBComponent, BodyComponent) (\acc (a, _, _, _) -> a : acc) []
|
||||
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 (16 :: Int) . whileM $ do
|
||||
remainingTime <- get @Float
|
||||
evalState (1.0 :: Float) . evalState (1000 :: Int) . whileM $ do
|
||||
fractions <- forM entityPairings \(entity1, entity2) -> do
|
||||
(position1, velocity1, aabb1, body1) <- AE.get @w @(PositionComponent, Maybe VelocityComponent, AABBComponent, BodyComponent) entity1
|
||||
(position2, velocity2, aabb2, body2) <- AE.get @w @(PositionComponent, Maybe VelocityComponent, AABBComponent, BodyComponent) entity2
|
||||
(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, body1), (entity2, position2, velocity2, aabb2, body2))
|
||||
( Just ((entity1, position1, velocity1, aabb1), (entity2, position2, velocity2, aabb2))
|
||||
, getCollidingVelocityRatio (position1, aabb1, Velocity velocity1') (position2, aabb2, Velocity velocity2')
|
||||
)
|
||||
|
||||
|
|
@ -172,17 +169,15 @@ applyVelocity'' = do
|
|||
order (_, a) (_, b) = a `compare` b
|
||||
clampedFractions = map (_2 %~ clampDown) fractions
|
||||
fractions' = filter (not . isNaN . (^. _2)) clampedFractions
|
||||
(info, minTime) = minimumBy order ((Nothing, remainingTime) : fractions')
|
||||
(info, minTime) = minimumBy order ((Nothing, 1.0) : fractions')
|
||||
|
||||
AE.cmap @w @(PositionComponent, AABBComponent, Maybe BodyComponent, Maybe VelocityComponent) @PositionComponent \(position1, _, body1, velocity1) ->
|
||||
forM_ allEntities \entity1 -> do
|
||||
(position1, velocity1) <- AE.get @w @(PositionComponent, Maybe VelocityComponent) entity1
|
||||
let
|
||||
velocity1' = fromMaybe (Velocity $ pure 0) velocity1
|
||||
in
|
||||
if unVelocity velocity1' == pure 0 || maybe False (^. immovable) body1
|
||||
then position1
|
||||
else Position $ position1.position + unVelocity velocity1' * pure (clampDown minTime)
|
||||
AE.set @w entity1 (Position $ position1.position + unVelocity velocity1' * pure (clampDown minTime))
|
||||
case info of
|
||||
Just ((entityA, positionA, velocityA, aabbA, bodyA), (entityB, positionB, velocityB, aabbB, bodyB)) -> do
|
||||
Just ((entityA, positionA, velocityA, aabbA), (entityB, positionB, velocityB, aabbB)) -> do
|
||||
do
|
||||
let
|
||||
Velocity velocityA' = fromMaybe (Velocity $ pure 0) velocityA
|
||||
|
|
@ -191,20 +186,22 @@ applyVelocity'' = do
|
|||
alongNormalA = velocityA' `dot` normal
|
||||
alongNormalB = velocityB' `dot` normal
|
||||
|
||||
bouncinessA = 1.0 + bodyA ^. bounciness
|
||||
bouncinessB = 1.0 + bodyB ^. bounciness
|
||||
bouncinessA = 1.0
|
||||
bouncinessB = 1.0
|
||||
|
||||
frictionA = 1.0 + bodyA ^. friction
|
||||
frictionB = 1.0 + bodyB ^. friction
|
||||
frictionA = 1.0
|
||||
frictionB = 1.0
|
||||
|
||||
-- friction and bounce
|
||||
newVelocityA' = (pure (-alongNormalA) * normal * pure bouncinessA + velocityA' + pure alongNormalB * normal * pure (2.0 - bouncinessB)) * pure frictionA
|
||||
newVelocityB' = (pure (-alongNormalB) * normal * pure bouncinessB + velocityB' + pure alongNormalA * normal * pure (2.0 - bouncinessA)) * pure frictionB
|
||||
newVelocityA' = (pure (-alongNormalA) * normal * pure bouncinessA + velocityA') * frictionA
|
||||
newVelocityB' = (pure (-alongNormalB) * normal * pure bouncinessB + velocityB') * frictionB
|
||||
|
||||
unless (bodyA ^. immovable) $ AE.set @w entityA (Velocity newVelocityA')
|
||||
unless (bodyB ^. immovable) $ AE.set @w entityB (Velocity newVelocityB')
|
||||
AE.set @w entityA (Velocity newVelocityA')
|
||||
AE.set @w entityB (Velocity newVelocityB')
|
||||
pure ()
|
||||
_ -> pure ()
|
||||
|
||||
remainingTime <- get @Float
|
||||
put @Float $ remainingTime - minTime
|
||||
|
||||
iterations <- get @Int
|
||||
|
|
@ -298,10 +295,10 @@ collides bEntity (Position positionA) aabbA (Position positionB) aabbB = do
|
|||
boundsB = aabbBounds (Position positionB) aabbB
|
||||
minDiff = minkowskiDifference (Position positionA, aabbA) (Position positionB, aabbB)
|
||||
|
||||
case ( minDiff.left <= 0.01
|
||||
, minDiff.right >= -0.01
|
||||
, minDiff.top >= -0.01
|
||||
, minDiff.bottom <= 0.01
|
||||
case ( minDiff.left <= 0
|
||||
, minDiff.right >= 0
|
||||
, minDiff.top <= 0
|
||||
, minDiff.bottom >= 0
|
||||
) of
|
||||
(True, True, True, True) ->
|
||||
let
|
||||
|
|
@ -311,6 +308,8 @@ collides bEntity (Position positionA) aabbA (Position positionB) aabbB = do
|
|||
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
|
||||
|
|
@ -369,9 +368,9 @@ collisionAABB
|
|||
)
|
||||
=> Eff es ()
|
||||
collisionAABB =
|
||||
void $ AE.cmapM @w @(AE.Entity, PositionComponent, AABBComponent) @(CollisionComponent)
|
||||
\(bodyEntity, bodyPosition, bodyAABB) -> do
|
||||
colliders <- flip (AE.cfoldM @w @(AE.Entity, PositionComponent, AABBComponent)) [] \acc (colliderEntity, colliderPosition, colliderAABB) -> do
|
||||
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
|
||||
|
|
@ -391,9 +390,10 @@ resolveAABB
|
|||
=> Eff es ()
|
||||
resolveAABB = do
|
||||
void $ AE.cmapM @w @(PositionComponent, BodyComponent, CollisionComponent) @PositionComponent
|
||||
\(Position position, Body{}, collision) ->
|
||||
\(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
|
||||
where
|
||||
|
|
|
|||
|
|
@ -1,59 +1,55 @@
|
|||
{-# LANGUAGE AllowAmbiguousTypes #-}
|
||||
|
||||
module System.Renderer (render, renderOrigins, renderBoundingBoxes, renderCollision) where
|
||||
|
||||
import Apecs.Effectful qualified as AE
|
||||
import Effectful
|
||||
import qualified Apecs.Effectful as AE
|
||||
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
|
||||
import Effectful
|
||||
import Effectful.Raylib
|
||||
import Linear.V2 (V2 (..), _x, _y)
|
||||
import Raylib.Util.Colors qualified as RL
|
||||
import World
|
||||
|
||||
render
|
||||
:: forall w es
|
||||
. ( AE.Get w PositionComponent
|
||||
:: forall w es .
|
||||
( AE.Get w PositionComponent
|
||||
, AE.Get w BoxComponent
|
||||
, AE.Get w TextBoxComponent
|
||||
, AE.ECS w :> es
|
||||
, RaylibDraw2D :> es
|
||||
)
|
||||
, RaylibDraw2D :> es )
|
||||
=> Eff es ()
|
||||
render = do
|
||||
AE.cmapM_ @w @(PositionComponent, BoxComponent)
|
||||
\(Position (V2 x y), Box color offset (dx, dy)) ->
|
||||
drawRectangle (x + fst offset - dx / 2) (y + snd offset - dy / 2) dx dy 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
|
||||
-- let size = V2 0 0
|
||||
-- drawText font text (V2 (position ^. _x - size ^. _y / 2) (position ^. _y - size ^. _y / 2)) fontSize spacing color
|
||||
pure ()
|
||||
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
|
||||
)
|
||||
:: 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
|
||||
)
|
||||
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
|
||||
:: forall w es .
|
||||
( AE.Get w PositionComponent
|
||||
, AE.ECS w :> es
|
||||
, RaylibDraw2D :> es
|
||||
)
|
||||
|
|
@ -61,16 +57,16 @@ renderOrigins
|
|||
renderOrigins = do
|
||||
AE.cmapM_ @w @PositionComponent
|
||||
\(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
|
||||
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
|
||||
. ( AE.Get w PositionComponent
|
||||
, AE.Get w AABBComponent
|
||||
, RaylibDraw2D :> es
|
||||
, AE.ECS w :> es
|
||||
)
|
||||
:: forall w es .
|
||||
( AE.Get w PositionComponent
|
||||
, AE.Get w AABBComponent
|
||||
, RaylibDraw2D :> es
|
||||
, AE.ECS w :> es
|
||||
)
|
||||
=> Eff es ()
|
||||
renderBoundingBoxes =
|
||||
AE.cmapM_ @w @(PositionComponent, AABBComponent)
|
||||
|
|
|
|||
106
rpg/src/World.hs
106
rpg/src/World.hs
|
|
@ -1,95 +1,41 @@
|
|||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE FieldSelectors #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
{-# OPTIONS_GHC -Wno-orphans #-}
|
||||
{-# LANGUAGE FieldSelectors #-}
|
||||
{-# OPTIONS_GHC -Wno-deferred-out-of-scope-variables #-}
|
||||
|
||||
module World (
|
||||
World,
|
||||
-- GenericWorld (..),
|
||||
initWorld,
|
||||
module Component.Player,
|
||||
module Component.Position,
|
||||
module Component.Camera,
|
||||
module Component.Box,
|
||||
module Component.Velocity,
|
||||
module Component.AABB,
|
||||
module Component.Body,
|
||||
module Component.Collision,
|
||||
module Component.TextBox,
|
||||
TypeEq,
|
||||
type (/=),
|
||||
) where
|
||||
module World
|
||||
( World
|
||||
, initWorld
|
||||
, module Component.Player
|
||||
, module Component.Position
|
||||
, module Component.Camera
|
||||
, module Component.Box
|
||||
, module Component.Velocity
|
||||
, module Component.AABB
|
||||
, module Component.Body
|
||||
, module Component.Collision
|
||||
, module Component.TextBox
|
||||
) where
|
||||
|
||||
import Component.Position
|
||||
import Component.Player
|
||||
import Component.Camera
|
||||
import Component.Box
|
||||
import Component.Velocity
|
||||
import Component.AABB
|
||||
import Component.Body
|
||||
import Component.Box
|
||||
import Component.Camera
|
||||
import Component.Collision
|
||||
import Component.Player
|
||||
import Component.Position
|
||||
import Component.TextBox
|
||||
import Component.Velocity
|
||||
|
||||
import Apecs
|
||||
import Apecs.Components
|
||||
import qualified Apecs.Effectful as AE
|
||||
import Apecs.Core
|
||||
import Apecs.Effectful qualified as AE
|
||||
import Control.Monad.IO.Class (MonadIO)
|
||||
import Control.Monad.Reader qualified as MTL
|
||||
import Data.Functor
|
||||
import Data.HashMap.Strict qualified as HSS
|
||||
import Data.IORef
|
||||
import Apecs.Components
|
||||
import Data.Vector.Unboxed
|
||||
import GHC.TypeError
|
||||
import Type.Reflection
|
||||
import Unsafe.Coerce
|
||||
import Control.Monad.IO.Class (MonadIO)
|
||||
|
||||
data SomeStorage = forall s. SomeStorage s
|
||||
makeWorld "World" [''PositionComponent, ''PlayerComponent, ''CameraComponent, ''BoxComponent, ''VelocityComponent, ''AABBComponent, ''BodyComponent, ''CollisionComponent, ''TextBoxComponent]
|
||||
|
||||
newtype GenericStorage = GenericStorage {unGenericStorage :: IORef (HSS.HashMap SomeTypeRep SomeStorage)}
|
||||
type instance Elem GenericStorage = GenericComponent
|
||||
|
||||
instance (MonadIO m) => ExplInit m GenericStorage where
|
||||
explInit = liftIO $ GenericStorage <$> newIORef mempty
|
||||
|
||||
data GenericComponent
|
||||
instance Component GenericComponent where type Storage GenericComponent = GenericStorage
|
||||
|
||||
makeWorld
|
||||
"World"
|
||||
[ ''PositionComponent
|
||||
, ''PlayerComponent
|
||||
, ''CameraComponent
|
||||
, ''BoxComponent
|
||||
, ''VelocityComponent
|
||||
, ''AABBComponent
|
||||
, ''BodyComponent
|
||||
, ''CollisionComponent
|
||||
, ''TextBoxComponent
|
||||
, ''GenericComponent
|
||||
]
|
||||
|
||||
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 5000 id
|
||||
|
||||
type family TypeEq a b where
|
||||
TypeEq a a = TypeError (Text "You must add " :<>: ShowType GenericComponent :<>: Text " to the world")
|
||||
TypeEq a b = False
|
||||
type a /= b = TypeEq a b ~ False
|
||||
|
||||
instance {-# OVERLAPS #-} (MonadIO m, Component c, Typeable c, c /= GenericComponent, Has w m GenericComponent, ExplInit m (Storage c)) => Has w m c where
|
||||
getStore :: SystemT w m (Storage c)
|
||||
getStore = do
|
||||
genericStore <- getStore @w @m @GenericComponent >>= liftIO . readIORef . unGenericStorage
|
||||
liftIO $ print "going generic"
|
||||
case genericStore HSS.!? someTypeRep (Proxy @c) of
|
||||
Just (SomeStorage store) -> pure . unsafeCoerce $ store
|
||||
Nothing -> do
|
||||
newStorage <- lift (explInit @_ @(Storage c))
|
||||
let genericStore' = HSS.insert (someTypeRep (Proxy @c)) (SomeStorage newStorage) genericStore
|
||||
getStore @w @m @GenericComponent >>= liftIO . flip writeIORef genericStore' . unGenericStorage
|
||||
pure newStorage
|
||||
pure $ generate 1000 id
|
||||
|
|
|
|||
Loading…
Reference in a new issue