magic_rb/haskell-games
1
0
Fork 0
mirror of https://git.sr.ht/~magic_rb/haskell-games synced 2024-11-21 15:24:22 +01:00
Code Issues Packages Projects Releases Wiki Activity

105 fps +-

Browse source 
Signed-off-by: magic_rb <richard@brezak.sk>
This commit is contained in:
magic_rb 2024-01-26 20:17:53 +01:00
parent 885bf8943b
commit 2972b5b048
No known key found for this signature in database
GPG key ID: 08D5287CC5DDCA0E
15 changed files with 343 additions and 225 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

1
flake.nix
View file

@ -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
View 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
View 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);

4
rpg/package.yaml
View file

@ -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:

14
rpg/rpg.cabal
View file

@ -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
rpg/rpg/Main.hs
View file

@ -2,4 +2,4 @@ module Main where
import Executables.RPG
main = runGame
main = main'

6
rpg/src/Common.hs
View file

@ -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

5
rpg/src/Effectful/Raylib.hs
View file

@ -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

100
rpg/src/Engine.hs
View file

@ -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
color <- readVal @backgroundColor @RL.Color
runDraw . runDraw2D c $ do
color <- readVal @backgroundColor @RL.Color
clearBackground color
beginFrame c color
getFPS >>= unsafeEff_ . print
-- getFPS >>= unsafeEff_ . print
render @w
-- renderOrigins @w
-- renderBoundingBoxes @w
-- renderCollision @w
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
engineRendering
endFrame
-- renderBoundingBoxes @w
-- renderCollision @w
-- gameRendering

92
rpg/src/Executables/Minkowski.hs
View file

@ -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

44
rpg/src/Executables/Pong.hs
View file

@ -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
-- (gets @GameState (\s -> s.score)) >>= liftIO . print
render @World
renderOrigins @World
renderBoundingBoxes @World
-- render @World
-- renderOrigins @World
-- renderBoundingBoxes @World
not <$> windowShouldClose

41
rpg/src/Executables/RPG.hs
View file

@ -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

234
rpg/src/System/Renderer.hs
View file

@ -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
)
=> 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
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
)
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

1
stack.yaml
View file

@ -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:

7
stack.yaml.lock
View file

@ -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