{-# OPTIONS_GHC -XNPlusKPatterns #-} -- (c) MP-I (1998/9-2006/7) and CP (2005/6-2014/5) module BTree where import Cp import Data.List import Data.Monoid -- (1) Datatype definition ----------------------------------------------------- data BTree a = Empty | Node(a, (BTree a, BTree a)) deriving Show inBTree :: Either () (b,(BTree b,BTree b)) -> BTree b inBTree = either (const Empty) Node outBTree :: BTree a -> Either () (a,(BTree a,BTree a)) outBTree Empty = Left () outBTree (Node (a,(t1,t2))) = Right(a,(t1,t2)) -- (2) Ana + cata + hylo ------------------------------------------------------- recBTree g = id -|- (id >< (g >< g)) cataBTree g = g . (recBTree (cataBTree g)) . outBTree anaBTree g = inBTree . (recBTree (anaBTree g) ) . g hyloBTree h g = cataBTree h . anaBTree g baseBTree f g = id -|- (f >< (g >< g)) -- recBTree f = baseBTree id f -- (3) Map --------------------------------------------------------------------- instance Functor BTree where fmap f = cataBTree ( inBTree . baseBTree f id ) -- equivalent to: -- where fmap f = anaBTree ( baseBTree f id . outBTree ) -- (4) Examples ---------------------------------------------------------------- -- (4.1) Inversion (mirror) ---------------------------------------------------- invBTree = cataBTree (inBTree . (id -|- id >< swap)) -- (4.2) Counting -------------------------------------------------------------- countBTree = cataBTree (either (const 0) (succ . (uncurry (+)) . p2)) -- (4.3) Serialization --------------------------------------------------------- inordt = cataBTree inord -- in-order traversal -- where inord = either (const []) join where join(x,(l,r))=l++[x]++r preordt = cataBTree (either (const []) f) -- pre-order traversal where f(x,(l,r))=x:l++r postordt = cataBTree (either (const []) f) -- post-order traversal where f(x,(l,r))=l++r++[x] -- (4.4) Quicksort ------------------------------------------------------------- qSort :: Ord a => [a] -> [a] qSort = hyloBTree inord qsep -- the same as (cataBTree inord) . (anaBTree qsep) -- where qsep [] = Left () qsep (h:t) = Right (h,(s,l)) where (s,l) = part ( Bool) -> [a] -> ([a], [a]) part p [] = ([],[]) part p (h:t) | p h = let (s,l) = part p t in (h:s,l) | otherwise = let (s,l) = part p t in (s,h:l) {-- pointwise versions: qSort [] = [] qSort (h:t) = let (t1,t2) = part (= h ] --} -- (4.5) Traces ---------------------------------------------------------------- traces :: Eq a => BTree a -> [[a]] traces = cataBTree (either (const [[]]) tunion) -- where tunion(a,(l,r)) = union (map (a:) l) (map (a:) r) -- (4.6) Towers of Hanoi ------------------------------------------------------- -- pointwise: -- hanoi(d,0) = [] -- hanoi(d,n+1) = (hanoi (not d,n)) ++ [(n,d)] ++ (hanoi (not d, n)) hanoi = hyloBTree present strategy --- where present = inord -- same as in qSort strategy(d,0) = Left () strategy(d,n+1) = Right ((n,d),((not d,n),(not d,n))) {-- The Towers of Hanoi problem comes from a puzzle marketed in 1883 by the French mathematician Édouard Lucas, under the pseudonym Claus. The puzzle is based on a legend according to which there is a temple, apparently in Bramah rather than in Hanoi as one might expect, where there are three giant poles fixed in the ground. On the first of these poles, at the time of the world's creation, God placed sixty four golden disks, each of different size, in decreasing order of size. The Bramin monks were given the task of moving the disks, one per day, from one pole to another subject to the rule that no disk may ever be above a smaller disk. The monks' task would be complete when they had succeeded in moving all the disks from the first of the poles to the second and, on the day that they completed their task the world would come to an end! There is a well­known inductive solution to the problem given by the pseudocode below. In this solution we make use of the fact that the given problem is symmetrical with respect to all three poles. Thus it is undesirable to name the individual poles. Instead we visualize the poles as being arranged in a circle; the problem is to move the tower of disks from one pole to the next pole in a specified direction around the circle. The code defines H n d to be a sequence of pairs (k,d') where n is the number of disks, k is a disk number and d and d' are directions. Disks are numbered from 0 onwards, disk 0 being the smallest. (Assigning number 0 to the smallest rather than the largest disk has the advantage that the number of the disk that is moved on any day is independent of the total number of disks to be moved.) Directions are boolean values, true representing a clockwise movement and false an anti­clockwise movement. The pair (k,d') means move the disk numbered k from its current position in the direction d'. The semicolon operator concatenates sequences together, [] denotes an empty sequence and [x] is a sequence with exactly one element x. Taking the pairs in order from left to right, the complete sequence H n d prescribes how to move the n smallest disks one­by­one from one pole to the next pole in the direction d following the rule of never placing a larger disk on top of a smaller disk. H 0 d = [], H (n+1) d = H n ¬d ; [ (n, d) ] ; H n ¬d. (excerpt from R. Backhouse, M. Fokkinga / Information Processing Letters 77 (2001) 71--76) --} -- (5) Depth and balancing (using mutual recursion) -------------------------- balBTree = p1.baldepth depthBTree = p2.baldepth baldepth = cataBTree g where g = either (const(True,1)) (h.(id> (a -> c) -> Either () (a,(c, c)) -> c tnat f = either (const mempty) (theta . (f >< theta)) where theta = uncurry mappend -- monoid reduction monBTree f = cataBTree (tnat f) -- alternative to (4.2) serialization ---------------------------------------- preordt' = monBTree singl -- alternative to (4.1) counting --------------------------------------------- countBTree' = monBTree (const (Sum 1)) ---------------------------- end of library ----------------------------------