{-# OPTIONS -fglasgow-exts -fallow-undecidable-instances #-}

module Examples where

import PFRecPat
import qualified List

-- 1 + Id

instance FunctorOf (Unit :+: Rec) Int
    where inn' = ((0!) \/ succ) . to
	  out' = from . ((()!) -|- pred) . grd (==0)

length' :: [a] -> Int
length' = ana (bot::Int) f
    where f = ((()!) -|- snd) . out

fact' :: Int -> Int
fact' = para (bot::Int) f
    where f = (1!) \/ (mult . (id >< succ))

plus' :: (Int,Int) -> Int
plus' = afold (bot::Int) t f
    where t = (fst -|- id >< succ) . distl
	  f = (snd \/ fst) . distl

ack :: Int -> Int -> Int
ack = cata (bot::Int) f
    where f = (succ!) \/ (curry (afold (bot::Int) t g . swap))
	  t = (fst -|- id) . distl
	  g = ((app . (id >< (1!))) \/ app) . distr . swap

-- A * Id

data Stream a = SCons a (Stream a) deriving Show

instance FunctorOf (Const a :*: Rec) (Stream a)
    where inn' (Const x :*: Rec xs) = SCons x xs
	  out' (SCons x xs) = Const x :*: Rec xs

generate :: Int -> Stream Int
generate = ana (bot::Stream Int) (id /\ succ)

idStream :: Stream a -> Stream a
idStream = ana (bot::Stream a) out

accum :: ((b, a) -> a) -> (Stream b, a) -> Stream a
accum o = ana (bot::Stream a) g
    where g = snd /\ swap . (o >< id) . assocl . (id >< swap) . assocr . (out >< id)

inits :: Stream a -> Stream [a]
inits = accum cons . (id /\ nil)

mapStream :: (a -> b) -> Stream a -> Stream b
mapStream f = ana (bot::Stream b) g 
    where g = (f >< id) . out

malcolm :: ((b, a) -> a) -> a -> Stream b -> Stream a
malcolm o e = mapStream (cata (bot::[b]) ((e!) \/ o)) . accum cons . (id /\ nil)
fmalcolm :: ((b, a) -> a) -> a -> Stream b -> Stream a
fmalcolm o e = accum o . (id /\ (e!))

-- 1 + A * Id

instance FunctorOf (Unit :+: (Const a :*: Rec)) [a] 
    where inn' = (nil \/ cons) . to
	  out' = from . ((()!) -|- head /\ tail) . (grd null)

nil :: a -> [b]
nil = ([]!)

cons :: (a,[a]) -> [a]
cons = uncurry (:)

wrap :: a -> [a]
wrap = cons . (id /\ nil)

length :: [a] -> Int
length = cata (bot::[a]) f
    where f = (0!) \/ (succ . snd)

rev :: [a] -> [a]
rev = cata (bot::[a]) f 
    where f = ([]!) \/ (cat . swap . (wrap >< id))

frev :: [a] -> [a] -> [a]
frev = cata (bot::[a]) f
    where f = (id!) \/ (comp . swap . (curry cons >< id))

frev' :: ([a],[a]) -> [a]
frev' = afold (bot::[a]) t f 
    where t = (fst -|- ((fst . fst) /\ ((snd . fst) /\ (cons . (fst >< id))))) . distl
	  f = (snd \/ (snd . fst)) . distl
	      
sum :: [Int] -> Int
sum = cata (bot::[Int]) f
    where f = (0!) \/ plus

prod :: [Int] -> Int
prod = cata (bot::[Int]) f
    where f = (1!) \/ mult

fprod :: [Int] -> Int -> Int
fprod = cata (bot::[Int]) f
    where f = (const id) \/ (comp . swap . (curry mult >< id))

downto :: Int -> [Int]
downto = ana (bot::[Int]) f
    where f = ((()!) -|- (id /\ pred)) . grd (==0)

myzip :: ([a],[b]) -> [(a,b)]
myzip = ana (bot::[(a,b)]) g
    where g = ((()!) -|- id) . coassocl . (id -|- (id -|- ((fst >< fst) /\ (snd >< snd))) . distr . (id >< out)) . distl . (out >< id)

mult :: (Int,Int) -> Int
mult = hylo (bot::[Int]) f g
    where g = (snd -|- (fst /\ id)) . distr . (id >< out)
	  f = (0!) \/ plus

fact :: Int -> Int
fact = hylo (bot::[Int]) f g
    where g = mapp (bot::Int) (id /\ id) . out
	  f = (1!) \/ (mult . (succ >< id))

part :: (Ord a) => (a,[a]) -> ([a],[a])  
part = hylo (bot::[(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)) . grd ((uncurry (>)) . fst))

bubble :: (Ord a) => [a] -> Either () (a,[a])
bubble = cata (bot::[a]) f
    where f = id -|- ((id >< ([]!)) \/ ((id >< cons) . assocr . (id \/ (swap >< id)) . grd (uncurry (<) . fst) . assocl)) . distr

bsort :: (Ord a) => [a] -> [a]
bsort = ana (bot::[a]) bubble

insert :: (Ord a) => (a,[a]) -> [a]
insert = apo (bot::[a]) f
    where f = ((Right . (id >< (Right . ([]!)))) \/ ((Right \/ Right) . (((id >< Left) . assocr . (swap >< id)) -|- ((id >< (Right . cons)) . assocr)) . grd (uncurry (>) . fst) . assocl)) . distr . (id >< out)

isort :: (Ord a) => [a] -> [a]
isort = cata (bot::[a]) (nil \/ insert)

isumsOp (l,x) = map (x+) l

isums :: [Int] -> [Int]
isums = cata (bot::[Int]) f
    where f = (cons . ((0!) /\ nil)) \/ (cons . ((0!) /\ isumsOp . swap))

aux (l,m) = m ++ map ((last m) +) l

i :: [Int] -> [Int]
i = cata (bot::[Int]) f
    where f = nil \/ aux . swap . (wrap >< id)

fi :: [Int] -> [Int] -> [Int]
fi = cata (bot::[Int]) f
    where f = (id!) \/ comp . swap . (curry aux . wrap >< id)

fisums :: [Int] -> Int -> [Int]
fisums = cata (bot::[Int]) f
    where f = (wrap!) \/ (fexp cons) . split' . ((id!) /\ comp . swap . (curry plus >< id))

isums' :: [Int] -> [Int]
isums' = cata (bot::[Int]) f
    where f = nil \/ isumsOp . swap . (id >< cons . ((0!) /\ id))

fisums'' :: [Int] -> Int -> [Int]
fisums'' = cata (bot::[Int]) f
    where f = (nil!) \/ comp . swap . (curry plus >< (fexp cons) . split' . ((id!) /\ id))

subsOp (r,l) = map (l++) r

subs :: Eq a => [a] -> [[a]]
subs = cata (bot::[a]) f
    where f = cons . (nil /\ nil) \/ (uncurry List.union) . (snd /\ subsOp . swap . (wrap >< id))

subsOp' (r,x) = map (x:) r

subs' :: Eq a => [a] -> [[a]]
subs' = cata (bot::[a]) f
    where f = cons . (nil /\ nil) \/ (uncurry List.union) . (snd /\ subsOp' . swap)

fsubs :: Eq a => [a] -> [a] -> [[a]]
fsubs = cata (bot::[a]) f
    where f = (wrap!) \/ (fexp (uncurry List.union)) . split' . (snd /\ (curry subsOp) . app . swap . (wrap >< id))

fsubs' :: Eq a => [a] -> [a] -> [[a]]
fsubs' = cata (bot::[a]) f
    where f = (wrap!) \/ (fexp (uncurry List.union)) . split' . (snd /\ comp . swap . ((curry snoc) >< id))

fsubs'' :: Eq a => [a] -> a -> [[a]]
fsubs'' = cata (bot::[a]) f
    where f = ((cons . (wrap /\ nil))!) \/ (fexp (uncurry List.union)) . split' . (snd /\ (curry subsOp') . app . swap)

mymap :: [a] -> (a -> b) -> [b]
mymap = cata (bot::[a]) f
    where f = (([]!)!) \/ (curry (cons . (app . swap >< app) . ((fst >< id) /\ (snd >< id))))

fisums' :: ([Int],Int) -> [Int]
fisums' = afold (bot::[Int]) t f
    where t = (fst -|- ((fst . fst) /\ ((snd . fst) /\ (plus . (fst >< id))))) . distl
	  f = ((wrap . snd) \/ (cons . swap . (snd >< id))) . distl

splitl :: [a] -> ([a],[a])
splitl = cata (bot::[a]) f
    where f = (nil /\ nil) \/ (swap . (cons >< id) . assocl)

cat' :: [a] -> [a] -> [a]
cat' = cata (bot::[a]) f
    where f = (id!) \/ (comp . (curry cons >< id))

accum' :: ((b, a) -> a) -> ([b], a) -> [a]
accum' o = ana (bot::[a]) g
    where g = (fst -|- (snd /\ (id >< o) . assocr . (swap >< id))) . distl . (out >< id)

--accum' :: ((b, a) -> a) -> ([b], a) -> [a]
--accum' op ([], b)   = []
--accum' op (x:xs, b) = b:(accum' op (xs, op (x, b)))

