z0w0/helm
1
1
Fork 0
mirror of https://github.com/z0w0/helm.git synced 2024-10-05 16:28:50 +03:00
Code Issues Projects Releases Wiki Activity

Initial work towards Helm 2.0.0 release, with reworking of the engine internals. Adds support for only re-rendering models if they've changed

Browse Source
This commit is contained in:
Zack Corr 2017-06-14 21:07:31 +10:00
parent 3564224d1e
commit 5c19afb173
9 changed files with 659 additions and 583 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

0
CHANGELOG.md Normal file
View File

10
helm.cabal
View File

@ -1,5 +1,5 @@
name: helm
version: 1.0.0
version: 2.0.0
synopsis: A functionally reactive game engine.
description: A functionally reactive game engine, with headgear to protect you
from the headache of game development provided.
@ -7,12 +7,12 @@ homepage: http://github.com/switchface/helm
bug-reports: http://github.com/switchface/helm/issues
license: MIT
license-file: LICENSE
tested-with: GHC == 7.10.2
tested-with: GHC == 8.0.2
extra-source-files: LICENSE, README.md
author: Zack Corr
maintainer: Zack Corr <zack@z0w0.me>
copyright: (c) 2013-2014, Zack Corr
category: Game Enately. FRP
copyright: (c) 2013-2017, Zack Corr
category: Game Engine. FRP
build-type: Simple
cabal-version: >=1.10
@ -33,9 +33,7 @@ library
Helm.Color
Helm.Engine
Helm.Engine.SDL
Helm.Engine.SDL.Asset
Helm.Engine.SDL.Engine
Helm.Engine.SDL.Graphics2D
Helm.Engine.SDL.Keyboard
Helm.Engine.SDL.Mouse
Helm.Graphics

128
src/Helm.hs
View File

@ -14,40 +14,17 @@ module Helm
) where
import Control.Exception (finally)
import Control.Monad (foldM, void)
import Control.Monad.Trans.State.Lazy (evalStateT)
import Control.Monad (foldM, void, when)
import Control.Monad.Trans.State.Lazy (runStateT)
import FRP.Elerea.Param (start, embed)
import Helm.Asset (Image)
import Helm.Engine (Cmd(..), Sub(..), GameConfig(..), Engine(..))
import Helm.Engine (Cmd(..), Sub(..), Game(..), GameConfig(..), Engine(..))
import Helm.Graphics
-- | A data structure describing a game's state (that is running under an engine).
data Game e m a = Game
{ gameConfig :: GameConfig e m a -- ^ The configuration of the game, passed by a user.
, gameModel :: m -- ^ The current game model state.
, actionSmp :: e -> IO [a] -- ^ A feedable monad that returns actions from mapped subscriptions.
}
-- | Prepare the game state from an engine and some game configuration.
prepare :: Engine e => e -> GameConfig e m a -> IO (Game e m a)
prepare engine config = do
{- The call to 'embed' here is a little bit hacky, but seems necessary
to get this working. This is because 'start' actually computes the signal
gen passed to it, and all of our signal gens try to fetch
the 'input' value within the top layer signal gen (rather than in the
contained signal). But we haven't sampled with the input value yet, so it'll
be undefined unless we 'embed'. -}
smp <- start $ embed (return engine) gen
return Game
{ gameConfig = config
, gameModel = fst initialFn
, actionSmp = smp
}
where
GameConfig { initialFn, subscriptionsFn = Sub gen } = config
-- | The context of an engine running a game.
-- This is used to track the connection of an engine's state to a game state.
data EngineContext e m a = EngineContext e (Game e m a)
-- | Runs a Helm game using an engine and some configuration for a game.
-- An engine should first be initialized separately to Helm, and then passed
@ -58,41 +35,84 @@ prepare engine config = do
-- which is currently bundled with the engine (although it will eventually be moved
-- to its own package). See 'Helm.Engine.SDL.startup' for how
-- to startup the SDL engine, which can then be run by this function.
run :: Engine e => e -> GameConfig e m a -> IO ()
run engine config@GameConfig { initialFn } =
void $ (prepare engine config >>= stepInitial >>= step engine) `finally` cleanup engine
run
:: Engine e
=> e -- ^ The engine to use to run the game.
-> GameConfig e m a -- ^ The configuration for running the game.
-> IO () -- ^ An IO monad that blocks the main thread until the engine quits.
run engine config@GameConfig { initialFn, subscriptionsFn = Sub sigGen } = void $ do
{- The call to 'embed' here is a little bit hacky, but seems necessary
to get this working. This is because 'start' actually computes the signal
gen passed to it, and all of our signal gens try to fetch
the 'input' value within the top layer signal gen (rather than in the
contained signal). But we haven't sampled with the input value yet, so it'll
be undefined unless we 'embed'. -}
smp <- start $ embed (return engine) sigGen
where
Cmd monad = snd initialFn
stepInitial game@Game { gameModel } = do
actions <- evalStateT monad engine
model <- foldM (stepModel engine game) gameModel actions
-- Setup the initial engine context and perform the initial game step
ctx@(EngineContext engine_ _) <- flip stepCmd (snd initialFn) $ EngineContext engine Game
{ gameConfig = config
, gameModel = fst initialFn
, dirtyModel = True
, actionSmp = smp
}
return game { gameModel = model }
step ctx `finally` cleanup engine_
-- | Step the game state forward.
step :: Engine e => e -> Game e m a -> IO ()
step engine game = do
-- | Step the engine context forward.
step
:: Engine e
=> EngineContext e m a -- ^ The engine context to step forward.
-> IO (EngineContext e m a) -- ^ An IO monad that produces the stepped engine context.
step ctx@(EngineContext engine game) = do
-- Tick the engine to pump the signal sinks
mayhaps <- tick engine
case mayhaps of
Nothing -> return ()
-- If nothing was returned, stop the step loop
Nothing -> return ctx
Just sunkEngine -> do
actions <- actionSmp sunkEngine
model <- foldM (stepModel sunkEngine game) gameModel actions
Just engine_ -> do
EngineContext engine__ game_ <- actionSmp engine_ >>= foldM stepAction (EngineContext engine_ game)
render sunkEngine $ viewFn model
step sunkEngine $ game { gameModel = model }
-- Render the game if game model has been changed this step
when (dirtyModel game_) $ render engine__ $ viewFn $ gameModel game_
-- Keep the loop going
step $ EngineContext engine__ $ game_ { dirtyModel = False }
where
Game { actionSmp, gameModel, gameConfig = GameConfig { viewFn } } = game
Game { actionSmp, gameConfig = GameConfig { viewFn } } = game
-- | Step the game model forward with a specific game action.
stepModel :: Engine e => e -> Game e m a -> m -> a -> IO m
stepModel engine game model action =
evalStateT monad engine >>= foldM (stepModel engine game) upModel
-- | Step the engine context forward with a specific game action.
stepAction
:: Engine e
=> EngineContext e m a -- ^ The engine context to step forward.
-> a -- ^ The action to step the engine context with.
-> IO (EngineContext e m a) -- ^ An IO monad that produces the engine context stepped with the action.
stepAction (EngineContext engine game@Game { gameModel, gameConfig = GameConfig { updateFn } }) action =
stepCmd ctx cmd
where
Game { gameConfig = GameConfig { updateFn } } = game
(upModel, Cmd monad) = updateFn model action
(updatedModel, cmd) = updateFn gameModel action
-- Mark the game as dirty and adjust the new game model
ctx = EngineContext engine $ game
{ dirtyModel = True
, gameModel = updatedModel
}
-- | Step the engine context forward with a specific command.
-- This will recursively call 'stepAction' with any actions
-- that are produced by the command.
stepCmd
:: Engine e
=> EngineContext e m a -- ^ The engine context to step forward.
-> Cmd e a -- ^ The command to step the engine context with.
-> IO (EngineContext e m a) -- ^ An IO monad that produces the engine context stepped with the command.
stepCmd (EngineContext engine game) (Cmd monad) = do
(actions, engine_) <- runStateT monad engine
-- Step any actions returned from the command
foldM stepAction (EngineContext engine_ game) actions

