ApomorphismShortcutRecursion.hs

{-#LANGUAGE DeriveFunctor#-}

module Main where

fix :: ((a -> b) -> a -> b) -> a -> b
fix f = f (fix f)

data Fix f = In { out :: f (Fix f) }

ana :: Functor f => (a -> f a) -> (a -> Fix f) -> a -> Fix f
ana psi f = In . fmap f . psi

anaRec :: Functor f => (a -> f a) -> a -> Fix f
anaRec psi = fix (ana psi)

cata :: Functor f => (f a -> a) -> (Fix f -> a) -> Fix f -> a
cata psi f = psi . fmap f . out

cataRec :: Functor f => (f a -> a) -> Fix f -> a
cataRec psi = fix (cata psi)

apo :: Functor f => (a -> f (Either (Fix f) a)) -> (a -> Fix f) -> a -> Fix f
apo psi f = In . fmap worker . psi
  where worker (Left t) = t
        worker (Right a) = f a

apoRec :: Functor f => (a -> f (Either (Fix f) a)) -> a -> Fix f
apoRec psi = fix (apo psi)

data ListF a b = Empty | Cons a b | NoOp b deriving Functor

type ListR a = Fix (ListF a)

genList :: Int -> ListR Int
genList = anaRec psi
  where psi 0 = Empty
        psi n = Cons n (n - 1)

cataList :: ListR Int -> String
cataList = cataRec psi
  where psi Empty = "[]"
        psi (Cons n x) = show n ++ ":" ++ x

apoMap :: ListR Int -> ListR Int
apoMap = apoRec (psi . out)
  where psi Empty = Empty
        psi (Cons x xs) = if x > 5 then Cons (x * 2) (Right xs) else fmap Left (out xs)

main :: IO ()
main = print (cataList (apoMap (genList 10)))