malcolm' :: ((b, a) -> a) -> a -> [b] -> [a]
malcolm' o e = map (cata (bot::[b]) ((e!) \/ o)) . accum' cons . (id /\ nil)

fmalcolm' :: ((b, a) -> a) -> a -> [b] -> [a]
fmalcolm' o e = accum' o . (id /\ (e!))

-- A + Id

{-
newtype FFrom a x = FFrom {unFFrom :: Either a x}

instance Functor (FFrom a)
    where fmap f = from . (id -|- f) . to

instance Iso (FFrom a x) (Either a x)
    where to = unFFrom
	  from = FFrom

type From a = Mu (FFrom a)
-}

{-
data From a = First a | Next (From a)

instance FunctorOf (Const a :+: Rec) (From a)
    where inn' (Inl (Const x)) = First x
	  inn' (Inr (Rec x)) = Next x
	  out' (First x) = Inl (Const x)
	  out' (Next x)  = Inr (Rec x)
-}

type From a = Mu (Const a :+: Rec)

plus :: (Int,Int) -> Int
plus = hylo (bot::From Int) f g
    where g = (snd -|- id) . distl . (out >< id)
	  f = id \/ succ

gt :: (Int,Int) -> Bool
gt = hylo (bot :: From Bool) f g
    where g = ((((False!) \/ (True!)) \/ (False!)) -|- id) . coassocl . (distl -|- distl) . distr . (out >< out)
	  f = id \/ id

