From 9c658ce9d4f260115b8d5f76b4377212d191dd6d Mon Sep 17 00:00:00 2001 From: magic_rb Date: Wed, 11 Oct 2023 22:14:07 +0200 Subject: [PATCH] First version of Pong Signed-off-by: magic_rb --- rpg/package.yaml | 10 ++ rpg/pong/Main.hs | 6 ++ rpg/rpg.cabal | 33 +++++++ rpg/src/Common.hs | 22 +++++ rpg/src/Component/Velocity.hs | 13 +++ rpg/src/Effectful/Raylib.hs | 6 ++ rpg/src/Lib.hs | 24 +---- rpg/src/Pong.hs | 177 ++++++++++++++++++++++++++++++++++ rpg/src/System/Physics.hs | 13 +++ rpg/src/System/Renderer.hs | 13 ++- rpg/src/World.hs | 13 ++- 11 files changed, 306 insertions(+), 24 deletions(-) create mode 100644 rpg/pong/Main.hs create mode 100644 rpg/src/Common.hs create mode 100644 rpg/src/Component/Velocity.hs create mode 100644 rpg/src/Pong.hs create mode 100644 rpg/src/System/Physics.hs diff --git a/rpg/package.yaml b/rpg/package.yaml index e0adfcb..1101936 100644 --- a/rpg/package.yaml +++ b/rpg/package.yaml @@ -63,6 +63,16 @@ executables: dependencies: - rpg + pong: + main: Main.hs + source-dirs: pong + ghc-options: + - -threaded + - -rtsopts + - -with-rtsopts=-N + dependencies: + - rpg + tests: rpg-test: main: Spec.hs diff --git a/rpg/pong/Main.hs b/rpg/pong/Main.hs new file mode 100644 index 0000000..996b26e --- /dev/null +++ b/rpg/pong/Main.hs @@ -0,0 +1,6 @@ +module Main where + +import Pong + +main :: IO () +main = pongGame diff --git a/rpg/rpg.cabal b/rpg/rpg.cabal index 65afbb4..e8956d0 100644 --- a/rpg/rpg.cabal +++ b/rpg/rpg.cabal @@ -25,13 +25,17 @@ source-repository head library exposed-modules: + Common Component.Box Component.Camera Component.Player Component.Position + Component.Velocity Effectful.Raylib Effectful.State.Static.Local.Lens Lib + Pong + System.Physics System.Renderer World other-modules: @@ -60,6 +64,35 @@ library , text default-language: GHC2021 +executable pong + main-is: Main.hs + other-modules: + Paths_rpg + autogen-modules: + Paths_rpg + hs-source-dirs: + pong + 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-effectful + , base >=4.7 && <5 + , bytestring + , effectful + , extra + , h-raylib + , lens + , rpg + , text + default-language: GHC2021 + executable rpg-exe main-is: Main.hs other-modules: diff --git a/rpg/src/Common.hs b/rpg/src/Common.hs new file mode 100644 index 0000000..aad3d26 --- /dev/null +++ b/rpg/src/Common.hs @@ -0,0 +1,22 @@ +module Common ( getCamera ) where + +import qualified Apecs.Effectful as AE +import World +import Effectful +import qualified Raylib.Types as RL +import GHC.Float + +getCamera + :: ( AE.ECS World :> es ) + => Eff es AE.Entity + -> (Int, Int) + -> Eff es RL.Camera2D +getCamera eff (dimX, dimY) = do + entity <- eff + (c, p) <- AE.get @World @(CameraComponent, PositionComponent) entity + pure $ RL.Camera2D + { RL.camera2D'offset = RL.Vector2 (int2Float dimX / 2) (int2Float dimY / 2) + , RL.camera2D'target = RL.Vector2 (p.x + fst c.offset) (p.y + snd c.offset) + , RL.camera2D'rotation = 0.0 + , RL.camera2D'zoom = int2Float (min dimX dimY) / int2Float c.zoom + } diff --git a/rpg/src/Component/Velocity.hs b/rpg/src/Component/Velocity.hs new file mode 100644 index 0000000..a9577b0 --- /dev/null +++ b/rpg/src/Component/Velocity.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE TypeFamilies #-} +module Component.Velocity (VelocityComponent(..)) where + +import Apecs.Effectful + +data VelocityComponent + = Velocity + { x :: Float + , y :: Float + } + deriving Show +instance Component VelocityComponent where type Storage VelocityComponent = Map VelocityComponent + diff --git a/rpg/src/Effectful/Raylib.hs b/rpg/src/Effectful/Raylib.hs index dc46f60..198c3b3 100644 --- a/rpg/src/Effectful/Raylib.hs +++ b/rpg/src/Effectful/Raylib.hs @@ -9,6 +9,7 @@ module Effectful.Raylib , runDraw2D , drawText , drawRectangle + , drawLine , runRaylibWindow , Raylib , RaylibDraw @@ -40,6 +41,7 @@ type instance DispatchOf RaylibDraw = Dynamic data RaylibDraw2D :: Effect where DrawText :: Text -> Int -> Int -> Int -> RL.Color -> RaylibDraw2D (Eff es) () DrawRectangle :: Float -> Float -> Float -> Float -> RL.Color -> RaylibDraw2D (Eff es) () + DrawLine :: Float -> Float -> Float -> Float -> RL.Color -> RaylibDraw2D (Eff es) () type instance DispatchOf RaylibDraw2D = Dynamic setTargetFPS :: (HasCallStack, Raylib :> es) => Int -> Eff es () @@ -66,6 +68,9 @@ drawText text posX posY fontSize color = send (DrawText text posX posY fontSize drawRectangle :: (HasCallStack, RaylibDraw2D :> es) => Float -> Float -> Float -> Float -> RL.Color -> Eff es () drawRectangle posX posY width height color = send (DrawRectangle posX posY width height color) +drawLine :: (HasCallStack, RaylibDraw2D :> es) => Float -> Float -> Float -> Float -> RL.Color -> Eff es () +drawLine posX posY endX endY color = send (DrawLine posX posY endX endY color) + runRaylibWindow :: (IOE :> es) => Int -> Int -> Text -> Eff (Raylib : es) () -> Eff es () runRaylibWindow width height name effect = do window <- liftIO $ RL.initWindow width height (T.unpack name) @@ -96,6 +101,7 @@ runRaylibWindow width height name effect = do case eff of DrawText text posX posY fontSize color -> liftIO $ RL.drawText (T.unpack text) posX posY fontSize 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 diff --git a/rpg/src/Lib.hs b/rpg/src/Lib.hs index 0f105e3..3d0e710 100644 --- a/rpg/src/Lib.hs +++ b/rpg/src/Lib.hs @@ -38,6 +38,7 @@ import Component.Box import Effectful.State.Static.Local.Lens import Effectful.Raylib import System.Renderer +import Common data GameConfig = GameConfig @@ -84,26 +85,6 @@ spawnBox -> Eff es AE.Entity spawnBox (posx, posy) color size = AE.newEntity @World (Box color size (0, 0), Position posx posy) -getCamera - :: ( AE.ECS World :> es - , State GameState :> es - , Reader GameConfig :> es - ) - => Eff es AE.Entity - -> Eff es RL.Camera2D -getCamera eff = do - entity <- eff - (c, p) <- AE.get @World @(CameraComponent, PositionComponent) entity - gameState <- get @GameState - gameConfig <- ask @GameConfig - - pure $ RL.Camera2D - { RL.camera2D'offset = RL.Vector2 (int2Float gameState.dimX / 2) (int2Float gameState.dimY / 2) - , RL.camera2D'target = RL.Vector2 (p.x + fst c.offset) (p.y + snd c.offset) - , RL.camera2D'rotation = 0.0 - , RL.camera2D'zoom = int2Float (min gameState.dimX gameState.dimY) / int2Float c.zoom - } - initialise :: ( Raylib :> es , State GameState :> es @@ -143,7 +124,8 @@ runGame = do 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})) - c <- getCamera (gets @GameState (\s -> s.cameraEntity)) + dims <- gets @GameState (\s -> (s.dimX, s.dimY)) + c <- getCamera (gets @GameState (\s -> s.cameraEntity)) dims liftIO $ print c runDraw . runDraw2D c $ do diff --git a/rpg/src/Pong.hs b/rpg/src/Pong.hs new file mode 100644 index 0000000..6a39d7d --- /dev/null +++ b/rpg/src/Pong.hs @@ -0,0 +1,177 @@ +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 Common +import Effectful.State.Static.Local.Lens +import Control.Lens hiding ((.=), (%=)) +import System.Renderer +import GHC.Float +import System.Physics + +data GameState + = GameState + { dimX :: Int + , dimY :: Int + , camera :: AE.Entity + , player1 :: AE.Entity + , player2 :: AE.Entity + , ball :: AE.Entity + } + deriving Show +makeLensesFor [("dimX", "dimX"), ("dimY", "dimY"), ("camera", "camera"), ("player1", "player1"), ("player2", "player2"), ("ball", "ball")] ''GameState + +data GameConfig + = GameConfig + { playArea :: Int + } + deriving Show +makeLensesFor [("playArea", "playArea")] ''GameConfig + +playerMovement + :: ( Raylib :> es + , AE.ECS World :> es + , Reader GameConfig :> es + ) + => (RL.KeyboardKey, Float) + -> (RL.KeyboardKey, Float) + -> Eff es AE.Entity + -> Eff es () +playerMovement (up, upSpeed) (down, downSpeed) entity = do + playArea <- asks @GameConfig (\c -> c.playArea) + isKeyDown up >>= flip when + (entity >>= flip (AE.modify @World @PositionComponent) (\p -> clampPosition playArea $ Position p.x (p.y + upSpeed))) + isKeyDown down >>= flip when + (entity >>= flip (AE.modify @World @PositionComponent) (\p -> clampPosition playArea $ Position p.x (p.y + downSpeed))) + where + clampPosition + :: Int + -> PositionComponent + -> PositionComponent + clampPosition playArea (Position x y) + | y > int2Float playArea / 2 - 1 = Position x (int2Float playArea / 2 - 1) + | y < int2Float playArea / 2 * (-1) + 1 = Position x (int2Float playArea / 2 * (-1) + 1) + | otherwise = Position x y + +ballMovement + :: ( AE.ECS World :> es + , Reader GameConfig :> es + ) + => Eff es AE.Entity + -> Eff es AE.Entity + -> Eff es AE.Entity + -> Eff es () +ballMovement player1 player2 ball = do + ballEntity <- ball + playArea <- asks @GameConfig (\c -> c.playArea) + player1Position <- player1 >>= AE.get @World + player2Position <- player2 >>= AE.get @World + ballPosition <- AE.get @World ballEntity + ballVelocity <- AE.get @World ballEntity + + let newVelocity = ballMovement' + playArea + player1Position + player2Position + (ballPosition, ballVelocity) + + AE.set @World ballEntity newVelocity + + where + invertYVelocity + :: VelocityComponent + -> VelocityComponent + invertYVelocity (Velocity x y) = Velocity x (-y) + invertXVelocity + :: VelocityComponent + -> VelocityComponent + invertXVelocity (Velocity x y) = Velocity (-x) y + + ballMovement' + :: Int + -> PositionComponent + -> PositionComponent + -> (PositionComponent, VelocityComponent) + -> VelocityComponent + ballMovement' playArea player1 player2 (ballPosition, ballVelocity) + | ballPosition.y + 0.25 > int2Float playArea / 2 = invertYVelocity ballVelocity + | ballPosition.y - 0.25 < int2Float playArea / 2 * (-1) = invertYVelocity ballVelocity + | ballPosition.x + 0.75 > player2.x && ballPosition.x + 0.5 < player2.x && ballPosition.y >= player2.y - 1.25 && ballPosition.y <= player2.y + 1.25 = invertXVelocity ballVelocity + | ballPosition.x - 0.75 < player1.x && ballPosition.x - 0.5 > player1.x && ballPosition.y >= player1.y - 1.25 && ballPosition.y <= player1.y + 1.25 = invertXVelocity ballVelocity + | otherwise = ballVelocity + +initialise + :: ( Raylib :> es + , State GameState :> es + , AE.ECS World :> es + ) + => Eff es () +initialise = do + setTargetFPS 60 + + cameraEntity <- AE.newEntity @World (Camera 20 (0, 0), Position 0 0) + camera .= cameraEntity + + player1Entity <- AE.newEntity @World (Player, Position (-10) 0, Box RL.white (0, -1) (0.5, 2)) + player1 .= player1Entity + + player2Entity <- AE.newEntity @World (Player, Position 10 0, Box RL.white (-0.5, -1) (0.5, 2)) + player2 .= player2Entity + + ballEntity <- AE.newEntity @World (Position 0 0, Velocity 0.1 0.1, Box RL.white (-0.25, -0.25) (0.5, 0.5)) + ball .= ballEntity + + pure () + +pongGame :: IO () +pongGame = do + let gameState + = GameState + { dimX = 600 + , dimY = 500 + , player1 = undefined + , player2 = undefined + , camera = undefined + , ball = undefined + } + 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 + ballMovement + (gets @GameState (\s -> s.player1)) + (gets @GameState (\s -> s.player2)) + (gets @GameState (\s -> s.ball)) + + applyVelocity + + playerMovement + (RL.KeyW, -0.2) + (RL.KeyS, 0.2) + (gets @GameState (\s -> s.player1)) + + playerMovement + (RL.KeyUp, -0.2) + (RL.KeyDown, 0.2) + (gets @GameState (\s -> s.player2)) + + (gets @GameState (\s -> s.ball)) >>= AE.get @World @(PositionComponent, VelocityComponent) >>= liftIO . print + + dims <- gets @GameState (\s -> (s.dimX, s.dimY)) + camera <- getCamera (gets @GameState (\s -> s.camera)) dims + runDraw . runDraw2D camera $ do + clearBackground RL.gray + + render + renderOrigins + not <$> windowShouldClose diff --git a/rpg/src/System/Physics.hs b/rpg/src/System/Physics.hs new file mode 100644 index 0000000..6d03644 --- /dev/null +++ b/rpg/src/System/Physics.hs @@ -0,0 +1,13 @@ +module System.Physics (applyVelocity) where + +import World +import qualified Apecs.Effectful as AE +import Effectful + +applyVelocity + :: ( AE.ECS World :> es + ) + => Eff es () +applyVelocity = do + AE.cmap @World @(PositionComponent, VelocityComponent) @_ + \(position, velocity) -> Position (position.x + velocity.x) (position.y + velocity.y) diff --git a/rpg/src/System/Renderer.hs b/rpg/src/System/Renderer.hs index bac26f1..0772a0f 100644 --- a/rpg/src/System/Renderer.hs +++ b/rpg/src/System/Renderer.hs @@ -1,4 +1,4 @@ -module System.Renderer (render) where +module System.Renderer (render, renderOrigins) where import Effectful import qualified Apecs.Effectful as AE @@ -6,6 +6,7 @@ import World import Component.Position import Component.Box import Effectful.Raylib +import qualified Raylib.Util.Colors as RL render :: ( AE.ECS World :> es @@ -15,3 +16,13 @@ render = do AE.cmapM_ @World @(PositionComponent, BoxComponent) \(pos, Box color offset size) -> drawRectangle (pos.x + fst offset) (pos.y + snd offset) (fst size) (snd size) color pure () + +renderOrigins + :: ( AE.ECS World :> es + , RaylibDraw2D :> es + ) + => Eff es () +renderOrigins = do + AE.cmapM_ @World @PositionComponent + \pos -> drawLine (pos.x - 0.1) (pos.y - 0.1) (pos.x + 0.1) (pos.y + 0.1) RL.red >> + drawLine (pos.x + 0.1) (pos.y - 0.1) (pos.x - 0.1) (pos.y + 0.1) RL.red diff --git a/rpg/src/World.hs b/rpg/src/World.hs index f0b64cb..48e64d8 100644 --- a/rpg/src/World.hs +++ b/rpg/src/World.hs @@ -1,12 +1,21 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE FieldSelectors #-} -module World (World, initWorld) where +module World + ( World + , initWorld + , module Component.Player + , module Component.Position + , module Component.Camera + , module Component.Box + , module Component.Velocity + ) where import Apecs.Effectful import Component.Position import Component.Player import Component.Camera import Component.Box +import Component.Velocity -makeWorld "World" [''PositionComponent, ''PlayerComponent, ''CameraComponent, ''BoxComponent] +makeWorld "World" [''PositionComponent, ''PlayerComponent, ''CameraComponent, ''BoxComponent, ''VelocityComponent]