module FRP.Elerea.Internal where
import Control.Applicative
import Control.Monad
import Control.Monad.Fix
import Data.IORef
import System.IO.Unsafe
type DTime = Double
type Sink a = a -> IO ()
newtype SignalMonad a = SM { createSignal :: IO a } deriving (Monad,Applicative,Functor,MonadFix)
signalDebug :: Show a => a -> SignalMonad ()
signalDebug = SM . print
newtype Signal a = S (IORef (SignalTrans a))
data SignalTrans a
= Ready (SignalNode a)
| Sampling (SignalNode a)
| Sampled a (SignalNode a)
| Aged a (SignalNode a)
data SignalNode a
= SNK a
| SNS a (DTime -> a -> a)
| forall t . SNT (Signal t) a (DTime -> t -> a -> a)
| forall t . SNA (Signal (t -> a)) (Signal t)
| SNH (Signal (Signal a)) (IORef (Signal a))
| SNM (Signal Bool) (Signal (SignalMonad a))
| SNE (IORef a)
| SND a (Signal a)
| forall t . SNKA (Signal a) (Signal t)
| forall t . SNF1 (t -> a) (Signal t)
| forall t1 t2 . SNF2 (t1 -> t2 -> a) (Signal t1) (Signal t2)
| forall t1 t2 t3 . SNF3 (t1 -> t2 -> t3 -> a) (Signal t1) (Signal t2) (Signal t3)
| forall t1 t2 t3 t4 . SNF4 (t1 -> t2 -> t3 -> t4 -> a) (Signal t1) (Signal t2) (Signal t3) (Signal t4)
| forall t1 t2 t3 t4 t5 . SNF5 (t1 -> t2 -> t3 -> t4 -> t5 -> a) (Signal t1) (Signal t2) (Signal t3) (Signal t4) (Signal t5)
debugLog :: String -> IO a -> IO a
debugLog _ io = io
instance Functor Signal where
fmap = (<*>) . pure
instance Applicative Signal where
pure = makeSignalUnsafe . SNK
f@(S rf) <*> x@(S rx) = unsafePerformIO $ do
c <- newIORef (Ready (SNA f x))
let opt s = writeIORef c (Ready s)
flip catch (const (debugLog "no_fun" $ return ())) $ do
Ready nf <- readIORef rf
merged <- flip catch (const (debugLog "no_arg" $ return False)) $ do
Ready nx <- readIORef rx
case (nf,nx) of
(SNK g,SNK y) -> debugLog "merge_00" $ opt (SNK (g y))
(SNK g,SNF1 h y1) -> debugLog "merge_01" $ opt (SNF1 (g.h) y1)
(SNK g,SNF2 h y1 y2) -> debugLog "merge_02" $ opt (SNF2 (\y1 y2 -> g (h y1 y2)) y1 y2)
(SNK g,SNF3 h y1 y2 y3) -> debugLog "merge_03" $ opt (SNF3 (\y1 y2 y3 -> g (h y1 y2 y3)) y1 y2 y3)
(SNK g,SNF4 h y1 y2 y3 y4) -> debugLog "merge_04" $ opt (SNF4 (\y1 y2 y3 y4 -> g (h y1 y2 y3 y4)) y1 y2 y3 y4)
(SNK g,SNF5 h y1 y2 y3 y4 y5) -> debugLog "merge_05" $ opt (SNF5 (\y1 y2 y3 y4 y5 -> g (h y1 y2 y3 y4 y5)) y1 y2 y3 y4 y5)
(SNK g,_) -> debugLog "lift_1x" $ opt (SNF1 g x)
(SNF1 g x1,SNK y) -> debugLog "merge_10" $ opt (SNF1 (\x1 -> g x1 y) x1)
(SNF1 g x1,SNF1 h y1) -> debugLog "merge_11" $ opt (SNF2 (\x1 y1 -> g x1 (h y1)) x1 y1)
(SNF1 g x1,SNF2 h y1 y2) -> debugLog "merge_12" $ opt (SNF3 (\x1 y1 y2 -> g x1 (h y1 y2)) x1 y1 y2)
(SNF1 g x1,SNF3 h y1 y2 y3) -> debugLog "merge_13" $ opt (SNF4 (\x1 y1 y2 y3 -> g x1 (h y1 y2 y3)) x1 y1 y2 y3)
(SNF1 g x1,SNF4 h y1 y2 y3 y4) -> debugLog "merge_14" $ opt (SNF5 (\x1 y1 y2 y3 y4 -> g x1 (h y1 y2 y3 y4)) x1 y1 y2 y3 y4)
(SNF1 g x1,_) -> debugLog "lift_2x" $ opt (SNF2 g x1 x)
(SNF2 g x1 x2,SNK y) -> debugLog "merge_20" $ opt (SNF2 (\x1 x2 -> g x1 x2 y) x1 x2)
(SNF2 g x1 x2,SNF1 h y1) -> debugLog "merge_21" $ opt (SNF3 (\x1 x2 y1 -> g x1 x2 (h y1)) x1 x2 y1)
(SNF2 g x1 x2,SNF2 h y1 y2) -> debugLog "merge_22" $ opt (SNF4 (\x1 x2 y1 y2 -> g x1 x2 (h y1 y2)) x1 x2 y1 y2)
(SNF2 g x1 x2,SNF3 h y1 y2 y3) -> debugLog "merge_23" $ opt (SNF5 (\x1 x2 y1 y2 y3 -> g x1 x2 (h y1 y2 y3)) x1 x2 y1 y2 y3)
(SNF2 g x1 x2,_) -> debugLog "lift_3x" $ opt (SNF3 g x1 x2 x)
(SNF3 g x1 x2 x3,SNK y) -> debugLog "merge_30" $ opt (SNF3 (\x1 x2 x3 -> g x1 x2 x3 y) x1 x2 x3)
(SNF3 g x1 x2 x3,SNF1 h y1) -> debugLog "merge_31" $ opt (SNF4 (\x1 x2 x3 y1 -> g x1 x2 x3 (h y1)) x1 x2 x3 y1)
(SNF3 g x1 x2 x3,SNF2 h y1 y2) -> debugLog "merge_32" $ opt (SNF5 (\x1 x2 x3 y1 y2 -> g x1 x2 x3 (h y1 y2)) x1 x2 x3 y1 y2)
(SNF3 g x1 x2 x3,_) -> debugLog "lift_4x" $ opt (SNF4 g x1 x2 x3 x)
(SNF4 g x1 x2 x3 x4,SNK y) -> debugLog "merge_40" $ opt (SNF4 (\x1 x2 x3 x4 -> g x1 x2 x3 x4 y) x1 x2 x3 x4)
(SNF4 g x1 x2 x3 x4,SNF1 h y1) -> debugLog "merge_41" $ opt (SNF5 (\x1 x2 x3 x4 y1 -> g x1 x2 x3 x4 (h y1)) x1 x2 x3 x4 y1)
(SNF4 g x1 x2 x3 x4,_) -> debugLog "lift_5x" $ opt (SNF5 g x1 x2 x3 x4 x)
(SNF5 g x1 x2 x3 x4 x5,SNK y) -> debugLog "merge_50" $ opt (SNF5 (\x1 x2 x3 x4 x5 -> g x1 x2 x3 x4 x5 y) x1 x2 x3 x4 x5)
_ -> return ()
return True
when (not merged) $ case nf of
SNK g -> debugLog "lift_1" $ opt (SNF1 g x)
SNF1 g x1 -> debugLog "lift_2" $ opt (SNF2 g x1 x)
SNF2 g x1 x2 -> debugLog "lift_3" $ opt (SNF3 g x1 x2 x)
SNF3 g x1 x2 x3 -> debugLog "lift_4" $ opt (SNF4 g x1 x2 x3 x)
SNF4 g x1 x2 x3 x4 -> debugLog "lift_5" $ opt (SNF5 g x1 x2 x3 x4 x)
_ -> return ()
return (S c)
instance Show (Signal a) where
showsPrec _ _ s = "<SIGNAL>" ++ s
instance Eq (Signal a) where
S s1 == S s2 = s1 == s2
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
makeSignal :: SignalNode a -> SignalMonad (Signal a)
makeSignal node = SM $ do
ref <- newIORef (Ready node)
return (S ref)
makeSignalUnsafe :: SignalNode a -> Signal a
makeSignalUnsafe = S . unsafePerformIO . newIORef . Ready
signalValue :: forall a . Signal a -> DTime -> IO a
signalValue (S r) dt = do
t <- readIORef r
case t of
Ready s -> do writeIORef r (Sampling s)
v <- sample s dt
writeIORef r (Sampled v s)
return v
Sampling s -> do
v <- sampleDelayed s dt
writeIORef r (Sampled v s)
return v
Sampled v _ -> return v
Aged v _ -> return v
age :: forall a . Signal a -> DTime -> IO ()
age (S r) dt = do
t <- readIORef r
case t of
Sampled v s -> do s' <- advance s v dt
writeIORef r (Aged v s')
case s' of
SNT s _ _ -> age s dt
SNA sf sx -> age sf dt >> age sx dt
SNH ss r -> age ss dt >> readIORef r >>= \s -> age s dt
SNM b sm -> age b dt >> age sm dt
SND _ s -> age s dt
SNKA s l -> age s dt >> age l dt
SNF1 _ s -> age s dt
SNF2 _ s1 s2 -> age s1 dt >> age s2 dt
SNF3 _ s1 s2 s3 -> age s1 dt >> age s2 dt >> age s3 dt
SNF4 _ s1 s2 s3 s4 -> age s1 dt >> age s2 dt >> age s3 dt >> age s4 dt
SNF5 _ s1 s2 s3 s4 s5 -> age s1 dt >> age s2 dt >> age s3 dt >> age s4 dt >> age s5 dt
_ -> return ()
Aged _ _ -> return ()
_ -> error "Inconsistent state: signal not sampled properly!"
commit :: forall a . Signal a -> IO ()
commit (S r) = do
t <- readIORef r
case t of
Aged _ s -> do writeIORef r (Ready s)
case s of
SNT s _ _ -> commit s
SNA sf sx -> commit sf >> commit sx
SNH ss r -> commit ss >> readIORef r >>= \s -> commit s
SNM b sm -> commit b >> commit sm
SND _ s -> commit s
SNKA s l -> commit s >> commit l
SNF1 _ s -> commit s
SNF2 _ s1 s2 -> commit s1 >> commit s2
SNF3 _ s1 s2 s3 -> commit s1 >> commit s2 >> commit s3
SNF4 _ s1 s2 s3 s4 -> commit s1 >> commit s2 >> commit s3 >> commit s4
SNF5 _ s1 s2 s3 s4 s5 -> commit s1 >> commit s2 >> commit s3 >> commit s4 >> commit s5
_ -> return ()
Ready _ -> return ()
_ -> error "Inconsistent state: signal not aged properly!"
advance :: SignalNode a -> a -> DTime -> IO (SignalNode a)
advance (SNS x f) _ dt = x `seq` return (SNS (f dt x) f)
advance (SNT s _ f) v _ = v `seq` return (SNT s v f)
advance (SND _ s) _ dt = do x <- signalValue s dt
return (SND x s)
advance s _ _ = return s
sample :: SignalNode a -> DTime -> IO a
sample (SNK x) _ = return x
sample (SNS x _) _ = return x
sample (SNT s x f) dt = do t <- signalValue s dt
return $! f dt t x
sample (SNA sf sx) dt = signalValue sf dt <*> signalValue sx dt
sample (SNH ss r) dt = do s <- signalValue ss dt
writeIORef r s
signalValue s dt
sample (SNM b sm) dt = do c <- signalValue b dt
SM m <- signalValue sm dt
if c then m else return undefined
sample (SNE r) _ = readIORef r
sample (SND v _) _ = return v
sample (SNKA s l) dt = do signalValue l dt
signalValue s dt
sample (SNF1 f s) dt = f <$> signalValue s dt
sample (SNF2 f s1 s2) dt = liftM2 f (signalValue s1 dt) (signalValue s2 dt)
sample (SNF3 f s1 s2 s3) dt = liftM3 f (signalValue s1 dt) (signalValue s2 dt) (signalValue s3 dt)
sample (SNF4 f s1 s2 s3 s4) dt = liftM4 f (signalValue s1 dt) (signalValue s2 dt) (signalValue s3 dt) (signalValue s4 dt)
sample (SNF5 f s1 s2 s3 s4 s5) dt = liftM5 f (signalValue s1 dt) (signalValue s2 dt) (signalValue s3 dt) (signalValue s4 dt) (signalValue s5 dt)
sampleDelayed :: SignalNode a -> DTime -> IO a
sampleDelayed (SNT _ x _) _ = return x
sampleDelayed sn dt = sample sn dt
superstep :: Signal a
-> DTime
-> IO a
superstep world dt = do
snapshot <- signalValue world dt
age world dt
commit world
return snapshot
stateful :: a
-> (DTime -> a -> a)
-> SignalMonad (Signal a)
stateful x0 f = makeSignal (SNS x0 f)
transfer :: a
-> (DTime -> t -> a -> a)
-> Signal t
-> SignalMonad (Signal a)
transfer x0 f s = makeSignal (SNT s x0 f)
sampler :: Signal (Signal a)
-> Signal a
sampler ss = makeSignalUnsafe (SNH ss (unsafePerformIO (newIORef undefined)))
generator :: Signal Bool
-> Signal (SignalMonad a)
-> Signal (Maybe a)
generator b sm = toMaybe <$> b <*> makeSignalUnsafe (SNM b sm)
toMaybe :: Bool -> a -> Maybe a
toMaybe c v = if c then Just v else Nothing
external :: a
-> IO (Signal a, Sink a)
external x0 = do
ref <- newIORef x0
snr <- newIORef (Ready (SNE ref))
return (S snr,writeIORef ref)
delay :: a
-> Signal a
-> SignalMonad (Signal a)
delay x0 s = makeSignal (SND x0 s)
keepAlive :: Signal a
-> Signal t
-> Signal a
keepAlive s l = makeSignalUnsafe (SNKA s l)