-- A + B*Id

type NeList a b = Mu (Const a :+: (Const b :*: Rec))

cat :: ([a],[a]) -> [a]
cat = hylo (bot::NeList [a] a) f g
    where g = (snd -|- assocr) . distl . (out >< id)
	  f = id \/ cons

snoc :: (a,[a]) -> [a]
snoc = hylo (bot::NeList a a) f g
    where g = (fst -|- assocr . (swap >< id) . assocl) . distr . (id >< out)
	  f = wrap \/ cons

merge :: (Ord a) => ([a],[a]) -> [a]
merge = hylo (bot::NeList [a] a) f g
    where g = ((id \/ id) -|- ((id \/ id) . (assocr -|- (assocr . (swap >< id) . assocl)) . (id >< cons -|- cons >< id) . grd ((uncurry (<)) . (fst >< fst)))) . coassocl . (snd -|- (((cons . fst) -|- id) . distr . (id >< out))) . distl . (out >< id)
	  f = id \/ cons

-- 1 + A * (Id * Id)

data BTree a = Empty | Node a (BTree a) (BTree a) deriving Show

instance FunctorOf (Unit :+: (Const a :*: (Rec :*: Rec))) (BTree a)
    where inn' (Inl Unit) = Empty
	  inn' (Inr (Const x :*: (Rec l :*: Rec r))) = Node x l r
	  out' Empty = Inl Unit
	  out' (Node x l r) = Inr (Const x :*: (Rec l :*: Rec r))

nleaves :: BTree a -> Int
nleaves = cata (bot::BTree a) f
    where f = (1!) \/ (plus . snd)

nnodes :: BTree a -> Int
nnodes = cata (bot::BTree a) f
    where f = (0!) \/ (succ . plus . snd)

