mirror of
https://github.com/z0w0/helm.git
synced 2024-09-11 04:15:32 +03:00
Further rework on the engine.
Moved away from forkIO'ing commands, instead there'll be an actor user function that is forkIO'd once. Additionally, start work on all of the new event sinking, esp. keyboard & mouse.
This commit is contained in:
parent
844f551e90
commit
2e05198eda
1
.gitignore
vendored
1
.gitignore
vendored
@ -5,3 +5,4 @@ dist
|
||||
*.hi
|
||||
cabal.sandbox.config
|
||||
.cabal-sandbox/
|
||||
.stack-work
|
||||
|
@ -1,31 +1,37 @@
|
||||
import Linear.V2 (V2(V2))
|
||||
|
||||
import Helm
|
||||
import Helm.Color
|
||||
import Helm.Engine.SDL (SDLEngine)
|
||||
import Helm.Graphics2D
|
||||
import Helm.Render.Cairo (render)
|
||||
|
||||
import qualified Helm.Cmd as Cmd
|
||||
import qualified Helm.Mouse as Mouse
|
||||
import qualified Helm.Sub as Sub
|
||||
import qualified Helm.Engine.SDL as SDL
|
||||
|
||||
data Action = Idle | ChangeDirection (Double, Double)
|
||||
data Action = Idle | ChangePosition (Double, Double)
|
||||
data Model = Model (Double, Double)
|
||||
|
||||
initial :: (Model, Cmd Action)
|
||||
initial :: (Model, Cmd SDLEngine Action)
|
||||
initial = (Model (0, 0), Cmd.none)
|
||||
|
||||
update :: Model -> Action -> (Model, Cmd Action)
|
||||
update model _ = (model, Cmd.none)
|
||||
update :: Model -> Action -> (Model, Cmd SDLEngine Action)
|
||||
update model Idle = (model, Cmd.none)
|
||||
update model (ChangePosition pos) = (Model pos, Cmd.none)
|
||||
|
||||
subscriptions :: Sub Action
|
||||
subscriptions = Sub.none
|
||||
subscriptions :: Sub SDLEngine Action
|
||||
subscriptions = Mouse.moves (\(V2 x y) -> ChangePosition (fromIntegral x, fromIntegral y))
|
||||
|
||||
view :: Model -> Render ()
|
||||
view model = render $ collage 800 600 []
|
||||
view :: Model -> Graphics
|
||||
view (Model pos) = Graphics2D $ collage 800 600 [move pos $ filled (rgb 1 0 0) $ rect 10 10]
|
||||
|
||||
main = do
|
||||
engine <- startup
|
||||
engine <- SDL.startup
|
||||
|
||||
run engine $ GameConfig {
|
||||
initialFn = initial,
|
||||
updateFn = update,
|
||||
subscriptionsFn = subscriptions,
|
||||
viewFn = view
|
||||
}
|
||||
run engine GameConfig
|
||||
{ initialFn = initial
|
||||
, updateFn = update
|
||||
, subscriptionsFn = subscriptions
|
||||
, viewFn = view
|
||||
}
|
||||
|
21
helm.cabal
21
helm.cabal
@ -7,7 +7,7 @@ homepage: http://github.com/switchface/helm
|
||||
bug-reports: http://github.com/switchface/helm/issues
|
||||
license: MIT
|
||||
license-file: LICENSE
|
||||
tested-with: GHC == 7.10.3
|
||||
tested-with: GHC == 8.0.1
|
||||
extra-source-files: LICENSE, README.md
|
||||
author: Zack Corr
|
||||
maintainer: Zack Corr <zack@z0w0.me>
|
||||
@ -24,21 +24,24 @@ library
|
||||
hs-source-dirs: src
|
||||
default-language: Haskell2010
|
||||
default-extensions: RecordWildCards, NamedFieldPuns
|
||||
ghc-options: -Wall -fno-warn-unused-do-bind
|
||||
ghc-options: -Wall
|
||||
|
||||
exposed-modules:
|
||||
Helm
|
||||
Helm.Asset
|
||||
Helm.Cmd
|
||||
Helm.Color
|
||||
Helm.Engine
|
||||
Helm.Game
|
||||
Helm.Engine.SDL
|
||||
Helm.Engine.SDL.Graphics2D
|
||||
Helm.Engine.SDL.Keyboard
|
||||
Helm.Engine.SDL.Mouse
|
||||
Helm.Graphics
|
||||
Helm.Graphics2D
|
||||
Helm.Graphics2D.Text
|
||||
Helm.Graphics2D.Transform
|
||||
Helm.Keyboard
|
||||
Helm.Mouse
|
||||
Helm.Render
|
||||
Helm.Render.Cairo
|
||||
Helm.Sub
|
||||
Helm.Time
|
||||
Helm.Window
|
||||
@ -48,7 +51,7 @@ library
|
||||
cairo >= 0.13 && < 0.14,
|
||||
pango >= 0.13 && < 0.14,
|
||||
containers >= 0.5 && < 1,
|
||||
elerea >= 2.7 && < 3,
|
||||
elerea >= 2.8 && < 3,
|
||||
sdl2 >= 2 && < 3,
|
||||
linear >= 1 && < 2,
|
||||
text >= 1.1.1.3 && < 2,
|
||||
@ -60,12 +63,14 @@ library
|
||||
build-depends: ghc-prim
|
||||
|
||||
executable helm-example-hello
|
||||
default-language: Haskell2010
|
||||
main-is: Main.hs
|
||||
hs-source-dirs: examples/hello
|
||||
|
||||
build-depends:
|
||||
base >= 4 && < 5,
|
||||
helm >= 1 && < 2
|
||||
helm >= 1 && < 2,
|
||||
linear >= 1 && < 2
|
||||
|
||||
test-suite helm-tests
|
||||
type: exitcode-stdio-1.0
|
||||
@ -78,7 +83,7 @@ test-suite helm-tests
|
||||
build-depends:
|
||||
base >= 4 && < 5,
|
||||
containers >= 0.5 && < 1,
|
||||
elerea >= 2.7 && < 3,
|
||||
elerea >= 2.8 && < 3,
|
||||
sdl2 >= 2 && < 3,
|
||||
HUnit >= 1.2 && < 2,
|
||||
test-framework >= 0.8 && < 1,
|
||||
|
140
src/Helm.hs
140
src/Helm.hs
@ -1,129 +1,17 @@
|
||||
{-| Contains the main functions for interfacing with the engine. -}
|
||||
module Helm (
|
||||
-- * Types
|
||||
Render(..),
|
||||
Engine,
|
||||
EngineConfig(..),
|
||||
Game,
|
||||
GameConfig(..),
|
||||
Cmd(..),
|
||||
Sub(..),
|
||||
-- * Engine
|
||||
startup,
|
||||
startupWith,
|
||||
run
|
||||
) where
|
||||
|
||||
import Control.Concurrent
|
||||
import Control.Concurrent.STM
|
||||
import Control.Exception (finally)
|
||||
import Control.Monad (foldM, forM_, void)
|
||||
import Control.Monad.Trans.State (evalStateT)
|
||||
import FRP.Elerea.Param
|
||||
import Linear.V2 (V2(V2))
|
||||
|
||||
import SDL.Event
|
||||
import SDL.Video (WindowConfig(..))
|
||||
import qualified SDL.Init as Init
|
||||
import qualified SDL.Video as Video
|
||||
import qualified Data.Text as T
|
||||
|
||||
import Helm.Cmd (Cmd(..))
|
||||
import Helm.Engine
|
||||
import Helm.Game
|
||||
import Helm.Render (Render(..))
|
||||
import Helm.Sub (Sub(..))
|
||||
|
||||
{-| Initialises a new engine with default configuration.
|
||||
The engine can then be run later using 'run'. -}
|
||||
startup :: IO Engine
|
||||
startup = startupWith defaultConfig
|
||||
|
||||
{-| Initializes a new engine with some configration. -}
|
||||
startupWith :: EngineConfig -> IO Engine
|
||||
startupWith config@(EngineConfig { .. }) = do
|
||||
Init.initializeAll
|
||||
|
||||
window <- Video.createWindow (T.pack windowTitle) windowConfig
|
||||
renderer <- Video.createRenderer window (-1) rendererConfig
|
||||
|
||||
Video.showWindow window
|
||||
|
||||
return Engine {
|
||||
window = window,
|
||||
renderer = renderer,
|
||||
engineConfig = config
|
||||
}
|
||||
|
||||
module Helm
|
||||
(
|
||||
-- * Types
|
||||
Engine
|
||||
,GameConfig(..)
|
||||
,Cmd(..)
|
||||
,Sub(..)
|
||||
,Graphics(..)
|
||||
-- * Engine
|
||||
,run
|
||||
,loadImage
|
||||
,loadSound)
|
||||
where
|
||||
(w, h) = windowDimensions
|
||||
rendererConfig = Video.RendererConfig Video.AcceleratedVSyncRenderer False
|
||||
windowConfig = Video.defaultWindow {
|
||||
windowInitialSize = V2 (fromIntegral w) (fromIntegral h),
|
||||
windowMode = if windowIsFullscreen then Video.Fullscreen else Video.Windowed,
|
||||
windowResizable = windowIsResizable
|
||||
}
|
||||
|
||||
prepare :: GameConfig m a -> IO (Game m a)
|
||||
prepare config = do
|
||||
smp <- start $ signalGen $ subscriptionsFn config
|
||||
queue <- newTQueueIO
|
||||
|
||||
return Game {
|
||||
gameConfig = config,
|
||||
gameModel = fst $ initialFn config,
|
||||
actionSmp = smp,
|
||||
actionQueue = queue
|
||||
}
|
||||
|
||||
where
|
||||
signalGen (Sub gen) = gen
|
||||
|
||||
dequeueCmds :: Game m a -> IO [a]
|
||||
dequeueCmds game = atomically dequeue
|
||||
where
|
||||
dequeue = do
|
||||
x <- tryReadTQueue (actionQueue game)
|
||||
|
||||
case x of
|
||||
Nothing -> return []
|
||||
Just action -> do
|
||||
xs <- dequeue
|
||||
|
||||
return $ action : xs
|
||||
|
||||
queueCmd :: Engine -> Game m a -> Cmd a -> IO ()
|
||||
queueCmd engine game (Cmd monad) = void $ forkIO $ do
|
||||
actions <- evalStateT monad engine
|
||||
|
||||
atomically $ forM_ actions (writeTQueue $ actionQueue game)
|
||||
|
||||
run :: Engine -> GameConfig m a -> IO ()
|
||||
run engine config = do
|
||||
game <- prepare config
|
||||
|
||||
queueCmd engine game $ snd $ initialFn config
|
||||
tick engine game `finally` Init.quit
|
||||
|
||||
tick :: Engine -> Game m a -> IO ()
|
||||
tick engine game = do
|
||||
actions <- (++) <$> actionSmp game engine <*> dequeueCmds game
|
||||
stepped <- foldM (step engine game) (gameModel game) actions
|
||||
|
||||
render engine game stepped
|
||||
tick engine $ game { gameModel = stepped }
|
||||
|
||||
step :: Engine -> Game m a -> m -> a -> IO m
|
||||
step engine game model action = do
|
||||
queueCmd engine game $ snd result
|
||||
|
||||
return $ fst result
|
||||
|
||||
where
|
||||
result = (updateFn $ gameConfig game) model action
|
||||
|
||||
render :: Engine -> Game m a -> m -> IO ()
|
||||
render engine game model = evalStateT monad engine >> return ()
|
||||
where
|
||||
Game { gameConfig = GameConfig { viewFn } } = game
|
||||
Render monad = viewFn model
|
||||
import Helm.Engine (Cmd(..), Sub(..), GameConfig(..), Engine(run, loadImage, loadSound))
|
||||
import Helm.Graphics
|
||||
|
1
src/Helm/.#Engine.hs
Symbolic link
1
src/Helm/.#Engine.hs
Symbolic link
@ -0,0 +1 @@
|
||||
zack@zarch.9208:1472817273
|
9
src/Helm/Asset.hs
Normal file
9
src/Helm/Asset.hs
Normal file
@ -0,0 +1,9 @@
|
||||
{-| Contains the types for loading game assets, e.g. images, audio, etc. -}
|
||||
module Helm.Asset (
|
||||
-- * Types
|
||||
Image(..),
|
||||
Sound(..)
|
||||
) where
|
||||
|
||||
newtype Image = Image ()
|
||||
newtype Sound = Sound ()
|
@ -1,4 +1,4 @@
|
||||
{-| Contains the command type and related utilities. -}
|
||||
{-| Contains the command related utilities. -}
|
||||
module Helm.Cmd (
|
||||
-- * Types
|
||||
Cmd(..),
|
||||
@ -9,22 +9,19 @@ module Helm.Cmd (
|
||||
) where
|
||||
|
||||
import Control.Monad.Trans.Class (lift)
|
||||
import Control.Monad.Trans.State (StateT)
|
||||
|
||||
import Helm.Engine (Engine)
|
||||
import Helm.Engine (Engine, Cmd(..))
|
||||
|
||||
data Cmd a = Cmd (StateT Engine IO [a])
|
||||
|
||||
batch :: [Cmd a] -> Cmd a
|
||||
batch :: Engine e => [Cmd e a] -> Cmd e a
|
||||
batch cmds = Cmd $ do
|
||||
lists <- sequence $ map (\(Cmd monad) -> monad) cmds
|
||||
lists <- mapM (\(Cmd m) -> m) cmds
|
||||
|
||||
return $ concat lists
|
||||
|
||||
none :: Cmd a
|
||||
none :: Engine e => Cmd e a
|
||||
none = Cmd $ return []
|
||||
|
||||
execute :: IO a -> (a -> b) -> Cmd b
|
||||
execute :: Engine e => IO a -> (a -> b) -> Cmd e b
|
||||
execute monad f = Cmd $ do
|
||||
result <- f <$> lift monad
|
||||
|
||||
|
@ -1,36 +1,296 @@
|
||||
{-| Contains the core engine types and typeclasses. -}
|
||||
module Helm.Engine (
|
||||
-- * Types
|
||||
EngineConfig(..),
|
||||
-- * Typeclasses
|
||||
Engine(..),
|
||||
-- * Setup
|
||||
defaultConfig
|
||||
-- * Types
|
||||
Cmd(..),
|
||||
GameConfig(..),
|
||||
Sub(..),
|
||||
MouseButton(..),
|
||||
Key(..)
|
||||
) where
|
||||
|
||||
import qualified SDL.Video as Video
|
||||
import Control.Monad.Trans.State (StateT)
|
||||
import FRP.Elerea.Param (SignalGen, Signal)
|
||||
import Linear.V2 (V2)
|
||||
|
||||
{-| A data structure describing how to run the engine. -}
|
||||
data EngineConfig = EngineConfig {
|
||||
windowDimensions :: (Int, Int),
|
||||
windowIsFullscreen :: Bool,
|
||||
windowIsResizable :: Bool,
|
||||
windowTitle :: String,
|
||||
windowQuitOnClose :: Bool
|
||||
import Helm.Asset
|
||||
import Helm.Graphics (Graphics)
|
||||
|
||||
class Engine e where
|
||||
loadImage :: e -> IO Image
|
||||
loadSound :: e -> IO Sound
|
||||
run :: e -> GameConfig e m a -> IO ()
|
||||
|
||||
windowSize :: e -> IO (V2 Int)
|
||||
|
||||
mouseMoveSignal :: e -> SignalGen e (Signal [V2 Int])
|
||||
mouseDownSignal :: e -> SignalGen e (Signal [(MouseButton, V2 Int)])
|
||||
mouseUpSignal :: e -> SignalGen e (Signal [(MouseButton, V2 Int)])
|
||||
mouseClickSignal :: e -> SignalGen e (Signal [(MouseButton, V2 Int)])
|
||||
keyboardDownSignal :: e -> SignalGen e (Signal [Key])
|
||||
keyboardUpSignal :: e -> SignalGen e (Signal [Key])
|
||||
keyboardPressSignal :: e -> SignalGen e (Signal [Key])
|
||||
windowResizeSignal :: e -> SignalGen e (Signal [V2 Int])
|
||||
|
||||
data Cmd e a = Cmd (StateT e IO [a])
|
||||
|
||||
data Sub e a = Sub (SignalGen e (Signal [a]))
|
||||
|
||||
{-| A data structure describing how to run a game. -}
|
||||
data GameConfig e m a = GameConfig {
|
||||
initialFn :: (m, Cmd e a),
|
||||
updateFn :: m -> a -> (m, Cmd e a),
|
||||
subscriptionsFn :: Sub e a,
|
||||
viewFn :: m -> Graphics
|
||||
}
|
||||
|
||||
{-| A data structure describing the game engine's state. -}
|
||||
data Engine = Engine {
|
||||
window :: Video.Window,
|
||||
renderer :: Video.Renderer,
|
||||
engineConfig :: EngineConfig
|
||||
}
|
||||
-- Mostly matches the SDL structure, except we don't care about extra buttons (for now).
|
||||
data MouseButton
|
||||
= LeftButton
|
||||
| MiddleButton
|
||||
| RightButton
|
||||
| X1Button
|
||||
| X2Button
|
||||
| UnknownButton
|
||||
deriving (Eq, Ord, Read, Show)
|
||||
|
||||
{-| Creates the default configuration for the engine. You should change the
|
||||
values where necessary. -}
|
||||
defaultConfig :: EngineConfig
|
||||
defaultConfig = EngineConfig {
|
||||
windowDimensions = (800, 600),
|
||||
windowIsFullscreen = False,
|
||||
windowIsResizable = True,
|
||||
windowTitle = "",
|
||||
windowQuitOnClose = True
|
||||
}
|
||||
-- Matches the SDL structure, but with clearer constructor names.
|
||||
data Key
|
||||
= ReturnKey
|
||||
| EscapeKey
|
||||
| BackspaceKey
|
||||
| TabKey
|
||||
| SpaceKey
|
||||
| ExclaimKey
|
||||
| QuoteDblKey
|
||||
| HashKey
|
||||
| PercentKey
|
||||
| DollarKey
|
||||
| AmpersandKey
|
||||
| QuoteKey
|
||||
| LeftParenKey
|
||||
| RightParenKey
|
||||
| AsteriskKey
|
||||
| PlusKey
|
||||
| CommaKey
|
||||
| MinusKey
|
||||
| PeriodKey
|
||||
| SlashKey
|
||||
| Number0Key
|
||||
| Number1Key
|
||||
| Number2Key
|
||||
| Number3Key
|
||||
| Number4Key
|
||||
| Number5Key
|
||||
| Number6Key
|
||||
| Number7Key
|
||||
| Number8Key
|
||||
| Number9Key
|
||||
| ColonKey
|
||||
| SemicolonKey
|
||||
| LessKey
|
||||
| EqualsKey
|
||||
| GreaterKey
|
||||
| QuestionKey
|
||||
| AtKey
|
||||
| LeftBracketKey
|
||||
| BackslashKey
|
||||
| RightBracketKey
|
||||
| CaretKey
|
||||
| UnderscoreKey
|
||||
| BackquoteKey
|
||||
| AKey
|
||||
| BKey
|
||||
| CKey
|
||||
| DKey
|
||||
| EKey
|
||||
| FKey
|
||||
| GKey
|
||||
| HKey
|
||||
| IKey
|
||||
| JKey
|
||||
| KKey
|
||||
| LKey
|
||||
| MKey
|
||||
| NKey
|
||||
| OKey
|
||||
| PKey
|
||||
| QKey
|
||||
| RKey
|
||||
| SKey
|
||||
| TKey
|
||||
| UKey
|
||||
| VKey
|
||||
| WKey
|
||||
| XKey
|
||||
| YKey
|
||||
| ZKey
|
||||
| CapsLockKey
|
||||
| F1Key
|
||||
| F2Key
|
||||
| F3Key
|
||||
| F4Key
|
||||
| F5Key
|
||||
| F6Key
|
||||
| F7Key
|
||||
| F8Key
|
||||
| F9Key
|
||||
| F10Key
|
||||
| F11Key
|
||||
| F12Key
|
||||
| PrintScreenKey
|
||||
| ScrollLockKey
|
||||
| PauseKey
|
||||
| InsertKey
|
||||
| HomeKey
|
||||
| PageUpKey
|
||||
| DeleteKey
|
||||
| EndKey
|
||||
| PageDownKey
|
||||
| RightKey
|
||||
| LeftKey
|
||||
| DownKey
|
||||
| UpKey
|
||||
| NumLockClearKey
|
||||
| KeypadDivideKey
|
||||
| KeypadMultiplyKey
|
||||
| KeypadMinusKey
|
||||
| KeypadPlusKey
|
||||
| KeypadEnterKey
|
||||
| Keypad1Key
|
||||
| Keypad2Key
|
||||
| Keypad3Key
|
||||
| Keypad4Key
|
||||
| Keypad5Key
|
||||
| Keypad6Key
|
||||
| Keypad7Key
|
||||
| Keypad8Key
|
||||
| Keypad9Key
|
||||
| Keypad0Key
|
||||
| KeypadPeriodKey
|
||||
| ApplicationKey
|
||||
| PowerKey
|
||||
| KeypadEqualsKey
|
||||
| F13Key
|
||||
| F14Key
|
||||
| F15Key
|
||||
| F16Key
|
||||
| F17Key
|
||||
| F18Key
|
||||
| F19Key
|
||||
| F20Key
|
||||
| F21Key
|
||||
| F22Key
|
||||
| F23Key
|
||||
| F24Key
|
||||
| ExecuteKey
|
||||
| HelpKey
|
||||
| MenuKey
|
||||
| SelectKey
|
||||
| StopKey
|
||||
| AgainKey
|
||||
| UndoKey
|
||||
| CutKey
|
||||
| CopyKey
|
||||
| PasteKey
|
||||
| FindKey
|
||||
| MuteKey
|
||||
| VolumeUpKey
|
||||
| VolumeDownKey
|
||||
| KeypadCommaKey
|
||||
| KeypadEqualsAS400Key
|
||||
| AltEraseKey
|
||||
| SysReqKey
|
||||
| CancelKey
|
||||
| ClearKey
|
||||
| PriorKey
|
||||
| Return2Key
|
||||
| SeparatorKey
|
||||
| OutKey
|
||||
| OperKey
|
||||
| ClearAgainKey
|
||||
| CrSelKey
|
||||
| ExSelKey
|
||||
| Keypad00Key
|
||||
| Keypad000Key
|
||||
| ThousandsSeparatorKey
|
||||
| DecimalSeparatorKey
|
||||
| CurrencyUnitKey
|
||||
| CurrencySubunitKey
|
||||
| KeypadLeftParenKey
|
||||
| KeypadRightParenKey
|
||||
| KeypadLeftBraceKey
|
||||
| KeypadRightBraceKey
|
||||
| KeypadTabKey
|
||||
| KeypadBackspaceKey
|
||||
| KeypadAKey
|
||||
| KeypadBKey
|
||||
| KeypadCKey
|
||||
| KeypadDKey
|
||||
| KeypadEKey
|
||||
| KeypadFKey
|
||||
| KeypadXorKey
|
||||
| KeypadPowerKey
|
||||
| KeypadPercentKey
|
||||
| KeypadLessKey
|
||||
| KeypadGreaterKey
|
||||
| KeypadAmpersandKey
|
||||
| KeypadDblAmpersandKey
|
||||
| KeypadVerticalBarKey
|
||||
| KeypadDblVerticalBarKey
|
||||
| KeypadColonKey
|
||||
| KeypadHashKey
|
||||
| KeypadSpaceKey
|
||||
| KeypadAtKey
|
||||
| KeypadExclamKey
|
||||
| KeypadMemStoreKey
|
||||
| KeypadMemRecallKey
|
||||
| KeypadMemClearKey
|
||||
| KeypadMemAddKey
|
||||
| KeypadMemSubtractKey
|
||||
| KeypadMemMultiplyKey
|
||||
| KeypadMemDivideKey
|
||||
| KeypadPlusMinusKey
|
||||
| KeypadClearKey
|
||||
| KeypadClearEntryKey
|
||||
| KeypadBinaryKey
|
||||
| KeypadOctalKey
|
||||
| KeypadDecimalKey
|
||||
| KeypadHexadecimalKey
|
||||
| LeftCtrlKey
|
||||
| LeftShiftKey
|
||||
| LeftAltKey
|
||||
| LeftGUIKey
|
||||
| RightCtrlKey
|
||||
| RightShiftKey
|
||||
| RightAltKey
|
||||
| RightGUIKey
|
||||
| ModeKey
|
||||
| AudioNextKey
|
||||
| AudioPrevKey
|
||||
| AudioStopKey
|
||||
| AudioPlayKey
|
||||
| AudioMuteKey
|
||||
| MediaSelectKey
|
||||
| WWWKey
|
||||
| MailKey
|
||||
| CalculatorKey
|
||||
| ComputerKey
|
||||
| ACSearchKey
|
||||
| ACHomeKey
|
||||
| ACBackKey
|
||||
| ACForwardKey
|
||||
| ACStopKey
|
||||
| ACRefreshKey
|
||||
| ACBookmarksKey
|
||||
| BrightnessDownKey
|
||||
| BrightnessUpKey
|
||||
| DisplaySwitchKey
|
||||
| KeyboardIllumToggleKey
|
||||
| KeyboardIllumDownKey
|
||||
| KeyboardIllumUpKey
|
||||
| EjectKey
|
||||
| SleepKey
|
||||
| UnknownKey
|
||||
deriving (Eq, Ord, Read, Show)
|
||||
|
296
src/Helm/Engine/SDL.hs
Normal file
296
src/Helm/Engine/SDL.hs
Normal file
@ -0,0 +1,296 @@
|
||||
{-| Contains the SDL implementation of Helm. -}
|
||||
module Helm.Engine.SDL
|
||||
(
|
||||
-- * Types
|
||||
SDLEngine
|
||||
,SDLEngineConfig(..)
|
||||
,
|
||||
-- * Utilities
|
||||
defaultConfig
|
||||
,startup
|
||||
,startupWith)
|
||||
where
|
||||
|
||||
import Control.Exception (finally)
|
||||
import Control.Monad (foldM, void)
|
||||
import Control.Monad.Trans.State.Lazy (evalStateT)
|
||||
import Data.Int (Int32)
|
||||
import qualified Data.Text as T
|
||||
import Data.Word (Word32)
|
||||
import Debug.Trace (traceShow)
|
||||
|
||||
import FRP.Elerea.Param
|
||||
import Linear.Affine (Point(P))
|
||||
import Linear.V2 (V2(V2))
|
||||
import SDL.Video (WindowConfig(..))
|
||||
import qualified SDL
|
||||
import qualified SDL.Event as Event
|
||||
import qualified SDL.Init as Init
|
||||
import qualified SDL.Time as Time
|
||||
import qualified SDL.Video as Video
|
||||
import qualified SDL.Video.Renderer as Renderer
|
||||
|
||||
import Helm.Asset
|
||||
import Helm.Engine (GameConfig(..), Cmd(..), Sub(..),
|
||||
Engine(..), Key, MouseButton)
|
||||
import Helm.Graphics (Graphics(..))
|
||||
import Helm.Graphics2D (Element)
|
||||
import Helm.Engine.SDL.Keyboard (mapKey)
|
||||
import Helm.Engine.SDL.Mouse (mapMouseButton)
|
||||
import qualified Helm.Engine.SDL.Graphics2D as Graphics2D
|
||||
|
||||
{-| A data structure describing how to run the engine. -}
|
||||
data SDLEngineConfig = SDLEngineConfig
|
||||
{ windowDimensions :: (Int, Int)
|
||||
, windowIsFullscreen :: Bool
|
||||
, windowIsResizable :: Bool
|
||||
, windowTitle :: String
|
||||
}
|
||||
|
||||
{-| A data structure describing the game engine's state. -}
|
||||
data SDLEngine = SDLEngine
|
||||
{ window :: Video.Window
|
||||
, renderer :: Video.Renderer
|
||||
, engineConfig :: SDLEngineConfig
|
||||
, lastMousePress :: Maybe (Word32, V2 Int32)
|
||||
|
||||
, 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 ()
|
||||
|
||||
, keyboardDownEventSignal :: SignalGen SDLEngine (Signal [Key])
|
||||
, keyboardDownEventSink :: Key -> IO ()
|
||||
, keyboardUpEventSignal :: SignalGen SDLEngine (Signal [Key])
|
||||
, keyboardUpEventSink :: Key -> IO ()
|
||||
, keyboardPressEventSignal :: SignalGen SDLEngine (Signal [Key])
|
||||
, keyboardPressEventSink :: Key -> IO ()
|
||||
|
||||
, windowResizeEventSignal :: SignalGen SDLEngine (Signal [V2 Int])
|
||||
, windowResizeEventSink :: V2 Int -> IO ()
|
||||
}
|
||||
|
||||
{-| A data structure describing a game's state (that is running under an engine). -}
|
||||
data SDLGame m a = SDLGame
|
||||
{ gameConfig :: GameConfig SDLEngine m a
|
||||
, gameModel :: m
|
||||
, running :: Bool
|
||||
, actionSmp :: SDLEngine -> IO [a]
|
||||
}
|
||||
|
||||
instance Engine SDLEngine where
|
||||
loadImage _ = return $ Image ()
|
||||
loadSound _ = return $ Sound ()
|
||||
|
||||
mouseMoveSignal = mouseMoveEventSignal
|
||||
mouseDownSignal = mouseDownEventSignal
|
||||
mouseUpSignal = mouseUpEventSignal
|
||||
mouseClickSignal = mouseClickEventSignal
|
||||
|
||||
keyboardDownSignal = keyboardDownEventSignal
|
||||
keyboardUpSignal = keyboardUpEventSignal
|
||||
keyboardPressSignal = keyboardPressEventSignal
|
||||
|
||||
windowResizeSignal = windowResizeEventSignal
|
||||
|
||||
windowSize SDLEngine { window } =
|
||||
fmap (fmap fromIntegral) . SDL.get $ Video.windowSize window
|
||||
|
||||
run engine config =
|
||||
void $ (prepare engine config >>= step engine) `finally` Init.quit
|
||||
|
||||
{-| Creates the default configuration for the engine. You should change the
|
||||
values where necessary. -}
|
||||
defaultConfig :: SDLEngineConfig
|
||||
defaultConfig = SDLEngineConfig
|
||||
{ windowDimensions = (800, 600)
|
||||
, windowIsFullscreen = False
|
||||
, windowIsResizable = True
|
||||
, windowTitle = "Helm"
|
||||
}
|
||||
|
||||
{-| Initialises a new engine with default configuration.
|
||||
The engine can then be run later using 'run'. -}
|
||||
startup :: IO SDLEngine
|
||||
startup = startupWith defaultConfig
|
||||
|
||||
{-| Initializes a new engine with some configration. -}
|
||||
startupWith :: SDLEngineConfig -> IO SDLEngine
|
||||
startupWith config@SDLEngineConfig{..} = do
|
||||
Init.initializeAll
|
||||
|
||||
window <- Video.createWindow (T.pack windowTitle) windowConfig
|
||||
renderer <- Video.createRenderer window (-1) rendererConfig
|
||||
|
||||
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
|
||||
, 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
|
||||
(w,h) = windowDimensions
|
||||
rendererConfig = Video.RendererConfig Video.AcceleratedVSyncRenderer False
|
||||
windowConfig = Video.defaultWindow
|
||||
{ windowInitialSize = V2 (fromIntegral w) (fromIntegral h)
|
||||
, windowMode = if windowIsFullscreen
|
||||
then Video.Fullscreen
|
||||
else Video.Windowed
|
||||
, windowResizable = windowIsResizable
|
||||
}
|
||||
|
||||
step :: SDLEngine -> SDLGame m a -> IO (SDLGame m a)
|
||||
step engine game@SDLGame{actionSmp,gameModel,gameConfig = GameConfig{viewFn}} = do
|
||||
sunkGame <- sinkEvents engine game
|
||||
|
||||
if running sunkGame
|
||||
then do
|
||||
actions <- actionSmp engine
|
||||
model <- foldM (stepModel engine game) gameModel actions
|
||||
|
||||
render engine $ viewFn model
|
||||
step engine $ sunkGame { gameModel = model }
|
||||
else return sunkGame
|
||||
|
||||
stepModel :: SDLEngine -> SDLGame m a -> m -> a -> IO m
|
||||
stepModel engine game@SDLGame { gameConfig = GameConfig { updateFn } } model action =
|
||||
evalStateT monad engine >>= foldM (stepModel engine game) model
|
||||
|
||||
where
|
||||
(model, Cmd monad) = updateFn model action
|
||||
|
||||
prepare :: SDLEngine -> GameConfig SDLEngine m a -> IO (SDLGame m a)
|
||||
prepare engine config@GameConfig { initialFn, subscriptionsFn = Sub gen } = 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 SDLGame
|
||||
{ gameConfig = config
|
||||
, gameModel = fst initialFn
|
||||
, running = True
|
||||
, actionSmp = smp
|
||||
}
|
||||
|
||||
render :: SDLEngine -> Graphics -> IO ()
|
||||
render engine (Graphics2D element) = render2d engine element
|
||||
|
||||
render2d :: SDLEngine -> Element -> IO ()
|
||||
render2d SDLEngine{window,renderer} element = do
|
||||
dims <- SDL.get $ Video.windowSize window
|
||||
texture <- Renderer.createTexture renderer mode access dims
|
||||
|
||||
Graphics2D.render texture dims element
|
||||
Renderer.clear renderer
|
||||
Renderer.copy renderer texture Nothing Nothing
|
||||
Renderer.destroyTexture texture
|
||||
Renderer.present renderer
|
||||
|
||||
where
|
||||
mode = Renderer.ARGB8888
|
||||
access = Renderer.TextureAccessStreaming
|
||||
|
||||
sinkEvents :: SDLEngine -> SDLGame m a -> IO (SDLGame m a)
|
||||
sinkEvents engine game = 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 game { running = False }
|
||||
|
||||
Just Event.Event { .. } ->
|
||||
sinkEvent engine eventPayload >> sinkEvents engine game
|
||||
|
||||
Nothing -> return game
|
||||
|
||||
depoint :: Point f a -> (f a)
|
||||
depoint (P x) = x
|
||||
|
||||
sinkEvent :: SDLEngine -> Event.EventPayload -> IO SDLEngine
|
||||
sinkEvent engine (Event.WindowResizedEvent Event.WindowResizedEventData { .. }) = do
|
||||
windowResizeEventSink engine $ fromIntegral <$> windowResizedEventSize
|
||||
|
||||
return engine
|
||||
|
||||
sinkEvent engine (Event.MouseMotionEvent Event.MouseMotionEventData { .. }) = do
|
||||
mouseMoveEventSink engine $ fromIntegral <$> depoint mouseMotionEventPos
|
||||
|
||||
return engine
|
||||
|
||||
sinkEvent engine (Event.MouseButtonEvent Event.MouseButtonEventData { .. }) = do
|
||||
case mouseButtonEventMotion of
|
||||
Event.Pressed -> do
|
||||
ticks <- Time.ticks
|
||||
mouseDownEventSink engine tup
|
||||
|
||||
return engine { lastMousePress = Just (ticks, pos) }
|
||||
|
||||
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, (V2 lastX lastY)) -> do
|
||||
ticks <- Time.ticks
|
||||
|
||||
traceShow (ticks - lastTicks) (return ())
|
||||
|
||||
if ticks - lastTicks < clickMs && (abs (lastX - x) <= clickRadius && abs (lastY - y) <= clickRadius)
|
||||
then traceShow "clickeroo" (mouseClickEventSink engine tup)
|
||||
else return ()
|
||||
|
||||
Nothing -> return ()
|
||||
|
||||
return engine
|
||||
|
||||
where
|
||||
SDLEngine { lastMousePress } = engine
|
||||
clickMs = 500 -- How long between mouse down/up to recognise clicks
|
||||
clickRadius = 1 -- The pixel radius to be considered a click.
|
||||
pos@(V2 x y) = depoint mouseButtonEventPos
|
||||
tup = (mapMouseButton mouseButtonEventButton, fromIntegral <$> pos)
|
||||
|
||||
sinkEvent engine _ = return engine
|
@ -1,53 +1,35 @@
|
||||
module Helm.Render.Cairo (
|
||||
-- * Rendering
|
||||
render
|
||||
) where
|
||||
|
||||
import Control.Monad.Trans.Class (lift)
|
||||
import Control.Monad.Trans.State (get)
|
||||
{-| Contains the SDL implementation 2D graphics rendering implementation (uses Cairo). -}
|
||||
module Helm.Engine.SDL.Graphics2D (render) where
|
||||
|
||||
import Data.Foldable (forM_)
|
||||
import qualified Data.Text as T
|
||||
import Linear.V2 (V2(V2))
|
||||
import Linear.V3 (V3(V3))
|
||||
import Foreign.C.Types (CInt)
|
||||
import Foreign.Ptr (castPtr)
|
||||
|
||||
import Helm.Engine (Engine(..))
|
||||
import Helm.Render (Render(..))
|
||||
import Graphics.Rendering.Cairo.Matrix (Matrix(..))
|
||||
import Linear.V2 (V2(V2))
|
||||
import Linear.V3 (V3(V3))
|
||||
|
||||
import Helm.Color (Color(..), Gradient(..))
|
||||
import Helm.Graphics2D
|
||||
|
||||
import Graphics.Rendering.Cairo.Matrix (Matrix(..))
|
||||
import qualified Data.Text as T
|
||||
import qualified Graphics.Rendering.Cairo as Cairo
|
||||
import qualified Graphics.Rendering.Pango as Pango
|
||||
|
||||
import qualified SDL
|
||||
import qualified SDL.Video as Video
|
||||
import qualified SDL.Video.Renderer as Renderer
|
||||
|
||||
render :: Element -> Render ()
|
||||
render element = Render $ do
|
||||
Engine { window, renderer } <- get
|
||||
render :: Renderer.Texture -> V2 CInt -> Element -> IO ()
|
||||
render texture (V2 w h) element = do
|
||||
(pixels, pitch) <- Renderer.lockTexture texture Nothing
|
||||
|
||||
lift $ do
|
||||
dims@(V2 w h) <- SDL.get $ Video.windowSize window
|
||||
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
|
||||
|
||||
texture <- Renderer.createTexture renderer Renderer.ARGB8888 Renderer.TextureAccessStreaming dims
|
||||
(pixels, pitch) <- Renderer.lockTexture texture Nothing
|
||||
renderElement element
|
||||
|
||||
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
|
||||
|
||||
renderElement element
|
||||
|
||||
Renderer.unlockTexture texture
|
||||
Renderer.clear renderer
|
||||
Renderer.copy renderer texture Nothing Nothing
|
||||
Renderer.destroyTexture texture
|
||||
Renderer.present renderer
|
||||
Renderer.unlockTexture texture
|
||||
|
||||
renderElement :: Element -> Cairo.Render ()
|
||||
renderElement (CollageElement w h center forms) = do
|
||||
@ -60,10 +42,9 @@ renderElement (CollageElement w h center forms) = do
|
||||
|
||||
Cairo.restore
|
||||
|
||||
renderElement (ImageElement (sx, sy) sw sh src stretch) = do
|
||||
return ()
|
||||
renderElement (ImageElement (sx, sy) sw sh src stretch) = return ()
|
||||
|
||||
renderElement (TextElement (Text { textColor = (Color r g b a), .. })) = do
|
||||
renderElement (TextElement Text { textColor = (Color r g b a), .. }) = do
|
||||
Cairo.save
|
||||
|
||||
layout <- Pango.createLayout textUTF8
|
||||
@ -75,7 +56,7 @@ renderElement (TextElement (Text { textColor = (Color r g b a), .. })) = do
|
||||
, Pango.AttrSize { paStart = i, paEnd = j, paSize = textHeight }
|
||||
]
|
||||
|
||||
Pango.PangoRectangle x y w h <- fmap snd $ Cairo.liftIO $ Pango.layoutGetExtents layout
|
||||
Pango.PangoRectangle x y w h <- fmap snd . Cairo.liftIO $ Pango.layoutGetExtents layout
|
||||
|
||||
Cairo.translate ((-w / 2) -x) ((-h / 2) - y)
|
||||
Cairo.setSourceRGBA r g b a
|
||||
@ -129,7 +110,7 @@ setLineJoin join = case join of
|
||||
to render with a line style and then strokes afterwards. 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
|
||||
setLineStyle LineStyle { lineColor = Color r g b a, .. } = do
|
||||
Cairo.setSourceRGBA r g b a
|
||||
setLineCap lineCap
|
||||
setLineJoin lineJoin
|
||||
@ -145,22 +126,21 @@ setFillStyle (Solid (Color r g b a)) = do
|
||||
Cairo.setSourceRGBA r g b a
|
||||
Cairo.fill
|
||||
|
||||
setFillStyle (Texture src) = do
|
||||
return ()
|
||||
setFillStyle (Texture src) = return ()
|
||||
|
||||
setFillStyle (Gradient (Linear (sx, sy) (ex, ey) points)) =
|
||||
Cairo.withLinearPattern sx sy ex ey $ \pattern ->
|
||||
setGradientFill pattern 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 $ \pattern ->
|
||||
setGradientFill pattern points
|
||||
Cairo.withRadialPattern sx sy sr ex ey er $ \ptn ->
|
||||
setGradientFill ptn points
|
||||
|
||||
{-| A utility function that adds color stops to a pattern and then fills it. -}
|
||||
setGradientFill :: Cairo.Pattern -> [(Double, Color)] -> Cairo.Render ()
|
||||
setGradientFill pattern points = do
|
||||
Cairo.setSource pattern
|
||||
mapM_ (\(o, Color r g b a) -> Cairo.patternAddColorStopRGBA pattern o r g b a) points
|
||||
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
|
||||
|
||||
{-| A utility that renders a form. -}
|
11
src/Helm/Engine/SDL/Keyboard.hs
Normal file
11
src/Helm/Engine/SDL/Keyboard.hs
Normal file
@ -0,0 +1,11 @@
|
||||
{-| Contains the SDL keyboard mappings. -}
|
||||
module Helm.Engine.SDL.Keyboard
|
||||
(mapKey)
|
||||
where
|
||||
|
||||
import qualified SDL.Input.Keyboard.Codes as Codes
|
||||
import Helm.Engine (Key(..))
|
||||
|
||||
mapKey :: Codes.Keycode -> Key
|
||||
mapKey Codes.KeycodeReturn = ReturnKey
|
||||
mapKey _ = UnknownKey
|
14
src/Helm/Engine/SDL/Mouse.hs
Normal file
14
src/Helm/Engine/SDL/Mouse.hs
Normal file
@ -0,0 +1,14 @@
|
||||
{-| Contains the SDL mouse button mappings. -}
|
||||
module Helm.Engine.SDL.Mouse (mapMouseButton) where
|
||||
|
||||
import qualified SDL.Event as Event
|
||||
|
||||
import Helm.Engine (MouseButton(..))
|
||||
|
||||
mapMouseButton :: Event.MouseButton -> MouseButton
|
||||
mapMouseButton Event.ButtonLeft = LeftButton
|
||||
mapMouseButton Event.ButtonMiddle = MiddleButton
|
||||
mapMouseButton Event.ButtonRight = RightButton
|
||||
mapMouseButton Event.ButtonX1 = X1Button
|
||||
mapMouseButton Event.ButtonX2 = X2Button
|
||||
mapMouseButton _ = UnknownButton
|
@ -1,28 +0,0 @@
|
||||
module Helm.Game (
|
||||
-- * Types
|
||||
GameConfig(..),
|
||||
Game(..)
|
||||
) where
|
||||
|
||||
import Control.Concurrent.STM (TQueue)
|
||||
|
||||
import Helm.Cmd (Cmd)
|
||||
import Helm.Engine (Engine)
|
||||
import Helm.Render (Render)
|
||||
import Helm.Sub (Sub)
|
||||
|
||||
{-| Describes how to run a game. -}
|
||||
data GameConfig m a = GameConfig {
|
||||
initialFn :: (m, Cmd a),
|
||||
updateFn :: m -> a -> (m, Cmd a),
|
||||
subscriptionsFn :: Sub a,
|
||||
viewFn :: m -> Render ()
|
||||
}
|
||||
|
||||
{-| Describes a game's state. -}
|
||||
data Game m a = Game {
|
||||
gameConfig :: GameConfig m a,
|
||||
gameModel :: m,
|
||||
actionSmp :: Engine -> IO [a],
|
||||
actionQueue :: TQueue a
|
||||
}
|
9
src/Helm/Graphics.hs
Normal file
9
src/Helm/Graphics.hs
Normal file
@ -0,0 +1,9 @@
|
||||
{-| Contains the graphics type. -}
|
||||
module Helm.Graphics (
|
||||
-- * Types
|
||||
Graphics(..)
|
||||
) where
|
||||
|
||||
import Helm.Graphics2D (Element)
|
||||
|
||||
data Graphics = Graphics2D Element
|
@ -263,7 +263,7 @@ data Path = Path [(Double, Double)] deriving (Show, Eq, Ord, Read)
|
||||
|
||||
{-| Creates a path for a collection of points. -}
|
||||
path :: [(Double, Double)] -> Path
|
||||
path points = Path points
|
||||
path = Path
|
||||
|
||||
{-| Creates a path from a line segment, i.e. a start and end point. -}
|
||||
segment :: (Double, Double) -> (Double, Double) -> Path
|
||||
|
@ -26,7 +26,7 @@ instance Num Transform where
|
||||
fromInteger n = Transform $ V3 (V3 (fromInteger n) 0 0) (V3 (fromInteger n) 0 0) (V3 0 0 1)
|
||||
|
||||
identity :: Transform
|
||||
identity = Transform $ Matrix.identity
|
||||
identity = Transform Matrix.identity
|
||||
|
||||
matrix :: Double -> Double -> Double -> Double -> Double -> Double -> Transform
|
||||
matrix a b c d x y = Transform $ V3 (V3 a b x) (V3 c d y) (V3 0 0 1)
|
||||
|
@ -1,19 +1,26 @@
|
||||
{-| Contains subscriptions to events from the keyboard. -}
|
||||
module Helm.Keyboard (
|
||||
-- * Subscriptions
|
||||
presses,
|
||||
downs,
|
||||
ups
|
||||
) where
|
||||
module Helm.Keyboard
|
||||
(
|
||||
-- * Types
|
||||
Key(..)
|
||||
-- * Subscriptions
|
||||
, presses
|
||||
, downs
|
||||
, ups
|
||||
) where
|
||||
|
||||
import SDL.Input.Keyboard.Codes (Keycode)
|
||||
import Helm (Sub(..))
|
||||
import FRP.Elerea.Param (input, snapshot)
|
||||
|
||||
presses :: (Keycode -> a) -> Sub a
|
||||
presses _ = Sub $ return $ return []
|
||||
import Helm.Engine (Engine(..), Sub(..), Key(..))
|
||||
|
||||
downs :: (Keycode -> a) -> Sub a
|
||||
presses :: Engine e => (Key -> a) -> Sub e a
|
||||
presses f = Sub $ do
|
||||
engine <- input >>= snapshot
|
||||
|
||||
fmap (fmap f) <$> keyboardPressSignal engine
|
||||
|
||||
downs :: Engine e => (Key -> a) -> Sub e a
|
||||
downs _ = Sub $ return $ return []
|
||||
|
||||
ups :: (Keycode -> a) -> Sub a
|
||||
ups :: Engine e => (Key -> a) -> Sub e a
|
||||
ups _ = Sub $ return $ return []
|
||||
|
@ -1,37 +1,43 @@
|
||||
{-| Contains subscriptions to events from the mouse. -}
|
||||
module Helm.Mouse
|
||||
(
|
||||
-- * Subscriptions
|
||||
moves,
|
||||
clicks,
|
||||
downs,
|
||||
ups,
|
||||
buttonClicks,
|
||||
buttonDowns,
|
||||
buttonUps
|
||||
) where
|
||||
(
|
||||
-- * Types
|
||||
MouseButton(..)
|
||||
-- * Subscriptions
|
||||
, moves
|
||||
, clicks
|
||||
, downs
|
||||
, ups
|
||||
, buttonClicks
|
||||
, buttonDowns
|
||||
, buttonUps
|
||||
) where
|
||||
|
||||
import FRP.Elerea.Param (input, snapshot)
|
||||
import Linear.V2 (V2(V2))
|
||||
import Helm (Sub(..))
|
||||
import SDL.Input.Mouse (MouseButton(ButtonLeft))
|
||||
|
||||
moves :: (V2 Int -> a) -> Sub a
|
||||
moves _ = Sub $ return $ return []
|
||||
import Helm.Engine (Sub(..), Engine(..), MouseButton(..))
|
||||
|
||||
buttonClicks :: MouseButton -> (V2 Int -> a) -> Sub a
|
||||
moves :: Engine e => (V2 Int -> a) -> Sub e a
|
||||
moves f = Sub $ do
|
||||
engine <- input >>= snapshot
|
||||
|
||||
fmap (fmap f) <$> mouseMoveSignal engine
|
||||
|
||||
buttonClicks :: Engine e => MouseButton -> (V2 Int -> a) -> Sub e a
|
||||
buttonClicks _ _ = Sub $ return $ return []
|
||||
|
||||
buttonDowns :: MouseButton -> (V2 Int -> a) -> Sub a
|
||||
buttonDowns :: Engine e => MouseButton -> (V2 Int -> a) -> Sub e a
|
||||
buttonDowns _ _ = Sub $ return $ return []
|
||||
|
||||
buttonUps :: MouseButton -> (V2 Int -> a) -> Sub a
|
||||
buttonUps :: Engine e => MouseButton -> (V2 Int -> a) -> Sub e a
|
||||
buttonUps _ _ = Sub $ return $ return []
|
||||
|
||||
clicks :: (V2 Int -> a) -> Sub a
|
||||
clicks = buttonClicks ButtonLeft
|
||||
clicks :: Engine e => (V2 Int -> a) -> Sub e a
|
||||
clicks = buttonClicks LeftButton
|
||||
|
||||
downs :: (V2 Int -> a) -> Sub a
|
||||
downs = buttonDowns ButtonLeft
|
||||
downs :: Engine e => (V2 Int -> a) -> Sub e a
|
||||
downs = buttonDowns LeftButton
|
||||
|
||||
ups :: (V2 Int -> a) -> Sub a
|
||||
ups = buttonUps ButtonLeft
|
||||
ups :: Engine e => (V2 Int -> a) -> Sub e a
|
||||
ups = buttonUps LeftButton
|
||||
|
@ -1,16 +0,0 @@
|
||||
module Helm.Render (
|
||||
-- * Types
|
||||
Render(..),
|
||||
-- * Utilities
|
||||
none
|
||||
) where
|
||||
|
||||
import Control.Monad.Trans.State (StateT)
|
||||
|
||||
import Helm.Engine (Engine)
|
||||
|
||||
data Render a = Render (StateT Engine IO a)
|
||||
|
||||
{-| Render nothing to the screen. -}
|
||||
none :: Render ()
|
||||
none = Render $ return ()
|
@ -1,26 +1,23 @@
|
||||
{-| Contains the subscription type and related utilities. -}
|
||||
module Helm.Sub (
|
||||
-- * Types
|
||||
Sub(..),
|
||||
-- * Utilities
|
||||
batch,
|
||||
none
|
||||
) where
|
||||
{-| Contains the subscription related utilities. -}
|
||||
module Helm.Sub
|
||||
(
|
||||
-- * Types
|
||||
Sub(..)
|
||||
-- * Utilities
|
||||
, batch
|
||||
, none
|
||||
) where
|
||||
|
||||
import FRP.Elerea.Param (SignalGen, Signal)
|
||||
import Helm.Engine (Engine, Sub(..))
|
||||
|
||||
import Helm.Engine (Engine)
|
||||
|
||||
data Sub a = Sub (SignalGen Engine (Signal [a]))
|
||||
|
||||
batch :: [Sub a] -> Sub a
|
||||
batch :: Engine e => [Sub e a] -> Sub e a
|
||||
batch subs = Sub $ do
|
||||
signals <- sequence $ map (\(Sub gen) -> gen) subs
|
||||
signals <- mapM (\(Sub gen) -> gen) subs
|
||||
|
||||
return $ do
|
||||
lists <- sequence signals
|
||||
|
||||
return $ concat lists
|
||||
|
||||
none :: Sub a
|
||||
none = Sub $ return $ return []
|
||||
none :: Engine e => Sub e a
|
||||
none = Sub . return $ return []
|
||||
|
@ -1,24 +1,25 @@
|
||||
{-| Contains functions for composing units of time and
|
||||
subscriptions to events from the game clock. -}
|
||||
module Helm.Time (
|
||||
-- * Types
|
||||
Time,
|
||||
-- * Units
|
||||
millisecond,
|
||||
second,
|
||||
minute,
|
||||
hour,
|
||||
inMilliseconds,
|
||||
inSeconds,
|
||||
inMinutes,
|
||||
inHours,
|
||||
-- * Commands
|
||||
now,
|
||||
-- * Subscriptions
|
||||
every,
|
||||
) where
|
||||
module Helm.Time
|
||||
(
|
||||
-- * Types
|
||||
Time
|
||||
-- * Units
|
||||
, millisecond
|
||||
, second
|
||||
, minute
|
||||
, hour
|
||||
, inMilliseconds
|
||||
, inSeconds
|
||||
, inMinutes
|
||||
, inHours
|
||||
-- * Commands
|
||||
, now
|
||||
-- * Subscriptions
|
||||
, every
|
||||
) where
|
||||
|
||||
import Helm (Cmd(..), Sub(..))
|
||||
import Helm.Engine (Cmd(..), Sub(..), Engine(..))
|
||||
|
||||
{-| A type describing an amount of time in an arbitary unit. Use the time
|
||||
composing/converting functions to manipulate time values. -}
|
||||
@ -56,8 +57,8 @@ inMinutes n = n / minute
|
||||
inHours :: Time -> Double
|
||||
inHours n = n / hour
|
||||
|
||||
now :: Cmd Time
|
||||
now :: Engine e => Cmd e Time
|
||||
now = Cmd $ return []
|
||||
|
||||
every :: Time -> (Time -> a) -> Sub a
|
||||
every :: Engine e => Time -> (Time -> a) -> Sub e a
|
||||
every _ _ = Sub $ return $ return []
|
||||
|
@ -1,42 +1,45 @@
|
||||
{-| Contains signals that sample input from the game window. -}
|
||||
module Helm.Window (
|
||||
-- * Commands
|
||||
size,
|
||||
width,
|
||||
height,
|
||||
-- * Subscriptions
|
||||
resizes
|
||||
) where
|
||||
module Helm.Window
|
||||
(
|
||||
-- * Commands
|
||||
size
|
||||
, width
|
||||
, height
|
||||
-- * Subscriptions
|
||||
, resizes
|
||||
) where
|
||||
|
||||
import Control.Monad.State (get)
|
||||
import Helm.Cmd (Cmd(..))
|
||||
import Helm.Engine (Engine(..))
|
||||
import Helm.Sub (Sub(..))
|
||||
import Control.Monad.IO.Class (liftIO)
|
||||
|
||||
import FRP.Elerea.Param (input, snapshot)
|
||||
import Linear.V2 (V2(V2))
|
||||
|
||||
import qualified SDL
|
||||
import qualified SDL.Video as Video
|
||||
import Helm.Engine (Engine(..), Cmd(..), Sub(..))
|
||||
|
||||
size :: Cmd (V2 Int)
|
||||
size :: Engine e => Cmd e (V2 Int)
|
||||
size = Cmd $ do
|
||||
Engine { window } <- get
|
||||
V2 x y <- SDL.get $ Video.windowSize window
|
||||
engine <- get
|
||||
V2 x y <- liftIO $ windowSize engine
|
||||
|
||||
return [V2 (fromIntegral x) (fromIntegral y)]
|
||||
|
||||
width :: Cmd Int
|
||||
width :: Engine e => Cmd e Int
|
||||
width = Cmd $ do
|
||||
Engine { window } <- get
|
||||
V2 x _ <- SDL.get $ Video.windowSize window
|
||||
engine <- get
|
||||
V2 x _ <- liftIO $ windowSize engine
|
||||
|
||||
return [fromIntegral x]
|
||||
|
||||
height :: Cmd Int
|
||||
height :: Engine e => Cmd e Int
|
||||
height = Cmd $ do
|
||||
Engine { window } <- get
|
||||
V2 _ y <- SDL.get $ Video.windowSize window
|
||||
engine <- get
|
||||
V2 _ y <- liftIO $ windowSize engine
|
||||
|
||||
return [fromIntegral y]
|
||||
|
||||
resizes :: (V2 Int -> a) -> Sub a
|
||||
resizes _ = Sub $ return $ return []
|
||||
resizes :: Engine e => (V2 Int -> a) -> Sub e a
|
||||
resizes f = Sub $ do
|
||||
engine <- input >>= snapshot
|
||||
|
||||
fmap (fmap f) <$> windowResizeSignal engine
|
||||
|
Loading…
Reference in New Issue
Block a user