netwire 3.1.0 → 4.0.0
raw patch · 39 files changed
+2688/−2442 lines, 39 filesdep +bifunctorsdep +profunctorsdep +semigroupsdep −arrowsdep −stmdep ~basedep ~containersdep ~deepseqsetup-changed
Dependencies added: bifunctors, profunctors, semigroups, tagged
Dependencies removed: arrows, stm
Dependency ranges changed: base, containers, deepseq, lifted-base, monad-control, mtl, random, time, vector, vector-space
Files
- Control/Wire.hs +329/−10
- Control/Wire/Classes.hs +21/−68
- Control/Wire/Instances.hs +0/−54
- Control/Wire/Prefab.hs +10/−12
- Control/Wire/Prefab/Accum.hs +85/−33
- Control/Wire/Prefab/Analyze.hs +143/−129
- Control/Wire/Prefab/Calculus.hs +0/−54
- Control/Wire/Prefab/Clock.hs +0/−40
- Control/Wire/Prefab/Effect.hs +117/−0
- Control/Wire/Prefab/Event.hs +213/−213
- Control/Wire/Prefab/Execute.hs +0/−46
- Control/Wire/Prefab/Move.hs +197/−0
- Control/Wire/Prefab/Noise.hs +96/−0
- Control/Wire/Prefab/Queue.hs +61/−30
- Control/Wire/Prefab/Random.hs +0/−64
- Control/Wire/Prefab/Sample.hs +64/−39
- Control/Wire/Prefab/Simple.hs +34/−47
- Control/Wire/Prefab/Split.hs +0/−65
- Control/Wire/Prefab/Time.hs +45/−0
- Control/Wire/Session.hs +192/−90
- Control/Wire/TimedMap.hs +78/−77
- Control/Wire/Tools.hs +0/−43
- Control/Wire/Trans.hs +11/−13
- Control/Wire/Trans/Clock.hs +0/−128
- Control/Wire/Trans/Combine.hs +83/−61
- Control/Wire/Trans/Embed.hs +47/−0
- Control/Wire/Trans/Event.hs +211/−0
- Control/Wire/Trans/Exhibit.hs +0/−69
- Control/Wire/Trans/Fork.hs +0/−232
- Control/Wire/Trans/Memoize.hs +0/−99
- Control/Wire/Trans/Sample.hs +0/−161
- Control/Wire/Trans/Simple.hs +33/−41
- Control/Wire/Trans/Switch.hs +101/−0
- Control/Wire/Trans/Time.hs +31/−0
- Control/Wire/Types.hs +94/−473
- Control/Wire/Wire.hs +348/−0
- LICENSE +1/−1
- Setup.lhs +1/−1
- netwire.cabal +42/−49
Control/Wire.hs view
@@ -1,31 +1,350 @@ -- | -- Module: Control.Wire--- Copyright: (c) 2011 Ertugrul Soeylemez+-- Copyright: (c) 2012 Ertugrul Soeylemez -- License: BSD3 -- Maintainer: Ertugrul Soeylemez <es@ertes.de> ----- Convenience module for the Netwire library.+-- Netwire is a library for functional reactive programming, that is for+-- time-varying values. It allows you to express various reactive+-- systems elegantly and concisely by using an embedded domain-specific+-- language. Examples of such systems include+--+-- * games,+--+-- * network applications with time-varying components,+--+-- * simulations,+--+-- * stateful web applications,+--+-- * widget-based user interfaces.+--+-- This library is based on an extension of the automaton arrow. The+-- usage is explained in the following tutorial. module Control.Wire- ( -- * Reexports+ ( -- * Quickstart tutorial+ -- $quickstart_intro++ -- ** Running wires+ -- $quickstart_running++ -- ** Constructing wires+ -- $quickstart_constructing++ -- ** Signal inhibition and events+ -- $quickstart_inhibition++ -- ** Custom wires+ -- $quickstart_custom++ -- * Netwire reexports module Control.Wire.Classes, module Control.Wire.Prefab, module Control.Wire.Session,- module Control.Wire.Tools, module Control.Wire.Trans, module Control.Wire.Types,+ module Control.Wire.Wire, - -- * Convenience- module Control.Arrow.Operations,- module Control.Arrow.Transformer+ -- * Other reexports+ module Control.Applicative,+ module Control.Arrow,+ module Control.Category,+ module Data.Profunctor,+ module System.Random,+ Proxy(..),+ Exception(..),+ SomeException(..) ) where -import Control.Arrow.Operations-import Control.Arrow.Transformer+import Control.Applicative+import Control.Arrow+import Control.Category+import Control.Exception (Exception(..), SomeException(..)) import Control.Wire.Classes import Control.Wire.Prefab import Control.Wire.Session-import Control.Wire.Tools import Control.Wire.Trans import Control.Wire.Types+import Control.Wire.Wire hiding (constant, identity, never)+import Data.Profunctor hiding (WrappedArrow(..))+import Data.Proxy (Proxy(..))+import System.Random+++{- $quickstart_intro++This section is a quickstart tutorial for the experienced, impatient+Haskell programmer.++The main concept used in Netwire is a family of /wire categories/:++> data Wire e m a b++A value of type @Wire e m a b@ represents a function that takes as+arguments++* a time delta of type 'Time' (which is just 'Double') that will be+ explained below,++* an input value of type @a@.++From these inputs it++* either produces an output value of type @b@ or /inhibits/ with a value+ of type @e@,++* produces a new wire of type @Wire e m a b@.++So you can think of 'Wire' as:++> newtype Wire e m a b =+> Wire {+> stepWire :: Time -> a -> m (Either e b, Wire e m a b)+> }++To summarize a wire of type @Wire e m a b@ takes a value of type @a@ and+supposedly produces a value of type @b@. It can be invoked multiple+times, where each invocation is called an /instant/ and the wire can+behave differently at every instant. Additionally it can choose not to+produce anything, but instead inhibit with an /inhibition exception/ of+type @e@. This is Netwire's notion of a time-varying value. -}+++{- $quickstart_running++To actually invoke a wire you can use the 'stepWire' function+(simplified type):++> stepWire ::+> (Monad m) =>+> Wire e m a b ->+> Time ->+> a ->+> m (Either e b, Wire e m a b)++The idea is simple: You have an application loop that invokes a given+wire with a time delta, which is just the number of seconds passed since+the last instant and an application-specific input value. It then does+something with the output value (or inhibition value) and restarts the+loop with the new wire produced by the current wire. Such an+application loop based on @stepWire@ could look like this:++> loop w' = do+> dt <- timeDeltaToLastInstant+> (mx, w) <- stepWire w' dt ()+> case mx of+> Left ex -> printf "Inhibited: %s\n" (show ex)+> Right x -> printf "Produced: %s\n" (show x)+> loop w++Usually the time deltas are based on actual clock time. To simplify+invocation for this common case there is a set of convenience functions+like 'stepSession' for stepping that calculate the time deltas for you:++> stepSession ::+> (Monad m) =>+> Wire e m a b ->+> Session m ->+> a ->+> m (Either e b, Wire e m a b, Session m)++To construct the initial session value you can use 'clockSession' or one+of the other predefined intial session values:++> clockSession :: (MonadIO m) => Session m++This simplifies the application loop, because you don't have to+calculate the time deltas yourself:++> loop w' session' = do+> (mx, w, session) <- stepSession w' session' ()+> case mx of+> Left ex -> printf "Inhibited: %s\n" (show ex)+> Right x -> printf "Produced: %s\n" (show x)+> loop w session++For the common case where the wire's underlying monad is 'Identity', but+the application monad is something else, there are convenience functions+like 'stepWireP', 'stepSessionP' and other @*P@ variants.++We haven't covered constructing wires yet. This is explained in the+next section. But we now have everything necessary to write our first+small application:++> module Main where+>+> import Control.Wire+> import Prelude hiding ((.), id)+> import Text.Printf+>+> testApp :: Wire () Identity a Time+> testApp = timeFrom 10+>+> main :: IO ()+> main = loop testApp clockSession+> where+> loop w' session' = do+> (mx, w, session) <- stepSessionP w' session' ()+> case mx of+> Left ex -> putStrLn ("Inhibited: " ++ show ex)+> Right x -> putStrLn ("Produced: " ++ show x)+> loop w session++When you run this program, it will continuously display a number of+seconds starting with 10. That's the @timeFrom 10@ wire. Notice that+the "Prelude" module is imported with hidden 'Prelude..' and+'Prelude.id'. Don't worry, the "Control.Wire" module reexports the+"Control.Category" module, which includes generalized version of both.+-}+++{- $quickstart_constructing++A number of convenience types are defined in the "Control.Wire.Types"+module, in particular the 'WireP' type:++> type WireP = Wire LastException Identity++Wires can be composed categorically, applicatively or by using wire+combinators. To feed the output of one wire @w1@ into another wire @w2@+you just use categorical composition:++> w2 . w1++For example the 'noise' wire generates random noise based on the given+random number generator. If its output type is 'Double', it generates+noise 0 <= x t < 1. The 'avg' wire calculates the average value of its+input over the last given number of samples:++> let myNoise = noise (mkStdGen 0) :: WireP a Double+> myAvg = avg 1000+> in myAvg . myNoise++That wire should produce values near 0.5, the average noise value over+the last 1000 samples of random noise between 0 and 1. There is a bit+of cruft here to tell the type system that noise's output type is+'Double'. To make this easier you can simply use 'outAs' or 'inAs':++> avg 1000 . outAs pDouble (noise (mkStdGen 0))++The 'Wire' type gives rise to a family of applicative functors. Using+applicative style you can apply a function to the output of a wire or+zip together the outputs of two wires (the "Control.Applicative" module+is reexported by this module):++> timeString = fmap (printf "%8.2f") time+>+> noisyTime = liftA2 (+) time (noise (mkStdGen 0))++Constant wires can be produced using 'pure'. The following wire starts+at 0 and increases with a constant speed of 3:++> integral_ 0 . pure 3++There are lots of convenience instances for wires. For example there+are instances for 'Num', 'Fractional' and 'Data.String.IsString', so you+can actually just use regular arithmetical operators and numeric+literals. If you have enabled the @OverloadedStrings@ extension you can+also write string literals:++> let n = noise (mkStdGen 0)+> in time + 3*n+>+> integral_ 0 . 3++There is a large library of predefined wires below the+"Control.Wire.Prefab" tree.+-}+++{- $quickstart_inhibition++As noted a few times wires can choose not to produce a value. In those+cases the wire /inhibits/ the signal. This is where the @e@ type comes+into play. That type is called the /inhibition monoid/.++Signal inhibition is what makes Netwire different. The 'Wire' type is+an 'Alternative' functor, where the 'empty' wire always inhibits and+wires can be combined with the following semantics:++> w1 <|> w2++If @w1@ inhibits, then the combination @w1 \<|\> w2@ acts like @w2@. In+other words, the combination chooses the first wire that produces. If+both inhibit, then the combination inhibits.++Events are modelled around this. An event wire is usually a wire that+acts like the identity wire, but it may inhibit depending on whether an+event has occurred or not. One simple event wire is the 'for' wire:++> for 3++This wire acts like the identity wire for three seconds and then stops+producing forever. You can use it to construct a wire that produces+"yes" for three seconds and then switches to "no":++> "yes" . for 3 <|> "no"++Another useful event wire is the 'wackelkontakt' wire (a Netwire running+gag; it's the German word for slack joint):++> wackelkontakt 0.9++This wire acts like the identity wire most of the time (90%), but+occasionally inhibits (10%). Using it you can produce a broken clock,+which occasionally refuses to display the current time:++> brokenClock =+> printf "%8.2f" <$> wackelkontakt 0.9 . time <|>+> "sorry, slack joint"++The 'periodically' wire produces once every given number of seconds.+The following wire produces once every two seconds:++> periodically 2++There are various combinators for event wires in the+"Control.Wire.Trans.Event" module, most notably 'hold' and 'holdFor'.+Given an inhibiting wire the @hold@ combinator holds the last produced+value, so it turns instantaneous events into continuous ones:++> secondClock = printf "%8.2f" <$> hold (periodically 1 . time)++This one displays the time in seconds and is only updated every second.+The 'holdFor' combinator allows you to limit the time the last output is+held for:++> jumpyClock =+> printf "%8.2f" <$> hold 0.5 (periodically 1 . time) <|>+> "wait 500ms for the next second"++You find a library of predefined event wires in the+"Control.Wire.Prefab.Event" module.+-}+++{- $quickstart_custom++From time to time you will want to write your own wire on a lower level.+In this case there are a number of options. The simplest option is+'mkPure':++> mkPure ::+> (Time -> a -> (Either e b, Wire e m a b)) ->+> Wire e m a b++The type quite literally tells what this function does. It takes a+function and turns it into a wire quite straightforwardly. Another+option is to use 'mkState', which is equivalent to @mkPure@, but allows+you to express the wire as a local state transformer:++> mkState ::+> s ->+> (Time -> (a, s) -> (Either e b, s)) ->+> Wire e m a b++The first argument is a starting state, the second is the state+transformation function.+-}
Control/Wire/Classes.hs view
@@ -1,93 +1,46 @@ -- | -- Module: Control.Wire.Classes--- Copyright: (c) 2011 Ertugrul Soeylemez+-- Copyright: (c) 2012 Ertugrul Soeylemez -- License: BSD3 -- Maintainer: Ertugrul Soeylemez <es@ertes.de> ----- Type classes used in Netwire.+-- Various type classes. module Control.Wire.Classes- ( -- * Various effects- -- ** Monadic- MonadClock(..),+ ( -- * Effects MonadRandom(..),- -- ** Arrows- ArrowKleisli(..),- arrIO++ -- * Utility classes+ Injectable(..) ) where -import Control.Applicative-import Control.Arrow-import Control.Arrow.Transformer-import Control.Arrow.Transformer.Automaton-import Control.Arrow.Transformer.Error-import Control.Arrow.Transformer.Reader-import Control.Arrow.Transformer.State-import Control.Arrow.Transformer.Static-import Control.Arrow.Transformer.Writer-import Control.Monad.Trans (MonadIO(..)) import Data.Monoid-import Data.Time.Clock.POSIX import System.Random --- | Arrows which support running monadic computations.--class Arrow (>~) => ArrowKleisli m (>~) | (>~) -> m where- -- | Run the input computation and output its result.- arrM :: Monad m => m b >~ b--instance Monad m => ArrowKleisli m (Kleisli m) where- arrM = Kleisli id--instance ArrowKleisli m (>~) => ArrowKleisli m (Automaton (>~)) where- arrM = lift arrM--instance (ArrowChoice (>~), ArrowKleisli m (>~)) => ArrowKleisli m (ErrorArrow ex (>~)) where- arrM = lift arrM--instance ArrowKleisli m (>~) => ArrowKleisli m (ReaderArrow e (>~)) where- arrM = lift arrM--instance ArrowKleisli m (>~) => ArrowKleisli m (StateArrow s (>~)) where- arrM = lift arrM--instance (Applicative f, ArrowKleisli m (>~)) => ArrowKleisli m (StaticArrow f (>~)) where- arrM = lift arrM--instance (ArrowKleisli m (>~), Monoid l) => ArrowKleisli m (WriterArrow l (>~)) where- arrM = lift arrM----- | Monads with a clock.+-- | Class for injectable values. See+-- 'Control.Wire.Prefab.Event.inject'. -class Monad m => MonadClock t m | m -> t where- -- | Current time in some monad-specific frame of reference.- getTime :: m t+class Injectable e f where+ toSignal :: f a -> Either e a --- | Instance for the system time. This is intentionally specific to--- allow you to define better instances with custom monads.+instance (Monoid e) => Injectable e Maybe where+ toSignal = maybe (Left mempty) Right -instance MonadClock Double IO where- getTime = fmap realToFrac getPOSIXTime+instance Injectable e (Either e) where+ toSignal = id --- | Monads supporting random number generation.+-- | Monads with a random number generator. -class Monad m => MonadRandom m where- -- | Returns a random number for the given type.- getRandom :: Random a => m a+class (Monad m) => MonadRandom m where+ -- | Get a random number.+ getRandom :: (Random a) => m a - -- | Returns a random number in the given range.- getRandomR :: Random a => (a, a) -> m a+ -- | Get a random number in the given range.+ getRandomR :: (Random a) => (a, a) -> m a instance MonadRandom IO where- getRandom = randomIO+ getRandom = randomIO getRandomR = randomRIO----- | Kleisli arrows, which have 'IO' at their base.--arrIO :: (ArrowKleisli m (>~), MonadIO m) => IO b >~ b-arrIO = arrM <<^ liftIO
− Control/Wire/Instances.hs
@@ -1,54 +0,0 @@--- |--- Module: Control.Wire.Instances--- Copyright: (c) 2011 Ertugrul Soeylemez--- License: BSD3--- Maintainer: Ertugrul Soeylemez <es@ertes.de>------ This module defines 'Functor', 'Applicative', 'Alternative', 'Monad'--- and 'MonadPlus' instances for 'First' and 'Last' monoids.--module Control.Wire.Instances () where--import Control.Applicative-import Control.Monad-import Data.Monoid---instance Functor First where- fmap f (First c) = First (fmap f c)--instance Applicative First where- pure = First . pure- First cf <*> First cx = First (cf <*> cx)--instance Alternative First where- empty = First Nothing- First cx <|> First cy = First (cx <|> cy)--instance Monad First where- return = pure- First cx >>= f = First (cx >>= getFirst . f)--instance MonadPlus First where- mzero = empty- mplus = (<|>)---instance Functor Last where- fmap f (Last c) = Last (fmap f c)--instance Applicative Last where- pure = Last . pure- Last cf <*> Last cx = Last (cf <*> cx)--instance Alternative Last where- empty = Last Nothing- Last cx <|> Last cy = Last (cy <|> cx)--instance Monad Last where- return = pure- Last cx >>= f = Last (cx >>= getLast . f)--instance MonadPlus Last where- mzero = empty- mplus = (<|>)
Control/Wire/Prefab.hs view
@@ -1,35 +1,33 @@ -- | -- Module: Control.Wire.Prefab--- Copyright: (c) 2011 Ertugrul Soeylemez+-- Copyright: (c) 2012 Ertugrul Soeylemez -- License: BSD3 -- Maintainer: Ertugrul Soeylemez <es@ertes.de> ----- Convenience module importing all the prefab wires.+-- Proxy module for the prefab wires. module Control.Wire.Prefab ( -- * Reexports module Control.Wire.Prefab.Accum, module Control.Wire.Prefab.Analyze,- module Control.Wire.Prefab.Calculus,- module Control.Wire.Prefab.Clock,+ module Control.Wire.Prefab.Effect, module Control.Wire.Prefab.Event,- module Control.Wire.Prefab.Execute,+ module Control.Wire.Prefab.Move,+ module Control.Wire.Prefab.Noise, module Control.Wire.Prefab.Queue,- module Control.Wire.Prefab.Random, module Control.Wire.Prefab.Sample, module Control.Wire.Prefab.Simple,- module Control.Wire.Prefab.Split+ module Control.Wire.Prefab.Time ) where import Control.Wire.Prefab.Accum import Control.Wire.Prefab.Analyze-import Control.Wire.Prefab.Calculus-import Control.Wire.Prefab.Clock+import Control.Wire.Prefab.Effect import Control.Wire.Prefab.Event-import Control.Wire.Prefab.Execute+import Control.Wire.Prefab.Move+import Control.Wire.Prefab.Noise import Control.Wire.Prefab.Queue-import Control.Wire.Prefab.Random import Control.Wire.Prefab.Sample import Control.Wire.Prefab.Simple-import Control.Wire.Prefab.Split+import Control.Wire.Prefab.Time
Control/Wire/Prefab/Accum.hs view
@@ -1,61 +1,113 @@ -- | -- Module: Control.Wire.Prefab.Accum--- Copyright: (c) 2011 Ertugrul Soeylemez+-- Copyright: (c) 2012 Ertugrul Soeylemez -- License: BSD3 -- Maintainer: Ertugrul Soeylemez <es@ertes.de> ----- Wires for signal accumulation.+-- Accumulation wires. These are left-scan equivalents of several+-- sorts. module Control.Wire.Prefab.Accum- ( -- * General accumulator+ ( -- * General+ -- ** Accumulation accum,+ accumT,+ -- ** Function iteration+ iterateW,+ iterateWT,+ -- ** Generic unfolding+ unfold,+ unfoldT, - -- * Special accumulators+ -- * Special countFrom,- countStep,-- -- * Specific instances- atFirst+ enumFromW,+ mconcatW ) where -import Control.Wire.Prefab.Simple-import Control.Wire.Types+import Control.Wire.Wire+import Data.AdditiveGroup+import Data.Monoid+import Prelude hiding (enumFrom, iterate) --- | General accumulator. Outputs the argument value at the first--- instant, then applies the input function repeatedly for subsequent--- instants. This acts like the 'iterate' function for lists.+-- | The most general accumulator. This wire corresponds to a left+-- scan. ----- * Depends: current instant.+-- * Depends: previous instant. -accum :: WirePure (>~) => a -> Wire e (>~) (a -> a) a-accum x =- mkPure $ \f -> x `seq` (Right x, accum (f x))+accum :: (b -> a -> b) -> b -> Wire e m a b+accum f = accumT (const f) --- | Apply the given function at the first instant. Then act as the--- identity wire forever.+-- | Like 'accum', but the accumulation function also receives the+-- current time delta. ----- * Depends: Current instant.+-- * Depends: previous instant, time. -atFirst :: WirePure (>~) => (b -> b) -> Wire e (>~) b b-atFirst f = mkPure $ \x -> (Right (f x), identity)+accumT :: (Time -> b -> a -> b) -> b -> Wire e m a b+accumT f x' =+ mkPure $ \dt x ->+ x' `seq` (Right x', accumT f (f dt x' x)) --- | Count upwards from the given starting value.+-- | Counts from the given vector adding the current input for the next+-- instant.+--+-- * Depends: previous instant. -countFrom :: (Enum b, WirePure (>~)) => b -> Wire e (>~) a b-countFrom n = mkPure $ \_ -> n `seq` (Right n, countFrom (succ n))+countFrom :: (AdditiveGroup b) => b -> Wire e m b b+countFrom = accum (^+^) --- | Count from the given starting value, repeatedly adding the input--- signal to it.+-- | Enumerates from the given element.++enumFromW :: (Enum b) => b -> Wire e m a b+enumFromW = accum (\x _ -> succ x)+++-- | Apply the input function continously. Corresponds to 'iterate' for+-- lists.++iterateW :: (b -> b) -> b -> Wire e m a b+iterateW f = accum (\x _ -> f x)+++-- | Like 'iterate', but the accumulation function also receives the+-- current time delta. ----- * Depends: current instant.+-- * Depends: time. -countStep :: (Num b, WirePure (>~)) => b -> Wire e (>~) b b-countStep x =- mkPure $ \dx ->- x `seq`- (Right x, countStep (x + dx))+iterateWT :: (Time -> b -> b) -> b -> Wire e m a b+iterateWT f = accumT (\dt x _ -> f dt x)+++-- | Running 'Monoid' sum.+--+-- * Depends: previous instant.++mconcatW :: (Monoid b) => Wire e m b b+mconcatW = accum mappend mempty+++-- | Corresponds to 'unfoldr' for lists.+--+-- * Depends: current instant, if the unfolding function is strict in+-- its second argument.++unfold :: (s -> a -> (b, s)) -> s -> Wire e m a b+unfold = unfoldT . const+++-- | Like 'unfold', but the accumulation function also receives the+-- current time delta.+--+-- * Depends: current instant, if the unfolding function is strict in+-- its third argument, time.++unfoldT :: (Time -> s -> a -> (b, s)) -> s -> Wire e m a b+unfoldT f s' =+ mkPure $ \dt x' ->+ let (x, s) = f dt s' x' in+ x `seq` (Right x, unfoldT f s)
Control/Wire/Prefab/Analyze.hs view
@@ -1,15 +1,16 @@ -- | -- Module: Control.Wire.Prefab.Analyze--- Copyright: (c) 2011 Ertugrul Soeylemez+-- Copyright: (c) 2012 Ertugrul Soeylemez -- License: BSD3 -- Maintainer: Ertugrul Soeylemez <es@ertes.de> ----- Various signal analysis tools+-- Signal analysis wires. module Control.Wire.Prefab.Analyze ( -- * Statistics -- ** Average avg,+ avgInt, avgAll, avgFps, avgFpsInt,@@ -20,210 +21,223 @@ -- * Monitoring collect,- diff, firstSeen, lastSeen ) where import qualified Data.Map as M-import qualified Data.Set as S-import qualified Data.Vector.Unboxed as Vu-import qualified Data.Vector.Unboxed.Mutable as Vum-import Control.Arrow-import Control.Monad.Fix-import Control.Monad.ST-import Control.Wire.Trans.Clock-import Control.Wire.Trans.Sample-import Control.Wire.Types+import qualified Data.Sequence as Seq+import Control.Category+import Control.Wire.Prefab.Time+import Control.Wire.Wire import Data.Map (Map) import Data.Monoid-import Data.Set (Set)+import Data.Sequence (Seq, ViewL(..), (|>), viewl)+import Data.VectorSpace+import Prelude hiding ((.), id) -- | Calculate the average of the signal over the given number of last -- samples. If you need an average over all samples ever produced, -- consider using 'avgAll' instead. ----- * Complexity: O(n) space, O(1) time wrt number of samples.+-- * Complexity: O(n) space wrt number of samples. -- -- * Depends: current instant. avg ::- forall e v (>~).- (Fractional v, Vu.Unbox v, WirePure (>~))+ forall a m e v.+ (Fractional a, VectorSpace v, Scalar v ~ a) => Int- -> Wire e (>~) v v-avg n = mkPure $ \x -> (Right x, avg' (Vu.replicate n (x/d)) x 0)+ -> Wire e m v v+avg n | n <= 0 = error "avg: The number of samples must be positive"+avg n =+ mkPure $ \_ x ->+ (Right x, avg' (Seq.replicate n (x ^/ d)) x)+ where- avg' :: Vu.Vector v -> v -> Int -> Wire e (>~) v v- avg' samples' s' cur' =- mkPure $ \((/d) -> x) ->- let cur = let ncur = succ cur' in- if ncur >= n then 0 else ncur- x' = samples' Vu.! cur- samples =- x' `seq` runST $ do- sam <- Vu.unsafeThaw samples'- Vum.write sam cur x- Vu.unsafeFreeze sam- s = s' - x' + x- in cur `seq` s' `seq` (Right s, avg' samples s cur)+ avg' :: Seq v -> v -> Wire e m v v+ avg' samples'' a' =+ mkPure $ \_ x ->+ let xa = x ^/ d+ xa' :< samples' = viewl samples''+ samples = samples' |> xa+ a = a' ^-^ xa' ^+^ xa+ in a `seq` (Right a, avg' samples a) - d :: v+ d :: Scalar v d = realToFrac n --- | Calculate the average of the signal over all samples.------ Please note that somewhat surprisingly this wire runs in constant--- space and is generally faster than 'avg', but most applications will--- benefit from averages over only the last few samples.+-- | Calculate the average of the input signal over all samples. This+-- is usually not what you want. In most cases the 'avg' wire is+-- preferable. -- -- * Depends: current instant. -avgAll :: forall e v (>~). (Fractional v, WirePure (>~)) => Wire e (>~) v v-avgAll = mkPure $ \x -> (Right x, avgAll' 1 x)+avgAll ::+ forall a m e v.+ (Fractional a, VectorSpace v, Scalar v ~ a)+ => Wire e m v v+avgAll = mkPure $ \_ x -> (Right x, avgAll' 1 x) where- avgAll' :: v -> v -> Wire e (>~) v v+ avgAll' :: a -> v -> Wire e m v v avgAll' n' a' =- mkPure $ \x ->+ mkPure $ \_ x -> let n = n' + 1- a = a' - a'/n + x/n+ a = a' ^+^ (x ^-^ a') ^/ n in a' `seq` (Right a, avgAll' n a) --- | Calculate the average number of frames per virtual second for the--- last given number of frames.+-- | Calculate the average number of instants per second for the last+-- given number of instants. In a continuous game or simulation this+-- corresponds to the average number of frames per second, hence the+-- name. ----- Please note that this wire uses the clock from the 'WWithDT' instance--- for the underlying arrow. If this clock doesn't represent real time,--- then the output of this wire won't either.+-- * Complexity: O(n) space wrt number of samples.+--+-- * Depends: time. -avgFps ::- (Arrow (Wire e (>~)), Fractional t, Vu.Unbox t, WirePure (>~), WWithDT t (>~))- => Int- -> Wire e (>~) a t-avgFps n = recip ^<< passDT (avg n)+avgFps :: (Monad m) => Int -> Wire e m a Double+avgFps n = recip (avg n) . dtime --- | Same as 'avgFps', but samples only at regular intervals. This can--- improve performance, if querying the clock is an expensive operation.+-- | Like 'avgFps', but sample in discrete intervals only. This can+-- greatly enhance the performance, when you have an inefficient clock+-- source.+--+-- * Complexity: O(n) space wrt number of samples.+--+-- * Depends: time. avgFpsInt ::- (Arrow (Wire e (>~)), Fractional t, Vu.Unbox t, WirePure (>~), WSampleInt (>~), WWithDT t (>~))- => Int -- ^ Interval size.- -> Int -- ^ Number of Samples.- -> Wire e (>~) a t-avgFpsInt int n =- proc x' ->- (| sampleInt ((* fromIntegral int) ^<< avgFps n -< x') |) int+ (Monad m)+ => Int -- ^ Sampling interval.+ -> Int -- ^ Number of samples.+ -> Wire e m a Double+avgFpsInt int n = recip (avgInt int n) . dtime --- | Collects all distinct inputs ever received.+-- | Same as 'avg', but with a sampling interval. This can be used to+-- increase the performance, if the input is complicated. ----- * Complexity: O(n) space, O(log n) time wrt collected inputs so far.+-- * Complexity: O(n) space wrt number of samples. -- -- * Depends: current instant. -collect :: forall b e (>~). (Ord b, WirePure (>~)) => Wire e (>~) b (Set b)-collect = collect' S.empty+avgInt ::+ forall a m e v.+ (Fractional a, VectorSpace v, Scalar v ~ a)+ => Int -- ^ Sampling interval.+ -> Int -- ^ Number of samples.+ -> Wire e m v v+avgInt _ n | n <= 0 = error "avg: The number of samples must be positive"+avgInt int n =+ mkPure $ \_ x ->+ (Right x, avg' 0 (Seq.replicate n (x ^/ d)) x)+ where- collect' :: Set b -> Wire e (>~) b (Set b)- collect' ins' =- mkPure $ \x ->- let ins = S.insert x ins'- in (Right ins, collect' ins)+ avg' :: Int -> Seq v -> v -> Wire e m v v+ avg' si samples'' a' | si < int = mkPure $ \_ _ -> (Right a', avg' (si + 1) samples'' a')+ avg' _ samples'' a' =+ mkPure $ \_ x ->+ let xa = x ^/ d+ xa' :< samples' = viewl samples''+ samples = samples' |> xa+ a = a' ^-^ xa' ^+^ xa+ in a `seq` (Right a, avg' 0 samples a) + d :: Scalar v+ d = realToFrac n --- | Outputs the last input value on every change of the input signal.--- Acts like the identity wire at the first instant.++-- | Collect all distinct inputs ever received together with a count.+-- Elements not appearing in the map have not been observed yet. ----- * Depends: current instant.+-- * Complexity: O(n) space. ----- * Inhibits: on no change after the first instant.+-- * Depends: current instant. -diff :: forall b e (>~). (Eq b, Monoid e, WirePure (>~)) => Wire e (>~) b b-diff = mkPure $ \x -> (Right x, diff' x)+collect :: forall b m e. (Ord b) => Wire e m b (Map b Int)+collect = collect' M.empty where- diff' :: b -> Wire e (>~) b b- diff' x' =- mkPure $ \x ->- if x' == x- then (Left mempty, diff' x')- else (Right x', diff' x)+ collect' :: Map b Int -> Wire e m b (Map b Int)+ collect' m' =+ mkPure $ \_ x ->+ let m = M.insertWith (+) x 1 m' in+ m `seq` (Right m, collect' m) --- | Reports the first global time the given input was seen.+-- | Outputs the first local time the input was seen. ----- * Complexity: O(n) space, O(log n) time wrt collected inputs so far.+-- * Complexity: O(n) space, O(log n) time wrt number of samples so far. ----- * Depends: Current instant.+-- * Depends: current instant, time. -firstSeen ::- forall a e t (>~). (Ord a, WirePure (>~), WWithSysTime t (>~))- => Wire e (>~) a t-firstSeen = withSysTime (firstSeen' M.empty)+firstSeen :: forall a m e. (Ord a) => Wire e m a Time+firstSeen = seen' 0 M.empty where- firstSeen' :: Map a t -> Wire e (>~) (a, t) t- firstSeen' xs' =- fix $ \again ->- mkPure $ \(x, t) ->- case M.lookup x xs' of- Just xt -> (Right xt, again)- Nothing -> (Right t, firstSeen' (M.insert x t xs'))+ seen' :: Time -> Map a Time -> Wire e m a Time+ seen' t' m' =+ mkPure $ \dt x ->+ let t = t' + dt in+ t `seq`+ case M.lookup x m' of+ Just xt -> (Right xt, seen' t m')+ Nothing ->+ let m = M.insert x t m' in+ m `seq` (Right t, seen' t m) --- | Outputs the high peak of the input signal.+-- | High peak. ----- * Depends: Current instant.+-- * Depends: current instant. -highPeak :: (Ord b, WirePure (>~)) => Wire e (>~) b b+highPeak :: (Ord b) => Wire e m b b highPeak = peakBy compare --- | Reports the last time the given input was seen. Inhibits when--- seeing a signal for the first time.+-- | Outputs the local time the input was previously seen. ----- * Complexity: O(n) space, O(log n) time wrt collected inputs so far.+-- * Complexity: O(n) space, O(log n) time wrt number of samples so far. ----- * Depends: Current instant.+-- * Depends: current instant, time. ----- * Inhibits: On first sight of a signal.+-- * Inhibits: if this is the first time the input is seen. -lastSeen ::- forall a e t (>~). (Monoid e, Ord a, WirePure (>~), WWithSysTime t (>~))- => Wire e (>~) a t-lastSeen = withSysTime (lastSeen' M.empty)+lastSeen :: forall a m e. (Monoid e, Ord a) => Wire e m a Time+lastSeen = seen' 0 M.empty where- lastSeen' :: Map a t -> Wire e (>~) (a, t) t- lastSeen' xs' =- mkPure $ \(x, t) ->- let xs = M.insert x t xs'- in (maybe (Left mempty) Right $ M.lookup x xs',- lastSeen' xs)+ seen' :: Time -> Map a Time -> Wire e m a Time+ seen' t' m' =+ mkPure $ \dt x ->+ let t = t' + dt+ m = M.insert x t m' in+ t `seq` m `seq`+ case M.lookup x m' of+ Just xt -> (Right xt, seen' t m)+ Nothing -> (Left mempty, seen' t m) --- | Outputs the low peak of the input signal.+-- | Low peak. ----- * Depends: Current instant.+-- * Depends: current instant. -lowPeak :: (Ord b, WirePure (>~)) => Wire e (>~) b b+lowPeak :: (Ord b) => Wire e m b b lowPeak = peakBy (flip compare) --- | Outputs the high peak of the input signal with respect to the given--- comparison function.+-- | Output the peak with respect to the given comparison function. ----- * Depends: Current instant.+-- * Depends: current instant. -peakBy ::- forall b e (>~). WirePure (>~)- => (b -> b -> Ordering)- -> Wire e (>~) b b-peakBy comp = mkPure (Right &&& peakBy')+peakBy :: forall b m e. (b -> b -> Ordering) -> Wire e m b b+peakBy f = mkPure $ \_ x -> (Right x, peak' x) where- peakBy' :: b -> Wire e (>~) b b- peakBy' x'' =- mkPure $ \x' ->- Right &&& peakBy' $ if comp x' x'' == GT then x' else x''+ peak' :: b -> Wire e m b b+ peak' x' =+ mkPure $ \_ x ->+ case f x' x of+ GT -> (Right x', peak' x')+ _ -> (Right x, peak' x)
− Control/Wire/Prefab/Calculus.hs
@@ -1,54 +0,0 @@--- |--- Module: Control.Wire.Prefab.Calculus--- Copyright: (c) 2011 Ertugrul Soeylemez--- License: BSD3--- Maintainer: Ertugrul Soeylemez <es@ertes.de>------ Wires for calculus over time.--module Control.Wire.Prefab.Calculus- ( -- * Integration- integral,-- -- * Differentiation- derivative- )- where--import Control.Wire.Trans.Clock-import Control.Wire.Types-import Data.VectorSpace----- | Integrate over time.------ * Depends: Current instant.--integral ::- forall e t v (>~).- (VectorSpace v, WirePure (>~), WWithDT t (>~), Scalar v ~ t)- => v -> Wire e (>~) v v-integral = withDT . integral'- where- integral' :: v -> Wire e (>~) (v, t) v- integral' x0 =- mkPure $ \(dx, dt) ->- let x1 = x0 ^+^ (dx ^* dt)- in x0 `seq` (Right x0, integral' x1)----- | Calculates the derivative of the input signal over time.------ * Depends: Current instant.--derivative ::- forall e t v (>~).- (Fractional t, VectorSpace v, WirePure (>~), WWithDT t (>~), Scalar v ~ t)- => Wire e (>~) v v-derivative = mkPure $ \x0 -> (Right zeroV, withDT (deriv' x0))- where- deriv' :: v -> Wire e (>~) (v, t) v- deriv' x0 =- mkPure $ \(x1, dt) ->- let dx = (x1 ^-^ x0) ^/ dt- in x0 `seq` (Right dx, deriv' x1)
− Control/Wire/Prefab/Clock.hs
@@ -1,40 +0,0 @@--- |--- Module: Control.Wire.Prefab.Clock--- Copyright: (c) 2011 Ertugrul Soeylemez--- License: BSD3--- Maintainer: Ertugrul Soeylemez <es@ertes.de>------ Various clocks.--module Control.Wire.Prefab.Clock- ( -- * Clock wires- dtime,- sysTime,- time- )- where--import Control.Wire.Prefab.Simple-import Control.Wire.Trans.Clock-import Control.Wire.Types----- | Time deltas starting from the time of the first instant.--dtime :: (WirePure (>~), WWithDT t (>~)) => Wire e (>~) a t-dtime = passDT identity----- | Global time. Independent of switching. *System* refers to the--- wire system, not the operating system, so this does not--- necessarily refer to OS time.--sysTime :: (WirePure (>~), WWithSysTime t (>~)) => Wire e (>~) a t-sysTime = passSysTime identity----- | Local time. Starts at the 'AdditiveGroup' notion of zero when--- switching in.--time :: (WirePure (>~), WWithTime t (>~)) => Wire e (>~) a t-time = passTime identity
+ Control/Wire/Prefab/Effect.hs view
@@ -0,0 +1,117 @@+-- |+-- Module: Control.Wire.Prefab.Effect+-- Copyright: (c) 2012 Ertugrul Soeylemez+-- License: BSD3+-- Maintainer: Ertugrul Soeylemez <es@ertes.de>+--+-- Effectful wires.++module Control.Wire.Prefab.Effect+ ( -- * Monadic effects+ -- ** Simple+ perform,+ -- ** Exception-aware+ execute,+ execute_,+ executeWith,+ executeWith_,++ -- * Branching+ branch,+ quit,+ quitWith+ )+ where++import qualified Data.Bifunctor as Bi+import Control.Exception.Lifted+import Control.Monad+import Control.Monad.Trans.Control+import Control.Wire.Types+import Control.Wire.Wire+import Data.List+import Data.Monoid+++-- | Branch according to the unterlying 'MonadPlus' instance. Note that+-- this wire branches at every instant.+--+-- * Depends: current instant.++branch :: (MonadPlus m) => Wire e m [a] a+branch = mkFixM $ \_ -> liftM Right . foldl' mplus mzero . map return+++-- | Variant of 'executeWith' for the 'LastException' inhibition monoid.+--+-- * Depends: current instant.+--+-- * Inhibits: when the action throws an exception.++execute ::+ (MonadBaseControl IO m)+ => Wire LastException m (m a) a+execute = executeWith (Last . Just)+++-- | Variant of 'executeWith_' for the 'LastException' inhibition monoid.+--+-- * Depends: current instant, if the given function is strict.+--+-- * Inhibits: when the action throws an exception.++execute_ ::+ (MonadBaseControl IO m)+ => (a -> m b)+ -> Wire LastException m a b+execute_ = executeWith_ (Last . Just)+++-- | Perform the input monadic action at every instant.+--+-- * Depends: current instant.+--+-- * Inhibits: when the action throws an exception.++executeWith ::+ (MonadBaseControl IO m)+ => (SomeException -> e) -- ^ Turns an exception into an inhibition value.+ -> Wire e m (m a) a+executeWith fromEx = mkFixM $ \_ c -> liftM (Bi.first fromEx) (try c)+++-- | Perform the given monadic action at every instant.+--+-- * Depends: current instant, if the given function is strict.+--+-- * Inhibits: when the action throws an exception.++executeWith_ ::+ (MonadBaseControl IO m)+ => (SomeException -> e) -- ^ Turns an exception into an inhibition value.+ -> (a -> m b) -- ^ Action to perform.+ -> Wire e m a b+executeWith_ fromEx c = mkFixM $ \_ -> liftM (Bi.first fromEx) . try . c+++-- | Perform the input monadic action in a wire.+--+-- * Depends: current instant.++perform :: (Monad m) => Wire e m (m b) b+perform = mkFixM . const $ liftM Right+++-- | Quits the current branch using 'mzero'.++quit :: (MonadPlus m) => Wire e m a b+quit = mkFixM $ \_ _ -> mzero+++-- | Acts like identity in the first instant, then quits the current+-- branch using 'mzero'.+--+-- * Depends: first instant.++quitWith :: (MonadPlus m) => Wire e m a a+quitWith = mkPure $ \_ x -> (Right x, quit)
Control/Wire/Prefab/Event.hs view
@@ -1,305 +1,305 @@ -- | -- Module: Control.Wire.Prefab.Event--- Copyright: (c) 2011 Ertugrul Soeylemez+-- Copyright: (c) 2012 Ertugrul Soeylemez -- License: BSD3 -- Maintainer: Ertugrul Soeylemez <es@ertes.de> ----- Wires for generating and manipulating events.+-- Event wires. module Control.Wire.Prefab.Event- ( -- * Event generation- -- ** Timed- WAfter(..),- WAt(..),- WDelayEvents(..),- WPeriodically(..),- -- ** Unconditional inhibition- inhibit,- never,+ ( -- * Instants+ afterI,+ eventsI,+ forI,+ notYet,+ once,+ periodicallyI,++ -- * Signal analysis+ changed,+ inject, -- ** Predicate-based asSoonAs, edge,- require, forbid,+ require,+ unless,+ until,+ when, while,- -- ** Instant-based- notYet,- once++ -- * Time+ after,+ events,+ for,+ periodically,++ -- * Utilities+ inhibit ) where -import qualified Data.Map as M-import qualified Data.Sequence as S-import Control.Arrow-import Control.Monad.Fix+import Control.Category import Control.Wire.Classes-import Control.Wire.Prefab.Simple import Control.Wire.Types+import Control.Wire.Wire import Data.Monoid-import Data.Map (Map)-import Data.Sequence (Seq, ViewL(..), (><))-import Data.VectorSpace+import Prelude hiding ((.), id, until) --- | Produces once after the input time interval has passed.+-- | Produce after the given amount of time. ----- * Depends: Current instant.+-- * Depends: current instant when producing, time. ----- * Inhibits: Always except at the target instant.+-- * Inhibits: until the given amount of time has passed. -class Arrow (>~) => WAfter t (>~) | (>~) -> t where- after :: Monoid e => Wire e (>~) t ()+after :: (Monoid e) => Time -> Event e m a+after t+ | t <= 0 = identity+ | otherwise = mkPure $ \dt _ -> (Left mempty, after (t - dt)) -instance (AdditiveGroup t, MonadClock t m, Ord t) => WAfter t (Kleisli m) where- after = after0- where- after0 :: forall e. Monoid e => Wire e (Kleisli m) t ()- after0 =- WmGen $ \int -> do- t0 <- getTime- return (int <= zeroV `orGoWith` after' t0) - where- after' :: t -> Wire e (Kleisli m) t ()- after' t0 =- fix $ \again ->- WmGen $ \int -> do- t <- getTime- return (t ^-^ t0 >= int `orGoWith` again)+-- | Produce after the given number of instants.+--+-- * Depends: current instant when producing.+--+-- * Inhibits: until the given number of instants has passed. +afterI :: (Monoid e) => Int -> Event e m a+afterI t+ | t <= 0 = identity+ | otherwise = mkPure $ \_ _ -> (Left mempty, afterI (t - 1)) --- | Produces once as soon as the current global time is later than or--- equal to the input global time and never again.++-- | Inhibit until the given predicate holds for the input signal. Then+-- produce forever. ----- * Depends: Current instant.+-- * Depends: current instant, if the predicate is strict. Once true,+-- on current instant forever. ----- * Inhibits: Always except at the target instant.+-- * Inhibits: until the predicate becomes true. -class Arrow (>~) => WAt t (>~) | (>~) -> t where- at :: Monoid e => Wire e (>~) t ()+asSoonAs :: (Monoid e) => (a -> Bool) -> Event e m a+asSoonAs p =+ mkPure $ \_ x ->+ if p x+ then (Right x, identity)+ else (Left mempty, asSoonAs p) -instance (MonadClock t m, Ord t) => WAt t (Kleisli m) where- at =- WmGen $ \tt -> do- t <- getTime- return (t >= tt `orGoWith` at) +-- | Produce when the signal has changed and at the first instant.+--+-- * Depends: current instant.+--+-- * Inhibits: after the first instant when the input has changed. --- | Delay incoming events.+changed :: (Eq a, Monoid e) => Event e m a+changed = mkPure $ \_ x0 -> (Right x0, changed' x0)+ where+ changed' x' =+ mkPure $ \_ x ->+ (if x' == x then Left mempty else Right x,+ changed' x) -class Arrow (>~) => WDelayEvents t (>~) | (>~) -> t where- -- | Delays each incoming event (left signal) by the given time- -- delta (right signal). The time delta at the instant the event- -- happened is significant.- --- -- * Depends: Current instant.- --- -- * Inhibits: When no delayed event happened.- delayEvents :: Monoid e => Wire e (>~) ([b], t) b - -- | Delays each incoming event (left signal) by the given time- -- delta (middle signal). The time delta at the instant the event- -- happened is significant. The right signal gives a maximum number- -- of events queued. When exceeded, new events are dropped, until- -- there is enough room.- --- -- * Depends: Current instant.- --- -- * Inhibits: When no delayed event happened.- delayEventsSafe :: Monoid e => Wire e (>~) (([b], t), Int) b+-- | Produces once whenever the given predicate switches from 'False' to+-- 'True'.+--+-- * Depends: current instant.+--+-- * Inhibits: when the predicate has not just switched from 'False' to+-- 'True'. -instance (AdditiveGroup t, MonadClock t m, Ord t) => WDelayEvents t (Kleisli m) where- -- delayEvents- delayEvents = delayEvents' M.empty- where- delayEvents' :: Monoid e => Map t (Seq b) -> Wire e (Kleisli m) ([b], t) b- delayEvents' delayed' =- WmGen $ \(evs, int) -> do- t <- getTime- let delayed = M.insertWith' (><) (t ^+^ int) (S.fromList evs) delayed'+edge :: (Monoid e) => (a -> Bool) -> Event e m a+edge p = off+ where+ off = mkPure $ \_ x -> if p x then (Right x, on) else (Left mempty, off)+ on = mkPure $ \_ x -> (Left mempty, if p x then on else off) - return $- case M.minViewWithKey delayed of- Nothing -> (Left mempty, delayEvents' delayed)- Just ((tt, revs), restMap)- | tt > t -> (Left mempty, delayEvents' delayed)- | otherwise ->- case S.viewl revs of- EmptyL -> (Left mempty, delayEvents' restMap)- rev :< restEvs ->- (Right rev,- delayEvents' (if S.null restEvs- then restMap- else M.insert tt restEvs restMap)) - -- delayEventsSafe- delayEventsSafe = delayEvents' 0 M.empty- where- delayEvents' :: Monoid e => Int -> Map t (Seq b) -> Wire e (Kleisli m) (([b], t), Int) b- delayEvents' curNum' delayed' =- WmGen $ \((evs, int), maxNum) -> do- t <- getTime- let addSeq = S.fromList evs- (curNum, delayed) =- if null evs || curNum' >= maxNum- then (curNum', delayed')- else (curNum' + S.length addSeq,- M.insertWith' (><) (t ^+^ int) addSeq delayed')- return $- case M.minViewWithKey delayed of- Nothing -> (Left mempty, delayEvents' curNum delayed)- Just ((tt, revs), restMap)- | tt > t -> (Left mempty, delayEvents' curNum delayed)- | otherwise ->- case S.viewl revs of- EmptyL -> (Left mempty, delayEvents' curNum restMap)- rev :< restEvs ->- (Right rev,- delayEvents' (pred curNum)- (if S.null restEvs- then restMap- else M.insert tt restEvs restMap))+-- | Produce once periodically. The production periods are given by the+-- argument list. When it's @[1,2,3]@ it produces after one second,+-- then after two more seconds and finally after three more seconds.+-- When the list is exhausted, it never produces again.+--+-- * Depends: current instant when producing, time.+--+-- * Inhibits: between the given intervals. +events :: (Monoid e) => [Time] -> Event e m a+events [] = never+events (t':ts) =+ mkPure $ \dt x ->+ let t = t' - dt in+ if t <= 0+ then (Right x, events (mapHead (+ t) ts))+ else (Left mempty, events (t:ts)) --- | Inhibits as long as the input signal is 'False'. Once it switches--- to 'True', it produces forever.+ where+ mapHead :: (a -> a) -> [a] -> [a]+ mapHead _ [] = []+ mapHead f (x:xs) = f x : xs+++-- | Variant of 'periodically' in number of instants instead of amount+-- of time. ----- * Depends: Current instant.+-- * Depends: current instant when producing. ----- * Inhibits: As long as input signal is 'False', then never again.+-- * Inhibits: between the given intervals. -asSoonAs :: (Monoid e, WirePure (>~)) => Wire e (>~) Bool ()-asSoonAs =- mkPure $ \b ->- if b then (Right (), constant ()) else (Left mempty, asSoonAs)+eventsI :: (Monoid e) => [Int] -> Event e m a+eventsI [] = never+eventsI (0:ts) = mkPure $ \_ x -> (Right x, eventsI ts)+eventsI (t:ts) = mkPure $ \_ _ -> (Left mempty, eventsI (t - 1 : ts)) --- | Produces once whenever the input signal switches from 'False' to--- 'True'.+-- | Produce for the given amount of time. ----- * Depends: Current instant.+-- * Depends: current instant when producing, time. ----- * Inhibits: Always except at the above mentioned instants.+-- * Inhibits: after the given amount of time has passed. -edge :: forall e (>~). (Monoid e, WirePure (>~)) => Wire e (>~) Bool ()-edge =- mkPure $ \b ->- if b then (Right (), switchBack) else (Left mempty, edge)+for :: (Monoid e) => Time -> Event e m a+for t+ | t <= 0 = never+ | otherwise = mkPure $ \dt x -> (Right x, for (t - dt)) - where- switchBack :: Wire e (>~) Bool ()- switchBack = mkPure $ \b -> (Left mempty, if b then switchBack else edge) +-- | Same as 'unless'. --- | Produces, whenever the current input signal is 'False'.+forbid :: (Monoid e) => (a -> Bool) -> Event e m a+forbid = unless+++-- | Produce for the given number of instants. ----- * Depends: Current instant.+-- * Depends: current instant when producing. ----- * Inhibits: When input is 'True'.+-- * Inhibits: after the given number of instants has passed. -forbid :: (Monoid e, WirePure (>~)) => Wire e (>~) Bool ()-forbid = mkPureFix (\b -> if b then Left mempty else Right ())+forI :: (Monoid e) => Int -> Event e m a+forI t+ | t <= 0 = never+ | otherwise = mkPure $ \_ x -> (Right x, forI (t - 1)) --- | Never produces. Always inhibits with the current input signal.+-- | Inhibit with the given value. ----- * Depends: Current instant.+-- * Inhibits: always.++inhibit :: e -> Wire e m a b+inhibit ex = mkFix (\_ _ -> Left ex)+++-- | Inject the input signal. Please keep in mind that in application+-- code it is almost always wrong to use this wire. It should only be+-- used to interact with other frameworks/abstractions, and even then+-- it's probably just a last resort. ----- * Inhibits: Always.+-- When you want to write your own wires, consider using 'mkPure' or the+-- various variants of it.+--+-- * Depends: current instant.+--+-- * Inhibits: depending on input signal (see 'Injectable'). -inhibit :: WirePure (>~) => Wire e (>~) e b-inhibit = mkPureFix Left+inject :: (Injectable e f) => Wire e m (f b) b+inject = mkFix (const toSignal) --- | Never produces. Equivalent to 'zeroArrow'.+-- | Inhibit once. ----- * Inhibits: Always.+-- * Depends: current instant after the first instant.+--+-- * Inhibits: in the first instant. -never :: (Monoid e, WirePure (>~)) => Wire e (>~) a b-never = mkPureFix (const (Left mempty))+notYet :: (Monoid e) => Event e m a+notYet = mkPure $ \_ _ -> (Left mempty, identity) --- | Inhibit at the first instant. Then produce forever.+-- | Produce once. ----- * Inhibits: At the first instant.+-- * Depends: current instant in the first instant.+--+-- * Inhibits: after the first instant. -notYet :: (Monoid e, WirePure (>~)) => Wire e (>~) b b-notYet = mkPure (const (Left mempty, identity))+once :: (Monoid e) => Event e m a+once = mkPure $ \_ x -> (Right x, never) --- | Acts like the identity function once and never again.+-- | Produce once periodically with the given time interval. ----- * Inhibits: After the first instant.+-- * Depends: current instant when producing, time.+--+-- * Inhibits: between the intervals. -once :: (Monoid e, WirePure (>~)) => Wire e (>~) b b-once = mkPure $ \x -> (Right x, never)+periodically :: (Monoid e) => Time -> Event e m a+periodically = events . repeat --- | Periodically produces an event. The period is given by the input--- time delta and can change over time. The current time delta with--- respect to the last production is significant. Does not produce at--- the first instant, unless the first delta is nonpositive.+-- | Produce once periodically with the given number of instants as the+-- interval. ----- * Depends: Current instant.+-- * Depends: current instant when producing. ----- * Inhibits: Always except at the periodic ticks.+-- * Inhibits: between the intervals. -class Arrow (>~) => WPeriodically t (>~) | (>~) -> t where- periodically :: Monoid e => Wire e (>~) t ()+periodicallyI :: (Monoid e) => Int -> Event e m a+periodicallyI = eventsI . repeat -instance (AdditiveGroup t, MonadClock t m, Ord t) => WPeriodically t (Kleisli m) where- periodically =- WmGen $ \int ->- if int <= zeroV- then return (Right (), periodically)- else do- t <- getTime- return (Left mempty, periodically' t) - where- periodically' :: Monoid e => t -> Wire e (Kleisli m) t ()- periodically' t0 =- WmGen $ \int -> do- t <- getTime- let tt = t0 ^+^ int- return $- if t >= tt- then (Right (), periodically' tt)- else (Left mempty, periodically' t0)+-- | Same as 'when'. +require :: (Monoid e) => (a -> Bool) -> Event e m a+require = when --- | Produces, whenever the current input signal is 'True'.++-- | Produce when the given predicate on the input signal does not hold. ----- * Depends: Current instant.+-- * Depends: current instant if the predicate is strict. ----- * Inhibits: When input is 'False'.+-- * Inhibits: When the predicate is true. -require :: (Monoid e, WirePure (>~)) => Wire e (>~) Bool ()-require = mkPureFix (\b -> if b then Right () else Left mempty)+unless :: (Monoid e) => (a -> Bool) -> Event e m a+unless p =+ mkFix $ \_ x ->+ if p x then Left mempty else Right x --- | Produce as long as the input signal is 'True'. Once it switches to--- 'False', never produce again. Corresponds to 'takeWhile' for lists.+-- | Produce until the given predicate on the input signal holds, then+-- inhibit forever. ----- * Depends: Current instant.+-- * Depends: current instant, if the predicate is strict. ----- * Inhibits: As soon as input becomes 'False'.+-- * Inhibits: forever as soon as the predicate becomes true. -while :: (Monoid e, WirePure (>~)) => Wire e (>~) Bool ()-while =- mkPure $ \b ->- if b then (Right (), while) else (Left mempty, never)+until :: (Monoid e) => (a -> Bool) -> Event e m a+until p = while (not . p) --- | Produces a single event occurence result, when the given 'Bool' is--- true.+-- | Produce when the given predicate on the input signal holds.+--+-- * Depends: current instant if the predicate is strict.+--+-- * Inhibits: When the predicate is false. -orGoWith ::- (Monoid e, WirePure (>~))- => Bool- -> Wire e (>~) a b- -> (Either e (), Wire e (>~) a b)-orGoWith True _ = (Right (), never)-orGoWith False w = (Left mempty, w)+when :: (Monoid e) => (a -> Bool) -> Event e m a+when p =+ mkFix $ \_ x ->+ if p x then Right x else Left mempty -infixl 3 `orGoWith`++-- | Produce while the given predicate on the input signal holds, then+-- inhibit forever.+--+-- * Depends: current instant, if the predicate is strict.+--+-- * Inhibits: forever as soon as the predicate becomes false.++while :: (Monoid e) => (a -> Bool) -> Event e m a+while p =+ mkPure $ \_ x ->+ if p x+ then (Right x, while p)+ else (Left mempty, never)
− Control/Wire/Prefab/Execute.hs
@@ -1,46 +0,0 @@--- |--- Module: Control.Wire.Prefab.Execute--- Copyright: (c) 2011 Ertugrul Soeylemez--- License: BSD3--- Maintainer: Ertugrul Soeylemez <es@ertes.de>------ Monadic computations for wires over Kleisli arrows. The difference--- between these wires and 'Control.Wire.Classes.arrM' is that these are--- exception-aware.--module Control.Wire.Prefab.Execute- ( -- * Run monadic actions- WExecute(..)- )- where--import Control.Applicative-import Control.Arrow-import Control.Exception.Lifted as Ex-import Control.Monad-import Control.Monad.Trans.Control-import Control.Wire.Types----- | Run monadic actions.--class Arrow (>~) => WExecute m (>~) | (>~) -> m where- -- | Run the input monadic action at each instant.- --- -- * Depends: Current instant.- --- -- * Inhibits: Whenever the input computation throws an exception.- execute :: Applicative f => Wire (f SomeException) (>~) (m b) b- execute = executeWith pure-- -- | Run the input monadic action at each instant. The argument- -- function converts thrown exceptions to inhibition values.- --- -- * Depends: Current instant.- --- -- * Inhibits: Whenever the input computation throws an exception.- executeWith :: (SomeException -> e) -> Wire e (>~) (m b) b--instance MonadBaseControl IO m => WExecute m (Kleisli m) where- executeWith fromEx =- mkFixM $ liftM (either (Left . fromEx) Right) . Ex.try
+ Control/Wire/Prefab/Move.hs view
@@ -0,0 +1,197 @@+-- |+-- Module: Control.Wire.Prefab.Move+-- Copyright: (c) 2012 Ertugrul Soeylemez+-- License: BSD3+-- Maintainer: Ertugrul Soeylemez <es@ertes.de>+--+-- This module provides the wires for various kinds of moving objects.+-- In particular this includes various calculus wires like integrals and+-- differentials.++module Control.Wire.Prefab.Move+ ( -- * Calculus+ -- ** Integrals+ integral,+ integral_,+ integralLim,+ integralLim_,+ -- ** Differentials+ derivative,+ derivative_,++ -- * Simulations/games+ object,+ object_,+ ObjectState(..),+ ObjectDiff(..)+ )+ where++import Control.Applicative+import Control.Arrow+import Control.Category+import Control.Wire.Prefab.Accum+import Control.Wire.Prefab.Time+import Control.Wire.Wire+import Data.Data+import Data.VectorSpace+import Prelude hiding ((.), id)+++-- | Object state. This includes the position and velocity.++data ObjectState a =+ ObjectState {+ objPosition :: a, -- ^ Position.+ objVelocity :: a -- ^ Velocity.+ }+ deriving (Data, Eq, Ord, Read, Show, Typeable)+++-- | Differential for objects.++data ObjectDiff a+ -- | Accelerate (units per second).+ = Accelerate a++ -- | Teleport to the given position instantly (velocity will be+ -- unchanged).+ | Position a++ -- | Specify velocity (units per second).+ | Velocity a+ deriving (Data, Eq, Ord, Read, Show, Typeable)+++-- | Derivative. Receives @x@ and @dt@ and calculates the change rate+-- @dx/dt@. Note that @dt@ despite its name does not have to be time.+--+-- The exception handler function is called when @dt@ is zero. That+-- function's result is the wire's output for those instants. If you+-- don't want to handle exceptional cases specially, just pass @(^/)@ as+-- the handler function.+--+-- * Depends: current instant.++derivative ::+ (Eq dt, Fractional dt, VectorSpace b, Scalar b ~ dt)+ => (b -> dt -> b) -- ^ Handle exceptional change rates (receives dx and dt).+ -> b -- ^ Initial position.+ -> Wire e m (b, dt) b+derivative catch x0 =+ mkPure $ \_ (x1, dt) ->+ let dx = x1 ^-^ x0+ d | dt == 0 = catch dx dt+ | otherwise = dx ^/ dt+ in (Right d, derivative catch x1)+++-- | Same as 'derivative', but with respect to time.+--+-- * Depends: current instant.++derivative_ ::+ (Monad m, VectorSpace b, Scalar b ~ Time)+ => (b -> Time -> b) -- ^ Handle exceptional cases.+ -> b -- ^ Initial position.+ -> Wire e m b b+derivative_ catch x0 = derivative catch x0 . (id &&& dtime)+++-- | Integral wire. Produces position from velocity in the sense of the+-- given vector space.+--+-- * Depends: previous instant.++integral ::+ (VectorSpace b)+ => b+ -> Wire e m (b, Scalar b) b+integral = accum (\x (dx, dt) -> x ^+^ dt *^ dx)+++-- | Same as 'integral', but with respect to time.+--+-- * Depends: previous instant.++integral_ ::+ (Monad m, VectorSpace b, Scalar b ~ Time)+ => b+ -> Wire e m b b+integral_ x = integral x . (id &&& dtime)+++-- | Variant of 'integral', where you can specify a post-update+-- function, which receives the previous position as well as the current+-- (in that order). This is useful for limiting the output (think of+-- robot arms that can't be moved freely).+--+-- * Depends: current instant if the post-update function is strict in+-- its first argument, previous instant if not.++integralLim ::+ (VectorSpace b)+ => (w -> b -> b -> b) -- ^ Post-update function.+ -> b -- ^ Initial value.+ -> Wire e m ((b, w), Scalar b) b+integralLim uf = accum (\x ((dx, w), dt) -> uf w x (x ^+^ dt *^ dx))+++-- | Same as 'integralLim', but with respect to time.+--+-- * Depends: previous instant.++integralLim_ ::+ (Monad m, VectorSpace b, Scalar b ~ Time)+ => (w -> b -> b -> b)+ -> b+ -> Wire e m (b, w) b+integralLim_ uf x0 = integralLim uf x0 . (id &&& dtime)+++-- | Objects are generalized integrals. They are controlled through+-- velocity and/or acceleration and can be collision-checked as well as+-- instantly teleported.+--+-- The post-move update function receives the world state and the+-- current object state. It is applied just before the wire produces+-- its output. You can use it to perform collision-checks or to limit+-- the velocity.+--+-- Note that teleportation doesn't change the velocity.+--+-- * Depends: current instant.++object ::+ forall b m dt e w.+ (VectorSpace b, Scalar b ~ dt)+ => (w -> ObjectState b -> ObjectState b) -- ^ Post-move update function.+ -> ObjectState b -- ^ Initial state.+ -> Wire e m (ObjectDiff b, w, dt) (ObjectState b)+object uf = loop+ where+ applyDiff :: dt -> ObjectDiff b -> ObjectState b -> ObjectState b+ applyDiff dt (Accelerate dv) (ObjectState x' v') = ObjectState x v+ where+ v = v' ^+^ dt *^ dv+ x = x' ^+^ dt *^ v+ applyDiff _ (Position x) (ObjectState _ v) = ObjectState x v+ applyDiff dt (Velocity v) (ObjectState x' _) = ObjectState (x' ^+^ dt *^ v) v++ loop :: ObjectState b -> Wire e m (ObjectDiff b, w, dt) (ObjectState b)+ loop os' =+ mkPure $ \_ (dos, w, dt) ->+ let os = uf w . applyDiff dt dos $ os'+ in (Right os, loop os)+++-- | Same as 'object', but with respect to time.+--+-- * Depends: current instant.++object_ ::+ (Monad m, VectorSpace b, Scalar b ~ Time)+ => (w -> ObjectState b -> ObjectState b) -- ^ Post-move update function.+ -> ObjectState b -- ^ Initial state.+ -> Wire e m (ObjectDiff b, w) (ObjectState b)+object_ uf x0 = object uf x0 . liftA2 (\(dx, w) dt -> (dx, w, dt)) id dtime
+ Control/Wire/Prefab/Noise.hs view
@@ -0,0 +1,96 @@+-- |+-- Module: Control.Wire.Prefab.Noise+-- Copyright: (c) 2012 Ertugrul Soeylemez+-- License: BSD3+-- Maintainer: Ertugrul Soeylemez <es@ertes.de>+--+-- Various noise generators.++module Control.Wire.Prefab.Noise+ ( -- * Pure random noise+ noise,+ noiseR,+ wackelkontakt,++ -- * Effectful random noise+ noiseM,+ noiseRM,+ wackelkontaktM+ )+ where++import Control.Monad+import Control.Wire.Classes+import Control.Wire.Prefab.Accum+import Control.Wire.Types+import Control.Wire.Wire+import Data.Monoid+import System.Random+++-- | Pure noise generator.++noise ::+ (Random b, RandomGen g)+ => g -- ^ Initial random number generator.+ -> Wire e m a b+noise = unfold (\g' _ -> random g')+++-- | Noise generator.++noiseM ::+ (MonadRandom m, Random b)+ => Wire e m a b+noiseM =+ mkFixM $ \_ _ -> liftM (Right $!) getRandom+++-- | Ranged noise generator.+--+-- * Depends: current instant.++noiseRM ::+ (MonadRandom m, Random b)+ => Wire e m (b, b) b+noiseRM = mkFixM $ \_ -> liftM (Right $!) . getRandomR+++-- | Pure ranged noise generator.+--+-- * Depends: current instant.++noiseR ::+ (Random b, RandomGen g)+ => g -- ^ Initial random number generator.+ -> Wire e m (b, b) b+noiseR = unfold (\g' r -> randomR r g')+++-- | Event: Occurs randomly with the given probability.+--+-- * Inhibits: @wackelkontaktM p@ inhibits with probability @1 - p@.++wackelkontakt ::+ (Monoid e, RandomGen g)+ => Double -- ^ Occurrence probability.+ -> g -- ^ Initial random number generator.+ -> Event e m a+wackelkontakt p g' =+ mkPure $ \_ x ->+ let (e, g) = random g' in+ (if (e < p) then Right x else Left mempty, wackelkontakt p g)+++-- | Event: Occurs randomly with the given probability.+--+-- * Inhibits: @wackelkontaktM p@ inhibits with probability @1 - p@.++wackelkontaktM ::+ (MonadRandom m, Monoid e)+ => Double -- ^ Occurrence probability.+ -> Event e m a+wackelkontaktM p =+ mkFixM $ \_ x -> do+ e <- getRandom+ return (if (e < p) then Right x else Left mempty)
Control/Wire/Prefab/Queue.hs view
@@ -1,57 +1,88 @@ -- | -- Module: Control.Wire.Prefab.Queue--- Copyright: (c) 2011 Ertugrul Soeylemez+-- Copyright: (c) 2012 Ertugrul Soeylemez -- License: BSD3 -- Maintainer: Ertugrul Soeylemez <es@ertes.de> ----- Various wires for queuing.+-- Wires acting as queues. module Control.Wire.Prefab.Queue- ( -- * Signal dams+ ( -- * Queues+ bag, fifo, lifo ) where -import qualified Data.Sequence as S-import Control.Wire.Types+import qualified Data.Set as S+import qualified Data.Sequence as Seq+import Control.Wire.Wire import Data.Monoid-import Data.Sequence (Seq, ViewL(..), (><))+import Data.Set (Set)+import Data.Sequence (ViewL(..), (><), viewl) --- | Queues incoming signals and acts as a dam outputting incoming--- signals in a FIFO fashion (one-way pipe). Note: Incorrect usage can--- lead to congestion.+-- | Incoming values are placed in a set, which is discharged element by+-- element. Lower values are served first. Duplicate values are served+-- once. --+-- Note: Incorrect usage can lead to congestion.+--+-- * Complexity: O(n) space wrt bag size.+-- -- * Depends: current instant. ----- * Inhibits: when the queue is empty.+-- * Inhibits: when the bag is empty. -fifo :: forall a e (>~). (Monoid e, WirePure (>~)) => Wire e (>~) [a] a-fifo = fifo' S.empty+bag :: (Monoid e, Ord b) => Wire e m (Set b) b+bag = bag' S.empty where- fifo' :: Seq a -> Wire e (>~) [a] a- fifo' xs' =- mkPure $ \((xs' ><) . S.fromList -> xs) ->- case S.viewl xs of- x :< rest -> (Right x, fifo' rest)- EmptyL -> (Left mempty, fifo' xs)+ bag' s' =+ mkPure $ \_ xs ->+ case S.minView (S.union s' xs) of+ Nothing -> (Left mempty, bag' S.empty)+ Just (x, s) -> (Right x, bag' s) --- | Queues incoming signals and acts as a dam outputting incoming--- signals in a LIFO fashion (stack). Note: Incorrect usage can lead to--- congestion.+-- | First in, first out. The input list is placed on the right end of+-- a queue at every instant, giving earlier elements a higher priority.+-- The queue is discharged item by item from the left. --+-- Note: Incorrect usage can lead to congestion.+--+-- * Complexity: O(n) space wrt queue size.+-- -- * Depends: current instant. ----- * Inhibits: when the queue is empty.+-- * Inhibits: when the queue is currently empty. -lifo :: forall a e (>~). (Monoid e, WirePure (>~)) => Wire e (>~) [a] a-lifo = lifo' S.empty+fifo :: (Monoid e) => Wire e m [b] b+fifo = fifo' Seq.empty where- lifo' :: Seq a -> Wire e (>~) [a] a- lifo' xs' =- mkPure $ \((>< xs') . S.fromList -> xs) ->- case S.viewl xs of- x :< rest -> (Right x, lifo' rest)- EmptyL -> (Left mempty, lifo' xs)+ fifo' queue' =+ mkPure $ \_ xs ->+ case viewl (queue' >< Seq.fromList xs) of+ EmptyL -> (Left mempty, fifo' Seq.empty)+ x :< queue -> (Right x, fifo' queue)+++-- | Last in, first out. The input list is placed on a stack at every+-- instant, giving earlier elements a higher priority. The stack is+-- discharged item by item from the top.+--+-- Note: Incorrect usage can lead to congestion.+--+-- * Complexity: O(n) space wrt stack size.+--+-- * Depends: current instant.+--+-- * Inhibits: when the stack is currently empty.++lifo :: (Monoid e) => Wire e m [b] b+lifo = lifo' Seq.empty+ where+ lifo' queue' =+ mkPure $ \_ xs ->+ case viewl (Seq.fromList xs >< queue') of+ EmptyL -> (Left mempty, lifo' Seq.empty)+ x :< queue -> (Right x, lifo' queue)
− Control/Wire/Prefab/Random.hs
@@ -1,64 +0,0 @@--- |--- Module: Control.Wire.Prefab.Random--- Copyright: (c) 2011 Ertugrul Soeylemez--- License: BSD3--- Maintainer: Ertugrul Soeylemez <es@ertes.de>------ Wires for generating random noise.--module Control.Wire.Prefab.Random- ( -- * Random noise- noise,- noiseR,-- -- * Specific types- noiseF,- noiseF1,- wackelkontakt- )- where--import Control.Arrow-import Control.Monad-import Control.Wire.Classes-import Control.Wire.Types-import System.Random----- | Random number wires.--class Arrow (>~) => WRandom (>~) where- -- | Generate random noise.- noise :: Random b => Wire e (>~) a b-- -- | Generate random noise in a certain range given by the input- -- signal.- --- -- * Depends: Current instant.- noiseR :: Random b => Wire e (>~) (b, b) b-- -- | Generate a random boolean, where the input signal is the- -- probability to be 'True'.- --- -- * Depends: Current instant.- wackelkontakt :: Wire e (>~) Double Bool--instance MonadRandom m => WRandom (Kleisli m) where- noise = mkFixM (liftM Right . const getRandom)- noiseR = mkFixM (liftM Right . getRandomR)- wackelkontakt =- mkFixM $ \p -> do- s <- getRandom- return (Right (not (s >= p)))----- | Generate random noise in range 0 <= x < 1.--noiseF :: WRandom (>~) => Wire e (>~) a Double-noiseF = noise----- | Generate random noise in range -1 <= x < 1.--noiseF1 :: (Arrow (Wire e (>~)), WRandom (>~)) => Wire e (>~) a Double-noiseF1 = ((*2) . pred) ^<< noise
Control/Wire/Prefab/Sample.hs view
@@ -1,60 +1,85 @@ -- | -- Module: Control.Wire.Prefab.Sample--- Copyright: (c) 2011 Ertugrul Soeylemez+-- Copyright: (c) 2012 Ertugrul Soeylemez -- License: BSD3 -- Maintainer: Ertugrul Soeylemez <es@ertes.de> -- -- Signal sampling wires. module Control.Wire.Prefab.Sample- ( -- * Simple samplers- WDiscrete(..),- keep+ ( -- * Sampling+ --history,+ keep,+ sample,+ window,+ windowList ) where -import Control.Arrow-import Control.Wire.Classes-import Control.Wire.Prefab.Simple-import Control.Wire.Types-import Data.AdditiveGroup+import qualified Data.Foldable as F+import qualified Data.Sequence as Seq+import Control.Wire.Wire+import Data.Sequence (Seq, (|>)) --- | Sample the right signal at discrete intervals given by the left--- input signal.+-- | Produce the most recent inputs in the given time window. The left+-- input signal is the sample, the right input signal is the time+-- window. ----- * Depends: Current instant (left), last sampling instant (right).+-- * Complexity: O(n), where n the number of samples in the time window.+--+-- * Depends: current instant. -class Arrow (>~) => WDiscrete t (>~) | (>~) -> t where- discrete :: Wire e (>~) (t, b) b+--history :: (Reactive cat) => Wire e cat (a, Time) (Seq (a, Time))+--history = undefined -instance (AdditiveGroup t, MonadClock t m, Ord t) => WDiscrete t (Kleisli m) where- discrete =- WmGen $ \(int, x) ->- if int <= zeroV- then return (Right x, discrete)- else do- t <- getTime- return (Right x, discrete' t x) - where- discrete' :: t -> b -> Wire e (Kleisli m) (t, b) b- discrete' t0 x0 =- WmGen $ \(int, x) ->- if int > zeroV- then do- t <- getTime- let tt = t0 ^+^ int- return $- if t >= tt- then (Right x, discrete' tt x)- else (Right x0, discrete' t0 x0)- else return (Right x, discrete)+-- | Keep the input signal of the first instant forever.+--+-- Depends: first instant. +keep :: Wire e m a a+keep = mkPure (\_ x -> (Right x, constant x)) --- | Keep the signal in the first instant forever.++-- | Sample the left signal at discrete intervals given by the right+-- signal. ----- * Depends: First instant.+-- * Depends: instant of the last sample. -keep :: WirePure (>~) => Wire e (>~) b b-keep = mkPure $ \x -> (Right x, constant x)+sample :: Wire e m (a, Time) a+sample = mkPure $ \dt (x, _) -> (Right x, sample' dt x)+ where+ sample' t0' x' =+ mkPure $ \dt (x, t1) ->+ let t0 = t0' + dt in+ if t0 >= t1+ then (Right x, sample' (t0 - t1) x)+ else (Right x', sample' t0 x')+++-- | Produce up to the given number of most recent inputs.+--+-- * Complexity: O(n), where n is the given argument.+--+-- * Depends: current instant.++window :: Int -> Wire e m a (Seq a)+window = collect' Seq.empty+ where+ collect' s' 0 = window' s'+ collect' s' n =+ mkPure $ \_ x ->+ let s = s' |> x in+ s `seq` (Right s, collect' s (n - 1))++ window' s' =+ mkPure $ \_ x ->+ let s = Seq.drop 1 (s' |> x) in+ s `seq` (Right s, window' s)+++-- | Same as @fmap toList . window@.++windowList :: (Monad m) => Int -> Wire e m a [a]+windowList = fmap F.toList . window
Control/Wire/Prefab/Simple.hs view
@@ -1,80 +1,67 @@ -- | -- Module: Control.Wire.Prefab.Simple--- Copyright: (c) 2011 Ertugrul Soeylemez+-- Copyright: (c) 2012 Ertugrul Soeylemez -- License: BSD3 -- Maintainer: Ertugrul Soeylemez <es@ertes.de> -- -- Basic wires. module Control.Wire.Prefab.Simple- ( -- * Simple predefined wires.- constant,- identity,+ ( -- * Basic signal manipulation+ append,+ delay,+ prepend, - -- * Forced reduction+ -- * Forcing evaluation force,- forceNF,-- -- * Inject signals- inject,- injectEvent+ forceNF ) where -import Control.DeepSeq (NFData, deepseq)-import Control.Wire.Types-import Data.Monoid----- | The constant wire. Outputs the given value all the time.--constant :: WirePure (>~) => b -> Wire e (>~) a b-constant x = mkPureFix (Right . const x)+import Control.Arrow+import Control.Category+import Control.DeepSeq (NFData, ($!!))+import Control.Wire.Wire+import Prelude hiding ((.), id) --- | Force the input signal to weak head normal form, before outputting--- it. Applies 'seq' to the input signal.+-- | Convenience function to add another signal. ----- * Depends: Current instant.+-- * Depends: current instant. -force :: WirePure (>~) => Wire e (>~) b b-force = mkPureFix (Right $!)+append :: (Monad m) => Wire e m a b -> Wire e m a (a, b)+append = (id &&&) --- | Force the input signal to normal form, before outputting it.--- Applies 'deepseq' to the input signal.+-- | One-instant delay. ----- * Depends: Current instant.+-- * Depends: Previous instant. -forceNF :: (NFData b, WirePure (>~)) => Wire e (>~) b b-forceNF = mkPureFix (\x -> x `deepseq` Right x)+delay :: a -> Wire e m a a+delay x' = mkPure (\_ x -> (Right x', delay x)) --- | The identity wire. Outputs its input signal unchanged.+-- | Acts like the identity wire, but forces evaluation of the signal to+-- WHNF. ----- * Depends: Current instant.+-- * Depends: current instant. -identity :: WirePure (>~) => Wire e (>~) a a-identity = mkPureFix (Right $)+force :: Wire e m a a+force = mkFix (\_ -> (Right $!)) --- | Inject the given 'Either' value as a signal. 'Left' means--- inhibition.------ * Depends: Current instant.+-- | Acts like the identity wire, but forces evaluation of the signal to+-- NF. ----- * Inhibits: When input is 'Left'.+-- * Depends: current instant. -inject :: WirePure (>~) => Wire e (>~) (Either e b) b-inject = mkPureFix id+forceNF :: (NFData a) => Wire e m a a+forceNF = mkFix (\_ -> (Right $!!)) --- | Inject the given 'Maybe' value as a signal. 'Nothing' means--- inhibition.------ * Depends: Current instant.+-- | Convenience function to add another signal. ----- * Inhibits: When input is 'Nothing'.+-- * Depends: current instant. -injectEvent :: (Monoid e, WirePure (>~)) => Wire e (>~) (Maybe b) b-injectEvent = mkPureFix (maybe (Left mempty) Right)+prepend :: (Monad m) => Wire e m a b -> Wire e m a (b, a)+prepend = (&&& id)
− Control/Wire/Prefab/Split.hs
@@ -1,65 +0,0 @@--- |--- Module: Control.Wire.Prefab.Split--- Copyright: (c) 2011 Ertugrul Soeylemez--- License: BSD3--- Maintainer: Ertugrul Soeylemez <es@ertes.de>------ Nondeterministic wires.--module Control.Wire.Prefab.Split- ( -- * Nondeterministic wires- WSplit(..)- )- where--import qualified Data.Foldable as F-import Control.Arrow-import Control.Monad-import Control.Wire.Types-import Data.Foldable (Foldable)----- | Split the wires in the sense of the underlying arrow. A /thread/--- in this sense is called a branch. This makes most sense with some--- logic monad (like a list monad transformer) wrapped in a 'Kleisli'--- arrow.------ Warning: Incorrect usage will cause space leaks. Use with care!--class Arrow (>~) => WSplit (>~) where- -- | Splits the wire into a branch for each given input value.- -- Additionally adds a single inhibiting branch.- --- -- Note: This wire splits at every instant. In many cases you- -- probably want to apply 'swallow' to it to split only in the first- -- instant.- --- -- * Branches: As many as there are input values + 1.- --- -- * Depends: Current instant.- --- -- * Inhibits: Always in one branch, never in all others.- branch :: Foldable f => Wire e (>~) (f b) b-- -- | Quits the current branch.- --- -- * Branches: Zero.- quit :: Wire e (>~) a b-- -- | Acts like the identity wire in the first instant and terminates- -- the branch in the next.- --- -- * Branches: One, then zero.- --- -- * Depends: Current instant.- quitWith :: Wire e (>~) b b---instance MonadPlus m => WSplit (Kleisli m) where- branch =- WmGen $ \xs' -> do- x <- F.foldl' (\xs x -> xs `mplus` return x) mzero xs'- return (Right x, branch)-- quit = WmGen (const mzero)- quitWith = WmPure (\x -> (Right x, quit))
+ Control/Wire/Prefab/Time.hs view
@@ -0,0 +1,45 @@+-- |+-- Module: Control.Wire.Prefab.Time+-- Copyright: (c) 2012 Ertugrul Soeylemez+-- License: BSD3+-- Maintainer: Ertugrul Soeylemez <es@ertes.de>+--+-- Time wires.++module Control.Wire.Prefab.Time+ ( -- * Time+ dtime,+ time,+ timeFrom+ )+ where++import Control.Wire.Wire+++-- | Outputs the time delta to the last instant.+--+-- * Depends: time.++dtime :: Wire e m a Time+dtime = mkFix (\dt _ -> Right dt)+++-- | Outputs the current local time passed since the first instant.+--+-- * Depends: time.++time :: Wire e m a Time+time = timeFrom 0+++-- | Outputs the current local time passed since the first instant with+-- the given offset.+--+-- * Depends: time.++timeFrom :: Time -> Wire e m a Time+timeFrom t' =+ mkPure $ \dt _ ->+ let t = t' + dt in+ t `seq` (Right t, timeFrom t)
Control/Wire/Session.hs view
@@ -1,137 +1,239 @@ -- | -- Module: Control.Wire.Session--- Copyright: (c) 2011 Ertugrul Soeylemez+-- Copyright: (c) 2012 Ertugrul Soeylemez -- License: BSD3 -- Maintainer: Ertugrul Soeylemez <es@ertes.de> ----- Wire sessions, i.e. running and/or testing wires.+-- Wire sessions. module Control.Wire.Session- ( -- * Running wires- stepWire,- stepWireM,+ ( -- * Performing instants+ stepSession,+ stepSession_,+ stepSessionP,+ stepSessionP_, -- * Testing wires testWire,- testWireM,- -- ** Utility functions- printInt,- printRes,- showRes,- succMod+ testWireP,+ -- ** Helper functions+ testPrint,++ -- * Sessions+ Session(..),+ -- ** Generic sessions+ genSession,+ -- ** Specific session types+ clockSession,+ counterSession,+ frozenSession ) where -import Control.Arrow+import Control.Concurrent+import Control.Exception import Control.Monad+import Control.Monad.Identity import Control.Monad.Trans-import Control.Wire.Classes import Control.Wire.Types+import Control.Wire.Wire+import Data.Monoid+import Data.Time.Clock import System.IO --- | Print a wire result on one line at regular intervals (first--- argument). The second argument is the interval counter.+-- | A session value contains time-related information. -printInt :: (Num a, Ord a) => a -> a -> String -> IO a-printInt int n' str = do- when (n' == 0) (printRes str)- return (succMod int n')+newtype Session m =+ Session {+ sessionUpdate :: m (Time, Session m)+ } --- | Print a wire result on one line.+-- | Construct a session using real time. This session type uses+-- 'getCurrentTime'. If you have a faster time source, you may want to+-- use 'genSession' instead and construct your own clock. -printRes :: String -> IO ()-printRes str = do- putStr "\r\027[K"- putStr str- hFlush stdout+clockSession :: (MonadIO m) => Session m+clockSession =+ Session $ do+ t0 <- liftIO getCurrentTime+ return (0, loop t0) + where+ loop t' =+ Session $ do+ t <- liftIO getCurrentTime+ let dt = realToFrac (diffUTCTime t t')+ return (dt, loop t) --- | Turn a wire result into a string for printing. -showRes :: Show e => Either e String -> String-showRes = either (("Inhibited: " ++) . show) id+-- | Construct a simple counter session. The time delta is the given+-- argument at every instant. +counterSession ::+ (Monad m)+ => Time -- ^ Time delta for every instant.+ -> Session m+counterSession dt =+ let s = Session (return (dt, s)) in s --- | Performs an instant of the given wire. -stepWire ::- WireToGen (>~)- => Wire e (>~) a b -- ^ Wire to step.- -> (a >~ (Either e b, Wire e (>~) a b))-stepWire = toGen+-- | Construct a frozen session. Same as @'counterSession' 0@. +frozenSession :: (Monad m) => Session m+frozenSession = counterSession 0 --- | Performs an instant of the given monad-based wire. -stepWireM ::- Monad m- => Wire e (Kleisli m) a b -- ^ Wire to step.- -> a -- ^ Input signal.- -> m (Either e b, Wire e (Kleisli m) a b)-stepWireM = toGenM+-- | Construct a generic session from the given initial session value+-- and the update function. You can use this function to implement your+-- own clock.+--+-- If you just want to use real time, you may want to use+-- 'clockSession'. +genSession ::+ (Monad m)+ => a+ -> (a -> m (Time, a))+ -> Session m+genSession s' f =+ Session $ do+ (t, s) <- f s'+ return (t, genSession s f) --- | Increments. Results in 0, if the result is greater than or equal--- to the first argument. -succMod :: (Num a, Ord a) => a -> a -> a-succMod int n =- let nn = n + 1 in- if nn >= int then 0 else nn+-- | Perform an instant of the given wire as part of a wire session.+--+-- This is a convenience function. You can also construct time deltas+-- yourself entirely circumventing 'Session'. This can be useful, if+-- there is really no need for an effectful monad. +stepSession ::+ (MonadIO m)+ => Wire e m a b -- ^ Wire to step.+ -> Session m -- ^ Current session state.+ -> a -- ^ Input value.+ -> m (Either e b, Wire e m a b, Session m)+stepSession w' (Session update) x' = do+ (dt, s) <- update+ (mx, w) <- stepWire w' dt x'+ mx `seq` return (mx, w, s) --- | Test a wire. This function runs the given wire continuously--- printing its output on a single line.------ The first argument specifies how often the wire's result is printed.--- If you specify 100 here, then the output is printed at every 100th--- frame. -testWire ::- forall a e m (>~). (ArrowApply (>~), ArrowKleisli m (>~), MonadIO m, Show e, WireToGen (>~))- => Int -- ^ Frames per output. Speed/accuracy tradeoff.- -> (() >~ a) -- ^ Input generator.- -> (Wire e (>~) a String >~ ())-testWire int getInput =- proc w' -> loop -< (0, w')+-- | Like 'stepSession', but throws an exception instead of returning an+-- 'Either' value. - where- loop :: (Int, Wire e (>~) a String) >~ ()- loop =- proc (n', w') -> do- let n = let nn = succ n' in if nn >= int then 0 else nn+stepSession_ ::+ (MonadIO m)+ => WireM m a b -- ^ Wire to step.+ -> Session m -- ^ Current session state.+ -> a -- ^ Input value.+ -> m (b, WireM m a b, Session m)+stepSession_ w' s' x' = do+ (mx, w, s) <- stepSession w' s' x' - inp <- getInput -< ()- (mstr, w) <- stepWire w' -<< inp+ let throwM = liftIO . throwIO+ emptyErr = toException (userError "empty inhibition signal")+ x <- either (throwM . maybe emptyErr id . getLast) return mx - arrIO -<- when (n' == 0) $ do- putStr "\r\027[K"- putStr (either (("Inhibited: " ++) . show) id mstr)- hFlush stdout+ return (x, w, s) - loop -< (n, w) +-- | Like 'stepSession', but for pure wires. --- | Test a monad-based wire. This function runs the given wire--- continuously printing its output on a single line.+stepSessionP ::+ (Monad m)+ => Wire e Identity a b -- ^ Wire to step.+ -> Session m -- ^ Current session state.+ -> a -- ^ Input value.+ -> m (Either e b, Wire e Identity a b, Session m)+stepSessionP w' (Session update) !x' = do+ (dt, s) <- update+ let (mx, w) = stepWireP w' dt x'+ mx `seq` return (mx, w, s)+++-- | Like 'stepSessionP', but throws an exception instead of returning an+-- 'Either' value.++stepSessionP_ ::+ (MonadIO m)+ => WireP a b -- ^ Wire to step.+ -> Session m -- ^ Current session state.+ -> a -- ^ Input value.+ -> m (b, WireP a b, Session m)+stepSessionP_ w' s' !x' = do+ (mx, w, s) <- stepSessionP w' s' x'++ let throwM = liftIO . throwIO+ emptyErr = toException (userError "empty inhibition signal")+ x <- either (throwM . maybe emptyErr id . getLast) return mx++ return (x, w, s)+++-- | @testPrint n int mx@ prints a formatted version of @mx@ to stderr,+-- if @n@ is zero. It returns @mod (succ n) int@. Requires @n >= 0@ to+-- work properly. ----- The first argument specifies how often the wire's result is printed.--- If you specify 100 here, then the output is printed at every 100th--- frame.+-- This function is used to implement the /printing interval/ used in+-- 'testWire' and 'testWireM'. -testWireM ::- forall a e m. (Show e, MonadIO m)- => Int -- ^ Frames per output. FPS/accuracy tradeoff.- -> m a -- ^ Input generator.- -> Wire e (Kleisli m) a String- -> m ()-testWireM int getInput = loop 0+testPrint :: (Show e) => Int -> Int -> Either e String -> IO Int+testPrint n' int mx = do+ let n = let nn = n' + 1 in+ if nn >= int then 0 else nn+ when (n' == 0) $ do+ hPutStr stderr "\r\027[K"+ hPutStr stderr (either (("(I) " ++) . show) id mx)+ hFlush stderr+ n `seq` return n+++-- | Runs the given wire continuously and prints its result to stderr.+-- Runs forever until an exception is raised.+--+-- The /printing interval/ sets the instants/printing ratio. The higher+-- this value, the less often the output is printed. Examples: 1000+-- means to print at every 1000-th instant, 1 means to print at every+-- instant.++testWire ::+ forall a b e m. (MonadIO m, Show e)+ => Int -- ^ Printing interval.+ -> Int -- ^ 'threadDelay' between instants.+ -> m a -- ^ Input generator.+ -> Session m -- ^ Initial session value.+ -> Wire e m a String -- ^ Wire to test.+ -> m b+testWire int delay getInput = loop 0 where- loop :: Int -> Wire e (Kleisli m) a String -> m ()- loop n' w' = do- (mstr, w) <- stepWireM w' =<< getInput- n <- liftIO . printInt int n' . showRes $ mstr- loop n w+ loop :: Int -> Session m -> Wire e m a String -> m b+ loop n' s' w' = do+ x' <- getInput+ (mx, w, s) <- stepSession w' s' x'+ n <- mx `seq` liftIO (testPrint n' int mx)+ when (delay > 0) (liftIO (threadDelay delay))+ loop n s w+++-- | Like 'testWire', but for pure wires.++testWireP ::+ forall a b e m. (MonadIO m, Show e)+ => Int -- ^ Printing interval.+ -> Int -- ^ 'threadDelay' between instants.+ -> m a -- ^ Input generator.+ -> Session m -- ^ Initial session value.+ -> Wire e Identity a String -- ^ Wire to test.+ -> m b+testWireP int delay getInput = loop 0+ where+ loop :: Int -> Session m -> Wire e Identity a String -> m b+ loop n' s' w' = do+ x' <- getInput+ (mx, w, s) <- stepSessionP w' s' x'+ n <- mx `seq` liftIO (testPrint n' int mx)+ when (delay > 0) (liftIO (threadDelay delay))+ loop n s w
Control/Wire/TimedMap.hs view
@@ -1,117 +1,118 @@ -- | -- Module: Control.Wire.TimedMap--- Copyright: (c) 2011 Ertugrul Soeylemez+-- Copyright: (c) 2012 Ertugrul Soeylemez -- License: BSD3 -- Maintainer: Ertugrul Soeylemez <es@ertes.de> ----- This module implements a map, where each key has a timestamp. It--- maintains a timestamp index allowing you delete oldest entries--- quickly.+-- Timed maps for efficient cleanups in the context wires. module Control.Wire.TimedMap- ( -- * Timed map- TimedMap(..),-- -- * Operations- -- ** Construct- tmEmpty,- -- ** Read- tmFindWithDefault,- tmLookup,- -- ** Modify- tmInsert,- tmLimitAge,- tmLimitSize+ ( -- * Timed maps+ TimedMap,+ -- * Queries+ findWithDefault,+ lookup,+ -- * Construction+ empty,+ -- * Insertion+ insert,+ -- * Deletion+ cleanup,+ cut,+ delete ) where import qualified Data.Map as M import qualified Data.Set as S+import Control.Monad+import Data.Data import Data.Map (Map) import Data.Set (Set)+import Prelude hiding (lookup) --- | A timed map is a regular map with timestamps and a timestamp index.+-- | A timed map is a map with an additional index based on time. data TimedMap t k a =- TimedMap {- tmMap :: Map k (a, t), -- ^ Underlying map with timestamps.- tmTimes :: Map t (Set k) -- ^ Timestamp index.- }- deriving Show+ TimedMap !(Map k (a, t)) !(Map t (Set k))+ deriving (Data, Show, Typeable) --- | Find a value with default.+-- | Remove all elements older than the given time. -tmFindWithDefault ::- Ord k- => a -- ^ Default, if key is not found.- -> k -- ^ Key to look up.- -> TimedMap t k a -- ^ Map to query.- -> a -- ^ Retrieved or default value.-tmFindWithDefault x0 k = M.findWithDefault x0 k . fmap fst . tmMap+cleanup :: (Ord k, Ord t) => t -> TimedMap t k a -> TimedMap t k a+cleanup t0 (TimedMap mk' mt') = TimedMap mk mt+ where+ (older', middle, mt) = M.splitLookup t0 mt'+ older =+ M.fromDistinctAscList .+ map (, ()) .+ S.toList .+ M.foldl' S.union S.empty .+ maybe id (M.insert t0) middle $ older'+ mk = mk' M.\\ older --- | The empty timed map.+-- | Remove all but the given number of latest elements. -tmEmpty :: TimedMap t k a-tmEmpty = TimedMap M.empty M.empty+cut :: (Ord k, Ord t) => Int -> TimedMap t k a -> TimedMap t k a+cut n !tm@(TimedMap mk mt)+ | M.size mk > n =+ let k = S.findMin . snd . M.findMin $ mt in+ cut n (delete k tm)+ | otherwise = tm --- | Insert a value into the map.--tmInsert ::- (Ord k, Ord t)- => t -- ^ Timestamp.- -> k -- ^ Key.- -> a -- ^ Value.- -> TimedMap t k a -- ^ Original map.- -> TimedMap t k a -- ^ Map with the value added.-tmInsert t k x (TimedMap xs' ts'') =- TimedMap xs ts+-- | Deletes the given key from the timed map. +delete :: (Ord k, Ord t) => k -> TimedMap t k a -> TimedMap t k a+delete k (TimedMap mk' mt') = TimedMap mk mt where- xs = M.insert k (x, t) xs'- ts = M.insertWith S.union t (S.singleton k) ts'- ts' =- case M.lookup k xs' of- Nothing -> ts''- Just (_, t') ->- M.update (\s' -> let s = S.delete k s' in- if S.null s then Nothing else Just s)- t' ts''+ mk = M.delete k mk'+ mt = case M.lookup k mk' of+ Nothing -> mt'+ Just (_, t') ->+ let alter Nothing = Nothing+ alter (Just s') = do+ let s = S.delete k s'+ guard (not (S.null s))+ return s+ in M.alter alter t' mt' --- | Delete all items older than the specified timestamp.+-- | Like 'lookup', but with a default value, if the key is not in the+-- map. -tmLimitAge :: (Ord t, Ord k) => t -> TimedMap t k a -> TimedMap t k a-tmLimitAge minT (TimedMap xs' ts') = TimedMap xs ts- where- xs = xs' M.\\ delMap- ts = maybe id (M.insert minT) tsCur tsYounger+findWithDefault :: (Ord k) => (a, t) -> k -> TimedMap t k a -> (a, t)+findWithDefault def k = maybe def id . lookup k - (tsOlder, tsCur, tsYounger) = M.splitLookup minT ts'- delMap =- M.fromDistinctAscList . map (, ()) .- S.toAscList . S.unions . M.elems $ tsOlder +-- | Empty timed map. --- | Delete at least as many oldest items as necessary to limit the--- map's size to the given value. If you have multiple keys with the--- same timestamp, this function can delete more keys than necessary.+empty :: TimedMap t k a+empty = TimedMap M.empty M.empty -tmLimitSize :: Ord k => Int -> TimedMap t k a -> TimedMap t k a-tmLimitSize n tm@(TimedMap xs ts') =- if n >= 0 && M.size xs > n- then tmLimitSize n $ TimedMap (xs M.\\ delMap) ts- else tm +-- | Insert into the timed map.++insert :: (Ord k, Ord t) => t -> k -> a -> TimedMap t k a -> TimedMap t k a+insert t k x (TimedMap mk' mt') = TimedMap mk mt where- delMap = M.fromDistinctAscList . map (, ()) . S.toAscList $ delKeys- ((_, delKeys), ts) = M.deleteFindMin ts'+ mk = M.insert k (x, t) mk'+ mt = case M.lookup k mk' of+ Nothing -> M.insertWith S.union t (S.singleton k) mt'+ Just (_, t') ->+ let alter Nothing = Nothing+ alter (Just s') = do+ let s = S.delete k s'+ guard (not (S.null s))+ return s+ in M.insertWith S.union t (S.singleton k) .+ M.alter alter t' $ mt' --- | Look up the value for the given key.+-- | Look up the given key in the timed map. -tmLookup :: Ord k => k -> TimedMap t k a -> Maybe a-tmLookup k (TimedMap xs _) = fmap fst (M.lookup k xs)+lookup :: (Ord k) => k -> TimedMap t k a -> Maybe (a, t)+lookup k (TimedMap mk _) = M.lookup k mk
− Control/Wire/Tools.hs
@@ -1,43 +0,0 @@--- |--- Module: Control.Wire.Tools--- Copyright: (c) 2011 Ertugrul Soeylemez--- License: BSD3--- Maintainer: Ertugrul Soeylemez <es@ertes.de>------ Utilities for creating wires.--module Control.Wire.Tools- ( -- * Arrow tools- distA,- mapA,-- -- * Utility functions- dup- )- where--import Control.Arrow----- | Distribute an input value over a list of arrow computations and--- collect the results.--distA :: forall a b (>~). Arrow (>~) => [a >~ b] -> (a >~ [b])-distA [] = arr (const [])-distA (c:cs) = arr (uncurry (:)) <<< c &&& distA cs----- | Duplicate a value into a tuple.--dup :: a -> (a, a)-dup x = (x, x)----- | Lift an arrow computation to lists of values.--mapA :: ArrowChoice (>~) => (a >~ b) -> ([a] >~ [b])-mapA c =- proc list ->- case list of- (x':xs') -> arr (uncurry (:)) <<< c *** mapA c -< (x', xs')- [] -> returnA -< []
Control/Wire/Trans.hs view
@@ -1,27 +1,25 @@ -- | -- Module: Control.Wire.Trans--- Copyright: (c) 2011 Ertugrul Soeylemez+-- Copyright: (c) 2012 Ertugrul Soeylemez -- License: BSD3 -- Maintainer: Ertugrul Soeylemez <es@ertes.de> ----- Wire transformers.+-- Proxy module to all wire combinator modules. module Control.Wire.Trans ( -- * Reexports- module Control.Wire.Trans.Clock, module Control.Wire.Trans.Combine,- module Control.Wire.Trans.Exhibit,- module Control.Wire.Trans.Fork,- module Control.Wire.Trans.Memoize,- module Control.Wire.Trans.Sample,- module Control.Wire.Trans.Simple+ module Control.Wire.Trans.Embed,+ module Control.Wire.Trans.Event,+ module Control.Wire.Trans.Simple,+ module Control.Wire.Trans.Switch,+ module Control.Wire.Trans.Time ) where -import Control.Wire.Trans.Clock import Control.Wire.Trans.Combine-import Control.Wire.Trans.Exhibit-import Control.Wire.Trans.Fork-import Control.Wire.Trans.Memoize-import Control.Wire.Trans.Sample+import Control.Wire.Trans.Embed+import Control.Wire.Trans.Event import Control.Wire.Trans.Simple+import Control.Wire.Trans.Switch+import Control.Wire.Trans.Time
− Control/Wire/Trans/Clock.hs
@@ -1,128 +0,0 @@--- |--- Module: Control.Wire.Trans.Clock--- Copyright: (c) 2011 Ertugrul Soeylemez--- License: BSD3--- Maintainer: Ertugrul Soeylemez <es@ertes.de>------ Supplying clocks to wires.--module Control.Wire.Trans.Clock- ( -- * Time deltas- WWithDT(..),-- -- * Global time- WWithSysTime(..),-- -- * Local time- WWithTime(..)- )- where--import Control.Arrow-import Control.Monad.Fix-import Control.Wire.Classes-import Control.Wire.Types-import Data.AdditiveGroup----- | Passes time deltas to the given wire with respect to the clock--- represented by the underlying arrow. Using this wire transformer you--- can program in the more traditional AFRP way using time deltas--- instead of time offsets. Note: The first time delta is 0.------ * Depends: Like argument wire.------ * Inhibits: When argument wire inhibits.--class Arrow (>~) => WWithDT t (>~) | (>~) -> t where- -- | Simplified variant without additional input.- passDT :: Wire e (>~) t b -> Wire e (>~) a b-- -- | Full variant.- withDT :: Wire e (>~) (a, t) b -> Wire e (>~) a b--instance (AdditiveGroup t, MonadClock t m) => WWithDT t (Kleisli m) where- passDT w' =- WmGen $ \_ -> do- t <- getTime- (mx, w) <- toGenM w' zeroV- return (mx, withDT' t w)-- where- withDT' :: t -> Wire e (Kleisli m) t b -> Wire e (Kleisli m) a b- withDT' t' w' =- WmGen $ \_ -> do- t <- getTime- let dt = t ^-^ t'- (mx, w) <- toGenM w' dt- return (mx, withDT' t w)-- withDT w' =- WmGen $ \x' -> do- t <- getTime- (mx, w) <- toGenM w' (x', zeroV)- return (mx, withDT' t w)-- where- withDT' :: t -> Wire e (Kleisli m) (a, t) b -> Wire e (Kleisli m) a b- withDT' t' w' =- WmGen $ \x' -> do- t <- getTime- let dt = t ^-^ t'- (mx, w) <- toGenM w' (x', dt)- return (mx, withDT' t w)----- | Passes the time passed since the first instant to the given wire.------ * Depends: Like argument wire.------ * Inhibits: When argument wire inhibits.--class Arrow (>~) => WWithTime t (>~) | (>~) -> t where- -- | Simplified variant without additional input.- passTime :: Wire e (>~) t b -> Wire e (>~) a b-- -- | Full variant.- withTime :: Wire e (>~) (a, t) b -> Wire e (>~) a b--instance (AdditiveGroup t, MonadClock t m) => WWithTime t (Kleisli m) where- passTime = withTime . mapInputM snd-- withTime w' =- WmGen $ \x' -> do- t0 <- getTime- (mx, w) <- toGenM w' (x', zeroV)- return (mx, withTime' t0 w)-- where- withTime' :: t -> Wire e (Kleisli m) (a, t) b -> Wire e (Kleisli m) a b- withTime' t0 =- fix $ \again w' ->- WmGen $ \x' -> do- t <- getTime- (mx, w) <- toGenM w' (x', t ^-^ t0)- return (mx, again w)----- | Passes the system time to the given wire.------ * Depends: Like argument wire.------ * Inhibits: When argument wire inhibits.--class Arrow (>~) => WWithSysTime t (>~) | (>~) -> t where- -- | Simplified variant without additional input.- passSysTime :: Wire e (>~) t b -> Wire e (>~) a b-- -- | Full variant.- withSysTime :: Wire e (>~) (a, t) b -> Wire e (>~) a b--instance MonadClock t m => WWithSysTime t (Kleisli m) where- passSysTime = withSysTime . mapInputM snd-- withSysTime w' =- WmGen $ \x' -> do- t <- getTime- (mx, w) <- toGenM w' (x', t)- return (mx, withSysTime w)
Control/Wire/Trans/Combine.hs view
@@ -1,88 +1,110 @@ -- | -- Module: Control.Wire.Trans.Combine--- Copyright: (c) 2011 Ertugrul Soeylemez+-- Copyright: (c) 2012 Ertugrul Soeylemez -- License: BSD3 -- Maintainer: Ertugrul Soeylemez <es@ertes.de> ----- Wire transformers for combining wires.+-- Wire combinators to manage sets of wires. module Control.Wire.Trans.Combine- ( -- * Context-sensitive evolution- WContext(..),- WContextLimit(..),+ ( -- * Multiplexing+ context,+ contextLatest,+ contextLimit, - -- * Distribute- WDistribute(..)+ -- * Multicast+ multicast ) where +import qualified Control.Wire.TimedMap as Tm import qualified Data.Map as M-import Control.Arrow-import Control.Wire.Classes-import Control.Wire.TimedMap-import Control.Wire.Types-import Data.AdditiveGroup-import Data.Either+import qualified Data.Traversable as T+import Control.Wire.TimedMap (TimedMap)+import Control.Wire.Wire+import Data.Map (Map) --- | Make the given wire context-sensitive. The right signal is a--- context and the wire will evolve individually for each context.+-- | The argument function turns the input signal into a context. For+-- each context the given base wire evolves individually. ----- * Depends: Like context wire (left), current instant (right).+-- Note: Incorrect usage can lead to a memory leak. Consider using+-- 'contextLimit' instead. ----- * Inhibits: Like context wire.+-- * Complexity: O(n) space, O(log n) time wrt to number of stored+-- contexts.+--+-- * Depends: current instant.+--+-- * Inhibits: when the context wire inhibits. -class Arrow (>~) => WContext (>~) where- context :: Ord k => Wire e (>~) (a, k) b -> Wire e (>~) (a, k) b+context ::+ forall a b m e k. (Monad m, Ord k)+ => (a -> k) -- ^ Function to turn the signal into a context.+ -> Wire e m a b -- ^ Base wire.+ -> Wire e m a b+context key w0 = context' M.empty 0+ where+ context' :: Map k (Wire e m a b, Time) -> Time -> Wire e m a b+ context' !ctxs t' =+ mkGen $ \dt' x' -> do+ let ctx = key x'+ (w', t0) = M.findWithDefault (w0, t') ctx ctxs+ t = t' + dt'+ dt = t - t0+ (mx, w) <- dt `seq` stepWire w' dt x'+ return (mx, context' (M.insert ctx (w, t) ctxs) t) -instance Monad m => WContext (Kleisli m) where- context w0 = context' M.empty- where- --context' :: Ord k => Map k (Wire e (Kleisli m) (a, k) b) -> Wire e (Kleisli m) (a, k) b- context' ctxs' =- WmGen $ \(x', ctx) -> do- let w' = M.findWithDefault w0 ctx ctxs'- (mx, w) <- toGenM w' (x', ctx)- let ctxs = M.insert ctx w ctxs'- return (mx, context' ctxs) +-- | Same as 'context', but keeps only the latest given number of+-- contexts. --- | Same as 'context', but with a time limit. The third signal--- specifies a maximum age. Contexts not used for longer than the--- maximum age are forgotten.------ * Depends: Like context wire (left), current instant (right).------ * Inhibits: Like context wire.+contextLatest ::+ (Monad m, Ord k)+ => (a -> k) -- ^ Signal to context.+ -> Int -- ^ Maximum number of latest wires.+ -> Wire e m a b -- ^ Base wire.+ -> Wire e m a b+contextLatest key maxWires = contextLimit key (\_ _ -> Tm.cut maxWires) -class Arrow (>~) => WContextLimit t (>~) | (>~) -> t where- contextLimit :: Ord k => Wire e (>~) (a, k) b -> Wire e (>~) ((a, k), t) b -instance (AdditiveGroup t, MonadClock t m, Ord t) => WContextLimit t (Kleisli m) where- contextLimit w0 = context' tmEmpty- where- --context' :: Ord k => TimedMap t k (Wire e (Kleisli m) (a, k) b) -> Wire e (Kleisli m) ((a, k), t) b- context' ctxs' =- WmGen $ \((x', ctx), maxAge) -> do- t <- getTime- let w' = tmFindWithDefault w0 ctx ctxs'- (mx, w) <- toGenM w' (x', ctx)+-- | Same as 'context', but applies the given cleanup function to the+-- context map at every instant. This can be used to drop older wires. - let ctxs = tmLimitAge (t ^-^ maxAge) . tmInsert t ctx w $ ctxs'- return (mx, context' ctxs)+contextLimit ::+ forall a b m e k. (Monad m, Ord k)+ => (a -> k) -- ^ Function to turn the signal into a context.+ -> (forall w. Int -> Time -> TimedMap Time k w -> TimedMap Time k w)+ -- ^ Cleanup function. Receives the current instant number,+ -- the current local time and the current map.+ -> Wire e m a b -- ^ Base wire.+ -> Wire e m a b+contextLimit key uf w0 = context' 0 Tm.empty 0+ where+ context' :: Int -> TimedMap Time k (Wire e m a b) -> Time -> Wire e m a b+ context' !n !ctxs t' =+ mkGen $ \dt' x' -> do+ let ctx = key x'+ (w', t0) = Tm.findWithDefault (w0, t') ctx ctxs+ t = t' + dt'+ dt = t - t0+ (mx, w) <- dt `seq` stepWire w' dt x'+ return (mx, context' (n + 1) (uf n t (Tm.insert t ctx w ctxs)) t) --- | Distribute the input signal over the given wires, evolving each of--- them individually. Discards all inhibited signals.+-- | Broadcast the input signal to all of the given wires collecting+-- their results. Each of the given subwires is evolved individually. ----- * Depends: as strict as the strictest subwire.--class Arrow (>~) => WDistribute (>~) where- distribute :: [Wire e (>~) a b] -> Wire e (>~) a [b]+-- * Depends: like the most dependent subwire.+--+-- * Inhibits: when any of the subwires inhibits. -instance Monad m => WDistribute (Kleisli m) where- distribute ws' =- WmGen $ \x' -> do- res <- mapM (\w' -> toGenM w' x') ws'- let (mxs, ws) = first rights . unzip $ res- return (Right mxs, distribute ws)+multicast ::+ (Monad m, T.Traversable f)+ => f (Wire e m a b)+ -> Wire e m a (f b)+multicast ws' =+ mkGen $ \dt x' -> do+ res <- T.mapM (\w -> stepWire w dt x') ws'+ let resx = T.sequence . fmap (\(mx, w) -> fmap (, w) mx) $ res+ return (fmap (fmap fst) resx, multicast (fmap snd res))
+ Control/Wire/Trans/Embed.hs view
@@ -0,0 +1,47 @@+-- |+-- Module: Control.Wire.Trans.Embed+-- Copyright: (c) 2012 Ertugrul Soeylemez+-- License: BSD3+-- Maintainer: Ertugrul Soeylemez <es@ertes.de>+--+-- Combinators for embedding wires.++module Control.Wire.Trans.Embed+ ( -- * Embedding wires+ embed+ )+ where++import Control.Wire.Wire+++-- | Performs the argument wire with the input time delta. It is+-- stepped often enough to catch up with the main wire. The individual+-- results are combined as given by the fold (second and third+-- argument).+--+-- * Complexity: O(n) time wrt stepping the subwire, where n is the+-- number of times the subwire is stepped.+--+-- * Depends: like argument wire, if stepped.+--+-- * Inhibits: When the fold results in a 'Left'.++embed ::+ (Monad m)+ => (a -> Time) -- ^ Time delta for the subwire.+ -> (Either e c -> Either e b -> Either e c) -- ^ Folding function.+ -> Either e c -- ^ Fold base value.+ -> Wire e m a b -- ^ Subwire to step.+ -> Wire e m a c+embed delta fold z = embed' 0+ where+ embed' rdt w0 =+ mkGen $ \dt x' ->+ let idt = delta x'+ loop odt r w'+ | odt >= idt = do+ (mx, w) <- stepWire w' idt x'+ loop (odt - idt) (fold r mx) w+ | otherwise = return (r, embed' odt w')+ in loop (rdt + dt) z w0
+ Control/Wire/Trans/Event.hs view
@@ -0,0 +1,211 @@+-- |+-- Module: Control.Wire.Trans.Event+-- Copyright: (c) 2012 Ertugrul Soeylemez+-- License: BSD3+-- Maintainer: Ertugrul Soeylemez <es@ertes.de>+--+-- Event-related wire combinators.++module Control.Wire.Trans.Event+ ( -- * Combinators+ eitherE,+ (<||>),++ -- * Holding events+ hold,+ hold_,+ holdFor,+ holdForI,++ -- * Inhibition+ (<!>),+ event,+ exhibit,+ gotEvent,+ notE+ )+ where++import Control.Arrow+import Control.Category+import Control.Wire.Types+import Control.Wire.Wire+import Data.Monoid hiding ((<>))+import Data.Semigroup+import Prelude hiding ((.), id)+++-- | Try both wires combining their results with the given functions.+--+-- * Like argument wires.+--+-- * Inhibits: when both wires inhibit.++eitherE ::+ (Monad m, Monoid e)+ => (b1 -> b) -- ^ Only left.+ -> (b2 -> b) -- ^ Only right.+ -> (b1 -> b2 -> b) -- ^ Both.+ -> Wire e m a b1 -- ^ First wire.+ -> Wire e m a b2 -- ^ Second wire.+ -> Wire e m a b+eitherE left right both = eitherE'+ where+ eitherE' w1' w2' =+ mkGen $ \dt x' -> do+ (mx1, w1) <- stepWire w1' dt x'+ (mx2, w2) <- stepWire w2' dt x'+ let res =+ case (mx1, mx2) of+ (Left ex1, Left ex2) -> Left (mappend ex1 ex2)+ (Right x1, Right x2) -> Right (both x1 x2)+ (Right x1, _) -> Right (left x1)+ (_, Right x2) -> Right (right x2)+ return (res, eitherE' w1 w2)+++-- | Semigroup version of 'eitherE'.++(<||>) ::+ (Monad m, Monoid e, Semigroup b)+ => Wire e m a b+ -> Wire e m a b+ -> Wire e m a b+(<||>) = eitherE id id (<>)+++-- | If the argument wire inhibits, inhibit with the given exception+-- instead.+--+-- * Depends: like argument wire.+--+-- * Inhibits: like argument wire.++(<!>) :: (Monad m) => Wire e m a b -> e -> Wire e m a b+w <!> ex = mapOutput (either (Left . const ex) Right) w+++-- | Prevent a wire from inhibiting. Instead produce a signal wrapped+-- in 'Maybe'.+--+-- Note: You probably shouldn't use this function.+--+-- * Depends: like argument wire.++event :: (Monad m) => Wire e m a b -> Wire e m a (Maybe b)+event = mapOutput (Right . either (const Nothing) Just)+++-- | Prevent a wire from inhibiting. Instead produce the inhibition+-- value.+--+-- Note: You probably shouldn't use this function.+--+-- * Depends: like argument wire.++exhibit :: (Monad m) => Wire e m a b -> Wire e m a (Either e b)+exhibit = mapOutput Right+++-- | Prevent a wire from inhibiting. Instead produce 'False', if the+-- wire inhibited.+--+-- Note: You probably shouldn't use this function.+--+-- * Depends: like argument wire.++gotEvent :: (Monad m) => Wire e m a b -> Wire e m a Bool+gotEvent = mapOutput (Right . either (const False) (const True))+++-- | Hold the latest event. Produces the last produced value starting+-- with the given one.+--+-- * Depends: like argument wire.++hold :: (Monad m) => b -> Wire e m a b -> Wire e m a b+hold x0 w' =+ mkGen $ \dt x' -> do+ (mx, w) <- stepWire w' dt x'+ case mx of+ Left _ -> return (Right x0, hold x0 w)+ Right x -> return (Right x, hold x w)+++-- | Hold the event. Once the argument wire produces the produced value+-- is held until the argument wire produces again.+--+-- * Depends: like argument wire.+--+-- * Inhibits: until the argument wire produces for the first time.++hold_ :: (Monad m) => Wire e m a b -> Wire e m a b+hold_ w' =+ mkGen $ \dt x' -> do+ (mx, w) <- stepWire w' dt x'+ return (mx, either (const hold_) hold mx w)+++-- | Hold the event for the given amount of time. When the argument+-- wire produces, the produced value is kept for the given amount of+-- time. If the wire produces again while another value is kept, the+-- new value takes precedence.+--+-- * Depends: like argument wire.+--+-- * Inhibits: as described.++holdFor :: (Monad m) => Time -> Wire e m a b -> Wire e m a b+holdFor t0 w = hold' . exhibit w+ where+ hold' =+ mkPure $ \_ mx ->+ case mx of+ Left _ -> (mx, hold')+ Right x -> (mx, hold'' t0 x)++ hold'' t' x' =+ mkPure $ \dt mx ->+ let t = t' - dt in+ case mx of+ Left _+ | t > 0 -> (Right x', hold'' t x')+ | otherwise -> (mx, hold')+ Right x -> (mx, hold'' t0 x)+++-- | Hold the event for the given number of instances. When the+-- argument wire produces, the produced value is kept for the given+-- number of instances. If the wire produces again while another value+-- is kept, the new value takes precedence.+--+-- * Depends: like argument wire.+--+-- * Inhibits: as described.++holdForI :: (Monad m) => Time -> Wire e m a b -> Wire e m a b+holdForI t0 w = hold' . exhibit w+ where+ hold' = mkPure $ \_ -> id &&& either (const hold') (hold'' t0)++ hold'' t x'+ | t <= 0 = hold'+ | otherwise =+ mkPure $ \_ mx ->+ case mx of+ Left _ -> (Right x', hold'' (t - 1) x')+ Right x -> (mx, hold'' t0 x)+++-- | Act like the identity wire, if the argument wire inhibits.+-- Inhibit, if the argument wire produces.+--+-- * Depends: like argument wire.+--+-- * Inhibits: when argument wire produces.++notE :: (Monad m, Monoid e) => Event e m a -> Event e m a+notE w' =+ mkGen $ \dt x' -> do+ (mx, w) <- stepWire w' dt x'+ return (either (const $ Right x') (const $ Left mempty) mx, notE w)
− Control/Wire/Trans/Exhibit.hs
@@ -1,69 +0,0 @@--- |--- Module: Control.Wire.Trans.Exhibit--- Copyright: (c) 2011 Ertugrul Soeylemez--- License: BSD3--- Maintainer: Ertugrul Soeylemez <es@ertes.de>------ Wire transformers for handling inhibited signals.--module Control.Wire.Trans.Exhibit- ( -- * Exhibition- WExhibit(..)- )- where--import Control.Arrow-import Control.Wire.Types----- | Wire transformers for handling inhibited signals.--class Arrow (>~) => WExhibit (>~) where- -- | Produces 'Just', whenever the argument wire produces, otherwise- -- 'Nothing'.- --- -- * Depends: like argument wire.- event :: Wire e (>~) a b -> Wire e (>~) a (Maybe b)-- -- | Produces 'Right', whenever the argument wire produces, otherwise- -- 'Left' with the inhibition value.- --- -- * Depends: like argument wire.- exhibit :: Wire e (>~) a b -> Wire e (>~) a (Either e b)-- -- | Produces 'True', whenever the argument wire produces, otherwise- -- 'False'.- gotEvent :: Wire e (>~) a b -> Wire e (>~) a Bool---instance Monad m => WExhibit (Kleisli m) where- event (WmPure f) =- WmPure $ \(f -> (mx, w)) ->- (Right (either (const Nothing) Just mx), event w)- event (WmGen c) =- WmGen $ \x' -> do- (mx, w) <- c x'- return (Right (either (const Nothing) Just mx), event w)-- exhibit (WmPure f) =- WmPure $ \(f -> (mx, w)) ->- (Right mx, exhibit w)- exhibit (WmGen c) =- WmGen $ \x' -> do- (mx, w) <- c x'- return (Right mx, exhibit w)-- gotEvent (WmPure f) =- WmPure $ \(f -> (mx, w)) ->- (Right (isRight mx), gotEvent w)- gotEvent (WmGen c) =- WmGen $ \x' -> do- (mx, w) <- c x'- return (Right (isRight mx), gotEvent w)----- | 'True', if 'Right'.--isRight :: Either e a -> Bool-isRight (Right _) = True-isRight (Left _) = False
− Control/Wire/Trans/Fork.hs
@@ -1,232 +0,0 @@--- |--- Module: Control.Wire.Trans.Fork--- Copyright: (c) 2011 Ertugrul Soeylemez--- License: BSD3--- Maintainer: Ertugrul Soeylemez <es@ertes.de>------ Wire concurrency.------ /Warning/: This module is highly experimental and currently causes--- space leaks. Please use wire concurrency only for short-lived--- threads.--module Control.Wire.Trans.Fork- ( -- * Embedding concurrent wires- WFork(..),-- -- * Wire thread manager- WireMgr,- startWireMgr,- stopWireMgr,- withWireMgr,-- -- * Wire threads- -- ** Channels- WireChan,- feedWireChan,- readWireChan,- -- ** Threads- WireThread,- killWireThread- )- where--import qualified Data.Map as M-import Control.Applicative-import Control.Arrow-import Control.Concurrent.Lifted-import Control.Concurrent.STM-import Control.Exception.Lifted-import Control.Monad-import Control.Monad.Fix-import Control.Monad.Trans.Control-import Control.Monad.Trans-import Control.Wire.Types-import Data.Map (Map)-import Data.Monoid---{-# WARNING WFork "Wire concurrency is not stable at the moment!" #-}----- | Forking wire transformer. Creates a concurrent wire thread and--- opens a communication channel to it.--class Arrow (>~) => WFork (>~) where- -- | Feed a wire thread with additional input.- --- -- * Depends: Current instant.- feedWire :: Wire e (>~) (WireChan a b, a) ()-- -- | Fork the input wire using the input wire manager.- --- -- Note: This wire forks at every instant. In many cases you will- -- want to use the 'swallow' wire transformer with this.- --- -- * Depends: Current instant.- forkWire :: Wire e (>~) (Wire e (>~) a b, WireMgr)- (WireChan a b, WireThread)-- -- | Asks the given wire for its next output.- --- -- * Depends: Current instant.- --- -- * Inhibits: When there is no data.- queryWire :: Monoid e => Wire e (>~) (WireChan a b) b--instance (MonadBaseControl IO m, MonadIO m) => WFork (Kleisli m) where- -- feedWire- feedWire =- mkFixM $ \(wc, x') -> do- let ichan = wcInputChan wc- liftIO . atomically $ writeTChan ichan x'- return (Right ())-- -- forkWire- forkWire =- mkFixM $ \(thrW, mgr) -> do- ichan <- liftIO newTChanIO- ochan <- liftIO newTChanIO- doneVar <- liftIO (newTVarIO False)- quitVar <- liftIO (newTVarIO False)-- let wc = WireChan { wcInputChan = ichan,- wcOutputChan = ochan }-- mgrOp mgr $ do- tid <- fork (thread ichan ochan quitVar doneVar thrW)-- let wt = WireThread { wtDoneVar = doneVar,- wtThreadId = tid,- wtQuitVar = quitVar }-- let thrsVar = wmThrsVar mgr- liftIO . atomically $ do- thrs <- readTVar thrsVar- writeTVar thrsVar (M.insert tid wt thrs)-- return (Right (wc, wt))-- where- thread ichan ochan quitVar doneVar =- fix $ \loop w' -> do- mx' <- liftIO . atomically $- Just <$> readTChan ichan <|>- Nothing <$ (readTVar quitVar >>= check)- case mx' of- Just x' -> do- (mx, w) <- toGenM w' x'- either (const $ return ()) (liftIO . atomically . writeTChan ochan) mx- loop w- Nothing -> do- liftIO (atomically $ writeTVar doneVar True)-- -- queryWire- queryWire =- mkFixM $ \wc -> do- let ochan = wcOutputChan wc- liftIO . atomically $- Right <$> readTChan ochan <|>- return (Left mempty)----- | A wire channel allows you to send input to and receive output from--- a concurrently running wire.--data WireChan a b =- WireChan {- wcInputChan :: !(TChan a), -- ^ Input channel.- wcOutputChan :: !(TChan b) -- ^ Output channel.- }----- | A wire thread manager keeps track of created wire threads.--data WireMgr =- WireMgr {- wmFreeVar :: !(TVar Bool),- wmThrsVar :: !(TVar (Map ThreadId WireThread))- }----- | A wire thread is a concurrently running wire.--data WireThread- = WireThread {- wtDoneVar :: !(TVar Bool), -- ^ True, when wire has quitted.- wtThreadId :: !ThreadId, -- ^ Thread id.- wtQuitVar :: !(TVar Bool) -- ^ Set to true to terminate the wire.- }----- | Feed the given wire thread with input.--feedWireChan :: WireChan a b -> a -> IO ()-feedWireChan (wcInputChan -> ichan) = atomically . writeTChan ichan----- | Kill the given wire thread.--killWireThread :: WireMgr -> WireThread -> IO ()-killWireThread mgr thr = do- let WireThread { wtDoneVar = doneVar,- wtThreadId = tid,- wtQuitVar = quitVar } = thr- thrsVar = wmThrsVar mgr- mgrOp mgr $ do- thrs <- readTVarIO thrsVar- atomically (writeTVar quitVar True)- atomically $ do- readTVar doneVar >>= check- writeTVar thrsVar (M.delete tid thrs)----- | Perform a manager operation safely.--mgrOp :: (MonadBaseControl IO m, MonadIO m) => WireMgr -> m a -> m a-mgrOp mgr c = do- let freeVar = wmFreeVar mgr- liftIO . atomically $ do- readTVar freeVar >>= check- writeTVar freeVar False-- c `finally` liftIO (atomically $ writeTVar freeVar True)----- | Read the given wire's next output.--readWireChan :: WireChan a b -> IO b-readWireChan (wcOutputChan -> ochan) = atomically (readTChan ochan)----- | Start a wire manager.--startWireMgr :: IO WireMgr-startWireMgr = do- freeVar <- newTVarIO True- thrsVar <- newTVarIO M.empty- return WireMgr { wmFreeVar = freeVar,- wmThrsVar = thrsVar }----- | Stop a wire manager terminating all threads it keeps track of.--stopWireMgr :: WireMgr -> IO ()-stopWireMgr mgr =- mgrOp mgr $ do- let thrsVar = wmThrsVar mgr- thrs <- fmap M.assocs (readTVarIO thrsVar)- forM_ thrs $ \(_, wtQuitVar -> quitVar) ->- atomically (writeTVar quitVar True)- forM_ thrs $ \(tid, wtDoneVar -> doneVar) -> do- atomically (readTVar doneVar >>= check)- killThread tid- atomically (writeTVar thrsVar M.empty)----- | Convenient wrapper around 'startWireMgr' and 'stopWireMgr'.--withWireMgr :: (MonadBaseControl IO m, MonadIO m) => (WireMgr -> m a) -> m a-withWireMgr k = do- mgr <- liftIO startWireMgr- k mgr `finally` liftIO (stopWireMgr mgr)
− Control/Wire/Trans/Memoize.hs
@@ -1,99 +0,0 @@--- |--- Module: Control.Wire.Trans.Memoize--- Copyright: (c) 2011 Ertugrul Soeylemez--- License: BSD3--- Maintainer: Ertugrul Soeylemez <es@ertes.de>------ Memoizing wire transformers.--module Control.Wire.Trans.Memoize- ( -- * Memoizing- WCache(..),- WPurify(..)- )- where--import Control.Arrow-import Control.Monad.Fix-import Control.Wire.Classes-import Control.Wire.TimedMap-import Control.Wire.Types-import Data.AdditiveGroup----- | Remember the most recently produced values. You can limit both the--- maximum age and the number of remembered values. The second input--- value specifies the maximum age, the third specifies the maximum--- number.------ Note: Inhibtion is never remembered.------ Note: Decreasing the size limit has O(n * log n) complexity, where n--- is the difference to the old limit.------ * Depends: Current instant.------ * Inhibits: Whenever result is not cached and argument wire inhibits.--class Arrow (>~) => WCache t (>~) | (>~) -> t where- cache :: Ord a => Wire e (>~) a b -> Wire e (>~) ((a, t), Int) b--instance (AdditiveGroup t, MonadClock t m, Ord t) => WCache t (Kleisli m) where- cache = cache' tmEmpty- where- cache' :: Ord a => TimedMap t a b -> Wire e (Kleisli m) a b -> Wire e (Kleisli m) ((a, t), Int) b- cache' xs' w' =- WmGen $ \((x', maxAge), limit) -> do- t <- getTime- (mx, w) <-- case tmLookup x' xs' of- Nothing -> toGenM w' x'- Just x -> return (Right x, w')- let xs = tmLimitSize limit .- tmLimitAge (t ^-^ maxAge) .- either (const id) (tmInsert t x') mx $ xs'- return (mx, cache' xs w)----- | Remember the last produced value. Whenever an input is repeated,--- the argument wire is ignored and the memoized result is returned--- instantly. Note: inhibition will not be remembered.------ * Depends: Current instant.------ * Inhibits: Like the argument wire for non-memoized inputs.--class Arrow (>~) => WPurify (>~) where- purify :: Eq a => Wire e (>~) a b -> Wire e (>~) a b--instance Monad m => WPurify (Kleisli m) where- purify w' =- case w' of- WmPure f ->- WmPure $ \x' ->- let (mx, w) = f x' in- (mx, either (const $ purify w) (\x -> purify' x' x w) mx)- WmGen c ->- WmGen $ \x' -> do- (mx, w) <- c x'- return (mx, either (const $ purify w) (\x -> purify' x' x w) mx)-- where- purify' :: Eq a => a -> b -> Wire e (Kleisli m) a b -> Wire e (Kleisli m) a b- purify' x0' x0 =- fix $ \again w' ->- case w' of- WmPure f ->- WmPure $ \x' ->- if x' /= x0'- then- let (mx, w) = f x' in- (mx, either (const $ again w) (\x -> purify' x' x w) mx)- else (Right x0, again w')- WmGen c ->- WmGen $ \x' ->- if x' /= x0'- then do- (mx, w) <- c x'- return (mx, either (const $ again w) (\x -> purify' x' x w) mx)- else return (Right x0, again w')
− Control/Wire/Trans/Sample.hs
@@ -1,161 +0,0 @@--- |--- Module: Control.Wire.Trans.Sample--- Copyright: (c) 2011 Ertugrul Soeylemez--- License: BSD3--- Maintainer: Ertugrul Soeylemez <es@ertes.de>------ Wire transformers for sampling wires.--module Control.Wire.Trans.Sample- ( -- * Sampling- WHold(..),- WSample(..),- WSampleInt(..),- WSwallow(..)- )- where--import Control.Arrow-import Control.Monad-import Control.Wire.Classes-import Control.Wire.Prefab.Simple-import Control.Wire.Types-import Data.AdditiveGroup----- | Hold signals.--class Arrow (>~) => WHold (>~) where- -- | Keeps the latest produced value.- --- -- * Depends: Like argument wire.- --- -- * Inhibits: Until first production.- hold :: Wire e (>~) a b -> Wire e (>~) a b-- -- | Keeps the latest produced value. Produces the argument value until- -- the argument wire starts producing.- --- -- * Depends: Like argument wire.- holdWith :: b -> Wire e (>~) a b -> Wire e (>~) a b--instance Monad m => WHold (Kleisli m) where- -- hold- hold (WmPure f) =- WmPure $ \x' ->- let (mx, w) = f x' in- case mx of- Left ex -> (Left ex, hold w)- Right x -> (Right x, holdWith x w)- hold (WmGen c) =- WmGen $ \x' -> do- (mx, w) <- c x'- return $- case mx of- Left ex -> (Left ex, hold w)- Right x -> (Right x, holdWith x w)-- -- holdWith- holdWith x0 (WmPure f) =- WmPure $ \x' ->- let (mx, w) = f x' in- case mx of- Left _ -> (Right x0, holdWith x0 w)- Right x -> (Right x, holdWith x w)- holdWith x0 (WmGen c) =- WmGen $ \x' -> do- (mx, w) <- c x'- return $- case mx of- Left _ -> (Right x0, holdWith x0 w)- Right x -> (Right x, holdWith x w)----- | Samples the given wire at discrete time intervals. Only runs the--- input through the wire, when the next sampling interval starts.------ * Depends: Current instant (left), like argument wire at sampling--- intervals (right).------ * Inhibits: Starts inhibiting when argument wire inhibits. Keeps--- inhibiting until next sampling interval.--class Arrow (>~) => WSample t (>~) | (>~) -> t where- sample :: Wire e (>~) a b -> Wire e (>~) (a, t) b--instance (AdditiveGroup t, MonadClock t m, Ord t) => WSample t (Kleisli m) where- sample w' =- WmGen $ \(x', int) ->- if int <= zeroV- then liftM (second sample) (toGenM w' x')- else do- t0 <- getTime- (mx, w) <- toGenM w' x'- return (mx, sample' t0 mx w)-- where- sample' :: Ord t => t -> Either e b -> Wire e (Kleisli m) a b -> Wire e (Kleisli m) (a, t) b- sample' t0 mx0 w' =- WmGen $ \(x', int) ->- if int <= zeroV- then liftM (second sample) (toGenM w' x')- else do- t <- getTime- let tt = t0 ^+^ int- if t >= tt- then do- (mx, w) <- toGenM w' x'- return (mx, sample' tt mx w)- else return (mx0, sample' t0 mx0 w')----- | Samples the given wire at discrete frame count intervals. Only--- runs the input through the wire, when the next sampling interval--- starts.------ * Depends: Current instant (left), like argument wire at sampling--- intervals (right).------ * Inhibits: Starts inhibiting when argument wire inhibits. Keeps--- inhibiting until next sampling interval.--class Arrow (>~) => WSampleInt (>~) where- sampleInt :: Wire e (>~) a b -> Wire e (>~) (a, Int) b--instance Monad m => WSampleInt (Kleisli m) where- sampleInt w' =- WmGen $ \(x', _) -> do- (mx, w) <- toGenM w' x'- return (mx, sample' 0 mx w)-- where- sample' :: Int -> Either e b -> Wire e (Kleisli m) a b -> Wire e (Kleisli m) (a, Int) b- sample' (succ -> n) mx0 w' =- WmGen $ \(x', int) ->- if n >= int- then do- (mx, w) <- toGenM w' x'- return (mx, sample' 0 mx w)- else return (mx0, sample' n mx0 w')----- | Waits for the argument wire to produce and then keeps the first--- produced value forever.------ * Depends: Like argument wire until first production. Then stops--- depending.------ * Inhibits: Until the argument wire starts producing.--class Arrow (>~) => WSwallow (>~) where- swallow :: Wire e (>~) a b -> Wire e (>~) a b--instance Monad m => WSwallow (Kleisli m) where- swallow (WmPure f) =- WmPure $ \x' ->- let (mx, w) = f x' in- (mx, either (const $ swallow w) constant mx)- swallow (WmGen c) =- WmGen $ \x' -> do- (mx, w) <- c x'- return (mx, either (const $ swallow w) constant mx)
Control/Wire/Trans/Simple.hs view
@@ -1,57 +1,49 @@ -- | -- Module: Control.Wire.Trans.Simple--- Copyright: (c) 2011 Ertugrul Soeylemez+-- Copyright: (c) 2012 Ertugrul Soeylemez -- License: BSD3 -- Maintainer: Ertugrul Soeylemez <es@ertes.de> ----- Simple wire transformers.+-- Basic wire combinators. module Control.Wire.Trans.Simple- ( -- * Override input- WOverrideInput(..),- (>--)+ ( -- * Predicate-based+ ifW ) where import Control.Arrow-import Control.Wire.Types----- | Override input.--class Arrow (>~) => WOverrideInput (>~) where- -- | Apply the given function to the input, until the argument wire- -- starts producing.- --- -- * Depends: Like argument wire.- --- -- * Inhibits: Like argument wire.-- (--<) :: Arrow (>~) => Wire e (>~) a b -> (a -> a) -> Wire e (>~) a b-- infixr 5 --<---instance Monad m => WOverrideInput (Kleisli m) where- WmPure f --< g =- WmPure $ \x' ->- let (mx, w) = f (g x') in- (mx, either (const $ w --< g) (const w) mx)- WmGen c --< g =- WmGen $ \x' -> do- (mx, w) <- c (g x')- return (mx, either (const $ w --< g) (const w) mx)-+import Control.Monad+import Control.Wire.Wire+import Data.Monoid+import Prelude hiding ((.), id) --- | Apply the given function to the input, until the argument wire--- starts producing.+-- | The wire @ifW p x y@ acts like @x@, when the predicate @p@ is true,+-- otherwise @y@. ----- * Depends: Like argument wire.+-- * Complexity: like the predicate and the chosen wire. ----- * Inhibits: Like argument wire.--(>--) :: WOverrideInput (>~) => (a -> a) -> Wire e (>~) a b -> Wire e (>~) a b-(>--) = flip (--<)+-- * Depends: like the predicate and the chosen wire.+--+-- * Inhibits: when the predicate or the chosen wire inhibits. -infixl 5 >--+ifW ::+ (Monad m, Monoid e)+ => Wire e m a Bool -- ^ Predicate.+ -> Wire e m a b -- ^ If true.+ -> Wire e m a b -- ^ If false.+ -> Wire e m a b+ifW = ifW' 0 0+ where+ ifW' !tx !ty wp' wx' wy' =+ mkGen $ \dt x' -> do+ (mb, wp) <- stepWire wp' dt x'+ case mb of+ Left ex -> return (Left ex, ifW' (tx + dt) (ty + dt) wp wx' wy')+ Right b ->+ if b+ then liftM (second (\wx -> ifW' 0 (ty + dt) wp wx wy')) $+ stepWire wx' (tx + dt) x'+ else liftM (second (ifW' (tx + dt) 0 wp wx')) $+ stepWire wy' (ty + dt) x'
+ Control/Wire/Trans/Switch.hs view
@@ -0,0 +1,101 @@+-- |+-- Module: Control.Wire.Trans.Switch+-- Copyright: (c) 2012 Ertugrul Soeylemez+-- License: BSD3+-- Maintainer: Ertugrul Soeylemez <es@ertes.de>+--+-- Switching combinators. Notice that these combinators restart time+-- when switching.++module Control.Wire.Trans.Switch+ ( -- * Simple switching+ andThen,+ switch,+ switchBy,+ (-->)+ )+ where++import Control.Arrow+import Control.Monad+import Control.Wire.Wire+++-- | Infix variant of 'andThen'.+--+-- This operator is right-associative with precedence 1.++(-->) :: (Monad m) => Wire e m a b -> Wire e m a b -> Wire e m a b+(-->) = andThen++infixr 1 -->+++-- | Behaves like the first wire until it inhibits. Switches to the+-- second wire as soon as the first one inhibits.+--+-- The @`andThen`@ operator is right-associative with precedence 1.+--+-- * Depends: like currently active wire.+--+-- * Inhibits: when switched to second wire and that one inhibits.+--+-- * Time: switching restarts time.++andThen ::+ (Monad m)+ => Wire e m a b -- ^ Wire to start with.+ -> Wire e m a b -- ^ Wire to switch into.+ -> Wire e m a b+andThen w1' w2' =+ mkGen $ \dt x' -> do+ (mx, w1) <- stepWire w1' dt x'+ case mx of+ Left _ -> stepWire w2' dt x'+ Right _ -> return (mx, andThen w1 w2')++infixr 1 `andThen`+++-- | If the first argument wire produces a wire, switch to it+-- immediately. If not, evolve the current wire. The second argument+-- wire is the initial wire.+--+-- * Depends: like event wire and the currently active wire.+--+-- * Inhibits: when the currently active wire inhibits.+--+-- * Time: switching restarts time.++switch ::+ (Monad m)+ => Wire e m a (Wire e m a b) -- ^ Produces a wire to switch into.+ -> Wire e m a b -- ^ Initial wire.+ -> Wire e m a b+switch wnew' w0 =+ mkGen $ \dt x' -> do+ (w', wnew) <- liftM (first (either (const w0) id)) (stepWire wnew' dt x')+ (mx, w) <- stepWire w' dt x'+ return (mx, switch wnew w)+++-- | Whenever the given wire inhibits, a new wire is constructed using+-- the given function.+--+-- * Depends: like currently active wire.+--+-- * Time: switching restarts time.++switchBy ::+ (Monad m)+ => (e' -> Wire e' m a b) -- ^ Wire selection function.+ -> Wire e' m a b -- ^ Initial wire.+ -> Wire e m a b+switchBy new w0 =+ mkGen $ \dt x' ->+ let select w' = do+ (mx, w) <- stepWire w' dt x'+ case mx of+ Left ex -> select (new ex)+ Right x -> return (Right x, switchBy new w)+ in select w0
+ Control/Wire/Trans/Time.hs view
@@ -0,0 +1,31 @@+-- |+-- Module: Control.Wire.Trans.Time+-- Copyright: (c) 2012 Ertugrul Soeylemez+-- License: BSD3+-- Maintainer: Ertugrul Soeylemez <es@ertes.de>+--+-- Time-related wire combinators.++module Control.Wire.Trans.Time+ ( -- * Local time+ mapTime+ )+ where++import Control.Arrow+import Control.Monad+import Control.Wire.Wire+++-- | Maps the given function over the time deltas for the given wire.+--+-- * Complexity: like argument wire.+--+-- * Depends: like argument wire.+--+-- * Inhibits: like argument wire.++mapTime :: (Monad m) => (Time -> Time) -> Wire e m a b -> Wire e m a b+mapTime f w' =+ mkGen $ \dt ->+ liftM (second (mapTime f)) . stepWire w' (f dt)
Control/Wire/Types.hs view
@@ -1,540 +1,161 @@ -- | -- Module: Control.Wire.Types--- Copyright: (c) 2011 Ertugrul Soeylemez+-- Copyright: (c) 2012 Ertugrul Soeylemez -- License: BSD3 -- Maintainer: Ertugrul Soeylemez <es@ertes.de> ----- Types used in the netwire library.+-- Types used in Netwire. Most notably this module implements the+-- instances for the various reactive classes. module Control.Wire.Types- ( -- * The wire- Wire(..),- WireM,-- -- * Construction and destruction- WireGen(..),- WirePure(..),- WireToGen(..),- mkFixM,- toGenM,-- -- * Inhibition+ ( -- * Convenient type aliases LastException,- inhibitException,- inhibitMsg,+ -- ** Events+ Event,+ EventM,+ EventP,+ -- ** Wires+ WireM,+ WireP, - -- * Utilities- mapInputM+ -- * Type-related utilities+ as,+ inAs,+ inLike,+ like,+ outAs,+ outLike,+ -- ** Predefined proxies+ pDouble,+ pFloat,+ pInt,+ pInteger,+ pString ) where -import qualified Control.Exception as Ex-import Control.Applicative-import Control.Arrow-import Control.Arrow.Operations-import Control.Arrow.Transformer import Control.Category+import Control.Exception (SomeException) import Control.Monad-import Control.Monad.Fix-import Control.Monad.Reader.Class-import Control.Monad.State.Class-import Control.Monad.Writer.Class-import Control.Wire.Classes+import Control.Monad.Identity+import Control.Wire.Wire import Data.Monoid+import Data.Proxy import Prelude hiding ((.), id) --- | Convenience type for wire exceptions.--type LastException = Last Ex.SomeException----- | Signal networks.--data family Wire :: * -> (* -> * -> *) -> * -> * -> *--data instance Wire e (Kleisli m) a b where- WmGen :: (a -> m (Either e b, Wire e (Kleisli m) a b)) -> Wire e (Kleisli m) a b- WmPure :: (a -> (Either e b, Wire e (Kleisli m) a b)) -> Wire e (Kleisli m) a b----- | Choice at the functor level.--instance (Monad m, Monoid e) => Alternative (Wire e (Kleisli m) a) where- empty = zeroArrow- (<|>) = (<+>)----- | Map a function signal over the output signal.--instance Monad m => Applicative (Wire e (Kleisli m) a) where- pure = mkPureFix . const . Right-- WmPure ff <*> wx'@(WmPure fx) =- WmPure $ \x' ->- case ff x' of- (Left ex, wf) -> (Left ex, wf <*> wx')- (Right f, wf) ->- let (mx, wx) = fx x'- in (fmap f mx, wf <*> wx)-- WmPure ff <*> wx'@(WmGen fx) =- WmGen $ \x' ->- case ff x' of- (Left ex, wf) -> return (Left ex, wf <*> wx')- (Right f, wf) -> liftM (fmap f *** (wf <*>)) (fx x')-- WmGen ff <*> wx'@(WmPure fx) =- WmGen $ \x' -> do- (mf, wf) <- ff x'- return $- case mf of- Left ex -> (Left ex, wf <*> wx')- Right f ->- let (mx, wx) = fx x'- in (fmap f mx, wf <*> wx)-- WmGen ff <*> wx'@(WmGen fx) =- WmGen $ \x' -> do- (mf, wf) <- ff x'- case mf of- Left ex -> return (Left ex, wf <*> wx')- Right f -> liftM (fmap f *** (wf <*>)) (fx x')----- | Wire side channels.--instance Monad m => Arrow (Wire e (Kleisli m)) where- arr f = mkPureFix $ Right . f-- first (WmGen c) =- WmGen $ \(x', y) -> do- (mx, w) <- c x'- return (fmap (, y) mx, first w)- first (WmPure f) =- WmPure $ \(x', y) ->- let (mx, w) = f x'- in (fmap (, y) mx, first w)-- second (WmGen c) =- WmGen $ \(x, y') -> do- (my, w) <- c y'- return (fmap (x,) my, second w)- second (WmPure f) =- WmPure $ \(x, y') ->- let (my, w) = f y'- in (fmap (x,) my, second w)-- -- (&&&) combinator.- WmGen c1 &&& w2'@(WmGen c2) =- WmGen $ \x' -> do- (mx1, w1) <- c1 x'- case mx1 of- Left ex -> return (Left ex, w1 &&& w2')- Right x1 -> do- (mx2, w2) <- c2 x'- return (fmap (x1,) mx2, w1 &&& w2)-- WmGen c1 &&& w2'@(WmPure g) =- WmGen $ \x' -> do- (mx1, w1) <- c1 x'- case mx1 of- Left ex -> return (Left ex, w1 &&& w2')- Right x1 ->- let (mx2, w2) = g x' in- return (fmap (x1,) mx2, w1 &&& w2)-- WmPure f &&& w2'@(WmGen c2) =- WmGen $ \x' ->- let (mx1, w1) = f x' in- case mx1 of- Left ex -> return (Left ex, w1 &&& w2')- Right x1 -> do- (mx2, w2) <- c2 x'- return (fmap (x1,) mx2, w1 &&& w2)-- WmPure f &&& w2'@(WmPure g) =- WmPure $ \x' ->- let (mx1, w1) = f x'- (mx2, w2) = g x' in- case mx1 of- Left ex -> (Left ex, w1 &&& w2')- Right x1 -> (fmap (x1,) mx2, w1 &&& w2)-- -- (***) combinator.- WmGen c1 *** w2'@(WmGen c2) =- WmGen $ \(x', y') -> do- (mx, w1) <- c1 x'- case mx of- Left ex -> return (Left ex, w1 *** w2')- Right x -> do- (my, w2) <- c2 y'- return (fmap (x,) my, w1 *** w2)-- WmGen c1 *** w2'@(WmPure g) =- WmGen $ \(x', g -> (my, w2)) -> do- (mx, w1) <- c1 x'- return $- case mx of- Left ex -> (Left ex, w1 *** w2')- Right x -> (fmap (x,) my, w1 *** w2)-- WmPure f *** w2'@(WmGen c2) =- WmGen $ \(f -> (mx, w1), y') -> do- case mx of- Left ex -> return (Left ex, w1 *** w2')- Right x -> do- (my, w2) <- c2 y'- return (fmap (x,) my, w1 *** w2)-- WmPure f *** w2'@(WmPure g) =- WmPure $ \(f -> (mx, w1), g -> (my, w2)) ->- case mx of- Left ex -> (Left ex, w1 *** w2')- Right x -> (fmap (x,) my, w1 *** w2)----- | Support for choice (signal redirection).--instance Monad m => ArrowChoice (Wire e (Kleisli m)) where- left w'@(WmPure f) =- WmPure $ \mx' ->- case mx' of- Left x' -> fmap Left *** left $ f x'- Right x' -> (Right (Right x'), left w')-- left w'@(WmGen c) =- WmGen $ \mx' ->- case mx' of- Left x' -> liftM (fmap Left *** left) (c x')- Right x' -> return (Right (Right x'), left w')-- right w'@(WmPure f) =- WmPure $ \mx' ->- case mx' of- Right x' -> fmap Right *** right $ f x'- Left x' -> (Right (Left x'), right w')-- right w'@(WmGen c) =- WmGen $ \mx' ->- case mx' of- Right x' -> liftM (fmap Right *** right) (c x')- Left x' -> return (Right (Left x'), right w')-- wl'@(WmPure f) +++ wr'@(WmPure g) =- WmPure $ \mx' ->- case mx' of- Left x' -> (fmap Left *** (+++ wr')) . f $ x'- Right x' -> (fmap Right *** (wl' +++)) . g $ x'-- wl' +++ wr' =- WmGen $ \mx' ->- case mx' of- Left x' -> liftM (fmap Left *** (+++ wr')) (toGenM wl' x')- Right x' -> liftM (fmap Right *** (wl' +++)) (toGenM wr' x')-- wl'@(WmPure f) ||| wr'@(WmPure g) =- WmPure $ \mx' ->- case mx' of- Left x' -> second (||| wr') . f $ x'- Right x' -> second (wl' |||) . g $ x'-- wl' ||| wr' =- WmGen $ \mx' ->- case mx' of- Left x' -> liftM (second (||| wr')) (toGenM wl' x')- Right x' -> liftM (second (wl' |||)) (toGenM wr' x')----- | Support for one-instant delays.--instance (MonadFix m, Monoid e) => ArrowCircuit (Wire e (Kleisli m)) where- delay x' = WmPure $ \x -> (Right x', delay x)----- | Inhibition handling interface. See also the--- "Control.Wire.Trans.Exhibit" and "Control.Wire.Prefab.Event" modules.--instance Monad m => ArrowError e (Wire e (Kleisli m)) where- raise = mkPureFix Left-- handle (WmPure f) wh'@(WmPure fh) =- WmPure $ \x' ->- let (mx, w) = f x' in- case mx of- Left ex ->- let (mxh, wh) = fh (x', ex)- in (mxh, handle w wh)- Right _ -> (mx, handle w wh')-- handle w' wh' =- WmGen $ \x' -> do- (mx, w) <- toGenM w' x'- case mx of- Left ex -> do- (mxh, wh) <- toGenM wh' (x', ex)- return (mxh, handle w wh)- Right _ -> return (mx, handle w wh')-- newError (WmPure f) = WmPure $ (Right *** newError) . f- newError (WmGen c) = WmGen $ liftM (Right *** newError) . c-- tryInUnless (WmPure f) ws'@(WmPure fs) we'@(WmPure fe) =- WmPure $ \x' ->- let (mx, w) = f x' in- case mx of- Left ex ->- let (mxe, we) = fe (x', ex)- in (mxe, tryInUnless w ws' we)- Right x ->- let (mxs, ws) = fs (x', x)- in (mxs, tryInUnless w ws we')-- tryInUnless w' ws' we' =- WmGen $ \x' -> do- (mx, w) <- toGenM w' x'- case mx of- Left ex -> do- (mxe, we) <- toGenM we' (x', ex)- return (mxe, tryInUnless w ws' we)- Right x -> do- (mxs, ws) <- toGenM ws' (x', x)- return (mxs, tryInUnless w ws we')----- | When the target arrow is an 'ArrowKleisli', then the wire arrow is--- also an ArrowKleisli.--instance Monad m => ArrowKleisli m (Wire e (Kleisli m)) where- arrM = mkFix (Right ^<< arrM)----- | Value recursion in the wire arrows. **NOTE**: Wires with feedback--- must *never* inhibit. There is an inherent, fundamental problem with--- handling the inhibition case, which you will observe as a fatal--- pattern match error.--instance (MonadFix m, Monoid e) => ArrowLoop (Wire e (Kleisli m)) where- loop w' =- WmGen $ \x' -> do- rec (mx, w) <- toGenM w' (x', d)- let d = either (error "Loop data dependency broken by inhibition") snd mx- return (fmap fst mx, loop w)----- | Combining possibly inhibiting wires.--instance (Monad m, Monoid e) => ArrowPlus (Wire e (Kleisli m)) where- WmGen c1 <+> w2'@(WmGen c2) =- WmGen $ \x' -> do- (mx1, w1) <- c1 x'- case mx1 of- Right _ -> return (mx1, w1 <+> w2')- Left ex1 -> do- (mx2, w2) <- c2 x'- return (mapLeft (mappend ex1) mx2, w1 <+> w2)-- WmGen c1 <+> w2'@(WmPure g) =- WmGen $ \x' -> do- (mx1, w1) <- c1 x'- case mx1 of- Right _ -> return (mx1, w1 <+> w2')- Left ex1 ->- let (mx2, w2) = g x' in- return (mapLeft (mappend ex1) mx2, w1 <+> w2)-- WmPure f <+> w2'@(WmGen c2) =- WmGen $ \x' ->- let (mx1, w1) = f x' in- case mx1 of- Right _ -> return (mx1, w1 <+> w2')- Left ex1 -> do- (mx2, w2) <- c2 x'- return (mapLeft (mappend ex1) mx2, w1 <+> w2)-- WmPure f <+> w2'@(WmPure g) =- WmPure $ \x' ->- let (mx1, w1) = f x'- (mx2, w2) = g x' in- case mx1 of- Right _ -> (mx1, w1 <+> w2')- Left ex1 -> (mapLeft (mappend ex1) mx2, w1 <+> w2)----- | If the underlying arrow is a reader arrow, then the wire arrow is--- also a reader arrow.--instance MonadReader r m => ArrowReader r (Wire e (Kleisli m)) where- readState = mkFixM (const (liftM Right ask))+-- | Event wires are wires that act like identity wires, but may inhibit+-- depending on whether a certain event has occurred. - newReader (WmPure f) = WmPure (second newReader . f . fst)- newReader (WmGen c) =- WmGen $ \(x', env) ->- liftM (second newReader) (local (const env) (c x'))+type Event e m a = Wire e m a a --- | If the underlying arrow is a state arrow, then the wire arrow is--- also a state arrow.+-- | 'WireP' equivalent of 'Event'. -instance MonadState s m => ArrowState s (Wire e (Kleisli m)) where- fetch = mkFixM (const (liftM Right get))- store = mkFixM (liftM Right . put)+type EventP a = WireP a a --- | Wire arrows are arrow transformers.+-- | 'WireM' equivalent of 'Event'. -instance Monad m => ArrowTransformer (Wire e) (Kleisli m) where- lift (Kleisli f) = mkFixM (liftM Right . f)+type EventM m a = WireM m a a --- | If the underlying arrow is a writer arrow, then the wire arrow is--- also a writer arrow.--instance MonadWriter w m => ArrowWriter w (Wire e (Kleisli m)) where- write = mkFixM (liftM Right . tell)+-- | Monoid for the last occurred exception. - newWriter (WmPure f) = WmPure ((fmap (, mempty) *** newWriter) . f)- newWriter (WmGen c) =- WmGen $ \x' -> do- ((mx, w), log) <- listen (c x')- return (fmap (, log) mx, newWriter w)+type LastException = Last SomeException --- | The always inhibiting wire. The @zeroArrow@ is equivalent to--- "Control.Wire.Prefab.Event.never".+-- | Monadic wires using 'LastException' as the inhibition monoid. -instance (Monad m, Monoid e) => ArrowZero (Wire e (Kleisli m)) where- zeroArrow = mkPureFix (const $ Left mempty)+type WireM = Wire LastException --- | Sequencing of wires.--instance Monad m => Category (Wire e (Kleisli m)) where- id = WmPure $ \x -> (Right x, id)-- w2'@(WmGen c2) . WmGen c1 =- WmGen $ \x'' -> do- (mx', w1) <- c1 x''- case mx' of- Left ex -> return (Left ex, w2' . w1)- Right x' -> do- (mx, w2) <- c2 x'- return (mx, w2 . w1)-- w2'@(WmGen c2) . WmPure g =- WmGen $ \(g -> (mx', w1)) -> do- case mx' of- Left ex -> return (Left ex, w2' . w1)- Right x' -> do- (mx, w2) <- c2 x'- return (mx, w2 . w1)-- w2'@(WmPure f) . WmGen c1 =- WmGen $ \x'' -> do- (mx', w1) <- c1 x''- return $- case mx' of- Left ex -> (Left ex, w2' . w1)- Right (f -> (mx, w2)) -> (mx, w2 . w1)+-- | Pure wires using 'LastException' as the inhibition monoid. - w2'@(WmPure f) . WmPure g =- WmPure $ \(g -> (mx', w1)) ->- case mx' of- Left ex -> (Left ex, w2' . w1)- Right (f -> (mx, w2)) -> (mx, w2 . w1)+type WireP = WireM Identity --- | Map a function over the output signal.+-- | Type-restricted identity wire. This is useful to specify the type+-- of a signal.+--+-- * Depends: current instant. -instance Monad m => Functor (Wire e (Kleisli m) a) where- fmap f (WmGen g) = WmGen (liftM (fmap f *** fmap f) . g)- fmap f (WmPure g) = WmPure ((fmap f *** fmap f) . g)+as :: (Monad m) => Proxy a -> Wire e m a a+as _ = id --- | Create a wire from the given transformation computation.--class Arrow (>~) => WireGen (>~) where- -- | Stateful variant.- mkGen :: (a >~ (Either e b, Wire e (>~) a b)) -> Wire e (>~) a b-- -- | Stateless variant.- mkFix :: Arrow (>~) => (a >~ Either e b) -> Wire e (>~) a b- mkFix c = let w = mkGen (arr (, w) . c) in w+-- | Utility to specify the input type of a wire. The argument is+-- ignored. For types with defaulting you might prefer 'inLike'.+--+-- > inAs (Proxy :: Proxy Double) highPeak -instance Monad m => WireGen (Kleisli m) where- mkGen (Kleisli c) = WmGen c- mkFix (Kleisli c) = let w = WmGen (liftM (, w) . c) in w+inAs :: Proxy a -> w a b -> w a b+inAs = const id --- | Monad-based wires.+-- | Utility to specify the input type of a wire. The first argument is+-- ignored. This is useful to make use of defaulting or when writing a+-- dummy value is actually shorter.+--+-- > inLike (0 :: Double) highPeak -type WireM e m = Wire e (Kleisli m)+inLike :: a -> w a b -> w a b+inLike = const id --- | Create a pure wire from the given transformation function.--class Arrow (>~) => WirePure (>~) where- -- | Stateful variant.- mkPure :: (a -> (Either e b, Wire e (>~) a b)) -> Wire e (>~) a b-- -- | Stateless variant.- mkPureFix :: (a -> Either e b) -> Wire e (>~) a b- mkPureFix f = let w = mkPure (\x -> (f x, w)) in w+-- | Type-restricted identity wire. This is useful to specify the type+-- of a signal. The argument is ignored.+--+-- * Depends: current instant. -instance Monad m => WirePure (Kleisli m) where- mkPure = WmPure+like :: (Monad m) => a -> Wire e m a a+like = const id --- | Convert the given wire to a generic arrow computation.--class WireToGen (>~) where- toGen :: Wire e (>~) a b -> (a >~ (Either e b, Wire e (>~) a b))+-- | Utility to specify the output type of a wire. The argument is+-- ignored. For types with defaulting you might prefer 'outLike'.+--+-- > outAs (Proxy :: Proxy Double) noiseM -instance Monad m => WireToGen (Kleisli m) where- toGen = Kleisli . toGenM+outAs :: Proxy b -> w a b -> w a b+outAs = const id --- | Turn an arbitrary exception to a wire exception.+-- | Utility to specify the output type of a wire. The first argument+-- is ignored. This is useful to make use of defaulting or when writing+-- a dummy value is actually shorter.+--+-- > outLike (0 :: Double) noiseM -inhibitException :: Ex.Exception e => e -> LastException-inhibitException = Last . Just . Ex.toException+outLike :: b -> w a b -> w a b+outLike = const id --- | Turn a string into a 'userError' exception wrapped by--- 'LastException'.+-- | 'Double' proxy for use with 'inAs' or 'outAs'. -inhibitMsg :: String -> LastException-inhibitMsg = inhibitException . userError+pDouble :: Proxy Double+pDouble = Proxy --- | Map a function over the input.+-- | 'Float' proxy for use with 'inAs' or 'outAs'. -mapInputM :: Monad m => (a' -> a) -> Wire e (Kleisli m) a b -> Wire e (Kleisli m) a' b-mapInputM f (WmPure g) = WmPure (second (mapInputM f) . g . f)-mapInputM f (WmGen g) = WmGen (liftM (second (mapInputM f)) . g . f)+pFloat :: Proxy Float+pFloat = Proxy --- | Map a function over the 'Left' value of an 'Either'.+-- | 'Int' proxy for use with 'inAs' or 'outAs'. -mapLeft :: (e' -> e) -> Either e' b -> Either e b-mapLeft f = either (Left . f) Right+pInt :: Proxy Int+pInt = Proxy --- | Create a stateless wire from the given monadic computation.+-- | 'Integer' proxy for use with 'inAs' or 'outAs'. -mkFixM ::- Monad m- => (a -> m (Either e b))- -> Wire e (Kleisli m) a b-mkFixM f = let w = WmGen (liftM (, w) . f) in w+pInteger :: Proxy Integer+pInteger = Proxy --- | Convert the given wire to a generic monadic computation.+-- | 'String' proxy for use with 'inAs' or 'outAs'. -toGenM ::- Monad m- => Wire e (Kleisli m) a b -- ^ Wire to convert.- -> a -- ^ Input value.- -> m (Either e b, Wire e (Kleisli m) a b)-toGenM (WmGen c) = c-toGenM (WmPure f) = (return . f)+pString :: Proxy String+pString = Proxy
+ Control/Wire/Wire.hs view
@@ -0,0 +1,348 @@+-- |+-- Module: Control.Wire.Wire+-- Copyright: (c) 2012 Ertugrul Soeylemez+-- License: BSD3+-- Maintainer: Ertugrul Soeylemez <es@ertes.de>+--+-- This is the core module implementing the 'Wire' type.++module Control.Wire.Wire+ ( -- * Wires+ Wire(..),+ Time,+ -- ** Constructing wires+ mkFix,+ mkFixM,+ mkGen,+ mkPure,+ mkState,+ mkStateM,+ -- ** Simple predefined wires+ constant,+ identity,+ never,+ -- ** Helper functions+ mapOutput,++ -- * Stepping+ stepWire,+ stepWireP+ )+ where++import qualified Data.Bifunctor as Bi+import Control.Applicative+import Control.Arrow+import Control.Category+import Control.Monad+import Control.Monad.Fix+import Control.Monad.Identity+import Data.AdditiveGroup+import Data.AffineSpace+import Data.Cross+import Data.Monoid+import Data.Profunctor+import Data.String+import Data.VectorSpace+import Prelude hiding ((.), id)+++-- | Time.++type Time = Double+++-- | A wire is a signal function from an input value of type @a@ that+-- either /produces/ an output value of type @b@ or /inhibits/ with a+-- value of type @e@. The underlying monad is @m@.++data Wire e m a b+ = WGen (Time -> a -> m (Either e b, Wire e m a b))+ | WPure (Time -> a -> (Either e b, Wire e m a b))++instance (AdditiveGroup b, Monad m) => AdditiveGroup (Wire e m a b) where+ zeroV = pure zeroV+ (^+^) = liftA2 (^+^)+ negateV = fmap negateV++instance (AdditiveGroup (Diff b), AffineSpace b, Monad m) => AffineSpace (Wire e m a b) where+ type Diff (Wire e m a b) = Wire e m a (Diff b)+ (.-.) = liftA2 (.-.)+ (.+^) = liftA2 (.+^)++instance (Monad m, Monoid e) => Alternative (Wire e m a) where+ empty = mkFix (const . const $ Left mempty)++ (<|>) = loop 0+ where+ loop !t2 (WPure f1) w2'@(WPure f2) =+ mkPure $ \dt x' ->+ let (mx1, w1) = f1 dt x' in+ case mx1 of+ Left ex1 ->+ let (mx2, w2) = f2 (t2 + dt) x' in+ (Bi.first (mappend ex1) mx2, loop 0 w1 w2)+ Right _ -> (mx1, loop (t2 + dt) w1 w2')++ loop !t2 w1' w2' =+ mkGen $ \dt x' -> do+ (mx1, w1) <- stepWire w1' dt x'+ case mx1 of+ Left ex1 -> do+ (mx2, w2) <- stepWire w2' (t2 + dt) x'+ return (Bi.first (mappend ex1) mx2, loop 0 w1 w2)+ Right _ -> return (mx1, loop (t2 + dt) w1 w2')++instance (Monad m) => Applicative (Wire e m a) where+ pure = constant++ (<*>) = loop 0+ where+ loop !tx (WPure ff) wx'@(WPure fx) =+ mkPure $ \dt x' ->+ let (mf, wf) = ff dt x' in+ case mf of+ Right f ->+ let (mx, wx) = fx (tx + dt) x' in+ (fmap f mx, loop 0 wf wx)+ Left ex -> (Left ex, loop (tx + dt) wf wx')++ loop !tx wf' wx' =+ mkGen $ \dt x' -> do+ (mf, wf) <- stepWire wf' dt x'+ case mf of+ Right f -> do+ (mx, wx) <- stepWire wx' (tx + dt) x'+ return (fmap f mx, loop 0 wf wx)+ Left ex -> return (Left ex, loop (tx + dt) wf wx')++instance (Monad m) => Arrow (Wire e m) where+ arr f = mkFix (const $ Right . f)+ first w = liftA2 (,) (lmap fst w) (arr snd)+ second w = liftA2 (,) (arr fst) (lmap snd w)+ (&&&) = liftA2 (,)+ w1 *** w2 = liftA2 (,) (lmap fst w1) (lmap snd w2)++instance (Monad m) => ArrowChoice (Wire e m) where+ (|||) = loop 0 0+ where+ loop !tl !tr wl' wr' =+ mkGen $ \dt ->+ either (\x' -> do+ (mx, wl) <- stepWire wl' (tl + dt) x'+ return (mx, loop 0 (tr + dt) wl wr'))+ (\x' -> do+ (mx, wr) <- stepWire wr' (tr + dt) x'+ return (mx, loop (tl + dt) 0 wl' wr))++ w1 +++ w2 = fmap Left w1 ||| fmap Right w2++ left = loop 0+ where+ loop !tl wl' =+ mkGen $ \dt ->+ either (liftM (fmap Left *** loop 0) . stepWire wl' (tl + dt))+ (\x -> return (Right (Right x), loop (tl + dt) wl'))++ right = loop 0+ where+ loop !tr wr' =+ mkGen $ \dt ->+ either (\x -> return (Right (Left x), loop (tr + dt) wr'))+ (liftM (fmap Right *** loop 0) . stepWire wr' (tr + dt))++instance (MonadFix m) => ArrowLoop (Wire e m) where+ loop w' =+ mkGen $ \dt x' ->+ liftM (fmap fst *** loop) .+ mfix $ \(mx, _) ->+ let feedbackErr = error "Feedback loop broken by inhibition" in+ stepWire w' dt (x', either feedbackErr snd mx)++instance (Monad m, Monoid e) => ArrowPlus (Wire e m) where+ (<+>) = (<|>)++instance (Monad m, Monoid e) => ArrowZero (Wire e m) where+ zeroArrow = empty++instance (Monad m) => Category (Wire e m) where+ id = identity++ (.) = loop 0+ where+ loop !t2 w2'@(WPure f2) (WPure f1) =+ mkPure $ \dt x'' ->+ let (mx', w1) = f1 dt x'' in+ case mx' of+ Right x' ->+ let (mx, w2) = f2 (t2 + dt) x' in+ (mx, loop 0 w2 w1)+ Left ex -> (Left ex, loop (t2 + dt) w2' w1)++ loop !t2 w2' w1' =+ mkGen $ \dt x'' -> do+ (mx', w1) <- stepWire w1' dt x''+ case mx' of+ Right x' -> do+ (mx, w2) <- stepWire w2' (t2 + dt) x'+ return (mx, loop 0 w2 w1)+ Left ex -> return (Left ex, loop (t2 + dt) w2' w1)++instance (Floating b, Monad m) => Floating (Wire e m a b) where+ pi = pure pi+ sqrt = fmap sqrt++ (**) = liftA2 (**)+ exp = fmap exp+ log = fmap log+ logBase = liftA2 logBase++ cos = fmap cos; sin = fmap sin; tan = fmap tan+ acos = fmap acos; asin = fmap asin; atan = fmap atan++ cosh = fmap cosh; sinh = fmap sinh; tanh = fmap tanh+ acosh = fmap acosh; asinh = fmap asinh; atanh = fmap atanh++instance (Fractional b, Monad m) => Fractional (Wire e m a b) where+ (/) = liftA2 (/)+ fromRational = pure . fromRational+ recip = fmap recip++instance (Monad m) => Functor (Wire e m a) where+ fmap = mapOutput . fmap++instance (HasCross2 b, Monad m) => HasCross2 (Wire e m a b) where+ cross2 = fmap cross2++instance (HasCross3 b, Monad m) => HasCross3 (Wire e m a b) where+ cross3 = liftA2 cross3++instance (HasNormal b, Monad m) => HasNormal (Wire e m a b) where+ normalVec = fmap normalVec++instance (InnerSpace b, Monad m) => InnerSpace (Wire e m a b) where+ (<.>) = liftA2 (<.>)++instance (Monad m, Num b) => Num (Wire e m a b) where+ (+) = liftA2 (+)+ (-) = liftA2 (-)+ (*) = liftA2 (*)++ abs = fmap abs+ signum = fmap signum+ fromInteger = pure . fromInteger++instance (IsString b, Monad m) => IsString (Wire e m a b) where+ fromString = pure . fromString++instance (Monad m, Monoid b) => Monoid (Wire e m a b) where+ mempty = pure mempty+ mappend = liftA2 mappend++instance (Monad m) => Profunctor (Wire e m) where+ lmap f (WPure g) = WPure (\dt -> second (lmap f) . g dt . f)+ lmap f (WGen g) = WGen (\dt -> liftM (second (lmap f)) . g dt . f)++ rmap = fmap++instance (Monad m, Read b) => Read (Wire e m a b) where+ readsPrec n = map (first pure) . readsPrec n++instance (Monad m, VectorSpace b) => VectorSpace (Wire e m a b) where+ type Scalar (Wire e m a b) = Wire e m a (Scalar b)+ (*^) = liftA2 (*^)+++-- | Variant of 'pure' without the 'Monad' constraint. Using 'pure' is+-- preferable.++constant :: b -> Wire e m a b+constant = mkFix . const . const . Right+++-- | Variant of 'id' without the 'Monad' constraint. Using 'id' is+-- preferable.++identity :: Wire e m a a+identity = WPure (\_ x -> (Right x, identity))+++-- | Map the given function over the raw wire output.++mapOutput :: (Monad m) => (Either e b' -> Either e b) -> Wire e m a b' -> Wire e m a b+mapOutput f (WGen g) = WGen (\dt -> liftM (f *** mapOutput f) . g dt)+mapOutput f (WPure g) = WPure (\dt -> (f *** mapOutput f) . g dt)+++-- | Construct a pure stateless wire from the given function.++mkFix :: (Time -> a -> Either e b) -> Wire e m a b+mkFix f = let w = mkPure (\dt -> (, w) . f dt) in w+++-- | Construct a stateless effectful wire from the given function.++mkFixM :: (Monad m) => (Time -> a -> m (Either e b)) -> Wire e m a b+mkFixM f = let w = mkGen (\dt -> liftM (, w) . f dt) in w+++-- | Construct an effectful wire from the given function.++mkGen :: (Time -> a -> m (Either e b, Wire e m a b)) -> Wire e m a b+mkGen = WGen+++-- | Construct a pure wire from the given function.++mkPure :: (Time -> a -> (Either e b, Wire e m a b)) -> Wire e m a b+mkPure = WPure+++-- | Construct a pure wire from the given local state transision+-- function.++mkState ::+ s+ -> (Time -> (a, s) -> (Either e b, s))+ -> Wire e m a b+mkState s0 f = loop s0+ where+ loop s' =+ mkPure $ \dt x' ->+ let (mx, s) = f dt (x', s') in+ (mx, loop s)+++-- | Construct a monadic wire from the given local state transision+-- function.++mkStateM ::+ (Monad m)+ => s+ -> (Time -> (a, s) -> m (Either e b, s))+ -> Wire e m a b+mkStateM s0 f = loop s0+ where+ loop s' =+ mkGen $ \dt x' -> liftM (second loop) (f dt (x', s'))+++-- | Variant of 'empty' without the 'Monad' constraint. Using 'empty'+-- is preferable.++never :: (Monoid e) => Wire e m a b+never = mkFix . const . const $ Left mempty+++-- | Perform an instant of the given wire.++stepWire :: (Monad m) => Wire e m a b -> Time -> a -> m (Either e b, Wire e m a b)+stepWire (WGen f) dt = f dt+stepWire (WPure f) dt = return . f dt+++-- | Perform an instant of the given pure wire.++stepWireP :: Wire e Identity a b -> Time -> a -> (Either e b, Wire e Identity a b)+stepWireP (WGen f) dt = runIdentity . f dt+stepWireP (WPure f) dt = f dt
LICENSE view
@@ -1,5 +1,5 @@ Netwire license-Copyright (c) 2011, Ertugrul Soeylemez+Copyright (c) 2012, Ertugrul Soeylemez All rights reserved.
Setup.lhs view
@@ -1,5 +1,5 @@ Netwire setup script-Copyright (C) 2011, Ertugrul Soeylemez+Copyright (C) 2012, Ertugrul Soeylemez Please see the LICENSE file for terms and conditions of use, modification and distribution of this package, including this file.
netwire.cabal view
@@ -1,97 +1,90 @@ Name: netwire-Version: 3.1.0+Version: 4.0.0 Category: Control, FRP-Synopsis: Fast generic automaton arrow transformer for AFRP+Synopsis: Flexible wire arrows for FRP Maintainer: Ertugrul Söylemez <es@ertes.de> Author: Ertugrul Söylemez <es@ertes.de>-Copyright: (c) 2011 Ertugrul Söylemez+Copyright: (c) 2012 Ertugrul Söylemez License: BSD3 License-file: LICENSE Build-type: Simple Stability: experimental-Cabal-version: >= 1.8+Cabal-version: >= 1.10 Description:- This library implements a fast and powerful generic automaton arrow- transformer for arrowized functional reactive programming or- automaton programming in general.+ Efficient and flexible wire arrows for functional reactive programming+ and other forms of locally stateful programming. +Source-repository head+ type: darcs+ location: http://darcs.ertes.de/netwire/+ Library Build-depends:- arrows >= 0.4.4,- base >= 4 && < 5,- containers >= 0.4.0,- deepseq >= 1.1.0,- lifted-base >= 0.1.0,- monad-control >= 0.3.0,- random >= 1.0.0,- time >= 1.2.0,- mtl >= 2.0.1,- stm >= 2.2.0,- vector >= 0.9,- vector-space >= 0.7.8- Extensions:- Arrows- DoRec+ base >= 4.0 && < 5,+ bifunctors >= 0.1 && < 4,+ containers >= 0.4 && < 1,+ deepseq >= 1.3 && < 2,+ lifted-base >= 0.1 && < 1,+ monad-control >= 0.3 && < 1,+ mtl >= 2.0 && < 3,+ profunctors >= 0.1 && < 4,+ random >= 1.0 && < 2,+ semigroups >= 0.8 && < 1,+ tagged >= 0.4 && < 1,+ time >= 1.4 && < 2,+ vector >= 0.9 && < 1,+ vector-space >= 0.8 && < 1+ Default-language: Haskell2010+ Default-extensions:+ BangPatterns+ DeriveDataTypeable FlexibleContexts FlexibleInstances- FunctionalDependencies- GADTs MultiParamTypeClasses RankNTypes ScopedTypeVariables TupleSections TypeFamilies- TypeOperators- UndecidableInstances- ViewPatterns GHC-Options: -W Exposed-modules: Control.Wire Control.Wire.Classes- Control.Wire.Instances Control.Wire.Prefab Control.Wire.Prefab.Accum Control.Wire.Prefab.Analyze- Control.Wire.Prefab.Calculus- Control.Wire.Prefab.Clock+ Control.Wire.Prefab.Effect Control.Wire.Prefab.Event- Control.Wire.Prefab.Execute+ Control.Wire.Prefab.Move+ Control.Wire.Prefab.Noise Control.Wire.Prefab.Queue- Control.Wire.Prefab.Random Control.Wire.Prefab.Sample Control.Wire.Prefab.Simple- Control.Wire.Prefab.Split+ Control.Wire.Prefab.Time Control.Wire.Session Control.Wire.TimedMap- Control.Wire.Tools Control.Wire.Trans- Control.Wire.Trans.Clock Control.Wire.Trans.Combine- Control.Wire.Trans.Exhibit- Control.Wire.Trans.Fork- Control.Wire.Trans.Memoize- Control.Wire.Trans.Sample+ Control.Wire.Trans.Embed+ Control.Wire.Trans.Event Control.Wire.Trans.Simple+ Control.Wire.Trans.Switch+ Control.Wire.Trans.Time Control.Wire.Types+ Control.Wire.Wire --- Executable netwire2-test+-- Executable netwire-test -- Build-depends:--- arrows, -- base >= 4 && < 5, -- containers,--- logict,--- mtl, -- netwire, -- random, -- time--- Extensions:+-- Default-language: Haskell2010+-- Default-extensions: -- Arrows--- FlexibleInstances--- MultiParamTypeClasses--- ScopedTypeVariables+-- DoRec+-- OverloadedStrings -- TupleSections--- TypeFamilies--- ViewPatterns -- Hs-source-dirs: test -- Main-is: Main.hs -- GHC-Options: -threaded -rtsopts