Recursion Scheme Sandbox

RecursionSchemeSandbox.hs

module Main where
import Control.Arrow((>>>),(<<<),(&&&),(|||))

{-# LANGUAGE DeriveFunctor #-}


main :: IO ()
main = putStrLn "Hello, Haskell!"


type Algebra f a = f a -> a

newtype Fix f = In (f (Fix f))

out :: Fix f -> f (Fix f)
out (In f) = f


data NatF a = Z | S a deriving Show

instance Functor NatF where
    fmap f Z = Z
    fmap f (S n) = S (f n)

data ListF b a = N | C b a

instance Functor (ListF b) where
    fmap f N = N
    fmap f (C e a) = C e (f a)

type Nat = Fix NatF
type List a = Fix (ListF a)

z :: Nat 
z = In Z

suc :: Nat -> Nat
suc n = In $ S n

nil :: List a
nil = In N

cons :: a -> List a -> List a
cons a xs = In $ C a xs
 
toIntAlg :: Algebra NatF Int
toIntAlg Z = 0
toIntAlg (S n) = 1 + n

natPlusOne :: Algebra NatF Nat
natPlusOne Z = suc z
natPlusOne (S n) = suc n

mapAlg :: (a -> b) ->  Algebra (ListF a) (List b)
mapAlg f N = nil
mapAlg f (C a xs) = cons (f a) xs

lenAlg :: Algebra (ListF a) Int
lenAlg N = 0
lenAlg (C _ xs) = 1 + xs

showListAlg :: (Show a) => Algebra (ListF a) String 
showListAlg N = ""
showListAlg (C a xs) = show a ++ "," ++xs

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


co :: CoAlgebra NatF Int 
co 0 = Z


toInt :: Nat -> Int
toInt = cata toIntAlg

len :: List a -> Int 
len = cata lenAlg

map :: (a -> b) -> List a -> List b
map = cata . mapAlg

pplist :: (Show a) => List a -> String 
pplist = cata showListAlg

ex :: Int 
ex = toInt $ suc $ suc $ suc z


-- Anamorphism

type CoAlgebra f a = a -> f a

ana :: (Functor f) => CoAlgebra f a -> a -> Fix f
ana coalg = coalg >>> fmap (ana coalg) >>> In

-- builds up a list of n 'a's ?!
nested :: CoAlgebra (ListF Char) Int 
nested 0 = N
nested n = C 'a' (n-1)

-- build up a balanced tree of height n

data TreeF b a = Leaf | Node a b a 

instance Functor (TreeF b) where
    fmap f Leaf = Leaf
    fmap f (Node l v r) = Node (f l) v (f r)

type Tree a = Fix (TreeF a)

showTreeAlg :: (Show a) => Algebra (TreeF a) String
showTreeAlg Leaf = ""
showTreeAlg (Node l v r) = "((" ++ l ++ ")" ++ (show v) ++ "(" ++ r ++ "))" 

showt :: (Show a) => Tree a -> String
showt = cata showTreeAlg

htreeAlg :: CoAlgebra (TreeF Int) Int 
htreeAlg n | n < 1= Leaf
htreeAlg n = Node (n-1) 0 (n-1)

htreeAlgg :: CoAlgebra (TreeF Int) Int 
htreeAlgg n | n < 1= Leaf
htreeAlgg n = Node (n-2) 0 (n-1)

balanced :: Int -> Tree Int
balanced = ana htreeAlg

unbalanced :: Int -> Tree Int 
unbalanced = ana htreeAlgg

-- paramorphism
-- para - parallel
-- package the result of the fold with its original subterm
type RAlgebra f a = f (Fix f , a) -> a

-- recall cata
-- out >>> fmap (cata alg) >>> alg
-- this is the same, but packing the parameter to fmap para into a tuple 
para :: (Functor f) => RAlgebra f a -> Fix f -> a
para ralg = out >>> fmap fanout >>> ralg 
    where
        fanout = id &&& para ralg
        --fanout t = (t , para ralg t)

-- ex sum tree
-- use the subterm to check if the tree is unbalanced, and throw an exception if it is
sumTreeAlg :: RAlgebra (TreeF Int) Int 
sumTreeAlg Leaf = 0
-- see that sub terms are tupled with the resultss
sumTreeAlg (Node (In Leaf,lv) v (In Node {}, rv)) = error "unbalanced"
sumTreeAlg (Node (In Node {}, rv) v (In Leaf,lv)) = error "unbalanced"
sumTreeAlg (Node (l,lv) v (r,rv)) = lv + v + rv

sumBalanced :: Tree Int -> Int
sumBalanced = para sumTreeAlg

-- builds up a tree using anamorphism
-- tears down a tree using catamorphims(paramorphisms)
exCataAna :: Int
exCataAna = sumBalanced $ balanced 8

-- apomorphisms
-- co in 2 ways here
-- arrow direction
-- product -> coproduct

-- semantics: early termination of term buildings
type RCoAlgebra f a = a -> f (Either (Fix f) a )


-- recall ana
-- coana = coalg >>> fmap (ana alg) >>> In
apo :: (Functor f) => RCoAlgebra f a -> a -> Fix f
apo rcoalg = rcoalg >>> fmap fanin >>> In
    where fanin = id ||| apo rcoalg
        --either id (apo rcoalg)
        
-- ex build a balanced tree, using Int as a generator, that stops at height 7

-- does not work b/c you are counting down from some n to x not from 0 to n
balancedNTree :: Int -> RCoAlgebra (TreeF ()) Int 
balancedNTree x n = case n of               
                     0 -> Leaf
                     n | n < x -> Node (Left $ In Leaf) () (Left $ In Leaf)
                     n -> Node (Right (n-1)) () (Right (n-1))

bal3 :: Int -> Tree ()
bal3 = apo $ balancedNTree 3

-- Algebras so far
-- F(A) -> A
-- A -> F(A) -- can this be used to build up streams (need some delayed evaluation)
-- F((Fix F) x A) -> A
-- A -> F((Fix F) + A)

-- what about mendler style catatmorphisms with an explicit recursor

-- histomorphims (like DP?, preserve the results of invocation on subterms)

-- this is different from para morphism where you are just given access to all the subterms
-- here the pair (value,subterm) is a recursive type, so you get both
-- Cofree Comonad
data Attr f a = Attr {attribute:: a, hole :: f (Attr f a)}

-- course of value (co)itteration and (co)recursion
type CVAlgebra f a = f(Attr f a) -> a


--
histo1 :: (Functor f) => CVAlgebra f a -> Fix f -> a
histo1 cvalg = out >>> fmap dp >>> cvalg
    where
        dp t = Attr (histo1 cvalg t) (fmap dp (out t))
        -- first component: evaluate the sub terms (just like cata)
        -- second component: t: Fix f
        -- out t :: f (Fix f)
        -- fmap dp (out t) :: f(Attr f a)
        -- b/c dp :: Fix f -> Attr f a
        
        --NOTE: This definition does not share subcomputations.. dp recomputes them!




-- try it with fib anyway
fibalg1 :: CVAlgebra NatF Int
-- 0 -> 1
fibalg1 Z = 1
-- 1 -> 1
fibalg1 (S (Attr _ Z)) = 1
-- n-1, n-2 -> n-1 + n-2
fibalg1 (S (Attr p (S (Attr pp _)))) = p + pp
-- could probably clean this up with pattern synonyms

fib1 :: Nat -> Int
fib1 = histo1 fibalg1

-- This definition shares subcomputations
--histo :: (Functor f) => CVAlgebra f a -> Fix f -> a
--histo cvalg = _

-- histo that does not recompute 
histo :: (Functor f) => CVAlgebra f a -> Fix f -> a
histo cvalg = dp >>> attribute where 
    dp = out >>> fmap dp >>> (cvalg &&& id) >>> uncurry Attr

fibalg2 :: CVAlgebra NatF Int 
fibalg2 Z = 1
fibalg2 (S (Attr _ Z)) = 1
fibalg2 (S (Attr p (S (Attr pp _)))) = p + pp

fib2 :: Nat -> Int 
fib2 = histo fibalg2

toNat :: Int -> Nat
toNat n | n < 1 = z
toNat n = suc $ toNat (n-1)

-- becase fib1 recomputes, it is exponential
-- you can see the difference between fib1 (exponential) and fib2 (linear) by trying it on 30
slow :: Int 
slow = fib1 $ toNat 30

fast :: Int 
fast = fib1 $ toNat 30

-- what about histomorphism over an inductive definition of matrix? (see Block matricies)
--Type Your Matrices for Great Good
-- would require a functor instance over their complicated GADT

-- claim: The cache shape changes based on the functor
-- ex) with NatF, the cache is essentially a linked list

