diff --git a/Control/Wire.hs b/Control/Wire.hs new file mode 100644 --- /dev/null +++ b/Control/Wire.hs @@ -0,0 +1,31 @@ +-- | +-- Module: Control.Wire +-- Copyright: (c) 2011 Ertugrul Soeylemez +-- License: BSD3 +-- Maintainer: Ertugrul Soeylemez +-- +-- 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 diff --git a/Control/Wire/Classes.hs b/Control/Wire/Classes.hs new file mode 100644 --- /dev/null +++ b/Control/Wire/Classes.hs @@ -0,0 +1,65 @@ +-- | +-- Module: Control.Wire.Classes +-- Copyright: (c) 2011 Ertugrul Soeylemez +-- License: BSD3 +-- Maintainer: Ertugrul Soeylemez +-- +-- 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 diff --git a/Control/Wire/Instances.hs b/Control/Wire/Instances.hs new file mode 100644 --- /dev/null +++ b/Control/Wire/Instances.hs @@ -0,0 +1,54 @@ +-- | +-- Module: Control.Wire.Instances +-- Copyright: (c) 2011 Ertugrul Soeylemez +-- License: BSD3 +-- Maintainer: Ertugrul Soeylemez +-- +-- 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 = (<|>) diff --git a/Control/Wire/Prefab.hs b/Control/Wire/Prefab.hs new file mode 100644 --- /dev/null +++ b/Control/Wire/Prefab.hs @@ -0,0 +1,33 @@ +-- | +-- Module: Control.Wire.Prefab +-- Copyright: (c) 2011 Ertugrul Soeylemez +-- License: BSD3 +-- Maintainer: Ertugrul Soeylemez +-- +-- 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 diff --git a/Control/Wire/Prefab/Accum.hs b/Control/Wire/Prefab/Accum.hs new file mode 100644 --- /dev/null +++ b/Control/Wire/Prefab/Accum.hs @@ -0,0 +1,58 @@ +-- | +-- Module: Control.Wire.Prefab.Accum +-- Copyright: (c) 2011 Ertugrul Soeylemez +-- License: BSD3 +-- Maintainer: Ertugrul Soeylemez +-- +-- 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)) diff --git a/Control/Wire/Prefab/Analyze.hs b/Control/Wire/Prefab/Analyze.hs new file mode 100644 --- /dev/null +++ b/Control/Wire/Prefab/Analyze.hs @@ -0,0 +1,212 @@ +-- | +-- Module: Control.Wire.Prefab.Analyze +-- Copyright: (c) 2011 Ertugrul Soeylemez +-- License: BSD3 +-- Maintainer: Ertugrul Soeylemez +-- +-- 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'' diff --git a/Control/Wire/Prefab/Calculus.hs b/Control/Wire/Prefab/Calculus.hs new file mode 100644 --- /dev/null +++ b/Control/Wire/Prefab/Calculus.hs @@ -0,0 +1,67 @@ +-- | +-- Module: Control.Wire.Prefab.Calculus +-- Copyright: (c) 2011 Ertugrul Soeylemez +-- License: BSD3 +-- Maintainer: Ertugrul Soeylemez +-- +-- 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) diff --git a/Control/Wire/Prefab/Clock.hs b/Control/Wire/Prefab/Clock.hs new file mode 100644 --- /dev/null +++ b/Control/Wire/Prefab/Clock.hs @@ -0,0 +1,61 @@ +-- | +-- Module: Control.Wire.Prefab.Clock +-- Copyright: (c) 2011 Ertugrul Soeylemez +-- License: BSD3 +-- Maintainer: Ertugrul Soeylemez +-- +-- 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 diff --git a/Control/Wire/Prefab/Event.hs b/Control/Wire/Prefab/Event.hs new file mode 100644 --- /dev/null +++ b/Control/Wire/Prefab/Event.hs @@ -0,0 +1,293 @@ +-- | +-- Module: Control.Wire.Prefab.Event +-- Copyright: (c) 2011 Ertugrul Soeylemez +-- License: BSD3 +-- Maintainer: Ertugrul Soeylemez +-- +-- 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) diff --git a/Control/Wire/Prefab/Queue.hs b/Control/Wire/Prefab/Queue.hs new file mode 100644 --- /dev/null +++ b/Control/Wire/Prefab/Queue.hs @@ -0,0 +1,57 @@ +-- | +-- Module: Control.Wire.Prefab.Queue +-- Copyright: (c) 2011 Ertugrul Soeylemez +-- License: BSD3 +-- Maintainer: Ertugrul Soeylemez +-- +-- 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) diff --git a/Control/Wire/Prefab/Random.hs b/Control/Wire/Prefab/Random.hs new file mode 100644 --- /dev/null +++ b/Control/Wire/Prefab/Random.hs @@ -0,0 +1,62 @@ +-- | +-- Module: Control.Wire.Prefab.Random +-- Copyright: (c) 2011 Ertugrul Soeylemez +-- License: BSD3 +-- Maintainer: Ertugrul Soeylemez +-- +-- 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)) diff --git a/Control/Wire/Prefab/Sample.hs b/Control/Wire/Prefab/Sample.hs new file mode 100644 --- /dev/null +++ b/Control/Wire/Prefab/Sample.hs @@ -0,0 +1,51 @@ +-- | +-- Module: Control.Wire.Prefab.Sample +-- Copyright: (c) 2011 Ertugrul Soeylemez +-- License: BSD3 +-- Maintainer: Ertugrul Soeylemez +-- +-- 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) diff --git a/Control/Wire/Prefab/Simple.hs b/Control/Wire/Prefab/Simple.hs new file mode 100644 --- /dev/null +++ b/Control/Wire/Prefab/Simple.hs @@ -0,0 +1,80 @@ +-- | +-- Module: Control.Wire.Prefab.Simple +-- Copyright: (c) 2011 Ertugrul Soeylemez +-- License: BSD3 +-- Maintainer: Ertugrul Soeylemez +-- +-- 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) diff --git a/Control/Wire/Prefab/Split.hs b/Control/Wire/Prefab/Split.hs new file mode 100644 --- /dev/null +++ b/Control/Wire/Prefab/Split.hs @@ -0,0 +1,59 @@ +-- | +-- Module: Control.Wire.Prefab.Split +-- Copyright: (c) 2011 Ertugrul Soeylemez +-- License: BSD3 +-- Maintainer: Ertugrul Soeylemez +-- +-- 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)) diff --git a/Control/Wire/Session.hs b/Control/Wire/Session.hs new file mode 100644 --- /dev/null +++ b/Control/Wire/Session.hs @@ -0,0 +1,60 @@ +-- | +-- Module: Control.Wire.Session +-- Copyright: (c) 2011 Ertugrul Soeylemez +-- License: BSD3 +-- Maintainer: Ertugrul Soeylemez +-- +-- 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) diff --git a/Control/Wire/Tools.hs b/Control/Wire/Tools.hs new file mode 100644 --- /dev/null +++ b/Control/Wire/Tools.hs @@ -0,0 +1,34 @@ +-- | +-- Module: Control.Wire.Tools +-- Copyright: (c) 2011 Ertugrul Soeylemez +-- License: BSD3 +-- Maintainer: Ertugrul Soeylemez +-- +-- 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 -< [] diff --git a/Control/Wire/Trans.hs b/Control/Wire/Trans.hs new file mode 100644 --- /dev/null +++ b/Control/Wire/Trans.hs @@ -0,0 +1,21 @@ +-- | +-- Module: Control.Wire.Trans +-- Copyright: (c) 2011 Ertugrul Soeylemez +-- License: BSD3 +-- Maintainer: Ertugrul Soeylemez +-- +-- 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 diff --git a/Control/Wire/Trans/Combine.hs b/Control/Wire/Trans/Combine.hs new file mode 100644 --- /dev/null +++ b/Control/Wire/Trans/Combine.hs @@ -0,0 +1,104 @@ +-- | +-- Module: Control.Wire.Trans.Combine +-- Copyright: (c) 2011 Ertugrul Soeylemez +-- License: BSD3 +-- Maintainer: Ertugrul Soeylemez +-- +-- 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) diff --git a/Control/Wire/Trans/Exhibit.hs b/Control/Wire/Trans/Exhibit.hs new file mode 100644 --- /dev/null +++ b/Control/Wire/Trans/Exhibit.hs @@ -0,0 +1,47 @@ +-- | +-- Module: Control.Wire.Trans.Exhibit +-- Copyright: (c) 2011 Ertugrul Soeylemez +-- License: BSD3 +-- Maintainer: Ertugrul Soeylemez +-- +-- 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) diff --git a/Control/Wire/Trans/Sample.hs b/Control/Wire/Trans/Sample.hs new file mode 100644 --- /dev/null +++ b/Control/Wire/Trans/Sample.hs @@ -0,0 +1,115 @@ +-- | +-- Module: Control.Wire.Trans.Sample +-- Copyright: (c) 2011 Ertugrul Soeylemez +-- License: BSD3 +-- Maintainer: Ertugrul Soeylemez +-- +-- 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) diff --git a/Control/Wire/Trans/Simple.hs b/Control/Wire/Trans/Simple.hs new file mode 100644 --- /dev/null +++ b/Control/Wire/Trans/Simple.hs @@ -0,0 +1,48 @@ +-- | +-- Module: Control.Wire.Trans.Simple +-- Copyright: (c) 2011 Ertugrul Soeylemez +-- License: BSD3 +-- Maintainer: Ertugrul Soeylemez +-- +-- 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 >-- diff --git a/Control/Wire/Types.hs b/Control/Wire/Types.hs new file mode 100644 --- /dev/null +++ b/Control/Wire/Types.hs @@ -0,0 +1,415 @@ +-- | +-- Module: Control.Wire.Types +-- Copyright: (c) 2011 Ertugrul Soeylemez +-- License: BSD3 +-- Maintainer: Ertugrul Soeylemez +-- +-- 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 diff --git a/FRP/NetWire.hs b/FRP/NetWire.hs deleted file mode 100644 --- a/FRP/NetWire.hs +++ /dev/null @@ -1,68 +0,0 @@ --- | --- Module: FRP.NetWire --- Copyright: (c) 2011 Ertugrul Soeylemez --- License: BSD3 --- Maintainer: Ertugrul Soeylemez --- --- 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 diff --git a/FRP/NetWire/Analyze.hs b/FRP/NetWire/Analyze.hs deleted file mode 100644 --- a/FRP/NetWire/Analyze.hs +++ /dev/null @@ -1,193 +0,0 @@ --- | --- Module: FRP.NetWire.Analyze --- Copyright: (c) 2011 Ertugrul Soeylemez --- License: BSD3 --- Maintainer: Ertugrul Soeylemez --- --- 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) diff --git a/FRP/NetWire/Calculus.hs b/FRP/NetWire/Calculus.hs deleted file mode 100644 --- a/FRP/NetWire/Calculus.hs +++ /dev/null @@ -1,59 +0,0 @@ --- | --- Module: FRP.NetWire.Calculus --- Copyright: (c) 2011 Ertugrul Soeylemez --- License: BSD3 --- Maintainer: Ertugrul Soeylemez --- --- 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) diff --git a/FRP/NetWire/Event.hs b/FRP/NetWire/Event.hs deleted file mode 100644 --- a/FRP/NetWire/Event.hs +++ /dev/null @@ -1,304 +0,0 @@ --- | --- Module: FRP.NetWire.Event --- Copyright: (c) 2011 Ertugrul Soeylemez --- License: BSD3 --- Maintainer: Ertugrul Soeylemez --- --- 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) diff --git a/FRP/NetWire/IO.hs b/FRP/NetWire/IO.hs deleted file mode 100644 --- a/FRP/NetWire/IO.hs +++ /dev/null @@ -1,41 +0,0 @@ --- | --- Module: FRP.NetWire.IO --- Copyright: (c) 2011 Ertugrul Soeylemez --- License: BSD3 --- Maintainer: Ertugrul Soeylemez --- --- 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 diff --git a/FRP/NetWire/Pure.hs b/FRP/NetWire/Pure.hs deleted file mode 100644 --- a/FRP/NetWire/Pure.hs +++ /dev/null @@ -1,29 +0,0 @@ --- | --- Module: FRP.NetWire.Pure --- Copyright: (c) 2011 Ertugrul Soeylemez --- License: BSD3 --- Maintainer: Ertugrul Soeylemez --- --- 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' diff --git a/FRP/NetWire/Random.hs b/FRP/NetWire/Random.hs deleted file mode 100644 --- a/FRP/NetWire/Random.hs +++ /dev/null @@ -1,103 +0,0 @@ --- | --- Module: FRP.NetWire.Random --- Copyright: (c) 2011 Ertugrul Soeylemez --- License: BSD3 --- Maintainer: Ertugrul Soeylemez --- --- 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 diff --git a/FRP/NetWire/Request.hs b/FRP/NetWire/Request.hs deleted file mode 100644 --- a/FRP/NetWire/Request.hs +++ /dev/null @@ -1,240 +0,0 @@ --- | --- Module: FRP.NetWire.Request --- Copyright: (c) 2011 Ertugrul Soeylemez --- License: BSD3 --- Maintainer: Ertugrul Soeylemez --- --- 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 diff --git a/FRP/NetWire/Session.hs b/FRP/NetWire/Session.hs deleted file mode 100644 --- a/FRP/NetWire/Session.hs +++ /dev/null @@ -1,222 +0,0 @@ --- | --- Module: FRP.NetWire.Session --- Copyright: (c) 2011 Ertugrul Soeylemez --- License: BSD3 --- Maintainer: Ertugrul Soeylemez --- --- 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) diff --git a/FRP/NetWire/Switch.hs b/FRP/NetWire/Switch.hs deleted file mode 100644 --- a/FRP/NetWire/Switch.hs +++ /dev/null @@ -1,190 +0,0 @@ --- | --- Module: FRP.NetWire.Switch --- Copyright: (c) 2011 Ertugrul Soeylemez --- License: BSD3 --- Maintainer: Ertugrul Soeylemez --- --- 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' diff --git a/FRP/NetWire/Tools.hs b/FRP/NetWire/Tools.hs deleted file mode 100644 --- a/FRP/NetWire/Tools.hs +++ /dev/null @@ -1,409 +0,0 @@ --- | --- Module: FRP.NetWire.Tools --- Copyright: (c) 2011 Ertugrul Soeylemez --- License: BSD3 --- Maintainer: Ertugrul Soeylemez --- --- 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) diff --git a/FRP/NetWire/Wire.hs b/FRP/NetWire/Wire.hs deleted file mode 100644 --- a/FRP/NetWire/Wire.hs +++ /dev/null @@ -1,425 +0,0 @@ --- | --- Module: FRP.NetWire.Wire --- Copyright: (c) 2011 Ertugrul Soeylemez --- License: BSD3 --- Maintainer: Ertugrul Soeylemez --- --- 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) diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -netwire license +Netwire license Copyright (c) 2011, Ertugrul Soeylemez All rights reserved. diff --git a/netwire.cabal b/netwire.cabal --- a/netwire.cabal +++ b/netwire.cabal @@ -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 Author: Ertugrul Söylemez 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