module FRP.Elerea.Param
( Signal
, SignalGen
, start
, external
, externalMulti
, delay
, stateful
, transfer
, memo
, generator
, noise
, getRandom
, debug
) where
import Control.Applicative
import Control.Concurrent.MVar
import Control.Monad
import Control.Monad.Fix
import Data.IORef
import Data.Maybe
import System.Mem.Weak
import System.Random.Mersenne
newtype Signal p a = S { unS :: p -> IO a }
type UpdatePool p = [Weak (p -> IO (), IO ())]
newtype SignalGen p a = SG { unSG :: IORef (UpdatePool p) -> IO a }
data Phase s a = Ready s | Aged s a
instance Functor (Signal p) where
fmap = liftM
instance Applicative (Signal p) where
pure = return
(<*>) = ap
instance Monad (Signal p) where
return = S . const . return
S g >>= f = S $ \p -> g p >>= \x -> unS (f x) p
instance Functor (SignalGen p) where
fmap = liftM
instance Applicative (SignalGen p) where
pure = return
(<*>) = ap
instance Monad (SignalGen p) where
return = SG . const . return
SG g >>= f = SG $ \p -> g p >>= \x -> unSG (f x) p
instance MonadFix (SignalGen p) where
mfix f = SG $ \p -> mfix (($p).unSG.f)
start :: SignalGen p (Signal p a)
-> IO (p -> IO a)
start (SG gen) = do
pool <- newIORef []
(S sample) <- gen pool
ptrs0 <- readIORef pool
writeIORef pool []
(as0,cs0) <- unzip . map fromJust <$> mapM deRefWeak ptrs0
let ageStatic param = mapM_ ($param) as0
commitStatic = sequence_ cs0
return $ \param -> do
let update [] ptrs age commit = do
writeIORef pool ptrs
ageStatic param >> age
commitStatic >> commit
update (p:ps) ptrs age commit = do
r <- deRefWeak p
case r of
Nothing -> update ps ptrs age commit
Just (a,c) -> update ps (p:ptrs) (age >> a param) (commit >> c)
res <- sample param
ptrs <- readIORef pool
update ptrs [] (return ()) (return ())
return res
addSignal :: (p -> Phase s a -> IO a)
-> (p -> Phase s a -> IO ())
-> IORef (Phase s a)
-> IORef (UpdatePool p)
-> IO (Signal p a)
addSignal sample age ref pool = do
let commit (Aged s _) = Ready s
commit _ = error "commit error: signal not aged"
sig = S $ \p -> readIORef ref >>= sample p
update <- mkWeak sig (\p -> readIORef ref >>= age p, modifyIORef ref commit) Nothing
modifyIORef pool (update:)
return sig
delay :: a
-> Signal p a
-> SignalGen p (Signal p a)
delay x0 (S s) = SG $ \pool -> do
ref <- newIORef (Ready x0)
let sample _ (Ready x) = return x
sample _ (Aged _ x) = return x
age p (Ready x) = s p >>= \x' -> x' `seq` writeIORef ref (Aged x' x)
age _ _ = return ()
addSignal sample age ref pool
memo :: Signal p a
-> SignalGen p (Signal p a)
memo (S s) = SG $ \pool -> do
ref <- newIORef (Ready undefined)
let sample p (Ready _) = s p >>= \x -> writeIORef ref (Aged undefined x) >> return x
sample _ (Aged _ x) = return x
age p (Ready _) = s p >>= \x -> writeIORef ref (Aged undefined x)
age _ _ = return ()
addSignal sample age ref pool
generator :: Signal p (SignalGen p a)
-> SignalGen p (Signal p a)
generator (S gen) = SG $ \pool -> do
ref <- newIORef (Ready undefined)
let next p = ($pool).unSG =<< gen p
sample p (Ready _) = next p >>= \x' -> writeIORef ref (Aged x' x') >> return x'
sample _ (Aged _ x) = return x
age p (Ready _) = next p >>= \x' -> writeIORef ref (Aged x' x')
age _ _ = return ()
addSignal sample age ref pool
external :: a
-> IO (Signal p a, a -> IO ())
external x = do
ref <- newIORef x
return (S (const (readIORef ref)), writeIORef ref)
externalMulti :: IO (SignalGen p (Signal p [a]), a -> IO ())
externalMulti = do
var <- newMVar []
return (SG $ \pool -> do
let sig = S $ const (readMVar var)
update <- mkWeak sig (const (return ()),takeMVar var >> putMVar var []) Nothing
modifyIORef pool (update:)
return sig
,\val -> do vals <- takeMVar var
putMVar var (val:vals)
)
stateful :: a -> (p -> a -> a) -> SignalGen p (Signal p a)
stateful x0 f = SG $ \pool -> do
ref <- newIORef (Ready x0)
let sample _ (Ready x) = return x
sample _ (Aged _ x) = return x
age p (Ready x) = let x' = f p x in x' `seq` writeIORef ref (Aged x' x)
age _ _ = return ()
addSignal sample age ref pool
transfer :: a -> (p -> t -> a -> a) -> Signal p t -> SignalGen p (Signal p a)
transfer x0 f (S s) = SG $ \pool -> do
ref <- newIORef (Ready x0)
let sample p (Ready x) = s p >>= \y -> let x' = f p y x in
x' `seq` writeIORef ref (Aged x' x') >> return x'
sample _ (Aged _ x) = return x
age p (Ready x) = s p >>= \y -> let x' = f p y x in
x' `seq` writeIORef ref (Aged x' x')
age _ _ = return ()
addSignal sample age ref pool
noise :: MTRandom a => SignalGen p (Signal p a)
noise = memo (S (const randomIO))
getRandom :: MTRandom a => SignalGen p a
getRandom = SG (const randomIO)
debug :: String -> SignalGen p ()
debug = SG . const . putStrLn
instance Show (Signal p a) where
showsPrec _ _ s = "<SIGNAL>" ++ s
instance Eq (Signal p a) where
_ == _ = False
unimp :: String -> a
unimp = error . ("Signal: "++)
instance Ord t => Ord (Signal p t) where
compare = unimp "compare"
min = liftA2 min
max = liftA2 max
instance Enum t => Enum (Signal p t) where
succ = fmap succ
pred = fmap pred
toEnum = pure . toEnum
fromEnum = unimp "fromEnum"
enumFrom = unimp "enumFrom"
enumFromThen = unimp "enumFromThen"
enumFromTo = unimp "enumFromTo"
enumFromThenTo = unimp "enumFromThenTo"
instance Bounded t => Bounded (Signal p t) where
minBound = pure minBound
maxBound = pure maxBound
instance Num t => Num (Signal p t) where
(+) = liftA2 (+)
() = liftA2 ()
(*) = liftA2 (*)
signum = fmap signum
abs = fmap abs
negate = fmap negate
fromInteger = pure . fromInteger
instance Real t => Real (Signal p t) where
toRational = unimp "toRational"
instance Integral t => Integral (Signal p t) where
quot = liftA2 quot
rem = liftA2 rem
div = liftA2 div
mod = liftA2 mod
quotRem a b = (fst <$> qrab,snd <$> qrab)
where qrab = quotRem <$> a <*> b
divMod a b = (fst <$> dmab,snd <$> dmab)
where dmab = divMod <$> a <*> b
toInteger = unimp "toInteger"
instance Fractional t => Fractional (Signal p t) where
(/) = liftA2 (/)
recip = fmap recip
fromRational = pure . fromRational
instance Floating t => Floating (Signal p t) where
pi = pure pi
exp = fmap exp
sqrt = fmap sqrt
log = fmap log
(**) = liftA2 (**)
logBase = liftA2 logBase
sin = fmap sin
tan = fmap tan
cos = fmap cos
asin = fmap asin
atan = fmap atan
acos = fmap acos
sinh = fmap sinh
tanh = fmap tanh
cosh = fmap cosh
asinh = fmap asinh
atanh = fmap atanh
acosh = fmap acosh