module FRP.Elerea.Param
( Signal
, SignalGen
, start
, external
, externalMulti
, delay
, generator
, memo
, until
, input
, embed
, stateful
, transfer
, 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 Prelude hiding (until)
import System.Mem.Weak
import System.Random.Mersenne
newtype Signal a = S (IO a) deriving (Functor, Applicative, Monad)
type UpdatePool = [Weak (IO (), IO ())]
newtype SignalGen p a = SG { unSG :: IORef UpdatePool -> Signal p -> IO a }
data Phase s a = Ready s | Aged s a
instance Functor (SignalGen p) where
fmap = liftM
instance Applicative (SignalGen p) where
pure = return
(<*>) = ap
instance Monad (SignalGen p) where
return = SG . const . const . return
SG g >>= f = SG $ \p i -> g p i >>= \x -> unSG (f x) p i
instance MonadFix (SignalGen p) where
mfix f = SG $ \p i -> mfix (($i).($p).unSG.f)
start :: SignalGen p (Signal a)
-> IO (p -> IO a)
start (SG gen) = do
pool <- newIORef []
(inp,sink) <- external undefined
S sample <- gen pool inp
ptrs0 <- readIORef pool
writeIORef pool []
(as0,cs0) <- unzip . map fromJust <$> mapM deRefWeak ptrs0
let ageStatic = sequence_ as0
commitStatic = sequence_ cs0
return $ \param -> do
let update [] ptrs age commit = do
writeIORef pool ptrs
ageStatic >> 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) (commit >> c)
sink param
res <- sample
ptrs <- readIORef pool
update ptrs [] (return ()) (return ())
return res
addSignal :: (Phase s a -> IO a)
-> (Phase s a -> IO ())
-> IORef (Phase s a)
-> IORef UpdatePool
-> IO (Signal a)
addSignal sample age ref pool = do
let commit (Aged s _) = Ready s
commit _ = error "commit error: signal not aged"
sig = S $ readIORef ref >>= sample
update <- mkWeak sig (readIORef ref >>= age, modifyIORef ref commit) Nothing
modifyIORef pool (update:)
return sig
delay :: a
-> Signal a
-> SignalGen p (Signal a)
delay x0 (S s) = SG $ \pool _ -> do
ref <- newIORef (Ready x0)
let sample (Ready x) = return x
sample (Aged _ x) = return x
age (Ready x) = s >>= \x' -> x' `seq` writeIORef ref (Aged x' x)
age _ = return ()
addSignal sample age ref pool
memo :: Signal a
-> SignalGen p (Signal a)
memo (S s) = SG $ \pool _ -> do
ref <- newIORef (Ready undefined)
let sample (Ready _) = s >>= \x -> writeIORef ref (Aged undefined x) >> return x
sample (Aged _ x) = return x
age (Ready _) = s >>= \x -> writeIORef ref (Aged undefined x)
age _ = return ()
addSignal sample age ref pool
generator :: Signal (SignalGen p a)
-> SignalGen p (Signal a)
generator (S gen) = SG $ \pool inp -> do
ref <- newIORef (Ready undefined)
let next = ($inp).($pool).unSG =<< gen
sample (Ready _) = next >>= \x' -> writeIORef ref (Aged x' x') >> return x'
sample (Aged _ x) = return x
age (Ready _) = next >>= \x' -> writeIORef ref (Aged x' x')
age _ = return ()
addSignal sample age ref pool
until :: Signal Bool
-> SignalGen p (Signal Bool)
until (S s) = SG $ \pool _ -> do
ref <- newIORef (Ready undefined)
rsmp <- mfix $ \rs -> newIORef $ do
x <- s
writeIORef ref (Aged undefined x)
when x $ writeIORef rs $ do
writeIORef ref (Aged undefined False)
return False
return x
let sample = join (readIORef rsmp)
addSignal (const sample) (const (() <$ sample)) ref pool
input :: SignalGen p (Signal p)
input = SG $ const return
embed :: Signal p' -> SignalGen p' a -> SignalGen p a
embed s (SG g) = SG $ \pool _ -> g pool s
external :: a
-> IO (Signal a, a -> IO ())
external x = do
ref <- newIORef x
return (S (readIORef ref), writeIORef ref)
externalMulti :: IO (SignalGen p (Signal [a]), a -> IO ())
externalMulti = do
var <- newMVar []
return (SG $ \pool _ -> do
let sig = S $ readMVar var
update <- mkWeak sig (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 a)
stateful x0 f = mfix $ \sig -> input >>= \i -> delay x0 (f <$> i <*> sig)
transfer :: a
-> (p -> t -> a -> a)
-> Signal t
-> SignalGen p (Signal a)
transfer x0 f s = mfix $ \sig -> input >>= \i -> liftA3 f i s <$> delay x0 sig
noise :: MTRandom a => SignalGen p (Signal a)
noise = memo (S randomIO)
getRandom :: MTRandom a => SignalGen p a
getRandom = SG (const (const randomIO))
debug :: String -> SignalGen p ()
debug = SG . const . const . putStrLn
instance Show (Signal a) where
showsPrec _ _ s = "<SIGNAL>" ++ s
instance Eq (Signal a) where
_ == _ = False
unimp :: String -> a
unimp = error . ("Signal: "++)
instance Ord t => Ord (Signal t) where
compare = unimp "compare"
min = liftA2 min
max = liftA2 max
instance Enum t => Enum (Signal 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 t) where
minBound = pure minBound
maxBound = pure maxBound
instance Num t => Num (Signal t) where
(+) = liftA2 (+)
() = liftA2 ()
(*) = liftA2 (*)
signum = fmap signum
abs = fmap abs
negate = fmap negate
fromInteger = pure . fromInteger
instance Real t => Real (Signal t) where
toRational = unimp "toRational"
instance Integral t => Integral (Signal 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 t) where
(/) = liftA2 (/)
recip = fmap recip
fromRational = pure . fromRational
instance Floating t => Floating (Signal 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