{-# LANGUAGE ExistentialQuantification #-}
module Synthesizer.CausalIO.Process (
T(Cons),
fromCausal,
mapAccum,
Synthesizer.CausalIO.Process.traverse,
runCont,
runStorableChunkyCont,
zip,
continue,
continueChunk,
) where
import qualified Synthesizer.Causal.Process as Causal
import qualified Synthesizer.Generic.Signal as SigG
import qualified Synthesizer.Generic.Cut as CutG
import qualified Synthesizer.Zip as Zip
import qualified Data.StorableVector.Lazy as SVL
import qualified Data.StorableVector as SV
import Foreign.Storable (Storable, )
import qualified Control.Monad.Trans.State as MS
import qualified Control.Arrow as Arr
import qualified Control.Category as Cat
import Control.Arrow ((^<<), (&&&), )
import Control.Monad (mplus, )
import Data.Monoid (Monoid, mempty, mappend, )
import Data.Semigroup (Semigroup, (<>), )
import System.IO.Unsafe (unsafePerformIO, unsafeInterleaveIO, )
import Prelude hiding (zip, )
data T a b =
forall state.
Cons
(a -> state -> IO (b, state))
(IO state)
(state -> IO ())
instance Cat.Category T where
id :: forall a. T a a
id = forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
Arr.arr forall a. a -> a
id
(Cons b -> state -> IO (c, state)
nextB IO state
createB state -> IO ()
deleteB) . :: forall b c a. T b c -> T a b -> T a c
.
(Cons a -> state -> IO (b, state)
nextA IO state
createA state -> IO ()
deleteA) = forall a b state.
(a -> state -> IO (b, state))
-> IO state -> (state -> IO ()) -> T a b
Cons
(\a
a (state
sa0,state
sb0) -> do
(b
b,state
sa1) <- a -> state -> IO (b, state)
nextA a
a state
sa0
(c
c,state
sb1) <- b -> state -> IO (c, state)
nextB b
b state
sb0
forall (m :: * -> *) a. Monad m => a -> m a
return (c
c,(state
sa1,state
sb1)))
(do
state
sa <- IO state
createA
state
sb <- IO state
createB
forall (m :: * -> *) a. Monad m => a -> m a
return (state
sa,state
sb))
(\(state
sa,state
sb) ->
state -> IO ()
deleteA state
sa forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> state -> IO ()
deleteB state
sb)
instance Arr.Arrow T where
arr :: forall b c. (b -> c) -> T b c
arr b -> c
f = forall a b state.
(a -> state -> IO (b, state))
-> IO state -> (state -> IO ()) -> T a b
Cons
(\ b
a () -> forall (m :: * -> *) a. Monad m => a -> m a
return (b -> c
f b
a, ()))
(forall (m :: * -> *) a. Monad m => a -> m a
return ())
(\ () -> forall (m :: * -> *) a. Monad m => a -> m a
return ())
first :: forall b c d. T b c -> T (b, d) (c, d)
first (Cons b -> state -> IO (c, state)
next IO state
create state -> IO ()
delete) = forall a b state.
(a -> state -> IO (b, state))
-> IO state -> (state -> IO ()) -> T a b
Cons
(\(b
b,d
d) state
sa0 ->
do (c
c,state
sa1) <- b -> state -> IO (c, state)
next b
b state
sa0
forall (m :: * -> *) a. Monad m => a -> m a
return ((c
c,d
d), state
sa1))
IO state
create
state -> IO ()
delete
fromCausal ::
(Monoid b) =>
Causal.T a b -> T a b
fromCausal :: forall b a. Monoid b => T a b -> T a b
fromCausal (Causal.Cons a -> StateT s Maybe b
next s
start) = forall a b state.
(a -> state -> IO (b, state))
-> IO state -> (state -> IO ()) -> T a b
Cons
(\a
a s
s0 ->
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
case forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
MS.runStateT (a -> StateT s Maybe b
next a
a) s
s0 of
Maybe (b, s)
Nothing -> (forall a. Monoid a => a
mempty, s
s0)
Just (b
b,s
s1) -> (b
b,s
s1))
(forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ s
start)
(\ s
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ())
mapAccum ::
(a -> state -> (b, state)) ->
state ->
T a b
mapAccum :: forall a state b. (a -> state -> (b, state)) -> state -> T a b
mapAccum a -> state -> (b, state)
next state
start =
forall a b state.
(a -> state -> IO (b, state))
-> IO state -> (state -> IO ()) -> T a b
Cons
(\a
a state
s -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ a -> state -> (b, state)
next a
a state
s)
(forall (m :: * -> *) a. Monad m => a -> m a
return state
start)
(\ state
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ())
traverse ::
state ->
(a -> MS.State state b) ->
T a b
traverse :: forall state a b. state -> (a -> State state b) -> T a b
traverse state
start a -> State state b
next =
forall a b state.
(a -> state -> IO (b, state))
-> IO state -> (state -> IO ()) -> T a b
Cons
(\a
a state
s -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall s a. State s a -> s -> (a, s)
MS.runState (a -> State state b
next a
a) state
s)
(forall (m :: * -> *) a. Monad m => a -> m a
return state
start)
(\ state
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ())
runCont ::
(CutG.Transform a, CutG.Transform b) =>
T a b -> IO (([a] -> [b]) -> [a] -> [b])
runCont :: forall a b.
(Transform a, Transform b) =>
T a b -> IO (([a] -> [b]) -> [a] -> [b])
runCont (Cons a -> state -> IO (b, state)
next IO state
create state -> IO ()
delete) =
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
\ [a] -> [b]
procRest [a]
sig ->
forall a. IO a -> a
unsafePerformIO forall a b. (a -> b) -> a -> b
$ do
let go :: [a] -> state -> IO [b]
go [a]
xt state
s0 =
forall a. IO a -> IO a
unsafeInterleaveIO forall a b. (a -> b) -> a -> b
$
case [a]
xt of
[] -> state -> IO ()
delete state
s0 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return []
a
x:[a]
xs -> do
(b
y,state
s1) <- a -> state -> IO (b, state)
next a
x state
s0
(if forall sig. Read sig => sig -> Int
CutG.length b
y forall a. Ord a => a -> a -> Bool
> Int
0
then forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (b
yforall a. a -> [a] -> [a]
:)
else forall a. a -> a
id) forall a b. (a -> b) -> a -> b
$
(if forall sig. Read sig => sig -> Int
CutG.length b
y forall a. Ord a => a -> a -> Bool
< forall sig. Read sig => sig -> Int
CutG.length a
x
then forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [a] -> [b]
procRest forall a b. (a -> b) -> a -> b
$
forall sig. Transform sig => Int -> sig -> sig
CutG.drop (forall sig. Read sig => sig -> Int
CutG.length b
y) a
x forall a. a -> [a] -> [a]
: [a]
xs
else [a] -> state -> IO [b]
go [a]
xs state
s1)
[a] -> state -> IO [b]
go [a]
sig forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO state
create
runStorableChunkyCont ::
(Storable a, Storable b) =>
T (SV.Vector a) (SV.Vector b) ->
IO ((SVL.Vector a -> SVL.Vector b) ->
SVL.Vector a -> SVL.Vector b)
runStorableChunkyCont :: forall a b.
(Storable a, Storable b) =>
T (Vector a) (Vector b)
-> IO ((Vector a -> Vector b) -> Vector a -> Vector b)
runStorableChunkyCont T (Vector a) (Vector b)
proc =
forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b.
(Transform a, Transform b) =>
T a b -> IO (([a] -> [b]) -> [a] -> [b])
runCont T (Vector a) (Vector b)
proc) forall a b. (a -> b) -> a -> b
$ \([Vector a] -> [Vector b]) -> [Vector a] -> [Vector b]
f Vector a -> Vector b
cont ->
forall a. Storable a => [Vector a] -> Vector a
SVL.fromChunks forall b c a. (b -> c) -> (a -> b) -> a -> c
.
([Vector a] -> [Vector b]) -> [Vector a] -> [Vector b]
f (forall a. Vector a -> [Vector a]
SVL.chunks forall b c a. (b -> c) -> (a -> b) -> a -> c
. Vector a -> Vector b
cont forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Storable a => [Vector a] -> Vector a
SVL.fromChunks) forall b c a. (b -> c) -> (a -> b) -> a -> c
.
forall a. Vector a -> [Vector a]
SVL.chunks
zip ::
(Arr.Arrow arrow) =>
arrow a b -> arrow a c -> arrow a (Zip.T b c)
zip :: forall (arrow :: * -> * -> *) a b c.
Arrow arrow =>
arrow a b -> arrow a c -> arrow a (T b c)
zip arrow a b
ab arrow a c
ac =
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall a b. a -> b -> T a b
Zip.Cons forall (a :: * -> * -> *) c d b.
Arrow a =>
(c -> d) -> a b c -> a b d
^<< arrow a b
ab forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& arrow a c
ac
instance (CutG.Transform a, CutG.Read b, Semigroup b) => Semigroup (T a b) where
<> :: T a b -> T a b -> T a b
(<>) = forall a b.
(Transform a, Read b) =>
(b -> b -> b) -> T a b -> T a b -> T a b
append forall a. Semigroup a => a -> a -> a
(<>)
instance (CutG.Transform a, CutG.Read b, Monoid b) => Monoid (T a b) where
mempty :: T a b
mempty = forall a b state.
(a -> state -> IO (b, state))
-> IO state -> (state -> IO ()) -> T a b
Cons
(\ a
_a () -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Monoid a => a
mempty, ()))
(forall (m :: * -> *) a. Monad m => a -> m a
return ())
(\() -> forall (m :: * -> *) a. Monad m => a -> m a
return ())
mappend :: T a b -> T a b -> T a b
mappend = forall a b.
(Transform a, Read b) =>
(b -> b -> b) -> T a b -> T a b -> T a b
append forall a. Monoid a => a -> a -> a
mappend
append ::
(CutG.Transform a, CutG.Read b) =>
(b -> b -> b) -> T a b -> T a b -> T a b
append :: forall a b.
(Transform a, Read b) =>
(b -> b -> b) -> T a b -> T a b -> T a b
append b -> b -> b
app
(Cons a -> state -> IO (b, state)
nextX IO state
createX state -> IO ()
deleteX)
(Cons a -> state -> IO (b, state)
nextY IO state
createY state -> IO ()
deleteY) = forall a b state.
(a -> state -> IO (b, state))
-> IO state -> (state -> IO ()) -> T a b
Cons
(\a
a Either state state
s ->
case Either state state
s of
Left state
s0 -> do
(b
b1,state
s1) <- a -> state -> IO (b, state)
nextX a
a state
s0
let lenA :: Int
lenA = forall sig. Read sig => sig -> Int
CutG.length a
a
lenB :: Int
lenB = forall sig. Read sig => sig -> Int
CutG.length b
b1
case forall a. Ord a => a -> a -> Ordering
compare Int
lenA Int
lenB of
Ordering
LT -> forall a. HasCallStack => [Char] -> a
error [Char]
"CausalIO.Process.mappend: output chunk is larger than input chunk"
Ordering
EQ -> forall (m :: * -> *) a. Monad m => a -> m a
return (b
b1, forall a b. a -> Either a b
Left state
s1)
Ordering
GT -> do
state -> IO ()
deleteX state
s1
(b
b2,state
s2) <- a -> state -> IO (b, state)
nextY (forall sig. Transform sig => Int -> sig -> sig
CutG.drop Int
lenB a
a) forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO state
createY
forall (m :: * -> *) a. Monad m => a -> m a
return (b -> b -> b
app b
b1 b
b2, forall a b. b -> Either a b
Right state
s2)
Right state
s0 -> do
(b
b1,state
s1) <- a -> state -> IO (b, state)
nextY a
a state
s0
forall (m :: * -> *) a. Monad m => a -> m a
return (b
b1, forall a b. b -> Either a b
Right state
s1))
(forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. a -> Either a b
Left IO state
createX)
(forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either state -> IO ()
deleteX state -> IO ()
deleteY)
data State a b =
forall state.
State
(a -> state -> IO (b, state))
(state -> IO ())
state
forceMaybe :: (Maybe a -> b) -> Maybe a -> b
forceMaybe :: forall a b. (Maybe a -> b) -> Maybe a -> b
forceMaybe Maybe a -> b
f Maybe a
ma =
case Maybe a
ma of
Maybe a
Nothing -> Maybe a -> b
f forall a. Maybe a
Nothing
Just a
a -> Maybe a -> b
f forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just a
a
continue ::
(CutG.Transform a, SigG.Transform sig b) =>
T a (sig b) -> (b -> T a (sig b)) -> T a (sig b)
continue :: forall a (sig :: * -> *) b.
(Transform a, Transform sig b) =>
T a (sig b) -> (b -> T a (sig b)) -> T a (sig b)
continue (Cons a -> state -> IO (sig b, state)
nextX IO state
createX state -> IO ()
deleteX) b -> T a (sig b)
procY = forall a b state.
(a -> state -> IO (b, state))
-> IO state -> (state -> IO ()) -> T a b
Cons
(\a
a Either (Maybe b, state) (State a (sig b))
s ->
case Either (Maybe b, state) (State a (sig b))
s of
Left (Maybe b
lastB0, state
s0) -> do
(sig b
b1,state
s1) <- a -> state -> IO (sig b, state)
nextX a
a state
s0
let lenA :: Int
lenA = forall sig. Read sig => sig -> Int
CutG.length a
a
lenB :: Int
lenB = forall sig. Read sig => sig -> Int
CutG.length sig b
b1
lastB1 :: Maybe b
lastB1 =
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
mplus (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$ forall (sig :: * -> *) y.
(Transform0 sig, Storage (sig y)) =>
sig y -> Maybe (sig y, y)
SigG.viewR sig b
b1) Maybe b
lastB0
cont :: a -> (sig b, Either (a, state) b)
cont a
lastB = (sig b
b1, forall a b. a -> Either a b
Left (a
lastB,state
s1))
case forall a. Ord a => a -> a -> Ordering
compare Int
lenA Int
lenB of
Ordering
LT -> forall a. HasCallStack => [Char] -> a
error [Char]
"CausalIO.Process.continue: output chunk is larger than input chunk"
Ordering
EQ -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. (Maybe a -> b) -> Maybe a -> b
forceMaybe forall {a} {b}. a -> (sig b, Either (a, state) b)
cont Maybe b
lastB1
Ordering
GT ->
case Maybe b
lastB1 of
Maybe b
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Monoid a => a
mempty, forall a b. a -> Either a b
Left (Maybe b
lastB1,state
s1))
Just b
lastB ->
case b -> T a (sig b)
procY b
lastB of
Cons a -> state -> IO (sig b, state)
nextY IO state
createY state -> IO ()
deleteY -> do
state -> IO ()
deleteX state
s1
(sig b
b2,state
s2) <- a -> state -> IO (sig b, state)
nextY (forall sig. Transform sig => Int -> sig -> sig
CutG.drop Int
lenB a
a) forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO state
createY
forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Monoid a => a -> a -> a
mappend sig b
b1 sig b
b2, forall a b. b -> Either a b
Right (forall a b state.
(a -> state -> IO (b, state))
-> (state -> IO ()) -> state -> State a b
State a -> state -> IO (sig b, state)
nextY state -> IO ()
deleteY state
s2))
Right (State a -> state -> IO (sig b, state)
nextY state -> IO ()
deleteY state
s0) -> do
(sig b
b1,state
s1) <- a -> state -> IO (sig b, state)
nextY a
a state
s0
forall (m :: * -> *) a. Monad m => a -> m a
return (sig b
b1, forall a b. b -> Either a b
Right (forall a b state.
(a -> state -> IO (b, state))
-> (state -> IO ()) -> state -> State a b
State a -> state -> IO (sig b, state)
nextY state -> IO ()
deleteY state
s1)))
(do
state
sa <- IO state
createX
forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. a -> Either a b
Left (forall a. Maybe a
Nothing, state
sa)))
(\Either (Maybe b, state) (State a (sig b))
s ->
case Either (Maybe b, state) (State a (sig b))
s of
Left (Maybe b
_lastB,state
s0) -> state -> IO ()
deleteX state
s0
Right (State a -> state -> IO (sig b, state)
_ state -> IO ()
deleteY state
s0) -> state -> IO ()
deleteY state
s0)
continueChunk ::
(CutG.Transform a, CutG.Transform b) =>
T a b -> (b -> T a b) -> T a b
continueChunk :: forall a b.
(Transform a, Transform b) =>
T a b -> (b -> T a b) -> T a b
continueChunk (Cons a -> state -> IO (b, state)
nextX IO state
createX state -> IO ()
deleteX) b -> T a b
procY = forall a b state.
(a -> state -> IO (b, state))
-> IO state -> (state -> IO ()) -> T a b
Cons
(\a
a Either (b, state) (State a b)
s ->
case Either (b, state) (State a b)
s of
Left (b
lastB0, state
s0) -> do
(b
b1,state
s1) <- a -> state -> IO (b, state)
nextX a
a state
s0
let lenA :: Int
lenA = forall sig. Read sig => sig -> Int
CutG.length a
a
lenB :: Int
lenB = forall sig. Read sig => sig -> Int
CutG.length b
b1
cont :: a -> (b, Either (a, state) b)
cont a
lastB = (b
b1, forall a b. a -> Either a b
Left (a
lastB,state
s1))
case forall a. Ord a => a -> a -> Ordering
compare Int
lenA Int
lenB of
Ordering
LT -> forall a. HasCallStack => [Char] -> a
error [Char]
"CausalIO.Process.continueChunk: output chunk is larger than input chunk"
Ordering
EQ ->
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ if Int
lenBforall a. Eq a => a -> a -> Bool
==Int
0 then forall {a} {b}. a -> (b, Either (a, state) b)
cont b
lastB0 else forall {a} {b}. a -> (b, Either (a, state) b)
cont b
b1
Ordering
GT ->
if Int
lenBforall a. Eq a => a -> a -> Bool
==Int
0
then forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall {a} {b}. a -> (b, Either (a, state) b)
cont b
lastB0
else
case b -> T a b
procY b
b1 of
Cons a -> state -> IO (b, state)
nextY IO state
createY state -> IO ()
deleteY -> do
state -> IO ()
deleteX state
s1
(b
b2,state
s2) <- a -> state -> IO (b, state)
nextY (forall sig. Transform sig => Int -> sig -> sig
CutG.drop Int
lenB a
a) forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO state
createY
forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Monoid a => a -> a -> a
mappend b
b1 b
b2, forall a b. b -> Either a b
Right (forall a b state.
(a -> state -> IO (b, state))
-> (state -> IO ()) -> state -> State a b
State a -> state -> IO (b, state)
nextY state -> IO ()
deleteY state
s2))
Right (State a -> state -> IO (b, state)
nextY state -> IO ()
deleteY state
s0) -> do
(b
b1,state
s1) <- a -> state -> IO (b, state)
nextY a
a state
s0
forall (m :: * -> *) a. Monad m => a -> m a
return (b
b1, forall a b. b -> Either a b
Right (forall a b state.
(a -> state -> IO (b, state))
-> (state -> IO ()) -> state -> State a b
State a -> state -> IO (b, state)
nextY state -> IO ()
deleteY state
s1)))
(do
state
sa <- IO state
createX
forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. a -> Either a b
Left (forall a. Monoid a => a
mempty, state
sa)))
(\Either (b, state) (State a b)
s ->
case Either (b, state) (State a b)
s of
Left (b
_lastB,state
s0) -> state -> IO ()
deleteX state
s0
Right (State a -> state -> IO (b, state)
_ state -> IO ()
deleteY state
s0) -> state -> IO ()
deleteY state
s0)