{-# LANGUAGE Arrows,LambdaCase #-}
module Goal.Core.Circuit
(
Circuit (Circuit, runCircuit)
, accumulateFunction
, accumulateCircuit
, streamCircuit
, iterateCircuit
, loopCircuit
, loopAccumulator
, arrM
, Chain
, chain
, chainCircuit
, streamChain
, iterateChain
, skipChain
, skipChain0
, iterateM
, iterateM'
) where
import Control.Arrow
import qualified Control.Category as C
newtype Circuit m a b = Circuit
{ Circuit m a b -> a -> m (b, Circuit m a b)
runCircuit :: a -> m (b, Circuit m a b) }
accumulateFunction :: Monad m => acc -> (a -> acc -> m (b,acc)) -> Circuit m a b
{-# INLINE accumulateFunction #-}
accumulateFunction :: acc -> (a -> acc -> m (b, acc)) -> Circuit m a b
accumulateFunction acc
acc a -> acc -> m (b, acc)
f = (a -> m (b, Circuit m a b)) -> Circuit m a b
forall (m :: Type -> Type) a b.
(a -> m (b, Circuit m a b)) -> Circuit m a b
Circuit ((a -> m (b, Circuit m a b)) -> Circuit m a b)
-> (a -> m (b, Circuit m a b)) -> Circuit m a b
forall a b. (a -> b) -> a -> b
$ \a
a -> do
(b
b,acc
acc') <- a -> acc -> m (b, acc)
f a
a acc
acc
(b, Circuit m a b) -> m (b, Circuit m a b)
forall (m :: Type -> Type) a. Monad m => a -> m a
return (b
b,acc -> (a -> acc -> m (b, acc)) -> Circuit m a b
forall (m :: Type -> Type) acc a b.
Monad m =>
acc -> (a -> acc -> m (b, acc)) -> Circuit m a b
accumulateFunction acc
acc' a -> acc -> m (b, acc)
f)
accumulateCircuit :: Monad m => acc -> Circuit m (a,acc) (b,acc) -> Circuit m a b
{-# INLINE accumulateCircuit #-}
accumulateCircuit :: acc -> Circuit m (a, acc) (b, acc) -> Circuit m a b
accumulateCircuit acc
acc0 Circuit m (a, acc) (b, acc)
mly0 = (acc, Circuit m (a, acc) (b, acc))
-> (a
-> (acc, Circuit m (a, acc) (b, acc))
-> m (b, (acc, Circuit m (a, acc) (b, acc))))
-> Circuit m a b
forall (m :: Type -> Type) acc a b.
Monad m =>
acc -> (a -> acc -> m (b, acc)) -> Circuit m a b
accumulateFunction (acc
acc0,Circuit m (a, acc) (b, acc)
mly0) ((a
-> (acc, Circuit m (a, acc) (b, acc))
-> m (b, (acc, Circuit m (a, acc) (b, acc))))
-> Circuit m a b)
-> (a
-> (acc, Circuit m (a, acc) (b, acc))
-> m (b, (acc, Circuit m (a, acc) (b, acc))))
-> Circuit m a b
forall a b. (a -> b) -> a -> b
$ \a
a (acc
acc,Circuit (a, acc) -> m ((b, acc), Circuit m (a, acc) (b, acc))
crcf) -> do
((b
b,acc
acc'),Circuit m (a, acc) (b, acc)
mly') <- (a, acc) -> m ((b, acc), Circuit m (a, acc) (b, acc))
crcf (a
a,acc
acc)
(b, (acc, Circuit m (a, acc) (b, acc)))
-> m (b, (acc, Circuit m (a, acc) (b, acc)))
forall (m :: Type -> Type) a. Monad m => a -> m a
return (b
b,(acc
acc',Circuit m (a, acc) (b, acc)
mly'))
loopCircuit :: Monad m => acc -> Circuit m (a,acc) (b,acc) -> Circuit m a (b,acc)
{-# INLINE loopCircuit #-}
loopCircuit :: acc -> Circuit m (a, acc) (b, acc) -> Circuit m a (b, acc)
loopCircuit acc
acc0 Circuit m (a, acc) (b, acc)
mly0 = (acc, Circuit m (a, acc) (b, acc))
-> (a
-> (acc, Circuit m (a, acc) (b, acc))
-> m ((b, acc), (acc, Circuit m (a, acc) (b, acc))))
-> Circuit m a (b, acc)
forall (m :: Type -> Type) acc a b.
Monad m =>
acc -> (a -> acc -> m (b, acc)) -> Circuit m a b
accumulateFunction (acc
acc0,Circuit m (a, acc) (b, acc)
mly0) ((a
-> (acc, Circuit m (a, acc) (b, acc))
-> m ((b, acc), (acc, Circuit m (a, acc) (b, acc))))
-> Circuit m a (b, acc))
-> (a
-> (acc, Circuit m (a, acc) (b, acc))
-> m ((b, acc), (acc, Circuit m (a, acc) (b, acc))))
-> Circuit m a (b, acc)
forall a b. (a -> b) -> a -> b
$ \a
a (acc
acc,Circuit (a, acc) -> m ((b, acc), Circuit m (a, acc) (b, acc))
crcf) -> do
((b
b,acc
acc'),Circuit m (a, acc) (b, acc)
mly') <- (a, acc) -> m ((b, acc), Circuit m (a, acc) (b, acc))
crcf (a
a,acc
acc)
((b, acc), (acc, Circuit m (a, acc) (b, acc)))
-> m ((b, acc), (acc, Circuit m (a, acc) (b, acc)))
forall (m :: Type -> Type) a. Monad m => a -> m a
return ((b
b,acc
acc'),(acc
acc',Circuit m (a, acc) (b, acc)
mly'))
loopAccumulator :: Monad m => acc -> Circuit m (a,acc) acc -> Circuit m a acc
{-# INLINE loopAccumulator #-}
loopAccumulator :: acc -> Circuit m (a, acc) acc -> Circuit m a acc
loopAccumulator acc
acc0 Circuit m (a, acc) acc
mly0 = (acc, Circuit m (a, acc) acc)
-> (a
-> (acc, Circuit m (a, acc) acc)
-> m (acc, (acc, Circuit m (a, acc) acc)))
-> Circuit m a acc
forall (m :: Type -> Type) acc a b.
Monad m =>
acc -> (a -> acc -> m (b, acc)) -> Circuit m a b
accumulateFunction (acc
acc0,Circuit m (a, acc) acc
mly0) ((a
-> (acc, Circuit m (a, acc) acc)
-> m (acc, (acc, Circuit m (a, acc) acc)))
-> Circuit m a acc)
-> (a
-> (acc, Circuit m (a, acc) acc)
-> m (acc, (acc, Circuit m (a, acc) acc)))
-> Circuit m a acc
forall a b. (a -> b) -> a -> b
$ \a
a (acc
acc,Circuit (a, acc) -> m (acc, Circuit m (a, acc) acc)
crcf) -> do
(acc
acc',Circuit m (a, acc) acc
mly') <- (a, acc) -> m (acc, Circuit m (a, acc) acc)
crcf (a
a,acc
acc)
(acc, (acc, Circuit m (a, acc) acc))
-> m (acc, (acc, Circuit m (a, acc) acc))
forall (m :: Type -> Type) a. Monad m => a -> m a
return (acc
acc',(acc
acc',Circuit m (a, acc) acc
mly'))
streamCircuit :: Monad m => Circuit m a b -> [a] -> m [b]
{-# INLINE streamCircuit #-}
streamCircuit :: Circuit m a b -> [a] -> m [b]
streamCircuit Circuit m a b
_ [] = [b] -> m [b]
forall (m :: Type -> Type) a. Monad m => a -> m a
return []
streamCircuit (Circuit a -> m (b, Circuit m a b)
mf) (a
a:[a]
as) = do
(b
b,Circuit m a b
crc') <- a -> m (b, Circuit m a b)
mf a
a
(b
b b -> [b] -> [b]
forall a. a -> [a] -> [a]
:) ([b] -> [b]) -> m [b] -> m [b]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Circuit m a b -> [a] -> m [b]
forall (m :: Type -> Type) a b.
Monad m =>
Circuit m a b -> [a] -> m [b]
streamCircuit Circuit m a b
crc' [a]
as
iterateCircuit :: Monad m => Circuit m a b -> [a] -> m b
{-# INLINE iterateCircuit #-}
iterateCircuit :: Circuit m a b -> [a] -> m b
iterateCircuit Circuit m a b
_ [] = [Char] -> m b
forall a. HasCallStack => [Char] -> a
error [Char]
"Empty list fed to iterateCircuit"
iterateCircuit (Circuit a -> m (b, Circuit m a b)
mf) [a
a] = (b, Circuit m a b) -> b
forall a b. (a, b) -> a
fst ((b, Circuit m a b) -> b) -> m (b, Circuit m a b) -> m b
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> m (b, Circuit m a b)
mf a
a
iterateCircuit (Circuit a -> m (b, Circuit m a b)
mf) (a
a:[a]
as) = do
(b
_,Circuit m a b
crc') <- a -> m (b, Circuit m a b)
mf a
a
Circuit m a b -> [a] -> m b
forall (m :: Type -> Type) a b.
Monad m =>
Circuit m a b -> [a] -> m b
iterateCircuit Circuit m a b
crc' [a]
as
arrM :: Monad m => (a -> m b) -> Circuit m a b
{-# INLINE arrM #-}
arrM :: (a -> m b) -> Circuit m a b
arrM a -> m b
mf = (a -> m (b, Circuit m a b)) -> Circuit m a b
forall (m :: Type -> Type) a b.
(a -> m (b, Circuit m a b)) -> Circuit m a b
Circuit ((a -> m (b, Circuit m a b)) -> Circuit m a b)
-> (a -> m (b, Circuit m a b)) -> Circuit m a b
forall a b. (a -> b) -> a -> b
$ \a
a -> do
b
b <- a -> m b
mf a
a
(b, Circuit m a b) -> m (b, Circuit m a b)
forall (m :: Type -> Type) a. Monad m => a -> m a
return (b
b, (a -> m b) -> Circuit m a b
forall (m :: Type -> Type) a b.
Monad m =>
(a -> m b) -> Circuit m a b
arrM a -> m b
mf)
type Chain m x = Circuit m () x
chain
:: Monad m
=> x
-> (x -> m x)
-> Chain m x
{-# INLINE chain #-}
chain :: x -> (x -> m x) -> Chain m x
chain x
x0 x -> m x
mf = x -> (() -> x -> m (x, x)) -> Chain m x
forall (m :: Type -> Type) acc a b.
Monad m =>
acc -> (a -> acc -> m (b, acc)) -> Circuit m a b
accumulateFunction x
x0 ((() -> x -> m (x, x)) -> Chain m x)
-> (() -> x -> m (x, x)) -> Chain m x
forall a b. (a -> b) -> a -> b
$ \() x
x -> do
x
x' <- x -> m x
mf x
x
(x, x) -> m (x, x)
forall (m :: Type -> Type) a. Monad m => a -> m a
return (x
x,x
x')
chainCircuit
:: Monad m
=> x
-> Circuit m x x
-> Chain m x
{-# INLINE chainCircuit #-}
chainCircuit :: x -> Circuit m x x -> Chain m x
chainCircuit x
x0 Circuit m x x
crc = x -> Circuit m ((), x) (x, x) -> Chain m x
forall (m :: Type -> Type) acc a b.
Monad m =>
acc -> Circuit m (a, acc) (b, acc) -> Circuit m a b
accumulateCircuit x
x0 (Circuit m ((), x) (x, x) -> Chain m x)
-> Circuit m ((), x) (x, x) -> Chain m x
forall a b. (a -> b) -> a -> b
$ proc ((),x
x) -> do
x
x' <- Circuit m x x
crc -< x
x
Circuit m (x, x) (x, x)
forall (a :: Type -> Type -> Type) b. Arrow a => a b b
returnA -< (x
x,x
x')
streamChain :: Monad m => Int -> Chain m x -> m [x]
{-# INLINE streamChain #-}
streamChain :: Int -> Chain m x -> m [x]
streamChain Int
n Chain m x
chn = Chain m x -> [()] -> m [x]
forall (m :: Type -> Type) a b.
Monad m =>
Circuit m a b -> [a] -> m [b]
streamCircuit Chain m x
chn ([()] -> m [x]) -> [()] -> m [x]
forall a b. (a -> b) -> a -> b
$ Int -> () -> [()]
forall a. Int -> a -> [a]
replicate (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) ()
iterateChain :: Monad m => Int -> Chain m x -> m x
{-# INLINE iterateChain #-}
iterateChain :: Int -> Chain m x -> m x
iterateChain Int
0 (Circuit () -> m (x, Chain m x)
mf) = (x, Chain m x) -> x
forall a b. (a, b) -> a
fst ((x, Chain m x) -> x) -> m (x, Chain m x) -> m x
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> () -> m (x, Chain m x)
mf ()
iterateChain Int
k (Circuit () -> m (x, Chain m x)
mf) = () -> m (x, Chain m x)
mf () m (x, Chain m x) -> ((x, Chain m x) -> m x) -> m x
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= Int -> Chain m x -> m x
forall (m :: Type -> Type) x. Monad m => Int -> Chain m x -> m x
iterateChain (Int
kInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) (Chain m x -> m x)
-> ((x, Chain m x) -> Chain m x) -> (x, Chain m x) -> m x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (x, Chain m x) -> Chain m x
forall a b. (a, b) -> b
snd
skipChain :: Monad m => Int -> Chain m x -> Chain m x
{-# INLINE skipChain #-}
skipChain :: Int -> Chain m x -> Chain m x
skipChain Int
n (Circuit () -> m (x, Chain m x)
mf) = (() -> m (x, Chain m x)) -> Chain m x
forall (m :: Type -> Type) a b.
(a -> m (b, Circuit m a b)) -> Circuit m a b
Circuit ((() -> m (x, Chain m x)) -> Chain m x)
-> (() -> m (x, Chain m x)) -> Chain m x
forall a b. (a -> b) -> a -> b
$ \() -> do
(x
x',Chain m x
crc') <- () -> m (x, Chain m x)
mf ()
(x, Chain m x) -> m (x, Chain m x)
forall (m :: Type -> Type) a. Monad m => a -> m a
return (x
x', Int -> Chain m x -> Chain m x
forall (m :: Type -> Type) x.
Monad m =>
Int -> Chain m x -> Chain m x
skipChain0 Int
n Chain m x
crc')
skipChain0 :: Monad m => Int -> Chain m x -> Chain m x
{-# INLINE skipChain0 #-}
skipChain0 :: Int -> Chain m x -> Chain m x
skipChain0 Int
n Chain m x
crc = (() -> m (x, Chain m x)) -> Chain m x
forall (m :: Type -> Type) a b.
(a -> m (b, Circuit m a b)) -> Circuit m a b
Circuit ((() -> m (x, Chain m x)) -> Chain m x)
-> (() -> m (x, Chain m x)) -> Chain m x
forall a b. (a -> b) -> a -> b
$ \() -> do
(Circuit () -> m (x, Chain m x)
mf) <- Int -> (Chain m x -> m (Chain m x)) -> Chain m x -> m (Chain m x)
forall (m :: Type -> Type) x.
Monad m =>
Int -> (x -> m x) -> x -> m x
iterateM' Int
n Chain m x -> m (Chain m x)
forall (f :: Type -> Type) a.
Functor f =>
Circuit f () a -> f (Circuit f () a)
iterator Chain m x
crc
(x
x',Chain m x
crc') <- () -> m (x, Chain m x)
mf ()
(x, Chain m x) -> m (x, Chain m x)
forall (m :: Type -> Type) a. Monad m => a -> m a
return (x
x', Int -> Chain m x -> Chain m x
forall (m :: Type -> Type) x.
Monad m =>
Int -> Chain m x -> Chain m x
skipChain0 Int
n Chain m x
crc')
where iterator :: Circuit f () a -> f (Circuit f () a)
iterator (Circuit () -> f (a, Circuit f () a)
mf') = (a, Circuit f () a) -> Circuit f () a
forall a b. (a, b) -> b
snd ((a, Circuit f () a) -> Circuit f () a)
-> f (a, Circuit f () a) -> f (Circuit f () a)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> () -> f (a, Circuit f () a)
mf' ()
iterateM :: Monad m => Int -> (x -> m x) -> x -> m [x]
{-# INLINE iterateM #-}
iterateM :: Int -> (x -> m x) -> x -> m [x]
iterateM Int
n x -> m x
mf x
x0 = Int -> Chain m x -> m [x]
forall (m :: Type -> Type) x. Monad m => Int -> Chain m x -> m [x]
streamChain Int
n (Chain m x -> m [x]) -> Chain m x -> m [x]
forall a b. (a -> b) -> a -> b
$ x -> (x -> m x) -> Chain m x
forall (m :: Type -> Type) x.
Monad m =>
x -> (x -> m x) -> Chain m x
chain x
x0 x -> m x
mf
iterateM' :: Monad m => Int -> (x -> m x) -> x -> m x
{-# INLINE iterateM' #-}
iterateM' :: Int -> (x -> m x) -> x -> m x
iterateM' Int
n x -> m x
mf x
x0 = Int -> Chain m x -> m x
forall (m :: Type -> Type) x. Monad m => Int -> Chain m x -> m x
iterateChain Int
n (Chain m x -> m x) -> Chain m x -> m x
forall a b. (a -> b) -> a -> b
$ x -> (x -> m x) -> Chain m x
forall (m :: Type -> Type) x.
Monad m =>
x -> (x -> m x) -> Chain m x
chain x
x0 x -> m x
mf
instance Monad m => C.Category (Circuit m) where
{-# INLINE id #-}
id :: Circuit m a a
id = (a -> m (a, Circuit m a a)) -> Circuit m a a
forall (m :: Type -> Type) a b.
(a -> m (b, Circuit m a b)) -> Circuit m a b
Circuit ((a -> m (a, Circuit m a a)) -> Circuit m a a)
-> (a -> m (a, Circuit m a a)) -> Circuit m a a
forall a b. (a -> b) -> a -> b
$ \a
a -> (a, Circuit m a a) -> m (a, Circuit m a a)
forall (m :: Type -> Type) a. Monad m => a -> m a
return (a
a,Circuit m a a
forall k (cat :: k -> k -> Type) (a :: k). Category cat => cat a a
C.id)
{-# INLINE (.) #-}
. :: Circuit m b c -> Circuit m a b -> Circuit m a c
(.) = Circuit m b c -> Circuit m a b -> Circuit m a c
forall (m :: Type -> Type) a b a.
Monad m =>
Circuit m a b -> Circuit m a a -> Circuit m a b
dot
where dot :: Circuit m a b -> Circuit m a a -> Circuit m a b
dot (Circuit a -> m (b, Circuit m a b)
crc1) (Circuit a -> m (a, Circuit m a a)
crc2) = (a -> m (b, Circuit m a b)) -> Circuit m a b
forall (m :: Type -> Type) a b.
(a -> m (b, Circuit m a b)) -> Circuit m a b
Circuit ((a -> m (b, Circuit m a b)) -> Circuit m a b)
-> (a -> m (b, Circuit m a b)) -> Circuit m a b
forall a b. (a -> b) -> a -> b
$ \a
a -> do
(a
b, Circuit m a a
crcA2') <- a -> m (a, Circuit m a a)
crc2 a
a
(b
c, Circuit m a b
crcA1') <- a -> m (b, Circuit m a b)
crc1 a
b
(b, Circuit m a b) -> m (b, Circuit m a b)
forall (m :: Type -> Type) a. Monad m => a -> m a
return (b
c, Circuit m a b
crcA1' Circuit m a b -> Circuit m a a -> Circuit m a b
`dot` Circuit m a a
crcA2')
instance Monad m => Arrow (Circuit m) where
{-# INLINE arr #-}
arr :: (b -> c) -> Circuit m b c
arr b -> c
f = (b -> m (c, Circuit m b c)) -> Circuit m b c
forall (m :: Type -> Type) a b.
(a -> m (b, Circuit m a b)) -> Circuit m a b
Circuit ((b -> m (c, Circuit m b c)) -> Circuit m b c)
-> (b -> m (c, Circuit m b c)) -> Circuit m b c
forall a b. (a -> b) -> a -> b
$ \b
a -> (c, Circuit m b c) -> m (c, Circuit m b c)
forall (m :: Type -> Type) a. Monad m => a -> m a
return (b -> c
f b
a, (b -> c) -> Circuit m b c
forall (a :: Type -> Type -> Type) b c.
Arrow a =>
(b -> c) -> a b c
arr b -> c
f)
{-# INLINE first #-}
first :: Circuit m b c -> Circuit m (b, d) (c, d)
first (Circuit b -> m (c, Circuit m b c)
crcf) = ((b, d) -> m ((c, d), Circuit m (b, d) (c, d)))
-> Circuit m (b, d) (c, d)
forall (m :: Type -> Type) a b.
(a -> m (b, Circuit m a b)) -> Circuit m a b
Circuit (((b, d) -> m ((c, d), Circuit m (b, d) (c, d)))
-> Circuit m (b, d) (c, d))
-> ((b, d) -> m ((c, d), Circuit m (b, d) (c, d)))
-> Circuit m (b, d) (c, d)
forall a b. (a -> b) -> a -> b
$ \(b
a,d
c) -> do
(c
b, Circuit m b c
crcA') <- b -> m (c, Circuit m b c)
crcf b
a
((c, d), Circuit m (b, d) (c, d))
-> m ((c, d), Circuit m (b, d) (c, d))
forall (m :: Type -> Type) a. Monad m => a -> m a
return ((c
b,d
c), Circuit m b c -> Circuit m (b, d) (c, d)
forall (a :: Type -> Type -> Type) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first Circuit m b c
crcA')
instance Monad m => ArrowChoice (Circuit m) where
{-# INLINE left #-}
left :: Circuit m b c -> Circuit m (Either b d) (Either c d)
left crcA :: Circuit m b c
crcA@(Circuit b -> m (c, Circuit m b c)
crcf) = (Either b d -> m (Either c d, Circuit m (Either b d) (Either c d)))
-> Circuit m (Either b d) (Either c d)
forall (m :: Type -> Type) a b.
(a -> m (b, Circuit m a b)) -> Circuit m a b
Circuit ((Either b d
-> m (Either c d, Circuit m (Either b d) (Either c d)))
-> Circuit m (Either b d) (Either c d))
-> (Either b d
-> m (Either c d, Circuit m (Either b d) (Either c d)))
-> Circuit m (Either b d) (Either c d)
forall a b. (a -> b) -> a -> b
$
\case
Left b
a -> do
(c
b,Circuit m b c
crcA') <- b -> m (c, Circuit m b c)
crcf b
a
(Either c d, Circuit m (Either b d) (Either c d))
-> m (Either c d, Circuit m (Either b d) (Either c d))
forall (m :: Type -> Type) a. Monad m => a -> m a
return (c -> Either c d
forall a b. a -> Either a b
Left c
b,Circuit m b c -> Circuit m (Either b d) (Either c d)
forall (a :: Type -> Type -> Type) b c d.
ArrowChoice a =>
a b c -> a (Either b d) (Either c d)
left Circuit m b c
crcA')
Right d
c -> (Either c d, Circuit m (Either b d) (Either c d))
-> m (Either c d, Circuit m (Either b d) (Either c d))
forall (m :: Type -> Type) a. Monad m => a -> m a
return (d -> Either c d
forall a b. b -> Either a b
Right d
c,Circuit m b c -> Circuit m (Either b d) (Either c d)
forall (a :: Type -> Type -> Type) b c d.
ArrowChoice a =>
a b c -> a (Either b d) (Either c d)
left Circuit m b c
crcA)