Recursion scheme playground

recursion.hs

{-# LANGUAGE  NoImplicitPrelude #-}
module Origami where

import Prelude
    (
      (.)
    , (-)
    , (*)
    , (++)
    , ($)
    , (&&)
    , (||)
    , Bool(..)
    , Either(..)
    , Eq(..)
    , Functor (..)
    , Int
    , Integer
    , Maybe(..)
    , Ord(..)
    , Show(..)
    , String
    , error
    , flip
    , id
    , otherwise
    , uncurry
    )

newtype Mu f = Mu { unMu :: f (Mu f) }

-- catamorphism
cata :: Functor f => (f a -> a) -> Mu f -> a
cata f = f . fmap (cata f) . unMu

-- paramorphism
para :: Functor f => (f (Mu f, a) -> a) -> Mu f -> a
para f = f . fmap go . unMu
  where
    go mu = (mu, para f mu)

-- anamporhism (catamorphism dual)
ana :: Functor f => (a -> f a) -> a -> Mu f
ana f a = Mu $ fmap (ana f) (f a)

-- apomorphism (paramorphism dual)
apo :: Functor f => (a -> f (Either a (Mu f))) -> a -> Mu f
apo f a = Mu $ fmap go (f a)
  where
    go (Left a1)  = apo f a1
    go (Right mu) = mu

-- hylomorphism (anamorphism and catamorphism composition)
hylo :: Functor f => (a -> f a) -> (f b -> b) -> a -> b
hylo ka kc = cata kc . ana ka

-- List fixpoint
type List a = Mu (Cons a)
data Cons a b = Cons a b
              | Nil

instance Functor (Cons a) where
    fmap f (Cons a b) = Cons a (f b)
    fmap _ Nil        = Nil

-- List api
cons :: a -> List a -> List a
cons x xs = Mu $ Cons x xs

uncons :: List a -> Maybe (a, List a)
uncons = para go
  where
    go Nil              = Nothing
    go (Cons a (as, _)) = Just (a, as)

nil :: List a
nil = Mu Nil

singleton :: a -> List a
singleton x = cons x nil

string :: Show a => List a -> String
string = cata go
  where
    go Nil = ""
    go (Cons a str) = show a ++ "," ++ str

map :: (a -> b) -> List a -> List b
map f = cata go
  where
    go Nil         = nil
    go (Cons a bs) = cons (f a) bs

append :: List a -> List a -> List a
append xs vs = cata go xs
  where
    go Nil         = vs
    go (Cons a as) = cons a as

bind :: (a -> List b) -> List a -> List b
bind f = cata go
  where
    go Nil         = nil
    go (Cons a bs) = append (f a) bs

filter :: (a -> Bool) -> List a -> List a
filter k = cata go
  where
    go Nil = nil
    go (Cons a as)
        | k a       = cons a as
        | otherwise = as

null :: List a -> Bool
null = cata go
  where
    go Nil        = False
    go (Cons _ _) = True

head :: List a -> a
head = cata go
  where
    go Nil        = error "empty list"
    go (Cons a _) = a

tail :: List a -> List a
tail = para go
  where
    go Nil              = nil
    go (Cons _ (xs, _)) = xs

find :: (a -> Bool) -> List a -> Maybe a
find k = cata go
  where
    go Nil = Nothing
    go (Cons a aOpt)
        | k a       = Just a
        | otherwise = aOpt

all :: (a -> Bool) -> List a -> Bool
all k = cata go
  where
    go Nil        = True
    go (Cons a b) = k a && b

any :: (a -> Bool) -> List a -> Bool
any k = cata go
  where
    go Nil        = True
    go (Cons a b) = k a || b

foldr :: (a -> b -> b) -> b -> List a -> b
foldr k b = cata go
  where
    go Nil         = b
    go (Cons a b1) = k a b1

foldl :: (b -> a -> b) -> b -> List a -> b
foldl k b mu = foldr go id mu $ b
  where
    go a f = f . flip k a

foldr1 :: (a -> a -> a) -> List a -> a
foldr1 k = go . uncons
  where
    go (Just (a, as)) = foldr k a as
    go Nothing        = error "empty list"

reverse :: List a -> List a
reverse = foldl (flip cons) nil

zip :: List a -> List b -> List (a, b)
zip as = cata go as
  where
    go Nil        _  = nil
    go (Cons a k) bs =
        case uncons bs of
            Nothing      -> nil
            Just (b,bs1) -> cons (a,b) (k bs1)

zipWith :: (a -> b -> c) -> List a -> List b -> List c
zipWith k as = map (uncurry k) . zip as

iterate :: (a -> a) -> a -> List a
iterate k = ana go
  where
    go a = Cons a (k a)

repeat :: a -> List a
repeat = iterate id

replicate :: Int -> a -> List a
replicate start a = ana go start
  where
    go 0 = Nil
    go i = Cons a (i-1)

cycle :: List a -> List a
cycle xs = xs' where xs' = append xs xs'

take :: Int -> List a -> List a
take = flip (cata go)
  where
    go Nil _ = nil
    go (Cons a k) i
        | i == 0    = nil
        | otherwise = cons a (k (i-1))

drop :: Int -> List a -> List a
drop = flip (para go)
  where
    go Nil _ = nil
    go (Cons a (as, k)) i
        | i == 0    = cons a as
        | otherwise = k (i-1)

takeWhile :: (a -> Bool) -> List a -> List a
takeWhile k = cata go
  where
    go Nil = nil
    go (Cons a as)
        | k a       = cons a as
        | otherwise = nil

dropWhile :: (a -> Bool) -> List a -> List a
dropWhile p = para go
  where
    go Nil = nil
    go (Cons a (as, fas))
        | p a       = fas
        | otherwise = cons a as

delete :: Eq a => a -> List a -> List a
delete x = para go
  where
    go Nil = nil
    go (Cons a (as, fas))
        | a == x    = as
        | otherwise = cons a fas

minimum :: Ord a => List a -> a
minimum = foldr1 min

maximum :: Ord a => List a -> a
maximum = foldr1 max

-- Sorting
insertionSort :: Ord a => List a -> List a
insertionSort = foldr (para . go) nil
  where
    go x Nil = cons x nil
    go x (Cons a (as, fas))
        | x < a     = cons x as
        | otherwise = cons a fas

selectionSort :: Ord a => List a -> List a
selectionSort = ana go
  where
    go xs =
        let a   = minimum xs
            xs1 = delete a xs in
        if null xs
            then Cons a xs1
            else Nil

bubbleSort :: Ord a => List a -> List a
bubbleSort = ana (foldr go Nil)
  where
    go x Nil = Cons x nil
    go x (Cons y ys)
        | x < y     = Cons x (cons y ys)
        | otherwise = Cons y (cons x ys)

-- Misc
fact :: Integer -> Integer
fact = hylo gen crush
  where
    gen x
        | x == 0    = Nil
        | otherwise = Cons x (x-1)

    crush Nil        = 1
    crush (Cons x y) = x * y