diff --git a/AvlTree.cabal b/AvlTree.cabal --- a/AvlTree.cabal +++ b/AvlTree.cabal @@ -1,68 +1,81 @@ -Name: AvlTree -Version: 4.2 -Cabal-Version: >= 1.2 -Build-Type: Simple -License: BSD3 -License-File: LICENSE -Copyright: (c) Adrian Hey 2004-2008 -Author: Adrian Hey -Maintainer: Adrian Hey http://homepages.nildram.co.uk/~ahey/em.png -Stability: Stable -Homepage: -Package-Url: -Synopsis: Balanced binary trees using the AVL algorithm. -Description: A comprehensive and efficient implementation of AVL trees. The raw AVL - API has been designed with efficiency and generality in mind, not elagance or - safety. 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.3, GHC == 6.8.2, GHC == 6.8.1 -Data-Files: -Extra-Source-Files: AUTHORS, CHANGELOG, MasterTable.txt, Test/Test.hs, include/ghcdefs.h, include/h98defs.h -Extra-Tmp-Files: +cabal-version: 2.2 +name: AvlTree +version: 4.3 +license: BSD-3-Clause +license-file: LICENSE +copyright: (c) Adrian Hey 2004-2008 +maintainer: Bodigrim +author: Adrian Hey +tested-with: + ghc ==8.4.4 ghc ==8.6.5 ghc ==8.8.4 ghc ==8.10.1 ghc ==9.0.2 + ghc ==9.2.8 ghc ==9.4.8 ghc ==9.6.7 ghc ==9.8.4 ghc ==9.10.3 + ghc ==9.12.2 ghc ==9.14.1 -Library - Buildable: True - Build-Depends: base, COrdering >= 2.3 - 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.Height, - Data.Tree.AVL.Split, - Data.Tree.AVL.Types, - Data.Tree.AVL.Write, - Data.Tree.AVL.Zipper, - Data.Tree.AVL.BinPath, - Data.Tree.AVL.Deprecated, - Data.Tree.AVL.Test.Utils, - 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 - Extensions: CPP - Hs-Source-Dirs: . - Build-Tools: - Ghc-Options: -Wall - 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: +synopsis: Balanced binary trees using the AVL algorithm. +description: + A comprehensive and efficient implementation of AVL trees. The raw AVL + API has been designed with efficiency and generality in mind, not elagance or + safety. 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 +build-type: Simple +extra-source-files: include/ghcdefs.h +extra-doc-files: + AUTHORS + CHANGELOG.md + MasterTable.txt + +source-repository head + type: git + location: https://github.com/Bodigrim/AvlTree.git + +library + exposed-modules: + Data.Tree.AVL + Data.Tree.AVL.Internals.Types + + hs-source-dirs: src + other-modules: + Data.Tree.AVL.Write + Data.Tree.AVL.Zipper + Data.Tree.AVL.Delete + Data.Tree.AVL.Join + Data.Tree.AVL.List + Data.Tree.AVL.Push + Data.Tree.AVL.Internals.HAVL + Data.Tree.AVL.Read + Data.Tree.AVL.Set + Data.Tree.AVL.Size + Data.Tree.AVL.Height + Data.Tree.AVL.Split + Data.Tree.AVL.Utils + Data.Tree.AVL.BinPath + Data.Tree.AVL.Internals.DelUtils + Data.Tree.AVL.Internals.HJoin + Data.Tree.AVL.Internals.HPush + Data.Tree.AVL.Internals.HSet + Data.Tree.AVL.Test.Utils + + default-language: Haskell2010 + default-extensions: CPP MagicHash UnboxedTuples + include-dirs: include + ghc-options: -Wall + build-depends: + base >=4.11 && <5, + COrdering >=2.3 && <2.4 + +test-suite AvlTree-tests + type: exitcode-stdio-1.0 + main-is: AllTests.hs + hs-source-dirs: tests + other-modules: Utils + default-language: Haskell2010 + default-extensions: CPP MagicHash UnboxedTuples + include-dirs: include + ghc-options: -Wall + build-depends: + base >=4.11 && <5, + COrdering >=2.3 && <2.4, + AvlTree diff --git a/CHANGELOG b/CHANGELOG deleted file mode 100644 --- a/CHANGELOG +++ /dev/null @@ -1,47 +0,0 @@ -2.4 ---- -* Initial Hackage/Cabal release. - Version set to 2.4 to distinguish from the 2.3 (non-cabal) release on my home page. - -3.0 ---- -* Included MasterTable.txt in the distro. -* Eq and Ord Instances now based on strict structural equality (derived) -* Exposed height related functions - -3.1 ---- -* Exposed BinPath primitives. -* Removed AVL tree based sorts. -* Removed Data.Map/Set conversions. This eliminates the containers package dependency. -* Removed link to Haskell wiki homepage as this will never be done. -* Removed link to maintainer email. - -3.2 ---- -No code changes, just reclaiming ownership and bumping version No. - -4.0 ---- -* Changed to derived Read/Show instances (instead of via lists). - Hence the instances are incompatible with earlier versions. -* Added: - genDisjointUnion,testGenDisjointUnion - genVenn,testGenVenn - genVennMaybe,testGenVennMaybe - genVennToList, - genVennAsList - genVennMaybeToList - genVennMaybeAsList -* Added UBT6 cpp macro to ghcdefs/h98defs - -4.1 ---- -* Added missing strictness to genVenn,genVennMaybe - -4.2 ---- -* A lot of function renaming (old names still available but deprecated). -* Gather all deprecations in 1 new module: Data.Tree.AVL.Deprecated -* Added findEmptyPath,nub,nubBy - diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,51 @@ +# 4.3 + +* Remove previously deprecated functions. +* Class `Typeable1` is no longer a thing. + +# 4.2 + +* A lot of function renaming (old names still available but deprecated). +* Gather all deprecations in 1 new module: `Data.Tree.AVL.Deprecated`. +* Added `findEmptyPath`, `nub`, `nubBy`. + +# 4.1 + +* Added missing strictness to `genVenn`, `genVennMaybe`. + +# 4.0 + +* Changed to derived `Read` / `Show` instances (instead of via lists). + Hence the instances are incompatible with earlier versions. +* Added: + * `genDisjointUnion`,`testGenDisjointUnion`, + * `genVenn`,`testGenVenn`, + * `genVennMaybe`,`testGenVennMaybe`, + * `genVennToList`, + * `genVennAsList`, + * `genVennMaybeToList`, + * `genVennMaybeAsList`. +* Added `UBT6` cpp macro to `ghcdefs.h` / `h98defs.h`. + +# 3.2 + +* No code changes, just reclaiming ownership and bumping version No. + +# 3.1 + +* Exposed `BinPath` primitives. +* Removed AVL tree based sorts. +* Removed `Data.Map` / `Data.Set` conversions. This eliminates the `containers` package dependency. +* Removed link to Haskell wiki homepage as this will never be done. +* Removed link to maintainer email. + +# 3.0 + +* Included `MasterTable.txt` in the distro. +* `Eq` and `Ord` Instances now based on strict structural equality (derived). +* Exposed height-related functions. + +# 2.4 + +* Initial Hackage/Cabal release. + Version set to 2.4 to distinguish from the 2.3 (non-cabal) release on my home page. diff --git a/Data/Tree/AVL.hs b/Data/Tree/AVL.hs deleted file mode 100644 --- a/Data/Tree/AVL.hs +++ /dev/null @@ -1,109 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} ------------------------------------------------------------------------------ --- | --- Module : Data.Tree.AVL --- Copyright : (c) Adrian Hey 2004,2008 --- 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 --- @ --- ------------------------------------------------------------------------------ -module Data.Tree.AVL -(module Data.Tree.AVL.Types, - module Data.Tree.AVL.Read, - module Data.Tree.AVL.Write, - module Data.Tree.AVL.Push, - module Data.Tree.AVL.Delete, - module Data.Tree.AVL.Set, - module Data.Tree.AVL.Zipper, - module Data.Tree.AVL.Join, - module Data.Tree.AVL.List, - module Data.Tree.AVL.Split, - module Data.Tree.AVL.Size, - module Data.Tree.AVL.Height, - - -- * Low level Binary Path utilities. - -- | This is the low level (unsafe) API used by the 'BAVL' type. - BinPath(..),findFullPath,findEmptyPath,openPath,openPathWith,readPath,writePath,insertPath,deletePath, - - -- * Correctness checking. - isBalanced,isSorted,isSortedOK, - - -- * Tree parameter utilities. - minElements,maxElements, - - module Data.Tree.AVL.Deprecated, -) where - -import Prelude hiding (map) -- so haddock finds the symbols there - -import Data.Tree.AVL.Types hiding (E,N,P,Z) -import Data.Tree.AVL.Size -import Data.Tree.AVL.Height -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) -import Data.Tree.AVL.BinPath(BinPath(..),findFullPath,findEmptyPath,openPath,openPathWith,readPath,writePath,insertPath) -import Data.Tree.AVL.Internals.DelUtils(deletePath) -import Data.Tree.AVL.Deprecated -#if __GLASGOW_HASKELL__ > 604 -import Data.Traversable -#endif - - -{- These are now derived since switch to structural equality! --- | 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 = map -- The lazy version. - -#if __GLASGOW_HASKELL__ > 604 -instance Traversable AVL where - traverse = traverseAVL -#endif diff --git a/Data/Tree/AVL/BinPath.hs b/Data/Tree/AVL/BinPath.hs deleted file mode 100644 --- a/Data/Tree/AVL/BinPath.hs +++ /dev/null @@ -1,392 +0,0 @@ -{-# 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. 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. --- --- See the BAVL type in Data.Tree.AVL.Zipper module for a safer wrapper round these --- functions. ------------------------------------------------------------------------------ -module Data.Tree.AVL.BinPath - (BinPath(..),findFullPath,findEmptyPath,openPath,openPathWith,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 - --- | A BinPath is full if the search succeeded, empty otherwise. -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) -findFullPath :: (e -> Ordering) -> AVL e -> UINT --- ?? What about strictness if UINT is boxed (i.e. non-ghc)? -findFullPath 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 - --- | Find the path to a non-existant AVL tree element, returns -1 (invalid path) if element is found --- --- Complexity: O(log n) -findEmptyPath :: (e -> Ordering) -> AVL e -> UINT --- ?? What about strictness if UINT is boxed (i.e. non-ghc)? -findEmptyPath c t = find L(1) L(0) t where - find _ i E = 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 -> L(-1) - 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) -openPath :: (e -> Ordering) -> AVL e -> BinPath e -openPath 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) -openPathWith :: (e -> COrdering a) -> AVL e -> BinPath a -openPathWith 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 -------------------------- ------------------------------------------------------------------------ - diff --git a/Data/Tree/AVL/Delete.hs b/Data/Tree/AVL/Delete.hs deleted file mode 100644 --- a/Data/Tree/AVL/Delete.hs +++ /dev/null @@ -1,533 +0,0 @@ -{-# 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 - delete,deleteFast,deleteIf,deleteMaybe, - - -- * \"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 - assertPop,tryPop,assertPopMaybe,tryPopMaybe,assertPopIf,tryPopIf, -) where - -import Prelude -- so haddock finds the symbols there - -import Data.COrdering -import Data.Tree.AVL.Types(AVL(..)) -import Data.Tree.AVL.BinPath(BinPath(..),findFullPath,openPathWith,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) -delete :: (e -> Ordering) -> AVL e -> AVL e -delete c t = case findFullPath c t of - L(-1) -> t -- Not found, p<0 - p -> 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) -deleteIf :: (e -> COrdering Bool) -> AVL e -> AVL e -deleteIf c t = case openPathWith 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) -deleteMaybe :: (e -> COrdering (Maybe e)) -> AVL e -> AVL e -deleteMaybe c t = case openPathWith c t of - FullBP p Nothing -> deletePath p t - FullBP p (Just e) -> writePath p e t - _ -> t - --- | Functionally identical to 'delete', 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) -deleteFast :: (e -> Ordering) -> AVL e -> AVL e --- This was the old delete so it's been tested OK, but as a different name. -deleteFast c = delete' where - delete' E = E - delete' (N l e r) = delN l e r - delete' (Z l e r) = delZ l e r - delete' (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) ------------------------------------------------------------------------ -------------------------- deleteFast 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) -assertPop :: (e -> COrdering a) -> AVL e -> (a,AVL e) -assertPop c = genPop_ where - genPop_ E = error "assertPop: 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 "assertPop: 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 "assertPop: 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 "assertPop: 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 "assertPop: 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) ------------------------------------------------------------------------ ------------------------- assertPop Ends Here ----------------------- ------------------------------------------------------------------------ - --- | Similar to 'genPop', but this function returns 'Nothing' if the search fails. --- --- Complexity: O(log n) -tryPop :: (e -> COrdering a) -> AVL e -> Maybe (a,AVL e) -tryPop c t = case openPathWith 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) -assertPopMaybe :: (e -> COrdering (a,Maybe e)) -> AVL e -> (a,AVL e) -assertPopMaybe c t = case openPathWith 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 "assertPopMaybe: element not found." - --- | Similar to 'assertPopMaybe', but returns 'Nothing' if the search fails. --- --- Complexity: O(log n) -tryPopMaybe :: (e -> COrdering (a,Maybe e)) -> AVL e -> Maybe (a,AVL e) -tryPopMaybe c t = case openPathWith 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 'assertPopMaybe'. 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) -assertPopIf :: (e -> COrdering (a,Bool)) -> AVL e -> (a,AVL e) -assertPopIf c t = case openPathWith c t of - FullBP _ (a,False) -> (a,t) - FullBP pth (a,True ) -> let t' = deletePath pth t in t' `seq` (a,t') - _ -> error "assertPopIf: element not found." - --- | Similar to 'genPopIf', but returns 'Nothing' if the search fails. --- --- Complexity: O(log n) -tryPopIf :: (e -> COrdering (a,Bool)) -> AVL e -> Maybe (a,AVL e) -tryPopIf c t = case openPathWith 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 - diff --git a/Data/Tree/AVL/Deprecated.hs b/Data/Tree/AVL/Deprecated.hs deleted file mode 100644 --- a/Data/Tree/AVL/Deprecated.hs +++ /dev/null @@ -1,683 +0,0 @@ -{-# OPTIONS_GHC -fglasgow-exts #-} ------------------------------------------------------------------------------ --- | --- Module : Data.Tree.AVL.Deprecated --- Copyright : (c) Adrian Hey 2004,2008 --- License : BSD3 --- --- Maintainer : http://homepages.nildram.co.uk/~ahey/em.png --- Stability : unstable --- Portability : portable ------------------------------------------------------------------------------ -module Data.Tree.AVL.Deprecated -(-- * Deprecated - - -- ** Deprecated names - -- | These functions are all still available, but with more sensible names. - -- They will dissapear on the next major version so you should amend your code - -- accordingly soon. - - genUnion,genUnionMaybe,genDisjointUnion,genUnions, - genDifference,genDifferenceMaybe,genSymDifference, - genIntersection,genIntersectionMaybe, - genIntersectionToListL,genIntersectionAsListL, - genIntersectionMaybeToListL,genIntersectionMaybeAsListL, - genVenn,genVennMaybe, - genVennToList,genVennAsList, - genVennMaybeToList,genVennMaybeAsList, - genIsSubsetOf,genIsSubsetOfBy, - - genAssertRead,genTryRead,genTryReadMaybe,genDefaultRead,genContains, - - genWrite,genWriteFast,genTryWrite,genWriteMaybe,genTryWriteMaybe, - - genDel,genDelFast,genDelIf,genDelMaybe, - genAssertPop,genTryPop,genAssertPopMaybe,genTryPopMaybe,genAssertPopIf,genTryPopIf, - - genPush,genPush',genPushMaybe,genPushMaybe', - - genAsTree, - - genForkL,genForkR,genFork, - genTakeLE,genDropGT, - genTakeLT,genDropGE, - genTakeGT,genDropLE, - genTakeGE,genDropLT, - - genAssertOpen,genTryOpen, - genTryOpenGE,genTryOpenLE, - genOpenEither, - genOpenBAVL, - - genFindPath,genOpenPath,genOpenPathWith, - - fastAddSize, - - reverseAVL,mapAVL,mapAVL', - mapAccumLAVL ,mapAccumRAVL , - mapAccumLAVL' ,mapAccumRAVL' , -#ifdef __GLASGOW_HASKELL__ - mapAccumLAVL'',mapAccumRAVL'', -#endif - replicateAVL, - filterAVL,mapMaybeAVL, - partitionAVL, - foldrAVL,foldrAVL',foldr1AVL,foldr1AVL',foldr2AVL,foldr2AVL', - foldlAVL,foldlAVL',foldl1AVL,foldl1AVL',foldl2AVL,foldl2AVL', - foldrAVL_UINT, - - findPath, - -{- - -- ** Deprecated functions - -- | Any functions listed here are deprecated, with no direct replacement. - -- They will continue to live \"forever\" here, but should not be used - -- (ideally). --} - -) where - -import Prelude hiding (reverse,map,replicate,filter,foldr,foldr1,foldl,foldl1) -- so haddock finds the symbols there - -import Data.COrdering(COrdering) -import Data.Tree.AVL.Types(AVL) -import Data.Tree.AVL.Set -import Data.Tree.AVL.Read -import Data.Tree.AVL.Write -import Data.Tree.AVL.Delete -import Data.Tree.AVL.Push -import Data.Tree.AVL.Split -import Data.Tree.AVL.List -import Data.Tree.AVL.Zipper -import Data.Tree.AVL.BinPath -import Data.Tree.AVL.Size - -#ifdef __GLASGOW_HASKELL__ -import GHC.Base(Int#) -#include "ghcdefs.h" -#else -#include "h98defs.h" -#endif - -{-# DEPRECATED genUnion "This is now called union." #-} --- | This name is /deprecated/. Instead use 'union'. -genUnion :: (e -> e -> COrdering e) -> AVL e -> AVL e -> AVL e -genUnion = union -{-# INLINE genUnion #-} - -{-# DEPRECATED genUnionMaybe "This is now called unionMaybe." #-} --- | This name is /deprecated/. Instead use 'unionMaybe'. -genUnionMaybe :: (e -> e -> COrdering (Maybe e)) -> AVL e -> AVL e -> AVL e -genUnionMaybe = unionMaybe -{-# INLINE genUnionMaybe #-} - -{-# DEPRECATED genDisjointUnion "This is now called disjointUnion." #-} --- | This name is /deprecated/. Instead use 'disjointUnion'. -genDisjointUnion :: (e -> e -> Ordering) -> AVL e -> AVL e -> AVL e -genDisjointUnion = disjointUnion -{-# INLINE genDisjointUnion #-} - -{-# DEPRECATED genUnions "This is now called unions." #-} --- | This name is /deprecated/. Instead use 'unions'. -genUnions :: (e -> e -> COrdering e) -> [AVL e] -> AVL e -genUnions = unions -{-# INLINE genUnions #-} - -{-# DEPRECATED genDifference "This is now called difference." #-} --- | This name is /deprecated/. Instead use 'difference'. -genDifference :: (a -> b -> Ordering) -> AVL a -> AVL b -> AVL a -genDifference = difference -{-# INLINE genDifference #-} - -{-# DEPRECATED genDifferenceMaybe "This is now called differenceMaybe." #-} --- | This name is /deprecated/. Instead use 'differenceMaybe'. -genDifferenceMaybe :: (a -> b -> COrdering (Maybe a)) -> AVL a -> AVL b -> AVL a -genDifferenceMaybe = differenceMaybe -{-# INLINE genDifferenceMaybe #-} - -{-# DEPRECATED genSymDifference "This is now called symDifference." #-} --- | This name is /deprecated/. Instead use 'symDifference'. -genSymDifference :: (e -> e -> Ordering) -> AVL e -> AVL e -> AVL e -genSymDifference = symDifference -{-# INLINE genSymDifference #-} - -{-# DEPRECATED genIntersection "This is now called intersection." #-} --- | This name is /deprecated/. Instead use 'intersection'. -genIntersection :: (a -> b -> COrdering c) -> AVL a -> AVL b -> AVL c -genIntersection = intersection -{-# INLINE genIntersection #-} - -{-# DEPRECATED genIntersectionMaybe "This is now called intersectionMaybe." #-} --- | This name is /deprecated/. Instead use 'intersectionMaybe'. -genIntersectionMaybe :: (a -> b -> COrdering (Maybe c)) -> AVL a -> AVL b -> AVL c -genIntersectionMaybe = intersectionMaybe -{-# INLINE genIntersectionMaybe #-} - -{-# DEPRECATED genIntersectionToListL "This is now called intersectionToList." #-} --- | This name is /deprecated/. Instead use 'intersectionToList'. -genIntersectionToListL :: (a -> b -> COrdering c) -> AVL a -> AVL b -> [c] -> [c] -genIntersectionToListL = intersectionToList -{-# INLINE genIntersectionToListL #-} - -{-# DEPRECATED genIntersectionAsListL "This is now called intersectionAsList." #-} --- | This name is /deprecated/. Instead use 'intersectionAsList'. -genIntersectionAsListL :: (a -> b -> COrdering c) -> AVL a -> AVL b -> [c] -genIntersectionAsListL = intersectionAsList -{-# INLINE genIntersectionAsListL #-} - -{-# DEPRECATED genIntersectionMaybeToListL "This is now called intersectionMaybeToList." #-} --- | This name is /deprecated/. Instead use 'intersectionMaybeToList'. -genIntersectionMaybeToListL :: (a -> b -> COrdering (Maybe c)) -> AVL a -> AVL b -> [c] -> [c] -genIntersectionMaybeToListL = intersectionMaybeToList -{-# INLINE genIntersectionMaybeToListL #-} - -{-# DEPRECATED genIntersectionMaybeAsListL "This is now called intersectionMaybeAsList." #-} --- | This name is /deprecated/. Instead use 'intersectionMaybeAsList'. -genIntersectionMaybeAsListL :: (a -> b -> COrdering (Maybe c)) -> AVL a -> AVL b -> [c] -genIntersectionMaybeAsListL = intersectionMaybeAsList -{-# INLINE genIntersectionMaybeAsListL #-} - -{-# DEPRECATED genVenn "This is now called venn." #-} --- | This name is /deprecated/. Instead use 'venn'. -genVenn :: (a -> b -> COrdering c) -> AVL a -> AVL b -> (AVL a, AVL c, AVL b) -genVenn = venn -{-# INLINE genVenn #-} - -{-# DEPRECATED genVennMaybe "This is now called vennMaybe." #-} --- | This name is /deprecated/. Instead use 'vennMaybe'. -genVennMaybe :: (a -> b -> COrdering (Maybe c)) -> AVL a -> AVL b -> (AVL a, AVL c, AVL b) -genVennMaybe = vennMaybe -{-# INLINE genVennMaybe #-} - -{-# DEPRECATED genVennToList "This is now called vennToList." #-} --- | This name is /deprecated/. Instead use 'vennToList'. -genVennToList :: (a -> b -> COrdering c) -> [c] -> AVL a -> AVL b -> (AVL a, [c], AVL b) -genVennToList = vennToList -{-# INLINE genVennToList #-} - -{-# DEPRECATED genVennAsList "This is now called vennAsList." #-} --- | This name is /deprecated/. Instead use 'vennAsList'. -genVennAsList :: (a -> b -> COrdering c) -> AVL a -> AVL b -> (AVL a, [c], AVL b) -genVennAsList = vennAsList -{-# INLINE genVennAsList #-} - -{-# DEPRECATED genVennMaybeToList "This is now called vennMaybeToList." #-} --- | This name is /deprecated/. Instead use 'vennMaybeToList'. -genVennMaybeToList :: (a -> b -> COrdering (Maybe c)) -> [c] -> AVL a -> AVL b -> (AVL a, [c], AVL b) -genVennMaybeToList = vennMaybeToList -{-# INLINE genVennMaybeToList #-} - -{-# DEPRECATED genVennMaybeAsList "This is now called vennMaybeAsList." #-} --- | This name is /deprecated/. Instead use 'vennMaybeAsList'. -genVennMaybeAsList :: (a -> b -> COrdering (Maybe c)) -> AVL a -> AVL b -> (AVL a, [c], AVL b) -genVennMaybeAsList = vennMaybeAsList -{-# INLINE genVennMaybeAsList #-} - -{-# DEPRECATED genIsSubsetOf "This is now called isSubsetOf." #-} --- | This name is /deprecated/. Instead use 'isSubsetOf'. -genIsSubsetOf :: (a -> b -> Ordering) -> AVL a -> AVL b -> Bool -genIsSubsetOf = isSubsetOf -{-# INLINE genIsSubsetOf #-} - -{-# DEPRECATED genIsSubsetOfBy "This is now called isSubsetOfBy." #-} --- | This name is /deprecated/. Instead use 'isSubsetOfBy'. -genIsSubsetOfBy :: (a -> b -> COrdering Bool) -> AVL a -> AVL b -> Bool -genIsSubsetOfBy = isSubsetOfBy -{-# INLINE genIsSubsetOfBy #-} - -{-# DEPRECATED genAssertRead "This is now called assertRead." #-} --- | This name is /deprecated/. Instead use 'assertRead'. -genAssertRead :: AVL e -> (e -> COrdering a) -> a -genAssertRead = assertRead -{-# INLINE genAssertRead #-} - -{-# DEPRECATED genTryRead "This is now called tryRead." #-} --- | This name is /deprecated/. Instead use 'tryRead'. -genTryRead :: AVL e -> (e -> COrdering a) -> Maybe a -genTryRead = tryRead -{-# INLINE genTryRead #-} - -{-# DEPRECATED genTryReadMaybe "This is now called tryReadMaybe." #-} --- | This name is /deprecated/. Instead use 'tryReadMaybe'. -genTryReadMaybe :: AVL e -> (e -> COrdering (Maybe a)) -> Maybe a -genTryReadMaybe = tryReadMaybe -{-# INLINE genTryReadMaybe #-} - -{-# DEPRECATED genDefaultRead "This is now called defaultRead." #-} --- | This name is /deprecated/. Instead use 'defaultRead'. -genDefaultRead :: a -> AVL e -> (e -> COrdering a) -> a -genDefaultRead = defaultRead -{-# INLINE genDefaultRead #-} - -{-# DEPRECATED genContains "This is now called contains." #-} --- | This name is /deprecated/. Instead use 'contains'. -genContains :: AVL e -> (e -> Ordering) -> Bool -genContains = contains -{-# INLINE genContains #-} - -{-# DEPRECATED genWrite "This is now called write." #-} --- | This name is /deprecated/. Instead use 'write'. -genWrite :: (e -> COrdering e) -> AVL e -> AVL e -genWrite = write -{-# INLINE genWrite #-} - -{-# DEPRECATED genWriteFast "This is now called writeFast." #-} --- | This name is /deprecated/. Instead use 'writeFast'. -genWriteFast :: (e -> COrdering e) -> AVL e -> AVL e -genWriteFast = writeFast -{-# INLINE genWriteFast #-} - -{-# DEPRECATED genTryWrite "This is now called tryWrite." #-} --- | This name is /deprecated/. Instead use 'tryWrite'. -genTryWrite :: (e -> COrdering e) -> AVL e -> Maybe (AVL e) -genTryWrite = tryWrite -{-# INLINE genTryWrite #-} - -{-# DEPRECATED genWriteMaybe "This is now called writeMaybe." #-} --- | This name is /deprecated/. Instead use 'writeMaybe'. -genWriteMaybe :: (e -> COrdering (Maybe e)) -> AVL e -> AVL e -genWriteMaybe = writeMaybe -{-# INLINE genWriteMaybe #-} - -{-# DEPRECATED genTryWriteMaybe "This is now called tryWriteMaybe." #-} --- | This name is /deprecated/. Instead use 'tryWriteMaybe'. -genTryWriteMaybe :: (e -> COrdering (Maybe e)) -> AVL e -> Maybe (AVL e) -genTryWriteMaybe = tryWriteMaybe -{-# INLINE genTryWriteMaybe #-} - -{-# DEPRECATED genDel "This is now called delete." #-} --- | This name is /deprecated/. Instead use 'delete'. -genDel :: (e -> Ordering) -> AVL e -> AVL e -genDel = delete -{-# INLINE genDel #-} - -{-# DEPRECATED genDelFast "This is now called deleteFast." #-} --- | This name is /deprecated/. Instead use 'deleteFast'. -genDelFast :: (e -> Ordering) -> AVL e -> AVL e -genDelFast = deleteFast -{-# INLINE genDelFast #-} - -{-# DEPRECATED genDelIf "This is now called deleteIf." #-} --- | This name is /deprecated/. Instead use 'deleteIf'. -genDelIf :: (e -> COrdering Bool) -> AVL e -> AVL e -genDelIf = deleteIf -{-# INLINE genDelIf #-} - -{-# DEPRECATED genDelMaybe "This is now called deleteMaybe." #-} --- | This name is /deprecated/. Instead use 'deleteMaybe'. -genDelMaybe :: (e -> COrdering (Maybe e)) -> AVL e -> AVL e -genDelMaybe = deleteMaybe -{-# INLINE genDelMaybe #-} - -{-# DEPRECATED genAssertPop "This is now called assertPop." #-} --- | This name is /deprecated/. Instead use 'assertPop'. -genAssertPop :: (e -> COrdering a) -> AVL e -> (a,AVL e) -genAssertPop = assertPop -{-# INLINE genAssertPop #-} - -{-# DEPRECATED genTryPop "This is now called tryPop." #-} --- | This name is /deprecated/. Instead use 'tryPop'. -genTryPop :: (e -> COrdering a) -> AVL e -> Maybe (a,AVL e) -genTryPop = tryPop -{-# INLINE genTryPop #-} - -{-# DEPRECATED genAssertPopMaybe "This is now called assertPopMaybe." #-} --- | This name is /deprecated/. Instead use 'assertPopMaybe'. -genAssertPopMaybe :: (e -> COrdering (a,Maybe e)) -> AVL e -> (a,AVL e) -genAssertPopMaybe = assertPopMaybe -{-# INLINE genAssertPopMaybe #-} - -{-# DEPRECATED genTryPopMaybe "This is now called tryPopMaybe." #-} --- | This name is /deprecated/. Instead use 'tryPopMaybe'. -genTryPopMaybe :: (e -> COrdering (a,Maybe e)) -> AVL e -> Maybe (a,AVL e) -genTryPopMaybe = tryPopMaybe -{-# INLINE genTryPopMaybe #-} - -{-# DEPRECATED genAssertPopIf "This is now called assertPopIf." #-} --- | This name is /deprecated/. Instead use 'assertPopIf'. -genAssertPopIf :: (e -> COrdering (a,Bool)) -> AVL e -> (a,AVL e) -genAssertPopIf = assertPopIf -{-# INLINE genAssertPopIf #-} - -{-# DEPRECATED genTryPopIf "This is now called tryPopIf." #-} --- | This name is /deprecated/. Instead use 'tryPopIf'. -genTryPopIf :: (e -> COrdering (a,Bool)) -> AVL e -> Maybe (a,AVL e) -genTryPopIf = tryPopIf -{-# INLINE genTryPopIf #-} - -{-# DEPRECATED genPush "This is now called push." #-} --- | This name is /deprecated/. Instead use 'push'. -genPush :: (e -> COrdering e) -> e -> AVL e -> AVL e -genPush = push -{-# INLINE genPush #-} - -{-# DEPRECATED genPush' "This is now called push'." #-} --- | This name is /deprecated/. Instead use ' push''. -genPush' :: (e -> COrdering e) -> e -> AVL e -> AVL e -genPush' = push' -{-# INLINE genPush' #-} - -{-# DEPRECATED genPushMaybe "This is now called pushMaybe." #-} --- | This name is /deprecated/. Instead use 'pushMaybe'. -genPushMaybe :: (e -> COrdering (Maybe e)) -> e -> AVL e -> AVL e -genPushMaybe = pushMaybe -{-# INLINE genPushMaybe #-} - -{-# DEPRECATED genPushMaybe' "This is now called pushMaybe'." #-} --- | This name is /deprecated/. Instead use 'pushMaybe''. -genPushMaybe' :: (e -> COrdering (Maybe e)) -> e -> AVL e -> AVL e -genPushMaybe' = pushMaybe' -{-# INLINE genPushMaybe' #-} - -{-# DEPRECATED genAsTree "This is now called asTree." #-} --- | This name is /deprecated/. Instead use 'asTree'. -genAsTree :: (e -> e -> COrdering e) -> [e] -> AVL e -genAsTree = asTree -{-# INLINE genAsTree #-} - -{-# DEPRECATED genForkL "This is now called forkL." #-} --- | This name is /deprecated/. Instead use 'forkL'. -genForkL :: (e -> Ordering) -> AVL e -> (AVL e, AVL e) -genForkL = forkL -{-# INLINE genForkL #-} - -{-# DEPRECATED genForkR "This is now called forkR." #-} --- | This name is /deprecated/. Instead use 'forkR'. -genForkR :: (e -> Ordering) -> AVL e -> (AVL e, AVL e) -genForkR = forkR -{-# INLINE genForkR #-} - -{-# DEPRECATED genFork "This is now called fork." #-} --- | This name is /deprecated/. Instead use 'fork'. -genFork :: (e -> COrdering a) -> AVL e -> (AVL e, Maybe a, AVL e) -genFork = fork -{-# INLINE genFork #-} - -{-# DEPRECATED genTakeLE "This is now called takeLE." #-} --- | This name is /deprecated/. Instead use 'takeLE'. -genTakeLE :: (e -> Ordering) -> AVL e -> AVL e -genTakeLE = takeLE -{-# INLINE genTakeLE #-} - -{-# DEPRECATED genDropGT "This is now called dropGT." #-} --- | This name is /deprecated/. Instead use 'dropGT'. -genDropGT :: (e -> Ordering) -> AVL e -> AVL e -genDropGT = dropGT -{-# INLINE genDropGT #-} - -{-# DEPRECATED genTakeLT "This is now called takeLT." #-} --- | This name is /deprecated/. Instead use 'takeLT'. -genTakeLT :: (e -> Ordering) -> AVL e -> AVL e -genTakeLT = takeLT -{-# INLINE genTakeLT #-} - -{-# DEPRECATED genDropGE "This is now called dropGE." #-} --- | This name is /deprecated/. Instead use 'dropGE'. -genDropGE :: (e -> Ordering) -> AVL e -> AVL e -genDropGE = dropGE -{-# INLINE genDropGE #-} - -{-# DEPRECATED genTakeGT "This is now called takeGT." #-} --- | This name is /deprecated/. Instead use 'takeGT'. -genTakeGT :: (e -> Ordering) -> AVL e -> AVL e -genTakeGT = takeGT -{-# INLINE genTakeGT #-} - -{-# DEPRECATED genDropLE "This is now called dropLE." #-} --- | This name is /deprecated/. Instead use 'dropLE'. -genDropLE :: (e -> Ordering) -> AVL e -> AVL e -genDropLE = dropLE -{-# INLINE genDropLE #-} - -{-# DEPRECATED genTakeGE "This is now called takeGE." #-} --- | This name is /deprecated/. Instead use 'takeGE'. -genTakeGE :: (e -> Ordering) -> AVL e -> AVL e -genTakeGE = takeGE -{-# INLINE genTakeGE #-} - -{-# DEPRECATED genDropLT "This is now called dropLT." #-} --- | This name is /deprecated/. Instead use 'dropLT'. -genDropLT :: (e -> Ordering) -> AVL e -> AVL e -genDropLT = dropLT -{-# INLINE genDropLT #-} - -{-# DEPRECATED genAssertOpen "This is now called assertOpen." #-} --- | This name is /deprecated/. Instead use 'assertOpen'. -genAssertOpen :: (e -> Ordering) -> AVL e -> ZAVL e -genAssertOpen = assertOpen -{-# INLINE genAssertOpen #-} - -{-# DEPRECATED genTryOpen "This is now called tryOpen." #-} --- | This name is /deprecated/. Instead use 'tryOpen'. -genTryOpen :: (e -> Ordering) -> AVL e -> Maybe (ZAVL e) -genTryOpen = tryOpen -{-# INLINE genTryOpen #-} - -{-# DEPRECATED genTryOpenGE "This is now called tryOpenGE." #-} --- | This name is /deprecated/. Instead use 'tryOpenGE'. -genTryOpenGE :: (e -> Ordering) -> AVL e -> Maybe (ZAVL e) -genTryOpenGE = tryOpenGE -{-# INLINE genTryOpenGE #-} - -{-# DEPRECATED genTryOpenLE "This is now called tryOpenLE." #-} --- | This name is /deprecated/. Instead use 'tryOpenLE'. -genTryOpenLE :: (e -> Ordering) -> AVL e -> Maybe (ZAVL e) -genTryOpenLE = tryOpenLE -{-# INLINE genTryOpenLE #-} - -{-# DEPRECATED genOpenEither "This is now called openEither." #-} --- | This name is /deprecated/. Instead use 'openEither'. -genOpenEither :: (e -> Ordering) -> AVL e -> Either (PAVL e) (ZAVL e) -genOpenEither = openEither -{-# INLINE genOpenEither #-} - -{-# DEPRECATED genOpenBAVL "This is now called openBAVL." #-} --- | This name is /deprecated/. Instead use 'openBAVL'. -genOpenBAVL :: (e -> Ordering) -> AVL e -> BAVL e -genOpenBAVL = openBAVL -{-# INLINE genOpenBAVL #-} - -{-# DEPRECATED genFindPath "This is now called findPath." #-} --- | This name is /deprecated/. Instead use 'findPath'. -genFindPath :: (e -> Ordering) -> AVL e -> UINT -genFindPath = findPath -{-# INLINE genFindPath #-} - -{-# DEPRECATED genOpenPath "This is now called openPath." #-} --- | This name is /deprecated/. Instead use 'openPath'. -genOpenPath :: (e -> Ordering) -> AVL e -> BinPath e -genOpenPath = openPath -{-# INLINE genOpenPath #-} - -{-# DEPRECATED genOpenPathWith "This is now called openPathWith." #-} --- | This name is /deprecated/. Instead use 'openPathWith'. -genOpenPathWith :: (e -> COrdering a) -> AVL e -> BinPath a -genOpenPathWith = openPathWith -{-# INLINE genOpenPathWith #-} - -{-# DEPRECATED fastAddSize "Use addSize or addSize#." #-} --- | This name is /deprecated/. Instead use 'addSize' or 'addSize#'. -fastAddSize :: UINT -> AVL e -> UINT -#ifdef __GLASGOW_HASKELL__ -fastAddSize = addSize# -#else -fastAddSize = addSize -#endif -{-# INLINE fastAddSize #-} - - - -{-# DEPRECATED reverseAVL "This is now called reverse." #-} --- | This name is /deprecated/. Instead use 'reverse'. -reverseAVL :: AVL e -> AVL e -reverseAVL = reverse -{-# INLINE reverseAVL #-} - -{-# DEPRECATED mapAVL "This is now called map." #-} --- | This name is /deprecated/. Instead use 'map'. -mapAVL :: (a -> b) -> AVL a -> AVL b -mapAVL = map -{-# INLINE mapAVL #-} - -{-# DEPRECATED mapAVL' "This is now called map'." #-} --- | This name is /deprecated/. Instead use 'map''. -mapAVL' :: (a -> b) -> AVL a -> AVL b -mapAVL' = map' -{-# INLINE mapAVL' #-} - -{-# DEPRECATED mapAccumLAVL "This is now called mapAccumL." #-} --- | This name is /deprecated/. Instead use 'mapAccumL'. -mapAccumLAVL :: (z -> a -> (z, b)) -> z -> AVL a -> (z, AVL b) -mapAccumLAVL = mapAccumL -{-# INLINE mapAccumLAVL #-} - -{-# DEPRECATED mapAccumRAVL "This is now called mapAccumR." #-} --- | This name is /deprecated/. Instead use 'mapAccumR'. -mapAccumRAVL :: (z -> a -> (z, b)) -> z -> AVL a -> (z, AVL b) -mapAccumRAVL = mapAccumR -{-# INLINE mapAccumRAVL #-} - -{-# DEPRECATED mapAccumLAVL' "This is now called mapAccumL'." #-} --- | This name is /deprecated/. Instead use 'mapAccumL''. -mapAccumLAVL' :: (z -> a -> (z, b)) -> z -> AVL a -> (z, AVL b) -mapAccumLAVL' = mapAccumL' -{-# INLINE mapAccumLAVL' #-} - -{-# DEPRECATED mapAccumRAVL' "This is now called mapAccumR'." #-} --- | This name is /deprecated/. Instead use 'mapAccumR''. -mapAccumRAVL' :: (z -> a -> (z, b)) -> z -> AVL a -> (z, AVL b) -mapAccumRAVL' = mapAccumR' -{-# INLINE mapAccumRAVL' #-} - -#ifdef __GLASGOW_HASKELL__ -{-# DEPRECATED mapAccumLAVL'' "This is now called mapAccumL''." #-} --- | This name is /deprecated/. Instead use 'mapAccumL'''. -mapAccumLAVL'' - :: (z -> a -> UBT2(z, b)) -> z -> AVL a -> (z, AVL b) -mapAccumLAVL'' = mapAccumL'' -{-# INLINE mapAccumLAVL'' #-} - -{-# DEPRECATED mapAccumRAVL'' "This is now called mapAccumR''." #-} --- | This name is /deprecated/. Instead use 'mapAccumR'''. -mapAccumRAVL'' - :: (z -> a -> UBT2(z, b)) -> z -> AVL a -> (z, AVL b) -mapAccumRAVL'' = mapAccumR'' -{-# INLINE mapAccumRAVL'' #-} - -{-# DEPRECATED foldrAVL_UINT "This is now called foldrInt#." #-} --- | This name is /deprecated/. Instead use 'foldrInt#'. -foldrAVL_UINT :: (e -> UINT -> UINT) -> UINT -> AVL e -> UINT -foldrAVL_UINT = foldrInt# -{-# INLINE foldrAVL_UINT #-} - -#else - -{-# DEPRECATED foldrAVL_UINT "This is deprecated, use foldr'." #-} --- | This name is /deprecated/. Instead use 'foldr''. -foldrAVL_UINT :: (e -> UINT -> UINT) -> UINT -> AVL e -> UINT -foldrAVL_UINT = foldr' -{-# INLINE foldrAVL_UINT #-} - -#endif - -{-# DEPRECATED replicateAVL "This is now called replicate." #-} --- | This name is /deprecated/. Instead use 'replicate'. -replicateAVL :: Int -> e -> AVL e -replicateAVL = replicate -{-# INLINE replicateAVL #-} - -{-# DEPRECATED filterAVL "This is now called filter." #-} --- | This name is /deprecated/. Instead use 'filter'. -filterAVL :: (e -> Bool) -> AVL e -> AVL e -filterAVL = filter -{-# INLINE filterAVL #-} - -{-# DEPRECATED mapMaybeAVL "This is now called mapMaybe." #-} --- | This name is /deprecated/. Instead use 'mapMaybe'. -mapMaybeAVL :: (a -> Maybe b) -> AVL a -> AVL b -mapMaybeAVL = mapMaybe -{-# INLINE mapMaybeAVL #-} - -{-# DEPRECATED partitionAVL "This is now called partition." #-} --- | This name is /deprecated/. Instead use 'partition'. -partitionAVL :: (e -> Bool) -> AVL e -> (AVL e, AVL e) -partitionAVL = partition -{-# INLINE partitionAVL #-} - -{-# DEPRECATED foldrAVL "This is now called foldr." #-} --- | This name is /deprecated/. Instead use 'foldr'. -foldrAVL :: (e -> a -> a) -> a -> AVL e -> a -foldrAVL = foldr -{-# INLINE foldrAVL #-} - -{-# DEPRECATED foldrAVL' "This is now called foldr'." #-} --- | This name is /deprecated/. Instead use 'foldr''. -foldrAVL' :: (e -> a -> a) -> a -> AVL e -> a -foldrAVL' = foldr' -{-# INLINE foldrAVL' #-} - -{-# DEPRECATED foldr1AVL "This is now called foldr1." #-} --- | This name is /deprecated/. Instead use 'foldr1'. -foldr1AVL :: (e -> e -> e) -> AVL e -> e -foldr1AVL = foldr1 -{-# INLINE foldr1AVL #-} - -{-# DEPRECATED foldr1AVL' "This is now called foldr1'." #-} --- | This name is /deprecated/. Instead use 'foldr1''. -foldr1AVL' :: (e -> e -> e) -> AVL e -> e -foldr1AVL' = foldr1' -{-# INLINE foldr1AVL' #-} - -{-# DEPRECATED foldr2AVL "This is now called foldr2." #-} --- | This name is /deprecated/. Instead use 'foldr2'. -foldr2AVL :: (e -> a -> a) -> (e -> a) -> AVL e -> a -foldr2AVL = foldr2 -{-# INLINE foldr2AVL #-} - -{-# DEPRECATED foldr2AVL' "This is now called foldr2'." #-} --- | This name is /deprecated/. Instead use 'foldr2''. -foldr2AVL' :: (e -> a -> a) -> (e -> a) -> AVL e -> a -foldr2AVL' = foldr2' -{-# INLINE foldr2AVL' #-} - -{-# DEPRECATED foldlAVL "This is now called foldl." #-} --- | This name is /deprecated/. Instead use 'foldl'. -foldlAVL :: (a -> e -> a) -> a -> AVL e -> a -foldlAVL = foldl -{-# INLINE foldlAVL #-} - -{-# DEPRECATED foldlAVL' "This is now called foldl'." #-} --- | This name is /deprecated/. Instead use 'foldl''. -foldlAVL' :: (a -> e -> a) -> a -> AVL e -> a -foldlAVL' = foldl' -{-# INLINE foldlAVL' #-} - -{-# DEPRECATED foldl1AVL "This is now called foldl1." #-} --- | This name is /deprecated/. Instead use 'foldl1'. -foldl1AVL :: (e -> e -> e) -> AVL e -> e -foldl1AVL = foldl1 -{-# INLINE foldl1AVL #-} - -{-# DEPRECATED foldl1AVL' "This is now called foldl1'." #-} --- | This name is /deprecated/. Instead use 'foldl1''. -foldl1AVL' :: (e -> e -> e) -> AVL e -> e -foldl1AVL' = foldl1' -{-# INLINE foldl1AVL' #-} - -{-# DEPRECATED foldl2AVL "This is now called foldl2." #-} --- | This name is /deprecated/. Instead use 'foldl2'. -foldl2AVL :: (a -> e -> a) -> (e -> a) -> AVL e -> a -foldl2AVL = foldl2 -{-# INLINE foldl2AVL #-} - -{-# DEPRECATED foldl2AVL' "This is now called foldl2'." #-} --- | This name is /deprecated/. Instead use 'foldl2''. -foldl2AVL' :: (a -> e -> a) -> (e -> a) -> AVL e -> a -foldl2AVL' = foldl2' -{-# INLINE foldl2AVL' #-} - -{-# DEPRECATED findPath "This is now called findFullPath." #-} --- | This name is /deprecated/. Instead use 'findFullPath'. -findPath :: (e -> Ordering) -> AVL e -> UINT -findPath = findFullPath -{-# INLINE findPath #-} diff --git a/Data/Tree/AVL/Height.hs b/Data/Tree/AVL/Height.hs deleted file mode 100644 --- a/Data/Tree/AVL/Height.hs +++ /dev/null @@ -1,99 +0,0 @@ -{-# OPTIONS_GHC -fglasgow-exts #-} ------------------------------------------------------------------------------ --- | --- Module : Data.Tree.AVL.Height --- 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.Height - (-- * AVL tree height utilities. - 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 - diff --git a/Data/Tree/AVL/Internals/DelUtils.hs b/Data/Tree/AVL/Internals/DelUtils.hs deleted file mode 100644 --- a/Data/Tree/AVL/Internals/DelUtils.hs +++ /dev/null @@ -1,790 +0,0 @@ -{-# 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.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 - diff --git a/Data/Tree/AVL/Internals/HAVL.hs b/Data/Tree/AVL/Internals/HAVL.hs deleted file mode 100644 --- a/Data/Tree/AVL/Internals/HAVL.hs +++ /dev/null @@ -1,98 +0,0 @@ -{-# 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.Height(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_ - diff --git a/Data/Tree/AVL/Internals/HJoin.hs b/Data/Tree/AVL/Internals/HJoin.hs deleted file mode 100644 --- a/Data/Tree/AVL/Internals/HJoin.hs +++ /dev/null @@ -1,329 +0,0 @@ -{-# 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 -------------------------- ------------------------------------------------------------------------ diff --git a/Data/Tree/AVL/Internals/HPush.hs b/Data/Tree/AVL/Internals/HPush.hs deleted file mode 100644 --- a/Data/Tree/AVL/Internals/HPush.hs +++ /dev/null @@ -1,189 +0,0 @@ -{-# 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 -------------------------- ------------------------------------------------------------------------ - diff --git a/Data/Tree/AVL/Internals/HSet.hs b/Data/Tree/AVL/Internals/HSet.hs deleted file mode 100644 --- a/Data/Tree/AVL/Internals/HSet.hs +++ /dev/null @@ -1,994 +0,0 @@ -{-# 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,disjointUnionH, - - -- * Intersection primitives. - intersectionH,intersectionMaybeH, - - -- * Difference primitives. - differenceH,differenceMaybeH,symDifferenceH, - - -- * Venn primitives - vennH,vennMaybeH, - ) 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 comparison to evaluate the union of two /disjoint/ sets represented as --- sorted AVL trees of known height. This function raises an error if the two sets intersect. --- --- Complexity: Not sure, but I\'d appreciate it if someone could figure it out. --- (Faster than Hedge union from Data.Set at any rate). -disjointUnionH :: (e -> e -> Ordering) -> AVL e -> UINT -> AVL e -> UINT -> UBT2(AVL e,UINT) -disjointUnionH 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 fork e1 r0 hr0 of - UBT4(rl0,hrl0,rr0,hrr0) -> case fork e0 l1 hl1 of -- (e0 < rl0 < e1) & (e0 < e1 < rr0) - UBT4(ll1,hll1,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 -> error "disjointUnionH: Trees intersect" `seq` UBT2(E,L(0)) - -- e1 < e0, so (l1 < e1 < e0) & (e1 < e0 < r0) - GT -> case fork e0 r1 hr1 of - UBT4(rl1,hrl1,rr1,hrr1) -> case fork e1 l0 hl0 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 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 - -- fork :: e -> AVL e -> UINT -> UBT4(AVL e,UINT,AVL e,UINT) - fork e0 t1 ht1 = fork_ t1 ht1 where - fork_ E _ = UBT4(E, L(0), E, L(0)) - fork_ (N l e r) h = fork__ l DECINT2(h) e r DECINT1(h) - fork_ (Z l e r) h = fork__ l DECINT1(h) e r DECINT1(h) - fork_ (P l e r) h = fork__ l DECINT1(h) e r DECINT2(h) - fork__ l hl e r hr = case c e0 e of - LT -> case fork_ l hl of - UBT4(l0,hl0,l1,hl1) -> case spliceH l1 hl1 e r hr of - UBT2(l1_,hl1_) -> UBT4(l0,hl0,l1_,hl1_) - EQ -> error "disjointUnionH: Trees intersect" `seq` UBT4(E, L(0), E, L(0)) - GT -> case fork_ r hr of - UBT4(l0,hl0,l1,hl1) -> case spliceH l hl e l0 hl0 of - UBT2(l0_,hl0_) -> UBT4(l0_,hl0_,l1,hl1) ------------------------------------------------------------------------ ----------------------- disjointUnionH 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 cmp = 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 cmp 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 cmp 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 cmp 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 fork e1 r0 hr0 of - UBT5(rl0,hrl0,be1,rr0,hrr0) -> case fork 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 fork e0 r1 hr1 of - UBT5(rl1,hrl1,be0,rr1,hrr1) -> case fork e1 l0 hl0 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 - -- fork :: e -> AVL e -> UINT -> UBT5(AVL e,UINT,Bool,AVL e,UINT) - fork e0 t1 ht1 = fork_ t1 ht1 where - fork_ E _ = UBT5(E, L(0), True, E, L(0)) - fork_ (N l e r) h = fork__ l DECINT2(h) e r DECINT1(h) - fork_ (Z l e r) h = fork__ l DECINT1(h) e r DECINT1(h) - fork_ (P l e r) h = fork__ l DECINT1(h) e r DECINT2(h) - fork__ l hl e r hr = case c e0 e of - LT -> case fork_ 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 fork_ 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) ------------------------------------------------------------------------ ------------------------ symDifferenceH Ends Here ---------------------- ------------------------------------------------------------------------ - - --- | Given two Sets @A@ and @B@ represented as sorted AVL trees, this function extracts --- the \'Venn diagram\' components @A-B@, @A.B@ and @B-A@. --- The two difference components are sorted AVL trees. --- The intersection component is prepended to the input List in ascending sorted in ascending order. --- The number of elements prepended is added to the corresponding Int argument (which may or may --- not be the List length). --- See also 'vennMaybeH'. --- --- Complexity: Not sure, but I\'d appreciate it if someone could figure it out. -vennH :: (a -> b -> COrdering c) -> [c] -> UINT -> AVL a -> UINT -> AVL b -> UINT -> UBT6(AVL a,UINT,[c],UINT,AVL b,UINT) -vennH cmp = v where - -- v :: [c] -> UINT -> AVL a -> UINT -> AVL b -> UINT -> UBT6(AVL a,UINT,[c],UINT,AVL b,UINT) - v cs cl E ha tb hb = UBT6(E ,ha,cs,cl,tb,hb) - v cs cl ta ha E hb = UBT6(ta,ha,cs,cl,E ,hb) - v cs cl (N la a ra) ha (N lb b rb) hb = v_ cs cl la DECINT2(ha) a ra DECINT1(ha) lb DECINT2(hb) b rb DECINT1(hb) - v cs cl (N la a ra) ha (Z lb b rb) hb = v_ cs cl la DECINT2(ha) a ra DECINT1(ha) lb DECINT1(hb) b rb DECINT1(hb) - v cs cl (N la a ra) ha (P lb b rb) hb = v_ cs cl la DECINT2(ha) a ra DECINT1(ha) lb DECINT1(hb) b rb DECINT2(hb) - v cs cl (Z la a ra) ha (N lb b rb) hb = v_ cs cl la DECINT1(ha) a ra DECINT1(ha) lb DECINT2(hb) b rb DECINT1(hb) - v cs cl (Z la a ra) ha (Z lb b rb) hb = v_ cs cl la DECINT1(ha) a ra DECINT1(ha) lb DECINT1(hb) b rb DECINT1(hb) - v cs cl (Z la a ra) ha (P lb b rb) hb = v_ cs cl la DECINT1(ha) a ra DECINT1(ha) lb DECINT1(hb) b rb DECINT2(hb) - v cs cl (P la a ra) ha (N lb b rb) hb = v_ cs cl la DECINT1(ha) a ra DECINT2(ha) lb DECINT2(hb) b rb DECINT1(hb) - v cs cl (P la a ra) ha (Z lb b rb) hb = v_ cs cl la DECINT1(ha) a ra DECINT2(ha) lb DECINT1(hb) b rb DECINT1(hb) - v cs cl (P la a ra) ha (P lb b rb) hb = v_ cs cl la DECINT1(ha) a ra DECINT2(ha) lb DECINT1(hb) b rb DECINT2(hb) - v_ cs cl la hla a ra hra lb hlb b rb hrb = - case cmp a b of - -- a < b, so (la < a < b) & (a < b < rb) - Lt -> case forka cmp a lb hlb of - UBT5(llb,hllb,mbca,rlb,hrlb) -> case forkb cmp b ra hra of - UBT5(lra,hlra,mbcb,rra,hrra) -> - -- (la + llb) < a < (lra + rlb) < b < (rra + rb) - case v cs cl rra hrra rb hrb of - UBT6(rab,hrab,cs0,cl0,rba,hrba) -> case (case mbcb of - Nothing -> case v cs0 cl0 lra hlra rlb hrlb of - UBT6(mab,hmab,cs1,cl1,mba,hmba) -> case spliceH mba hmba b rba hrba of - UBT2(mrba,hmrba) -> UBT6(mab,hmab,cs1,cl1,mrba,hmrba) - Just cb -> case v (cb:cs0) INCINT1(cl0) lra hlra rlb hrlb of - UBT6(mab,hmab,cs1,cl1,mba,hmba) -> case joinH mba hmba rba hrba of - UBT2(mrba,hmrba) -> UBT6(mab,hmab,cs1,cl1,mrba,hmrba) - ) of - UBT6(mab,hmab,cs1,cl1,mrba,hmrba) -> case joinH mab hmab rab hrab of - UBT2(mrab,hmrab) -> case (case mbca of - Nothing -> case v cs1 cl1 la hla llb hllb of - UBT6(lab,hlab,cs2,cl2,lba,hlba) -> case spliceH lab hlab a mrab hmrab of - UBT2(ab,hab) -> UBT6(ab,hab,cs2,cl2,lba,hlba) - Just ca -> case v (ca:cs1) INCINT1(cl1) la hla llb hllb of - UBT6(lab,hlab,cs2,cl2,lba,hlba) -> case joinH lab hlab mrab hmrab of - UBT2(ab,hab) -> UBT6(ab,hab,cs2,cl2,lba,hlba) - ) of - UBT6(ab,hab,cs2,cl2,lba,hlba) -> case joinH lba hlba mrba hmrba of - UBT2(ba,hba) -> UBT6(ab,hab,cs2,cl2,ba,hba) - -- a = b - Eq c -> case v cs cl ra hra rb hrb of - UBT6(rab,hrab,cs0,cl0,rba,hrba) -> case v (c:cs0) INCINT1(cl0) la hla lb hlb of - UBT6(lab,hlab,cs1,cl1,lba,hlba) -> case joinH lab hlab rab hrab of - UBT2(ab,hab) -> case joinH lba hlba rba hrba of - UBT2(ba,hba) -> UBT6(ab,hab,cs1,cl1,ba,hba) - -- b < a, so (lb < b < a) & (b < a < ra) - Gt -> case forka cmp a rb hrb of - UBT5(lrb,hlrb,mbca,rrb,hrrb) -> case forkb cmp b la hla of - UBT5(lla,hlla,mbcb,rla,hrla) -> - -- (lla + lb) < b < (rla + lrb) < a < (ra + rrb) - case v cs cl ra hra rrb hrrb of - UBT6(rab,hrab,cs0,cl0,rba,hrba) -> case (case mbca of - Nothing -> case v cs0 cl0 rla hrla lrb hlrb of - UBT6(mab,hmab,cs1,cl1,mba,hmba) -> case spliceH mab hmab a rab hrab of - UBT2(mrab,hmrab) -> UBT6(mrab,hmrab,cs1,cl1,mba,hmba) - Just ca -> case v (ca:cs0) INCINT1(cl0) rla hrla lrb hlrb of - UBT6(mab,hmab,cs1,cl1,mba,hmba) -> case joinH mab hmab rab hrab of - UBT2(mrab,hmrab) -> UBT6(mrab,hmrab,cs1,cl1,mba,hmba) - ) of - UBT6(mrab,hmrab,cs1,cl1,mba,hmba) -> case joinH mba hmba rba hrba of - UBT2(mrba,hmrba) -> case (case mbcb of - Nothing -> case v cs1 cl1 lla hlla lb hlb of - UBT6(lab,hlab,cs2,cl2,lba,hlba) -> case spliceH lba hlba b mrba hmrba of - UBT2(ba,hba) -> UBT6(lab,hlab,cs2,cl2,ba,hba) - Just cb -> case v (cb:cs1) INCINT1(cl1) lla hlla lb hlb of - UBT6(lab,hlab,cs2,cl2,lba,hlba) -> case joinH lba hlba mrba hmrba of - UBT2(ba,hba) -> UBT6(lab,hlab,cs2,cl2,ba,hba) - ) of - UBT6(lab,hlab,cs2,cl2,ba,hba) -> case joinH lab hlab mrab hmrab of - UBT2(ab,hab) -> UBT6(ab,hab,cs2,cl2,ba,hba) ------------------------------------------------------------------------ ---------------------------- vennH Ends Here --------------------------- ------------------------------------------------------------------------ - --- | Similar to 'vennH', but intersection elements for which the combining comparison --- returns @('Eq' 'Nothing')@ are deleted from the intersection list. --- --- Complexity: Not sure, but I\'d appreciate it if someone could figure it out. -vennMaybeH :: (a -> b -> COrdering (Maybe c)) -> [c] -> UINT -> AVL a -> UINT -> AVL b -> UINT -> UBT6(AVL a,UINT,[c],UINT,AVL b,UINT) -vennMaybeH cmp = v where - -- v :: [c] -> UINT -> AVL a -> UINT -> AVL b -> UINT -> UBT6(AVL a,UINT,[c],UINT,AVL b,UINT) - v cs cl E ha tb hb = UBT6(E ,ha,cs,cl,tb,hb) - v cs cl ta ha E hb = UBT6(ta,ha,cs,cl,E ,hb) - v cs cl (N la a ra) ha (N lb b rb) hb = v_ cs cl la DECINT2(ha) a ra DECINT1(ha) lb DECINT2(hb) b rb DECINT1(hb) - v cs cl (N la a ra) ha (Z lb b rb) hb = v_ cs cl la DECINT2(ha) a ra DECINT1(ha) lb DECINT1(hb) b rb DECINT1(hb) - v cs cl (N la a ra) ha (P lb b rb) hb = v_ cs cl la DECINT2(ha) a ra DECINT1(ha) lb DECINT1(hb) b rb DECINT2(hb) - v cs cl (Z la a ra) ha (N lb b rb) hb = v_ cs cl la DECINT1(ha) a ra DECINT1(ha) lb DECINT2(hb) b rb DECINT1(hb) - v cs cl (Z la a ra) ha (Z lb b rb) hb = v_ cs cl la DECINT1(ha) a ra DECINT1(ha) lb DECINT1(hb) b rb DECINT1(hb) - v cs cl (Z la a ra) ha (P lb b rb) hb = v_ cs cl la DECINT1(ha) a ra DECINT1(ha) lb DECINT1(hb) b rb DECINT2(hb) - v cs cl (P la a ra) ha (N lb b rb) hb = v_ cs cl la DECINT1(ha) a ra DECINT2(ha) lb DECINT2(hb) b rb DECINT1(hb) - v cs cl (P la a ra) ha (Z lb b rb) hb = v_ cs cl la DECINT1(ha) a ra DECINT2(ha) lb DECINT1(hb) b rb DECINT1(hb) - v cs cl (P la a ra) ha (P lb b rb) hb = v_ cs cl la DECINT1(ha) a ra DECINT2(ha) lb DECINT1(hb) b rb DECINT2(hb) - v_ cs cl la hla a ra hra lb hlb b rb hrb = - case cmp a b of - -- a < b, so (la < a < b) & (a < b < rb) - Lt -> case forka cmp a lb hlb of - UBT5(llb,hllb,mbmbca,rlb,hrlb) -> case forkb cmp b ra hra of - UBT5(lra,hlra,mbmbcb,rra,hrra) -> - -- (la + llb) < a < (lra + rlb) < b < (rra + rb) - case v cs cl rra hrra rb hrb of - UBT6(rab,hrab,cs0,cl0,rba,hrba) -> case (case mbmbcb of - Nothing -> case v cs0 cl0 lra hlra rlb hrlb of - UBT6(mab,hmab,cs1,cl1,mba,hmba) -> case spliceH mba hmba b rba hrba of - UBT2(mrba,hmrba) -> UBT6(mab,hmab,cs1,cl1,mrba,hmrba) - Just mbcb -> case (case mbcb of - Nothing -> v cs0 cl0 lra hlra rlb hrlb - Just cb -> v (cb:cs0) INCINT1(cl0) lra hlra rlb hrlb - ) of - UBT6(mab,hmab,cs1,cl1,mba,hmba) -> case joinH mba hmba rba hrba of - UBT2(mrba,hmrba) -> UBT6(mab,hmab,cs1,cl1,mrba,hmrba) - ) of - UBT6(mab,hmab,cs1,cl1,mrba,hmrba) -> case joinH mab hmab rab hrab of - UBT2(mrab,hmrab) -> case (case mbmbca of - Nothing -> case v cs1 cl1 la hla llb hllb of - UBT6(lab,hlab,cs2,cl2,lba,hlba) -> case spliceH lab hlab a mrab hmrab of - UBT2(ab,hab) -> UBT6(ab,hab,cs2,cl2,lba,hlba) - Just mbca -> case (case mbca of - Nothing -> v cs1 cl1 la hla llb hllb - Just ca -> v (ca:cs1) INCINT1(cl1) la hla llb hllb - ) of - UBT6(lab,hlab,cs2,cl2,lba,hlba) -> case joinH lab hlab mrab hmrab of - UBT2(ab,hab) -> UBT6(ab,hab,cs2,cl2,lba,hlba) - ) of - UBT6(ab,hab,cs2,cl2,lba,hlba) -> case joinH lba hlba mrba hmrba of - UBT2(ba,hba) -> UBT6(ab,hab,cs2,cl2,ba,hba) - -- a = b - Eq mbc -> case v cs cl ra hra rb hrb of - UBT6(rab,hrab,cs0,cl0,rba,hrba) -> case (case mbc of - Nothing -> v cs0 cl0 la hla lb hlb - Just c -> v (c:cs0) INCINT1(cl0) la hla lb hlb - ) of - UBT6(lab,hlab,cs1,cl1,lba,hlba) -> case joinH lab hlab rab hrab of - UBT2(ab,hab) -> case joinH lba hlba rba hrba of - UBT2(ba,hba) -> UBT6(ab,hab,cs1,cl1,ba,hba) - -- b < a, so (lb < b < a) & (b < a < ra) - Gt -> case forka cmp a rb hrb of - UBT5(lrb,hlrb,mbmbca,rrb,hrrb) -> case forkb cmp b la hla of - UBT5(lla,hlla,mbmbcb,rla,hrla) -> - -- (lla + lb) < b < (rla + lrb) < a < (ra + rrb) - case v cs cl ra hra rrb hrrb of - UBT6(rab,hrab,cs0,cl0,rba,hrba) -> case (case mbmbca of - Nothing -> case v cs0 cl0 rla hrla lrb hlrb of - UBT6(mab,hmab,cs1,cl1,mba,hmba) -> case spliceH mab hmab a rab hrab of - UBT2(mrab,hmrab) -> UBT6(mrab,hmrab,cs1,cl1,mba,hmba) - Just mbca -> case (case mbca of - Nothing -> v cs0 cl0 rla hrla lrb hlrb - Just ca -> v (ca:cs0) INCINT1(cl0) rla hrla lrb hlrb - ) of - UBT6(mab,hmab,cs1,cl1,mba,hmba) -> case joinH mab hmab rab hrab of - UBT2(mrab,hmrab) -> UBT6(mrab,hmrab,cs1,cl1,mba,hmba) - ) of - UBT6(mrab,hmrab,cs1,cl1,mba,hmba) -> case joinH mba hmba rba hrba of - UBT2(mrba,hmrba) -> case (case mbmbcb of - Nothing -> case v cs1 cl1 lla hlla lb hlb of - UBT6(lab,hlab,cs2,cl2,lba,hlba) -> case spliceH lba hlba b mrba hmrba of - UBT2(ba,hba) -> UBT6(lab,hlab,cs2,cl2,ba,hba) - Just mbcb -> case (case mbcb of - Nothing -> v cs1 cl1 lla hlla lb hlb - Just cb -> v (cb:cs1) INCINT1(cl1) lla hlla lb hlb - ) of - UBT6(lab,hlab,cs2,cl2,lba,hlba) -> case joinH lba hlba mrba hmrba of - UBT2(ba,hba) -> UBT6(lab,hlab,cs2,cl2,ba,hba) - ) of - UBT6(lab,hlab,cs2,cl2,ba,hba) -> case joinH lab hlab mrab hmrab of - UBT2(ab,hab) -> UBT6(ab,hab,cs2,cl2,ba,hba) ------------------------------------------------------------------------ ------------------------- vennMaybeH Ends Here ------------------------- ------------------------------------------------------------------------ - --- Common forks used by vennH,vennMaybeH --- We need 2 different versions of fork to ensure that comparison arguments are used in --- the right order (c a b) -forka :: (a -> b -> COrdering c) -> a -> AVL b -> UINT -> UBT5(AVL b,UINT,Maybe c,AVL b,UINT) -forka cmp a tb htb = f tb htb where - f E _ = UBT5(E,L(0),Nothing,E,L(0)) - f n@(N _ b r) L(2) = case cmp a b of -- l must be E, r must be Z - Lt -> UBT5(E,L(0),Nothing,n,L(2)) - Eq c -> UBT5(E,L(0),Just c ,r,L(1)) - Gt -> case r of - Z _ br _ -> case cmp a br of -- l & r must be E - Lt -> UBT5(Z E b E,L(1),Nothing,r,L(1)) - Eq c -> UBT5(Z E b E,L(1),Just c ,E,L(0)) - Gt -> UBT5(n ,L(2),Nothing,E,L(0)) - _ -> undefined `seq` UBT5(E,L(0),Nothing,E,L(0)) - f (N l b r) h = f_ l DECINT2(h) b r DECINT1(h) - f z@(Z l b r) L(2) = case cmp a b of -- l & r must be Z - Lt -> case l of - Z _ bl _ -> case cmp a bl of -- l & r must be E - Lt -> UBT5(E,L(0),Nothing,z ,L(2)) - Eq c -> UBT5(E,L(0),Just c ,N E b r,L(2)) - Gt -> UBT5(l,L(1),Nothing,N E b r,L(2)) - _ -> undefined `seq` UBT5(E,L(0),Nothing,E,L(0)) - Eq c -> UBT5(l,L(1),Just c,r,L(1)) - Gt -> case r of - Z _ br _ -> case cmp a br of -- l & r must be E - Lt -> UBT5(P l b E,L(2),Nothing,r,L(1)) - Eq c -> UBT5(P l b E,L(2),Just c ,E,L(0)) - Gt -> UBT5(z ,L(2),Nothing,E,L(0)) - _ -> undefined `seq` UBT5(E,L(0),Nothing,E,L(0)) - f z@(Z _ b _) L(1) = case cmp a b of -- l & r must be E - Lt -> UBT5(E,L(0),Nothing,z,L(1)) - Eq c -> UBT5(E,L(0),Just c ,E,L(0)) - Gt -> UBT5(z,L(1),Nothing,E,L(0)) - f (Z l b r) h = f_ l DECINT1(h) b r DECINT1(h) - f p@(P l b _) L(2) = case cmp a b of -- l must be Z, r must be E - Lt -> case l of - Z _ bl _ -> case cmp a bl of -- l & r must be E - Lt -> UBT5(E,L(0),Nothing,p ,L(2)) - Eq c -> UBT5(E,L(0),Just c ,Z E b E,L(1)) - Gt -> UBT5(l,L(1),Nothing,Z E b E,L(1)) - _ -> undefined `seq` UBT5(E,L(0),Nothing,E,L(0)) - Eq c -> UBT5(l,L(1),Just c ,E,L(0)) - Gt -> UBT5(p,L(2),Nothing,E,L(0)) - f (P l b r) h = f_ l DECINT1(h) b r DECINT2(h) - f_ l hl b r hr = case cmp a b of - Lt -> case f l hl of - UBT5(ll,hll,mbc,lr,hlr) -> case spliceH lr hlr b r hr of - UBT2(r_,hr_) -> UBT5(ll,hll,mbc,r_,hr_) - Eq c -> UBT5(l,hl,Just c,r,hr) - Gt -> case f r hr of - UBT5(rl,hrl,mbc,rr,hrr) -> case spliceH l hl b rl hrl of - UBT2(l_,hl_) -> UBT5(l_,hl_,mbc,rr,hrr) - --- This should be exactly the same as forka, but with the following swaps: --- * a <-> b, except is compare! --- * Lt <-> Gt (becasuse we didn't swap in compare) -forkb :: (a -> b -> COrdering c) -> b -> AVL a -> UINT -> UBT5(AVL a,UINT,Maybe c,AVL a,UINT) -forkb cmp b ta hta = f ta hta where - f E _ = UBT5(E,L(0),Nothing,E,L(0)) - f n@(N _ a r) L(2) = case cmp a b of -- l must be E, r must be Z - Gt -> UBT5(E,L(0),Nothing,n,L(2)) - Eq c -> UBT5(E,L(0),Just c ,r,L(1)) - Lt -> case r of - Z _ ar _ -> case cmp ar b of -- l & r must be E - Gt -> UBT5(Z E a E,L(1),Nothing,r,L(1)) - Eq c -> UBT5(Z E a E,L(1),Just c ,E,L(0)) - Lt -> UBT5(n ,L(2),Nothing,E,L(0)) - _ -> undefined `seq` UBT5(E,L(0),Nothing,E,L(0)) - f (N l a r) h = f_ l DECINT2(h) a r DECINT1(h) - f z@(Z l a r) L(2) = case cmp a b of -- l & r must be Z - Gt -> case l of - Z _ al _ -> case cmp al b of -- l & r must be E - Gt -> UBT5(E,L(0),Nothing,z ,L(2)) - Eq c -> UBT5(E,L(0),Just c ,N E a r,L(2)) - Lt -> UBT5(l,L(1),Nothing,N E a r,L(2)) - _ -> undefined `seq` UBT5(E,L(0),Nothing,E,L(0)) - Eq c -> UBT5(l,L(1),Just c,r,L(1)) - Lt -> case r of - Z _ ar _ -> case cmp ar b of -- l & r must be E - Gt -> UBT5(P l a E,L(2),Nothing,r,L(1)) - Eq c -> UBT5(P l a E,L(2),Just c ,E,L(0)) - Lt -> UBT5(z ,L(2),Nothing,E,L(0)) - _ -> undefined `seq` UBT5(E,L(0),Nothing,E,L(0)) - f z@(Z _ a _) L(1) = case cmp a b of -- l & r must be E - Gt -> UBT5(E,L(0),Nothing,z,L(1)) - Eq c -> UBT5(E,L(0),Just c ,E,L(0)) - Lt -> UBT5(z,L(1),Nothing,E,L(0)) - f (Z l a r) h = f_ l DECINT1(h) a r DECINT1(h) - f p@(P l a _) L(2) = case cmp a b of -- l must be Z, r must be E - Gt -> case l of - Z _ al _ -> case cmp al b of -- l & r must be E - Gt -> UBT5(E,L(0),Nothing,p ,L(2)) - Eq c -> UBT5(E,L(0),Just c ,Z E a E,L(1)) - Lt -> UBT5(l,L(1),Nothing,Z E a E,L(1)) - _ -> undefined `seq` UBT5(E,L(0),Nothing,E,L(0)) - Eq c -> UBT5(l,L(1),Just c ,E,L(0)) - Lt -> UBT5(p,L(2),Nothing,E,L(0)) - f (P l a r) h = f_ l DECINT1(h) a r DECINT2(h) - f_ l hl a r hr = case cmp a b of - Gt -> case f l hl of - UBT5(ll,hll,mbc,lr,hlr) -> case spliceH lr hlr a r hr of - UBT2(r_,hr_) -> UBT5(ll,hll,mbc,r_,hr_) - Eq c -> UBT5(l,hl,Just c,r,hr) - Lt -> case f r hr of - UBT5(rl,hrl,mbc,rr,hrr) -> case spliceH l hl a rl hrl of - UBT2(l_,hl_) -> UBT5(l_,hl_,mbc,rr,hrr) - - diff --git a/Data/Tree/AVL/Join.hs b/Data/Tree/AVL/Join.hs deleted file mode 100644 --- a/Data/Tree/AVL/Join.hs +++ /dev/null @@ -1,121 +0,0 @@ -{-# 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.Height(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) diff --git a/Data/Tree/AVL/List.hs b/Data/Tree/AVL/List.hs deleted file mode 100644 --- a/Data/Tree/AVL/List.hs +++ /dev/null @@ -1,852 +0,0 @@ -{-# 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 - asTree, - - -- ** \"Pushing\" unsorted Lists in sorted AVL trees - pushList, - - -- * Some analogues of common List functions - reverse,map,map', - mapAccumL ,mapAccumR , - mapAccumL' ,mapAccumR' , - replicate, - filter,mapMaybe, - filterViaList,mapMaybeViaList, - partition, -#if __GLASGOW_HASKELL__ > 604 - traverseAVL, -#endif - - -- ** 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. - foldr,foldr',foldr1,foldr1',foldr2,foldr2', - foldl,foldl',foldl1,foldl1',foldl2,foldl2', - -#ifdef __GLASGOW_HASKELL__ - -- ** (GHC Only) - mapAccumL'',mapAccumR'', foldrInt#, -#endif - - -- * Some clones of common List functions - -- | These are a cure for the horrible @O(n^2)@ complexity the noddy Data.List definitions. - nub,nubBy, - - -- * \"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', -) where - -import Prelude hiding (reverse,map,replicate,filter,foldr,foldr1,foldl,foldl1) -- so haddock finds the symbols there - -import Data.COrdering -import Data.Tree.AVL.Types(AVL(..),empty) -import Data.Tree.AVL.Size(size) -import Data.Tree.AVL.Push(push) -import Data.Tree.AVL.BinPath(findEmptyPath,insertPath) -import Data.Tree.AVL.Internals.HJoin(spliceH,joinH) - -import Data.Bits(shiftR,(.&.)) -import qualified Data.List as List (foldl',map) -#if __GLASGOW_HASKELL__ > 604 -import Control.Applicative hiding (empty) -#endif - -#ifdef __GLASGOW_HASKELL__ -import GHC.Base(Int#,(-#)) -#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 'foldr'' for a strict version. --- --- It behaves as if defined.. --- --- > foldr f a avl = foldr f a (asListL avl) --- --- For example, the 'asListL' function could be defined.. --- --- > asListL = foldr (:) [] --- --- Complexity: O(n) -foldr :: (e -> a -> a) -> a -> AVL e -> a -foldr 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 'foldr', 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) -foldr' :: (e -> a -> a) -> a -> AVL e -> a -foldr' 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 'foldr1'' for a strict version. --- --- > foldr1 f avl = foldr1 f (asListL avl) --- --- This function raises an error if the tree is empty. --- --- Complexity: O(n) -foldr1 :: (e -> e -> e) -> AVL e -> e -foldr1 f = foldU where - foldU E = error "foldr1: 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 = foldr f (f e (foldU r)) l - -- Use this when r might be E - foldW l e E = foldr f e l - foldW l e (N rl re rr) = foldr 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 = foldr f (f e (foldW rl re rr)) l - --- | The strict version of 'foldr1', 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) -foldr1' :: (e -> e -> e) -> AVL e -> e -foldr1' f = foldU where - foldU E = error "foldr1': 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` foldr' f a' l - -- Use this when r might be E - foldW l e E = foldr' 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` foldr' 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` foldr' f a' l - --- | This fold is a hybrid between 'foldr' and 'foldr1'. As with 'foldr1', 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 'foldr'). --- As with 'foldr' and 'foldr1', this function is lazy, so it's best not to use it with functions --- that are strict in their second argument. See 'foldr2'' for a strict version. --- --- Complexity: O(n) -foldr2 :: (e -> a -> a) -> (e -> a) -> AVL e -> a -foldr2 f g = foldU where - foldU E = error "foldr2: 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 = foldr f (f e (foldU r)) l - -- Use this when r might be E - foldW l e E = foldr f (g e) l - foldW l e (N rl re rr) = foldr 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 = foldr f (f e (foldW rl re rr)) l - --- | The strict version of 'foldr2', 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) -foldr2' :: (e -> a -> a) -> (e -> a) -> AVL e -> a -foldr2' f g = foldU where - foldU E = error "foldr2': 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` foldr' f a' l - -- Use this when r might be E - foldW l e E = let a = g e in a `seq` foldr' 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` foldr' 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` foldr' 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 'foldl'' for a strict version. --- --- > foldl f a avl = foldl f a (asListL avl) --- --- For example, the 'asListR' function could be defined.. --- --- > asListR = foldl (flip (:)) [] --- --- Complexity: O(n) -foldl :: (a -> e -> a) -> a -> AVL e -> a -foldl 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 'foldl', 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) -foldl' :: (a -> e -> a) -> a -> AVL e -> a -foldl' 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 'foldl1'' for a strict version. --- --- > foldl1 f avl = foldl1 f (asListL avl) --- --- This function raises an error if the tree is empty. --- --- Complexity: O(n) -foldl1 :: (e -> e -> e) -> AVL e -> e -foldl1 f = foldU where - foldU E = error "foldl1: 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 = foldl f (f (foldU l) e) r - -- Use this when l might be E - foldW E e r = foldl 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 = foldl 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 = foldl f (f (foldW ll le lr) e) r - --- | The strict version of 'foldl1', 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) -foldl1' :: (e -> e -> e) -> AVL e -> e -foldl1' f = foldU where - foldU E = error "foldl1': 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` foldl' f a' r - -- Use this when l might be E - foldW E e r = foldl' 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` foldl' 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` foldl' f a' r - --- | This fold is a hybrid between 'foldl' and 'foldl1'. As with 'foldl1', 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 'foldl'). --- As with 'foldl' and 'foldl1', this function is lazy, so it's best not to use it with functions --- that are strict in their first argument. See 'foldl2'' for a strict version. --- --- Complexity: O(n) -foldl2 :: (a -> e -> a) -> (e -> a) -> AVL e -> a -foldl2 f g = foldU where - foldU E = error "foldl2: 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 = foldl f (f (foldU l) e) r - -- Use this when l might be E - foldW E e r = foldl 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 = foldl 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 = foldl f (f (foldW ll le lr) e) r - --- | The strict version of 'foldl2', 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) -foldl2' :: (a -> e -> a) -> (e -> a) -> AVL e -> a -foldl2' f g = foldU where - foldU E = error "foldl2': 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` foldl' f a' r - -- Use this when l might be E - foldW E e r = let a = g e in a `seq` foldl' 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` foldl' 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` foldl' f a' r - -#ifdef __GLASGOW_HASKELL__ --- | This is a specialised version of 'foldr'' for use with an --- /unboxed/ Int accumulator. --- --- Complexity: O(n) -foldrInt# :: (e -> UINT -> UINT) -> UINT -> AVL e -> UINT -foldrInt# 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 -#endif - --- | The AVL equivalent of 'Data.List.mapAccumL' on lists. --- It behaves like a combination of 'map' and 'foldl'. --- 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 'mapAccumL'' for a strict version. --- --- Complexity: O(n) -mapAccumL :: (z -> a -> (z, b)) -> z -> AVL a -> (z, AVL b) -mapAccumL 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 'mapAccumL', 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) -mapAccumL' :: (z -> a -> (z, b)) -> z -> AVL a -> (z, AVL b) -mapAccumL' 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 'map' and 'foldr'. --- 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 'mapAccumR'' for a strict version. --- --- Complexity: O(n) -mapAccumR :: (z -> a -> (z, b)) -> z -> AVL a -> (z, AVL b) -mapAccumR 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 'mapAccumR', 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) -mapAccumR' :: (z -> a -> (z, b)) -> z -> AVL a -> (z, AVL b) -mapAccumR' 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 'mapAccumL'' but uses an unboxed pair in the --- accumulating function. --- --- Complexity: O(n) -mapAccumL'' - :: (z -> a -> UBT2(z, b)) -> z -> AVL a -> (z, AVL b) -mapAccumL'' 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 'mapAccumR'' but uses an unboxed pair in the --- accumulating function. --- --- Complexity: O(n) -mapAccumR'' - :: (z -> a -> UBT2(z, b)) -> z -> AVL a -> (z, AVL b) -mapAccumR'' 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 (replicate 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 (replicate 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) -reverse :: AVL e -> AVL e -reverse E = E -reverse (N l e r) = let l' = reverse l - r' = reverse r - in l' `seq` r' `seq` P r' e l' -reverse (Z l e r) = let l' = reverse l - r' = reverse r - in l' `seq` r' `seq` Z r' e l' -reverse (P l e r) = let l' = reverse l - r' = reverse 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 ('map''). --- --- 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) -map :: (a -> b) -> AVL a -> AVL b -map f = mp where - mp E = E - mp (N l a r) = let l' = mp l - r' = mp r - in l' `seq` r' `seq` N l' (f a) r' - mp (Z l a r) = let l' = mp l - r' = mp r - in l' `seq` r' `seq` Z l' (f a) r' - mp (P l a r) = let l' = mp l - r' = mp r - in l' `seq` r' `seq` P l' (f a) r' - --- | Similar to 'map', but the supplied function is applied strictly. --- --- Complexity: O(n) -map' :: (a -> b) -> AVL a -> AVL b -map' f = mp' where - mp' E = E - mp' (N l a r) = let l' = mp' l - r' = mp' r - b = f a - in b `seq` l' `seq` r' `seq` N l' b r' - mp' (Z l a r) = let l' = mp' l - r' = mp' r - b = f a - in b `seq` l' `seq` r' `seq` Z l' b r' - mp' (P l a r) = let l' = mp' l - r' = mp' r - b = f a - in b `seq` l' `seq` r' `seq` P l' b r' - - --- | Construct a flat AVL tree of size n (n>=0), where all elements are identical. --- --- Complexity: O(log n) -replicate :: Int -> e -> AVL e -replicate 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 'reverse'. --- --- Complexity: O(n) -flatReverse :: AVL e -> AVL e -flatReverse t = asTreeLenL (size t) (asListR t) - --- | Similar to 'map', but the resulting tree is flat. --- This function has higher constant factor overhead than 'map'. --- --- Complexity: O(n) -flatMap :: (a -> b) -> AVL a -> AVL b -flatMap f t = asTreeLenL (size t) (List.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) (mp' f (asListL t)) where - mp' _ [] = [] - mp' g (a:as) = let b = g a in b `seq` (b : mp' f as) - --- | Remove all AVL tree elements which do not satisfy the supplied predicate. --- Element ordering is preserved. The resulting tree is flat. --- See 'filter' 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) -filter :: (e -> Bool) -> AVL e -> AVL e -filter 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) -partition :: (e -> Bool) -> AVL e -> (AVL e, AVL e) -partition 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 'mapMaybe' for an alternative implementation which is probably more efficient. --- --- Complexity: O(n) -mapMaybeViaList :: (a -> Maybe b) -> AVL a -> AVL b -mapMaybeViaList f t = mp' [] 0 (asListR t) where - mp' sb n [] = asTreeLenL n sb - mp' sb n (a:as) = case f a of - Just b -> let n'=n+1 in n' `seq` mp' (b:sb) n' as - Nothing -> mp' sb n as - --- | Remove all AVL tree elements for which the supplied function returns 'Nothing'. --- Element ordering is preserved. --- --- Complexity: O(n) -mapMaybe :: (a -> Maybe b) -> AVL a -> AVL b -mapMaybe 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 'pushList' on the empty AVL tree. --- --- Complexity: O(n.(log n)) -asTree :: (e -> e -> COrdering e) -> [e] -> AVL e -asTree c = pushList c empty -{-# INLINE asTree #-} - --- | 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. -pushList :: (e -> e -> COrdering e) -> AVL e -> [e] -> AVL e -pushList c avl = List.foldl' addElem avl - where addElem t e = push (c e) e t - --- | A fast alternative implementation for 'Data.List.nub'. --- Deletes all but the first occurrence of an element from the input list. --- --- Complexity: O(n.(log n)) -nub :: Ord a => [a] -> [a] -nub = nubBy compare -{-# INLINE nub #-} - --- | A fast alternative implementation for 'Data.List.nubBy'. --- Deletes all but the first occurrence of an element from the input list. --- --- Complexity: O(n.(log n)) -nubBy :: (a -> a -> Ordering) -> [a] -> [a] -nubBy c = nubbit E where - nubbit _ [] = [] - nubbit avl (a:as) = case findEmptyPath (c a) avl of - L(-1) -> nubbit avl as -- Already encountered - p -> let avl' = insertPath p a avl -- First encounter - in avl' `seq` (a : nubbit avl' as) - -#if __GLASGOW_HASKELL__ > 604 --- | This is the non-overloaded version of the 'Data.Traversable.traverse' method for AVL trees. -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 - diff --git a/Data/Tree/AVL/Push.hs b/Data/Tree/AVL/Push.hs deleted file mode 100644 --- a/Data/Tree/AVL/Push.hs +++ /dev/null @@ -1,715 +0,0 @@ ------------------------------------------------------------------------------ --- | --- 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 - push,push',pushMaybe,pushMaybe', -) where - -import Prelude -- so haddock finds the symbols there - -import Data.COrdering -import Data.Tree.AVL.Types(AVL(..)) -import Data.Tree.AVL.BinPath(BinPath(..),openPathWith,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 'push'' --- --- Complexity: O(log n) -push :: (e -> COrdering e) -> e -> AVL e -> AVL e -push 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 -- 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 -- 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 -- 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 "push: 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 "push: 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 "push: 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 "push: 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 "push: 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 "push: 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 "push: 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 "push: 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 "push: 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 "push: 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) !! ------------------------------------------------------------------------ -------------------------- push Ends Here ---------------------------- ------------------------------------------------------------------------ - --- | Almost identical to 'push', 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) -push' :: (e -> COrdering e) -> e -> AVL e -> AVL e -push' 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 -- 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 -- 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 -- 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 "push': 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 "push': 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 "push': 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 "push': 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 "push': 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 "push': 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 "push': 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 "push': 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 "push': 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 "push': 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) !! ------------------------------------------------------------------------ -------------------------- push' Ends Here ---------------------------- ------------------------------------------------------------------------ - --- | Similar to 'push', 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 'pushMaybe'' --- --- Complexity: O(log n) -pushMaybe :: (e -> COrdering (Maybe e)) -> e -> AVL e -> AVL e -pushMaybe c e t = case openPathWith c t of - FullBP _ Nothing -> t - FullBP p (Just e') -> writePath p e' t - EmptyBP p -> insertPath p e t - --- | Almost identical to 'pushMaybe', 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) -pushMaybe' :: (e -> COrdering (Maybe e)) -> e -> AVL e -> AVL e -pushMaybe' c e t = case openPathWith 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 --------------------------- ------------------------------------------------------------------------ - - diff --git a/Data/Tree/AVL/Read.hs b/Data/Tree/AVL/Read.hs deleted file mode 100644 --- a/Data/Tree/AVL/Read.hs +++ /dev/null @@ -1,168 +0,0 @@ ------------------------------------------------------------------------------ --- | --- 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 - assertRead,tryRead,tryReadMaybe,defaultRead, - - -- ** Simple searches of /sorted/ AVL trees - contains, -) 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) -assertRead :: AVL e -> (e -> COrdering a) -> a -assertRead t c = genRead' t where - genRead' E = error "assertRead 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 'assertRead', but returns 'Nothing' if the search failed. --- --- Complexity: O(log n) -tryRead :: AVL e -> (e -> COrdering a) -> Maybe a -tryRead t c = tryRead' t where - tryRead' E = Nothing - tryRead' (N l e r) = tryRead'' l e r - tryRead' (Z l e r) = tryRead'' l e r - tryRead' (P l e r) = tryRead'' l e r - tryRead'' l e r = case c e of - Lt -> tryRead' l - Eq a -> Just a - Gt -> tryRead' 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) -tryReadMaybe :: AVL e -> (e -> COrdering (Maybe a)) -> Maybe a -tryReadMaybe t c = tryRead' t where - tryRead' E = Nothing - tryRead' (N l e r) = tryRead'' l e r - tryRead' (Z l e r) = tryRead'' l e r - tryRead' (P l e r) = tryRead'' l e r - tryRead'' l e r = case c e of - Lt -> tryRead' l - Eq mba -> mba - Gt -> tryRead' r - --- | General purpose function to perform a search of a sorted tree, using the supplied selector. --- This function is similar to 'assertRead', but returns a the default value (first argument) if --- the search fails. --- --- Complexity: O(log n) -defaultRead :: a -> AVL e -> (e -> COrdering a) -> a -defaultRead 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) -contains :: AVL e -> (e -> Ordering) -> Bool -contains t c = contains' t where - contains' E = False - contains' (N l e r) = contains'' l e r - contains' (Z l e r) = contains'' l e r - contains' (P l e r) = contains'' l e r - contains'' l e r = case c e of - LT -> contains' l - EQ -> True - GT -> contains' r diff --git a/Data/Tree/AVL/Set.hs b/Data/Tree/AVL/Set.hs deleted file mode 100644 --- a/Data/Tree/AVL/Set.hs +++ /dev/null @@ -1,618 +0,0 @@ -{-# 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 - union,unionMaybe,disjointUnion,unions, - - -- ** Difference - difference,differenceMaybe,symDifference, - - -- ** Intersection - intersection,intersectionMaybe, - - -- *** 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.) - intersectionToList,intersectionAsList, - intersectionMaybeToList,intersectionMaybeAsList, - - -- ** \'Venn diagram\' operations - -- | Given two sets A and B represented as sorted AVL trees, the venn operations evaluate - -- components @A-B@, @A.B@ and @B-A@. The intersection part may be obtained as a List - -- rather than AVL tree if required. - -- - -- Note that in all cases the three resulting sets are /disjoint/ and can safely be re-combined - -- after most \"munging\" operations using 'disjointUnion'. - venn,vennMaybe, - - -- *** \'Venn diagram\' operations with the intersection component as a List. - -- | These variants are provided for the same reasons as the Intersection as List variants. - vennToList,vennAsList, - vennMaybeToList,vennMaybeAsList, - - -- ** Subset - isSubsetOf,isSubsetOfBy, -) where - -import Prelude -- so haddock finds the symbols there - -import Data.Tree.AVL.Types(AVL(..)) -import Data.Tree.AVL.Height(addHeight) -import Data.Tree.AVL.List(asTreeLenL) -import Data.Tree.AVL.Internals.HJoin(spliceH) -import Data.Tree.AVL.Internals.HSet(unionH,unionMaybeH,disjointUnionH, - intersectionH,intersectionMaybeH, - vennH,vennMaybeH, - 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. -union :: (e -> e -> COrdering e) -> AVL e -> AVL e -> AVL e -union 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 'union', 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. -unionMaybe :: (e -> e -> COrdering (Maybe e)) -> AVL e -> AVL e -> AVL e -unionMaybe 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 comparison to evaluate the union of two /disjoint/ sets represented as --- sorted AVL trees. It will be slightly faster than 'union' but will raise an error if the --- two sets intersect. Typically this would be used to re-combine the \"post-munge\" results --- from one of the \"venn\" operations. --- --- Complexity: Not sure, but I\'d appreciate it if someone could figure it out. --- (Faster than Hedge union from Data.Set at any rate). -disjointUnion :: (e -> e -> Ordering) -> AVL e -> AVL e -> AVL e -disjointUnion 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 disjointUnionH 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.. --- --- @unions ccmp avls = foldl' ('union' ccmp) empty avls@ -unions :: (e -> e -> COrdering e) -> [AVL e] -> AVL e -unions 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. -intersection :: (a -> b -> COrdering c) -> AVL a -> AVL b -> AVL c -intersection c t0 t1 = case intersectionH c t0 t1 of UBT2(t,_) -> t - --- | Similar to 'intersection', 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. -intersectionMaybe :: (a -> b -> COrdering (Maybe c)) -> AVL a -> AVL b -> AVL c -intersectionMaybe c t0 t1 = case intersectionMaybeH c t0 t1 of UBT2(t,_) -> t - --- | Similar to 'intersection', but prepends the result to the supplied list in --- ascending order. This is a (++) free function which behaves as if defined: --- --- @intersectionToList c setA setB cs = asListL (intersection c setA setB) ++ cs@ --- --- Complexity: Not sure, but I\'d appreciate it if someone could figure it out. -intersectionToList :: (a -> b -> COrdering c) -> AVL a -> AVL b -> [c] -> [c] -intersectionToList 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_) ------------------------------------------------------------------------ ------------------- intersectionToList Ends Here ------------------- ------------------------------------------------------------------------ - --- | Applies 'intersectionToList' to the empty list. --- --- Complexity: Not sure, but I\'d appreciate it if someone could figure it out. -intersectionAsList :: (a -> b -> COrdering c) -> AVL a -> AVL b -> [c] -intersectionAsList c setA setB = intersectionToList c setA setB [] - --- | Similar to 'intersectionToList', 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. -intersectionMaybeToList :: (a -> b -> COrdering (Maybe c)) -> AVL a -> AVL b -> [c] -> [c] -intersectionMaybeToList 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_) ------------------------------------------------------------------------ ----------------- intersectionMaybeToList Ends Here ---------------- ------------------------------------------------------------------------ - --- | Applies 'intersectionMaybeToList' to the empty list. --- --- Complexity: Not sure, but I\'d appreciate it if someone could figure it out. -intersectionMaybeAsList :: (a -> b -> COrdering (Maybe c)) -> AVL a -> AVL b -> [c] -intersectionMaybeAsList c setA setB = intersectionMaybeToList c setA setB [] - --- | Uses the supplied comparison to evaluate the difference between two sets represented as --- sorted AVL trees. The expression.. --- --- > difference 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. -difference :: (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. -difference c t0 t1 = case differenceH c t0 L(0) t1 of UBT2(t,_) -> t - --- | Similar to 'difference', 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. -differenceMaybe :: (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. -differenceMaybe 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. -isSubsetOf :: (a -> b -> Ordering) -> AVL a -> AVL b -> Bool -isSubsetOf 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_) ------------------------------------------------------------------------ ------------------------- isSubsetOf Ends Here ---------------------- ------------------------------------------------------------------------ - --- | Similar to 'isSubsetOf', 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. -isSubsetOfBy :: (a -> b -> COrdering Bool) -> AVL a -> AVL b -> Bool -isSubsetOfBy 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_) ------------------------------------------------------------------------ ------------------------ isSubsetOfBy 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. -symDifference :: (e -> e -> Ordering) -> AVL e -> AVL e -> AVL e -symDifference 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 - --- | Given two Sets @A@ and @B@ represented as sorted AVL trees, this function --- extracts the \'Venn diagram\' components @A-B@, @A.B@ and @B-A@. --- See also 'vennMaybe'. --- --- Complexity: Not sure, but I\'d appreciate it if someone could figure it out. -venn :: (a -> b -> COrdering c) -> AVL a -> AVL b -> (AVL a, AVL c, AVL b) -venn c = gu where -- This is to avoid O(log n) height calculation for empty sets - gu E t1 = (E ,E,t1) - gu t0 E = (t0,E,E ) - 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 vennH c [] L(0) t0 h0 t1 h1 of - UBT6(tab,_,cs,cl,tba,_) -> let tc = asTreeLenL ASINT(cl) cs - in tc `seq` (tab,tc,tba) - --- | Similar to 'venn', but intersection elements for which the combining comparison --- returns @('Eq' 'Nothing')@ are deleted from the intersection result. --- --- Complexity: Not sure, but I\'d appreciate it if someone could figure it out. -vennMaybe :: (a -> b -> COrdering (Maybe c)) -> AVL a -> AVL b -> (AVL a, AVL c, AVL b) -vennMaybe c = gu where -- This is to avoid O(log n) height calculation for empty sets - gu E t1 = (E ,E,t1) - gu t0 E = (t0,E,E ) - 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 vennMaybeH c [] L(0) t0 h0 t1 h1 of - UBT6(tab,_,cs,cl,tba,_) -> let tc = asTreeLenL ASINT(cl) cs - in tc `seq` (tab,tc,tba) - --- | Same as 'venn', but prepends the intersection component to the supplied list --- in ascending order. -vennToList :: (a -> b -> COrdering c) -> [c] -> AVL a -> AVL b -> (AVL a, [c], AVL b) -vennToList cmp cs = gu where -- This is to avoid O(log n) height calculation for empty sets - gu E t1 = (E ,cs,t1) - gu t0 E = (t0,cs,E ) - 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 vennH cmp cs L(0) t0 h0 t1 h1 of - UBT6(tab,_,cs_,_,tba,_) -> (tab,cs_,tba) - --- | Same as 'vennMaybe', but prepends the intersection component to the supplied list --- in ascending order. -vennMaybeToList :: (a -> b -> COrdering (Maybe c)) -> [c] -> AVL a -> AVL b -> (AVL a, [c], AVL b) -vennMaybeToList cmp cs = gu where -- This is to avoid O(log n) height calculation for empty sets - gu E t1 = (E ,cs,t1) - gu t0 E = (t0,cs,E ) - 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 vennMaybeH cmp cs L(0) t0 h0 t1 h1 of - UBT6(tab,_,cs_,_,tba,_) -> (tab,cs_,tba) - --- | Same as 'venn', but returns the intersection component as a list in ascending order. --- This is just 'vennToList' applied to an empty initial intersection list. -vennAsList :: (a -> b -> COrdering c) -> AVL a -> AVL b -> (AVL a, [c], AVL b) -vennAsList cmp = vennToList cmp [] -{-# INLINE vennAsList #-} - --- | Same as 'vennMaybe', but returns the intersection component as a list in ascending order. --- This is just 'vennMaybeToList' applied to an empty initial intersection list. -vennMaybeAsList :: (a -> b -> COrdering (Maybe c)) -> AVL a -> AVL b -> (AVL a, [c], AVL b) -vennMaybeAsList cmp = vennMaybeToList cmp [] -{-# INLINE vennMaybeAsList #-} - diff --git a/Data/Tree/AVL/Size.hs b/Data/Tree/AVL/Size.hs deleted file mode 100644 --- a/Data/Tree/AVL/Size.hs +++ /dev/null @@ -1,193 +0,0 @@ -{-# 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,clipSize, - -#ifdef __GLASGOW_HASKELL__ - -- ** (GHC Only) - addSize#,size#, -#endif - ) where - -import Data.Tree.AVL.Types(AVL(..)) -import Data.Tree.AVL.Height(addHeight) - -#ifdef __GLASGOW_HASKELL__ -import GHC.Base -#include "ghcdefs.h" -#else -#include "h98defs.h" -#endif - -#ifdef __GLASGOW_HASKELL__ -import GHC.Base -#include "ghcdefs.h" - --- | A convenience wrapper for 'addSize#'. -size :: AVL e -> Int -size t = ASINT(addSize# L(0) t) -{-# INLINE size #-} - --- | A convenience wrapper for 'addSize#'. -size# :: AVL e -> UINT -size# t = addSize# L(0) t -{-# INLINE size# #-} - --- | See 'addSize#'. -addSize :: Int -> AVL e -> Int -addSize ASINT(n) t = ASINT(addSize# n t) -{-# INLINE addSize #-} - -#define AddSize addSize# -#else -#include "h98defs.h" - --- | A convenience wrapper for 'addSize'. -size :: AVL e -> Int -size t = addSize 0 t -{-# INLINE size #-} - -#define AddSize addSize -#endif - -{----------------------------------------- -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 add the size of a tree to the first argument. 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) -AddSize :: UINT -> AVL e -> UINT -AddSize n E = n -AddSize 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 -AddSize 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 -AddSize 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 "AddSize: 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 "AddSize: 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 'addSize'. --- --- 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 -------------------------- ------------------------------------------------------------------------ - diff --git a/Data/Tree/AVL/Split.hs b/Data/Tree/AVL/Split.hs deleted file mode 100644 --- a/Data/Tree/AVL/Split.hs +++ /dev/null @@ -1,837 +0,0 @@ -{-# 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 'takeLT' 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. - forkL,forkR,fork, - takeLE,dropGT, - takeLT,dropGE, - takeGT,dropLE, - takeGE,dropLT, -) 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) -forkL :: (e -> Ordering) -> AVL e -> (AVL e, AVL e) -forkL c avl = let (HAVL l _,HAVL r _) = forkL_ L(0) avl -- Tree heights are relative - in (l,r) - where - forkL_ h E = (HAVL E h, HAVL E h) - forkL_ h (N l e r) = forkL__ l DECINT2(h) e r DECINT1(h) - forkL_ h (Z l e r) = forkL__ l DECINT1(h) e r DECINT1(h) - forkL_ h (P l e r) = forkL__ l DECINT1(h) e r DECINT2(h) - forkL__ l hl e r hr = case c e of - -- Current element > pivot, so goes in right half - LT -> let (havl0,havl1) = forkL_ 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) = forkL_ 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) -forkR :: (e -> Ordering) -> AVL e -> (AVL e, AVL e) -forkR c avl = let (HAVL l _,HAVL r _) = forkR_ L(0) avl -- Tree heights are relative - in (l,r) - where - forkR_ h E = (HAVL E h, HAVL E h) - forkR_ h (N l e r) = forkR__ l DECINT2(h) e r DECINT1(h) - forkR_ h (Z l e r) = forkR__ l DECINT1(h) e r DECINT1(h) - forkR_ h (P l e r) = forkR__ l DECINT1(h) e r DECINT2(h) - forkR__ l hl e r hr = case c e of - -- Current element > pivot, so goes in right half - LT -> let (havl0,havl1) = forkR_ 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) = forkR_ hr r - havl0_ = spliceHAVL (HAVL l hl) e havl0 - in havl0_ `seq` (havl0_, havl1) - - --- | Similar to 'forkL' and 'forkR', but returns any equal element found (instead of --- incorporating it into the left or right tree results respectively). --- --- Complexity: O(log n) -fork :: (e -> COrdering a) -> AVL e -> (AVL e, Maybe a, AVL e) -fork c avl = let (HAVL l _, mba, HAVL r _) = fork_ L(0) avl -- Tree heights are relative - in (l,mba,r) - where - fork_ h E = (HAVL E h, Nothing, HAVL E h) - fork_ h (N l e r) = fork__ l DECINT2(h) e r DECINT1(h) - fork_ h (Z l e r) = fork__ l DECINT1(h) e r DECINT1(h) - fork_ h (P l e r) = fork__ l DECINT1(h) e r DECINT2(h) - fork__ l hl e r hr = case c e of - -- Current element > pivot - Lt -> let (havl0,mba,havl1) = fork_ 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) = fork_ hr r - havl0_ = spliceHAVL (HAVL l hl) e havl0 - in havl0_ `seq` (havl0_, mba, havl1) - --- | This is a simplified version of 'forkL' 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 'dropGT'. --- --- Complexity: O(log n) -takeLE :: (e -> Ordering) -> AVL e -> AVL e -takeLE c avl = let HAVL l _ = forkL_ L(0) avl -- Tree heights are relative - in l - where - forkL_ h E = HAVL E h - forkL_ h (N l e r) = forkL__ l DECINT2(h) e r DECINT1(h) - forkL_ h (Z l e r) = forkL__ l DECINT1(h) e r DECINT1(h) - forkL_ h (P l e r) = forkL__ l DECINT1(h) e r DECINT2(h) - forkL__ l hl e r hr = case c e of - LT -> forkL_ hl l - EQ -> pushRHAVL (HAVL l hl) e - GT -> let havl0 = forkL_ hr r - in spliceHAVL (HAVL l hl) e havl0 - - --- | A synonym for 'takeLE'. --- --- Complexity: O(log n) -dropGT :: (e -> Ordering) -> AVL e -> AVL e -dropGT = takeLE -{-# INLINE dropGT #-} - --- | This is a simplified version of 'forkL' which returns a sorted tree containing --- only those elements which are greater according to the supplied selector. --- This function also has the synonym 'dropLE'. --- --- Complexity: O(log n) -takeGT :: (e -> Ordering) -> AVL e -> AVL e -takeGT c avl = let HAVL r _ = forkL_ L(0) avl -- Tree heights are relative - in r - where - forkL_ h E = HAVL E h - forkL_ h (N l e r) = forkL__ l DECINT2(h) e r DECINT1(h) - forkL_ h (Z l e r) = forkL__ l DECINT1(h) e r DECINT1(h) - forkL_ h (P l e r) = forkL__ l DECINT1(h) e r DECINT2(h) - forkL__ l hl e r hr = case c e of - LT -> let havl1 = forkL_ hl l - in spliceHAVL havl1 e (HAVL r hr) - EQ -> HAVL r hr - GT -> forkL_ hr r - --- | A synonym for 'takeGT'. --- --- Complexity: O(log n) -dropLE :: (e -> Ordering) -> AVL e -> AVL e -dropLE = takeGT -{-# INLINE dropLE #-} - --- | This is a simplified version of 'forkR' which returns a sorted tree containing --- only those elements which are less than according to the supplied selector. --- This function also has the synonym 'dropGE'. --- --- Complexity: O(log n) -takeLT :: (e -> Ordering) -> AVL e -> AVL e -takeLT c avl = let HAVL l _ = forkL_ L(0) avl -- Tree heights are relative - in l - where - forkL_ h E = HAVL E h - forkL_ h (N l e r) = forkL__ l DECINT2(h) e r DECINT1(h) - forkL_ h (Z l e r) = forkL__ l DECINT1(h) e r DECINT1(h) - forkL_ h (P l e r) = forkL__ l DECINT1(h) e r DECINT2(h) - forkL__ l hl e r hr = case c e of - LT -> forkL_ hl l - EQ -> HAVL l hl - GT -> let havl0 = forkL_ hr r - in spliceHAVL (HAVL l hl) e havl0 - - --- | A synonym for 'takeLT'. --- --- Complexity: O(log n) -dropGE :: (e -> Ordering) -> AVL e -> AVL e -dropGE = takeLT -{-# INLINE dropGE #-} - --- | This is a simplified version of 'forkR' 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 'dropLT'. --- --- Complexity: O(log n) -takeGE :: (e -> Ordering) -> AVL e -> AVL e -takeGE c avl = let HAVL r _ = forkL_ L(0) avl -- Tree heights are relative - in r - where - forkL_ h E = HAVL E h - forkL_ h (N l e r) = forkL__ l DECINT2(h) e r DECINT1(h) - forkL_ h (Z l e r) = forkL__ l DECINT1(h) e r DECINT1(h) - forkL_ h (P l e r) = forkL__ l DECINT1(h) e r DECINT2(h) - forkL__ l hl e r hr = case c e of - LT -> let havl1 = forkL_ hl l - in spliceHAVL havl1 e (HAVL r hr) - EQ -> pushLHAVL e (HAVL r hr) - GT -> forkL_ hr r - --- | A synonym for 'takeGE'. --- --- Complexity: O(log n) -dropLT :: (e -> Ordering) -> AVL e -> AVL e -dropLT = takeGE -{-# INLINE dropLT #-} - diff --git a/Data/Tree/AVL/Test/AllTests.hs b/Data/Tree/AVL/Test/AllTests.hs deleted file mode 100644 --- a/Data/Tree/AVL/Test/AllTests.hs +++ /dev/null @@ -1,1517 +0,0 @@ -{-# 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 -,testWrite -,testPush -,testPushL -,testPushR -,testDelete -,testAssertDelL -,testAssertDelR -,testAssertPopL -,testPopHL -,testAssertPopR -,testAssertPop -,testFlatten -,testJoin -,testJoinHAVL -,testConcatAVL -,testFlatConcat -,testFoldr -,testFoldr' -,testFoldl -,testFoldl' -,testFoldr1 -,testFoldr1' -,testFoldl1 -,testFoldl1' -,testMapAccumL -,testMapAccumR -,testMapAccumL' -,testMapAccumR' -#ifdef __GLASGOW_HASKELL__ -,testMapAccumL'' -,testMapAccumR'' -#endif -,testSplitAtL -,testFilterViaList -,testFilter -,testMapMaybeViaList -,testMapMaybe -,testTakeL -,testDropL -,testSplitAtR -,testTakeR -,testDropR -,testSpanL -,testTakeWhileL -,testDropWhileL -,testSpanR -,testTakeWhileR -,testDropWhileR -,testRotateL -,testRotateR -,testRotateByL -,testRotateByR -,testForkL -,testForkR -,testFork -,testTakeLE -,testTakeGT -,testTakeGE -,testTakeLT -,testUnion -,testDisjointUnion -,testUnionMaybe -,testIntersection -,testIntersectionMaybe -,testIntersectionAsList -,testIntersectionMaybeAsList -,testDifference -,testDifferenceMaybe -,testSymDifference -,testIsSubsetOf -,testIsSubsetOfBy -,testVenn -,testVennMaybe -,testCompareHeight -,testShowReadEq --- Zipper tests -,testOpenClose -,testDelClose -,testOpenLClose -,testOpenRClose -,testMoveL -,testMoveR -,testInsertL -,testInsertMoveL -,testInsertR -,testInsertMoveR -,testInsertTreeL -,testInsertTreeR -,testDelMoveL -,testDelMoveR -,testDelAllL -,testDelAllR -,testDelAllCloseL -,testDelAllIncCloseL -,testDelAllCloseR -,testDelAllIncCloseR -,testZipSize -,testTryOpenLE -,testTryOpenGE -,testOpenEither -,testBAVLtoZipper -) where - -import Prelude hiding (reverse,map,replicate,filter,foldr,foldr1,foldl,foldl1) -- so haddock finds the symbols there - -import Data.COrdering -import Data.Tree.AVLX - -import qualified Data.List as L (replicate,reverse,filter,foldr1,foldl1,map,insert,mapAccumL,mapAccumR) -import System.Exit(exitFailure) - -#ifdef __GLASGOW_HASKELL__ -import GHC.Base(Int#,Int(..)) -#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 - testWrite - testPush - testPushL - testPushR - testDelete - testAssertDelL - testAssertDelR - testAssertPopL - testPopHL - testAssertPopR - testAssertPop - testFlatten - testJoin - testJoinHAVL - testConcatAVL - testFlatConcat - testFoldr - testFoldr' - testFoldl - testFoldl' - testFoldr1 - testFoldr1' - testFoldl1 - testFoldl1' - testMapAccumL - testMapAccumR - testMapAccumL' - testMapAccumR' -#ifdef __GLASGOW_HASKELL__ - testMapAccumL'' - testMapAccumR'' -#endif - testSplitAtL - testFilterViaList - testFilter - testMapMaybeViaList - testMapMaybe - testTakeL - testDropL - testSplitAtR - testTakeR - testDropR - testSpanL - testTakeWhileL - testDropWhileL - testSpanR - testTakeWhileR - testDropWhileR - testRotateL - testRotateR - testRotateByL - testRotateByR - testForkL - testForkR - testFork - testTakeLE - testTakeGT - testTakeGE - testTakeLT - testUnion - testDisjointUnion - testUnionMaybe - testIntersection - testIntersectionMaybe - testIntersectionAsList - testIntersectionMaybeAsList - testDifference - testDifferenceMaybe - testSymDifference - testIsSubsetOf - testIsSubsetOfBy - testVenn - testVennMaybe - testCompareHeight - testShowReadEq --- Zipper tests - testOpenClose - testDelClose - testOpenLClose - testOpenRClose - testMoveL - testMoveR - testInsertL - testInsertMoveL - testInsertR - testInsertMoveR - testInsertTreeL - testInsertTreeR - testDelMoveL - testDelMoveR - testDelAllL - testDelAllR - testDelAllCloseL - testDelAllIncCloseL - testDelAllCloseR - testDelAllIncCloseR - testZipSize - testTryOpenLE - testTryOpenGE - testOpenEither - 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 write function -testWrite :: IO () -testWrite = do title "write" - exhaustiveTest test (take 5 allNonEmptyAVL) - where test _ s t = all test_ [0..s-1] - where test_ n = let t_ = write (withCC' (+) n) t - in isBalanced t_ && (asListL t_ == [0..n-1]++(n+n):[n+1..s-1]) - - --- | Test push function -testPush :: IO () --- Also exercises: map' and contains -testPush = do title "push" - exhaustiveTest test (take 6 allAVL) - where test h s t = all oddTest odds && all evenTest evens - where t_ = map' (\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__ = psh 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__ = psh n t_ - s__ = size t__ - h__ = ASINT(height t__) - in (s__ == s+1) && (isSortedOK compare t__) && (h__-h <= 1) && (t__ `contns` n) - psh e = push (sndCC e) e - contns avl e = contains avl (compare e) - --- | Test delete function -testDelete :: IO () -testDelete = do title "delete" - exhaustiveTest test (take 5 allNonEmptyAVL) - where test h s t = all oddTest odds && all evenTest evens - where t_ = map' (\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) && (L.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 = delete (compare e) - --- | Test assertPop function -testAssertPop :: IO () -testAssertPop = - do title "assertPop" - exhaustiveTest test (take 5 allNonEmptyAVL) - where test h s t = all testElem elems - where elems = [0,1..s-1] - testElem n = let (n_,t_) = assertPop (fstCC n) t - in case checkHeight t_ of - Just h_ -> (h-h_<=1) && (L.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 foldr -testFoldr :: IO () -testFoldr = do title "foldr" - exhaustiveTest test (take 6 allAVL) - where test _ s t = foldr (:) [] t == [0..s-1] --- | Test foldr' -testFoldr' :: IO () -testFoldr' = do title "foldr'" - exhaustiveTest test (take 6 allAVL) - where test _ s t = foldr' (:) [] t == [0..s-1] --- | Test foldl -testFoldl :: IO () -testFoldl = do title "foldl" - exhaustiveTest test (take 6 allAVL) - where test _ s t = foldl (flip (:)) [] t == [s-1,s-2..0] --- | Test foldl' -testFoldl' :: IO () -testFoldl' = do title "foldl'" - exhaustiveTest test (take 6 allAVL) - where test _ s t = foldl' (flip (:)) [] t == [s-1,s-2..0] --- | Test foldr1 -testFoldr1 :: IO () -testFoldr1 = do title "foldr1" - exhaustiveTest test (take 5 allNonEmptyAVL) - where test _ s t = foldr1 (-) t == L.foldr1 (-) [0..s-1] --- | Test foldr1' -testFoldr1' :: IO () -testFoldr1' = do title "foldr1'" - exhaustiveTest test (take 5 allNonEmptyAVL) - where test _ s t = foldr1' (-) t == L.foldr1 (-) [0..s-1] --- | Test foldl1 -testFoldl1 :: IO () -testFoldl1 = do title "foldl1" - exhaustiveTest test (take 5 allNonEmptyAVL) - where test _ s t = foldl1 (-) t == L.foldl1 (-) [0..s-1] --- | Test foldl1' -testFoldl1' :: IO () -testFoldl1' = do title "foldl1'" - exhaustiveTest test (take 5 allNonEmptyAVL) - where test _ s t = foldl1' (-) t == L.foldl1 (-) [0..s-1] - --- | Test mapAccumL -testMapAccumL :: IO () -testMapAccumL = do title "mapAccumL" - exhaustiveTest test (take 6 allAVL) - where test _ _ t = let (nt,t') = mapAccumL f 0 t - (nl,l ) = L.mapAccumL f 0 (asListL t) - in (nt==nl) && ((asListL t') == l) && (isSortedOK compare t') - f acc n = (acc+n,n+1) - --- | Test mapAccumR -testMapAccumR :: IO () -testMapAccumR = do title "mapAccumR" - exhaustiveTest test (take 6 allAVL) - where test _ _ t = let (nt,t') = mapAccumR f 0 t - (nl,l ) = L.mapAccumR f 0 (asListL t) - in (nt==nl) && ((asListL t') == l) && (isSortedOK compare t') - f acc n = (acc+n,n+1) - --- | Test mapAccumL' -testMapAccumL' :: IO () -testMapAccumL' = do title "mapAccumL'" - exhaustiveTest test (take 6 allAVL) - where test _ _ t = let (nt,t') = mapAccumL' f 0 t - (nl,l ) = L.mapAccumL f 0 (asListL t) - in (nt==nl) && ((asListL t') == l) && (isSortedOK compare t') - f acc n = (acc+n,n+1) - --- | Test mapAccumR' -testMapAccumR' :: IO () -testMapAccumR' = do title "mapAccumR'" - exhaustiveTest test (take 6 allAVL) - where test _ _ t = let (nt,t') = mapAccumR' f 0 t - (nl,l ) = 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 mapAccumL'' -testMapAccumL'' :: IO () -testMapAccumL'' = do title "mapAccumL''" - exhaustiveTest test (take 6 allAVL) - where test _ _ t = let (nt,t') = mapAccumL'' f_ 0 t - (nl,l ) = 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 mapAccumR'' -testMapAccumR'' :: IO () -testMapAccumR'' = do title "mapAccumR''" - exhaustiveTest test (take 6 allAVL) - where test _ _ t = let (nt,t') = mapAccumR'' f_ 0 t - (nl,l ) = 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 $ map (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 $ map (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 $ map (\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 $ L.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 $ map (\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 $ L.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 filter function -testFilter :: IO () -testFilter = do title "filter" - exhaustiveTest test (take 6 allAVL) - where test _ s t = all testit [0..s] -- n==s should yield unmodified tree - where testit n = let t' = filter (/= 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 mapMaybe function -testMapMaybe :: IO () -testMapMaybe = do title "mapMaybe" - exhaustiveTest test (take 6 allAVL) - where test _ s t = all testit [0..s] -- n==s should yield unmodified tree - where testit n = let t' = mapMaybe (\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) && - (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 (map' (\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 (map' (\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 $ L.map rotateIt [-1..s] - where rotateIt n = map' (\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 $ L.map rotateIt [-1..s] - where rotateIt n = map' (\n_ -> (n_+n) `mod` s) $ rotateByR t n - isOK t_ = (isBalanced t_) && (asListL t_ == tlist) - tlist = asListL t - --- | Test forkL function -testForkL :: IO () -testForkL = do title "forkL" - exhaustiveTest test (take 6 allAVL) - where test _ s t = all testFarkL [-1..s-1] - where tlist = asListL t - testFarkL n = let (l,r) = forkL (compare n) t - in (isBalanced l) && (isBalanced r) && - (size l == n+1) && (size r == s-(n+1)) && - (l `toListL` asListL r == tlist) - --- | Test forkR function -testForkR :: IO () -testForkR = do title "forkR" - exhaustiveTest test (take 6 allAVL) - where test _ s t = all testFarkR [0..s] - where tlist = asListL t - testFarkR n = let (l,r) = forkR (compare n) t - in (isBalanced l) && (isBalanced r) && - (size l == n) && (size r == s-n) && - (l `toListL` asListL r == tlist) - - --- | Test fork function -testFork :: IO () -testFork = do title "fork" - 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) = fork (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) = fork (fstCC n) t - in case mbn of - Nothing -> (isEmpty l) && (isBalanced r) && (asListL r == tlist) - _ -> False - testFork2 n = let (l,mbn,r) = fork (fstCC n) t - in case mbn of - Nothing -> (isEmpty r) && (isBalanced l) && (asListL l == tlist) - _ -> False - --- | Test takeLE function -testTakeLE :: IO () -testTakeLE = do title "takeLE" - exhaustiveTest test (take 6 allAVL) - where test _ s t = all testTikeLE [-1..s-1] - where testTikeLE n = let l = takeLE (compare n) t - in (isBalanced l) && (asListL l == [0..n]) - --- | Test takeLT function -testTakeLT :: IO () -testTakeLT = do title "takeLT" - exhaustiveTest test (take 6 allAVL) - where test _ s t = all testTikeLT [0..s] - where testTikeLT n = let l = takeLT (compare n) t - in (isBalanced l) && (asListL l == [0..n-1]) - --- | Test takeGT function -testTakeGT :: IO () -testTakeGT = do title "takeGT" - exhaustiveTest test (take 6 allAVL) - where test _ s t = all testTikeGT [-1..s-1] - where testTikeGT n = let r = takeGT (compare n) t - in (isBalanced r) && (asListL r == [n+1..s-1]) - --- | Test takeGE function -testTakeGE :: IO () -testTakeGE = do title "takeGE" - exhaustiveTest test (take 6 allAVL) - where test _ s t = all testTikeGE [0..s] - where testTikeGE n = let r = takeGE (compare n) t - in (isBalanced r) && (asListL r == [n..s-1]) - --- | Test the union function -testUnion :: IO () -testUnion = let trees = take num $ concatMap (\(_,ts) -> ts) allAVL - num = 1000 - in do title "union" - 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 $ map' (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_ = map' (\n -> n+n ) l -- even - r_ = map' (\n -> n+n+1) r -- odd - u = unionFst l_ r_ - in isSortedOK compare u && (size u == ls+rs) - unionFst = union fstCC - --- | Test the disjointUnion function -testDisjointUnion :: IO () -testDisjointUnion = - let trees = take num $ concatMap (\(_,ts) -> ts) allAVL - num = 1000 - in do title "disjointUnion" - putStrLn $ "Testing " ++ show (num*num) ++ " tree pairs.." - if and [test (map' (\n -> 2*n) l) ls (map' (\n -> 2*n+1) r) rs - | (l,ls) <- trees -- 0,2..2*ls-2 - , (r,rs) <- trees -- 1,3..2*rs-1 - ] - then passed - else failed - where test l ls r rs = all (\f -> f l ls r rs) [test1] - test1 l ls r rs = and [test1_ $ map' (+(2*n)) r | n <- [(-rs)..(ls-1)]] - where test1_ r_ = let u = disjointUnion compare l r_ - in isBalanced u && (asListL u == listUnion (asListL l) (asListL r_)) - --- | Test the symDifference function -testSymDifference :: IO () -testSymDifference = - let trees = take num $ concatMap (\(_,ts) -> ts) allAVL - num = 1000 - in do title "symDifference" - 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 $ map' (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_ = map' (\n -> n+n ) l -- even - r_ = map' (\n -> n+n+1) r -- odd - u = symDiff l_ r_ - in isSortedOK compare u && (size u == ls+rs) - symDiff = symDifference compare - --- | Test the unionMaybe function -testUnionMaybe :: IO () -testUnionMaybe = let trees = take num $ concatMap (\(_,ts) -> ts) allAVL - num = 1000 - in do title "unionMaybe" - 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 $ map' (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] - ++ L.filter even [n1 .. n2-1] - ++ [n2..n3-1] - ) - test3 l ls r rs = let l_ = map' (\n -> n+n ) l -- even - r_ = map' (\n -> n+n+1) r -- odd - u = onion l_ r_ - in isSortedOK compare u && (size u == ls+rs) - onion = unionMaybe (withCC' com) - com a _ = if even a then Just a else Nothing - --- | Test the intersection function -testIntersection :: IO () -testIntersection = let trees = take num $ concatMap (\(_,ts) -> ts) allAVL - num = 1000 - in do title "intersection" - 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 = intersection fstCC l r - in isBalanced u && (asListL u == [0 .. min ls rs - 1]) - test2 l ls r rs = and [test2_ n $ map' (n+) r | n <- [(-rs)..ls]] - where test2_ n r_ = let u = intersection fstCC l r_ - in isBalanced u && (asListL u == [max n 0 .. min ls (rs+n) - 1]) - test3 l _ r _ = let l_ = map' (\n -> n+n ) l -- even - r_ = map' (\n -> n+n+1) r -- odd - u = intersection fstCC l_ r_ - in isEmpty u - --- | Test the intersectionMaybe function -testIntersectionMaybe :: IO () -testIntersectionMaybe = let trees = take num $ concatMap (\(_,ts) -> ts) allAVL - num = 1000 - in do title "intersectionMaybe" - 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 $ map' (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 == L.filter even [n1 .. n2-1]) - test3 l _ r _ = let l_ = map' (\n -> n+n ) l -- even - r_ = map' (\n -> n+n+1) r -- odd - u = insect l_ r_ - in isEmpty u - insect = intersectionMaybe (withCC' com) - com a _ = if even a then Just a else Nothing - --- | Test the intersectionAsList function -testIntersectionAsList :: IO () -testIntersectionAsList = - let trees = take num $ concatMap (\(_,ts) -> ts) allAVL - num = 1000 - in do title "intersectionAsList" - 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 = intersectionAsList fstCC l r - in u == [0 .. min ls rs - 1] - test2 l ls r rs = and [test2_ n $ map' (n+) r | n <- [(-rs)..ls]] - where test2_ n r_ = let u = intersectionAsList fstCC l r_ - in u == [max n 0 .. min ls (rs+n) - 1] - test3 l _ r _ = let l_ = map' (\n -> n+n ) l -- even - r_ = map' (\n -> n+n+1) r -- odd - u = intersectionAsList fstCC l_ r_ - in null u - --- | Test the intersectionMaybeAsList function -testIntersectionMaybeAsList :: IO () -testIntersectionMaybeAsList = - let trees = take num $ concatMap (\(_,ts) -> ts) allAVL - num = 1000 - in do title "intersectionMaybeAsList" - 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 $ map' (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 == L.filter even [n1 .. n2-1] - test3 l _ r _ = let l_ = map' (\n -> n+n ) l -- even - r_ = map' (\n -> n+n+1) r -- odd - u = insect l_ r_ - in null u - insect = intersectionMaybeAsList (withCC' com) - com a _ = if even a then Just a else Nothing - --- | Test the difference function -testDifference :: IO () -testDifference = let trees = take num $ concatMap (\(_,ts) -> ts) allAVL - num = 1000 - in do title "difference" - 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 = diff l r - in isBalanced u && (asListL u == [rs .. ls - 1]) - test2 l ls r rs = and [test2_ n $ map' (n+) r | n <- [(-rs)..ls]] - where test2_ n r_ = let u = diff l r_ - in isBalanced u && (asListL u == [0 .. n-1] ++ [rs+n .. ls-1]) - test3 l ls r rs = let l_ = map' (\n -> n+n ) l -- even - r_ = map' (\n -> n+n+1) r -- odd - u = diff l r_ - u_ = diff l_ r_ - mn = min (ls-1) (2*rs-1) - in isBalanced u && - (asListL u == L.filter even [0..mn] ++ [mn+1..ls-1]) && - isBalanced u_ && (asListL u_ == asListL l_) - diff = difference compare - --- | Test the differenceMaybe function -testDifferenceMaybe :: IO () -testDifferenceMaybe = - let trees = take num $ concatMap (\(_,ts) -> ts) allAVL - num = 1000 - in do title "differenceMaybe" - 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 = differenceMaybe c l r - in isBalanced u && (asListL u == L.filter odd [0..mn] ++ [mn+1..ls-1]) - test2 l ls r rs = and [test2_ n $ map' (n+) r | n <- [(-rs)..ls]] - where test2_ n r_ = let u = differenceMaybe c l r_ - n0 = max 0 n - n1 = min (ls-1) (rs+n-1) - in isBalanced u && - (asListL u == [0..n0-1] ++ L.filter odd [n0..n1] ++ [n1+1..ls-1]) - test3 l ls r rs = let l_ = map' (\n -> n+n+1) l -- odd - r_ = map' (\n -> n+n ) r -- even - u = differenceMaybe c l r_ - u_ = differenceMaybe c l_ r_ - mn = min (ls-1) (2*rs-2) - mx = max (mn+1) 0 - listfil = L.filter odd [0..mn] - listrem = [mx..ls-1] - in isBalanced u && isBalanced u_ && (asListL u_ == asListL l_) && - (asListL u == listfil ++ listrem) - --- | Test the isSubsetOf function -testIsSubsetOf :: IO () -testIsSubsetOf = let trees = take num $ concatMap (\(_,ts) -> ts) allAVL - num = 1000 - in do title "isSubsetOf" - 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 `isSubset` r == (ls<=rs)) && - (r `isSubset` l == (rs<=ls)) - test2 l ls r rs = and [test2_ n $ map' (n+) r | n <- [(-rs)..ls]] - where test2_ n r_ = (l `isSubset` r_ == ((n<=0) && (rs+n>=ls))) && - (r_ `isSubset` l == ((n>=0) && (rs+n<=ls))) - isSubset = isSubsetOf compare - --- | Test the isSubsetOfBy function -testIsSubsetOfBy :: IO () -testIsSubsetOfBy = let trees = take num $ concatMap (\(_,ts) -> ts) allAVL - num = 1000 - in do title "isSubsetOfBy" - 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 isSubsetOf - -- 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 `isSubset` r == (ls<=rs)) && - (r `isSubset` l == (rs<=ls)) - test2 l ls r rs = and [test2_ n $ map' (n+) r | n <- [(-rs)..ls]] - where test2_ n r_ = (l `isSubset` r_ == ((n<=0) && (rs+n>=ls))) && - (r_ `isSubset` l == ((n>=0) && (rs+n<=ls))) - isSubset = isSubsetOfBy (withCC (\_ _ -> True )) - test3 l ls r rs = and [test3_ n | n <- [0..max ls rs]] - where test3_ n = (l `isSubset'` r == ((ls<=rs) && (n>=ls))) && - (r `isSubset'` l == ((rs<=ls) && (n>=rs))) - where isSubset' = isSubsetOfBy (withCC (\m _ -> m /= n)) - --- | Test the venn function. Also exercises disjointUnion -testVenn :: IO () -testVenn = - let trees = concatMap (\(_,ts) -> ts) (take 5 allAVL) -- All trees of height 4 or less = 335 trees (112,225 pairs) - num = length trees - in do title "venn" - 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 = let (lr,i,rl) = ven l r - in and [all isBalanced [lr,i,rl] - ,asListL lr == listDiff [0..ls-1] [0..rs-1] - ,asListL i == listIntersection [0..ls-1] [0..rs-1] - ,asListL rl == listDiff [0..rs-1] [0..ls-1] - ,asListL (disu i (disu rl lr)) == listUnion [0..ls-1] [0..rs-1] - ] - test2 l ls r rs = and [test2_ $ map' (n+) r | n <- [(-rs)..ls]] - where test2_ r_ = let (lr,i,rl) = ven l r_ - in and [all isBalanced [lr,i,rl] - ,asListL lr == listDiff (asListL l ) (asListL r_) - ,asListL i == listIntersection (asListL l ) (asListL r_) - ,asListL rl == listDiff (asListL r_) (asListL l ) - ,asListL (disu i (disu rl lr)) == listUnion (asListL l ) (asListL r_) - ] - ven = venn fstCC - disu = disjointUnion compare - --- | Test the vennMaybe function. -testVennMaybe :: IO () -testVennMaybe = - let trees = concatMap (\(_,ts) -> ts) (take 5 allAVL) -- All trees of height 4 or less = 335 trees (112,225 pairs) - num = length trees - in do title "vennMaybe" - 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 = and [t cmp l ls r rs| t<-[test1], cmp<-[cmpAll,cmpNone,cmpEven,cmpOdd]] - test1 cmp l ls r rs = and [test1_ $ map' (n+) r | n <- [(-rs)..ls]] - where test1_ r_ = let (lr,i,rl) = vennMaybe cmp l r_ - in and [all isBalanced [lr,i,rl] - ,asListL lr == listDiff (asListL l ) (asListL r_) - ,asListL rl == listDiff (asListL r_) (asListL l ) - ,asListL i == listIntersectionMaybe cmp (asListL l ) (asListL r_) - ,asListL (disu i (disu rl lr)) == listUnion (asListL i) (listUnion (asListL lr) (asListL rl)) - ] - cmpAll = withCC' (\x _ -> Just x) - cmpNone = withCC' (\_ _ -> Nothing) - cmpEven = withCC' (\x _ -> if even x then Just x else Nothing) - cmpOdd = withCC' (\x _ -> if odd x then Just x else Nothing) - disu = disjointUnion compare - --- | 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 -testOpenClose :: IO () -testOpenClose = do title "Zipper open/close" - exhaustiveTest test (take 5 allNonEmptyAVL) - where test _ s t = all test_ [0..s-1] - where test_ n = let z = assertOpen (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 $ assertOpen (compare n) t - in (isBalanced t_) -- && (L.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 (L.map getCurrent zavls == L.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 (L.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 $ assertOpen (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 $ assertOpen (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 (assertOpen (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 (assertOpen (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 $ assertOpen (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 (assertOpen (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 (L.map getCurrent zavls == L.reverse [0..s-1]) && - (and $ zipWith test_ zavls $ L.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 (L.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 $ assertOpen (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 $ assertOpen (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 $ assertOpen (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 $ assertOpen (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 $ assertOpen (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 $ assertOpen (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 = assertOpen (compare n) t - in (sizeL z == n) && (sizeR z == (s-1)-n) && (sizeZAVL z == s) - --- | Test Zipper tryOpenGE -testTryOpenGE :: IO () -testTryOpenGE = do title "Zipper tryOpenGE" - exhaustiveTest test (take 5 allNonEmptyAVL) - where test _ s t = let t_ = map' (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 = tryOGE n t_ - t__ = close z - in (getCurrent z == n) && (isBalanced t__) && (asListL t__ == [0,2..2*s-2]) - testO t_ n = let Just z = tryOGE n t_ - t__ = close z - in (getCurrent z == n+1) && (isBalanced t__) && (asListL t__ == [0,2..2*s-2]) - tryOGE a = tryOpenGE (compare a) - --- | Test Zipper tryOpenLE -testTryOpenLE :: IO () -testTryOpenLE = do title "Zipper tryOpenLE" - exhaustiveTest test (take 5 allNonEmptyAVL) - where test _ s t = let t_ = map' (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 = tryOLE n t_ - t__ = close z - in (getCurrent z == n) && (isBalanced t__) && (asListL t__ == [0,2..2*s-2]) - testO t_ n = let Just z = tryOLE n t_ - t__ = close z - in (getCurrent z == n-1) && (isBalanced t__) && (asListL t__ == [0,2..2*s-2]) - tryOLE a = tryOpenLE (compare a) - --- | Test Zipper openEither (also tests fill and fillClose) -testOpenEither :: IO () -testOpenEither = do title "Zipper openEither" - exhaustiveTest test (take 6 allAVL) - where test _ s t = let t_ = map' (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 = openEith n t_ - t__ = close z - in (getCurrent z == n) && (isBalanced t__) && (asListL t__ == [0,2..2*s-2]) - testO t_ n = let Left p = openEith 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])) - openEith a = openEither (compare a) - - - --- | Test anyBAVLtoEither -testBAVLtoZipper :: IO () -testBAVLtoZipper = do title "BAVLtoZipper" - exhaustiveTest test (take 6 allAVL) - where test _ s t = let t_ = map' (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 = oBAVL 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 = oBAVL 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])) - oBAVL e = openBAVL (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 = L.replicate (length titl) '*' - in putStrLn "" >> putStrLn mark >> putStrLn titl >> putStrLn mark - -passed :: IO () -passed = putStrLn "Passed" - -failed :: IO () -failed = do putStrLn "!! FAILED !!" - exitFailure - - --- List union (of ascending Ints) -listUnion :: [Int] -> [Int] -> [Int] -listUnion [] ys = ys -listUnion xs [] = xs -listUnion xs@(x:xs') ys@(y:ys') = case compare x y of - LT -> x:(listUnion xs' ys ) - EQ -> x:(listUnion xs' ys') -- Eliminate duplicates - GT -> y:(listUnion xs ys') - --- List intersection (of ascending Ints) -listIntersection :: [Int] -> [Int] -> [Int] -listIntersection [] _ = [] -listIntersection _ [] = [] -listIntersection xs@(x:xs') ys@(y:ys') = case compare x y of - LT -> listIntersection xs' ys - EQ -> x:(listIntersection xs' ys') - GT -> listIntersection xs ys' - --- List intersection maybe (of ascending Ints) -listIntersectionMaybe :: (Int -> Int -> COrdering (Maybe Int)) -> [Int] -> [Int] -> [Int] -listIntersectionMaybe _ [] _ = [] -listIntersectionMaybe _ _ [] = [] -listIntersectionMaybe cmp xs@(x:xs') ys@(y:ys') = case cmp x y of - Lt -> listIntersectionMaybe cmp xs' ys - Eq (Just i) -> i:(listIntersectionMaybe cmp xs' ys') - Eq Nothing -> listIntersectionMaybe cmp xs' ys' - Gt -> listIntersectionMaybe cmp xs ys' - --- List Difference (of ascending Ints) -listDiff :: [Int] -> [Int] -> [Int] -listDiff [] _ = [] -listDiff xs [] = xs -listDiff xs@(x:xs') ys@(y:ys') = case compare x y of - LT -> x:(listDiff xs' ys) - EQ -> listDiff xs' ys' - GT -> listDiff xs ys' - diff --git a/Data/Tree/AVL/Test/Counter.hs b/Data/Tree/AVL/Test/Counter.hs deleted file mode 100644 --- a/Data/Tree/AVL/Test/Counter.hs +++ /dev/null @@ -1,49 +0,0 @@ ------------------------------------------------------------------------------ --- | --- 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 - - diff --git a/Data/Tree/AVL/Test/Utils.hs b/Data/Tree/AVL/Test/Utils.hs deleted file mode 100644 --- a/Data/Tree/AVL/Test/Utils.hs +++ /dev/null @@ -1,221 +0,0 @@ -{-# 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(map',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' = map' (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) diff --git a/Data/Tree/AVL/Types.hs b/Data/Tree/AVL/Types.hs deleted file mode 100644 --- a/Data/Tree/AVL/Types.hs +++ /dev/null @@ -1,162 +0,0 @@ -{-# 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. --- --- Controlling Strictness. --- --- The 'AVL' tree 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). --- --- The 'Eq' and 'Ord' instances. --- --- Begining with version 3.0 these are now derived, and hence are defined in terms of --- strict structural equality, rather than observational equivalence. The reason for --- this change is that the observational equivalence abstraction was technically breakable --- with the exposed API. But since this change, some functions which were previously --- considered unsafe have become safe to expose (those that measure tree height, for example). --- --- The 'Read' and 'Show' instances. --- --- Begining with version 4.0 these are now derived to ensure consistency with 'Eq' instance. --- (Show now reveals the exact tree structure). --- - -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) - deriving(Eq,Ord,Show,Read) - --- 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) -isEmpty :: AVL e -> Bool -isEmpty E = True -isEmpty _ = False -{-# INLINE isEmpty #-} - --- | Returns 'True' if an AVL tree is non-empty. --- --- Complexity: O(1) -isNonEmpty :: AVL e -> Bool -isNonEmpty E = False -isNonEmpty _ = True -{-# INLINE isNonEmpty #-} - --- | Creates an AVL tree with just one element. --- --- Complexity: O(1) -singleton :: e -> AVL e -singleton e = Z E e E -{-# INLINE singleton #-} - --- | Create an AVL tree of two elements, occuring in same order as the arguments. -pair :: e -> e -> AVL e -pair e0 e1 = P (Z E e0 E) e1 E -{-# INLINE pair #-} - --- | 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) -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 -{-# INLINE tryGetSingleton #-} diff --git a/Data/Tree/AVL/Write.hs b/Data/Tree/AVL/Write.hs deleted file mode 100644 --- a/Data/Tree/AVL/Write.hs +++ /dev/null @@ -1,197 +0,0 @@ ------------------------------------------------------------------------------ --- | --- 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 - write,writeFast,tryWrite,writeMaybe,tryWriteMaybe -) where - -import Prelude -- so haddock finds the symbols there - -import Data.COrdering -import Data.Tree.AVL.Types(AVL(..)) -import Data.Tree.AVL.BinPath(BinPath(..),openPathWith,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) -write :: (e -> COrdering e) -> AVL e -> AVL e -write c t = case openPathWith c t of - FullBP pth e -> writePath pth e t - _ -> t - --- | Functionally identical to 'write', 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) -writeFast :: (e -> COrdering e) -> AVL e -> AVL e -writeFast c = w where - w E = E - w (N l e r) = case c e of - Lt -> let l' = w l in l' `seq` N l' e r - Eq v -> N l v r - Gt -> let r' = w r in r' `seq` N l e r' - w (Z l e r) = case c e of - Lt -> let l' = w l in l' `seq` Z l' e r - Eq v -> Z l v r - Gt -> let r' = w r in r' `seq` Z l e r' - w (P l e r) = case c e of - Lt -> let l' = w l in l' `seq` P l' e r - Eq v -> P l v r - Gt -> let r' = w 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) -tryWrite :: (e -> COrdering e) -> AVL e -> Maybe (AVL e) -tryWrite c t = case openPathWith c t of - FullBP pth e -> Just $! writePath pth e t - _ -> Nothing - --- | Similar to 'write', 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) -writeMaybe :: (e -> COrdering (Maybe e)) -> AVL e -> AVL e -writeMaybe c t = case openPathWith c t of - FullBP pth (Just e) -> writePath pth e t - _ -> t - --- | Similar to 'tryWrite', 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) -tryWriteMaybe :: (e -> COrdering (Maybe e)) -> AVL e -> Maybe (AVL e) -tryWriteMaybe c t = case openPathWith c t of - FullBP pth (Just e) -> Just $! writePath pth e t - FullBP _ Nothing -> Just t - _ -> Nothing - - diff --git a/Data/Tree/AVL/Zipper.hs b/Data/Tree/AVL/Zipper.hs deleted file mode 100644 --- a/Data/Tree/AVL/Zipper.hs +++ /dev/null @@ -1,903 +0,0 @@ -{-# 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 .. - -- - -- - -- - -- 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, - assertOpen,tryOpen, - tryOpenGE,tryOpenLE, - openEither, - - -- ** 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 - openBAVL,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.Height(height,addHeight) -import Data.Tree.AVL.Internals.DelUtils(deletePath,popRN,popRZ,popRP,popLN,popLZ,popLP) -import Data.Tree.AVL.Internals.HJoin(spliceH,joinH) -import Data.Tree.AVL.Internals.HPush(pushHL,pushHR) -import Data.Tree.AVL.BinPath(BinPath(..),openPath,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) -assertOpen :: (e -> Ordering) -> AVL e -> ZAVL e -assertOpen c t = op EP L(0) t where -- Relative heights !! - -- op :: (Path e) -> UINT -> AVL e -> ZAVL e - op _ _ E = error "assertOpen: 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 'openBAVL', test for \"fullness\" --- using 'fullBAVL' and then convert to a 'ZAVL' using 'fullBAVLtoZAVL'. --- --- Complexity: O(log n) -tryOpen :: (e -> Ordering) -> AVL e -> Maybe (ZAVL e) -tryOpen 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) -tryOpenGE :: (e -> Ordering) -> AVL e -> Maybe (ZAVL e) -tryOpenGE 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) -tryOpenLE :: (e -> Ordering) -> AVL e -> Maybe (ZAVL e) -tryOpenLE 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) -openEither :: (e -> Ordering) -> AVL e -> Either (PAVL e) (ZAVL e) -openEither 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) -openBAVL :: (e -> Ordering) -> AVL e -> BAVL e -{-# INLINE openBAVL #-} -openBAVL c t = bp `seq` BAVL t bp - where bp = openPath 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 !! diff --git a/Data/Tree/AVLX.hs b/Data/Tree/AVLX.hs deleted file mode 100644 --- a/Data/Tree/AVLX.hs +++ /dev/null @@ -1,63 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-duplicate-exports #-} ------------------------------------------------------------------------------ --- | --- 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, - module Data.Tree.AVL.Delete, - module Data.Tree.AVL.Join, - module Data.Tree.AVL.List, - module Data.Tree.AVL.Push, - module Data.Tree.AVL.Read, - module Data.Tree.AVL.Set, - module Data.Tree.AVL.Size, - module Data.Tree.AVL.Height, - module Data.Tree.AVL.Split, - module Data.Tree.AVL.Types, - module Data.Tree.AVL.Write, - module Data.Tree.AVL.Zipper, - module Data.Tree.AVL.BinPath, - module Data.Tree.AVL.Deprecated, - module Data.Tree.AVL.Internals.DelUtils, - module Data.Tree.AVL.Internals.HAVL, - module Data.Tree.AVL.Internals.HJoin, - module Data.Tree.AVL.Internals.HPush, - module Data.Tree.AVL.Internals.HSet, - module Data.Tree.AVL.Test.Counter, - module Data.Tree.AVL.Test.Utils, -) where - -import Data.Tree.AVL -import Data.Tree.AVL.Delete -import Data.Tree.AVL.Join -import Data.Tree.AVL.List -import Data.Tree.AVL.Push -import Data.Tree.AVL.Read -import Data.Tree.AVL.Set -import Data.Tree.AVL.Size -import Data.Tree.AVL.Height -import Data.Tree.AVL.Split -import Data.Tree.AVL.Types -import Data.Tree.AVL.Write -import Data.Tree.AVL.Zipper -import Data.Tree.AVL.BinPath -import Data.Tree.AVL.Internals.DelUtils -import Data.Tree.AVL.Internals.HAVL -import Data.Tree.AVL.Internals.HJoin -import Data.Tree.AVL.Internals.HPush -import Data.Tree.AVL.Internals.HSet -import Data.Tree.AVL.Test.Counter -import Data.Tree.AVL.Test.Utils -import Data.Tree.AVL.Deprecated - - diff --git a/Setup.hs b/Setup.hs deleted file mode 100644 --- a/Setup.hs +++ /dev/null @@ -1,3 +0,0 @@ -#!/usr/bin/runhaskell -import Distribution.Simple -main = defaultMain diff --git a/Test/Test.hs b/Test/Test.hs deleted file mode 100644 --- a/Test/Test.hs +++ /dev/null @@ -1,6 +0,0 @@ --- Run me after installation to test AVL lib. --- Takes a long time! -import Data.Tree.AVL.Test.AllTests(allTests) - -main :: IO () -main = allTests diff --git a/include/h98defs.h b/include/h98defs.h deleted file mode 100644 --- a/include/h98defs.h +++ /dev/null @@ -1,26 +0,0 @@ -#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 UBT6(u,v,w,x,y,z) ( u,v,w,x,y,z ) -#define IS_NEG(n) (n < 0) -#define LEFT_JUSTIFY_INT(m,n) (shiftL (m) (32-n)) diff --git a/src/Data/Tree/AVL.hs b/src/Data/Tree/AVL.hs new file mode 100644 --- /dev/null +++ b/src/Data/Tree/AVL.hs @@ -0,0 +1,358 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +-- | +-- Copyright : (c) Adrian Hey 2004,2008 +-- License : BSD3 +-- +-- 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 +-- @ +-- +module Data.Tree.AVL +(-- * Types + AVL, + + -- * Simple AVL related utilities + empty,isEmpty,isNonEmpty,singleton,pair,tryGetSingleton, + + -- * Reading from AVL trees + + -- ** Reading from extreme left or right + assertReadL,tryReadL, + assertReadR,tryReadR, + + -- ** Reading from /sorted/ AVL trees + assertRead,tryRead,tryReadMaybe,defaultRead, + + -- ** Simple searches of /sorted/ AVL trees + contains, + + -- * 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 + write,writeFast,tryWrite,writeMaybe,tryWriteMaybe, + + -- * \"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 + push,push',pushMaybe,pushMaybe', + + -- * Deleting elements from AVL trees + + -- ** Deleting from extreme left or right + delL,delR,assertDelL,assertDelR,tryDelL,tryDelR, + + -- ** Deleting from /sorted/ trees + delete,deleteFast,deleteIf,deleteMaybe, + + -- * \"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 + assertPop,tryPop,assertPopMaybe,tryPopMaybe,assertPopIf,tryPopIf, + + -- * 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 + union,unionMaybe,disjointUnion,unions, + + -- ** Difference + difference,differenceMaybe,symDifference, + + -- ** Intersection + intersection,intersectionMaybe, + + -- *** 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.) + intersectionToList,intersectionAsList, + intersectionMaybeToList,intersectionMaybeAsList, + + -- ** \'Venn diagram\' operations + -- | Given two sets A and B represented as sorted AVL trees, the venn operations evaluate + -- components @A-B@, @A.B@ and @B-A@. The intersection part may be obtained as a List + -- rather than AVL tree if required. + -- + -- Note that in all cases the three resulting sets are /disjoint/ and can safely be re-combined + -- after most \"munging\" operations using 'disjointUnion'. + venn,vennMaybe, + + -- *** \'Venn diagram\' operations with the intersection component as a List. + -- | These variants are provided for the same reasons as the Intersection as List variants. + vennToList,vennAsList, + vennMaybeToList,vennMaybeAsList, + + -- ** Subset + isSubsetOf,isSubsetOfBy, + + -- * 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 . + -- + -- 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 t'BAVL' as a cheaper alternative if you don't + -- need to navigate the tree. + + -- ** Types + ZAVL,PAVL, + + -- ** Opening + assertOpenL,assertOpenR, + tryOpenL,tryOpenR, + assertOpen,tryOpen, + tryOpenGE,tryOpenLE, + openEither, + + -- ** 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 + openBAVL,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, + + -- * Joining AVL trees + join,concatAVL,flatConcat, + + -- * 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 + asTree, + + -- ** \"Pushing\" unsorted Lists in sorted AVL trees + pushList, + + -- * Some analogues of common List functions + reverse,map,map', + mapAccumL ,mapAccumR , + mapAccumL' ,mapAccumR' , + replicate, + filter,mapMaybe, + filterViaList,mapMaybeViaList, + partition, + traverseAVL, + + -- ** 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. + foldr,foldr',foldr1,foldr1',foldr2,foldr2', + foldl,foldl',foldl1,foldl1',foldl2,foldl2', + + -- ** (GHC Only) + mapAccumL'',mapAccumR'', foldrInt#, + + -- * Some clones of common List functions + -- | These are a cure for the horrible @O(n^2)@ complexity the noddy Data.List definitions. + nub,nubBy, + + -- * \"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', + + -- * 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.Internals.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.Internals.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 'takeLT' 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. + forkL,forkR,fork, + takeLE,dropGT, + takeLT,dropGE, + takeGT,dropLE, + takeGE,dropLT, + + -- * AVL tree size utilities + size,addSize,clipSize, + addSize#,size#, + +-- * AVL tree height utilities + height,addHeight,compareHeight, + + -- * Low level Binary Path utilities + -- | This is the low level (unsafe) API used by the t'BAVL' type + BinPath(..),findFullPath,findEmptyPath,openPath,openPathWith,readPath,writePath,insertPath,deletePath, + + -- * Correctness checking + isBalanced,isSorted,isSortedOK, + + -- * Tree parameter utilities + minElements,maxElements, +) where + +import Prelude () +import Data.Functor (Functor, fmap) +import Data.Traversable (Traversable, traverse) +import Data.Tree.AVL.Internals.Types hiding (E,N,P,Z) +import Data.Tree.AVL.Utils +import Data.Tree.AVL.Size +import Data.Tree.AVL.Height +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) +import Data.Tree.AVL.BinPath(BinPath(..),findFullPath,findEmptyPath,openPath,openPathWith,readPath,writePath,insertPath) +import Data.Tree.AVL.Internals.DelUtils(deletePath) + +-- This definition has been placed here +-- to avoid introducing cyclic dependency between Types.hs and List.hs +instance Functor AVL where + fmap = map -- The lazy version. + +instance Traversable AVL where + traverse = traverseAVL diff --git a/src/Data/Tree/AVL/BinPath.hs b/src/Data/Tree/AVL/BinPath.hs new file mode 100644 --- /dev/null +++ b/src/Data/Tree/AVL/BinPath.hs @@ -0,0 +1,353 @@ +-- | +-- Copyright : (c) Adrian Hey 2005 +-- License : BSD3 +-- +-- This module provides a cheap but extremely limited and dangerous alternative +-- to using the Zipper. 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. +-- +-- See the BAVL type in Data.Tree.AVL.Zipper module for a safer wrapper round these +-- functions. +module Data.Tree.AVL.BinPath + (BinPath(..),findFullPath,findEmptyPath,openPath,openPathWith,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.Internals.Types(AVL(..)) +import Data.COrdering + +import GHC.Base +#include "ghcdefs.h" + +-- Test path LSB +bit0 :: Int# -> Bool +{-# INLINE bit0 #-} +bit0 p = isTrue# (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 isTrue# (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# + +-- | A BinPath is full if the search succeeded, empty otherwise. +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) +findFullPath :: (e -> Ordering) -> AVL e -> UINT +-- ?? What about strictness if UINT is boxed (i.e. non-ghc)? +findFullPath 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 + +-- | Find the path to a non-existant AVL tree element, returns -1 (invalid path) if element is found +-- +-- Complexity: O(log n) +findEmptyPath :: (e -> Ordering) -> AVL e -> UINT +-- ?? What about strictness if UINT is boxed (i.e. non-ghc)? +findEmptyPath c t = find L(1) L(0) t where + find _ i E = 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 -> L(-1) + 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) +openPath :: (e -> Ordering) -> AVL e -> BinPath e +openPath 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) +openPathWith :: (e -> COrdering a) -> AVL e -> BinPath a +openPathWith 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) !! diff --git a/src/Data/Tree/AVL/Delete.hs b/src/Data/Tree/AVL/Delete.hs new file mode 100644 --- /dev/null +++ b/src/Data/Tree/AVL/Delete.hs @@ -0,0 +1,514 @@ +-- | +-- Copyright : (c) Adrian Hey 2004,2005 +-- License : BSD3 +-- +{-# OPTIONS_HADDOCK hide #-} +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 + delete,deleteFast,deleteIf,deleteMaybe, + + -- * \"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 + assertPop,tryPop,assertPopMaybe,tryPopMaybe,assertPopIf,tryPopIf, +) where + +import Data.COrdering +import Data.Tree.AVL.Internals.Types(AVL(..)) +import Data.Tree.AVL.BinPath(BinPath(..),findFullPath,openPathWith,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 + ) + +#include "ghcdefs.h" + +-- | 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) +delete :: (e -> Ordering) -> AVL e -> AVL e +delete c t = case findFullPath c t of + L(-1) -> t -- Not found, p<0 + p -> deletePath p t -- Found, so delete + +-- | This version only deletes the element if the supplied selector returns @('Data.COrdering.Eq' 'True')@. +-- If it returns @('Data.COrdering.Eq' 'False')@ or if no matching element is found then this function returns +-- the original tree. +-- +-- Complexity: O(log n) +deleteIf :: (e -> COrdering Bool) -> AVL e -> AVL e +deleteIf c t = case openPathWith c t of + FullBP p True -> deletePath p t + _ -> t + +-- | This version only deletes the element if the supplied selector returns @('Data.COrdering.Eq' 'Nothing')@. +-- If it returns @('Data.COrdering.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) +deleteMaybe :: (e -> COrdering (Maybe e)) -> AVL e -> AVL e +deleteMaybe c t = case openPathWith c t of + FullBP p Nothing -> deletePath p t + FullBP p (Just e) -> writePath p e t + _ -> t + +-- | Functionally identical to 'delete', 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) +deleteFast :: (e -> Ordering) -> AVL e -> AVL e +-- This was the old delete so it's been tested OK, but as a different name. +deleteFast c = delete' where + delete' E = E + delete' (N l e r) = delN l e r + delete' (Z l e r) = delZ l e r + delete' (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) + +-- | 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) +assertPop :: (e -> COrdering a) -> AVL e -> (a,AVL e) +assertPop c = genPop_ where + genPop_ E = error "assertPop: 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 "assertPop: 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 "assertPop: 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 "assertPop: 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 "assertPop: 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) + +-- | Similar to 'assertPop', but this function returns 'Nothing' if the search fails. +-- +-- Complexity: O(log n) +tryPop :: (e -> COrdering a) -> AVL e -> Maybe (a,AVL e) +tryPop c t = case openPathWith 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) +assertPopMaybe :: (e -> COrdering (a,Maybe e)) -> AVL e -> (a,AVL e) +assertPopMaybe c t = case openPathWith 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 "assertPopMaybe: element not found." + +-- | Similar to 'assertPopMaybe', but returns 'Nothing' if the search fails. +-- +-- Complexity: O(log n) +tryPopMaybe :: (e -> COrdering (a,Maybe e)) -> AVL e -> Maybe (a,AVL e) +tryPopMaybe c t = case openPathWith 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 'assertPopMaybe'. 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) +assertPopIf :: (e -> COrdering (a,Bool)) -> AVL e -> (a,AVL e) +assertPopIf c t = case openPathWith c t of + FullBP _ (a,False) -> (a,t) + FullBP pth (a,True ) -> let t' = deletePath pth t in t' `seq` (a,t') + _ -> error "assertPopIf: element not found." + +-- | Similar to 'assertPopIf', but returns 'Nothing' if the search fails. +-- +-- Complexity: O(log n) +tryPopIf :: (e -> COrdering (a,Bool)) -> AVL e -> Maybe (a,AVL e) +tryPopIf c t = case openPathWith 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 + diff --git a/src/Data/Tree/AVL/Height.hs b/src/Data/Tree/AVL/Height.hs new file mode 100644 --- /dev/null +++ b/src/Data/Tree/AVL/Height.hs @@ -0,0 +1,84 @@ +-- | +-- Copyright : (c) Adrian Hey 2004,2005 +-- License : BSD3 +-- +-- 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. +{-# OPTIONS_HADDOCK hide #-} +module Data.Tree.AVL.Height + (-- * AVL tree height utilities. + height,addHeight,compareHeight, + ) where + +import Data.Tree.AVL.Internals.Types(AVL(..)) + +import GHC.Base +#include "ghcdefs.h" + +-- | 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 + diff --git a/src/Data/Tree/AVL/Internals/DelUtils.hs b/src/Data/Tree/AVL/Internals/DelUtils.hs new file mode 100644 --- /dev/null +++ b/src/Data/Tree/AVL/Internals/DelUtils.hs @@ -0,0 +1,731 @@ +-- | +-- Copyright : (c) Adrian Hey 2004,2005 +-- License : BSD3 +-- +-- 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.Internals.Types(AVL(..)) +import Data.Tree.AVL.BinPath(sel,goL,goR) + +import GHC.Base +#include "ghcdefs.h" + +{------------------------------------------------------------------------------------------------------------------------------ + -------------------------------------- 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 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 + +-------------------------- 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) + +-------------------------- 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) + +-------------------------- 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) + +-- | Deletes a tree element. Assumes the path bits were extracted +-- from a 'Data.Tree.AVL.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) + +-- | 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) + +{-************************** 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 + diff --git a/src/Data/Tree/AVL/Internals/HAVL.hs b/src/Data/Tree/AVL/Internals/HAVL.hs new file mode 100644 --- /dev/null +++ b/src/Data/Tree/AVL/Internals/HAVL.hs @@ -0,0 +1,87 @@ +-- | +-- Copyright : (c) Adrian Hey 2004,2005 +-- License : BSD3 +-- +-- HAVL data type and related utilities +{-# OPTIONS_HADDOCK hide #-} +module Data.Tree.AVL.Internals.HAVL + ( + HAVL(HAVL),emptyHAVL,toHAVL,isEmptyHAVL,isNonEmptyHAVL, + spliceHAVL,joinHAVL, + pushLHAVL,pushRHAVL + ) where + +import Data.Tree.AVL.Internals.Types(AVL(..)) +import Data.Tree.AVL.Height(addHeight) +import Data.Tree.AVL.Internals.HJoin(spliceH,joinH) +import Data.Tree.AVL.Internals.HPush(pushHL,pushHR) + +import GHC.Base +#include "ghcdefs.h" + +-- | 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 'Data.Tree.AVL.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 'Data.Tree.AVL.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_ + diff --git a/src/Data/Tree/AVL/Internals/HJoin.hs b/src/Data/Tree/AVL/Internals/HJoin.hs new file mode 100644 --- /dev/null +++ b/src/Data/Tree/AVL/Internals/HJoin.hs @@ -0,0 +1,305 @@ +-- | +-- Copyright : (c) Adrian Hey 2004,2005 +-- License : BSD3 +-- +-- Functions for joining AVL trees of known height. +module Data.Tree.AVL.Internals.HJoin + ( spliceH,joinH,joinH', + ) where + +import Data.Tree.AVL.Internals.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) + +import GHC.Base +#include "ghcdefs.h" + +-- | 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 isTrue# (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 + +-- | 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 isTrue# (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 isTrue# (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) + +-- 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" + +-- 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" diff --git a/src/Data/Tree/AVL/Internals/HPush.hs b/src/Data/Tree/AVL/Internals/HPush.hs new file mode 100644 --- /dev/null +++ b/src/Data/Tree/AVL/Internals/HPush.hs @@ -0,0 +1,171 @@ +-- | +-- Copyright : (c) Adrian Hey 2004,2005 +-- License : BSD3 +-- +-- Functions for pushing elements into trees of known height. +module Data.Tree.AVL.Internals.HPush + (pushHL,pushHR,pushHL_,pushHR_, + ) where + +import Data.Tree.AVL.Internals.Types(AVL(..)) + +import GHC.Base +#include "ghcdefs.h" + +-- | A version of 'Data.Tree.AVL.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 'Data.Tree.AVL.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 !! + +-- | 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 diff --git a/src/Data/Tree/AVL/Internals/HSet.hs b/src/Data/Tree/AVL/Internals/HSet.hs new file mode 100644 --- /dev/null +++ b/src/Data/Tree/AVL/Internals/HSet.hs @@ -0,0 +1,950 @@ +-- | +-- Copyright : (c) Adrian Hey 2004,2005 +-- License : BSD3 +-- +-- 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,disjointUnionH, + + -- * Intersection primitives. + intersectionH,intersectionMaybeH, + + -- * Difference primitives. + differenceH,differenceMaybeH,symDifferenceH, + + -- * Venn primitives + vennH,vennMaybeH, + ) where + +import Data.Tree.AVL.Internals.Types(AVL(..)) +import Data.Tree.AVL.Internals.HJoin(spliceH,joinH) + +import Data.COrdering + +import GHC.Base +#include "ghcdefs.h" + +-- | 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_) + +-- | 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_) + +-- | Uses the supplied comparison to evaluate the union of two /disjoint/ sets represented as +-- sorted AVL trees of known height. This function raises an error if the two sets intersect. +-- +-- Complexity: Not sure, but I\'d appreciate it if someone could figure it out. +-- (Faster than Hedge union from Data.Set at any rate). +disjointUnionH :: (e -> e -> Ordering) -> AVL e -> UINT -> AVL e -> UINT -> UBT2(AVL e,UINT) +disjointUnionH 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 fork e1 r0 hr0 of + UBT4(rl0,hrl0,rr0,hrr0) -> case fork e0 l1 hl1 of -- (e0 < rl0 < e1) & (e0 < e1 < rr0) + UBT4(ll1,hll1,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 -> error "disjointUnionH: Trees intersect" `seq` UBT2(E,L(0)) + -- e1 < e0, so (l1 < e1 < e0) & (e1 < e0 < r0) + GT -> case fork e0 r1 hr1 of + UBT4(rl1,hrl1,rr1,hrr1) -> case fork e1 l0 hl0 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 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 + -- fork :: e -> AVL e -> UINT -> UBT4(AVL e,UINT,AVL e,UINT) + fork e0 t1 ht1 = fork_ t1 ht1 where + fork_ E _ = UBT4(E, L(0), E, L(0)) + fork_ (N l e r) h = fork__ l DECINT2(h) e r DECINT1(h) + fork_ (Z l e r) h = fork__ l DECINT1(h) e r DECINT1(h) + fork_ (P l e r) h = fork__ l DECINT1(h) e r DECINT2(h) + fork__ l hl e r hr = case c e0 e of + LT -> case fork_ l hl of + UBT4(l0,hl0,l1,hl1) -> case spliceH l1 hl1 e r hr of + UBT2(l1_,hl1_) -> UBT4(l0,hl0,l1_,hl1_) + EQ -> error "disjointUnionH: Trees intersect" `seq` UBT4(E, L(0), E, L(0)) + GT -> case fork_ r hr of + UBT4(l0,hl0,l1,hl1) -> case spliceH l hl e l0 hl0 of + UBT2(l0_,hl0_) -> UBT4(l0_,hl0_,l1,hl1) + +-- | 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 cmp = 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 cmp 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 cmp 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 cmp 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_) + +-- | 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_) + +-- | 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_) + +-- | 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_) + +-- | 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 fork e1 r0 hr0 of + UBT5(rl0,hrl0,be1,rr0,hrr0) -> case fork 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 fork e0 r1 hr1 of + UBT5(rl1,hrl1,be0,rr1,hrr1) -> case fork e1 l0 hl0 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 + -- fork :: e -> AVL e -> UINT -> UBT5(AVL e,UINT,Bool,AVL e,UINT) + fork e0 t1 ht1 = fork_ t1 ht1 where + fork_ E _ = UBT5(E, L(0), True, E, L(0)) + fork_ (N l e r) h = fork__ l DECINT2(h) e r DECINT1(h) + fork_ (Z l e r) h = fork__ l DECINT1(h) e r DECINT1(h) + fork_ (P l e r) h = fork__ l DECINT1(h) e r DECINT2(h) + fork__ l hl e r hr = case c e0 e of + LT -> case fork_ 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 fork_ 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) + +-- | Given two Sets @A@ and @B@ represented as sorted AVL trees, this function extracts +-- the \'Venn diagram\' components @A-B@, @A.B@ and @B-A@. +-- The two difference components are sorted AVL trees. +-- The intersection component is prepended to the input List in ascending sorted in ascending order. +-- The number of elements prepended is added to the corresponding Int argument (which may or may +-- not be the List length). +-- See also 'vennMaybeH'. +-- +-- Complexity: Not sure, but I\'d appreciate it if someone could figure it out. +vennH :: (a -> b -> COrdering c) -> [c] -> UINT -> AVL a -> UINT -> AVL b -> UINT -> UBT6(AVL a,UINT,[c],UINT,AVL b,UINT) +vennH cmp = v where + -- v :: [c] -> UINT -> AVL a -> UINT -> AVL b -> UINT -> UBT6(AVL a,UINT,[c],UINT,AVL b,UINT) + v cs cl E ha tb hb = UBT6(E ,ha,cs,cl,tb,hb) + v cs cl ta ha E hb = UBT6(ta,ha,cs,cl,E ,hb) + v cs cl (N la a ra) ha (N lb b rb) hb = v_ cs cl la DECINT2(ha) a ra DECINT1(ha) lb DECINT2(hb) b rb DECINT1(hb) + v cs cl (N la a ra) ha (Z lb b rb) hb = v_ cs cl la DECINT2(ha) a ra DECINT1(ha) lb DECINT1(hb) b rb DECINT1(hb) + v cs cl (N la a ra) ha (P lb b rb) hb = v_ cs cl la DECINT2(ha) a ra DECINT1(ha) lb DECINT1(hb) b rb DECINT2(hb) + v cs cl (Z la a ra) ha (N lb b rb) hb = v_ cs cl la DECINT1(ha) a ra DECINT1(ha) lb DECINT2(hb) b rb DECINT1(hb) + v cs cl (Z la a ra) ha (Z lb b rb) hb = v_ cs cl la DECINT1(ha) a ra DECINT1(ha) lb DECINT1(hb) b rb DECINT1(hb) + v cs cl (Z la a ra) ha (P lb b rb) hb = v_ cs cl la DECINT1(ha) a ra DECINT1(ha) lb DECINT1(hb) b rb DECINT2(hb) + v cs cl (P la a ra) ha (N lb b rb) hb = v_ cs cl la DECINT1(ha) a ra DECINT2(ha) lb DECINT2(hb) b rb DECINT1(hb) + v cs cl (P la a ra) ha (Z lb b rb) hb = v_ cs cl la DECINT1(ha) a ra DECINT2(ha) lb DECINT1(hb) b rb DECINT1(hb) + v cs cl (P la a ra) ha (P lb b rb) hb = v_ cs cl la DECINT1(ha) a ra DECINT2(ha) lb DECINT1(hb) b rb DECINT2(hb) + v_ cs cl la hla a ra hra lb hlb b rb hrb = + case cmp a b of + -- a < b, so (la < a < b) & (a < b < rb) + Lt -> case forka cmp a lb hlb of + UBT5(llb,hllb,mbca,rlb,hrlb) -> case forkb cmp b ra hra of + UBT5(lra,hlra,mbcb,rra,hrra) -> + -- (la + llb) < a < (lra + rlb) < b < (rra + rb) + case v cs cl rra hrra rb hrb of + UBT6(rab,hrab,cs0,cl0,rba,hrba) -> case (case mbcb of + Nothing -> case v cs0 cl0 lra hlra rlb hrlb of + UBT6(mab,hmab,cs1,cl1,mba,hmba) -> case spliceH mba hmba b rba hrba of + UBT2(mrba,hmrba) -> UBT6(mab,hmab,cs1,cl1,mrba,hmrba) + Just cb -> case v (cb:cs0) INCINT1(cl0) lra hlra rlb hrlb of + UBT6(mab,hmab,cs1,cl1,mba,hmba) -> case joinH mba hmba rba hrba of + UBT2(mrba,hmrba) -> UBT6(mab,hmab,cs1,cl1,mrba,hmrba) + ) of + UBT6(mab,hmab,cs1,cl1,mrba,hmrba) -> case joinH mab hmab rab hrab of + UBT2(mrab,hmrab) -> case (case mbca of + Nothing -> case v cs1 cl1 la hla llb hllb of + UBT6(lab,hlab,cs2,cl2,lba,hlba) -> case spliceH lab hlab a mrab hmrab of + UBT2(ab,hab) -> UBT6(ab,hab,cs2,cl2,lba,hlba) + Just ca -> case v (ca:cs1) INCINT1(cl1) la hla llb hllb of + UBT6(lab,hlab,cs2,cl2,lba,hlba) -> case joinH lab hlab mrab hmrab of + UBT2(ab,hab) -> UBT6(ab,hab,cs2,cl2,lba,hlba) + ) of + UBT6(ab,hab,cs2,cl2,lba,hlba) -> case joinH lba hlba mrba hmrba of + UBT2(ba,hba) -> UBT6(ab,hab,cs2,cl2,ba,hba) + -- a = b + Eq c -> case v cs cl ra hra rb hrb of + UBT6(rab,hrab,cs0,cl0,rba,hrba) -> case v (c:cs0) INCINT1(cl0) la hla lb hlb of + UBT6(lab,hlab,cs1,cl1,lba,hlba) -> case joinH lab hlab rab hrab of + UBT2(ab,hab) -> case joinH lba hlba rba hrba of + UBT2(ba,hba) -> UBT6(ab,hab,cs1,cl1,ba,hba) + -- b < a, so (lb < b < a) & (b < a < ra) + Gt -> case forka cmp a rb hrb of + UBT5(lrb,hlrb,mbca,rrb,hrrb) -> case forkb cmp b la hla of + UBT5(lla,hlla,mbcb,rla,hrla) -> + -- (lla + lb) < b < (rla + lrb) < a < (ra + rrb) + case v cs cl ra hra rrb hrrb of + UBT6(rab,hrab,cs0,cl0,rba,hrba) -> case (case mbca of + Nothing -> case v cs0 cl0 rla hrla lrb hlrb of + UBT6(mab,hmab,cs1,cl1,mba,hmba) -> case spliceH mab hmab a rab hrab of + UBT2(mrab,hmrab) -> UBT6(mrab,hmrab,cs1,cl1,mba,hmba) + Just ca -> case v (ca:cs0) INCINT1(cl0) rla hrla lrb hlrb of + UBT6(mab,hmab,cs1,cl1,mba,hmba) -> case joinH mab hmab rab hrab of + UBT2(mrab,hmrab) -> UBT6(mrab,hmrab,cs1,cl1,mba,hmba) + ) of + UBT6(mrab,hmrab,cs1,cl1,mba,hmba) -> case joinH mba hmba rba hrba of + UBT2(mrba,hmrba) -> case (case mbcb of + Nothing -> case v cs1 cl1 lla hlla lb hlb of + UBT6(lab,hlab,cs2,cl2,lba,hlba) -> case spliceH lba hlba b mrba hmrba of + UBT2(ba,hba) -> UBT6(lab,hlab,cs2,cl2,ba,hba) + Just cb -> case v (cb:cs1) INCINT1(cl1) lla hlla lb hlb of + UBT6(lab,hlab,cs2,cl2,lba,hlba) -> case joinH lba hlba mrba hmrba of + UBT2(ba,hba) -> UBT6(lab,hlab,cs2,cl2,ba,hba) + ) of + UBT6(lab,hlab,cs2,cl2,ba,hba) -> case joinH lab hlab mrab hmrab of + UBT2(ab,hab) -> UBT6(ab,hab,cs2,cl2,ba,hba) + +-- | Similar to 'vennH', but intersection elements for which the combining comparison +-- returns @('Data.COrdering.Eq' 'Nothing')@ are deleted from the intersection list. +-- +-- Complexity: Not sure, but I\'d appreciate it if someone could figure it out. +vennMaybeH :: (a -> b -> COrdering (Maybe c)) -> [c] -> UINT -> AVL a -> UINT -> AVL b -> UINT -> UBT6(AVL a,UINT,[c],UINT,AVL b,UINT) +vennMaybeH cmp = v where + -- v :: [c] -> UINT -> AVL a -> UINT -> AVL b -> UINT -> UBT6(AVL a,UINT,[c],UINT,AVL b,UINT) + v cs cl E ha tb hb = UBT6(E ,ha,cs,cl,tb,hb) + v cs cl ta ha E hb = UBT6(ta,ha,cs,cl,E ,hb) + v cs cl (N la a ra) ha (N lb b rb) hb = v_ cs cl la DECINT2(ha) a ra DECINT1(ha) lb DECINT2(hb) b rb DECINT1(hb) + v cs cl (N la a ra) ha (Z lb b rb) hb = v_ cs cl la DECINT2(ha) a ra DECINT1(ha) lb DECINT1(hb) b rb DECINT1(hb) + v cs cl (N la a ra) ha (P lb b rb) hb = v_ cs cl la DECINT2(ha) a ra DECINT1(ha) lb DECINT1(hb) b rb DECINT2(hb) + v cs cl (Z la a ra) ha (N lb b rb) hb = v_ cs cl la DECINT1(ha) a ra DECINT1(ha) lb DECINT2(hb) b rb DECINT1(hb) + v cs cl (Z la a ra) ha (Z lb b rb) hb = v_ cs cl la DECINT1(ha) a ra DECINT1(ha) lb DECINT1(hb) b rb DECINT1(hb) + v cs cl (Z la a ra) ha (P lb b rb) hb = v_ cs cl la DECINT1(ha) a ra DECINT1(ha) lb DECINT1(hb) b rb DECINT2(hb) + v cs cl (P la a ra) ha (N lb b rb) hb = v_ cs cl la DECINT1(ha) a ra DECINT2(ha) lb DECINT2(hb) b rb DECINT1(hb) + v cs cl (P la a ra) ha (Z lb b rb) hb = v_ cs cl la DECINT1(ha) a ra DECINT2(ha) lb DECINT1(hb) b rb DECINT1(hb) + v cs cl (P la a ra) ha (P lb b rb) hb = v_ cs cl la DECINT1(ha) a ra DECINT2(ha) lb DECINT1(hb) b rb DECINT2(hb) + v_ cs cl la hla a ra hra lb hlb b rb hrb = + case cmp a b of + -- a < b, so (la < a < b) & (a < b < rb) + Lt -> case forka cmp a lb hlb of + UBT5(llb,hllb,mbmbca,rlb,hrlb) -> case forkb cmp b ra hra of + UBT5(lra,hlra,mbmbcb,rra,hrra) -> + -- (la + llb) < a < (lra + rlb) < b < (rra + rb) + case v cs cl rra hrra rb hrb of + UBT6(rab,hrab,cs0,cl0,rba,hrba) -> case (case mbmbcb of + Nothing -> case v cs0 cl0 lra hlra rlb hrlb of + UBT6(mab,hmab,cs1,cl1,mba,hmba) -> case spliceH mba hmba b rba hrba of + UBT2(mrba,hmrba) -> UBT6(mab,hmab,cs1,cl1,mrba,hmrba) + Just mbcb -> case (case mbcb of + Nothing -> v cs0 cl0 lra hlra rlb hrlb + Just cb -> v (cb:cs0) INCINT1(cl0) lra hlra rlb hrlb + ) of + UBT6(mab,hmab,cs1,cl1,mba,hmba) -> case joinH mba hmba rba hrba of + UBT2(mrba,hmrba) -> UBT6(mab,hmab,cs1,cl1,mrba,hmrba) + ) of + UBT6(mab,hmab,cs1,cl1,mrba,hmrba) -> case joinH mab hmab rab hrab of + UBT2(mrab,hmrab) -> case (case mbmbca of + Nothing -> case v cs1 cl1 la hla llb hllb of + UBT6(lab,hlab,cs2,cl2,lba,hlba) -> case spliceH lab hlab a mrab hmrab of + UBT2(ab,hab) -> UBT6(ab,hab,cs2,cl2,lba,hlba) + Just mbca -> case (case mbca of + Nothing -> v cs1 cl1 la hla llb hllb + Just ca -> v (ca:cs1) INCINT1(cl1) la hla llb hllb + ) of + UBT6(lab,hlab,cs2,cl2,lba,hlba) -> case joinH lab hlab mrab hmrab of + UBT2(ab,hab) -> UBT6(ab,hab,cs2,cl2,lba,hlba) + ) of + UBT6(ab,hab,cs2,cl2,lba,hlba) -> case joinH lba hlba mrba hmrba of + UBT2(ba,hba) -> UBT6(ab,hab,cs2,cl2,ba,hba) + -- a = b + Eq mbc -> case v cs cl ra hra rb hrb of + UBT6(rab,hrab,cs0,cl0,rba,hrba) -> case (case mbc of + Nothing -> v cs0 cl0 la hla lb hlb + Just c -> v (c:cs0) INCINT1(cl0) la hla lb hlb + ) of + UBT6(lab,hlab,cs1,cl1,lba,hlba) -> case joinH lab hlab rab hrab of + UBT2(ab,hab) -> case joinH lba hlba rba hrba of + UBT2(ba,hba) -> UBT6(ab,hab,cs1,cl1,ba,hba) + -- b < a, so (lb < b < a) & (b < a < ra) + Gt -> case forka cmp a rb hrb of + UBT5(lrb,hlrb,mbmbca,rrb,hrrb) -> case forkb cmp b la hla of + UBT5(lla,hlla,mbmbcb,rla,hrla) -> + -- (lla + lb) < b < (rla + lrb) < a < (ra + rrb) + case v cs cl ra hra rrb hrrb of + UBT6(rab,hrab,cs0,cl0,rba,hrba) -> case (case mbmbca of + Nothing -> case v cs0 cl0 rla hrla lrb hlrb of + UBT6(mab,hmab,cs1,cl1,mba,hmba) -> case spliceH mab hmab a rab hrab of + UBT2(mrab,hmrab) -> UBT6(mrab,hmrab,cs1,cl1,mba,hmba) + Just mbca -> case (case mbca of + Nothing -> v cs0 cl0 rla hrla lrb hlrb + Just ca -> v (ca:cs0) INCINT1(cl0) rla hrla lrb hlrb + ) of + UBT6(mab,hmab,cs1,cl1,mba,hmba) -> case joinH mab hmab rab hrab of + UBT2(mrab,hmrab) -> UBT6(mrab,hmrab,cs1,cl1,mba,hmba) + ) of + UBT6(mrab,hmrab,cs1,cl1,mba,hmba) -> case joinH mba hmba rba hrba of + UBT2(mrba,hmrba) -> case (case mbmbcb of + Nothing -> case v cs1 cl1 lla hlla lb hlb of + UBT6(lab,hlab,cs2,cl2,lba,hlba) -> case spliceH lba hlba b mrba hmrba of + UBT2(ba,hba) -> UBT6(lab,hlab,cs2,cl2,ba,hba) + Just mbcb -> case (case mbcb of + Nothing -> v cs1 cl1 lla hlla lb hlb + Just cb -> v (cb:cs1) INCINT1(cl1) lla hlla lb hlb + ) of + UBT6(lab,hlab,cs2,cl2,lba,hlba) -> case joinH lba hlba mrba hmrba of + UBT2(ba,hba) -> UBT6(lab,hlab,cs2,cl2,ba,hba) + ) of + UBT6(lab,hlab,cs2,cl2,ba,hba) -> case joinH lab hlab mrab hmrab of + UBT2(ab,hab) -> UBT6(ab,hab,cs2,cl2,ba,hba) + +-- Common forks used by vennH,vennMaybeH +-- We need 2 different versions of fork to ensure that comparison arguments are used in +-- the right order (c a b) +forka :: (a -> b -> COrdering c) -> a -> AVL b -> UINT -> UBT5(AVL b,UINT,Maybe c,AVL b,UINT) +forka cmp a tb htb = f tb htb where + f E _ = UBT5(E,L(0),Nothing,E,L(0)) + f n@(N _ b r) L(2) = case cmp a b of -- l must be E, r must be Z + Lt -> UBT5(E,L(0),Nothing,n,L(2)) + Eq c -> UBT5(E,L(0),Just c ,r,L(1)) + Gt -> case r of + Z _ br _ -> case cmp a br of -- l & r must be E + Lt -> UBT5(Z E b E,L(1),Nothing,r,L(1)) + Eq c -> UBT5(Z E b E,L(1),Just c ,E,L(0)) + Gt -> UBT5(n ,L(2),Nothing,E,L(0)) + _ -> undefined `seq` UBT5(E,L(0),Nothing,E,L(0)) + f (N l b r) h = f_ l DECINT2(h) b r DECINT1(h) + f z@(Z l b r) L(2) = case cmp a b of -- l & r must be Z + Lt -> case l of + Z _ bl _ -> case cmp a bl of -- l & r must be E + Lt -> UBT5(E,L(0),Nothing,z ,L(2)) + Eq c -> UBT5(E,L(0),Just c ,N E b r,L(2)) + Gt -> UBT5(l,L(1),Nothing,N E b r,L(2)) + _ -> undefined `seq` UBT5(E,L(0),Nothing,E,L(0)) + Eq c -> UBT5(l,L(1),Just c,r,L(1)) + Gt -> case r of + Z _ br _ -> case cmp a br of -- l & r must be E + Lt -> UBT5(P l b E,L(2),Nothing,r,L(1)) + Eq c -> UBT5(P l b E,L(2),Just c ,E,L(0)) + Gt -> UBT5(z ,L(2),Nothing,E,L(0)) + _ -> undefined `seq` UBT5(E,L(0),Nothing,E,L(0)) + f z@(Z _ b _) L(1) = case cmp a b of -- l & r must be E + Lt -> UBT5(E,L(0),Nothing,z,L(1)) + Eq c -> UBT5(E,L(0),Just c ,E,L(0)) + Gt -> UBT5(z,L(1),Nothing,E,L(0)) + f (Z l b r) h = f_ l DECINT1(h) b r DECINT1(h) + f p@(P l b _) L(2) = case cmp a b of -- l must be Z, r must be E + Lt -> case l of + Z _ bl _ -> case cmp a bl of -- l & r must be E + Lt -> UBT5(E,L(0),Nothing,p ,L(2)) + Eq c -> UBT5(E,L(0),Just c ,Z E b E,L(1)) + Gt -> UBT5(l,L(1),Nothing,Z E b E,L(1)) + _ -> undefined `seq` UBT5(E,L(0),Nothing,E,L(0)) + Eq c -> UBT5(l,L(1),Just c ,E,L(0)) + Gt -> UBT5(p,L(2),Nothing,E,L(0)) + f (P l b r) h = f_ l DECINT1(h) b r DECINT2(h) + f_ l hl b r hr = case cmp a b of + Lt -> case f l hl of + UBT5(ll,hll,mbc,lr,hlr) -> case spliceH lr hlr b r hr of + UBT2(r_,hr_) -> UBT5(ll,hll,mbc,r_,hr_) + Eq c -> UBT5(l,hl,Just c,r,hr) + Gt -> case f r hr of + UBT5(rl,hrl,mbc,rr,hrr) -> case spliceH l hl b rl hrl of + UBT2(l_,hl_) -> UBT5(l_,hl_,mbc,rr,hrr) + +-- This should be exactly the same as forka, but with the following swaps: +-- * a <-> b, except is compare! +-- * Lt <-> Gt (becasuse we didn't swap in compare) +forkb :: (a -> b -> COrdering c) -> b -> AVL a -> UINT -> UBT5(AVL a,UINT,Maybe c,AVL a,UINT) +forkb cmp b ta hta = f ta hta where + f E _ = UBT5(E,L(0),Nothing,E,L(0)) + f n@(N _ a r) L(2) = case cmp a b of -- l must be E, r must be Z + Gt -> UBT5(E,L(0),Nothing,n,L(2)) + Eq c -> UBT5(E,L(0),Just c ,r,L(1)) + Lt -> case r of + Z _ ar _ -> case cmp ar b of -- l & r must be E + Gt -> UBT5(Z E a E,L(1),Nothing,r,L(1)) + Eq c -> UBT5(Z E a E,L(1),Just c ,E,L(0)) + Lt -> UBT5(n ,L(2),Nothing,E,L(0)) + _ -> undefined `seq` UBT5(E,L(0),Nothing,E,L(0)) + f (N l a r) h = f_ l DECINT2(h) a r DECINT1(h) + f z@(Z l a r) L(2) = case cmp a b of -- l & r must be Z + Gt -> case l of + Z _ al _ -> case cmp al b of -- l & r must be E + Gt -> UBT5(E,L(0),Nothing,z ,L(2)) + Eq c -> UBT5(E,L(0),Just c ,N E a r,L(2)) + Lt -> UBT5(l,L(1),Nothing,N E a r,L(2)) + _ -> undefined `seq` UBT5(E,L(0),Nothing,E,L(0)) + Eq c -> UBT5(l,L(1),Just c,r,L(1)) + Lt -> case r of + Z _ ar _ -> case cmp ar b of -- l & r must be E + Gt -> UBT5(P l a E,L(2),Nothing,r,L(1)) + Eq c -> UBT5(P l a E,L(2),Just c ,E,L(0)) + Lt -> UBT5(z ,L(2),Nothing,E,L(0)) + _ -> undefined `seq` UBT5(E,L(0),Nothing,E,L(0)) + f z@(Z _ a _) L(1) = case cmp a b of -- l & r must be E + Gt -> UBT5(E,L(0),Nothing,z,L(1)) + Eq c -> UBT5(E,L(0),Just c ,E,L(0)) + Lt -> UBT5(z,L(1),Nothing,E,L(0)) + f (Z l a r) h = f_ l DECINT1(h) a r DECINT1(h) + f p@(P l a _) L(2) = case cmp a b of -- l must be Z, r must be E + Gt -> case l of + Z _ al _ -> case cmp al b of -- l & r must be E + Gt -> UBT5(E,L(0),Nothing,p ,L(2)) + Eq c -> UBT5(E,L(0),Just c ,Z E a E,L(1)) + Lt -> UBT5(l,L(1),Nothing,Z E a E,L(1)) + _ -> undefined `seq` UBT5(E,L(0),Nothing,E,L(0)) + Eq c -> UBT5(l,L(1),Just c ,E,L(0)) + Lt -> UBT5(p,L(2),Nothing,E,L(0)) + f (P l a r) h = f_ l DECINT1(h) a r DECINT2(h) + f_ l hl a r hr = case cmp a b of + Gt -> case f l hl of + UBT5(ll,hll,mbc,lr,hlr) -> case spliceH lr hlr a r hr of + UBT2(r_,hr_) -> UBT5(ll,hll,mbc,r_,hr_) + Eq c -> UBT5(l,hl,Just c,r,hr) + Lt -> case f r hr of + UBT5(rl,hrl,mbc,rr,hrr) -> case spliceH l hl a rl hrl of + UBT2(l_,hl_) -> UBT5(l_,hl_,mbc,rr,hrr) + + diff --git a/src/Data/Tree/AVL/Internals/Types.hs b/src/Data/Tree/AVL/Internals/Types.hs new file mode 100644 --- /dev/null +++ b/src/Data/Tree/AVL/Internals/Types.hs @@ -0,0 +1,89 @@ +-- | +-- Copyright : (c) Adrian Hey 2004,2005 +-- License : BSD3 +-- +-- AVL Tree data type definition. +-- +-- This is an internal unstable module, it's contents may change +-- in any way whatsoever and without any warning between minor versions of this package. +-- PVP does not apply. +{-# OPTIONS_HADDOCK hide #-} +module Data.Tree.AVL.Internals.Types + ( -- * Types + AVL(..), + ) where + +-- | 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. +-- +-- Controlling Strictness. +-- +-- The 'AVL' tree 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). +-- +-- The 'Eq' and 'Ord' instances. +-- +-- Begining with version 3.0 these are now derived, and hence are defined in terms of +-- strict structural equality, rather than observational equivalence. The reason for +-- this change is that the observational equivalence abstraction was technically breakable +-- with the exposed API. But since this change, some functions which were previously +-- considered unsafe have become safe to expose (those that measure tree height, for example). +-- +-- The 'Read' and 'Show' instances. +-- +-- Begining with version 4.0 these are now derived to ensure consistency with 'Eq' instance. +-- (Show now reveals the exact tree structure). +-- + +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) + deriving(Eq,Ord,Show,Read) + +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 diff --git a/src/Data/Tree/AVL/Join.hs b/src/Data/Tree/AVL/Join.hs new file mode 100644 --- /dev/null +++ b/src/Data/Tree/AVL/Join.hs @@ -0,0 +1,108 @@ +-- | +-- Copyright : (c) Adrian Hey 2004,2005 +-- License : BSD3 +-- +{-# OPTIONS_HADDOCK hide #-} +module Data.Tree.AVL.Join +(-- * Joining AVL trees + join,concatAVL,flatConcat, +) where + +import Prelude () +import Data.Tree.AVL.Internals.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.Height(height,addHeight) +import Data.Tree.AVL.Internals.HJoin(joinH',spliceH) +import Data.Foldable (foldl', foldr) + +import GHC.Exts +#include "ghcdefs.h" + +-- | 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 isTrue# (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) + +-- | 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) diff --git a/src/Data/Tree/AVL/List.hs b/src/Data/Tree/AVL/List.hs new file mode 100644 --- /dev/null +++ b/src/Data/Tree/AVL/List.hs @@ -0,0 +1,838 @@ +-- | +-- Copyright : (c) Adrian Hey 2004,2005 +-- License : BSD3 +-- +{-# OPTIONS_HADDOCK hide #-} +{-# LANGUAGE ScopedTypeVariables #-} + +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 + asTree, + + -- ** \"Pushing\" unsorted Lists in sorted AVL trees + pushList, + + -- * Some analogues of common List functions + reverse,map,map', + mapAccumL ,mapAccumR , + mapAccumL' ,mapAccumR' , + replicate, + filter,mapMaybe, + filterViaList,mapMaybeViaList, + partition, + traverseAVL, + + -- ** 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. + foldr,foldr',foldr1,foldr1',foldr2,foldr2', + foldl,foldl',foldl1,foldl1',foldl2,foldl2', + + -- ** (GHC Only) + mapAccumL'',mapAccumR'', foldrInt#, + + -- * Some clones of common List functions + -- | These are a cure for the horrible @O(n^2)@ complexity the noddy Data.List definitions. + nub,nubBy, + + -- * \"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', +) where + +import Prelude (seq, (+), (-), odd, error) +import Data.Eq ((==)) +import Data.Bool (Bool(..), (||)) +import Data.Int (Int) +import Data.Foldable (length) +import Data.Maybe (Maybe(..)) +import Data.Ord (Ord, compare, Ordering) +import Data.COrdering +import Data.Tree.AVL.Internals.Types(AVL(..)) +import Data.Tree.AVL.Utils(empty) +import Data.Tree.AVL.Size(size) +import Data.Tree.AVL.Push(push) +import Data.Tree.AVL.BinPath(findEmptyPath,insertPath) +import Data.Tree.AVL.Internals.HJoin(spliceH,joinH) + +import Data.Bits(shiftR,(.&.)) +import qualified Data.List as List (foldl',map) +import Control.Applicative hiding (empty) + +import GHC.Base(Int#,(-#)) +#include "ghcdefs.h" + +-- | 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 'foldr'' for a strict version. +-- +-- It behaves as if defined.. +-- +-- > foldr f a avl = foldr f a (asListL avl) +-- +-- For example, the 'asListL' function could be defined.. +-- +-- > asListL = foldr (:) [] +-- +-- Complexity: O(n) +foldr :: (e -> a -> a) -> a -> AVL e -> a +foldr 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 'foldr', 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) +foldr' :: (e -> a -> a) -> a -> AVL e -> a +foldr' 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 'foldr1'' for a strict version. +-- +-- > foldr1 f avl = foldr1 f (asListL avl) +-- +-- This function raises an error if the tree is empty. +-- +-- Complexity: O(n) +foldr1 :: (e -> e -> e) -> AVL e -> e +foldr1 f = foldU where + foldU E = error "foldr1: 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 = foldr f (f e (foldU r)) l + -- Use this when r might be E + foldW l e E = foldr f e l + foldW l e (N rl re rr) = foldr 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 = foldr f (f e (foldW rl re rr)) l + +-- | The strict version of 'foldr1', 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) +foldr1' :: (e -> e -> e) -> AVL e -> e +foldr1' f = foldU where + foldU E = error "foldr1': 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` foldr' f a' l + -- Use this when r might be E + foldW l e E = foldr' 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` foldr' 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` foldr' f a' l + +-- | This fold is a hybrid between 'foldr' and 'foldr1'. As with 'foldr1', 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 'foldr'). +-- As with 'foldr' and 'foldr1', this function is lazy, so it's best not to use it with functions +-- that are strict in their second argument. See 'foldr2'' for a strict version. +-- +-- Complexity: O(n) +foldr2 :: (e -> a -> a) -> (e -> a) -> AVL e -> a +foldr2 f g = foldU where + foldU E = error "foldr2: 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 = foldr f (f e (foldU r)) l + -- Use this when r might be E + foldW l e E = foldr f (g e) l + foldW l e (N rl re rr) = foldr 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 = foldr f (f e (foldW rl re rr)) l + +-- | The strict version of 'foldr2', 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) +foldr2' :: (e -> a -> a) -> (e -> a) -> AVL e -> a +foldr2' f g = foldU where + foldU E = error "foldr2': 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` foldr' f a' l + -- Use this when r might be E + foldW l e E = let a = g e in a `seq` foldr' 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` foldr' 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` foldr' 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 'foldl'' for a strict version. +-- +-- > foldl f a avl = foldl f a (asListL avl) +-- +-- For example, the 'asListR' function could be defined.. +-- +-- > asListR = foldl (flip (:)) [] +-- +-- Complexity: O(n) +foldl :: (a -> e -> a) -> a -> AVL e -> a +foldl 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 'foldl', 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) +foldl' :: (a -> e -> a) -> a -> AVL e -> a +foldl' 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 'foldl1'' for a strict version. +-- +-- > foldl1 f avl = foldl1 f (asListL avl) +-- +-- This function raises an error if the tree is empty. +-- +-- Complexity: O(n) +foldl1 :: (e -> e -> e) -> AVL e -> e +foldl1 f = foldU where + foldU E = error "foldl1: 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 = foldl f (f (foldU l) e) r + -- Use this when l might be E + foldW E e r = foldl 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 = foldl 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 = foldl f (f (foldW ll le lr) e) r + +-- | The strict version of 'foldl1', 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) +foldl1' :: (e -> e -> e) -> AVL e -> e +foldl1' f = foldU where + foldU E = error "foldl1': 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` foldl' f a' r + -- Use this when l might be E + foldW E e r = foldl' 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` foldl' 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` foldl' f a' r + +-- | This fold is a hybrid between 'foldl' and 'foldl1'. As with 'foldl1', 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 'foldl'). +-- As with 'foldl' and 'foldl1', this function is lazy, so it's best not to use it with functions +-- that are strict in their first argument. See 'foldl2'' for a strict version. +-- +-- Complexity: O(n) +foldl2 :: (a -> e -> a) -> (e -> a) -> AVL e -> a +foldl2 f g = foldU where + foldU E = error "foldl2: 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 = foldl f (f (foldU l) e) r + -- Use this when l might be E + foldW E e r = foldl 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 = foldl 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 = foldl f (f (foldW ll le lr) e) r + +-- | The strict version of 'foldl2', 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) +foldl2' :: (a -> e -> a) -> (e -> a) -> AVL e -> a +foldl2' f g = foldU where + foldU E = error "foldl2': 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` foldl' f a' r + -- Use this when l might be E + foldW E e r = let a = g e in a `seq` foldl' 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` foldl' 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` foldl' f a' r + +-- | This is a specialised version of 'foldr'' for use with an +-- /unboxed/ Int accumulator. +-- +-- Complexity: O(n) +foldrInt# :: (e -> UINT -> UINT) -> UINT -> AVL e -> UINT +foldrInt# 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 AVL equivalent of 'Data.List.mapAccumL' on lists. +-- It behaves like a combination of 'map' and 'foldl'. +-- 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 'mapAccumL'' for a strict version. +-- +-- Complexity: O(n) +mapAccumL :: (z -> a -> (z, b)) -> z -> AVL a -> (z, AVL b) +mapAccumL 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 'mapAccumL', 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) +mapAccumL' :: (z -> a -> (z, b)) -> z -> AVL a -> (z, AVL b) +mapAccumL' 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 'map' and 'foldr'. +-- 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 'mapAccumR'' for a strict version. +-- +-- Complexity: O(n) +mapAccumR :: (z -> a -> (z, b)) -> z -> AVL a -> (z, AVL b) +mapAccumR 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 'mapAccumR', 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) +mapAccumR' :: (z -> a -> (z, b)) -> z -> AVL a -> (z, AVL b) +mapAccumR' 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. + +-- | Similar to 'mapAccumL'' but uses an unboxed pair in the +-- accumulating function. +-- +-- Complexity: O(n) +mapAccumL'' + :: (z -> a -> UBT2(z, b)) -> z -> AVL a -> (z, AVL b) +mapAccumL'' 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) + +-- | Similar to 'mapAccumR'' but uses an unboxed pair in the +-- accumulating function. +-- +-- Complexity: O(n) +mapAccumR'' + :: (z -> a -> UBT2(z, b)) -> z -> AVL a -> (z, AVL b) +mapAccumR'' 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) + +-------------------------------------- +-- | 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 (replicate 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 (replicate 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) +reverse :: AVL e -> AVL e +reverse E = E +reverse (N l e r) = let l' = reverse l + r' = reverse r + in l' `seq` r' `seq` P r' e l' +reverse (Z l e r) = let l' = reverse l + r' = reverse r + in l' `seq` r' `seq` Z r' e l' +reverse (P l e r) = let l' = reverse l + r' = reverse 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 ('map''). +-- +-- 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) +map :: (a -> b) -> AVL a -> AVL b +map f = mp where + mp E = E + mp (N l a r) = let l' = mp l + r' = mp r + in l' `seq` r' `seq` N l' (f a) r' + mp (Z l a r) = let l' = mp l + r' = mp r + in l' `seq` r' `seq` Z l' (f a) r' + mp (P l a r) = let l' = mp l + r' = mp r + in l' `seq` r' `seq` P l' (f a) r' + +-- | Similar to 'map', but the supplied function is applied strictly. +-- +-- Complexity: O(n) +map' :: (a -> b) -> AVL a -> AVL b +map' f = mp' where + mp' E = E + mp' (N l a r) = let l' = mp' l + r' = mp' r + b = f a + in b `seq` l' `seq` r' `seq` N l' b r' + mp' (Z l a r) = let l' = mp' l + r' = mp' r + b = f a + in b `seq` l' `seq` r' `seq` Z l' b r' + mp' (P l a r) = let l' = mp' l + r' = mp' r + b = f a + in b `seq` l' `seq` r' `seq` P l' b r' + + +-- | Construct a flat AVL tree of size n (n>=0), where all elements are identical. +-- +-- Complexity: O(log n) +replicate :: Int -> e -> AVL e +replicate 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 'reverse'. +-- +-- Complexity: O(n) +flatReverse :: AVL e -> AVL e +flatReverse t = asTreeLenL (size t) (asListR t) + +-- | Similar to 'map', but the resulting tree is flat. +-- This function has higher constant factor overhead than 'map'. +-- +-- Complexity: O(n) +flatMap :: (a -> b) -> AVL a -> AVL b +flatMap f t = asTreeLenL (size t) (List.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) (mp' f (asListL t)) where + mp' _ [] = [] + mp' g (a:as) = let b = g a in b `seq` (b : mp' f as) + +-- | Remove all AVL tree elements which do not satisfy the supplied predicate. +-- Element ordering is preserved. The resulting tree is flat. +-- See 'filter' 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) +filter :: forall e. (e -> Bool) -> AVL e -> AVL e +filter p t0 = case filter_ L(0) t0 of UBT3(_,t_,_) -> t_ -- Work with relative heights!! + where + filter_ :: UINT -> AVL e -> UBT3(Bool, AVL e, UINT) + 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) +partition :: (e -> Bool) -> AVL e -> (AVL e, AVL e) +partition 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 'mapMaybe' for an alternative implementation which is probably more efficient. +-- +-- Complexity: O(n) +mapMaybeViaList :: (a -> Maybe b) -> AVL a -> AVL b +mapMaybeViaList f t = mp' [] 0 (asListR t) where + mp' sb n [] = asTreeLenL n sb + mp' sb n (a:as) = case f a of + Just b -> let n'=n+1 in n' `seq` mp' (b:sb) n' as + Nothing -> mp' sb n as + +-- | Remove all AVL tree elements for which the supplied function returns 'Nothing'. +-- Element ordering is preserved. +-- +-- Complexity: O(n) +mapMaybe :: forall a b. (a -> Maybe b) -> AVL a -> AVL b +mapMaybe f t0 = case mapMaybe_ L(0) t0 of UBT2(t_,_) -> t_ -- Work with relative heights!! + where + mapMaybe_ :: UINT -> AVL a -> UBT2(AVL b, UINT) + 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 'pushList' on the empty AVL tree. +-- +-- Complexity: O(n.(log n)) +asTree :: (e -> e -> COrdering e) -> [e] -> AVL e +asTree c = pushList c empty +{-# INLINE asTree #-} + +-- | 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. +pushList :: (e -> e -> COrdering e) -> AVL e -> [e] -> AVL e +pushList c avl = List.foldl' addElem avl + where addElem t e = push (c e) e t + +-- | A fast alternative implementation for 'Data.List.nub'. +-- Deletes all but the first occurrence of an element from the input list. +-- +-- Complexity: O(n.(log n)) +nub :: Ord a => [a] -> [a] +nub = nubBy compare +{-# INLINE nub #-} + +-- | A fast alternative implementation for 'Data.List.nubBy'. +-- Deletes all but the first occurrence of an element from the input list. +-- +-- Complexity: O(n.(log n)) +nubBy :: (a -> a -> Ordering) -> [a] -> [a] +nubBy c = nubbit E where + nubbit _ [] = [] + nubbit avl (a:as) = case findEmptyPath (c a) avl of + L(-1) -> nubbit avl as -- Already encountered + p -> let avl' = insertPath p a avl -- First encounter + in avl' `seq` (a : nubbit avl' as) + +-- | This is the non-overloaded version of the 'Data.Traversable.traverse' method for AVL trees. +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 diff --git a/src/Data/Tree/AVL/Push.hs b/src/Data/Tree/AVL/Push.hs new file mode 100644 --- /dev/null +++ b/src/Data/Tree/AVL/Push.hs @@ -0,0 +1,692 @@ +-- | +-- Copyright : (c) Adrian Hey 2004,2005 +-- License : BSD3 +-- +{-# OPTIONS_HADDOCK hide #-} +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 + push,push',pushMaybe,pushMaybe', +) where + +import Data.COrdering +import Data.Tree.AVL.Internals.Types(AVL(..)) +import Data.Tree.AVL.BinPath(BinPath(..),openPathWith,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 @('Data.COrdering.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 'push'' +-- +-- Complexity: O(log n) +push :: (e -> COrdering e) -> e -> AVL e -> AVL e +push 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 -- 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 -- 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 -- 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 "push: 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 "push: 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 "push: 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 "push: 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 "push: 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 "push: 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 "push: 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 "push: 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 "push: 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 "push: 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) !! + +-- | Almost identical to 'push', 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) +push' :: (e -> COrdering e) -> e -> AVL e -> AVL e +push' 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 -- 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 -- 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 -- 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 "push': 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 "push': 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 "push': 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 "push': 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 "push': 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 "push': 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 "push': 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 "push': 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 "push': 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 "push': 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) !! + +-- | Similar to 'push', but returns the original tree if the combining comparison returns +-- @('Data.COrdering.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 'pushMaybe'' +-- +-- Complexity: O(log n) +pushMaybe :: (e -> COrdering (Maybe e)) -> e -> AVL e -> AVL e +pushMaybe c e t = case openPathWith c t of + FullBP _ Nothing -> t + FullBP p (Just e') -> writePath p e' t + EmptyBP p -> insertPath p e t + +-- | Almost identical to 'pushMaybe', 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) +pushMaybe' :: (e -> COrdering (Maybe e)) -> e -> AVL e -> AVL e +pushMaybe' c e t = case openPathWith 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 !! + +-- | 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 diff --git a/src/Data/Tree/AVL/Read.hs b/src/Data/Tree/AVL/Read.hs new file mode 100644 --- /dev/null +++ b/src/Data/Tree/AVL/Read.hs @@ -0,0 +1,163 @@ +-- | +-- Copyright : (c) Adrian Hey 2004,2005 +-- License : BSD3 +-- +{-# OPTIONS_HADDOCK hide #-} +module Data.Tree.AVL.Read +(-- * Reading from AVL trees + + -- ** Reading from extreme left or right + assertReadL,tryReadL, + assertReadR,tryReadR, + + -- ** Reading from /sorted/ AVL trees + assertRead,tryRead,tryReadMaybe,defaultRead, + + -- ** Simple searches of /sorted/ AVL trees + contains, +) where + +import Prelude -- so haddock finds the symbols there + +import Data.COrdering +import Data.Tree.AVL.Internals.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) +assertRead :: AVL e -> (e -> COrdering a) -> a +assertRead t c = genRead' t where + genRead' E = error "assertRead 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 'assertRead', but returns 'Nothing' if the search failed. +-- +-- Complexity: O(log n) +tryRead :: AVL e -> (e -> COrdering a) -> Maybe a +tryRead t c = tryRead' t where + tryRead' E = Nothing + tryRead' (N l e r) = tryRead'' l e r + tryRead' (Z l e r) = tryRead'' l e r + tryRead' (P l e r) = tryRead'' l e r + tryRead'' l e r = case c e of + Lt -> tryRead' l + Eq a -> Just a + Gt -> tryRead' 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) +tryReadMaybe :: AVL e -> (e -> COrdering (Maybe a)) -> Maybe a +tryReadMaybe t c = tryRead' t where + tryRead' E = Nothing + tryRead' (N l e r) = tryRead'' l e r + tryRead' (Z l e r) = tryRead'' l e r + tryRead' (P l e r) = tryRead'' l e r + tryRead'' l e r = case c e of + Lt -> tryRead' l + Eq mba -> mba + Gt -> tryRead' r + +-- | General purpose function to perform a search of a sorted tree, using the supplied selector. +-- This function is similar to 'assertRead', but returns a the default value (first argument) if +-- the search fails. +-- +-- Complexity: O(log n) +defaultRead :: a -> AVL e -> (e -> COrdering a) -> a +defaultRead 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) +contains :: AVL e -> (e -> Ordering) -> Bool +contains t c = contains' t where + contains' E = False + contains' (N l e r) = contains'' l e r + contains' (Z l e r) = contains'' l e r + contains' (P l e r) = contains'' l e r + contains'' l e r = case c e of + LT -> contains' l + EQ -> True + GT -> contains' r diff --git a/src/Data/Tree/AVL/Set.hs b/src/Data/Tree/AVL/Set.hs new file mode 100644 --- /dev/null +++ b/src/Data/Tree/AVL/Set.hs @@ -0,0 +1,596 @@ +-- | +-- Copyright : (c) Adrian Hey 2004,2005 +-- License : BSD3 +-- +{-# OPTIONS_HADDOCK hide #-} +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 + union,unionMaybe,disjointUnion,unions, + + -- ** Difference + difference,differenceMaybe,symDifference, + + -- ** Intersection + intersection,intersectionMaybe, + + -- *** 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.) + intersectionToList,intersectionAsList, + intersectionMaybeToList,intersectionMaybeAsList, + + -- ** \'Venn diagram\' operations + -- | Given two sets A and B represented as sorted AVL trees, the venn operations evaluate + -- components @A-B@, @A.B@ and @B-A@. The intersection part may be obtained as a List + -- rather than AVL tree if required. + -- + -- Note that in all cases the three resulting sets are /disjoint/ and can safely be re-combined + -- after most \"munging\" operations using 'disjointUnion'. + venn,vennMaybe, + + -- *** \'Venn diagram\' operations with the intersection component as a List. + -- | These variants are provided for the same reasons as the Intersection as List variants. + vennToList,vennAsList, + vennMaybeToList,vennMaybeAsList, + + -- ** Subset + isSubsetOf,isSubsetOfBy, +) where + +import Prelude -- so haddock finds the symbols there + +import Data.Tree.AVL.Internals.Types(AVL(..)) +import Data.Tree.AVL.Height(addHeight) +import Data.Tree.AVL.List(asTreeLenL) +import Data.Tree.AVL.Internals.HJoin(spliceH) +import Data.Tree.AVL.Internals.HSet(unionH,unionMaybeH,disjointUnionH, + intersectionH,intersectionMaybeH, + vennH,vennMaybeH, + differenceH,differenceMaybeH,symDifferenceH) + +import Data.COrdering + +import GHC.Base +#include "ghcdefs.h" + +-- | 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. +union :: (e -> e -> COrdering e) -> AVL e -> AVL e -> AVL e +union 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 'union', 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. +unionMaybe :: (e -> e -> COrdering (Maybe e)) -> AVL e -> AVL e -> AVL e +unionMaybe 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 comparison to evaluate the union of two /disjoint/ sets represented as +-- sorted AVL trees. It will be slightly faster than 'union' but will raise an error if the +-- two sets intersect. Typically this would be used to re-combine the \"post-munge\" results +-- from one of the \"venn\" operations. +-- +-- Complexity: Not sure, but I\'d appreciate it if someone could figure it out. +-- (Faster than Hedge union from Data.Set at any rate). +disjointUnion :: (e -> e -> Ordering) -> AVL e -> AVL e -> AVL e +disjointUnion 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 disjointUnionH 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.. +-- +-- @unions ccmp avls = foldl' ('union' ccmp) empty avls@ +unions :: (e -> e -> COrdering e) -> [AVL e] -> AVL e +unions 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. +intersection :: (a -> b -> COrdering c) -> AVL a -> AVL b -> AVL c +intersection c t0 t1 = case intersectionH c t0 t1 of UBT2(t,_) -> t + +-- | Similar to 'intersection', 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. +intersectionMaybe :: (a -> b -> COrdering (Maybe c)) -> AVL a -> AVL b -> AVL c +intersectionMaybe c t0 t1 = case intersectionMaybeH c t0 t1 of UBT2(t,_) -> t + +-- | Similar to 'intersection', but prepends the result to the supplied list in +-- ascending order. This is a (++) free function which behaves as if defined: +-- +-- @intersectionToList c setA setB cs = asListL (intersection c setA setB) ++ cs@ +-- +-- Complexity: Not sure, but I\'d appreciate it if someone could figure it out. +intersectionToList :: (a -> b -> COrdering c) -> AVL a -> AVL b -> [c] -> [c] +intersectionToList 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_) + +-- | Applies 'intersectionToList' to the empty list. +-- +-- Complexity: Not sure, but I\'d appreciate it if someone could figure it out. +intersectionAsList :: (a -> b -> COrdering c) -> AVL a -> AVL b -> [c] +intersectionAsList c setA setB = intersectionToList c setA setB [] + +-- | Similar to 'intersectionToList', 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. +intersectionMaybeToList :: (a -> b -> COrdering (Maybe c)) -> AVL a -> AVL b -> [c] -> [c] +intersectionMaybeToList 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_) + +-- | Applies 'intersectionMaybeToList' to the empty list. +-- +-- Complexity: Not sure, but I\'d appreciate it if someone could figure it out. +intersectionMaybeAsList :: (a -> b -> COrdering (Maybe c)) -> AVL a -> AVL b -> [c] +intersectionMaybeAsList c setA setB = intersectionMaybeToList c setA setB [] + +-- | Uses the supplied comparison to evaluate the difference between two sets represented as +-- sorted AVL trees. The expression.. +-- +-- > difference 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. +difference :: (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. +difference c t0 t1 = case differenceH c t0 L(0) t1 of UBT2(t,_) -> t + +-- | Similar to 'difference', 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. +differenceMaybe :: (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. +differenceMaybe 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. +isSubsetOf :: (a -> b -> Ordering) -> AVL a -> AVL b -> Bool +isSubsetOf 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_) + +-- | Similar to 'isSubsetOf', but also requires that the supplied combining +-- comparison returns @('Data.COrdering.Eq' True)@ for matching elements. +-- +-- Complexity: Not sure, but I\'d appreciate it if someone could figure it out. +isSubsetOfBy :: (a -> b -> COrdering Bool) -> AVL a -> AVL b -> Bool +isSubsetOfBy 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_) + +-- | 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. +symDifference :: (e -> e -> Ordering) -> AVL e -> AVL e -> AVL e +symDifference 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 + +-- | Given two Sets @A@ and @B@ represented as sorted AVL trees, this function +-- extracts the \'Venn diagram\' components @A-B@, @A.B@ and @B-A@. +-- See also 'vennMaybe'. +-- +-- Complexity: Not sure, but I\'d appreciate it if someone could figure it out. +venn :: (a -> b -> COrdering c) -> AVL a -> AVL b -> (AVL a, AVL c, AVL b) +venn c = gu where -- This is to avoid O(log n) height calculation for empty sets + gu E t1 = (E ,E,t1) + gu t0 E = (t0,E,E ) + 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 vennH c [] L(0) t0 h0 t1 h1 of + UBT6(tab,_,cs,cl,tba,_) -> let tc = asTreeLenL ASINT(cl) cs + in tc `seq` (tab,tc,tba) + +-- | Similar to 'venn', but intersection elements for which the combining comparison +-- returns @('Data.COrdering.Eq' 'Nothing')@ are deleted from the intersection result. +-- +-- Complexity: Not sure, but I\'d appreciate it if someone could figure it out. +vennMaybe :: (a -> b -> COrdering (Maybe c)) -> AVL a -> AVL b -> (AVL a, AVL c, AVL b) +vennMaybe c = gu where -- This is to avoid O(log n) height calculation for empty sets + gu E t1 = (E ,E,t1) + gu t0 E = (t0,E,E ) + 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 vennMaybeH c [] L(0) t0 h0 t1 h1 of + UBT6(tab,_,cs,cl,tba,_) -> let tc = asTreeLenL ASINT(cl) cs + in tc `seq` (tab,tc,tba) + +-- | Same as 'venn', but prepends the intersection component to the supplied list +-- in ascending order. +vennToList :: (a -> b -> COrdering c) -> [c] -> AVL a -> AVL b -> (AVL a, [c], AVL b) +vennToList cmp cs = gu where -- This is to avoid O(log n) height calculation for empty sets + gu E t1 = (E ,cs,t1) + gu t0 E = (t0,cs,E ) + 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 vennH cmp cs L(0) t0 h0 t1 h1 of + UBT6(tab,_,cs_,_,tba,_) -> (tab,cs_,tba) + +-- | Same as 'vennMaybe', but prepends the intersection component to the supplied list +-- in ascending order. +vennMaybeToList :: (a -> b -> COrdering (Maybe c)) -> [c] -> AVL a -> AVL b -> (AVL a, [c], AVL b) +vennMaybeToList cmp cs = gu where -- This is to avoid O(log n) height calculation for empty sets + gu E t1 = (E ,cs,t1) + gu t0 E = (t0,cs,E ) + 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 vennMaybeH cmp cs L(0) t0 h0 t1 h1 of + UBT6(tab,_,cs_,_,tba,_) -> (tab,cs_,tba) + +-- | Same as 'venn', but returns the intersection component as a list in ascending order. +-- This is just 'vennToList' applied to an empty initial intersection list. +vennAsList :: (a -> b -> COrdering c) -> AVL a -> AVL b -> (AVL a, [c], AVL b) +vennAsList cmp = vennToList cmp [] +{-# INLINE vennAsList #-} + +-- | Same as 'vennMaybe', but returns the intersection component as a list in ascending order. +-- This is just 'vennMaybeToList' applied to an empty initial intersection list. +vennMaybeAsList :: (a -> b -> COrdering (Maybe c)) -> AVL a -> AVL b -> (AVL a, [c], AVL b) +vennMaybeAsList cmp = vennMaybeToList cmp [] +{-# INLINE vennMaybeAsList #-} + diff --git a/src/Data/Tree/AVL/Size.hs b/src/Data/Tree/AVL/Size.hs new file mode 100644 --- /dev/null +++ b/src/Data/Tree/AVL/Size.hs @@ -0,0 +1,158 @@ +-- | +-- Copyright : (c) Adrian Hey 2004,2005 +-- License : BSD3 +-- +-- AVL Tree size related utilities. + +{-# OPTIONS_HADDOCK hide #-} +module Data.Tree.AVL.Size + (-- * AVL tree size utilities + size,addSize,clipSize, + addSize#,size#, + ) where + +import Data.Tree.AVL.Internals.Types(AVL(..)) +import Data.Tree.AVL.Height(addHeight) + +import GHC.Base +#include "ghcdefs.h" + +-- | A convenience wrapper for 'addSize#'. +size :: AVL e -> Int +size t = ASINT(addSize# L(0) t) +{-# INLINE size #-} + +-- | A convenience wrapper for 'addSize#'. +size# :: AVL e -> UINT +size# t = addSize# L(0) t +{-# INLINE size# #-} + +-- | See 'addSize#'. +addSize :: Int -> AVL e -> Int +addSize ASINT(n) t = ASINT(addSize# n t) +{-# INLINE addSize #-} + +#define AddSize addSize# + +{----------------------------------------- +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 add the size of a tree to the first argument. 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) +AddSize :: UINT -> AVL e -> UINT +AddSize n E = n +AddSize 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 +AddSize 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 +AddSize 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 "AddSize: 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 "AddSize: Bad Tree." -- impossible +{-# INLINE fas2 #-} + +-- | 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 'addSize'. +-- +-- 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 isTrue# (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 isTrue# (c LTN L(4)) then L(-1) else cSz2 DECINT2(c) t +cSzZ3 :: UINT -> AVL e -> AVL e -> UINT +cSzZ3 c l r = if isTrue# (c LTN L(5)) then L(-1) + else let c_ = cSz2 DECINT1(c) l + in if isTrue# (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 isTrue# (c LTN L(7)) then L(-1) + else let c_ = cSzG2 DECINT1(c) DECINT2(h) l -- (h-2) >= 2 + in if isTrue# (c_ LTN L(4)) then L(-1) + else cSzG3 c_ DECINT1(h) r -- (h-1) >= 3 +cSzZ c h l r = if isTrue# (c LTN L(9)) then L(-1) + else let c_ = cSzG3 DECINT1(c) DECINT1(h) l -- (h-1) >= 3 + in if isTrue# (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 #-} diff --git a/src/Data/Tree/AVL/Split.hs b/src/Data/Tree/AVL/Split.hs new file mode 100644 --- /dev/null +++ b/src/Data/Tree/AVL/Split.hs @@ -0,0 +1,790 @@ +-- | +-- Copyright : (c) Adrian Hey 2004,2005 +-- License : BSD3 +-- +{-# OPTIONS_HADDOCK hide #-} +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.Internals.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.Internals.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 'takeLT' 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. + forkL,forkR,fork, + takeLE,dropGT, + takeLT,dropGE, + takeGT,dropLE, + takeGE,dropLT, +) where + +import Prelude -- so haddock finds the symbols there + + +import Data.COrdering(COrdering(..)) +import Data.Tree.AVL.Internals.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') + +import GHC.Base +#include "ghcdefs.h" + +-- 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' + +-- | 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 + +-- 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 + +-- | 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 + +-- | 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' + +-- | 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' + + +-- 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 + +-- | 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 + +-- 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 + +-- | 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 + +-- | 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 + +-- | 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 + +-- | 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 isTrue# (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 isTrue# (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) +forkL :: (e -> Ordering) -> AVL e -> (AVL e, AVL e) +forkL c avl = let (HAVL l _,HAVL r _) = forkL_ L(0) avl -- Tree heights are relative + in (l,r) + where + forkL_ h E = (HAVL E h, HAVL E h) + forkL_ h (N l e r) = forkL__ l DECINT2(h) e r DECINT1(h) + forkL_ h (Z l e r) = forkL__ l DECINT1(h) e r DECINT1(h) + forkL_ h (P l e r) = forkL__ l DECINT1(h) e r DECINT2(h) + forkL__ l hl e r hr = case c e of + -- Current element > pivot, so goes in right half + LT -> let (havl0,havl1) = forkL_ 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) = forkL_ 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) +forkR :: (e -> Ordering) -> AVL e -> (AVL e, AVL e) +forkR c avl = let (HAVL l _,HAVL r _) = forkR_ L(0) avl -- Tree heights are relative + in (l,r) + where + forkR_ h E = (HAVL E h, HAVL E h) + forkR_ h (N l e r) = forkR__ l DECINT2(h) e r DECINT1(h) + forkR_ h (Z l e r) = forkR__ l DECINT1(h) e r DECINT1(h) + forkR_ h (P l e r) = forkR__ l DECINT1(h) e r DECINT2(h) + forkR__ l hl e r hr = case c e of + -- Current element > pivot, so goes in right half + LT -> let (havl0,havl1) = forkR_ 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) = forkR_ hr r + havl0_ = spliceHAVL (HAVL l hl) e havl0 + in havl0_ `seq` (havl0_, havl1) + + +-- | Similar to 'forkL' and 'forkR', but returns any equal element found (instead of +-- incorporating it into the left or right tree results respectively). +-- +-- Complexity: O(log n) +fork :: (e -> COrdering a) -> AVL e -> (AVL e, Maybe a, AVL e) +fork c avl = let (HAVL l _, mba, HAVL r _) = fork_ L(0) avl -- Tree heights are relative + in (l,mba,r) + where + fork_ h E = (HAVL E h, Nothing, HAVL E h) + fork_ h (N l e r) = fork__ l DECINT2(h) e r DECINT1(h) + fork_ h (Z l e r) = fork__ l DECINT1(h) e r DECINT1(h) + fork_ h (P l e r) = fork__ l DECINT1(h) e r DECINT2(h) + fork__ l hl e r hr = case c e of + -- Current element > pivot + Lt -> let (havl0,mba,havl1) = fork_ 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) = fork_ hr r + havl0_ = spliceHAVL (HAVL l hl) e havl0 + in havl0_ `seq` (havl0_, mba, havl1) + +-- | This is a simplified version of 'forkL' 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 'dropGT'. +-- +-- Complexity: O(log n) +takeLE :: (e -> Ordering) -> AVL e -> AVL e +takeLE c avl = let HAVL l _ = forkL_ L(0) avl -- Tree heights are relative + in l + where + forkL_ h E = HAVL E h + forkL_ h (N l e r) = forkL__ l DECINT2(h) e r DECINT1(h) + forkL_ h (Z l e r) = forkL__ l DECINT1(h) e r DECINT1(h) + forkL_ h (P l e r) = forkL__ l DECINT1(h) e r DECINT2(h) + forkL__ l hl e r hr = case c e of + LT -> forkL_ hl l + EQ -> pushRHAVL (HAVL l hl) e + GT -> let havl0 = forkL_ hr r + in spliceHAVL (HAVL l hl) e havl0 + + +-- | A synonym for 'takeLE'. +-- +-- Complexity: O(log n) +dropGT :: (e -> Ordering) -> AVL e -> AVL e +dropGT = takeLE +{-# INLINE dropGT #-} + +-- | This is a simplified version of 'forkL' which returns a sorted tree containing +-- only those elements which are greater according to the supplied selector. +-- This function also has the synonym 'dropLE'. +-- +-- Complexity: O(log n) +takeGT :: (e -> Ordering) -> AVL e -> AVL e +takeGT c avl = let HAVL r _ = forkL_ L(0) avl -- Tree heights are relative + in r + where + forkL_ h E = HAVL E h + forkL_ h (N l e r) = forkL__ l DECINT2(h) e r DECINT1(h) + forkL_ h (Z l e r) = forkL__ l DECINT1(h) e r DECINT1(h) + forkL_ h (P l e r) = forkL__ l DECINT1(h) e r DECINT2(h) + forkL__ l hl e r hr = case c e of + LT -> let havl1 = forkL_ hl l + in spliceHAVL havl1 e (HAVL r hr) + EQ -> HAVL r hr + GT -> forkL_ hr r + +-- | A synonym for 'takeGT'. +-- +-- Complexity: O(log n) +dropLE :: (e -> Ordering) -> AVL e -> AVL e +dropLE = takeGT +{-# INLINE dropLE #-} + +-- | This is a simplified version of 'forkR' which returns a sorted tree containing +-- only those elements which are less than according to the supplied selector. +-- This function also has the synonym 'dropGE'. +-- +-- Complexity: O(log n) +takeLT :: (e -> Ordering) -> AVL e -> AVL e +takeLT c avl = let HAVL l _ = forkL_ L(0) avl -- Tree heights are relative + in l + where + forkL_ h E = HAVL E h + forkL_ h (N l e r) = forkL__ l DECINT2(h) e r DECINT1(h) + forkL_ h (Z l e r) = forkL__ l DECINT1(h) e r DECINT1(h) + forkL_ h (P l e r) = forkL__ l DECINT1(h) e r DECINT2(h) + forkL__ l hl e r hr = case c e of + LT -> forkL_ hl l + EQ -> HAVL l hl + GT -> let havl0 = forkL_ hr r + in spliceHAVL (HAVL l hl) e havl0 + + +-- | A synonym for 'takeLT'. +-- +-- Complexity: O(log n) +dropGE :: (e -> Ordering) -> AVL e -> AVL e +dropGE = takeLT +{-# INLINE dropGE #-} + +-- | This is a simplified version of 'forkR' 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 'dropLT'. +-- +-- Complexity: O(log n) +takeGE :: (e -> Ordering) -> AVL e -> AVL e +takeGE c avl = let HAVL r _ = forkL_ L(0) avl -- Tree heights are relative + in r + where + forkL_ h E = HAVL E h + forkL_ h (N l e r) = forkL__ l DECINT2(h) e r DECINT1(h) + forkL_ h (Z l e r) = forkL__ l DECINT1(h) e r DECINT1(h) + forkL_ h (P l e r) = forkL__ l DECINT1(h) e r DECINT2(h) + forkL__ l hl e r hr = case c e of + LT -> let havl1 = forkL_ hl l + in spliceHAVL havl1 e (HAVL r hr) + EQ -> pushLHAVL e (HAVL r hr) + GT -> forkL_ hr r + +-- | A synonym for 'takeGE'. +-- +-- Complexity: O(log n) +dropLT :: (e -> Ordering) -> AVL e -> AVL e +dropLT = takeGE +{-# INLINE dropLT #-} + diff --git a/src/Data/Tree/AVL/Test/Utils.hs b/src/Data/Tree/AVL/Test/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Data/Tree/AVL/Test/Utils.hs @@ -0,0 +1,112 @@ +-- | +-- Copyright : (c) Adrian Hey 2004,2005 +-- License : BSD3 +-- +-- +-- 'AVL' tree related test and verification utilities. +module Data.Tree.AVL.Test.Utils + (-- * Correctness checking. + isBalanced,isSorted,isSortedOK, + -- * Tree parameter utilities. + minElements,maxElements, + ) where + +import Data.Tree.AVL.Internals.Types(AVL(..)) + +import GHC.Base +#include "ghcdefs.h" + +-- | 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 (isTrue# (cH t EQL L(-1))) + +-- 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 isTrue# (hl EQL L(-1)) then hl + else let hr = cH r + in if isTrue# (hr EQL L(-1)) then hr + else if isTrue# (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) + +-- | 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) diff --git a/src/Data/Tree/AVL/Utils.hs b/src/Data/Tree/AVL/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Data/Tree/AVL/Utils.hs @@ -0,0 +1,55 @@ +-- | +-- Copyright : (c) Adrian Hey 2004,2005 +-- License : BSD3 +-- +-- A few simple utility functions. +{-# OPTIONS_HADDOCK hide #-} +module Data.Tree.AVL.Utils + ( -- * Simple AVL related utilities + empty,isEmpty,isNonEmpty,singleton,pair,tryGetSingleton, + + ) where + +import Data.Tree.AVL.Internals.Types (AVL(..)) + +-- | The empty AVL tree. +{-# INLINE empty #-} +empty :: AVL e +empty = E + +-- | Returns 'True' if an AVL tree is empty. +-- +-- Complexity: O(1) +isEmpty :: AVL e -> Bool +isEmpty E = True +isEmpty _ = False +{-# INLINE isEmpty #-} + +-- | Returns 'True' if an AVL tree is non-empty. +-- +-- Complexity: O(1) +isNonEmpty :: AVL e -> Bool +isNonEmpty E = False +isNonEmpty _ = True +{-# INLINE isNonEmpty #-} + +-- | Creates an AVL tree with just one element. +-- +-- Complexity: O(1) +singleton :: e -> AVL e +singleton e = Z E e E +{-# INLINE singleton #-} + +-- | Create an AVL tree of two elements, occuring in same order as the arguments. +pair :: e -> e -> AVL e +pair e0 e1 = P (Z E e0 E) e1 E +{-# INLINE pair #-} + +-- | 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) +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 +{-# INLINE tryGetSingleton #-} diff --git a/src/Data/Tree/AVL/Write.hs b/src/Data/Tree/AVL/Write.hs new file mode 100644 --- /dev/null +++ b/src/Data/Tree/AVL/Write.hs @@ -0,0 +1,192 @@ +-- | +-- Copyright : (c) Adrian Hey 2004,2005 +-- License : BSD3 +-- +{-# OPTIONS_HADDOCK hide #-} +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 + write,writeFast,tryWrite,writeMaybe,tryWriteMaybe +) where + +import Prelude -- so haddock finds the symbols there + +import Data.COrdering +import Data.Tree.AVL.Internals.Types(AVL(..)) +import Data.Tree.AVL.BinPath(BinPath(..),openPathWith,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 @('Data.COrdering.Eq' e)@ +-- constructor returned by the selector. If the search fails this function returns the original tree. +-- +-- Complexity: O(log n) +write :: (e -> COrdering e) -> AVL e -> AVL e +write c t = case openPathWith c t of + FullBP pth e -> writePath pth e t + _ -> t + +-- | Functionally identical to 'write', 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) +writeFast :: (e -> COrdering e) -> AVL e -> AVL e +writeFast c = w where + w E = E + w (N l e r) = case c e of + Lt -> let l' = w l in l' `seq` N l' e r + Eq v -> N l v r + Gt -> let r' = w r in r' `seq` N l e r' + w (Z l e r) = case c e of + Lt -> let l' = w l in l' `seq` Z l' e r + Eq v -> Z l v r + Gt -> let r' = w r in r' `seq` Z l e r' + w (P l e r) = case c e of + Lt -> let l' = w l in l' `seq` P l' e r + Eq v -> P l v r + Gt -> let r' = w 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 @('Data.COrdering.Eq' e)@ constructor returned by +-- the selector. This function returns 'Nothing' if the search failed. +-- +-- Complexity: O(log n) +tryWrite :: (e -> COrdering e) -> AVL e -> Maybe (AVL e) +tryWrite c t = case openPathWith c t of + FullBP pth e -> Just $! writePath pth e t + _ -> Nothing + +-- | Similar to 'write', but also returns the original tree if the search succeeds but +-- the selector returns @('Data.COrdering.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) +writeMaybe :: (e -> COrdering (Maybe e)) -> AVL e -> AVL e +writeMaybe c t = case openPathWith c t of + FullBP pth (Just e) -> writePath pth e t + _ -> t + +-- | Similar to 'tryWrite', but also returns the original tree if the search succeeds but +-- the selector returns @('Data.COrdering.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) +tryWriteMaybe :: (e -> COrdering (Maybe e)) -> AVL e -> Maybe (AVL e) +tryWriteMaybe c t = case openPathWith c t of + FullBP pth (Just e) -> Just $! writePath pth e t + FullBP _ Nothing -> Just t + _ -> Nothing + + diff --git a/src/Data/Tree/AVL/Zipper.hs b/src/Data/Tree/AVL/Zipper.hs new file mode 100644 --- /dev/null +++ b/src/Data/Tree/AVL/Zipper.hs @@ -0,0 +1,895 @@ +-- | +-- Copyright : (c) Adrian Hey 2004,2005 +-- License : BSD3 +-- +{-# OPTIONS_HADDOCK hide #-} +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 . + -- + -- 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 t'BAVL' as a cheaper alternative if you don't + -- need to navigate the tree. + + -- ** Types + ZAVL,PAVL, + + -- ** Opening + assertOpenL,assertOpenR, + tryOpenL,tryOpenR, + assertOpen,tryOpen, + tryOpenGE,tryOpenLE, + openEither, + + -- ** 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 + openBAVL,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.Internals.Types(AVL(..)) +import Data.Tree.AVL.Size(size,addSize) +import Data.Tree.AVL.Height(height,addHeight) +import Data.Tree.AVL.Internals.DelUtils(deletePath,popRN,popRZ,popRP,popLN,popLZ,popLP) +import Data.Tree.AVL.Internals.HJoin(spliceH,joinH) +import Data.Tree.AVL.Internals.HPush(pushHL,pushHR) +import Data.Tree.AVL.BinPath(BinPath(..),openPath,writePath,insertPath,sel,goL,goR) + +import GHC.Base +#include "ghcdefs.h" + +-- 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) +assertOpen :: (e -> Ordering) -> AVL e -> ZAVL e +assertOpen c t = op EP L(0) t where -- Relative heights !! + -- op :: (Path e) -> UINT -> AVL e -> ZAVL e + op _ _ E = error "assertOpen: 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 'openBAVL', test for \"fullness\" +-- using 'fullBAVL' and then convert to a t'ZAVL' using 'fullBAVLtoZAVL'. +-- +-- Complexity: O(log n) +tryOpen :: (e -> Ordering) -> AVL e -> Maybe (ZAVL e) +tryOpen 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) +tryOpenGE :: (e -> Ordering) -> AVL e -> Maybe (ZAVL e) +tryOpenGE 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) +tryOpenLE :: (e -> Ordering) -> AVL e -> Maybe (ZAVL e) +tryOpenLE 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) +openEither :: (e -> Ordering) -> AVL e -> Either (PAVL e) (ZAVL e) +openEither 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 t'PAVL' with the supplied element, which becomes +-- the current element of the resulting t'ZAVL'. The supplied filling element should +-- be \"equal\" to the value used in the search which created the t'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 t'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 t'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\" t'BAVL' if a matching element was found, +-- otherwise returns an \"empty\" t'BAVL'. +-- +-- Complexity: O(log n) +openBAVL :: (e -> Ordering) -> AVL e -> BAVL e +{-# INLINE openBAVL #-} +openBAVL c t = bp `seq` BAVL t bp + where bp = openPath c t + +-- | Returns the original tree, extracted from the t'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 t'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 t'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\" t'BAVL'. +-- This function returns 'Nothing' if applied to an \"empty\" t'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\" t'BAVL'. +-- This function raises an error if applied to an \"empty\" t'BAVL'. +-- +-- Complexity: O(1) +readFullBAVL :: BAVL e -> e +{-# INLINE readFullBAVL #-} +readFullBAVL (BAVL _ (FullBP _ e)) = e +readFullBAVL (BAVL _ (EmptyBP _ )) = error "readFullBAVL: Empty BAVL." + +-- | If the t'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 t'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 t'BAVL') +deleteBAVL :: BAVL e -> AVL e +{-# INLINE deleteBAVL #-} +deleteBAVL (BAVL t (FullBP p _)) = deletePath p t +deleteBAVL (BAVL t (EmptyBP _ )) = t + +-- | Converts a \"full\" t'BAVL' as a t'ZAVL'. +-- Raises an error if applied to an \"empty\" t'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\" t'BAVL' as a t'PAVL'. +-- Raises an error if applied to a \"full\" t'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 t'BAVL' to either a t'PAVL' or t'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 !! diff --git a/tests/AllTests.hs b/tests/AllTests.hs new file mode 100644 --- /dev/null +++ b/tests/AllTests.hs @@ -0,0 +1,1409 @@ +-- | +-- Copyright : (c) Adrian Hey 2004,2005,2006,2007 +-- License : BSD3 +-- +-- This module contains a large set of fairly comprehensive but extremely +-- time consuming tests of AVL tree functions (not based on QuickCheck). +-- + +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} +{-# OPTIONS_GHC -Wno-unbanged-strict-patterns #-} + +module Main +(main +) where + +import Prelude ((+), (*), (-), odd, even, mod) +import Data.Bool (Bool(..), (&&), (||), not) +import Text.Read (read) +import Data.Function (($), (.), flip) +import Text.Show (show) +import Data.Eq ((==), (/=)) +import Data.Foldable (length, all, and, any, or, concatMap, null, concat) +import Data.List ((++), take, zipWith, iterate, dropWhile, takeWhile, span, drop) +import Control.Monad ((>>)) +import Data.Either (Either(..)) +import Data.String (String) +import Data.Maybe (Maybe(..)) +import System.IO (IO, putStrLn) +import Data.Ord (Ordering(..), compare, (>=), (<=), max, min, (<)) +import Data.COrdering +import Data.Tree.AVL +import qualified Data.List as L (replicate,reverse,filter,foldr1,foldl1,map,insert,mapAccumL,mapAccumR) +import System.Exit(exitFailure) + +import Data.Tree.AVL.Internals.Types (AVL(..)) +-- import Data.Tree.AVL.Internals.HAVL (HAVL(..), toHAVL, joinHAVL) +import Utils (exhaustiveTest, pathTree, allAVL, allNonEmptyAVL, checkHeight) + +import GHC.Base(Int(..)) +#include "ghcdefs.h" + +-- | Run every test in this module (takes a very long time). +main :: IO () +main = + do testReadPath + testIsBalanced + testIsSorted + testSize + testClipSize + testWrite + testPush + testPushL + testPushR + testDelete + testAssertDelL + testAssertDelR + testAssertPopL + -- testPopHL + testAssertPopR + testAssertPop + testFlatten + testJoin + -- testJoinHAVL + testConcatAVL + testFlatConcat + testFoldr + testFoldr' + testFoldl + testFoldl' + testFoldr1 + testFoldr1' + testFoldl1 + testFoldl1' + testMapAccumL + testMapAccumR + testMapAccumL' + testMapAccumR' + testMapAccumL'' + testMapAccumR'' + testSplitAtL + testFilterViaList + testFilter + testMapMaybeViaList + testMapMaybe + testTakeL + testDropL + testSplitAtR + testTakeR + testDropR + testSpanL + testTakeWhileL + testDropWhileL + testSpanR + testTakeWhileR + testDropWhileR + testRotateL + testRotateR + testRotateByL + testRotateByR + testForkL + testForkR + testFork + testTakeLE + testTakeGT + testTakeGE + testTakeLT + testUnion + testDisjointUnion + testUnionMaybe + testIntersection + testIntersectionMaybe + testIntersectionAsList + testIntersectionMaybeAsList + testDifference + testDifferenceMaybe + testSymDifference + testIsSubsetOf + testIsSubsetOfBy + testVenn + testVennMaybe + testCompareHeight + testShowReadEq +-- Zipper tests + testOpenClose + testDelClose + testOpenLClose + testOpenRClose + testMoveL + testMoveR + testInsertL + testInsertMoveL + testInsertR + testInsertMoveR + testInsertTreeL + testInsertTreeR + testDelMoveL + testDelMoveR + testDelAllL + testDelAllR + testDelAllCloseL + testDelAllIncCloseL + testDelAllCloseR + testDelAllIncCloseR + testZipSize + testTryOpenLE + testTryOpenGE + testOpenEither + 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 write function +testWrite :: IO () +testWrite = do title "write" + exhaustiveTest test (take 5 allNonEmptyAVL) + where test _ s t = all test_ [0..s-1] + where test_ n = let t_ = write (withCC' (+) n) t + in isBalanced t_ && (asListL t_ == [0..n-1]++(n+n):[n+1..s-1]) + + +-- | Test push function +testPush :: IO () +-- Also exercises: map' and contains +testPush = do title "push" + exhaustiveTest test (take 6 allAVL) + where test h s t = all oddTest odds && all evenTest evens + where t_ = map' (\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__ = psh 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__ = psh n t_ + s__ = size t__ + h__ = ASINT(height t__) + in (s__ == s+1) && (isSortedOK compare t__) && (h__-h <= 1) && (t__ `contns` n) + psh e = push (sndCC e) e + contns avl e = contains avl (compare e) + +-- | Test delete function +testDelete :: IO () +testDelete = do title "delete" + exhaustiveTest test (take 5 allNonEmptyAVL) + where test h s t = all oddTest odds && all evenTest evens + where t_ = map' (\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) && (L.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 = delete (compare e) + +-- | Test assertPop function +testAssertPop :: IO () +testAssertPop = + do title "assertPop" + exhaustiveTest test (take 5 allNonEmptyAVL) + where test h s t = all testElem elems + where elems = [0,1..s-1] + testElem n = let (n_,t_) = assertPop (fstCC n) t + in case checkHeight t_ of + Just h_ -> (h-h_<=1) && (L.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_ == (drop 1 $ 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_ == (drop 1 $ 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 foldr +testFoldr :: IO () +testFoldr = do title "foldr" + exhaustiveTest test (take 6 allAVL) + where test _ s t = foldr (:) [] t == [0..s-1] +-- | Test foldr' +testFoldr' :: IO () +testFoldr' = do title "foldr'" + exhaustiveTest test (take 6 allAVL) + where test _ s t = foldr' (:) [] t == [0..s-1] +-- | Test foldl +testFoldl :: IO () +testFoldl = do title "foldl" + exhaustiveTest test (take 6 allAVL) + where test _ s t = foldl (flip (:)) [] t == [s-1,s-2..0] +-- | Test foldl' +testFoldl' :: IO () +testFoldl' = do title "foldl'" + exhaustiveTest test (take 6 allAVL) + where test _ s t = foldl' (flip (:)) [] t == [s-1,s-2..0] +-- | Test foldr1 +testFoldr1 :: IO () +testFoldr1 = do title "foldr1" + exhaustiveTest test (take 5 allNonEmptyAVL) + where test _ s t = foldr1 (-) t == L.foldr1 (-) [0..s-1] +-- | Test foldr1' +testFoldr1' :: IO () +testFoldr1' = do title "foldr1'" + exhaustiveTest test (take 5 allNonEmptyAVL) + where test _ s t = foldr1' (-) t == L.foldr1 (-) [0..s-1] +-- | Test foldl1 +testFoldl1 :: IO () +testFoldl1 = do title "foldl1" + exhaustiveTest test (take 5 allNonEmptyAVL) + where test _ s t = foldl1 (-) t == L.foldl1 (-) [0..s-1] +-- | Test foldl1' +testFoldl1' :: IO () +testFoldl1' = do title "foldl1'" + exhaustiveTest test (take 5 allNonEmptyAVL) + where test _ s t = foldl1' (-) t == L.foldl1 (-) [0..s-1] + +-- | Test mapAccumL +testMapAccumL :: IO () +testMapAccumL = do title "mapAccumL" + exhaustiveTest test (take 6 allAVL) + where test _ _ t = let (nt,t') = mapAccumL f 0 t + (nl,l ) = L.mapAccumL f 0 (asListL t) + in (nt==nl) && ((asListL t') == l) && (isSortedOK compare t') + f acc n = (acc+n,n+1) + +-- | Test mapAccumR +testMapAccumR :: IO () +testMapAccumR = do title "mapAccumR" + exhaustiveTest test (take 6 allAVL) + where test _ _ t = let (nt,t') = mapAccumR f 0 t + (nl,l ) = L.mapAccumR f 0 (asListL t) + in (nt==nl) && ((asListL t') == l) && (isSortedOK compare t') + f acc n = (acc+n,n+1) + +-- | Test mapAccumL' +testMapAccumL' :: IO () +testMapAccumL' = do title "mapAccumL'" + exhaustiveTest test (take 6 allAVL) + where test _ _ t = let (nt,t') = mapAccumL' f 0 t + (nl,l ) = L.mapAccumL f 0 (asListL t) + in (nt==nl) && ((asListL t') == l) && (isSortedOK compare t') + f acc n = (acc+n,n+1) + +-- | Test mapAccumR' +testMapAccumR' :: IO () +testMapAccumR' = do title "mapAccumR'" + exhaustiveTest test (take 6 allAVL) + where test _ _ t = let (nt,t') = mapAccumR' f 0 t + (nl,l ) = L.mapAccumR f 0 (asListL t) + in (nt==nl) && ((asListL t') == l) && (isSortedOK compare t') + f acc n = (acc+n,n+1) + +-- | Test mapAccumL'' +testMapAccumL'' :: IO () +testMapAccumL'' = do title "mapAccumL''" + exhaustiveTest test (take 6 allAVL) + where test _ _ t = let (nt,t') = mapAccumL'' f_ 0 t + (nl,l ) = 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 mapAccumR'' +testMapAccumR'' :: IO () +testMapAccumR'' = do title "mapAccumR''" + exhaustiveTest test (take 6 allAVL) + where test _ _ t = let (nt,t') = mapAccumR'' f_ 0 t + (nl,l ) = 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) + +-- | 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 $ map (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 $ map (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 $ map (\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 $ L.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 $ map (\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 $ L.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 filter function +testFilter :: IO () +testFilter = do title "filter" + exhaustiveTest test (take 6 allAVL) + where test _ s t = all testit [0..s] -- n==s should yield unmodified tree + where testit n = let t' = filter (/= 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 mapMaybe function +testMapMaybe :: IO () +testMapMaybe = do title "mapMaybe" + exhaustiveTest test (take 6 allAVL) + where test _ s t = all testit [0..s] -- n==s should yield unmodified tree + where testit n = let t' = mapMaybe (\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) && + (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 $ drop 1 $ iterate (map' (\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 $ drop 1 $ iterate (map' (\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 $ L.map rotateIt [-1..s] + where rotateIt n = map' (\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 $ L.map rotateIt [-1..s] + where rotateIt n = map' (\n_ -> (n_+n) `mod` s) $ rotateByR t n + isOK t_ = (isBalanced t_) && (asListL t_ == tlist) + tlist = asListL t + +-- | Test forkL function +testForkL :: IO () +testForkL = do title "forkL" + exhaustiveTest test (take 6 allAVL) + where test _ s t = all testFarkL [-1..s-1] + where tlist = asListL t + testFarkL n = let (l,r) = forkL (compare n) t + in (isBalanced l) && (isBalanced r) && + (size l == n+1) && (size r == s-(n+1)) && + (l `toListL` asListL r == tlist) + +-- | Test forkR function +testForkR :: IO () +testForkR = do title "forkR" + exhaustiveTest test (take 6 allAVL) + where test _ s t = all testFarkR [0..s] + where tlist = asListL t + testFarkR n = let (l,r) = forkR (compare n) t + in (isBalanced l) && (isBalanced r) && + (size l == n) && (size r == s-n) && + (l `toListL` asListL r == tlist) + + +-- | Test fork function +testFork :: IO () +testFork = do title "fork" + 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) = fork (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) = fork (fstCC n) t + in case mbn of + Nothing -> (isEmpty l) && (isBalanced r) && (asListL r == tlist) + _ -> False + testFork2 n = let (l,mbn,r) = fork (fstCC n) t + in case mbn of + Nothing -> (isEmpty r) && (isBalanced l) && (asListL l == tlist) + _ -> False + +-- | Test takeLE function +testTakeLE :: IO () +testTakeLE = do title "takeLE" + exhaustiveTest test (take 6 allAVL) + where test _ s t = all testTikeLE [-1..s-1] + where testTikeLE n = let l = takeLE (compare n) t + in (isBalanced l) && (asListL l == [0..n]) + +-- | Test takeLT function +testTakeLT :: IO () +testTakeLT = do title "takeLT" + exhaustiveTest test (take 6 allAVL) + where test _ s t = all testTikeLT [0..s] + where testTikeLT n = let l = takeLT (compare n) t + in (isBalanced l) && (asListL l == [0..n-1]) + +-- | Test takeGT function +testTakeGT :: IO () +testTakeGT = do title "takeGT" + exhaustiveTest test (take 6 allAVL) + where test _ s t = all testTikeGT [-1..s-1] + where testTikeGT n = let r = takeGT (compare n) t + in (isBalanced r) && (asListL r == [n+1..s-1]) + +-- | Test takeGE function +testTakeGE :: IO () +testTakeGE = do title "takeGE" + exhaustiveTest test (take 6 allAVL) + where test _ s t = all testTikeGE [0..s] + where testTikeGE n = let r = takeGE (compare n) t + in (isBalanced r) && (asListL r == [n..s-1]) + +-- | Test the union function +testUnion :: IO () +testUnion = let trees = take num $ concatMap (\(_,ts) -> ts) allAVL + num = 1000 + in do title "union" + 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 $ map' (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_ = map' (\n -> n+n ) l -- even + r_ = map' (\n -> n+n+1) r -- odd + u = unionFst l_ r_ + in isSortedOK compare u && (size u == ls+rs) + unionFst = union fstCC + +-- | Test the disjointUnion function +testDisjointUnion :: IO () +testDisjointUnion = + let trees = take num $ concatMap (\(_,ts) -> ts) allAVL + num = 1000 + in do title "disjointUnion" + putStrLn $ "Testing " ++ show (num*num) ++ " tree pairs.." + if and [test (map' (\n -> 2*n) l) ls (map' (\n -> 2*n+1) r) rs + | (l,ls) <- trees -- 0,2..2*ls-2 + , (r,rs) <- trees -- 1,3..2*rs-1 + ] + then passed + else failed + where test l ls r rs = all (\f -> f l ls r rs) [test1] + test1 l ls r rs = and [test1_ $ map' (+(2*n)) r | n <- [(-rs)..(ls-1)]] + where test1_ r_ = let u = disjointUnion compare l r_ + in isBalanced u && (asListL u == listUnion (asListL l) (asListL r_)) + +-- | Test the symDifference function +testSymDifference :: IO () +testSymDifference = + let trees = take num $ concatMap (\(_,ts) -> ts) allAVL + num = 1000 + in do title "symDifference" + 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 $ map' (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_ = map' (\n -> n+n ) l -- even + r_ = map' (\n -> n+n+1) r -- odd + u = symDiff l_ r_ + in isSortedOK compare u && (size u == ls+rs) + symDiff = symDifference compare + +-- | Test the unionMaybe function +testUnionMaybe :: IO () +testUnionMaybe = let trees = take num $ concatMap (\(_,ts) -> ts) allAVL + num = 1000 + in do title "unionMaybe" + 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 $ map' (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] + ++ L.filter even [n1 .. n2-1] + ++ [n2..n3-1] + ) + test3 l ls r rs = let l_ = map' (\n -> n+n ) l -- even + r_ = map' (\n -> n+n+1) r -- odd + u = onion l_ r_ + in isSortedOK compare u && (size u == ls+rs) + onion = unionMaybe (withCC' com) + com a _ = if even a then Just a else Nothing + +-- | Test the intersection function +testIntersection :: IO () +testIntersection = let trees = take num $ concatMap (\(_,ts) -> ts) allAVL + num = 1000 + in do title "intersection" + 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 = intersection fstCC l r + in isBalanced u && (asListL u == [0 .. min ls rs - 1]) + test2 l ls r rs = and [test2_ n $ map' (n+) r | n <- [(-rs)..ls]] + where test2_ n r_ = let u = intersection fstCC l r_ + in isBalanced u && (asListL u == [max n 0 .. min ls (rs+n) - 1]) + test3 l _ r _ = let l_ = map' (\n -> n+n ) l -- even + r_ = map' (\n -> n+n+1) r -- odd + u = intersection fstCC l_ r_ + in isEmpty u + +-- | Test the intersectionMaybe function +testIntersectionMaybe :: IO () +testIntersectionMaybe = let trees = take num $ concatMap (\(_,ts) -> ts) allAVL + num = 1000 + in do title "intersectionMaybe" + 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 $ map' (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 == L.filter even [n1 .. n2-1]) + test3 l _ r _ = let l_ = map' (\n -> n+n ) l -- even + r_ = map' (\n -> n+n+1) r -- odd + u = insect l_ r_ + in isEmpty u + insect = intersectionMaybe (withCC' com) + com a _ = if even a then Just a else Nothing + +-- | Test the intersectionAsList function +testIntersectionAsList :: IO () +testIntersectionAsList = + let trees = take num $ concatMap (\(_,ts) -> ts) allAVL + num = 1000 + in do title "intersectionAsList" + 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 = intersectionAsList fstCC l r + in u == [0 .. min ls rs - 1] + test2 l ls r rs = and [test2_ n $ map' (n+) r | n <- [(-rs)..ls]] + where test2_ n r_ = let u = intersectionAsList fstCC l r_ + in u == [max n 0 .. min ls (rs+n) - 1] + test3 l _ r _ = let l_ = map' (\n -> n+n ) l -- even + r_ = map' (\n -> n+n+1) r -- odd + u = intersectionAsList fstCC l_ r_ + in null u + +-- | Test the intersectionMaybeAsList function +testIntersectionMaybeAsList :: IO () +testIntersectionMaybeAsList = + let trees = take num $ concatMap (\(_,ts) -> ts) allAVL + num = 1000 + in do title "intersectionMaybeAsList" + 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 $ map' (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 == L.filter even [n1 .. n2-1] + test3 l _ r _ = let l_ = map' (\n -> n+n ) l -- even + r_ = map' (\n -> n+n+1) r -- odd + u = insect l_ r_ + in null u + insect = intersectionMaybeAsList (withCC' com) + com a _ = if even a then Just a else Nothing + +-- | Test the difference function +testDifference :: IO () +testDifference = let trees = take num $ concatMap (\(_,ts) -> ts) allAVL + num = 1000 + in do title "difference" + 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 = diff l r + in isBalanced u && (asListL u == [rs .. ls - 1]) + test2 l ls r rs = and [test2_ n $ map' (n+) r | n <- [(-rs)..ls]] + where test2_ n r_ = let u = diff l r_ + in isBalanced u && (asListL u == [0 .. n-1] ++ [rs+n .. ls-1]) + test3 l ls r rs = let l_ = map' (\n -> n+n ) l -- even + r_ = map' (\n -> n+n+1) r -- odd + u = diff l r_ + u_ = diff l_ r_ + mn = min (ls-1) (2*rs-1) + in isBalanced u && + (asListL u == L.filter even [0..mn] ++ [mn+1..ls-1]) && + isBalanced u_ && (asListL u_ == asListL l_) + diff = difference compare + +-- | Test the differenceMaybe function +testDifferenceMaybe :: IO () +testDifferenceMaybe = + let trees = take num $ concatMap (\(_,ts) -> ts) allAVL + num = 1000 + in do title "differenceMaybe" + 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 = differenceMaybe c l r + in isBalanced u && (asListL u == L.filter odd [0..mn] ++ [mn+1..ls-1]) + test2 l ls r rs = and [test2_ n $ map' (n+) r | n <- [(-rs)..ls]] + where test2_ n r_ = let u = differenceMaybe c l r_ + n0 = max 0 n + n1 = min (ls-1) (rs+n-1) + in isBalanced u && + (asListL u == [0..n0-1] ++ L.filter odd [n0..n1] ++ [n1+1..ls-1]) + test3 l ls r rs = let l_ = map' (\n -> n+n+1) l -- odd + r_ = map' (\n -> n+n ) r -- even + u = differenceMaybe c l r_ + u_ = differenceMaybe c l_ r_ + mn = min (ls-1) (2*rs-2) + mx = max (mn+1) 0 + listfil = L.filter odd [0..mn] + listrem = [mx..ls-1] + in isBalanced u && isBalanced u_ && (asListL u_ == asListL l_) && + (asListL u == listfil ++ listrem) + +-- | Test the isSubsetOf function +testIsSubsetOf :: IO () +testIsSubsetOf = let trees = take num $ concatMap (\(_,ts) -> ts) allAVL + num = 1000 + in do title "isSubsetOf" + 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 `isSubset` r == (ls<=rs)) && + (r `isSubset` l == (rs<=ls)) + test2 l ls r rs = and [test2_ n $ map' (n+) r | n <- [(-rs)..ls]] + where test2_ n r_ = (l `isSubset` r_ == ((n<=0) && (rs+n>=ls))) && + (r_ `isSubset` l == ((n>=0) && (rs+n<=ls))) + isSubset = isSubsetOf compare + +-- | Test the isSubsetOfBy function +testIsSubsetOfBy :: IO () +testIsSubsetOfBy = let trees = take num $ concatMap (\(_,ts) -> ts) allAVL + num = 1000 + in do title "isSubsetOfBy" + 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 isSubsetOf + -- 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 `isSubset` r == (ls<=rs)) && + (r `isSubset` l == (rs<=ls)) + test2 l ls r rs = and [test2_ n $ map' (n+) r | n <- [(-rs)..ls]] + where test2_ n r_ = (l `isSubset` r_ == ((n<=0) && (rs+n>=ls))) && + (r_ `isSubset` l == ((n>=0) && (rs+n<=ls))) + isSubset = isSubsetOfBy (withCC (\_ _ -> True )) + test3 l ls r rs = and [test3_ n | n <- [0..max ls rs]] + where test3_ n = (l `isSubset'` r == ((ls<=rs) && (n>=ls))) && + (r `isSubset'` l == ((rs<=ls) && (n>=rs))) + where isSubset' = isSubsetOfBy (withCC (\m _ -> m /= n)) + +-- | Test the venn function. Also exercises disjointUnion +testVenn :: IO () +testVenn = + let trees = concatMap (\(_,ts) -> ts) (take 5 allAVL) -- All trees of height 4 or less = 335 trees (112,225 pairs) + num = length trees + in do title "venn" + 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 = let (lr,i,rl) = ven l r + in and [all isBalanced [lr,i,rl] + ,asListL lr == listDiff [0..ls-1] [0..rs-1] + ,asListL i == listIntersection [0..ls-1] [0..rs-1] + ,asListL rl == listDiff [0..rs-1] [0..ls-1] + ,asListL (disu i (disu rl lr)) == listUnion [0..ls-1] [0..rs-1] + ] + test2 l ls r rs = and [test2_ $ map' (n+) r | n <- [(-rs)..ls]] + where test2_ r_ = let (lr,i,rl) = ven l r_ + in and [all isBalanced [lr,i,rl] + ,asListL lr == listDiff (asListL l ) (asListL r_) + ,asListL i == listIntersection (asListL l ) (asListL r_) + ,asListL rl == listDiff (asListL r_) (asListL l ) + ,asListL (disu i (disu rl lr)) == listUnion (asListL l ) (asListL r_) + ] + ven = venn fstCC + disu = disjointUnion compare + +-- | Test the vennMaybe function. +testVennMaybe :: IO () +testVennMaybe = + let trees = concatMap (\(_,ts) -> ts) (take 5 allAVL) -- All trees of height 4 or less = 335 trees (112,225 pairs) + num = length trees + in do title "vennMaybe" + 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 = and [t cmp l ls r rs| t<-[test1], cmp<-[cmpAll,cmpNone,cmpEven,cmpOdd]] + test1 cmp l ls r rs = and [test1_ $ map' (n+) r | n <- [(-rs)..ls]] + where test1_ r_ = let (lr,i,rl) = vennMaybe cmp l r_ + in and [all isBalanced [lr,i,rl] + ,asListL lr == listDiff (asListL l ) (asListL r_) + ,asListL rl == listDiff (asListL r_) (asListL l ) + ,asListL i == listIntersectionMaybe cmp (asListL l ) (asListL r_) + ,asListL (disu i (disu rl lr)) == listUnion (asListL i) (listUnion (asListL lr) (asListL rl)) + ] + cmpAll = withCC' (\x _ -> Just x) + cmpNone = withCC' (\_ _ -> Nothing) + cmpEven = withCC' (\x _ -> if even x then Just x else Nothing) + cmpOdd = withCC' (\x _ -> if odd x then Just x else Nothing) + disu = disjointUnion compare + +-- | 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 +testOpenClose :: IO () +testOpenClose = do title "Zipper open/close" + exhaustiveTest test (take 5 allNonEmptyAVL) + where test _ s t = all test_ [0..s-1] + where test_ n = let z = assertOpen (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 $ assertOpen (compare n) t + in (isBalanced t_) -- && (L.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 (L.map getCurrent zavls == L.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 (L.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 $ assertOpen (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 $ assertOpen (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 (assertOpen (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 (assertOpen (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 $ assertOpen (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 (assertOpen (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 (L.map getCurrent zavls == L.reverse [0..s-1]) && + (and $ zipWith test_ zavls $ L.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 (L.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 $ assertOpen (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 $ assertOpen (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 $ assertOpen (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 $ assertOpen (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 $ assertOpen (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 $ assertOpen (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 = assertOpen (compare n) t + in (sizeL z == n) && (sizeR z == (s-1)-n) && (sizeZAVL z == s) + +-- | Test Zipper tryOpenGE +testTryOpenGE :: IO () +testTryOpenGE = do title "Zipper tryOpenGE" + exhaustiveTest test (take 5 allNonEmptyAVL) + where test _ s t = let t_ = map' (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 = tryOGE n t_ + t__ = close z + in (getCurrent z == n) && (isBalanced t__) && (asListL t__ == [0,2..2*s-2]) + testO t_ n = let Just z = tryOGE n t_ + t__ = close z + in (getCurrent z == n+1) && (isBalanced t__) && (asListL t__ == [0,2..2*s-2]) + tryOGE a = tryOpenGE (compare a) + +-- | Test Zipper tryOpenLE +testTryOpenLE :: IO () +testTryOpenLE = do title "Zipper tryOpenLE" + exhaustiveTest test (take 5 allNonEmptyAVL) + where test _ s t = let t_ = map' (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 = tryOLE n t_ + t__ = close z + in (getCurrent z == n) && (isBalanced t__) && (asListL t__ == [0,2..2*s-2]) + testO t_ n = let Just z = tryOLE n t_ + t__ = close z + in (getCurrent z == n-1) && (isBalanced t__) && (asListL t__ == [0,2..2*s-2]) + tryOLE a = tryOpenLE (compare a) + +-- | Test Zipper openEither (also tests fill and fillClose) +testOpenEither :: IO () +testOpenEither = do title "Zipper openEither" + exhaustiveTest test (take 6 allAVL) + where test _ s t = let t_ = map' (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 = openEith n t_ + t__ = close z + in (getCurrent z == n) && (isBalanced t__) && (asListL t__ == [0,2..2*s-2]) + testO t_ n = let Left p = openEith 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])) + openEith a = openEither (compare a) + + + +-- | Test anyBAVLtoEither +testBAVLtoZipper :: IO () +testBAVLtoZipper = do title "BAVLtoZipper" + exhaustiveTest test (take 6 allAVL) + where test _ s t = let t_ = map' (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 = oBAVL 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 = oBAVL 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])) + oBAVL e = openBAVL (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 = L.replicate (length titl) '*' + in putStrLn "" >> putStrLn mark >> putStrLn titl >> putStrLn mark + +passed :: IO () +passed = putStrLn "Passed" + +failed :: IO () +failed = do putStrLn "!! FAILED !!" + exitFailure + + +-- List union (of ascending Ints) +listUnion :: [Int] -> [Int] -> [Int] +listUnion [] ys = ys +listUnion xs [] = xs +listUnion xs@(x:xs') ys@(y:ys') = case compare x y of + LT -> x:(listUnion xs' ys ) + EQ -> x:(listUnion xs' ys') -- Eliminate duplicates + GT -> y:(listUnion xs ys') + +-- List intersection (of ascending Ints) +listIntersection :: [Int] -> [Int] -> [Int] +listIntersection [] _ = [] +listIntersection _ [] = [] +listIntersection xs@(x:xs') ys@(y:ys') = case compare x y of + LT -> listIntersection xs' ys + EQ -> x:(listIntersection xs' ys') + GT -> listIntersection xs ys' + +-- List intersection maybe (of ascending Ints) +listIntersectionMaybe :: (Int -> Int -> COrdering (Maybe Int)) -> [Int] -> [Int] -> [Int] +listIntersectionMaybe _ [] _ = [] +listIntersectionMaybe _ _ [] = [] +listIntersectionMaybe cmp xs@(x:xs') ys@(y:ys') = case cmp x y of + Lt -> listIntersectionMaybe cmp xs' ys + Eq (Just i) -> i:(listIntersectionMaybe cmp xs' ys') + Eq Nothing -> listIntersectionMaybe cmp xs' ys' + Gt -> listIntersectionMaybe cmp xs ys' + +-- List Difference (of ascending Ints) +listDiff :: [Int] -> [Int] -> [Int] +listDiff [] _ = [] +listDiff xs [] = xs +listDiff xs@(x:xs') ys@(y:ys') = case compare x y of + LT -> x:(listDiff xs' ys) + EQ -> listDiff xs' ys' + GT -> listDiff xs ys' + diff --git a/tests/Utils.hs b/tests/Utils.hs new file mode 100644 --- /dev/null +++ b/tests/Utils.hs @@ -0,0 +1,128 @@ +-- | +-- Copyright : (c) Adrian Hey 2004,2005 +-- License : BSD3 +-- +-- +-- 'AVL' tree related test and verification utilities. +module Utils + (-- * Correctness checking. + checkHeight, + -- * Test data generation. + TestTrees,allAVL, allNonEmptyAVL, numTrees, flatAVL, + -- * Exhaustive tests. + exhaustiveTest, + -- * Testing BinPath module. + pathTree, + ) where + +import Data.Tree.AVL +import Data.Tree.AVL.Internals.Types (AVL(..)) + +import GHC.Base +#include "ghcdefs.h" + +-- | 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 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 isTrue# (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 isTrue# (hl EQL L(-1)) then hl + else let hr = cH r + in if isTrue# (hr EQL L(-1)) then hr + else if isTrue# (SUBINT(hr,hl) EQL delta) then INCINT1(hr) + else L(-1) + + +-- | 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' = map' (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 = drop 1 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]