24
src/Helm/Engine.hs
View File

@ -4,6 +4,7 @@ module Helm.Engine (
Engine(..),
-- * Types
Cmd(..),
Game(..),
GameConfig(..),
Sub(..),
MouseButton(..),
@ -68,9 +69,9 @@ class Engine e where
-- | Represents a subscription to a stream of events captured from a user's interaction with the engine.
-- A subscription is best thought of as a collection of events over time - which is the nature of
-- functional reactive programming (the paradigm that Helm bases it's concepts on).
-- Although Helm uses a departed version of the traditional FRP paradigm, it still follows the
-- concept closely and hence an understanding of FRP will allow you to understnad the library easily.
-- functional reactive programming (the paradigm that Helm bases its concepts on).
-- Although Helm uses a departed version of the traditional FRP paradigm, it still shares some
-- concepts. An understanding of FRP will allow you to understand the library easily.
--
-- Functions throughout the Helm library that return a subscription will first let you map the data
-- related to the event you're subscribing to into another form (specifically, a game action).
@ -84,7 +85,7 @@ newtype Sub e a = Sub (SignalGen e (Signal [a]))
-- | Represents an IO-like monad with knowledge about the state of the game engine. Each command
-- contains a collection of game actions that will be applied to your game's update function to update
-- the game state. This is similar to a subscription in a way, with the difference being that
-- a command does not change over time, but rather is a lazy monad and hence contains a value that
-- a command does not change over time, but rather is a lazy monad and hence contains a value
-- from the time of the execution. A good example of the usage of a command vs. a subscription is the game
-- window size - a command would allow you to map the current window size into an action, whereas
-- a subscription would let you subscribe to when the window is resized and then map that event into
@ -118,8 +119,8 @@ data GameConfig e m a = GameConfig {
initialFn :: (m, Cmd e a),
-- | Called whenever a game action is mapped from a command or subscription.
-- This is where the actual implementation of a Helm game is done.
-- The function is given a game model and the mapped action type,
-- This is where the actual implementation of a Helm game is provided.
-- The function is given a game model and an action,
-- and should produce the new game model state based off of the action.
--
-- The first tuple value is the new model state, and then the second
@ -157,6 +158,17 @@ data GameConfig e m a = GameConfig {
viewFn :: m -> Graphics e
}
-- | Represents the state of a game being run.
--
-- The type variable e refers to an instance of the 'Engine' class,
-- m refers to a game model type and a refers to a game action type.
data Game e m a = Game
{ gameConfig :: GameConfig e m a -- ^ The configuration of the game, passed by a user.
, gameModel :: m -- ^ The current game model state.
, dirtyModel :: Bool -- ^ Whether or not the model has been changed and the game should be rerendered.
, actionSmp :: e -> IO [a] -- ^ A feedable monad that returns actions from mapped subscriptions.
}
-- | Represents a mouse button that can be pressed on a mouse.
data MouseButton
= LeftButton

240
src/Helm/Engine/SDL.hs
View File

@ -13,236 +13,12 @@ module Helm.Engine.SDL
, withImage
) where
import Control.Monad (when)
import qualified Data.Text as T
import Helm.Engine.SDL.Engine
( SDLEngine
, SDLEngineConfig(..)
, defaultConfig
, startup
, startupWith
, withImage
)
import FRP.Elerea.Param
import Linear.Affine (Point(P))
import Linear.Metric (distance)
import Linear.V2 (V2(V2))
import qualified SDL
import qualified SDL.Event as Event
import qualified SDL.Init as Init
import SDL.Input.Keyboard (Keysym(..))
import qualified SDL.Time as Time
import qualified SDL.Video as Video
import SDL.Video (WindowConfig(..))
import qualified SDL.Video.Renderer as Renderer
import Helm.Engine (Engine(..))
import Helm.Engine.SDL.Asset (withImage)
import Helm.Engine.SDL.Engine (SDLEngine(..), SDLEngineConfig(..))
import qualified Helm.Engine.SDL.Graphics2D as Graphics2D
import Helm.Engine.SDL.Keyboard (mapKey)
import Helm.Engine.SDL.Mouse (mapMouseButton)
import Helm.Graphics (Graphics(..))
import Helm.Graphics2D (Collage)
-- FIXME: Find a nice and easy way to have this instance with the SDLEngine type.
-- Can't avoid the orphan instance without dependency hell right now.
instance Engine SDLEngine where
render engine (Graphics2D coll) = render2d engine coll
cleanup SDLEngine { window, renderer, texture } = do
Renderer.destroyTexture texture
Video.destroyWindow window
Video.destroyRenderer renderer
Init.quit
tick engine = do
mayhaps <- Event.pumpEvents >> Event.pollEvent
case mayhaps of
-- Handle the quit event exclusively first to simplify our code
Just Event.Event { eventPayload = Event.QuitEvent } ->
return Nothing
Just Event.Event { .. } ->
sinkEvent engine eventPayload >>= tick
Nothing -> return $ Just engine
mouseMoveSignal = mouseMoveEventSignal
mouseDownSignal = mouseDownEventSignal
mouseUpSignal = mouseUpEventSignal
mouseClickSignal = mouseClickEventSignal
keyboardDownSignal = keyboardDownEventSignal
keyboardUpSignal = keyboardUpEventSignal
keyboardPressSignal = keyboardPressEventSignal
windowResizeSignal = windowResizeEventSignal
runningTime _ = fromIntegral <$> Time.ticks
windowSize SDLEngine { window } = fmap (fmap fromIntegral) . SDL.get $ Video.windowSize window
-- | The default configuration for the engine. You should change the values where necessary.
defaultConfig :: SDLEngineConfig
defaultConfig = SDLEngineConfig
{ windowDimensions = V2 800 600
, windowIsFullscreen = False
, windowIsResizable = True
, windowTitle = "Helm"
}
-- | Initialize a new engine with default configuration. The engine can then be run later using 'run'.
startup :: IO SDLEngine
startup = startupWith defaultConfig
-- | Prepare a texture for streamed rendering based of a window size.
prepTexture :: V2 Int -> Video.Renderer -> IO Renderer.Texture
prepTexture dims renderer =
Renderer.createTexture renderer mode access $ fromIntegral <$> dims
where
mode = Renderer.ARGB8888
access = Renderer.TextureAccessStreaming
-- | Initialize a new engine with some configration, ready to be 'run'.
startupWith :: SDLEngineConfig -> IO SDLEngine
startupWith config@SDLEngineConfig { .. } = do
Init.initializeAll
window <- Video.createWindow (T.pack windowTitle) windowConfig
renderer <- Video.createRenderer window (-1) rendererConfig
texture <- prepTexture windowDimensions renderer
mouseMoveEvent <- externalMulti
mouseDownEvent <- externalMulti
mouseUpEvent <- externalMulti
mouseClickEvent <- externalMulti
keyboardDownEvent <- externalMulti
keyboardUpEvent <- externalMulti
keyboardPressEvent <- externalMulti
windowResizeEvent <- externalMulti
Video.showWindow window
return SDLEngine
{ window = window
, renderer = renderer
, texture = texture
, engineConfig = config
, lastMousePress = Nothing
, mouseMoveEventSignal = fst mouseMoveEvent
, mouseMoveEventSink = snd mouseMoveEvent
, mouseDownEventSignal = fst mouseDownEvent
, mouseDownEventSink = snd mouseDownEvent
, mouseUpEventSignal = fst mouseUpEvent
, mouseUpEventSink = snd mouseUpEvent
, mouseClickEventSignal = fst mouseClickEvent
, mouseClickEventSink = snd mouseClickEvent
, keyboardDownEventSignal = fst keyboardDownEvent
, keyboardDownEventSink = snd keyboardDownEvent
, keyboardUpEventSignal = fst keyboardUpEvent
, keyboardUpEventSink = snd keyboardUpEvent
, keyboardPressEventSignal = fst keyboardPressEvent
, keyboardPressEventSink = snd keyboardPressEvent
, windowResizeEventSignal = fst windowResizeEvent
, windowResizeEventSink = snd windowResizeEvent
}
where
rendererConfig = Video.RendererConfig Video.AcceleratedVSyncRenderer False
windowConfig = Video.defaultWindow
{ windowInitialSize = fromIntegral <$> windowDimensions
, windowMode = if windowIsFullscreen
then Video.Fullscreen
else Video.Windowed
, windowResizable = windowIsResizable
}
-- | Renders a 2D element to the engine screen.
render2d :: SDLEngine -> Collage SDLEngine -> IO ()
render2d SDLEngine { window, renderer, texture } element = do
dims <- SDL.get $ Video.windowSize window
Graphics2D.render texture dims element
Renderer.clear renderer
Renderer.copy renderer texture Nothing Nothing
Renderer.present renderer
-- | Turns a point containing a vector into a regular vector.
depoint :: Point f a -> f a
depoint (P x) = x
-- | Sink an SDL event into the Elerea sinks initialized at startup of the SDL engine.
-- These sinks then provide the data for the Elerea signals, which will be in
-- turn will provide the Helm subscriptions with events.
sinkEvent :: SDLEngine -> Event.EventPayload -> IO SDLEngine
sinkEvent engine (Event.WindowResizedEvent Event.WindowResizedEventData { .. }) = do
windowResizeEventSink engine dims
Renderer.destroyTexture texture
resized <- prepTexture dims renderer
return engine { texture = resized }
where
dims = fromIntegral <$> windowResizedEventSize
SDLEngine { texture, renderer } = engine
sinkEvent engine (Event.MouseMotionEvent Event.MouseMotionEventData { .. }) = do
mouseMoveEventSink engine $ fromIntegral <$> depoint mouseMotionEventPos
return engine
sinkEvent engine (Event.KeyboardEvent Event.KeyboardEventData { .. }) =
case keyboardEventKeyMotion of
Event.Pressed -> do
keyboardDownEventSink engine key
if keyboardEventRepeat
then keyboardPressEventSink engine key >> return engine
else return engine
Event.Released -> do
keyboardUpEventSink engine key
keyboardPressEventSink engine key
return engine
where
Keysym { .. } = keyboardEventKeysym
key = mapKey keysymKeycode
sinkEvent engine (Event.MouseButtonEvent Event.MouseButtonEventData { .. }) =
case mouseButtonEventMotion of
Event.Pressed -> do
ticks <- Time.ticks
mouseDownEventSink engine tup
return engine { lastMousePress = Just (ticks, dubPos) }
Event.Released -> do
mouseUpEventSink engine tup
-- Weirdly enough, SDL provides a value that says how many clicks there
-- were, but this value is always set to one even if it's just a regular
-- mouse up event. Note that here we're defining a click as a mouse up
-- event being in a very close proximity to a previous mouse down event.
-- We manually calculate whether this was a click or not.
case lastMousePress of
Just (lastTicks, lastPos) -> do
ticks <- Time.ticks
-- Check that it's a expected amount of time for a click and that the mouse
-- has basically stayed in place
when (distance dubPos lastPos <= clickRadius && ticks - lastTicks < clickMs)
(mouseClickEventSink engine tup)
Nothing -> return ()
return engine
where
SDLEngine { lastMousePress } = engine
clickMs = 500 -- How long between mouse down/up to recognise clicks
clickRadius = 3 -- The pixel radius to be considered a click.
pos = depoint mouseButtonEventPos
dubPos = fromIntegral <$> pos
tup = (mapMouseButton mouseButtonEventButton, fromIntegral <$> pos)
sinkEvent engine _ = return engine

41
src/Helm/Engine/SDL/Asset.hs
View File

@ -1,41 +0,0 @@
-- | Contains the SDL asset types.
module Helm.Engine.SDL.Asset
(
-- * Types
Image(..)
-- * Loading
, withImage
) where
import qualified Graphics.Rendering.Cairo as Cairo
import Linear.V2 (V2(..))
import Helm.Asset (Image)
import Helm.Engine.SDL.Engine (SDLEngine)
-- | Represents an 'Image' for the SDL engine.
data instance Image SDLEngine = SDLImage
{ cairoSurface :: Cairo.Surface -- ^ The Cairo surface for the image.
, imageDims :: V2 Int -- ^ The image dimensions of the image (when it was loaded).
}
-- | Load an image asset using the SDL engine and do
-- something with it. The image will be cleaned up
-- once the provided monad completes.
--
-- Currently, the only supported image file format is PNG.
--
-- The expected usage would be to use 'withImage'
-- for each image you need to load before
-- running the engine, and then use the images with
-- graphics. Once the engine stops running, the image
-- will then be automatically cleaned up.
withImage :: SDLEngine -> FilePath -> (Image SDLEngine -> IO a) -> IO a
withImage _ path f = Cairo.withImageSurfaceFromPNG path $ \surface -> do
width <- Cairo.imageSurfaceGetWidth surface
height <- Cairo.imageSurfaceGetHeight surface
f SDLImage
{ cairoSurface = surface
, imageDims = V2 width height
}

583
src/Helm/Engine/SDL/Engine.hs
View File

@ -4,50 +4,575 @@ module Helm.Engine.SDL.Engine
-- * Types
SDLEngine(..)
, SDLEngineConfig(..)
-- * Startup
, defaultConfig
, startup
, startupWith
-- * Asset Loading
, withImage
) where
import Data.Word (Word32)
import Control.Monad (when)
import FRP.Elerea.Param (Signal, SignalGen)
import Linear.V2 (V2)
import Data.Foldable (forM_)
import qualified Data.Text as T
import Data.Word (Word32)
import Foreign.Ptr (castPtr)
import qualified Graphics.Rendering.Cairo as Cairo
import Graphics.Rendering.Cairo.Matrix (Matrix(..))
import qualified Graphics.Rendering.Pango as Pango
import FRP.Elerea.Param (Signal, SignalGen, externalMulti)
import Linear.Affine (Point(P))
import Linear.Metric (distance)
import Linear.V2 (V2(V2))
import Linear.V3 (V3(V3))
import qualified SDL
import qualified SDL.Event as Event
import qualified SDL.Init as Init
import SDL.Input.Keyboard (Keysym(..))
import qualified SDL.Time as Time
import qualified SDL.Video as Video
import SDL.Video (WindowConfig(..))
import qualified SDL.Video.Renderer as Renderer
import Helm.Engine (MouseButton, Key)
import Helm.Asset (Image)
import Helm.Color (Color(..), Gradient(..))
import Helm.Engine (Engine(..), Key, MouseButton)
import Helm.Engine.SDL.Keyboard (mapKey)
import Helm.Engine.SDL.Mouse (mapMouseButton)
import Helm.Graphics
import qualified Helm.Graphics2D as Graphics2D
import Helm.Graphics2D.Text (Text(..), FontWeight(..), FontStyle(..))
-- | Represents the configuration to run the SDL engine with.
-- Use 'defaultConfig' and then only change the necessary fields.
data SDLEngineConfig = SDLEngineConfig
{ windowDimensions :: V2 Int
, windowIsFullscreen :: !Bool
, windowIsResizable :: !Bool
, windowTitle :: !String
{ windowDimensions :: V2 Int -- ^ The initial SDL window size.
, windowIsFullscreen :: !Bool -- ^ Whether the SDL window should start fullscreen.
, windowIsResizable :: !Bool -- ^ Whether the SDL window should be resizable.
, windowTitle :: !String -- ^ The initial SDL window title.
}
-- | Represents the SDL engine's internal state.
data SDLEngine = SDLEngine
{ window :: Video.Window
, renderer :: Video.Renderer
, texture :: !Renderer.Texture
, engineConfig :: SDLEngineConfig
, lastMousePress :: Maybe (Word32, V2 Double)
{ window :: !Video.Window -- ^ The SDL window.
, renderer :: !Video.Renderer -- ^ The SDL renderer.
, texture :: !Renderer.Texture -- ^ The SDL texture for rendering.
, engineConfig :: !SDLEngineConfig -- ^ The engine config being used.
, lastMousePress :: Maybe (Word32, V2 Double) -- ^ The last mouse press info.
, mouseMoveEventSignal :: SignalGen SDLEngine (Signal [V2 Int])
, mouseMoveEventSink :: V2 Int -> IO ()
, mouseDownEventSignal :: SignalGen SDLEngine (Signal [(MouseButton, V2 Int)])
, mouseDownEventSink :: (MouseButton, V2 Int) -> IO ()
, mouseUpEventSignal :: SignalGen SDLEngine (Signal [(MouseButton, V2 Int)])
, mouseUpEventSink :: (MouseButton, V2 Int) -> IO ()
, mouseClickEventSignal :: SignalGen SDLEngine (Signal [(MouseButton, V2 Int)])
, mouseClickEventSink :: (MouseButton, V2 Int) -> IO ()
, mouseMoveEventSignal :: SignalGen SDLEngine (Signal [V2 Int]) -- ^ The mouse move event signal.
, mouseMoveEventSink :: V2 Int -> IO () -- ^ The mouse move event sink.
, mouseDownEventSignal :: SignalGen SDLEngine (Signal [(MouseButton, V2 Int)]) -- ^ The mouse down event signal.
, mouseDownEventSink :: (MouseButton, V2 Int) -> IO () -- ^ The mouse down event sink.
, mouseUpEventSignal :: SignalGen SDLEngine (Signal [(MouseButton, V2 Int)]) -- ^ The mouse up event signal.
, mouseUpEventSink :: (MouseButton, V2 Int) -> IO () -- ^ The mouse up event sink.
, mouseClickEventSignal :: SignalGen SDLEngine (Signal [(MouseButton, V2 Int)]) -- ^ The mouse click event signal.
, mouseClickEventSink :: (MouseButton, V2 Int) -> IO () -- ^ The mouse click event sink.
, keyboardDownEventSignal :: SignalGen SDLEngine (Signal [Key])
, keyboardDownEventSink :: Key -> IO ()
, keyboardUpEventSignal :: SignalGen SDLEngine (Signal [Key])
, keyboardUpEventSink :: Key -> IO ()
, keyboardPressEventSignal :: SignalGen SDLEngine (Signal [Key])
, keyboardPressEventSink :: Key -> IO ()
, keyboardDownEventSignal :: SignalGen SDLEngine (Signal [Key]) -- ^ The keyboard down event signal.
, keyboardDownEventSink :: Key -> IO () -- ^ The keyboard down event sink.
, keyboardUpEventSignal :: SignalGen SDLEngine (Signal [Key]) -- ^ The keyboard up event signal.
, keyboardUpEventSink :: Key -> IO () -- ^ The keyboard up event sink.
, keyboardPressEventSignal :: SignalGen SDLEngine (Signal [Key]) -- ^ The keyboard press event signal.
, keyboardPressEventSink :: Key -> IO () -- ^ The keyboard press event sink.
, windowResizeEventSignal :: SignalGen SDLEngine (Signal [V2 Int])
, windowResizeEventSink :: V2 Int -> IO ()
, windowResizeEventSignal :: SignalGen SDLEngine (Signal [V2 Int]) -- ^ The window resize event signal.
, windowResizeEventSink :: V2 Int -> IO () -- ^ The window resize event sink.
}
-- | Represents an 'Image' for the SDL engine.
data instance Image SDLEngine = SDLImage
{ cairoSurface :: Cairo.Surface -- ^ The Cairo surface for the image.
, imageDims :: V2 Int -- ^ The image dimensions of the image (when it was loaded).
}
-- | Load an image asset using the SDL engine and do
-- something with it. The image will be cleaned up
-- once the provided monad completes.
--
-- Currently, the only supported image file format is PNG.
--
-- The expected usage would be to use 'withImage'
-- for each image you need to load before
-- running the engine, and then use the images with
-- graphics. Once the engine stops running, the image
-- will then be automatically cleaned up.
withImage :: SDLEngine -> FilePath -> (Image SDLEngine -> IO a) -> IO a
withImage _ path f = Cairo.withImageSurfaceFromPNG path $ \surface -> do
width <- Cairo.imageSurfaceGetWidth surface
height <- Cairo.imageSurfaceGetHeight surface
f SDLImage
{ cairoSurface = surface
, imageDims = V2 width height
}
-- | Provides the SDL engine implementation for Helm.
instance Engine SDLEngine where
-- | Render the SDL engine.
render engine (Graphics2D coll) = render2d engine coll
-- | Cleanup the engine assets and quit using SDL's init library.
cleanup SDLEngine { window, renderer, texture } = do
Renderer.destroyTexture texture
Video.destroyWindow window
Video.destroyRenderer renderer
Init.quit
-- | Tick the engine forward.
--
-- At the moment this just sinks event into the signals
-- as no other functionality is required.
tick engine = do
mayhaps <- Event.pumpEvents >> Event.pollEvent
case mayhaps of
-- Handle the quit event exclusively first to simplify our code
Just Event.Event { eventPayload = Event.QuitEvent } ->
return Nothing
-- Sink everything else into the signals
Just Event.Event { .. } ->
sinkEvent engine eventPayload >>= tick
Nothing -> return $ Just engine
-- | The SDL-specific mouse move signal.
mouseMoveSignal = mouseMoveEventSignal
-- | The SDL-specific mouse down signal.
mouseDownSignal = mouseDownEventSignal
-- | The SDL-specific mouse up signal.
mouseUpSignal = mouseUpEventSignal
-- | The SDL-specific mouse click signal.
mouseClickSignal = mouseClickEventSignal
-- | The SDL-specific keyboard down signal.
keyboardDownSignal = keyboardDownEventSignal
-- | The SDL-specific keyboard up signal.
keyboardUpSignal = keyboardUpEventSignal
-- | The SDL-specific keyboard press signal.
keyboardPressSignal = keyboardPressEventSignal
-- | The SDL-specific window resize signal.
windowResizeSignal = windowResizeEventSignal
-- | The running time provided using SDL ticks. This may
-- need to be changed to a Haskell library for consistency with other future engines.
runningTime _ = fromIntegral <$> Time.ticks
-- | Gets the size of the SDL engine's window.
windowSize SDLEngine { window } = fmap (fmap fromIntegral) . SDL.get $ Video.windowSize window
-- | The default configuration for the engine. You should change the values where necessary.
defaultConfig :: SDLEngineConfig
defaultConfig = SDLEngineConfig
{ windowDimensions = V2 800 600
, windowIsFullscreen = False
, windowIsResizable = True
, windowTitle = "Helm"
}
-- | Initialize a new engine with default configuration. The engine can then be run later using 'run'.
startup :: IO SDLEngine
startup = startupWith defaultConfig
-- | Prepare a texture for streamed rendering based of a window size.
prepTexture
:: V2 Int -- ^ The dimensions for the new texture.
-> Video.Renderer -- ^ The SDL video renderer.
-> IO Renderer.Texture -- ^ An IO monad that produces the prepared SDL texture.
prepTexture dims renderer =
Renderer.createTexture renderer mode access $ fromIntegral <$> dims
where
mode = Renderer.ARGB8888
access = Renderer.TextureAccessStreaming
-- | Initialize a new engine with some configration, ready to be 'run'.
startupWith
:: SDLEngineConfig -- ^ The configuration to start the engine with.
-> IO SDLEngine -- ^ An IO monad that produces an SDL engine to run games with.
startupWith config@SDLEngineConfig { .. } = do
Init.initializeAll
-- Initialize the SDL window from our provided engine config.
window <- Video.createWindow (T.pack windowTitle) windowConfig
renderer <- Video.createRenderer window (-1) rendererConfig
texture <- prepTexture windowDimensions renderer
-- Initialize all of the sinks and signals that SDL events will be sunk into.
mouseMoveEvent <- externalMulti
mouseDownEvent <- externalMulti
mouseUpEvent <- externalMulti
mouseClickEvent <- externalMulti
keyboardDownEvent <- externalMulti
keyboardUpEvent <- externalMulti
keyboardPressEvent <- externalMulti
windowResizeEvent <- externalMulti
-- By default the SDL window isn't shown
Video.showWindow window
return SDLEngine
{ window = window
, renderer = renderer
, texture = texture
, engineConfig = config
, lastMousePress = Nothing
, mouseMoveEventSignal = fst mouseMoveEvent
, mouseMoveEventSink = snd mouseMoveEvent
, mouseDownEventSignal = fst mouseDownEvent
, mouseDownEventSink = snd mouseDownEvent
, mouseUpEventSignal = fst mouseUpEvent
, mouseUpEventSink = snd mouseUpEvent
, mouseClickEventSignal = fst mouseClickEvent
, mouseClickEventSink = snd mouseClickEvent
, keyboardDownEventSignal = fst keyboardDownEvent
, keyboardDownEventSink = snd keyboardDownEvent
, keyboardUpEventSignal = fst keyboardUpEvent
, keyboardUpEventSink = snd keyboardUpEvent
, keyboardPressEventSignal = fst keyboardPressEvent
, keyboardPressEventSink = snd keyboardPressEvent
, windowResizeEventSignal = fst windowResizeEvent
, windowResizeEventSink = snd windowResizeEvent
}
where
rendererConfig = Video.RendererConfig Video.AcceleratedVSyncRenderer False
windowConfig = Video.defaultWindow
{ windowInitialSize = fromIntegral <$> windowDimensions
, windowMode = if windowIsFullscreen
then Video.Fullscreen
else Video.Windowed
, windowResizable = windowIsResizable
}
-- | Renders a 2D element to the engine screen.
render2d
:: SDLEngine -- ^ The SDL engine to use for rendering.
-> Graphics2D.Collage SDLEngine -- ^ The collage to render.
-> IO () -- ^ An IO monad that renders the SDL collage.
render2d SDLEngine { window, renderer, texture } coll = do
V2 w h <- SDL.get $ Video.windowSize window
(pixels, pitch) <- Renderer.lockTexture texture Nothing
Cairo.withImageSurfaceForData (castPtr pixels) Cairo.FormatARGB32 (fromIntegral w) (fromIntegral h) (fromIntegral pitch) $ \surface ->
Cairo.renderWith surface $ do
Cairo.setSourceRGB 0 0 0
Cairo.rectangle 0 0 (fromIntegral w) (fromIntegral h)
Cairo.fill
renderCollage coll
Renderer.unlockTexture texture
Renderer.clear renderer
Renderer.copy renderer texture Nothing Nothing
Renderer.present renderer
-- | Render a collage (a group of forms with context).
renderCollage
:: Graphics2D.Collage SDLEngine -- ^ The collage to render.
-> Cairo.Render () -- ^ The render monad result.
renderCollage Graphics2D.Collage { .. } = do
Cairo.save
forM_ collageDims $ \(V2 w h) -> do
Cairo.rectangle 0 0 w h
Cairo.clip
forM_ collageCenter $ \(V2 x y) -> Cairo.translate x y
mapM_ renderForm collageForms
Cairo.restore
-- | Map a 'FontWeight' to a Pango font weight.
mapFontWeight :: FontWeight -> Pango.Weight
mapFontWeight weight = case weight of
LightWeight -> Pango.WeightLight
NormalWeight -> Pango.WeightNormal
BoldWeight -> Pango.WeightBold
-- | Map a 'FontStyle' variant to a Pango font style.
mapFontStyle :: FontStyle -> Pango.FontStyle
mapFontStyle style = case style of
NormalStyle -> Pango.StyleNormal
ObliqueStyle -> Pango.StyleOblique
ItalicStyle -> Pango.StyleItalic
-- | Setup a transformation state, render something with it, and then restore the old state.
withTransform
:: Double -- ^ The x and y scale factor of the state.
-> Double -- ^ The theta rotation of the state, in radians.
-> Double -- ^ The x translation value for the state.
-> Double -- ^ The y translation value for the state.
-> Cairo.Render () -- ^ The render monad to run with the transformation state.
-> Cairo.Render () -- ^ The final render monad.
withTransform s t x y f = do
Cairo.save
Cairo.scale s s
Cairo.translate x y
Cairo.rotate t
f
Cairo.restore
-- | Set the Cairo line cap from a 'LineCap'.
setLineCap
:: Graphics2D.LineCap -- ^ The line cap to use for rendering.
-> Cairo.Render () -- ^ The render monad with the line cap set.
setLineCap cap = case cap of
Graphics2D.FlatCap -> Cairo.setLineCap Cairo.LineCapButt
Graphics2D.RoundCap -> Cairo.setLineCap Cairo.LineCapRound
Graphics2D.PaddedCap -> Cairo.setLineCap Cairo.LineCapSquare
-- | Set the Cairo line join from a 'LineJoin'.
setLineJoin
:: Graphics2D.LineJoin -- ^ The line join to use for rendering.
-> Cairo.Render () -- ^ The render monad with the line join set.
setLineJoin join = case join of
Graphics2D.SmoothJoin -> Cairo.setLineJoin Cairo.LineJoinRound
Graphics2D.ClippedJoin -> Cairo.setLineJoin Cairo.LineJoinBevel
Graphics2D.SharpJoin lim -> do
Cairo.setLineJoin Cairo.LineJoinMiter
Cairo.setMiterLimit lim
-- | Set up all the necessary settings with Cairo
-- to render with a line style (and then stroke the line). Assumes
-- that all drawing paths have already been setup before being called.
setLineStyle
:: Graphics2D.LineStyle -- ^ The line style to use for rendering.
-> Cairo.Render () -- ^ The render monad with the line style set.
setLineStyle Graphics2D.LineStyle { lineColor = Color r g b a, .. } = do
Cairo.setSourceRGBA r g b a
setLineCap lineCap
setLineJoin lineJoin
Cairo.setLineWidth lineWidth
Cairo.setDash lineDashing lineDashOffset
Cairo.stroke
-- | Set up all the necessary settings with Cairo
-- to render with a fill style (and then fill the line). Assumes
-- that all drawing paths have already been setup before being called.
setFillStyle
:: Graphics2D.FillStyle SDLEngine -- ^ The fill style to use for rendering.
-> Cairo.Render () -- ^ The render monad with the fill style set.
setFillStyle (Graphics2D.Solid (Color r g b a)) = do
Cairo.setSourceRGBA r g b a
Cairo.fill
-- Fill with a texture.
setFillStyle (Graphics2D.Texture SDLImage { cairoSurface }) = do
Cairo.setSourceSurface cairoSurface 0 0
Cairo.getSource >>= flip Cairo.patternSetExtend Cairo.ExtendRepeat
Cairo.fill
-- Fill with a linear gradient.
setFillStyle (Graphics2D.Gradient (Linear (sx, sy) (ex, ey) points)) =
Cairo.withLinearPattern sx sy ex ey $ \ptn ->
setGradientFill ptn points
-- Fill with a radial gradient.
setFillStyle (Graphics2D.Gradient (Radial (sx, sy) sr (ex, ey) er points)) =
Cairo.withRadialPattern sx sy sr ex ey er $ \ptn ->
setGradientFill ptn points
-- | Add color stops to a pattern and then fill it.
setGradientFill
:: Cairo.Pattern -- ^ The pattern to set for filling.
-> [(Double, Color)] -- ^ The gradient points to use for filling.
-> Cairo.Render () -- ^ The render monad result.
setGradientFill ptn points = do
Cairo.setSource ptn
mapM_ (\(o, Color r g b a) -> Cairo.patternAddColorStopRGBA ptn o r g b a) points
Cairo.fill
-- | Render a form.
renderForm
:: Graphics2D.Form SDLEngine -- ^ The form to render.
-> Cairo.Render () -- ^ The render monad result.
renderForm Graphics2D.Form { formPos = V2 x y, .. } = withTransform formScale formTheta x y $ do
Cairo.save
case formStyle of
-- Render a path form (a connection of points).
Graphics2D.PathForm style (Graphics2D.Path (~ps @ (V2 hx hy : _))) -> do
Cairo.newPath
Cairo.moveTo hx hy
mapM_ (\(V2 lx ly) -> Cairo.lineTo lx ly) ps
setLineStyle style
-- Render a shape (a multitude generalised path form).
Graphics2D.ShapeForm style shape -> do
Cairo.newPath
case shape of
Graphics2D.PolygonShape (Graphics2D.Path (~ps @ (V2 hx hy : _))) -> do
Cairo.moveTo hx hy
mapM_ (\(V2 lx ly) -> Cairo.lineTo lx ly) (ps ++ [head ps])
Graphics2D.RectangleShape (V2 w h) ->
Cairo.rectangle (-w / 2) (-h / 2) w h
Graphics2D.ArcShape (V2 cx cy) a1 a2 r (V2 sx sy) -> do
Cairo.scale sx sy
Cairo.arc cx cy r a1 a2
case style of
Graphics2D.OutlinedShape ls -> setLineStyle ls
Graphics2D.FilledShape fs -> setFillStyle fs
-- Render a text form using Pango.
Graphics2D.TextForm Text { textColor = Color r g b a, .. } -> do
layout <- Pango.createLayout textString
Cairo.liftIO $ Pango.layoutSetAttributes layout
[ Pango.AttrFamily { paStart = i, paEnd = j, paFamily = T.pack textTypeface }
, Pango.AttrWeight { paStart = i, paEnd = j, paWeight = mapFontWeight textWeight }
, Pango.AttrStyle { paStart = i, paEnd = j, paStyle = mapFontStyle textStyle }
, Pango.AttrSize { paStart = i, paEnd = j, paSize = textHeight }
]
Pango.PangoRectangle tx ty w h <- fmap snd $ Cairo.liftIO $ Pango.layoutGetExtents layout
Cairo.translate ((-w / 2) - tx) ((-h / 2) - ty)
Cairo.setSourceRGBA r g b a
Pango.showLayout layout
where
i = 0
j = length textString
-- Render an image form.
Graphics2D.ImageForm SDLImage { imageDims = V2 w h, .. } (V2 sx sy) (V2 sw sh) stretch -> do
Cairo.translate (-sx) (-sy)
if stretch then
Cairo.scale (sw / fromIntegral w)
(sh / fromIntegral h)
else
Cairo.scale 1 1
Cairo.setSourceSurface cairoSurface 0 0
Cairo.translate sx sy
Cairo.rectangle 0 0 sw sh
if stretch then
Cairo.paint
else
Cairo.fill
-- Render a group of other forms using a transform.
Graphics2D.GroupForm (Graphics2D.Transform (V3 (V3 a b lx) (V3 c d ly) _)) forms -> do
Cairo.transform $ Matrix a b c d lx ly
mapM_ renderForm forms
-- Render a collage within a collage.
Graphics2D.CollageForm coll -> renderCollage coll
Cairo.restore
-- | Turns a point containing a vector into a regular vector.
depoint :: Point f a -> f a
depoint (P x) = x
-- | Sink an SDL event into the Elerea sinks initialized at startup of the SDL engine.
--
-- These sinks then provide the data for the Elerea signals, which will be in
-- turn will provide the Helm subscriptions with events.
sinkEvent
:: SDLEngine -- ^ The SDL engine to sink events into.
-> Event.EventPayload -- ^ The SDL event payload to sink.
-> IO SDLEngine -- ^ An IO-monad that produces the SDL engine with its events sunk.
sinkEvent engine (Event.WindowResizedEvent Event.WindowResizedEventData { .. }) = do
windowResizeEventSink engine dims
Renderer.destroyTexture texture
-- Create a new texture with the correct size matching the window dims.
resized <- prepTexture dims renderer
return engine { texture = resized }
where
dims = fromIntegral <$> windowResizedEventSize
SDLEngine { texture, renderer } = engine
-- Sink mouse motion events as mouse moves.
sinkEvent engine (Event.MouseMotionEvent Event.MouseMotionEventData { .. }) = do
mouseMoveEventSink engine $ fromIntegral <$> depoint mouseMotionEventPos
return engine
-- Sink keyboard events into the relevant Elerea sinks.
--
-- Note that keyboard up and press are the same for the time being.
-- This may change in the future.
sinkEvent engine (Event.KeyboardEvent Event.KeyboardEventData { .. }) =
case keyboardEventKeyMotion of
Event.Pressed -> do
keyboardDownEventSink engine key
if keyboardEventRepeat
then keyboardPressEventSink engine key >> return engine
else return engine
Event.Released -> do
keyboardUpEventSink engine key
keyboardPressEventSink engine key
return engine
where
Keysym { .. } = keyboardEventKeysym
key = mapKey keysymKeycode
-- Sink mouse events into the relevant Elerea sinks.
sinkEvent engine (Event.MouseButtonEvent Event.MouseButtonEventData { .. }) =
case mouseButtonEventMotion of
Event.Pressed -> do
ticks <- Time.ticks
mouseDownEventSink engine tup
return engine { lastMousePress = Just (ticks, dubPos) }
Event.Released -> do
mouseUpEventSink engine tup
-- Weirdly enough, SDL provides a value that says how many clicks there
-- were, but this value is always set to one even if it's just a regular
-- mouse up event. Note that here we're defining a click as a mouse up
-- event being in a very close proximity to a previous mouse down event.
-- We manually calculate whether this was a click or not.
case lastMousePress of
Just (lastTicks, lastPos) -> do
ticks <- Time.ticks
-- Check that it's a expected amount of time for a click and that the mouse
-- has basically stayed in place
when (distance dubPos lastPos <= clickRadius && ticks - lastTicks < clickMs)
(mouseClickEventSink engine tup)
Nothing -> return ()
return engine
where
SDLEngine { lastMousePress } = engine
clickMs = 500 -- How long between mouse down/up to recognise clicks
clickRadius = 3 -- The pixel radius to be considered a click.
pos = depoint mouseButtonEventPos
dubPos = fromIntegral <$> pos
tup = (mapMouseButton mouseButtonEventButton, fromIntegral <$> pos)
-- Don't sink other events.
sinkEvent engine _ = return engine

214
src/Helm/Engine/SDL/Graphics2D.hs
View File

@ -1,214 +0,0 @@
-- | Contains the SDL implementation 2D graphics rendering implementation.
--
-- The SDL engine uses Cairo for its 2D vector graphics, which is hardware accelerated
-- and generally pretty fast.
module Helm.Engine.SDL.Graphics2D (render) where
import Data.Foldable (forM_)
import Foreign.C.Types (CInt)
import Foreign.Ptr (castPtr)
import qualified Data.Text as T
import qualified Graphics.Rendering.Cairo as Cairo
import qualified Graphics.Rendering.Pango as Pango
import Graphics.Rendering.Cairo.Matrix (Matrix(..))
import Linear.V2 (V2(V2))
import Linear.V3 (V3(V3))
import qualified SDL.Video.Renderer as Renderer
import Helm.Color (Color(..), Gradient(..))
import Helm.Engine.SDL.Asset (Image(..))
import Helm.Engine.SDL.Engine (SDLEngine)
import Helm.Graphics2D
import Helm.Graphics2D.Text
-- | Render a 2D element to an SDL texture (with a width and height).
render :: Renderer.Texture -> V2 CInt -> Collage SDLEngine -> IO ()
render tex (V2 w h) coll = do
(pixels, pitch) <- Renderer.lockTexture tex Nothing
Cairo.withImageSurfaceForData (castPtr pixels) Cairo.FormatARGB32 (fromIntegral w) (fromIntegral h) (fromIntegral pitch) $ \surface ->
Cairo.renderWith surface $ do
Cairo.setSourceRGB 0 0 0
Cairo.rectangle 0 0 (fromIntegral w) (fromIntegral h)
Cairo.fill
renderCollage coll
Renderer.unlockTexture tex
-- | Render a collage (a group of forms with context).
renderCollage :: Collage SDLEngine -> Cairo.Render ()
renderCollage Collage { .. } = do
Cairo.save
forM_ collageDims $ \(V2 w h) -> do
Cairo.rectangle 0 0 w h
Cairo.clip
forM_ collageCenter $ \(V2 x y) -> Cairo.translate x y
mapM_ renderForm collageForms
Cairo.restore
-- | Map a 'FontWeight' to a Pango font weight.
mapFontWeight :: FontWeight -> Pango.Weight
mapFontWeight weight = case weight of
LightWeight -> Pango.WeightLight
NormalWeight -> Pango.WeightNormal
BoldWeight -> Pango.WeightBold
-- | Map a 'FontStyle' variant to a Pango font style.
mapFontStyle :: FontStyle -> Pango.FontStyle
mapFontStyle style = case style of
NormalStyle -> Pango.StyleNormal
ObliqueStyle -> Pango.StyleOblique
ItalicStyle -> Pango.StyleItalic
-- | Setup a transformation state, render something with it, and then restore the old state.
withTransform
:: Double -- ^ The x and y scale factor of the state.
-> Double -- ^ The theta rotation of the state, in radians.
-> Double -- ^ The x translation value for the state.
-> Double -- ^ The y translation value for the state.
-> Cairo.Render () -- ^ The render monad to run with the transformation state.
-> Cairo.Render () -- ^ The final render monad.
withTransform s t x y f = do
Cairo.save
Cairo.scale s s
Cairo.translate x y
Cairo.rotate t
f
Cairo.restore
-- | Set the Cairo line cap from a 'LineCap'.
setLineCap :: LineCap -> Cairo.Render ()
setLineCap cap = case cap of
FlatCap -> Cairo.setLineCap Cairo.LineCapButt
RoundCap -> Cairo.setLineCap Cairo.LineCapRound
PaddedCap -> Cairo.setLineCap Cairo.LineCapSquare
-- | Set the Cairo line join from a 'LineJoin'.
setLineJoin :: LineJoin -> Cairo.Render ()
setLineJoin join = case join of
SmoothJoin -> Cairo.setLineJoin Cairo.LineJoinRound
ClippedJoin -> Cairo.setLineJoin Cairo.LineJoinBevel
SharpJoin lim -> do Cairo.setLineJoin Cairo.LineJoinMiter
Cairo.setMiterLimit lim
-- | Set up all the necessary settings with Cairo
-- to render with a line style (and then stroke the line). Assumes
-- that all drawing paths have already been setup before being called.
setLineStyle :: LineStyle -> Cairo.Render ()
setLineStyle LineStyle { lineColor = Color r g b a, .. } = do
Cairo.setSourceRGBA r g b a
setLineCap lineCap
setLineJoin lineJoin
Cairo.setLineWidth lineWidth
Cairo.setDash lineDashing lineDashOffset
Cairo.stroke
-- | Set up all the necessary settings with Cairo
-- to render with a fill style (and then fill the line). Assumes
-- that all drawing paths have already been setup before being called.
setFillStyle :: FillStyle SDLEngine -> Cairo.Render ()
setFillStyle (Solid (Color r g b a)) = do
Cairo.setSourceRGBA r g b a
Cairo.fill
setFillStyle (Texture SDLImage { cairoSurface }) = do
Cairo.setSourceSurface cairoSurface 0 0
Cairo.getSource >>= flip Cairo.patternSetExtend Cairo.ExtendRepeat
Cairo.fill
setFillStyle (Gradient (Linear (sx, sy) (ex, ey) points)) =
Cairo.withLinearPattern sx sy ex ey $ \ptn ->
setGradientFill ptn points
setFillStyle (Gradient (Radial (sx, sy) sr (ex, ey) er points)) =
Cairo.withRadialPattern sx sy sr ex ey er $ \ptn ->
setGradientFill ptn points
-- | Add color stops to a pattern and then fill it.
setGradientFill :: Cairo.Pattern -> [(Double, Color)] -> Cairo.Render ()
setGradientFill ptn points = do
Cairo.setSource ptn
mapM_ (\(o, Color r g b a) -> Cairo.patternAddColorStopRGBA ptn o r g b a) points
Cairo.fill
-- | Render a form.
renderForm :: Form SDLEngine -> Cairo.Render ()
renderForm Form { formPos = V2 x y, .. } = withTransform formScale formTheta x y $ do
Cairo.save
case formStyle of
PathForm style (Path (~ps @ (V2 hx hy : _))) -> do
Cairo.newPath
Cairo.moveTo hx hy
mapM_ (\(V2 lx ly) -> Cairo.lineTo lx ly) ps
setLineStyle style
ShapeForm style shape -> do
Cairo.newPath
case shape of
PolygonShape (Path (~ps @ (V2 hx hy : _))) -> do
Cairo.moveTo hx hy
mapM_ (\(V2 lx ly) -> Cairo.lineTo lx ly) (ps ++ [head ps])
RectangleShape (V2 w h) ->
Cairo.rectangle (-w / 2) (-h / 2) w h
ArcShape (V2 cx cy) a1 a2 r (V2 sx sy) -> do
Cairo.scale sx sy
Cairo.arc cx cy r a1 a2
case style of
OutlinedShape ls -> setLineStyle ls
FilledShape fs -> setFillStyle fs
TextForm Text { textColor = Color r g b a, .. } -> do
layout <- Pango.createLayout textString
Cairo.liftIO $ Pango.layoutSetAttributes layout
[ Pango.AttrFamily { paStart = i, paEnd = j, paFamily = T.pack textTypeface }
, Pango.AttrWeight { paStart = i, paEnd = j, paWeight = mapFontWeight textWeight }
, Pango.AttrStyle { paStart = i, paEnd = j, paStyle = mapFontStyle textStyle }
, Pango.AttrSize { paStart = i, paEnd = j, paSize = textHeight }
]
Pango.PangoRectangle tx ty w h <- fmap snd $ Cairo.liftIO $ Pango.layoutGetExtents layout
Cairo.translate ((-w / 2) - tx) ((-h / 2) - ty)
Cairo.setSourceRGBA r g b a
Pango.showLayout layout
where
i = 0
j = length textString
ImageForm SDLImage { imageDims = V2 w h, .. } (V2 sx sy) (V2 sw sh) stretch -> do
Cairo.translate (-sx) (-sy)
if stretch then
Cairo.scale (sw / fromIntegral w)
(sh / fromIntegral h)
else
Cairo.scale 1 1
Cairo.setSourceSurface cairoSurface 0 0
Cairo.translate sx sy
Cairo.rectangle 0 0 sw sh
if stretch then
Cairo.paint
else
Cairo.fill
GroupForm (Transform (V3 (V3 a b lx) (V3 c d ly) _)) forms -> do
Cairo.transform $ Matrix a b c d lx ly
mapM_ renderForm forms
CollageForm coll -> renderCollage coll
Cairo.restore

2
stack.yaml
View File

@ -5,4 +5,4 @@ extra-deps:
- elerea-2.9.0
- text-1.2.2.0
- sdl2-2.1.3
resolver: lts-5.5
resolver: lts-8.18