Tests for monadic reactimate

bouncingMan.hs

-- Provide your own manSprite.bmp
-- Creates a basic SDL screen and makes an image bounce along the screen
-- I've included some little utility functions which would normally be better
-- tucked out the way in little modules.

import Graphics.UI.SDL as SDL
import FRP.Yampa as Y
import Control.Monad.Reader
import Data.Time.Clock.POSIX
import Data.IORef

data Environment = Environment {screen :: Surface, object :: Surface}

type ProgEnviron = ReaderT Environment IO

input :: ProgEnviron (Maybe Bool)
input = fmap Just $ liftIO wasQuitEvent

output :: ((Double, Double), Bool) -> ProgEnviron Bool
output ((x,y),exit) = do
    env <- ask
    let scr = screen env
        obj = object env
    liftIO (wipe scr)
    liftIO (blitSurface obj Nothing scr (Just $ Rect (round x) (round y) 0 0))
    liftIO (SDL.flip scr)
    return exit

-- sigFun describes a basic sinusoidal wave, while passing the boolean value through
-- untouched
sigFun :: SF Bool ((Double, Double), Bool)
sigFun = ((arr (*4) <<< time) &&& (arr ((+100).(*10).sin.(*10)) <<< time)) &&& identity

main = do
    SDL.init [InitEverything]
    screen <- setVideoMode 640 480 32 [SWSurface]
    person  <- loadBMP "manSprite.bmp"

    let enviro = Environment screen person

    -- yampaMain is a friendly version of reactimate defined at
    -- the bottom of this file
    runReaderT (yampaMain (return False) input output sigFun) $ enviro

    SDL.quit

-- The rest of this file consists of just utility functions
-- used in the above.
-- (normally I put these in various modules I import)

-- Poll Events gets all the pending events in one go for processing
pollEvents :: IO [SDL.Event]
pollEvents = do
  event <- pollEvent
  if event == SDL.NoEvent then return [] else (fmap (event:)  pollEvents)

wasQuitEvent :: IO Bool
wasQuitEvent = do
  events <- pollEvents
  let quitAsked = or $ map (==SDL.Quit) events
  return quitAsked

-- wipe clears a surface (paints it black)
wipe :: Surface ->  IO Bool
wipe surface = fillRect surface Nothing (Pixel $ 0)

-- Yampa utility functions follow to simplify reactimate

sReactimate :: (Monad m) => m a -> m (DTime, Maybe a) -> (b -> m Bool) -> SF a b -> m ()
sReactimate init inp out sigFun = Y.reactimate init (sInput inp) (sOutput out) sigFun
    where sInput inp _ = inp
          sOutput out _ = out

yampaMain :: (MonadIO m) => m a -> m (Maybe a) -> (b -> m Bool) -> SF a b -> m ()
yampaMain init input output sigFun = do
  t <-liftIO getPOSIXTime
  timeRef <- liftIO (newIORef t)
  let timeWrapInput ins = do
        inV <- ins
        t' <- liftIO getPOSIXTime
        t <- liftIO (readIORef timeRef)
        let dt = realToFrac (t' - t)
        liftIO (writeIORef timeRef t')
        return (dt, inV)
  sReactimate init (timeWrapInput input) output sigFun

sillyEmbed.hs

module Main where
import FRP.Yampa as Y

-- Lazy or strict? I'm using small lists, so lazy.
import Control.Monad.Trans.State.Lazy

-- We will represent computing with Yampa along a list by using the
-- state monad on a zipper-like structure, which encodes the input
-- and output streams as they are processed. Input is the first
-- component, output is the second component (which like with a zipper
-- will be written out backwards).
type ProcessStream a b c = ([(a, Maybe b)], [(a, c)])

-- The following encapsulates the process of taking an output value,
-- and moving along the process stream with it. Notice also this
-- function converts time steps into total time.
writeOut :: (Num a) =>  c -> ProcessStream a b c -> ProcessStream a b c
writeOut _ ([],[]) = ([],[])
writeOut _ ([], ys) = ([], ys)
writeOut v (x:xs, []) = (xs, [(fst x, v)])
writeOut v (x:xs, y:ys) = let (dt, _) = x
                              (t, _) = y in
                          (xs, (t+dt , v):y:ys)

-- A (YampaFeed a b) should be processed with an (SF a b)
-- The processing of the list is stored in the state, while
-- the encapsulated value is used to interact with reactimate
-- (as it must)
type YampaFeed a b = State (ProcessStream DTime a b)

initFunc :: a -> (YampaFeed a b) a
initFunc val = do
  st <- get
  let (xs, ys) = st
      newst = ((0,Just val):xs, ys)
  put newst
  return val

input :: (YampaFeed a b) (DTime, Maybe a)
input = do
  st <- get
  return.head $ fst st
      
output :: b -> (YampaFeed a b) Bool
output out = do
  prev <- get
  let curr = writeOut out prev
  put curr
  let (x, y) = curr
  return (if null x then True else False)

-- The following wraps reactimate in a more friendly format.
-- It removes the redundancy of the Bool inputs.
sReactimate :: (Monad m) => m a -> m (DTime, Maybe a) -> (b -> m Bool) -> SF a b -> m ()
sReactimate init inp out sigFun = Y.reactimate init (sInput inp) (sOutput out) sigFun
    where sInput inp _ = inp
          sOutput out _ = out
  
sillyEmbed :: SF a b -> (a, [(DTime, Maybe a)]) -> [b]
sillyEmbed sf (v, ins) = map snd.reverse $ snd streamed
  where streamed = execState (sReactimate (initFunc v) input output sf) $ (ins, [])

Some tests for sillyEmbed.hs

-- Opening sillyEmbed.hs in ghci (with cabal repl in a sandbox),
-- we can try the following.

-- Integration test
steps = take 10000 $ repeat 0.0001
totTime = scanl (+) 0 steps
inp = zip steps (map Just $ map sin totTime)
-- Compare
embedTest = last $ sillyEmbed integral (0, inp)
-- and the analytic value
actual = 1 - cos 1

statefulTime.hs

-- Timing using the state monad (transformer)
-- yampaMain keeps track of time by wrapping the MonadIO
-- with an additional StateT, where the state is the last
-- recorded time. It is read and updated at each input step
-- (see timeWrapInput, internal to yampaMain).
import FRP.Yampa as Y
import Control.Monad.State
import Data.Time.Clock.POSIX

sigFun :: SF () Bool
sigFun = time >>> arr (>=2)

output :: Bool -> IO Bool
output exit = do
  if exit then putStrLn "World!" >> return True else return False

main = do
    putStrLn "Hello, "

    -- yampaMain is a friendly version of reactimate defined at
    -- the bottom of this file using the state monad
    yampaMain (return ()) (return Nothing) output sigFun

sReactimate :: (Monad m) => m a -> m (DTime, Maybe a) -> (b -> m Bool) -> SF a b -> m ()
sReactimate init inp out sigFun = Y.reactimate init (sInput inp) (sOutput out) sigFun
    where sInput inp _ = inp
          sOutput out _ = out

yampaMain :: (MonadIO m) => m a -> m (Maybe a) -> (b -> m Bool) -> SF a b -> m ()
yampaMain init input output sigFun = do
  t <- liftIO getPOSIXTime
  evalStateT (sReactimate (lift init) (timeWrapInput input) (\b -> lift (output b)) sigFun) $ t
  where timeWrapInput inF = do
          inV <- lift inF
          oldt <- get
          t <- liftIO getPOSIXTime
          put t
          let dt = realToFrac (t - oldt)
          return (dt, inV)