From 885bf8943b7c097254daebd146972d714e7b01de Mon Sep 17 00:00:00 2001 From: magic_rb Date: Mon, 22 Jan 2024 22:36:47 +0100 Subject: [PATCH] Stuff&Things Signed-off-by: magic_rb --- flake.nix | 1 + rpg/package.yaml | 4 + rpg/rpg.cabal | 34 +++++- rpg/src/Component/Position.hs | 10 +- rpg/src/Component/Velocity.hs | 9 +- rpg/src/Engine.hs | 10 +- rpg/src/Executables/Pong.hs | 18 ++- rpg/src/Executables/RPG.hs | 39 +++---- rpg/src/Noise/Perlin.hs | 70 ++++++++++++ rpg/src/Signals.hs | 14 +++ rpg/src/Stores/SparseSet.hs | 185 +++++++++++++++++++++++++++++++ rpg/src/System/OpenGLRenderer.hs | 19 ++++ rpg/src/System/Physics.hs | 10 +- rpg/src/System/Renderer.hs | 77 ++++++------- rpg/src/World.hs | 9 +- 15 files changed, 427 insertions(+), 82 deletions(-) create mode 100644 rpg/src/Noise/Perlin.hs create mode 100644 rpg/src/Signals.hs create mode 100644 rpg/src/Stores/SparseSet.hs create mode 100644 rpg/src/System/OpenGLRenderer.hs diff --git a/flake.nix b/flake.nix index 0ce8bf0..8ed7eee 100644 --- a/flake.nix +++ b/flake.nix @@ -53,6 +53,7 @@ xorg.libXi xorg.libXext xorg.libXdmcp + xorg.libXxf86vm libglvnd httplz ((raylib.override { includeEverything = true; }).overrideAttrs (old: { diff --git a/rpg/package.yaml b/rpg/package.yaml index a991fa9..8730784 100644 --- a/rpg/package.yaml +++ b/rpg/package.yaml @@ -34,6 +34,10 @@ dependencies: - vector - mtl - unordered-containers +- primitive +- containers +- GLFW-b +- OpenGL language: GHC2021 default-extensions: diff --git a/rpg/rpg.cabal b/rpg/rpg.cabal index 5aff25a..97a314d 100644 --- a/rpg/rpg.cabal +++ b/rpg/rpg.cabal @@ -43,6 +43,10 @@ library Executables.Minkowski Executables.Pong Executables.RPG + Noise.Perlin + Signals + Stores.SparseSet + System.OpenGLRenderer System.Physics System.Renderer World @@ -62,10 +66,13 @@ 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: - apecs + GLFW-b + , OpenGL + , apecs , apecs-effectful , base >=4.7 && <5 , bytestring + , containers , effectful , effectful-core , extra @@ -73,6 +80,7 @@ library , lens , linear , mtl + , primitive , text , unordered-containers , vector @@ -96,10 +104,13 @@ 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: - apecs + GLFW-b + , OpenGL + , apecs , apecs-effectful , base >=4.7 && <5 , bytestring + , containers , effectful , effectful-core , extra @@ -107,6 +118,7 @@ executable minkowski , lens , linear , mtl + , primitive , rpg , text , unordered-containers @@ -131,10 +143,13 @@ 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: - apecs + GLFW-b + , OpenGL + , apecs , apecs-effectful , base >=4.7 && <5 , bytestring + , containers , effectful , effectful-core , extra @@ -142,6 +157,7 @@ executable pong , lens , linear , mtl + , primitive , rpg , text , unordered-containers @@ -166,10 +182,13 @@ 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: - apecs + GLFW-b + , OpenGL + , apecs , apecs-effectful , base >=4.7 && <5 , bytestring + , containers , effectful , effectful-core , extra @@ -177,6 +196,7 @@ executable rpg-exe , lens , linear , mtl + , primitive , rpg , text , unordered-containers @@ -202,10 +222,13 @@ 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: - apecs + GLFW-b + , OpenGL + , apecs , apecs-effectful , base >=4.7 && <5 , bytestring + , containers , effectful , effectful-core , extra @@ -213,6 +236,7 @@ test-suite rpg-test , lens , linear , mtl + , primitive , rpg , text , unordered-containers diff --git a/rpg/src/Component/Position.hs b/rpg/src/Component/Position.hs index 1205b55..2a90022 100644 --- a/rpg/src/Component/Position.hs +++ b/rpg/src/Component/Position.hs @@ -1,15 +1,21 @@ +{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE TypeFamilies #-} module Component.Position (PositionComponent (..), position) where import Apecs.Core -import Apecs.Effectful import Control.Lens +import Foreign.Storable import Linear.V2 +import Stores.SparseSet newtype PositionComponent = Position { position :: V2 Float } deriving (Show) -instance Component PositionComponent where type Storage PositionComponent = Map PositionComponent + deriving newtype (Storable) +instance Component PositionComponent where type Storage PositionComponent = SparseSet IO PositionComponent makeLensesFor [("position", "position")] ''PositionComponent + +instance ComponentDefault PositionComponent where + componentDefault = Position (V2 0 0) diff --git a/rpg/src/Component/Velocity.hs b/rpg/src/Component/Velocity.hs index d1601de..926839b 100644 --- a/rpg/src/Component/Velocity.hs +++ b/rpg/src/Component/Velocity.hs @@ -1,13 +1,20 @@ +{-# 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) -instance Component VelocityComponent where type Storage VelocityComponent = Map VelocityComponent + deriving newtype (Storable) +instance Component VelocityComponent where type Storage VelocityComponent = SparseSet IO VelocityComponent unVelocity :: VelocityComponent -> V2 Float unVelocity (Velocity v) = v + +instance ComponentDefault VelocityComponent where + componentDefault = Velocity (V2 0 0) diff --git a/rpg/src/Engine.hs b/rpg/src/Engine.hs index 11df470..012cf5a 100644 --- a/rpg/src/Engine.hs +++ b/rpg/src/Engine.hs @@ -104,8 +104,8 @@ startEngine = do engineInput applyVelocity'' @w - collisionAABB @w - resolveAABB @w + -- collisionAABB @w + -- resolveAABB @w enginePhysics @@ -118,8 +118,8 @@ startEngine = do getFPS >>= unsafeEff_ . print render @w - renderOrigins @w - renderBoundingBoxes @w - renderCollision @w + -- renderOrigins @w + -- renderBoundingBoxes @w + -- renderCollision @w engineRendering diff --git a/rpg/src/Executables/Pong.hs b/rpg/src/Executables/Pong.hs index 9c90a4a..4177dc2 100644 --- a/rpg/src/Executables/Pong.hs +++ b/rpg/src/Executables/Pong.hs @@ -134,7 +134,11 @@ initialise = do , Position $ V2 (-10) 0 , Box RL.white (0, 0) (0.5, 2) , AABB (V2 0.5 2) (V2 0 0) - , Body 0.0 0.0 False + , Body + { bounciness = 0.0 + , friction = 0.0 + , immovable = False + } ) player1 .= player1Entity @@ -144,7 +148,11 @@ initialise = do , Position $ V2 10 0 , Box RL.white (0, 0) (0.5, 2) , AABB (V2 0.5 2) (V2 0 0) - , Body 0.0 0.0 False + , Body + { bounciness = 0.0 + , friction = 0.0 + , immovable = False + } ) player2 .= player2Entity @@ -154,7 +162,11 @@ 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 1.0 0.0 False + , Body + { bounciness = 1.0 + , friction = 0.0 + , immovable = False + } ) ball .= ballEntity diff --git a/rpg/src/Executables/RPG.hs b/rpg/src/Executables/RPG.hs index cc6d7f0..8a04903 100644 --- a/rpg/src/Executables/RPG.hs +++ b/rpg/src/Executables/RPG.hs @@ -35,7 +35,9 @@ import Effectful.Reader.Dynamic import Effectful.State.Static.Local import Effectful.State.Static.Local.Lens import Engine +import GHC.Float (float2Int, floorFloat) import Linear.V2 +import Noise.Perlin import Raylib.Core qualified as RL import Raylib.Types qualified as RL import Raylib.Util.Colors qualified as RL @@ -80,17 +82,6 @@ spawnPlayer color = , Box color (0, 0) (0.8, 0.8) ) -movePlayer - :: (AE.ECS LocalWorld :> es) - => Eff es AE.Entity - -> (Float, Float) - -> Eff es () -movePlayer eff (x, y) = do - entity <- eff - AE.set @LocalWorld @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) => (Float, Float) @@ -116,7 +107,15 @@ initialise ) => Eff es () initialise = do - setTargetFPS 240 + 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 @@ -143,22 +142,16 @@ initialise = do ) forM_ [(-3) .. 3] \i -> do - spawnBox (-7, i) RL.gray (1, 1) + void $ spawnBox (-7, i) RL.gray (1, 1) spawnBox (7, i) RL.gray (1, 1) forM_ [(-7) .. 7] \i -> do - spawnBox (i, 4) RL.gray (1, 1) + void $ spawnBox (i, 4) RL.gray (1, 1) spawnBox (i, -4) RL.gray (1, 1) boxes .= [] pure () -data RPGEngine = RPGEngine - -data TagComponent a = Tag a - deriving (Show) -instance AE.Component (TagComponent a) where type Storage (TagComponent a) = AE.Map (TagComponent a) - runEngine :: forall es . ( AE.ECS LocalWorld :> es @@ -190,7 +183,7 @@ runEngine = interpret \_ eff -> isKeyDown RL.KeyKpSubtract >>= flip when (AE.modify @LocalWorld @CameraComponent @CameraComponent cameraEntity (\c -> c{zoom = c.zoom - 1})) pure () EnginePhysics -> pure () - EngineRendering unlift -> do + EngineRendering _ -> do pure () -- AE.cmapM_ @World @(AE.Entity, PositionComponent, CollisionComponent) \(entity, position, collision) -> @@ -208,8 +201,12 @@ runGame = do , dimY = 450 , playerEntity = undefined , cameraEntity = undefined + , camera = undefined + , boxes = undefined } + print $ perlin 0 0 + RL.setTraceLogLevel RL.LogWarning runEff . AE.runECS initWorld diff --git a/rpg/src/Noise/Perlin.hs b/rpg/src/Noise/Perlin.hs new file mode 100644 index 0000000..2045cb2 --- /dev/null +++ b/rpg/src/Noise/Perlin.hs @@ -0,0 +1,70 @@ +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 diff --git a/rpg/src/Signals.hs b/rpg/src/Signals.hs new file mode 100644 index 0000000..cda43df --- /dev/null +++ b/rpg/src/Signals.hs @@ -0,0 +1,14 @@ +{-# 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 diff --git a/rpg/src/Stores/SparseSet.hs b/rpg/src/Stores/SparseSet.hs new file mode 100644 index 0000000..3529784 --- /dev/null +++ b/rpg/src/Stores/SparseSet.hs @@ -0,0 +1,185 @@ +{-# 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 diff --git a/rpg/src/System/OpenGLRenderer.hs b/rpg/src/System/OpenGLRenderer.hs new file mode 100644 index 0000000..0ff0dd1 --- /dev/null +++ b/rpg/src/System/OpenGLRenderer.hs @@ -0,0 +1,19 @@ +{-# 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 () diff --git a/rpg/src/System/Physics.hs b/rpg/src/System/Physics.hs index 753f897..a43306e 100644 --- a/rpg/src/System/Physics.hs +++ b/rpg/src/System/Physics.hs @@ -21,6 +21,7 @@ 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 @@ -30,6 +31,7 @@ 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 @@ -76,7 +78,7 @@ applyVelocity' = do [] <&> pairs - forM_ entities \(entity, entities') -> evalState (1.0 :: Float) . evalState (1000 :: Int) $ whileM do + forM_ entities \(entity, entities') -> evalState (1.0 :: Float) . evalState (100 :: Int) $ whileM do (position1, velocity1, aabb1) <- AE.get @w @(PositionComponent, Maybe VelocityComponent, AABBComponent) entity let Velocity velocity1' = fromMaybe (Velocity $ pure 0) velocity1 @@ -152,7 +154,7 @@ applyVelocity'' = do pairs xs = [(x, y) | (x : ys) <- tails (nub xs), y <- ys] entityPairings = pairs allEntities - evalState (1.0 :: Float) . evalState (1000 :: Int) . whileM $ do + evalState (1.0 :: Float) . evalState (16 :: Int) . whileM $ do remainingTime <- get @Float fractions <- forM entityPairings \(entity1, entity2) -> do (position1, velocity1, aabb1, body1) <- AE.get @w @(PositionComponent, Maybe VelocityComponent, AABBComponent, BodyComponent) entity1 @@ -309,8 +311,6 @@ 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 @@ -391,7 +391,7 @@ resolveAABB => Eff es () resolveAABB = do void $ AE.cmapM @w @(PositionComponent, BodyComponent, CollisionComponent) @PositionComponent - \(Position position, Body _ _ _, collision) -> + \(Position position, Body{}, collision) -> case collision.colliders of (_ : _) -> do pure $ Position position diff --git a/rpg/src/System/Renderer.hs b/rpg/src/System/Renderer.hs index 8c32f30..7e63cd7 100644 --- a/rpg/src/System/Renderer.hs +++ b/rpg/src/System/Renderer.hs @@ -1,56 +1,59 @@ {-# LANGUAGE AllowAmbiguousTypes #-} + module System.Renderer (render, renderOrigins, renderBoundingBoxes, renderCollision) where -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 Apecs.Effectful qualified as AE 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 size) -> drawRectangle (x + fst offset - fst size / 2) (y + snd offset - snd size / 2) (fst size) (snd size) color + \(Position (V2 x y), Box color offset (dx, dy)) -> + drawRectangle (x + fst offset - dx / 2) (y + snd offset - dy / 2) dx dy color AE.cmapM_ @w @(PositionComponent, TextBoxComponent) \(Position position, TextBox font text fontSize spacing color) -> do - 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 () + -- let size = V2 0 0 + -- drawText font text (V2 (position ^. _x - size ^. _y / 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 ) @@ -58,16 +61,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) diff --git a/rpg/src/World.hs b/rpg/src/World.hs index 75009a5..7403c53 100644 --- a/rpg/src/World.hs +++ b/rpg/src/World.hs @@ -18,6 +18,8 @@ module World ( module Component.Body, module Component.Collision, module Component.TextBox, + TypeEq, + type (/=), ) where import Component.AABB @@ -46,13 +48,13 @@ import Unsafe.Coerce data SomeStorage = forall s. SomeStorage s -data GenericStorage = GenericStorage {unGenericStorage :: IORef (HSS.HashMap SomeTypeRep SomeStorage)} +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 = GenericComponent +data GenericComponent instance Component GenericComponent where type Storage GenericComponent = GenericStorage makeWorld @@ -72,7 +74,7 @@ makeWorld instance (Monad m) => ExplMembers m EntityStore where explMembers :: EntityStore -> m (Vector Int) explMembers _ = do - pure $ generate 1000 id + pure $ generate 5000 id type family TypeEq a b where TypeEq a a = TypeError (Text "You must add " :<>: ShowType GenericComponent :<>: Text " to the world") @@ -83,6 +85,7 @@ instance {-# OVERLAPS #-} (MonadIO m, Component c, Typeable c, c /= GenericCompo 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