{-# language RankNTypes #-}
{-# language DeriveFunctor #-}
module Data.SRTree.Recursion where

import Control.Monad ( (>=>) )

data ListF a b = NilF | ConsF a b deriving forall a b. a -> ListF a b -> ListF a a
forall a b. (a -> b) -> ListF a a -> ListF a b
forall a a b. a -> ListF a b -> ListF a a
forall a a b. (a -> b) -> ListF a a -> ListF a b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> ListF a b -> ListF a a
$c<$ :: forall a a b. a -> ListF a b -> ListF a a
fmap :: forall a b. (a -> b) -> ListF a a -> ListF a b
$cfmap :: forall a a b. (a -> b) -> ListF a a -> ListF a b
Functor
data NatF a = ZeroF | SuccF a deriving forall a b. a -> NatF b -> NatF a
forall a b. (a -> b) -> NatF a -> NatF b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> NatF b -> NatF a
$c<$ :: forall a b. a -> NatF b -> NatF a
fmap :: forall a b. (a -> b) -> NatF a -> NatF b
$cfmap :: forall a b. (a -> b) -> NatF a -> NatF b
Functor
data StreamF a b = StreamF a b deriving forall a b. a -> StreamF a b -> StreamF a a
forall a b. (a -> b) -> StreamF a a -> StreamF a b
forall a a b. a -> StreamF a b -> StreamF a a
forall a a b. (a -> b) -> StreamF a a -> StreamF a b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> StreamF a b -> StreamF a a
$c<$ :: forall a a b. a -> StreamF a b -> StreamF a a
fmap :: forall a b. (a -> b) -> StreamF a a -> StreamF a b
$cfmap :: forall a a b. (a -> b) -> StreamF a a -> StreamF a b
Functor
data TreeF a b = LeafF | NodeF b a b deriving forall a b. a -> TreeF a b -> TreeF a a
forall a b. (a -> b) -> TreeF a a -> TreeF a b
forall a a b. a -> TreeF a b -> TreeF a a
forall a a b. (a -> b) -> TreeF a a -> TreeF a b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> TreeF a b -> TreeF a a
$c<$ :: forall a a b. a -> TreeF a b -> TreeF a a
fmap :: forall a b. (a -> b) -> TreeF a a -> TreeF a b
$cfmap :: forall a a b. (a -> b) -> TreeF a a -> TreeF a b
Functor

newtype Fix f = Fix {forall (f :: * -> *). Fix f -> f (Fix f)
unfix :: f (Fix f)}

type Algebra f a = f a -> a
type CoAlgebra f a = a -> f a

data Cofree f a = a :< f (Cofree f a)
data Free f a = Ret a | Op (f (Free f a))

extract :: Cofree f a -> a
extract :: forall (f :: * -> *) a. Cofree f a -> a
extract (a
x :< f (Cofree f a)
_) = a
x

unOp :: Free f a -> f (Free f a)
unOp :: forall (f :: * -> *) a. Free f a -> f (Free f a)
unOp (Op f (Free f a)
x) = f (Free f a)
x
unOp Free f a
_ = forall a. HasCallStack => [Char] -> a
error [Char]
"partial function unOp called on Ret"

cata :: Functor f => (f a -> a) -> Fix f -> a
cata :: forall (f :: * -> *) a. Functor f => (f a -> a) -> Fix f -> a
cata f a -> a
alg = f a -> a
alg forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) a. Functor f => (f a -> a) -> Fix f -> a
cata f a -> a
alg) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *). Fix f -> f (Fix f)
unfix

cataM :: (Functor f, Monad m) => (forall x . f (m x) -> m (f x)) -> (f a -> m a) -> Fix f -> m a
cataM :: forall (f :: * -> *) (m :: * -> *) a.
(Functor f, Monad m) =>
(forall x. f (m x) -> m (f x)) -> (f a -> m a) -> Fix f -> m a
cataM forall x. f (m x) -> m (f x)
seq f a -> m a
alg = forall (f :: * -> *) a. Functor f => (f a -> a) -> Fix f -> a
cata (forall x. f (m x) -> m (f x)
seq forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> f a -> m a
alg)

