z0w0/helm
1
1
Fork 0
mirror of https://github.com/z0w0/helm.git synced 2024-10-26 13:21:13 +03:00
Code Issues Projects Releases Wiki Activity

Completely reworking engine per recent changes to Elm

Browse Source
This commit is contained in:
Zack Corr 2016-06-11 14:18:50 +10:00
parent b0ed6a91c4
commit 844f551e90
33 changed files with 807 additions and 1974 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
.editorconfig Normal file
View 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
View File

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

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

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

11
src/FRP/Helm/Engine.hs
View File

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

791
src/FRP/Helm/Keyboard.hs
View File

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

53
src/FRP/Helm/Mouse.hs
View File

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

80
src/FRP/Helm/Random.hs
View File

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

29
src/FRP/Helm/Sample.hs
View File

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

164
src/FRP/Helm/Signal.hs
View File

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

148
src/FRP/Helm/Time.hs
View File

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

32
src/FRP/Helm/Utilities.hs
View File

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

44
src/FRP/Helm/Window.hs
View File

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

97
src/FRP/Helm/Color.hs → src/Helm/Color.hs
View File

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

36
src/Helm/Engine.hs Normal file
View 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
View 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
}

35
src/FRP/Helm/Graphics.hs → src/Helm/Graphics2D.hs
View File

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

17
src/FRP/Helm/Text.hs → src/Helm/Graphics2D/Text.hs
View File

@ -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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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 []

33
tests/Color.hs
View File

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

9
tests/Main.hs
View File

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

11
tests/Time.hs
View File

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