module Generics.Pointless.Examples.Examples where
import Generics.Pointless.Combinators
import Generics.Pointless.Functors
import Generics.Pointless.RecursionPatterns
import Prelude hiding (Functor(..),filter,concat,tail,length)
import Data.List hiding (filter,concat,tail,length,partition)
one = suck . zero
add :: (Int,Int) -> Int
add = uncurry (+)
addAnaPW :: (Int,Int) -> Int
addAnaPW = ana (_L::Int) h
where h (0,0) = Left _L
h (n,0) = Right (n1,0)
h (0,m) = Right (0,m1)
h (n,m) = Right (n,m1)
addAna :: (Int,Int) -> Int
addAna = ana (_L::Int) f
where f = (bang -|- (id >< zero \/ (zero >< id \/ succ >< id))) . aux . (out >< out)
aux = coassocr . (distl -|- distl) . distr
type From a = K a :+!: I
addHylo :: (Int,Int) -> Int
addHylo = hylo (_L::From Int) f g
where f = id \/ succ
g = (snd -|- id) . distl . (out >< id)
addAccum :: (Int,Int) -> Int
addAccum = accum (_L::Int) f t
where t = (fst -|- id >< succ) . distl
f = (snd \/ fst) . distl
addApoPW :: (Int,Int) -> Int
addApoPW = apo (_L :: Int) h
where h (0,0) = Left _L
h (n,0) = Right $ Right $ n1
h (n,m) = Right $ Left (n,m1)
addApo :: (Int,Int) -> Int
addApo = apo (_L::Int) h
where h = (id -|- coswap) . coassocr . (fst -|- inn >< id) . distr . (out >< out)
prod :: (Int,Int) -> Int
prod = uncurry (*)
prodHylo :: (Int,Int) -> Int
prodHylo = hylo (_L::[Int]) f g
where f = zero \/ add
g = (snd -|- fst /\ id) . distr . (id >< out)
gt :: Ord a => (a,a) -> Bool
gt = uncurry (>)
gtHylo :: (Int,Int) -> Bool
gtHylo = hylo (_L :: From Bool) f g
where g = ((((False!) \/ (True!)) \/ (False!)) -|- id) . coassocl . (distl -|- distl) . distr . (out >< out)
f = id \/ id
fact :: Int -> Int
fact 0 = 1
fact n = n * fact (n1)
factPF :: Int -> Int
factPF = ((1!) \/ prod) .
(id -|- id >< factPF) .
(id -|- id /\ pred) . (iszero?)
where iszero = (==0)
factPF' :: Int -> Int
factPF' = (one \/ prod) . (id -|- id >< factPF') . (id -|- succ /\ id) . out
factHylo :: Int -> Int
factHylo = hylo (_L :: [Int]) f g
where g = (id -|- succ /\ id) . out
f = one \/ prod
factPara :: Int -> Int
factPara = para (_L::Int) f
where f = one \/ (prod . (id >< succ))
factZygo :: Int -> Int
factZygo = zygo (_L::Int) inn f
where f = one \/ (prod . (id >< succ))
fib :: Int -> Int
fib 0 = 0
fib 1 = 1
fib n = fib (n1) + fib (n2)
fibPF :: Int -> Int
fibPF = (zero \/ (one \/ add)) . (bang -|- (bang -|- fibPF >< fibPF)) . (id -|- aux) . ((==0)?)
where aux = (id -|- pred /\ pred . pred) . ((==1)?)
fibPF' :: Int -> Int
fibPF' = (zero \/ (one \/ add)) . (id -|- (id -|- fibPF' >< fibPF')) . (id -|- aux) . out
where aux = (id -|- succ /\ id) . out
type BSTree = K One :+!: (K One :+!: I :*!: I)
fibHylo :: Int -> Int
fibHylo = hylo (_L :: BSTree) f g
where f = zero \/ (one \/ add)
g = (id -|- ((id -|- succ /\ id) . out)) . out
fibHisto :: Int -> Int
fibHisto = histo (_L::Int) f
where f = (zero \/ (one . snd \/ add . (id >< outl)) . distr . out)
fibDyna :: Int -> Int
fibDyna = dyna (_L::Int) f g
where f = (zero \/ (one . snd \/ add . (id >< outl)) . distr . out)
g = out
bp :: Int -> Int
bp 0 = 1
bp n = if odd n then bp (n1) else bp (n1) + bp (div n 2)
type BTree = K One :+!: (I :+!: (I :*!: I))
bpHylo :: Int -> Int
bpHylo = hylo (_L :: BTree) g h
where g = one \/ (id \/ add)
h = (id -|- h') . out
h' = (id -|- id /\ (`div` 2) . succ) . (even?)
bpDyna :: Int -> Int
bpDyna = dyna (_L :: [Int]) (g . o) h
where g = one \/ (id \/ add)
o = id -|- oj
oj = (o1 -|- o2) . ((odd . fst)?)
o1 = outl . snd
o2 = outl . snd /\ (outl . oi)
oi = uncurry pi . ((pred . (`div` 2)) >< id)
h = (id -|- succ /\ id) . out
pi 0 x = x
pi k x = case outr x of
Right (_,y) -> pi (pred k) y
average :: [Int] -> Int
average = uncurry div . (sum /\ length)
averageCata :: [Int] -> Int
averageCata = uncurry div . cata (_L::[Int]) f
where f = (zero \/ add . (id >< fst)) /\ (zero \/ succ . snd . snd)
wrap :: a -> [a]
wrap = (:[])
wrapPF :: a -> [a]
wrapPF = cons . (id /\ nil . bang)
tail :: [a] -> [a]
tail [] = []
tail (x:xs) = xs
tailPF :: [a] -> [a]
tailPF = (([]!) \/ snd) . out
tailCata :: [a] -> [a]
tailCata = fst . cata (_L::[a]) (f /\ inn . (id -|- id >< snd))
where f = ([]!) \/ snd . snd
tailPara :: [a] -> [a]
tailPara = para (_L::[a]) f
where f = ([]!) \/ snd . snd
length :: [a] -> Int
length [] = 0
length (x:xs) = succ (length xs)
lengthPF :: [a] -> Int
lengthPF = (zero . bang \/ succ . lengthPF . tail) . (null?)
lengthPF' :: [a] -> Int
lengthPF' = inn . (id -|- (lengthPF' . snd)) . out
lengthHylo :: [a] -> Int
lengthHylo = hylo (_L::Int) f g
where f = inn
g = (id -|- snd) . out
lengthAna :: [a] -> Int
lengthAna = ana _L f
where f = (id -|- snd) . out
lengthCata :: [a] -> Int
lengthCata = cata _L f
where f = zero \/ succ . snd
filter :: (a -> Bool) -> [a] -> [a]
filter p [] = []
filter p (x:xs) = if p x then x : filter p xs else filter p xs
filterCata :: (a -> Bool) -> [a] -> [a]
filterCata p = cata (_L::[a]) f
where f = (nil \/ (cons \/ snd)) . (id -|- ((p . fst)?))
repeatAna :: a -> [a]
repeatAna = ana (_L::[a]) (inr . (id /\ id))
replicateAna :: (Int,a) -> [a]
replicateAna = ana (_L::[a]) h
where h = (bang -|- snd /\ id) . distl . (out >< id)
downtoAna :: Int -> [Int]
downtoAna = ana _L f
where f = (bang -|- (id /\ pred)) . ((==0) ?)
insertApo :: Ord a => (a,[a]) -> [a]
insertApo = apo (_L::[a]) f
where f = inr. undistr . (inr \/ (inr \/ inl)) . ((id >< nil) -|- ((id >< cons) . assocr -|- assocr . (swap >< id)) . distl . ((le?) >< id) . assocl) . distr . (id >< out)
le = uncurry (<=)
insertPara :: Ord a => (a,[a]) -> [a]
insertPara (x,l) = para (_L::[a]) f l
where f = wrap . (x!) \/ ((x:) . cons . (id >< snd) \/ cons . (id >< fst)) . (((x <=) . fst)?)
snoc :: (a,[a]) -> [a]
snoc = hylo (_L::NeList a a) f g
where g = (fst -|- assocr . (swap >< id) . assocl) . distr . (id >< out)
f = wrap \/ cons
snocApo :: (a,[a]) -> [a]
snocApo = apo (_L::[a]) h
where h = inr . undistr . coswap . (id >< nil -|- assocr . (swap >< id) . assocl) . distr . (id >< out)
bubble :: (Ord a) => [a] -> Either One (a,[a])
bubble = cata (_L::[a]) f
where f = id -|- ((id >< ([]!)) \/ ((id >< cons) . assocr . (id \/ (swap >< id)) . ((uncurry (<) . fst) ?) . assocl)) . distr
takeAna :: (Int,[a]) -> [a]
takeAna = ana (_L::[a]) h
where h = (bang -|- assocr . (swap >< id) . assocl) . aux . (out >< out)
aux = coassocl . (distl -|- distl) . distr
partition :: Ord a => (a,[a]) -> ([a],[a])
partition (a,xs) = foldr (select a) ([],[]) xs
where select :: Ord a => a -> a -> ([a], [a]) -> ([a], [a])
select a x (ts,fs) = if a > x then (x:ts,fs) else (ts, x:fs)
partitionHylo :: (Ord a) => (a,[a]) -> ([a],[a])
partitionHylo = hylo (_L::[(a,a)]) f g
where g = (snd -|- ((id >< fst) /\ (id >< snd))) . distr . (id >< out)
f = (nil /\ nil) \/ (((cons >< id) . assocl . (snd >< id) \/ (id >< cons) . ((fst . snd) /\ (id >< snd)) . (snd >< id)) . ((gt . fst)?))
isum :: [Int] -> [Int]
isum = cata (_L::[Int]) f
where f = nil \/ isumOp . swap . (id >< cons . (zero . bang /\ id))
isumOp (l,x) = map (x+) l
fisum :: [Int] -> Int -> [Int]
fisum = cata (_L::[Int]) f
where f = pnt (nil . bang) \/ comp . swap . (curry add >< (cons .) . split . (pnt id . bang /\ id))
mapCata :: [a] -> (a -> b) -> [b]
mapCata = cata (_L::[a]) f
where f = (([]!)!) \/ curry (cons . (app . swap >< app) . ((fst >< id) /\ (snd >< id)))
reverseAna :: [a] -> [a]
reverseAna = cata (_L::[a]) f
where f = nil \/ (cat . swap . (wrap >< id))
qsort :: (Ord a) => [a] -> [a]
qsort = hylo (_L::Tree a) f g
where g = (id -|- (fst /\ partition)) . out
f = nil \/ (cat . (id >< cons) . assocr . (swap >< id) . assocl)
bsort :: (Ord a) => [a] -> [a]
bsort = ana (_L::[a]) bubble
isort :: (Ord a) => [a] -> [a]
isort = cata (_L::[a]) (nil \/ insertApo)
msplit :: [a] -> ([a],[a])
msplit = cata (_L::[a]) f
where f = (nil /\ nil) \/ (swap . (cons >< id) . assocl)
msort :: (Ord a) => [a] -> [a]
msort = hylo (_L::(K One :+!: K a) :+!: (I :*!: I)) f g
where g = coassocl . (id -|- (fst -|- msplit . cons) . ((null . snd)?)) . out
f = (([]!) \/ wrap) \/ merge
hsort :: (Ord a) => [a] -> [a]
hsort = hylo f g h
where f = _L ::(K One :+!: K a) :+!: (K a :*!: (I :*!: I))
h = coassocl . (id -|- (fst -|- hsplit . cons) . ((null . snd)?)) . out
g = (([]!) \/ wrap) \/ cons . (id >< merge)
hsplit :: (Ord a) => [a] -> (a,([a],[a]))
hsplit [x] = (x,([],[]))
hsplit (h:t) | h < m = (h,(m:l,r))
| otherwise = (m,(h:r,l))
where (m,(l,r)) = hsplit t
malcolm :: ((b, a) -> a) -> a -> [b] -> [a]
malcolm o e = map (cata (_L::[b]) ((e!) \/ o)) . malcolmAna' cons . (id /\ nil . bang)
malcolmAna :: ((b, a) -> a) -> a -> [b] -> [a]
malcolmAna o e = malcolmAna' o . (id /\ (e!))
malcolmAna' :: ((b, a) -> a) -> ([b], a) -> [a]
malcolmAna' o = ana (_L::[a]) g
where g = (fst -|- (snd /\ (id >< o) . assocr . (swap >< id))) . distl . (out >< id)
zipAna :: ([a],[b]) -> [(a,b)]
zipAna = ana (_L::[(a,b)]) f
where f = (bang -|- ((fst >< fst) /\ (snd >< snd))) . aux . (out >< out)
aux = coassocl . (distl -|- distl) . distr
subsequences :: Eq a => [a] -> [[a]]
subsequences = cata (_L::[a]) f
where f = cons . (nil /\ nil) \/ uncurry union . (snd /\ subsOp . swap . (wrap >< id))
subsOp (r,l) = map (l++) r
cat :: ([a],[a]) -> [a]
cat = uncurry (++)
catCata :: [a] -> [a] -> [a]
catCata = cata (_L::[a]) f
where f = (id!) \/ (comp . (curry cons >< id))
type NeList a b = K a :+!: (K b :*!: I)
catHylo :: ([a],[a]) -> [a]
catHylo = hylo (_L::NeList [a] a) f g
where g = (snd -|- assocr) . distl . (out >< id)
f = id \/ cons
concat :: [[a]] -> [a]
concat [] = []
concat (l:ls) = l ++ concat ls
concatCata :: [[a]] -> [a]
concatCata = cata (_L::[[a]]) g
where g = ([]!) \/ cat
merge :: (Ord a) => ([a],[a]) -> [a]
merge = hylo (_L::NeList [a] a) f g
where g = ((id \/ id) -|- ((id \/ id) . (assocr -|- (assocr . (swap >< id) . assocl)) . (id >< cons -|- cons >< id) . ((uncurry (<) . (fst >< fst))?) )) . coassocl . (snd -|- (((cons . fst) -|- id) . distr . (id >< out))) . distl . (out >< id)
f = id \/ cons
sumCata :: [Int] -> Int
sumCata = cata (_L::[Int]) f
where f = (0!) \/ add
mult :: [Int] -> Int
mult [] = 1
mult (x:xs) = x * mult xs
multCata :: [Int] -> Int
multCata = cata _L f
where f = (1!) \/ prod
sorted :: (Ord a) => [a] -> Bool
sorted = para (_L::[a]) f
where f = true \/ uncurry (&&) . ((true . bang \/ uncurry (<=) . (id >< head)) . ((null . snd)?) >< id) . assocl . (id >< swap)
editdist :: Eq a => ([a],[a]) -> Int
editdist ([],bs) = length bs
editdist (as,[]) = length as
editdist (a:as,b:bs) = minimum [m1,m2,m3]
where m1 = editdist (as,b:bs) + 1
m2 = editdist (a:as,bs) + 1
m3 = editdist (as,bs) + (if a==b then 0 else 1)
type EditDist a = K [a] :+!: ((K a :*!: K a) :*!: I :*!: I :*!: I)
type EditDistL a = (K [a] :*!: K [a]) :*!: (K One :+!: I)
editdistHylo :: Eq a => ([a],[a]) -> Int
editdistHylo (x::([a],[a])) = hylo (_L::EditDist a) g h x
where g :: Eq a => F (EditDist a) Int -> Int
g = length \/ g'
g' ((a,b),(x1,(x2,x3))) = min m1 (min m2 m3)
where m1 = succ x1
m2 = succ x2
m3 = add (x3,if a==b then 0 else 1)
h ([],bs) = Left bs
h (as,[]) = Left as
h (a:as,b:bs) = Right ((a,b),((as,b:bs),((a:as,bs),(as,bs))))
editDistDyna :: Eq a => ([a],[a]) -> Int
editDistDyna (l1::[a],l2) = dyna (_L :: EditDistL a) (g . o (length l1)) (h l1) (l1,l2)
where g :: Eq a => F (EditDist a) Int -> Int
g = length \/ g'
g' ((a,b),(x1,(x2,x3))) = min m1 (min m2 m3)
where m1 = succ x1
m2 = succ x2
m3 = add (x3,if a==b then 0 else 1)
o :: Int -> F (EditDistL a) (Histo (EditDistL a) Int) -> F (EditDist a) Int
o n ((as,bs),Left _) = Left []
o n (([],bs),Right x) = Left bs
o n ((as,[]),Right x) = Left as
o n ((a:as,b:bs),Right x) = Right ((a,b),(j x,(j (pi n x),j (pi (succ n) x))))
h :: [a] -> ([a],[a]) -> F (EditDistL a) ([a],[a])
h cs ([],[]) = (([],[]),Left _L)
h cs ([],b:bs) = (([],b:bs),Right (cs,bs))
h cs (a:as,bs) = ((a:as,bs),Right (as,bs))
pi :: Int -> Histo (EditDistL a) Int -> Histo (EditDistL a) Int
pi 0 x = x
pi k x = case outr x of
(_,Right y) -> pi (pred k) y
j = outl
type Stream a = K a :*!: I
headS :: Stream a -> a
headS = fst . out
tailS :: Stream a -> Stream a
tailS = snd . out
generate :: Int -> Stream Int
generate = ana (_L::Stream Int) (id /\ succ)
idStream :: Stream a -> Stream a
idStream = ana (_L::Stream a) out
mapStream :: (a -> b) -> Stream a -> Stream b
mapStream f = ana (_L::Stream b) g
where g = (f >< id) . out
malcolmS :: ((b,a) -> a) -> a -> Stream b -> Stream a
malcolmS o e = mapStream (cata (_L::[b]) ((e!) \/ o)) . malcolmSAna' cons . (id /\ nil . bang)
malcolmSAna :: ((b,a) -> a) -> a -> Stream b -> Stream a
malcolmSAna o e = malcolmSAna' o . (id /\ (e!))
malcolmSAna' :: ((b,a) -> a) -> (Stream b, a) -> Stream a
malcolmSAna' o = ana (_L::Stream a) g
where g = snd /\ swap . (o >< id) . assocl . (id >< swap) . assocr . (out >< id)
inits :: Stream a -> Stream [a]
inits = malcolmSAna' cons . (id /\ nil . bang)
exchFutu :: Stream a -> Stream a
exchFutu = futu (_L::Stream a) (f /\ (g . (h /\ i)))
where f = headS . tailS
g = innr
h = headS
i = innl . tailS . tailS
data Tree a = Empty | Node a (Tree a) (Tree a) deriving Show
type instance PF (Tree a) = Const One :+: (Const a :*: (Id :*: Id))
instance Mu (Tree a) where
inn (Left _) = Empty
inn (Right (a,(b,c))) = Node a b c
out Empty = Left _L
out (Node a b c) = Right (a,(b,c))
nleaves :: Tree a -> Int
nleaves = cata (_L::Tree a) f
where f = (1!) \/ (add . snd)
nnodes :: Tree a -> Int
nnodes = cata (_L::Tree a) f
where f = (0!) \/ (succ . add . snd)
genTree :: Int -> Tree Int
genTree = ana (_L::Tree Int) f
where f = (bang -|- (id /\ (pred /\ pred))) . ((==0)?)
preTree :: Tree a -> [a]
preTree = cata (_L::Tree a) f
where f = ([]!) \/ (cons . (id >< cat))
postTree :: Tree a -> [a]
postTree = cata (_L::Tree a) f
where f = ([]!) \/ (cat . swap . (wrap >< cat))
data LTree a = Leaf a | Branch (LTree a) (LTree a)
type instance PF (LTree a) = Const a :+: (Id :*: Id)
instance Mu (LTree a) where
inn (Left x) = Leaf x
inn (Right (x,y)) = Branch x y
out (Leaf x) = Left x
out (Branch x y) = Right (x,y)
leaves :: LTree a -> [a]
leaves = cata (_L::LTree a) f
where f = wrap \/ cat
genLTree :: Int -> LTree Int
genLTree = ana (_L::LTree Int) f
where f = ((0!) -|- (id /\ id)) . out
height :: LTree a -> Int
height = cata (_L::LTree a) f
where f = (0!) \/ (succ . uncurry max)
data Rose a = Forest a [Rose a] deriving Show
type instance PF (Rose a) = Const a :*: ([] :@: Id)
instance Mu (Rose a) where
inn (a,l) = Forest a l
out (Forest a l) = (a,l)
preRose :: Rose a -> [a]
preRose = cata (_L::Rose a) f
where f = (cons . (id >< concat))
postRose :: Rose a -> [a]
postRose = cata (_L::Rose a) f
where f = cat . swap . (wrap >< cata (_L::[[a]]) (nil \/ cat))
genRose :: Int -> Rose Int
genRose = ana (_L::Rose Int) f
where f = ((id /\ ([]!)) \/ (id /\ downtoAna . pred)) . ((==0)?)