diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -1,8 +1,13 @@ +2017-08-17 Ivan Perez + * Yampa.cabal: Version bump (0.10.6.1). + * examples/: new examples, using wiimote. + * src/: Minor improvements to documentation. + 2017-05-05 Ivan Perez * Yampa.cabal: Version bump (0.10.6). * tests/: do not warn if they contain tabs. - * src/: Includes combinators to deal with collections, - to iterate over time (for custom/discrete integration), + * src/: Includes combinators to deal with collections, + to iterate over time (for custom/discrete integration), implements ArrowChoice. 2017-04-26 Ivan Perez diff --git a/Yampa.cabal b/Yampa.cabal --- a/Yampa.cabal +++ b/Yampa.cabal @@ -1,5 +1,5 @@ name: Yampa -version: 0.10.6 +version: 0.10.6.1 cabal-version: >= 1.8 license: BSD3 license-file: LICENSE @@ -49,6 +49,10 @@ default: True manual: True +flag examples + default: False + manual: True + library hs-source-dirs: src ghc-options : -O3 -Wall -fno-warn-name-shadowing @@ -132,6 +136,30 @@ build-depends: base, Yampa + +executable yampa-examples-sdl-bouncingbox + main-is: MainBouncingBox.hs + hs-source-dirs: examples/yampa-game/ + ghc-options : -O3 -Wall -fno-warn-name-shadowing + build-Depends: base < 5, random, deepseq, SDL, Yampa + if !flag(examples) + buildable: False + +executable yampa-examples-sdl-circlingmouse + main-is: MainCircleMouse.hs + hs-source-dirs: examples/yampa-game/ + ghc-options : -O3 -Wall -fno-warn-name-shadowing + build-Depends: base < 5, random, deepseq, SDL, Yampa + if !flag(examples) + buildable: False + +executable yampa-examples-sdl-wiimote + main-is: MainWiimote.hs + hs-source-dirs: examples/yampa-game/ + ghc-options : -O3 -Wall -fno-warn-name-shadowing -rtsopts + build-Depends: base < 5, random, deepseq, SDL, hcwiid, Yampa + if !flag(examples) + buildable: False source-repository head type: git diff --git a/examples/yampa-game/MainBouncingBox.hs b/examples/yampa-game/MainBouncingBox.hs new file mode 100644 --- /dev/null +++ b/examples/yampa-game/MainBouncingBox.hs @@ -0,0 +1,100 @@ +{-# LANGUAGE Arrows #-} +import Data.IORef +import Debug.Trace +import FRP.Yampa as Yampa +import Graphics.UI.SDL as SDL + +-- Helper functions +import YampaSDL + +width :: Num a => a +width = 640 +height :: Num a => a +height = 480 + +-- | Reactimation. +-- +-- This main function runs an FRP system by producing a signal, passing it +-- through a signal function, and consuming it. +-- +-- The first two arguments to reactimate are the value of the input signal +-- at time zero and at subsequent times, together with the times between +-- samples. +-- +-- The third argument to reactimate is the output consumer that renders +-- the signal. +-- +-- The last argument is the actual signal function. +-- +main = do + timeRef <- yampaSDLTimeInit + reactimate initGraphs + (\_ -> do + dtSecs <- yampaSDLTimeSense timeRef + return (dtSecs, Nothing)) + (\_ e -> display e >> return False) + (bounce (fromIntegral height / 2) 0) + +-- * FRP stuff + +-- | Vertical coordinate and velocity of a falling mass starting +-- at a height with an initial velocity. +falling :: Double -> Double -> SF () (Double, Double) +falling y0 v0 = proc () -> do + vy <- (v0+) ^<< integral -< gravity + py <- (y0+) ^<< integral -< vy + returnA -< (py, vy) + +-- | Vertical coordinate and velocity of a bouncing mass starting +-- at a height with an initial velicity. +bounce :: Double -> Double -> SF () (Double, Double) +bounce y vy = switch (falling y vy >>> (Yampa.identity &&& hitBottom)) + (\(y, vy) -> bounce y (-vy)) + +-- | Fire an event when the input height and velocity indicate +-- that the object has hit the bottom (so it's falling and the +-- vertical position is under the floor). +hitBottom :: SF (Double, Double) (Yampa.Event (Double, Double)) +hitBottom = arr (\(y,vy) -> + let boxTop = y + fromIntegral boxSide + in if (boxTop > fromIntegral height) && (vy > 0) + then Yampa.Event (y, vy) + else Yampa.NoEvent) + +-- * Graphics + +-- | Initialise rendering system. +initGraphs :: IO () +initGraphs = do + -- Initialise SDL + SDL.init [InitVideo] + + -- Create window + screen <- setVideoMode width height 16 [SWSurface] + setCaption "Test" "" + +-- | Display a box at a position. +display :: (Double, Double) -> IO() +display (boxY,_) = do + -- Obtain surface + screen <- getVideoSurface + + -- Paint screen green + let format = surfaceGetPixelFormat screen + bgColor <- mapRGB format 55 60 64 + fillRect screen Nothing bgColor + + -- Paint small red square, at an angle 'angle' with respect to the center + foreC <- mapRGB format 212 108 73 + let x = (width - boxSide) `div` 2 + y = round boxY + fillRect screen (Just (Rect x y boxSide boxSide)) foreC + + -- Double buffering + SDL.flip screen + +gravity :: Double +gravity = 6.2 + +boxSide :: Int +boxSide = 30 diff --git a/examples/yampa-game/MainCircleMouse.hs b/examples/yampa-game/MainCircleMouse.hs new file mode 100644 --- /dev/null +++ b/examples/yampa-game/MainCircleMouse.hs @@ -0,0 +1,107 @@ +{-# LANGUAGE Arrows #-} +import Data.IORef +import Debug.Trace +import FRP.Yampa as Yampa +import Graphics.UI.SDL as SDL + +-- Helper functions +import YampaSDL + +width :: Num a => a +width = 640 +height :: Num a => a +height = 480 + +-- | Reactimation. +-- +-- This main function runs an FRP system by producing a signal, passing it +-- through a signal function, and consuming it. +-- +-- The first two arguments to reactimate are the value of the input signal +-- at time zero and at subsequent times, together with the times between +-- samples. +-- +-- The third argument to reactimate is the output consumer that renders +-- the signal. +-- +-- The last argument is the actual signal function. +-- +main = do + timeRef <- newIORef (0 :: Int) + controllerRef <- newIORef $ Controller (0,0) + reactimate (initGraphs >> readIORef controllerRef) + (\_ -> do + dtSecs <- yampaSDLTimeSense timeRef + mInput <- sdlGetController controllerRef + -- print (mInput) + return (dtSecs, Just mInput) + ) + (\_ e -> display (e) >> return False) + player + +-- * FRP stuff + +-- | Player is going in circles around the input controller position +player :: SF Controller (Double, Double) +player = arr controllerPos >>> inCircles + +-- | Coordinate of a body going in circles around another body. +inCircles :: SF (Double, Double) (Double, Double) +inCircles = proc (centerX, centerY) -> do + t <- time -< () + let x = centerX + cos t * radius + y = centerY + sin t * radius + radius = 30 + returnA -< (x,y) + +-- * SDL stuff + +-- ** Input subsystem + +-- | Input controller +data Controller = Controller + { controllerPos :: (Double, Double) + } + +-- | Give a controller, refresh its state and return the latest value. +-- We need a non-blocking controller-polling function. +sdlGetController :: IORef Controller -> IO Controller +sdlGetController controllerState = do + state <- readIORef controllerState + e <- pollEvent + case e of + MouseMotion x y _ _ -> writeIORef controllerState (Controller (fromIntegral x, fromIntegral y)) >> sdlGetController controllerState + _ -> return state + +-- * Graphics + +-- | Initialise rendering system. +initGraphs :: IO () +initGraphs = do + -- Initialise SDL + SDL.init [InitVideo] + + -- Create window + screen <- SDL.setVideoMode width height 16 [SWSurface] + SDL.setCaption "Test" "" + +-- | Display a box at a position. +display :: (Double, Double) -> IO() +display (playerX, playerY) = do + -- Obtain surface + screen <- getVideoSurface + + -- Paint screen green + let format = surfaceGetPixelFormat screen + bgColor <- mapRGB format 55 60 64 + fillRect screen Nothing bgColor + + -- Paint small red square, at an angle 'angle' with respect to the center + foreC <- mapRGB format 212 108 73 + let side = 10 + x = round playerX + y = round playerY + fillRect screen (Just (Rect x y side side)) foreC + + -- Double buffering + SDL.flip screen diff --git a/examples/yampa-game/MainWiimote.hs b/examples/yampa-game/MainWiimote.hs new file mode 100644 --- /dev/null +++ b/examples/yampa-game/MainWiimote.hs @@ -0,0 +1,125 @@ +{-# LANGUAGE Arrows #-} +import Control.Monad +import Data.IORef +import Data.Maybe +import Debug.Trace +import FRP.Yampa as Yampa +import Graphics.UI.SDL as SDL +import System.CWiid + +-- Helper functions +import YampaSDL + +width :: Num a => a +width = 640 +height :: Num a => a +height = 480 + +-- | Reactimation. +-- +-- This main function runs an FRP system by producing a signal, passing it +-- through a signal function, and consuming it. +-- +-- The first two arguments to reactimate are the value of the input signal +-- at time zero and at subsequent times, together with the times between +-- samples. +-- +-- The third argument to reactimate is the output consumer that renders +-- the signal. +-- +-- The last argument is the actual signal function. +-- +main = do + mWiimote <- initializeWiimote + timeRef <- newIORef (0 :: Int) + if isNothing mWiimote + then putStrLn "Couldn't find wiimote" + else do let wiimote = fromJust mWiimote + reactimate (initGraphs >> senseWiimote wiimote) + (\_ -> do + dtSecs <- yampaSDLTimeSense timeRef + mInput <- senseWiimote wiimote + return (dtSecs, Just mInput) + ) + (\_ e -> display (e) >> return False) + player + +-- Pure SF +inCircles :: SF (Double, Double) (Double, Double) +inCircles = proc (centerX, centerY) -> do + t <- time -< () + let x = centerX + cos t * radius + y = centerY + sin t * radius + radius = 30 + returnA -< (x,y) + +-- * Graphics + +-- | Initialise rendering system. +initGraphs :: IO () +initGraphs = do + -- Initialise SDL + SDL.init [InitVideo] + + -- Create window + screen <- SDL.setVideoMode width height 16 [SWSurface] + SDL.setCaption "Test" "" + +-- | Display a box at a position. +display :: (Double, Double) -> IO() +display (playerX, playerY) = do + -- Obtain surface + screen <- getVideoSurface + + -- Paint screen green + let format = surfaceGetPixelFormat screen + bgColor <- mapRGB format 55 60 64 + fillRect screen Nothing bgColor + + -- Paint small red square, at an angle 'angle' with respect to the center + foreC <- mapRGB format 212 108 73 + let side = 30 + x = round playerX + y = round playerY + fillRect screen (Just (Rect x y side side)) foreC + + -- Double buffering + SDL.flip screen + +player :: SF (Double, Double) (Double, Double) +player = inCircles + +senseWiimote :: CWiidWiimote -> IO (Double, Double) +senseWiimote wmdev = do + irs <- cwiidGetIR wmdev + + -- Obtain positions of leds 1 and 2 (with a normal wii bar, those + -- will be the ones we use). + let led1 = irs!!0 + led2 = irs!!1 + + -- Calculate mid point between sensor bar leds + let posX = ((cwiidIRSrcPosX led1) + (cwiidIRSrcPosX led2)) `div` 2 + posY = ((cwiidIRSrcPosY led1) + (cwiidIRSrcPosY led2)) `div` 2 + + -- Calculate proportional coordinates + let propX = fromIntegral (1024 - posX) / width + propY = fromIntegral (max 0 (posY - 384)) / 384.0 + + -- Calculate game area coordinates + let finX = width * propX + finY = height * propY + + return (finX, finY) + +-- | Initializes the wiimote, optionally returning the sensing function. It +-- returns Nothing if the Wiimote cannot be detected. Users should have a BT +-- device and press 1+2 to connect to it. A message is shown on stdout. +initializeWiimote :: IO (Maybe CWiidWiimote) +initializeWiimote = do + putStrLn "Initializing WiiMote. Please press 1+2 to connect." + wm <- cwiidOpen + case wm of + Nothing -> return () + Just wm' -> void $ cwiidSetRptMode wm' 15 -- Enable button reception, acc and IR + return wm diff --git a/src/FRP/Yampa.hs b/src/FRP/Yampa.hs --- a/src/FRP/Yampa.hs +++ b/src/FRP/Yampa.hs @@ -18,8 +18,11 @@ -- -- You can find examples, tutorials and documentation on Yampa here: -- --- +-- -- +-- +-- +-- -- Structuring a hybrid system in Yampa is done based on two main concepts: -- -- * Signal Functions: 'SF'. Yampa is based on the concept of Signal Functions, @@ -39,11 +42,10 @@ -- an input sensing action and an actuation/consumer action and executes -- until explicitly stopped), and 'react' (which executes only one cycle). -- --- This will be the last version of Yampa to include mergeable records, --- point2 and point3, vector2 and vector3, and other auxiliary definitions. The --- internals have now changed. Although not all will be exposed in the next --- version, below is the new project structure. Please, take a look and let us --- know if you think there are any potential problems with it. +-- This will be the last version of Yampa to include mergeable records, point2 +-- and point3, vector2 and vector3, and other auxiliary definitions. The +-- internals have now changed. Also, please let us know if you see any problems +-- with the new project structure. -- -- Main Yampa modules: -- @@ -108,7 +110,7 @@ -- * "FRP.Yampa.Diagnostics" -- -- * "FRP.Yampa.Forceable" --- +-- -- * "FRP.Yampa.Internals" -- No longer in use -- -- * "FRP.Yampa.MergeableRecord" @@ -116,48 +118,42 @@ -- * "FRP.Yampa.Miscellany" -- -- * "FRP.Yampa.Utilities" --- --- CHANGELOG: --- --- * Adds (most) documentation. --- --- * New version using GADTs. --- + -- ToDo: -- --- * Specialize def. of repeatedly. Could have an impact on invaders. +-- - Specialize def. of repeatedly. Could have an impact on invaders. -- --- * New defs for accs using SFAcc +-- - New defs for accs using SFAcc -- --- * Make sure opt worked: e.g. +-- - Make sure opt worked: e.g. -- --- > repeatedly >>> count >>> arr (fmap sqr) +-- - > repeatedly >>> count >>> arr (fmap sqr) -- --- * Introduce SFAccHld. +-- - Introduce SFAccHld. -- --- * See if possible to unify AccHld wity Acc??? They are so close. +-- - See if possible to unify AccHld wity Acc??? They are so close. -- --- * Introduce SScan. BUT KEEP IN MIND: Most if not all opts would --- have been possible without GADTs??? +-- - Introduce SScan. BUT KEEP IN MIND: Most if not all opts would +-- - have been possible without GADTs??? -- --- * Look into pairs. At least pairing of SScan ought to be interesting. +-- - Look into pairs. At least pairing of SScan ought to be interesting. -- --- * Would be nice if we could get rid of first & second with impunity --- thanks to Id optimizations. That's a clear win, with or without --- an explicit pair combinator. +-- - Would be nice if we could get rid of first & second with impunity +-- - thanks to Id optimizations. That's a clear win, with or without +-- - an explicit pair combinator. -- --- * delayEventCat is a bit complicated ... +-- - delayEventCat is a bit complicated ... -- -- -- Random ideas: -- --- * What if one used rules to optimize +-- - What if one used rules to optimize -- - (arr :: SF a ()) to (constant ()) -- - (arr :: SF a a) to identity -- But inspection of invader source code seem to indicate that -- these are not very common cases at all. -- --- * It would be nice if it was possible to come up with opt. rules +-- - It would be nice if it was possible to come up with opt. rules -- that are invariant of how signal function expressions are -- parenthesized. Right now, we have e.g. -- arr f >>> (constant c >>> sf) @@ -169,7 +165,7 @@ -- SFComp :: -> SF' a b -> SF' b c -> SF' a c -- ??? -- --- * The transition function would still be optimized in (pretty much) +-- - The transition function would still be optimized in (pretty much) -- the current way, but it would still be possible to look "inside" -- composed signal functions for lost optimization opts. -- Seems to me this could be done without too much extra effort/no dupl. @@ -185,10 +181,10 @@ -- (sf2', c) = (sfTF' sf2) dt b -- @ -- --- * The ONLY change was changing the constructor from SF' to SFComp and +-- - The ONLY change was changing the constructor from SF' to SFComp and -- adding sf1 and sf2 to the constructor app.! -- --- * An optimized case: +-- - An optimized case: -- cpAuxC1 b sf1 sf2 = SFComp tf sf1 sf2 -- So cpAuxC1 gets an extra arg, and we change the constructor. -- But how to exploit without writing 1000s of rules??? @@ -197,10 +193,10 @@ -- recursive call? E.g. we're in the arr case, and the first sf is another -- arr, so we'd like to combine the two. -- --- * It would also be intersting, then, to know when to STOP playing this +-- - It would also be intersting, then, to know when to STOP playing this -- game, due to the overhead involved. -- --- * Why don't we have a "SWITCH" constructor that indicates that the +-- - Why don't we have a "SWITCH" constructor that indicates that the -- structure will change, and thus that it is worthwile to keep -- looking for opt. opportunities, whereas a plain "SF'" would -- indicate that things NEVER are going to change, and thus we can just @@ -300,7 +296,7 @@ rMerge, -- :: Event a -> Event a -> Event a, infixl 6 merge, -- :: Event a -> Event a -> Event a, infixl 6 mergeBy, -- :: (a -> a -> a) -> Event a -> Event a -> Event a - mapMerge, -- :: (a -> c) -> (b -> c) -> (a -> b -> c) + mapMerge, -- :: (a -> c) -> (b -> c) -> (a -> b -> c) -- -> Event a -> Event b -> Event c mergeEvents, -- :: [Event a] -> Event a catEvents, -- :: [Event a] -> Event [a] diff --git a/src/FRP/Yampa/InternalCore.hs b/src/FRP/Yampa/InternalCore.hs --- a/src/FRP/Yampa/InternalCore.hs +++ b/src/FRP/Yampa/InternalCore.hs @@ -49,48 +49,48 @@ -- "FRP.Yampa.Event" defines events and event-manipulation functions. -- -- Finally, see [<#g:26>] for sources of randomness (useful in games). --- + -- CHANGELOG: -- --- * Adds (most) documentation. +-- - Adds (most) documentation. -- --- * New version using GADTs. +-- - New version using GADTs. -- -- ToDo: -- --- * Specialize def. of repeatedly. Could have an impact on invaders. +-- - Specialize def. of repeatedly. Could have an impact on invaders. -- --- * New defs for accs using SFAcc +-- - New defs for accs using SFAcc -- --- * Make sure opt worked: e.g. +-- - Make sure opt worked: e.g. -- --- > repeatedly >>> count >>> arr (fmap sqr) +-- - > repeatedly >>> count >>> arr (fmap sqr) -- --- * Introduce SFAccHld. +-- - Introduce SFAccHld. -- --- * See if possible to unify AccHld wity Acc??? They are so close. +-- - See if possible to unify AccHld wity Acc??? They are so close. -- --- * Introduce SScan. BUT KEEP IN MIND: Most if not all opts would --- have been possible without GADTs??? +-- - Introduce SScan. BUT KEEP IN MIND: Most if not all opts would +-- - have been possible without GADTs??? -- --- * Look into pairs. At least pairing of SScan ought to be interesting. +-- - Look into pairs. At least pairing of SScan ought to be interesting. -- --- * Would be nice if we could get rid of first & second with impunity --- thanks to Id optimizations. That's a clear win, with or without --- an explicit pair combinator. +-- - Would be nice if we could get rid of first & second with impunity +-- - thanks to Id optimizations. That's a clear win, with or without +-- - an explicit pair combinator. -- --- * delayEventCat is a bit complicated ... +-- - delayEventCat is a bit complicated ... -- -- -- Random ideas: -- --- * What if one used rules to optimize +-- - What if one used rules to optimize -- - (arr :: SF a ()) to (constant ()) -- - (arr :: SF a a) to identity -- But inspection of invader source code seem to indicate that -- these are not very common cases at all. -- --- * It would be nice if it was possible to come up with opt. rules +-- - It would be nice if it was possible to come up with opt. rules -- that are invariant of how signal function expressions are -- parenthesized. Right now, we have e.g. -- arr f >>> (constant c >>> sf) @@ -102,7 +102,7 @@ -- SFComp :: -> SF' a b -> SF' b c -> SF' a c -- ??? -- --- * The transition function would still be optimized in (pretty much) +-- - The transition function would still be optimized in (pretty much) -- the current way, but it would still be possible to look "inside" -- composed signal functions for lost optimization opts. -- Seems to me this could be done without too much extra effort/no dupl. @@ -118,10 +118,10 @@ -- (sf2', c) = (sfTF' sf2) dt b -- @ -- --- * The ONLY change was changing the constructor from SF' to SFComp and +-- - The ONLY change was changing the constructor from SF' to SFComp and -- adding sf1 and sf2 to the constructor app.! -- --- * An optimized case: +-- - An optimized case: -- cpAuxC1 b sf1 sf2 = SFComp tf sf1 sf2 -- So cpAuxC1 gets an extra arg, and we change the constructor. -- But how to exploit without writing 1000s of rules??? @@ -130,10 +130,10 @@ -- recursive call? E.g. we're in the arr case, and the first sf is another -- arr, so we'd like to combine the two. -- --- * It would also be intersting, then, to know when to STOP playing this +-- - It would also be intersting, then, to know when to STOP playing this -- game, due to the overhead involved. -- --- * Why don't we have a "SWITCH" constructor that indicates that the +-- - Why don't we have a "SWITCH" constructor that indicates that the -- structure will change, and thus that it is worthwile to keep -- looking for opt. opportunities, whereas a plain "SF'" would -- indicate that things NEVER are going to change, and thus we can just @@ -514,7 +514,7 @@ Left x -> let (sf', b') = sfTF' fSF dt x in (futureArrowLeft sf', Left b') Right x -> (futureArrowLeft fSF, Right x) - + instance Arrow SF where arr = arrPrim diff --git a/src/FRP/Yampa/Switches.hs b/src/FRP/Yampa/Switches.hs --- a/src/FRP/Yampa/Switches.hs +++ b/src/FRP/Yampa/Switches.hs @@ -9,7 +9,25 @@ -- Stability : provisional -- Portability : non-portable (GHC extensions) -- ------------------------------------------------------------------------------------------ +-- Switches allow you to change the signal function being applied. +-- +-- The basic idea of switching is fromed by combining a subordinate signal function +-- and a signal function continuation parameterised over some initial data. +-- +-- For example, the most basic switch has the following signature: +-- +-- @switch :: SF a (b, Event c) -> (c -> SF a b) -> SF a b@ +-- +-- which indicates that it has two parameters: a signal function +-- that produces an output and indicates, with an event, when it is time to +-- switch, and a signal function that starts with the residual data left by the +-- first SF in the event and continues onwards. +-- +-- Note that switching occurs, at most, once. If you want something to switch +-- repeatedly, you need to loop. However, some switches are immediate (meaning +-- that the second SF is started at the time of switching). If you use the same +-- SF that originally provoked the switch, you are very likely to fall into an +-- infinite loop. module FRP.Yampa.Switches ( -- Re-exported module, classes, and types @@ -296,7 +314,7 @@ -- | Recurring switch. -- --- See for more +-- See for more -- information on how this switch works. -- !!! Suboptimal. Overall, the constructor is invarying since rSwitch is @@ -320,7 +338,7 @@ -- | Recurring switch with delayed observation. -- --- See for more +-- See for more -- information on how this switch works. drSwitch :: SF a b -> SF (a, Event (SF a b)) b drSwitch sf = dSwitch (first sf) ((noEventSnd >=-) . drSwitch) @@ -336,7 +354,7 @@ -- | "Call-with-current-continuation" switch. -- --- See for more +-- See for more -- information on how this switch works. -- !!! Has not been optimized properly. @@ -455,7 +473,7 @@ -- | 'kSwitch' with delayed observation. -- --- See for more +-- See for more -- information on how this switch works. -- !!! Has not been optimized properly. Should be like kSwitch.