helm 0.6.1 → 0.7.0
raw patch · 14 files changed
+558/−635 lines, 14 filesdep +timedep ~sdl2
Dependencies added: time
Dependency ranges changed: sdl2
Files
- README.md +10/−21
- helm.cabal +9/−3
- src/FRP/Helm.hs +103/−60
- src/FRP/Helm/Animation.hs +0/−122
- src/FRP/Helm/Engine.hs +11/−0
- src/FRP/Helm/Keyboard.hs +21/−19
- src/FRP/Helm/Mouse.hs +44/−23
- src/FRP/Helm/Random.hs +81/−0
- src/FRP/Helm/Sample.hs +29/−0
- src/FRP/Helm/Signal.hs +122/−0
- src/FRP/Helm/Time.hs +89/−31
- src/FRP/Helm/Transition.hs +0/−225
- src/FRP/Helm/Utilities.hs +0/−116
- src/FRP/Helm/Window.hs +39/−15
README.md view
@@ -38,20 +38,19 @@ 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.Animation` contains a simple implementation of animations. Each- animation is made up of a list of frames which render a form at a specific time. * `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.Utilities` contains a few useful functions, such as lifting/folding signal generators- containing signals.- * `FRP.Helm.Time` contains functions for composing units of time and signals that sample from the game clock.- * `FRP.Helm.Transition` contains functions for composing transitions allowing you to animate between interpolable types, e.g. colors.+ * `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@@ -66,13 +65,10 @@ render (w, h) = collage w h [move (100, 100) $ filled red $ square 64] main :: IO ()-main = do- engine <- startup defaultConfig-- run engine $ render <~ Window.dimensions engine+main = run defaultConfig $ render <~ Window.dimensions ``` -It renders a red square at the position `(100, 100)` with a side length of `64`. +It renders a red square at the position `(100, 100)` with a side length of `64`. 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).@@ -86,26 +82,19 @@ data State = State { mx :: Double, my :: Double } step :: (Int, Int) -> State -> State-step (dx, dy) state = state { mx = (realToFrac dx) + mx state,- my = (realToFrac dy) + my state }+step (dx, dy) state = state { mx = (10 * (realToFrac dx)) + mx state,+ my = (10 * (realToFrac dy)) + my state } render :: (Int, Int) -> State -> Element render (w, h) (State { mx = mx, my = my }) = centeredCollage w h [move (mx, my) $ filled white $ square 100] main :: IO ()-main = do- engine <- startup defaultConfig-- run engine $ render <~ Window.dimensions engine ~~ stepper-+main = run defaultConfig $ render <~ Window.dimensions ~~ stepper where state = State { mx = 0, my = 0 } stepper = foldp step state Keyboard.arrows- ```--Checkout the demos folder for more examples. ## Installing and Building
helm.cabal view
@@ -1,5 +1,5 @@ name: helm-version: 0.6.1+version: 0.7.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.@@ -30,14 +30,16 @@ FRP.Helm FRP.Helm.Color FRP.Helm.Graphics- FRP.Helm.Animation+ 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- FRP.Helm.Transition build-depends: base >= 4 && < 5,@@ -48,6 +50,7 @@ filepath >= 1.3 && < 2, sdl2 >= 1.1 && < 2, 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,@@ -66,9 +69,12 @@ 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 && < 2
src/FRP/Helm.hs view
@@ -3,20 +3,20 @@ module FRP.Helm ( -- * Types Time,- Engine(..), EngineConfig(..), -- * Engine- startup, run, defaultConfig, -- * Prelude module Color, module Graphics, module Utilities,- FRP.Helm.Utilities.lift+ 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@@ -28,12 +28,16 @@ import Foreign.Marshal.Alloc import Foreign.Ptr import Foreign.Storable-import FRP.Elerea.Simple+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 hiding (lift)-import qualified FRP.Helm.Utilities (lift)+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@@ -43,7 +47,16 @@ type Helm a = StateT Engine Cairo.Render a -{-| A data structure describing miscellaneous initial configurations of the game window and engine. -}+{-| 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,@@ -51,7 +64,8 @@ windowTitle :: String } -{-| Creates the default configuration for the engine. You should change the fields where necessary before passing it to 'run'. -}+{-| 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),@@ -60,20 +74,17 @@ windowTitle = "" } -{-| A data structure describing the current engine state. -}-data Engine = Engine {- window :: SDL.Window,- renderer :: SDL.Renderer,- cache :: Map.Map FilePath Cairo.Surface-}- {-| 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 }+ return Engine { window = window+ , renderer = renderer+ , cache = Map.empty+ , continue = True+ } where (w, h) = windowDimensions@@ -94,56 +105,81 @@ > main :: IO () > main = run defaultConfig $ lift render Window.dimensions -}-run :: Engine -> SignalGen (Signal Element) -> IO ()-run engine gen = finally (start gen >>= run' engine) SDL.quit+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 -{-| A utility function called by 'run' that samples the element- or quits the entire engine if SDL events say to do so. -}-run' :: Engine -> IO Element -> IO ()-run' engine smp = do- continue <- run''+{-| 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 - when continue $ smp >>= render engine >>= flip run' smp+ if status == 1 then do+ event <- peek eventptr -{-| A utility function called by 'run\'' that polls all SDL events- off the stack, returning true if the game should keep running,- false otherwise. -}-run'' :: IO Bool-run'' = alloca $ \eventptr -> do- status <- SDL.pollEvent eventptr+ case event of+ SDL.WindowEvent _ _ _ e _ _ -> return $ if e == SDL.windowEventExposed+ then Changed ()+ else Unchanged ()+ _ -> return $ Unchanged ()+ else return $ Unchanged () - if status == 1 then do- event <- peek eventptr+{-| 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 ()) - case event of- SDL.QuitEvent _ _ -> return False- _ -> run''- else- return True+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 -> IO Engine-render engine@(Engine { .. }) element = alloca $ \wptr ->- alloca $ \hptr ->- alloca $ \pixelsptr ->- alloca $ \pitchptr -> do- SDL.getWindowSize window wptr hptr-- w <- fromIntegral <$> peek wptr- h <- fromIntegral <$> peek hptr+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) - format <- SDL.masksToPixelFormatEnum 32 (fromBE32 0x0000ff00) (fromBE32 0x00ff0000) (fromBE32 0xff000000) (fromBE32 0x000000ff)- texture <- SDL.createTexture renderer format SDL.textureAccessStreaming (fromIntegral w) (fromIntegral h)+ 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)+ res <- Cairo.withImageSurfaceForData (castPtr pixels)+ Cairo.FormatARGB32 w h pitch $ \surface -> Cairo.renderWith surface+ $ evalStateT (render' w h element) engine SDL.unlockTexture texture @@ -170,7 +206,7 @@ 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+ Engine _ _ cache _ <- get case Map.lookup src cache of Just surface -> do@@ -207,7 +243,8 @@ Cairo.translate (-fromIntegral sx) (-fromIntegral sy) if stretch then- Cairo.scale (fromIntegral sw / fromIntegral w) (fromIntegral sh / fromIntegral h)+ Cairo.scale (fromIntegral sw / fromIntegral w)+ (fromIntegral sh / fromIntegral h) else Cairo.scale 1 1 @@ -222,12 +259,15 @@ 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 }]+ 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+ 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@@ -252,7 +292,8 @@ ObliqueStyle -> Pango.StyleOblique ItalicStyle -> Pango.StyleItalic -{-| A utility function that goes into a state of transformation and then pops it when finished. -}+{-| 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@@ -300,10 +341,12 @@ Cairo.fill setFillStyle (Gradient (Linear (sx, sy) (ex, ey) points)) =- lift $ Cairo.withLinearPattern sx sy ex ey $ \pattern -> setFillStyle' pattern 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+ 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 ()
− src/FRP/Helm/Animation.hs
@@ -1,122 +0,0 @@-{-| Contains all data structures and functions for creating and stepping animations. -}-module FRP.Helm.Animation (- -- * Types- Frame,- Animation,- AnimationStatus(..),- -- * Creating- absolute,- relative,- -- * Animating- animate,- formAt,- length-) where--import Prelude hiding (length)--import FRP.Elerea.Simple-import Control.Applicative-import FRP.Helm.Graphics (Form,blank)-import FRP.Helm.Time (Time, inMilliseconds)-import Data.Maybe (fromJust)-import Data.List (find)-import qualified Data.List as List (length)--{-| A type describing a single frame in an animation. A frame consists of a time at- which the frame takes place in an animation and the form which is how the frame- actually looks when rendered. -}-type Frame = (Time, Form)--{-| A type describing an animation consisting of a list of frames. -}-type Animation = [Frame]--{-| A data structure that can be used to manage the status of the animation. -}-data AnimationStatus- -- | The animation continues to play through its frames.- = Cycle- -- | The animation is paused.- | Pause- -- | The animation is stopped, jumping back to the first frame and initial time.- | Stop- -- | The animation is set to a specific one-indexed frame.- | SetFrame Int- -- | The animation is set to a specific time and its related frame.- | SetTime Time--{-| Creates an animation from a list of frames. The time value in each frame- is absolute to the entire animation, i.e. each time value is the time- at which the frame takes place relative to the starting time of the animation. -}-absolute :: [Frame] -> Animation-absolute = id--{-| Creates an animation from a list of frames. The time value in each frame- is relative to other frames, i.e. each time value is the difference- in time from the last frame.-- > relative [(100 * millisecond, picture1), (100 * millisecond, picture2)] == absolute [(100 * millisecond, picture1), (200 * millisecond, picture2)]- -}-relative :: [Frame] -> Animation-relative = scanl1 (\acc x -> (fst acc + fst x, snd x))--{-| Creates a signal that returns the current form in the animation when sampled from- a specific animation. The second argument is a signal that returns the time to- setup the animation forward when sampled. The third argument is a signal that returns- the status of the animation, allowing you to control it. -}-animate :: Animation -> SignalGen (Signal Time) -> SignalGen (Signal AnimationStatus) -> SignalGen (Signal Form)-animate [] _ _ = return $ return blank-animate anim dt status = do- dt1 <- dt- status1 <- status- progress <- transfer2 0 (timestep anim) status1 $ inMilliseconds <$> dt1-- return $ fromJust <$> formAt anim <$> progress--{-| Steps the animation but also cycles if the end is reached, handles any statuses and- tries to pickup any issues and handle them silently. -}-timestep :: Animation -> AnimationStatus -> Time -> Time -> Time-timestep anim Cycle dt t = cycleTime anim (dt + t)-timestep _ Pause _ t = t-timestep _ Stop _ _ = 0-timestep anim (SetTime sT) _ _ = cycleTime anim $ inMilliseconds sT-timestep anim (SetFrame f) _ _ = gentleIndex anim f- where- gentleIndex [] _ = 0- gentleIndex xs n = fst $ xs !! (cycleFrames anim n -1)--{-| The form that will be rendered for a specific time in an animation. -}-formAt :: Animation -> Time -> Maybe Form-formAt anim t = snd <$> find (\frame -> t <= fst frame) anim--{-| The amount of time one cycle of the animation takes. -}-length :: Animation -> Time-length [] = 0-length anim = maximum $ times anim--{-| A list of all the time values of each frame in the animation. -}-times :: Animation -> [Time]-times = map fst--{-| Given an animation, a function is created which loops the time of the animation- to always be in the animations length boundary. -}-cycleTime :: Animation -> Time -> Time-cycleTime anim = cycleTime' (length anim)--{-| Helper function which makes a timer loop through an time interval. -}-cycleTime' :: Time -> Time -> Time-cycleTime' l t- | t > l = cycleTime' l (t-l)- | t < 0 = cycleTime' l (l+t)- | otherwise = t--{-| Given an animation, a function is created which loops the frame indices of the animation- to always be in the animations frame length boundary. -}-cycleFrames :: Animation -> Int -> Int-cycleFrames anim = cycleFrames' (List.length anim)--{-| Helper function which makes a frame index loop through an interval starting at 1. -}-cycleFrames' :: Int -> Int -> Int-cycleFrames' l f- | f > l = cycleFrames' l (f-l)- | f < 1 = cycleFrames' l (l+f)- | otherwise = f
+ src/FRP/Helm/Engine.hs view
@@ -0,0 +1,11 @@+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+}
src/FRP/Helm/Keyboard.hs view
@@ -12,7 +12,9 @@ import Data.List import Foreign hiding (shift) import Foreign.C.Types-import FRP.Elerea.Simple+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)@@ -756,36 +758,36 @@ toEnum _ = error "FRP.Helm.Keyboard.Key.toEnum: bad argument" {-| Whether a key is pressed. -}-isDown :: Key -> SignalGen (Signal Bool)-isDown k = effectful $ elem (fromEnum k) <$> getKeyState+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 :: SignalGen (Signal [Key])-keysDown = effectful $ map toEnum <$> getKeyState+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 :: SignalGen (Signal (Int, Int))-arrows = do- up <- isDown UpKey- left <- isDown LeftKey- down <- isDown DownKey- right <- isDown RightKey+arrows :: Signal (Int, Int)+arrows = arrows' <$> up <*> left <*> down <*> right+ where up = isDown UpKey+ left = isDown LeftKey+ down = isDown DownKey+ right = isDown RightKey - return $ arrows' <$> up <*> left <*> down <*> right {-| 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 :: SignalGen (Signal (Int, Int))-wasd = do- w <- isDown WKey- a <- isDown AKey- s <- isDown SKey- d <- isDown DKey+wasd :: Signal (Int, Int)+wasd = arrows' <$> w <*> a <*> s <*> d+ where w = isDown WKey+ a = isDown AKey+ s = isDown SKey+ d = isDown DKey - return $ arrows' <$> w <*> a <*> s <*> d
src/FRP/Helm/Mouse.hs view
@@ -1,19 +1,24 @@ {-| Contains signals that sample input from the mouse. -}-module FRP.Helm.Mouse (+module FRP.Helm.Mouse+( -- * Types Mouse(..), -- * Position- isDown,+ position, x, y, -- * Mouse State- position, x, y+ isDown,+ isDownButton,+ clicks ) where +import Control.Applicative (pure) import Data.Bits import Foreign.Marshal.Alloc import Foreign.Ptr import Foreign.Storable-import FRP.Elerea.Simple-import FRP.Helm.Utilities+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. -}@@ -26,11 +31,11 @@ {- All integer values of this enum are equivalent to the SDL key enum. -} instance Enum Mouse where- fromEnum LeftMouse = 1+ fromEnum LeftMouse = 1 fromEnum MiddleMouse = 2- fromEnum RightMouse = 3- fromEnum X1Mouse = 4- fromEnum X2Mouse = 5+ fromEnum RightMouse = 3+ fromEnum X1Mouse = 4+ fromEnum X2Mouse = 5 toEnum 1 = LeftMouse toEnum 2 = MiddleMouse@@ -40,26 +45,42 @@ toEnum _ = error "FRP.Helm.Mouse.Mouse.toEnum: bad argument" {-| The current position of the mouse. -}-position :: SignalGen (Signal (Int, Int))-position = effectful $ alloca $ \xptr -> alloca $ \yptr -> do- _ <- SDL.getMouseState xptr yptr- x_ <- peek xptr- y_ <- peek yptr+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_)+ return (fromIntegral x_, fromIntegral y_) {-| The current x-coordinate of the mouse. -}-x :: SignalGen (Signal Int)+x :: Signal Int x = fst <~ position {-| The current y-coordinate of the mouse. -}-y :: SignalGen (Signal Int)+y :: Signal Int y = snd <~ position -{-| The current state of a certain mouse button.- True if the mouse is down, false otherwise. -}-isDown :: Mouse -> SignalGen (Signal Bool)-isDown m = effectful $ do- flags <- SDL.getMouseState nullPtr nullPtr+{-| The current state of the left mouse-button. True when the button is down,+ and false otherwise. -}+isDown :: Signal Bool+isDown = isDownButton LeftMouse - return $ (.&.) (fromIntegral flags) (fromEnum m) /= 0+{-| 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 ()+
+ src/FRP/Helm/Random.hs view
@@ -0,0 +1,81 @@+{-# 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
+ src/FRP/Helm/Sample.hs view
@@ -0,0 +1,29 @@+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
+ src/FRP/Helm/Signal.hs view
@@ -0,0 +1,122 @@+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.+-}+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
src/FRP/Helm/Time.hs view
@@ -1,8 +1,7 @@ {-| Contains functions for composing units of time and signals that sample from the game clock. -} module FRP.Helm.Time (- -- * Types+ -- * Units Time,- -- * Composing millisecond, second, minute,@@ -11,19 +10,27 @@ inSeconds, inMinutes, inHours,+ -- * Tickers fps,- -- * Clock State- running,- delta,- delay+ fpsWhen,+ every,+ -- * Timing+ timestamp,+ delay,+ since ) where import Control.Applicative-import FRP.Elerea.Simple hiding (delay)-import qualified Graphics.UI.SDL as SDL+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. -}+{-| 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. -}@@ -58,31 +65,82 @@ inHours :: Time -> Double inHours n = n / hour -{-| Converts a frames-per-second value into a time value. -}-fps :: Int -> Time-fps n = second / realToFrac n+{-| 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 -{-| A signal that returns the time that the game has been running for when sampled. -}-running :: SignalGen (Signal Time)-running = effectful $ (*) millisecond <$> realToFrac <$> SDL.getTicks+{-| 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 signal that returns the time since it was last sampled when sampled. -}-delta :: SignalGen (Signal Time)-delta = running >>= delta'+{-| 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 -{-| A utility function that does the real magic for 'delta'. -}-delta' :: Signal Time -> SignalGen (Signal Time)-delta' t = fmap ((*) millisecond . snd) <$> transfer (0, 0) (\ t2 (t1, _) -> (t2, t2 - t1)) t+{-| 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 = getTime >>= transfer (0,0) update_+ where+ getTime = effectful $ liftM ((second *) . realToFrac) getPOSIXTime+ update_ _ new old = let delta = new - fst old+ in if delta >= t then (new, delta) else old -{-| A signal that blocks the game thread for a certain amount of time when sampled and then returns the- amount of time it blocked for. Please note that delaying by values smaller than 1 millisecond can have- platform-specific results. -}-delay :: Time -> SignalGen (Signal Time)-delay t = effectful $ do- before <- SDL.getTicks+{-| 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. - SDL.delay fixed- (*) millisecond <$> realToFrac <$> flip (-) before <$> SDL.getTicks+ 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- fixed = max 0 $ round $ inMilliseconds t+ -- 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))
− src/FRP/Helm/Transition.hs
@@ -1,225 +0,0 @@-{-# LANGUAGE DefaultSignatures, TypeOperators, FlexibleContexts, FlexibleInstances #-}-{-| Contains all data structures for describing transitions, composing and animating them. -}-module FRP.Helm.Transition (- -- * Types- Transition,- TransitionStatus(..),- Interpolate(..),- -- * Creating- waypoint,- startWith,- fromList,- -- * Transitions- transition,- length-) where--import Control.Applicative-import FRP.Elerea.Simple-import FRP.Helm.Color (Color)-import FRP.Helm.Time (Time, inSeconds)-import Data.List (find)-import Prelude hiding (length)-import Data.Maybe (fromJust)-import GHC.Float-import Data.Word-import Data.Int-import GHC.Generics-import Control.Monad.Writer.Lazy-import Control.Monad.State.Lazy--{-| A type describing a combosable transition. The writer keeps record of all the frames in the transition.- The state holds the current value of the transition. This allows you to easily compose transitions using do notation. -}-type Transition a = StateT a (Writer [(a, Time)])--{-| This is used only for easier search of frames when transitioning is in progress. -}-data InternalFrame a =- InternalFrame { -- | The initial value in the transition.- s :: a,- -- | The final value in the transition.- e :: a,- -- | The time that the transition will take.- t :: Double,- -- | The transition-relative time of the beginning of this frame.- tend :: Double,- -- | The transition-relative time of the end of this frame.- tstart :: Double- } deriving Show--type InternalTransition a = [InternalFrame a]--{-| A variety of statuses that can be used to control a transition. -}-data TransitionStatus- -- | The transition will repeat forever.- = Cycle- -- | The transition will be paused and won't changed until resumed.- | Pause- -- | The transition is cycled once and then stops.- | Once- -- | The transition will reset to a certain point in time.- | Set Time--{-| Adds a value to the transition monad that will be the next point in the transition. -}-waypoint :: Interpolate a => a -> Time -> Transition a a-waypoint a t = do- tell [(a, t)]- put a- return a--{-| Interpolates between the beginning and the end of the given frame. -}-transFrame :: Interpolate a => InternalFrame a -> Time -> a-transFrame InternalFrame{..} time = interpolate progress s e- where- progress = time / (tend - tstart)--{-| Searches the frame active at the given time and gives back the value of the frame at that time. -}-transitionAt :: Interpolate a => InternalTransition a -> Time -> a-transitionAt pks timeUnsafe = transFrame currentTransition currentTime- where- currentTime = time - tstart currentTransition- currentTransition = fromJust $ find (\InternalFrame { .. } -> tend >= time) pks- time = cycleTime pks timeUnsafe--{-| Turns the internal representation of a transition into a signal.- The provided time signal acts as the inner clock of the transition.- The status signal can be used to control the transition, deciding whether- the transition should cycle, go to a specific time, pause, stop or run once. -}-transition :: Interpolate a => SignalGen (Signal Time) -> SignalGen (Signal TransitionStatus) -> InternalTransition a -> SignalGen (Signal a)-transition _ _ [] = error "empty transitions don't have any default value"-transition dtGen statusGen trans = do- dt <- dtGen- status <- statusGen- time <- transfer2 0 step' status $ inSeconds <$> dt- - return $ transitionAt trans <$> time- - where- step' Cycle dt t = cycleTime trans (dt + t)- step' Pause _ t = t- step' Once dt t = if newT < length trans then newT- else length trans- where newT = dt + t- step' (Set t) _ _ = inSeconds t--{-| Converts a list of tuples describing a waypoint value and time into a transition.- The first element in the list is the starting value and time of the transition.-- > color = transition (constant $ Time.fps 60) (constant Cycle) $ fromList [(white, 0), (green, 2 * second), (red, 5 * second), (black, 1 * second), (yellow, 2 * second)] -}-fromList :: Interpolate a => [(a,Time)] -> InternalTransition a-fromList [] = error "empty transitions don't have any default value"-fromList ((v1, d1) : xs) = scanl (\InternalFrame { .. } (v, d) -> InternalFrame e v d (tend + d) tend) first xs- where- first = InternalFrame v1 v1 d1 d1 0--{-| Starts a transition with an initial value. -- > color = transition (constant $ Time.fps 60) (constant Cycle) $ startWith white $ do- > waypoint green (2 * second)- > waypoint red (5 * second)- > waypoint black (1 * second)- > waypoint yellow (2 * second)--}-startWith :: Interpolate a => a -> Transition a b -> InternalTransition a-startWith beginning transitionMonad = fromList $ snd $ runWriter $ evalStateT (tell [(beginning, 0)] >> transitionMonad) beginning--{-| Given an animation, a function is created which loops the time of the animation- to always be in the animations length boundary. -}-cycleTime :: InternalTransition a -> Time -> Time-cycleTime [] = const 0-cycleTime anim = cycleTime' (length anim)--{-| Helper function which makes a timer loop through an time interval. -}-cycleTime' :: Time -> Time -> Time-cycleTime' l t- | t > l = cycleTime' l (t-l)- | t < 0 = cycleTime' l (l+t)- | otherwise = t--{-| How long it takes for the provided transition to end. -}-length :: InternalTransition a -> Double-length = tend . last--{-| Defines a value that can be interpolated. An example instance of this class follows:-- > data YourDataType = YourDataConstructor SomeInterpolableType SomeOtherInterpolableType deriving Generic- >- > instance Interpolate YourDataType- > interpolate 0.5 (YourDataConstructor 3 5) (YourDataConstructor 5 7) == YourDataConstructor 4 6- -}-class Interpolate a where- interpolate :: Double -> a -> a -> a- default interpolate :: (Generic a, GInterpolate (Rep a)) => Double -> a -> a -> a- interpolate d a b = to $ ginterpolate d (from a) (from b)--class GInterpolate a where- ginterpolate :: Double -> a b -> a b -> a b--instance GInterpolate V1 where- ginterpolate _ _ b = b--instance GInterpolate U1 where- ginterpolate _ _ b = b--instance (GInterpolate a, GInterpolate b) => GInterpolate (a :*: b) where- ginterpolate d (a1 :*: b1) (a2 :*: b2) = ginterpolate d a1 a2 :*: ginterpolate d b1 b2--instance (GInterpolate a, GInterpolate b) => GInterpolate (a :+: b) where- ginterpolate d (L1 a) (L1 b) = L1 $ ginterpolate d a b- ginterpolate d (R1 a) (R1 b) = R1 $ ginterpolate d a b- ginterpolate _ (L1 _) (R1 b) = R1 b- ginterpolate _ (R1 _) (L1 b) = L1 b--instance (GInterpolate a) => GInterpolate (M1 i c a) where- ginterpolate d (M1 a) (M1 b) = M1 $ ginterpolate d a b--instance (Interpolate a) => GInterpolate (K1 i a) where- ginterpolate d (K1 a) (K1 b) = K1 $ interpolate d a b--instance Interpolate Double where- interpolate p a b = b * p + a * (1-p)--instance Interpolate Float where- interpolate p a b = b * double2Float p + a * double2Float (1 - p)--instance Interpolate Char where- interpolate _ _ b = b--integralInterpolate :: Integral a => Double -> a -> a -> a-integralInterpolate d a b = ceiling $ interpolate d (fromIntegral a :: Double) (fromIntegral b :: Double)--instance Interpolate Word where- interpolate = integralInterpolate--instance Interpolate Word8 where- interpolate = integralInterpolate--instance Interpolate Word16 where- interpolate = integralInterpolate--instance Interpolate Word32 where- interpolate = integralInterpolate--instance Interpolate Word64 where- interpolate = integralInterpolate--instance Interpolate Int where- interpolate = integralInterpolate--instance Interpolate Int8 where- interpolate = integralInterpolate--instance Interpolate Int16 where- interpolate = integralInterpolate--instance Interpolate Int32 where- interpolate = integralInterpolate--instance Interpolate Int64 where- interpolate = integralInterpolate--instance Interpolate Integer where- interpolate = integralInterpolate--instance Interpolate Bool-instance Interpolate (Double, Double)-instance Interpolate Color
src/FRP/Helm/Utilities.hs view
@@ -7,34 +7,8 @@ -- * Applying (<|), (|>),- -- * Random numbers- random,- randomR,- -- * Composing- constant,- combine,- lift,- lift2,- lift3,- (<~),- (~~),- -- * Accumulating- foldp,- count,- countIf,- -- * DYEL?- lift4,- lift5,- lift6,- lift7,- lift8 ) where -import Control.Applicative ((<*>))-import Control.Monad ((>=>))-import FRP.Elerea.Simple-import System.Random (Random, randomIO, randomRIO)- {-| Converts radians into the standard angle measurement (radians). -} radians :: Double -> Double radians n = n@@ -56,93 +30,3 @@ more consistent. -} (<|) :: (a -> b) -> a -> b (<|) = ($)--{-| Creates a signal that never changes. -}-constant :: a -> SignalGen (Signal a)-constant = return . return--{-| Combines a list of signals into a signal of lists. -}-combine :: [SignalGen (Signal a)] -> SignalGen (Signal [a])-combine = sequence >=> return . sequence--{-| Applies a function to a signal producing a new signal. This is a wrapper around the builtin- 'fmap' function that automatically binds the input signal out of the signal generator.-- > render <~ Window.dimensions- -}-lift :: (a -> b) -> SignalGen (Signal a) -> SignalGen (Signal b)-lift = fmap . fmap--{-| Applies a function to two signals. -}-lift2 :: (a -> b -> c) -> SignalGen (Signal a) -> SignalGen (Signal b) -> SignalGen (Signal c)-lift2 f a b = f <~ a ~~ b--{-| Applies a function to three signals. -}-lift3 :: (a -> b -> c -> d) -> SignalGen (Signal a) -> SignalGen (Signal b) -> SignalGen (Signal c) -> SignalGen (Signal d)-lift3 f a b c = f <~ a ~~ b ~~ c--{-| Applies a function to four signals. -}-lift4 :: (a -> b -> c -> d -> e) -> SignalGen (Signal a) -> SignalGen (Signal b) -> SignalGen (Signal c) -> SignalGen (Signal d)- -> SignalGen (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) -> SignalGen (Signal a) -> SignalGen (Signal b) -> SignalGen (Signal c) -> SignalGen (Signal d)- -> SignalGen (Signal e) -> SignalGen (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) -> SignalGen (Signal a) -> SignalGen (Signal b) -> SignalGen (Signal c) -> SignalGen (Signal d)- -> SignalGen (Signal e) -> SignalGen (Signal f) -> SignalGen (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) -> SignalGen (Signal a) -> SignalGen (Signal b) -> SignalGen (Signal c) -> SignalGen (Signal d)- -> SignalGen (Signal e) -> SignalGen (Signal f) -> SignalGen (Signal g) -> SignalGen (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) -> SignalGen (Signal a) -> SignalGen (Signal b) -> SignalGen (Signal c) -> SignalGen (Signal d)- -> SignalGen (Signal e) -> SignalGen (Signal f) -> SignalGen (Signal g) -> SignalGen (Signal h)- -> SignalGen (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) -> SignalGen (Signal a) -> SignalGen (Signal b)-(<~) = lift--infixl 4 <~--{-| Applies a function within a signal to a signal. This is a wrapper around the builtin '<*>' operator- that automatically binds the input signal out of the signal generator.-- > render <~ Window.dimensions ~~ Window.position- -}-(~~) :: SignalGen (Signal (a -> b)) -> SignalGen (Signal a) -> SignalGen (Signal b)-(~~) = (<*>) . fmap (<*>)--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. -}-foldp :: (a -> b -> b) -> b -> SignalGen (Signal a) -> SignalGen (Signal b)-foldp f ini = (>>= transfer ini f)--{-| Creates a signal that counts the amount of times it has been sampled. -}-count :: SignalGen (Signal Int)-count = stateful 0 (+ 1)--{-| Creates a signal that counts the amount of times an input signal has passed- a predicate when sampled. -}-countIf :: (a -> Bool) -> SignalGen (Signal a) -> SignalGen (Signal Int)-countIf f = foldp (\v c -> c + fromEnum (f v)) 0--{-| Creates a signal of a random number. -}-random :: Random a => SignalGen (Signal a)-random = effectful randomIO--{-| Creates a signal of a random number based on the given range. -}-randomR :: Random a => (a, a) -> SignalGen (Signal a)-randomR = effectful . randomRIO
src/FRP/Helm/Window.hs view
@@ -1,29 +1,53 @@ {-| Contains signals that sample input from the game window. -} module FRP.Helm.Window (- -- * Dimensions- dimensions, width, height+ -- * Dimensions+ dimensions,+ width,+ height,+ position ) where +import Control.Applicative (pure) import Foreign.Marshal.Alloc import Foreign.Storable-import FRP.Elerea.Simple-import FRP.Helm (Engine(..))-import FRP.Helm.Utilities+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 :: Engine -> SignalGen (Signal (Int, Int))-dimensions (Engine { window }) = effectful $ alloca $ \wptr -> alloca $ \hptr -> do- SDL.getWindowSize window wptr hptr+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+ w <- peek wptr+ h <- peek hptr - return (fromIntegral w, fromIntegral h)+ 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 :: Engine -> SignalGen (Signal Int)-width engine = fst <~ dimensions engine+width :: Signal Int+width = fst <~ dimensions {-| The current height of the window. -}-height :: Engine -> SignalGen (Signal Int)-height engine = snd <~ dimensions engine+height :: Signal Int+height = snd <~ dimensions