Add a draft of the catmorphisms post

code/catamorphisms/Cata.hs

@@ -0,0 +1,101 @@
+{-# LANGUAGE LambdaCase, DeriveFunctor, DeriveFoldable, MultiParamTypeClasses #-}
+import Prelude hiding (length, sum, fix)
+
+length :: [a] -> Int
+length [] = 0
+length (_:xs) = 1 + length xs
+
+lengthF :: ([a] -> Int) -> [a] -> Int
+lengthF rec [] = 0
+lengthF rec (_:xs) = 1 + rec xs
+
+lengthF' = \rec -> \case
+    [] -> 0
+    _:xs -> 1 + rec xs
+
+fix f = let x = f x in x
+
+length' = fix lengthF
+
+data MyList = MyNil | MyCons Int MyList
+data MyListF a = MyNilF | MyConsF Int a 
+
+newtype Fix f = Fix { unFix :: f (Fix f) }
+
+testList :: Fix MyListF
+testList = Fix (MyConsF 1 (Fix (MyConsF 2 (Fix (MyConsF 3 (Fix MyNilF))))))
+
+myOut :: MyList -> MyListF MyList
+myOut MyNil = MyNilF
+myOut (MyCons i xs) = MyConsF i xs
+
+myIn :: MyListF MyList -> MyList 
+myIn MyNilF = MyNil
+myIn (MyConsF i xs) = MyCons i xs
+
+instance Functor MyListF where
+    fmap f MyNilF = MyNilF
+    fmap f (MyConsF i a) = MyConsF i (f a)
+
+mySumF :: MyListF Int -> Int
+mySumF MyNilF = 0
+mySumF (MyConsF i rest) = i + rest
+
+mySum :: MyList -> Int
+mySum = mySumF . fmap mySum . myOut
+
+myCata :: (MyListF a -> a) -> MyList -> a
+myCata f = f . fmap (myCata f) . myOut
+
+myLength = myCata $ \case
+    MyNilF -> 0
+    MyConsF _ l -> 1 + l
+
+myMax = myCata $ \case
+    MyNilF -> 0
+    MyConsF x y -> max x y
+
+myMin = myCata $ \case
+    MyNilF -> 0
+    MyConsF x y -> min x y
+
+myTestList = MyCons 2 (MyCons 1 (MyCons 3 MyNil))
+
+pack :: a -> (Int -> a -> a) -> MyListF a -> a
+pack b f MyNilF = b
+pack b f (MyConsF x y) = f x y
+
+unpack :: (MyListF a -> a) -> (a, Int -> a -> a)
+unpack f = (f MyNilF, \i a -> f (MyConsF i a))
+
+class Functor f => Cata a f where
+    out :: a -> f a
+
+cata :: Cata a f => (f b -> b) -> a -> b
+cata f = f . fmap (cata f) . out
+
+instance Cata MyList MyListF where
+    out = myOut
+
+data ListF a b = Nil | Cons a b deriving Functor
+
+instance Cata [a] (ListF a) where
+    out [] = Nil
+    out (x:xs) = Cons x xs
+
+sum :: Num a => [a] -> a
+sum = cata $ \case
+    Nil -> 0
+    Cons x xs -> x + xs
+
+data BinaryTree a = Node a (BinaryTree a) (BinaryTree a) | Leaf deriving (Show, Foldable)
+data BinaryTreeF a b = NodeF a b b | LeafF deriving Functor
+
+instance Cata (BinaryTree a) (BinaryTreeF a) where
+    out (Node a l r) = NodeF a l r
+    out Leaf = LeafF
+
+invert :: BinaryTree a -> BinaryTree a
+invert = cata $ \case
+    LeafF -> Leaf
+    NodeF a l r -> Node a r l