{-# 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 -- -- This module defines functions for deleting elements from AVL trees and related -- utilities. ----------------------------------------------------------------------------- module Data.Tree.AVL.Delete (-- * Deleting. -- ** Deleting from extreme left or right. assertDelL,assertDelR,tryDelL,tryDelR, -- ** Deleting from /sorted/ trees. genDel,genDelFast,genDelIf,genDelMaybe, -- * Popping. -- | \"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 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 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