summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--reactive-banana-sdl2.cabal8
-rw-r--r--src/Reactive/Banana/SDL2.hs73
-rw-r--r--src/Reactive/Banana/SDL2/Types.hs18
-rw-r--r--src/Reactive/Banana/SDL2/Util.hs105
4 files changed, 115 insertions, 89 deletions
diff --git a/reactive-banana-sdl2.cabal b/reactive-banana-sdl2.cabal
index 55c62af..e7452cc 100644
--- a/reactive-banana-sdl2.cabal
+++ b/reactive-banana-sdl2.cabal
@@ -1,5 +1,5 @@
name: reactive-banana-sdl2
-version: 0.1.0.0
+version: 0.1.1.0
synopsis: Reactive Banana integration with SDL2
description: Provides bindings and convenience functions for using Reactive Banana with SDL2.
Please see README.md
@@ -19,9 +19,9 @@ library
exposed-modules: Reactive.Banana.SDL2
, Reactive.Banana.SDL2.Types
, Reactive.Banana.SDL2.Util
- build-depends: base >= 4.7 && < 5
- , reactive-banana >= 1.1.0 && < 1.2.0
- , sdl2 >= 2.1.0 && < 2.2.0
+ build-depends: base >= 4.7 && < 5
+ , reactive-banana >= 1.1.0 && < 1.2.0
+ , sdl2 >= 2.1.0 && < 2.2.0
default-language: Haskell2010
diff --git a/src/Reactive/Banana/SDL2.hs b/src/Reactive/Banana/SDL2.hs
index 7e7e537..07e8f4a 100644
--- a/src/Reactive/Banana/SDL2.hs
+++ b/src/Reactive/Banana/SDL2.hs
@@ -1,50 +1,59 @@
-module Reactive.Banana.SDL2 ( module Reactive.Banana.SDL2.Types
- , module Reactive.Banana.SDL2.Util
- , getSDLEventSource, runSDLPump
- )where
+module Reactive.Banana.SDL2 (
+ module Reactive.Banana.SDL2.Types
+ , module Reactive.Banana.SDL2.Util
+ , getSDLEventSource
+ , runSDLPump
+ , runCappedSDLPump
+ ) where
import Control.Monad
import Data.Word
import Reactive.Banana as R
import Reactive.Banana.Frameworks (newAddHandler)
+import qualified SDL as SDL
+import qualified SDL.Raw as SDLR
+
import Reactive.Banana.SDL2.Types
import Reactive.Banana.SDL2.Util
-import SDL
-import SDL.Time
-import qualified SDL.Raw as SDLR
getSDLEventSource :: IO SDLEventSource
getSDLEventSource = SDLEventSource <$> newAddHandler <*> newAddHandler
--- | one step in the main event loop, returning False when it needs to stop
-
+-- | One step in the main event loop, returning False when it needs to stop.
mainSDLPump :: SDLEventSource -> IO Bool
-mainSDLPump es= do
- let esdl = getSDLEvent es
- etick = getTickEvent es
- tick <- SDL.ticks
- me <- collectEvents
-
- case me of
- Nothing -> return False
- Just e -> do
- mapM (fire esdl) e
- fire etick tick
- return True
-
--- | collect SDL events
--- return Nothing on quit, otherwise the last event
+mainSDLPump sdlEventSource = do
+ let esdl = getSDLEvent sdlEventSource
+ etick = getTickEvent sdlEventSource
+ tick <- SDL.ticks
+ mEvents <- collectEvents
+ case mEvents of Nothing -> return False
+ Just events -> do mapM (fire esdl) events
+ fire etick tick
+ return True
+
+-- | Collect SDL events.
+-- Evaluate to Nothing on quit, otherwise evaluates to the last event.
collectEvents :: IO (Maybe [SDL.EventPayload])
collectEvents = do
- e <- SDL.pollEvent
- case fmap eventPayload e of
- Just SDL.QuitEvent -> return Nothing
- Nothing -> return (Just [])
- Just ev -> liftM (liftM (ev:)) collectEvents
+ e <- SDL.pollEvent
+ case fmap SDL.eventPayload e of
+ Just SDL.QuitEvent -> return Nothing
+ Nothing -> return (Just [])
+ Just event -> liftM (liftM (event:)) collectEvents
+-- | The main event loop.
runSDLPump :: SDLEventSource -> IO ()
-runSDLPump es = whileM (mainSDLPump es)
-
-runCappedSDLPump = undefined
+runSDLPump sdlEventSource = whileM $ mainSDLPump sdlEventSource
+
+-- | The main event loop, capped at a given FPS.
+runCappedSDLPump :: Word16 -> SDLEventSource -> IO ()
+runCappedSDLPump fpsCap sdlEventSource = do
+ startTick <- SDL.ticks
+ shouldContinue <- mainSDLPump sdlEventSource
+ endTick <- SDL.ticks
+ let ticks = fromIntegral $ endTick - startTick
+ secsPerFrame = fromIntegral $ 1000 `div` fpsCap
+ when (ticks < secsPerFrame) $ SDL.delay (secsPerFrame - ticks)
+ when shouldContinue $ runCappedSDLPump fpsCap sdlEventSource
diff --git a/src/Reactive/Banana/SDL2/Types.hs b/src/Reactive/Banana/SDL2/Types.hs
index 616e164..e4c6149 100644
--- a/src/Reactive/Banana/SDL2/Types.hs
+++ b/src/Reactive/Banana/SDL2/Types.hs
@@ -1,18 +1,26 @@
-- | Types used for events
-module Reactive.Banana.SDL2.Types ( EventSource, SDLEventSource (..), WrappedEvent
- , TickEvent ) where
+module Reactive.Banana.SDL2.Types (
+ EventSource
+ , SDLEventSource (..)
+ , WrappedEvent
+ , TickEvent
+ ) where
import Data.Word
import Reactive.Banana as R
import Reactive.Banana.Frameworks (AddHandler)
-import SDL
+import qualified SDL as SDL
+
-- | Generic Event Source
type EventSource a = (AddHandler a, a -> IO ())
--- | an event containing a list of SDL event
+
+-- | An event containing a list of SDL event
type WrappedEvent = R.Event SDL.EventPayload
+
-- | SDL Tick event
-type TickEvent = R.Event Word32
+type TickEvent = R.Event Word32
+
-- | SDL Event Source
data SDLEventSource = SDLEventSource { getSDLEvent :: EventSource SDL.EventPayload
, getTickEvent :: EventSource Word32 }
diff --git a/src/Reactive/Banana/SDL2/Util.hs b/src/Reactive/Banana/SDL2/Util.hs
index 3df61ae..22ac96b 100644
--- a/src/Reactive/Banana/SDL2/Util.hs
+++ b/src/Reactive/Banana/SDL2/Util.hs
@@ -1,11 +1,20 @@
{-# LANGUAGE RecursiveDo #-}
-- | Functions on events
-module Reactive.Banana.SDL2.Util ( addHandler, fire, sdlEvent, tickEvent
- , keyEvent, keyDownEvent, keyUpEvent, mouseEvent, mouseButtonEvent
- , keyFilter, keyUpFilter
- , mouseEventWithin, tickDiffEvent
- , whileM, successive ) where
+module Reactive.Banana.SDL2.Util (
+ addHandler, fire, sdlEvent, tickEvent
+ , keyEvent
+ , keyDownEvent
+ , keyUpEvent
+ , mouseEvent
+ , mouseButtonEvent
+ , keyFilter
+ , keyUpFilter
+ , mouseEventWithin
+ , tickDiffEvent
+ , whileM
+ , successive
+ ) where
import Control.Monad (liftM, when)
import Reactive.Banana as R
@@ -14,15 +23,16 @@ import Reactive.Banana.SDL2.Types
import SDL
import SDL.Raw as SDLR
--- | run while the given computation returns True
+
+-- | Run while the given computation returns True
whileM :: IO Bool -> IO ()
whileM f = f >>= (\x -> when x $ whileM f)
--- | get the AddHandler from a EventSource
+-- | Get the AddHandler from a EventSource
addHandler :: EventSource a -> AddHandler a
addHandler = fst
--- | fire the event from an Event Source
+-- | Fire the event from an Event Source
fire :: EventSource a -> a -> IO ()
fire = snd
@@ -34,13 +44,14 @@ sdlEvent = fromAddHandler . addHandler . getSDLEvent
tickEvent :: SDLEventSource -> MomentIO TickEvent
tickEvent = fromAddHandler . addHandler . getTickEvent
--- | event carrying the difference between the last two SDL ticks
+-- | Event carrying the difference between the last two SDL ticks.
tickDiffEvent :: SDLEventSource -> MomentIO TickEvent
tickDiffEvent source = mdo
te <- tickEvent source
- s <- (successive (\a b-> if b > a then Just (b - a) else Nothing)) te
+ s <- (successive (\a b -> if b > a then Just (b - a) else Nothing)) te
return s
+-- | Filter and aggregate an event stream based on a function.
successive :: (a -> a -> Maybe b) -> R.Event a -> MomentIO (R.Event b)
successive f e = (\b -> filterJust (b <@> e)) <$> stepper (const Nothing) (f <$> e)
-- Below same as about but with mdo; easier to debug (at least to me)
@@ -51,63 +62,61 @@ successive f e = (\b -> filterJust (b <@> e)) <$> stepper (const Nothing) (f <$>
-- stepperB :: (a -> a -> Maybe b) -> R.Event a -> MomentIO (Behavior (a -> Maybe b ))
-- stepperB f e = stepper (const Nothing) (f <$> e)
-
--- | filter any key events
+-- | Filter any key events
keyEvent :: WrappedEvent -> WrappedEvent
-keyEvent = filterE isKey
- where
- isKey e = case e of
- SDL.KeyboardEvent _ -> True
- otherwise -> False
+keyEvent = filterE isKey
+ where
+ isKey e = case e of
+ SDL.KeyboardEvent _ -> True
+ otherwise -> False
--- | event carrying the key pressed down
+-- | Event carrying the key pressed down
keyDownEvent :: WrappedEvent -> R.Event SDL.Keysym
-keyDownEvent= filterJust . (isDown <$>) . keyEvent
- where isDown (SDL.KeyboardEvent (KeyboardEventData _ Pressed _ k)) = Just k
- isDown _ = Nothing
+keyDownEvent = filterJust . (isDown <$>) . keyEvent
+ where isDown (SDL.KeyboardEvent (KeyboardEventData _ Pressed _ k)) = Just k
+ isDown _ = Nothing
--- | event carrying the key pressed up
+-- | Event carrying the key pressed up
keyUpEvent :: WrappedEvent -> R.Event SDL.Keysym
keyUpEvent = filterJust . (isDown <$>) . keyEvent
- where isDown (SDL.KeyboardEvent (KeyboardEventData _ Released _ k)) = Just k
- isDown _ = Nothing
+ where isDown (SDL.KeyboardEvent (KeyboardEventData _ Released _ k)) = Just k
+ isDown _ = Nothing
--- | filter any mouse event (button or move)
+-- | Filter any mouse event (button or move)
mouseEvent :: WrappedEvent -> WrappedEvent
mouseEvent esdl = unionWith f mouseMotion (mouseButtonEvent esdl)
- where
- f e1 e2 = e2
- mouseMotion = filterE isMotion $ esdl
- isMotion e = case e of
- SDL.MouseMotionEvent MouseMotionEventData {} -> True
- otherwise -> False
-
--- | mouse button event
+ where
+ f e1 e2 = e2
+ mouseMotion = filterE isMotion $ esdl
+ isMotion e = case e of
+ SDL.MouseMotionEvent MouseMotionEventData {} -> True
+ otherwise -> False
+
+-- | Mouse button event
mouseButtonEvent :: WrappedEvent -> WrappedEvent
mouseButtonEvent = filterE isButton
- where
- isButton e = case e of
- SDL.MouseButtonEvent MouseButtonEventData{} -> True
- otherwise -> False
+ where
+ isButton e = case e of
+ SDL.MouseButtonEvent MouseButtonEventData{} -> True
+ otherwise -> False
--- | mouse event occuring inside a given area
+-- | Mouse event occuring inside a given area
mouseEventWithin :: Rect -> WrappedEvent -> WrappedEvent
mouseEventWithin ~(Rect x y w h) = filterE isWithin
- where
- within pos = undefined
- isWithin e = case e of
- SDL.MouseMotionEvent (MouseMotionEventData _ _ _ pos _) -> within pos
- SDL.MouseButtonEvent (MouseButtonEventData _ _ _ _ _ pos) -> within pos
- otherwise -> False
-
-
--- | filter an event on a particular key being held down
+ where
+ within pos = undefined
+ isWithin e = case e of
+ SDL.MouseMotionEvent (MouseMotionEventData _ _ _ pos _) -> within pos
+ SDL.MouseButtonEvent (MouseButtonEventData _ _ _ _ _ pos) -> within pos
+ otherwise -> False
+
+-- | Filter an event on a particular key being held down
keyFilter :: SDL.Keycode-> SDL.EventPayload -> Bool
keyFilter k (SDL.KeyboardEvent (KeyboardEventData _ Pressed _ (SDL.Keysym _ k' _ )))
| k == k' = True
keyFilter _ _ = False
--- | filter an event on a particular key being released
+-- | Filter an event on a particular key being released
keyUpFilter :: SDL.Keycode -> SDL.EventPayload -> Bool
keyUpFilter k (SDL.KeyboardEvent (KeyboardEventData _ Released _ (SDL.Keysym _ k' _ )))
| k == k' = True