{-# LANGUAGE TypeOperators #-}
{-# OPTIONS -fplugin=Rattus.Plugin #-}
{-# LANGUAGE Arrows #-}
{-# LANGUAGE RebindableSyntax #-}
module Rattus.Yampa (
SF,
identity,
compose,
switch,
rSwitch,
constant,
loopPre,
stepSF,
initially,
integral,
(-->),
(-:>),
(>--),
(-=>),
(>=-),
(^>>),
(>>^),
(<<^),
(^<<),
module Rattus.Arrow, (>>>)) where
import Rattus.Primitives
import Rattus.Plugin
import Rattus.Strict
import GHC.Float
import Control.Category
import Rattus.Arrow
import Prelude hiding (id)
import Data.VectorSpace
{-# ANN module Rattus #-}
type DTime = Double
data SF a b = SF{
SF a b -> DTime -> a -> O (SF a b) :* b
stepSF :: !(DTime -> a -> (O(SF a b) :* b))}
identity :: SF a a
identity :: SF a a
identity = (DTime -> a -> O (SF a a) :* a) -> SF a a
forall a b. (DTime -> a -> O (SF a b) :* b) -> SF a b
SF (\ DTime
_ a
x -> (SF a a -> O (SF a a)
forall a. a -> O a
delay SF a a
forall a. SF a a
identity O (SF a a) -> a -> O (SF a a) :* a
forall a b. a -> b -> a :* b
:* a
x))
compose :: SF b c -> SF a b -> SF a c
compose :: SF b c -> SF a b -> SF a c
compose (SF DTime -> b -> O (SF b c) :* c
sf2) (SF DTime -> a -> O (SF a b) :* b
sf1) = (DTime -> a -> O (SF a c) :* c) -> SF a c
forall a b. (DTime -> a -> O (SF a b) :* b) -> SF a b
SF DTime -> a -> O (SF a c) :* c
sf
where sf :: DTime -> a -> O (SF a c) :* c
sf DTime
d a
a = let (O (SF a b)
r1 :* b
b) = DTime -> a -> O (SF a b) :* b
sf1 DTime
d a
a
(O (SF b c)
r2 :* c
c) = DTime -> b -> O (SF b c) :* c
sf2 DTime
d b
b
in (SF a c -> O (SF a c)
forall a. a -> O a
delay (SF b c -> SF a b -> SF a c
forall b c a. SF b c -> SF a b -> SF a c
compose (O (SF b c) -> SF b c
forall a. O a -> a
adv O (SF b c)
r2) (O (SF a b) -> SF a b
forall a. O a -> a
adv O (SF a b)
r1)) O (SF a c) -> c -> O (SF a c) :* c
forall a b. a -> b -> a :* b
:* c
c)
integral :: (Stable a, VectorSpace a s) => a -> SF a a
integral :: a -> SF a a
integral a
acc = (DTime -> a -> O (SF a a) :* a) -> SF a a
forall a b. (DTime -> a -> O (SF a b) :* b) -> SF a b
SF DTime -> a -> O (SF a a) :* a
forall s a a.
(VectorSpace a s, VectorSpace a a, Real a) =>
a -> a -> O (SF a a) :* a
sf'
where sf' :: a -> a -> O (SF a a) :* a
sf' a
t a
a = let acc' :: a
acc' = a
acc a -> a -> a
forall v a. VectorSpace v a => v -> v -> v
^+^ (a -> a
forall a b. (Real a, Fractional b) => a -> b
realToFrac a
t a -> a -> a
forall v a. VectorSpace v a => a -> v -> v
*^ a
a)
in (SF a a -> O (SF a a)
forall a. a -> O a
delay (a -> SF a a
forall a s. (Stable a, VectorSpace a s) => a -> SF a a
integral a
acc') O (SF a a) -> a -> O (SF a a) :* a
forall a b. a -> b -> a :* b
:* a
acc')
switch :: SF a (b :* Maybe' c) -> Box (c -> SF a b) -> SF a b
switch :: SF a (b :* Maybe' c) -> Box (c -> SF a b) -> SF a b
switch (SF DTime -> a -> O (SF a (b :* Maybe' c)) :* (b :* Maybe' c)
sf) Box (c -> SF a b)
f = (DTime -> a -> O (SF a b) :* b) -> SF a b
forall a b. (DTime -> a -> O (SF a b) :* b) -> SF a b
SF DTime -> a -> O (SF a b) :* b
sf'
where sf' :: DTime -> a -> O (SF a b) :* b
sf' DTime
t a
a = let (O (SF a (b :* Maybe' c))
nxt :* (b
b :* Maybe' c
c')) = DTime -> a -> O (SF a (b :* Maybe' c)) :* (b :* Maybe' c)
sf DTime
t a
a
in case Maybe' c
c' of
Just' c
c -> SF a b -> DTime -> a -> O (SF a b) :* b
forall a b. SF a b -> DTime -> a -> O (SF a b) :* b
stepSF (Box (c -> SF a b) -> c -> SF a b
forall a. Box a -> a
unbox Box (c -> SF a b)
f c
c) DTime
t a
a
Maybe' c
Nothing' -> (SF a b -> O (SF a b)
forall a. a -> O a
delay (SF a (b :* Maybe' c) -> Box (c -> SF a b) -> SF a b
forall a b c. SF a (b :* Maybe' c) -> Box (c -> SF a b) -> SF a b
switch (O (SF a (b :* Maybe' c)) -> SF a (b :* Maybe' c)
forall a. O a -> a
adv O (SF a (b :* Maybe' c))
nxt) Box (c -> SF a b)
f)O (SF a b) -> b -> O (SF a b) :* b
forall a b. a -> b -> a :* b
:* b
b)
rSwitch :: SF a b -> SF (a :* Maybe' (SF a b)) b
rSwitch :: SF a b -> SF (a :* Maybe' (SF a b)) b
rSwitch (SF DTime -> a -> O (SF a b) :* b
sf) = (DTime
-> (a :* Maybe' (SF a b)) -> O (SF (a :* Maybe' (SF a b)) b) :* b)
-> SF (a :* Maybe' (SF a b)) b
forall a b. (DTime -> a -> O (SF a b) :* b) -> SF a b
SF DTime
-> (a :* Maybe' (SF a b)) -> O (SF (a :* Maybe' (SF a b)) b) :* b
sf'
where sf' :: DTime
-> (a :* Maybe' (SF a b)) -> O (SF (a :* Maybe' (SF a b)) b) :* b
sf' DTime
t (a
a :* Maybe' (SF a b)
m) = case Maybe' (SF a b)
m of
Just' (SF DTime -> a -> O (SF a b) :* b
newSf) ->
let (O (SF a b)
nxt :* b
b) = DTime -> a -> O (SF a b) :* b
newSf DTime
t a
a
in (SF (a :* Maybe' (SF a b)) b -> O (SF (a :* Maybe' (SF a b)) b)
forall a. a -> O a
delay (SF a b -> SF (a :* Maybe' (SF a b)) b
forall a b. SF a b -> SF (a :* Maybe' (SF a b)) b
rSwitch (O (SF a b) -> SF a b
forall a. O a -> a
adv O (SF a b)
nxt)) O (SF (a :* Maybe' (SF a b)) b)
-> b -> O (SF (a :* Maybe' (SF a b)) b) :* b
forall a b. a -> b -> a :* b
:* b
b)
Maybe' (SF a b)
Nothing' -> let (O (SF a b)
nxt :* b
b) = DTime -> a -> O (SF a b) :* b
sf DTime
t a
a
in (SF (a :* Maybe' (SF a b)) b -> O (SF (a :* Maybe' (SF a b)) b)
forall a. a -> O a
delay (SF a b -> SF (a :* Maybe' (SF a b)) b
forall a b. SF a b -> SF (a :* Maybe' (SF a b)) b
rSwitch (O (SF a b) -> SF a b
forall a. O a -> a
adv O (SF a b)
nxt)) O (SF (a :* Maybe' (SF a b)) b)
-> b -> O (SF (a :* Maybe' (SF a b)) b) :* b
forall a b. a -> b -> a :* b
:* b
b)
constant :: Stable b => b -> SF a b
constant :: b -> SF a b
constant b
x = SF a b
forall a. SF a b
run
where run :: SF a b
run = (DTime -> a -> O (SF a b) :* b) -> SF a b
forall a b. (DTime -> a -> O (SF a b) :* b) -> SF a b
SF (\ DTime
_ a
_ -> (SF a b -> O (SF a b)
forall a. a -> O a
delay SF a b
run O (SF a b) -> b -> O (SF a b) :* b
forall a b. a -> b -> a :* b
:* b
x))
(-->) :: b -> SF a b -> SF a b
b
b --> :: b -> SF a b -> SF a b
--> (SF DTime -> a -> O (SF a b) :* b
sf) = (DTime -> a -> O (SF a b) :* b) -> SF a b
forall a b. (DTime -> a -> O (SF a b) :* b) -> SF a b
SF DTime -> a -> O (SF a b) :* b
sf'
where sf' :: DTime -> a -> O (SF a b) :* b
sf' DTime
d a
x = ((O (SF a b) :* b) -> O (SF a b)
forall a b. (a :* b) -> a
fst' (DTime -> a -> O (SF a b) :* b
sf DTime
d a
x) O (SF a b) -> b -> O (SF a b) :* b
forall a b. a -> b -> a :* b
:* b
b)
(-:>) :: b -> O (SF a b) -> SF a b
b
b -:> :: b -> O (SF a b) -> SF a b
-:> O (SF a b)
sf = (DTime -> a -> O (SF a b) :* b) -> SF a b
forall a b. (DTime -> a -> O (SF a b) :* b) -> SF a b
SF DTime -> a -> O (SF a b) :* b
forall p p. p -> p -> O (SF a b) :* b
sf'
where sf' :: p -> p -> O (SF a b) :* b
sf' p
_d p
_x = (O (SF a b)
sf O (SF a b) -> b -> O (SF a b) :* b
forall a b. a -> b -> a :* b
:* b
b)
(>--) :: a -> SF a b -> SF a b
a
a >-- :: a -> SF a b -> SF a b
>-- (SF DTime -> a -> O (SF a b) :* b
sf) = (DTime -> a -> O (SF a b) :* b) -> SF a b
forall a b. (DTime -> a -> O (SF a b) :* b) -> SF a b
SF DTime -> a -> O (SF a b) :* b
forall p. DTime -> p -> O (SF a b) :* b
sf'
where sf' :: DTime -> p -> O (SF a b) :* b
sf' DTime
d p
_a = DTime -> a -> O (SF a b) :* b
sf DTime
d a
a
(-=>) :: (b -> b) -> SF a b -> SF a b
b -> b
f -=> :: (b -> b) -> SF a b -> SF a b
-=> (SF DTime -> a -> O (SF a b) :* b
sf) = (DTime -> a -> O (SF a b) :* b) -> SF a b
forall a b. (DTime -> a -> O (SF a b) :* b) -> SF a b
SF DTime -> a -> O (SF a b) :* b
sf'
where sf' :: DTime -> a -> O (SF a b) :* b
sf' DTime
d a
a = let (O (SF a b)
r:*b
b) = DTime -> a -> O (SF a b) :* b
sf DTime
d a
a
in (O (SF a b)
rO (SF a b) -> b -> O (SF a b) :* b
forall a b. a -> b -> a :* b
:*b -> b
f b
b)
(>=-) :: (a -> a) -> SF a b -> SF a b
a -> a
f >=- :: (a -> a) -> SF a b -> SF a b
>=- (SF DTime -> a -> O (SF a b) :* b
sf) = (DTime -> a -> O (SF a b) :* b) -> SF a b
forall a b. (DTime -> a -> O (SF a b) :* b) -> SF a b
SF DTime -> a -> O (SF a b) :* b
sf'
where sf' :: DTime -> a -> O (SF a b) :* b
sf' DTime
d a
a = DTime -> a -> O (SF a b) :* b
sf DTime
d (a -> a
f a
a)
initially :: a -> SF a a
initially :: a -> SF a a
initially = (a -> SF a a -> SF a a
forall b a. b -> SF a b -> SF a b
--> SF a a
forall a. SF a a
identity)
arrPrim :: Box (a -> b) -> SF a b
arrPrim :: Box (a -> b) -> SF a b
arrPrim Box (a -> b)
f = SF a b
run where
run :: SF a b
run = (DTime -> a -> O (SF a b) :* b) -> SF a b
forall a b. (DTime -> a -> O (SF a b) :* b) -> SF a b
SF (\ DTime
_d a
a -> (SF a b -> O (SF a b)
forall a. a -> O a
delay SF a b
runO (SF a b) -> b -> O (SF a b) :* b
forall a b. a -> b -> a :* b
:* Box (a -> b) -> a -> b
forall a. Box a -> a
unbox Box (a -> b)
f a
a ))
{-# ANN firstPrim AllowLazyData #-}
firstPrim :: SF a b -> SF (a,c) (b,c)
firstPrim :: SF a b -> SF (a, c) (b, c)
firstPrim (SF DTime -> a -> O (SF a b) :* b
sf) = (DTime -> (a, c) -> O (SF (a, c) (b, c)) :* (b, c))
-> SF (a, c) (b, c)
forall a b. (DTime -> a -> O (SF a b) :* b) -> SF a b
SF DTime -> (a, c) -> O (SF (a, c) (b, c)) :* (b, c)
forall b c. DTime -> (a, b) -> O (SF (a, c) (b, c)) :* (b, b)
sf'
where sf' :: DTime -> (a, b) -> O (SF (a, c) (b, c)) :* (b, b)
sf' DTime
d (a
a,b
c) = let (O (SF a b)
r:* b
b) = DTime -> a -> O (SF a b) :* b
sf DTime
d a
a
in (SF (a, c) (b, c) -> O (SF (a, c) (b, c))
forall a. a -> O a
delay (SF a b -> SF (a, c) (b, c)
forall a b c. SF a b -> SF (a, c) (b, c)
firstPrim (O (SF a b) -> SF a b
forall a. O a -> a
adv O (SF a b)
r))O (SF (a, c) (b, c)) -> (b, b) -> O (SF (a, c) (b, c)) :* (b, b)
forall a b. a -> b -> a :* b
:* (b
b,b
c))
{-# ANN secondPrim AllowLazyData #-}
secondPrim :: SF a b -> SF (c,a) (c,b)
secondPrim :: SF a b -> SF (c, a) (c, b)
secondPrim (SF DTime -> a -> O (SF a b) :* b
sf) = (DTime -> (c, a) -> O (SF (c, a) (c, b)) :* (c, b))
-> SF (c, a) (c, b)
forall a b. (DTime -> a -> O (SF a b) :* b) -> SF a b
SF DTime -> (c, a) -> O (SF (c, a) (c, b)) :* (c, b)
forall a c. DTime -> (a, a) -> O (SF (c, a) (c, b)) :* (a, b)
sf'
where sf' :: DTime -> (a, a) -> O (SF (c, a) (c, b)) :* (a, b)
sf' DTime
d (a
c,a
a) = let (O (SF a b)
r:* b
b) = DTime -> a -> O (SF a b) :* b
sf DTime
d a
a
in (SF (c, a) (c, b) -> O (SF (c, a) (c, b))
forall a. a -> O a
delay (SF a b -> SF (c, a) (c, b)
forall a b c. SF a b -> SF (c, a) (c, b)
secondPrim (O (SF a b) -> SF a b
forall a. O a -> a
adv O (SF a b)
r))O (SF (c, a) (c, b)) -> (a, b) -> O (SF (c, a) (c, b)) :* (a, b)
forall a b. a -> b -> a :* b
:* (a
c,b
b))
{-# ANN parSplitPrim AllowLazyData #-}
parSplitPrim :: SF a b -> SF c d -> SF (a,c) (b,d)
parSplitPrim :: SF a b -> SF c d -> SF (a, c) (b, d)
parSplitPrim (SF DTime -> a -> O (SF a b) :* b
sf1) (SF DTime -> c -> O (SF c d) :* d
sf2) = (DTime -> (a, c) -> O (SF (a, c) (b, d)) :* (b, d))
-> SF (a, c) (b, d)
forall a b. (DTime -> a -> O (SF a b) :* b) -> SF a b
SF DTime -> (a, c) -> O (SF (a, c) (b, d)) :* (b, d)
sf'
where sf' :: DTime -> (a, c) -> O (SF (a, c) (b, d)) :* (b, d)
sf' DTime
dt (a
a,c
c) = let (O (SF a b)
r1:* b
b) = DTime -> a -> O (SF a b) :* b
sf1 DTime
dt a
a
(O (SF c d)
r2:* d
d) = DTime -> c -> O (SF c d) :* d
sf2 DTime
dt c
c
in (SF (a, c) (b, d) -> O (SF (a, c) (b, d))
forall a. a -> O a
delay (SF a b -> SF c d -> SF (a, c) (b, d)
forall a b c d. SF a b -> SF c d -> SF (a, c) (b, d)
parSplitPrim (O (SF a b) -> SF a b
forall a. O a -> a
adv O (SF a b)
r1) (O (SF c d) -> SF c d
forall a. O a -> a
adv O (SF c d)
r2))O (SF (a, c) (b, d)) -> (b, d) -> O (SF (a, c) (b, d)) :* (b, d)
forall a b. a -> b -> a :* b
:* (b
b,d
d))
{-# ANN parFanOutPrim AllowLazyData #-}
parFanOutPrim :: SF a b -> SF a c -> SF a (b, c)
parFanOutPrim :: SF a b -> SF a c -> SF a (b, c)
parFanOutPrim (SF DTime -> a -> O (SF a b) :* b
sf1) (SF DTime -> a -> O (SF a c) :* c
sf2) = (DTime -> a -> O (SF a (b, c)) :* (b, c)) -> SF a (b, c)
forall a b. (DTime -> a -> O (SF a b) :* b) -> SF a b
SF DTime -> a -> O (SF a (b, c)) :* (b, c)
sf'
where sf' :: DTime -> a -> O (SF a (b, c)) :* (b, c)
sf' DTime
dt a
a = let (O (SF a b)
r1:* b
b) = DTime -> a -> O (SF a b) :* b
sf1 DTime
dt a
a
(O (SF a c)
r2:* c
c) = DTime -> a -> O (SF a c) :* c
sf2 DTime
dt a
a
in (SF a (b, c) -> O (SF a (b, c))
forall a. a -> O a
delay (SF a b -> SF a c -> SF a (b, c)
forall a b c. SF a b -> SF a c -> SF a (b, c)
parFanOutPrim (O (SF a b) -> SF a b
forall a. O a -> a
adv O (SF a b)
r1) (O (SF a c) -> SF a c
forall a. O a -> a
adv O (SF a c)
r2))O (SF a (b, c)) -> (b, c) -> O (SF a (b, c)) :* (b, c)
forall a b. a -> b -> a :* b
:* (b
b,c
c))
instance Category SF where
id :: SF a a
id = SF a a
forall a. SF a a
identity
. :: SF b c -> SF a b -> SF a c
(.) = SF b c -> SF a b -> SF a c
forall b c a. SF b c -> SF a b -> SF a c
compose
instance Arrow SF where
arrBox :: Box (b -> c) -> SF b c
arrBox = Box (b -> c) -> SF b c
forall b c. Box (b -> c) -> SF b c
arrPrim
first :: SF b c -> SF (b, d) (c, d)
first = SF b c -> SF (b, d) (c, d)
forall a b c. SF a b -> SF (a, c) (b, c)
firstPrim
second :: SF b c -> SF (d, b) (d, c)
second = SF b c -> SF (d, b) (d, c)
forall a b c. SF a b -> SF (c, a) (c, b)
secondPrim
*** :: SF b c -> SF b' c' -> SF (b, b') (c, c')
(***) = SF b c -> SF b' c' -> SF (b, b') (c, c')
forall a b c d. SF a b -> SF c d -> SF (a, c) (b, d)
parSplitPrim
&&& :: SF b c -> SF b c' -> SF b (c, c')
(&&&) = SF b c -> SF b c' -> SF b (c, c')
forall a b c. SF a b -> SF a c -> SF a (b, c)
parFanOutPrim
loopPre :: c -> SF (a:*c) (b:*O c) -> SF a b
loopPre :: c -> SF (a :* c) (b :* O c) -> SF a b
loopPre c
c (SF DTime -> (a :* c) -> O (SF (a :* c) (b :* O c)) :* (b :* O c)
sf) = (DTime -> a -> O (SF a b) :* b) -> SF a b
forall a b. (DTime -> a -> O (SF a b) :* b) -> SF a b
SF DTime -> a -> O (SF a b) :* b
sf'
where sf' :: DTime -> a -> O (SF a b) :* b
sf' DTime
d a
a = let (O (SF (a :* c) (b :* O c))
r:* (b
b:*O c
c')) = DTime -> (a :* c) -> O (SF (a :* c) (b :* O c)) :* (b :* O c)
sf DTime
d (a
aa -> c -> a :* c
forall a b. a -> b -> a :* b
:*c
c)
in (SF a b -> O (SF a b)
forall a. a -> O a
delay (c -> SF (a :* c) (b :* O c) -> SF a b
forall c a b. c -> SF (a :* c) (b :* O c) -> SF a b
loopPre (O c -> c
forall a. O a -> a
adv O c
c') (O (SF (a :* c) (b :* O c)) -> SF (a :* c) (b :* O c)
forall a. O a -> a
adv O (SF (a :* c) (b :* O c))
r))O (SF a b) -> b -> O (SF a b) :* b
forall a b. a -> b -> a :* b
:* b
b)
(^>>) :: Arrow a => Box (b -> c) -> a c d -> a b d
Box (b -> c)
f ^>> :: Box (b -> c) -> a c d -> a b d
^>> a c d
a = Box (b -> c) -> a b c
forall (a :: * -> * -> *) b c. Arrow a => Box (b -> c) -> a b c
arrBox Box (b -> c)
f a b c -> a c d -> a b d
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> a c d
a
(>>^) :: Arrow a => a b c -> Box (c -> d) -> a b d
a b c
a >>^ :: a b c -> Box (c -> d) -> a b d
>>^ Box (c -> d)
f = a b c
a a b c -> a c d -> a b d
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> Box (c -> d) -> a c d
forall (a :: * -> * -> *) b c. Arrow a => Box (b -> c) -> a b c
arrBox Box (c -> d)
f
(<<^) :: Arrow a => a c d -> Box (b -> c) -> a b d
a c d
a <<^ :: a c d -> Box (b -> c) -> a b d
<<^ Box (b -> c)
f = a c d
a a c d -> a b c -> a b d
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
<<< Box (b -> c) -> a b c
forall (a :: * -> * -> *) b c. Arrow a => Box (b -> c) -> a b c
arrBox Box (b -> c)
f
(^<<) :: Arrow a => Box (c -> d) -> a b c -> a b d
Box (c -> d)
f ^<< :: Box (c -> d) -> a b c -> a b d
^<< a b c
a = Box (c -> d) -> a c d
forall (a :: * -> * -> *) b c. Arrow a => Box (b -> c) -> a b c
arrBox Box (c -> d)
f a c d -> a b c -> a b d
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
<<< a b c
a