ana :: Functor f => (a -> f a) -> a -> Fix f
ana :: forall (f :: * -> *) a. Functor f => (a -> f a) -> a -> Fix f
ana a -> f a
coalg = forall (f :: * -> *). f (Fix f) -> Fix f
Fix forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) a. Functor f => (a -> f a) -> a -> Fix f
ana a -> f a
coalg) forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> f a
coalg

hylo :: Functor f => (f b -> b) -> (a -> f a) -> a -> b
hylo :: forall (f :: * -> *) b a.
Functor f =>
(f b -> b) -> (a -> f a) -> a -> b
hylo f b -> b
alg a -> f a
coalg = f b -> b
alg forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) a. Functor f => (f a -> a) -> Fix f -> a
cata f b -> b
alg forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Functor f => (a -> f a) -> a -> Fix f
ana a -> f a
coalg) forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> f a
coalg

para :: Functor f => (f (Fix f, a) -> a) -> Fix f -> a
para :: forall (f :: * -> *) a.
Functor f =>
(f (Fix f, a) -> a) -> Fix f -> a
para f (Fix f, a) -> a
alg = f (Fix f, a) -> a
alg forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. a -> a
id forall {t} {a} {b}. (t -> a) -> (t -> b) -> t -> (a, b)
&&& forall (f :: * -> *) a.
Functor f =>
(f (Fix f, a) -> a) -> Fix f -> a
para f (Fix f, a) -> a
alg) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *). Fix f -> f (Fix f)
unfix
  where (t -> a
f &&& :: (t -> a) -> (t -> b) -> t -> (a, b)
&&& t -> b
g) t
x = (t -> a
f t
x, t -> b
g t
x)

mutu :: Functor f => (f (a, b) -> a) -> (f (a, b) -> b) -> (Fix f -> a, Fix f -> b)
mutu :: forall (f :: * -> *) a b.
Functor f =>
(f (a, b) -> a) -> (f (a, b) -> b) -> (Fix f -> a, Fix f -> b)
mutu f (a, b) -> a
alg1 f (a, b) -> b
alg2 = (forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Functor f => (f a -> a) -> Fix f -> a
cata f (a, b) -> (a, b)
alg, forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Functor f => (f a -> a) -> Fix f -> a
cata f (a, b) -> (a, b)
alg)
  where alg :: f (a, b) -> (a, b)
alg f (a, b)
x = (f (a, b) -> a
alg1 f (a, b)
x, f (a, b) -> b
alg2 f (a, b)
x)

apo :: Functor f => (a -> f (Either (Fix f) a)) -> a -> Fix f
apo :: forall (f :: * -> *) a.
Functor f =>
(a -> f (Either (Fix f) a)) -> a -> Fix f
apo a -> f (Either (Fix f) a)
coalg = forall (f :: * -> *). f (Fix f) -> Fix f
Fix forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. a -> a
id forall {t} {t} {t}. (t -> t) -> (t -> t) -> Either t t -> t
||| forall (f :: * -> *) a.
Functor f =>
(a -> f (Either (Fix f) a)) -> a -> Fix f
apo a -> f (Either (Fix f) a)
coalg) forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> f (Either (Fix f) a)
coalg
  where 
      (t -> t
f ||| :: (t -> t) -> (t -> t) -> Either t t -> t
||| t -> t
g) (Left t
x)  = t -> t
f t
x
      (t -> t
f ||| t -> t
g) (Right t
y) = t -> t
g t
y

accu :: Functor f => (forall x. f x -> p -> f (x, p)) -> (f a -> p -> a) -> Fix f -> p -> a
accu :: forall (f :: * -> *) p a.
Functor f =>
(forall x. f x -> p -> f (x, p))
-> (f a -> p -> a) -> Fix f -> p -> a
accu forall x. f x -> p -> f (x, p)
st f a -> p -> a
alg (Fix f (Fix f)
t) p
p = f a -> p -> a
alg (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (forall (f :: * -> *) p a.
Functor f =>
(forall x. f x -> p -> f (x, p))
-> (f a -> p -> a) -> Fix f -> p -> a
accu forall x. f x -> p -> f (x, p)
st f a -> p -> a
alg)) (forall x. f x -> p -> f (x, p)
st f (Fix f)
t p
p)) p
p