genBTree :: Int -> BTree Int
genBTree = ana (bot::BTree Int) f
    where f = ((()!) -|- (id /\ (pred /\ pred))) . grd (==0)

qsort :: (Ord a) => [a] -> [a]
qsort = hylo (bot::BTree a) f g
    where g = (id -|- (fst /\ part)) . out
	  f = nil \/ (cat . (snoc >< id) . assocl)

postBTree :: BTree a -> [a]
postBTree = cata (bot::BTree a) f
    where f = ([]!) \/ (cat . swap . (wrap >< cat))

fpostBTree :: BTree a -> [a] -> [a]
fpostBTree = cata (bot::BTree a) f
    where f = (id!) \/ (comp . swap . (curry cons >< comp))

-- A + Id * Id

data LTree a = Leaf a | Branch (LTree a) (LTree a)

instance FunctorOf (Const a :+: (Rec :*: Rec)) (LTree a)
    where inn' (Inl (Const x)) = Leaf x
	  inn' (Inr (Rec l :*: Rec r)) = Branch l r
	  out' (Leaf x) = Inl (Const x)
	  out' (Branch l r) = Inr (Rec l :*: Rec r)

leaves :: LTree a -> [a]
leaves = cata (bot::LTree a) f
    where f = wrap \/ cat

fleaves :: LTree a -> [a] -> [a]
fleaves = cata (bot::LTree a) f
    where f = (curry cons) \/ comp

genLTree :: Int -> LTree Int
genLTree = ana (bot::LTree Int) f
    where f = (id -|- (pred /\ pred)) . grd (==0)

height :: LTree a -> Int
height = cata (bot::LTree a) f
    where f = (0!) \/ (succ . (uncurry max)) 

fheight'' :: LTree a -> (Int,Int) -> Int
fheight'' = cata (bot::LTree a) f
    where f = ((uncurry max)!) \/ comp . (id >< curry ((fst . snd /\ app) . (id >< (succ >< id))))

split' = curry ((app >< app) . ((fst >< id) /\ (snd >< id)))

fheight' :: LTree a -> Int -> Int
fheight' = cata (bot::LTree a) f
    where f = (id!) \/ (curry (app . (id >< succ))) . (fexp (uncurry max) . split')

fexp' = curry (comp . swap)

fheight :: LTree a -> Int -> Int -> Int
fheight = cata (bot::LTree a) f
    where f = (max!) \/ (curry (app . (id >< succ))) . fexp comp . split'

-- 1 + Id * Id

type STree = Mu (Unit :+: (Rec :*: Rec))

fib :: Int -> Int
fib = hylo (bot::STree) f g
    where g = ((id \/ id) -|- (id /\ succ)) . coassocl . (id -|- out) . out
	  f = (1!) \/ plus

-- (1 + A) + Id * Id

msort :: (Ord a) => [a] -> [a]
msort = hylo (bot::Mu ((Unit :+: Const a) :+: (Rec :*: Rec))) f g
    where g = coassocl . (id -|- ((fst -|- (splitl . cons)) . grd (null . snd))) . out 
	  f = (nil \/ wrap) \/ merge

-- A * [Id]

data Rose a = Rose a [Rose a]

instance FunctorOf (Const a :*: ([] :@: Rec)) (Rose a)
    where inn' ((Const x) :*: (Comp l)) = Rose x (map unRec l)
	  out' (Rose x l) = (Const x) :*: (Comp (map Rec l)) 

rnodes :: Rose a -> [a]
rnodes = cata (bot::Rose a) f
    where f :: (a,[[a]]) -> [a]
          f = cons . (id >< concat)

genRose :: Int -> Rose Int
genRose = ana (bot::Rose Int) f
    where f = ((id /\ ([]!)) \/ (id /\ downto . pred)) . grd (==0)

postRose :: Rose a -> [a]
postRose = cata (bot::Rose a) f
    where f = cat . swap . (wrap >< cata (bot::[[a]]) (nil \/ cat))

fpostRose :: Rose a -> [a] -> [a]
fpostRose = cata (bot::Rose a) f
    where f = comp . swap . (curry cons >< cata (bot::[[a]->[a]]) ((id!) \/ comp))