diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (C) 2013-2014, Zack Corr +Copyright (C) 2013-2016, Zack Corr Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -2,119 +2,100 @@

- +

## 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 functionally-reactive programming framework](https://github.com/cobbpg/elerea) +and [SDL2](https://www.libsdl.org/). 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 -a value that changes over time. This sort of architecture used for a game allows for pretty -simplistic (and in my opinion, artistic) code. - -Documentation of the Helm API is available on [Hackage](http://hackage.haskell.org/package/helm). -There is currently a heavily work-in-progress guide on [Helm's website](http://helm-engine.org/guide), -which is a resource aiming to give thorough explanations of the way Helm and its API work through examples. -You can [ask on the mailing list](https://groups.google.com/d/forum/helm-dev) if you're having any trouble -with using the engine for games or working on the engine itself, or if you just want to chit-chat about -Helm. - -## Features - -* Allows you to express game logic dependent on input in a straightforward manner, - treating events as first class values (the essence of FRP). -* Vector graphics based rendering, allow you to either write art - designed for any resolution or still load generic images and render - 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 - and readily make the most basic of games. - * `FRP.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 - 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 - as lifting/folding - * `FRP.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. - -## Example - -The simplest example of a Helm game that doesn't require any input from the user is the following: +is contained in a subscription, which is essentially +as a collection of input events changing over time mapped to game interactions. -```haskell -import FRP.Helm -import qualified FRP.Helm.Window as Window +Think of it this way - when you hold down the w and a keys, two keyboard events are being captured at every moment. +You might want your game to move your character forward by pressing `w`. +When you add a subscription to your game, you choose how to map these two input events +into a game action type (which you provide, the engine doesn't have any concept +of how the action works). So if you mapped the `w` key to some game action variant (game +actions are usually represented as a collection of data type variants), and the `w` key was held down, +then at every game tick the game would produce a `w` key press event and turn this into +the relevant game action. -render :: (Int, Int) -> Element -render (w, h) = collage w h [move (100, 100) $ filled red $ square 64] +On top of subscriptions, Helm has another core concept called commands. +Commands are essentially IO-like monads that have context about the engine state. +Like subscriptions, commands are mapped directly to game actions. This +means that when interacting with IO through Helm, you directly +specify how the result maps to a game action and allows you to make logical +conclusions about how certain monadic results should interact with your game. -main :: IO () -main = run defaultConfig $ render <~ Window.dimensions -``` +Helm provides a structure familiar to MVC-based framework developers. +There is a model (which represents the state of your game), +a view of the current model (i.e. what's actually shown on the screen) and a function similiar +to a controller that folds the model forward based off of input actions (which are in turn +mapped to from subscription events). -It renders a red square at the position `(100, 100)` with a side length of `64`. +This presents a powerful paradigm shift for game development. Instead of writing event listeners, +Helm treats input events as first-class citizens of the type system, and the actual interaction +between the game state and input events becomes immediately clearer. -The next example is the barebones of a game that depends on input. It shows how to create -an accumulated state that depends on the values sampled from signals (e.g. mouse input). -You should see a white square on the screen and pressing the arrow keys allows you to move it. +## Features -```haskell -import FRP.Helm -import qualified FRP.Helm.Keyboard as Keyboard -import qualified FRP.Helm.Window as Window +* Interactions between input and game logic is made clear by events and game actions being treated + first-class by the engine +* Color composition via `Helm.Color` +* 2D vector graphics rendering via `Helm.Graphics2D` + * Advanced text rendering via `Helm.Graphics2D.Text` + * Matrix-based 2D transformations (for advanced techniques like skewing) via `Helm.Graphics2D.Transform` +* Keyboard event interactions via `Helm.Keyboard` +* Mouse event interactions via `Helm.Mouse` +* Command-related utilities such as batching via `Helm.Cmd` +* Subscription-related utilities, such as batching and lifting IO-likes via `Helm.Sub` +* Time-based event interactions via `Helm.Time` +* Window event interactions and other utilities via `Helm.Window` +* The base functionality of Helm is separate from the backend engine implementation, so + custom media frameworks (which generally handle rendering, input, etc.) can be integrated + with Helm quite easily. At the moment, the only available implementation is SDL2 + (which is currently bundled with the game engine) however the plan is to have more options in the future. -data State = State { mx :: Double, my :: Double } +## Installing and Building -step :: (Int, Int) -> State -> State -step (dx, dy) state = state { mx = (10 * (realToFrac dx)) + mx state, - my = (10 * (realToFrac dy)) + my state } +Before you can use Helm, you'll to follow the +[Gtk2Hs installation guide](https://wiki.haskell.org/Gtk2Hs/Installation) +(which is required for the Haskell Cairo bindings). Additionally, Helm +requires a GHC version of 7.6 or higher. -render :: (Int, Int) -> State -> Element -render (w, h) (State { mx = mx, my = my }) = - centeredCollage w h [move (mx, my) $ filled white $ square 100] +Using [Stack](https://haskellstack.org) when working with Helm is recommended. +To install Helm with Stack, use: -main :: IO () -main = run defaultConfig $ render <~ Window.dimensions ~~ stepper - where - state = State { mx = 0, my = 0 } - stepper = foldp step state Keyboard.arrows ``` +stack install helm +``` -## Installing and Building +It's best to add Helm as a dependency in your game's Cabal file rather +than installing it globally, however if you're new to the engine, installing +it globally will let you run the example Helm games. See the next section. -Helm requires GHC 7.6 (Elerea doesn't work with older versions due to a compiler bug). -To install the latest (stable) version from the Hackage repository, use: +## Getting Started -``` -cabal install helm -``` +Check out the `examples` directory for some examples; the `flappy` example is a particularly good start. +Unfortunately, there's little to no example games yet, so if you end up making something cool and lightweight +that you'd think would be a good example, feel free to open a pull request! -Alternatively to get the latest development version, you can clone this repository and then run: +If you have installed Helm globally using Stack, you can run the `flappy` example using: ``` -cabal install +stack exec helm-example-flappy ``` -You may need to jump a few hoops to install the Cairo bindings (which are a dependency), -which unfortunately is out of my hands. Read the [installing guide](http://helm-engine.org/guide/installing/) -on the website for a few platform-specific instructions. +## Documentation +API documentation for the latest stable version of Helm is available on [Hackage](http://hackage.haskell.org/package/helm). +Alternatively, if you've cloned this repo, you can build the documentation manually using Haddock. + ## License Helm is licensed under the MIT license. See the LICENSE file for more details. @@ -126,12 +107,10 @@ 1. Try out the engine, reporting any issues or suggestions you have. 2. Look through the source, get a feel for the code and then contribute some features or fixes. If you plan on contributing - code please submit a pull request and follow the formatting - styles set out in the current code: 2 space indents, documentation - on every top-level function, favouring monad operators over - do blocks when there is a logical flow of data, spaces between operators - and after commas, etc. Please also confirm that the code passes under - HLint. - -There are a number of issues [tagged with the bounty tag](https://github.com/switchface/helm/issues?labels=bounty&state=open), -meaning they have associated bounties on [Bountysource](https://www.bountysource.com/trackers/290443-helm). + code, please follow + [Johan Tibell's Haskell style guide](https://github.com/tibbe/haskell-style-guide/blob/master/haskell-style.md) + with the following exceptions: + * Up to 120 characters per line are allowed (widescreens for life). + * Use a two space indent. + * Acronyms in all caps for identifiers (while maintaing camel-case), i.e. SDL or 2D/3D. + diff --git a/examples/flappy/Main.hs b/examples/flappy/Main.hs new file mode 100644 --- /dev/null +++ b/examples/flappy/Main.hs @@ -0,0 +1,402 @@ +{-# LANGUAGE RecordWildCards #-} +-- | A Flappy Bird clone. Click to flap. +-- Avoid the grey obstacles and don't touch the lava. +module Main where + +import Data.List (find) +import Data.Maybe (isJust) +import Debug.Trace (traceShow) +import Text.Printf (printf) + +import Linear.V2 (V2(V2)) +import qualified System.Random as Rand + +import Helm +import qualified Helm.Cmd as Cmd +import Helm.Color +import Helm.Engine.SDL (SDLEngine) +import qualified Helm.Engine.SDL as SDL +import Helm.Graphics2D +import qualified Helm.Graphics2D.Text as Text +import qualified Helm.Keyboard as Keyboard +import qualified Helm.Mouse as Mouse +import qualified Helm.Sub as Sub +import qualified Helm.Time as Time +import Helm.Time (Time) + +-- | Represents the game actions for our game. +data Action + = DoNothing -- ^ Do nothing. + | Animate Double -- ^ Animate the player with a dt. + | Flap -- ^ Flap the player. + | Restart -- ^ Restart the game after dying. + | SetupObstacles Rand.StdGen -- ^ Setup the obstacles using an RNG. + +-- | Represents the status of the player (i.e. where they're at). +data PlayerStatus + = Playing -- ^ The player is playing the game. + | Waiting -- ^ The player is waiting and needs to click to start the game. + | Dead -- ^ The player is dead and needs to hit space to get to the waiting state. + deriving (Eq, Ord, Show) + +-- | Represents an obstacle the flapper can hit. +data Obstacle + = NoObstacle -- ^ The obstacle exists, but it's just empty (not visible and uncollidable). + | Obstacle -- ^ An actually collidable obstacle. + { obsTopLeft :: V2 Double + , obsBottomRight :: V2 Double + } deriving (Eq, Ord, Show) + +-- | Represents the game state of the game. +data Model = Model + { flapperPos :: V2 Double + , flapperVel :: V2 Double + , playerStatus :: PlayerStatus + , obstacles :: [Obstacle] + , timeScore :: Time + , timeSpeed :: Double + } + +initial :: (Model, Cmd SDLEngine Action) +initial = + ( Model + { flapperPos = V2 0 0 + , flapperVel = V2 0 0 + , playerStatus = Waiting + , obstacles = [] + , timeScore = 0 + , timeSpeed = 1 + } + , Cmd.execute Rand.newStdGen SetupObstacles + ) + +-- | The gravity acceleration for the flapper. +-- Note that the Y component is positive as the downwards +-- direction in our view is the positive end of the Y-axis. +-- The origin (0, 0) is the center of the screen. +gravity :: V2 Double +gravity = V2 0 7 + +lavaHeight :: Double +lavaHeight = 65 + +windowDims :: V2 Int +windowDims = V2 800 600 + +scrollVel :: V2 Double +scrollVel = V2 4 0 + +obsWidth :: Double +obsWidth = 70 + +obsMargin :: Double +obsMargin = 50 + +obsOffset :: Double +obsOffset = (obsMargin + obsWidth) * 6 + +flapperDims :: V2 Double +flapperDims = V2 50 50 + +-- | Only the obstacles the player has seen/can see. +relevantObs :: Model -> [Obstacle] +relevantObs Model { .. } = + take n obstacles + + where + V2 x _ = flapperPos + V2 w _ = fromIntegral <$> windowDims + n = max 0 $ floor $ (x - obsOffset + w) / (obsMargin + obsWidth) + +-- | Are any obstacles touching the flapper? +touchingObs :: Model -> Bool +touchingObs model@Model { .. } = + isJust $ find f $ relevantObs model + + where + V2 x y = flapperPos + V2 w h = flapperDims + + -- The flapper pos is centered. Turn it into a box. + ftx = x - w / 2 + fty = y - h / 2 + fbx = x + w / 2 + fby = y + h / 2 + + -- Check if the flapper box and obs box intersect. + -- If so, we're dead. + f NoObstacle = False + f Obstacle { .. } = + max tx ftx < min bx fbx && + max ty fty < min by fby + + where + V2 tx ty = obsTopLeft + V2 bx by = obsBottomRight + +-- | Is our flapper touching the lava at the bottom of the screen? +inLava :: Model -> Bool +inLava Model { .. } = + y + fh / 2 >= h / 2 - lavaHeight + + where + V2 _ fh = flapperDims + V2 x y = flapperPos + V2 w h = fromIntegral <$> windowDims + +-- | Should our flapper die? Only checks if they should - +-- DOES NOT transition the player status to dead. +shouldDie :: Model -> Bool +shouldDie model = inLava model || touchingObs model + +update :: Model -> Action -> (Model, Cmd SDLEngine Action) +update model@Model { .. } (Animate dt) = + if playerStatus == Waiting then (model, Cmd.none) + else + ( model + { flapperPos = if y < -hh + then V2 x (-hh) + else pos + , flapperVel = vel + , playerStatus = if dead + then Dead + else Playing + , timeScore = elapsed + , timeSpeed = speed + } + , Cmd.none + ) + + where + -- | If the player is actually playing, increase the score. + -- They might be at the death screen (which is also animated). + elapsed = if dead + then timeScore + else timeScore + dt + + dt' = dt * 0.005 + gravity' = gravity * V2 dt' dt' + + -- Make the movement right faster as the player gets further across. + speed = logBase 10 (10 + Time.inSeconds elapsed) + vel = if dead + then V2 0 1 * (flapperVel + gravity') -- No x-velocity while dead. + else flapperVel + gravity' + + pos@(V2 x y) = flapperPos + vel + if dead + then V2 0 0 + else scrollVel * V2 speed 0 + + V2 _ h = fromIntegral <$> windowDims + hh = h / 2 + dead = (playerStatus == Dead) || shouldDie model + +-- | The player has clicked using their mouse. +-- | Process the "flap" of our flapper's wings. +update model@Model { .. } Flap = + if playerStatus == Dead + then (model, Cmd.none) + else + ( model + { flapperVel = V2 0 (-17) + , playerStatus = Playing + } + , Cmd.none + ) + +-- | The player has pressed space while on the death screen. +-- Restart the game. +update model@Model { .. } Restart = + if playerStatus /= Dead + then (model, Cmd.none) + else + ( model + { playerStatus = Waiting + , flapperPos = V2 0 0 + , flapperVel = V2 0 0 + , timeScore = 0 + } + + -- Trigger a regeneration of obstacles + , Cmd.execute Rand.newStdGen SetupObstacles + ) + +-- | Initialize a list of all the obstacles in the game. +-- This works really nicely, as the list of obstacles +-- we produce is lazy and we can just keep generating +-- new obstacles out of until infinity - which is perfect, +-- as our player might just keep playing the game +-- for an eternity and beyond. +update model (SetupObstacles rng) = + (model + { obstacles = scanl generate NoObstacle $ + zip [0..] $ + Rand.randoms rng + } + , Cmd.none + ) + + where + -- | Generate an obstacle based based off the last obstacle + -- generated and some random input. + generate + :: Obstacle -- | The last obstacle generated (or 'NoObstacle' if first). + -> (Int, Double) -- | First element is the obstacle index, second is random input between [0,1). + -> Obstacle -- | The generated obstacle. + generate last (i, n) = + -- Randomly exclude obstacles, but don't do it for the first one. + if i > 0 && (n < lb || n > hb) + then NoObstacle + else + Obstacle + { obsTopLeft = V2 x y + , obsBottomRight = V2 (x + obsWidth) (y + height) + } + + where + lb = 0.2 + hb = 0.8 + + -- We have to normalize the value here as we ignored < lb and > hb above. + -- Let's get this back to (0, 1] + n' = (n - lb) / (hb - lb) + x = obsOffset + (obsWidth + obsMargin) * fromIntegral i + V2 _ h = fromIntegral <$> windowDims + h' = h - lavaHeight + hh' = h / 2 + minHeight = 100 + maxHeight = 300 + (y, height) = calc last + + -- | Calc the obstacle height and + calc NoObstacle = + -- Generate a random y and random height. This can be anywhere on the screen as + -- we're not next to an older obstacle. + (-hh' + n' * h', height') + + where + height' = minHeight + (maxHeight - minHeight) * n' + + calc Obstacle { .. } = + -- We want the obstacle being generated to be in a similar position + -- to the last one generated. So we adjust the last position randomly + -- by a portion of the last generated obstacle's height. + ( max (-hh') $ min hh' $ ty + (n' - 0.5) * maxHeight + , height') + + where + V2 tx ty = obsTopLeft + V2 bx by = obsBottomRight + lastHeight = by - ty + height' = min maxHeight $ lastHeight + (n' - 0.5) * minHeight + +-- | Do nothing. +update model _ = (model, Cmd.none) + +subscriptions :: Sub SDLEngine Action +subscriptions = Sub.batch + [ Mouse.clicks $ \_ _ -> Flap + , Keyboard.presses $ \key -> (case key of + Keyboard.SpaceKey -> Restart + _ -> DoNothing) + , Time.fps 60 Animate + ] + +-- | Turn some second value into a pretty pluralized form (for UI). +secondsText :: Time -> String +secondsText t = + show s ++ if s /= 1 then " seconds" else " second" + + where + s = round $ Time.inSeconds t + +-- | The overlay displayed when the player is dead. +deadOverlay :: Color -> Model -> Form SDLEngine +deadOverlay color Model { .. } = + group + [ move (V2 0 (-25)) $ text $ Text.height 30 $ + Text.color color $ + Text.toText "Oops, you're dead." + + , move (V2 0 25) $ text $ Text.height 12 $ + Text.color color $ + Text.toText score + + , move (V2 0 50) $ text $ Text.height 12 $ + Text.color color $ + Text.toText "Press space to restart" + ] + + where + score = "You lasted " ++ secondsText timeScore + +-- | The overlay displayed when the player is waiting to play. +waitingOverlay :: Color -> Form SDLEngine +waitingOverlay color = + group + [ move (V2 0 (-75)) $ text $ Text.height 30 $ + Text.color color $ + Text.toText "Ready?" + + , move (V2 0 75) $ text $ Text.height 12 $ + Text.color color $ + Text.toText "Click to flap" + ] + +-- | The overlay when playing the game (i.e. HUD). +playingOverlay :: Color -> Model -> Form SDLEngine +playingOverlay color Model { .. } = + group + [ + move (V2 0 (-h / 2 + 25)) $ text $ Text.height 12 $ + Text.color color $ + Text.toText status + ] + + where + status = secondsText timeScore ++ " | " ++ printf "%.2fx speed" timeSpeed + V2 _ h = fromIntegral <$> windowDims + +view :: Model -> Graphics SDLEngine +view model@Model { .. } = Graphics2D $ + center (V2 (w / 2) (h / 2)) $ collage + [ backdrop + , toForm $ center (V2 (-x) 0) $ collage + [ move flapperPos flapper + , group $ map structure $ relevantObs model + ] + + , lava + , overlay playerStatus model + ] + + where + dims@(V2 w h) = fromIntegral <$> windowDims + V2 x y = flapperPos + overlayColor = rgb 1 1 1 + overlay Waiting _ = waitingOverlay overlayColor + overlay Dead model = deadOverlay overlayColor model + overlay Playing model = playingOverlay overlayColor model + flapper = filled (rgb 0.36 0.25 0.22) $ rect flapperDims + backdrop = filled (rgb 0.13 0.13 0.13) $ rect dims + lava = move (V2 0 (h / 2 - lavaHeight / 2)) $ filled (rgb 0.72 0.11 0.11) $ rect $ V2 w lavaHeight + structure NoObstacle = blank + structure Obstacle { .. } = + move (V2 ((tx + bx) / 2) ((ty + by) / 2)) $ filled (rgb 0.38 0.49 0.55) $ rect $ V2 (bx - tx) (by - ty) + + where + V2 tx ty = obsTopLeft + V2 bx by = obsBottomRight + +main :: IO () +main = do + engine <- SDL.startupWith $ SDL.defaultConfig + { SDL.windowIsResizable = False + , SDL.windowDimensions = windowDims } + + run engine GameConfig + { initialFn = initial + , updateFn = update + , subscriptionsFn = subscriptions + , viewFn = view + } diff --git a/helm.cabal b/helm.cabal --- a/helm.cabal +++ b/helm.cabal @@ -1,5 +1,5 @@ name: helm -version: 0.7.1 +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. @@ -7,12 +7,12 @@ bug-reports: http://github.com/switchface/helm/issues license: MIT license-file: LICENSE -tested-with: GHC == 7.6.3 +tested-with: GHC == 7.10.2 extra-source-files: LICENSE, README.md author: Zack Corr maintainer: Zack Corr copyright: (c) 2013-2014, Zack Corr -category: Game Engine, FRP +category: Game Engine, .1FRP build-type: Simple cabal-version: >=1.10 @@ -23,58 +23,69 @@ library hs-source-dirs: src default-language: Haskell2010 - default-extensions: RecordWildCards, NamedFieldPuns - ghc-options: -Wall -fno-warn-unused-do-bind + default-extensions: RecordWildCards, NamedFieldPuns, TypeFamilies + ghc-options: -Wall 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.Asset + Helm.Cmd + Helm.Color + Helm.Engine + Helm.Engine.SDL + Helm.Engine.SDL.Asset + Helm.Engine.SDL.Engine + Helm.Engine.SDL.Graphics2D + Helm.Engine.SDL.Keyboard + Helm.Engine.SDL.Mouse + Helm.Graphics + Helm.Graphics2D + Helm.Graphics2D.Text + Helm.Graphics2D.Transform + Helm.Keyboard + Helm.Mouse + Helm.Sub + Helm.Time + Helm.Window build-depends: - base >= 4 && < 5, - cairo > 0.12 && < 0.13, - pango > 0.12 && < 0.13, + base == 4.*, + cairo >= 0.13 && < 0.14, + pango >= 0.13 && < 0.14, containers >= 0.5 && < 1, - elerea >= 2.7 && < 3, - filepath >= 1.3 && < 2, - sdl2 >= 1.1 && < 1.3, - text >= 1.1.1.3, - time >= 1.4 && < 1.5, - random >= 1.0.1.1 && < 1.2, - mtl >= 2.1 && < 2.2, - transformers >= 0.3.0.0, - cpu >= 0.1.2 && < 1 + elerea >= 2.9 && < 3, + sdl2 > 2.1.1 && < 3, + linear >= 1 && < 2, + text >= 1.1.1.3 && < 2, + mtl >= 2.1 && < 3, + stm >= 2.4 && < 3, + transformers >= 0.3.0.0 && < 0.6 if impl(ghc < 7.6) build-depends: ghc-prim -test-suite helm-tests - type: exitcode-stdio-1.0 - x-uses-tf: true - ghc-options: -threaded -Wall -rtsopts -O - hs-source-dirs: tests, src +executable helm-example-flappy default-language: Haskell2010 main-is: Main.hs + hs-source-dirs: examples/flappy build-depends: base >= 4 && < 5, - cairo > 0.12 && < 0.13, - containers >= 0.5 && < 1, - HUnit >= 1.2 && < 2, - test-framework >= 0.8 && < 1, - test-framework-hunit >= 0.3 && < 1, - test-framework-quickcheck2 >= 0.3 && < 1, - time >= 1.4 && < 1.5, - elerea >= 2.7 && < 3, - sdl2 >= 1.1 && < 1.3 + linear >= 1 && < 2, + random == 1.*, + helm + +test-suite helm-spec + type: exitcode-stdio-1.0 + ghc-options: -Wall + hs-source-dirs: test + default-language: Haskell2010 + main-is: Spec.hs + + other-modules: + Helm.TimeSpec + + build-depends: + base == 4.*, + hspec == 2.*, + helm diff --git a/src/FRP/Helm.hs b/src/FRP/Helm.hs deleted file mode 100644 --- a/src/FRP/Helm.hs +++ /dev/null @@ -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.Applicative -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.Bits -import Data.Foldable (forM_) -import Foreign.C.String -import Foreign.Marshal.Alloc -import Foreign.Ptr -import Foreign.Storable -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 System.Endian -import qualified Data.Map as Map -import qualified Graphics.UI.SDL as SDL -import qualified Graphics.Rendering.Cairo as Cairo -import qualified Graphics.Rendering.Pango as Pango - -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 { .. }) = withCAString windowTitle $ \title -> do - window <- SDL.createWindow title 0 0 (fromIntegral w) (fromIntegral h) wflags - renderer <- SDL.createRenderer window (-1) rflags - - return Engine { window = window - , renderer = renderer - , cache = Map.empty - , continue = True - } - - where - (w, h) = windowDimensions - wflags = foldl (.|.) 0 $ [SDL.windowFlagShown] ++ - [SDL.windowFlagResizable | windowIsResizable] ++ - [SDL.windowFlagFullscreen | windowIsFullscreen] - rflags = (.|.) SDL.rendererFlagPresentVSync SDL.rendererFlagAccelerated - -{-| 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.quit - -{-| An event that triggers when SDL thinks we need to re-draw. -} -exposed :: Signal () -exposed = Signal getExposed - where - getExposed = effectful $ alloca $ \eventptr -> do - SDL.pumpEvents - status <- SDL.pollEvent eventptr - - if status == 1 then do - event <- peek eventptr - - case event of - SDL.WindowEvent _ _ _ e _ _ -> return $ if e == SDL.windowEventExposed - then Changed () - else Unchanged () - _ -> return $ Unchanged () - else return $ Unchanged () - -{-| An event that triggers when SDL thinks we need to quit. -} -quit :: Signal () -quit = Signal getQuit - where - getQuit = effectful $ do - q <- SDL.quitRequested - return (if q then Changed () else 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) = alloca $ \pixelsptr -> - alloca $ \pitchptr -> do - format <- SDL.masksToPixelFormatEnum 32 (fromBE32 0x0000ff00) - (fromBE32 0x00ff0000) (fromBE32 0xff000000) (fromBE32 0x000000ff) - - texture <- SDL.createTexture renderer format - SDL.textureAccessStreaming (fromIntegral w) (fromIntegral h) - - SDL.lockTexture texture nullPtr pixelsptr pitchptr - - pixels <- peek pixelsptr - pitch <- fromIntegral <$> peek pitchptr - - res <- Cairo.withImageSurfaceForData (castPtr pixels) - Cairo.FormatARGB32 w h pitch $ \surface -> Cairo.renderWith surface - $ evalStateT (render' w h element) engine - - SDL.unlockTexture texture - - SDL.renderClear renderer - SDL.renderCopy renderer texture nullPtr nullPtr - SDL.destroyTexture texture - SDL.renderPresent 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 = 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 diff --git a/src/FRP/Helm/Color.hs b/src/FRP/Helm/Color.hs deleted file mode 100644 --- a/src/FRP/Helm/Color.hs +++ /dev/null @@ -1,196 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -{-| Contains all data structures and functions for composing colors. -} -module FRP.Helm.Color ( - -- * Types - Color(..), - Gradient(..), - -- * Composing - rgba, - rgb, - hsva, - hsv, - blend, - complement, - linear, - radial, - -- * Constants - red, - lime, - blue, - yellow, - cyan, - magenta, - black, - white, - gray, - grey, - maroon, - navy, - green, - teal, - purple, - violet, - forestGreen -) where - -import GHC.Generics - -{-| A data structure describing a color. It is represented interally as an RGBA - color, but the utility functions 'hsva', 'hsv', etc. can be used to convert - from other popular formats to this structure. -} -data Color = Color Double Double Double Double deriving (Show, Eq, Ord, Read, Generic) - -{-| Creates an RGB color. -} -rgb :: Double -> Double -> Double -> Color -rgb r g b = rgba r g b 1 - -{-| Creates an RGB color, with transparency. -} -rgba :: Double -> Double -> Double -> Double -> Color -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" - | 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 - where - denom = fromIntegral $ length colors - -{-| A utility function that adds colors together. -} -blend' :: Color -> Color -> Color -blend' (Color r1 g1 b1 a1) (Color r2 g2 b2 a2) = Color (r1 + r2) (g1 + g2) (b1 + b2) (a1 + a2) - -{-| Calculate a complementary color for a provided color. Useful for outlining - a filled shape in a color clearly distinguishable from the fill color. -} -complement :: Color -> Color -complement (Color r g b a) = hsva (fromIntegral ((round (h + 180) :: Int) `mod` 360)) (s / mx) mx a - where - mx = r `max` g `max` b - mn = r `min` g `min` b - s = mx - mn - h | mx == r = (g - b) / s * 60 - | mx == g = (b - r) / s * 60 + 120 - | mx == b = (r - g) / s * 60 + 240 - | otherwise = undefined - -{-| Create an RGBA color from HSVA values. -} -hsva :: Double -> Double -> Double -> Double -> Color -hsva h s v a - | h'' == 0 = rgba v t p a - | h'' == 1 = rgba q v p a - | h'' == 2 = rgba p v t a - | h'' == 3 = rgba p q v a - | h'' == 4 = rgba t p v a - | h'' == 5 = rgba v p q a - | otherwise = undefined - - where - h' = h / 60 - h'' = floor h' `mod` 6 :: Int - f = h' - fromIntegral h'' - p = v * (1 - s) - q = v * (1 - f * s) - t = v * (1 - (1 - f) * s) - -{-| Create an RGB color from HSV values. -} -hsv :: Double -> Double -> Double -> Color -hsv h s v = hsva h s v 1 - -{-| A data structure describing a gradient. There are two types of gradients: - radial and linear. Radial gradients are based on a set of colors transitioned - over certain radii in an arc pattern. Linear gradients are a set of colors - transitioned in a straight line. -} -data Gradient = Linear (Double, Double) (Double, Double) [(Double, Color)] | - Radial (Double, Double) Double (Double, Double) Double [(Double, Color)] deriving (Show, Eq, Ord, Read) - -{-| Creates a linear gradient. Takes a starting position, ending position and a list - of color stops (which are colors combined with a floating value between /0.0/ and /1.0/ - that describes at what step along the line between the starting position - and ending position the paired color should be transitioned to). - - > linear (0, 0) (100, 100) [(0, black), (1, white)] - - The above example creates a gradient that starts at /(0, 0)/ - and ends at /(100, 100)/. In other words, it's a diagonal gradient, transitioning from the top-left - to the bottom-right. The provided color stops result in the gradient transitioning from - black to white. - -} -linear :: (Double, Double) -> (Double, Double) -> [(Double, Color)] -> Gradient -linear = Linear - -{-| Creates a radial gradient. Takes a starting position and radius, ending position and radius - and a list of color stops. See the document for 'linear' for more information on color stops. -} -radial :: (Double, Double) -> Double -> (Double, Double) -> Double -> [(Double, Color)] -> Gradient -radial = Radial diff --git a/src/FRP/Helm/Engine.hs b/src/FRP/Helm/Engine.hs deleted file mode 100644 --- a/src/FRP/Helm/Engine.hs +++ /dev/null @@ -1,11 +0,0 @@ -module FRP.Helm.Engine where -import qualified Graphics.UI.SDL as SDL -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 :: SDL.Window, - renderer :: SDL.Renderer, - cache :: Map.Map FilePath Cairo.Surface, - continue :: Bool -} diff --git a/src/FRP/Helm/Graphics.hs b/src/FRP/Helm/Graphics.hs deleted file mode 100644 --- a/src/FRP/Helm/Graphics.hs +++ /dev/null @@ -1,303 +0,0 @@ -{-| Contains all the data structures and functions for composing - and rendering graphics. -} -module FRP.Helm.Graphics ( - -- * Types - Element(..), - FontWeight(..), - FontStyle(..), - Text(..), - Form(..), - FormStyle(..), - FillStyle(..), - LineCap(..), - LineJoin(..), - LineStyle(..), - Path, - Shape(..), - -- * Elements - image, - fittedImage, - croppedImage, - collage, - centeredCollage, - fixedCollage, - -- * Styles & Forms - defaultLine, - solid, - dashed, - dotted, - filled, - textured, - gradient, - outlined, - traced, - sprite, - toForm, - blank, - -- * Grouping - group, - groupTransform, - -- * Transforming - rotate, - scale, - move, - moveX, - moveY, - -- * Paths - path, - segment, - -- * Shapes - polygon, - rect, - square, - oval, - circle, - ngon -) where - -import FRP.Helm.Color (Color, black, Gradient) -import Graphics.Rendering.Cairo.Matrix (Matrix) - -{-| A data structure describing the weight of a piece of font. -} -data FontWeight = LightWeight | - NormalWeight | - BoldWeight deriving (Show, Eq, Ord, Enum, Read) - -{-| A data structure describing the style of of a piece of font. -} -data FontStyle = NormalStyle | - ObliqueStyle | - ItalicStyle deriving (Show, Eq, Ord, Enum, Read) - -{-| A data structure describing a piece of formatted text. -} -data Text = Text { - textUTF8 :: String, - textColor :: Color, - textTypeface :: String, - textHeight :: Double, - textWeight :: FontWeight, - textStyle :: FontStyle -} deriving (Show, Eq) - -{-| A data structure describing something that can be rendered - to the screen. Elements are the most important structure - in Helm. Games essentially feed the engine a stream - of elements which are then rendered directly to the screen. - The usual way to render art in a Helm game is to call - off to the 'collage' function, which essentially - renders a collection of forms together. -} -data Element = CollageElement Int Int (Maybe (Double, Double)) [Form] | - ImageElement (Int, Int) Int Int FilePath Bool | - TextElement Text deriving (Show, Eq) - -{-| Create an element from an image with a given width, height and image file path. - If the image dimensions are not the same as given, then it will stretch/shrink to fit. - Only PNG files are supported currently. -} -image :: Int -> Int -> FilePath -> Element -image w h src = ImageElement (0, 0) w h src True - -{-| Create an element from an image with a given width, height and image file path. - If the image dimensions are not the same as given, then it will only use the relevant pixels - (i.e. cut out the given dimensions instead of scaling). If the given dimensions are bigger than - the actual image, than irrelevant pixels are ignored. -} -fittedImage :: Int -> Int -> FilePath -> Element -fittedImage w h src = ImageElement (0, 0) w h src False - -{-| Create an element from an image by cropping it with a certain position, width, height - and image file path. This can be used to divide a single image up into smaller ones. -} -croppedImage :: (Int, Int) -> Int -> Int -> FilePath -> Element -croppedImage pos w h src = ImageElement pos w h src False - -{-| A data structure describing a form. A form is essentially a notion of a transformed - graphic, whether it be an element or shape. See 'FormStyle' for an insight - into what sort of graphics can be wrapped in a form. -} -data Form = Form { - formTheta :: Double, - formScale :: Double, - formX :: Double, - formY :: Double, - formStyle :: FormStyle -} deriving (Show, Eq) - -{-| A data structure describing how a shape or path looks when filled. -} -data FillStyle = Solid Color | Texture String | Gradient Gradient deriving (Show, Eq, Ord, Read) - -{-| A data structure describing the shape of the ends of a line. -} -data LineCap = FlatCap | RoundCap | PaddedCap deriving (Show, Eq, Enum, Ord, Read) - -{-| A data structure describing the shape of the join of a line, i.e. - where separate line segments join. The 'Sharp' variant takes - an argument to limit the length of the join. -} -data LineJoin = SmoothJoin | SharpJoin Double | ClippedJoin deriving (Show, Eq, Ord, Read) - -{-| A data structure describing how a shape or path looks when stroked. -} -data LineStyle = LineStyle { - lineColor :: Color, - lineWidth :: Double, - lineCap :: LineCap, - lineJoin :: LineJoin, - lineDashing :: [Double], - lineDashOffset :: Double -} deriving (Show, Eq) - -{-| Creates the default line style. By default, the line is black with a width of 1, - flat caps and regular sharp joints. -} -defaultLine :: LineStyle -defaultLine = LineStyle { - lineColor = black, - lineWidth = 1, - lineCap = FlatCap, - lineJoin = SharpJoin 10, - lineDashing = [], - lineDashOffset = 0 -} - -{-| Create a solid line style with a color. -} -solid :: Color -> LineStyle -solid color = defaultLine { lineColor = color } - -{-| Create a dashed line style with a color. -} -dashed :: Color -> LineStyle -dashed color = defaultLine { lineColor = color, lineDashing = [8, 4] } - -{-| Create a dotted line style with a color. -} -dotted :: Color -> LineStyle -dotted color = defaultLine { lineColor = color, 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) - -{-| Utility function for creating a form. -} -form :: FormStyle -> Form -form style = Form { formTheta = 0, formScale = 1, formX = 0, formY = 0, formStyle = style } - -{-| Utility function for creating a filled form from a fill style and shape. -} -fill :: FillStyle -> Shape -> Form -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) - -{-| Creates a form from a shape with a tiled texture and image file path. -} -textured :: String -> Shape -> Form -textured src = fill (Texture src) - -{-| Creates a form from a shape filled with a gradient. -} -gradient :: Gradient -> Shape -> Form -gradient grad = fill (Gradient grad) - -{-| Creates a form from a shape by outlining it with a specific line style. -} -outlined :: LineStyle -> Shape -> Form -outlined style shape = form (ShapeForm (Left style) shape) - -{-| Creates a form from a path by tracing it with a specific line style. -} -traced :: LineStyle -> Path -> Form -traced style p = form (PathForm style p) - -{-| Creates a form from a image file path with additional position, width and height arguments. - Allows you to splice smaller parts from a single image. -} -sprite :: Int -> Int -> (Int, Int) -> FilePath -> Form -sprite w h pos src = form (ElementForm (ImageElement pos w h src False)) - -{-| Creates a form from an element. -} -toForm :: Element -> Form -toForm element = form (ElementForm element) - -{-| Creates a empty form, useful for having forms rendered only at some state. -} -blank :: Form -blank = group [] - -{-| Groups a collection of forms into a single one. -} -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) - -{-| Rotates a form by an amount (in radians). -} -rotate :: Double -> Form -> Form -rotate t f = f { formTheta = t + formTheta f } - -{-| Scales a form by an amount, e.g. scaling by /2.0/ will double the size. -} -scale :: Double -> Form -> Form -scale n f = f { formScale = n * formScale f } - -{-| Moves a form relative to its current position. -} -move :: (Double, Double) -> Form -> Form -move (rx, ry) f = f { formX = rx + formX f, formY = ry + formY f } - -{-| Moves a form's x-coordinate relative to its current position. -} -moveX :: Double -> Form -> Form -moveX x = move (x, 0) - -{-| Moves a form's y-coordinate relative to its current position. -} -moveY :: Double -> Form -> Form -moveY y = move (0, y) - -{-| Create an element from a collection of forms, with width and height arguments. - All forms are centered and clipped within the supplied dimensions. - It is generally used to directly render a collection of forms. - - > collage 800 600 [move (100, 100) $ filled red $ square 100, - > move (100, 100) $ outlined (solid white) $ circle 50] - -} -collage :: Int -> Int -> [Form] -> Element -collage w h = CollageElement w h Nothing - -{-| Like 'collage', but it centers the forms within the supplied dimensions. -} -centeredCollage :: Int -> Int -> [Form] -> Element -centeredCollage w h = CollageElement w h (Just (realToFrac w / 2, realToFrac h / 2)) - -{-| Like 'centeredCollage', but it centers the forms around a specific point. -} -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)] - -{-| Creates a path for a collection of points. -} -path :: [(Double, Double)] -> Path -path points = 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] - -{-| A data structure describing a some sort of graphically representable object, - such as a polygon formed from a list of points or a rectangle. -} -data Shape = PolygonShape Path | - RectangleShape (Double, Double) | - ArcShape (Double, Double) Double Double Double (Double, Double) deriving (Show, Eq, Ord, Read) - -{-| Creates a shape from a path (a list of points). -} -polygon :: Path -> Shape -polygon = PolygonShape - -{-| Creates a rectangular shape with a width and height. -} -rect :: Double -> Double -> Shape -rect w h = RectangleShape (w, h) - -{-| Creates a square shape with a side length. -} -square :: Double -> Shape -square n = rect n n - -{-| Creates an oval shape with a width and height. -} -oval :: Double -> Double -> Shape -oval w h = ArcShape (0, 0) 0 (2 * pi) 1 (w / 2, h / 2) - -{-| Creates a circle shape with a radius. -} -circle :: Double -> Shape -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 - m = fromIntegral n - t = 2 * pi / m diff --git a/src/FRP/Helm/Keyboard.hs b/src/FRP/Helm/Keyboard.hs deleted file mode 100644 --- a/src/FRP/Helm/Keyboard.hs +++ /dev/null @@ -1,793 +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 Control.Applicative -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 . -} -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 - diff --git a/src/FRP/Helm/Mouse.hs b/src/FRP/Helm/Mouse.hs deleted file mode 100644 --- a/src/FRP/Helm/Mouse.hs +++ /dev/null @@ -1,86 +0,0 @@ -{-| Contains signals that sample input from the mouse. -} -module FRP.Helm.Mouse -( - -- * Types - Mouse(..), - -- * Position - position, x, y, - -- * Mouse State - isDown, - isDownButton, - clicks -) where - -import Control.Applicative (pure) -import Data.Bits -import Foreign.Marshal.Alloc -import Foreign.Ptr -import Foreign.Storable -import FRP.Elerea.Param hiding (Signal) -import FRP.Helm.Sample -import FRP.Helm.Signal -import qualified Graphics.UI.SDL as SDL - -{-| A data structure describing a button on a mouse. -} -data Mouse - = LeftMouse - | MiddleMouse - | RightMouse - | X1Mouse - | X2Mouse deriving (Show, Eq, Ord, Read) - -{- All integer values of this enum are equivalent to the SDL key enum. -} -instance Enum Mouse where - fromEnum LeftMouse = 1 - fromEnum MiddleMouse = 2 - fromEnum RightMouse = 3 - fromEnum X1Mouse = 4 - fromEnum X2Mouse = 5 - - toEnum 1 = LeftMouse - toEnum 2 = MiddleMouse - toEnum 3 = RightMouse - toEnum 4 = X1Mouse - toEnum 5 = X2Mouse - toEnum _ = error "FRP.Helm.Mouse.Mouse.toEnum: bad argument" - -{-| The current position of the mouse. -} -position :: Signal (Int, Int) -position = Signal $ getPosition >>= transfer (pure (0,0)) update - where - getPosition = effectful $ alloca $ \xptr -> alloca $ \yptr -> do - _ <- SDL.getMouseState xptr yptr - x_ <- peek xptr - y_ <- peek yptr - - 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 LeftMouse - -{-| The current state of a given mouse button. True if down, false otherwise. - -} -isDownButton :: Mouse -> Signal Bool -isDownButton m = Signal $ getDown >>= transfer (pure False) update - where - getDown = effectful $ do - flags <- SDL.getMouseState nullPtr nullPtr - - return $ (.&.) (fromIntegral flags) (fromEnum m) /= 0 - -{-| 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 () - diff --git a/src/FRP/Helm/Random.hs b/src/FRP/Helm/Random.hs deleted file mode 100644 --- a/src/FRP/Helm/Random.hs +++ /dev/null @@ -1,81 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} -module FRP.Helm.Random ( - range, - float, - floatList -) where -import Control.Applicative (pure) -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 diff --git a/src/FRP/Helm/Sample.hs b/src/FRP/Helm/Sample.hs deleted file mode 100644 --- a/src/FRP/Helm/Sample.hs +++ /dev/null @@ -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 diff --git a/src/FRP/Helm/Signal.hs b/src/FRP/Helm/Signal.hs deleted file mode 100644 --- a/src/FRP/Helm/Signal.hs +++ /dev/null @@ -1,127 +0,0 @@ -module FRP.Helm.Signal( - Signal(..), - -- * Composing - constant, - combine, - lift, - lift2, - lift3, - (<~), - (~~), - -- * Accumulating - foldp, - count, - countIf, - -- * DYEL? - lift4, - lift5, - lift6, - lift7, - lift8 -) where -import Control.Applicative -import Data.Traversable (sequenceA) -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 - -{-| 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) -> SignalGen (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 diff --git a/src/FRP/Helm/Text.hs b/src/FRP/Helm/Text.hs deleted file mode 100644 --- a/src/FRP/Helm/Text.hs +++ /dev/null @@ -1,98 +0,0 @@ -{-| Contains all the data structures and functions for composing - pieces of formatted text. -} -module FRP.Helm.Text ( - -- * Elements - plainText, - asText, - text, - -- * Composing - defaultText, - toText, - -- * Formatting - light, - bold, - italic, - oblique, - color, - monospace, - typeface, - header, - height -) where - -import FRP.Helm.Color (Color, black) -import FRP.Helm.Graphics (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, - textTypeface = "sans-serif", - textHeight = 14, - textWeight = NormalWeight, - textStyle = NormalStyle -} - -{-| Creates a text from a string. -} -toText :: String -> Text -toText utf8 = defaultText { textUTF8 = utf8 } - -{-| Creates a text element from a string. -} -plainText :: String -> Element -plainText utf8 = text $ toText utf8 - -{-| Creates a text element from any showable type, defaulting to - the monospace typeface. -} -asText :: Show a => a -> Element -asText val = text $ monospace $ toText $ show val - -{-| Creates an element from a text. -} -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 } - -{-| Sets the weight of a piece of text to light. -} -light :: Text -> Text -light txt = txt { textWeight = LightWeight } - -{-| Sets the slant of a piece of text to italic. -} -italic :: Text -> Text -italic txt = txt { textStyle = ItalicStyle } - -{-| Sets the slant of a piece of text to oblique. -} -oblique :: Text -> Text -oblique txt = txt { textStyle = ObliqueStyle } - -{-| Sets the color of a piece of text. -} -color :: Color -> Text -> Text -color col txt = txt { textColor = col } - -{-| Sets the typeface of the text to monospace. -} -monospace :: Text -> Text -monospace txt = txt { textTypeface = "monospace" } - -{-| Sets the typeface of the text. -} -typeface :: String -> Text -> Text -typeface face txt = txt { textTypeface = face } - -{-| Sets the size of a text noticeably large. -} -header :: Text -> Text -header = height 32 - -{-| Sets the size of a piece of text. -} -height :: Double -> Text -> Text -height size txt = txt { textHeight = size } diff --git a/src/FRP/Helm/Time.hs b/src/FRP/Helm/Time.hs deleted file mode 100644 --- a/src/FRP/Helm/Time.hs +++ /dev/null @@ -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.Applicative -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)) diff --git a/src/FRP/Helm/Utilities.hs b/src/FRP/Helm/Utilities.hs deleted file mode 100644 --- a/src/FRP/Helm/Utilities.hs +++ /dev/null @@ -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 -(<|) = ($) diff --git a/src/FRP/Helm/Window.hs b/src/FRP/Helm/Window.hs deleted file mode 100644 --- a/src/FRP/Helm/Window.hs +++ /dev/null @@ -1,53 +0,0 @@ -{-| Contains signals that sample input from the game window. -} -module FRP.Helm.Window ( - -- * Dimensions - dimensions, - width, - height, - position -) where - -import Control.Applicative (pure) -import Foreign.Marshal.Alloc -import Foreign.Storable -import FRP.Elerea.Param hiding (Signal) -import FRP.Helm.Engine -import FRP.Helm.Sample -import FRP.Helm.Signal -import qualified Graphics.UI.SDL as SDL - -{-| 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 = alloca $ \wptr -> alloca $ \hptr -> do - SDL.getWindowSize (window engine) wptr hptr - - w <- peek wptr - h <- peek hptr - - 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 = alloca $ \xptr -> alloca $ \yptr -> do - SDL.getWindowPosition (window engine) xptr yptr - - x <- peek xptr - y <- peek yptr - - 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 diff --git a/src/Helm.hs b/src/Helm.hs new file mode 100644 --- /dev/null +++ b/src/Helm.hs @@ -0,0 +1,98 @@ +-- | Contains the main functions for interfacing with the engine. +-- This can be thought of Helm's own Prelude. +module Helm + ( + -- * Types + Cmd(..) + , Engine + , GameConfig(..) + , Graphics(..) + , Image + , Sub(..) + -- * Engine + , run + ) where + +import Control.Exception (finally) +import Control.Monad (foldM, void) +import Control.Monad.Trans.State.Lazy (evalStateT) +import FRP.Elerea.Param (start, embed) + +import Helm.Asset (Image) +import Helm.Engine (Cmd(..), Sub(..), GameConfig(..), Engine(..)) +import Helm.Graphics + +-- | A data structure describing a game's state (that is running under an engine). +data Game e m a = Game + { gameConfig :: GameConfig e m a -- ^ The configuration of the game, passed by a user. + , gameModel :: m -- ^ The current game model state. + , actionSmp :: e -> IO [a] -- ^ A feedable monad that returns actions from mapped subscriptions. + } + +-- | Prepare the game state from an engine and some game configuration. +prepare :: Engine e => e -> GameConfig e m a -> IO (Game e m a) +prepare engine config = do + {- The call to 'embed' here is a little bit hacky, but seems necessary + to get this working. This is because 'start' actually computes the signal + gen passed to it, and all of our signal gens try to fetch + the 'input' value within the top layer signal gen (rather than in the + contained signal). But we haven't sampled with the input value yet, so it'll + be undefined unless we 'embed'. -} + smp <- start $ embed (return engine) gen + + return Game + { gameConfig = config + , gameModel = fst initialFn + , actionSmp = smp + } + + where + GameConfig { initialFn, subscriptionsFn = Sub gen } = config + +-- | Runs a Helm game using an engine and some configuration for a game. +-- An engine should first be initialized separately to Helm, and then passed +-- to this function. Helm is written this way so that library users can +-- choose what backend engine they want to use (and hence Helm is engine-agnostic). +-- +-- The best engine to get started with is the SDL implementation of Helm, +-- which is currently bundled with the engine (although it will eventually be moved +-- to its own package). See 'Helm.Engine.SDL.startup' for how +-- to startup the SDL engine, which can then be run by this function. +run :: Engine e => e -> GameConfig e m a -> IO () +run engine config@GameConfig { initialFn } = + void $ (prepare engine config >>= stepInitial >>= step engine) `finally` cleanup engine + + where + Cmd monad = snd initialFn + stepInitial game@Game { gameModel } = do + actions <- evalStateT monad engine + model <- foldM (stepModel engine game) gameModel actions + + return game { gameModel = model } + +-- | Step the game state forward. +step :: Engine e => e -> Game e m a -> IO () +step engine game = do + mayhaps <- tick engine + + case mayhaps of + Nothing -> return () + + Just sunkEngine -> do + actions <- actionSmp sunkEngine + model <- foldM (stepModel sunkEngine game) gameModel actions + + render sunkEngine $ viewFn model + step sunkEngine $ game { gameModel = model } + + where + Game { actionSmp, gameModel, gameConfig = GameConfig { viewFn } } = game + +-- | Step the game model forward with a specific game action. +stepModel :: Engine e => e -> Game e m a -> m -> a -> IO m +stepModel engine game model action = + evalStateT monad engine >>= foldM (stepModel engine game) upModel + + where + Game { gameConfig = GameConfig { updateFn } } = game + (upModel, Cmd monad) = updateFn model action diff --git a/src/Helm/Asset.hs b/src/Helm/Asset.hs new file mode 100644 --- /dev/null +++ b/src/Helm/Asset.hs @@ -0,0 +1,18 @@ +-- | Contains the file asset types. +module Helm.Asset + ( + -- * Type Families + Image + ) where + +-- | Represents an image asset loaded by an engine instance. +-- +-- This is a type family, where the instance +-- types are the specific internal representations of an image +-- for an engine. Hence the e type variable here should refer +-- to an 'Engine' instance, but that is not strictly required. +-- +-- Having the image type be a family allows us to separate the internal +-- representation of the image assets for each engine from +-- the core Helm library. +data family Image e diff --git a/src/Helm/Cmd.hs b/src/Helm/Cmd.hs new file mode 100644 --- /dev/null +++ b/src/Helm/Cmd.hs @@ -0,0 +1,43 @@ +-- | Contains the command type and related utilities. +module Helm.Cmd ( + -- * Types + Cmd(..), + -- * Utilities + batch, + none, + execute +) where + +import Control.Monad.Trans.Class (lift) + +import Helm.Engine (Engine, Cmd(..)) + +-- | Combine a list of commands into a single one. +batch + :: Engine e + => [Cmd e a] -- ^ The list of commands to combine. + -> Cmd e a -- ^ The accumulated command. +batch cmds = Cmd $ do + lists <- mapM (\(Cmd m) -> m) cmds + + return $ concat lists + +-- | A command that does nothing. When returned in a Helm +-- game's update or initial functions, it will not produce +-- any game actions. +none :: Engine e => Cmd e a +none = Cmd $ return [] + +-- | Execute an IO monad and then map its result to a game action. +-- This can be used as a kind of 'liftIO', however to keep +-- things consistent with the rest of the library, you +-- must map the monad result a game action. +execute + :: Engine e + => IO b -- ^ The IO monad to execute. + -> (b -> a) -- ^ The function to map the monad result to an action. + -> Cmd e a -- ^ The mapped command. +execute monad f = Cmd $ do + result <- f <$> lift monad + + return [result] diff --git a/src/Helm/Color.hs b/src/Helm/Color.hs new file mode 100644 --- /dev/null +++ b/src/Helm/Color.hs @@ -0,0 +1,116 @@ +{-# LANGUAGE DeriveGeneric #-} +-- | Contains all data structures and functions for composing colors. +module Helm.Color ( + -- * Types + Color(..), + Gradient(..), + -- * Composing + rgba, + rgb, + hsva, + hsv, + blend, + complement, + linear, + radial +) where + +import GHC.Generics + +-- | Represents a color. It is represented interally as an RGBA +-- color, but the utility functions 'hsva', 'hsv', etc. can be used to convert +-- from other popular formats to this structure. +data Color = Color !Double !Double !Double !Double deriving (Show, Eq, Ord, Read, Generic) + +-- | Create an RGB color. +rgb :: Double -> Double -> Double -> Color +rgb r g b = rgba r g b 1 + +-- | Create an RGBA color. +rgba :: Double -> Double -> Double -> Double -> Color +rgba r g b a + | r < 0 || r > 1 || + g < 0 || g > 1 || + b < 0 || b > 1 || + a < 0 || a > 1 = error "Helm.Color.rgba: color components must be between 0 and 1" + | otherwise = Color r g b a + +-- | Blends colors together by averaging out their 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 + + where + black = rgb 0 0 0 + denom = fromIntegral $ length colors + +-- | Adds colors together. +blend' :: Color -> Color -> Color +blend' (Color r1 g1 b1 a1) (Color r2 g2 b2 a2) = Color (r1 + r2) (g1 + g2) (b1 + b2) (a1 + a2) + +-- | Calculate the complementary color for a color provided color. +-- This is useful for outlining a filled shape in a color clearly +-- distinguishable from the fill color. +complement :: Color -> Color +complement (Color r g b a) = hsva (fromIntegral ((round (h + 180) :: Int) `mod` 360)) (s / mx) mx a + where + mx = r `max` g `max` b + mn = r `min` g `min` b + s = mx - mn + h | mx == r = (g - b) / s * 60 + | mx == g = (b - r) / s * 60 + 120 + | mx == b = (r - g) / s * 60 + 240 + | otherwise = undefined + +-- | Create an RGBA color from HSVA values. +hsva :: Double -> Double -> Double -> Double -> Color +hsva h s v a + | h'' == 0 = rgba v t p a + | h'' == 1 = rgba q v p a + | h'' == 2 = rgba p v t a + | h'' == 3 = rgba p q v a + | h'' == 4 = rgba t p v a + | h'' == 5 = rgba v p q a + | otherwise = undefined + + where + h' = h / 60 + h'' = floor h' `mod` 6 :: Int + f = h' - fromIntegral h'' + p = v * (1 - s) + q = v * (1 - f * s) + t = v * (1 - (1 - f) * s) + +-- | Create an RGB color from HSV values. +hsv :: Double -> Double -> Double -> Color +hsv h s v = hsva h s v 1 + +-- | Represents a gradient. +-- +-- Helm supports radial and linear gradients. +-- Radial gradients are based on a set of colors transitioned +-- over certain radii in an arc pattern. Linear gradients are a set of colors +-- transitioned in a straight line. +data Gradient + = Linear !(Double, Double) !(Double, Double) ![(Double, Color)] -- ^ A linear gradient. + | Radial !(Double, Double) !Double !(Double, Double) !Double ![(Double, Color)] -- ^ A radial gradient. + deriving (Show, Eq, Ord, Read) + +-- | Creates a linear gradient. Takes a starting position, ending position and a list +-- of color stops (which are colors combined with a floating value between /0.0/ and /1.0/ +-- that describes at what step along the line between the starting position +-- and ending position the paired color should be transitioned to). +-- +-- > linear (0, 0) (100, 100) [(0, black), (1, white)] +-- +-- The above example creates a gradient that starts at /(0, 0)/ +-- and ends at /(100, 100)/. In other words, it's a diagonal gradient, transitioning from the top-left +-- to the bottom-right. The provided color stops result in the gradient transitioning from +-- black to white. +linear :: (Double, Double) -> (Double, Double) -> [(Double, Color)] -> Gradient +linear = Linear + +-- | Creates a radial gradient. Takes a starting position and radius, ending position and radius +-- and a list of color stops. See the document for 'linear' for more information on color stops. +radial :: (Double, Double) -> Double -> (Double, Double) -> Double -> [(Double, Color)] -> Gradient +radial = Radial diff --git a/src/Helm/Engine.hs b/src/Helm/Engine.hs new file mode 100644 --- /dev/null +++ b/src/Helm/Engine.hs @@ -0,0 +1,408 @@ +-- | Contains the core engine types and classes. +module Helm.Engine ( + -- * Typeclasses + Engine(..), + -- * Types + Cmd(..), + GameConfig(..), + Sub(..), + MouseButton(..), + Key(..) +) where + +import Control.Monad.Trans.State (StateT) + +import FRP.Elerea.Param (SignalGen, Signal) +import Linear.V2 (V2) + +import Helm.Graphics (Graphics) + +-- | Represents a backend engine that can run a Helm game. +-- +-- Helm separates the logic for running a game from the actual interaction with the user - +-- window management, event management (key presses, mouse presses, etc.) are all handled by a specific instance +-- of the engine typeclass. Meanwhile, the game loop and other core features are handled independently +-- by the Helm library itself. +class Engine e where + -- | Renders a graphics element to the engine's game window. + render :: e -> Graphics e -> IO () + + -- | Ticks (or steps) the engine forward. Generally, an engine should use this method to + -- gather any new input events from the underlying engine and sink them into the signals it provides below. + -- Depending on the implementation of the engine, it might be necessary to do other things here too. + tick :: e -> IO (Maybe e) + + -- | Cleans up all resources loaded by the engine. This will be run when the engine has stopped execution, + -- hence it should do everything required to free any resources allocated by the engine. + cleanup :: e -> IO () + + -- | Get the game window size. + windowSize :: e -> IO (V2 Int) + + -- | Get the current game running time. + runningTime :: e -> IO Double + + -- | The mouse move signal, with events provided by the engine. + mouseMoveSignal :: e -> SignalGen e (Signal [V2 Int]) + + -- | The mouse down signal, with events provided by the engine. + mouseDownSignal :: e -> SignalGen e (Signal [(MouseButton, V2 Int)]) + + -- | The mouse up signal, with events provided by the engine. + mouseUpSignal :: e -> SignalGen e (Signal [(MouseButton, V2 Int)]) + + -- | The mouse click signal, with events provided by the engine. + mouseClickSignal :: e -> SignalGen e (Signal [(MouseButton, V2 Int)]) + + -- | The keyboard down signal, with events provided by the engine. + keyboardDownSignal :: e -> SignalGen e (Signal [Key]) + + -- | The keyboard up signal, with events provided by the engine. + keyboardUpSignal :: e -> SignalGen e (Signal [Key]) + + -- | The keyboard press signal, with events provided by the engine. + keyboardPressSignal :: e -> SignalGen e (Signal [Key]) + + -- | The window resize signal, with events provided by the engine. + windowResizeSignal :: e -> SignalGen e (Signal [V2 Int]) + +-- | Represents a subscription to a stream of events captured from a user's interaction with the engine. +-- A subscription is best thought of as a collection of events over time - which is the nature of +-- functional reactive programming (the paradigm that Helm bases it's concepts on). +-- Although Helm uses a departed version of the traditional FRP paradigm, it still follows the +-- concept closely and hence an understanding of FRP will allow you to understnad the library easily. +-- +-- Functions throughout the Helm library that return a subscription will first let you map the data +-- related to the event you're subscribing to into another form (specifically, a game action). +-- These game actions are then sent to the update function of your game, i.e. the mapped +-- subscription specifies exactly how game events will interact with your game state. +-- +-- Here the type variable e is an instance of the 'Engine' typeclass +-- and the variable a is the game action data type used by your game. +newtype Sub e a = Sub (SignalGen e (Signal [a])) + +-- | Represents an IO-like monad with knowledge about the state of the game engine. Each command +-- contains a collection of game actions that will be applied to your game's update function to update +-- the game state. This is similar to a subscription in a way, with the difference being that +-- a command does not change over time, but rather is a lazy monad and hence contains a value that +-- from the time of the execution. A good example of the usage of a command vs. a subscription is the game +-- window size - a command would allow you to map the current window size into an action, whereas +-- a subscription would let you subscribe to when the window is resized and then map that event into +-- a game action. +-- +-- Just like a subscription, any function that returns a command in the Helm library will +-- first let you map from the original contained value to a game action. It's important +-- to note that commands are **evaluated on the main-thread** - which means they can +-- block the rendering process. *Don't execute long-running monads under commands!* +-- +-- Here the type variable e is an instance of the 'Engine' typeclass +-- and the variable a is the game action data type used by your game. +newtype Cmd e a = Cmd (StateT e IO [a]) + +-- | Represents the configuration for a Helm game. +-- +-- The type variable e refers to an instance of the 'Engine' class, +-- m refers to a game model type and a refers to a game action type. +data GameConfig e m a = GameConfig { + -- | Called when the game starts up. The first value in the tuple + -- is the initial game model state and then the second value is an optional + -- command to be run. The command allows you to execute some monads + -- during game startup and build up some game actions before the game begins + -- rendering. A good example would be loading a game configuration file, + -- parsing the file contents and then mapping the parsed contents + -- to relevant game actions. + -- + -- If no initial command is required, simply pass 'Cmd.none' + -- for the second tuple value. Alternatively, if there are a number of commands + -- to run, call 'Cmd.batch' to combine them into one. + initialFn :: (m, Cmd e a), + + -- | Called whenever a game action is mapped from a command or subscription. + -- This is where the actual implementation of a Helm game is done. + -- The function is given a game model and the mapped action type, + -- and should produce the new game model state based off of the action. + -- + -- The first tuple value is the new model state, and then the second + -- is a command that can be run to produce more game actions. + -- By having this command returnable here, you can run additional IO logic + -- based off the game action, and produce more game actions from the result. + -- + -- Be very careful with what commands you run in the game update function - most importantly, + -- don't execute long-winding commands or it will block the rendering process!. + -- Helm will try to intelligently queue recursive commands to prevent blocking rendering. + -- However, having a game action that returns a specific command from the update function, + -- which in turn is executed and returns that same game action (which will then in turn return the same command, + -- and so on) is not recommend. The best way to return commands from the update function is to + -- to hide them behind conditionals based off your game state, so that they're not run every update function. + updateFn :: m -> a -> (m, Cmd e a), + + -- | The subscriptions for a game. All the input sources required + -- to make the game work should be subscribed to and mapped to the relevant + -- game action type variant. + -- + -- If no subscriptions are required (i.e. no user input is required), + -- pass 'Sub.none'. Alternatively, if multiple subscriptions are required + -- use 'Sub.batch' to combine them. + subscriptionsFn :: Sub e a, + + -- | Called when the engine is ready to render the game. + -- The function is given the current state of the game model + -- and should produce a graphics value to be rendered to the + -- screen. + -- + -- Do not rely on this function being called every game tick - + -- the engine will figure out whether it needs to be called + -- based off window exposure and whether or not the game model + -- has changed since the last render. + viewFn :: m -> Graphics e +} + +-- | Represents a mouse button that can be pressed on a mouse. +data MouseButton + = LeftButton + | MiddleButton + | RightButton + | X1Button + | X2Button + | UnknownButton + deriving (Eq, Ord, Read, Show) + +-- | Represents a key that can be pressed on the keyboard. +data Key + = ReturnKey + | EscapeKey + | BackspaceKey + | TabKey + | SpaceKey + | ExclaimKey + | QuoteDblKey + | HashKey + | PercentKey + | DollarKey + | AmpersandKey + | QuoteKey + | LeftParenKey + | RightParenKey + | AsteriskKey + | PlusKey + | CommaKey + | MinusKey + | PeriodKey + | SlashKey + | Number0Key + | Number1Key + | Number2Key + | Number3Key + | Number4Key + | Number5Key + | Number6Key + | Number7Key + | Number8Key + | Number9Key + | ColonKey + | SemicolonKey + | LessKey + | EqualsKey + | GreaterKey + | QuestionKey + | AtKey + | LeftBracketKey + | BackslashKey + | RightBracketKey + | CaretKey + | UnderscoreKey + | BackquoteKey + | AKey + | BKey + | CKey + | DKey + | EKey + | FKey + | GKey + | HKey + | IKey + | JKey + | KKey + | LKey + | MKey + | NKey + | OKey + | PKey + | QKey + | RKey + | SKey + | TKey + | UKey + | VKey + | WKey + | XKey + | YKey + | ZKey + | CapsLockKey + | F1Key + | F2Key + | F3Key + | F4Key + | F5Key + | F6Key + | F7Key + | F8Key + | F9Key + | F10Key + | F11Key + | F12Key + | PrintScreenKey + | ScrollLockKey + | PauseKey + | InsertKey + | HomeKey + | PageUpKey + | DeleteKey + | EndKey + | PageDownKey + | RightKey + | LeftKey + | DownKey + | UpKey + | NumLockClearKey + | KeypadDivideKey + | KeypadMultiplyKey + | KeypadMinusKey + | KeypadPlusKey + | KeypadEnterKey + | KeypadNumber1Key + | KeypadNumber2Key + | KeypadNumber3Key + | KeypadNumber4Key + | KeypadNumber5Key + | KeypadNumber6Key + | KeypadNumber7Key + | KeypadNumber8Key + | KeypadNumber9Key + | KeypadNumber0Key + | KeypadPeriodKey + | ApplicationKey + | PowerKey + | KeypadEqualsKey + | F13Key + | F14Key + | F15Key + | F16Key + | F17Key + | F18Key + | F19Key + | F20Key + | F21Key + | F22Key + | F23Key + | F24Key + | ExecuteKey + | HelpKey + | MenuKey + | SelectKey + | StopKey + | AgainKey + | UndoKey + | CutKey + | CopyKey + | PasteKey + | FindKey + | MuteKey + | VolumeUpKey + | VolumeDownKey + | KeypadCommaKey + | KeypadEqualsAS400Key + | AltEraseKey + | SysReqKey + | CancelKey + | ClearKey + | PriorKey + | Return2Key + | SeparatorKey + | OutKey + | OperKey + | ClearAgainKey + | CrSelKey + | ExSelKey + | Keypad00Key + | Keypad000Key + | ThousandsSeparatorKey + | DecimalSeparatorKey + | CurrencyUnitKey + | CurrencySubunitKey + | KeypadLeftParenKey + | KeypadRightParenKey + | KeypadLeftBraceKey + | KeypadRightBraceKey + | KeypadTabKey + | KeypadBackspaceKey + | KeypadAKey + | KeypadBKey + | KeypadCKey + | KeypadDKey + | KeypadEKey + | KeypadFKey + | KeypadXorKey + | KeypadPowerKey + | KeypadPercentKey + | KeypadLessKey + | KeypadGreaterKey + | KeypadAmpersandKey + | KeypadDblAmpersandKey + | KeypadVerticalBarKey + | KeypadDblVerticalBarKey + | KeypadColonKey + | KeypadHashKey + | KeypadSpaceKey + | KeypadAtKey + | KeypadExclamKey + | KeypadMemStoreKey + | KeypadMemRecallKey + | KeypadMemClearKey + | KeypadMemAddKey + | KeypadMemSubtractKey + | KeypadMemMultiplyKey + | KeypadMemDivideKey + | KeypadPlusMinusKey + | KeypadClearKey + | KeypadClearEntryKey + | KeypadBinaryKey + | KeypadOctalKey + | KeypadDecimalKey + | KeypadHexadecimalKey + | LeftCtrlKey + | LeftShiftKey + | LeftAltKey + | LeftGUIKey + | RightCtrlKey + | RightShiftKey + | RightAltKey + | RightGUIKey + | ModeKey + | AudioNextKey + | AudioPrevKey + | AudioStopKey + | AudioPlayKey + | AudioMuteKey + | MediaSelectKey + | WWWKey + | MailKey + | CalculatorKey + | ComputerKey + | ACSearchKey + | ACHomeKey + | ACBackKey + | ACForwardKey + | ACStopKey + | ACRefreshKey + | ACBookmarksKey + | BrightnessDownKey + | BrightnessUpKey + | DisplaySwitchKey + | KeyboardIllumToggleKey + | KeyboardIllumDownKey + | KeyboardIllumUpKey + | EjectKey + | SleepKey + | UnknownKey + deriving (Eq, Ord, Read, Show) diff --git a/src/Helm/Engine/SDL.hs b/src/Helm/Engine/SDL.hs new file mode 100644 --- /dev/null +++ b/src/Helm/Engine/SDL.hs @@ -0,0 +1,248 @@ +{-# LANGUAGE TypeFamilies #-} +-- | Contains the SDL engine implementation of Helm. +module Helm.Engine.SDL + ( + -- * Types + SDLEngine + , SDLEngineConfig(..) + -- * Startup + , defaultConfig + , startup + , startupWith + -- * Asset Loading + , withImage + ) where + +import Control.Monad (when) +import qualified Data.Text as T + +import FRP.Elerea.Param +import Linear.Affine (Point(P)) +import Linear.Metric (distance) +import Linear.V2 (V2(V2)) + +import qualified SDL +import qualified SDL.Event as Event +import qualified SDL.Init as Init +import SDL.Input.Keyboard (Keysym(..)) +import qualified SDL.Time as Time +import qualified SDL.Video as Video +import SDL.Video (WindowConfig(..)) +import qualified SDL.Video.Renderer as Renderer + +import Helm.Engine (Engine(..)) +import Helm.Engine.SDL.Asset (withImage) +import Helm.Engine.SDL.Engine (SDLEngine(..), SDLEngineConfig(..)) +import qualified Helm.Engine.SDL.Graphics2D as Graphics2D +import Helm.Engine.SDL.Keyboard (mapKey) +import Helm.Engine.SDL.Mouse (mapMouseButton) +import Helm.Graphics (Graphics(..)) +import Helm.Graphics2D (Collage) + +-- FIXME: Find a nice and easy way to have this instance with the SDLEngine type. +-- Can't avoid the orphan instance without dependency hell right now. +instance Engine SDLEngine where + render engine (Graphics2D coll) = render2d engine coll + cleanup SDLEngine { window, renderer, texture } = do + Renderer.destroyTexture texture + Video.destroyWindow window + Video.destroyRenderer renderer + Init.quit + + tick engine = do + mayhaps <- Event.pumpEvents >> Event.pollEvent + + case mayhaps of + -- Handle the quit event exclusively first to simplify our code + Just Event.Event { eventPayload = Event.QuitEvent } -> + return Nothing + + Just Event.Event { .. } -> + sinkEvent engine eventPayload >>= tick + + Nothing -> return $ Just engine + + mouseMoveSignal = mouseMoveEventSignal + mouseDownSignal = mouseDownEventSignal + mouseUpSignal = mouseUpEventSignal + mouseClickSignal = mouseClickEventSignal + + keyboardDownSignal = keyboardDownEventSignal + keyboardUpSignal = keyboardUpEventSignal + keyboardPressSignal = keyboardPressEventSignal + + windowResizeSignal = windowResizeEventSignal + + runningTime _ = fromIntegral <$> Time.ticks + windowSize SDLEngine { window } = fmap (fmap fromIntegral) . SDL.get $ Video.windowSize window + +-- | The default configuration for the engine. You should change the values where necessary. +defaultConfig :: SDLEngineConfig +defaultConfig = SDLEngineConfig + { windowDimensions = V2 800 600 + , windowIsFullscreen = False + , windowIsResizable = True + , windowTitle = "Helm" + } + +-- | Initialize a new engine with default configuration. The engine can then be run later using 'run'. +startup :: IO SDLEngine +startup = startupWith defaultConfig + +-- | Prepare a texture for streamed rendering based of a window size. +prepTexture :: V2 Int -> Video.Renderer -> IO Renderer.Texture +prepTexture dims renderer = + Renderer.createTexture renderer mode access $ fromIntegral <$> dims + + where + mode = Renderer.ARGB8888 + access = Renderer.TextureAccessStreaming + +-- | Initialize a new engine with some configration, ready to be 'run'. +startupWith :: SDLEngineConfig -> IO SDLEngine +startupWith config@SDLEngineConfig { .. } = do + Init.initializeAll + + window <- Video.createWindow (T.pack windowTitle) windowConfig + renderer <- Video.createRenderer window (-1) rendererConfig + texture <- prepTexture windowDimensions renderer + + mouseMoveEvent <- externalMulti + mouseDownEvent <- externalMulti + mouseUpEvent <- externalMulti + mouseClickEvent <- externalMulti + keyboardDownEvent <- externalMulti + keyboardUpEvent <- externalMulti + keyboardPressEvent <- externalMulti + windowResizeEvent <- externalMulti + + Video.showWindow window + + return SDLEngine + { window = window + , renderer = renderer + , texture = texture + , engineConfig = config + , lastMousePress = Nothing + + , mouseMoveEventSignal = fst mouseMoveEvent + , mouseMoveEventSink = snd mouseMoveEvent + , mouseDownEventSignal = fst mouseDownEvent + , mouseDownEventSink = snd mouseDownEvent + , mouseUpEventSignal = fst mouseUpEvent + , mouseUpEventSink = snd mouseUpEvent + , mouseClickEventSignal = fst mouseClickEvent + , mouseClickEventSink = snd mouseClickEvent + + , keyboardDownEventSignal = fst keyboardDownEvent + , keyboardDownEventSink = snd keyboardDownEvent + , keyboardUpEventSignal = fst keyboardUpEvent + , keyboardUpEventSink = snd keyboardUpEvent + , keyboardPressEventSignal = fst keyboardPressEvent + , keyboardPressEventSink = snd keyboardPressEvent + + , windowResizeEventSignal = fst windowResizeEvent + , windowResizeEventSink = snd windowResizeEvent + } + where + rendererConfig = Video.RendererConfig Video.AcceleratedVSyncRenderer False + windowConfig = Video.defaultWindow + { windowInitialSize = fromIntegral <$> windowDimensions + , windowMode = if windowIsFullscreen + then Video.Fullscreen + else Video.Windowed + , windowResizable = windowIsResizable + } + +-- | Renders a 2D element to the engine screen. +render2d :: SDLEngine -> Collage SDLEngine -> IO () +render2d SDLEngine { window, renderer, texture } element = do + dims <- SDL.get $ Video.windowSize window + + Graphics2D.render texture dims element + Renderer.clear renderer + Renderer.copy renderer texture Nothing Nothing + Renderer.present renderer + +-- | Turns a point containing a vector into a regular vector. +depoint :: Point f a -> f a +depoint (P x) = x + +-- | Sink an SDL event into the Elerea sinks initialized at startup of the SDL engine. +-- These sinks then provide the data for the Elerea signals, which will be in +-- turn will provide the Helm subscriptions with events. +sinkEvent :: SDLEngine -> Event.EventPayload -> IO SDLEngine +sinkEvent engine (Event.WindowResizedEvent Event.WindowResizedEventData { .. }) = do + windowResizeEventSink engine dims + Renderer.destroyTexture texture + + resized <- prepTexture dims renderer + + return engine { texture = resized } + + where + dims = fromIntegral <$> windowResizedEventSize + SDLEngine { texture, renderer } = engine + +sinkEvent engine (Event.MouseMotionEvent Event.MouseMotionEventData { .. }) = do + mouseMoveEventSink engine $ fromIntegral <$> depoint mouseMotionEventPos + + return engine + +sinkEvent engine (Event.KeyboardEvent Event.KeyboardEventData { .. }) = + case keyboardEventKeyMotion of + Event.Pressed -> do + keyboardDownEventSink engine key + + if keyboardEventRepeat + then keyboardPressEventSink engine key >> return engine + else return engine + + Event.Released -> do + keyboardUpEventSink engine key + keyboardPressEventSink engine key + + return engine + + where + Keysym { .. } = keyboardEventKeysym + key = mapKey keysymKeycode + +sinkEvent engine (Event.MouseButtonEvent Event.MouseButtonEventData { .. }) = + case mouseButtonEventMotion of + Event.Pressed -> do + ticks <- Time.ticks + mouseDownEventSink engine tup + + return engine { lastMousePress = Just (ticks, dubPos) } + + Event.Released -> do + mouseUpEventSink engine tup + + -- Weirdly enough, SDL provides a value that says how many clicks there + -- were, but this value is always set to one even if it's just a regular + -- mouse up event. Note that here we're defining a click as a mouse up + -- event being in a very close proximity to a previous mouse down event. + -- We manually calculate whether this was a click or not. + case lastMousePress of + Just (lastTicks, lastPos) -> do + ticks <- Time.ticks + + -- Check that it's a expected amount of time for a click and that the mouse + -- has basically stayed in place + when (distance dubPos lastPos <= clickRadius && ticks - lastTicks < clickMs) + (mouseClickEventSink engine tup) + + Nothing -> return () + + return engine + + where + SDLEngine { lastMousePress } = engine + clickMs = 500 -- How long between mouse down/up to recognise clicks + clickRadius = 3 -- The pixel radius to be considered a click. + pos = depoint mouseButtonEventPos + dubPos = fromIntegral <$> pos + tup = (mapMouseButton mouseButtonEventButton, fromIntegral <$> pos) + +sinkEvent engine _ = return engine diff --git a/src/Helm/Engine/SDL/Asset.hs b/src/Helm/Engine/SDL/Asset.hs new file mode 100644 --- /dev/null +++ b/src/Helm/Engine/SDL/Asset.hs @@ -0,0 +1,41 @@ +-- | Contains the SDL asset types. +module Helm.Engine.SDL.Asset + ( + -- * Types + Image(..) + -- * Loading + , withImage + ) where + +import qualified Graphics.Rendering.Cairo as Cairo +import Linear.V2 (V2(..)) + +import Helm.Asset (Image) +import Helm.Engine.SDL.Engine (SDLEngine) + +-- | Represents an 'Image' for the SDL engine. +data instance Image SDLEngine = SDLImage + { cairoSurface :: Cairo.Surface -- ^ The Cairo surface for the image. + , imageDims :: V2 Int -- ^ The image dimensions of the image (when it was loaded). + } + +-- | Load an image asset using the SDL engine and do +-- something with it. The image will be cleaned up +-- once the provided monad completes. +-- +-- Currently, the only supported image file format is PNG. +-- +-- The expected usage would be to use 'withImage' +-- for each image you need to load before +-- running the engine, and then use the images with +-- graphics. Once the engine stops running, the image +-- will then be automatically cleaned up. +withImage :: SDLEngine -> FilePath -> (Image SDLEngine -> IO a) -> IO a +withImage _ path f = Cairo.withImageSurfaceFromPNG path $ \surface -> do + width <- Cairo.imageSurfaceGetWidth surface + height <- Cairo.imageSurfaceGetHeight surface + + f SDLImage + { cairoSurface = surface + , imageDims = V2 width height + } diff --git a/src/Helm/Engine/SDL/Engine.hs b/src/Helm/Engine/SDL/Engine.hs new file mode 100644 --- /dev/null +++ b/src/Helm/Engine/SDL/Engine.hs @@ -0,0 +1,53 @@ +-- | Contains the SDL engine types. +module Helm.Engine.SDL.Engine + ( + -- * Types + SDLEngine(..) + , SDLEngineConfig(..) + ) where + +import Data.Word (Word32) + +import FRP.Elerea.Param (Signal, SignalGen) +import Linear.V2 (V2) +import qualified SDL.Video as Video +import qualified SDL.Video.Renderer as Renderer + +import Helm.Engine (MouseButton, Key) + +-- | Represents the configuration to run the SDL engine with. +-- Use 'defaultConfig' and then only change the necessary fields. +data SDLEngineConfig = SDLEngineConfig + { windowDimensions :: V2 Int + , windowIsFullscreen :: !Bool + , windowIsResizable :: !Bool + , windowTitle :: !String + } + +-- | Represents the SDL engine's internal state. +data SDLEngine = SDLEngine + { window :: Video.Window + , renderer :: Video.Renderer + , texture :: !Renderer.Texture + , engineConfig :: SDLEngineConfig + , lastMousePress :: Maybe (Word32, V2 Double) + + , mouseMoveEventSignal :: SignalGen SDLEngine (Signal [V2 Int]) + , mouseMoveEventSink :: V2 Int -> IO () + , mouseDownEventSignal :: SignalGen SDLEngine (Signal [(MouseButton, V2 Int)]) + , mouseDownEventSink :: (MouseButton, V2 Int) -> IO () + , mouseUpEventSignal :: SignalGen SDLEngine (Signal [(MouseButton, V2 Int)]) + , mouseUpEventSink :: (MouseButton, V2 Int) -> IO () + , mouseClickEventSignal :: SignalGen SDLEngine (Signal [(MouseButton, V2 Int)]) + , mouseClickEventSink :: (MouseButton, V2 Int) -> IO () + + , keyboardDownEventSignal :: SignalGen SDLEngine (Signal [Key]) + , keyboardDownEventSink :: Key -> IO () + , keyboardUpEventSignal :: SignalGen SDLEngine (Signal [Key]) + , keyboardUpEventSink :: Key -> IO () + , keyboardPressEventSignal :: SignalGen SDLEngine (Signal [Key]) + , keyboardPressEventSink :: Key -> IO () + + , windowResizeEventSignal :: SignalGen SDLEngine (Signal [V2 Int]) + , windowResizeEventSink :: V2 Int -> IO () + } diff --git a/src/Helm/Engine/SDL/Graphics2D.hs b/src/Helm/Engine/SDL/Graphics2D.hs new file mode 100644 --- /dev/null +++ b/src/Helm/Engine/SDL/Graphics2D.hs @@ -0,0 +1,214 @@ +-- | Contains the SDL implementation 2D graphics rendering implementation. +-- +-- The SDL engine uses Cairo for its 2D vector graphics, which is hardware accelerated +-- and generally pretty fast. +module Helm.Engine.SDL.Graphics2D (render) where + +import Data.Foldable (forM_) +import Foreign.C.Types (CInt) +import Foreign.Ptr (castPtr) + +import qualified Data.Text as T +import qualified Graphics.Rendering.Cairo as Cairo +import qualified Graphics.Rendering.Pango as Pango +import Graphics.Rendering.Cairo.Matrix (Matrix(..)) +import Linear.V2 (V2(V2)) +import Linear.V3 (V3(V3)) +import qualified SDL.Video.Renderer as Renderer + +import Helm.Color (Color(..), Gradient(..)) +import Helm.Engine.SDL.Asset (Image(..)) +import Helm.Engine.SDL.Engine (SDLEngine) +import Helm.Graphics2D +import Helm.Graphics2D.Text + +-- | Render a 2D element to an SDL texture (with a width and height). +render :: Renderer.Texture -> V2 CInt -> Collage SDLEngine -> IO () +render tex (V2 w h) coll = do + (pixels, pitch) <- Renderer.lockTexture tex Nothing + + Cairo.withImageSurfaceForData (castPtr pixels) Cairo.FormatARGB32 (fromIntegral w) (fromIntegral h) (fromIntegral pitch) $ \surface -> + Cairo.renderWith surface $ do + Cairo.setSourceRGB 0 0 0 + Cairo.rectangle 0 0 (fromIntegral w) (fromIntegral h) + Cairo.fill + + renderCollage coll + + Renderer.unlockTexture tex + +-- | Render a collage (a group of forms with context). +renderCollage :: Collage SDLEngine -> Cairo.Render () +renderCollage Collage { .. } = do + Cairo.save + + forM_ collageDims $ \(V2 w h) -> do + Cairo.rectangle 0 0 w h + Cairo.clip + + forM_ collageCenter $ \(V2 x y) -> Cairo.translate x y + mapM_ renderForm collageForms + + Cairo.restore + +-- | Map a 'FontWeight' to a Pango font weight. +mapFontWeight :: FontWeight -> Pango.Weight +mapFontWeight weight = case weight of + LightWeight -> Pango.WeightLight + NormalWeight -> Pango.WeightNormal + BoldWeight -> Pango.WeightBold + +-- | Map a 'FontStyle' variant to a Pango font style. +mapFontStyle :: FontStyle -> Pango.FontStyle +mapFontStyle style = case style of + NormalStyle -> Pango.StyleNormal + ObliqueStyle -> Pango.StyleOblique + ItalicStyle -> Pango.StyleItalic + +-- | Setup a transformation state, render something with it, and then restore the old state. +withTransform + :: Double -- ^ The x and y scale factor of the state. + -> Double -- ^ The theta rotation of the state, in radians. + -> Double -- ^ The x translation value for the state. + -> Double -- ^ The y translation value for the state. + -> Cairo.Render () -- ^ The render monad to run with the transformation state. + -> Cairo.Render () -- ^ The final render monad. +withTransform s t x y f = do + Cairo.save + Cairo.scale s s + Cairo.translate x y + Cairo.rotate t + f + Cairo.restore + +-- | Set the Cairo line cap from a 'LineCap'. +setLineCap :: LineCap -> Cairo.Render () +setLineCap cap = case cap of + FlatCap -> Cairo.setLineCap Cairo.LineCapButt + RoundCap -> Cairo.setLineCap Cairo.LineCapRound + PaddedCap -> Cairo.setLineCap Cairo.LineCapSquare + +-- | Set the Cairo line join from a 'LineJoin'. +setLineJoin :: LineJoin -> Cairo.Render () +setLineJoin join = case join of + SmoothJoin -> Cairo.setLineJoin Cairo.LineJoinRound + ClippedJoin -> Cairo.setLineJoin Cairo.LineJoinBevel + SharpJoin lim -> do Cairo.setLineJoin Cairo.LineJoinMiter + Cairo.setMiterLimit lim + +-- | Set up all the necessary settings with Cairo +-- to render with a line style (and then stroke the line). Assumes +-- that all drawing paths have already been setup before being called. +setLineStyle :: LineStyle -> Cairo.Render () +setLineStyle LineStyle { lineColor = Color r g b a, .. } = do + Cairo.setSourceRGBA r g b a + setLineCap lineCap + setLineJoin lineJoin + Cairo.setLineWidth lineWidth + Cairo.setDash lineDashing lineDashOffset + Cairo.stroke + +-- | Set up all the necessary settings with Cairo +-- to render with a fill style (and then fill the line). Assumes +-- that all drawing paths have already been setup before being called. +setFillStyle :: FillStyle SDLEngine -> Cairo.Render () +setFillStyle (Solid (Color r g b a)) = do + Cairo.setSourceRGBA r g b a + Cairo.fill + +setFillStyle (Texture SDLImage { cairoSurface }) = do + Cairo.setSourceSurface cairoSurface 0 0 + Cairo.getSource >>= flip Cairo.patternSetExtend Cairo.ExtendRepeat + Cairo.fill + +setFillStyle (Gradient (Linear (sx, sy) (ex, ey) points)) = + Cairo.withLinearPattern sx sy ex ey $ \ptn -> + setGradientFill ptn points + +setFillStyle (Gradient (Radial (sx, sy) sr (ex, ey) er points)) = + Cairo.withRadialPattern sx sy sr ex ey er $ \ptn -> + setGradientFill ptn points + +-- | Add color stops to a pattern and then fill it. +setGradientFill :: Cairo.Pattern -> [(Double, Color)] -> Cairo.Render () +setGradientFill ptn points = do + Cairo.setSource ptn + mapM_ (\(o, Color r g b a) -> Cairo.patternAddColorStopRGBA ptn o r g b a) points + Cairo.fill + +-- | Render a form. +renderForm :: Form SDLEngine -> Cairo.Render () +renderForm Form { formPos = V2 x y, .. } = withTransform formScale formTheta x y $ do + Cairo.save + + case formStyle of + PathForm style (Path (~ps @ (V2 hx hy : _))) -> do + Cairo.newPath + Cairo.moveTo hx hy + mapM_ (\(V2 lx ly) -> Cairo.lineTo lx ly) ps + setLineStyle style + + ShapeForm style shape -> do + Cairo.newPath + + case shape of + PolygonShape (Path (~ps @ (V2 hx hy : _))) -> do + Cairo.moveTo hx hy + mapM_ (\(V2 lx ly) -> Cairo.lineTo lx ly) ps + + RectangleShape (V2 w h) -> + Cairo.rectangle (-w / 2) (-h / 2) w h + + ArcShape (V2 cx cy) a1 a2 r (V2 sx sy) -> do + Cairo.scale sx sy + Cairo.arc cx cy r a1 a2 + + case style of + OutlinedShape ls -> setLineStyle ls + FilledShape fs -> setFillStyle fs + + TextForm Text { textColor = Color r g b a, .. } -> do + layout <- Pango.createLayout textString + + Cairo.liftIO $ Pango.layoutSetAttributes layout + [ Pango.AttrFamily { paStart = i, paEnd = j, paFamily = T.pack textTypeface } + , Pango.AttrWeight { paStart = i, paEnd = j, paWeight = mapFontWeight textWeight } + , Pango.AttrStyle { paStart = i, paEnd = j, paStyle = mapFontStyle textStyle } + , Pango.AttrSize { paStart = i, paEnd = j, paSize = textHeight } + ] + + Pango.PangoRectangle tx ty w h <- fmap snd $ Cairo.liftIO $ Pango.layoutGetExtents layout + + Cairo.translate ((-w / 2) - tx) ((-h / 2) - ty) + Cairo.setSourceRGBA r g b a + Pango.showLayout layout + + where + i = 0 + j = length textString + + ImageForm SDLImage { imageDims = V2 w h, .. } (V2 sx sy) (V2 sw sh) stretch -> do + Cairo.translate (-sx) (-sy) + + if stretch then + Cairo.scale (sw / fromIntegral w) + (sh / fromIntegral h) + else + Cairo.scale 1 1 + + Cairo.setSourceSurface cairoSurface 0 0 + Cairo.translate sx sy + Cairo.rectangle 0 0 sw sh + + if stretch then + Cairo.paint + else + Cairo.fill + + GroupForm (Transform (V3 (V3 a b lx) (V3 c d ly) _)) forms -> do + Cairo.transform $ Matrix a b c d lx ly + mapM_ renderForm forms + + CollageForm coll -> renderCollage coll + + Cairo.restore diff --git a/src/Helm/Engine/SDL/Keyboard.hs b/src/Helm/Engine/SDL/Keyboard.hs new file mode 100644 --- /dev/null +++ b/src/Helm/Engine/SDL/Keyboard.hs @@ -0,0 +1,245 @@ +-- | Contains the SDL keyboard mappings. +module Helm.Engine.SDL.Keyboard (mapKey) where + +import qualified SDL.Input.Keyboard.Codes as Codes + +import Helm.Engine (Key(..)) + +-- | Map an SDL keycode to a Helm key. +mapKey :: Codes.Keycode -> Key +mapKey Codes.KeycodeReturn = ReturnKey +mapKey Codes.KeycodeEscape = EscapeKey +mapKey Codes.KeycodeBackspace = BackspaceKey +mapKey Codes.KeycodeTab = TabKey +mapKey Codes.KeycodeSpace = SpaceKey +mapKey Codes.KeycodeExclaim = ExclaimKey +mapKey Codes.KeycodeQuoteDbl = QuoteDblKey +mapKey Codes.KeycodeHash = HashKey +mapKey Codes.KeycodePercent = PercentKey +mapKey Codes.KeycodeDollar = DollarKey +mapKey Codes.KeycodeAmpersand = AmpersandKey +mapKey Codes.KeycodeQuote = QuoteKey +mapKey Codes.KeycodeLeftParen = LeftParenKey +mapKey Codes.KeycodeRightParen = RightParenKey +mapKey Codes.KeycodeAsterisk = AsteriskKey +mapKey Codes.KeycodePlus = PlusKey +mapKey Codes.KeycodeComma = CommaKey +mapKey Codes.KeycodeMinus = MinusKey +mapKey Codes.KeycodePeriod = PeriodKey +mapKey Codes.KeycodeSlash = SlashKey +mapKey Codes.Keycode0 = Number0Key +mapKey Codes.Keycode1 = Number1Key +mapKey Codes.Keycode2 = Number2Key +mapKey Codes.Keycode3 = Number3Key +mapKey Codes.Keycode4 = Number4Key +mapKey Codes.Keycode5 = Number5Key +mapKey Codes.Keycode6 = Number6Key +mapKey Codes.Keycode7 = Number7Key +mapKey Codes.Keycode8 = Number8Key +mapKey Codes.Keycode9 = Number9Key +mapKey Codes.KeycodeColon = ColonKey +mapKey Codes.KeycodeSemicolon = SemicolonKey +mapKey Codes.KeycodeLess = LessKey +mapKey Codes.KeycodeEquals = EqualsKey +mapKey Codes.KeycodeGreater = GreaterKey +mapKey Codes.KeycodeQuestion = QuestionKey +mapKey Codes.KeycodeAt = AtKey +mapKey Codes.KeycodeLeftBracket = LeftKey +mapKey Codes.KeycodeBackslash = BackslashKey +mapKey Codes.KeycodeRightBracket = RightBracketKey +mapKey Codes.KeycodeCaret = CaretKey +mapKey Codes.KeycodeUnderscore = UnderscoreKey +mapKey Codes.KeycodeBackquote = BackquoteKey +mapKey Codes.KeycodeA = AKey +mapKey Codes.KeycodeB = BKey +mapKey Codes.KeycodeC = CKey +mapKey Codes.KeycodeD = DKey +mapKey Codes.KeycodeE = EKey +mapKey Codes.KeycodeF = FKey +mapKey Codes.KeycodeG = GKey +mapKey Codes.KeycodeH = HKey +mapKey Codes.KeycodeI = IKey +mapKey Codes.KeycodeJ = JKey +mapKey Codes.KeycodeK = KKey +mapKey Codes.KeycodeL = LKey +mapKey Codes.KeycodeM = MKey +mapKey Codes.KeycodeN = NKey +mapKey Codes.KeycodeO = OKey +mapKey Codes.KeycodeP = PKey +mapKey Codes.KeycodeQ = QKey +mapKey Codes.KeycodeR = RKey +mapKey Codes.KeycodeS = SKey +mapKey Codes.KeycodeT = TKey +mapKey Codes.KeycodeU = UKey +mapKey Codes.KeycodeV = VKey +mapKey Codes.KeycodeW = WKey +mapKey Codes.KeycodeX = XKey +mapKey Codes.KeycodeY = YKey +mapKey Codes.KeycodeZ = ZKey +mapKey Codes.KeycodeCapsLock = CapsLockKey +mapKey Codes.KeycodeF1 = F1Key +mapKey Codes.KeycodeF2 = F2Key +mapKey Codes.KeycodeF3 = F3Key +mapKey Codes.KeycodeF4 = F4Key +mapKey Codes.KeycodeF5 = F5Key +mapKey Codes.KeycodeF6 = F6Key +mapKey Codes.KeycodeF7 = F7Key +mapKey Codes.KeycodeF8 = F8Key +mapKey Codes.KeycodeF9 = F9Key +mapKey Codes.KeycodeF10 = F10Key +mapKey Codes.KeycodeF11 = F11Key +mapKey Codes.KeycodeF12 = F12Key +mapKey Codes.KeycodePrintScreen = PrintScreenKey +mapKey Codes.KeycodeScrollLock = ScrollLockKey +mapKey Codes.KeycodePause = PauseKey +mapKey Codes.KeycodeInsert = InsertKey +mapKey Codes.KeycodeHome = HomeKey +mapKey Codes.KeycodePageUp = PageUpKey +mapKey Codes.KeycodeDelete = DeleteKey +mapKey Codes.KeycodeEnd = EndKey +mapKey Codes.KeycodePageDown = PageDownKey +mapKey Codes.KeycodeRight = RightKey +mapKey Codes.KeycodeLeft = LeftKey +mapKey Codes.KeycodeDown = DownKey +mapKey Codes.KeycodeUp = UpKey +mapKey Codes.KeycodeNumLockClear = NumLockClearKey +mapKey Codes.KeycodeKPDivide = KeypadDivideKey +mapKey Codes.KeycodeKPMultiply = KeypadMultiplyKey +mapKey Codes.KeycodeKPMinus = KeypadMinusKey +mapKey Codes.KeycodeKPPlus = KeypadPlusKey +mapKey Codes.KeycodeKPEnter = KeypadEnterKey +mapKey Codes.KeycodeKP1 = KeypadNumber1Key +mapKey Codes.KeycodeKP2 = KeypadNumber2Key +mapKey Codes.KeycodeKP3 = KeypadNumber3Key +mapKey Codes.KeycodeKP4 = KeypadNumber4Key +mapKey Codes.KeycodeKP5 = KeypadNumber5Key +mapKey Codes.KeycodeKP6 = KeypadNumber6Key +mapKey Codes.KeycodeKP7 = KeypadNumber7Key +mapKey Codes.KeycodeKP8 = KeypadNumber8Key +mapKey Codes.KeycodeKP9 = KeypadNumber9Key +mapKey Codes.KeycodeKP0 = KeypadNumber0Key +mapKey Codes.KeycodeKPPeriod = KeypadPeriodKey +mapKey Codes.KeycodeApplication = ApplicationKey +mapKey Codes.KeycodePower = PowerKey +mapKey Codes.KeycodeKPEquals = KeypadEqualsKey +mapKey Codes.KeycodeF13 = F13Key +mapKey Codes.KeycodeF14 = F14Key +mapKey Codes.KeycodeF15 = F15Key +mapKey Codes.KeycodeF16 = F16Key +mapKey Codes.KeycodeF17 = F17Key +mapKey Codes.KeycodeF18 = F18Key +mapKey Codes.KeycodeF19 = F19Key +mapKey Codes.KeycodeF20 = F20Key +mapKey Codes.KeycodeF21 = F21Key +mapKey Codes.KeycodeF22 = F22Key +mapKey Codes.KeycodeF23 = F23Key +mapKey Codes.KeycodeF24 = F24Key +mapKey Codes.KeycodeExecute = ExecuteKey +mapKey Codes.KeycodeHelp = HelpKey +mapKey Codes.KeycodeMenu = MenuKey +mapKey Codes.KeycodeSelect = SelectKey +mapKey Codes.KeycodeStop = StopKey +mapKey Codes.KeycodeAgain = AgainKey +mapKey Codes.KeycodeUndo = UndoKey +mapKey Codes.KeycodeCut = CutKey +mapKey Codes.KeycodeCopy = CopyKey +mapKey Codes.KeycodePaste = PasteKey +mapKey Codes.KeycodeFind = FindKey +mapKey Codes.KeycodeMute = MuteKey +mapKey Codes.KeycodeVolumeUp = VolumeUpKey +mapKey Codes.KeycodeVolumeDown = VolumeDownKey +mapKey Codes.KeycodeKPComma = KeypadCommaKey +mapKey Codes.KeycodeKPEqualsAS400 = KeypadEqualsAS400Key +mapKey Codes.KeycodeAltErase = AltEraseKey +mapKey Codes.KeycodeSysReq = SysReqKey +mapKey Codes.KeycodeCancel = CancelKey +mapKey Codes.KeycodeClear = ClearKey +mapKey Codes.KeycodePrior = PriorKey +mapKey Codes.KeycodeReturn2 = Return2Key +mapKey Codes.KeycodeSeparator = SeparatorKey +mapKey Codes.KeycodeOut = OutKey +mapKey Codes.KeycodeOper = OperKey +mapKey Codes.KeycodeClearAgain = ClearAgainKey +mapKey Codes.KeycodeCrSel = CrSelKey +mapKey Codes.KeycodeExSel = ExSelKey +mapKey Codes.KeycodeKP00 = Keypad00Key +mapKey Codes.KeycodeKP000 = Keypad000Key +mapKey Codes.KeycodeThousandsSeparator = ThousandsSeparatorKey +mapKey Codes.KeycodeDecimalSeparator = DecimalSeparatorKey +mapKey Codes.KeycodeCurrencyUnit = CurrencyUnitKey +mapKey Codes.KeycodeCurrencySubunit = CurrencySubunitKey +mapKey Codes.KeycodeKPLeftParen = KeypadLeftParenKey +mapKey Codes.KeycodeKPRightParen = KeypadRightParenKey +mapKey Codes.KeycodeKPLeftBrace = KeypadLeftBraceKey +mapKey Codes.KeycodeKPRightBrace = KeypadRightBraceKey +mapKey Codes.KeycodeKPTab = KeypadTabKey +mapKey Codes.KeycodeKPBackspace = KeypadBackspaceKey +mapKey Codes.KeycodeKPA = KeypadAKey +mapKey Codes.KeycodeKPB = KeypadBKey +mapKey Codes.KeycodeKPC = KeypadCKey +mapKey Codes.KeycodeKPD = KeypadDKey +mapKey Codes.KeycodeKPE = KeypadEKey +mapKey Codes.KeycodeKPF = KeypadFKey +mapKey Codes.KeycodeKPXor = KeypadXorKey +mapKey Codes.KeycodeKPPower = KeypadPowerKey +mapKey Codes.KeycodeKPPercent = KeypadPercentKey +mapKey Codes.KeycodeKPLess = KeypadLessKey +mapKey Codes.KeycodeKPGreater = KeypadGreaterKey +mapKey Codes.KeycodeKPAmpersand = KeypadAmpersandKey +mapKey Codes.KeycodeKPDblAmpersand = KeypadDblAmpersandKey +mapKey Codes.KeycodeKPVerticalBar = KeypadVerticalBarKey +mapKey Codes.KeycodeKPDblVerticalBar = KeypadDblVerticalBarKey +mapKey Codes.KeycodeKPColon = KeypadColonKey +mapKey Codes.KeycodeKPHash = KeypadHashKey +mapKey Codes.KeycodeKPSpace = KeypadSpaceKey +mapKey Codes.KeycodeKPAt = KeypadAtKey +mapKey Codes.KeycodeKPExclam = KeypadExclamKey +mapKey Codes.KeycodeKPMemStore = KeypadMemStoreKey +mapKey Codes.KeycodeKPMemRecall = KeypadMemRecallKey +mapKey Codes.KeycodeKPMemClear = KeypadMemClearKey +mapKey Codes.KeycodeKPMemAdd = KeypadMemAddKey +mapKey Codes.KeycodeKPMemSubtract = KeypadMemSubtractKey +mapKey Codes.KeycodeKPMemMultiply = KeypadMemMultiplyKey +mapKey Codes.KeycodeKPMemDivide = KeypadMemDivideKey +mapKey Codes.KeycodeKPPlusMinus = KeypadPlusMinusKey +mapKey Codes.KeycodeKPClear = KeypadClearKey +mapKey Codes.KeycodeKPClearEntry = KeypadClearEntryKey +mapKey Codes.KeycodeKPBinary = KeypadBinaryKey +mapKey Codes.KeycodeKPOctal = KeypadOctalKey +mapKey Codes.KeycodeKPDecimal = KeypadDecimalKey +mapKey Codes.KeycodeKPHexadecimal = KeypadHexadecimalKey +mapKey Codes.KeycodeLCtrl = LeftCtrlKey +mapKey Codes.KeycodeLShift = LeftShiftKey +mapKey Codes.KeycodeLAlt = LeftAltKey +mapKey Codes.KeycodeLGUI = LeftGUIKey +mapKey Codes.KeycodeRCtrl = RightCtrlKey +mapKey Codes.KeycodeRShift = RightShiftKey +mapKey Codes.KeycodeRAlt = RightAltKey +mapKey Codes.KeycodeRGUI = RightGUIKey +mapKey Codes.KeycodeMode = ModeKey +mapKey Codes.KeycodeAudioNext = AudioNextKey +mapKey Codes.KeycodeAudioPrev = AudioPrevKey +mapKey Codes.KeycodeAudioStop = AudioStopKey +mapKey Codes.KeycodeAudioPlay = AudioPlayKey +mapKey Codes.KeycodeAudioMute = AudioMuteKey +mapKey Codes.KeycodeMediaSelect = MediaSelectKey +mapKey Codes.KeycodeWWW = WWWKey +mapKey Codes.KeycodeMail = MailKey +mapKey Codes.KeycodeCalculator = CalculatorKey +mapKey Codes.KeycodeComputer = ComputerKey +mapKey Codes.KeycodeACSearch = ACSearchKey +mapKey Codes.KeycodeACHome = ACHomeKey +mapKey Codes.KeycodeACBack = ACBackKey +mapKey Codes.KeycodeACForward = ACForwardKey +mapKey Codes.KeycodeACStop = ACStopKey +mapKey Codes.KeycodeACRefresh = ACRefreshKey +mapKey Codes.KeycodeACBookmarks = ACBookmarksKey +mapKey Codes.KeycodeBrightnessDown = BrightnessDownKey +mapKey Codes.KeycodeBrightnessUp = BrightnessUpKey +mapKey Codes.KeycodeDisplaySwitch = DisplaySwitchKey +mapKey Codes.KeycodeKbdIllumToggle = KeyboardIllumToggleKey +mapKey Codes.KeycodeKbdIllumDown = KeyboardIllumDownKey +mapKey Codes.KeycodeKbdIllumUp = KeyboardIllumUpKey +mapKey Codes.KeycodeEject = EjectKey +mapKey Codes.KeycodeSleep = SleepKey +mapKey _ = UnknownKey diff --git a/src/Helm/Engine/SDL/Mouse.hs b/src/Helm/Engine/SDL/Mouse.hs new file mode 100644 --- /dev/null +++ b/src/Helm/Engine/SDL/Mouse.hs @@ -0,0 +1,15 @@ +-- | Contains the SDL mouse button mappings. +module Helm.Engine.SDL.Mouse (mapMouseButton) where + +import qualified SDL.Event as Event + +import Helm.Engine (MouseButton(..)) + +-- | Map an SDL mouse button to a Helm mouse button. +mapMouseButton :: Event.MouseButton -> MouseButton +mapMouseButton Event.ButtonLeft = LeftButton +mapMouseButton Event.ButtonMiddle = MiddleButton +mapMouseButton Event.ButtonRight = RightButton +mapMouseButton Event.ButtonX1 = X1Button +mapMouseButton Event.ButtonX2 = X2Button +mapMouseButton _ = UnknownButton diff --git a/src/Helm/Graphics.hs b/src/Helm/Graphics.hs new file mode 100644 --- /dev/null +++ b/src/Helm/Graphics.hs @@ -0,0 +1,14 @@ +-- | Contains the graphics type. +module Helm.Graphics + ( + -- * Types + Graphics(..) + ) where + +import Helm.Graphics2D (Collage) + +-- | Represents any form of structure that produces visual +-- graphics to the screen, e.g. 2D or 3D graphics. +-- +-- The type variable e should refer to an 'Engine' instance. +data Graphics e = Graphics2D (Collage e) diff --git a/src/Helm/Graphics2D.hs b/src/Helm/Graphics2D.hs new file mode 100644 --- /dev/null +++ b/src/Helm/Graphics2D.hs @@ -0,0 +1,375 @@ +-- | Contains all the types and functions for composing +-- and rendering 2D graphics. +module Helm.Graphics2D + ( + -- * Types + Collage(..) + , Form(..) + , FormStyle(..) + , FillStyle(..) + , LineCap(..) + , LineJoin(..) + , LineStyle(..) + , Path(..) + , Shape(..) + , ShapeStyle(..) + , Transform(..) + , Text(..) + -- * Collages + , collage + , clip + , center + , toForm + -- * Styles & Forms + , defaultLine + , solid + , dashed + , dotted + , filled + , textured + , gradient + , outlined + , traced + , image + , fittedImage + , croppedImage + , blank + , alpha + , text + -- * Grouping + , group + , groupTransform + -- * Transforming + , rotate + , scale + , move + -- * Paths + , path + -- * Shapes + , polygon + , rect + , square + , oval + , circle + , ngon + ) where + +import Linear.V2 (V2(V2)) + +import Helm.Asset (Image) +import Helm.Color (Color, rgb, Gradient) +import Helm.Graphics2D.Text (Text(..)) +import Helm.Graphics2D.Transform (Transform(..), identity) + +-- | Represents a collection of forms, which in turn are rendereable +-- shapes and lines. In Helm, the collage is the main structure +-- representing 2D graphics and is passed directly to the engine +-- to be rendered by your view function. It's best to think of a collage +-- as a fancy version of a game screen, with the difference being that the +-- collage itself knows nothing about the window state. It only knows +-- what will be rendered to the screen (which in this case, is a series of forms) +-- and the order in which they will be rendered. +data Collage e = Collage + { collageDims :: Maybe (V2 Double) -- ^ The optional dimensions of the collage. It will be clipped to these dims. + , collageForms :: [Form e] -- ^ The collection of forms under the collage. + , collageCenter :: Maybe (V2 Double) -- ^ The optional center of the collage. + } + +-- | Create a collage from a list of forms. +-- By default, the collage will not be clipped +-- and will not be centered. The origin point of the contained +-- forms will be the top-left of the collage (which in the case of rendering +-- a collage to the screen, is coincidently the top-left of the game window). +-- See 'center' and 'clip'. +collage :: [Form e] -> Collage e +collage forms = Collage + { collageDims = Nothing + , collageForms = forms + , collageCenter = Nothing + } + +-- | Center a collage around a fixed point. This is useful to implement +-- 2D game cameras - usually, you have the center of the screen +-- at the position of the game camera (which in a 2D platformer, +-- is usually your game character). Note that this will center +-- the forms themselves, i.e. their original point will change from being +-- the top left of the collage to +center :: + V2 Double -- ^ The position to center the collage at. + -> Collage e -- ^ The source collage. + -> Collage e -- ^ The centered collage. +center pos col = col { collageCenter = Just pos } + +-- | Clip a collage by provided dimensions. Note that by default, +-- a collage will not be clipped and anything beyond the window dimensions +-- will still technically be rendered (although obviously it will not appear +-- on the game screen). By composing a collage with this function, +-- when the collage is rendered its contents will be clipped by these dimensions. +-- Not only will this generally speed up performance, it can be used for certain +-- cases where you don't want the forms in the collage to spill over +-- to other collages near it (but that's a very rare use-case). +-- +-- Something to note, that this is absolutely not an ensurance that your 2D graphics +-- will be rendered quickly if you're doing a lot of graphics work. The clip merely +-- prevents things being drawn outside the dimensions, which in most cases will +-- indeed speed up the performance, but it is down to the engine implementation for how much +-- this actually helps. +-- +-- In that sense, it's up to the library user to make sure they're not rendering huge amounts +-- of forms that aren't even in the screen's bounds. +clip :: + V2 Double -- ^ The dimensions to clip the collage with. + -> Collage e -- ^ The source collage. + -> Collage e -- ^ The clipped collage. +clip dims col = col { collageDims = Just dims } + +-- | Create a form from a collage. This might seem a little strange (as +-- a collage is generally what you provide to the engine to render the 2D graphics) +-- but by allowing this functionality, you can compose collages from other collages. +toForm :: Collage e -> Form e +toForm = defaultForm . CollageForm + +-- | Represents the styles of forms available. The form style holds data specific +-- to a variation of form, and the 'Form' is instead a general version of this +-- with positioning information, rotation, scale, etc. +data FormStyle e + = PathForm LineStyle Path -- ^ A form composed of a path + | ShapeForm (ShapeStyle e) Shape -- ^ A form composed of a shape. + | TextForm Text -- ^ A form composed of a piece of text, including string and style info. + | ImageForm (Image e) (V2 Double) (V2 Double) Bool -- ^ A form composed of an image + | GroupForm Transform [Form e] -- ^ A form composed of a group of forms, with a transformation. + | CollageForm (Collage e) -- ^ A form composed of a collage (which in turn is a collection of forms). + +-- | Represents something that can be rendered to the screen ( +-- contained under a collage). There are many different types of forms, which can be composed +-- below but are generally represented by the 'FormStyle' type. +-- +-- A form might be an image, or a rectangle, or a circle, or even a collection +-- of forms (which in turn can be those same things). +data Form e = Form + { formTheta :: Double -- ^ The rotation of the form (in radians). + , formScale :: Double -- ^ The scale factor of the form. + , formPos :: V2 Double -- ^ The position of the form. This will be rendered relative to the collage origin. + , formAlpha :: Double -- ^ The alpha channel of the form. + , formStyle :: FormStyle e -- ^ The style of form. + } + +-- | Represents the style of shape filling available. +data FillStyle e + = Solid Color -- ^ The shape will be filled with a solid color. + | Texture (Image e) -- ^ The shape will be filled with a texture (a.k.a. image). + | Gradient Gradient -- ^ The shape will be filled with a gradient (which can be linear or radial). + +-- | Represents the shape of the ends of a line. +data LineCap + = FlatCap + | RoundCap + | PaddedCap + deriving (Show, Eq, Ord, Read) + +-- | Represents the shape of the joints between line segments. +data LineJoin + = SmoothJoin + | SharpJoin Double + | ClippedJoin + deriving (Show, Eq, Ord, Read) + +-- | Represents the style used for drawing lines. It's best +-- to use 'defaultLine' and then only change the fields +-- you need to. +data LineStyle = LineStyle + { lineColor :: Color + , lineWidth :: Double + , lineCap :: LineCap + , lineJoin :: LineJoin + , lineDashing :: [Double] + , lineDashOffset :: Double + } deriving (Show, Eq) + +-- | Represents a series of 2D points which will be drawn in sequence. +-- Like a 'Shape', a path on its own holds no styling information. +data Path = Path [V2 Double] deriving (Show, Eq, Ord, Read) + +-- | Create a path from a sequence of points (represented as 2D vectors). +path :: [V2 Double] -> Path +path = Path + +-- | Represents a collection of points that when drawn in order +-- will result in a closed polygon. They have no style information - +-- rather, you compose shapes into a form with fill or line style +-- and that affects their appearance. +-- +-- Note that realistically, a shape could be represented as +-- a path only. However, we add extra variants here as drawing backends +-- usually provide optimized forms of drawing circles (and perhaps rectangles, +-- although that is less likely) hence it's better to fall to those +-- if our shape is circular. +data Shape + = PolygonShape Path + | RectangleShape (V2 Double) + | ArcShape (V2 Double) Double Double Double (V2 Double) + deriving (Show, Eq, Ord, Read) + +-- | Create an arbitary-sided polygon from a path. +-- The points provided should refer to each corner of the -gon, +-- however the points do not need to loop around (i.e. the final point +-- will automatically connect to the first point). +polygon :: Path -> Shape +polygon = PolygonShape + +-- | Create a rectangular shape from a 2D vector, with +-- x and y representing width and height, respectively. +rect :: V2 Double -> Shape +rect = RectangleShape + +-- | Create a square shape with a side length. +square :: Double -> Shape +square n = rect (V2 n n) + +-- | Create an oval shape with a width and height. +oval :: Double -> Double -> Shape +oval w h = ArcShape (V2 0 0) 0 (2 * pi) 1 (V2 (w / 2) (h / 2)) + +-- | Create a circle shape with a radius. +circle :: Double -> Shape +circle r = ArcShape (V2 0 0) 0 (2 * pi) r (V2 1 1) + +-- | Create a generic n-sided polygon (e.g. octagon, pentagon, etc) with +-- a side count and radius. +ngon :: Int -> Double -> Shape +ngon n r = polygon $ path $ map point series + where + point i = V2 (r * cos (t * i)) (r * sin (t * i)) + series = [0 .. fromIntegral (n - 1)] + m = fromIntegral n + t = 2 * pi / m + +-- | Create the default line style. By default, the line is black with a width of 1, +-- flat caps and regular sharp joints. +defaultLine :: LineStyle +defaultLine = LineStyle + { lineColor = rgb 0 0 0 + , lineWidth = 1 + , lineCap = FlatCap + , lineJoin = SharpJoin 10 + , lineDashing = [] + , lineDashOffset = 0 + } + +-- | Create a initial form from a specific form style. +-- The form will be at the origin point (0, 0). +defaultForm :: FormStyle e -> Form e +defaultForm style = Form + { formTheta = 0 + , formScale = 1 + , formPos = V2 0 0 + , formAlpha = 1 + , formStyle = style + } + +-- | Represents the style used for drawing a shape. +data ShapeStyle e + = OutlinedShape LineStyle -- ^ Stroke/outline the shape, with a specific line style. + | FilledShape (FillStyle e) -- ^ Fill the shape, with a specific fill style. + +-- | Create a solid line style with a color. +solid :: Color -> LineStyle +solid color = defaultLine { lineColor = color } + +-- | Create a dashed line style with a color. +dashed :: Color -> LineStyle +dashed color = defaultLine { lineColor = color, lineDashing = [8, 4] } + +-- | Create a dotted line style with a color. +dotted :: Color -> LineStyle +dotted color = defaultLine { lineColor = color, lineDashing = [3, 3] } + +-- | Fill a shape with a specific fill style. +fill :: FillStyle e -> Shape -> Form e +fill style shape = defaultForm (ShapeForm (FilledShape style) shape) + +-- | Fill a shape with a color. +filled :: Color -> Shape -> Form e +filled color = fill (Solid color) + +-- | Fill a shape with a texture. The texture should +-- be an image loaded by the engine. +textured :: Image e -> Shape -> Form e +textured img = fill (Texture img) + +-- | Fill a shape with a gradient (either 'linear' or 'radial'). +gradient :: Gradient -> Shape -> Form e +gradient grad = fill (Gradient grad) + +-- | Create a form from a shape by outlining it with a specific line style. +outlined :: LineStyle -> Shape -> Form e +outlined style shape = defaultForm (ShapeForm (OutlinedShape style) shape) + +-- | Create a form from a path by tracing it with a specific line style. +traced :: LineStyle -> Path -> Form e +traced style p = defaultForm (PathForm style p) + +-- | Create an empty form, useful for having forms rendered only at some state. +blank :: Form e +blank = group [] + +-- | Create a form from an image. If the image dimensions are not the +-- same as provided, then it will stretch/shrink to fit. +image :: V2 Double -> Image e -> Form e +image dims img = defaultForm $ ImageForm img (V2 0 0) dims True + +-- | Create a form from an image with a 2D vector describing its dimensions. +-- If the image dimensions are not the same as given, then it will only use the relevant pixels +-- (i.e. cut out the given dimensions instead of scaling). If the given dimensions are bigger than +-- the actual image, than irrelevant pixels are ignored. +fittedImage :: V2 Double -> Image e -> Form e +fittedImage dims img = defaultForm $ ImageForm img (V2 0 0) dims False + +-- | Create a form from an image by cropping it with a certain position, width, height +-- and image file path. This can be used to divide a single image up into smaller ones ( +-- for example, drawing a single sprite from a sprite sheet). +croppedImage :: V2 Double -> V2 Double -> Image e -> Form e +croppedImage pos dims img = defaultForm $ ImageForm img pos dims False + +-- | Group a list of forms into one. They will be drawn in their +-- sequential order within the list. +group :: [Form e] -> Form e +group forms = defaultForm (GroupForm identity forms) + +-- | Group a list of forms into one, while also applying a matrix +-- transformation. +groupTransform :: Transform -> [Form e] -> Form e +groupTransform matrix forms = defaultForm (GroupForm matrix forms) + +-- | Move a form by a given 2D vector. The movement is relative, +-- i.e. the translation vector provided will be added to the form's +-- current position. +move :: V2 Double -> Form e -> Form e +move trans form = form { formPos = formPos form + trans } + +-- | Scale a form by a scalar factor. Scaling by 2 will double the size +-- of the form, and scaling by 0.5 will half the size. Note that like +-- 'move', the scale function is relative - i.e. if you scaled by 0.5 +-- and then scaled by 0.5 a gain, the final scale would be 0.25 or +-- a quarter of the form's initial scale. +scale :: Double -> Form e -> Form e +scale factor form = form { formScale = factor * formScale form } + +-- | Rotate a form by a given angle (in radians). +-- Like 'move' and 'scale', the rotation is relative. +rotate :: Double -> Form e -> Form e +rotate theta form = form { formTheta = formTheta form + theta } + +-- | Change the alpha value of a form (i.e. its transparency). +-- By default, forms will have an alpha value of 1, in other words, +-- they are fully opaque. Alternatively, a value of 0 will mean the +-- form is completely hidden. +alpha :: Double -> Form e -> Form e +alpha x form = form { formAlpha = x } + +-- | Create a form from a `Text` structure, which in turn +-- contains all of the text values and styling. This allows +-- you to render a the text graphically (and in turn it's a regular old +-- form, so it can be translated, rotated, etc.). +text :: Text -> Form e +text = defaultForm . TextForm diff --git a/src/Helm/Graphics2D/Text.hs b/src/Helm/Graphics2D/Text.hs new file mode 100644 --- /dev/null +++ b/src/Helm/Graphics2D/Text.hs @@ -0,0 +1,97 @@ +-- | Contains all the data structures and functions for composing +-- pieces of graphical text. +module Helm.Graphics2D.Text + ( + -- * Types + Text(..) + , FontWeight(..) + , FontStyle(..) + -- * Composing + , defaultText + , toText + , showText + -- * Formatting + , light + , bold + , italic + , oblique + , color + , typeface + , height + ) where + +import Helm.Color (Color(..), rgb) + +-- | Represents the weight for a text's font. +data FontWeight + = LightWeight + | NormalWeight + | BoldWeight + deriving (Show, Eq, Ord, Enum, Read) + +-- | Represents the style for a text's font. +data FontStyle + = NormalStyle + | ObliqueStyle + | ItalicStyle + deriving (Show, Eq, Ord, Enum, Read) + +-- | Represents a graphical piece of text, +-- containing a UTF-8 string and any relevant style fields. +data Text = Text + { textString :: String + , textColor :: Color + , textTypeface :: String + , textHeight :: Double + , textWeight :: FontWeight + , textStyle :: FontStyle + } deriving (Show, Eq) + +-- | Create the default text. By default it is is black sans-serif +-- with a height of 14pt. +defaultText :: Text +defaultText = Text { + textString = "", + textColor = rgb 0 0 0, + textTypeface = "sans-serif", + textHeight = 14, + textWeight = NormalWeight, + textStyle = NormalStyle +} + +-- | Create a text from a string. By default, this text will be 14pt, +-- black and unstyled. +toText :: String -> Text +toText str = defaultText { textString = str } + +-- | Create a text from a type instancing 'Show'. +showText :: Show a => a -> Text +showText a = toText $ show a + +-- | Set the weight of a text to bold. +bold :: Text -> Text +bold txt = txt { textWeight = BoldWeight } + +-- | Set the weight of a piece of text to light. +light :: Text -> Text +light txt = txt { textWeight = LightWeight } + +-- | Set the slant of a piece of text to italic. +italic :: Text -> Text +italic txt = txt { textStyle = ItalicStyle } + +-- | Set the slant of a piece of text to oblique. +oblique :: Text -> Text +oblique txt = txt { textStyle = ObliqueStyle } + +-- | Set the color of a piece of text. +color :: Color -> Text -> Text +color col txt = txt { textColor = col } + +-- | Set the typeface of the text. +typeface :: String -> Text -> Text +typeface face txt = txt { textTypeface = face } + +-- | Set the size of a piece of text. +height :: Double -> Text -> Text +height size txt = txt { textHeight = size } diff --git a/src/Helm/Graphics2D/Transform.hs b/src/Helm/Graphics2D/Transform.hs new file mode 100644 --- /dev/null +++ b/src/Helm/Graphics2D/Transform.hs @@ -0,0 +1,85 @@ +-- | Contains the 2D transform matrix type and functions for composing +-- transformation matricies. +module Helm.Graphics2D.Transform + ( + -- * Types + Transform(..) + -- * Composing + , identity + , matrix + , rotation + , translation + , scale + , multiply + ) where + +import qualified Linear.Matrix as Matrix +import Linear.V2 (V2(V2)) +import Linear.V3 (V3(V3)) + +-- | Represents a transformation matrix that can be used to transform +-- forms. This is more useful than just using the composing methods +-- in the graphics API, as it can perform skewing and other +-- complex transformation techniques. +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) + +-- | Construct an identity transformation matrix. Anything transformed by this matrix +-- will remain the same. +identity :: Transform +identity = Transform Matrix.identity + +-- | Construct a transformation matrix with specific row/column values. +-- +-- > matrix a b c d x y +-- +-- / a b x \ +-- \ c d y / +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) + +-- | Construct a counter-clockwise rotating transformation matrix. +-- +-- > rotation t +-- +-- / cos t -sin t 0 \ +-- \ sin t cos t 0 / +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 + +-- | Construct a translating transformation matrix. +-- +-- > translation (V2 x y) +-- +-- / 1 0 x \ +-- \ 0 1 y / +translation :: V2 Double -> Transform +translation (V2 x y) = Transform $ V3 (V3 1 0 x) (V3 0 1 y) (V3 0 0 1) + +-- | Construction a scaling transformation matrix. To scale in all directions, +-- simply have the x and y values the same. Alternatively, +-- to scale by only one direction, keep the excluded dimenion's +-- vector component as 1. +-- +-- > scale (V2 x y) +-- +-- / x 0 0 \ +-- \ 0 y 0 / +scale :: V2 Double -> Transform +scale (V2 x y) = Transform $ V3 (V3 x 0 0) (V3 y 0 0) (V3 0 0 1) + +-- | Multiply two transformatio nmatrices together.. +multiply :: Transform -> Transform -> Transform +multiply (Transform a) (Transform b) = Transform $ a * b diff --git a/src/Helm/Keyboard.hs b/src/Helm/Keyboard.hs new file mode 100644 --- /dev/null +++ b/src/Helm/Keyboard.hs @@ -0,0 +1,46 @@ +-- | Contains subscriptions to events from the keyboard. +module Helm.Keyboard + ( + -- * Types + Key(..) + -- * Subscriptions + , presses + , downs + , ups + ) where + +import FRP.Elerea.Param (input, snapshot) + +import Helm.Engine (Engine(..), Sub(..), Key(..)) + +-- | Subscribe to keyboard press events and map to a game action. +-- A key press event is produced whenever a key is either released +-- or continously held down. +presses + :: Engine e + => (Key -> a) -- ^ The function to map the key pressed to an action. + -> Sub e a -- ^ The mapped subscription. +presses f = Sub $ do + engine <- input >>= snapshot + + fmap (fmap f) <$> keyboardPressSignal engine + +-- | Subscribe to keyboard down events and map to a game action. +downs + :: Engine e + => (Key -> a) -- ^ The function to map the key held down to an action. + -> Sub e a -- ^ The mapped subscription. +downs f = Sub $ do + engine <- input >>= snapshot + + fmap (fmap f) <$> keyboardDownSignal engine + +-- | Subscribe to keyboard up events and map to a game action. +ups + :: Engine e + => (Key -> a) -- ^ The function to map the key released to an action. + -> Sub e a -- ^ The mapped subscription. +ups f = Sub $ do + engine <- input >>= snapshot + + fmap (fmap f) <$> keyboardUpSignal engine diff --git a/src/Helm/Mouse.hs b/src/Helm/Mouse.hs new file mode 100644 --- /dev/null +++ b/src/Helm/Mouse.hs @@ -0,0 +1,62 @@ +{-| Contains subscriptions to events from the mouse. -} +module Helm.Mouse + ( + -- * Types + MouseButton(..) + -- * Subscriptions + , moves + , clicks + , downs + , ups + ) where + +import FRP.Elerea.Param (input, snapshot) +import Linear.V2 (V2) + +import Helm.Engine (Sub(..), Engine(..), MouseButton(..)) + +-- | Subscribe to mouse movement events and map to a game action. +moves + :: Engine e + => (V2 Int -> a) -- ^ The function to map a mouse position to an action. + -> Sub e a -- ^ The mapped subscription. +moves f = Sub $ do + engine <- input >>= snapshot + + fmap (fmap f) <$> mouseMoveSignal engine + +-- | Subscribe to mouse click events and map to a game action. +-- This subscription is for all mouse buttons - you'll need to +-- match over a mouse button if you want to capture a specific one. +-- +-- Note that Helm defines a mouse click as a mouse up event which +-- came after a very recent mouse down event in a close radius +-- of the mouse down event. +clicks + :: Engine e + => (MouseButton -> V2 Int -> a) -- ^ The function to map a mouse button and position to an action. + -> Sub e a -- ^ The mapped subscription. +clicks f = Sub $ do + engine <- input >>= snapshot + + fmap (fmap (uncurry f)) <$> mouseClickSignal engine + +-- | Subscribe to mouse button down events and map to a game action. +downs + :: Engine e + => (MouseButton -> V2 Int -> a) -- ^ The function to map a mouse button and position to an action. + -> Sub e a -- ^ The mapped subscription. +downs f = Sub $ do + engine <- input >>= snapshot + + fmap (fmap (uncurry f)) <$> mouseDownSignal engine + +-- | Subscribe to mouse button up events and map to a game action. +ups + :: Engine e + => (MouseButton -> V2 Int -> a) -- ^ The function to map a mouse button and position to an action. + -> Sub e a -- ^ The mapped subscription. +ups f = Sub $ do + engine <- input >>= snapshot + + fmap (fmap (uncurry f)) <$> mouseUpSignal engine diff --git a/src/Helm/Sub.hs b/src/Helm/Sub.hs new file mode 100644 --- /dev/null +++ b/src/Helm/Sub.hs @@ -0,0 +1,33 @@ +-- | Contains the subscription type and related utilities. +module Helm.Sub + ( + -- * Types + Sub(..) + -- * Utilities + , batch + , none + ) where + +import Helm.Engine (Engine, Sub(..)) + +-- | Combine a list of subscriptions into a single one. +-- This is allows for subscriptions to multiple input events to be +-- combined into one subscription that encompasses all the actions +-- mapped from events. +batch + :: Engine e + => [Sub e a] -- ^ The list of subscriptions. + -> Sub e a -- ^ The subscriptions accumulated. +batch subs = Sub $ do + signals <- mapM (\(Sub gen) -> gen) subs + + return $ do + lists <- sequence signals + + return $ concat lists + +-- | A subscription that does nothing. If user input events +-- aren't required for a game, return this in the subscriptions function +-- of the game. +none :: Engine e => Sub e a +none = Sub . return $ return [] diff --git a/src/Helm/Time.hs b/src/Helm/Time.hs new file mode 100644 --- /dev/null +++ b/src/Helm/Time.hs @@ -0,0 +1,116 @@ +-- | 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 + , fps + ) where + +import Control.Monad.State (get) +import Control.Monad.IO.Class (liftIO) + +import FRP.Elerea.Param (transfer, input, snapshot, effectful) + +import Helm.Engine (Cmd(..), Sub(..), Engine(..)) + +-- | Represents an amount of time in an arbitary unit. +-- This type can then be composed with the relevant utility functions. +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 + +-- | Map the running time of the engine to a game action. +-- Note that this is not the current clock time but rather the engine time, +-- i.e. when the engine first starts running, the applied value will be zero. +now + :: Engine e + => (Time -> a) -- ^ The function to map the running time to an action. + -> Cmd e a -- ^ The mapped command. +now f = Cmd $ do + engine <- get + ticks <- liftIO $ f <$> runningTime engine + + return [ticks] + +-- | Generic subscription for time interval-based events. +every' :: Engine e => (e -> Time -> (Time, [Double]) -> (Time, [Double])) -> (Time -> a) -> Sub e a +every' step f = Sub $ do + engine <- input >>= snapshot + time <- effectful $ runningTime engine + sig <- transfer (0, []) step time + + return $ map f . snd <$> sig + +-- | Subscribe to the running time of the engine and map to a game action, +-- producing events at a provided interval. +every + :: Engine e + => Time -- ^ The interval of time to produce events at. + -> (Time -> a) -- ^ The function to map the running time to an action. + -> Sub e a -- ^ The mapped subscription. +every interval = every' step + where + step _ t (lt, _) = + if t - lt >= interval + then (t, [t]) -- Use new t value with t event + else (lt, []) -- Use old t value with no event + +-- | Subscribe to events that emit at a provided frames per second and map to a game action, +-- producing events at a provided interval. The time value applied is the delta between +-- the current and last event emission time. +fps + :: Engine e + => Int -- ^ The frames per second. + -> (Time -> a) -- ^ The function to map the time delta to an action. + -> Sub e a -- ^ The mapped subscription. +fps frames = every' step + where + interval = 1000 / fromIntegral frames + step _ t (lt, _) = + if t - lt >= interval + then (t, [t - lt]) -- Use new t value with t event + else (lt, []) -- Use old t value with no event diff --git a/src/Helm/Window.hs b/src/Helm/Window.hs new file mode 100644 --- /dev/null +++ b/src/Helm/Window.hs @@ -0,0 +1,37 @@ +-- | Contains signals that sample input from the game window. +module Helm.Window + ( + -- * Commands + size + -- * Subscriptions + , resizes + ) where + +import Control.Monad.State (get) +import Control.Monad.IO.Class (liftIO) + +import FRP.Elerea.Param (input, snapshot) +import Linear.V2 (V2) + +import Helm.Engine (Engine(..), Cmd(..), Sub(..)) + +-- | Map the game window size to a game action. +size + :: Engine e + => (V2 Int -> a) -- ^ The function to map the window size to an action. + -> Cmd e a -- ^ The mapped command. +size f = Cmd $ do + engine <- get + sized <- liftIO $ f <$> windowSize engine + + return [sized] + +-- | Subscribe to the resize events from the game window and map to a game action. +resizes + :: Engine e + => (V2 Int -> a) -- ^ The function to map the changed window size to an action. + -> Sub e a -- ^ The mapped subscription. +resizes f = Sub $ do + engine <- input >>= snapshot + + fmap (map f) <$> windowResizeSignal engine diff --git a/test/Helm/TimeSpec.hs b/test/Helm/TimeSpec.hs new file mode 100644 --- /dev/null +++ b/test/Helm/TimeSpec.hs @@ -0,0 +1,16 @@ +module Helm.TimeSpec where + +import Helm.Time +import Test.Hspec + +spec :: Spec +spec = + describe "units" $ do + it "represents 1 ms the same as (1/1000) s" $ + inSeconds millisecond `shouldBe` (1/1000) + + it "represents 1 s the same as (1/60) min" $ + inMinutes second `shouldBe` (1/60.0) + + it "represents 1 min as (1/60) hrs" $ + inHours minute `shouldBe` (1/60.0) diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/tests/Main.hs b/tests/Main.hs deleted file mode 100644 --- a/tests/Main.hs +++ /dev/null @@ -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]