diff --git a/.dir-locals.el b/.dir-locals.el new file mode 100644 index 0000000..2486863 --- /dev/null +++ b/.dir-locals.el @@ -0,0 +1 @@ +((haskell-mode . ((apheleia-formatter . fourmolu) (apheleia-mode . t)))) diff --git a/flake.lock b/flake.lock index d3c081f..952d822 100644 --- a/flake.lock +++ b/flake.lock @@ -2,11 +2,11 @@ "nodes": { "nixpkgs": { "locked": { - "lastModified": 1695145219, - "narHash": "sha256-Eoe9IHbvmo5wEDeJXKFOpKUwxYJIOxKUesounVccNYk=", + "lastModified": 1700612854, + "narHash": "sha256-yrQ8osMD+vDLGFX7pcwsY/Qr5PUd6OmDMYJZzZi0+zc=", "owner": "NixOS", "repo": "nixpkgs", - "rev": "5ba549eafcf3e33405e5f66decd1a72356632b96", + "rev": "19cbff58383a4ae384dea4d1d0c823d72b49d614", "type": "github" }, "original": { diff --git a/flake.nix b/flake.nix index 9603248..0ce8bf0 100644 --- a/flake.nix +++ b/flake.nix @@ -37,6 +37,7 @@ buildInputs = with pkgs; [ stdenv.cc stack-wrapper + hPkgs.fourmolu hPkgs.ghc hPkgs.implicit-hie hPkgs.haskell-language-server @@ -53,6 +54,7 @@ xorg.libXext xorg.libXdmcp libglvnd + httplz ((raylib.override { includeEverything = true; }).overrideAttrs (old: { patches = []; src = fetchFromGitHub { diff --git a/fourmolu.yaml b/fourmolu.yaml new file mode 100644 index 0000000..355d9f1 --- /dev/null +++ b/fourmolu.yaml @@ -0,0 +1,51 @@ +# Number of spaces per indentation step +indentation: 2 + +# Max line length for automatic line breaking +column-limit: none + +# Styling of arrows in type signatures (choices: trailing, leading, or leading-args) +function-arrows: leading + +# How to place commas in multi-line lists, records, etc. (choices: leading or trailing) +comma-style: leading + +# Styling of import/export lists (choices: leading, trailing, or diff-friendly) +import-export-style: diff-friendly + +# Whether to full-indent or half-indent 'where' bindings past the preceding body +indent-wheres: false + +# Whether to leave a space before an opening record brace +record-brace-space: false + +# Number of spaces between top-level declarations +newlines-between-decls: 1 + +# How to print Haddock comments (choices: single-line, multi-line, or multi-line-compact) +haddock-style: multi-line + +# How to print module docstring +haddock-style-module: null + +# Styling of let blocks (choices: auto, inline, newline, or mixed) +let-style: auto + +# How to align the 'in' keyword with respect to the 'let' keyword (choices: left-align, right-align, or no-space) +in-style: right-align + +# Whether to put parentheses around a single constraint (choices: auto, always, or never) +single-constraint-parens: always + +# Output Unicode syntax (choices: detect, always, or never) +unicode: never + +# Give the programmer more choice on where to insert blank lines +respectful: true + +# Fixity information for operators +fixities: [] + +# Module reexports Fourmolu should know about +reexports: [] + diff --git a/rpg/minkowski/Main.hs b/rpg/minkowski/Main.hs new file mode 100644 index 0000000..f21f5d7 --- /dev/null +++ b/rpg/minkowski/Main.hs @@ -0,0 +1,7 @@ +module Main where + +import Executables.Minkowski + +main = do + print "test" + main' diff --git a/rpg/package.yaml b/rpg/package.yaml index a091f70..57dbdc7 100644 --- a/rpg/package.yaml +++ b/rpg/package.yaml @@ -23,6 +23,7 @@ dependencies: - base >= 4.7 && < 5 - h-raylib - effectful +- effectful-core - bytestring - text - lens @@ -31,6 +32,7 @@ dependencies: - linear - extra - vector + language: GHC2021 default-extensions: - OverloadedStrings @@ -66,6 +68,16 @@ executables: dependencies: - rpg + minkowski: + main: Main.hs + source-dirs: minkowski + ghc-options: + - -threaded + - -rtsopts + - -with-rtsopts=-N + dependencies: + - rpg + pong: main: Main.hs source-dirs: pong diff --git a/rpg/rpg.cabal b/rpg/rpg.cabal index 7e637fd..3abff03 100644 --- a/rpg/rpg.cabal +++ b/rpg/rpg.cabal @@ -1,6 +1,6 @@ cabal-version: 2.2 --- This file has been generated from package.yaml by hpack version 0.35.2. +-- This file has been generated from package.yaml by hpack version 0.36.0. -- -- see: https://github.com/sol/hpack @@ -35,10 +35,12 @@ library Component.Position Component.TextBox Component.Velocity + Effectful.Accessor Effectful.Raylib Effectful.Reader.Static.State Effectful.State.Static.Local.Lens Engine + Executables.Minkowski Lib Pong System.Physics @@ -65,6 +67,7 @@ library , base >=4.7 && <5 , bytestring , effectful + , effectful-core , extra , h-raylib , lens @@ -73,6 +76,39 @@ library , vector default-language: GHC2021 +executable minkowski + main-is: Main.hs + other-modules: + Paths_rpg + autogen-modules: + Paths_rpg + hs-source-dirs: + minkowski + default-extensions: + OverloadedStrings + DuplicateRecordFields + BlockArguments + OverloadedRecordDot + NoFieldSelectors + TemplateHaskell + LambdaCase + ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N + build-depends: + apecs + , apecs-effectful + , base >=4.7 && <5 + , bytestring + , effectful + , effectful-core + , extra + , h-raylib + , lens + , linear + , rpg + , text + , vector + default-language: GHC2021 + executable pong main-is: Main.hs other-modules: @@ -96,6 +132,7 @@ executable pong , base >=4.7 && <5 , bytestring , effectful + , effectful-core , extra , h-raylib , lens @@ -128,6 +165,7 @@ executable rpg-exe , base >=4.7 && <5 , bytestring , effectful + , effectful-core , extra , h-raylib , lens @@ -161,6 +199,7 @@ test-suite rpg-test , base >=4.7 && <5 , bytestring , effectful + , effectful-core , extra , h-raylib , lens diff --git a/rpg/src/Common.hs b/rpg/src/Common.hs index b1da88a..d76f37a 100644 --- a/rpg/src/Common.hs +++ b/rpg/src/Common.hs @@ -1,37 +1,42 @@ {-# LANGUAGE AllowAmbiguousTypes #-} -module Common ( getCamera, playerMovement ) where -import qualified Apecs.Effectful as AE -import World -import Effectful -import qualified Raylib.Types as RL -import GHC.Float -import Linear.V2 +module Common (getCamera, playerMovement) where + +import Apecs.Effectful qualified as AE import Control.Lens +import Effectful import Effectful.Raylib +import GHC.Float +import Linear (normalize) +import Linear.V2 +import Raylib.Types qualified as RL +import World getCamera - :: forall w es . - ( AE.Get w CameraComponent + :: forall w es + . ( AE.Get w CameraComponent , AE.Get w PositionComponent , AE.ECS w :> es ) => Eff es AE.Entity + -- ^ entity to follow -> (Int, Int) + -- ^ dimensions -> Eff es RL.Camera2D getCamera eff (dimX, dimY) = do entity <- eff (c, Position (V2 x y)) <- AE.get @w @(CameraComponent, PositionComponent) entity - pure $ RL.Camera2D - { RL.camera2D'offset = RL.Vector2 (int2Float dimX / 2) (int2Float dimY / 2) - , RL.camera2D'target = RL.Vector2 (x + fst c.offset) (y + snd c.offset) - , RL.camera2D'rotation = 0.0 - , RL.camera2D'zoom = int2Float (min dimX dimY) / int2Float c.zoom - } + pure $ + RL.Camera2D + { RL.camera2D'offset = RL.Vector2 (int2Float dimX / 2) (int2Float dimY / 2) + , RL.camera2D'target = RL.Vector2 (x + fst c.offset) (y + snd c.offset) + , RL.camera2D'rotation = 0.0 + , RL.camera2D'zoom = int2Float (min dimX dimY) / int2Float c.zoom + } playerMovement - :: forall w es . - ( Raylib :> es + :: forall w es + . ( Raylib :> es , AE.ECS w :> es , AE.Get w VelocityComponent ) @@ -45,11 +50,12 @@ playerMovement -> Eff es () playerMovement player (left, right, up, down) speed = do directions <- - mapM (\tuple -> fst tuple <&> (, snd tuple)) - [ ( isKeyDown left, V2 (-speed) 0 ) - , ( isKeyDown right, V2 speed 0 ) - , ( isKeyDown down, V2 0 speed ) - , ( isKeyDown up, V2 0 (-speed) ) - ] + mapM + (\tuple -> fst tuple <&> (,snd tuple)) + [ (isKeyDown left, V2 (-1.0) 0) + , (isKeyDown right, V2 1.0 0) + , (isKeyDown down, V2 0 1.0) + , (isKeyDown up, V2 0 (-1.0)) + ] let movement = foldl (+) (V2 0 0) $ map snd $ filter fst directions - AE.modify @w @() @VelocityComponent player (\() -> Velocity (movement ^. _x) (movement ^. _y)) + AE.set @w @VelocityComponent player (Velocity (normalize movement * pure speed)) diff --git a/rpg/src/Component/AABB.hs b/rpg/src/Component/AABB.hs index 657aa80..7822bbc 100644 --- a/rpg/src/Component/AABB.hs +++ b/rpg/src/Component/AABB.hs @@ -1,26 +1,76 @@ {-# LANGUAGE TypeFamilies #-} -module Component.AABB - ( AABBComponent(..) - , aabbBounds - ) where +module Component.AABB ( + AABBComponent (..), + size, + offset, + AABBBounds (..), + left, + right, + top, + bottom, + aabbBounds, + aabbFromBounds, +) where import Apecs.Effectful -import Linear.V2 -import Linear.V4 import Component.Position +import Control.Lens +import Linear.V2 -data AABBComponent - = AABB +data AABBComponent = AABB { size :: V2 Float , offset :: V2 Float } - deriving Show + deriving (Show) instance Component AABBComponent where type Storage AABBComponent = Map AABBComponent +makeLensesFor + [ ("size", "size") + , ("offset", "offset") + ] + ''AABBComponent -aabbBounds :: PositionComponent -> AABBComponent -> V4 Float +data AABBBounds = AABBBounds + { left :: Float + , right :: Float + , top :: Float + , bottom :: Float + } + deriving (Show) +makeLensesFor + [ ("left", "left") + , ("right", "right") + , ("top", "top") + , ("bottom", "bottom") + ] + ''AABBBounds + +aabbBounds :: PositionComponent -> AABBComponent -> AABBBounds aabbBounds (Position (V2 posX posY)) (AABB (V2 sizeX sizeY) (V2 offsetX offsetY)) = - V4 (posX + sizeX / 2 + offsetX) - (posX - sizeX / 2 + offsetX) - (posY + sizeY / 2 + offsetY) - (posY - sizeY / 2 + offsetY) + AABBBounds + { left = posX - sizeX / 2 + offsetX + , right = posX + sizeX / 2 + offsetX + , top = posY + sizeY / 2 + offsetY + , bottom = posY - sizeY / 2 + offsetY + } + +aabbFromBounds + :: AABBBounds + -- ^ AABB bounds + -> V2 Float + -- ^ the offset of the AABB from its origin + -> (PositionComponent, AABBComponent) + -- ^ a AABB component +aabbFromBounds (AABBBounds left right top bottom) offset@(V2 offsetX offsetY) = + let + width = right - left + height = bottom - top + posX = left + width / 2 - offsetX + posY = top + height / 2 - offsetY + in + ( Position $ V2 posX posY + , AABB + { size = V2 width height + , offset = offset + } + ) diff --git a/rpg/src/Component/Position.hs b/rpg/src/Component/Position.hs index ff1e329..4a5e50d 100644 --- a/rpg/src/Component/Position.hs +++ b/rpg/src/Component/Position.hs @@ -1,11 +1,15 @@ {-# LANGUAGE TypeFamilies #-} -module Component.Position (PositionComponent(..)) where +module Component.Position (PositionComponent(..), position) where import Apecs.Effectful import Linear.V2 +import Control.Lens newtype PositionComponent - = Position (V2 Float) + = Position + { position :: V2 Float + } deriving Show instance Component PositionComponent where type Storage PositionComponent = Map PositionComponent +makeLensesFor [("position", "position")] ''PositionComponent diff --git a/rpg/src/Component/Velocity.hs b/rpg/src/Component/Velocity.hs index a9577b0..d1601de 100644 --- a/rpg/src/Component/Velocity.hs +++ b/rpg/src/Component/Velocity.hs @@ -1,13 +1,13 @@ {-# LANGUAGE TypeFamilies #-} -module Component.Velocity (VelocityComponent(..)) where + +module Component.Velocity (VelocityComponent (..), unVelocity) where import Apecs.Effectful +import Linear.V2 -data VelocityComponent - = Velocity - { x :: Float - , y :: Float - } - deriving Show +newtype VelocityComponent = Velocity (V2 Float) + deriving (Show, Num) instance Component VelocityComponent where type Storage VelocityComponent = Map VelocityComponent +unVelocity :: VelocityComponent -> V2 Float +unVelocity (Velocity v) = v diff --git a/rpg/src/Effectful/Accessor.hs b/rpg/src/Effectful/Accessor.hs new file mode 100644 index 0000000..84c7371 --- /dev/null +++ b/rpg/src/Effectful/Accessor.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE AllowAmbiguousTypes #-} + +module Effectful.Accessor + ( Writes + , writeVal + , runWrites + , Reads + , readVal + , runReads + , runReadsWrites + ) where + +import Effectful +import GHC.Exts (Symbol) +import Effectful.Dispatch.Dynamic + +data Writes (name :: Symbol) a :: Effect where + WriteVal :: forall name a es . a -> (Writes name a) es () +type instance DispatchOf (Writes name a) = Dynamic + +writeVal :: forall name a es . ( Writes name a :> es, HasCallStack ) => a -> Eff es () +writeVal val = send (WriteVal @name @a val) + +runWrites :: forall name a es b . (a -> Eff es ()) -> Eff (Writes name a : es) b -> Eff es b +runWrites action = interpret \_ -> \case + WriteVal a -> inject (action a) + +data Reads (name :: Symbol) a :: Effect where + ReadVal :: (Reads name a) es a +type instance DispatchOf (Reads name a) = Dynamic + +readVal :: forall name a es . ( Reads name a :> es, HasCallStack ) => Eff es a +readVal = send (ReadVal @name @a) + +runReads :: forall name a es b . Eff es a -> Eff (Reads name a : es) b -> Eff es b +runReads action = interpret \_ -> \case + ReadVal -> inject action + +runReadsWrites + :: forall name a es b . + Eff es a + -> (a -> Eff es ()) + -> Eff (Reads name a : Writes name a : es) b + -> Eff es b +runReadsWrites getter setter = runWrites @name @a setter . runReads @name @a (inject getter) diff --git a/rpg/src/Effectful/Raylib.hs b/rpg/src/Effectful/Raylib.hs index cdbf237..6fab8b3 100644 --- a/rpg/src/Effectful/Raylib.hs +++ b/rpg/src/Effectful/Raylib.hs @@ -1,32 +1,38 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE TypeFamilies #-} -module Effectful.Raylib - ( setTargetFPS - , windowShouldClose - , getFontDefault - , isKeyDown - , runDraw - , clearBackground - , runDraw2D - , measureText - , drawText - , drawRectangle - , drawLine - , runRaylibWindow - , Raylib - , RaylibDraw - , RaylibDraw2D - ) where -import Effectful -import qualified Raylib.Types as RL +module Effectful.Raylib ( + setTargetFPS, + windowShouldClose, + getFontDefault, + isKeyDown, + runDraw, + getMousePosition, + getScreenToWorld2D, + isMouseButtonPressed, + isMouseButtonReleased, + clearBackground, + runDraw2D, + measureText, + drawText, + drawRectangle, + drawLine, + runRaylibWindow, + Raylib, + RaylibDraw, + RaylibDraw2D, +) where + +import Control.Lens import Data.Text (Text) +import Data.Text qualified as T +import Effectful import Effectful.Dispatch.Dynamic -import qualified Raylib.Core as RL -import qualified Data.Text as T -import qualified Raylib.Core.Text as RL -import qualified Raylib.Core.Shapes as RL import Linear (V2 (..)) +import Raylib.Core qualified as RL +import Raylib.Core.Shapes qualified as RL +import Raylib.Core.Text qualified as RL +import Raylib.Types qualified as RL data Raylib :: Effect where SetTargetFPS :: Int -> Raylib (Eff es) () @@ -34,10 +40,14 @@ data Raylib :: Effect where GetFontDefault :: Raylib (Eff es) RL.Font IsKeyDown :: RL.KeyboardKey -> Raylib (Eff es) Bool RunDraw :: (IOE :> es) => Eff (RaylibDraw : es) a -> Raylib (Eff es) a + GetMousePosition :: Raylib (Eff es) (V2 Int) + GetScreenToWorld2D :: V2 Int -> RL.Camera2D -> Raylib (Eff es) (V2 Float) + IsMouseButtonPressed :: RL.MouseButton -> Raylib (Eff es) Bool + IsMouseButtonReleased :: RL.MouseButton -> Raylib (Eff es) Bool type instance DispatchOf Raylib = Dynamic data RaylibDraw :: Effect where - ClearBackground :: RL.Color -> RaylibDraw (Eff es) () + ClearBackground :: RL.Color -> RaylibDraw (Eff es) () RunDraw2D :: (IOE :> es) => RL.Camera2D -> Eff (RaylibDraw2D : es) a -> RaylibDraw (Eff es) a type instance DispatchOf RaylibDraw = Dynamic @@ -63,6 +73,18 @@ isKeyDown key = send (IsKeyDown key) runDraw :: (HasCallStack, IOE :> es, Raylib :> es) => Eff (RaylibDraw : es) a -> Eff es a runDraw effect = send (RunDraw effect) +getMousePosition :: (HasCallStack, Raylib :> es) => Eff es (V2 Int) +getMousePosition = send GetMousePosition + +getScreenToWorld2D :: (HasCallStack, Raylib :> es) => V2 Int -> RL.Camera2D -> Eff es (V2 Float) +getScreenToWorld2D vector camera = send (GetScreenToWorld2D vector camera) + +isMouseButtonPressed :: (HasCallStack, Raylib :> es) => RL.MouseButton -> Eff es Bool +isMouseButtonPressed mouseButton = send (IsMouseButtonPressed mouseButton) + +isMouseButtonReleased :: (HasCallStack, Raylib :> es) => RL.MouseButton -> Eff es Bool +isMouseButtonReleased mouseButton = send (IsMouseButtonReleased mouseButton) + clearBackground :: (HasCallStack, RaylibDraw :> es) => RL.Color -> Eff es () clearBackground color = send (ClearBackground color) @@ -92,37 +114,44 @@ runRaylibWindow width height name effect = do SetTargetFPS fps -> liftIO $ RL.setTargetFPS fps IsKeyDown key -> liftIO $ RL.isKeyDown key RunDraw drawEffect -> unlift $ runRaylibDrawing drawEffect + GetMousePosition -> liftIO $ RL.getMousePosition <&> \(RL.Vector2 x y) -> V2 (floor x) (floor y) + GetScreenToWorld2D (V2 xi yi) camera -> + liftIO $ + RL.getScreenToWorld2D (RL.Vector2 (fromIntegral xi) (fromIntegral yi)) camera + <&> \(RL.Vector2 x y) -> V2 x y + IsMouseButtonPressed mouseButton -> liftIO $ RL.isMouseButtonPressed mouseButton + IsMouseButtonReleased mouseButton -> liftIO $ RL.isMouseButtonReleased mouseButton liftIO $ RL.closeWindow window - where - runRaylibDrawing :: (IOE :> es) => Eff (RaylibDraw : es) a -> Eff es a - runRaylibDrawing effect' = do - liftIO RL.beginDrawing - res <- interpret' effect' $ \env eff -> localSeqUnlift env \unlift -> - case eff of - ClearBackground color -> liftIO $ RL.clearBackground color - RunDraw2D camera draw2dEffect -> unlift $ runRaylibDrawing2d camera draw2dEffect - liftIO RL.endDrawing - pure res + where + runRaylibDrawing :: (IOE :> es) => Eff (RaylibDraw : es) a -> Eff es a + runRaylibDrawing effect' = do + liftIO RL.beginDrawing + res <- interpret' effect' $ \env eff -> localSeqUnlift env \unlift -> + case eff of + ClearBackground color -> liftIO $ RL.clearBackground color + RunDraw2D camera draw2dEffect -> unlift $ runRaylibDrawing2d camera draw2dEffect + liftIO RL.endDrawing + pure res - runRaylibDrawing2d :: (IOE :> es) => RL.Camera2D -> Eff (RaylibDraw2D : es) a -> Eff es a - runRaylibDrawing2d camera effect' = do - liftIO (RL.beginMode2D camera) - res <- interpret' effect' $ \env eff -> localSeqUnlift env \unlift -> - case eff of - MeasureText font text fontSize spacing -> do - RL.Vector2 x y <- liftIO $ RL.measureTextEx font (T.unpack text) fontSize spacing - pure (V2 x y) - DrawText font text (V2 posX posY) fontSize spacing color -> - liftIO $ RL.drawTextEx font (T.unpack text) (RL.Vector2 posX posY) fontSize spacing color - DrawRectangle posX posY width height color -> liftIO $ RL.drawRectangleV (RL.Vector2 posX posY) (RL.Vector2 width height) color - DrawLine startX startY endX endY color -> liftIO $ RL.drawLineV (RL.Vector2 startX startY) (RL.Vector2 endX endY) color - liftIO RL.endMode2D - pure res + runRaylibDrawing2d :: (IOE :> es) => RL.Camera2D -> Eff (RaylibDraw2D : es) a -> Eff es a + runRaylibDrawing2d camera effect' = do + liftIO (RL.beginMode2D camera) + res <- interpret' effect' $ \env eff -> localSeqUnlift env \unlift -> + case eff of + MeasureText font text fontSize spacing -> do + RL.Vector2 x y <- liftIO $ RL.measureTextEx font (T.unpack text) fontSize spacing + pure (V2 x y) + DrawText font text (V2 posX posY) fontSize spacing color -> + liftIO $ RL.drawTextEx font (T.unpack text) (RL.Vector2 posX posY) fontSize spacing color + DrawRectangle posX posY width height color -> liftIO $ RL.drawRectangleV (RL.Vector2 posX posY) (RL.Vector2 width height) color + DrawLine startX startY endX endY color -> liftIO $ RL.drawLineV (RL.Vector2 startX startY) (RL.Vector2 endX endY) color + liftIO RL.endMode2D + pure res - interpret' - :: DispatchOf e ~ Dynamic - => Eff (e ': es) a - -> EffectHandler e es - -> Eff es a - interpret' eff handler = interpret handler eff + interpret' + :: (DispatchOf e ~ Dynamic) + => Eff (e ': es) a + -> EffectHandler e es + -> Eff es a + interpret' eff handler = interpret handler eff diff --git a/rpg/src/Engine.hs b/rpg/src/Engine.hs index 5348dc7..70260f6 100644 --- a/rpg/src/Engine.hs +++ b/rpg/src/Engine.hs @@ -1,63 +1,123 @@ {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} -module Engine ( Engine(..), runEngine ) where +module Engine (Engine (..), engineInput, enginePhysics, engineRendering, initialEngine, EngineConstraint, startEngine) where +import Apecs.Effectful qualified as AE +import Data.Kind import Effectful -import System.Physics -import World -import qualified Apecs.Effectful as AE -import qualified Raylib.Types as RL -import System.Renderer +import Effectful.Accessor +import Effectful.Dispatch.Dynamic +import Effectful.Dispatch.Static +import Effectful.Internal.Monad import Effectful.Raylib +import GHC.Exts +import Raylib.Types qualified as RL +import System.Physics +import System.Renderer +import World -class Engine es a where - engineInput :: a -> Eff es () - engineInput _ = pure () - enginePhysics :: a -> Eff es () - enginePhysics _ = pure () - engineRendering :: a -> Eff es () - engineRendering _ = pure () - engineGetCamera :: a -> Eff es RL.Camera2D - engineClearColor :: a -> Eff es RL.Color +data EngineOps es = EngineOps + { input :: Eff es () + , physics :: Eff es () + , rendering :: Eff es () + } -runEngine - :: forall w es a . - ( Engine es a - , AE.Get w PositionComponent - , AE.Get w BodyComponent - , AE.Get w AABBComponent - , AE.Get w BoxComponent - , AE.Get w TextBoxComponent - , AE.Get w CollisionComponent - , AE.Get w VelocityComponent - , IOE :> es - , Raylib :> es - , AE.ECS w :> es +data Engine :: Effect where + EngineInput :: Engine (Eff es) () + EnginePhysics :: Engine (Eff es) () + EngineRendering :: (SharedSuffix es2 es, RaylibDraw :> es2, RaylibDraw2D :> es2) => (forall r. Eff es2 r -> Eff es r) -> Engine (Eff es) () +type instance DispatchOf Engine = Dynamic + +engineInput :: (HasCallStack, Engine :> es) => Eff es () +engineInput = send EngineInput + +enginePhysics :: (HasCallStack, Engine :> es) => Eff es () +enginePhysics = send EnginePhysics + +engineRendering :: forall es. (HasCallStack, Engine :> es, SharedSuffix es es, RaylibDraw :> es, RaylibDraw2D :> es) => Eff es () +engineRendering = unsafeEff $ \env -> (`unEff` env) $ localSeqUnlift @_ @es (LocalEnv env) (\unlift -> send $ EngineRendering unlift) + +class EngineConstraints where + type EngineConstraint (camera :: Symbol) (backgroundColor :: Symbol) (es :: [Effect]) (w :: Type) :: Constraint +instance EngineConstraints where + type + EngineConstraint camera backgroundColor es w = + ( AE.Get w PositionComponent + , AE.Get w BodyComponent + , AE.Get w AABBComponent + , AE.Get w BoxComponent + , AE.Get w TextBoxComponent + , AE.Get w CollisionComponent + , AE.Get w VelocityComponent + , Reads camera RL.Camera2D :> es + , Reads backgroundColor RL.Color :> es + , IOE :> es + , Raylib :> es + , AE.ECS w :> es + ) + +initialEngine + :: forall (es :: [Effect]) + . EngineOps es +initialEngine = + EngineOps + { input = pure () + , physics = pure () + , rendering = pure () + } + +-- inlineBracket +-- (consEnv e dummyRelinker es0) +-- unconsEnv +-- (\es -> unEff m es) + +injectEngine :: forall xs ys. (Subset xs ys) => EngineOps xs -> EngineOps ys +injectEngine engine = + EngineOps + { input = inject engine.input + , physics = inject engine.physics + , rendering = inject engine.rendering + } + +raiseEngine :: forall e es. EngineOps es -> EngineOps (e : es) +raiseEngine engine = + EngineOps + { input = raise engine.input + , physics = raise engine.physics + , rendering = raise engine.rendering + } + +startEngine + :: forall + (camera :: Symbol) + (backgroundColor :: Symbol) + (w :: Type) + es + . ( EngineConstraint camera backgroundColor es w + , Engine :> es ) - => a - -> Eff es () -runEngine engine = do - engineInput engine - - applyVelocity @w + => Eff es () +startEngine = do + engineInput + applyVelocity'' @w collisionAABB @w resolveAABB @w - enginePhysics engine + enginePhysics - c <- engineGetCamera engine + c <- readVal @camera @RL.Camera2D runDraw . runDraw2D c $ do - color <- inject $ engineClearColor engine + color <- readVal @backgroundColor @RL.Color clearBackground color - inject $ engineRendering engine - render @w renderOrigins @w renderBoundingBoxes @w renderCollision @w + engineRendering diff --git a/rpg/src/Executables/Minkowski.hs b/rpg/src/Executables/Minkowski.hs new file mode 100644 index 0000000..569b947 --- /dev/null +++ b/rpg/src/Executables/Minkowski.hs @@ -0,0 +1,213 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE UndecidableInstances #-} + +module Executables.Minkowski (main') where + +import Apecs.Effectful qualified as AE +import Common +import Control.Lens hiding ((%=), (.=)) +import Control.Monad.Extra +import Data.Maybe (isJust) +import Effectful +import Effectful.Accessor +import Effectful.Dispatch.Dynamic +import Effectful.Raylib +import Effectful.Raylib qualified as RL +import Effectful.Reader.Static +import Effectful.State.Static.Local +import Effectful.State.Static.Local.Lens +import Engine +import Linear (normalize) +import Linear.V2 (V2 (..), _x, _y) +import Raylib.Types qualified as RL +import Raylib.Util.Colors qualified as RL +import System.Physics +import World + +data GameState = GameState + { cameraEntity :: AE.Entity + , windowDimensions :: V2 Int + , selectedBox :: Maybe (V2 Float, AE.Entity) + , boxes :: (AE.Entity, AE.Entity) + , minkowski :: AE.Entity + } + deriving (Show) +makeLensesFor + [ ("cameraEntity", "cameraEntity") + , ("windowDimensions", "windowDimensions") + , ("selectedBox", "selectedBox") + , ("boxes", "boxes") + , ("minkowski", "minkowski") + ] + ''GameState + +data GameConfig = GameConfig + { backgroundColor :: RL.Color + } + deriving (Show) +makeLensesFor + [ ("backgroundColor", "backgroundColor") + ] + ''GameConfig + +runGameState + :: (AE.ECS World :> es) + => Eff (State GameState : es) () + -> Eff es () +runGameState action = do + cameraEntity' <- + AE.newEntity @World + ( Position $ V2 0 0 + , Camera 10 (0, 0) + ) + + box1 <- + AE.newEntity @World + ( Position $ V2 0 0 + , Box RL.green (0, 0) (1, 1) + , AABB (V2 1 1) (V2 0 0) + ) + + box2 <- + AE.newEntity @World + ( Position $ V2 2 0 + , Box RL.green (0, 0) (1, 1) + , AABB (V2 1 1) (V2 0 0) + ) + + minkowski' <- + AE.newEntity @World + ( Position $ V2 (-2) 0 + , AABB (V2 2 2) (V2 0 0) + ) + + flip evalState action $ + GameState + { cameraEntity = cameraEntity' + , windowDimensions = V2 640 480 + , selectedBox = Nothing + , boxes = (box1, box2) + , minkowski = minkowski' + } + +runGameConfig + :: Eff (Reader GameConfig : es) () -> Eff es () +runGameConfig = + runReader $ + GameConfig + { backgroundColor = RL.gray + } + +readsCamera + :: ( State GameState :> es + , AE.ECS World :> es + ) + => Eff es RL.Camera2D +readsCamera = do + windowDimensions <- gets @GameState \s -> (s ^. windowDimensions . _x, s ^. windowDimensions . _y) + camera <- gets @GameState \s -> s.cameraEntity + getCamera + @World + (pure camera) + windowDimensions + +runEngine :: forall es. (IOE :> es, AE.ECS World :> es, State GameState :> es, Raylib :> es) => Eff (Engine : es) () -> Eff es () +runEngine = interpret \env eff -> + case eff of + EngineInput -> do + camera <- readsCamera + pos <- getMousePosition >>= \pos -> getScreenToWorld2D pos camera + + isMouseButtonPressed RL.MouseButtonLeft >>= \case + True -> do + AE.cfold @World @(AE.Entity, PositionComponent, AABBComponent) + (\acc (entity, position, aabb) -> (pointCollides pos position aabb <&> (,entity)) : acc) + [] + <&> filter isJust + >>= \case + Just (offset, entity) : _ -> selectedBox .= Just (offset, entity) + _ -> pure () + False -> pure () + isMouseButtonReleased RL.MouseButtonLeft >>= \case + True -> do + selectedBox' <- gets @GameState \s -> s.selectedBox + case selectedBox' of + Just (_, boxEntity) -> + AE.set @World @VelocityComponent boxEntity (Velocity $ V2 0 0) + Nothing -> pure () + selectedBox .= Nothing + False -> pure () + + box <- gets @GameState \s -> s.selectedBox + (box1, box2) <- gets @GameState \s -> s.boxes + box1' <- AE.get @World @(PositionComponent, AABBComponent) box1 + box2' <- AE.get @World @(PositionComponent, AABBComponent) box2 + minkowski' <- gets @GameState \s -> s.minkowski + + case box of + Just (_, box') -> do + Position bpos <- AE.get @World @PositionComponent box' + let offset = pos - bpos + let (mpos, maabb) = aabbFromBounds (minkowskiDifference box1' box2') (V2 0 0) + -- liftIO $ print (Velocity (offset ^. _x) (offset ^. _y)) + AE.set @World minkowski' (mpos, maabb) + AE.set @World box' (Velocity $ V2 (offset ^. _x) (offset ^. _y)) + Nothing -> pure () + EnginePhysics -> pure () + EngineRendering unlift' -> do + (box1, box2) <- gets @GameState \s -> s.boxes + box1Position <- AE.get @World @PositionComponent box1 + (box2Position, box2AABB) <- AE.get @World @(PositionComponent, AABBComponent) box2 + let ray = Ray . normalize $ V2 (box1Position ^. position . _x - box2Position ^. position . _x) (box1Position ^. position . _y - box2Position ^. position . _y) + let collision = rayCollides box1Position (ray, ray) box2Position box2AABB + case collision of + Just collision -> localSeqUnlift env \unlift -> + unlift . unlift' $ RL.drawLine (box1Position ^. position . _x) (box1Position ^. position . _y) (collision ^. _x) (collision ^. _y) RL.blue + Nothing -> pure () + + minkowski' <- gets @GameState \s -> s.minkowski + (minkowskiPosition, minkowskiAABB) <- AE.get @World @(PositionComponent, AABBComponent) minkowski' + let ray = Ray . normalize $ V2 (negate (minkowskiPosition ^. position . _x)) (negate (minkowskiPosition ^. position . _y)) + let collision = rayCollides (Position $ V2 0 0) (ray, ray) minkowskiPosition minkowskiAABB + case collision of + Just collision -> localSeqUnlift env \unlift -> + unlift . unlift' $ RL.drawLine 0 0 (collision ^. _x) (collision ^. _y) RL.blue + Nothing -> pure () + + pure () + +initialize + :: (Raylib :> es) + => Eff es () +initialize = do + setTargetFPS 60 + +main' :: IO () +main' = do + runEff + . AE.runECS initWorld + . runGameState + . runGameConfig + $ gets @GameState (\s -> (s ^. windowDimensions . _x, s ^. windowDimensions . _y)) >>= \(dimX, dimY) -> + runRaylibWindow dimX dimY "App" + . runEngine + $ initialize >> whileM do + engineEnv $ startEngine @"state.camera" @"config.backgroundColor" @World + not <$> windowShouldClose + where + readsBackgroundColor + :: (Reader GameConfig :> es) + => Eff es RL.Color + readsBackgroundColor = asks @GameConfig \c -> c.backgroundColor + engineEnv + :: ( State GameState :> es + , AE.ECS World :> es + , Reader GameConfig :> es + ) + => Eff (Reads "config.backgroundColor" RL.Color : Reads "state.camera" RL.Camera2D : es) a + -> Eff es a + engineEnv = + runReads @"state.camera" @RL.Camera2D readsCamera + . runReads @"config.backgroundColor" @RL.Color readsBackgroundColor diff --git a/rpg/src/Lib.hs b/rpg/src/Lib.hs index e9809f1..848f1be 100644 --- a/rpg/src/Lib.hs +++ b/rpg/src/Lib.hs @@ -1,56 +1,56 @@ -{-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE BlockArguments #-} -{-# LANGUAGE GADTs #-} {-# LANGUAGE DataKinds #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE LambdaCase #-} -{-# LANGUAGE RankNTypes #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeData #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} -module Lib - ( runGame - ) where +module Lib ( + runGame, +) where -import Raylib.Core qualified as RL -import Raylib.Types qualified as RL -import Raylib.Util.Colors qualified as RL -import Control.Monad.Extra -import Control.Lens hiding ((.=)) -import qualified Raylib.Core.Text as RL -import Effectful -import Data.Text (Text) -import Effectful.Dispatch.Dynamic -import qualified Data.Text as T -import Effectful.State.Static.Local -import qualified Raylib.Core.Shapes as RL import Apecs.Effectful qualified as AE -import GHC.Float -import Effectful.Reader.Dynamic -import World +import Common +import Component.Box +import Component.Camera import Component.Player import Component.Position -import Component.Camera -import Component.Box -import Effectful.State.Static.Local.Lens +import Control.Lens hiding ((.=)) +import Control.Monad.Extra +import Data.Text (Text) +import Data.Text qualified as T +import Effectful +import Effectful.Accessor +import Effectful.Dispatch.Dynamic import Effectful.Raylib -import System.Renderer -import Common -import Linear.V2 -import System.Physics +import Effectful.Reader.Dynamic +import Effectful.State.Static.Local +import Effectful.State.Static.Local.Lens import Engine +import GHC.Float +import Linear.V2 +import Raylib.Core qualified as RL +import Raylib.Core.Shapes qualified as RL +import Raylib.Core.Text qualified as RL +import Raylib.Types qualified as RL +import Raylib.Util.Colors qualified as RL +import System.Physics +import System.Renderer +import World -data GameConfig - = GameConfig +data GameConfig = GameConfig { } -data GameState - = GameState +data GameState = GameState { dimX :: Int , dimY :: Int , camera :: RL.Camera2D @@ -58,54 +58,64 @@ data GameState , cameraEntity :: AE.Entity , boxes :: [AE.Entity] } - deriving Show -makeLensesFor [ ("dimX", "dimX") - , ("dimY", "dimY") - , ("camera", "camera") - , ("playerEntity", "playerEntity") - , ("cameraEntity", "cameraEntity") - , ("boxes", "boxes") - ] ''GameState + deriving (Show) +makeLensesFor + [ ("dimX", "dimX") + , ("dimY", "dimY") + , ("camera", "camera") + , ("playerEntity", "playerEntity") + , ("cameraEntity", "cameraEntity") + , ("boxes", "boxes") + ] + ''GameState spawnPlayer - :: ( AE.ECS World :> es ) + :: (AE.ECS World :> es) => RL.Color -> Eff es AE.Entity -spawnPlayer color = AE.newEntity @World - ( Player - , Position $ V2 0 2 - , Camera 10 (0, 0) - , AABB (V2 1 1) (V2 0 0) - , Body (V2 0 2) - , Box color (0, 0) (1, 1) - ) +spawnPlayer color = + AE.newEntity @World + ( Player + , Position $ V2 0 2 + , Camera 10 (0, 0) + , AABB (V2 0.8 0.8) (V2 0 0) + , Body (V2 0 2) + , Box color (0, 0) (0.8, 0.8) + ) movePlayer - :: ( AE.ECS World :> es ) + :: (AE.ECS World :> es) => Eff es AE.Entity -> (Float, Float) -> Eff es () movePlayer eff (x, y) = do entity <- eff - AE.modify @World @() @VelocityComponent entity (\() -> Velocity x y) - -- AE.modify @World @PositionComponent @PositionComponent entity (\(Position p) -> Position $ V2 (p ^. _x + x) (p ^. _y + y)) + AE.set @World @VelocityComponent entity (Velocity $ V2 x y) + +-- AE.modify @World @PositionComponent @PositionComponent entity (\(Position p) -> Position $ V2 (p ^. _x + x) (p ^. _y + y)) spawnBox - :: ( AE.ECS World :> es ) + :: (AE.ECS World :> es, Raylib :> es) => (Float, Float) -> RL.Color -> (Float, Float) -> Eff es AE.Entity -spawnBox (posx, posy) color size = AE.newEntity @World - ( Box color (0, 0) size - , Position $ V2 posx posy - , AABB (V2 1 1) (V2 0 0) - ) +spawnBox (posx, posy) color size = do + entity <- + AE.newEntity @World + ( Box color (0, 0) size + , Position $ V2 posx posy + , AABB (V2 1 1) (V2 0 0) + ) + font <- getFontDefault + AE.set @World entity (TextBox font (T.pack $ show (AE.unEntity entity)) 0.3 0.1 RL.yellow) + pure entity initialise :: ( Raylib :> es , State GameState :> es - , AE.ECS World :> es ) + , AE.ECS World :> es + ) => Eff es () initialise = do setTargetFPS 60 @@ -117,7 +127,10 @@ initialise = do _ <- spawnBox (0, 0) RL.gray (1, 1) _ <- spawnBox (2, 0) RL.gray (1, 1) _ <- spawnBox (3, 0) RL.gray (1, 1) + _ <- spawnBox (4, 0) RL.gray (1, 1) _ <- spawnBox (3, 1) RL.gray (1, 1) + _ <- spawnBox (3, -1) RL.gray (1, 1) + _ <- spawnBox (3, -3) RL.gray (1, 1) boxes .= [] @@ -125,53 +138,65 @@ initialise = do data RPGEngine = RPGEngine -instance ( Raylib :> es - , AE.ECS World :> es - , State GameState :> es - , IOE :> es - ) => Engine es RPGEngine where - engineInput engine = do - playerEntity <- gets @GameState (\s -> s.playerEntity) - playerMovement @World - playerEntity - ( RL.KeyA - , RL.KeyD - , RL.KeyW - , RL.KeyS - ) - 0.1 +runEngine + :: forall es + . ( AE.ECS World :> es + , Raylib :> es + , State GameState :> es + ) + => Eff (Engine : es) () + -> Eff es () +runEngine = interpret \_ eff -> + case eff of + EngineInput -> do + playerEntity <- gets @GameState (\s -> s.playerEntity) + playerMovement @World + playerEntity + ( RL.KeyA + , RL.KeyD + , RL.KeyW + , RL.KeyS + ) + 0.1 - cameraEntity <- gets @GameState (\s -> s.cameraEntity) + cameraEntity <- gets @GameState (\s -> s.cameraEntity) - isKeyDown RL.KeyKpAdd >>= flip when ( AE.modify @World @CameraComponent @CameraComponent cameraEntity (\c -> c { zoom = c.zoom + 1})) - isKeyDown RL.KeyKpSubtract >>= flip when ( AE.modify @World @CameraComponent @CameraComponent cameraEntity (\c -> c { zoom = c.zoom - 1})) - pure () - enginePhysics _ = pure () - -- AE.cmapM_ @World @(AE.Entity, PositionComponent, CollisionComponent) \(entity, position, collision) -> - -- when (collision.colliders /= []) $ liftIO $ print (show entity <> " with " <> show collision.colliders <> " at " <> show position) - engineGetCamera engine = do - dims <- gets @GameState (\s -> (s.dimX, s.dimY)) - getCamera @World (gets @GameState (\s -> s.cameraEntity)) dims - engineClearColor _ = pure RL.white + isKeyDown RL.KeyKpAdd >>= flip when (AE.modify @World @CameraComponent @CameraComponent cameraEntity (\c -> c{zoom = c.zoom + 1})) + isKeyDown RL.KeyKpSubtract >>= flip when (AE.modify @World @CameraComponent @CameraComponent cameraEntity (\c -> c{zoom = c.zoom - 1})) + pure () + EnginePhysics -> pure () + EngineRendering unlift -> pure () + +-- AE.cmapM_ @World @(AE.Entity, PositionComponent, CollisionComponent) \(entity, position, collision) -> +-- when (collision.colliders /= []) $ liftIO $ print (show entity <> " with " <> show collision.colliders <> " at " <> show position) runGame :: IO () runGame = do - let gameConfig - = GameConfig - { - } - gameState - = GameState - { dimX = 800 - , dimY = 450 - , playerEntity = undefined - , cameraEntity = undefined - } + let gameConfig = + GameConfig + { + } + gameState = + GameState + { dimX = 800 + , dimY = 450 + , playerEntity = undefined + , cameraEntity = undefined + } RL.setTraceLogLevel RL.LogWarning - runEff . AE.runECS initWorld . evalState gameState . runReader gameConfig . runRaylibWindow gameState.dimX gameState.dimY "App" $ initialise >> whileM do - - runEngine @World RPGEngine - not <$> windowShouldClose + runEff + . AE.runECS initWorld + . evalState gameState + . runReader gameConfig + . runRaylibWindow gameState.dimX gameState.dimY "App" + . runReads @"config.camera" @RL.Camera2D do + dims <- gets @GameState (\s -> (s.dimX, s.dimY)) + getCamera @World (gets @GameState (\s -> s.cameraEntity)) dims + . runReads @"config.backgroundColor" @RL.Color (pure RL.white) + . runEngine + $ initialise >> whileM do + startEngine @"config.camera" @"config.backgroundColor" @World + not <$> windowShouldClose pure () diff --git a/rpg/src/Pong.hs b/rpg/src/Pong.hs index 183cee6..f2cfb26 100644 --- a/rpg/src/Pong.hs +++ b/rpg/src/Pong.hs @@ -1,28 +1,28 @@ {-# LANGUAGE AllowAmbiguousTypes #-} + module Pong (pongGame) where -import Effectful.State.Static.Local -import qualified Apecs.Effectful as AE -import Effectful -import qualified Raylib.Core as RL -import qualified Raylib.Types as RL -import Effectful.Reader.Static -import Effectful.Raylib -import Control.Monad.Extra -import World -import qualified Raylib.Util.Colors as RL +import Apecs.Effectful qualified as AE import Common hiding (playerMovement) +import Control.Lens hiding ((%=), (.=)) +import Control.Monad.Extra +import Data.Text qualified as T +import Effectful +import Effectful.Raylib +import Effectful.Reader.Static +import Effectful.State.Static.Local import Effectful.State.Static.Local.Lens -import Control.Lens hiding ((.=), (%=)) -import System.Renderer import GHC.Float -import System.Physics +import Linear qualified as L import Linear.V2 -import qualified Linear as L -import qualified Data.Text as T +import Raylib.Core qualified as RL +import Raylib.Types qualified as RL +import Raylib.Util.Colors qualified as RL +import System.Physics +import System.Renderer +import World -data GameState - = GameState +data GameState = GameState { dimX :: Int , dimY :: Int , camera :: AE.Entity @@ -31,12 +31,12 @@ data GameState , ball :: AE.Entity , goal1 :: AE.Entity , goal2 :: AE.Entity - , bottom :: AE.Entity - , top :: AE.Entity + , bottomBorder :: AE.Entity + , topBorder :: AE.Entity , separator :: AE.Entity , score :: (Int, Int) } - deriving Show + deriving (Show) makeLensesFor [ ("dimX", "dimX") , ("dimY", "dimY") @@ -46,24 +46,25 @@ makeLensesFor , ("ball", "ball") , ("goal1", "goal1") , ("goal2", "goal2") - , ("bottom", "bottom") - , ("top", "top") + , ("bottomBorder", "bottomBorder") + , ("topBorder", "topBorder") , ("separator", "separator") , ("score", "score") - ] ''GameState + ] + ''GameState -data GameConfig - = GameConfig +data GameConfig = GameConfig { playArea :: Int } - deriving Show + deriving (Show) makeLensesFor [ ("playArea", "playArea") - ] ''GameConfig + ] + ''GameConfig playerMovement - :: forall w es . - ( Raylib :> es + :: forall w es + . ( Raylib :> es , AE.Get w PositionComponent , AE.Set w PositionComponent , AE.ECS w :> es @@ -75,23 +76,27 @@ playerMovement -> Eff es () playerMovement (up, upSpeed) (down, downSpeed) entity = do playArea <- asks @GameConfig (\c -> c.playArea) - isKeyDown up >>= flip when - (entity >>= flip (AE.modify @w @PositionComponent) (\(Position p) -> clampPosition playArea . Position $ V2 (p ^. _x) (p ^. _y + upSpeed))) - isKeyDown down >>= flip when - (entity >>= flip (AE.modify @w @PositionComponent) (\(Position p) -> clampPosition playArea . Position $ V2 (p ^. _x) (p ^. _y + downSpeed))) - where - clampPosition - :: Int - -> PositionComponent - -> PositionComponent - clampPosition playArea (Position position) - | position ^. _y > int2Float playArea / 2 - 1 = Position $ V2 (position ^. _x) (int2Float playArea / 2 - 1) - | position ^. _y < int2Float playArea / 2 * (-1) + 1 = Position $ V2 (position ^. _x) (int2Float playArea / 2 * (-1) + 1) - | otherwise = Position position + isKeyDown up + >>= flip + when + (entity >>= flip (AE.modify @w @PositionComponent) (\(Position p) -> clampPosition playArea . Position $ V2 (p ^. _x) (p ^. _y + upSpeed))) + isKeyDown down + >>= flip + when + (entity >>= flip (AE.modify @w @PositionComponent) (\(Position p) -> clampPosition playArea . Position $ V2 (p ^. _x) (p ^. _y + downSpeed))) + where + clampPosition + :: Int + -> PositionComponent + -> PositionComponent + clampPosition playArea (Position position) + | position ^. _y > int2Float playArea / 2 - 1 = Position $ V2 (position ^. _x) (int2Float playArea / 2 - 1) + | position ^. _y < int2Float playArea / 2 * (-1) + 1 = Position $ V2 (position ^. _x) (int2Float playArea / 2 * (-1) + 1) + | otherwise = Position position ballMovement - :: forall es . - ( AE.ECS World :> es + :: forall es + . ( AE.ECS World :> es ) => Eff es AE.Entity -> Eff es AE.Entity @@ -114,48 +119,45 @@ ballMovement player1 player2 ball top bottom = do player2' bottom' top' - ballVelocity >>= AE.set @World ball' + ballVelocity + >>= AE.set @World ball' + where + invertYVelocity + :: VelocityComponent + -> VelocityComponent + invertYVelocity (Velocity (V2 x y)) = Velocity $ V2 x (-y) - where - invertYVelocity - :: VelocityComponent - -> VelocityComponent - invertYVelocity (Velocity x y) = Velocity x (-y) - - invertXVelocity - :: VelocityComponent - -> VelocityComponent - invertXVelocity (Velocity x y) = Velocity (-x) y - - ballMovement' - :: AE.Entity - -> AE.Entity - -> AE.Entity - -> AE.Entity - -> AE.Entity - -> VelocityComponent - -> Eff es VelocityComponent - ballMovement' ball player1 player2 bottom top ballVelocity = do - player1c <- getEntityCollision @World ball player1 - player2c <- getEntityCollision @World ball player2 - bottomC <- testEntityCollision @World ball bottom - topC <- testEntityCollision @World ball top - let ret = case (player1c, player2c) of - -- (Just collider, _) -> bounce collider - -- (_, Just collider) -> bounce collider - _ | bottomC || topC -> invertYVelocity ballVelocity - _ -> ballVelocity - v2ToVelocity (V2 x y) = Velocity x y - bounce collider = ballVelocity -- newVelocity.x (abs newVelocity.y * cloor ballVelocity.y) - -- where newVelocity = v2ToVelocity $ L.normalize collider.offset * sqrt 0.02 - -- cloor f - -- | f < 0 = -1 - -- | f == 0 = 0 - -- | otherwise = 1 - - - pure ret + invertXVelocity + :: VelocityComponent + -> VelocityComponent + invertXVelocity (Velocity (V2 x y)) = Velocity $ V2 (-x) y + ballMovement' + :: AE.Entity + -> AE.Entity + -> AE.Entity + -> AE.Entity + -> AE.Entity + -> VelocityComponent + -> Eff es VelocityComponent + ballMovement' ball player1 player2 bottom top ballVelocity = do + player1c <- getEntityCollision @World ball player1 + player2c <- getEntityCollision @World ball player2 + bottomC <- testEntityCollision @World ball bottom + topC <- testEntityCollision @World ball top + let ret = case (player1c, player2c) of + -- (Just collider, _) -> bounce collider + -- (_, Just collider) -> bounce collider + _ | bottomC || topC -> invertYVelocity ballVelocity + _ -> ballVelocity + v2ToVelocity (V2 x y) = Velocity $ V2 x y + bounce collider = ballVelocity -- newVelocity.x (abs newVelocity.y * cloor ballVelocity.y) + -- where newVelocity = v2ToVelocity $ L.normalize collider.offset * sqrt 0.02 + -- cloor f + -- | f < 0 = -1 + -- | f == 0 = 0 + -- | otherwise = 1 + pure ret ballRespawn :: ( AE.ECS World :> es @@ -192,137 +194,147 @@ initialise = do setTargetFPS 60 playArea <- asks @GameConfig (\s -> s.playArea) - cameraEntity <- AE.newEntity @World - ( Camera playArea (0, 0) - , Position $ V2 0 0 - ) + cameraEntity <- + AE.newEntity @World + ( Camera playArea (0, 0) + , Position $ V2 0 0 + ) camera .= cameraEntity - player1Entity <- AE.newEntity @World - ( Player - , Position $ V2 (-10) 0 - , Box RL.white (0, 0) (0.5, 2) - , AABB (V2 0.5 2) (V2 0 0) - ) + player1Entity <- + AE.newEntity @World + ( Player + , Position $ V2 (-10) 0 + , Box RL.white (0, 0) (0.5, 2) + , AABB (V2 0.5 2) (V2 0 0) + ) player1 .= player1Entity - player2Entity <- AE.newEntity @World - (Player - , Position $ V2 10 0 - , Box RL.white (0, 0) (0.5, 2) - , AABB (V2 0.5 2) (V2 0 0) - ) + player2Entity <- + AE.newEntity @World + ( Player + , Position $ V2 10 0 + , Box RL.white (0, 0) (0.5, 2) + , AABB (V2 0.5 2) (V2 0 0) + ) player2 .= player2Entity - ballEntity <- AE.newEntity @World - ( Position $ V2 0 0 - , Velocity 0.1 (-0.1) - , Box RL.white (0, 0) (0.5, 0.5) - , AABB (V2 0.5 0.5) (V2 0 0) - , Body (V2 0 0) - ) + ballEntity <- + AE.newEntity @World + ( Position $ V2 0 0 + , Velocity $ V2 0.1 (-0.1) + , Box RL.white (0, 0) (0.5, 0.5) + , AABB (V2 0.5 0.5) (V2 0 0) + , Body (V2 0 0) + ) ball .= ballEntity - goal1Entity <- AE.newEntity @World - ( Position $ V2 (int2Float (-playArea) / 2 - 1) 0 - , AABB (V2 0.1 (int2Float playArea)) (V2 0 0) - , Box RL.red (0, 0) (0.1, int2Float playArea) - ) - goal2Entity <- AE.newEntity @World - ( Position $ V2 (int2Float playArea / 2 + 1) 0 - , AABB (V2 0.1 (int2Float playArea)) (V2 0 0) - , Box RL.red (0, 0) (0.1, int2Float playArea) - ) + goal1Entity <- + AE.newEntity @World + ( Position $ V2 (int2Float (-playArea) / 2 - 1) 0 + , AABB (V2 0.1 (int2Float playArea)) (V2 0 0) + , Box RL.red (0, 0) (0.1, int2Float playArea) + ) + goal2Entity <- + AE.newEntity @World + ( Position $ V2 (int2Float playArea / 2 + 1) 0 + , AABB (V2 0.1 (int2Float playArea)) (V2 0 0) + , Box RL.red (0, 0) (0.1, int2Float playArea) + ) goal1 .= goal1Entity goal2 .= goal2Entity - topEntity <- AE.newEntity @World - ( Position $ V2 0 (int2Float (-playArea) / 2) - , AABB (V2 (int2Float playArea + 2) 0.1) (V2 0 0) - , Box RL.blue (0, 0) (int2Float playArea + 2, 0.1) - ) - bottomEntity <- AE.newEntity @World - ( Position $ V2 0 (int2Float playArea / 2) - , AABB (V2 (int2Float playArea + 2) 0.1) (V2 0 0) - , Box RL.green (0, 0) (int2Float playArea + 2, 0.1) - ) - top .= topEntity - bottom .= bottomEntity + topEntity <- + AE.newEntity @World + ( Position $ V2 0 (int2Float (-playArea) / 2) + , AABB (V2 (int2Float playArea + 2) 0.1) (V2 0 0) + , Box RL.blue (0, 0) (int2Float playArea + 2, 0.1) + ) + bottomEntity <- + AE.newEntity @World + ( Position $ V2 0 (int2Float playArea / 2) + , AABB (V2 (int2Float playArea + 2) 0.1) (V2 0 0) + , Box RL.green (0, 0) (int2Float playArea + 2, 0.1) + ) + topBorder .= topEntity + bottomBorder .= bottomEntity font <- getFontDefault - separatorEntity <- AE.newEntity @World - ( Position $ V2 0 0 - , Box RL.darkGray (0, 0) (0.1, int2Float playArea) - , TextBox font "" 3 0.1 RL.darkGray - ) + separatorEntity <- + AE.newEntity @World + ( Position $ V2 0 0 + , Box RL.darkGray (0, 0) (0.1, int2Float playArea) + , TextBox font "" 3 0.1 RL.darkGray + ) separator .= separatorEntity pure () pongGame :: IO () pongGame = do - let gameState - = GameState - { dimX = 600 - , dimY = 500 - , player1 = undefined - , player2 = undefined - , camera = undefined - , ball = undefined - , goal1 = undefined - , goal2 = undefined - , top = undefined - , bottom = undefined - , separator = undefined - , score = (0, 0) - } - gameConfig - = GameConfig - { playArea = 20 - } + let gameState = + GameState + { dimX = 600 + , dimY = 500 + , player1 = undefined + , player2 = undefined + , camera = undefined + , ball = undefined + , goal1 = undefined + , goal2 = undefined + , topBorder = undefined + , bottomBorder = undefined + , separator = undefined + , score = (0, 0) + } + gameConfig = + GameConfig + { playArea = 20 + } -- RL.setTraceLogLevel RL.LogWarning - runEff . AE.runECS initWorld . evalState gameState . runReader gameConfig . runRaylibWindow gameState.dimX gameState.dimY "App" $ initialise >> whileM do - playerMovement @World - (RL.KeyW, -0.2) - (RL.KeyS, 0.2) - (gets @GameState (\s -> s.player1)) + runEff . AE.runECS initWorld . evalState gameState . runReader gameConfig . runRaylibWindow gameState.dimX gameState.dimY "App" $ + initialise >> whileM do + playerMovement @World + (RL.KeyW, -0.2) + (RL.KeyS, 0.2) + (gets @GameState (\s -> s.player1)) - playerMovement @World - (RL.KeyUp, -0.2) - (RL.KeyDown, 0.2) - (gets @GameState (\s -> s.player2)) + playerMovement @World + (RL.KeyUp, -0.2) + (RL.KeyDown, 0.2) + (gets @GameState (\s -> s.player2)) - -- ballMovement - -- (gets @GameState (\s -> s.player1)) - -- (gets @GameState (\s -> s.player2)) - -- (gets @GameState (\s -> s.ball)) - -- (gets @GameState (\s -> s.bottom)) - -- (gets @GameState (\s -> s.top)) + -- ballMovement + -- (gets @GameState (\s -> s.player1)) + -- (gets @GameState (\s -> s.player2)) + -- (gets @GameState (\s -> s.ball)) + -- (gets @GameState (\s -> s.bottom)) + -- (gets @GameState (\s -> s.top)) - ballRespawn - (gets @GameState (\s -> s.goal2)) - (gets @GameState (\s -> s.goal1)) - (gets @GameState (\s -> s.ball)) + ballRespawn + (gets @GameState (\s -> s.goal2)) + (gets @GameState (\s -> s.goal1)) + (gets @GameState (\s -> s.ball)) - collisionAABB @World - applyVelocity @World - resolveAABB @World + collisionAABB @World + applyVelocity @World + resolveAABB @World - AE.cmapM_ @World @(AE.Entity, PositionComponent, CollisionComponent) \(entity, position, collision) -> - when (collision.colliders /= []) $ liftIO $ print (show entity <> " with " <> show collision.colliders <> " at " <> show position) + AE.cmapM_ @World @(AE.Entity, PositionComponent, CollisionComponent) \(entity, position, collision) -> + when (collision.colliders /= []) $ liftIO $ print (show entity <> " with " <> show collision.colliders <> " at " <> show position) - score' <- gets @GameState (\s -> s.score) - gets @GameState (\s -> s.separator)>>= flip (AE.modify @World @TextBoxComponent) \textBox -> - textBox { text = T.pack $ show score' } + score' <- gets @GameState (\s -> s.score) + gets @GameState (\s -> s.separator) >>= flip (AE.modify @World @TextBoxComponent) \textBox -> + textBox{text = T.pack $ show score'} - dims <- gets @GameState (\s -> (s.dimX, s.dimY)) - camera <- getCamera @World (gets @GameState (\s -> s.camera)) dims - runDraw . runDraw2D camera $ do - clearBackground RL.gray + dims <- gets @GameState (\s -> (s.dimX, s.dimY)) + camera <- getCamera @World (gets @GameState (\s -> s.camera)) dims + runDraw . runDraw2D camera $ do + clearBackground RL.gray - -- (gets @GameState (\s -> s.score)) >>= liftIO . print + -- (gets @GameState (\s -> s.score)) >>= liftIO . print - render @World - renderOrigins @World - renderBoundingBoxes @World - not <$> windowShouldClose + render @World + renderOrigins @World + renderBoundingBoxes @World + not <$> windowShouldClose diff --git a/rpg/src/System/Physics.hs b/rpg/src/System/Physics.hs index 6b290f7..18da8b2 100644 --- a/rpg/src/System/Physics.hs +++ b/rpg/src/System/Physics.hs @@ -1,43 +1,305 @@ {-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} -module System.Physics (applyVelocity, testEntityCollision, getEntityCollision, collides, collisionAABB, resolveAABB) where +module System.Physics ( + applyVelocity, + applyVelocity', + applyVelocity'', + testEntityCollision, + getEntityCollision, + pointCollides, + collides, + collisionAABB, + resolveAABB, + minkowskiDifference, + RayComponent (..), + direction, + rayCollides, +) where -import World -import qualified Apecs.Effectful as AE -import qualified Apecs.Components as AE (EntityStore) -import Effectful -import Linear -import Control.Lens -import Effectful.Dispatch.Static (unsafeEff_) -import qualified Apecs -import qualified Apecs.Core +import Apecs qualified import Apecs.Components (EntityStore) +import Apecs.Components qualified as AE (EntityStore) +import Apecs.Core qualified +import Apecs.Effectful qualified as AE +import Control.Lens import Control.Monad.Extra -import qualified Debug.Trace as Debut.Trace +import Data.Foldable (minimumBy) +import Data.List (nub, subsequences, tails) +import Data.Maybe (catMaybes, fromMaybe, isJust) +import Debug.Trace qualified as Debug +import Effectful +import Effectful.Dispatch.Static (unsafeEff_) +import Effectful.Raylib +import Effectful.State.Static.Local (evalState, get, modify, put) +import Linear +import World + +data RayComponent = Ray + { direction :: V2 Float + } +makeLensesFor [("origin", "origin"), ("direction", "direction")] ''RayComponent applyVelocity - :: forall w es . - ( AE.Get w PositionComponent + :: forall w es + . ( AE.Get w PositionComponent , AE.Get w VelocityComponent + , AE.Get w AABBComponent , AE.Set w PositionComponent , AE.ECS w :> es ) => Eff es () applyVelocity = do - AE.cmap @w @(PositionComponent, VelocityComponent) @_ - \(Position position, velocity) -> Position $ V2 (position ^. _x + velocity.x) (position ^. _y + velocity.y) + AE.cmapM @w @(AE.Entity, PositionComponent, VelocityComponent, Maybe AABBComponent) @_ + \(this, Position position, Velocity velocity, aabb') -> + case aabb' of + Just aabb -> pure . Position $ V2 (position ^. _x + velocity ^. _x) (position ^. _y + velocity ^. _y) + Nothing -> pure . Position $ V2 (position ^. _x + velocity ^. _x) (position ^. _y + velocity ^. _y) + +applyVelocity' + :: forall w es + . ( AE.Get w PositionComponent + , AE.Get w VelocityComponent + , AE.Get w AABBComponent + , AE.Set w PositionComponent + , AE.ECS w :> es + ) + => Eff es () +applyVelocity' = do + let + pairs :: [AE.Entity] -> [(AE.Entity, [AE.Entity])] + pairs xs = map (\x -> (x, filter (/= x) xs)) xs + + entities :: [(AE.Entity, [AE.Entity])] <- + AE.cfold @w @(AE.Entity, PositionComponent, Maybe VelocityComponent, AABBComponent) + (\acc (this, _, _, _) -> this : acc) + [] + <&> pairs + + forM_ entities \(entity, entities') -> evalState (1.0 :: Float) . evalState (1000 :: Int) $ whileM do + (position1, velocity1, aabb1) <- AE.get @w @(PositionComponent, Maybe VelocityComponent, AABBComponent) entity + let Velocity velocity1' = fromMaybe (Velocity $ pure 0) velocity1 + + fractions <- forM entities' \entity2 -> do + (position2, velocity2, aabb2) <- AE.get @w @(PositionComponent, Maybe VelocityComponent, AABBComponent) entity2 + let + Velocity velocity2' = fromMaybe (Velocity $ pure 0) velocity2 + pure (velocity1' - velocity2', getCollidingVelocityRatio (position1, aabb1, Velocity velocity1') (position2, aabb2, Velocity velocity2')) + + let + order (_, a) (_, b) = a `compare` b + mapH (a, x) + | isNaN x = (a, 1.0) + | otherwise = (a, x) + h = + minimumBy + order + ( (velocity1', 1.0) + : map mapH fractions + ) + h' = + if h ^. _2 < 0.01 + then _2 .~ 0 $ h + else h + newPosition = Position $ position1.position + (velocity1' * pure (h' ^. _2)) + + tangent = normalize (h' ^. _1) ^. _yx & _x %~ negate + newVelocity = Velocity $ pure (tangent `dot` velocity1') * tangent + + AE.set @w entity newPosition + when (h' ^. _2 /= 1.0) $ AE.set @w entity newVelocity + + remainingTime <- get @Float + put @Float $ remainingTime - (h' ^. _2) + + iterations <- get @Int + put @Int $ iterations - 1 + + when (entity == 0) $ unsafeEff_ $ print (tangent, velocity1', tangent `dot` velocity1') + pure (iterations /= 0 && unVelocity newVelocity /= pure 0 && remainingTime > 0) + +clampDown :: Float -> Float +clampDown h + | h < 0.01 = 0 + | otherwise = h + +aabbCollisionNormal :: (PositionComponent, AABBComponent) -> (PositionComponent, AABBComponent) -> V2 Float +aabbCollisionNormal (position1, aabb1) (position2, aabb2) = + (^. _1) $ + minimumBy + order + [ (V2 (-1) 0, abs $ minDiff ^. left) + , (V2 1 0, abs $ minDiff ^. right) + , (V2 0 (-1), abs $ minDiff ^. bottom) + , (V2 0 1, abs $ minDiff ^. top) + ] + where + order (_, a) (_, b) = a `compare` b + minDiff = minkowskiDifference (position1, aabb1) (position2, aabb2) + +applyVelocity'' + :: forall w es + . ( AE.Get w PositionComponent + , AE.Get w VelocityComponent + , AE.Get w AABBComponent + , AE.Set w PositionComponent + , AE.ECS w :> es + ) + => Eff es () +applyVelocity'' = do + allEntities <- AE.cfold @w @(AE.Entity, PositionComponent, AABBComponent) (\acc (a, _, _) -> a : acc) [] + let + pairs xs = [(x, y) | (x : ys) <- tails (nub xs), y <- ys] + entityPairings = pairs allEntities + + evalState (1.0 :: Float) . evalState (1000 :: Int) . whileM $ do + fractions <- forM entityPairings \(entity1, entity2) -> do + (position1, velocity1, aabb1) <- AE.get @w @(PositionComponent, Maybe VelocityComponent, AABBComponent) entity1 + (position2, velocity2, aabb2) <- AE.get @w @(PositionComponent, Maybe VelocityComponent, AABBComponent) entity2 + let + Velocity velocity1' = fromMaybe (Velocity $ pure 0) velocity1 + Velocity velocity2' = fromMaybe (Velocity $ pure 0) velocity2 + + pure + ( Just ((entity1, position1, velocity1, aabb1), (entity2, position2, velocity2, aabb2)) + , getCollidingVelocityRatio (position1, aabb1, Velocity velocity1') (position2, aabb2, Velocity velocity2') + ) + + let + order (_, a) (_, b) = a `compare` b + clampedFractions = map (_2 %~ clampDown) fractions + fractions' = filter (not . isNaN . (^. _2)) clampedFractions + (info, minTime) = minimumBy order ((Nothing, 1.0) : fractions') + + forM_ allEntities \entity1 -> do + (position1, velocity1) <- AE.get @w @(PositionComponent, Maybe VelocityComponent) entity1 + let + velocity1' = fromMaybe (Velocity $ pure 0) velocity1 + AE.set @w entity1 (Position $ position1.position + unVelocity velocity1' * pure (clampDown minTime)) + case info of + Just ((entityA, positionA, velocityA, aabbA), (entityB, positionB, velocityB, aabbB)) -> do + do + let + Velocity velocityA' = fromMaybe (Velocity $ pure 0) velocityA + Velocity velocityB' = fromMaybe (Velocity $ pure 0) velocityB + normal = aabbCollisionNormal (positionA, aabbA) (positionB, aabbB) + alongNormalA = velocityA' `dot` normal + alongNormalB = velocityB' `dot` normal + + bouncinessA = 1.0 + bouncinessB = 1.0 + + frictionA = 1.0 + frictionB = 1.0 + + -- friction and bounce + newVelocityA' = (pure (-alongNormalA) * normal * pure bouncinessA + velocityA') * frictionA + newVelocityB' = (pure (-alongNormalB) * normal * pure bouncinessB + velocityB') * frictionB + + AE.set @w entityA (Velocity newVelocityA') + AE.set @w entityB (Velocity newVelocityB') + pure () + _ -> pure () + + remainingTime <- get @Float + put @Float $ remainingTime - minTime + + iterations <- get @Int + put @Int $ iterations - 1 + + pure (iterations - 1 /= 0 && remainingTime - minTime > 0) + +getCollidingVelocityRatio + :: (PositionComponent, AABBComponent, VelocityComponent) + -- ^ collider A + -> (PositionComponent, AABBComponent, VelocityComponent) + -- ^ collider B + -> Float + -- ^ (normal, ratio) +getCollidingVelocityRatio (position1, aabb1, velocity1) (position2, aabb2, velocity2) = percentage + where + aabbBounds = minkowskiDifference (position1, aabb1) (position2, aabb2) + (positionMinkowski, aabbMinkowski) = aabbFromBounds aabbBounds (V2 0 0) + Velocity velocityMinkowski = velocity1 - velocity2 + ray = Ray . negate $ velocityMinkowski + collision = rayCollides (Position $ V2 0 0) (ray, ray) positionMinkowski aabbMinkowski + percentage = norm (fromMaybe (pure $ 1 / 0) collision) / norm velocityMinkowski + +minkowskiDifference :: (PositionComponent, AABBComponent) -> (PositionComponent, AABBComponent) -> AABBBounds +minkowskiDifference (positionA, aabbA) (positionB, aabbB) = + -- V4 x -x y -y + let + boundsA = aabbBounds positionA aabbA + boundsB = aabbBounds positionB aabbB + in + AABBBounds + { left = boundsA.left - boundsB.right + , right = boundsA.right - boundsB.left + , top = boundsA.top - boundsB.bottom + , bottom = boundsA.bottom - boundsB.top + } + +pointCollides + :: V2 Float + -> PositionComponent + -> AABBComponent + -> Maybe (V2 Float) +pointCollides point position@(Position pos) aabb = do + let (V2 x y) = point + bounds = aabbBounds position aabb + in if bounds ^. left <= x && bounds ^. right >= x && bounds ^. top >= y && bounds ^. bottom <= y + then Just (V2 x y - pos) + else Nothing + +rayCollides + :: PositionComponent + -- ^ ray origin + -> (RayComponent, RayComponent) + -- ^ normal and inversed ray + -> PositionComponent + -- ^ position of target + -> AABBComponent + -- ^ aabb of target + -> Maybe (V2 Float) +rayCollides (Position origin) (ray, rayInverse) (Position position) aabb = + -- https://tavianator.com/2011/ray_box.html + let bounds = aabbBounds (Position position) aabb + tx1 = (bounds ^. left - origin ^. _x) / ray ^. direction . _x + tx2 = (bounds ^. right - origin ^. _x) / ray ^. direction . _x + + tmin' = min tx1 tx2 + tmax' = max tx1 tx2 + + ty1 = (bounds ^. bottom - origin ^. _y) / ray ^. direction . _y + ty2 = (bounds ^. top - origin ^. _y) / ray ^. direction . _y + + tmin = max tmin' (min (min ty1 ty2) tmax') + tmax = min tmax' (max (max ty1 ty2) tmin') + in if tmax > max tmin 0.0 + then + if tmax < 0 + then Just $ V2 (ray ^. direction . _x * tmax + origin ^. _x) (ray ^. direction . _y * tmax + origin ^. _y) + else Just $ V2 (ray ^. direction . _x * tmin + origin ^. _x) (ray ^. direction . _y * tmin + origin ^. _y) + else Nothing collides :: AE.Entity - -> PositionComponent -> AABBComponent - -> PositionComponent -> AABBComponent + -> PositionComponent + -> AABBComponent + -> PositionComponent + -> AABBComponent -> Maybe Collider collides bEntity (Position positionA) aabbA (Position positionB) aabbB = do -- V4 x -x y -y let boundsA = aabbBounds (Position positionA) aabbA boundsB = aabbBounds (Position positionB) aabbB + minDiff = minkowskiDifference (Position positionA, aabbA) (Position positionB, aabbB) - case (boundsA ^. _y - boundsB ^. _x <= 0, boundsA ^. _x - boundsB ^. _y >= 0, boundsB ^. _w - boundsA ^. _z <= 0, boundsB ^. _z - boundsA ^. _w >= 0) of + case ( minDiff.left <= 0 + , minDiff.right >= 0 + , minDiff.top <= 0 + , minDiff.bottom >= 0 + ) of (True, True, True, True) -> let offsetX = (positionB ^. _x - positionA ^. _x) @@ -49,51 +311,56 @@ collides bEntity (Position positionA) aabbA (Position positionB) aabbB = do -- foo :: Float = ((fromIntegral :: Int -> Float) . floor $ (atan2 (offset ^. _x) (offset ^. _y) / 2 * pi * 4)) / 4 * 2 * pi -- foo :: Float = 1.5 + (-1)^fromEnum (offsetY > 0) * (0.5 + (fromIntegral . fromEnum $ offsetX > 0)) foo = case compare (abs offsetX) (abs offsetY) of - LT -> V2 0 offsetY - GT -> V2 offsetX 0 - EQ -> V2 offsetX 0 - in - Just Collider - { other = bEntity - -- https://stackoverflow.com/questions/9324339/how-much-do-two-rectangles-overlap - , overlap = V2 - ((min (boundsA ^. _x) (boundsB ^. _x) - max (boundsA ^. _y) (boundsB ^. _y)) * normalize' offsetX) - ((max (boundsA ^. _w) (boundsB ^. _w) - min (boundsA ^. _z) (boundsB ^. _z)) * normalize' offsetY) - , offset = offset - , normal = normalize foo - } + LT -> V2 0 offsetY + GT -> V2 offsetX 0 + EQ -> V2 offsetX 0 + in + Just + Collider + { other = bEntity + , -- https://stackoverflow.com/questions/9324339/how-much-do-two-rectangles-overlap + overlap = + V2 + ((min (boundsA ^. right) (boundsB ^. right) - max (boundsA ^. left) (boundsB ^. left)) * normalize' offsetX) + ((max (boundsA ^. bottom) (boundsB ^. bottom) - min (boundsA ^. top) (boundsB ^. top)) * normalize' offsetY) + , offset = offset + , normal = normalize foo + } _ -> Nothing testEntityCollision - :: forall w es . - ( AE.Get w CollisionComponent - , AE.ECS w :> es ) + :: forall w es + . ( AE.Get w CollisionComponent + , AE.ECS w :> es + ) => AE.Entity -> AE.Entity -> Eff es Bool -testEntityCollision a b = getEntityCollision @w a b <&> \case Just _ -> True ; Nothing -> False +testEntityCollision a b = getEntityCollision @w a b <&> \case Just _ -> True; Nothing -> False getEntityCollision - :: forall w es . - ( AE.Get w CollisionComponent - , AE.ECS w :> es ) + :: forall w es + . ( AE.Get w CollisionComponent + , AE.ECS w :> es + ) => AE.Entity -> AE.Entity -> Eff es (Maybe Collider) getEntityCollision a b = AE.tryGet @w @CollisionComponent a >>= \case Just collision -> pure $ testEntityCollision' collision b - Nothing -> AE.tryGet @w @CollisionComponent b >>= \case - Just collision -> pure $ testEntityCollision' collision a - Nothing -> pure Nothing - where - testEntityCollision' :: CollisionComponent -> AE.Entity -> Maybe Collider - testEntityCollision' collision other = - foldl (\case Just j -> const $ Just j ; Nothing -> \x -> if x.other == other then Just x else Nothing) Nothing collision.colliders + Nothing -> + AE.tryGet @w @CollisionComponent b >>= \case + Just collision -> pure $ testEntityCollision' collision a + Nothing -> pure Nothing + where + testEntityCollision' :: CollisionComponent -> AE.Entity -> Maybe Collider + testEntityCollision' collision other = + foldl (\case Just j -> const $ Just j; Nothing -> \x -> if x.other == other then Just x else Nothing) Nothing collision.colliders collisionAABB - :: forall w es . - ( AE.Get w PositionComponent + :: forall w es + . ( AE.Get w PositionComponent , AE.Get w BodyComponent , AE.Get w AABBComponent , AE.Get w CollisionComponent @@ -102,19 +369,19 @@ collisionAABB => Eff es () collisionAABB = void $ AE.cmapM @w @(AE.Entity, PositionComponent, BodyComponent, AABBComponent) @(CollisionComponent) - \(bodyEntity, bodyPosition, _, bodyAABB) -> do - colliders <- flip (AE.cfoldM @w @(AE.Entity, PositionComponent, AABBComponent)) [] \acc (colliderEntity, colliderPosition, colliderAABB) -> - pure $ if bodyEntity /= colliderEntity then - case collides colliderEntity bodyPosition bodyAABB colliderPosition colliderAABB of - Just collider -> collider : acc - Nothing -> acc - else - acc - pure $ Collision { colliders = colliders } + \(bodyEntity, bodyPosition, _, bodyAABB) -> do + colliders <- flip (AE.cfoldM @w @(AE.Entity, PositionComponent, AABBComponent)) [] \acc (colliderEntity, colliderPosition, colliderAABB) -> + pure $ + if bodyEntity /= colliderEntity + then case collides colliderEntity bodyPosition bodyAABB colliderPosition colliderAABB of + Just collider -> collider : acc + Nothing -> acc + else acc + pure $ Collision{colliders = colliders} resolveAABB - :: forall w es . - ( AE.Get w PositionComponent + :: forall w es + . ( AE.Get w PositionComponent , AE.Get w BodyComponent , AE.Get w CollisionComponent , AE.ECS w :> es @@ -125,14 +392,15 @@ resolveAABB = do void $ AE.cmapM @w @(PositionComponent, BodyComponent, CollisionComponent) @PositionComponent \(Position position, Body previousPosition, collision) -> case collision.colliders of - (_:_) -> do + (_ : _) -> do -- liftIO . print $ foldl (\a c -> a - c.overlap) (head collision.colliders).overlap (tail collision.colliders) pure $ Position position _ -> pure $ Position position - -- pure . Position $ foldl resolve position collision.colliders - where resolve :: V2 Float -> Collider -> V2 Float - resolve position collider = - case collider.overlap of - V2 x y | abs x < abs y -> position & _x %~ flip (-) x - V2 x y | abs y < abs x -> position & _y %~ (+) y - V2 x _ -> position & _x %~ flip (-) x + where + -- pure . Position $ foldl resolve position collision.colliders + resolve :: V2 Float -> Collider -> V2 Float + resolve position collider = + case collider.overlap of + V2 x y | abs x < abs y -> position & _x %~ flip (-) x + V2 x y | abs y < abs x -> position & _y %~ (+) y + V2 x _ -> position & _x %~ flip (-) x diff --git a/rpg/src/System/Renderer.hs b/rpg/src/System/Renderer.hs index b69a945..a28ae79 100644 --- a/rpg/src/System/Renderer.hs +++ b/rpg/src/System/Renderer.hs @@ -71,10 +71,10 @@ renderBoundingBoxes renderBoundingBoxes = AE.cmapM_ @w @(PositionComponent, AABBComponent) \(pos, aabb) -> do - let (V4 x nx y ny) = aabbBounds pos aabb - drawLine x y x ny RL.red - drawLine x ny nx ny RL.red - drawLine nx ny nx y RL.red - drawLine nx y x y RL.red - drawLine x y nx ny RL.red - drawLine nx y x ny RL.red + let (AABBBounds left right top bottom) = aabbBounds pos aabb + drawLine right bottom right top RL.red + drawLine right top left top RL.red + drawLine left top left bottom RL.red + drawLine left bottom right bottom RL.red + drawLine right bottom left top RL.red + drawLine left bottom right top RL.red diff --git a/snake/app/Main.hs b/snake/app/Main.hs index defcdb5..8d02f4c 100644 --- a/snake/app/Main.hs +++ b/snake/app/Main.hs @@ -370,7 +370,7 @@ main = in bracket (SDL.initialize [ SDL.InitEvents, SDL.InitVideo ]) (const SDL.quit) $ \_ -> bracket (SDL.createWindow "Snake" windowConfig) SDL.destroyWindow $ \window -> - bracket (SDL.createRenderer window (-1) rendererConfig) SDL.destroyRenderer $ \renderer -> + bracket (SDL.createRenderer window 0 rendererConfig) SDL.destroyRenderer $ \renderer -> initStdGen >>= \rng -> SDLI.loadTexture renderer "textures/atlas.png" >>= \texture -> diff --git a/stack.yaml b/stack.yaml index b6a2a2f..8cd9b9a 100644 --- a/stack.yaml +++ b/stack.yaml @@ -55,6 +55,10 @@ flags: detect-platform: false platform-nixos: true +# Needed by HLS to display haddocks +ghc-options: + '$everything': -haddock + # Extra package databases containing global packages # extra-package-dbs: []