module Control.Reactive (
Event,
Reactive,
stepper,
maybeStepper,
sampleAndHold2,
apply,
filter',
gate,
sample,
snapshot,
snapshotWith,
justE,
splitE,
eitherE,
lastE,
delayE,
recallEWith,
diffE,
bufferE,
gatherE,
scatterE,
accumE,
accumR,
foldpE,
foldpR,
scanlE,
scanlR,
mapAccum,
firstE,
restE,
countE,
countR,
monoidE,
monoidR,
sumE,
productE,
allE,
anyE,
sumR,
productR,
allR,
anyR,
tickE,
onR,
offR,
toggleR,
pulse,
time,
integral,
TransportControl(..),
transport,
record,
playback,
playback',
seqE,
oftenE,
getCharE,
putCharE,
getLineE,
putLineE,
systemTimeR,
systemTimeSecondsR,
systemTimeDayR,
readChanE,
writeChanE,
getE,
pollE,
putE,
run,
runLoop,
runLoopUntil,
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.Concurrent (forkIO, forkOS, threadDelay)
import System.IO.Unsafe
import Control.Reactive.Chan
import Control.Reactive.Var
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
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
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'
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'
runRS :: Reactive a -> IO a
runRS = fmap last . runR
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)
return ys
runR (RAccum v x) = do
v' <- readVar v
x' <- runE x
let !w = (foldr (.) id x') v'
writeVar v w
return [w]
runR (RApply f x) = do
f' <- runR f
x' <- runR x
return $ f' <*> x'
instance Functor (Event) where
fmap = EMap
instance Monoid (Event a) where
mempty = ENever
mappend = EMerge
never :: Event a
never = mempty
mergeE :: Event a -> Event a -> Event a
mergeE = mappend
eitherE :: Event a -> Event b -> Event (Either a b)
a `eitherE` b = fmap Left a `mergeE` fmap Right b
seqE :: Event a -> Event b -> Event b
seqE = ESeq
oftenE :: Event ()
oftenE = pollE $ return $ Just ()
mapE :: (a -> b) -> Event a -> Event b
mapE = (<$>)
filterE :: (a -> Bool) -> Event a -> Event a
filterE p = EPred p
retainE :: (a -> Bool) -> Event a -> Event a
retainE p = EPred (not . p)
scatterE :: Event [a] -> Event a
scatterE = EConcat
justE :: Event (Maybe a) -> Event a
justE = EConcat . fmap maybeToList
partitionE :: (a -> Bool) -> Event a -> (Event a, Event a)
partitionE p e = (filterE p e, retainE p 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)
replaceE :: b -> Event a -> Event b
replaceE x = (x <$)
tickE :: Event a -> Event ()
tickE = replaceE ()
tickME :: Monoid b => Event a -> Event b
tickME = replaceE mempty
accumE :: a -> Event (a -> a) -> Event a
a `accumE` e = (a `accumR` e) `sample` e
foldpE :: (a -> b -> b) -> b -> Event a -> Event b
foldpE f a e = a `accumE` (f <$> e)
scanlE :: (a -> b -> a) -> a -> Event b -> Event a
scanlE f = foldpE (flip f)
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
firstE :: Event a -> Event a
firstE = justE . fmap snd . foldpE g (True,Nothing)
where
g c (True, _) = (False,Just c)
g c (False, _) = (False,Nothing)
restE :: Event a -> Event a
restE = justE . fmap snd . foldpE g (True,Nothing)
where
g c (True, _) = (False,Nothing)
g c (False, _) = (False,Just c)
countE :: Enum b => Event a -> Event b
countE = accumE (toEnum 0) . fmap (const succ)
lastE :: Event a -> Event a
lastE = fmap snd . recallE
delayE :: Int -> Event a -> Event a
delayE n = foldr (.) id (replicate n lastE)
bufferE :: Int -> Event a -> Event [a]
bufferE n = (reverse <$>) . foldpE g []
where
g x xs = x : take (n1) xs
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"
recallE :: Event a -> Event (a, a)
recallE = recallEWith (,)
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)
instance Monoid a => Monoid (Reactive a) where
mempty = pure mempty
mappend = liftA2 mappend
instance Functor Reactive where
fmap f = (pure f <*>)
instance Applicative Reactive where
pure = RConst
(<*>) = RApply
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 *^)
alwaysR :: a -> Reactive a
alwaysR = pure
stepper :: a -> Event a -> Reactive a
stepper x e = RStep (newVar x) e
maybeStepper :: Event a -> Reactive (Maybe a)
maybeStepper e = Nothing `stepper` fmap Just e
eventToReactive :: Event a -> Reactive a
eventToReactive = stepper (error "eventToReactive: ")
sampleAndHold2 :: b -> Reactive b -> Event a -> Reactive b
sampleAndHold2 z r e = z `stepper` (r `sample` e)
apply :: Reactive (a -> b) -> Event a -> Event b
r `apply` e = r `o` e where o = snapshotWith ($)
sample :: Reactive b -> Event a -> Event b
sample = ESamp
snapshot :: Reactive a -> Event b -> Event (a, b)
snapshot = snapshotWith (,)
snapshotWith :: (a -> b -> c) -> Reactive a -> Event b -> Event c
snapshotWith f r e = sample (liftA2 f r (eventToReactive e)) e
filter' :: Reactive (a -> Bool) -> Event a -> Event a
r `filter'` e = justE $ (partial <$> r) `apply` e
gate :: Reactive Bool -> Event a -> Event a
r `gate` e = (const <$> r) `filter'` e
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"
zipR :: Reactive a -> Reactive b -> Reactive (a, b)
zipR = liftA2 (,)
accumR :: a -> Event (a -> a) -> Reactive a
accumR x = RAccum (newVar x)
foldpR :: (a -> b -> b) -> b -> Event a -> Reactive b
foldpR f = scanlR (flip f)
scanlR :: (a -> b -> a) -> a -> Event b -> Reactive a
scanlR f a e = a `stepper` scanlE f a e
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
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
diffE :: Num a => Event a -> Event a
diffE = recallEWith $ flip ()
time :: Fractional a => Reactive a
time = accumR 0 ((+ kStdPulseInterval) <$ kStdPulse)
integral :: Fractional b => Event a -> Reactive b -> Reactive b
integral t b = sumR (snapshotWith (*) b (diffE (tx `sample` t)))
where
tx :: Fractional a => Reactive a
tx = fmap (fromRational . toRational) $ systemTimeSecondsR
data TransportControl t
= Play
|Reverse
| Pause
| Stop
deriving (Eq, Ord, Show)
isStop Stop = True
isStop _ = False
transport :: (Ord t, Fractional t) => Event (TransportControl t) -> Event a -> Reactive t -> Reactive t
transport ctrl trig speed = position'
where
action = Pause `stepper` ctrl
direction = action <$$> \a -> case a of
Play -> 1
Reverse -> (1)
Pause -> 0
Stop -> 0
position = integral trig (speed * direction)
startPosition = sampleAndHold2 0 position (filterE isStop ctrl)
position' = position startPosition
record :: Ord t => Reactive t -> Event a -> Reactive [(t, a)]
record t x = foldpR append [] (t `snapshot` x)
where
append x xs = xs ++ [x]
playback :: Ord t => Reactive t -> Reactive [(t,a)] -> Event a
playback t s = scatterE $ fmap snd <$> playback' oftenE t s
playback' :: Ord t => Event b -> Reactive t -> Reactive [(t,a)] -> Event [(t, a)]
playback' p t s = cursor s (t `sample` p)
where
cursor s = snapshotWith (flip occs) s . recallE
occs (x,y) = filter (\(t,_) -> x < t && t <= y)
getE :: IO a -> Event a
getE k = unsafePerformIO $ do
ch <- newChan
forkIO $ cycleM $
k >>= writeChan ch
return (EChan ch)
pollE :: IO (Maybe a) -> Event a
pollE = ESource . fmap maybeToList
putE :: (a -> IO ()) -> Event a -> Event a
putE k = ESink $ \x -> do
k x
return x
readChanE :: Chan a -> Event a
readChanE = EChan
writeChanE :: Chan a -> Event a -> Event a
writeChanE ch e = ESink (writeChan ch) e `seqE` e
getCharE :: Event Char
getCharE = getE getChar
putCharE :: Event Char -> Event Char
putCharE = putE putChar
getLineE :: Event String
getLineE = getE getLine
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
pulse :: DiffTime -> Event ()
pulse t = getE $ threadDelay (round (fromMicro t))
where
fromMicro = (* 1000000)
run :: Event a -> IO ()
run e = do
f <- prepE e
runE f
return ()
runLoop :: Event a -> IO ()
runLoop e = do
f <- prepE e
runLoop' f
where
runLoop' g = do
runE g
threadDelay kLoopInterval >> runLoop' g
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
type Source a = Event a
type Sink a = Event a -> Event ()
notify :: String -> Event a -> Event a
notify m x = putLineE (fmap (const m) x) `seqE` x
showing :: Show a => String -> Event a -> Event a
showing m x = putE k x
where
k x = putStrLn $m ++ show x
newSource :: IO (a -> IO (), Source a)
newSource = do
ch <- newChan
return (writeChan ch, readChanE ch)
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]
joinMaybes :: MonadPlus m => m (Maybe a) -> m a
joinMaybes = (>>= maybe mzero return)
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/20) * 1000000
kStdPulse = pulse kStdPulseInterval
(<$$>) = flip fmap