histo :: Functor f => (f (Cofree f a) -> a) -> Fix f -> a
histo :: forall (f :: * -> *) a.
Functor f =>
(f (Cofree f a) -> a) -> Fix f -> a
histo f (Cofree f a) -> a
alg = forall (f :: * -> *) a. Cofree f a -> a
extract forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Functor f => (f a -> a) -> Fix f -> a
cata (\f (Cofree f a)
x -> f (Cofree f a) -> a
alg f (Cofree f a)
x forall (f :: * -> *) a. a -> f (Cofree f a) -> Cofree f a
:< f (Cofree f a)
x)

futu :: Functor f => (a -> f (Free f a)) -> a -> Fix f
futu :: forall (f :: * -> *) a.
Functor f =>
(a -> f (Free f a)) -> a -> Fix f
futu a -> f (Free f a)
coalg = forall (f :: * -> *) a. Functor f => (a -> f a) -> a -> Fix f
ana Free f a -> f (Free f a)
coalg' forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. a -> Free f a
Ret
  where
    coalg' :: Free f a -> f (Free f a)
coalg' (Ret a
a) = a -> f (Free f a)
coalg a
a
    coalg' (Op f (Free f a)
k) = f (Free f a)
k

chrono :: Functor f => (f (Cofree f b) -> b) -> (a -> f (Free f a)) -> a -> b
chrono :: forall (f :: * -> *) b a.
Functor f =>
(f (Cofree f b) -> b) -> (a -> f (Free f a)) -> a -> b
chrono f (Cofree f b) -> b
alg a -> f (Free f a)
coalg = forall (f :: * -> *) a. Cofree f a -> a
extract forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) b a.
Functor f =>
(f b -> b) -> (a -> f a) -> a -> b
hylo f (Cofree f b) -> Cofree f b
alg' Free f a -> f (Free f a)
coalg' forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. a -> Free f a
Ret
  where
    alg' :: f (Cofree f b) -> Cofree f b
alg' f (Cofree f b)
x = f (Cofree f b) -> b
alg f (Cofree f b)
x forall (f :: * -> *) a. a -> f (Cofree f a) -> Cofree f a
:< f (Cofree f b)
x
    coalg' :: Free f a -> f (Free f a)
coalg' (Ret a
a) = a -> f (Free f a)
coalg a
a
    coalg' (Op f (Free f a)
k) = f (Free f a)
k

fromList :: [a] -> Fix (ListF a)
fromList :: forall a. [a] -> Fix (ListF a)
fromList [] = forall (f :: * -> *). f (Fix f) -> Fix f
Fix forall a b. ListF a b
NilF
fromList (a
x:[a]
xs) = forall (f :: * -> *). f (Fix f) -> Fix f
Fix (forall a b. a -> b -> ListF a b
ConsF a
x (forall a. [a] -> Fix (ListF a)
fromList [a]
xs))

toList :: Fix (ListF a) -> [a]
toList :: forall a. Fix (ListF a) -> [a]
toList (Fix ListF a (Fix (ListF a))
NilF) = []
toList (Fix (ConsF a
x Fix (ListF a)
xs)) = a
x forall a. a -> [a] -> [a]
: forall a. Fix (ListF a) -> [a]
toList Fix (ListF a)
xs

stream2list :: StreamF a [a] -> [a]
stream2list :: forall a. StreamF a [a] -> [a]
stream2list (StreamF a
x [a]
y) = a
x forall a. a -> [a] -> [a]
: [a]
y

toNat :: Int -> Fix NatF
toNat :: Int -> Fix NatF
toNat Int
0 = forall (f :: * -> *). f (Fix f) -> Fix f
Fix forall a. NatF a
ZeroF
toNat Int
n = forall (f :: * -> *). f (Fix f) -> Fix f
Fix (forall a. a -> NatF a
SuccF (Int -> Fix NatF
toNat (Int
nforall a. Num a => a -> a -> a
-Int
1)))

fromNat :: Fix NatF -> Int
fromNat :: Fix NatF -> Int
fromNat (Fix NatF (Fix NatF)
ZeroF) = Int
0
fromNat (Fix (SuccF Fix NatF
x)) = Int
1 forall a. Num a => a -> a -> a
+ Fix NatF -> Int
fromNat Fix NatF
x