diff --git a/AUTHORS b/AUTHORS new file mode 100644 --- /dev/null +++ b/AUTHORS @@ -0,0 +1,1 @@ +(c) Adrian HEY diff --git a/AvlTree.cabal b/AvlTree.cabal new file mode 100644 --- /dev/null +++ b/AvlTree.cabal @@ -0,0 +1,68 @@ +Name: AvlTree +Version: 2.4 +Cabal-Version: >= 1.2 +Build-Type: Simple +License: BSD3 +License-File: LICENSE +Copyright: (c) Adrian Hey 2004-2008 +Author: Adrian Hey +Maintainer: http://homepages.nildram.co.uk/~ahey/em.png +Stability: Stable +Homepage: http://www.haskell.org/haskellwiki/AvlTree +Package-Url: +Synopsis: Balanced binary trees using AVL algorithm. +Description: A comprehensive library and efficient implementation of AVL trees. The raw AVL + API has been designed with efficiency and generality in mind, not elagance. It + contains all the stuff you really don't want to write yourself if you can avoid + it. This library may be useful for rolling your own Sets, Maps, Sequences, Queues + (for example). +Category: Data Structures +Tested-With: GHC == 6.8.2, GHC == 6.8.1 +Data-Files: +Extra-Source-Files: AUTHORS, CHANGELOG, Test/Test.hs, include/ghcdefs.h, include/h98defs.h +Extra-Tmp-Files: +Author: Adrian Hey + +Library + Buildable: True + Build-Depends: base, containers, COrdering >= 2.1 + Exposed-Modules: Data.Tree.AVL, + Data.Tree.AVL.Test.AllTests, + Data.Tree.AVL.Test.Counter + Other-Modules: Data.Tree.AVLX, + Data.Tree.AVL.Delete, + Data.Tree.AVL.Join, + Data.Tree.AVL.List, + Data.Tree.AVL.Push, + Data.Tree.AVL.Read, + Data.Tree.AVL.Set, + Data.Tree.AVL.Size, + Data.Tree.AVL.Split, + Data.Tree.AVL.Types, + Data.Tree.AVL.Write, + Data.Tree.AVL.Zipper, + Data.Tree.AVL.Test.Utils, + Data.Tree.AVL.Internals.BinPath, + Data.Tree.AVL.Internals.DelUtils, + Data.Tree.AVL.Internals.HAVL, + Data.Tree.AVL.Internals.HJoin, + Data.Tree.AVL.Internals.HPush, + Data.Tree.AVL.Internals.HSet, + Data.Tree.AVL.Internals.HeightUtils + Extensions: CPP + Hs-Source-Dirs: . + Build-Tools: + Ghc-Options: -O -Wall -split-objs + Ghc-Prof-Options: + Ghc-Shared-Options: + Hugs-Options: + Nhc98-Options: + Includes: + Install-Includes: + Include-Dirs: include + C-Sources: + Extra-Libraries: + Extra-Lib-Dirs: + CC-Options: + LD-Options: + Pkgconfig-Depends: diff --git a/CHANGELOG b/CHANGELOG new file mode 100644 --- /dev/null +++ b/CHANGELOG @@ -0,0 +1,4 @@ +2.4 +--- +* Initial Hackage/Cabal release. + Version set to 2.4 to distinguish from the 2.3 (non-cabal) release on my home page. diff --git a/Data/Tree/AVL.hs b/Data/Tree/AVL.hs new file mode 100644 --- /dev/null +++ b/Data/Tree/AVL.hs @@ -0,0 +1,144 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +----------------------------------------------------------------------------- +-- | +-- Module : Data.Tree.AVL +-- Copyright : (c) Adrian Hey 2004,2005 +-- License : BSD3 +-- +-- Maintainer : http://homepages.nildram.co.uk/~ahey/em.png +-- Stability : stable +-- Portability : portable +-- +-- Many of the functions defined by this package make use of generalised comparison functions +-- which return a variant of the Prelude 'Prelude.Ordering' data type: 'Data.COrdering.COrdering'. These +-- are refered to as \"combining comparisons\". (This is because they combine \"equal\" +-- values in some manner defined by the user.) +-- +-- The idea is that using this simple mechanism you can define many practical and +-- useful variations of tree (or general set) operations from a few generic primitives, +-- something that would not be so easy using plain 'Prelude.Ordering' comparisons +-- (overloaded or otherwise). +-- +-- Functions which involve searching a tree really only require a single argument +-- function which takes the current tree element value as argument and returns +-- an 'Prelude.Ordering' or 'Data.COrdering.COrdering' to direct the next stage of the search down +-- the left or right sub-trees (or stop at the current element). For documentation +-- purposes, these functions are called \"selectors\" throughout this library. +-- Typically a selector will be obtained by partially applying the appropriate +-- combining comparison with the value or key being searched for. For example.. +-- +-- @ +-- mySelector :: Int -> Ordering Tree elements are Ints +-- or.. +-- mySelector :: (key,val) -> COrdering val Tree elements are (key,val) pairs +-- @ +-- +-- Please read the notes in the "Data.Tree.AVL.Types" module documentation too. +----------------------------------------------------------------------------- +module Data.Tree.AVL +(module Data.Tree.AVL.Types, + + -- * Conversion utilities + + -- ** Conversion between /sorted/ AVL trees and Data.Set + set2AVL,avl2Set, + + -- ** Conversion between /sorted/ AVL trees of (key,value) pairs and Data.Map + map2AVL,avl2Map, + + module Data.Tree.AVL.Size, + module Data.Tree.AVL.Read, + module Data.Tree.AVL.Write, + module Data.Tree.AVL.Push, + module Data.Tree.AVL.Delete, + module Data.Tree.AVL.List, + module Data.Tree.AVL.Join, + module Data.Tree.AVL.Split, + module Data.Tree.AVL.Set, + module Data.Tree.AVL.Zipper, + + -- * Correctness checking. + isBalanced,isSorted,isSortedOK, + + -- * Tree parameter utilities. + minElements,maxElements, +) where + +import Prelude -- so haddock finds the symbols there + +import qualified Data.Set as BaseSet +import qualified Data.Map as BaseMap + +import Data.Tree.AVL.Types hiding (E,N,P,Z) +import Data.Tree.AVL.Size +import Data.Tree.AVL.Read +import Data.Tree.AVL.Write +import Data.Tree.AVL.Push +import Data.Tree.AVL.Delete +import Data.Tree.AVL.List +import Data.Tree.AVL.Join +import Data.Tree.AVL.Split +import Data.Tree.AVL.Set +import Data.Tree.AVL.Zipper +import Data.Tree.AVL.Test.Utils(isBalanced,isSorted,isSortedOK,minElements,maxElements) + +#if __GLASGOW_HASKELL__ > 604 +import Data.Traversable +instance Traversable AVL where + traverse = traverseAVL +#endif + +-- | Convert a 'Data.Set.Set' (from the base package Data.Set module) to a sorted AVL tree. +-- Elements and element ordering are preserved (ascending order is left to right). +-- +-- Complexity: O(n) +set2AVL :: BaseSet.Set a -> AVL a +set2AVL set = asTreeLenL (BaseSet.size set) (BaseSet.toAscList set) + +-- | Convert a /sorted/ AVL tree to a 'Data.Set.Set' (from the base package Data.Set module). +-- Elements and element ordering are preserved. +-- +-- Complexity: O(n) +avl2Set :: AVL a -> BaseSet.Set a +avl2Set avl = BaseSet.fromDistinctAscList (asListL avl) + +-- | Convert a 'Data.Map.Map' to a sorted (by key) AVL tree. +-- Elements and element ordering are preserved (ascending order is left to right). +-- +-- Complexity: O(n) +map2AVL :: BaseMap.Map key val -> AVL (key,val) +map2AVL mp = asTreeLenL (BaseMap.size mp) (BaseMap.toAscList mp) + +-- | Convert a /sorted/ (by key) AVL tree to a 'Data.Map.Map' (from the base package Data.Map module). +-- Elements and element ordering are preserved. +-- +-- Complexity: O(n) +avl2Map :: AVL (key,val) -> BaseMap.Map key val +avl2Map avl = BaseMap.fromDistinctAscList (asListL avl) + +-- | Eq is based on equality of the lists produced by 'asListL'. This definition has been placed here +-- to avoid introducing cyclic dependency between Types.hs and List.hs +instance Eq e => Eq (AVL e) where + x == y = (size x == size y) && (asListL x == asListL y) -- Compare sizes first as this will usually resolve it + +-- | Ordering is based on ordering of the lists produced by 'asListL'. This definition has been placed here +-- to avoid introducing cyclic dependency between Types.hs and List.hs +instance Ord e => Ord (AVL e) where + x `compare` y = asListL x `compare` asListL y + +-- | Show is based on showing the list produced by 'asListL'. This definition has been placed here +-- to avoid introducing cyclic dependency between Types.hs and List.hs +instance Show e => Show (AVL e) where + -- showsPrec :: Int -> AVL e -> Shows -- type Shows = String -> String + showsPrec _ t = ("AVL " ++) . showList (asListL t) + +instance Read e => Read (AVL e) where + -- readsPrec :: Int -> ReadS a -- type ReadS a = String -> [(a,String)] + readsPrec _ str = case lex str of + [("AVL",str')] -> [(asTreeL es, str'') | (es,str'') <- readList str'] + _ -> [] + +-- | AVL trees are an instance of 'Functor'. This definition has been placed here +-- to avoid introducing cyclic dependency between Types.hs and List.hs +instance Functor AVL where + fmap = mapAVL -- The lazy version. diff --git a/Data/Tree/AVL/Delete.hs b/Data/Tree/AVL/Delete.hs new file mode 100644 --- /dev/null +++ b/Data/Tree/AVL/Delete.hs @@ -0,0 +1,534 @@ +{-# OPTIONS_GHC -fglasgow-exts #-} +----------------------------------------------------------------------------- +-- | +-- Module : Data.Tree.AVL.Delete +-- Copyright : (c) Adrian Hey 2004,2005 +-- License : BSD3 +-- +-- Maintainer : http://homepages.nildram.co.uk/~ahey/em.png +-- Stability : stable +-- Portability : portable +----------------------------------------------------------------------------- +module Data.Tree.AVL.Delete +(-- * Deleting elements from AVL trees + + -- ** Deleting from extreme left or right + delL,delR,assertDelL,assertDelR,tryDelL,tryDelR, + + -- ** Deleting from /sorted/ trees + genDel,genDelFast,genDelIf,genDelMaybe, + + -- * \"Popping\" elements from AVL trees + -- | \"Popping\" means reading and deleting a tree element in a single operation. + + -- ** Popping from extreme left or right + assertPopL,assertPopR,tryPopL,tryPopR, + + -- ** Popping from /sorted/ trees + genAssertPop,genTryPop,genAssertPopMaybe,genTryPopMaybe,genAssertPopIf,genTryPopIf, +) where + +import Prelude -- so haddock finds the symbols there + +import Data.COrdering +import Data.Tree.AVL.Types(AVL(..)) +import Data.Tree.AVL.Internals.BinPath(BinPath(..),genFindPath,genOpenPathWith,writePath) + +import Data.Tree.AVL.Internals.DelUtils + (-- Deleting Utilities + delRN,delRZ,delRP,delLN,delLZ,delLP, + -- Popping Utilities. + popRN,popRZ,popRP,popLN,popLZ,popLP, + -- Balancing Utilities + chkLN,chkLZ,chkLP,chkRN,chkRZ,chkRP, + chkLN',chkLZ',chkLP',chkRN',chkRZ',chkRP', + -- Node substitution utilities. + subN,subZR,subZL,subP, + -- BinPath related + deletePath + ) + +#ifdef __GLASGOW_HASKELL__ +import GHC.Base +#include "ghcdefs.h" +#else +#include "h98defs.h" +#endif + +-- | Delete the left-most element of an AVL tree. If the tree is sorted this will be the +-- least element. This function returns an empty tree if it's argument is an empty tree. +-- +-- Complexity: O(log n) +delL :: AVL e -> AVL e +delL E = E +delL (N l e r) = delLN l e r +delL (Z l e r) = delLZ l e r +delL (P l e r) = delLP l e r + +-- | Delete the left-most element of a /non-empty/ AVL tree. If the tree is sorted this will be the +-- least element. This function raises an error if it's argument is an empty tree. +-- +-- Complexity: O(log n) +assertDelL :: AVL e -> AVL e +assertDelL E = error "assertDelL: Empty tree." +assertDelL (N l e r) = delLN l e r +assertDelL (Z l e r) = delLZ l e r +assertDelL (P l e r) = delLP l e r + +-- | Try to delete the left-most element of a /non-empty/ AVL tree. If the tree is sorted this will be the +-- least element. This function returns 'Nothing' if it's argument is an empty tree. +-- +-- Complexity: O(log n) +tryDelL :: AVL e -> Maybe (AVL e) +tryDelL E = Nothing +tryDelL (N l e r) = Just $! delLN l e r +tryDelL (Z l e r) = Just $! delLZ l e r +tryDelL (P l e r) = Just $! delLP l e r + +-- | Delete the right-most element of an AVL tree. If the tree is sorted this will be the +-- greatest element. This function returns an empty tree if it's argument is an empty tree. +-- +-- Complexity: O(log n) +delR :: AVL e -> AVL e +delR E = E +delR (N l e r) = delRN l e r +delR (Z l e r) = delRZ l e r +delR (P l e r) = delRP l e r + +-- | Delete the right-most element of a /non-empty/ AVL tree. If the tree is sorted this will be the +-- greatest element. This function raises an error if it's argument is an empty tree. +-- +-- Complexity: O(log n) +assertDelR :: AVL e -> AVL e +assertDelR E = error "assertDelR: Empty tree." +assertDelR (N l e r) = delRN l e r +assertDelR (Z l e r) = delRZ l e r +assertDelR (P l e r) = delRP l e r + +-- | Try to delete the right-most element of a /non-empty/ AVL tree. If the tree is sorted this will be the +-- greatest element. This function returns 'Nothing' if it's argument is an empty tree. +-- +-- Complexity: O(log n) +tryDelR :: AVL e -> Maybe (AVL e) +tryDelR E = Nothing +tryDelR (N l e r) = Just $! delRN l e r +tryDelR (Z l e r) = Just $! delRZ l e r +tryDelR (P l e r) = Just $! delRP l e r + +-- | Pop the left-most element from a non-empty AVL tree, returning the popped element and the +-- modified AVL tree. If the tree is sorted this will be the least element. +-- This function raises an error if it's argument is an empty tree. +-- +-- Complexity: O(log n) +assertPopL :: AVL e -> (e,AVL e) +assertPopL E = error "assertPopL: Empty tree." +assertPopL (N l e r) = case popLN l e r of UBT2(v,t) -> (v,t) +assertPopL (Z l e r) = case popLZ l e r of UBT2(v,t) -> (v,t) +assertPopL (P l e r) = case popLP l e r of UBT2(v,t) -> (v,t) + +-- | Same as 'assertPopL', except this version returns 'Nothing' if it's argument is an empty tree. +-- +-- Complexity: O(log n) +tryPopL :: AVL e -> Maybe (e,AVL e) +tryPopL E = Nothing +tryPopL (N l e r) = Just $! case popLN l e r of UBT2(v,t) -> (v,t) +tryPopL (Z l e r) = Just $! case popLZ l e r of UBT2(v,t) -> (v,t) +tryPopL (P l e r) = Just $! case popLP l e r of UBT2(v,t) -> (v,t) + + +-- | Pop the right-most element from a non-empty AVL tree, returning the popped element and the +-- modified AVL tree. If the tree is sorted this will be the greatest element. +-- This function raises an error if it's argument is an empty tree. +-- +-- Complexity: O(log n) +assertPopR :: AVL e -> (AVL e,e) +assertPopR E = error "assertPopR: Empty tree." +assertPopR (N l e r) = case popRN l e r of UBT2(t,v) -> (t,v) +assertPopR (Z l e r) = case popRZ l e r of UBT2(t,v) -> (t,v) +assertPopR (P l e r) = case popRP l e r of UBT2(t,v) -> (t,v) + +-- | Same as 'assertPopR', except this version returns 'Nothing' if it's argument is an empty tree. +-- +-- Complexity: O(log n) +tryPopR :: AVL e -> Maybe (AVL e,e) +tryPopR E = Nothing +tryPopR (N l e r) = Just $! case popRN l e r of UBT2(t,v) -> (t,v) +tryPopR (Z l e r) = Just $! case popRZ l e r of UBT2(t,v) -> (t,v) +tryPopR (P l e r) = Just $! case popRP l e r of UBT2(t,v) -> (t,v) + +-- | General purpose function for deletion of elements from a sorted AVL tree. +-- If a matching element is not found then this function returns the original tree. +-- +-- Complexity: O(log n) +genDel :: (e -> Ordering) -> AVL e -> AVL e +genDel c t = let p = genFindPath c t + in case COMPAREUINT p L(0) of + LT -> t -- Not found, p<0 + _ -> deletePath p t -- Found, so delete + +-- | This version only deletes the element if the supplied selector returns @('Eq' 'True')@. +-- If it returns @('Eq' 'False')@ or if no matching element is found then this function returns +-- the original tree. +-- +-- Complexity: O(log n) +genDelIf :: (e -> COrdering Bool) -> AVL e -> AVL e +genDelIf c t = case genOpenPathWith c t of + FullBP p True -> deletePath p t + _ -> t + +-- | This version only deletes the element if the supplied selector returns @('Eq' 'Nothing')@. +-- If it returns @('Eq' ('Just' e))@ then the matching element is replaced by e. +-- If no matching element is found then this function returns the original tree. +-- +-- Complexity: O(log n) +genDelMaybe :: (e -> COrdering (Maybe e)) -> AVL e -> AVL e +genDelMaybe c t = case genOpenPathWith c t of + FullBP p Nothing -> deletePath p t + FullBP p (Just e) -> writePath p e t + _ -> t + +-- | Functionally identical to 'genDel', but returns an identical tree (one with all the nodes on +-- the path duplicated) if the search fails. This should probably only be used if you know the +-- search will succeed. +-- +-- Complexity: O(log n) +genDelFast :: (e -> Ordering) -> AVL e -> AVL e +-- This was the old genDel so it's been tested OK, but as a different name. +genDelFast c = genDel' where + genDel' E = E + genDel' (N l e r) = delN l e r + genDel' (Z l e r) = delZ l e r + genDel' (P l e r) = delP l e r + + ----------------------------- LEVEL 1 --------------------------------- + -- delN, delZ, delP -- + ----------------------------------------------------------------------- + + -- Delete from (N l e r) + delN l e r = case c e of + LT -> delNL l e r + EQ -> subN l r + GT -> delNR l e r + + -- Delete from (Z l e r) + delZ l e r = case c e of + LT -> delZL l e r + EQ -> subZR l r + GT -> delZR l e r + + -- Delete from (P l e r) + delP l e r = case c e of + LT -> delPL l e r + EQ -> subP l r + GT -> delPR l e r + + ----------------------------- LEVEL 2 --------------------------------- + -- delNL, delZL, delPL -- + -- delNR, delZR, delPR -- + ----------------------------------------------------------------------- + + -- Delete from the left subtree of (N l e r) + delNL E e r = N E e r -- Left sub-tree is empty + delNL (N ll le lr) e r = case c le of + LT -> chkLN (delNL ll le lr) e r + EQ -> chkLN (subN ll lr) e r + GT -> chkLN (delNR ll le lr) e r + delNL (Z ll le lr) e r = case c le of + LT -> let l' = delZL ll le lr in l' `seq` N l' e r -- height can't change + EQ -> chkLN' (subZR ll lr) e r -- << But it can here + GT -> let l' = delZR ll le lr in l' `seq` N l' e r -- height can't change + delNL (P ll le lr) e r = case c le of + LT -> chkLN (delPL ll le lr) e r + EQ -> chkLN (subP ll lr) e r + GT -> chkLN (delPR ll le lr) e r + + -- Delete from the right subtree of (N l e r) + delNR _ _ E = error "delNR: Bug0" -- Impossible + delNR l e (N rl re rr) = case c re of + LT -> chkRN l e (delNL rl re rr) + EQ -> chkRN l e (subN rl rr) + GT -> chkRN l e (delNR rl re rr) + delNR l e (Z rl re rr) = case c re of + LT -> let r' = delZL rl re rr in r' `seq` N l e r' -- height can't change + EQ -> chkRN' l e (subZL rl rr) -- << But it can here + GT -> let r' = delZR rl re rr in r' `seq` N l e r' -- height can't change + delNR l e (P rl re rr) = case c re of + LT -> chkRN l e (delPL rl re rr) + EQ -> chkRN l e (subP rl rr) + GT -> chkRN l e (delPR rl re rr) + + -- Delete from the left subtree of (Z l e r) + delZL E e r = Z E e r -- Left sub-tree is empty + delZL (N ll le lr) e r = case c le of + LT -> chkLZ (delNL ll le lr) e r + EQ -> chkLZ (subN ll lr) e r + GT -> chkLZ (delNR ll le lr) e r + delZL (Z ll le lr) e r = case c le of + LT -> let l' = delZL ll le lr in l' `seq` Z l' e r -- height can't change + EQ -> chkLZ' (subZR ll lr) e r -- << But it can here + GT -> let l' = delZR ll le lr in l' `seq` Z l' e r -- height can't change + delZL (P ll le lr) e r = case c le of + LT -> chkLZ (delPL ll le lr) e r + EQ -> chkLZ (subP ll lr) e r + GT -> chkLZ (delPR ll le lr) e r + + -- Delete from the right subtree of (Z l e r) + delZR l e E = Z l e E -- Right sub-tree is empty + delZR l e (N rl re rr) = case c re of + LT -> chkRZ l e (delNL rl re rr) + EQ -> chkRZ l e (subN rl rr) + GT -> chkRZ l e (delNR rl re rr) + delZR l e (Z rl re rr) = case c re of + LT -> let r' = delZL rl re rr in r' `seq` Z l e r' -- height can't change + EQ -> chkRZ' l e (subZL rl rr) -- << But it can here + GT -> let r' = delZR rl re rr in r' `seq` Z l e r' -- height can't change + delZR l e (P rl re rr) = case c re of + LT -> chkRZ l e (delPL rl re rr) + EQ -> chkRZ l e (subP rl rr) + GT -> chkRZ l e (delPR rl re rr) + + -- Delete from the left subtree of (P l e r) + delPL E _ _ = error "delPL: Bug0" -- Impossible + delPL (N ll le lr) e r = case c le of + LT -> chkLP (delNL ll le lr) e r + EQ -> chkLP (subN ll lr) e r + GT -> chkLP (delNR ll le lr) e r + delPL (Z ll le lr) e r = case c le of + LT -> let l' = delZL ll le lr in l' `seq` P l' e r -- height can't change + EQ -> chkLP' (subZR ll lr) e r -- << But it can here + GT -> let l' = delZR ll le lr in l' `seq` P l' e r -- height can't change + delPL (P ll le lr) e r = case c le of + LT -> chkLP (delPL ll le lr) e r + EQ -> chkLP (subP ll lr) e r + GT -> chkLP (delPR ll le lr) e r + + -- Delete from the right subtree of (P l e r) + delPR l e E = P l e E -- Right sub-tree is empty + delPR l e (N rl re rr) = case c re of + LT -> chkRP l e (delNL rl re rr) + EQ -> chkRP l e (subN rl rr) + GT -> chkRP l e (delNR rl re rr) + delPR l e (Z rl re rr) = case c re of + LT -> let r' = delZL rl re rr in r' `seq` P l e r' -- height can't change + EQ -> chkRP' l e (subZL rl rr) -- << But it can here + GT -> let r' = delZR rl re rr in r' `seq` P l e r' -- height can't change + delPR l e (P rl re rr) = case c re of + LT -> chkRP l e (delPL rl re rr) + EQ -> chkRP l e (subP rl rr) + GT -> chkRP l e (delPR rl re rr) +----------------------------------------------------------------------- +------------------------- genDelFast Ends Here ------------------------ +----------------------------------------------------------------------- + +-- | General purpose function for popping elements from a sorted AVL tree. +-- An error is raised if a matching element is not found. The pair returned +-- by this function consists of the popped value and the modified tree. +-- +-- Complexity: O(log n) +genAssertPop :: (e -> COrdering a) -> AVL e -> (a,AVL e) +genAssertPop c = genPop_ where + genPop_ E = error "genAssertPop: element not found." + genPop_ (N l e r) = case popN l e r of UBT2(v,t) -> (v,t) + genPop_ (Z l e r) = case popZ l e r of UBT2(v,t) -> (v,t) + genPop_ (P l e r) = case popP l e r of UBT2(v,t) -> (v,t) + + ----------------------------- LEVEL 1 --------------------------------- + -- popN, popZ, popP -- + ----------------------------------------------------------------------- + + -- Pop from (N l e r) + popN l e r = case c e of + Lt -> popNL l e r + Eq a -> let t = subN l r in t `seq` UBT2(a,t) + Gt -> popNR l e r + + -- Pop from (Z l e r) + popZ l e r = case c e of + Lt -> popZL l e r + Eq a -> let t = subZR l r in t `seq` UBT2(a,t) + Gt -> popZR l e r + + -- Pop from (P l e r) + popP l e r = case c e of + Lt -> popPL l e r + Eq a -> let t = subP l r in t `seq` UBT2(a,t) + Gt -> popPR l e r + + ----------------------------- LEVEL 2 --------------------------------- + -- popNL, popZL, popPL -- + -- popNR, popZR, popPR -- + ----------------------------------------------------------------------- + + -- Pop from the left subtree of (N l e r) + popNL E _ _ = error "genAssertPop: element not found." -- Left sub-tree is empty + popNL (N ll le lr) e r = case c le of + Lt -> case popNL ll le lr of + UBT2(a,l_) -> let t = chkLN l_ e r in t `seq` UBT2(a,t) + Eq a -> let t = chkLN (subN ll lr) e r in t `seq` UBT2(a,t) + Gt -> case popNR ll le lr of + UBT2(a,l_) -> let t = chkLN l_ e r in t `seq` UBT2(a,t) + popNL (Z ll le lr) e r = case c le of + Lt -> case popZL ll le lr of UBT2(a,l_) -> UBT2(a, N l_ e r) + Eq a -> let t = chkLN' (subZR ll lr) e r + in t `seq` UBT2(a,t) + Gt -> case popZR ll le lr of UBT2(a,l_) -> UBT2(a, N l_ e r) + popNL (P ll le lr) e r = case c le of + Lt -> case popPL ll le lr of + UBT2(a,l_) -> let t = chkLN l_ e r in t `seq` UBT2(a,t) + Eq a -> let t = chkLN (subP ll lr) e r in t `seq` UBT2(a,t) + Gt -> case popPR ll le lr of + UBT2(a,l_) -> let t = chkLN l_ e r in t `seq` UBT2(a,t) + + -- Pop from the right subtree of (N l e r) + popNR _ _ E = error "genPop.popNR: Bug!" -- Impossible + popNR l e (N rl re rr) = case c re of + Lt -> case popNL rl re rr of + UBT2(a,r_) -> let t = chkRN l e r_ in t `seq` UBT2(a,t) + Eq a -> let t = chkRN l e (subN rl rr) in t `seq` UBT2(a,t) + Gt -> case popNR rl re rr of + UBT2(a,r_) -> let t = chkRN l e r_ in t `seq` UBT2(a,t) + popNR l e (Z rl re rr) = case c re of + Lt -> case popZL rl re rr of UBT2(a,r_) -> UBT2(a, N l e r_) + Eq a -> let t = chkRN' l e (subZL rl rr) + in t `seq` UBT2(a,t) + Gt -> case popZR rl re rr of UBT2(a,r_) -> UBT2(a, N l e r_) + popNR l e (P rl re rr) = case c re of + Lt -> case popPL rl re rr of + UBT2(a,r_) -> let t = chkRN l e r_ in t `seq` UBT2(a,t) + Eq a -> let t = chkRN l e (subP rl rr) in t `seq` UBT2(a,t) + Gt -> case popPR rl re rr of + UBT2(a,r_) -> let t = chkRN l e r_ in t `seq` UBT2(a,t) + + -- Pop from the left subtree of (Z l e r) + popZL E _ _ = error "genAssertPop: element not found." -- Left sub-tree is empty + popZL (N ll le lr) e r = case c le of + Lt -> case popNL ll le lr of + UBT2(a,l_) -> let t = chkLZ l_ e r in t `seq` UBT2(a,t) + Eq a -> let t = chkLZ (subN ll lr) e r in t `seq` UBT2(a,t) + Gt -> case popNR ll le lr of + UBT2(a,l_) -> let t = chkLZ l_ e r in t `seq` UBT2(a,t) + popZL (Z ll le lr) e r = case c le of + Lt -> case popZL ll le lr of UBT2(a,l_) -> UBT2(a, Z l_ e r) + Eq a -> let t = chkLZ' (subZR ll lr) e r + in t `seq` UBT2(a,t) + Gt -> case popZR ll le lr of UBT2(a,l_) -> UBT2(a, Z l_ e r) + popZL (P ll le lr) e r = case c le of + Lt -> case popPL ll le lr of + UBT2(a,l_) -> let t = chkLZ l_ e r in t `seq` UBT2(a,t) + Eq a -> let t = chkLZ (subP ll lr) e r in t `seq` UBT2(a,t) + Gt -> case popPR ll le lr of + UBT2(a,l_) -> let t = chkLZ l_ e r in t `seq` UBT2(a,t) + + -- Pop from the right subtree of (Z l e r) + popZR _ _ E = error "genAssertPop: element not found." -- Right sub-tree is empty + popZR l e (N rl re rr) = case c re of + Lt -> case popNL rl re rr of + UBT2(a,r_) -> let t = chkRZ l e r_ in t `seq` UBT2(a,t) + Eq a -> let t = chkRZ l e (subN rl rr) in t `seq` UBT2(a,t) + Gt -> case popNR rl re rr of + UBT2(a,r_) -> let t = chkRZ l e r_ in t `seq` UBT2(a,t) + popZR l e (Z rl re rr) = case c re of + Lt -> case popZL rl re rr of UBT2(a,r_) -> UBT2(a, Z l e r_) + Eq a -> let t = chkRZ' l e (subZL rl rr) + in t `seq` UBT2(a,t) + Gt -> case popZR rl re rr of UBT2(a,r_) -> UBT2(a, Z l e r_) + popZR l e (P rl re rr) = case c re of + Lt -> case popPL rl re rr of + UBT2(a,r_) -> let t = chkRZ l e r_ in t `seq` UBT2(a,t) + Eq a -> let t = chkRZ l e (subP rl rr) in t `seq` UBT2(a,t) + Gt -> case popPR rl re rr of + UBT2(a,r_) -> let t = chkRZ l e r_ in t `seq` UBT2(a,t) + + -- Pop from the left subtree of (P l e r) + popPL E _ _ = error "genPop.popPL: Bug!" -- Impossible + popPL (N ll le lr) e r = case c le of + Lt -> case popNL ll le lr of + UBT2(a,l_) -> let t = chkLP l_ e r in t `seq` UBT2(a,t) + Eq a -> let t = chkLP (subN ll lr) e r in t `seq` UBT2(a,t) + Gt -> case popNR ll le lr of + UBT2(a,l_) -> let t = chkLP l_ e r in t `seq` UBT2(a,t) + popPL (Z ll le lr) e r = case c le of + Lt -> case popZL ll le lr of UBT2(a,l_) -> UBT2(a, P l_ e r) + Eq a -> let t = chkLP' (subZR ll lr) e r + in t `seq` UBT2(a,t) + Gt -> case popZR ll le lr of UBT2(a,l_) -> UBT2(a, P l_ e r) + popPL (P ll le lr) e r = case c le of + Lt -> case popPL ll le lr of + UBT2(a,l_) -> let t = chkLP l_ e r in t `seq` UBT2(a,t) + Eq a -> let t = chkLP (subP ll lr) e r in t `seq` UBT2(a,t) + Gt -> case popPR ll le lr of + UBT2(a,l_) -> let t = chkLP l_ e r in t `seq` UBT2(a,t) + + -- Pop from the right subtree of (P l e r) + popPR _ _ E = error "genAssertPop: element not found." -- Right sub-tree is empty + popPR l e (N rl re rr) = case c re of + Lt -> case popNL rl re rr of + UBT2(a,r_) -> let t = chkRP l e r_ in t `seq` UBT2(a,t) + Eq a -> let t = chkRP l e (subN rl rr) in t `seq` UBT2(a,t) + Gt -> case popNR rl re rr of + UBT2(a,r_) -> let t = chkRP l e r_ in t `seq` UBT2(a,t) + popPR l e (Z rl re rr) = case c re of + Lt -> case popZL rl re rr of UBT2(a,r_) -> UBT2(a, P l e r_) + Eq a -> let t = chkRP' l e (subZL rl rr) + in t `seq` UBT2(a,t) + Gt -> case popZR rl re rr of UBT2(a,r_) -> UBT2(a, P l e r_) + popPR l e (P rl re rr) = case c re of + Lt -> case popPL rl re rr of + UBT2(a,r_) -> let t = chkRP l e r_ in t `seq` UBT2(a,t) + Eq a -> let t = chkRP l e (subP rl rr) in t `seq` UBT2(a,t) + Gt -> case popPR rl re rr of + UBT2(a,r_) -> let t = chkRP l e r_ in t `seq` UBT2(a,t) +----------------------------------------------------------------------- +------------------------ genAssertPop Ends Here ----------------------- +----------------------------------------------------------------------- + +-- | Similar to 'genPop', but this function returns 'Nothing' if the search fails. +-- +-- Complexity: O(log n) +genTryPop :: (e -> COrdering a) -> AVL e -> Maybe (a,AVL e) +genTryPop c t = case genOpenPathWith c t of + FullBP pth a -> let t' = deletePath pth t in t' `seq` Just (a,t') + _ -> Nothing + +-- | In this case the selector returns two values if a search succeeds. +-- If the second is @('Just' e)@ then the new value (@e@) is substituted in the same place in the tree. +-- If the second is 'Nothing' then the corresponding tree element is deleted. +-- This function raises an error if the search fails. +-- +-- Complexity: O(log n) +genAssertPopMaybe :: (e -> COrdering (a,Maybe e)) -> AVL e -> (a,AVL e) +genAssertPopMaybe c t = case genOpenPathWith c t of + FullBP pth (a,Just e ) -> let t' = writePath pth e t in t' `seq` (a,t') + FullBP pth (a,Nothing) -> let t' = deletePath pth t in t' `seq` (a,t') + _ -> error "genAssertPopMaybe: element not found." + +-- | Similar to 'genAssertPopMaybe', but returns 'Nothing' if the search fails. +-- +-- Complexity: O(log n) +genTryPopMaybe :: (e -> COrdering (a,Maybe e)) -> AVL e -> Maybe (a,AVL e) +genTryPopMaybe c t = case genOpenPathWith c t of + FullBP pth (a,Just e ) -> let t' = writePath pth e t in t' `seq` Just (a,t') + FullBP pth (a,Nothing) -> let t' = deletePath pth t in t' `seq` Just (a,t') + _ -> Nothing + + +-- | A simpler version of 'genAssertPopMaybe'. The corresponding element is deleted if the second value +-- returned by the selector is 'True'. If it\'s 'False', the original tree is returned. +-- This function raises an error if the search fails. +-- +-- Complexity: O(log n) +genAssertPopIf :: (e -> COrdering (a,Bool)) -> AVL e -> (a,AVL e) +genAssertPopIf c t = case genOpenPathWith c t of + FullBP _ (a,False) -> (a,t) + FullBP pth (a,True ) -> let t' = deletePath pth t in t' `seq` (a,t') + _ -> error "genAssertPopIf: element not found." + +-- | Similar to 'genPopIf', but returns 'Nothing' if the search fails. +-- +-- Complexity: O(log n) +genTryPopIf :: (e -> COrdering (a,Bool)) -> AVL e -> Maybe (a,AVL e) +genTryPopIf c t = case genOpenPathWith c t of + FullBP _ (a,False) -> Just (a,t) + FullBP pth (a,True ) -> let t' = deletePath pth t in t' `seq` Just (a,t') + _ -> Nothing + diff --git a/Data/Tree/AVL/Internals/BinPath.hs b/Data/Tree/AVL/Internals/BinPath.hs new file mode 100644 --- /dev/null +++ b/Data/Tree/AVL/Internals/BinPath.hs @@ -0,0 +1,376 @@ +{-# OPTIONS_GHC -fglasgow-exts #-} +----------------------------------------------------------------------------- +-- | +-- Module : Data.Tree.AVL.Internals.BinPath +-- Copyright : (c) Adrian Hey 2005 +-- License : BSD3 +-- +-- Maintainer : http://homepages.nildram.co.uk/~ahey/em.png +-- Stability : stable +-- Portability : portable +-- +-- This module provides a cheap but extremely limited and dangerous alternative +-- to using the Zipper, hence it's for INTERNAL USE ONLY. A BinPath provides +-- a way of finding a particular element in an AVL tree again without doing +-- any comparisons. But a BinPath is ONLY VALID IF THE TREE SHAPE DOES NOT +-- CHANGE. +----------------------------------------------------------------------------- +module Data.Tree.AVL.Internals.BinPath + (BinPath(..),genFindPath,genOpenPath,genOpenPathWith,readPath,writePath,insertPath, + -- These are used by deletePath, which currently resides in Data.Tree.AVL.Internals.DelUtils + sel,goL,goR, + ) where +-- N.B. The deletePath function should really be here too, but has been put +-- in Data.Tree.AVL.Internals.DelUtils instead because deletion is a tangled web of circular +-- depencency. + +import Data.Tree.AVL.Types(AVL(..)) +import Data.COrdering + +#if __GLASGOW_HASKELL__ +import GHC.Base +#include "ghcdefs.h" + +-- Test path LSB +bit0 :: Int# -> Bool +{-# INLINE bit0 #-} +bit0 p = word2Int# (and# (int2Word# p) (int2Word# 1#)) ==# 1# + +-- A pseudo comparison.. +-- N.B. If the path was bit reversed, this could be a straight comparison.?? +sel :: Int# -> Ordering +{-# INLINE sel #-} +sel p = if p ==# 0# then EQ + else if bit0 p then LT -- Left if Bit 0 == 1 + else GT -- Right if Bit 0 == 0 + + +-- Modify path for entering left subtree +goL :: Int# -> Int# +{-# INLINE goL #-} +goL p = iShiftRL# p 1# + +-- Modify path for entering right subtree +goR :: Int# -> Int# +{-# INLINE goR #-} +goR p = iShiftRL# (p -# 1#) 1# + +#else +#include "h98defs.h" +import Data.Bits((.&.),shiftL) + +-- A pseudo comparison.. +-- N.B. If the path was bit reversed, this could be a straight comparison.?? +sel :: Int -> Ordering +{-# INLINE sel #-} +sel p = if p == 0 then EQ + else if bit0 p then LT -- Left if Bit 0 == 1 + else GT -- Right if Bit 0 == 0 +bit0 :: Int -> Bool +{-# INLINE bit0 #-} +bit0 p = (p .&. 1) == 1 + +-- Modify path for entering left subtree +goL :: Int -> Int +{-# INLINE goL #-} +goL p = shiftL p 1 + +-- Modify path for entering right subtree +goR :: Int -> Int +{-# INLINE goR #-} +goR p = shiftL (p-1) 1 +#endif + +-- | Int fields are search /depth/ and /path bits/ respecively. The /path bits/ consist of a +-- a string of /depth/ bits, left justified. MSB of 0 means go left, MSB of 1 means go right. +data BinPath a = FullBP {-# UNPACK #-} !UINT a -- Found + | EmptyBP {-# UNPACK #-} !UINT -- Not Found + +{------------------------------------------------------------------------------------------- + Notes: +-------------------------------------------------------------------------------------------- +The Binary paths are based on an indexing scheme that: + 1- Uniquely identifies each tree node + 2- Provides a simple algorithm for path generation. + 3- Provides a simple algorithm to locate a node in the tree, given it's path. + +Imagine an infinite Binary Tree, with nodes indexed as follows: + + _____00_____ <- d=1 + / \ + _01_ _02_ <- d=2 + / \ / \ + 03 05 04 06 <- d=4 + / \ / \ / \ / \ + 07 11 09 13 08 12 10 14 <- d=8 + <-------- More Layers -------> + +To generate the node index (path) as we move down the tree we.. + 1- Initialise index (i) to 0, and a parameter (d) to 1 + 2- If we've arrived where we want, output i. + 3- Either Move left: i <- i+d, d <- 2d, goto 2 + or Move right: i <- i+2d, d <- 2d, goto 2 + +To find a node, given its index (path) i, we.. + 1- If i=0 then stop, we've arrived. + 2- If i is odd then move left , i <- (i-1)>>1, goto 1 -- (i-1)>>1 = i>>1 if i is odd + else move right, i <- (i-1)>>1, goto 1 -- (i-1)>>1 = (i>>1)-1 if i is even +Examples: + i=05: (left ,i<-2):(right,i<-0):(stop) + i=12: (right,i<-5):(left ,i<-2):(right,i<-0):(stop) + +See also: pathTree in Data.Tree.AVL.Test.Utils for recursive implementation of the indexing scheme. +--------------------------------------------------------------------------------------------} + +-- | Find the path to a AVL tree element, returns -1 (invalid path) if element not found +-- +-- Complexity: O(log n) +genFindPath :: (e -> Ordering) -> AVL e -> UINT +-- ?? What about strictness if UINT is boxed (i.e. non-ghc)? +genFindPath c t = find L(1) L(0) t where + find _ _ E = L(-1) + find d i (N l e r) = find' d i l e r + find d i (Z l e r) = find' d i l e r + find d i (P l e r) = find' d i l e r + find' d i l e r = case c e of + LT -> let d_ = ADDINT(d,d) in find d_ ADDINT(i,d ) l + EQ -> i + GT -> let d_ = ADDINT(d,d) in find d_ ADDINT(i,d_) r -- d_ = 2d + +-- | Get the BinPath of an element using the supplied selector. +-- +-- Complexity: O(log n) +genOpenPath :: (e -> Ordering) -> AVL e -> BinPath e +genOpenPath c t = find L(1) L(0) t where + find _ i E = EmptyBP i + find d i (N l e r) = find' d i l e r + find d i (Z l e r) = find' d i l e r + find d i (P l e r) = find' d i l e r + find' d i l e r = case c e of + LT -> let d_ = ADDINT(d,d) in find d_ ADDINT(i,d ) l + EQ -> FullBP i e + GT -> let d_ = ADDINT(d,d) in find d_ ADDINT(i,d_) r -- d_ = 2d + +-- | Get the BinPath of an element using the supplied (combining) selector. +-- +-- Complexity: O(log n) +genOpenPathWith :: (e -> COrdering a) -> AVL e -> BinPath a +genOpenPathWith c t = find L(1) L(0) t where + find _ i E = EmptyBP i + find d i (N l e r) = find' d i l e r + find d i (Z l e r) = find' d i l e r + find d i (P l e r) = find' d i l e r + find' d i l e r = case c e of + Lt -> let d_ = ADDINT(d,d) in find d_ ADDINT(i,d ) l + Eq a -> FullBP i a + Gt -> let d_ = ADDINT(d,d) in find d_ ADDINT(i,d_) r -- d_ = 2d + +-- | Overwrite a tree element. Assumes the path bits were extracted from 'FullBP' constructor. +-- Raises an error if the path leads to an empty tree. +-- +-- N.B This operation does not change tree shape (no insertion occurs). +-- +-- Complexity: O(log n) +writePath :: UINT -> e -> AVL e -> AVL e +writePath i0 e' t = wp i0 t where + wp L(0) E = error "writePath: Bug0" -- Needed to force strictness in path + wp L(0) (N l _ r) = N l e' r + wp L(0) (Z l _ r) = Z l e' r + wp L(0) (P l _ r) = P l e' r + wp _ E = error "writePath: Bug1" + wp i (N l e r) = if bit0 i then let l' = wp (goL i) l in l' `seq` N l' e r + else let r' = wp (goR i) r in r' `seq` N l e r' + wp i (Z l e r) = if bit0 i then let l' = wp (goL i) l in l' `seq` Z l' e r + else let r' = wp (goR i) r in r' `seq` Z l e r' + wp i (P l e r) = if bit0 i then let l' = wp (goL i) l in l' `seq` P l' e r + else let r' = wp (goR i) r in r' `seq` P l e r' + +-- | Read a tree element. Assumes the path bits were extracted from 'FullBP' constructor. +-- Raises an error if the path leads to an empty tree. +-- +-- Complexity: O(log n) +readPath :: UINT -> AVL e -> e +readPath L(0) E = error "readPath: Bug0" -- Needed to force strictness in path +readPath L(0) (N _ e _) = e +readPath L(0) (Z _ e _) = e +readPath L(0) (P _ e _) = e +readPath _ E = error "readPath: Bug1" +readPath i (N l _ r) = readPath_ i l r +readPath i (Z l _ r) = readPath_ i l r +readPath i (P l _ r) = readPath_ i l r +readPath_ :: UINT -> AVL e -> AVL e -> e +readPath_ i l r = if bit0 i then readPath (goL i) l + else readPath (goR i) r + +-- | Inserts a new tree element. Assumes the path bits were extracted from a 'EmptyBP' constructor. +-- This function replaces the first Empty node it encounters with the supplied value, regardless +-- of the current path bits (which are not checked). DO NOT USE THIS FOR REPLACING ELEMENTS ALREADY +-- PRESENT IN THE TREE (use 'writePath' for this). +-- +-- Complexity: O(log n) +insertPath :: UINT -> e -> AVL e -> AVL e +insertPath i0 e0 t = put i0 t where + ----------------------------- LEVEL 0 --------------------------------- + -- put -- + ----------------------------------------------------------------------- + put _ E = Z E e0 E + put i (N l e r) = putN i l e r + put i (Z l e r) = putZ i l e r + put i (P l e r) = putP i l e r + + ----------------------------- LEVEL 1 --------------------------------- + -- putN, putZ, putP -- + ----------------------------------------------------------------------- + -- Put in (N l e r), BF=-1 , (never returns P) + putN i l e r = if bit0 i then putNL i l e r -- put in L subtree + else putNR i l e r -- put in R subtree + + -- Put in (Z l e r), BF= 0 + putZ i l e r = if bit0 i then putZL i l e r -- put in L subtree + else putZR i l e r -- put in R subtree + + -- Put in (P l e r), BF=+1 , (never returns N) + putP i l e r = if bit0 i then putPL i l e r -- put in L subtree + else putPR i l e r -- put in R subtree + + ----------------------------- LEVEL 2 --------------------------------- + -- putNL, putZL, putPL -- + -- putNR, putZR, putPR -- + ----------------------------------------------------------------------- + + -- (putNL l e r): Put in L subtree of (N l e r), BF=-1 (Never requires rebalancing) , (never returns P) + {-# INLINE putNL #-} + putNL _ E e r = Z (Z E e0 E) e r -- L subtree empty, H:0->1, parent BF:-1-> 0 + putNL i (N ll le lr) e r = let l' = putN (goL i) ll le lr -- L subtree BF<>0, H:h->h, parent BF:-1->-1 + in l' `seq` N l' e r + putNL i (P ll le lr) e r = let l' = putP (goL i) ll le lr -- L subtree BF<>0, H:h->h, parent BF:-1->-1 + in l' `seq` N l' e r + putNL i (Z ll le lr) e r = let l' = putZ (goL i) ll le lr -- L subtree BF= 0, so need to look for changes + in case l' of + E -> error "insertPath: Bug0" -- impossible + Z _ _ _ -> N l' e r -- L subtree BF:0-> 0, H:h->h , parent BF:-1->-1 + _ -> Z l' e r -- L subtree BF:0->+/-1, H:h->h+1, parent BF:-1-> 0 + + -- (putZL l e r): Put in L subtree of (Z l e r), BF= 0 (Never requires rebalancing) , (never returns N) + {-# INLINE putZL #-} + putZL _ E e r = P (Z E e0 E) e r -- L subtree H:0->1, parent BF: 0->+1 + putZL i (N ll le lr) e r = let l' = putN (goL i) ll le lr -- L subtree BF<>0, H:h->h, parent BF: 0-> 0 + in l' `seq` Z l' e r + putZL i (P ll le lr) e r = let l' = putP (goL i) ll le lr -- L subtree BF<>0, H:h->h, parent BF: 0-> 0 + in l' `seq` Z l' e r + putZL i (Z ll le lr) e r = let l' = putZ (goL i) ll le lr -- L subtree BF= 0, so need to look for changes + in case l' of + E -> error "insertPath: Bug1" -- impossible + Z _ _ _ -> Z l' e r -- L subtree BF: 0-> 0, H:h->h , parent BF: 0-> 0 + _ -> P l' e r -- L subtree BF: 0->+/-1, H:h->h+1, parent BF: 0->+1 + + -- (putZR l e r): Put in R subtree of (Z l e r), BF= 0 (Never requires rebalancing) , (never returns P) + {-# INLINE putZR #-} + putZR _ l e E = N l e (Z E e0 E) -- R subtree H:0->1, parent BF: 0->-1 + putZR i l e (N rl re rr) = let r' = putN (goR i) rl re rr -- R subtree BF<>0, H:h->h, parent BF: 0-> 0 + in r' `seq` Z l e r' + putZR i l e (P rl re rr) = let r' = putP (goR i) rl re rr -- R subtree BF<>0, H:h->h, parent BF: 0-> 0 + in r' `seq` Z l e r' + putZR i l e (Z rl re rr) = let r' = putZ (goR i) rl re rr -- R subtree BF= 0, so need to look for changes + in case r' of + E -> error "insertPath: Bug2" -- impossible + Z _ _ _ -> Z l e r' -- R subtree BF: 0-> 0, H:h->h , parent BF: 0-> 0 + _ -> N l e r' -- R subtree BF: 0->+/-1, H:h->h+1, parent BF: 0->-1 + + -- (putPR l e r): Put in R subtree of (P l e r), BF=+1 (Never requires rebalancing) , (never returns N) + {-# INLINE putPR #-} + putPR _ l e E = Z l e (Z E e0 E) -- R subtree empty, H:0->1, parent BF:+1-> 0 + putPR i l e (N rl re rr) = let r' = putN (goR i) rl re rr -- R subtree BF<>0, H:h->h, parent BF:+1->+1 + in r' `seq` P l e r' + putPR i l e (P rl re rr) = let r' = putP (goR i) rl re rr -- R subtree BF<>0, H:h->h, parent BF:+1->+1 + in r' `seq` P l e r' + putPR i l e (Z rl re rr) = let r' = putZ (goR i) rl re rr -- R subtree BF= 0, so need to look for changes + in case r' of + E -> error "insertPath: Bug3" -- impossible + Z _ _ _ -> P l e r' -- R subtree BF:0-> 0, H:h->h , parent BF:+1->+1 + _ -> Z l e r' -- R subtree BF:0->+/-1, H:h->h+1, parent BF:+1-> 0 + + -------- These 2 cases (NR and PL) may need rebalancing if they go to LEVEL 3 --------- + + -- (putNR l e r): Put in R subtree of (N l e r), BF=-1 , (never returns P) + {-# INLINE putNR #-} + putNR _ _ _ E = error "insertPath: Bug4" -- impossible if BF=-1 + putNR i l e (N rl re rr) = let r' = putN (goR i) rl re rr -- R subtree BF<>0, H:h->h, parent BF:-1->-1 + in r' `seq` N l e r' + putNR i l e (P rl re rr) = let r' = putP (goR i) rl re rr -- R subtree BF<>0, H:h->h, parent BF:-1->-1 + in r' `seq` N l e r' + putNR i l e (Z rl re rr) = let i' = goR i in if bit0 i' then putNRL i' l e rl re rr -- RL (never returns P) + else putNRR i' l e rl re rr -- RR (never returns P) + + -- (putPL l e r): Put in L subtree of (P l e r), BF=+1 , (never returns N) + {-# INLINE putPL #-} + putPL _ E _ _ = error "insertPath: Bug5" -- impossible if BF=+1 + putPL i (N ll le lr) e r = let l' = putN (goL i) ll le lr -- L subtree BF<>0, H:h->h, parent BF:+1->+1 + in l' `seq` P l' e r + putPL i (P ll le lr) e r = let l' = putP (goL i) ll le lr -- L subtree BF<>0, H:h->h, parent BF:+1->+1 + in l' `seq` P l' e r + putPL i (Z ll le lr) e r = let i' = goL i in if bit0 i' then putPLL i' ll le lr e r -- LL (never returns N) + else putPLR i' ll le lr e r -- LR (never returns N) + + ----------------------------- LEVEL 3 --------------------------------- + -- putNRR, putPLL -- + -- putNRL, putPLR -- + ----------------------------------------------------------------------- + + -- (putNRR l e rl re rr): Put in RR subtree of (N l e (Z rl re rr)) , (never returns P) + {-# INLINE putNRR #-} + putNRR _ l e rl re E = Z (Z l e rl) re (Z E e0 E) -- l and rl must also be E, special CASE RR!! + putNRR i l e rl re (N rrl rre rrr) = let rr' = putN (goR i) rrl rre rrr -- RR subtree BF<>0, H:h->h, so no change + in rr' `seq` N l e (Z rl re rr') + putNRR i l e rl re (P rrl rre rrr) = let rr' = putP (goR i) rrl rre rrr -- RR subtree BF<>0, H:h->h, so no change + in rr' `seq` N l e (Z rl re rr') + putNRR i l e rl re (Z rrl rre rrr) = let rr' = putZ (goR i) rrl rre rrr -- RR subtree BF= 0, so need to look for changes + in case rr' of + E -> error "insertPath: Bug6" -- impossible + Z _ _ _ -> N l e (Z rl re rr') -- RR subtree BF: 0-> 0, H:h->h, so no change + _ -> Z (Z l e rl) re rr' -- RR subtree BF: 0->+/-1, H:h->h+1, parent BF:-1->-2, CASE RR !! + + -- (putPLL ll le lr e r): Put in LL subtree of (P (Z ll le lr) e r) , (never returns N) + {-# INLINE putPLL #-} + putPLL _ E le lr e r = Z (Z E e0 E) le (Z lr e r) -- r and lr must also be E, special CASE LL!! + putPLL i (N lll lle llr) le lr e r = let ll' = putN (goL i) lll lle llr -- LL subtree BF<>0, H:h->h, so no change + in ll' `seq` P (Z ll' le lr) e r + putPLL i (P lll lle llr) le lr e r = let ll' = putP (goL i) lll lle llr -- LL subtree BF<>0, H:h->h, so no change + in ll' `seq` P (Z ll' le lr) e r + putPLL i (Z lll lle llr) le lr e r = let ll' = putZ (goL i) lll lle llr -- LL subtree BF= 0, so need to look for changes + in case ll' of + E -> error "insertPath: Bug7" -- impossible + Z _ _ _ -> P (Z ll' le lr) e r -- LL subtree BF: 0-> 0, H:h->h, so no change + _ -> Z ll' le (Z lr e r) -- LL subtree BF: 0->+/-1, H:h->h+1, parent BF:-1->-2, CASE LL !! + + -- (putNRL l e rl re rr): Put in RL subtree of (N l e (Z rl re rr)) , (never returns P) + {-# INLINE putNRL #-} + putNRL _ l e E re rr = Z (Z l e E) e0 (Z E re rr) -- l and rr must also be E, special CASE LR !! + putNRL i l e (N rll rle rlr) re rr = let rl' = putN (goL i) rll rle rlr -- RL subtree BF<>0, H:h->h, so no change + in rl' `seq` N l e (Z rl' re rr) + putNRL i l e (P rll rle rlr) re rr = let rl' = putP (goL i) rll rle rlr -- RL subtree BF<>0, H:h->h, so no change + in rl' `seq` N l e (Z rl' re rr) + putNRL i l e (Z rll rle rlr) re rr = let rl' = putZ (goL i) rll rle rlr -- RL subtree BF= 0, so need to look for changes + in case rl' of + E -> error "insertPath: Bug8" -- impossible + Z _ _ _ -> N l e (Z rl' re rr) -- RL subtree BF: 0-> 0, H:h->h, so no change + N rll' rle' rlr' -> Z (P l e rll') rle' (Z rlr' re rr) -- RL subtree BF: 0->-1, SO.. CASE RL(1) !! + P rll' rle' rlr' -> Z (Z l e rll') rle' (N rlr' re rr) -- RL subtree BF: 0->+1, SO.. CASE RL(2) !! + + -- (putPLR ll le lr e r): Put in LR subtree of (P (Z ll le lr) e r) , (never returns N) + {-# INLINE putPLR #-} + putPLR _ ll le E e r = Z (Z ll le E) e0 (Z E e r) -- r and ll must also be E, special CASE LR !! + putPLR i ll le (N lrl lre lrr) e r = let lr' = putN (goR i) lrl lre lrr -- LR subtree BF<>0, H:h->h, so no change + in lr' `seq` P (Z ll le lr') e r + putPLR i ll le (P lrl lre lrr) e r = let lr' = putP (goR i) lrl lre lrr -- LR subtree BF<>0, H:h->h, so no change + in lr' `seq` P (Z ll le lr') e r + putPLR i ll le (Z lrl lre lrr) e r = let lr' = putZ (goR i) lrl lre lrr -- LR subtree BF= 0, so need to look for changes + in case lr' of + E -> error "insertPath: Bug9" -- impossible + Z _ _ _ -> P (Z ll le lr') e r -- LR subtree BF: 0-> 0, H:h->h, so no change + N lrl' lre' lrr' -> Z (P ll le lrl') lre' (Z lrr' e r) -- LR subtree BF: 0->-1, SO.. CASE LR(2) !! + P lrl' lre' lrr' -> Z (Z ll le lrl') lre' (N lrr' e r) -- LR subtree BF: 0->+1, SO.. CASE LR(1) !! +----------------------------------------------------------------------- +----------------------- insertPath Ends Here -------------------------- +----------------------------------------------------------------------- + diff --git a/Data/Tree/AVL/Internals/DelUtils.hs b/Data/Tree/AVL/Internals/DelUtils.hs new file mode 100644 --- /dev/null +++ b/Data/Tree/AVL/Internals/DelUtils.hs @@ -0,0 +1,790 @@ +{-# OPTIONS_GHC -fglasgow-exts #-} +----------------------------------------------------------------------------- +-- | +-- Module : Data.Tree.AVL.Internals.DelUtils +-- Copyright : (c) Adrian Hey 2004,2005 +-- License : BSD3 +-- +-- Maintainer : http://homepages.nildram.co.uk/~ahey/em.png +-- Stability : stable +-- Portability : portable +-- +-- This module defines utility functions for deleting elements from AVL trees. +----------------------------------------------------------------------------- +module Data.Tree.AVL.Internals.DelUtils + (-- * Deleting utilities. + delRN,delRZ,delRP,delLN,delLZ,delLP, + + -- * Popping utilities. + popRN,popRZ,popRP,popLN,popLZ,popLP, + popHL,popHLN,popHLZ,popHLP, + + -- * Balancing utilities. + chkLN,chkLZ,chkLP,chkRN,chkRZ,chkRP, + chkLN',chkLZ',chkLP',chkRN',chkRZ',chkRP', + + -- * Node substitution utilities. + subN,subZR,subZL,subP, + + -- * BinPath related. + deletePath, + ) where + +import Data.Tree.AVL.Types(AVL(..)) +import Data.Tree.AVL.Internals.BinPath(sel,goL,goR) + +#ifdef __GLASGOW_HASKELL__ +import GHC.Base +#include "ghcdefs.h" +#else +#include "h98defs.h" +#endif + +{------------------------------------------------------------------------------------------------------------------------------ + -------------------------------------- Notes about Deletion and Rebalancing ------------------------------------------------- + ------------------------------------------------------------------------------------------------------------------------------ +If you go through a similar analysis to that indicated in the Push.hs module (which I haven't illustrated +here with ASCII art) it can be seen that (as with insertion) the height change in a tree which occurs +as a result of deletion of a node can be infered from the change in BF, (whether or not a re-balancing +rotation was required). The rules are: + BF +/-1 -> 0, height decreased by 1 + BF 0 -> +/-1, height unchanged. + BF unchanged , height unchanged. + BF +/-1 -> -/+1, height unchanged. + +Unlike insertion, rebalancing on deletion requires pattern matching on nodes which aren't on the +current path, hence the existance of separate rebalancing functions (rebalN and rebalP). + +----------------------------------------------------------------------------------------------------------------------------- +-----------------------------------------------------------------------------------------------------------------------------} + + +----------------------------------------------------------------------- +------------------------ delL Starts Here ----------------------------- +----------------------------------------------------------------------- +-------------------------- delL LEVEL 1 ------------------------------- +-- delLN, delLZ, delLP -- +----------------------------------------------------------------------- +-- Delete leftmost from (N l e r) +delLN :: AVL e -> e -> AVL e -> AVL e +delLN E _ r = r -- Terminal case, r must be of form (Z E re E) +delLN (N ll le lr) e r = chkLN (delLN ll le lr) e r +delLN (Z ll le lr) e r = delLNZ ll le lr e r +delLN (P ll le lr) e r = chkLN (delLP ll le lr) e r + +-- Delete leftmost from (Z l e r) +delLZ :: AVL e -> e -> AVL e -> AVL e +delLZ E _ _ = E -- Terminal case, r must be E +delLZ (N ll le lr) e r = delLZN ll le lr e r +delLZ (Z ll le lr) e r = delLZZ ll le lr e r +delLZ (P ll le lr) e r = delLZP ll le lr e r + +-- Delete leftmost from (P l e r) +delLP :: AVL e -> e -> AVL e -> AVL e +delLP E _ _ = error "delLP: Bug0" -- Impossible if BF=+1 +delLP (N ll le lr) e r = chkLP (delLN ll le lr) e r +delLP (Z ll le lr) e r = delLPZ ll le lr e r +delLP (P ll le lr) e r = chkLP (delLP ll le lr) e r + +-------------------------- delL LEVEL 2 ------------------------------- +-- delLNZ, delLZZ, delLPZ -- +-- delLZN, delLZP -- +----------------------------------------------------------------------- + +-- Delete leftmost from (N (Z ll le lr) e r), height of left sub-tree can't change in this case +{-# INLINE delLNZ #-} +delLNZ :: AVL e -> e -> AVL e -> e -> AVL e -> AVL e +delLNZ E _ _ e r = rebalN E e r -- Terminal case, Needs rebalancing +delLNZ (N lll lle llr) le lr e r = let l' = delLZN lll lle llr le lr in l' `seq` N l' e r +delLNZ (Z lll lle llr) le lr e r = let l' = delLZZ lll lle llr le lr in l' `seq` N l' e r +delLNZ (P lll lle llr) le lr e r = let l' = delLZP lll lle llr le lr in l' `seq` N l' e r + +-- Delete leftmost from (Z (Z ll le lr) e r), height of left sub-tree can't change in this case +-- Don't inline +delLZZ :: AVL e -> e -> AVL e -> e -> AVL e -> AVL e +delLZZ E _ _ e r = N E e r -- Terminal case +delLZZ (N lll lle llr) le lr e r = let l' = delLZN lll lle llr le lr in l' `seq` Z l' e r +delLZZ (Z lll lle llr) le lr e r = let l' = delLZZ lll lle llr le lr in l' `seq` Z l' e r +delLZZ (P lll lle llr) le lr e r = let l' = delLZP lll lle llr le lr in l' `seq` Z l' e r + +-- Delete leftmost from (P (Z ll le lr) e r), height of left sub-tree can't change in this case +{-# INLINE delLPZ #-} +delLPZ :: AVL e -> e -> AVL e -> e -> AVL e -> AVL e +delLPZ E _ _ e _ = Z E e E -- Terminal case +delLPZ (N lll lle llr) le lr e r = let l' = delLZN lll lle llr le lr in l' `seq` P l' e r +delLPZ (Z lll lle llr) le lr e r = let l' = delLZZ lll lle llr le lr in l' `seq` P l' e r +delLPZ (P lll lle llr) le lr e r = let l' = delLZP lll lle llr le lr in l' `seq` P l' e r + +-- Delete leftmost from (Z (N ll le lr) e r) +{-# INLINE delLZN #-} +delLZN :: AVL e -> e -> AVL e -> e -> AVL e -> AVL e +delLZN ll le lr e r = chkLZ (delLN ll le lr) e r + +-- Delete leftmost from (Z (P ll le lr) e r) +{-# INLINE delLZP #-} +delLZP :: AVL e -> e -> AVL e -> e -> AVL e -> AVL e +delLZP ll le lr e r = chkLZ (delLP ll le lr) e r +----------------------------------------------------------------------- +-------------------------- delL Ends Here ----------------------------- +----------------------------------------------------------------------- + + + +----------------------------------------------------------------------- +------------------------ delR Starts Here ----------------------------- +----------------------------------------------------------------------- +-------------------------- delR LEVEL 1 ------------------------------- +-- delRN, delRZ, delRP -- +----------------------------------------------------------------------- +-- Delete rightmost from (N l e r) +delRN :: AVL e -> e -> AVL e -> AVL e +delRN _ _ E = error "delRN: Bug0" -- Impossible if BF=-1 +delRN l e (N rl re rr) = chkRN l e (delRN rl re rr) +delRN l e (Z rl re rr) = delRNZ l e rl re rr +delRN l e (P rl re rr) = chkRN l e (delRP rl re rr) + +-- Delete rightmost from (Z l e r) +delRZ :: AVL e -> e -> AVL e -> AVL e +delRZ _ _ E = E -- Terminal case, l must be E +delRZ l e (N rl re rr) = delRZN l e rl re rr +delRZ l e (Z rl re rr) = delRZZ l e rl re rr +delRZ l e (P rl re rr) = delRZP l e rl re rr + +-- Delete rightmost from (P l e r) +delRP :: AVL e -> e -> AVL e -> AVL e +delRP l _ E = l -- Terminal case, l must be of form (Z E le E) +delRP l e (N rl re rr) = chkRP l e (delRN rl re rr) +delRP l e (Z rl re rr) = delRPZ l e rl re rr +delRP l e (P rl re rr) = chkRP l e (delRP rl re rr) + +-------------------------- delR LEVEL 2 ------------------------------- +-- delRNZ, delRZZ, delRPZ -- +-- delRZN, delRZP -- +----------------------------------------------------------------------- + +-- Delete rightmost from (N l e (Z rl re rr)), height of right sub-tree can't change in this case +delRNZ :: AVL e -> e -> AVL e -> e -> AVL e -> AVL e +{-# INLINE delRNZ #-} +delRNZ _ e _ _ E = Z E e E -- Terminal case +delRNZ l e rl re (N rrl rre rrr) = let r' = delRZN rl re rrl rre rrr in r' `seq` N l e r' +delRNZ l e rl re (Z rrl rre rrr) = let r' = delRZZ rl re rrl rre rrr in r' `seq` N l e r' +delRNZ l e rl re (P rrl rre rrr) = let r' = delRZP rl re rrl rre rrr in r' `seq` N l e r' + +-- Delete rightmost from (Z l e (Z rl re rr)), height of right sub-tree can't change in this case +delRZZ :: AVL e -> e -> AVL e -> e -> AVL e -> AVL e +delRZZ l e _ _ E = P l e E -- Terminal case +delRZZ l e rl re (N rrl rre rrr) = let r' = delRZN rl re rrl rre rrr in r' `seq` Z l e r' +delRZZ l e rl re (Z rrl rre rrr) = let r' = delRZZ rl re rrl rre rrr in r' `seq` Z l e r' +delRZZ l e rl re (P rrl rre rrr) = let r' = delRZP rl re rrl rre rrr in r' `seq` Z l e r' + +-- Delete rightmost from (P l e (Z rl re rr)), height of right sub-tree can't change in this case +delRPZ :: AVL e -> e -> AVL e -> e -> AVL e -> AVL e +{-# INLINE delRPZ #-} +delRPZ l e _ _ E = rebalP l e E -- Terminal case, Needs rebalancing +delRPZ l e rl re (N rrl rre rrr) = let r' = delRZN rl re rrl rre rrr in r' `seq` P l e r' +delRPZ l e rl re (Z rrl rre rrr) = let r' = delRZZ rl re rrl rre rrr in r' `seq` P l e r' +delRPZ l e rl re (P rrl rre rrr) = let r' = delRZP rl re rrl rre rrr in r' `seq` P l e r' + +-- Delete rightmost from (Z l e (N rl re rr)) +delRZN :: AVL e -> e -> AVL e -> e -> AVL e -> AVL e +{-# INLINE delRZN #-} +delRZN l e rl re rr = chkRZ l e (delRN rl re rr) + +-- Delete rightmost from (Z l e (P rl re rr)) +delRZP :: AVL e -> e -> AVL e -> e -> AVL e -> AVL e +{-# INLINE delRZP #-} +delRZP l e rl re rr = chkRZ l e (delRP rl re rr) +----------------------------------------------------------------------- +-------------------------- delR Ends Here ----------------------------- +----------------------------------------------------------------------- + + + +----------------------------------------------------------------------- +------------------------ popL Starts Here ----------------------------- +----------------------------------------------------------------------- +-------------------------- popL LEVEL 1 ------------------------------- +-- popLN, popLZ, popLP -- +----------------------------------------------------------------------- +-- Delete leftmost from (N l e r) +popLN :: AVL e -> e -> AVL e -> UBT2(e,AVL e) +popLN E e r = UBT2(e,r) -- Terminal case, r must be of form (Z E re E) +popLN (N ll le lr) e r = case popLN ll le lr of + UBT2(v,l) -> let t = chkLN l e r in t `seq` UBT2(v,t) +popLN (Z ll le lr) e r = popLNZ ll le lr e r +popLN (P ll le lr) e r = case popLP ll le lr of + UBT2(v,l) -> let t = chkLN l e r in t `seq` UBT2(v,t) + +-- Delete leftmost from (Z l e r) +popLZ :: AVL e -> e -> AVL e -> UBT2(e,AVL e) +popLZ E e _ = UBT2(e,E) -- Terminal case, r must be E +popLZ (N ll le lr) e r = popLZN ll le lr e r +popLZ (Z ll le lr) e r = popLZZ ll le lr e r +popLZ (P ll le lr) e r = popLZP ll le lr e r + +-- Delete leftmost from (P l e r) +popLP :: AVL e -> e -> AVL e -> UBT2(e,AVL e) +popLP E _ _ = error "popLP: Bug!" -- Impossible if BF=+1 +popLP (N ll le lr) e r = case popLN ll le lr of + UBT2(v,l) -> let t = chkLP l e r in t `seq` UBT2(v,t) +popLP (Z ll le lr) e r = popLPZ ll le lr e r +popLP (P ll le lr) e r = case popLP ll le lr of + UBT2(v,l) -> let t = chkLP l e r in t `seq` UBT2(v,t) + +-------------------------- popL LEVEL 2 ------------------------------- +-- popLNZ, popLZZ, popLPZ -- +-- popLZN, popLZP -- +----------------------------------------------------------------------- + +-- Delete leftmost from (N (Z ll le lr) e r), height of left sub-tree can't change in this case +popLNZ :: AVL e -> e -> AVL e -> e -> AVL e -> UBT2(e,AVL e) +{-# INLINE popLNZ #-} +popLNZ E le _ e r = let t = rebalN E e r -- Terminal case, Needs rebalancing + in t `seq` UBT2(le,t) +popLNZ (N lll lle llr) le lr e r = case popLZN lll lle llr le lr of + UBT2(v,l) -> UBT2(v, N l e r) +popLNZ (Z lll lle llr) le lr e r = case popLZZ lll lle llr le lr of + UBT2(v,l) -> UBT2(v, N l e r) +popLNZ (P lll lle llr) le lr e r = case popLZP lll lle llr le lr of + UBT2(v,l) -> UBT2(v, N l e r) + +-- Delete leftmost from (Z (Z ll le lr) e r), height of left sub-tree can't change in this case +-- Don't INLINE this! +popLZZ :: AVL e -> e -> AVL e -> e -> AVL e -> UBT2(e,AVL e) +popLZZ E le _ e r = UBT2(le, N E e r) -- Terminal case +popLZZ (N lll lle llr) le lr e r = case popLZN lll lle llr le lr of + UBT2(v,l) -> UBT2(v, Z l e r) +popLZZ (Z lll lle llr) le lr e r = case popLZZ lll lle llr le lr of + UBT2(v,l) -> UBT2(v, Z l e r) +popLZZ (P lll lle llr) le lr e r = case popLZP lll lle llr le lr of + UBT2(v,l) -> UBT2(v, Z l e r) + +-- Delete leftmost from (P (Z ll le lr) e r), height of left sub-tree can't change in this case +popLPZ :: AVL e -> e -> AVL e -> e -> AVL e -> UBT2(e,AVL e) +{-# INLINE popLPZ #-} +popLPZ E le _ e _ = UBT2(le, Z E e E) -- Terminal case +popLPZ (N lll lle llr) le lr e r = case popLZN lll lle llr le lr of + UBT2(v,l) -> UBT2(v, P l e r) +popLPZ (Z lll lle llr) le lr e r = case popLZZ lll lle llr le lr of + UBT2(v,l) -> UBT2(v, P l e r) +popLPZ (P lll lle llr) le lr e r = case popLZP lll lle llr le lr of + UBT2(v,l) -> UBT2(v, P l e r) + +-- Delete leftmost from (Z (N ll le lr) e r) +-- Don't INLINE this! +popLZN :: AVL e -> e -> AVL e -> e -> AVL e -> UBT2(e,AVL e) +popLZN ll le lr e r = case popLN ll le lr of + UBT2(v,l) -> let t = chkLZ l e r in t `seq` UBT2(v,t) +-- Delete leftmost from (Z (P ll le lr) e r) +-- Don't INLINE this! +popLZP :: AVL e -> e -> AVL e -> e -> AVL e -> UBT2(e,AVL e) +popLZP ll le lr e r = case popLP ll le lr of + UBT2(v,l) -> let t = chkLZ l e r in t `seq` UBT2(v,t) +----------------------------------------------------------------------- +-------------------------- popL Ends Here ----------------------------- +----------------------------------------------------------------------- + + + +----------------------------------------------------------------------- +------------------------ popR Starts Here ----------------------------- +----------------------------------------------------------------------- +-------------------------- popR LEVEL 1 ------------------------------- +-- popRN, popRZ, popRP -- +----------------------------------------------------------------------- +-- Delete rightmost from (N l e r) +popRN :: AVL e -> e -> AVL e -> UBT2(AVL e,e) +popRN _ _ E = error "popRN: Bug!" -- Impossible if BF=-1 +popRN l e (N rl re rr) = case popRN rl re rr of + UBT2(r,v) -> let t = chkRN l e r in t `seq` UBT2(t,v) +popRN l e (Z rl re rr) = popRNZ l e rl re rr +popRN l e (P rl re rr) = case popRP rl re rr of + UBT2(r,v) -> let t = chkRN l e r in t `seq` UBT2(t,v) + +-- Delete rightmost from (Z l e r) +popRZ :: AVL e -> e -> AVL e -> UBT2(AVL e,e) +popRZ _ e E = UBT2(E,e) -- Terminal case, l must be E +popRZ l e (N rl re rr) = popRZN l e rl re rr +popRZ l e (Z rl re rr) = popRZZ l e rl re rr +popRZ l e (P rl re rr) = popRZP l e rl re rr + +-- Delete rightmost from (P l e r) +popRP :: AVL e -> e -> AVL e -> UBT2(AVL e,e) +popRP l e E = UBT2(l,e) -- Terminal case, l must be of form (Z E le E) +popRP l e (N rl re rr) = case popRN rl re rr of + UBT2(r,v) -> let t = chkRP l e r in t `seq` UBT2(t,v) +popRP l e (Z rl re rr) = popRPZ l e rl re rr +popRP l e (P rl re rr) = case popRP rl re rr of + UBT2(r,v) -> let t = chkRP l e r in t `seq` UBT2(t,v) + +-------------------------- popR LEVEL 2 ------------------------------- +-- popRNZ, popRZZ, popRPZ -- +-- popRZN, popRZP -- +----------------------------------------------------------------------- + +-- Delete rightmost from (N l e (Z rl re rr)), height of right sub-tree can't change in this case +popRNZ :: AVL e -> e -> AVL e -> e -> AVL e -> UBT2(AVL e,e) +{-# INLINE popRNZ #-} +popRNZ _ e _ re E = UBT2(Z E e E, re) -- Terminal case +popRNZ l e rl re (N rrl rre rrr) = case popRZN rl re rrl rre rrr of + UBT2(r,v) -> UBT2(N l e r, v) +popRNZ l e rl re (Z rrl rre rrr) = case popRZZ rl re rrl rre rrr of + UBT2(r,v) -> UBT2(N l e r, v) +popRNZ l e rl re (P rrl rre rrr) = case popRZP rl re rrl rre rrr of + UBT2(r,v) -> UBT2(N l e r, v) + +-- Delete rightmost from (Z l e (Z rl re rr)), height of right sub-tree can't change in this case +-- Don't INLINE this! +popRZZ :: AVL e -> e -> AVL e -> e -> AVL e -> UBT2(AVL e,e) +popRZZ l e _ re E = UBT2(P l e E, re) -- Terminal case +popRZZ l e rl re (N rrl rre rrr) = case popRZN rl re rrl rre rrr of + UBT2(r,v) -> UBT2(Z l e r, v) +popRZZ l e rl re (Z rrl rre rrr) = case popRZZ rl re rrl rre rrr of + UBT2(r,v) -> UBT2(Z l e r, v) +popRZZ l e rl re (P rrl rre rrr) = case popRZP rl re rrl rre rrr of + UBT2(r,v) -> UBT2(Z l e r, v) + +-- Delete rightmost from (P l e (Z rl re rr)), height of right sub-tree can't change in this case +popRPZ :: AVL e -> e -> AVL e -> e -> AVL e -> UBT2(AVL e,e) +{-# INLINE popRPZ #-} +popRPZ l e _ re E = let t = rebalP l e E -- Terminal case, Needs rebalancing + in t `seq` UBT2(t,re) +popRPZ l e rl re (N rrl rre rrr) = case popRZN rl re rrl rre rrr of + UBT2(r,v) -> UBT2(P l e r, v) +popRPZ l e rl re (Z rrl rre rrr) = case popRZZ rl re rrl rre rrr of + UBT2(r,v) -> UBT2(P l e r, v) +popRPZ l e rl re (P rrl rre rrr) = case popRZP rl re rrl rre rrr of + UBT2(r,v) -> UBT2(P l e r, v) + +-- Delete rightmost from (Z l e (N rl re rr)) +-- Don't INLINE this! +popRZN :: AVL e -> e -> AVL e -> e -> AVL e -> UBT2(AVL e,e) +popRZN l e rl re rr = case popRN rl re rr of + UBT2(r,v) -> let t = chkRZ l e r in t `seq` UBT2(t,v) + +-- Delete rightmost from (Z l e (P rl re rr)) +-- Don't INLINE this! +popRZP :: AVL e -> e -> AVL e -> e -> AVL e -> UBT2(AVL e,e) +popRZP l e rl re rr = case popRP rl re rr of + UBT2(r,v) -> let t = chkRZ l e r in t `seq` UBT2(t,v) +----------------------------------------------------------------------- +-------------------------- popR Ends Here ----------------------------- +----------------------------------------------------------------------- + + + +----------------------------------------------------------------------- +--------------------- deletePath Starts Here -------------------------- +----------------------------------------------------------------------- +-- | Deletes a tree element. Assumes the path bits were extracted from a 'FullBP' constructor. +-- +-- Complexity: O(log n) +deletePath :: UINT -> AVL e -> AVL e +deletePath _ E = error "deletePath: Element not found." +deletePath p (N l e r) = delN p l e r +deletePath p (Z l e r) = delZ p l e r +deletePath p (P l e r) = delP p l e r + +----------------------------- LEVEL 1 --------------------------------- +-- delN, delZ, delP -- +----------------------------------------------------------------------- + +-- Delete from (N l e r) +delN :: UINT -> AVL e -> e -> AVL e -> AVL e +delN p l e r = case sel p of + LT -> delNL p l e r + EQ -> subN l r + GT -> delNR p l e r + +-- Delete from (Z l e r) +delZ :: UINT -> AVL e -> e -> AVL e -> AVL e +delZ p l e r = case sel p of + LT -> delZL p l e r + EQ -> subZR l r + GT -> delZR p l e r + +-- Delete from (P l e r) +delP :: UINT -> AVL e -> e -> AVL e -> AVL e +delP p l e r = case sel p of + LT -> delPL p l e r + EQ -> subP l r + GT -> delPR p l e r + +----------------------------- LEVEL 2 --------------------------------- +-- delNL, delZL, delPL -- +-- delNR, delZR, delPR -- +----------------------------------------------------------------------- + +-- Delete from the left subtree of (N l e r) +delNL :: UINT -> AVL e -> e -> AVL e -> AVL e +delNL p t = dNL (goL p) t +{-# INLINE dNL #-} +dNL :: UINT -> AVL e -> e -> AVL e -> AVL e +dNL _ E _ _ = error "deletePath: Element not found." -- Left sub-tree is empty +dNL p (N ll le lr) e r = case sel p of + LT -> chkLN (delNL p ll le lr) e r + EQ -> chkLN (subN ll lr) e r + GT -> chkLN (delNR p ll le lr) e r +dNL p (Z ll le lr) e r = case sel p of + LT -> let l' = delZL p ll le lr in l' `seq` N l' e r -- height can't change + EQ -> chkLN' (subZR ll lr) e r -- << But it can here + GT -> let l' = delZR p ll le lr in l' `seq` N l' e r -- height can't change +dNL p (P ll le lr) e r = case sel p of + LT -> chkLN (delPL p ll le lr) e r + EQ -> chkLN (subP ll lr) e r + GT -> chkLN (delPR p ll le lr) e r + +-- Delete from the right subtree of (N l e r) +delNR :: UINT -> AVL e -> e -> AVL e -> AVL e +delNR p t = dNR (goR p) t +{-# INLINE dNR #-} +dNR :: UINT -> AVL e -> e -> AVL e -> AVL e +dNR _ _ _ E = error "delNR: Bug0" -- Impossible +dNR p l e (N rl re rr) = case sel p of + LT -> chkRN l e (delNL p rl re rr) + EQ -> chkRN l e (subN rl rr) + GT -> chkRN l e (delNR p rl re rr) +dNR p l e (Z rl re rr) = case sel p of + LT -> let r' = delZL p rl re rr in r' `seq` N l e r' -- height can't change + EQ -> chkRN' l e (subZL rl rr) -- << But it can here + GT -> let r' = delZR p rl re rr in r' `seq` N l e r' -- height can't change +dNR p l e (P rl re rr) = case sel p of + LT -> chkRN l e (delPL p rl re rr) + EQ -> chkRN l e (subP rl rr) + GT -> chkRN l e (delPR p rl re rr) + +-- Delete from the left subtree of (Z l e r) +delZL :: UINT -> AVL e -> e -> AVL e -> AVL e +delZL p t = dZL (goL p) t +{-# INLINE dZL #-} +dZL :: UINT -> AVL e -> e -> AVL e -> AVL e +dZL _ E _ _ = error "deletePath: Element not found." -- Left sub-tree is empty +dZL p (N ll le lr) e r = case sel p of + LT -> chkLZ (delNL p ll le lr) e r + EQ -> chkLZ (subN ll lr) e r + GT -> chkLZ (delNR p ll le lr) e r +dZL p (Z ll le lr) e r = case sel p of + LT -> let l' = delZL p ll le lr in l' `seq` Z l' e r -- height can't change + EQ -> chkLZ' (subZR ll lr) e r -- << But it can here + GT -> let l' = delZR p ll le lr in l' `seq` Z l' e r -- height can't change +dZL p (P ll le lr) e r = case sel p of + LT -> chkLZ (delPL p ll le lr) e r + EQ -> chkLZ (subP ll lr) e r + GT -> chkLZ (delPR p ll le lr) e r + +-- Delete from the right subtree of (Z l e r) +delZR :: UINT -> AVL e -> e -> AVL e -> AVL e +delZR p t = dZR (goR p) t +{-# INLINE dZR #-} +dZR :: UINT -> AVL e -> e -> AVL e -> AVL e +dZR _ _ _ E = error "deletePath: Element not found." -- Right sub-tree is empty +dZR p l e (N rl re rr) = case sel p of + LT -> chkRZ l e (delNL p rl re rr) + EQ -> chkRZ l e (subN rl rr) + GT -> chkRZ l e (delNR p rl re rr) +dZR p l e (Z rl re rr) = case sel p of + LT -> let r' = delZL p rl re rr in r' `seq` Z l e r' -- height can't change + EQ -> chkRZ' l e (subZL rl rr) -- << But it can here + GT -> let r' = delZR p rl re rr in r' `seq` Z l e r' -- height can't change +dZR p l e (P rl re rr) = case sel p of + LT -> chkRZ l e (delPL p rl re rr) + EQ -> chkRZ l e (subP rl rr) + GT -> chkRZ l e (delPR p rl re rr) + +-- Delete from the left subtree of (P l e r) +delPL :: UINT -> AVL e -> e -> AVL e -> AVL e +delPL p t = dPL (goL p) t +{-# INLINE dPL #-} +dPL :: UINT -> AVL e -> e -> AVL e -> AVL e +dPL _ E _ _ = error "delPL: Bug0" -- Impossible +dPL p (N ll le lr) e r = case sel p of + LT -> chkLP (delNL p ll le lr) e r + EQ -> chkLP (subN ll lr) e r + GT -> chkLP (delNR p ll le lr) e r +dPL p (Z ll le lr) e r = case sel p of + LT -> let l' = delZL p ll le lr in l' `seq` P l' e r -- height can't change + EQ -> chkLP' (subZR ll lr) e r -- << But it can here + GT -> let l' = delZR p ll le lr in l' `seq` P l' e r -- height can't change +dPL p (P ll le lr) e r = case sel p of + LT -> chkLP (delPL p ll le lr) e r + EQ -> chkLP (subP ll lr) e r + GT -> chkLP (delPR p ll le lr) e r + +-- Delete from the right subtree of (P l e r) +delPR :: UINT -> AVL e -> e -> AVL e -> AVL e +delPR p t = dPR (goR p) t +{-# INLINE dPR #-} +dPR :: UINT -> AVL e -> e -> AVL e -> AVL e +dPR _ _ _ E = error "deletePath: Element not found." -- Right sub-tree is empty +dPR p l e (N rl re rr) = case sel p of + LT -> chkRP l e (delNL p rl re rr) + EQ -> chkRP l e (subN rl rr) + GT -> chkRP l e (delNR p rl re rr) +dPR p l e (Z rl re rr) = case sel p of + LT -> let r' = delZL p rl re rr in r' `seq` P l e r' -- height can't change + EQ -> chkRP' l e (subZL rl rr) -- << But it can here + GT -> let r' = delZR p rl re rr in r' `seq` P l e r' -- height can't change +dPR p l e (P rl re rr) = case sel p of + LT -> chkRP l e (delPL p rl re rr) + EQ -> chkRP l e (subP rl rr) + GT -> chkRP l e (delPR p rl re rr) +----------------------------------------------------------------------- +----------------------- deletePath Ends Here -------------------------- +----------------------------------------------------------------------- + + + +------------------------------------------------------------------------------------- +-- This is a modified version of popL which returns the (popped) tree height as well. +------------------------------------------------------------------------------------- +popHL :: AVL e -> UBT3(e,AVL e,UINT) +popHL E = error "popHL: Empty tree." +popHL (N l e r) = popHLN l e r +popHL (Z l e r) = popHLZ l e r +popHL (P l e r) = popHLP l e r + +popHLN :: AVL e -> e -> AVL e -> UBT3(e,AVL e,UINT) +popHLN l e r = case popHLN_ L(2) l e r of + UBT3(e_,t,h) -> case t of + E -> error "popHLN: Bug0" -- impossible + Z _ _ _ -> UBT3(e_,t,DECINT1(h)) -- dH = -1 + _ -> UBT3(e_,t, h ) -- dH = 0 + +popHLZ :: AVL e -> e -> AVL e -> UBT3(e,AVL e,UINT) +popHLZ l e r = case popHLZ_ L(1) l e r of + UBT3(e_,t,h) -> case t of + E -> UBT3(e,E,L(0)) -- Resulting tree is empty + P _ _ _ -> error "popHLZ: Bug0" -- impossible + _ -> UBT3(e_,t, h ) -- dH = 0 + +popHLP :: AVL e -> e -> AVL e -> UBT3(e,AVL e,UINT) +popHLP l e r = case popHLP_ L(1) l e r of + UBT3(e_,t,h) -> case t of + Z _ _ _ -> UBT3(e_,t,DECINT1(h)) -- dH = -1 + P _ _ _ -> UBT3(e_,t, h ) -- dH = 0 + _ -> error "popHLP: Bug0" -- impossible + +-------------------------- popHL LEVEL 1 ------------------------------ +-- popHLN_, popHLZ_, popHLP_ -- +----------------------------------------------------------------------- +-- Delete leftmost from (N l e r) +popHLN_ :: UINT -> AVL e -> e -> AVL e -> UBT3(e,AVL e,UINT) +popHLN_ h E e r = UBT3(e,r,h) -- Terminal case, r must be of form (Z E re E) +popHLN_ h (N ll le lr) e r = case popHLN_ INCINT2(h) ll le lr of + UBT3(e_,l,hl) -> let t = chkLN l e r in t `seq` UBT3(e_,t,hl) +popHLN_ h (Z ll le lr) e r = popHLNZ INCINT1(h) ll le lr e r +popHLN_ h (P ll le lr) e r = case popHLP_ INCINT1(h) ll le lr of + UBT3(e_,l,hl) -> let t = chkLN l e r in t `seq` UBT3(e_,t,hl) + +-- Delete leftmost from (Z l e r) +{-# INLINE popHLZ_ #-} +popHLZ_ :: UINT -> AVL e -> e -> AVL e -> UBT3(e,AVL e,UINT) +popHLZ_ h E e _ = UBT3(e,E,h) -- Terminal case, r must be E +popHLZ_ h (N ll le lr) e r = popHLZN INCINT2(h) ll le lr e r +popHLZ_ h (Z ll le lr) e r = popHLZZ INCINT1(h) ll le lr e r +popHLZ_ h (P ll le lr) e r = popHLZP INCINT1(h) ll le lr e r + +-- Delete leftmost from (P l e r) +popHLP_ :: UINT -> AVL e -> e -> AVL e -> UBT3(e,AVL e,UINT) +popHLP_ _ E _ _ = error "popHLP_: Bug0" -- Impossible if BF=+1 +popHLP_ h (N ll le lr) e r = case popHLN_ INCINT2(h) ll le lr of + UBT3(e_,l,hl) -> let t = chkLP l e r in t `seq` UBT3(e_,t,hl) +popHLP_ h (Z ll le lr) e r = popHLPZ INCINT1(h) ll le lr e r +popHLP_ h (P ll le lr) e r = case popHLP_ INCINT1(h) ll le lr of + UBT3(e_,l,hl) -> let t = chkLP l e r in t `seq` UBT3(e_,t,hl) + +-------------------------- popHL LEVEL 2 ------------------------------ +-- popHLNZ, popHLZZ, popHLPZ -- +-- popHLZN, popHLZP -- +----------------------------------------------------------------------- + +-- Delete leftmost from (N (Z ll le lr) e r), height of left sub-tree can't change in this case +{-# INLINE popHLNZ #-} +popHLNZ :: UINT -> AVL e -> e -> AVL e -> e -> AVL e -> UBT3(e,AVL e,UINT) +popHLNZ h E le _ e r = let t = rebalN E e r -- Terminal case, Needs rebalancing + in t `seq` UBT3(le,t,h) +popHLNZ h (N lll lle llr) le lr e r = case popHLZN INCINT2(h) lll lle llr le lr of + UBT3(e_,l,hl) -> UBT3(e_, N l e r, hl) +popHLNZ h (Z lll lle llr) le lr e r = case popHLZZ INCINT1(h) lll lle llr le lr of + UBT3(e_,l,hl) -> UBT3(e_, N l e r, hl) +popHLNZ h (P lll lle llr) le lr e r = case popHLZP INCINT1(h) lll lle llr le lr of + UBT3(e_,l,hl) -> UBT3(e_, N l e r, hl) + +-- Delete leftmost from (Z (Z ll le lr) e r), height of left sub-tree can't change in this case +-- Don't INLINE this! +popHLZZ :: UINT -> AVL e -> e -> AVL e -> e -> AVL e -> UBT3(e,AVL e,UINT) +popHLZZ h E le _ e r = UBT3(le, N E e r, h) -- Terminal case +popHLZZ h (N lll lle llr) le lr e r = case popHLZN INCINT2(h) lll lle llr le lr of + UBT3(e_,l,hl) -> UBT3(e_, Z l e r, hl) +popHLZZ h (Z lll lle llr) le lr e r = case popHLZZ INCINT1(h) lll lle llr le lr of + UBT3(e_,l,hl) -> UBT3(e_, Z l e r, hl) +popHLZZ h (P lll lle llr) le lr e r = case popHLZP INCINT1(h) lll lle llr le lr of + UBT3(e_,l,hl) -> UBT3(e_, Z l e r, hl) + +-- Delete leftmost from (P (Z ll le lr) e r), height of left sub-tree can't change in this case +{-# INLINE popHLPZ #-} +popHLPZ :: UINT -> AVL e -> e -> AVL e -> e -> AVL e -> UBT3(e,AVL e,UINT) +popHLPZ h E le _ e _ = UBT3(le, Z E e E, h) -- Terminal case +popHLPZ h (N lll lle llr) le lr e r = case popHLZN INCINT2(h) lll lle llr le lr of + UBT3(e_,l,hl) -> UBT3(e_, P l e r, hl) +popHLPZ h (Z lll lle llr) le lr e r = case popHLZZ INCINT1(h) lll lle llr le lr of + UBT3(e_,l,hl) -> UBT3(e_, P l e r, hl) +popHLPZ h (P lll lle llr) le lr e r = case popHLZP INCINT1(h) lll lle llr le lr of + UBT3(e_,l,hl) -> UBT3(e_, P l e r, hl) + +-- Delete leftmost from (Z (N ll le lr) e r) +-- Don't INLINE this! +popHLZN :: UINT -> AVL e -> e -> AVL e -> e -> AVL e -> UBT3(e,AVL e,UINT) +popHLZN h ll le lr e r = case popHLN_ h ll le lr of + UBT3(e_,l,hl) -> let t = chkLZ l e r in t `seq` UBT3(e_,t,hl) +-- Delete leftmost from (Z (P ll le lr) e r) +-- Don't INLINE this! +popHLZP :: UINT -> AVL e -> e -> AVL e -> e -> AVL e -> UBT3(e,AVL e,UINT) +popHLZP h ll le lr e r = case popHLP_ h ll le lr of + UBT3(e_,l,hl) -> let t = chkLZ l e r in t `seq` UBT3(e_,t,hl) +----------------------------------------------------------------------- +------------------------- popHL Ends Here ----------------------------- +----------------------------------------------------------------------- + +{-************************** Balancing Utilities Below Here ************************************-} + +-- Rebalance a tree of form (N l e r) which has become unbalanced as +-- a result of the height of the left sub-tree (l) decreasing by 1. +-- N.B Result is never of form (N _ _ _) (or E!) +rebalN :: AVL e -> e -> AVL e -> AVL e +rebalN _ _ E = error "rebalN: Bug0" -- impossible case +rebalN l e (N rl re rr) = Z (Z l e rl) re rr -- N->Z, dH=-1 +rebalN l e (Z rl re rr) = P (N l e rl) re rr -- N->P, dH= 0 +rebalN _ _ (P E _ _) = error "rebalN: Bug1" -- impossible case +rebalN l e (P (N rll rle rlr) re rr) = Z (P l e rll) rle (Z rlr re rr) -- N->Z, dH=-1 +rebalN l e (P (Z rll rle rlr) re rr) = Z (Z l e rll) rle (Z rlr re rr) -- N->Z, dH=-1 +rebalN l e (P (P rll rle rlr) re rr) = Z (Z l e rll) rle (N rlr re rr) -- N->Z, dH=-1 + +-- Rebalance a tree of form (P l e r) which has become unbalanced as +-- a result of the height of the right sub-tree (r) decreasing by 1. +-- N.B Result is never of form (P _ _ _) (or E!) +rebalP :: AVL e -> e -> AVL e -> AVL e +rebalP E _ _ = error "rebalP: Bug0" -- impossible case +rebalP (P ll le lr ) e r = Z ll le (Z lr e r) -- P->Z, dH=-1 +rebalP (Z ll le lr ) e r = N ll le (P lr e r) -- P->N, dH= 0 +rebalP (N _ _ E ) _ _ = error "rebalP: Bug1" -- impossible case +rebalP (N ll le (P lrl lre lrr)) e r = Z (Z ll le lrl) lre (N lrr e r) -- P->Z, dH=-1 +rebalP (N ll le (Z lrl lre lrr)) e r = Z (Z ll le lrl) lre (Z lrr e r) -- P->Z, dH=-1 +rebalP (N ll le (N lrl lre lrr)) e r = Z (P ll le lrl) lre (Z lrr e r) -- P->Z, dH=-1 + +-- Check for height changes in left subtree of (N l e r), +-- where l was (N ll le lr) or (P ll le lr) +chkLN :: AVL e -> e -> AVL e -> AVL e +chkLN l e r = case l of + E -> error "chkLN: Bug0" -- impossible if BF<>0 + N _ _ _ -> N l e r -- BF +/-1 -> -1, so dH= 0 + Z _ _ _ -> rebalN l e r -- BF +/-1 -> 0, so dH=-1 + P _ _ _ -> N l e r -- BF +/-1 -> +1, so dH= 0 +-- Check for height changes in left subtree of (Z l e r), +-- where l was (N ll le lr) or (P ll le lr) +chkLZ :: AVL e -> e -> AVL e -> AVL e +chkLZ l e r = case l of + E -> error "chkLZ: Bug0" -- impossible if BF<>0 + N _ _ _ -> Z l e r -- BF +/-1 -> -1, so dH= 0 + Z _ _ _ -> N l e r -- BF +/-1 -> 0, so dH=-1 + P _ _ _ -> Z l e r -- BF +/-1 -> +1, so dH= 0 +-- Check for height changes in left subtree of (P l e r), +-- where l was (N ll le lr) or (P ll le lr) +chkLP :: AVL e -> e -> AVL e -> AVL e +chkLP l e r = case l of + E -> error "chkLP: Bug0" -- impossible if BF<>0 + N _ _ _ -> P l e r -- BF +/-1 -> -1, so dH= 0 + Z _ _ _ -> Z l e r -- BF +/-1 -> 0, so dH=-1 + P _ _ _ -> P l e r -- BF +/-1 -> +1, so dH= 0 +-- Check for height changes in right subtree of (N l e r), +-- where r was (N rl re rr) or (P rl re rr) +chkRN :: AVL e -> e -> AVL e -> AVL e +chkRN l e r = case r of + E -> error "chkRN: Bug0" -- impossible if BF<>0 + N _ _ _ -> N l e r -- BF +/-1 -> -1, so dH= 0 + Z _ _ _ -> Z l e r -- BF +/-1 -> 0, so dH=-1 + P _ _ _ -> N l e r -- BF +/-1 -> +1, so dH= 0 +-- Check for height changes in right subtree of (Z l e r), +-- where r was (N rl re rr) or (P rl re rr) +chkRZ :: AVL e -> e -> AVL e -> AVL e +chkRZ l e r = case r of + E -> error "chkRZ: Bug0" -- impossible if BF<>0 + N _ _ _ -> Z l e r -- BF +/-1 -> -1, so dH= 0 + Z _ _ _ -> P l e r -- BF +/-1 -> 0, so dH=-1 + P _ _ _ -> Z l e r -- BF +/-1 -> +1, so dH= 0 +-- Check for height changes in right subtree of (P l e r), +-- where l was (N rl re rr) or (P rl re rr) +chkRP :: AVL e -> e -> AVL e -> AVL e +chkRP l e r = case r of + E -> error "chkRP: Bug0" -- impossible if BF<>0 + N _ _ _ -> P l e r -- BF +/-1 -> -1, so dH= 0 + Z _ _ _ -> rebalP l e r -- BF +/-1 -> 0, so dH=-1 + P _ _ _ -> P l e r -- BF +/-1 -> +1, so dH= 0 + +-- Substitute deleted element from (N l _ r) +subN :: AVL e -> AVL e -> AVL e +subN _ E = error "subN: Bug0" -- Impossible +subN l (N rl re rr) = case popLN rl re rr of UBT2(e,r_) -> chkRN l e r_ +subN l (Z rl re rr) = case popLZ rl re rr of UBT2(e,r_) -> chkRN' l e r_ +subN l (P rl re rr) = case popLP rl re rr of UBT2(e,r_) -> chkRN l e r_ + +-- Substitute deleted element from (Z l _ r) +-- Pops the replacement from the right sub-tree, so result may be (P _ _ _) +subZR :: AVL e -> AVL e -> AVL e +subZR _ E = E -- Both left and right subtrees must have been empty +subZR l (N rl re rr) = case popLN rl re rr of UBT2(e,r_) -> chkRZ l e r_ +subZR l (Z rl re rr) = case popLZ rl re rr of UBT2(e,r_) -> chkRZ' l e r_ +subZR l (P rl re rr) = case popLP rl re rr of UBT2(e,r_) -> chkRZ l e r_ + +-- Local utility to substitute deleted element from (Z l _ r) +-- Pops the replacement from the left sub-tree, so result may be (N _ _ _) +subZL :: AVL e -> AVL e -> AVL e +subZL E _ = E -- Both left and right subtrees must have been empty +subZL (N ll le lr) r = case popRN ll le lr of UBT2(l_,e) -> chkLZ l_ e r +subZL (Z ll le lr) r = case popRZ ll le lr of UBT2(l_,e) -> chkLZ' l_ e r +subZL (P ll le lr) r = case popRP ll le lr of UBT2(l_,e) -> chkLZ l_ e r + +-- Substitute deleted element from (P l _ r) +subP :: AVL e -> AVL e -> AVL e +subP E _ = error "subP: Bug0" -- Impossible +subP (N ll le lr) r = case popRN ll le lr of UBT2(l_,e) -> chkLP l_ e r +subP (Z ll le lr) r = case popRZ ll le lr of UBT2(l_,e) -> chkLP' l_ e r +subP (P ll le lr) r = case popRP ll le lr of UBT2(l_,e) -> chkLP l_ e r + +-- Check for height changes in left subtree of (N l e r), +-- where l was (Z ll le lr) +chkLN' :: AVL e -> e -> AVL e -> AVL e +chkLN' l e r = case l of + E -> rebalN l e r -- BF 0 -> E, so dH=-1 + _ -> N l e r -- Otherwise dH=0 +-- Check for height changes in left subtree of (Z l e r), +-- where l was (Z ll le lr) +chkLZ' :: AVL e -> e -> AVL e -> AVL e +chkLZ' l e r = case l of + E -> N l e r -- BF 0 -> E, so dH=-1 + _ -> Z l e r -- Otherwise dH=0 +-- Check for height changes in left subtree of (P l e r), +-- where l was (Z ll le lr) +chkLP' :: AVL e -> e -> AVL e -> AVL e +chkLP' l e r = case l of + E -> Z l e r -- BF 0 -> E, so dH=-1 + _ -> P l e r -- Otherwise dH=0 +-- Check for height changes in right subtree of (N l e r), +-- where r was (Z rl re rr) +chkRN' :: AVL e -> e -> AVL e -> AVL e +chkRN' l e r = case r of + E -> Z l e r -- BF 0 -> E, so dH=-1 + _ -> N l e r -- Otherwise dH=0 +-- Check for height changes in right subtree of (Z l e r), +-- where r was (Z rl re rr) +chkRZ' :: AVL e -> e -> AVL e -> AVL e +chkRZ' l e r = case r of + E -> P l e r -- BF 0 -> E, so dH=-1 + _ -> Z l e r -- Otherwise dH=0 +-- Check for height changes in right subtree of (P l e r), +-- where l was (Z rl re rr) +chkRP' :: AVL e -> e -> AVL e -> AVL e +chkRP' l e r = case r of + E -> rebalP l e r -- BF 0 -> E, so dH=-1 + _ -> P l e r -- Otherwise dH=0 + diff --git a/Data/Tree/AVL/Internals/HAVL.hs b/Data/Tree/AVL/Internals/HAVL.hs new file mode 100644 --- /dev/null +++ b/Data/Tree/AVL/Internals/HAVL.hs @@ -0,0 +1,98 @@ +{-# OPTIONS_GHC -fglasgow-exts #-} +----------------------------------------------------------------------------- +-- | +-- Module : Data.Tree.AVL.Internals.HAVL +-- Copyright : (c) Adrian Hey 2004,2005 +-- License : BSD3 +-- +-- Maintainer : http://homepages.nildram.co.uk/~ahey/em.png +-- Stability : stable +-- Portability : portable +-- +-- HAVL data type and related utilities +----------------------------------------------------------------------------- +module Data.Tree.AVL.Internals.HAVL + ( + HAVL(HAVL),emptyHAVL,toHAVL,isEmptyHAVL,isNonEmptyHAVL, + spliceHAVL,joinHAVL, + pushLHAVL,pushRHAVL + ) where + +import Data.Tree.AVL.Types(AVL(..)) +import Data.Tree.AVL.Internals.HeightUtils(addHeight) +import Data.Tree.AVL.Internals.HJoin(spliceH,joinH) +import Data.Tree.AVL.Internals.HPush(pushHL,pushHR) + +#ifdef __GLASGOW_HASKELL__ +import GHC.Base +#include "ghcdefs.h" +#else +#include "h98defs.h" +#endif + +-- | An HAVL represents an AVL tree of known height. +data HAVL e = HAVL (AVL e) {-# UNPACK #-} !UINT + +-- | Empty HAVL (height is 0). +emptyHAVL :: HAVL e +emptyHAVL = HAVL E L(0) + +-- | Returns 'True' if the AVL component of an HAVL tree is empty. Note that height component +-- is ignored, so it's OK to use this function in cases where the height is relative. +-- +-- Complexity: O(1) +{-# INLINE isEmptyHAVL #-} +isEmptyHAVL :: HAVL e -> Bool +isEmptyHAVL (HAVL E _) = True +isEmptyHAVL (HAVL _ _) = False + +-- | Returns 'True' if the AVL component of an HAVL tree is non-empty. Note that height component +-- is ignored, so it's OK to use this function in cases where the height is relative. +-- +-- Complexity: O(1) +{-# INLINE isNonEmptyHAVL #-} +isNonEmptyHAVL :: HAVL e -> Bool +isNonEmptyHAVL (HAVL E _) = False +isNonEmptyHAVL (HAVL _ _) = True + +-- | Converts an AVL to HAVL +toHAVL :: AVL e -> HAVL e +toHAVL t = HAVL t (addHeight L(0) t) + +-- | Splice two HAVL trees using the supplied bridging element. +-- That is, the bridging element appears "in the middle" of the resulting HAVL tree. +-- The elements of the first tree argument are to the left of the bridging element and +-- the elements of the second tree are to the right of the bridging element. +-- +-- This function does not require that the AVL heights are absolutely correct, only that +-- the difference in supplied heights is equal to the difference in actual heights. So it's +-- OK if the input heights both have the same unknown constant offset. (The output height +-- will also have the same constant offset in this case.) +-- +-- Complexity: O(d), where d is the absolute difference in tree heights. +{-# INLINE spliceHAVL #-} +spliceHAVL :: HAVL e -> e -> HAVL e -> HAVL e +spliceHAVL (HAVL l hl) e (HAVL r hr) = case spliceH l hl e r hr of UBT2(t,ht) -> HAVL t ht + +-- | Join two HAVL trees. +-- It's OK if heights are relative (I.E. if they share same fixed offset). +-- +-- Complexity: O(d), where d is the absolute difference in tree heights. +{-# INLINE joinHAVL #-} +joinHAVL :: HAVL e -> HAVL e -> HAVL e +joinHAVL (HAVL l hl) (HAVL r hr) = case joinH l hl r hr of UBT2(t,ht) -> HAVL t ht + +-- | A version of 'pushL' for HAVL trees. +-- It's OK if height is relative, with fixed offset. In this case the height of the result +-- will have the same fixed offset. +{-# INLINE pushLHAVL #-} +pushLHAVL :: e -> HAVL e -> HAVL e +pushLHAVL e (HAVL t ht) = case pushHL e t ht of UBT2(t_,ht_) -> HAVL t_ ht_ + +-- | A version of 'pushR' for HAVL trees. +-- It's OK if height is relative, with fixed offset. In this case the height of the result +-- will have the same fixed offset. +{-# INLINE pushRHAVL #-} +pushRHAVL :: HAVL e -> e -> HAVL e +pushRHAVL (HAVL t ht) e = case pushHR t ht e of UBT2(t_,ht_) -> HAVL t_ ht_ + diff --git a/Data/Tree/AVL/Internals/HJoin.hs b/Data/Tree/AVL/Internals/HJoin.hs new file mode 100644 --- /dev/null +++ b/Data/Tree/AVL/Internals/HJoin.hs @@ -0,0 +1,329 @@ +{-# OPTIONS_GHC -fglasgow-exts #-} +----------------------------------------------------------------------------- +-- | +-- Module : Data.Tree.AVL.Internals.HJoin +-- Copyright : (c) Adrian Hey 2004,2005 +-- License : BSD3 +-- +-- Maintainer : http://homepages.nildram.co.uk/~ahey/em.png +-- Stability : stable +-- Portability : portable +-- +-- Functions for joining AVL trees of known height. +----------------------------------------------------------------------------- +module Data.Tree.AVL.Internals.HJoin + ( spliceH,joinH,joinH', + ) where + +import Data.Tree.AVL.Types(AVL(..)) +import Data.Tree.AVL.Push(pushL,pushR) +import Data.Tree.AVL.Internals.HPush(pushHL_,pushHR_) +import Data.Tree.AVL.Internals.DelUtils(popRN,popRZ,popRP,popLN,popLZ,popLP) + +#if __GLASGOW_HASKELL__ +import GHC.Base +#include "ghcdefs.h" +#else +#include "h98defs.h" +#endif + +-- | Join two trees of known height, returning an AVL tree. +-- It's OK if heights are relative (I.E. if they share same fixed offset). +-- +-- Complexity: O(d), where d is the absolute difference in tree heights. +joinH' + :: AVL e -> UINT -> AVL e -> UINT -> AVL e +joinH' l hl r hr + = if hl LEQ hr then let d = SUBINT(hr,hl) in joinHL d l r + else let d = SUBINT(hl,hr) in joinHR d l r + +-- hr >= hl, join l to left subtree of r. +-- Int argument is absolute difference in tree height, hr-hl (>=0) +{-# INLINE joinHL #-} +joinHL :: UINT -> AVL e -> AVL e -> AVL e +joinHL _ E r = r -- l was empty +joinHL d (N ll le lr) r = case popRN ll le lr of + UBT2(l_,e) -> case l_ of + E -> error "joinHL: Bug0" -- impossible if BF=-1 + Z _ _ _ -> spliceL l_ e INCINT1(d) r -- hl2=hl-1 + _ -> spliceL l_ e d r -- hl2=hl +joinHL d (Z ll le lr) r = case popRZ ll le lr of + UBT2(l_,e) -> case l_ of + E -> e `pushL` r -- l had only one element + _ -> spliceL l_ e d r -- hl2=hl +joinHL d (P ll le lr) r = case popRP ll le lr of + UBT2(l_,e) -> case l_ of + E -> error "joinHL: Bug1" -- impossible if BF=+1 + Z _ _ _ -> spliceL l_ e INCINT1(d) r -- hl2=hl-1 + _ -> spliceL l_ e d r -- hl2=hl + + +-- hl >= hr, join r to right subtree of l. +-- Int argument is absolute difference in tree height, hl-hr (>=0) +{-# INLINE joinHR #-} +joinHR :: UINT -> AVL e -> AVL e -> AVL e +joinHR _ l E = l -- r was empty +joinHR d l (N rl re rr) = case popLN rl re rr of + UBT2(e,r_) -> case r_ of + E -> error "joinHR: Bug0" -- impossible if BF=-1 + Z _ _ _ -> spliceR r_ e INCINT1(d) l -- hr2=hr-1 + _ -> spliceR r_ e d l -- hr2=hr +joinHR d l (Z rl re rr) = case popLZ rl re rr of + UBT2(e,r_) -> case r_ of + E -> l `pushR` e -- r had only one element + _ -> spliceR r_ e d l -- hr2=hr +joinHR d l (P rl re rr) = case popLP rl re rr of + UBT2(e,r_) -> case r_ of + E -> error "joinHL: Bug1" -- impossible if BF=+1 + Z _ _ _ -> spliceR r_ e INCINT1(d) l -- hr2=hr-1 + _ -> spliceR r_ e d l -- hr2=hr +----------------------------------------------------------------------- +--------------------------- joinH' Ends Here -------------------------- +----------------------------------------------------------------------- + +-- | Join two AVL trees of known height, returning an AVL tree of known height. +-- It's OK if heights are relative (I.E. if they share same fixed offset). +-- +-- Complexity: O(d), where d is the absolute difference in tree heights. +joinH :: AVL e -> UINT -> AVL e -> UINT -> UBT2(AVL e,UINT) +joinH l hl r hr = + case COMPAREUINT hl hr of + -- hr > hl + LT -> case l of + E -> UBT2(r,hr) + N ll le lr -> case popRN ll le lr of + UBT2(l_,e) -> case l_ of + Z _ _ _ -> spliceHL l_ DECINT1(hl) e r hr -- dH=-1 + _ -> spliceHL l_ hl e r hr -- dH= 0 + Z ll le lr -> case popRZ ll le lr of + UBT2(l_,e) -> case l_ of + E -> pushHL_ l r hr -- l had only 1 element + _ -> spliceHL l_ hl e r hr -- dH=0 + P ll le lr -> case popRP ll le lr of + UBT2(l_,e) -> case l_ of + Z _ _ _ -> spliceHL l_ DECINT1(hl) e r hr -- dH=-1 + _ -> spliceHL l_ hl e r hr -- dH= 0 + -- hr = hl + EQ -> case l of + E -> UBT2(l,hl) -- r must be empty too, don't use emptyAVL! + N ll le lr -> case popRN ll le lr of + UBT2(l_,e) -> case l_ of + Z _ _ _ -> spliceHL l_ DECINT1(hl) e r hr -- dH=-1 + _ -> UBT2(Z l_ e r, INCINT1(hr)) -- dH= 0 + Z ll le lr -> case popRZ ll le lr of + UBT2(l_,e) -> case l_ of + E -> pushHL_ l r hr -- l had only 1 element + _ -> UBT2(Z l_ e r, INCINT1(hr)) -- dH= 0 + P ll le lr -> case popRP ll le lr of + UBT2(l_,e) -> case l_ of + Z _ _ _ -> spliceHL l_ DECINT1(hl) e r hr -- dH=-1 + _ -> UBT2(Z l_ e r, INCINT1(hr)) -- dH= 0 + -- hl > hr + GT -> case r of + E -> UBT2(l,hl) + N rl re rr -> case popLN rl re rr of + UBT2(e,r_) -> case r_ of + Z _ _ _ -> spliceHR l hl e r_ DECINT1(hr) -- dH=-1 + _ -> spliceHR l hl e r_ hr -- dH= 0 + Z rl re rr -> case popLZ rl re rr of + UBT2(e,r_) -> case r_ of + E -> pushHR_ l hl r -- r had only 1 element + _ -> spliceHR l hl e r_ hr -- dH=0 + P rl re rr -> case popLP rl re rr of + UBT2(e,r_) -> case r_ of + Z _ _ _ -> spliceHR l hl e r_ DECINT1(hr) -- dH=-1 + _ -> spliceHR l hl e r_ hr -- dH= 0 + + +-- | Splice two AVL trees of known height using the supplied bridging element. +-- That is, the bridging element appears \"in the middle\" of the resulting AVL tree. +-- The elements of the first tree argument are to the left of the bridging element and +-- the elements of the second tree are to the right of the bridging element. +-- +-- This function does not require that the AVL heights are absolutely correct, only that +-- the difference in supplied heights is equal to the difference in actual heights. So it's +-- OK if the input heights both have the same unknown constant offset. (The output height +-- will also have the same constant offset in this case.) +-- +-- Complexity: O(d), where d is the absolute difference in tree heights. +spliceH :: AVL e -> UINT -> e -> AVL e -> UINT -> UBT2(AVL e,UINT) +-- You'd think inlining this function would make a significant difference to many functions +-- (such as set operations), but it doesn't. It makes them marginally slower!! +spliceH l hl b r hr = + case COMPAREUINT hl hr of + LT -> spliceHL l hl b r hr + EQ -> UBT2(Z l b r, INCINT1(hl)) + GT -> spliceHR l hl b r hr + +-- Splice two trees of known relative height where hr>hl, using the supplied bridging element, +-- returning another tree of known relative height. +spliceHL :: AVL e -> UINT -> e -> AVL e -> UINT -> UBT2(AVL e,UINT) +spliceHL l hl b r hr = let d = SUBINT(hr,hl) + in if d EQL L(1) then UBT2(N l b r, INCINT1(hr)) + else spliceHL_ hr d l b r + +-- Splice two trees of known relative height where hl>hr, using the supplied bridging element, +-- returning another tree of known relative height. +spliceHR :: AVL e -> UINT -> e -> AVL e -> UINT -> UBT2(AVL e,UINT) +spliceHR l hl b r hr = let d = SUBINT(hl,hr) + in if d EQL L(1) then UBT2(P l b r, INCINT1(hl)) + else spliceHR_ hl d l b r + +-- Splice two trees of known relative height where hr>hl+1, using the supplied bridging element, +-- returning another tree of known relative height. d >= 2 +{-# INLINE spliceHL_ #-} +spliceHL_ :: UINT -> UINT -> AVL e -> e -> AVL e -> UBT2(AVL e,UINT) +spliceHL_ _ _ _ _ E = error "spliceHL_: Bug0" -- impossible if hr>hl +spliceHL_ hr d l b (N rl re rr) = let r_ = spliceLN l b DECINT2(d) rl re rr + in r_ `seq` UBT2(r_,hr) +spliceHL_ hr d l b (Z rl re rr) = let r_ = spliceLZ l b DECINT1(d) rl re rr + in case r_ of + E -> error "spliceHL_: Bug1" + Z _ _ _ -> UBT2(r_, hr ) + _ -> UBT2(r_,INCINT1(hr)) +spliceHL_ hr d l b (P rl re rr) = let r_ = spliceLP l b DECINT1(d) rl re rr + in r_ `seq` UBT2(r_,hr) + +-- Splice two trees of known relative height where hl>hr+1, using the supplied bridging element, +-- returning another tree of known relative height. d >= 2 !! +{-# INLINE spliceHR_ #-} +spliceHR_ :: UINT -> UINT -> AVL e -> e -> AVL e -> UBT2(AVL e,UINT) +spliceHR_ _ _ E _ _ = error "spliceHR_: Bug0" -- impossible if hl>hr +spliceHR_ hl d (N ll le lr) b r = let l_ = spliceRN r b DECINT1(d) ll le lr + in l_ `seq` UBT2(l_,hl) +spliceHR_ hl d (Z ll le lr) b r = let l_ = spliceRZ r b DECINT1(d) ll le lr + in case l_ of + E -> error "spliceHR_: Bug1" + Z _ _ _ -> UBT2(l_, hl ) + _ -> UBT2(l_,INCINT1(hl)) +spliceHR_ hl d (P ll le lr) b r = let l_ = spliceRP r b DECINT2(d) ll le lr + in l_ `seq` UBT2(l_,hl) +----------------------------------------------------------------------- +-------------------------- spliceH Ends Here -------------------------- +----------------------------------------------------------------------- + +-- hr >= hl, splice s to left subtree of r, using b as the bridge +-- The Int argument is the absolute difference in tree height, hr-hl (>=0) +spliceL :: AVL e -> e -> UINT -> AVL e -> AVL e +spliceL s b L(0) r = Z s b r +spliceL s b L(1) r = N s b r +spliceL s b d (N rl re rr) = spliceLN s b DECINT2(d) rl re rr -- height diff of rl is two less +spliceL s b d (Z rl re rr) = spliceLZ s b DECINT1(d) rl re rr -- height diff of rl is one less +spliceL s b d (P rl re rr) = spliceLP s b DECINT1(d) rl re rr -- height diff of rl is one less +spliceL _ _ _ E = error "spliceL: Bug0" -- r can't be empty + +-- Splice into left subtree of (N l e r), height cannot change as a result of this +spliceLN :: AVL e -> e -> UINT -> AVL e -> e -> AVL e -> AVL e +spliceLN s b L(0) l e r = Z (Z s b l) e r -- dH=0 +spliceLN s b L(1) l e r = Z (N s b l) e r -- dH=0 +spliceLN s b d (N ll le lr) e r = let l_ = spliceLN s b DECINT2(d) ll le lr in l_ `seq` N l_ e r +spliceLN s b d (Z ll le lr) e r = let l_ = spliceLZ s b DECINT1(d) ll le lr + in case l_ of + Z _ _ _ -> N l_ e r -- dH=0 + P _ _ _ -> Z l_ e r -- dH=0 + _ -> error "spliceLN: Bug0" -- impossible +spliceLN s b d (P ll le lr) e r = let l_ = spliceLP s b DECINT1(d) ll le lr in l_ `seq` N l_ e r +spliceLN _ _ _ E _ _ = error "spliceLN: Bug1" -- impossible + +-- Splice into left subtree of (Z l e r), Z->P if dH=1, Z->Z if dH=0 +spliceLZ :: AVL e -> e -> UINT -> AVL e -> e -> AVL e -> AVL e +spliceLZ s b L(1) l e r = P (N s b l) e r -- Z->P, dH=1 +spliceLZ s b d (N ll le lr) e r = let l_ = spliceLN s b DECINT2(d) ll le lr in l_ `seq` Z l_ e r -- Z->Z, dH=0 +spliceLZ s b d (Z ll le lr) e r = let l_ = spliceLZ s b DECINT1(d) ll le lr + in case l_ of + Z _ _ _ -> Z l_ e r -- Z->Z, dH=0 + P _ _ _ -> P l_ e r -- Z->P, dH=1 + _ -> error "spliceLZ: Bug0" -- impossible +spliceLZ s b d (P ll le lr) e r = let l_ = spliceLP s b DECINT1(d) ll le lr in l_ `seq` Z l_ e r -- Z->Z, dH=0 +spliceLZ _ _ _ E _ _ = error "spliceLZ: Bug1" -- impossible + +-- Splice into left subtree of (P l e r), height cannot change as a result of this +spliceLP :: AVL e -> e -> UINT -> AVL e -> e -> AVL e -> AVL e +spliceLP s b L(1) (N ll le lr) e r = Z (P s b ll) le (Z lr e r) -- dH=0 +spliceLP s b L(1) (Z ll le lr) e r = Z (Z s b ll) le (Z lr e r) -- dH=0 +spliceLP s b L(1) (P ll le lr) e r = Z (Z s b ll) le (N lr e r) -- dH=0 +spliceLP s b d (N ll le lr) e r = let l_ = spliceLN s b DECINT2(d) ll le lr in l_ `seq` P l_ e r -- dH=0 +spliceLP s b d (Z ll le lr) e r = spliceLPZ s b DECINT1(d) ll le lr e r -- dH=0 +spliceLP s b d (P ll le lr) e r = let l_ = spliceLP s b DECINT1(d) ll le lr in l_ `seq` P l_ e r -- dH=0 +spliceLP _ _ _ E _ _ = error "spliceLP: Bug0" + +-- Splice into left subtree of (P (Z ll le lr) e r) +{-# INLINE spliceLPZ #-} +spliceLPZ :: AVL e -> e -> UINT -> AVL e -> e -> AVL e -> e -> AVL e -> AVL e +spliceLPZ s b L(1) ll le lr e r = Z (N s b ll) le (Z lr e r) -- dH=0 +spliceLPZ s b d (N lll lle llr) le lr e r = let ll_ = spliceLN s b DECINT2(d) lll lle llr -- dH=0 + in ll_ `seq` P (Z ll_ le lr) e r +spliceLPZ s b d (Z lll lle llr) le lr e r = let ll_ = spliceLZ s b DECINT1(d) lll lle llr -- dH=0 + in case ll_ of + Z _ _ _ -> P (Z ll_ le lr) e r -- dH=0 + P _ _ _ -> Z ll_ le (Z lr e r) -- dH=0 + _ -> error "spliceLPZ: Bug0" -- impossible +spliceLPZ s b d (P lll lle llr) le lr e r = let ll_ = spliceLP s b DECINT1(d) lll lle llr -- dH=0 + in ll_ `seq` P (Z ll_ le lr) e r +spliceLPZ _ _ _ E _ _ _ _ = error "spliceLPZ: Bug1" +----------------------------------------------------------------------- +-------------------------- spliceL Ends Here -------------------------- +----------------------------------------------------------------------- + +-- hl >= hr, splice s to right subtree of l, using b as the bridge +-- The Int argument is the absolute difference in tree height, hl-hr (>=0) +spliceR :: AVL e -> e -> UINT -> AVL e -> AVL e +spliceR s b L(0) l = Z l b s +spliceR s b L(1) l = P l b s +spliceR s b d (N ll le lr) = spliceRN s b DECINT1(d) ll le lr -- height diff of lr is one less +spliceR s b d (Z ll le lr) = spliceRZ s b DECINT1(d) ll le lr -- height diff of lr is one less +spliceR s b d (P ll le lr) = spliceRP s b DECINT2(d) ll le lr -- height diff of lr is two less +spliceR _ _ _ E = error "spliceR: Bug0" -- l can't be empty + +-- Splice into right subtree of (P l e r), height cannot change as a result of this +spliceRP :: AVL e -> e -> UINT -> AVL e -> e -> AVL e -> AVL e +spliceRP s b L(0) l e r = Z l e (Z r b s) -- dH=0 +spliceRP s b L(1) l e r = Z l e (P r b s) -- dH=0 +spliceRP s b d l e (N rl re rr) = let r_ = spliceRN s b DECINT1(d) rl re rr in r_ `seq` P l e r_ +spliceRP s b d l e (Z rl re rr) = let r_ = spliceRZ s b DECINT1(d) rl re rr + in case r_ of + Z _ _ _ -> P l e r_ -- dH=0 + N _ _ _ -> Z l e r_ -- dH=0 + _ -> error "spliceRP: Bug0" -- impossible +spliceRP s b d l e (P rl re rr) = let r_ = spliceRP s b DECINT2(d) rl re rr in r_ `seq` P l e r_ +spliceRP _ _ _ _ _ E = error "spliceRP: Bug1" -- impossible + +-- Splice into right subtree of (Z l e r), Z->N if dH=1, Z->Z if dH=0 +spliceRZ :: AVL e -> e -> UINT -> AVL e -> e -> AVL e -> AVL e +spliceRZ s b L(1) l e r = N l e (P r b s) -- Z->N, dH=1 +spliceRZ s b d l e (N rl re rr) = let r_ = spliceRN s b DECINT1(d) rl re rr in r_ `seq` Z l e r_ -- Z->Z, dH=0 +spliceRZ s b d l e (Z rl re rr) = let r_ = spliceRZ s b DECINT1(d) rl re rr + in case r_ of + Z _ _ _ -> Z l e r_ -- Z->Z, dH=0 + N _ _ _ -> N l e r_ -- Z->N, dH=1 + _ -> error "spliceRZ: Bug0" -- impossible +spliceRZ s b d l e (P rl re rr) = let r_ = spliceRP s b DECINT2(d) rl re rr in r_ `seq` Z l e r_ -- Z->Z, dH=0 +spliceRZ _ _ _ _ _ E = error "spliceRZ: Bug1" -- impossible + +-- Splice into right subtree of (N l e r), height cannot change as a result of this +spliceRN :: AVL e -> e -> UINT -> AVL e -> e -> AVL e -> AVL e +spliceRN s b L(1) l e (N rl re rr) = Z (P l e rl) re (Z rr b s) -- dH=0 +spliceRN s b L(1) l e (Z rl re rr) = Z (Z l e rl) re (Z rr b s) -- dH=0 +spliceRN s b L(1) l e (P rl re rr) = Z (Z l e rl) re (N rr b s) -- dH=0 +spliceRN s b d l e (N rl re rr) = let r_ = spliceRN s b DECINT1(d) rl re rr in r_ `seq` N l e r_ -- dH=0 +spliceRN s b d l e (Z rl re rr) = spliceRNZ s b DECINT1(d) l e rl re rr -- dH=0 +spliceRN s b d l e (P rl re rr) = let r_ = spliceRP s b DECINT2(d) rl re rr in r_ `seq` N l e r_ -- dH=0 +spliceRN _ _ _ _ _ E = error "spliceRN: Bug0" + +-- Splice into right subtree of (N l e (Z rl re rr)) +{-# INLINE spliceRNZ #-} +spliceRNZ :: AVL e -> e -> UINT -> AVL e -> e -> AVL e -> e -> AVL e -> AVL e +spliceRNZ s b L(1) l e rl re rr = Z (Z l e rl) re (P rr b s) -- dH=0 +spliceRNZ s b d l e rl re (N rrl rre rrr) = let rr_ = spliceRN s b DECINT1(d) rrl rre rrr + in rr_ `seq` N l e (Z rl re rr_) -- dH=0 +spliceRNZ s b d l e rl re (Z rrl rre rrr) = let rr_ = spliceRZ s b DECINT1(d) rrl rre rrr -- dH=0 + in case rr_ of + Z _ _ _ -> N l e (Z rl re rr_) -- dH=0 + N _ _ _ -> Z (Z l e rl) re rr_ -- dH=0 + _ -> error "spliceRNZ: Bug0" -- impossible +spliceRNZ s b d l e rl re (P rrl rre rrr) = let rr_ = spliceRP s b DECINT2(d) rrl rre rrr -- dH=0 + in rr_ `seq` N l e (Z rl re rr_) +spliceRNZ _ _ _ _ _ _ _ E = error "spliceRNZ: Bug1" +----------------------------------------------------------------------- +-------------------------- spliceR Ends Here -------------------------- +----------------------------------------------------------------------- diff --git a/Data/Tree/AVL/Internals/HPush.hs b/Data/Tree/AVL/Internals/HPush.hs new file mode 100644 --- /dev/null +++ b/Data/Tree/AVL/Internals/HPush.hs @@ -0,0 +1,189 @@ +{-# OPTIONS_GHC -fglasgow-exts #-} +----------------------------------------------------------------------------- +-- | +-- Module : Data.Tree.AVL.Internals.HPush +-- Copyright : (c) Adrian Hey 2004,2005 +-- License : BSD3 +-- +-- Maintainer : http://homepages.nildram.co.uk/~ahey/em.png +-- Stability : stable +-- Portability : portable +-- +-- Functions for pushing elements into trees of known height. +----------------------------------------------------------------------------- +module Data.Tree.AVL.Internals.HPush + (pushHL,pushHR,pushHL_,pushHR_, + ) where + +import Data.Tree.AVL.Types(AVL(..)) + +#ifdef __GLASGOW_HASKELL__ +import GHC.Base +#include "ghcdefs.h" +#else +#include "h98defs.h" +#endif + +-- | A version of 'pushL' for an AVL tree of known height. Returns an AVL tree of known height. +-- It's OK if height is relative, with fixed offset. In this case the height of the result +-- will have the same fixed offset. +{-# INLINE pushHL #-} +pushHL :: e -> AVL e -> UINT -> UBT2(AVL e,UINT) +pushHL e t h = pushHL_ (Z E e E) t h + +-- | A version of 'pushR' for an AVL tree of known height. Returns an AVL tree of known height. +-- It's OK if height is relative, with fixed offset. In this case the height of the result +-- will have the same fixed offset. +{-# INLINE pushHR #-} +pushHR :: AVL e -> UINT -> e -> UBT2(AVL e,UINT) +pushHR t h e = pushHR_ t h (Z E e E) + +-- | Push a singleton tree (first arg) in the leftmost position of an AVL tree of known height, +-- returning an AVL tree of known height. It's OK if height is relative, with fixed offset. +-- In this case the height of the result will have the same fixed offset. +-- +-- Complexity: O(log n) +pushHL_ :: AVL e -> AVL e -> UINT -> UBT2(AVL e,UINT) +pushHL_ t0 t h = case t of + E -> UBT2(t0, INCINT1(h)) -- Relative Heights + N l e r -> let t_ = putNL l e r in t_ `seq` UBT2(t_,h) + P l e r -> let t_ = putPL l e r in t_ `seq` UBT2(t_,h) + Z l e r -> let t_ = putZL l e r + in case t_ of + Z _ _ _ -> UBT2(t_, h ) + P _ _ _ -> UBT2(t_, INCINT1(h)) + _ -> error "pushHL_: Bug0" -- impossible + where + ----------------------------- LEVEL 2 --------------------------------- + -- putNL, putZL, putPL -- + ----------------------------------------------------------------------- + + -- (putNL l e r): Put in L subtree of (N l e r), BF=-1 (Never requires rebalancing) , (never returns P) + putNL E e r = Z t0 e r -- L subtree empty, H:0->1, parent BF:-1-> 0 + putNL (N ll le lr) e r = let l' = putNL ll le lr -- L subtree BF<>0, H:h->h, parent BF:-1->-1 + in l' `seq` N l' e r + putNL (P ll le lr) e r = let l' = putPL ll le lr -- L subtree BF<>0, H:h->h, parent BF:-1->-1 + in l' `seq` N l' e r + putNL (Z ll le lr) e r = let l' = putZL ll le lr -- L subtree BF= 0, so need to look for changes + in case l' of + Z _ _ _ -> N l' e r -- L subtree BF:0-> 0, H:h->h , parent BF:-1->-1 + P _ _ _ -> Z l' e r -- L subtree BF:0->+1, H:h->h+1, parent BF:-1-> 0 + _ -> error "pushHL_: Bug1" -- impossible + + -- (putZL l e r): Put in L subtree of (Z l e r), BF= 0 (Never requires rebalancing) , (never returns N) + putZL E e r = P t0 e r -- L subtree H:0->1, parent BF: 0->+1 + putZL (N ll le lr) e r = let l' = putNL ll le lr -- L subtree BF<>0, H:h->h, parent BF: 0-> 0 + in l' `seq` Z l' e r + putZL (P ll le lr) e r = let l' = putPL ll le lr -- L subtree BF<>0, H:h->h, parent BF: 0-> 0 + in l' `seq` Z l' e r + putZL (Z ll le lr) e r = let l' = putZL ll le lr -- L subtree BF= 0, so need to look for changes + in case l' of + Z _ _ _ -> Z l' e r -- L subtree BF: 0-> 0, H:h->h , parent BF: 0-> 0 + N _ _ _ -> error "pushHL_: Bug2" -- impossible + _ -> P l' e r -- L subtree BF: 0->+1, H:h->h+1, parent BF: 0->+1 + + -------- This case (PL) may need rebalancing if it goes to LEVEL 3 --------- + + -- (putPL l e r): Put in L subtree of (P l e r), BF=+1 , (never returns N) + putPL E _ _ = error "pushHL_: Bug3" -- impossible if BF=+1 + putPL (N ll le lr) e r = let l' = putNL ll le lr -- L subtree BF<>0, H:h->h, parent BF:+1->+1 + in l' `seq` P l' e r + putPL (P ll le lr) e r = let l' = putPL ll le lr -- L subtree BF<>0, H:h->h, parent BF:+1->+1 + in l' `seq` P l' e r + putPL (Z ll le lr) e r = putPLL ll le lr e r -- LL (never returns N) + + ----------------------------- LEVEL 3 --------------------------------- + -- putPLL -- + ----------------------------------------------------------------------- + + -- (putPLL ll le lr e r): Put in LL subtree of (P (Z ll le lr) e r) , (never returns N) + {-# INLINE putPLL #-} + putPLL E le lr e r = Z t0 le (Z lr e r) -- r and lr must also be E, special CASE LL!! + putPLL (N lll lle llr) le lr e r = let ll' = putNL lll lle llr -- LL subtree BF<>0, H:h->h, so no change + in ll' `seq` P (Z ll' le lr) e r + putPLL (P lll lle llr) le lr e r = let ll' = putPL lll lle llr -- LL subtree BF<>0, H:h->h, so no change + in ll' `seq` P (Z ll' le lr) e r + putPLL (Z lll lle llr) le lr e r = let ll' = putZL lll lle llr -- LL subtree BF= 0, so need to look for changes + in case ll' of + Z _ _ _ -> P (Z ll' le lr) e r -- LL subtree BF: 0-> 0, H:h->h, so no change + N _ _ _ -> error "pushHL_: Bug4" -- impossible + _ -> Z ll' le (Z lr e r) -- LL subtree BF: 0->+1, H:h->h+1, parent BF:-1->-2, CASE LL !! +----------------------------------------------------------------------- +-------------------------- pushHL_ Ends Here -------------------------- +----------------------------------------------------------------------- + + +-- | Push a singleton tree (third arg) in the rightmost position of an AVL tree of known height, +-- returning an AVL tree of known height. It's OK if height is relative, with fixed offset. +-- In this case the height of the result will have the same fixed offset. +-- +-- Complexity: O(log n) +pushHR_ :: AVL e -> UINT -> AVL e -> UBT2(AVL e,UINT) +pushHR_ t h t0 = case t of + E -> UBT2(t0, INCINT1(h)) -- Relative Heights + N l e r -> let t_ = putNR l e r in t_ `seq` UBT2(t_,h) + P l e r -> let t_ = putPR l e r in t_ `seq` UBT2(t_,h) + Z l e r -> let t_ = putZR l e r + in case t_ of + Z _ _ _ -> UBT2(t_, h ) + N _ _ _ -> UBT2(t_, INCINT1(h)) + _ -> error "pushHR_: Bug0" -- impossible + where + ----------------------------- LEVEL 2 --------------------------------- + -- putNR, putZR, putPR -- + ----------------------------------------------------------------------- + + -- (putZR l e r): Put in R subtree of (Z l e r), BF= 0 (Never requires rebalancing) , (never returns P) + putZR l e E = N l e t0 -- R subtree H:0->1, parent BF: 0->-1 + putZR l e (N rl re rr) = let r' = putNR rl re rr -- R subtree BF<>0, H:h->h, parent BF: 0-> 0 + in r' `seq` Z l e r' + putZR l e (P rl re rr) = let r' = putPR rl re rr -- R subtree BF<>0, H:h->h, parent BF: 0-> 0 + in r' `seq` Z l e r' + putZR l e (Z rl re rr) = let r' = putZR rl re rr -- R subtree BF= 0, so need to look for changes + in case r' of + Z _ _ _ -> Z l e r' -- R subtree BF: 0-> 0, H:h->h , parent BF: 0-> 0 + N _ _ _ -> N l e r' -- R subtree BF: 0->-1, H:h->h+1, parent BF: 0->-1 + _ -> error "pushHR_: Bug1" -- impossible + + -- (putPR l e r): Put in R subtree of (P l e r), BF=+1 (Never requires rebalancing) , (never returns N) + putPR l e E = Z l e t0 -- R subtree empty, H:0->1, parent BF:+1-> 0 + putPR l e (N rl re rr) = let r' = putNR rl re rr -- R subtree BF<>0, H:h->h, parent BF:+1->+1 + in r' `seq` P l e r' + putPR l e (P rl re rr) = let r' = putPR rl re rr -- R subtree BF<>0, H:h->h, parent BF:+1->+1 + in r' `seq` P l e r' + putPR l e (Z rl re rr) = let r' = putZR rl re rr -- R subtree BF= 0, so need to look for changes + in case r' of + Z _ _ _ -> P l e r' -- R subtree BF:0-> 0, H:h->h , parent BF:+1->+1 + N _ _ _ -> Z l e r' -- R subtree BF:0->-1, H:h->h+1, parent BF:+1-> 0 + _ -> error "pushHR_: Bug2" -- impossible + + -------- This case (NR) may need rebalancing if it goes to LEVEL 3 --------- + + -- (putNR l e r): Put in R subtree of (N l e r), BF=-1 , (never returns P) + putNR _ _ E = error "pushHR_: Bug3" -- impossible if BF=-1 + putNR l e (N rl re rr) = let r' = putNR rl re rr -- R subtree BF<>0, H:h->h, parent BF:-1->-1 + in r' `seq` N l e r' + putNR l e (P rl re rr) = let r' = putPR rl re rr -- R subtree BF<>0, H:h->h, parent BF:-1->-1 + in r' `seq` N l e r' + putNR l e (Z rl re rr) = putNRR l e rl re rr -- RR (never returns P) + + ----------------------------- LEVEL 3 --------------------------------- + -- putNRR -- + ----------------------------------------------------------------------- + + -- (putNRR l e rl re rr): Put in RR subtree of (N l e (Z rl re rr)) , (never returns P) + {-# INLINE putNRR #-} + putNRR l e rl re E = Z (Z l e rl) re t0 -- l and rl must also be E, special CASE RR!! + putNRR l e rl re (N rrl rre rrr) = let rr' = putNR rrl rre rrr -- RR subtree BF<>0, H:h->h, so no change + in rr' `seq` N l e (Z rl re rr') + putNRR l e rl re (P rrl rre rrr) = let rr' = putPR rrl rre rrr -- RR subtree BF<>0, H:h->h, so no change + in rr' `seq` N l e (Z rl re rr') + putNRR l e rl re (Z rrl rre rrr) = let rr' = putZR rrl rre rrr -- RR subtree BF= 0, so need to look for changes + in case rr' of + Z _ _ _ -> N l e (Z rl re rr') -- RR subtree BF: 0-> 0, H:h->h, so no change + N _ _ _ -> Z (Z l e rl) re rr' -- RR subtree BF: 0->-1, H:h->h+1, parent BF:-1->-2, CASE RR !! + _ -> error "pushHR_: Bug4" -- impossible +----------------------------------------------------------------------- +-------------------------- pushHR_ Ends Here -------------------------- +----------------------------------------------------------------------- + diff --git a/Data/Tree/AVL/Internals/HSet.hs b/Data/Tree/AVL/Internals/HSet.hs new file mode 100644 --- /dev/null +++ b/Data/Tree/AVL/Internals/HSet.hs @@ -0,0 +1,655 @@ +{-# OPTIONS_GHC -fglasgow-exts #-} +----------------------------------------------------------------------------- +-- | +-- Module : Data.Tree.AVL.Internals.HSet +-- Copyright : (c) Adrian Hey 2004,2005 +-- License : BSD3 +-- +-- Maintainer : http://homepages.nildram.co.uk/~ahey/em.png +-- Stability : stable +-- Portability : portable +-- +-- Set primitives on AVL trees with (height information supplied where needed). +-- All the functions in this module use essentially the same symetric \"Divide and Conquer\" algorithm. +----------------------------------------------------------------------------- +module Data.Tree.AVL.Internals.HSet + (-- * Union primitives. + unionH,unionMaybeH, + + -- * Intersection primitives. + intersectionH,intersectionMaybeH, + + -- * Difference primitives. + differenceH,differenceMaybeH,symDifferenceH, + ) where + +import Data.Tree.AVL.Types(AVL(..)) +import Data.Tree.AVL.Internals.HJoin(spliceH,joinH) + +import Data.COrdering + +#ifdef __GLASGOW_HASKELL__ +import GHC.Base +#include "ghcdefs.h" +#else +#include "h98defs.h" +#endif + +-- | Uses the supplied combining comparison to evaluate the union of two sets represented as +-- sorted AVL trees of known height. Whenever the combining comparison is applied, the first +-- comparison argument is an element of the first tree and the second comparison argument is +-- an element of the second tree. +-- +-- Complexity: Not sure, but I'd appreciate it if someone could figure it out. +-- (Faster than Hedge union from Data.Set at any rate). +unionH :: (e -> e -> COrdering e) -> AVL e -> UINT -> AVL e -> UINT -> UBT2(AVL e,UINT) +unionH c = u where + -- u :: AVL e -> UINT -> AVL e -> UINT -> UBT2(AVL e,UINT) + u E _ t1 h1 = UBT2(t1,h1) + u t0 h0 E _ = UBT2(t0,h0) + u (N l0 e0 r0) h0 (N l1 e1 r1) h1 = u_ l0 DECINT2(h0) e0 r0 DECINT1(h0) l1 DECINT2(h1) e1 r1 DECINT1(h1) + u (N l0 e0 r0) h0 (Z l1 e1 r1) h1 = u_ l0 DECINT2(h0) e0 r0 DECINT1(h0) l1 DECINT1(h1) e1 r1 DECINT1(h1) + u (N l0 e0 r0) h0 (P l1 e1 r1) h1 = u_ l0 DECINT2(h0) e0 r0 DECINT1(h0) l1 DECINT1(h1) e1 r1 DECINT2(h1) + u (Z l0 e0 r0) h0 (N l1 e1 r1) h1 = u_ l0 DECINT1(h0) e0 r0 DECINT1(h0) l1 DECINT2(h1) e1 r1 DECINT1(h1) + u (Z l0 e0 r0) h0 (Z l1 e1 r1) h1 = u_ l0 DECINT1(h0) e0 r0 DECINT1(h0) l1 DECINT1(h1) e1 r1 DECINT1(h1) + u (Z l0 e0 r0) h0 (P l1 e1 r1) h1 = u_ l0 DECINT1(h0) e0 r0 DECINT1(h0) l1 DECINT1(h1) e1 r1 DECINT2(h1) + u (P l0 e0 r0) h0 (N l1 e1 r1) h1 = u_ l0 DECINT1(h0) e0 r0 DECINT2(h0) l1 DECINT2(h1) e1 r1 DECINT1(h1) + u (P l0 e0 r0) h0 (Z l1 e1 r1) h1 = u_ l0 DECINT1(h0) e0 r0 DECINT2(h0) l1 DECINT1(h1) e1 r1 DECINT1(h1) + u (P l0 e0 r0) h0 (P l1 e1 r1) h1 = u_ l0 DECINT1(h0) e0 r0 DECINT2(h0) l1 DECINT1(h1) e1 r1 DECINT2(h1) + u_ l0 hl0 e0 r0 hr0 l1 hl1 e1 r1 hr1 = + case c e0 e1 of + -- e0 < e1, so (l0 < e0 < e1) & (e0 < e1 < r1) + Lt -> case forkR r0 hr0 e1 of + UBT5(rl0,hrl0,e1_,rr0,hrr0) -> case forkL e0 l1 hl1 of -- (e0 < rl0 < e1) & (e0 < e1 < rr0) + UBT5(ll1,hll1,e0_,lr1,hlr1) -> -- (ll1 < e0 < e1) & (e0 < lr1 < e1) + -- (l0 + ll1) < e0 < (rl0 + lr1) < e1 < (rr0 + r1) + case u l0 hl0 ll1 hll1 of + UBT2(l,hl) -> case u rl0 hrl0 lr1 hlr1 of + UBT2(m,hm) -> case u rr0 hrr0 r1 hr1 of + UBT2(r,hr) -> case spliceH m hm e1_ r hr of + UBT2(t,ht) -> spliceH l hl e0_ t ht + -- e0 = e1 + Eq e -> case u l0 hl0 l1 hl1 of + UBT2(l,hl) -> case u r0 hr0 r1 hr1 of + UBT2(r,hr) -> spliceH l hl e r hr + -- e1 < e0, so (l1 < e1 < e0) & (e1 < e0 < r0) + Gt -> case forkL e0 r1 hr1 of + UBT5(rl1,hrl1,e0_,rr1,hrr1) -> case forkR l0 hl0 e1 of -- (e1 < rl1 < e0) & (e1 < e0 < rr1) + UBT5(ll0,hll0,e1_,lr0,hlr0) -> -- (ll0 < e1 < e0) & (e1 < lr0 < e0) + -- (ll0 + l1) < e1 < (lr0 + rl1) < e0 < (r0 + rr1) + case u ll0 hll0 l1 hl1 of + UBT2(l,hl) -> case u lr0 hlr0 rl1 hrl1 of + UBT2(m,hm) -> case u r0 hr0 rr1 hrr1 of + UBT2(r,hr) -> case spliceH l hl e1_ m hm of + UBT2(t,ht) -> spliceH t ht e0_ r hr + -- We need 2 different versions of fork (L & R) to ensure that comparison arguments are used in + -- the right order (c e0 e1) + -- forkL :: e -> AVL e -> UINT -> UBT5(AVL e,UINT,e,AVL e,UINT) + forkL e0 t1 ht1 = forkL_ t1 ht1 where + forkL_ E _ = UBT5(E, L(0), e0, E, L(0)) + forkL_ (N l e r) h = forkL__ l DECINT2(h) e r DECINT1(h) + forkL_ (Z l e r) h = forkL__ l DECINT1(h) e r DECINT1(h) + forkL_ (P l e r) h = forkL__ l DECINT1(h) e r DECINT2(h) + forkL__ l hl e r hr = case c e0 e of + Lt -> case forkL_ l hl of + UBT5(l0,hl0,e0_,l1,hl1) -> case spliceH l1 hl1 e r hr of + UBT2(l1_,hl1_) -> UBT5(l0,hl0,e0_,l1_,hl1_) + Eq e0_ -> UBT5(l,hl,e0_,r,hr) + Gt -> case forkL_ r hr of + UBT5(l0,hl0,e0_,l1,hl1) -> case spliceH l hl e l0 hl0 of + UBT2(l0_,hl0_) -> UBT5(l0_,hl0_,e0_,l1,hl1) + -- forkR :: AVL e -> UINT -> e -> UBT5(AVL e,UINT,e,AVL e,UINT) + forkR t0 ht0 e1 = forkR_ t0 ht0 where + forkR_ E _ = UBT5(E, L(0), e1, E, L(0)) + forkR_ (N l e r) h = forkR__ l DECINT2(h) e r DECINT1(h) + forkR_ (Z l e r) h = forkR__ l DECINT1(h) e r DECINT1(h) + forkR_ (P l e r) h = forkR__ l DECINT1(h) e r DECINT2(h) + forkR__ l hl e r hr = case c e e1 of + Lt -> case forkR_ r hr of + UBT5(l0,hl0,e1_,l1,hl1) -> case spliceH l hl e l0 hl0 of + UBT2(l0_,hl0_) -> UBT5(l0_,hl0_,e1_,l1,hl1) + Eq e1_ -> UBT5(l,hl,e1_,r,hr) + Gt -> case forkR_ l hl of + UBT5(l0,hl0,e1_,l1,hl1) -> case spliceH l1 hl1 e r hr of + UBT2(l1_,hl1_) -> UBT5(l0,hl0,e1_,l1_,hl1_) +----------------------------------------------------------------------- +-------------------------- unionH Ends Here --------------------------- +----------------------------------------------------------------------- + +-- | Similar to _unionH_, but the resulting tree does not include elements in cases where +-- the supplied combining comparison returns @(Eq Nothing)@. +-- +-- Complexity: Not sure, but I_d appreciate it if someone could figure it out. +unionMaybeH :: (e -> e -> COrdering (Maybe e)) -> AVL e -> UINT -> AVL e -> UINT -> UBT2(AVL e,UINT) +unionMaybeH c = u where + -- u :: AVL e -> UINT -> AVL e -> UINT -> UBT2(AVL e,UINT) + u E _ t1 h1 = UBT2(t1,h1) + u t0 h0 E _ = UBT2(t0,h0) + u (N l0 e0 r0) h0 (N l1 e1 r1) h1 = u_ l0 DECINT2(h0) e0 r0 DECINT1(h0) l1 DECINT2(h1) e1 r1 DECINT1(h1) + u (N l0 e0 r0) h0 (Z l1 e1 r1) h1 = u_ l0 DECINT2(h0) e0 r0 DECINT1(h0) l1 DECINT1(h1) e1 r1 DECINT1(h1) + u (N l0 e0 r0) h0 (P l1 e1 r1) h1 = u_ l0 DECINT2(h0) e0 r0 DECINT1(h0) l1 DECINT1(h1) e1 r1 DECINT2(h1) + u (Z l0 e0 r0) h0 (N l1 e1 r1) h1 = u_ l0 DECINT1(h0) e0 r0 DECINT1(h0) l1 DECINT2(h1) e1 r1 DECINT1(h1) + u (Z l0 e0 r0) h0 (Z l1 e1 r1) h1 = u_ l0 DECINT1(h0) e0 r0 DECINT1(h0) l1 DECINT1(h1) e1 r1 DECINT1(h1) + u (Z l0 e0 r0) h0 (P l1 e1 r1) h1 = u_ l0 DECINT1(h0) e0 r0 DECINT1(h0) l1 DECINT1(h1) e1 r1 DECINT2(h1) + u (P l0 e0 r0) h0 (N l1 e1 r1) h1 = u_ l0 DECINT1(h0) e0 r0 DECINT2(h0) l1 DECINT2(h1) e1 r1 DECINT1(h1) + u (P l0 e0 r0) h0 (Z l1 e1 r1) h1 = u_ l0 DECINT1(h0) e0 r0 DECINT2(h0) l1 DECINT1(h1) e1 r1 DECINT1(h1) + u (P l0 e0 r0) h0 (P l1 e1 r1) h1 = u_ l0 DECINT1(h0) e0 r0 DECINT2(h0) l1 DECINT1(h1) e1 r1 DECINT2(h1) + u_ l0 hl0 e0 r0 hr0 l1 hl1 e1 r1 hr1 = + case c e0 e1 of + -- e0 < e1, so (l0 < e0 < e1) & (e0 < e1 < r1) + Lt -> case forkR r0 hr0 e1 of + UBT5(rl0,hrl0,mbe1_,rr0,hrr0) -> case forkL e0 l1 hl1 of -- (e0 < rl0 < e1) & (e0 < e1 < rr0) + UBT5(ll1,hll1,mbe0_,lr1,hlr1) -> -- (ll1 < e0 < e1) & (e0 < lr1 < e1) + -- (l0 + ll1) < e0 < (rl0 + lr1) < e1 < (rr0 + r1) + case u l0 hl0 ll1 hll1 of + UBT2(l,hl) -> case u rl0 hrl0 lr1 hlr1 of + UBT2(m,hm) -> case u rr0 hrr0 r1 hr1 of + UBT2(r,hr) -> case (case mbe1_ of + Just e1_ -> spliceH m hm e1_ r hr + Nothing -> joinH m hm r hr + ) of + UBT2(t,ht) -> case mbe0_ of + Just e0_ -> spliceH l hl e0_ t ht + Nothing -> joinH l hl t ht + -- e0 = e1 + Eq mbe -> case u l0 hl0 l1 hl1 of + UBT2(l,hl) -> case u r0 hr0 r1 hr1 of + UBT2(r,hr) -> case mbe of + Just e -> spliceH l hl e r hr + Nothing -> joinH l hl r hr + -- e1 < e0, so (l1 < e1 < e0) & (e1 < e0 < r0) + Gt -> case forkL e0 r1 hr1 of + UBT5(rl1,hrl1,mbe0_,rr1,hrr1) -> case forkR l0 hl0 e1 of -- (e1 < rl1 < e0) & (e1 < e0 < rr1) + UBT5(ll0,hll0,mbe1_,lr0,hlr0) -> -- (ll0 < e1 < e0) & (e1 < lr0 < e0) + -- (ll0 + l1) < e1 < (lr0 + rl1) < e0 < (r0 + rr1) + case u ll0 hll0 l1 hl1 of + UBT2(l,hl) -> case u lr0 hlr0 rl1 hrl1 of + UBT2(m,hm) -> case u r0 hr0 rr1 hrr1 of + UBT2(r,hr) -> case (case mbe1_ of + Just e1_ -> spliceH l hl e1_ m hm + Nothing -> joinH l hl m hm + ) of + UBT2(t,ht) -> case mbe0_ of + Just e0_ -> spliceH t ht e0_ r hr + Nothing -> joinH t ht r hr + -- We need 2 different versions of fork (L & R) to ensure that comparison arguments are used in + -- the right order (c e0 e1) + -- forkL :: e -> AVL e -> UINT -> UBT5(AVL e,UINT,Maybe e,AVL e,UINT) + forkL e0 t1 ht1 = forkL_ t1 ht1 where + forkL_ E _ = UBT5(E, L(0), Just e0, E, L(0)) + forkL_ (N l e r) h = forkL__ l DECINT2(h) e r DECINT1(h) + forkL_ (Z l e r) h = forkL__ l DECINT1(h) e r DECINT1(h) + forkL_ (P l e r) h = forkL__ l DECINT1(h) e r DECINT2(h) + forkL__ l hl e r hr = case c e0 e of + Lt -> case forkL_ l hl of + UBT5(l0,hl0,mbe0_,l1,hl1) -> case spliceH l1 hl1 e r hr of + UBT2(l1_,hl1_) -> UBT5(l0,hl0,mbe0_,l1_,hl1_) + Eq mbe0_ -> UBT5(l,hl,mbe0_,r,hr) + Gt -> case forkL_ r hr of + UBT5(l0,hl0,mbe0_,l1,hl1) -> case spliceH l hl e l0 hl0 of + UBT2(l0_,hl0_) -> UBT5(l0_,hl0_,mbe0_,l1,hl1) + -- forkR :: AVL e -> UINT -> e -> UBT5(AVL e,UINT,Maybe e,AVL e,UINT) + forkR t0 ht0 e1 = forkR_ t0 ht0 where + forkR_ E _ = UBT5(E, L(0), Just e1, E, L(0)) + forkR_ (N l e r) h = forkR__ l DECINT2(h) e r DECINT1(h) + forkR_ (Z l e r) h = forkR__ l DECINT1(h) e r DECINT1(h) + forkR_ (P l e r) h = forkR__ l DECINT1(h) e r DECINT2(h) + forkR__ l hl e r hr = case c e e1 of + Lt -> case forkR_ r hr of + UBT5(l0,hl0,mbe1_,l1,hl1) -> case spliceH l hl e l0 hl0 of + UBT2(l0_,hl0_) -> UBT5(l0_,hl0_,mbe1_,l1,hl1) + Eq mbe1_ -> UBT5(l,hl,mbe1_,r,hr) + Gt -> case forkR_ l hl of + UBT5(l0,hl0,mbe1_,l1,hl1) -> case spliceH l1 hl1 e r hr of + UBT2(l1_,hl1_) -> UBT5(l0,hl0,mbe1_,l1_,hl1_) +----------------------------------------------------------------------- +----------------------- unionMaybeH Ends Here ------------------------- +----------------------------------------------------------------------- + + +-- | Uses the supplied combining comparison to evaluate the intersection of two sets represented as +-- sorted AVL trees. This function requires no height information at all for +-- the two tree inputs. The absolute height of the resulting tree is returned also. +-- +-- Complexity: Not sure, but I_d appreciate it if someone could figure it out. +intersectionH :: (a -> b -> COrdering c) -> AVL a -> AVL b -> UBT2(AVL c,UINT) +intersectionH comp = i where + -- i :: AVL a -> AVL b -> UBT2(AVL c,UINT) + i E _ = UBT2(E,L(0)) + i _ E = UBT2(E,L(0)) + i (N l0 e0 r0) (N l1 e1 r1) = i_ l0 e0 r0 l1 e1 r1 + i (N l0 e0 r0) (Z l1 e1 r1) = i_ l0 e0 r0 l1 e1 r1 + i (N l0 e0 r0) (P l1 e1 r1) = i_ l0 e0 r0 l1 e1 r1 + i (Z l0 e0 r0) (N l1 e1 r1) = i_ l0 e0 r0 l1 e1 r1 + i (Z l0 e0 r0) (Z l1 e1 r1) = i_ l0 e0 r0 l1 e1 r1 + i (Z l0 e0 r0) (P l1 e1 r1) = i_ l0 e0 r0 l1 e1 r1 + i (P l0 e0 r0) (N l1 e1 r1) = i_ l0 e0 r0 l1 e1 r1 + i (P l0 e0 r0) (Z l1 e1 r1) = i_ l0 e0 r0 l1 e1 r1 + i (P l0 e0 r0) (P l1 e1 r1) = i_ l0 e0 r0 l1 e1 r1 + i_ l0 e0 r0 l1 e1 r1 = + case comp e0 e1 of + -- e0 < e1, so (l0 < e0 < e1) & (e0 < e1 < r1) + Lt -> case forkR r0 e1 of + UBT5(rl0,_,mbc1,rr0,_) -> case forkL e0 l1 of -- (e0 < rl0 < e1) & (e0 < e1 < rr0) + UBT5(ll1,_,mbc0,lr1,_) -> -- (ll1 < e0 < e1) & (e0 < lr1 < e1) + -- (l0 + ll1) < e0 < (rl0 + lr1) < e1 < (rr0 + r1) + case i rr0 r1 of + UBT2(r,hr) -> case i rl0 lr1 of + UBT2(m,hm) -> case i l0 ll1 of + UBT2(l,hl) -> case (case mbc1 of + Just c1 -> spliceH m hm c1 r hr + Nothing -> joinH m hm r hr + ) of + UBT2(t,ht) -> case mbc0 of + Just c0 -> spliceH l hl c0 t ht + Nothing -> joinH l hl t ht + -- e0 = e1 + Eq c -> case i l0 l1 of + UBT2(l,hl) -> case i r0 r1 of + UBT2(r,hr) -> spliceH l hl c r hr + -- e1 < e0, so (l1 < e1 < e0) & (e1 < e0 < r0) + Gt -> case forkL e0 r1 of + UBT5(rl1,_,mbc0,rr1,_) -> case forkR l0 e1 of -- (e1 < rl1 < e0) & (e1 < e0 < rr1) + UBT5(ll0,_,mbc1,lr0,_) -> -- (ll0 < e1 < e0) & (e1 < lr0 < e0) + -- (ll0 + l1) < e1 < (lr0 + rl1) < e0 < (r0 + rr1) + case i r0 rr1 of + UBT2(r,hr) -> case i lr0 rl1 of + UBT2(m,hm) -> case i ll0 l1 of + UBT2(l,hl) -> case (case mbc0 of + Just c0 -> spliceH m hm c0 r hr + Nothing -> joinH m hm r hr + ) of + UBT2(t,ht) -> case mbc1 of + Just c1 -> spliceH l hl c1 t ht + Nothing -> joinH l hl t ht + -- We need 2 different versions of fork (L & R) to ensure that comparison arguments are used in + -- the right order (c e0 e1) + -- forkL :: a -> AVL b -> UBT5(AVL b,UINT,Maybe c,AVL b,UINT) + forkL e0 t1 = forkL_ t1 L(0) where + forkL_ E h = UBT5(E,h,Nothing,E,h) -- Relative heights!! + forkL_ (N l e r) h = forkL__ l DECINT2(h) e r DECINT1(h) + forkL_ (Z l e r) h = forkL__ l DECINT1(h) e r DECINT1(h) + forkL_ (P l e r) h = forkL__ l DECINT1(h) e r DECINT2(h) + forkL__ l hl e r hr = case comp e0 e of + Lt -> case forkL_ l hl of + UBT5(l0,hl0,mbc0,l1,hl1) -> case spliceH l1 hl1 e r hr of + UBT2(l1_,hl1_) -> UBT5(l0,hl0,mbc0,l1_,hl1_) + Eq c0 -> UBT5(l,hl,Just c0,r,hr) + Gt -> case forkL_ r hr of + UBT5(l0,hl0,mbc0,l1,hl1) -> case spliceH l hl e l0 hl0 of + UBT2(l0_,hl0_) -> UBT5(l0_,hl0_,mbc0,l1,hl1) + -- forkR :: AVL a -> b -> UBT5(AVL a,UINT,Maybe c,AVL a,UINT) + forkR t0 e1 = forkR_ t0 L(0) where + forkR_ E h = UBT5(E,h,Nothing,E,h) -- Relative heights!! + forkR_ (N l e r) h = forkR__ l DECINT2(h) e r DECINT1(h) + forkR_ (Z l e r) h = forkR__ l DECINT1(h) e r DECINT1(h) + forkR_ (P l e r) h = forkR__ l DECINT1(h) e r DECINT2(h) + forkR__ l hl e r hr = case comp e e1 of + Lt -> case forkR_ r hr of + UBT5(l0,hl0,mbc1,l1,hl1) -> case spliceH l hl e l0 hl0 of + UBT2(l0_,hl0_) -> UBT5(l0_,hl0_,mbc1,l1,hl1) + Eq c1 -> UBT5(l,hl,Just c1,r,hr) + Gt -> case forkR_ l hl of + UBT5(l0,hl0,mbc1,l1,hl1) -> case spliceH l1 hl1 e r hr of + UBT2(l1_,hl1_) -> UBT5(l0,hl0,mbc1,l1_,hl1_) +----------------------------------------------------------------------- +---------------------- intersectionH Ends Here ------------------------ +----------------------------------------------------------------------- + +-- | Similar to _intersectionH_, but the resulting tree does not include elements in cases where +-- the supplied combining comparison returns @(Eq Nothing)@. +-- +-- Complexity: Not sure, but I_d appreciate it if someone could figure it out. +intersectionMaybeH :: (a -> b -> COrdering (Maybe c)) -> AVL a -> AVL b -> UBT2(AVL c,UINT) +intersectionMaybeH comp = i where + -- i :: AVL a -> AVL b -> UBT2(AVL c,UINT) + i E _ = UBT2(E,L(0)) + i _ E = UBT2(E,L(0)) + i (N l0 e0 r0) (N l1 e1 r1) = i_ l0 e0 r0 l1 e1 r1 + i (N l0 e0 r0) (Z l1 e1 r1) = i_ l0 e0 r0 l1 e1 r1 + i (N l0 e0 r0) (P l1 e1 r1) = i_ l0 e0 r0 l1 e1 r1 + i (Z l0 e0 r0) (N l1 e1 r1) = i_ l0 e0 r0 l1 e1 r1 + i (Z l0 e0 r0) (Z l1 e1 r1) = i_ l0 e0 r0 l1 e1 r1 + i (Z l0 e0 r0) (P l1 e1 r1) = i_ l0 e0 r0 l1 e1 r1 + i (P l0 e0 r0) (N l1 e1 r1) = i_ l0 e0 r0 l1 e1 r1 + i (P l0 e0 r0) (Z l1 e1 r1) = i_ l0 e0 r0 l1 e1 r1 + i (P l0 e0 r0) (P l1 e1 r1) = i_ l0 e0 r0 l1 e1 r1 + i_ l0 e0 r0 l1 e1 r1 = + case comp e0 e1 of + -- e0 < e1, so (l0 < e0 < e1) & (e0 < e1 < r1) + Lt -> case forkR r0 e1 of + UBT5(rl0,_,mbc1,rr0,_) -> case forkL e0 l1 of -- (e0 < rl0 < e1) & (e0 < e1 < rr0) + UBT5(ll1,_,mbc0,lr1,_) -> -- (ll1 < e0 < e1) & (e0 < lr1 < e1) + -- (l0 + ll1) < e0 < (rl0 + lr1) < e1 < (rr0 + r1) + case i rr0 r1 of + UBT2(r,hr) -> case i rl0 lr1 of + UBT2(m,hm) -> case i l0 ll1 of + UBT2(l,hl) -> case (case mbc1 of + Just c1 -> spliceH m hm c1 r hr + Nothing -> joinH m hm r hr + ) of + UBT2(t,ht) -> case mbc0 of + Just c0 -> spliceH l hl c0 t ht + Nothing -> joinH l hl t ht + -- e0 = e1 + Eq mbc -> case i l0 l1 of + UBT2(l,hl) -> case i r0 r1 of + UBT2(r,hr) -> case mbc of + Just c -> spliceH l hl c r hr + Nothing -> joinH l hl r hr + -- e1 < e0, so (l1 < e1 < e0) & (e1 < e0 < r0) + Gt -> case forkL e0 r1 of + UBT5(rl1,_,mbc0,rr1,_) -> case forkR l0 e1 of -- (e1 < rl1 < e0) & (e1 < e0 < rr1) + UBT5(ll0,_,mbc1,lr0,_) -> -- (ll0 < e1 < e0) & (e1 < lr0 < e0) + -- (ll0 + l1) < e1 < (lr0 + rl1) < e0 < (r0 + rr1) + case i r0 rr1 of + UBT2(r,hr) -> case i lr0 rl1 of + UBT2(m,hm) -> case i ll0 l1 of + UBT2(l,hl) -> case (case mbc0 of + Just c0 -> spliceH m hm c0 r hr + Nothing -> joinH m hm r hr + ) of + UBT2(t,ht) -> case mbc1 of + Just c1 -> spliceH l hl c1 t ht + Nothing -> joinH l hl t ht + -- We need 2 different versions of fork (L & R) to ensure that comparison arguments are used in + -- the right order (c e0 e1) + -- forkL :: a -> AVL b -> UBT5(AVL b,UINT,Maybe c,AVL b,UINT) + forkL e0 t1 = forkL_ t1 L(0) where + forkL_ E h = UBT5(E,h,Nothing,E,h) -- Relative heights!! + forkL_ (N l e r) h = forkL__ l DECINT2(h) e r DECINT1(h) + forkL_ (Z l e r) h = forkL__ l DECINT1(h) e r DECINT1(h) + forkL_ (P l e r) h = forkL__ l DECINT1(h) e r DECINT2(h) + forkL__ l hl e r hr = case comp e0 e of + Lt -> case forkL_ l hl of + UBT5(l0,hl0,mbc0,l1,hl1) -> case spliceH l1 hl1 e r hr of + UBT2(l1_,hl1_) -> UBT5(l0,hl0,mbc0,l1_,hl1_) + Eq mbc0_ -> UBT5(l,hl,mbc0_,r,hr) + Gt -> case forkL_ r hr of + UBT5(l0,hl0,mbc0,l1,hl1) -> case spliceH l hl e l0 hl0 of + UBT2(l0_,hl0_) -> UBT5(l0_,hl0_,mbc0,l1,hl1) + -- forkR :: AVL a -> b -> UBT5(AVL a,UINT,Maybe c,AVL a,UINT) + forkR t0 e1 = forkR_ t0 L(0) where + forkR_ E h = UBT5(E,h,Nothing,E,h) -- Relative heights!! + forkR_ (N l e r) h = forkR__ l DECINT2(h) e r DECINT1(h) + forkR_ (Z l e r) h = forkR__ l DECINT1(h) e r DECINT1(h) + forkR_ (P l e r) h = forkR__ l DECINT1(h) e r DECINT2(h) + forkR__ l hl e r hr = case comp e e1 of + Lt -> case forkR_ r hr of + UBT5(l0,hl0,mbc1,l1,hl1) -> case spliceH l hl e l0 hl0 of + UBT2(l0_,hl0_) -> UBT5(l0_,hl0_,mbc1,l1,hl1) + Eq mbc1_ -> UBT5(l,hl,mbc1_,r,hr) + Gt -> case forkR_ l hl of + UBT5(l0,hl0,mbc1,l1,hl1) -> case spliceH l1 hl1 e r hr of + UBT2(l1_,hl1_) -> UBT5(l0,hl0,mbc1,l1_,hl1_) +----------------------------------------------------------------------- +-------------------- intersectionMaybeH Ends Here --------------------- +----------------------------------------------------------------------- + +-- | Uses the supplied comparison to evaluate the difference between two sets represented as +-- sorted AVL trees. +-- +-- N.B. This function works with relative heights for the first tree and needs no height +-- information for the second tree, so it_s OK to initialise the height of the first to zero, +-- rather than calculating the absolute height. However, if you do this the height of the resulting +-- tree will be incorrect also (it will have the same fixed offset as the first tree). +-- +-- Complexity: Not sure, but I_d appreciate it if someone could figure it out. +differenceH :: (a -> b -> Ordering) -> AVL a -> UINT -> AVL b -> UBT2(AVL a,UINT) +differenceH comp = d where + -- d :: AVL a -> UINT -> AVL b -> UBT2(AVL a,UINT) + d E h0 _ = UBT2(E ,h0) -- Relative heights!! + d t0 h0 E = UBT2(t0,h0) + d (N l0 e0 r0) h0 (N l1 e1 r1) = d_ l0 DECINT2(h0) e0 r0 DECINT1(h0) l1 e1 r1 + d (N l0 e0 r0) h0 (Z l1 e1 r1) = d_ l0 DECINT2(h0) e0 r0 DECINT1(h0) l1 e1 r1 + d (N l0 e0 r0) h0 (P l1 e1 r1) = d_ l0 DECINT2(h0) e0 r0 DECINT1(h0) l1 e1 r1 + d (Z l0 e0 r0) h0 (N l1 e1 r1) = d_ l0 DECINT1(h0) e0 r0 DECINT1(h0) l1 e1 r1 + d (Z l0 e0 r0) h0 (Z l1 e1 r1) = d_ l0 DECINT1(h0) e0 r0 DECINT1(h0) l1 e1 r1 + d (Z l0 e0 r0) h0 (P l1 e1 r1) = d_ l0 DECINT1(h0) e0 r0 DECINT1(h0) l1 e1 r1 + d (P l0 e0 r0) h0 (N l1 e1 r1) = d_ l0 DECINT1(h0) e0 r0 DECINT2(h0) l1 e1 r1 + d (P l0 e0 r0) h0 (Z l1 e1 r1) = d_ l0 DECINT1(h0) e0 r0 DECINT2(h0) l1 e1 r1 + d (P l0 e0 r0) h0 (P l1 e1 r1) = d_ l0 DECINT1(h0) e0 r0 DECINT2(h0) l1 e1 r1 + d_ l0 hl0 e0 r0 hr0 l1 e1 r1 = + case comp e0 e1 of + -- e0 < e1, so (l0 < e0 < e1) & (e0 < e1 < r1) + LT -> case forkR r0 hr0 e1 of + UBT4(rl0,hrl0, rr0,hrr0) -> case forkL e0 l1 of -- (e0 < rl0 < e1) & (e0 < e1 < rr0) + UBT5(ll1,_ ,be0,lr1,_ ) -> -- (ll1 < e0 < e1) & (e0 < lr1 < e1) + -- (l0 + ll1) < e0 < (rl0 + lr1) < e1 < (rr0 + r1) + case d rr0 hrr0 r1 of -- right + UBT2(r,hr) -> case d rl0 hrl0 lr1 of -- middle + UBT2(m,hm) -> case d l0 hl0 ll1 of -- left + UBT2(l,hl) -> case joinH m hm r hr of -- join middle right + UBT2(y,hy) -> if be0 + then spliceH l hl e0 y hy + else joinH l hl y hy + -- e0 = e1 + EQ -> case d r0 hr0 r1 of -- right + UBT2(r,hr) -> case d l0 hl0 l1 of -- left + UBT2(l,hl) -> joinH l hl r hr + -- e1 < e0, so (l1 < e1 < e0) & (e1 < e0 < r0) + GT -> case forkL e0 r1 of + UBT5(rl1,_ ,be0,rr1,_ ) -> case forkR l0 hl0 e1 of -- (e1 < rl1 < e0) & (e1 < e0 < rr1) + UBT4(ll0,hll0, lr0,hlr0) -> -- (ll0 < e1 < e0) & (e1 < lr0 < e0) + -- (ll0 + l1) < e1 < (lr0 + rl1) < e0 < (r0 + rr1) + case d r0 hr0 rr1 of -- right + UBT2(r,hr) -> case d lr0 hlr0 rl1 of -- middle + UBT2(m,hm) -> case d ll0 hll0 l1 of -- left + UBT2(l,hl) -> case joinH l hl m hm of -- join left middle + UBT2(x,hx) -> if be0 + then spliceH x hx e0 r hr + else joinH x hx r hr + -- We need 2 different versions of fork (L & R) to ensure that comparison arguments are used in + -- the right order (c e0 e1), and for other algorithmic reasons in this case. + -- N.B. forkL returns True if t1 does not contain e0 (I.E. If e0 is an element of the result). + -- forkL :: a -> AVL b -> UBT5(AVL b, UINT, Bool, AVL b, UINT) + forkL e0 t1 = forkL_ t1 L(0) where + forkL_ E h = UBT5(E,h,True,E,h) -- Relative heights!! + forkL_ (N l e r) h = forkL__ l DECINT2(h) e r DECINT1(h) + forkL_ (Z l e r) h = forkL__ l DECINT1(h) e r DECINT1(h) + forkL_ (P l e r) h = forkL__ l DECINT1(h) e r DECINT2(h) + forkL__ l hl e r hr = case comp e0 e of + LT -> case forkL_ l hl of + UBT5(x0,hx0,be0,x1,hx1) -> case spliceH x1 hx1 e r hr of + UBT2(x1_,hx1_) -> UBT5(x0,hx0,be0,x1_,hx1_) + EQ -> UBT5(l,hl,False,r,hr) + GT -> case forkL_ r hr of + UBT5(x0,hx0,be0,x1,hx1) -> case spliceH l hl e x0 hx0 of + UBT2(x0_,hx0_) -> UBT5(x0_,hx0_,be0,x1,hx1) + -- N.B. forkR t0, according to e1. Neither of the resulting forks will contain an element + -- which is "equal" to e1. + -- forkR :: AVL a -> UINT -> b -> UBT4(AVL a, UINT, AVL a, UINT) + forkR t0 ht0 e1 = forkR_ t0 ht0 where + forkR_ E h = UBT4(E,h,E,h) -- Relative heights!! + forkR_ (N l e r) h = forkR__ l DECINT2(h) e r DECINT1(h) + forkR_ (Z l e r) h = forkR__ l DECINT1(h) e r DECINT1(h) + forkR_ (P l e r) h = forkR__ l DECINT1(h) e r DECINT2(h) + forkR__ l hl e r hr = case comp e e1 of + LT -> case forkR_ r hr of + UBT4(x0,hx0,x1,hx1) -> case spliceH l hl e x0 hx0 of + UBT2(x0_,hx0_) -> UBT4(x0_,hx0_,x1,hx1) + EQ -> UBT4(l,hl,r,hr) -- e1 is dropped. + GT -> case forkR_ l hl of + UBT4(x0,hx0,x1,hx1) -> case spliceH x1 hx1 e r hr of + UBT2(x1_,hx1_) -> UBT4(x0,hx0,x1_,hx1_) +----------------------------------------------------------------------- +----------------------- differenceH Ends Here ------------------------- +----------------------------------------------------------------------- + +-- | Similar to _differenceH_, but the resulting tree also includes those elements a\_ for which the +-- combining comparison returns @Eq (Just a\_)@. +-- +-- N.B. This function works with relative heights for the first tree and needs no height +-- information for the second tree, so it_s OK to initialise the height of the first to zero, +-- rather than calculating the absolute height. However, if you do this the height of the resulting +-- tree will be incorrect also (it will have the same fixed offset as the first tree). +-- +-- Complexity: Not sure, but I_d appreciate it if someone could figure it out. +differenceMaybeH :: (a -> b -> COrdering (Maybe a)) -> AVL a -> UINT -> AVL b -> UBT2(AVL a,UINT) +differenceMaybeH comp = d where + -- d :: AVL a -> UINT -> AVL b -> UBT2(AVL a,UINT) + d E h0 _ = UBT2(E ,h0) -- Relative heights!! + d t0 h0 E = UBT2(t0,h0) + d (N l0 e0 r0) h0 (N l1 e1 r1) = d_ l0 DECINT2(h0) e0 r0 DECINT1(h0) l1 e1 r1 + d (N l0 e0 r0) h0 (Z l1 e1 r1) = d_ l0 DECINT2(h0) e0 r0 DECINT1(h0) l1 e1 r1 + d (N l0 e0 r0) h0 (P l1 e1 r1) = d_ l0 DECINT2(h0) e0 r0 DECINT1(h0) l1 e1 r1 + d (Z l0 e0 r0) h0 (N l1 e1 r1) = d_ l0 DECINT1(h0) e0 r0 DECINT1(h0) l1 e1 r1 + d (Z l0 e0 r0) h0 (Z l1 e1 r1) = d_ l0 DECINT1(h0) e0 r0 DECINT1(h0) l1 e1 r1 + d (Z l0 e0 r0) h0 (P l1 e1 r1) = d_ l0 DECINT1(h0) e0 r0 DECINT1(h0) l1 e1 r1 + d (P l0 e0 r0) h0 (N l1 e1 r1) = d_ l0 DECINT1(h0) e0 r0 DECINT2(h0) l1 e1 r1 + d (P l0 e0 r0) h0 (Z l1 e1 r1) = d_ l0 DECINT1(h0) e0 r0 DECINT2(h0) l1 e1 r1 + d (P l0 e0 r0) h0 (P l1 e1 r1) = d_ l0 DECINT1(h0) e0 r0 DECINT2(h0) l1 e1 r1 + d_ l0 hl0 e0 r0 hr0 l1 e1 r1 = + case comp e0 e1 of + -- e0 < e1, so (l0 < e0 < e1) & (e0 < e1 < r1) + Lt -> case forkR r0 hr0 e1 of + UBT5( rl0,hrl0,mbe1,rr0,hrr0) -> case forkL e0 l1 of -- (e0 < rl0 < e1) & (e0 < e1 < rr0) + UBT5(ll1,_ ,mbe0,lr1,_ ) -> -- (ll1 < e0 < e1) & (e0 < lr1 < e1) + -- (l0 + ll1) < e0 < (rl0 + lr1) < e1 < (rr0 + r1) + case d rr0 hrr0 r1 of -- right + UBT2(r,hr) -> case d rl0 hrl0 lr1 of -- middle + UBT2(m,hm) -> case d l0 hl0 ll1 of -- left + UBT2(l,hl) -> case (case mbe1 of + Just e1_ -> spliceH m hm e1_ r hr -- splice middle right with e1_ + Nothing -> joinH m hm r hr) of -- join middle right + UBT2(y,hy) -> case mbe0 of + Just e0_ -> spliceH l hl e0_ y hy + Nothing -> joinH l hl y hy + -- e0 = e1 + Eq mbe0 -> case d r0 hr0 r1 of -- right + UBT2(r,hr) -> case d l0 hl0 l1 of -- left + UBT2(l,hl) -> case mbe0 of + Just e0_ -> spliceH l hl e0_ r hr -- retain updated e0 + Nothing -> joinH l hl r hr -- discard original e0 + -- e1 < e0, so (l1 < e1 < e0) & (e1 < e0 < r0) + Gt -> case forkL e0 r1 of + UBT5( rl1,_ ,mbe0,rr1,_ ) -> case forkR l0 hl0 e1 of -- (e1 < rl1 < e0) & (e1 < e0 < rr1) + UBT5(ll0,hll0,mbe1,lr0,hlr0) -> -- (ll0 < e1 < e0) & (e1 < lr0 < e0) + -- (ll0 + l1) < e1 < (lr0 + rl1) < e0 < (r0 + rr1) + case d r0 hr0 rr1 of -- right + UBT2(r,hr) -> case d lr0 hlr0 rl1 of -- middle + UBT2(m,hm) -> case d ll0 hll0 l1 of -- left + UBT2(l,hl) -> case (case mbe1 of + Just e1_ -> spliceH l hl e1_ m hm -- splice left middle with e1_ + Nothing -> joinH l hl m hm) of -- join left middle + UBT2(x,hx) -> case mbe0 of + Just e0_ -> spliceH x hx e0_ r hr + Nothing -> joinH x hx r hr + -- We need 2 different versions of fork (L & R) to ensure that comparison arguments are used in + -- the right order (c e0 e1), and for other algorithmic reasons in this case. + -- N.B. forkL returns (Just e0) if t1 does not contain e0 (I.E. If original e0 is an element of the result). + -- forkL :: a -> AVL b -> UBT5(AVL b, UINT, Maybe a, AVL b, UINT) + forkL e0 t1 = forkL_ t1 L(0) where + forkL_ E h = UBT5(E,h,Just e0,E,h) -- Relative heights!! + forkL_ (N l e r) h = forkL__ l DECINT2(h) e r DECINT1(h) + forkL_ (Z l e r) h = forkL__ l DECINT1(h) e r DECINT1(h) + forkL_ (P l e r) h = forkL__ l DECINT1(h) e r DECINT2(h) + forkL__ l hl e r hr = case comp e0 e of + Lt -> case forkL_ l hl of + UBT5(x0,hx0,mbe0,x1,hx1) -> case spliceH x1 hx1 e r hr of + UBT2(x1_,hx1_) -> UBT5(x0,hx0,mbe0,x1_,hx1_) + Eq mbe0 -> UBT5(l,hl,mbe0,r,hr) + Gt -> case forkL_ r hr of + UBT5(x0,hx0,mbe0,x1,hx1) -> case spliceH l hl e x0 hx0 of + UBT2(x0_,hx0_) -> UBT5(x0_,hx0_,mbe0,x1,hx1) + -- N.B. forkR t0, according to e1. Returns Nothing if t0 does not contain e1. + -- forkR :: AVL a -> UINT -> b -> UBT5(AVL a, UINT, Maybe a, AVL a, UINT) + forkR t0 ht0 e1 = forkR_ t0 ht0 where + forkR_ E h = UBT5(E,h,Nothing,E,h) -- Relative heights!! + forkR_ (N l e r) h = forkR__ l DECINT2(h) e r DECINT1(h) + forkR_ (Z l e r) h = forkR__ l DECINT1(h) e r DECINT1(h) + forkR_ (P l e r) h = forkR__ l DECINT1(h) e r DECINT2(h) + forkR__ l hl e r hr = case comp e e1 of + Lt -> case forkR_ r hr of + UBT5(x0,hx0,mbe1,x1,hx1) -> case spliceH l hl e x0 hx0 of + UBT2(x0_,hx0_) -> UBT5(x0_,hx0_,mbe1,x1,hx1) + Eq mbe1 -> UBT5(l,hl,mbe1,r,hr) + Gt -> case forkR_ l hl of + UBT5(x0,hx0,mbe1,x1,hx1) -> case spliceH x1 hx1 e r hr of + UBT2(x1_,hx1_) -> UBT5(x0,hx0,mbe1,x1_,hx1_) +----------------------------------------------------------------------- +--------------------- differenceMaybeH Ends Here ---------------------- +----------------------------------------------------------------------- + +-- | The symmetric difference is the set of elements which occur in one set or the other but /not both/. +-- +-- Complexity: Not sure, but I_d appreciate it if someone could figure it out. +symDifferenceH :: (e -> e -> Ordering) -> AVL e -> UINT -> AVL e -> UINT -> UBT2(AVL e,UINT) +symDifferenceH c = u where + -- u :: AVL e -> UINT -> AVL e -> UINT -> UBT2(AVL e,UINT) + u E _ t1 h1 = UBT2(t1,h1) + u t0 h0 E _ = UBT2(t0,h0) + u (N l0 e0 r0) h0 (N l1 e1 r1) h1 = u_ l0 DECINT2(h0) e0 r0 DECINT1(h0) l1 DECINT2(h1) e1 r1 DECINT1(h1) + u (N l0 e0 r0) h0 (Z l1 e1 r1) h1 = u_ l0 DECINT2(h0) e0 r0 DECINT1(h0) l1 DECINT1(h1) e1 r1 DECINT1(h1) + u (N l0 e0 r0) h0 (P l1 e1 r1) h1 = u_ l0 DECINT2(h0) e0 r0 DECINT1(h0) l1 DECINT1(h1) e1 r1 DECINT2(h1) + u (Z l0 e0 r0) h0 (N l1 e1 r1) h1 = u_ l0 DECINT1(h0) e0 r0 DECINT1(h0) l1 DECINT2(h1) e1 r1 DECINT1(h1) + u (Z l0 e0 r0) h0 (Z l1 e1 r1) h1 = u_ l0 DECINT1(h0) e0 r0 DECINT1(h0) l1 DECINT1(h1) e1 r1 DECINT1(h1) + u (Z l0 e0 r0) h0 (P l1 e1 r1) h1 = u_ l0 DECINT1(h0) e0 r0 DECINT1(h0) l1 DECINT1(h1) e1 r1 DECINT2(h1) + u (P l0 e0 r0) h0 (N l1 e1 r1) h1 = u_ l0 DECINT1(h0) e0 r0 DECINT2(h0) l1 DECINT2(h1) e1 r1 DECINT1(h1) + u (P l0 e0 r0) h0 (Z l1 e1 r1) h1 = u_ l0 DECINT1(h0) e0 r0 DECINT2(h0) l1 DECINT1(h1) e1 r1 DECINT1(h1) + u (P l0 e0 r0) h0 (P l1 e1 r1) h1 = u_ l0 DECINT1(h0) e0 r0 DECINT2(h0) l1 DECINT1(h1) e1 r1 DECINT2(h1) + u_ l0 hl0 e0 r0 hr0 l1 hl1 e1 r1 hr1 = + case c e0 e1 of + -- e0 < e1, so (l0 < e0 < e1) & (e0 < e1 < r1) + LT -> case forkR r0 hr0 e1 of + UBT5(rl0,hrl0,be1,rr0,hrr0) -> case forkL e0 l1 hl1 of -- (e0 < rl0 < e1) & (e0 < e1 < rr0) + UBT5(ll1,hll1,be0,lr1,hlr1) -> -- (ll1 < e0 < e1) & (e0 < lr1 < e1) + -- (l0 + ll1) < e0 < (rl0 + lr1) < e1 < (rr0 + r1) + case u l0 hl0 ll1 hll1 of + UBT2(l,hl) -> case u rl0 hrl0 lr1 hlr1 of + UBT2(m,hm) -> case u rr0 hrr0 r1 hr1 of + UBT2(r,hr) -> case (if be1 then spliceH m hm e1 r hr + else joinH m hm r hr + ) of + UBT2(t,ht) -> if be0 then spliceH l hl e0 t ht + else joinH l hl t ht + -- e0 = e1 + EQ -> case u l0 hl0 l1 hl1 of + UBT2(l,hl) -> case u r0 hr0 r1 hr1 of + UBT2(r,hr) -> joinH l hl r hr + -- e1 < e0, so (l1 < e1 < e0) & (e1 < e0 < r0) + GT -> case forkL e0 r1 hr1 of + UBT5(rl1,hrl1,be0,rr1,hrr1) -> case forkR l0 hl0 e1 of -- (e1 < rl1 < e0) & (e1 < e0 < rr1) + UBT5(ll0,hll0,be1,lr0,hlr0) -> -- (ll0 < e1 < e0) & (e1 < lr0 < e0) + -- (ll0 + l1) < e1 < (lr0 + rl1) < e0 < (r0 + rr1) + case u ll0 hll0 l1 hl1 of + UBT2(l,hl) -> case u lr0 hlr0 rl1 hrl1 of + UBT2(m,hm) -> case u r0 hr0 rr1 hrr1 of + UBT2(r,hr) -> case (if be1 then spliceH l hl e1 m hm + else joinH l hl m hm + ) of + UBT2(t,ht) -> if be0 then spliceH t ht e0 r hr + else joinH t ht r hr + -- We need 2 different versions of fork (L & R) to ensure that comparison arguments are used in + -- the right order (c e0 e1) + -- forkL :: e -> AVL e -> UINT -> UBT5(AVL e,UINT,Bool,AVL e,UINT) + forkL e0 t1 ht1 = forkL_ t1 ht1 where + forkL_ E _ = UBT5(E, L(0), True, E, L(0)) + forkL_ (N l e r) h = forkL__ l DECINT2(h) e r DECINT1(h) + forkL_ (Z l e r) h = forkL__ l DECINT1(h) e r DECINT1(h) + forkL_ (P l e r) h = forkL__ l DECINT1(h) e r DECINT2(h) + forkL__ l hl e r hr = case c e0 e of + LT -> case forkL_ l hl of + UBT5(l0,hl0,be0,l1,hl1) -> case spliceH l1 hl1 e r hr of + UBT2(l1_,hl1_) -> UBT5(l0,hl0,be0,l1_,hl1_) + EQ -> UBT5(l,hl,False,r,hr) + GT -> case forkL_ r hr of + UBT5(l0,hl0,be0,l1,hl1) -> case spliceH l hl e l0 hl0 of + UBT2(l0_,hl0_) -> UBT5(l0_,hl0_,be0,l1,hl1) + -- forkR :: AVL e -> UINT -> e -> UBT5(AVL e,UINT,Bool,AVL e,UINT) + forkR t0 ht0 e1 = forkR_ t0 ht0 where + forkR_ E _ = UBT5(E, L(0), True, E, L(0)) + forkR_ (N l e r) h = forkR__ l DECINT2(h) e r DECINT1(h) + forkR_ (Z l e r) h = forkR__ l DECINT1(h) e r DECINT1(h) + forkR_ (P l e r) h = forkR__ l DECINT1(h) e r DECINT2(h) + forkR__ l hl e r hr = case c e e1 of + LT -> case forkR_ r hr of + UBT5(l0,hl0,be1,l1,hl1) -> case spliceH l hl e l0 hl0 of + UBT2(l0_,hl0_) -> UBT5(l0_,hl0_,be1,l1,hl1) + EQ -> UBT5(l,hl,False,r,hr) + GT -> case forkR_ l hl of + UBT5(l0,hl0,be1,l1,hl1) -> case spliceH l1 hl1 e r hr of + UBT2(l1_,hl1_) -> UBT5(l0,hl0,be1,l1_,hl1_) +----------------------------------------------------------------------- +----------------------- symDifferenceH Ends Here ---------------------- +----------------------------------------------------------------------- diff --git a/Data/Tree/AVL/Internals/HeightUtils.hs b/Data/Tree/AVL/Internals/HeightUtils.hs new file mode 100644 --- /dev/null +++ b/Data/Tree/AVL/Internals/HeightUtils.hs @@ -0,0 +1,98 @@ +{-# OPTIONS_GHC -fglasgow-exts #-} +----------------------------------------------------------------------------- +-- | +-- Module : Data.Tree.AVL.Internals.HeightUtils +-- Copyright : (c) Adrian Hey 2004,2005 +-- License : BSD3 +-- +-- Maintainer : http://homepages.nildram.co.uk/~ahey/em.png +-- Stability : stable +-- Portability : portable +-- +-- AVL tree height related utilities. +-- +-- The functions defined here are not exported by the main Data.Tree.AVL module +-- because they violate the policy for AVL tree equality used elsewhere in this library. +-- You need to import this module explicitly if you want to use any of these functions. +----------------------------------------------------------------------------- +module Data.Tree.AVL.Internals.HeightUtils + (height,addHeight,compareHeight, -- heightInt, + ) where + +import Data.Tree.AVL.Types(AVL(..)) + +#ifdef __GLASGOW_HASKELL__ +import GHC.Base +#include "ghcdefs.h" +#else +#include "h98defs.h" +#endif + +-- {-# INLINE heightInt #-} -- Don't want this +-- heightInt :: AVL e -> Int +-- heightInt t = ASINT(addHeight L(0) t) + +-- | Determine the height of an AVL tree. +-- +-- Complexity: O(log n) +{-# INLINE height #-} +height :: AVL e -> UINT +height t = addHeight L(0) t + +-- | Adds the height of a tree to the first argument. +-- +-- Complexity: O(log n) +addHeight :: UINT -> AVL e -> UINT +addHeight h E = h +addHeight h (N l _ _) = addHeight INCINT2(h) l +addHeight h (Z l _ _) = addHeight INCINT1(h) l +addHeight h (P _ _ r) = addHeight INCINT2(h) r + +-- | A fast algorithm for comparing the heights of two trees. This algorithm avoids the need +-- to compute the heights of both trees and should offer better performance if the trees differ +-- significantly in height. But if you need the heights anyway it will be quicker to just evaluate +-- them both and compare the results. +-- +-- Complexity: O(log n), where n is the size of the smaller of the two trees. +compareHeight :: AVL a -> AVL b -> Ordering +compareHeight = ch L(0) where -- d = hA-hB + ch :: UINT -> AVL a -> AVL b -> Ordering + ch d E E = COMPAREUINT d L(0) + ch d E (N l1 _ _ ) = chA DECINT2(d) l1 + ch d E (Z l1 _ _ ) = chA DECINT1(d) l1 + ch d E (P _ _ r1) = chA DECINT2(d) r1 + ch d (N l0 _ _ ) E = chB INCINT2(d) l0 + ch d (N l0 _ _ ) (N l1 _ _ ) = ch d l0 l1 + ch d (N l0 _ _ ) (Z l1 _ _ ) = ch INCINT1(d) l0 l1 + ch d (N l0 _ _ ) (P _ _ r1) = ch d l0 r1 + ch d (Z l0 _ _ ) E = chB INCINT1(d) l0 + ch d (Z l0 _ _ ) (N l1 _ _ ) = ch DECINT1(d) l0 l1 + ch d (Z l0 _ _ ) (Z l1 _ _ ) = ch d l0 l1 + ch d (Z l0 _ _ ) (P _ _ r1) = ch DECINT1(d) l0 r1 + ch d (P _ _ r0) E = chB INCINT2(d) r0 + ch d (P _ _ r0) (N l1 _ _ ) = ch d r0 l1 + ch d (P _ _ r0) (Z l1 _ _ ) = ch INCINT1(d) r0 l1 + ch d (P _ _ r0) (P _ _ r1) = ch d r0 r1 + -- Tree A ended first, continue with Tree B until hA-hB<0, or Tree B ends + chA d tB = case COMPAREUINT d L(0) of + LT -> LT + EQ -> case tB of + E -> EQ + _ -> LT + GT -> case tB of + E -> GT + N l _ _ -> chA DECINT2(d) l + Z l _ _ -> chA DECINT1(d) l + P _ _ r -> chA DECINT2(d) r + -- Tree B ended first, continue with Tree A until hA-hB>0, or Tree A ends + chB d tA = case COMPAREUINT d L(0) of + GT -> GT + EQ -> case tA of + E -> EQ + _ -> GT + LT -> case tA of + E -> LT + N l _ _ -> chB INCINT2(d) l + Z l _ _ -> chB INCINT1(d) l + P _ _ r -> chB INCINT2(d) r + diff --git a/Data/Tree/AVL/Join.hs b/Data/Tree/AVL/Join.hs new file mode 100644 --- /dev/null +++ b/Data/Tree/AVL/Join.hs @@ -0,0 +1,121 @@ +{-# OPTIONS_GHC -fglasgow-exts #-} +----------------------------------------------------------------------------- +-- | +-- Module : Data.Tree.AVL.Join +-- Copyright : (c) Adrian Hey 2004,2005 +-- License : BSD3 +-- +-- Maintainer : http://homepages.nildram.co.uk/~ahey/em.png +-- Stability : stable +-- Portability : portable +----------------------------------------------------------------------------- +module Data.Tree.AVL.Join +(-- * Joining AVL trees + join,concatAVL,flatConcat, +) where + +import Data.Tree.AVL.Types(AVL(..)) +import Data.Tree.AVL.Size(addSize) +import Data.Tree.AVL.List(asTreeLenL,toListL) +import Data.Tree.AVL.Internals.DelUtils(popHLN,popHLZ,popHLP) +import Data.Tree.AVL.Internals.HeightUtils(height,addHeight) +import Data.Tree.AVL.Internals.HJoin(joinH',spliceH) + +import Data.List(foldl') + +#ifdef __GLASGOW_HASKELL__ +import GHC.Base +#include "ghcdefs.h" +#else +#include "h98defs.h" +#endif + +-- | Join two AVL trees. This is the AVL equivalent of (++). +-- +-- > asListL (l `join` r) = asListL l ++ asListL r +-- +-- Complexity: O(log n), where n is the size of the larger of the two trees. +join :: AVL e -> AVL e -> AVL e +join l r = joinH' l (height l) r (height r) + +-- Specialised list of AVL trees of known height, with leftmost element popped. +-- (used by concatAVL). +data HAVLS e = HE | H e (AVL e) UINT (HAVLS e) + +-- | Concatenate a /finite/ list of AVL trees. During construction of the resulting tree the +-- input list is consumed lazily, but it will be consumed entirely before the result is returned. +-- +-- > asListL (concatAVL avls) = concatMap asListL avls +-- +-- Complexity: Umm..Dunno. Uses a divide and conquer approach to splice adjacent pairs of +-- trees in the list recursively, until only one tree remains. The complexity of each splice +-- is proportional to the difference in tree heights. +concatAVL :: [AVL e] -> AVL e +concatAVL [] = E +concatAVL ( E :ts) = concatAVL ts +concatAVL (t@(N l _ _):ts) = concatHAVLS t (addHeight L(2) l) (mkHAVLS ts) +concatAVL (t@(Z l _ _):ts) = concatHAVLS t (addHeight L(1) l) (mkHAVLS ts) +concatAVL (t@(P _ _ r):ts) = concatHAVLS t (addHeight L(2) r) (mkHAVLS ts) + +-- Recursively call mergePairs until only one tree remains. +-- The head of the current list has to be treated specially becuase it has no associated +-- bridging element. +concatHAVLS :: AVL e -> UINT -> HAVLS e -> AVL e +concatHAVLS l _ HE = l +concatHAVLS l hl (H e r hr hs) = case mergePairs l hl e r hr hs of + UBT3(t,ht,hs_) -> concatHAVLS t ht hs_ + + +-- Merge adjacent pairs in the current list. +-- The head of the current list has to be treated specially becuase it has no associated +-- bridging element. +-- This function is strict in both elements of the result pair. +{-# INLINE mergePairs #-} +mergePairs :: AVL e -> UINT -> e -> AVL e -> UINT -> HAVLS e -> UBT3(AVL e,UINT,HAVLS e) +mergePairs l hl e r hr hs = case spliceH l hl e r hr of + UBT2(t,ht) -> case hs of + HE -> UBT3(t,ht,HE) + H e_ t_ ht_ hs_ -> let hs__ = mergePairs_ e_ t_ ht_ hs_ + in hs__ `seq` UBT3(t,ht,hs__) + +-- Deals with the rest of mergePairs after the head of the current list has been dealt with. +-- This function is strict in the resulting list head and lazy in the tail. +mergePairs_ :: e -> AVL e -> UINT -> HAVLS e -> HAVLS e +mergePairs_ e l hl HE = H e l hl HE +mergePairs_ e l hl (H e_ r hr hs) = case spliceH l hl e_ r hr of + UBT2(t,ht) -> case hs of + HE -> H e t ht HE + H e__ r_ hr_ hs_ -> H e t ht (mergePairs_ e__ r_ hr_ hs_) + +-- Uses popHL to get the leftmost element from each tree and calculate the (popped) tree height. +-- The popped element is used as a bridging element for splicing purposes. +-- Empty and singleton trees get special treatment. +-- This function is strict in the resulting list head and lazy in the tail. +mkHAVLS :: [AVL e] -> HAVLS e +mkHAVLS [] = HE +mkHAVLS ( E :ts) = mkHAVLS ts -- Discard empty trees +mkHAVLS ((N l e r):ts) = case popHLN l e r of -- Never a singlton with N + UBT3(e_,t,ht) -> H e_ t ht (mkHAVLS ts) +mkHAVLS ((Z l e r):ts) = case popHLZ l e r of + UBT3(e_,t,ht) -> if ht EQL L(0) + then mkHAVLS_ e_ ts -- Deal with singleton + else H e_ t ht (mkHAVLS ts) -- Otherwise treat as normal +mkHAVLS ((P l e r):ts) = case popHLP l e r of -- Never a singlton with P + UBT3(e_,t,ht) -> H e_ t ht (mkHAVLS ts) +-- Deals with singletons (avoids unnecessary popHL in next in list) +mkHAVLS_ :: e -> [AVL e] -> HAVLS e +mkHAVLS_ e [] = H e E L(0) HE -- End of list reached anyway +mkHAVLS_ e ( E :ts) = mkHAVLS_ e ts -- Discard empty trees +mkHAVLS_ e (t@(N l _ _):ts) = H e t (addHeight L(2) l) (mkHAVLS ts) +mkHAVLS_ e (t@(Z l _ _):ts) = H e t (addHeight L(1) l) (mkHAVLS ts) +mkHAVLS_ e (t@(P _ _ r):ts) = H e t (addHeight L(2) r) (mkHAVLS ts) +----------------------------------------------------------------------- +---------------------- concatAVL Ends Here ---------------------------- +----------------------------------------------------------------------- + +-- | Similar to 'concatAVL', except the resulting tree is flat. +-- This function evaluates the entire list of trees before constructing the result. +-- +-- Complexity: O(n), where n is the total number of elements in the resulting tree. +flatConcat :: [AVL e] -> AVL e +flatConcat avls = asTreeLenL (foldl' addSize 0 avls) (foldr toListL [] avls) diff --git a/Data/Tree/AVL/List.hs b/Data/Tree/AVL/List.hs new file mode 100644 --- /dev/null +++ b/Data/Tree/AVL/List.hs @@ -0,0 +1,856 @@ +{-# OPTIONS_GHC -fglasgow-exts #-} +----------------------------------------------------------------------------- +-- | +-- Module : Data.Tree.AVL.List +-- Copyright : (c) Adrian Hey 2004,2005 +-- License : BSD3 +-- +-- Maintainer : http://homepages.nildram.co.uk/~ahey/em.png +-- Stability : stable +-- Portability : portable +----------------------------------------------------------------------------- +module Data.Tree.AVL.List +(-- * List related utilities for AVL trees + + -- ** Converting AVL trees to Lists (fixed element order). + -- | These functions are lazy and allow normal lazy list processing + -- style to be used (without necessarily converting the entire tree + -- to a list in one gulp). + asListL,toListL,asListR,toListR, + + -- ** Converting Lists to AVL trees (fixed element order) + asTreeLenL,asTreeL, + asTreeLenR,asTreeR, + + -- ** Converting unsorted Lists to sorted AVL trees + genAsTree, + + -- ** \"Pushing\" unsorted Lists in sorted AVL trees + genPushList, + + -- * Some analogues of common List functions + reverseAVL,mapAVL,mapAVL', + mapAccumLAVL ,mapAccumRAVL , + mapAccumLAVL' ,mapAccumRAVL' , +#ifdef __GLASGOW_HASKELL__ + mapAccumLAVL'',mapAccumRAVL'', +#endif +#if __GLASGOW_HASKELL__ > 604 + traverseAVL, +#endif + replicateAVL, + filterAVL,mapMaybeAVL, + filterViaList,mapMaybeViaList, + partitionAVL, + + -- ** Folds + -- | Note that unlike folds over lists ('foldr' and 'foldl'), there is no + -- significant difference between left and right folds in AVL trees, other + -- than which side of the tree each starts with. + -- Therefore this library provides strict and lazy versions of both. + foldrAVL,foldrAVL',foldr1AVL,foldr1AVL',foldr2AVL,foldr2AVL', + foldlAVL,foldlAVL',foldl1AVL,foldl1AVL',foldl2AVL,foldl2AVL', + foldrAVL_UINT, + + -- * \"Flattening\" AVL trees + -- | These functions can be improve search times by reducing a tree of given size to + -- the minimum possible height. + flatten, + flatReverse,flatMap,flatMap', + + -- * AVL tree based sorting of Lists + -- | Nothing to do with AVL trees really. But using AVL trees do give an O(n.(log n)) sort + -- algorithm for free, so here it is. These functions all consume the entire + -- input list to construct a sorted AVL tree and then read the elements out as a list (lazily). + genSortAscending,genSortDescending, +) where + +import Prelude -- so haddock finds the symbols there + +#if __GLASGOW_HASKELL__ > 604 +import Control.Applicative hiding (empty) +#endif + +import Data.COrdering +import Data.Tree.AVL.Types(AVL(..),empty) +import Data.Tree.AVL.Size(size) +import Data.Tree.AVL.Push(genPush) +import Data.Tree.AVL.Internals.HJoin(spliceH,joinH) + +import Data.Bits(shiftR,(.&.)) +import Data.List(foldl') + +#ifdef __GLASGOW_HASKELL__ +import GHC.Base +#include "ghcdefs.h" +#else +#include "h98defs.h" +#endif + +-- | List AVL tree contents in left to right order. +-- The resulting list in ascending order if the tree is sorted. +-- +-- Complexity: O(n) +asListL :: AVL e -> [e] +asListL avl = toListL avl [] + +-- | Join the AVL tree contents to an existing list in left to right order. +-- This is a ++ free function which behaves as if defined thusly.. +-- +-- > avl `toListL` as = (asListL avl) ++ as +-- +-- Complexity: O(n) +toListL :: AVL e -> [e] -> [e] +toListL E es = es +toListL (N l e r) es = toListL' l e r es +toListL (Z l e r) es = toListL' l e r es +toListL (P l e r) es = toListL' l e r es +toListL' :: AVL e -> e -> AVL e -> [e] -> [e] +toListL' l e r es = toListL l (e:(toListL r es)) + +-- | List AVL tree contents in right to left order. +-- The resulting list in descending order if the tree is sorted. +-- +-- Complexity: O(n) +asListR :: AVL e -> [e] +asListR avl = toListR avl [] + +-- | Join the AVL tree contents to an existing list in right to left order. +-- This is a ++ free function which behaves as if defined thusly.. +-- +-- > avl `toListR` as = (asListR avl) ++ as +-- +-- Complexity: O(n) +toListR :: AVL e -> [e] -> [e] +toListR E es = es +toListR (N l e r) es = toListR' l e r es +toListR (Z l e r) es = toListR' l e r es +toListR (P l e r) es = toListR' l e r es +toListR' :: AVL e -> e -> AVL e -> [e] -> [e] +toListR' l e r es = toListR r (e:(toListR l es)) + +-- | The AVL equivalent of 'foldr' on lists. This is a the lazy version (as lazy as the folding function +-- anyway). Using this version with a function that is strict in it's second argument will result in O(n) +-- stack use. See 'foldrAVL'' for a strict version. +-- +-- It behaves as if defined.. +-- +-- > foldrAVL f a avl = foldr f a (asListL avl) +-- +-- For example, the 'asListL' function could be defined.. +-- +-- > asListL = foldrAVL (:) [] +-- +-- Complexity: O(n) +foldrAVL :: (e -> a -> a) -> a -> AVL e -> a +foldrAVL f = foldU where + foldU a E = a + foldU a (N l e r) = foldV a l e r + foldU a (Z l e r) = foldV a l e r + foldU a (P l e r) = foldV a l e r + foldV a l e r = foldU (f e (foldU a r)) l + +-- | The strict version of 'foldrAVL', which is useful for functions which are strict in their second +-- argument. The advantage of this version is that it reduces the stack use from the O(n) that the lazy +-- version gives (when used with strict functions) to O(log n). +-- +-- Complexity: O(n) +foldrAVL' :: (e -> a -> a) -> a -> AVL e -> a +foldrAVL' f = foldU where + foldU a E = a + foldU a (N l e r) = foldV a l e r + foldU a (Z l e r) = foldV a l e r + foldU a (P l e r) = foldV a l e r + foldV a l e r = let a' = foldU a r + a'' = f e a' + in a' `seq` a'' `seq` foldU a'' l + +-- | The AVL equivalent of 'foldr1' on lists. This is a the lazy version (as lazy as the folding function +-- anyway). Using this version with a function that is strict in it's second argument will result in O(n) +-- stack use. See 'foldr1AVL'' for a strict version. +-- +-- > foldr1AVL f avl = foldr1 f (asListL avl) +-- +-- This function raises an error if the tree is empty. +-- +-- Complexity: O(n) +foldr1AVL :: (e -> e -> e) -> AVL e -> e +foldr1AVL f = foldU where + foldU E = error "foldr1AVL: Empty Tree" + foldU (N l e r) = foldV l e r -- r can't be E + foldU (Z l e r) = foldW l e r -- r might be E + foldU (P l e r) = foldW l e r -- r might be E + -- Use this when r can't be E + foldV l e r = foldrAVL f (f e (foldU r)) l + -- Use this when r might be E + foldW l e E = foldrAVL f e l + foldW l e (N rl re rr) = foldrAVL f (f e (foldV rl re rr)) l -- rr can't be E + foldW l e (Z rl re rr) = foldX l e rl re rr -- rr might be E + foldW l e (P rl re rr) = foldX l e rl re rr -- rr might be E + -- Common code for foldW (Z and P cases) + foldX l e rl re rr = foldrAVL f (f e (foldW rl re rr)) l + +-- | The strict version of 'foldr1AVL', which is useful for functions which are strict in their second +-- argument. The advantage of this version is that it reduces the stack use from the O(n) that the lazy +-- version gives (when used with strict functions) to O(log n). +-- +-- Complexity: O(n) +foldr1AVL' :: (e -> e -> e) -> AVL e -> e +foldr1AVL' f = foldU where + foldU E = error "foldr1AVL': Empty Tree" + foldU (N l e r) = foldV l e r -- r can't be E + foldU (Z l e r) = foldW l e r -- r might be E + foldU (P l e r) = foldW l e r -- r might be E + -- Use this when r can't be E + foldV l e r = let a = foldU r + a' = f e a + in a `seq` a' `seq` foldrAVL' f a' l + -- Use this when r might be E + foldW l e E = foldrAVL' f e l + foldW l e (N rl re rr) = let a = foldV rl re rr -- rr can't be E + a' = f e a + in a `seq` a' `seq` foldrAVL' f a' l + foldW l e (Z rl re rr) = foldX l e rl re rr -- rr might be E + foldW l e (P rl re rr) = foldX l e rl re rr -- rr might be E + -- Common code for foldW (Z and P cases) + foldX l e rl re rr = let a = foldW rl re rr + a' = f e a + in a `seq` a' `seq` foldrAVL' f a' l + +-- | This fold is a hybrid between 'foldrAVL' and 'foldr1AVL'. As with 'foldr1AVL', it requires +-- a non-empty tree, but instead of treating the rightmost element as an initial value, it applies +-- a function to it (second function argument) and uses the result instead. This allows +-- a more flexible type for the main folding function (same type as that used by 'foldrAVL'). +-- As with 'foldrAVL' and 'foldr1AVL', this function is lazy, so it's best not to use it with functions +-- that are strict in their second argument. See 'foldr2AVL'' for a strict version. +-- +-- Complexity: O(n) +foldr2AVL :: (e -> a -> a) -> (e -> a) -> AVL e -> a +foldr2AVL f g = foldU where + foldU E = error "foldr2AVL: Empty Tree" + foldU (N l e r) = foldV l e r -- r can't be E + foldU (Z l e r) = foldW l e r -- r might be E + foldU (P l e r) = foldW l e r -- r might be E + -- Use this when r can't be E + foldV l e r = foldrAVL f (f e (foldU r)) l + -- Use this when r might be E + foldW l e E = foldrAVL f (g e) l + foldW l e (N rl re rr) = foldrAVL f (f e (foldV rl re rr)) l -- rr can't be E + foldW l e (Z rl re rr) = foldX l e rl re rr -- rr might be E + foldW l e (P rl re rr) = foldX l e rl re rr -- rr might be E + -- Common code for foldW (Z and P cases) + foldX l e rl re rr = foldrAVL f (f e (foldW rl re rr)) l + +-- | The strict version of 'foldr2AVL', which is useful for functions which are strict in their second +-- argument. The advantage of this version is that it reduces the stack use from the O(n) that the lazy +-- version gives (when used with strict functions) to O(log n). +-- +-- Complexity: O(n) +foldr2AVL' :: (e -> a -> a) -> (e -> a) -> AVL e -> a +foldr2AVL' f g = foldU where + foldU E = error "foldr2AVL': Empty Tree" + foldU (N l e r) = foldV l e r -- r can't be E + foldU (Z l e r) = foldW l e r -- r might be E + foldU (P l e r) = foldW l e r -- r might be E + -- Use this when r can't be E + foldV l e r = let a = foldU r + a' = f e a + in a `seq` a' `seq` foldrAVL' f a' l + -- Use this when r might be E + foldW l e E = let a = g e in a `seq` foldrAVL' f a l + foldW l e (N rl re rr) = let a = foldV rl re rr -- rr can't be E + a' = f e a + in a `seq` a' `seq` foldrAVL' f a' l + foldW l e (Z rl re rr) = foldX l e rl re rr -- rr might be E + foldW l e (P rl re rr) = foldX l e rl re rr -- rr might be E + -- Common code for foldW (Z and P cases) + foldX l e rl re rr = let a = foldW rl re rr + a' = f e a + in a `seq` a' `seq` foldrAVL' f a' l + + +-- | The AVL equivalent of 'foldl' on lists. This is a the lazy version (as lazy as the folding function +-- anyway). Using this version with a function that is strict in it's first argument will result in O(n) +-- stack use. See 'foldlAVL'' for a strict version. +-- +-- > foldlAVL f a avl = foldl f a (asListL avl) +-- +-- For example, the 'asListR' function could be defined.. +-- +-- > asListR = foldlAVL (flip (:)) [] +-- +-- Complexity: O(n) +foldlAVL :: (a -> e -> a) -> a -> AVL e -> a +foldlAVL f = foldU where + foldU a E = a + foldU a (N l e r) = foldV a l e r + foldU a (Z l e r) = foldV a l e r + foldU a (P l e r) = foldV a l e r + foldV a l e r = foldU (f (foldU a l) e) r + +-- | The strict version of 'foldlAVL', which is useful for functions which are strict in their first +-- argument. The advantage of this version is that it reduces the stack use from the O(n) that the lazy +-- version gives (when used with strict functions) to O(log n). +-- +-- Complexity: O(n) +foldlAVL' :: (a -> e -> a) -> a -> AVL e -> a +foldlAVL' f = foldU where + foldU a E = a + foldU a (N l e r) = foldV a l e r + foldU a (Z l e r) = foldV a l e r + foldU a (P l e r) = foldV a l e r + foldV a l e r = let a' = foldU a l + a'' = f a' e + in a' `seq` a'' `seq` foldU a'' r + +-- | The AVL equivalent of 'foldl1' on lists. This is a the lazy version (as lazy as the folding function +-- anyway). Using this version with a function that is strict in it's first argument will result in O(n) +-- stack use. See 'foldl1AVL'' for a strict version. +-- +-- > foldl1AVL f avl = foldl1 f (asListL avl) +-- +-- This function raises an error if the tree is empty. +-- +-- Complexity: O(n) +foldl1AVL :: (e -> e -> e) -> AVL e -> e +foldl1AVL f = foldU where + foldU E = error "foldl1AVL: Empty Tree" + foldU (N l e r) = foldW l e r -- l might be E + foldU (Z l e r) = foldW l e r -- l might be E + foldU (P l e r) = foldV l e r -- l can't be E + -- Use this when l can't be E + foldV l e r = foldlAVL f (f (foldU l) e) r + -- Use this when l might be E + foldW E e r = foldlAVL f e r + foldW (N ll le lr) e r = foldX ll le lr e r -- ll might be E + foldW (Z ll le lr) e r = foldX ll le lr e r -- ll might be E + foldW (P ll le lr) e r = foldlAVL f (f (foldV ll le lr) e) r -- ll can't be E + -- Common code for foldW (Z and P cases) + foldX ll le lr e r = foldlAVL f (f (foldW ll le lr) e) r + +-- | The strict version of 'foldl1AVL', which is useful for functions which are strict in their first +-- argument. The advantage of this version is that it reduces the stack use from the O(n) that the lazy +-- version gives (when used with strict functions) to O(log n). +-- +-- Complexity: O(n) +foldl1AVL' :: (e -> e -> e) -> AVL e -> e +foldl1AVL' f = foldU where + foldU E = error "foldl1AVL': Empty Tree" + foldU (N l e r) = foldW l e r -- l might be E + foldU (Z l e r) = foldW l e r -- l might be E + foldU (P l e r) = foldV l e r -- l can't be E + -- Use this when l can't be E + foldV l e r = let a = foldU l + a' = f a e + in a `seq` a' `seq` foldlAVL' f a' r + -- Use this when l might be E + foldW E e r = foldlAVL' f e r + foldW (N ll le lr) e r = foldX ll le lr e r -- ll might be E + foldW (Z ll le lr) e r = foldX ll le lr e r -- ll might be E + foldW (P ll le lr) e r = let a = foldV ll le lr -- ll can't be E + a' = f a e + in a `seq` a' `seq` foldlAVL' f a' r + -- Common code for foldW (Z and P cases) + foldX ll le lr e r = let a = foldW ll le lr + a' = f a e + in a `seq` a' `seq` foldlAVL' f a' r + +-- | This fold is a hybrid between 'foldlAVL' and 'foldl1AVL'. As with 'foldl1AVL', it requires +-- a non-empty tree, but instead of treating the leftmost element as an initial value, it applies +-- a function to it (second function argument) and uses the result instead. This allows +-- a more flexible type for the main folding function (same type as that used by 'foldlAVL'). +-- As with 'foldlAVL' and 'foldl1AVL', this function is lazy, so it's best not to use it with functions +-- that are strict in their first argument. See 'foldl2AVL'' for a strict version. +-- +-- Complexity: O(n) +foldl2AVL :: (a -> e -> a) -> (e -> a) -> AVL e -> a +foldl2AVL f g = foldU where + foldU E = error "foldl2AVL: Empty Tree" + foldU (N l e r) = foldW l e r -- l might be E + foldU (Z l e r) = foldW l e r -- l might be E + foldU (P l e r) = foldV l e r -- l can't be E + -- Use this when l can't be E + foldV l e r = foldlAVL f (f (foldU l) e) r + -- Use this when l might be E + foldW E e r = foldlAVL f (g e) r + foldW (N ll le lr) e r = foldX ll le lr e r -- ll might be E + foldW (Z ll le lr) e r = foldX ll le lr e r -- ll might be E + foldW (P ll le lr) e r = foldlAVL f (f (foldV ll le lr) e) r -- ll can't be E + -- Common code for foldW (Z and P cases) + foldX ll le lr e r = foldlAVL f (f (foldW ll le lr) e) r + +-- | The strict version of 'foldl2AVL', which is useful for functions which are strict in their first +-- argument. The advantage of this version is that it reduces the stack use from the O(n) that the lazy +-- version gives (when used with strict functions) to O(log n). +-- +-- Complexity: O(n) +foldl2AVL' :: (a -> e -> a) -> (e -> a) -> AVL e -> a +foldl2AVL' f g = foldU where + foldU E = error "foldl2AVL': Empty Tree" + foldU (N l e r) = foldW l e r -- l might be E + foldU (Z l e r) = foldW l e r -- l might be E + foldU (P l e r) = foldV l e r -- l can't be E + -- Use this when l can't be E + foldV l e r = let a = foldU l + a' = f a e + in a `seq` a' `seq` foldlAVL' f a' r + -- Use this when l might be E + foldW E e r = let a = g e in a `seq` foldlAVL' f a r + foldW (N ll le lr) e r = foldX ll le lr e r -- ll might be E + foldW (Z ll le lr) e r = foldX ll le lr e r -- ll might be E + foldW (P ll le lr) e r = let a = foldV ll le lr -- ll can't be E + a' = f a e + in a `seq` a' `seq` foldlAVL' f a' r + -- Common code for foldW (Z and P cases) + foldX ll le lr e r = let a = foldW ll le lr + a' = f a e + in a `seq` a' `seq` foldlAVL' f a' r + +-- | This is a specialised version of 'foldrAVL'' for use with an +-- /unboxed/ Int accumulator (with GHC). Defaults to boxed Int +-- for other Haskells. +-- +-- Complexity: O(n) +foldrAVL_UINT :: (e -> UINT -> UINT) -> UINT -> AVL e -> UINT +#ifdef __GLASGOW_HASKELL__ +foldrAVL_UINT f = foldU where + foldU a E = a + foldU a (N l e r) = foldV a l e r + foldU a (Z l e r) = foldV a l e r + foldU a (P l e r) = foldV a l e r + foldV a l e r = foldU (f e (foldU a r)) l +#else +foldrAVL_UINT = foldrAVL' -- Strict version! +{-# INLINE foldrAVL_UINT #-} +#endif + +-- | The AVL equivalent of 'Data.List.mapAccumL' on lists. +-- It behaves like a combination of 'mapAVL' and 'foldlAVL'. +-- It applies a function to each element of a tree, passing an accumulating parameter from +-- left to right, and returning a final value of this accumulator together with the new tree. +-- +-- Using this version with a function that is strict in it's first argument will result in +-- O(n) stack use. See 'mapAccumLAVL'' for a strict version. +-- +-- Complexity: O(n) +mapAccumLAVL :: (z -> a -> (z, b)) -> z -> AVL a -> (z, AVL b) +mapAccumLAVL f z ta = case mapAL z ta of + UBT2(zt,tb) -> (zt,tb) + where mapAL z_ E = UBT2(z_,E) + mapAL z_ (N la a ra) = mapAL' z_ N la a ra + mapAL z_ (Z la a ra) = mapAL' z_ Z la a ra + mapAL z_ (P la a ra) = mapAL' z_ P la a ra + {-# INLINE mapAL' #-} + mapAL' z' c la a ra = case mapAL z' la of + UBT2(zl,lb) -> let (za,b) = f zl a + in case mapAL za ra of + UBT2(zr,rb) -> UBT2(zr, c lb b rb) + +-- | This is a strict version of 'mapAccumLAVL', which is useful for functions which +-- are strict in their first argument. The advantage of this version is that it reduces +-- the stack use from the O(n) that the lazy version gives (when used with strict functions) +-- to O(log n). +-- +-- Complexity: O(n) +mapAccumLAVL' :: (z -> a -> (z, b)) -> z -> AVL a -> (z, AVL b) +mapAccumLAVL' f z ta = case mapAL z ta of + UBT2(zt,tb) -> (zt,tb) + where mapAL z_ E = UBT2(z_,E) + mapAL z_ (N la a ra) = mapAL' z_ N la a ra + mapAL z_ (Z la a ra) = mapAL' z_ Z la a ra + mapAL z_ (P la a ra) = mapAL' z_ P la a ra + {-# INLINE mapAL' #-} + mapAL' z' c la a ra = case mapAL z' la of + UBT2(zl,lb) -> case f zl a of + (za,b) -> case mapAL za ra of + UBT2(zr,rb) -> UBT2(zr, c lb b rb) + + +-- | The AVL equivalent of 'Data.List.mapAccumR' on lists. +-- It behaves like a combination of 'mapAVL' and 'foldrAVL'. +-- It applies a function to each element of a tree, passing an accumulating parameter from +-- right to left, and returning a final value of this accumulator together with the new tree. +-- +-- Using this version with a function that is strict in it's first argument will result in +-- O(n) stack use. See 'mapAccumRAVL'' for a strict version. +-- +-- Complexity: O(n) +mapAccumRAVL :: (z -> a -> (z, b)) -> z -> AVL a -> (z, AVL b) +mapAccumRAVL f z ta = case mapAR z ta of + UBT2(zt,tb) -> (zt,tb) + where mapAR z_ E = UBT2(z_,E) + mapAR z_ (N la a ra) = mapAR' z_ N la a ra + mapAR z_ (Z la a ra) = mapAR' z_ Z la a ra + mapAR z_ (P la a ra) = mapAR' z_ P la a ra + {-# INLINE mapAR' #-} + mapAR' z' c la a ra = case mapAR z' ra of + UBT2(zr,rb) -> let (za,b) = f zr a + in case mapAR za la of + UBT2(zl,lb) -> UBT2(zl, c lb b rb) + +-- | This is a strict version of 'mapAccumRAVL', which is useful for functions which +-- are strict in their first argument. The advantage of this version is that it reduces +-- the stack use from the O(n) that the lazy version gives (when used with strict functions) +-- to O(log n). +-- +-- Complexity: O(n) +mapAccumRAVL' :: (z -> a -> (z, b)) -> z -> AVL a -> (z, AVL b) +mapAccumRAVL' f z ta = case mapAR z ta of + UBT2(zt,tb) -> (zt,tb) + where mapAR z_ E = UBT2(z_,E) + mapAR z_ (N la a ra) = mapAR' z_ N la a ra + mapAR z_ (Z la a ra) = mapAR' z_ Z la a ra + mapAR z_ (P la a ra) = mapAR' z_ P la a ra + {-# INLINE mapAR' #-} + mapAR' z' c la a ra = case mapAR z' ra of + UBT2(zr,rb) -> case f zr a of + (za,b) -> case mapAR za la of + UBT2(zl,lb) -> UBT2(zl, c lb b rb) + +------------------------------------------------------------------------------------------------ +-- These two functions attempt to make the strict mapAccums more efficient and reduce heap +-- burn rate with ghc by using an accumulating function that returns an unboxed pair. +------------------------------------------------------------------------------------------------ +#ifdef __GLASGOW_HASKELL__ +-- | Glasgow Haskell only. Similar to 'mapAccumLAVL'' but uses an unboxed pair in the +-- accumulating function. +-- +-- Complexity: O(n) +mapAccumLAVL'' + :: (z -> a -> UBT2(z, b)) -> z -> AVL a -> (z, AVL b) +mapAccumLAVL'' f z ta = case mapAL z ta of + UBT2(zt,tb) -> (zt,tb) + where mapAL z_ E = UBT2(z_,E) + mapAL z_ (N la a ra) = mapAL' z_ N la a ra + mapAL z_ (Z la a ra) = mapAL' z_ Z la a ra + mapAL z_ (P la a ra) = mapAL' z_ P la a ra + {-# INLINE mapAL' #-} + mapAL' z' c la a ra = case mapAL z' la of + UBT2(zl,lb) -> case f zl a of + UBT2(za,b) -> case mapAL za ra of + UBT2(zr,rb) -> UBT2(zr, c lb b rb) + +-- | Glasgow Haskell only. Similar to 'mapAccumRAVL'' but uses an unboxed pair in the +-- accumulating function. +-- +-- Complexity: O(n) +mapAccumRAVL'' + :: (z -> a -> UBT2(z, b)) -> z -> AVL a -> (z, AVL b) +mapAccumRAVL'' f z ta = case mapAR z ta of + UBT2(zt,tb) -> (zt,tb) + where mapAR z_ E = UBT2(z_,E) + mapAR z_ (N la a ra) = mapAR' z_ N la a ra + mapAR z_ (Z la a ra) = mapAR' z_ Z la a ra + mapAR z_ (P la a ra) = mapAR' z_ P la a ra + {-# INLINE mapAR' #-} + mapAR' z' c la a ra = case mapAR z' ra of + UBT2(zr,rb) -> case f zr a of + UBT2(za,b) -> case mapAR za la of + UBT2(zl,lb) -> UBT2(zl, c lb b rb) + +#endif +------------------------------------------------------------------------------------------------ +------------------------------------------------------------------------------------------------ + +-- | Convert a list of known length into an AVL tree, such that the head of the list becomes +-- the leftmost tree element. The resulting tree is flat (and also sorted if the supplied list +-- is sorted in ascending order). +-- +-- If the actual length of the list is not the same as the supplied length then +-- an error will be raised. +-- +-- Complexity: O(n) +asTreeLenL :: Int -> [e] -> AVL e +asTreeLenL n es = case subst (replicateAVL n ()) es of + UBT2(tree,es_) -> case es_ of + [] -> tree + _ -> error "asTreeLenL: List too long." + where + -- Substitute template values for real values taken from the list + subst E as = UBT2(E,as) + subst (N l _ r) as = subst' N l r as + subst (Z l _ r) as = subst' Z l r as + subst (P l _ r) as = subst' P l r as + {-# INLINE subst' #-} + subst' f l r as = case subst l as of + UBT2(l_,xs) -> case xs of + a:as' -> case subst r as' of + UBT2(r_,as__) -> let t_ = f l_ a r_ + in t_ `seq` UBT2(t_,as__) + [] -> error "asTreeLenL: List too short." + + +-- | As 'asTreeLenL', except the length of the list is calculated internally, not supplied +-- as an argument. +-- +-- Complexity: O(n) +asTreeL :: [e] -> AVL e +asTreeL es = asTreeLenL (length es) es + +-- | Convert a list of known length into an AVL tree, such that the head of the list becomes +-- the rightmost tree element. The resulting tree is flat (and also sorted if the supplied list +-- is sorted in descending order). +-- +-- If the actual length of the list is not the same as the supplied length then +-- an error will be raised. +-- +-- Complexity: O(n) +asTreeLenR :: Int -> [e] -> AVL e +asTreeLenR n es = case subst (replicateAVL n ()) es of + UBT2(tree,es_) -> case es_ of + [] -> tree + _ -> error "asTreeLenR: List too long." + where + -- Substitute template values for real values taken from the list + subst E as = UBT2(E,as) + subst (N l _ r) as = subst' N l r as + subst (Z l _ r) as = subst' Z l r as + subst (P l _ r) as = subst' P l r as + {-# INLINE subst' #-} + subst' f l r as = case subst r as of + UBT2(r_,xs) -> case xs of + a:as' -> case subst l as' of + UBT2(l_,as__) -> let t_ = f l_ a r_ + in t_ `seq` UBT2(t_,as__) + [] -> error "asTreeLenR: List too short." + +-- | As 'asTreeLenR', except the length of the list is calculated internally, not supplied +-- as an argument. +-- +-- Complexity: O(n) +asTreeR :: [e] -> AVL e +asTreeR es = asTreeLenR (length es) es + +-- | Reverse an AVL tree (swaps and reverses left and right sub-trees). +-- The resulting tree is the mirror image of the original. +-- +-- Complexity: O(n) +reverseAVL :: AVL e -> AVL e +reverseAVL E = E +reverseAVL (N l e r) = let l' = reverseAVL l + r' = reverseAVL r + in l' `seq` r' `seq` P r' e l' +reverseAVL (Z l e r) = let l' = reverseAVL l + r' = reverseAVL r + in l' `seq` r' `seq` Z r' e l' +reverseAVL (P l e r) = let l' = reverseAVL l + r' = reverseAVL r + in l' `seq` r' `seq` N r' e l' + +-- | Apply a function to every element in an AVL tree. This function preserves the tree shape. +-- There is also a strict version of this function ('mapAVL''). +-- +-- N.B. If the tree is sorted the result of this operation will only be sorted if +-- the applied function preserves ordering (for some suitable ordering definition). +-- +-- Complexity: O(n) +mapAVL :: (a -> b) -> AVL a -> AVL b +mapAVL f = map' where + map' E = E + map' (N l a r) = let l' = map' l + r' = map' r + in l' `seq` r' `seq` N l' (f a) r' + map' (Z l a r) = let l' = map' l + r' = map' r + in l' `seq` r' `seq` Z l' (f a) r' + map' (P l a r) = let l' = map' l + r' = map' r + in l' `seq` r' `seq` P l' (f a) r' + +-- | Similar to 'mapAVL', but the supplied function is applied strictly. +-- +-- Complexity: O(n) +mapAVL' :: (a -> b) -> AVL a -> AVL b +mapAVL' f = map' where + map' E = E + map' (N l a r) = let l' = map' l + r' = map' r + b = f a + in b `seq` l' `seq` r' `seq` N l' b r' + map' (Z l a r) = let l' = map' l + r' = map' r + b = f a + in b `seq` l' `seq` r' `seq` Z l' b r' + map' (P l a r) = let l' = map' l + r' = map' r + b = f a + in b `seq` l' `seq` r' `seq` P l' b r' + +#if __GLASGOW_HASKELL__ > 604 +traverseAVL :: Applicative f => (a -> f b) -> AVL a -> f (AVL b) +traverseAVL _f E = pure E +traverseAVL f (N l v r) = N <$> traverseAVL f l <*> f v <*> traverseAVL f r +traverseAVL f (Z l v r) = Z <$> traverseAVL f l <*> f v <*> traverseAVL f r +traverseAVL f (P l v r) = P <$> traverseAVL f l <*> f v <*> traverseAVL f r +#endif + +-- | Construct a flat AVL tree of size n (n>=0), where all elements are identical. +-- +-- Complexity: O(log n) +replicateAVL :: Int -> e -> AVL e +replicateAVL m e = rep m where -- Functional spaghetti follows :-) + rep n | odd n = repOdd n -- n is odd , >=1 + rep n = repEvn n -- n is even, >=0 + -- n is known to be odd (>=1), so left and right sub-trees are identical + repOdd n = let sub = rep (n `shiftR` 1) in sub `seq` Z sub e sub + -- n is known to be even (>=0) + repEvn n | n .&. (n-1) == 0 = repP2 n -- treat exact powers of 2 specially, traps n=0 too + repEvn n = let nl = n `shiftR` 1 -- size of left subtree (odd or even) + nr = nl - 1 -- size of right subtree (even or odd) + in if odd nr + then let l = repEvn nl -- right sub-tree is odd , so left is even (>=2) + r = repOdd nr + in l `seq` r `seq` Z l e r + else let l = repOdd nl -- right sub-tree is even, so left is odd (>=2) + r = repEvn nr + in l `seq` r `seq` Z l e r + -- n is an exact power of 2 (or 0), I.E. 0,1,2,4,8,16.. + repP2 0 = E + repP2 1 = Z E e E + repP2 n = let nl = n `shiftR` 1 -- nl is also an exact power of 2 + nr = nl - 1 -- nr is one less that an exact power of 2 + l = repP2 nl + r = repP2M1 nr + in l `seq` r `seq` P l e r -- BF=+1 + -- n is one less than an exact power of 2, I.E. 0,1,3,7,15.. + repP2M1 0 = E + repP2M1 n = let sub = repP2M1 (n `shiftR` 1) in sub `seq` Z sub e sub + +-- | Flatten an AVL tree, preserving the ordering of the tree elements. +-- +-- Complexity: O(n) +flatten :: AVL e -> AVL e +flatten t = asTreeLenL (size t) (asListL t) + +-- | Similar to 'flatten', but the tree elements are reversed. This function has higher constant +-- factor overhead than 'reverseAVL'. +-- +-- Complexity: O(n) +flatReverse :: AVL e -> AVL e +flatReverse t = asTreeLenL (size t) (asListR t) + +-- | Similar to 'mapAVL', but the resulting tree is flat. +-- This function has higher constant factor overhead than 'mapAVL'. +-- +-- Complexity: O(n) +flatMap :: (a -> b) -> AVL a -> AVL b +flatMap f t = asTreeLenL (size t) (map f (asListL t)) + +-- | Same as 'flatMap', but the supplied function is applied strictly. +-- +-- Complexity: O(n) +flatMap' :: (a -> b) -> AVL a -> AVL b +flatMap' f t = asTreeLenL (size t) (map' f (asListL t)) where + map' _ [] = [] + map' g (a:as) = let b = g a in b `seq` (b : map' f as) + +-- | Remove all AVL tree elements which do not satisfy the supplied predicate. +-- Element ordering is preserved. The resulting tree is flat. +-- See 'filterAVL' for an alternative implementation which is probably more efficient. +-- +-- Complexity: O(n) +filterViaList :: (e -> Bool) -> AVL e -> AVL e +filterViaList p t = filter' [] 0 (asListR t) where + filter' se n [] = asTreeLenL n se + filter' se n (e:es) = if p e then let n'=n+1 in n' `seq` filter' (e:se) n' es + else filter' se n es + +-- | Remove all AVL tree elements which do not satisfy the supplied predicate. +-- Element ordering is preserved. +-- +-- Complexity: O(n) +filterAVL :: (e -> Bool) -> AVL e -> AVL e +filterAVL p t0 = case filter_ L(0) t0 of UBT3(_,t_,_) -> t_ -- Work with relative heights!! + where filter_ h t = case t of + E -> UBT3(False,E,h) + N l e r -> f l DECINT2(h) e r DECINT1(h) + Z l e r -> f l DECINT1(h) e r DECINT1(h) + P l e r -> f l DECINT1(h) e r DECINT2(h) + where f l hl e r hr = case filter_ hl l of + UBT3(bl,l_,hl_) -> case filter_ hr r of + UBT3(br,r_,hr_) -> if p e + then if bl || br + then case spliceH l_ hl_ e r_ hr_ of + UBT2(t_,h_) -> UBT3(True,t_,h_) + else UBT3(False,t,h) + else case joinH l_ hl_ r_ hr_ of + UBT2(t_,h_) -> UBT3(True,t_,h_) + +-- | Partition an AVL tree using the supplied predicate. The first AVL tree in the +-- resulting pair contains all elements for which the predicate is True, the second +-- contains all those for which the predicate is False. Element ordering is preserved. +-- Both of the resulting trees are flat. +-- +-- Complexity: O(n) +partitionAVL :: (e -> Bool) -> AVL e -> (AVL e, AVL e) +partitionAVL p t = part 0 [] 0 [] (asListR t) where + part nT lstT nF lstF [] = let avlT = asTreeLenL nT lstT + avlF = asTreeLenL nF lstF + in (avlT,avlF) -- Non strict in avlT, avlF !! + part nT lstT nF lstF (e:es) = if p e then let nT'=nT+1 in nT' `seq` part nT' (e:lstT) nF lstF es + else let nF'=nF+1 in nF' `seq` part nT lstT nF' (e:lstF) es + +-- | Remove all AVL tree elements for which the supplied function returns 'Nothing'. +-- Element ordering is preserved. The resulting tree is flat. +-- See 'mapMaybeAVL' for an alternative implementation which is probably more efficient. +-- +-- Complexity: O(n) +mapMaybeViaList :: (a -> Maybe b) -> AVL a -> AVL b +mapMaybeViaList f t = map' [] 0 (asListR t) where + map' sb n [] = asTreeLenL n sb + map' sb n (a:as) = case f a of + Just b -> let n'=n+1 in n' `seq` map' (b:sb) n' as + Nothing -> map' sb n as + +-- | Remove all AVL tree elements for which the supplied function returns 'Nothing'. +-- Element ordering is preserved. +-- +-- Complexity: O(n) +mapMaybeAVL :: (a -> Maybe b) -> AVL a -> AVL b +mapMaybeAVL f t0 = case mapMaybe_ L(0) t0 of UBT2(t_,_) -> t_ -- Work with relative heights!! + where mapMaybe_ h t = case t of + E -> UBT2(E,h) + N l a r -> m l DECINT2(h) a r DECINT1(h) + Z l a r -> m l DECINT1(h) a r DECINT1(h) + P l a r -> m l DECINT1(h) a r DECINT2(h) + where m l hl a r hr = case mapMaybe_ hl l of + UBT2(l_,hl_) -> case mapMaybe_ hr r of + UBT2(r_,hr_) -> case f a of + Just b -> spliceH l_ hl_ b r_ hr_ + Nothing -> joinH l_ hl_ r_ hr_ + +-- | Invokes 'genPushList' on the empty AVL tree. +-- +-- Complexity: O(n.(log n)) +{-# INLINE genAsTree #-} +genAsTree :: (e -> e -> COrdering e) -> [e] -> AVL e +genAsTree c = genPushList c empty + +-- | Push the elements of an unsorted List in a sorted AVL tree using the supplied combining comparison. +-- +-- Complexity: O(n.(log (m+n))) where n is the list length, m is the tree size. +genPushList :: (e -> e -> COrdering e) -> AVL e -> [e] -> AVL e +genPushList c avl = foldl' addElem avl + where addElem t e = genPush (c e) e t + +-- | Uses the supplied combining comparison to sort list elements into ascending order. +-- Multiple occurences of the same element are eliminated (they are combined in some way). +-- +-- @'genSortAscending' c = 'asListL' . 'genAsTree' c@ +-- +-- Complexity: O(n.(log n)) +{-# INLINE genSortAscending #-} +genSortAscending :: (e -> e -> COrdering e) -> [e] -> [e] +genSortAscending c = asListL . genAsTree c + +-- | Uses the supplied combining comparison to sort list elements into descending order. +-- Multiple occurences of the same element are eliminated (they are combined in some way). +-- +-- @'genSortDescending' c = 'asListR' . 'genAsTree' c@ +-- +-- Complexity: O(n.(log n)) +{-# INLINE genSortDescending #-} +genSortDescending :: (e -> e -> COrdering e) -> [e] -> [e] +genSortDescending c = asListR . genAsTree c + + diff --git a/Data/Tree/AVL/Push.hs b/Data/Tree/AVL/Push.hs new file mode 100644 --- /dev/null +++ b/Data/Tree/AVL/Push.hs @@ -0,0 +1,715 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Data.Tree.AVL.Push +-- Copyright : (c) Adrian Hey 2004,2005 +-- License : BSD3 +-- +-- Maintainer : http://homepages.nildram.co.uk/~ahey/em.png +-- Stability : stable +-- Portability : portable +----------------------------------------------------------------------------- +module Data.Tree.AVL.Push +(-- * \"Pushing\" new elements into AVL trees + -- | \"Pushing\" is another word for insertion. (c.f \"Popping\".) + + -- ** Pushing on extreme left or right + pushL,pushR, + + -- ** Pushing on /sorted/ AVL trees + genPush,genPush',genPushMaybe,genPushMaybe', +) where + +import Prelude -- so haddock finds the symbols there + +import Data.COrdering +import Data.Tree.AVL.Types(AVL(..)) +import Data.Tree.AVL.Internals.BinPath(BinPath(..),genOpenPathWith,writePath,insertPath) + +{------------------------------------------------------------------------------------------------------------------------------ + -------------------------------------- Notes about Insertion and Rebalancing ------------------------------------------------- + ------------------------------------------------------------------------------------------------------------------------------ + If we forget about tree rebalancing, and consider what changes in BF tell us about changes in H + under ordinary circumstances, we can make the following observations: + + (1) Insertion can never reduce the height of a (sub)tree. + (2) Insertion can only change the height of a (sub)tree by +1 at most. Therefore the BF of the + root can change by +/- 1 most. + (2) If insertion changes the BF from 0 -> +/- 1, then this must be because either the left or + right subtrees has grown in height by 1. Since they were equal before (BF=0), the overall + height of the root must also have grown by 1. + (3) If insertion changes the BF from +/-1 -> 0, then this must be because one either the left + or right subtree has grown by 1 so that it is now equal in height to the opposing subtree. + Since height of the root is determined by the maximum height of the subtrees, it is left + unchanged. + (4) If insertion leaves the BF unchanged, then this must be because the height of neither + subtree has changed. Therefore the height of the root is left unchanged. + (5) It follows from (2) and (3), that changes in height, and hence BF can (and will) propogate + up the tree (along the insertion path) as far as the first node with non-zero BF, and no further. + (6) If insertion changes the BF from +/-1 -> +/-2 then we have a problem. This is dealt with by + one of four possible rebalancing 'rotations' (there are two possiblities for each of the left + and right subtrees). However, it's appropriate to mention an important property of the rotations + now. The net effect of unbalancing and rebalancing is to give the root BF=0 and leave the height + unchanged. So the combined effect of the unbalance-rebalance operation appears like a special + case of (3). Another important property of rebalancing is that it /preserves/ the tree sorting. + (7) It follows from (6) and (5) any single insertion will cause most one unbalance-rebalance operation. + + So in summary we have a set of rules to enable us to infer changes in height of a subtree (if any) from + changes in the BF of the subtree, and hence the changes (if any) in the BF of the root. The rules are: + BF 0 -> +/-1, height increased by 1 + BF +/-1 -> 0, height unchanged. + BF unchanged , height unchanged. + BF +/-1 -> -/+1, NEVER OCCURS + + It should also be observed that these observations and rules apply to INSERTION only (not deletion). + +Rebalancing: CASE RR +-------------------- + Consider inserting into the right subtree of the right subtree (RR subtree). From the obsevations above we can + say this is only going to unbalance the root if: + The height of the RR subtree is increased by 1 (we determine this from looking at changes in it's BF) + ..and.. The right subtree has BF=0 prior to insertion (observation 5) + ..and.. THe root has BF=-1 prior to insertion (observation 2) + + In pictures.. + + ----- ----- ----- + | B | | B | | D | + |H=h+2| |H=h+3| |H=h+2| <- Note + |BF=-1| |BF=-2| <-- Unbalanced! |BF= 0| <- Note + /-----\ /-----\ /-----\ + / \ / \ / \ + / \ / \ / \ + -----/ \----- -----/ \----- -----/ \----- + | A | | D | E grows | A | | D | Rebalance | B | | E | + | H=h | |H=h+1| by 1 | H=h | |H=h+2| --------> |H=h+1| |H=h+1| + | | |BF= 0| ------> | | |BF=-1| |BF= 0| | | + ----- /-----\ h -> h+1 ----- /-----\ /-----\ ----- + / \ / \ / \ + / \ / \ / \ + -----/ \----- -----/ \----- -----/ \----- + | C | | E | | C | | E | | A | | C | + | H=h | | H=h | | H=h | |H=h+1| | H=h | | H=h | + | | | | | | | | | | | | + ----- ----- ----- ----- ----- ----- + + Unfortunately, if you try this for insertion into the right left subtree (C) it doesn't work. To deal with + this case we need a more complicated re-balancing rotation involving 3 nodes. There are 2 distinct cases, which + both use the same rotation, but details re. BF and H are different. + +Rebalancing: CASE RL(1) +----------------------- + + ----- ----- ----- + | B | | B | | D | + |H=h+3| |H=h+4| |H=h+3| <- Note + |BF=-1| |BF=-2| <-- Unbalanced! |BF= 0| <- Note + /-----\ /-----\ /-----\ + / \ / \ / \ + / \ / \ / \ + -----/ \----- -----/ \----- / \ + | A | | F | E grows | A | | F | Rebalance -----/ \----- + |H=h+1| |H=h+2| by 1 |H=h+1| |H=h+3| --------> | B | | F | + | | |BF= 0| ------> | | |BF=+1| |H=h+2| |H=h+2| + ----- /-----\ h -> h+1 ----- /-----\ |BF=+1| |BF= 0| + / \ / \ -----/-----\----- -----/-----\----- + / \ / \ | A | | C | | E | | G | + -----/ \----- -----/ \----- |H=h+1| | H=h | |H=h+1| |H=h+1| + | D | | G | | D | | G | | | | | | | | | + |H=h+1| |H=h+1| |H=h+2| |H=h+1| ----- ----- ----- ----- + |BF= 0| | | |BF=-1| | | + /-----\ ----- /-----\ ----- + / \ / \ + / \ / \ + -----/ \----- -----/ \----- + | C | | E | | C | | E | + | H=h | | H=h | | H=h | |H=h+1| + | | | | | | | | + ----- ----- ----- ----- + +Rebalancing: CASE RL(2) +----------------------- + + ----- ----- ----- + | B | | B | | D | + |H=h+3| |H=h+4| |H=h+3| <- Note + |BF=-1| |BF=-2| <-- Unbalanced! |BF= 0| <- Note + /-----\ /-----\ /-----\ + / \ / \ / \ + / \ / \ / \ + -----/ \----- -----/ \----- / \ + | A | | F | C grows | A | | F | Rebalance -----/ \----- + |H=h+1| |H=h+2| by 1 |H=h+1| |H=h+3| --------> | B | | F | + | | |BF= 0| ------> | | |BF=+1| |H=h+2| |H=h+2| + ----- /-----\ h -> h+1 ----- /-----\ |BF= 0| |BF=-1| + / \ / \ -----/-----\----- -----/-----\----- + / \ / \ | A | | C | | E | | G | + -----/ \----- -----/ \----- |H=h+1| |H=h+1| | H=h | |H=h+1| + | D | | G | | D | | G | | | | | | | | | + |H=h+1| |H=h+1| |H=h+2| |H=h+1| ----- ----- ----- ----- + |BF= 0| | | |BF=+1| | | + /-----\ ----- /-----\ ----- + / \ / \ + / \ / \ + -----/ \----- -----/ \----- + | C | | E | | C | | E | + | H=h | | H=h | |H=h+1| | H=h | + | | | | | | | | + ----- ----- ----- ----- +----------------------------------------------------------------------------------------------------------------------------- +-----------------------------------------------------------------------------------------------------------------------------} + +-- | General push. This function searches the AVL tree using the supplied selector. If a matching element +-- is found it's replaced by the value (@e@) returned in the @('Eq' e)@ constructor returned by the selector. +-- If no match is found then the default element value is added at in the appropriate position in the tree. +-- +-- Note that for this to work properly requires that the selector behave as if it were comparing the +-- (potentially) new default element with existing tree elements, even if it isn't. +-- +-- Note also that this function is /non-strict/ in it\'s second argument (the default value which +-- is inserted if the search fails or is discarded if the search succeeds). If you want +-- to force evaluation, but only if it\'s actually incorprated in the tree, then use 'genPush'' +-- +-- Complexity: O(log n) +genPush :: (e -> COrdering e) -> e -> AVL e -> AVL e +genPush c e0 = put where -- there now follows a huge collection of functions requiring + -- pattern matching from hell in which c and e0 are free variables +-- This may look longwinded, it's been done this way to.. +-- * Avoid doing case analysis on the same node more than once. +-- * Minimise heap burn rate (by avoiding explicit rebalancing operations). + ----------------------------- LEVEL 0 --------------------------------- + -- put -- + ----------------------------------------------------------------------- + put E = Z E e0 E + put (N l e r) = putN l e r + put (Z l e r) = putZ l e r + put (P l e r) = putP l e r + + ----------------------------- LEVEL 1 --------------------------------- + -- putN, putZ, putP -- + ----------------------------------------------------------------------- + + -- Put in (N l e r), BF=-1 , (never returns P) + putN l e r = case c e of + Lt -> putNL l e r -- 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 "genPush: Bug0" -- impossible + Z _ _ _ -> N l' e r -- L subtree BF:0-> 0, H:h->h , parent BF:-1->-1 + _ -> Z l' e r -- L subtree BF:0->+/-1, H:h->h+1, parent BF:-1-> 0 + + -- (putZL l e r): Put in L subtree of (Z l e r), BF= 0 (Never requires rebalancing) , (never returns N) + {-# INLINE putZL #-} + putZL E e r = P (Z E e0 E ) e r -- L subtree H:0->1, parent BF: 0->+1 + putZL (N ll le lr) e r = let l' = putN ll le lr -- L subtree BF<>0, H:h->h, parent BF: 0-> 0 + in l' `seq` Z l' e r + putZL (P ll le lr) e r = let l' = putP ll le lr -- L subtree BF<>0, H:h->h, parent BF: 0-> 0 + in l' `seq` Z l' e r + putZL (Z ll le lr) e r = let l' = putZ ll le lr -- L subtree BF= 0, so need to look for changes + in case l' of + E -> error "genPush: Bug1" -- impossible + Z _ _ _ -> Z l' e r -- L subtree BF: 0-> 0, H:h->h , parent BF: 0-> 0 + _ -> P l' e r -- L subtree BF: 0->+/-1, H:h->h+1, parent BF: 0->+1 + + -- (putZR l e r): Put in R subtree of (Z l e r), BF= 0 (Never requires rebalancing) , (never returns P) + {-# INLINE putZR #-} + putZR l e E = N l e (Z E e0 E ) -- R subtree H:0->1, parent BF: 0->-1 + putZR l e (N rl re rr) = let r' = putN rl re rr -- R subtree BF<>0, H:h->h, parent BF: 0-> 0 + in r' `seq` Z l e r' + putZR l e (P rl re rr) = let r' = putP rl re rr -- R subtree BF<>0, H:h->h, parent BF: 0-> 0 + in r' `seq` Z l e r' + putZR l e (Z rl re rr) = let r' = putZ rl re rr -- R subtree BF= 0, so need to look for changes + in case r' of + E -> error "genPush: Bug2" -- impossible + Z _ _ _ -> Z l e r' -- R subtree BF: 0-> 0, H:h->h , parent BF: 0-> 0 + _ -> N l e r' -- R subtree BF: 0->+/-1, H:h->h+1, parent BF: 0->-1 + + -- (putPR l e r): Put in R subtree of (P l e r), BF=+1 (Never requires rebalancing) , (never returns N) + {-# INLINE putPR #-} + putPR l e E = Z l e (Z E e0 E ) -- R subtree empty, H:0->1, parent BF:+1-> 0 + putPR l e (N rl re rr) = let r' = putN rl re rr -- R subtree BF<>0, H:h->h, parent BF:+1->+1 + in r' `seq` P l e r' + putPR l e (P rl re rr) = let r' = putP rl re rr -- R subtree BF<>0, H:h->h, parent BF:+1->+1 + in r' `seq` P l e r' + putPR l e (Z rl re rr) = let r' = putZ rl re rr -- R subtree BF= 0, so need to look for changes + in case r' of + E -> error "genPush: Bug3" -- impossible + Z _ _ _ -> P l e r' -- R subtree BF:0-> 0, H:h->h , parent BF:+1->+1 + _ -> Z l e r' -- R subtree BF:0->+/-1, H:h->h+1, parent BF:+1-> 0 + + -------- These 2 cases (NR and PL) may need rebalancing if they go to LEVEL 3 --------- + + -- (putNR l e r): Put in R subtree of (N l e r), BF=-1 , (never returns P) + {-# INLINE putNR #-} + putNR _ _ E = error "genPush: Bug4" -- impossible if BF=-1 + putNR l e (N rl re rr) = let r' = putN rl re rr -- R subtree BF<>0, H:h->h, parent BF:-1->-1 + in r' `seq` N l e r' + putNR l e (P rl re rr) = let r' = putP rl re rr -- R subtree BF<>0, H:h->h, parent BF:-1->-1 + in r' `seq` N l e r' + putNR l e (Z rl re rr) = case c re of -- determine if RR or RL + Lt -> putNRL l e rl re rr -- RL (never returns P) + Eq re' -> N l e (Z rl re' rr) -- new re + Gt -> putNRR l e rl re rr -- RR (never returns P) + + -- (putPL l e r): Put in L subtree of (P l e r), BF=+1 , (never returns N) + {-# INLINE putPL #-} + putPL E _ _ = error "genPush: Bug5" -- impossible if BF=+1 + putPL (N ll le lr) e r = let l' = putN ll le lr -- L subtree BF<>0, H:h->h, parent BF:+1->+1 + in l' `seq` P l' e r + putPL (P ll le lr) e r = let l' = putP ll le lr -- L subtree BF<>0, H:h->h, parent BF:+1->+1 + in l' `seq` P l' e r + putPL (Z ll le lr) e r = case c le of -- determine if LL or LR + Lt -> putPLL ll le lr e r -- LL (never returns N) + Eq le' -> P (Z ll le' lr) e r -- new le + Gt -> putPLR ll le lr e r -- LR (never returns N) + + ----------------------------- LEVEL 3 --------------------------------- + -- putNRR, putPLL -- + -- putNRL, putPLR -- + ----------------------------------------------------------------------- + + -- (putNRR l e rl re rr): Put in RR subtree of (N l e (Z rl re rr)) , (never returns P) + {-# INLINE putNRR #-} + putNRR l e rl re E = Z (Z l e rl) re (Z E e0 E) -- l and rl must also be E, special CASE RR!! + putNRR l e rl re (N rrl rre rrr) = let rr' = putN rrl rre rrr -- RR subtree BF<>0, H:h->h, so no change + in rr' `seq` N l e (Z rl re rr') + putNRR l e rl re (P rrl rre rrr) = let rr' = putP rrl rre rrr -- RR subtree BF<>0, H:h->h, so no change + in rr' `seq` N l e (Z rl re rr') + putNRR l e rl re (Z rrl rre rrr) = let rr' = putZ rrl rre rrr -- RR subtree BF= 0, so need to look for changes + in case rr' of + E -> error "genPush: Bug6" -- impossible + Z _ _ _ -> N l e (Z rl re rr') -- RR subtree BF: 0-> 0, H:h->h, so no change + _ -> Z (Z l e rl) re rr' -- RR subtree BF: 0->+/-1, H:h->h+1, parent BF:-1->-2, CASE RR !! + + -- (putPLL ll le lr e r): Put in LL subtree of (P (Z ll le lr) e r) , (never returns N) + {-# INLINE putPLL #-} + putPLL E le lr e r = Z (Z E e0 E) le (Z lr e r) -- r and lr must also be E, special CASE LL!! + putPLL (N lll lle llr) le lr e r = let ll' = putN lll lle llr -- LL subtree BF<>0, H:h->h, so no change + in ll' `seq` P (Z ll' le lr) e r + putPLL (P lll lle llr) le lr e r = let ll' = putP lll lle llr -- LL subtree BF<>0, H:h->h, so no change + in ll' `seq` P (Z ll' le lr) e r + putPLL (Z lll lle llr) le lr e r = let ll' = putZ lll lle llr -- LL subtree BF= 0, so need to look for changes + in case ll' of + E -> error "genPush: Bug7" -- impossible + Z _ _ _ -> P (Z ll' le lr) e r -- LL subtree BF: 0-> 0, H:h->h, so no change + _ -> Z ll' le (Z lr e r) -- LL subtree BF: 0->+/-1, H:h->h+1, parent BF:-1->-2, CASE LL !! + + -- (putNRL l e rl re rr): Put in RL subtree of (N l e (Z rl re rr)) , (never returns P) + {-# INLINE putNRL #-} + putNRL l e E re rr = Z (Z l e E) e0 (Z E re rr) -- l and rr must also be E, special CASE LR !! + putNRL l e (N rll rle rlr) re rr = let rl' = putN rll rle rlr -- RL subtree BF<>0, H:h->h, so no change + in rl' `seq` N l e (Z rl' re rr) + putNRL l e (P rll rle rlr) re rr = let rl' = putP rll rle rlr -- RL subtree BF<>0, H:h->h, so no change + in rl' `seq` N l e (Z rl' re rr) + putNRL l e (Z rll rle rlr) re rr = let rl' = putZ rll rle rlr -- RL subtree BF= 0, so need to look for changes + in case rl' of + E -> error "genPush: Bug8" -- impossible + Z _ _ _ -> N l e (Z rl' re rr) -- RL subtree BF: 0-> 0, H:h->h, so no change + N rll' rle' rlr' -> Z (P l e rll') rle' (Z rlr' re rr) -- RL subtree BF: 0->-1, SO.. CASE RL(1) !! + P rll' rle' rlr' -> Z (Z l e rll') rle' (N rlr' re rr) -- RL subtree BF: 0->+1, SO.. CASE RL(2) !! + + -- (putPLR ll le lr e r): Put in LR subtree of (P (Z ll le lr) e r) , (never returns N) + {-# INLINE putPLR #-} + putPLR ll le E e r = Z (Z ll le E) e0 (Z E e r) -- r and ll must also be E, special CASE LR !! + putPLR ll le (N lrl lre lrr) e r = let lr' = putN lrl lre lrr -- LR subtree BF<>0, H:h->h, so no change + in lr' `seq` P (Z ll le lr') e r + putPLR ll le (P lrl lre lrr) e r = let lr' = putP lrl lre lrr -- LR subtree BF<>0, H:h->h, so no change + in lr' `seq` P (Z ll le lr') e r + putPLR ll le (Z lrl lre lrr) e r = let lr' = putZ lrl lre lrr -- LR subtree BF= 0, so need to look for changes + in case lr' of + E -> error "genPush: Bug9" -- impossible + Z _ _ _ -> P (Z ll le lr') e r -- LR subtree BF: 0-> 0, H:h->h, so no change + N lrl' lre' lrr' -> Z (P ll le lrl') lre' (Z lrr' e r) -- LR subtree BF: 0->-1, SO.. CASE LR(2) !! + P lrl' lre' lrr' -> Z (Z ll le lrl') lre' (N lrr' e r) -- LR subtree BF: 0->+1, SO.. CASE LR(1) !! +----------------------------------------------------------------------- +------------------------- genPush Ends Here ---------------------------- +----------------------------------------------------------------------- + +-- | Almost identical to 'genPush', but this version forces evaluation of the default new element +-- (second argument) if no matching element is found. Note that it does /not/ do this if +-- a matching element is found, because in this case the default new element is discarded +-- anyway. Note also that it does not force evaluation of any replacement value provided by the +-- selector (if it returns Eq). (You have to do that yourself if that\'s what you want.) +-- +-- Complexity: O(log n) +genPush' :: (e -> COrdering e) -> e -> AVL e -> AVL e +genPush' c e0 = put where + ----------------------------- LEVEL 0 --------------------------------- + -- put -- + ----------------------------------------------------------------------- + put E = e0 `seq` Z E e0 E + put (N l e r) = putN l e r + put (Z l e r) = putZ l e r + put (P l e r) = putP l e r + + ----------------------------- LEVEL 1 --------------------------------- + -- putN, putZ, putP -- + ----------------------------------------------------------------------- + + -- Put in (N l e r), BF=-1 , (never returns P) + putN l e r = case c e of + Lt -> putNL l e r -- 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 "genPush': Bug0" -- impossible + Z _ _ _ -> N l' e r -- L subtree BF:0-> 0, H:h->h , parent BF:-1->-1 + _ -> Z l' e r -- L subtree BF:0->+/-1, H:h->h+1, parent BF:-1-> 0 + + -- (putZL l e r): Put in L subtree of (Z l e r), BF= 0 (Never requires rebalancing) , (never returns N) + {-# INLINE putZL #-} + putZL E e r = e0 `seq` P (Z E e0 E ) e r -- L subtree H:0->1, parent BF: 0->+1 + putZL (N ll le lr) e r = let l' = putN ll le lr -- L subtree BF<>0, H:h->h, parent BF: 0-> 0 + in l' `seq` Z l' e r + putZL (P ll le lr) e r = let l' = putP ll le lr -- L subtree BF<>0, H:h->h, parent BF: 0-> 0 + in l' `seq` Z l' e r + putZL (Z ll le lr) e r = let l' = putZ ll le lr -- L subtree BF= 0, so need to look for changes + in case l' of + E -> error "genPush': Bug1" -- impossible + Z _ _ _ -> Z l' e r -- L subtree BF: 0-> 0, H:h->h , parent BF: 0-> 0 + _ -> P l' e r -- L subtree BF: 0->+/-1, H:h->h+1, parent BF: 0->+1 + + -- (putZR l e r): Put in R subtree of (Z l e r), BF= 0 (Never requires rebalancing) , (never returns P) + {-# INLINE putZR #-} + putZR l e E = e0 `seq` N l e (Z E e0 E) -- R subtree H:0->1, parent BF: 0->-1 + putZR l e (N rl re rr) = let r' = putN rl re rr -- R subtree BF<>0, H:h->h, parent BF: 0-> 0 + in r' `seq` Z l e r' + putZR l e (P rl re rr) = let r' = putP rl re rr -- R subtree BF<>0, H:h->h, parent BF: 0-> 0 + in r' `seq` Z l e r' + putZR l e (Z rl re rr) = let r' = putZ rl re rr -- R subtree BF= 0, so need to look for changes + in case r' of + E -> error "genPush': Bug2" -- impossible + Z _ _ _ -> Z l e r' -- R subtree BF: 0-> 0, H:h->h , parent BF: 0-> 0 + _ -> N l e r' -- R subtree BF: 0->+/-1, H:h->h+1, parent BF: 0->-1 + + -- (putPR l e r): Put in R subtree of (P l e r), BF=+1 (Never requires rebalancing) , (never returns N) + {-# INLINE putPR #-} + putPR l e E = e0 `seq` Z l e (Z E e0 E) -- R subtree empty, H:0->1, parent BF:+1-> 0 + putPR l e (N rl re rr) = let r' = putN rl re rr -- R subtree BF<>0, H:h->h, parent BF:+1->+1 + in r' `seq` P l e r' + putPR l e (P rl re rr) = let r' = putP rl re rr -- R subtree BF<>0, H:h->h, parent BF:+1->+1 + in r' `seq` P l e r' + putPR l e (Z rl re rr) = let r' = putZ rl re rr -- R subtree BF= 0, so need to look for changes + in case r' of + E -> error "genPush': Bug3" -- impossible + Z _ _ _ -> P l e r' -- R subtree BF:0-> 0, H:h->h , parent BF:+1->+1 + _ -> Z l e r' -- R subtree BF:0->+/-1, H:h->h+1, parent BF:+1-> 0 + + -------- These 2 cases (NR and PL) may need rebalancing if they go to LEVEL 3 --------- + + -- (putNR l e r): Put in R subtree of (N l e r), BF=-1 , (never returns P) + {-# INLINE putNR #-} + putNR _ _ E = error "genPush': Bug4" -- impossible if BF=-1 + putNR l e (N rl re rr) = let r' = putN rl re rr -- R subtree BF<>0, H:h->h, parent BF:-1->-1 + in r' `seq` N l e r' + putNR l e (P rl re rr) = let r' = putP rl re rr -- R subtree BF<>0, H:h->h, parent BF:-1->-1 + in r' `seq` N l e r' + putNR l e (Z rl re rr) = case c re of -- determine if RR or RL + Lt -> putNRL l e rl re rr -- RL (never returns P) + Eq re' -> N l e (Z rl re' rr) -- new re + Gt -> putNRR l e rl re rr -- RR (never returns P) + + -- (putPL l e r): Put in L subtree of (P l e r), BF=+1 , (never returns N) + {-# INLINE putPL #-} + putPL E _ _ = error "genPush': Bug5" -- impossible if BF=+1 + putPL (N ll le lr) e r = let l' = putN ll le lr -- L subtree BF<>0, H:h->h, parent BF:+1->+1 + in l' `seq` P l' e r + putPL (P ll le lr) e r = let l' = putP ll le lr -- L subtree BF<>0, H:h->h, parent BF:+1->+1 + in l' `seq` P l' e r + putPL (Z ll le lr) e r = case c le of -- determine if LL or LR + Lt -> putPLL ll le lr e r -- LL (never returns N) + Eq le' -> P (Z ll le' lr) e r -- new le + Gt -> putPLR ll le lr e r -- LR (never returns N) + + ----------------------------- LEVEL 3 --------------------------------- + -- putNRR, putPLL -- + -- putNRL, putPLR -- + ----------------------------------------------------------------------- + + -- (putNRR l e rl re rr): Put in RR subtree of (N l e (Z rl re rr)) , (never returns P) + {-# INLINE putNRR #-} + putNRR l e rl re E = e0 `seq` Z (Z l e rl) re (Z E e0 E) -- l and rl must also be E, special CASE RR!! + putNRR l e rl re (N rrl rre rrr) = let rr' = putN rrl rre rrr -- RR subtree BF<>0, H:h->h, so no change + in rr' `seq` N l e (Z rl re rr') + putNRR l e rl re (P rrl rre rrr) = let rr' = putP rrl rre rrr -- RR subtree BF<>0, H:h->h, so no change + in rr' `seq` N l e (Z rl re rr') + putNRR l e rl re (Z rrl rre rrr) = let rr' = putZ rrl rre rrr -- RR subtree BF= 0, so need to look for changes + in case rr' of + E -> error "genPush': Bug6" -- impossible + Z _ _ _ -> N l e (Z rl re rr') -- RR subtree BF: 0-> 0, H:h->h, so no change + _ -> Z (Z l e rl) re rr' -- RR subtree BF: 0->+/-1, H:h->h+1, parent BF:-1->-2, CASE RR !! + + -- (putPLL ll le lr e r): Put in LL subtree of (P (Z ll le lr) e r) , (never returns N) + {-# INLINE putPLL #-} + putPLL E le lr e r = e0 `seq` Z (Z E e0 E) le (Z lr e r) -- r and lr must also be E, special CASE LL!! + putPLL (N lll lle llr) le lr e r = let ll' = putN lll lle llr -- LL subtree BF<>0, H:h->h, so no change + in ll' `seq` P (Z ll' le lr) e r + putPLL (P lll lle llr) le lr e r = let ll' = putP lll lle llr -- LL subtree BF<>0, H:h->h, so no change + in ll' `seq` P (Z ll' le lr) e r + putPLL (Z lll lle llr) le lr e r = let ll' = putZ lll lle llr -- LL subtree BF= 0, so need to look for changes + in case ll' of + E -> error "genPush': Bug7" -- impossible + Z _ _ _ -> P (Z ll' le lr) e r -- LL subtree BF: 0-> 0, H:h->h, so no change + _ -> Z ll' le (Z lr e r) -- LL subtree BF: 0->+/-1, H:h->h+1, parent BF:-1->-2, CASE LL !! + + -- (putNRL l e rl re rr): Put in RL subtree of (N l e (Z rl re rr)) , (never returns P) + {-# INLINE putNRL #-} + putNRL l e E re rr = e0 `seq` Z (Z l e E) e0 (Z E re rr) -- l and rr must also be E, special CASE LR !! + putNRL l e (N rll rle rlr) re rr = let rl' = putN rll rle rlr -- RL subtree BF<>0, H:h->h, so no change + in rl' `seq` N l e (Z rl' re rr) + putNRL l e (P rll rle rlr) re rr = let rl' = putP rll rle rlr -- RL subtree BF<>0, H:h->h, so no change + in rl' `seq` N l e (Z rl' re rr) + putNRL l e (Z rll rle rlr) re rr = let rl' = putZ rll rle rlr -- RL subtree BF= 0, so need to look for changes + in case rl' of + E -> error "genPush': Bug8" -- impossible + Z _ _ _ -> N l e (Z rl' re rr) -- RL subtree BF: 0-> 0, H:h->h, so no change + N rll' rle' rlr' -> Z (P l e rll') rle' (Z rlr' re rr) -- RL subtree BF: 0->-1, SO.. CASE RL(1) !! + P rll' rle' rlr' -> Z (Z l e rll') rle' (N rlr' re rr) -- RL subtree BF: 0->+1, SO.. CASE RL(2) !! + + -- (putPLR ll le lr e r): Put in LR subtree of (P (Z ll le lr) e r) , (never returns N) + {-# INLINE putPLR #-} + putPLR ll le E e r = e0 `seq` Z (Z ll le E) e0 (Z E e r) -- r and ll must also be E, special CASE LR !! + putPLR ll le (N lrl lre lrr) e r = let lr' = putN lrl lre lrr -- LR subtree BF<>0, H:h->h, so no change + in lr' `seq` P (Z ll le lr') e r + putPLR ll le (P lrl lre lrr) e r = let lr' = putP lrl lre lrr -- LR subtree BF<>0, H:h->h, so no change + in lr' `seq` P (Z ll le lr') e r + putPLR ll le (Z lrl lre lrr) e r = let lr' = putZ lrl lre lrr -- LR subtree BF= 0, so need to look for changes + in case lr' of + E -> error "genPush': Bug9" -- impossible + Z _ _ _ -> P (Z ll le lr') e r -- LR subtree BF: 0-> 0, H:h->h, so no change + N lrl' lre' lrr' -> Z (P ll le lrl') lre' (Z lrr' e r) -- LR subtree BF: 0->-1, SO.. CASE LR(2) !! + P lrl' lre' lrr' -> Z (Z ll le lrl') lre' (N lrr' e r) -- LR subtree BF: 0->+1, SO.. CASE LR(1) !! +----------------------------------------------------------------------- +------------------------- genPush' Ends Here ---------------------------- +----------------------------------------------------------------------- + +-- | Similar to 'genPush', but returns the original tree if the combining comparison returns +-- @('Eq' 'Nothing')@. So this function can be used reduce heap burn rate by avoiding duplication +-- of nodes on the insertion path. But it may also be marginally slower otherwise. +-- +-- Note that this function is /non-strict/ in it\'s second argument (the default value which +-- is inserted in the search fails or is discarded if the search succeeds). If you want +-- to force evaluation, but only if it\'s actually incorprated in the tree, then use 'genPushMaybe'' +-- +-- Complexity: O(log n) +genPushMaybe :: (e -> COrdering (Maybe e)) -> e -> AVL e -> AVL e +genPushMaybe c e t = case genOpenPathWith c t of + FullBP _ Nothing -> t + FullBP p (Just e') -> writePath p e' t + EmptyBP p -> insertPath p e t + +-- | Almost identical to 'genPushMaybe', but this version forces evaluation of the default new element +-- (second argument) if no matching element is found. Note that it does /not/ do this if +-- a matching element is found, because in this case the default new element is discarded +-- anyway. +-- +-- Complexity: O(log n) +genPushMaybe' :: (e -> COrdering (Maybe e)) -> e -> AVL e -> AVL e +genPushMaybe' c e t = case genOpenPathWith c t of + FullBP _ Nothing -> t + FullBP p (Just e') -> writePath p e' t + EmptyBP p -> e `seq` insertPath p e t + +-- | Push a new element in the leftmost position of an AVL tree. No comparison or searching is involved. +-- +-- Complexity: O(log n) +pushL :: e -> AVL e -> AVL e +pushL e0 = pushL' where -- There now follows a cut down version of the more general put. + -- Insertion is always on the left subtree. + -- Re-Balancing cases RR,RL/LR(1/2) never occur. Only LL! + -- There are also more impossible cases (putZL never returns N) + ----------------------------- LEVEL 0 --------------------------------- + -- pushL' -- + ----------------------------------------------------------------------- + pushL' E = Z E e0 E + pushL' (N l e r) = putNL l e r + pushL' (Z l e r) = putZL l e r + pushL' (P l e r) = putPL l e r + + ----------------------------- LEVEL 2 --------------------------------- + -- putNL, putZL, putPL -- + ----------------------------------------------------------------------- + + -- (putNL l e r): Put in L subtree of (N l e r), BF=-1 (Never requires rebalancing) , (never returns P) + putNL E e r = Z (Z E e0 E) e r -- L subtree empty, H:0->1, parent BF:-1-> 0 + putNL (N ll le lr) e r = let l' = putNL ll le lr -- L subtree BF<>0, H:h->h, parent BF:-1->-1 + in l' `seq` N l' e r + putNL (P ll le lr) e r = let l' = putPL ll le lr -- L subtree BF<>0, H:h->h, parent BF:-1->-1 + in l' `seq` N l' e r + putNL (Z ll le lr) e r = let l' = putZL ll le lr -- L subtree BF= 0, so need to look for changes + in case l' of + Z _ _ _ -> N l' e r -- L subtree BF:0-> 0, H:h->h , parent BF:-1->-1 + P _ _ _ -> Z l' e r -- L subtree BF:0->+1, H:h->h+1, parent BF:-1-> 0 + _ -> error "pushL: Bug0" -- impossible + + -- (putZL l e r): Put in L subtree of (Z l e r), BF= 0 (Never requires rebalancing) , (never returns N) + putZL E e r = P (Z E e0 E) e r -- L subtree H:0->1, parent BF: 0->+1 + putZL (N ll le lr) e r = let l' = putNL ll le lr -- L subtree BF<>0, H:h->h, parent BF: 0-> 0 + in l' `seq` Z l' e r + putZL (P ll le lr) e r = let l' = putPL ll le lr -- L subtree BF<>0, H:h->h, parent BF: 0-> 0 + in l' `seq` Z l' e r + putZL (Z ll le lr) e r = let l' = putZL ll le lr -- L subtree BF= 0, so need to look for changes + in case l' of + Z _ _ _ -> Z l' e r -- L subtree BF: 0-> 0, H:h->h , parent BF: 0-> 0 + N _ _ _ -> error "pushL: Bug1" -- impossible + _ -> P l' e r -- L subtree BF: 0->+1, H:h->h+1, parent BF: 0->+1 + + -------- This case (PL) may need rebalancing if it goes to LEVEL 3 --------- + + -- (putPL l e r): Put in L subtree of (P l e r), BF=+1 , (never returns N) + putPL E _ _ = error "pushL: Bug2" -- impossible if BF=+1 + putPL (N ll le lr) e r = let l' = putNL ll le lr -- L subtree BF<>0, H:h->h, parent BF:+1->+1 + in l' `seq` P l' e r + putPL (P ll le lr) e r = let l' = putPL ll le lr -- L subtree BF<>0, H:h->h, parent BF:+1->+1 + in l' `seq` P l' e r + putPL (Z ll le lr) e r = putPLL ll le lr e r -- LL (never returns N) + + ----------------------------- LEVEL 3 --------------------------------- + -- putPLL -- + ----------------------------------------------------------------------- + + -- (putPLL ll le lr e r): Put in LL subtree of (P (Z ll le lr) e r) , (never returns N) + {-# INLINE putPLL #-} + putPLL E le lr e r = Z (Z E e0 E) le (Z lr e r) -- r and lr must also be E, special CASE LL!! + putPLL (N lll lle llr) le lr e r = let ll' = putNL lll lle llr -- LL subtree BF<>0, H:h->h, so no change + in ll' `seq` P (Z ll' le lr) e r + putPLL (P lll lle llr) le lr e r = let ll' = putPL lll lle llr -- LL subtree BF<>0, H:h->h, so no change + in ll' `seq` P (Z ll' le lr) e r + putPLL (Z lll lle llr) le lr e r = let ll' = putZL lll lle llr -- LL subtree BF= 0, so need to look for changes + in case ll' of + Z _ _ _ -> P (Z ll' le lr) e r -- LL subtree BF: 0-> 0, H:h->h, so no change + N _ _ _ -> error "pushL: Bug3" -- impossible + _ -> Z ll' le (Z lr e r) -- LL subtree BF: 0->+1, H:h->h+1, parent BF:-1->-2, CASE LL !! +----------------------------------------------------------------------- +--------------------------- pushL Ends Here --------------------------- +----------------------------------------------------------------------- + + +-- | Push a new element in the rightmost position of an AVL tree. No comparison or searching is involved. +-- +-- Complexity: O(log n) +pushR :: AVL e -> e -> AVL e +pushR t e0 = pushR' t where -- There now follows a cut down version of the more general put. + -- Insertion is always on the right subtree. + -- Re-Balancing cases LL,RL/LR(1/2) never occur. Only RR! + -- There are also more impossible cases (putZR never returns P) + + ----------------------------- LEVEL 0 --------------------------------- + -- pushR' -- + ----------------------------------------------------------------------- + pushR' E = Z E e0 E + pushR' (N l e r) = putNR l e r + pushR' (Z l e r) = putZR l e r + pushR' (P l e r) = putPR l e r + + ----------------------------- LEVEL 2 --------------------------------- + -- putNR, putZR, putPR -- + ----------------------------------------------------------------------- + + -- (putZR l e r): Put in R subtree of (Z l e r), BF= 0 (Never requires rebalancing) , (never returns P) + putZR l e E = N l e (Z E e0 E) -- R subtree H:0->1, parent BF: 0->-1 + putZR l e (N rl re rr) = let r' = putNR rl re rr -- R subtree BF<>0, H:h->h, parent BF: 0-> 0 + in r' `seq` Z l e r' + putZR l e (P rl re rr) = let r' = putPR rl re rr -- R subtree BF<>0, H:h->h, parent BF: 0-> 0 + in r' `seq` Z l e r' + putZR l e (Z rl re rr) = let r' = putZR rl re rr -- R subtree BF= 0, so need to look for changes + in case r' of + Z _ _ _ -> Z l e r' -- R subtree BF: 0-> 0, H:h->h , parent BF: 0-> 0 + N _ _ _ -> N l e r' -- R subtree BF: 0->-1, H:h->h+1, parent BF: 0->-1 + _ -> error "pushR: Bug0" -- impossible + + -- (putPR l e r): Put in R subtree of (P l e r), BF=+1 (Never requires rebalancing) , (never returns N) + putPR l e E = Z l e (Z E e0 E) -- R subtree empty, H:0->1, parent BF:+1-> 0 + putPR l e (N rl re rr) = let r' = putNR rl re rr -- R subtree BF<>0, H:h->h, parent BF:+1->+1 + in r' `seq` P l e r' + putPR l e (P rl re rr) = let r' = putPR rl re rr -- R subtree BF<>0, H:h->h, parent BF:+1->+1 + in r' `seq` P l e r' + putPR l e (Z rl re rr) = let r' = putZR rl re rr -- R subtree BF= 0, so need to look for changes + in case r' of + Z _ _ _ -> P l e r' -- R subtree BF:0-> 0, H:h->h , parent BF:+1->+1 + N _ _ _ -> Z l e r' -- R subtree BF:0->-1, H:h->h+1, parent BF:+1-> 0 + _ -> error "pushR: Bug1" -- impossible + + -------- This case (NR) may need rebalancing if it goes to LEVEL 3 --------- + + -- (putNR l e r): Put in R subtree of (N l e r), BF=-1 , (never returns P) + putNR _ _ E = error "pushR: Bug2" -- impossible if BF=-1 + putNR l e (N rl re rr) = let r' = putNR rl re rr -- R subtree BF<>0, H:h->h, parent BF:-1->-1 + in r' `seq` N l e r' + putNR l e (P rl re rr) = let r' = putPR rl re rr -- R subtree BF<>0, H:h->h, parent BF:-1->-1 + in r' `seq` N l e r' + putNR l e (Z rl re rr) = putNRR l e rl re rr -- RR (never returns P) + + ----------------------------- LEVEL 3 --------------------------------- + -- putNRR -- + ----------------------------------------------------------------------- + + -- (putNRR l e rl re rr): Put in RR subtree of (N l e (Z rl re rr)) , (never returns P) + {-# INLINE putNRR #-} + putNRR l e rl re E = Z (Z l e rl) re (Z E e0 E) -- l and rl must also be E, special CASE RR!! + putNRR l e rl re (N rrl rre rrr) = let rr' = putNR rrl rre rrr -- RR subtree BF<>0, H:h->h, so no change + in rr' `seq` N l e (Z rl re rr') + putNRR l e rl re (P rrl rre rrr) = let rr' = putPR rrl rre rrr -- RR subtree BF<>0, H:h->h, so no change + in rr' `seq` N l e (Z rl re rr') + putNRR l e rl re (Z rrl rre rrr) = let rr' = putZR rrl rre rrr -- RR subtree BF= 0, so need to look for changes + in case rr' of + Z _ _ _ -> N l e (Z rl re rr') -- RR subtree BF: 0-> 0, H:h->h, so no change + N _ _ _ -> Z (Z l e rl) re rr' -- RR subtree BF: 0->-1, H:h->h+1, parent BF:-1->-2, CASE RR !! + _ -> error "pushR: Bug3" -- impossible +----------------------------------------------------------------------- +--------------------------- pushR Ends Here --------------------------- +----------------------------------------------------------------------- + + diff --git a/Data/Tree/AVL/Read.hs b/Data/Tree/AVL/Read.hs new file mode 100644 --- /dev/null +++ b/Data/Tree/AVL/Read.hs @@ -0,0 +1,168 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Data.Tree.AVL.Read +-- Copyright : (c) Adrian Hey 2004,2005 +-- License : BSD3 +-- +-- Maintainer : http://homepages.nildram.co.uk/~ahey/em.png +-- Stability : stable +-- Portability : portable +----------------------------------------------------------------------------- +module Data.Tree.AVL.Read +(-- * Reading from AVL trees + + -- ** Reading from extreme left or right + assertReadL,tryReadL, + assertReadR,tryReadR, + + -- ** Reading from /sorted/ AVL trees + genAssertRead,genTryRead,genTryReadMaybe,genDefaultRead, + + -- ** Simple searches of /sorted/ AVL trees + genContains, +) where + +import Prelude -- so haddock finds the symbols there + +import Data.COrdering +import Data.Tree.AVL.Types(AVL(..)) + +-- | Read the leftmost element from a /non-empty/ tree. Raises an error if the tree is empty. +-- If the tree is sorted this will return the least element. +-- +-- Complexity: O(log n) +assertReadL :: AVL e -> e +assertReadL E = error "assertReadL: Empty tree." +assertReadL (N l e _) = readLE l e +assertReadL (Z l e _) = readLE l e +assertReadL (P l _ _) = readLNE l -- BF=+1, so left sub-tree cannot be empty. + +-- | Similar to 'assertReadL' but returns 'Nothing' if the tree is empty. +-- +-- Complexity: O(log n) +tryReadL :: AVL e -> Maybe e +tryReadL E = Nothing +tryReadL (N l e _) = Just $! readLE l e +tryReadL (Z l e _) = Just $! readLE l e +tryReadL (P l _ _) = Just $! readLNE l -- BF=+1, so left sub-tree cannot be empty. + +-- Local utilities for the above +readLNE :: AVL e -> e +readLNE E = error "readLNE: Bug." +readLNE (N l e _) = readLE l e +readLNE (Z l e _) = readLE l e +readLNE (P l _ _) = readLNE l -- BF=+1, so left sub-tree cannot be empty. +readLE :: AVL e -> e -> e +readLE E e = e +readLE (N l e _) _ = readLE l e +readLE (Z l e _) _ = readLE l e +readLE (P l _ _) _ = readLNE l -- BF=+1, so left sub-tree cannot be empty. + + +-- | Read the rightmost element from a /non-empty/ tree. Raises an error if the tree is empty. +-- If the tree is sorted this will return the greatest element. +-- +-- Complexity: O(log n) +assertReadR :: AVL e -> e +assertReadR E = error "assertReadR: Empty tree." +assertReadR (P _ e r) = readRE r e +assertReadR (Z _ e r) = readRE r e +assertReadR (N _ _ r) = readRNE r -- BF=-1, so right sub-tree cannot be empty. + +-- | Similar to 'assertReadR' but returns 'Nothing' if the tree is empty. +-- +-- Complexity: O(log n) +tryReadR :: AVL e -> Maybe e +tryReadR E = Nothing +tryReadR (P _ e r) = Just $! readRE r e +tryReadR (Z _ e r) = Just $! readRE r e +tryReadR (N _ _ r) = Just $! readRNE r -- BF=-1, so right sub-tree cannot be empty. + +-- Local utilities for the above +readRNE :: AVL e -> e +readRNE E = error "readRNE: Bug." +readRNE (P _ e r) = readRE r e +readRNE (Z _ e r) = readRE r e +readRNE (N _ _ r) = readRNE r -- BF=-1, so right sub-tree cannot be empty. +readRE :: AVL e -> e -> e +readRE E e = e +readRE (P _ e r) _ = readRE r e +readRE (Z _ e r) _ = readRE r e +readRE (N _ _ r) _ = readRNE r -- BF=-1, so right sub-tree cannot be empty. + + +-- | General purpose function to perform a search of a sorted tree, using the supplied selector. +-- This function raises a error if the search fails. +-- +-- Complexity: O(log n) +genAssertRead :: AVL e -> (e -> COrdering a) -> a +genAssertRead t c = genRead' t where + genRead' E = error "genAssertRead failed." + genRead' (N l e r) = genRead'' l e r + genRead' (Z l e r) = genRead'' l e r + genRead' (P l e r) = genRead'' l e r + genRead'' l e r = case c e of + Lt -> genRead' l + Eq a -> a + Gt -> genRead' r + +-- | General purpose function to perform a search of a sorted tree, using the supplied selector. +-- This function is similar to 'genAssertRead', but returns 'Nothing' if the search failed. +-- +-- Complexity: O(log n) +genTryRead :: AVL e -> (e -> COrdering a) -> Maybe a +genTryRead t c = genTryRead' t where + genTryRead' E = Nothing + genTryRead' (N l e r) = genTryRead'' l e r + genTryRead' (Z l e r) = genTryRead'' l e r + genTryRead' (P l e r) = genTryRead'' l e r + genTryRead'' l e r = case c e of + Lt -> genTryRead' l + Eq a -> Just a + Gt -> genTryRead' r + +-- | This version returns the result of the selector (without adding a 'Just' wrapper) if the search +-- succeeds, or 'Nothing' if it fails. +-- +-- Complexity: O(log n) +genTryReadMaybe :: AVL e -> (e -> COrdering (Maybe a)) -> Maybe a +genTryReadMaybe t c = genTryRead' t where + genTryRead' E = Nothing + genTryRead' (N l e r) = genTryRead'' l e r + genTryRead' (Z l e r) = genTryRead'' l e r + genTryRead' (P l e r) = genTryRead'' l e r + genTryRead'' l e r = case c e of + Lt -> genTryRead' l + Eq mba -> mba + Gt -> genTryRead' r + +-- | General purpose function to perform a search of a sorted tree, using the supplied selector. +-- This function is similar to 'genAssertRead', but returns a the default value (first argument) if +-- the search fails. +-- +-- Complexity: O(log n) +genDefaultRead :: a -> AVL e -> (e -> COrdering a) -> a +genDefaultRead d t c = genRead' t where + genRead' E = d + genRead' (N l e r) = genRead'' l e r + genRead' (Z l e r) = genRead'' l e r + genRead' (P l e r) = genRead'' l e r + genRead'' l e r = case c e of + Lt -> genRead' l + Eq a -> a + Gt -> genRead' r + +-- | General purpose function to perform a search of a sorted tree, using the supplied selector. +-- Returns True if matching element is found. +-- +-- Complexity: O(log n) +genContains :: AVL e -> (e -> Ordering) -> Bool +genContains t c = genContains' t where + genContains' E = False + genContains' (N l e r) = genContains'' l e r + genContains' (Z l e r) = genContains'' l e r + genContains' (P l e r) = genContains'' l e r + genContains'' l e r = case c e of + LT -> genContains' l + EQ -> True + GT -> genContains' r diff --git a/Data/Tree/AVL/Set.hs b/Data/Tree/AVL/Set.hs new file mode 100644 --- /dev/null +++ b/Data/Tree/AVL/Set.hs @@ -0,0 +1,491 @@ +{-# OPTIONS_GHC -fglasgow-exts #-} +----------------------------------------------------------------------------- +-- | +-- Module : Data.Tree.AVL.Set +-- Copyright : (c) Adrian Hey 2004,2005 +-- License : BSD3 +-- +-- Maintainer : http://homepages.nildram.co.uk/~ahey/em.png +-- Stability : stable +-- Portability : portable +----------------------------------------------------------------------------- +module Data.Tree.AVL.Set +(-- * Set operations + -- | Functions for manipulating AVL trees which represent ordered sets (I.E. /sorted/ trees). + -- Note that although many of these functions work with a variety of different element + -- types they all require that elements are sorted according to the same criterion (such + -- as a field value in a record). + + -- ** Union + genUnion,genUnionMaybe,genUnions, + + -- ** Difference + genDifference,genDifferenceMaybe,genSymDifference, + + -- ** Intersection + genIntersection,genIntersectionMaybe, + + -- *** Intersection with the result as a list + -- | Sometimes you don\'t want intersection to give a tree, particularly if the + -- resulting elements are not orderered or sorted according to whatever criterion was + -- used to sort the elements of the input sets. + -- + -- The reason these variants are provided for intersection only (and not the other + -- set functions) is that the (tree returning) intersections always construct an entirely + -- new tree, whereas with the others the resulting tree will typically share sub-trees + -- with one or both of the originals. (Of course the results of the others can easily be + -- converted to a list too if required.) + genIntersectionToListL,genIntersectionAsListL, + genIntersectionMaybeToListL,genIntersectionMaybeAsListL, + + -- ** Subset + genIsSubsetOf,genIsSubsetOfBy + +) where + +import Prelude -- so haddock finds the symbols there + +import Data.Tree.AVL.Types(AVL(..)) +import Data.Tree.AVL.Internals.HeightUtils(addHeight) +import Data.Tree.AVL.Internals.HJoin(spliceH) +import Data.Tree.AVL.Internals.HSet(unionH,unionMaybeH, + intersectionH,intersectionMaybeH, + differenceH,differenceMaybeH,symDifferenceH) + +import Data.COrdering + +#ifdef __GLASGOW_HASKELL__ +import GHC.Base +#include "ghcdefs.h" +#else +#include "h98defs.h" +#endif + +-- | Uses the supplied combining comparison to evaluate the union of two sets represented as +-- sorted AVL trees. Whenever the combining comparison is applied, the first comparison argument is +-- an element of the first tree and the second comparison argument is an element of the second tree. +-- +-- Complexity: Not sure, but I'd appreciate it if someone could figure it out. +-- (Faster than Hedge union from Data.Set at any rate). +genUnion :: (e -> e -> COrdering e) -> AVL e -> AVL e -> AVL e +genUnion c = gu where -- This is to avoid O(log n) height calculation for empty sets + gu E t1 = t1 + gu t0 E = t0 + gu t0@(N l0 _ _ ) t1@(N l1 _ _ ) = gu_ t0 (addHeight L(2) l0) t1 (addHeight L(2) l1) + gu t0@(N l0 _ _ ) t1@(Z l1 _ _ ) = gu_ t0 (addHeight L(2) l0) t1 (addHeight L(1) l1) + gu t0@(N l0 _ _ ) t1@(P _ _ r1) = gu_ t0 (addHeight L(2) l0) t1 (addHeight L(2) r1) + gu t0@(Z l0 _ _ ) t1@(N l1 _ _ ) = gu_ t0 (addHeight L(1) l0) t1 (addHeight L(2) l1) + gu t0@(Z l0 _ _ ) t1@(Z l1 _ _ ) = gu_ t0 (addHeight L(1) l0) t1 (addHeight L(1) l1) + gu t0@(Z l0 _ _ ) t1@(P _ _ r1) = gu_ t0 (addHeight L(1) l0) t1 (addHeight L(2) r1) + gu t0@(P _ _ r0) t1@(N l1 _ _ ) = gu_ t0 (addHeight L(2) r0) t1 (addHeight L(2) l1) + gu t0@(P _ _ r0) t1@(Z l1 _ _ ) = gu_ t0 (addHeight L(2) r0) t1 (addHeight L(1) l1) + gu t0@(P _ _ r0) t1@(P _ _ r1) = gu_ t0 (addHeight L(2) r0) t1 (addHeight L(2) r1) + gu_ t0 h0 t1 h1 = case unionH c t0 h0 t1 h1 of UBT2(t,_) -> t + +-- | Similar to 'genUnion', but the resulting tree does not include elements in cases where +-- the supplied combining comparison returns @(Eq Nothing)@. +-- +-- Complexity: Not sure, but I'd appreciate it if someone could figure it out. +genUnionMaybe :: (e -> e -> COrdering (Maybe e)) -> AVL e -> AVL e -> AVL e +genUnionMaybe c = gu where -- This is to avoid O(log n) height calculation for empty sets + gu E t1 = t1 + gu t0 E = t0 + gu t0@(N l0 _ _ ) t1@(N l1 _ _ ) = gu_ t0 (addHeight L(2) l0) t1 (addHeight L(2) l1) + gu t0@(N l0 _ _ ) t1@(Z l1 _ _ ) = gu_ t0 (addHeight L(2) l0) t1 (addHeight L(1) l1) + gu t0@(N l0 _ _ ) t1@(P _ _ r1) = gu_ t0 (addHeight L(2) l0) t1 (addHeight L(2) r1) + gu t0@(Z l0 _ _ ) t1@(N l1 _ _ ) = gu_ t0 (addHeight L(1) l0) t1 (addHeight L(2) l1) + gu t0@(Z l0 _ _ ) t1@(Z l1 _ _ ) = gu_ t0 (addHeight L(1) l0) t1 (addHeight L(1) l1) + gu t0@(Z l0 _ _ ) t1@(P _ _ r1) = gu_ t0 (addHeight L(1) l0) t1 (addHeight L(2) r1) + gu t0@(P _ _ r0) t1@(N l1 _ _ ) = gu_ t0 (addHeight L(2) r0) t1 (addHeight L(2) l1) + gu t0@(P _ _ r0) t1@(Z l1 _ _ ) = gu_ t0 (addHeight L(2) r0) t1 (addHeight L(1) l1) + gu t0@(P _ _ r0) t1@(P _ _ r1) = gu_ t0 (addHeight L(2) r0) t1 (addHeight L(2) r1) + gu_ t0 h0 t1 h1 = case unionMaybeH c t0 h0 t1 h1 of UBT2(t,_) -> t + +-- | Uses the supplied combining comparison to evaluate the union of all sets in a list +-- of sets represented as sorted AVL trees. Behaves as if defined.. +-- +-- @genUnions ccmp avls = foldl' ('genUnion' ccmp) empty avls@ +genUnions :: (e -> e -> COrdering e) -> [AVL e] -> AVL e +genUnions c = gus E L(0) where + gus a _ [] = a + gus a ha ( E :avls) = gus a ha avls + gus a ha (t@(N l _ _):avls) = case unionH c a ha t (addHeight L(2) l) of UBT2(a_,ha_) -> gus a_ ha_ avls + gus a ha (t@(Z l _ _):avls) = case unionH c a ha t (addHeight L(1) l) of UBT2(a_,ha_) -> gus a_ ha_ avls + gus a ha (t@(P _ _ r):avls) = case unionH c a ha t (addHeight L(2) r) of UBT2(a_,ha_) -> gus a_ ha_ avls + +-- | Uses the supplied combining comparison to evaluate the intersection of two sets represented as +-- sorted AVL trees. +-- +-- Complexity: Not sure, but I'd appreciate it if someone could figure it out. +genIntersection :: (a -> b -> COrdering c) -> AVL a -> AVL b -> AVL c +genIntersection c t0 t1 = case intersectionH c t0 t1 of UBT2(t,_) -> t + +-- | Similar to 'genIntersection', but the resulting tree does not include elements in cases where +-- the supplied combining comparison returns @(Eq Nothing)@. +-- +-- Complexity: Not sure, but I'd appreciate it if someone could figure it out. +genIntersectionMaybe :: (a -> b -> COrdering (Maybe c)) -> AVL a -> AVL b -> AVL c +genIntersectionMaybe c t0 t1 = case intersectionMaybeH c t0 t1 of UBT2(t,_) -> t + +-- | Similar to 'genIntersection', but prepends the result to the supplied list in +-- left to right order. This is a (++) free function which behaves as if defined: +-- +-- @genIntersectionToListL c setA setB cs = asListL (genIntersection c setA setB) ++ cs@ +-- +-- Complexity: Not sure, but I'd appreciate it if someone could figure it out. +genIntersectionToListL :: (a -> b -> COrdering c) -> AVL a -> AVL b -> [c] -> [c] +genIntersectionToListL comp = i where + -- i :: AVL a -> AVL b -> [c] -> [c] + i E _ cs = cs + i _ E cs = cs + i (N l0 e0 r0) (N l1 e1 r1) cs = i' l0 e0 r0 l1 e1 r1 cs + i (N l0 e0 r0) (Z l1 e1 r1) cs = i' l0 e0 r0 l1 e1 r1 cs + i (N l0 e0 r0) (P l1 e1 r1) cs = i' l0 e0 r0 l1 e1 r1 cs + i (Z l0 e0 r0) (N l1 e1 r1) cs = i' l0 e0 r0 l1 e1 r1 cs + i (Z l0 e0 r0) (Z l1 e1 r1) cs = i' l0 e0 r0 l1 e1 r1 cs + i (Z l0 e0 r0) (P l1 e1 r1) cs = i' l0 e0 r0 l1 e1 r1 cs + i (P l0 e0 r0) (N l1 e1 r1) cs = i' l0 e0 r0 l1 e1 r1 cs + i (P l0 e0 r0) (Z l1 e1 r1) cs = i' l0 e0 r0 l1 e1 r1 cs + i (P l0 e0 r0) (P l1 e1 r1) cs = i' l0 e0 r0 l1 e1 r1 cs + i' l0 e0 r0 l1 e1 r1 cs = + case comp e0 e1 of + -- e0 < e1, so (l0 < e0 < e1) & (e0 < e1 < r1) + Lt -> case forkR r0 e1 of + UBT5(rl0,_,mbc1,rr0,_) -> case forkL e0 l1 of -- (e0 < rl0 < e1) & (e0 < e1 < rr0) + UBT5(ll1,_,mbc0,lr1,_) -> -- (ll1 < e0 < e1) & (e0 < lr1 < e1) + -- (l0 + ll1) < e0 < (rl0 + lr1) < e1 < (rr0 + r1) + let cs' = i rr0 r1 cs + cs'' = cs' `seq` case mbc1 of + Nothing -> i rl0 lr1 cs' + Just c1 -> i rl0 lr1 (c1:cs') + in cs'' `seq` case mbc0 of + Nothing -> i l0 ll1 cs'' + Just c0 -> i l0 ll1 (c0:cs'') + -- e0 = e1 + Eq c -> let cs' = i r0 r1 cs in cs' `seq` i l0 l1 (c:cs') + -- e1 < e0, so (l1 < e1 < e0) & (e1 < e0 < r0) + Gt -> case forkL e0 r1 of + UBT5(rl1,_,mbc0,rr1,_) -> case forkR l0 e1 of -- (e1 < rl1 < e0) & (e1 < e0 < rr1) + UBT5(ll0,_,mbc1,lr0,_) -> -- (ll0 < e1 < e0) & (e1 < lr0 < e0) + -- (ll0 + l1) < e1 < (lr0 + rl1) < e0 < (r0 + rr1) + let cs' = i r0 rr1 cs + cs'' = cs' `seq` case mbc0 of + Nothing -> i lr0 rl1 cs' + Just c0 -> i lr0 rl1 (c0:cs') + in cs'' `seq` case mbc1 of + Nothing -> i ll0 l1 cs'' + Just c1 -> i ll0 l1 (c1:cs'') + -- We need 2 different versions of fork (L & R) to ensure that comparison arguments are used in + -- the right order (c e0 e1) + -- forkL :: a -> AVL b -> UBT5(AVL b,UINT,Maybe c,AVL b,UINT) + forkL e0 t1 = forkL_ t1 L(0) where + forkL_ E h = UBT5(E,h,Nothing,E,h) -- Relative heights!! + forkL_ (N l e r) h = forkL__ l DECINT2(h) e r DECINT1(h) + forkL_ (Z l e r) h = forkL__ l DECINT1(h) e r DECINT1(h) + forkL_ (P l e r) h = forkL__ l DECINT1(h) e r DECINT2(h) + forkL__ l hl e r hr = case comp e0 e of + Lt -> case forkL_ l hl of + UBT5(l0,hl0,mbc0,l1,hl1) -> case spliceH l1 hl1 e r hr of + UBT2(l1_,hl1_) -> UBT5(l0,hl0,mbc0,l1_,hl1_) + Eq c0 -> UBT5(l,hl,Just c0,r,hr) + Gt -> case forkL_ r hr of + UBT5(l0,hl0,mbc0,l1,hl1) -> case spliceH l hl e l0 hl0 of + UBT2(l0_,hl0_) -> UBT5(l0_,hl0_,mbc0,l1,hl1) + -- forkR :: AVL a -> b -> UBT5(AVL a,UINT,Maybe c,AVL a,UINT) + forkR t0 e1 = forkR_ t0 L(0) where + forkR_ E h = UBT5(E,h,Nothing,E,h) -- Relative heights!! + forkR_ (N l e r) h = forkR__ l DECINT2(h) e r DECINT1(h) + forkR_ (Z l e r) h = forkR__ l DECINT1(h) e r DECINT1(h) + forkR_ (P l e r) h = forkR__ l DECINT1(h) e r DECINT2(h) + forkR__ l hl e r hr = case comp e e1 of + Lt -> case forkR_ r hr of + UBT5(l0,hl0,mbc1,l1,hl1) -> case spliceH l hl e l0 hl0 of + UBT2(l0_,hl0_) -> UBT5(l0_,hl0_,mbc1,l1,hl1) + Eq c1 -> UBT5(l,hl,Just c1,r,hr) + Gt -> case forkR_ l hl of + UBT5(l0,hl0,mbc1,l1,hl1) -> case spliceH l1 hl1 e r hr of + UBT2(l1_,hl1_) -> UBT5(l0,hl0,mbc1,l1_,hl1_) +----------------------------------------------------------------------- +------------------ genIntersectionToListL Ends Here ------------------- +----------------------------------------------------------------------- + +-- | Applies 'genIntersectionToListL' to the empty list. +-- +-- Complexity: Not sure, but I'd appreciate it if someone could figure it out. +genIntersectionAsListL :: (a -> b -> COrdering c) -> AVL a -> AVL b -> [c] +genIntersectionAsListL c setA setB = genIntersectionToListL c setA setB [] + +-- | Similar to 'genIntersectionToListL', but the result does not include elements in cases where +-- the supplied combining comparison returns @(Eq Nothing)@. +-- +-- Complexity: Not sure, but I'd appreciate it if someone could figure it out. +genIntersectionMaybeToListL :: (a -> b -> COrdering (Maybe c)) -> AVL a -> AVL b -> [c] -> [c] +genIntersectionMaybeToListL comp = i where + -- i :: AVL a -> AVL b -> [c] -> [c] + i E _ cs = cs + i _ E cs = cs + i (N l0 e0 r0) (N l1 e1 r1) cs = i' l0 e0 r0 l1 e1 r1 cs + i (N l0 e0 r0) (Z l1 e1 r1) cs = i' l0 e0 r0 l1 e1 r1 cs + i (N l0 e0 r0) (P l1 e1 r1) cs = i' l0 e0 r0 l1 e1 r1 cs + i (Z l0 e0 r0) (N l1 e1 r1) cs = i' l0 e0 r0 l1 e1 r1 cs + i (Z l0 e0 r0) (Z l1 e1 r1) cs = i' l0 e0 r0 l1 e1 r1 cs + i (Z l0 e0 r0) (P l1 e1 r1) cs = i' l0 e0 r0 l1 e1 r1 cs + i (P l0 e0 r0) (N l1 e1 r1) cs = i' l0 e0 r0 l1 e1 r1 cs + i (P l0 e0 r0) (Z l1 e1 r1) cs = i' l0 e0 r0 l1 e1 r1 cs + i (P l0 e0 r0) (P l1 e1 r1) cs = i' l0 e0 r0 l1 e1 r1 cs + i' l0 e0 r0 l1 e1 r1 cs = + case comp e0 e1 of + -- e0 < e1, so (l0 < e0 < e1) & (e0 < e1 < r1) + Lt -> case forkR r0 e1 of + UBT5(rl0,_,mbc1,rr0,_) -> case forkL e0 l1 of -- (e0 < rl0 < e1) & (e0 < e1 < rr0) + UBT5(ll1,_,mbc0,lr1,_) -> -- (ll1 < e0 < e1) & (e0 < lr1 < e1) + -- (l0 + ll1) < e0 < (rl0 + lr1) < e1 < (rr0 + r1) + let cs' = i rr0 r1 cs + cs'' = cs' `seq` case mbc1 of + Nothing -> i rl0 lr1 cs' + Just c1 -> i rl0 lr1 (c1:cs') + in cs'' `seq` case mbc0 of + Nothing -> i l0 ll1 cs'' + Just c0 -> i l0 ll1 (c0:cs'') + -- e0 = e1 + Eq mbc -> let cs' = i r0 r1 cs in cs' `seq` case mbc of + Nothing -> i l0 l1 cs' + Just c -> i l0 l1 (c:cs') + -- e1 < e0, so (l1 < e1 < e0) & (e1 < e0 < r0) + Gt -> case forkL e0 r1 of + UBT5(rl1,_,mbc0,rr1,_) -> case forkR l0 e1 of -- (e1 < rl1 < e0) & (e1 < e0 < rr1) + UBT5(ll0,_,mbc1,lr0,_) -> -- (ll0 < e1 < e0) & (e1 < lr0 < e0) + -- (ll0 + l1) < e1 < (lr0 + rl1) < e0 < (r0 + rr1) + let cs' = i r0 rr1 cs + cs'' = cs' `seq` case mbc0 of + Nothing -> i lr0 rl1 cs' + Just c0 -> i lr0 rl1 (c0:cs') + in cs'' `seq` case mbc1 of + Nothing -> i ll0 l1 cs'' + Just c1 -> i ll0 l1 (c1:cs'') + -- We need 2 different versions of fork (L & R) to ensure that comparison arguments are used in + -- the right order (c e0 e1) + -- forkL :: a -> AVL b -> UBT5(AVL b,UINT,Maybe c,AVL b,UINT) + forkL e0 t1 = forkL_ t1 L(0) where + forkL_ E h = UBT5(E,h,Nothing,E,h) -- Relative heights!! + forkL_ (N l e r) h = forkL__ l DECINT2(h) e r DECINT1(h) + forkL_ (Z l e r) h = forkL__ l DECINT1(h) e r DECINT1(h) + forkL_ (P l e r) h = forkL__ l DECINT1(h) e r DECINT2(h) + forkL__ l hl e r hr = case comp e0 e of + Lt -> case forkL_ l hl of + UBT5(l0,hl0,mbc0,l1,hl1) -> case spliceH l1 hl1 e r hr of + UBT2(l1_,hl1_) -> UBT5(l0,hl0,mbc0,l1_,hl1_) + Eq mbc0 -> UBT5(l,hl,mbc0,r,hr) + Gt -> case forkL_ r hr of + UBT5(l0,hl0,mbc0,l1,hl1) -> case spliceH l hl e l0 hl0 of + UBT2(l0_,hl0_) -> UBT5(l0_,hl0_,mbc0,l1,hl1) + -- forkR :: AVL a -> b -> UBT5(AVL a,UINT,Maybe c,AVL a,UINT) + forkR t0 e1 = forkR_ t0 L(0) where + forkR_ E h = UBT5(E,h,Nothing,E,h) -- Relative heights!! + forkR_ (N l e r) h = forkR__ l DECINT2(h) e r DECINT1(h) + forkR_ (Z l e r) h = forkR__ l DECINT1(h) e r DECINT1(h) + forkR_ (P l e r) h = forkR__ l DECINT1(h) e r DECINT2(h) + forkR__ l hl e r hr = case comp e e1 of + Lt -> case forkR_ r hr of + UBT5(l0,hl0,mbc1,l1,hl1) -> case spliceH l hl e l0 hl0 of + UBT2(l0_,hl0_) -> UBT5(l0_,hl0_,mbc1,l1,hl1) + Eq mbc1 -> UBT5(l,hl,mbc1,r,hr) + Gt -> case forkR_ l hl of + UBT5(l0,hl0,mbc1,l1,hl1) -> case spliceH l1 hl1 e r hr of + UBT2(l1_,hl1_) -> UBT5(l0,hl0,mbc1,l1_,hl1_) +----------------------------------------------------------------------- +---------------- genIntersectionMaybeToListL Ends Here ---------------- +----------------------------------------------------------------------- + +-- | Applies 'genIntersectionMaybeToListL' to the empty list. +-- +-- Complexity: Not sure, but I'd appreciate it if someone could figure it out. +genIntersectionMaybeAsListL :: (a -> b -> COrdering (Maybe c)) -> AVL a -> AVL b -> [c] +genIntersectionMaybeAsListL c setA setB = genIntersectionMaybeToListL c setA setB [] + +-- | Uses the supplied comparison to evaluate the difference between two sets represented as +-- sorted AVL trees. The expression.. +-- +-- > genDifference cmp setA setB +-- +-- .. is a set containing all those elements of @setA@ which do not appear in @setB@. +-- +-- Complexity: Not sure, but I'd appreciate it if someone could figure it out. +genDifference :: (a -> b -> Ordering) -> AVL a -> AVL b -> AVL a +-- N.B. differenceH works with relative heights on first tree, and needs no height for the second. +genDifference c t0 t1 = case differenceH c t0 L(0) t1 of UBT2(t,_) -> t + +-- | Similar to 'genDifference', but the resulting tree also includes those elements a\' for which the +-- combining comparison returns @(Eq (Just a\'))@. +-- +-- Complexity: Not sure, but I'd appreciate it if someone could figure it out. +genDifferenceMaybe :: (a -> b -> COrdering (Maybe a)) -> AVL a -> AVL b -> AVL a +-- N.B. differenceMaybeH works with relative heights on first tree, and needs no height for the second. +genDifferenceMaybe c t0 t1 = case differenceMaybeH c t0 L(0) t1 of UBT2(t,_) -> t + +-- | Uses the supplied comparison to test whether the first set is a subset of the second, +-- both sets being represented as sorted AVL trees. This function returns True if any of +-- the following conditions hold.. +-- +-- * The first set is empty (the empty set is a subset of any set). +-- +-- * The two sets are equal. +-- +-- * The first set is a proper subset of the second set. +-- +-- Complexity: Not sure, but I'd appreciate it if someone could figure it out. +genIsSubsetOf :: (a -> b -> Ordering) -> AVL a -> AVL b -> Bool +genIsSubsetOf comp = s where + -- s :: AVL a -> AVL b -> Bool + s E _ = True + s _ E = False + s (N l0 e0 r0) (N l1 e1 r1) = s' l0 e0 r0 l1 e1 r1 + s (N l0 e0 r0) (Z l1 e1 r1) = s' l0 e0 r0 l1 e1 r1 + s (N l0 e0 r0) (P l1 e1 r1) = s' l0 e0 r0 l1 e1 r1 + s (Z l0 e0 r0) (N l1 e1 r1) = s' l0 e0 r0 l1 e1 r1 + s (Z l0 e0 r0) (Z l1 e1 r1) = s' l0 e0 r0 l1 e1 r1 + s (Z l0 e0 r0) (P l1 e1 r1) = s' l0 e0 r0 l1 e1 r1 + s (P l0 e0 r0) (N l1 e1 r1) = s' l0 e0 r0 l1 e1 r1 + s (P l0 e0 r0) (Z l1 e1 r1) = s' l0 e0 r0 l1 e1 r1 + s (P l0 e0 r0) (P l1 e1 r1) = s' l0 e0 r0 l1 e1 r1 + s' l0 e0 r0 l1 e1 r1 = + case comp e0 e1 of + -- e0 < e1, so (l0 < e0 < e1) & (e0 < e1 < r1) + LT -> case forkL e0 l1 of + UBT5(False,_ ,_,_ ,_) -> False + UBT5(True ,ll1,_,lr1,_) -> (s l0 ll1) && case forkR r0 e1 of -- (ll1 < e0 < e1) & (e0 < lr1 < e1) + UBT4(rl0,_,rr0,_) -> (s rl0 lr1) && (s rr0 r1) -- (e0 < rl0 < e1) & (e0 < e1 < rr0) + -- e0 = e1 + EQ -> (s l0 l1) && (s r0 r1) + -- e1 < e0, so (l1 < e1 < e0) & (e1 < e0 < r0) + GT -> case forkL e0 r1 of + UBT5(False,_ ,_,_ ,_) -> False + UBT5(True ,rl1,_,rr1,_) -> (s r0 rr1) && case forkR l0 e1 of -- (e1 < rl1 < e0) & (e1 < e0 < rr1) + UBT4(ll0,_,lr0,_) -> (s lr0 rl1) && (s ll0 l1) -- (ll0 < e1 < e0) & (e1 < lr0 < e0) + -- forkL returns False if t1 does not contain e0 (which implies set 0 cannot be a subset of set 1) + -- forkL :: a -> AVL b -> UBT5(Bool,AVL b,UINT,AVL b,UINT) -- Vals 1..4 only valid if Bool is True! + forkL e0 t = forkL_ t L(0) where + forkL_ E h = UBT5(False,E,h,E,h) + forkL_ (N l e r) h = forkL__ l DECINT2(h) e r DECINT1(h) + forkL_ (Z l e r) h = forkL__ l DECINT1(h) e r DECINT1(h) + forkL_ (P l e r) h = forkL__ l DECINT1(h) e r DECINT2(h) + forkL__ l hl e r hr = case comp e0 e of + LT -> case forkL_ l hl of + UBT5(False,t0,ht0,t1,ht1) -> UBT5(False,t0,ht0,t1,ht1) + UBT5(True ,t0,ht0,t1,ht1) -> case spliceH t1 ht1 e r hr of + UBT2(t1_,ht1_) -> UBT5(True,t0,ht0,t1_,ht1_) + EQ -> UBT5(True,l,hl,r,hr) + GT -> case forkL_ r hr of + UBT5(False,t0,ht0,t1,ht1) -> UBT5(False,t0,ht0,t1,ht1) + UBT5(True ,t0,ht0,t1,ht1) -> case spliceH l hl e t0 ht0 of + UBT2(t0_,ht0_) -> UBT5(True,t0_,ht0_,t1,ht1) + -- forkR discards an element from set 0 if it is equal to the element from set 1 + -- forkR :: AVL a -> b -> UBT4(AVL a,UINT,AVL a,UINT) + forkR t e1 = forkR_ t L(0) where + forkR_ E h = UBT4(E,h,E,h) -- Relative heights!! + forkR_ (N l e r) h = forkR__ l DECINT2(h) e r DECINT1(h) + forkR_ (Z l e r) h = forkR__ l DECINT1(h) e r DECINT1(h) + forkR_ (P l e r) h = forkR__ l DECINT1(h) e r DECINT2(h) + forkR__ l hl e r hr = case comp e e1 of + LT -> case forkR_ r hr of + UBT4(t0,ht0,t1,ht1) -> case spliceH l hl e t0 ht0 of + UBT2(t0_,ht0_) -> UBT4(t0_,ht0_,t1,ht1) + EQ -> UBT4(l,hl,r,hr) -- e is discarded from set 0 + GT -> case forkR_ l hl of + UBT4(t0,ht0,t1,ht1) -> case spliceH t1 ht1 e r hr of + UBT2(t1_,ht1_) -> UBT4(t0,ht0,t1_,ht1_) +----------------------------------------------------------------------- +------------------------ genIsSubsetOf Ends Here ---------------------- +----------------------------------------------------------------------- + +-- | Similar to 'genIsSubsetOf', but also requires that the supplied combining +-- comparison returns @('Eq' True)@ for matching elements. +-- +-- Complexity: Not sure, but I'd appreciate it if someone could figure it out. +genIsSubsetOfBy :: (a -> b -> COrdering Bool) -> AVL a -> AVL b -> Bool +genIsSubsetOfBy comp = s where + -- s :: AVL a -> AVL b -> Bool + s E _ = True + s _ E = False + s (N l0 e0 r0) (N l1 e1 r1) = s' l0 e0 r0 l1 e1 r1 + s (N l0 e0 r0) (Z l1 e1 r1) = s' l0 e0 r0 l1 e1 r1 + s (N l0 e0 r0) (P l1 e1 r1) = s' l0 e0 r0 l1 e1 r1 + s (Z l0 e0 r0) (N l1 e1 r1) = s' l0 e0 r0 l1 e1 r1 + s (Z l0 e0 r0) (Z l1 e1 r1) = s' l0 e0 r0 l1 e1 r1 + s (Z l0 e0 r0) (P l1 e1 r1) = s' l0 e0 r0 l1 e1 r1 + s (P l0 e0 r0) (N l1 e1 r1) = s' l0 e0 r0 l1 e1 r1 + s (P l0 e0 r0) (Z l1 e1 r1) = s' l0 e0 r0 l1 e1 r1 + s (P l0 e0 r0) (P l1 e1 r1) = s' l0 e0 r0 l1 e1 r1 + s' l0 e0 r0 l1 e1 r1 = + case comp e0 e1 of + -- e0 < e1, so (l0 < e0 < e1) & (e0 < e1 < r1) + Lt -> case forkL e0 l1 of + UBT5(False,_ ,_,_ ,_) -> False + UBT5(True ,ll1,_,lr1,_) -> (s l0 ll1) && case forkR r0 e1 of -- (ll1 < e0 < e1) & (e0 < lr1 < e1) + UBT5(False,_ ,_,_ ,_) -> False + UBT5(True ,rl0,_,rr0,_) -> (s rl0 lr1) && (s rr0 r1) -- (e0 < rl0 < e1) & (e0 < e1 < rr0) + -- e0 = e1 + Eq True -> (s l0 l1) && (s r0 r1) + Eq False -> False + -- e1 < e0, so (l1 < e1 < e0) & (e1 < e0 < r0) + Gt -> case forkL e0 r1 of + UBT5(False,_ ,_,_ ,_) -> False + UBT5(True ,rl1,_,rr1,_) -> (s r0 rr1) && case forkR l0 e1 of -- (e1 < rl1 < e0) & (e1 < e0 < rr1) + UBT5(False,_ ,_,_ ,_) -> False + UBT5(True ,ll0,_,lr0,_) -> (s lr0 rl1) && (s ll0 l1) -- (ll0 < e1 < e0) & (e1 < lr0 < e0) + -- forkL returns False if t1 does not contain e0 (which implies set 0 cannot be a subset of set 1) + -- forkL :: a -> AVL b -> UBT5(Bool,AVL b,UINT,AVL b,UINT) -- Vals 1..4 only valid if Bool is True! + forkL e0 t = forkL_ t L(0) where + forkL_ E h = UBT5(False,E,h,E,h) + forkL_ (N l e r) h = forkL__ l DECINT2(h) e r DECINT1(h) + forkL_ (Z l e r) h = forkL__ l DECINT1(h) e r DECINT1(h) + forkL_ (P l e r) h = forkL__ l DECINT1(h) e r DECINT2(h) + forkL__ l hl e r hr = case comp e0 e of + Lt -> case forkL_ l hl of + UBT5(False,t0,ht0,t1,ht1) -> UBT5(False,t0,ht0,t1,ht1) + UBT5(True ,t0,ht0,t1,ht1) -> case spliceH t1 ht1 e r hr of + UBT2(t1_,ht1_) -> UBT5(True,t0,ht0,t1_,ht1_) + Eq b -> UBT5(b,l,hl,r,hr) + Gt -> case forkL_ r hr of + UBT5(False,t0,ht0,t1,ht1) -> UBT5(False,t0,ht0,t1,ht1) + UBT5(True ,t0,ht0,t1,ht1) -> case spliceH l hl e t0 ht0 of + UBT2(t0_,ht0_) -> UBT5(True,t0_,ht0_,t1,ht1) + -- forkR discards an element from set 0 if it is equal to the element from set 1 + -- forkR :: AVL a -> b -> UBT5(Bool,AVL a,UINT,AVL a,UINT) -- Vals 1..4 only valid if Bool is True! + forkR t e1 = forkR_ t L(0) where + forkR_ E h = UBT5(True,E,h,E,h) -- Relative heights!! + forkR_ (N l e r) h = forkR__ l DECINT2(h) e r DECINT1(h) + forkR_ (Z l e r) h = forkR__ l DECINT1(h) e r DECINT1(h) + forkR_ (P l e r) h = forkR__ l DECINT1(h) e r DECINT2(h) + forkR__ l hl e r hr = case comp e e1 of + Lt -> case forkR_ r hr of + UBT5(False,t0,ht0,t1,ht1) -> UBT5(False,t0,ht0,t1,ht1) + UBT5(True ,t0,ht0,t1,ht1) -> case spliceH l hl e t0 ht0 of + UBT2(t0_,ht0_) -> UBT5(True,t0_,ht0_,t1,ht1) + Eq b -> UBT5(b,l,hl,r,hr) -- e is discarded from set 0 + Gt -> case forkR_ l hl of + UBT5(False,t0,ht0,t1,ht1) -> UBT5(False,t0,ht0,t1,ht1) + UBT5(True ,t0,ht0,t1,ht1) -> case spliceH t1 ht1 e r hr of + UBT2(t1_,ht1_) -> UBT5(True,t0,ht0,t1_,ht1_) +----------------------------------------------------------------------- +----------------------- genIsSubsetOfBy Ends Here --------------------- +----------------------------------------------------------------------- + +-- | The symmetric difference is the set of elements which occur in one set or the other but /not both/. +-- +-- Complexity: Not sure, but I'd appreciate it if someone could figure it out. +genSymDifference :: (e -> e -> Ordering) -> AVL e -> AVL e -> AVL e +genSymDifference c = gu where -- This is to avoid O(log n) height calculation for empty sets + gu E t1 = t1 + gu t0 E = t0 + gu t0@(N l0 _ _ ) t1@(N l1 _ _ ) = gu_ t0 (addHeight L(2) l0) t1 (addHeight L(2) l1) + gu t0@(N l0 _ _ ) t1@(Z l1 _ _ ) = gu_ t0 (addHeight L(2) l0) t1 (addHeight L(1) l1) + gu t0@(N l0 _ _ ) t1@(P _ _ r1) = gu_ t0 (addHeight L(2) l0) t1 (addHeight L(2) r1) + gu t0@(Z l0 _ _ ) t1@(N l1 _ _ ) = gu_ t0 (addHeight L(1) l0) t1 (addHeight L(2) l1) + gu t0@(Z l0 _ _ ) t1@(Z l1 _ _ ) = gu_ t0 (addHeight L(1) l0) t1 (addHeight L(1) l1) + gu t0@(Z l0 _ _ ) t1@(P _ _ r1) = gu_ t0 (addHeight L(1) l0) t1 (addHeight L(2) r1) + gu t0@(P _ _ r0) t1@(N l1 _ _ ) = gu_ t0 (addHeight L(2) r0) t1 (addHeight L(2) l1) + gu t0@(P _ _ r0) t1@(Z l1 _ _ ) = gu_ t0 (addHeight L(2) r0) t1 (addHeight L(1) l1) + gu t0@(P _ _ r0) t1@(P _ _ r1) = gu_ t0 (addHeight L(2) r0) t1 (addHeight L(2) r1) + gu_ t0 h0 t1 h1 = case symDifferenceH c t0 h0 t1 h1 of UBT2(t,_) -> t + diff --git a/Data/Tree/AVL/Size.hs b/Data/Tree/AVL/Size.hs new file mode 100644 --- /dev/null +++ b/Data/Tree/AVL/Size.hs @@ -0,0 +1,174 @@ +{-# OPTIONS_GHC -fglasgow-exts #-} +----------------------------------------------------------------------------- +-- | +-- Module : Data.Tree.AVL.Size +-- Copyright : (c) Adrian Hey 2004,2005 +-- License : BSD3 +-- +-- Maintainer : http://homepages.nildram.co.uk/~ahey/em.png +-- Stability : stable +-- Portability : portable +-- +-- AVL Tree size related utilities. +----------------------------------------------------------------------------- +module Data.Tree.AVL.Size + (-- * AVL tree size utilities. + size,addSize,fastAddSize,clipSize + ) where + +import Data.Tree.AVL.Types(AVL(..)) +import Data.Tree.AVL.Internals.HeightUtils(addHeight) + +#ifdef __GLASGOW_HASKELL__ +import GHC.Base +#include "ghcdefs.h" +#else +#include "h98defs.h" +#endif + +-- | Counts the total number of elements in an AVL tree. +-- +-- @'size' = 'addSize' 0@ +-- +-- Complexity: O(n) +{-# INLINE size #-} +size :: AVL e -> Int +size = addSize 0 + +-- | Adds the size of a tree to the first argument. +-- This is just a convenience wrapper for 'fastAddSize'. +-- +-- Complexity: O(n) +{-# INLINE addSize #-} +addSize :: Int -> AVL e -> Int +addSize ASINT(n) t = ASINT(fastAddSize n t) + +{----------------------------------------- +Notes for fast size calculation. + case (h,avl) + (0,_ ) -> 0 -- Must be E + (1,_ ) -> 1 -- Must be (Z E _ E ) + (2,N _ _ _) -> 2 -- Must be (N E _ (Z E _ E)) + (2,Z _ _ _) -> 3 -- Must be (Z (Z E _ E) _ (Z E _ E)) + (2,P _ _ _) -> 2 -- Must be (P (Z E _ E) _ E ) + (3,N _ _ r) -> 2 + size 2 r -- Must be (N (Z E _ E) _ r ) + (3,P l _ _) -> 2 + size 2 l -- Must be (P l _ (Z E _ E)) +------------------------------------------} + +-- | Fast algorithm to calculate size. This avoids visiting about 50% of tree nodes +-- by using fact that trees with small heights can only have particular shapes. +-- So it's still O(n), but with substantial saving in constant factors. +-- +-- Complexity: O(n) +fastAddSize :: UINT -> AVL e -> UINT +fastAddSize n E = n +fastAddSize n (N l _ r) = case addHeight L(2) l of + L(2) -> INCINT2(n) + L(3) -> fas2 INCINT2(n) r + h -> fasNP n h l r +fastAddSize n (Z l _ r) = case addHeight L(1) l of + L(1) -> INCINT1(n) + L(2) -> INCINT3(n) + L(3) -> fas2 (fas2 INCINT1(n) l) r + h -> fasZ n h l r +fastAddSize n (P l _ r) = case addHeight L(2) r of + L(2) -> INCINT2(n) + L(3) -> fas2 INCINT2(n) l + h -> fasNP n h r l +-- Parent Height (h) >= 4 !! +fasNP,fasZ :: UINT -> UINT -> AVL e -> AVL e -> UINT +fasNP n h l r = fasG3 (fasG2 INCINT1(n) DECINT2(h) l) DECINT1(h) r +fasZ n h l r = fasG3 (fasG3 INCINT1(n) DECINT1(h) l) DECINT1(h) r +-- h>=2 !! +fasG2 :: UINT -> UINT -> AVL e -> UINT +fasG2 n L(2) t = fas2 n t +fasG2 n h t = fasG3 n h t +{-# INLINE fasG2 #-} +-- h>=3 !! +fasG3 :: UINT -> UINT -> AVL e -> UINT +fasG3 n L(3) (N _ _ r) = fas2 INCINT2(n) r +fasG3 n L(3) (Z l _ r) = fas2 (fas2 INCINT1(n) l) r +fasG3 n L(3) (P l _ _) = fas2 INCINT2(n) l +fasG3 n h (N l _ r) = fasNP n h l r -- h>=4 +fasG3 n h (Z l _ r) = fasZ n h l r -- h>=4 +fasG3 n h (P l _ r) = fasNP n h r l -- h>=4 +fasG3 _ _ E = error "fastAddSize: Bad Tree." -- impossible +-- h=2 !! +fas2 :: UINT -> AVL e -> UINT +fas2 n (N _ _ _) = INCINT2(n) +fas2 n (Z _ _ _) = INCINT3(n) +fas2 n (P _ _ _) = INCINT2(n) +fas2 _ E = error "fastAddSize: Bad Tree." -- impossible +{-# INLINE fas2 #-} +----------------------------------------------------------------------- +----------------------- fastAddSize Ends Here ------------------------- +----------------------------------------------------------------------- + +-- | Returns the exact tree size in the form @('Just' n)@ if this is less than or +-- equal to the input clip value. Returns @'Nothing'@ of the size is greater than +-- the clip value. This function exploits the same optimisation as 'fastAddSize'. +-- +-- Complexity: O(min n c) where n is tree size and c is clip value. +clipSize :: Int -> AVL e -> Maybe Int +clipSize ASINT(c) t = let c_ = cSzh c t in if c_ LTN L(0) + then Nothing + else Just ASINT(SUBINT(c,c_)) +-- First entry calculates initial height +cSzh :: UINT -> AVL e -> UINT +cSzh c E = c +cSzh c (N l _ r) = case addHeight L(2) l of + L(2) -> DECINT2(c) + L(3) -> cSzNP3 c r + h -> cSzNP c h l r +cSzh c (Z l _ r) = case addHeight L(1) l of + L(1) -> DECINT1(c) + L(2) -> DECINT3(c) + L(3) -> cSzZ3 c l r + h -> cSzZ c h l r +cSzh c (P l _ r) = case addHeight L(2) r of + L(2) -> DECINT2(c) + L(3) -> cSzNP3 c l + h -> cSzNP c h r l +-- Parent Height = 3 !! +cSzNP3 :: UINT -> AVL e -> UINT +cSzNP3 c t = if c LTN L(4) then L(-1) else cSz2 DECINT2(c) t +cSzZ3 :: UINT -> AVL e -> AVL e -> UINT +cSzZ3 c l r = if c LTN L(5) then L(-1) + else let c_ = cSz2 DECINT1(c) l + in if c_ LTN L(2) then L(-1) + else cSz2 c_ r +-- Parent Height (h) >= 4 !! +cSzNP,cSzZ :: UINT -> UINT -> AVL e -> AVL e -> UINT +cSzNP c h l r = if c LTN L(7) then L(-1) + else let c_ = cSzG2 DECINT1(c) DECINT2(h) l -- (h-2) >= 2 + in if c_ LTN L(4) then L(-1) + else cSzG3 c_ DECINT1(h) r -- (h-1) >= 3 +cSzZ c h l r = if c LTN L(9) then L(-1) + else let c_ = cSzG3 DECINT1(c) DECINT1(h) l -- (h-1) >= 3 + in if c_ LTN L(4) then L(-1) + else cSzG3 c_ DECINT1(h) r -- (h-1) >= 3 +-- h>=2 !! +cSzG2 :: UINT -> UINT -> AVL e -> UINT +cSzG2 c L(2) t = cSz2 c t +cSzG2 c h t = cSzG3 c h t +{-# INLINE cSzG2 #-} +-- h>=3 !! +cSzG3 :: UINT -> UINT -> AVL e -> UINT +cSzG3 c L(3) (N _ _ r) = cSzNP3 c r +cSzG3 c L(3) (Z l _ r) = cSzZ3 c l r +cSzG3 c L(3) (P l _ _) = cSzNP3 c l +cSzG3 c h (N l _ r) = cSzNP c h l r -- h>=4 +cSzG3 c h (Z l _ r) = cSzZ c h l r -- h>=4 +cSzG3 c h (P l _ r) = cSzNP c h r l -- h>=4 +cSzG3 _ _ E = error "clipSize: Bad Tree." -- impossible +-- h=2 !! +cSz2 :: UINT -> AVL e -> UINT +cSz2 c (N _ _ _) = DECINT2(c) +cSz2 c (Z _ _ _) = DECINT3(c) +cSz2 c (P _ _ _) = DECINT2(c) +cSz2 _ E = error "clipSize: Bad Tree." -- impossible +{-# INLINE cSz2 #-} +----------------------------------------------------------------------- +------------------------- clipSize Ends Here -------------------------- +----------------------------------------------------------------------- + diff --git a/Data/Tree/AVL/Split.hs b/Data/Tree/AVL/Split.hs new file mode 100644 --- /dev/null +++ b/Data/Tree/AVL/Split.hs @@ -0,0 +1,837 @@ +{-# OPTIONS_GHC -fglasgow-exts #-} +----------------------------------------------------------------------------- +-- | +-- Module : Data.Tree.AVL.Split +-- Copyright : (c) Adrian Hey 2004,2005 +-- License : BSD3 +-- +-- Maintainer : http://homepages.nildram.co.uk/~ahey/em.png +-- Stability : stable +-- Portability : portable +----------------------------------------------------------------------------- +module Data.Tree.AVL.Split +(-- * Splitting AVL trees + + -- ** Taking fixed size lumps of tree + -- | Bear in mind that the tree size (s) is not stored in the AVL data structure, but if it is + -- already known for other reasons then for (n > s\/2) using the appropriate complementary + -- function with argument (s-n) will be faster. + -- But it's probably not worth invoking 'Data.Tree.AVL.Types.size' for no reason other than to + -- exploit this optimisation (because this is O(s) anyway). + splitAtL,splitAtR,takeL,takeR,dropL,dropR, + + -- ** Rotations + -- | Bear in mind that the tree size (s) is not stored in the AVL data structure, but if it is + -- already known for other reasons then for (n > s\/2) using the appropriate complementary + -- function with argument (s-n) will be faster. + -- But it's probably not worth invoking 'Data.Tree.AVL.Types.size' for no reason other than to exploit this optimisation + -- (because this is O(s) anyway). + rotateL,rotateR,popRotateL,popRotateR,rotateByL,rotateByR, + + -- ** Taking lumps of tree according to a supplied predicate + spanL,spanR,takeWhileL,dropWhileL,takeWhileR,dropWhileR, + + -- ** Taking lumps of /sorted/ trees + -- | Prepare to get confused. All these functions adhere to the same Ordering convention as + -- is used for searches. That is, if the supplied selector returns LT that means the search + -- key is less than the current tree element. Or put another way, the current tree element + -- is greater than the search key. + -- + -- So (for example) the result of the 'genTakeLT' function is a tree containing all those elements + -- which are less than the notional search key. That is, all those elements for which the + -- supplied selector returns GT (not LT as you might expect). I know that seems backwards, but + -- it's consistent if you think about it. + genForkL,genForkR,genFork, + genTakeLE,genDropGT, + genTakeLT,genDropGE, + genTakeGT,genDropLE, + genTakeGE,genDropLT, +) where + +import Prelude -- so haddock finds the symbols there + + +import Data.COrdering(COrdering(..)) +import Data.Tree.AVL.Types(AVL(..)) +import Data.Tree.AVL.Push(pushL,pushR) +import Data.Tree.AVL.Internals.DelUtils(popRN,popRZ,popRP,popLN,popLZ,popLP) +import Data.Tree.AVL.Internals.HAVL(HAVL(HAVL),spliceHAVL,pushLHAVL,pushRHAVL) +import Data.Tree.AVL.Internals.HJoin(joinH') + +#ifdef __GLASGOW_HASKELL__ +import GHC.Base +#include "ghcdefs.h" +#else +#include "h98defs.h" +#endif + +-- Local Datatype for results of split operations. +data SplitResult e = All (HAVL e) (HAVL e) -- Two tree/height pairs. Non Strict!! + | More {-# UNPACK #-} !UINT -- No of tree elements still required (>=0!!) + +-- | Split an AVL tree from the Left. The 'Int' argument n (n >= 0) specifies the split point. +-- This function raises an error if n is negative. +-- +-- If the tree size is greater than n the result is (Right (l,r)) where l contains +-- the leftmost n elements and r contains the remaining rightmost elements (r will be non-empty). +-- +-- If the tree size is less than or equal to n then the result is (Left s), where s is tree size. +-- +-- An empty tree will always yield a result of (Left 0). +-- +-- Complexity: O(n) +splitAtL :: Int -> AVL e -> Either Int (AVL e, AVL e) +splitAtL n _ | n < 0 = error "splitAtL: Negative argument." +splitAtL 0 E = Left 0 -- Treat this case specially +splitAtL 0 t = Right (E,t) +splitAtL ASINT(n) t = case splitL n t L(0) of -- Tree Heights are relative!! + More n_ -> Left ASINT(SUBINT(n,n_)) + All (HAVL l _) (HAVL r _) -> Right (l,r) + +-- n > 0 !! +-- N.B Never returns a result of form (ALL lhavl rhavl) where rhavl is empty +splitL :: UINT -> AVL e -> UINT -> SplitResult e +splitL n E _ = More n +splitL n (N l e r) h = splitL_ n l DECINT2(h) e r DECINT1(h) +splitL n (Z l e r) h = splitL_ n l DECINT1(h) e r DECINT1(h) +splitL n (P l e r) h = splitL_ n l DECINT1(h) e r DECINT2(h) + +-- n > 0 !! +-- N.B Never returns a result of form (ALL lhavl rhavl) where rhavl is empty +splitL_ :: UINT -> AVL e -> UINT -> e -> AVL e -> UINT -> SplitResult e +splitL_ n l hl e r hr = + case splitL n l hl of + More L(0) -> let rhavl = pushLHAVL e (HAVL r hr); lhavl = HAVL l hl + in lhavl `seq` rhavl `seq` All lhavl rhavl + More L(1) -> case r of + E -> More L(0) + _ -> let lhavl = pushRHAVL (HAVL l hl) e + rhavl = HAVL r hr + in lhavl `seq` rhavl `seq` All lhavl rhavl + More n_ -> let sr = splitL DECINT1(n_) r hr + in case sr of + More _ -> sr + All havl0 havl1 -> let havl0' = spliceHAVL (HAVL l hl) e havl0 + in havl0' `seq` All havl0' havl1 + All havl0 havl1 -> let havl1' = spliceHAVL havl1 e (HAVL r hr) + in havl1' `seq` All havl0 havl1' +----------------------------------------------------------------------- +------------------------- splitAtL Ends Here -------------------------- +----------------------------------------------------------------------- + +-- | Split an AVL tree from the Right. The 'Int' argument n (n >= 0) specifies the split point. +-- This function raises an error if n is negative. +-- +-- If the tree size is greater than n the result is (Right (l,r)) where r contains +-- the rightmost n elements and l contains the remaining leftmost elements (l will be non-empty). +-- +-- If the tree size is less than or equal to n then the result is (Left s), where s is tree size. +-- +-- An empty tree will always yield a result of (Left 0). +-- +-- Complexity: O(n) +splitAtR :: Int -> AVL e -> Either Int (AVL e, AVL e) +splitAtR n _ | n < 0 = error "splitAtR: Negative argument." +splitAtR 0 E = Left 0 -- Treat this case specially +splitAtR 0 t = Right (t,E) +splitAtR ASINT(n) t = case splitR n t L(0) of -- Tree Heights are relative!! + More n_ -> Left ASINT(SUBINT(n,n_)) + All (HAVL l _) (HAVL r _) -> Right (l,r) + +-- n > 0 !! +-- N.B Never returns a result of form (ALL lhavl rhavl) where lhavl is empty +splitR :: UINT -> AVL e -> UINT -> SplitResult e +splitR n E _ = More n +splitR n (N l e r) h = splitR_ n l DECINT2(h) e r DECINT1(h) +splitR n (Z l e r) h = splitR_ n l DECINT1(h) e r DECINT1(h) +splitR n (P l e r) h = splitR_ n l DECINT1(h) e r DECINT2(h) + +-- n > 0 !! +-- N.B Never returns a result of form (ALL lhavl rhavl) where lhavl is empty +splitR_ :: UINT -> AVL e -> UINT -> e -> AVL e -> UINT -> SplitResult e +splitR_ n l hl e r hr = + case splitR n r hr of + More L(0) -> let lhavl = pushRHAVL (HAVL l hl) e; rhavl = HAVL r hr + in lhavl `seq` rhavl `seq` All lhavl rhavl + More L(1) -> case l of + E -> More L(0) + _ -> let rhavl = pushLHAVL e (HAVL r hr) + lhavl = HAVL l hl + in lhavl `seq` rhavl `seq` All lhavl rhavl + More n_ -> let sr = splitR DECINT1(n_) l hl + in case sr of + More _ -> sr + All havl0 havl1 -> let havl1' = spliceHAVL havl1 e (HAVL r hr) + in havl1' `seq` All havl0 havl1' + All havl0 havl1 -> let havlO' = spliceHAVL (HAVL l hl) e havl0 + in havlO' `seq` All havlO' havl1 +----------------------------------------------------------------------- +------------------------- splitAtR Ends Here -------------------------- +----------------------------------------------------------------------- + +-- Local Datatype for results of take/drop operations. +data TakeResult e = AllTR (HAVL e) -- The resulting Tree + | MoreTR {-# UNPACK #-} !UINT -- No of tree elements still required (>=0!!) + +-- | This is a simplified version of 'splitAtL' which does not return the remaining tree. +-- The 'Int' argument n (n >= 0) specifies the number of elements to take (from the left). +-- This function raises an error if n is negative. +-- +-- If the tree size is greater than n the result is (Right l) where l contains +-- the leftmost n elements. +-- +-- If the tree size is less than or equal to n then the result is (Left s), where s is tree size. +-- +-- An empty tree will always yield a result of (Left 0). +-- +-- Complexity: O(n) +takeL :: Int -> AVL e -> Either Int (AVL e) +takeL n _ | n < 0 = error "takeL: Negative argument." +takeL 0 E = Left 0 -- Treat this case specially +takeL 0 _ = Right E +takeL ASINT(n) t = case takeL_ n t L(0) of -- Tree Heights are relative!! + MoreTR n_ -> Left ASINT(SUBINT(n,n_)) + AllTR (HAVL t' _) -> Right t' + +-- n > 0 !! +takeL_ :: UINT -> AVL e -> UINT -> TakeResult e +takeL_ n E _ = MoreTR n +takeL_ n (N l e r) h = takeL__ n l DECINT2(h) e r DECINT1(h) +takeL_ n (Z l e r) h = takeL__ n l DECINT1(h) e r DECINT1(h) +takeL_ n (P l e r) h = takeL__ n l DECINT1(h) e r DECINT2(h) + +-- n > 0 !! +takeL__ :: UINT -> AVL e -> UINT -> e -> AVL e -> UINT -> TakeResult e +takeL__ n l hl e r hr = + let takel = takeL_ n l hl + in case takel of + MoreTR L(0) -> let lhavl = HAVL l hl + in lhavl `seq` AllTR lhavl + MoreTR L(1) -> case r of + E -> MoreTR L(0) + _ -> let lhavl = pushRHAVL (HAVL l hl) e + in lhavl `seq` AllTR lhavl + MoreTR n_ -> let taker = takeL_ DECINT1(n_) r hr + in case taker of + AllTR havl0 -> let havl0' = spliceHAVL (HAVL l hl) e havl0 + in havl0' `seq` AllTR havl0' + _ -> taker + _ -> takel +----------------------------------------------------------------------- +-------------------------- takeL Ends Here ---------------------------- +----------------------------------------------------------------------- + +-- | This is a simplified version of 'splitAtR' which does not return the remaining tree. +-- The 'Int' argument n (n >= 0) specifies the number of elements to take (from the right). +-- This function raises an error if n is negative. +-- +-- If the tree size is greater than n the result is (Right r) where r contains +-- the rightmost n elements. +-- +-- If the tree size is less than or equal to n then the result is (Left s), where s is tree size. +-- +-- An empty tree will always yield a result of (Left 0). +-- +-- Complexity: O(n) +takeR :: Int -> AVL e -> Either Int (AVL e) +takeR n _ | n < 0 = error "takeR: Negative argument." +takeR 0 E = Left 0 -- Treat this case specially +takeR 0 _ = Right E +takeR ASINT(n) t = case takeR_ n t L(0) of -- Tree Heights are relative!! + MoreTR n_ -> Left ASINT(SUBINT(n,n_)) + AllTR (HAVL t' _) -> Right t' + +-- n > 0 !! +takeR_ :: UINT -> AVL e -> UINT -> TakeResult e +takeR_ n E _ = MoreTR n +takeR_ n (N l e r) h = takeR__ n l DECINT2(h) e r DECINT1(h) +takeR_ n (Z l e r) h = takeR__ n l DECINT1(h) e r DECINT1(h) +takeR_ n (P l e r) h = takeR__ n l DECINT1(h) e r DECINT2(h) + +-- n > 0 !! +takeR__ :: UINT -> AVL e -> UINT -> e -> AVL e -> UINT -> TakeResult e +takeR__ n l hl e r hr = + let taker = takeR_ n r hr + in case taker of + MoreTR L(0) -> let rhavl = HAVL r hr + in rhavl `seq` AllTR rhavl + MoreTR L(1) -> case l of + E -> MoreTR L(0) + _ -> let rhavl = pushLHAVL e (HAVL r hr) + in rhavl `seq` AllTR rhavl + MoreTR n_ -> let takel = takeR_ DECINT1(n_) l hl + in case takel of + AllTR havl0 -> let havl0' = spliceHAVL havl0 e (HAVL r hr) + in havl0' `seq` AllTR havl0' + _ -> takel + _ -> taker +----------------------------------------------------------------------- +-------------------------- takeR Ends Here ---------------------------- +----------------------------------------------------------------------- + +-- | This is a simplified version of 'splitAtL' which returns the remaining tree only (rightmost elements). +-- This function raises an error if n is negative. +-- +-- If the tree size is greater than n the result is (Right r) where r contains +-- the remaining elements (r will be non-empty). +-- +-- If the tree size is less than or equal to n then the result is (Left s), where s is tree size. +-- +-- An empty tree will always yield a result of (Left 0). +-- +-- Complexity: O(n) +dropL :: Int -> AVL e -> Either Int (AVL e) +dropL n _ | n < 0 = error "dropL: Negative argument." +dropL 0 E = Left 0 -- Treat this case specially +dropL 0 t = Right t +dropL ASINT(n) t = case dropL_ n t L(0) of -- Tree Heights are relative!! + MoreTR n_ -> Left ASINT(SUBINT(n,n_)) + AllTR (HAVL r _) -> Right r + +-- n > 0 !! +-- N.B Never returns a result of form (AllTR rhavl) where rhavl is empty +dropL_ :: UINT -> AVL e -> UINT -> TakeResult e +dropL_ n E _ = MoreTR n +dropL_ n (N l e r) h = dropL__ n l DECINT2(h) e r DECINT1(h) +dropL_ n (Z l e r) h = dropL__ n l DECINT1(h) e r DECINT1(h) +dropL_ n (P l e r) h = dropL__ n l DECINT1(h) e r DECINT2(h) + +-- n > 0 !! +-- N.B Never returns a result of form (AllTR rhavl) where rhavl is empty +dropL__ :: UINT -> AVL e -> UINT -> e -> AVL e -> UINT -> TakeResult e +dropL__ n l hl e r hr = + case dropL_ n l hl of + MoreTR L(0) -> let rhavl = pushLHAVL e (HAVL r hr) + in rhavl `seq` AllTR rhavl + MoreTR L(1) -> case r of + E -> MoreTR L(0) + _ -> let rhavl = HAVL r hr in rhavl `seq` AllTR rhavl + MoreTR n_ -> dropL_ DECINT1(n_) r hr + AllTR havl1 -> let havl1' = spliceHAVL havl1 e (HAVL r hr) + in havl1' `seq` AllTR havl1' +----------------------------------------------------------------------- +--------------------------- dropL Ends Here --------------------------- +----------------------------------------------------------------------- + +-- | This is a simplified version of 'splitAtR' which returns the remaining tree only (leftmost elements). +-- This function raises an error if n is negative. +-- +-- If the tree size is greater than n the result is (Right l) where l contains +-- the remaining elements (l will be non-empty). +-- +-- If the tree size is less than or equal to n then the result is (Left s), where s is tree size. +-- +-- An empty tree will always yield a result of (Left 0). +-- +-- Complexity: O(n) +dropR :: Int -> AVL e -> Either Int (AVL e) +dropR n _ | n < 0 = error "dropL: Negative argument." +dropR 0 E = Left 0 -- Treat this case specially +dropR 0 t = Right t +dropR ASINT(n) t = case dropR_ n t L(0) of -- Tree Heights are relative!! + MoreTR n_ -> Left ASINT(SUBINT(n,n_)) + AllTR (HAVL l _) -> Right l + +-- n > 0 !! +-- N.B Never returns a result of form (AllTR lhavl) where lhavl is empty +dropR_ :: UINT -> AVL e -> UINT -> TakeResult e +dropR_ n E _ = MoreTR n +dropR_ n (N l e r) h = dropR__ n l DECINT2(h) e r DECINT1(h) +dropR_ n (Z l e r) h = dropR__ n l DECINT1(h) e r DECINT1(h) +dropR_ n (P l e r) h = dropR__ n l DECINT1(h) e r DECINT2(h) + +-- n > 0 !! +-- N.B Never returns a result of form (AllTR lhavl) where lhavl is empty +dropR__ :: UINT -> AVL e -> UINT -> e -> AVL e -> UINT -> TakeResult e +dropR__ n l hl e r hr = + case dropR_ n r hr of + MoreTR L(0) -> let lhavl = pushRHAVL (HAVL l hl) e + in lhavl `seq` AllTR lhavl + MoreTR L(1) -> case l of + E -> MoreTR L(0) + _ -> let lhavl = HAVL l hl in lhavl `seq` AllTR lhavl + MoreTR n_ -> dropR_ DECINT1(n_) l hl + AllTR havl0 -> let havl0' = spliceHAVL (HAVL l hl) e havl0 + in havl0' `seq` AllTR havl0' +----------------------------------------------------------------------- +--------------------------- dropR Ends Here --------------------------- +----------------------------------------------------------------------- + + +-- Local Datatype for results of span operations. +data SpanResult e = Some (HAVL e) (HAVL e) -- Two tree/height pairs. Non Strict!! + | TheLot -- The Lot satisfied + +-- | Span an AVL tree from the left, using the supplied predicate. This function returns +-- a pair of trees (l,r), where l contains the leftmost consecutive elements which +-- satisfy the predicate. The leftmost element of r (if any) is the first to fail +-- the predicate. Either of the resulting trees may be empty. Element ordering is preserved. +-- +-- Complexity: O(n), where n is the size of l. +spanL :: (e -> Bool) -> AVL e -> (AVL e, AVL e) +spanL p t = case spanIt t L(0) of -- Tree heights are relative + TheLot -> (t, E) -- All satisfied + Some (HAVL l _) (HAVL r _) -> (l, r) -- Some satisfied + where + spanIt E _ = TheLot + spanIt (N l e r) h = spanIt_ l DECINT2(h) e r DECINT1(h) + spanIt (Z l e r) h = spanIt_ l DECINT1(h) e r DECINT1(h) + spanIt (P l e r) h = spanIt_ l DECINT1(h) e r DECINT2(h) + -- N.B: Never Returns (Some _ (HAVL E _)) (== TheLot) + spanIt_ l hl e r hr = + case spanIt l hl of + Some havl0 havl1 -> let havl1_ = spliceHAVL havl1 e (HAVL r hr) + in havl1_ `seq` Some havl0 havl1_ + TheLot -> if p e + then let spanItr = spanIt r hr + in case spanItr of + Some havl0 havl1 -> let havl0_ = spliceHAVL (HAVL l hl) e havl0 + in havl0_ `seq` Some havl0_ havl1 + _ -> spanItr + else let rhavl = pushLHAVL e (HAVL r hr) + lhavl = HAVL l hl + in lhavl `seq` rhavl `seq` Some lhavl rhavl +----------------------------------------------------------------------- +--------------------------- spanL Ends Here --------------------------- +----------------------------------------------------------------------- + +-- | Span an AVL tree from the right, using the supplied predicate. This function returns +-- a pair of trees (l,r), where r contains the rightmost consecutive elements which +-- satisfy the predicate. The rightmost element of l (if any) is the first to fail +-- the predicate. Either of the resulting trees may be empty. Element ordering is preserved. +-- +-- Complexity: O(n), where n is the size of r. +spanR :: (e -> Bool) -> AVL e -> (AVL e, AVL e) +spanR p t = case spanIt t L(0) of -- Tree heights are relative + TheLot -> (E, t) -- All satisfied + Some (HAVL l _) (HAVL r _) -> (l, r) -- Some satisfied + where + spanIt E _ = TheLot + spanIt (N l e r) h = spanIt_ l DECINT2(h) e r DECINT1(h) + spanIt (Z l e r) h = spanIt_ l DECINT1(h) e r DECINT1(h) + spanIt (P l e r) h = spanIt_ l DECINT1(h) e r DECINT2(h) + -- N.B: Never Returns (Some (HAVL E _) _) (== TheLot) + spanIt_ l hl e r hr = + case spanIt r hr of + Some havl0 havl1 -> let havl0_ = spliceHAVL (HAVL l hl) e havl0 + in havl0_ `seq` Some havl0_ havl1 + TheLot -> if p e + then let spanItl = spanIt l hl + in case spanItl of + Some havl0 havl1 -> let havl1_ = spliceHAVL havl1 e (HAVL r hr) + in havl1_ `seq` Some havl0 havl1_ + _ -> spanItl + else let lhavl = pushRHAVL (HAVL l hl) e + rhavl = HAVL r hr + in lhavl `seq` rhavl `seq` Some lhavl rhavl +----------------------------------------------------------------------- +--------------------------- spanR Ends Here --------------------------- +----------------------------------------------------------------------- + +-- Local Datatype for results of takeWhile/DropWhile operations. +data TakeWhileResult e = SomeTW (HAVL e) + | TheLotTW + +-- | This is a simplified version of 'spanL' which does not return the remaining tree +-- The result is the leftmost consecutive sequence of elements which satisfy the +-- supplied predicate (which may be empty). +-- +-- Complexity: O(n), where n is the size of the result. +takeWhileL :: (e -> Bool) -> AVL e -> AVL e +takeWhileL p t = case spanIt t L(0) of -- Tree heights are relative + TheLotTW -> t -- All satisfied + SomeTW (HAVL l _) -> l -- Some satisfied + where + spanIt E _ = TheLotTW + spanIt (N l e r) h = spanIt_ l DECINT2(h) e r DECINT1(h) + spanIt (Z l e r) h = spanIt_ l DECINT1(h) e r DECINT1(h) + spanIt (P l e r) h = spanIt_ l DECINT1(h) e r DECINT2(h) + spanIt_ l hl e r hr = + let twl = spanIt l hl + in case twl of + TheLotTW -> if p e + then let twr = spanIt r hr + in case twr of + SomeTW havl0 -> let havl0_ = spliceHAVL (HAVL l hl) e havl0 + in havl0_ `seq` SomeTW havl0_ + _ -> twr + else let lhavl = HAVL l hl in lhavl `seq` SomeTW lhavl + _ -> twl +----------------------------------------------------------------------- +------------------------- takeWhileL Ends Here ------------------------ +----------------------------------------------------------------------- + +-- | This is a simplified version of 'spanR' which does not return the remaining tree +-- The result is the rightmost consecutive sequence of elements which satisfy the +-- supplied predicate (which may be empty). +-- +-- Complexity: O(n), where n is the size of the result. +takeWhileR :: (e -> Bool) -> AVL e -> AVL e +takeWhileR p t = case spanIt t L(0) of -- Tree heights are relative + TheLotTW -> t -- All satisfied + SomeTW (HAVL r _) -> r -- Some satisfied + where + spanIt E _ = TheLotTW + spanIt (N l e r) h = spanIt_ l DECINT2(h) e r DECINT1(h) + spanIt (Z l e r) h = spanIt_ l DECINT1(h) e r DECINT1(h) + spanIt (P l e r) h = spanIt_ l DECINT1(h) e r DECINT2(h) + spanIt_ l hl e r hr = + let twr = spanIt r hr + in case twr of + TheLotTW -> if p e + then let twl = spanIt l hl + in case twl of + SomeTW havl1 -> let havl1_ = spliceHAVL havl1 e (HAVL r hr) + in havl1_ `seq` SomeTW havl1_ + _ -> twl + else let rhavl = HAVL r hr in rhavl `seq` SomeTW rhavl + _ -> twr +----------------------------------------------------------------------- +------------------------- takeWhileR Ends Here ------------------------ +----------------------------------------------------------------------- + +-- | This is a simplified version of 'spanL' which does not return the tree containing +-- the elements which satisfy the supplied predicate. +-- The result is a tree whose leftmost element is the first to fail the predicate, starting from +-- the left (which may be empty). +-- +-- Complexity: O(n), where n is the number of elements dropped. +dropWhileL :: (e -> Bool) -> AVL e -> AVL e +dropWhileL p t = case spanIt t L(0) of -- Tree heights are relative + TheLotTW -> E -- All satisfied + SomeTW (HAVL r _) -> r -- Some satisfied + where + spanIt E _ = TheLotTW + spanIt (N l e r) h = spanIt_ l DECINT2(h) e r DECINT1(h) + spanIt (Z l e r) h = spanIt_ l DECINT1(h) e r DECINT1(h) + spanIt (P l e r) h = spanIt_ l DECINT1(h) e r DECINT2(h) + spanIt_ l hl e r hr = + case spanIt l hl of + SomeTW havl1 -> let havl1_ = spliceHAVL havl1 e (HAVL r hr) + in havl1_ `seq` SomeTW havl1_ + TheLotTW -> if p e + then spanIt r hr + else let rhavl = pushLHAVL e (HAVL r hr) + in rhavl `seq` SomeTW rhavl +----------------------------------------------------------------------- +---------------------- dropWhileL Ends Here --------------------------- +----------------------------------------------------------------------- + +-- | This is a simplified version of 'spanR' which does not return the tree containing +-- the elements which satisfy the supplied predicate. +-- The result is a tree whose rightmost element is the first to fail the predicate, starting from +-- the right (which may be empty). +-- +-- Complexity: O(n), where n is the number of elements dropped. +dropWhileR :: (e -> Bool) -> AVL e -> AVL e +dropWhileR p t = case spanIt t L(0) of -- Tree heights are relative + TheLotTW -> E -- All satisfied + SomeTW (HAVL l _) -> l -- Some satisfied + where + spanIt E _ = TheLotTW + spanIt (N l e r) h = spanIt_ l DECINT2(h) e r DECINT1(h) + spanIt (Z l e r) h = spanIt_ l DECINT1(h) e r DECINT1(h) + spanIt (P l e r) h = spanIt_ l DECINT1(h) e r DECINT2(h) + spanIt_ l hl e r hr = + case spanIt r hr of + SomeTW havl0 -> let havl0_ = spliceHAVL (HAVL l hl) e havl0 + in havl0_ `seq` SomeTW havl0_ + TheLotTW -> if p e + then spanIt l hl + else let lhavl = pushRHAVL (HAVL l hl) e + in lhavl `seq` SomeTW lhavl +----------------------------------------------------------------------- +---------------------- dropWhileR Ends Here --------------------------- +----------------------------------------------------------------------- + + +-- | Rotate an AVL tree one place left. This function pops the leftmost element and pushes into +-- the rightmost position. An empty tree yields an empty tree. +-- +-- Complexity: O(log n) +rotateL :: AVL e -> AVL e +rotateL E = E +rotateL (N l e r) = case popLN l e r of UBT2(e_,t) -> pushR t e_ +rotateL (Z l e r) = case popLZ l e r of UBT2(e_,t) -> pushR t e_ +rotateL (P l e r) = case popLP l e r of UBT2(e_,t) -> pushR t e_ + +-- | Rotate an AVL tree one place right. This function pops the rightmost element and pushes into +-- the leftmost position. An empty tree yields an empty tree. +-- +-- Complexity: O(log n) +rotateR :: AVL e -> AVL e +rotateR E = E +rotateR (N l e r) = case popRN l e r of UBT2(t,e_) -> pushL e_ t +rotateR (Z l e r) = case popRZ l e r of UBT2(t,e_) -> pushL e_ t +rotateR (P l e r) = case popRP l e r of UBT2(t,e_) -> pushL e_ t + +-- | Similar to 'rotateL', but returns the rotated element. This function raises an error if +-- applied to an empty tree. +-- +-- Complexity: O(log n) +popRotateL :: AVL e -> (e, AVL e) +popRotateL E = error "popRotateL: Empty tree." +popRotateL (N l e r) = case popLN l e r of UBT2(e_,t) -> popRotateL' e_ t +popRotateL (Z l e r) = case popLZ l e r of UBT2(e_,t) -> popRotateL' e_ t +popRotateL (P l e r) = case popLP l e r of UBT2(e_,t) -> popRotateL' e_ t +popRotateL' :: e -> AVL e -> (e, AVL e) +popRotateL' e t = let t' = pushR t e in t' `seq` (e,t') + +-- | Similar to 'rotateR', but returns the rotated element. This function raises an error if +-- applied to an empty tree. +-- +-- Complexity: O(log n) +popRotateR :: AVL e -> (AVL e, e) +popRotateR E = error "popRotateR: Empty tree." +popRotateR (N l e r) = case popRN l e r of UBT2(t,e_) -> popRotateR' t e_ +popRotateR (Z l e r) = case popRZ l e r of UBT2(t,e_) -> popRotateR' t e_ +popRotateR (P l e r) = case popRP l e r of UBT2(t,e_) -> popRotateR' t e_ +popRotateR' :: AVL e -> e -> (AVL e, e) +popRotateR' t e = let t' = pushL e t in t' `seq` (t',e) + + +-- | Rotate an AVL tree left by n places. If s is the size of the tree then ordinarily n +-- should be in the range [0..s-1]. However, this function will deliver a correct result +-- for any n (n\<0 or n\>=s), the actual rotation being given by (n \`mod\` s) in such cases. +-- The result of rotating an empty tree is an empty tree. +-- +-- Complexity: O(n) +rotateByL :: AVL e -> Int -> AVL e +rotateByL t ASINT(n) = case COMPAREUINT n L(0) of + LT -> rotateByR__ t NEGATE(n) + EQ -> t + GT -> rotateByL__ t n +-- n>=0!! +{-# INLINE rotateByL_ #-} +rotateByL_ :: AVL e -> UINT -> AVL e +rotateByL_ t L(0) = t +rotateByL_ t n = rotateByL__ t n +-- n>0!! +rotateByL__ :: AVL e -> UINT -> AVL e +rotateByL__ E _ = E +rotateByL__ t n = case splitL n t L(0) of -- Tree Heights are relative!! + More L(0) -> t + More m -> let s = SUBINT(n,m) -- Actual size of tree, > 0!! + n_ = _MODULO_(n,s) -- Actual shift required, 0..s-1 + in if ADDINT(n_,n_) LEQ s + then rotateByL_ t n_ -- n_ may be 0 !! + else rotateByR__ t SUBINT(s,n_) -- (s-n_) can't be 0 + All (HAVL l hl) (HAVL r hr) -> joinH' r hr l hl + + +-- | Rotate an AVL tree right by n places. If s is the size of the tree then ordinarily n +-- should be in the range [0..s-1]. However, this function will deliver a correct result +-- for any n (n\<0 or n\>=s), the actual rotation being given by (n \`mod\` s) in such cases. +-- The result of rotating an empty tree is an empty tree. +-- +-- Complexity: O(n) +rotateByR :: AVL e -> Int -> AVL e +rotateByR t ASINT(n) = case COMPAREUINT n L(0) of + LT -> rotateByL__ t NEGATE(n) + EQ -> t + GT -> rotateByR__ t n +-- n>=0!! +{-# INLINE rotateByR_ #-} +rotateByR_ :: AVL e -> UINT -> AVL e +rotateByR_ t L(0) = t +rotateByR_ t n = rotateByR__ t n +-- n>0!! +rotateByR__ :: AVL e -> UINT -> AVL e +rotateByR__ E _ = E +rotateByR__ t n = case splitR n t L(0) of -- Tree Heights are relative!! + More L(0) -> t + More m -> let s = SUBINT(n,m) -- Actual size of tree, > 0!! + n_ = _MODULO_(n,s) -- Actual shift required, 0..s-1 + in if ADDINT(n_,n_) LEQ s + then rotateByR_ t n_ -- n_ may be 0 !! + else rotateByL__ t SUBINT(s,n_) -- (s-n_) can_t be 0 + All (HAVL l hl) (HAVL r hr) -> joinH' r hr l hl + + +-- | Divide a sorted AVL tree into left and right sorted trees (l,r), such that l contains all the +-- elements less than or equal to according to the supplied selector and r contains all the elements greater than +-- according to the supplied selector. +-- +-- Complexity: O(log n) +genForkL :: (e -> Ordering) -> AVL e -> (AVL e, AVL e) +genForkL c avl = let (HAVL l _,HAVL r _) = genForkL_ L(0) avl -- Tree heights are relative + in (l,r) + where + genForkL_ h E = (HAVL E h, HAVL E h) + genForkL_ h (N l e r) = genForkL__ l DECINT2(h) e r DECINT1(h) + genForkL_ h (Z l e r) = genForkL__ l DECINT1(h) e r DECINT1(h) + genForkL_ h (P l e r) = genForkL__ l DECINT1(h) e r DECINT2(h) + genForkL__ l hl e r hr = case c e of + -- Current element > pivot, so goes in right half + LT -> let (havl0,havl1) = genForkL_ hl l + havl1_ = spliceHAVL havl1 e (HAVL r hr) + in havl1_ `seq` (havl0, havl1_) + -- Current element = pivot, so goes in left half and stop here + EQ -> let lhavl = pushRHAVL (HAVL l hl) e + rhavl = HAVL r hr + in lhavl `seq` rhavl `seq` (lhavl,rhavl) + -- Current element < pivot, so goes in left half + GT -> let (havl0,havl1) = genForkL_ hr r + havl0_ = spliceHAVL (HAVL l hl) e havl0 + in havl0_ `seq` (havl0_, havl1) + +-- | Divide a sorted AVL tree into left and right sorted trees (l,r), such that l contains all the +-- elements less than supplied selector and r contains all the elements greater than or equal to the +-- supplied selector. +-- +-- Complexity: O(log n) +genForkR :: (e -> Ordering) -> AVL e -> (AVL e, AVL e) +genForkR c avl = let (HAVL l _,HAVL r _) = genForkR_ L(0) avl -- Tree heights are relative + in (l,r) + where + genForkR_ h E = (HAVL E h, HAVL E h) + genForkR_ h (N l e r) = genForkR__ l DECINT2(h) e r DECINT1(h) + genForkR_ h (Z l e r) = genForkR__ l DECINT1(h) e r DECINT1(h) + genForkR_ h (P l e r) = genForkR__ l DECINT1(h) e r DECINT2(h) + genForkR__ l hl e r hr = case c e of + -- Current element > pivot, so goes in right half + LT -> let (havl0,havl1) = genForkR_ hl l + havl1_ = spliceHAVL havl1 e (HAVL r hr) + in havl1_ `seq` (havl0, havl1_) + -- Current element = pivot, so goes in right half and stop here + EQ -> let rhavl = pushLHAVL e (HAVL r hr) + lhavl = HAVL l hl + in lhavl `seq` rhavl `seq` (lhavl, rhavl) + -- Current element < pivot, so goes in left half + GT -> let (havl0,havl1) = genForkR_ hr r + havl0_ = spliceHAVL (HAVL l hl) e havl0 + in havl0_ `seq` (havl0_, havl1) + + +-- | Similar to 'genForkL' and 'genForkR', but returns any equal element found (instead of +-- incorporating it into the left or right tree results respectively). +-- +-- Complexity: O(log n) +genFork :: (e -> COrdering a) -> AVL e -> (AVL e, Maybe a, AVL e) +genFork c avl = let (HAVL l _, mba, HAVL r _) = genFork_ L(0) avl -- Tree heights are relative + in (l,mba,r) + where + genFork_ h E = (HAVL E h, Nothing, HAVL E h) + genFork_ h (N l e r) = genFork__ l DECINT2(h) e r DECINT1(h) + genFork_ h (Z l e r) = genFork__ l DECINT1(h) e r DECINT1(h) + genFork_ h (P l e r) = genFork__ l DECINT1(h) e r DECINT2(h) + genFork__ l hl e r hr = case c e of + -- Current element > pivot + Lt -> let (havl0,mba,havl1) = genFork_ hl l + havl1_ = spliceHAVL havl1 e (HAVL r hr) + in havl1_ `seq` (havl0, mba, havl1_) + -- Current element = pivot + Eq a -> let lhavl = HAVL l hl + rhavl = HAVL r hr + in lhavl `seq` rhavl `seq` (lhavl, Just a, rhavl) + -- Current element < pivot + Gt -> let (havl0,mba,havl1) = genFork_ hr r + havl0_ = spliceHAVL (HAVL l hl) e havl0 + in havl0_ `seq` (havl0_, mba, havl1) + +-- | This is a simplified version of 'genForkL' which returns a sorted tree containing +-- only those elements which are less than or equal to according to the supplied selector. +-- This function also has the synonym 'genDropGT'. +-- +-- Complexity: O(log n) +genTakeLE :: (e -> Ordering) -> AVL e -> AVL e +genTakeLE c avl = let HAVL l _ = genForkL_ L(0) avl -- Tree heights are relative + in l + where + genForkL_ h E = HAVL E h + genForkL_ h (N l e r) = genForkL__ l DECINT2(h) e r DECINT1(h) + genForkL_ h (Z l e r) = genForkL__ l DECINT1(h) e r DECINT1(h) + genForkL_ h (P l e r) = genForkL__ l DECINT1(h) e r DECINT2(h) + genForkL__ l hl e r hr = case c e of + LT -> genForkL_ hl l + EQ -> pushRHAVL (HAVL l hl) e + GT -> let havl0 = genForkL_ hr r + in spliceHAVL (HAVL l hl) e havl0 + + +-- | A synonym for 'genTakeLE'. +-- +-- Complexity: O(log n) +{-# INLINE genDropGT #-} +genDropGT :: (e -> Ordering) -> AVL e -> AVL e +genDropGT = genTakeLE + +-- | This is a simplified version of 'genForkL' which returns a sorted tree containing +-- only those elements which are greater according to the supplied selector. +-- This function also has the synonym 'genDropLE'. +-- +-- Complexity: O(log n) +genTakeGT :: (e -> Ordering) -> AVL e -> AVL e +genTakeGT c avl = let HAVL r _ = genForkL_ L(0) avl -- Tree heights are relative + in r + where + genForkL_ h E = HAVL E h + genForkL_ h (N l e r) = genForkL__ l DECINT2(h) e r DECINT1(h) + genForkL_ h (Z l e r) = genForkL__ l DECINT1(h) e r DECINT1(h) + genForkL_ h (P l e r) = genForkL__ l DECINT1(h) e r DECINT2(h) + genForkL__ l hl e r hr = case c e of + LT -> let havl1 = genForkL_ hl l + in spliceHAVL havl1 e (HAVL r hr) + EQ -> HAVL r hr + GT -> genForkL_ hr r + +-- | A synonym for 'genTakeGT'. +-- +-- Complexity: O(log n) +{-# INLINE genDropLE #-} +genDropLE :: (e -> Ordering) -> AVL e -> AVL e +genDropLE = genTakeGT + +-- | This is a simplified version of 'genForkR' which returns a sorted tree containing +-- only those elements which are less than according to the supplied selector. +-- This function also has the synonym 'genDropGE'. +-- +-- Complexity: O(log n) +genTakeLT :: (e -> Ordering) -> AVL e -> AVL e +genTakeLT c avl = let HAVL l _ = genForkL_ L(0) avl -- Tree heights are relative + in l + where + genForkL_ h E = HAVL E h + genForkL_ h (N l e r) = genForkL__ l DECINT2(h) e r DECINT1(h) + genForkL_ h (Z l e r) = genForkL__ l DECINT1(h) e r DECINT1(h) + genForkL_ h (P l e r) = genForkL__ l DECINT1(h) e r DECINT2(h) + genForkL__ l hl e r hr = case c e of + LT -> genForkL_ hl l + EQ -> HAVL l hl + GT -> let havl0 = genForkL_ hr r + in spliceHAVL (HAVL l hl) e havl0 + + +-- | A synonym for 'genTakeLT'. +-- +-- Complexity: O(log n) +{-# INLINE genDropGE #-} +genDropGE :: (e -> Ordering) -> AVL e -> AVL e +genDropGE = genTakeLT + +-- | This is a simplified version of 'genForkR' which returns a sorted tree containing +-- only those elements which are greater or equal to according to the supplied selector. +-- This function also has the synonym 'genDropLT'. +-- +-- Complexity: O(log n) +genTakeGE :: (e -> Ordering) -> AVL e -> AVL e +genTakeGE c avl = let HAVL r _ = genForkL_ L(0) avl -- Tree heights are relative + in r + where + genForkL_ h E = HAVL E h + genForkL_ h (N l e r) = genForkL__ l DECINT2(h) e r DECINT1(h) + genForkL_ h (Z l e r) = genForkL__ l DECINT1(h) e r DECINT1(h) + genForkL_ h (P l e r) = genForkL__ l DECINT1(h) e r DECINT2(h) + genForkL__ l hl e r hr = case c e of + LT -> let havl1 = genForkL_ hl l + in spliceHAVL havl1 e (HAVL r hr) + EQ -> pushLHAVL e (HAVL r hr) + GT -> genForkL_ hr r + +-- | A synonym for 'genTakeGE'. +-- +-- Complexity: O(log n) +{-# INLINE genDropLT #-} +genDropLT :: (e -> Ordering) -> AVL e -> AVL e +genDropLT = genTakeGE + diff --git a/Data/Tree/AVL/Test/AllTests.hs b/Data/Tree/AVL/Test/AllTests.hs new file mode 100644 --- /dev/null +++ b/Data/Tree/AVL/Test/AllTests.hs @@ -0,0 +1,1405 @@ +{-# OPTIONS -fglasgow-exts #-} +----------------------------------------------------------------------------- +-- | +-- Module : Data.Tree.AVL.Test.AllTests +-- Copyright : (c) Adrian Hey 2004,2005,2006,2007 +-- License : BSD3 +-- +-- Maintainer : http://homepages.nildram.co.uk/~ahey/em.png +-- Stability : unstable +-- Portability : portable +-- +-- This module contains a large set of fairly comprehensive but extremely +-- time consuming tests of AVL tree functions (not based on QuickCheck). +-- +-- They can all be run using 'allTests', or they can be run individually. +----------------------------------------------------------------------------- +module Data.Tree.AVL.Test.AllTests +(allTests +,testReadPath +,testIsBalanced +,testIsSorted +,testSize +,testClipSize +,testGenWrite +,testGenPush +,testPushL +,testPushR +,testGenDel +,testAssertDelL +,testAssertDelR +,testAssertPopL +,testPopHL +,testAssertPopR +,testGenAssertPop +,testFlatten +,testJoin +,testJoinHAVL +,testConcatAVL +,testFlatConcat +,testFoldrAVL +,testFoldrAVL' +,testFoldlAVL +,testFoldlAVL' +,testFoldr1AVL +,testFoldr1AVL' +,testFoldl1AVL +,testFoldl1AVL' +,testMapAccumLAVL +,testMapAccumRAVL +,testMapAccumLAVL' +,testMapAccumRAVL' +#ifdef __GLASGOW_HASKELL__ +,testMapAccumLAVL'' +,testMapAccumRAVL'' +#endif +,testSplitAtL +,testFilterViaList +,testFilterAVL +,testMapMaybeViaList +,testMapMaybeAVL +,testTakeL +,testDropL +,testSplitAtR +,testTakeR +,testDropR +,testSpanL +,testTakeWhileL +,testDropWhileL +,testSpanR +,testTakeWhileR +,testDropWhileR +,testRotateL +,testRotateR +,testRotateByL +,testRotateByR +,testGenForkL +,testGenForkR +,testGenFork +,testGenTakeLE +,testGenTakeGT +,testGenTakeGE +,testGenTakeLT +,testGenUnion +,testGenUnionMaybe +,testGenIntersection +,testGenIntersectionMaybe +,testGenIntersectionAsListL +,testGenIntersectionMaybeAsListL +,testGenDifference +,testGenDifferenceMaybe +,testGenSymDifference +,testGenIsSubsetOf +,testGenIsSubsetOfBy +,testCompareHeight +,testShowReadEq +-- Zipper tests +,testGenOpenClose +,testDelClose +,testOpenLClose +,testOpenRClose +,testMoveL +,testMoveR +,testInsertL +,testInsertMoveL +,testInsertR +,testInsertMoveR +,testInsertTreeL +,testInsertTreeR +,testDelMoveL +,testDelMoveR +,testDelAllL +,testDelAllR +,testDelAllCloseL +,testDelAllIncCloseL +,testDelAllCloseR +,testDelAllIncCloseR +,testZipSize +,testGenTryOpenLE +,testGenTryOpenGE +,testGenOpenEither +,testBAVLtoZipper +) where + +import Data.COrdering +import Data.Tree.AVLX + +import Data.List(insert,mapAccumL,mapAccumR) +import System.Exit(exitFailure) + +#ifdef __GLASGOW_HASKELL__ +import GHC.Base +#include "ghcdefs.h" +#else +#include "h98defs.h" +#endif + + +-- import Debug.Trace(trace) +-- import System.IO.Unsafe(unsafePerformIO) + +-- | Run every test in this module (takes a very long time). +allTests :: IO () +allTests = + do testReadPath + testIsBalanced + testIsSorted + testSize + testClipSize + testGenWrite + testGenPush + testPushL + testPushR + testGenDel + testAssertDelL + testAssertDelR + testAssertPopL + testPopHL + testAssertPopR + testGenAssertPop + testFlatten + testJoin + testJoinHAVL + testConcatAVL + testFlatConcat + testFoldrAVL + testFoldrAVL' + testFoldlAVL + testFoldlAVL' + testFoldr1AVL + testFoldr1AVL' + testFoldl1AVL + testFoldl1AVL' + testMapAccumLAVL + testMapAccumRAVL + testMapAccumLAVL' + testMapAccumRAVL' +#ifdef __GLASGOW_HASKELL__ + testMapAccumLAVL'' + testMapAccumRAVL'' +#endif + testSplitAtL + testFilterViaList + testFilterAVL + testMapMaybeViaList + testMapMaybeAVL + testTakeL + testDropL + testSplitAtR + testTakeR + testDropR + testSpanL + testTakeWhileL + testDropWhileL + testSpanR + testTakeWhileR + testDropWhileR + testRotateL + testRotateR + testRotateByL + testRotateByR + testGenForkL + testGenForkR + testGenFork + testGenTakeLE + testGenTakeGT + testGenTakeGE + testGenTakeLT + testGenUnion + testGenUnionMaybe + testGenIntersection + testGenIntersectionMaybe + testGenIntersectionAsListL + testGenIntersectionMaybeAsListL + testGenDifference + testGenDifferenceMaybe + testGenSymDifference + testGenIsSubsetOf + testGenIsSubsetOfBy + testCompareHeight + testShowReadEq +-- Zipper tests + testGenOpenClose + testDelClose + testOpenLClose + testOpenRClose + testMoveL + testMoveR + testInsertL + testInsertMoveL + testInsertR + testInsertMoveR + testInsertTreeL + testInsertTreeR + testDelMoveL + testDelMoveR + testDelAllL + testDelAllR + testDelAllCloseL + testDelAllIncCloseL + testDelAllCloseR + testDelAllIncCloseR + testZipSize + testGenTryOpenLE + testGenTryOpenGE + testGenOpenEither + testBAVLtoZipper + + +-- | Test isBalanced is capable of failing for a few non-AVL trees. +testIsBalanced :: IO () +testIsBalanced = do title "isBalanced" + if or [isBalanced t | t <- nonAVLs] then failed else passed + where nonAVLs :: [AVL Int] + nonAVLs = [Z E 0 (Z E 0 E) + ,Z (Z E 0 E) 0 E + ,N E 0 E + ,P E 0 E + ] + +-- | Test isSorted is capable of failing for a few non-sorted trees. +testIsSorted :: IO () +testIsSorted = do title "isSorted" + if or [isSorted compare (asTreeL l) | l <- nonSorted] then failed else passed + where nonSorted = ["AA","BA" + ,"AAA","ABA","ABB","AAB" + ,"AABC","ACBA","ABCC","ABBB","AAAB" + ] + +-- | Test size function +testSize :: IO () +testSize = do title "size" + exhaustiveTest test (take 6 allAVL) + where test _ s t = size t == s + +-- | Test clipSize function +testClipSize :: IO () +testClipSize = do title "clipSize" + exhaustiveTest test (take 6 allAVL) + where test _ s t = all (== Nothing) [clipSize n t | n <- [0..s-1 ]] && + all (== Just s ) [clipSize n t | n <- [s..s+10]] + +-- | Test genWrite function +testGenWrite :: IO () +testGenWrite = do title "genWrite" + exhaustiveTest test (take 5 allNonEmptyAVL) + where test _ s t = all test_ [0..s-1] + where test_ n = let t_ = genWrite (withCC' (+) n) t + in isBalanced t_ && (asListL t_ == [0..n-1]++(n+n):[n+1..s-1]) + + +-- | Test genPush function +testGenPush :: IO () +-- Also exercises: mapAVL' and genContains +testGenPush = do title "genPush" + exhaustiveTest test (take 6 allAVL) + where test h s t = all oddTest odds && all evenTest evens + where t_ = mapAVL' (\n -> 2*n+1) t -- t_ elements are odd, 1,3..2*s-1 + odds = [1,3..2*s-1] + evens = [0,2..2*s ] + oddTest n = let t__ = push n t_ -- Should yield identical trees + s__ = size t__ + h__ = ASINT(height t__) + in (s__ == s) && (isSortedOK compare t__) && (h__== h) + evenTest n = let t__ = push n t_ + s__ = size t__ + h__ = ASINT(height t__) + in (s__ == s+1) && (isSortedOK compare t__) && (h__-h <= 1) && (t__ `contains` n) + push e = genPush (sndCC e) e + contains avl e = genContains avl (compare e) + +-- | Test genDel function +testGenDel :: IO () +testGenDel = do title "genDel" + exhaustiveTest test (take 5 allNonEmptyAVL) + where test h s t = all oddTest odds && all evenTest evens + where t_ = mapAVL' (\n -> 2*n+1) t -- t_ elements are odd, 1,3..2*s-1 + odds = [1,3..2*s-1] + evens = [0,2..2*s ] + oddTest n = let t__ = del n t_ + in case checkHeight t__ of + Just h_ -> (h-h_<=1) && (insert n (asListL t__) == odds) + Nothing -> False + evenTest n = let t__ = del n t_ + in case checkHeight t__ of + Just h_ -> (h==h_) && (asListL t__ == odds) + Nothing -> False + del e = genDel (compare e) + +-- | Test genAssertPop function +testGenAssertPop :: IO () +testGenAssertPop = + do title "genAssertPop" + exhaustiveTest test (take 5 allNonEmptyAVL) + where test h s t = all testElem elems + where elems = [0,1..s-1] + testElem n = let (n_,t_) = genAssertPop (fstCC n) t + in case checkHeight t_ of + Just h_ -> (h-h_<=1) && (insert n_ (asListL t_) == elems) + Nothing -> False + +-- | Test pushL function +-- Also exercises: asListL +testPushL :: IO () +testPushL = do title "pushL" + exhaustiveTest test (take 6 allAVL) + where test h _ t = let t_ = 0 `pushL` t + in case checkHeight t_ of + Just h_ | (h_==h+1) || (h_==h) -> asListL t_ == (0 : asListL t) + _ -> False + +-- | Test pushR function +-- Also exercises: asListR +testPushR :: IO () +testPushR = do title "pushR" + exhaustiveTest test (take 6 allAVL) + where test h s t = let t_ = t `pushR` s + in case checkHeight t_ of + Just h_ | (h_==h+1) || (h_==h) -> asListR t_ == (s : asListR t) + _ -> False + +-- | Test assertDelL function +-- Also exercises: asListL +testAssertDelL :: IO () +testAssertDelL = + do title "assertDelL" + exhaustiveTest test (take 5 allNonEmptyAVL) + where test h _ t = let t_ = assertDelL t + in case checkHeight t_ of + Just h_ | (h_==h-1) || (h_==h) -> asListL t_ == (tail $ asListL t) + _ -> False + +-- | Test delR function +-- Also exercises: asListR +testAssertDelR :: IO () +testAssertDelR = + do title "assertDelR" + exhaustiveTest test (take 5 allNonEmptyAVL) + where test h _ t = let t_ = assertDelR t + in case checkHeight t_ of + Just h_ | (h_==h-1) || (h_==h) -> asListR t_ == (tail $ asListR t) + _ -> False + +-- | Test assertPopL function +-- Also exercises: asListL +testAssertPopL :: IO () +testAssertPopL = + do title "assertPopL" + exhaustiveTest test (take 5 allNonEmptyAVL) + where test h _ t = let (v,t_) = assertPopL t + in case checkHeight t_ of + Just h_ | (h_==h-1) || (h_==h) -> (v : asListL t_) == asListL t + _ -> False + +-- | Test popHL function +-- This test can only be run if popHL and HAVL are not hidden. +-- However, popHL is exercised by indirectly by testConcatAVL anyway +testPopHL :: IO () +testPopHL = do title "popHL" + exhaustiveTest test (take 5 allNonEmptyAVL) + where test _ _ t = let UBT3(v, t_,h) = popHL t + in case checkHeight t_ of + Just h_ | (h_== ASINT(h)) -> (v : asListL t_) == asListL t + _ -> False + + +-- | Test assertPopR function +-- Also exercises: asListR +testAssertPopR :: IO () +testAssertPopR = + do title "assertPopR" + exhaustiveTest test (take 5 allNonEmptyAVL) + where test h _ t = let (t_,v) = assertPopR t + in case checkHeight t_ of + Just h_ | (h_==h-1) || (h_==h) -> (v : asListR t_) == asListR t + _ -> False + +-- | Test flatten function +-- Also exercises: asListL,replicateAVL +testFlatten :: IO () +testFlatten = do title "flatten" + exhaustiveTest test (take 6 allAVL) + where test _ _ t = let t_ = flatten t + in isBalanced t_ && (asListL t == asListL t_) + +-- | Test foldrAVL +testFoldrAVL :: IO () +testFoldrAVL = do title "foldrAVL" + exhaustiveTest test (take 6 allAVL) + where test _ s t = foldrAVL (:) [] t == [0..s-1] +-- | Test foldrAVL' +testFoldrAVL' :: IO () +testFoldrAVL' = do title "foldrAVL'" + exhaustiveTest test (take 6 allAVL) + where test _ s t = foldrAVL' (:) [] t == [0..s-1] +-- | Test foldlAVL +testFoldlAVL :: IO () +testFoldlAVL = do title "foldlAVL" + exhaustiveTest test (take 6 allAVL) + where test _ s t = foldlAVL (flip (:)) [] t == [s-1,s-2..0] +-- | Test foldlAVL' +testFoldlAVL' :: IO () +testFoldlAVL' = do title "foldlAVL'" + exhaustiveTest test (take 6 allAVL) + where test _ s t = foldlAVL' (flip (:)) [] t == [s-1,s-2..0] +-- | Test foldr1AVL +testFoldr1AVL :: IO () +testFoldr1AVL = do title "foldr1AVL" + exhaustiveTest test (take 5 allNonEmptyAVL) + where test _ s t = foldr1AVL (-) t == foldr1 (-) [0..s-1] +-- | Test foldr1AVL' +testFoldr1AVL' :: IO () +testFoldr1AVL' = do title "foldr1AVL'" + exhaustiveTest test (take 5 allNonEmptyAVL) + where test _ s t = foldr1AVL' (-) t == foldr1 (-) [0..s-1] +-- | Test foldl1AVL +testFoldl1AVL :: IO () +testFoldl1AVL = do title "foldl1AVL" + exhaustiveTest test (take 5 allNonEmptyAVL) + where test _ s t = foldl1AVL (-) t == foldl1 (-) [0..s-1] +-- | Test foldl1AVL' +testFoldl1AVL' :: IO () +testFoldl1AVL' = do title "foldl1AVL'" + exhaustiveTest test (take 5 allNonEmptyAVL) + where test _ s t = foldl1AVL' (-) t == foldl1 (-) [0..s-1] + +-- | Test mapAccumLAVL +testMapAccumLAVL :: IO () +testMapAccumLAVL = do title "mapAccumLAVL" + exhaustiveTest test (take 6 allAVL) + where test _ _ t = let (nt,t') = mapAccumLAVL f 0 t + (nl,l ) = mapAccumL f 0 (asListL t) + in (nt==nl) && ((asListL t') == l) && (isSortedOK compare t') + f acc n = (acc+n,n+1) + +-- | Test mapAccumRAVL +testMapAccumRAVL :: IO () +testMapAccumRAVL = do title "mapAccumRAVL" + exhaustiveTest test (take 6 allAVL) + where test _ _ t = let (nt,t') = mapAccumRAVL f 0 t + (nl,l ) = mapAccumR f 0 (asListL t) + in (nt==nl) && ((asListL t') == l) && (isSortedOK compare t') + f acc n = (acc+n,n+1) + +-- | Test mapAccumLAVL' +testMapAccumLAVL' :: IO () +testMapAccumLAVL' = do title "mapAccumLAVL'" + exhaustiveTest test (take 6 allAVL) + where test _ _ t = let (nt,t') = mapAccumLAVL' f 0 t + (nl,l ) = mapAccumL f 0 (asListL t) + in (nt==nl) && ((asListL t') == l) && (isSortedOK compare t') + f acc n = (acc+n,n+1) + +-- | Test mapAccumRAVL' +testMapAccumRAVL' :: IO () +testMapAccumRAVL' = do title "mapAccumRAVL'" + exhaustiveTest test (take 6 allAVL) + where test _ _ t = let (nt,t') = mapAccumRAVL' f 0 t + (nl,l ) = mapAccumR f 0 (asListL t) + in (nt==nl) && ((asListL t') == l) && (isSortedOK compare t') + f acc n = (acc+n,n+1) + +#ifdef __GLASGOW_HASKELL__ +-- | Test mapAccumLAVL'' +testMapAccumLAVL'' :: IO () +testMapAccumLAVL'' = do title "mapAccumLAVL''" + exhaustiveTest test (take 6 allAVL) + where test _ _ t = let (nt,t') = mapAccumLAVL'' f_ 0 t + (nl,l ) = mapAccumL f 0 (asListL t) + in (nt==nl) && ((asListL t') == l) && (isSortedOK compare t') + f_ acc n = UBT2(acc+n,n+1) + f acc n = (acc+n,n+1) + +-- | Test mapAccumRAVL'' +testMapAccumRAVL'' :: IO () +testMapAccumRAVL'' = do title "mapAccumRAVL''" + exhaustiveTest test (take 6 allAVL) + where test _ _ t = let (nt,t') = mapAccumRAVL'' f_ 0 t + (nl,l ) = mapAccumR f 0 (asListL t) + in (nt==nl) && ((asListL t') == l) && (isSortedOK compare t') + f_ acc n = UBT2(acc+n,n+1) + f acc n = (acc+n,n+1) +#endif + +-- | Test the join function +testJoin :: IO () +testJoin = let trees = take num $ concatMap (\(_,ts) -> ts) allAVL + num = 2000 + in do title "join" + putStrLn $ "Testing " ++ show (num*num) ++ " tree pairs.." + if and [test l $ mapAVL (ls+) r | (l,ls) <- trees, (r,_) <- trees] then passed else failed + where test l r = let j = l `join` r + in isBalanced j && (asListL j == l `toListL` asListL r) + +-- | Test the joinHAVL function +testJoinHAVL :: IO () +testJoinHAVL = let trees = take num $ concatMap (\(_,ts) -> ts) allAVL + num = 2000 + in do title "joinHAVL" + putStrLn $ "Testing " ++ show (num*num) ++ " tree pairs.." + if and [test l $ mapAVL (ls+) r | (l,ls) <- trees, (r,_) <- trees] then passed else failed + where test l r = let (HAVL j hj) = (toHAVL l) `joinHAVL` (toHAVL r) + in case checkHeight j of + Nothing -> False + Just hj_ -> (ASINT(hj) == hj_) && (asListL j == l `toListL` asListL r) + +-- | Test the concatAVL function. +testConcatAVL :: IO () +testConcatAVL = let trees = take num $ concatMap (\(_,ts) -> ts) allAVL + num = 2000 + in do title "concatAVL" + putStrLn $ "Testing " ++ show (num*num) ++ " tree pairs.." + if others && and [test ls l $ mapAVL (\n -> n+(ls+1)) r + | (l,ls) <- trees, (r,_) <- trees] + then passed else failed + where test ls l r = let j = concatAVL $ [empty,empty,l,empty,singleton ls,empty,r,empty,empty] + in isBalanced j && (asListL j == l `toListL` (ls:asListL r)) + others = all (isEmpty . concatAVL) [[],[empty],[empty,empty],[empty,empty,empty]] + && (all test1 $ concatMap (\ss -> [ss,"":ss,"Z":ss]) + [[""] + ,["A"] + ,["","A","BC","","D","","EFGH","I"] + ] + ) + test1 ss = let t = concatAVL $ map asTreeL ss + in isBalanced t && (asListL t == concat ss) + +-- | Test the flatConcat function. +testFlatConcat :: IO () +testFlatConcat = let trees = take num $ concatMap (\(_,ts) -> ts) allAVL + num = 2000 + in do title "flatConcat" + putStrLn $ "Testing " ++ show (num*num) ++ " tree pairs.." + if others && and [test ls l $ mapAVL (\n -> n+(ls+1)) r + | (l,ls) <- trees, (r,_) <- trees] + then passed else failed + where test ls l r = let j = flatConcat $ [empty,empty,l,empty,singleton ls,empty,r,empty,empty] + in isBalanced j && (asListL j == l `toListL` (ls:asListL r)) + others = all (isEmpty . flatConcat) [[],[empty],[empty,empty],[empty,empty,empty]] + && (all test1 $ concatMap (\ss -> [ss,"":ss,"Z":ss]) + [[""] + ,["A"] + ,["","A","BC","","D","","EFGH","I"] + ] + ) + test1 ss = let t = flatConcat $ map asTreeL ss + in isBalanced t && (asListL t == concat ss) + +-- | Test the filterViaList function +testFilterViaList :: IO () +testFilterViaList = do title "filterViaList" + exhaustiveTest test (take 6 allAVL) + where test _ s t = all testit [0..s] -- n==s should yield unmodified tree + where testit n = let t' = filterViaList (/= n) t + in (isSortedOK compare t') && (asListL t' == ([0..n-1]++[n+1..s-1])) + +-- | Test the filterAVL function +testFilterAVL :: IO () +testFilterAVL = do title "filterAVL" + exhaustiveTest test (take 6 allAVL) + where test _ s t = all testit [0..s] -- n==s should yield unmodified tree + where testit n = let t' = filterAVL (/= n) t + in (isSortedOK compare t') && (asListL t' == ([0..n-1]++[n+1..s-1])) + +-- | Test the mapMaybeViaList function +testMapMaybeViaList :: IO () +testMapMaybeViaList = do title "mapMaybeViaList" + exhaustiveTest test (take 6 allAVL) + where test _ s t = all testit [0..s] -- n==s should yield unmodified tree + where testit n = let t' = mapMaybeViaList (\m -> if m==n then Nothing else Just m) t + in (isSortedOK compare t') && (asListL t' == ([0..n-1]++[n+1..s-1])) + +-- | Test the mapMaybeAVL function +testMapMaybeAVL :: IO () +testMapMaybeAVL = do title "mapMaybeAVL" + exhaustiveTest test (take 6 allAVL) + where test _ s t = all testit [0..s] -- n==s should yield unmodified tree + where testit n = let t' = mapMaybeAVL (\m -> if m==n then Nothing else Just m) t + in (isSortedOK compare t') && (asListL t' == ([0..n-1]++[n+1..s-1])) + +-- | Test splitAtL function +testSplitAtL :: IO () +testSplitAtL = do title "splitAtL" + exhaustiveTest test (take 6 allAVL) + where test _ s t = all splitTest0 [0..s-1] && all splitTest1 [s] + where tlist = asListL t + splitTest0 n = case splitAtL n t of + Left _ -> False + Right (l,r) -> (isBalanced l) && (isBalanced r) && + (size l == n) && (size r == s-n) && + (l `toListL` asListL r) == tlist + splitTest1 n = case splitAtL n t of + Left s_ -> s_==s + Right _ -> False + +-- | Test takeL function +testTakeL :: IO () +testTakeL = do title "takeL" + exhaustiveTest test (take 6 allAVL) + where test _ s t = all takeTest0 [0..s-1] && all takeTest1 [s] + where takeTest0 n = case takeL n t of + Left _ -> False + Right l -> (isBalanced l) && (asListL l) == [0..n-1] + takeTest1 n = case takeL n t of + Left s_ -> s_==s + Right _ -> False + +-- | Test dropL function +testDropL :: IO () +testDropL = do title "dropL" + exhaustiveTest test (take 6 allAVL) + where test _ s t = all dropTest0 [0..s-1] && all dropTest1 [s] + where dropTest0 n = case dropL n t of + Left _ -> False + Right r -> (isBalanced r) && (asListL r) == [n..s-1] + dropTest1 n = case dropL n t of + Left s_ -> s_==s + Right _ -> False + +-- | Test splitAtR function +testSplitAtR :: IO () +testSplitAtR = do title "splitAtR" + exhaustiveTest test (take 6 allAVL) + where test _ s t = all splitTest0 [0..s-1] && all splitTest1 [s] + where tlist = asListR t + splitTest0 n = case splitAtR n t of + Left _ -> False + Right (l,r) -> (isBalanced l) && (isBalanced r) && + (size r == n) && (size l == s-n) && + (r `toListR` asListR l) == tlist + splitTest1 n = case splitAtR n t of + Left s_ -> s_==s + Right _ -> False + +-- | Test takeR function +testTakeR :: IO () +testTakeR = do title "takeR" + exhaustiveTest test (take 6 allAVL) + where test _ s t = all takeTest0 [0..s-1] && all takeTest1 [s] + where takeTest0 n = case takeR n t of + Left _ -> False + Right r -> (isBalanced r) && (asListL r) == [s-n..s-1] + takeTest1 n = case takeR n t of + Left s_ -> s_==s + Right _ -> False + +-- | Test dropR function +testDropR :: IO () +testDropR = do title "dropR" + exhaustiveTest test (take 6 allAVL) + where test _ s t = all dropTest0 [0..s-1] && all dropTest1 [s] + where dropTest0 n = case dropR n t of + Left _ -> False + Right l -> (isBalanced l) && (asListL l) == [0..(s-1)-n] + dropTest1 n = case dropR n t of + Left s_ -> s_==s + Right _ -> False + +-- | Test spanL function +testSpanL :: IO () +testSpanL = do title "spanL" + exhaustiveTest test (take 6 allAVL) + where test _ s t = all spanTest [0..s] + where tlist = asListL t + spanTest n = let (l ,r ) = spanL (=n) t + (l_,r_) = span (>=n) tlist + in (isBalanced l) && (isBalanced r) && + (asListR l == r_) && (asListR r == l_) + +-- | Test takeWhileR function +testTakeWhileR :: IO () +testTakeWhileR = do title "takeWhileR" + exhaustiveTest test (take 6 allAVL) + where test _ s t = all spanTest [0..s] + where tlist = asListR t + spanTest n = let r = takeWhileR (>=n) t + r_ = takeWhile (>=n) tlist + in (isBalanced r) && (asListR r == r_) + +-- | Test dropWhileR function +testDropWhileR :: IO () +testDropWhileR = do title "dropWhileR" + exhaustiveTest test (take 6 allAVL) + where test _ s t = all spanTest [0..s] + where tlist = asListR t + spanTest n = let l = dropWhileR (>=n) t + l_ = dropWhile (>=n) tlist + in (isBalanced l) && (asListR l == l_) + +-- | Test rotateL function +testRotateL :: IO () +testRotateL = do title "rotateL" + exhaustiveTest test (take 6 allAVL) + where test _ s t = all isOK rotations + where rotations = take s $ tail $ iterate (mapAVL' (\n -> (n-1) `mod` s) . rotateL) t + isOK t_ = (isBalanced t_) && (asListL t_ == tlist) + tlist = asListL t +-- | Test rotateR function +testRotateR :: IO () +testRotateR = do title "rotateR" + exhaustiveTest test (take 6 allAVL) + where test _ s t = all isOK rotations + where rotations = take s $ tail $ iterate (mapAVL' (\n -> (n+1) `mod` s) . rotateR) t + isOK t_ = (isBalanced t_) && (asListL t_ == tlist) + tlist = asListL t + +-- | Test rotateByL function +testRotateByL :: IO () +testRotateByL = do title "rotateByL" + exhaustiveTest test (take 6 allAVL) + where test _ s t = all isOK $ map rotateIt [-1..s] + where rotateIt n = mapAVL' (\n_ -> (n_-n) `mod` s) $ rotateByL t n + isOK t_ = (isBalanced t_) && (asListL t_ == tlist) + tlist = asListL t + +-- | Test rotateByR function +testRotateByR :: IO () +testRotateByR = do title "rotateByR" + exhaustiveTest test (take 6 allAVL) + where test _ s t = all isOK $ map rotateIt [-1..s] + where rotateIt n = mapAVL' (\n_ -> (n_+n) `mod` s) $ rotateByR t n + isOK t_ = (isBalanced t_) && (asListL t_ == tlist) + tlist = asListL t + +-- | Test genForkL function +testGenForkL :: IO () +testGenForkL = do title "genForkL" + exhaustiveTest test (take 6 allAVL) + where test _ s t = all testForkL [-1..s-1] + where tlist = asListL t + testForkL n = let (l,r) = genForkL (compare n) t + in (isBalanced l) && (isBalanced r) && + (size l == n+1) && (size r == s-(n+1)) && + (l `toListL` asListL r == tlist) + +-- | Test genForkR function +testGenForkR :: IO () +testGenForkR = do title "genForkR" + exhaustiveTest test (take 6 allAVL) + where test _ s t = all testForkR [0..s] + where tlist = asListL t + testForkR n = let (l,r) = genForkR (compare n) t + in (isBalanced l) && (isBalanced r) && + (size l == n) && (size r == s-n) && + (l `toListL` asListL r == tlist) + + +-- | Test genFork function +testGenFork :: IO () +testGenFork = do title "genFork" + exhaustiveTest test (take 6 allAVL) + where test _ s t = all testFork0 [0..s-1] && testFork1 (-1) && testFork2 s + where tlist = asListL t + testFork0 n = let (l,mbn,r) = genFork (fstCC n) t + in case mbn of + Just n_ -> (n_==n) && (isBalanced l) && (isBalanced r) && + (size l == n) && (size r == s-(n+1)) && + (l `toListL` (n : asListL r) == tlist) + _ -> False + testFork1 n = let (l,mbn,r) = genFork (fstCC n) t + in case mbn of + Nothing -> (isEmpty l) && (isBalanced r) && (asListL r == tlist) + _ -> False + testFork2 n = let (l,mbn,r) = genFork (fstCC n) t + in case mbn of + Nothing -> (isEmpty r) && (isBalanced l) && (asListL l == tlist) + _ -> False + +-- | Test genTakeLE function +testGenTakeLE :: IO () +testGenTakeLE = do title "genTakeLE" + exhaustiveTest test (take 6 allAVL) + where test _ s t = all testTakeLE [-1..s-1] + where testTakeLE n = let l = genTakeLE (compare n) t + in (isBalanced l) && (asListL l == [0..n]) + +-- | Test genTakeLT function +testGenTakeLT :: IO () +testGenTakeLT = do title "genTakeLT" + exhaustiveTest test (take 6 allAVL) + where test _ s t = all testTakeLT [0..s] + where testTakeLT n = let l = genTakeLT (compare n) t + in (isBalanced l) && (asListL l == [0..n-1]) + +-- | Test genTakeGT function +testGenTakeGT :: IO () +testGenTakeGT = do title "genTakeGT" + exhaustiveTest test (take 6 allAVL) + where test _ s t = all testTakeGT [-1..s-1] + where testTakeGT n = let r = genTakeGT (compare n) t + in (isBalanced r) && (asListL r == [n+1..s-1]) + +-- | Test genTakeGE function +testGenTakeGE :: IO () +testGenTakeGE = do title "genTakeGE" + exhaustiveTest test (take 6 allAVL) + where test _ s t = all testTakeGE [0..s] + where testTakeGE n = let r = genTakeGE (compare n) t + in (isBalanced r) && (asListL r == [n..s-1]) + +-- | Test the genUnion function +testGenUnion :: IO () +testGenUnion = let trees = take num $ concatMap (\(_,ts) -> ts) allAVL + num = 1000 + in do title "genUnion" + putStrLn $ "Testing " ++ show (num*num) ++ " tree pairs.." + if and [test l ls r rs | (l,ls) <- trees, (r,rs) <- trees] then passed else failed + where test l ls r rs = all (\f -> f l ls r rs) [test1,test2,test3] + test1 l ls r rs = let u = unionFst l r + in isBalanced u && (asListL u == [0 .. max ls rs - 1]) + test2 l ls r rs = and [test2_ n $ mapAVL' (n+) r | n <- [(-rs)..ls]] + where test2_ n r_ = let u = unionFst l r_ + in isBalanced u && (asListL u == [min n 0 .. max ls (rs+n) - 1]) + test3 l ls r rs = let l_ = mapAVL' (\n -> n+n ) l -- even + r_ = mapAVL' (\n -> n+n+1) r -- odd + u = unionFst l_ r_ + in isSortedOK compare u && (size u == ls+rs) + unionFst = genUnion fstCC + + +-- | Test the genSymDifference function +testGenSymDifference :: IO () +testGenSymDifference = + let trees = take num $ concatMap (\(_,ts) -> ts) allAVL + num = 1000 + in do title "genSymDifference" + putStrLn $ "Testing " ++ show (num*num) ++ " tree pairs.." + if and [test l ls r rs | (l,ls) <- trees, (r,rs) <- trees] then passed else failed + where test l ls r rs = all (\f -> f l ls r rs) [test1,test2,test3] + test1 l ls r rs = let u = symDiff l r + in isBalanced u && (asListL u == [min ls rs .. max ls rs - 1]) + test2 l ls r rs = and [test2_ n $ mapAVL' (n+) r | n <- [(-rs)..ls]] + where test2_ n r_ = let u = symDiff l r_ + in isBalanced u && (asListL u == [min n 0 .. max n 0 - 1] ++ + [min ls (rs+n) .. max ls (rs+n) - 1]) + test3 l ls r rs = let l_ = mapAVL' (\n -> n+n ) l -- even + r_ = mapAVL' (\n -> n+n+1) r -- odd + u = symDiff l_ r_ + in isSortedOK compare u && (size u == ls+rs) + symDiff = genSymDifference compare + +-- | Test the genUnionMaybe function +testGenUnionMaybe :: IO () +testGenUnionMaybe = let trees = take num $ concatMap (\(_,ts) -> ts) allAVL + num = 1000 + in do title "genUnionMaybe" + putStrLn $ "Testing " ++ show (num*num) ++ " tree pairs.." + if and [test l ls r rs | (l,ls) <- trees, (r,rs) <- trees] then passed else failed + where test l ls r rs = all (\f -> f l ls r rs) [test1,test2,test3] + test1 l ls r rs = let u = onion l r + mn = min ls rs + mx = max ls rs + in isBalanced u && (asListL u == [0,2 .. mn - 1] ++ [mn .. mx-1]) + test2 l ls r rs = and [test2_ n $ mapAVL' (n+) r | n <- [(-rs)..ls]] + where test2_ n r_ = let u = onion l r_ + n0 = min n 0 + n1 = max n 0 + n2 = min ls (rs+n) + n3 = max ls (rs+n) + in isBalanced u && (asListL u == [n0 .. n1-1] + ++ filter even [n1 .. n2-1] + ++ [n2..n3-1] + ) + test3 l ls r rs = let l_ = mapAVL' (\n -> n+n ) l -- even + r_ = mapAVL' (\n -> n+n+1) r -- odd + u = onion l_ r_ + in isSortedOK compare u && (size u == ls+rs) + onion = genUnionMaybe (withCC' com) + com a _ = if even a then Just a else Nothing + +-- | Test the genIntersection function +testGenIntersection :: IO () +testGenIntersection = let trees = take num $ concatMap (\(_,ts) -> ts) allAVL + num = 1000 + in do title "genIntersection" + putStrLn $ "Testing " ++ show (num*num) ++ " tree pairs.." + if and [test l ls r rs | (l,ls) <- trees, (r,rs) <- trees] then passed else failed + where test l ls r rs = all (\f -> f l ls r rs) [test1,test2,test3] + test1 l ls r rs = let u = genIntersection fstCC l r + in isBalanced u && (asListL u == [0 .. min ls rs - 1]) + test2 l ls r rs = and [test2_ n $ mapAVL' (n+) r | n <- [(-rs)..ls]] + where test2_ n r_ = let u = genIntersection fstCC l r_ + in isBalanced u && (asListL u == [max n 0 .. min ls (rs+n) - 1]) + test3 l _ r _ = let l_ = mapAVL' (\n -> n+n ) l -- even + r_ = mapAVL' (\n -> n+n+1) r -- odd + u = genIntersection fstCC l_ r_ + in isEmpty u + +-- | Test the genIntersectionMaybe function +testGenIntersectionMaybe :: IO () +testGenIntersectionMaybe = let trees = take num $ concatMap (\(_,ts) -> ts) allAVL + num = 1000 + in do title "genIntersectionMaybe" + putStrLn $ "Testing " ++ show (num*num) ++ " tree pairs.." + if and [test l ls r rs | (l,ls) <- trees, (r,rs) <- trees] then passed else failed + where test l ls r rs = all (\f -> f l ls r rs) [test1,test2,test3] + test1 l ls r rs = let u = insect l r + mn = min ls rs + in isBalanced u && (asListL u == [0,2 .. mn - 1]) + test2 l ls r rs = and [test2_ n $ mapAVL' (n+) r | n <- [(-rs)..ls]] + where test2_ n r_ = let u = insect l r_ + n1 = max n 0 + n2 = min ls (rs+n) + in isBalanced u && (asListL u == filter even [n1 .. n2-1]) + test3 l _ r _ = let l_ = mapAVL' (\n -> n+n ) l -- even + r_ = mapAVL' (\n -> n+n+1) r -- odd + u = insect l_ r_ + in isEmpty u + insect = genIntersectionMaybe (withCC' com) + com a _ = if even a then Just a else Nothing + +-- | Test the genIntersectionAsListL function +testGenIntersectionAsListL :: IO () +testGenIntersectionAsListL = + let trees = take num $ concatMap (\(_,ts) -> ts) allAVL + num = 1000 + in do title "genIntersectionAsListL" + putStrLn $ "Testing " ++ show (num*num) ++ " tree pairs.." + if and [test l ls r rs | (l,ls) <- trees, (r,rs) <- trees] then passed else failed + where test l ls r rs = all (\f -> f l ls r rs) [test1,test2,test3] + test1 l ls r rs = let u = genIntersectionAsListL fstCC l r + in u == [0 .. min ls rs - 1] + test2 l ls r rs = and [test2_ n $ mapAVL' (n+) r | n <- [(-rs)..ls]] + where test2_ n r_ = let u = genIntersectionAsListL fstCC l r_ + in u == [max n 0 .. min ls (rs+n) - 1] + test3 l _ r _ = let l_ = mapAVL' (\n -> n+n ) l -- even + r_ = mapAVL' (\n -> n+n+1) r -- odd + u = genIntersectionAsListL fstCC l_ r_ + in null u + +-- | Test the genIntersectionMaybeAsListL function +testGenIntersectionMaybeAsListL :: IO () +testGenIntersectionMaybeAsListL = + let trees = take num $ concatMap (\(_,ts) -> ts) allAVL + num = 1000 + in do title "genIntersectionMaybeAsListL" + putStrLn $ "Testing " ++ show (num*num) ++ " tree pairs.." + if and [test l ls r rs | (l,ls) <- trees, (r,rs) <- trees] then passed else failed + where test l ls r rs = all (\f -> f l ls r rs) [test1,test2,test3] + test1 l ls r rs = let u = insect l r + mn = min ls rs + in u == [0,2 .. mn - 1] + test2 l ls r rs = and [test2_ n $ mapAVL' (n+) r | n <- [(-rs)..ls]] + where test2_ n r_ = let u = insect l r_ + n1 = max n 0 + n2 = min ls (rs+n) + in u == filter even [n1 .. n2-1] + test3 l _ r _ = let l_ = mapAVL' (\n -> n+n ) l -- even + r_ = mapAVL' (\n -> n+n+1) r -- odd + u = insect l_ r_ + in null u + insect = genIntersectionMaybeAsListL (withCC' com) + com a _ = if even a then Just a else Nothing + +-- | Test the genDifference function +testGenDifference :: IO () +testGenDifference = let trees = take num $ concatMap (\(_,ts) -> ts) allAVL + num = 1000 + in do title "genDifference" + putStrLn $ "Testing " ++ show (num*num) ++ " tree pairs.." + if and [test l ls r rs | (l,ls) <- trees, (r,rs) <- trees] then passed else failed + where test l ls r rs = all (\f -> f l ls r rs) [test1,test2,test3] + test1 l ls r rs = let u = difference l r + in isBalanced u && (asListL u == [rs .. ls - 1]) + test2 l ls r rs = and [test2_ n $ mapAVL' (n+) r | n <- [(-rs)..ls]] + where test2_ n r_ = let u = difference l r_ + in isBalanced u && (asListL u == [0 .. n-1] ++ [rs+n .. ls-1]) + test3 l ls r rs = let l_ = mapAVL' (\n -> n+n ) l -- even + r_ = mapAVL' (\n -> n+n+1) r -- odd + u = difference l r_ + u_ = difference l_ r_ + mn = min (ls-1) (2*rs-1) + in isBalanced u && + (asListL u == filter even [0..mn] ++ [mn+1..ls-1]) && + isBalanced u_ && (u_ == l_) + difference = genDifference compare + +-- | Test the genDifferenceMaybe function +testGenDifferenceMaybe :: IO () +testGenDifferenceMaybe = + let trees = take num $ concatMap (\(_,ts) -> ts) allAVL + num = 1000 + in do title "genDifferenceMaybe" + putStrLn $ "Testing " ++ show (num*num) ++ " tree pairs.." + if and [test l ls r rs | (l,ls) <- trees, (r,rs) <- trees] then passed else failed + where c m n = case compare m n of + LT -> Lt + EQ -> if even m then (Eq Nothing) else (Eq (Just m)) + GT -> Gt + test l ls r rs = all (\f -> f l ls r rs) [test1,test2,test3] + test1 l ls r rs = let mn = min (ls-1) (rs-1) + u = genDifferenceMaybe c l r + in isBalanced u && (asListL u == filter odd [0..mn] ++ [mn+1..ls-1]) + test2 l ls r rs = and [test2_ n $ mapAVL' (n+) r | n <- [(-rs)..ls]] + where test2_ n r_ = let u = genDifferenceMaybe c l r_ + n0 = max 0 n + n1 = min (ls-1) (rs+n-1) + in isBalanced u && + (asListL u == [0..n0-1] ++ filter odd [n0..n1] ++ [n1+1..ls-1]) + test3 l ls r rs = let l_ = mapAVL' (\n -> n+n+1) l -- odd + r_ = mapAVL' (\n -> n+n ) r -- even + u = genDifferenceMaybe c l r_ + u_ = genDifferenceMaybe c l_ r_ + mn = min (ls-1) (2*rs-2) + mx = max (mn+1) 0 + listfil = filter odd [0..mn] + listrem = [mx..ls-1] + in isBalanced u && isBalanced u_ && (u_ == l_) && + (asListL u == listfil ++ listrem) + +-- | Test the genIsSubsetOf function +testGenIsSubsetOf :: IO () +testGenIsSubsetOf = let trees = take num $ concatMap (\(_,ts) -> ts) allAVL + num = 1000 + in do title "genIsSubsetOf" + putStrLn $ "Testing " ++ show (num*num) ++ " tree pairs.." + if and [test l ls r rs | (l,ls) <- trees, (r,rs) <- trees] then passed else failed + where test l ls r rs = all (\f -> f l ls r rs) [test1,test2] + test1 l ls r rs = (l `isSubsetOf` r == (ls<=rs)) && + (r `isSubsetOf` l == (rs<=ls)) + test2 l ls r rs = and [test2_ n $ mapAVL' (n+) r | n <- [(-rs)..ls]] + where test2_ n r_ = (l `isSubsetOf` r_ == ((n<=0) && (rs+n>=ls))) && + (r_ `isSubsetOf` l == ((n>=0) && (rs+n<=ls))) + isSubsetOf = genIsSubsetOf compare + +-- | Test the genIsSubsetOfBy function +testGenIsSubsetOfBy :: IO () +testGenIsSubsetOfBy = let trees = take num $ concatMap (\(_,ts) -> ts) allAVL + num = 1000 + in do title "genIsSubsetOfBy" + putStrLn $ "Testing " ++ show (num*num) ++ " tree pairs.." + if and [test l ls r rs | (l,ls) <- trees, (r,rs) <- trees] then passed else failed + -- test1 & test2 chack same behaviour as genIsSubsetOf + -- test3 checks behviour for comarison functions that may return (Eq False) + where test l ls r rs = all (\f -> f l ls r rs) [test1,test2,test3] + test1 l ls r rs = (l `isSubsetOf` r == (ls<=rs)) && + (r `isSubsetOf` l == (rs<=ls)) + test2 l ls r rs = and [test2_ n $ mapAVL' (n+) r | n <- [(-rs)..ls]] + where test2_ n r_ = (l `isSubsetOf` r_ == ((n<=0) && (rs+n>=ls))) && + (r_ `isSubsetOf` l == ((n>=0) && (rs+n<=ls))) + isSubsetOf = genIsSubsetOfBy (withCC (\_ _ -> True )) + test3 l ls r rs = and [test3_ n | n <- [0..max ls rs]] + where test3_ n = (l `isSubsetOf'` r == ((ls<=rs) && (n>=ls))) && + (r `isSubsetOf'` l == ((rs<=ls) && (n>=rs))) + where isSubsetOf' = genIsSubsetOfBy (withCC (\m _ -> m /= n)) + + +-- | Test compareHeight function +testCompareHeight :: IO () +testCompareHeight = let trees = take num $ concatMap (\(h,ts) -> [(t,h)|(t,_)<-ts]) allAVL + num = 10000 + in do title "compareHeight" + putStrLn $ "Testing " ++ show (num*num) ++ " tree pairs.." + if and [test l lh r rh | (l,lh) <- trees, (r,rh) <- trees] then passed else failed + where test l lh r rh = compareHeight l r == compare lh rh + +-- | Test Zipper open\/close +testGenOpenClose :: IO () +testGenOpenClose = do title "Zipper open/close" + exhaustiveTest test (take 5 allNonEmptyAVL) + where test _ s t = all test_ [0..s-1] + where test_ n = let z = genAssertOpen (compare n) t + t_ = close z + in (getCurrent z == n) && (isBalanced t_) && (asListL t_ == [0..s-1]) +-- | Test Zipper delClose +testDelClose :: IO () +testDelClose = do title "Zipper delClose" + exhaustiveTest test (take 5 allNonEmptyAVL) + where test _ s t = all test_ [0..s-1] + where test_ n = let t_ = delClose $ genAssertOpen (compare n) t + in (isBalanced t_) -- && (insert n (asListL t_) == [0..s-1]) + +-- | Test Zipper assertOpenL\/close +testOpenLClose :: IO () +testOpenLClose = do title "Zipper assertOpenL/close" + exhaustiveTest test (take 5 allNonEmptyAVL) + where test _ s t = let z = assertOpenL t + t_ = close z + in (getCurrent z == 0) && (isBalanced t_) && (asListL t_ == [0..s-1]) + +-- | Test Zipper assertOpenR\/close +testOpenRClose :: IO () +testOpenRClose = do title "Zipper assertOpenR/close" + exhaustiveTest test (take 5 allNonEmptyAVL) + where test _ s t = let z = assertOpenR t + t_ = close z + in (getCurrent z == s-1) && (isBalanced t_) && (asListL t_ == [0..s-1]) + +-- | Test Zipper assertMoveL\/isRightmost +testMoveL :: IO () +testMoveL = do title "Zipper assertMoveL/isRightmost" + exhaustiveTest test (take 5 allNonEmptyAVL) + where test _ s t = let zavls@(z:zs) = take s $ iterate assertMoveL (assertOpenR t) + in (map getCurrent zavls == reverse [0..s-1]) && (all test_ zavls) && + (isRightmost z) && (not $ any isRightmost zs) + where test_ zavl = let t_ = close zavl + in (isBalanced t_) && (asListL t_ == [0..s-1]) + +-- | Test Zipper assertMoveR\/isLeftmost +testMoveR :: IO () +testMoveR = do title "Zipper assertMoveR/isLeftmost" + exhaustiveTest test (take 5 allNonEmptyAVL) + where test _ s t = let zavls@(z:zs) = take s $ iterate assertMoveR (assertOpenL t) + in (map getCurrent zavls == [0..s-1]) && (all test_ zavls) && + (isLeftmost z) && (not $ any isLeftmost zs) + where test_ zavl = let t_ = close zavl + in (isBalanced t_) && (asListL t_ == [0..s-1]) + +-- | Test Zipper insertL +testInsertL :: IO () +testInsertL = do title "Zipper insertL" + exhaustiveTest test (take 5 allNonEmptyAVL) + where test _ s t = all test_ [0..s-1] + where test_ n = let z = insertL s $ genAssertOpen (compare n) t + t_ = close z + in (getCurrent z == n) && (isBalanced t_) && + (asListL t_ == [0..n-1] ++ s:[n..s-1]) +-- | Test Zipper insertMoveL +testInsertMoveL :: IO () +testInsertMoveL = do title "Zipper insertMoveL" + exhaustiveTest test (take 5 allNonEmptyAVL) + where test _ s t = all test_ [0..s-1] + where test_ n = let z = insertMoveL s $ genAssertOpen (compare n) t + t_ = close z + in (getCurrent z == s) && (isBalanced t_) && + (asListL t_ == [0..n-1] ++ s:[n..s-1]) + +-- | Test Zipper insertR +testInsertR :: IO () +testInsertR = do title "Zipper insertR" + exhaustiveTest test (take 5 allNonEmptyAVL) + where test _ s t = all test_ [0..s-1] + where test_ n = let z = insertR (genAssertOpen (compare n) t) s + t_ = close z + in (getCurrent z == n) && (isBalanced t_) && + (asListL t_ == [0..n] ++ s:[(n+1)..s-1]) + +-- | Test Zipper insertMoveR +testInsertMoveR :: IO () +testInsertMoveR = do title "Zipper insertMoveR" + exhaustiveTest test (take 5 allNonEmptyAVL) + where test _ s t = all test_ [0..s-1] + where test_ n = let z = insertMoveR (genAssertOpen (compare n) t) s + t_ = close z + in (getCurrent z == s) && (isBalanced t_) && + (asListL t_ == [0..n] ++ s:[(n+1)..s-1]) + +-- | Test Zipper insertTreeL +testInsertTreeL :: IO () +testInsertTreeL = do title "Zipper insertTreeL" + exhaustiveTest test (take 5 allNonEmptyAVL) + where test _ s t = all test_ [0..s-1] + where test_ n = let z = insertTreeL t $ genAssertOpen (compare n) t + t_ = close z + in (getCurrent z == n) && (isBalanced t_) && + (asListL t_ == [0..n-1] ++ [0..s-1] ++ [n..s-1]) + +-- | Test Zipper insertTreeR +testInsertTreeR :: IO () +testInsertTreeR = do title "Zipper insertTreeR" + exhaustiveTest test (take 5 allNonEmptyAVL) + where test _ s t = all test_ [0..s-1] + where test_ n = let z = insertTreeR (genAssertOpen (compare n) t) t + t_ = close z + in (getCurrent z == n) && (isBalanced t_) && + (asListL t_ == [0..n] ++ [0..s-1] ++ [n+1..s-1]) +-- | Test Zipper assertDelMoveL +testDelMoveL :: IO () +testDelMoveL = do title "Zipper assertDelMoveL" + exhaustiveTest test (take 5 allNonEmptyAVL) + where test _ s t = let zavls = take s $ iterate assertDelMoveL $ insertR (assertOpenR t) s + in (map getCurrent zavls == reverse [0..s-1]) && + (and $ zipWith test_ zavls $ reverse [0..s-1]) + where test_ zavl s_ = let t_ = close zavl + in (isBalanced t_) && (asListL t_ == [0..s_] ++ [s]) + +-- | Test Zipper assertDelMoveR +testDelMoveR :: IO () +testDelMoveR = do title "Zipper assertDelMoveR" + exhaustiveTest test (take 5 allNonEmptyAVL) + where test _ s t = let zavls = take s $ iterate assertDelMoveR $ insertL s $ assertOpenL t + in (map getCurrent zavls == [0..s-1]) && + (and $ zipWith test_ zavls [0..s-1]) + where test_ zavl s_ = let t_ = close zavl + in (isBalanced t_) && (asListL t_ == s:[s_..s-1]) + +-- | Test Zipper delAllL +testDelAllL :: IO () +testDelAllL = do title "Zipper delAllL" + exhaustiveTest test (take 5 allNonEmptyAVL) + where test _ s t = all test_ [0..s-1] + where test_ n = let z = delAllL $ genAssertOpen (compare n) t + t_ = close z + t__ = close $ insertTreeL t z + in (isBalanced t_ ) && (asListL t_ == [n..s-1]) && + (isBalanced t__) && (asListL t__ == [0..s-1] ++ [n..s-1]) + +-- | Test Zipper delAllR +testDelAllR :: IO () +testDelAllR = do title "Zipper delAllR" + exhaustiveTest test (take 5 allNonEmptyAVL) + where test _ s t = all test_ [0..s-1] + where test_ n = let z = delAllR $ genAssertOpen (compare n) t + t_ = close z + t__ = close $ insertTreeR z t + in (isBalanced t_ ) && (asListL t_ == [0..n]) && + (isBalanced t__) && (asListL t__ == [0..n] ++ [0..s-1]) + +-- | Test Zipper delAllCloseL +testDelAllCloseL :: IO () +testDelAllCloseL = do title "Zipper delAllCloseL" + exhaustiveTest test (take 5 allNonEmptyAVL) + where test _ s t = all test_ [0..s-1] + where test_ n = let t_ = delAllCloseL $ genAssertOpen (compare n) t + in (isBalanced t_ ) && (asListL t_ == [n..s-1]) + +-- | Test Zipper delAllIncCloseL +testDelAllIncCloseL :: IO () +testDelAllIncCloseL = do title "Zipper delAllIncCloseL" + exhaustiveTest test (take 5 allNonEmptyAVL) + where test _ s t = all test_ [0..s-1] + where test_ n = let t_ = delAllIncCloseL $ genAssertOpen (compare n) t + in (isBalanced t_ ) && (asListL t_ == [n+1..s-1]) + +-- | Test Zipper delAllCloseR +testDelAllCloseR :: IO () +testDelAllCloseR = do title "Zipper delAllCloseR" + exhaustiveTest test (take 5 allNonEmptyAVL) + where test _ s t = all test_ [0..s-1] + where test_ n = let t_ = delAllCloseR $ genAssertOpen (compare n) t + in (isBalanced t_ ) && (asListL t_ == [0..n]) + +-- | Test Zipper delAllIncCloseR +testDelAllIncCloseR :: IO () +testDelAllIncCloseR = do title "Zipper delAllIncCloseR" + exhaustiveTest test (take 5 allNonEmptyAVL) + where test _ s t = all test_ [0..s-1] + where test_ n = let t_ = delAllIncCloseR $ genAssertOpen (compare n) t + in (isBalanced t_ ) && (asListL t_ == [0..n-1]) + +-- | Test Zipper sizeL\/sizeR\/sizeZAVL +testZipSize :: IO () +testZipSize = do title "Zipper sizeL/sizeR/sizeZAVL" + exhaustiveTest test (take 5 allNonEmptyAVL) + where test _ s t = all test_ [0..s-1] + where test_ n = let z = genAssertOpen (compare n) t + in (sizeL z == n) && (sizeR z == (s-1)-n) && (sizeZAVL z == s) + +-- | Test Zipper genTryOpenGE +testGenTryOpenGE :: IO () +testGenTryOpenGE = do title "Zipper genTryOpenGE" + exhaustiveTest test (take 5 allNonEmptyAVL) + where test _ s t = let t_ = mapAVL' (2*) t + in all (testE t_) [0,2..2*s-2] && all (testO t_) [(-1),1..2*s-3] + where testE t_ n = let Just z = tryOpenGE n t_ + t__ = close z + in (getCurrent z == n) && (isBalanced t__) && (asListL t__ == [0,2..2*s-2]) + testO t_ n = let Just z = tryOpenGE n t_ + t__ = close z + in (getCurrent z == n+1) && (isBalanced t__) && (asListL t__ == [0,2..2*s-2]) + tryOpenGE a = genTryOpenGE (compare a) + +-- | Test Zipper genTryOpenLE +testGenTryOpenLE :: IO () +testGenTryOpenLE = do title "Zipper genTryOpenLE" + exhaustiveTest test (take 5 allNonEmptyAVL) + where test _ s t = let t_ = mapAVL' (2*) t + in all (testE t_) [0,2..2*s-2] && all (testO t_) [1,3..2*s-1] + where testE t_ n = let Just z = tryOpenLE n t_ + t__ = close z + in (getCurrent z == n) && (isBalanced t__) && (asListL t__ == [0,2..2*s-2]) + testO t_ n = let Just z = tryOpenLE n t_ + t__ = close z + in (getCurrent z == n-1) && (isBalanced t__) && (asListL t__ == [0,2..2*s-2]) + tryOpenLE a = genTryOpenLE (compare a) + +-- | Test Zipper genOpenEither (also tests fill and fillClose) +testGenOpenEither :: IO () +testGenOpenEither = do title "Zipper genOpenEither" + exhaustiveTest test (take 6 allAVL) + where test _ s t = let t_ = mapAVL' (2*) t + in all (testE t_) [0,2..2*s-2] && all (testO t_) [-1,1..2*s-1] + where testE t_ n = let Right z = openEither n t_ + t__ = close z + in (getCurrent z == n) && (isBalanced t__) && (asListL t__ == [0,2..2*s-2]) + testO t_ n = let Left p = openEither n t_ + t__ = close (fill n p) + t___ = fillClose n p + in (isBalanced t__) && (isBalanced t___) && (t__ == t___) && + (asListL t__ == ([0,2..n-1] ++ n : [n+1,n+3..2*s-2])) + openEither a = genOpenEither (compare a) + + + +-- | Test anyBAVLtoEither +testBAVLtoZipper :: IO () +testBAVLtoZipper = do title "BAVLtoZipper" + exhaustiveTest test (take 6 allAVL) + where test _ s t = let t_ = mapAVL' (2*) t + in all (testE t_) [0,2..2*s-2] && all (testO t_) [-1,1..2*s-1] + where testE t_ n = let bavl = openBAVL n t_ + Right z = anyBAVLtoEither bavl + t__ = close z + in (getCurrent z == n) && (isBalanced t__) && (asListL t__ == [0,2..2*s-2]) + testO t_ n = let bavl = openBAVL n t_ + Left p = anyBAVLtoEither bavl + t__ = fillClose n p + in (isBalanced t__) && (asListL t__ == ([0,2..n-1] ++ n : [n+1,n+3..2*s-2])) + openBAVL e = genOpenBAVL (compare e) + + +-- | Test Show,Read,Eq instances +testShowReadEq :: IO () +testShowReadEq = do title "ShowReadEq" + exhaustiveTest test (take 5 allAVL) -- No need to get carried away with this one + where test _ _ t = t == (read $ show t) + +-- | Test readPath +testReadPath :: IO () +testReadPath = do title "ReadPath" + if all test [0..100] then passed else failed + where test n = let ASINT(n_)=n in (n == readPath n_ pathTree) + +title :: String -> IO () +title str = let titl = "* Test " ++ str ++ " *" + mark = replicate (length titl) '*' + in putStrLn "" >> putStrLn mark >> putStrLn titl >> putStrLn mark + +passed :: IO () +passed = putStrLn "Passed" + +failed :: IO () +failed = do putStrLn "!! FAILED !!" + exitFailure + diff --git a/Data/Tree/AVL/Test/Counter.hs b/Data/Tree/AVL/Test/Counter.hs new file mode 100644 --- /dev/null +++ b/Data/Tree/AVL/Test/Counter.hs @@ -0,0 +1,49 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Data.Tree.AVL.Test.Counter +-- Copyright : (c) Adrian Hey 2004,2005 +-- License : BSD3 +-- +-- Maintainer : http://homepages.nildram.co.uk/~ahey/em.png +-- Stability : stable +-- Portability : portable +-- +-- This module defines the 'XInt' type which is a specialised instance of 'Ord' which allows +-- the number of comparisons performed to be counted. This may be used evaluate various +-- algorithms. The functions defined here are not exported by the main "Data.Tree.AVL" +-- module. You need to import this module explicitly if you want to use any of them. +----------------------------------------------------------------------------- +module Data.Tree.AVL.Test.Counter + (XInt(..), + getCount,resetCount, + ) where + +import System.IO.Unsafe(unsafePerformIO) +import Data.IORef(IORef,newIORef,readIORef,writeIORef) + +{-# NOINLINE count #-} +count :: IORef Int +count = unsafePerformIO $ newIORef 0 + +-- Increment the counter. +incCount :: IO () +incCount = do c <- readIORef count + let c' = c+1 in c' `seq` writeIORef count c' + +-- | Read the current comparison counter. +getCount :: IO Int +getCount = readIORef count + +-- | Reset the comparison counter to zero. +resetCount :: IO () +resetCount = writeIORef count 0 + +-- | Basic data type. +newtype XInt = XInt Int deriving (Eq,Show,Read) + +-- | A side effecting instance of Ord. +instance Ord XInt where + compare (XInt x) (XInt y) = unsafePerformIO $ do incCount + return $! compare x y + + diff --git a/Data/Tree/AVL/Test/Utils.hs b/Data/Tree/AVL/Test/Utils.hs new file mode 100644 --- /dev/null +++ b/Data/Tree/AVL/Test/Utils.hs @@ -0,0 +1,221 @@ +{-# OPTIONS_GHC -fglasgow-exts #-} +----------------------------------------------------------------------------- +-- | +-- Module : Data.Tree.AVL.Test.Utils +-- Copyright : (c) Adrian Hey 2004,2005 +-- License : BSD3 +-- +-- Maintainer : http://homepages.nildram.co.uk/~ahey/em.png +-- Stability : stable +-- Portability : portable +-- +-- 'AVL' tree related test and verification utilities. +----------------------------------------------------------------------------- +module Data.Tree.AVL.Test.Utils + (-- * Correctness checking. + isBalanced,checkHeight,isSorted,isSortedOK, + -- * Test data generation. + TestTrees,allAVL, allNonEmptyAVL, numTrees, flatAVL, + -- * Exhaustive tests. + exhaustiveTest, + -- * Tree parameter utilities. + minElements,maxElements, + -- * Testing BinPath module. + pathTree, + ) where + +import Data.Tree.AVL.Types(AVL(..)) +import Data.Tree.AVL.List(mapAVL',asTreeLenL,asListL) + +#ifdef __GLASGOW_HASKELL__ +import GHC.Base +#include "ghcdefs.h" +#else +#include "h98defs.h" +#endif + +-- | Infinite test tree. Used for test purposes for BinPath module. +-- Value at each node is the path to that node. +pathTree :: AVL Int +pathTree = Z l 0 r where + l = mapIt (\n -> 2*n+1) pathTree + r = mapIt (\n -> 2*n+2) pathTree + -- Need special lazy map for this recursive tree defn + mapIt f (Z l' n r') = let n'= f n in n' `seq` Z (mapIt f l') n' (mapIt f r') + mapIt _ _ = undefined + +-- | Verify that a tree is height balanced and that the BF of each node is correct. +-- +-- Complexity: O(n) +isBalanced :: AVL e -> Bool +isBalanced t = not (cH t EQL L(-1)) + +-- | Verify that a tree is balanced and the BF of each node is correct. +-- Returns (Just height) if so, otherwise Nothing. +-- +-- Complexity: O(n) +checkHeight :: AVL e -> Maybe Int +checkHeight t = let ht = cH t in if ht EQL L(-1) then Nothing else Just ASINT(ht) + +-- Local utility, returns height if balanced, -1 if not +cH :: AVL e -> UINT +cH E = L(0) +cH (N l _ r) = cH_ L(1) l r -- (hr-hl) = 1 +cH (Z l _ r) = cH_ L(0) l r -- (hr-hl) = 0 +cH (P l _ r) = cH_ L(1) r l -- (hl-hr) = 1 +cH_ :: UINT -> AVL e -> AVL e -> UINT +cH_ delta l r = let hl = cH l + in if hl EQL L(-1) then hl + else let hr = cH r + in if hr EQL L(-1) then hr + else if SUBINT(hr,hl) EQL delta then INCINT1(hr) + else L(-1) + +-- | Verify that a tree is sorted. +-- +-- Complexity: O(n) +isSorted :: (e -> e -> Ordering) -> AVL e -> Bool +isSorted c = isSorted' where + isSorted' E = True + isSorted' (N l e r) = isSorted'' l e r + isSorted' (Z l e r) = isSorted'' l e r + isSorted' (P l e r) = isSorted'' l e r + isSorted'' l e r = (isSortedU l e) && (isSortedL e r) + -- Verify tree is sorted and rightmost element is less than an upper limit (ul) + isSortedU E _ = True + isSortedU (N l e r) ul = isSortedU' l e r ul + isSortedU (Z l e r) ul = isSortedU' l e r ul + isSortedU (P l e r) ul = isSortedU' l e r ul + isSortedU' l e r ul = case c e ul of + LT -> (isSortedU l e) && (isSortedLU e r ul) + _ -> False + -- Verify tree is sorted and leftmost element is greater than a lower limit (ll) + isSortedL _ E = True + isSortedL ll (N l e r) = isSortedL' ll l e r + isSortedL ll (Z l e r) = isSortedL' ll l e r + isSortedL ll (P l e r) = isSortedL' ll l e r + isSortedL' ll l e r = case c e ll of + GT -> (isSortedLU ll l e) && (isSortedL e r) + _ -> False + -- Verify tree is sorted and leftmost element is greater than a lower limit (ll) + -- and rightmost element is less than an upper limit (ul) + isSortedLU _ E _ = True + isSortedLU ll (N l e r) ul = isSortedLU' ll l e r ul + isSortedLU ll (Z l e r) ul = isSortedLU' ll l e r ul + isSortedLU ll (P l e r) ul = isSortedLU' ll l e r ul + isSortedLU' ll l e r ul = case c e ll of + GT -> case c e ul of + LT -> (isSortedLU ll l e) && (isSortedLU e r ul) + _ -> False + _ -> False +-- isSorted ends -- +------------------- + +-- | Verify that a tree is sorted, height balanced and the BF of each node is correct. +-- +-- Complexity: O(n) +isSortedOK :: (e -> e -> Ordering) -> AVL e -> Bool +isSortedOK c t = (isBalanced t) && (isSorted c t) + +-- | AVL Tree test data. Each element of a the list is a pair consisting of a height, +-- and list of all possible sorted trees of the same height, paired with their sizes. +-- The elements of each tree of size s are 0..s-1. +type TestTrees = [(Int, [(AVL Int, Int)])] + +-- | All possible sorted AVL trees. +allAVL :: TestTrees +allAVL = p0 : p1 : moreTrees p1 p0 where + p0 = (0, [(E , 0)]) -- All possible trees of height 0 + p1 = (1, [(Z E 0 E, 1)]) -- All possible trees of height 1 + -- Generate more trees of height N, from existing trees of height N-1 and N-2 + moreTrees :: (Int, [(AVL Int, Int)]) -> (Int, [(AVL Int, Int)]) -> [(Int, [(AVL Int, Int)])] + moreTrees pN1@(hN1, tpsN1) -- Height N-1 + (_ , tpsN2) = -- Height N-2 + let hN0 = hN1 + 1 -- Height N + tsN0 = interleave (interleave [newTree P l r | r <- tpsN2 , l <- tpsN1] -- BF=+1 + [newTree N l r | l <- tpsN2 , r <- tpsN1]) -- BF=-1 + [newTree Z l r | l <- tpsN1 , r <- tpsN1] -- BF= 0 + pN0 = (hN0,tsN0) + in hN0 `seq` pN0 : moreTrees pN0 pN1 + -- Generate a new (tree,size) pair using the supplied constructor + newTree con (l,sizel) (r,sizer) = + let rootEl = sizel -- Value of new root element + addRight = sizel+1 -- Offset to add to elements of right sub-tree + newSize = addRight + sizer -- Size of the new tree + r' = mapAVL' (addRight+) r + t = r' `seq` con l rootEl r' + in newSize `seq` t `seq` (t, newSize) + -- interleave two lists (until one or other is []) + interleave [] ys = ys + interleave xs [] = xs + interleave (x:xs) (y:ys) = (x:y:interleave xs ys) + + +-- | Same as 'allAVL', but excluding the empty tree (of height 0). +allNonEmptyAVL :: TestTrees +allNonEmptyAVL = tail allAVL + +-- | Returns the number of possible AVL trees of a given height. +-- +-- Behaves as if defined.. +-- +-- > numTrees h = (\(_,xs) -> length xs) (allAVL !! h) +-- +-- and satisfies this recurrence relation.. +-- +-- @ +-- numTrees 0 = 1 +-- numTrees 1 = 1 +-- numTrees h = (2*(numTrees (h-2)) + (numTrees (h-1))) * (numTrees (h-1)) +-- @ +numTrees :: Int -> Integer +numTrees 0 = 1 +numTrees 1 = 1 +numTrees n = numTrees' 1 1 n where + numTrees' n1 n2 2 = (2*n2 + n1)*n1 + numTrees' n1 n2 m = numTrees' ((2*n2 + n1)*n1) n1 (m-1) + +-- | Apply the test function to each AVL tree in the TestTrees argument, and report +-- progress as test proceeds. The first two arguments of the test function are +-- tree height and size respectively. +exhaustiveTest :: (Int -> Int -> AVL Int -> Bool) -> TestTrees -> IO () +exhaustiveTest f xs = mapM_ test xs where + test (h,tps) = do putStr "Tree Height : " >> print h + putStr "Number Of Trees: " >> print (numTrees h) + mapM_ test' tps + putStrLn "Done." + where test' (t,s) = if f h s t then return () -- putStr "." + else error $ show $ asListL t -- Temporary Hack + +-- | Generates a flat AVL tree of n elements [0..n-1]. +flatAVL :: Int -> AVL Int +flatAVL n = asTreeLenL n [0..n-1] + +-- | Detetermine the minimum number of elements in an AVL tree of given height. +-- This function satisfies this recurrence relation.. +-- +-- @ +-- minElements 0 = 0 +-- minElements 1 = 1 +-- minElements h = 1 + minElements (h-1) + minElements (h-2) +-- -- = Some weird expression involving the golden ratio +-- @ +minElements :: Int -> Integer +minElements 0 = 0 +minElements 1 = 1 +minElements h = minElements' 0 1 h where + minElements' n1 n2 2 = 1 + n1 + n2 + minElements' n1 n2 m = minElements' n2 (1 + n1 + n2) (m-1) + +-- | Detetermine the maximum number of elements in an AVL tree of given height. +-- This function satisfies this recurrence relation.. +-- +-- @ +-- maxElements 0 = 0 +-- maxElements h = 1 + 2 * maxElements (h-1) -- = 2^h-1 +-- @ +maxElements :: Int -> Integer +maxElements 0 = 0 +maxElements h = maxElements' 0 h where + maxElements' n1 1 = 1 + 2*n1 + maxElements' n1 m = maxElements' (1 + 2*n1) (m-1) diff --git a/Data/Tree/AVL/Types.hs b/Data/Tree/AVL/Types.hs new file mode 100644 --- /dev/null +++ b/Data/Tree/AVL/Types.hs @@ -0,0 +1,165 @@ +{-# OPTIONS_GHC -fglasgow-exts #-} +----------------------------------------------------------------------------- +-- | +-- Module : Data.Tree.AVL.Types +-- Copyright : (c) Adrian Hey 2004,2005 +-- License : BSD3 +-- +-- Maintainer : http://homepages.nildram.co.uk/~ahey/em.png +-- Stability : stable +-- Portability : portable +-- +-- AVL Tree data type definition and a few simple utility functions. +----------------------------------------------------------------------------- +module Data.Tree.AVL.Types + ( -- * Types. + AVL(..), + + -- * Simple AVL related utilities. + empty,isEmpty,isNonEmpty,singleton,pair,tryGetSingleton, + + ) where + +import Prelude -- so haddock finds the symbols there + +import Data.Typeable +#if __GLASGOW_HASKELL__ > 604 +import Data.Foldable +import Data.Monoid +#endif + +-- | AVL tree data type. +-- +-- The balance factor (BF) of an 'AVL' tree node is defined as the difference between the height of +-- the left and right sub-trees. An 'AVL' tree is ALWAYS height balanced, such that |BF| <= 1. +-- The functions in this library ("Data.Tree.AVL") are designed so that they never construct +-- an unbalanced tree (well that's assuming they're not broken). The 'AVL' tree type defined here +-- has the BF encoded the constructors. +-- +-- Some functions in this library return 'AVL' trees that are also \"flat\", which (in the context +-- of this library) means that the sizes of left and right sub-trees differ by at most one and +-- are also flat. Flat sorted trees should give slightly shorter searches than sorted trees which +-- are merely height balanced. Whether or not flattening is worth the effort depends on the number +-- of times the tree will be searched and the cost of element comparison. +-- +-- In cases where the tree elements are sorted, all the relevant 'AVL' functions follow the +-- convention that the leftmost tree element is least and the rightmost tree element is +-- the greatest. Bear this in mind when defining general comparison functions. It should +-- also be noted that all functions in this library for sorted trees require that the tree +-- does not contain multiple elements which are \"equal\" (according to whatever criterion +-- has been used to sort the elements). +-- +-- It is important to be consistent about argument ordering when defining general purpose +-- comparison functions (or selectors) for searching a sorted tree, such as .. +-- +-- @ +-- myComp :: (k -> e -> Ordering) +-- -- or.. +-- myCComp :: (k -> e -> COrdering a) +-- @ +-- +-- In these cases the first argument is the search key and the second argument is an element of +-- the 'AVL' tree. For example.. +-- +-- @ +-- key \`myCComp\` element -> Lt implies key < element, proceed down the left sub-tree +-- key \`myCComp\` element -> Gt implies key > element, proceed down the right sub-tree +-- @ +-- +-- This convention is same as that used by the overloaded 'compare' method from 'Ord' class. +-- +-- WARNING: The constructors of this data type are exported from this module but not from +-- the top level 'AVL' wrapper ("Data.Tree.AVL"). Don't try to construct your own 'AVL' +-- trees unless you're sure you know what your doing. If you end up creating and using +-- 'AVL' trees that aren't you'll break most of the functions in this library. +-- +-- Controlling Strictness. +-- +-- The 'AVL' data type is declared as non-strict in all it's fields, +-- but all the functions in this library behave as though it is strict in its +-- recursive fields (left and right sub-trees). Strictness in the element field is +-- controlled either by using the strict variants of functions (defined in this library +-- where appropriate), or using strict variants of the combinators defined in "Data.COrdering", +-- or using 'seq' etc. in your own code (in any combining comparisons you define, for example). +-- +-- A note about 'Eq' and 'Ord' class instances. +-- +-- For 'AVL' trees the defined instances of 'Ord' and 'Eq' are based on the lists that are produced using +-- the 'Data.Tree.AVL.List.asListL' function (it could just as well have been 'Data.Tree.AVL.List.asListR', +-- the choice is arbitrary but I can only chose one). This means that two trees which contain the same elements +-- in the same order are equal regardless of detailed tree structure. The same principle has been applied to +-- the instances of 'Read' and 'Show'. Unfortunately, this has the undesirable and non-intuitive effect +-- of making \"equal\" trees potentially distinguishable using some functions (such as height). +-- All such functions have been placed in the Data.Tree.AVL.Internals modules, which are not +-- included in the main "Data.Tree.AVL" wrapper. For all \"normal\" functions (f) exported by "Data.Tree.AVL" +-- it is safe to assume that if a and b are 'AVL' trees then (a == b) implies (f a == f b), provided the same +-- is true for the tree elements. +-- +data AVL e = E -- ^ Empty Tree + | N (AVL e) e (AVL e) -- ^ BF=-1 (right height > left height) + | Z (AVL e) e (AVL e) -- ^ BF= 0 + | P (AVL e) e (AVL e) -- ^ BF=+1 (left height > right height) + +-- A name for the AVL type constructor, fully qualified +avlTyConName :: String +avlTyConName = "Data.Tree.AVL.AVL" + +-- A Typeable1 instance +instance Typeable1 AVL where + typeOf1 _ = mkTyConApp (mkTyCon avlTyConName) [] + +#ifndef __GLASGOW_HASKELL__ +-- A Typeable instance (not needed by ghc, but Haddock fails to document this instance) +instance Typeable e => Typeable (AVL e) where + typeOf = typeOfDefault +#endif + +#if __GLASGOW_HASKELL__ > 604 +instance Foldable AVL where + foldMap _f E = mempty + foldMap f (N l v r) = foldMap f l `mappend` f v `mappend` foldMap f r + foldMap f (Z l v r) = foldMap f l `mappend` f v `mappend` foldMap f r + foldMap f (P l v r) = foldMap f l `mappend` f v `mappend` foldMap f r +#endif + +-- | The empty AVL tree. +{-# INLINE empty #-} +empty :: AVL e +empty = E + +-- | Returns 'True' if an AVL tree is empty. +-- +-- Complexity: O(1) +{-# INLINE isEmpty #-} +isEmpty :: AVL e -> Bool +isEmpty E = True +isEmpty _ = False + +-- | Returns 'True' if an AVL tree is non-empty. +-- +-- Complexity: O(1) +{-# INLINE isNonEmpty #-} +isNonEmpty :: AVL e -> Bool +isNonEmpty E = False +isNonEmpty _ = True + +-- | Creates an AVL tree with just one element. +-- +-- Complexity: O(1) +{-# INLINE singleton #-} +singleton :: e -> AVL e +singleton e = Z E e E + +-- | Create an AVL tree of two elements, occuring in same order as the arguments. +{-# INLINE pair #-} +pair :: e -> e -> AVL e +pair e0 e1 = P (Z E e0 E) e1 E + +-- | If the AVL tree is a singleton (has only one element @e@) then this function returns @('Just' e)@. +-- Otherwise it returns Nothing. +-- +-- Complexity: O(1) +{-# INLINE tryGetSingleton #-} +tryGetSingleton :: AVL e -> Maybe e +tryGetSingleton (Z E e _) = Just e -- Right subtree must be E too, but no need to waste time checking +tryGetSingleton _ = Nothing diff --git a/Data/Tree/AVL/Write.hs b/Data/Tree/AVL/Write.hs new file mode 100644 --- /dev/null +++ b/Data/Tree/AVL/Write.hs @@ -0,0 +1,197 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Data.Tree.AVL.Write +-- Copyright : (c) Adrian Hey 2004,2005 +-- License : BSD3 +-- +-- Maintainer : http://homepages.nildram.co.uk/~ahey/em.png +-- Stability : stable +-- Portability : portable +----------------------------------------------------------------------------- +module Data.Tree.AVL.Write +(-- * Writing to AVL trees + -- | These functions alter the content of a tree (values of tree elements) but not the structure + -- of a tree. + + -- ** Writing to extreme left or right + -- | I'm not sure these are likely to be much use in practice, but they're + -- simple enough to implement so are included for the sake of completeness. + writeL,tryWriteL,writeR,tryWriteR, + + -- ** Writing to /sorted/ trees + genWrite,genWriteFast,genTryWrite,genWriteMaybe,genTryWriteMaybe +) where + +import Prelude -- so haddock finds the symbols there + +import Data.COrdering +import Data.Tree.AVL.Types(AVL(..)) +import Data.Tree.AVL.Internals.BinPath(BinPath(..),genOpenPathWith,writePath) + +--------------------------------------------------------------------------- +-- writeL, tryWriteL -- +--------------------------------------------------------------------------- +-- | Replace the left most element of a tree with the supplied new element. +-- This function raises an error if applied to an empty tree. +-- +-- Complexity: O(log n) +writeL :: e -> AVL e -> AVL e +writeL _ E = error "writeL: Empty Tree" +writeL e' (N l e r) = writeLN e' l e r +writeL e' (Z l e r) = writeLZ e' l e r +writeL e' (P l e r) = writeLP e' l e r + +-- | Similar to 'writeL', but returns 'Nothing' if applied to an empty tree. +-- +-- Complexity: O(log n) +tryWriteL :: e -> AVL e -> Maybe (AVL e) +tryWriteL _ E = Nothing +tryWriteL e' (N l e r) = Just $! writeLN e' l e r +tryWriteL e' (Z l e r) = Just $! writeLZ e' l e r +tryWriteL e' (P l e r) = Just $! writeLP e' l e r + +-- This version of writeL is for trees which are known to be non-empty. +writeL' :: e -> AVL e -> AVL e +writeL' _ E = error "writeL': Bug0" +writeL' e' (N l e r) = writeLN e' l e r -- l may be empty +writeL' e' (Z l e r) = writeLZ e' l e r -- l may be empty +writeL' e' (P l e r) = writeLP e' l e r -- l can't be empty + +-- Write to left sub-tree of N l e r, or here if l is empty +writeLN :: e -> AVL e -> e -> AVL e -> AVL e +writeLN e' E _ r = N E e' r +writeLN e' (N ll le lr) e r = let l' = writeLN e' ll le lr in l' `seq` N l' e r +writeLN e' (Z ll le lr) e r = let l' = writeLZ e' ll le lr in l' `seq` N l' e r +writeLN e' (P ll le lr) e r = let l' = writeLP e' ll le lr in l' `seq` N l' e r + +-- Write to left sub-tree of Z l e r, or here if l is empty +writeLZ :: e -> AVL e -> e -> AVL e -> AVL e +writeLZ e' E _ r = Z E e' r -- r must be E too! +writeLZ e' (N ll le lr) e r = let l' = writeLN e' ll le lr in l' `seq` Z l' e r +writeLZ e' (Z ll le lr) e r = let l' = writeLZ e' ll le lr in l' `seq` Z l' e r +writeLZ e' (P ll le lr) e r = let l' = writeLP e' ll le lr in l' `seq` Z l' e r + +-- Write to left sub-tree of P l e r (l can't be empty) +{-# INLINE writeLP #-} +writeLP :: e -> AVL e -> e -> AVL e -> AVL e +writeLP e' l e r = let l' = writeL' e' l in l' `seq` P l' e r +--------------------------------------------------------------------------- +-- writeL, tryWriteL end here -- +--------------------------------------------------------------------------- + + +--------------------------------------------------------------------------- +-- writeR, tryWriteR -- +--------------------------------------------------------------------------- +-- | Replace the right most element of a tree with the supplied new element. +-- This function raises an error if applied to an empty tree. +-- +-- Complexity: O(log n) +writeR :: AVL e -> e -> AVL e +writeR E _ = error "writeR: Empty Tree" +writeR (N l e r) e' = writeRN l e r e' +writeR (Z l e r) e' = writeRZ l e r e' +writeR (P l e r) e' = writeRP l e r e' + +-- | Similar to 'writeR', but returns 'Nothing' if applied to an empty tree. +-- +-- Complexity: O(log n) +tryWriteR :: AVL e -> e -> Maybe (AVL e) +tryWriteR E _ = Nothing +tryWriteR (N l e r) e' = Just $! writeRN l e r e' +tryWriteR (Z l e r) e' = Just $! writeRZ l e r e' +tryWriteR (P l e r) e' = Just $! writeRP l e r e' + +-- This version of writeR is for trees which are known to be non-empty. +writeR' :: AVL e -> e -> AVL e +writeR' E _ = error "writeR': Bug0" +writeR' (N l e r) e' = writeRN l e r e' -- r can't be empty +writeR' (Z l e r) e' = writeRZ l e r e' -- r may be empty +writeR' (P l e r) e' = writeRP l e r e' -- r may be empty + +-- Write to right sub-tree of N l e r (r can't be empty) +{-# INLINE writeRN #-} +writeRN :: AVL e -> e -> AVL e -> e -> AVL e +writeRN l e r e' = let r' = writeR' r e' in r' `seq` N l e r' + +-- Write to right sub-tree of Z l e r, or here if r is empty +writeRZ :: AVL e -> e -> AVL e -> e -> AVL e +writeRZ l _ E e' = Z l e' E -- l must be E too! +writeRZ l e (N rl re rr) e' = let r' = writeRN rl re rr e' in r' `seq` Z l e r' +writeRZ l e (Z rl re rr) e' = let r' = writeRZ rl re rr e' in r' `seq` Z l e r' +writeRZ l e (P rl re rr) e' = let r' = writeRP rl re rr e' in r' `seq` Z l e r' + +-- Write to right sub-tree of P l e r, or here if r is empty +writeRP :: AVL e -> e -> AVL e -> e -> AVL e +writeRP l _ E e' = P l e' E +writeRP l e (N rl re rr) e' = let r' = writeRN rl re rr e' in r' `seq` P l e r' +writeRP l e (Z rl re rr) e' = let r' = writeRZ rl re rr e' in r' `seq` P l e r' +writeRP l e (P rl re rr) e' = let r' = writeRP rl re rr e' in r' `seq` P l e r' +--------------------------------------------------------------------------- +-- writeR, tryWriteR end here -- +--------------------------------------------------------------------------- + + +-- | A general purpose function to perform a search of a tree, using the supplied selector. +-- If the search succeeds the found element is replaced by the value (@e@) of the @('Eq' e)@ +-- constructor returned by the selector. If the search fails this function returns the original tree. +-- +-- Complexity: O(log n) +genWrite :: (e -> COrdering e) -> AVL e -> AVL e +genWrite c t = case genOpenPathWith c t of + FullBP pth e -> writePath pth e t + _ -> t + +-- | Functionally identical to 'genWrite', but returns an identical tree (one with all the nodes on +-- the path duplicated) if the search fails. This should probably only be used if you know the +-- search will succeed and will return an element which is different from that already present. +-- +-- Complexity: O(log n) +genWriteFast :: (e -> COrdering e) -> AVL e -> AVL e +genWriteFast c = write where + write E = E + write (N l e r) = case c e of + Lt -> let l' = write l in l' `seq` N l' e r + Eq v -> N l v r + Gt -> let r' = write r in r' `seq` N l e r' + write (Z l e r) = case c e of + Lt -> let l' = write l in l' `seq` Z l' e r + Eq v -> Z l v r + Gt -> let r' = write r in r' `seq` Z l e r' + write (P l e r) = case c e of + Lt -> let l' = write l in l' `seq` P l' e r + Eq v -> P l v r + Gt -> let r' = write r in r' `seq` P l e r' + +-- | A general purpose function to perform a search of a tree, using the supplied selector. +-- The found element is replaced by the value (@e@) of the @('Eq' e)@ constructor returned by +-- the selector. This function returns 'Nothing' if the search failed. +-- +-- Complexity: O(log n) +genTryWrite :: (e -> COrdering e) -> AVL e -> Maybe (AVL e) +genTryWrite c t = case genOpenPathWith c t of + FullBP pth e -> Just $! writePath pth e t + _ -> Nothing + +-- | Similar to 'genWrite', but also returns the original tree if the search succeeds but +-- the selector returns @('Eq' 'Nothing')@. (This version is intended to help reduce heap burn +-- rate if it\'s likely that no modification of the value is needed.) +-- +-- Complexity: O(log n) +genWriteMaybe :: (e -> COrdering (Maybe e)) -> AVL e -> AVL e +genWriteMaybe c t = case genOpenPathWith c t of + FullBP pth (Just e) -> writePath pth e t + _ -> t + +-- | Similar to 'genTryWrite', but also returns the original tree if the search succeeds but +-- the selector returns @('Eq' 'Nothing')@. (This version is intended to help reduce heap burn +-- rate if it\'s likely that no modification of the value is needed.) +-- +-- Complexity: O(log n) +genTryWriteMaybe :: (e -> COrdering (Maybe e)) -> AVL e -> Maybe (AVL e) +genTryWriteMaybe c t = case genOpenPathWith c t of + FullBP pth (Just e) -> Just $! writePath pth e t + FullBP _ Nothing -> Just t + _ -> Nothing + + diff --git a/Data/Tree/AVL/Zipper.hs b/Data/Tree/AVL/Zipper.hs new file mode 100644 --- /dev/null +++ b/Data/Tree/AVL/Zipper.hs @@ -0,0 +1,903 @@ +{-# OPTIONS_GHC -fglasgow-exts #-} +----------------------------------------------------------------------------- +-- | +-- Module : Data.Tree.AVL.Zipper +-- Copyright : (c) Adrian Hey 2004,2005 +-- License : BSD3 +-- +-- Maintainer : http://homepages.nildram.co.uk/~ahey/em.png +-- Stability : stable +-- Portability : portable +-- +----------------------------------------------------------------------------- +module Data.Tree.AVL.Zipper +(-- * The AVL Zipper + -- | An implementation of \"The Zipper\" for AVL trees. This can be used like + -- a functional pointer to a serial data structure which can be navigated + -- and modified, without having to worry about all those tricky tree balancing + -- issues. See JFP Vol.7 part 5 or .. + -- + -- + -- + -- Notes about efficiency: + -- + -- The functions defined here provide a useful way to achieve those awkward + -- operations which may not be covered by the rest of this package. They're + -- reasonably efficient (mostly O(log n) or better), but zipper flexibility + -- is bought at the expense of keeping path information explicitly as a heap + -- data structure rather than implicitly on the stack. Since heap storage + -- probably costs more, zipper operations will are likely to incur higher + -- constant factors than equivalent non-zipper operations (if available). + -- + -- Some of the functions provided here may appear to be weird combinations of + -- functions from a more logical set of primitives. They are provided because + -- they are not really simple combinations of the corresponding primitives. + -- They are more efficient, so you should use them if possible (e.g combining + -- deleting with Zipper closing). + -- + -- Also, consider using the 'BAVL' as a cheaper alternative if you don't + -- need to navigate the tree. + + -- ** Types + ZAVL,PAVL, + + -- ** Opening + assertOpenL,assertOpenR, + tryOpenL,tryOpenR, + genAssertOpen,genTryOpen, + genTryOpenGE,genTryOpenLE, + genOpenEither, + + -- ** Closing + close,fillClose, + + -- ** Manipulating the current element. + getCurrent,putCurrent,applyCurrent,applyCurrent', + + -- ** Moving + assertMoveL,assertMoveR,tryMoveL,tryMoveR, + + -- ** Inserting elements + insertL,insertR,insertMoveL,insertMoveR,fill, + + -- ** Deleting elements + delClose, + assertDelMoveL,assertDelMoveR,tryDelMoveR,tryDelMoveL, + delAllL,delAllR, + delAllCloseL,delAllCloseR, + delAllIncCloseL,delAllIncCloseR, + + -- ** Inserting AVL trees + insertTreeL,insertTreeR, + + -- ** Current element status + isLeftmost,isRightmost, + sizeL,sizeR, + + -- ** Operations on whole zippers + sizeZAVL, + + -- ** A cheaper option is to use BAVL + -- | These are a cheaper but more restrictive alternative to using the full Zipper. + -- They use \"Binary Paths\" (Ints) to point to a particular element of an 'AVL' tree. + -- Use these when you don't need to navigate the tree, you just want to look at a + -- particular element (and perhaps modify or delete it). The advantage of these is + -- that they don't create the usual Zipper heap structure, so they will be faster + -- (and reduce heap burn rate too). + -- + -- If you subsequently decide you need a Zipper rather than a BAVL then some conversion + -- utilities are provided. + + -- *** Types + BAVL, + + -- *** Opening and closing + genOpenBAVL,closeBAVL, + + -- *** Inspecting status + fullBAVL,emptyBAVL,tryReadBAVL,readFullBAVL, + + -- *** Modifying the tree + pushBAVL,deleteBAVL, + + -- *** Converting to BAVL to Zipper + -- | These are O(log n) operations but with low constant factors because no comparisons + -- are required (and the tree nodes on the path will most likely still be in cache as + -- a result of opening the BAVL in the first place). + fullBAVLtoZAVL,emptyBAVLtoPAVL,anyBAVLtoEither, +) where + +import Prelude -- so haddock finds the symbols there + +import Data.Tree.AVL.Types(AVL(..)) +import Data.Tree.AVL.Size(size,addSize) +import Data.Tree.AVL.Internals.DelUtils(deletePath,popRN,popRZ,popRP,popLN,popLZ,popLP) +import Data.Tree.AVL.Internals.HeightUtils(height,addHeight) +import Data.Tree.AVL.Internals.HJoin(spliceH,joinH) +import Data.Tree.AVL.Internals.HPush(pushHL,pushHR) +import Data.Tree.AVL.Internals.BinPath(BinPath(..),genOpenPath,writePath,insertPath,sel,goL,goR) + +#ifdef __GLASGOW_HASKELL__ +import GHC.Base +#include "ghcdefs.h" +#else +#include "h98defs.h" +#endif + +-- N.B. Zippers are always opened using relative heights for efficiency reasons. On the +-- whole this causes no problems, except when inserting entire AVL trees or substituting +-- the empty tree. (These cases have some minor height computation overhead). + +-- | Abstract data type for a successfully opened AVL tree. All ZAVL\'s are non-empty! +-- A ZAVL can be tought of as a functional pointer to an AVL tree element. +data ZAVL e = ZAVL (Path e) (AVL e) !UINT e (AVL e) !UINT + +-- | Abstract data type for an unsuccessfully opened AVL tree. +-- A PAVL can be thought of as a functional pointer to the gap +-- where the expected element should be (but isn't). You can fill this gap using +-- the 'fill' function, or fill and close at the same time using the 'fillClose' function. +data PAVL e = PAVL (Path e) !UINT + +data Path e = EP -- Empty Path + | LP (Path e) e (AVL e) !UINT -- Left subtree was taken + | RP (Path e) e (AVL e) !UINT -- Right subtree was taken + +-- Local Closing Utility +close_ :: Path e -> AVL e -> UINT -> AVL e +close_ EP t _ = t +close_ (LP p e r hr) l hl = case spliceH l hl e r hr of UBT2(t,ht) -> close_ p t ht +close_ (RP p e l hl) r hr = case spliceH l hl e r hr of UBT2(t,ht) -> close_ p t ht + +-- Local Utility to remove all left paths from a path +noLP :: Path e -> Path e +noLP EP = EP +noLP (LP p _ _ _ ) = noLP p +noLP (RP p e l hl) = let p_ = noLP p in p_ `seq` RP p_ e l hl + +-- Local Utility to remove all right paths from a path +noRP :: Path e -> Path e +noRP EP = EP +noRP (LP p e r hr) = let p_ = noRP p in p_ `seq` LP p_ e r hr +noRP (RP p _ _ _ ) = noRP p + +-- Local Closing Utility which ignores all left paths +closeNoLP :: Path e -> AVL e -> UINT -> AVL e +closeNoLP EP t _ = t +closeNoLP (LP p _ _ _ ) l hl = closeNoLP p l hl +closeNoLP (RP p e l hl) r hr = case spliceH l hl e r hr of UBT2(t,ht) -> closeNoLP p t ht + +-- Local Closing Utility which ignores all right paths +closeNoRP :: Path e -> AVL e -> UINT -> AVL e +closeNoRP EP t _ = t +closeNoRP (LP p e r hr) l hl = case spliceH l hl e r hr of UBT2(t,ht) -> closeNoRP p t ht +closeNoRP (RP p _ _ _ ) r hr = closeNoRP p r hr + +-- Add size of all path elements. +addSizeP :: Int -> Path e -> Int +addSizeP n EP = n +addSizeP n (LP p _ r _) = addSizeP (addSize (n+1) r) p +addSizeP n (RP p _ l _) = addSizeP (addSize (n+1) l) p + +-- Add size of all RP path elements. +addSizeRP :: Int -> Path e -> Int +addSizeRP n EP = n +addSizeRP n (LP p _ _ _) = addSizeRP n p +addSizeRP n (RP p _ l _) = addSizeRP (addSize (n+1) l) p + +-- Add size of all LP path elements. +addSizeLP :: Int -> Path e -> Int +addSizeLP n EP = n +addSizeLP n (LP p _ r _) = addSizeLP (addSize (n+1) r) p +addSizeLP n (RP p _ _ _) = addSizeLP n p + +-- | Opens a sorted AVL tree at the element given by the supplied selector. This function +-- raises an error if the tree does not contain such an element. +-- +-- Complexity: O(log n) +genAssertOpen :: (e -> Ordering) -> AVL e -> ZAVL e +genAssertOpen c t = op EP L(0) t where -- Relative heights !! + -- op :: (Path e) -> UINT -> AVL e -> ZAVL e + op _ _ E = error "genAssertOpen: No matching element." + op p h (N l e r) = case c e of + LT -> let p_ = LP p e r DECINT1(h) in p_ `seq` op p_ DECINT2(h) l + EQ -> ZAVL p l DECINT2(h) e r DECINT1(h) + GT -> let p_ = RP p e l DECINT2(h) in p_ `seq` op p_ DECINT1(h) r + op p h (Z l e r) = case c e of + LT -> let p_ = LP p e r DECINT1(h) in p_ `seq` op p_ DECINT1(h) l + EQ -> ZAVL p l DECINT1(h) e r DECINT1(h) + GT -> let p_ = RP p e l DECINT1(h) in p_ `seq` op p_ DECINT1(h) r + op p h (P l e r) = case c e of + LT -> let p_ = LP p e r DECINT2(h) in p_ `seq` op p_ DECINT1(h) l + EQ -> ZAVL p l DECINT1(h) e r DECINT2(h) + GT -> let p_ = RP p e l DECINT1(h) in p_ `seq` op p_ DECINT2(h) r + +-- | Attempts to open a sorted AVL tree at the element given by the supplied selector. +-- This function returns 'Nothing' if there is no such element. +-- +-- Note that this operation will still create a zipper path structure on the heap (which +-- is promptly discarded) if the search fails, and so is potentially inefficient if failure +-- is likely. In cases like this it may be better to use 'genOpenBAVL', test for \"fullness\" +-- using 'fullBAVL' and then convert to a 'ZAVL' using 'fullBAVLtoZAVL'. +-- +-- Complexity: O(log n) +genTryOpen :: (e -> Ordering) -> AVL e -> Maybe (ZAVL e) +genTryOpen c t = op EP L(0) t where -- Relative heights !! + -- op :: (Path e) -> UINT -> AVL e -> Maybe (ZAVL e) + op _ _ E = Nothing + op p h (N l e r) = case c e of + LT -> let p_ = LP p e r DECINT1(h) in p_ `seq` op p_ DECINT2(h) l + EQ -> Just $! ZAVL p l DECINT2(h) e r DECINT1(h) + GT -> let p_ = RP p e l DECINT2(h) in p_ `seq` op p_ DECINT1(h) r + op p h (Z l e r) = case c e of + LT -> let p_ = LP p e r DECINT1(h) in p_ `seq` op p_ DECINT1(h) l + EQ -> Just $! ZAVL p l DECINT1(h) e r DECINT1(h) + GT -> let p_ = RP p e l DECINT1(h) in p_ `seq` op p_ DECINT1(h) r + op p h (P l e r) = case c e of + LT -> let p_ = LP p e r DECINT2(h) in p_ `seq` op p_ DECINT1(h) l + EQ -> Just $! ZAVL p l DECINT1(h) e r DECINT2(h) + GT -> let p_ = RP p e l DECINT1(h) in p_ `seq` op p_ DECINT2(h) r + +-- | Attempts to open a sorted AVL tree at the least element which is greater than or equal, according to +-- the supplied selector. This function returns 'Nothing' if the tree does not contain such an element. +-- +-- Complexity: O(log n) +genTryOpenGE :: (e -> Ordering) -> AVL e -> Maybe (ZAVL e) +genTryOpenGE c t = op EP L(0) t where -- Relative heights !! + -- op :: (Path e) -> UINT -> AVL e -> ZAVL e + op p h E = backupR p E h where + backupR EP _ _ = Nothing + backupR (LP p_ e r hr) l hl = Just $! ZAVL p_ l hl e r hr + backupR (RP p_ e l hl) r hr = case spliceH l hl e r hr of UBT2(t_,ht_) -> backupR p_ t_ ht_ + op p h (N l e r) = case c e of + LT -> let p_ = LP p e r DECINT1(h) in p_ `seq` op p_ DECINT2(h) l + EQ -> Just $! ZAVL p l DECINT2(h) e r DECINT1(h) + GT -> let p_ = RP p e l DECINT2(h) in p_ `seq` op p_ DECINT1(h) r + op p h (Z l e r) = case c e of + LT -> let p_ = LP p e r DECINT1(h) in p_ `seq` op p_ DECINT1(h) l + EQ -> Just $! ZAVL p l DECINT1(h) e r DECINT1(h) + GT -> let p_ = RP p e l DECINT1(h) in p_ `seq` op p_ DECINT1(h) r + op p h (P l e r) = case c e of + LT -> let p_ = LP p e r DECINT2(h) in p_ `seq` op p_ DECINT1(h) l + EQ -> Just $! ZAVL p l DECINT1(h) e r DECINT2(h) + GT -> let p_ = RP p e l DECINT1(h) in p_ `seq` op p_ DECINT2(h) r + +-- | Attempts to open a sorted AVL tree at the greatest element which is less than or equal, according to +-- the supplied selector. This function returns _Nothing_ if the tree does not contain such an element. +-- +-- Complexity: O(log n) +genTryOpenLE :: (e -> Ordering) -> AVL e -> Maybe (ZAVL e) +genTryOpenLE c t = op EP L(0) t where -- Relative heights !! + -- op :: (Path e) -> UINT -> AVL e -> ZAVL e + op p h E = backupL p E h where + backupL EP _ _ = Nothing + backupL (LP p_ e r hr) l hl = case spliceH l hl e r hr of UBT2(t_,ht_) -> backupL p_ t_ ht_ + backupL (RP p_ e l hl) r hr = Just $! ZAVL p_ l hl e r hr + op p h (N l e r) = case c e of + LT -> let p_ = LP p e r DECINT1(h) in p_ `seq` op p_ DECINT2(h) l + EQ -> Just $! ZAVL p l DECINT2(h) e r DECINT1(h) + GT -> let p_ = RP p e l DECINT2(h) in p_ `seq` op p_ DECINT1(h) r + op p h (Z l e r) = case c e of + LT -> let p_ = LP p e r DECINT1(h) in p_ `seq` op p_ DECINT1(h) l + EQ -> Just $! ZAVL p l DECINT1(h) e r DECINT1(h) + GT -> let p_ = RP p e l DECINT1(h) in p_ `seq` op p_ DECINT1(h) r + op p h (P l e r) = case c e of + LT -> let p_ = LP p e r DECINT2(h) in p_ `seq` op p_ DECINT1(h) l + EQ -> Just $! ZAVL p l DECINT1(h) e r DECINT2(h) + GT -> let p_ = RP p e l DECINT1(h) in p_ `seq` op p_ DECINT2(h) r + +-- | Opens a non-empty AVL tree at the leftmost element. +-- This function raises an error if the tree is empty. +-- +-- Complexity: O(log n) +assertOpenL :: AVL e -> ZAVL e +assertOpenL E = error "assertOpenL: Empty tree." +assertOpenL (N l e r) = openLN EP L(0) l e r -- Relative heights !! +assertOpenL (Z l e r) = openLZ EP L(0) l e r -- Relative heights !! +assertOpenL (P l e r) = openL_ (LP EP e r L(0)) L(1) l -- Relative heights !! + +-- | Attempts to open a non-empty AVL tree at the leftmost element. +-- This function returns 'Nothing' if the tree is empty. +-- +-- Complexity: O(log n) +tryOpenL :: AVL e -> Maybe (ZAVL e) +tryOpenL E = Nothing +tryOpenL (N l e r) = Just $! openLN EP L(0) l e r -- Relative heights !! +tryOpenL (Z l e r) = Just $! openLZ EP L(0) l e r -- Relative heights !! +tryOpenL (P l e r) = Just $! openL_ (LP EP e r L(0)) L(1) l -- Relative heights !! + +-- Local utility for opening at the leftmost element, using current path and height. +openL_ :: (Path e) -> UINT -> AVL e -> ZAVL e +openL_ _ _ E = error "openL_: Bug0" +openL_ p h (N l e r) = openLN p h l e r +openL_ p h (Z l e r) = openLZ p h l e r +openL_ p h (P l e r) = let p_ = LP p e r DECINT2(h) in p_ `seq` openL_ p_ DECINT1(h) l + +-- Open leftmost of (N l e r), where l may be E +openLN :: (Path e) -> UINT -> AVL e -> e -> AVL e -> ZAVL e +openLN p h E e r = ZAVL p E DECINT2(h) e r DECINT1(h) +openLN p h (N ll le lr) e r = let p_ = LP p e r DECINT1(h) in p_ `seq` openLN p_ DECINT2(h) ll le lr +openLN p h (Z ll le lr) e r = let p_ = LP p e r DECINT1(h) in p_ `seq` openLZ p_ DECINT2(h) ll le lr +openLN p h (P ll le lr) e r = let p_ = LP p e r DECINT1(h) + p__ = p_ `seq` LP p_ le lr DECINT4(h) + in p__ `seq` openL_ p__ DECINT3(h) ll +-- Open leftmost of (Z l e r), where l may be E +openLZ :: (Path e) -> UINT -> AVL e -> e -> AVL e -> ZAVL e +openLZ p h E e r = ZAVL p E DECINT1(h) e r DECINT1(h) +openLZ p h (N ll le lr) e r = let p_ = LP p e r DECINT1(h) in p_ `seq` openLN p_ DECINT1(h) ll le lr +openLZ p h (Z ll le lr) e r = let p_ = LP p e r DECINT1(h) in p_ `seq` openLZ p_ DECINT1(h) ll le lr +openLZ p h (P ll le lr) e r = let p_ = LP p e r DECINT1(h) + p__ = p_ `seq` LP p_ le lr DECINT3(h) + in p__ `seq` openL_ p__ DECINT2(h) ll + +-- | Opens a non-empty AVL tree at the rightmost element. +-- This function raises an error if the tree is empty. +-- +-- Complexity: O(log n) +assertOpenR :: AVL e -> ZAVL e +assertOpenR E = error "assertOpenR: Empty tree." +assertOpenR (N l e r) = openR_ (RP EP e l L(0)) L(1) r -- Relative heights !! +assertOpenR (Z l e r) = openRZ EP L(0) l e r -- Relative heights !! +assertOpenR (P l e r) = openRP EP L(0) l e r -- Relative heights !! + +-- | Attempts to open a non-empty AVL tree at the rightmost element. +-- This function returns 'Nothing' if the tree is empty. +-- +-- Complexity: O(log n) +tryOpenR :: AVL e -> Maybe (ZAVL e) +tryOpenR E = Nothing +tryOpenR (N l e r) = Just $! openR_ (RP EP e l L(0)) L(1) r -- Relative heights !! +tryOpenR (Z l e r) = Just $! openRZ EP L(0) l e r -- Relative heights !! +tryOpenR (P l e r) = Just $! openRP EP L(0) l e r -- Relative heights !! + +-- Local utility for opening at the rightmost element, using current path and height. +openR_ :: (Path e) -> UINT -> AVL e -> ZAVL e +openR_ _ _ E = error "openR_: Bug0" +openR_ p h (N l e r) = let p_ = RP p e l DECINT2(h) in p_ `seq` openR_ p_ DECINT1(h) r +openR_ p h (Z l e r) = openRZ p h l e r +openR_ p h (P l e r) = openRP p h l e r +-- Open rightmost of (P l e r), where r may be E +openRP :: (Path e) -> UINT -> AVL e -> e -> AVL e -> ZAVL e +openRP p h l e E = ZAVL p l DECINT1(h) e E DECINT2(h) +openRP p h l e (N rl re rr) = let p_ = RP p e l DECINT1(h) + p__ = p_ `seq` RP p_ re rl DECINT4(h) + in p__ `seq` openR_ p__ DECINT3(h) rr +openRP p h l e (Z rl re rr) = let p_ = RP p e l DECINT1(h) in p_ `seq` openRZ p_ DECINT2(h) rl re rr +openRP p h l e (P rl re rr) = let p_ = RP p e l DECINT1(h) in p_ `seq` openRP p_ DECINT2(h) rl re rr +-- Open rightmost of (Z l e r), where r may be E +openRZ :: (Path e) -> UINT -> AVL e -> e -> AVL e -> ZAVL e +openRZ p h l e E = ZAVL p l DECINT1(h) e E DECINT1(h) +openRZ p h l e (N rl re rr) = let p_ = RP p e l DECINT1(h) + p__ = p_ `seq` RP p_ re rl DECINT3(h) + in p__ `seq` openR_ p__ DECINT2(h) rr +openRZ p h l e (Z rl re rr) = let p_ = RP p e l DECINT1(h) in p_ `seq` openRZ p_ DECINT1(h) rl re rr +openRZ p h l e (P rl re rr) = let p_ = RP p e l DECINT1(h) in p_ `seq` openRP p_ DECINT1(h) rl re rr + +-- | Returns @('Right' zavl)@ if the expected element was found, @('Left' pavl)@ if the +-- expected element was not found. It's OK to use this function on empty trees. +-- +-- Complexity: O(log n) +genOpenEither :: (e -> Ordering) -> AVL e -> Either (PAVL e) (ZAVL e) +genOpenEither c t = op EP L(0) t where -- Relative heights !! + -- op :: (Path e) -> UINT -> AVL e -> Either (PAVL e) (ZAVL e) + op p h E = Left $! PAVL p h + op p h (N l e r) = case c e of + LT -> let p_ = LP p e r DECINT1(h) in p_ `seq` op p_ DECINT2(h) l + EQ -> Right $! ZAVL p l DECINT2(h) e r DECINT1(h) + GT -> let p_ = RP p e l DECINT2(h) in p_ `seq` op p_ DECINT1(h) r + op p h (Z l e r) = case c e of + LT -> let p_ = LP p e r DECINT1(h) in p_ `seq` op p_ DECINT1(h) l + EQ -> Right $! ZAVL p l DECINT1(h) e r DECINT1(h) + GT -> let p_ = RP p e l DECINT1(h) in p_ `seq` op p_ DECINT1(h) r + op p h (P l e r) = case c e of + LT -> let p_ = LP p e r DECINT2(h) in p_ `seq` op p_ DECINT1(h) l + EQ -> Right $! ZAVL p l DECINT1(h) e r DECINT2(h) + GT -> let p_ = RP p e l DECINT1(h) in p_ `seq` op p_ DECINT2(h) r + +-- | Fill the gap pointed to by a 'PAVL' with the supplied element, which becomes +-- the current element of the resulting 'ZAVL'. The supplied filling element should +-- be \"equal\" to the value used in the search which created the 'PAVL'. +-- +-- Complexity: O(1) +fill :: e -> PAVL e -> ZAVL e +fill e (PAVL p h) = ZAVL p E h e E h + +-- | Essentially the same operation as 'fill', but the resulting 'ZAVL' is closed +-- immediately. +-- +-- Complexity: O(log n) +fillClose :: e -> PAVL e -> AVL e +fillClose e (PAVL p h) = close_ p (Z E e E) INCINT1(h) + +-- | Closes a Zipper. +-- +-- Complexity: O(log n) +close :: ZAVL e -> AVL e +close (ZAVL p l hl e r hr) = case spliceH l hl e r hr of UBT2(t,ht) -> close_ p t ht + +-- | Deletes the current element and then closes the Zipper. +-- +-- Complexity: O(log n) +delClose :: ZAVL e -> AVL e +delClose (ZAVL p l hl _ r hr) = case joinH l hl r hr of UBT2(t,ht) -> close_ p t ht + +-- | Gets the current element of a Zipper. +-- +-- Complexity: O(1) +getCurrent :: ZAVL e -> e +getCurrent (ZAVL _ _ _ e _ _) = e + +-- | Overwrites the current element of a Zipper. +-- +-- Complexity: O(1) +putCurrent :: e -> ZAVL e -> ZAVL e +putCurrent e (ZAVL p l hl _ r hr) = ZAVL p l hl e r hr + +-- | Applies a function to the current element of a Zipper (lazily). +-- See also 'applyCurrent'' for a strict version of this function. +-- +-- Complexity: O(1) +applyCurrent :: (e -> e) -> ZAVL e -> ZAVL e +applyCurrent f (ZAVL p l hl e r hr) = ZAVL p l hl (f e) r hr + +-- | Applies a function to the current element of a Zipper strictly. +-- See also 'applyCurrent' for a non-strict version of this function. +-- +-- Complexity: O(1) +applyCurrent' :: (e -> e) -> ZAVL e -> ZAVL e +applyCurrent' f (ZAVL p l hl e r hr) = let e_ = f e in e_ `seq` ZAVL p l hl e_ r hr + +-- | Moves one step left. +-- This function raises an error if the current element is already the leftmost element. +-- +-- Complexity: O(1) average, O(log n) worst case. +assertMoveL :: ZAVL e -> ZAVL e +assertMoveL (ZAVL p E _ e r hr) = case pushHL e r hr of UBT2(t,ht) -> cR p t ht + where cR EP _ _ = error "assertMoveL: Can't move left." + cR (LP p_ e_ r_ hr_) l_ hl_ = case spliceH l_ hl_ e_ r_ hr_ of UBT2(t,ht) -> cR p_ t ht + cR (RP p_ e_ l_ hl_) r_ hr_ = ZAVL p_ l_ hl_ e_ r_ hr_ +assertMoveL (ZAVL p (N ll le lr) hl e r hr) = let p_ = RP (LP p e r hr) le ll DECINT2(hl) + in p_ `seq` openR_ p_ DECINT1(hl) lr +assertMoveL (ZAVL p (Z ll le lr) hl e r hr) = openRZ (LP p e r hr) hl ll le lr +assertMoveL (ZAVL p (P ll le lr) hl e r hr) = openRP (LP p e r hr) hl ll le lr + +-- | Attempts to move one step left. +-- This function returns 'Nothing' if the current element is already the leftmost element. +-- +-- Complexity: O(1) average, O(log n) worst case. +tryMoveL :: ZAVL e -> Maybe (ZAVL e) +tryMoveL (ZAVL p E _ e r hr) = case pushHL e r hr of UBT2(t,ht) -> cR p t ht + where cR EP _ _ = Nothing + cR (LP p_ e_ r_ hr_) l_ hl_ = case spliceH l_ hl_ e_ r_ hr_ of UBT2(t,ht) -> cR p_ t ht + cR (RP p_ e_ l_ hl_) r_ hr_ = Just $! ZAVL p_ l_ hl_ e_ r_ hr_ +tryMoveL (ZAVL p (N ll le lr) hl e r hr) = Just $! let p_ = RP (LP p e r hr) le ll DECINT2(hl) + in p_ `seq` openR_ p_ DECINT1(hl) lr +tryMoveL (ZAVL p (Z ll le lr) hl e r hr) = Just $! openRZ (LP p e r hr) hl ll le lr +tryMoveL (ZAVL p (P ll le lr) hl e r hr) = Just $! openRP (LP p e r hr) hl ll le lr + +-- | Moves one step right. +-- This function raises an error if the current element is already the rightmost element. +-- +-- Complexity: O(1) average, O(log n) worst case. +assertMoveR :: ZAVL e -> ZAVL e +assertMoveR (ZAVL p l hl e E _ ) = case pushHR l hl e of UBT2(t,ht) -> cL p t ht + where cL EP _ _ = error "assertMoveR: Can't move right." + cL (RP p_ e_ l_ hl_) r_ hr_ = case spliceH l_ hl_ e_ r_ hr_ of UBT2(t,ht) -> cL p_ t ht + cL (LP p_ e_ r_ hr_) l_ hl_ = ZAVL p_ l_ hl_ e_ r_ hr_ +assertMoveR (ZAVL p l hl e (N rl re rr) hr) = openLN (RP p e l hl) hr rl re rr +assertMoveR (ZAVL p l hl e (Z rl re rr) hr) = openLZ (RP p e l hl) hr rl re rr +assertMoveR (ZAVL p l hl e (P rl re rr) hr) = let p_ = LP (RP p e l hl) re rr DECINT2(hr) + in p_ `seq` openL_ p_ DECINT1(hr) rl + +-- | Attempts to move one step right. +-- This function returns 'Nothing' if the current element is already the rightmost element. +-- +-- Complexity: O(1) average, O(log n) worst case. +tryMoveR :: ZAVL e -> Maybe (ZAVL e) +tryMoveR (ZAVL p l hl e E _ ) = case pushHR l hl e of UBT2(t,ht) -> cL p t ht + where cL EP _ _ = Nothing + cL (RP p_ e_ l_ hl_) r_ hr_ = case spliceH l_ hl_ e_ r_ hr_ of UBT2(t,ht) -> cL p_ t ht + cL (LP p_ e_ r_ hr_) l_ hl_ = Just $! ZAVL p_ l_ hl_ e_ r_ hr_ +tryMoveR (ZAVL p l hl e (N rl re rr) hr) = Just $! openLN (RP p e l hl) hr rl re rr +tryMoveR (ZAVL p l hl e (Z rl re rr) hr) = Just $! openLZ (RP p e l hl) hr rl re rr +tryMoveR (ZAVL p l hl e (P rl re rr) hr) = Just $! let p_ = LP (RP p e l hl) re rr DECINT2(hr) + in p_ `seq` openL_ p_ DECINT1(hr) rl + +-- | Returns 'True' if the current element is the leftmost element. +-- +-- Complexity: O(1) average, O(log n) worst case. +isLeftmost :: ZAVL e -> Bool +isLeftmost (ZAVL p E _ _ _ _) = iL p + where iL EP = True + iL (LP p_ _ _ _) = iL p_ + iL (RP _ _ _ _) = False +isLeftmost (ZAVL _ _ _ _ _ _) = False + +-- | Returns 'True' if the current element is the rightmost element. +-- +-- Complexity: O(1) average, O(log n) worst case. +isRightmost :: ZAVL e -> Bool +isRightmost (ZAVL p _ _ _ E _) = iR p + where iR EP = True + iR (RP p_ _ _ _) = iR p_ + iR (LP _ _ _ _) = False +isRightmost (ZAVL _ _ _ _ _ _) = False + +-- | Inserts a new element to the immediate left of the current element. +-- +-- Complexity: O(1) average, O(log n) worst case. +insertL :: e -> ZAVL e -> ZAVL e +insertL e0 (ZAVL p l hl e1 r hr) = case pushHR l hl e0 of UBT2(l_,hl_) -> ZAVL p l_ hl_ e1 r hr + +-- | Inserts a new element to the immediate left of the current element and then +-- moves one step left (so the newly inserted element becomes the current element). +-- +-- Complexity: O(1) average, O(log n) worst case. +insertMoveL :: e -> ZAVL e -> ZAVL e +insertMoveL e0 (ZAVL p l hl e1 r hr) = case pushHL e1 r hr of UBT2(r_,hr_) -> ZAVL p l hl e0 r_ hr_ + +-- | Inserts a new element to the immediate right of the current element. +-- +-- Complexity: O(1) average, O(log n) worst case. +insertR :: ZAVL e -> e -> ZAVL e +insertR (ZAVL p l hl e0 r hr) e1 = case pushHL e1 r hr of UBT2(r_,hr_) -> ZAVL p l hl e0 r_ hr_ + +-- | Inserts a new element to the immediate right of the current element and then +-- moves one step right (so the newly inserted element becomes the current element). +-- +-- Complexity: O(1) average, O(log n) worst case. +insertMoveR :: ZAVL e -> e -> ZAVL e +insertMoveR (ZAVL p l hl e0 r hr) e1 = case pushHR l hl e0 of UBT2(l_,hl_) -> ZAVL p l_ hl_ e1 r hr + +-- | Inserts a new AVL tree to the immediate left of the current element. +-- +-- Complexity: O(log n), where n is the size of the inserted tree. +insertTreeL :: AVL e -> ZAVL e -> ZAVL e +insertTreeL E zavl = zavl +insertTreeL t@(N l _ _) zavl = insertLH t (addHeight L(2) l) zavl -- Absolute height required!! +insertTreeL t@(Z l _ _) zavl = insertLH t (addHeight L(1) l) zavl -- Absolute height required!! +insertTreeL t@(P _ _ r) zavl = insertLH t (addHeight L(2) r) zavl -- Absolute height required!! + + +-- Local utility to insert an AVL to the immediate left of the current element. +-- This operation carries a minor overhead in that we must convert the absolute +-- AVL height into a relative height with the same offset as the rest of the ZAVL. +-- This requires calculation of the absolute height at the current position, but +-- this should be relatively cheap because the overwhelming majority of elements will +-- be close to the bottom of any tree. +insertLH :: AVL e -> UINT -> ZAVL e -> ZAVL e +insertLH t ht (ZAVL p l hl e r hr) = + let offset = case COMPAREUINT hl hr of -- chose smaller sub-tree to calculate absolute height + LT -> SUBINT(hl,height l) + EQ -> SUBINT(hl,height l) + GT -> SUBINT(hr,height r) + in case joinH l hl t ADDINT(ht,offset) of UBT2(l_,hl_) -> ZAVL p l_ hl_ e r hr + +-- | Inserts a new AVL tree to the immediate right of the current element. +-- +-- Complexity: O(log n), where n is the size of the inserted tree. +insertTreeR :: ZAVL e -> AVL e -> ZAVL e +insertTreeR zavl E = zavl +insertTreeR zavl t@(N l _ _) = insertRH t (addHeight L(2) l) zavl -- Absolute height required!! +insertTreeR zavl t@(Z l _ _) = insertRH t (addHeight L(1) l) zavl -- Absolute height required!! +insertTreeR zavl t@(P _ _ r) = insertRH t (addHeight L(2) r) zavl -- Absolute height required!! + +-- Local utility to insert an AVL to the immediate right of the current element. +-- This operation carries a minor overhead in that we must convert the absolute +-- AVL height into a relative height with the same offset as the rest of the ZAVL. +-- This requires calculation of the absolute height at the current position, but +-- this should be relatively cheap because the overwhelming majority of elements will +-- be close to the bottom of any tree. +insertRH :: AVL e -> UINT -> ZAVL e -> ZAVL e +insertRH t ht (ZAVL p l hl e r hr) = + let offset = case COMPAREUINT hl hr of -- chose smaller sub-tree to calculate absolute height + LT -> SUBINT(hl,height l) + EQ -> SUBINT(hr,height r) + GT -> SUBINT(hr,height r) + in case joinH t ADDINT(ht,offset) r hr of UBT2(r_,hr_) -> ZAVL p l hl e r_ hr_ + + +-- | Deletes the current element and moves one step left. +-- This function raises an error if the current element is already the leftmost element. +-- +-- Complexity: O(1) average, O(log n) worst case. +assertDelMoveL :: ZAVL e -> ZAVL e +assertDelMoveL (ZAVL p E _ _ r hr) = dR p r hr + where dR EP _ _ = error "assertDelMoveL: Can't move left." + dR (LP p_ e_ r_ hr_) l_ hl_ = case spliceH l_ hl_ e_ r_ hr_ of UBT2(t,ht) -> dR p_ t ht + dR (RP p_ e_ l_ hl_) r_ hr_ = ZAVL p_ l_ hl_ e_ r_ hr_ +assertDelMoveL (ZAVL p (N ll le lr) hl _ r hr) = case popRN ll le lr of + UBT2(l,e) -> case l of + Z _ _ _ -> ZAVL p l DECINT1(hl) e r hr + N _ _ _ -> ZAVL p l hl e r hr + _ -> error "assertDelMoveL: Bug0" -- impossible +assertDelMoveL (ZAVL p (Z ll le lr) hl _ r hr) = case popRZ ll le lr of + UBT2(l,e) -> case l of + E -> ZAVL p l DECINT1(hl) e r hr -- Don't use E!! + N _ _ _ -> error "assertDelMoveL: Bug1" -- impossible + _ -> ZAVL p l hl e r hr +assertDelMoveL (ZAVL p (P ll le lr) hl _ r hr) = case popRP ll le lr of + UBT2(l,e) -> case l of + E -> error "assertDelMoveL: Bug2" -- impossible + Z _ _ _ -> ZAVL p l DECINT1(hl) e r hr + _ -> ZAVL p l hl e r hr + + +-- | Attempts to delete the current element and move one step left. +-- This function returns 'Nothing' if the current element is already the leftmost element. +-- +-- Complexity: O(1) average, O(log n) worst case. +tryDelMoveL :: ZAVL e -> Maybe (ZAVL e) +tryDelMoveL (ZAVL p E _ _ r hr) = dR p r hr + where dR EP _ _ = Nothing + dR (LP p_ e_ r_ hr_) l_ hl_ = case spliceH l_ hl_ e_ r_ hr_ of UBT2(t,ht) -> dR p_ t ht + dR (RP p_ e_ l_ hl_) r_ hr_ = Just $! ZAVL p_ l_ hl_ e_ r_ hr_ +tryDelMoveL (ZAVL p (N ll le lr) hl _ r hr) = Just $! case popRN ll le lr of + UBT2(l,e) -> case l of + Z _ _ _ -> ZAVL p l DECINT1(hl) e r hr + N _ _ _ -> ZAVL p l hl e r hr + _ -> error "tryDelMoveL: Bug0" -- impossible +tryDelMoveL (ZAVL p (Z ll le lr) hl _ r hr) = Just $! case popRZ ll le lr of + UBT2(l,e) -> case l of + E -> ZAVL p l DECINT1(hl) e r hr -- Don't use E!! + N _ _ _ -> error "tryDelMoveL: Bug1" -- impossible + _ -> ZAVL p l hl e r hr +tryDelMoveL (ZAVL p (P ll le lr) hl _ r hr) = Just $! case popRP ll le lr of + UBT2(l,e) -> case l of + E -> error "tryDelMoveL: Bug2" -- impossible + Z _ _ _ -> ZAVL p l DECINT1(hl) e r hr + _ -> ZAVL p l hl e r hr + + +-- | Deletes the current element and moves one step right. +-- This function raises an error if the current element is already the rightmost element. +-- +-- Complexity: O(1) average, O(log n) worst case. +assertDelMoveR :: ZAVL e -> ZAVL e +assertDelMoveR (ZAVL p l hl _ E _ ) = dL p l hl + where dL EP _ _ = error "delMoveR: Can't move right." + dL (LP p_ e_ r_ hr_) l_ hl_ = ZAVL p_ l_ hl_ e_ r_ hr_ + dL (RP p_ e_ l_ hl_) r_ hr_ = case spliceH l_ hl_ e_ r_ hr_ of UBT2(t,ht) -> dL p_ t ht +assertDelMoveR (ZAVL p l hl _ (N rl re rr) hr) = case popLN rl re rr of + UBT2(e,r) -> case r of + E -> error "delMoveR: Bug0" -- impossible + Z _ _ _ -> ZAVL p l hl e r DECINT1(hr) + _ -> ZAVL p l hl e r hr +assertDelMoveR (ZAVL p l hl _ (Z rl re rr) hr) = case popLZ rl re rr of + UBT2(e,r) -> case r of + E -> ZAVL p l hl e r DECINT1(hr) -- Don't use E!! + P _ _ _ -> error "delMoveR: Bug1" -- impossible + _ -> ZAVL p l hl e r hr +assertDelMoveR (ZAVL p l hl _ (P rl re rr) hr) = case popLP rl re rr of + UBT2(e,r) -> case r of + Z _ _ _ -> ZAVL p l hl e r DECINT1(hr) + P _ _ _ -> ZAVL p l hl e r hr + _ -> error "delMoveR: Bug2" -- impossible + + +-- | Attempts to delete the current element and move one step right. +-- This function returns 'Nothing' if the current element is already the rightmost element. +-- +-- Complexity: O(1) average, O(log n) worst case. +tryDelMoveR :: ZAVL e -> Maybe (ZAVL e) +tryDelMoveR (ZAVL p l hl _ E _ ) = dL p l hl + where dL EP _ _ = Nothing + dL (LP p_ e_ r_ hr_) l_ hl_ = Just $! ZAVL p_ l_ hl_ e_ r_ hr_ + dL (RP p_ e_ l_ hl_) r_ hr_ = case spliceH l_ hl_ e_ r_ hr_ of UBT2(t,ht) -> dL p_ t ht +tryDelMoveR (ZAVL p l hl _ (N rl re rr) hr) = Just $! case popLN rl re rr of + UBT2(e,r) -> case r of + E -> error "tryDelMoveR: Bug0" -- impossible + Z _ _ _ -> ZAVL p l hl e r DECINT1(hr) + _ -> ZAVL p l hl e r hr +tryDelMoveR (ZAVL p l hl _ (Z rl re rr) hr) = Just $! case popLZ rl re rr of + UBT2(e,r) -> case r of + E -> ZAVL p l hl e r DECINT1(hr) -- Don't use E!! + P _ _ _ -> error "tryDelMoveR: Bug1" -- impossible + _ -> ZAVL p l hl e r hr +tryDelMoveR (ZAVL p l hl _ (P rl re rr) hr) = Just $! case popLP rl re rr of + UBT2(e,r) -> case r of + Z _ _ _ -> ZAVL p l hl e r DECINT1(hr) + P _ _ _ -> ZAVL p l hl e r hr + _ -> error "tryDelMoveR: Bug2" -- impossible + + +-- | Delete all elements to the left of the current element. +-- +-- Complexity: O(log n) +delAllL :: ZAVL e -> ZAVL e +delAllL (ZAVL p l hl e r hr) = + let hE = case COMPAREUINT hl hr of -- Calculate relative offset and use this as height of empty tree + LT -> SUBINT(hl,height l) + EQ -> SUBINT(hr,height r) + GT -> SUBINT(hr,height r) + p_ = noRP p -- remove right paths (current element becomes leftmost) + in p_ `seq` ZAVL p_ E hE e r hr + +-- | Delete all elements to the right of the current element. +-- +-- Complexity: O(log n) +delAllR :: ZAVL e -> ZAVL e +delAllR (ZAVL p l hl e r hr) = + let hE = case COMPAREUINT hl hr of -- Calculate relative offset and use this as height of empty tree + LT -> SUBINT(hl,height l) + EQ -> SUBINT(hl,height l) + GT -> SUBINT(hr,height r) + p_ = noLP p -- remove left paths (current element becomes rightmost) + in p_ `seq` ZAVL p_ l hl e E hE + +-- | Similar to 'delAllL', in that all elements to the left of the current element are deleted, +-- but this function also closes the tree in the process. +-- +-- Complexity: O(log n) +delAllCloseL :: ZAVL e -> AVL e +delAllCloseL (ZAVL p _ _ e r hr) = case pushHL e r hr of UBT2(t,ht) -> closeNoRP p t ht + +-- | Similar to 'delAllR', in that all elements to the right of the current element are deleted, +-- but this function also closes the tree in the process. +-- +-- Complexity: O(log n) +delAllCloseR :: ZAVL e -> AVL e +delAllCloseR (ZAVL p l hl e _ _) = case pushHR l hl e of UBT2(t,ht) -> closeNoLP p t ht + +-- | Similar to 'delAllCloseL', but in this case the current element and all +-- those to the left of the current element are deleted. +-- +-- Complexity: O(log n) +delAllIncCloseL :: ZAVL e -> AVL e +delAllIncCloseL (ZAVL p _ _ _ r hr) = closeNoRP p r hr + +-- | Similar to 'delAllCloseR', but in this case the current element and all +-- those to the right of the current element are deleted. +-- +-- Complexity: O(log n) +delAllIncCloseR :: ZAVL e -> AVL e +delAllIncCloseR (ZAVL p l hl _ _ _) = closeNoLP p l hl + +-- | Counts the number of elements to the left of the current element +-- (this does not include the current element). +-- +-- Complexity: O(n), where n is the count result. +sizeL :: ZAVL e -> Int +sizeL (ZAVL p l _ _ _ _) = addSizeRP (size l) p + +-- | Counts the number of elements to the right of the current element +-- (this does not include the current element). +-- +-- Complexity: O(n), where n is the count result. +sizeR :: ZAVL e -> Int +sizeR (ZAVL p _ _ _ r _) = addSizeLP (size r) p + +-- | Counts the total number of elements in a ZAVL. +-- +-- Complexity: O(n) +sizeZAVL :: ZAVL e -> Int +sizeZAVL (ZAVL p l _ _ r _) = addSizeP (addSize (addSize 1 l) r) p + + +{-------------------- BAVL stuff below ----------------------------------} + +-- | A 'BAVL' is like a pointer reference to somewhere inside an 'AVL' tree. It may be either \"full\" +-- (meaning it points to an actual tree node containing an element), or \"empty\" (meaning it +-- points to the position in a tree where an element was expected but wasn\'t found). +data BAVL e = BAVL (AVL e) (BinPath e) + +-- | Search for an element in a /sorted/ 'AVL' tree using the supplied selector. +-- Returns a \"full\" 'BAVL' if a matching element was found, otherwise returns an \"empty\" 'BAVL'. +-- +-- Complexity: O(log n) +genOpenBAVL :: (e -> Ordering) -> AVL e -> BAVL e +{-# INLINE genOpenBAVL #-} +genOpenBAVL c t = bp `seq` BAVL t bp + where bp = genOpenPath c t + +-- | Returns the original tree, extracted from the 'BAVL'. Typically you will not need this, as +-- the original tree will still be in scope in most cases. +-- +-- Complexity: O(1) +closeBAVL :: BAVL e -> AVL e +{-# INLINE closeBAVL #-} +closeBAVL (BAVL t _) = t + +-- | Returns 'True' if the 'BAVL' is \"full\" (a corresponding element was found). +-- +-- Complexity: O(1) +fullBAVL :: BAVL e -> Bool +{-# INLINE fullBAVL #-} +fullBAVL (BAVL _ (FullBP _ _)) = True +fullBAVL (BAVL _ (EmptyBP _ )) = False + +-- | Returns 'True' if the 'BAVL' is \"empty\" (no corresponding element was found). +-- +-- Complexity: O(1) +emptyBAVL :: BAVL e -> Bool +{-# INLINE emptyBAVL #-} +emptyBAVL (BAVL _ (FullBP _ _)) = False +emptyBAVL (BAVL _ (EmptyBP _ )) = True + +-- | Read the element value from a \"full\" 'BAVL'. +-- This function returns 'Nothing' if applied to an \"empty\" 'BAVL'. +-- +-- Complexity: O(1) +tryReadBAVL :: BAVL e -> Maybe e +{-# INLINE tryReadBAVL #-} +tryReadBAVL (BAVL _ (FullBP _ e)) = Just e +tryReadBAVL (BAVL _ (EmptyBP _ )) = Nothing + +-- | Read the element value from a \"full\" 'BAVL'. +-- This function raises an error if applied to an \"empty\" 'BAVL'. +-- +-- Complexity: O(1) +readFullBAVL :: BAVL e -> e +{-# INLINE readFullBAVL #-} +readFullBAVL (BAVL _ (FullBP _ e)) = e +readFullBAVL (BAVL _ (EmptyBP _ )) = error "readFullBAVL: Empty BAVL." + +-- | If the 'BAVL' is \"full\", this function returns the original tree with the corresponding +-- element replaced by the new element (first argument). If it\'s \"empty\" the original tree is returned +-- with the new element inserted. +-- +-- Complexity: O(log n) +pushBAVL :: e -> BAVL e -> AVL e +{-# INLINE pushBAVL #-} +pushBAVL e (BAVL t (FullBP p _)) = writePath p e t +pushBAVL e (BAVL t (EmptyBP p )) = insertPath p e t + +-- | If the 'BAVL' is \"full\", this function returns the original tree with the corresponding +-- element deleted. If it\'s \"empty\" the original tree is returned unmodified. +-- +-- Complexity: O(log n) (or O(1) for an empty 'BAVL') +deleteBAVL :: BAVL e -> AVL e +{-# INLINE deleteBAVL #-} +deleteBAVL (BAVL t (FullBP p _)) = deletePath p t +deleteBAVL (BAVL t (EmptyBP _ )) = t + +-- | Converts a \"full\" 'BAVL' as a 'ZAVL'. Raises an error if applied to an \"empty\" 'BAVL'. +-- +-- Complexity: O(log n) +fullBAVLtoZAVL :: BAVL e -> ZAVL e +fullBAVLtoZAVL (BAVL t (FullBP i _)) = openFull i EP L(0) t -- Relative heights !! +fullBAVLtoZAVL (BAVL _ (EmptyBP _ )) = error "fullBAVLtoZAVL: Empty BAVL." +-- Local Utility +openFull :: UINT -> (Path e) -> UINT -> AVL e -> ZAVL e +openFull _ _ _ E = error "openFull: Bug0." +openFull i p h (N l e r) = case sel i of + LT -> let p_ = LP p e r DECINT1(h) in p_ `seq` openFull (goL i) p_ DECINT2(h) l + EQ -> ZAVL p l DECINT2(h) e r DECINT1(h) + GT -> let p_ = RP p e l DECINT2(h) in p_ `seq` openFull (goR i) p_ DECINT1(h) r +openFull i p h (Z l e r) = case sel i of + LT -> let p_ = LP p e r DECINT1(h) in p_ `seq` openFull (goL i) p_ DECINT1(h) l + EQ -> ZAVL p l DECINT1(h) e r DECINT1(h) + GT -> let p_ = RP p e l DECINT1(h) in p_ `seq` openFull (goR i) p_ DECINT1(h) r +openFull i p h (P l e r) = case sel i of + LT -> let p_ = LP p e r DECINT2(h) in p_ `seq` openFull (goL i) p_ DECINT1(h) l + EQ -> ZAVL p l DECINT1(h) e r DECINT2(h) + GT -> let p_ = RP p e l DECINT1(h) in p_ `seq` openFull (goR i) p_ DECINT2(h) r + +-- | Converts an \"empty\" 'BAVL' as a 'PAVL'. Raises an error if applied to a \"full\" 'BAVL'. +-- +-- Complexity: O(log n) +emptyBAVLtoPAVL :: BAVL e -> PAVL e +emptyBAVLtoPAVL (BAVL _ (FullBP _ _)) = error "emptyBAVLtoPAVL: Full BAVL." +emptyBAVLtoPAVL (BAVL t (EmptyBP i )) = openEmpty i EP L(0) t -- Relative heights !! +-- Local Utility +openEmpty :: UINT -> (Path e) -> UINT -> AVL e -> PAVL e +openEmpty _ p h E = PAVL p h -- Test for i==0 ?? +openEmpty i p h (N l e r) = case sel i of + LT -> let p_ = LP p e r DECINT1(h) in p_ `seq` openEmpty (goL i) p_ DECINT2(h) l + EQ -> error "openEmpty: Bug0" + GT -> let p_ = RP p e l DECINT2(h) in p_ `seq` openEmpty (goR i) p_ DECINT1(h) r +openEmpty i p h (Z l e r) = case sel i of + LT -> let p_ = LP p e r DECINT1(h) in p_ `seq` openEmpty (goL i) p_ DECINT1(h) l + EQ -> error "openEmpty: Bug1" + GT -> let p_ = RP p e l DECINT1(h) in p_ `seq` openEmpty (goR i) p_ DECINT1(h) r +openEmpty i p h (P l e r) = case sel i of + LT -> let p_ = LP p e r DECINT2(h) in p_ `seq` openEmpty (goL i) p_ DECINT1(h) l + EQ -> error "openEmpty: Bug2" + GT -> let p_ = RP p e l DECINT1(h) in p_ `seq` openEmpty (goR i) p_ DECINT2(h) r + + +-- | Converts a 'BAVL' to either a 'PAVL' or 'ZAVL' (depending on whether it is \"empty\" or \"full\"). +-- +-- Complexity: O(log n) +anyBAVLtoEither :: BAVL e -> Either (PAVL e) (ZAVL e) +anyBAVLtoEither (BAVL t (FullBP i _)) = Right (openFull i EP L(0) t) -- Relative heights !! +anyBAVLtoEither (BAVL t (EmptyBP i )) = Left (openEmpty i EP L(0) t) -- Relative heights !! diff --git a/Data/Tree/AVLX.hs b/Data/Tree/AVLX.hs new file mode 100644 --- /dev/null +++ b/Data/Tree/AVLX.hs @@ -0,0 +1,42 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Data.Tree.AVLX +-- Copyright : (c) Adrian Hey 2004,2005,2006,2007 +-- License : BSD3 +-- +-- Maintainer : http://homepages.nildram.co.uk/~ahey/em.png +-- Stability : unstable +-- Portability : portable +-- +-- This module exports everything AVL, for test purposes only. +-- Not for general consumption. +----------------------------------------------------------------------------- +module Data.Tree.AVLX +(module Data.Tree.AVL -- The normal user AVL API +-- + Normally Hidden Modules +,module Data.Tree.AVL.Internals.HeightUtils +,module Data.Tree.AVL.Internals.DelUtils +,module Data.Tree.AVL.Internals.HPush +,module Data.Tree.AVL.Internals.HSet +,module Data.Tree.AVL.Internals.HAVL +,module Data.Tree.AVL.Internals.HJoin +,module Data.Tree.AVL.Internals.BinPath +,module Data.Tree.AVL.Test.Utils +,module Data.Tree.AVL.Test.Counter +,AVL(..) +) where + + +import Data.Tree.AVL hiding (AVL) +import Data.Tree.AVL.Types(AVL(..)) -- We want constructors exposed + +import Data.Tree.AVL.Internals.HeightUtils +import Data.Tree.AVL.Internals.DelUtils +import Data.Tree.AVL.Internals.HPush +import Data.Tree.AVL.Internals.HSet +import Data.Tree.AVL.Internals.HAVL +import Data.Tree.AVL.Internals.HJoin +import Data.Tree.AVL.Internals.BinPath +import Data.Tree.AVL.Test.Utils hiding (isBalanced,isSorted,isSortedOK,minElements,maxElements) +import Data.Tree.AVL.Test.Counter + diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,31 @@ +See the AUTHORS file for a list of copyright holders. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of the copyright holders nor the names of + other contributors may be used to endorse or promote products + derived from this software without specific prior written + permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,3 @@ +#!/usr/bin/runhaskell +import Distribution.Simple +main = defaultMain diff --git a/Test/Test.hs b/Test/Test.hs new file mode 100644 --- /dev/null +++ b/Test/Test.hs @@ -0,0 +1,6 @@ +-- Run me after installation to test AVL lib. +-- Takes a long time! +import Data.Tree.AVL.Test.AllTests(allTests) + +main :: IO () +main = allTests diff --git a/include/ghcdefs.h b/include/ghcdefs.h new file mode 100644 --- /dev/null +++ b/include/ghcdefs.h @@ -0,0 +1,25 @@ +#define UINT Int# +#define COMPAREUINT compareInt# +#define INCINT1(n) ((n)+#1#) +#define INCINT2(n) ((n)+#2#) +#define INCINT3(n) ((n)+#3#) +#define INCINT4(n) ((n)+#4#) +#define DECINT1(n) ((n)-#1#) +#define DECINT2(n) ((n)-#2#) +#define DECINT3(n) ((n)-#3#) +#define DECINT4(n) ((n)-#4#) +#define SUBINT(m,n) ((m)-#(n)) +#define ADDINT(m,n) ((m)+#(n)) +#define L(n) n# +#define LEQ <=# +#define LTN <# +#define EQL ==# +#define ASINT(n) (I# (n)) +#define NEGATE(n) (0#-#(n)) +#define _MODULO_(n,m) (modInt# n m) +#define UBT2(y,z) (# y,z #) +#define UBT3(x,y,z) (# x,y,z #) +#define UBT4(w,x,y,z) (# w,x,y,z #) +#define UBT5(v,w,x,y,z) (# v,w,x,y,z #) +#define IS_NEG(n) (n <# 0#) +#define LEFT_JUSTIFY_INT(m,n) (iShiftL# (m) (32#-#n)) diff --git a/include/h98defs.h b/include/h98defs.h new file mode 100644 --- /dev/null +++ b/include/h98defs.h @@ -0,0 +1,25 @@ +#define UINT Int +#define COMPAREUINT compare +#define INCINT1(n) ((n) + 1) +#define INCINT2(n) ((n) + 2) +#define INCINT3(n) ((n) + 3) +#define INCINT4(n) ((n) + 4) +#define DECINT1(n) ((n) - 1) +#define DECINT2(n) ((n) - 2) +#define DECINT3(n) ((n) - 3) +#define DECINT4(n) ((n) - 4) +#define SUBINT(m,n) ((m)- (n)) +#define ADDINT(m,n) ((m)+ (n)) +#define L(n) n +#define LEQ <= +#define LTN < +#define EQL == +#define ASINT(n) (n) +#define NEGATE(n) (0 - (n)) +#define _MODULO_(n,m) (n `mod` m) +#define UBT2(y,z) ( y,z ) +#define UBT3(x,y,z) ( x,y,z ) +#define UBT4(w,x,y,z) ( w,x,y,z ) +#define UBT5(v,w,x,y,z) ( v,w,x,y,z ) +#define IS_NEG(n) (n < 0) +#define LEFT_JUSTIFY_INT(m,n) (shiftL (m) (32-n))