First version of Pong

Signed-off-by: magic_rb <richard@brezak.sk>

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

rpg/pong/Main.hs

@@ -0,0 +1,6 @@
+module Main where
+
+import Pong
+
+main :: IO ()
+main = pongGame

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:

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
+    }

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
+

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
 

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
 

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

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)

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

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]