reenact (empty) → 0.6
raw patch · 9 files changed
+1769/−0 lines, 9 filesdep +HCodecsdep +basedep +hamidsetup-changed
Dependencies added: HCodecs, base, hamid, hosc, stm, time, vector-space
Files
- COPYING +26/−0
- Setup.lhs +4/−0
- reenact.cabal +44/−0
- src/Control/Reactive.hs +1217/−0
- src/Control/Reactive/Chan.hs +42/−0
- src/Control/Reactive/Midi.hs +87/−0
- src/Control/Reactive/Osc.hs +70/−0
- src/Control/Reactive/Util.hs +237/−0
- src/Control/Reactive/Var.hs +42/−0
+ COPYING view
@@ -0,0 +1,26 @@++Copyright (c) 2013, Hans Höglund+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:+ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.+ * Redistributions in binary form must reproduce the above copyright+ notice, this list of conditions and the following disclaimer in the+ documentation and/or other materials provided with the distribution.+ * Neither the name of the <organization> nor the+ names of its contributors may be used to endorse or promote products+ derived from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND+ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL <COPYRIGHT HOLDER> BE LIABLE FOR ANY+DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES+(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;+LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND+ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS+SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.+
+ Setup.lhs view
@@ -0,0 +1,4 @@+#! /usr/bin/env runhaskell++> import Distribution.Simple+> main = defaultMain
+ reenact.cabal view
@@ -0,0 +1,44 @@++name: reenact+version: 0.6+cabal-version: >= 1.2+author: Hans Hoglund+maintainer: Hans Hoglund+license: BSD3+license-file: COPYING+synopsis: A reimplementation of Conal Elliott's Reactive.+category: Music+tested-with: GHC+build-type: Simple++description: + Reenact is a reimplementation of the "Reactive" library by Conal Elliot.++ It preserves semantics and most operators of the original library. In+ particular the @Monoid@, @Applicative@ and @Monad@ instances for + @Events@, @Reactives@ and @Behaviours@ are available and have the original semantics.++ The implementation however is completely different, based on asynchronous+ channels instead of the @unamb@ operator.++library + ghc-options: -threaded -O3+ build-depends: + base >= 4 && < 5,+ stm,+ time,+ hamid >= 0.6,+ HCodecs >= 0.2.2,+ hosc,+ -- semigroups,+ -- semigroupoids,+ vector-space+ hs-source-dirs: src+ exposed-modules:+ Control.Reactive+ Control.Reactive.Chan+ Control.Reactive.Var+ Control.Reactive.Midi+ Control.Reactive.Osc+ other-modules:+ Control.Reactive.Util
+ src/Control/Reactive.hs view
@@ -0,0 +1,1217 @@++{-# LANGUAGE GADTs, TypeFamilies, ScopedTypeVariables, OverloadedStrings, BangPatterns #-}++-- |+--+-- Primitives:+-- +-- * 'Event': 'mempty', 'mappend', 'fmap'+--+-- * 'Reactive': 'fmap', 'return', 'join', '<'+--+-- * 'scatterE'+--+-- * 'accumE' or 'accumR'+--+-- * 'stepper', 'apply' (or 'sample', or 'snapshotWith')+--+-- * 'readChanE', 'writeChanE', 'getE', 'pollE', 'putE', 'runLoopUntil'+--++module Control.Reactive (++ -- * Types+ Event,+ Reactive,++ -- * Basic combinators+ -- ** Event to reactive+ stepper,+ -- switcher,+ maybeStepper,+ -- maybeSwitcher,+ -- sampleAndHold,+ sampleAndHold2,+ + -- ** Reactive to event+ apply,+ filter',+ gate,+ sample,+ snapshot,+ snapshotWith,++ -- * Merging and splitting values+ justE,+ splitE,+ eitherE,+ -- filterE,+ -- retainE,+ -- partitionE,+ -- zipR,+ -- unzipR,++ -- * Past-dependent values+ -- ** Buffering events+ lastE,+ delayE,+ -- recallE,+ recallEWith,+ diffE,+ bufferE,+ gatherE,+ scatterE,++ -- ** Accumulating values+ accumE,+ accumR,+ foldpE,+ foldpR,+ scanlE,+ scanlR,+ mapAccum,++ -- ** Special accumulators+ firstE,+ restE,+ countE,+ countR,+ monoidE,+ monoidR,++ -- ** Lifted monoids+ sumE,+ productE,+ allE,+ anyE,+ sumR,+ productR,+ allR,+ anyR, + + -- * Toggles and switches+ tickE,+ onR,+ offR,+ toggleR, ++ -- * Time+ -- Time,+ pulse,+ time,+ integral,+ + -- * Record and playback+ TransportControl(..),+ transport,+ record,+ playback,+ playback',++ -- * Special functions+ seqE,+ oftenE,++ -- * Creating events and reactives+ -- ** From standard library+ getCharE,+ putCharE,+ getLineE,+ putLineE,+ + systemTimeR,+ systemTimeSecondsR, + systemTimeDayR, +++ -- ** From channels+ readChanE,+ writeChanE,++ -- ** From IO+ getE,+ pollE,+ putE,+ -- modifyE,+ + -- * Run events+ run,+ runLoop,+ runLoopUntil, ++ -- * Utility+ Source,+ Sink,+ newSource,+ newSink, + notify,+ showing,+ runEvent,+ runReactive,+ unsafeGetReactive,+ ) where++import Prelude hiding (mapM)++import Data.Time+import Data.Monoid +import Data.Maybe+import Data.Either+import Data.String+import Data.VectorSpace hiding (Sum, getSum)+import Control.Monad+import Control.Applicative+-- import Control.Newtype++import Control.Concurrent (forkIO, forkOS, threadDelay)+import System.IO.Unsafe++import Control.Reactive.Chan+import Control.Reactive.Var+++-------------------------------------------------------------------------------------+-- Primitives+-------------------------------------------------------------------------------------++-- | +-- A stream of values.+--+-- > type Event a = [(Time, a)]+-- +data Event a where+ ENever :: Event a+ + EMerge :: Event a -> Event a -> Event a+ ESeq :: Event a -> Event b -> Event b+ EMap :: (a -> b) -> Event a -> Event b+ EPred :: (a -> Bool) -> Event a -> Event a+ EConcat :: Event [a] -> Event a++ EChan :: Chan a -> Event a+ ESource :: IO [a] -> Event a+ ESink :: (a -> IO b) -> Event a -> Event b++ ESamp :: Reactive a -> Event b -> Event a++-- | +-- A time-varying value.+--+-- > type Reactive a = Time -> a+-- +data Reactive a where+ RConst :: a -> Reactive a++ RStep :: Var a -> Event a -> Reactive a+ RAccum :: Var a -> Event (a -> a) -> Reactive a+ + RApply :: Reactive (a -> b) -> Reactive a -> Reactive b+ -- RJoin :: Reactive (Reactive a) -> Reactive a+ ++prepE :: Event a -> IO (Event a)+prepE (EMerge a b) = do+ a' <- prepE a+ b' <- prepE b+ return $ EMerge a' b'+prepE (ESeq a b) = do+ a' <- prepE a+ b' <- prepE b+ return $ ESeq a' b'+prepE (EMap f x) = do+ x' <- prepE x+ return $ EMap f x'+prepE (EPred p x) = do+ x' <- prepE x+ return $ EPred p x'+prepE (EConcat x) = do+ x' <- prepE x+ return $ EConcat x'+prepE (ESink k a) = do+ a' <- prepE a+ return $ ESink k a'+prepE (ESamp r x) = do+ r' <- prepR r+ x' <- prepE x+ return $ ESamp r' x'+prepE (EChan ch) = do+ ch' <- prepC ch+ return $ ESource ch' +prepE x = return x++prepR :: Reactive a -> IO (Reactive a)+prepR (RConst v) = do+ return $ RConst v+prepR (RStep v x) = do+ x' <- prepE x+ v' <- prepV v+ return $ RStep v' x'+prepR (RAccum v x) = do+ x' <- prepE x+ v' <- prepV v+ return $ RAccum v' x'+prepR (RApply f x) = do+ f' <- prepR f+ x' <- prepR x+ return $ RApply f' x'+-- prepR (RJoin r) = do+-- r' <- prepR r+-- return $ RJoin r'++ -- r'' <- prepR r'+ -- return $ RJoin r''++-- prepR x = return x+++prepC :: Chan a -> IO (IO [a])+prepC ch = do+ ch' <- dupChan ch+ return $ fmap maybeToList $ tryReadChan ch'++prepV :: Var a -> IO (Var a)+prepV v = dupVar v++runE :: Event a -> IO [a]+runE ENever = return []+runE (EMap f x) = fmap (fmap f) (runE x)+runE (EPred p x) = fmap (filter p) (runE x)+runE (EConcat x) = fmap concat (runE x)+runE (EMerge a b) = liftM2 (++) (runE a) (runE b)+runE (ESource i) = i+runE (ESink o x) = runE x >>= mapM o+runE (ESeq a b) = runE a >> runE b+runE (ESamp r x) = do+ r' <- runRS r+ x' <- runE x+ return $ fmap (const r') x'+ -- case x' of+ -- [] -> return []+ -- _ -> return [r']++runRS :: Reactive a -> IO a+runRS = fmap last . runR+-- Note: last is safe as reactives (per definition) always have at least one value++runR :: Reactive a -> IO [a]+runR (RConst v) = return [v]+runR (RStep v x) = do+ v' <- readVar v+ x' <- runE x + let !ys = (v':x')+ writeVar v (last ys)+ -- putStrLn $ "RStep, size is " ++ show (length x')+ return ys+runR (RAccum v x) = do+ v' <- readVar v+ x' <- runE x+ let !w = (foldr (.) id x') v'+ writeVar v w+ -- putStrLn $ "RAccum, size is " ++ show (length x')+ return [w] +runR (RApply f x) = do+ f' <- runR f+ x' <- runR x+ return $ f' <*> x'++-- FIXME leaks here?+-- FIXME we need an extra prepare here is the subnetwork is switched in+-- runR (RJoin r) = do+ -- r' <- runRS r+ -- r_ <- prepR r'+ -- runR r_++ -- r' <- runR r+ -- r_ <- mapM prepR r'+ -- r_' <- mapM runR r_+ -- return $ concat r_'++{-# INLINE runR #-}+{-# INLINE runE #-}+{-# INLINE runRS #-}++-------------------------------------------------------------------------------------+-- Event API+-------------------------------------------------------------------------------------++-- |+-- Event is a functor: 'fmap' transforms each value.+--+instance Functor (Event) where+ fmap = EMap++-- |+-- Event is a monoid: 'mempty' is the event that never occurs, 'mappend' interleaves values.+--+instance Monoid (Event a) where+ mempty = ENever+ mappend = EMerge+++-- |+-- The empty event.+--+never :: Event a+never = mempty++-- |+-- Interleave values.+--+mergeE :: Event a -> Event a -> Event a+mergeE = mappend++-- |+-- Interleave values of different types.+--+eitherE :: Event a -> Event b -> Event (Either a b)+a `eitherE` b = fmap Left a `mergeE` fmap Right b++-- |+-- Run both and behave as the second event.+--+seqE :: Event a -> Event b -> Event b+seqE = ESeq++oftenE :: Event ()+oftenE = pollE $ return $ Just ()++-- |+-- Map over values (synonym for @f \<$> xs@).+mapE :: (a -> b) -> Event a -> Event b+mapE = (<$>)++-- |+-- Filter values, semantically @filter p xs@.+--+filterE :: (a -> Bool) -> Event a -> Event a+filterE p = EPred p++-- |+-- Retain values, semantically @retain p xs@.+--+retainE :: (a -> Bool) -> Event a -> Event a+retainE p = EPred (not . p)++-- |+-- Separate chunks of values.+--+-- > scatterE [e1,e2..] = [e1] <> [e2] ..+--+scatterE :: Event [a] -> Event a+scatterE = EConcat++-- |+-- Discard empty values.+--+justE :: Event (Maybe a) -> Event a+justE = EConcat . fmap maybeToList++-- |+-- Partition values, semantically @partition p xs@.+-- +-- > let (x, y) = partitionE p e in mergeE x y ≡ e+--+partitionE :: (a -> Bool) -> Event a -> (Event a, Event a)+partitionE p e = (filterE p e, retainE p e)++-- | +-- Partition values of different types. See also 'partitionE'.+--+-- > let (x, y) in eitherE x y = splitE e ≡ e+-- +splitE :: Event (Either a b) -> (Event a, Event b)+splitE e = (justE $ fromLeft <$> e, justE $ fromRight <$> e)++unzipE :: Event (a, b) -> (Event a, Event b)+unzipE e = (fst <$> e, snd <$> e)++unzipR :: Reactive (a, b) -> (Reactive a, Reactive b)+unzipR r = (fst <$> r, snd <$> r)++-- |+-- Replace values, semantically @x <$ e@.+--+replaceE :: b -> Event a -> Event b+replaceE x = (x <$)++-- |+-- Throw away values of the event.+--+-- This is of course just @() <$ x@ but it is useful to fix the type in some cases.+--+tickE :: Event a -> Event ()+tickE = replaceE ()++-- |+-- Discard values, using an arbitrary empty element.+--+tickME :: Monoid b => Event a -> Event b+tickME = replaceE mempty++-- |+-- Event accumulator.+--+-- > a `accumE` e = (a `accumR` e) `sample` e+-- > a `accumR` e = a `stepper` (a `accumE` e)+-- +accumE :: a -> Event (a -> a) -> Event a+a `accumE` e = (a `accumR` e) `sample` e++-- |+-- Create a past-dependent event.+--+-- > scanlE f z x = foldpE (flip f) f z x+-- +foldpE :: (a -> b -> b) -> b -> Event a -> Event b+foldpE f a e = a `accumE` (f <$> e)++-- |+-- Create a past-dependent event. This combinator corresponds to 'scanl' on streams.+--+-- > scanlE f z x = foldpE (flip f) f z x+-- +scanlE :: (a -> b -> a) -> a -> Event b -> Event a+scanlE f = foldpE (flip f)+ +-- |+-- Create a past-dependent event using a 'Monoid' instance.+--+monoidE :: Monoid a => Event a -> Event a+monoidE = scanlE mappend mempty++liftMonoidE :: Monoid m => (a -> m) -> (m -> a) -> Event a -> Event a+liftMonoidE i o = fmap o . monoidE . fmap i++sumE :: Num a => Event a -> Event a+sumE = liftMonoidE Sum getSum++productE :: Num a => Event a -> Event a+productE = liftMonoidE Product getProduct++allE :: Event Bool -> Event Bool+allE = liftMonoidE All getAll++anyE :: Event Bool -> Event Bool+anyE = liftMonoidE Any getAny+++-- |+-- Get just the first value.+--+firstE :: Event a -> Event a+firstE = justE . fmap snd . foldpE g (True,Nothing)+ where+ g c (True, _) = (False,Just c) -- first time output+ g c (False, _) = (False,Nothing) -- then no output+ +-- |+-- Get all but the first value.+--+restE :: Event a -> Event a+restE = justE . fmap snd . foldpE g (True,Nothing)+ where + g c (True, _) = (False,Nothing) -- first time no output+ g c (False, _) = (False,Just c) -- then output++-- |+-- Count values.+--+countE :: Enum b => Event a -> Event b+countE = accumE (toEnum 0) . fmap (const succ)++-- |+-- Delay by one value.+--+lastE :: Event a -> Event a+lastE = fmap snd . recallE++-- |+-- Delay by @n@ values.+--+delayE :: Int -> Event a -> Event a+delayE n = foldr (.) id (replicate n lastE)++-- |+-- Buffer up to /n/ values. When the buffer is full, old elements will be rotated out.+--+-- > bufferE n e = [[e1],[e1,e2]..[e1..en],[e2..en+1]..]+--+bufferE :: Int -> Event a -> Event [a]+bufferE n = (reverse <$>) . foldpE g []+ where+ g x xs = x : take (n-1) xs++-- |+-- Gather event values into chunks of regular size.+--+-- > gatherE n e = [[e1..en],[en+1..e2n]..]+--+gatherE :: Int -> Event a -> Event [a]+gatherE n = (reverse <$>) . filterE (\xs -> length xs == n) . foldpE g []+ where+ g x xs | length xs < n = x : xs+ | length xs == n = x : []+ | otherwise = error "gatherE: Wrong length"++-- |+-- Pack with last value.+--+recallE :: Event a -> Event (a, a)+recallE = recallEWith (,)++-- |+-- Pack with last value. Similar to @withPrevEWith@ in reactive but flipped.+--++-- recallEWith :: (a -> a -> b) -> Event a -> Event b+-- recallEWith f = justE . fmap k . bufferE 2+-- where+-- k [] = Nothing+-- k [x] = Nothing+-- k (a:b:_) = Just $ f a b++recallEWith f e + = (joinMaybes' . fmap combineMaybes) + $ dup Nothing `accumE` fmap (shift . Just) e+ where + shift b (_,a) = (a,b)+ dup x = (x,x)+ joinMaybes' = justE+ combineMaybes = uncurry (liftA2 f)++{-++TODO not sure about these++eventMain :: Event (Maybe Bool) -> IO ()+eventMain = eventMain' . (fmap . fmap) (\r -> if r then ExitSuccess else ExitFailure (-1))++eventMain' :: Event (Maybe ExitCode) -> IO ()+eventMain' e = do+ code <- runLoopUntil e+ exitWith code +-}++-------------------------------------------------------------------------------------+-- Reactive API+-------------------------------------------------------------------------------------++-- |+-- Reactive has a lifted is a monoid: 'mempty' is the constant empty value and+-- mappend combines values according to 'mappend' on values.+--+instance Monoid a => Monoid (Reactive a) where+ mempty = pure mempty+ mappend = liftA2 mappend++-- |+-- Reactive is a functor: 'fmap' transforms the value at each point in time.+--+instance Functor Reactive where+ fmap f = (pure f <*>)++-- |+-- Reactive is an applicative functor: 'pure' is a constant value and @fr \<*> xr@ applies the+-- function @fr t@ to the value @xr t@.+--+instance Applicative Reactive where+ pure = RConst+ -- pure x = x `stepper` never + (<*>) = RApply++-- instance Monad Reactive where+-- return = pure+-- x >>= k = (RJoin . fmap k) x++instance IsString a => IsString (Reactive a) where+ fromString = pure . fromString++instance Eq (Reactive b) where+ (==) = noFun "(==)"+ (/=) = noFun "(/=)"++instance Ord b => Ord (Reactive b) where+ min = liftA2 min+ max = liftA2 max++instance Enum a => Enum (Reactive a) where+ succ = fmap succ+ pred = fmap pred+ toEnum = pure . toEnum+ fromEnum = noFun "fromEnum"+ enumFrom = noFun "enumFrom"+ enumFromThen = noFun "enumFromThen"+ enumFromTo = noFun "enumFromTo"+ enumFromThenTo = noFun "enumFromThenTo"++instance Num a => Num (Reactive a) where+ (+) = liftA2 (+)+ (*) = liftA2 (*)+ (-) = liftA2 (-)+ abs = fmap abs+ signum = fmap signum+ fromInteger = pure . fromInteger++instance (Num a, Ord a) => Real (Reactive a) where+ toRational = noFun "toRational"++instance Integral a => Integral (Reactive a) where+ quot = liftA2 quot+ rem = liftA2 rem+ div = liftA2 div+ mod = liftA2 mod+ quotRem = (fmap.fmap) unzipR (liftA2 quotRem)+ divMod = (fmap.fmap) unzipR (liftA2 divMod)+ toInteger = noFun "toInteger"++instance Fractional b => Fractional (Reactive b) where+ recip = fmap recip+ fromRational = pure . fromRational++instance Floating b => Floating (Reactive b) where+ pi = pure pi+ sqrt = fmap sqrt+ exp = fmap exp+ log = fmap log+ sin = fmap sin+ cos = fmap cos+ asin = fmap asin+ atan = fmap atan+ acos = fmap acos+ sinh = fmap sinh+ cosh = fmap cosh+ asinh = fmap asinh+ atanh = fmap atanh+ acosh = fmap acosh++instance AdditiveGroup v => AdditiveGroup (Reactive v) where+ zeroV = pure zeroV+ (^+^) = liftA2 (^+^)+ negateV = liftA negateV++instance VectorSpace v => VectorSpace (Reactive v) where+ type Scalar (Reactive v) = Scalar v+ (*^) s = fmap (s *^)+ ++-- |+-- A non-reactive reactive.+--+alwaysR :: a -> Reactive a+alwaysR = pure++-- |+-- Step between values.+--+stepper :: a -> Event a -> Reactive a+stepper x e = RStep (newVar x) e++-- |+-- Switch between time-varying values.+--+-- switcher :: Reactive a -> Event (Reactive a) -> Reactive a+-- r `switcher` e = RJoin (r `stepper` e)+-- r `switcher` e = join (r `stepper` e)++-- |+-- Step between values without initial.+--+maybeStepper :: Event a -> Reactive (Maybe a)+maybeStepper e = Nothing `stepper` fmap Just e++-- |+-- Switch between time-varying values without initial.+--+-- maybeSwitcher :: Event (Reactive a) -> Reactive (Maybe a)+-- maybeSwitcher e = pure Nothing `switcher` fmap (fmap Just) e++-- |+-- Step between values without initial, failing if sampled before the first step.+--+eventToReactive :: Event a -> Reactive a+eventToReactive = stepper (error "eventToReactive: ")++-- |+-- Switch between the values of a time-varying value when an event occurs.+--+-- sampleAndHold :: Reactive b -> Event a -> Reactive b+-- sampleAndHold r e = r `switcher` (pure <$> r `sample` e) +-- sampleAndHold r e = (liftA2 change) r (maybeStepper $ sample r e)+-- where+-- change a Nothing = a+-- change a (Just b) = b++sampleAndHold2 :: b -> Reactive b -> Event a -> Reactive b+sampleAndHold2 z r e = z `stepper` (r `sample` e) +++-- | +-- Apply the values of an event to a time-varying function.+--+-- > r `apply` e = r `snapshotWith ($)` e+-- +apply :: Reactive (a -> b) -> Event a -> Event b+r `apply` e = r `o` e where o = snapshotWith ($)++-- |+-- Sample a time-varying value.+--+-- > r `snapshot` e = snapshotWith const+--+sample :: Reactive b -> Event a -> Event b+sample = ESamp++-- |+-- Sample a time-varying value with the value of the trigger.+--+-- > r `snapshot` e = snapshotWith (,)+--+snapshot :: Reactive a -> Event b -> Event (a, b)+snapshot = snapshotWith (,)++-- |+-- Sample a time-varying value with the value of the trigger, using the given +-- function to combine.+--+-- > r `snapshotWith f` e = (f <$> r) `apply` e+--+snapshotWith :: (a -> b -> c) -> Reactive a -> Event b -> Event c+snapshotWith f r e = sample (liftA2 f r (eventToReactive e)) e+++-- | +-- Filter an event based on a time-varying predicate.+-- +-- > r `filter'` e = justE $ (partial <$> r) `apply` e+--+filter' :: Reactive (a -> Bool) -> Event a -> Event a+r `filter'` e = justE $ (partial <$> r) `apply` e++-- | +-- Filter an event based on a time-varying toggle.+-- +-- > r `gate` e = (const <$> r) `filter'` e+-- +gate :: Reactive Bool -> Event a -> Event a+r `gate` e = (const <$> r) `filter'` e+++-- | +-- Efficient combination of 'accumE' and 'accumR'.+-- +mapAccum :: a -> Event (a -> (b,a)) -> (Event b, Reactive a)+mapAccum acc ef = (fst <$> e, stepper acc (snd <$> e))+ where + e = accumE (emptyAccum,acc) ((. snd) <$> ef)+ emptyAccum = error "mapAccum: Empty accumulator"++-- |+-- Combine reactives. See also 'eitherE'.+--+zipR :: Reactive a -> Reactive b -> Reactive (a, b)+zipR = liftA2 (,)++-- |+-- Reactive accumulator.+--+-- > a `accumE` e = (a `accumR` e) `sample` e+-- > a `accumR` e = a `stepper` (a `accumE` e)+-- +accumR :: a -> Event (a -> a) -> Reactive a+accumR x = RAccum (newVar x)++-- |+-- Create a past-dependent reactive. This combinator corresponds to 'scanl' on streams.+--+-- > scanlR f z x = foldpR (flip f) f z x+-- +foldpR :: (a -> b -> b) -> b -> Event a -> Reactive b+foldpR f = scanlR (flip f)++-- |+-- Create a past-dependent reactive. This combinator corresponds to 'scanl' on streams.+--+-- > scanlR f z x = foldpR (flip f) f z x+-- +scanlR :: (a -> b -> a) -> a -> Event b -> Reactive a+scanlR f a e = a `stepper` scanlE f a e++-- |+-- Create a past-dependent event using a 'Monoid' instance.+--+monoidR :: Monoid a => Event a -> Reactive a+monoidR = scanlR mappend mempty++liftMonoidR :: Monoid m => (a -> m) -> (m -> a) -> Event a -> Reactive a+liftMonoidR i o = fmap o . monoidR . fmap i++sumR :: Num a => Event a -> Reactive a+sumR = liftMonoidR Sum getSum++productR :: Num a => Event a -> Reactive a+productR = liftMonoidR Product getProduct++allR :: Event Bool -> Reactive Bool+allR = liftMonoidR All getAll++anyR :: Event Bool -> Reactive Bool+anyR = liftMonoidR Any getAny++-- |+-- Count values.+--+countR :: Enum b => Event a -> Reactive b+countR = accumR (toEnum 0) . fmap (const succ)++++onR :: Event a -> Reactive Bool+onR = fmap isJust . maybeStepper++offR :: Event a -> Reactive Bool+offR = fmap not . onR++toggleR :: Event a -> Reactive Bool+toggleR = fmap odd . countR++-- |+-- Difference of successive values.+--+diffE :: Num a => Event a -> Event a+diffE = recallEWith $ flip (-)++++-- |+-- A generalized time behaviour.+--+time :: Fractional a => Reactive a+time = accumR 0 ((+ kStdPulseInterval) <$ kStdPulse)+++-- |+-- Integrates a behaviour.+--+-- > integral pulse behavior+--+integral :: Fractional b => Event a -> Reactive b -> Reactive b+integral t b = sumR (snapshotWith (*) b (diffE (tx `sample` t)))+ where+ -- tx = time+ tx :: Fractional a => Reactive a+ tx = fmap (fromRational . toRational) $ systemTimeSecondsR++++data TransportControl t + = Play -- ^ Play from the current position.+ | Reverse -- ^ Play in reverse from the current position.+ | Pause -- ^ Stop playing, and retain current position.+ | Stop -- ^ Stop and reset position.+ deriving (Eq, Ord, Show)+-- | Seek t -- ^ Set current position.++isStop Stop = True+isStop _ = False++-- |+-- Generates a cursor that moves forward or backward continuously.+--+-- The cursor may be started, stopped, moved by sending a 'TransportControl' event.+--+-- > transport control pulse speed+--+transport :: (Ord t, Fractional t) => Event (TransportControl t) -> Event a -> Reactive t -> Reactive t+transport ctrl trig speed = position'+ where + -- action :: Reactive (TransportControl t)+ action = Pause `stepper` ctrl++ -- direction :: Num a => Reactive a+ direction = action <$$> \a -> case a of+ Play -> 1+ Reverse -> (-1)+ Pause -> 0 + Stop -> 0 + + -- position :: Num a => Reactive a+ position = integral trig (speed * direction)+ -- startPosition = position `sampleAndHold` (filterE isStop ctrl)+ startPosition = sampleAndHold2 0 position (filterE isStop ctrl)++ position' = position - startPosition+++-- |+-- Record a list of values.+--+record :: Ord t => Reactive t -> Event a -> Reactive [(t, a)]+record t x = foldpR append [] (t `snapshot` x)+ where+ append x xs = xs ++ [x]++-- |+-- Play back a list of values.+--+-- This function will sample the time behaviour at an arbitrary+-- small interval. To get precise control of how time is sampled,+-- use 'playback'' instead.+-- +playback :: Ord t => Reactive t -> Reactive [(t,a)] -> Event a+playback t s = scatterE $ fmap snd <$> playback' oftenE t s++-- |+-- Play back a list of values.+-- +playback' :: Ord t => Event b -> Reactive t -> Reactive [(t,a)] -> Event [(t, a)]+playback' p t s = cursor s (t `sample` p)+ where + -- cursor :: Ord t => Reactive [(t,a)] -> Event t -> Event [(a,t)]+ cursor s = snapshotWith (flip occs) s . recallE++ -- occs :: Ord t => (t,t) -> [(a,t)] -> [(a,t)]+ occs (x,y) = filter (\(t,_) -> x < t && t <= y)+++{-++modify :: Event (a -> a) -> Reactive a -> Reactive a+set :: Event a -> Reactive b -> Reactive a+-}++ +-------------------------------------------------------------------------------------+-- Lifting IO etc+-------------------------------------------------------------------------------------++-- |+-- Event reading from external world.+-- The computation should be blocking and is polled exactly once per value.+--+-- This function can be used with standard I/O functions.+--+getE :: IO a -> Event a+getE k = unsafePerformIO $ do+ ch <- newChan+ forkIO $ cycleM $ + k >>= writeChan ch+ return (EChan ch)++-- |+-- Event reading from external world.+-- The computation should be non-blocking and may be polled repeatedly for each value.+--+-- This function should be used with /non-effectful/ functions, typically functions that+-- observe the current value of some external property.+-- You should /not/ use this function with standard I/O functions as this+-- may lead to non-deterministic reads (i.e. loss of data).+--+pollE :: IO (Maybe a) -> Event a+pollE = ESource . fmap maybeToList++-- Event interacting with the external world.+-- The computation should be non-blocking and its values will be contested.+--+-- modifyE :: (a -> IO b) -> Event a -> Event b+-- modifyE = ESink++-- |+-- Event writing to the external world.+--+-- This function can be used with standard I/O functions.+--+putE :: (a -> IO ()) -> Event a -> Event a+putE k = ESink $ \x -> do+ k x+ return x++-- |+-- Event reading from a channel.+--+readChanE :: Chan a -> Event a+readChanE = EChan++-- |+-- Event writing to a channel.+--+writeChanE :: Chan a -> Event a -> Event a+writeChanE ch e = ESink (writeChan ch) e `seqE` e++-- |+-- Event version of 'getChar'.+--+getCharE :: Event Char+getCharE = getE getChar ++-- |+-- Event version of 'putChar'.+--+putCharE :: Event Char -> Event Char+putCharE = putE putChar++-- |+-- Event version of 'getLine'.+--+getLineE :: Event String+getLineE = getE getLine ++-- |+-- Event version of 'putStrLn'.+--+putLineE :: Event String -> Event String+putLineE = putE putStrLn++systemTimeR :: Reactive UTCTime +systemTimeR = eventToReactive $ pollE (Just <$> getCurrentTime)++systemTimeSecondsR :: Reactive DiffTime+systemTimeSecondsR = fmap utctDayTime systemTimeR++systemTimeDayR :: Reactive Day+systemTimeDayR = fmap utctDay systemTimeR+++-- | +-- An event occuring at the specified interval.+--+pulse :: DiffTime -> Event ()+pulse t = getE $ threadDelay (round (fromMicro t))+ where + fromMicro = (* 1000000)++-------------------------------------------------------------------------------------+-- Running+-------------------------------------------------------------------------------------++-- | +-- Run the given event once.+--+run :: Event a -> IO ()+run e = do+ f <- prepE e+ runE f+ return ()++-- | +-- Run the given event for ever.+--+runLoop :: Event a -> IO ()+runLoop e = do + f <- prepE e+ runLoop' f + where + runLoop' g = do+ runE g+ threadDelay kLoopInterval >> runLoop' g++-- | +-- Run the given event until the first @Just x@ value, then return @x@.+--+runLoopUntil :: Event (Maybe a) -> IO a+runLoopUntil e = do + f <- prepE e+ runLoopUntil' f + where + runLoopUntil' g = do+ r <- runE g+ case (catMaybes r) of + [] -> threadDelay kLoopInterval >> runLoopUntil' g+ (a:_) -> return a+++++-------------------------------------------------------------------------------------+-- Utility+-------------------------------------------------------------------------------------++type Source a = Event a+type Sink a = Event a -> Event ()++-- |+-- Behaves like the original event but writes a given message to the standard+-- output for each value.+-- +notify :: String -> Event a -> Event a+notify m x = putLineE (fmap (const m) x) `seqE` x++-- |+-- Behaves like the original event but writes its value, prepended by the given+-- message, for each value.+-- +showing :: Show a => String -> Event a -> Event a+showing m x = putE k x+ where+ k x = putStrLn $ m ++ show x++-- |+-- Creates a new source and a computation that writes it.+-- +newSource :: IO (a -> IO (), Source a)+newSource = do+ ch <- newChan+ return (writeChan ch, readChanE ch)++-- |+-- Creates a new sink and a computation that reads from it.+-- +newSink :: IO (IO (Maybe a), Sink a)+newSink = do+ ch <- newChan+ return (tryReadChan ch, tickE . writeChanE ch) ++runEvent :: Show a => Event a -> IO ()+runEvent = runLoop . showing ""++runReactive :: Show a => Reactive a -> IO ()+runReactive r = runEvent (r `sample` pulse (1/20))++unsafeGetReactive :: Reactive a -> a+unsafeGetReactive r = unsafePerformIO $ runRS r+++-------------------------------------------------------------------------------------++partial :: (a -> Bool) -> (a -> Maybe a)+partial p x+ | p x = Just x+ | otherwise = Nothing++list z f [] = z+list z f xs = f xs++filterMap p = catMaybes . map p ++cycleM x = x >> cycleM x ++single x = [x]++-- | Pass through @Just@ occurrences.+joinMaybes :: MonadPlus m => m (Maybe a) -> m a+joinMaybes = (>>= maybe mzero return)++-- | Pass through values satisfying @p@.+filterMP :: MonadPlus m => (a -> Bool) -> m a -> m a+filterMP p m = joinMaybes (liftM f m)+ where+ f a | p a = Just a+ | otherwise = Nothing++fromLeft (Left a) = Just a+fromLeft (Right b) = Nothing+fromRight (Left a) = Nothing+fromRight (Right b) = Just b ++noFun = noOverloading "Reactive"+noOverloading ty meth = error $ meth ++ ": No overloading for " ++ ty+++kStdPulseInterval :: Fractional a => a+kStdPulseInterval = (1/20)++kLoopInterval = round $ (1/10) * 1000000 -- us++kStdPulse = pulse kStdPulseInterval++(<$$>) = flip fmap+
+ src/Control/Reactive/Chan.hs view
@@ -0,0 +1,42 @@++module Control.Reactive.Chan (+ Chan(..),+ newChan,+ dupChan,+ readChan,+ tryReadChan,+ writeChan,+ ) where++import Data.Monoid +import Data.Maybe+import Control.Monad+import Control.Applicative++import Control.Concurrent (forkIO, forkOS, threadDelay)+import Control.Monad.STM (atomically)+import Control.Concurrent.STM.TChan+import Control.Concurrent.STM.TMVar++import System.IO.Unsafe++newtype Chan a = Chan { getChan :: TChan a }++newChan :: IO (Chan a)+newChan = do+ c' <- atomically $ newTChan+ return (Chan c')++dupChan :: Chan a -> IO (Chan a)+dupChan (Chan c) = do+ c' <- atomically . dupTChan $ c+ return (Chan c') ++writeChan :: Chan a -> a -> IO ()+writeChan (Chan c) x = atomically $ writeTChan c x++readChan :: Chan a -> IO a+readChan (Chan c) = atomically $ readTChan c++tryReadChan :: Chan a -> IO (Maybe a)+tryReadChan (Chan c) = atomically $ tryReadTChan c
+ src/Control/Reactive/Midi.hs view
@@ -0,0 +1,87 @@++module Control.Reactive.Midi (+ module Codec.Midi,+ + -- * Basic types+ Midi.MidiTime,+ Midi.MidiMessage,++ -- * Sources and destinations+ MidiSource,+ MidiDestination,+ midiSources,+ midiDestinations,+ findSource,+ findDestination,+ + -- * Sending and receiving+ midiIn,+ midiIn',+ midiOut,+ ) where++import Data.Monoid +import Data.Maybe+import Control.Monad+import Control.Applicative+import Control.Concurrent (forkIO, threadDelay)+import System.IO.Unsafe (unsafePerformIO)++import Control.Reactive+import Control.Reactive.Util++import Codec.Midi hiding (Time, Track)+import qualified System.MIDI as Midi++type MidiSource = Midi.Source+type MidiDestination = Midi.Destination++midiSources :: Reactive [MidiSource]+midiSources = eventToReactive + (pollE $ threadDelay 1 >> Midi.sources >>= return . Just)++midiDestinations :: Reactive [MidiDestination]+midiDestinations = eventToReactive + (pollE $ threadDelay 1 >> Midi.destinations >>= return . Just)++findSource :: Reactive String -> Reactive (Maybe MidiSource)+findSource nm = g <$> nm <*> midiSources+ where+ g = (\n -> listToMaybe . filter (\d -> isSubstringOfNormalized n $ unsafePerformIO (Midi.name d)))++findDestination :: Reactive String -> Reactive (Maybe MidiDestination)+findDestination nm = g <$> nm <*> midiDestinations+ where+ g = (\n -> listToMaybe . filter (\d -> isSubstringOfNormalized n $ unsafePerformIO (Midi.name d)))+++midiIn :: MidiSource -> Event Midi.MidiMessage+midiIn dev = snd <$> midiIn' dev++midiIn' :: MidiSource -> Event (Midi.MidiTime, Midi.MidiMessage)+midiIn' dev = unsafePerformIO $ do+ (k, e) <- newSource+ str <- Midi.openSource dev (Just $ curry k)+ Midi.start str+ return e++midiOut :: MidiDestination -> Event Midi.MidiMessage -> Event Midi.MidiMessage+midiOut dest = putE $ \msg -> do+ Midi.send dest' msg+ where+ dest' = unsafePerformIO $ do+ -- putStrLn "Midi.openDestination"+ Midi.openDestination dest+++++++++---------++eventToReactive :: Event a -> Reactive a+eventToReactive = stepper (error "eventToReactive: ")+
+ src/Control/Reactive/Osc.hs view
@@ -0,0 +1,70 @@++module Control.Reactive.Osc (+ module Sound.OpenSoundControl,++ -- * Basic types+ OscTime,+ OscPacket,+ OscMessage,+ OscBundle,++ -- * Sending and receiving+ -- ** UDP+ oscInUdp,+ oscOutUdp,+ ) where++import Data.Monoid +import Data.Maybe+import Control.Monad+import Control.Applicative+import System.IO.Unsafe (unsafePerformIO)+import Control.Concurrent (forkIO, forkOS, threadDelay)++import Control.Reactive+import Control.Reactive.Util++import Sound.OpenSoundControl hiding (Time, time)+import qualified Sound.OSC.FD as Osc++type OscTime = Osc.Time++type OscPacket = Osc.Packet+type OscMessage = Osc.Message+type OscBundle = Osc.Bundle++-- |+-- Recieve OSC from the given port.+--+-- > oscInUdp port+--+oscInUdp :: Int -> Event OscPacket+oscInUdp port = unsafePerformIO $ do+ (k, e) <- newSource+ fd <- Osc.udpServer "127.0.0.1" port+ forkIO $ do+ Osc.recvPacket fd >>= k+ return e++-- |+-- Send OSC to the given address.+--+-- > oscInUdp address port+--+oscOutUdp :: OSC a => String -> Int -> Event a -> Event a+oscOutUdp addr port = putE $ \msg -> do+ -- putStrLn "Osc.sendOSC"+ Osc.sendOSC dest msg+ where+ dest = unsafePerformIO $ do+ -- putStrLn "Osc.openUDP"+ Osc.openUDP addr port++{-+oscIn :: Osc.Transport t => t -> Event OscPacket+oscIn = undefined++oscOut :: (OSC a, Osc.Transport t) => t -> Event a -> Event a+oscOut dest = -}++
+ src/Control/Reactive/Util.hs view
@@ -0,0 +1,237 @@++-------------------------------------------------------------------------------------+-- |+-- Copyright : (c) Hans Hoglund 2012+--+-- License : GPL+--+-- Maintainer : hans@hanshoglund.se+-- Stability : stable+-- Portability : portable+--+-- Utility functions.+--+------------------------------------------------------------------------------------- ++module Control.Reactive.Util (+ -- ** String and Char+ toUpperChar,+ toLowerChar,+ toUpperString,+ toLowerString,+ toCapitalString, + isSubstringOf,+ isInfixOfNormalized,+ isSubstringOfNormalized,+ + -- ** Lists+ prefix,+ suffix,+ sep,+ pre,+ post,+ wrap,+ concatSep,+ concatPre,+ concatPost,+ concatWrap,+ concatLines,+ divideList,+ breakList, + + -- ** Monads+ concatMapN,+ concatMapM,+ concatMapA,+ + -- ** Special map+ mapIndexed, + + -- ** Mathematics+ tau, + + -- ** System+ -- execute,+ ) where++import Prelude hiding (concat)++import Data.Monoid +import Control.Applicative+import Data.Foldable+import Data.Traversable+import Control.Monad (MonadPlus)++-- import System.Posix++import qualified Data.Char as Char+import qualified Data.List as List++-------------------------------------------------------------------------------------+-- String and Char+-------------------------------------------------------------------------------------++-- |+-- Synonym for 'Char.toUpper'+toUpperChar :: Char -> Char+toUpperChar = Char.toUpper++-- |+-- Synonym for 'Char.toLower'+toLowerChar :: Char -> Char+toLowerChar = Char.toLower++-- |+-- Synonym for 'fmap Char.toUpper'+toUpperString :: String -> String+toUpperString = fmap Char.toUpper++-- |+-- Synonym for 'fmap Char.toLower'+toLowerString :: String -> String+toLowerString = fmap Char.toLower++-- |+-- Convert a string to use upper case for the leading letter and lower case for+-- remaining letters.+toCapitalString :: String -> String+toCapitalString [] = []+toCapitalString (x:xs) = toUpperChar x : toLowerString xs++isSubstringOf :: String -> String -> Bool+a `isSubstringOf` b + = a `List.isPrefixOf` b+ || a `List.isInfixOf` b+ || a `List.isSuffixOf` b++isInfixOfNormalized :: String -> String -> Bool+a `isInfixOfNormalized` b = toLowerString a `List.isInfixOf` toLowerString b ++isSubstringOfNormalized :: String -> String -> Bool+a `isSubstringOfNormalized` b = toLowerString a `isSubstringOf` toLowerString b ++-------------------------------------------------------------------------------------+-- List+-------------------------------------------------------------------------------------++-- |+-- Synonym for '(++)'+--+prefix :: [a] -> [a] -> [a]+prefix x = (x ++)++-- |+-- Synonym for 'flip (++)'+--+suffix :: [a] -> [a] -> [a]+suffix x = (++ x)++-- |+-- Separate a list by the given element.+--+-- Equivalent to 'List.intersperse'+--+sep :: a -> [a] -> [a]+sep = List.intersperse++-- |+-- Initiate and separate a list by the given element.+--+pre :: a -> [a] -> [a]+pre x = (x :) . sep x++-- |+-- Separate and terminate a list by the given element.+--+post :: a -> [a] -> [a]+post x = suffix [x] . sep x++-- |+-- Separate and terminate a list by the given element.+--+wrap :: a -> a -> [a] -> [a]+wrap x y = (x :) . suffix [y] . sep x++-- |+-- Combination of 'concat' and 'sep'.+--+concatSep :: [a] -> [[a]] -> [a]+concatSep x = concat . sep x++-- |+-- Combination of 'concat' and 'pre'.+--+concatPre :: [a] -> [[a]] -> [a]+concatPre x = concat . pre x++-- |+-- Combination of 'concat' and 'post'.+--+concatPost :: [a] -> [[a]] -> [a]+concatPost x = concat . post x++-- |+-- Combination of 'concat' and 'wrap'.+--+concatWrap :: [a] -> [a] -> [[a]] -> [a]+concatWrap x y = concat . wrap x y+++concatLines :: [String] -> String+concatLines = concatPost "\n"++-- |+-- Divide a list into parts of maximum length n.+--+divideList :: Int -> [a] -> [[a]]+divideList n xs+ | length xs <= n = [xs]+ | otherwise = [take n xs] ++ (divideList n $ drop n xs)++-- |+-- Break up a list into parts of maximum length n, inserting the given list as separator.+-- Useful for breaking up strings, as in @breakList 80 "\n" str@.+--+breakList :: Int -> [a] -> [a] -> [a]+breakList n z = mconcat . List.intersperse z . divideList n+++-- |+-- A version of 'concatMap' generalized to arbitrary 'Monoid' instances.+--+concatMapN :: (Applicative f, Monoid b) => (a -> f b) -> [a] -> f b+concatMapN f = fmap mconcat . traverse f++-- |+-- A version of 'concatMap' generalized to arbitrary 'MonadPlus' instances.+--+concatMapM :: (MonadPlus m, Applicative f, Traversable t) => (a -> f (m b)) -> t a -> f (m b)+concatMapM f = fmap msum . traverse f++-- |+-- A version of 'concatMap' generalized to arbitrary 'Alternative' instances.+--+concatMapA :: (Alternative m, Applicative f, Traversable t) => (a -> f (m b)) -> t a -> f (m b)+concatMapA f = fmap asum . traverse f+++mapIndexed :: (Int -> a -> b) -> [a] -> [b]+mapIndexed f as = map (uncurry f) (zip is as)+ where+ n = length as - 1+ is = [0..n]++tau :: Floating a => a+tau = 2 * pi++{-+-- |+-- Excecute an external process asynchronously (using @forkProcess@) with the given arguments.+--+execute :: FilePath -> [String] -> IO ()+execute program args = do+ forkProcess $ executeFile program True args Nothing+ return ()+-}++
+ src/Control/Reactive/Var.hs view
@@ -0,0 +1,42 @@++{-# LANGUAGE BangPatterns #-}++module Control.Reactive.Var (+ Var(..),+ dupVar,+ newVar,+ readVar,+ writeVar,+ -- swapVar+ ) where++import Data.Monoid +import Data.Maybe+import Control.Monad+import Control.Applicative++import Control.Concurrent (forkIO, forkOS, threadDelay)+import Control.Monad.STM (atomically)+import Control.Concurrent.STM.TChan+import Control.Concurrent.STM.TVar++import System.IO.Unsafe++newtype Var a = Var { getVar :: TVar a }++newVar :: a -> Var a+newVar = Var . unsafePerformIO . newTVarIO++dupVar :: Var a -> IO (Var a)+dupVar v = atomically $ readTVar (getVar v) >>= newTVar >>= return . Var++readVar :: Var a -> IO a+readVar = atomically . readTVar . getVar++writeVar :: Var a -> a -> IO ()+-- writeVar (Var v) x = atomically $ modifyTVar' v (const x)+writeVar (Var !v) x = atomically $ swapTVar v x >> return ()++-- swapVar :: Var a -> a -> IO a+-- swapVar v = atomically . swapTVar (getVar v)+--