mirror of
https://github.com/z0w0/helm.git
synced 2024-10-26 05:07:52 +03:00
Completely reworking engine per recent changes to Elm
This commit is contained in:
parent
b0ed6a91c4
commit
844f551e90
12
.editorconfig
Normal file
12
.editorconfig
Normal file
@ -0,0 +1,12 @@
|
||||
root = true
|
||||
|
||||
[*]
|
||||
indent_style = space
|
||||
indent_size = 2
|
||||
end_of_line = lf
|
||||
charset = utf-8
|
||||
trim_trailing_whitespace = true
|
||||
insert_final_newline = true
|
||||
|
||||
[*.md]
|
||||
trim_trailing_whitespace = false
|
48
README.md
48
README.md
@ -2,19 +2,17 @@
|
||||
<a href="http://helm-engine.org" title="Homepage"><img src="http://helm-engine.org/img/logo-alt.png" /></a>
|
||||
<br>
|
||||
<br>
|
||||
<a href="https://travis-ci.org/switchface/helm" title="Travis CI"><img src="https://travis-ci.org/switchface/helm.svg" /></a>
|
||||
<a href="https://travis-ci.org/z0w0/helm" title="Travis CI"><img src="https://travis-ci.org/z0w0/helm.svg" /></a>
|
||||
</p>
|
||||
|
||||
## Introduction
|
||||
|
||||
Helm is a functionally reactive game engine written in Haskell and built around
|
||||
the [Elerea FRP framework](https://github.com/cobbpg/elerea). Helm is
|
||||
heavily inspired by the [Elm programming language](http://elm-lang.org) (especially the API).
|
||||
All rendering is done through a vector-graphics based API. At the core, Helm is
|
||||
built on SDL and the Cairo vector graphics library.
|
||||
Helm is a purely functional game engine written in Haskell and built with
|
||||
the [Elerea FRP framework](https://github.com/cobbpg/elerea). Helm was
|
||||
originally inspired by the [Elm programming language](http://elm-lang.org).
|
||||
|
||||
In Helm, every piece of input that can be gathered from a user (or the operating system)
|
||||
is hidden behind a signal. For those unfamiliar with FRP, signals are essentially
|
||||
is hidden behind a subscription. For those unfamiliar with FRP, signals are essentially
|
||||
a value that changes over time. This sort of architecture used for a game allows for pretty
|
||||
simplistic (and in my opinion, artistic) code.
|
||||
|
||||
@ -34,32 +32,32 @@ Helm.
|
||||
those as you would with any pixel-blitting engine.
|
||||
* Straightforward API heavily inspired by the Elm programming language. The API
|
||||
is broken up into the following areas:
|
||||
* `FRP.Helm` contains the main code for interfacing with the game engine but
|
||||
also includes some utility functions and the modules `FRP.Helm.Color`, `FRP.Helm.Utilities`
|
||||
and `FRP.Helm.Graphics` in the style of a sort of prelude library, allowing it to be included
|
||||
* `Helm` contains the main code for interfacing with the game engine but
|
||||
also includes some utility functions and the modules `Helm.Color`, `Helm.Utilities`
|
||||
and `Helm.Graphics` in the style of a sort of prelude library, allowing it to be included
|
||||
and readily make the most basic of games.
|
||||
* `FRP.Helm.Color` contains the `Color` data structure, functions for composing
|
||||
* `Helm.Color` contains the `Color` data structure, functions for composing
|
||||
colors and a few pre-defined colors that are usually used in games.
|
||||
* `FRP.Helm.Graphics` contains all the graphics data structures, functions
|
||||
* `Helm.Graphics` contains all the graphics data structures, functions
|
||||
for composing these structures and other general graphical utilities.
|
||||
* `FRP.Helm.Keyboard` contains signals for working with keyboard state.
|
||||
* `FRP.Helm.Mouse` contains signals for working with mouse state.
|
||||
* `FRP.Helm.Random` contains signals for generating random values
|
||||
* `FRP.Helm.Signal` constains useful functions for working with signals such
|
||||
* `Helm.Keyboard` contains signals for working with keyboard state.
|
||||
* `Helm.Mouse` contains signals for working with mouse state.
|
||||
* `Helm.Random` contains signals for generating random values
|
||||
* `Helm.Signal` constains useful functions for working with signals such
|
||||
as lifting/folding
|
||||
* `FRP.Helm.Text` contains functions for composing text, formatting it
|
||||
* `Helm.Text` contains functions for composing text, formatting it
|
||||
and then turning it into an element.
|
||||
* `FRP.Helm.Time` contains functions for composing units of time and time-dependant signals
|
||||
* `FRP.Helm.Utilities` contains an assortment of useful functions,
|
||||
* `FRP.Helm.Window` contains signals for working with the game window state.
|
||||
* `Helm.Time` contains functions for composing units of time and time-dependant signals
|
||||
* `Helm.Utilities` contains an assortment of useful functions,
|
||||
* `Helm.Window` contains signals for working with the game window state.
|
||||
|
||||
## Example
|
||||
|
||||
The simplest example of a Helm game that doesn't require any input from the user is the following:
|
||||
|
||||
```haskell
|
||||
import FRP.Helm
|
||||
import qualified FRP.Helm.Window as Window
|
||||
import Helm
|
||||
import qualified Helm.Window as Window
|
||||
|
||||
render :: (Int, Int) -> Element
|
||||
render (w, h) = collage w h [move (100, 100) $ filled red $ square 64]
|
||||
@ -75,9 +73,9 @@ an accumulated state that depends on the values sampled from signals (e.g. mouse
|
||||
You should see a white square on the screen and pressing the arrow keys allows you to move it.
|
||||
|
||||
```haskell
|
||||
import FRP.Helm
|
||||
import qualified FRP.Helm.Keyboard as Keyboard
|
||||
import qualified FRP.Helm.Window as Window
|
||||
import Helm
|
||||
import qualified Helm.Keyboard as Keyboard
|
||||
import qualified Helm.Window as Window
|
||||
|
||||
data State = State { mx :: Double, my :: Double }
|
||||
|
||||
|
31
examples/hello/Main.hs
Normal file
31
examples/hello/Main.hs
Normal file
@ -0,0 +1,31 @@
|
||||
import Helm
|
||||
import Helm.Graphics2D
|
||||
import Helm.Render.Cairo (render)
|
||||
|
||||
import qualified Helm.Cmd as Cmd
|
||||
import qualified Helm.Sub as Sub
|
||||
|
||||
data Action = Idle | ChangeDirection (Double, Double)
|
||||
data Model = Model (Double, Double)
|
||||
|
||||
initial :: (Model, Cmd Action)
|
||||
initial = (Model (0, 0), Cmd.none)
|
||||
|
||||
update :: Model -> Action -> (Model, Cmd Action)
|
||||
update model _ = (model, Cmd.none)
|
||||
|
||||
subscriptions :: Sub Action
|
||||
subscriptions = Sub.none
|
||||
|
||||
view :: Model -> Render ()
|
||||
view model = render $ collage 800 600 []
|
||||
|
||||
main = do
|
||||
engine <- startup
|
||||
|
||||
run engine $ GameConfig {
|
||||
initialFn = initial,
|
||||
updateFn = update,
|
||||
subscriptionsFn = subscriptions,
|
||||
viewFn = view
|
||||
}
|
55
helm.cabal
55
helm.cabal
@ -1,5 +1,5 @@
|
||||
name: helm
|
||||
version: 0.8.0
|
||||
version: 1.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.
|
||||
@ -27,19 +27,21 @@ library
|
||||
ghc-options: -Wall -fno-warn-unused-do-bind
|
||||
|
||||
exposed-modules:
|
||||
FRP.Helm
|
||||
FRP.Helm.Color
|
||||
FRP.Helm.Graphics
|
||||
FRP.Helm.Engine
|
||||
FRP.Helm.Keyboard
|
||||
FRP.Helm.Mouse
|
||||
FRP.Helm.Random
|
||||
FRP.Helm.Sample
|
||||
FRP.Helm.Signal
|
||||
FRP.Helm.Text
|
||||
FRP.Helm.Time
|
||||
FRP.Helm.Utilities
|
||||
FRP.Helm.Window
|
||||
Helm
|
||||
Helm.Cmd
|
||||
Helm.Color
|
||||
Helm.Engine
|
||||
Helm.Game
|
||||
Helm.Graphics2D
|
||||
Helm.Graphics2D.Text
|
||||
Helm.Graphics2D.Transform
|
||||
Helm.Keyboard
|
||||
Helm.Mouse
|
||||
Helm.Render
|
||||
Helm.Render.Cairo
|
||||
Helm.Sub
|
||||
Helm.Time
|
||||
Helm.Window
|
||||
|
||||
build-depends:
|
||||
base >= 4 && < 5,
|
||||
@ -47,19 +49,24 @@ library
|
||||
pango >= 0.13 && < 0.14,
|
||||
containers >= 0.5 && < 1,
|
||||
elerea >= 2.7 && < 3,
|
||||
filepath >= 1.3 && < 2,
|
||||
sdl2 >= 2 && < 3,
|
||||
linear >= 1 && < 2,
|
||||
text >= 1.1.1.3 && < 2,
|
||||
time >= 1.4 && < 2,
|
||||
random >= 1.0.1.1 && < 1.2,
|
||||
mtl >= 2.1 && < 3,
|
||||
transformers >= 0.3.0.0 && < 0.5,
|
||||
cpu >= 0.1.2 && < 1,
|
||||
linear >= 1 && < 2
|
||||
stm >= 2.4 && < 3,
|
||||
transformers >= 0.3.0.0 && < 0.5
|
||||
|
||||
if impl(ghc < 7.6)
|
||||
build-depends: ghc-prim
|
||||
|
||||
executable helm-example-hello
|
||||
main-is: Main.hs
|
||||
hs-source-dirs: examples/hello
|
||||
|
||||
build-depends:
|
||||
base >= 4 && < 5,
|
||||
helm >= 1 && < 2
|
||||
|
||||
test-suite helm-tests
|
||||
type: exitcode-stdio-1.0
|
||||
x-uses-tf: true
|
||||
@ -70,12 +77,10 @@ test-suite helm-tests
|
||||
|
||||
build-depends:
|
||||
base >= 4 && < 5,
|
||||
cairo >= 0.13 && < 0.14,
|
||||
containers >= 0.5 && < 1,
|
||||
elerea >= 2.7 && < 3,
|
||||
sdl2 >= 2 && < 3,
|
||||
HUnit >= 1.2 && < 2,
|
||||
test-framework >= 0.8 && < 1,
|
||||
test-framework-hunit >= 0.3 && < 1,
|
||||
test-framework-quickcheck2 >= 0.3 && < 1,
|
||||
time >= 1.4 && < 2,
|
||||
elerea >= 2.7 && < 3,
|
||||
sdl2 >= 2 && < 3
|
||||
test-framework-quickcheck2 >= 0.3 && < 1
|
||||
|
394
src/FRP/Helm.hs
394
src/FRP/Helm.hs
@ -1,394 +0,0 @@
|
||||
{-| Contains miscellaneous utility functions and the main
|
||||
functions for interfacing with the engine. -}
|
||||
module FRP.Helm (
|
||||
-- * Types
|
||||
Time,
|
||||
EngineConfig(..),
|
||||
-- * Engine
|
||||
run,
|
||||
defaultConfig,
|
||||
-- * Prelude
|
||||
module Color,
|
||||
module Graphics,
|
||||
module Utilities,
|
||||
module Signal,
|
||||
FRP.Helm.Signal.lift
|
||||
) where
|
||||
|
||||
|
||||
import Control.Concurrent (threadDelay)
|
||||
import Control.Exception
|
||||
import Control.Monad (when)
|
||||
import Control.Monad.IO.Class
|
||||
import Control.Monad.Trans.Class (lift)
|
||||
import Control.Monad.Trans.State
|
||||
|
||||
import Data.Foldable (forM_)
|
||||
|
||||
|
||||
import Foreign.Ptr
|
||||
|
||||
import FRP.Elerea.Param hiding (Signal)
|
||||
import FRP.Helm.Color as Color
|
||||
import FRP.Helm.Engine
|
||||
import FRP.Helm.Graphics as Graphics
|
||||
import FRP.Helm.Utilities as Utilities
|
||||
import FRP.Helm.Sample
|
||||
import FRP.Helm.Signal as Signal hiding (lift)
|
||||
import qualified FRP.Helm.Signal (lift)
|
||||
import FRP.Helm.Time (Time)
|
||||
import qualified FRP.Helm.Window as Window
|
||||
import System.FilePath
|
||||
|
||||
import qualified Data.Map as Map
|
||||
import SDL.Event
|
||||
import SDL.Video hiding (windowTitle)
|
||||
import Linear.V2 (V2(V2))
|
||||
import qualified SDL.Init
|
||||
import qualified SDL.Video.Renderer as Renderer
|
||||
import qualified Graphics.Rendering.Cairo as Cairo
|
||||
import qualified Graphics.Rendering.Pango as Pango
|
||||
import Data.Text (pack)
|
||||
|
||||
type Helm a = StateT Engine Cairo.Render a
|
||||
|
||||
{-| A data structure holding the main element and information required for
|
||||
rendering. -}
|
||||
data Application = Application {
|
||||
mainElement :: Element,
|
||||
mainDimensions :: (Int, Int),
|
||||
mainContinue :: Bool
|
||||
}
|
||||
|
||||
{-| A data structure describing miscellaneous initial configurations of the
|
||||
game window and engine. -}
|
||||
data EngineConfig = EngineConfig {
|
||||
windowDimensions :: (Int, Int),
|
||||
windowIsFullscreen :: Bool,
|
||||
windowIsResizable :: Bool,
|
||||
windowTitle :: String
|
||||
}
|
||||
|
||||
{-| Creates the default configuration for the engine. You should change the
|
||||
fields where necessary before passing it to 'run'. -}
|
||||
defaultConfig :: EngineConfig
|
||||
defaultConfig = EngineConfig {
|
||||
windowDimensions = (800, 600),
|
||||
windowIsFullscreen = False,
|
||||
windowIsResizable = True,
|
||||
windowTitle = ""
|
||||
}
|
||||
|
||||
{-| Creates a new engine that can be run later using 'run'. -}
|
||||
startup :: EngineConfig -> IO Engine
|
||||
startup (EngineConfig { .. }) = do
|
||||
SDL.Init.initializeAll
|
||||
window <- createWindow (pack windowTitle) winCfg
|
||||
renderer <- createRenderer window (-1) renCfg
|
||||
showWindow window
|
||||
|
||||
return Engine { window = window
|
||||
, renderer = renderer
|
||||
, cache = Map.empty
|
||||
, continue = True
|
||||
}
|
||||
|
||||
where
|
||||
(w, h) = windowDimensions
|
||||
winCfg = defaultWindow { windowInitialSize = V2 (fromIntegral w) (fromIntegral h)
|
||||
, windowMode = if windowIsFullscreen then Fullscreen else Windowed
|
||||
, windowResizable = windowIsResizable
|
||||
}
|
||||
renCfg = RendererConfig AcceleratedVSyncRenderer False
|
||||
|
||||
{-| Initializes and runs the game engine. The supplied signal generator is
|
||||
constantly sampled for an element to render until the user quits.
|
||||
|
||||
> import FRP.Helm
|
||||
> import qualified FRP.Helm.Window as Window
|
||||
>
|
||||
> render :: (Int, Int) -> Element
|
||||
> render (w, h) = collage w h [rect (fromIntegral w) (fromIntegral h) |> filled red]
|
||||
>
|
||||
> main :: IO ()
|
||||
> main = run defaultConfig $ lift render Window.dimensions
|
||||
-}
|
||||
run :: EngineConfig -> Signal Element -> IO ()
|
||||
run config element = do engine <- startup config
|
||||
run_ engine $ application <~ element
|
||||
~~ Window.dimensions
|
||||
~~ continue'
|
||||
~~ exposed
|
||||
where
|
||||
application :: Element -> (Int, Int) -> Bool -> () -> Application
|
||||
application e d c _ = Application e d c
|
||||
run_ eng (Signal gen) = (start gen >>= run' eng) `finally` SDL.Init.quit
|
||||
|
||||
{-| An event that triggers when SDL thinks we need to re-draw. -}
|
||||
exposed :: Signal ()
|
||||
exposed = Signal getExposed
|
||||
where
|
||||
getExposed = effectful $ do
|
||||
pumpEvents
|
||||
mEvent <- pollEvent
|
||||
case mEvent of
|
||||
Just (Event _ (WindowExposedEvent _)) ->
|
||||
return $ Changed ()
|
||||
_ ->
|
||||
return $ Unchanged ()
|
||||
|
||||
{-| An event that triggers when SDL thinks we need to quit. -}
|
||||
quit :: Signal ()
|
||||
quit = Signal getQuit
|
||||
where
|
||||
getQuit = effectful $ do
|
||||
mEvent <- pollEvent
|
||||
case mEvent of
|
||||
Just (Event _ QuitEvent) ->
|
||||
return $ Changed ()
|
||||
_ ->
|
||||
return $ Unchanged ()
|
||||
|
||||
continue' :: Signal Bool
|
||||
continue' = (==0) <~ count quit
|
||||
|
||||
{-| A utility function called by 'run' that samples the element
|
||||
or quits the entire engine if SDL events say to do so. -}
|
||||
run' :: Engine -> (Engine -> IO (Sample Application)) -> IO ()
|
||||
run' engine smp = when (continue engine) $ smp engine >>= renderIfChanged engine
|
||||
>>= flip run' smp
|
||||
|
||||
{-| Renders when the sample is marked as changed delays the thread otherwise -}
|
||||
renderIfChanged :: Engine -> Sample Application -> IO Engine
|
||||
renderIfChanged engine event = case event of
|
||||
Changed app -> if mainContinue app
|
||||
then render engine (mainElement app) (mainDimensions app)
|
||||
else return engine { continue = False }
|
||||
|
||||
Unchanged _ -> do threadDelay 1000
|
||||
return engine
|
||||
|
||||
{-| A utility function that renders a previously sampled element
|
||||
using an engine state. -}
|
||||
render :: Engine -> Element -> (Int, Int) -> IO Engine
|
||||
render engine@(Engine { .. }) element (w, h) = do
|
||||
texture <- Renderer.createTexture renderer Renderer.ARGB8888
|
||||
Renderer.TextureAccessStreaming (V2 (fromIntegral w) (fromIntegral h))
|
||||
|
||||
(pixels, pitch) <- Renderer.lockTexture texture Nothing
|
||||
|
||||
res <- Cairo.withImageSurfaceForData (castPtr pixels)
|
||||
Cairo.FormatARGB32 w h (fromIntegral pitch) $ \surface -> Cairo.renderWith surface
|
||||
$ evalStateT (render' w h element) engine
|
||||
|
||||
Renderer.unlockTexture texture
|
||||
|
||||
Renderer.clear renderer
|
||||
Renderer.copy renderer texture Nothing Nothing
|
||||
Renderer.destroyTexture texture
|
||||
Renderer.present renderer
|
||||
|
||||
return res
|
||||
|
||||
|
||||
{-| A utility function called by 'render' that is called by Cairo
|
||||
when it's ready to do rendering. -}
|
||||
render' :: Int -> Int -> Element -> Helm Engine
|
||||
render' w h element = do
|
||||
lift $ do Cairo.setSourceRGB 0 0 0
|
||||
Cairo.rectangle 0 0 (fromIntegral w) (fromIntegral h)
|
||||
Cairo.fill
|
||||
|
||||
renderElement element
|
||||
get
|
||||
|
||||
{-| A utility function that lazily grabs an image surface from the cache,
|
||||
i.e. creating it if it's not already stored in it. -}
|
||||
getSurface :: FilePath -> Helm (Cairo.Surface, Int, Int)
|
||||
getSurface src = do
|
||||
Engine _ _ cache _ <- get
|
||||
|
||||
case Map.lookup src cache of
|
||||
Just surface -> do
|
||||
w <- Cairo.imageSurfaceGetWidth surface
|
||||
h <- Cairo.imageSurfaceGetHeight surface
|
||||
|
||||
return (surface, w, h)
|
||||
|
||||
Nothing -> do
|
||||
-- TODO: Use SDL_image to support more formats. I gave up after it was painful
|
||||
-- to convert between the two surface types safely.
|
||||
-- FIXME: Does this throw an error?
|
||||
surface <- liftIO $ Cairo.imageSurfaceCreateFromPNG src
|
||||
w <- liftIO $ Cairo.imageSurfaceGetWidth surface
|
||||
h <- liftIO $ Cairo.imageSurfaceGetHeight surface
|
||||
|
||||
modify (\engine -> engine{cache=Map.insert src surface cache})
|
||||
return (surface, w, h)
|
||||
|
||||
{-| A utility function for rendering a specific element. -}
|
||||
renderElement :: Element -> Helm ()
|
||||
renderElement (CollageElement w h center forms) = do
|
||||
lift $ do Cairo.save
|
||||
Cairo.rectangle 0 0 (fromIntegral w) (fromIntegral h)
|
||||
Cairo.clip
|
||||
forM_ center $ uncurry Cairo.translate
|
||||
mapM_ renderForm forms
|
||||
lift Cairo.restore
|
||||
|
||||
renderElement (ImageElement (sx, sy) sw sh src stretch) = do
|
||||
(surface, w, h) <- getSurface (normalise src)
|
||||
|
||||
lift $ do Cairo.save
|
||||
Cairo.translate (-fromIntegral sx) (-fromIntegral sy)
|
||||
|
||||
if stretch then
|
||||
Cairo.scale (fromIntegral sw / fromIntegral w)
|
||||
(fromIntegral sh / fromIntegral h)
|
||||
else
|
||||
Cairo.scale 1 1
|
||||
|
||||
Cairo.setSourceSurface surface 0 0
|
||||
Cairo.translate (fromIntegral sx) (fromIntegral sy)
|
||||
Cairo.rectangle 0 0 (fromIntegral sw) (fromIntegral sh)
|
||||
if stretch then
|
||||
Cairo.paint
|
||||
else
|
||||
Cairo.fill
|
||||
|
||||
Cairo.restore
|
||||
|
||||
renderElement (TextElement (Text { textColor = (Color r g b a), .. })) = do
|
||||
lift Cairo.save
|
||||
|
||||
layout <- lift $ Pango.createLayout textUTF8
|
||||
|
||||
Cairo.liftIO $ Pango.layoutSetAttributes layout
|
||||
[ Pango.AttrFamily { paStart = i, paEnd = j, paFamily = 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 x y w h <- fmap snd
|
||||
$ Cairo.liftIO $ Pango.layoutGetExtents layout
|
||||
|
||||
lift $ do Cairo.translate ((-w / 2) -x) ((-h / 2) - y)
|
||||
Cairo.setSourceRGBA r g b a
|
||||
Pango.showLayout layout
|
||||
Cairo.restore
|
||||
|
||||
where
|
||||
i = 0
|
||||
j = length textUTF8
|
||||
|
||||
{-| A utility function that maps to a Pango font weight based off our variant. -}
|
||||
mapFontWeight :: FontWeight -> Pango.Weight
|
||||
mapFontWeight weight = case weight of
|
||||
LightWeight -> Pango.WeightLight
|
||||
NormalWeight -> Pango.WeightNormal
|
||||
BoldWeight -> Pango.WeightBold
|
||||
|
||||
{-| A utility function that maps to a Pango font style based off our variant. -}
|
||||
mapFontStyle :: FontStyle -> Pango.FontStyle
|
||||
mapFontStyle style = case style of
|
||||
NormalStyle -> Pango.StyleNormal
|
||||
ObliqueStyle -> Pango.StyleOblique
|
||||
ItalicStyle -> Pango.StyleItalic
|
||||
|
||||
{-| A utility function that goes into a state of transformation and then pops
|
||||
it when finished. -}
|
||||
withTransform :: Double -> Double -> Double -> Double -> Helm () -> Helm ()
|
||||
withTransform s t x y f = do
|
||||
lift $ Cairo.save >> Cairo.scale s s >> Cairo.translate x y >> Cairo.rotate t
|
||||
f
|
||||
lift Cairo.restore
|
||||
|
||||
{-| A utility function that sets the Cairo line cap based off of our version. -}
|
||||
setLineCap :: LineCap -> Cairo.Render ()
|
||||
setLineCap cap = case cap of
|
||||
FlatCap -> Cairo.setLineCap Cairo.LineCapButt
|
||||
RoundCap -> Cairo.setLineCap Cairo.LineCapRound
|
||||
PaddedCap -> Cairo.setLineCap Cairo.LineCapSquare
|
||||
|
||||
{-| A utility function that sets the Cairo line style based off of our version. -}
|
||||
setLineJoin :: LineJoin -> Cairo.Render ()
|
||||
setLineJoin join = case join of
|
||||
SmoothJoin -> Cairo.setLineJoin Cairo.LineJoinRound
|
||||
SharpJoin lim -> Cairo.setLineJoin Cairo.LineJoinMiter >> Cairo.setMiterLimit lim
|
||||
ClippedJoin -> Cairo.setLineJoin Cairo.LineJoinBevel
|
||||
|
||||
{-| A utility function that sets up all the necessary settings with Cairo
|
||||
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
|
||||
Cairo.setSourceRGBA r g b a
|
||||
setLineCap lineCap
|
||||
setLineJoin lineJoin
|
||||
Cairo.setLineWidth lineWidth
|
||||
Cairo.setDash lineDashing lineDashOffset
|
||||
Cairo.stroke
|
||||
|
||||
{-| A utility function that sets up all the necessary settings with Cairo
|
||||
to render with a fill style and then fills afterwards. Assumes
|
||||
that all drawing paths have already been setup before being called. -}
|
||||
setFillStyle :: FillStyle -> Helm ()
|
||||
setFillStyle (Solid (Color r g b a)) = lift $ do
|
||||
Cairo.setSourceRGBA r g b a
|
||||
Cairo.fill
|
||||
|
||||
setFillStyle (Texture src) = do
|
||||
(surface, _, _) <- getSurface (normalise src)
|
||||
lift $ do Cairo.setSourceSurface surface 0 0
|
||||
Cairo.getSource >>= flip Cairo.patternSetExtend Cairo.ExtendRepeat
|
||||
Cairo.fill
|
||||
|
||||
setFillStyle (Gradient (Linear (sx, sy) (ex, ey) points)) =
|
||||
lift $ Cairo.withLinearPattern sx sy ex ey
|
||||
$ \pattern -> setFillStyle' pattern points
|
||||
|
||||
setFillStyle (Gradient (Radial (sx, sy) sr (ex, ey) er points)) =
|
||||
lift $ Cairo.withRadialPattern sx sy sr ex ey er
|
||||
$ \pattern -> setFillStyle' pattern points
|
||||
|
||||
{-| A utility function that adds color stops to a pattern and then fills it. -}
|
||||
setFillStyle' :: Cairo.Pattern -> [(Double, Color)] -> Cairo.Render ()
|
||||
setFillStyle' pattern points = do
|
||||
Cairo.setSource pattern
|
||||
mapM_ (\(o, Color r g b a) -> Cairo.patternAddColorStopRGBA pattern o r g b a) points
|
||||
Cairo.fill
|
||||
|
||||
{-| A utility that renders a form. -}
|
||||
renderForm :: Form -> Helm ()
|
||||
renderForm Form { .. } = withTransform formScale formTheta formX formY $
|
||||
case formStyle of
|
||||
PathForm style ~ps @ ((hx, hy) : _) -> lift $ do
|
||||
Cairo.newPath
|
||||
Cairo.moveTo hx hy
|
||||
mapM_ (uncurry Cairo.lineTo) ps
|
||||
setLineStyle style
|
||||
|
||||
ShapeForm style shape -> do
|
||||
lift Cairo.newPath
|
||||
|
||||
case shape of
|
||||
PolygonShape ~ps @ ((hx, hy) : _) ->
|
||||
lift $ do Cairo.moveTo hx hy
|
||||
mapM_ (uncurry Cairo.lineTo) ps
|
||||
|
||||
RectangleShape (w, h) -> lift $ Cairo.rectangle (-w / 2) (-h / 2) w h
|
||||
|
||||
ArcShape (cx, cy) a1 a2 r (sx, sy) ->
|
||||
lift $ do Cairo.scale sx sy
|
||||
Cairo.arc cx cy r a1 a2
|
||||
Cairo.scale 1 1
|
||||
|
||||
either (lift . setLineStyle) setFillStyle style
|
||||
|
||||
ElementForm element -> renderElement element
|
||||
GroupForm mayhaps forms -> do
|
||||
lift $ do Cairo.save
|
||||
forM_ mayhaps Cairo.setMatrix
|
||||
mapM_ renderForm forms
|
||||
lift Cairo.restore
|
@ -1,11 +0,0 @@
|
||||
module FRP.Helm.Engine where
|
||||
import qualified SDL.Video as Video
|
||||
import qualified Graphics.Rendering.Cairo as Cairo
|
||||
import qualified Data.Map as Map
|
||||
{-| A data structure describing the current engine state. -}
|
||||
data Engine = Engine {
|
||||
window :: Video.Window,
|
||||
renderer :: Video.Renderer,
|
||||
cache :: Map.Map FilePath Cairo.Surface,
|
||||
continue :: Bool
|
||||
}
|
@ -1,791 +0,0 @@
|
||||
{-| Contains signals that sample input from the keyboard. -}
|
||||
module FRP.Helm.Keyboard (
|
||||
-- * Types
|
||||
Key(..),
|
||||
-- * Key State
|
||||
isDown, keysDown,
|
||||
-- * Directions
|
||||
arrows, wasd
|
||||
) where
|
||||
|
||||
import Data.List
|
||||
import Foreign hiding (shift)
|
||||
import Foreign.C.Types
|
||||
import FRP.Elerea.Param hiding (Signal)
|
||||
import FRP.Helm.Sample
|
||||
import FRP.Helm.Signal
|
||||
|
||||
{-| The SDL bindings for Haskell don't wrap this, so we have to use the FFI ourselves. -}
|
||||
foreign import ccall unsafe "SDL_GetKeyboardState" sdlGetKeyState :: Ptr CInt -> IO (Ptr Word8)
|
||||
|
||||
{-| A utility function for getting a list of SDL keys currently pressed.
|
||||
Based on <http://coderepos.org/share/browser/lang/haskell/nario/Main.hs?rev=22646#L49>. -}
|
||||
getKeyState :: IO [Int]
|
||||
getKeyState = alloca $ \numkeysPtr -> do
|
||||
keysPtr <- sdlGetKeyState numkeysPtr
|
||||
numkeys <- peek numkeysPtr
|
||||
|
||||
(map fromIntegral . elemIndices 1) <$> peekArray (fromIntegral numkeys) keysPtr
|
||||
|
||||
{-| A data structure describing a physical key on a keyboard. -}
|
||||
data Key
|
||||
= 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
|
||||
| Number1Key
|
||||
| Number2Key
|
||||
| Number3Key
|
||||
| Number4Key
|
||||
| Number5Key
|
||||
| Number6Key
|
||||
| Number7Key
|
||||
| Number8Key
|
||||
| Number9Key
|
||||
| Number0Key
|
||||
| ReturnKey
|
||||
| EscapeKey
|
||||
| BackspaceKey
|
||||
| TabKey
|
||||
| SpaceKey
|
||||
| MinusKey
|
||||
| EqualsKey
|
||||
| LeftBracketKey
|
||||
| RightBracketKey
|
||||
| BackslashKey
|
||||
| NonUSHashKey
|
||||
| SemicolonKey
|
||||
| ApostropheKey
|
||||
| GraveKey
|
||||
| CommaKey
|
||||
| PeriodKey
|
||||
| SlashKey
|
||||
| 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
|
||||
| NonUSBackslashKey
|
||||
| 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
|
||||
| International1Key
|
||||
| International2Key
|
||||
| International3Key
|
||||
| International4Key
|
||||
| International5Key
|
||||
| International6Key
|
||||
| International7Key
|
||||
| International8Key
|
||||
| International9Key
|
||||
| Lang1Key
|
||||
| Lang2Key
|
||||
| Lang3Key
|
||||
| Lang4Key
|
||||
| Lang5Key
|
||||
| Lang6Key
|
||||
| Lang7Key
|
||||
| Lang8Key
|
||||
| Lang9Key
|
||||
| AltEraseKey
|
||||
| SysReqKey
|
||||
| CancelKey
|
||||
| ClearKey
|
||||
| PriorKey
|
||||
| Return2Key
|
||||
| SeparatorKey
|
||||
| OutKey
|
||||
| OperKey
|
||||
| ClearAgainKey
|
||||
| CrSelKey
|
||||
| ExSelKey
|
||||
| Keypad00Key
|
||||
| Keypad000Key
|
||||
| ThousandSeparatorKey
|
||||
| DecimalSeparatorKey
|
||||
| CurrencyUnitKey
|
||||
| CurrencySubUnitKey
|
||||
| KeypadLeftParenKey
|
||||
| KeypadRightParenKey
|
||||
| KeypadLeftBraceKey
|
||||
| KeypadRightBraceKey
|
||||
| KeypadTabKey
|
||||
| KeypadBackspaceKey
|
||||
| KeypadAKey
|
||||
| KeypadBKey
|
||||
| KeypadCKey
|
||||
| KeypadDKey
|
||||
| KeypadEKey
|
||||
| KeypadFKey
|
||||
| KeypadXORKey
|
||||
| KeypadPowerKey
|
||||
| KeypadPercentKey
|
||||
| KeypadLessKey
|
||||
| KeypadGreaterKey
|
||||
| KeypadAmpersandKey
|
||||
| KeypadDoubleAmpersandKey
|
||||
| KeypadVerticalBarKey
|
||||
| KeypadDoubleVerticalBarKey
|
||||
| KeypadColonKey
|
||||
| KeypadHashKey
|
||||
| KeypadSpaceKey
|
||||
| KeypadAtKey
|
||||
| KeypadExclamationKey
|
||||
| KeypadMemStoreKey
|
||||
| KeypadMemRecallKey
|
||||
| KeypadMemClearKey
|
||||
| KeypadMemAddKey
|
||||
| KeypadMemSubstractKey
|
||||
| KeypadMemMultiplyKey
|
||||
| KeypadMemDivideKey
|
||||
| KeypadPlusMinusKey
|
||||
| KeypadClearKey
|
||||
| KeypadClearEntryKey
|
||||
| KeypadBinaryKey
|
||||
| KeypadOctalKey
|
||||
| KeypadDecimalKey
|
||||
| KeypadHexadecimalKey
|
||||
| LeftControlKey
|
||||
| LeftShiftKey
|
||||
| LeftAltKey
|
||||
| LeftMetaKey
|
||||
| RightControlKey
|
||||
| RightShiftKey
|
||||
| RightAltKey
|
||||
| RightMetaKey
|
||||
| ModeKey
|
||||
| AudioNextKey
|
||||
| AudioPreviousKey
|
||||
| AudioStopKey
|
||||
| AudioPlayKey
|
||||
| AudioMuteKey
|
||||
| MediaSelectKey
|
||||
| WWWKey
|
||||
| MailKey
|
||||
| CalculatorKey
|
||||
| ComputerKey
|
||||
| ACSearchKey
|
||||
| ACHomeKey
|
||||
| ACBackKey
|
||||
| ACForwardKey
|
||||
| ACStopKey
|
||||
| ACRefreshKey
|
||||
| ACBookmarksKey
|
||||
| BrightnessDownKey
|
||||
| BrightnessUpKey
|
||||
| DisplaySwitchKey
|
||||
| KeyboardIllumToggleKey
|
||||
| KeyboardIllumDownKey
|
||||
| KeyboardIllumUpKey
|
||||
| EjectKey
|
||||
| SleepKey
|
||||
| App1Key
|
||||
| App2Key
|
||||
deriving (Show, Eq, Ord, Read)
|
||||
|
||||
{- All integer values of this enum are equivalent to the SDL scancode enum. -}
|
||||
instance Enum Key where
|
||||
fromEnum AKey = 4
|
||||
fromEnum BKey = 5
|
||||
fromEnum CKey = 6
|
||||
fromEnum DKey = 7
|
||||
fromEnum EKey = 8
|
||||
fromEnum FKey = 9
|
||||
fromEnum GKey = 10
|
||||
fromEnum HKey = 11
|
||||
fromEnum IKey = 12
|
||||
fromEnum JKey = 13
|
||||
fromEnum KKey = 14
|
||||
fromEnum LKey = 15
|
||||
fromEnum MKey = 16
|
||||
fromEnum NKey = 17
|
||||
fromEnum OKey = 18
|
||||
fromEnum PKey = 19
|
||||
fromEnum QKey = 20
|
||||
fromEnum RKey = 21
|
||||
fromEnum SKey = 22
|
||||
fromEnum TKey = 23
|
||||
fromEnum UKey = 24
|
||||
fromEnum VKey = 25
|
||||
fromEnum WKey = 26
|
||||
fromEnum XKey = 27
|
||||
fromEnum YKey = 28
|
||||
fromEnum ZKey = 29
|
||||
fromEnum Number1Key = 30
|
||||
fromEnum Number2Key = 31
|
||||
fromEnum Number3Key = 32
|
||||
fromEnum Number4Key = 33
|
||||
fromEnum Number5Key = 34
|
||||
fromEnum Number6Key = 35
|
||||
fromEnum Number7Key = 36
|
||||
fromEnum Number8Key = 37
|
||||
fromEnum Number9Key = 38
|
||||
fromEnum Number0Key = 39
|
||||
fromEnum ReturnKey = 40
|
||||
fromEnum EscapeKey = 41
|
||||
fromEnum BackspaceKey = 42
|
||||
fromEnum TabKey = 43
|
||||
fromEnum SpaceKey = 44
|
||||
fromEnum MinusKey = 45
|
||||
fromEnum EqualsKey = 46
|
||||
fromEnum LeftBracketKey = 47
|
||||
fromEnum RightBracketKey = 48
|
||||
fromEnum BackslashKey = 49
|
||||
fromEnum NonUSHashKey = 50
|
||||
fromEnum SemicolonKey = 51
|
||||
fromEnum ApostropheKey = 52
|
||||
fromEnum GraveKey = 53
|
||||
fromEnum CommaKey = 54
|
||||
fromEnum PeriodKey = 55
|
||||
fromEnum SlashKey = 56
|
||||
fromEnum CapslockKey = 57
|
||||
fromEnum F1Key = 58
|
||||
fromEnum F2Key = 59
|
||||
fromEnum F3Key = 60
|
||||
fromEnum F4Key = 61
|
||||
fromEnum F5Key = 62
|
||||
fromEnum F6Key = 63
|
||||
fromEnum F7Key = 64
|
||||
fromEnum F8Key = 65
|
||||
fromEnum F9Key = 66
|
||||
fromEnum F10Key = 67
|
||||
fromEnum F11Key = 68
|
||||
fromEnum F12Key = 69
|
||||
fromEnum PrintScreenKey = 70
|
||||
fromEnum ScrollLockKey = 71
|
||||
fromEnum PauseKey = 72
|
||||
fromEnum InsertKey = 73
|
||||
fromEnum HomeKey = 74
|
||||
fromEnum PageUpKey = 75
|
||||
fromEnum DeleteKey = 76
|
||||
fromEnum EndKey = 77
|
||||
fromEnum PageDownKey = 78
|
||||
fromEnum RightKey = 79
|
||||
fromEnum LeftKey = 80
|
||||
fromEnum DownKey = 81
|
||||
fromEnum UpKey = 82
|
||||
fromEnum NumLockClearKey = 83
|
||||
fromEnum KeypadDivideKey = 84
|
||||
fromEnum KeypadMultiplyKey = 85
|
||||
fromEnum KeypadMinusKey = 86
|
||||
fromEnum KeypadPlusKey = 87
|
||||
fromEnum KeypadEnterKey = 88
|
||||
fromEnum Keypad1Key = 89
|
||||
fromEnum Keypad2Key = 90
|
||||
fromEnum Keypad3Key = 91
|
||||
fromEnum Keypad4Key = 92
|
||||
fromEnum Keypad5Key = 93
|
||||
fromEnum Keypad6Key = 94
|
||||
fromEnum Keypad7Key = 95
|
||||
fromEnum Keypad8Key = 96
|
||||
fromEnum Keypad9Key = 97
|
||||
fromEnum Keypad0Key = 98
|
||||
fromEnum KeypadPeriodKey = 99
|
||||
fromEnum NonUSBackslashKey = 100
|
||||
fromEnum ApplicationKey = 101
|
||||
fromEnum PowerKey = 102
|
||||
fromEnum KeypadEqualsKey = 103
|
||||
fromEnum F13Key = 104
|
||||
fromEnum F14Key = 105
|
||||
fromEnum F15Key = 106
|
||||
fromEnum F16Key = 107
|
||||
fromEnum F17Key = 108
|
||||
fromEnum F18Key = 109
|
||||
fromEnum F19Key = 110
|
||||
fromEnum F20Key = 111
|
||||
fromEnum F21Key = 112
|
||||
fromEnum F22Key = 113
|
||||
fromEnum F23Key = 114
|
||||
fromEnum F24Key = 115
|
||||
fromEnum ExecuteKey = 116
|
||||
fromEnum HelpKey = 117
|
||||
fromEnum MenuKey = 118
|
||||
fromEnum SelectKey = 119
|
||||
fromEnum StopKey = 120
|
||||
fromEnum AgainKey = 121
|
||||
fromEnum UndoKey = 122
|
||||
fromEnum CutKey = 123
|
||||
fromEnum CopyKey = 124
|
||||
fromEnum PasteKey = 125
|
||||
fromEnum FindKey = 126
|
||||
fromEnum MuteKey = 127
|
||||
fromEnum VolumeUpKey = 128
|
||||
fromEnum VolumeDownKey = 129
|
||||
fromEnum KeypadCommaKey = 133
|
||||
fromEnum KeyPadEqualsAs400Key = 134
|
||||
fromEnum International1Key = 135
|
||||
fromEnum International2Key = 136
|
||||
fromEnum International3Key = 137
|
||||
fromEnum International4Key = 138
|
||||
fromEnum International5Key = 139
|
||||
fromEnum International6Key = 140
|
||||
fromEnum International7Key = 141
|
||||
fromEnum International8Key = 142
|
||||
fromEnum International9Key = 143
|
||||
fromEnum Lang1Key = 144
|
||||
fromEnum Lang2Key = 145
|
||||
fromEnum Lang3Key = 146
|
||||
fromEnum Lang4Key = 147
|
||||
fromEnum Lang5Key = 148
|
||||
fromEnum Lang6Key = 149
|
||||
fromEnum Lang7Key = 150
|
||||
fromEnum Lang8Key = 151
|
||||
fromEnum Lang9Key = 152
|
||||
fromEnum AltEraseKey = 153
|
||||
fromEnum SysReqKey = 154
|
||||
fromEnum CancelKey = 155
|
||||
fromEnum ClearKey = 156
|
||||
fromEnum PriorKey = 157
|
||||
fromEnum Return2Key = 158
|
||||
fromEnum SeparatorKey = 159
|
||||
fromEnum OutKey = 160
|
||||
fromEnum OperKey = 161
|
||||
fromEnum ClearAgainKey = 162
|
||||
fromEnum CrSelKey = 163
|
||||
fromEnum ExSelKey = 164
|
||||
fromEnum Keypad00Key = 176
|
||||
fromEnum Keypad000Key = 177
|
||||
fromEnum ThousandSeparatorKey = 178
|
||||
fromEnum DecimalSeparatorKey = 179
|
||||
fromEnum CurrencyUnitKey = 180
|
||||
fromEnum CurrencySubUnitKey = 181
|
||||
fromEnum KeypadLeftParenKey = 182
|
||||
fromEnum KeypadRightParenKey = 183
|
||||
fromEnum KeypadLeftBraceKey = 184
|
||||
fromEnum KeypadRightBraceKey = 185
|
||||
fromEnum KeypadTabKey = 186
|
||||
fromEnum KeypadBackspaceKey = 187
|
||||
fromEnum KeypadAKey = 188
|
||||
fromEnum KeypadBKey = 189
|
||||
fromEnum KeypadCKey = 190
|
||||
fromEnum KeypadDKey = 191
|
||||
fromEnum KeypadEKey = 192
|
||||
fromEnum KeypadFKey = 193
|
||||
fromEnum KeypadXORKey = 194
|
||||
fromEnum KeypadPowerKey = 195
|
||||
fromEnum KeypadPercentKey = 196
|
||||
fromEnum KeypadLessKey = 197
|
||||
fromEnum KeypadGreaterKey = 198
|
||||
fromEnum KeypadAmpersandKey = 199
|
||||
fromEnum KeypadDoubleAmpersandKey = 200
|
||||
fromEnum KeypadVerticalBarKey = 201
|
||||
fromEnum KeypadDoubleVerticalBarKey = 202
|
||||
fromEnum KeypadColonKey = 203
|
||||
fromEnum KeypadHashKey = 204
|
||||
fromEnum KeypadSpaceKey = 205
|
||||
fromEnum KeypadAtKey = 206
|
||||
fromEnum KeypadExclamationKey = 207
|
||||
fromEnum KeypadMemStoreKey = 208
|
||||
fromEnum KeypadMemRecallKey = 209
|
||||
fromEnum KeypadMemClearKey = 210
|
||||
fromEnum KeypadMemAddKey = 211
|
||||
fromEnum KeypadMemSubstractKey = 212
|
||||
fromEnum KeypadMemMultiplyKey = 213
|
||||
fromEnum KeypadMemDivideKey = 214
|
||||
fromEnum KeypadPlusMinusKey = 215
|
||||
fromEnum KeypadClearKey = 216
|
||||
fromEnum KeypadClearEntryKey = 217
|
||||
fromEnum KeypadBinaryKey = 218
|
||||
fromEnum KeypadOctalKey = 219
|
||||
fromEnum KeypadDecimalKey = 220
|
||||
fromEnum KeypadHexadecimalKey = 221
|
||||
fromEnum LeftControlKey = 224
|
||||
fromEnum LeftShiftKey = 225
|
||||
fromEnum LeftAltKey = 226
|
||||
fromEnum LeftMetaKey = 227
|
||||
fromEnum RightControlKey = 228
|
||||
fromEnum RightShiftKey = 299
|
||||
fromEnum RightAltKey = 230
|
||||
fromEnum RightMetaKey = 231
|
||||
fromEnum ModeKey = 257
|
||||
fromEnum AudioNextKey = 258
|
||||
fromEnum AudioPreviousKey = 259
|
||||
fromEnum AudioStopKey = 260
|
||||
fromEnum AudioPlayKey = 261
|
||||
fromEnum AudioMuteKey = 262
|
||||
fromEnum MediaSelectKey = 263
|
||||
fromEnum WWWKey = 264
|
||||
fromEnum MailKey = 265
|
||||
fromEnum CalculatorKey = 266
|
||||
fromEnum ComputerKey = 267
|
||||
fromEnum ACSearchKey = 268
|
||||
fromEnum ACHomeKey = 269
|
||||
fromEnum ACBackKey = 270
|
||||
fromEnum ACForwardKey = 271
|
||||
fromEnum ACStopKey = 272
|
||||
fromEnum ACRefreshKey = 273
|
||||
fromEnum ACBookmarksKey = 274
|
||||
fromEnum BrightnessDownKey = 275
|
||||
fromEnum BrightnessUpKey = 276
|
||||
fromEnum DisplaySwitchKey = 277
|
||||
fromEnum KeyboardIllumToggleKey = 278
|
||||
fromEnum KeyboardIllumDownKey = 279
|
||||
fromEnum KeyboardIllumUpKey = 280
|
||||
fromEnum EjectKey = 281
|
||||
fromEnum SleepKey = 282
|
||||
fromEnum App1Key = 283
|
||||
fromEnum App2Key = 284
|
||||
|
||||
toEnum 4 = AKey
|
||||
toEnum 5 = BKey
|
||||
toEnum 6 = CKey
|
||||
toEnum 7 = DKey
|
||||
toEnum 8 = EKey
|
||||
toEnum 9 = FKey
|
||||
toEnum 10 = GKey
|
||||
toEnum 11 = HKey
|
||||
toEnum 12 = IKey
|
||||
toEnum 13 = JKey
|
||||
toEnum 14 = KKey
|
||||
toEnum 15 = LKey
|
||||
toEnum 16 = MKey
|
||||
toEnum 17 = NKey
|
||||
toEnum 18 = OKey
|
||||
toEnum 19 = PKey
|
||||
toEnum 20 = QKey
|
||||
toEnum 21 = RKey
|
||||
toEnum 22 = SKey
|
||||
toEnum 23 = TKey
|
||||
toEnum 24 = UKey
|
||||
toEnum 25 = VKey
|
||||
toEnum 26 = WKey
|
||||
toEnum 27 = XKey
|
||||
toEnum 28 = YKey
|
||||
toEnum 29 = ZKey
|
||||
toEnum 30 = Number1Key
|
||||
toEnum 31 = Number2Key
|
||||
toEnum 32 = Number3Key
|
||||
toEnum 33 = Number4Key
|
||||
toEnum 34 = Number5Key
|
||||
toEnum 35 = Number6Key
|
||||
toEnum 36 = Number7Key
|
||||
toEnum 37 = Number8Key
|
||||
toEnum 38 = Number9Key
|
||||
toEnum 39 = Number0Key
|
||||
toEnum 40 = ReturnKey
|
||||
toEnum 41 = EscapeKey
|
||||
toEnum 42 = BackspaceKey
|
||||
toEnum 43 = TabKey
|
||||
toEnum 44 = SpaceKey
|
||||
toEnum 45 = MinusKey
|
||||
toEnum 46 = EqualsKey
|
||||
toEnum 47 = LeftBracketKey
|
||||
toEnum 48 = RightBracketKey
|
||||
toEnum 49 = BackslashKey
|
||||
toEnum 50 = NonUSHashKey
|
||||
toEnum 51 = SemicolonKey
|
||||
toEnum 52 = ApostropheKey
|
||||
toEnum 53 = GraveKey
|
||||
toEnum 54 = CommaKey
|
||||
toEnum 55 = PeriodKey
|
||||
toEnum 56 = SlashKey
|
||||
toEnum 57 = CapslockKey
|
||||
toEnum 58 = F1Key
|
||||
toEnum 59 = F2Key
|
||||
toEnum 60 = F3Key
|
||||
toEnum 61 = F4Key
|
||||
toEnum 62 = F5Key
|
||||
toEnum 63 = F6Key
|
||||
toEnum 64 = F7Key
|
||||
toEnum 65 = F8Key
|
||||
toEnum 66 = F9Key
|
||||
toEnum 67 = F10Key
|
||||
toEnum 68 = F11Key
|
||||
toEnum 69 = F12Key
|
||||
toEnum 70 = PrintScreenKey
|
||||
toEnum 71 = ScrollLockKey
|
||||
toEnum 72 = PauseKey
|
||||
toEnum 73 = InsertKey
|
||||
toEnum 74 = HomeKey
|
||||
toEnum 75 = PageUpKey
|
||||
toEnum 76 = DeleteKey
|
||||
toEnum 77 = EndKey
|
||||
toEnum 78 = PageDownKey
|
||||
toEnum 79 = RightKey
|
||||
toEnum 80 = LeftKey
|
||||
toEnum 81 = DownKey
|
||||
toEnum 82 = UpKey
|
||||
toEnum 83 = NumLockClearKey
|
||||
toEnum 84 = KeypadDivideKey
|
||||
toEnum 85 = KeypadMultiplyKey
|
||||
toEnum 86 = KeypadMinusKey
|
||||
toEnum 87 = KeypadPlusKey
|
||||
toEnum 88 = KeypadEnterKey
|
||||
toEnum 89 = Keypad1Key
|
||||
toEnum 90 = Keypad2Key
|
||||
toEnum 91 = Keypad3Key
|
||||
toEnum 92 = Keypad4Key
|
||||
toEnum 93 = Keypad5Key
|
||||
toEnum 94 = Keypad6Key
|
||||
toEnum 95 = Keypad7Key
|
||||
toEnum 96 = Keypad8Key
|
||||
toEnum 97 = Keypad9Key
|
||||
toEnum 98 = Keypad0Key
|
||||
toEnum 99 = KeypadPeriodKey
|
||||
toEnum 100 = NonUSBackslashKey
|
||||
toEnum 101 = ApplicationKey
|
||||
toEnum 102 = PowerKey
|
||||
toEnum 103 = KeypadEqualsKey
|
||||
toEnum 104 = F13Key
|
||||
toEnum 105 = F14Key
|
||||
toEnum 106 = F15Key
|
||||
toEnum 107 = F16Key
|
||||
toEnum 108 = F17Key
|
||||
toEnum 109 = F18Key
|
||||
toEnum 110 = F19Key
|
||||
toEnum 111 = F20Key
|
||||
toEnum 112 = F21Key
|
||||
toEnum 113 = F22Key
|
||||
toEnum 114 = F23Key
|
||||
toEnum 115 = F24Key
|
||||
toEnum 116 = ExecuteKey
|
||||
toEnum 117 = HelpKey
|
||||
toEnum 118 = MenuKey
|
||||
toEnum 119 = SelectKey
|
||||
toEnum 120 = StopKey
|
||||
toEnum 121 = AgainKey
|
||||
toEnum 122 = UndoKey
|
||||
toEnum 123 = CutKey
|
||||
toEnum 124 = CopyKey
|
||||
toEnum 125 = PasteKey
|
||||
toEnum 126 = FindKey
|
||||
toEnum 127 = MuteKey
|
||||
toEnum 128 = VolumeUpKey
|
||||
toEnum 129 = VolumeDownKey
|
||||
toEnum 133 = KeypadCommaKey
|
||||
toEnum 134 = KeyPadEqualsAs400Key
|
||||
toEnum 135 = International1Key
|
||||
toEnum 136 = International2Key
|
||||
toEnum 137 = International3Key
|
||||
toEnum 138 = International4Key
|
||||
toEnum 139 = International5Key
|
||||
toEnum 140 = International6Key
|
||||
toEnum 141 = International7Key
|
||||
toEnum 142 = International8Key
|
||||
toEnum 143 = International9Key
|
||||
toEnum 144 = Lang1Key
|
||||
toEnum 145 = Lang2Key
|
||||
toEnum 146 = Lang3Key
|
||||
toEnum 147 = Lang4Key
|
||||
toEnum 148 = Lang5Key
|
||||
toEnum 149 = Lang6Key
|
||||
toEnum 150 = Lang7Key
|
||||
toEnum 151 = Lang8Key
|
||||
toEnum 152 = Lang9Key
|
||||
toEnum 153 = AltEraseKey
|
||||
toEnum 154 = SysReqKey
|
||||
toEnum 155 = CancelKey
|
||||
toEnum 156 = ClearKey
|
||||
toEnum 157 = PriorKey
|
||||
toEnum 158 = Return2Key
|
||||
toEnum 159 = SeparatorKey
|
||||
toEnum 160 = OutKey
|
||||
toEnum 161 = OperKey
|
||||
toEnum 162 = ClearAgainKey
|
||||
toEnum 163 = CrSelKey
|
||||
toEnum 164 = ExSelKey
|
||||
toEnum 176 = Keypad00Key
|
||||
toEnum 177 = Keypad000Key
|
||||
toEnum 178 = ThousandSeparatorKey
|
||||
toEnum 179 = DecimalSeparatorKey
|
||||
toEnum 180 = CurrencyUnitKey
|
||||
toEnum 181 = CurrencySubUnitKey
|
||||
toEnum 182 = KeypadLeftParenKey
|
||||
toEnum 183 = KeypadRightParenKey
|
||||
toEnum 184 = KeypadLeftBraceKey
|
||||
toEnum 185 = KeypadRightBraceKey
|
||||
toEnum 186 = KeypadTabKey
|
||||
toEnum 187 = KeypadBackspaceKey
|
||||
toEnum 188 = KeypadAKey
|
||||
toEnum 189 = KeypadBKey
|
||||
toEnum 190 = KeypadCKey
|
||||
toEnum 191 = KeypadDKey
|
||||
toEnum 192 = KeypadEKey
|
||||
toEnum 193 = KeypadFKey
|
||||
toEnum 194 = KeypadXORKey
|
||||
toEnum 195 = KeypadPowerKey
|
||||
toEnum 196 = KeypadPercentKey
|
||||
toEnum 197 = KeypadLessKey
|
||||
toEnum 198 = KeypadGreaterKey
|
||||
toEnum 199 = KeypadAmpersandKey
|
||||
toEnum 200 = KeypadDoubleAmpersandKey
|
||||
toEnum 201 = KeypadVerticalBarKey
|
||||
toEnum 202 = KeypadDoubleVerticalBarKey
|
||||
toEnum 203 = KeypadColonKey
|
||||
toEnum 204 = KeypadHashKey
|
||||
toEnum 205 = KeypadSpaceKey
|
||||
toEnum 206 = KeypadAtKey
|
||||
toEnum 207 = KeypadExclamationKey
|
||||
toEnum 208 = KeypadMemStoreKey
|
||||
toEnum 209 = KeypadMemRecallKey
|
||||
toEnum 210 = KeypadMemClearKey
|
||||
toEnum 211 = KeypadMemAddKey
|
||||
toEnum 212 = KeypadMemSubstractKey
|
||||
toEnum 213 = KeypadMemMultiplyKey
|
||||
toEnum 214 = KeypadMemDivideKey
|
||||
toEnum 215 = KeypadPlusMinusKey
|
||||
toEnum 216 = KeypadClearKey
|
||||
toEnum 217 = KeypadClearEntryKey
|
||||
toEnum 218 = KeypadBinaryKey
|
||||
toEnum 219 = KeypadOctalKey
|
||||
toEnum 220 = KeypadDecimalKey
|
||||
toEnum 221 = KeypadHexadecimalKey
|
||||
toEnum 224 = LeftControlKey
|
||||
toEnum 225 = LeftShiftKey
|
||||
toEnum 226 = LeftAltKey
|
||||
toEnum 227 = LeftMetaKey
|
||||
toEnum 228 = RightControlKey
|
||||
toEnum 299 = RightShiftKey
|
||||
toEnum 230 = RightAltKey
|
||||
toEnum 231 = RightMetaKey
|
||||
toEnum 257 = ModeKey
|
||||
toEnum 258 = AudioNextKey
|
||||
toEnum 259 = AudioPreviousKey
|
||||
toEnum 260 = AudioStopKey
|
||||
toEnum 261 = AudioPlayKey
|
||||
toEnum 262 = AudioMuteKey
|
||||
toEnum 263 = MediaSelectKey
|
||||
toEnum 264 = WWWKey
|
||||
toEnum 265 = MailKey
|
||||
toEnum 266 = CalculatorKey
|
||||
toEnum 267 = ComputerKey
|
||||
toEnum 268 = ACSearchKey
|
||||
toEnum 269 = ACHomeKey
|
||||
toEnum 270 = ACBackKey
|
||||
toEnum 271 = ACForwardKey
|
||||
toEnum 272 = ACStopKey
|
||||
toEnum 273 = ACRefreshKey
|
||||
toEnum 274 = ACBookmarksKey
|
||||
toEnum 275 = BrightnessDownKey
|
||||
toEnum 276 = BrightnessUpKey
|
||||
toEnum 277 = DisplaySwitchKey
|
||||
toEnum 278 = KeyboardIllumToggleKey
|
||||
toEnum 279 = KeyboardIllumDownKey
|
||||
toEnum 280 = KeyboardIllumUpKey
|
||||
toEnum 281 = EjectKey
|
||||
toEnum 282 = SleepKey
|
||||
toEnum 283 = App1Key
|
||||
toEnum 284 = App2Key
|
||||
toEnum _ = error "FRP.Helm.Keyboard.Key.toEnum: bad argument"
|
||||
|
||||
{-| Whether a key is pressed. -}
|
||||
isDown :: Key -> Signal Bool
|
||||
isDown k = Signal $ getDown >>= transfer (pure True) update
|
||||
where getDown = effectful $ elem (fromEnum k) <$> getKeyState
|
||||
|
||||
{-| A list of keys that are currently being pressed. -}
|
||||
keysDown :: Signal [Key]
|
||||
keysDown = Signal $ getDown >>= transfer (pure []) update
|
||||
where getDown = effectful $ map toEnum <$> getKeyState
|
||||
|
||||
{-| A directional tuple combined from the arrow keys. When none of the arrow keys
|
||||
are being pressed this signal samples to /(0, 0)/, otherwise it samples to a
|
||||
direction based on which keys are pressed. For example, pressing the left key
|
||||
results in /(-1, 0)/, the down key /(0, 1)/, up and right /(1, -1)/, etc. -}
|
||||
arrows :: Signal (Int, Int)
|
||||
arrows = arrows' <$> up <*> left <*> down <*> right
|
||||
where up = isDown UpKey
|
||||
left = isDown LeftKey
|
||||
down = isDown DownKey
|
||||
right = isDown RightKey
|
||||
|
||||
|
||||
{-| A utility function for setting up a vector signal from directional keys. -}
|
||||
arrows' :: Bool -> Bool -> Bool -> Bool -> (Int, Int)
|
||||
arrows' u l d r = (-1 * fromEnum l + 1 * fromEnum r, -1 * fromEnum u + 1 * fromEnum d)
|
||||
|
||||
{-| Similar to the 'arrows' signal, but uses the popular WASD movement controls instead. -}
|
||||
wasd :: Signal (Int, Int)
|
||||
wasd = arrows' <$> w <*> a <*> s <*> d
|
||||
where w = isDown WKey
|
||||
a = isDown AKey
|
||||
s = isDown SKey
|
||||
d = isDown DKey
|
@ -1,53 +0,0 @@
|
||||
{-| Contains signals that sample input from the mouse. -}
|
||||
module FRP.Helm.Mouse
|
||||
(
|
||||
-- * Position
|
||||
position, x, y,
|
||||
-- * Mouse State
|
||||
isDown,
|
||||
isDownButton,
|
||||
clicks
|
||||
) where
|
||||
|
||||
import FRP.Elerea.Param hiding (Signal)
|
||||
import FRP.Helm.Sample
|
||||
import FRP.Helm.Signal
|
||||
import SDL.Input.Mouse
|
||||
import Linear.V2 (V2(V2))
|
||||
import Linear.Affine (Point(P))
|
||||
|
||||
{-| The current position of the mouse. -}
|
||||
position :: Signal (Int, Int)
|
||||
position = Signal $ getPosition >>= transfer (pure (0,0)) update
|
||||
where
|
||||
getPosition = effectful $ do
|
||||
P (V2 x_ y_) <- getAbsoluteMouseLocation
|
||||
return (fromIntegral x_, fromIntegral y_)
|
||||
|
||||
{-| The current x-coordinate of the mouse. -}
|
||||
x :: Signal Int
|
||||
x = fst <~ position
|
||||
|
||||
{-| The current y-coordinate of the mouse. -}
|
||||
y :: Signal Int
|
||||
y = snd <~ position
|
||||
|
||||
{-| The current state of the left mouse-button. True when the button is down,
|
||||
and false otherwise. -}
|
||||
isDown :: Signal Bool
|
||||
isDown = isDownButton ButtonLeft
|
||||
|
||||
{-| The current state of a given mouse button. True if down, false otherwise.
|
||||
-}
|
||||
isDownButton :: MouseButton -> Signal Bool
|
||||
isDownButton btn = Signal $ getDown >>= transfer (pure False) update
|
||||
where
|
||||
getDown = effectful $ do
|
||||
btnMap <- getMouseButtons
|
||||
return (btnMap btn)
|
||||
|
||||
{-| Always equal to unit. Event triggers on every mouse click. -}
|
||||
clicks :: Signal ()
|
||||
clicks = Signal $ signalGen isDown >>= transfer (pure ()) update_
|
||||
where update_ _ (Changed True) _ = Changed ()
|
||||
update_ _ _ _ = Unchanged ()
|
@ -1,80 +0,0 @@
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
module FRP.Helm.Random (
|
||||
range,
|
||||
float,
|
||||
floatList
|
||||
) where
|
||||
import Control.Monad (liftM, join, replicateM)
|
||||
import FRP.Elerea.Param hiding (Signal)
|
||||
import qualified FRP.Elerea.Param as Elerea (Signal)
|
||||
import FRP.Helm.Signal
|
||||
import FRP.Helm.Sample
|
||||
import FRP.Helm.Engine
|
||||
import System.Random (Random, randomRIO)
|
||||
|
||||
{-| Given a range from low to high and a signal of values, this produces
|
||||
a new signal that changes whenever the input signal changes. The new
|
||||
values are random number between 'low' and 'high' inclusive.
|
||||
-}
|
||||
range :: Int -> Int -> Signal a -> Signal Int
|
||||
range x y = rand (x,y)
|
||||
|
||||
{-| Produces a new signal that changes whenever the input signal changes.
|
||||
The new values are random numbers in [0..1).
|
||||
-}
|
||||
float :: Signal a -> Signal Float
|
||||
float = rand (0,1)
|
||||
|
||||
{-| A utility signal that does the work for 'float' and 'range'. -}
|
||||
rand :: (Random a, Num a) =>
|
||||
(a, a) -> Signal b -> Signal a
|
||||
rand limits s = Signal $ do
|
||||
s' <- signalGen s
|
||||
rs :: Elerea.Signal (SignalGen Engine (Elerea.Signal a))
|
||||
<- randomGens limits s'
|
||||
r :: Elerea.Signal (Elerea.Signal a)
|
||||
<- generator rs
|
||||
transfer2 (pure 0) update_ s' (join r)
|
||||
where
|
||||
update_ :: (Random a, Num a) => p ->
|
||||
Sample b -> a -> Sample a -> Sample a
|
||||
update_ _ new random old = case new of
|
||||
Changed _ -> Changed random
|
||||
Unchanged _ -> Unchanged $ value old
|
||||
randomGens :: (Random a, Num a) =>
|
||||
(a,a) -> Elerea.Signal (Sample b)
|
||||
-> SignalGen p (Elerea.Signal
|
||||
(SignalGen p (Elerea.Signal a)))
|
||||
randomGens l = transfer (return (return 0)) (makeGen l)
|
||||
makeGen ::(Random a, Num a) => (a,a) -> p -> Sample b
|
||||
-> SignalGen p (Elerea.Signal a)
|
||||
-> SignalGen p (Elerea.Signal a)
|
||||
makeGen l _ new _ = case new of
|
||||
Changed _ -> effectful $ randomRIO l
|
||||
Unchanged _ -> return $ return 0
|
||||
|
||||
{-| Produces a new signal of lists that changes whenever the input signal
|
||||
changes. The input signal specifies the length of the random list. Each value is
|
||||
a random number in [0..1).
|
||||
-}
|
||||
floatList :: Signal Int -> Signal [Float]
|
||||
floatList s = Signal $ do
|
||||
s' <- signalGen s
|
||||
fl :: Elerea.Signal (SignalGen Engine (Elerea.Signal [Float]))
|
||||
<- floatListGens s'
|
||||
ss :: Elerea.Signal (Elerea.Signal [Float])
|
||||
<- generator fl
|
||||
transfer2 (pure []) update_ s' (join ss)
|
||||
where
|
||||
floatListGens :: Elerea.Signal (Sample Int)
|
||||
-> SignalGen p (Elerea.Signal
|
||||
(SignalGen p (Elerea.Signal [Float])))
|
||||
floatListGens = transfer (return (return [])) makeGen
|
||||
makeGen _ new _ = case new of
|
||||
Changed n -> liftM sequence $ replicateM n
|
||||
$ effectful
|
||||
$ randomRIO (0,1)
|
||||
Unchanged _ -> return (return [])
|
||||
update_ _ int new old = case int of
|
||||
Changed _ -> Changed new
|
||||
Unchanged _ -> Unchanged $ value old
|
@ -1,29 +0,0 @@
|
||||
module FRP.Helm.Sample (
|
||||
Sample(..),
|
||||
value,
|
||||
update
|
||||
) where
|
||||
|
||||
import Control.Applicative
|
||||
|
||||
data Sample a = Changed a | Unchanged a
|
||||
deriving (Show, Eq)
|
||||
|
||||
instance Functor Sample where
|
||||
fmap = liftA
|
||||
|
||||
instance Applicative Sample where
|
||||
pure = Unchanged
|
||||
(Changed f) <*> (Changed x) = Changed (f x)
|
||||
(Changed f) <*> (Unchanged x) = Changed (f x)
|
||||
(Unchanged f) <*> (Changed x) = Changed (f x)
|
||||
(Unchanged f) <*> (Unchanged x) = Unchanged (f x)
|
||||
|
||||
value :: Sample a -> a
|
||||
value (Changed x) = x
|
||||
value (Unchanged x) = x
|
||||
|
||||
update :: Eq a => p -> a -> Sample a -> Sample a
|
||||
update _ new old = if new == value old
|
||||
then Unchanged $ value old
|
||||
else Changed new
|
@ -1,164 +0,0 @@
|
||||
module FRP.Helm.Signal(
|
||||
Signal(..),
|
||||
-- * Composing
|
||||
constant,
|
||||
combine,
|
||||
merge,
|
||||
mergeMany,
|
||||
sampleOn,
|
||||
lift,
|
||||
lift2,
|
||||
lift3,
|
||||
(<~),
|
||||
(~~),
|
||||
-- * Accumulating
|
||||
foldp,
|
||||
count,
|
||||
countIf,
|
||||
-- * DYEL?
|
||||
lift4,
|
||||
lift5,
|
||||
lift6,
|
||||
lift7,
|
||||
lift8
|
||||
) where
|
||||
import Control.Applicative
|
||||
|
||||
import FRP.Elerea.Param hiding (Signal)
|
||||
import qualified FRP.Elerea.Param as Elerea (Signal)
|
||||
import FRP.Helm.Sample
|
||||
import FRP.Helm.Engine
|
||||
|
||||
newtype Signal a = Signal {signalGen :: SignalGen Engine (Elerea.Signal (Sample a))}
|
||||
|
||||
instance Functor Signal where
|
||||
fmap = liftA
|
||||
|
||||
instance Applicative Signal where
|
||||
pure = Signal . pure . pure . pure
|
||||
(Signal f) <*> (Signal x) = Signal $ liftA2 (liftA2 (<*>)) f x
|
||||
|
||||
{-| Creates a signal that never changes. -}
|
||||
constant :: a -> Signal a
|
||||
constant x = Signal $ stateful (Changed x) (\_ _ -> Unchanged x)
|
||||
|
||||
{-| Combines a list of signals into a signal of lists. -}
|
||||
combine :: [Signal a] -> Signal [a]
|
||||
combine = sequenceA
|
||||
|
||||
{-|
|
||||
Merge two signals into one. This function is extremely useful for bringing
|
||||
together lots of different signals to feed into a foldp.
|
||||
|
||||
If an update comes from either of the incoming signals, it updates the outgoing
|
||||
signal. If an update comes on both signals at the same time, the left update
|
||||
wins (i.e., the right update is discarded).
|
||||
-}
|
||||
merge :: Signal a -> Signal a -> Signal a
|
||||
merge s1 s2 = Signal $ do
|
||||
s1' <- signalGen s1
|
||||
s2' <- signalGen s2
|
||||
return $ update' <$> s1' <*> s2'
|
||||
where update' (Changed x) _ = Changed x
|
||||
update' (Unchanged _) (Changed y) = Changed y
|
||||
update' (Unchanged x) (Unchanged _) = Unchanged x
|
||||
|
||||
{-| Merge many signals into one. This is useful when you are merging more than
|
||||
two signals. When multiple updates come in at the same time, the left-most
|
||||
update wins, just like with merge. -}
|
||||
mergeMany :: [Signal a] -> Signal a
|
||||
mergeMany = foldl1 merge
|
||||
|
||||
{-| Sample the second signal based on the first. -}
|
||||
sampleOn :: Signal a -> Signal b -> Signal b
|
||||
sampleOn s1 s2 = Signal $ do
|
||||
s1' <- signalGen s1
|
||||
s2' <- signalGen s2
|
||||
return $ update' <$> s1' <*> s2'
|
||||
where update' (Unchanged _) (Changed y) = Unchanged y
|
||||
update' (Unchanged _) (Unchanged y) = Unchanged y
|
||||
update' (Changed _) (Changed y) = Changed y
|
||||
update' (Changed _) (Unchanged y) = Changed y
|
||||
|
||||
{-| Applies a function to a signal producing a new signal. This is a synonym of
|
||||
'fmap'. It automatically binds the input signal out of the signal generator.
|
||||
|
||||
> lift render Window.dimensions
|
||||
-}
|
||||
lift :: (a -> b) -> Signal a -> Signal b
|
||||
lift = fmap
|
||||
|
||||
{-| Applies a function to two signals. -}
|
||||
lift2 :: (a -> b -> c) -> Signal a -> Signal b -> Signal c
|
||||
lift2 f a b = f <~ a ~~ b
|
||||
|
||||
{-| Applies a function to three signals. -}
|
||||
lift3 :: (a -> b -> c -> d) -> Signal a -> Signal b -> Signal c -> Signal d
|
||||
lift3 f a b c = f <~ a ~~ b ~~ c
|
||||
|
||||
{-| Applies a function to four signals. -}
|
||||
lift4 :: (a -> b -> c -> d -> e) -> Signal a -> Signal b -> Signal c -> Signal d
|
||||
-> Signal e
|
||||
lift4 f a b c d = f <~ a ~~ b ~~ c ~~ d
|
||||
|
||||
{-| Applies a function to five signals. -}
|
||||
lift5 :: (a -> b -> c -> d -> e -> f) -> Signal a -> Signal b -> Signal c -> Signal d
|
||||
-> Signal e -> Signal f
|
||||
lift5 f a b c d e = f <~ a ~~ b ~~ c ~~ d ~~ e
|
||||
|
||||
{-| Applies a function to six signals. -}
|
||||
lift6 :: (a -> b -> c -> d -> e -> f -> g) -> Signal a -> Signal b -> Signal c -> Signal d
|
||||
-> Signal e -> Signal f -> Signal g
|
||||
lift6 f a b c d e f1 = f <~ a ~~ b ~~ c ~~ d ~~ e ~~ f1
|
||||
|
||||
{-| Applies a function to seven signals. -}
|
||||
lift7 :: (a -> b -> c -> d -> e -> f -> g -> h) -> Signal a -> Signal b -> Signal c -> Signal d
|
||||
-> Signal e -> Signal f -> Signal g -> Signal h
|
||||
lift7 f a b c d e f1 g = f <~ a ~~ b ~~ c ~~ d ~~ e ~~ f1 ~~ g
|
||||
|
||||
{-| Applies a function to eight signals. -}
|
||||
lift8 :: (a -> b -> c -> d -> e -> f -> g -> h -> i) -> Signal a -> Signal b -> Signal c -> Signal d
|
||||
-> Signal e -> Signal f -> Signal g -> Signal h
|
||||
-> Signal i
|
||||
lift8 f a b c d e f1 g h = f <~ a ~~ b ~~ c ~~ d ~~ e ~~ f1 ~~ g ~~ h
|
||||
|
||||
{-| An alias for 'lift'. -}
|
||||
(<~) :: (a -> b) -> Signal a -> Signal b
|
||||
(<~) = lift
|
||||
|
||||
infixl 4 <~
|
||||
|
||||
{-| Applies a function within a signal to a signal. This is a synonym of <*>.
|
||||
It automatically binds the input signal out of the signal generator.
|
||||
|
||||
> render <~ Window.dimensions ~~ Window.position
|
||||
-}
|
||||
(~~) :: Signal (a -> b) -> Signal a -> Signal b
|
||||
(~~) = (<*>)
|
||||
|
||||
infixl 4 ~~
|
||||
|
||||
{-| Creates a past-dependent signal that depends on another signal. This is a
|
||||
wrapper around the 'transfer' function that automatically binds the input
|
||||
signal out of the signal generator. This function is useful for making a render
|
||||
function that depends on some accumulated state.
|
||||
|
||||
> playerPosition :: (Int, Int) -> Signal (Int, Int)
|
||||
> playerPosition initial = foldp update initial arrows
|
||||
> where update (dx, dy) (x, y) = (x + dx, y + dy)
|
||||
|
||||
-}
|
||||
foldp :: (a -> b -> b) -> b -> Signal a -> Signal b
|
||||
foldp f ini (Signal gen) =
|
||||
Signal $ gen >>= transfer (pure ini) update_
|
||||
>>= delay (Changed ini)
|
||||
where update_ _ (Unchanged _) y = Unchanged (value y)
|
||||
update_ _ (Changed x) y = Changed $ f x (value y)
|
||||
|
||||
{-| Count the number of events that have occurred.-}
|
||||
count :: Signal a -> Signal Int
|
||||
count = foldp (\_ y -> y + 1) 0
|
||||
|
||||
{-| Count the number of events that have occurred that satisfy a given predicate.-}
|
||||
countIf :: (a -> Bool) -> Signal a -> Signal Int
|
||||
countIf f = foldp (\v c -> c + fromEnum (f v)) 0
|
@ -1,148 +0,0 @@
|
||||
{-| Contains functions for composing units of time and signals that sample from the game clock. -}
|
||||
module FRP.Helm.Time (
|
||||
-- * Units
|
||||
Time,
|
||||
millisecond,
|
||||
second,
|
||||
minute,
|
||||
hour,
|
||||
inMilliseconds,
|
||||
inSeconds,
|
||||
inMinutes,
|
||||
inHours,
|
||||
-- * Tickers
|
||||
fps,
|
||||
fpsWhen,
|
||||
every,
|
||||
-- * Timing
|
||||
timestamp,
|
||||
delay,
|
||||
since
|
||||
) where
|
||||
|
||||
|
||||
import Control.Monad
|
||||
import FRP.Elerea.Param hiding (delay, Signal, until)
|
||||
import qualified FRP.Elerea.Param as Elerea (Signal, until)
|
||||
import Data.Time.Clock.POSIX (getPOSIXTime)
|
||||
import FRP.Helm.Signal
|
||||
import FRP.Helm.Sample
|
||||
import System.IO.Unsafe (unsafePerformIO)
|
||||
|
||||
{-| A type describing an amount of time in an arbitary unit. Use the time
|
||||
composing/converting functions to manipulate time values. -}
|
||||
type Time = Double
|
||||
|
||||
{-| A time value representing one millisecond. -}
|
||||
millisecond :: Time
|
||||
millisecond = 1
|
||||
|
||||
{-| A time value representing one second. -}
|
||||
second :: Time
|
||||
second = 1000
|
||||
|
||||
{-| A time value representing one minute. -}
|
||||
minute :: Time
|
||||
minute = 60000
|
||||
|
||||
{-| A time value representing one hour. -}
|
||||
hour :: Time
|
||||
hour = 3600000
|
||||
|
||||
{-| Converts a time value to a fractional value, in milliseconds. -}
|
||||
inMilliseconds :: Time -> Double
|
||||
inMilliseconds n = n
|
||||
|
||||
{-| Converts a time value to a fractional value, in seconds. -}
|
||||
inSeconds :: Time -> Double
|
||||
inSeconds n = n / second
|
||||
|
||||
{-| Converts a time value to a fractional value, in minutes. -}
|
||||
inMinutes :: Time -> Double
|
||||
inMinutes n = n / minute
|
||||
|
||||
{-| Converts a time value to a fractional value, in hours. -}
|
||||
inHours :: Time -> Double
|
||||
inHours n = n / hour
|
||||
|
||||
{-| Takes desired number of frames per second (fps). The resulting signal gives
|
||||
a sequence of time deltas as quickly as possible until it reaches the
|
||||
desired FPS. A time delta is the time between the last frame and the current
|
||||
frame. -}
|
||||
fps :: Double -> Signal Time
|
||||
fps n = snd <~ every' t
|
||||
where --Ain't nobody got time for infinity
|
||||
t = if n == 0 then 0 else second / n
|
||||
|
||||
{-| Same as the fps function, but you can turn it on and off. Allows you to do
|
||||
brief animations based on user input without major inefficiencies. The first
|
||||
time delta after a pause is always zero, no matter how long the pause was.
|
||||
This way summing the deltas will actually give the amount of time that the
|
||||
output signal has been running. -}
|
||||
fpsWhen :: Double -> Signal Bool -> Signal Time
|
||||
fpsWhen n sig = Signal $ do c <- signalGen sig
|
||||
f <- signalGen (fps n)
|
||||
transfer2 (pure 0) update_ f c
|
||||
where update_ _ new (Unchanged cont) old = if cont
|
||||
then new
|
||||
else Unchanged $ value old
|
||||
update_ _ _ (Changed cont) old = if cont
|
||||
then Changed 0
|
||||
else Unchanged $ value old
|
||||
{-| Takes a time interval t. The resulting signal is the current time, updated
|
||||
every t. -}
|
||||
every :: Time -> Signal Time
|
||||
every t = fst <~ every' t
|
||||
|
||||
{-| A utility signal used by 'fps' and 'every' that returns the current time
|
||||
and a delta every t. -}
|
||||
every' :: Time -> Signal (Time, Time)
|
||||
every' t = Signal $ every'' t >>= transfer (pure (0,0)) update
|
||||
|
||||
{-| Another utility signal that does all the magic for 'every'' by working on
|
||||
the Elerea SignalGen level -}
|
||||
every'' :: Time -> SignalGen p (Elerea.Signal (Time, Time))
|
||||
every'' t = do
|
||||
it <- execute getTime
|
||||
effectful getTime >>= transfer (it,0) update_
|
||||
where
|
||||
getTime = liftM ((second *) . realToFrac) getPOSIXTime
|
||||
update_ _ new old = let delta = new - fst old
|
||||
in if delta >= t then (new, delta) else old
|
||||
|
||||
{-| Add a timestamp to any signal. Timestamps increase monotonically. When you
|
||||
create (timestamp Mouse.x), an initial timestamp is produced. The timestamp
|
||||
updates whenever Mouse.x updates.
|
||||
|
||||
Unlike in Elm the timestamps are not tied to the underlying signals so the
|
||||
timestamps for Mouse.x and Mouse.y will be slightly different. -}
|
||||
timestamp :: Signal a -> Signal (Time, a)
|
||||
timestamp = lift2 (,) pure_time
|
||||
where pure_time = fst <~ (Signal $ (fmap . fmap) pure (every'' millisecond))
|
||||
|
||||
{-| Delay a signal by a certain amount of time. So (delay second Mouse.clicks)
|
||||
will update one second later than any mouse click. -}
|
||||
delay :: Time -> Signal a -> Signal a
|
||||
delay t (Signal gen) = Signal $ (fmap . fmap) fst $
|
||||
do s <- gen
|
||||
w <- timeout
|
||||
e <- snapshot =<< input
|
||||
transfer2 (makeInit e, []) update_ w s
|
||||
where
|
||||
-- XXX uses unsafePerformIO, is there a better way?
|
||||
makeInit e = pure $ value $ unsafePerformIO (start gen >>= (\f -> f e))
|
||||
update_ _ waiting new (old, olds) = if waiting then (old, new:olds)
|
||||
else (last olds, new:init olds)
|
||||
timeout = every'' t >>= transfer False (\_ (time,delta) _ -> time /= delta)
|
||||
-- 'Elerea.until' will lose the reference to the input so
|
||||
-- we don't keep looking up the time even though the
|
||||
-- output can never change again
|
||||
>>= Elerea.until
|
||||
>>= transfer True (\_ new old -> old && not new)
|
||||
|
||||
{-| Takes a time t and any signal. The resulting boolean signal is true for
|
||||
time t after every event on the input signal. So (second `since`
|
||||
Mouse.clicks) would result in a signal that is true for one second after
|
||||
each mouse click and false otherwise. -}
|
||||
since :: Time -> Signal a -> Signal Bool
|
||||
since t s = lift2 (/=) (count s) (count (delay t s))
|
@ -1,32 +0,0 @@
|
||||
{-| Contains miscellaneous utility functions such as functions for working with signals and signal generators. -}
|
||||
module FRP.Helm.Utilities (
|
||||
-- * Angles
|
||||
radians,
|
||||
degrees,
|
||||
turns,
|
||||
-- * Applying
|
||||
(<|),
|
||||
(|>),
|
||||
) where
|
||||
|
||||
{-| Converts radians into the standard angle measurement (radians). -}
|
||||
radians :: Double -> Double
|
||||
radians n = n
|
||||
|
||||
{-| Converts degrees into the standard angle measurement (radians). -}
|
||||
degrees :: Double -> Double
|
||||
degrees n = n * pi / 180
|
||||
|
||||
{-| Converts turns into the standard angle measurement (radians).
|
||||
Turns are essentially full revolutions of the unit circle. -}
|
||||
turns :: Double -> Double
|
||||
turns n = 2 * pi * n
|
||||
|
||||
{-| Forward function application, think of it as a inverted '($)'. Provided for easy porting from Elm. -}
|
||||
(|>) :: a -> (a -> b) -> b
|
||||
(|>) = flip ($)
|
||||
|
||||
{-| Exactly the same as '($)', only there to make code using '(|>)'
|
||||
more consistent. -}
|
||||
(<|) :: (a -> b) -> a -> b
|
||||
(<|) = ($)
|
@ -1,44 +0,0 @@
|
||||
{-| Contains signals that sample input from the game window. -}
|
||||
module FRP.Helm.Window (
|
||||
-- * Dimensions
|
||||
dimensions,
|
||||
width,
|
||||
height,
|
||||
position
|
||||
) where
|
||||
|
||||
import FRP.Elerea.Param hiding (Signal)
|
||||
import FRP.Helm.Engine
|
||||
import FRP.Helm.Sample
|
||||
import FRP.Helm.Signal
|
||||
import SDL
|
||||
import qualified SDL.Video as Video
|
||||
import Linear.V2 (V2(V2))
|
||||
|
||||
{-| The current dimensions of the window. -}
|
||||
dimensions :: Signal (Int, Int)
|
||||
dimensions =
|
||||
Signal $ input >>= getDimensions >>= transfer (pure (0,0)) update
|
||||
where
|
||||
getDimensions = effectful1 action
|
||||
action engine = do
|
||||
V2 w h <- SDL.get $ Video.windowSize (window engine)
|
||||
return (fromIntegral w, fromIntegral h)
|
||||
|
||||
{-| The current position of the window. -}
|
||||
position :: Signal (Int, Int)
|
||||
position =
|
||||
Signal $ input >>= getPosition >>= transfer (pure (0,0)) update
|
||||
where
|
||||
getPosition = effectful1 action
|
||||
action engine = do
|
||||
V2 x y <- Video.getWindowAbsolutePosition (window engine)
|
||||
return (fromIntegral x, fromIntegral y)
|
||||
|
||||
{-| The current width of the window. -}
|
||||
width :: Signal Int
|
||||
width = fst <~ dimensions
|
||||
|
||||
{-| The current height of the window. -}
|
||||
height :: Signal Int
|
||||
height = snd <~ dimensions
|
129
src/Helm.hs
Normal file
129
src/Helm.hs
Normal file
@ -0,0 +1,129 @@
|
||||
{-| 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
|
||||
}
|
||||
|
||||
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
|
31
src/Helm/Cmd.hs
Normal file
31
src/Helm/Cmd.hs
Normal file
@ -0,0 +1,31 @@
|
||||
{-| Contains the command type and related utilities. -}
|
||||
module Helm.Cmd (
|
||||
-- * Types
|
||||
Cmd(..),
|
||||
-- * Utilities
|
||||
batch,
|
||||
none,
|
||||
execute
|
||||
) where
|
||||
|
||||
import Control.Monad.Trans.Class (lift)
|
||||
import Control.Monad.Trans.State (StateT)
|
||||
|
||||
import Helm.Engine (Engine)
|
||||
|
||||
data Cmd a = Cmd (StateT Engine IO [a])
|
||||
|
||||
batch :: [Cmd a] -> Cmd a
|
||||
batch cmds = Cmd $ do
|
||||
lists <- sequence $ map (\(Cmd monad) -> monad) cmds
|
||||
|
||||
return $ concat lists
|
||||
|
||||
none :: Cmd a
|
||||
none = Cmd $ return []
|
||||
|
||||
execute :: IO a -> (a -> b) -> Cmd b
|
||||
execute monad f = Cmd $ do
|
||||
result <- f <$> lift monad
|
||||
|
||||
return [result]
|
@ -1,6 +1,6 @@
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-| Contains all data structures and functions for composing colors. -}
|
||||
module FRP.Helm.Color (
|
||||
module Helm.Color (
|
||||
-- * Types
|
||||
Color(..),
|
||||
Gradient(..),
|
||||
@ -12,25 +12,7 @@ module FRP.Helm.Color (
|
||||
blend,
|
||||
complement,
|
||||
linear,
|
||||
radial,
|
||||
-- * Constants
|
||||
red,
|
||||
lime,
|
||||
blue,
|
||||
yellow,
|
||||
cyan,
|
||||
magenta,
|
||||
black,
|
||||
white,
|
||||
gray,
|
||||
grey,
|
||||
maroon,
|
||||
navy,
|
||||
green,
|
||||
teal,
|
||||
purple,
|
||||
violet,
|
||||
forestGreen
|
||||
radial
|
||||
) where
|
||||
|
||||
import GHC.Generics
|
||||
@ -50,82 +32,17 @@ rgba r g b a
|
||||
| r < 0 || r > 1 ||
|
||||
g < 0 || g > 1 ||
|
||||
b < 0 || b > 1 ||
|
||||
a < 0 || a > 1 = error "FRP.Helm.Color.rgba: color components must be between 0 and 1"
|
||||
a < 0 || a > 1 = error "Helm.Color.rgba: color components must be between 0 and 1"
|
||||
| otherwise = Color r g b a
|
||||
|
||||
{-| A bright red color. -}
|
||||
red :: Color
|
||||
red = rgb 1 0 0
|
||||
|
||||
{-| A bright green color. -}
|
||||
lime :: Color
|
||||
lime = rgb 0 1 0
|
||||
|
||||
{-| A bright blue color. -}
|
||||
blue :: Color
|
||||
blue = rgb 0 0 1
|
||||
|
||||
{-| A yellow color, made from combining red and green. -}
|
||||
yellow :: Color
|
||||
yellow = rgb 1 1 0
|
||||
|
||||
{-| A cyan color, combined from bright green and blue. -}
|
||||
cyan :: Color
|
||||
cyan = rgb 0 1 1
|
||||
|
||||
{-| A magenta color, combined from bright red and blue. -}
|
||||
magenta :: Color
|
||||
magenta = rgb 1 0 1
|
||||
|
||||
{-| A black color. -}
|
||||
black :: Color
|
||||
black = rgb 0 0 0
|
||||
|
||||
{-| A white color. -}
|
||||
white :: Color
|
||||
white = rgb 1 1 1
|
||||
|
||||
{-| A gray color, exactly halfway between black and white. -}
|
||||
gray :: Color
|
||||
gray = rgb 0.5 0.5 0.5
|
||||
|
||||
{-| Common alternative spelling of 'gray'. -}
|
||||
grey :: Color
|
||||
grey = gray
|
||||
|
||||
{-| A medium red color. -}
|
||||
maroon :: Color
|
||||
maroon = rgb 0.5 0 0
|
||||
|
||||
{-| A medium blue color. -}
|
||||
navy :: Color
|
||||
navy = rgb 0 0 0.5
|
||||
|
||||
{-| A medium green color. -}
|
||||
green :: Color
|
||||
green = rgb 0 0.5 0
|
||||
|
||||
{-| A teal color, combined from medium green and blue. -}
|
||||
teal :: Color
|
||||
teal = rgb 0 0.5 0.5
|
||||
|
||||
{-| A purple color, combined from medium red and blue. -}
|
||||
purple :: Color
|
||||
purple = rgb 0.5 0 0.5
|
||||
|
||||
{-| A violet color. -}
|
||||
violet :: Color
|
||||
violet = rgb 0.923 0.508 0.923
|
||||
|
||||
{-| A dark green color. -}
|
||||
forestGreen :: Color
|
||||
forestGreen = rgb 0.133 0.543 0.133
|
||||
|
||||
{-| Takes a list of colors and turns it into a single color by
|
||||
averaging the color components. -}
|
||||
blend :: [Color] -> Color
|
||||
blend colors = (\(Color r g b a) -> Color (r / denom) (g / denom) (b / denom) (a / denom)) $ foldl blend' black colors
|
||||
blend colors =
|
||||
(\(Color r g b a) -> Color (r / denom) (g / denom) (b / denom) (a / denom)) $ foldl blend' black colors
|
||||
|
||||
where
|
||||
black = rgb 0 0 0
|
||||
denom = fromIntegral $ length colors
|
||||
|
||||
{-| A utility function that adds colors together. -}
|
||||
@ -162,7 +79,7 @@ hsva h s v a
|
||||
f = h' - fromIntegral h''
|
||||
p = v * (1 - s)
|
||||
q = v * (1 - f * s)
|
||||
t = v * (1 - (1 - f) * s)
|
||||
t = v * (1 - (1 - f) * s)
|
||||
|
||||
{-| Create an RGB color from HSV values. -}
|
||||
hsv :: Double -> Double -> Double -> Color
|
36
src/Helm/Engine.hs
Normal file
36
src/Helm/Engine.hs
Normal file
@ -0,0 +1,36 @@
|
||||
module Helm.Engine (
|
||||
-- * Types
|
||||
EngineConfig(..),
|
||||
Engine(..),
|
||||
-- * Setup
|
||||
defaultConfig
|
||||
) where
|
||||
|
||||
import qualified SDL.Video as Video
|
||||
|
||||
{-| A data structure describing how to run the engine. -}
|
||||
data EngineConfig = EngineConfig {
|
||||
windowDimensions :: (Int, Int),
|
||||
windowIsFullscreen :: Bool,
|
||||
windowIsResizable :: Bool,
|
||||
windowTitle :: String,
|
||||
windowQuitOnClose :: Bool
|
||||
}
|
||||
|
||||
{-| A data structure describing the game engine's state. -}
|
||||
data Engine = Engine {
|
||||
window :: Video.Window,
|
||||
renderer :: Video.Renderer,
|
||||
engineConfig :: EngineConfig
|
||||
}
|
||||
|
||||
{-| 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
|
||||
}
|
28
src/Helm/Game.hs
Normal file
28
src/Helm/Game.hs
Normal file
@ -0,0 +1,28 @@
|
||||
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
|
||||
}
|
@ -1,6 +1,6 @@
|
||||
{-| Contains all the data structures and functions for composing
|
||||
and rendering graphics. -}
|
||||
module FRP.Helm.Graphics (
|
||||
module Helm.Graphics2D (
|
||||
-- * Types
|
||||
Element(..),
|
||||
FontWeight(..),
|
||||
@ -12,8 +12,9 @@ module FRP.Helm.Graphics (
|
||||
LineCap(..),
|
||||
LineJoin(..),
|
||||
LineStyle(..),
|
||||
Path,
|
||||
Path(..),
|
||||
Shape(..),
|
||||
Transform(..),
|
||||
-- * Elements
|
||||
image,
|
||||
fittedImage,
|
||||
@ -55,8 +56,8 @@ module FRP.Helm.Graphics (
|
||||
ngon
|
||||
) where
|
||||
|
||||
import FRP.Helm.Color (Color, black, Gradient)
|
||||
import Graphics.Rendering.Cairo.Matrix (Matrix)
|
||||
import Helm.Color (Color, rgb, Gradient)
|
||||
import Helm.Graphics2D.Transform (Transform(..))
|
||||
|
||||
{-| A data structure describing the weight of a piece of font. -}
|
||||
data FontWeight = LightWeight |
|
||||
@ -143,7 +144,7 @@ data LineStyle = LineStyle {
|
||||
flat caps and regular sharp joints. -}
|
||||
defaultLine :: LineStyle
|
||||
defaultLine = LineStyle {
|
||||
lineColor = black,
|
||||
lineColor = rgb 0 0 0,
|
||||
lineWidth = 1,
|
||||
lineCap = FlatCap,
|
||||
lineJoin = SharpJoin 10,
|
||||
@ -153,22 +154,22 @@ defaultLine = LineStyle {
|
||||
|
||||
{-| Create a solid line style with a color. -}
|
||||
solid :: Color -> LineStyle
|
||||
solid color = defaultLine { lineColor = color }
|
||||
solid col = defaultLine { lineColor = col }
|
||||
|
||||
{-| Create a dashed line style with a color. -}
|
||||
dashed :: Color -> LineStyle
|
||||
dashed color = defaultLine { lineColor = color, lineDashing = [8, 4] }
|
||||
dashed col = defaultLine { lineColor = col, lineDashing = [8, 4] }
|
||||
|
||||
{-| Create a dotted line style with a color. -}
|
||||
dotted :: Color -> LineStyle
|
||||
dotted color = defaultLine { lineColor = color, lineDashing = [3, 3] }
|
||||
dotted col = defaultLine { lineColor = col, lineDashing = [3, 3] }
|
||||
|
||||
{-| A data structure describing a few ways that graphics that can be wrapped in a form
|
||||
and hence transformed. -}
|
||||
data FormStyle = PathForm LineStyle Path |
|
||||
ShapeForm (Either LineStyle FillStyle) Shape |
|
||||
ElementForm Element |
|
||||
GroupForm (Maybe Matrix) [Form] deriving (Show, Eq)
|
||||
GroupForm (Maybe Transform) [Form] deriving (Show, Eq)
|
||||
|
||||
{-| Utility function for creating a form. -}
|
||||
form :: FormStyle -> Form
|
||||
@ -180,7 +181,7 @@ fill style shape = form (ShapeForm (Right style) shape)
|
||||
|
||||
{-| Creates a form from a shape by filling it with a specific color. -}
|
||||
filled :: Color -> Shape -> Form
|
||||
filled color = fill (Solid color)
|
||||
filled col = fill (Solid col)
|
||||
|
||||
{-| Creates a form from a shape with a tiled texture and image file path. -}
|
||||
textured :: String -> Shape -> Form
|
||||
@ -215,9 +216,9 @@ blank = group []
|
||||
group :: [Form] -> Form
|
||||
group forms = form (GroupForm Nothing forms)
|
||||
|
||||
{-| Groups a collection of forms into a single one, also applying a matrix transformation. -}
|
||||
groupTransform :: Matrix -> [Form] -> Form
|
||||
groupTransform matrix forms = form (GroupForm (Just matrix) forms)
|
||||
{-| Groups a collection of forms into a single one, also applying a 2D transformation. -}
|
||||
groupTransform :: Transform -> [Form] -> Form
|
||||
groupTransform trans forms = form (GroupForm (Just trans) forms)
|
||||
|
||||
{-| Rotates a form by an amount (in radians). -}
|
||||
rotate :: Double -> Form -> Form
|
||||
@ -258,15 +259,15 @@ fixedCollage :: Int -> Int -> (Double, Double) -> [Form] -> Element
|
||||
fixedCollage w h (x, y) = CollageElement w h (Just (realToFrac w / 2 - x, realToFrac h / 2 - y))
|
||||
|
||||
{-| A data type made up a collection of points that form a path when joined. -}
|
||||
type Path = [(Double, Double)]
|
||||
data Path = Path [(Double, Double)] deriving (Show, Eq, Ord, Read)
|
||||
|
||||
{-| Creates a path for a collection of points. -}
|
||||
path :: [(Double, Double)] -> Path
|
||||
path points = points
|
||||
path points = Path points
|
||||
|
||||
{-| Creates a path from a line segment, i.e. a start and end point. -}
|
||||
segment :: (Double, Double) -> (Double, Double) -> Path
|
||||
segment p1 p2 = [p1, p2]
|
||||
segment p1 p2 = Path [p1, p2]
|
||||
|
||||
{-| A data structure describing a some sort of graphically representable object,
|
||||
such as a polygon formed from a list of points or a rectangle. -}
|
||||
@ -297,7 +298,7 @@ circle r = ArcShape (0, 0) 0 (2 * pi) r (1, 1)
|
||||
{-| Creates a generic n-sided polygon (e.g. octagon, pentagon, etc) with
|
||||
an amount of sides and radius. -}
|
||||
ngon :: Int -> Double -> Shape
|
||||
ngon n r = PolygonShape (map (\i -> (r * cos (t * i), r * sin (t * i))) [0 .. fromIntegral (n - 1)])
|
||||
where
|
||||
ngon n r = PolygonShape $ Path (map (\i -> (r * cos (t * i), r * sin (t * i))) [0 .. fromIntegral (n - 1)])
|
||||
where
|
||||
m = fromIntegral n
|
||||
t = 2 * pi / m
|
@ -1,6 +1,6 @@
|
||||
{-| Contains all the data structures and functions for composing
|
||||
pieces of formatted text. -}
|
||||
module FRP.Helm.Text (
|
||||
module Helm.Graphics2D.Text (
|
||||
-- * Elements
|
||||
plainText,
|
||||
asText,
|
||||
@ -20,15 +20,15 @@ module FRP.Helm.Text (
|
||||
height
|
||||
) where
|
||||
|
||||
import FRP.Helm.Color (Color, black)
|
||||
import FRP.Helm.Graphics (Element(TextElement), Text(..), FontWeight(..), FontStyle(..))
|
||||
import Helm.Color (Color(..), rgb)
|
||||
import Helm.Graphics2D (Element(TextElement), Text(..), FontWeight(..), FontStyle(..))
|
||||
|
||||
{-| Creates the default text. By default the text is black sans-serif
|
||||
with a height of 14pt. -}
|
||||
defaultText :: Text
|
||||
defaultText = Text {
|
||||
textUTF8 = "",
|
||||
textColor = black,
|
||||
textColor = rgb 0 0 0,
|
||||
textTypeface = "sans-serif",
|
||||
textHeight = 14,
|
||||
textWeight = NormalWeight,
|
||||
@ -52,15 +52,6 @@ asText val = text $ monospace $ toText $ show val
|
||||
text :: Text -> Element
|
||||
text = TextElement
|
||||
|
||||
{- TODO:
|
||||
centered
|
||||
justified
|
||||
righted
|
||||
underline
|
||||
strikeThrough
|
||||
overline
|
||||
-}
|
||||
|
||||
{-| Sets the weight of a piece of text to bold. -}
|
||||
bold :: Text -> Text
|
||||
bold txt = txt { textWeight = BoldWeight }
|
47
src/Helm/Graphics2D/Transform.hs
Normal file
47
src/Helm/Graphics2D/Transform.hs
Normal file
@ -0,0 +1,47 @@
|
||||
module Helm.Graphics2D.Transform (
|
||||
-- * Types
|
||||
Transform(..),
|
||||
-- * Composing
|
||||
identity,
|
||||
matrix,
|
||||
rotation,
|
||||
translation,
|
||||
scale,
|
||||
multiply
|
||||
) where
|
||||
|
||||
import Linear.V3 (V3(V3))
|
||||
import qualified Linear.Matrix as Matrix
|
||||
|
||||
data Transform = Transform (Matrix.M33 Double) deriving (Show, Eq, Ord, Read)
|
||||
|
||||
instance Num Transform where
|
||||
(*) (Transform a) (Transform b) = Transform $ a * b
|
||||
(+) (Transform a) (Transform b) = Transform $ a + b
|
||||
(-) (Transform a) (Transform b) = Transform $ a - b
|
||||
|
||||
negate (Transform a) = Transform $ negate a
|
||||
abs (Transform a) = Transform $ abs a
|
||||
signum (Transform a) = Transform $ signum a
|
||||
fromInteger n = Transform $ V3 (V3 (fromInteger n) 0 0) (V3 (fromInteger n) 0 0) (V3 0 0 1)
|
||||
|
||||
identity :: Transform
|
||||
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)
|
||||
|
||||
rotation :: Double -> Transform
|
||||
rotation t = Transform $ V3 (V3 c (-s) 0) (V3 s c 0) (V3 0 0 1)
|
||||
where
|
||||
s = sin t
|
||||
c = cos t
|
||||
|
||||
translation :: Double -> Double -> Transform
|
||||
translation x y = Transform $ V3 (V3 1 0 x) (V3 0 1 y) (V3 0 0 1)
|
||||
|
||||
scale :: Double -> Double -> Transform
|
||||
scale x y = Transform $ V3 (V3 x 0 0) (V3 y 0 0) (V3 0 0 1)
|
||||
|
||||
multiply :: Transform -> Transform -> Transform
|
||||
multiply (Transform a) (Transform b) = Transform $ a * b
|
19
src/Helm/Keyboard.hs
Normal file
19
src/Helm/Keyboard.hs
Normal file
@ -0,0 +1,19 @@
|
||||
{-| Contains subscriptions to events from the keyboard. -}
|
||||
module Helm.Keyboard (
|
||||
-- * Subscriptions
|
||||
presses,
|
||||
downs,
|
||||
ups
|
||||
) where
|
||||
|
||||
import SDL.Input.Keyboard.Codes (Keycode)
|
||||
import Helm (Sub(..))
|
||||
|
||||
presses :: (Keycode -> a) -> Sub a
|
||||
presses _ = Sub $ return $ return []
|
||||
|
||||
downs :: (Keycode -> a) -> Sub a
|
||||
downs _ = Sub $ return $ return []
|
||||
|
||||
ups :: (Keycode -> a) -> Sub a
|
||||
ups _ = Sub $ return $ return []
|
37
src/Helm/Mouse.hs
Normal file
37
src/Helm/Mouse.hs
Normal file
@ -0,0 +1,37 @@
|
||||
{-| Contains subscriptions to events from the mouse. -}
|
||||
module Helm.Mouse
|
||||
(
|
||||
-- * Subscriptions
|
||||
moves,
|
||||
clicks,
|
||||
downs,
|
||||
ups,
|
||||
buttonClicks,
|
||||
buttonDowns,
|
||||
buttonUps
|
||||
) where
|
||||
|
||||
import Linear.V2 (V2(V2))
|
||||
import Helm (Sub(..))
|
||||
import SDL.Input.Mouse (MouseButton(ButtonLeft))
|
||||
|
||||
moves :: (V2 Int -> a) -> Sub a
|
||||
moves _ = Sub $ return $ return []
|
||||
|
||||
buttonClicks :: MouseButton -> (V2 Int -> a) -> Sub a
|
||||
buttonClicks _ _ = Sub $ return $ return []
|
||||
|
||||
buttonDowns :: MouseButton -> (V2 Int -> a) -> Sub a
|
||||
buttonDowns _ _ = Sub $ return $ return []
|
||||
|
||||
buttonUps :: MouseButton -> (V2 Int -> a) -> Sub a
|
||||
buttonUps _ _ = Sub $ return $ return []
|
||||
|
||||
clicks :: (V2 Int -> a) -> Sub a
|
||||
clicks = buttonClicks ButtonLeft
|
||||
|
||||
downs :: (V2 Int -> a) -> Sub a
|
||||
downs = buttonDowns ButtonLeft
|
||||
|
||||
ups :: (V2 Int -> a) -> Sub a
|
||||
ups = buttonUps ButtonLeft
|
16
src/Helm/Render.hs
Normal file
16
src/Helm/Render.hs
Normal file
@ -0,0 +1,16 @@
|
||||
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 ()
|
203
src/Helm/Render/Cairo.hs
Normal file
203
src/Helm/Render/Cairo.hs
Normal file
@ -0,0 +1,203 @@
|
||||
module Helm.Render.Cairo (
|
||||
-- * Rendering
|
||||
render
|
||||
) where
|
||||
|
||||
import Control.Monad.Trans.Class (lift)
|
||||
import Control.Monad.Trans.State (get)
|
||||
|
||||
import Data.Foldable (forM_)
|
||||
import qualified Data.Text as T
|
||||
import Linear.V2 (V2(V2))
|
||||
import Linear.V3 (V3(V3))
|
||||
import Foreign.Ptr (castPtr)
|
||||
|
||||
import Helm.Engine (Engine(..))
|
||||
import Helm.Render (Render(..))
|
||||
import Helm.Color (Color(..), Gradient(..))
|
||||
import Helm.Graphics2D
|
||||
|
||||
import Graphics.Rendering.Cairo.Matrix (Matrix(..))
|
||||
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
|
||||
|
||||
lift $ do
|
||||
dims@(V2 w h) <- SDL.get $ Video.windowSize window
|
||||
|
||||
texture <- Renderer.createTexture renderer Renderer.ARGB8888 Renderer.TextureAccessStreaming dims
|
||||
(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
|
||||
|
||||
renderElement element
|
||||
|
||||
Renderer.unlockTexture texture
|
||||
Renderer.clear renderer
|
||||
Renderer.copy renderer texture Nothing Nothing
|
||||
Renderer.destroyTexture texture
|
||||
Renderer.present renderer
|
||||
|
||||
renderElement :: Element -> Cairo.Render ()
|
||||
renderElement (CollageElement w h center forms) = do
|
||||
Cairo.save
|
||||
Cairo.rectangle 0 0 (fromIntegral w) (fromIntegral h)
|
||||
Cairo.clip
|
||||
|
||||
forM_ center $ uncurry Cairo.translate
|
||||
mapM_ renderForm forms
|
||||
|
||||
Cairo.restore
|
||||
|
||||
renderElement (ImageElement (sx, sy) sw sh src stretch) = do
|
||||
return ()
|
||||
|
||||
renderElement (TextElement (Text { textColor = (Color r g b a), .. })) = do
|
||||
Cairo.save
|
||||
|
||||
layout <- Pango.createLayout textUTF8
|
||||
|
||||
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 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
|
||||
Pango.showLayout layout
|
||||
Cairo.restore
|
||||
|
||||
where
|
||||
i = 0
|
||||
j = length textUTF8
|
||||
|
||||
{-| A utility function that maps to a Pango font weight based off our variant. -}
|
||||
mapFontWeight :: FontWeight -> Pango.Weight
|
||||
mapFontWeight weight = case weight of
|
||||
LightWeight -> Pango.WeightLight
|
||||
NormalWeight -> Pango.WeightNormal
|
||||
BoldWeight -> Pango.WeightBold
|
||||
|
||||
{-| A utility function that maps to a Pango font style based off our variant. -}
|
||||
mapFontStyle :: FontStyle -> Pango.FontStyle
|
||||
mapFontStyle style = case style of
|
||||
NormalStyle -> Pango.StyleNormal
|
||||
ObliqueStyle -> Pango.StyleOblique
|
||||
ItalicStyle -> Pango.StyleItalic
|
||||
|
||||
{-| A utility function that goes into a state of transformation and then pops
|
||||
it when finished. -}
|
||||
withTransform :: Double -> Double -> Double -> Double -> Cairo.Render () -> Cairo.Render ()
|
||||
withTransform s t x y f = do
|
||||
Cairo.save
|
||||
Cairo.scale s s
|
||||
Cairo.translate x y
|
||||
Cairo.rotate t
|
||||
f
|
||||
Cairo.restore
|
||||
|
||||
{-| A utility function that sets the Cairo line cap based off of our version. -}
|
||||
setLineCap :: LineCap -> Cairo.Render ()
|
||||
setLineCap cap = case cap of
|
||||
FlatCap -> Cairo.setLineCap Cairo.LineCapButt
|
||||
RoundCap -> Cairo.setLineCap Cairo.LineCapRound
|
||||
PaddedCap -> Cairo.setLineCap Cairo.LineCapSquare
|
||||
|
||||
{-| A utility function that sets the Cairo line style based off of our version. -}
|
||||
setLineJoin :: LineJoin -> Cairo.Render ()
|
||||
setLineJoin join = case join of
|
||||
SmoothJoin -> Cairo.setLineJoin Cairo.LineJoinRound
|
||||
SharpJoin lim -> Cairo.setLineJoin Cairo.LineJoinMiter >> Cairo.setMiterLimit lim
|
||||
ClippedJoin -> Cairo.setLineJoin Cairo.LineJoinBevel
|
||||
|
||||
{-| A utility function that sets up all the necessary settings with Cairo
|
||||
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
|
||||
Cairo.setSourceRGBA r g b a
|
||||
setLineCap lineCap
|
||||
setLineJoin lineJoin
|
||||
Cairo.setLineWidth lineWidth
|
||||
Cairo.setDash lineDashing lineDashOffset
|
||||
Cairo.stroke
|
||||
|
||||
{-| A utility function that sets up all the necessary settings with Cairo
|
||||
to render with a fill style and then fills afterwards. Assumes
|
||||
that all drawing paths have already been setup before being called. -}
|
||||
setFillStyle :: FillStyle -> Cairo.Render ()
|
||||
setFillStyle (Solid (Color r g b a)) = do
|
||||
Cairo.setSourceRGBA r g b a
|
||||
Cairo.fill
|
||||
|
||||
setFillStyle (Texture src) = do
|
||||
return ()
|
||||
|
||||
setFillStyle (Gradient (Linear (sx, sy) (ex, ey) points)) =
|
||||
Cairo.withLinearPattern sx sy ex ey $ \pattern ->
|
||||
setGradientFill pattern points
|
||||
|
||||
setFillStyle (Gradient (Radial (sx, sy) sr (ex, ey) er points)) =
|
||||
Cairo.withRadialPattern sx sy sr ex ey er $ \pattern ->
|
||||
setGradientFill pattern 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
|
||||
Cairo.fill
|
||||
|
||||
{-| A utility that renders a form. -}
|
||||
renderForm :: Form -> Cairo.Render ()
|
||||
renderForm Form { .. } = withTransform formScale formTheta formX formY $
|
||||
case formStyle of
|
||||
PathForm style (Path (~ps @ ((hx, hy) : _))) -> do
|
||||
Cairo.newPath
|
||||
Cairo.moveTo hx hy
|
||||
mapM_ (uncurry Cairo.lineTo) ps
|
||||
setLineStyle style
|
||||
|
||||
ShapeForm style shape -> do
|
||||
Cairo.newPath
|
||||
|
||||
case shape of
|
||||
PolygonShape (Path (~ps @ ((hx, hy) : _))) -> do
|
||||
Cairo.moveTo hx hy
|
||||
mapM_ (uncurry Cairo.lineTo) ps
|
||||
|
||||
RectangleShape (w, h) ->
|
||||
Cairo.rectangle (-w / 2) (-h / 2) w h
|
||||
|
||||
ArcShape (cx, cy) a1 a2 r (sx, sy) -> do
|
||||
Cairo.scale sx sy
|
||||
Cairo.arc cx cy r a1 a2
|
||||
Cairo.scale 1 1
|
||||
|
||||
either setLineStyle setFillStyle style
|
||||
|
||||
ElementForm element -> renderElement element
|
||||
|
||||
GroupForm mayhaps forms -> do
|
||||
Cairo.save
|
||||
|
||||
forM_ mayhaps $ \(Transform (V3 (V3 a b x) (V3 c d y) (V3 0 0 1))) ->
|
||||
Cairo.setMatrix $ Matrix a b c d x y
|
||||
|
||||
mapM_ renderForm forms
|
||||
Cairo.restore
|
26
src/Helm/Sub.hs
Normal file
26
src/Helm/Sub.hs
Normal file
@ -0,0 +1,26 @@
|
||||
{-| Contains the subscription type and related utilities. -}
|
||||
module Helm.Sub (
|
||||
-- * Types
|
||||
Sub(..),
|
||||
-- * Utilities
|
||||
batch,
|
||||
none
|
||||
) where
|
||||
|
||||
import FRP.Elerea.Param (SignalGen, Signal)
|
||||
|
||||
import Helm.Engine (Engine)
|
||||
|
||||
data Sub a = Sub (SignalGen Engine (Signal [a]))
|
||||
|
||||
batch :: [Sub a] -> Sub a
|
||||
batch subs = Sub $ do
|
||||
signals <- sequence $ map (\(Sub gen) -> gen) subs
|
||||
|
||||
return $ do
|
||||
lists <- sequence signals
|
||||
|
||||
return $ concat lists
|
||||
|
||||
none :: Sub a
|
||||
none = Sub $ return $ return []
|
63
src/Helm/Time.hs
Normal file
63
src/Helm/Time.hs
Normal file
@ -0,0 +1,63 @@
|
||||
{-| 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
|
||||
|
||||
import Helm (Cmd(..), Sub(..))
|
||||
|
||||
{-| A type describing an amount of time in an arbitary unit. Use the time
|
||||
composing/converting functions to manipulate time values. -}
|
||||
type Time = Double
|
||||
|
||||
{-| A time value representing one millisecond. -}
|
||||
millisecond :: Time
|
||||
millisecond = 1
|
||||
|
||||
{-| A time value representing one second. -}
|
||||
second :: Time
|
||||
second = 1000
|
||||
|
||||
{-| A time value representing one minute. -}
|
||||
minute :: Time
|
||||
minute = 60000
|
||||
|
||||
{-| A time value representing one hour. -}
|
||||
hour :: Time
|
||||
hour = 3600000
|
||||
|
||||
{-| Converts a time value to a fractional value, in milliseconds. -}
|
||||
inMilliseconds :: Time -> Double
|
||||
inMilliseconds n = n
|
||||
|
||||
{-| Converts a time value to a fractional value, in seconds. -}
|
||||
inSeconds :: Time -> Double
|
||||
inSeconds n = n / second
|
||||
|
||||
{-| Converts a time value to a fractional value, in minutes. -}
|
||||
inMinutes :: Time -> Double
|
||||
inMinutes n = n / minute
|
||||
|
||||
{-| Converts a time value to a fractional value, in hours. -}
|
||||
inHours :: Time -> Double
|
||||
inHours n = n / hour
|
||||
|
||||
now :: Cmd Time
|
||||
now = Cmd $ return []
|
||||
|
||||
every :: Time -> (Time -> a) -> Sub a
|
||||
every _ _ = Sub $ return $ return []
|
42
src/Helm/Window.hs
Normal file
42
src/Helm/Window.hs
Normal file
@ -0,0 +1,42 @@
|
||||
{-| Contains signals that sample input from the game window. -}
|
||||
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 Linear.V2 (V2(V2))
|
||||
|
||||
import qualified SDL
|
||||
import qualified SDL.Video as Video
|
||||
|
||||
size :: Cmd (V2 Int)
|
||||
size = Cmd $ do
|
||||
Engine { window } <- get
|
||||
V2 x y <- SDL.get $ Video.windowSize window
|
||||
|
||||
return [V2 (fromIntegral x) (fromIntegral y)]
|
||||
|
||||
width :: Cmd Int
|
||||
width = Cmd $ do
|
||||
Engine { window } <- get
|
||||
V2 x _ <- SDL.get $ Video.windowSize window
|
||||
|
||||
return [fromIntegral x]
|
||||
|
||||
height :: Cmd Int
|
||||
height = Cmd $ do
|
||||
Engine { window } <- get
|
||||
V2 _ y <- SDL.get $ Video.windowSize window
|
||||
|
||||
return [fromIntegral y]
|
||||
|
||||
resizes :: (V2 Int -> a) -> Sub a
|
||||
resizes _ = Sub $ return $ return []
|
@ -1,7 +1,7 @@
|
||||
flags: {}
|
||||
packages:
|
||||
- '.'
|
||||
- '.'
|
||||
extra-deps:
|
||||
- elerea-2.8.0
|
||||
- text-1.2.2.0
|
||||
- elerea-2.8.0
|
||||
- text-1.2.2.0
|
||||
resolver: lts-5.5
|
||||
|
@ -1,33 +0,0 @@
|
||||
module Color where
|
||||
|
||||
import FRP.Helm.Color
|
||||
import Test.HUnit hiding (Test)
|
||||
import Test.Framework (Test)
|
||||
import Test.Framework.Providers.HUnit
|
||||
import Test.Framework.Providers.QuickCheck2 (testProperty)
|
||||
|
||||
tests :: [Test]
|
||||
tests = [testCase "gray is grey" (gray @=? grey),
|
||||
testCase "hsv sane for black" (black @=? hsv 0 0 0),
|
||||
testCase "hsv sane for white" (white @=? hsv 0 0 1),
|
||||
testCase "hsv sane for red" (red @=? hsv 0 1 1),
|
||||
testCase "hsv sane for lime" (lime @=? hsv 120 1 1),
|
||||
testCase "hsv sane for blue" (blue @=? hsv 240 1 1),
|
||||
testCase "hsv sane for yellow" (yellow @=? hsv 60 1 1),
|
||||
testCase "hsv sane for cyan" (cyan @=? hsv 180 1 1),
|
||||
testCase "hsv sane for magenta" (magenta @=? hsv 300 1 1),
|
||||
testCase "hsv sane for gray" (gray @=? hsv 0 0 0.5),
|
||||
testCase "hsv sane for maroon" (maroon @=? hsv 0 1 0.5),
|
||||
testCase "hsv sane for navy" (navy @=? hsv 240 1 0.5),
|
||||
testCase "hsv sane for green" (green @=? hsv 120 1 0.5),
|
||||
testCase "hsv sane for teal" (teal @=? hsv 180 1 0.5),
|
||||
testCase "hsv sane for purple" (purple @=? hsv 300 1 0.5),
|
||||
testCase "hsv sane for violet" (violet @=? trunc (hsv 300 0.4496 0.923)),
|
||||
testCase "hsv sane for forestGreen" (forestGreen @=? trunc (hsv 120 0.755 0.543))]
|
||||
|
||||
-- We only need a few digits to be right to mark them sane. Hard to be accurate beyond 3, really.
|
||||
trunc :: Color -> Color
|
||||
trunc (Color r g b a) = rgba (trunc' r 3) (trunc' g 3) (trunc' b 3) a
|
||||
|
||||
trunc' :: Double -> Integer -> Double
|
||||
trunc' f n = fromInteger (round $ f * (10 ^ n)) / (10.0 ^^ n)
|
@ -1,9 +0,0 @@
|
||||
module Main where
|
||||
|
||||
import Test.Framework (defaultMain, testGroup)
|
||||
import qualified Color
|
||||
import qualified Time
|
||||
|
||||
main :: IO ()
|
||||
main = defaultMain [testGroup "Color" Color.tests,
|
||||
testGroup "Time" Time.tests]
|
@ -1,11 +0,0 @@
|
||||
module Time where
|
||||
|
||||
import FRP.Helm.Time
|
||||
import Test.HUnit hiding (Test)
|
||||
import Test.Framework (Test)
|
||||
import Test.Framework.Providers.HUnit
|
||||
|
||||
tests :: [Test]
|
||||
tests = [testCase "1 ms is (1/1000) s" (inSeconds millisecond @=? 0.001),
|
||||
testCase "1 s is (1/60) mins" (inMinutes second @=? 1 / 60),
|
||||
testCase "1 min is (1/60) hours" (inHours minute @=? 1 / 60)]
|
Loading…
Reference in New Issue
Block a user