mirror of
https://git.sr.ht/~magic_rb/haskell-games
synced 2024-11-21 23:34:21 +01:00
105 fps +-
Signed-off-by: magic_rb <richard@brezak.sk>
This commit is contained in:
parent
885bf8943b
commit
2972b5b048
|
|
@ -41,6 +41,7 @@
|
|||
hPkgs.ghc
|
||||
hPkgs.implicit-hie
|
||||
hPkgs.haskell-language-server
|
||||
hPkgs.profiterole
|
||||
SDL2
|
||||
SDL2_image
|
||||
libtiff
|
||||
|
|
|
|||
7
rpg/cbits/raylib_batch.c
Normal file
7
rpg/cbits/raylib_batch.c
Normal file
|
|
@ -0,0 +1,7 @@
|
|||
#include "raylib_batch.h"
|
||||
|
||||
void draw_rectangles_batch(const rectangle_info_t* rectangles, size_t count) {
|
||||
for (size_t i = 0; i < count; i++) {
|
||||
DrawRectangleV(rectangles[i].position, rectangles[i].size, rectangles[i].color);
|
||||
}
|
||||
}
|
||||
10
rpg/cbits/raylib_batch.h
Normal file
10
rpg/cbits/raylib_batch.h
Normal file
|
|
@ -0,0 +1,10 @@
|
|||
#include <raylib.h>
|
||||
#include <stddef.h>
|
||||
|
||||
typedef struct rectangle_info {
|
||||
Vector2 position;
|
||||
Vector2 size;
|
||||
Color color;
|
||||
} rectangle_info_t;
|
||||
|
||||
void draw_rectangles_batch(const rectangle_info_t* rectangles, size_t count);
|
||||
|
|
@ -38,6 +38,8 @@ dependencies:
|
|||
- containers
|
||||
- GLFW-b
|
||||
- OpenGL
|
||||
- derive-storable
|
||||
- derive-storable-plugin
|
||||
|
||||
language: GHC2021
|
||||
default-extensions:
|
||||
|
|
@ -62,6 +64,8 @@ ghc-options:
|
|||
|
||||
library:
|
||||
source-dirs: src
|
||||
c-sources: cbits/*.c
|
||||
include-dirs: cbits
|
||||
|
||||
executables:
|
||||
rpg-exe:
|
||||
|
|
|
|||
|
|
@ -65,6 +65,10 @@ library
|
|||
TemplateHaskell
|
||||
LambdaCase
|
||||
ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints
|
||||
include-dirs:
|
||||
cbits
|
||||
c-sources:
|
||||
cbits/raylib_batch.c
|
||||
build-depends:
|
||||
GLFW-b
|
||||
, OpenGL
|
||||
|
|
@ -73,6 +77,8 @@ library
|
|||
, base >=4.7 && <5
|
||||
, bytestring
|
||||
, containers
|
||||
, derive-storable
|
||||
, derive-storable-plugin
|
||||
, effectful
|
||||
, effectful-core
|
||||
, extra
|
||||
|
|
@ -111,6 +117,8 @@ executable minkowski
|
|||
, base >=4.7 && <5
|
||||
, bytestring
|
||||
, containers
|
||||
, derive-storable
|
||||
, derive-storable-plugin
|
||||
, effectful
|
||||
, effectful-core
|
||||
, extra
|
||||
|
|
@ -150,6 +158,8 @@ executable pong
|
|||
, base >=4.7 && <5
|
||||
, bytestring
|
||||
, containers
|
||||
, derive-storable
|
||||
, derive-storable-plugin
|
||||
, effectful
|
||||
, effectful-core
|
||||
, extra
|
||||
|
|
@ -189,6 +199,8 @@ executable rpg-exe
|
|||
, base >=4.7 && <5
|
||||
, bytestring
|
||||
, containers
|
||||
, derive-storable
|
||||
, derive-storable-plugin
|
||||
, effectful
|
||||
, effectful-core
|
||||
, extra
|
||||
|
|
@ -229,6 +241,8 @@ test-suite rpg-test
|
|||
, base >=4.7 && <5
|
||||
, bytestring
|
||||
, containers
|
||||
, derive-storable
|
||||
, derive-storable-plugin
|
||||
, effectful
|
||||
, effectful-core
|
||||
, extra
|
||||
|
|
|
|||
|
|
@ -2,4 +2,4 @@ module Main where
|
|||
|
||||
import Executables.RPG
|
||||
|
||||
main = runGame
|
||||
main = main'
|
||||
|
|
|
|||
|
|
@ -5,11 +5,11 @@ 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 System.Renderer
|
||||
import World
|
||||
|
||||
getCamera
|
||||
|
|
@ -36,9 +36,9 @@ getCamera eff (dimX, dimY) = do
|
|||
|
||||
playerMovement
|
||||
:: forall w es
|
||||
. ( Raylib :> es
|
||||
, AE.ECS w :> es
|
||||
. ( AE.ECS w :> es
|
||||
, AE.Get w VelocityComponent
|
||||
, Renderer :> es
|
||||
)
|
||||
=> AE.Entity
|
||||
-> ( RL.KeyboardKey
|
||||
|
|
|
|||
|
|
@ -108,11 +108,11 @@ drawRectangle posX posY width height color = send (DrawRectangle posX posY width
|
|||
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 :: (IOE :> es) => Int -> Int -> Text -> Eff (Raylib : es) a -> Eff es a
|
||||
runRaylibWindow width height name effect = do
|
||||
window <- liftIO $ RL.initWindow width height (T.unpack name)
|
||||
|
||||
interpret' effect $ \env eff -> localSeqUnlift env \unlift ->
|
||||
res <- interpret' effect $ \env eff -> localSeqUnlift env \unlift ->
|
||||
case eff of
|
||||
WindowShouldClose -> liftIO RL.windowShouldClose
|
||||
GetFontDefault -> liftIO RL.getFontDefault
|
||||
|
|
@ -129,6 +129,7 @@ runRaylibWindow width height name effect = do
|
|||
GetFPS -> liftIO RL.getFPS
|
||||
|
||||
liftIO $ RL.closeWindow window
|
||||
pure res
|
||||
where
|
||||
runRaylibDrawing :: (IOE :> es) => Eff (RaylibDraw : es) a -> Eff es a
|
||||
runRaylibDrawing effect' = do
|
||||
|
|
|
|||
|
|
@ -3,7 +3,7 @@
|
|||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
|
||||
module Engine (Engine (..), engineInput, enginePhysics, engineRendering, initialEngine, EngineConstraint, startEngine) where
|
||||
module Engine (Game (..), EngineConstraint, startEngine) where
|
||||
|
||||
import Apecs.Effectful qualified as AE
|
||||
import Data.Kind
|
||||
|
|
@ -12,33 +12,32 @@ import Effectful.Accessor
|
|||
import Effectful.Dispatch.Dynamic
|
||||
import Effectful.Dispatch.Static
|
||||
import Effectful.Internal.Monad
|
||||
import Effectful.Raylib
|
||||
import Effectful.Raylib hiding (drawLine)
|
||||
import GHC.Exts
|
||||
import Linear.V2
|
||||
import Raylib.Types qualified as RL
|
||||
import Raylib.Util.Colors qualified as RL
|
||||
import System.Physics
|
||||
import System.Renderer
|
||||
import World
|
||||
|
||||
data EngineOps es = EngineOps
|
||||
{ input :: Eff es ()
|
||||
, physics :: Eff es ()
|
||||
, rendering :: Eff es ()
|
||||
}
|
||||
data Game :: Effect where
|
||||
GameInput :: Game (Eff es) ()
|
||||
GamePhysics :: Game (Eff es) ()
|
||||
GameRendering :: (SharedSuffix es2 es, RaylibDraw :> es2, RaylibDraw2D :> es2) => (forall r. Eff es2 r -> Eff es r) -> Game (Eff es) ()
|
||||
type instance DispatchOf Game = Dynamic
|
||||
|
||||
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
|
||||
data Engine :: Effect
|
||||
type instance DispatchOf Engine = Static WithSideEffects
|
||||
|
||||
engineInput :: (HasCallStack, Engine :> es) => Eff es ()
|
||||
engineInput = send EngineInput
|
||||
gameInput :: (HasCallStack, Game :> es) => Eff es ()
|
||||
gameInput = send GameInput
|
||||
|
||||
enginePhysics :: (HasCallStack, Engine :> es) => Eff es ()
|
||||
enginePhysics = send EnginePhysics
|
||||
gamePhysics :: (HasCallStack, Game :> es) => Eff es ()
|
||||
gamePhysics = send GamePhysics
|
||||
|
||||
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)
|
||||
gameRendering :: forall es. (HasCallStack, Game :> es, SharedSuffix es es, RaylibDraw :> es, RaylibDraw2D :> es) => Eff es ()
|
||||
gameRendering = unsafeEff $ \env -> (`unEff` env) $ localSeqUnlift @_ @es (LocalEnv env) (\unlift -> send $ GameRendering unlift)
|
||||
|
||||
class EngineConstraints where
|
||||
type EngineConstraint (camera :: Symbol) (backgroundColor :: Symbol) (es :: [Effect]) (w :: Type) :: Constraint
|
||||
|
|
@ -55,41 +54,10 @@ instance EngineConstraints where
|
|||
, Reads camera RL.Camera2D :> es
|
||||
, Reads backgroundColor RL.Color :> es
|
||||
, IOE :> es
|
||||
, Raylib :> es
|
||||
, Renderer :> 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)
|
||||
|
|
@ -97,29 +65,37 @@ startEngine
|
|||
(w :: Type)
|
||||
es
|
||||
. ( EngineConstraint camera backgroundColor es w
|
||||
, Engine :> es
|
||||
, Game :> es
|
||||
)
|
||||
=> Eff es ()
|
||||
startEngine = do
|
||||
engineInput
|
||||
gameInput
|
||||
applyVelocity'' @w
|
||||
|
||||
-- collisionAABB @w
|
||||
-- resolveAABB @w
|
||||
|
||||
enginePhysics
|
||||
gamePhysics
|
||||
|
||||
c <- readVal @camera @RL.Camera2D
|
||||
|
||||
runDraw . runDraw2D c $ do
|
||||
color <- readVal @backgroundColor @RL.Color
|
||||
clearBackground color
|
||||
|
||||
getFPS >>= unsafeEff_ . print
|
||||
beginFrame c color
|
||||
|
||||
-- getFPS >>= unsafeEff_ . print
|
||||
|
||||
AE.cmapM_ @w @(PositionComponent, BoxComponent)
|
||||
drawSprite
|
||||
-- AE.cmapM_
|
||||
-- @w
|
||||
-- @PositionComponent
|
||||
-- \(Position (V2 x y)) ->
|
||||
-- drawLine (V2 (x - 0.1) (y - 0.1)) (V2 (x + 0.1) (y + 0.1)) RL.red
|
||||
-- >> drawLine (V2 (x + 0.1) (y - 0.1)) (V2 (x - 0.1) (y + 0.1)) RL.red
|
||||
|
||||
endFrame
|
||||
|
||||
render @w
|
||||
-- renderOrigins @w
|
||||
-- renderBoundingBoxes @w
|
||||
-- renderCollision @w
|
||||
|
||||
engineRendering
|
||||
-- gameRendering
|
||||
|
|
|
|||
|
|
@ -13,8 +13,8 @@ import Data.Maybe (isJust)
|
|||
import Effectful
|
||||
import Effectful.Accessor
|
||||
import Effectful.Dispatch.Dynamic
|
||||
import Effectful.Raylib
|
||||
import Effectful.Raylib qualified as RL
|
||||
import Effectful.Raylib hiding (windowShouldClose)
|
||||
import Effectful.Raylib qualified as RL hiding (windowShouldClose)
|
||||
import Effectful.Reader.Static
|
||||
import Effectful.State.Static.Local
|
||||
import Effectful.State.Static.Local.Lens
|
||||
|
|
@ -24,6 +24,7 @@ import Linear.V2 (V2 (..), _x, _y)
|
|||
import Raylib.Types qualified as RL
|
||||
import Raylib.Util.Colors qualified as RL
|
||||
import System.Physics
|
||||
import System.Renderer
|
||||
import World
|
||||
|
||||
data GameState = GameState
|
||||
|
|
@ -115,50 +116,51 @@ readsCamera = do
|
|||
(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 ->
|
||||
runGame :: forall es. (IOE :> es, AE.ECS World :> es, State GameState :> es, Renderer :> es) => Eff (Game : es) () -> Eff es ()
|
||||
runGame = interpret \env eff ->
|
||||
case eff of
|
||||
EngineInput -> do
|
||||
GameInput -> do
|
||||
camera <- readsCamera
|
||||
pos <- getMousePosition >>= \pos -> getScreenToWorld2D pos camera
|
||||
pure ()
|
||||
-- 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 ()
|
||||
-- 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
|
||||
-- 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)
|
||||
-- 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)
|
||||
|
||||
AE.set @World minkowski' (mpos, maabb)
|
||||
AE.set @World box' (Velocity $ V2 (offset ^. _x) (offset ^. _y))
|
||||
Nothing -> pure ()
|
||||
EnginePhysics -> pure ()
|
||||
EngineRendering unlift' -> do
|
||||
-- AE.set @World minkowski' (mpos, maabb)
|
||||
-- AE.set @World box' (Velocity $ V2 (offset ^. _x) (offset ^. _y))
|
||||
-- Nothing -> pure ()
|
||||
GamePhysics -> pure ()
|
||||
GameRendering unlift' -> do
|
||||
(box1, box2) <- gets @GameState \s -> s.boxes
|
||||
box1Position <- AE.get @World @PositionComponent box1
|
||||
(box2Position, box2AABB) <- AE.get @World @(PositionComponent, AABBComponent) box2
|
||||
|
|
@ -181,10 +183,12 @@ runEngine = interpret \env eff ->
|
|||
pure ()
|
||||
|
||||
initialize
|
||||
:: (Raylib :> es)
|
||||
:: (Renderer :> es)
|
||||
=> Eff es ()
|
||||
initialize = do
|
||||
setTargetFPS 60
|
||||
pure ()
|
||||
|
||||
-- setTargetFPS 60
|
||||
|
||||
main' :: IO ()
|
||||
main' = do
|
||||
|
|
@ -193,8 +197,8 @@ main' = do
|
|||
. runGameState
|
||||
. runGameConfig
|
||||
$ gets @GameState (\s -> (s ^. windowDimensions . _x, s ^. windowDimensions . _y)) >>= \(dimX, dimY) ->
|
||||
runRaylibWindow dimX dimY "App"
|
||||
. runEngine
|
||||
runRaylibRenderer dimX dimY "App"
|
||||
. runGame
|
||||
$ initialize >> whileM do
|
||||
engineEnv $ startEngine @"state.camera" @"config.backgroundColor" @World
|
||||
not <$> windowShouldClose
|
||||
|
|
|
|||
|
|
@ -9,7 +9,7 @@ import Control.Monad.Extra
|
|||
import Data.Text qualified as T
|
||||
import Effectful
|
||||
import Effectful.Dispatch.Static
|
||||
import Effectful.Raylib
|
||||
import Effectful.Raylib hiding (isKeyDown, windowShouldClose)
|
||||
import Effectful.Reader.Static
|
||||
import Effectful.State.Static.Local
|
||||
import Effectful.State.Static.Local.Lens
|
||||
|
|
@ -65,7 +65,7 @@ makeLensesFor
|
|||
|
||||
playerMovement
|
||||
:: forall w es
|
||||
. ( Raylib :> es
|
||||
. ( Renderer :> es
|
||||
, AE.Get w PositionComponent
|
||||
, AE.Set w VelocityComponent
|
||||
, AE.ECS w :> es
|
||||
|
|
@ -111,14 +111,14 @@ ballRespawn goal1 goal2 ball = do
|
|||
ret
|
||||
|
||||
initialise
|
||||
:: ( Raylib :> es
|
||||
:: ( Renderer :> es
|
||||
, State GameState :> es
|
||||
, Reader GameConfig :> es
|
||||
, AE.ECS World :> es
|
||||
)
|
||||
=> Eff es ()
|
||||
initialise = do
|
||||
setTargetFPS 60
|
||||
-- setTargetFPS 60
|
||||
playArea <- asks @GameConfig (\s -> s.playArea)
|
||||
|
||||
cameraEntity <-
|
||||
|
|
@ -202,14 +202,14 @@ initialise = do
|
|||
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
|
||||
)
|
||||
separator .= separatorEntity
|
||||
-- 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
|
||||
-- )
|
||||
-- separator .= separatorEntity
|
||||
|
||||
pure ()
|
||||
|
||||
|
|
@ -235,7 +235,7 @@ pongGame = do
|
|||
{ playArea = 20
|
||||
}
|
||||
-- RL.setTraceLogLevel RL.LogWarning
|
||||
runEff . AE.runECS initWorld . evalState gameState . runReader gameConfig . runRaylibWindow gameState.dimX gameState.dimY "App" $
|
||||
runEff . AE.runECS initWorld . evalState gameState . runReader gameConfig . runRaylibRenderer gameState.dimX gameState.dimY "App" $
|
||||
initialise >> whileM do
|
||||
playerMovement @World
|
||||
(RL.KeyW, -0.2)
|
||||
|
|
@ -267,18 +267,18 @@ pongGame = do
|
|||
-- 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'}
|
||||
-- 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
|
||||
getFPS >>= unsafeEff_ . print
|
||||
runDraw . runDraw2D camera $ do
|
||||
clearBackground RL.gray
|
||||
-- getFPS >>= unsafeEff_ . print
|
||||
beginFrame camera RL.white
|
||||
AE.cmapM_ @World @(PositionComponent, BoxComponent) drawSprite
|
||||
|
||||
-- (gets @GameState (\s -> s.score)) >>= liftIO . print
|
||||
|
||||
render @World
|
||||
renderOrigins @World
|
||||
renderBoundingBoxes @World
|
||||
-- render @World
|
||||
-- renderOrigins @World
|
||||
-- renderBoundingBoxes @World
|
||||
not <$> windowShouldClose
|
||||
|
|
|
|||
|
|
@ -14,7 +14,7 @@
|
|||
{-# LANGUAGE UndecidableInstances #-}
|
||||
|
||||
module Executables.RPG (
|
||||
runGame,
|
||||
main',
|
||||
) where
|
||||
|
||||
import Apecs.Effectful qualified as AE
|
||||
|
|
@ -30,7 +30,7 @@ import Effectful
|
|||
import Effectful.Accessor
|
||||
import Effectful.Dispatch.Dynamic
|
||||
import Effectful.Dispatch.Static
|
||||
import Effectful.Raylib
|
||||
import Effectful.Raylib hiding (isKeyDown, windowShouldClose)
|
||||
import Effectful.Reader.Dynamic
|
||||
import Effectful.State.Static.Local
|
||||
import Effectful.State.Static.Local.Lens
|
||||
|
|
@ -38,9 +38,9 @@ import Engine
|
|||
import GHC.Float (float2Int, floorFloat)
|
||||
import Linear.V2
|
||||
import Noise.Perlin
|
||||
import Raylib.Core qualified as RL
|
||||
import Raylib.Types qualified as RL
|
||||
import Raylib.Util.Colors qualified as RL
|
||||
import System.Renderer
|
||||
import World
|
||||
|
||||
type LocalWorld = World
|
||||
|
|
@ -83,7 +83,7 @@ spawnPlayer color =
|
|||
)
|
||||
|
||||
spawnBox
|
||||
:: (AE.ECS LocalWorld :> es, Raylib :> es)
|
||||
:: (AE.ECS LocalWorld :> es)
|
||||
=> (Float, Float)
|
||||
-> RL.Color
|
||||
-> (Float, Float)
|
||||
|
|
@ -96,18 +96,17 @@ spawnBox (posx, posy) color size = do
|
|||
, Body 0.0 0.0 True
|
||||
, AABB (V2 1 1) (V2 0 0)
|
||||
)
|
||||
font <- getFontDefault
|
||||
AE.set @LocalWorld entity (TextBox font (T.pack $ show (AE.unEntity entity)) 0.3 0.1 RL.yellow)
|
||||
-- font <- getFontDefault
|
||||
-- AE.set @LocalWorld entity (TextBox font (T.pack $ show (AE.unEntity entity)) 0.3 0.1 RL.yellow)
|
||||
pure entity
|
||||
|
||||
initialise
|
||||
:: ( Raylib :> es
|
||||
, State GameState :> es
|
||||
:: ( State GameState :> es
|
||||
, AE.ECS LocalWorld :> es
|
||||
)
|
||||
=> Eff es ()
|
||||
initialise = do
|
||||
setTargetFPS 60
|
||||
-- setTargetFPS 60
|
||||
|
||||
forM_ [-32 .. 32] \x -> do
|
||||
forM_ [-32 .. 32] \y -> do
|
||||
|
|
@ -152,17 +151,17 @@ initialise = do
|
|||
|
||||
pure ()
|
||||
|
||||
runEngine
|
||||
runGame
|
||||
:: forall es
|
||||
. ( AE.ECS LocalWorld :> es
|
||||
, Raylib :> es
|
||||
, Renderer :> es
|
||||
, State GameState :> es
|
||||
)
|
||||
=> Eff (Engine : es) ()
|
||||
=> Eff (Game : es) ()
|
||||
-> Eff es ()
|
||||
runEngine = interpret \_ eff ->
|
||||
runGame = interpret \_ eff ->
|
||||
case eff of
|
||||
EngineInput -> do
|
||||
GameInput -> do
|
||||
playerEntity <- gets @GameState (\s -> s.playerEntity)
|
||||
-- AE.modify @LocalWorld @(Maybe (TagComponent Int)) @(TagComponent Int) playerEntity \case
|
||||
-- Just (Tag n) -> Tag (n + 1)
|
||||
|
|
@ -182,15 +181,15 @@ runEngine = interpret \_ eff ->
|
|||
isKeyDown RL.KeyKpAdd >>= flip when (AE.modify @LocalWorld @CameraComponent @CameraComponent cameraEntity (\c -> c{zoom = c.zoom + 1}))
|
||||
isKeyDown RL.KeyKpSubtract >>= flip when (AE.modify @LocalWorld @CameraComponent @CameraComponent cameraEntity (\c -> c{zoom = c.zoom - 1}))
|
||||
pure ()
|
||||
EnginePhysics -> pure ()
|
||||
EngineRendering _ -> do
|
||||
GamePhysics -> pure ()
|
||||
GameRendering _ -> do
|
||||
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
|
||||
main' :: IO ()
|
||||
main' = do
|
||||
let gameConfig =
|
||||
GameConfig
|
||||
{
|
||||
|
|
@ -207,17 +206,17 @@ runGame = do
|
|||
|
||||
print $ perlin 0 0
|
||||
|
||||
RL.setTraceLogLevel RL.LogWarning
|
||||
-- RL.setTraceLogLevel RL.LogWarning
|
||||
runEff
|
||||
. AE.runECS initWorld
|
||||
. evalState gameState
|
||||
. runReader gameConfig
|
||||
. runRaylibWindow gameState.dimX gameState.dimY "App"
|
||||
. runRaylibRenderer gameState.dimX gameState.dimY "App"
|
||||
. runReads @"config.camera" @RL.Camera2D do
|
||||
dims <- gets @GameState (\s -> (s.dimX, s.dimY))
|
||||
getCamera @LocalWorld (gets @GameState (\s -> s.cameraEntity)) dims
|
||||
. runReads @"config.backgroundColor" @RL.Color (pure RL.white)
|
||||
. runEngine
|
||||
. runGame
|
||||
$ initialise >> whileM do
|
||||
startEngine @"config.camera" @"config.backgroundColor" @LocalWorld
|
||||
not <$> windowShouldClose
|
||||
|
|
|
|||
|
|
@ -1,84 +1,178 @@
|
|||
{-# LANGUAGE AllowAmbiguousTypes #-}
|
||||
{-# LANGUAGE CApiFFI #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DeriveAnyClass #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# OPTIONS_GHC -fplugin-opt=Foreign.Storable.Generic.Plugin:-v1 #-}
|
||||
{-# OPTIONS_GHC -fplugin=Foreign.Storable.Generic.Plugin #-}
|
||||
|
||||
module System.Renderer (render, renderOrigins, renderBoundingBoxes, renderCollision) where
|
||||
module System.Renderer (Renderer (..), runRaylibRenderer, beginFrame, drawSprite, drawLine, isKeyDown, windowShouldClose, endFrame) where
|
||||
|
||||
import Apecs.Effectful qualified as AE
|
||||
import Control.Lens
|
||||
import Control.Monad
|
||||
import Control.Monad.Primitive (PrimState)
|
||||
import Data.IORef
|
||||
import Data.Text (Text)
|
||||
import Data.Vector.Storable qualified as VS hiding (unsafeToForeignPtr)
|
||||
import Data.Vector.Storable.Mutable qualified as VS
|
||||
import Effectful
|
||||
import Effectful.Raylib
|
||||
import Effectful.Dispatch.Dynamic
|
||||
import Effectful.Raylib hiding (drawLine, isKeyDown, windowShouldClose)
|
||||
import Effectful.State.Static.Local
|
||||
import Foreign (Storable, withForeignPtr)
|
||||
import Foreign.C.Types
|
||||
import Foreign.Ptr
|
||||
import Foreign.Storable.Generic
|
||||
import GHC.Generics (Generic)
|
||||
import Linear.V2 (V2 (..), _x, _y)
|
||||
import Raylib.Core qualified as RL
|
||||
import Raylib.Core.Shapes qualified as RL
|
||||
import Raylib.Types qualified as RL
|
||||
import Raylib.Util.Colors qualified as RL
|
||||
import World
|
||||
|
||||
render
|
||||
:: forall w es
|
||||
. ( AE.Get w PositionComponent
|
||||
, AE.Get w BoxComponent
|
||||
, AE.Get w TextBoxComponent
|
||||
, AE.ECS w :> es
|
||||
, RaylibDraw2D :> es
|
||||
)
|
||||
=> Eff es ()
|
||||
render = do
|
||||
AE.cmapM_ @w @(PositionComponent, BoxComponent)
|
||||
\(Position (V2 x y), Box color offset (dx, dy)) ->
|
||||
drawRectangle (x + fst offset - dx / 2) (y + snd offset - dy / 2) dx dy color
|
||||
AE.cmapM_ @w @(PositionComponent, TextBoxComponent)
|
||||
\(Position position, TextBox font text fontSize spacing color) -> do
|
||||
-- size <- measureText font text fontSize spacing
|
||||
-- let size = V2 0 0
|
||||
-- drawText font text (V2 (position ^. _x - size ^. _y / 2) (position ^. _y - size ^. _y / 2)) fontSize spacing color
|
||||
pure ()
|
||||
data Renderer :: Effect where
|
||||
BeginFrame :: RL.Camera2D -> RL.Color -> Renderer (Eff es) ()
|
||||
DrawSprite :: (PositionComponent, BoxComponent) -> Renderer (Eff es) ()
|
||||
DrawLine :: V2 Float -> V2 Float -> RL.Color -> Renderer (Eff es) ()
|
||||
WindowShouldClose :: Renderer (Eff es) Bool
|
||||
IsKeyDown :: RL.KeyboardKey -> Renderer (Eff es) Bool
|
||||
EndFrame :: Renderer (Eff es) ()
|
||||
type instance DispatchOf Renderer = Dynamic
|
||||
|
||||
renderCollision
|
||||
:: forall w es
|
||||
. ( AE.Get w PositionComponent
|
||||
, AE.Get w CollisionComponent
|
||||
, AE.Get w BoxComponent
|
||||
, AE.ECS w :> es
|
||||
, RaylibDraw2D :> es
|
||||
)
|
||||
=> Eff es ()
|
||||
renderCollision =
|
||||
AE.cmapM_ @w @(PositionComponent, CollisionComponent, BoxComponent)
|
||||
\(Position (V2 x y), Collision colliders, _) ->
|
||||
forM_
|
||||
colliders
|
||||
( \(Collider _ (V2 overlapX overlapY) (V2 offsetX offsetY) _) -> do
|
||||
drawLine x y (x + offsetX) (y + offsetY) RL.green
|
||||
drawLine (x + offsetX / 2) (y + offsetY / 2) (x + offsetX / 2 + overlapX / 2) (y + offsetY / 2 + overlapY / 2) RL.yellow
|
||||
drawLine (x + offsetX / 2) (y + offsetY / 2) (x + offsetX / 2 - overlapX / 2) (y + offsetY / 2 - overlapY / 2) RL.orange
|
||||
)
|
||||
beginFrame :: (HasCallStack, Renderer :> es) => RL.Camera2D -> RL.Color -> Eff es ()
|
||||
beginFrame camera color = send (BeginFrame camera color)
|
||||
|
||||
renderOrigins
|
||||
:: forall w es
|
||||
. ( AE.Get w PositionComponent
|
||||
, AE.ECS w :> es
|
||||
, RaylibDraw2D :> es
|
||||
)
|
||||
=> Eff es ()
|
||||
renderOrigins = do
|
||||
AE.cmapM_ @w @PositionComponent
|
||||
\(Position (V2 x y)) ->
|
||||
drawLine (x - 0.1) (y - 0.1) (x + 0.1) (y + 0.1) RL.red
|
||||
>> drawLine (x + 0.1) (y - 0.1) (x - 0.1) (y + 0.1) RL.red
|
||||
drawSprite :: (HasCallStack, Renderer :> es) => (PositionComponent, BoxComponent) -> Eff es ()
|
||||
drawSprite d = send (DrawSprite d)
|
||||
|
||||
renderBoundingBoxes
|
||||
:: forall w es
|
||||
. ( AE.Get w PositionComponent
|
||||
, AE.Get w AABBComponent
|
||||
, RaylibDraw2D :> es
|
||||
, AE.ECS w :> es
|
||||
drawLine :: (HasCallStack, Renderer :> es) => V2 Float -> V2 Float -> RL.Color -> Eff es ()
|
||||
drawLine start end color = send (DrawLine start end color)
|
||||
|
||||
windowShouldClose :: (HasCallStack, Renderer :> es) => Eff es Bool
|
||||
windowShouldClose = send WindowShouldClose
|
||||
|
||||
isKeyDown :: (HasCallStack, Renderer :> es) => RL.KeyboardKey -> Eff es Bool
|
||||
isKeyDown key = send (IsKeyDown key)
|
||||
|
||||
endFrame :: (HasCallStack, Renderer :> es) => Eff es ()
|
||||
endFrame = send EndFrame
|
||||
|
||||
data RectangleInfo = RectangleInfo {position :: V2 Float, size :: V2 Float, color :: RL.Color}
|
||||
deriving (Generic, GStorable)
|
||||
|
||||
foreign import capi safe "raylib_batch.h" draw_rectangles_batch :: Ptr RectangleInfo -> CSize -> IO ()
|
||||
|
||||
runRaylibRenderer :: (IOE :> es) => Int -> Int -> Text -> Eff (Renderer : es) a -> Eff es a
|
||||
runRaylibRenderer dimX dimY title go = do
|
||||
vectorRef <- liftIO $ VS.new @_ @RectangleInfo 4279 >>= newIORef
|
||||
indexRef <-
|
||||
liftIO $
|
||||
newIORef
|
||||
(0 :: Int)
|
||||
reinterpret
|
||||
(runRaylibWindow dimX dimY title)
|
||||
( \_ -> \case
|
||||
BeginFrame camera color -> do
|
||||
liftIO $ RL.getFPS >>= liftIO . print
|
||||
liftIO $ writeIORef indexRef 0
|
||||
liftIO $ RL.beginDrawing
|
||||
liftIO $ RL.clearBackground color
|
||||
liftIO $ RL.beginMode2D camera
|
||||
DrawSprite (Position position, Box{color, offset, size}) -> do
|
||||
vector <- liftIO $ readIORef vectorRef
|
||||
index <- liftIO $ readIORef indexRef
|
||||
liftIO $ VS.write vector index (RectangleInfo position (V2 (size ^. _1) (size ^. _2)) color)
|
||||
liftIO $ writeIORef indexRef (index + 1)
|
||||
where
|
||||
-- liftIO $ RL.drawRectangleV rlPosition rlSize color
|
||||
|
||||
rlPosition = RL.Vector2 (position ^. _x + fst offset - (size ^. _1) / 2) (position ^. _y + snd offset - size ^. _2 / 2)
|
||||
rlSize = RL.Vector2 (size ^. _1) (size ^. _2)
|
||||
DrawLine start end color ->
|
||||
liftIO $ RL.drawLineV (RL.Vector2 (start ^. _x) (start ^. _y)) (RL.Vector2 (end ^. _x) (end ^. _y)) color
|
||||
WindowShouldClose -> liftIO RL.windowShouldClose
|
||||
IsKeyDown key -> liftIO $ RL.isKeyDown key
|
||||
EndFrame -> do
|
||||
vector <- liftIO $ readIORef vectorRef
|
||||
index <- liftIO $ readIORef indexRef
|
||||
let (fptr, offset, length) = (VS.unsafeToForeignPtr vector)
|
||||
liftIO $ withForeignPtr fptr \ptr -> draw_rectangles_batch (plusPtr ptr offset) (fromIntegral length)
|
||||
liftIO RL.endMode2D
|
||||
liftIO RL.endDrawing
|
||||
)
|
||||
=> Eff es ()
|
||||
renderBoundingBoxes =
|
||||
AE.cmapM_ @w @(PositionComponent, AABBComponent)
|
||||
\(pos, aabb) -> do
|
||||
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
|
||||
go
|
||||
|
||||
-- render
|
||||
-- :: forall w es
|
||||
-- . ( AE.Get w PositionComponent
|
||||
-- , AE.Get w BoxComponent
|
||||
-- , AE.Get w TextBoxComponent
|
||||
-- , AE.ECS w :> es
|
||||
-- , RaylibDraw2D :> es
|
||||
-- )
|
||||
-- => Eff es ()
|
||||
-- render = do
|
||||
-- AE.cmapM_ @w @(PositionComponent, BoxComponent)
|
||||
-- \(Position (V2 x y), Box color offset (dx, dy)) ->
|
||||
-- drawRectangle (x + fst offset - dx / 2) (y + snd offset - dy / 2) dx dy color
|
||||
-- AE.cmapM_ @w @(PositionComponent, TextBoxComponent)
|
||||
-- \(Position position, TextBox font text fontSize spacing color) -> do
|
||||
-- -- size <- measureText font text fontSize spacing
|
||||
-- -- let size = V2 0 0
|
||||
-- -- drawText font text (V2 (position ^. _x - size ^. _y / 2) (position ^. _y - size ^. _y / 2)) fontSize spacing color
|
||||
-- pure ()
|
||||
|
||||
-- renderCollision
|
||||
-- :: forall w es
|
||||
-- . ( AE.Get w PositionComponent
|
||||
-- , AE.Get w CollisionComponent
|
||||
-- , AE.Get w BoxComponent
|
||||
-- , AE.ECS w :> es
|
||||
-- , RaylibDraw2D :> es
|
||||
-- )
|
||||
-- => Eff es ()
|
||||
-- renderCollision =
|
||||
-- AE.cmapM_ @w @(PositionComponent, CollisionComponent, BoxComponent)
|
||||
-- \(Position (V2 x y), Collision colliders, _) ->
|
||||
-- forM_
|
||||
-- colliders
|
||||
-- ( \(Collider _ (V2 overlapX overlapY) (V2 offsetX offsetY) _) -> do
|
||||
-- drawLine x y (x + offsetX) (y + offsetY) RL.green
|
||||
-- drawLine (x + offsetX / 2) (y + offsetY / 2) (x + offsetX / 2 + overlapX / 2) (y + offsetY / 2 + overlapY / 2) RL.yellow
|
||||
-- drawLine (x + offsetX / 2) (y + offsetY / 2) (x + offsetX / 2 - overlapX / 2) (y + offsetY / 2 - overlapY / 2) RL.orange
|
||||
-- )
|
||||
|
||||
-- renderOrigins
|
||||
-- :: forall w es
|
||||
-- . ( AE.Get w PositionComponent
|
||||
-- , AE.ECS w :> es
|
||||
-- , RaylibDraw2D :> es
|
||||
-- )
|
||||
-- => Eff es ()
|
||||
-- renderOrigins = do
|
||||
-- AE.cmapM_ @w @PositionComponent
|
||||
-- \(Position (V2 x y)) ->
|
||||
-- drawLine (x - 0.1) (y - 0.1) (x + 0.1) (y + 0.1) RL.red
|
||||
-- >> drawLine (x + 0.1) (y - 0.1) (x - 0.1) (y + 0.1) RL.red
|
||||
|
||||
-- renderBoundingBoxes
|
||||
-- :: forall w es
|
||||
-- . ( AE.Get w PositionComponent
|
||||
-- , AE.Get w AABBComponent
|
||||
-- , RaylibDraw2D :> es
|
||||
-- , AE.ECS w :> es
|
||||
-- )
|
||||
-- => Eff es ()
|
||||
-- renderBoundingBoxes =
|
||||
-- AE.cmapM_ @w @(PositionComponent, AABBComponent)
|
||||
-- \(pos, aabb) -> do
|
||||
-- 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
|
||||
|
|
|
|||
|
|
@ -48,6 +48,7 @@ extra-deps:
|
|||
- lens-5.2.2@sha256:e01d5732173645b80f23a189a0f7e1f5cd0b2286de0ce20baf941cbf5c3b8435,15158
|
||||
- effectful-2.2.2.0@sha256:1d5682727c2d5ebd83f7a7ae0ef809369422ccd37d4157ae7e2084f2a1cf6cfd,6044
|
||||
- effectful-core-2.2.2.2@sha256:ebbf61f024a08c7bb5e569b1c6856c0ca92687d6a5ff01d24d28567948c402fc,3477
|
||||
- derive-storable-plugin-0.2.3.7@sha256:f82b5cc67d7affbb41040d3a5812e6a587894e232e7a5d5ccb33103836e51fa6,2868
|
||||
|
||||
# Override default flag values for local packages and extra-deps
|
||||
flags:
|
||||
|
|
|
|||
|
|
@ -47,6 +47,13 @@ packages:
|
|||
size: 1918
|
||||
original:
|
||||
hackage: effectful-core-2.2.2.2@sha256:ebbf61f024a08c7bb5e569b1c6856c0ca92687d6a5ff01d24d28567948c402fc,3477
|
||||
- completed:
|
||||
hackage: derive-storable-plugin-0.2.3.7@sha256:f82b5cc67d7affbb41040d3a5812e6a587894e232e7a5d5ccb33103836e51fa6,2868
|
||||
pantry-tree:
|
||||
sha256: b11fd39df181394cc3cb37d4cc43149ef776ab2c079413c84ad59f3904ff557f
|
||||
size: 1411
|
||||
original:
|
||||
hackage: derive-storable-plugin-0.2.3.7@sha256:f82b5cc67d7affbb41040d3a5812e6a587894e232e7a5d5ccb33103836e51fa6,2868
|
||||
snapshots:
|
||||
- completed:
|
||||
sha256: 93137bc0122de394fa2c43e933971b2996cd7dc600989b721ad971810b9a2f3f
|
||||
|
|
|
|||
Loading…
Reference in a new issue