> module BinTree ( Pretty.., > -- types > BinTree(..), > -- construction > empty, leaf, insert, right, > -- modification > delete, deleteMany, mapBinTree, foldBinTree, > -- conversion > build, buildBal, inorder, > -- size > size, depth, > -- testing > member > ) > where
> import Pretty > import Support ( intersperse, replicate )
> data BinTree a = Empty > | Node (BinTree a) a (BinTree a) > deriving (Eq)Pretty printing a tree.
> instance Pretty a => Pretty (BinTree a) where > ppPrec d t = block 0 (ppUnlines ts) > where (_, _, ts) = ppBinTree t
> {-
> ppPrec d t = block 0 (ppUnlines (ppBinTree t))
> ppBinTree :: Pretty a => BinTree a -> [[Txt]]
> ppBinTree Empty = [[str "|"]]
> ppBinTree (Node l a r) = [[pp a]]
> ++ (str "|--":ts) : map (str "| ":) tss
> ++ (str "`--":us) : map (str " ":) uss
> where ts:tss = ppBinTree l
> us:uss = ppBinTree r
> -}
Ist ppBinTree t = (l, r, ts), so gibt l die Anzahl der Zeilen
ueber der Wurzel von t und r die Anzahl der Zeilen darunter
an. Beachte, da"s der rechte Teilbaum oberhalb des linken liegt.
> ppBinTree :: Pretty a => BinTree a -> (Int, Int, [[Txt]]) > ppBinTree Empty = (0, 0, [[str "@"]]) > ppBinTree (Node l a r) = (rl + 1 + rr, ll + 1 + lr, > zipCons rstripe rts > ++ [[pp a]] > ++ zipCons lstripe lts) > where (rr, rl, rts) = ppBinTree r > (lr, ll, lts) = ppBinTree l > rstripe = replicate rr (str " ") > ++ [str "/--"] > ++ replicate rl (str "| ") > lstripe = replicate lr (str "| ") > ++ [str "\\--"] > ++ replicate ll (str " ")
> zipCons [] [] = [] > zipCons (a:as) (x:xs) = (a:x) : zipCons as xs
> ppUnlines :: [[Txt]] -> [Txt] > ppUnlines = concat . intersperse [nl]
> empty = Empty
> leaf a = Node Empty a Empty
insert inserts an element into a binary search tree.
> insert :: (Ord a) => BinTree a -> a -> BinTree a > insert Empty a = leaf a > insert (Node l b r) a > | a<=b = Node (insert l a) b r > | otherwise = Node l b (insert r a)Erzeugung eines rechtsentarteten Baums.
> right :: [a] -> BinTree a > right [] = Empty > right (a:x) = Node Empty a (right x)
delete deletes an element from a binary search tree.
> delete :: (Ord a) => BinTree a -> a -> BinTree a > delete Empty a = Empty > delete (Node l b r) a = case _tagCmp a b of > _LT -> Node (delete l a) b r > _EQ -> join l r > _GT -> Node l b (delete r a)
> join Empty r = r > join (Node ll a lr) r = let (b,t) = split ll a lr in Node t b r > > split l a Empty = (a,l) > split l a (Node rl b rr) > = let (c,t) = split rl b rr in (c,Node l a t)Variant of
join which uses continuations.
> {-----------------------------------------------------------------------------
> join' Empty r = r
> join' (Node ll a lr) r= split' ll a lr (\b t -> Node t b r)
>
> split' l a Empty k = k a l
> split' l a (Node rl b rr) k
> = split' rl b rr (\c t -> k c (Node l a t))
> -----------------------------------------------------------------------------}
> deleteMany :: (Ord a) => BinTree a -> [a] -> BinTree a > deleteMany = foldl delete
mapBinTree and foldBinTree.
> mapBinTree :: (a -> b) -> BinTree a -> BinTree b > mapBinTree f Empty = Empty > mapBinTree f (Node l a r) = Node (mapBinTree f l) (f a) (mapBinTree f r)
> foldBinTree :: (a -> b -> a -> a) -> a -> BinTree b -> a > foldBinTree n e Empty = e > foldBinTree n e (Node l a r) = n (foldBinTree n e l) a (foldBinTree n e r)
> build :: (Ord a) => [a] -> BinTree a > build = foldl insert Empty
buildBal constructs a balanced binary tree.
> buildBal :: [a] -> BinTree a > buildBal x = fst (buildn (length x) x) > where > buildn :: Int -> [a] -> (BinTree a, [a]) > buildn 0 x = (Empty, x) > buildn (n+1) x = (Node l a r, z) > where m = n `div` 2 > (l,a:y) = buildn m x > (r, z) = buildn (n - m) y
> {-----------------------------------------------------------------------------
Ditto using a Monad (state transformer based on CPS).
> import CPS
> buildBal' :: [a] -> BinTree a > buildBal' x = splitBuild' (length x) (\t _ -> t) x
> splitBuild' :: Int -> CPS (BinTree a) ([a] -> res) > splitBuild' 0 = unit Empty > splitBuild' (n+1) = let m = n `div` 2 in > splitBuild' m &= \l -> > item &= \a -> > splitBuild' (n - m) &= \r -> > unit (Node l a r)
> item :: CPS a ([a] -> res)
> item = \c (a:x) -> c a x
> {-# INLINE item #-}
> -----------------------------------------------------------------------------}
> inorder :: BinTree a -> [a] > inorder t = traverse t [] > where > traverse Empty = id > traverse (Node l a r) = traverse l . put a . traverse r
> size, depth :: BinTree a -> Int > size = foldBinTree (\l _ r -> l + 1 + r) 0 > depth = foldBinTree (\l _ r -> max l r + 1) 0
> member :: (Ord a) => a -> BinTree a -> Bool > member a Empty = False > member a (Node l b r) = a==b || member a l || member a r
> put = (:)
> {-----------------------------------------------------------------------------
> import Benchmark
> main1 = let n = 500000 in > let t1 = buildBal [1..n]::BinTree Int in > let t2 = deleteMany t1 [1..n] in > display 79 t2
> main = let n = 500000 in > time (print (depth (buildBal [1..n]))) >> > time (print (depth (buildBal' [1..n]))) > -----------------------------------------------------------------------------}