1 -----------------------------------------------------------------------------
3 -- Module : Generics.Pointless.Examples.Examples
4 -- Copyright : (c) 2008 University of Minho
7 -- Maintainer : hpacheco@di.uminho.pt
8 -- Stability : experimental
9 -- Portability : non-portable
12 -- point-free programming with recursion patterns as hylomorphisms
14 -- This module provides examples, examples and more examples.
16 -----------------------------------------------------------------------------
18 module Generics.Pointless.Examples.Examples where
20 import Generics.Pointless.Combinators
21 import Generics.Pointless.Functors
22 import Generics.Pointless.RecursionPatterns
23 import Prelude hiding (Functor(..),filter,concat,tail,length)
24 import Data.List hiding (filter,concat,tail,length,partition)
33 -- | Pre-defined algebraic addition.
34 add :: (Int,Int) -> Int
37 -- | Definition of algebraic addition as an anamorphism in the point-wise style.
38 addAnaPW :: (Int,Int) -> Int
39 addAnaPW = ana (_L::Int) h
40 where h (0,0) = Left _L
41 h (n,0) = Right (n-1,0)
42 h (0,n) = Right (0,n-1)
43 h (n,m) = Right (n,m-1)
45 -- | Defition of algebraic addition as an anamorphism.
46 addAna :: (Int,Int) -> Int
47 addAna = ana (_L::Int) f
48 where f = (bang -|- (id >< zero \/ (zero >< id \/ succ >< id))) . aux . (out >< out)
49 aux = coassocr . (distl -|- distl) . distr
51 -- | The fixpoint of the functor that is either a constant or defined recursively.
52 type From a = K a :+!: I
54 -- | Definition of algebraic addition as an hylomorphism.
55 addHylo :: (Int,Int) -> Int
56 addHylo = hylo (_L::From Int) f g
58 g = (snd -|- id) . distl . (out >< id)
60 -- | Definition of algebraic addition as an accumulation.
61 addAccum :: (Int,Int) -> Int
62 addAccum = accum (_L::Int) t f
63 where t = (fst -|- id >< succ) . distl
64 f = (snd \/ fst) . distl
66 -- | Definition of algebraic addition as an apomorphism.
67 addApo :: (Int,Int) -> Int
68 addApo = apo (_L::Int) h
69 where h = (id -|- coswap) . coassocr . (fst -|- inn >< id) . distr . (out >< out)
73 -- | Pre-defined algebraic product.
74 prod :: (Int,Int) -> Int
77 -- | Definition of algebraic product as an hylomorphism
78 prodHylo :: (Int,Int) -> Int
79 prodHylo = hylo (_L::[Int]) f g
81 g = (snd -|- fst /\ id) . distr . (id >< out)
83 -- ** 'Greater than' comparison
85 -- | Pre-defined 'greater than' comparison.
86 gt :: Ord a => (a,a) -> Bool
89 -- | Definition of 'greater than' as an hylomorphism.
90 gtHylo :: (Int,Int) -> Bool
91 gtHylo = hylo (_L :: From Bool) f g
92 where g = ((((False!) \/ (True!)) \/ (False!)) -|- id) . coassocl . (distl -|- distl) . distr . (out >< out)
97 -- | Native recursive definition of the factorial function.
100 fact n = n * fact (n-1)
102 -- | Recursive definition of the factorial function in the point-free style.
104 factPF = ((1!) \/ prod) .
105 (id -|- id >< factPF) .
106 (id -|- id /\ pred) . (iszero?)
109 -- | Recursive definition of the factorial function in the point-free style with structural recursion.
110 factPF' :: Int -> Int
111 factPF' = (one \/ prod) . (id -|- id >< factPF') . (id -|- succ /\ id) . out
113 -- | Definition of the factorial function as an hylomorphism.
114 factHylo :: Int -> Int
115 factHylo = hylo (_L :: [Int]) f g
116 where g = (id -|- succ /\ id) . out
119 -- | Definition of the factorial function as a paramorphism.
120 factPara :: Int -> Int
121 factPara = para (_L::Int) f
122 where f = one \/ (prod . (id >< succ))
124 -- | Definition of the factorial function as a zygomorphism.
125 factZygo :: Int -> Int
126 factZygo = zygo (_L::Int) inn f
127 where f = one \/ (prod . (id >< succ))
131 -- | Native recursive definition of the fibonacci function.
135 fib n = fib (n-1) + fib (n-2)
137 -- | Recursive definition of the fibonacci function in the point-free style.
139 fibPF = (zero \/ (one \/ add)) . (bang -|- (bang -|- fibPF >< fibPF)) . (id -|- aux) . ((==0)?)
140 where aux = (id -|- pred /\ pred . pred) . ((==1)?)
142 -- | Recursive definition of the fibonacci function in the point-free style with structural recursion.
144 fibPF' = (zero \/ (one \/ add)) . (id -|- (id -|- fibPF' >< fibPF')) . (id -|- aux) . out
145 where aux = (id -|- succ /\ id) . out
147 -- | The fixpoint of the functor for a binary shape tree.
148 type BSTree = K One :+!: (K One :+!: I :*!: I)
150 -- | Definition of the fibonacci function as an hylomorphism.
151 fibHylo :: Int -> Int
152 fibHylo = hylo (_L :: BSTree) f g
153 where f = zero \/ (one \/ add)
154 g = (id -|- ((id -|- succ /\ id) . out)) . out
157 -- | Definition of the fibonacci function as an histomorphism.
158 fibHisto :: Int -> Int
159 fibHisto = histo (_L::Int) f
160 where f = (zero \/ (one . snd \/ add . (id >< outl)) . distr . out)
162 -- | Definition of the fibonacci function as a dynamorphism.
163 fibDyna :: Int -> Int
164 fibDyna = dyna (_L::Int) f g
165 where f = (zero \/ (one . snd \/ add . (id >< outl)) . distr . out)
168 -- ** Binary Partitioning
170 -- | Native recursive definition for the binary partitions of a number.
172 -- The number of binary partitions for a number n is the number of unique ways to partition
173 -- this number (ignoring the order) into powers of 2.
174 -- | Definition of the binary partitioning of a number as an hylomorphism.
177 bp n = if odd n then bp (n-1) else bp (n-1) + bp (div n 2)
179 -- | The fixpoint of the functor representing trees with maximal branching factor of two.
180 type BTree = K One :+!: (I :+!: (I :*!: I))
182 -- | Definition of the binary partitioning of a number as an hylomorphism.
184 bpHylo = hylo (_L :: BTree) g h
185 where g = one \/ (id \/ add)
186 h = (id -|- h') . out
187 h' = (id -|- id /\ (`div` 2) . succ) . (even?)
189 -- | Definition of the binary partitioning of a number as a dynamorphism.
191 bpDyna = dyna (_L :: [Int]) (g . o) h
192 where g = one \/ (id \/ add)
194 oj = (o1 -|- o2) . ((odd . fst)?)
196 o2 = outl . snd /\ (outl . oi)
197 oi = uncurry pi . ((pred . (`div` 2)) >< id)
198 h = (id -|- succ /\ id) . out
200 pi k x = case outr x of
201 Right (_,y) -> pi (pred k) y
205 -- | Recursive definition of the average of a set of integers.
206 average :: [Int] -> Int
207 average = uncurry div . (sum /\ length)
209 -- | Definition of the average of a set of integers as a catamorphism.
210 averageCata :: [Int] -> Int
211 averageCata = uncurry div . cata (_L::[Int]) f
212 where f = (zero \/ add . (id >< fst)) /\ (zero \/ succ . snd . snd)
216 -- ** Singleton list.
218 -- | Pre-defined wrapping of an element into a list.
222 -- | Definition of wrapping in the point-free style.
224 wrapPF = cons . (id /\ nil . bang)
228 -- | Definition of the tail of a list as a total function.
233 -- | Definition of the tail of a list in the point-free style.
235 tailPF = (([]!) \/ snd) . out
237 -- | Definition of the tail of a list as an anamorphism.
238 tailCata :: [a] -> [a]
239 tailCata = fst . cata (_L::[a]) (f /\ inn . (id -|- id >< snd))
240 where f = ([]!) \/ snd . snd
242 -- | Definition of the tail of a list as a paramorphism.
243 tailPara :: [a] -> [a]
244 tailPara = para (_L::[a]) f
245 where f = ([]!) \/ snd . snd
249 -- | Native recursion definition of list length.
252 length (x:xs) = succ (length xs)
254 -- | Recursive definition of list length in the point-free style.
255 lengthPF :: [a] -> Int
256 lengthPF = (zero . bang \/ succ . lengthPF . tail) . (null?)
258 -- | Recursive definition of list length in the point-free style with structural recursion.
259 lengthPF' :: [a] -> Int
260 lengthPF' = inn . (id -|- (lengthPF' . snd)) . out
262 -- | Definition of list length as an hylomorphism.
263 lengthHylo :: [a] -> Int
264 lengthHylo = hylo (_L::Int) f g
266 g = (id -|- snd) . out
268 -- | Definition of list length as an anamorphism.
269 lengthAna :: [a] -> Int
271 where f = (id -|- snd) . out
273 -- | Definition of list length as a catamorphism.
274 lengthCata :: [a] -> Int
275 lengthCata = cata _L f
276 where f = zero \/ succ . snd
280 -- | Native recursive definition of list filtering.
281 filter :: (a -> Bool) -> [a] -> [a]
283 filter p (x:xs) = if p x then x : filter p xs else filter p xs
285 -- | Definition of list filtering as an catamorphism.
286 filterCata :: (a -> Bool) -> [a] -> [a]
287 filterCata p = cata (_L::[a]) f
288 where f = (nil \/ (cons \/ snd)) . (id -|- ((p . fst)?))
292 -- | Generation of infinite lists as an anamorphism.
293 repeatAna :: a -> [a]
294 repeatAna = ana (_L::[a]) (inr . (id /\ id))
296 -- | Finite replication of an element as an anamorphism.
297 replicateAna :: (Int,a) -> [a]
298 replicateAna = ana (_L::[a]) h
299 where h = (bang -|- snd /\ id) . distl . (out >< id)
301 -- | Generation of a downwards list as an anamorphism.
302 downtoAna :: Int -> [Int]
304 where f = (bang -|- (id /\ pred)) . ((==0) ?)
306 -- | Ordered list insertion as an apomorphism.
307 insertApo :: Ord a => (a,[a]) -> [a]
308 insertApo = apo (_L::[a]) f
309 where f = inr. undistr . (inr \/ (inr \/ inl)) . ((id >< nil) -|- ((id >< cons) . assocr -|- assocr . (swap >< id)) . distl . ((le?) >< id) . assocl) . distr . (id >< out)
312 -- | Ordered list insertion as a paramorphism.
313 insertPara :: Ord a => (a,[a]) -> [a]
314 insertPara (x,l) = para (_L::[a]) f l
315 where f = wrap . (x!) \/ ((x:) . cons . (id >< snd) \/ cons . (id >< fst)) . (((x <=) . fst)?)
317 -- | Append an element to the end of a list as an hylomorphism.
318 snoc :: (a,[a]) -> [a]
319 snoc = hylo (_L::NeList a a) f g
320 where g = (fst -|- assocr . (swap >< id) . assocl) . distr . (id >< out)
323 -- | Append an element to the end of a list as an apomorphism.
324 snocApo :: (a,[a]) -> [a]
325 snocApo = apo (_L::[a]) h
326 where h = inr . undistr . coswap . (id >< nil -|- assocr . (swap >< id) . assocl) . distr . (id >< out)
330 -- | Creates a bubble from a list. Used in the bubble sort algorithm.
331 bubble :: (Ord a) => [a] -> Either One (a,[a])
332 bubble = cata (_L::[a]) f
333 where f = id -|- ((id >< ([]!)) \/ ((id >< cons) . assocr . (id \/ (swap >< id)) . ((uncurry (<) . fst) ?) . assocl)) . distr
335 -- | Extraction of a number of elements from a list as an anamorphism.
336 takeAna :: (Int,[a]) -> [a]
337 takeAna = ana (_L::[a]) h
338 where h = (bang -|- assocr . (swap >< id) . assocl) . aux . (out >< out)
339 aux = coassocl . (distl -|- distl) . distr
343 -- | Native recursive definition for partitioning a list at a specified element.
344 partition :: Ord a => (a,[a]) -> ([a],[a])
345 partition (a,xs) = foldr (select a) ([],[]) xs
346 where select :: Ord a => a -> a -> ([a], [a]) -> ([a], [a])
347 select a x (ts,fs) = if a > x then (x:ts,fs) else (ts, x:fs)
349 -- | Definition for partitioning a list at a specified element as an hylomorphism.
350 partitionHylo :: (Ord a) => (a,[a]) -> ([a],[a])
351 partitionHylo = hylo (_L::[(a,a)]) f g
352 where g = (snd -|- ((id >< fst) /\ (id >< snd))) . distr . (id >< out)
353 f = (nil /\ nil) \/ (((cons >< id) . assocl . (snd >< id) \/ (id >< cons) . ((fst . snd) /\ (id >< snd)) . (snd >< id)) . ((gt . fst)?))
355 -- ** Transformations
357 -- | Incremental summation as a catamorphism.
358 isum :: [Int] -> [Int]
359 isum = cata (_L::[Int]) f
360 where f = nil \/ isumOp . swap . (id >< cons . (zero . bang /\ id))
361 isumOp (l,x) = map (x+) l
363 -- | Incrementation the elements of a list by a specified value a catamorphism.
364 fisum :: [Int] -> Int -> [Int]
365 fisum = cata (_L::[Int]) f
366 where f = pnt (nil . bang) \/ comp . swap . (curry add >< (cons .) . split . (pnt id . bang /\ id))
368 -- | Definition of list mapping as a catamorphism.
369 mapCata :: [a] -> (a -> b) -> [b]
370 mapCata = cata (_L::[a]) f
371 where f = (([]!)!) \/ curry (cons . (app . swap >< app) . ((fst >< id) /\ (snd >< id)))
373 -- | Definition of list reversion as a catamorphism.
374 reverseAna :: [a] -> [a]
375 reverseAna = cata (_L::[a]) f
376 where f = nil \/ (cat . swap . (wrap >< id))
378 -- | Definition of the quicksort algorithm as an hylomorphism.
379 qsort :: (Ord a) => [a] -> [a]
380 qsort = hylo (_L::Tree a) f g
381 where g = (id -|- (fst /\ partition)) . out
382 f = nil \/ (cat . (id >< cons) . assocr . (swap >< id) . assocl)
384 -- | Definition of the bubble sort algorithm as an anamorphism.
385 bsort :: (Ord a) => [a] -> [a]
386 bsort = ana (_L::[a]) bubble
387 -- | Definition of the insertion sort algorithm as a catamorphism.
388 isort :: (Ord a) => [a] -> [a]
389 isort = cata (_L::[a]) (nil \/ insertApo)
391 -- Auxiliary split function for the merge sort algorithm.
392 msplit :: [a] -> ([a],[a])
393 msplit = cata (_L::[a]) f
394 where f = (nil /\ nil) \/ (swap . (cons >< id) . assocl)
396 -- Definition of the merge sort algorithm as an hylomorphism.
397 msort :: (Ord a) => [a] -> [a]
398 msort = hylo (_L::(K One :+!: K a) :+!: (I :*!: I)) f g
399 where g = coassocl . (id -|- (fst -|- msplit . cons) . ((null . snd)?)) . out
400 f = (([]!) \/ wrap) \/ merge
402 -- | Definition of the heap sort algorithm as an hylomorphism.
403 hsort :: (Ord a) => [a] -> [a]
405 where f = _L ::(K One :+!: K a) :+!: (K a :*!: (I :*!: I))
406 h = coassocl . (id -|- (fst -|- hsplit . cons) . ((null . snd)?)) . out
407 g = (([]!) \/ wrap) \/ cons . (id >< merge)
409 -- Auxiliary split function for the heap sort algorithm.
410 hsplit :: (Ord a) => [a] -> (a,([a],[a]))
411 hsplit [x] = (x,([],[]))
412 hsplit (h:t) | h < m = (h,(m:l,r))
413 | otherwise = (m,(h:r,l))
414 where (m,(l,r)) = hsplit t
416 -- | Malcolm downwards accumulations on lists.
417 malcolm :: ((b, a) -> a) -> a -> [b] -> [a]
418 malcolm o e = map (cata (_L::[b]) ((e!) \/ o)) . malcolmAna' cons . (id /\ nil . bang)
420 -- | Malcom downwards accumulations on lists as an anamorphism.
421 malcolmAna :: ((b, a) -> a) -> a -> [b] -> [a]
422 malcolmAna o e = malcolmAna' o . (id /\ (e!))
424 -- | Uncurried version of Malcom downwards accumulations on lists as an anamorphism.
425 malcolmAna' :: ((b, a) -> a) -> ([b], a) -> [a]
426 malcolmAna' o = ana (_L::[a]) g
427 where g = (fst -|- (snd /\ (id >< o) . assocr . (swap >< id))) . distl . (out >< id)
431 -- | Definition of the zip for lists of pairs as an anamorphism.
432 zipAna :: ([a],[b]) -> [(a,b)]
433 zipAna = ana (_L::[(a,b)]) f
434 where f = (bang -|- ((fst >< fst) /\ (snd >< snd))) . aux . (out >< out)
435 aux = coassocl . (distl -|- distl) . distr
439 -- | Definition of the subsequences of a list as a catamorphism.
440 subsequences :: Eq a => [a] -> [[a]]
441 subsequences = cata (_L::[a]) f
442 where f = cons . (nil /\ nil) \/ uncurry union . (snd /\ subsOp . swap . (wrap >< id))
443 subsOp (r,l) = map (l++) r
447 -- | Pre-defined list concatenation.
448 cat :: ([a],[a]) -> [a]
451 -- | List concatenation as a catamorphism.
452 catCata :: [a] -> [a] -> [a]
453 catCata = cata (_L::[a]) f
454 where f = (id!) \/ (comp . (curry cons >< id))
456 -- | The fixpoint of the list functor with a specific terminal element.
457 type NeList a b = K a :+!: (K b :*!: I)
459 -- | List concatenation as an hylomorphism.
460 catHylo :: ([a],[a]) -> [a]
461 catHylo = hylo (_L::NeList [a] a) f g
462 where g = (snd -|- assocr) . distl . (out >< id)
465 -- | Native recursive definition of lists-of-lists concatenation.
466 concat :: [[a]] -> [a]
468 concat (l:ls) = l ++ concat ls
470 -- | Definition of lists-of-lists concatenation as an anamorphism.
471 concatCata :: [[a]] -> [a]
472 concatCata = cata (_L::[[a]]) g
473 where g = ([]!) \/ cat
475 -- | Sorted concatenation of two lists as an hylomorphism.
476 merge :: (Ord a) => ([a],[a]) -> [a]
477 merge = hylo (_L::NeList [a] a) f g
478 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)
483 -- | Definition of inter addition as a catamorphism.
484 sumCata :: [Int] -> Int
485 sumCata = cata (_L::[Int]) f
486 where f = (0!) \/ add
490 -- | Native recursive definition of integer multiplication.
493 mult (x:xs) = x * mult xs
495 -- | Definition of integer multiplication as a catamorphism.
496 multCata :: [Int] -> Int
498 where f = (1!) \/ prod
502 -- Test if a list is sorted as a paramorphism.
503 sorted :: (Ord a) => [a] -> Bool
504 sorted = para (_L::[a]) f
505 where f = true \/ uncurry (&&) . ((true . bang \/ uncurry (<=) . (id >< head)) . ((null . snd)?) >< id) . assocl . (id >< swap)
509 -- | Native recursive definition of the edit distance algorithm.
511 -- Edit distance is a classical dynamic programming algorithm that calculates
512 -- a measure of âdistanceâ or âdiï¬erenceâ between lists with comparable elements.
513 editdist :: Eq a => ([a],[a]) -> Int
514 editdist ([],bs) = length bs
515 editdist (as,[]) = length as
516 editdist (a:as,b:bs) = minimum [m1,m2,m3]
517 where m1 = editdist (as,b:bs) + 1
518 m2 = editdist (a:as,bs) + 1
519 m3 = editdist (as,bs) + (if a==b then 0 else 1)
521 -- | The fixpoint of the functor that represents a virtual matrix used to accumulate and look up values for the edit distance algorithm.
523 -- Since matrixes are not inductive types, a walk-through of a matrix is used, consisting in a list of values from the matrix ordered predictability.
525 -- For a more detailed explanation, please refer to <http://math.ut.ee/~eugene/kabanov-vene-mpc-06.pdf>.
526 type EditDist a = K [a] :+!: ((K a :*!: K a) :*!: I :*!: I :*!: I)
527 type EditDistL a = (K [a] :*!: K [a]) :*!: (K One :+!: I)
529 -- | The edit distance algorithm as an hylomorphism.
530 editdistHylo :: Eq a => ([a],[a]) -> Int
531 editdistHylo (x::([a],[a])) = hylo (_L::EditDist a) g h x
532 where g :: Eq a => F (EditDist a) Int -> Int
534 g' ((a,b),(x1,(x2,x3))) = min m1 (min m2 m3)
537 m3 = add (x3,if a==b then 0 else 1)
540 h (a:as,b:bs) = Right ((a,b),((as,b:bs),((a:as,bs),(as,bs))))
542 -- | The edit distance algorithm as a dynamorphism.
543 editDistDyna :: Eq a => ([a],[a]) -> Int
544 editDistDyna (l1::[a],l2) = dyna (_L :: EditDistL a) (g . o (length l1)) (h l1) (l1,l2)
545 where g :: Eq a => F (EditDist a) Int -> Int
547 g' ((a,b),(x1,(x2,x3))) = min m1 (min m2 m3)
550 m3 = add (x3,if a==b then 0 else 1)
551 o :: Int -> F (EditDistL a) (Histo (EditDistL a) Int) -> F (EditDist a) Int
552 o n ((as,bs),Left _) = Left []
553 o n (([],bs),Right x) = Left bs
554 o n ((as,[]),Right x) = Left as
555 o n ((a:as,b:bs),Right x) = Right ((a,b),(j x,(j (pi n x),j (pi (succ n) x))))
556 h :: [a] -> ([a],[a]) -> F (EditDistL a) ([a],[a])
557 h cs ([],[]) = (([],[]),Left _L)
558 h cs ([],b:bs) = (([],b:bs),Right (cs,bs))
559 h cs (a:as,bs) = ((a:as,bs),Right (as,bs))
560 pi :: Int -> Histo (EditDistL a) Int -> Histo (EditDistL a) Int
562 pi k x = case outr x of
563 (_,Right y) -> pi (pred k) y
568 -- | The fixpoint of the functor of streams.
569 type Stream a = K a :*!: I
572 headS :: Stream a -> a
576 tailS :: Stream a -> Stream a
579 -- | Definition of a stream sequence generator as an anamorphism.
580 generate :: Int -> Stream Int
581 generate = ana (_L::Stream Int) (id /\ succ)
583 -- | Identity o streams as an anamorphism.
584 idStream :: Stream a -> Stream a
585 idStream = ana (_L::Stream a) out
587 -- | Mapping over streams as an anamorphism.
588 mapStream :: (a -> b) -> Stream a -> Stream b
589 mapStream f = ana (_L::Stream b) g
590 where g = (f >< id) . out
592 -- | Malcolm downwards accumulations on streams.
593 malcolmS :: ((b,a) -> a) -> a -> Stream b -> Stream a
594 malcolmS o e = mapStream (cata (_L::[b]) ((e!) \/ o)) . malcolmSAna' cons . (id /\ nil . bang)
596 -- | Malcom downwards accumulations on streams as an anamorphism.
597 malcolmSAna :: ((b,a) -> a) -> a -> Stream b -> Stream a
598 malcolmSAna o e = malcolmSAna' o . (id /\ (e!))
600 -- | Uncurried version of Malcom downwards accumulations on streams as an anamorphism.
601 malcolmSAna' :: ((b,a) -> a) -> (Stream b, a) -> Stream a
602 malcolmSAna' o = ana (_L::Stream a) g
603 where g = snd /\ swap . (o >< id) . assocl . (id >< swap) . assocr . (out >< id)
605 -- | Promotes streams elements to streams of singleton elements.
606 inits :: Stream a -> Stream [a]
607 inits = malcolmSAna' cons . (id /\ nil . bang)
609 -- | Definition of parwise exchange on streams as a futumorphism.
610 exchFutu :: Stream a -> Stream a
611 exchFutu = futu (_L::Stream a) (f /\ (g . (h /\ i)))
612 where f = headS . tailS
615 i = innl . tailS . tailS
619 -- | Datatype declaration of a binary tree.
620 data Tree a = Empty | Node a (Tree a) (Tree a) deriving Show
622 -- | The functor of a binary tree.
623 type instance PF (Tree a) = Const One :+: (Const a :*: (Id :*: Id))
625 instance Mu (Tree a) where
627 inn (Right (a,(b,c))) = Node a b c
629 out (Node a b c) = Right (a,(b,c))
631 -- | Counting the number of leaves in a binary tree as a catamorphism.
632 nleaves :: Tree a -> Int
633 nleaves = cata (_L::Tree a) f
634 where f = (1!) \/ (add . snd)
636 -- | Counting the number of nodes in a binary tree as a catamorphism.
637 nnodes :: Tree a -> Int
638 nnodes = cata (_L::Tree a) f
639 where f = (0!) \/ (succ . add . snd)
641 -- | Generation of a binary tree with a specified height as an anamorphism.
642 genTree :: Int -> Tree Int
643 genTree = ana (_L::Tree Int) f
644 where f = (bang -|- (id /\ (pred /\ pred))) . ((==0)?)
646 -- | The preorder traversal on binary trees as a catamorphism.
647 preTree :: Tree a -> [a]
648 preTree = cata (_L::Tree a) f
649 where f = ([]!) \/ (cons . (id >< cat))
651 -- | The postorder traversal on binary trees as a catamorphism.
652 postTree :: Tree a -> [a]
653 postTree = cata (_L::Tree a) f
654 where f = ([]!) \/ (cat . swap . (wrap >< cat))
658 -- | Datatype declaration of a leaf tree.
659 data LTree a = Leaf a | Branch (LTree a) (LTree a)
661 -- | The functor of a leaf tree.
662 type instance PF (LTree a) = Const a :+: (Id :*: Id)
664 instance Mu (LTree a) where
665 inn (Left x) = Leaf x
666 inn (Right (x,y)) = Branch x y
667 out (Leaf x) = Left x
668 out (Branch x y) = Right (x,y)
670 -- | Extract the leaves of a leaf tree as a catamorphism.
671 leaves :: LTree a -> [a]
672 leaves = cata (_L::LTree a) f
673 where f = wrap \/ cat
675 -- | Generation of a leaft tree of a specified height as an anamorphism.
676 genLTree :: Int -> LTree Int
677 genLTree = ana (_L::LTree Int) f
678 where f = ((0!) -|- (id /\ id)) . out
680 -- | Calculate the height of a leaf tree as a catamorphism.
681 height :: LTree a -> Int
682 height = cata (_L::LTree a) f
683 where f = (0!) \/ (succ . uncurry max)
687 -- | Datatype declaration of a rose tree.
688 data Rose a = Forest a [Rose a] deriving Show
690 -- | The functor of a rose tree.
691 type instance PF (Rose a) = Const a :*: ([] :@: Id)
693 instance Mu (Rose a) where
694 inn (a,l) = Forest a l
695 out (Forest a l) = (a,l)
697 -- The preorder traversal on rose trees as a catamorphism.
698 preRose :: Rose a -> [a]
699 preRose = cata (_L::Rose a) f
700 where f = (cons . (id >< concat))
702 -- | The postorder traversal on rose trees as a catamorphism.
703 postRose :: Rose a -> [a]
704 postRose = cata (_L::Rose a) f
705 where f = cat . swap . (wrap >< cata (_L::[[a]]) (nil \/ cat))
707 -- | Generation of a rose tree of a specified height as an anamorphism.
708 genRose :: Int -> Rose Int
709 genRose = ana (_L::Rose Int) f
710 where f = ((id /\ ([]!)) \/ (id /\ downtoAna . pred)) . ((==0)?)