{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RecordWildCards #-}
module LiveCoding.Cell.Resample where
import Control.Arrow
import Data.Maybe
import GHC.TypeNats
import Data.Vector.Sized (Vector, fromList, toList)
import LiveCoding.Cell
import LiveCoding.Cell.Monad
resample :: (Monad m, KnownNat n) => Cell m a b -> Cell m (Vector n a) (Vector n b)
resample :: forall (m :: * -> *) (n :: Nat) a b.
(Monad m, KnownNat n) =>
Cell m a b -> Cell m (Vector n a) (Vector n b)
resample Cell m a b
cell = forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr forall (n :: Nat) a. Vector n a -> [a]
toList forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> forall (m :: * -> *) a b. Monad m => Cell m a b -> Cell m [a] [b]
resampleList Cell m a b
cell forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr (forall (n :: Nat) a. KnownNat n => [a] -> Maybe (Vector n a)
fromList forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> forall a. HasCallStack => Maybe a -> a
fromJust)
resampleList :: Monad m => Cell m a b -> Cell m [a] [b]
resampleList :: forall (m :: * -> *) a b. Monad m => Cell m a b -> Cell m [a] [b]
resampleList = forall (m1 :: * -> *) (m2 :: * -> *) a1 b1 a2 b2.
(Monad m1, Monad m2) =>
(forall s. (s -> a1 -> m1 (b1, s)) -> s -> a2 -> m2 (b2, s))
-> Cell m1 a1 b1 -> Cell m2 a2 b2
hoistCellKleisli forall {m :: * -> *} {t} {t} {a}.
Monad m =>
(t -> t -> m (a, t)) -> t -> [t] -> m ([a], t)
morph
where
morph :: (t -> t -> m (a, t)) -> t -> [t] -> m ([a], t)
morph t -> t -> m (a, t)
_ t
s [] = forall (m :: * -> *) a. Monad m => a -> m a
return ([], t
s)
morph t -> t -> m (a, t)
singleStep t
s (t
a : [t]
as) = do
(!a
b, t
s') <- t -> t -> m (a, t)
singleStep t
s t
a
(![a]
bs, t
s'') <- (t -> t -> m (a, t)) -> t -> [t] -> m ([a], t)
morph t -> t -> m (a, t)
singleStep t
s' [t]
as
forall (m :: * -> *) a. Monad m => a -> m a
return (a
b forall a. a -> [a] -> [a]
: [a]
bs, t
s'')
resampleMaybe :: Monad m => Cell m a b -> Cell m (Maybe a) (Maybe b)
resampleMaybe :: forall (m :: * -> *) a b.
Monad m =>
Cell m a b -> Cell m (Maybe a) (Maybe b)
resampleMaybe Cell m a b
cell = forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr forall a. Maybe a -> [a]
maybeToList forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> forall (m :: * -> *) a b. Monad m => Cell m a b -> Cell m [a] [b]
resampleList Cell m a b
cell forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr forall a. [a] -> Maybe a
listToMaybe
resampleListPar :: Monad m => Cell m a b -> Cell m [a] [b]
resampleListPar :: forall (m :: * -> *) a b. Monad m => Cell m a b -> Cell m [a] [b]
resampleListPar (Cell s
initial s -> a -> m (b, s)
step) = Cell {[s] -> [a] -> m ([b], [s])
forall a. [a]
cellStep :: [s] -> [a] -> m ([b], [s])
cellState :: [s]
cellStep :: [s] -> [a] -> m ([b], [s])
cellState :: forall a. [a]
..}
where
cellState :: [a]
cellState = []
cellStep :: [s] -> [a] -> m ([b], [s])
cellStep [s]
s [a]
xs = forall a b. [(a, b)] -> ([a], [b])
unzip forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry s -> a -> m (b, s)
step) (forall a b. [a] -> [b] -> [(a, b)]
zip [s]
s' [a]
xs)
where
s' :: [s]
s' = [s]
s forall a. [a] -> [a] -> [a]
++ forall a. Int -> a -> [a]
replicate (forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
xs forall a. Num a => a -> a -> a
- forall (t :: * -> *) a. Foldable t => t a -> Int
length [s]
s) s
initial
resampleListPar (ArrM a -> m b
f) = forall (m :: * -> *) a b. (a -> m b) -> Cell m a b
ArrM (forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse a -> m b
f)