netwire 1.2.7 → 2.0.0
raw patch · 36 files changed
+2070/−2323 lines, 36 filesdep +arrowsdep −mersenne-randomdep −monad-controldep −stmdep ~basedep ~vectordep ~vector-space
Dependencies added: arrows
Dependencies removed: mersenne-random, monad-control, stm
Dependency ranges changed: base, vector, vector-space
Files
- Control/Wire.hs +31/−0
- Control/Wire/Classes.hs +65/−0
- Control/Wire/Instances.hs +54/−0
- Control/Wire/Prefab.hs +33/−0
- Control/Wire/Prefab/Accum.hs +58/−0
- Control/Wire/Prefab/Analyze.hs +212/−0
- Control/Wire/Prefab/Calculus.hs +67/−0
- Control/Wire/Prefab/Clock.hs +61/−0
- Control/Wire/Prefab/Event.hs +293/−0
- Control/Wire/Prefab/Queue.hs +57/−0
- Control/Wire/Prefab/Random.hs +62/−0
- Control/Wire/Prefab/Sample.hs +51/−0
- Control/Wire/Prefab/Simple.hs +80/−0
- Control/Wire/Prefab/Split.hs +59/−0
- Control/Wire/Session.hs +60/−0
- Control/Wire/Tools.hs +34/−0
- Control/Wire/Trans.hs +21/−0
- Control/Wire/Trans/Combine.hs +104/−0
- Control/Wire/Trans/Exhibit.hs +47/−0
- Control/Wire/Trans/Sample.hs +115/−0
- Control/Wire/Trans/Simple.hs +48/−0
- Control/Wire/Types.hs +415/−0
- FRP/NetWire.hs +0/−68
- FRP/NetWire/Analyze.hs +0/−193
- FRP/NetWire/Calculus.hs +0/−59
- FRP/NetWire/Event.hs +0/−304
- FRP/NetWire/IO.hs +0/−41
- FRP/NetWire/Pure.hs +0/−29
- FRP/NetWire/Random.hs +0/−103
- FRP/NetWire/Request.hs +0/−240
- FRP/NetWire/Session.hs +0/−222
- FRP/NetWire/Switch.hs +0/−190
- FRP/NetWire/Tools.hs +0/−409
- FRP/NetWire/Wire.hs +0/−425
- LICENSE +1/−1
- netwire.cabal +42/−39
+ Control/Wire.hs view
@@ -0,0 +1,31 @@+-- |+-- Module: Control.Wire+-- Copyright: (c) 2011 Ertugrul Soeylemez+-- License: BSD3+-- Maintainer: Ertugrul Soeylemez <es@ertes.de>+--+-- Convenience module for the Netwire library.++module Control.Wire+ ( -- * 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,++ -- * Convenience+ module Control.Arrow.Operations,+ module Control.Arrow.Transformer+ )+ where++import Control.Arrow.Operations+import Control.Arrow.Transformer+import Control.Wire.Classes+import Control.Wire.Prefab+import Control.Wire.Session+import Control.Wire.Tools+import Control.Wire.Trans+import Control.Wire.Types
+ Control/Wire/Classes.hs view
@@ -0,0 +1,65 @@+-- |+-- Module: Control.Wire.Classes+-- Copyright: (c) 2011 Ertugrul Soeylemez+-- License: BSD3+-- Maintainer: Ertugrul Soeylemez <es@ertes.de>+--+-- Type classes used in Netwire.++module Control.Wire.Classes+ ( -- * Various effects+ ArrowClock(..),+ ArrowIO(..),+ ArrowRandom(..)+ )+ where++import Control.Arrow+import Control.Monad.IO.Class+import Data.Time.Clock.POSIX+import System.Random+++-- | Arrows with a clock.++class Arrow (>~) => ArrowClock (>~) where+ -- | Type for time values.+ type Time (>~)++ -- | Current time in some arrow-specific frame of reference.+ arrTime :: a >~ Time (>~)+++-- | Instance for the system time. Use this only for testing. This is+-- intentionally specific to allow you to define better instances with+-- custom arrows.++instance ArrowClock (Kleisli IO) where+ type Time (Kleisli IO) = Double+ arrTime = Kleisli (const $ fmap realToFrac getPOSIXTime)+++-- | Arrows which support running IO computations.++class Arrow (>~) => ArrowIO (>~) where+ -- | Run the input IO computation and output its result.+ arrIO :: IO b >~ b++instance MonadIO m => ArrowIO (Kleisli m) where+ arrIO = Kleisli liftIO+++-- | Arrows with support for random number generation.++class Arrow (>~) => ArrowRandom (>~) where+ -- | Return a random number.+ arrRand :: Random b => a >~ b++ -- | Return a random number in the input range.+ arrRandR :: Random b => (b, b) >~ b++-- | Instance for the 'IO'-builtin 'StdGen'.++instance ArrowRandom (Kleisli IO) where+ arrRand = Kleisli (const randomIO)+ arrRandR = Kleisli randomRIO
+ Control/Wire/Instances.hs view
@@ -0,0 +1,54 @@+-- |+-- 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
@@ -0,0 +1,33 @@+-- |+-- Module: Control.Wire.Prefab+-- Copyright: (c) 2011 Ertugrul Soeylemez+-- License: BSD3+-- Maintainer: Ertugrul Soeylemez <es@ertes.de>+--+-- Convenience module importing all 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.Event,+ 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+ )+ 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.Event+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
+ Control/Wire/Prefab/Accum.hs view
@@ -0,0 +1,58 @@+-- |+-- Module: Control.Wire.Prefab.Accum+-- Copyright: (c) 2011 Ertugrul Soeylemez+-- License: BSD3+-- Maintainer: Ertugrul Soeylemez <es@ertes.de>+--+-- Wires for signal accumulation.++module Control.Wire.Prefab.Accum+ ( -- * General accumulator+ accum,++ -- * Special accumulators+ countFrom,+ countStep,++ -- * Specific instances+ atFirst+ )+ where++import Control.Wire.Prefab.Simple+import Control.Wire.Types+++-- | 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.+--+-- * Depends: current instant.++accum :: a -> Wire e (>~) (a -> a) a+accum x =+ mkPure $ \f -> x `seq` (Right x, accum (f x))+++-- | Apply the given function at the first instant. Then act as the+-- identity wire forever.+--+-- * Depends: Current instant.++atFirst :: (b -> b) -> Wire e (>~) b b+atFirst f = mkPure $ \x -> (Right (f x), identity)+++-- | Count upwards from the given starting value.++countFrom :: Enum b => b -> Wire e (>~) a b+countFrom n = mkPure $ \_ -> n `seq` (Right n, countFrom (succ n))+++-- | Count from the given starting value, repeatedly adding the input+-- signal to it.+--+-- * Depends: current instant.++countStep :: Num a => a -> Wire e (>~) a a+countStep x = mkPure $ \dx -> x `seq` (Right x, countStep (x + dx))
+ Control/Wire/Prefab/Analyze.hs view
@@ -0,0 +1,212 @@+-- |+-- Module: Control.Wire.Prefab.Analyze+-- Copyright: (c) 2011 Ertugrul Soeylemez+-- License: BSD3+-- Maintainer: Ertugrul Soeylemez <es@ertes.de>+--+-- Various signal analysis tools++module Control.Wire.Prefab.Analyze+ ( -- * Statistics+ -- ** Average+ avg,+ avgAll,+ avgFps,+ -- ** Peak+ highPeak,+ lowPeak,+ peakBy,++ -- * 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.Classes+import Control.Wire.Prefab.Clock+import Control.Wire.Types+import Data.Map (Map)+import Data.Monoid+import Data.Set (Set)+++-- | 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.+--+-- * Depends: current instant.++avg :: forall e v (>~). (Arrow (>~), Fractional v, Vu.Unbox v) => Int -> Wire e (>~) v v+avg n = mkPure $ \x -> (Right x, avg' (Vu.replicate n (x/d)) x 0)+ where+ avg' :: Vu.Vector v -> v -> Int -> Wire e (>~) v v+ avg' samples' s' cur' =+ mkPure $ \((/d) -> x) ->+ let cur = let cur = succ cur' in if cur >= n then 0 else cur+ x' = samples' Vu.! cur+ samples =+ x' `seq` runST $ do+ s <- Vu.unsafeThaw samples'+ Vum.write s cur x+ Vu.unsafeFreeze s+ s = s' - x' + x+ in cur `seq` s' `seq` (Right s, avg' samples s cur)++ d :: 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.+--+-- * Depends: current instant.++avgAll :: forall e v (>~). (Arrow (>~), Fractional v) => Wire e (>~) v v+avgAll = mkPure $ \x -> (Right x, avgAll' 1 x)+ where+ avgAll' :: v -> v -> Wire e (>~) v v+ avgAll' n' a' =+ mkPure $ \x ->+ let n = n' + 1+ a = a' - a'/n + x/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.+--+-- Please note that this wire uses the clock from the 'ArrowClock'+-- instance for the underlying arrow. If this clock doesn't represent+-- real time, then the output of this wire won't either.++avgFps ::+ (ArrowChoice (>~), ArrowClock (>~), Fractional t, Time (>~) ~ t, Vu.Unbox t)+ => Int+ -> Wire e (>~) a t+avgFps n = recip ^<< avg n <<< dtime+++-- | Collects all distinct inputs ever received.+--+-- * Complexity: O(n) space, O(log n) time wrt collected inputs so far.+--+-- * Depends: current instant.++collect :: forall b e (>~). Ord b => Wire e (>~) b (Set b)+collect = collect' S.empty+ where+ collect' :: Set b -> Wire e (>~) b (Set b)+ collect' ins' =+ mkPure $ \x ->+ let ins = S.insert x ins'+ in (Right ins, collect' ins)+++-- | Outputs the last input value on every change of the input signal.+-- Acts like the identity wire at the first instant.+--+-- * Depends: current instant.+--+-- * Inhibits: on no change after the first instant.++diff :: forall b e (>~). (Eq b, Monoid e) => Wire e (>~) b b+diff =+ mkPure $ \x -> (Right x, diff' x)++ where+ diff' :: b -> Wire e (>~) b b+ diff' x' =+ mkPure $ \x ->+ if x' == x+ then (Left mempty, diff' x')+ else (Right x', diff' x)+++-- | Reports the first time the given input was seen.+--+-- * Complexity: O(n) space, O(log n) time wrt collected inputs so far.+--+-- * Depends: Current instant.++firstSeen ::+ forall a e t (>~). (ArrowChoice (>~), ArrowClock (>~), Monoid e, Ord a, Time (>~) ~ t)+ => Wire e (>~) a t+firstSeen = firstSeen' M.empty+ where+ firstSeen' :: Map a t -> Wire e (>~) a t+ firstSeen' xs' =+ fix $ \again ->+ mkGen $ proc x' -> do+ case M.lookup x' xs' of+ Just t -> returnA -< (Right t, again)+ Nothing -> do+ t <- arrTime -< ()+ returnA -< (Right t, firstSeen' (M.insert x' t xs'))+++-- | Outputs the high peak of the input signal.+--+-- * Depends: Current instant.++highPeak :: Ord b => Wire e (>~) b b+highPeak = peakBy compare+++-- | Reports the last time the given input was seen. Inhibits when+-- seeing a signal for the first time.+--+-- * Complexity: O(n) space, O(log n) time wrt collected inputs so far.+--+-- * Depends: Current instant.+--+-- * Inhibits: On first sight of a signal.++lastSeen ::+ forall a e t (>~). (ArrowClock (>~), Monoid e, Ord a, Time (>~) ~ t)+ => Wire e (>~) a t+lastSeen = lastSeen' M.empty+ where+ lastSeen' :: Map a t -> Wire e (>~) a t+ lastSeen' xs' =+ mkGen $ proc x' -> do+ t <- arrTime -< ()+ let xs = M.insert x' t xs'+ returnA -< (maybe (Left mempty) Right $ M.lookup x' xs',+ lastSeen' xs)+++-- | Outputs the low peak of the input signal.+--+-- * Depends: Current instant.++lowPeak :: Ord b => Wire e (>~) b b+lowPeak = peakBy (flip compare)+++-- | Outputs the high peak of the input signal with respect to the given+-- comparison function.+--+-- * Depends: Current instant.++peakBy :: forall b e (>~). (b -> b -> Ordering) -> Wire e (>~) b b+peakBy comp = mkPure (Right &&& peakBy')+ where+ peakBy' :: b -> Wire e (>~) b b+ peakBy' x'' =+ mkPure $ \x' ->+ Right &&& peakBy' $ if comp x' x'' == GT then x' else x''
+ Control/Wire/Prefab/Calculus.hs view
@@ -0,0 +1,67 @@+-- |+-- 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.Arrow+import Control.Wire.Classes+import Control.Wire.Types+import Data.VectorSpace+++-- | Integrate over time.+--+-- * Depends: Current instant.++integral ::+ forall e t v (>~).+ (ArrowClock (>~), Num t, Scalar v ~ t, Time (>~) ~ t, VectorSpace v)+ => v -> Wire e (>~) v v+integral x0 =+ mkGen $ proc _ -> do+ t <- arrTime -< ()+ returnA -< (Right x0, integral' x0 t)++ where+ integral' :: v -> t -> Wire e (>~) v v+ integral' x0 t' =+ mkGen $ proc dx -> do+ t <- arrTime -< ()+ let dt = t - t'+ let x1 = x0 ^+^ (dx ^* dt)+ returnA -< x0 `seq` (Right x0, integral' x1 t)+++-- | Calculates the derivative of the input signal over time.+--+-- * Depends: Current instant.++derivative ::+ forall e t v (>~).+ (ArrowClock (>~), Fractional t, Scalar v ~ t, Time (>~) ~ t, VectorSpace v)+ => Wire e (>~) v v+derivative =+ mkGen $ proc x0 -> do+ t <- arrTime -< ()+ returnA -< (Right zeroV, deriv' x0 t)++ where+ deriv' :: v -> t -> Wire e (>~) v v+ deriv' x0 t' =+ mkGen $ proc x1 -> do+ t <- arrTime -< ()+ let dt = t - t'+ let dx = (x1 ^-^ x0) ^/ dt+ returnA -< x0 `seq` (Right dx, deriv' x1 t)
+ Control/Wire/Prefab/Clock.hs view
@@ -0,0 +1,61 @@+-- |+-- 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,+ dtimeFrom,+ time,+ timeFrom,+ timeOffset+ )+ where++import Control.Arrow+import Control.Wire.Classes+import Control.Wire.Types+++-- | Time deltas starting from the first instant.++dtime :: (ArrowClock (>~), Time (>~) ~ t, Num t) => Wire e (>~) a t+dtime =+ mkGen $ proc _ -> do+ t <- arrTime -< ()+ returnA -< (Right 0, dtimeFrom t)+++-- | Time deltas starting from the given instant.++dtimeFrom :: (ArrowClock (>~), Time (>~) ~ t, Num t) => t -> Wire e (>~) a t+dtimeFrom t' =+ mkGen $ proc _ -> do+ t <- arrTime -< ()+ let dt = t - t'+ returnA -< t' `seq` (Right dt, dtimeFrom t)+++-- | Current time with the given origin at the first instant.++timeFrom :: (ArrowClock (>~), Time (>~) ~ t, Num t) => t -> Wire e (>~) a t+timeFrom t0 =+ mkGen $ proc _ -> do+ t <- arrTime -< ()+ returnA -< t0 `seq` (Right t0, timeOffset (t0 - t))+++-- | Current time with the given offset.++timeOffset :: (ArrowClock (>~), Time (>~) ~ t, Num t) => t -> Wire e (>~) a t+timeOffset offset = mkFix $ proc _ -> Right . (+ offset) ^<< arrTime -< ()+++-- | Current time with origin 0 at the first instant.++time :: (ArrowClock (>~), Time (>~) ~ t, Num t) => Wire e (>~) a t+time = timeFrom 0
+ Control/Wire/Prefab/Event.hs view
@@ -0,0 +1,293 @@+-- |+-- Module: Control.Wire.Prefab.Event+-- Copyright: (c) 2011 Ertugrul Soeylemez+-- License: BSD3+-- Maintainer: Ertugrul Soeylemez <es@ertes.de>+--+-- Wires for generating and manipulating events.++module Control.Wire.Prefab.Event+ ( -- * Event generation+ -- ** Timed+ after,+ at,+ delayEvents,+ delayEventsSafe,+ periodically,+ -- ** Unconditional inhibition+ inhibit,+ never,+ -- ** Predicate-based+ asSoonAs,+ edge,+ require,+ forbid,+ while,+ -- ** Instant-based+ notYet,+ once+ )+ where++import qualified Data.Map as M+import qualified Data.Sequence as S+import Control.Arrow+import Control.Monad.Fix+import Control.Wire.Classes+import Control.Wire.Prefab.Simple+import Control.Wire.Types+import Data.Monoid+import Data.Map (Map)+import Data.Sequence (Seq, ViewL(..), (><))+++-- | Produces once after the input time delta has passed.+--+-- * Depends: Current instant.+--+-- * Inhibits: Always except at the target instant.++after ::+ forall e t (>~).+ (ArrowClock (>~), Monoid e, Num t, Ord t, Time (>~) ~ t)+ => Wire e (>~) t ()+after =+ mkGen $ proc dt -> do+ t0 <- arrTime -< ()+ returnA -<+ if dt <= 0+ then (Right (), never)+ else (Left mempty, after' t0)++ where+ after' :: t -> Wire e (>~) t ()+ after' t0 =+ fix $ \again ->+ mkGen $ proc dt -> do+ t <- arrTime -< ()+ returnA -<+ if t - t0 >= dt+ then (Right (), never)+ else (Left mempty, again)+++-- | Produces once as soon as the current time is later than or equal to+-- the current time and never again.+--+-- * Depends: Current instant.+--+-- * Inhibits: Always except at the target instant.++at :: (ArrowClock (>~), Monoid e, Ord t, Time (>~) ~ t) => Wire e (>~) t ()+at =+ mkGen $ proc tt -> do+ t <- arrTime -< ()+ returnA -<+ if t >= tt+ then (Right (), never)+ else (Left mempty, at)+++-- | 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 ::+ forall b e t (>~).+ (ArrowClock (>~), Monoid e, Num t, Ord t, Time (>~) ~ t)+ => Wire e (>~) ([b], t) b+delayEvents = delayEvents' M.empty+ where+ delayEvents' :: Map t (Seq b) -> Wire e (>~) ([b], t) b+ delayEvents' devs' =+ mkGen $ proc (evs, dt) -> do+ t <- arrTime -< ()+ let devs | null evs = devs'+ | otherwise = M.insertWith' (><) (t + dt) (S.fromList evs) devs'+ returnA -<+ devs `seq`+ case M.minViewWithKey devs of+ Nothing -> (Left mempty, delayEvents' devs)+ Just ((tt, revs), restMap)+ | tt > t -> (Left mempty, delayEvents' devs)+ | 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))+++-- | 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 ::+ forall b e t (>~).+ (ArrowClock (>~), Monoid e, Num t, Ord t, Time (>~) ~ t)+ => Wire e (>~) (([b], t), Int) b+delayEventsSafe = delayEvents' 0 M.empty+ where+ delayEvents' :: Int -> Map t (Seq b) -> Wire e (>~) (([b], t), Int) b+ delayEvents' curNum' devs' =+ mkGen $ proc ((evs, dt), maxNum) -> do+ t <- arrTime -< ()+ let addSeq = S.fromList evs+ (curNum, devs) =+ if null evs || curNum' >= maxNum+ then (curNum', devs')+ else (curNum' + S.length addSeq,+ M.insertWith' (><) (t + dt) addSeq devs')+ returnA -<+ case M.minViewWithKey devs of+ Nothing -> (Left mempty, delayEvents' curNum devs)+ Just ((tt, revs), restMap)+ | tt > t -> (Left mempty, delayEvents' curNum devs)+ | 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))+++-- | Inhibits as long as the input signal is 'False'. Once it switches+-- to 'True', it produces forever.+--+-- * Depends: Current instant.+--+-- * Inhibits: As long as input signal is 'False', then never again.++asSoonAs :: Monoid e => Wire e (>~) Bool ()+asSoonAs =+ mkPure $ \b ->+ if b then (Right (), constant ()) else (Left mempty, asSoonAs)+++-- | Produces once whenever the input signal switches from 'False' to+-- 'True'.+--+-- * Depends: Current instant.+--+-- * Inhibits: Always except at the above mentioned instants.++edge :: forall e (>~). Monoid e => Wire e (>~) Bool ()+edge =+ mkPure $ \b ->+ if b then (Right (), switchBack) else (Left mempty, edge)++ where+ switchBack :: Wire e (>~) Bool ()+ switchBack = mkPure $ \b -> (Left mempty, if b then switchBack else edge)+++-- | Produces, whenever the current input signal is 'False'.+--+-- * Depends: Current instant.+--+-- * Inhibits: When input is 'True'.++forbid :: Monoid e => Wire e (>~) Bool ()+forbid = mkPureFix (\b -> if b then Left mempty else Right ())+++-- | Never produces. Always inhibits with the current input signal.+--+-- * Depends: Current instant.+--+-- * Inhibits: Always.++inhibit :: Wire e (>~) e b+inhibit = mkPureFix Left+++-- | Never produces. Equivalent to 'zeroArrow'.+--+-- * Inhibits: Always.++never :: Monoid e => Wire e (>~) a b+never = mkPureFix (const (Left mempty))+++-- | Inhibit at the first instant. Then produce forever.+--+-- * Inhibits: At the first instant.++notYet :: Monoid e => Wire e (>~) b b+notYet = mkPure (const (Left mempty, identity))+++-- | Acts like the identity function once and never again.+--+-- * Inhibits: After the first instant.++once :: Monoid e => Wire e (>~) b b+once = mkPure $ \x -> (Right x, never)+++-- | 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.+--+-- * Depends: Current instant.+--+-- * Inhibits: Always except at the periodic ticks.++periodically ::+ forall e t (>~).+ (ArrowClock (>~), Monoid e, Num t, Ord t, Time (>~) ~ t)+ => Wire e (>~) t ()+periodically =+ mkGen $ proc dt -> do+ t <- arrTime -< ()+ returnA -< (if dt <= 0 then Right () else Left mempty, periodically' t)++ where+ periodically' :: t -> Wire e (>~) t ()+ periodically' t0 =+ mkGen $ proc dt -> do+ t <- arrTime -< ()+ returnA -<+ let tt = t0 + dt in+ if tt <= t+ then (Right (), periodically' tt)+ else (Left mempty, periodically' t0)+++-- | Produces, whenever the current input signal is 'True'.+--+-- * Depends: Current instant.+--+-- * Inhibits: When input is 'False'.++require :: Monoid e => Wire e (>~) Bool ()+require = mkPureFix (\b -> if b then Right () else Left mempty)+++-- | Produce as long as the input signal is 'True'. Once it switches to+-- 'False', never produce again. Corresponds to 'takeWhile' for lists.+--+-- * Depends: Current instant.+--+-- * Inhibits: As soon as input becomes 'False'.++while :: Monoid e => Wire e (>~) Bool ()+while =+ mkPure $ \b ->+ if b then (Right (), while) else (Left mempty, never)
+ Control/Wire/Prefab/Queue.hs view
@@ -0,0 +1,57 @@+-- |+-- Module: Control.Wire.Prefab.Queue+-- Copyright: (c) 2011 Ertugrul Soeylemez+-- License: BSD3+-- Maintainer: Ertugrul Soeylemez <es@ertes.de>+--+-- Various wires for queuing.++module Control.Wire.Prefab.Queue+ ( -- * Signal dams+ fifo,+ lifo+ )+ where++import qualified Data.Sequence as S+import Control.Wire.Types+import Data.Monoid+import Data.Sequence (Seq, 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.+--+-- * Depends: current instant.+--+-- * Inhibits: when the queue is empty.++fifo :: forall a e (>~). Monoid e => Wire e (>~) [a] a+fifo = fifo' 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)+++-- | Queues incoming signals and acts as a dam outputting incoming+-- signals in a LIFO fashion (stack). Note: Incorrect usage can lead to+-- congestion.+--+-- * Depends: current instant.+--+-- * Inhibits: when the queue is empty.++lifo :: forall a e (>~). Monoid e => Wire e (>~) [a] a+lifo = lifo' S.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)
+ Control/Wire/Prefab/Random.hs view
@@ -0,0 +1,62 @@+-- |+-- 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.Wire.Classes+import Control.Wire.Types+import System.Random+++-- | Generate random noise.++noise :: (ArrowRandom (>~), Random b) => Wire e (>~) a b+noise = mkFix $ arr Right <<< arrRand+++-- | Generate random noise in range 0 <= x < 1.++noiseF :: ArrowRandom (>~) => Wire e (>~) a Double+noiseF = noise+++-- | Generate random noise in range -1 <= x < 1.++noiseF1 :: ArrowRandom (>~) => Wire e (>~) a Double+noiseF1 = mkFix (arr (Right . (*2) . pred) <<< arrRand)+++-- | Generate random noise in a certain range given by the input signal.+--+-- * Depends: Current instant.++noiseR :: (ArrowRandom (>~), Random b) => Wire e (>~) (b, b) b+noiseR = mkFix $ arr Right <<< arrRandR+++-- | Generate a random boolean, where the input signal is the+-- probability to be 'True'.+--+-- * Depends: Current instant.++wackelkontakt :: ArrowRandom (>~) => Wire e (>~) Double Bool+wackelkontakt =+ mkFix $ proc p -> do+ s <- arrRand -< ()+ returnA -< Right (not (s >= p))
+ Control/Wire/Prefab/Sample.hs view
@@ -0,0 +1,51 @@+-- |+-- Module: Control.Wire.Prefab.Sample+-- Copyright: (c) 2011 Ertugrul Soeylemez+-- License: BSD3+-- Maintainer: Ertugrul Soeylemez <es@ertes.de>+--+-- Signal sampling wires.++module Control.Wire.Prefab.Sample+ ( -- * Simple samplers+ discrete,+ keep+ )+ where++import Control.Arrow+import Control.Wire.Classes+import Control.Wire.Prefab.Simple+import Control.Wire.Types+++-- | Sample the right signal at discrete intervals given by the left+-- input signal.+--+-- * Depends: Current instant (left), last sampling instant (right).++discrete ::+ forall b e t (>~). (ArrowClock (>~), Num t, Ord t, Time (>~) ~ t)+ => Wire e (>~) (t, b) b+discrete =+ mkGen $ proc (_, x) -> do+ t <- arrTime -< ()+ returnA -< (Right x, discrete' t x)++ where+ discrete' :: t -> b -> Wire e (>~) (t, b) b+ discrete' t' x0 =+ mkGen $ proc (dt, x) -> do+ t <- arrTime -< ()+ returnA -<+ if (t - t' >= dt)+ then (Right x, discrete' t x)+ else (Right x0, discrete' t' x0)+++-- | Keep the signal in the first instant forever.+--+-- * Depends: First instant.++keep :: Wire e (>~) b b+keep = mkPure $ \x -> (Right x, constant x)
+ Control/Wire/Prefab/Simple.hs view
@@ -0,0 +1,80 @@+-- |+-- Module: Control.Wire.Prefab.Simple+-- Copyright: (c) 2011 Ertugrul Soeylemez+-- License: BSD3+-- Maintainer: Ertugrul Soeylemez <es@ertes.de>+--+-- Basic wires.++module Control.Wire.Prefab.Simple+ ( -- * Simple predefined wires.+ constant,+ identity,++ -- * Forced reduction+ force,+ forceNF,++ -- * Inject signals+ inject,+ injectEvent+ )+ where++import Control.DeepSeq+import Control.Wire.Types+import Data.Monoid+++-- | The constant wire. Outputs the given value all the time.++constant :: b -> Wire e (>~) a b+constant x = x `seq` mkPureFix (Right . const x)+++-- | Force the input signal to weak head normal form, before outputting+-- it. Applies 'seq' to the input signal.+--+-- * Depends: Current instant.++force :: Wire e (>~) b b+force = mkPureFix $ \x -> x `seq` Right x+++-- | Force the input signal to normal form, before outputting it.+-- Applies 'deepseq' to the input signal.+--+-- * Depends: Current instant.++forceNF :: NFData b => Wire e (>~) b b+forceNF = mkPureFix $ \x -> x `deepseq` Right x+++-- | The identity wire. Outputs its input signal unchanged.+--+-- * Depends: Current instant.++identity :: Wire e (>~) a a+identity = mkPureFix (Right $!)+++-- | Inject the given 'Either' value as a signal. 'Left' means+-- inhibition.+--+-- * Depends: Current instant.+--+-- * Inhibits: When input is 'Left'.++inject :: Wire e (>~) (Either e b) b+inject = mkPureFix id+++-- | Inject the given 'Maybe' value as a signal. 'Nothing' means+-- inhibition.+--+-- * Depends: Current instant.+--+-- * Inhibits: When input is 'Nothing'.++injectEvent :: Monoid e => Wire e (>~) (Maybe b) b+injectEvent = mkPureFix (maybe (Left mempty) Right)
+ Control/Wire/Prefab/Split.hs view
@@ -0,0 +1,59 @@+-- |+-- Module: Control.Wire.Prefab.Split+-- Copyright: (c) 2011 Ertugrul Soeylemez+-- License: BSD3+-- Maintainer: Ertugrul Soeylemez <es@ertes.de>+--+-- Wires for splitting and terminating computations.++module Control.Wire.Prefab.Split+ ( -- * Simple splitters+ fork,++ -- * Simple terminators+ quit,+ quitWith+ )+ where++import Control.Arrow+import Control.Wire.Types+import Data.Monoid+++-- | Takes the input list and forks the wire for each value. Also forks+-- a single inhibiting wire. Warning: Incorrect usage will cause space+-- leaks! Use with care!+--+-- * Depends: Current instant+--+-- * Inhibits: Always in one thread, never in all others.+--+-- * Threads: Length of input list + 1.++fork :: (ArrowChoice (>~), ArrowPlus (>~), Monoid e) => Wire e (>~) [b] b+fork = mkFix fork'+ where+ fork' = proc xs' ->+ case xs' of+ [] -> returnA -< Left mempty+ (x:xs) -> arr (Right . fst) <+> (fork' <<^ snd) -< (x, xs)+++-- | Terminates the current wire with no output.+--+-- * Threads: None.++quit :: ArrowZero (>~) => Wire e (>~) a b+quit = mkGen zeroArrow+++-- | Terminates the current wire thread with the given input value as+-- the last output.+--+-- * Depends: Current instant.+--+-- * Threads: 1, then none.++quitWith :: ArrowZero (>~) => Wire e (>~) b b+quitWith = mkGen $ arr (\x -> (Right x, quit))
+ Control/Wire/Session.hs view
@@ -0,0 +1,60 @@+-- |+-- Module: Control.Wire.Session+-- Copyright: (c) 2011 Ertugrul Soeylemez+-- License: BSD3+-- Maintainer: Ertugrul Soeylemez <es@ertes.de>+--+-- Wire sessions, i.e. running and/or testing wires.++module Control.Wire.Session+ ( -- * Running wires+ stepWire,++ -- * Testing wires+ testWire+ )+ where++import Control.Arrow+import Control.Monad+import Control.Wire.Classes+import Control.Wire.Types+import System.IO+++-- | Performs an instant of the given wire.++stepWire ::+ Arrow (>~)+ => Wire e (>~) a b -- ^ Wire to step.+ -> (a >~ (Either e b, Wire e (>~) a b))+stepWire = toGen+++-- | Test a wire. This function runs the given wire continuously+-- printing its output on a single line.++testWire ::+ forall a e (>~). (ArrowApply (>~), ArrowIO (>~), Show e)+ => Int -- ^ Frames per output. FPS/accuracy tradeoff.+ -> (() >~ a) -- ^ Input generator.+ -> (Wire e (>~) a String >~ ())+testWire int getInput =+ proc w' -> loop -< (int, w')++ 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++ inp <- getInput -< ()+ (mstr, w) <- stepWire w' -<< inp++ arrIO -<+ when (n' == 0) $ do+ putStr "\r\027[K"+ putStr (either (("Inhibited: " ++) . show) id mstr)+ hFlush stdout++ loop -< (n, w)
+ Control/Wire/Tools.hs view
@@ -0,0 +1,34 @@+-- |+-- 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+ )+ 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+++-- | 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
@@ -0,0 +1,21 @@+-- |+-- Module: Control.Wire.Trans+-- Copyright: (c) 2011 Ertugrul Soeylemez+-- License: BSD3+-- Maintainer: Ertugrul Soeylemez <es@ertes.de>+--+-- Wire transformers.++module Control.Wire.Trans+ ( -- * Reexports+ module Control.Wire.Trans.Combine,+ module Control.Wire.Trans.Exhibit,+ module Control.Wire.Trans.Sample,+ module Control.Wire.Trans.Simple+ )+ where++import Control.Wire.Trans.Combine+import Control.Wire.Trans.Exhibit+import Control.Wire.Trans.Sample+import Control.Wire.Trans.Simple
+ Control/Wire/Trans/Combine.hs view
@@ -0,0 +1,104 @@+-- |+-- Module: Control.Wire.Trans.Combine+-- Copyright: (c) 2011 Ertugrul Soeylemez+-- License: BSD3+-- Maintainer: Ertugrul Soeylemez <es@ertes.de>+--+-- Wire transformers for combining wires.++module Control.Wire.Trans.Combine+ ( -- * Context-sensitive evolution+ context,+ contextLimit,++ -- * Distribute+ distribute+ )+ where++import qualified Data.Map as M+import qualified Data.Set as S+import Control.Arrow+import Control.Wire.Classes+import Control.Wire.Tools+import Control.Wire.Types+import Data.Either+import Data.Map (Map)+import Data.Set (Set)+++-- | Make the given wire context-sensitive. The right signal is a+-- context and the wire will evolve individually for each context.+--+-- * Depends: Like context wire (left), current instant (right).+-- * Inhibits: Like context wire.++context ::+ forall a b e k (>~).+ (ArrowApply (>~), ArrowChoice (>~), Ord k)+ => Wire e (>~) a b -> Wire e (>~) (a, k) b+context w0 = context' M.empty+ where+ context' :: Map k (Wire e (>~) a b) -> Wire e (>~) (a, k) b+ context' ctxs' =+ mkGen $ proc (x', ctx) -> do+ let w' = M.findWithDefault w0 ctx ctxs'+ (mx, w) <- toGen w' -<< x'+ let ctxs = M.insert ctx w ctxs'+ returnA -< (mx, context' ctxs)+++-- | 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.++contextLimit ::+ forall a b e k t (>~).+ (ArrowApply (>~), ArrowClock (>~), Num t, Ord k, Ord t, Time (>~) ~ t)+ => Wire e (>~) a b -> Wire e (>~) ((a, k), t) b+contextLimit w0 = context' M.empty M.empty+ where+ context' ::+ Map k (Wire e (>~) a b, t)+ -> Map t (Set k)+ -> Wire e (>~) ((a, k), t) b+ context' ctxs'' hist'' =+ mkGen $ proc ((x', ctx), maxAge) -> do+ t <- arrTime -< ()+ let (w', t') = M.findWithDefault (w0, t) ctx ctxs''+ (mx, w) <- toGen w' -<< x'++ let ctxs' = M.insert ctx (w, t) ctxs''+ hist' =+ M.insertWith' S.union t (S.singleton ctx) .+ M.update (\s' -> let s = S.delete ctx s'+ in if S.null s then Nothing else Just s) t' $+ hist''++ (ctxs, hist) =+ let (delMap, hist) = M.split (t - maxAge) hist'+ dels = M.fromDistinctAscList . map (, ()) .+ S.toAscList . S.unions . M.elems $ delMap+ in (ctxs' M.\\ dels, hist)+ returnA -< (mx, context' ctxs hist)+++-- | Distribute the input signal over the given wires, evolving each of+-- them individually. Collects produced outputs.+--+-- Note: This wire transformer discards all inhibited signals.+--+-- * Depends: as strict as the strictest subwire.++distribute ::+ ArrowApply (>~) =>+ [Wire e (>~) a b] -> Wire e (>~) a [b]+distribute ws' =+ mkGen $ proc x' -> do+ (mxs, ws) <-+ first rights . unzip ^<<+ distA (map toGen ws') -<< x'+ returnA -< (Right mxs, distribute ws)
+ Control/Wire/Trans/Exhibit.hs view
@@ -0,0 +1,47 @@+-- |+-- 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+ event,+ exhibit+ )+ where++import Control.Arrow+import Control.Wire.Types+++-- | Produces 'Just', whenever the argument wire produces, otherwise+-- 'Nothing'.+--+-- * Depends: like argument wire.++event :: Arrow (>~) => Wire e (>~) a b -> Wire e (>~) a (Maybe b)+event (WPure f) =+ mkPure $ \(f -> (mx, w)) ->+ (Right $ either (const Nothing) Just mx, event w)+event (WGen c) =+ mkGen $ proc x' -> do+ (mx, w) <- c -< x'+ returnA -< (Right $ either (const Nothing) Just mx, event w)+++-- | Produces 'Right', whenever the argument wire produces, otherwise+-- 'Left' with the inhibition value.+--+-- * Depends: like argument wire.++exhibit :: Arrow (>~) => Wire e (>~) a b -> Wire e (>~) a (Either e b)+exhibit (WPure f) =+ mkPure $ \(f -> (mx, w)) ->+ (Right mx, exhibit w)+exhibit (WGen c) =+ mkGen $ proc x' -> do+ (mx, w) <- c -< x'+ returnA -< (Right mx, exhibit w)
+ Control/Wire/Trans/Sample.hs view
@@ -0,0 +1,115 @@+-- |+-- 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+ hold,+ holdWith,+ sample,+ swallow+ )+ where++import Control.Arrow+import Control.Wire.Classes+import Control.Wire.Prefab.Simple+import Control.Wire.Types+++-- | Keeps the latest produced value.+--+-- * Depends: Like argument wire.+-- * Inhibits: Until first production.++hold :: Arrow (>~) => Wire e (>~) a b -> Wire e (>~) a b+hold (WPure f) =+ mkPure $ \x' ->+ let (mx, w) = f x' in+ case mx of+ Left ex -> (Left ex, hold w)+ Right x -> (Right x, holdWith x w)+hold (WGen c) =+ mkGen $ proc x' -> do+ (mx, w) <- c -< x'+ returnA -<+ case mx of+ Left ex -> (Left ex, hold w)+ Right x -> (Right x, holdWith x w)+++-- | Keeps the latest produced value. Produces the argument value until+-- the argument wire starts producing.+--+-- * Depends: Like argument wire.++holdWith :: Arrow (>~) => b -> Wire e (>~) a b -> Wire e (>~) a b+holdWith x0 (WPure f) =+ mkPure $ \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 (WGen c) =+ mkGen $ proc x' -> do+ (mx, w) <- c -< x'+ returnA -<+ case mx of+ Left _ -> (Right x0, holdWith x0 w)+ Right x -> (Right x, holdWith x w)+++-- | Samples the given wire at discrete intervals. Only runs the input+-- through the wire, then the next sampling interval has elapsed.+--+-- * Depends: Current instant (left), like argument wire at sampling+-- intervals (right).+-- * Inhibits: Starts inhibiting when argument wire inhibits. Keeps+-- inhibiting until next sampling interval.++sample ::+ forall a b e t (>~).+ (ArrowChoice (>~), ArrowClock (>~), Num t, Ord t, Time (>~) ~ t)+ => Wire e (>~) a b+ -> Wire e (>~) (a, t) b+sample w' =+ mkGen $ proc (x', _) -> do+ t <- arrTime -< ()+ (mx, w) <- toGen w' -< x'+ returnA -< (mx, sample' t mx w)++ where+ sample' :: t -> Either e b -> Wire e (>~) a b -> Wire e (>~) (a, t) b+ sample' t' mx0 w' =+ mkGen $ proc (x', dt) -> do+ t <- arrTime -< ()+ if t - t' < dt+ then returnA -< (mx0, sample' t' mx0 w')+ else do+ (mx, w) <- toGen w' -< x'+ returnA -< (mx, sample' t mx 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.++swallow :: ArrowChoice (>~) => Wire e (>~) a b -> Wire e (>~) a b+swallow (WPure f) =+ mkPure $ \x' ->+ case f x' of+ (Left ex, w) -> (Left ex, swallow w)+ (Right x, _) -> (Right x, constant x)+swallow (WGen c) =+ mkGen $ proc x' -> do+ (mx, w) <- c -< x'+ case mx of+ Left ex -> returnA -< (Left ex, swallow w)+ Right x -> returnA -< (Right x, constant x)
+ Control/Wire/Trans/Simple.hs view
@@ -0,0 +1,48 @@+-- |+-- Module: Control.Wire.Trans.Simple+-- Copyright: (c) 2011 Ertugrul Soeylemez+-- License: BSD3+-- Maintainer: Ertugrul Soeylemez <es@ertes.de>+--+-- Simple wire transformers.++module Control.Wire.Trans.Simple+ ( -- * Override input+ (--<),+ (>--)+ )+ where++import Control.Arrow+import Control.Wire.Types+++-- | 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+WPure f --< g =+ mkPure $ \x' ->+ let (mx, w) = f (g x') in+ (mx, either (const $ w --< g) (const w) mx)+WGen c --< g =+ mkGen $ proc x' -> do+ (mx, w) <- c -< g x'+ returnA -< (mx, either (const $ w --< g) (const w) mx)++infixr 5 --<+++-- | Apply the given function to the input, until the argument wire+-- starts producing.+--+-- * Depends: Like argument wire.+-- * Inhibits: Like argument wire.++(>--) :: Arrow (>~) => (a -> a) -> Wire e (>~) a b -> Wire e (>~) a b+(>--) = flip (--<)++infixl 5 >--
+ Control/Wire/Types.hs view
@@ -0,0 +1,415 @@+-- |+-- Module: Control.Wire.Types+-- Copyright: (c) 2011 Ertugrul Soeylemez+-- License: BSD3+-- Maintainer: Ertugrul Soeylemez <es@ertes.de>+--+-- Types used in the netwire library.++module Control.Wire.Types+ ( -- * The wire+ Wire(..),++ -- * Smart construction+ mkFix,+ mkGen,+ mkPure,+ mkPureFix,++ -- * Destruction+ toGen+ )+ 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.Wire.Classes+import Data.Monoid+import Prelude hiding ((.), id)+++-- | Signal networks.++data Wire e (>~) a b where+ WGen :: !(a >~ (Either e b, Wire e (>~) a b)) -> Wire e (>~) a b+ WPure :: !(a -> (Either e b, Wire e (>~) a b)) -> Wire e (>~) a b+++-- | Wire side channels.++instance ArrowChoice (>~) => Arrow (Wire e (>~)) where+ arr f = mkPureFix $ Right . f++ first (WGen c) =+ WGen $ proc (x', y) -> do+ (mx, w) <- c -< x'+ returnA -< (fmap (, y) mx, first w)+ first (WPure f) =+ WPure $ \(x', y) ->+ let (mx, w) = f x'+ in (fmap (, y) mx, first w)++ second (WGen c) =+ WGen $ proc (x, y') -> do+ (my, w) <- c -< y'+ returnA -< (fmap (x,) my, second w)+ second (WPure f) =+ WPure $ \(x, y') ->+ let (my, w) = f y'+ in (fmap (x,) my, second w)++ -- (&&&) combinator.+ WGen c1 &&& w2'@(WGen c2) =+ WGen $ proc x' -> do+ (mx1, w1) <- c1 -< x'+ case mx1 of+ Left ex -> returnA -< (Left ex, w1 &&& w2')+ Right x1 -> do+ (mx2, w2) <- c2 -< x'+ returnA -< (fmap (x1,) mx2, w1 &&& w2)++ WGen c1 &&& w2'@(WPure g) =+ WGen $ proc x' -> do+ (mx1, w1) <- c1 -< x'+ case mx1 of+ Left ex -> returnA -< (Left ex, w1 &&& w2')+ Right x1 ->+ let (mx2, w2) = g x' in+ returnA -< (fmap (x1,) mx2, w1 &&& w2)++ WPure f &&& w2'@(WGen c2) =+ WGen $ proc x' ->+ let (mx1, w1) = f x' in+ case mx1 of+ Left ex -> returnA -< (Left ex, w1 &&& w2')+ Right x1 -> do+ (mx2, w2) <- c2 -< x'+ returnA -< (fmap (x1,) mx2, w1 &&& w2)++ WPure f &&& w2'@(WPure g) =+ WPure $ \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.+ WGen c1 *** w2'@(WGen c2) =+ WGen $ proc (x', y') -> do+ (mx, w1) <- c1 -< x'+ case mx of+ Left ex -> returnA -< (Left ex, w1 *** w2')+ Right x -> do+ (my, w2) <- c2 -< y'+ returnA -< (fmap (x,) my, w1 *** w2)++ WGen c1 *** w2'@(WPure g) =+ WGen $ proc (x', g -> (my, w2)) -> do+ (mx, w1) <- c1 -< x'+ case mx of+ Left ex -> returnA -< (Left ex, w1 *** w2')+ Right x -> returnA -< (fmap (x,) my, w1 *** w2)++ WPure f *** w2'@(WGen c2) =+ WGen $ proc (f -> (mx, w1), y') -> do+ case mx of+ Left ex -> returnA -< (Left ex, w1 *** w2')+ Right x -> do+ (my, w2) <- c2 -< y'+ returnA -< (fmap (x,) my, w1 *** w2)++ WPure f *** w2'@(WPure g) =+ WPure $ \(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 ArrowChoice (>~) => ArrowChoice (Wire e (>~)) where+ left w'@(WPure f) =+ WPure $ \mx' ->+ case mx' of+ Left x' -> fmap Left *** left $ f x'+ Right x' -> (Right (Right x'), left w')++ left w'@(WGen c) =+ WGen $ proc mx' ->+ case mx' of+ Left x' -> (fmap Left *** left) ^<< c -< x'+ Right x' -> returnA -< (Right (Right x'), left w')++ right w'@(WPure f) =+ WPure $ \mx' ->+ case mx' of+ Right x' -> fmap Right *** right $ f x'+ Left x' -> (Right (Left x'), right w')++ right w'@(WGen c) =+ WGen $ proc mx' ->+ case mx' of+ Right x' -> (fmap Right *** right) ^<< c -< x'+ Left x' -> returnA -< (Right (Left x'), right w')++ wl'@(WPure f) +++ wr'@(WPure g) =+ WPure $ \mx' ->+ case mx' of+ Left x' -> (fmap Left *** (+++ wr')) . f $ x'+ Right x' -> (fmap Right *** (wl' +++)) . g $ x'++ wl' +++ wr' =+ WGen $ proc mx' ->+ case mx' of+ Left x' -> arr (fmap Left *** (+++ wr')) . toGen wl' -< x'+ Right x' -> arr (fmap Right *** (wl' +++)) . toGen wr' -< x'++ wl'@(WPure f) ||| wr'@(WPure g) =+ WPure $ \mx' ->+ case mx' of+ Left x' -> second (||| wr') . f $ x'+ Right x' -> second (wl' |||) . g $ x'++ wl' ||| wr' =+ WGen $ proc mx' ->+ case mx' of+ Left x' -> arr (second (||| wr')) . toGen wl' -< x'+ Right x' -> arr (second (wl' |||)) . toGen wr' -< x'+++-- | Support for one-instant delays.++instance (ArrowChoice (>~), ArrowLoop (>~)) => ArrowCircuit (Wire e (>~)) where+ delay x' = mkPure $ \x -> (Right x', delay x)+++-- | Inhibition handling interface. See also the+-- "Control.Wire.Trans.Exhibit" and "Control.Wire.Prefab.Event" modules.++instance ArrowChoice (>~) => ArrowError e (Wire e (>~)) where+ raise = mkPureFix Left++ handle (WPure f) wh'@(WPure fh) =+ WPure $ \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' =+ WGen $ proc x' -> do+ (mx, w) <- toGen w' -< x'+ case mx of+ Left ex -> do+ (mxh, wh) <- toGen wh' -< (x', ex)+ returnA -< (mxh, handle w wh)+ Right _ -> returnA -< (mx, handle w wh')++ newError (WPure f) = WPure $ (Right *** newError) . f+ newError (WGen c) = WGen $ arr (Right *** newError) . c++ tryInUnless (WPure f) ws'@(WPure fs) we'@(WPure fe) =+ WPure $ \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' =+ WGen $ proc x' -> do+ (mx, w) <- toGen w' -< x'+ case mx of+ Left ex -> do+ (mxe, we) <- toGen we' -< (x', ex)+ returnA -< (mxe, tryInUnless w ws' we)+ Right x -> do+ (mxs, ws) <- toGen ws' -< (x', x)+ returnA -< (mxs, tryInUnless w ws we')+++-- | When the target arrow is an 'ArrowIO' (e.g. a Kleisli arrow over+-- IO), then the wire arrow is also an @ArrowIO@.++instance (Applicative f, ArrowChoice (>~), ArrowIO (>~)) =>+ ArrowIO (Wire (f Ex.SomeException) (>~)) where+ arrIO = mkFix $ arr (mapLeft pure) <<< arrIO <<< arr Ex.try+++-- | 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 (ArrowChoice (>~), ArrowLoop (>~)) => ArrowLoop (Wire e (>~)) where+ loop w' =+ WGen $ proc x' -> do+ rec (Right (x, d), w) <- toGen w' -< (x', d)+ returnA -< (Right x, loop w)+++-- | Combining possibly inhibiting wires.++instance (ArrowChoice (>~), Monoid e) => ArrowPlus (Wire e (>~)) where+ WGen c1 <+> w2'@(WGen c2) =+ WGen $ proc x' -> do+ (mx1, w1) <- c1 -< x'+ case mx1 of+ Right _ -> returnA -< (mx1, w1 <+> w2')+ Left ex1 -> do+ (mx2, w2) <- c2 -< x'+ returnA -< (mapLeft (mappend ex1) mx2, w1 <+> w2)++ WGen c1 <+> w2'@(WPure g) =+ WGen $ proc x' -> do+ (mx1, w1) <- c1 -< x'+ case mx1 of+ Right _ -> returnA -< (mx1, w1 <+> w2')+ Left ex1 ->+ let (mx2, w2) = g x' in+ returnA -< (mapLeft (mappend ex1) mx2, w1 <+> w2)++ WPure f <+> w2'@(WGen c2) =+ WGen $ proc x' ->+ let (mx1, w1) = f x' in+ case mx1 of+ Right _ -> returnA -< (mx1, w1 <+> w2')+ Left ex1 -> do+ (mx2, w2) <- c2 -< x'+ returnA -< (mapLeft (mappend ex1) mx2, w1 <+> w2)++ WPure f <+> w2'@(WPure g) =+ WPure $ \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 (ArrowChoice (>~), ArrowReader r (>~)) => ArrowReader r (Wire e (>~)) where+ readState = lift readState++ newReader (WPure f) = WPure (second newReader . f . fst)+ newReader (WGen c) = WGen $ arr (second newReader) . newReader c+++-- | If the underlying arrow is a state arrow, then the wire arrow is+-- also a state arrow.++instance (ArrowChoice (>~), ArrowState s (>~)) => ArrowState s (Wire e (>~)) where+ fetch = lift fetch+ store = lift store+++-- | Wire arrows are arrow transformers.++instance ArrowChoice (>~) => ArrowTransformer (Wire e) (>~) where+ lift c = mkFix $ Right ^<< c+++-- | If the underlying arrow is a writer arrow, then the wire arrow is+-- also a writer arrow.++instance (ArrowChoice (>~), ArrowWriter w (>~)) => ArrowWriter w (Wire e (>~)) where+ write = lift write++ newWriter (WPure f) = WPure ((fmap (, mempty) *** newWriter) . f)+ newWriter (WGen c) =+ WGen $ arr (\((mx, w), log) ->+ (fmap (, log) mx, newWriter w)) .+ newWriter c+++-- | The always inhibiting wire. The @zeroArrow@ is equivalent to+-- "Control.Wire.Prefab.Event.never".++instance (ArrowChoice (>~), Monoid e) => ArrowZero (Wire e (>~)) where+ zeroArrow = mkPureFix (const $ Left mempty)+++-- | Sequencing of wires.++instance ArrowChoice (>~) => Category (Wire e (>~)) where+ id = arr id++ w2'@(WGen c2) . WGen c1 =+ WGen $ proc x'' -> do+ (mx', w1) <- c1 -< x''+ case mx' of+ Left ex -> returnA -< (Left ex, w2' . w1)+ Right x' -> do+ (mx, w2) <- c2 -< x'+ returnA -< (mx, w2 . w1)++ w2'@(WGen c2) . WPure g =+ WGen $ proc (g -> (mx', w1)) -> do+ case mx' of+ Left ex -> returnA -< (Left ex, w2' . w1)+ Right x' -> do+ (mx, w2) <- c2 -< x'+ returnA -< (mx, w2 . w1)++ w2'@(WPure f) . WGen c1 =+ WGen $ proc x'' -> do+ (mx', w1) <- c1 -< x''+ case mx' of+ Left ex -> returnA -< (Left ex, w2' . w1)+ Right (f -> (mx, w2)) -> returnA -< (mx, w2 . w1)++ w2'@(WPure f) . WPure g =+ WPure $ \(g -> (mx', w1)) ->+ case mx' of+ Left ex -> (Left ex, w2' . w1)+ Right (f -> (mx, w2)) -> (mx, w2 . w1)+++-- | Maps over the left side of an 'Either' value.++mapLeft :: (e' -> e) -> Either e' a -> Either e a+mapLeft f (Left x) = Left (f x)+mapLeft _ (Right x) = Right x+++-- | Create a wire from the given stateless transformation computation.++mkFix :: Arrow (>~) => (a >~ Either e b) -> Wire e (>~) a b+mkFix c = let w = WGen (arr (, w) . c) in w+++-- | Create a wire from the given transformation computation.++mkGen :: (a >~ (Either e b, Wire e (>~) a b)) -> Wire e (>~) a b+mkGen = WGen+++-- | Create a pure wire from the given transformation function.++mkPure :: (a -> (Either e b, Wire e (>~) a b)) -> Wire e (>~) a b+mkPure = WPure+++-- | Create a pure wire from the given transformation function.++mkPureFix :: (a -> Either e b) -> Wire e (>~) a b+mkPureFix f = let w = WPure ((, w) . f) in w+++-- | Convert the given wire to a generic arrow computation.++toGen :: Arrow (>~) => Wire e (>~) a b -> (a >~ (Either e b, Wire e (>~) a b))+toGen (WGen c) = c+toGen (WPure f) = arr f
− FRP/NetWire.hs
@@ -1,68 +0,0 @@--- |--- Module: FRP.NetWire--- Copyright: (c) 2011 Ertugrul Soeylemez--- License: BSD3--- Maintainer: Ertugrul Soeylemez <es@ertes.de>------ Arrowized FRP implementation for networking applications. The aim of--- this library is to provide a convenient FRP implementation, which--- should enable you to write entirely pure network sessions.--module FRP.NetWire- ( -- * Wires- Wire, Output, Time,- WireState(..),- mkGen, toGen,-- -- * Reactive sessions- Session,- stepWire,- stepWireDelta,- stepWireTime,- withWire,-- -- * Testing wires- testWire,- testWireStr,-- -- * Pure wires- SF,- stepSF,- stepWirePure,-- -- * Inhibition- InhibitException(..),- inhibitEx,- noEvent,-- -- * Netwire Reexports- module FRP.NetWire.Analyze,- module FRP.NetWire.Calculus,- module FRP.NetWire.Event,- module FRP.NetWire.IO,- module FRP.NetWire.Random,- module FRP.NetWire.Request,- module FRP.NetWire.Switch,- module FRP.NetWire.Tools,-- -- * Other convenience reexports- module Control.Monad.IO.Class,- module Control.Monad.IO.Control,- module Data.Functor.Identity- )- where--import Control.Monad.IO.Class-import Control.Monad.IO.Control-import Data.Functor.Identity-import FRP.NetWire.Analyze-import FRP.NetWire.Calculus-import FRP.NetWire.Event-import FRP.NetWire.IO-import FRP.NetWire.Pure-import FRP.NetWire.Random-import FRP.NetWire.Request-import FRP.NetWire.Session-import FRP.NetWire.Switch-import FRP.NetWire.Tools-import FRP.NetWire.Wire
− FRP/NetWire/Analyze.hs
@@ -1,193 +0,0 @@--- |--- Module: FRP.NetWire.Analyze--- Copyright: (c) 2011 Ertugrul Soeylemez--- License: BSD3--- Maintainer: Ertugrul Soeylemez <es@ertes.de>------ Signal analysis.--module FRP.NetWire.Analyze- ( -- * Changes- diff,-- -- * Statistics- -- ** Average- avg,- avgAll,- avgFps,-- -- ** Misc- collect,- lastSeen,-- -- ** Peak- highPeak,- lowPeak,- peakBy- )- where--import qualified Data.Map as M-import qualified Data.Set as S-import qualified Data.Vector.Unboxed as U-import qualified Data.Vector.Unboxed.Mutable as UM-import Control.DeepSeq-import Control.Monad.ST-import Data.Map (Map)-import Data.Set (Set)-import FRP.NetWire.Wire----- | Calculate the average of the signal over the given number of last--- samples. This wire has O(n) space complexity and O(1) time--- complexity.------ If you need an average over all samples ever produced, consider using--- 'avgAll' instead.------ Never inhibits. Feedback by delay.--avg :: forall m v. (Fractional v, Monad m, NFData v, U.Unbox v) => Int -> Wire m v v-avg n = mkGen $ \_ x -> return (Right x, avg' (U.replicate n (x/d)) x 0)- where- avg' :: U.Vector v -> v -> Int -> Wire m v v- avg' samples' s' cur' =- mkGen $ \_ ((/d) -> x) -> do- let cur = let cur = succ cur' in if cur >= n then 0 else cur- x' = samples' U.! cur- samples =- x' `deepseq` runST $ do- s <- U.unsafeThaw samples'- UM.write s cur x- U.unsafeFreeze s- let s = s' - x' + x- s' `deepseq` cur `seq` return (Right s, avg' samples s cur)-- d :: 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.------ Never inhibits. Feedback by delay.--avgAll :: forall m v. (Fractional v, Monad m, NFData v) => Wire m v v-avgAll = mkGen $ \_ x -> return (Right x, avgAll' 1 x)- where- avgAll' :: v -> v -> Wire m v v- avgAll' n' a' =- mkGen $ \_ x ->- let n = n' + 1- a = a' - a'/n + x/n in- n `deepseq` a' `deepseq` return (Right a, avgAll' n a)----- | Calculate the average number of frames per virtual second for the--- last given number of frames.------ Please note that this wire uses the clock, which you give the network--- using the stepping functions in "FRP.NetWire.Session". If this clock--- doesn't represent real time, then the output of this wire won't--- either.------ Never inhibits.--avgFps :: forall a m. Monad m => Int -> Wire m a Double-avgFps = avgFps' . avg- where- avgFps' :: Wire m Double Double -> Wire m a Double- avgFps' w' =- mkGen $ \ws@(wsDTime -> dt) _ -> do- (ma, w) <- toGen w' ws dt- return (fmap recip ma, avgFps' w)----- | Collects all the inputs ever received. This wire uses O(n) memory--- and runs in O(log n) time, where n is the number of inputs collected--- so far.------ Never inhibits. Feedback by delay.--collect :: forall a m. (Ord a, Monad m) => Wire m a (Set a)-collect = collect' S.empty- where- collect' :: Set a -> Wire m a (Set a)- collect' s' =- mkGen $ \_ x ->- let s = S.insert x s'- in s `seq` return (Right s, collect' s)----- | Emits an event, whenever the input signal changes. The event--- contains the last input value and the time elapsed since the last--- change.------ Inhibits on no change.--diff :: forall a m. (Eq a, Monad m) => Wire m a (a, Time)-diff =- mkGen $ \(wsDTime -> dt) x' ->- return (Left noEvent, diff' dt x')-- where- diff' :: Time -> a -> Wire m a (a, Time)- diff' t' x' =- mkGen $ \(wsDTime -> dt) x ->- let t = t' + dt in- if x' == x- then return (Left noEvent, diff' t x')- else return (Right (x', t), diff' 0 x)----- | Return the high peak.------ Never inhibits. Feedback by delay.--highPeak :: (Monad m, NFData a, Ord a) => Wire m a a-highPeak = peakBy compare----- | Returns the time delta between now and when the input signal was--- last seen. This wire uses O(n) memory and runs in O(log n) time,--- where n is the number of inputs collected so far.------ Inhibits, when a signal is seen for the first time.--lastSeen :: forall a m. (Ord a, Monad m) => Wire m a Time-lastSeen = lastSeen' M.empty 0- where- lastSeen' :: Map a Time -> Time -> Wire m a Time- lastSeen' tm' t' =- mkGen $ \(wsDTime -> dt) x -> do- let t = t' + dt- let mx = case M.lookup x tm' of- Nothing -> Left (inhibitEx "Signal seen for the first time")- Just lt -> Right (t - lt)- let tm = t `seq` M.insert x t tm'- tm `seq` return (mx, lastSeen' tm t)----- | Return the low peak.------ Never inhibits. Feedback by delay.--lowPeak :: (Monad m, NFData a, Ord a) => Wire m a a-lowPeak = peakBy (flip compare)----- | Return the high peak with the given comparison function.------ Never inhibits. Feedback by delay.--peakBy :: forall a m. (Monad m, NFData a) => (a -> a -> Ordering) -> Wire m a a-peakBy comp = mkGen $ \_ x -> return (Right x, peakBy' x)- where- peakBy' :: a -> Wire m a a- peakBy' p' =- mkGen $ \_ x -> do- let p = if comp x p' == GT then x else p'- p' `deepseq` return (Right p, peakBy' p)
− FRP/NetWire/Calculus.hs
@@ -1,59 +0,0 @@--- |--- Module: FRP.NetWire.Calculus--- Copyright: (c) 2011 Ertugrul Soeylemez--- License: BSD3--- Maintainer: Ertugrul Soeylemez <es@ertes.de>------ Calculus functions.--module FRP.NetWire.Calculus- ( -- * Calculus over time- derivative,- derivativeFrom,- integral- )- where--import Control.DeepSeq-import Data.VectorSpace-import FRP.NetWire.Wire----- | Differentiate over time.------ Inhibits at first instant.--derivative :: (Monad m, NFData v, VectorSpace v, Scalar v ~ Double) => Wire m v v-derivative =- mkGen $ \_ y2 ->- return (Left (inhibitEx "Derivative at first instant"),- derivativeFrom y2)----- | Differentiate over time. The argument is the value before the--- first instant.------ Never inhibits. Feedback by delay.--derivativeFrom ::- forall m v. (Monad m, NFData v, VectorSpace v, Scalar v ~ Double) =>- v -> Wire m v v-derivativeFrom y1 = derivativeFrom' zeroV y1- where- derivativeFrom' :: v -> v -> Wire m v v- derivativeFrom' dy' y1 =- mkGen $ \(wsDTime -> dt) y2 -> do- let dy = (y2 ^-^ y1) ^/ dt- dy' `deepseq` return (Right dy, derivativeFrom' dy y2)----- | Integrate over time. The argument is the integration constant.------ Never inhibits. Feedback by delay.--integral :: (Monad m, NFData v, VectorSpace v, Scalar v ~ Double) => v -> Wire m v v-integral x1 =- mkGen $ \ws dx -> do- let dt = wsDTime ws- x2 = x1 ^+^ dt *^ dx- x1 `deepseq` return (Right x2, integral x2)
− FRP/NetWire/Event.hs
@@ -1,304 +0,0 @@--- |--- Module: FRP.NetWire.Event--- Copyright: (c) 2011 Ertugrul Soeylemez--- License: BSD3--- Maintainer: Ertugrul Soeylemez <es@ertes.de>------ Event system. None of these wires except 'event' supports feedback,--- because they all can inhibit.--module FRP.NetWire.Event- ( -- * Producing events- after,- afterEach,- edge,- edgeBy,- edgeJust,- never,- once,- periodically,- repeatedly,- repeatedlyList,-- -- * Event transformers- -- ** Delaying events- dam,- delayEvents,- delayEventsSafe,- -- ** Selecting events- dropEvents,- dropFor,- notYet,- takeEvents,- takeFor,- -- ** Tools- event- )- where--import qualified Data.Sequence as Seq-import Control.Arrow-import Control.Monad-import Data.Maybe-import Data.Sequence (Seq, (|>), ViewL((:<)))-import FRP.NetWire.Tools-import FRP.NetWire.Wire----- | Produce a signal once after the specified delay and never again.--- The event's value will be the input signal at that point.--after :: Monad m => Time -> Wire m a a-after t' =- mkGen $ \(wsDTime -> dt) x ->- let t = t' - dt in- if t <= 0- then return (Right x, never)- else return (Left noEvent, after t)----- | Produce an event according to the given list of time deltas and--- event values. The time deltas are relative to each other, hence from--- the perspective of switching in @[(1, 'a'), (2, 'b'), (3, 'c')]@--- produces the event @'a'@ after one second, @'b'@ after three seconds--- and @'c'@ after six seconds.--afterEach :: forall a b m. Monad m => [(Time, b)] -> Wire m a b-afterEach = afterEach' 0- where- afterEach' :: Time -> [(Time, b)] -> Wire m a b- afterEach' _ [] = never- afterEach' t' d@((int, x):ds) =- mkGen $ \(wsDTime -> dt) _ ->- let t = t' + dt in- if t >= int- then let nextT = t - int- in nextT `seq` return (Right x, afterEach' (t - int) ds)- else return (Left noEvent, afterEach' t d)----- | Event dam. Collects all values from the input list and emits one--- value at each instant.------ Note that this combinator can cause event congestion. If you feed--- values faster than it can produce, it will leak memory.--dam :: forall a m. Monad m => Wire m [a] a-dam = dam' []- where- dam' :: [a] -> Wire m [a] a- dam' xs =- mkGen $ \_ ys ->- case xs ++ ys of- [] -> return (Left noEvent, dam' [])- (x:rest) -> return (Right x, dam' rest)----- | Delay events by the time interval in the left signal.------ Note that this event transformer has to keep all delayed events in--- memory, which can cause event congestion. If events are fed in--- faster than they can be produced (for example when the framerate--- starts to drop), it will leak memory. Use 'delayEventSafe' to--- prevent this.--delayEvents :: forall a m. Monad m => Wire m (Time, Maybe a) a-delayEvents = delayEvent' Seq.empty 0- where- delayEvent' :: Seq (Time, a) -> Time -> Wire m (Time, Maybe a) a- delayEvent' es' t' =- mkGen $ \(wsDTime -> dt) (int, ev) -> do- let t = t' + dt- es = t `seq` maybe es' (\ee -> es' |> (t + int, ee)) ev- case Seq.viewl es of- Seq.EmptyL -> return (Left noEvent, delayEvent' es 0)- (et, ee) :< rest- | t >= et -> return (Right ee, delayEvent' rest t)- | otherwise -> return (Left noEvent, delayEvent' es t)----- | Delay events by the time interval in the left signal. The event--- queue is limited to the maximum number of events given by middle--- signal. If the current queue grows to this size, then temporarily no--- further events are queued.------ As suggested by the type, this maximum can change over time.--- However, if it's decreased below the number of currently queued--- events, the events are not deleted.--delayEventsSafe :: forall a m. Monad m => Wire m (Time, Int, Maybe a) a-delayEventsSafe = delayEventSafe' Seq.empty 0- where- delayEventSafe' :: Seq (Time, a) -> Time -> Wire m (Time, Int, Maybe a) a- delayEventSafe' es' t' =- mkGen $ \(wsDTime -> dt) (int, maxEvs, ev') -> do- let t = t' + dt- ev = guard (Seq.length es' < maxEvs) >> ev'- es = t `seq` maybe es' (\ee -> es' |> (t + int, ee)) ev- case Seq.viewl es of- Seq.EmptyL -> return (Left noEvent, delayEventSafe' es 0)- (et, ee) :< rest- | t >= et -> return (Right ee, delayEventSafe' rest t)- | otherwise -> return (Left noEvent, delayEventSafe' es t)----- | Drop the given number of events, before passing events through.--dropEvents :: forall a m. Monad m => Int -> Wire m a a-dropEvents 0 = identity-dropEvents n =- mkGen $ \_ x -> return (Right x, dropEvents (pred n))----- | Timed event gate for the right signal, which begins closed and--- opens after the time interval in the left signal has passed.--dropFor :: forall a m. Monad m => Wire m (Time, a) a-dropFor = dropFor' 0- where- dropFor' :: Time -> Wire m (Time, a) a- dropFor' t' =- mkGen $ \(wsDTime -> dt) (int, x) ->- let t = t' + dt in- if t >= int- then return (Right x, arr snd)- else return (Left noEvent, dropFor' t)----- | Produce a single event with the right signal whenever the left--- signal switches from 'False' to 'True'.--edge :: Monad m => Wire m (Bool, a) a-edge = edgeBy fst snd----- | Whenever the predicate in the first argument switches from 'False'--- to 'True' for the input signal, produce an event carrying the value--- given by applying the second argument function to the input signal.--edgeBy :: forall a b m. Monad m => (a -> Bool) -> (a -> b) -> Wire m a b-edgeBy p f = edgeBy'- where- edgeBy' :: Wire m a b- edgeBy' =- mkGen $ \_ subject ->- if p subject- then return (Right (f subject), switchBack)- else return (Left noEvent, edgeBy')-- switchBack :: Wire m a b- switchBack =- mkGen $ \_ subject ->- return (Left noEvent, if p subject then switchBack else edgeBy')----- | Produce a single event carrying the value of the input signal,--- whenever the input signal switches to 'Just'.--edgeJust :: Monad m => Wire m (Maybe a) a-edgeJust = edgeBy isJust fromJust----- | Variant of 'exhibit', which produces a 'Maybe' instead of an--- 'Either'.------ Never inhibits. Same feedback properties as argument wire.--event :: Monad m => Wire m a b -> Wire m a (Maybe b)-event w' =- mkGen $ \ws x' -> do- (mx, w) <- toGen w' ws x'- case mx of- Left _ -> return (Right Nothing, event w)- Right x -> return (Right (Just x), event w)----- | Never produce an event. This is equivalent to 'inhibit', but with--- a contextually more appropriate exception message.--never :: Monad m => Wire m a b-never = mkGen $ \_ _ -> return (Left noEvent, never)----- | Suppress the first event occurence.--notYet :: Monad m => Wire m a a-notYet = mkGen $ \_ _ -> return (Left noEvent, identity)----- | Produce an event at the first instant and never again.--once :: Monad m => Wire m a a-once = mkGen $ \_ x -> return (Right x, never)----- | Emits a '()' signal each time the signal interval passes. This is--- a simpler variant of 'repeatedly'.--periodically :: forall m. Monad m => Wire m Time ()-periodically = periodically' 0- where- periodically' :: Time -> Wire m Time ()- periodically' t' =- mkGen $ \(wsDTime -> dt) int ->- let t = t' + dt in- if t >= int- then let nextT = fmod t int- in nextT `seq` return (Right (), periodically' nextT)- else return (Left noEvent, periodically' t)----- | Emit the right signal event each time the left signal interval--- passes.--repeatedly :: forall a m. Monad m => Wire m (Time, a) a-repeatedly = repeatedly' 0- where- repeatedly' :: Time -> Wire m (Time, a) a- repeatedly' t' =- mkGen $ \(wsDTime -> dt) (int, x) ->- let t = t' + dt in- if t >= int- then let nextT = fmod t int- in nextT `seq` return (Right x, repeatedly' nextT)- else return (Left noEvent, repeatedly' t)----- | Each time the signal interval passes emit the next element from the--- given list.--repeatedlyList :: forall a m. Monad m => [a] -> Wire m Time a-repeatedlyList = repeatedly' 0- where- repeatedly' :: Time -> [a] -> Wire m Time a- repeatedly' _ [] = never- repeatedly' t' x@(x0:xs) =- mkGen $ \(wsDTime -> dt) int ->- let t = t' + dt in- if t >= int- then let nextT = fmod t int- in nextT `seq` return (Right x0, repeatedly' nextT xs)- else return (Left noEvent, repeatedly' t x)----- | Pass only the first given number of events. Then suppress events--- forever.--takeEvents :: forall a m. Monad m => Int -> Wire m a a-takeEvents 0 = never-takeEvents n = mkGen $ \_ x -> return (Right x, takeEvents (pred n))----- | Timed event gate for the right signal, which starts open and slams--- shut after the left signal time interval passed.--takeFor :: forall a m. Monad m => Wire m (Time, a) a-takeFor = takeFor' 0- where- takeFor' :: Time -> Wire m (Time, a) a- takeFor' t' =- mkGen $ \(wsDTime -> dt) (int, x) ->- let t = t' + dt in- if t >= int- then return (Left noEvent, never)- else return (Right x, takeFor' t)
− FRP/NetWire/IO.hs
@@ -1,41 +0,0 @@--- |--- Module: FRP.NetWire.IO--- Copyright: (c) 2011 Ertugrul Soeylemez--- License: BSD3--- Maintainer: Ertugrul Soeylemez <es@ertes.de>------ Access the rest of the universe.--module FRP.NetWire.IO- ( -- * IO Actions- execute,-- -- * Generic actions- liftWire- )- where--import Control.Exception.Control-import Control.Monad-import Control.Monad.IO.Control-import FRP.NetWire.Wire----- | Execute the IO action in the input signal at every instant.------ Note: If the action throws an exception, then this wire inhibits the--- signal.------ Inhibits on exception. No feedback.--execute :: MonadControlIO m => Wire m (m a) a-execute = mkGen $ \_ c -> liftM (, execute) (try c)----- | Lift the given monadic computation to a wire. The action is run at--- every instant.------ Never inhibits. Same feedback behaviour as the given computation.--liftWire :: Monad m => Wire m (m a) a-liftWire = mkGen $ \_ c -> liftM ((, liftWire) . Right) c
− FRP/NetWire/Pure.hs
@@ -1,29 +0,0 @@--- |--- Module: FRP.NetWire.Pure--- Copyright: (c) 2011 Ertugrul Soeylemez--- License: BSD3--- Maintainer: Ertugrul Soeylemez <es@ertes.de>------ Pure wire sessions.--module FRP.NetWire.Pure- ( -- * Pure sessions- stepSF,- stepWirePure- )- where--import Data.Functor.Identity-import FRP.NetWire.Wire----- | Perform the next instant of a pure wire over the identity monad.--stepSF :: Time -> a -> SF a b -> (Output b, SF a b)-stepSF dt x' = runIdentity . stepWirePure dt x'----- | Perform the next instant of a pure wire.--stepWirePure :: Monad m => Time -> a -> Wire m a b -> m (Output b, Wire m a b)-stepWirePure dt x' w' = toGen w' (PureState dt) x'
− FRP/NetWire/Random.hs
@@ -1,103 +0,0 @@--- |--- Module: FRP.NetWire.Random--- Copyright: (c) 2011 Ertugrul Soeylemez--- License: BSD3--- Maintainer: Ertugrul Soeylemez <es@ertes.de>------ Noise generators.--module FRP.NetWire.Random- ( -- * Impure noise generators- noise,- noise1,- noiseGen,- noiseR,- wackelkontakt,-- -- * Pure noise generators- pureNoise,- pureNoiseR- )- where--import qualified System.Random as R-import Control.Monad-import Control.Monad.IO.Class-import FRP.NetWire.Wire-import System.Random.Mersenne----- | Impure noise between 0 (inclusive) and 1 (exclusive).------ Never inhibits.--noise :: MonadIO m => Wire m a Double-noise = noiseGen----- | Impure noise between -1 (inclusive) and 1 (exclusive).------ Never inhibits.--noise1 :: MonadIO m => Wire m a Double-noise1 =- mkGen $ \(wsRndGen -> mt) _ -> do- x <- liftM (pred . (2*)) . liftIO $ random mt- x `seq` return (Right x, noise1)----- | Impure noise.------ Never inhibits.--noiseGen :: (MonadIO m, MTRandom b) => Wire m a b-noiseGen =- mkGen $ \(wsRndGen -> mt) _ -> do- x <- liftIO (random mt)- x `seq` return (Right x, noiseGen)----- | Impure noise between 0 (inclusive) and the input signal--- (exclusive). Note: The noise is generated by multiplying with a--- 'Double', hence the precision is limited.------ Never inhibits. Feedback by delay.--noiseR :: (MonadIO m, Real a, Integral b) => Wire m a b-noiseR =- mkGen $ \(wsRndGen -> mt) n -> do- x' <- liftIO (random mt)- let x = floor ((x' :: Double) * realToFrac n)- return (Right x, noiseR)----- | Pure noise. For impure wires it's recommended to use the impure--- noise generators.------ Never inhibits.--pureNoise :: (Monad m, R.RandomGen g, R.Random b) => g -> Wire m a b-pureNoise g' =- mkGen $ \_ _ ->- let (x, g) = R.random g'- in x `seq` return (Right x, pureNoise g)----- | Pure noise in a range. For impure wires it's recommended to use--- the impure noise generators.------ Never inhibits. Feedback by delay.--pureNoiseR :: (Monad m, R.RandomGen g, R.Random b) => g -> Wire m (b, b) b-pureNoiseR g' =- mkGen $ \_ range ->- let (x, g) = R.randomR range g'- in return (Right x, pureNoise g)----- | Impure random boolean.------ Never inhibits.--wackelkontakt :: MonadIO m => Wire m a Bool-wackelkontakt = noiseGen
− FRP/NetWire/Request.hs
@@ -1,240 +0,0 @@--- |--- Module: FRP.NetWire.Request--- Copyright: (c) 2011 Ertugrul Soeylemez--- License: BSD3--- Maintainer: Ertugrul Soeylemez <es@ertes.de>------ Object managers, unique identifiers and context-sensitive wires.--module FRP.NetWire.Request- ( -- * Containers- MgrMsg(..),- manager,-- -- * Context-sensitive mutation- context,- contextInt,- contextLimited,- contextLimitedInt,- -- ** Simple variants- context_,- contextInt_,- contextLimited_,- contextLimitedInt_,-- -- * Identifiers.- identifier- )- where--import qualified Data.IntMap as IM-import qualified Data.Map as M-import qualified Data.Traversable as T-import Control.Arrow-import Control.Monad.IO.Class-import Control.Concurrent.STM-import Data.IntMap (IntMap)-import Data.Map (Map)-import Data.Monoid-import FRP.NetWire.Wire----- | Messages to wire managers (see the 'manager' wire).--data MgrMsg k m a b- -- | Do nothing. Send this, if the wire shouldn't be changed in an- -- instant.- = MgrNop-- -- | Perform two operations in an instant.- | MgrMulti (MgrMsg k m a b) (MgrMsg k m a b)-- -- | Add the given wire with the given key. If the manager already- -- has a wire with this key, it is overwritten.- | MgrAdd k (Wire m a b)-- -- | Delete the wire with the given key, if it exists.- | MgrDel k---- | The monoid instance can be used to combine multiple manager--- operations. They are performed from left to right. This instance--- tries hard to optimize operations away without sacrificing--- performance.--instance Eq k => Monoid (MgrMsg k m a b) where- mempty = MgrNop-- mappend MgrNop y = y- mappend x MgrNop = x- mappend (MgrAdd k1 _) y@(MgrAdd k2 _) | k1 == k2 = y- mappend (MgrDel k1) y@(MgrAdd k2 _) | k1 == k2 = y- mappend (MgrAdd k1 _) (MgrDel k2) | k1 == k2 = MgrNop- mappend (MgrDel k1) y@(MgrDel k2) | k1 == k2 = y- mappend x y = MgrMulti x y----- | Make the given wire context-sensitive. The left input signal is a--- context and the argument wire will mutate individually for each such--- context.------ Inherits inhibition and feedback behaviour from the current context's--- wire.--context :: forall a b ctx m. (Ord ctx, Monad m) => Wire m (ctx, a) b -> Wire m (ctx, a) b-context w0 = context' M.empty 0- where- context' :: Map ctx (Time, Wire m (ctx, a) b) -> Time -> Wire m (ctx, a) b- context' tm' t' =- mkGen $ \ws@(wsDTime -> dt') inp@(ctx, _) -> do- let t = t' + dt'- let (dt, w') = case M.lookup ctx tm' of- Nothing -> (0, w0)- Just (lt, w') -> (t - lt, w')- (mx, w) <- dt `seq` toGen w' (ws { wsDTime = dt }) inp- let tm = M.insert ctx (t, w) tm'- return (mx, context' tm t)----- | Simplified variant of 'context'. Takes a context signal only.--context_ :: (Ord ctx, Monad m) => Wire m ctx b -> Wire m ctx b-context_ w0 = arr (, ()) >>> context (arr fst >>> w0)----- | Specialized version of 'context'. Use this one, if your contexts--- are 'Int's and you have a lot of them.------ Inherits inhibition and feedback behaviour from the current context's--- wire.--contextInt :: forall a b m. Monad m => Wire m (Int, a) b -> Wire m (Int, a) b-contextInt w0 = context' IM.empty 0- where- context' :: IntMap (Time, Wire m (Int, a) b) -> Time -> Wire m (Int, a) b- context' tm' t' =- mkGen $ \ws@(wsDTime -> dt') inp@(ctx, _) -> do- let t = t' + dt'- let (dt, w') = case IM.lookup ctx tm' of- Nothing -> (0, w0)- Just (lt, w') -> (t - lt, w')- (mx, w) <- dt `seq` toGen w' (ws { wsDTime = dt }) inp- let tm = IM.insert ctx (t, w) tm'- return (mx, context' tm t)----- | Simplified variant of 'contextInt'. Takes a context signal only.--contextInt_ :: Monad m => Wire m Int b -> Wire m Int b-contextInt_ w0 = arr (, ()) >>> contextInt (arr fst >>> w0)----- | Same as 'context', but with a time limit. The first signal--- specifies a threshold and the second signal specifies a maximum age.--- If the current number of contexts exceeds the threshold, then all--- contexts exceeding the maximum age are deleted.------ Inherits inhibition and feedback behaviour from the current context's--- wire.--contextLimited :: forall a b ctx m. (Ord ctx, Monad m) => Wire m (ctx, a) b -> Wire m (Int, Time, ctx, a) b-contextLimited w0 = context' M.empty 0- where- context' :: Map ctx (Time, Wire m (ctx, a) b) -> Time -> Wire m (Int, Time, ctx, a) b- context' tm'' t' =- mkGen $ \ws@(wsDTime -> dt') (limit, maxAge, ctx, x') -> do- let t = t' + dt'- let (dt, w') = case M.lookup ctx tm'' of- Nothing -> (0, w0)- Just (lt, w') -> (t - lt, w')- (mx, w) <- dt `seq` toGen w' (ws { wsDTime = dt }) (ctx, x')- let tm' = M.insert ctx (t, w) tm''- tm = if M.size tm' <= limit- then tm'- else M.filter (\(ct, _) -> t - ct <= maxAge) tm'-- return (mx, context' tm t)----- | Simplified variant of 'contextLimited'. Takes a context signal--- only.--contextLimited_ :: (Ord ctx, Monad m) => Wire m ctx b -> Wire m (Int, Time, ctx) b-contextLimited_ w0 =- arr (\(thr, maxAge, ctx) -> (thr, maxAge, ctx, ())) >>>- contextLimited (arr fst >>> w0)----- | Specialized version of 'contextLimited'. Use this one, if your--- contexts are 'Int's and you have a lot of them.------ Inherits inhibition and feedback behaviour from the current context's--- wire.--contextLimitedInt :: forall a b m. Monad m => Wire m (Int, a) b -> Wire m (Int, Time, Int, a) b-contextLimitedInt w0 = context' IM.empty 0- where- context' :: IntMap (Time, Wire m (Int, a) b) -> Time -> Wire m (Int, Time, Int, a) b- context' tm'' t' =- mkGen $ \ws@(wsDTime -> dt') (limit, maxAge, ctx, x') -> do- let t = t' + dt'- let (dt, w') = case IM.lookup ctx tm'' of- Nothing -> (0, w0)- Just (lt, w') -> (t - lt, w')- (mx, w) <- dt `seq` toGen w' (ws { wsDTime = dt }) (ctx, x')- let tm' = IM.insert ctx (t, w) tm''- tm = if IM.size tm' <= limit- then tm'- else IM.filter (\(ct, _) -> t - ct <= maxAge) tm'-- return (mx, context' tm t)----- | Simplified variant of 'contextLimitedInt'. Takes a context signal--- only.--contextLimitedInt_ :: Monad m => Wire m Int b -> Wire m (Int, Time, Int) b-contextLimitedInt_ w0 =- arr (\(thr, maxAge, ctx) -> (thr, maxAge, ctx, ())) >>>- contextLimitedInt (arr fst >>> w0)----- | Choose a new unique identifier at every instant.------ Never inhibits. Feedback by delay.--identifier :: MonadIO m => Wire m a Int-identifier =- mkGen $ \ws _ -> do- let reqVar = wsReqVar ws- req <- liftIO . atomically $ do- req' <- readTVar reqVar- let req = succ req'- req `seq` writeTVar reqVar (succ req')- return req'- return (Right req, identifier)----- | Wire manager, which can be manipulated during the session. This is--- a convenient alternative to parallel switches.------ This wire manages a set of subwires, each indexed by a key. Through--- messages new subwires can be added and existing ones can be deleted.------ Inhibits, whenever one of the managed wires inhibits. Inherits--- feedback behaviour from the worst managed wire.--manager :: forall a b k m. (Monad m, Ord k) => Wire m (a, MgrMsg k m a b) (Map k b)-manager = mgr M.empty- where- mgr :: Map k (Wire m a b) -> Wire m (a, MgrMsg k m a b) (Map k b)- mgr wires'' =- mkGen $ \ws (x', msg) -> do- let wires' = processMsg msg wires''- wires <- T.mapM (\w -> toGen w ws x') wires'- return (T.sequenceA (fmap fst wires), mgr (fmap snd wires))-- processMsg :: MgrMsg k m a b -> Map k (Wire m a b) -> Map k (Wire m a b)- processMsg MgrNop = id- processMsg (MgrMulti m1 m2) = processMsg m2 . processMsg m1- processMsg (MgrAdd k w) = M.insert k w- processMsg (MgrDel k) = M.delete k
− FRP/NetWire/Session.hs
@@ -1,222 +0,0 @@--- |--- Module: FRP.NetWire.Session--- Copyright: (c) 2011 Ertugrul Soeylemez--- License: BSD3--- Maintainer: Ertugrul Soeylemez <es@ertes.de>------ Wire sessions.--module FRP.NetWire.Session- ( -- * Sessions- Session(..),- stepWire,- stepWireDelta,- stepWireTime,- stepWireTime',- withWire,-- -- * Testing wires- testWire,- testWireStr,-- -- * Low level- sessionStart,- sessionStop- )- where--import Control.Applicative-import Control.Arrow-import Control.Concurrent.STM-import Control.Exception.Control-import Control.Monad-import Control.Monad.IO.Class-import Control.Monad.IO.Control-import Data.IORef-import Data.Time.Clock-import FRP.NetWire.Wire-import System.IO----- | Reactive sessions with the given input and output types over the--- given monad. The monad must have a 'MonadControlIO' instance to be--- usable with the stepping functions.--data Session m a b =- Session {- sessFreeVar :: TVar Bool, -- ^ False, if in use.- sessStateRef :: IORef (WireState m), -- ^ State of the last instant.- sessTimeRef :: IORef UTCTime, -- ^ Time of the last instant.- sessWireRef :: IORef (Wire m a b) -- ^ Wire for the next instant.- }----- | Start a wire session.--sessionStart :: MonadIO m => Wire m a b -> IO (Session m a b)-sessionStart w = do- t@(UTCTime td tt) <- getCurrentTime- ws <- initWireState-- sess <-- td `seq` tt `seq` t `seq` ws `seq`- liftIO $- Session- <$> newTVarIO True- <*> newIORef ws- <*> newIORef t- <*> newIORef w-- sess `seq` return sess----- | Clean up a wire session.--sessionStop :: Session m a b -> IO ()-sessionStop sess =- readIORef (sessStateRef sess) >>= cleanupWireState----- | Feed the given input value into the reactive system performing the--- next instant using real time.--stepWire ::- MonadControlIO m- => a -- ^ Input value.- -> Session m a b -- ^ Session to step.- -> m (Output b) -- ^ System's output.-stepWire x' sess =- withBlock sess $ do- t <- liftIO getCurrentTime- stepWireTime' t x' sess----- | Feed the given input value into the reactive system performing the--- next instant using the given time delta.--stepWireDelta ::- MonadControlIO m- => NominalDiffTime -- ^ Time delta.- -> a -- ^ Input value.- -> Session m a b -- ^ Session to step.- -> m (Output b) -- ^ System's output.-stepWireDelta dt x' sess =- withBlock sess $ do- t' <- liftIO (readIORef $ sessTimeRef sess)- let t@(UTCTime td tt) = addUTCTime dt t'- td `seq` tt `seq` t `seq` stepWireTime' t x' sess----- | Feed the given input value into the reactive system performing the--- next instant, which is at the given time. This function is--- thread-safe.--stepWireTime ::- MonadControlIO m- => UTCTime -- ^ Absolute time of the instant to perform.- -> a -- ^ Input value.- -> Session m a b -- ^ Session to step.- -> m (Output b) -- ^ System's output.-stepWireTime t' x' sess = withBlock sess (stepWireTime' t' x' sess)----- | Feed the given input value into the reactive system performing the--- next instant, which is at the given time. This function is /not/--- thread-safe.--stepWireTime' ::- MonadIO m- => UTCTime -- ^ Absolute time of the instant to perform.- -> a -- ^ Input value.- -> Session m a b -- ^ Session to step.- -> m (Output b) -- ^ System's output.-stepWireTime' t x' sess = do- let Session { sessTimeRef = tRef, sessStateRef = wsRef, sessWireRef = wRef- } = sess-- -- Time delta.- t' <- liftIO (readIORef tRef)- let dt = realToFrac (diffUTCTime t t')- dt `seq` liftIO (writeIORef tRef t)-- -- Wire state.- ws' <- liftIO (readIORef wsRef)- let ws = ws' { wsDTime = dt }- ws `seq` liftIO (writeIORef wsRef ws)-- -- Wire.- w' <- liftIO (readIORef wRef)- (x, w) <- toGen w' ws x'- w `seq` liftIO (writeIORef wRef w)-- return x----- | Interface to 'testWireStr' accepting all 'Show' instances as the--- output type.--testWire ::- forall a b m. (MonadControlIO m, Show b)- => Int -- ^ Show output once each this number of frames.- -> m a -- ^ Input generator.- -> Wire m a b -- ^ Your wire.- -> m ()-testWire fpp getInput w' = testWireStr fpp getInput (w' >>> arr show)----- | This function provides a convenient way to test wires. It wraps a--- default loop around your wire, which just displays the output on your--- stdout in a single line (it uses an ANSI escape sequence to clear the--- line). It uses real time.--testWireStr ::- forall a m. MonadControlIO m- => Int -- ^ Show output once each this number of frames.- -> m a -- ^ Input generator.- -> Wire m a String -- ^ Wire to evolve.- -> m ()-testWireStr fpp getInput w' =- withWire w' (loop 0)-- where- loop :: Int -> Session m a String -> m ()- loop n' sess = do- let n = let n = succ n' in if n >= fpp then 0 else n-- x' <- getInput- mx <- stepWire x' sess- when (n' == 0) . liftIO $ do- putStr "\r\027[K"- case mx of- Left ex -> putStr (show ex)- Right str -> putStr str- hFlush stdout-- n `seq` loop n sess----- | Perform an interlocked step function.--withBlock ::- MonadControlIO m- => Session m a b -- ^ The session to mark as locked for the- -- duration of the given computation.- -> m c -- ^ Computation to perform.- -> m c -- ^ Result.-withBlock (Session { sessFreeVar = freeVar }) c = do- liftIO (atomically $ readTVar freeVar >>= check >> writeTVar freeVar False)- c `finally` liftIO (atomically $ writeTVar freeVar True)----- | Initialize a reactive session and pass it to the given--- continuation.--withWire ::- (MonadControlIO m, MonadIO sm)- => Wire sm a b -- ^ Initial wire of the session.- -> (Session sm a b -> m c) -- ^ Continuation, which receives the- -- session data.- -> m c -- ^ Continuation's result.-withWire w k = do- sess <- liftIO (sessionStart w)- k sess `finally` liftIO (sessionStop sess)
− FRP/NetWire/Switch.hs
@@ -1,190 +0,0 @@--- |--- Module: FRP.NetWire.Switch--- Copyright: (c) 2011 Ertugrul Soeylemez--- License: BSD3--- Maintainer: Ertugrul Soeylemez <es@ertes.de>------ Switching combinators. Note that 'Wire' also provides a--- state-preserving 'Control.Arrow.ArrowApply' instance, which may be--- more convenient than these combinators in many cases.--module FRP.NetWire.Switch- ( -- * Basic switches- switch, dSwitch,- rSwitch, drSwitch,-- -- * Broadcasters- parB,- rpSwitchB, drpSwitchB,-- -- * Routers- par,- rpSwitch, drpSwitch,-- -- * Embedding wires- appEvent,- appFirst,- appFrozen- )- where--import qualified Data.Traversable as T-import Control.Applicative-import Data.Traversable (Traversable)-import FRP.NetWire.Wire----- | Decoupled variant of 'rpSwitch'.--drpSwitch ::- (Applicative m, Monad m, Traversable f) =>- (forall w. a -> f w -> f (b, w)) ->- f (Wire m b c) ->- Wire m (a, Maybe (f (Wire m b c) -> f (Wire m b c))) (f c)-drpSwitch route wires''' =- WGen $ \ws (x'', ev) -> do- let wires'' = route x'' wires'''- r <- T.sequenceA $ fmap (\(x', w') -> toGen w' ws x') wires''- let xs = T.sequenceA . fmap fst $ r- wires' = fmap snd r- wires = maybe id id ev wires'- return (xs, rpSwitch route wires)----- | Decoupled variant of 'rpSwitchB'.--drpSwitchB ::- (Applicative m, Monad m, Traversable f) =>- f (Wire m a b) ->- Wire m (a, Maybe (f (Wire m a b) -> f (Wire m a b))) (f b)-drpSwitchB wires'' =- WGen $ \ws (x', ev) -> do- r <- T.sequenceA $ fmap (\w' -> toGen w' ws x') wires''- let xs = T.sequenceA . fmap fst $ r- wires' = fmap snd r- wires = maybe id id ev wires'- return (xs, rpSwitchB wires)----- | Decoupled variant of 'rSwitch'.--drSwitch :: Monad m => Wire m a b -> Wire m (a, Maybe (Wire m a b)) b-drSwitch w1' =- WGen $ \ws (x', swEv) -> do- (mx, w1) <- toGen w1' ws x'- let w = maybe w1 id swEv- w `seq` return (mx, drSwitch w)----- | Decoupled variant of 'switch'.--dSwitch :: Monad m => Wire m a (b, Maybe c) -> (c -> Wire m a b) -> Wire m a b-dSwitch w1' f =- WGen $ \ws x' -> do- (m, w1) <- toGen w1' ws x'- case m of- Left ex -> return (Left ex, dSwitch w1 f)- Right (x, swEv) ->- case swEv of- Nothing -> return (Right x, dSwitch w1 f)- Just sw -> return (Right x, f sw)----- | Route signal to a collection of signal functions using the supplied--- routing function. If any of the wires inhibits, the whole network--- inhibits.--par ::- (Applicative m, Monad m, Traversable f) =>- (forall w. a -> f w -> f (b, w)) -> f (Wire m b c) -> Wire m a (f c)-par route wires'' =- WGen $ \ws x'' -> do- let wires' = route x'' wires''- r <- T.sequenceA $ fmap (\(x', w') -> toGen w' ws x') wires'- let xs = T.sequenceA . fmap fst $ r- wires = fmap snd r- return (xs, par route wires)----- | Broadcast signal to a collection of signal functions. If any of--- the wires inhibits, then the whole parallel network inhibits.--parB :: (Applicative m, Monad m, Traversable f) => f (Wire m a b) -> Wire m a (f b)-parB wires' =- WGen $ \ws x' -> do- r <- T.sequenceA $ fmap (\w' -> toGen w' ws x') wires'- let xs = T.sequenceA . fmap fst $ r- wires = fmap snd r- return (xs, parB wires)----- | Recurrent parallel routing switch. This combinator acts like--- 'par', but takes an additional event signal, which can transform the--- set of wires. This is the most powerful switch.------ Just like 'par' if any of the wires inhibits, the whole network--- inhibits.--rpSwitch ::- (Applicative m, Monad m, Traversable f) =>- (forall w. a -> f w -> f (b, w)) ->- f (Wire m b c) ->- Wire m (a, Maybe (f (Wire m b c) -> f (Wire m b c))) (f c)-rpSwitch route wires''' =- WGen $ \ws (x'', ev) -> do- let wires'' = maybe id id ev wires'''- wires' = route x'' wires''- r <- T.sequenceA $ fmap (\(x', w') -> toGen w' ws x') wires'- let xs = T.sequenceA . fmap fst $ r- wires = fmap snd r- return (xs, rpSwitch route wires)----- | Recurrent parallel broadcast switch. This combinator acts like--- 'parB', but takes an additional event signal, which can transform the--- set of wires.------ Just like 'parB' if any of the wires inhibits, the whole network--- inhibits.--rpSwitchB ::- (Applicative m, Monad m, Traversable f) =>- f (Wire m a b) -> Wire m (a, Maybe (f (Wire m a b) -> f (Wire m a b))) (f b)-rpSwitchB wires'' =- WGen $ \ws (x', ev) -> do- let wires' = maybe id id ev wires''- r <- T.sequenceA $ fmap (\w' -> toGen w' ws x') wires'- let xs = T.sequenceA . fmap fst $ r- wires = fmap snd r- return (xs, rpSwitchB wires)----- | Combinator for recurrent switches. The wire produced by this--- switch takes switching events and switches to the wires contained in--- the events. The first argument is the initial wire.--rSwitch :: Monad m => Wire m a b -> Wire m (a, Maybe (Wire m a b)) b-rSwitch w1 =- WGen $ \ws (x', swEv) -> do- let w' = maybe w1 id swEv- (mx, w) <- toGen w' ws x'- return (mx, rSwitch w)----- | This is the most basic switching combinator. It is an event-based--- one-time switch.------ The first argument is the initial wire, which may produce a switching--- event at some point. When this event is produced, then the signal--- path switches to the wire produced by the second argument function.--switch :: Monad m => Wire m a (b, Maybe c) -> (c -> Wire m a b) -> Wire m a b-switch w1' f =- WGen $ \ws x' -> do- (m, w1) <- toGen w1' ws x'- case m of- Left ex -> return (Left ex, switch w1 f)- Right (x, swEv) ->- case swEv of- Nothing -> return (Right x, switch w1 f)- Just sw -> toGen (f sw) (ws { wsDTime = 0 }) x'
− FRP/NetWire/Tools.hs
@@ -1,409 +0,0 @@--- |--- Module: FRP.NetWire.Tools--- Copyright: (c) 2011 Ertugrul Soeylemez--- License: BSD3--- Maintainer: Ertugrul Soeylemez <es@ertes.de>------ The usual FRP tools you'll want to work with.--module FRP.NetWire.Tools- ( -- * Basic utilities- constant,- identity,-- -- * Time- time,- timeFrom,-- -- * Signal transformers- accum,- delay,- discrete,- hold,- inject,- injectMaybe,- keep,-- -- * Inhibitors- forbid,- forbid_,- inhibit,- inhibit_,- require,- require_,-- -- * Wire transformers- exhibit,- freeze,- sample,- swallow,- (-->),- (>--),- (-=>),- (>=-),-- -- * Arrow tools- mapA,-- -- * Convenience functions- dup,- fmod,- swap- )- where--import Control.Applicative-import Control.Arrow-import Control.Category hiding ((.))-import Control.Exception-import FRP.NetWire.Wire-import Prelude hiding (id)----- | Override the output value at the first non-inhibited instant.------ Same inhibition properties as argument wire. Same feedback--- properties as argument wire.--(-->) :: Monad m => b -> Wire m a b -> Wire m a b-y --> w' =- WGen $ \ws x -> do- (mx, w) <- toGen w' ws x- case mx of- Left _ -> return (mx, y --> w)- Right _ -> return (Right y, w)----- | Override the input value, until the wire starts producing.------ Same inhibition properties as argument wire. Same feedback--- properties as argument wire.--(>--) :: Monad m => a -> Wire m a b -> Wire m a b-x' >-- w' =- WGen $ \ws _ -> do- (mx, w) <- toGen w' ws x'- return (mx, either (const $ x' >-- w) (const w) mx)----- | Apply a function to the wire's output at the first non-inhibited--- instant.------ Same inhibition properties as argument wire. Same feedback--- properties as argument wire.--(-=>) :: Monad m => (b -> b) -> Wire m a b -> Wire m a b-f -=> w' =- WGen $ \ws x' -> do- (mx, w) <- toGen w' ws x'- case mx of- Left _ -> return (mx, f -=> w)- Right x -> return (Right (f x), w)----- | Apply a function to the wire's input, until the wire starts--- producing.------ Same inhibition properties as argument wire. Same feedback--- properties as argument wire.--(>=-) :: Monad m => (a -> a) -> Wire m a b -> Wire m a b-f >=- w' =- WGen $ \ws x' -> do- (mx, w) <- toGen w' ws (f x')- return (mx, either (const (f >=- w)) (const w) mx)----- | This function corresponds to the 'iterate' function for lists.--- Begins with an initial output value. Each time an input function is--- received, it is applied to the current accumulator and the new value--- is emitted.------ Never inhibits. Direct feedback.--accum :: Monad m => a -> Wire m (a -> a) a-accum x = mkGen $ \_ f -> x `seq` return (Right x, accum (f x))----- | The constant wire. Please use this function instead of @arr (const--- c)@.------ Never inhibits.--constant :: Monad m => b -> Wire m a b-constant = pure----- | One-instant delay. Delay the signal for an instant returning the--- argument value at the first instant. This wire is mainly useful to--- add feedback support to wires, which wouldn't support it by--- themselves. For example, the 'FRP.NetWire.Analyze.avg' wire does not--- support feedback by itself, but the following works:------ > do rec x <- delay 1 <<< avg 1000 -< x------ Never inhibits. Direct feedback.--delay :: Monad m => a -> Wire m a a-delay r = mkGen $ \_ x -> return (Right r, delay x)----- | Turn a continuous signal into a discrete one. This transformer--- picks values from the right signal at intervals of the left signal.------ The interval length is followed in real time. If it's zero, then--- this wire acts like @second id@.------ Never inhibits. Feedback by delay.--discrete :: forall a m. Monad m => Wire m (Time, a) a-discrete =- mkGen $ \(wsDTime -> dt) (_, x0) ->- return (Right x0, discrete' dt x0)-- where- discrete' :: Time -> a -> Wire m (Time, a) a- discrete' t' x' =- mkGen $ \(wsDTime -> dt) (int, x) ->- let t = t' + dt in- if t >= int- then return (Right x, discrete' (fmod t int) x)- else return (Right x', discrete' t x')----- | Duplicate a value to a tuple.--dup :: a -> (a, a)-dup x = (x, x)----- | This function corresponds to 'try' for exceptions, allowing you to--- observe inhibited signals. See also 'FRP.NetWire.Event.event'.------ Never inhibits. Same feedback properties as argument wire.--exhibit :: Monad m => Wire m a b -> Wire m a (Output b)-exhibit w' =- WGen $ \ws x' -> do- (mx, w) <- toGen w' ws x'- return (Right mx, exhibit w)----- | Floating point modulo operation. Note that @fmod n 0@ = 0.--fmod :: Double -> Double -> Double-fmod _ 0 = 0-fmod n d = n - d * realToFrac (floor $ n/d)----- | Inhibit, when the left signal is true.------ Inhibits on true left signal. No feedback.--forbid :: Monad m => Wire m (Bool, a) a-forbid =- mkFix $ \_ (b, x) ->- return (if b then Left (inhibitEx "Forbidden condition met") else Right x)----- | Inhibit, when the signal is true.------ Inhibits on true signal. No feedback.--forbid_ :: Monad m => Wire m Bool ()-forbid_ =- mkFix $ \_ b ->- return (if b then Left (inhibitEx "Forbidden condition met") else Right ())----- | Effectively prevent a wire from rewiring itself. This function--- will turn any stateful wire into a stateless wire, rendering most--- wires useless.------ Note: This function should not be used normally. Use it only, if--- you know exactly what you're doing.------ Same inhibition properties as first instant of argument wire. Same--- feedback properties as first instant of argument wire.--freeze :: Monad m => Wire m a b -> Wire m a b-freeze w =- mkFix $ \ws x' -> do- (mx, _) <- toGen w ws x'- return mx----- | Keep the latest output.------ Inhibits until first signal from argument wire. Same feedback--- properties as argument wire.--hold :: forall a b m. Monad m => Wire m a b -> Wire m a b-hold w' =- mkGen $ \ws x' -> do- (mx, w) <- toGen w' ws x'- case mx of- Right x -> return (mx, hold' x w)- Left _ -> return (mx, hold w)-- where- hold' :: b -> Wire m a b -> Wire m a b- hold' x0 w' =- mkGen $ \ws x' -> do- (mx, w) <- toGen w' ws x'- case mx of- Left _ -> return (Right x0, hold' x0 w)- Right x -> return (Right x, hold' x w)----- | Identity signal transformer. Outputs its input.------ Never inhibits. Feedback by delay.--identity :: Monad m => Wire m a a-identity = id----- | Unconditional inhibition with the given inhibition exception.------ Always inhibits.--inhibit :: (Exception e, Monad m) => Wire m e b-inhibit =- mkFix $ \_ ex -> return (Left (toException ex))----- | Unconditional inhibition with default inhibition exception.------ Always inhibits.--inhibit_ :: Monad m => Wire m a b-inhibit_ = zeroArrow----- | Inject the input 'Either' signal.------ Inhibits on 'Left' signals.--inject :: forall a e m. (Exception e, Monad m) => Wire m (Either e a) a-inject = mkFix $ \_ mx -> return (leftToEx mx)- where- leftToEx :: Either e a -> Either SomeException a- leftToEx (Right x) = Right x- leftToEx (Left ex) = Left (toException ex)----- | Inject the input 'Maybe' signal.------ Inhibits on 'Nothing' signals.--injectMaybe :: Monad m => Wire m (Maybe a) a-injectMaybe =- mkFix $ \_ mx ->- return (maybe (Left (inhibitEx "No signal to inject")) Right mx)----- | Keep the value in the first instant forever.------ Never inhibits. Feedback by delay.--keep :: Monad m => Wire m a a-keep = mkGen $ \_ x -> return (Right x, constant x)----- | Apply an arrow to a list of inputs.--mapA :: ArrowChoice a => a b c -> a [b] [c]-mapA a =- proc x ->- case x of- [] -> returnA -< []- (x0:xs) -> arr (uncurry (:)) <<< a *** mapA a -< (x0, xs)----- | Inhibit, when the left signal is false.------ Inhibits on false left signal. No feedback.--require :: Monad m => Wire m (Bool, a) a-require =- mkFix $ \_ (b, x) ->- return (if b then Right x else Left (inhibitEx "Required condition not met"))----- | Inhibit, when the signal is false.------ Inhibits on false signal. No feedback.--require_ :: Monad m => Wire m Bool ()-require_ =- mkFix $ \_ b ->- return (if b then Right () else Left (inhibitEx "Required condition not met"))----- | Sample the given wire at specific intervals. Use this instead of--- 'discrete', if you want to prevent the signal from passing through--- the wire all the time. Returns the most recent result.------ The left signal interval is allowed to become zero, at which point--- the signal is passed through the wire at every instant.------ Inhibits until the first result from the argument wire. Same--- feedback properties as argument wire.--sample :: forall a b m. Monad m => Wire m a b -> Wire m (Time, a) b-sample w' =- WGen $ \ws@(wsDTime -> dt) (_, x') -> do- (mx, w) <- toGen w' ws x'- return (mx, sample' dt mx w)-- where- sample' :: Time -> Output b -> Wire m a b -> Wire m (Time, a) b- sample' t' mx' w' =- WGen $ \ws@(wsDTime -> dt) (int, x'') ->- let t = t' + dt in- if t >= int || int <= 0- then do- (mmx, w) <- toGen w' (ws { wsDTime = t }) x''- let mx = either (const mx') (const mmx) mmx- nextT = fmod t int- () `seq` return (mx, sample' nextT mx w)- else- return (mx', sample' t mx' w')----- | Wait for the first signal from the given wire and keep it forever.------ Inhibits until signal from argument wire. Direct feedback, if--- argument wire never inhibits, otherwise no feedback.--swallow :: Monad m => Wire m a b -> Wire m a b-swallow w' =- WGen $ \ws x' -> do- (mx, w) <- toGen w' ws x'- return (mx, either (const (swallow w)) constant mx)----- | Swap the values in a tuple.--swap :: (a, b) -> (b, a)-swap (x, y) = (y, x)----- | Get the local time.------ Never inhibits.--time :: Monad m => Wire m a Time-time = timeFrom 0----- | Get the local time, assuming it starts from the given value.------ Never inhibits.--timeFrom :: Monad m => Time -> Wire m a Time-timeFrom t' =- mkGen $ \(wsDTime -> dt) _ ->- let t = t' + dt- in t `seq` return (Right t, timeFrom t)
− FRP/NetWire/Wire.hs
@@ -1,425 +0,0 @@--- |--- Module: FRP.NetWire.Wire--- Copyright: (c) 2011 Ertugrul Soeylemez--- License: BSD3--- Maintainer: Ertugrul Soeylemez <es@ertes.de>------ The module contains the main 'Wire' type and its type class--- instances. It also provides convenience functions for wire--- developers.--module FRP.NetWire.Wire- ( -- * Wires- Wire(..),- WireState(..),-- -- * Auxilliary types- InhibitException(..),- Output,- SF,- Time,-- -- * Utilities- cleanupWireState,- inhibitEx,- initWireState,- mkFix,- mkGen,- noEvent,- toGen,-- -- * Wire transformers- appEvent,- appFirst,- appFrozen- )- where--import Control.Applicative-import Control.Arrow-import Control.Category-import Control.Concurrent.STM-import Control.Exception (Exception(..), SomeException)-import Control.Monad-import Control.Monad.Fix-import Control.Monad.IO.Class-import Data.Functor.Identity-import Data.Typeable-import Prelude hiding ((.), id)-import System.Random.Mersenne----- | Inhibition exception with an informative message. This exception--- is the result of signal inhibition, where no further exception--- information is available.--data InhibitException =- InhibitException String- deriving (Read, Show, Typeable)--instance Exception InhibitException----- | Functor for output signals.--type Output = Either SomeException----- | Signal functions are wires over the identity monad.--type SF = Wire Identity----- | Time.--type Time = Double----- | A wire is a network of signal transformers.--data Wire :: (* -> *) -> * -> * -> * where- WArr :: (a -> b) -> Wire m a b- WGen :: (WireState m -> a -> m (Output b, Wire m a b)) -> Wire m a b----- | This instance corresponds to the 'ArrowPlus' and 'ArrowZero'--- instances.--instance Monad m => Alternative (Wire m a) where- empty = zeroArrow- (<|>) = (<+>)----- | Applicative interface to signal networks.--instance Monad m => Applicative (Wire m a) where- pure = arr . const- wf <*> wx = wf &&& wx >>> arr (uncurry ($))----- | Arrow interface to signal networks.--instance Monad m => Arrow (Wire m) where- arr = WArr-- first (WGen f) = WGen $ \ws (x', y) -> liftM (fmap (, y) *** first) (f ws x')- first (WArr f) = WArr (first f)-- second (WGen f) = WGen $ \ws (x, y') -> liftM (fmap (x,) *** second) (f ws y')- second (WArr f) = WArr (second f)-- (***) = wsidebyside 0- (&&&) = wboth 0----- | The 'app' combinator has the behaviour of 'appFrozen'. Note that--- this effectively keeps a wire bound by the "-<<" syntax from--- evolving. For alternative embedding combinators see also 'appEvent'--- and 'appFirst'.--instance Monad m => ArrowApply (Wire m) where- app = appFrozen----- | Signal routing. Unused routes are ignored. Note that they still--- run in real time, i.e. the time deltas passed are accumulated.--instance Monad m => ArrowChoice (Wire m) where- left w' = wl 0- where- wl t' =- WGen $ \ws@(wsDTime -> dt) mx' ->- let t = t' + dt in- t `seq`- case mx' of- Left x' -> liftM (fmap Left *** left) (toGen w' (ws { wsDTime = t }) x')- Right x -> return (pure (Right x), wl t)-- right w' = wl 0- where- wl t' =- WGen $ \ws@(wsDTime -> dt) mx' ->- let t = t' + dt in- t `seq`- case mx' of- Right x' -> liftM (fmap Right *** right) (toGen w' (ws { wsDTime = t }) x')- Left x -> return (pure (Left x), wl t)-- wf' +++ wg' = wl 0 0 wf' wg'- where- wl tf' tg' wf' wg' =- WGen $ \ws@(wsDTime -> dt) mx' ->- let tf = tf' + dt- tg = tg' + dt in- tf `seq` tg `seq`- case mx' of- Left x' -> do- (mx, wf) <- toGen wf' (ws { wsDTime = tf }) x'- return (fmap Left mx, wl 0 tg wf wg')- Right x' -> do- (mx, wg) <- toGen wg' (ws { wsDTime = tg }) x'- return (fmap Right mx, wl tf 0 wf' wg)-- wf' ||| wg' = wl 0 0 wf' wg'- where- wl tf' tg' wf' wg' =- WGen $ \ws@(wsDTime -> dt) mx' ->- let tf = tf' + dt- tg = tg' + dt in- tf `seq` tg `seq`- case mx' of- Left x' -> do- (mx, wf) <- toGen wf' (ws { wsDTime = tf }) x'- return (mx, wl 0 tg wf wg')- Right x' -> do- (mx, wg) <- toGen wg' (ws { wsDTime = tg }) x'- return (mx, wl tf 0 wf' wg)----- | Value recursion. Warning: Recursive signal networks must never--- inhibit. Make use of 'FRP.NetWire.Tools.exhibit' or--- 'FRP.NetWire.Event.event' for wires that may inhibit.--instance MonadFix m => ArrowLoop (Wire m) where- loop w' =- WGen $ \ws x' -> do- rec (Right (x, d), w) <- toGen w' ws (x', d)- return (Right x, loop w)----- | Left-biased signal network combination. If the left arrow--- inhibits, the right arrow is tried. If both inhibit, their--- combination inhibits. Ignored wire networks still run in real time,--- i.e. passed time deltas are accumulated.--instance Monad m => ArrowPlus (Wire m) where- wf'@(WGen _) <+> wg' = wl 0 wf' wg'- where- wl t' wf' wg' =- WGen $ \ws@(wsDTime -> dt) x' -> do- let t = t' + dt- (mx, wf) <- toGen wf' ws x'- case mx of- Right _ -> t `seq` return (mx, wl t wf wg')- Left _ -> do- (mx2, wg) <- t `seq` toGen wg' (ws { wsDTime = t }) x'- return (mx2, wl 0 wf wg)-- wa@(WArr _) <+> _ = wa----- | The zero arrow always inhibits.--instance Monad m => ArrowZero (Wire m) where- zeroArrow = mkFix $ \_ _ -> return (Left (inhibitEx "Signal inhibited"))----- | Identity signal network and signal network sequencing.--instance Monad m => Category (Wire m) where- id = WArr id- (.) = flip (wcompose 0)----- | Map over the output of a signal network.--instance Monad m => Functor (Wire m a) where- fmap f = (>>> arr f)----- | The state of the wire.--data WireState :: (* -> *) -> * where- ImpureState ::- MonadIO m =>- { wsDTime :: Double, -- ^ Time difference for current instant.- wsRndGen :: MTGen, -- ^ Random number generator.- wsReqVar :: TVar Int -- ^ Request counter.- } -> WireState m-- PureState :: { wsDTime :: Double } -> WireState m----- | Embeds the input wire (left signal) into the network with the given--- input signal (right signal). Each time the input wire is a 'Just',--- the current state of the last wire is discarded and the new wire is--- evolved instead. New wires can be generated by an event wire and--- catched via 'FRP.NetWire.Event.event'. The initial wire is given by--- the argument.------ Inhibits whenever the embedded wire inhibits. Same feedback--- behaviour as the embedded wire.--appEvent ::- forall a b m. Monad m- => Wire m a b- -> Wire m (Maybe (Wire m a b), a) b-appEvent cw' =- mkGen $ \ws (mw, x') -> do- let w' = maybe cw' id mw- (mx, w) <- toGen w' ws x'- return (mx, appEvent w)----- | Embeds the first received input wire (left signal) into the--- network, feeding it the right signal. This wire respects its left--- signal only in the first instant, after which it wraps that wire's--- evolution.------ Inhibits whenever the embedded wire inhibits. Same feedback--- behaviour as the embedded wire.--appFirst :: forall a b m. Monad m => Wire m (Wire m a b, a) b-appFirst =- mkGen $ \ws (w', x') -> do- (mx, w) <- toGen w' ws x'- return (mx, embed w)-- where- embed :: Wire m a b -> Wire m (Wire m a b, a) b- embed w' =- mkGen $ \ws (_, x') -> do- (mx, w) <- toGen w' ws x'- return (mx, embed w)----- | Embeds the first instant of the input wire (left signal) into the--- network, feeding it the right signal. This wire respects its left--- signal in all instances, such that the embedded wire cannot evolve.------ Inhibits whenever the embedded wire inhibits. Same feedback--- behaviour as the embedded wire.--appFrozen :: Monad m => Wire m (Wire m a b, a) b-appFrozen = mkFix $ \ws (w, x') -> liftM fst (toGen w ws x')----- | Clean up wire state.--cleanupWireState :: WireState m -> IO ()-cleanupWireState _ = return ()----- | Construct an 'InhibitException' wrapped in a 'SomeException'.--inhibitEx :: String -> SomeException-inhibitEx = toException . InhibitException----- | Initialize wire state.--initWireState :: MonadIO m => IO (WireState m)-initWireState =- ImpureState- <$> pure 0- <*> getStdGen- <*> newTVarIO 0----- | Create a fixed wire from the given function. This is a smart--- constructor. It creates a stateless wire.--mkFix :: Monad m => (WireState m -> a -> m (Output b)) -> Wire m a b-mkFix f = let w = WGen $ \ws -> liftM (, w) . f ws in w----- | Create a generic (i.e. possibly stateful) wire from the given--- function. This is a smart constructor. Please use it instead of the--- 'WGen' constructor for creating generic wires.--mkGen :: (WireState m -> a -> m (Output b, Wire m a b)) -> Wire m a b-mkGen = WGen----- | Construct an 'InhibitException' wrapped in a 'SomeException' with a--- message indicating that a certain event did not happen.--noEvent :: SomeException-noEvent = inhibitEx "No event"----- | Extract the transition function of a wire. Unless there is reason--- (like optimization) to pattern-match against the 'Wire' constructors,--- this function is the recommended way to evolve a wire.--toGen :: Monad m => Wire m a b -> WireState m -> a -> m (Output b, Wire m a b)-toGen (WGen f) ws x = f ws x-toGen wf@(WArr f) _ x = return (Right (f x), wf)----- | Efficient signal sharing.--wboth :: Monad m => Time -> Wire m a b -> Wire m a c -> Wire m a (b, c)-wboth t' (WGen f) wg'@(WGen g) =- WGen $ \ws@(wsDTime -> dt) x' -> do- let t = t' + dt- (mx1, wf) <- t `seq` f ws x'- case mx1 of- Left ex -> return (Left ex, wboth t wf wg')- Right _ -> do- (mx2, wg) <- g ws x'- return (liftA2 (,) mx1 mx2, wboth 0 wf wg)--wboth t' wf@(WArr f) (WGen g) =- WGen $ \ws x' -> do- (mx2, wg) <- g ws x'- return (fmap (f x',) mx2, wboth t' wf wg)--wboth t' (WGen f) wg@(WArr g) =- WGen $ \ws x' -> do- (mx1, wf) <- f ws x'- return (fmap (, g x') mx1, wboth t' wf wg)--wboth _ (WArr f) (WArr g) = WArr (f &&& g)----- | Efficient forward-composition of two wires.--wcompose :: Monad m => Time -> Wire m a b -> Wire m b c -> Wire m a c-wcompose t' (WGen f) wg'@(WGen g) =- WGen $ \ws@(wsDTime -> dt) x'' -> do- let t = t' + dt- (mx', wf) <- t `seq` f ws x''- case mx' of- Left ex -> return (Left ex, wcompose t wf wg')- Right x' -> do- (mx, wg) <- g (ws { wsDTime = t }) x'- return (mx, wcompose 0 wf wg)--wcompose t' wf@(WArr f) (WGen g) =- WGen $ \ws x' -> do- (mx, wg) <- g ws (f x')- return (mx, wcompose t' wf wg)--wcompose t' (WGen f) wg@(WArr g) =- WGen $ \ws x' -> do- (mx, wf) <- f ws x'- return (fmap g mx, wcompose t' wf wg)--wcompose _ (WArr f) (WArr g) = WArr (g . f)----- | Run two signals through two signal networks.--wsidebyside :: Monad m => Time -> Wire m a c -> Wire m b d -> Wire m (a, b) (c, d)-wsidebyside t' (WGen f) wg'@(WGen g) =- WGen $ \ws@(wsDTime -> dt) (x', y') -> do- let t = t' + dt- (mx, wf) <- t `seq` f ws x'- case mx of- Left ex -> return (Left ex, wsidebyside t wf wg')- Right _ -> do- (my, wg) <- g ws y'- return (liftA2 (,) mx my, wsidebyside 0 wf wg)--wsidebyside t' wf@(WArr f) (WGen g) =- WGen $ \ws (x', y') -> do- (my, wg) <- g ws y'- return (fmap (f x',) my, wsidebyside t' wf wg)--wsidebyside t' (WGen f) wg@(WArr g) =- WGen $ \ws (x', y') -> do- (mx, wf) <- f ws x'- return (fmap (, g y') mx, wsidebyside t' wf wg)--wsidebyside _ (WArr f) (WArr g) = WArr (f *** g)
LICENSE view
@@ -1,4 +1,4 @@-netwire license+Netwire license Copyright (c) 2011, Ertugrul Soeylemez All rights reserved.
netwire.cabal view
@@ -1,75 +1,78 @@ Name: netwire-Version: 1.2.7-Category: FRP, Network-Synopsis: Arrowized FRP implementation+Version: 2.0.0+Category: Control, FRP+Synopsis: Generic automaton arrow transformer and useful tools Maintainer: Ertugrul Söylemez <es@ertes.de> Author: Ertugrul Söylemez <es@ertes.de> Copyright: (c) 2011 Ertugrul Söylemez License: BSD3 License-file: LICENSE Build-type: Simple-Stability: beta+Stability: experimental Cabal-version: >= 1.8 Description:- This library provides an arrowized functional reactive programming- (FRP) implementation. From the basic idea it is similar to Yampa- and Animas, but has a much simpler internal representation and a lot- of new features.+ This library implements a powerful generic automaton arrow+ transformer. Library Build-depends:- base >= 4 && <= 5,+ arrows >= 0.4.4,+ base >= 4 && < 5, containers >= 0.4.0, deepseq >= 1.1.0,--- forkable-monad >= 0.1.1,- mersenne-random >= 1.0.0,- monad-control >= 0.2.0, random >= 1.0.0,- stm >= 2.2.0, time >= 1.2.0, transformers >= 0.2.2,- vector >= 0.7.1,- vector-space >= 0.7.3+ vector >= 0.9,+ vector-space >= 0.7.8 Extensions: Arrows- DeriveDataTypeable- DoRec, FlexibleInstances GADTs- RankNTypes+ MultiParamTypeClasses ScopedTypeVariables TupleSections TypeFamilies+ TypeOperators+ UndecidableInstances ViewPatterns GHC-Options: -W Exposed-modules:- FRP.NetWire- FRP.NetWire.Analyze- FRP.NetWire.Calculus- FRP.NetWire.Event- FRP.NetWire.IO- FRP.NetWire.Pure- FRP.NetWire.Random- FRP.NetWire.Request- FRP.NetWire.Session- FRP.NetWire.Switch- FRP.NetWire.Tools- FRP.NetWire.Wire+ 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.Event+ Control.Wire.Prefab.Queue+ Control.Wire.Prefab.Random+ Control.Wire.Prefab.Sample+ Control.Wire.Prefab.Simple+ Control.Wire.Prefab.Split+ Control.Wire.Session+ Control.Wire.Tools+ Control.Wire.Trans+ Control.Wire.Trans.Combine+ Control.Wire.Trans.Exhibit+ Control.Wire.Trans.Sample+ Control.Wire.Trans.Simple+ Control.Wire.Types --- Executable netwire-test+-- Executable netwire2-test -- Build-depends:--- base >= 4 && <= 5,+-- arrows,+-- base >= 4 && < 5, -- containers,--- instinct, -- netwire,--- OpenGL,--- SDL,--- transformers,--- vector+-- transformers -- Extensions: -- Arrows--- ScopedTypeVariables+-- TupleSections+-- TypeFamilies -- ViewPatterns--- Hs-Source-Dirs: test+-- Hs-source-dirs: test -- Main-is: Main.hs -- GHC-Options: -W -threaded -rtsopts