rsagl-frp (empty) → 0.6.0.0
raw patch · 12 files changed
+1293/−0 lines, 12 filesdep +arraydep +arrowsdep +basesetup-changed
Dependencies added: array, arrows, base, containers, mtl, old-time, random, rsagl-math, stm
Files
- LICENSE +26/−0
- RSAGL/FRP.hs +16/−0
- RSAGL/FRP/Accumulation.hs +107/−0
- RSAGL/FRP/FRP.hs +447/−0
- RSAGL/FRP/FRPModel.hs +129/−0
- RSAGL/FRP/FactoryArrow.hs +53/−0
- RSAGL/FRP/Message.hs +127/−0
- RSAGL/FRP/RK4.hs +136/−0
- RSAGL/FRP/RecombinantState.hs +23/−0
- RSAGL/FRP/Time.lhs +178/−0
- Setup.hs +5/−0
- rsagl-frp.cabal +46/−0
+ LICENSE view
@@ -0,0 +1,26 @@+Copyright (c) 2006, 2007, Christopher Lane Hinson+ All rights reserved.++Redistribution and use in source and binary forms, with or without modification, are +permitted provided that the following conditions are met:++Redistributions of source code must retain the above copyright notice, this list of +conditions and the following disclaimer.++Redistributions in binary form must reproduce the above copyright notice, this list of +conditions and the following disclaimer in the documentation and/or other materials +provided with the distribution.++Neither the name of Christopher Lane Hinson nor the names of its contributors may be used +to endorse or promote products derived from this software without specific prior written +permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY +EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF +MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE +COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR +TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ RSAGL/FRP.hs view
@@ -0,0 +1,16 @@+module RSAGL.FRP+ (module RSAGL.FRP.FRP,+ module RSAGL.FRP.FRPModel,+ module RSAGL.FRP.Time,+ module RSAGL.FRP.Accumulation,+ module RSAGL.FRP.RecombinantState,+ module RSAGL.FRP.RK4)+ where++import RSAGL.FRP.Accumulation+import RSAGL.FRP.FRP+import RSAGL.FRP.FRPModel+import RSAGL.FRP.RecombinantState+import RSAGL.FRP.RK4+import RSAGL.FRP.Time+
+ RSAGL/FRP/Accumulation.hs view
@@ -0,0 +1,107 @@+{-# LANGUAGE Arrows #-}++module RSAGL.FRP.Accumulation+ (delay,+ integral,+ derivative,+ accumulateNumerical,+ integralRK4,+ integralRK4',+ summation,+ threadTime,+ sticky,+ initial,+ EdgeDetectionMode(..),+ edge,+ changed,+ clingy)+ where++import RSAGL.FRP.FRP+import RSAGL.FRP.Time+import RSAGL.FRP.RK4+import Control.Arrow+import RSAGL.Math.AbstractVector+import Data.Maybe++-- | Delay a piece of data for one frame.+delay :: x -> FRP e m x x+delay initial_value = accumulate (initial_value,error "delay: impossible") (\new_value (old_value,_) -> (new_value,old_value)) >>> arr snd++-- | Take the integral of a rate over time, using the trapezoidal rule.+integral :: (AbstractVector v,AbstractAdd p v) => p -> FRP e m (Rate v) p+integral initial_value = proc v ->+ do delta_t <- deltaTime -< ()+ (new_accum,_) <- accumulate (zero,perSecond zero) (\(delta_t,new_rate) (old_accum,old_rate) ->+ (old_accum `add` ((scalarMultiply (recip 2) $ new_rate `add` old_rate) `over` delta_t),new_rate)) -< (delta_t,v)+ returnA -< initial_value `add` new_accum++-- | Take the derivative of a value over time, by simple subtraction between frames.+derivative :: (AbstractVector v,AbstractSubtract p v) => FRP e m p (Rate v)+derivative = proc new_value ->+ do delta_t <- deltaTime -< ()+ m_old_value <- delay Nothing -< Just new_value+ let z = perSecond zero+ returnA -< maybe z (\old_value -> if delta_t == zero then z else (new_value `sub` old_value) `per` delta_t) m_old_value++-- | 'accumulate' harness for some numerical methods.+-- Parameters are: current input, previous output, delta time, absolute time, and number of frames at the specified frequency.+accumulateNumerical :: Frequency -> (i -> o -> Time -> Time -> Integer -> o) -> o -> FRP e m i o+accumulateNumerical frequency accumF initial_value = proc i ->+ do absolute_time <- absoluteTime -< ()+ delta_t <- deltaTime -< ()+ accumulate initial_value (\(i,absolute_time',delta_t',frames) o -> accumF i o absolute_time' delta_t' frames) -< + (i,absolute_time,delta_t,ceiling $ toSeconds delta_t / toSeconds (interval frequency))++integralRK4 :: (AbstractVector v) => Frequency -> (p -> v -> p) -> p -> FRP e m (Time -> p -> Rate v) p+integralRK4 f addPV = accumulateNumerical f (\diffF p abs_t delta_t -> integrateRK4 addPV diffF p (abs_t `sub` delta_t) abs_t)++integralRK4' :: (AbstractVector v) => Frequency -> (p -> v -> p) -> (p,Rate v) ->+ FRP e m (Time -> p -> Rate v -> Acceleration v) (p,Rate v)+integralRK4' f addPV = accumulateNumerical f (\diffF p abs_t delta_t -> integrateRK4' addPV diffF p (abs_t `sub` delta_t) abs_t)++-- | Sum some data frame-by-frame.+summation :: (AbstractAdd p v) => p -> FRP e m v p+summation initial_value = accumulate initial_value (\v p -> p `add` v)++-- | Elapsed time since the instantiation of this switch or thread. Reset when a thread switches.+threadTime :: FRP e m () Time+threadTime = summation zero <<< deltaTime++-- | The edge detection mode. If 'Discrete', detect edge between subsequent frames only.+-- If 'Fuzzy' detect edge since the most recent previous detected edge.+-- If 'HashedDiscrete', the comparison function is itself expensive, and the FRP runtime will compare by 'StableName's as a short-circuit optimization.+data EdgeDetectionMode = Fuzzy | Discrete++-- | Answer the most recent input that satisfies the predicate.+-- Accepts an initial value, which need not itself satisfy the predicate.+--+-- This can be a performance optimization, if it prevents unecessary evaluation of an input.+sticky :: (x -> Bool) -> x -> FRP e m x x+sticky f x = accumulate x (\new_x old_x -> if f new_x then new_x else old_x)++-- | Answer the first input that ever passes through a function.+initial :: FRP e m x x+initial = accumulate Nothing (\new_x m_old_x -> Just $ fromMaybe new_x m_old_x) >>> arr (fromMaybe $ error "initial: impossible happened")++-- | Returns 'True' only during frames on which the input has changed, based on a user-specified equality predicate.+-- The predicate function takes the most recent input as its first parameter.+edge :: EdgeDetectionMode -> (x -> x -> Bool) -> FRP e m x Bool+edge Discrete predicateF = proc x ->+ do d_x <- delay Nothing -< Just x+ returnA -< maybe True (not . predicateF x) d_x+edge Fuzzy predicateF = arr snd <<< accumulate (Nothing,error "changed: impossible")+ (\x_now (x_old,_) -> if maybe True (predicateF x_now) x_old+ then (x_old,False)+ else (Just x_now,True))++-- | Same as 'edge Discrete'.+changed :: (x -> x -> Bool) -> FRP e m x Bool+changed = edge Discrete++-- | Recalculate a function only at the edges of it's input.+clingy :: EdgeDetectionMode -> (j -> j -> Bool) -> (j -> p) -> FRP e m j p+clingy edm predicateF f = proc j ->+ do e <- edge edm predicateF -< j+ arr snd <<< sticky fst (error "clingy: impossible") -< (e,f j)+
+ RSAGL/FRP/FRP.hs view
@@ -0,0 +1,447 @@+{-# LANGUAGE ExistentialQuantification, Arrows, ScopedTypeVariables, Rank2Types,+ FlexibleInstances, MultiParamTypeClasses, TypeFamilies,+ UndecidableInstances, DoRec #-}++module RSAGL.FRP.FRP+ (FRP,+ switchContinue,+ switchTerminate,+ spawnThreads,+ killThreadIf,+ threadIdentity,+ withThreadIdentity,+ frpTest,+ FRPProgram,+ newFRPProgram,+ newFRP1Program,+ updateFRPProgram,+ accumulate,+ absoluteTime,+ deltaTime,+ ThreadIdentityRule,+ forbidDuplicates,+ allowAnonymous,+ nullaryThreadIdentity,+ frpContext,+ frp1Context,+ frpFix,+ whenJust,+ ioInit,+ ioAction,+ outgoingBy,+ outgoing,+ incoming,+ StreamFunctor(..),+ randomA)+ where++import Prelude hiding ((.),id)+import RSAGL.FRP.FactoryArrow+import Control.Monad.Cont+import Control.Monad.Fix+import RSAGL.FRP.Time+import RSAGL.FRP.FRPModel+import Control.Concurrent.MVar+import Control.Category+import Control.Arrow+import Control.Arrow.Operations hiding (delay)+import Data.IORef+import Control.Applicative+import RSAGL.Math.AbstractVector+import Data.List+import Data.Maybe+import Control.Exception+import RSAGL.FRP.RecombinantState+import RSAGL.FRP.Message+import System.Random++{--------------------------------------------------------------------------------}+-- FRP Data Structures+{--------------------------------------------------------------------------------}++-- | State information for a currently-executed FRP program.+data FRPState i o = FRPState {+ -- | Ending time of the current frame, and the frame-local time horizon.+ frpstate_absolute_time :: Time,+ -- | Delta to the ending time of the previous frame.+ frpstate_delta_time :: Time,+ -- | Continuation to exit the current switch.+ frpstate_exit :: (Maybe o) -> ContT (Maybe o) IO (Maybe o) }++data FRPInit s t i o = FRPInit {+ frp_current_switch :: IORef (i -> ContT (Maybe o) IO (Maybe o)),+ frp_state :: IORef (FRPState i o),+ frp_user_state :: IORef s,+ -- | Put a thread in here to spawn it.+ frp_spawned_threads :: MVar [FRPInit s t i o],+ frp_previous_time :: IORef (Maybe Time),+ frp_thread_identity :: t,+ frp_previous_result :: IORef (Maybe o) }++type FRPProgram s i o = FRPInit s () i o++-- | A switchable automata with timewise numerical methods.+newtype FRP e m j p = FRP (FRPInit (StateOf m) (ThreadIDOf m) (SwitchInputOf m) (SwitchOutputOf m) ->+ FactoryArrow IO (ContT (Maybe (SwitchOutputOf m)) IO) j p)++instance Functor (FRP e m j) where+ fmap f frpx = frpx >>> arr f++instance Applicative (FRP e m j) where+ pure a = proc _ -> returnA -< a+ f <*> s = proc i ->+ do s' <- s -< i+ f' <- f -< i+ returnA -< f' s'++instance Category (FRP e m) where+ (FRP a) . (FRP b) = FRP $ \frp_init -> a frp_init . b frp_init+ id = FRP $ const id++instance Arrow (FRP e m) where+ arr f = FRP $ \_ -> arr f+ first (FRP f) = FRP $ \frp_init -> first (f frp_init)+ second (FRP f) = FRP $ \frp_init -> second (f frp_init)++instance (StateOf m ~ s) => ArrowState s (FRP e m) where+ fetch = frpxOf $ \frpinit _ -> lift $ getProgramState frpinit+ store = frpxOf $ \frpinit x -> lift $ putProgramState frpinit x++-- | Construct a single-threaded FRPProgram.+newFRP1Program :: (forall e. FRP e (FRP1 s i o) i o) -> IO (FRPProgram s i o)+newFRP1Program thread = unsafeFRPProgram (error "newFRP1Program: impossible, tried to access the spawned_threads pool from a single threaded FRPProgram.") () thread++-- | Construct a multi-threaded FRPProgram.+newFRPProgram :: (RecombinantState s,Eq t) =>+ ThreadIdentityRule t ->+ (forall e. [(t,FRP e (FRPX t s i o) i o)]) ->+ IO (FRPProgram s i [(t,o)])+newFRPProgram rule seed_threads = newFRP1Program $ frpContext rule seed_threads++-- | Construct an FRPProgram from a single seed thread. This program will spawn threads+-- into the specified MVar.+unsafeFRPProgram :: MVar [FRPInit (StateOf m) (ThreadIDOf m) (SwitchInputOf m) (SwitchOutputOf m)] ->+ ThreadIDOf m ->+ FRP e m (SwitchInputOf m) (SwitchOutputOf m) ->+ IO (FRPInit (StateOf m) (ThreadIDOf m) (SwitchInputOf m) (SwitchOutputOf m))+unsafeFRPProgram spawned_threads t frpx =+ do frpstate_ref <- newIORef $ error "Tried to use uninitialized FRPState variable."+ current_switch_ref <- newIORef $ error "Tried to use uninitialized frp_current_switch variable."+ previous_time_ref <- newIORef Nothing+ previous_result_ref <- newIORef Nothing+ user_state_ref <- newIORef $ error "Tried to use uninitialized user state variable. (use setProgramState)."+ let frp_init = FRPInit current_switch_ref frpstate_ref user_state_ref spawned_threads previous_time_ref t previous_result_ref+ writeIORef current_switch_ref =<< constructSwitch frp_init frpx+ return frp_init++getProgramState :: FRPInit s t i o -> IO s+getProgramState = readIORef . frp_user_state++putProgramState :: FRPInit s t i o -> s -> IO ()+putProgramState frp_init s = writeIORef (frp_user_state frp_init) $ s++modifyProgramState :: FRPInit s t i o -> (s -> s) -> IO ()+modifyProgramState frp_init f = putProgramState frp_init =<< liftM f (getProgramState frp_init)++-- | Bring an FRPProgram up-to-date with the current time or a specific time.+updateFRPProgram :: Maybe Time -> (i,s) -> FRPProgram s i o -> IO (o,s)+updateFRPProgram user_t (i,s) frp_init =+ do actual_t <- getTime+ prev_t <- readIORef $ frp_previous_time frp_init+ when (maybe False (> actual_t) prev_t) $ error "updateFRPProgram: previous time greater than current actual time"+ when (maybe False (> actual_t) user_t) $ error "updateFRPProgram: user time greater than current actual time"+ let t = minimum $ catMaybes [Just actual_t,user_t]+ liftM (fromMaybe $ error "updateFRPProgram: unexpected termination") $ unsafeRunFRPProgram t (i,s) frp_init++frpTest :: (forall e. [FRP e (FRPX () () i o) i o]) -> [i] -> IO [[o]]+frpTest seed_threads inputs =+ do test_program <- newFRPProgram nullaryThreadIdentity $ map (\thread -> ((),thread)) seed_threads+ liftM (map $ map snd . maybe (error "frpTest: unexpected termination") fst) $ + mapM (\(t,i) -> unsafeRunFRPProgram t (i,()) test_program) $ zip (map fromSeconds [0.0,0.1..]) inputs++-- | Update an FRPProgram.+unsafeRunFRPProgram :: Time -> (i,s) -> FRPInit s t i o -> IO (Maybe (o,s))+unsafeRunFRPProgram t (i,s) frp_init =+ do prev_t <- readIORef (frp_previous_time frp_init)+ m_o <- flip runContT return $+ do o <- callCC $ \exit ->+ do let state = FRPState {+ frpstate_absolute_time = t,+ frpstate_delta_time = fromMaybe zero $ sub <$> pure t <*> prev_t,+ frpstate_exit = exit }+ lift $ writeIORef (frp_state frp_init) state+ lift $ putProgramState frp_init s+ action <- lift $ readIORef (frp_current_switch frp_init)+ action i+ lift $ writeIORef (frp_previous_time frp_init) $ Just t+ lift $ writeIORef (frp_previous_result frp_init) $ o+ return o+ s' <- readIORef (frp_user_state frp_init)+ return $ fmap (\o -> (o,s')) m_o++getFRPState :: FRPInit s t i o -> IO (FRPState i o)+getFRPState = readIORef . frp_state++-- | Shorthand for simple operations in the ContT monad.+frpxOf :: (FRPInit (StateOf m) (ThreadIDOf m) (SwitchInputOf m) (SwitchOutputOf m) ->+ j ->+ ContT (Maybe (SwitchOutputOf m)) IO p) ->+ FRP e m j p+frpxOf action = FRP $ \frpinit -> FactoryArrow $ return $ Kleisli $ action frpinit++-- | Framewise accumulation of signals.+-- The embedded function recieves the current input and the previous output.+accumulate :: p -> (j -> p -> p) -> FRP e m j p+accumulate initial_value accumF = FRP $ \_ -> FactoryArrow $+ do prev_o_ref <- newIORef initial_value+ return $ Kleisli $ \i -> lift $+ do prev_o <- readIORef prev_o_ref+ let o = accumF i prev_o+ writeIORef prev_o_ref o+ _ <- evaluate o+ return o++-- | Get the current absolute time.+absoluteTime :: FRP e m () Time+absoluteTime = frpxOf $ \frpinit () -> lift $ do liftM frpstate_absolute_time $ getFRPState frpinit++-- | Get the change in time since the last update.+deltaTime :: FRP e m () Time+deltaTime = frpxOf $ \frpinit () -> lift $ do liftM frpstate_delta_time $ getFRPState frpinit++-- | Replace the 'frpinit_current_switch' value of the currently running thread with a newly constructed switch.+replaceSwitch :: FRPInit (StateOf m) (ThreadIDOf m) (SwitchInputOf m) (SwitchOutputOf m) -> FRP e m (SwitchInputOf m) (SwitchOutputOf m) ->+ ContT (Maybe (SwitchOutputOf m)) IO (SwitchInputOf m -> ContT (Maybe (SwitchOutputOf m)) IO (Maybe (SwitchOutputOf m)))+replaceSwitch frpinit switch =+ do newSwitch <- lift $ constructSwitch frpinit switch+ lift $ writeIORef (frp_current_switch frpinit) newSwitch+ return newSwitch++constructSwitch :: FRPInit (StateOf m) (ThreadIDOf m) (SwitchInputOf m) (SwitchOutputOf m) ->+ FRP e m (SwitchInputOf m) (SwitchOutputOf m) ->+ IO (SwitchInputOf m -> ContT (Maybe (SwitchOutputOf m)) IO (Maybe (SwitchOutputOf m)))+constructSwitch frp_init (FRP f) =+ do (Kleisli current_switch) <- runFactory $ f frp_init+ return $ \i ->+ do o <- current_switch i+ exit <- liftM frpstate_exit $ lift $ getFRPState frp_init+ exit $ Just o++-- | Whenever a value is provided, change the presently running switch (or thread) to the specified new value,+-- and execute that switch before continuing. This destroys all state local to the currently running+-- switch (or thread).+-- This function acts as if the switch were performed at frame begin.+switchContinue :: FRP e m (Maybe (FRP e m (SwitchInputOf m) (SwitchOutputOf m)),SwitchInputOf m) (SwitchInputOf m)+switchContinue = frpxOf $ \frpinit (m_switch,i) ->+ do case m_switch of+ (Just switch) ->+ do newSwitch <- replaceSwitch frpinit switch+ _ <- callCC $ \_ -> newSwitch i+ error "switchContinue: Unreachable code."+ Nothing -> return i++-- | Whenever a value is provided, change the presently running switch (or thread) to the specified new value,+-- and execute that switch before continuing. This destroys all state local to the currently running+-- switch (or thread).+-- This function acts as if the switch were performed at frame end.+switchTerminate :: FRP e m (Maybe (FRP e m (SwitchInputOf m) (SwitchOutputOf m)),SwitchOutputOf m) (SwitchOutputOf m)+switchTerminate = frpxOf $ \frp_init (m_switch,o) ->+ do case m_switch of+ (Just switch) ->+ do _ <- replaceSwitch frp_init switch+ exit <- lift $ liftM frpstate_exit $ getFRPState frp_init+ _ <- exit $ Just o+ error "switchTerminate: Unreachable code."+ Nothing -> return o++-- | Spawn new threads once per frame.+spawnThreads :: (ThreadingOf m ~ Enabled) => FRP e m [(ThreadIDOf m,FRP e m (SwitchInputOf m) (SwitchOutputOf m))] ()+spawnThreads = frpxOf $ \frp_init new_threads -> lift $+ do constructed_new_threads <- mapM (uncurry $ unsafeFRPProgram $ frp_spawned_threads frp_init) new_threads+ modifyMVar_ (frp_spawned_threads frp_init) $ return . (constructed_new_threads ++)+ return ()++-- | Kill the current thread, only when the given parameter is true.+killThreadIf :: (ThreadingOf m ~ Enabled) => FRP e m Bool ()+killThreadIf = frpxOf $ \frpinit b ->+ do exit <- lift $ liftM frpstate_exit $ getFRPState frpinit+ when b $ exit Nothing >> return ()+ return ()++-- | Should a thread be allowed to spawn? Typical values are 'nullaryThreadIdentity', 'forbidDuplicates'.+-- The predicate tests whether or not a particular thread is already running.+type ThreadIdentityRule t = (t -> Bool) -> t -> Bool++-- | Allow unlimited duplicate threads.+nullaryThreadIdentity :: ThreadIdentityRule a+nullaryThreadIdentity _ _ = True++-- | Forbig duplicate threads by equality on the thread identity.+forbidDuplicates :: (Eq t) => ThreadIdentityRule t+forbidDuplicates = (not .)++-- | Allow unlimited duplicate 'Nothing' threads, while restricting all other threads according to the specified rule.+allowAnonymous :: ThreadIdentityRule t -> ThreadIdentityRule (Maybe t)+allowAnonymous _ _ Nothing = True+allowAnonymous r f (Just x) = r (f . Just) x++accumulateThreads :: (Eq t) => ThreadIdentityRule t -> [t] -> [FRPInit s t i o] -> [FRPInit s t i o]+accumulateThreads _ _ [] = []+accumulateThreads rule ts (x:xs) | rule (`elem` ts) (frp_thread_identity x) = x : accumulateThreads rule (frp_thread_identity x : ts) xs+accumulateThreads rule ts (_:xs) | otherwise = accumulateThreads rule ts xs++-- | Get the current thread's identity.+threadIdentity :: FRP e m () (ThreadIDOf m)+threadIdentity = frpxOf $ \frpinit () -> return $ frp_thread_identity frpinit++-- | Construct an arrow from its thread identity.+withThreadIdentity :: (ThreadIDOf m -> FRP e m j p) -> FRP e m j p+withThreadIdentity (actionF) = FRP $ \frp_init ->+ let (FRP actionA) = actionF $ frp_thread_identity frp_init+ in actionA frp_init++data ThreadGroup s t i o = ThreadGroup {+ thread_outputs :: [ThreadResult s t i o],+ thread_group :: MVar [FRPInit s t i o] }++data ThreadResult s t i o = ThreadResult {+ thread_output :: o,+ thread_object :: FRPInit s t i o }++threadResults :: ThreadGroup s t i o -> [(t,o)]+threadResults = map (\t -> (frp_thread_identity $ thread_object t,thread_output t)) . thread_outputs++-- | A complex function that embeds a thread group inside another running thread. If the parent thread terminates+-- or switches, the embedded thread group is instantly lost.+--+-- 'unsafeThreadGroup' accepts some paremters:+-- * A transformation from the current state to the nested state.+-- * A state-append function, which takes the original state as the first parameter, and one of the threaded results as the second parameter.+-- This will be run repeatedly to accumulate the output state.+-- * A multithreading algorithm. The simplest implementation is sequence_.+-- * A list of seed threads with their associated thread identities.+unsafeThreadGroup :: forall e m n.+ (FRPModel m,FRPModel n,Unwrap n ~ m) =>+ (StateOf m -> StateOf n) ->+ (StateOf m -> StateOf n -> StateOf m) ->+ ThreadIdentityRule (ThreadIDOf n) ->+ ([IO ()] -> IO ()) ->+ [(ThreadIDOf n,FRP e n (SwitchInputOf n) (SwitchOutputOf n))] ->+ FRP e m (SwitchInputOf n) (ThreadGroup (StateOf n) (ThreadIDOf n) (SwitchInputOf n) (SwitchOutputOf n))+unsafeThreadGroup sclone sappend rule multithread seed_threads = FRP $ \frp_init -> FactoryArrow $+ do threads <- newEmptyMVar+ putMVar threads =<< (mapM (uncurry $ unsafeFRPProgram threads) seed_threads)+ let runThreads :: [ThreadIDOf n] -> SwitchInputOf n -> IO [ThreadResult (StateOf n) (ThreadIDOf n) (SwitchInputOf n) (SwitchOutputOf n)]+ runThreads already_running_threads j =+ do threads_this_pass <- liftM (accumulateThreads rule already_running_threads) $ takeMVar threads+ putMVar threads []+ s_orig_clone <- liftM sclone $ getProgramState frp_init+ absolute_time <- liftM frpstate_absolute_time $ getFRPState frp_init+ multithread $ map (\t -> unsafeRunFRPProgram absolute_time (j,s_orig_clone) t >> return ()) threads_this_pass+ results_this_pass <- liftM catMaybes $ forM threads_this_pass $ \t ->+ do m_o <- readIORef (frp_previous_result t)+ s <- readIORef (frp_user_state t)+ modifyProgramState frp_init (`sappend` s)+ return $+ do o <- m_o+ return $ ThreadResult o t+ results <- liftM (results_this_pass++) (if null threads_this_pass+ then return []+ else runThreads (nub $ map frp_thread_identity threads_this_pass ++ already_running_threads) j)+ modifyMVar_ threads (return . ((map thread_object results_this_pass)++))+ return results+ return $ Kleisli $ \j ->+ do results <- lift $ runThreads [] j+ return $ ThreadGroup {+ thread_outputs = results,+ thread_group = threads }++-- | Embed some threads inside another running thread, as 'threadGroup'.+frpContext :: (RecombinantState s,s ~ StateOf m,FRPModel m,Eq t) =>+ ThreadIdentityRule t -> [(t,FRP e (FRPContext t j p m) j p)] -> FRP e m j [(t,p)]+frpContext rule seed_threads = arr threadResults . unsafeThreadGroup clone recombine rule sequence_ seed_threads++-- | Embed a single-threaded, bracketed switch inside another running thread.+frp1Context :: (FRPModel m) => FRP e (FRP1Context j p m) j p -> FRP e m j p+frp1Context thread = proc i ->+ do os <- withThreadIdentity (\t -> unsafeThreadGroup id (const id) nullaryThreadIdentity sequence_ [(t,thread)]) -< i+ returnA -< case threadResults os of+ [(_,o)] -> o+ _ -> error "frp1Context: unexpected non-singular result."++-- |+-- Value recusion (see fix).+--+frpFix :: (FRPModel m) => FRP e (FRP1Context (j,x) (p,x) m) (j,x) (p,x) -> FRP e m j p+frpFix thread = FRP $ \frp_init -> FactoryArrow $+ do empty_thread_group <- newMVar []+ nested_frp_init <- unsafeFRPProgram empty_thread_group (frp_thread_identity frp_init) thread+ return $ Kleisli $ \i -> lift $+ do s <- getProgramState frp_init+ absolute_time <- liftM frpstate_absolute_time $ getFRPState frp_init+ liftM fst $ mfix $ \ox ->+ do result <- unsafeRunFRPProgram absolute_time ((i,snd ox),s) nested_frp_init+ case result of+ Just (ox',s') ->+ do putProgramState frp_init s'+ return ox'+ Nothing ->+ do error "frpFix: unexpected non-singualr result."++-- | Run a computation only when the input is defined.+whenJust :: (FRPModel m) => (forall x y. FRP e (FRP1Context x y m) j p) -> FRP e m (Maybe j) (Maybe p)+whenJust actionA = frp1Context whenJust_+ where whenJust_ = proc i ->+ do switchContinue -< (maybe (Just whenNothing_) (const Nothing) i,i)+ arr (Just) <<< actionA -< fromMaybe (error "whenJust: impossible case") i+ whenNothing_ = proc i ->+ do switchContinue -< (fmap (const whenJust_) i,i)+ returnA -< Nothing++-- | Perform an IO action when a stream is first initialized.+ioInit :: (InputOutputOf m ~ Enabled) => (IO p) -> FRP e m () p+ioInit action = FRP $ \_ -> FactoryArrow $+ do p <- action+ return $ Kleisli $ const $ return p++-- | Perform an arbitrary IO action.+ioAction :: (InputOutputOf m ~ Enabled) => (j -> IO p) -> FRP e m j p+ioAction action = frpxOf $ \_ j -> lift $ action j++-- | Send tagged information.+outgoingBy :: (j -> j -> Bool)+ -- ^ Equality predicate as described in 'newTransmitterBy'.+ -> FRP e m j (Message j)+outgoingBy f = FRP $ \_ -> FactoryArrow $+ do t <- newTransmitterBy f+ return $ Kleisli $ lift . transmit t++-- | Send tagged information.+outgoing :: (Eq j) => FRP e m j (Message j)+outgoing = outgoingBy (==)++-- | Receive tagged information, with memoization.+incoming :: FRP e m (Message j) j+incoming = FRP $ \_ -> FactoryArrow $+ do r <- newReceiver+ return $ Kleisli $ lift . receive r++-- | An FRP-embedded functor.+class StreamFunctor s where+ streampure :: a -> FRP e m () (s a)+ streammap :: (a -> b) -> FRP e m (s a) (s b)++instance StreamFunctor Message where+ streampure a = FRP $ \_ -> FactoryArrow $+ do a' <- send a+ return $ Kleisli $ const $ return a'+ streammap f = proc m ->+ do f' <- streampure f -< ()+ returnA -< f' <<*>> m++-- | Get a bounded random value, as 'randomRIO'. A new value is pulled for each+-- frame of animation.+randomA :: (Random a) => FRP e m (a,a) a+randomA = frpxOf $ \_ ->+ lift . randomRIO+
+ RSAGL/FRP/FRPModel.hs view
@@ -0,0 +1,129 @@+{-# LANGUAGE TypeFamilies,+ EmptyDataDecls,+ UndecidableInstances,+ FlexibleContexts #-}++-- | A model of the types used by an FRP program.+module RSAGL.FRP.FRPModel+ (Enabled,+ Disabled,+ Capability,+ FRPModel(..),+ FRP1,+ FRPX,+ FRPContext,+ FRP1Context,+ IODisabled,+ Switch,+ SimpleSwitch)+ where++import RSAGL.FRP.RecombinantState++class RSAGL_FRP_FRPMODEL a where++data Enabled+data Disabled++class (RSAGL_FRP_FRPMODEL a) => Capability a where++instance RSAGL_FRP_FRPMODEL Enabled where+instance Capability Enabled where+instance RSAGL_FRP_FRPMODEL Disabled where+instance Capability Disabled where++class (RSAGL_FRP_FRPMODEL frp,Eq (ThreadIDOf frp)) => FRPModel frp where+ -- | The threading capability, either 'Enabled' or 'Disabled'.+ type ThreadingOf frp :: *+ -- | The a type of the thread ID (for example, a unique integer).+ type ThreadIDOf frp :: *+ -- | The 'ArrowState' type.+ type StateOf frp :: *+ -- | The type of the switch input+ -- (used in switchTerminate/switchContinue, etc)+ type SwitchInputOf frp :: *+ -- | The type of the switch output+ -- (used in switchTerminate/switchContinue, etc)+ type SwitchOutputOf frp :: *+ -- | Access to the IO monad, either 'Enabled' or 'Disabled'.+ type InputOutputOf frp :: *+ -- | Unwrap to get the nested Switch type.+ type Unwrap frp :: *++instance RSAGL_FRP_FRPMODEL () where++instance FRPModel () where+ type ThreadingOf () = Disabled+ type ThreadIDOf () = ()+ type StateOf () = ()+ type SwitchInputOf () = ()+ type SwitchOutputOf () = ()+ type InputOutputOf () = Disabled+ type Unwrap () = ()++-- | The FRPModel type that represents a switch.+-- Consists of the following type variables.+--+-- Note: Don't pattern-match against this type directly, as it is a volatile+-- interface. Either use a type synonym, such as 'SimpleSwitch', or match+-- against the type functions in FRPModel.+--+-- * k - See, ThreadingOf.+-- * t - See, ThreadIDOf.+-- * s - See, StateOf.+-- * i - See, SwitchInputOf.+-- * o - See, SwitchOutputOf.+-- * m - A variable that represents switch nesting.+data Switch k t s io i o m++instance (RSAGL_FRP_FRPMODEL m, Capability k) =>+ RSAGL_FRP_FRPMODEL (Switch k t s io i o m) where++instance (RSAGL_FRP_FRPMODEL m, Eq t, Capability k) =>+ FRPModel (Switch k t s io i o m) where+ type ThreadingOf (Switch k t s io i o m) = k+ type ThreadIDOf (Switch k t s io i o m) = t+ type StateOf (Switch k t s io i o m) = s+ type SwitchInputOf (Switch k t s io i o m) = i+ type SwitchOutputOf (Switch k t s io i o m) = o+ type InputOutputOf (Switch k t s io i o m) = io+ type Unwrap (Switch k t s io i o m) = m++-- | A root-level single-threaded program.+-- IO is enabled by default.+type FRP1 s i o = Switch Disabled () s Enabled i o ()++-- | A root-level multi-threaded program.+-- IO is enabled by default.+type FRPX t s i o = FRPContext t i o (FRP1 s i [(t,o)])++-- | A multi-threaded embedded subprogram.+type FRPContext t i o m = Switch Enabled+ t+ (SubState (StateOf m))+ (InputOutputOf m)+ i+ o+ m++-- | A single-threaded embedded subprogram.+type FRP1Context i o m = Switch Disabled+ (ThreadIDOf m)+ (StateOf m)+ (InputOutputOf m)+ i+ o+ m++-- | A subprogram with IO capabilities disabled.+type IODisabled i o m = Switch (ThreadingOf m)+ (ThreadIDOf m)+ (StateOf m)+ Disabled+ i+ o+ m++-- | A legacy configuration, IO capabilities enabled.+type SimpleSwitch k t s i o m = Switch k t s Enabled i o m+
+ RSAGL/FRP/FactoryArrow.hs view
@@ -0,0 +1,53 @@+{-# LANGUAGE Arrows, MultiParamTypeClasses, FlexibleInstances, FlexibleContexts, ExistentialQuantification, Rank2Types #-}++module RSAGL.FRP.FactoryArrow+ (FactoryArrow(..))+ where++import Prelude hiding ((.),id)+import Control.Arrow+import Control.Monad+import Control.Monad.Fix+import Control.Category++-- | An 'Arrow' that constructs an associated monadic computation.+newtype FactoryArrow m n i o = FactoryArrow { runFactory :: m (Kleisli n i o) }++instance (Monad m,Monad n) => Category (FactoryArrow m n) where+ (FactoryArrow a) . (FactoryArrow b) = FactoryArrow $+ do b' <- b+ a' <- a+ return $ a' . b'+ id = FactoryArrow $ return id++instance (Monad m,Monad n) => Arrow (FactoryArrow m n) where+ arr = FactoryArrow . return . arr+ first = FactoryArrow . liftM first . runFactory+ second = FactoryArrow . liftM second . runFactory++instance (Monad m,MonadFix n) => ArrowLoop (FactoryArrow m n) where+ loop = FactoryArrow . liftM loop . runFactory++-- | Careful! To implement ArrowApply, the factory action must run imbedded in the constructed action.+instance (Monad m) => ArrowApply (FactoryArrow m m) where+ app = factoryApp id++-- | Implements ArrowApply for any FactoryArrow capable of it,+-- but this requires a way to lift operations in m into n.+factoryApp :: (Monad m,Monad n) => (forall a. m a -> n a) -> FactoryArrow m n (FactoryArrow m n i o,i) o+factoryApp liftM2N = FactoryArrow $ return $ Kleisli $ \(FactoryArrow m,i) ->+ do (Kleisli n) <- liftM2N m+ n i++-- | A choice is constructed at factory time whether or not the constructed action is ever evaluated.+instance (Monad m,Monad n) => ArrowChoice (FactoryArrow m n) where+ left = FactoryArrow . liftM left . runFactory+ right = FactoryArrow . liftM right . runFactory++instance (Monad m,MonadPlus n) => ArrowZero (FactoryArrow m n) where+ zeroArrow = FactoryArrow $ return zeroArrow++-- | As with ArrowChoice, both branches are constructed at factory time whether or not the constructed actions are ever evaluated.+instance (Monad m,MonadPlus n) => ArrowPlus (FactoryArrow m n) where+ a <+> b = FactoryArrow $ liftM2 (<+>) (runFactory a) (runFactory b)+
+ RSAGL/FRP/Message.hs view
@@ -0,0 +1,127 @@+{-# LANGUAGE Arrows #-}++-- | A memoization scheme in which a piece of information is tagged with+-- a unique identifier for its source. Messages can be combined,+-- and the tagging information indicates the specific combination.+-- On the receiving end, we memoize the single most recent incoming+-- message, and reuse it if the source information matches.+--+module RSAGL.FRP.Message+ (Message,+ consistent,+ consistency,+ peek,+ Transmitter,+ newTransmitterBy,+ newTransmitter,+ Receiver,+ newReceiver,+ (<<*>>),+ send,+ receive,+ transmit)+ where++import System.IO.Unsafe+import Control.Concurrent.STM++-- | A sourced packet of information.+data Message a = Message {+ message_source :: Source,+ message_value :: a }++-- | Two messages are consistent if they arrive from identical sources.+consistent :: Message a -> Message b -> Bool+consistent a b = message_source a == message_source b++-- | An arbitrary ordering scheme on messages.+consistency :: Message a -> Message b -> Ordering+consistency a b = message_source a `compare` message_source b++-- | Examine a message without memoization.+peek :: Message a -> a+peek = message_value++{-# NOINLINE integer_source #-}+integer_source :: TVar Integer+integer_source = unsafePerformIO $ newTVarIO 0++uniqueInteger :: STM Integer+uniqueInteger =+ do i <- readTVar integer_source+ let i' = succ i+ writeTVar integer_source i'+ return i'++-- | A unique tag with fast comparison.+data Source =+ Source Integer+ | Apply Source Source+ deriving (Eq,Ord)++send_ :: a -> STM (Message a)+send_ a =+ do u <- uniqueInteger+ return $ Message {+ message_source = Source u,+ message_value = a }++-- | Construct a new message from a one-time source.+send :: a -> IO (Message a)+send = atomically . send_++-- | Bind two messages.+(<<*>>) :: Message (a -> b) -> Message a -> Message b+f <<*>> k = Message {+ message_source = Apply (message_source f)+ (message_source k),+ message_value = message_value f $ message_value k }++-- | An object that can memoize sequentially matching incoming messages.+data Receiver a = Receiver {+ receiver_previous_message :: TVar (Maybe (Message a)) }++newReceiver :: IO (Receiver a)+newReceiver =+ do m <- newTVarIO Nothing+ return $ Receiver m++-- | Memoizes an incomming message stream.+receive :: Receiver a -> Message a -> IO a+receive r m = atomically $+ do m_c <- readTVar $ receiver_previous_message r+ case m_c of+ Just c | message_source c == message_source m ->+ return $ message_value c+ _ ->+ do writeTVar (receiver_previous_message r) $ Just m+ return $ message_value m++-- | An object that can memoize matching sequential outgoing messages.+data Transmitter a = Transmitter {+ transmitter_predicate :: a -> a -> Bool,+ transmitter_previous_message :: TVar (Maybe (Message a)) }++-- Defines a 'Transmitter' that uses a custom predicate to identify+-- matching outgoing messages. The parameters of the predicate+-- are the cached value and the new value, respectively.+newTransmitterBy :: (a -> a -> Bool) -> IO (Transmitter a)+newTransmitterBy f =+ do m <- newTVarIO Nothing+ return $ Transmitter f m++-- | Equivalent to @newTransmitterBy (==)@.+newTransmitter :: (Eq a) => IO (Transmitter a)+newTransmitter = newTransmitterBy (==)++-- | Tags an outgoing stream for memoization.+transmit :: Transmitter a -> a -> IO (Message a)+transmit t a = atomically $+ do m_c <- readTVar $ transmitter_previous_message t+ case m_c of+ Just c | (transmitter_predicate t) (message_value c) a -> return c+ _ ->+ do m <- send_ a+ writeTVar (transmitter_previous_message t) $ Just m+ return m+
+ RSAGL/FRP/RK4.hs view
@@ -0,0 +1,136 @@+module RSAGL.FRP.RK4+ (rk4,+ integrateRK4,+ rk4',+ integrateRK4')+ where++import RSAGL.Math.AbstractVector+import RSAGL.FRP.Time++-- | Generic implementation of one time-step of the RK4 algorithm.+genericRK4 :: (AbstractVector v) =>+ (Time -> p -> v -> p)+ -- ^ Addition function. Adds a vector to a point using+ -- a time-diff. The input vector (@v@) to this function+ -- is already scaled to represent the time interval,+ -- so the time-diff should be ignored unless this+ -- function is to have non-linear with respect to+ -- frame rate.+ -> (Time -> p -> Rate v)+ -- ^ The differential equation, representing velocity+ -- in terms of position at an absolute time.+ -> p+ -- ^ Initial value.+ -> Time+ -- ^ Starting time.+ -> Time+ -- ^ Ending time.+ -> p+genericRK4 addPV diffF p0 t0 t1 =+ addPV h p0 $ (scalarMultiply (recip 6)+ (abstractSum [k1,k2,k2,k3,k3,k4])+ `over` h)+ where k1 = diffF t0 p0+ k2 = diffF tmid (addPV h2 p0 $ k1 `over` h2)+ k3 = diffF tmid (addPV h2 p0 $ k2 `over` h2)+ k4 = diffF t1 (addPV h p0 $ k3 `over` h)+ h = t1 `sub` t0+ h2 = scalarMultiply (recip 2) h+ tmid = t0 `add` h2++-- | Implementation of RK4 that time steps a system in which velocity is+-- a function of absolute time and position.+rk4 :: (AbstractVector v) =>+ (p -> v -> p)+ -- ^ Definition of vector addition.+ -> (Time -> p -> Rate v)+ -- ^ Differential equation, representing velocity in terms+ -- of position at an absolute time.+ -> p+ -- ^ Initial value.+ -> Time+ -- ^ Starting time.+ -> Time+ -- ^ Ending time.+ -> p+rk4 addPV = genericRK4 (const addPV)++-- | Implementation of RK4 that time steps a system in which acceleration+-- is a function of absolute time, position and velocity.+rk4' :: (AbstractVector v) =>+ (p -> v -> p)+ -- ^ Definition of vector addition.+ -> (Time -> p -> Rate v -> Acceleration v)+ -- ^ Differential equation, representing acceleration in+ -- terms of position and velocity at an absolute time.+ -> (p,Rate v)+ -- ^ Initial value.+ -> Time+ -- ^ Starting time.+ -> Time+ -- ^ Ending time.+ -> (p,Rate v)+rk4' addPV diffF = genericRK4+ (\t (p,old_v) delta_v -> let new_v = old_v `add` delta_v+ in (addPV p $ (scalarMultiply (recip 2) $+ old_v `add` new_v)+ `over` t,new_v))+ (\t (p,v) -> diffF t p v)++-- | Integrate a system of multiple time steps.+genericIntegrate :: (p -> Time -> Time -> p)+ -- ^ Description of a single time step,+ -- given position, initial time, and ending time.+ -> p+ -- ^ Initial value.+ -> Time+ -- ^ Starting time.+ -> Time+ -- ^ Ending time.+ -> Integer+ -- ^ Number of time steps.+ -> p+genericIntegrate _ pn _ _ 0 = pn+genericIntegrate f p0 t0 tn n = genericIntegrate f p1 t1 tn (n-1)+ where t1 = t0 `add` (scalarMultiply (recip $ fromInteger n) $ tn `sub` t0)+ p1 = f p0 t0 t1++-- | Implementation of RK4 that repeatedly time steps a system in which velocity+-- is a function of absolute time and position.+integrateRK4 :: (AbstractVector v) =>+ (p -> v -> p)+ -- ^ Definition of vector addition.+ -> (Time -> p -> Rate v)+ -- ^ Differential equation, representing velocity in terms+ -- of position at an absolute time.+ -> p+ -- ^ Initial value.+ -> Time+ -- ^ Starting time.+ -> Time+ -- ^ Ending time.+ -> Integer+ -- ^ Number of time steps.+ -> p+integrateRK4 addPV diffF = genericIntegrate $ rk4 addPV diffF++-- | Implementation of RK4 that repeatedly time steps a system in which+-- acceleration is a function of absolute time, position and velocity.+integrateRK4' :: (AbstractVector v) =>+ (p -> v -> p)+ -- ^ Definition of vector addition.+ -> (Time -> p -> Rate v -> Acceleration v)+ -- ^ Differential equation, representing acceleration in+ -- terms of position and velocity at an absolute time.+ -> (p,Rate v)+ -- ^ Initial value.+ -> Time+ -- ^ Starting time.+ -> Time+ -- ^ Ending time.+ -> Integer+ -- ^ Number of time steps.+ -> (p,Rate v)+integrateRK4' addPV diffF = genericIntegrate $ rk4' addPV diffF+
+ RSAGL/FRP/RecombinantState.hs view
@@ -0,0 +1,23 @@+{-# LANGUAGE TypeFamilies #-}+module RSAGL.FRP.RecombinantState+ (RecombinantState(..))+ where++-- | Describes concurrency-aware state. The goal is to take some stateful+-- information, clone it into a variety of concurrent threads, and then+-- recombine using the (possibly modified) state.+class RecombinantState s where+ type SubState s :: *+ -- | A new version of the state, which should carry the context,+ -- but not the content, of the original. I.e., the original+ -- content will be re-merged during the recombination phase.+ clone :: s -> SubState s+ -- | Recombine the modified, cloned information with the+ -- original state.+ recombine :: s -> SubState s -> s++instance RecombinantState () where+ type SubState () = ()+ clone = id+ recombine = const+
+ RSAGL/FRP/Time.lhs view
@@ -0,0 +1,178 @@+\section{RSAGL.Time}++RSAGL.Time provides a fixed-point (as opposed to a floating-point number) representation of time.+This is necessary because the Float and RSdouble types are inadequate to precisely represent large+quantities of time.++This time library is designed to support real-time animation.++\begin{code}+{-# LANGUAGE TypeSynonymInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses #-}++module RSAGL.FRP.Time+ (Time,+ Rate,+ Acceleration,+ Frequency,+ fps30,+ fps60,+ fps120,+ minute,+ day,+ month,+ year,+ pack,+ unpack,+ packa,+ unpacka,+ fromSeconds,+ toSeconds,+ getTime,+ cyclical,+ cyclical',+ over,+ rate,+ time,+ perSecond,+ per,+ interval,+ withTime)+ where++import RSAGL.Math.AbstractVector+import System.Time+import RSAGL.Math.Affine+import RSAGL.Math.Types++{-# INLINE time_resolution #-}+time_resolution :: (Num n) => n+time_resolution = 1000000++newtype Time = Time Integer deriving (Show,Eq,Ord)+newtype Rate a = Rate a deriving (Show,Eq,Ord,AffineTransformable)+type Acceleration a = Rate (Rate a)+type Frequency = Rate RSdouble++instance AbstractZero Time where+ zero = Time 0++instance AbstractAdd Time Time where+ add (Time a) (Time b) = Time $ a + b++instance AbstractSubtract Time Time where+ sub (Time a) (Time b) = Time $ a - b++instance AbstractScale Time where+ scalarMultiply d (Time t) = Time $ round $ d * fromInteger t++instance AbstractVector Time++instance (AbstractZero a) => AbstractZero (Rate a) where+ zero = Rate zero++instance (AbstractAdd a a) => AbstractAdd (Rate a) (Rate a) where+ add (Rate a) (Rate b) = Rate $ a `add` b++instance (AbstractSubtract a a) => AbstractSubtract (Rate a) (Rate a) where+ sub (Rate a) (Rate b) = Rate $ a `sub` b++instance (AbstractScale a) => AbstractScale (Rate a) where+ scalarMultiply d (Rate r) = Rate $ scalarMultiply d r++instance (AbstractVector a) => AbstractVector (Rate a)+\end{code}++\subsection{Getting and Constructing Time}++getTime gets the current, absolute time, using Haskell's standard time facilities, getClockTime.++\begin{code}+minute :: Time+minute = fromSeconds 60++hour :: Time+hour = scalarMultiply 60 minute++day :: Time+day = scalarMultiply 24 hour++month :: Time+month = scalarMultiply 30.43 day++year :: Time+year = scalarMultiply 365.25 month++fps30 :: Frequency+fps30 = perSecond 30++fps60 :: Frequency+fps60 = perSecond 60++fps120 :: Frequency+fps120 = perSecond 120++fromSeconds :: RSdouble -> Time+fromSeconds = Time . round . (* time_resolution)++toSeconds :: Time -> RSdouble+toSeconds (Time t) = fromInteger t / time_resolution++getTime :: IO Time+getTime =+ do (TOD secs picos) <- getClockTime+ return $ Time $ secs * time_resolution + (picos * time_resolution) `div` 1000000000000++pack :: [Rate a] -> Rate [a]+pack = Rate . map (\(Rate a) -> a)++unpack :: Rate [a] -> [Rate a]+unpack (Rate as) = map perSecond as++unpacka :: Acceleration [a] -> [Acceleration a]+unpacka (Rate (Rate as)) = map (Rate . Rate) as++packa :: [Acceleration a] -> Acceleration [a]+packa = Rate . Rate . map (\(Rate (Rate a)) -> a)+\end{code}++\subsection{Modulo Division for Time}++\texttt{cyclical} answers the amount of time into a cycle. \texttt{cyclical'} answers the fraction of time into a cycle, +in the range \texttt{0 <= x <= 1}.++\begin{code}+cyclical :: Time -> Time -> Time+cyclical (Time t) (Time k) = Time $ t `mod` k++cyclical' :: Time -> Time -> RSdouble+cyclical' t k = (toSeconds $ t `cyclical` k) / toSeconds k+\end{code}++\subsection{Rate as Change over Time}++\begin{code}+{-# INLINE over #-}+over :: (AbstractVector a) => Rate a -> Time -> a+over (Rate a) (Time t) = (fromInteger t / time_resolution) `scalarMultiply` a++{-# INLINE rate #-}+rate :: (AbstractVector a) => (a,Time) -> (a,Time) -> Rate a+rate (x,t1) (y,t2) = (y `sub` x) `per` (t2 `sub` t1)++perSecond :: a -> Rate a+perSecond a = Rate a++{-# INLINE per #-}+per :: (AbstractVector a) => a -> Time -> Rate a+per a (Time t) = Rate $ (recip $ fromInteger t / time_resolution) `scalarMultiply` a++interval :: Frequency -> Time+interval (Rate x) = fromSeconds $ recip x++time :: RSdouble -> Rate RSdouble -> Time+time d r = interval $ withTime (fromSeconds 1) (/d) r++{-# INLINE withTime #-}+withTime :: (AbstractVector a,AbstractVector b) => Time -> (a -> b) -> Rate a -> Rate b+withTime t f = (`per` t) . f . (`over` t)+\end{code}
+ Setup.hs view
@@ -0,0 +1,5 @@+#!/usr/bin/runhaskell++import Distribution.Simple++main = defaultMainWithHooks simpleUserHooks
+ rsagl-frp.cabal view
@@ -0,0 +1,46 @@+name: rsagl-frp+version: 0.6.0.0+license: BSD3+license-file: LICENSE+author: Christopher Lane Hinson+maintainer: Christopher Lane Hinson <lane@downstairspeople.org>++category: FRP+synopsis: The RogueStar Animation and Graphics Library: Functional Reactive Programming+description: RSAGL, the RogueStar Animation and Graphics Library,+ was specifically designed for a computer game called+ roguestar, but effort has been made to make it accessable+ to other projects that might benefit from it.+ .+ This package implements the RSAGL functional reactive+ programming architecture.+cabal-version: >= 1.2+homepage: http://roguestar.downstairspeople.org/++build-type: Simple+tested-with: GHC==6.12.1++Library+ exposed-modules: RSAGL.FRP,+ RSAGL.FRP.Accumulation+ RSAGL.FRP.FactoryArrow+ RSAGL.FRP.FRP+ RSAGL.FRP.FRPModel+ RSAGL.FRP.Message+ RSAGL.FRP.RecombinantState+ RSAGL.FRP.RK4+ RSAGL.FRP.Time++ ghc-options: -fno-warn-type-defaults -fexcess-precision+ ghc-prof-options: -prof -auto-all++ build-depends: base>=4 && <5,+ rsagl-math==0.6.0.0,+ random>= 1.0.0.2 && < 1.1,+ old-time>= 1.0.0.3 && < 1.1,+ array>= 0.3.0.0 && < 0.4,+ arrows>= 0.4.1.2 && < 0.5,+ containers>= 0.3.0.0 && < 0.4,+ mtl>= 1.1.0.2 && < 1.2,+ stm>= 2.1.1.2 && < 2.2+