Created
April 2, 2020 18:18
-
-
Save xgrommx/892d7139fe4c0c6abf6fbfe8b0891b31 to your computer and use it in GitHub Desktop.
Recursion schemes from scratch
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| {-# LANGUAGE RankNTypes, MultiParamTypeClasses, FunctionalDependencies #-} | |
| module Main7 where | |
| sumL :: [Int] -> Int | |
| sumL [] = 0 | |
| sumL (x:xs) = x + sumL xs | |
| sumL1 :: [Int] -> Int | |
| sumL1 [] = 0 | |
| sumL1 (x:xs) = (+) x (sumL1 xs) | |
| sumL2 :: Int -> [Int] -> Int | |
| sumL2 z [] = z | |
| sumL2 z (x:xs) = (+) x (sumL2 z xs) | |
| sumL3 :: (Int -> Int -> Int) -> Int -> [Int] -> Int | |
| sumL3 fn z [] = z | |
| sumL3 fn z (x:xs) = fn x (sumL3 fn z xs) | |
| sumL4 :: (a -> a -> a) -> a -> [a] -> a | |
| sumL4 fn z [] = z | |
| sumL4 fn z (x:xs) = fn x (sumL4 fn z xs) | |
| foldrList :: (a -> b -> b) -> b -> [a] -> b | |
| foldrList fn z [] = z | |
| foldrList fn z (x:xs) = fn x (foldrList fn z xs) | |
| -- (a -> b -> b) -> b -> [a] -> b | |
| -- ((a, b) -> b) -> b -> [a] -> b | |
| -- b -> ((a, b) -> b) -> [a] -> b | |
| -- (() -> b) -> ((a, b) -> b) -> [a] -> b | |
| -- ((() -> b), ((a, b) -> b)) -> [a] -> b | |
| -- ((1 -> b) * (a * b -> b)) -> [a] -> b | |
| -- (b ^ 1 * b ^ (a * b)) -> [a] -> b | |
| -- (b ^ (1 + a * b)) -> [a] -> b | |
| -- (Either () (a, b) -> b) -> [a] -> b | |
| -- (Maybe (a, b) -> b) -> [a] -> b | |
| -- (ListF a b -> b) -> [a] -> b | |
| type Algebra f a = f a -> a | |
| class Functor f => Recursive t f | t -> f where | |
| project :: t -> f t | |
| data ListF a b = NilF | ConsF a b | |
| instance Functor (ListF a) where | |
| fmap _ NilF = NilF | |
| fmap f (ConsF a b) = ConsF a (f b) | |
| projectL :: [a] -> ListF a [a] | |
| projectL [] = NilF | |
| projectL (x:xs) = ConsF x xs | |
| instance Recursive [a] (ListF a) where | |
| project = projectL | |
| foldrListC :: Algebra (ListF a) b -> [a] -> b | |
| foldrListC g = go where | |
| go = g . fmap go . project | |
| data Expr = Lit Int | Add Expr Expr | Mul Expr Expr | |
| evalExpr :: Expr -> Int | |
| evalExpr = go where | |
| go (Lit x) = x | |
| go (Add e1 e2) = go e1 + go e2 | |
| go (Mul e1 e2) = go e1 * go e2 | |
| evalExpr' :: (Int -> a) -> (a -> a -> a) -> (a -> a -> a) -> Expr -> a | |
| evalExpr' fn _ _ (Lit a) = fn a | |
| evalExpr' fn add mul (Add a b) = add (evalExpr' fn add mul a) (evalExpr' fn add mul b) | |
| evalExpr' fn add mul (Mul a b) = mul (evalExpr' fn add mul a) (evalExpr' fn add mul b) | |
| -- (Int -> a) -> (a -> a -> a) -> (a -> a -> a) -> Expr -> a | |
| -- (Int -> a) -> ((a, a) -> a) -> ((a, a) -> a) -> Expr -> a | |
| -- ((Int -> a), ((a, a) -> a)) -> ((a, a) -> a) -> Expr -> a | |
| -- (((Int -> a), ((a, a) -> a)), ((a, a) -> a)) -> Expr -> a | |
| -- (a ^ Int * a ^ a * a * a ^ a * a) | |
| -- (Either Int (Either (a, a) (a, a)) -> a) -> Expr -> a | |
| -- (ExprF a -> a) -> Expr -> a | |
| projectE :: Expr -> ExprF Expr | |
| projectE (Lit x) = LitF x | |
| projectE (Add a b) = AddF a b | |
| projectE (Mul a b) = MulF a b | |
| data ExprF a = LitF Int | AddF a a | MulF a a | |
| instance Recursive Expr ExprF where | |
| project = projectE | |
| instance Functor ExprF where | |
| fmap _ (LitF x) = LitF x | |
| fmap f (AddF a b) = AddF (f a) (f b) | |
| fmap f (MulF a b) = MulF (f a) (f b) | |
| evalExprC :: Algebra ExprF a -> Expr -> a | |
| evalExprC g = go where | |
| go = g . fmap go . project | |
| -- data Tree a = Empty | Node (Tree a) a (Tree a) | |
| -- data RoseTree a = RoseNode a [RoseTree a] | |
| -- () = 1 | |
| -- Void = 0 | |
| -- (,) = (*) | |
| -- Either = (+) | |
| -- a -> b = b ^ a | |
| -- a ^ n * a ^ m = a ^ (n + m) | |
| cata :: Recursive t f => Algebra f a -> t -> a | |
| cata alg = go where | |
| go = alg . fmap go . project | |
| foldMapL :: Monoid m => (a -> m) -> [a] -> m | |
| foldMapL fn = cata alg where | |
| alg NilF = mempty | |
| alg (ConsF x xs) = fn x <> xs |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment