diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,12 @@ +## [0.2.0] +- Update to Brillo 3.0.0 +- Rename `play` to `playWithApecs` +- Rename `foldDraw` to `cfoldDraw` +- Rename `foldDrawM` to `cfoldDrawM` +- Remove `Apecs.Brillo.Physics` entirely + ## [0.1.1] -Brillo update patch +- Brillo update patch ## [0.1.0] -IDK, made this +- IDK, made this diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,3 +1,67 @@ # apecs-brillo -Apecs' gloss package, but adapted for brillo +The camera is already handled, you only have to pass in your own drawing, stepping and key handling functions. Check the `Apecs.Brillo` documentation to see the type signatures. + +```hs +module Example where + +import Apecs qualified +import Brillo qualified +import Apecs.Brillo qualified as Brillo +import System.Exit (exitSuccess) +import Control.Monad (void) +import Linear + +newtype Position = Position (V2 Float) + deriving Show + +instance Apecs.Component Position where + type Storage Position = Apecs.Map Position + +newtype Velocity = Velocity (V2 Float) + deriving Show + +instance Apecs.Component Velocity where + type Storage Velocity = Apecs.Map Velocity + +Apecs.makeWorld "World" + [ ''Brillo.Camera + , ''Position + , ''Velocity + ] + +main :: IO () +main = do + world <- initWorld + Apecs.runWith world do + initialise + Brillo.playWithApecs (Brillo.InWindow "Example" (800, 600) (10, 10)) Brillo.black 60 draw handleEvent step + +initialise :: Apecs.System World () +initialise = void do + Apecs.newEntity (Position 0, Velocity (V2 12 (-16))) + Apecs.newEntity (Position (V2 24 0), Velocity (V2 (-48) 8)) + Apecs.newEntity (Position (V2 48 24), Velocity (V2 32 16)) + +step :: Float -> Apecs.System World () +step dT = do + velocity dT + gravity dT + +velocity :: Float -> Apecs.System World () +velocity dT = Apecs.cmap \(Position pos, Velocity vel) -> Position $ pos + vel ^* dT + +gravity :: Float -> Apecs.System World () +gravity dT = Apecs.cmap \(Velocity vel) -> Position $ vel + gravityVel ^* dT + where gravityVel = V2 0 (-1) + +handleEvent :: Brillo.Event -> Apecs.System World () +handleEvent = \case + Brillo.EventKey (Brillo.SpecialKey Brillo.KeyEsc) Brillo.Down _ _ -> Apecs.liftIO exitSuccess + _ -> pure () + +draw :: Apecs.System World Brillo.Picture +draw = do + drawnEntities <- Brillo.cfoldDraw \(Position (V2 x y)) -> Brillo.Translate x y $ Brillo.circleSolid 10 + + pure $ Brillo.Color (Brillo.makeColorI 255 255 255 255) drawnEntities``` diff --git a/apecs-brillo.cabal b/apecs-brillo.cabal --- a/apecs-brillo.cabal +++ b/apecs-brillo.cabal @@ -5,12 +5,12 @@ -- see: https://github.com/sol/hpack name: apecs-brillo -version: 0.1.1.1 +version: 0.2.0.0 synopsis: Apecs' gloss package, but adapted for brillo. -description: Please see the README on Codeberg at +description: A library that's meant to bridge the gap between brillo and gloss. category: Game engine author: Execute -maintainer: execute@erisws.com +maintainer: Execute copyright: 2017 Jonas Carpay, Execute license: BSD-3-Clause license-file: LICENSE @@ -26,24 +26,109 @@ library exposed-modules: Apecs.Brillo - Apecs.Physics.Brillo other-modules: Paths_apecs_brillo autogen-modules: Paths_apecs_brillo hs-source-dirs: src - ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints + default-extensions: + TemplateHaskell + ImportQualifiedPost + DuplicateRecordFields + ApplicativeDo + BlockArguments + DeriveAnyClass + DerivingVia + LambdaCase + NamedFieldPuns + NumDecimals + OverloadedLabels + OverloadedLists + OverloadedRecordDot + OverloadedStrings + MultiParamTypeClasses + NoStarIsType + PatternSynonyms + RecordWildCards + StrictData + BangPatterns + TypeAbstractions + TypeFamilies + FlexibleInstances + FlexibleContexts + DataKinds + TypeOperators + NoFieldSelectors + ScopedTypeVariables + TypeApplications + TupleSections + DeriveAnyClass + DeriveTraversable + DeriveGeneric + ghc-options: -Wall -Wcompat -Wimplicit-lift -Wincomplete-patterns -Wincomplete-patterns -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-exported-signatures -Wmissing-methods -Wmissing-signatures -Wname-shadowing -Wno-deprecations -Wredundant-bang-patterns -Wredundant-constraints -Wunused-packages build-depends: apecs >=0.7 && <0.11 - , apecs-physics >=0.3 && <5 - , base >=4.7 && <5 - , brillo ==2.* - , brillo-rendering ==2.* + , base >=4.8 && <5 + , brillo ==3.* + , brillo-rendering ==3.* , containers >=0.5 && <0.8 , linear >=1.2 && <2 default-language: Haskell2010 +executable example-balls + main-is: Main.hs + other-modules: + Paths_apecs_brillo + autogen-modules: + Paths_apecs_brillo + hs-source-dirs: + examples/balls + default-extensions: + TemplateHaskell + ImportQualifiedPost + DuplicateRecordFields + ApplicativeDo + BlockArguments + DeriveAnyClass + DerivingVia + LambdaCase + NamedFieldPuns + NumDecimals + OverloadedLabels + OverloadedLists + OverloadedRecordDot + OverloadedStrings + MultiParamTypeClasses + NoStarIsType + PatternSynonyms + RecordWildCards + StrictData + BangPatterns + TypeAbstractions + TypeFamilies + FlexibleInstances + FlexibleContexts + DataKinds + TypeOperators + NoFieldSelectors + ScopedTypeVariables + TypeApplications + TupleSections + DeriveAnyClass + DeriveTraversable + DeriveGeneric + ghc-options: -Wall -Wcompat -Wimplicit-lift -Wincomplete-patterns -Wincomplete-patterns -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-exported-signatures -Wmissing-methods -Wmissing-signatures -Wname-shadowing -Wno-deprecations -Wredundant-bang-patterns -Wredundant-constraints -Wunused-packages -threaded -rtsopts -with-rtsopts=-N + build-depends: + apecs >=0.7 && <0.11 + , apecs-brillo + , base >=4.8 && <5 + , brillo ==3.* + , brillo-rendering ==3.* + , containers >=0.5 && <0.8 + , linear >=1.2 && <2 + default-language: Haskell2010 + test-suite apecs-brillo-test type: exitcode-stdio-1.0 main-is: Spec.hs @@ -53,14 +138,47 @@ Paths_apecs_brillo hs-source-dirs: test - 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 + default-extensions: + TemplateHaskell + ImportQualifiedPost + DuplicateRecordFields + ApplicativeDo + BlockArguments + DeriveAnyClass + DerivingVia + LambdaCase + NamedFieldPuns + NumDecimals + OverloadedLabels + OverloadedLists + OverloadedRecordDot + OverloadedStrings + MultiParamTypeClasses + NoStarIsType + PatternSynonyms + RecordWildCards + StrictData + BangPatterns + TypeAbstractions + TypeFamilies + FlexibleInstances + FlexibleContexts + DataKinds + TypeOperators + NoFieldSelectors + ScopedTypeVariables + TypeApplications + TupleSections + DeriveAnyClass + DeriveTraversable + DeriveGeneric + ghc-options: -Wall -Wcompat -Wimplicit-lift -Wincomplete-patterns -Wincomplete-patterns -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-exported-signatures -Wmissing-methods -Wmissing-signatures -Wname-shadowing -Wno-deprecations -Wredundant-bang-patterns -Wredundant-constraints -Wunused-packages -threaded -rtsopts -with-rtsopts=-N build-depends: apecs >=0.7 && <0.11 , apecs-brillo - , apecs-physics >=0.3 && <5 - , base >=4.7 && <5 - , brillo ==2.* - , brillo-rendering ==2.* + , base >=4.8 && <5 + , brillo ==3.* + , brillo-rendering ==3.* , containers >=0.5 && <0.8 , linear >=1.2 && <2 default-language: Haskell2010 diff --git a/examples/balls/Main.hs b/examples/balls/Main.hs new file mode 100644 --- /dev/null +++ b/examples/balls/Main.hs @@ -0,0 +1,63 @@ +{-# LANGUAGE FieldSelectors #-} +module Main where + +import Apecs qualified +import Brillo qualified +import Apecs.Brillo qualified as Brillo +import System.Exit (exitSuccess) +import Control.Monad (void) +import Linear + +newtype Position = Position (V2 Float) + deriving Show + +instance Apecs.Component Position where + type Storage Position = Apecs.Map Position + +newtype Velocity = Velocity (V2 Float) + deriving Show + +instance Apecs.Component Velocity where + type Storage Velocity = Apecs.Map Velocity + +Apecs.makeWorld "World" + [ ''Brillo.Camera + , ''Position + , ''Velocity + ] + +main :: IO () +main = do + world <- initWorld + Apecs.runWith world do + initialise + Brillo.playWithApecs (Brillo.InWindow "Example" (800, 600) (10, 10)) Brillo.black 60 draw handleEvent step + +initialise :: Apecs.System World () +initialise = void do + Apecs.newEntity (Position 0, Velocity (V2 12 (-16))) + Apecs.newEntity (Position (V2 24 0), Velocity (V2 (-48) 8)) + Apecs.newEntity (Position (V2 48 24), Velocity (V2 32 16)) + +step :: Float -> Apecs.System World () +step dT = do + velocity dT + gravity dT + +velocity :: Float -> Apecs.System World () +velocity dT = Apecs.cmap \(Position pos, Velocity vel) -> Position $ pos + vel ^* dT + +gravity :: Float -> Apecs.System World () +gravity dT = Apecs.cmap \(Velocity vel) -> Position $ vel + gravityVel ^* dT + where gravityVel = V2 0 (-1) + +handleEvent :: Brillo.Event -> Apecs.System World () +handleEvent = \case + Brillo.EventKey (Brillo.SpecialKey Brillo.KeyEsc) Brillo.Down _ _ -> Apecs.liftIO exitSuccess + _ -> pure () + +draw :: Apecs.System World Brillo.Picture +draw = do + drawnEntities <- Brillo.cfoldDraw \(Position (V2 x y)) -> Brillo.Translate x y $ Brillo.circleSolid 10 + + pure $ Brillo.Color (Brillo.makeColorI 255 255 255 255) drawnEntities diff --git a/src/Apecs/Brillo.hs b/src/Apecs/Brillo.hs --- a/src/Apecs/Brillo.hs +++ b/src/Apecs/Brillo.hs @@ -2,67 +2,80 @@ {-# LANGUAGE TypeFamilies #-} module Apecs.Brillo - ( module Apecs.Brillo - , module G - ) where + ( Camera(..) -import Data.Semigroup (Semigroup (..)) -import Brillo -import Brillo.Interface.IO.Game as G -import Linear.V2 -import Linear.Vector + , Brillo.Event(..) + , Brillo.Key(..) + , Brillo.SpecialKey(..) + , Brillo.MouseButton(..) + , Brillo.KeyState(..) + , Brillo.Modifiers(..) -import Apecs + , playWithApecs + , cameraTransform + , windowToWorld + + , cfoldDraw + , cfoldDrawM + ) where + +import Brillo qualified +import Brillo.Interface.IO.Game qualified as Brillo +import Linear +import Apecs qualified + data Camera = Camera { camOffset :: V2 Float , camScale :: Float } deriving (Eq, Show, Read) instance Semigroup Camera where - Camera x1 r1 <> Camera x2 r2 = Camera (x1 + x2) (r1 * r2) + Camera pos1 scale1 <> Camera pos2 scale2 = Camera (pos1 + pos2) (scale1 * scale2) + instance Monoid Camera where mempty = Camera 0 1 mappend = (<>) --- | Apply a camera transformation to a picture -cameraTransform :: Camera -> Picture -> Picture -cameraTransform (Camera (V2 cx cy) cs) = - Scale cs cs . Translate (-cx) (-cy) +instance Apecs.Component Camera where type Storage Camera = Apecs.Global Camera -windowToWorld :: Camera -> (Float,Float) -> V2 Float -windowToWorld (Camera cx cs) (x,y) = V2 x y ^/ cs + cx +playWithApecs + :: (Apecs.Has w IO Camera) + => Brillo.Display -- ^ Display mode + -> Brillo.Color -- ^ Background color + -> Int -- ^ Desired FPS + -> Apecs.System w Brillo.Picture -- ^ Drawing function + -> (Brillo.Event -> Apecs.System w ()) -- ^ Event handling function + -> (Float -> Apecs.System w ()) -- ^ Stepping function, with a time delta argument. + -> Apecs.System w () +playWithApecs disp col fps draw handle step = do + w <- Apecs.ask + Apecs.liftIO $ Brillo.playIO disp col fps w draw' handle' step' + where + handle' event = Apecs.runSystem $ handle event >> Apecs.ask -instance Component Camera where - type Storage Camera = Global Camera + step' dT = Apecs.runSystem $ step dT >> Apecs.ask -play - :: (Has w IO Camera) - => Display -- ^ Display mode - -> Color -- ^ Background color - -> Int -- ^ Desired FPS - -> System w Picture -- ^ Drawing function - -> (Event -> System w ()) -- ^ Event handling function - -> (Float -> System w ()) -- ^ Stepping function, with a time delta argument. - -> System w () -play disp col fps draw handle step = do - w <- ask - liftIO$ playIO disp col fps w draw' handle' step' - where - handle' event = runSystem $ handle event >> ask - step' dT = runSystem $ step dT >> ask - draw' = runSystem $ do - cam <- get global - cameraTransform cam <$> draw + draw' = Apecs.runSystem do + cam <- Apecs.get Apecs.global + cameraTransform cam <$> draw +-- | Apply a camera transformation to a picture. +cameraTransform :: Camera -> Brillo.Picture -> Brillo.Picture +cameraTransform (Camera (V2 camX camY) camScale) = Brillo.Scale camScale camScale . Brillo.Translate (-camX) (-camY) + +-- | Translates a position from the camera's offset and scale. +windowToWorld :: Camera -> (Float, Float) -> V2 Float +windowToWorld (Camera camPos camScale) (x, y) = V2 x y ^/ camScale + camPos + -- | Renders a picture given a component rendering function. -foldDraw :: (Get w IO c, Members w IO c) - => (c -> Picture) -- ^ Component render function. - -> System w Picture -foldDraw fn = cfold (\pic -> mappend pic . fn) mempty +cfoldDraw :: (Apecs.Get w IO c, Apecs.Members w IO c) + => (c -> Brillo.Picture) -- ^ Component render function. + -> Apecs.System w Brillo.Picture +cfoldDraw f = Apecs.cfold (\p -> mappend p . f) mempty -- | Monadically renders a picture given a component rendering function. -foldDrawM :: (Get w IO c, Members w IO c) - => (c -> System w Picture) -- ^ Component render function. - -> System w Picture -foldDrawM fn = cfoldM (\pic -> fmap (mappend pic) . fn) mempty +cfoldDrawM :: (Apecs.Get w IO c, Apecs.Members w IO c) + => (c -> Apecs.System w Brillo.Picture) -- ^ Component render function. + -> Apecs.System w Brillo.Picture +cfoldDrawM f = Apecs.cfoldM (\p -> fmap (mappend p) . f) mempty diff --git a/src/Apecs/Physics/Brillo.hs b/src/Apecs/Physics/Brillo.hs deleted file mode 100644 --- a/src/Apecs/Physics/Brillo.hs +++ /dev/null @@ -1,65 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeFamilies #-} - -module Apecs.Physics.Brillo - ( convexToPicture - , Transform, worldTransform, drawBody - , simulate - , module Apecs.Brillo - ) where - -import Control.Monad (foldM) -import Data.Semigroup (Semigroup (..)) -import Brillo.Geometry.Angle (radToDeg) -import Brillo.Interface.IO.Simulate (simulateIO) - -import Apecs -import Apecs.Physics -import Apecs.Brillo - -convexToPicture :: Convex -> Picture -convexToPicture (Convex [V2 x y] radius) = Translate (realToFrac x) (realToFrac y) $ Circle (realToFrac radius) -convexToPicture (Convex [a,b] _) = Line [v2ToTuple a, v2ToTuple b] -convexToPicture (Convex verts _) = Polygon (v2ToTuple <$> verts) - -v2ToTuple :: V2 Double -> (Float, Float) -v2ToTuple (V2 x y) = (realToFrac x, realToFrac y) - -type Transform = (Position, Angle) -worldTransform :: Transform -> Picture -> Picture -worldTransform (Position (V2 x y), Angle theta) = - Translate (realToFrac x) (realToFrac y) . - Rotate (negate . radToDeg . realToFrac $ theta) - -drawBody :: Has w IO Physics => (Body, Transform, ShapeList) -> System w Picture -drawBody (btype, transform, ShapeList shapes) = Color shColor . worldTransform transform <$> foldM foldfn mempty shapes - where foldfn pic shapeEty = do - Shape _ convex <- get shapeEty - return . mappend pic $ convexToPicture convex - shColor = case btype of - DynamicBody -> red - KinematicBody -> green - StaticBody -> blue - -simulate - :: ( Has w IO Camera - , Has w IO Physics - ) - => Display - -> System w () -simulate disp = do - w <- ask - liftIO $ - simulateIO disp - black - 60 - w - (\_ -> runSystem draw w) - (\_ _ _ -> runSystem (stepPhysics (1/60)) w >> return w) - - where - draw = do - pic <- foldDrawM drawBody - cam <- get global - return $ cameraTransform cam pic diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,7 +1,6 @@ module Spec where import Apecs -import Apecs.Brillo.Physics test :: IO () test = putStrLn "tests not done yet"