AvlTree (empty) → 2.4
raw patch · 31 files changed
+9720/−0 lines, 31 filesdep +COrderingdep +basedep +containerssetup-changed
Dependencies added: COrdering, base, containers
Files
- AUTHORS +1/−0
- AvlTree.cabal +68/−0
- CHANGELOG +4/−0
- Data/Tree/AVL.hs +144/−0
- Data/Tree/AVL/Delete.hs +534/−0
- Data/Tree/AVL/Internals/BinPath.hs +376/−0
- Data/Tree/AVL/Internals/DelUtils.hs +790/−0
- Data/Tree/AVL/Internals/HAVL.hs +98/−0
- Data/Tree/AVL/Internals/HJoin.hs +329/−0
- Data/Tree/AVL/Internals/HPush.hs +189/−0
- Data/Tree/AVL/Internals/HSet.hs +655/−0
- Data/Tree/AVL/Internals/HeightUtils.hs +98/−0
- Data/Tree/AVL/Join.hs +121/−0
- Data/Tree/AVL/List.hs +856/−0
- Data/Tree/AVL/Push.hs +715/−0
- Data/Tree/AVL/Read.hs +168/−0
- Data/Tree/AVL/Set.hs +491/−0
- Data/Tree/AVL/Size.hs +174/−0
- Data/Tree/AVL/Split.hs +837/−0
- Data/Tree/AVL/Test/AllTests.hs +1405/−0
- Data/Tree/AVL/Test/Counter.hs +49/−0
- Data/Tree/AVL/Test/Utils.hs +221/−0
- Data/Tree/AVL/Types.hs +165/−0
- Data/Tree/AVL/Write.hs +197/−0
- Data/Tree/AVL/Zipper.hs +903/−0
- Data/Tree/AVLX.hs +42/−0
- LICENSE +31/−0
- Setup.hs +3/−0
- Test/Test.hs +6/−0
- include/ghcdefs.h +25/−0
- include/h98defs.h +25/−0
+ AUTHORS view
@@ -0,0 +1,1 @@+(c) Adrian HEY
+ AvlTree.cabal view
@@ -0,0 +1,68 @@+Name: AvlTree+Version: 2.4+Cabal-Version: >= 1.2+Build-Type: Simple+License: BSD3+License-File: LICENSE+Copyright: (c) Adrian Hey 2004-2008+Author: Adrian Hey+Maintainer: http://homepages.nildram.co.uk/~ahey/em.png+Stability: Stable+Homepage: http://www.haskell.org/haskellwiki/AvlTree+Package-Url:+Synopsis: Balanced binary trees using AVL algorithm.+Description: A comprehensive library and efficient implementation of AVL trees. The raw AVL+ API has been designed with efficiency and generality in mind, not elagance. It+ contains all the stuff you really don't want to write yourself if you can avoid+ it. This library may be useful for rolling your own Sets, Maps, Sequences, Queues+ (for example).+Category: Data Structures+Tested-With: GHC == 6.8.2, GHC == 6.8.1+Data-Files:+Extra-Source-Files: AUTHORS, CHANGELOG, Test/Test.hs, include/ghcdefs.h, include/h98defs.h+Extra-Tmp-Files:+Author: Adrian Hey++Library+ Buildable: True+ Build-Depends: base, containers, COrdering >= 2.1+ Exposed-Modules: Data.Tree.AVL,+ Data.Tree.AVL.Test.AllTests,+ Data.Tree.AVL.Test.Counter+ Other-Modules: Data.Tree.AVLX,+ Data.Tree.AVL.Delete,+ Data.Tree.AVL.Join,+ Data.Tree.AVL.List,+ Data.Tree.AVL.Push,+ Data.Tree.AVL.Read,+ Data.Tree.AVL.Set,+ Data.Tree.AVL.Size,+ Data.Tree.AVL.Split,+ Data.Tree.AVL.Types,+ Data.Tree.AVL.Write,+ Data.Tree.AVL.Zipper,+ Data.Tree.AVL.Test.Utils,+ Data.Tree.AVL.Internals.BinPath,+ Data.Tree.AVL.Internals.DelUtils,+ Data.Tree.AVL.Internals.HAVL,+ Data.Tree.AVL.Internals.HJoin,+ Data.Tree.AVL.Internals.HPush,+ Data.Tree.AVL.Internals.HSet,+ Data.Tree.AVL.Internals.HeightUtils+ Extensions: CPP+ Hs-Source-Dirs: .+ Build-Tools:+ Ghc-Options: -O -Wall -split-objs+ Ghc-Prof-Options:+ Ghc-Shared-Options:+ Hugs-Options:+ Nhc98-Options:+ Includes:+ Install-Includes:+ Include-Dirs: include+ C-Sources:+ Extra-Libraries:+ Extra-Lib-Dirs:+ CC-Options:+ LD-Options:+ Pkgconfig-Depends:
+ CHANGELOG view
@@ -0,0 +1,4 @@+2.4 +--- +* Initial Hackage/Cabal release. + Version set to 2.4 to distinguish from the 2.3 (non-cabal) release on my home page.
+ Data/Tree/AVL.hs view
@@ -0,0 +1,144 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+-----------------------------------------------------------------------------+-- |+-- Module : Data.Tree.AVL+-- Copyright : (c) Adrian Hey 2004,2005+-- License : BSD3+--+-- Maintainer : http://homepages.nildram.co.uk/~ahey/em.png+-- Stability : stable+-- Portability : portable+--+-- Many of the functions defined by this package make use of generalised comparison functions+-- which return a variant of the Prelude 'Prelude.Ordering' data type: 'Data.COrdering.COrdering'. These+-- are refered to as \"combining comparisons\". (This is because they combine \"equal\"+-- values in some manner defined by the user.)+--+-- The idea is that using this simple mechanism you can define many practical and+-- useful variations of tree (or general set) operations from a few generic primitives,+-- something that would not be so easy using plain 'Prelude.Ordering' comparisons+-- (overloaded or otherwise).+--+-- Functions which involve searching a tree really only require a single argument+-- function which takes the current tree element value as argument and returns+-- an 'Prelude.Ordering' or 'Data.COrdering.COrdering' to direct the next stage of the search down+-- the left or right sub-trees (or stop at the current element). For documentation+-- purposes, these functions are called \"selectors\" throughout this library.+-- Typically a selector will be obtained by partially applying the appropriate+-- combining comparison with the value or key being searched for. For example..+--+-- @+-- mySelector :: Int -> Ordering Tree elements are Ints+-- or..+-- mySelector :: (key,val) -> COrdering val Tree elements are (key,val) pairs+-- @+--+-- Please read the notes in the "Data.Tree.AVL.Types" module documentation too.+-----------------------------------------------------------------------------+module Data.Tree.AVL+(module Data.Tree.AVL.Types,++ -- * Conversion utilities++ -- ** Conversion between /sorted/ AVL trees and Data.Set+ set2AVL,avl2Set,++ -- ** Conversion between /sorted/ AVL trees of (key,value) pairs and Data.Map+ map2AVL,avl2Map,++ module Data.Tree.AVL.Size,+ module Data.Tree.AVL.Read,+ module Data.Tree.AVL.Write,+ module Data.Tree.AVL.Push,+ module Data.Tree.AVL.Delete,+ module Data.Tree.AVL.List,+ module Data.Tree.AVL.Join,+ module Data.Tree.AVL.Split,+ module Data.Tree.AVL.Set,+ module Data.Tree.AVL.Zipper,++ -- * Correctness checking.+ isBalanced,isSorted,isSortedOK,++ -- * Tree parameter utilities.+ minElements,maxElements,+) where++import Prelude -- so haddock finds the symbols there++import qualified Data.Set as BaseSet+import qualified Data.Map as BaseMap++import Data.Tree.AVL.Types hiding (E,N,P,Z)+import Data.Tree.AVL.Size+import Data.Tree.AVL.Read+import Data.Tree.AVL.Write+import Data.Tree.AVL.Push+import Data.Tree.AVL.Delete+import Data.Tree.AVL.List+import Data.Tree.AVL.Join+import Data.Tree.AVL.Split+import Data.Tree.AVL.Set+import Data.Tree.AVL.Zipper+import Data.Tree.AVL.Test.Utils(isBalanced,isSorted,isSortedOK,minElements,maxElements)++#if __GLASGOW_HASKELL__ > 604+import Data.Traversable+instance Traversable AVL where+ traverse = traverseAVL+#endif++-- | Convert a 'Data.Set.Set' (from the base package Data.Set module) to a sorted AVL tree.+-- Elements and element ordering are preserved (ascending order is left to right).+--+-- Complexity: O(n)+set2AVL :: BaseSet.Set a -> AVL a+set2AVL set = asTreeLenL (BaseSet.size set) (BaseSet.toAscList set)++-- | Convert a /sorted/ AVL tree to a 'Data.Set.Set' (from the base package Data.Set module).+-- Elements and element ordering are preserved.+--+-- Complexity: O(n)+avl2Set :: AVL a -> BaseSet.Set a+avl2Set avl = BaseSet.fromDistinctAscList (asListL avl)++-- | Convert a 'Data.Map.Map' to a sorted (by key) AVL tree.+-- Elements and element ordering are preserved (ascending order is left to right).+--+-- Complexity: O(n)+map2AVL :: BaseMap.Map key val -> AVL (key,val)+map2AVL mp = asTreeLenL (BaseMap.size mp) (BaseMap.toAscList mp)++-- | Convert a /sorted/ (by key) AVL tree to a 'Data.Map.Map' (from the base package Data.Map module).+-- Elements and element ordering are preserved.+--+-- Complexity: O(n)+avl2Map :: AVL (key,val) -> BaseMap.Map key val+avl2Map avl = BaseMap.fromDistinctAscList (asListL avl)++-- | Eq is based on equality of the lists produced by 'asListL'. This definition has been placed here+-- to avoid introducing cyclic dependency between Types.hs and List.hs+instance Eq e => Eq (AVL e) where+ x == y = (size x == size y) && (asListL x == asListL y) -- Compare sizes first as this will usually resolve it++-- | Ordering is based on ordering of the lists produced by 'asListL'. This definition has been placed here+-- to avoid introducing cyclic dependency between Types.hs and List.hs+instance Ord e => Ord (AVL e) where+ x `compare` y = asListL x `compare` asListL y++-- | Show is based on showing the list produced by 'asListL'. This definition has been placed here+-- to avoid introducing cyclic dependency between Types.hs and List.hs+instance Show e => Show (AVL e) where+ -- showsPrec :: Int -> AVL e -> Shows -- type Shows = String -> String+ showsPrec _ t = ("AVL " ++) . showList (asListL t)++instance Read e => Read (AVL e) where+ -- readsPrec :: Int -> ReadS a -- type ReadS a = String -> [(a,String)]+ readsPrec _ str = case lex str of+ [("AVL",str')] -> [(asTreeL es, str'') | (es,str'') <- readList str']+ _ -> []++-- | AVL trees are an instance of 'Functor'. This definition has been placed here+-- to avoid introducing cyclic dependency between Types.hs and List.hs+instance Functor AVL where+ fmap = mapAVL -- The lazy version.
+ Data/Tree/AVL/Delete.hs view
@@ -0,0 +1,534 @@+{-# OPTIONS_GHC -fglasgow-exts #-}+-----------------------------------------------------------------------------+-- |+-- Module : Data.Tree.AVL.Delete+-- Copyright : (c) Adrian Hey 2004,2005+-- License : BSD3+--+-- Maintainer : http://homepages.nildram.co.uk/~ahey/em.png+-- Stability : stable+-- Portability : portable+-----------------------------------------------------------------------------+module Data.Tree.AVL.Delete+(-- * Deleting elements from AVL trees++ -- ** Deleting from extreme left or right+ delL,delR,assertDelL,assertDelR,tryDelL,tryDelR,++ -- ** Deleting from /sorted/ trees+ genDel,genDelFast,genDelIf,genDelMaybe,++ -- * \"Popping\" elements from AVL trees+ -- | \"Popping\" means reading and deleting a tree element in a single operation.++ -- ** Popping from extreme left or right+ assertPopL,assertPopR,tryPopL,tryPopR,++ -- ** Popping from /sorted/ trees+ genAssertPop,genTryPop,genAssertPopMaybe,genTryPopMaybe,genAssertPopIf,genTryPopIf,+) where++import Prelude -- so haddock finds the symbols there++import Data.COrdering+import Data.Tree.AVL.Types(AVL(..))+import Data.Tree.AVL.Internals.BinPath(BinPath(..),genFindPath,genOpenPathWith,writePath)++import Data.Tree.AVL.Internals.DelUtils+ (-- Deleting Utilities+ delRN,delRZ,delRP,delLN,delLZ,delLP,+ -- Popping Utilities.+ popRN,popRZ,popRP,popLN,popLZ,popLP,+ -- Balancing Utilities+ chkLN,chkLZ,chkLP,chkRN,chkRZ,chkRP,+ chkLN',chkLZ',chkLP',chkRN',chkRZ',chkRP',+ -- Node substitution utilities.+ subN,subZR,subZL,subP,+ -- BinPath related+ deletePath+ )++#ifdef __GLASGOW_HASKELL__+import GHC.Base+#include "ghcdefs.h"+#else+#include "h98defs.h"+#endif++-- | Delete the left-most element of an AVL tree. If the tree is sorted this will be the+-- least element. This function returns an empty tree if it's argument is an empty tree.+--+-- Complexity: O(log n)+delL :: AVL e -> AVL e+delL E = E+delL (N l e r) = delLN l e r+delL (Z l e r) = delLZ l e r+delL (P l e r) = delLP l e r++-- | Delete the left-most element of a /non-empty/ AVL tree. If the tree is sorted this will be the+-- least element. This function raises an error if it's argument is an empty tree.+--+-- Complexity: O(log n)+assertDelL :: AVL e -> AVL e+assertDelL E = error "assertDelL: Empty tree."+assertDelL (N l e r) = delLN l e r+assertDelL (Z l e r) = delLZ l e r+assertDelL (P l e r) = delLP l e r++-- | Try to delete the left-most element of a /non-empty/ AVL tree. If the tree is sorted this will be the+-- least element. This function returns 'Nothing' if it's argument is an empty tree.+--+-- Complexity: O(log n)+tryDelL :: AVL e -> Maybe (AVL e)+tryDelL E = Nothing+tryDelL (N l e r) = Just $! delLN l e r+tryDelL (Z l e r) = Just $! delLZ l e r+tryDelL (P l e r) = Just $! delLP l e r++-- | Delete the right-most element of an AVL tree. If the tree is sorted this will be the+-- greatest element. This function returns an empty tree if it's argument is an empty tree.+--+-- Complexity: O(log n)+delR :: AVL e -> AVL e+delR E = E+delR (N l e r) = delRN l e r+delR (Z l e r) = delRZ l e r+delR (P l e r) = delRP l e r++-- | Delete the right-most element of a /non-empty/ AVL tree. If the tree is sorted this will be the+-- greatest element. This function raises an error if it's argument is an empty tree.+--+-- Complexity: O(log n)+assertDelR :: AVL e -> AVL e+assertDelR E = error "assertDelR: Empty tree."+assertDelR (N l e r) = delRN l e r+assertDelR (Z l e r) = delRZ l e r+assertDelR (P l e r) = delRP l e r++-- | Try to delete the right-most element of a /non-empty/ AVL tree. If the tree is sorted this will be the+-- greatest element. This function returns 'Nothing' if it's argument is an empty tree.+--+-- Complexity: O(log n)+tryDelR :: AVL e -> Maybe (AVL e)+tryDelR E = Nothing+tryDelR (N l e r) = Just $! delRN l e r+tryDelR (Z l e r) = Just $! delRZ l e r+tryDelR (P l e r) = Just $! delRP l e r++-- | Pop the left-most element from a non-empty AVL tree, returning the popped element and the+-- modified AVL tree. If the tree is sorted this will be the least element.+-- This function raises an error if it's argument is an empty tree.+--+-- Complexity: O(log n)+assertPopL :: AVL e -> (e,AVL e)+assertPopL E = error "assertPopL: Empty tree."+assertPopL (N l e r) = case popLN l e r of UBT2(v,t) -> (v,t)+assertPopL (Z l e r) = case popLZ l e r of UBT2(v,t) -> (v,t)+assertPopL (P l e r) = case popLP l e r of UBT2(v,t) -> (v,t)++-- | Same as 'assertPopL', except this version returns 'Nothing' if it's argument is an empty tree.+--+-- Complexity: O(log n)+tryPopL :: AVL e -> Maybe (e,AVL e)+tryPopL E = Nothing+tryPopL (N l e r) = Just $! case popLN l e r of UBT2(v,t) -> (v,t)+tryPopL (Z l e r) = Just $! case popLZ l e r of UBT2(v,t) -> (v,t)+tryPopL (P l e r) = Just $! case popLP l e r of UBT2(v,t) -> (v,t)+++-- | Pop the right-most element from a non-empty AVL tree, returning the popped element and the+-- modified AVL tree. If the tree is sorted this will be the greatest element.+-- This function raises an error if it's argument is an empty tree.+--+-- Complexity: O(log n)+assertPopR :: AVL e -> (AVL e,e)+assertPopR E = error "assertPopR: Empty tree."+assertPopR (N l e r) = case popRN l e r of UBT2(t,v) -> (t,v)+assertPopR (Z l e r) = case popRZ l e r of UBT2(t,v) -> (t,v)+assertPopR (P l e r) = case popRP l e r of UBT2(t,v) -> (t,v)++-- | Same as 'assertPopR', except this version returns 'Nothing' if it's argument is an empty tree.+--+-- Complexity: O(log n)+tryPopR :: AVL e -> Maybe (AVL e,e)+tryPopR E = Nothing+tryPopR (N l e r) = Just $! case popRN l e r of UBT2(t,v) -> (t,v)+tryPopR (Z l e r) = Just $! case popRZ l e r of UBT2(t,v) -> (t,v)+tryPopR (P l e r) = Just $! case popRP l e r of UBT2(t,v) -> (t,v)++-- | General purpose function for deletion of elements from a sorted AVL tree.+-- If a matching element is not found then this function returns the original tree.+--+-- Complexity: O(log n)+genDel :: (e -> Ordering) -> AVL e -> AVL e+genDel c t = let p = genFindPath c t+ in case COMPAREUINT p L(0) of+ LT -> t -- Not found, p<0+ _ -> deletePath p t -- Found, so delete++-- | This version only deletes the element if the supplied selector returns @('Eq' 'True')@.+-- If it returns @('Eq' 'False')@ or if no matching element is found then this function returns+-- the original tree.+--+-- Complexity: O(log n)+genDelIf :: (e -> COrdering Bool) -> AVL e -> AVL e+genDelIf c t = case genOpenPathWith c t of+ FullBP p True -> deletePath p t+ _ -> t++-- | This version only deletes the element if the supplied selector returns @('Eq' 'Nothing')@.+-- If it returns @('Eq' ('Just' e))@ then the matching element is replaced by e.+-- If no matching element is found then this function returns the original tree.+--+-- Complexity: O(log n)+genDelMaybe :: (e -> COrdering (Maybe e)) -> AVL e -> AVL e+genDelMaybe c t = case genOpenPathWith c t of+ FullBP p Nothing -> deletePath p t+ FullBP p (Just e) -> writePath p e t+ _ -> t++-- | Functionally identical to 'genDel', but returns an identical tree (one with all the nodes on+-- the path duplicated) if the search fails. This should probably only be used if you know the+-- search will succeed.+--+-- Complexity: O(log n)+genDelFast :: (e -> Ordering) -> AVL e -> AVL e+-- This was the old genDel so it's been tested OK, but as a different name.+genDelFast c = genDel' where+ genDel' E = E+ genDel' (N l e r) = delN l e r+ genDel' (Z l e r) = delZ l e r+ genDel' (P l e r) = delP l e r++ ----------------------------- LEVEL 1 ---------------------------------+ -- delN, delZ, delP --+ -----------------------------------------------------------------------++ -- Delete from (N l e r)+ delN l e r = case c e of+ LT -> delNL l e r+ EQ -> subN l r+ GT -> delNR l e r++ -- Delete from (Z l e r)+ delZ l e r = case c e of+ LT -> delZL l e r+ EQ -> subZR l r+ GT -> delZR l e r++ -- Delete from (P l e r)+ delP l e r = case c e of+ LT -> delPL l e r+ EQ -> subP l r+ GT -> delPR l e r++ ----------------------------- LEVEL 2 ---------------------------------+ -- delNL, delZL, delPL --+ -- delNR, delZR, delPR --+ -----------------------------------------------------------------------++ -- Delete from the left subtree of (N l e r)+ delNL E e r = N E e r -- Left sub-tree is empty+ delNL (N ll le lr) e r = case c le of+ LT -> chkLN (delNL ll le lr) e r+ EQ -> chkLN (subN ll lr) e r+ GT -> chkLN (delNR ll le lr) e r+ delNL (Z ll le lr) e r = case c le of+ LT -> let l' = delZL ll le lr in l' `seq` N l' e r -- height can't change+ EQ -> chkLN' (subZR ll lr) e r -- << But it can here+ GT -> let l' = delZR ll le lr in l' `seq` N l' e r -- height can't change+ delNL (P ll le lr) e r = case c le of+ LT -> chkLN (delPL ll le lr) e r+ EQ -> chkLN (subP ll lr) e r+ GT -> chkLN (delPR ll le lr) e r++ -- Delete from the right subtree of (N l e r)+ delNR _ _ E = error "delNR: Bug0" -- Impossible+ delNR l e (N rl re rr) = case c re of+ LT -> chkRN l e (delNL rl re rr)+ EQ -> chkRN l e (subN rl rr)+ GT -> chkRN l e (delNR rl re rr)+ delNR l e (Z rl re rr) = case c re of+ LT -> let r' = delZL rl re rr in r' `seq` N l e r' -- height can't change+ EQ -> chkRN' l e (subZL rl rr) -- << But it can here+ GT -> let r' = delZR rl re rr in r' `seq` N l e r' -- height can't change+ delNR l e (P rl re rr) = case c re of+ LT -> chkRN l e (delPL rl re rr)+ EQ -> chkRN l e (subP rl rr)+ GT -> chkRN l e (delPR rl re rr)++ -- Delete from the left subtree of (Z l e r)+ delZL E e r = Z E e r -- Left sub-tree is empty+ delZL (N ll le lr) e r = case c le of+ LT -> chkLZ (delNL ll le lr) e r+ EQ -> chkLZ (subN ll lr) e r+ GT -> chkLZ (delNR ll le lr) e r+ delZL (Z ll le lr) e r = case c le of+ LT -> let l' = delZL ll le lr in l' `seq` Z l' e r -- height can't change+ EQ -> chkLZ' (subZR ll lr) e r -- << But it can here+ GT -> let l' = delZR ll le lr in l' `seq` Z l' e r -- height can't change+ delZL (P ll le lr) e r = case c le of+ LT -> chkLZ (delPL ll le lr) e r+ EQ -> chkLZ (subP ll lr) e r+ GT -> chkLZ (delPR ll le lr) e r++ -- Delete from the right subtree of (Z l e r)+ delZR l e E = Z l e E -- Right sub-tree is empty+ delZR l e (N rl re rr) = case c re of+ LT -> chkRZ l e (delNL rl re rr)+ EQ -> chkRZ l e (subN rl rr)+ GT -> chkRZ l e (delNR rl re rr)+ delZR l e (Z rl re rr) = case c re of+ LT -> let r' = delZL rl re rr in r' `seq` Z l e r' -- height can't change+ EQ -> chkRZ' l e (subZL rl rr) -- << But it can here+ GT -> let r' = delZR rl re rr in r' `seq` Z l e r' -- height can't change+ delZR l e (P rl re rr) = case c re of+ LT -> chkRZ l e (delPL rl re rr)+ EQ -> chkRZ l e (subP rl rr)+ GT -> chkRZ l e (delPR rl re rr)++ -- Delete from the left subtree of (P l e r)+ delPL E _ _ = error "delPL: Bug0" -- Impossible+ delPL (N ll le lr) e r = case c le of+ LT -> chkLP (delNL ll le lr) e r+ EQ -> chkLP (subN ll lr) e r+ GT -> chkLP (delNR ll le lr) e r+ delPL (Z ll le lr) e r = case c le of+ LT -> let l' = delZL ll le lr in l' `seq` P l' e r -- height can't change+ EQ -> chkLP' (subZR ll lr) e r -- << But it can here+ GT -> let l' = delZR ll le lr in l' `seq` P l' e r -- height can't change+ delPL (P ll le lr) e r = case c le of+ LT -> chkLP (delPL ll le lr) e r+ EQ -> chkLP (subP ll lr) e r+ GT -> chkLP (delPR ll le lr) e r++ -- Delete from the right subtree of (P l e r)+ delPR l e E = P l e E -- Right sub-tree is empty+ delPR l e (N rl re rr) = case c re of+ LT -> chkRP l e (delNL rl re rr)+ EQ -> chkRP l e (subN rl rr)+ GT -> chkRP l e (delNR rl re rr)+ delPR l e (Z rl re rr) = case c re of+ LT -> let r' = delZL rl re rr in r' `seq` P l e r' -- height can't change+ EQ -> chkRP' l e (subZL rl rr) -- << But it can here+ GT -> let r' = delZR rl re rr in r' `seq` P l e r' -- height can't change+ delPR l e (P rl re rr) = case c re of+ LT -> chkRP l e (delPL rl re rr)+ EQ -> chkRP l e (subP rl rr)+ GT -> chkRP l e (delPR rl re rr)+-----------------------------------------------------------------------+------------------------- genDelFast Ends Here ------------------------+-----------------------------------------------------------------------++-- | General purpose function for popping elements from a sorted AVL tree.+-- An error is raised if a matching element is not found. The pair returned+-- by this function consists of the popped value and the modified tree.+--+-- Complexity: O(log n)+genAssertPop :: (e -> COrdering a) -> AVL e -> (a,AVL e)+genAssertPop c = genPop_ where+ genPop_ E = error "genAssertPop: element not found."+ genPop_ (N l e r) = case popN l e r of UBT2(v,t) -> (v,t)+ genPop_ (Z l e r) = case popZ l e r of UBT2(v,t) -> (v,t)+ genPop_ (P l e r) = case popP l e r of UBT2(v,t) -> (v,t)++ ----------------------------- LEVEL 1 ---------------------------------+ -- popN, popZ, popP --+ -----------------------------------------------------------------------++ -- Pop from (N l e r)+ popN l e r = case c e of+ Lt -> popNL l e r+ Eq a -> let t = subN l r in t `seq` UBT2(a,t)+ Gt -> popNR l e r++ -- Pop from (Z l e r)+ popZ l e r = case c e of+ Lt -> popZL l e r+ Eq a -> let t = subZR l r in t `seq` UBT2(a,t)+ Gt -> popZR l e r++ -- Pop from (P l e r)+ popP l e r = case c e of+ Lt -> popPL l e r+ Eq a -> let t = subP l r in t `seq` UBT2(a,t)+ Gt -> popPR l e r++ ----------------------------- LEVEL 2 ---------------------------------+ -- popNL, popZL, popPL --+ -- popNR, popZR, popPR --+ -----------------------------------------------------------------------++ -- Pop from the left subtree of (N l e r)+ popNL E _ _ = error "genAssertPop: element not found." -- Left sub-tree is empty+ popNL (N ll le lr) e r = case c le of+ Lt -> case popNL ll le lr of+ UBT2(a,l_) -> let t = chkLN l_ e r in t `seq` UBT2(a,t)+ Eq a -> let t = chkLN (subN ll lr) e r in t `seq` UBT2(a,t)+ Gt -> case popNR ll le lr of+ UBT2(a,l_) -> let t = chkLN l_ e r in t `seq` UBT2(a,t)+ popNL (Z ll le lr) e r = case c le of+ Lt -> case popZL ll le lr of UBT2(a,l_) -> UBT2(a, N l_ e r)+ Eq a -> let t = chkLN' (subZR ll lr) e r+ in t `seq` UBT2(a,t)+ Gt -> case popZR ll le lr of UBT2(a,l_) -> UBT2(a, N l_ e r)+ popNL (P ll le lr) e r = case c le of+ Lt -> case popPL ll le lr of+ UBT2(a,l_) -> let t = chkLN l_ e r in t `seq` UBT2(a,t)+ Eq a -> let t = chkLN (subP ll lr) e r in t `seq` UBT2(a,t)+ Gt -> case popPR ll le lr of+ UBT2(a,l_) -> let t = chkLN l_ e r in t `seq` UBT2(a,t)++ -- Pop from the right subtree of (N l e r)+ popNR _ _ E = error "genPop.popNR: Bug!" -- Impossible+ popNR l e (N rl re rr) = case c re of+ Lt -> case popNL rl re rr of+ UBT2(a,r_) -> let t = chkRN l e r_ in t `seq` UBT2(a,t)+ Eq a -> let t = chkRN l e (subN rl rr) in t `seq` UBT2(a,t)+ Gt -> case popNR rl re rr of+ UBT2(a,r_) -> let t = chkRN l e r_ in t `seq` UBT2(a,t)+ popNR l e (Z rl re rr) = case c re of+ Lt -> case popZL rl re rr of UBT2(a,r_) -> UBT2(a, N l e r_)+ Eq a -> let t = chkRN' l e (subZL rl rr)+ in t `seq` UBT2(a,t)+ Gt -> case popZR rl re rr of UBT2(a,r_) -> UBT2(a, N l e r_)+ popNR l e (P rl re rr) = case c re of+ Lt -> case popPL rl re rr of+ UBT2(a,r_) -> let t = chkRN l e r_ in t `seq` UBT2(a,t)+ Eq a -> let t = chkRN l e (subP rl rr) in t `seq` UBT2(a,t)+ Gt -> case popPR rl re rr of+ UBT2(a,r_) -> let t = chkRN l e r_ in t `seq` UBT2(a,t)++ -- Pop from the left subtree of (Z l e r)+ popZL E _ _ = error "genAssertPop: element not found." -- Left sub-tree is empty+ popZL (N ll le lr) e r = case c le of+ Lt -> case popNL ll le lr of+ UBT2(a,l_) -> let t = chkLZ l_ e r in t `seq` UBT2(a,t)+ Eq a -> let t = chkLZ (subN ll lr) e r in t `seq` UBT2(a,t)+ Gt -> case popNR ll le lr of+ UBT2(a,l_) -> let t = chkLZ l_ e r in t `seq` UBT2(a,t)+ popZL (Z ll le lr) e r = case c le of+ Lt -> case popZL ll le lr of UBT2(a,l_) -> UBT2(a, Z l_ e r)+ Eq a -> let t = chkLZ' (subZR ll lr) e r+ in t `seq` UBT2(a,t)+ Gt -> case popZR ll le lr of UBT2(a,l_) -> UBT2(a, Z l_ e r)+ popZL (P ll le lr) e r = case c le of+ Lt -> case popPL ll le lr of+ UBT2(a,l_) -> let t = chkLZ l_ e r in t `seq` UBT2(a,t)+ Eq a -> let t = chkLZ (subP ll lr) e r in t `seq` UBT2(a,t)+ Gt -> case popPR ll le lr of+ UBT2(a,l_) -> let t = chkLZ l_ e r in t `seq` UBT2(a,t)++ -- Pop from the right subtree of (Z l e r)+ popZR _ _ E = error "genAssertPop: element not found." -- Right sub-tree is empty+ popZR l e (N rl re rr) = case c re of+ Lt -> case popNL rl re rr of+ UBT2(a,r_) -> let t = chkRZ l e r_ in t `seq` UBT2(a,t)+ Eq a -> let t = chkRZ l e (subN rl rr) in t `seq` UBT2(a,t)+ Gt -> case popNR rl re rr of+ UBT2(a,r_) -> let t = chkRZ l e r_ in t `seq` UBT2(a,t)+ popZR l e (Z rl re rr) = case c re of+ Lt -> case popZL rl re rr of UBT2(a,r_) -> UBT2(a, Z l e r_)+ Eq a -> let t = chkRZ' l e (subZL rl rr)+ in t `seq` UBT2(a,t)+ Gt -> case popZR rl re rr of UBT2(a,r_) -> UBT2(a, Z l e r_)+ popZR l e (P rl re rr) = case c re of+ Lt -> case popPL rl re rr of+ UBT2(a,r_) -> let t = chkRZ l e r_ in t `seq` UBT2(a,t)+ Eq a -> let t = chkRZ l e (subP rl rr) in t `seq` UBT2(a,t)+ Gt -> case popPR rl re rr of+ UBT2(a,r_) -> let t = chkRZ l e r_ in t `seq` UBT2(a,t)++ -- Pop from the left subtree of (P l e r)+ popPL E _ _ = error "genPop.popPL: Bug!" -- Impossible+ popPL (N ll le lr) e r = case c le of+ Lt -> case popNL ll le lr of+ UBT2(a,l_) -> let t = chkLP l_ e r in t `seq` UBT2(a,t)+ Eq a -> let t = chkLP (subN ll lr) e r in t `seq` UBT2(a,t)+ Gt -> case popNR ll le lr of+ UBT2(a,l_) -> let t = chkLP l_ e r in t `seq` UBT2(a,t)+ popPL (Z ll le lr) e r = case c le of+ Lt -> case popZL ll le lr of UBT2(a,l_) -> UBT2(a, P l_ e r)+ Eq a -> let t = chkLP' (subZR ll lr) e r+ in t `seq` UBT2(a,t)+ Gt -> case popZR ll le lr of UBT2(a,l_) -> UBT2(a, P l_ e r)+ popPL (P ll le lr) e r = case c le of+ Lt -> case popPL ll le lr of+ UBT2(a,l_) -> let t = chkLP l_ e r in t `seq` UBT2(a,t)+ Eq a -> let t = chkLP (subP ll lr) e r in t `seq` UBT2(a,t)+ Gt -> case popPR ll le lr of+ UBT2(a,l_) -> let t = chkLP l_ e r in t `seq` UBT2(a,t)++ -- Pop from the right subtree of (P l e r)+ popPR _ _ E = error "genAssertPop: element not found." -- Right sub-tree is empty+ popPR l e (N rl re rr) = case c re of+ Lt -> case popNL rl re rr of+ UBT2(a,r_) -> let t = chkRP l e r_ in t `seq` UBT2(a,t)+ Eq a -> let t = chkRP l e (subN rl rr) in t `seq` UBT2(a,t)+ Gt -> case popNR rl re rr of+ UBT2(a,r_) -> let t = chkRP l e r_ in t `seq` UBT2(a,t)+ popPR l e (Z rl re rr) = case c re of+ Lt -> case popZL rl re rr of UBT2(a,r_) -> UBT2(a, P l e r_)+ Eq a -> let t = chkRP' l e (subZL rl rr)+ in t `seq` UBT2(a,t)+ Gt -> case popZR rl re rr of UBT2(a,r_) -> UBT2(a, P l e r_)+ popPR l e (P rl re rr) = case c re of+ Lt -> case popPL rl re rr of+ UBT2(a,r_) -> let t = chkRP l e r_ in t `seq` UBT2(a,t)+ Eq a -> let t = chkRP l e (subP rl rr) in t `seq` UBT2(a,t)+ Gt -> case popPR rl re rr of+ UBT2(a,r_) -> let t = chkRP l e r_ in t `seq` UBT2(a,t)+-----------------------------------------------------------------------+------------------------ genAssertPop Ends Here -----------------------+-----------------------------------------------------------------------++-- | Similar to 'genPop', but this function returns 'Nothing' if the search fails.+--+-- Complexity: O(log n)+genTryPop :: (e -> COrdering a) -> AVL e -> Maybe (a,AVL e)+genTryPop c t = case genOpenPathWith c t of+ FullBP pth a -> let t' = deletePath pth t in t' `seq` Just (a,t')+ _ -> Nothing++-- | In this case the selector returns two values if a search succeeds.+-- If the second is @('Just' e)@ then the new value (@e@) is substituted in the same place in the tree.+-- If the second is 'Nothing' then the corresponding tree element is deleted.+-- This function raises an error if the search fails.+--+-- Complexity: O(log n)+genAssertPopMaybe :: (e -> COrdering (a,Maybe e)) -> AVL e -> (a,AVL e)+genAssertPopMaybe c t = case genOpenPathWith c t of+ FullBP pth (a,Just e ) -> let t' = writePath pth e t in t' `seq` (a,t')+ FullBP pth (a,Nothing) -> let t' = deletePath pth t in t' `seq` (a,t')+ _ -> error "genAssertPopMaybe: element not found."++-- | Similar to 'genAssertPopMaybe', but returns 'Nothing' if the search fails.+--+-- Complexity: O(log n)+genTryPopMaybe :: (e -> COrdering (a,Maybe e)) -> AVL e -> Maybe (a,AVL e)+genTryPopMaybe c t = case genOpenPathWith c t of+ FullBP pth (a,Just e ) -> let t' = writePath pth e t in t' `seq` Just (a,t')+ FullBP pth (a,Nothing) -> let t' = deletePath pth t in t' `seq` Just (a,t')+ _ -> Nothing+++-- | A simpler version of 'genAssertPopMaybe'. The corresponding element is deleted if the second value+-- returned by the selector is 'True'. If it\'s 'False', the original tree is returned.+-- This function raises an error if the search fails.+--+-- Complexity: O(log n)+genAssertPopIf :: (e -> COrdering (a,Bool)) -> AVL e -> (a,AVL e)+genAssertPopIf c t = case genOpenPathWith c t of+ FullBP _ (a,False) -> (a,t)+ FullBP pth (a,True ) -> let t' = deletePath pth t in t' `seq` (a,t')+ _ -> error "genAssertPopIf: element not found."++-- | Similar to 'genPopIf', but returns 'Nothing' if the search fails.+--+-- Complexity: O(log n)+genTryPopIf :: (e -> COrdering (a,Bool)) -> AVL e -> Maybe (a,AVL e)+genTryPopIf c t = case genOpenPathWith c t of+ FullBP _ (a,False) -> Just (a,t)+ FullBP pth (a,True ) -> let t' = deletePath pth t in t' `seq` Just (a,t')+ _ -> Nothing+
+ Data/Tree/AVL/Internals/BinPath.hs view
@@ -0,0 +1,376 @@+{-# OPTIONS_GHC -fglasgow-exts #-}+-----------------------------------------------------------------------------+-- |+-- Module : Data.Tree.AVL.Internals.BinPath+-- Copyright : (c) Adrian Hey 2005+-- License : BSD3+--+-- Maintainer : http://homepages.nildram.co.uk/~ahey/em.png+-- Stability : stable+-- Portability : portable+--+-- This module provides a cheap but extremely limited and dangerous alternative+-- to using the Zipper, hence it's for INTERNAL USE ONLY. A BinPath provides+-- a way of finding a particular element in an AVL tree again without doing+-- any comparisons. But a BinPath is ONLY VALID IF THE TREE SHAPE DOES NOT+-- CHANGE.+-----------------------------------------------------------------------------+module Data.Tree.AVL.Internals.BinPath+ (BinPath(..),genFindPath,genOpenPath,genOpenPathWith,readPath,writePath,insertPath,+ -- These are used by deletePath, which currently resides in Data.Tree.AVL.Internals.DelUtils+ sel,goL,goR,+ ) where+-- N.B. The deletePath function should really be here too, but has been put+-- in Data.Tree.AVL.Internals.DelUtils instead because deletion is a tangled web of circular+-- depencency.++import Data.Tree.AVL.Types(AVL(..))+import Data.COrdering++#if __GLASGOW_HASKELL__+import GHC.Base+#include "ghcdefs.h"++-- Test path LSB+bit0 :: Int# -> Bool+{-# INLINE bit0 #-}+bit0 p = word2Int# (and# (int2Word# p) (int2Word# 1#)) ==# 1#++-- A pseudo comparison..+-- N.B. If the path was bit reversed, this could be a straight comparison.??+sel :: Int# -> Ordering+{-# INLINE sel #-}+sel p = if p ==# 0# then EQ+ else if bit0 p then LT -- Left if Bit 0 == 1+ else GT -- Right if Bit 0 == 0+++-- Modify path for entering left subtree+goL :: Int# -> Int#+{-# INLINE goL #-}+goL p = iShiftRL# p 1#++-- Modify path for entering right subtree+goR :: Int# -> Int#+{-# INLINE goR #-}+goR p = iShiftRL# (p -# 1#) 1#++#else+#include "h98defs.h"+import Data.Bits((.&.),shiftL)++-- A pseudo comparison..+-- N.B. If the path was bit reversed, this could be a straight comparison.??+sel :: Int -> Ordering+{-# INLINE sel #-}+sel p = if p == 0 then EQ+ else if bit0 p then LT -- Left if Bit 0 == 1+ else GT -- Right if Bit 0 == 0+bit0 :: Int -> Bool+{-# INLINE bit0 #-}+bit0 p = (p .&. 1) == 1++-- Modify path for entering left subtree+goL :: Int -> Int+{-# INLINE goL #-}+goL p = shiftL p 1++-- Modify path for entering right subtree+goR :: Int -> Int+{-# INLINE goR #-}+goR p = shiftL (p-1) 1+#endif++-- | Int fields are search /depth/ and /path bits/ respecively. The /path bits/ consist of a+-- a string of /depth/ bits, left justified. MSB of 0 means go left, MSB of 1 means go right.+data BinPath a = FullBP {-# UNPACK #-} !UINT a -- Found+ | EmptyBP {-# UNPACK #-} !UINT -- Not Found++{-------------------------------------------------------------------------------------------+ Notes:+--------------------------------------------------------------------------------------------+The Binary paths are based on an indexing scheme that:+ 1- Uniquely identifies each tree node+ 2- Provides a simple algorithm for path generation.+ 3- Provides a simple algorithm to locate a node in the tree, given it's path.++Imagine an infinite Binary Tree, with nodes indexed as follows:++ _____00_____ <- d=1+ / \+ _01_ _02_ <- d=2+ / \ / \+ 03 05 04 06 <- d=4+ / \ / \ / \ / \+ 07 11 09 13 08 12 10 14 <- d=8+ <-------- More Layers ------->++To generate the node index (path) as we move down the tree we..+ 1- Initialise index (i) to 0, and a parameter (d) to 1+ 2- If we've arrived where we want, output i.+ 3- Either Move left: i <- i+d, d <- 2d, goto 2+ or Move right: i <- i+2d, d <- 2d, goto 2++To find a node, given its index (path) i, we..+ 1- If i=0 then stop, we've arrived.+ 2- If i is odd then move left , i <- (i-1)>>1, goto 1 -- (i-1)>>1 = i>>1 if i is odd+ else move right, i <- (i-1)>>1, goto 1 -- (i-1)>>1 = (i>>1)-1 if i is even+Examples:+ i=05: (left ,i<-2):(right,i<-0):(stop)+ i=12: (right,i<-5):(left ,i<-2):(right,i<-0):(stop)++See also: pathTree in Data.Tree.AVL.Test.Utils for recursive implementation of the indexing scheme.+--------------------------------------------------------------------------------------------}++-- | Find the path to a AVL tree element, returns -1 (invalid path) if element not found+--+-- Complexity: O(log n)+genFindPath :: (e -> Ordering) -> AVL e -> UINT+-- ?? What about strictness if UINT is boxed (i.e. non-ghc)?+genFindPath c t = find L(1) L(0) t where+ find _ _ E = L(-1)+ find d i (N l e r) = find' d i l e r+ find d i (Z l e r) = find' d i l e r+ find d i (P l e r) = find' d i l e r+ find' d i l e r = case c e of+ LT -> let d_ = ADDINT(d,d) in find d_ ADDINT(i,d ) l+ EQ -> i+ GT -> let d_ = ADDINT(d,d) in find d_ ADDINT(i,d_) r -- d_ = 2d++-- | Get the BinPath of an element using the supplied selector.+--+-- Complexity: O(log n)+genOpenPath :: (e -> Ordering) -> AVL e -> BinPath e+genOpenPath c t = find L(1) L(0) t where+ find _ i E = EmptyBP i+ find d i (N l e r) = find' d i l e r+ find d i (Z l e r) = find' d i l e r+ find d i (P l e r) = find' d i l e r+ find' d i l e r = case c e of+ LT -> let d_ = ADDINT(d,d) in find d_ ADDINT(i,d ) l+ EQ -> FullBP i e+ GT -> let d_ = ADDINT(d,d) in find d_ ADDINT(i,d_) r -- d_ = 2d++-- | Get the BinPath of an element using the supplied (combining) selector.+--+-- Complexity: O(log n)+genOpenPathWith :: (e -> COrdering a) -> AVL e -> BinPath a+genOpenPathWith c t = find L(1) L(0) t where+ find _ i E = EmptyBP i+ find d i (N l e r) = find' d i l e r+ find d i (Z l e r) = find' d i l e r+ find d i (P l e r) = find' d i l e r+ find' d i l e r = case c e of+ Lt -> let d_ = ADDINT(d,d) in find d_ ADDINT(i,d ) l+ Eq a -> FullBP i a+ Gt -> let d_ = ADDINT(d,d) in find d_ ADDINT(i,d_) r -- d_ = 2d++-- | Overwrite a tree element. Assumes the path bits were extracted from 'FullBP' constructor.+-- Raises an error if the path leads to an empty tree.+--+-- N.B This operation does not change tree shape (no insertion occurs).+--+-- Complexity: O(log n)+writePath :: UINT -> e -> AVL e -> AVL e+writePath i0 e' t = wp i0 t where+ wp L(0) E = error "writePath: Bug0" -- Needed to force strictness in path+ wp L(0) (N l _ r) = N l e' r+ wp L(0) (Z l _ r) = Z l e' r+ wp L(0) (P l _ r) = P l e' r+ wp _ E = error "writePath: Bug1"+ wp i (N l e r) = if bit0 i then let l' = wp (goL i) l in l' `seq` N l' e r+ else let r' = wp (goR i) r in r' `seq` N l e r'+ wp i (Z l e r) = if bit0 i then let l' = wp (goL i) l in l' `seq` Z l' e r+ else let r' = wp (goR i) r in r' `seq` Z l e r'+ wp i (P l e r) = if bit0 i then let l' = wp (goL i) l in l' `seq` P l' e r+ else let r' = wp (goR i) r in r' `seq` P l e r'++-- | Read a tree element. Assumes the path bits were extracted from 'FullBP' constructor.+-- Raises an error if the path leads to an empty tree.+--+-- Complexity: O(log n)+readPath :: UINT -> AVL e -> e+readPath L(0) E = error "readPath: Bug0" -- Needed to force strictness in path+readPath L(0) (N _ e _) = e+readPath L(0) (Z _ e _) = e+readPath L(0) (P _ e _) = e+readPath _ E = error "readPath: Bug1"+readPath i (N l _ r) = readPath_ i l r+readPath i (Z l _ r) = readPath_ i l r+readPath i (P l _ r) = readPath_ i l r+readPath_ :: UINT -> AVL e -> AVL e -> e+readPath_ i l r = if bit0 i then readPath (goL i) l+ else readPath (goR i) r++-- | Inserts a new tree element. Assumes the path bits were extracted from a 'EmptyBP' constructor.+-- This function replaces the first Empty node it encounters with the supplied value, regardless+-- of the current path bits (which are not checked). DO NOT USE THIS FOR REPLACING ELEMENTS ALREADY+-- PRESENT IN THE TREE (use 'writePath' for this).+--+-- Complexity: O(log n)+insertPath :: UINT -> e -> AVL e -> AVL e+insertPath i0 e0 t = put i0 t where+ ----------------------------- LEVEL 0 ---------------------------------+ -- put --+ -----------------------------------------------------------------------+ put _ E = Z E e0 E+ put i (N l e r) = putN i l e r+ put i (Z l e r) = putZ i l e r+ put i (P l e r) = putP i l e r++ ----------------------------- LEVEL 1 ---------------------------------+ -- putN, putZ, putP --+ -----------------------------------------------------------------------+ -- Put in (N l e r), BF=-1 , (never returns P)+ putN i l e r = if bit0 i then putNL i l e r -- put in L subtree+ else putNR i l e r -- put in R subtree++ -- Put in (Z l e r), BF= 0+ putZ i l e r = if bit0 i then putZL i l e r -- put in L subtree+ else putZR i l e r -- put in R subtree++ -- Put in (P l e r), BF=+1 , (never returns N)+ putP i l e r = if bit0 i then putPL i l e r -- put in L subtree+ else putPR i l e r -- put in R subtree++ ----------------------------- LEVEL 2 ---------------------------------+ -- putNL, putZL, putPL --+ -- putNR, putZR, putPR --+ -----------------------------------------------------------------------++ -- (putNL l e r): Put in L subtree of (N l e r), BF=-1 (Never requires rebalancing) , (never returns P)+ {-# INLINE putNL #-}+ putNL _ E e r = Z (Z E e0 E) e r -- L subtree empty, H:0->1, parent BF:-1-> 0+ putNL i (N ll le lr) e r = let l' = putN (goL i) ll le lr -- L subtree BF<>0, H:h->h, parent BF:-1->-1+ in l' `seq` N l' e r+ putNL i (P ll le lr) e r = let l' = putP (goL i) ll le lr -- L subtree BF<>0, H:h->h, parent BF:-1->-1+ in l' `seq` N l' e r+ putNL i (Z ll le lr) e r = let l' = putZ (goL i) ll le lr -- L subtree BF= 0, so need to look for changes+ in case l' of+ E -> error "insertPath: Bug0" -- impossible+ Z _ _ _ -> N l' e r -- L subtree BF:0-> 0, H:h->h , parent BF:-1->-1+ _ -> Z l' e r -- L subtree BF:0->+/-1, H:h->h+1, parent BF:-1-> 0++ -- (putZL l e r): Put in L subtree of (Z l e r), BF= 0 (Never requires rebalancing) , (never returns N)+ {-# INLINE putZL #-}+ putZL _ E e r = P (Z E e0 E) e r -- L subtree H:0->1, parent BF: 0->+1+ putZL i (N ll le lr) e r = let l' = putN (goL i) ll le lr -- L subtree BF<>0, H:h->h, parent BF: 0-> 0+ in l' `seq` Z l' e r+ putZL i (P ll le lr) e r = let l' = putP (goL i) ll le lr -- L subtree BF<>0, H:h->h, parent BF: 0-> 0+ in l' `seq` Z l' e r+ putZL i (Z ll le lr) e r = let l' = putZ (goL i) ll le lr -- L subtree BF= 0, so need to look for changes+ in case l' of+ E -> error "insertPath: Bug1" -- impossible+ Z _ _ _ -> Z l' e r -- L subtree BF: 0-> 0, H:h->h , parent BF: 0-> 0+ _ -> P l' e r -- L subtree BF: 0->+/-1, H:h->h+1, parent BF: 0->+1++ -- (putZR l e r): Put in R subtree of (Z l e r), BF= 0 (Never requires rebalancing) , (never returns P)+ {-# INLINE putZR #-}+ putZR _ l e E = N l e (Z E e0 E) -- R subtree H:0->1, parent BF: 0->-1+ putZR i l e (N rl re rr) = let r' = putN (goR i) rl re rr -- R subtree BF<>0, H:h->h, parent BF: 0-> 0+ in r' `seq` Z l e r'+ putZR i l e (P rl re rr) = let r' = putP (goR i) rl re rr -- R subtree BF<>0, H:h->h, parent BF: 0-> 0+ in r' `seq` Z l e r'+ putZR i l e (Z rl re rr) = let r' = putZ (goR i) rl re rr -- R subtree BF= 0, so need to look for changes+ in case r' of+ E -> error "insertPath: Bug2" -- impossible+ Z _ _ _ -> Z l e r' -- R subtree BF: 0-> 0, H:h->h , parent BF: 0-> 0+ _ -> N l e r' -- R subtree BF: 0->+/-1, H:h->h+1, parent BF: 0->-1++ -- (putPR l e r): Put in R subtree of (P l e r), BF=+1 (Never requires rebalancing) , (never returns N)+ {-# INLINE putPR #-}+ putPR _ l e E = Z l e (Z E e0 E) -- R subtree empty, H:0->1, parent BF:+1-> 0+ putPR i l e (N rl re rr) = let r' = putN (goR i) rl re rr -- R subtree BF<>0, H:h->h, parent BF:+1->+1+ in r' `seq` P l e r'+ putPR i l e (P rl re rr) = let r' = putP (goR i) rl re rr -- R subtree BF<>0, H:h->h, parent BF:+1->+1+ in r' `seq` P l e r'+ putPR i l e (Z rl re rr) = let r' = putZ (goR i) rl re rr -- R subtree BF= 0, so need to look for changes+ in case r' of+ E -> error "insertPath: Bug3" -- impossible+ Z _ _ _ -> P l e r' -- R subtree BF:0-> 0, H:h->h , parent BF:+1->+1+ _ -> Z l e r' -- R subtree BF:0->+/-1, H:h->h+1, parent BF:+1-> 0++ -------- These 2 cases (NR and PL) may need rebalancing if they go to LEVEL 3 ---------++ -- (putNR l e r): Put in R subtree of (N l e r), BF=-1 , (never returns P)+ {-# INLINE putNR #-}+ putNR _ _ _ E = error "insertPath: Bug4" -- impossible if BF=-1+ putNR i l e (N rl re rr) = let r' = putN (goR i) rl re rr -- R subtree BF<>0, H:h->h, parent BF:-1->-1+ in r' `seq` N l e r'+ putNR i l e (P rl re rr) = let r' = putP (goR i) rl re rr -- R subtree BF<>0, H:h->h, parent BF:-1->-1+ in r' `seq` N l e r'+ putNR i l e (Z rl re rr) = let i' = goR i in if bit0 i' then putNRL i' l e rl re rr -- RL (never returns P)+ else putNRR i' l e rl re rr -- RR (never returns P)++ -- (putPL l e r): Put in L subtree of (P l e r), BF=+1 , (never returns N)+ {-# INLINE putPL #-}+ putPL _ E _ _ = error "insertPath: Bug5" -- impossible if BF=+1+ putPL i (N ll le lr) e r = let l' = putN (goL i) ll le lr -- L subtree BF<>0, H:h->h, parent BF:+1->+1+ in l' `seq` P l' e r+ putPL i (P ll le lr) e r = let l' = putP (goL i) ll le lr -- L subtree BF<>0, H:h->h, parent BF:+1->+1+ in l' `seq` P l' e r+ putPL i (Z ll le lr) e r = let i' = goL i in if bit0 i' then putPLL i' ll le lr e r -- LL (never returns N)+ else putPLR i' ll le lr e r -- LR (never returns N)++ ----------------------------- LEVEL 3 ---------------------------------+ -- putNRR, putPLL --+ -- putNRL, putPLR --+ -----------------------------------------------------------------------++ -- (putNRR l e rl re rr): Put in RR subtree of (N l e (Z rl re rr)) , (never returns P)+ {-# INLINE putNRR #-}+ putNRR _ l e rl re E = Z (Z l e rl) re (Z E e0 E) -- l and rl must also be E, special CASE RR!!+ putNRR i l e rl re (N rrl rre rrr) = let rr' = putN (goR i) rrl rre rrr -- RR subtree BF<>0, H:h->h, so no change+ in rr' `seq` N l e (Z rl re rr')+ putNRR i l e rl re (P rrl rre rrr) = let rr' = putP (goR i) rrl rre rrr -- RR subtree BF<>0, H:h->h, so no change+ in rr' `seq` N l e (Z rl re rr')+ putNRR i l e rl re (Z rrl rre rrr) = let rr' = putZ (goR i) rrl rre rrr -- RR subtree BF= 0, so need to look for changes+ in case rr' of+ E -> error "insertPath: Bug6" -- impossible+ Z _ _ _ -> N l e (Z rl re rr') -- RR subtree BF: 0-> 0, H:h->h, so no change+ _ -> Z (Z l e rl) re rr' -- RR subtree BF: 0->+/-1, H:h->h+1, parent BF:-1->-2, CASE RR !!++ -- (putPLL ll le lr e r): Put in LL subtree of (P (Z ll le lr) e r) , (never returns N)+ {-# INLINE putPLL #-}+ putPLL _ E le lr e r = Z (Z E e0 E) le (Z lr e r) -- r and lr must also be E, special CASE LL!!+ putPLL i (N lll lle llr) le lr e r = let ll' = putN (goL i) lll lle llr -- LL subtree BF<>0, H:h->h, so no change+ in ll' `seq` P (Z ll' le lr) e r+ putPLL i (P lll lle llr) le lr e r = let ll' = putP (goL i) lll lle llr -- LL subtree BF<>0, H:h->h, so no change+ in ll' `seq` P (Z ll' le lr) e r+ putPLL i (Z lll lle llr) le lr e r = let ll' = putZ (goL i) lll lle llr -- LL subtree BF= 0, so need to look for changes+ in case ll' of+ E -> error "insertPath: Bug7" -- impossible+ Z _ _ _ -> P (Z ll' le lr) e r -- LL subtree BF: 0-> 0, H:h->h, so no change+ _ -> Z ll' le (Z lr e r) -- LL subtree BF: 0->+/-1, H:h->h+1, parent BF:-1->-2, CASE LL !!++ -- (putNRL l e rl re rr): Put in RL subtree of (N l e (Z rl re rr)) , (never returns P)+ {-# INLINE putNRL #-}+ putNRL _ l e E re rr = Z (Z l e E) e0 (Z E re rr) -- l and rr must also be E, special CASE LR !!+ putNRL i l e (N rll rle rlr) re rr = let rl' = putN (goL i) rll rle rlr -- RL subtree BF<>0, H:h->h, so no change+ in rl' `seq` N l e (Z rl' re rr)+ putNRL i l e (P rll rle rlr) re rr = let rl' = putP (goL i) rll rle rlr -- RL subtree BF<>0, H:h->h, so no change+ in rl' `seq` N l e (Z rl' re rr)+ putNRL i l e (Z rll rle rlr) re rr = let rl' = putZ (goL i) rll rle rlr -- RL subtree BF= 0, so need to look for changes+ in case rl' of+ E -> error "insertPath: Bug8" -- impossible+ Z _ _ _ -> N l e (Z rl' re rr) -- RL subtree BF: 0-> 0, H:h->h, so no change+ N rll' rle' rlr' -> Z (P l e rll') rle' (Z rlr' re rr) -- RL subtree BF: 0->-1, SO.. CASE RL(1) !!+ P rll' rle' rlr' -> Z (Z l e rll') rle' (N rlr' re rr) -- RL subtree BF: 0->+1, SO.. CASE RL(2) !!++ -- (putPLR ll le lr e r): Put in LR subtree of (P (Z ll le lr) e r) , (never returns N)+ {-# INLINE putPLR #-}+ putPLR _ ll le E e r = Z (Z ll le E) e0 (Z E e r) -- r and ll must also be E, special CASE LR !!+ putPLR i ll le (N lrl lre lrr) e r = let lr' = putN (goR i) lrl lre lrr -- LR subtree BF<>0, H:h->h, so no change+ in lr' `seq` P (Z ll le lr') e r+ putPLR i ll le (P lrl lre lrr) e r = let lr' = putP (goR i) lrl lre lrr -- LR subtree BF<>0, H:h->h, so no change+ in lr' `seq` P (Z ll le lr') e r+ putPLR i ll le (Z lrl lre lrr) e r = let lr' = putZ (goR i) lrl lre lrr -- LR subtree BF= 0, so need to look for changes+ in case lr' of+ E -> error "insertPath: Bug9" -- impossible+ Z _ _ _ -> P (Z ll le lr') e r -- LR subtree BF: 0-> 0, H:h->h, so no change+ N lrl' lre' lrr' -> Z (P ll le lrl') lre' (Z lrr' e r) -- LR subtree BF: 0->-1, SO.. CASE LR(2) !!+ P lrl' lre' lrr' -> Z (Z ll le lrl') lre' (N lrr' e r) -- LR subtree BF: 0->+1, SO.. CASE LR(1) !!+-----------------------------------------------------------------------+----------------------- insertPath Ends Here --------------------------+-----------------------------------------------------------------------+
+ Data/Tree/AVL/Internals/DelUtils.hs view
@@ -0,0 +1,790 @@+{-# OPTIONS_GHC -fglasgow-exts #-}+-----------------------------------------------------------------------------+-- |+-- Module : Data.Tree.AVL.Internals.DelUtils+-- Copyright : (c) Adrian Hey 2004,2005+-- License : BSD3+--+-- Maintainer : http://homepages.nildram.co.uk/~ahey/em.png+-- Stability : stable+-- Portability : portable+--+-- This module defines utility functions for deleting elements from AVL trees.+-----------------------------------------------------------------------------+module Data.Tree.AVL.Internals.DelUtils+ (-- * Deleting utilities.+ delRN,delRZ,delRP,delLN,delLZ,delLP,++ -- * Popping utilities.+ popRN,popRZ,popRP,popLN,popLZ,popLP,+ popHL,popHLN,popHLZ,popHLP,++ -- * Balancing utilities.+ chkLN,chkLZ,chkLP,chkRN,chkRZ,chkRP,+ chkLN',chkLZ',chkLP',chkRN',chkRZ',chkRP',++ -- * Node substitution utilities.+ subN,subZR,subZL,subP,++ -- * BinPath related.+ deletePath,+ ) where++import Data.Tree.AVL.Types(AVL(..))+import Data.Tree.AVL.Internals.BinPath(sel,goL,goR)++#ifdef __GLASGOW_HASKELL__+import GHC.Base+#include "ghcdefs.h"+#else+#include "h98defs.h"+#endif++{------------------------------------------------------------------------------------------------------------------------------+ -------------------------------------- Notes about Deletion and Rebalancing -------------------------------------------------+ ------------------------------------------------------------------------------------------------------------------------------+If you go through a similar analysis to that indicated in the Push.hs module (which I haven't illustrated+here with ASCII art) it can be seen that (as with insertion) the height change in a tree which occurs+as a result of deletion of a node can be infered from the change in BF, (whether or not a re-balancing+rotation was required). The rules are:+ BF +/-1 -> 0, height decreased by 1+ BF 0 -> +/-1, height unchanged.+ BF unchanged , height unchanged.+ BF +/-1 -> -/+1, height unchanged.++Unlike insertion, rebalancing on deletion requires pattern matching on nodes which aren't on the+current path, hence the existance of separate rebalancing functions (rebalN and rebalP).++-----------------------------------------------------------------------------------------------------------------------------+-----------------------------------------------------------------------------------------------------------------------------}+++-----------------------------------------------------------------------+------------------------ delL Starts Here -----------------------------+-----------------------------------------------------------------------+-------------------------- delL LEVEL 1 -------------------------------+-- delLN, delLZ, delLP --+-----------------------------------------------------------------------+-- Delete leftmost from (N l e r)+delLN :: AVL e -> e -> AVL e -> AVL e+delLN E _ r = r -- Terminal case, r must be of form (Z E re E)+delLN (N ll le lr) e r = chkLN (delLN ll le lr) e r+delLN (Z ll le lr) e r = delLNZ ll le lr e r+delLN (P ll le lr) e r = chkLN (delLP ll le lr) e r++-- Delete leftmost from (Z l e r)+delLZ :: AVL e -> e -> AVL e -> AVL e+delLZ E _ _ = E -- Terminal case, r must be E+delLZ (N ll le lr) e r = delLZN ll le lr e r+delLZ (Z ll le lr) e r = delLZZ ll le lr e r+delLZ (P ll le lr) e r = delLZP ll le lr e r++-- Delete leftmost from (P l e r)+delLP :: AVL e -> e -> AVL e -> AVL e+delLP E _ _ = error "delLP: Bug0" -- Impossible if BF=+1+delLP (N ll le lr) e r = chkLP (delLN ll le lr) e r+delLP (Z ll le lr) e r = delLPZ ll le lr e r+delLP (P ll le lr) e r = chkLP (delLP ll le lr) e r++-------------------------- delL LEVEL 2 -------------------------------+-- delLNZ, delLZZ, delLPZ --+-- delLZN, delLZP --+-----------------------------------------------------------------------++-- Delete leftmost from (N (Z ll le lr) e r), height of left sub-tree can't change in this case+{-# INLINE delLNZ #-}+delLNZ :: AVL e -> e -> AVL e -> e -> AVL e -> AVL e+delLNZ E _ _ e r = rebalN E e r -- Terminal case, Needs rebalancing+delLNZ (N lll lle llr) le lr e r = let l' = delLZN lll lle llr le lr in l' `seq` N l' e r+delLNZ (Z lll lle llr) le lr e r = let l' = delLZZ lll lle llr le lr in l' `seq` N l' e r+delLNZ (P lll lle llr) le lr e r = let l' = delLZP lll lle llr le lr in l' `seq` N l' e r++-- Delete leftmost from (Z (Z ll le lr) e r), height of left sub-tree can't change in this case+-- Don't inline+delLZZ :: AVL e -> e -> AVL e -> e -> AVL e -> AVL e+delLZZ E _ _ e r = N E e r -- Terminal case+delLZZ (N lll lle llr) le lr e r = let l' = delLZN lll lle llr le lr in l' `seq` Z l' e r+delLZZ (Z lll lle llr) le lr e r = let l' = delLZZ lll lle llr le lr in l' `seq` Z l' e r+delLZZ (P lll lle llr) le lr e r = let l' = delLZP lll lle llr le lr in l' `seq` Z l' e r++-- Delete leftmost from (P (Z ll le lr) e r), height of left sub-tree can't change in this case+{-# INLINE delLPZ #-}+delLPZ :: AVL e -> e -> AVL e -> e -> AVL e -> AVL e+delLPZ E _ _ e _ = Z E e E -- Terminal case+delLPZ (N lll lle llr) le lr e r = let l' = delLZN lll lle llr le lr in l' `seq` P l' e r+delLPZ (Z lll lle llr) le lr e r = let l' = delLZZ lll lle llr le lr in l' `seq` P l' e r+delLPZ (P lll lle llr) le lr e r = let l' = delLZP lll lle llr le lr in l' `seq` P l' e r++-- Delete leftmost from (Z (N ll le lr) e r)+{-# INLINE delLZN #-}+delLZN :: AVL e -> e -> AVL e -> e -> AVL e -> AVL e+delLZN ll le lr e r = chkLZ (delLN ll le lr) e r++-- Delete leftmost from (Z (P ll le lr) e r)+{-# INLINE delLZP #-}+delLZP :: AVL e -> e -> AVL e -> e -> AVL e -> AVL e+delLZP ll le lr e r = chkLZ (delLP ll le lr) e r+-----------------------------------------------------------------------+-------------------------- delL Ends Here -----------------------------+-----------------------------------------------------------------------++++-----------------------------------------------------------------------+------------------------ delR Starts Here -----------------------------+-----------------------------------------------------------------------+-------------------------- delR LEVEL 1 -------------------------------+-- delRN, delRZ, delRP --+-----------------------------------------------------------------------+-- Delete rightmost from (N l e r)+delRN :: AVL e -> e -> AVL e -> AVL e+delRN _ _ E = error "delRN: Bug0" -- Impossible if BF=-1+delRN l e (N rl re rr) = chkRN l e (delRN rl re rr)+delRN l e (Z rl re rr) = delRNZ l e rl re rr+delRN l e (P rl re rr) = chkRN l e (delRP rl re rr)++-- Delete rightmost from (Z l e r)+delRZ :: AVL e -> e -> AVL e -> AVL e+delRZ _ _ E = E -- Terminal case, l must be E+delRZ l e (N rl re rr) = delRZN l e rl re rr+delRZ l e (Z rl re rr) = delRZZ l e rl re rr+delRZ l e (P rl re rr) = delRZP l e rl re rr++-- Delete rightmost from (P l e r)+delRP :: AVL e -> e -> AVL e -> AVL e+delRP l _ E = l -- Terminal case, l must be of form (Z E le E)+delRP l e (N rl re rr) = chkRP l e (delRN rl re rr)+delRP l e (Z rl re rr) = delRPZ l e rl re rr+delRP l e (P rl re rr) = chkRP l e (delRP rl re rr)++-------------------------- delR LEVEL 2 -------------------------------+-- delRNZ, delRZZ, delRPZ --+-- delRZN, delRZP --+-----------------------------------------------------------------------++-- Delete rightmost from (N l e (Z rl re rr)), height of right sub-tree can't change in this case+delRNZ :: AVL e -> e -> AVL e -> e -> AVL e -> AVL e+{-# INLINE delRNZ #-}+delRNZ _ e _ _ E = Z E e E -- Terminal case+delRNZ l e rl re (N rrl rre rrr) = let r' = delRZN rl re rrl rre rrr in r' `seq` N l e r'+delRNZ l e rl re (Z rrl rre rrr) = let r' = delRZZ rl re rrl rre rrr in r' `seq` N l e r'+delRNZ l e rl re (P rrl rre rrr) = let r' = delRZP rl re rrl rre rrr in r' `seq` N l e r'++-- Delete rightmost from (Z l e (Z rl re rr)), height of right sub-tree can't change in this case+delRZZ :: AVL e -> e -> AVL e -> e -> AVL e -> AVL e+delRZZ l e _ _ E = P l e E -- Terminal case+delRZZ l e rl re (N rrl rre rrr) = let r' = delRZN rl re rrl rre rrr in r' `seq` Z l e r'+delRZZ l e rl re (Z rrl rre rrr) = let r' = delRZZ rl re rrl rre rrr in r' `seq` Z l e r'+delRZZ l e rl re (P rrl rre rrr) = let r' = delRZP rl re rrl rre rrr in r' `seq` Z l e r'++-- Delete rightmost from (P l e (Z rl re rr)), height of right sub-tree can't change in this case+delRPZ :: AVL e -> e -> AVL e -> e -> AVL e -> AVL e+{-# INLINE delRPZ #-}+delRPZ l e _ _ E = rebalP l e E -- Terminal case, Needs rebalancing+delRPZ l e rl re (N rrl rre rrr) = let r' = delRZN rl re rrl rre rrr in r' `seq` P l e r'+delRPZ l e rl re (Z rrl rre rrr) = let r' = delRZZ rl re rrl rre rrr in r' `seq` P l e r'+delRPZ l e rl re (P rrl rre rrr) = let r' = delRZP rl re rrl rre rrr in r' `seq` P l e r'++-- Delete rightmost from (Z l e (N rl re rr))+delRZN :: AVL e -> e -> AVL e -> e -> AVL e -> AVL e+{-# INLINE delRZN #-}+delRZN l e rl re rr = chkRZ l e (delRN rl re rr)++-- Delete rightmost from (Z l e (P rl re rr))+delRZP :: AVL e -> e -> AVL e -> e -> AVL e -> AVL e+{-# INLINE delRZP #-}+delRZP l e rl re rr = chkRZ l e (delRP rl re rr)+-----------------------------------------------------------------------+-------------------------- delR Ends Here -----------------------------+-----------------------------------------------------------------------++++-----------------------------------------------------------------------+------------------------ popL Starts Here -----------------------------+-----------------------------------------------------------------------+-------------------------- popL LEVEL 1 -------------------------------+-- popLN, popLZ, popLP --+-----------------------------------------------------------------------+-- Delete leftmost from (N l e r)+popLN :: AVL e -> e -> AVL e -> UBT2(e,AVL e)+popLN E e r = UBT2(e,r) -- Terminal case, r must be of form (Z E re E)+popLN (N ll le lr) e r = case popLN ll le lr of+ UBT2(v,l) -> let t = chkLN l e r in t `seq` UBT2(v,t)+popLN (Z ll le lr) e r = popLNZ ll le lr e r+popLN (P ll le lr) e r = case popLP ll le lr of+ UBT2(v,l) -> let t = chkLN l e r in t `seq` UBT2(v,t)++-- Delete leftmost from (Z l e r)+popLZ :: AVL e -> e -> AVL e -> UBT2(e,AVL e)+popLZ E e _ = UBT2(e,E) -- Terminal case, r must be E+popLZ (N ll le lr) e r = popLZN ll le lr e r+popLZ (Z ll le lr) e r = popLZZ ll le lr e r+popLZ (P ll le lr) e r = popLZP ll le lr e r++-- Delete leftmost from (P l e r)+popLP :: AVL e -> e -> AVL e -> UBT2(e,AVL e)+popLP E _ _ = error "popLP: Bug!" -- Impossible if BF=+1+popLP (N ll le lr) e r = case popLN ll le lr of+ UBT2(v,l) -> let t = chkLP l e r in t `seq` UBT2(v,t)+popLP (Z ll le lr) e r = popLPZ ll le lr e r+popLP (P ll le lr) e r = case popLP ll le lr of+ UBT2(v,l) -> let t = chkLP l e r in t `seq` UBT2(v,t)++-------------------------- popL LEVEL 2 -------------------------------+-- popLNZ, popLZZ, popLPZ --+-- popLZN, popLZP --+-----------------------------------------------------------------------++-- Delete leftmost from (N (Z ll le lr) e r), height of left sub-tree can't change in this case+popLNZ :: AVL e -> e -> AVL e -> e -> AVL e -> UBT2(e,AVL e)+{-# INLINE popLNZ #-}+popLNZ E le _ e r = let t = rebalN E e r -- Terminal case, Needs rebalancing+ in t `seq` UBT2(le,t)+popLNZ (N lll lle llr) le lr e r = case popLZN lll lle llr le lr of+ UBT2(v,l) -> UBT2(v, N l e r)+popLNZ (Z lll lle llr) le lr e r = case popLZZ lll lle llr le lr of+ UBT2(v,l) -> UBT2(v, N l e r)+popLNZ (P lll lle llr) le lr e r = case popLZP lll lle llr le lr of+ UBT2(v,l) -> UBT2(v, N l e r)++-- Delete leftmost from (Z (Z ll le lr) e r), height of left sub-tree can't change in this case+-- Don't INLINE this!+popLZZ :: AVL e -> e -> AVL e -> e -> AVL e -> UBT2(e,AVL e)+popLZZ E le _ e r = UBT2(le, N E e r) -- Terminal case+popLZZ (N lll lle llr) le lr e r = case popLZN lll lle llr le lr of+ UBT2(v,l) -> UBT2(v, Z l e r)+popLZZ (Z lll lle llr) le lr e r = case popLZZ lll lle llr le lr of+ UBT2(v,l) -> UBT2(v, Z l e r)+popLZZ (P lll lle llr) le lr e r = case popLZP lll lle llr le lr of+ UBT2(v,l) -> UBT2(v, Z l e r)++-- Delete leftmost from (P (Z ll le lr) e r), height of left sub-tree can't change in this case+popLPZ :: AVL e -> e -> AVL e -> e -> AVL e -> UBT2(e,AVL e)+{-# INLINE popLPZ #-}+popLPZ E le _ e _ = UBT2(le, Z E e E) -- Terminal case+popLPZ (N lll lle llr) le lr e r = case popLZN lll lle llr le lr of+ UBT2(v,l) -> UBT2(v, P l e r)+popLPZ (Z lll lle llr) le lr e r = case popLZZ lll lle llr le lr of+ UBT2(v,l) -> UBT2(v, P l e r)+popLPZ (P lll lle llr) le lr e r = case popLZP lll lle llr le lr of+ UBT2(v,l) -> UBT2(v, P l e r)++-- Delete leftmost from (Z (N ll le lr) e r)+-- Don't INLINE this!+popLZN :: AVL e -> e -> AVL e -> e -> AVL e -> UBT2(e,AVL e)+popLZN ll le lr e r = case popLN ll le lr of+ UBT2(v,l) -> let t = chkLZ l e r in t `seq` UBT2(v,t)+-- Delete leftmost from (Z (P ll le lr) e r)+-- Don't INLINE this!+popLZP :: AVL e -> e -> AVL e -> e -> AVL e -> UBT2(e,AVL e)+popLZP ll le lr e r = case popLP ll le lr of+ UBT2(v,l) -> let t = chkLZ l e r in t `seq` UBT2(v,t)+-----------------------------------------------------------------------+-------------------------- popL Ends Here -----------------------------+-----------------------------------------------------------------------++++-----------------------------------------------------------------------+------------------------ popR Starts Here -----------------------------+-----------------------------------------------------------------------+-------------------------- popR LEVEL 1 -------------------------------+-- popRN, popRZ, popRP --+-----------------------------------------------------------------------+-- Delete rightmost from (N l e r)+popRN :: AVL e -> e -> AVL e -> UBT2(AVL e,e)+popRN _ _ E = error "popRN: Bug!" -- Impossible if BF=-1+popRN l e (N rl re rr) = case popRN rl re rr of+ UBT2(r,v) -> let t = chkRN l e r in t `seq` UBT2(t,v)+popRN l e (Z rl re rr) = popRNZ l e rl re rr+popRN l e (P rl re rr) = case popRP rl re rr of+ UBT2(r,v) -> let t = chkRN l e r in t `seq` UBT2(t,v)++-- Delete rightmost from (Z l e r)+popRZ :: AVL e -> e -> AVL e -> UBT2(AVL e,e)+popRZ _ e E = UBT2(E,e) -- Terminal case, l must be E+popRZ l e (N rl re rr) = popRZN l e rl re rr+popRZ l e (Z rl re rr) = popRZZ l e rl re rr+popRZ l e (P rl re rr) = popRZP l e rl re rr++-- Delete rightmost from (P l e r)+popRP :: AVL e -> e -> AVL e -> UBT2(AVL e,e)+popRP l e E = UBT2(l,e) -- Terminal case, l must be of form (Z E le E)+popRP l e (N rl re rr) = case popRN rl re rr of+ UBT2(r,v) -> let t = chkRP l e r in t `seq` UBT2(t,v)+popRP l e (Z rl re rr) = popRPZ l e rl re rr+popRP l e (P rl re rr) = case popRP rl re rr of+ UBT2(r,v) -> let t = chkRP l e r in t `seq` UBT2(t,v)++-------------------------- popR LEVEL 2 -------------------------------+-- popRNZ, popRZZ, popRPZ --+-- popRZN, popRZP --+-----------------------------------------------------------------------++-- Delete rightmost from (N l e (Z rl re rr)), height of right sub-tree can't change in this case+popRNZ :: AVL e -> e -> AVL e -> e -> AVL e -> UBT2(AVL e,e)+{-# INLINE popRNZ #-}+popRNZ _ e _ re E = UBT2(Z E e E, re) -- Terminal case+popRNZ l e rl re (N rrl rre rrr) = case popRZN rl re rrl rre rrr of+ UBT2(r,v) -> UBT2(N l e r, v)+popRNZ l e rl re (Z rrl rre rrr) = case popRZZ rl re rrl rre rrr of+ UBT2(r,v) -> UBT2(N l e r, v)+popRNZ l e rl re (P rrl rre rrr) = case popRZP rl re rrl rre rrr of+ UBT2(r,v) -> UBT2(N l e r, v)++-- Delete rightmost from (Z l e (Z rl re rr)), height of right sub-tree can't change in this case+-- Don't INLINE this!+popRZZ :: AVL e -> e -> AVL e -> e -> AVL e -> UBT2(AVL e,e)+popRZZ l e _ re E = UBT2(P l e E, re) -- Terminal case+popRZZ l e rl re (N rrl rre rrr) = case popRZN rl re rrl rre rrr of+ UBT2(r,v) -> UBT2(Z l e r, v)+popRZZ l e rl re (Z rrl rre rrr) = case popRZZ rl re rrl rre rrr of+ UBT2(r,v) -> UBT2(Z l e r, v)+popRZZ l e rl re (P rrl rre rrr) = case popRZP rl re rrl rre rrr of+ UBT2(r,v) -> UBT2(Z l e r, v)++-- Delete rightmost from (P l e (Z rl re rr)), height of right sub-tree can't change in this case+popRPZ :: AVL e -> e -> AVL e -> e -> AVL e -> UBT2(AVL e,e)+{-# INLINE popRPZ #-}+popRPZ l e _ re E = let t = rebalP l e E -- Terminal case, Needs rebalancing+ in t `seq` UBT2(t,re)+popRPZ l e rl re (N rrl rre rrr) = case popRZN rl re rrl rre rrr of+ UBT2(r,v) -> UBT2(P l e r, v)+popRPZ l e rl re (Z rrl rre rrr) = case popRZZ rl re rrl rre rrr of+ UBT2(r,v) -> UBT2(P l e r, v)+popRPZ l e rl re (P rrl rre rrr) = case popRZP rl re rrl rre rrr of+ UBT2(r,v) -> UBT2(P l e r, v)++-- Delete rightmost from (Z l e (N rl re rr))+-- Don't INLINE this!+popRZN :: AVL e -> e -> AVL e -> e -> AVL e -> UBT2(AVL e,e)+popRZN l e rl re rr = case popRN rl re rr of+ UBT2(r,v) -> let t = chkRZ l e r in t `seq` UBT2(t,v)++-- Delete rightmost from (Z l e (P rl re rr))+-- Don't INLINE this!+popRZP :: AVL e -> e -> AVL e -> e -> AVL e -> UBT2(AVL e,e)+popRZP l e rl re rr = case popRP rl re rr of+ UBT2(r,v) -> let t = chkRZ l e r in t `seq` UBT2(t,v)+-----------------------------------------------------------------------+-------------------------- popR Ends Here -----------------------------+-----------------------------------------------------------------------++++-----------------------------------------------------------------------+--------------------- deletePath Starts Here --------------------------+-----------------------------------------------------------------------+-- | Deletes a tree element. Assumes the path bits were extracted from a 'FullBP' constructor.+--+-- Complexity: O(log n)+deletePath :: UINT -> AVL e -> AVL e+deletePath _ E = error "deletePath: Element not found."+deletePath p (N l e r) = delN p l e r+deletePath p (Z l e r) = delZ p l e r+deletePath p (P l e r) = delP p l e r++----------------------------- LEVEL 1 ---------------------------------+-- delN, delZ, delP --+-----------------------------------------------------------------------++-- Delete from (N l e r)+delN :: UINT -> AVL e -> e -> AVL e -> AVL e+delN p l e r = case sel p of+ LT -> delNL p l e r+ EQ -> subN l r+ GT -> delNR p l e r++-- Delete from (Z l e r)+delZ :: UINT -> AVL e -> e -> AVL e -> AVL e+delZ p l e r = case sel p of+ LT -> delZL p l e r+ EQ -> subZR l r+ GT -> delZR p l e r++-- Delete from (P l e r)+delP :: UINT -> AVL e -> e -> AVL e -> AVL e+delP p l e r = case sel p of+ LT -> delPL p l e r+ EQ -> subP l r+ GT -> delPR p l e r++----------------------------- LEVEL 2 ---------------------------------+-- delNL, delZL, delPL --+-- delNR, delZR, delPR --+-----------------------------------------------------------------------++-- Delete from the left subtree of (N l e r)+delNL :: UINT -> AVL e -> e -> AVL e -> AVL e+delNL p t = dNL (goL p) t+{-# INLINE dNL #-}+dNL :: UINT -> AVL e -> e -> AVL e -> AVL e+dNL _ E _ _ = error "deletePath: Element not found." -- Left sub-tree is empty+dNL p (N ll le lr) e r = case sel p of+ LT -> chkLN (delNL p ll le lr) e r+ EQ -> chkLN (subN ll lr) e r+ GT -> chkLN (delNR p ll le lr) e r+dNL p (Z ll le lr) e r = case sel p of+ LT -> let l' = delZL p ll le lr in l' `seq` N l' e r -- height can't change+ EQ -> chkLN' (subZR ll lr) e r -- << But it can here+ GT -> let l' = delZR p ll le lr in l' `seq` N l' e r -- height can't change+dNL p (P ll le lr) e r = case sel p of+ LT -> chkLN (delPL p ll le lr) e r+ EQ -> chkLN (subP ll lr) e r+ GT -> chkLN (delPR p ll le lr) e r++-- Delete from the right subtree of (N l e r)+delNR :: UINT -> AVL e -> e -> AVL e -> AVL e+delNR p t = dNR (goR p) t+{-# INLINE dNR #-}+dNR :: UINT -> AVL e -> e -> AVL e -> AVL e+dNR _ _ _ E = error "delNR: Bug0" -- Impossible+dNR p l e (N rl re rr) = case sel p of+ LT -> chkRN l e (delNL p rl re rr)+ EQ -> chkRN l e (subN rl rr)+ GT -> chkRN l e (delNR p rl re rr)+dNR p l e (Z rl re rr) = case sel p of+ LT -> let r' = delZL p rl re rr in r' `seq` N l e r' -- height can't change+ EQ -> chkRN' l e (subZL rl rr) -- << But it can here+ GT -> let r' = delZR p rl re rr in r' `seq` N l e r' -- height can't change+dNR p l e (P rl re rr) = case sel p of+ LT -> chkRN l e (delPL p rl re rr)+ EQ -> chkRN l e (subP rl rr)+ GT -> chkRN l e (delPR p rl re rr)++-- Delete from the left subtree of (Z l e r)+delZL :: UINT -> AVL e -> e -> AVL e -> AVL e+delZL p t = dZL (goL p) t+{-# INLINE dZL #-}+dZL :: UINT -> AVL e -> e -> AVL e -> AVL e+dZL _ E _ _ = error "deletePath: Element not found." -- Left sub-tree is empty+dZL p (N ll le lr) e r = case sel p of+ LT -> chkLZ (delNL p ll le lr) e r+ EQ -> chkLZ (subN ll lr) e r+ GT -> chkLZ (delNR p ll le lr) e r+dZL p (Z ll le lr) e r = case sel p of+ LT -> let l' = delZL p ll le lr in l' `seq` Z l' e r -- height can't change+ EQ -> chkLZ' (subZR ll lr) e r -- << But it can here+ GT -> let l' = delZR p ll le lr in l' `seq` Z l' e r -- height can't change+dZL p (P ll le lr) e r = case sel p of+ LT -> chkLZ (delPL p ll le lr) e r+ EQ -> chkLZ (subP ll lr) e r+ GT -> chkLZ (delPR p ll le lr) e r++-- Delete from the right subtree of (Z l e r)+delZR :: UINT -> AVL e -> e -> AVL e -> AVL e+delZR p t = dZR (goR p) t+{-# INLINE dZR #-}+dZR :: UINT -> AVL e -> e -> AVL e -> AVL e+dZR _ _ _ E = error "deletePath: Element not found." -- Right sub-tree is empty+dZR p l e (N rl re rr) = case sel p of+ LT -> chkRZ l e (delNL p rl re rr)+ EQ -> chkRZ l e (subN rl rr)+ GT -> chkRZ l e (delNR p rl re rr)+dZR p l e (Z rl re rr) = case sel p of+ LT -> let r' = delZL p rl re rr in r' `seq` Z l e r' -- height can't change+ EQ -> chkRZ' l e (subZL rl rr) -- << But it can here+ GT -> let r' = delZR p rl re rr in r' `seq` Z l e r' -- height can't change+dZR p l e (P rl re rr) = case sel p of+ LT -> chkRZ l e (delPL p rl re rr)+ EQ -> chkRZ l e (subP rl rr)+ GT -> chkRZ l e (delPR p rl re rr)++-- Delete from the left subtree of (P l e r)+delPL :: UINT -> AVL e -> e -> AVL e -> AVL e+delPL p t = dPL (goL p) t+{-# INLINE dPL #-}+dPL :: UINT -> AVL e -> e -> AVL e -> AVL e+dPL _ E _ _ = error "delPL: Bug0" -- Impossible+dPL p (N ll le lr) e r = case sel p of+ LT -> chkLP (delNL p ll le lr) e r+ EQ -> chkLP (subN ll lr) e r+ GT -> chkLP (delNR p ll le lr) e r+dPL p (Z ll le lr) e r = case sel p of+ LT -> let l' = delZL p ll le lr in l' `seq` P l' e r -- height can't change+ EQ -> chkLP' (subZR ll lr) e r -- << But it can here+ GT -> let l' = delZR p ll le lr in l' `seq` P l' e r -- height can't change+dPL p (P ll le lr) e r = case sel p of+ LT -> chkLP (delPL p ll le lr) e r+ EQ -> chkLP (subP ll lr) e r+ GT -> chkLP (delPR p ll le lr) e r++-- Delete from the right subtree of (P l e r)+delPR :: UINT -> AVL e -> e -> AVL e -> AVL e+delPR p t = dPR (goR p) t+{-# INLINE dPR #-}+dPR :: UINT -> AVL e -> e -> AVL e -> AVL e+dPR _ _ _ E = error "deletePath: Element not found." -- Right sub-tree is empty+dPR p l e (N rl re rr) = case sel p of+ LT -> chkRP l e (delNL p rl re rr)+ EQ -> chkRP l e (subN rl rr)+ GT -> chkRP l e (delNR p rl re rr)+dPR p l e (Z rl re rr) = case sel p of+ LT -> let r' = delZL p rl re rr in r' `seq` P l e r' -- height can't change+ EQ -> chkRP' l e (subZL rl rr) -- << But it can here+ GT -> let r' = delZR p rl re rr in r' `seq` P l e r' -- height can't change+dPR p l e (P rl re rr) = case sel p of+ LT -> chkRP l e (delPL p rl re rr)+ EQ -> chkRP l e (subP rl rr)+ GT -> chkRP l e (delPR p rl re rr)+-----------------------------------------------------------------------+----------------------- deletePath Ends Here --------------------------+-----------------------------------------------------------------------++++-------------------------------------------------------------------------------------+-- This is a modified version of popL which returns the (popped) tree height as well.+-------------------------------------------------------------------------------------+popHL :: AVL e -> UBT3(e,AVL e,UINT)+popHL E = error "popHL: Empty tree."+popHL (N l e r) = popHLN l e r+popHL (Z l e r) = popHLZ l e r+popHL (P l e r) = popHLP l e r++popHLN :: AVL e -> e -> AVL e -> UBT3(e,AVL e,UINT)+popHLN l e r = case popHLN_ L(2) l e r of+ UBT3(e_,t,h) -> case t of+ E -> error "popHLN: Bug0" -- impossible+ Z _ _ _ -> UBT3(e_,t,DECINT1(h)) -- dH = -1+ _ -> UBT3(e_,t, h ) -- dH = 0++popHLZ :: AVL e -> e -> AVL e -> UBT3(e,AVL e,UINT)+popHLZ l e r = case popHLZ_ L(1) l e r of+ UBT3(e_,t,h) -> case t of+ E -> UBT3(e,E,L(0)) -- Resulting tree is empty+ P _ _ _ -> error "popHLZ: Bug0" -- impossible+ _ -> UBT3(e_,t, h ) -- dH = 0++popHLP :: AVL e -> e -> AVL e -> UBT3(e,AVL e,UINT)+popHLP l e r = case popHLP_ L(1) l e r of+ UBT3(e_,t,h) -> case t of+ Z _ _ _ -> UBT3(e_,t,DECINT1(h)) -- dH = -1+ P _ _ _ -> UBT3(e_,t, h ) -- dH = 0+ _ -> error "popHLP: Bug0" -- impossible++-------------------------- popHL LEVEL 1 ------------------------------+-- popHLN_, popHLZ_, popHLP_ --+-----------------------------------------------------------------------+-- Delete leftmost from (N l e r)+popHLN_ :: UINT -> AVL e -> e -> AVL e -> UBT3(e,AVL e,UINT)+popHLN_ h E e r = UBT3(e,r,h) -- Terminal case, r must be of form (Z E re E)+popHLN_ h (N ll le lr) e r = case popHLN_ INCINT2(h) ll le lr of+ UBT3(e_,l,hl) -> let t = chkLN l e r in t `seq` UBT3(e_,t,hl)+popHLN_ h (Z ll le lr) e r = popHLNZ INCINT1(h) ll le lr e r+popHLN_ h (P ll le lr) e r = case popHLP_ INCINT1(h) ll le lr of+ UBT3(e_,l,hl) -> let t = chkLN l e r in t `seq` UBT3(e_,t,hl)++-- Delete leftmost from (Z l e r)+{-# INLINE popHLZ_ #-}+popHLZ_ :: UINT -> AVL e -> e -> AVL e -> UBT3(e,AVL e,UINT)+popHLZ_ h E e _ = UBT3(e,E,h) -- Terminal case, r must be E+popHLZ_ h (N ll le lr) e r = popHLZN INCINT2(h) ll le lr e r+popHLZ_ h (Z ll le lr) e r = popHLZZ INCINT1(h) ll le lr e r+popHLZ_ h (P ll le lr) e r = popHLZP INCINT1(h) ll le lr e r++-- Delete leftmost from (P l e r)+popHLP_ :: UINT -> AVL e -> e -> AVL e -> UBT3(e,AVL e,UINT)+popHLP_ _ E _ _ = error "popHLP_: Bug0" -- Impossible if BF=+1+popHLP_ h (N ll le lr) e r = case popHLN_ INCINT2(h) ll le lr of+ UBT3(e_,l,hl) -> let t = chkLP l e r in t `seq` UBT3(e_,t,hl)+popHLP_ h (Z ll le lr) e r = popHLPZ INCINT1(h) ll le lr e r+popHLP_ h (P ll le lr) e r = case popHLP_ INCINT1(h) ll le lr of+ UBT3(e_,l,hl) -> let t = chkLP l e r in t `seq` UBT3(e_,t,hl)++-------------------------- popHL LEVEL 2 ------------------------------+-- popHLNZ, popHLZZ, popHLPZ --+-- popHLZN, popHLZP --+-----------------------------------------------------------------------++-- Delete leftmost from (N (Z ll le lr) e r), height of left sub-tree can't change in this case+{-# INLINE popHLNZ #-}+popHLNZ :: UINT -> AVL e -> e -> AVL e -> e -> AVL e -> UBT3(e,AVL e,UINT)+popHLNZ h E le _ e r = let t = rebalN E e r -- Terminal case, Needs rebalancing+ in t `seq` UBT3(le,t,h)+popHLNZ h (N lll lle llr) le lr e r = case popHLZN INCINT2(h) lll lle llr le lr of+ UBT3(e_,l,hl) -> UBT3(e_, N l e r, hl)+popHLNZ h (Z lll lle llr) le lr e r = case popHLZZ INCINT1(h) lll lle llr le lr of+ UBT3(e_,l,hl) -> UBT3(e_, N l e r, hl)+popHLNZ h (P lll lle llr) le lr e r = case popHLZP INCINT1(h) lll lle llr le lr of+ UBT3(e_,l,hl) -> UBT3(e_, N l e r, hl)++-- Delete leftmost from (Z (Z ll le lr) e r), height of left sub-tree can't change in this case+-- Don't INLINE this!+popHLZZ :: UINT -> AVL e -> e -> AVL e -> e -> AVL e -> UBT3(e,AVL e,UINT)+popHLZZ h E le _ e r = UBT3(le, N E e r, h) -- Terminal case+popHLZZ h (N lll lle llr) le lr e r = case popHLZN INCINT2(h) lll lle llr le lr of+ UBT3(e_,l,hl) -> UBT3(e_, Z l e r, hl)+popHLZZ h (Z lll lle llr) le lr e r = case popHLZZ INCINT1(h) lll lle llr le lr of+ UBT3(e_,l,hl) -> UBT3(e_, Z l e r, hl)+popHLZZ h (P lll lle llr) le lr e r = case popHLZP INCINT1(h) lll lle llr le lr of+ UBT3(e_,l,hl) -> UBT3(e_, Z l e r, hl)++-- Delete leftmost from (P (Z ll le lr) e r), height of left sub-tree can't change in this case+{-# INLINE popHLPZ #-}+popHLPZ :: UINT -> AVL e -> e -> AVL e -> e -> AVL e -> UBT3(e,AVL e,UINT)+popHLPZ h E le _ e _ = UBT3(le, Z E e E, h) -- Terminal case+popHLPZ h (N lll lle llr) le lr e r = case popHLZN INCINT2(h) lll lle llr le lr of+ UBT3(e_,l,hl) -> UBT3(e_, P l e r, hl)+popHLPZ h (Z lll lle llr) le lr e r = case popHLZZ INCINT1(h) lll lle llr le lr of+ UBT3(e_,l,hl) -> UBT3(e_, P l e r, hl)+popHLPZ h (P lll lle llr) le lr e r = case popHLZP INCINT1(h) lll lle llr le lr of+ UBT3(e_,l,hl) -> UBT3(e_, P l e r, hl)++-- Delete leftmost from (Z (N ll le lr) e r)+-- Don't INLINE this!+popHLZN :: UINT -> AVL e -> e -> AVL e -> e -> AVL e -> UBT3(e,AVL e,UINT)+popHLZN h ll le lr e r = case popHLN_ h ll le lr of+ UBT3(e_,l,hl) -> let t = chkLZ l e r in t `seq` UBT3(e_,t,hl)+-- Delete leftmost from (Z (P ll le lr) e r)+-- Don't INLINE this!+popHLZP :: UINT -> AVL e -> e -> AVL e -> e -> AVL e -> UBT3(e,AVL e,UINT)+popHLZP h ll le lr e r = case popHLP_ h ll le lr of+ UBT3(e_,l,hl) -> let t = chkLZ l e r in t `seq` UBT3(e_,t,hl)+-----------------------------------------------------------------------+------------------------- popHL Ends Here -----------------------------+-----------------------------------------------------------------------++{-************************** Balancing Utilities Below Here ************************************-}++-- Rebalance a tree of form (N l e r) which has become unbalanced as+-- a result of the height of the left sub-tree (l) decreasing by 1.+-- N.B Result is never of form (N _ _ _) (or E!)+rebalN :: AVL e -> e -> AVL e -> AVL e+rebalN _ _ E = error "rebalN: Bug0" -- impossible case+rebalN l e (N rl re rr) = Z (Z l e rl) re rr -- N->Z, dH=-1+rebalN l e (Z rl re rr) = P (N l e rl) re rr -- N->P, dH= 0+rebalN _ _ (P E _ _) = error "rebalN: Bug1" -- impossible case+rebalN l e (P (N rll rle rlr) re rr) = Z (P l e rll) rle (Z rlr re rr) -- N->Z, dH=-1+rebalN l e (P (Z rll rle rlr) re rr) = Z (Z l e rll) rle (Z rlr re rr) -- N->Z, dH=-1+rebalN l e (P (P rll rle rlr) re rr) = Z (Z l e rll) rle (N rlr re rr) -- N->Z, dH=-1++-- Rebalance a tree of form (P l e r) which has become unbalanced as+-- a result of the height of the right sub-tree (r) decreasing by 1.+-- N.B Result is never of form (P _ _ _) (or E!)+rebalP :: AVL e -> e -> AVL e -> AVL e+rebalP E _ _ = error "rebalP: Bug0" -- impossible case+rebalP (P ll le lr ) e r = Z ll le (Z lr e r) -- P->Z, dH=-1+rebalP (Z ll le lr ) e r = N ll le (P lr e r) -- P->N, dH= 0+rebalP (N _ _ E ) _ _ = error "rebalP: Bug1" -- impossible case+rebalP (N ll le (P lrl lre lrr)) e r = Z (Z ll le lrl) lre (N lrr e r) -- P->Z, dH=-1+rebalP (N ll le (Z lrl lre lrr)) e r = Z (Z ll le lrl) lre (Z lrr e r) -- P->Z, dH=-1+rebalP (N ll le (N lrl lre lrr)) e r = Z (P ll le lrl) lre (Z lrr e r) -- P->Z, dH=-1++-- Check for height changes in left subtree of (N l e r),+-- where l was (N ll le lr) or (P ll le lr)+chkLN :: AVL e -> e -> AVL e -> AVL e+chkLN l e r = case l of+ E -> error "chkLN: Bug0" -- impossible if BF<>0+ N _ _ _ -> N l e r -- BF +/-1 -> -1, so dH= 0+ Z _ _ _ -> rebalN l e r -- BF +/-1 -> 0, so dH=-1+ P _ _ _ -> N l e r -- BF +/-1 -> +1, so dH= 0+-- Check for height changes in left subtree of (Z l e r),+-- where l was (N ll le lr) or (P ll le lr)+chkLZ :: AVL e -> e -> AVL e -> AVL e+chkLZ l e r = case l of+ E -> error "chkLZ: Bug0" -- impossible if BF<>0+ N _ _ _ -> Z l e r -- BF +/-1 -> -1, so dH= 0+ Z _ _ _ -> N l e r -- BF +/-1 -> 0, so dH=-1+ P _ _ _ -> Z l e r -- BF +/-1 -> +1, so dH= 0+-- Check for height changes in left subtree of (P l e r),+-- where l was (N ll le lr) or (P ll le lr)+chkLP :: AVL e -> e -> AVL e -> AVL e+chkLP l e r = case l of+ E -> error "chkLP: Bug0" -- impossible if BF<>0+ N _ _ _ -> P l e r -- BF +/-1 -> -1, so dH= 0+ Z _ _ _ -> Z l e r -- BF +/-1 -> 0, so dH=-1+ P _ _ _ -> P l e r -- BF +/-1 -> +1, so dH= 0+-- Check for height changes in right subtree of (N l e r),+-- where r was (N rl re rr) or (P rl re rr)+chkRN :: AVL e -> e -> AVL e -> AVL e+chkRN l e r = case r of+ E -> error "chkRN: Bug0" -- impossible if BF<>0+ N _ _ _ -> N l e r -- BF +/-1 -> -1, so dH= 0+ Z _ _ _ -> Z l e r -- BF +/-1 -> 0, so dH=-1+ P _ _ _ -> N l e r -- BF +/-1 -> +1, so dH= 0+-- Check for height changes in right subtree of (Z l e r),+-- where r was (N rl re rr) or (P rl re rr)+chkRZ :: AVL e -> e -> AVL e -> AVL e+chkRZ l e r = case r of+ E -> error "chkRZ: Bug0" -- impossible if BF<>0+ N _ _ _ -> Z l e r -- BF +/-1 -> -1, so dH= 0+ Z _ _ _ -> P l e r -- BF +/-1 -> 0, so dH=-1+ P _ _ _ -> Z l e r -- BF +/-1 -> +1, so dH= 0+-- Check for height changes in right subtree of (P l e r),+-- where l was (N rl re rr) or (P rl re rr)+chkRP :: AVL e -> e -> AVL e -> AVL e+chkRP l e r = case r of+ E -> error "chkRP: Bug0" -- impossible if BF<>0+ N _ _ _ -> P l e r -- BF +/-1 -> -1, so dH= 0+ Z _ _ _ -> rebalP l e r -- BF +/-1 -> 0, so dH=-1+ P _ _ _ -> P l e r -- BF +/-1 -> +1, so dH= 0++-- Substitute deleted element from (N l _ r)+subN :: AVL e -> AVL e -> AVL e+subN _ E = error "subN: Bug0" -- Impossible+subN l (N rl re rr) = case popLN rl re rr of UBT2(e,r_) -> chkRN l e r_+subN l (Z rl re rr) = case popLZ rl re rr of UBT2(e,r_) -> chkRN' l e r_+subN l (P rl re rr) = case popLP rl re rr of UBT2(e,r_) -> chkRN l e r_++-- Substitute deleted element from (Z l _ r)+-- Pops the replacement from the right sub-tree, so result may be (P _ _ _)+subZR :: AVL e -> AVL e -> AVL e+subZR _ E = E -- Both left and right subtrees must have been empty+subZR l (N rl re rr) = case popLN rl re rr of UBT2(e,r_) -> chkRZ l e r_+subZR l (Z rl re rr) = case popLZ rl re rr of UBT2(e,r_) -> chkRZ' l e r_+subZR l (P rl re rr) = case popLP rl re rr of UBT2(e,r_) -> chkRZ l e r_++-- Local utility to substitute deleted element from (Z l _ r)+-- Pops the replacement from the left sub-tree, so result may be (N _ _ _)+subZL :: AVL e -> AVL e -> AVL e+subZL E _ = E -- Both left and right subtrees must have been empty+subZL (N ll le lr) r = case popRN ll le lr of UBT2(l_,e) -> chkLZ l_ e r+subZL (Z ll le lr) r = case popRZ ll le lr of UBT2(l_,e) -> chkLZ' l_ e r+subZL (P ll le lr) r = case popRP ll le lr of UBT2(l_,e) -> chkLZ l_ e r++-- Substitute deleted element from (P l _ r)+subP :: AVL e -> AVL e -> AVL e+subP E _ = error "subP: Bug0" -- Impossible+subP (N ll le lr) r = case popRN ll le lr of UBT2(l_,e) -> chkLP l_ e r+subP (Z ll le lr) r = case popRZ ll le lr of UBT2(l_,e) -> chkLP' l_ e r+subP (P ll le lr) r = case popRP ll le lr of UBT2(l_,e) -> chkLP l_ e r++-- Check for height changes in left subtree of (N l e r),+-- where l was (Z ll le lr)+chkLN' :: AVL e -> e -> AVL e -> AVL e+chkLN' l e r = case l of+ E -> rebalN l e r -- BF 0 -> E, so dH=-1+ _ -> N l e r -- Otherwise dH=0+-- Check for height changes in left subtree of (Z l e r),+-- where l was (Z ll le lr)+chkLZ' :: AVL e -> e -> AVL e -> AVL e+chkLZ' l e r = case l of+ E -> N l e r -- BF 0 -> E, so dH=-1+ _ -> Z l e r -- Otherwise dH=0+-- Check for height changes in left subtree of (P l e r),+-- where l was (Z ll le lr)+chkLP' :: AVL e -> e -> AVL e -> AVL e+chkLP' l e r = case l of+ E -> Z l e r -- BF 0 -> E, so dH=-1+ _ -> P l e r -- Otherwise dH=0+-- Check for height changes in right subtree of (N l e r),+-- where r was (Z rl re rr)+chkRN' :: AVL e -> e -> AVL e -> AVL e+chkRN' l e r = case r of+ E -> Z l e r -- BF 0 -> E, so dH=-1+ _ -> N l e r -- Otherwise dH=0+-- Check for height changes in right subtree of (Z l e r),+-- where r was (Z rl re rr)+chkRZ' :: AVL e -> e -> AVL e -> AVL e+chkRZ' l e r = case r of+ E -> P l e r -- BF 0 -> E, so dH=-1+ _ -> Z l e r -- Otherwise dH=0+-- Check for height changes in right subtree of (P l e r),+-- where l was (Z rl re rr)+chkRP' :: AVL e -> e -> AVL e -> AVL e+chkRP' l e r = case r of+ E -> rebalP l e r -- BF 0 -> E, so dH=-1+ _ -> P l e r -- Otherwise dH=0+
+ Data/Tree/AVL/Internals/HAVL.hs view
@@ -0,0 +1,98 @@+{-# OPTIONS_GHC -fglasgow-exts #-}+-----------------------------------------------------------------------------+-- |+-- Module : Data.Tree.AVL.Internals.HAVL+-- Copyright : (c) Adrian Hey 2004,2005+-- License : BSD3+--+-- Maintainer : http://homepages.nildram.co.uk/~ahey/em.png+-- Stability : stable+-- Portability : portable+--+-- HAVL data type and related utilities+-----------------------------------------------------------------------------+module Data.Tree.AVL.Internals.HAVL+ (+ HAVL(HAVL),emptyHAVL,toHAVL,isEmptyHAVL,isNonEmptyHAVL,+ spliceHAVL,joinHAVL,+ pushLHAVL,pushRHAVL+ ) where++import Data.Tree.AVL.Types(AVL(..))+import Data.Tree.AVL.Internals.HeightUtils(addHeight)+import Data.Tree.AVL.Internals.HJoin(spliceH,joinH)+import Data.Tree.AVL.Internals.HPush(pushHL,pushHR)++#ifdef __GLASGOW_HASKELL__+import GHC.Base+#include "ghcdefs.h"+#else+#include "h98defs.h"+#endif++-- | An HAVL represents an AVL tree of known height.+data HAVL e = HAVL (AVL e) {-# UNPACK #-} !UINT++-- | Empty HAVL (height is 0).+emptyHAVL :: HAVL e+emptyHAVL = HAVL E L(0)++-- | Returns 'True' if the AVL component of an HAVL tree is empty. Note that height component+-- is ignored, so it's OK to use this function in cases where the height is relative.+--+-- Complexity: O(1)+{-# INLINE isEmptyHAVL #-}+isEmptyHAVL :: HAVL e -> Bool+isEmptyHAVL (HAVL E _) = True+isEmptyHAVL (HAVL _ _) = False++-- | Returns 'True' if the AVL component of an HAVL tree is non-empty. Note that height component+-- is ignored, so it's OK to use this function in cases where the height is relative.+--+-- Complexity: O(1)+{-# INLINE isNonEmptyHAVL #-}+isNonEmptyHAVL :: HAVL e -> Bool+isNonEmptyHAVL (HAVL E _) = False+isNonEmptyHAVL (HAVL _ _) = True++-- | Converts an AVL to HAVL+toHAVL :: AVL e -> HAVL e+toHAVL t = HAVL t (addHeight L(0) t)++-- | Splice two HAVL trees using the supplied bridging element.+-- That is, the bridging element appears "in the middle" of the resulting HAVL tree.+-- The elements of the first tree argument are to the left of the bridging element and+-- the elements of the second tree are to the right of the bridging element.+--+-- This function does not require that the AVL heights are absolutely correct, only that+-- the difference in supplied heights is equal to the difference in actual heights. So it's+-- OK if the input heights both have the same unknown constant offset. (The output height+-- will also have the same constant offset in this case.)+--+-- Complexity: O(d), where d is the absolute difference in tree heights.+{-# INLINE spliceHAVL #-}+spliceHAVL :: HAVL e -> e -> HAVL e -> HAVL e+spliceHAVL (HAVL l hl) e (HAVL r hr) = case spliceH l hl e r hr of UBT2(t,ht) -> HAVL t ht++-- | Join two HAVL trees.+-- It's OK if heights are relative (I.E. if they share same fixed offset).+--+-- Complexity: O(d), where d is the absolute difference in tree heights.+{-# INLINE joinHAVL #-}+joinHAVL :: HAVL e -> HAVL e -> HAVL e+joinHAVL (HAVL l hl) (HAVL r hr) = case joinH l hl r hr of UBT2(t,ht) -> HAVL t ht++-- | A version of 'pushL' for HAVL trees.+-- It's OK if height is relative, with fixed offset. In this case the height of the result+-- will have the same fixed offset.+{-# INLINE pushLHAVL #-}+pushLHAVL :: e -> HAVL e -> HAVL e+pushLHAVL e (HAVL t ht) = case pushHL e t ht of UBT2(t_,ht_) -> HAVL t_ ht_++-- | A version of 'pushR' for HAVL trees.+-- It's OK if height is relative, with fixed offset. In this case the height of the result+-- will have the same fixed offset.+{-# INLINE pushRHAVL #-}+pushRHAVL :: HAVL e -> e -> HAVL e+pushRHAVL (HAVL t ht) e = case pushHR t ht e of UBT2(t_,ht_) -> HAVL t_ ht_+
+ Data/Tree/AVL/Internals/HJoin.hs view
@@ -0,0 +1,329 @@+{-# OPTIONS_GHC -fglasgow-exts #-}+-----------------------------------------------------------------------------+-- |+-- Module : Data.Tree.AVL.Internals.HJoin+-- Copyright : (c) Adrian Hey 2004,2005+-- License : BSD3+--+-- Maintainer : http://homepages.nildram.co.uk/~ahey/em.png+-- Stability : stable+-- Portability : portable+--+-- Functions for joining AVL trees of known height.+-----------------------------------------------------------------------------+module Data.Tree.AVL.Internals.HJoin+ ( spliceH,joinH,joinH',+ ) where++import Data.Tree.AVL.Types(AVL(..))+import Data.Tree.AVL.Push(pushL,pushR)+import Data.Tree.AVL.Internals.HPush(pushHL_,pushHR_)+import Data.Tree.AVL.Internals.DelUtils(popRN,popRZ,popRP,popLN,popLZ,popLP)++#if __GLASGOW_HASKELL__+import GHC.Base+#include "ghcdefs.h"+#else+#include "h98defs.h"+#endif++-- | Join two trees of known height, returning an AVL tree.+-- It's OK if heights are relative (I.E. if they share same fixed offset).+--+-- Complexity: O(d), where d is the absolute difference in tree heights.+joinH'+ :: AVL e -> UINT -> AVL e -> UINT -> AVL e+joinH' l hl r hr+ = if hl LEQ hr then let d = SUBINT(hr,hl) in joinHL d l r+ else let d = SUBINT(hl,hr) in joinHR d l r++-- hr >= hl, join l to left subtree of r.+-- Int argument is absolute difference in tree height, hr-hl (>=0)+{-# INLINE joinHL #-}+joinHL :: UINT -> AVL e -> AVL e -> AVL e+joinHL _ E r = r -- l was empty+joinHL d (N ll le lr) r = case popRN ll le lr of+ UBT2(l_,e) -> case l_ of+ E -> error "joinHL: Bug0" -- impossible if BF=-1+ Z _ _ _ -> spliceL l_ e INCINT1(d) r -- hl2=hl-1+ _ -> spliceL l_ e d r -- hl2=hl+joinHL d (Z ll le lr) r = case popRZ ll le lr of+ UBT2(l_,e) -> case l_ of+ E -> e `pushL` r -- l had only one element+ _ -> spliceL l_ e d r -- hl2=hl+joinHL d (P ll le lr) r = case popRP ll le lr of+ UBT2(l_,e) -> case l_ of+ E -> error "joinHL: Bug1" -- impossible if BF=+1+ Z _ _ _ -> spliceL l_ e INCINT1(d) r -- hl2=hl-1+ _ -> spliceL l_ e d r -- hl2=hl+++-- hl >= hr, join r to right subtree of l.+-- Int argument is absolute difference in tree height, hl-hr (>=0)+{-# INLINE joinHR #-}+joinHR :: UINT -> AVL e -> AVL e -> AVL e+joinHR _ l E = l -- r was empty+joinHR d l (N rl re rr) = case popLN rl re rr of+ UBT2(e,r_) -> case r_ of+ E -> error "joinHR: Bug0" -- impossible if BF=-1+ Z _ _ _ -> spliceR r_ e INCINT1(d) l -- hr2=hr-1+ _ -> spliceR r_ e d l -- hr2=hr+joinHR d l (Z rl re rr) = case popLZ rl re rr of+ UBT2(e,r_) -> case r_ of+ E -> l `pushR` e -- r had only one element+ _ -> spliceR r_ e d l -- hr2=hr+joinHR d l (P rl re rr) = case popLP rl re rr of+ UBT2(e,r_) -> case r_ of+ E -> error "joinHL: Bug1" -- impossible if BF=+1+ Z _ _ _ -> spliceR r_ e INCINT1(d) l -- hr2=hr-1+ _ -> spliceR r_ e d l -- hr2=hr+-----------------------------------------------------------------------+--------------------------- joinH' Ends Here --------------------------+-----------------------------------------------------------------------++-- | Join two AVL trees of known height, returning an AVL tree of known height.+-- It's OK if heights are relative (I.E. if they share same fixed offset).+--+-- Complexity: O(d), where d is the absolute difference in tree heights.+joinH :: AVL e -> UINT -> AVL e -> UINT -> UBT2(AVL e,UINT)+joinH l hl r hr =+ case COMPAREUINT hl hr of+ -- hr > hl+ LT -> case l of+ E -> UBT2(r,hr)+ N ll le lr -> case popRN ll le lr of+ UBT2(l_,e) -> case l_ of+ Z _ _ _ -> spliceHL l_ DECINT1(hl) e r hr -- dH=-1+ _ -> spliceHL l_ hl e r hr -- dH= 0+ Z ll le lr -> case popRZ ll le lr of+ UBT2(l_,e) -> case l_ of+ E -> pushHL_ l r hr -- l had only 1 element+ _ -> spliceHL l_ hl e r hr -- dH=0+ P ll le lr -> case popRP ll le lr of+ UBT2(l_,e) -> case l_ of+ Z _ _ _ -> spliceHL l_ DECINT1(hl) e r hr -- dH=-1+ _ -> spliceHL l_ hl e r hr -- dH= 0+ -- hr = hl+ EQ -> case l of+ E -> UBT2(l,hl) -- r must be empty too, don't use emptyAVL!+ N ll le lr -> case popRN ll le lr of+ UBT2(l_,e) -> case l_ of+ Z _ _ _ -> spliceHL l_ DECINT1(hl) e r hr -- dH=-1+ _ -> UBT2(Z l_ e r, INCINT1(hr)) -- dH= 0+ Z ll le lr -> case popRZ ll le lr of+ UBT2(l_,e) -> case l_ of+ E -> pushHL_ l r hr -- l had only 1 element+ _ -> UBT2(Z l_ e r, INCINT1(hr)) -- dH= 0+ P ll le lr -> case popRP ll le lr of+ UBT2(l_,e) -> case l_ of+ Z _ _ _ -> spliceHL l_ DECINT1(hl) e r hr -- dH=-1+ _ -> UBT2(Z l_ e r, INCINT1(hr)) -- dH= 0+ -- hl > hr+ GT -> case r of+ E -> UBT2(l,hl)+ N rl re rr -> case popLN rl re rr of+ UBT2(e,r_) -> case r_ of+ Z _ _ _ -> spliceHR l hl e r_ DECINT1(hr) -- dH=-1+ _ -> spliceHR l hl e r_ hr -- dH= 0+ Z rl re rr -> case popLZ rl re rr of+ UBT2(e,r_) -> case r_ of+ E -> pushHR_ l hl r -- r had only 1 element+ _ -> spliceHR l hl e r_ hr -- dH=0+ P rl re rr -> case popLP rl re rr of+ UBT2(e,r_) -> case r_ of+ Z _ _ _ -> spliceHR l hl e r_ DECINT1(hr) -- dH=-1+ _ -> spliceHR l hl e r_ hr -- dH= 0+++-- | Splice two AVL trees of known height using the supplied bridging element.+-- That is, the bridging element appears \"in the middle\" of the resulting AVL tree.+-- The elements of the first tree argument are to the left of the bridging element and+-- the elements of the second tree are to the right of the bridging element.+--+-- This function does not require that the AVL heights are absolutely correct, only that+-- the difference in supplied heights is equal to the difference in actual heights. So it's+-- OK if the input heights both have the same unknown constant offset. (The output height+-- will also have the same constant offset in this case.)+--+-- Complexity: O(d), where d is the absolute difference in tree heights.+spliceH :: AVL e -> UINT -> e -> AVL e -> UINT -> UBT2(AVL e,UINT)+-- You'd think inlining this function would make a significant difference to many functions+-- (such as set operations), but it doesn't. It makes them marginally slower!!+spliceH l hl b r hr =+ case COMPAREUINT hl hr of+ LT -> spliceHL l hl b r hr+ EQ -> UBT2(Z l b r, INCINT1(hl))+ GT -> spliceHR l hl b r hr++-- Splice two trees of known relative height where hr>hl, using the supplied bridging element,+-- returning another tree of known relative height.+spliceHL :: AVL e -> UINT -> e -> AVL e -> UINT -> UBT2(AVL e,UINT)+spliceHL l hl b r hr = let d = SUBINT(hr,hl)+ in if d EQL L(1) then UBT2(N l b r, INCINT1(hr))+ else spliceHL_ hr d l b r++-- Splice two trees of known relative height where hl>hr, using the supplied bridging element,+-- returning another tree of known relative height.+spliceHR :: AVL e -> UINT -> e -> AVL e -> UINT -> UBT2(AVL e,UINT)+spliceHR l hl b r hr = let d = SUBINT(hl,hr)+ in if d EQL L(1) then UBT2(P l b r, INCINT1(hl))+ else spliceHR_ hl d l b r++-- Splice two trees of known relative height where hr>hl+1, using the supplied bridging element,+-- returning another tree of known relative height. d >= 2+{-# INLINE spliceHL_ #-}+spliceHL_ :: UINT -> UINT -> AVL e -> e -> AVL e -> UBT2(AVL e,UINT)+spliceHL_ _ _ _ _ E = error "spliceHL_: Bug0" -- impossible if hr>hl+spliceHL_ hr d l b (N rl re rr) = let r_ = spliceLN l b DECINT2(d) rl re rr+ in r_ `seq` UBT2(r_,hr)+spliceHL_ hr d l b (Z rl re rr) = let r_ = spliceLZ l b DECINT1(d) rl re rr+ in case r_ of+ E -> error "spliceHL_: Bug1"+ Z _ _ _ -> UBT2(r_, hr )+ _ -> UBT2(r_,INCINT1(hr))+spliceHL_ hr d l b (P rl re rr) = let r_ = spliceLP l b DECINT1(d) rl re rr+ in r_ `seq` UBT2(r_,hr)++-- Splice two trees of known relative height where hl>hr+1, using the supplied bridging element,+-- returning another tree of known relative height. d >= 2 !!+{-# INLINE spliceHR_ #-}+spliceHR_ :: UINT -> UINT -> AVL e -> e -> AVL e -> UBT2(AVL e,UINT)+spliceHR_ _ _ E _ _ = error "spliceHR_: Bug0" -- impossible if hl>hr+spliceHR_ hl d (N ll le lr) b r = let l_ = spliceRN r b DECINT1(d) ll le lr+ in l_ `seq` UBT2(l_,hl)+spliceHR_ hl d (Z ll le lr) b r = let l_ = spliceRZ r b DECINT1(d) ll le lr+ in case l_ of+ E -> error "spliceHR_: Bug1"+ Z _ _ _ -> UBT2(l_, hl )+ _ -> UBT2(l_,INCINT1(hl))+spliceHR_ hl d (P ll le lr) b r = let l_ = spliceRP r b DECINT2(d) ll le lr+ in l_ `seq` UBT2(l_,hl)+-----------------------------------------------------------------------+-------------------------- spliceH Ends Here --------------------------+-----------------------------------------------------------------------++-- hr >= hl, splice s to left subtree of r, using b as the bridge+-- The Int argument is the absolute difference in tree height, hr-hl (>=0)+spliceL :: AVL e -> e -> UINT -> AVL e -> AVL e+spliceL s b L(0) r = Z s b r+spliceL s b L(1) r = N s b r+spliceL s b d (N rl re rr) = spliceLN s b DECINT2(d) rl re rr -- height diff of rl is two less+spliceL s b d (Z rl re rr) = spliceLZ s b DECINT1(d) rl re rr -- height diff of rl is one less+spliceL s b d (P rl re rr) = spliceLP s b DECINT1(d) rl re rr -- height diff of rl is one less+spliceL _ _ _ E = error "spliceL: Bug0" -- r can't be empty++-- Splice into left subtree of (N l e r), height cannot change as a result of this+spliceLN :: AVL e -> e -> UINT -> AVL e -> e -> AVL e -> AVL e+spliceLN s b L(0) l e r = Z (Z s b l) e r -- dH=0+spliceLN s b L(1) l e r = Z (N s b l) e r -- dH=0+spliceLN s b d (N ll le lr) e r = let l_ = spliceLN s b DECINT2(d) ll le lr in l_ `seq` N l_ e r+spliceLN s b d (Z ll le lr) e r = let l_ = spliceLZ s b DECINT1(d) ll le lr+ in case l_ of+ Z _ _ _ -> N l_ e r -- dH=0+ P _ _ _ -> Z l_ e r -- dH=0+ _ -> error "spliceLN: Bug0" -- impossible+spliceLN s b d (P ll le lr) e r = let l_ = spliceLP s b DECINT1(d) ll le lr in l_ `seq` N l_ e r+spliceLN _ _ _ E _ _ = error "spliceLN: Bug1" -- impossible++-- Splice into left subtree of (Z l e r), Z->P if dH=1, Z->Z if dH=0+spliceLZ :: AVL e -> e -> UINT -> AVL e -> e -> AVL e -> AVL e+spliceLZ s b L(1) l e r = P (N s b l) e r -- Z->P, dH=1+spliceLZ s b d (N ll le lr) e r = let l_ = spliceLN s b DECINT2(d) ll le lr in l_ `seq` Z l_ e r -- Z->Z, dH=0+spliceLZ s b d (Z ll le lr) e r = let l_ = spliceLZ s b DECINT1(d) ll le lr+ in case l_ of+ Z _ _ _ -> Z l_ e r -- Z->Z, dH=0+ P _ _ _ -> P l_ e r -- Z->P, dH=1+ _ -> error "spliceLZ: Bug0" -- impossible+spliceLZ s b d (P ll le lr) e r = let l_ = spliceLP s b DECINT1(d) ll le lr in l_ `seq` Z l_ e r -- Z->Z, dH=0+spliceLZ _ _ _ E _ _ = error "spliceLZ: Bug1" -- impossible++-- Splice into left subtree of (P l e r), height cannot change as a result of this+spliceLP :: AVL e -> e -> UINT -> AVL e -> e -> AVL e -> AVL e+spliceLP s b L(1) (N ll le lr) e r = Z (P s b ll) le (Z lr e r) -- dH=0+spliceLP s b L(1) (Z ll le lr) e r = Z (Z s b ll) le (Z lr e r) -- dH=0+spliceLP s b L(1) (P ll le lr) e r = Z (Z s b ll) le (N lr e r) -- dH=0+spliceLP s b d (N ll le lr) e r = let l_ = spliceLN s b DECINT2(d) ll le lr in l_ `seq` P l_ e r -- dH=0+spliceLP s b d (Z ll le lr) e r = spliceLPZ s b DECINT1(d) ll le lr e r -- dH=0+spliceLP s b d (P ll le lr) e r = let l_ = spliceLP s b DECINT1(d) ll le lr in l_ `seq` P l_ e r -- dH=0+spliceLP _ _ _ E _ _ = error "spliceLP: Bug0"++-- Splice into left subtree of (P (Z ll le lr) e r)+{-# INLINE spliceLPZ #-}+spliceLPZ :: AVL e -> e -> UINT -> AVL e -> e -> AVL e -> e -> AVL e -> AVL e+spliceLPZ s b L(1) ll le lr e r = Z (N s b ll) le (Z lr e r) -- dH=0+spliceLPZ s b d (N lll lle llr) le lr e r = let ll_ = spliceLN s b DECINT2(d) lll lle llr -- dH=0+ in ll_ `seq` P (Z ll_ le lr) e r+spliceLPZ s b d (Z lll lle llr) le lr e r = let ll_ = spliceLZ s b DECINT1(d) lll lle llr -- dH=0+ in case ll_ of+ Z _ _ _ -> P (Z ll_ le lr) e r -- dH=0+ P _ _ _ -> Z ll_ le (Z lr e r) -- dH=0+ _ -> error "spliceLPZ: Bug0" -- impossible+spliceLPZ s b d (P lll lle llr) le lr e r = let ll_ = spliceLP s b DECINT1(d) lll lle llr -- dH=0+ in ll_ `seq` P (Z ll_ le lr) e r+spliceLPZ _ _ _ E _ _ _ _ = error "spliceLPZ: Bug1"+-----------------------------------------------------------------------+-------------------------- spliceL Ends Here --------------------------+-----------------------------------------------------------------------++-- hl >= hr, splice s to right subtree of l, using b as the bridge+-- The Int argument is the absolute difference in tree height, hl-hr (>=0)+spliceR :: AVL e -> e -> UINT -> AVL e -> AVL e+spliceR s b L(0) l = Z l b s+spliceR s b L(1) l = P l b s+spliceR s b d (N ll le lr) = spliceRN s b DECINT1(d) ll le lr -- height diff of lr is one less+spliceR s b d (Z ll le lr) = spliceRZ s b DECINT1(d) ll le lr -- height diff of lr is one less+spliceR s b d (P ll le lr) = spliceRP s b DECINT2(d) ll le lr -- height diff of lr is two less+spliceR _ _ _ E = error "spliceR: Bug0" -- l can't be empty++-- Splice into right subtree of (P l e r), height cannot change as a result of this+spliceRP :: AVL e -> e -> UINT -> AVL e -> e -> AVL e -> AVL e+spliceRP s b L(0) l e r = Z l e (Z r b s) -- dH=0+spliceRP s b L(1) l e r = Z l e (P r b s) -- dH=0+spliceRP s b d l e (N rl re rr) = let r_ = spliceRN s b DECINT1(d) rl re rr in r_ `seq` P l e r_+spliceRP s b d l e (Z rl re rr) = let r_ = spliceRZ s b DECINT1(d) rl re rr+ in case r_ of+ Z _ _ _ -> P l e r_ -- dH=0+ N _ _ _ -> Z l e r_ -- dH=0+ _ -> error "spliceRP: Bug0" -- impossible+spliceRP s b d l e (P rl re rr) = let r_ = spliceRP s b DECINT2(d) rl re rr in r_ `seq` P l e r_+spliceRP _ _ _ _ _ E = error "spliceRP: Bug1" -- impossible++-- Splice into right subtree of (Z l e r), Z->N if dH=1, Z->Z if dH=0+spliceRZ :: AVL e -> e -> UINT -> AVL e -> e -> AVL e -> AVL e+spliceRZ s b L(1) l e r = N l e (P r b s) -- Z->N, dH=1+spliceRZ s b d l e (N rl re rr) = let r_ = spliceRN s b DECINT1(d) rl re rr in r_ `seq` Z l e r_ -- Z->Z, dH=0+spliceRZ s b d l e (Z rl re rr) = let r_ = spliceRZ s b DECINT1(d) rl re rr+ in case r_ of+ Z _ _ _ -> Z l e r_ -- Z->Z, dH=0+ N _ _ _ -> N l e r_ -- Z->N, dH=1+ _ -> error "spliceRZ: Bug0" -- impossible+spliceRZ s b d l e (P rl re rr) = let r_ = spliceRP s b DECINT2(d) rl re rr in r_ `seq` Z l e r_ -- Z->Z, dH=0+spliceRZ _ _ _ _ _ E = error "spliceRZ: Bug1" -- impossible++-- Splice into right subtree of (N l e r), height cannot change as a result of this+spliceRN :: AVL e -> e -> UINT -> AVL e -> e -> AVL e -> AVL e+spliceRN s b L(1) l e (N rl re rr) = Z (P l e rl) re (Z rr b s) -- dH=0+spliceRN s b L(1) l e (Z rl re rr) = Z (Z l e rl) re (Z rr b s) -- dH=0+spliceRN s b L(1) l e (P rl re rr) = Z (Z l e rl) re (N rr b s) -- dH=0+spliceRN s b d l e (N rl re rr) = let r_ = spliceRN s b DECINT1(d) rl re rr in r_ `seq` N l e r_ -- dH=0+spliceRN s b d l e (Z rl re rr) = spliceRNZ s b DECINT1(d) l e rl re rr -- dH=0+spliceRN s b d l e (P rl re rr) = let r_ = spliceRP s b DECINT2(d) rl re rr in r_ `seq` N l e r_ -- dH=0+spliceRN _ _ _ _ _ E = error "spliceRN: Bug0"++-- Splice into right subtree of (N l e (Z rl re rr))+{-# INLINE spliceRNZ #-}+spliceRNZ :: AVL e -> e -> UINT -> AVL e -> e -> AVL e -> e -> AVL e -> AVL e+spliceRNZ s b L(1) l e rl re rr = Z (Z l e rl) re (P rr b s) -- dH=0+spliceRNZ s b d l e rl re (N rrl rre rrr) = let rr_ = spliceRN s b DECINT1(d) rrl rre rrr+ in rr_ `seq` N l e (Z rl re rr_) -- dH=0+spliceRNZ s b d l e rl re (Z rrl rre rrr) = let rr_ = spliceRZ s b DECINT1(d) rrl rre rrr -- dH=0+ in case rr_ of+ Z _ _ _ -> N l e (Z rl re rr_) -- dH=0+ N _ _ _ -> Z (Z l e rl) re rr_ -- dH=0+ _ -> error "spliceRNZ: Bug0" -- impossible+spliceRNZ s b d l e rl re (P rrl rre rrr) = let rr_ = spliceRP s b DECINT2(d) rrl rre rrr -- dH=0+ in rr_ `seq` N l e (Z rl re rr_)+spliceRNZ _ _ _ _ _ _ _ E = error "spliceRNZ: Bug1"+-----------------------------------------------------------------------+-------------------------- spliceR Ends Here --------------------------+-----------------------------------------------------------------------
+ Data/Tree/AVL/Internals/HPush.hs view
@@ -0,0 +1,189 @@+{-# OPTIONS_GHC -fglasgow-exts #-}+-----------------------------------------------------------------------------+-- |+-- Module : Data.Tree.AVL.Internals.HPush+-- Copyright : (c) Adrian Hey 2004,2005+-- License : BSD3+--+-- Maintainer : http://homepages.nildram.co.uk/~ahey/em.png+-- Stability : stable+-- Portability : portable+--+-- Functions for pushing elements into trees of known height.+-----------------------------------------------------------------------------+module Data.Tree.AVL.Internals.HPush+ (pushHL,pushHR,pushHL_,pushHR_,+ ) where++import Data.Tree.AVL.Types(AVL(..))++#ifdef __GLASGOW_HASKELL__+import GHC.Base+#include "ghcdefs.h"+#else+#include "h98defs.h"+#endif++-- | A version of 'pushL' for an AVL tree of known height. Returns an AVL tree of known height.+-- It's OK if height is relative, with fixed offset. In this case the height of the result+-- will have the same fixed offset.+{-# INLINE pushHL #-}+pushHL :: e -> AVL e -> UINT -> UBT2(AVL e,UINT)+pushHL e t h = pushHL_ (Z E e E) t h++-- | A version of 'pushR' for an AVL tree of known height. Returns an AVL tree of known height.+-- It's OK if height is relative, with fixed offset. In this case the height of the result+-- will have the same fixed offset.+{-# INLINE pushHR #-}+pushHR :: AVL e -> UINT -> e -> UBT2(AVL e,UINT)+pushHR t h e = pushHR_ t h (Z E e E)++-- | Push a singleton tree (first arg) in the leftmost position of an AVL tree of known height,+-- returning an AVL tree of known height. It's OK if height is relative, with fixed offset.+-- In this case the height of the result will have the same fixed offset.+--+-- Complexity: O(log n)+pushHL_ :: AVL e -> AVL e -> UINT -> UBT2(AVL e,UINT)+pushHL_ t0 t h = case t of+ E -> UBT2(t0, INCINT1(h)) -- Relative Heights+ N l e r -> let t_ = putNL l e r in t_ `seq` UBT2(t_,h)+ P l e r -> let t_ = putPL l e r in t_ `seq` UBT2(t_,h)+ Z l e r -> let t_ = putZL l e r+ in case t_ of+ Z _ _ _ -> UBT2(t_, h )+ P _ _ _ -> UBT2(t_, INCINT1(h))+ _ -> error "pushHL_: Bug0" -- impossible+ where+ ----------------------------- LEVEL 2 ---------------------------------+ -- putNL, putZL, putPL --+ -----------------------------------------------------------------------++ -- (putNL l e r): Put in L subtree of (N l e r), BF=-1 (Never requires rebalancing) , (never returns P)+ putNL E e r = Z t0 e r -- L subtree empty, H:0->1, parent BF:-1-> 0+ putNL (N ll le lr) e r = let l' = putNL ll le lr -- L subtree BF<>0, H:h->h, parent BF:-1->-1+ in l' `seq` N l' e r+ putNL (P ll le lr) e r = let l' = putPL ll le lr -- L subtree BF<>0, H:h->h, parent BF:-1->-1+ in l' `seq` N l' e r+ putNL (Z ll le lr) e r = let l' = putZL ll le lr -- L subtree BF= 0, so need to look for changes+ in case l' of+ Z _ _ _ -> N l' e r -- L subtree BF:0-> 0, H:h->h , parent BF:-1->-1+ P _ _ _ -> Z l' e r -- L subtree BF:0->+1, H:h->h+1, parent BF:-1-> 0+ _ -> error "pushHL_: Bug1" -- impossible++ -- (putZL l e r): Put in L subtree of (Z l e r), BF= 0 (Never requires rebalancing) , (never returns N)+ putZL E e r = P t0 e r -- L subtree H:0->1, parent BF: 0->+1+ putZL (N ll le lr) e r = let l' = putNL ll le lr -- L subtree BF<>0, H:h->h, parent BF: 0-> 0+ in l' `seq` Z l' e r+ putZL (P ll le lr) e r = let l' = putPL ll le lr -- L subtree BF<>0, H:h->h, parent BF: 0-> 0+ in l' `seq` Z l' e r+ putZL (Z ll le lr) e r = let l' = putZL ll le lr -- L subtree BF= 0, so need to look for changes+ in case l' of+ Z _ _ _ -> Z l' e r -- L subtree BF: 0-> 0, H:h->h , parent BF: 0-> 0+ N _ _ _ -> error "pushHL_: Bug2" -- impossible+ _ -> P l' e r -- L subtree BF: 0->+1, H:h->h+1, parent BF: 0->+1++ -------- This case (PL) may need rebalancing if it goes to LEVEL 3 ---------++ -- (putPL l e r): Put in L subtree of (P l e r), BF=+1 , (never returns N)+ putPL E _ _ = error "pushHL_: Bug3" -- impossible if BF=+1+ putPL (N ll le lr) e r = let l' = putNL ll le lr -- L subtree BF<>0, H:h->h, parent BF:+1->+1+ in l' `seq` P l' e r+ putPL (P ll le lr) e r = let l' = putPL ll le lr -- L subtree BF<>0, H:h->h, parent BF:+1->+1+ in l' `seq` P l' e r+ putPL (Z ll le lr) e r = putPLL ll le lr e r -- LL (never returns N)++ ----------------------------- LEVEL 3 ---------------------------------+ -- putPLL --+ -----------------------------------------------------------------------++ -- (putPLL ll le lr e r): Put in LL subtree of (P (Z ll le lr) e r) , (never returns N)+ {-# INLINE putPLL #-}+ putPLL E le lr e r = Z t0 le (Z lr e r) -- r and lr must also be E, special CASE LL!!+ putPLL (N lll lle llr) le lr e r = let ll' = putNL lll lle llr -- LL subtree BF<>0, H:h->h, so no change+ in ll' `seq` P (Z ll' le lr) e r+ putPLL (P lll lle llr) le lr e r = let ll' = putPL lll lle llr -- LL subtree BF<>0, H:h->h, so no change+ in ll' `seq` P (Z ll' le lr) e r+ putPLL (Z lll lle llr) le lr e r = let ll' = putZL lll lle llr -- LL subtree BF= 0, so need to look for changes+ in case ll' of+ Z _ _ _ -> P (Z ll' le lr) e r -- LL subtree BF: 0-> 0, H:h->h, so no change+ N _ _ _ -> error "pushHL_: Bug4" -- impossible+ _ -> Z ll' le (Z lr e r) -- LL subtree BF: 0->+1, H:h->h+1, parent BF:-1->-2, CASE LL !!+-----------------------------------------------------------------------+-------------------------- pushHL_ Ends Here --------------------------+-----------------------------------------------------------------------+++-- | Push a singleton tree (third arg) in the rightmost position of an AVL tree of known height,+-- returning an AVL tree of known height. It's OK if height is relative, with fixed offset.+-- In this case the height of the result will have the same fixed offset.+--+-- Complexity: O(log n)+pushHR_ :: AVL e -> UINT -> AVL e -> UBT2(AVL e,UINT)+pushHR_ t h t0 = case t of+ E -> UBT2(t0, INCINT1(h)) -- Relative Heights+ N l e r -> let t_ = putNR l e r in t_ `seq` UBT2(t_,h)+ P l e r -> let t_ = putPR l e r in t_ `seq` UBT2(t_,h)+ Z l e r -> let t_ = putZR l e r+ in case t_ of+ Z _ _ _ -> UBT2(t_, h )+ N _ _ _ -> UBT2(t_, INCINT1(h))+ _ -> error "pushHR_: Bug0" -- impossible+ where+ ----------------------------- LEVEL 2 ---------------------------------+ -- putNR, putZR, putPR --+ -----------------------------------------------------------------------++ -- (putZR l e r): Put in R subtree of (Z l e r), BF= 0 (Never requires rebalancing) , (never returns P)+ putZR l e E = N l e t0 -- R subtree H:0->1, parent BF: 0->-1+ putZR l e (N rl re rr) = let r' = putNR rl re rr -- R subtree BF<>0, H:h->h, parent BF: 0-> 0+ in r' `seq` Z l e r'+ putZR l e (P rl re rr) = let r' = putPR rl re rr -- R subtree BF<>0, H:h->h, parent BF: 0-> 0+ in r' `seq` Z l e r'+ putZR l e (Z rl re rr) = let r' = putZR rl re rr -- R subtree BF= 0, so need to look for changes+ in case r' of+ Z _ _ _ -> Z l e r' -- R subtree BF: 0-> 0, H:h->h , parent BF: 0-> 0+ N _ _ _ -> N l e r' -- R subtree BF: 0->-1, H:h->h+1, parent BF: 0->-1+ _ -> error "pushHR_: Bug1" -- impossible++ -- (putPR l e r): Put in R subtree of (P l e r), BF=+1 (Never requires rebalancing) , (never returns N)+ putPR l e E = Z l e t0 -- R subtree empty, H:0->1, parent BF:+1-> 0+ putPR l e (N rl re rr) = let r' = putNR rl re rr -- R subtree BF<>0, H:h->h, parent BF:+1->+1+ in r' `seq` P l e r'+ putPR l e (P rl re rr) = let r' = putPR rl re rr -- R subtree BF<>0, H:h->h, parent BF:+1->+1+ in r' `seq` P l e r'+ putPR l e (Z rl re rr) = let r' = putZR rl re rr -- R subtree BF= 0, so need to look for changes+ in case r' of+ Z _ _ _ -> P l e r' -- R subtree BF:0-> 0, H:h->h , parent BF:+1->+1+ N _ _ _ -> Z l e r' -- R subtree BF:0->-1, H:h->h+1, parent BF:+1-> 0+ _ -> error "pushHR_: Bug2" -- impossible++ -------- This case (NR) may need rebalancing if it goes to LEVEL 3 ---------++ -- (putNR l e r): Put in R subtree of (N l e r), BF=-1 , (never returns P)+ putNR _ _ E = error "pushHR_: Bug3" -- impossible if BF=-1+ putNR l e (N rl re rr) = let r' = putNR rl re rr -- R subtree BF<>0, H:h->h, parent BF:-1->-1+ in r' `seq` N l e r'+ putNR l e (P rl re rr) = let r' = putPR rl re rr -- R subtree BF<>0, H:h->h, parent BF:-1->-1+ in r' `seq` N l e r'+ putNR l e (Z rl re rr) = putNRR l e rl re rr -- RR (never returns P)++ ----------------------------- LEVEL 3 ---------------------------------+ -- putNRR --+ -----------------------------------------------------------------------++ -- (putNRR l e rl re rr): Put in RR subtree of (N l e (Z rl re rr)) , (never returns P)+ {-# INLINE putNRR #-}+ putNRR l e rl re E = Z (Z l e rl) re t0 -- l and rl must also be E, special CASE RR!!+ putNRR l e rl re (N rrl rre rrr) = let rr' = putNR rrl rre rrr -- RR subtree BF<>0, H:h->h, so no change+ in rr' `seq` N l e (Z rl re rr')+ putNRR l e rl re (P rrl rre rrr) = let rr' = putPR rrl rre rrr -- RR subtree BF<>0, H:h->h, so no change+ in rr' `seq` N l e (Z rl re rr')+ putNRR l e rl re (Z rrl rre rrr) = let rr' = putZR rrl rre rrr -- RR subtree BF= 0, so need to look for changes+ in case rr' of+ Z _ _ _ -> N l e (Z rl re rr') -- RR subtree BF: 0-> 0, H:h->h, so no change+ N _ _ _ -> Z (Z l e rl) re rr' -- RR subtree BF: 0->-1, H:h->h+1, parent BF:-1->-2, CASE RR !!+ _ -> error "pushHR_: Bug4" -- impossible+-----------------------------------------------------------------------+-------------------------- pushHR_ Ends Here --------------------------+-----------------------------------------------------------------------+
+ Data/Tree/AVL/Internals/HSet.hs view
@@ -0,0 +1,655 @@+{-# OPTIONS_GHC -fglasgow-exts #-}+-----------------------------------------------------------------------------+-- |+-- Module : Data.Tree.AVL.Internals.HSet+-- Copyright : (c) Adrian Hey 2004,2005+-- License : BSD3+--+-- Maintainer : http://homepages.nildram.co.uk/~ahey/em.png+-- Stability : stable+-- Portability : portable+--+-- Set primitives on AVL trees with (height information supplied where needed).+-- All the functions in this module use essentially the same symetric \"Divide and Conquer\" algorithm.+-----------------------------------------------------------------------------+module Data.Tree.AVL.Internals.HSet+ (-- * Union primitives.+ unionH,unionMaybeH,++ -- * Intersection primitives.+ intersectionH,intersectionMaybeH,++ -- * Difference primitives.+ differenceH,differenceMaybeH,symDifferenceH,+ ) where++import Data.Tree.AVL.Types(AVL(..))+import Data.Tree.AVL.Internals.HJoin(spliceH,joinH)++import Data.COrdering++#ifdef __GLASGOW_HASKELL__+import GHC.Base+#include "ghcdefs.h"+#else+#include "h98defs.h"+#endif++-- | Uses the supplied combining comparison to evaluate the union of two sets represented as+-- sorted AVL trees of known height. Whenever the combining comparison is applied, the first+-- comparison argument is an element of the first tree and the second comparison argument is+-- an element of the second tree.+--+-- Complexity: Not sure, but I'd appreciate it if someone could figure it out.+-- (Faster than Hedge union from Data.Set at any rate).+unionH :: (e -> e -> COrdering e) -> AVL e -> UINT -> AVL e -> UINT -> UBT2(AVL e,UINT)+unionH c = u where+ -- u :: AVL e -> UINT -> AVL e -> UINT -> UBT2(AVL e,UINT)+ u E _ t1 h1 = UBT2(t1,h1)+ u t0 h0 E _ = UBT2(t0,h0)+ u (N l0 e0 r0) h0 (N l1 e1 r1) h1 = u_ l0 DECINT2(h0) e0 r0 DECINT1(h0) l1 DECINT2(h1) e1 r1 DECINT1(h1)+ u (N l0 e0 r0) h0 (Z l1 e1 r1) h1 = u_ l0 DECINT2(h0) e0 r0 DECINT1(h0) l1 DECINT1(h1) e1 r1 DECINT1(h1)+ u (N l0 e0 r0) h0 (P l1 e1 r1) h1 = u_ l0 DECINT2(h0) e0 r0 DECINT1(h0) l1 DECINT1(h1) e1 r1 DECINT2(h1)+ u (Z l0 e0 r0) h0 (N l1 e1 r1) h1 = u_ l0 DECINT1(h0) e0 r0 DECINT1(h0) l1 DECINT2(h1) e1 r1 DECINT1(h1)+ u (Z l0 e0 r0) h0 (Z l1 e1 r1) h1 = u_ l0 DECINT1(h0) e0 r0 DECINT1(h0) l1 DECINT1(h1) e1 r1 DECINT1(h1)+ u (Z l0 e0 r0) h0 (P l1 e1 r1) h1 = u_ l0 DECINT1(h0) e0 r0 DECINT1(h0) l1 DECINT1(h1) e1 r1 DECINT2(h1)+ u (P l0 e0 r0) h0 (N l1 e1 r1) h1 = u_ l0 DECINT1(h0) e0 r0 DECINT2(h0) l1 DECINT2(h1) e1 r1 DECINT1(h1)+ u (P l0 e0 r0) h0 (Z l1 e1 r1) h1 = u_ l0 DECINT1(h0) e0 r0 DECINT2(h0) l1 DECINT1(h1) e1 r1 DECINT1(h1)+ u (P l0 e0 r0) h0 (P l1 e1 r1) h1 = u_ l0 DECINT1(h0) e0 r0 DECINT2(h0) l1 DECINT1(h1) e1 r1 DECINT2(h1)+ u_ l0 hl0 e0 r0 hr0 l1 hl1 e1 r1 hr1 =+ case c e0 e1 of+ -- e0 < e1, so (l0 < e0 < e1) & (e0 < e1 < r1)+ Lt -> case forkR r0 hr0 e1 of+ UBT5(rl0,hrl0,e1_,rr0,hrr0) -> case forkL e0 l1 hl1 of -- (e0 < rl0 < e1) & (e0 < e1 < rr0)+ UBT5(ll1,hll1,e0_,lr1,hlr1) -> -- (ll1 < e0 < e1) & (e0 < lr1 < e1)+ -- (l0 + ll1) < e0 < (rl0 + lr1) < e1 < (rr0 + r1)+ case u l0 hl0 ll1 hll1 of+ UBT2(l,hl) -> case u rl0 hrl0 lr1 hlr1 of+ UBT2(m,hm) -> case u rr0 hrr0 r1 hr1 of+ UBT2(r,hr) -> case spliceH m hm e1_ r hr of+ UBT2(t,ht) -> spliceH l hl e0_ t ht+ -- e0 = e1+ Eq e -> case u l0 hl0 l1 hl1 of+ UBT2(l,hl) -> case u r0 hr0 r1 hr1 of+ UBT2(r,hr) -> spliceH l hl e r hr+ -- e1 < e0, so (l1 < e1 < e0) & (e1 < e0 < r0)+ Gt -> case forkL e0 r1 hr1 of+ UBT5(rl1,hrl1,e0_,rr1,hrr1) -> case forkR l0 hl0 e1 of -- (e1 < rl1 < e0) & (e1 < e0 < rr1)+ UBT5(ll0,hll0,e1_,lr0,hlr0) -> -- (ll0 < e1 < e0) & (e1 < lr0 < e0)+ -- (ll0 + l1) < e1 < (lr0 + rl1) < e0 < (r0 + rr1)+ case u ll0 hll0 l1 hl1 of+ UBT2(l,hl) -> case u lr0 hlr0 rl1 hrl1 of+ UBT2(m,hm) -> case u r0 hr0 rr1 hrr1 of+ UBT2(r,hr) -> case spliceH l hl e1_ m hm of+ UBT2(t,ht) -> spliceH t ht e0_ r hr+ -- We need 2 different versions of fork (L & R) to ensure that comparison arguments are used in+ -- the right order (c e0 e1)+ -- forkL :: e -> AVL e -> UINT -> UBT5(AVL e,UINT,e,AVL e,UINT)+ forkL e0 t1 ht1 = forkL_ t1 ht1 where+ forkL_ E _ = UBT5(E, L(0), e0, E, L(0))+ forkL_ (N l e r) h = forkL__ l DECINT2(h) e r DECINT1(h)+ forkL_ (Z l e r) h = forkL__ l DECINT1(h) e r DECINT1(h)+ forkL_ (P l e r) h = forkL__ l DECINT1(h) e r DECINT2(h)+ forkL__ l hl e r hr = case c e0 e of+ Lt -> case forkL_ l hl of+ UBT5(l0,hl0,e0_,l1,hl1) -> case spliceH l1 hl1 e r hr of+ UBT2(l1_,hl1_) -> UBT5(l0,hl0,e0_,l1_,hl1_)+ Eq e0_ -> UBT5(l,hl,e0_,r,hr)+ Gt -> case forkL_ r hr of+ UBT5(l0,hl0,e0_,l1,hl1) -> case spliceH l hl e l0 hl0 of+ UBT2(l0_,hl0_) -> UBT5(l0_,hl0_,e0_,l1,hl1)+ -- forkR :: AVL e -> UINT -> e -> UBT5(AVL e,UINT,e,AVL e,UINT)+ forkR t0 ht0 e1 = forkR_ t0 ht0 where+ forkR_ E _ = UBT5(E, L(0), e1, E, L(0))+ forkR_ (N l e r) h = forkR__ l DECINT2(h) e r DECINT1(h)+ forkR_ (Z l e r) h = forkR__ l DECINT1(h) e r DECINT1(h)+ forkR_ (P l e r) h = forkR__ l DECINT1(h) e r DECINT2(h)+ forkR__ l hl e r hr = case c e e1 of+ Lt -> case forkR_ r hr of+ UBT5(l0,hl0,e1_,l1,hl1) -> case spliceH l hl e l0 hl0 of+ UBT2(l0_,hl0_) -> UBT5(l0_,hl0_,e1_,l1,hl1)+ Eq e1_ -> UBT5(l,hl,e1_,r,hr)+ Gt -> case forkR_ l hl of+ UBT5(l0,hl0,e1_,l1,hl1) -> case spliceH l1 hl1 e r hr of+ UBT2(l1_,hl1_) -> UBT5(l0,hl0,e1_,l1_,hl1_)+-----------------------------------------------------------------------+-------------------------- unionH Ends Here ---------------------------+-----------------------------------------------------------------------++-- | Similar to _unionH_, but the resulting tree does not include elements in cases where+-- the supplied combining comparison returns @(Eq Nothing)@.+--+-- Complexity: Not sure, but I_d appreciate it if someone could figure it out.+unionMaybeH :: (e -> e -> COrdering (Maybe e)) -> AVL e -> UINT -> AVL e -> UINT -> UBT2(AVL e,UINT)+unionMaybeH c = u where+ -- u :: AVL e -> UINT -> AVL e -> UINT -> UBT2(AVL e,UINT)+ u E _ t1 h1 = UBT2(t1,h1)+ u t0 h0 E _ = UBT2(t0,h0)+ u (N l0 e0 r0) h0 (N l1 e1 r1) h1 = u_ l0 DECINT2(h0) e0 r0 DECINT1(h0) l1 DECINT2(h1) e1 r1 DECINT1(h1)+ u (N l0 e0 r0) h0 (Z l1 e1 r1) h1 = u_ l0 DECINT2(h0) e0 r0 DECINT1(h0) l1 DECINT1(h1) e1 r1 DECINT1(h1)+ u (N l0 e0 r0) h0 (P l1 e1 r1) h1 = u_ l0 DECINT2(h0) e0 r0 DECINT1(h0) l1 DECINT1(h1) e1 r1 DECINT2(h1)+ u (Z l0 e0 r0) h0 (N l1 e1 r1) h1 = u_ l0 DECINT1(h0) e0 r0 DECINT1(h0) l1 DECINT2(h1) e1 r1 DECINT1(h1)+ u (Z l0 e0 r0) h0 (Z l1 e1 r1) h1 = u_ l0 DECINT1(h0) e0 r0 DECINT1(h0) l1 DECINT1(h1) e1 r1 DECINT1(h1)+ u (Z l0 e0 r0) h0 (P l1 e1 r1) h1 = u_ l0 DECINT1(h0) e0 r0 DECINT1(h0) l1 DECINT1(h1) e1 r1 DECINT2(h1)+ u (P l0 e0 r0) h0 (N l1 e1 r1) h1 = u_ l0 DECINT1(h0) e0 r0 DECINT2(h0) l1 DECINT2(h1) e1 r1 DECINT1(h1)+ u (P l0 e0 r0) h0 (Z l1 e1 r1) h1 = u_ l0 DECINT1(h0) e0 r0 DECINT2(h0) l1 DECINT1(h1) e1 r1 DECINT1(h1)+ u (P l0 e0 r0) h0 (P l1 e1 r1) h1 = u_ l0 DECINT1(h0) e0 r0 DECINT2(h0) l1 DECINT1(h1) e1 r1 DECINT2(h1)+ u_ l0 hl0 e0 r0 hr0 l1 hl1 e1 r1 hr1 =+ case c e0 e1 of+ -- e0 < e1, so (l0 < e0 < e1) & (e0 < e1 < r1)+ Lt -> case forkR r0 hr0 e1 of+ UBT5(rl0,hrl0,mbe1_,rr0,hrr0) -> case forkL e0 l1 hl1 of -- (e0 < rl0 < e1) & (e0 < e1 < rr0)+ UBT5(ll1,hll1,mbe0_,lr1,hlr1) -> -- (ll1 < e0 < e1) & (e0 < lr1 < e1)+ -- (l0 + ll1) < e0 < (rl0 + lr1) < e1 < (rr0 + r1)+ case u l0 hl0 ll1 hll1 of+ UBT2(l,hl) -> case u rl0 hrl0 lr1 hlr1 of+ UBT2(m,hm) -> case u rr0 hrr0 r1 hr1 of+ UBT2(r,hr) -> case (case mbe1_ of+ Just e1_ -> spliceH m hm e1_ r hr+ Nothing -> joinH m hm r hr+ ) of+ UBT2(t,ht) -> case mbe0_ of+ Just e0_ -> spliceH l hl e0_ t ht+ Nothing -> joinH l hl t ht+ -- e0 = e1+ Eq mbe -> case u l0 hl0 l1 hl1 of+ UBT2(l,hl) -> case u r0 hr0 r1 hr1 of+ UBT2(r,hr) -> case mbe of+ Just e -> spliceH l hl e r hr+ Nothing -> joinH l hl r hr+ -- e1 < e0, so (l1 < e1 < e0) & (e1 < e0 < r0)+ Gt -> case forkL e0 r1 hr1 of+ UBT5(rl1,hrl1,mbe0_,rr1,hrr1) -> case forkR l0 hl0 e1 of -- (e1 < rl1 < e0) & (e1 < e0 < rr1)+ UBT5(ll0,hll0,mbe1_,lr0,hlr0) -> -- (ll0 < e1 < e0) & (e1 < lr0 < e0)+ -- (ll0 + l1) < e1 < (lr0 + rl1) < e0 < (r0 + rr1)+ case u ll0 hll0 l1 hl1 of+ UBT2(l,hl) -> case u lr0 hlr0 rl1 hrl1 of+ UBT2(m,hm) -> case u r0 hr0 rr1 hrr1 of+ UBT2(r,hr) -> case (case mbe1_ of+ Just e1_ -> spliceH l hl e1_ m hm+ Nothing -> joinH l hl m hm+ ) of+ UBT2(t,ht) -> case mbe0_ of+ Just e0_ -> spliceH t ht e0_ r hr+ Nothing -> joinH t ht r hr+ -- We need 2 different versions of fork (L & R) to ensure that comparison arguments are used in+ -- the right order (c e0 e1)+ -- forkL :: e -> AVL e -> UINT -> UBT5(AVL e,UINT,Maybe e,AVL e,UINT)+ forkL e0 t1 ht1 = forkL_ t1 ht1 where+ forkL_ E _ = UBT5(E, L(0), Just e0, E, L(0))+ forkL_ (N l e r) h = forkL__ l DECINT2(h) e r DECINT1(h)+ forkL_ (Z l e r) h = forkL__ l DECINT1(h) e r DECINT1(h)+ forkL_ (P l e r) h = forkL__ l DECINT1(h) e r DECINT2(h)+ forkL__ l hl e r hr = case c e0 e of+ Lt -> case forkL_ l hl of+ UBT5(l0,hl0,mbe0_,l1,hl1) -> case spliceH l1 hl1 e r hr of+ UBT2(l1_,hl1_) -> UBT5(l0,hl0,mbe0_,l1_,hl1_)+ Eq mbe0_ -> UBT5(l,hl,mbe0_,r,hr)+ Gt -> case forkL_ r hr of+ UBT5(l0,hl0,mbe0_,l1,hl1) -> case spliceH l hl e l0 hl0 of+ UBT2(l0_,hl0_) -> UBT5(l0_,hl0_,mbe0_,l1,hl1)+ -- forkR :: AVL e -> UINT -> e -> UBT5(AVL e,UINT,Maybe e,AVL e,UINT)+ forkR t0 ht0 e1 = forkR_ t0 ht0 where+ forkR_ E _ = UBT5(E, L(0), Just e1, E, L(0))+ forkR_ (N l e r) h = forkR__ l DECINT2(h) e r DECINT1(h)+ forkR_ (Z l e r) h = forkR__ l DECINT1(h) e r DECINT1(h)+ forkR_ (P l e r) h = forkR__ l DECINT1(h) e r DECINT2(h)+ forkR__ l hl e r hr = case c e e1 of+ Lt -> case forkR_ r hr of+ UBT5(l0,hl0,mbe1_,l1,hl1) -> case spliceH l hl e l0 hl0 of+ UBT2(l0_,hl0_) -> UBT5(l0_,hl0_,mbe1_,l1,hl1)+ Eq mbe1_ -> UBT5(l,hl,mbe1_,r,hr)+ Gt -> case forkR_ l hl of+ UBT5(l0,hl0,mbe1_,l1,hl1) -> case spliceH l1 hl1 e r hr of+ UBT2(l1_,hl1_) -> UBT5(l0,hl0,mbe1_,l1_,hl1_)+-----------------------------------------------------------------------+----------------------- unionMaybeH Ends Here -------------------------+-----------------------------------------------------------------------+++-- | Uses the supplied combining comparison to evaluate the intersection of two sets represented as+-- sorted AVL trees. This function requires no height information at all for+-- the two tree inputs. The absolute height of the resulting tree is returned also.+--+-- Complexity: Not sure, but I_d appreciate it if someone could figure it out.+intersectionH :: (a -> b -> COrdering c) -> AVL a -> AVL b -> UBT2(AVL c,UINT)+intersectionH comp = i where+ -- i :: AVL a -> AVL b -> UBT2(AVL c,UINT)+ i E _ = UBT2(E,L(0))+ i _ E = UBT2(E,L(0))+ i (N l0 e0 r0) (N l1 e1 r1) = i_ l0 e0 r0 l1 e1 r1+ i (N l0 e0 r0) (Z l1 e1 r1) = i_ l0 e0 r0 l1 e1 r1+ i (N l0 e0 r0) (P l1 e1 r1) = i_ l0 e0 r0 l1 e1 r1+ i (Z l0 e0 r0) (N l1 e1 r1) = i_ l0 e0 r0 l1 e1 r1+ i (Z l0 e0 r0) (Z l1 e1 r1) = i_ l0 e0 r0 l1 e1 r1+ i (Z l0 e0 r0) (P l1 e1 r1) = i_ l0 e0 r0 l1 e1 r1+ i (P l0 e0 r0) (N l1 e1 r1) = i_ l0 e0 r0 l1 e1 r1+ i (P l0 e0 r0) (Z l1 e1 r1) = i_ l0 e0 r0 l1 e1 r1+ i (P l0 e0 r0) (P l1 e1 r1) = i_ l0 e0 r0 l1 e1 r1+ i_ l0 e0 r0 l1 e1 r1 =+ case comp e0 e1 of+ -- e0 < e1, so (l0 < e0 < e1) & (e0 < e1 < r1)+ Lt -> case forkR r0 e1 of+ UBT5(rl0,_,mbc1,rr0,_) -> case forkL e0 l1 of -- (e0 < rl0 < e1) & (e0 < e1 < rr0)+ UBT5(ll1,_,mbc0,lr1,_) -> -- (ll1 < e0 < e1) & (e0 < lr1 < e1)+ -- (l0 + ll1) < e0 < (rl0 + lr1) < e1 < (rr0 + r1)+ case i rr0 r1 of+ UBT2(r,hr) -> case i rl0 lr1 of+ UBT2(m,hm) -> case i l0 ll1 of+ UBT2(l,hl) -> case (case mbc1 of+ Just c1 -> spliceH m hm c1 r hr+ Nothing -> joinH m hm r hr+ ) of+ UBT2(t,ht) -> case mbc0 of+ Just c0 -> spliceH l hl c0 t ht+ Nothing -> joinH l hl t ht+ -- e0 = e1+ Eq c -> case i l0 l1 of+ UBT2(l,hl) -> case i r0 r1 of+ UBT2(r,hr) -> spliceH l hl c r hr+ -- e1 < e0, so (l1 < e1 < e0) & (e1 < e0 < r0)+ Gt -> case forkL e0 r1 of+ UBT5(rl1,_,mbc0,rr1,_) -> case forkR l0 e1 of -- (e1 < rl1 < e0) & (e1 < e0 < rr1)+ UBT5(ll0,_,mbc1,lr0,_) -> -- (ll0 < e1 < e0) & (e1 < lr0 < e0)+ -- (ll0 + l1) < e1 < (lr0 + rl1) < e0 < (r0 + rr1)+ case i r0 rr1 of+ UBT2(r,hr) -> case i lr0 rl1 of+ UBT2(m,hm) -> case i ll0 l1 of+ UBT2(l,hl) -> case (case mbc0 of+ Just c0 -> spliceH m hm c0 r hr+ Nothing -> joinH m hm r hr+ ) of+ UBT2(t,ht) -> case mbc1 of+ Just c1 -> spliceH l hl c1 t ht+ Nothing -> joinH l hl t ht+ -- We need 2 different versions of fork (L & R) to ensure that comparison arguments are used in+ -- the right order (c e0 e1)+ -- forkL :: a -> AVL b -> UBT5(AVL b,UINT,Maybe c,AVL b,UINT)+ forkL e0 t1 = forkL_ t1 L(0) where+ forkL_ E h = UBT5(E,h,Nothing,E,h) -- Relative heights!!+ forkL_ (N l e r) h = forkL__ l DECINT2(h) e r DECINT1(h)+ forkL_ (Z l e r) h = forkL__ l DECINT1(h) e r DECINT1(h)+ forkL_ (P l e r) h = forkL__ l DECINT1(h) e r DECINT2(h)+ forkL__ l hl e r hr = case comp e0 e of+ Lt -> case forkL_ l hl of+ UBT5(l0,hl0,mbc0,l1,hl1) -> case spliceH l1 hl1 e r hr of+ UBT2(l1_,hl1_) -> UBT5(l0,hl0,mbc0,l1_,hl1_)+ Eq c0 -> UBT5(l,hl,Just c0,r,hr)+ Gt -> case forkL_ r hr of+ UBT5(l0,hl0,mbc0,l1,hl1) -> case spliceH l hl e l0 hl0 of+ UBT2(l0_,hl0_) -> UBT5(l0_,hl0_,mbc0,l1,hl1)+ -- forkR :: AVL a -> b -> UBT5(AVL a,UINT,Maybe c,AVL a,UINT)+ forkR t0 e1 = forkR_ t0 L(0) where+ forkR_ E h = UBT5(E,h,Nothing,E,h) -- Relative heights!!+ forkR_ (N l e r) h = forkR__ l DECINT2(h) e r DECINT1(h)+ forkR_ (Z l e r) h = forkR__ l DECINT1(h) e r DECINT1(h)+ forkR_ (P l e r) h = forkR__ l DECINT1(h) e r DECINT2(h)+ forkR__ l hl e r hr = case comp e e1 of+ Lt -> case forkR_ r hr of+ UBT5(l0,hl0,mbc1,l1,hl1) -> case spliceH l hl e l0 hl0 of+ UBT2(l0_,hl0_) -> UBT5(l0_,hl0_,mbc1,l1,hl1)+ Eq c1 -> UBT5(l,hl,Just c1,r,hr)+ Gt -> case forkR_ l hl of+ UBT5(l0,hl0,mbc1,l1,hl1) -> case spliceH l1 hl1 e r hr of+ UBT2(l1_,hl1_) -> UBT5(l0,hl0,mbc1,l1_,hl1_)+-----------------------------------------------------------------------+---------------------- intersectionH Ends Here ------------------------+-----------------------------------------------------------------------++-- | Similar to _intersectionH_, but the resulting tree does not include elements in cases where+-- the supplied combining comparison returns @(Eq Nothing)@.+--+-- Complexity: Not sure, but I_d appreciate it if someone could figure it out.+intersectionMaybeH :: (a -> b -> COrdering (Maybe c)) -> AVL a -> AVL b -> UBT2(AVL c,UINT)+intersectionMaybeH comp = i where+ -- i :: AVL a -> AVL b -> UBT2(AVL c,UINT)+ i E _ = UBT2(E,L(0))+ i _ E = UBT2(E,L(0))+ i (N l0 e0 r0) (N l1 e1 r1) = i_ l0 e0 r0 l1 e1 r1+ i (N l0 e0 r0) (Z l1 e1 r1) = i_ l0 e0 r0 l1 e1 r1+ i (N l0 e0 r0) (P l1 e1 r1) = i_ l0 e0 r0 l1 e1 r1+ i (Z l0 e0 r0) (N l1 e1 r1) = i_ l0 e0 r0 l1 e1 r1+ i (Z l0 e0 r0) (Z l1 e1 r1) = i_ l0 e0 r0 l1 e1 r1+ i (Z l0 e0 r0) (P l1 e1 r1) = i_ l0 e0 r0 l1 e1 r1+ i (P l0 e0 r0) (N l1 e1 r1) = i_ l0 e0 r0 l1 e1 r1+ i (P l0 e0 r0) (Z l1 e1 r1) = i_ l0 e0 r0 l1 e1 r1+ i (P l0 e0 r0) (P l1 e1 r1) = i_ l0 e0 r0 l1 e1 r1+ i_ l0 e0 r0 l1 e1 r1 =+ case comp e0 e1 of+ -- e0 < e1, so (l0 < e0 < e1) & (e0 < e1 < r1)+ Lt -> case forkR r0 e1 of+ UBT5(rl0,_,mbc1,rr0,_) -> case forkL e0 l1 of -- (e0 < rl0 < e1) & (e0 < e1 < rr0)+ UBT5(ll1,_,mbc0,lr1,_) -> -- (ll1 < e0 < e1) & (e0 < lr1 < e1)+ -- (l0 + ll1) < e0 < (rl0 + lr1) < e1 < (rr0 + r1)+ case i rr0 r1 of+ UBT2(r,hr) -> case i rl0 lr1 of+ UBT2(m,hm) -> case i l0 ll1 of+ UBT2(l,hl) -> case (case mbc1 of+ Just c1 -> spliceH m hm c1 r hr+ Nothing -> joinH m hm r hr+ ) of+ UBT2(t,ht) -> case mbc0 of+ Just c0 -> spliceH l hl c0 t ht+ Nothing -> joinH l hl t ht+ -- e0 = e1+ Eq mbc -> case i l0 l1 of+ UBT2(l,hl) -> case i r0 r1 of+ UBT2(r,hr) -> case mbc of+ Just c -> spliceH l hl c r hr+ Nothing -> joinH l hl r hr+ -- e1 < e0, so (l1 < e1 < e0) & (e1 < e0 < r0)+ Gt -> case forkL e0 r1 of+ UBT5(rl1,_,mbc0,rr1,_) -> case forkR l0 e1 of -- (e1 < rl1 < e0) & (e1 < e0 < rr1)+ UBT5(ll0,_,mbc1,lr0,_) -> -- (ll0 < e1 < e0) & (e1 < lr0 < e0)+ -- (ll0 + l1) < e1 < (lr0 + rl1) < e0 < (r0 + rr1)+ case i r0 rr1 of+ UBT2(r,hr) -> case i lr0 rl1 of+ UBT2(m,hm) -> case i ll0 l1 of+ UBT2(l,hl) -> case (case mbc0 of+ Just c0 -> spliceH m hm c0 r hr+ Nothing -> joinH m hm r hr+ ) of+ UBT2(t,ht) -> case mbc1 of+ Just c1 -> spliceH l hl c1 t ht+ Nothing -> joinH l hl t ht+ -- We need 2 different versions of fork (L & R) to ensure that comparison arguments are used in+ -- the right order (c e0 e1)+ -- forkL :: a -> AVL b -> UBT5(AVL b,UINT,Maybe c,AVL b,UINT)+ forkL e0 t1 = forkL_ t1 L(0) where+ forkL_ E h = UBT5(E,h,Nothing,E,h) -- Relative heights!!+ forkL_ (N l e r) h = forkL__ l DECINT2(h) e r DECINT1(h)+ forkL_ (Z l e r) h = forkL__ l DECINT1(h) e r DECINT1(h)+ forkL_ (P l e r) h = forkL__ l DECINT1(h) e r DECINT2(h)+ forkL__ l hl e r hr = case comp e0 e of+ Lt -> case forkL_ l hl of+ UBT5(l0,hl0,mbc0,l1,hl1) -> case spliceH l1 hl1 e r hr of+ UBT2(l1_,hl1_) -> UBT5(l0,hl0,mbc0,l1_,hl1_)+ Eq mbc0_ -> UBT5(l,hl,mbc0_,r,hr)+ Gt -> case forkL_ r hr of+ UBT5(l0,hl0,mbc0,l1,hl1) -> case spliceH l hl e l0 hl0 of+ UBT2(l0_,hl0_) -> UBT5(l0_,hl0_,mbc0,l1,hl1)+ -- forkR :: AVL a -> b -> UBT5(AVL a,UINT,Maybe c,AVL a,UINT)+ forkR t0 e1 = forkR_ t0 L(0) where+ forkR_ E h = UBT5(E,h,Nothing,E,h) -- Relative heights!!+ forkR_ (N l e r) h = forkR__ l DECINT2(h) e r DECINT1(h)+ forkR_ (Z l e r) h = forkR__ l DECINT1(h) e r DECINT1(h)+ forkR_ (P l e r) h = forkR__ l DECINT1(h) e r DECINT2(h)+ forkR__ l hl e r hr = case comp e e1 of+ Lt -> case forkR_ r hr of+ UBT5(l0,hl0,mbc1,l1,hl1) -> case spliceH l hl e l0 hl0 of+ UBT2(l0_,hl0_) -> UBT5(l0_,hl0_,mbc1,l1,hl1)+ Eq mbc1_ -> UBT5(l,hl,mbc1_,r,hr)+ Gt -> case forkR_ l hl of+ UBT5(l0,hl0,mbc1,l1,hl1) -> case spliceH l1 hl1 e r hr of+ UBT2(l1_,hl1_) -> UBT5(l0,hl0,mbc1,l1_,hl1_)+-----------------------------------------------------------------------+-------------------- intersectionMaybeH Ends Here ---------------------+-----------------------------------------------------------------------++-- | Uses the supplied comparison to evaluate the difference between two sets represented as+-- sorted AVL trees.+--+-- N.B. This function works with relative heights for the first tree and needs no height+-- information for the second tree, so it_s OK to initialise the height of the first to zero,+-- rather than calculating the absolute height. However, if you do this the height of the resulting+-- tree will be incorrect also (it will have the same fixed offset as the first tree).+--+-- Complexity: Not sure, but I_d appreciate it if someone could figure it out.+differenceH :: (a -> b -> Ordering) -> AVL a -> UINT -> AVL b -> UBT2(AVL a,UINT)+differenceH comp = d where+ -- d :: AVL a -> UINT -> AVL b -> UBT2(AVL a,UINT)+ d E h0 _ = UBT2(E ,h0) -- Relative heights!!+ d t0 h0 E = UBT2(t0,h0)+ d (N l0 e0 r0) h0 (N l1 e1 r1) = d_ l0 DECINT2(h0) e0 r0 DECINT1(h0) l1 e1 r1+ d (N l0 e0 r0) h0 (Z l1 e1 r1) = d_ l0 DECINT2(h0) e0 r0 DECINT1(h0) l1 e1 r1+ d (N l0 e0 r0) h0 (P l1 e1 r1) = d_ l0 DECINT2(h0) e0 r0 DECINT1(h0) l1 e1 r1+ d (Z l0 e0 r0) h0 (N l1 e1 r1) = d_ l0 DECINT1(h0) e0 r0 DECINT1(h0) l1 e1 r1+ d (Z l0 e0 r0) h0 (Z l1 e1 r1) = d_ l0 DECINT1(h0) e0 r0 DECINT1(h0) l1 e1 r1+ d (Z l0 e0 r0) h0 (P l1 e1 r1) = d_ l0 DECINT1(h0) e0 r0 DECINT1(h0) l1 e1 r1+ d (P l0 e0 r0) h0 (N l1 e1 r1) = d_ l0 DECINT1(h0) e0 r0 DECINT2(h0) l1 e1 r1+ d (P l0 e0 r0) h0 (Z l1 e1 r1) = d_ l0 DECINT1(h0) e0 r0 DECINT2(h0) l1 e1 r1+ d (P l0 e0 r0) h0 (P l1 e1 r1) = d_ l0 DECINT1(h0) e0 r0 DECINT2(h0) l1 e1 r1+ d_ l0 hl0 e0 r0 hr0 l1 e1 r1 =+ case comp e0 e1 of+ -- e0 < e1, so (l0 < e0 < e1) & (e0 < e1 < r1)+ LT -> case forkR r0 hr0 e1 of+ UBT4(rl0,hrl0, rr0,hrr0) -> case forkL e0 l1 of -- (e0 < rl0 < e1) & (e0 < e1 < rr0)+ UBT5(ll1,_ ,be0,lr1,_ ) -> -- (ll1 < e0 < e1) & (e0 < lr1 < e1)+ -- (l0 + ll1) < e0 < (rl0 + lr1) < e1 < (rr0 + r1)+ case d rr0 hrr0 r1 of -- right+ UBT2(r,hr) -> case d rl0 hrl0 lr1 of -- middle+ UBT2(m,hm) -> case d l0 hl0 ll1 of -- left+ UBT2(l,hl) -> case joinH m hm r hr of -- join middle right+ UBT2(y,hy) -> if be0+ then spliceH l hl e0 y hy+ else joinH l hl y hy+ -- e0 = e1+ EQ -> case d r0 hr0 r1 of -- right+ UBT2(r,hr) -> case d l0 hl0 l1 of -- left+ UBT2(l,hl) -> joinH l hl r hr+ -- e1 < e0, so (l1 < e1 < e0) & (e1 < e0 < r0)+ GT -> case forkL e0 r1 of+ UBT5(rl1,_ ,be0,rr1,_ ) -> case forkR l0 hl0 e1 of -- (e1 < rl1 < e0) & (e1 < e0 < rr1)+ UBT4(ll0,hll0, lr0,hlr0) -> -- (ll0 < e1 < e0) & (e1 < lr0 < e0)+ -- (ll0 + l1) < e1 < (lr0 + rl1) < e0 < (r0 + rr1)+ case d r0 hr0 rr1 of -- right+ UBT2(r,hr) -> case d lr0 hlr0 rl1 of -- middle+ UBT2(m,hm) -> case d ll0 hll0 l1 of -- left+ UBT2(l,hl) -> case joinH l hl m hm of -- join left middle+ UBT2(x,hx) -> if be0+ then spliceH x hx e0 r hr+ else joinH x hx r hr+ -- We need 2 different versions of fork (L & R) to ensure that comparison arguments are used in+ -- the right order (c e0 e1), and for other algorithmic reasons in this case.+ -- N.B. forkL returns True if t1 does not contain e0 (I.E. If e0 is an element of the result).+ -- forkL :: a -> AVL b -> UBT5(AVL b, UINT, Bool, AVL b, UINT)+ forkL e0 t1 = forkL_ t1 L(0) where+ forkL_ E h = UBT5(E,h,True,E,h) -- Relative heights!!+ forkL_ (N l e r) h = forkL__ l DECINT2(h) e r DECINT1(h)+ forkL_ (Z l e r) h = forkL__ l DECINT1(h) e r DECINT1(h)+ forkL_ (P l e r) h = forkL__ l DECINT1(h) e r DECINT2(h)+ forkL__ l hl e r hr = case comp e0 e of+ LT -> case forkL_ l hl of+ UBT5(x0,hx0,be0,x1,hx1) -> case spliceH x1 hx1 e r hr of+ UBT2(x1_,hx1_) -> UBT5(x0,hx0,be0,x1_,hx1_)+ EQ -> UBT5(l,hl,False,r,hr)+ GT -> case forkL_ r hr of+ UBT5(x0,hx0,be0,x1,hx1) -> case spliceH l hl e x0 hx0 of+ UBT2(x0_,hx0_) -> UBT5(x0_,hx0_,be0,x1,hx1)+ -- N.B. forkR t0, according to e1. Neither of the resulting forks will contain an element+ -- which is "equal" to e1.+ -- forkR :: AVL a -> UINT -> b -> UBT4(AVL a, UINT, AVL a, UINT)+ forkR t0 ht0 e1 = forkR_ t0 ht0 where+ forkR_ E h = UBT4(E,h,E,h) -- Relative heights!!+ forkR_ (N l e r) h = forkR__ l DECINT2(h) e r DECINT1(h)+ forkR_ (Z l e r) h = forkR__ l DECINT1(h) e r DECINT1(h)+ forkR_ (P l e r) h = forkR__ l DECINT1(h) e r DECINT2(h)+ forkR__ l hl e r hr = case comp e e1 of+ LT -> case forkR_ r hr of+ UBT4(x0,hx0,x1,hx1) -> case spliceH l hl e x0 hx0 of+ UBT2(x0_,hx0_) -> UBT4(x0_,hx0_,x1,hx1)+ EQ -> UBT4(l,hl,r,hr) -- e1 is dropped.+ GT -> case forkR_ l hl of+ UBT4(x0,hx0,x1,hx1) -> case spliceH x1 hx1 e r hr of+ UBT2(x1_,hx1_) -> UBT4(x0,hx0,x1_,hx1_)+-----------------------------------------------------------------------+----------------------- differenceH Ends Here -------------------------+-----------------------------------------------------------------------++-- | Similar to _differenceH_, but the resulting tree also includes those elements a\_ for which the+-- combining comparison returns @Eq (Just a\_)@.+--+-- N.B. This function works with relative heights for the first tree and needs no height+-- information for the second tree, so it_s OK to initialise the height of the first to zero,+-- rather than calculating the absolute height. However, if you do this the height of the resulting+-- tree will be incorrect also (it will have the same fixed offset as the first tree).+--+-- Complexity: Not sure, but I_d appreciate it if someone could figure it out.+differenceMaybeH :: (a -> b -> COrdering (Maybe a)) -> AVL a -> UINT -> AVL b -> UBT2(AVL a,UINT)+differenceMaybeH comp = d where+ -- d :: AVL a -> UINT -> AVL b -> UBT2(AVL a,UINT)+ d E h0 _ = UBT2(E ,h0) -- Relative heights!!+ d t0 h0 E = UBT2(t0,h0)+ d (N l0 e0 r0) h0 (N l1 e1 r1) = d_ l0 DECINT2(h0) e0 r0 DECINT1(h0) l1 e1 r1+ d (N l0 e0 r0) h0 (Z l1 e1 r1) = d_ l0 DECINT2(h0) e0 r0 DECINT1(h0) l1 e1 r1+ d (N l0 e0 r0) h0 (P l1 e1 r1) = d_ l0 DECINT2(h0) e0 r0 DECINT1(h0) l1 e1 r1+ d (Z l0 e0 r0) h0 (N l1 e1 r1) = d_ l0 DECINT1(h0) e0 r0 DECINT1(h0) l1 e1 r1+ d (Z l0 e0 r0) h0 (Z l1 e1 r1) = d_ l0 DECINT1(h0) e0 r0 DECINT1(h0) l1 e1 r1+ d (Z l0 e0 r0) h0 (P l1 e1 r1) = d_ l0 DECINT1(h0) e0 r0 DECINT1(h0) l1 e1 r1+ d (P l0 e0 r0) h0 (N l1 e1 r1) = d_ l0 DECINT1(h0) e0 r0 DECINT2(h0) l1 e1 r1+ d (P l0 e0 r0) h0 (Z l1 e1 r1) = d_ l0 DECINT1(h0) e0 r0 DECINT2(h0) l1 e1 r1+ d (P l0 e0 r0) h0 (P l1 e1 r1) = d_ l0 DECINT1(h0) e0 r0 DECINT2(h0) l1 e1 r1+ d_ l0 hl0 e0 r0 hr0 l1 e1 r1 =+ case comp e0 e1 of+ -- e0 < e1, so (l0 < e0 < e1) & (e0 < e1 < r1)+ Lt -> case forkR r0 hr0 e1 of+ UBT5( rl0,hrl0,mbe1,rr0,hrr0) -> case forkL e0 l1 of -- (e0 < rl0 < e1) & (e0 < e1 < rr0)+ UBT5(ll1,_ ,mbe0,lr1,_ ) -> -- (ll1 < e0 < e1) & (e0 < lr1 < e1)+ -- (l0 + ll1) < e0 < (rl0 + lr1) < e1 < (rr0 + r1)+ case d rr0 hrr0 r1 of -- right+ UBT2(r,hr) -> case d rl0 hrl0 lr1 of -- middle+ UBT2(m,hm) -> case d l0 hl0 ll1 of -- left+ UBT2(l,hl) -> case (case mbe1 of+ Just e1_ -> spliceH m hm e1_ r hr -- splice middle right with e1_+ Nothing -> joinH m hm r hr) of -- join middle right+ UBT2(y,hy) -> case mbe0 of+ Just e0_ -> spliceH l hl e0_ y hy+ Nothing -> joinH l hl y hy+ -- e0 = e1+ Eq mbe0 -> case d r0 hr0 r1 of -- right+ UBT2(r,hr) -> case d l0 hl0 l1 of -- left+ UBT2(l,hl) -> case mbe0 of+ Just e0_ -> spliceH l hl e0_ r hr -- retain updated e0+ Nothing -> joinH l hl r hr -- discard original e0+ -- e1 < e0, so (l1 < e1 < e0) & (e1 < e0 < r0)+ Gt -> case forkL e0 r1 of+ UBT5( rl1,_ ,mbe0,rr1,_ ) -> case forkR l0 hl0 e1 of -- (e1 < rl1 < e0) & (e1 < e0 < rr1)+ UBT5(ll0,hll0,mbe1,lr0,hlr0) -> -- (ll0 < e1 < e0) & (e1 < lr0 < e0)+ -- (ll0 + l1) < e1 < (lr0 + rl1) < e0 < (r0 + rr1)+ case d r0 hr0 rr1 of -- right+ UBT2(r,hr) -> case d lr0 hlr0 rl1 of -- middle+ UBT2(m,hm) -> case d ll0 hll0 l1 of -- left+ UBT2(l,hl) -> case (case mbe1 of+ Just e1_ -> spliceH l hl e1_ m hm -- splice left middle with e1_+ Nothing -> joinH l hl m hm) of -- join left middle+ UBT2(x,hx) -> case mbe0 of+ Just e0_ -> spliceH x hx e0_ r hr+ Nothing -> joinH x hx r hr+ -- We need 2 different versions of fork (L & R) to ensure that comparison arguments are used in+ -- the right order (c e0 e1), and for other algorithmic reasons in this case.+ -- N.B. forkL returns (Just e0) if t1 does not contain e0 (I.E. If original e0 is an element of the result).+ -- forkL :: a -> AVL b -> UBT5(AVL b, UINT, Maybe a, AVL b, UINT)+ forkL e0 t1 = forkL_ t1 L(0) where+ forkL_ E h = UBT5(E,h,Just e0,E,h) -- Relative heights!!+ forkL_ (N l e r) h = forkL__ l DECINT2(h) e r DECINT1(h)+ forkL_ (Z l e r) h = forkL__ l DECINT1(h) e r DECINT1(h)+ forkL_ (P l e r) h = forkL__ l DECINT1(h) e r DECINT2(h)+ forkL__ l hl e r hr = case comp e0 e of+ Lt -> case forkL_ l hl of+ UBT5(x0,hx0,mbe0,x1,hx1) -> case spliceH x1 hx1 e r hr of+ UBT2(x1_,hx1_) -> UBT5(x0,hx0,mbe0,x1_,hx1_)+ Eq mbe0 -> UBT5(l,hl,mbe0,r,hr)+ Gt -> case forkL_ r hr of+ UBT5(x0,hx0,mbe0,x1,hx1) -> case spliceH l hl e x0 hx0 of+ UBT2(x0_,hx0_) -> UBT5(x0_,hx0_,mbe0,x1,hx1)+ -- N.B. forkR t0, according to e1. Returns Nothing if t0 does not contain e1.+ -- forkR :: AVL a -> UINT -> b -> UBT5(AVL a, UINT, Maybe a, AVL a, UINT)+ forkR t0 ht0 e1 = forkR_ t0 ht0 where+ forkR_ E h = UBT5(E,h,Nothing,E,h) -- Relative heights!!+ forkR_ (N l e r) h = forkR__ l DECINT2(h) e r DECINT1(h)+ forkR_ (Z l e r) h = forkR__ l DECINT1(h) e r DECINT1(h)+ forkR_ (P l e r) h = forkR__ l DECINT1(h) e r DECINT2(h)+ forkR__ l hl e r hr = case comp e e1 of+ Lt -> case forkR_ r hr of+ UBT5(x0,hx0,mbe1,x1,hx1) -> case spliceH l hl e x0 hx0 of+ UBT2(x0_,hx0_) -> UBT5(x0_,hx0_,mbe1,x1,hx1)+ Eq mbe1 -> UBT5(l,hl,mbe1,r,hr)+ Gt -> case forkR_ l hl of+ UBT5(x0,hx0,mbe1,x1,hx1) -> case spliceH x1 hx1 e r hr of+ UBT2(x1_,hx1_) -> UBT5(x0,hx0,mbe1,x1_,hx1_)+-----------------------------------------------------------------------+--------------------- differenceMaybeH Ends Here ----------------------+-----------------------------------------------------------------------++-- | The symmetric difference is the set of elements which occur in one set or the other but /not both/.+--+-- Complexity: Not sure, but I_d appreciate it if someone could figure it out.+symDifferenceH :: (e -> e -> Ordering) -> AVL e -> UINT -> AVL e -> UINT -> UBT2(AVL e,UINT)+symDifferenceH c = u where+ -- u :: AVL e -> UINT -> AVL e -> UINT -> UBT2(AVL e,UINT)+ u E _ t1 h1 = UBT2(t1,h1)+ u t0 h0 E _ = UBT2(t0,h0)+ u (N l0 e0 r0) h0 (N l1 e1 r1) h1 = u_ l0 DECINT2(h0) e0 r0 DECINT1(h0) l1 DECINT2(h1) e1 r1 DECINT1(h1)+ u (N l0 e0 r0) h0 (Z l1 e1 r1) h1 = u_ l0 DECINT2(h0) e0 r0 DECINT1(h0) l1 DECINT1(h1) e1 r1 DECINT1(h1)+ u (N l0 e0 r0) h0 (P l1 e1 r1) h1 = u_ l0 DECINT2(h0) e0 r0 DECINT1(h0) l1 DECINT1(h1) e1 r1 DECINT2(h1)+ u (Z l0 e0 r0) h0 (N l1 e1 r1) h1 = u_ l0 DECINT1(h0) e0 r0 DECINT1(h0) l1 DECINT2(h1) e1 r1 DECINT1(h1)+ u (Z l0 e0 r0) h0 (Z l1 e1 r1) h1 = u_ l0 DECINT1(h0) e0 r0 DECINT1(h0) l1 DECINT1(h1) e1 r1 DECINT1(h1)+ u (Z l0 e0 r0) h0 (P l1 e1 r1) h1 = u_ l0 DECINT1(h0) e0 r0 DECINT1(h0) l1 DECINT1(h1) e1 r1 DECINT2(h1)+ u (P l0 e0 r0) h0 (N l1 e1 r1) h1 = u_ l0 DECINT1(h0) e0 r0 DECINT2(h0) l1 DECINT2(h1) e1 r1 DECINT1(h1)+ u (P l0 e0 r0) h0 (Z l1 e1 r1) h1 = u_ l0 DECINT1(h0) e0 r0 DECINT2(h0) l1 DECINT1(h1) e1 r1 DECINT1(h1)+ u (P l0 e0 r0) h0 (P l1 e1 r1) h1 = u_ l0 DECINT1(h0) e0 r0 DECINT2(h0) l1 DECINT1(h1) e1 r1 DECINT2(h1)+ u_ l0 hl0 e0 r0 hr0 l1 hl1 e1 r1 hr1 =+ case c e0 e1 of+ -- e0 < e1, so (l0 < e0 < e1) & (e0 < e1 < r1)+ LT -> case forkR r0 hr0 e1 of+ UBT5(rl0,hrl0,be1,rr0,hrr0) -> case forkL e0 l1 hl1 of -- (e0 < rl0 < e1) & (e0 < e1 < rr0)+ UBT5(ll1,hll1,be0,lr1,hlr1) -> -- (ll1 < e0 < e1) & (e0 < lr1 < e1)+ -- (l0 + ll1) < e0 < (rl0 + lr1) < e1 < (rr0 + r1)+ case u l0 hl0 ll1 hll1 of+ UBT2(l,hl) -> case u rl0 hrl0 lr1 hlr1 of+ UBT2(m,hm) -> case u rr0 hrr0 r1 hr1 of+ UBT2(r,hr) -> case (if be1 then spliceH m hm e1 r hr+ else joinH m hm r hr+ ) of+ UBT2(t,ht) -> if be0 then spliceH l hl e0 t ht+ else joinH l hl t ht+ -- e0 = e1+ EQ -> case u l0 hl0 l1 hl1 of+ UBT2(l,hl) -> case u r0 hr0 r1 hr1 of+ UBT2(r,hr) -> joinH l hl r hr+ -- e1 < e0, so (l1 < e1 < e0) & (e1 < e0 < r0)+ GT -> case forkL e0 r1 hr1 of+ UBT5(rl1,hrl1,be0,rr1,hrr1) -> case forkR l0 hl0 e1 of -- (e1 < rl1 < e0) & (e1 < e0 < rr1)+ UBT5(ll0,hll0,be1,lr0,hlr0) -> -- (ll0 < e1 < e0) & (e1 < lr0 < e0)+ -- (ll0 + l1) < e1 < (lr0 + rl1) < e0 < (r0 + rr1)+ case u ll0 hll0 l1 hl1 of+ UBT2(l,hl) -> case u lr0 hlr0 rl1 hrl1 of+ UBT2(m,hm) -> case u r0 hr0 rr1 hrr1 of+ UBT2(r,hr) -> case (if be1 then spliceH l hl e1 m hm+ else joinH l hl m hm+ ) of+ UBT2(t,ht) -> if be0 then spliceH t ht e0 r hr+ else joinH t ht r hr+ -- We need 2 different versions of fork (L & R) to ensure that comparison arguments are used in+ -- the right order (c e0 e1)+ -- forkL :: e -> AVL e -> UINT -> UBT5(AVL e,UINT,Bool,AVL e,UINT)+ forkL e0 t1 ht1 = forkL_ t1 ht1 where+ forkL_ E _ = UBT5(E, L(0), True, E, L(0))+ forkL_ (N l e r) h = forkL__ l DECINT2(h) e r DECINT1(h)+ forkL_ (Z l e r) h = forkL__ l DECINT1(h) e r DECINT1(h)+ forkL_ (P l e r) h = forkL__ l DECINT1(h) e r DECINT2(h)+ forkL__ l hl e r hr = case c e0 e of+ LT -> case forkL_ l hl of+ UBT5(l0,hl0,be0,l1,hl1) -> case spliceH l1 hl1 e r hr of+ UBT2(l1_,hl1_) -> UBT5(l0,hl0,be0,l1_,hl1_)+ EQ -> UBT5(l,hl,False,r,hr)+ GT -> case forkL_ r hr of+ UBT5(l0,hl0,be0,l1,hl1) -> case spliceH l hl e l0 hl0 of+ UBT2(l0_,hl0_) -> UBT5(l0_,hl0_,be0,l1,hl1)+ -- forkR :: AVL e -> UINT -> e -> UBT5(AVL e,UINT,Bool,AVL e,UINT)+ forkR t0 ht0 e1 = forkR_ t0 ht0 where+ forkR_ E _ = UBT5(E, L(0), True, E, L(0))+ forkR_ (N l e r) h = forkR__ l DECINT2(h) e r DECINT1(h)+ forkR_ (Z l e r) h = forkR__ l DECINT1(h) e r DECINT1(h)+ forkR_ (P l e r) h = forkR__ l DECINT1(h) e r DECINT2(h)+ forkR__ l hl e r hr = case c e e1 of+ LT -> case forkR_ r hr of+ UBT5(l0,hl0,be1,l1,hl1) -> case spliceH l hl e l0 hl0 of+ UBT2(l0_,hl0_) -> UBT5(l0_,hl0_,be1,l1,hl1)+ EQ -> UBT5(l,hl,False,r,hr)+ GT -> case forkR_ l hl of+ UBT5(l0,hl0,be1,l1,hl1) -> case spliceH l1 hl1 e r hr of+ UBT2(l1_,hl1_) -> UBT5(l0,hl0,be1,l1_,hl1_)+-----------------------------------------------------------------------+----------------------- symDifferenceH Ends Here ----------------------+-----------------------------------------------------------------------
+ Data/Tree/AVL/Internals/HeightUtils.hs view
@@ -0,0 +1,98 @@+{-# OPTIONS_GHC -fglasgow-exts #-}+-----------------------------------------------------------------------------+-- |+-- Module : Data.Tree.AVL.Internals.HeightUtils+-- Copyright : (c) Adrian Hey 2004,2005+-- License : BSD3+--+-- Maintainer : http://homepages.nildram.co.uk/~ahey/em.png+-- Stability : stable+-- Portability : portable+--+-- AVL tree height related utilities.+--+-- The functions defined here are not exported by the main Data.Tree.AVL module+-- because they violate the policy for AVL tree equality used elsewhere in this library.+-- You need to import this module explicitly if you want to use any of these functions.+-----------------------------------------------------------------------------+module Data.Tree.AVL.Internals.HeightUtils+ (height,addHeight,compareHeight, -- heightInt,+ ) where++import Data.Tree.AVL.Types(AVL(..))++#ifdef __GLASGOW_HASKELL__+import GHC.Base+#include "ghcdefs.h"+#else+#include "h98defs.h"+#endif++-- {-# INLINE heightInt #-} -- Don't want this+-- heightInt :: AVL e -> Int+-- heightInt t = ASINT(addHeight L(0) t)++-- | Determine the height of an AVL tree.+--+-- Complexity: O(log n)+{-# INLINE height #-}+height :: AVL e -> UINT+height t = addHeight L(0) t++-- | Adds the height of a tree to the first argument.+--+-- Complexity: O(log n)+addHeight :: UINT -> AVL e -> UINT+addHeight h E = h+addHeight h (N l _ _) = addHeight INCINT2(h) l+addHeight h (Z l _ _) = addHeight INCINT1(h) l+addHeight h (P _ _ r) = addHeight INCINT2(h) r++-- | A fast algorithm for comparing the heights of two trees. This algorithm avoids the need+-- to compute the heights of both trees and should offer better performance if the trees differ+-- significantly in height. But if you need the heights anyway it will be quicker to just evaluate+-- them both and compare the results.+--+-- Complexity: O(log n), where n is the size of the smaller of the two trees.+compareHeight :: AVL a -> AVL b -> Ordering+compareHeight = ch L(0) where -- d = hA-hB+ ch :: UINT -> AVL a -> AVL b -> Ordering+ ch d E E = COMPAREUINT d L(0)+ ch d E (N l1 _ _ ) = chA DECINT2(d) l1+ ch d E (Z l1 _ _ ) = chA DECINT1(d) l1+ ch d E (P _ _ r1) = chA DECINT2(d) r1+ ch d (N l0 _ _ ) E = chB INCINT2(d) l0+ ch d (N l0 _ _ ) (N l1 _ _ ) = ch d l0 l1+ ch d (N l0 _ _ ) (Z l1 _ _ ) = ch INCINT1(d) l0 l1+ ch d (N l0 _ _ ) (P _ _ r1) = ch d l0 r1+ ch d (Z l0 _ _ ) E = chB INCINT1(d) l0+ ch d (Z l0 _ _ ) (N l1 _ _ ) = ch DECINT1(d) l0 l1+ ch d (Z l0 _ _ ) (Z l1 _ _ ) = ch d l0 l1+ ch d (Z l0 _ _ ) (P _ _ r1) = ch DECINT1(d) l0 r1+ ch d (P _ _ r0) E = chB INCINT2(d) r0+ ch d (P _ _ r0) (N l1 _ _ ) = ch d r0 l1+ ch d (P _ _ r0) (Z l1 _ _ ) = ch INCINT1(d) r0 l1+ ch d (P _ _ r0) (P _ _ r1) = ch d r0 r1+ -- Tree A ended first, continue with Tree B until hA-hB<0, or Tree B ends+ chA d tB = case COMPAREUINT d L(0) of+ LT -> LT+ EQ -> case tB of+ E -> EQ+ _ -> LT+ GT -> case tB of+ E -> GT+ N l _ _ -> chA DECINT2(d) l+ Z l _ _ -> chA DECINT1(d) l+ P _ _ r -> chA DECINT2(d) r+ -- Tree B ended first, continue with Tree A until hA-hB>0, or Tree A ends+ chB d tA = case COMPAREUINT d L(0) of+ GT -> GT+ EQ -> case tA of+ E -> EQ+ _ -> GT+ LT -> case tA of+ E -> LT+ N l _ _ -> chB INCINT2(d) l+ Z l _ _ -> chB INCINT1(d) l+ P _ _ r -> chB INCINT2(d) r+
+ Data/Tree/AVL/Join.hs view
@@ -0,0 +1,121 @@+{-# OPTIONS_GHC -fglasgow-exts #-}+-----------------------------------------------------------------------------+-- |+-- Module : Data.Tree.AVL.Join+-- Copyright : (c) Adrian Hey 2004,2005+-- License : BSD3+--+-- Maintainer : http://homepages.nildram.co.uk/~ahey/em.png+-- Stability : stable+-- Portability : portable+-----------------------------------------------------------------------------+module Data.Tree.AVL.Join+(-- * Joining AVL trees+ join,concatAVL,flatConcat,+) where++import Data.Tree.AVL.Types(AVL(..))+import Data.Tree.AVL.Size(addSize)+import Data.Tree.AVL.List(asTreeLenL,toListL)+import Data.Tree.AVL.Internals.DelUtils(popHLN,popHLZ,popHLP)+import Data.Tree.AVL.Internals.HeightUtils(height,addHeight)+import Data.Tree.AVL.Internals.HJoin(joinH',spliceH)++import Data.List(foldl')++#ifdef __GLASGOW_HASKELL__+import GHC.Base+#include "ghcdefs.h"+#else+#include "h98defs.h"+#endif++-- | Join two AVL trees. This is the AVL equivalent of (++).+--+-- > asListL (l `join` r) = asListL l ++ asListL r+--+-- Complexity: O(log n), where n is the size of the larger of the two trees.+join :: AVL e -> AVL e -> AVL e+join l r = joinH' l (height l) r (height r)++-- Specialised list of AVL trees of known height, with leftmost element popped.+-- (used by concatAVL).+data HAVLS e = HE | H e (AVL e) UINT (HAVLS e)++-- | Concatenate a /finite/ list of AVL trees. During construction of the resulting tree the+-- input list is consumed lazily, but it will be consumed entirely before the result is returned.+--+-- > asListL (concatAVL avls) = concatMap asListL avls+--+-- Complexity: Umm..Dunno. Uses a divide and conquer approach to splice adjacent pairs of+-- trees in the list recursively, until only one tree remains. The complexity of each splice+-- is proportional to the difference in tree heights.+concatAVL :: [AVL e] -> AVL e+concatAVL [] = E+concatAVL ( E :ts) = concatAVL ts+concatAVL (t@(N l _ _):ts) = concatHAVLS t (addHeight L(2) l) (mkHAVLS ts)+concatAVL (t@(Z l _ _):ts) = concatHAVLS t (addHeight L(1) l) (mkHAVLS ts)+concatAVL (t@(P _ _ r):ts) = concatHAVLS t (addHeight L(2) r) (mkHAVLS ts)++-- Recursively call mergePairs until only one tree remains.+-- The head of the current list has to be treated specially becuase it has no associated+-- bridging element.+concatHAVLS :: AVL e -> UINT -> HAVLS e -> AVL e+concatHAVLS l _ HE = l+concatHAVLS l hl (H e r hr hs) = case mergePairs l hl e r hr hs of+ UBT3(t,ht,hs_) -> concatHAVLS t ht hs_+++-- Merge adjacent pairs in the current list.+-- The head of the current list has to be treated specially becuase it has no associated+-- bridging element.+-- This function is strict in both elements of the result pair.+{-# INLINE mergePairs #-}+mergePairs :: AVL e -> UINT -> e -> AVL e -> UINT -> HAVLS e -> UBT3(AVL e,UINT,HAVLS e)+mergePairs l hl e r hr hs = case spliceH l hl e r hr of+ UBT2(t,ht) -> case hs of+ HE -> UBT3(t,ht,HE)+ H e_ t_ ht_ hs_ -> let hs__ = mergePairs_ e_ t_ ht_ hs_+ in hs__ `seq` UBT3(t,ht,hs__)++-- Deals with the rest of mergePairs after the head of the current list has been dealt with.+-- This function is strict in the resulting list head and lazy in the tail.+mergePairs_ :: e -> AVL e -> UINT -> HAVLS e -> HAVLS e+mergePairs_ e l hl HE = H e l hl HE+mergePairs_ e l hl (H e_ r hr hs) = case spliceH l hl e_ r hr of+ UBT2(t,ht) -> case hs of+ HE -> H e t ht HE+ H e__ r_ hr_ hs_ -> H e t ht (mergePairs_ e__ r_ hr_ hs_)++-- Uses popHL to get the leftmost element from each tree and calculate the (popped) tree height.+-- The popped element is used as a bridging element for splicing purposes.+-- Empty and singleton trees get special treatment.+-- This function is strict in the resulting list head and lazy in the tail.+mkHAVLS :: [AVL e] -> HAVLS e+mkHAVLS [] = HE+mkHAVLS ( E :ts) = mkHAVLS ts -- Discard empty trees+mkHAVLS ((N l e r):ts) = case popHLN l e r of -- Never a singlton with N+ UBT3(e_,t,ht) -> H e_ t ht (mkHAVLS ts)+mkHAVLS ((Z l e r):ts) = case popHLZ l e r of+ UBT3(e_,t,ht) -> if ht EQL L(0)+ then mkHAVLS_ e_ ts -- Deal with singleton+ else H e_ t ht (mkHAVLS ts) -- Otherwise treat as normal+mkHAVLS ((P l e r):ts) = case popHLP l e r of -- Never a singlton with P+ UBT3(e_,t,ht) -> H e_ t ht (mkHAVLS ts)+-- Deals with singletons (avoids unnecessary popHL in next in list)+mkHAVLS_ :: e -> [AVL e] -> HAVLS e+mkHAVLS_ e [] = H e E L(0) HE -- End of list reached anyway+mkHAVLS_ e ( E :ts) = mkHAVLS_ e ts -- Discard empty trees+mkHAVLS_ e (t@(N l _ _):ts) = H e t (addHeight L(2) l) (mkHAVLS ts)+mkHAVLS_ e (t@(Z l _ _):ts) = H e t (addHeight L(1) l) (mkHAVLS ts)+mkHAVLS_ e (t@(P _ _ r):ts) = H e t (addHeight L(2) r) (mkHAVLS ts)+-----------------------------------------------------------------------+---------------------- concatAVL Ends Here ----------------------------+-----------------------------------------------------------------------++-- | Similar to 'concatAVL', except the resulting tree is flat.+-- This function evaluates the entire list of trees before constructing the result.+--+-- Complexity: O(n), where n is the total number of elements in the resulting tree.+flatConcat :: [AVL e] -> AVL e+flatConcat avls = asTreeLenL (foldl' addSize 0 avls) (foldr toListL [] avls)
+ Data/Tree/AVL/List.hs view
@@ -0,0 +1,856 @@+{-# OPTIONS_GHC -fglasgow-exts #-}+-----------------------------------------------------------------------------+-- |+-- Module : Data.Tree.AVL.List+-- Copyright : (c) Adrian Hey 2004,2005+-- License : BSD3+--+-- Maintainer : http://homepages.nildram.co.uk/~ahey/em.png+-- Stability : stable+-- Portability : portable+-----------------------------------------------------------------------------+module Data.Tree.AVL.List+(-- * List related utilities for AVL trees++ -- ** Converting AVL trees to Lists (fixed element order).+ -- | These functions are lazy and allow normal lazy list processing+ -- style to be used (without necessarily converting the entire tree+ -- to a list in one gulp).+ asListL,toListL,asListR,toListR,++ -- ** Converting Lists to AVL trees (fixed element order)+ asTreeLenL,asTreeL,+ asTreeLenR,asTreeR,++ -- ** Converting unsorted Lists to sorted AVL trees+ genAsTree,++ -- ** \"Pushing\" unsorted Lists in sorted AVL trees+ genPushList,++ -- * Some analogues of common List functions+ reverseAVL,mapAVL,mapAVL',+ mapAccumLAVL ,mapAccumRAVL ,+ mapAccumLAVL' ,mapAccumRAVL' ,+#ifdef __GLASGOW_HASKELL__+ mapAccumLAVL'',mapAccumRAVL'',+#endif+#if __GLASGOW_HASKELL__ > 604+ traverseAVL,+#endif+ replicateAVL,+ filterAVL,mapMaybeAVL,+ filterViaList,mapMaybeViaList,+ partitionAVL,++ -- ** Folds+ -- | Note that unlike folds over lists ('foldr' and 'foldl'), there is no+ -- significant difference between left and right folds in AVL trees, other+ -- than which side of the tree each starts with.+ -- Therefore this library provides strict and lazy versions of both.+ foldrAVL,foldrAVL',foldr1AVL,foldr1AVL',foldr2AVL,foldr2AVL',+ foldlAVL,foldlAVL',foldl1AVL,foldl1AVL',foldl2AVL,foldl2AVL',+ foldrAVL_UINT,++ -- * \"Flattening\" AVL trees+ -- | These functions can be improve search times by reducing a tree of given size to+ -- the minimum possible height.+ flatten,+ flatReverse,flatMap,flatMap',++ -- * AVL tree based sorting of Lists+ -- | Nothing to do with AVL trees really. But using AVL trees do give an O(n.(log n)) sort+ -- algorithm for free, so here it is. These functions all consume the entire+ -- input list to construct a sorted AVL tree and then read the elements out as a list (lazily).+ genSortAscending,genSortDescending,+) where++import Prelude -- so haddock finds the symbols there++#if __GLASGOW_HASKELL__ > 604+import Control.Applicative hiding (empty)+#endif++import Data.COrdering+import Data.Tree.AVL.Types(AVL(..),empty)+import Data.Tree.AVL.Size(size)+import Data.Tree.AVL.Push(genPush)+import Data.Tree.AVL.Internals.HJoin(spliceH,joinH)++import Data.Bits(shiftR,(.&.))+import Data.List(foldl')++#ifdef __GLASGOW_HASKELL__+import GHC.Base+#include "ghcdefs.h"+#else+#include "h98defs.h"+#endif++-- | List AVL tree contents in left to right order.+-- The resulting list in ascending order if the tree is sorted.+--+-- Complexity: O(n)+asListL :: AVL e -> [e]+asListL avl = toListL avl []++-- | Join the AVL tree contents to an existing list in left to right order.+-- This is a ++ free function which behaves as if defined thusly..+--+-- > avl `toListL` as = (asListL avl) ++ as+--+-- Complexity: O(n)+toListL :: AVL e -> [e] -> [e]+toListL E es = es+toListL (N l e r) es = toListL' l e r es+toListL (Z l e r) es = toListL' l e r es+toListL (P l e r) es = toListL' l e r es+toListL' :: AVL e -> e -> AVL e -> [e] -> [e]+toListL' l e r es = toListL l (e:(toListL r es))++-- | List AVL tree contents in right to left order.+-- The resulting list in descending order if the tree is sorted.+--+-- Complexity: O(n)+asListR :: AVL e -> [e]+asListR avl = toListR avl []++-- | Join the AVL tree contents to an existing list in right to left order.+-- This is a ++ free function which behaves as if defined thusly..+--+-- > avl `toListR` as = (asListR avl) ++ as+--+-- Complexity: O(n)+toListR :: AVL e -> [e] -> [e]+toListR E es = es+toListR (N l e r) es = toListR' l e r es+toListR (Z l e r) es = toListR' l e r es+toListR (P l e r) es = toListR' l e r es+toListR' :: AVL e -> e -> AVL e -> [e] -> [e]+toListR' l e r es = toListR r (e:(toListR l es))++-- | The AVL equivalent of 'foldr' on lists. This is a the lazy version (as lazy as the folding function+-- anyway). Using this version with a function that is strict in it's second argument will result in O(n)+-- stack use. See 'foldrAVL'' for a strict version.+--+-- It behaves as if defined..+--+-- > foldrAVL f a avl = foldr f a (asListL avl)+--+-- For example, the 'asListL' function could be defined..+--+-- > asListL = foldrAVL (:) []+--+-- Complexity: O(n)+foldrAVL :: (e -> a -> a) -> a -> AVL e -> a+foldrAVL f = foldU where+ foldU a E = a+ foldU a (N l e r) = foldV a l e r+ foldU a (Z l e r) = foldV a l e r+ foldU a (P l e r) = foldV a l e r+ foldV a l e r = foldU (f e (foldU a r)) l++-- | The strict version of 'foldrAVL', which is useful for functions which are strict in their second+-- argument. The advantage of this version is that it reduces the stack use from the O(n) that the lazy+-- version gives (when used with strict functions) to O(log n).+--+-- Complexity: O(n)+foldrAVL' :: (e -> a -> a) -> a -> AVL e -> a+foldrAVL' f = foldU where+ foldU a E = a+ foldU a (N l e r) = foldV a l e r+ foldU a (Z l e r) = foldV a l e r+ foldU a (P l e r) = foldV a l e r+ foldV a l e r = let a' = foldU a r+ a'' = f e a'+ in a' `seq` a'' `seq` foldU a'' l++-- | The AVL equivalent of 'foldr1' on lists. This is a the lazy version (as lazy as the folding function+-- anyway). Using this version with a function that is strict in it's second argument will result in O(n)+-- stack use. See 'foldr1AVL'' for a strict version.+--+-- > foldr1AVL f avl = foldr1 f (asListL avl)+--+-- This function raises an error if the tree is empty.+--+-- Complexity: O(n)+foldr1AVL :: (e -> e -> e) -> AVL e -> e+foldr1AVL f = foldU where+ foldU E = error "foldr1AVL: Empty Tree"+ foldU (N l e r) = foldV l e r -- r can't be E+ foldU (Z l e r) = foldW l e r -- r might be E+ foldU (P l e r) = foldW l e r -- r might be E+ -- Use this when r can't be E+ foldV l e r = foldrAVL f (f e (foldU r)) l+ -- Use this when r might be E+ foldW l e E = foldrAVL f e l+ foldW l e (N rl re rr) = foldrAVL f (f e (foldV rl re rr)) l -- rr can't be E+ foldW l e (Z rl re rr) = foldX l e rl re rr -- rr might be E+ foldW l e (P rl re rr) = foldX l e rl re rr -- rr might be E+ -- Common code for foldW (Z and P cases)+ foldX l e rl re rr = foldrAVL f (f e (foldW rl re rr)) l++-- | The strict version of 'foldr1AVL', which is useful for functions which are strict in their second+-- argument. The advantage of this version is that it reduces the stack use from the O(n) that the lazy+-- version gives (when used with strict functions) to O(log n).+--+-- Complexity: O(n)+foldr1AVL' :: (e -> e -> e) -> AVL e -> e+foldr1AVL' f = foldU where+ foldU E = error "foldr1AVL': Empty Tree"+ foldU (N l e r) = foldV l e r -- r can't be E+ foldU (Z l e r) = foldW l e r -- r might be E+ foldU (P l e r) = foldW l e r -- r might be E+ -- Use this when r can't be E+ foldV l e r = let a = foldU r+ a' = f e a+ in a `seq` a' `seq` foldrAVL' f a' l+ -- Use this when r might be E+ foldW l e E = foldrAVL' f e l+ foldW l e (N rl re rr) = let a = foldV rl re rr -- rr can't be E+ a' = f e a+ in a `seq` a' `seq` foldrAVL' f a' l+ foldW l e (Z rl re rr) = foldX l e rl re rr -- rr might be E+ foldW l e (P rl re rr) = foldX l e rl re rr -- rr might be E+ -- Common code for foldW (Z and P cases)+ foldX l e rl re rr = let a = foldW rl re rr+ a' = f e a+ in a `seq` a' `seq` foldrAVL' f a' l++-- | This fold is a hybrid between 'foldrAVL' and 'foldr1AVL'. As with 'foldr1AVL', it requires+-- a non-empty tree, but instead of treating the rightmost element as an initial value, it applies+-- a function to it (second function argument) and uses the result instead. This allows+-- a more flexible type for the main folding function (same type as that used by 'foldrAVL').+-- As with 'foldrAVL' and 'foldr1AVL', this function is lazy, so it's best not to use it with functions+-- that are strict in their second argument. See 'foldr2AVL'' for a strict version.+--+-- Complexity: O(n)+foldr2AVL :: (e -> a -> a) -> (e -> a) -> AVL e -> a+foldr2AVL f g = foldU where+ foldU E = error "foldr2AVL: Empty Tree"+ foldU (N l e r) = foldV l e r -- r can't be E+ foldU (Z l e r) = foldW l e r -- r might be E+ foldU (P l e r) = foldW l e r -- r might be E+ -- Use this when r can't be E+ foldV l e r = foldrAVL f (f e (foldU r)) l+ -- Use this when r might be E+ foldW l e E = foldrAVL f (g e) l+ foldW l e (N rl re rr) = foldrAVL f (f e (foldV rl re rr)) l -- rr can't be E+ foldW l e (Z rl re rr) = foldX l e rl re rr -- rr might be E+ foldW l e (P rl re rr) = foldX l e rl re rr -- rr might be E+ -- Common code for foldW (Z and P cases)+ foldX l e rl re rr = foldrAVL f (f e (foldW rl re rr)) l++-- | The strict version of 'foldr2AVL', which is useful for functions which are strict in their second+-- argument. The advantage of this version is that it reduces the stack use from the O(n) that the lazy+-- version gives (when used with strict functions) to O(log n).+--+-- Complexity: O(n)+foldr2AVL' :: (e -> a -> a) -> (e -> a) -> AVL e -> a+foldr2AVL' f g = foldU where+ foldU E = error "foldr2AVL': Empty Tree"+ foldU (N l e r) = foldV l e r -- r can't be E+ foldU (Z l e r) = foldW l e r -- r might be E+ foldU (P l e r) = foldW l e r -- r might be E+ -- Use this when r can't be E+ foldV l e r = let a = foldU r+ a' = f e a+ in a `seq` a' `seq` foldrAVL' f a' l+ -- Use this when r might be E+ foldW l e E = let a = g e in a `seq` foldrAVL' f a l+ foldW l e (N rl re rr) = let a = foldV rl re rr -- rr can't be E+ a' = f e a+ in a `seq` a' `seq` foldrAVL' f a' l+ foldW l e (Z rl re rr) = foldX l e rl re rr -- rr might be E+ foldW l e (P rl re rr) = foldX l e rl re rr -- rr might be E+ -- Common code for foldW (Z and P cases)+ foldX l e rl re rr = let a = foldW rl re rr+ a' = f e a+ in a `seq` a' `seq` foldrAVL' f a' l+++-- | The AVL equivalent of 'foldl' on lists. This is a the lazy version (as lazy as the folding function+-- anyway). Using this version with a function that is strict in it's first argument will result in O(n)+-- stack use. See 'foldlAVL'' for a strict version.+--+-- > foldlAVL f a avl = foldl f a (asListL avl)+--+-- For example, the 'asListR' function could be defined..+--+-- > asListR = foldlAVL (flip (:)) []+--+-- Complexity: O(n)+foldlAVL :: (a -> e -> a) -> a -> AVL e -> a+foldlAVL f = foldU where+ foldU a E = a+ foldU a (N l e r) = foldV a l e r+ foldU a (Z l e r) = foldV a l e r+ foldU a (P l e r) = foldV a l e r+ foldV a l e r = foldU (f (foldU a l) e) r++-- | The strict version of 'foldlAVL', which is useful for functions which are strict in their first+-- argument. The advantage of this version is that it reduces the stack use from the O(n) that the lazy+-- version gives (when used with strict functions) to O(log n).+--+-- Complexity: O(n)+foldlAVL' :: (a -> e -> a) -> a -> AVL e -> a+foldlAVL' f = foldU where+ foldU a E = a+ foldU a (N l e r) = foldV a l e r+ foldU a (Z l e r) = foldV a l e r+ foldU a (P l e r) = foldV a l e r+ foldV a l e r = let a' = foldU a l+ a'' = f a' e+ in a' `seq` a'' `seq` foldU a'' r++-- | The AVL equivalent of 'foldl1' on lists. This is a the lazy version (as lazy as the folding function+-- anyway). Using this version with a function that is strict in it's first argument will result in O(n)+-- stack use. See 'foldl1AVL'' for a strict version.+--+-- > foldl1AVL f avl = foldl1 f (asListL avl)+--+-- This function raises an error if the tree is empty.+--+-- Complexity: O(n)+foldl1AVL :: (e -> e -> e) -> AVL e -> e+foldl1AVL f = foldU where+ foldU E = error "foldl1AVL: Empty Tree"+ foldU (N l e r) = foldW l e r -- l might be E+ foldU (Z l e r) = foldW l e r -- l might be E+ foldU (P l e r) = foldV l e r -- l can't be E+ -- Use this when l can't be E+ foldV l e r = foldlAVL f (f (foldU l) e) r+ -- Use this when l might be E+ foldW E e r = foldlAVL f e r+ foldW (N ll le lr) e r = foldX ll le lr e r -- ll might be E+ foldW (Z ll le lr) e r = foldX ll le lr e r -- ll might be E+ foldW (P ll le lr) e r = foldlAVL f (f (foldV ll le lr) e) r -- ll can't be E+ -- Common code for foldW (Z and P cases)+ foldX ll le lr e r = foldlAVL f (f (foldW ll le lr) e) r++-- | The strict version of 'foldl1AVL', which is useful for functions which are strict in their first+-- argument. The advantage of this version is that it reduces the stack use from the O(n) that the lazy+-- version gives (when used with strict functions) to O(log n).+--+-- Complexity: O(n)+foldl1AVL' :: (e -> e -> e) -> AVL e -> e+foldl1AVL' f = foldU where+ foldU E = error "foldl1AVL': Empty Tree"+ foldU (N l e r) = foldW l e r -- l might be E+ foldU (Z l e r) = foldW l e r -- l might be E+ foldU (P l e r) = foldV l e r -- l can't be E+ -- Use this when l can't be E+ foldV l e r = let a = foldU l+ a' = f a e+ in a `seq` a' `seq` foldlAVL' f a' r+ -- Use this when l might be E+ foldW E e r = foldlAVL' f e r+ foldW (N ll le lr) e r = foldX ll le lr e r -- ll might be E+ foldW (Z ll le lr) e r = foldX ll le lr e r -- ll might be E+ foldW (P ll le lr) e r = let a = foldV ll le lr -- ll can't be E+ a' = f a e+ in a `seq` a' `seq` foldlAVL' f a' r+ -- Common code for foldW (Z and P cases)+ foldX ll le lr e r = let a = foldW ll le lr+ a' = f a e+ in a `seq` a' `seq` foldlAVL' f a' r++-- | This fold is a hybrid between 'foldlAVL' and 'foldl1AVL'. As with 'foldl1AVL', it requires+-- a non-empty tree, but instead of treating the leftmost element as an initial value, it applies+-- a function to it (second function argument) and uses the result instead. This allows+-- a more flexible type for the main folding function (same type as that used by 'foldlAVL').+-- As with 'foldlAVL' and 'foldl1AVL', this function is lazy, so it's best not to use it with functions+-- that are strict in their first argument. See 'foldl2AVL'' for a strict version.+--+-- Complexity: O(n)+foldl2AVL :: (a -> e -> a) -> (e -> a) -> AVL e -> a+foldl2AVL f g = foldU where+ foldU E = error "foldl2AVL: Empty Tree"+ foldU (N l e r) = foldW l e r -- l might be E+ foldU (Z l e r) = foldW l e r -- l might be E+ foldU (P l e r) = foldV l e r -- l can't be E+ -- Use this when l can't be E+ foldV l e r = foldlAVL f (f (foldU l) e) r+ -- Use this when l might be E+ foldW E e r = foldlAVL f (g e) r+ foldW (N ll le lr) e r = foldX ll le lr e r -- ll might be E+ foldW (Z ll le lr) e r = foldX ll le lr e r -- ll might be E+ foldW (P ll le lr) e r = foldlAVL f (f (foldV ll le lr) e) r -- ll can't be E+ -- Common code for foldW (Z and P cases)+ foldX ll le lr e r = foldlAVL f (f (foldW ll le lr) e) r++-- | The strict version of 'foldl2AVL', which is useful for functions which are strict in their first+-- argument. The advantage of this version is that it reduces the stack use from the O(n) that the lazy+-- version gives (when used with strict functions) to O(log n).+--+-- Complexity: O(n)+foldl2AVL' :: (a -> e -> a) -> (e -> a) -> AVL e -> a+foldl2AVL' f g = foldU where+ foldU E = error "foldl2AVL': Empty Tree"+ foldU (N l e r) = foldW l e r -- l might be E+ foldU (Z l e r) = foldW l e r -- l might be E+ foldU (P l e r) = foldV l e r -- l can't be E+ -- Use this when l can't be E+ foldV l e r = let a = foldU l+ a' = f a e+ in a `seq` a' `seq` foldlAVL' f a' r+ -- Use this when l might be E+ foldW E e r = let a = g e in a `seq` foldlAVL' f a r+ foldW (N ll le lr) e r = foldX ll le lr e r -- ll might be E+ foldW (Z ll le lr) e r = foldX ll le lr e r -- ll might be E+ foldW (P ll le lr) e r = let a = foldV ll le lr -- ll can't be E+ a' = f a e+ in a `seq` a' `seq` foldlAVL' f a' r+ -- Common code for foldW (Z and P cases)+ foldX ll le lr e r = let a = foldW ll le lr+ a' = f a e+ in a `seq` a' `seq` foldlAVL' f a' r++-- | This is a specialised version of 'foldrAVL'' for use with an+-- /unboxed/ Int accumulator (with GHC). Defaults to boxed Int+-- for other Haskells.+--+-- Complexity: O(n)+foldrAVL_UINT :: (e -> UINT -> UINT) -> UINT -> AVL e -> UINT+#ifdef __GLASGOW_HASKELL__+foldrAVL_UINT f = foldU where+ foldU a E = a+ foldU a (N l e r) = foldV a l e r+ foldU a (Z l e r) = foldV a l e r+ foldU a (P l e r) = foldV a l e r+ foldV a l e r = foldU (f e (foldU a r)) l+#else+foldrAVL_UINT = foldrAVL' -- Strict version!+{-# INLINE foldrAVL_UINT #-}+#endif++-- | The AVL equivalent of 'Data.List.mapAccumL' on lists.+-- It behaves like a combination of 'mapAVL' and 'foldlAVL'.+-- It applies a function to each element of a tree, passing an accumulating parameter from+-- left to right, and returning a final value of this accumulator together with the new tree.+--+-- Using this version with a function that is strict in it's first argument will result in+-- O(n) stack use. See 'mapAccumLAVL'' for a strict version.+--+-- Complexity: O(n)+mapAccumLAVL :: (z -> a -> (z, b)) -> z -> AVL a -> (z, AVL b)+mapAccumLAVL f z ta = case mapAL z ta of+ UBT2(zt,tb) -> (zt,tb)+ where mapAL z_ E = UBT2(z_,E)+ mapAL z_ (N la a ra) = mapAL' z_ N la a ra+ mapAL z_ (Z la a ra) = mapAL' z_ Z la a ra+ mapAL z_ (P la a ra) = mapAL' z_ P la a ra+ {-# INLINE mapAL' #-}+ mapAL' z' c la a ra = case mapAL z' la of+ UBT2(zl,lb) -> let (za,b) = f zl a+ in case mapAL za ra of+ UBT2(zr,rb) -> UBT2(zr, c lb b rb)++-- | This is a strict version of 'mapAccumLAVL', which is useful for functions which+-- are strict in their first argument. The advantage of this version is that it reduces+-- the stack use from the O(n) that the lazy version gives (when used with strict functions)+-- to O(log n).+--+-- Complexity: O(n)+mapAccumLAVL' :: (z -> a -> (z, b)) -> z -> AVL a -> (z, AVL b)+mapAccumLAVL' f z ta = case mapAL z ta of+ UBT2(zt,tb) -> (zt,tb)+ where mapAL z_ E = UBT2(z_,E)+ mapAL z_ (N la a ra) = mapAL' z_ N la a ra+ mapAL z_ (Z la a ra) = mapAL' z_ Z la a ra+ mapAL z_ (P la a ra) = mapAL' z_ P la a ra+ {-# INLINE mapAL' #-}+ mapAL' z' c la a ra = case mapAL z' la of+ UBT2(zl,lb) -> case f zl a of+ (za,b) -> case mapAL za ra of+ UBT2(zr,rb) -> UBT2(zr, c lb b rb)+++-- | The AVL equivalent of 'Data.List.mapAccumR' on lists.+-- It behaves like a combination of 'mapAVL' and 'foldrAVL'.+-- It applies a function to each element of a tree, passing an accumulating parameter from+-- right to left, and returning a final value of this accumulator together with the new tree.+--+-- Using this version with a function that is strict in it's first argument will result in+-- O(n) stack use. See 'mapAccumRAVL'' for a strict version.+--+-- Complexity: O(n)+mapAccumRAVL :: (z -> a -> (z, b)) -> z -> AVL a -> (z, AVL b)+mapAccumRAVL f z ta = case mapAR z ta of+ UBT2(zt,tb) -> (zt,tb)+ where mapAR z_ E = UBT2(z_,E)+ mapAR z_ (N la a ra) = mapAR' z_ N la a ra+ mapAR z_ (Z la a ra) = mapAR' z_ Z la a ra+ mapAR z_ (P la a ra) = mapAR' z_ P la a ra+ {-# INLINE mapAR' #-}+ mapAR' z' c la a ra = case mapAR z' ra of+ UBT2(zr,rb) -> let (za,b) = f zr a+ in case mapAR za la of+ UBT2(zl,lb) -> UBT2(zl, c lb b rb)++-- | This is a strict version of 'mapAccumRAVL', which is useful for functions which+-- are strict in their first argument. The advantage of this version is that it reduces+-- the stack use from the O(n) that the lazy version gives (when used with strict functions)+-- to O(log n).+--+-- Complexity: O(n)+mapAccumRAVL' :: (z -> a -> (z, b)) -> z -> AVL a -> (z, AVL b)+mapAccumRAVL' f z ta = case mapAR z ta of+ UBT2(zt,tb) -> (zt,tb)+ where mapAR z_ E = UBT2(z_,E)+ mapAR z_ (N la a ra) = mapAR' z_ N la a ra+ mapAR z_ (Z la a ra) = mapAR' z_ Z la a ra+ mapAR z_ (P la a ra) = mapAR' z_ P la a ra+ {-# INLINE mapAR' #-}+ mapAR' z' c la a ra = case mapAR z' ra of+ UBT2(zr,rb) -> case f zr a of+ (za,b) -> case mapAR za la of+ UBT2(zl,lb) -> UBT2(zl, c lb b rb)++------------------------------------------------------------------------------------------------+-- These two functions attempt to make the strict mapAccums more efficient and reduce heap+-- burn rate with ghc by using an accumulating function that returns an unboxed pair.+------------------------------------------------------------------------------------------------+#ifdef __GLASGOW_HASKELL__+-- | Glasgow Haskell only. Similar to 'mapAccumLAVL'' but uses an unboxed pair in the+-- accumulating function.+--+-- Complexity: O(n)+mapAccumLAVL''+ :: (z -> a -> UBT2(z, b)) -> z -> AVL a -> (z, AVL b)+mapAccumLAVL'' f z ta = case mapAL z ta of+ UBT2(zt,tb) -> (zt,tb)+ where mapAL z_ E = UBT2(z_,E)+ mapAL z_ (N la a ra) = mapAL' z_ N la a ra+ mapAL z_ (Z la a ra) = mapAL' z_ Z la a ra+ mapAL z_ (P la a ra) = mapAL' z_ P la a ra+ {-# INLINE mapAL' #-}+ mapAL' z' c la a ra = case mapAL z' la of+ UBT2(zl,lb) -> case f zl a of+ UBT2(za,b) -> case mapAL za ra of+ UBT2(zr,rb) -> UBT2(zr, c lb b rb)++-- | Glasgow Haskell only. Similar to 'mapAccumRAVL'' but uses an unboxed pair in the+-- accumulating function.+--+-- Complexity: O(n)+mapAccumRAVL''+ :: (z -> a -> UBT2(z, b)) -> z -> AVL a -> (z, AVL b)+mapAccumRAVL'' f z ta = case mapAR z ta of+ UBT2(zt,tb) -> (zt,tb)+ where mapAR z_ E = UBT2(z_,E)+ mapAR z_ (N la a ra) = mapAR' z_ N la a ra+ mapAR z_ (Z la a ra) = mapAR' z_ Z la a ra+ mapAR z_ (P la a ra) = mapAR' z_ P la a ra+ {-# INLINE mapAR' #-}+ mapAR' z' c la a ra = case mapAR z' ra of+ UBT2(zr,rb) -> case f zr a of+ UBT2(za,b) -> case mapAR za la of+ UBT2(zl,lb) -> UBT2(zl, c lb b rb)++#endif+------------------------------------------------------------------------------------------------+------------------------------------------------------------------------------------------------++-- | Convert a list of known length into an AVL tree, such that the head of the list becomes+-- the leftmost tree element. The resulting tree is flat (and also sorted if the supplied list+-- is sorted in ascending order).+--+-- If the actual length of the list is not the same as the supplied length then+-- an error will be raised.+--+-- Complexity: O(n)+asTreeLenL :: Int -> [e] -> AVL e+asTreeLenL n es = case subst (replicateAVL n ()) es of+ UBT2(tree,es_) -> case es_ of+ [] -> tree+ _ -> error "asTreeLenL: List too long."+ where+ -- Substitute template values for real values taken from the list+ subst E as = UBT2(E,as)+ subst (N l _ r) as = subst' N l r as+ subst (Z l _ r) as = subst' Z l r as+ subst (P l _ r) as = subst' P l r as+ {-# INLINE subst' #-}+ subst' f l r as = case subst l as of+ UBT2(l_,xs) -> case xs of+ a:as' -> case subst r as' of+ UBT2(r_,as__) -> let t_ = f l_ a r_+ in t_ `seq` UBT2(t_,as__)+ [] -> error "asTreeLenL: List too short."+++-- | As 'asTreeLenL', except the length of the list is calculated internally, not supplied+-- as an argument.+--+-- Complexity: O(n)+asTreeL :: [e] -> AVL e+asTreeL es = asTreeLenL (length es) es++-- | Convert a list of known length into an AVL tree, such that the head of the list becomes+-- the rightmost tree element. The resulting tree is flat (and also sorted if the supplied list+-- is sorted in descending order).+--+-- If the actual length of the list is not the same as the supplied length then+-- an error will be raised.+--+-- Complexity: O(n)+asTreeLenR :: Int -> [e] -> AVL e+asTreeLenR n es = case subst (replicateAVL n ()) es of+ UBT2(tree,es_) -> case es_ of+ [] -> tree+ _ -> error "asTreeLenR: List too long."+ where+ -- Substitute template values for real values taken from the list+ subst E as = UBT2(E,as)+ subst (N l _ r) as = subst' N l r as+ subst (Z l _ r) as = subst' Z l r as+ subst (P l _ r) as = subst' P l r as+ {-# INLINE subst' #-}+ subst' f l r as = case subst r as of+ UBT2(r_,xs) -> case xs of+ a:as' -> case subst l as' of+ UBT2(l_,as__) -> let t_ = f l_ a r_+ in t_ `seq` UBT2(t_,as__)+ [] -> error "asTreeLenR: List too short."++-- | As 'asTreeLenR', except the length of the list is calculated internally, not supplied+-- as an argument.+--+-- Complexity: O(n)+asTreeR :: [e] -> AVL e+asTreeR es = asTreeLenR (length es) es++-- | Reverse an AVL tree (swaps and reverses left and right sub-trees).+-- The resulting tree is the mirror image of the original.+--+-- Complexity: O(n)+reverseAVL :: AVL e -> AVL e+reverseAVL E = E+reverseAVL (N l e r) = let l' = reverseAVL l+ r' = reverseAVL r+ in l' `seq` r' `seq` P r' e l'+reverseAVL (Z l e r) = let l' = reverseAVL l+ r' = reverseAVL r+ in l' `seq` r' `seq` Z r' e l'+reverseAVL (P l e r) = let l' = reverseAVL l+ r' = reverseAVL r+ in l' `seq` r' `seq` N r' e l'++-- | Apply a function to every element in an AVL tree. This function preserves the tree shape.+-- There is also a strict version of this function ('mapAVL'').+--+-- N.B. If the tree is sorted the result of this operation will only be sorted if+-- the applied function preserves ordering (for some suitable ordering definition).+--+-- Complexity: O(n)+mapAVL :: (a -> b) -> AVL a -> AVL b+mapAVL f = map' where+ map' E = E+ map' (N l a r) = let l' = map' l+ r' = map' r+ in l' `seq` r' `seq` N l' (f a) r'+ map' (Z l a r) = let l' = map' l+ r' = map' r+ in l' `seq` r' `seq` Z l' (f a) r'+ map' (P l a r) = let l' = map' l+ r' = map' r+ in l' `seq` r' `seq` P l' (f a) r'++-- | Similar to 'mapAVL', but the supplied function is applied strictly.+--+-- Complexity: O(n)+mapAVL' :: (a -> b) -> AVL a -> AVL b+mapAVL' f = map' where+ map' E = E+ map' (N l a r) = let l' = map' l+ r' = map' r+ b = f a+ in b `seq` l' `seq` r' `seq` N l' b r'+ map' (Z l a r) = let l' = map' l+ r' = map' r+ b = f a+ in b `seq` l' `seq` r' `seq` Z l' b r'+ map' (P l a r) = let l' = map' l+ r' = map' r+ b = f a+ in b `seq` l' `seq` r' `seq` P l' b r'++#if __GLASGOW_HASKELL__ > 604+traverseAVL :: Applicative f => (a -> f b) -> AVL a -> f (AVL b)+traverseAVL _f E = pure E+traverseAVL f (N l v r) = N <$> traverseAVL f l <*> f v <*> traverseAVL f r+traverseAVL f (Z l v r) = Z <$> traverseAVL f l <*> f v <*> traverseAVL f r+traverseAVL f (P l v r) = P <$> traverseAVL f l <*> f v <*> traverseAVL f r+#endif++-- | Construct a flat AVL tree of size n (n>=0), where all elements are identical.+--+-- Complexity: O(log n)+replicateAVL :: Int -> e -> AVL e+replicateAVL m e = rep m where -- Functional spaghetti follows :-)+ rep n | odd n = repOdd n -- n is odd , >=1+ rep n = repEvn n -- n is even, >=0+ -- n is known to be odd (>=1), so left and right sub-trees are identical+ repOdd n = let sub = rep (n `shiftR` 1) in sub `seq` Z sub e sub+ -- n is known to be even (>=0)+ repEvn n | n .&. (n-1) == 0 = repP2 n -- treat exact powers of 2 specially, traps n=0 too+ repEvn n = let nl = n `shiftR` 1 -- size of left subtree (odd or even)+ nr = nl - 1 -- size of right subtree (even or odd)+ in if odd nr+ then let l = repEvn nl -- right sub-tree is odd , so left is even (>=2)+ r = repOdd nr+ in l `seq` r `seq` Z l e r+ else let l = repOdd nl -- right sub-tree is even, so left is odd (>=2)+ r = repEvn nr+ in l `seq` r `seq` Z l e r+ -- n is an exact power of 2 (or 0), I.E. 0,1,2,4,8,16..+ repP2 0 = E+ repP2 1 = Z E e E+ repP2 n = let nl = n `shiftR` 1 -- nl is also an exact power of 2+ nr = nl - 1 -- nr is one less that an exact power of 2+ l = repP2 nl+ r = repP2M1 nr+ in l `seq` r `seq` P l e r -- BF=+1+ -- n is one less than an exact power of 2, I.E. 0,1,3,7,15..+ repP2M1 0 = E+ repP2M1 n = let sub = repP2M1 (n `shiftR` 1) in sub `seq` Z sub e sub++-- | Flatten an AVL tree, preserving the ordering of the tree elements.+--+-- Complexity: O(n)+flatten :: AVL e -> AVL e+flatten t = asTreeLenL (size t) (asListL t)++-- | Similar to 'flatten', but the tree elements are reversed. This function has higher constant+-- factor overhead than 'reverseAVL'.+--+-- Complexity: O(n)+flatReverse :: AVL e -> AVL e+flatReverse t = asTreeLenL (size t) (asListR t)++-- | Similar to 'mapAVL', but the resulting tree is flat.+-- This function has higher constant factor overhead than 'mapAVL'.+--+-- Complexity: O(n)+flatMap :: (a -> b) -> AVL a -> AVL b+flatMap f t = asTreeLenL (size t) (map f (asListL t))++-- | Same as 'flatMap', but the supplied function is applied strictly.+--+-- Complexity: O(n)+flatMap' :: (a -> b) -> AVL a -> AVL b+flatMap' f t = asTreeLenL (size t) (map' f (asListL t)) where+ map' _ [] = []+ map' g (a:as) = let b = g a in b `seq` (b : map' f as)++-- | Remove all AVL tree elements which do not satisfy the supplied predicate.+-- Element ordering is preserved. The resulting tree is flat.+-- See 'filterAVL' for an alternative implementation which is probably more efficient.+--+-- Complexity: O(n)+filterViaList :: (e -> Bool) -> AVL e -> AVL e+filterViaList p t = filter' [] 0 (asListR t) where+ filter' se n [] = asTreeLenL n se+ filter' se n (e:es) = if p e then let n'=n+1 in n' `seq` filter' (e:se) n' es+ else filter' se n es++-- | Remove all AVL tree elements which do not satisfy the supplied predicate.+-- Element ordering is preserved.+--+-- Complexity: O(n)+filterAVL :: (e -> Bool) -> AVL e -> AVL e+filterAVL p t0 = case filter_ L(0) t0 of UBT3(_,t_,_) -> t_ -- Work with relative heights!!+ where filter_ h t = case t of+ E -> UBT3(False,E,h)+ N l e r -> f l DECINT2(h) e r DECINT1(h)+ Z l e r -> f l DECINT1(h) e r DECINT1(h)+ P l e r -> f l DECINT1(h) e r DECINT2(h)+ where f l hl e r hr = case filter_ hl l of+ UBT3(bl,l_,hl_) -> case filter_ hr r of+ UBT3(br,r_,hr_) -> if p e+ then if bl || br+ then case spliceH l_ hl_ e r_ hr_ of+ UBT2(t_,h_) -> UBT3(True,t_,h_)+ else UBT3(False,t,h)+ else case joinH l_ hl_ r_ hr_ of+ UBT2(t_,h_) -> UBT3(True,t_,h_)++-- | Partition an AVL tree using the supplied predicate. The first AVL tree in the+-- resulting pair contains all elements for which the predicate is True, the second+-- contains all those for which the predicate is False. Element ordering is preserved.+-- Both of the resulting trees are flat.+--+-- Complexity: O(n)+partitionAVL :: (e -> Bool) -> AVL e -> (AVL e, AVL e)+partitionAVL p t = part 0 [] 0 [] (asListR t) where+ part nT lstT nF lstF [] = let avlT = asTreeLenL nT lstT+ avlF = asTreeLenL nF lstF+ in (avlT,avlF) -- Non strict in avlT, avlF !!+ part nT lstT nF lstF (e:es) = if p e then let nT'=nT+1 in nT' `seq` part nT' (e:lstT) nF lstF es+ else let nF'=nF+1 in nF' `seq` part nT lstT nF' (e:lstF) es++-- | Remove all AVL tree elements for which the supplied function returns 'Nothing'.+-- Element ordering is preserved. The resulting tree is flat.+-- See 'mapMaybeAVL' for an alternative implementation which is probably more efficient.+--+-- Complexity: O(n)+mapMaybeViaList :: (a -> Maybe b) -> AVL a -> AVL b+mapMaybeViaList f t = map' [] 0 (asListR t) where+ map' sb n [] = asTreeLenL n sb+ map' sb n (a:as) = case f a of+ Just b -> let n'=n+1 in n' `seq` map' (b:sb) n' as+ Nothing -> map' sb n as++-- | Remove all AVL tree elements for which the supplied function returns 'Nothing'.+-- Element ordering is preserved.+--+-- Complexity: O(n)+mapMaybeAVL :: (a -> Maybe b) -> AVL a -> AVL b+mapMaybeAVL f t0 = case mapMaybe_ L(0) t0 of UBT2(t_,_) -> t_ -- Work with relative heights!!+ where mapMaybe_ h t = case t of+ E -> UBT2(E,h)+ N l a r -> m l DECINT2(h) a r DECINT1(h)+ Z l a r -> m l DECINT1(h) a r DECINT1(h)+ P l a r -> m l DECINT1(h) a r DECINT2(h)+ where m l hl a r hr = case mapMaybe_ hl l of+ UBT2(l_,hl_) -> case mapMaybe_ hr r of+ UBT2(r_,hr_) -> case f a of+ Just b -> spliceH l_ hl_ b r_ hr_+ Nothing -> joinH l_ hl_ r_ hr_++-- | Invokes 'genPushList' on the empty AVL tree.+--+-- Complexity: O(n.(log n))+{-# INLINE genAsTree #-}+genAsTree :: (e -> e -> COrdering e) -> [e] -> AVL e+genAsTree c = genPushList c empty++-- | Push the elements of an unsorted List in a sorted AVL tree using the supplied combining comparison.+--+-- Complexity: O(n.(log (m+n))) where n is the list length, m is the tree size.+genPushList :: (e -> e -> COrdering e) -> AVL e -> [e] -> AVL e+genPushList c avl = foldl' addElem avl+ where addElem t e = genPush (c e) e t++-- | Uses the supplied combining comparison to sort list elements into ascending order.+-- Multiple occurences of the same element are eliminated (they are combined in some way).+--+-- @'genSortAscending' c = 'asListL' . 'genAsTree' c@+--+-- Complexity: O(n.(log n))+{-# INLINE genSortAscending #-}+genSortAscending :: (e -> e -> COrdering e) -> [e] -> [e]+genSortAscending c = asListL . genAsTree c++-- | Uses the supplied combining comparison to sort list elements into descending order.+-- Multiple occurences of the same element are eliminated (they are combined in some way).+--+-- @'genSortDescending' c = 'asListR' . 'genAsTree' c@+--+-- Complexity: O(n.(log n))+{-# INLINE genSortDescending #-}+genSortDescending :: (e -> e -> COrdering e) -> [e] -> [e]+genSortDescending c = asListR . genAsTree c++
+ Data/Tree/AVL/Push.hs view
@@ -0,0 +1,715 @@+-----------------------------------------------------------------------------+-- |+-- Module : Data.Tree.AVL.Push+-- Copyright : (c) Adrian Hey 2004,2005+-- License : BSD3+--+-- Maintainer : http://homepages.nildram.co.uk/~ahey/em.png+-- Stability : stable+-- Portability : portable+-----------------------------------------------------------------------------+module Data.Tree.AVL.Push+(-- * \"Pushing\" new elements into AVL trees+ -- | \"Pushing\" is another word for insertion. (c.f \"Popping\".)++ -- ** Pushing on extreme left or right+ pushL,pushR,++ -- ** Pushing on /sorted/ AVL trees+ genPush,genPush',genPushMaybe,genPushMaybe',+) where++import Prelude -- so haddock finds the symbols there++import Data.COrdering+import Data.Tree.AVL.Types(AVL(..))+import Data.Tree.AVL.Internals.BinPath(BinPath(..),genOpenPathWith,writePath,insertPath)++{------------------------------------------------------------------------------------------------------------------------------+ -------------------------------------- Notes about Insertion and Rebalancing -------------------------------------------------+ ------------------------------------------------------------------------------------------------------------------------------+ If we forget about tree rebalancing, and consider what changes in BF tell us about changes in H+ under ordinary circumstances, we can make the following observations:++ (1) Insertion can never reduce the height of a (sub)tree.+ (2) Insertion can only change the height of a (sub)tree by +1 at most. Therefore the BF of the+ root can change by +/- 1 most.+ (2) If insertion changes the BF from 0 -> +/- 1, then this must be because either the left or+ right subtrees has grown in height by 1. Since they were equal before (BF=0), the overall+ height of the root must also have grown by 1.+ (3) If insertion changes the BF from +/-1 -> 0, then this must be because one either the left+ or right subtree has grown by 1 so that it is now equal in height to the opposing subtree.+ Since height of the root is determined by the maximum height of the subtrees, it is left+ unchanged.+ (4) If insertion leaves the BF unchanged, then this must be because the height of neither+ subtree has changed. Therefore the height of the root is left unchanged.+ (5) It follows from (2) and (3), that changes in height, and hence BF can (and will) propogate+ up the tree (along the insertion path) as far as the first node with non-zero BF, and no further.+ (6) If insertion changes the BF from +/-1 -> +/-2 then we have a problem. This is dealt with by+ one of four possible rebalancing 'rotations' (there are two possiblities for each of the left+ and right subtrees). However, it's appropriate to mention an important property of the rotations+ now. The net effect of unbalancing and rebalancing is to give the root BF=0 and leave the height+ unchanged. So the combined effect of the unbalance-rebalance operation appears like a special+ case of (3). Another important property of rebalancing is that it /preserves/ the tree sorting.+ (7) It follows from (6) and (5) any single insertion will cause most one unbalance-rebalance operation.++ So in summary we have a set of rules to enable us to infer changes in height of a subtree (if any) from+ changes in the BF of the subtree, and hence the changes (if any) in the BF of the root. The rules are:+ BF 0 -> +/-1, height increased by 1+ BF +/-1 -> 0, height unchanged.+ BF unchanged , height unchanged.+ BF +/-1 -> -/+1, NEVER OCCURS++ It should also be observed that these observations and rules apply to INSERTION only (not deletion).++Rebalancing: CASE RR+--------------------+ Consider inserting into the right subtree of the right subtree (RR subtree). From the obsevations above we can+ say this is only going to unbalance the root if:+ The height of the RR subtree is increased by 1 (we determine this from looking at changes in it's BF)+ ..and.. The right subtree has BF=0 prior to insertion (observation 5)+ ..and.. THe root has BF=-1 prior to insertion (observation 2)++ In pictures..++ ----- ----- -----+ | B | | B | | D |+ |H=h+2| |H=h+3| |H=h+2| <- Note+ |BF=-1| |BF=-2| <-- Unbalanced! |BF= 0| <- Note+ /-----\ /-----\ /-----\+ / \ / \ / \+ / \ / \ / \+ -----/ \----- -----/ \----- -----/ \-----+ | A | | D | E grows | A | | D | Rebalance | B | | E |+ | H=h | |H=h+1| by 1 | H=h | |H=h+2| --------> |H=h+1| |H=h+1|+ | | |BF= 0| ------> | | |BF=-1| |BF= 0| | |+ ----- /-----\ h -> h+1 ----- /-----\ /-----\ -----+ / \ / \ / \+ / \ / \ / \+ -----/ \----- -----/ \----- -----/ \-----+ | C | | E | | C | | E | | A | | C |+ | H=h | | H=h | | H=h | |H=h+1| | H=h | | H=h |+ | | | | | | | | | | | |+ ----- ----- ----- ----- ----- -----++ Unfortunately, if you try this for insertion into the right left subtree (C) it doesn't work. To deal with+ this case we need a more complicated re-balancing rotation involving 3 nodes. There are 2 distinct cases, which+ both use the same rotation, but details re. BF and H are different.++Rebalancing: CASE RL(1)+-----------------------++ ----- ----- -----+ | B | | B | | D |+ |H=h+3| |H=h+4| |H=h+3| <- Note+ |BF=-1| |BF=-2| <-- Unbalanced! |BF= 0| <- Note+ /-----\ /-----\ /-----\+ / \ / \ / \+ / \ / \ / \+ -----/ \----- -----/ \----- / \+ | A | | F | E grows | A | | F | Rebalance -----/ \-----+ |H=h+1| |H=h+2| by 1 |H=h+1| |H=h+3| --------> | B | | F |+ | | |BF= 0| ------> | | |BF=+1| |H=h+2| |H=h+2|+ ----- /-----\ h -> h+1 ----- /-----\ |BF=+1| |BF= 0|+ / \ / \ -----/-----\----- -----/-----\-----+ / \ / \ | A | | C | | E | | G |+ -----/ \----- -----/ \----- |H=h+1| | H=h | |H=h+1| |H=h+1|+ | D | | G | | D | | G | | | | | | | | |+ |H=h+1| |H=h+1| |H=h+2| |H=h+1| ----- ----- ----- -----+ |BF= 0| | | |BF=-1| | |+ /-----\ ----- /-----\ -----+ / \ / \+ / \ / \+ -----/ \----- -----/ \-----+ | C | | E | | C | | E |+ | H=h | | H=h | | H=h | |H=h+1|+ | | | | | | | |+ ----- ----- ----- -----++Rebalancing: CASE RL(2)+-----------------------++ ----- ----- -----+ | B | | B | | D |+ |H=h+3| |H=h+4| |H=h+3| <- Note+ |BF=-1| |BF=-2| <-- Unbalanced! |BF= 0| <- Note+ /-----\ /-----\ /-----\+ / \ / \ / \+ / \ / \ / \+ -----/ \----- -----/ \----- / \+ | A | | F | C grows | A | | F | Rebalance -----/ \-----+ |H=h+1| |H=h+2| by 1 |H=h+1| |H=h+3| --------> | B | | F |+ | | |BF= 0| ------> | | |BF=+1| |H=h+2| |H=h+2|+ ----- /-----\ h -> h+1 ----- /-----\ |BF= 0| |BF=-1|+ / \ / \ -----/-----\----- -----/-----\-----+ / \ / \ | A | | C | | E | | G |+ -----/ \----- -----/ \----- |H=h+1| |H=h+1| | H=h | |H=h+1|+ | D | | G | | D | | G | | | | | | | | |+ |H=h+1| |H=h+1| |H=h+2| |H=h+1| ----- ----- ----- -----+ |BF= 0| | | |BF=+1| | |+ /-----\ ----- /-----\ -----+ / \ / \+ / \ / \+ -----/ \----- -----/ \-----+ | C | | E | | C | | E |+ | H=h | | H=h | |H=h+1| | H=h |+ | | | | | | | |+ ----- ----- ----- -----+-----------------------------------------------------------------------------------------------------------------------------+-----------------------------------------------------------------------------------------------------------------------------}++-- | General push. This function searches the AVL tree using the supplied selector. If a matching element+-- is found it's replaced by the value (@e@) returned in the @('Eq' e)@ constructor returned by the selector.+-- If no match is found then the default element value is added at in the appropriate position in the tree.+--+-- Note that for this to work properly requires that the selector behave as if it were comparing the+-- (potentially) new default element with existing tree elements, even if it isn't.+--+-- Note also that this function is /non-strict/ in it\'s second argument (the default value which+-- is inserted if the search fails or is discarded if the search succeeds). If you want+-- to force evaluation, but only if it\'s actually incorprated in the tree, then use 'genPush''+--+-- Complexity: O(log n)+genPush :: (e -> COrdering e) -> e -> AVL e -> AVL e+genPush c e0 = put where -- there now follows a huge collection of functions requiring+ -- pattern matching from hell in which c and e0 are free variables+-- This may look longwinded, it's been done this way to..+-- * Avoid doing case analysis on the same node more than once.+-- * Minimise heap burn rate (by avoiding explicit rebalancing operations).+ ----------------------------- LEVEL 0 ---------------------------------+ -- put --+ -----------------------------------------------------------------------+ put E = Z E e0 E+ put (N l e r) = putN l e r+ put (Z l e r) = putZ l e r+ put (P l e r) = putP l e r++ ----------------------------- LEVEL 1 ---------------------------------+ -- putN, putZ, putP --+ -----------------------------------------------------------------------++ -- Put in (N l e r), BF=-1 , (never returns P)+ putN l e r = case c e of+ Lt -> putNL l e r -- <e, so put in L subtree+ Eq e' -> N l e' r -- =e, so update existing+ Gt -> putNR l e r -- >e, so put in R subtree++ -- Put in (Z l e r), BF= 0+ putZ l e r = case c e of+ Lt -> putZL l e r -- <e, so put in L subtree+ Eq e' -> Z l e' r -- =e, so update existing+ Gt -> putZR l e r -- >e, so put in R subtree++ -- Put in (P l e r), BF=+1 , (never returns N)+ putP l e r = case c e of+ Lt -> putPL l e r -- <e, so put in L subtree+ Eq e' -> P l e' r -- =e, so update existing+ Gt -> putPR l e r -- >e, so put in R subtree++ ----------------------------- LEVEL 2 ---------------------------------+ -- putNL, putZL, putPL --+ -- putNR, putZR, putPR --+ -----------------------------------------------------------------------++ -- (putNL l e r): Put in L subtree of (N l e r), BF=-1 (Never requires rebalancing) , (never returns P)+ {-# INLINE putNL #-}+ putNL E e r = Z (Z E e0 E ) e r -- L subtree empty, H:0->1, parent BF:-1-> 0+ putNL (N ll le lr) e r = let l' = putN ll le lr -- L subtree BF<>0, H:h->h, parent BF:-1->-1+ in l' `seq` N l' e r+ putNL (P ll le lr) e r = let l' = putP ll le lr -- L subtree BF<>0, H:h->h, parent BF:-1->-1+ in l' `seq` N l' e r+ putNL (Z ll le lr) e r = let l' = putZ ll le lr -- L subtree BF= 0, so need to look for changes+ in case l' of+ E -> error "genPush: Bug0" -- impossible+ Z _ _ _ -> N l' e r -- L subtree BF:0-> 0, H:h->h , parent BF:-1->-1+ _ -> Z l' e r -- L subtree BF:0->+/-1, H:h->h+1, parent BF:-1-> 0++ -- (putZL l e r): Put in L subtree of (Z l e r), BF= 0 (Never requires rebalancing) , (never returns N)+ {-# INLINE putZL #-}+ putZL E e r = P (Z E e0 E ) e r -- L subtree H:0->1, parent BF: 0->+1+ putZL (N ll le lr) e r = let l' = putN ll le lr -- L subtree BF<>0, H:h->h, parent BF: 0-> 0+ in l' `seq` Z l' e r+ putZL (P ll le lr) e r = let l' = putP ll le lr -- L subtree BF<>0, H:h->h, parent BF: 0-> 0+ in l' `seq` Z l' e r+ putZL (Z ll le lr) e r = let l' = putZ ll le lr -- L subtree BF= 0, so need to look for changes+ in case l' of+ E -> error "genPush: Bug1" -- impossible+ Z _ _ _ -> Z l' e r -- L subtree BF: 0-> 0, H:h->h , parent BF: 0-> 0+ _ -> P l' e r -- L subtree BF: 0->+/-1, H:h->h+1, parent BF: 0->+1++ -- (putZR l e r): Put in R subtree of (Z l e r), BF= 0 (Never requires rebalancing) , (never returns P)+ {-# INLINE putZR #-}+ putZR l e E = N l e (Z E e0 E ) -- R subtree H:0->1, parent BF: 0->-1+ putZR l e (N rl re rr) = let r' = putN rl re rr -- R subtree BF<>0, H:h->h, parent BF: 0-> 0+ in r' `seq` Z l e r'+ putZR l e (P rl re rr) = let r' = putP rl re rr -- R subtree BF<>0, H:h->h, parent BF: 0-> 0+ in r' `seq` Z l e r'+ putZR l e (Z rl re rr) = let r' = putZ rl re rr -- R subtree BF= 0, so need to look for changes+ in case r' of+ E -> error "genPush: Bug2" -- impossible+ Z _ _ _ -> Z l e r' -- R subtree BF: 0-> 0, H:h->h , parent BF: 0-> 0+ _ -> N l e r' -- R subtree BF: 0->+/-1, H:h->h+1, parent BF: 0->-1++ -- (putPR l e r): Put in R subtree of (P l e r), BF=+1 (Never requires rebalancing) , (never returns N)+ {-# INLINE putPR #-}+ putPR l e E = Z l e (Z E e0 E ) -- R subtree empty, H:0->1, parent BF:+1-> 0+ putPR l e (N rl re rr) = let r' = putN rl re rr -- R subtree BF<>0, H:h->h, parent BF:+1->+1+ in r' `seq` P l e r'+ putPR l e (P rl re rr) = let r' = putP rl re rr -- R subtree BF<>0, H:h->h, parent BF:+1->+1+ in r' `seq` P l e r'+ putPR l e (Z rl re rr) = let r' = putZ rl re rr -- R subtree BF= 0, so need to look for changes+ in case r' of+ E -> error "genPush: Bug3" -- impossible+ Z _ _ _ -> P l e r' -- R subtree BF:0-> 0, H:h->h , parent BF:+1->+1+ _ -> Z l e r' -- R subtree BF:0->+/-1, H:h->h+1, parent BF:+1-> 0++ -------- These 2 cases (NR and PL) may need rebalancing if they go to LEVEL 3 ---------++ -- (putNR l e r): Put in R subtree of (N l e r), BF=-1 , (never returns P)+ {-# INLINE putNR #-}+ putNR _ _ E = error "genPush: Bug4" -- impossible if BF=-1+ putNR l e (N rl re rr) = let r' = putN rl re rr -- R subtree BF<>0, H:h->h, parent BF:-1->-1+ in r' `seq` N l e r'+ putNR l e (P rl re rr) = let r' = putP rl re rr -- R subtree BF<>0, H:h->h, parent BF:-1->-1+ in r' `seq` N l e r'+ putNR l e (Z rl re rr) = case c re of -- determine if RR or RL+ Lt -> putNRL l e rl re rr -- RL (never returns P)+ Eq re' -> N l e (Z rl re' rr) -- new re+ Gt -> putNRR l e rl re rr -- RR (never returns P)++ -- (putPL l e r): Put in L subtree of (P l e r), BF=+1 , (never returns N)+ {-# INLINE putPL #-}+ putPL E _ _ = error "genPush: Bug5" -- impossible if BF=+1+ putPL (N ll le lr) e r = let l' = putN ll le lr -- L subtree BF<>0, H:h->h, parent BF:+1->+1+ in l' `seq` P l' e r+ putPL (P ll le lr) e r = let l' = putP ll le lr -- L subtree BF<>0, H:h->h, parent BF:+1->+1+ in l' `seq` P l' e r+ putPL (Z ll le lr) e r = case c le of -- determine if LL or LR+ Lt -> putPLL ll le lr e r -- LL (never returns N)+ Eq le' -> P (Z ll le' lr) e r -- new le+ Gt -> putPLR ll le lr e r -- LR (never returns N)++ ----------------------------- LEVEL 3 ---------------------------------+ -- putNRR, putPLL --+ -- putNRL, putPLR --+ -----------------------------------------------------------------------++ -- (putNRR l e rl re rr): Put in RR subtree of (N l e (Z rl re rr)) , (never returns P)+ {-# INLINE putNRR #-}+ putNRR l e rl re E = Z (Z l e rl) re (Z E e0 E) -- l and rl must also be E, special CASE RR!!+ putNRR l e rl re (N rrl rre rrr) = let rr' = putN rrl rre rrr -- RR subtree BF<>0, H:h->h, so no change+ in rr' `seq` N l e (Z rl re rr')+ putNRR l e rl re (P rrl rre rrr) = let rr' = putP rrl rre rrr -- RR subtree BF<>0, H:h->h, so no change+ in rr' `seq` N l e (Z rl re rr')+ putNRR l e rl re (Z rrl rre rrr) = let rr' = putZ rrl rre rrr -- RR subtree BF= 0, so need to look for changes+ in case rr' of+ E -> error "genPush: Bug6" -- impossible+ Z _ _ _ -> N l e (Z rl re rr') -- RR subtree BF: 0-> 0, H:h->h, so no change+ _ -> Z (Z l e rl) re rr' -- RR subtree BF: 0->+/-1, H:h->h+1, parent BF:-1->-2, CASE RR !!++ -- (putPLL ll le lr e r): Put in LL subtree of (P (Z ll le lr) e r) , (never returns N)+ {-# INLINE putPLL #-}+ putPLL E le lr e r = Z (Z E e0 E) le (Z lr e r) -- r and lr must also be E, special CASE LL!!+ putPLL (N lll lle llr) le lr e r = let ll' = putN lll lle llr -- LL subtree BF<>0, H:h->h, so no change+ in ll' `seq` P (Z ll' le lr) e r+ putPLL (P lll lle llr) le lr e r = let ll' = putP lll lle llr -- LL subtree BF<>0, H:h->h, so no change+ in ll' `seq` P (Z ll' le lr) e r+ putPLL (Z lll lle llr) le lr e r = let ll' = putZ lll lle llr -- LL subtree BF= 0, so need to look for changes+ in case ll' of+ E -> error "genPush: Bug7" -- impossible+ Z _ _ _ -> P (Z ll' le lr) e r -- LL subtree BF: 0-> 0, H:h->h, so no change+ _ -> Z ll' le (Z lr e r) -- LL subtree BF: 0->+/-1, H:h->h+1, parent BF:-1->-2, CASE LL !!++ -- (putNRL l e rl re rr): Put in RL subtree of (N l e (Z rl re rr)) , (never returns P)+ {-# INLINE putNRL #-}+ putNRL l e E re rr = Z (Z l e E) e0 (Z E re rr) -- l and rr must also be E, special CASE LR !!+ putNRL l e (N rll rle rlr) re rr = let rl' = putN rll rle rlr -- RL subtree BF<>0, H:h->h, so no change+ in rl' `seq` N l e (Z rl' re rr)+ putNRL l e (P rll rle rlr) re rr = let rl' = putP rll rle rlr -- RL subtree BF<>0, H:h->h, so no change+ in rl' `seq` N l e (Z rl' re rr)+ putNRL l e (Z rll rle rlr) re rr = let rl' = putZ rll rle rlr -- RL subtree BF= 0, so need to look for changes+ in case rl' of+ E -> error "genPush: Bug8" -- impossible+ Z _ _ _ -> N l e (Z rl' re rr) -- RL subtree BF: 0-> 0, H:h->h, so no change+ N rll' rle' rlr' -> Z (P l e rll') rle' (Z rlr' re rr) -- RL subtree BF: 0->-1, SO.. CASE RL(1) !!+ P rll' rle' rlr' -> Z (Z l e rll') rle' (N rlr' re rr) -- RL subtree BF: 0->+1, SO.. CASE RL(2) !!++ -- (putPLR ll le lr e r): Put in LR subtree of (P (Z ll le lr) e r) , (never returns N)+ {-# INLINE putPLR #-}+ putPLR ll le E e r = Z (Z ll le E) e0 (Z E e r) -- r and ll must also be E, special CASE LR !!+ putPLR ll le (N lrl lre lrr) e r = let lr' = putN lrl lre lrr -- LR subtree BF<>0, H:h->h, so no change+ in lr' `seq` P (Z ll le lr') e r+ putPLR ll le (P lrl lre lrr) e r = let lr' = putP lrl lre lrr -- LR subtree BF<>0, H:h->h, so no change+ in lr' `seq` P (Z ll le lr') e r+ putPLR ll le (Z lrl lre lrr) e r = let lr' = putZ lrl lre lrr -- LR subtree BF= 0, so need to look for changes+ in case lr' of+ E -> error "genPush: Bug9" -- impossible+ Z _ _ _ -> P (Z ll le lr') e r -- LR subtree BF: 0-> 0, H:h->h, so no change+ N lrl' lre' lrr' -> Z (P ll le lrl') lre' (Z lrr' e r) -- LR subtree BF: 0->-1, SO.. CASE LR(2) !!+ P lrl' lre' lrr' -> Z (Z ll le lrl') lre' (N lrr' e r) -- LR subtree BF: 0->+1, SO.. CASE LR(1) !!+-----------------------------------------------------------------------+------------------------- genPush Ends Here ----------------------------+-----------------------------------------------------------------------++-- | Almost identical to 'genPush', but this version forces evaluation of the default new element+-- (second argument) if no matching element is found. Note that it does /not/ do this if+-- a matching element is found, because in this case the default new element is discarded+-- anyway. Note also that it does not force evaluation of any replacement value provided by the+-- selector (if it returns Eq). (You have to do that yourself if that\'s what you want.)+--+-- Complexity: O(log n)+genPush' :: (e -> COrdering e) -> e -> AVL e -> AVL e+genPush' c e0 = put where+ ----------------------------- LEVEL 0 ---------------------------------+ -- put --+ -----------------------------------------------------------------------+ put E = e0 `seq` Z E e0 E+ put (N l e r) = putN l e r+ put (Z l e r) = putZ l e r+ put (P l e r) = putP l e r++ ----------------------------- LEVEL 1 ---------------------------------+ -- putN, putZ, putP --+ -----------------------------------------------------------------------++ -- Put in (N l e r), BF=-1 , (never returns P)+ putN l e r = case c e of+ Lt -> putNL l e r -- <e, so put in L subtree+ Eq e' -> N l e' r -- =e, so update existing+ Gt -> putNR l e r -- >e, so put in R subtree++ -- Put in (Z l e r), BF= 0+ putZ l e r = case c e of+ Lt -> putZL l e r -- <e, so put in L subtree+ Eq e' -> Z l e' r -- =e, so update existing+ Gt -> putZR l e r -- >e, so put in R subtree++ -- Put in (P l e r), BF=+1 , (never returns N)+ putP l e r = case c e of+ Lt -> putPL l e r -- <e, so put in L subtree+ Eq e' -> P l e' r -- =e, so update existing+ Gt -> putPR l e r -- >e, so put in R subtree++ ----------------------------- LEVEL 2 ---------------------------------+ -- putNL, putZL, putPL --+ -- putNR, putZR, putPR --+ -----------------------------------------------------------------------++ -- (putNL l e r): Put in L subtree of (N l e r), BF=-1 (Never requires rebalancing) , (never returns P)+ {-# INLINE putNL #-}+ putNL E e r = e0 `seq` Z (Z E e0 E ) e r -- L subtree empty, H:0->1, parent BF:-1-> 0+ putNL (N ll le lr) e r = let l' = putN ll le lr -- L subtree BF<>0, H:h->h, parent BF:-1->-1+ in l' `seq` N l' e r+ putNL (P ll le lr) e r = let l' = putP ll le lr -- L subtree BF<>0, H:h->h, parent BF:-1->-1+ in l' `seq` N l' e r+ putNL (Z ll le lr) e r = let l' = putZ ll le lr -- L subtree BF= 0, so need to look for changes+ in case l' of+ E -> error "genPush': Bug0" -- impossible+ Z _ _ _ -> N l' e r -- L subtree BF:0-> 0, H:h->h , parent BF:-1->-1+ _ -> Z l' e r -- L subtree BF:0->+/-1, H:h->h+1, parent BF:-1-> 0++ -- (putZL l e r): Put in L subtree of (Z l e r), BF= 0 (Never requires rebalancing) , (never returns N)+ {-# INLINE putZL #-}+ putZL E e r = e0 `seq` P (Z E e0 E ) e r -- L subtree H:0->1, parent BF: 0->+1+ putZL (N ll le lr) e r = let l' = putN ll le lr -- L subtree BF<>0, H:h->h, parent BF: 0-> 0+ in l' `seq` Z l' e r+ putZL (P ll le lr) e r = let l' = putP ll le lr -- L subtree BF<>0, H:h->h, parent BF: 0-> 0+ in l' `seq` Z l' e r+ putZL (Z ll le lr) e r = let l' = putZ ll le lr -- L subtree BF= 0, so need to look for changes+ in case l' of+ E -> error "genPush': Bug1" -- impossible+ Z _ _ _ -> Z l' e r -- L subtree BF: 0-> 0, H:h->h , parent BF: 0-> 0+ _ -> P l' e r -- L subtree BF: 0->+/-1, H:h->h+1, parent BF: 0->+1++ -- (putZR l e r): Put in R subtree of (Z l e r), BF= 0 (Never requires rebalancing) , (never returns P)+ {-# INLINE putZR #-}+ putZR l e E = e0 `seq` N l e (Z E e0 E) -- R subtree H:0->1, parent BF: 0->-1+ putZR l e (N rl re rr) = let r' = putN rl re rr -- R subtree BF<>0, H:h->h, parent BF: 0-> 0+ in r' `seq` Z l e r'+ putZR l e (P rl re rr) = let r' = putP rl re rr -- R subtree BF<>0, H:h->h, parent BF: 0-> 0+ in r' `seq` Z l e r'+ putZR l e (Z rl re rr) = let r' = putZ rl re rr -- R subtree BF= 0, so need to look for changes+ in case r' of+ E -> error "genPush': Bug2" -- impossible+ Z _ _ _ -> Z l e r' -- R subtree BF: 0-> 0, H:h->h , parent BF: 0-> 0+ _ -> N l e r' -- R subtree BF: 0->+/-1, H:h->h+1, parent BF: 0->-1++ -- (putPR l e r): Put in R subtree of (P l e r), BF=+1 (Never requires rebalancing) , (never returns N)+ {-# INLINE putPR #-}+ putPR l e E = e0 `seq` Z l e (Z E e0 E) -- R subtree empty, H:0->1, parent BF:+1-> 0+ putPR l e (N rl re rr) = let r' = putN rl re rr -- R subtree BF<>0, H:h->h, parent BF:+1->+1+ in r' `seq` P l e r'+ putPR l e (P rl re rr) = let r' = putP rl re rr -- R subtree BF<>0, H:h->h, parent BF:+1->+1+ in r' `seq` P l e r'+ putPR l e (Z rl re rr) = let r' = putZ rl re rr -- R subtree BF= 0, so need to look for changes+ in case r' of+ E -> error "genPush': Bug3" -- impossible+ Z _ _ _ -> P l e r' -- R subtree BF:0-> 0, H:h->h , parent BF:+1->+1+ _ -> Z l e r' -- R subtree BF:0->+/-1, H:h->h+1, parent BF:+1-> 0++ -------- These 2 cases (NR and PL) may need rebalancing if they go to LEVEL 3 ---------++ -- (putNR l e r): Put in R subtree of (N l e r), BF=-1 , (never returns P)+ {-# INLINE putNR #-}+ putNR _ _ E = error "genPush': Bug4" -- impossible if BF=-1+ putNR l e (N rl re rr) = let r' = putN rl re rr -- R subtree BF<>0, H:h->h, parent BF:-1->-1+ in r' `seq` N l e r'+ putNR l e (P rl re rr) = let r' = putP rl re rr -- R subtree BF<>0, H:h->h, parent BF:-1->-1+ in r' `seq` N l e r'+ putNR l e (Z rl re rr) = case c re of -- determine if RR or RL+ Lt -> putNRL l e rl re rr -- RL (never returns P)+ Eq re' -> N l e (Z rl re' rr) -- new re+ Gt -> putNRR l e rl re rr -- RR (never returns P)++ -- (putPL l e r): Put in L subtree of (P l e r), BF=+1 , (never returns N)+ {-# INLINE putPL #-}+ putPL E _ _ = error "genPush': Bug5" -- impossible if BF=+1+ putPL (N ll le lr) e r = let l' = putN ll le lr -- L subtree BF<>0, H:h->h, parent BF:+1->+1+ in l' `seq` P l' e r+ putPL (P ll le lr) e r = let l' = putP ll le lr -- L subtree BF<>0, H:h->h, parent BF:+1->+1+ in l' `seq` P l' e r+ putPL (Z ll le lr) e r = case c le of -- determine if LL or LR+ Lt -> putPLL ll le lr e r -- LL (never returns N)+ Eq le' -> P (Z ll le' lr) e r -- new le+ Gt -> putPLR ll le lr e r -- LR (never returns N)++ ----------------------------- LEVEL 3 ---------------------------------+ -- putNRR, putPLL --+ -- putNRL, putPLR --+ -----------------------------------------------------------------------++ -- (putNRR l e rl re rr): Put in RR subtree of (N l e (Z rl re rr)) , (never returns P)+ {-# INLINE putNRR #-}+ putNRR l e rl re E = e0 `seq` Z (Z l e rl) re (Z E e0 E) -- l and rl must also be E, special CASE RR!!+ putNRR l e rl re (N rrl rre rrr) = let rr' = putN rrl rre rrr -- RR subtree BF<>0, H:h->h, so no change+ in rr' `seq` N l e (Z rl re rr')+ putNRR l e rl re (P rrl rre rrr) = let rr' = putP rrl rre rrr -- RR subtree BF<>0, H:h->h, so no change+ in rr' `seq` N l e (Z rl re rr')+ putNRR l e rl re (Z rrl rre rrr) = let rr' = putZ rrl rre rrr -- RR subtree BF= 0, so need to look for changes+ in case rr' of+ E -> error "genPush': Bug6" -- impossible+ Z _ _ _ -> N l e (Z rl re rr') -- RR subtree BF: 0-> 0, H:h->h, so no change+ _ -> Z (Z l e rl) re rr' -- RR subtree BF: 0->+/-1, H:h->h+1, parent BF:-1->-2, CASE RR !!++ -- (putPLL ll le lr e r): Put in LL subtree of (P (Z ll le lr) e r) , (never returns N)+ {-# INLINE putPLL #-}+ putPLL E le lr e r = e0 `seq` Z (Z E e0 E) le (Z lr e r) -- r and lr must also be E, special CASE LL!!+ putPLL (N lll lle llr) le lr e r = let ll' = putN lll lle llr -- LL subtree BF<>0, H:h->h, so no change+ in ll' `seq` P (Z ll' le lr) e r+ putPLL (P lll lle llr) le lr e r = let ll' = putP lll lle llr -- LL subtree BF<>0, H:h->h, so no change+ in ll' `seq` P (Z ll' le lr) e r+ putPLL (Z lll lle llr) le lr e r = let ll' = putZ lll lle llr -- LL subtree BF= 0, so need to look for changes+ in case ll' of+ E -> error "genPush': Bug7" -- impossible+ Z _ _ _ -> P (Z ll' le lr) e r -- LL subtree BF: 0-> 0, H:h->h, so no change+ _ -> Z ll' le (Z lr e r) -- LL subtree BF: 0->+/-1, H:h->h+1, parent BF:-1->-2, CASE LL !!++ -- (putNRL l e rl re rr): Put in RL subtree of (N l e (Z rl re rr)) , (never returns P)+ {-# INLINE putNRL #-}+ putNRL l e E re rr = e0 `seq` Z (Z l e E) e0 (Z E re rr) -- l and rr must also be E, special CASE LR !!+ putNRL l e (N rll rle rlr) re rr = let rl' = putN rll rle rlr -- RL subtree BF<>0, H:h->h, so no change+ in rl' `seq` N l e (Z rl' re rr)+ putNRL l e (P rll rle rlr) re rr = let rl' = putP rll rle rlr -- RL subtree BF<>0, H:h->h, so no change+ in rl' `seq` N l e (Z rl' re rr)+ putNRL l e (Z rll rle rlr) re rr = let rl' = putZ rll rle rlr -- RL subtree BF= 0, so need to look for changes+ in case rl' of+ E -> error "genPush': Bug8" -- impossible+ Z _ _ _ -> N l e (Z rl' re rr) -- RL subtree BF: 0-> 0, H:h->h, so no change+ N rll' rle' rlr' -> Z (P l e rll') rle' (Z rlr' re rr) -- RL subtree BF: 0->-1, SO.. CASE RL(1) !!+ P rll' rle' rlr' -> Z (Z l e rll') rle' (N rlr' re rr) -- RL subtree BF: 0->+1, SO.. CASE RL(2) !!++ -- (putPLR ll le lr e r): Put in LR subtree of (P (Z ll le lr) e r) , (never returns N)+ {-# INLINE putPLR #-}+ putPLR ll le E e r = e0 `seq` Z (Z ll le E) e0 (Z E e r) -- r and ll must also be E, special CASE LR !!+ putPLR ll le (N lrl lre lrr) e r = let lr' = putN lrl lre lrr -- LR subtree BF<>0, H:h->h, so no change+ in lr' `seq` P (Z ll le lr') e r+ putPLR ll le (P lrl lre lrr) e r = let lr' = putP lrl lre lrr -- LR subtree BF<>0, H:h->h, so no change+ in lr' `seq` P (Z ll le lr') e r+ putPLR ll le (Z lrl lre lrr) e r = let lr' = putZ lrl lre lrr -- LR subtree BF= 0, so need to look for changes+ in case lr' of+ E -> error "genPush': Bug9" -- impossible+ Z _ _ _ -> P (Z ll le lr') e r -- LR subtree BF: 0-> 0, H:h->h, so no change+ N lrl' lre' lrr' -> Z (P ll le lrl') lre' (Z lrr' e r) -- LR subtree BF: 0->-1, SO.. CASE LR(2) !!+ P lrl' lre' lrr' -> Z (Z ll le lrl') lre' (N lrr' e r) -- LR subtree BF: 0->+1, SO.. CASE LR(1) !!+-----------------------------------------------------------------------+------------------------- genPush' Ends Here ----------------------------+-----------------------------------------------------------------------++-- | Similar to 'genPush', but returns the original tree if the combining comparison returns+-- @('Eq' 'Nothing')@. So this function can be used reduce heap burn rate by avoiding duplication+-- of nodes on the insertion path. But it may also be marginally slower otherwise.+--+-- Note that this function is /non-strict/ in it\'s second argument (the default value which+-- is inserted in the search fails or is discarded if the search succeeds). If you want+-- to force evaluation, but only if it\'s actually incorprated in the tree, then use 'genPushMaybe''+--+-- Complexity: O(log n)+genPushMaybe :: (e -> COrdering (Maybe e)) -> e -> AVL e -> AVL e+genPushMaybe c e t = case genOpenPathWith c t of+ FullBP _ Nothing -> t+ FullBP p (Just e') -> writePath p e' t+ EmptyBP p -> insertPath p e t++-- | Almost identical to 'genPushMaybe', but this version forces evaluation of the default new element+-- (second argument) if no matching element is found. Note that it does /not/ do this if+-- a matching element is found, because in this case the default new element is discarded+-- anyway.+--+-- Complexity: O(log n)+genPushMaybe' :: (e -> COrdering (Maybe e)) -> e -> AVL e -> AVL e+genPushMaybe' c e t = case genOpenPathWith c t of+ FullBP _ Nothing -> t+ FullBP p (Just e') -> writePath p e' t+ EmptyBP p -> e `seq` insertPath p e t++-- | Push a new element in the leftmost position of an AVL tree. No comparison or searching is involved.+--+-- Complexity: O(log n)+pushL :: e -> AVL e -> AVL e+pushL e0 = pushL' where -- There now follows a cut down version of the more general put.+ -- Insertion is always on the left subtree.+ -- Re-Balancing cases RR,RL/LR(1/2) never occur. Only LL!+ -- There are also more impossible cases (putZL never returns N)+ ----------------------------- LEVEL 0 ---------------------------------+ -- pushL' --+ -----------------------------------------------------------------------+ pushL' E = Z E e0 E+ pushL' (N l e r) = putNL l e r+ pushL' (Z l e r) = putZL l e r+ pushL' (P l e r) = putPL l e r++ ----------------------------- LEVEL 2 ---------------------------------+ -- putNL, putZL, putPL --+ -----------------------------------------------------------------------++ -- (putNL l e r): Put in L subtree of (N l e r), BF=-1 (Never requires rebalancing) , (never returns P)+ putNL E e r = Z (Z E e0 E) e r -- L subtree empty, H:0->1, parent BF:-1-> 0+ putNL (N ll le lr) e r = let l' = putNL ll le lr -- L subtree BF<>0, H:h->h, parent BF:-1->-1+ in l' `seq` N l' e r+ putNL (P ll le lr) e r = let l' = putPL ll le lr -- L subtree BF<>0, H:h->h, parent BF:-1->-1+ in l' `seq` N l' e r+ putNL (Z ll le lr) e r = let l' = putZL ll le lr -- L subtree BF= 0, so need to look for changes+ in case l' of+ Z _ _ _ -> N l' e r -- L subtree BF:0-> 0, H:h->h , parent BF:-1->-1+ P _ _ _ -> Z l' e r -- L subtree BF:0->+1, H:h->h+1, parent BF:-1-> 0+ _ -> error "pushL: Bug0" -- impossible++ -- (putZL l e r): Put in L subtree of (Z l e r), BF= 0 (Never requires rebalancing) , (never returns N)+ putZL E e r = P (Z E e0 E) e r -- L subtree H:0->1, parent BF: 0->+1+ putZL (N ll le lr) e r = let l' = putNL ll le lr -- L subtree BF<>0, H:h->h, parent BF: 0-> 0+ in l' `seq` Z l' e r+ putZL (P ll le lr) e r = let l' = putPL ll le lr -- L subtree BF<>0, H:h->h, parent BF: 0-> 0+ in l' `seq` Z l' e r+ putZL (Z ll le lr) e r = let l' = putZL ll le lr -- L subtree BF= 0, so need to look for changes+ in case l' of+ Z _ _ _ -> Z l' e r -- L subtree BF: 0-> 0, H:h->h , parent BF: 0-> 0+ N _ _ _ -> error "pushL: Bug1" -- impossible+ _ -> P l' e r -- L subtree BF: 0->+1, H:h->h+1, parent BF: 0->+1++ -------- This case (PL) may need rebalancing if it goes to LEVEL 3 ---------++ -- (putPL l e r): Put in L subtree of (P l e r), BF=+1 , (never returns N)+ putPL E _ _ = error "pushL: Bug2" -- impossible if BF=+1+ putPL (N ll le lr) e r = let l' = putNL ll le lr -- L subtree BF<>0, H:h->h, parent BF:+1->+1+ in l' `seq` P l' e r+ putPL (P ll le lr) e r = let l' = putPL ll le lr -- L subtree BF<>0, H:h->h, parent BF:+1->+1+ in l' `seq` P l' e r+ putPL (Z ll le lr) e r = putPLL ll le lr e r -- LL (never returns N)++ ----------------------------- LEVEL 3 ---------------------------------+ -- putPLL --+ -----------------------------------------------------------------------++ -- (putPLL ll le lr e r): Put in LL subtree of (P (Z ll le lr) e r) , (never returns N)+ {-# INLINE putPLL #-}+ putPLL E le lr e r = Z (Z E e0 E) le (Z lr e r) -- r and lr must also be E, special CASE LL!!+ putPLL (N lll lle llr) le lr e r = let ll' = putNL lll lle llr -- LL subtree BF<>0, H:h->h, so no change+ in ll' `seq` P (Z ll' le lr) e r+ putPLL (P lll lle llr) le lr e r = let ll' = putPL lll lle llr -- LL subtree BF<>0, H:h->h, so no change+ in ll' `seq` P (Z ll' le lr) e r+ putPLL (Z lll lle llr) le lr e r = let ll' = putZL lll lle llr -- LL subtree BF= 0, so need to look for changes+ in case ll' of+ Z _ _ _ -> P (Z ll' le lr) e r -- LL subtree BF: 0-> 0, H:h->h, so no change+ N _ _ _ -> error "pushL: Bug3" -- impossible+ _ -> Z ll' le (Z lr e r) -- LL subtree BF: 0->+1, H:h->h+1, parent BF:-1->-2, CASE LL !!+-----------------------------------------------------------------------+--------------------------- pushL Ends Here ---------------------------+-----------------------------------------------------------------------+++-- | Push a new element in the rightmost position of an AVL tree. No comparison or searching is involved.+--+-- Complexity: O(log n)+pushR :: AVL e -> e -> AVL e+pushR t e0 = pushR' t where -- There now follows a cut down version of the more general put.+ -- Insertion is always on the right subtree.+ -- Re-Balancing cases LL,RL/LR(1/2) never occur. Only RR!+ -- There are also more impossible cases (putZR never returns P)++ ----------------------------- LEVEL 0 ---------------------------------+ -- pushR' --+ -----------------------------------------------------------------------+ pushR' E = Z E e0 E+ pushR' (N l e r) = putNR l e r+ pushR' (Z l e r) = putZR l e r+ pushR' (P l e r) = putPR l e r++ ----------------------------- LEVEL 2 ---------------------------------+ -- putNR, putZR, putPR --+ -----------------------------------------------------------------------++ -- (putZR l e r): Put in R subtree of (Z l e r), BF= 0 (Never requires rebalancing) , (never returns P)+ putZR l e E = N l e (Z E e0 E) -- R subtree H:0->1, parent BF: 0->-1+ putZR l e (N rl re rr) = let r' = putNR rl re rr -- R subtree BF<>0, H:h->h, parent BF: 0-> 0+ in r' `seq` Z l e r'+ putZR l e (P rl re rr) = let r' = putPR rl re rr -- R subtree BF<>0, H:h->h, parent BF: 0-> 0+ in r' `seq` Z l e r'+ putZR l e (Z rl re rr) = let r' = putZR rl re rr -- R subtree BF= 0, so need to look for changes+ in case r' of+ Z _ _ _ -> Z l e r' -- R subtree BF: 0-> 0, H:h->h , parent BF: 0-> 0+ N _ _ _ -> N l e r' -- R subtree BF: 0->-1, H:h->h+1, parent BF: 0->-1+ _ -> error "pushR: Bug0" -- impossible++ -- (putPR l e r): Put in R subtree of (P l e r), BF=+1 (Never requires rebalancing) , (never returns N)+ putPR l e E = Z l e (Z E e0 E) -- R subtree empty, H:0->1, parent BF:+1-> 0+ putPR l e (N rl re rr) = let r' = putNR rl re rr -- R subtree BF<>0, H:h->h, parent BF:+1->+1+ in r' `seq` P l e r'+ putPR l e (P rl re rr) = let r' = putPR rl re rr -- R subtree BF<>0, H:h->h, parent BF:+1->+1+ in r' `seq` P l e r'+ putPR l e (Z rl re rr) = let r' = putZR rl re rr -- R subtree BF= 0, so need to look for changes+ in case r' of+ Z _ _ _ -> P l e r' -- R subtree BF:0-> 0, H:h->h , parent BF:+1->+1+ N _ _ _ -> Z l e r' -- R subtree BF:0->-1, H:h->h+1, parent BF:+1-> 0+ _ -> error "pushR: Bug1" -- impossible++ -------- This case (NR) may need rebalancing if it goes to LEVEL 3 ---------++ -- (putNR l e r): Put in R subtree of (N l e r), BF=-1 , (never returns P)+ putNR _ _ E = error "pushR: Bug2" -- impossible if BF=-1+ putNR l e (N rl re rr) = let r' = putNR rl re rr -- R subtree BF<>0, H:h->h, parent BF:-1->-1+ in r' `seq` N l e r'+ putNR l e (P rl re rr) = let r' = putPR rl re rr -- R subtree BF<>0, H:h->h, parent BF:-1->-1+ in r' `seq` N l e r'+ putNR l e (Z rl re rr) = putNRR l e rl re rr -- RR (never returns P)++ ----------------------------- LEVEL 3 ---------------------------------+ -- putNRR --+ -----------------------------------------------------------------------++ -- (putNRR l e rl re rr): Put in RR subtree of (N l e (Z rl re rr)) , (never returns P)+ {-# INLINE putNRR #-}+ putNRR l e rl re E = Z (Z l e rl) re (Z E e0 E) -- l and rl must also be E, special CASE RR!!+ putNRR l e rl re (N rrl rre rrr) = let rr' = putNR rrl rre rrr -- RR subtree BF<>0, H:h->h, so no change+ in rr' `seq` N l e (Z rl re rr')+ putNRR l e rl re (P rrl rre rrr) = let rr' = putPR rrl rre rrr -- RR subtree BF<>0, H:h->h, so no change+ in rr' `seq` N l e (Z rl re rr')+ putNRR l e rl re (Z rrl rre rrr) = let rr' = putZR rrl rre rrr -- RR subtree BF= 0, so need to look for changes+ in case rr' of+ Z _ _ _ -> N l e (Z rl re rr') -- RR subtree BF: 0-> 0, H:h->h, so no change+ N _ _ _ -> Z (Z l e rl) re rr' -- RR subtree BF: 0->-1, H:h->h+1, parent BF:-1->-2, CASE RR !!+ _ -> error "pushR: Bug3" -- impossible+-----------------------------------------------------------------------+--------------------------- pushR Ends Here ---------------------------+-----------------------------------------------------------------------++
+ Data/Tree/AVL/Read.hs view
@@ -0,0 +1,168 @@+-----------------------------------------------------------------------------+-- |+-- Module : Data.Tree.AVL.Read+-- Copyright : (c) Adrian Hey 2004,2005+-- License : BSD3+--+-- Maintainer : http://homepages.nildram.co.uk/~ahey/em.png+-- Stability : stable+-- Portability : portable+-----------------------------------------------------------------------------+module Data.Tree.AVL.Read+(-- * Reading from AVL trees++ -- ** Reading from extreme left or right+ assertReadL,tryReadL,+ assertReadR,tryReadR,++ -- ** Reading from /sorted/ AVL trees+ genAssertRead,genTryRead,genTryReadMaybe,genDefaultRead,++ -- ** Simple searches of /sorted/ AVL trees+ genContains,+) where++import Prelude -- so haddock finds the symbols there++import Data.COrdering+import Data.Tree.AVL.Types(AVL(..))++-- | Read the leftmost element from a /non-empty/ tree. Raises an error if the tree is empty.+-- If the tree is sorted this will return the least element.+--+-- Complexity: O(log n)+assertReadL :: AVL e -> e+assertReadL E = error "assertReadL: Empty tree."+assertReadL (N l e _) = readLE l e+assertReadL (Z l e _) = readLE l e+assertReadL (P l _ _) = readLNE l -- BF=+1, so left sub-tree cannot be empty.++-- | Similar to 'assertReadL' but returns 'Nothing' if the tree is empty.+--+-- Complexity: O(log n)+tryReadL :: AVL e -> Maybe e+tryReadL E = Nothing+tryReadL (N l e _) = Just $! readLE l e+tryReadL (Z l e _) = Just $! readLE l e+tryReadL (P l _ _) = Just $! readLNE l -- BF=+1, so left sub-tree cannot be empty.++-- Local utilities for the above+readLNE :: AVL e -> e+readLNE E = error "readLNE: Bug."+readLNE (N l e _) = readLE l e+readLNE (Z l e _) = readLE l e+readLNE (P l _ _) = readLNE l -- BF=+1, so left sub-tree cannot be empty.+readLE :: AVL e -> e -> e+readLE E e = e+readLE (N l e _) _ = readLE l e+readLE (Z l e _) _ = readLE l e+readLE (P l _ _) _ = readLNE l -- BF=+1, so left sub-tree cannot be empty.+++-- | Read the rightmost element from a /non-empty/ tree. Raises an error if the tree is empty.+-- If the tree is sorted this will return the greatest element.+--+-- Complexity: O(log n)+assertReadR :: AVL e -> e+assertReadR E = error "assertReadR: Empty tree."+assertReadR (P _ e r) = readRE r e+assertReadR (Z _ e r) = readRE r e+assertReadR (N _ _ r) = readRNE r -- BF=-1, so right sub-tree cannot be empty.++-- | Similar to 'assertReadR' but returns 'Nothing' if the tree is empty.+--+-- Complexity: O(log n)+tryReadR :: AVL e -> Maybe e+tryReadR E = Nothing+tryReadR (P _ e r) = Just $! readRE r e+tryReadR (Z _ e r) = Just $! readRE r e+tryReadR (N _ _ r) = Just $! readRNE r -- BF=-1, so right sub-tree cannot be empty.++-- Local utilities for the above+readRNE :: AVL e -> e+readRNE E = error "readRNE: Bug."+readRNE (P _ e r) = readRE r e+readRNE (Z _ e r) = readRE r e+readRNE (N _ _ r) = readRNE r -- BF=-1, so right sub-tree cannot be empty.+readRE :: AVL e -> e -> e+readRE E e = e+readRE (P _ e r) _ = readRE r e+readRE (Z _ e r) _ = readRE r e+readRE (N _ _ r) _ = readRNE r -- BF=-1, so right sub-tree cannot be empty.+++-- | General purpose function to perform a search of a sorted tree, using the supplied selector.+-- This function raises a error if the search fails.+--+-- Complexity: O(log n)+genAssertRead :: AVL e -> (e -> COrdering a) -> a+genAssertRead t c = genRead' t where+ genRead' E = error "genAssertRead failed."+ genRead' (N l e r) = genRead'' l e r+ genRead' (Z l e r) = genRead'' l e r+ genRead' (P l e r) = genRead'' l e r+ genRead'' l e r = case c e of+ Lt -> genRead' l+ Eq a -> a+ Gt -> genRead' r++-- | General purpose function to perform a search of a sorted tree, using the supplied selector.+-- This function is similar to 'genAssertRead', but returns 'Nothing' if the search failed.+--+-- Complexity: O(log n)+genTryRead :: AVL e -> (e -> COrdering a) -> Maybe a+genTryRead t c = genTryRead' t where+ genTryRead' E = Nothing+ genTryRead' (N l e r) = genTryRead'' l e r+ genTryRead' (Z l e r) = genTryRead'' l e r+ genTryRead' (P l e r) = genTryRead'' l e r+ genTryRead'' l e r = case c e of+ Lt -> genTryRead' l+ Eq a -> Just a+ Gt -> genTryRead' r++-- | This version returns the result of the selector (without adding a 'Just' wrapper) if the search+-- succeeds, or 'Nothing' if it fails.+--+-- Complexity: O(log n)+genTryReadMaybe :: AVL e -> (e -> COrdering (Maybe a)) -> Maybe a+genTryReadMaybe t c = genTryRead' t where+ genTryRead' E = Nothing+ genTryRead' (N l e r) = genTryRead'' l e r+ genTryRead' (Z l e r) = genTryRead'' l e r+ genTryRead' (P l e r) = genTryRead'' l e r+ genTryRead'' l e r = case c e of+ Lt -> genTryRead' l+ Eq mba -> mba+ Gt -> genTryRead' r++-- | General purpose function to perform a search of a sorted tree, using the supplied selector.+-- This function is similar to 'genAssertRead', but returns a the default value (first argument) if+-- the search fails.+--+-- Complexity: O(log n)+genDefaultRead :: a -> AVL e -> (e -> COrdering a) -> a+genDefaultRead d t c = genRead' t where+ genRead' E = d+ genRead' (N l e r) = genRead'' l e r+ genRead' (Z l e r) = genRead'' l e r+ genRead' (P l e r) = genRead'' l e r+ genRead'' l e r = case c e of+ Lt -> genRead' l+ Eq a -> a+ Gt -> genRead' r++-- | General purpose function to perform a search of a sorted tree, using the supplied selector.+-- Returns True if matching element is found.+--+-- Complexity: O(log n)+genContains :: AVL e -> (e -> Ordering) -> Bool+genContains t c = genContains' t where+ genContains' E = False+ genContains' (N l e r) = genContains'' l e r+ genContains' (Z l e r) = genContains'' l e r+ genContains' (P l e r) = genContains'' l e r+ genContains'' l e r = case c e of+ LT -> genContains' l+ EQ -> True+ GT -> genContains' r
+ Data/Tree/AVL/Set.hs view
@@ -0,0 +1,491 @@+{-# OPTIONS_GHC -fglasgow-exts #-}+-----------------------------------------------------------------------------+-- |+-- Module : Data.Tree.AVL.Set+-- Copyright : (c) Adrian Hey 2004,2005+-- License : BSD3+--+-- Maintainer : http://homepages.nildram.co.uk/~ahey/em.png+-- Stability : stable+-- Portability : portable+-----------------------------------------------------------------------------+module Data.Tree.AVL.Set+(-- * Set operations+ -- | Functions for manipulating AVL trees which represent ordered sets (I.E. /sorted/ trees).+ -- Note that although many of these functions work with a variety of different element+ -- types they all require that elements are sorted according to the same criterion (such+ -- as a field value in a record).++ -- ** Union+ genUnion,genUnionMaybe,genUnions,++ -- ** Difference+ genDifference,genDifferenceMaybe,genSymDifference,++ -- ** Intersection+ genIntersection,genIntersectionMaybe,++ -- *** Intersection with the result as a list+ -- | Sometimes you don\'t want intersection to give a tree, particularly if the+ -- resulting elements are not orderered or sorted according to whatever criterion was+ -- used to sort the elements of the input sets.+ --+ -- The reason these variants are provided for intersection only (and not the other+ -- set functions) is that the (tree returning) intersections always construct an entirely+ -- new tree, whereas with the others the resulting tree will typically share sub-trees+ -- with one or both of the originals. (Of course the results of the others can easily be+ -- converted to a list too if required.)+ genIntersectionToListL,genIntersectionAsListL,+ genIntersectionMaybeToListL,genIntersectionMaybeAsListL,++ -- ** Subset+ genIsSubsetOf,genIsSubsetOfBy++) where++import Prelude -- so haddock finds the symbols there++import Data.Tree.AVL.Types(AVL(..))+import Data.Tree.AVL.Internals.HeightUtils(addHeight)+import Data.Tree.AVL.Internals.HJoin(spliceH)+import Data.Tree.AVL.Internals.HSet(unionH,unionMaybeH,+ intersectionH,intersectionMaybeH,+ differenceH,differenceMaybeH,symDifferenceH)++import Data.COrdering++#ifdef __GLASGOW_HASKELL__+import GHC.Base+#include "ghcdefs.h"+#else+#include "h98defs.h"+#endif++-- | Uses the supplied combining comparison to evaluate the union of two sets represented as+-- sorted AVL trees. Whenever the combining comparison is applied, the first comparison argument is+-- an element of the first tree and the second comparison argument is an element of the second tree.+--+-- Complexity: Not sure, but I'd appreciate it if someone could figure it out.+-- (Faster than Hedge union from Data.Set at any rate).+genUnion :: (e -> e -> COrdering e) -> AVL e -> AVL e -> AVL e+genUnion c = gu where -- This is to avoid O(log n) height calculation for empty sets+ gu E t1 = t1+ gu t0 E = t0+ gu t0@(N l0 _ _ ) t1@(N l1 _ _ ) = gu_ t0 (addHeight L(2) l0) t1 (addHeight L(2) l1)+ gu t0@(N l0 _ _ ) t1@(Z l1 _ _ ) = gu_ t0 (addHeight L(2) l0) t1 (addHeight L(1) l1)+ gu t0@(N l0 _ _ ) t1@(P _ _ r1) = gu_ t0 (addHeight L(2) l0) t1 (addHeight L(2) r1)+ gu t0@(Z l0 _ _ ) t1@(N l1 _ _ ) = gu_ t0 (addHeight L(1) l0) t1 (addHeight L(2) l1)+ gu t0@(Z l0 _ _ ) t1@(Z l1 _ _ ) = gu_ t0 (addHeight L(1) l0) t1 (addHeight L(1) l1)+ gu t0@(Z l0 _ _ ) t1@(P _ _ r1) = gu_ t0 (addHeight L(1) l0) t1 (addHeight L(2) r1)+ gu t0@(P _ _ r0) t1@(N l1 _ _ ) = gu_ t0 (addHeight L(2) r0) t1 (addHeight L(2) l1)+ gu t0@(P _ _ r0) t1@(Z l1 _ _ ) = gu_ t0 (addHeight L(2) r0) t1 (addHeight L(1) l1)+ gu t0@(P _ _ r0) t1@(P _ _ r1) = gu_ t0 (addHeight L(2) r0) t1 (addHeight L(2) r1)+ gu_ t0 h0 t1 h1 = case unionH c t0 h0 t1 h1 of UBT2(t,_) -> t++-- | Similar to 'genUnion', but the resulting tree does not include elements in cases where+-- the supplied combining comparison returns @(Eq Nothing)@.+--+-- Complexity: Not sure, but I'd appreciate it if someone could figure it out.+genUnionMaybe :: (e -> e -> COrdering (Maybe e)) -> AVL e -> AVL e -> AVL e+genUnionMaybe c = gu where -- This is to avoid O(log n) height calculation for empty sets+ gu E t1 = t1+ gu t0 E = t0+ gu t0@(N l0 _ _ ) t1@(N l1 _ _ ) = gu_ t0 (addHeight L(2) l0) t1 (addHeight L(2) l1)+ gu t0@(N l0 _ _ ) t1@(Z l1 _ _ ) = gu_ t0 (addHeight L(2) l0) t1 (addHeight L(1) l1)+ gu t0@(N l0 _ _ ) t1@(P _ _ r1) = gu_ t0 (addHeight L(2) l0) t1 (addHeight L(2) r1)+ gu t0@(Z l0 _ _ ) t1@(N l1 _ _ ) = gu_ t0 (addHeight L(1) l0) t1 (addHeight L(2) l1)+ gu t0@(Z l0 _ _ ) t1@(Z l1 _ _ ) = gu_ t0 (addHeight L(1) l0) t1 (addHeight L(1) l1)+ gu t0@(Z l0 _ _ ) t1@(P _ _ r1) = gu_ t0 (addHeight L(1) l0) t1 (addHeight L(2) r1)+ gu t0@(P _ _ r0) t1@(N l1 _ _ ) = gu_ t0 (addHeight L(2) r0) t1 (addHeight L(2) l1)+ gu t0@(P _ _ r0) t1@(Z l1 _ _ ) = gu_ t0 (addHeight L(2) r0) t1 (addHeight L(1) l1)+ gu t0@(P _ _ r0) t1@(P _ _ r1) = gu_ t0 (addHeight L(2) r0) t1 (addHeight L(2) r1)+ gu_ t0 h0 t1 h1 = case unionMaybeH c t0 h0 t1 h1 of UBT2(t,_) -> t++-- | Uses the supplied combining comparison to evaluate the union of all sets in a list+-- of sets represented as sorted AVL trees. Behaves as if defined..+--+-- @genUnions ccmp avls = foldl' ('genUnion' ccmp) empty avls@+genUnions :: (e -> e -> COrdering e) -> [AVL e] -> AVL e+genUnions c = gus E L(0) where+ gus a _ [] = a+ gus a ha ( E :avls) = gus a ha avls+ gus a ha (t@(N l _ _):avls) = case unionH c a ha t (addHeight L(2) l) of UBT2(a_,ha_) -> gus a_ ha_ avls+ gus a ha (t@(Z l _ _):avls) = case unionH c a ha t (addHeight L(1) l) of UBT2(a_,ha_) -> gus a_ ha_ avls+ gus a ha (t@(P _ _ r):avls) = case unionH c a ha t (addHeight L(2) r) of UBT2(a_,ha_) -> gus a_ ha_ avls++-- | Uses the supplied combining comparison to evaluate the intersection of two sets represented as+-- sorted AVL trees.+--+-- Complexity: Not sure, but I'd appreciate it if someone could figure it out.+genIntersection :: (a -> b -> COrdering c) -> AVL a -> AVL b -> AVL c+genIntersection c t0 t1 = case intersectionH c t0 t1 of UBT2(t,_) -> t++-- | Similar to 'genIntersection', but the resulting tree does not include elements in cases where+-- the supplied combining comparison returns @(Eq Nothing)@.+--+-- Complexity: Not sure, but I'd appreciate it if someone could figure it out.+genIntersectionMaybe :: (a -> b -> COrdering (Maybe c)) -> AVL a -> AVL b -> AVL c+genIntersectionMaybe c t0 t1 = case intersectionMaybeH c t0 t1 of UBT2(t,_) -> t++-- | Similar to 'genIntersection', but prepends the result to the supplied list in+-- left to right order. This is a (++) free function which behaves as if defined:+--+-- @genIntersectionToListL c setA setB cs = asListL (genIntersection c setA setB) ++ cs@+--+-- Complexity: Not sure, but I'd appreciate it if someone could figure it out.+genIntersectionToListL :: (a -> b -> COrdering c) -> AVL a -> AVL b -> [c] -> [c]+genIntersectionToListL comp = i where+ -- i :: AVL a -> AVL b -> [c] -> [c]+ i E _ cs = cs+ i _ E cs = cs+ i (N l0 e0 r0) (N l1 e1 r1) cs = i' l0 e0 r0 l1 e1 r1 cs+ i (N l0 e0 r0) (Z l1 e1 r1) cs = i' l0 e0 r0 l1 e1 r1 cs+ i (N l0 e0 r0) (P l1 e1 r1) cs = i' l0 e0 r0 l1 e1 r1 cs+ i (Z l0 e0 r0) (N l1 e1 r1) cs = i' l0 e0 r0 l1 e1 r1 cs+ i (Z l0 e0 r0) (Z l1 e1 r1) cs = i' l0 e0 r0 l1 e1 r1 cs+ i (Z l0 e0 r0) (P l1 e1 r1) cs = i' l0 e0 r0 l1 e1 r1 cs+ i (P l0 e0 r0) (N l1 e1 r1) cs = i' l0 e0 r0 l1 e1 r1 cs+ i (P l0 e0 r0) (Z l1 e1 r1) cs = i' l0 e0 r0 l1 e1 r1 cs+ i (P l0 e0 r0) (P l1 e1 r1) cs = i' l0 e0 r0 l1 e1 r1 cs+ i' l0 e0 r0 l1 e1 r1 cs =+ case comp e0 e1 of+ -- e0 < e1, so (l0 < e0 < e1) & (e0 < e1 < r1)+ Lt -> case forkR r0 e1 of+ UBT5(rl0,_,mbc1,rr0,_) -> case forkL e0 l1 of -- (e0 < rl0 < e1) & (e0 < e1 < rr0)+ UBT5(ll1,_,mbc0,lr1,_) -> -- (ll1 < e0 < e1) & (e0 < lr1 < e1)+ -- (l0 + ll1) < e0 < (rl0 + lr1) < e1 < (rr0 + r1)+ let cs' = i rr0 r1 cs+ cs'' = cs' `seq` case mbc1 of+ Nothing -> i rl0 lr1 cs'+ Just c1 -> i rl0 lr1 (c1:cs')+ in cs'' `seq` case mbc0 of+ Nothing -> i l0 ll1 cs''+ Just c0 -> i l0 ll1 (c0:cs'')+ -- e0 = e1+ Eq c -> let cs' = i r0 r1 cs in cs' `seq` i l0 l1 (c:cs')+ -- e1 < e0, so (l1 < e1 < e0) & (e1 < e0 < r0)+ Gt -> case forkL e0 r1 of+ UBT5(rl1,_,mbc0,rr1,_) -> case forkR l0 e1 of -- (e1 < rl1 < e0) & (e1 < e0 < rr1)+ UBT5(ll0,_,mbc1,lr0,_) -> -- (ll0 < e1 < e0) & (e1 < lr0 < e0)+ -- (ll0 + l1) < e1 < (lr0 + rl1) < e0 < (r0 + rr1)+ let cs' = i r0 rr1 cs+ cs'' = cs' `seq` case mbc0 of+ Nothing -> i lr0 rl1 cs'+ Just c0 -> i lr0 rl1 (c0:cs')+ in cs'' `seq` case mbc1 of+ Nothing -> i ll0 l1 cs''+ Just c1 -> i ll0 l1 (c1:cs'')+ -- We need 2 different versions of fork (L & R) to ensure that comparison arguments are used in+ -- the right order (c e0 e1)+ -- forkL :: a -> AVL b -> UBT5(AVL b,UINT,Maybe c,AVL b,UINT)+ forkL e0 t1 = forkL_ t1 L(0) where+ forkL_ E h = UBT5(E,h,Nothing,E,h) -- Relative heights!!+ forkL_ (N l e r) h = forkL__ l DECINT2(h) e r DECINT1(h)+ forkL_ (Z l e r) h = forkL__ l DECINT1(h) e r DECINT1(h)+ forkL_ (P l e r) h = forkL__ l DECINT1(h) e r DECINT2(h)+ forkL__ l hl e r hr = case comp e0 e of+ Lt -> case forkL_ l hl of+ UBT5(l0,hl0,mbc0,l1,hl1) -> case spliceH l1 hl1 e r hr of+ UBT2(l1_,hl1_) -> UBT5(l0,hl0,mbc0,l1_,hl1_)+ Eq c0 -> UBT5(l,hl,Just c0,r,hr)+ Gt -> case forkL_ r hr of+ UBT5(l0,hl0,mbc0,l1,hl1) -> case spliceH l hl e l0 hl0 of+ UBT2(l0_,hl0_) -> UBT5(l0_,hl0_,mbc0,l1,hl1)+ -- forkR :: AVL a -> b -> UBT5(AVL a,UINT,Maybe c,AVL a,UINT)+ forkR t0 e1 = forkR_ t0 L(0) where+ forkR_ E h = UBT5(E,h,Nothing,E,h) -- Relative heights!!+ forkR_ (N l e r) h = forkR__ l DECINT2(h) e r DECINT1(h)+ forkR_ (Z l e r) h = forkR__ l DECINT1(h) e r DECINT1(h)+ forkR_ (P l e r) h = forkR__ l DECINT1(h) e r DECINT2(h)+ forkR__ l hl e r hr = case comp e e1 of+ Lt -> case forkR_ r hr of+ UBT5(l0,hl0,mbc1,l1,hl1) -> case spliceH l hl e l0 hl0 of+ UBT2(l0_,hl0_) -> UBT5(l0_,hl0_,mbc1,l1,hl1)+ Eq c1 -> UBT5(l,hl,Just c1,r,hr)+ Gt -> case forkR_ l hl of+ UBT5(l0,hl0,mbc1,l1,hl1) -> case spliceH l1 hl1 e r hr of+ UBT2(l1_,hl1_) -> UBT5(l0,hl0,mbc1,l1_,hl1_)+-----------------------------------------------------------------------+------------------ genIntersectionToListL Ends Here -------------------+-----------------------------------------------------------------------++-- | Applies 'genIntersectionToListL' to the empty list.+--+-- Complexity: Not sure, but I'd appreciate it if someone could figure it out.+genIntersectionAsListL :: (a -> b -> COrdering c) -> AVL a -> AVL b -> [c]+genIntersectionAsListL c setA setB = genIntersectionToListL c setA setB []++-- | Similar to 'genIntersectionToListL', but the result does not include elements in cases where+-- the supplied combining comparison returns @(Eq Nothing)@.+--+-- Complexity: Not sure, but I'd appreciate it if someone could figure it out.+genIntersectionMaybeToListL :: (a -> b -> COrdering (Maybe c)) -> AVL a -> AVL b -> [c] -> [c]+genIntersectionMaybeToListL comp = i where+ -- i :: AVL a -> AVL b -> [c] -> [c]+ i E _ cs = cs+ i _ E cs = cs+ i (N l0 e0 r0) (N l1 e1 r1) cs = i' l0 e0 r0 l1 e1 r1 cs+ i (N l0 e0 r0) (Z l1 e1 r1) cs = i' l0 e0 r0 l1 e1 r1 cs+ i (N l0 e0 r0) (P l1 e1 r1) cs = i' l0 e0 r0 l1 e1 r1 cs+ i (Z l0 e0 r0) (N l1 e1 r1) cs = i' l0 e0 r0 l1 e1 r1 cs+ i (Z l0 e0 r0) (Z l1 e1 r1) cs = i' l0 e0 r0 l1 e1 r1 cs+ i (Z l0 e0 r0) (P l1 e1 r1) cs = i' l0 e0 r0 l1 e1 r1 cs+ i (P l0 e0 r0) (N l1 e1 r1) cs = i' l0 e0 r0 l1 e1 r1 cs+ i (P l0 e0 r0) (Z l1 e1 r1) cs = i' l0 e0 r0 l1 e1 r1 cs+ i (P l0 e0 r0) (P l1 e1 r1) cs = i' l0 e0 r0 l1 e1 r1 cs+ i' l0 e0 r0 l1 e1 r1 cs =+ case comp e0 e1 of+ -- e0 < e1, so (l0 < e0 < e1) & (e0 < e1 < r1)+ Lt -> case forkR r0 e1 of+ UBT5(rl0,_,mbc1,rr0,_) -> case forkL e0 l1 of -- (e0 < rl0 < e1) & (e0 < e1 < rr0)+ UBT5(ll1,_,mbc0,lr1,_) -> -- (ll1 < e0 < e1) & (e0 < lr1 < e1)+ -- (l0 + ll1) < e0 < (rl0 + lr1) < e1 < (rr0 + r1)+ let cs' = i rr0 r1 cs+ cs'' = cs' `seq` case mbc1 of+ Nothing -> i rl0 lr1 cs'+ Just c1 -> i rl0 lr1 (c1:cs')+ in cs'' `seq` case mbc0 of+ Nothing -> i l0 ll1 cs''+ Just c0 -> i l0 ll1 (c0:cs'')+ -- e0 = e1+ Eq mbc -> let cs' = i r0 r1 cs in cs' `seq` case mbc of+ Nothing -> i l0 l1 cs'+ Just c -> i l0 l1 (c:cs')+ -- e1 < e0, so (l1 < e1 < e0) & (e1 < e0 < r0)+ Gt -> case forkL e0 r1 of+ UBT5(rl1,_,mbc0,rr1,_) -> case forkR l0 e1 of -- (e1 < rl1 < e0) & (e1 < e0 < rr1)+ UBT5(ll0,_,mbc1,lr0,_) -> -- (ll0 < e1 < e0) & (e1 < lr0 < e0)+ -- (ll0 + l1) < e1 < (lr0 + rl1) < e0 < (r0 + rr1)+ let cs' = i r0 rr1 cs+ cs'' = cs' `seq` case mbc0 of+ Nothing -> i lr0 rl1 cs'+ Just c0 -> i lr0 rl1 (c0:cs')+ in cs'' `seq` case mbc1 of+ Nothing -> i ll0 l1 cs''+ Just c1 -> i ll0 l1 (c1:cs'')+ -- We need 2 different versions of fork (L & R) to ensure that comparison arguments are used in+ -- the right order (c e0 e1)+ -- forkL :: a -> AVL b -> UBT5(AVL b,UINT,Maybe c,AVL b,UINT)+ forkL e0 t1 = forkL_ t1 L(0) where+ forkL_ E h = UBT5(E,h,Nothing,E,h) -- Relative heights!!+ forkL_ (N l e r) h = forkL__ l DECINT2(h) e r DECINT1(h)+ forkL_ (Z l e r) h = forkL__ l DECINT1(h) e r DECINT1(h)+ forkL_ (P l e r) h = forkL__ l DECINT1(h) e r DECINT2(h)+ forkL__ l hl e r hr = case comp e0 e of+ Lt -> case forkL_ l hl of+ UBT5(l0,hl0,mbc0,l1,hl1) -> case spliceH l1 hl1 e r hr of+ UBT2(l1_,hl1_) -> UBT5(l0,hl0,mbc0,l1_,hl1_)+ Eq mbc0 -> UBT5(l,hl,mbc0,r,hr)+ Gt -> case forkL_ r hr of+ UBT5(l0,hl0,mbc0,l1,hl1) -> case spliceH l hl e l0 hl0 of+ UBT2(l0_,hl0_) -> UBT5(l0_,hl0_,mbc0,l1,hl1)+ -- forkR :: AVL a -> b -> UBT5(AVL a,UINT,Maybe c,AVL a,UINT)+ forkR t0 e1 = forkR_ t0 L(0) where+ forkR_ E h = UBT5(E,h,Nothing,E,h) -- Relative heights!!+ forkR_ (N l e r) h = forkR__ l DECINT2(h) e r DECINT1(h)+ forkR_ (Z l e r) h = forkR__ l DECINT1(h) e r DECINT1(h)+ forkR_ (P l e r) h = forkR__ l DECINT1(h) e r DECINT2(h)+ forkR__ l hl e r hr = case comp e e1 of+ Lt -> case forkR_ r hr of+ UBT5(l0,hl0,mbc1,l1,hl1) -> case spliceH l hl e l0 hl0 of+ UBT2(l0_,hl0_) -> UBT5(l0_,hl0_,mbc1,l1,hl1)+ Eq mbc1 -> UBT5(l,hl,mbc1,r,hr)+ Gt -> case forkR_ l hl of+ UBT5(l0,hl0,mbc1,l1,hl1) -> case spliceH l1 hl1 e r hr of+ UBT2(l1_,hl1_) -> UBT5(l0,hl0,mbc1,l1_,hl1_)+-----------------------------------------------------------------------+---------------- genIntersectionMaybeToListL Ends Here ----------------+-----------------------------------------------------------------------++-- | Applies 'genIntersectionMaybeToListL' to the empty list.+--+-- Complexity: Not sure, but I'd appreciate it if someone could figure it out.+genIntersectionMaybeAsListL :: (a -> b -> COrdering (Maybe c)) -> AVL a -> AVL b -> [c]+genIntersectionMaybeAsListL c setA setB = genIntersectionMaybeToListL c setA setB []++-- | Uses the supplied comparison to evaluate the difference between two sets represented as+-- sorted AVL trees. The expression..+--+-- > genDifference cmp setA setB+--+-- .. is a set containing all those elements of @setA@ which do not appear in @setB@.+--+-- Complexity: Not sure, but I'd appreciate it if someone could figure it out.+genDifference :: (a -> b -> Ordering) -> AVL a -> AVL b -> AVL a+-- N.B. differenceH works with relative heights on first tree, and needs no height for the second.+genDifference c t0 t1 = case differenceH c t0 L(0) t1 of UBT2(t,_) -> t++-- | Similar to 'genDifference', but the resulting tree also includes those elements a\' for which the+-- combining comparison returns @(Eq (Just a\'))@.+--+-- Complexity: Not sure, but I'd appreciate it if someone could figure it out.+genDifferenceMaybe :: (a -> b -> COrdering (Maybe a)) -> AVL a -> AVL b -> AVL a+-- N.B. differenceMaybeH works with relative heights on first tree, and needs no height for the second.+genDifferenceMaybe c t0 t1 = case differenceMaybeH c t0 L(0) t1 of UBT2(t,_) -> t++-- | Uses the supplied comparison to test whether the first set is a subset of the second,+-- both sets being represented as sorted AVL trees. This function returns True if any of+-- the following conditions hold..+--+-- * The first set is empty (the empty set is a subset of any set).+--+-- * The two sets are equal.+--+-- * The first set is a proper subset of the second set.+--+-- Complexity: Not sure, but I'd appreciate it if someone could figure it out.+genIsSubsetOf :: (a -> b -> Ordering) -> AVL a -> AVL b -> Bool+genIsSubsetOf comp = s where+ -- s :: AVL a -> AVL b -> Bool+ s E _ = True+ s _ E = False+ s (N l0 e0 r0) (N l1 e1 r1) = s' l0 e0 r0 l1 e1 r1+ s (N l0 e0 r0) (Z l1 e1 r1) = s' l0 e0 r0 l1 e1 r1+ s (N l0 e0 r0) (P l1 e1 r1) = s' l0 e0 r0 l1 e1 r1+ s (Z l0 e0 r0) (N l1 e1 r1) = s' l0 e0 r0 l1 e1 r1+ s (Z l0 e0 r0) (Z l1 e1 r1) = s' l0 e0 r0 l1 e1 r1+ s (Z l0 e0 r0) (P l1 e1 r1) = s' l0 e0 r0 l1 e1 r1+ s (P l0 e0 r0) (N l1 e1 r1) = s' l0 e0 r0 l1 e1 r1+ s (P l0 e0 r0) (Z l1 e1 r1) = s' l0 e0 r0 l1 e1 r1+ s (P l0 e0 r0) (P l1 e1 r1) = s' l0 e0 r0 l1 e1 r1+ s' l0 e0 r0 l1 e1 r1 =+ case comp e0 e1 of+ -- e0 < e1, so (l0 < e0 < e1) & (e0 < e1 < r1)+ LT -> case forkL e0 l1 of+ UBT5(False,_ ,_,_ ,_) -> False+ UBT5(True ,ll1,_,lr1,_) -> (s l0 ll1) && case forkR r0 e1 of -- (ll1 < e0 < e1) & (e0 < lr1 < e1)+ UBT4(rl0,_,rr0,_) -> (s rl0 lr1) && (s rr0 r1) -- (e0 < rl0 < e1) & (e0 < e1 < rr0)+ -- e0 = e1+ EQ -> (s l0 l1) && (s r0 r1)+ -- e1 < e0, so (l1 < e1 < e0) & (e1 < e0 < r0)+ GT -> case forkL e0 r1 of+ UBT5(False,_ ,_,_ ,_) -> False+ UBT5(True ,rl1,_,rr1,_) -> (s r0 rr1) && case forkR l0 e1 of -- (e1 < rl1 < e0) & (e1 < e0 < rr1)+ UBT4(ll0,_,lr0,_) -> (s lr0 rl1) && (s ll0 l1) -- (ll0 < e1 < e0) & (e1 < lr0 < e0)+ -- forkL returns False if t1 does not contain e0 (which implies set 0 cannot be a subset of set 1)+ -- forkL :: a -> AVL b -> UBT5(Bool,AVL b,UINT,AVL b,UINT) -- Vals 1..4 only valid if Bool is True!+ forkL e0 t = forkL_ t L(0) where+ forkL_ E h = UBT5(False,E,h,E,h)+ forkL_ (N l e r) h = forkL__ l DECINT2(h) e r DECINT1(h)+ forkL_ (Z l e r) h = forkL__ l DECINT1(h) e r DECINT1(h)+ forkL_ (P l e r) h = forkL__ l DECINT1(h) e r DECINT2(h)+ forkL__ l hl e r hr = case comp e0 e of+ LT -> case forkL_ l hl of+ UBT5(False,t0,ht0,t1,ht1) -> UBT5(False,t0,ht0,t1,ht1)+ UBT5(True ,t0,ht0,t1,ht1) -> case spliceH t1 ht1 e r hr of+ UBT2(t1_,ht1_) -> UBT5(True,t0,ht0,t1_,ht1_)+ EQ -> UBT5(True,l,hl,r,hr)+ GT -> case forkL_ r hr of+ UBT5(False,t0,ht0,t1,ht1) -> UBT5(False,t0,ht0,t1,ht1)+ UBT5(True ,t0,ht0,t1,ht1) -> case spliceH l hl e t0 ht0 of+ UBT2(t0_,ht0_) -> UBT5(True,t0_,ht0_,t1,ht1)+ -- forkR discards an element from set 0 if it is equal to the element from set 1+ -- forkR :: AVL a -> b -> UBT4(AVL a,UINT,AVL a,UINT)+ forkR t e1 = forkR_ t L(0) where+ forkR_ E h = UBT4(E,h,E,h) -- Relative heights!!+ forkR_ (N l e r) h = forkR__ l DECINT2(h) e r DECINT1(h)+ forkR_ (Z l e r) h = forkR__ l DECINT1(h) e r DECINT1(h)+ forkR_ (P l e r) h = forkR__ l DECINT1(h) e r DECINT2(h)+ forkR__ l hl e r hr = case comp e e1 of+ LT -> case forkR_ r hr of+ UBT4(t0,ht0,t1,ht1) -> case spliceH l hl e t0 ht0 of+ UBT2(t0_,ht0_) -> UBT4(t0_,ht0_,t1,ht1)+ EQ -> UBT4(l,hl,r,hr) -- e is discarded from set 0+ GT -> case forkR_ l hl of+ UBT4(t0,ht0,t1,ht1) -> case spliceH t1 ht1 e r hr of+ UBT2(t1_,ht1_) -> UBT4(t0,ht0,t1_,ht1_)+-----------------------------------------------------------------------+------------------------ genIsSubsetOf Ends Here ----------------------+-----------------------------------------------------------------------++-- | Similar to 'genIsSubsetOf', but also requires that the supplied combining+-- comparison returns @('Eq' True)@ for matching elements.+--+-- Complexity: Not sure, but I'd appreciate it if someone could figure it out.+genIsSubsetOfBy :: (a -> b -> COrdering Bool) -> AVL a -> AVL b -> Bool+genIsSubsetOfBy comp = s where+ -- s :: AVL a -> AVL b -> Bool+ s E _ = True+ s _ E = False+ s (N l0 e0 r0) (N l1 e1 r1) = s' l0 e0 r0 l1 e1 r1+ s (N l0 e0 r0) (Z l1 e1 r1) = s' l0 e0 r0 l1 e1 r1+ s (N l0 e0 r0) (P l1 e1 r1) = s' l0 e0 r0 l1 e1 r1+ s (Z l0 e0 r0) (N l1 e1 r1) = s' l0 e0 r0 l1 e1 r1+ s (Z l0 e0 r0) (Z l1 e1 r1) = s' l0 e0 r0 l1 e1 r1+ s (Z l0 e0 r0) (P l1 e1 r1) = s' l0 e0 r0 l1 e1 r1+ s (P l0 e0 r0) (N l1 e1 r1) = s' l0 e0 r0 l1 e1 r1+ s (P l0 e0 r0) (Z l1 e1 r1) = s' l0 e0 r0 l1 e1 r1+ s (P l0 e0 r0) (P l1 e1 r1) = s' l0 e0 r0 l1 e1 r1+ s' l0 e0 r0 l1 e1 r1 =+ case comp e0 e1 of+ -- e0 < e1, so (l0 < e0 < e1) & (e0 < e1 < r1)+ Lt -> case forkL e0 l1 of+ UBT5(False,_ ,_,_ ,_) -> False+ UBT5(True ,ll1,_,lr1,_) -> (s l0 ll1) && case forkR r0 e1 of -- (ll1 < e0 < e1) & (e0 < lr1 < e1)+ UBT5(False,_ ,_,_ ,_) -> False+ UBT5(True ,rl0,_,rr0,_) -> (s rl0 lr1) && (s rr0 r1) -- (e0 < rl0 < e1) & (e0 < e1 < rr0)+ -- e0 = e1+ Eq True -> (s l0 l1) && (s r0 r1)+ Eq False -> False+ -- e1 < e0, so (l1 < e1 < e0) & (e1 < e0 < r0)+ Gt -> case forkL e0 r1 of+ UBT5(False,_ ,_,_ ,_) -> False+ UBT5(True ,rl1,_,rr1,_) -> (s r0 rr1) && case forkR l0 e1 of -- (e1 < rl1 < e0) & (e1 < e0 < rr1)+ UBT5(False,_ ,_,_ ,_) -> False+ UBT5(True ,ll0,_,lr0,_) -> (s lr0 rl1) && (s ll0 l1) -- (ll0 < e1 < e0) & (e1 < lr0 < e0)+ -- forkL returns False if t1 does not contain e0 (which implies set 0 cannot be a subset of set 1)+ -- forkL :: a -> AVL b -> UBT5(Bool,AVL b,UINT,AVL b,UINT) -- Vals 1..4 only valid if Bool is True!+ forkL e0 t = forkL_ t L(0) where+ forkL_ E h = UBT5(False,E,h,E,h)+ forkL_ (N l e r) h = forkL__ l DECINT2(h) e r DECINT1(h)+ forkL_ (Z l e r) h = forkL__ l DECINT1(h) e r DECINT1(h)+ forkL_ (P l e r) h = forkL__ l DECINT1(h) e r DECINT2(h)+ forkL__ l hl e r hr = case comp e0 e of+ Lt -> case forkL_ l hl of+ UBT5(False,t0,ht0,t1,ht1) -> UBT5(False,t0,ht0,t1,ht1)+ UBT5(True ,t0,ht0,t1,ht1) -> case spliceH t1 ht1 e r hr of+ UBT2(t1_,ht1_) -> UBT5(True,t0,ht0,t1_,ht1_)+ Eq b -> UBT5(b,l,hl,r,hr)+ Gt -> case forkL_ r hr of+ UBT5(False,t0,ht0,t1,ht1) -> UBT5(False,t0,ht0,t1,ht1)+ UBT5(True ,t0,ht0,t1,ht1) -> case spliceH l hl e t0 ht0 of+ UBT2(t0_,ht0_) -> UBT5(True,t0_,ht0_,t1,ht1)+ -- forkR discards an element from set 0 if it is equal to the element from set 1+ -- forkR :: AVL a -> b -> UBT5(Bool,AVL a,UINT,AVL a,UINT) -- Vals 1..4 only valid if Bool is True!+ forkR t e1 = forkR_ t L(0) where+ forkR_ E h = UBT5(True,E,h,E,h) -- Relative heights!!+ forkR_ (N l e r) h = forkR__ l DECINT2(h) e r DECINT1(h)+ forkR_ (Z l e r) h = forkR__ l DECINT1(h) e r DECINT1(h)+ forkR_ (P l e r) h = forkR__ l DECINT1(h) e r DECINT2(h)+ forkR__ l hl e r hr = case comp e e1 of+ Lt -> case forkR_ r hr of+ UBT5(False,t0,ht0,t1,ht1) -> UBT5(False,t0,ht0,t1,ht1)+ UBT5(True ,t0,ht0,t1,ht1) -> case spliceH l hl e t0 ht0 of+ UBT2(t0_,ht0_) -> UBT5(True,t0_,ht0_,t1,ht1)+ Eq b -> UBT5(b,l,hl,r,hr) -- e is discarded from set 0+ Gt -> case forkR_ l hl of+ UBT5(False,t0,ht0,t1,ht1) -> UBT5(False,t0,ht0,t1,ht1)+ UBT5(True ,t0,ht0,t1,ht1) -> case spliceH t1 ht1 e r hr of+ UBT2(t1_,ht1_) -> UBT5(True,t0,ht0,t1_,ht1_)+-----------------------------------------------------------------------+----------------------- genIsSubsetOfBy Ends Here ---------------------+-----------------------------------------------------------------------++-- | The symmetric difference is the set of elements which occur in one set or the other but /not both/.+--+-- Complexity: Not sure, but I'd appreciate it if someone could figure it out.+genSymDifference :: (e -> e -> Ordering) -> AVL e -> AVL e -> AVL e+genSymDifference c = gu where -- This is to avoid O(log n) height calculation for empty sets+ gu E t1 = t1+ gu t0 E = t0+ gu t0@(N l0 _ _ ) t1@(N l1 _ _ ) = gu_ t0 (addHeight L(2) l0) t1 (addHeight L(2) l1)+ gu t0@(N l0 _ _ ) t1@(Z l1 _ _ ) = gu_ t0 (addHeight L(2) l0) t1 (addHeight L(1) l1)+ gu t0@(N l0 _ _ ) t1@(P _ _ r1) = gu_ t0 (addHeight L(2) l0) t1 (addHeight L(2) r1)+ gu t0@(Z l0 _ _ ) t1@(N l1 _ _ ) = gu_ t0 (addHeight L(1) l0) t1 (addHeight L(2) l1)+ gu t0@(Z l0 _ _ ) t1@(Z l1 _ _ ) = gu_ t0 (addHeight L(1) l0) t1 (addHeight L(1) l1)+ gu t0@(Z l0 _ _ ) t1@(P _ _ r1) = gu_ t0 (addHeight L(1) l0) t1 (addHeight L(2) r1)+ gu t0@(P _ _ r0) t1@(N l1 _ _ ) = gu_ t0 (addHeight L(2) r0) t1 (addHeight L(2) l1)+ gu t0@(P _ _ r0) t1@(Z l1 _ _ ) = gu_ t0 (addHeight L(2) r0) t1 (addHeight L(1) l1)+ gu t0@(P _ _ r0) t1@(P _ _ r1) = gu_ t0 (addHeight L(2) r0) t1 (addHeight L(2) r1)+ gu_ t0 h0 t1 h1 = case symDifferenceH c t0 h0 t1 h1 of UBT2(t,_) -> t+
+ Data/Tree/AVL/Size.hs view
@@ -0,0 +1,174 @@+{-# OPTIONS_GHC -fglasgow-exts #-}+-----------------------------------------------------------------------------+-- |+-- Module : Data.Tree.AVL.Size+-- Copyright : (c) Adrian Hey 2004,2005+-- License : BSD3+--+-- Maintainer : http://homepages.nildram.co.uk/~ahey/em.png+-- Stability : stable+-- Portability : portable+--+-- AVL Tree size related utilities.+-----------------------------------------------------------------------------+module Data.Tree.AVL.Size+ (-- * AVL tree size utilities.+ size,addSize,fastAddSize,clipSize+ ) where++import Data.Tree.AVL.Types(AVL(..))+import Data.Tree.AVL.Internals.HeightUtils(addHeight)++#ifdef __GLASGOW_HASKELL__+import GHC.Base+#include "ghcdefs.h"+#else+#include "h98defs.h"+#endif++-- | Counts the total number of elements in an AVL tree.+--+-- @'size' = 'addSize' 0@+--+-- Complexity: O(n)+{-# INLINE size #-}+size :: AVL e -> Int+size = addSize 0++-- | Adds the size of a tree to the first argument.+-- This is just a convenience wrapper for 'fastAddSize'.+--+-- Complexity: O(n)+{-# INLINE addSize #-}+addSize :: Int -> AVL e -> Int+addSize ASINT(n) t = ASINT(fastAddSize n t)++{-----------------------------------------+Notes for fast size calculation.+ case (h,avl)+ (0,_ ) -> 0 -- Must be E+ (1,_ ) -> 1 -- Must be (Z E _ E )+ (2,N _ _ _) -> 2 -- Must be (N E _ (Z E _ E))+ (2,Z _ _ _) -> 3 -- Must be (Z (Z E _ E) _ (Z E _ E))+ (2,P _ _ _) -> 2 -- Must be (P (Z E _ E) _ E )+ (3,N _ _ r) -> 2 + size 2 r -- Must be (N (Z E _ E) _ r )+ (3,P l _ _) -> 2 + size 2 l -- Must be (P l _ (Z E _ E))+------------------------------------------}++-- | Fast algorithm to calculate size. This avoids visiting about 50% of tree nodes+-- by using fact that trees with small heights can only have particular shapes.+-- So it's still O(n), but with substantial saving in constant factors.+--+-- Complexity: O(n)+fastAddSize :: UINT -> AVL e -> UINT+fastAddSize n E = n+fastAddSize n (N l _ r) = case addHeight L(2) l of+ L(2) -> INCINT2(n)+ L(3) -> fas2 INCINT2(n) r+ h -> fasNP n h l r+fastAddSize n (Z l _ r) = case addHeight L(1) l of+ L(1) -> INCINT1(n)+ L(2) -> INCINT3(n)+ L(3) -> fas2 (fas2 INCINT1(n) l) r+ h -> fasZ n h l r+fastAddSize n (P l _ r) = case addHeight L(2) r of+ L(2) -> INCINT2(n)+ L(3) -> fas2 INCINT2(n) l+ h -> fasNP n h r l+-- Parent Height (h) >= 4 !!+fasNP,fasZ :: UINT -> UINT -> AVL e -> AVL e -> UINT+fasNP n h l r = fasG3 (fasG2 INCINT1(n) DECINT2(h) l) DECINT1(h) r+fasZ n h l r = fasG3 (fasG3 INCINT1(n) DECINT1(h) l) DECINT1(h) r+-- h>=2 !!+fasG2 :: UINT -> UINT -> AVL e -> UINT+fasG2 n L(2) t = fas2 n t+fasG2 n h t = fasG3 n h t+{-# INLINE fasG2 #-}+-- h>=3 !!+fasG3 :: UINT -> UINT -> AVL e -> UINT+fasG3 n L(3) (N _ _ r) = fas2 INCINT2(n) r+fasG3 n L(3) (Z l _ r) = fas2 (fas2 INCINT1(n) l) r+fasG3 n L(3) (P l _ _) = fas2 INCINT2(n) l+fasG3 n h (N l _ r) = fasNP n h l r -- h>=4+fasG3 n h (Z l _ r) = fasZ n h l r -- h>=4+fasG3 n h (P l _ r) = fasNP n h r l -- h>=4+fasG3 _ _ E = error "fastAddSize: Bad Tree." -- impossible+-- h=2 !!+fas2 :: UINT -> AVL e -> UINT+fas2 n (N _ _ _) = INCINT2(n)+fas2 n (Z _ _ _) = INCINT3(n)+fas2 n (P _ _ _) = INCINT2(n)+fas2 _ E = error "fastAddSize: Bad Tree." -- impossible+{-# INLINE fas2 #-}+-----------------------------------------------------------------------+----------------------- fastAddSize Ends Here -------------------------+-----------------------------------------------------------------------++-- | Returns the exact tree size in the form @('Just' n)@ if this is less than or+-- equal to the input clip value. Returns @'Nothing'@ of the size is greater than+-- the clip value. This function exploits the same optimisation as 'fastAddSize'.+--+-- Complexity: O(min n c) where n is tree size and c is clip value.+clipSize :: Int -> AVL e -> Maybe Int+clipSize ASINT(c) t = let c_ = cSzh c t in if c_ LTN L(0)+ then Nothing+ else Just ASINT(SUBINT(c,c_))+-- First entry calculates initial height+cSzh :: UINT -> AVL e -> UINT+cSzh c E = c+cSzh c (N l _ r) = case addHeight L(2) l of+ L(2) -> DECINT2(c)+ L(3) -> cSzNP3 c r+ h -> cSzNP c h l r+cSzh c (Z l _ r) = case addHeight L(1) l of+ L(1) -> DECINT1(c)+ L(2) -> DECINT3(c)+ L(3) -> cSzZ3 c l r+ h -> cSzZ c h l r+cSzh c (P l _ r) = case addHeight L(2) r of+ L(2) -> DECINT2(c)+ L(3) -> cSzNP3 c l+ h -> cSzNP c h r l+-- Parent Height = 3 !!+cSzNP3 :: UINT -> AVL e -> UINT+cSzNP3 c t = if c LTN L(4) then L(-1) else cSz2 DECINT2(c) t+cSzZ3 :: UINT -> AVL e -> AVL e -> UINT+cSzZ3 c l r = if c LTN L(5) then L(-1)+ else let c_ = cSz2 DECINT1(c) l+ in if c_ LTN L(2) then L(-1)+ else cSz2 c_ r+-- Parent Height (h) >= 4 !!+cSzNP,cSzZ :: UINT -> UINT -> AVL e -> AVL e -> UINT+cSzNP c h l r = if c LTN L(7) then L(-1)+ else let c_ = cSzG2 DECINT1(c) DECINT2(h) l -- (h-2) >= 2+ in if c_ LTN L(4) then L(-1)+ else cSzG3 c_ DECINT1(h) r -- (h-1) >= 3+cSzZ c h l r = if c LTN L(9) then L(-1)+ else let c_ = cSzG3 DECINT1(c) DECINT1(h) l -- (h-1) >= 3+ in if c_ LTN L(4) then L(-1)+ else cSzG3 c_ DECINT1(h) r -- (h-1) >= 3+-- h>=2 !!+cSzG2 :: UINT -> UINT -> AVL e -> UINT+cSzG2 c L(2) t = cSz2 c t+cSzG2 c h t = cSzG3 c h t+{-# INLINE cSzG2 #-}+-- h>=3 !!+cSzG3 :: UINT -> UINT -> AVL e -> UINT+cSzG3 c L(3) (N _ _ r) = cSzNP3 c r+cSzG3 c L(3) (Z l _ r) = cSzZ3 c l r+cSzG3 c L(3) (P l _ _) = cSzNP3 c l+cSzG3 c h (N l _ r) = cSzNP c h l r -- h>=4+cSzG3 c h (Z l _ r) = cSzZ c h l r -- h>=4+cSzG3 c h (P l _ r) = cSzNP c h r l -- h>=4+cSzG3 _ _ E = error "clipSize: Bad Tree." -- impossible+-- h=2 !!+cSz2 :: UINT -> AVL e -> UINT+cSz2 c (N _ _ _) = DECINT2(c)+cSz2 c (Z _ _ _) = DECINT3(c)+cSz2 c (P _ _ _) = DECINT2(c)+cSz2 _ E = error "clipSize: Bad Tree." -- impossible+{-# INLINE cSz2 #-}+-----------------------------------------------------------------------+------------------------- clipSize Ends Here --------------------------+-----------------------------------------------------------------------+
+ Data/Tree/AVL/Split.hs view
@@ -0,0 +1,837 @@+{-# OPTIONS_GHC -fglasgow-exts #-}+-----------------------------------------------------------------------------+-- |+-- Module : Data.Tree.AVL.Split+-- Copyright : (c) Adrian Hey 2004,2005+-- License : BSD3+--+-- Maintainer : http://homepages.nildram.co.uk/~ahey/em.png+-- Stability : stable+-- Portability : portable+-----------------------------------------------------------------------------+module Data.Tree.AVL.Split+(-- * Splitting AVL trees++ -- ** Taking fixed size lumps of tree+ -- | Bear in mind that the tree size (s) is not stored in the AVL data structure, but if it is+ -- already known for other reasons then for (n > s\/2) using the appropriate complementary+ -- function with argument (s-n) will be faster.+ -- But it's probably not worth invoking 'Data.Tree.AVL.Types.size' for no reason other than to+ -- exploit this optimisation (because this is O(s) anyway).+ splitAtL,splitAtR,takeL,takeR,dropL,dropR,++ -- ** Rotations+ -- | Bear in mind that the tree size (s) is not stored in the AVL data structure, but if it is+ -- already known for other reasons then for (n > s\/2) using the appropriate complementary+ -- function with argument (s-n) will be faster.+ -- But it's probably not worth invoking 'Data.Tree.AVL.Types.size' for no reason other than to exploit this optimisation+ -- (because this is O(s) anyway).+ rotateL,rotateR,popRotateL,popRotateR,rotateByL,rotateByR,++ -- ** Taking lumps of tree according to a supplied predicate+ spanL,spanR,takeWhileL,dropWhileL,takeWhileR,dropWhileR,++ -- ** Taking lumps of /sorted/ trees+ -- | Prepare to get confused. All these functions adhere to the same Ordering convention as+ -- is used for searches. That is, if the supplied selector returns LT that means the search+ -- key is less than the current tree element. Or put another way, the current tree element+ -- is greater than the search key.+ --+ -- So (for example) the result of the 'genTakeLT' function is a tree containing all those elements+ -- which are less than the notional search key. That is, all those elements for which the+ -- supplied selector returns GT (not LT as you might expect). I know that seems backwards, but+ -- it's consistent if you think about it.+ genForkL,genForkR,genFork,+ genTakeLE,genDropGT,+ genTakeLT,genDropGE,+ genTakeGT,genDropLE,+ genTakeGE,genDropLT,+) where++import Prelude -- so haddock finds the symbols there+++import Data.COrdering(COrdering(..))+import Data.Tree.AVL.Types(AVL(..))+import Data.Tree.AVL.Push(pushL,pushR)+import Data.Tree.AVL.Internals.DelUtils(popRN,popRZ,popRP,popLN,popLZ,popLP)+import Data.Tree.AVL.Internals.HAVL(HAVL(HAVL),spliceHAVL,pushLHAVL,pushRHAVL)+import Data.Tree.AVL.Internals.HJoin(joinH')++#ifdef __GLASGOW_HASKELL__+import GHC.Base+#include "ghcdefs.h"+#else+#include "h98defs.h"+#endif++-- Local Datatype for results of split operations.+data SplitResult e = All (HAVL e) (HAVL e) -- Two tree/height pairs. Non Strict!!+ | More {-# UNPACK #-} !UINT -- No of tree elements still required (>=0!!)++-- | Split an AVL tree from the Left. The 'Int' argument n (n >= 0) specifies the split point.+-- This function raises an error if n is negative.+--+-- If the tree size is greater than n the result is (Right (l,r)) where l contains+-- the leftmost n elements and r contains the remaining rightmost elements (r will be non-empty).+--+-- If the tree size is less than or equal to n then the result is (Left s), where s is tree size.+--+-- An empty tree will always yield a result of (Left 0).+--+-- Complexity: O(n)+splitAtL :: Int -> AVL e -> Either Int (AVL e, AVL e)+splitAtL n _ | n < 0 = error "splitAtL: Negative argument."+splitAtL 0 E = Left 0 -- Treat this case specially+splitAtL 0 t = Right (E,t)+splitAtL ASINT(n) t = case splitL n t L(0) of -- Tree Heights are relative!!+ More n_ -> Left ASINT(SUBINT(n,n_))+ All (HAVL l _) (HAVL r _) -> Right (l,r)++-- n > 0 !!+-- N.B Never returns a result of form (ALL lhavl rhavl) where rhavl is empty+splitL :: UINT -> AVL e -> UINT -> SplitResult e+splitL n E _ = More n+splitL n (N l e r) h = splitL_ n l DECINT2(h) e r DECINT1(h)+splitL n (Z l e r) h = splitL_ n l DECINT1(h) e r DECINT1(h)+splitL n (P l e r) h = splitL_ n l DECINT1(h) e r DECINT2(h)++-- n > 0 !!+-- N.B Never returns a result of form (ALL lhavl rhavl) where rhavl is empty+splitL_ :: UINT -> AVL e -> UINT -> e -> AVL e -> UINT -> SplitResult e+splitL_ n l hl e r hr =+ case splitL n l hl of+ More L(0) -> let rhavl = pushLHAVL e (HAVL r hr); lhavl = HAVL l hl+ in lhavl `seq` rhavl `seq` All lhavl rhavl+ More L(1) -> case r of+ E -> More L(0)+ _ -> let lhavl = pushRHAVL (HAVL l hl) e+ rhavl = HAVL r hr+ in lhavl `seq` rhavl `seq` All lhavl rhavl+ More n_ -> let sr = splitL DECINT1(n_) r hr+ in case sr of+ More _ -> sr+ All havl0 havl1 -> let havl0' = spliceHAVL (HAVL l hl) e havl0+ in havl0' `seq` All havl0' havl1+ All havl0 havl1 -> let havl1' = spliceHAVL havl1 e (HAVL r hr)+ in havl1' `seq` All havl0 havl1'+-----------------------------------------------------------------------+------------------------- splitAtL Ends Here --------------------------+-----------------------------------------------------------------------++-- | Split an AVL tree from the Right. The 'Int' argument n (n >= 0) specifies the split point.+-- This function raises an error if n is negative.+--+-- If the tree size is greater than n the result is (Right (l,r)) where r contains+-- the rightmost n elements and l contains the remaining leftmost elements (l will be non-empty).+--+-- If the tree size is less than or equal to n then the result is (Left s), where s is tree size.+--+-- An empty tree will always yield a result of (Left 0).+--+-- Complexity: O(n)+splitAtR :: Int -> AVL e -> Either Int (AVL e, AVL e)+splitAtR n _ | n < 0 = error "splitAtR: Negative argument."+splitAtR 0 E = Left 0 -- Treat this case specially+splitAtR 0 t = Right (t,E)+splitAtR ASINT(n) t = case splitR n t L(0) of -- Tree Heights are relative!!+ More n_ -> Left ASINT(SUBINT(n,n_))+ All (HAVL l _) (HAVL r _) -> Right (l,r)++-- n > 0 !!+-- N.B Never returns a result of form (ALL lhavl rhavl) where lhavl is empty+splitR :: UINT -> AVL e -> UINT -> SplitResult e+splitR n E _ = More n+splitR n (N l e r) h = splitR_ n l DECINT2(h) e r DECINT1(h)+splitR n (Z l e r) h = splitR_ n l DECINT1(h) e r DECINT1(h)+splitR n (P l e r) h = splitR_ n l DECINT1(h) e r DECINT2(h)++-- n > 0 !!+-- N.B Never returns a result of form (ALL lhavl rhavl) where lhavl is empty+splitR_ :: UINT -> AVL e -> UINT -> e -> AVL e -> UINT -> SplitResult e+splitR_ n l hl e r hr =+ case splitR n r hr of+ More L(0) -> let lhavl = pushRHAVL (HAVL l hl) e; rhavl = HAVL r hr+ in lhavl `seq` rhavl `seq` All lhavl rhavl+ More L(1) -> case l of+ E -> More L(0)+ _ -> let rhavl = pushLHAVL e (HAVL r hr)+ lhavl = HAVL l hl+ in lhavl `seq` rhavl `seq` All lhavl rhavl+ More n_ -> let sr = splitR DECINT1(n_) l hl+ in case sr of+ More _ -> sr+ All havl0 havl1 -> let havl1' = spliceHAVL havl1 e (HAVL r hr)+ in havl1' `seq` All havl0 havl1'+ All havl0 havl1 -> let havlO' = spliceHAVL (HAVL l hl) e havl0+ in havlO' `seq` All havlO' havl1+-----------------------------------------------------------------------+------------------------- splitAtR Ends Here --------------------------+-----------------------------------------------------------------------++-- Local Datatype for results of take/drop operations.+data TakeResult e = AllTR (HAVL e) -- The resulting Tree+ | MoreTR {-# UNPACK #-} !UINT -- No of tree elements still required (>=0!!)++-- | This is a simplified version of 'splitAtL' which does not return the remaining tree.+-- The 'Int' argument n (n >= 0) specifies the number of elements to take (from the left).+-- This function raises an error if n is negative.+--+-- If the tree size is greater than n the result is (Right l) where l contains+-- the leftmost n elements.+--+-- If the tree size is less than or equal to n then the result is (Left s), where s is tree size.+--+-- An empty tree will always yield a result of (Left 0).+--+-- Complexity: O(n)+takeL :: Int -> AVL e -> Either Int (AVL e)+takeL n _ | n < 0 = error "takeL: Negative argument."+takeL 0 E = Left 0 -- Treat this case specially+takeL 0 _ = Right E+takeL ASINT(n) t = case takeL_ n t L(0) of -- Tree Heights are relative!!+ MoreTR n_ -> Left ASINT(SUBINT(n,n_))+ AllTR (HAVL t' _) -> Right t'++-- n > 0 !!+takeL_ :: UINT -> AVL e -> UINT -> TakeResult e+takeL_ n E _ = MoreTR n+takeL_ n (N l e r) h = takeL__ n l DECINT2(h) e r DECINT1(h)+takeL_ n (Z l e r) h = takeL__ n l DECINT1(h) e r DECINT1(h)+takeL_ n (P l e r) h = takeL__ n l DECINT1(h) e r DECINT2(h)++-- n > 0 !!+takeL__ :: UINT -> AVL e -> UINT -> e -> AVL e -> UINT -> TakeResult e+takeL__ n l hl e r hr =+ let takel = takeL_ n l hl+ in case takel of+ MoreTR L(0) -> let lhavl = HAVL l hl+ in lhavl `seq` AllTR lhavl+ MoreTR L(1) -> case r of+ E -> MoreTR L(0)+ _ -> let lhavl = pushRHAVL (HAVL l hl) e+ in lhavl `seq` AllTR lhavl+ MoreTR n_ -> let taker = takeL_ DECINT1(n_) r hr+ in case taker of+ AllTR havl0 -> let havl0' = spliceHAVL (HAVL l hl) e havl0+ in havl0' `seq` AllTR havl0'+ _ -> taker+ _ -> takel+-----------------------------------------------------------------------+-------------------------- takeL Ends Here ----------------------------+-----------------------------------------------------------------------++-- | This is a simplified version of 'splitAtR' which does not return the remaining tree.+-- The 'Int' argument n (n >= 0) specifies the number of elements to take (from the right).+-- This function raises an error if n is negative.+--+-- If the tree size is greater than n the result is (Right r) where r contains+-- the rightmost n elements.+--+-- If the tree size is less than or equal to n then the result is (Left s), where s is tree size.+--+-- An empty tree will always yield a result of (Left 0).+--+-- Complexity: O(n)+takeR :: Int -> AVL e -> Either Int (AVL e)+takeR n _ | n < 0 = error "takeR: Negative argument."+takeR 0 E = Left 0 -- Treat this case specially+takeR 0 _ = Right E+takeR ASINT(n) t = case takeR_ n t L(0) of -- Tree Heights are relative!!+ MoreTR n_ -> Left ASINT(SUBINT(n,n_))+ AllTR (HAVL t' _) -> Right t'++-- n > 0 !!+takeR_ :: UINT -> AVL e -> UINT -> TakeResult e+takeR_ n E _ = MoreTR n+takeR_ n (N l e r) h = takeR__ n l DECINT2(h) e r DECINT1(h)+takeR_ n (Z l e r) h = takeR__ n l DECINT1(h) e r DECINT1(h)+takeR_ n (P l e r) h = takeR__ n l DECINT1(h) e r DECINT2(h)++-- n > 0 !!+takeR__ :: UINT -> AVL e -> UINT -> e -> AVL e -> UINT -> TakeResult e+takeR__ n l hl e r hr =+ let taker = takeR_ n r hr+ in case taker of+ MoreTR L(0) -> let rhavl = HAVL r hr+ in rhavl `seq` AllTR rhavl+ MoreTR L(1) -> case l of+ E -> MoreTR L(0)+ _ -> let rhavl = pushLHAVL e (HAVL r hr)+ in rhavl `seq` AllTR rhavl+ MoreTR n_ -> let takel = takeR_ DECINT1(n_) l hl+ in case takel of+ AllTR havl0 -> let havl0' = spliceHAVL havl0 e (HAVL r hr)+ in havl0' `seq` AllTR havl0'+ _ -> takel+ _ -> taker+-----------------------------------------------------------------------+-------------------------- takeR Ends Here ----------------------------+-----------------------------------------------------------------------++-- | This is a simplified version of 'splitAtL' which returns the remaining tree only (rightmost elements).+-- This function raises an error if n is negative.+--+-- If the tree size is greater than n the result is (Right r) where r contains+-- the remaining elements (r will be non-empty).+--+-- If the tree size is less than or equal to n then the result is (Left s), where s is tree size.+--+-- An empty tree will always yield a result of (Left 0).+--+-- Complexity: O(n)+dropL :: Int -> AVL e -> Either Int (AVL e)+dropL n _ | n < 0 = error "dropL: Negative argument."+dropL 0 E = Left 0 -- Treat this case specially+dropL 0 t = Right t+dropL ASINT(n) t = case dropL_ n t L(0) of -- Tree Heights are relative!!+ MoreTR n_ -> Left ASINT(SUBINT(n,n_))+ AllTR (HAVL r _) -> Right r++-- n > 0 !!+-- N.B Never returns a result of form (AllTR rhavl) where rhavl is empty+dropL_ :: UINT -> AVL e -> UINT -> TakeResult e+dropL_ n E _ = MoreTR n+dropL_ n (N l e r) h = dropL__ n l DECINT2(h) e r DECINT1(h)+dropL_ n (Z l e r) h = dropL__ n l DECINT1(h) e r DECINT1(h)+dropL_ n (P l e r) h = dropL__ n l DECINT1(h) e r DECINT2(h)++-- n > 0 !!+-- N.B Never returns a result of form (AllTR rhavl) where rhavl is empty+dropL__ :: UINT -> AVL e -> UINT -> e -> AVL e -> UINT -> TakeResult e+dropL__ n l hl e r hr =+ case dropL_ n l hl of+ MoreTR L(0) -> let rhavl = pushLHAVL e (HAVL r hr)+ in rhavl `seq` AllTR rhavl+ MoreTR L(1) -> case r of+ E -> MoreTR L(0)+ _ -> let rhavl = HAVL r hr in rhavl `seq` AllTR rhavl+ MoreTR n_ -> dropL_ DECINT1(n_) r hr+ AllTR havl1 -> let havl1' = spliceHAVL havl1 e (HAVL r hr)+ in havl1' `seq` AllTR havl1'+-----------------------------------------------------------------------+--------------------------- dropL Ends Here ---------------------------+-----------------------------------------------------------------------++-- | This is a simplified version of 'splitAtR' which returns the remaining tree only (leftmost elements).+-- This function raises an error if n is negative.+--+-- If the tree size is greater than n the result is (Right l) where l contains+-- the remaining elements (l will be non-empty).+--+-- If the tree size is less than or equal to n then the result is (Left s), where s is tree size.+--+-- An empty tree will always yield a result of (Left 0).+--+-- Complexity: O(n)+dropR :: Int -> AVL e -> Either Int (AVL e)+dropR n _ | n < 0 = error "dropL: Negative argument."+dropR 0 E = Left 0 -- Treat this case specially+dropR 0 t = Right t+dropR ASINT(n) t = case dropR_ n t L(0) of -- Tree Heights are relative!!+ MoreTR n_ -> Left ASINT(SUBINT(n,n_))+ AllTR (HAVL l _) -> Right l++-- n > 0 !!+-- N.B Never returns a result of form (AllTR lhavl) where lhavl is empty+dropR_ :: UINT -> AVL e -> UINT -> TakeResult e+dropR_ n E _ = MoreTR n+dropR_ n (N l e r) h = dropR__ n l DECINT2(h) e r DECINT1(h)+dropR_ n (Z l e r) h = dropR__ n l DECINT1(h) e r DECINT1(h)+dropR_ n (P l e r) h = dropR__ n l DECINT1(h) e r DECINT2(h)++-- n > 0 !!+-- N.B Never returns a result of form (AllTR lhavl) where lhavl is empty+dropR__ :: UINT -> AVL e -> UINT -> e -> AVL e -> UINT -> TakeResult e+dropR__ n l hl e r hr =+ case dropR_ n r hr of+ MoreTR L(0) -> let lhavl = pushRHAVL (HAVL l hl) e+ in lhavl `seq` AllTR lhavl+ MoreTR L(1) -> case l of+ E -> MoreTR L(0)+ _ -> let lhavl = HAVL l hl in lhavl `seq` AllTR lhavl+ MoreTR n_ -> dropR_ DECINT1(n_) l hl+ AllTR havl0 -> let havl0' = spliceHAVL (HAVL l hl) e havl0+ in havl0' `seq` AllTR havl0'+-----------------------------------------------------------------------+--------------------------- dropR Ends Here ---------------------------+-----------------------------------------------------------------------+++-- Local Datatype for results of span operations.+data SpanResult e = Some (HAVL e) (HAVL e) -- Two tree/height pairs. Non Strict!!+ | TheLot -- The Lot satisfied++-- | Span an AVL tree from the left, using the supplied predicate. This function returns+-- a pair of trees (l,r), where l contains the leftmost consecutive elements which+-- satisfy the predicate. The leftmost element of r (if any) is the first to fail+-- the predicate. Either of the resulting trees may be empty. Element ordering is preserved.+--+-- Complexity: O(n), where n is the size of l.+spanL :: (e -> Bool) -> AVL e -> (AVL e, AVL e)+spanL p t = case spanIt t L(0) of -- Tree heights are relative+ TheLot -> (t, E) -- All satisfied+ Some (HAVL l _) (HAVL r _) -> (l, r) -- Some satisfied+ where+ spanIt E _ = TheLot+ spanIt (N l e r) h = spanIt_ l DECINT2(h) e r DECINT1(h)+ spanIt (Z l e r) h = spanIt_ l DECINT1(h) e r DECINT1(h)+ spanIt (P l e r) h = spanIt_ l DECINT1(h) e r DECINT2(h)+ -- N.B: Never Returns (Some _ (HAVL E _)) (== TheLot)+ spanIt_ l hl e r hr =+ case spanIt l hl of+ Some havl0 havl1 -> let havl1_ = spliceHAVL havl1 e (HAVL r hr)+ in havl1_ `seq` Some havl0 havl1_+ TheLot -> if p e+ then let spanItr = spanIt r hr+ in case spanItr of+ Some havl0 havl1 -> let havl0_ = spliceHAVL (HAVL l hl) e havl0+ in havl0_ `seq` Some havl0_ havl1+ _ -> spanItr+ else let rhavl = pushLHAVL e (HAVL r hr)+ lhavl = HAVL l hl+ in lhavl `seq` rhavl `seq` Some lhavl rhavl+-----------------------------------------------------------------------+--------------------------- spanL Ends Here ---------------------------+-----------------------------------------------------------------------++-- | Span an AVL tree from the right, using the supplied predicate. This function returns+-- a pair of trees (l,r), where r contains the rightmost consecutive elements which+-- satisfy the predicate. The rightmost element of l (if any) is the first to fail+-- the predicate. Either of the resulting trees may be empty. Element ordering is preserved.+--+-- Complexity: O(n), where n is the size of r.+spanR :: (e -> Bool) -> AVL e -> (AVL e, AVL e)+spanR p t = case spanIt t L(0) of -- Tree heights are relative+ TheLot -> (E, t) -- All satisfied+ Some (HAVL l _) (HAVL r _) -> (l, r) -- Some satisfied+ where+ spanIt E _ = TheLot+ spanIt (N l e r) h = spanIt_ l DECINT2(h) e r DECINT1(h)+ spanIt (Z l e r) h = spanIt_ l DECINT1(h) e r DECINT1(h)+ spanIt (P l e r) h = spanIt_ l DECINT1(h) e r DECINT2(h)+ -- N.B: Never Returns (Some (HAVL E _) _) (== TheLot)+ spanIt_ l hl e r hr =+ case spanIt r hr of+ Some havl0 havl1 -> let havl0_ = spliceHAVL (HAVL l hl) e havl0+ in havl0_ `seq` Some havl0_ havl1+ TheLot -> if p e+ then let spanItl = spanIt l hl+ in case spanItl of+ Some havl0 havl1 -> let havl1_ = spliceHAVL havl1 e (HAVL r hr)+ in havl1_ `seq` Some havl0 havl1_+ _ -> spanItl+ else let lhavl = pushRHAVL (HAVL l hl) e+ rhavl = HAVL r hr+ in lhavl `seq` rhavl `seq` Some lhavl rhavl+-----------------------------------------------------------------------+--------------------------- spanR Ends Here ---------------------------+-----------------------------------------------------------------------++-- Local Datatype for results of takeWhile/DropWhile operations.+data TakeWhileResult e = SomeTW (HAVL e)+ | TheLotTW++-- | This is a simplified version of 'spanL' which does not return the remaining tree+-- The result is the leftmost consecutive sequence of elements which satisfy the+-- supplied predicate (which may be empty).+--+-- Complexity: O(n), where n is the size of the result.+takeWhileL :: (e -> Bool) -> AVL e -> AVL e+takeWhileL p t = case spanIt t L(0) of -- Tree heights are relative+ TheLotTW -> t -- All satisfied+ SomeTW (HAVL l _) -> l -- Some satisfied+ where+ spanIt E _ = TheLotTW+ spanIt (N l e r) h = spanIt_ l DECINT2(h) e r DECINT1(h)+ spanIt (Z l e r) h = spanIt_ l DECINT1(h) e r DECINT1(h)+ spanIt (P l e r) h = spanIt_ l DECINT1(h) e r DECINT2(h)+ spanIt_ l hl e r hr =+ let twl = spanIt l hl+ in case twl of+ TheLotTW -> if p e+ then let twr = spanIt r hr+ in case twr of+ SomeTW havl0 -> let havl0_ = spliceHAVL (HAVL l hl) e havl0+ in havl0_ `seq` SomeTW havl0_+ _ -> twr+ else let lhavl = HAVL l hl in lhavl `seq` SomeTW lhavl+ _ -> twl+-----------------------------------------------------------------------+------------------------- takeWhileL Ends Here ------------------------+-----------------------------------------------------------------------++-- | This is a simplified version of 'spanR' which does not return the remaining tree+-- The result is the rightmost consecutive sequence of elements which satisfy the+-- supplied predicate (which may be empty).+--+-- Complexity: O(n), where n is the size of the result.+takeWhileR :: (e -> Bool) -> AVL e -> AVL e+takeWhileR p t = case spanIt t L(0) of -- Tree heights are relative+ TheLotTW -> t -- All satisfied+ SomeTW (HAVL r _) -> r -- Some satisfied+ where+ spanIt E _ = TheLotTW+ spanIt (N l e r) h = spanIt_ l DECINT2(h) e r DECINT1(h)+ spanIt (Z l e r) h = spanIt_ l DECINT1(h) e r DECINT1(h)+ spanIt (P l e r) h = spanIt_ l DECINT1(h) e r DECINT2(h)+ spanIt_ l hl e r hr =+ let twr = spanIt r hr+ in case twr of+ TheLotTW -> if p e+ then let twl = spanIt l hl+ in case twl of+ SomeTW havl1 -> let havl1_ = spliceHAVL havl1 e (HAVL r hr)+ in havl1_ `seq` SomeTW havl1_+ _ -> twl+ else let rhavl = HAVL r hr in rhavl `seq` SomeTW rhavl+ _ -> twr+-----------------------------------------------------------------------+------------------------- takeWhileR Ends Here ------------------------+-----------------------------------------------------------------------++-- | This is a simplified version of 'spanL' which does not return the tree containing+-- the elements which satisfy the supplied predicate.+-- The result is a tree whose leftmost element is the first to fail the predicate, starting from+-- the left (which may be empty).+--+-- Complexity: O(n), where n is the number of elements dropped.+dropWhileL :: (e -> Bool) -> AVL e -> AVL e+dropWhileL p t = case spanIt t L(0) of -- Tree heights are relative+ TheLotTW -> E -- All satisfied+ SomeTW (HAVL r _) -> r -- Some satisfied+ where+ spanIt E _ = TheLotTW+ spanIt (N l e r) h = spanIt_ l DECINT2(h) e r DECINT1(h)+ spanIt (Z l e r) h = spanIt_ l DECINT1(h) e r DECINT1(h)+ spanIt (P l e r) h = spanIt_ l DECINT1(h) e r DECINT2(h)+ spanIt_ l hl e r hr =+ case spanIt l hl of+ SomeTW havl1 -> let havl1_ = spliceHAVL havl1 e (HAVL r hr)+ in havl1_ `seq` SomeTW havl1_+ TheLotTW -> if p e+ then spanIt r hr+ else let rhavl = pushLHAVL e (HAVL r hr)+ in rhavl `seq` SomeTW rhavl+-----------------------------------------------------------------------+---------------------- dropWhileL Ends Here ---------------------------+-----------------------------------------------------------------------++-- | This is a simplified version of 'spanR' which does not return the tree containing+-- the elements which satisfy the supplied predicate.+-- The result is a tree whose rightmost element is the first to fail the predicate, starting from+-- the right (which may be empty).+--+-- Complexity: O(n), where n is the number of elements dropped.+dropWhileR :: (e -> Bool) -> AVL e -> AVL e+dropWhileR p t = case spanIt t L(0) of -- Tree heights are relative+ TheLotTW -> E -- All satisfied+ SomeTW (HAVL l _) -> l -- Some satisfied+ where+ spanIt E _ = TheLotTW+ spanIt (N l e r) h = spanIt_ l DECINT2(h) e r DECINT1(h)+ spanIt (Z l e r) h = spanIt_ l DECINT1(h) e r DECINT1(h)+ spanIt (P l e r) h = spanIt_ l DECINT1(h) e r DECINT2(h)+ spanIt_ l hl e r hr =+ case spanIt r hr of+ SomeTW havl0 -> let havl0_ = spliceHAVL (HAVL l hl) e havl0+ in havl0_ `seq` SomeTW havl0_+ TheLotTW -> if p e+ then spanIt l hl+ else let lhavl = pushRHAVL (HAVL l hl) e+ in lhavl `seq` SomeTW lhavl+-----------------------------------------------------------------------+---------------------- dropWhileR Ends Here ---------------------------+-----------------------------------------------------------------------+++-- | Rotate an AVL tree one place left. This function pops the leftmost element and pushes into+-- the rightmost position. An empty tree yields an empty tree.+--+-- Complexity: O(log n)+rotateL :: AVL e -> AVL e+rotateL E = E+rotateL (N l e r) = case popLN l e r of UBT2(e_,t) -> pushR t e_+rotateL (Z l e r) = case popLZ l e r of UBT2(e_,t) -> pushR t e_+rotateL (P l e r) = case popLP l e r of UBT2(e_,t) -> pushR t e_++-- | Rotate an AVL tree one place right. This function pops the rightmost element and pushes into+-- the leftmost position. An empty tree yields an empty tree.+--+-- Complexity: O(log n)+rotateR :: AVL e -> AVL e+rotateR E = E+rotateR (N l e r) = case popRN l e r of UBT2(t,e_) -> pushL e_ t+rotateR (Z l e r) = case popRZ l e r of UBT2(t,e_) -> pushL e_ t+rotateR (P l e r) = case popRP l e r of UBT2(t,e_) -> pushL e_ t++-- | Similar to 'rotateL', but returns the rotated element. This function raises an error if+-- applied to an empty tree.+--+-- Complexity: O(log n)+popRotateL :: AVL e -> (e, AVL e)+popRotateL E = error "popRotateL: Empty tree."+popRotateL (N l e r) = case popLN l e r of UBT2(e_,t) -> popRotateL' e_ t+popRotateL (Z l e r) = case popLZ l e r of UBT2(e_,t) -> popRotateL' e_ t+popRotateL (P l e r) = case popLP l e r of UBT2(e_,t) -> popRotateL' e_ t+popRotateL' :: e -> AVL e -> (e, AVL e)+popRotateL' e t = let t' = pushR t e in t' `seq` (e,t')++-- | Similar to 'rotateR', but returns the rotated element. This function raises an error if+-- applied to an empty tree.+--+-- Complexity: O(log n)+popRotateR :: AVL e -> (AVL e, e)+popRotateR E = error "popRotateR: Empty tree."+popRotateR (N l e r) = case popRN l e r of UBT2(t,e_) -> popRotateR' t e_+popRotateR (Z l e r) = case popRZ l e r of UBT2(t,e_) -> popRotateR' t e_+popRotateR (P l e r) = case popRP l e r of UBT2(t,e_) -> popRotateR' t e_+popRotateR' :: AVL e -> e -> (AVL e, e)+popRotateR' t e = let t' = pushL e t in t' `seq` (t',e)+++-- | Rotate an AVL tree left by n places. If s is the size of the tree then ordinarily n+-- should be in the range [0..s-1]. However, this function will deliver a correct result+-- for any n (n\<0 or n\>=s), the actual rotation being given by (n \`mod\` s) in such cases.+-- The result of rotating an empty tree is an empty tree.+--+-- Complexity: O(n)+rotateByL :: AVL e -> Int -> AVL e+rotateByL t ASINT(n) = case COMPAREUINT n L(0) of+ LT -> rotateByR__ t NEGATE(n)+ EQ -> t+ GT -> rotateByL__ t n+-- n>=0!!+{-# INLINE rotateByL_ #-}+rotateByL_ :: AVL e -> UINT -> AVL e+rotateByL_ t L(0) = t+rotateByL_ t n = rotateByL__ t n+-- n>0!!+rotateByL__ :: AVL e -> UINT -> AVL e+rotateByL__ E _ = E+rotateByL__ t n = case splitL n t L(0) of -- Tree Heights are relative!!+ More L(0) -> t+ More m -> let s = SUBINT(n,m) -- Actual size of tree, > 0!!+ n_ = _MODULO_(n,s) -- Actual shift required, 0..s-1+ in if ADDINT(n_,n_) LEQ s+ then rotateByL_ t n_ -- n_ may be 0 !!+ else rotateByR__ t SUBINT(s,n_) -- (s-n_) can't be 0+ All (HAVL l hl) (HAVL r hr) -> joinH' r hr l hl+++-- | Rotate an AVL tree right by n places. If s is the size of the tree then ordinarily n+-- should be in the range [0..s-1]. However, this function will deliver a correct result+-- for any n (n\<0 or n\>=s), the actual rotation being given by (n \`mod\` s) in such cases.+-- The result of rotating an empty tree is an empty tree.+--+-- Complexity: O(n)+rotateByR :: AVL e -> Int -> AVL e+rotateByR t ASINT(n) = case COMPAREUINT n L(0) of+ LT -> rotateByL__ t NEGATE(n)+ EQ -> t+ GT -> rotateByR__ t n+-- n>=0!!+{-# INLINE rotateByR_ #-}+rotateByR_ :: AVL e -> UINT -> AVL e+rotateByR_ t L(0) = t+rotateByR_ t n = rotateByR__ t n+-- n>0!!+rotateByR__ :: AVL e -> UINT -> AVL e+rotateByR__ E _ = E+rotateByR__ t n = case splitR n t L(0) of -- Tree Heights are relative!!+ More L(0) -> t+ More m -> let s = SUBINT(n,m) -- Actual size of tree, > 0!!+ n_ = _MODULO_(n,s) -- Actual shift required, 0..s-1+ in if ADDINT(n_,n_) LEQ s+ then rotateByR_ t n_ -- n_ may be 0 !!+ else rotateByL__ t SUBINT(s,n_) -- (s-n_) can_t be 0+ All (HAVL l hl) (HAVL r hr) -> joinH' r hr l hl+++-- | Divide a sorted AVL tree into left and right sorted trees (l,r), such that l contains all the+-- elements less than or equal to according to the supplied selector and r contains all the elements greater than+-- according to the supplied selector.+--+-- Complexity: O(log n)+genForkL :: (e -> Ordering) -> AVL e -> (AVL e, AVL e)+genForkL c avl = let (HAVL l _,HAVL r _) = genForkL_ L(0) avl -- Tree heights are relative+ in (l,r)+ where+ genForkL_ h E = (HAVL E h, HAVL E h)+ genForkL_ h (N l e r) = genForkL__ l DECINT2(h) e r DECINT1(h)+ genForkL_ h (Z l e r) = genForkL__ l DECINT1(h) e r DECINT1(h)+ genForkL_ h (P l e r) = genForkL__ l DECINT1(h) e r DECINT2(h)+ genForkL__ l hl e r hr = case c e of+ -- Current element > pivot, so goes in right half+ LT -> let (havl0,havl1) = genForkL_ hl l+ havl1_ = spliceHAVL havl1 e (HAVL r hr)+ in havl1_ `seq` (havl0, havl1_)+ -- Current element = pivot, so goes in left half and stop here+ EQ -> let lhavl = pushRHAVL (HAVL l hl) e+ rhavl = HAVL r hr+ in lhavl `seq` rhavl `seq` (lhavl,rhavl)+ -- Current element < pivot, so goes in left half+ GT -> let (havl0,havl1) = genForkL_ hr r+ havl0_ = spliceHAVL (HAVL l hl) e havl0+ in havl0_ `seq` (havl0_, havl1)++-- | Divide a sorted AVL tree into left and right sorted trees (l,r), such that l contains all the+-- elements less than supplied selector and r contains all the elements greater than or equal to the+-- supplied selector.+--+-- Complexity: O(log n)+genForkR :: (e -> Ordering) -> AVL e -> (AVL e, AVL e)+genForkR c avl = let (HAVL l _,HAVL r _) = genForkR_ L(0) avl -- Tree heights are relative+ in (l,r)+ where+ genForkR_ h E = (HAVL E h, HAVL E h)+ genForkR_ h (N l e r) = genForkR__ l DECINT2(h) e r DECINT1(h)+ genForkR_ h (Z l e r) = genForkR__ l DECINT1(h) e r DECINT1(h)+ genForkR_ h (P l e r) = genForkR__ l DECINT1(h) e r DECINT2(h)+ genForkR__ l hl e r hr = case c e of+ -- Current element > pivot, so goes in right half+ LT -> let (havl0,havl1) = genForkR_ hl l+ havl1_ = spliceHAVL havl1 e (HAVL r hr)+ in havl1_ `seq` (havl0, havl1_)+ -- Current element = pivot, so goes in right half and stop here+ EQ -> let rhavl = pushLHAVL e (HAVL r hr)+ lhavl = HAVL l hl+ in lhavl `seq` rhavl `seq` (lhavl, rhavl)+ -- Current element < pivot, so goes in left half+ GT -> let (havl0,havl1) = genForkR_ hr r+ havl0_ = spliceHAVL (HAVL l hl) e havl0+ in havl0_ `seq` (havl0_, havl1)+++-- | Similar to 'genForkL' and 'genForkR', but returns any equal element found (instead of+-- incorporating it into the left or right tree results respectively).+--+-- Complexity: O(log n)+genFork :: (e -> COrdering a) -> AVL e -> (AVL e, Maybe a, AVL e)+genFork c avl = let (HAVL l _, mba, HAVL r _) = genFork_ L(0) avl -- Tree heights are relative+ in (l,mba,r)+ where+ genFork_ h E = (HAVL E h, Nothing, HAVL E h)+ genFork_ h (N l e r) = genFork__ l DECINT2(h) e r DECINT1(h)+ genFork_ h (Z l e r) = genFork__ l DECINT1(h) e r DECINT1(h)+ genFork_ h (P l e r) = genFork__ l DECINT1(h) e r DECINT2(h)+ genFork__ l hl e r hr = case c e of+ -- Current element > pivot+ Lt -> let (havl0,mba,havl1) = genFork_ hl l+ havl1_ = spliceHAVL havl1 e (HAVL r hr)+ in havl1_ `seq` (havl0, mba, havl1_)+ -- Current element = pivot+ Eq a -> let lhavl = HAVL l hl+ rhavl = HAVL r hr+ in lhavl `seq` rhavl `seq` (lhavl, Just a, rhavl)+ -- Current element < pivot+ Gt -> let (havl0,mba,havl1) = genFork_ hr r+ havl0_ = spliceHAVL (HAVL l hl) e havl0+ in havl0_ `seq` (havl0_, mba, havl1)++-- | This is a simplified version of 'genForkL' which returns a sorted tree containing+-- only those elements which are less than or equal to according to the supplied selector.+-- This function also has the synonym 'genDropGT'.+--+-- Complexity: O(log n)+genTakeLE :: (e -> Ordering) -> AVL e -> AVL e+genTakeLE c avl = let HAVL l _ = genForkL_ L(0) avl -- Tree heights are relative+ in l+ where+ genForkL_ h E = HAVL E h+ genForkL_ h (N l e r) = genForkL__ l DECINT2(h) e r DECINT1(h)+ genForkL_ h (Z l e r) = genForkL__ l DECINT1(h) e r DECINT1(h)+ genForkL_ h (P l e r) = genForkL__ l DECINT1(h) e r DECINT2(h)+ genForkL__ l hl e r hr = case c e of+ LT -> genForkL_ hl l+ EQ -> pushRHAVL (HAVL l hl) e+ GT -> let havl0 = genForkL_ hr r+ in spliceHAVL (HAVL l hl) e havl0+++-- | A synonym for 'genTakeLE'.+--+-- Complexity: O(log n)+{-# INLINE genDropGT #-}+genDropGT :: (e -> Ordering) -> AVL e -> AVL e+genDropGT = genTakeLE++-- | This is a simplified version of 'genForkL' which returns a sorted tree containing+-- only those elements which are greater according to the supplied selector.+-- This function also has the synonym 'genDropLE'.+--+-- Complexity: O(log n)+genTakeGT :: (e -> Ordering) -> AVL e -> AVL e+genTakeGT c avl = let HAVL r _ = genForkL_ L(0) avl -- Tree heights are relative+ in r+ where+ genForkL_ h E = HAVL E h+ genForkL_ h (N l e r) = genForkL__ l DECINT2(h) e r DECINT1(h)+ genForkL_ h (Z l e r) = genForkL__ l DECINT1(h) e r DECINT1(h)+ genForkL_ h (P l e r) = genForkL__ l DECINT1(h) e r DECINT2(h)+ genForkL__ l hl e r hr = case c e of+ LT -> let havl1 = genForkL_ hl l+ in spliceHAVL havl1 e (HAVL r hr)+ EQ -> HAVL r hr+ GT -> genForkL_ hr r++-- | A synonym for 'genTakeGT'.+--+-- Complexity: O(log n)+{-# INLINE genDropLE #-}+genDropLE :: (e -> Ordering) -> AVL e -> AVL e+genDropLE = genTakeGT++-- | This is a simplified version of 'genForkR' which returns a sorted tree containing+-- only those elements which are less than according to the supplied selector.+-- This function also has the synonym 'genDropGE'.+--+-- Complexity: O(log n)+genTakeLT :: (e -> Ordering) -> AVL e -> AVL e+genTakeLT c avl = let HAVL l _ = genForkL_ L(0) avl -- Tree heights are relative+ in l+ where+ genForkL_ h E = HAVL E h+ genForkL_ h (N l e r) = genForkL__ l DECINT2(h) e r DECINT1(h)+ genForkL_ h (Z l e r) = genForkL__ l DECINT1(h) e r DECINT1(h)+ genForkL_ h (P l e r) = genForkL__ l DECINT1(h) e r DECINT2(h)+ genForkL__ l hl e r hr = case c e of+ LT -> genForkL_ hl l+ EQ -> HAVL l hl+ GT -> let havl0 = genForkL_ hr r+ in spliceHAVL (HAVL l hl) e havl0+++-- | A synonym for 'genTakeLT'.+--+-- Complexity: O(log n)+{-# INLINE genDropGE #-}+genDropGE :: (e -> Ordering) -> AVL e -> AVL e+genDropGE = genTakeLT++-- | This is a simplified version of 'genForkR' which returns a sorted tree containing+-- only those elements which are greater or equal to according to the supplied selector.+-- This function also has the synonym 'genDropLT'.+--+-- Complexity: O(log n)+genTakeGE :: (e -> Ordering) -> AVL e -> AVL e+genTakeGE c avl = let HAVL r _ = genForkL_ L(0) avl -- Tree heights are relative+ in r+ where+ genForkL_ h E = HAVL E h+ genForkL_ h (N l e r) = genForkL__ l DECINT2(h) e r DECINT1(h)+ genForkL_ h (Z l e r) = genForkL__ l DECINT1(h) e r DECINT1(h)+ genForkL_ h (P l e r) = genForkL__ l DECINT1(h) e r DECINT2(h)+ genForkL__ l hl e r hr = case c e of+ LT -> let havl1 = genForkL_ hl l+ in spliceHAVL havl1 e (HAVL r hr)+ EQ -> pushLHAVL e (HAVL r hr)+ GT -> genForkL_ hr r++-- | A synonym for 'genTakeGE'.+--+-- Complexity: O(log n)+{-# INLINE genDropLT #-}+genDropLT :: (e -> Ordering) -> AVL e -> AVL e+genDropLT = genTakeGE+
+ Data/Tree/AVL/Test/AllTests.hs view
@@ -0,0 +1,1405 @@+{-# OPTIONS -fglasgow-exts #-}+-----------------------------------------------------------------------------+-- |+-- Module : Data.Tree.AVL.Test.AllTests+-- Copyright : (c) Adrian Hey 2004,2005,2006,2007+-- License : BSD3+--+-- Maintainer : http://homepages.nildram.co.uk/~ahey/em.png+-- Stability : unstable+-- Portability : portable+--+-- This module contains a large set of fairly comprehensive but extremely+-- time consuming tests of AVL tree functions (not based on QuickCheck).+--+-- They can all be run using 'allTests', or they can be run individually.+-----------------------------------------------------------------------------+module Data.Tree.AVL.Test.AllTests+(allTests+,testReadPath+,testIsBalanced+,testIsSorted+,testSize+,testClipSize+,testGenWrite+,testGenPush+,testPushL+,testPushR+,testGenDel+,testAssertDelL+,testAssertDelR+,testAssertPopL+,testPopHL+,testAssertPopR+,testGenAssertPop+,testFlatten+,testJoin+,testJoinHAVL+,testConcatAVL+,testFlatConcat+,testFoldrAVL+,testFoldrAVL'+,testFoldlAVL+,testFoldlAVL'+,testFoldr1AVL+,testFoldr1AVL'+,testFoldl1AVL+,testFoldl1AVL'+,testMapAccumLAVL+,testMapAccumRAVL+,testMapAccumLAVL'+,testMapAccumRAVL'+#ifdef __GLASGOW_HASKELL__+,testMapAccumLAVL''+,testMapAccumRAVL''+#endif+,testSplitAtL+,testFilterViaList+,testFilterAVL+,testMapMaybeViaList+,testMapMaybeAVL+,testTakeL+,testDropL+,testSplitAtR+,testTakeR+,testDropR+,testSpanL+,testTakeWhileL+,testDropWhileL+,testSpanR+,testTakeWhileR+,testDropWhileR+,testRotateL+,testRotateR+,testRotateByL+,testRotateByR+,testGenForkL+,testGenForkR+,testGenFork+,testGenTakeLE+,testGenTakeGT+,testGenTakeGE+,testGenTakeLT+,testGenUnion+,testGenUnionMaybe+,testGenIntersection+,testGenIntersectionMaybe+,testGenIntersectionAsListL+,testGenIntersectionMaybeAsListL+,testGenDifference+,testGenDifferenceMaybe+,testGenSymDifference+,testGenIsSubsetOf+,testGenIsSubsetOfBy+,testCompareHeight+,testShowReadEq+-- Zipper tests+,testGenOpenClose+,testDelClose+,testOpenLClose+,testOpenRClose+,testMoveL+,testMoveR+,testInsertL+,testInsertMoveL+,testInsertR+,testInsertMoveR+,testInsertTreeL+,testInsertTreeR+,testDelMoveL+,testDelMoveR+,testDelAllL+,testDelAllR+,testDelAllCloseL+,testDelAllIncCloseL+,testDelAllCloseR+,testDelAllIncCloseR+,testZipSize+,testGenTryOpenLE+,testGenTryOpenGE+,testGenOpenEither+,testBAVLtoZipper+) where++import Data.COrdering+import Data.Tree.AVLX++import Data.List(insert,mapAccumL,mapAccumR)+import System.Exit(exitFailure)++#ifdef __GLASGOW_HASKELL__+import GHC.Base+#include "ghcdefs.h"+#else+#include "h98defs.h"+#endif+++-- import Debug.Trace(trace)+-- import System.IO.Unsafe(unsafePerformIO)++-- | Run every test in this module (takes a very long time).+allTests :: IO ()+allTests =+ do testReadPath+ testIsBalanced+ testIsSorted+ testSize+ testClipSize+ testGenWrite+ testGenPush+ testPushL+ testPushR+ testGenDel+ testAssertDelL+ testAssertDelR+ testAssertPopL+ testPopHL+ testAssertPopR+ testGenAssertPop+ testFlatten+ testJoin+ testJoinHAVL+ testConcatAVL+ testFlatConcat+ testFoldrAVL+ testFoldrAVL'+ testFoldlAVL+ testFoldlAVL'+ testFoldr1AVL+ testFoldr1AVL'+ testFoldl1AVL+ testFoldl1AVL'+ testMapAccumLAVL+ testMapAccumRAVL+ testMapAccumLAVL'+ testMapAccumRAVL'+#ifdef __GLASGOW_HASKELL__+ testMapAccumLAVL''+ testMapAccumRAVL''+#endif+ testSplitAtL+ testFilterViaList+ testFilterAVL+ testMapMaybeViaList+ testMapMaybeAVL+ testTakeL+ testDropL+ testSplitAtR+ testTakeR+ testDropR+ testSpanL+ testTakeWhileL+ testDropWhileL+ testSpanR+ testTakeWhileR+ testDropWhileR+ testRotateL+ testRotateR+ testRotateByL+ testRotateByR+ testGenForkL+ testGenForkR+ testGenFork+ testGenTakeLE+ testGenTakeGT+ testGenTakeGE+ testGenTakeLT+ testGenUnion+ testGenUnionMaybe+ testGenIntersection+ testGenIntersectionMaybe+ testGenIntersectionAsListL+ testGenIntersectionMaybeAsListL+ testGenDifference+ testGenDifferenceMaybe+ testGenSymDifference+ testGenIsSubsetOf+ testGenIsSubsetOfBy+ testCompareHeight+ testShowReadEq+-- Zipper tests+ testGenOpenClose+ testDelClose+ testOpenLClose+ testOpenRClose+ testMoveL+ testMoveR+ testInsertL+ testInsertMoveL+ testInsertR+ testInsertMoveR+ testInsertTreeL+ testInsertTreeR+ testDelMoveL+ testDelMoveR+ testDelAllL+ testDelAllR+ testDelAllCloseL+ testDelAllIncCloseL+ testDelAllCloseR+ testDelAllIncCloseR+ testZipSize+ testGenTryOpenLE+ testGenTryOpenGE+ testGenOpenEither+ testBAVLtoZipper+++-- | Test isBalanced is capable of failing for a few non-AVL trees.+testIsBalanced :: IO ()+testIsBalanced = do title "isBalanced"+ if or [isBalanced t | t <- nonAVLs] then failed else passed+ where nonAVLs :: [AVL Int]+ nonAVLs = [Z E 0 (Z E 0 E)+ ,Z (Z E 0 E) 0 E+ ,N E 0 E+ ,P E 0 E+ ]++-- | Test isSorted is capable of failing for a few non-sorted trees.+testIsSorted :: IO ()+testIsSorted = do title "isSorted"+ if or [isSorted compare (asTreeL l) | l <- nonSorted] then failed else passed+ where nonSorted = ["AA","BA"+ ,"AAA","ABA","ABB","AAB"+ ,"AABC","ACBA","ABCC","ABBB","AAAB"+ ]++-- | Test size function+testSize :: IO ()+testSize = do title "size"+ exhaustiveTest test (take 6 allAVL)+ where test _ s t = size t == s++-- | Test clipSize function+testClipSize :: IO ()+testClipSize = do title "clipSize"+ exhaustiveTest test (take 6 allAVL)+ where test _ s t = all (== Nothing) [clipSize n t | n <- [0..s-1 ]] &&+ all (== Just s ) [clipSize n t | n <- [s..s+10]]++-- | Test genWrite function+testGenWrite :: IO ()+testGenWrite = do title "genWrite"+ exhaustiveTest test (take 5 allNonEmptyAVL)+ where test _ s t = all test_ [0..s-1]+ where test_ n = let t_ = genWrite (withCC' (+) n) t+ in isBalanced t_ && (asListL t_ == [0..n-1]++(n+n):[n+1..s-1])+++-- | Test genPush function+testGenPush :: IO ()+-- Also exercises: mapAVL' and genContains+testGenPush = do title "genPush"+ exhaustiveTest test (take 6 allAVL)+ where test h s t = all oddTest odds && all evenTest evens+ where t_ = mapAVL' (\n -> 2*n+1) t -- t_ elements are odd, 1,3..2*s-1+ odds = [1,3..2*s-1]+ evens = [0,2..2*s ]+ oddTest n = let t__ = push n t_ -- Should yield identical trees+ s__ = size t__+ h__ = ASINT(height t__)+ in (s__ == s) && (isSortedOK compare t__) && (h__== h)+ evenTest n = let t__ = push n t_+ s__ = size t__+ h__ = ASINT(height t__)+ in (s__ == s+1) && (isSortedOK compare t__) && (h__-h <= 1) && (t__ `contains` n)+ push e = genPush (sndCC e) e+ contains avl e = genContains avl (compare e)++-- | Test genDel function+testGenDel :: IO ()+testGenDel = do title "genDel"+ exhaustiveTest test (take 5 allNonEmptyAVL)+ where test h s t = all oddTest odds && all evenTest evens+ where t_ = mapAVL' (\n -> 2*n+1) t -- t_ elements are odd, 1,3..2*s-1+ odds = [1,3..2*s-1]+ evens = [0,2..2*s ]+ oddTest n = let t__ = del n t_+ in case checkHeight t__ of+ Just h_ -> (h-h_<=1) && (insert n (asListL t__) == odds)+ Nothing -> False+ evenTest n = let t__ = del n t_+ in case checkHeight t__ of+ Just h_ -> (h==h_) && (asListL t__ == odds)+ Nothing -> False+ del e = genDel (compare e)++-- | Test genAssertPop function+testGenAssertPop :: IO ()+testGenAssertPop =+ do title "genAssertPop"+ exhaustiveTest test (take 5 allNonEmptyAVL)+ where test h s t = all testElem elems+ where elems = [0,1..s-1]+ testElem n = let (n_,t_) = genAssertPop (fstCC n) t+ in case checkHeight t_ of+ Just h_ -> (h-h_<=1) && (insert n_ (asListL t_) == elems)+ Nothing -> False++-- | Test pushL function+-- Also exercises: asListL+testPushL :: IO ()+testPushL = do title "pushL"+ exhaustiveTest test (take 6 allAVL)+ where test h _ t = let t_ = 0 `pushL` t+ in case checkHeight t_ of+ Just h_ | (h_==h+1) || (h_==h) -> asListL t_ == (0 : asListL t)+ _ -> False++-- | Test pushR function+-- Also exercises: asListR+testPushR :: IO ()+testPushR = do title "pushR"+ exhaustiveTest test (take 6 allAVL)+ where test h s t = let t_ = t `pushR` s+ in case checkHeight t_ of+ Just h_ | (h_==h+1) || (h_==h) -> asListR t_ == (s : asListR t)+ _ -> False++-- | Test assertDelL function+-- Also exercises: asListL+testAssertDelL :: IO ()+testAssertDelL =+ do title "assertDelL"+ exhaustiveTest test (take 5 allNonEmptyAVL)+ where test h _ t = let t_ = assertDelL t+ in case checkHeight t_ of+ Just h_ | (h_==h-1) || (h_==h) -> asListL t_ == (tail $ asListL t)+ _ -> False++-- | Test delR function+-- Also exercises: asListR+testAssertDelR :: IO ()+testAssertDelR =+ do title "assertDelR"+ exhaustiveTest test (take 5 allNonEmptyAVL)+ where test h _ t = let t_ = assertDelR t+ in case checkHeight t_ of+ Just h_ | (h_==h-1) || (h_==h) -> asListR t_ == (tail $ asListR t)+ _ -> False++-- | Test assertPopL function+-- Also exercises: asListL+testAssertPopL :: IO ()+testAssertPopL =+ do title "assertPopL"+ exhaustiveTest test (take 5 allNonEmptyAVL)+ where test h _ t = let (v,t_) = assertPopL t+ in case checkHeight t_ of+ Just h_ | (h_==h-1) || (h_==h) -> (v : asListL t_) == asListL t+ _ -> False++-- | Test popHL function+-- This test can only be run if popHL and HAVL are not hidden.+-- However, popHL is exercised by indirectly by testConcatAVL anyway+testPopHL :: IO ()+testPopHL = do title "popHL"+ exhaustiveTest test (take 5 allNonEmptyAVL)+ where test _ _ t = let UBT3(v, t_,h) = popHL t+ in case checkHeight t_ of+ Just h_ | (h_== ASINT(h)) -> (v : asListL t_) == asListL t+ _ -> False+++-- | Test assertPopR function+-- Also exercises: asListR+testAssertPopR :: IO ()+testAssertPopR =+ do title "assertPopR"+ exhaustiveTest test (take 5 allNonEmptyAVL)+ where test h _ t = let (t_,v) = assertPopR t+ in case checkHeight t_ of+ Just h_ | (h_==h-1) || (h_==h) -> (v : asListR t_) == asListR t+ _ -> False++-- | Test flatten function+-- Also exercises: asListL,replicateAVL+testFlatten :: IO ()+testFlatten = do title "flatten"+ exhaustiveTest test (take 6 allAVL)+ where test _ _ t = let t_ = flatten t+ in isBalanced t_ && (asListL t == asListL t_)++-- | Test foldrAVL+testFoldrAVL :: IO ()+testFoldrAVL = do title "foldrAVL"+ exhaustiveTest test (take 6 allAVL)+ where test _ s t = foldrAVL (:) [] t == [0..s-1]+-- | Test foldrAVL'+testFoldrAVL' :: IO ()+testFoldrAVL' = do title "foldrAVL'"+ exhaustiveTest test (take 6 allAVL)+ where test _ s t = foldrAVL' (:) [] t == [0..s-1]+-- | Test foldlAVL+testFoldlAVL :: IO ()+testFoldlAVL = do title "foldlAVL"+ exhaustiveTest test (take 6 allAVL)+ where test _ s t = foldlAVL (flip (:)) [] t == [s-1,s-2..0]+-- | Test foldlAVL'+testFoldlAVL' :: IO ()+testFoldlAVL' = do title "foldlAVL'"+ exhaustiveTest test (take 6 allAVL)+ where test _ s t = foldlAVL' (flip (:)) [] t == [s-1,s-2..0]+-- | Test foldr1AVL+testFoldr1AVL :: IO ()+testFoldr1AVL = do title "foldr1AVL"+ exhaustiveTest test (take 5 allNonEmptyAVL)+ where test _ s t = foldr1AVL (-) t == foldr1 (-) [0..s-1]+-- | Test foldr1AVL'+testFoldr1AVL' :: IO ()+testFoldr1AVL' = do title "foldr1AVL'"+ exhaustiveTest test (take 5 allNonEmptyAVL)+ where test _ s t = foldr1AVL' (-) t == foldr1 (-) [0..s-1]+-- | Test foldl1AVL+testFoldl1AVL :: IO ()+testFoldl1AVL = do title "foldl1AVL"+ exhaustiveTest test (take 5 allNonEmptyAVL)+ where test _ s t = foldl1AVL (-) t == foldl1 (-) [0..s-1]+-- | Test foldl1AVL'+testFoldl1AVL' :: IO ()+testFoldl1AVL' = do title "foldl1AVL'"+ exhaustiveTest test (take 5 allNonEmptyAVL)+ where test _ s t = foldl1AVL' (-) t == foldl1 (-) [0..s-1]++-- | Test mapAccumLAVL+testMapAccumLAVL :: IO ()+testMapAccumLAVL = do title "mapAccumLAVL"+ exhaustiveTest test (take 6 allAVL)+ where test _ _ t = let (nt,t') = mapAccumLAVL f 0 t+ (nl,l ) = mapAccumL f 0 (asListL t)+ in (nt==nl) && ((asListL t') == l) && (isSortedOK compare t')+ f acc n = (acc+n,n+1)++-- | Test mapAccumRAVL+testMapAccumRAVL :: IO ()+testMapAccumRAVL = do title "mapAccumRAVL"+ exhaustiveTest test (take 6 allAVL)+ where test _ _ t = let (nt,t') = mapAccumRAVL f 0 t+ (nl,l ) = mapAccumR f 0 (asListL t)+ in (nt==nl) && ((asListL t') == l) && (isSortedOK compare t')+ f acc n = (acc+n,n+1)++-- | Test mapAccumLAVL'+testMapAccumLAVL' :: IO ()+testMapAccumLAVL' = do title "mapAccumLAVL'"+ exhaustiveTest test (take 6 allAVL)+ where test _ _ t = let (nt,t') = mapAccumLAVL' f 0 t+ (nl,l ) = mapAccumL f 0 (asListL t)+ in (nt==nl) && ((asListL t') == l) && (isSortedOK compare t')+ f acc n = (acc+n,n+1)++-- | Test mapAccumRAVL'+testMapAccumRAVL' :: IO ()+testMapAccumRAVL' = do title "mapAccumRAVL'"+ exhaustiveTest test (take 6 allAVL)+ where test _ _ t = let (nt,t') = mapAccumRAVL' f 0 t+ (nl,l ) = mapAccumR f 0 (asListL t)+ in (nt==nl) && ((asListL t') == l) && (isSortedOK compare t')+ f acc n = (acc+n,n+1)++#ifdef __GLASGOW_HASKELL__+-- | Test mapAccumLAVL''+testMapAccumLAVL'' :: IO ()+testMapAccumLAVL'' = do title "mapAccumLAVL''"+ exhaustiveTest test (take 6 allAVL)+ where test _ _ t = let (nt,t') = mapAccumLAVL'' f_ 0 t+ (nl,l ) = mapAccumL f 0 (asListL t)+ in (nt==nl) && ((asListL t') == l) && (isSortedOK compare t')+ f_ acc n = UBT2(acc+n,n+1)+ f acc n = (acc+n,n+1)++-- | Test mapAccumRAVL''+testMapAccumRAVL'' :: IO ()+testMapAccumRAVL'' = do title "mapAccumRAVL''"+ exhaustiveTest test (take 6 allAVL)+ where test _ _ t = let (nt,t') = mapAccumRAVL'' f_ 0 t+ (nl,l ) = mapAccumR f 0 (asListL t)+ in (nt==nl) && ((asListL t') == l) && (isSortedOK compare t')+ f_ acc n = UBT2(acc+n,n+1)+ f acc n = (acc+n,n+1)+#endif++-- | Test the join function+testJoin :: IO ()+testJoin = let trees = take num $ concatMap (\(_,ts) -> ts) allAVL+ num = 2000+ in do title "join"+ putStrLn $ "Testing " ++ show (num*num) ++ " tree pairs.."+ if and [test l $ mapAVL (ls+) r | (l,ls) <- trees, (r,_) <- trees] then passed else failed+ where test l r = let j = l `join` r+ in isBalanced j && (asListL j == l `toListL` asListL r)++-- | Test the joinHAVL function+testJoinHAVL :: IO ()+testJoinHAVL = let trees = take num $ concatMap (\(_,ts) -> ts) allAVL+ num = 2000+ in do title "joinHAVL"+ putStrLn $ "Testing " ++ show (num*num) ++ " tree pairs.."+ if and [test l $ mapAVL (ls+) r | (l,ls) <- trees, (r,_) <- trees] then passed else failed+ where test l r = let (HAVL j hj) = (toHAVL l) `joinHAVL` (toHAVL r)+ in case checkHeight j of+ Nothing -> False+ Just hj_ -> (ASINT(hj) == hj_) && (asListL j == l `toListL` asListL r)++-- | Test the concatAVL function.+testConcatAVL :: IO ()+testConcatAVL = let trees = take num $ concatMap (\(_,ts) -> ts) allAVL+ num = 2000+ in do title "concatAVL"+ putStrLn $ "Testing " ++ show (num*num) ++ " tree pairs.."+ if others && and [test ls l $ mapAVL (\n -> n+(ls+1)) r+ | (l,ls) <- trees, (r,_) <- trees]+ then passed else failed+ where test ls l r = let j = concatAVL $ [empty,empty,l,empty,singleton ls,empty,r,empty,empty]+ in isBalanced j && (asListL j == l `toListL` (ls:asListL r))+ others = all (isEmpty . concatAVL) [[],[empty],[empty,empty],[empty,empty,empty]]+ && (all test1 $ concatMap (\ss -> [ss,"":ss,"Z":ss])+ [[""]+ ,["A"]+ ,["","A","BC","","D","","EFGH","I"]+ ]+ )+ test1 ss = let t = concatAVL $ map asTreeL ss+ in isBalanced t && (asListL t == concat ss)++-- | Test the flatConcat function.+testFlatConcat :: IO ()+testFlatConcat = let trees = take num $ concatMap (\(_,ts) -> ts) allAVL+ num = 2000+ in do title "flatConcat"+ putStrLn $ "Testing " ++ show (num*num) ++ " tree pairs.."+ if others && and [test ls l $ mapAVL (\n -> n+(ls+1)) r+ | (l,ls) <- trees, (r,_) <- trees]+ then passed else failed+ where test ls l r = let j = flatConcat $ [empty,empty,l,empty,singleton ls,empty,r,empty,empty]+ in isBalanced j && (asListL j == l `toListL` (ls:asListL r))+ others = all (isEmpty . flatConcat) [[],[empty],[empty,empty],[empty,empty,empty]]+ && (all test1 $ concatMap (\ss -> [ss,"":ss,"Z":ss])+ [[""]+ ,["A"]+ ,["","A","BC","","D","","EFGH","I"]+ ]+ )+ test1 ss = let t = flatConcat $ map asTreeL ss+ in isBalanced t && (asListL t == concat ss)++-- | Test the filterViaList function+testFilterViaList :: IO ()+testFilterViaList = do title "filterViaList"+ exhaustiveTest test (take 6 allAVL)+ where test _ s t = all testit [0..s] -- n==s should yield unmodified tree+ where testit n = let t' = filterViaList (/= n) t+ in (isSortedOK compare t') && (asListL t' == ([0..n-1]++[n+1..s-1]))++-- | Test the filterAVL function+testFilterAVL :: IO ()+testFilterAVL = do title "filterAVL"+ exhaustiveTest test (take 6 allAVL)+ where test _ s t = all testit [0..s] -- n==s should yield unmodified tree+ where testit n = let t' = filterAVL (/= n) t+ in (isSortedOK compare t') && (asListL t' == ([0..n-1]++[n+1..s-1]))++-- | Test the mapMaybeViaList function+testMapMaybeViaList :: IO ()+testMapMaybeViaList = do title "mapMaybeViaList"+ exhaustiveTest test (take 6 allAVL)+ where test _ s t = all testit [0..s] -- n==s should yield unmodified tree+ where testit n = let t' = mapMaybeViaList (\m -> if m==n then Nothing else Just m) t+ in (isSortedOK compare t') && (asListL t' == ([0..n-1]++[n+1..s-1]))++-- | Test the mapMaybeAVL function+testMapMaybeAVL :: IO ()+testMapMaybeAVL = do title "mapMaybeAVL"+ exhaustiveTest test (take 6 allAVL)+ where test _ s t = all testit [0..s] -- n==s should yield unmodified tree+ where testit n = let t' = mapMaybeAVL (\m -> if m==n then Nothing else Just m) t+ in (isSortedOK compare t') && (asListL t' == ([0..n-1]++[n+1..s-1]))++-- | Test splitAtL function+testSplitAtL :: IO ()+testSplitAtL = do title "splitAtL"+ exhaustiveTest test (take 6 allAVL)+ where test _ s t = all splitTest0 [0..s-1] && all splitTest1 [s]+ where tlist = asListL t+ splitTest0 n = case splitAtL n t of+ Left _ -> False+ Right (l,r) -> (isBalanced l) && (isBalanced r) &&+ (size l == n) && (size r == s-n) &&+ (l `toListL` asListL r) == tlist+ splitTest1 n = case splitAtL n t of+ Left s_ -> s_==s+ Right _ -> False++-- | Test takeL function+testTakeL :: IO ()+testTakeL = do title "takeL"+ exhaustiveTest test (take 6 allAVL)+ where test _ s t = all takeTest0 [0..s-1] && all takeTest1 [s]+ where takeTest0 n = case takeL n t of+ Left _ -> False+ Right l -> (isBalanced l) && (asListL l) == [0..n-1]+ takeTest1 n = case takeL n t of+ Left s_ -> s_==s+ Right _ -> False++-- | Test dropL function+testDropL :: IO ()+testDropL = do title "dropL"+ exhaustiveTest test (take 6 allAVL)+ where test _ s t = all dropTest0 [0..s-1] && all dropTest1 [s]+ where dropTest0 n = case dropL n t of+ Left _ -> False+ Right r -> (isBalanced r) && (asListL r) == [n..s-1]+ dropTest1 n = case dropL n t of+ Left s_ -> s_==s+ Right _ -> False++-- | Test splitAtR function+testSplitAtR :: IO ()+testSplitAtR = do title "splitAtR"+ exhaustiveTest test (take 6 allAVL)+ where test _ s t = all splitTest0 [0..s-1] && all splitTest1 [s]+ where tlist = asListR t+ splitTest0 n = case splitAtR n t of+ Left _ -> False+ Right (l,r) -> (isBalanced l) && (isBalanced r) &&+ (size r == n) && (size l == s-n) &&+ (r `toListR` asListR l) == tlist+ splitTest1 n = case splitAtR n t of+ Left s_ -> s_==s+ Right _ -> False++-- | Test takeR function+testTakeR :: IO ()+testTakeR = do title "takeR"+ exhaustiveTest test (take 6 allAVL)+ where test _ s t = all takeTest0 [0..s-1] && all takeTest1 [s]+ where takeTest0 n = case takeR n t of+ Left _ -> False+ Right r -> (isBalanced r) && (asListL r) == [s-n..s-1]+ takeTest1 n = case takeR n t of+ Left s_ -> s_==s+ Right _ -> False++-- | Test dropR function+testDropR :: IO ()+testDropR = do title "dropR"+ exhaustiveTest test (take 6 allAVL)+ where test _ s t = all dropTest0 [0..s-1] && all dropTest1 [s]+ where dropTest0 n = case dropR n t of+ Left _ -> False+ Right l -> (isBalanced l) && (asListL l) == [0..(s-1)-n]+ dropTest1 n = case dropR n t of+ Left s_ -> s_==s+ Right _ -> False++-- | Test spanL function+testSpanL :: IO ()+testSpanL = do title "spanL"+ exhaustiveTest test (take 6 allAVL)+ where test _ s t = all spanTest [0..s]+ where tlist = asListL t+ spanTest n = let (l ,r ) = spanL (<n) t+ (l_,r_) = span (<n) tlist+ in (isBalanced l) && (isBalanced r) &&+ (asListL l == l_) && (asListL r == r_)++-- | Test takeWhileL function+testTakeWhileL :: IO ()+testTakeWhileL = do title "takeWhileL"+ exhaustiveTest test (take 6 allAVL)+ where test _ s t = all spanTest [0..s]+ where tlist = asListL t+ spanTest n = let l = takeWhileL (<n) t+ l_ = takeWhile (<n) tlist+ in (isBalanced l) && (asListL l == l_)++-- | Test dropWhileL function+testDropWhileL :: IO ()+testDropWhileL = do title "dropWhileL"+ exhaustiveTest test (take 6 allAVL)+ where test _ s t = all spanTest [0..s]+ where tlist = asListL t+ spanTest n = let r = dropWhileL (<n) t+ r_ = dropWhile (<n) tlist+ in (isBalanced r) && (asListL r == r_)++-- | Test spanR function+testSpanR :: IO ()+testSpanR = do title "spanR"+ exhaustiveTest test (take 6 allAVL)+ where test _ s t = all spanTest [0..s]+ where tlist = asListR t+ spanTest n = let (l ,r ) = spanR (>=n) t+ (l_,r_) = span (>=n) tlist+ in (isBalanced l) && (isBalanced r) &&+ (asListR l == r_) && (asListR r == l_)++-- | Test takeWhileR function+testTakeWhileR :: IO ()+testTakeWhileR = do title "takeWhileR"+ exhaustiveTest test (take 6 allAVL)+ where test _ s t = all spanTest [0..s]+ where tlist = asListR t+ spanTest n = let r = takeWhileR (>=n) t+ r_ = takeWhile (>=n) tlist+ in (isBalanced r) && (asListR r == r_)++-- | Test dropWhileR function+testDropWhileR :: IO ()+testDropWhileR = do title "dropWhileR"+ exhaustiveTest test (take 6 allAVL)+ where test _ s t = all spanTest [0..s]+ where tlist = asListR t+ spanTest n = let l = dropWhileR (>=n) t+ l_ = dropWhile (>=n) tlist+ in (isBalanced l) && (asListR l == l_)++-- | Test rotateL function+testRotateL :: IO ()+testRotateL = do title "rotateL"+ exhaustiveTest test (take 6 allAVL)+ where test _ s t = all isOK rotations+ where rotations = take s $ tail $ iterate (mapAVL' (\n -> (n-1) `mod` s) . rotateL) t+ isOK t_ = (isBalanced t_) && (asListL t_ == tlist)+ tlist = asListL t+-- | Test rotateR function+testRotateR :: IO ()+testRotateR = do title "rotateR"+ exhaustiveTest test (take 6 allAVL)+ where test _ s t = all isOK rotations+ where rotations = take s $ tail $ iterate (mapAVL' (\n -> (n+1) `mod` s) . rotateR) t+ isOK t_ = (isBalanced t_) && (asListL t_ == tlist)+ tlist = asListL t++-- | Test rotateByL function+testRotateByL :: IO ()+testRotateByL = do title "rotateByL"+ exhaustiveTest test (take 6 allAVL)+ where test _ s t = all isOK $ map rotateIt [-1..s]+ where rotateIt n = mapAVL' (\n_ -> (n_-n) `mod` s) $ rotateByL t n+ isOK t_ = (isBalanced t_) && (asListL t_ == tlist)+ tlist = asListL t++-- | Test rotateByR function+testRotateByR :: IO ()+testRotateByR = do title "rotateByR"+ exhaustiveTest test (take 6 allAVL)+ where test _ s t = all isOK $ map rotateIt [-1..s]+ where rotateIt n = mapAVL' (\n_ -> (n_+n) `mod` s) $ rotateByR t n+ isOK t_ = (isBalanced t_) && (asListL t_ == tlist)+ tlist = asListL t++-- | Test genForkL function+testGenForkL :: IO ()+testGenForkL = do title "genForkL"+ exhaustiveTest test (take 6 allAVL)+ where test _ s t = all testForkL [-1..s-1]+ where tlist = asListL t+ testForkL n = let (l,r) = genForkL (compare n) t+ in (isBalanced l) && (isBalanced r) &&+ (size l == n+1) && (size r == s-(n+1)) &&+ (l `toListL` asListL r == tlist)++-- | Test genForkR function+testGenForkR :: IO ()+testGenForkR = do title "genForkR"+ exhaustiveTest test (take 6 allAVL)+ where test _ s t = all testForkR [0..s]+ where tlist = asListL t+ testForkR n = let (l,r) = genForkR (compare n) t+ in (isBalanced l) && (isBalanced r) &&+ (size l == n) && (size r == s-n) &&+ (l `toListL` asListL r == tlist)+++-- | Test genFork function+testGenFork :: IO ()+testGenFork = do title "genFork"+ exhaustiveTest test (take 6 allAVL)+ where test _ s t = all testFork0 [0..s-1] && testFork1 (-1) && testFork2 s+ where tlist = asListL t+ testFork0 n = let (l,mbn,r) = genFork (fstCC n) t+ in case mbn of+ Just n_ -> (n_==n) && (isBalanced l) && (isBalanced r) &&+ (size l == n) && (size r == s-(n+1)) &&+ (l `toListL` (n : asListL r) == tlist)+ _ -> False+ testFork1 n = let (l,mbn,r) = genFork (fstCC n) t+ in case mbn of+ Nothing -> (isEmpty l) && (isBalanced r) && (asListL r == tlist)+ _ -> False+ testFork2 n = let (l,mbn,r) = genFork (fstCC n) t+ in case mbn of+ Nothing -> (isEmpty r) && (isBalanced l) && (asListL l == tlist)+ _ -> False++-- | Test genTakeLE function+testGenTakeLE :: IO ()+testGenTakeLE = do title "genTakeLE"+ exhaustiveTest test (take 6 allAVL)+ where test _ s t = all testTakeLE [-1..s-1]+ where testTakeLE n = let l = genTakeLE (compare n) t+ in (isBalanced l) && (asListL l == [0..n])++-- | Test genTakeLT function+testGenTakeLT :: IO ()+testGenTakeLT = do title "genTakeLT"+ exhaustiveTest test (take 6 allAVL)+ where test _ s t = all testTakeLT [0..s]+ where testTakeLT n = let l = genTakeLT (compare n) t+ in (isBalanced l) && (asListL l == [0..n-1])++-- | Test genTakeGT function+testGenTakeGT :: IO ()+testGenTakeGT = do title "genTakeGT"+ exhaustiveTest test (take 6 allAVL)+ where test _ s t = all testTakeGT [-1..s-1]+ where testTakeGT n = let r = genTakeGT (compare n) t+ in (isBalanced r) && (asListL r == [n+1..s-1])++-- | Test genTakeGE function+testGenTakeGE :: IO ()+testGenTakeGE = do title "genTakeGE"+ exhaustiveTest test (take 6 allAVL)+ where test _ s t = all testTakeGE [0..s]+ where testTakeGE n = let r = genTakeGE (compare n) t+ in (isBalanced r) && (asListL r == [n..s-1])++-- | Test the genUnion function+testGenUnion :: IO ()+testGenUnion = let trees = take num $ concatMap (\(_,ts) -> ts) allAVL+ num = 1000+ in do title "genUnion"+ putStrLn $ "Testing " ++ show (num*num) ++ " tree pairs.."+ if and [test l ls r rs | (l,ls) <- trees, (r,rs) <- trees] then passed else failed+ where test l ls r rs = all (\f -> f l ls r rs) [test1,test2,test3]+ test1 l ls r rs = let u = unionFst l r+ in isBalanced u && (asListL u == [0 .. max ls rs - 1])+ test2 l ls r rs = and [test2_ n $ mapAVL' (n+) r | n <- [(-rs)..ls]]+ where test2_ n r_ = let u = unionFst l r_+ in isBalanced u && (asListL u == [min n 0 .. max ls (rs+n) - 1])+ test3 l ls r rs = let l_ = mapAVL' (\n -> n+n ) l -- even+ r_ = mapAVL' (\n -> n+n+1) r -- odd+ u = unionFst l_ r_+ in isSortedOK compare u && (size u == ls+rs)+ unionFst = genUnion fstCC+++-- | Test the genSymDifference function+testGenSymDifference :: IO ()+testGenSymDifference =+ let trees = take num $ concatMap (\(_,ts) -> ts) allAVL+ num = 1000+ in do title "genSymDifference"+ putStrLn $ "Testing " ++ show (num*num) ++ " tree pairs.."+ if and [test l ls r rs | (l,ls) <- trees, (r,rs) <- trees] then passed else failed+ where test l ls r rs = all (\f -> f l ls r rs) [test1,test2,test3]+ test1 l ls r rs = let u = symDiff l r+ in isBalanced u && (asListL u == [min ls rs .. max ls rs - 1])+ test2 l ls r rs = and [test2_ n $ mapAVL' (n+) r | n <- [(-rs)..ls]]+ where test2_ n r_ = let u = symDiff l r_+ in isBalanced u && (asListL u == [min n 0 .. max n 0 - 1] +++ [min ls (rs+n) .. max ls (rs+n) - 1])+ test3 l ls r rs = let l_ = mapAVL' (\n -> n+n ) l -- even+ r_ = mapAVL' (\n -> n+n+1) r -- odd+ u = symDiff l_ r_+ in isSortedOK compare u && (size u == ls+rs)+ symDiff = genSymDifference compare++-- | Test the genUnionMaybe function+testGenUnionMaybe :: IO ()+testGenUnionMaybe = let trees = take num $ concatMap (\(_,ts) -> ts) allAVL+ num = 1000+ in do title "genUnionMaybe"+ putStrLn $ "Testing " ++ show (num*num) ++ " tree pairs.."+ if and [test l ls r rs | (l,ls) <- trees, (r,rs) <- trees] then passed else failed+ where test l ls r rs = all (\f -> f l ls r rs) [test1,test2,test3]+ test1 l ls r rs = let u = onion l r+ mn = min ls rs+ mx = max ls rs+ in isBalanced u && (asListL u == [0,2 .. mn - 1] ++ [mn .. mx-1])+ test2 l ls r rs = and [test2_ n $ mapAVL' (n+) r | n <- [(-rs)..ls]]+ where test2_ n r_ = let u = onion l r_+ n0 = min n 0+ n1 = max n 0+ n2 = min ls (rs+n)+ n3 = max ls (rs+n)+ in isBalanced u && (asListL u == [n0 .. n1-1]+ ++ filter even [n1 .. n2-1]+ ++ [n2..n3-1]+ )+ test3 l ls r rs = let l_ = mapAVL' (\n -> n+n ) l -- even+ r_ = mapAVL' (\n -> n+n+1) r -- odd+ u = onion l_ r_+ in isSortedOK compare u && (size u == ls+rs)+ onion = genUnionMaybe (withCC' com)+ com a _ = if even a then Just a else Nothing++-- | Test the genIntersection function+testGenIntersection :: IO ()+testGenIntersection = let trees = take num $ concatMap (\(_,ts) -> ts) allAVL+ num = 1000+ in do title "genIntersection"+ putStrLn $ "Testing " ++ show (num*num) ++ " tree pairs.."+ if and [test l ls r rs | (l,ls) <- trees, (r,rs) <- trees] then passed else failed+ where test l ls r rs = all (\f -> f l ls r rs) [test1,test2,test3]+ test1 l ls r rs = let u = genIntersection fstCC l r+ in isBalanced u && (asListL u == [0 .. min ls rs - 1])+ test2 l ls r rs = and [test2_ n $ mapAVL' (n+) r | n <- [(-rs)..ls]]+ where test2_ n r_ = let u = genIntersection fstCC l r_+ in isBalanced u && (asListL u == [max n 0 .. min ls (rs+n) - 1])+ test3 l _ r _ = let l_ = mapAVL' (\n -> n+n ) l -- even+ r_ = mapAVL' (\n -> n+n+1) r -- odd+ u = genIntersection fstCC l_ r_+ in isEmpty u++-- | Test the genIntersectionMaybe function+testGenIntersectionMaybe :: IO ()+testGenIntersectionMaybe = let trees = take num $ concatMap (\(_,ts) -> ts) allAVL+ num = 1000+ in do title "genIntersectionMaybe"+ putStrLn $ "Testing " ++ show (num*num) ++ " tree pairs.."+ if and [test l ls r rs | (l,ls) <- trees, (r,rs) <- trees] then passed else failed+ where test l ls r rs = all (\f -> f l ls r rs) [test1,test2,test3]+ test1 l ls r rs = let u = insect l r+ mn = min ls rs+ in isBalanced u && (asListL u == [0,2 .. mn - 1])+ test2 l ls r rs = and [test2_ n $ mapAVL' (n+) r | n <- [(-rs)..ls]]+ where test2_ n r_ = let u = insect l r_+ n1 = max n 0+ n2 = min ls (rs+n)+ in isBalanced u && (asListL u == filter even [n1 .. n2-1])+ test3 l _ r _ = let l_ = mapAVL' (\n -> n+n ) l -- even+ r_ = mapAVL' (\n -> n+n+1) r -- odd+ u = insect l_ r_+ in isEmpty u+ insect = genIntersectionMaybe (withCC' com)+ com a _ = if even a then Just a else Nothing++-- | Test the genIntersectionAsListL function+testGenIntersectionAsListL :: IO ()+testGenIntersectionAsListL =+ let trees = take num $ concatMap (\(_,ts) -> ts) allAVL+ num = 1000+ in do title "genIntersectionAsListL"+ putStrLn $ "Testing " ++ show (num*num) ++ " tree pairs.."+ if and [test l ls r rs | (l,ls) <- trees, (r,rs) <- trees] then passed else failed+ where test l ls r rs = all (\f -> f l ls r rs) [test1,test2,test3]+ test1 l ls r rs = let u = genIntersectionAsListL fstCC l r+ in u == [0 .. min ls rs - 1]+ test2 l ls r rs = and [test2_ n $ mapAVL' (n+) r | n <- [(-rs)..ls]]+ where test2_ n r_ = let u = genIntersectionAsListL fstCC l r_+ in u == [max n 0 .. min ls (rs+n) - 1]+ test3 l _ r _ = let l_ = mapAVL' (\n -> n+n ) l -- even+ r_ = mapAVL' (\n -> n+n+1) r -- odd+ u = genIntersectionAsListL fstCC l_ r_+ in null u++-- | Test the genIntersectionMaybeAsListL function+testGenIntersectionMaybeAsListL :: IO ()+testGenIntersectionMaybeAsListL =+ let trees = take num $ concatMap (\(_,ts) -> ts) allAVL+ num = 1000+ in do title "genIntersectionMaybeAsListL"+ putStrLn $ "Testing " ++ show (num*num) ++ " tree pairs.."+ if and [test l ls r rs | (l,ls) <- trees, (r,rs) <- trees] then passed else failed+ where test l ls r rs = all (\f -> f l ls r rs) [test1,test2,test3]+ test1 l ls r rs = let u = insect l r+ mn = min ls rs+ in u == [0,2 .. mn - 1]+ test2 l ls r rs = and [test2_ n $ mapAVL' (n+) r | n <- [(-rs)..ls]]+ where test2_ n r_ = let u = insect l r_+ n1 = max n 0+ n2 = min ls (rs+n)+ in u == filter even [n1 .. n2-1]+ test3 l _ r _ = let l_ = mapAVL' (\n -> n+n ) l -- even+ r_ = mapAVL' (\n -> n+n+1) r -- odd+ u = insect l_ r_+ in null u+ insect = genIntersectionMaybeAsListL (withCC' com)+ com a _ = if even a then Just a else Nothing++-- | Test the genDifference function+testGenDifference :: IO ()+testGenDifference = let trees = take num $ concatMap (\(_,ts) -> ts) allAVL+ num = 1000+ in do title "genDifference"+ putStrLn $ "Testing " ++ show (num*num) ++ " tree pairs.."+ if and [test l ls r rs | (l,ls) <- trees, (r,rs) <- trees] then passed else failed+ where test l ls r rs = all (\f -> f l ls r rs) [test1,test2,test3]+ test1 l ls r rs = let u = difference l r+ in isBalanced u && (asListL u == [rs .. ls - 1])+ test2 l ls r rs = and [test2_ n $ mapAVL' (n+) r | n <- [(-rs)..ls]]+ where test2_ n r_ = let u = difference l r_+ in isBalanced u && (asListL u == [0 .. n-1] ++ [rs+n .. ls-1])+ test3 l ls r rs = let l_ = mapAVL' (\n -> n+n ) l -- even+ r_ = mapAVL' (\n -> n+n+1) r -- odd+ u = difference l r_+ u_ = difference l_ r_+ mn = min (ls-1) (2*rs-1)+ in isBalanced u &&+ (asListL u == filter even [0..mn] ++ [mn+1..ls-1]) &&+ isBalanced u_ && (u_ == l_)+ difference = genDifference compare++-- | Test the genDifferenceMaybe function+testGenDifferenceMaybe :: IO ()+testGenDifferenceMaybe =+ let trees = take num $ concatMap (\(_,ts) -> ts) allAVL+ num = 1000+ in do title "genDifferenceMaybe"+ putStrLn $ "Testing " ++ show (num*num) ++ " tree pairs.."+ if and [test l ls r rs | (l,ls) <- trees, (r,rs) <- trees] then passed else failed+ where c m n = case compare m n of+ LT -> Lt+ EQ -> if even m then (Eq Nothing) else (Eq (Just m))+ GT -> Gt+ test l ls r rs = all (\f -> f l ls r rs) [test1,test2,test3]+ test1 l ls r rs = let mn = min (ls-1) (rs-1)+ u = genDifferenceMaybe c l r+ in isBalanced u && (asListL u == filter odd [0..mn] ++ [mn+1..ls-1])+ test2 l ls r rs = and [test2_ n $ mapAVL' (n+) r | n <- [(-rs)..ls]]+ where test2_ n r_ = let u = genDifferenceMaybe c l r_+ n0 = max 0 n+ n1 = min (ls-1) (rs+n-1)+ in isBalanced u &&+ (asListL u == [0..n0-1] ++ filter odd [n0..n1] ++ [n1+1..ls-1])+ test3 l ls r rs = let l_ = mapAVL' (\n -> n+n+1) l -- odd+ r_ = mapAVL' (\n -> n+n ) r -- even+ u = genDifferenceMaybe c l r_+ u_ = genDifferenceMaybe c l_ r_+ mn = min (ls-1) (2*rs-2)+ mx = max (mn+1) 0+ listfil = filter odd [0..mn]+ listrem = [mx..ls-1]+ in isBalanced u && isBalanced u_ && (u_ == l_) &&+ (asListL u == listfil ++ listrem)++-- | Test the genIsSubsetOf function+testGenIsSubsetOf :: IO ()+testGenIsSubsetOf = let trees = take num $ concatMap (\(_,ts) -> ts) allAVL+ num = 1000+ in do title "genIsSubsetOf"+ putStrLn $ "Testing " ++ show (num*num) ++ " tree pairs.."+ if and [test l ls r rs | (l,ls) <- trees, (r,rs) <- trees] then passed else failed+ where test l ls r rs = all (\f -> f l ls r rs) [test1,test2]+ test1 l ls r rs = (l `isSubsetOf` r == (ls<=rs)) &&+ (r `isSubsetOf` l == (rs<=ls))+ test2 l ls r rs = and [test2_ n $ mapAVL' (n+) r | n <- [(-rs)..ls]]+ where test2_ n r_ = (l `isSubsetOf` r_ == ((n<=0) && (rs+n>=ls))) &&+ (r_ `isSubsetOf` l == ((n>=0) && (rs+n<=ls)))+ isSubsetOf = genIsSubsetOf compare++-- | Test the genIsSubsetOfBy function+testGenIsSubsetOfBy :: IO ()+testGenIsSubsetOfBy = let trees = take num $ concatMap (\(_,ts) -> ts) allAVL+ num = 1000+ in do title "genIsSubsetOfBy"+ putStrLn $ "Testing " ++ show (num*num) ++ " tree pairs.."+ if and [test l ls r rs | (l,ls) <- trees, (r,rs) <- trees] then passed else failed+ -- test1 & test2 chack same behaviour as genIsSubsetOf+ -- test3 checks behviour for comarison functions that may return (Eq False)+ where test l ls r rs = all (\f -> f l ls r rs) [test1,test2,test3]+ test1 l ls r rs = (l `isSubsetOf` r == (ls<=rs)) &&+ (r `isSubsetOf` l == (rs<=ls))+ test2 l ls r rs = and [test2_ n $ mapAVL' (n+) r | n <- [(-rs)..ls]]+ where test2_ n r_ = (l `isSubsetOf` r_ == ((n<=0) && (rs+n>=ls))) &&+ (r_ `isSubsetOf` l == ((n>=0) && (rs+n<=ls)))+ isSubsetOf = genIsSubsetOfBy (withCC (\_ _ -> True ))+ test3 l ls r rs = and [test3_ n | n <- [0..max ls rs]]+ where test3_ n = (l `isSubsetOf'` r == ((ls<=rs) && (n>=ls))) &&+ (r `isSubsetOf'` l == ((rs<=ls) && (n>=rs)))+ where isSubsetOf' = genIsSubsetOfBy (withCC (\m _ -> m /= n))+++-- | Test compareHeight function+testCompareHeight :: IO ()+testCompareHeight = let trees = take num $ concatMap (\(h,ts) -> [(t,h)|(t,_)<-ts]) allAVL+ num = 10000+ in do title "compareHeight"+ putStrLn $ "Testing " ++ show (num*num) ++ " tree pairs.."+ if and [test l lh r rh | (l,lh) <- trees, (r,rh) <- trees] then passed else failed+ where test l lh r rh = compareHeight l r == compare lh rh++-- | Test Zipper open\/close+testGenOpenClose :: IO ()+testGenOpenClose = do title "Zipper open/close"+ exhaustiveTest test (take 5 allNonEmptyAVL)+ where test _ s t = all test_ [0..s-1]+ where test_ n = let z = genAssertOpen (compare n) t+ t_ = close z+ in (getCurrent z == n) && (isBalanced t_) && (asListL t_ == [0..s-1])+-- | Test Zipper delClose+testDelClose :: IO ()+testDelClose = do title "Zipper delClose"+ exhaustiveTest test (take 5 allNonEmptyAVL)+ where test _ s t = all test_ [0..s-1]+ where test_ n = let t_ = delClose $ genAssertOpen (compare n) t+ in (isBalanced t_) -- && (insert n (asListL t_) == [0..s-1])++-- | Test Zipper assertOpenL\/close+testOpenLClose :: IO ()+testOpenLClose = do title "Zipper assertOpenL/close"+ exhaustiveTest test (take 5 allNonEmptyAVL)+ where test _ s t = let z = assertOpenL t+ t_ = close z+ in (getCurrent z == 0) && (isBalanced t_) && (asListL t_ == [0..s-1])++-- | Test Zipper assertOpenR\/close+testOpenRClose :: IO ()+testOpenRClose = do title "Zipper assertOpenR/close"+ exhaustiveTest test (take 5 allNonEmptyAVL)+ where test _ s t = let z = assertOpenR t+ t_ = close z+ in (getCurrent z == s-1) && (isBalanced t_) && (asListL t_ == [0..s-1])++-- | Test Zipper assertMoveL\/isRightmost+testMoveL :: IO ()+testMoveL = do title "Zipper assertMoveL/isRightmost"+ exhaustiveTest test (take 5 allNonEmptyAVL)+ where test _ s t = let zavls@(z:zs) = take s $ iterate assertMoveL (assertOpenR t)+ in (map getCurrent zavls == reverse [0..s-1]) && (all test_ zavls) &&+ (isRightmost z) && (not $ any isRightmost zs)+ where test_ zavl = let t_ = close zavl+ in (isBalanced t_) && (asListL t_ == [0..s-1])++-- | Test Zipper assertMoveR\/isLeftmost+testMoveR :: IO ()+testMoveR = do title "Zipper assertMoveR/isLeftmost"+ exhaustiveTest test (take 5 allNonEmptyAVL)+ where test _ s t = let zavls@(z:zs) = take s $ iterate assertMoveR (assertOpenL t)+ in (map getCurrent zavls == [0..s-1]) && (all test_ zavls) &&+ (isLeftmost z) && (not $ any isLeftmost zs)+ where test_ zavl = let t_ = close zavl+ in (isBalanced t_) && (asListL t_ == [0..s-1])++-- | Test Zipper insertL+testInsertL :: IO ()+testInsertL = do title "Zipper insertL"+ exhaustiveTest test (take 5 allNonEmptyAVL)+ where test _ s t = all test_ [0..s-1]+ where test_ n = let z = insertL s $ genAssertOpen (compare n) t+ t_ = close z+ in (getCurrent z == n) && (isBalanced t_) &&+ (asListL t_ == [0..n-1] ++ s:[n..s-1])+-- | Test Zipper insertMoveL+testInsertMoveL :: IO ()+testInsertMoveL = do title "Zipper insertMoveL"+ exhaustiveTest test (take 5 allNonEmptyAVL)+ where test _ s t = all test_ [0..s-1]+ where test_ n = let z = insertMoveL s $ genAssertOpen (compare n) t+ t_ = close z+ in (getCurrent z == s) && (isBalanced t_) &&+ (asListL t_ == [0..n-1] ++ s:[n..s-1])++-- | Test Zipper insertR+testInsertR :: IO ()+testInsertR = do title "Zipper insertR"+ exhaustiveTest test (take 5 allNonEmptyAVL)+ where test _ s t = all test_ [0..s-1]+ where test_ n = let z = insertR (genAssertOpen (compare n) t) s+ t_ = close z+ in (getCurrent z == n) && (isBalanced t_) &&+ (asListL t_ == [0..n] ++ s:[(n+1)..s-1])++-- | Test Zipper insertMoveR+testInsertMoveR :: IO ()+testInsertMoveR = do title "Zipper insertMoveR"+ exhaustiveTest test (take 5 allNonEmptyAVL)+ where test _ s t = all test_ [0..s-1]+ where test_ n = let z = insertMoveR (genAssertOpen (compare n) t) s+ t_ = close z+ in (getCurrent z == s) && (isBalanced t_) &&+ (asListL t_ == [0..n] ++ s:[(n+1)..s-1])++-- | Test Zipper insertTreeL+testInsertTreeL :: IO ()+testInsertTreeL = do title "Zipper insertTreeL"+ exhaustiveTest test (take 5 allNonEmptyAVL)+ where test _ s t = all test_ [0..s-1]+ where test_ n = let z = insertTreeL t $ genAssertOpen (compare n) t+ t_ = close z+ in (getCurrent z == n) && (isBalanced t_) &&+ (asListL t_ == [0..n-1] ++ [0..s-1] ++ [n..s-1])++-- | Test Zipper insertTreeR+testInsertTreeR :: IO ()+testInsertTreeR = do title "Zipper insertTreeR"+ exhaustiveTest test (take 5 allNonEmptyAVL)+ where test _ s t = all test_ [0..s-1]+ where test_ n = let z = insertTreeR (genAssertOpen (compare n) t) t+ t_ = close z+ in (getCurrent z == n) && (isBalanced t_) &&+ (asListL t_ == [0..n] ++ [0..s-1] ++ [n+1..s-1])+-- | Test Zipper assertDelMoveL+testDelMoveL :: IO ()+testDelMoveL = do title "Zipper assertDelMoveL"+ exhaustiveTest test (take 5 allNonEmptyAVL)+ where test _ s t = let zavls = take s $ iterate assertDelMoveL $ insertR (assertOpenR t) s+ in (map getCurrent zavls == reverse [0..s-1]) &&+ (and $ zipWith test_ zavls $ reverse [0..s-1])+ where test_ zavl s_ = let t_ = close zavl+ in (isBalanced t_) && (asListL t_ == [0..s_] ++ [s])++-- | Test Zipper assertDelMoveR+testDelMoveR :: IO ()+testDelMoveR = do title "Zipper assertDelMoveR"+ exhaustiveTest test (take 5 allNonEmptyAVL)+ where test _ s t = let zavls = take s $ iterate assertDelMoveR $ insertL s $ assertOpenL t+ in (map getCurrent zavls == [0..s-1]) &&+ (and $ zipWith test_ zavls [0..s-1])+ where test_ zavl s_ = let t_ = close zavl+ in (isBalanced t_) && (asListL t_ == s:[s_..s-1])++-- | Test Zipper delAllL+testDelAllL :: IO ()+testDelAllL = do title "Zipper delAllL"+ exhaustiveTest test (take 5 allNonEmptyAVL)+ where test _ s t = all test_ [0..s-1]+ where test_ n = let z = delAllL $ genAssertOpen (compare n) t+ t_ = close z+ t__ = close $ insertTreeL t z+ in (isBalanced t_ ) && (asListL t_ == [n..s-1]) &&+ (isBalanced t__) && (asListL t__ == [0..s-1] ++ [n..s-1])++-- | Test Zipper delAllR+testDelAllR :: IO ()+testDelAllR = do title "Zipper delAllR"+ exhaustiveTest test (take 5 allNonEmptyAVL)+ where test _ s t = all test_ [0..s-1]+ where test_ n = let z = delAllR $ genAssertOpen (compare n) t+ t_ = close z+ t__ = close $ insertTreeR z t+ in (isBalanced t_ ) && (asListL t_ == [0..n]) &&+ (isBalanced t__) && (asListL t__ == [0..n] ++ [0..s-1])++-- | Test Zipper delAllCloseL+testDelAllCloseL :: IO ()+testDelAllCloseL = do title "Zipper delAllCloseL"+ exhaustiveTest test (take 5 allNonEmptyAVL)+ where test _ s t = all test_ [0..s-1]+ where test_ n = let t_ = delAllCloseL $ genAssertOpen (compare n) t+ in (isBalanced t_ ) && (asListL t_ == [n..s-1])++-- | Test Zipper delAllIncCloseL+testDelAllIncCloseL :: IO ()+testDelAllIncCloseL = do title "Zipper delAllIncCloseL"+ exhaustiveTest test (take 5 allNonEmptyAVL)+ where test _ s t = all test_ [0..s-1]+ where test_ n = let t_ = delAllIncCloseL $ genAssertOpen (compare n) t+ in (isBalanced t_ ) && (asListL t_ == [n+1..s-1])++-- | Test Zipper delAllCloseR+testDelAllCloseR :: IO ()+testDelAllCloseR = do title "Zipper delAllCloseR"+ exhaustiveTest test (take 5 allNonEmptyAVL)+ where test _ s t = all test_ [0..s-1]+ where test_ n = let t_ = delAllCloseR $ genAssertOpen (compare n) t+ in (isBalanced t_ ) && (asListL t_ == [0..n])++-- | Test Zipper delAllIncCloseR+testDelAllIncCloseR :: IO ()+testDelAllIncCloseR = do title "Zipper delAllIncCloseR"+ exhaustiveTest test (take 5 allNonEmptyAVL)+ where test _ s t = all test_ [0..s-1]+ where test_ n = let t_ = delAllIncCloseR $ genAssertOpen (compare n) t+ in (isBalanced t_ ) && (asListL t_ == [0..n-1])++-- | Test Zipper sizeL\/sizeR\/sizeZAVL+testZipSize :: IO ()+testZipSize = do title "Zipper sizeL/sizeR/sizeZAVL"+ exhaustiveTest test (take 5 allNonEmptyAVL)+ where test _ s t = all test_ [0..s-1]+ where test_ n = let z = genAssertOpen (compare n) t+ in (sizeL z == n) && (sizeR z == (s-1)-n) && (sizeZAVL z == s)++-- | Test Zipper genTryOpenGE+testGenTryOpenGE :: IO ()+testGenTryOpenGE = do title "Zipper genTryOpenGE"+ exhaustiveTest test (take 5 allNonEmptyAVL)+ where test _ s t = let t_ = mapAVL' (2*) t+ in all (testE t_) [0,2..2*s-2] && all (testO t_) [(-1),1..2*s-3]+ where testE t_ n = let Just z = tryOpenGE n t_+ t__ = close z+ in (getCurrent z == n) && (isBalanced t__) && (asListL t__ == [0,2..2*s-2])+ testO t_ n = let Just z = tryOpenGE n t_+ t__ = close z+ in (getCurrent z == n+1) && (isBalanced t__) && (asListL t__ == [0,2..2*s-2])+ tryOpenGE a = genTryOpenGE (compare a)++-- | Test Zipper genTryOpenLE+testGenTryOpenLE :: IO ()+testGenTryOpenLE = do title "Zipper genTryOpenLE"+ exhaustiveTest test (take 5 allNonEmptyAVL)+ where test _ s t = let t_ = mapAVL' (2*) t+ in all (testE t_) [0,2..2*s-2] && all (testO t_) [1,3..2*s-1]+ where testE t_ n = let Just z = tryOpenLE n t_+ t__ = close z+ in (getCurrent z == n) && (isBalanced t__) && (asListL t__ == [0,2..2*s-2])+ testO t_ n = let Just z = tryOpenLE n t_+ t__ = close z+ in (getCurrent z == n-1) && (isBalanced t__) && (asListL t__ == [0,2..2*s-2])+ tryOpenLE a = genTryOpenLE (compare a)++-- | Test Zipper genOpenEither (also tests fill and fillClose)+testGenOpenEither :: IO ()+testGenOpenEither = do title "Zipper genOpenEither"+ exhaustiveTest test (take 6 allAVL)+ where test _ s t = let t_ = mapAVL' (2*) t+ in all (testE t_) [0,2..2*s-2] && all (testO t_) [-1,1..2*s-1]+ where testE t_ n = let Right z = openEither n t_+ t__ = close z+ in (getCurrent z == n) && (isBalanced t__) && (asListL t__ == [0,2..2*s-2])+ testO t_ n = let Left p = openEither n t_+ t__ = close (fill n p)+ t___ = fillClose n p+ in (isBalanced t__) && (isBalanced t___) && (t__ == t___) &&+ (asListL t__ == ([0,2..n-1] ++ n : [n+1,n+3..2*s-2]))+ openEither a = genOpenEither (compare a)++++-- | Test anyBAVLtoEither+testBAVLtoZipper :: IO ()+testBAVLtoZipper = do title "BAVLtoZipper"+ exhaustiveTest test (take 6 allAVL)+ where test _ s t = let t_ = mapAVL' (2*) t+ in all (testE t_) [0,2..2*s-2] && all (testO t_) [-1,1..2*s-1]+ where testE t_ n = let bavl = openBAVL n t_+ Right z = anyBAVLtoEither bavl+ t__ = close z+ in (getCurrent z == n) && (isBalanced t__) && (asListL t__ == [0,2..2*s-2])+ testO t_ n = let bavl = openBAVL n t_+ Left p = anyBAVLtoEither bavl+ t__ = fillClose n p+ in (isBalanced t__) && (asListL t__ == ([0,2..n-1] ++ n : [n+1,n+3..2*s-2]))+ openBAVL e = genOpenBAVL (compare e)+++-- | Test Show,Read,Eq instances+testShowReadEq :: IO ()+testShowReadEq = do title "ShowReadEq"+ exhaustiveTest test (take 5 allAVL) -- No need to get carried away with this one+ where test _ _ t = t == (read $ show t)++-- | Test readPath+testReadPath :: IO ()+testReadPath = do title "ReadPath"+ if all test [0..100] then passed else failed+ where test n = let ASINT(n_)=n in (n == readPath n_ pathTree)++title :: String -> IO ()+title str = let titl = "* Test " ++ str ++ " *"+ mark = replicate (length titl) '*'+ in putStrLn "" >> putStrLn mark >> putStrLn titl >> putStrLn mark++passed :: IO ()+passed = putStrLn "Passed"++failed :: IO ()+failed = do putStrLn "!! FAILED !!"+ exitFailure+
+ Data/Tree/AVL/Test/Counter.hs view
@@ -0,0 +1,49 @@+-----------------------------------------------------------------------------+-- |+-- Module : Data.Tree.AVL.Test.Counter+-- Copyright : (c) Adrian Hey 2004,2005+-- License : BSD3+--+-- Maintainer : http://homepages.nildram.co.uk/~ahey/em.png+-- Stability : stable+-- Portability : portable+--+-- This module defines the 'XInt' type which is a specialised instance of 'Ord' which allows+-- the number of comparisons performed to be counted. This may be used evaluate various+-- algorithms. The functions defined here are not exported by the main "Data.Tree.AVL"+-- module. You need to import this module explicitly if you want to use any of them.+-----------------------------------------------------------------------------+module Data.Tree.AVL.Test.Counter+ (XInt(..),+ getCount,resetCount,+ ) where++import System.IO.Unsafe(unsafePerformIO)+import Data.IORef(IORef,newIORef,readIORef,writeIORef)++{-# NOINLINE count #-}+count :: IORef Int+count = unsafePerformIO $ newIORef 0++-- Increment the counter.+incCount :: IO ()+incCount = do c <- readIORef count+ let c' = c+1 in c' `seq` writeIORef count c'++-- | Read the current comparison counter.+getCount :: IO Int+getCount = readIORef count++-- | Reset the comparison counter to zero.+resetCount :: IO ()+resetCount = writeIORef count 0++-- | Basic data type.+newtype XInt = XInt Int deriving (Eq,Show,Read)++-- | A side effecting instance of Ord.+instance Ord XInt where+ compare (XInt x) (XInt y) = unsafePerformIO $ do incCount+ return $! compare x y++
+ Data/Tree/AVL/Test/Utils.hs view
@@ -0,0 +1,221 @@+{-# OPTIONS_GHC -fglasgow-exts #-}+-----------------------------------------------------------------------------+-- |+-- Module : Data.Tree.AVL.Test.Utils+-- Copyright : (c) Adrian Hey 2004,2005+-- License : BSD3+--+-- Maintainer : http://homepages.nildram.co.uk/~ahey/em.png+-- Stability : stable+-- Portability : portable+--+-- 'AVL' tree related test and verification utilities.+-----------------------------------------------------------------------------+module Data.Tree.AVL.Test.Utils+ (-- * Correctness checking.+ isBalanced,checkHeight,isSorted,isSortedOK,+ -- * Test data generation.+ TestTrees,allAVL, allNonEmptyAVL, numTrees, flatAVL,+ -- * Exhaustive tests.+ exhaustiveTest,+ -- * Tree parameter utilities.+ minElements,maxElements,+ -- * Testing BinPath module.+ pathTree,+ ) where++import Data.Tree.AVL.Types(AVL(..))+import Data.Tree.AVL.List(mapAVL',asTreeLenL,asListL)++#ifdef __GLASGOW_HASKELL__+import GHC.Base+#include "ghcdefs.h"+#else+#include "h98defs.h"+#endif++-- | Infinite test tree. Used for test purposes for BinPath module.+-- Value at each node is the path to that node.+pathTree :: AVL Int+pathTree = Z l 0 r where+ l = mapIt (\n -> 2*n+1) pathTree+ r = mapIt (\n -> 2*n+2) pathTree+ -- Need special lazy map for this recursive tree defn+ mapIt f (Z l' n r') = let n'= f n in n' `seq` Z (mapIt f l') n' (mapIt f r')+ mapIt _ _ = undefined++-- | Verify that a tree is height balanced and that the BF of each node is correct.+--+-- Complexity: O(n)+isBalanced :: AVL e -> Bool+isBalanced t = not (cH t EQL L(-1))++-- | Verify that a tree is balanced and the BF of each node is correct.+-- Returns (Just height) if so, otherwise Nothing.+--+-- Complexity: O(n)+checkHeight :: AVL e -> Maybe Int+checkHeight t = let ht = cH t in if ht EQL L(-1) then Nothing else Just ASINT(ht)++-- Local utility, returns height if balanced, -1 if not+cH :: AVL e -> UINT+cH E = L(0)+cH (N l _ r) = cH_ L(1) l r -- (hr-hl) = 1+cH (Z l _ r) = cH_ L(0) l r -- (hr-hl) = 0+cH (P l _ r) = cH_ L(1) r l -- (hl-hr) = 1+cH_ :: UINT -> AVL e -> AVL e -> UINT+cH_ delta l r = let hl = cH l+ in if hl EQL L(-1) then hl+ else let hr = cH r+ in if hr EQL L(-1) then hr+ else if SUBINT(hr,hl) EQL delta then INCINT1(hr)+ else L(-1)++-- | Verify that a tree is sorted.+--+-- Complexity: O(n)+isSorted :: (e -> e -> Ordering) -> AVL e -> Bool+isSorted c = isSorted' where+ isSorted' E = True+ isSorted' (N l e r) = isSorted'' l e r+ isSorted' (Z l e r) = isSorted'' l e r+ isSorted' (P l e r) = isSorted'' l e r+ isSorted'' l e r = (isSortedU l e) && (isSortedL e r)+ -- Verify tree is sorted and rightmost element is less than an upper limit (ul)+ isSortedU E _ = True+ isSortedU (N l e r) ul = isSortedU' l e r ul+ isSortedU (Z l e r) ul = isSortedU' l e r ul+ isSortedU (P l e r) ul = isSortedU' l e r ul+ isSortedU' l e r ul = case c e ul of+ LT -> (isSortedU l e) && (isSortedLU e r ul)+ _ -> False+ -- Verify tree is sorted and leftmost element is greater than a lower limit (ll)+ isSortedL _ E = True+ isSortedL ll (N l e r) = isSortedL' ll l e r+ isSortedL ll (Z l e r) = isSortedL' ll l e r+ isSortedL ll (P l e r) = isSortedL' ll l e r+ isSortedL' ll l e r = case c e ll of+ GT -> (isSortedLU ll l e) && (isSortedL e r)+ _ -> False+ -- Verify tree is sorted and leftmost element is greater than a lower limit (ll)+ -- and rightmost element is less than an upper limit (ul)+ isSortedLU _ E _ = True+ isSortedLU ll (N l e r) ul = isSortedLU' ll l e r ul+ isSortedLU ll (Z l e r) ul = isSortedLU' ll l e r ul+ isSortedLU ll (P l e r) ul = isSortedLU' ll l e r ul+ isSortedLU' ll l e r ul = case c e ll of+ GT -> case c e ul of+ LT -> (isSortedLU ll l e) && (isSortedLU e r ul)+ _ -> False+ _ -> False+-- isSorted ends --+-------------------++-- | Verify that a tree is sorted, height balanced and the BF of each node is correct.+--+-- Complexity: O(n)+isSortedOK :: (e -> e -> Ordering) -> AVL e -> Bool+isSortedOK c t = (isBalanced t) && (isSorted c t)++-- | AVL Tree test data. Each element of a the list is a pair consisting of a height,+-- and list of all possible sorted trees of the same height, paired with their sizes.+-- The elements of each tree of size s are 0..s-1.+type TestTrees = [(Int, [(AVL Int, Int)])]++-- | All possible sorted AVL trees.+allAVL :: TestTrees+allAVL = p0 : p1 : moreTrees p1 p0 where+ p0 = (0, [(E , 0)]) -- All possible trees of height 0+ p1 = (1, [(Z E 0 E, 1)]) -- All possible trees of height 1+ -- Generate more trees of height N, from existing trees of height N-1 and N-2+ moreTrees :: (Int, [(AVL Int, Int)]) -> (Int, [(AVL Int, Int)]) -> [(Int, [(AVL Int, Int)])]+ moreTrees pN1@(hN1, tpsN1) -- Height N-1+ (_ , tpsN2) = -- Height N-2+ let hN0 = hN1 + 1 -- Height N+ tsN0 = interleave (interleave [newTree P l r | r <- tpsN2 , l <- tpsN1] -- BF=+1+ [newTree N l r | l <- tpsN2 , r <- tpsN1]) -- BF=-1+ [newTree Z l r | l <- tpsN1 , r <- tpsN1] -- BF= 0+ pN0 = (hN0,tsN0)+ in hN0 `seq` pN0 : moreTrees pN0 pN1+ -- Generate a new (tree,size) pair using the supplied constructor+ newTree con (l,sizel) (r,sizer) =+ let rootEl = sizel -- Value of new root element+ addRight = sizel+1 -- Offset to add to elements of right sub-tree+ newSize = addRight + sizer -- Size of the new tree+ r' = mapAVL' (addRight+) r+ t = r' `seq` con l rootEl r'+ in newSize `seq` t `seq` (t, newSize)+ -- interleave two lists (until one or other is [])+ interleave [] ys = ys+ interleave xs [] = xs+ interleave (x:xs) (y:ys) = (x:y:interleave xs ys)+++-- | Same as 'allAVL', but excluding the empty tree (of height 0).+allNonEmptyAVL :: TestTrees+allNonEmptyAVL = tail allAVL++-- | Returns the number of possible AVL trees of a given height.+--+-- Behaves as if defined..+--+-- > numTrees h = (\(_,xs) -> length xs) (allAVL !! h)+--+-- and satisfies this recurrence relation..+--+-- @+-- numTrees 0 = 1+-- numTrees 1 = 1+-- numTrees h = (2*(numTrees (h-2)) + (numTrees (h-1))) * (numTrees (h-1))+-- @+numTrees :: Int -> Integer+numTrees 0 = 1+numTrees 1 = 1+numTrees n = numTrees' 1 1 n where+ numTrees' n1 n2 2 = (2*n2 + n1)*n1+ numTrees' n1 n2 m = numTrees' ((2*n2 + n1)*n1) n1 (m-1)++-- | Apply the test function to each AVL tree in the TestTrees argument, and report+-- progress as test proceeds. The first two arguments of the test function are+-- tree height and size respectively.+exhaustiveTest :: (Int -> Int -> AVL Int -> Bool) -> TestTrees -> IO ()+exhaustiveTest f xs = mapM_ test xs where+ test (h,tps) = do putStr "Tree Height : " >> print h+ putStr "Number Of Trees: " >> print (numTrees h)+ mapM_ test' tps+ putStrLn "Done."+ where test' (t,s) = if f h s t then return () -- putStr "."+ else error $ show $ asListL t -- Temporary Hack++-- | Generates a flat AVL tree of n elements [0..n-1].+flatAVL :: Int -> AVL Int+flatAVL n = asTreeLenL n [0..n-1]++-- | Detetermine the minimum number of elements in an AVL tree of given height.+-- This function satisfies this recurrence relation..+--+-- @+-- minElements 0 = 0+-- minElements 1 = 1+-- minElements h = 1 + minElements (h-1) + minElements (h-2)+-- -- = Some weird expression involving the golden ratio+-- @+minElements :: Int -> Integer+minElements 0 = 0+minElements 1 = 1+minElements h = minElements' 0 1 h where+ minElements' n1 n2 2 = 1 + n1 + n2+ minElements' n1 n2 m = minElements' n2 (1 + n1 + n2) (m-1)++-- | Detetermine the maximum number of elements in an AVL tree of given height.+-- This function satisfies this recurrence relation..+--+-- @+-- maxElements 0 = 0+-- maxElements h = 1 + 2 * maxElements (h-1) -- = 2^h-1+-- @+maxElements :: Int -> Integer+maxElements 0 = 0+maxElements h = maxElements' 0 h where+ maxElements' n1 1 = 1 + 2*n1+ maxElements' n1 m = maxElements' (1 + 2*n1) (m-1)
+ Data/Tree/AVL/Types.hs view
@@ -0,0 +1,165 @@+{-# OPTIONS_GHC -fglasgow-exts #-}+-----------------------------------------------------------------------------+-- |+-- Module : Data.Tree.AVL.Types+-- Copyright : (c) Adrian Hey 2004,2005+-- License : BSD3+--+-- Maintainer : http://homepages.nildram.co.uk/~ahey/em.png+-- Stability : stable+-- Portability : portable+--+-- AVL Tree data type definition and a few simple utility functions.+-----------------------------------------------------------------------------+module Data.Tree.AVL.Types+ ( -- * Types.+ AVL(..),++ -- * Simple AVL related utilities.+ empty,isEmpty,isNonEmpty,singleton,pair,tryGetSingleton,++ ) where++import Prelude -- so haddock finds the symbols there++import Data.Typeable+#if __GLASGOW_HASKELL__ > 604+import Data.Foldable+import Data.Monoid+#endif++-- | AVL tree data type.+--+-- The balance factor (BF) of an 'AVL' tree node is defined as the difference between the height of+-- the left and right sub-trees. An 'AVL' tree is ALWAYS height balanced, such that |BF| <= 1.+-- The functions in this library ("Data.Tree.AVL") are designed so that they never construct+-- an unbalanced tree (well that's assuming they're not broken). The 'AVL' tree type defined here+-- has the BF encoded the constructors.+--+-- Some functions in this library return 'AVL' trees that are also \"flat\", which (in the context+-- of this library) means that the sizes of left and right sub-trees differ by at most one and+-- are also flat. Flat sorted trees should give slightly shorter searches than sorted trees which+-- are merely height balanced. Whether or not flattening is worth the effort depends on the number+-- of times the tree will be searched and the cost of element comparison.+--+-- In cases where the tree elements are sorted, all the relevant 'AVL' functions follow the+-- convention that the leftmost tree element is least and the rightmost tree element is+-- the greatest. Bear this in mind when defining general comparison functions. It should+-- also be noted that all functions in this library for sorted trees require that the tree+-- does not contain multiple elements which are \"equal\" (according to whatever criterion+-- has been used to sort the elements).+--+-- It is important to be consistent about argument ordering when defining general purpose+-- comparison functions (or selectors) for searching a sorted tree, such as ..+--+-- @+-- myComp :: (k -> e -> Ordering)+-- -- or..+-- myCComp :: (k -> e -> COrdering a)+-- @+--+-- In these cases the first argument is the search key and the second argument is an element of+-- the 'AVL' tree. For example..+--+-- @+-- key \`myCComp\` element -> Lt implies key < element, proceed down the left sub-tree+-- key \`myCComp\` element -> Gt implies key > element, proceed down the right sub-tree+-- @+--+-- This convention is same as that used by the overloaded 'compare' method from 'Ord' class.+--+-- WARNING: The constructors of this data type are exported from this module but not from+-- the top level 'AVL' wrapper ("Data.Tree.AVL"). Don't try to construct your own 'AVL'+-- trees unless you're sure you know what your doing. If you end up creating and using+-- 'AVL' trees that aren't you'll break most of the functions in this library.+--+-- Controlling Strictness.+--+-- The 'AVL' data type is declared as non-strict in all it's fields,+-- but all the functions in this library behave as though it is strict in its+-- recursive fields (left and right sub-trees). Strictness in the element field is+-- controlled either by using the strict variants of functions (defined in this library+-- where appropriate), or using strict variants of the combinators defined in "Data.COrdering",+-- or using 'seq' etc. in your own code (in any combining comparisons you define, for example).+--+-- A note about 'Eq' and 'Ord' class instances.+--+-- For 'AVL' trees the defined instances of 'Ord' and 'Eq' are based on the lists that are produced using+-- the 'Data.Tree.AVL.List.asListL' function (it could just as well have been 'Data.Tree.AVL.List.asListR',+-- the choice is arbitrary but I can only chose one). This means that two trees which contain the same elements+-- in the same order are equal regardless of detailed tree structure. The same principle has been applied to+-- the instances of 'Read' and 'Show'. Unfortunately, this has the undesirable and non-intuitive effect+-- of making \"equal\" trees potentially distinguishable using some functions (such as height).+-- All such functions have been placed in the Data.Tree.AVL.Internals modules, which are not+-- included in the main "Data.Tree.AVL" wrapper. For all \"normal\" functions (f) exported by "Data.Tree.AVL"+-- it is safe to assume that if a and b are 'AVL' trees then (a == b) implies (f a == f b), provided the same+-- is true for the tree elements.+--+data AVL e = E -- ^ Empty Tree+ | N (AVL e) e (AVL e) -- ^ BF=-1 (right height > left height)+ | Z (AVL e) e (AVL e) -- ^ BF= 0+ | P (AVL e) e (AVL e) -- ^ BF=+1 (left height > right height)++-- A name for the AVL type constructor, fully qualified+avlTyConName :: String+avlTyConName = "Data.Tree.AVL.AVL"++-- A Typeable1 instance+instance Typeable1 AVL where+ typeOf1 _ = mkTyConApp (mkTyCon avlTyConName) []++#ifndef __GLASGOW_HASKELL__+-- A Typeable instance (not needed by ghc, but Haddock fails to document this instance)+instance Typeable e => Typeable (AVL e) where+ typeOf = typeOfDefault+#endif++#if __GLASGOW_HASKELL__ > 604+instance Foldable AVL where+ foldMap _f E = mempty+ foldMap f (N l v r) = foldMap f l `mappend` f v `mappend` foldMap f r+ foldMap f (Z l v r) = foldMap f l `mappend` f v `mappend` foldMap f r+ foldMap f (P l v r) = foldMap f l `mappend` f v `mappend` foldMap f r+#endif++-- | The empty AVL tree.+{-# INLINE empty #-}+empty :: AVL e+empty = E++-- | Returns 'True' if an AVL tree is empty.+--+-- Complexity: O(1)+{-# INLINE isEmpty #-}+isEmpty :: AVL e -> Bool+isEmpty E = True+isEmpty _ = False++-- | Returns 'True' if an AVL tree is non-empty.+--+-- Complexity: O(1)+{-# INLINE isNonEmpty #-}+isNonEmpty :: AVL e -> Bool+isNonEmpty E = False+isNonEmpty _ = True++-- | Creates an AVL tree with just one element.+--+-- Complexity: O(1)+{-# INLINE singleton #-}+singleton :: e -> AVL e+singleton e = Z E e E++-- | Create an AVL tree of two elements, occuring in same order as the arguments.+{-# INLINE pair #-}+pair :: e -> e -> AVL e+pair e0 e1 = P (Z E e0 E) e1 E++-- | If the AVL tree is a singleton (has only one element @e@) then this function returns @('Just' e)@.+-- Otherwise it returns Nothing.+--+-- Complexity: O(1)+{-# INLINE tryGetSingleton #-}+tryGetSingleton :: AVL e -> Maybe e+tryGetSingleton (Z E e _) = Just e -- Right subtree must be E too, but no need to waste time checking+tryGetSingleton _ = Nothing
+ Data/Tree/AVL/Write.hs view
@@ -0,0 +1,197 @@+-----------------------------------------------------------------------------+-- |+-- Module : Data.Tree.AVL.Write+-- Copyright : (c) Adrian Hey 2004,2005+-- License : BSD3+--+-- Maintainer : http://homepages.nildram.co.uk/~ahey/em.png+-- Stability : stable+-- Portability : portable+-----------------------------------------------------------------------------+module Data.Tree.AVL.Write+(-- * Writing to AVL trees+ -- | These functions alter the content of a tree (values of tree elements) but not the structure+ -- of a tree.++ -- ** Writing to extreme left or right+ -- | I'm not sure these are likely to be much use in practice, but they're+ -- simple enough to implement so are included for the sake of completeness.+ writeL,tryWriteL,writeR,tryWriteR,++ -- ** Writing to /sorted/ trees+ genWrite,genWriteFast,genTryWrite,genWriteMaybe,genTryWriteMaybe+) where++import Prelude -- so haddock finds the symbols there++import Data.COrdering+import Data.Tree.AVL.Types(AVL(..))+import Data.Tree.AVL.Internals.BinPath(BinPath(..),genOpenPathWith,writePath)++---------------------------------------------------------------------------+-- writeL, tryWriteL --+---------------------------------------------------------------------------+-- | Replace the left most element of a tree with the supplied new element.+-- This function raises an error if applied to an empty tree.+--+-- Complexity: O(log n)+writeL :: e -> AVL e -> AVL e+writeL _ E = error "writeL: Empty Tree"+writeL e' (N l e r) = writeLN e' l e r+writeL e' (Z l e r) = writeLZ e' l e r+writeL e' (P l e r) = writeLP e' l e r++-- | Similar to 'writeL', but returns 'Nothing' if applied to an empty tree.+--+-- Complexity: O(log n)+tryWriteL :: e -> AVL e -> Maybe (AVL e)+tryWriteL _ E = Nothing+tryWriteL e' (N l e r) = Just $! writeLN e' l e r+tryWriteL e' (Z l e r) = Just $! writeLZ e' l e r+tryWriteL e' (P l e r) = Just $! writeLP e' l e r++-- This version of writeL is for trees which are known to be non-empty.+writeL' :: e -> AVL e -> AVL e+writeL' _ E = error "writeL': Bug0"+writeL' e' (N l e r) = writeLN e' l e r -- l may be empty+writeL' e' (Z l e r) = writeLZ e' l e r -- l may be empty+writeL' e' (P l e r) = writeLP e' l e r -- l can't be empty++-- Write to left sub-tree of N l e r, or here if l is empty+writeLN :: e -> AVL e -> e -> AVL e -> AVL e+writeLN e' E _ r = N E e' r+writeLN e' (N ll le lr) e r = let l' = writeLN e' ll le lr in l' `seq` N l' e r+writeLN e' (Z ll le lr) e r = let l' = writeLZ e' ll le lr in l' `seq` N l' e r+writeLN e' (P ll le lr) e r = let l' = writeLP e' ll le lr in l' `seq` N l' e r++-- Write to left sub-tree of Z l e r, or here if l is empty+writeLZ :: e -> AVL e -> e -> AVL e -> AVL e+writeLZ e' E _ r = Z E e' r -- r must be E too!+writeLZ e' (N ll le lr) e r = let l' = writeLN e' ll le lr in l' `seq` Z l' e r+writeLZ e' (Z ll le lr) e r = let l' = writeLZ e' ll le lr in l' `seq` Z l' e r+writeLZ e' (P ll le lr) e r = let l' = writeLP e' ll le lr in l' `seq` Z l' e r++-- Write to left sub-tree of P l e r (l can't be empty)+{-# INLINE writeLP #-}+writeLP :: e -> AVL e -> e -> AVL e -> AVL e+writeLP e' l e r = let l' = writeL' e' l in l' `seq` P l' e r+---------------------------------------------------------------------------+-- writeL, tryWriteL end here --+---------------------------------------------------------------------------+++---------------------------------------------------------------------------+-- writeR, tryWriteR --+---------------------------------------------------------------------------+-- | Replace the right most element of a tree with the supplied new element.+-- This function raises an error if applied to an empty tree.+--+-- Complexity: O(log n)+writeR :: AVL e -> e -> AVL e+writeR E _ = error "writeR: Empty Tree"+writeR (N l e r) e' = writeRN l e r e'+writeR (Z l e r) e' = writeRZ l e r e'+writeR (P l e r) e' = writeRP l e r e'++-- | Similar to 'writeR', but returns 'Nothing' if applied to an empty tree.+--+-- Complexity: O(log n)+tryWriteR :: AVL e -> e -> Maybe (AVL e)+tryWriteR E _ = Nothing+tryWriteR (N l e r) e' = Just $! writeRN l e r e'+tryWriteR (Z l e r) e' = Just $! writeRZ l e r e'+tryWriteR (P l e r) e' = Just $! writeRP l e r e'++-- This version of writeR is for trees which are known to be non-empty.+writeR' :: AVL e -> e -> AVL e+writeR' E _ = error "writeR': Bug0"+writeR' (N l e r) e' = writeRN l e r e' -- r can't be empty+writeR' (Z l e r) e' = writeRZ l e r e' -- r may be empty+writeR' (P l e r) e' = writeRP l e r e' -- r may be empty++-- Write to right sub-tree of N l e r (r can't be empty)+{-# INLINE writeRN #-}+writeRN :: AVL e -> e -> AVL e -> e -> AVL e+writeRN l e r e' = let r' = writeR' r e' in r' `seq` N l e r'++-- Write to right sub-tree of Z l e r, or here if r is empty+writeRZ :: AVL e -> e -> AVL e -> e -> AVL e+writeRZ l _ E e' = Z l e' E -- l must be E too!+writeRZ l e (N rl re rr) e' = let r' = writeRN rl re rr e' in r' `seq` Z l e r'+writeRZ l e (Z rl re rr) e' = let r' = writeRZ rl re rr e' in r' `seq` Z l e r'+writeRZ l e (P rl re rr) e' = let r' = writeRP rl re rr e' in r' `seq` Z l e r'++-- Write to right sub-tree of P l e r, or here if r is empty+writeRP :: AVL e -> e -> AVL e -> e -> AVL e+writeRP l _ E e' = P l e' E+writeRP l e (N rl re rr) e' = let r' = writeRN rl re rr e' in r' `seq` P l e r'+writeRP l e (Z rl re rr) e' = let r' = writeRZ rl re rr e' in r' `seq` P l e r'+writeRP l e (P rl re rr) e' = let r' = writeRP rl re rr e' in r' `seq` P l e r'+---------------------------------------------------------------------------+-- writeR, tryWriteR end here --+---------------------------------------------------------------------------+++-- | A general purpose function to perform a search of a tree, using the supplied selector.+-- If the search succeeds the found element is replaced by the value (@e@) of the @('Eq' e)@+-- constructor returned by the selector. If the search fails this function returns the original tree.+--+-- Complexity: O(log n)+genWrite :: (e -> COrdering e) -> AVL e -> AVL e+genWrite c t = case genOpenPathWith c t of+ FullBP pth e -> writePath pth e t+ _ -> t++-- | Functionally identical to 'genWrite', but returns an identical tree (one with all the nodes on+-- the path duplicated) if the search fails. This should probably only be used if you know the+-- search will succeed and will return an element which is different from that already present.+--+-- Complexity: O(log n)+genWriteFast :: (e -> COrdering e) -> AVL e -> AVL e+genWriteFast c = write where+ write E = E+ write (N l e r) = case c e of+ Lt -> let l' = write l in l' `seq` N l' e r+ Eq v -> N l v r+ Gt -> let r' = write r in r' `seq` N l e r'+ write (Z l e r) = case c e of+ Lt -> let l' = write l in l' `seq` Z l' e r+ Eq v -> Z l v r+ Gt -> let r' = write r in r' `seq` Z l e r'+ write (P l e r) = case c e of+ Lt -> let l' = write l in l' `seq` P l' e r+ Eq v -> P l v r+ Gt -> let r' = write r in r' `seq` P l e r'++-- | A general purpose function to perform a search of a tree, using the supplied selector.+-- The found element is replaced by the value (@e@) of the @('Eq' e)@ constructor returned by+-- the selector. This function returns 'Nothing' if the search failed.+--+-- Complexity: O(log n)+genTryWrite :: (e -> COrdering e) -> AVL e -> Maybe (AVL e)+genTryWrite c t = case genOpenPathWith c t of+ FullBP pth e -> Just $! writePath pth e t+ _ -> Nothing++-- | Similar to 'genWrite', but also returns the original tree if the search succeeds but+-- the selector returns @('Eq' 'Nothing')@. (This version is intended to help reduce heap burn+-- rate if it\'s likely that no modification of the value is needed.)+--+-- Complexity: O(log n)+genWriteMaybe :: (e -> COrdering (Maybe e)) -> AVL e -> AVL e+genWriteMaybe c t = case genOpenPathWith c t of+ FullBP pth (Just e) -> writePath pth e t+ _ -> t++-- | Similar to 'genTryWrite', but also returns the original tree if the search succeeds but+-- the selector returns @('Eq' 'Nothing')@. (This version is intended to help reduce heap burn+-- rate if it\'s likely that no modification of the value is needed.)+--+-- Complexity: O(log n)+genTryWriteMaybe :: (e -> COrdering (Maybe e)) -> AVL e -> Maybe (AVL e)+genTryWriteMaybe c t = case genOpenPathWith c t of+ FullBP pth (Just e) -> Just $! writePath pth e t+ FullBP _ Nothing -> Just t+ _ -> Nothing++
+ Data/Tree/AVL/Zipper.hs view
@@ -0,0 +1,903 @@+{-# OPTIONS_GHC -fglasgow-exts #-}+-----------------------------------------------------------------------------+-- |+-- Module : Data.Tree.AVL.Zipper+-- Copyright : (c) Adrian Hey 2004,2005+-- License : BSD3+--+-- Maintainer : http://homepages.nildram.co.uk/~ahey/em.png+-- Stability : stable+-- Portability : portable+--+-----------------------------------------------------------------------------+module Data.Tree.AVL.Zipper+(-- * The AVL Zipper+ -- | An implementation of \"The Zipper\" for AVL trees. This can be used like+ -- a functional pointer to a serial data structure which can be navigated+ -- and modified, without having to worry about all those tricky tree balancing+ -- issues. See JFP Vol.7 part 5 or ..+ --+ -- <http://haskell.org/haskellwiki/Zipper>+ --+ -- Notes about efficiency:+ --+ -- The functions defined here provide a useful way to achieve those awkward+ -- operations which may not be covered by the rest of this package. They're+ -- reasonably efficient (mostly O(log n) or better), but zipper flexibility+ -- is bought at the expense of keeping path information explicitly as a heap+ -- data structure rather than implicitly on the stack. Since heap storage+ -- probably costs more, zipper operations will are likely to incur higher+ -- constant factors than equivalent non-zipper operations (if available).+ --+ -- Some of the functions provided here may appear to be weird combinations of+ -- functions from a more logical set of primitives. They are provided because+ -- they are not really simple combinations of the corresponding primitives.+ -- They are more efficient, so you should use them if possible (e.g combining+ -- deleting with Zipper closing).+ --+ -- Also, consider using the 'BAVL' as a cheaper alternative if you don't+ -- need to navigate the tree.++ -- ** Types+ ZAVL,PAVL,++ -- ** Opening+ assertOpenL,assertOpenR,+ tryOpenL,tryOpenR,+ genAssertOpen,genTryOpen,+ genTryOpenGE,genTryOpenLE,+ genOpenEither,++ -- ** Closing+ close,fillClose,++ -- ** Manipulating the current element.+ getCurrent,putCurrent,applyCurrent,applyCurrent',++ -- ** Moving+ assertMoveL,assertMoveR,tryMoveL,tryMoveR,++ -- ** Inserting elements+ insertL,insertR,insertMoveL,insertMoveR,fill,++ -- ** Deleting elements+ delClose,+ assertDelMoveL,assertDelMoveR,tryDelMoveR,tryDelMoveL,+ delAllL,delAllR,+ delAllCloseL,delAllCloseR,+ delAllIncCloseL,delAllIncCloseR,++ -- ** Inserting AVL trees+ insertTreeL,insertTreeR,++ -- ** Current element status+ isLeftmost,isRightmost,+ sizeL,sizeR,++ -- ** Operations on whole zippers+ sizeZAVL,++ -- ** A cheaper option is to use BAVL+ -- | These are a cheaper but more restrictive alternative to using the full Zipper.+ -- They use \"Binary Paths\" (Ints) to point to a particular element of an 'AVL' tree.+ -- Use these when you don't need to navigate the tree, you just want to look at a+ -- particular element (and perhaps modify or delete it). The advantage of these is+ -- that they don't create the usual Zipper heap structure, so they will be faster+ -- (and reduce heap burn rate too).+ --+ -- If you subsequently decide you need a Zipper rather than a BAVL then some conversion+ -- utilities are provided.++ -- *** Types+ BAVL,++ -- *** Opening and closing+ genOpenBAVL,closeBAVL,++ -- *** Inspecting status+ fullBAVL,emptyBAVL,tryReadBAVL,readFullBAVL,++ -- *** Modifying the tree+ pushBAVL,deleteBAVL,++ -- *** Converting to BAVL to Zipper+ -- | These are O(log n) operations but with low constant factors because no comparisons+ -- are required (and the tree nodes on the path will most likely still be in cache as+ -- a result of opening the BAVL in the first place).+ fullBAVLtoZAVL,emptyBAVLtoPAVL,anyBAVLtoEither,+) where++import Prelude -- so haddock finds the symbols there++import Data.Tree.AVL.Types(AVL(..))+import Data.Tree.AVL.Size(size,addSize)+import Data.Tree.AVL.Internals.DelUtils(deletePath,popRN,popRZ,popRP,popLN,popLZ,popLP)+import Data.Tree.AVL.Internals.HeightUtils(height,addHeight)+import Data.Tree.AVL.Internals.HJoin(spliceH,joinH)+import Data.Tree.AVL.Internals.HPush(pushHL,pushHR)+import Data.Tree.AVL.Internals.BinPath(BinPath(..),genOpenPath,writePath,insertPath,sel,goL,goR)++#ifdef __GLASGOW_HASKELL__+import GHC.Base+#include "ghcdefs.h"+#else+#include "h98defs.h"+#endif++-- N.B. Zippers are always opened using relative heights for efficiency reasons. On the+-- whole this causes no problems, except when inserting entire AVL trees or substituting+-- the empty tree. (These cases have some minor height computation overhead).++-- | Abstract data type for a successfully opened AVL tree. All ZAVL\'s are non-empty!+-- A ZAVL can be tought of as a functional pointer to an AVL tree element.+data ZAVL e = ZAVL (Path e) (AVL e) !UINT e (AVL e) !UINT++-- | Abstract data type for an unsuccessfully opened AVL tree.+-- A PAVL can be thought of as a functional pointer to the gap+-- where the expected element should be (but isn't). You can fill this gap using+-- the 'fill' function, or fill and close at the same time using the 'fillClose' function.+data PAVL e = PAVL (Path e) !UINT++data Path e = EP -- Empty Path+ | LP (Path e) e (AVL e) !UINT -- Left subtree was taken+ | RP (Path e) e (AVL e) !UINT -- Right subtree was taken++-- Local Closing Utility+close_ :: Path e -> AVL e -> UINT -> AVL e+close_ EP t _ = t+close_ (LP p e r hr) l hl = case spliceH l hl e r hr of UBT2(t,ht) -> close_ p t ht+close_ (RP p e l hl) r hr = case spliceH l hl e r hr of UBT2(t,ht) -> close_ p t ht++-- Local Utility to remove all left paths from a path+noLP :: Path e -> Path e+noLP EP = EP+noLP (LP p _ _ _ ) = noLP p+noLP (RP p e l hl) = let p_ = noLP p in p_ `seq` RP p_ e l hl++-- Local Utility to remove all right paths from a path+noRP :: Path e -> Path e+noRP EP = EP+noRP (LP p e r hr) = let p_ = noRP p in p_ `seq` LP p_ e r hr+noRP (RP p _ _ _ ) = noRP p++-- Local Closing Utility which ignores all left paths+closeNoLP :: Path e -> AVL e -> UINT -> AVL e+closeNoLP EP t _ = t+closeNoLP (LP p _ _ _ ) l hl = closeNoLP p l hl+closeNoLP (RP p e l hl) r hr = case spliceH l hl e r hr of UBT2(t,ht) -> closeNoLP p t ht++-- Local Closing Utility which ignores all right paths+closeNoRP :: Path e -> AVL e -> UINT -> AVL e+closeNoRP EP t _ = t+closeNoRP (LP p e r hr) l hl = case spliceH l hl e r hr of UBT2(t,ht) -> closeNoRP p t ht+closeNoRP (RP p _ _ _ ) r hr = closeNoRP p r hr++-- Add size of all path elements.+addSizeP :: Int -> Path e -> Int+addSizeP n EP = n+addSizeP n (LP p _ r _) = addSizeP (addSize (n+1) r) p+addSizeP n (RP p _ l _) = addSizeP (addSize (n+1) l) p++-- Add size of all RP path elements.+addSizeRP :: Int -> Path e -> Int+addSizeRP n EP = n+addSizeRP n (LP p _ _ _) = addSizeRP n p+addSizeRP n (RP p _ l _) = addSizeRP (addSize (n+1) l) p++-- Add size of all LP path elements.+addSizeLP :: Int -> Path e -> Int+addSizeLP n EP = n+addSizeLP n (LP p _ r _) = addSizeLP (addSize (n+1) r) p+addSizeLP n (RP p _ _ _) = addSizeLP n p++-- | Opens a sorted AVL tree at the element given by the supplied selector. This function+-- raises an error if the tree does not contain such an element.+--+-- Complexity: O(log n)+genAssertOpen :: (e -> Ordering) -> AVL e -> ZAVL e+genAssertOpen c t = op EP L(0) t where -- Relative heights !!+ -- op :: (Path e) -> UINT -> AVL e -> ZAVL e+ op _ _ E = error "genAssertOpen: No matching element."+ op p h (N l e r) = case c e of+ LT -> let p_ = LP p e r DECINT1(h) in p_ `seq` op p_ DECINT2(h) l+ EQ -> ZAVL p l DECINT2(h) e r DECINT1(h)+ GT -> let p_ = RP p e l DECINT2(h) in p_ `seq` op p_ DECINT1(h) r+ op p h (Z l e r) = case c e of+ LT -> let p_ = LP p e r DECINT1(h) in p_ `seq` op p_ DECINT1(h) l+ EQ -> ZAVL p l DECINT1(h) e r DECINT1(h)+ GT -> let p_ = RP p e l DECINT1(h) in p_ `seq` op p_ DECINT1(h) r+ op p h (P l e r) = case c e of+ LT -> let p_ = LP p e r DECINT2(h) in p_ `seq` op p_ DECINT1(h) l+ EQ -> ZAVL p l DECINT1(h) e r DECINT2(h)+ GT -> let p_ = RP p e l DECINT1(h) in p_ `seq` op p_ DECINT2(h) r++-- | Attempts to open a sorted AVL tree at the element given by the supplied selector.+-- This function returns 'Nothing' if there is no such element.+--+-- Note that this operation will still create a zipper path structure on the heap (which+-- is promptly discarded) if the search fails, and so is potentially inefficient if failure+-- is likely. In cases like this it may be better to use 'genOpenBAVL', test for \"fullness\"+-- using 'fullBAVL' and then convert to a 'ZAVL' using 'fullBAVLtoZAVL'.+--+-- Complexity: O(log n)+genTryOpen :: (e -> Ordering) -> AVL e -> Maybe (ZAVL e)+genTryOpen c t = op EP L(0) t where -- Relative heights !!+ -- op :: (Path e) -> UINT -> AVL e -> Maybe (ZAVL e)+ op _ _ E = Nothing+ op p h (N l e r) = case c e of+ LT -> let p_ = LP p e r DECINT1(h) in p_ `seq` op p_ DECINT2(h) l+ EQ -> Just $! ZAVL p l DECINT2(h) e r DECINT1(h)+ GT -> let p_ = RP p e l DECINT2(h) in p_ `seq` op p_ DECINT1(h) r+ op p h (Z l e r) = case c e of+ LT -> let p_ = LP p e r DECINT1(h) in p_ `seq` op p_ DECINT1(h) l+ EQ -> Just $! ZAVL p l DECINT1(h) e r DECINT1(h)+ GT -> let p_ = RP p e l DECINT1(h) in p_ `seq` op p_ DECINT1(h) r+ op p h (P l e r) = case c e of+ LT -> let p_ = LP p e r DECINT2(h) in p_ `seq` op p_ DECINT1(h) l+ EQ -> Just $! ZAVL p l DECINT1(h) e r DECINT2(h)+ GT -> let p_ = RP p e l DECINT1(h) in p_ `seq` op p_ DECINT2(h) r++-- | Attempts to open a sorted AVL tree at the least element which is greater than or equal, according to+-- the supplied selector. This function returns 'Nothing' if the tree does not contain such an element.+--+-- Complexity: O(log n)+genTryOpenGE :: (e -> Ordering) -> AVL e -> Maybe (ZAVL e)+genTryOpenGE c t = op EP L(0) t where -- Relative heights !!+ -- op :: (Path e) -> UINT -> AVL e -> ZAVL e+ op p h E = backupR p E h where+ backupR EP _ _ = Nothing+ backupR (LP p_ e r hr) l hl = Just $! ZAVL p_ l hl e r hr+ backupR (RP p_ e l hl) r hr = case spliceH l hl e r hr of UBT2(t_,ht_) -> backupR p_ t_ ht_+ op p h (N l e r) = case c e of+ LT -> let p_ = LP p e r DECINT1(h) in p_ `seq` op p_ DECINT2(h) l+ EQ -> Just $! ZAVL p l DECINT2(h) e r DECINT1(h)+ GT -> let p_ = RP p e l DECINT2(h) in p_ `seq` op p_ DECINT1(h) r+ op p h (Z l e r) = case c e of+ LT -> let p_ = LP p e r DECINT1(h) in p_ `seq` op p_ DECINT1(h) l+ EQ -> Just $! ZAVL p l DECINT1(h) e r DECINT1(h)+ GT -> let p_ = RP p e l DECINT1(h) in p_ `seq` op p_ DECINT1(h) r+ op p h (P l e r) = case c e of+ LT -> let p_ = LP p e r DECINT2(h) in p_ `seq` op p_ DECINT1(h) l+ EQ -> Just $! ZAVL p l DECINT1(h) e r DECINT2(h)+ GT -> let p_ = RP p e l DECINT1(h) in p_ `seq` op p_ DECINT2(h) r++-- | Attempts to open a sorted AVL tree at the greatest element which is less than or equal, according to+-- the supplied selector. This function returns _Nothing_ if the tree does not contain such an element.+--+-- Complexity: O(log n)+genTryOpenLE :: (e -> Ordering) -> AVL e -> Maybe (ZAVL e)+genTryOpenLE c t = op EP L(0) t where -- Relative heights !!+ -- op :: (Path e) -> UINT -> AVL e -> ZAVL e+ op p h E = backupL p E h where+ backupL EP _ _ = Nothing+ backupL (LP p_ e r hr) l hl = case spliceH l hl e r hr of UBT2(t_,ht_) -> backupL p_ t_ ht_+ backupL (RP p_ e l hl) r hr = Just $! ZAVL p_ l hl e r hr+ op p h (N l e r) = case c e of+ LT -> let p_ = LP p e r DECINT1(h) in p_ `seq` op p_ DECINT2(h) l+ EQ -> Just $! ZAVL p l DECINT2(h) e r DECINT1(h)+ GT -> let p_ = RP p e l DECINT2(h) in p_ `seq` op p_ DECINT1(h) r+ op p h (Z l e r) = case c e of+ LT -> let p_ = LP p e r DECINT1(h) in p_ `seq` op p_ DECINT1(h) l+ EQ -> Just $! ZAVL p l DECINT1(h) e r DECINT1(h)+ GT -> let p_ = RP p e l DECINT1(h) in p_ `seq` op p_ DECINT1(h) r+ op p h (P l e r) = case c e of+ LT -> let p_ = LP p e r DECINT2(h) in p_ `seq` op p_ DECINT1(h) l+ EQ -> Just $! ZAVL p l DECINT1(h) e r DECINT2(h)+ GT -> let p_ = RP p e l DECINT1(h) in p_ `seq` op p_ DECINT2(h) r++-- | Opens a non-empty AVL tree at the leftmost element.+-- This function raises an error if the tree is empty.+--+-- Complexity: O(log n)+assertOpenL :: AVL e -> ZAVL e+assertOpenL E = error "assertOpenL: Empty tree."+assertOpenL (N l e r) = openLN EP L(0) l e r -- Relative heights !!+assertOpenL (Z l e r) = openLZ EP L(0) l e r -- Relative heights !!+assertOpenL (P l e r) = openL_ (LP EP e r L(0)) L(1) l -- Relative heights !!++-- | Attempts to open a non-empty AVL tree at the leftmost element.+-- This function returns 'Nothing' if the tree is empty.+--+-- Complexity: O(log n)+tryOpenL :: AVL e -> Maybe (ZAVL e)+tryOpenL E = Nothing+tryOpenL (N l e r) = Just $! openLN EP L(0) l e r -- Relative heights !!+tryOpenL (Z l e r) = Just $! openLZ EP L(0) l e r -- Relative heights !!+tryOpenL (P l e r) = Just $! openL_ (LP EP e r L(0)) L(1) l -- Relative heights !!++-- Local utility for opening at the leftmost element, using current path and height.+openL_ :: (Path e) -> UINT -> AVL e -> ZAVL e+openL_ _ _ E = error "openL_: Bug0"+openL_ p h (N l e r) = openLN p h l e r+openL_ p h (Z l e r) = openLZ p h l e r+openL_ p h (P l e r) = let p_ = LP p e r DECINT2(h) in p_ `seq` openL_ p_ DECINT1(h) l++-- Open leftmost of (N l e r), where l may be E+openLN :: (Path e) -> UINT -> AVL e -> e -> AVL e -> ZAVL e+openLN p h E e r = ZAVL p E DECINT2(h) e r DECINT1(h)+openLN p h (N ll le lr) e r = let p_ = LP p e r DECINT1(h) in p_ `seq` openLN p_ DECINT2(h) ll le lr+openLN p h (Z ll le lr) e r = let p_ = LP p e r DECINT1(h) in p_ `seq` openLZ p_ DECINT2(h) ll le lr+openLN p h (P ll le lr) e r = let p_ = LP p e r DECINT1(h)+ p__ = p_ `seq` LP p_ le lr DECINT4(h)+ in p__ `seq` openL_ p__ DECINT3(h) ll+-- Open leftmost of (Z l e r), where l may be E+openLZ :: (Path e) -> UINT -> AVL e -> e -> AVL e -> ZAVL e+openLZ p h E e r = ZAVL p E DECINT1(h) e r DECINT1(h)+openLZ p h (N ll le lr) e r = let p_ = LP p e r DECINT1(h) in p_ `seq` openLN p_ DECINT1(h) ll le lr+openLZ p h (Z ll le lr) e r = let p_ = LP p e r DECINT1(h) in p_ `seq` openLZ p_ DECINT1(h) ll le lr+openLZ p h (P ll le lr) e r = let p_ = LP p e r DECINT1(h)+ p__ = p_ `seq` LP p_ le lr DECINT3(h)+ in p__ `seq` openL_ p__ DECINT2(h) ll++-- | Opens a non-empty AVL tree at the rightmost element.+-- This function raises an error if the tree is empty.+--+-- Complexity: O(log n)+assertOpenR :: AVL e -> ZAVL e+assertOpenR E = error "assertOpenR: Empty tree."+assertOpenR (N l e r) = openR_ (RP EP e l L(0)) L(1) r -- Relative heights !!+assertOpenR (Z l e r) = openRZ EP L(0) l e r -- Relative heights !!+assertOpenR (P l e r) = openRP EP L(0) l e r -- Relative heights !!++-- | Attempts to open a non-empty AVL tree at the rightmost element.+-- This function returns 'Nothing' if the tree is empty.+--+-- Complexity: O(log n)+tryOpenR :: AVL e -> Maybe (ZAVL e)+tryOpenR E = Nothing+tryOpenR (N l e r) = Just $! openR_ (RP EP e l L(0)) L(1) r -- Relative heights !!+tryOpenR (Z l e r) = Just $! openRZ EP L(0) l e r -- Relative heights !!+tryOpenR (P l e r) = Just $! openRP EP L(0) l e r -- Relative heights !!++-- Local utility for opening at the rightmost element, using current path and height.+openR_ :: (Path e) -> UINT -> AVL e -> ZAVL e+openR_ _ _ E = error "openR_: Bug0"+openR_ p h (N l e r) = let p_ = RP p e l DECINT2(h) in p_ `seq` openR_ p_ DECINT1(h) r+openR_ p h (Z l e r) = openRZ p h l e r+openR_ p h (P l e r) = openRP p h l e r+-- Open rightmost of (P l e r), where r may be E+openRP :: (Path e) -> UINT -> AVL e -> e -> AVL e -> ZAVL e+openRP p h l e E = ZAVL p l DECINT1(h) e E DECINT2(h)+openRP p h l e (N rl re rr) = let p_ = RP p e l DECINT1(h)+ p__ = p_ `seq` RP p_ re rl DECINT4(h)+ in p__ `seq` openR_ p__ DECINT3(h) rr+openRP p h l e (Z rl re rr) = let p_ = RP p e l DECINT1(h) in p_ `seq` openRZ p_ DECINT2(h) rl re rr+openRP p h l e (P rl re rr) = let p_ = RP p e l DECINT1(h) in p_ `seq` openRP p_ DECINT2(h) rl re rr+-- Open rightmost of (Z l e r), where r may be E+openRZ :: (Path e) -> UINT -> AVL e -> e -> AVL e -> ZAVL e+openRZ p h l e E = ZAVL p l DECINT1(h) e E DECINT1(h)+openRZ p h l e (N rl re rr) = let p_ = RP p e l DECINT1(h)+ p__ = p_ `seq` RP p_ re rl DECINT3(h)+ in p__ `seq` openR_ p__ DECINT2(h) rr+openRZ p h l e (Z rl re rr) = let p_ = RP p e l DECINT1(h) in p_ `seq` openRZ p_ DECINT1(h) rl re rr+openRZ p h l e (P rl re rr) = let p_ = RP p e l DECINT1(h) in p_ `seq` openRP p_ DECINT1(h) rl re rr++-- | Returns @('Right' zavl)@ if the expected element was found, @('Left' pavl)@ if the+-- expected element was not found. It's OK to use this function on empty trees.+--+-- Complexity: O(log n)+genOpenEither :: (e -> Ordering) -> AVL e -> Either (PAVL e) (ZAVL e)+genOpenEither c t = op EP L(0) t where -- Relative heights !!+ -- op :: (Path e) -> UINT -> AVL e -> Either (PAVL e) (ZAVL e)+ op p h E = Left $! PAVL p h+ op p h (N l e r) = case c e of+ LT -> let p_ = LP p e r DECINT1(h) in p_ `seq` op p_ DECINT2(h) l+ EQ -> Right $! ZAVL p l DECINT2(h) e r DECINT1(h)+ GT -> let p_ = RP p e l DECINT2(h) in p_ `seq` op p_ DECINT1(h) r+ op p h (Z l e r) = case c e of+ LT -> let p_ = LP p e r DECINT1(h) in p_ `seq` op p_ DECINT1(h) l+ EQ -> Right $! ZAVL p l DECINT1(h) e r DECINT1(h)+ GT -> let p_ = RP p e l DECINT1(h) in p_ `seq` op p_ DECINT1(h) r+ op p h (P l e r) = case c e of+ LT -> let p_ = LP p e r DECINT2(h) in p_ `seq` op p_ DECINT1(h) l+ EQ -> Right $! ZAVL p l DECINT1(h) e r DECINT2(h)+ GT -> let p_ = RP p e l DECINT1(h) in p_ `seq` op p_ DECINT2(h) r++-- | Fill the gap pointed to by a 'PAVL' with the supplied element, which becomes+-- the current element of the resulting 'ZAVL'. The supplied filling element should+-- be \"equal\" to the value used in the search which created the 'PAVL'.+--+-- Complexity: O(1)+fill :: e -> PAVL e -> ZAVL e+fill e (PAVL p h) = ZAVL p E h e E h++-- | Essentially the same operation as 'fill', but the resulting 'ZAVL' is closed+-- immediately.+--+-- Complexity: O(log n)+fillClose :: e -> PAVL e -> AVL e+fillClose e (PAVL p h) = close_ p (Z E e E) INCINT1(h)++-- | Closes a Zipper.+--+-- Complexity: O(log n)+close :: ZAVL e -> AVL e+close (ZAVL p l hl e r hr) = case spliceH l hl e r hr of UBT2(t,ht) -> close_ p t ht++-- | Deletes the current element and then closes the Zipper.+--+-- Complexity: O(log n)+delClose :: ZAVL e -> AVL e+delClose (ZAVL p l hl _ r hr) = case joinH l hl r hr of UBT2(t,ht) -> close_ p t ht++-- | Gets the current element of a Zipper.+--+-- Complexity: O(1)+getCurrent :: ZAVL e -> e+getCurrent (ZAVL _ _ _ e _ _) = e++-- | Overwrites the current element of a Zipper.+--+-- Complexity: O(1)+putCurrent :: e -> ZAVL e -> ZAVL e+putCurrent e (ZAVL p l hl _ r hr) = ZAVL p l hl e r hr++-- | Applies a function to the current element of a Zipper (lazily).+-- See also 'applyCurrent'' for a strict version of this function.+--+-- Complexity: O(1)+applyCurrent :: (e -> e) -> ZAVL e -> ZAVL e+applyCurrent f (ZAVL p l hl e r hr) = ZAVL p l hl (f e) r hr++-- | Applies a function to the current element of a Zipper strictly.+-- See also 'applyCurrent' for a non-strict version of this function.+--+-- Complexity: O(1)+applyCurrent' :: (e -> e) -> ZAVL e -> ZAVL e+applyCurrent' f (ZAVL p l hl e r hr) = let e_ = f e in e_ `seq` ZAVL p l hl e_ r hr++-- | Moves one step left.+-- This function raises an error if the current element is already the leftmost element.+--+-- Complexity: O(1) average, O(log n) worst case.+assertMoveL :: ZAVL e -> ZAVL e+assertMoveL (ZAVL p E _ e r hr) = case pushHL e r hr of UBT2(t,ht) -> cR p t ht+ where cR EP _ _ = error "assertMoveL: Can't move left."+ cR (LP p_ e_ r_ hr_) l_ hl_ = case spliceH l_ hl_ e_ r_ hr_ of UBT2(t,ht) -> cR p_ t ht+ cR (RP p_ e_ l_ hl_) r_ hr_ = ZAVL p_ l_ hl_ e_ r_ hr_+assertMoveL (ZAVL p (N ll le lr) hl e r hr) = let p_ = RP (LP p e r hr) le ll DECINT2(hl)+ in p_ `seq` openR_ p_ DECINT1(hl) lr+assertMoveL (ZAVL p (Z ll le lr) hl e r hr) = openRZ (LP p e r hr) hl ll le lr+assertMoveL (ZAVL p (P ll le lr) hl e r hr) = openRP (LP p e r hr) hl ll le lr++-- | Attempts to move one step left.+-- This function returns 'Nothing' if the current element is already the leftmost element.+--+-- Complexity: O(1) average, O(log n) worst case.+tryMoveL :: ZAVL e -> Maybe (ZAVL e)+tryMoveL (ZAVL p E _ e r hr) = case pushHL e r hr of UBT2(t,ht) -> cR p t ht+ where cR EP _ _ = Nothing+ cR (LP p_ e_ r_ hr_) l_ hl_ = case spliceH l_ hl_ e_ r_ hr_ of UBT2(t,ht) -> cR p_ t ht+ cR (RP p_ e_ l_ hl_) r_ hr_ = Just $! ZAVL p_ l_ hl_ e_ r_ hr_+tryMoveL (ZAVL p (N ll le lr) hl e r hr) = Just $! let p_ = RP (LP p e r hr) le ll DECINT2(hl)+ in p_ `seq` openR_ p_ DECINT1(hl) lr+tryMoveL (ZAVL p (Z ll le lr) hl e r hr) = Just $! openRZ (LP p e r hr) hl ll le lr+tryMoveL (ZAVL p (P ll le lr) hl e r hr) = Just $! openRP (LP p e r hr) hl ll le lr++-- | Moves one step right.+-- This function raises an error if the current element is already the rightmost element.+--+-- Complexity: O(1) average, O(log n) worst case.+assertMoveR :: ZAVL e -> ZAVL e+assertMoveR (ZAVL p l hl e E _ ) = case pushHR l hl e of UBT2(t,ht) -> cL p t ht+ where cL EP _ _ = error "assertMoveR: Can't move right."+ cL (RP p_ e_ l_ hl_) r_ hr_ = case spliceH l_ hl_ e_ r_ hr_ of UBT2(t,ht) -> cL p_ t ht+ cL (LP p_ e_ r_ hr_) l_ hl_ = ZAVL p_ l_ hl_ e_ r_ hr_+assertMoveR (ZAVL p l hl e (N rl re rr) hr) = openLN (RP p e l hl) hr rl re rr+assertMoveR (ZAVL p l hl e (Z rl re rr) hr) = openLZ (RP p e l hl) hr rl re rr+assertMoveR (ZAVL p l hl e (P rl re rr) hr) = let p_ = LP (RP p e l hl) re rr DECINT2(hr)+ in p_ `seq` openL_ p_ DECINT1(hr) rl++-- | Attempts to move one step right.+-- This function returns 'Nothing' if the current element is already the rightmost element.+--+-- Complexity: O(1) average, O(log n) worst case.+tryMoveR :: ZAVL e -> Maybe (ZAVL e)+tryMoveR (ZAVL p l hl e E _ ) = case pushHR l hl e of UBT2(t,ht) -> cL p t ht+ where cL EP _ _ = Nothing+ cL (RP p_ e_ l_ hl_) r_ hr_ = case spliceH l_ hl_ e_ r_ hr_ of UBT2(t,ht) -> cL p_ t ht+ cL (LP p_ e_ r_ hr_) l_ hl_ = Just $! ZAVL p_ l_ hl_ e_ r_ hr_+tryMoveR (ZAVL p l hl e (N rl re rr) hr) = Just $! openLN (RP p e l hl) hr rl re rr+tryMoveR (ZAVL p l hl e (Z rl re rr) hr) = Just $! openLZ (RP p e l hl) hr rl re rr+tryMoveR (ZAVL p l hl e (P rl re rr) hr) = Just $! let p_ = LP (RP p e l hl) re rr DECINT2(hr)+ in p_ `seq` openL_ p_ DECINT1(hr) rl++-- | Returns 'True' if the current element is the leftmost element.+--+-- Complexity: O(1) average, O(log n) worst case.+isLeftmost :: ZAVL e -> Bool+isLeftmost (ZAVL p E _ _ _ _) = iL p+ where iL EP = True+ iL (LP p_ _ _ _) = iL p_+ iL (RP _ _ _ _) = False+isLeftmost (ZAVL _ _ _ _ _ _) = False++-- | Returns 'True' if the current element is the rightmost element.+--+-- Complexity: O(1) average, O(log n) worst case.+isRightmost :: ZAVL e -> Bool+isRightmost (ZAVL p _ _ _ E _) = iR p+ where iR EP = True+ iR (RP p_ _ _ _) = iR p_+ iR (LP _ _ _ _) = False+isRightmost (ZAVL _ _ _ _ _ _) = False++-- | Inserts a new element to the immediate left of the current element.+--+-- Complexity: O(1) average, O(log n) worst case.+insertL :: e -> ZAVL e -> ZAVL e+insertL e0 (ZAVL p l hl e1 r hr) = case pushHR l hl e0 of UBT2(l_,hl_) -> ZAVL p l_ hl_ e1 r hr++-- | Inserts a new element to the immediate left of the current element and then+-- moves one step left (so the newly inserted element becomes the current element).+--+-- Complexity: O(1) average, O(log n) worst case.+insertMoveL :: e -> ZAVL e -> ZAVL e+insertMoveL e0 (ZAVL p l hl e1 r hr) = case pushHL e1 r hr of UBT2(r_,hr_) -> ZAVL p l hl e0 r_ hr_++-- | Inserts a new element to the immediate right of the current element.+--+-- Complexity: O(1) average, O(log n) worst case.+insertR :: ZAVL e -> e -> ZAVL e+insertR (ZAVL p l hl e0 r hr) e1 = case pushHL e1 r hr of UBT2(r_,hr_) -> ZAVL p l hl e0 r_ hr_++-- | Inserts a new element to the immediate right of the current element and then+-- moves one step right (so the newly inserted element becomes the current element).+--+-- Complexity: O(1) average, O(log n) worst case.+insertMoveR :: ZAVL e -> e -> ZAVL e+insertMoveR (ZAVL p l hl e0 r hr) e1 = case pushHR l hl e0 of UBT2(l_,hl_) -> ZAVL p l_ hl_ e1 r hr++-- | Inserts a new AVL tree to the immediate left of the current element.+--+-- Complexity: O(log n), where n is the size of the inserted tree.+insertTreeL :: AVL e -> ZAVL e -> ZAVL e+insertTreeL E zavl = zavl+insertTreeL t@(N l _ _) zavl = insertLH t (addHeight L(2) l) zavl -- Absolute height required!!+insertTreeL t@(Z l _ _) zavl = insertLH t (addHeight L(1) l) zavl -- Absolute height required!!+insertTreeL t@(P _ _ r) zavl = insertLH t (addHeight L(2) r) zavl -- Absolute height required!!+++-- Local utility to insert an AVL to the immediate left of the current element.+-- This operation carries a minor overhead in that we must convert the absolute+-- AVL height into a relative height with the same offset as the rest of the ZAVL.+-- This requires calculation of the absolute height at the current position, but+-- this should be relatively cheap because the overwhelming majority of elements will+-- be close to the bottom of any tree.+insertLH :: AVL e -> UINT -> ZAVL e -> ZAVL e+insertLH t ht (ZAVL p l hl e r hr) =+ let offset = case COMPAREUINT hl hr of -- chose smaller sub-tree to calculate absolute height+ LT -> SUBINT(hl,height l)+ EQ -> SUBINT(hl,height l)+ GT -> SUBINT(hr,height r)+ in case joinH l hl t ADDINT(ht,offset) of UBT2(l_,hl_) -> ZAVL p l_ hl_ e r hr++-- | Inserts a new AVL tree to the immediate right of the current element.+--+-- Complexity: O(log n), where n is the size of the inserted tree.+insertTreeR :: ZAVL e -> AVL e -> ZAVL e+insertTreeR zavl E = zavl+insertTreeR zavl t@(N l _ _) = insertRH t (addHeight L(2) l) zavl -- Absolute height required!!+insertTreeR zavl t@(Z l _ _) = insertRH t (addHeight L(1) l) zavl -- Absolute height required!!+insertTreeR zavl t@(P _ _ r) = insertRH t (addHeight L(2) r) zavl -- Absolute height required!!++-- Local utility to insert an AVL to the immediate right of the current element.+-- This operation carries a minor overhead in that we must convert the absolute+-- AVL height into a relative height with the same offset as the rest of the ZAVL.+-- This requires calculation of the absolute height at the current position, but+-- this should be relatively cheap because the overwhelming majority of elements will+-- be close to the bottom of any tree.+insertRH :: AVL e -> UINT -> ZAVL e -> ZAVL e+insertRH t ht (ZAVL p l hl e r hr) =+ let offset = case COMPAREUINT hl hr of -- chose smaller sub-tree to calculate absolute height+ LT -> SUBINT(hl,height l)+ EQ -> SUBINT(hr,height r)+ GT -> SUBINT(hr,height r)+ in case joinH t ADDINT(ht,offset) r hr of UBT2(r_,hr_) -> ZAVL p l hl e r_ hr_+++-- | Deletes the current element and moves one step left.+-- This function raises an error if the current element is already the leftmost element.+--+-- Complexity: O(1) average, O(log n) worst case.+assertDelMoveL :: ZAVL e -> ZAVL e+assertDelMoveL (ZAVL p E _ _ r hr) = dR p r hr+ where dR EP _ _ = error "assertDelMoveL: Can't move left."+ dR (LP p_ e_ r_ hr_) l_ hl_ = case spliceH l_ hl_ e_ r_ hr_ of UBT2(t,ht) -> dR p_ t ht+ dR (RP p_ e_ l_ hl_) r_ hr_ = ZAVL p_ l_ hl_ e_ r_ hr_+assertDelMoveL (ZAVL p (N ll le lr) hl _ r hr) = case popRN ll le lr of+ UBT2(l,e) -> case l of+ Z _ _ _ -> ZAVL p l DECINT1(hl) e r hr+ N _ _ _ -> ZAVL p l hl e r hr+ _ -> error "assertDelMoveL: Bug0" -- impossible+assertDelMoveL (ZAVL p (Z ll le lr) hl _ r hr) = case popRZ ll le lr of+ UBT2(l,e) -> case l of+ E -> ZAVL p l DECINT1(hl) e r hr -- Don't use E!!+ N _ _ _ -> error "assertDelMoveL: Bug1" -- impossible+ _ -> ZAVL p l hl e r hr+assertDelMoveL (ZAVL p (P ll le lr) hl _ r hr) = case popRP ll le lr of+ UBT2(l,e) -> case l of+ E -> error "assertDelMoveL: Bug2" -- impossible+ Z _ _ _ -> ZAVL p l DECINT1(hl) e r hr+ _ -> ZAVL p l hl e r hr+++-- | Attempts to delete the current element and move one step left.+-- This function returns 'Nothing' if the current element is already the leftmost element.+--+-- Complexity: O(1) average, O(log n) worst case.+tryDelMoveL :: ZAVL e -> Maybe (ZAVL e)+tryDelMoveL (ZAVL p E _ _ r hr) = dR p r hr+ where dR EP _ _ = Nothing+ dR (LP p_ e_ r_ hr_) l_ hl_ = case spliceH l_ hl_ e_ r_ hr_ of UBT2(t,ht) -> dR p_ t ht+ dR (RP p_ e_ l_ hl_) r_ hr_ = Just $! ZAVL p_ l_ hl_ e_ r_ hr_+tryDelMoveL (ZAVL p (N ll le lr) hl _ r hr) = Just $! case popRN ll le lr of+ UBT2(l,e) -> case l of+ Z _ _ _ -> ZAVL p l DECINT1(hl) e r hr+ N _ _ _ -> ZAVL p l hl e r hr+ _ -> error "tryDelMoveL: Bug0" -- impossible+tryDelMoveL (ZAVL p (Z ll le lr) hl _ r hr) = Just $! case popRZ ll le lr of+ UBT2(l,e) -> case l of+ E -> ZAVL p l DECINT1(hl) e r hr -- Don't use E!!+ N _ _ _ -> error "tryDelMoveL: Bug1" -- impossible+ _ -> ZAVL p l hl e r hr+tryDelMoveL (ZAVL p (P ll le lr) hl _ r hr) = Just $! case popRP ll le lr of+ UBT2(l,e) -> case l of+ E -> error "tryDelMoveL: Bug2" -- impossible+ Z _ _ _ -> ZAVL p l DECINT1(hl) e r hr+ _ -> ZAVL p l hl e r hr+++-- | Deletes the current element and moves one step right.+-- This function raises an error if the current element is already the rightmost element.+--+-- Complexity: O(1) average, O(log n) worst case.+assertDelMoveR :: ZAVL e -> ZAVL e+assertDelMoveR (ZAVL p l hl _ E _ ) = dL p l hl+ where dL EP _ _ = error "delMoveR: Can't move right."+ dL (LP p_ e_ r_ hr_) l_ hl_ = ZAVL p_ l_ hl_ e_ r_ hr_+ dL (RP p_ e_ l_ hl_) r_ hr_ = case spliceH l_ hl_ e_ r_ hr_ of UBT2(t,ht) -> dL p_ t ht+assertDelMoveR (ZAVL p l hl _ (N rl re rr) hr) = case popLN rl re rr of+ UBT2(e,r) -> case r of+ E -> error "delMoveR: Bug0" -- impossible+ Z _ _ _ -> ZAVL p l hl e r DECINT1(hr)+ _ -> ZAVL p l hl e r hr+assertDelMoveR (ZAVL p l hl _ (Z rl re rr) hr) = case popLZ rl re rr of+ UBT2(e,r) -> case r of+ E -> ZAVL p l hl e r DECINT1(hr) -- Don't use E!!+ P _ _ _ -> error "delMoveR: Bug1" -- impossible+ _ -> ZAVL p l hl e r hr+assertDelMoveR (ZAVL p l hl _ (P rl re rr) hr) = case popLP rl re rr of+ UBT2(e,r) -> case r of+ Z _ _ _ -> ZAVL p l hl e r DECINT1(hr)+ P _ _ _ -> ZAVL p l hl e r hr+ _ -> error "delMoveR: Bug2" -- impossible+++-- | Attempts to delete the current element and move one step right.+-- This function returns 'Nothing' if the current element is already the rightmost element.+--+-- Complexity: O(1) average, O(log n) worst case.+tryDelMoveR :: ZAVL e -> Maybe (ZAVL e)+tryDelMoveR (ZAVL p l hl _ E _ ) = dL p l hl+ where dL EP _ _ = Nothing+ dL (LP p_ e_ r_ hr_) l_ hl_ = Just $! ZAVL p_ l_ hl_ e_ r_ hr_+ dL (RP p_ e_ l_ hl_) r_ hr_ = case spliceH l_ hl_ e_ r_ hr_ of UBT2(t,ht) -> dL p_ t ht+tryDelMoveR (ZAVL p l hl _ (N rl re rr) hr) = Just $! case popLN rl re rr of+ UBT2(e,r) -> case r of+ E -> error "tryDelMoveR: Bug0" -- impossible+ Z _ _ _ -> ZAVL p l hl e r DECINT1(hr)+ _ -> ZAVL p l hl e r hr+tryDelMoveR (ZAVL p l hl _ (Z rl re rr) hr) = Just $! case popLZ rl re rr of+ UBT2(e,r) -> case r of+ E -> ZAVL p l hl e r DECINT1(hr) -- Don't use E!!+ P _ _ _ -> error "tryDelMoveR: Bug1" -- impossible+ _ -> ZAVL p l hl e r hr+tryDelMoveR (ZAVL p l hl _ (P rl re rr) hr) = Just $! case popLP rl re rr of+ UBT2(e,r) -> case r of+ Z _ _ _ -> ZAVL p l hl e r DECINT1(hr)+ P _ _ _ -> ZAVL p l hl e r hr+ _ -> error "tryDelMoveR: Bug2" -- impossible+++-- | Delete all elements to the left of the current element.+--+-- Complexity: O(log n)+delAllL :: ZAVL e -> ZAVL e+delAllL (ZAVL p l hl e r hr) =+ let hE = case COMPAREUINT hl hr of -- Calculate relative offset and use this as height of empty tree+ LT -> SUBINT(hl,height l)+ EQ -> SUBINT(hr,height r)+ GT -> SUBINT(hr,height r)+ p_ = noRP p -- remove right paths (current element becomes leftmost)+ in p_ `seq` ZAVL p_ E hE e r hr++-- | Delete all elements to the right of the current element.+--+-- Complexity: O(log n)+delAllR :: ZAVL e -> ZAVL e+delAllR (ZAVL p l hl e r hr) =+ let hE = case COMPAREUINT hl hr of -- Calculate relative offset and use this as height of empty tree+ LT -> SUBINT(hl,height l)+ EQ -> SUBINT(hl,height l)+ GT -> SUBINT(hr,height r)+ p_ = noLP p -- remove left paths (current element becomes rightmost)+ in p_ `seq` ZAVL p_ l hl e E hE++-- | Similar to 'delAllL', in that all elements to the left of the current element are deleted,+-- but this function also closes the tree in the process.+--+-- Complexity: O(log n)+delAllCloseL :: ZAVL e -> AVL e+delAllCloseL (ZAVL p _ _ e r hr) = case pushHL e r hr of UBT2(t,ht) -> closeNoRP p t ht++-- | Similar to 'delAllR', in that all elements to the right of the current element are deleted,+-- but this function also closes the tree in the process.+--+-- Complexity: O(log n)+delAllCloseR :: ZAVL e -> AVL e+delAllCloseR (ZAVL p l hl e _ _) = case pushHR l hl e of UBT2(t,ht) -> closeNoLP p t ht++-- | Similar to 'delAllCloseL', but in this case the current element and all+-- those to the left of the current element are deleted.+--+-- Complexity: O(log n)+delAllIncCloseL :: ZAVL e -> AVL e+delAllIncCloseL (ZAVL p _ _ _ r hr) = closeNoRP p r hr++-- | Similar to 'delAllCloseR', but in this case the current element and all+-- those to the right of the current element are deleted.+--+-- Complexity: O(log n)+delAllIncCloseR :: ZAVL e -> AVL e+delAllIncCloseR (ZAVL p l hl _ _ _) = closeNoLP p l hl++-- | Counts the number of elements to the left of the current element+-- (this does not include the current element).+--+-- Complexity: O(n), where n is the count result.+sizeL :: ZAVL e -> Int+sizeL (ZAVL p l _ _ _ _) = addSizeRP (size l) p++-- | Counts the number of elements to the right of the current element+-- (this does not include the current element).+--+-- Complexity: O(n), where n is the count result.+sizeR :: ZAVL e -> Int+sizeR (ZAVL p _ _ _ r _) = addSizeLP (size r) p++-- | Counts the total number of elements in a ZAVL.+--+-- Complexity: O(n)+sizeZAVL :: ZAVL e -> Int+sizeZAVL (ZAVL p l _ _ r _) = addSizeP (addSize (addSize 1 l) r) p+++{-------------------- BAVL stuff below ----------------------------------}++-- | A 'BAVL' is like a pointer reference to somewhere inside an 'AVL' tree. It may be either \"full\"+-- (meaning it points to an actual tree node containing an element), or \"empty\" (meaning it+-- points to the position in a tree where an element was expected but wasn\'t found).+data BAVL e = BAVL (AVL e) (BinPath e)++-- | Search for an element in a /sorted/ 'AVL' tree using the supplied selector.+-- Returns a \"full\" 'BAVL' if a matching element was found, otherwise returns an \"empty\" 'BAVL'.+--+-- Complexity: O(log n)+genOpenBAVL :: (e -> Ordering) -> AVL e -> BAVL e+{-# INLINE genOpenBAVL #-}+genOpenBAVL c t = bp `seq` BAVL t bp+ where bp = genOpenPath c t++-- | Returns the original tree, extracted from the 'BAVL'. Typically you will not need this, as+-- the original tree will still be in scope in most cases.+--+-- Complexity: O(1)+closeBAVL :: BAVL e -> AVL e+{-# INLINE closeBAVL #-}+closeBAVL (BAVL t _) = t++-- | Returns 'True' if the 'BAVL' is \"full\" (a corresponding element was found).+--+-- Complexity: O(1)+fullBAVL :: BAVL e -> Bool+{-# INLINE fullBAVL #-}+fullBAVL (BAVL _ (FullBP _ _)) = True+fullBAVL (BAVL _ (EmptyBP _ )) = False++-- | Returns 'True' if the 'BAVL' is \"empty\" (no corresponding element was found).+--+-- Complexity: O(1)+emptyBAVL :: BAVL e -> Bool+{-# INLINE emptyBAVL #-}+emptyBAVL (BAVL _ (FullBP _ _)) = False+emptyBAVL (BAVL _ (EmptyBP _ )) = True++-- | Read the element value from a \"full\" 'BAVL'.+-- This function returns 'Nothing' if applied to an \"empty\" 'BAVL'.+--+-- Complexity: O(1)+tryReadBAVL :: BAVL e -> Maybe e+{-# INLINE tryReadBAVL #-}+tryReadBAVL (BAVL _ (FullBP _ e)) = Just e+tryReadBAVL (BAVL _ (EmptyBP _ )) = Nothing++-- | Read the element value from a \"full\" 'BAVL'.+-- This function raises an error if applied to an \"empty\" 'BAVL'.+--+-- Complexity: O(1)+readFullBAVL :: BAVL e -> e+{-# INLINE readFullBAVL #-}+readFullBAVL (BAVL _ (FullBP _ e)) = e+readFullBAVL (BAVL _ (EmptyBP _ )) = error "readFullBAVL: Empty BAVL."++-- | If the 'BAVL' is \"full\", this function returns the original tree with the corresponding+-- element replaced by the new element (first argument). If it\'s \"empty\" the original tree is returned+-- with the new element inserted.+--+-- Complexity: O(log n)+pushBAVL :: e -> BAVL e -> AVL e+{-# INLINE pushBAVL #-}+pushBAVL e (BAVL t (FullBP p _)) = writePath p e t+pushBAVL e (BAVL t (EmptyBP p )) = insertPath p e t++-- | If the 'BAVL' is \"full\", this function returns the original tree with the corresponding+-- element deleted. If it\'s \"empty\" the original tree is returned unmodified.+--+-- Complexity: O(log n) (or O(1) for an empty 'BAVL')+deleteBAVL :: BAVL e -> AVL e+{-# INLINE deleteBAVL #-}+deleteBAVL (BAVL t (FullBP p _)) = deletePath p t+deleteBAVL (BAVL t (EmptyBP _ )) = t++-- | Converts a \"full\" 'BAVL' as a 'ZAVL'. Raises an error if applied to an \"empty\" 'BAVL'.+--+-- Complexity: O(log n)+fullBAVLtoZAVL :: BAVL e -> ZAVL e+fullBAVLtoZAVL (BAVL t (FullBP i _)) = openFull i EP L(0) t -- Relative heights !!+fullBAVLtoZAVL (BAVL _ (EmptyBP _ )) = error "fullBAVLtoZAVL: Empty BAVL."+-- Local Utility+openFull :: UINT -> (Path e) -> UINT -> AVL e -> ZAVL e+openFull _ _ _ E = error "openFull: Bug0."+openFull i p h (N l e r) = case sel i of+ LT -> let p_ = LP p e r DECINT1(h) in p_ `seq` openFull (goL i) p_ DECINT2(h) l+ EQ -> ZAVL p l DECINT2(h) e r DECINT1(h)+ GT -> let p_ = RP p e l DECINT2(h) in p_ `seq` openFull (goR i) p_ DECINT1(h) r+openFull i p h (Z l e r) = case sel i of+ LT -> let p_ = LP p e r DECINT1(h) in p_ `seq` openFull (goL i) p_ DECINT1(h) l+ EQ -> ZAVL p l DECINT1(h) e r DECINT1(h)+ GT -> let p_ = RP p e l DECINT1(h) in p_ `seq` openFull (goR i) p_ DECINT1(h) r+openFull i p h (P l e r) = case sel i of+ LT -> let p_ = LP p e r DECINT2(h) in p_ `seq` openFull (goL i) p_ DECINT1(h) l+ EQ -> ZAVL p l DECINT1(h) e r DECINT2(h)+ GT -> let p_ = RP p e l DECINT1(h) in p_ `seq` openFull (goR i) p_ DECINT2(h) r++-- | Converts an \"empty\" 'BAVL' as a 'PAVL'. Raises an error if applied to a \"full\" 'BAVL'.+--+-- Complexity: O(log n)+emptyBAVLtoPAVL :: BAVL e -> PAVL e+emptyBAVLtoPAVL (BAVL _ (FullBP _ _)) = error "emptyBAVLtoPAVL: Full BAVL."+emptyBAVLtoPAVL (BAVL t (EmptyBP i )) = openEmpty i EP L(0) t -- Relative heights !!+-- Local Utility+openEmpty :: UINT -> (Path e) -> UINT -> AVL e -> PAVL e+openEmpty _ p h E = PAVL p h -- Test for i==0 ??+openEmpty i p h (N l e r) = case sel i of+ LT -> let p_ = LP p e r DECINT1(h) in p_ `seq` openEmpty (goL i) p_ DECINT2(h) l+ EQ -> error "openEmpty: Bug0"+ GT -> let p_ = RP p e l DECINT2(h) in p_ `seq` openEmpty (goR i) p_ DECINT1(h) r+openEmpty i p h (Z l e r) = case sel i of+ LT -> let p_ = LP p e r DECINT1(h) in p_ `seq` openEmpty (goL i) p_ DECINT1(h) l+ EQ -> error "openEmpty: Bug1"+ GT -> let p_ = RP p e l DECINT1(h) in p_ `seq` openEmpty (goR i) p_ DECINT1(h) r+openEmpty i p h (P l e r) = case sel i of+ LT -> let p_ = LP p e r DECINT2(h) in p_ `seq` openEmpty (goL i) p_ DECINT1(h) l+ EQ -> error "openEmpty: Bug2"+ GT -> let p_ = RP p e l DECINT1(h) in p_ `seq` openEmpty (goR i) p_ DECINT2(h) r+++-- | Converts a 'BAVL' to either a 'PAVL' or 'ZAVL' (depending on whether it is \"empty\" or \"full\").+--+-- Complexity: O(log n)+anyBAVLtoEither :: BAVL e -> Either (PAVL e) (ZAVL e)+anyBAVLtoEither (BAVL t (FullBP i _)) = Right (openFull i EP L(0) t) -- Relative heights !!+anyBAVLtoEither (BAVL t (EmptyBP i )) = Left (openEmpty i EP L(0) t) -- Relative heights !!
+ Data/Tree/AVLX.hs view
@@ -0,0 +1,42 @@+-----------------------------------------------------------------------------+-- |+-- Module : Data.Tree.AVLX+-- Copyright : (c) Adrian Hey 2004,2005,2006,2007+-- License : BSD3+--+-- Maintainer : http://homepages.nildram.co.uk/~ahey/em.png+-- Stability : unstable+-- Portability : portable+--+-- This module exports everything AVL, for test purposes only.+-- Not for general consumption.+-----------------------------------------------------------------------------+module Data.Tree.AVLX+(module Data.Tree.AVL -- The normal user AVL API+-- + Normally Hidden Modules+,module Data.Tree.AVL.Internals.HeightUtils+,module Data.Tree.AVL.Internals.DelUtils+,module Data.Tree.AVL.Internals.HPush+,module Data.Tree.AVL.Internals.HSet+,module Data.Tree.AVL.Internals.HAVL+,module Data.Tree.AVL.Internals.HJoin+,module Data.Tree.AVL.Internals.BinPath+,module Data.Tree.AVL.Test.Utils+,module Data.Tree.AVL.Test.Counter+,AVL(..)+) where+++import Data.Tree.AVL hiding (AVL)+import Data.Tree.AVL.Types(AVL(..)) -- We want constructors exposed++import Data.Tree.AVL.Internals.HeightUtils+import Data.Tree.AVL.Internals.DelUtils+import Data.Tree.AVL.Internals.HPush+import Data.Tree.AVL.Internals.HSet+import Data.Tree.AVL.Internals.HAVL+import Data.Tree.AVL.Internals.HJoin+import Data.Tree.AVL.Internals.BinPath+import Data.Tree.AVL.Test.Utils hiding (isBalanced,isSorted,isSortedOK,minElements,maxElements)+import Data.Tree.AVL.Test.Counter+
+ LICENSE view
@@ -0,0 +1,31 @@+See the AUTHORS file for a list of copyright holders.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are+met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of the copyright holders nor the names of+ other contributors may be used to endorse or promote products+ derived from this software without specific prior written+ permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.+
+ Setup.hs view
@@ -0,0 +1,3 @@+#!/usr/bin/runhaskell+import Distribution.Simple+main = defaultMain
+ Test/Test.hs view
@@ -0,0 +1,6 @@+-- Run me after installation to test AVL lib. +-- Takes a long time! +import Data.Tree.AVL.Test.AllTests(allTests) + +main :: IO () +main = allTests
+ include/ghcdefs.h view
@@ -0,0 +1,25 @@+#define UINT Int#+#define COMPAREUINT compareInt#+#define INCINT1(n) ((n)+#1#)+#define INCINT2(n) ((n)+#2#)+#define INCINT3(n) ((n)+#3#)+#define INCINT4(n) ((n)+#4#)+#define DECINT1(n) ((n)-#1#)+#define DECINT2(n) ((n)-#2#)+#define DECINT3(n) ((n)-#3#)+#define DECINT4(n) ((n)-#4#)+#define SUBINT(m,n) ((m)-#(n))+#define ADDINT(m,n) ((m)+#(n))+#define L(n) n#+#define LEQ <=#+#define LTN <#+#define EQL ==#+#define ASINT(n) (I# (n))+#define NEGATE(n) (0#-#(n))+#define _MODULO_(n,m) (modInt# n m)+#define UBT2(y,z) (# y,z #)+#define UBT3(x,y,z) (# x,y,z #)+#define UBT4(w,x,y,z) (# w,x,y,z #)+#define UBT5(v,w,x,y,z) (# v,w,x,y,z #)+#define IS_NEG(n) (n <# 0#)+#define LEFT_JUSTIFY_INT(m,n) (iShiftL# (m) (32#-#n))
+ include/h98defs.h view
@@ -0,0 +1,25 @@+#define UINT Int+#define COMPAREUINT compare+#define INCINT1(n) ((n) + 1)+#define INCINT2(n) ((n) + 2)+#define INCINT3(n) ((n) + 3)+#define INCINT4(n) ((n) + 4)+#define DECINT1(n) ((n) - 1)+#define DECINT2(n) ((n) - 2)+#define DECINT3(n) ((n) - 3)+#define DECINT4(n) ((n) - 4)+#define SUBINT(m,n) ((m)- (n))+#define ADDINT(m,n) ((m)+ (n))+#define L(n) n+#define LEQ <=+#define LTN <+#define EQL ==+#define ASINT(n) (n)+#define NEGATE(n) (0 - (n))+#define _MODULO_(n,m) (n `mod` m)+#define UBT2(y,z) ( y,z )+#define UBT3(x,y,z) ( x,y,z )+#define UBT4(w,x,y,z) ( w,x,y,z )+#define UBT5(v,w,x,y,z) ( v,w,x,y,z )+#define IS_NEG(n) (n < 0)+#define LEFT_JUSTIFY_INT(m,n) (shiftL (m) (32-n))