-- to see this.. define a CVAlgebra over TreeF

data BTreeF a = L | B a a

type BinaryTree = Fix BTreeF

bTreeCVAlg :: CVAlgebra BTreeF ()
bTreeCVAlg L = ()
bTreeCVAlg (B (Attr () leftCache ) (Attr () rightCache)) = ()

-- NOTE: you can achieve cata and para from histo
{-
cata :: Functor f => Algebra f a -> Term f -> a
cata f = histo (fmap attribute >>> f)

para :: Functor f => RAlgebra f a -> Term f -> a
para f = histo (fmap worker >>> f) where
  worker (Attr a h) = (In (fmap (worker >>> fst) h), a)
-}


-- Futumorphisms
-- start dualizing!

-- Free Monad
data CoAttr f a = Automatic a | Manual (f (CoAttr f a ))

type CVCoAlgebra f a = a -> f (CoAttr f a)

--futu :: Functor f => CVCoAlgebra f a -> a -> Fix f
--futu cvco = 


-- hylomorphims: anamorphim >>> catamorphism  (or use deforistation to remove intermediate step)
-- metamorphism: catamorphism >>> anamorphism
-- https://bartoszmilewski.com/2018/08/20/recursion-schemes-for-higher-algebras/
-- http://www.cs.ox.ac.uk/jeremy.gibbons/publications/urs.pdf
-- http://comonad.com/haskell/Chronomorphism.hs
-- https://www.cs.ox.ac.uk/ralf.hinze/publications/WGP13.pdf
--  zygomorphism, explicit recursor
--  mutumorphism, mutual recursive
--  dynamorphism?
--  pre/postpromorpism
--  chronomorphism?
-- all of them... yikes
-- https://hackage.haskell.org/package/recursion-schemes-5.2.2/docs/Data-Functor-Foldable.html
-- including mendler
--    generalizes all of them? 
    --chrono :: Functor f =>
     --     (f (Cofree f b) -> b) ->
      --    (a -> f (Free f a)) ->
       --   a -> b


-- Merge sort hylomorphism
-- how to apply deforistation?

merge :: Ord a => [a] -> [a] -> [a]
merge [] m = m
merge n [] = n
merge (x:xs) (y:ys) | x <= y = x : merge xs (y:ys)
merge (x:xs) (y:ys) = y : merge (x:xs) ys

hylo :: Functor f => Algebra f b -> CoAlgebra f a -> a -> b
hylo f g = g >>> fmap (hylo f g) >>> f 

data TreeF' a r = Empty | Leaf' a | Node' r r 

instance Functor (TreeF' a) where
    fmap f Empty = Empty
    fmap f (Leaf' x) = Leaf' x
    fmap f (Node' l r) = Node' (f l) (f r)


split :: CoAlgebra (TreeF' a) [a]
split []  = Empty
split [x] = Leaf' x
split xs  = Node' l r where
  (l, r) = splitAt (length xs `div` 2) xs


combine :: Ord a => Algebra (TreeF' a) [a]
combine Empty = []
combine (Leaf' x) = [x]
combine (Node' l r) = merge l r


mergeSort :: Ord a => [a] -> [a]
mergeSort = hylo combine split

divBy :: Int -> Int -> Bool 
divBy x y | mod x y == 0 = True
divBy _ _ = False


fb :: Int -> IO ()
fb x | divBy x 3 && divBy x 5 = print "FizzBuzz"
fb x | divBy x 3 = print "Fizz"
fb x | divBy x 5 = print "Buzz"
fb x = print $ show x

fizzbuzz :: [Int] -> IO ()
fizzbuzz = mapM_ fb