diff --git a/AvlTree.cabal b/AvlTree.cabal --- a/AvlTree.cabal +++ b/AvlTree.cabal @@ -1,5 +1,5 @@ Name: AvlTree -Version: 4.1 +Version: 4.2 Cabal-Version: >= 1.2 Build-Type: Simple License: BSD3 @@ -24,7 +24,7 @@ Library Buildable: True - Build-Depends: base, COrdering >= 2.2 + Build-Depends: base, COrdering >= 2.3 Exposed-Modules: Data.Tree.AVL, Data.Tree.AVL.Test.AllTests, Data.Tree.AVL.Test.Counter @@ -42,6 +42,7 @@ Data.Tree.AVL.Write, Data.Tree.AVL.Zipper, Data.Tree.AVL.BinPath, + Data.Tree.AVL.Deprecated, Data.Tree.AVL.Test.Utils, Data.Tree.AVL.Internals.DelUtils, Data.Tree.AVL.Internals.HAVL, diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -38,3 +38,10 @@ 4.1 --- * Added missing strictness to genVenn,genVennMaybe + +4.2 +--- +* A lot of function renaming (old names still available but deprecated). +* Gather all deprecations in 1 new module: Data.Tree.AVL.Deprecated +* Added findEmptyPath,nub,nubBy + diff --git a/Data/Tree/AVL.hs b/Data/Tree/AVL.hs --- a/Data/Tree/AVL.hs +++ b/Data/Tree/AVL.hs @@ -2,7 +2,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Data.Tree.AVL --- Copyright : (c) Adrian Hey 2004,2005 +-- Copyright : (c) Adrian Hey 2004,2008 -- License : BSD3 -- -- Maintainer : http://homepages.nildram.co.uk/~ahey/em.png @@ -36,31 +36,32 @@ ----------------------------------------------------------------------------- module Data.Tree.AVL (module Data.Tree.AVL.Types, - module Data.Tree.AVL.Size, - module Data.Tree.AVL.Height, 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, + module Data.Tree.AVL.Join, + module Data.Tree.AVL.List, + module Data.Tree.AVL.Split, + module Data.Tree.AVL.Size, + module Data.Tree.AVL.Height, + -- * Low level Binary Path utilities. + -- | This is the low level (unsafe) API used by the 'BAVL' type. + BinPath(..),findFullPath,findEmptyPath,openPath,openPathWith,readPath,writePath,insertPath,deletePath, + -- * Correctness checking. isBalanced,isSorted,isSortedOK, -- * Tree parameter utilities. minElements,maxElements, - -- * Low level Binary Path utilities. - -- | This is the low level (unsafe) API used by the 'BAVL' type. - BinPath(..),genFindPath,genOpenPath,genOpenPathWith,readPath,writePath,insertPath,deletePath, - + module Data.Tree.AVL.Deprecated, ) where -import Prelude -- so haddock finds the symbols there +import Prelude hiding (map) -- so haddock finds the symbols there import Data.Tree.AVL.Types hiding (E,N,P,Z) import Data.Tree.AVL.Size @@ -75,15 +76,14 @@ import Data.Tree.AVL.Set import Data.Tree.AVL.Zipper import Data.Tree.AVL.Test.Utils(isBalanced,isSorted,isSortedOK,minElements,maxElements) -import Data.Tree.AVL.BinPath(BinPath(..),genFindPath,genOpenPath,genOpenPathWith,readPath,writePath,insertPath) +import Data.Tree.AVL.BinPath(BinPath(..),findFullPath,findEmptyPath,openPath,openPathWith,readPath,writePath,insertPath) import Data.Tree.AVL.Internals.DelUtils(deletePath) - +import Data.Tree.AVL.Deprecated #if __GLASGOW_HASKELL__ > 604 import Data.Traversable -instance Traversable AVL where - traverse = traverseAVL #endif + {- These are now derived since switch to structural equality! -- | Show is based on showing the list produced by 'asListL'. This definition has been placed here -- to avoid introducing cyclic dependency between Types.hs and List.hs @@ -101,4 +101,9 @@ -- | 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. + fmap = map -- The lazy version. + +#if __GLASGOW_HASKELL__ > 604 +instance Traversable AVL where + traverse = traverseAVL +#endif diff --git a/Data/Tree/AVL/BinPath.hs b/Data/Tree/AVL/BinPath.hs --- a/Data/Tree/AVL/BinPath.hs +++ b/Data/Tree/AVL/BinPath.hs @@ -18,7 +18,7 @@ -- functions. ----------------------------------------------------------------------------- module Data.Tree.AVL.BinPath - (BinPath(..),genFindPath,genOpenPath,genOpenPathWith,readPath,writePath,insertPath, + (BinPath(..),findFullPath,findEmptyPath,openPath,openPathWith,readPath,writePath,insertPath, -- These are used by deletePath, which currently resides in Data.Tree.AVL.Internals.DelUtils sel,goL,goR, ) where @@ -126,9 +126,9 @@ -- | 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 +findFullPath :: (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 +findFullPath c t = find L(1) L(0) t where find _ _ E = L(-1) find d i (N l e r) = find' d i l e r find d i (Z l e r) = find' d i l e r @@ -138,11 +138,26 @@ EQ -> i GT -> let d_ = ADDINT(d,d) in find d_ ADDINT(i,d_) r -- d_ = 2d +-- | Find the path to a non-existant AVL tree element, returns -1 (invalid path) if element is found +-- +-- Complexity: O(log n) +findEmptyPath :: (e -> Ordering) -> AVL e -> UINT +-- ?? What about strictness if UINT is boxed (i.e. non-ghc)? +findEmptyPath c t = find L(1) L(0) t where + find _ i E = i + find d i (N l e r) = find' d i l e r + find d i (Z l e r) = find' d i l e r + find d i (P l e r) = find' d i l e r + find' d i l e r = case c e of + LT -> let d_ = ADDINT(d,d) in find d_ ADDINT(i,d ) l + EQ -> L(-1) + GT -> let d_ = ADDINT(d,d) in find d_ ADDINT(i,d_) r -- d_ = 2d + -- | Get the BinPath of an element using the supplied selector. -- -- Complexity: O(log n) -genOpenPath :: (e -> Ordering) -> AVL e -> BinPath e -genOpenPath c t = find L(1) L(0) t where +openPath :: (e -> Ordering) -> AVL e -> BinPath e +openPath c t = find L(1) L(0) t where find _ i E = EmptyBP i find d i (N l e r) = find' d i l e r find d i (Z l e r) = find' d i l e r @@ -155,8 +170,8 @@ -- | 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 +openPathWith :: (e -> COrdering a) -> AVL e -> BinPath a +openPathWith c t = find L(1) L(0) t where find _ i E = EmptyBP i find d i (N l e r) = find' d i l e r find d i (Z l e r) = find' d i l e r diff --git a/Data/Tree/AVL/Delete.hs b/Data/Tree/AVL/Delete.hs --- a/Data/Tree/AVL/Delete.hs +++ b/Data/Tree/AVL/Delete.hs @@ -16,7 +16,7 @@ delL,delR,assertDelL,assertDelR,tryDelL,tryDelR, -- ** Deleting from /sorted/ trees - genDel,genDelFast,genDelIf,genDelMaybe, + delete,deleteFast,deleteIf,deleteMaybe, -- * \"Popping\" elements from AVL trees -- | \"Popping\" means reading and deleting a tree element in a single operation. @@ -25,14 +25,14 @@ assertPopL,assertPopR,tryPopL,tryPopR, -- ** Popping from /sorted/ trees - genAssertPop,genTryPop,genAssertPopMaybe,genTryPopMaybe,genAssertPopIf,genTryPopIf, + assertPop,tryPop,assertPopMaybe,tryPopMaybe,assertPopIf,tryPopIf, ) where import Prelude -- so haddock finds the symbols there import Data.COrdering import Data.Tree.AVL.Types(AVL(..)) -import Data.Tree.AVL.BinPath(BinPath(..),genFindPath,genOpenPathWith,writePath) +import Data.Tree.AVL.BinPath(BinPath(..),findFullPath,openPathWith,writePath) import Data.Tree.AVL.Internals.DelUtils (-- Deleting Utilities @@ -160,19 +160,18 @@ -- 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 +delete :: (e -> Ordering) -> AVL e -> AVL e +delete c t = case findFullPath c t of + L(-1) -> t -- Not found, p<0 + p -> deletePath p t -- Found, so delete -- | This version only deletes the element if the supplied selector returns @('Eq' 'True')@. -- If it returns @('Eq' 'False')@ or if no matching element is found then this function returns -- the original tree. -- -- Complexity: O(log n) -genDelIf :: (e -> COrdering Bool) -> AVL e -> AVL e -genDelIf c t = case genOpenPathWith c t of +deleteIf :: (e -> COrdering Bool) -> AVL e -> AVL e +deleteIf c t = case openPathWith c t of FullBP p True -> deletePath p t _ -> t @@ -181,24 +180,24 @@ -- 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 +deleteMaybe :: (e -> COrdering (Maybe e)) -> AVL e -> AVL e +deleteMaybe c t = case openPathWith c t of FullBP p Nothing -> deletePath p t FullBP p (Just e) -> writePath p e t _ -> t --- | Functionally identical to 'genDel', but returns an identical tree (one with all the nodes on +-- | Functionally identical to 'delete', but returns an identical tree (one with all the nodes on -- the path duplicated) if the search fails. This should probably only be used if you know the -- search will succeed. -- -- Complexity: O(log n) -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 +deleteFast :: (e -> Ordering) -> AVL e -> AVL e +-- This was the old delete so it's been tested OK, but as a different name. +deleteFast c = delete' where + delete' E = E + delete' (N l e r) = delN l e r + delete' (Z l e r) = delZ l e r + delete' (P l e r) = delP l e r ----------------------------- LEVEL 1 --------------------------------- -- delN, delZ, delP -- @@ -317,7 +316,7 @@ EQ -> chkRP l e (subP rl rr) GT -> chkRP l e (delPR rl re rr) ----------------------------------------------------------------------- -------------------------- genDelFast Ends Here ------------------------ +------------------------- deleteFast Ends Here ------------------------ ----------------------------------------------------------------------- -- | General purpose function for popping elements from a sorted AVL tree. @@ -325,9 +324,9 @@ -- 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." +assertPop :: (e -> COrdering a) -> AVL e -> (a,AVL e) +assertPop c = genPop_ where + genPop_ E = error "assertPop: element not found." genPop_ (N l e r) = case popN l e r of UBT2(v,t) -> (v,t) genPop_ (Z l e r) = case popZ l e r of UBT2(v,t) -> (v,t) genPop_ (P l e r) = case popP l e r of UBT2(v,t) -> (v,t) @@ -360,7 +359,7 @@ ----------------------------------------------------------------------- -- Pop from the left subtree of (N l e r) - popNL E _ _ = error "genAssertPop: element not found." -- Left sub-tree is empty + popNL E _ _ = error "assertPop: element not found." -- Left sub-tree is empty popNL (N ll le lr) e r = case c le of Lt -> case popNL ll le lr of UBT2(a,l_) -> let t = chkLN l_ e r in t `seq` UBT2(a,t) @@ -400,7 +399,7 @@ 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 E _ _ = error "assertPop: element not found." -- Left sub-tree is empty popZL (N ll le lr) e r = case c le of Lt -> case popNL ll le lr of UBT2(a,l_) -> let t = chkLZ l_ e r in t `seq` UBT2(a,t) @@ -420,7 +419,7 @@ 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 _ _ E = error "assertPop: element not found." -- Right sub-tree is empty popZR l e (N rl re rr) = case c re of Lt -> case popNL rl re rr of UBT2(a,r_) -> let t = chkRZ l e r_ in t `seq` UBT2(a,t) @@ -460,7 +459,7 @@ 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 _ _ E = error "assertPop: element not found." -- Right sub-tree is empty popPR l e (N rl re rr) = case c re of Lt -> case popNL rl re rr of UBT2(a,r_) -> let t = chkRP l e r_ in t `seq` UBT2(a,t) @@ -479,14 +478,14 @@ 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 ----------------------- +------------------------ assertPop 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 +tryPop :: (e -> COrdering a) -> AVL e -> Maybe (a,AVL e) +tryPop c t = case openPathWith c t of FullBP pth a -> let t' = deletePath pth t in t' `seq` Just (a,t') _ -> Nothing @@ -496,38 +495,38 @@ -- 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 +assertPopMaybe :: (e -> COrdering (a,Maybe e)) -> AVL e -> (a,AVL e) +assertPopMaybe c t = case openPathWith c t of FullBP pth (a,Just e ) -> let t' = writePath pth e t in t' `seq` (a,t') FullBP pth (a,Nothing) -> let t' = deletePath pth t in t' `seq` (a,t') - _ -> error "genAssertPopMaybe: element not found." + _ -> error "assertPopMaybe: element not found." --- | Similar to 'genAssertPopMaybe', but returns 'Nothing' if the search fails. +-- | Similar to 'assertPopMaybe', 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 +tryPopMaybe :: (e -> COrdering (a,Maybe e)) -> AVL e -> Maybe (a,AVL e) +tryPopMaybe c t = case openPathWith c t of FullBP pth (a,Just e ) -> let t' = writePath pth e t in t' `seq` Just (a,t') FullBP pth (a,Nothing) -> let t' = deletePath pth t in t' `seq` Just (a,t') _ -> Nothing --- | A simpler version of 'genAssertPopMaybe'. The corresponding element is deleted if the second value +-- | A simpler version of 'assertPopMaybe'. The corresponding element is deleted if the second value -- returned by the selector is 'True'. If it\'s 'False', the original tree is returned. -- This function raises an error if the search fails. -- -- Complexity: O(log n) -genAssertPopIf :: (e -> COrdering (a,Bool)) -> AVL e -> (a,AVL e) -genAssertPopIf c t = case genOpenPathWith c t of +assertPopIf :: (e -> COrdering (a,Bool)) -> AVL e -> (a,AVL e) +assertPopIf c t = case openPathWith c t of FullBP _ (a,False) -> (a,t) FullBP pth (a,True ) -> let t' = deletePath pth t in t' `seq` (a,t') - _ -> error "genAssertPopIf: element not found." + _ -> error "assertPopIf: 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 +tryPopIf :: (e -> COrdering (a,Bool)) -> AVL e -> Maybe (a,AVL e) +tryPopIf c t = case openPathWith c t of FullBP _ (a,False) -> Just (a,t) FullBP pth (a,True ) -> let t' = deletePath pth t in t' `seq` Just (a,t') _ -> Nothing diff --git a/Data/Tree/AVL/Deprecated.hs b/Data/Tree/AVL/Deprecated.hs new file mode 100644 --- /dev/null +++ b/Data/Tree/AVL/Deprecated.hs @@ -0,0 +1,683 @@ +{-# OPTIONS_GHC -fglasgow-exts #-} +----------------------------------------------------------------------------- +-- | +-- Module : Data.Tree.AVL.Deprecated +-- Copyright : (c) Adrian Hey 2004,2008 +-- License : BSD3 +-- +-- Maintainer : http://homepages.nildram.co.uk/~ahey/em.png +-- Stability : unstable +-- Portability : portable +----------------------------------------------------------------------------- +module Data.Tree.AVL.Deprecated +(-- * Deprecated + + -- ** Deprecated names + -- | These functions are all still available, but with more sensible names. + -- They will dissapear on the next major version so you should amend your code + -- accordingly soon. + + genUnion,genUnionMaybe,genDisjointUnion,genUnions, + genDifference,genDifferenceMaybe,genSymDifference, + genIntersection,genIntersectionMaybe, + genIntersectionToListL,genIntersectionAsListL, + genIntersectionMaybeToListL,genIntersectionMaybeAsListL, + genVenn,genVennMaybe, + genVennToList,genVennAsList, + genVennMaybeToList,genVennMaybeAsList, + genIsSubsetOf,genIsSubsetOfBy, + + genAssertRead,genTryRead,genTryReadMaybe,genDefaultRead,genContains, + + genWrite,genWriteFast,genTryWrite,genWriteMaybe,genTryWriteMaybe, + + genDel,genDelFast,genDelIf,genDelMaybe, + genAssertPop,genTryPop,genAssertPopMaybe,genTryPopMaybe,genAssertPopIf,genTryPopIf, + + genPush,genPush',genPushMaybe,genPushMaybe', + + genAsTree, + + genForkL,genForkR,genFork, + genTakeLE,genDropGT, + genTakeLT,genDropGE, + genTakeGT,genDropLE, + genTakeGE,genDropLT, + + genAssertOpen,genTryOpen, + genTryOpenGE,genTryOpenLE, + genOpenEither, + genOpenBAVL, + + genFindPath,genOpenPath,genOpenPathWith, + + fastAddSize, + + reverseAVL,mapAVL,mapAVL', + mapAccumLAVL ,mapAccumRAVL , + mapAccumLAVL' ,mapAccumRAVL' , +#ifdef __GLASGOW_HASKELL__ + mapAccumLAVL'',mapAccumRAVL'', +#endif + replicateAVL, + filterAVL,mapMaybeAVL, + partitionAVL, + foldrAVL,foldrAVL',foldr1AVL,foldr1AVL',foldr2AVL,foldr2AVL', + foldlAVL,foldlAVL',foldl1AVL,foldl1AVL',foldl2AVL,foldl2AVL', + foldrAVL_UINT, + + findPath, + +{- + -- ** Deprecated functions + -- | Any functions listed here are deprecated, with no direct replacement. + -- They will continue to live \"forever\" here, but should not be used + -- (ideally). +-} + +) where + +import Prelude hiding (reverse,map,replicate,filter,foldr,foldr1,foldl,foldl1) -- so haddock finds the symbols there + +import Data.COrdering(COrdering) +import Data.Tree.AVL.Types(AVL) +import Data.Tree.AVL.Set +import Data.Tree.AVL.Read +import Data.Tree.AVL.Write +import Data.Tree.AVL.Delete +import Data.Tree.AVL.Push +import Data.Tree.AVL.Split +import Data.Tree.AVL.List +import Data.Tree.AVL.Zipper +import Data.Tree.AVL.BinPath +import Data.Tree.AVL.Size + +#ifdef __GLASGOW_HASKELL__ +import GHC.Base(Int#) +#include "ghcdefs.h" +#else +#include "h98defs.h" +#endif + +{-# DEPRECATED genUnion "This is now called union." #-} +-- | This name is /deprecated/. Instead use 'union'. +genUnion :: (e -> e -> COrdering e) -> AVL e -> AVL e -> AVL e +genUnion = union +{-# INLINE genUnion #-} + +{-# DEPRECATED genUnionMaybe "This is now called unionMaybe." #-} +-- | This name is /deprecated/. Instead use 'unionMaybe'. +genUnionMaybe :: (e -> e -> COrdering (Maybe e)) -> AVL e -> AVL e -> AVL e +genUnionMaybe = unionMaybe +{-# INLINE genUnionMaybe #-} + +{-# DEPRECATED genDisjointUnion "This is now called disjointUnion." #-} +-- | This name is /deprecated/. Instead use 'disjointUnion'. +genDisjointUnion :: (e -> e -> Ordering) -> AVL e -> AVL e -> AVL e +genDisjointUnion = disjointUnion +{-# INLINE genDisjointUnion #-} + +{-# DEPRECATED genUnions "This is now called unions." #-} +-- | This name is /deprecated/. Instead use 'unions'. +genUnions :: (e -> e -> COrdering e) -> [AVL e] -> AVL e +genUnions = unions +{-# INLINE genUnions #-} + +{-# DEPRECATED genDifference "This is now called difference." #-} +-- | This name is /deprecated/. Instead use 'difference'. +genDifference :: (a -> b -> Ordering) -> AVL a -> AVL b -> AVL a +genDifference = difference +{-# INLINE genDifference #-} + +{-# DEPRECATED genDifferenceMaybe "This is now called differenceMaybe." #-} +-- | This name is /deprecated/. Instead use 'differenceMaybe'. +genDifferenceMaybe :: (a -> b -> COrdering (Maybe a)) -> AVL a -> AVL b -> AVL a +genDifferenceMaybe = differenceMaybe +{-# INLINE genDifferenceMaybe #-} + +{-# DEPRECATED genSymDifference "This is now called symDifference." #-} +-- | This name is /deprecated/. Instead use 'symDifference'. +genSymDifference :: (e -> e -> Ordering) -> AVL e -> AVL e -> AVL e +genSymDifference = symDifference +{-# INLINE genSymDifference #-} + +{-# DEPRECATED genIntersection "This is now called intersection." #-} +-- | This name is /deprecated/. Instead use 'intersection'. +genIntersection :: (a -> b -> COrdering c) -> AVL a -> AVL b -> AVL c +genIntersection = intersection +{-# INLINE genIntersection #-} + +{-# DEPRECATED genIntersectionMaybe "This is now called intersectionMaybe." #-} +-- | This name is /deprecated/. Instead use 'intersectionMaybe'. +genIntersectionMaybe :: (a -> b -> COrdering (Maybe c)) -> AVL a -> AVL b -> AVL c +genIntersectionMaybe = intersectionMaybe +{-# INLINE genIntersectionMaybe #-} + +{-# DEPRECATED genIntersectionToListL "This is now called intersectionToList." #-} +-- | This name is /deprecated/. Instead use 'intersectionToList'. +genIntersectionToListL :: (a -> b -> COrdering c) -> AVL a -> AVL b -> [c] -> [c] +genIntersectionToListL = intersectionToList +{-# INLINE genIntersectionToListL #-} + +{-# DEPRECATED genIntersectionAsListL "This is now called intersectionAsList." #-} +-- | This name is /deprecated/. Instead use 'intersectionAsList'. +genIntersectionAsListL :: (a -> b -> COrdering c) -> AVL a -> AVL b -> [c] +genIntersectionAsListL = intersectionAsList +{-# INLINE genIntersectionAsListL #-} + +{-# DEPRECATED genIntersectionMaybeToListL "This is now called intersectionMaybeToList." #-} +-- | This name is /deprecated/. Instead use 'intersectionMaybeToList'. +genIntersectionMaybeToListL :: (a -> b -> COrdering (Maybe c)) -> AVL a -> AVL b -> [c] -> [c] +genIntersectionMaybeToListL = intersectionMaybeToList +{-# INLINE genIntersectionMaybeToListL #-} + +{-# DEPRECATED genIntersectionMaybeAsListL "This is now called intersectionMaybeAsList." #-} +-- | This name is /deprecated/. Instead use 'intersectionMaybeAsList'. +genIntersectionMaybeAsListL :: (a -> b -> COrdering (Maybe c)) -> AVL a -> AVL b -> [c] +genIntersectionMaybeAsListL = intersectionMaybeAsList +{-# INLINE genIntersectionMaybeAsListL #-} + +{-# DEPRECATED genVenn "This is now called venn." #-} +-- | This name is /deprecated/. Instead use 'venn'. +genVenn :: (a -> b -> COrdering c) -> AVL a -> AVL b -> (AVL a, AVL c, AVL b) +genVenn = venn +{-# INLINE genVenn #-} + +{-# DEPRECATED genVennMaybe "This is now called vennMaybe." #-} +-- | This name is /deprecated/. Instead use 'vennMaybe'. +genVennMaybe :: (a -> b -> COrdering (Maybe c)) -> AVL a -> AVL b -> (AVL a, AVL c, AVL b) +genVennMaybe = vennMaybe +{-# INLINE genVennMaybe #-} + +{-# DEPRECATED genVennToList "This is now called vennToList." #-} +-- | This name is /deprecated/. Instead use 'vennToList'. +genVennToList :: (a -> b -> COrdering c) -> [c] -> AVL a -> AVL b -> (AVL a, [c], AVL b) +genVennToList = vennToList +{-# INLINE genVennToList #-} + +{-# DEPRECATED genVennAsList "This is now called vennAsList." #-} +-- | This name is /deprecated/. Instead use 'vennAsList'. +genVennAsList :: (a -> b -> COrdering c) -> AVL a -> AVL b -> (AVL a, [c], AVL b) +genVennAsList = vennAsList +{-# INLINE genVennAsList #-} + +{-# DEPRECATED genVennMaybeToList "This is now called vennMaybeToList." #-} +-- | This name is /deprecated/. Instead use 'vennMaybeToList'. +genVennMaybeToList :: (a -> b -> COrdering (Maybe c)) -> [c] -> AVL a -> AVL b -> (AVL a, [c], AVL b) +genVennMaybeToList = vennMaybeToList +{-# INLINE genVennMaybeToList #-} + +{-# DEPRECATED genVennMaybeAsList "This is now called vennMaybeAsList." #-} +-- | This name is /deprecated/. Instead use 'vennMaybeAsList'. +genVennMaybeAsList :: (a -> b -> COrdering (Maybe c)) -> AVL a -> AVL b -> (AVL a, [c], AVL b) +genVennMaybeAsList = vennMaybeAsList +{-# INLINE genVennMaybeAsList #-} + +{-# DEPRECATED genIsSubsetOf "This is now called isSubsetOf." #-} +-- | This name is /deprecated/. Instead use 'isSubsetOf'. +genIsSubsetOf :: (a -> b -> Ordering) -> AVL a -> AVL b -> Bool +genIsSubsetOf = isSubsetOf +{-# INLINE genIsSubsetOf #-} + +{-# DEPRECATED genIsSubsetOfBy "This is now called isSubsetOfBy." #-} +-- | This name is /deprecated/. Instead use 'isSubsetOfBy'. +genIsSubsetOfBy :: (a -> b -> COrdering Bool) -> AVL a -> AVL b -> Bool +genIsSubsetOfBy = isSubsetOfBy +{-# INLINE genIsSubsetOfBy #-} + +{-# DEPRECATED genAssertRead "This is now called assertRead." #-} +-- | This name is /deprecated/. Instead use 'assertRead'. +genAssertRead :: AVL e -> (e -> COrdering a) -> a +genAssertRead = assertRead +{-# INLINE genAssertRead #-} + +{-# DEPRECATED genTryRead "This is now called tryRead." #-} +-- | This name is /deprecated/. Instead use 'tryRead'. +genTryRead :: AVL e -> (e -> COrdering a) -> Maybe a +genTryRead = tryRead +{-# INLINE genTryRead #-} + +{-# DEPRECATED genTryReadMaybe "This is now called tryReadMaybe." #-} +-- | This name is /deprecated/. Instead use 'tryReadMaybe'. +genTryReadMaybe :: AVL e -> (e -> COrdering (Maybe a)) -> Maybe a +genTryReadMaybe = tryReadMaybe +{-# INLINE genTryReadMaybe #-} + +{-# DEPRECATED genDefaultRead "This is now called defaultRead." #-} +-- | This name is /deprecated/. Instead use 'defaultRead'. +genDefaultRead :: a -> AVL e -> (e -> COrdering a) -> a +genDefaultRead = defaultRead +{-# INLINE genDefaultRead #-} + +{-# DEPRECATED genContains "This is now called contains." #-} +-- | This name is /deprecated/. Instead use 'contains'. +genContains :: AVL e -> (e -> Ordering) -> Bool +genContains = contains +{-# INLINE genContains #-} + +{-# DEPRECATED genWrite "This is now called write." #-} +-- | This name is /deprecated/. Instead use 'write'. +genWrite :: (e -> COrdering e) -> AVL e -> AVL e +genWrite = write +{-# INLINE genWrite #-} + +{-# DEPRECATED genWriteFast "This is now called writeFast." #-} +-- | This name is /deprecated/. Instead use 'writeFast'. +genWriteFast :: (e -> COrdering e) -> AVL e -> AVL e +genWriteFast = writeFast +{-# INLINE genWriteFast #-} + +{-# DEPRECATED genTryWrite "This is now called tryWrite." #-} +-- | This name is /deprecated/. Instead use 'tryWrite'. +genTryWrite :: (e -> COrdering e) -> AVL e -> Maybe (AVL e) +genTryWrite = tryWrite +{-# INLINE genTryWrite #-} + +{-# DEPRECATED genWriteMaybe "This is now called writeMaybe." #-} +-- | This name is /deprecated/. Instead use 'writeMaybe'. +genWriteMaybe :: (e -> COrdering (Maybe e)) -> AVL e -> AVL e +genWriteMaybe = writeMaybe +{-# INLINE genWriteMaybe #-} + +{-# DEPRECATED genTryWriteMaybe "This is now called tryWriteMaybe." #-} +-- | This name is /deprecated/. Instead use 'tryWriteMaybe'. +genTryWriteMaybe :: (e -> COrdering (Maybe e)) -> AVL e -> Maybe (AVL e) +genTryWriteMaybe = tryWriteMaybe +{-# INLINE genTryWriteMaybe #-} + +{-# DEPRECATED genDel "This is now called delete." #-} +-- | This name is /deprecated/. Instead use 'delete'. +genDel :: (e -> Ordering) -> AVL e -> AVL e +genDel = delete +{-# INLINE genDel #-} + +{-# DEPRECATED genDelFast "This is now called deleteFast." #-} +-- | This name is /deprecated/. Instead use 'deleteFast'. +genDelFast :: (e -> Ordering) -> AVL e -> AVL e +genDelFast = deleteFast +{-# INLINE genDelFast #-} + +{-# DEPRECATED genDelIf "This is now called deleteIf." #-} +-- | This name is /deprecated/. Instead use 'deleteIf'. +genDelIf :: (e -> COrdering Bool) -> AVL e -> AVL e +genDelIf = deleteIf +{-# INLINE genDelIf #-} + +{-# DEPRECATED genDelMaybe "This is now called deleteMaybe." #-} +-- | This name is /deprecated/. Instead use 'deleteMaybe'. +genDelMaybe :: (e -> COrdering (Maybe e)) -> AVL e -> AVL e +genDelMaybe = deleteMaybe +{-# INLINE genDelMaybe #-} + +{-# DEPRECATED genAssertPop "This is now called assertPop." #-} +-- | This name is /deprecated/. Instead use 'assertPop'. +genAssertPop :: (e -> COrdering a) -> AVL e -> (a,AVL e) +genAssertPop = assertPop +{-# INLINE genAssertPop #-} + +{-# DEPRECATED genTryPop "This is now called tryPop." #-} +-- | This name is /deprecated/. Instead use 'tryPop'. +genTryPop :: (e -> COrdering a) -> AVL e -> Maybe (a,AVL e) +genTryPop = tryPop +{-# INLINE genTryPop #-} + +{-# DEPRECATED genAssertPopMaybe "This is now called assertPopMaybe." #-} +-- | This name is /deprecated/. Instead use 'assertPopMaybe'. +genAssertPopMaybe :: (e -> COrdering (a,Maybe e)) -> AVL e -> (a,AVL e) +genAssertPopMaybe = assertPopMaybe +{-# INLINE genAssertPopMaybe #-} + +{-# DEPRECATED genTryPopMaybe "This is now called tryPopMaybe." #-} +-- | This name is /deprecated/. Instead use 'tryPopMaybe'. +genTryPopMaybe :: (e -> COrdering (a,Maybe e)) -> AVL e -> Maybe (a,AVL e) +genTryPopMaybe = tryPopMaybe +{-# INLINE genTryPopMaybe #-} + +{-# DEPRECATED genAssertPopIf "This is now called assertPopIf." #-} +-- | This name is /deprecated/. Instead use 'assertPopIf'. +genAssertPopIf :: (e -> COrdering (a,Bool)) -> AVL e -> (a,AVL e) +genAssertPopIf = assertPopIf +{-# INLINE genAssertPopIf #-} + +{-# DEPRECATED genTryPopIf "This is now called tryPopIf." #-} +-- | This name is /deprecated/. Instead use 'tryPopIf'. +genTryPopIf :: (e -> COrdering (a,Bool)) -> AVL e -> Maybe (a,AVL e) +genTryPopIf = tryPopIf +{-# INLINE genTryPopIf #-} + +{-# DEPRECATED genPush "This is now called push." #-} +-- | This name is /deprecated/. Instead use 'push'. +genPush :: (e -> COrdering e) -> e -> AVL e -> AVL e +genPush = push +{-# INLINE genPush #-} + +{-# DEPRECATED genPush' "This is now called push'." #-} +-- | This name is /deprecated/. Instead use ' push''. +genPush' :: (e -> COrdering e) -> e -> AVL e -> AVL e +genPush' = push' +{-# INLINE genPush' #-} + +{-# DEPRECATED genPushMaybe "This is now called pushMaybe." #-} +-- | This name is /deprecated/. Instead use 'pushMaybe'. +genPushMaybe :: (e -> COrdering (Maybe e)) -> e -> AVL e -> AVL e +genPushMaybe = pushMaybe +{-# INLINE genPushMaybe #-} + +{-# DEPRECATED genPushMaybe' "This is now called pushMaybe'." #-} +-- | This name is /deprecated/. Instead use 'pushMaybe''. +genPushMaybe' :: (e -> COrdering (Maybe e)) -> e -> AVL e -> AVL e +genPushMaybe' = pushMaybe' +{-# INLINE genPushMaybe' #-} + +{-# DEPRECATED genAsTree "This is now called asTree." #-} +-- | This name is /deprecated/. Instead use 'asTree'. +genAsTree :: (e -> e -> COrdering e) -> [e] -> AVL e +genAsTree = asTree +{-# INLINE genAsTree #-} + +{-# DEPRECATED genForkL "This is now called forkL." #-} +-- | This name is /deprecated/. Instead use 'forkL'. +genForkL :: (e -> Ordering) -> AVL e -> (AVL e, AVL e) +genForkL = forkL +{-# INLINE genForkL #-} + +{-# DEPRECATED genForkR "This is now called forkR." #-} +-- | This name is /deprecated/. Instead use 'forkR'. +genForkR :: (e -> Ordering) -> AVL e -> (AVL e, AVL e) +genForkR = forkR +{-# INLINE genForkR #-} + +{-# DEPRECATED genFork "This is now called fork." #-} +-- | This name is /deprecated/. Instead use 'fork'. +genFork :: (e -> COrdering a) -> AVL e -> (AVL e, Maybe a, AVL e) +genFork = fork +{-# INLINE genFork #-} + +{-# DEPRECATED genTakeLE "This is now called takeLE." #-} +-- | This name is /deprecated/. Instead use 'takeLE'. +genTakeLE :: (e -> Ordering) -> AVL e -> AVL e +genTakeLE = takeLE +{-# INLINE genTakeLE #-} + +{-# DEPRECATED genDropGT "This is now called dropGT." #-} +-- | This name is /deprecated/. Instead use 'dropGT'. +genDropGT :: (e -> Ordering) -> AVL e -> AVL e +genDropGT = dropGT +{-# INLINE genDropGT #-} + +{-# DEPRECATED genTakeLT "This is now called takeLT." #-} +-- | This name is /deprecated/. Instead use 'takeLT'. +genTakeLT :: (e -> Ordering) -> AVL e -> AVL e +genTakeLT = takeLT +{-# INLINE genTakeLT #-} + +{-# DEPRECATED genDropGE "This is now called dropGE." #-} +-- | This name is /deprecated/. Instead use 'dropGE'. +genDropGE :: (e -> Ordering) -> AVL e -> AVL e +genDropGE = dropGE +{-# INLINE genDropGE #-} + +{-# DEPRECATED genTakeGT "This is now called takeGT." #-} +-- | This name is /deprecated/. Instead use 'takeGT'. +genTakeGT :: (e -> Ordering) -> AVL e -> AVL e +genTakeGT = takeGT +{-# INLINE genTakeGT #-} + +{-# DEPRECATED genDropLE "This is now called dropLE." #-} +-- | This name is /deprecated/. Instead use 'dropLE'. +genDropLE :: (e -> Ordering) -> AVL e -> AVL e +genDropLE = dropLE +{-# INLINE genDropLE #-} + +{-# DEPRECATED genTakeGE "This is now called takeGE." #-} +-- | This name is /deprecated/. Instead use 'takeGE'. +genTakeGE :: (e -> Ordering) -> AVL e -> AVL e +genTakeGE = takeGE +{-# INLINE genTakeGE #-} + +{-# DEPRECATED genDropLT "This is now called dropLT." #-} +-- | This name is /deprecated/. Instead use 'dropLT'. +genDropLT :: (e -> Ordering) -> AVL e -> AVL e +genDropLT = dropLT +{-# INLINE genDropLT #-} + +{-# DEPRECATED genAssertOpen "This is now called assertOpen." #-} +-- | This name is /deprecated/. Instead use 'assertOpen'. +genAssertOpen :: (e -> Ordering) -> AVL e -> ZAVL e +genAssertOpen = assertOpen +{-# INLINE genAssertOpen #-} + +{-# DEPRECATED genTryOpen "This is now called tryOpen." #-} +-- | This name is /deprecated/. Instead use 'tryOpen'. +genTryOpen :: (e -> Ordering) -> AVL e -> Maybe (ZAVL e) +genTryOpen = tryOpen +{-# INLINE genTryOpen #-} + +{-# DEPRECATED genTryOpenGE "This is now called tryOpenGE." #-} +-- | This name is /deprecated/. Instead use 'tryOpenGE'. +genTryOpenGE :: (e -> Ordering) -> AVL e -> Maybe (ZAVL e) +genTryOpenGE = tryOpenGE +{-# INLINE genTryOpenGE #-} + +{-# DEPRECATED genTryOpenLE "This is now called tryOpenLE." #-} +-- | This name is /deprecated/. Instead use 'tryOpenLE'. +genTryOpenLE :: (e -> Ordering) -> AVL e -> Maybe (ZAVL e) +genTryOpenLE = tryOpenLE +{-# INLINE genTryOpenLE #-} + +{-# DEPRECATED genOpenEither "This is now called openEither." #-} +-- | This name is /deprecated/. Instead use 'openEither'. +genOpenEither :: (e -> Ordering) -> AVL e -> Either (PAVL e) (ZAVL e) +genOpenEither = openEither +{-# INLINE genOpenEither #-} + +{-# DEPRECATED genOpenBAVL "This is now called openBAVL." #-} +-- | This name is /deprecated/. Instead use 'openBAVL'. +genOpenBAVL :: (e -> Ordering) -> AVL e -> BAVL e +genOpenBAVL = openBAVL +{-# INLINE genOpenBAVL #-} + +{-# DEPRECATED genFindPath "This is now called findPath." #-} +-- | This name is /deprecated/. Instead use 'findPath'. +genFindPath :: (e -> Ordering) -> AVL e -> UINT +genFindPath = findPath +{-# INLINE genFindPath #-} + +{-# DEPRECATED genOpenPath "This is now called openPath." #-} +-- | This name is /deprecated/. Instead use 'openPath'. +genOpenPath :: (e -> Ordering) -> AVL e -> BinPath e +genOpenPath = openPath +{-# INLINE genOpenPath #-} + +{-# DEPRECATED genOpenPathWith "This is now called openPathWith." #-} +-- | This name is /deprecated/. Instead use 'openPathWith'. +genOpenPathWith :: (e -> COrdering a) -> AVL e -> BinPath a +genOpenPathWith = openPathWith +{-# INLINE genOpenPathWith #-} + +{-# DEPRECATED fastAddSize "Use addSize or addSize#." #-} +-- | This name is /deprecated/. Instead use 'addSize' or 'addSize#'. +fastAddSize :: UINT -> AVL e -> UINT +#ifdef __GLASGOW_HASKELL__ +fastAddSize = addSize# +#else +fastAddSize = addSize +#endif +{-# INLINE fastAddSize #-} + + + +{-# DEPRECATED reverseAVL "This is now called reverse." #-} +-- | This name is /deprecated/. Instead use 'reverse'. +reverseAVL :: AVL e -> AVL e +reverseAVL = reverse +{-# INLINE reverseAVL #-} + +{-# DEPRECATED mapAVL "This is now called map." #-} +-- | This name is /deprecated/. Instead use 'map'. +mapAVL :: (a -> b) -> AVL a -> AVL b +mapAVL = map +{-# INLINE mapAVL #-} + +{-# DEPRECATED mapAVL' "This is now called map'." #-} +-- | This name is /deprecated/. Instead use 'map''. +mapAVL' :: (a -> b) -> AVL a -> AVL b +mapAVL' = map' +{-# INLINE mapAVL' #-} + +{-# DEPRECATED mapAccumLAVL "This is now called mapAccumL." #-} +-- | This name is /deprecated/. Instead use 'mapAccumL'. +mapAccumLAVL :: (z -> a -> (z, b)) -> z -> AVL a -> (z, AVL b) +mapAccumLAVL = mapAccumL +{-# INLINE mapAccumLAVL #-} + +{-# DEPRECATED mapAccumRAVL "This is now called mapAccumR." #-} +-- | This name is /deprecated/. Instead use 'mapAccumR'. +mapAccumRAVL :: (z -> a -> (z, b)) -> z -> AVL a -> (z, AVL b) +mapAccumRAVL = mapAccumR +{-# INLINE mapAccumRAVL #-} + +{-# DEPRECATED mapAccumLAVL' "This is now called mapAccumL'." #-} +-- | This name is /deprecated/. Instead use 'mapAccumL''. +mapAccumLAVL' :: (z -> a -> (z, b)) -> z -> AVL a -> (z, AVL b) +mapAccumLAVL' = mapAccumL' +{-# INLINE mapAccumLAVL' #-} + +{-# DEPRECATED mapAccumRAVL' "This is now called mapAccumR'." #-} +-- | This name is /deprecated/. Instead use 'mapAccumR''. +mapAccumRAVL' :: (z -> a -> (z, b)) -> z -> AVL a -> (z, AVL b) +mapAccumRAVL' = mapAccumR' +{-# INLINE mapAccumRAVL' #-} + +#ifdef __GLASGOW_HASKELL__ +{-# DEPRECATED mapAccumLAVL'' "This is now called mapAccumL''." #-} +-- | This name is /deprecated/. Instead use 'mapAccumL'''. +mapAccumLAVL'' + :: (z -> a -> UBT2(z, b)) -> z -> AVL a -> (z, AVL b) +mapAccumLAVL'' = mapAccumL'' +{-# INLINE mapAccumLAVL'' #-} + +{-# DEPRECATED mapAccumRAVL'' "This is now called mapAccumR''." #-} +-- | This name is /deprecated/. Instead use 'mapAccumR'''. +mapAccumRAVL'' + :: (z -> a -> UBT2(z, b)) -> z -> AVL a -> (z, AVL b) +mapAccumRAVL'' = mapAccumR'' +{-# INLINE mapAccumRAVL'' #-} + +{-# DEPRECATED foldrAVL_UINT "This is now called foldrInt#." #-} +-- | This name is /deprecated/. Instead use 'foldrInt#'. +foldrAVL_UINT :: (e -> UINT -> UINT) -> UINT -> AVL e -> UINT +foldrAVL_UINT = foldrInt# +{-# INLINE foldrAVL_UINT #-} + +#else + +{-# DEPRECATED foldrAVL_UINT "This is deprecated, use foldr'." #-} +-- | This name is /deprecated/. Instead use 'foldr''. +foldrAVL_UINT :: (e -> UINT -> UINT) -> UINT -> AVL e -> UINT +foldrAVL_UINT = foldr' +{-# INLINE foldrAVL_UINT #-} + +#endif + +{-# DEPRECATED replicateAVL "This is now called replicate." #-} +-- | This name is /deprecated/. Instead use 'replicate'. +replicateAVL :: Int -> e -> AVL e +replicateAVL = replicate +{-# INLINE replicateAVL #-} + +{-# DEPRECATED filterAVL "This is now called filter." #-} +-- | This name is /deprecated/. Instead use 'filter'. +filterAVL :: (e -> Bool) -> AVL e -> AVL e +filterAVL = filter +{-# INLINE filterAVL #-} + +{-# DEPRECATED mapMaybeAVL "This is now called mapMaybe." #-} +-- | This name is /deprecated/. Instead use 'mapMaybe'. +mapMaybeAVL :: (a -> Maybe b) -> AVL a -> AVL b +mapMaybeAVL = mapMaybe +{-# INLINE mapMaybeAVL #-} + +{-# DEPRECATED partitionAVL "This is now called partition." #-} +-- | This name is /deprecated/. Instead use 'partition'. +partitionAVL :: (e -> Bool) -> AVL e -> (AVL e, AVL e) +partitionAVL = partition +{-# INLINE partitionAVL #-} + +{-# DEPRECATED foldrAVL "This is now called foldr." #-} +-- | This name is /deprecated/. Instead use 'foldr'. +foldrAVL :: (e -> a -> a) -> a -> AVL e -> a +foldrAVL = foldr +{-# INLINE foldrAVL #-} + +{-# DEPRECATED foldrAVL' "This is now called foldr'." #-} +-- | This name is /deprecated/. Instead use 'foldr''. +foldrAVL' :: (e -> a -> a) -> a -> AVL e -> a +foldrAVL' = foldr' +{-# INLINE foldrAVL' #-} + +{-# DEPRECATED foldr1AVL "This is now called foldr1." #-} +-- | This name is /deprecated/. Instead use 'foldr1'. +foldr1AVL :: (e -> e -> e) -> AVL e -> e +foldr1AVL = foldr1 +{-# INLINE foldr1AVL #-} + +{-# DEPRECATED foldr1AVL' "This is now called foldr1'." #-} +-- | This name is /deprecated/. Instead use 'foldr1''. +foldr1AVL' :: (e -> e -> e) -> AVL e -> e +foldr1AVL' = foldr1' +{-# INLINE foldr1AVL' #-} + +{-# DEPRECATED foldr2AVL "This is now called foldr2." #-} +-- | This name is /deprecated/. Instead use 'foldr2'. +foldr2AVL :: (e -> a -> a) -> (e -> a) -> AVL e -> a +foldr2AVL = foldr2 +{-# INLINE foldr2AVL #-} + +{-# DEPRECATED foldr2AVL' "This is now called foldr2'." #-} +-- | This name is /deprecated/. Instead use 'foldr2''. +foldr2AVL' :: (e -> a -> a) -> (e -> a) -> AVL e -> a +foldr2AVL' = foldr2' +{-# INLINE foldr2AVL' #-} + +{-# DEPRECATED foldlAVL "This is now called foldl." #-} +-- | This name is /deprecated/. Instead use 'foldl'. +foldlAVL :: (a -> e -> a) -> a -> AVL e -> a +foldlAVL = foldl +{-# INLINE foldlAVL #-} + +{-# DEPRECATED foldlAVL' "This is now called foldl'." #-} +-- | This name is /deprecated/. Instead use 'foldl''. +foldlAVL' :: (a -> e -> a) -> a -> AVL e -> a +foldlAVL' = foldl' +{-# INLINE foldlAVL' #-} + +{-# DEPRECATED foldl1AVL "This is now called foldl1." #-} +-- | This name is /deprecated/. Instead use 'foldl1'. +foldl1AVL :: (e -> e -> e) -> AVL e -> e +foldl1AVL = foldl1 +{-# INLINE foldl1AVL #-} + +{-# DEPRECATED foldl1AVL' "This is now called foldl1'." #-} +-- | This name is /deprecated/. Instead use 'foldl1''. +foldl1AVL' :: (e -> e -> e) -> AVL e -> e +foldl1AVL' = foldl1' +{-# INLINE foldl1AVL' #-} + +{-# DEPRECATED foldl2AVL "This is now called foldl2." #-} +-- | This name is /deprecated/. Instead use 'foldl2'. +foldl2AVL :: (a -> e -> a) -> (e -> a) -> AVL e -> a +foldl2AVL = foldl2 +{-# INLINE foldl2AVL #-} + +{-# DEPRECATED foldl2AVL' "This is now called foldl2'." #-} +-- | This name is /deprecated/. Instead use 'foldl2''. +foldl2AVL' :: (a -> e -> a) -> (e -> a) -> AVL e -> a +foldl2AVL' = foldl2' +{-# INLINE foldl2AVL' #-} + +{-# DEPRECATED findPath "This is now called findFullPath." #-} +-- | This name is /deprecated/. Instead use 'findFullPath'. +findPath :: (e -> Ordering) -> AVL e -> UINT +findPath = findFullPath +{-# INLINE findPath #-} diff --git a/Data/Tree/AVL/Internals/HSet.hs b/Data/Tree/AVL/Internals/HSet.hs --- a/Data/Tree/AVL/Internals/HSet.hs +++ b/Data/Tree/AVL/Internals/HSet.hs @@ -840,7 +840,7 @@ UBT6(ab,hab,cs2,cl2,lba,hlba) -> case joinH lba hlba mrba hmrba of UBT2(ba,hba) -> UBT6(ab,hab,cs2,cl2,ba,hba) -- a = b - Eq mbc -> case v cs cl ra hra rb hrb of + Eq mbc -> case v cs cl ra hra rb hrb of UBT6(rab,hrab,cs0,cl0,rba,hrba) -> case (case mbc of Nothing -> v cs0 cl0 la hla lb hlb Just c -> v (c:cs0) INCINT1(cl0) la hla lb hlb @@ -888,10 +888,46 @@ -- the right order (c a b) forka :: (a -> b -> COrdering c) -> a -> AVL b -> UINT -> UBT5(AVL b,UINT,Maybe c,AVL b,UINT) forka cmp a tb htb = f tb htb where - f E h = UBT5(E,h,Nothing,E,h) - f (N l b r) h = f_ l DECINT2(h) b r DECINT1(h) - f (Z l b r) h = f_ l DECINT1(h) b r DECINT1(h) - f (P l b r) h = f_ l DECINT1(h) b r DECINT2(h) + f E _ = UBT5(E,L(0),Nothing,E,L(0)) + f n@(N _ b r) L(2) = case cmp a b of -- l must be E, r must be Z + Lt -> UBT5(E,L(0),Nothing,n,L(2)) + Eq c -> UBT5(E,L(0),Just c ,r,L(1)) + Gt -> case r of + Z _ br _ -> case cmp a br of -- l & r must be E + Lt -> UBT5(Z E b E,L(1),Nothing,r,L(1)) + Eq c -> UBT5(Z E b E,L(1),Just c ,E,L(0)) + Gt -> UBT5(n ,L(2),Nothing,E,L(0)) + _ -> undefined `seq` UBT5(E,L(0),Nothing,E,L(0)) + f (N l b r) h = f_ l DECINT2(h) b r DECINT1(h) + f z@(Z l b r) L(2) = case cmp a b of -- l & r must be Z + Lt -> case l of + Z _ bl _ -> case cmp a bl of -- l & r must be E + Lt -> UBT5(E,L(0),Nothing,z ,L(2)) + Eq c -> UBT5(E,L(0),Just c ,N E b r,L(2)) + Gt -> UBT5(l,L(1),Nothing,N E b r,L(2)) + _ -> undefined `seq` UBT5(E,L(0),Nothing,E,L(0)) + Eq c -> UBT5(l,L(1),Just c,r,L(1)) + Gt -> case r of + Z _ br _ -> case cmp a br of -- l & r must be E + Lt -> UBT5(P l b E,L(2),Nothing,r,L(1)) + Eq c -> UBT5(P l b E,L(2),Just c ,E,L(0)) + Gt -> UBT5(z ,L(2),Nothing,E,L(0)) + _ -> undefined `seq` UBT5(E,L(0),Nothing,E,L(0)) + f z@(Z _ b _) L(1) = case cmp a b of -- l & r must be E + Lt -> UBT5(E,L(0),Nothing,z,L(1)) + Eq c -> UBT5(E,L(0),Just c ,E,L(0)) + Gt -> UBT5(z,L(1),Nothing,E,L(0)) + f (Z l b r) h = f_ l DECINT1(h) b r DECINT1(h) + f p@(P l b _) L(2) = case cmp a b of -- l must be Z, r must be E + Lt -> case l of + Z _ bl _ -> case cmp a bl of -- l & r must be E + Lt -> UBT5(E,L(0),Nothing,p ,L(2)) + Eq c -> UBT5(E,L(0),Just c ,Z E b E,L(1)) + Gt -> UBT5(l,L(1),Nothing,Z E b E,L(1)) + _ -> undefined `seq` UBT5(E,L(0),Nothing,E,L(0)) + Eq c -> UBT5(l,L(1),Just c ,E,L(0)) + Gt -> UBT5(p,L(2),Nothing,E,L(0)) + f (P l b r) h = f_ l DECINT1(h) b r DECINT2(h) f_ l hl b r hr = case cmp a b of Lt -> case f l hl of UBT5(ll,hll,mbc,lr,hlr) -> case spliceH lr hlr b r hr of @@ -900,19 +936,59 @@ Gt -> case f r hr of UBT5(rl,hrl,mbc,rr,hrr) -> case spliceH l hl b rl hrl of UBT2(l_,hl_) -> UBT5(l_,hl_,mbc,rr,hrr) + +-- This should be exactly the same as forka, but with the following swaps: +-- * a <-> b, except is compare! +-- * Lt <-> Gt (becasuse we didn't swap in compare) forkb :: (a -> b -> COrdering c) -> b -> AVL a -> UINT -> UBT5(AVL a,UINT,Maybe c,AVL a,UINT) forkb cmp b ta hta = f ta hta where - f E h = UBT5(E,h,Nothing,E,h) - f (N l a r) h = f_ l DECINT2(h) a r DECINT1(h) - f (Z l a r) h = f_ l DECINT1(h) a r DECINT1(h) - f (P l a r) h = f_ l DECINT1(h) a r DECINT2(h) + f E _ = UBT5(E,L(0),Nothing,E,L(0)) + f n@(N _ a r) L(2) = case cmp a b of -- l must be E, r must be Z + Gt -> UBT5(E,L(0),Nothing,n,L(2)) + Eq c -> UBT5(E,L(0),Just c ,r,L(1)) + Lt -> case r of + Z _ ar _ -> case cmp ar b of -- l & r must be E + Gt -> UBT5(Z E a E,L(1),Nothing,r,L(1)) + Eq c -> UBT5(Z E a E,L(1),Just c ,E,L(0)) + Lt -> UBT5(n ,L(2),Nothing,E,L(0)) + _ -> undefined `seq` UBT5(E,L(0),Nothing,E,L(0)) + f (N l a r) h = f_ l DECINT2(h) a r DECINT1(h) + f z@(Z l a r) L(2) = case cmp a b of -- l & r must be Z + Gt -> case l of + Z _ al _ -> case cmp al b of -- l & r must be E + Gt -> UBT5(E,L(0),Nothing,z ,L(2)) + Eq c -> UBT5(E,L(0),Just c ,N E a r,L(2)) + Lt -> UBT5(l,L(1),Nothing,N E a r,L(2)) + _ -> undefined `seq` UBT5(E,L(0),Nothing,E,L(0)) + Eq c -> UBT5(l,L(1),Just c,r,L(1)) + Lt -> case r of + Z _ ar _ -> case cmp ar b of -- l & r must be E + Gt -> UBT5(P l a E,L(2),Nothing,r,L(1)) + Eq c -> UBT5(P l a E,L(2),Just c ,E,L(0)) + Lt -> UBT5(z ,L(2),Nothing,E,L(0)) + _ -> undefined `seq` UBT5(E,L(0),Nothing,E,L(0)) + f z@(Z _ a _) L(1) = case cmp a b of -- l & r must be E + Gt -> UBT5(E,L(0),Nothing,z,L(1)) + Eq c -> UBT5(E,L(0),Just c ,E,L(0)) + Lt -> UBT5(z,L(1),Nothing,E,L(0)) + f (Z l a r) h = f_ l DECINT1(h) a r DECINT1(h) + f p@(P l a _) L(2) = case cmp a b of -- l must be Z, r must be E + Gt -> case l of + Z _ al _ -> case cmp al b of -- l & r must be E + Gt -> UBT5(E,L(0),Nothing,p ,L(2)) + Eq c -> UBT5(E,L(0),Just c ,Z E a E,L(1)) + Lt -> UBT5(l,L(1),Nothing,Z E a E,L(1)) + _ -> undefined `seq` UBT5(E,L(0),Nothing,E,L(0)) + Eq c -> UBT5(l,L(1),Just c ,E,L(0)) + Lt -> UBT5(p,L(2),Nothing,E,L(0)) + f (P l a r) h = f_ l DECINT1(h) a r DECINT2(h) f_ l hl a r hr = case cmp a b of - Lt -> case f r hr of - UBT5(rl,hrl,mbc,rr,hrr) -> case spliceH l hl a rl hrl of - UBT2(l_,hl_) -> UBT5(l_,hl_,mbc,rr,hrr) - Eq c -> UBT5(l,hl,Just c,r,hr) Gt -> case f l hl of UBT5(ll,hll,mbc,lr,hlr) -> case spliceH lr hlr a r hr of UBT2(r_,hr_) -> UBT5(ll,hll,mbc,r_,hr_) + Eq c -> UBT5(l,hl,Just c,r,hr) + Lt -> case f r hr of + UBT5(rl,hrl,mbc,rr,hrr) -> case spliceH l hl a rl hrl of + UBT2(l_,hl_) -> UBT5(l_,hl_,mbc,rr,hrr) diff --git a/Data/Tree/AVL/List.hs b/Data/Tree/AVL/List.hs --- a/Data/Tree/AVL/List.hs +++ b/Data/Tree/AVL/List.hs @@ -23,35 +23,40 @@ asTreeLenR,asTreeR, -- ** Converting unsorted Lists to sorted AVL trees - genAsTree, + asTree, -- ** \"Pushing\" unsorted Lists in sorted AVL trees - genPushList, + pushList, -- * Some analogues of common List functions - reverseAVL,mapAVL,mapAVL', - mapAccumLAVL ,mapAccumRAVL , - mapAccumLAVL' ,mapAccumRAVL' , -#ifdef __GLASGOW_HASKELL__ - mapAccumLAVL'',mapAccumRAVL'', -#endif + reverse,map,map', + mapAccumL ,mapAccumR , + mapAccumL' ,mapAccumR' , + replicate, + filter,mapMaybe, + filterViaList,mapMaybeViaList, + partition, #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, + foldr,foldr',foldr1,foldr1',foldr2,foldr2', + foldl,foldl',foldl1,foldl1',foldl2,foldl2', +#ifdef __GLASGOW_HASKELL__ + -- ** (GHC Only) + mapAccumL'',mapAccumR'', foldrInt#, +#endif + + -- * Some clones of common List functions + -- | These are a cure for the horrible @O(n^2)@ complexity the noddy Data.List definitions. + nub,nubBy, + -- * \"Flattening\" AVL trees -- | These functions can be improve search times by reducing a tree of given size to -- the minimum possible height. @@ -59,23 +64,23 @@ flatReverse,flatMap,flatMap', ) where -import Prelude -- so haddock finds the symbols there - -#if __GLASGOW_HASKELL__ > 604 -import Control.Applicative hiding (empty) -#endif +import Prelude hiding (reverse,map,replicate,filter,foldr,foldr1,foldl,foldl1) -- so haddock finds the symbols there import Data.COrdering import Data.Tree.AVL.Types(AVL(..),empty) import Data.Tree.AVL.Size(size) -import Data.Tree.AVL.Push(genPush) +import Data.Tree.AVL.Push(push) +import Data.Tree.AVL.BinPath(findEmptyPath,insertPath) import Data.Tree.AVL.Internals.HJoin(spliceH,joinH) import Data.Bits(shiftR,(.&.)) -import Data.List(foldl') +import qualified Data.List as List (foldl',map) +#if __GLASGOW_HASKELL__ > 604 +import Control.Applicative hiding (empty) +#endif #ifdef __GLASGOW_HASKELL__ -import GHC.Base +import GHC.Base(Int#,(-#)) #include "ghcdefs.h" #else #include "h98defs.h" @@ -125,32 +130,32 @@ -- | 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. +-- stack use. See 'foldr'' for a strict version. -- -- It behaves as if defined.. -- --- > foldrAVL f a avl = foldr f a (asListL avl) +-- > foldr f a avl = foldr f a (asListL avl) -- -- For example, the 'asListL' function could be defined.. -- --- > asListL = foldrAVL (:) [] +-- > asListL = foldr (:) [] -- -- Complexity: O(n) -foldrAVL :: (e -> a -> a) -> a -> AVL e -> a -foldrAVL f = foldU where +foldr :: (e -> a -> a) -> a -> AVL e -> a +foldr f = foldU where foldU a E = a foldU a (N l e r) = foldV a l e r foldU a (Z l e r) = foldV a l e r foldU a (P l e r) = foldV a l e r foldV a l e r = foldU (f e (foldU a r)) l --- | The strict version of 'foldrAVL', which is useful for functions which are strict in their second +-- | The strict version of 'foldr', which is useful for functions which are strict in their second -- argument. The advantage of this version is that it reduces the stack use from the O(n) that the lazy -- version gives (when used with strict functions) to O(log n). -- -- Complexity: O(n) -foldrAVL' :: (e -> a -> a) -> a -> AVL e -> a -foldrAVL' f = foldU where +foldr' :: (e -> a -> a) -> a -> AVL e -> a +foldr' f = foldU where foldU a E = a foldU a (N l e r) = foldV a l e r foldU a (Z l e r) = foldV a l e r @@ -161,134 +166,134 @@ -- | 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. +-- stack use. See 'foldr1'' for a strict version. -- --- > foldr1AVL f avl = foldr1 f (asListL avl) +-- > foldr1 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" +foldr1 :: (e -> e -> e) -> AVL e -> e +foldr1 f = foldU where + foldU E = error "foldr1: Empty Tree" foldU (N l e r) = foldV l e r -- r can't be E foldU (Z l e r) = foldW l e r -- r might be E foldU (P l e r) = foldW l e r -- r might be E -- Use this when r can't be E - foldV l e r = foldrAVL f (f e (foldU r)) l + foldV l e r = foldr 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 E = foldr f e l + foldW l e (N rl re rr) = foldr f (f e (foldV rl re rr)) l -- rr can't be E foldW l e (Z rl re rr) = foldX l e rl re rr -- rr might be E foldW l e (P rl re rr) = foldX l e rl re rr -- rr might be E -- Common code for foldW (Z and P cases) - foldX l e rl re rr = foldrAVL f (f e (foldW rl re rr)) l + foldX l e rl re rr = foldr f (f e (foldW rl re rr)) l --- | The strict version of 'foldr1AVL', which is useful for functions which are strict in their second +-- | The strict version of 'foldr1', which is useful for functions which are strict in their second -- argument. The advantage of this version is that it reduces the stack use from the O(n) that the lazy -- version gives (when used with strict functions) to O(log n). -- -- Complexity: O(n) -foldr1AVL' :: (e -> e -> e) -> AVL e -> e -foldr1AVL' f = foldU where - foldU E = error "foldr1AVL': Empty Tree" +foldr1' :: (e -> e -> e) -> AVL e -> e +foldr1' f = foldU where + foldU E = error "foldr1': Empty Tree" foldU (N l e r) = foldV l e r -- r can't be E foldU (Z l e r) = foldW l e r -- r might be E foldU (P l e r) = foldW l e r -- r might be E -- Use this when r can't be E foldV l e r = let a = foldU r a' = f e a - in a `seq` a' `seq` foldrAVL' f a' l + in a `seq` a' `seq` foldr' f a' l -- Use this when r might be E - foldW l e E = foldrAVL' f e l + foldW l e E = foldr' f e l foldW l e (N rl re rr) = let a = foldV rl re rr -- rr can't be E a' = f e a - in a `seq` a' `seq` foldrAVL' f a' l + in a `seq` a' `seq` foldr' f a' l foldW l e (Z rl re rr) = foldX l e rl re rr -- rr might be E foldW l e (P rl re rr) = foldX l e rl re rr -- rr might be E -- Common code for foldW (Z and P cases) foldX l e rl re rr = let a = foldW rl re rr a' = f e a - in a `seq` a' `seq` foldrAVL' f a' l + in a `seq` a' `seq` foldr' f a' l --- | This fold is a hybrid between 'foldrAVL' and 'foldr1AVL'. As with 'foldr1AVL', it requires +-- | This fold is a hybrid between 'foldr' and 'foldr1'. As with 'foldr1', it requires -- a non-empty tree, but instead of treating the rightmost element as an initial value, it applies -- a function to it (second function argument) and uses the result instead. This allows --- a more flexible type for the main folding function (same type as that used by '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. +-- a more flexible type for the main folding function (same type as that used by 'foldr'). +-- As with 'foldr' and 'foldr1', this function is lazy, so it's best not to use it with functions +-- that are strict in their second argument. See 'foldr2'' for a strict version. -- -- Complexity: O(n) -foldr2AVL :: (e -> a -> a) -> (e -> a) -> AVL e -> a -foldr2AVL f g = foldU where - foldU E = error "foldr2AVL: Empty Tree" +foldr2 :: (e -> a -> a) -> (e -> a) -> AVL e -> a +foldr2 f g = foldU where + foldU E = error "foldr2: Empty Tree" foldU (N l e r) = foldV l e r -- r can't be E foldU (Z l e r) = foldW l e r -- r might be E foldU (P l e r) = foldW l e r -- r might be E -- Use this when r can't be E - foldV l e r = foldrAVL f (f e (foldU r)) l + foldV l e r = foldr 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 E = foldr f (g e) l + foldW l e (N rl re rr) = foldr f (f e (foldV rl re rr)) l -- rr can't be E foldW l e (Z rl re rr) = foldX l e rl re rr -- rr might be E foldW l e (P rl re rr) = foldX l e rl re rr -- rr might be E -- Common code for foldW (Z and P cases) - foldX l e rl re rr = foldrAVL f (f e (foldW rl re rr)) l + foldX l e rl re rr = foldr f (f e (foldW rl re rr)) l --- | The strict version of 'foldr2AVL', which is useful for functions which are strict in their second +-- | The strict version of 'foldr2', which is useful for functions which are strict in their second -- argument. The advantage of this version is that it reduces the stack use from the O(n) that the lazy -- version gives (when used with strict functions) to O(log n). -- -- Complexity: O(n) -foldr2AVL' :: (e -> a -> a) -> (e -> a) -> AVL e -> a -foldr2AVL' f g = foldU where - foldU E = error "foldr2AVL': Empty Tree" +foldr2' :: (e -> a -> a) -> (e -> a) -> AVL e -> a +foldr2' f g = foldU where + foldU E = error "foldr2': Empty Tree" foldU (N l e r) = foldV l e r -- r can't be E foldU (Z l e r) = foldW l e r -- r might be E foldU (P l e r) = foldW l e r -- r might be E -- Use this when r can't be E foldV l e r = let a = foldU r a' = f e a - in a `seq` a' `seq` foldrAVL' f a' l + in a `seq` a' `seq` foldr' f a' l -- Use this when r might be E - foldW l e E = let a = g e in a `seq` foldrAVL' f a l + foldW l e E = let a = g e in a `seq` foldr' f a l foldW l e (N rl re rr) = let a = foldV rl re rr -- rr can't be E a' = f e a - in a `seq` a' `seq` foldrAVL' f a' l + in a `seq` a' `seq` foldr' f a' l foldW l e (Z rl re rr) = foldX l e rl re rr -- rr might be E foldW l e (P rl re rr) = foldX l e rl re rr -- rr might be E -- Common code for foldW (Z and P cases) foldX l e rl re rr = let a = foldW rl re rr a' = f e a - in a `seq` a' `seq` foldrAVL' f a' l + in a `seq` a' `seq` foldr' f a' l -- | The AVL equivalent of 'foldl' on lists. This is a the lazy version (as lazy as the folding function -- anyway). Using this version with a function that is strict in it's first argument will result in O(n) --- stack use. See 'foldlAVL'' for a strict version. +-- stack use. See 'foldl'' for a strict version. -- --- > foldlAVL f a avl = foldl f a (asListL avl) +-- > foldl f a avl = foldl f a (asListL avl) -- -- For example, the 'asListR' function could be defined.. -- --- > asListR = foldlAVL (flip (:)) [] +-- > asListR = foldl (flip (:)) [] -- -- Complexity: O(n) -foldlAVL :: (a -> e -> a) -> a -> AVL e -> a -foldlAVL f = foldU where +foldl :: (a -> e -> a) -> a -> AVL e -> a +foldl f = foldU where foldU a E = a foldU a (N l e r) = foldV a l e r foldU a (Z l e r) = foldV a l e r foldU a (P l e r) = foldV a l e r foldV a l e r = foldU (f (foldU a l) e) r --- | The strict version of 'foldlAVL', which is useful for functions which are strict in their first +-- | The strict version of 'foldl', which is useful for functions which are strict in their first -- argument. The advantage of this version is that it reduces the stack use from the O(n) that the lazy -- version gives (when used with strict functions) to O(log n). -- -- Complexity: O(n) -foldlAVL' :: (a -> e -> a) -> a -> AVL e -> a -foldlAVL' f = foldU where +foldl' :: (a -> e -> a) -> a -> AVL e -> a +foldl' f = foldU where foldU a E = a foldU a (N l e r) = foldV a l e r foldU a (Z l e r) = foldV a l e r @@ -299,136 +304,132 @@ -- | 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. +-- stack use. See 'foldl1'' for a strict version. -- --- > foldl1AVL f avl = foldl1 f (asListL avl) +-- > foldl1 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" +foldl1 :: (e -> e -> e) -> AVL e -> e +foldl1 f = foldU where + foldU E = error "foldl1: Empty Tree" foldU (N l e r) = foldW l e r -- l might be E foldU (Z l e r) = foldW l e r -- l might be E foldU (P l e r) = foldV l e r -- l can't be E -- Use this when l can't be E - foldV l e r = foldlAVL f (f (foldU l) e) r + foldV l e r = foldl f (f (foldU l) e) r -- Use this when l might be E - foldW E e r = foldlAVL f e r + foldW E e r = foldl f e r foldW (N ll le lr) e r = foldX ll le lr e r -- ll might be E foldW (Z ll le lr) e r = foldX ll le lr e r -- ll might be E - foldW (P ll le lr) e r = foldlAVL f (f (foldV ll le lr) e) r -- ll can't be E + foldW (P ll le lr) e r = foldl f (f (foldV ll le lr) e) r -- ll can't be E -- Common code for foldW (Z and P cases) - foldX ll le lr e r = foldlAVL f (f (foldW ll le lr) e) r + foldX ll le lr e r = foldl f (f (foldW ll le lr) e) r --- | The strict version of 'foldl1AVL', which is useful for functions which are strict in their first +-- | The strict version of 'foldl1', which is useful for functions which are strict in their first -- argument. The advantage of this version is that it reduces the stack use from the O(n) that the lazy -- version gives (when used with strict functions) to O(log n). -- -- Complexity: O(n) -foldl1AVL' :: (e -> e -> e) -> AVL e -> e -foldl1AVL' f = foldU where - foldU E = error "foldl1AVL': Empty Tree" +foldl1' :: (e -> e -> e) -> AVL e -> e +foldl1' f = foldU where + foldU E = error "foldl1': Empty Tree" foldU (N l e r) = foldW l e r -- l might be E foldU (Z l e r) = foldW l e r -- l might be E foldU (P l e r) = foldV l e r -- l can't be E -- Use this when l can't be E foldV l e r = let a = foldU l a' = f a e - in a `seq` a' `seq` foldlAVL' f a' r + in a `seq` a' `seq` foldl' f a' r -- Use this when l might be E - foldW E e r = foldlAVL' f e r + foldW E e r = foldl' f e r foldW (N ll le lr) e r = foldX ll le lr e r -- ll might be E foldW (Z ll le lr) e r = foldX ll le lr e r -- ll might be E foldW (P ll le lr) e r = let a = foldV ll le lr -- ll can't be E a' = f a e - in a `seq` a' `seq` foldlAVL' f a' r + in a `seq` a' `seq` foldl' f a' r -- Common code for foldW (Z and P cases) foldX ll le lr e r = let a = foldW ll le lr a' = f a e - in a `seq` a' `seq` foldlAVL' f a' r + in a `seq` a' `seq` foldl' f a' r --- | This fold is a hybrid between 'foldlAVL' and 'foldl1AVL'. As with 'foldl1AVL', it requires +-- | This fold is a hybrid between 'foldl' and 'foldl1'. As with 'foldl1', it requires -- a non-empty tree, but instead of treating the leftmost element as an initial value, it applies -- a function to it (second function argument) and uses the result instead. This allows --- a more flexible type for the main folding function (same type as that used by '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. +-- a more flexible type for the main folding function (same type as that used by 'foldl'). +-- As with 'foldl' and 'foldl1', this function is lazy, so it's best not to use it with functions +-- that are strict in their first argument. See 'foldl2'' for a strict version. -- -- Complexity: O(n) -foldl2AVL :: (a -> e -> a) -> (e -> a) -> AVL e -> a -foldl2AVL f g = foldU where - foldU E = error "foldl2AVL: Empty Tree" +foldl2 :: (a -> e -> a) -> (e -> a) -> AVL e -> a +foldl2 f g = foldU where + foldU E = error "foldl2: Empty Tree" foldU (N l e r) = foldW l e r -- l might be E foldU (Z l e r) = foldW l e r -- l might be E foldU (P l e r) = foldV l e r -- l can't be E -- Use this when l can't be E - foldV l e r = foldlAVL f (f (foldU l) e) r + foldV l e r = foldl f (f (foldU l) e) r -- Use this when l might be E - foldW E e r = foldlAVL f (g e) r + foldW E e r = foldl f (g e) r foldW (N ll le lr) e r = foldX ll le lr e r -- ll might be E foldW (Z ll le lr) e r = foldX ll le lr e r -- ll might be E - foldW (P ll le lr) e r = foldlAVL f (f (foldV ll le lr) e) r -- ll can't be E + foldW (P ll le lr) e r = foldl f (f (foldV ll le lr) e) r -- ll can't be E -- Common code for foldW (Z and P cases) - foldX ll le lr e r = foldlAVL f (f (foldW ll le lr) e) r + foldX ll le lr e r = foldl f (f (foldW ll le lr) e) r --- | The strict version of 'foldl2AVL', which is useful for functions which are strict in their first +-- | The strict version of 'foldl2', which is useful for functions which are strict in their first -- argument. The advantage of this version is that it reduces the stack use from the O(n) that the lazy -- version gives (when used with strict functions) to O(log n). -- -- Complexity: O(n) -foldl2AVL' :: (a -> e -> a) -> (e -> a) -> AVL e -> a -foldl2AVL' f g = foldU where - foldU E = error "foldl2AVL': Empty Tree" +foldl2' :: (a -> e -> a) -> (e -> a) -> AVL e -> a +foldl2' f g = foldU where + foldU E = error "foldl2': Empty Tree" foldU (N l e r) = foldW l e r -- l might be E foldU (Z l e r) = foldW l e r -- l might be E foldU (P l e r) = foldV l e r -- l can't be E -- Use this when l can't be E foldV l e r = let a = foldU l a' = f a e - in a `seq` a' `seq` foldlAVL' f a' r + in a `seq` a' `seq` foldl' f a' r -- Use this when l might be E - foldW E e r = let a = g e in a `seq` foldlAVL' f a r + foldW E e r = let a = g e in a `seq` foldl' f a r foldW (N ll le lr) e r = foldX ll le lr e r -- ll might be E foldW (Z ll le lr) e r = foldX ll le lr e r -- ll might be E foldW (P ll le lr) e r = let a = foldV ll le lr -- ll can't be E a' = f a e - in a `seq` a' `seq` foldlAVL' f a' r + in a `seq` a' `seq` foldl' f a' r -- Common code for foldW (Z and P cases) foldX ll le lr e r = let a = foldW ll le lr a' = f a e - in a `seq` a' `seq` foldlAVL' f a' r + in a `seq` a' `seq` foldl' 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. +#ifdef __GLASGOW_HASKELL__ +-- | This is a specialised version of 'foldr'' for use with an +-- /unboxed/ Int accumulator. -- -- Complexity: O(n) -foldrAVL_UINT :: (e -> UINT -> UINT) -> UINT -> AVL e -> UINT -#ifdef __GLASGOW_HASKELL__ -foldrAVL_UINT f = foldU where +foldrInt# :: (e -> UINT -> UINT) -> UINT -> AVL e -> UINT +foldrInt# f = foldU where foldU a E = a foldU a (N l e r) = foldV a l e r foldU a (Z l e r) = foldV a l e r foldU a (P l e r) = foldV a l e r foldV a l e r = foldU (f e (foldU a r)) l -#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 behaves like a combination of 'map' and 'foldl'. -- It applies a function to each element of a tree, passing an accumulating parameter from -- left to right, and returning a final value of this accumulator together with the new tree. -- -- Using this version with a function that is strict in it's first argument will result in --- O(n) stack use. See 'mapAccumLAVL'' for a strict version. +-- O(n) stack use. See 'mapAccumL'' 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 +mapAccumL :: (z -> a -> (z, b)) -> z -> AVL a -> (z, AVL b) +mapAccumL f z ta = case mapAL z ta of UBT2(zt,tb) -> (zt,tb) where mapAL z_ E = UBT2(z_,E) mapAL z_ (N la a ra) = mapAL' z_ N la a ra @@ -440,14 +441,14 @@ 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 +-- | This is a strict version of 'mapAccumL', which is useful for functions which -- are strict in their first argument. The advantage of this version is that it reduces -- the stack use from the O(n) that the lazy version gives (when used with strict functions) -- to O(log n). -- -- Complexity: O(n) -mapAccumLAVL' :: (z -> a -> (z, b)) -> z -> AVL a -> (z, AVL b) -mapAccumLAVL' f z ta = case mapAL z ta of +mapAccumL' :: (z -> a -> (z, b)) -> z -> AVL a -> (z, AVL b) +mapAccumL' f z ta = case mapAL z ta of UBT2(zt,tb) -> (zt,tb) where mapAL z_ E = UBT2(z_,E) mapAL z_ (N la a ra) = mapAL' z_ N la a ra @@ -461,16 +462,16 @@ -- | The AVL equivalent of 'Data.List.mapAccumR' on lists. --- It behaves like a combination of 'mapAVL' and 'foldrAVL'. +-- It behaves like a combination of 'map' and 'foldr'. -- It applies a function to each element of a tree, passing an accumulating parameter from -- right to left, and returning a final value of this accumulator together with the new tree. -- -- Using this version with a function that is strict in it's first argument will result in --- O(n) stack use. See 'mapAccumRAVL'' for a strict version. +-- O(n) stack use. See 'mapAccumR'' 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 +mapAccumR :: (z -> a -> (z, b)) -> z -> AVL a -> (z, AVL b) +mapAccumR f z ta = case mapAR z ta of UBT2(zt,tb) -> (zt,tb) where mapAR z_ E = UBT2(z_,E) mapAR z_ (N la a ra) = mapAR' z_ N la a ra @@ -482,14 +483,14 @@ 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 +-- | This is a strict version of 'mapAccumR', which is useful for functions which -- are strict in their first argument. The advantage of this version is that it reduces -- the stack use from the O(n) that the lazy version gives (when used with strict functions) -- to O(log n). -- -- Complexity: O(n) -mapAccumRAVL' :: (z -> a -> (z, b)) -> z -> AVL a -> (z, AVL b) -mapAccumRAVL' f z ta = case mapAR z ta of +mapAccumR' :: (z -> a -> (z, b)) -> z -> AVL a -> (z, AVL b) +mapAccumR' f z ta = case mapAR z ta of UBT2(zt,tb) -> (zt,tb) where mapAR z_ E = UBT2(z_,E) mapAR z_ (N la a ra) = mapAR' z_ N la a ra @@ -506,13 +507,13 @@ -- 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 +-- | Glasgow Haskell only. Similar to 'mapAccumL'' but uses an unboxed pair in the -- accumulating function. -- -- Complexity: O(n) -mapAccumLAVL'' +mapAccumL'' :: (z -> a -> UBT2(z, b)) -> z -> AVL a -> (z, AVL b) -mapAccumLAVL'' f z ta = case mapAL z ta of +mapAccumL'' f z ta = case mapAL z ta of UBT2(zt,tb) -> (zt,tb) where mapAL z_ E = UBT2(z_,E) mapAL z_ (N la a ra) = mapAL' z_ N la a ra @@ -524,13 +525,13 @@ 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 +-- | Glasgow Haskell only. Similar to 'mapAccumR'' but uses an unboxed pair in the -- accumulating function. -- -- Complexity: O(n) -mapAccumRAVL'' +mapAccumR'' :: (z -> a -> UBT2(z, b)) -> z -> AVL a -> (z, AVL b) -mapAccumRAVL'' f z ta = case mapAR z ta of +mapAccumR'' f z ta = case mapAR z ta of UBT2(zt,tb) -> (zt,tb) where mapAR z_ E = UBT2(z_,E) mapAR z_ (N la a ra) = mapAR' z_ N la a ra @@ -555,7 +556,7 @@ -- -- Complexity: O(n) asTreeLenL :: Int -> [e] -> AVL e -asTreeLenL n es = case subst (replicateAVL n ()) es of +asTreeLenL n es = case subst (replicate n ()) es of UBT2(tree,es_) -> case es_ of [] -> tree _ -> error "asTreeLenL: List too long." @@ -590,7 +591,7 @@ -- -- Complexity: O(n) asTreeLenR :: Int -> [e] -> AVL e -asTreeLenR n es = case subst (replicateAVL n ()) es of +asTreeLenR n es = case subst (replicate n ()) es of UBT2(tree,es_) -> case es_ of [] -> tree _ -> error "asTreeLenR: List too long." @@ -619,70 +620,63 @@ -- 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' +reverse :: AVL e -> AVL e +reverse E = E +reverse (N l e r) = let l' = reverse l + r' = reverse r + in l' `seq` r' `seq` P r' e l' +reverse (Z l e r) = let l' = reverse l + r' = reverse r + in l' `seq` r' `seq` Z r' e l' +reverse (P l e r) = let l' = reverse l + r' = reverse r + in l' `seq` r' `seq` N r' e l' -- | Apply a function to every element in an AVL tree. This function preserves the tree shape. --- There is also a strict version of this function ('mapAVL''). +-- There is also a strict version of this function ('map''). -- -- N.B. If the tree is sorted the result of this operation will only be sorted if -- the applied function preserves ordering (for some suitable ordering definition). -- -- Complexity: O(n) -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' +map :: (a -> b) -> AVL a -> AVL b +map f = mp where + mp E = E + mp (N l a r) = let l' = mp l + r' = mp r + in l' `seq` r' `seq` N l' (f a) r' + mp (Z l a r) = let l' = mp l + r' = mp r + in l' `seq` r' `seq` Z l' (f a) r' + mp (P l a r) = let l' = mp l + r' = mp r + in l' `seq` r' `seq` P l' (f a) r' --- | Similar to 'mapAVL', but the supplied function is applied strictly. +-- | Similar to 'map', 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' +map' :: (a -> b) -> AVL a -> AVL b +map' f = mp' where + mp' E = E + mp' (N l a r) = let l' = mp' l + r' = mp' r + b = f a + in b `seq` l' `seq` r' `seq` N l' b r' + mp' (Z l a r) = let l' = mp' l + r' = mp' r + b = f a + in b `seq` l' `seq` r' `seq` Z l' b r' + mp' (P l a r) = let l' = mp' l + r' = mp' r + b = f a + in b `seq` l' `seq` r' `seq` P l' b r' -#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 :-) +replicate :: Int -> e -> AVL e +replicate m e = rep m where -- Functional spaghetti follows :-) rep n | odd n = repOdd n -- n is odd , >=1 rep n = repEvn n -- n is even, >=0 -- n is known to be odd (>=1), so left and right sub-trees are identical @@ -717,30 +711,30 @@ 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'. +-- factor overhead than 'reverse'. -- -- 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'. +-- | Similar to 'map', but the resulting tree is flat. +-- This function has higher constant factor overhead than 'map'. -- -- Complexity: O(n) flatMap :: (a -> b) -> AVL a -> AVL b -flatMap f t = asTreeLenL (size t) (map f (asListL t)) +flatMap f t = asTreeLenL (size t) (List.map f (asListL t)) -- | Same as 'flatMap', but the supplied function is applied strictly. -- -- Complexity: O(n) flatMap' :: (a -> b) -> AVL a -> AVL b -flatMap' f t = asTreeLenL (size t) (map' f (asListL t)) where - map' _ [] = [] - map' g (a:as) = let b = g a in b `seq` (b : map' f as) +flatMap' f t = asTreeLenL (size t) (mp' f (asListL t)) where + mp' _ [] = [] + mp' g (a:as) = let b = g a in b `seq` (b : mp' f as) -- | Remove all AVL tree elements which do not satisfy the supplied predicate. -- Element ordering is preserved. The resulting tree is flat. --- See 'filterAVL' for an alternative implementation which is probably more efficient. +-- See 'filter' for an alternative implementation which is probably more efficient. -- -- Complexity: O(n) filterViaList :: (e -> Bool) -> AVL e -> AVL e @@ -753,8 +747,8 @@ -- 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!! +filter :: (e -> Bool) -> AVL e -> AVL e +filter p t0 = case filter_ L(0) t0 of UBT3(_,t_,_) -> t_ -- Work with relative heights!! where filter_ h t = case t of E -> UBT3(False,E,h) N l e r -> f l DECINT2(h) e r DECINT1(h) @@ -776,8 +770,8 @@ -- 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 +partition :: (e -> Bool) -> AVL e -> (AVL e, AVL e) +partition p t = part 0 [] 0 [] (asListR t) where part nT lstT nF lstF [] = let avlT = asTreeLenL nT lstT avlF = asTreeLenL nF lstF in (avlT,avlF) -- Non strict in avlT, avlF !! @@ -786,22 +780,22 @@ -- | 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. +-- See 'mapMaybe' for an alternative implementation which is probably more efficient. -- -- Complexity: O(n) mapMaybeViaList :: (a -> Maybe b) -> AVL a -> AVL b -mapMaybeViaList f t = 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 +mapMaybeViaList f t = mp' [] 0 (asListR t) where + mp' sb n [] = asTreeLenL n sb + mp' sb n (a:as) = case f a of + Just b -> let n'=n+1 in n' `seq` mp' (b:sb) n' as + Nothing -> mp' sb n as -- | Remove all AVL tree elements for which the supplied function returns 'Nothing'. -- Element ordering is preserved. -- -- Complexity: O(n) -mapMaybeAVL :: (a -> Maybe b) -> AVL a -> AVL b -mapMaybeAVL f t0 = case mapMaybe_ L(0) t0 of UBT2(t_,_) -> t_ -- Work with relative heights!! +mapMaybe :: (a -> Maybe b) -> AVL a -> AVL b +mapMaybe f t0 = case mapMaybe_ L(0) t0 of UBT2(t_,_) -> t_ -- Work with relative heights!! where mapMaybe_ h t = case t of E -> UBT2(E,h) N l a r -> m l DECINT2(h) a r DECINT1(h) @@ -813,17 +807,46 @@ Just b -> spliceH l_ hl_ b r_ hr_ Nothing -> joinH l_ hl_ r_ hr_ --- | Invokes 'genPushList' on the empty AVL tree. +-- | Invokes 'pushList' 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 +asTree :: (e -> e -> COrdering e) -> [e] -> AVL e +asTree c = pushList c empty +{-# INLINE asTree #-} -- | Push the elements of an unsorted List in a sorted AVL tree using the supplied combining comparison. -- -- Complexity: O(n.(log (m+n))) where n is the list length, m is the tree size. -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 +pushList :: (e -> e -> COrdering e) -> AVL e -> [e] -> AVL e +pushList c avl = List.foldl' addElem avl + where addElem t e = push (c e) e t + +-- | A fast alternative implementation for 'Data.List.nub'. +-- Deletes all but the first occurrence of an element from the input list. +-- +-- Complexity: O(n.(log n)) +nub :: Ord a => [a] -> [a] +nub = nubBy compare +{-# INLINE nub #-} + +-- | A fast alternative implementation for 'Data.List.nubBy'. +-- Deletes all but the first occurrence of an element from the input list. +-- +-- Complexity: O(n.(log n)) +nubBy :: (a -> a -> Ordering) -> [a] -> [a] +nubBy c = nubbit E where + nubbit _ [] = [] + nubbit avl (a:as) = case findEmptyPath (c a) avl of + L(-1) -> nubbit avl as -- Already encountered + p -> let avl' = insertPath p a avl -- First encounter + in avl' `seq` (a : nubbit avl' as) + +#if __GLASGOW_HASKELL__ > 604 +-- | This is the non-overloaded version of the 'Data.Traversable.traverse' method for AVL trees. +traverseAVL :: Applicative f => (a -> f b) -> AVL a -> f (AVL b) +traverseAVL _f E = pure E +traverseAVL f (N l v r) = N <$> traverseAVL f l <*> f v <*> traverseAVL f r +traverseAVL f (Z l v r) = Z <$> traverseAVL f l <*> f v <*> traverseAVL f r +traverseAVL f (P l v r) = P <$> traverseAVL f l <*> f v <*> traverseAVL f r +#endif diff --git a/Data/Tree/AVL/Push.hs b/Data/Tree/AVL/Push.hs --- a/Data/Tree/AVL/Push.hs +++ b/Data/Tree/AVL/Push.hs @@ -16,14 +16,14 @@ pushL,pushR, -- ** Pushing on /sorted/ AVL trees - genPush,genPush',genPushMaybe,genPushMaybe', + push,push',pushMaybe,pushMaybe', ) where import Prelude -- so haddock finds the symbols there import Data.COrdering import Data.Tree.AVL.Types(AVL(..)) -import Data.Tree.AVL.BinPath(BinPath(..),genOpenPathWith,writePath,insertPath) +import Data.Tree.AVL.BinPath(BinPath(..),openPathWith,writePath,insertPath) {------------------------------------------------------------------------------------------------------------------------------ -------------------------------------- Notes about Insertion and Rebalancing ------------------------------------------------- @@ -167,11 +167,11 @@ -- -- 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'' +-- to force evaluation, but only if it\'s actually incorprated in the tree, then use 'push'' -- -- 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 +push :: (e -> COrdering e) -> e -> AVL e -> AVL e +push c e0 = put where -- there now follows a huge collection of functions requiring -- pattern matching from hell in which c and e0 are free variables -- This may look longwinded, it's been done this way to.. -- * Avoid doing case analysis on the same node more than once. @@ -220,7 +220,7 @@ 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 + E -> error "push: Bug0" -- impossible Z _ _ _ -> N l' e r -- L subtree BF:0-> 0, H:h->h , parent BF:-1->-1 _ -> Z l' e r -- L subtree BF:0->+/-1, H:h->h+1, parent BF:-1-> 0 @@ -233,7 +233,7 @@ 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 + E -> error "push: Bug1" -- impossible Z _ _ _ -> Z l' e r -- L subtree BF: 0-> 0, H:h->h , parent BF: 0-> 0 _ -> P l' e r -- L subtree BF: 0->+/-1, H:h->h+1, parent BF: 0->+1 @@ -246,7 +246,7 @@ 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 + E -> error "push: Bug2" -- impossible Z _ _ _ -> Z l e r' -- R subtree BF: 0-> 0, H:h->h , parent BF: 0-> 0 _ -> N l e r' -- R subtree BF: 0->+/-1, H:h->h+1, parent BF: 0->-1 @@ -259,7 +259,7 @@ 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 + E -> error "push: Bug3" -- impossible Z _ _ _ -> P l e r' -- R subtree BF:0-> 0, H:h->h , parent BF:+1->+1 _ -> Z l e r' -- R subtree BF:0->+/-1, H:h->h+1, parent BF:+1-> 0 @@ -267,7 +267,7 @@ -- (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 _ _ E = error "push: Bug4" -- impossible if BF=-1 putNR l e (N rl re rr) = let r' = putN rl re rr -- R subtree BF<>0, H:h->h, parent BF:-1->-1 in r' `seq` N l e r' putNR l e (P rl re rr) = let r' = putP rl re rr -- R subtree BF<>0, H:h->h, parent BF:-1->-1 @@ -279,7 +279,7 @@ -- (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 E _ _ = error "push: Bug5" -- impossible if BF=+1 putPL (N ll le lr) e r = let l' = putN ll le lr -- L subtree BF<>0, H:h->h, parent BF:+1->+1 in l' `seq` P l' e r putPL (P ll le lr) e r = let l' = putP ll le lr -- L subtree BF<>0, H:h->h, parent BF:+1->+1 @@ -303,7 +303,7 @@ 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 + E -> error "push: Bug6" -- impossible Z _ _ _ -> N l e (Z rl re rr') -- RR subtree BF: 0-> 0, H:h->h, so no change _ -> Z (Z l e rl) re rr' -- RR subtree BF: 0->+/-1, H:h->h+1, parent BF:-1->-2, CASE RR !! @@ -316,7 +316,7 @@ 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 + E -> error "push: Bug7" -- impossible Z _ _ _ -> P (Z ll' le lr) e r -- LL subtree BF: 0-> 0, H:h->h, so no change _ -> Z ll' le (Z lr e r) -- LL subtree BF: 0->+/-1, H:h->h+1, parent BF:-1->-2, CASE LL !! @@ -329,7 +329,7 @@ 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 + E -> error "push: Bug8" -- impossible Z _ _ _ -> N l e (Z rl' re rr) -- RL subtree BF: 0-> 0, H:h->h, so no change N rll' rle' rlr' -> Z (P l e rll') rle' (Z rlr' re rr) -- RL subtree BF: 0->-1, SO.. CASE RL(1) !! P rll' rle' rlr' -> Z (Z l e rll') rle' (N rlr' re rr) -- RL subtree BF: 0->+1, SO.. CASE RL(2) !! @@ -343,23 +343,23 @@ 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 + E -> error "push: Bug9" -- impossible Z _ _ _ -> P (Z ll le lr') e r -- LR subtree BF: 0-> 0, H:h->h, so no change N lrl' lre' lrr' -> Z (P ll le lrl') lre' (Z lrr' e r) -- LR subtree BF: 0->-1, SO.. CASE LR(2) !! P lrl' lre' lrr' -> Z (Z ll le lrl') lre' (N lrr' e r) -- LR subtree BF: 0->+1, SO.. CASE LR(1) !! ----------------------------------------------------------------------- -------------------------- genPush Ends Here ---------------------------- +------------------------- push Ends Here ---------------------------- ----------------------------------------------------------------------- --- | Almost identical to 'genPush', but this version forces evaluation of the default new element +-- | Almost identical to 'push', but this version forces evaluation of the default new element -- (second argument) if no matching element is found. Note that it does /not/ do this if -- a matching element is found, because in this case the default new element is discarded -- anyway. Note also that it does not force evaluation of any replacement value provided by the -- selector (if it returns Eq). (You have to do that yourself if that\'s what you want.) -- -- Complexity: O(log n) -genPush' :: (e -> COrdering e) -> e -> AVL e -> AVL e -genPush' c e0 = put where +push' :: (e -> COrdering e) -> e -> AVL e -> AVL e +push' c e0 = put where ----------------------------- LEVEL 0 --------------------------------- -- put -- ----------------------------------------------------------------------- @@ -404,7 +404,7 @@ 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 + E -> error "push': Bug0" -- impossible Z _ _ _ -> N l' e r -- L subtree BF:0-> 0, H:h->h , parent BF:-1->-1 _ -> Z l' e r -- L subtree BF:0->+/-1, H:h->h+1, parent BF:-1-> 0 @@ -417,7 +417,7 @@ 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 + E -> error "push': Bug1" -- impossible Z _ _ _ -> Z l' e r -- L subtree BF: 0-> 0, H:h->h , parent BF: 0-> 0 _ -> P l' e r -- L subtree BF: 0->+/-1, H:h->h+1, parent BF: 0->+1 @@ -430,7 +430,7 @@ 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 + E -> error "push': Bug2" -- impossible Z _ _ _ -> Z l e r' -- R subtree BF: 0-> 0, H:h->h , parent BF: 0-> 0 _ -> N l e r' -- R subtree BF: 0->+/-1, H:h->h+1, parent BF: 0->-1 @@ -443,7 +443,7 @@ 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 + E -> error "push': Bug3" -- impossible Z _ _ _ -> P l e r' -- R subtree BF:0-> 0, H:h->h , parent BF:+1->+1 _ -> Z l e r' -- R subtree BF:0->+/-1, H:h->h+1, parent BF:+1-> 0 @@ -451,7 +451,7 @@ -- (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 _ _ E = error "push': Bug4" -- impossible if BF=-1 putNR l e (N rl re rr) = let r' = putN rl re rr -- R subtree BF<>0, H:h->h, parent BF:-1->-1 in r' `seq` N l e r' putNR l e (P rl re rr) = let r' = putP rl re rr -- R subtree BF<>0, H:h->h, parent BF:-1->-1 @@ -463,7 +463,7 @@ -- (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 E _ _ = error "push': Bug5" -- impossible if BF=+1 putPL (N ll le lr) e r = let l' = putN ll le lr -- L subtree BF<>0, H:h->h, parent BF:+1->+1 in l' `seq` P l' e r putPL (P ll le lr) e r = let l' = putP ll le lr -- L subtree BF<>0, H:h->h, parent BF:+1->+1 @@ -487,7 +487,7 @@ 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 + E -> error "push': Bug6" -- impossible Z _ _ _ -> N l e (Z rl re rr') -- RR subtree BF: 0-> 0, H:h->h, so no change _ -> Z (Z l e rl) re rr' -- RR subtree BF: 0->+/-1, H:h->h+1, parent BF:-1->-2, CASE RR !! @@ -500,7 +500,7 @@ 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 + E -> error "push': Bug7" -- impossible Z _ _ _ -> P (Z ll' le lr) e r -- LL subtree BF: 0-> 0, H:h->h, so no change _ -> Z ll' le (Z lr e r) -- LL subtree BF: 0->+/-1, H:h->h+1, parent BF:-1->-2, CASE LL !! @@ -513,7 +513,7 @@ 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 + E -> error "push': Bug8" -- impossible Z _ _ _ -> N l e (Z rl' re rr) -- RL subtree BF: 0-> 0, H:h->h, so no change N rll' rle' rlr' -> Z (P l e rll') rle' (Z rlr' re rr) -- RL subtree BF: 0->-1, SO.. CASE RL(1) !! P rll' rle' rlr' -> Z (Z l e rll') rle' (N rlr' re rr) -- RL subtree BF: 0->+1, SO.. CASE RL(2) !! @@ -527,37 +527,37 @@ 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 + E -> error "push': Bug9" -- impossible Z _ _ _ -> P (Z ll le lr') e r -- LR subtree BF: 0-> 0, H:h->h, so no change N lrl' lre' lrr' -> Z (P ll le lrl') lre' (Z lrr' e r) -- LR subtree BF: 0->-1, SO.. CASE LR(2) !! P lrl' lre' lrr' -> Z (Z ll le lrl') lre' (N lrr' e r) -- LR subtree BF: 0->+1, SO.. CASE LR(1) !! ----------------------------------------------------------------------- -------------------------- genPush' Ends Here ---------------------------- +------------------------- push' Ends Here ---------------------------- ----------------------------------------------------------------------- --- | Similar to 'genPush', but returns the original tree if the combining comparison returns +-- | Similar to 'push', but returns the original tree if the combining comparison returns -- @('Eq' 'Nothing')@. So this function can be used reduce heap burn rate by avoiding duplication -- of nodes on the insertion path. But it may also be marginally slower otherwise. -- -- Note that this function is /non-strict/ in it\'s second argument (the default value which -- is inserted in the search fails or is discarded if the search succeeds). If you want --- to force evaluation, but only if it\'s actually incorprated in the tree, then use 'genPushMaybe'' +-- to force evaluation, but only if it\'s actually incorprated in the tree, then use 'pushMaybe'' -- -- Complexity: O(log n) -genPushMaybe :: (e -> COrdering (Maybe e)) -> e -> AVL e -> AVL e -genPushMaybe c e t = case genOpenPathWith c t of +pushMaybe :: (e -> COrdering (Maybe e)) -> e -> AVL e -> AVL e +pushMaybe c e t = case openPathWith c t of FullBP _ Nothing -> t FullBP p (Just e') -> writePath p e' t EmptyBP p -> insertPath p e t --- | Almost identical to 'genPushMaybe', but this version forces evaluation of the default new element +-- | Almost identical to 'pushMaybe', but this version forces evaluation of the default new element -- (second argument) if no matching element is found. Note that it does /not/ do this if -- a matching element is found, because in this case the default new element is discarded -- anyway. -- -- Complexity: O(log n) -genPushMaybe' :: (e -> COrdering (Maybe e)) -> e -> AVL e -> AVL e -genPushMaybe' c e t = case genOpenPathWith c t of +pushMaybe' :: (e -> COrdering (Maybe e)) -> e -> AVL e -> AVL e +pushMaybe' c e t = case openPathWith c t of FullBP _ Nothing -> t FullBP p (Just e') -> writePath p e' t EmptyBP p -> e `seq` insertPath p e t diff --git a/Data/Tree/AVL/Read.hs b/Data/Tree/AVL/Read.hs --- a/Data/Tree/AVL/Read.hs +++ b/Data/Tree/AVL/Read.hs @@ -16,10 +16,10 @@ assertReadR,tryReadR, -- ** Reading from /sorted/ AVL trees - genAssertRead,genTryRead,genTryReadMaybe,genDefaultRead, + assertRead,tryRead,tryReadMaybe,defaultRead, -- ** Simple searches of /sorted/ AVL trees - genContains, + contains, ) where import Prelude -- so haddock finds the symbols there @@ -95,9 +95,9 @@ -- 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." +assertRead :: AVL e -> (e -> COrdering a) -> a +assertRead t c = genRead' t where + genRead' E = error "assertRead failed." genRead' (N l e r) = genRead'' l e r genRead' (Z l e r) = genRead'' l e r genRead' (P l e r) = genRead'' l e r @@ -107,42 +107,42 @@ 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. +-- This function is similar to 'assertRead', 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 +tryRead :: AVL e -> (e -> COrdering a) -> Maybe a +tryRead t c = tryRead' t where + tryRead' E = Nothing + tryRead' (N l e r) = tryRead'' l e r + tryRead' (Z l e r) = tryRead'' l e r + tryRead' (P l e r) = tryRead'' l e r + tryRead'' l e r = case c e of + Lt -> tryRead' l + Eq a -> Just a + Gt -> tryRead' r -- | This version returns the result of the selector (without adding a 'Just' wrapper) if the search -- succeeds, or 'Nothing' if it fails. -- -- Complexity: O(log n) -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 +tryReadMaybe :: AVL e -> (e -> COrdering (Maybe a)) -> Maybe a +tryReadMaybe t c = tryRead' t where + tryRead' E = Nothing + tryRead' (N l e r) = tryRead'' l e r + tryRead' (Z l e r) = tryRead'' l e r + tryRead' (P l e r) = tryRead'' l e r + tryRead'' l e r = case c e of + Lt -> tryRead' l Eq mba -> mba - Gt -> genTryRead' r + Gt -> tryRead' 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 +-- This function is similar to 'assertRead', 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 +defaultRead :: a -> AVL e -> (e -> COrdering a) -> a +defaultRead d t c = genRead' t where genRead' E = d genRead' (N l e r) = genRead'' l e r genRead' (Z l e r) = genRead'' l e r @@ -156,13 +156,13 @@ -- 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 +contains :: AVL e -> (e -> Ordering) -> Bool +contains t c = contains' t where + contains' E = False + contains' (N l e r) = contains'' l e r + contains' (Z l e r) = contains'' l e r + contains' (P l e r) = contains'' l e r + contains'' l e r = case c e of + LT -> contains' l + EQ -> True + GT -> contains' r diff --git a/Data/Tree/AVL/Set.hs b/Data/Tree/AVL/Set.hs --- a/Data/Tree/AVL/Set.hs +++ b/Data/Tree/AVL/Set.hs @@ -17,13 +17,13 @@ -- as a field value in a record). -- ** Union - genUnion,genUnionMaybe,genDisjointUnion,genUnions, + union,unionMaybe,disjointUnion,unions, -- ** Difference - genDifference,genDifferenceMaybe,genSymDifference, + difference,differenceMaybe,symDifference, -- ** Intersection - genIntersection,genIntersectionMaybe, + intersection,intersectionMaybe, -- *** Intersection with the result as a list -- | Sometimes you don\'t want intersection to give a tree, particularly if the @@ -35,8 +35,8 @@ -- 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, + intersectionToList,intersectionAsList, + intersectionMaybeToList,intersectionMaybeAsList, -- ** \'Venn diagram\' operations -- | Given two sets A and B represented as sorted AVL trees, the venn operations evaluate @@ -44,17 +44,16 @@ -- rather than AVL tree if required. -- -- Note that in all cases the three resulting sets are /disjoint/ and can safely be re-combined - -- after most \"munging\" operations using 'genDisjointUnion'. - genVenn,genVennMaybe, + -- after most \"munging\" operations using 'disjointUnion'. + venn,vennMaybe, -- *** \'Venn diagram\' operations with the intersection component as a List. -- | These variants are provided for the same reasons as the Intersection as List variants. - genVennToList,genVennAsList, - genVennMaybeToList,genVennMaybeAsList, + vennToList,vennAsList, + vennMaybeToList,vennMaybeAsList, -- ** Subset - genIsSubsetOf,genIsSubsetOfBy - + isSubsetOf,isSubsetOfBy, ) where import Prelude -- so haddock finds the symbols there @@ -82,9 +81,8 @@ -- 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 +union :: (e -> e -> COrdering e) -> AVL e -> AVL e -> AVL e +union c = gu where -- This is to avoid O(log n) height calculation for empty sets gu E t1 = t1 gu t0 E = t0 gu t0@(N l0 _ _ ) t1@(N l1 _ _ ) = gu_ t0 (addHeight L(2) l0) t1 (addHeight L(2) l1) @@ -98,12 +96,12 @@ 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 +-- | Similar to 'union', but the resulting tree does not include elements in cases where -- the supplied combining comparison returns @(Eq Nothing)@. -- -- Complexity: Not sure, but I\'d appreciate it if someone could figure it out. -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 +unionMaybe :: (e -> e -> COrdering (Maybe e)) -> AVL e -> AVL e -> AVL e +unionMaybe c = gu where -- This is to avoid O(log n) height calculation for empty sets gu E t1 = t1 gu t0 E = t0 gu t0@(N l0 _ _ ) t1@(N l1 _ _ ) = gu_ t0 (addHeight L(2) l0) t1 (addHeight L(2) l1) @@ -118,14 +116,14 @@ gu_ t0 h0 t1 h1 = case unionMaybeH c t0 h0 t1 h1 of UBT2(t,_) -> t -- | Uses the supplied comparison to evaluate the union of two /disjoint/ sets represented as --- sorted AVL trees. It will be slightly faster than 'genUnion' but will raise an error if the +-- sorted AVL trees. It will be slightly faster than 'union' but will raise an error if the -- two sets intersect. Typically this would be used to re-combine the \"post-munge\" results -- from one of the \"venn\" operations. -- -- Complexity: Not sure, but I\'d appreciate it if someone could figure it out. -- (Faster than Hedge union from Data.Set at any rate). -genDisjointUnion :: (e -> e -> Ordering) -> AVL e -> AVL e -> AVL e -genDisjointUnion c = gu where -- This is to avoid O(log n) height calculation for empty sets +disjointUnion :: (e -> e -> Ordering) -> AVL e -> AVL e -> AVL e +disjointUnion c = gu where -- This is to avoid O(log n) height calculation for empty sets gu E t1 = t1 gu t0 E = t0 gu t0@(N l0 _ _ ) t1@(N l1 _ _ ) = gu_ t0 (addHeight L(2) l0) t1 (addHeight L(2) l1) @@ -142,9 +140,9 @@ -- | 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 +-- @unions ccmp avls = foldl' ('union' ccmp) empty avls@ +unions :: (e -> e -> COrdering e) -> [AVL e] -> AVL e +unions c = gus E L(0) where gus a _ [] = a gus a ha ( E :avls) = gus a ha avls gus a ha (t@(N l _ _):avls) = case unionH c a ha t (addHeight L(2) l) of UBT2(a_,ha_) -> gus a_ ha_ avls @@ -155,24 +153,24 @@ -- 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 +intersection :: (a -> b -> COrdering c) -> AVL a -> AVL b -> AVL c +intersection c t0 t1 = case intersectionH c t0 t1 of UBT2(t,_) -> t --- | Similar to 'genIntersection', but the resulting tree does not include elements in cases where +-- | Similar to 'intersection', but the resulting tree does not include elements in cases where -- the supplied combining comparison returns @(Eq Nothing)@. -- -- Complexity: Not sure, but I\'d appreciate it if someone could figure it out. -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 +intersectionMaybe :: (a -> b -> COrdering (Maybe c)) -> AVL a -> AVL b -> AVL c +intersectionMaybe c t0 t1 = case intersectionMaybeH c t0 t1 of UBT2(t,_) -> t --- | Similar to 'genIntersection', but prepends the result to the supplied list in --- left to right order. This is a (++) free function which behaves as if defined: +-- | Similar to 'intersection', but prepends the result to the supplied list in +-- ascending order. This is a (++) free function which behaves as if defined: -- --- @genIntersectionToListL c setA setB cs = asListL (genIntersection c setA setB) ++ cs@ +-- @intersectionToList c setA setB cs = asListL (intersection c setA setB) ++ cs@ -- -- Complexity: Not sure, but I\'d appreciate it if someone could figure it out. -genIntersectionToListL :: (a -> b -> COrdering c) -> AVL a -> AVL b -> [c] -> [c] -genIntersectionToListL comp = i where +intersectionToList :: (a -> b -> COrdering c) -> AVL a -> AVL b -> [c] -> [c] +intersectionToList comp = i where -- i :: AVL a -> AVL b -> [c] -> [c] i E _ cs = cs i _ E cs = cs @@ -244,21 +242,21 @@ 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 ------------------- +------------------ intersectionToList Ends Here ------------------- ----------------------------------------------------------------------- --- | Applies 'genIntersectionToListL' to the empty list. +-- | Applies 'intersectionToList' 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 [] +intersectionAsList :: (a -> b -> COrdering c) -> AVL a -> AVL b -> [c] +intersectionAsList c setA setB = intersectionToList c setA setB [] --- | Similar to 'genIntersectionToListL', but the result does not include elements in cases where +-- | Similar to 'intersectionToList', but the result does not include elements in cases where -- the supplied combining comparison returns @(Eq Nothing)@. -- -- Complexity: Not sure, but I\'d appreciate it if someone could figure it out. -genIntersectionMaybeToListL :: (a -> b -> COrdering (Maybe c)) -> AVL a -> AVL b -> [c] -> [c] -genIntersectionMaybeToListL comp = i where +intersectionMaybeToList :: (a -> b -> COrdering (Maybe c)) -> AVL a -> AVL b -> [c] -> [c] +intersectionMaybeToList comp = i where -- i :: AVL a -> AVL b -> [c] -> [c] i E _ cs = cs i _ E cs = cs @@ -332,34 +330,34 @@ 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 ---------------- +---------------- intersectionMaybeToList Ends Here ---------------- ----------------------------------------------------------------------- --- | Applies 'genIntersectionMaybeToListL' to the empty list. +-- | Applies 'intersectionMaybeToList' 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 [] +intersectionMaybeAsList :: (a -> b -> COrdering (Maybe c)) -> AVL a -> AVL b -> [c] +intersectionMaybeAsList c setA setB = intersectionMaybeToList c setA setB [] -- | Uses the supplied comparison to evaluate the difference between two sets represented as -- sorted AVL trees. The expression.. -- --- > genDifference cmp setA setB +-- > difference cmp setA setB -- -- .. is a set containing all those elements of @setA@ which do not appear in @setB@. -- -- Complexity: Not sure, but I\'d appreciate it if someone could figure it out. -genDifference :: (a -> b -> Ordering) -> AVL a -> AVL b -> AVL a +difference :: (a -> b -> Ordering) -> AVL a -> AVL b -> AVL a -- N.B. differenceH works with relative heights on first tree, and needs no height for the second. -genDifference c t0 t1 = case differenceH c t0 L(0) t1 of UBT2(t,_) -> t +difference 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 +-- | Similar to 'difference', but the resulting tree also includes those elements a\' for which the -- combining comparison returns @(Eq (Just a\'))@. -- -- Complexity: Not sure, but I\'d appreciate it if someone could figure it out. -genDifferenceMaybe :: (a -> b -> COrdering (Maybe a)) -> AVL a -> AVL b -> AVL a +differenceMaybe :: (a -> b -> COrdering (Maybe a)) -> AVL a -> AVL b -> AVL a -- N.B. differenceMaybeH works with relative heights on first tree, and needs no height for the second. -genDifferenceMaybe c t0 t1 = case differenceMaybeH c t0 L(0) t1 of UBT2(t,_) -> t +differenceMaybe c t0 t1 = case differenceMaybeH c t0 L(0) t1 of UBT2(t,_) -> t -- | Uses the supplied comparison to test whether the first set is a subset of the second, -- both sets being represented as sorted AVL trees. This function returns True if any of @@ -372,8 +370,8 @@ -- * 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 +isSubsetOf :: (a -> b -> Ordering) -> AVL a -> AVL b -> Bool +isSubsetOf comp = s where -- s :: AVL a -> AVL b -> Bool s E _ = True s _ E = False @@ -433,15 +431,15 @@ UBT4(t0,ht0,t1,ht1) -> case spliceH t1 ht1 e r hr of UBT2(t1_,ht1_) -> UBT4(t0,ht0,t1_,ht1_) ----------------------------------------------------------------------- ------------------------- genIsSubsetOf Ends Here ---------------------- +------------------------ isSubsetOf Ends Here ---------------------- ----------------------------------------------------------------------- --- | Similar to 'genIsSubsetOf', but also requires that the supplied combining +-- | Similar to 'isSubsetOf', but also requires that the supplied combining -- comparison returns @('Eq' True)@ for matching elements. -- -- Complexity: Not sure, but I\'d appreciate it if someone could figure it out. -genIsSubsetOfBy :: (a -> b -> COrdering Bool) -> AVL a -> AVL b -> Bool -genIsSubsetOfBy comp = s where +isSubsetOfBy :: (a -> b -> COrdering Bool) -> AVL a -> AVL b -> Bool +isSubsetOfBy comp = s where -- s :: AVL a -> AVL b -> Bool s E _ = True s _ E = False @@ -506,14 +504,14 @@ 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 --------------------- +----------------------- isSubsetOfBy Ends Here --------------------- ----------------------------------------------------------------------- -- | The symmetric difference is the set of elements which occur in one set or the other but /not both/. -- -- Complexity: Not sure, but I\'d appreciate it if someone could figure it out. -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 +symDifference :: (e -> e -> Ordering) -> AVL e -> AVL e -> AVL e +symDifference c = gu where -- This is to avoid O(log n) height calculation for empty sets gu E t1 = t1 gu t0 E = t0 gu t0@(N l0 _ _ ) t1@(N l1 _ _ ) = gu_ t0 (addHeight L(2) l0) t1 (addHeight L(2) l1) @@ -529,11 +527,11 @@ -- | Given two Sets @A@ and @B@ represented as sorted AVL trees, this function -- extracts the \'Venn diagram\' components @A-B@, @A.B@ and @B-A@. --- See also 'genVennMaybe'. +-- See also 'vennMaybe'. -- -- Complexity: Not sure, but I\'d appreciate it if someone could figure it out. -genVenn :: (a -> b -> COrdering c) -> AVL a -> AVL b -> (AVL a, AVL c, AVL b) -genVenn c = gu where -- This is to avoid O(log n) height calculation for empty sets +venn :: (a -> b -> COrdering c) -> AVL a -> AVL b -> (AVL a, AVL c, AVL b) +venn c = gu where -- This is to avoid O(log n) height calculation for empty sets gu E t1 = (E ,E,t1) gu t0 E = (t0,E,E ) gu t0@(N l0 _ _ ) t1@(N l1 _ _ ) = gu_ t0 (addHeight L(2) l0) t1 (addHeight L(2) l1) @@ -549,12 +547,12 @@ UBT6(tab,_,cs,cl,tba,_) -> let tc = asTreeLenL ASINT(cl) cs in tc `seq` (tab,tc,tba) --- | Similar to 'genVenn', but intersection elements for which the combining comparison +-- | Similar to 'venn', but intersection elements for which the combining comparison -- returns @('Eq' 'Nothing')@ are deleted from the intersection result. -- -- Complexity: Not sure, but I\'d appreciate it if someone could figure it out. -genVennMaybe :: (a -> b -> COrdering (Maybe c)) -> AVL a -> AVL b -> (AVL a, AVL c, AVL b) -genVennMaybe c = gu where -- This is to avoid O(log n) height calculation for empty sets +vennMaybe :: (a -> b -> COrdering (Maybe c)) -> AVL a -> AVL b -> (AVL a, AVL c, AVL b) +vennMaybe c = gu where -- This is to avoid O(log n) height calculation for empty sets gu E t1 = (E ,E,t1) gu t0 E = (t0,E,E ) gu t0@(N l0 _ _ ) t1@(N l1 _ _ ) = gu_ t0 (addHeight L(2) l0) t1 (addHeight L(2) l1) @@ -570,10 +568,10 @@ UBT6(tab,_,cs,cl,tba,_) -> let tc = asTreeLenL ASINT(cl) cs in tc `seq` (tab,tc,tba) --- | Same as 'genVenn', but prepends the intersection component to the supplied list +-- | Same as 'venn', but prepends the intersection component to the supplied list -- in ascending order. -genVennToList :: (a -> b -> COrdering c) -> [c] -> AVL a -> AVL b -> (AVL a, [c], AVL b) -genVennToList cmp cs = gu where -- This is to avoid O(log n) height calculation for empty sets +vennToList :: (a -> b -> COrdering c) -> [c] -> AVL a -> AVL b -> (AVL a, [c], AVL b) +vennToList cmp cs = gu where -- This is to avoid O(log n) height calculation for empty sets gu E t1 = (E ,cs,t1) gu t0 E = (t0,cs,E ) gu t0@(N l0 _ _ ) t1@(N l1 _ _ ) = gu_ t0 (addHeight L(2) l0) t1 (addHeight L(2) l1) @@ -588,10 +586,10 @@ gu_ t0 h0 t1 h1 = case vennH cmp cs L(0) t0 h0 t1 h1 of UBT6(tab,_,cs_,_,tba,_) -> (tab,cs_,tba) --- | Same as 'genVennMaybe', but prepends the intersection component to the supplied list +-- | Same as 'vennMaybe', but prepends the intersection component to the supplied list -- in ascending order. -genVennMaybeToList :: (a -> b -> COrdering (Maybe c)) -> [c] -> AVL a -> AVL b -> (AVL a, [c], AVL b) -genVennMaybeToList cmp cs = gu where -- This is to avoid O(log n) height calculation for empty sets +vennMaybeToList :: (a -> b -> COrdering (Maybe c)) -> [c] -> AVL a -> AVL b -> (AVL a, [c], AVL b) +vennMaybeToList cmp cs = gu where -- This is to avoid O(log n) height calculation for empty sets gu E t1 = (E ,cs,t1) gu t0 E = (t0,cs,E ) gu t0@(N l0 _ _ ) t1@(N l1 _ _ ) = gu_ t0 (addHeight L(2) l0) t1 (addHeight L(2) l1) @@ -606,15 +604,15 @@ gu_ t0 h0 t1 h1 = case vennMaybeH cmp cs L(0) t0 h0 t1 h1 of UBT6(tab,_,cs_,_,tba,_) -> (tab,cs_,tba) --- | Same as 'genVenn', but returns the intersection component as a list in ascending order. --- This is just 'genVennToList' applied to an empty initial intersection list. -genVennAsList :: (a -> b -> COrdering c) -> AVL a -> AVL b -> (AVL a, [c], AVL b) -{-# INLINE genVennAsList #-} -genVennAsList cmp = genVennToList cmp [] +-- | Same as 'venn', but returns the intersection component as a list in ascending order. +-- This is just 'vennToList' applied to an empty initial intersection list. +vennAsList :: (a -> b -> COrdering c) -> AVL a -> AVL b -> (AVL a, [c], AVL b) +vennAsList cmp = vennToList cmp [] +{-# INLINE vennAsList #-} --- | Same as 'genVennMaybe', but returns the intersection component as a list in ascending order. --- This is just 'genVennMaybeToList' applied to an empty initial intersection list. -genVennMaybeAsList :: (a -> b -> COrdering (Maybe c)) -> AVL a -> AVL b -> (AVL a, [c], AVL b) -{-# INLINE genVennMaybeAsList #-} -genVennMaybeAsList cmp = genVennMaybeToList cmp [] +-- | Same as 'vennMaybe', but returns the intersection component as a list in ascending order. +-- This is just 'vennMaybeToList' applied to an empty initial intersection list. +vennMaybeAsList :: (a -> b -> COrdering (Maybe c)) -> AVL a -> AVL b -> (AVL a, [c], AVL b) +vennMaybeAsList cmp = vennMaybeToList cmp [] +{-# INLINE vennMaybeAsList #-} diff --git a/Data/Tree/AVL/Size.hs b/Data/Tree/AVL/Size.hs --- a/Data/Tree/AVL/Size.hs +++ b/Data/Tree/AVL/Size.hs @@ -13,7 +13,12 @@ ----------------------------------------------------------------------------- module Data.Tree.AVL.Size (-- * AVL tree size utilities. - size,addSize,fastAddSize,clipSize + size,addSize,clipSize, + +#ifdef __GLASGOW_HASKELL__ + -- ** (GHC Only) + addSize#,size#, +#endif ) where import Data.Tree.AVL.Types(AVL(..)) @@ -26,23 +31,37 @@ #include "h98defs.h" #endif --- | Counts the total number of elements in an AVL tree. --- --- @'size' = 'addSize' 0@ --- --- Complexity: O(n) -{-# INLINE size #-} +#ifdef __GLASGOW_HASKELL__ +import GHC.Base +#include "ghcdefs.h" + +-- | A convenience wrapper for 'addSize#'. size :: AVL e -> Int -size = addSize 0 +size t = ASINT(addSize# L(0) t) +{-# INLINE size #-} --- | Adds the size of a tree to the first argument. --- This is just a convenience wrapper for 'fastAddSize'. --- --- Complexity: O(n) -{-# INLINE addSize #-} +-- | A convenience wrapper for 'addSize#'. +size# :: AVL e -> UINT +size# t = addSize# L(0) t +{-# INLINE size# #-} + +-- | See 'addSize#'. addSize :: Int -> AVL e -> Int -addSize ASINT(n) t = ASINT(fastAddSize n t) +addSize ASINT(n) t = ASINT(addSize# n t) +{-# INLINE addSize #-} +#define AddSize addSize# +#else +#include "h98defs.h" + +-- | A convenience wrapper for 'addSize'. +size :: AVL e -> Int +size t = addSize 0 t +{-# INLINE size #-} + +#define AddSize addSize +#endif + {----------------------------------------- Notes for fast size calculation. case (h,avl) @@ -55,26 +74,26 @@ (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 +-- | Fast algorithm to add the size of a tree to the first argument. This avoids visiting about 50% of tree nodes -- by using fact that trees with small heights can only have particular shapes. -- So it's still O(n), but with substantial saving in constant factors. -- -- Complexity: O(n) -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 +AddSize :: UINT -> AVL e -> UINT +AddSize n E = n +AddSize n (N l _ r) = case addHeight L(2) l of + L(2) -> INCINT2(n) + L(3) -> fas2 INCINT2(n) r + h -> fasNP n h l r +AddSize n (Z l _ r) = case addHeight L(1) l of + L(1) -> INCINT1(n) + L(2) -> INCINT3(n) + L(3) -> fas2 (fas2 INCINT1(n) l) r + h -> fasZ n h l r +AddSize n (P l _ r) = case addHeight L(2) r of + L(2) -> INCINT2(n) + L(3) -> fas2 INCINT2(n) l + h -> fasNP n h r l -- Parent Height (h) >= 4 !! fasNP,fasZ :: UINT -> UINT -> AVL e -> AVL e -> UINT fasNP n h l r = fasG3 (fasG2 INCINT1(n) DECINT2(h) l) DECINT1(h) r @@ -92,13 +111,13 @@ 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 +fasG3 _ _ E = error "AddSize: Bad Tree." -- impossible -- h=2 !! fas2 :: UINT -> AVL e -> UINT fas2 n (N _ _ _) = INCINT2(n) fas2 n (Z _ _ _) = INCINT3(n) fas2 n (P _ _ _) = INCINT2(n) -fas2 _ E = error "fastAddSize: Bad Tree." -- impossible +fas2 _ E = error "AddSize: Bad Tree." -- impossible {-# INLINE fas2 #-} ----------------------------------------------------------------------- ----------------------- fastAddSize Ends Here ------------------------- @@ -106,7 +125,7 @@ -- | 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'. +-- the clip value. This function exploits the same optimisation as 'addSize'. -- -- Complexity: O(min n c) where n is tree size and c is clip value. clipSize :: Int -> AVL e -> Maybe Int diff --git a/Data/Tree/AVL/Split.hs b/Data/Tree/AVL/Split.hs --- a/Data/Tree/AVL/Split.hs +++ b/Data/Tree/AVL/Split.hs @@ -37,15 +37,15 @@ -- 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 + -- So (for example) the result of the 'takeLT' function is a tree containing all those elements -- which are less than the notional search key. That is, all those elements for which the -- supplied selector returns GT (not LT as you might expect). I know that seems backwards, but -- it's consistent if you think about it. - genForkL,genForkR,genFork, - genTakeLE,genDropGT, - genTakeLT,genDropGE, - genTakeGT,genDropLE, - genTakeGE,genDropLT, + forkL,forkR,fork, + takeLE,dropGT, + takeLT,dropGE, + takeGT,dropLE, + takeGE,dropLT, ) where import Prelude -- so haddock finds the symbols there @@ -653,17 +653,17 @@ -- 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 +forkL :: (e -> Ordering) -> AVL e -> (AVL e, AVL e) +forkL c avl = let (HAVL l _,HAVL r _) = forkL_ L(0) avl -- Tree heights are relative in (l,r) where - 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 + forkL_ h E = (HAVL E h, HAVL E h) + forkL_ h (N l e r) = forkL__ l DECINT2(h) e r DECINT1(h) + forkL_ h (Z l e r) = forkL__ l DECINT1(h) e r DECINT1(h) + forkL_ h (P l e r) = forkL__ l DECINT1(h) e r DECINT2(h) + forkL__ l hl e r hr = case c e of -- Current element > pivot, so goes in right half - LT -> let (havl0,havl1) = genForkL_ hl l + LT -> let (havl0,havl1) = forkL_ hl l havl1_ = spliceHAVL havl1 e (HAVL r hr) in havl1_ `seq` (havl0, havl1_) -- Current element = pivot, so goes in left half and stop here @@ -671,7 +671,7 @@ 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 + GT -> let (havl0,havl1) = forkL_ hr r havl0_ = spliceHAVL (HAVL l hl) e havl0 in havl0_ `seq` (havl0_, havl1) @@ -680,17 +680,17 @@ -- 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 +forkR :: (e -> Ordering) -> AVL e -> (AVL e, AVL e) +forkR c avl = let (HAVL l _,HAVL r _) = forkR_ L(0) avl -- Tree heights are relative in (l,r) where - 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 + forkR_ h E = (HAVL E h, HAVL E h) + forkR_ h (N l e r) = forkR__ l DECINT2(h) e r DECINT1(h) + forkR_ h (Z l e r) = forkR__ l DECINT1(h) e r DECINT1(h) + forkR_ h (P l e r) = forkR__ l DECINT1(h) e r DECINT2(h) + forkR__ l hl e r hr = case c e of -- Current element > pivot, so goes in right half - LT -> let (havl0,havl1) = genForkR_ hl l + LT -> let (havl0,havl1) = forkR_ hl l havl1_ = spliceHAVL havl1 e (HAVL r hr) in havl1_ `seq` (havl0, havl1_) -- Current element = pivot, so goes in right half and stop here @@ -698,26 +698,26 @@ 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 + GT -> let (havl0,havl1) = forkR_ 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 +-- | Similar to 'forkL' and 'forkR', but returns any equal element found (instead of -- incorporating it into the left or right tree results respectively). -- -- Complexity: O(log n) -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 +fork :: (e -> COrdering a) -> AVL e -> (AVL e, Maybe a, AVL e) +fork c avl = let (HAVL l _, mba, HAVL r _) = fork_ L(0) avl -- Tree heights are relative in (l,mba,r) where - 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 + fork_ h E = (HAVL E h, Nothing, HAVL E h) + fork_ h (N l e r) = fork__ l DECINT2(h) e r DECINT1(h) + fork_ h (Z l e r) = fork__ l DECINT1(h) e r DECINT1(h) + fork_ h (P l e r) = fork__ l DECINT1(h) e r DECINT2(h) + fork__ l hl e r hr = case c e of -- Current element > pivot - Lt -> let (havl0,mba,havl1) = genFork_ hl l + Lt -> let (havl0,mba,havl1) = fork_ hl l havl1_ = spliceHAVL havl1 e (HAVL r hr) in havl1_ `seq` (havl0, mba, havl1_) -- Current element = pivot @@ -725,113 +725,113 @@ rhavl = HAVL r hr in lhavl `seq` rhavl `seq` (lhavl, Just a, rhavl) -- Current element < pivot - Gt -> let (havl0,mba,havl1) = genFork_ hr r + Gt -> let (havl0,mba,havl1) = fork_ hr r havl0_ = spliceHAVL (HAVL l hl) e havl0 in havl0_ `seq` (havl0_, mba, havl1) --- | This is a simplified version of 'genForkL' which returns a sorted tree containing +-- | This is a simplified version of 'forkL' which returns a sorted tree containing -- only those elements which are less than or equal to according to the supplied selector. --- This function also has the synonym 'genDropGT'. +-- This function also has the synonym 'dropGT'. -- -- 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 +takeLE :: (e -> Ordering) -> AVL e -> AVL e +takeLE c avl = let HAVL l _ = forkL_ 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 + forkL_ h E = HAVL E h + forkL_ h (N l e r) = forkL__ l DECINT2(h) e r DECINT1(h) + forkL_ h (Z l e r) = forkL__ l DECINT1(h) e r DECINT1(h) + forkL_ h (P l e r) = forkL__ l DECINT1(h) e r DECINT2(h) + forkL__ l hl e r hr = case c e of + LT -> forkL_ hl l EQ -> pushRHAVL (HAVL l hl) e - GT -> let havl0 = genForkL_ hr r + GT -> let havl0 = forkL_ hr r in spliceHAVL (HAVL l hl) e havl0 --- | A synonym for 'genTakeLE'. +-- | A synonym for 'takeLE'. -- -- Complexity: O(log n) -{-# INLINE genDropGT #-} -genDropGT :: (e -> Ordering) -> AVL e -> AVL e -genDropGT = genTakeLE +dropGT :: (e -> Ordering) -> AVL e -> AVL e +dropGT = takeLE +{-# INLINE dropGT #-} --- | This is a simplified version of 'genForkL' which returns a sorted tree containing +-- | This is a simplified version of 'forkL' which returns a sorted tree containing -- only those elements which are greater according to the supplied selector. --- This function also has the synonym 'genDropLE'. +-- This function also has the synonym 'dropLE'. -- -- 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 +takeGT :: (e -> Ordering) -> AVL e -> AVL e +takeGT c avl = let HAVL r _ = forkL_ 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 + forkL_ h E = HAVL E h + forkL_ h (N l e r) = forkL__ l DECINT2(h) e r DECINT1(h) + forkL_ h (Z l e r) = forkL__ l DECINT1(h) e r DECINT1(h) + forkL_ h (P l e r) = forkL__ l DECINT1(h) e r DECINT2(h) + forkL__ l hl e r hr = case c e of + LT -> let havl1 = forkL_ hl l in spliceHAVL havl1 e (HAVL r hr) EQ -> HAVL r hr - GT -> genForkL_ hr r + GT -> forkL_ hr r --- | A synonym for 'genTakeGT'. +-- | A synonym for 'takeGT'. -- -- Complexity: O(log n) -{-# INLINE genDropLE #-} -genDropLE :: (e -> Ordering) -> AVL e -> AVL e -genDropLE = genTakeGT +dropLE :: (e -> Ordering) -> AVL e -> AVL e +dropLE = takeGT +{-# INLINE dropLE #-} --- | This is a simplified version of 'genForkR' which returns a sorted tree containing +-- | This is a simplified version of 'forkR' which returns a sorted tree containing -- only those elements which are less than according to the supplied selector. --- This function also has the synonym 'genDropGE'. +-- This function also has the synonym 'dropGE'. -- -- 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 +takeLT :: (e -> Ordering) -> AVL e -> AVL e +takeLT c avl = let HAVL l _ = forkL_ 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 + forkL_ h E = HAVL E h + forkL_ h (N l e r) = forkL__ l DECINT2(h) e r DECINT1(h) + forkL_ h (Z l e r) = forkL__ l DECINT1(h) e r DECINT1(h) + forkL_ h (P l e r) = forkL__ l DECINT1(h) e r DECINT2(h) + forkL__ l hl e r hr = case c e of + LT -> forkL_ hl l EQ -> HAVL l hl - GT -> let havl0 = genForkL_ hr r + GT -> let havl0 = forkL_ hr r in spliceHAVL (HAVL l hl) e havl0 --- | A synonym for 'genTakeLT'. +-- | A synonym for 'takeLT'. -- -- Complexity: O(log n) -{-# INLINE genDropGE #-} -genDropGE :: (e -> Ordering) -> AVL e -> AVL e -genDropGE = genTakeLT +dropGE :: (e -> Ordering) -> AVL e -> AVL e +dropGE = takeLT +{-# INLINE dropGE #-} --- | This is a simplified version of 'genForkR' which returns a sorted tree containing +-- | This is a simplified version of 'forkR' which returns a sorted tree containing -- only those elements which are greater or equal to according to the supplied selector. --- This function also has the synonym 'genDropLT'. +-- This function also has the synonym 'dropLT'. -- -- 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 +takeGE :: (e -> Ordering) -> AVL e -> AVL e +takeGE c avl = let HAVL r _ = forkL_ 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 + forkL_ h E = HAVL E h + forkL_ h (N l e r) = forkL__ l DECINT2(h) e r DECINT1(h) + forkL_ h (Z l e r) = forkL__ l DECINT1(h) e r DECINT1(h) + forkL_ h (P l e r) = forkL__ l DECINT1(h) e r DECINT2(h) + forkL__ l hl e r hr = case c e of + LT -> let havl1 = forkL_ hl l in spliceHAVL havl1 e (HAVL r hr) EQ -> pushLHAVL e (HAVL r hr) - GT -> genForkL_ hr r + GT -> forkL_ hr r --- | A synonym for 'genTakeGE'. +-- | A synonym for 'takeGE'. -- -- Complexity: O(log n) -{-# INLINE genDropLT #-} -genDropLT :: (e -> Ordering) -> AVL e -> AVL e -genDropLT = genTakeGE +dropLT :: (e -> Ordering) -> AVL e -> AVL e +dropLT = takeGE +{-# INLINE dropLT #-} diff --git a/Data/Tree/AVL/Test/AllTests.hs b/Data/Tree/AVL/Test/AllTests.hs --- a/Data/Tree/AVL/Test/AllTests.hs +++ b/Data/Tree/AVL/Test/AllTests.hs @@ -21,1446 +21,1453 @@ ,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 -,testGenDisjointUnion -,testGenUnionMaybe -,testGenIntersection -,testGenIntersectionMaybe -,testGenIntersectionAsListL -,testGenIntersectionMaybeAsListL -,testGenDifference -,testGenDifferenceMaybe -,testGenSymDifference -,testGenIsSubsetOf -,testGenIsSubsetOfBy -,testGenVenn -,testGenVennMaybe -,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 - testGenDisjointUnion - testGenUnionMaybe - testGenIntersection - testGenIntersectionMaybe - testGenIntersectionAsListL - testGenIntersectionMaybeAsListL - testGenDifference - testGenDifferenceMaybe - testGenSymDifference - testGenIsSubsetOf - testGenIsSubsetOfBy - testGenVenn - testGenVennMaybe - 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 genDisjointUnion function -testGenDisjointUnion :: IO () -testGenDisjointUnion = - let trees = take num $ concatMap (\(_,ts) -> ts) allAVL - num = 1000 - in do title "genDisjointUnion" - putStrLn $ "Testing " ++ show (num*num) ++ " tree pairs.." - if and [test (mapAVL' (\n -> 2*n) l) ls (mapAVL' (\n -> 2*n+1) r) rs - | (l,ls) <- trees -- 0,2..2*ls-2 - , (r,rs) <- trees -- 1,3..2*rs-1 - ] - then passed - else failed - where test l ls r rs = all (\f -> f l ls r rs) [test1] - test1 l ls r rs = and [test1_ $ mapAVL' (+(2*n)) r | n <- [(-rs)..(ls-1)]] - where test1_ r_ = let u = genDisjointUnion compare l r_ - in isBalanced u && (asListL u == listUnion (asListL l) (asListL r_)) - --- | 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_ && (asListL u_ == asListL 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_ && (asListL u_ == asListL 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 the genVenn function -testGenVenn :: IO () -testGenVenn = - let trees = concatMap (\(_,ts) -> ts) (take 5 allAVL) -- All trees of height 4 or less = 335 trees (112,225 pairs) - num = length trees - in do title "genVenn" - putStrLn $ "Testing " ++ show (num*num) ++ " tree pairs.." - if and [test l ls r rs | (l,ls) <- trees, (r,rs) <- trees] then passed else failed - where test l ls r rs = all (\f -> f l ls r rs) [test1,test2] - test1 l ls r rs = let (lr,i,rl) = venn l r - in and [all isBalanced [lr,i,rl] - ,asListL lr == listDiff [0..ls-1] [0..rs-1] - ,asListL i == listIntersection [0..ls-1] [0..rs-1] - ,asListL rl == listDiff [0..rs-1] [0..ls-1] - ] - test2 l ls r rs = and [test2_ $ mapAVL' (n+) r | n <- [(-rs)..ls]] - where test2_ r_ = let (lr,i,rl) = venn l r_ - in and [all isBalanced [lr,i,rl] - ,asListL lr == listDiff (asListL l ) (asListL r_) - ,asListL i == listIntersection (asListL l ) (asListL r_) - ,asListL rl == listDiff (asListL r_) (asListL l ) - ] - venn = genVenn fstCC - --- | Test the genVennMaybe function -testGenVennMaybe :: IO () -testGenVennMaybe = - let trees = concatMap (\(_,ts) -> ts) (take 5 allAVL) -- All trees of height 4 or less = 335 trees (112,225 pairs) - num = length trees - in do title "genVennMaybe" - putStrLn $ "Testing " ++ show (num*num) ++ " tree pairs.." - if and [test l ls r rs | (l,ls) <- trees, (r,rs) <- trees] then passed else failed - where test l ls r rs = and [t cmp l ls r rs| t<-[test1], cmp<-[cmpAll,cmpNone,cmpEven,cmpOdd]] - test1 cmp l ls r rs = and [test1_ $ mapAVL' (n+) r | n <- [(-rs)..ls]] - where test1_ r_ = let (lr,i,rl) = genVennMaybe cmp l r_ - in and [all isBalanced [lr,i,rl] - ,asListL lr == listDiff (asListL l ) (asListL r_) - ,asListL rl == listDiff (asListL r_) (asListL l ) - ,asListL i == listIntersectionMaybe cmp (asListL l ) (asListL r_) - ] - cmpAll = withCC' (\x _ -> Just x) - cmpNone = withCC' (\_ _ -> Nothing) - cmpEven = withCC' (\x _ -> if even x then Just x else Nothing) - cmpOdd = withCC' (\x _ -> if odd x then Just x else Nothing) - --- | 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) '*' +,testWrite +,testPush +,testPushL +,testPushR +,testDelete +,testAssertDelL +,testAssertDelR +,testAssertPopL +,testPopHL +,testAssertPopR +,testAssertPop +,testFlatten +,testJoin +,testJoinHAVL +,testConcatAVL +,testFlatConcat +,testFoldr +,testFoldr' +,testFoldl +,testFoldl' +,testFoldr1 +,testFoldr1' +,testFoldl1 +,testFoldl1' +,testMapAccumL +,testMapAccumR +,testMapAccumL' +,testMapAccumR' +#ifdef __GLASGOW_HASKELL__ +,testMapAccumL'' +,testMapAccumR'' +#endif +,testSplitAtL +,testFilterViaList +,testFilter +,testMapMaybeViaList +,testMapMaybe +,testTakeL +,testDropL +,testSplitAtR +,testTakeR +,testDropR +,testSpanL +,testTakeWhileL +,testDropWhileL +,testSpanR +,testTakeWhileR +,testDropWhileR +,testRotateL +,testRotateR +,testRotateByL +,testRotateByR +,testForkL +,testForkR +,testFork +,testTakeLE +,testTakeGT +,testTakeGE +,testTakeLT +,testUnion +,testDisjointUnion +,testUnionMaybe +,testIntersection +,testIntersectionMaybe +,testIntersectionAsList +,testIntersectionMaybeAsList +,testDifference +,testDifferenceMaybe +,testSymDifference +,testIsSubsetOf +,testIsSubsetOfBy +,testVenn +,testVennMaybe +,testCompareHeight +,testShowReadEq +-- Zipper tests +,testOpenClose +,testDelClose +,testOpenLClose +,testOpenRClose +,testMoveL +,testMoveR +,testInsertL +,testInsertMoveL +,testInsertR +,testInsertMoveR +,testInsertTreeL +,testInsertTreeR +,testDelMoveL +,testDelMoveR +,testDelAllL +,testDelAllR +,testDelAllCloseL +,testDelAllIncCloseL +,testDelAllCloseR +,testDelAllIncCloseR +,testZipSize +,testTryOpenLE +,testTryOpenGE +,testOpenEither +,testBAVLtoZipper +) where + +import Prelude hiding (reverse,map,replicate,filter,foldr,foldr1,foldl,foldl1) -- so haddock finds the symbols there + +import Data.COrdering +import Data.Tree.AVLX + +import qualified Data.List as L (replicate,reverse,filter,foldr1,foldl1,map,insert,mapAccumL,mapAccumR) +import System.Exit(exitFailure) + +#ifdef __GLASGOW_HASKELL__ +import GHC.Base(Int#,Int(..)) +#include "ghcdefs.h" +#else +#include "h98defs.h" +#endif + + +-- import Debug.Trace(trace) +-- import System.IO.Unsafe(unsafePerformIO) + +-- | Run every test in this module (takes a very long time). +allTests :: IO () +allTests = + do testReadPath + testIsBalanced + testIsSorted + testSize + testClipSize + testWrite + testPush + testPushL + testPushR + testDelete + testAssertDelL + testAssertDelR + testAssertPopL + testPopHL + testAssertPopR + testAssertPop + testFlatten + testJoin + testJoinHAVL + testConcatAVL + testFlatConcat + testFoldr + testFoldr' + testFoldl + testFoldl' + testFoldr1 + testFoldr1' + testFoldl1 + testFoldl1' + testMapAccumL + testMapAccumR + testMapAccumL' + testMapAccumR' +#ifdef __GLASGOW_HASKELL__ + testMapAccumL'' + testMapAccumR'' +#endif + testSplitAtL + testFilterViaList + testFilter + testMapMaybeViaList + testMapMaybe + testTakeL + testDropL + testSplitAtR + testTakeR + testDropR + testSpanL + testTakeWhileL + testDropWhileL + testSpanR + testTakeWhileR + testDropWhileR + testRotateL + testRotateR + testRotateByL + testRotateByR + testForkL + testForkR + testFork + testTakeLE + testTakeGT + testTakeGE + testTakeLT + testUnion + testDisjointUnion + testUnionMaybe + testIntersection + testIntersectionMaybe + testIntersectionAsList + testIntersectionMaybeAsList + testDifference + testDifferenceMaybe + testSymDifference + testIsSubsetOf + testIsSubsetOfBy + testVenn + testVennMaybe + testCompareHeight + testShowReadEq +-- Zipper tests + testOpenClose + testDelClose + testOpenLClose + testOpenRClose + testMoveL + testMoveR + testInsertL + testInsertMoveL + testInsertR + testInsertMoveR + testInsertTreeL + testInsertTreeR + testDelMoveL + testDelMoveR + testDelAllL + testDelAllR + testDelAllCloseL + testDelAllIncCloseL + testDelAllCloseR + testDelAllIncCloseR + testZipSize + testTryOpenLE + testTryOpenGE + testOpenEither + testBAVLtoZipper + + +-- | Test isBalanced is capable of failing for a few non-AVL trees. +testIsBalanced :: IO () +testIsBalanced = do title "isBalanced" + if or [isBalanced t | t <- nonAVLs] then failed else passed + where nonAVLs :: [AVL Int] + nonAVLs = [Z E 0 (Z E 0 E) + ,Z (Z E 0 E) 0 E + ,N E 0 E + ,P E 0 E + ] + +-- | Test isSorted is capable of failing for a few non-sorted trees. +testIsSorted :: IO () +testIsSorted = do title "isSorted" + if or [isSorted compare (asTreeL l) | l <- nonSorted] then failed else passed + where nonSorted = ["AA","BA" + ,"AAA","ABA","ABB","AAB" + ,"AABC","ACBA","ABCC","ABBB","AAAB" + ] + +-- | Test size function +testSize :: IO () +testSize = do title "size" + exhaustiveTest test (take 6 allAVL) + where test _ s t = size t == s + +-- | Test clipSize function +testClipSize :: IO () +testClipSize = do title "clipSize" + exhaustiveTest test (take 6 allAVL) + where test _ s t = all (== Nothing) [clipSize n t | n <- [0..s-1 ]] && + all (== Just s ) [clipSize n t | n <- [s..s+10]] + +-- | Test write function +testWrite :: IO () +testWrite = do title "write" + exhaustiveTest test (take 5 allNonEmptyAVL) + where test _ s t = all test_ [0..s-1] + where test_ n = let t_ = write (withCC' (+) n) t + in isBalanced t_ && (asListL t_ == [0..n-1]++(n+n):[n+1..s-1]) + + +-- | Test push function +testPush :: IO () +-- Also exercises: map' and contains +testPush = do title "push" + exhaustiveTest test (take 6 allAVL) + where test h s t = all oddTest odds && all evenTest evens + where t_ = map' (\n -> 2*n+1) t -- t_ elements are odd, 1,3..2*s-1 + odds = [1,3..2*s-1] + evens = [0,2..2*s ] + oddTest n = let t__ = psh n t_ -- Should yield identical trees + s__ = size t__ + h__ = ASINT(height t__) + in (s__ == s) && (isSortedOK compare t__) && (h__== h) + evenTest n = let t__ = psh n t_ + s__ = size t__ + h__ = ASINT(height t__) + in (s__ == s+1) && (isSortedOK compare t__) && (h__-h <= 1) && (t__ `contns` n) + psh e = push (sndCC e) e + contns avl e = contains avl (compare e) + +-- | Test delete function +testDelete :: IO () +testDelete = do title "delete" + exhaustiveTest test (take 5 allNonEmptyAVL) + where test h s t = all oddTest odds && all evenTest evens + where t_ = map' (\n -> 2*n+1) t -- t_ elements are odd, 1,3..2*s-1 + odds = [1,3..2*s-1] + evens = [0,2..2*s ] + oddTest n = let t__ = del n t_ + in case checkHeight t__ of + Just h_ -> (h-h_<=1) && (L.insert n (asListL t__) == odds) + Nothing -> False + evenTest n = let t__ = del n t_ + in case checkHeight t__ of + Just h_ -> (h==h_) && (asListL t__ == odds) + Nothing -> False + del e = delete (compare e) + +-- | Test assertPop function +testAssertPop :: IO () +testAssertPop = + do title "assertPop" + exhaustiveTest test (take 5 allNonEmptyAVL) + where test h s t = all testElem elems + where elems = [0,1..s-1] + testElem n = let (n_,t_) = assertPop (fstCC n) t + in case checkHeight t_ of + Just h_ -> (h-h_<=1) && (L.insert n_ (asListL t_) == elems) + Nothing -> False + +-- | Test pushL function +-- Also exercises: asListL +testPushL :: IO () +testPushL = do title "pushL" + exhaustiveTest test (take 6 allAVL) + where test h _ t = let t_ = 0 `pushL` t + in case checkHeight t_ of + Just h_ | (h_==h+1) || (h_==h) -> asListL t_ == (0 : asListL t) + _ -> False + +-- | Test pushR function +-- Also exercises: asListR +testPushR :: IO () +testPushR = do title "pushR" + exhaustiveTest test (take 6 allAVL) + where test h s t = let t_ = t `pushR` s + in case checkHeight t_ of + Just h_ | (h_==h+1) || (h_==h) -> asListR t_ == (s : asListR t) + _ -> False + +-- | Test assertDelL function +-- Also exercises: asListL +testAssertDelL :: IO () +testAssertDelL = + do title "assertDelL" + exhaustiveTest test (take 5 allNonEmptyAVL) + where test h _ t = let t_ = assertDelL t + in case checkHeight t_ of + Just h_ | (h_==h-1) || (h_==h) -> asListL t_ == (tail $ asListL t) + _ -> False + +-- | Test delR function +-- Also exercises: asListR +testAssertDelR :: IO () +testAssertDelR = + do title "assertDelR" + exhaustiveTest test (take 5 allNonEmptyAVL) + where test h _ t = let t_ = assertDelR t + in case checkHeight t_ of + Just h_ | (h_==h-1) || (h_==h) -> asListR t_ == (tail $ asListR t) + _ -> False + +-- | Test assertPopL function +-- Also exercises: asListL +testAssertPopL :: IO () +testAssertPopL = + do title "assertPopL" + exhaustiveTest test (take 5 allNonEmptyAVL) + where test h _ t = let (v,t_) = assertPopL t + in case checkHeight t_ of + Just h_ | (h_==h-1) || (h_==h) -> (v : asListL t_) == asListL t + _ -> False + +-- | Test popHL function +-- This test can only be run if popHL and HAVL are not hidden. +-- However, popHL is exercised by indirectly by testConcatAVL anyway +testPopHL :: IO () +testPopHL = do title "popHL" + exhaustiveTest test (take 5 allNonEmptyAVL) + where test _ _ t = let UBT3(v, t_,h) = popHL t + in case checkHeight t_ of + Just h_ | (h_== ASINT(h)) -> (v : asListL t_) == asListL t + _ -> False + + +-- | Test assertPopR function +-- Also exercises: asListR +testAssertPopR :: IO () +testAssertPopR = + do title "assertPopR" + exhaustiveTest test (take 5 allNonEmptyAVL) + where test h _ t = let (t_,v) = assertPopR t + in case checkHeight t_ of + Just h_ | (h_==h-1) || (h_==h) -> (v : asListR t_) == asListR t + _ -> False + +-- | Test flatten function +-- Also exercises: asListL,replicateAVL +testFlatten :: IO () +testFlatten = do title "flatten" + exhaustiveTest test (take 6 allAVL) + where test _ _ t = let t_ = flatten t + in isBalanced t_ && (asListL t == asListL t_) + +-- | Test foldr +testFoldr :: IO () +testFoldr = do title "foldr" + exhaustiveTest test (take 6 allAVL) + where test _ s t = foldr (:) [] t == [0..s-1] +-- | Test foldr' +testFoldr' :: IO () +testFoldr' = do title "foldr'" + exhaustiveTest test (take 6 allAVL) + where test _ s t = foldr' (:) [] t == [0..s-1] +-- | Test foldl +testFoldl :: IO () +testFoldl = do title "foldl" + exhaustiveTest test (take 6 allAVL) + where test _ s t = foldl (flip (:)) [] t == [s-1,s-2..0] +-- | Test foldl' +testFoldl' :: IO () +testFoldl' = do title "foldl'" + exhaustiveTest test (take 6 allAVL) + where test _ s t = foldl' (flip (:)) [] t == [s-1,s-2..0] +-- | Test foldr1 +testFoldr1 :: IO () +testFoldr1 = do title "foldr1" + exhaustiveTest test (take 5 allNonEmptyAVL) + where test _ s t = foldr1 (-) t == L.foldr1 (-) [0..s-1] +-- | Test foldr1' +testFoldr1' :: IO () +testFoldr1' = do title "foldr1'" + exhaustiveTest test (take 5 allNonEmptyAVL) + where test _ s t = foldr1' (-) t == L.foldr1 (-) [0..s-1] +-- | Test foldl1 +testFoldl1 :: IO () +testFoldl1 = do title "foldl1" + exhaustiveTest test (take 5 allNonEmptyAVL) + where test _ s t = foldl1 (-) t == L.foldl1 (-) [0..s-1] +-- | Test foldl1' +testFoldl1' :: IO () +testFoldl1' = do title "foldl1'" + exhaustiveTest test (take 5 allNonEmptyAVL) + where test _ s t = foldl1' (-) t == L.foldl1 (-) [0..s-1] + +-- | Test mapAccumL +testMapAccumL :: IO () +testMapAccumL = do title "mapAccumL" + exhaustiveTest test (take 6 allAVL) + where test _ _ t = let (nt,t') = mapAccumL f 0 t + (nl,l ) = L.mapAccumL f 0 (asListL t) + in (nt==nl) && ((asListL t') == l) && (isSortedOK compare t') + f acc n = (acc+n,n+1) + +-- | Test mapAccumR +testMapAccumR :: IO () +testMapAccumR = do title "mapAccumR" + exhaustiveTest test (take 6 allAVL) + where test _ _ t = let (nt,t') = mapAccumR f 0 t + (nl,l ) = L.mapAccumR f 0 (asListL t) + in (nt==nl) && ((asListL t') == l) && (isSortedOK compare t') + f acc n = (acc+n,n+1) + +-- | Test mapAccumL' +testMapAccumL' :: IO () +testMapAccumL' = do title "mapAccumL'" + exhaustiveTest test (take 6 allAVL) + where test _ _ t = let (nt,t') = mapAccumL' f 0 t + (nl,l ) = L.mapAccumL f 0 (asListL t) + in (nt==nl) && ((asListL t') == l) && (isSortedOK compare t') + f acc n = (acc+n,n+1) + +-- | Test mapAccumR' +testMapAccumR' :: IO () +testMapAccumR' = do title "mapAccumR'" + exhaustiveTest test (take 6 allAVL) + where test _ _ t = let (nt,t') = mapAccumR' f 0 t + (nl,l ) = L.mapAccumR f 0 (asListL t) + in (nt==nl) && ((asListL t') == l) && (isSortedOK compare t') + f acc n = (acc+n,n+1) + +#ifdef __GLASGOW_HASKELL__ +-- | Test mapAccumL'' +testMapAccumL'' :: IO () +testMapAccumL'' = do title "mapAccumL''" + exhaustiveTest test (take 6 allAVL) + where test _ _ t = let (nt,t') = mapAccumL'' f_ 0 t + (nl,l ) = L.mapAccumL f 0 (asListL t) + in (nt==nl) && ((asListL t') == l) && (isSortedOK compare t') + f_ acc n = UBT2(acc+n,n+1) + f acc n = (acc+n,n+1) + +-- | Test mapAccumR'' +testMapAccumR'' :: IO () +testMapAccumR'' = do title "mapAccumR''" + exhaustiveTest test (take 6 allAVL) + where test _ _ t = let (nt,t') = mapAccumR'' f_ 0 t + (nl,l ) = L.mapAccumR f 0 (asListL t) + in (nt==nl) && ((asListL t') == l) && (isSortedOK compare t') + f_ acc n = UBT2(acc+n,n+1) + f acc n = (acc+n,n+1) +#endif + +-- | Test the join function +testJoin :: IO () +testJoin = let trees = take num $ concatMap (\(_,ts) -> ts) allAVL + num = 2000 + in do title "join" + putStrLn $ "Testing " ++ show (num*num) ++ " tree pairs.." + if and [test l $ map (ls+) r | (l,ls) <- trees, (r,_) <- trees] then passed else failed + where test l r = let j = l `join` r + in isBalanced j && (asListL j == l `toListL` asListL r) + +-- | Test the joinHAVL function +testJoinHAVL :: IO () +testJoinHAVL = let trees = take num $ concatMap (\(_,ts) -> ts) allAVL + num = 2000 + in do title "joinHAVL" + putStrLn $ "Testing " ++ show (num*num) ++ " tree pairs.." + if and [test l $ map (ls+) r | (l,ls) <- trees, (r,_) <- trees] then passed else failed + where test l r = let (HAVL j hj) = (toHAVL l) `joinHAVL` (toHAVL r) + in case checkHeight j of + Nothing -> False + Just hj_ -> (ASINT(hj) == hj_) && (asListL j == l `toListL` asListL r) + +-- | Test the concatAVL function. +testConcatAVL :: IO () +testConcatAVL = let trees = take num $ concatMap (\(_,ts) -> ts) allAVL + num = 2000 + in do title "concatAVL" + putStrLn $ "Testing " ++ show (num*num) ++ " tree pairs.." + if others && and [test ls l $ map (\n -> n+(ls+1)) r + | (l,ls) <- trees, (r,_) <- trees] + then passed else failed + where test ls l r = let j = concatAVL $ [empty,empty,l,empty,singleton ls,empty,r,empty,empty] + in isBalanced j && (asListL j == l `toListL` (ls:asListL r)) + others = all (isEmpty . concatAVL) [[],[empty],[empty,empty],[empty,empty,empty]] + && (all test1 $ concatMap (\ss -> [ss,"":ss,"Z":ss]) + [[""] + ,["A"] + ,["","A","BC","","D","","EFGH","I"] + ] + ) + test1 ss = let t = concatAVL $ L.map asTreeL ss + in isBalanced t && (asListL t == concat ss) + +-- | Test the flatConcat function. +testFlatConcat :: IO () +testFlatConcat = let trees = take num $ concatMap (\(_,ts) -> ts) allAVL + num = 2000 + in do title "flatConcat" + putStrLn $ "Testing " ++ show (num*num) ++ " tree pairs.." + if others && and [test ls l $ map (\n -> n+(ls+1)) r + | (l,ls) <- trees, (r,_) <- trees] + then passed else failed + where test ls l r = let j = flatConcat $ [empty,empty,l,empty,singleton ls,empty,r,empty,empty] + in isBalanced j && (asListL j == l `toListL` (ls:asListL r)) + others = all (isEmpty . flatConcat) [[],[empty],[empty,empty],[empty,empty,empty]] + && (all test1 $ concatMap (\ss -> [ss,"":ss,"Z":ss]) + [[""] + ,["A"] + ,["","A","BC","","D","","EFGH","I"] + ] + ) + test1 ss = let t = flatConcat $ L.map asTreeL ss + in isBalanced t && (asListL t == concat ss) + +-- | Test the filterViaList function +testFilterViaList :: IO () +testFilterViaList = do title "filterViaList" + exhaustiveTest test (take 6 allAVL) + where test _ s t = all testit [0..s] -- n==s should yield unmodified tree + where testit n = let t' = filterViaList (/= n) t + in (isSortedOK compare t') && (asListL t' == ([0..n-1]++[n+1..s-1])) + +-- | Test the filter function +testFilter :: IO () +testFilter = do title "filter" + exhaustiveTest test (take 6 allAVL) + where test _ s t = all testit [0..s] -- n==s should yield unmodified tree + where testit n = let t' = filter (/= n) t + in (isSortedOK compare t') && (asListL t' == ([0..n-1]++[n+1..s-1])) + +-- | Test the mapMaybeViaList function +testMapMaybeViaList :: IO () +testMapMaybeViaList = do title "mapMaybeViaList" + exhaustiveTest test (take 6 allAVL) + where test _ s t = all testit [0..s] -- n==s should yield unmodified tree + where testit n = let t' = mapMaybeViaList (\m -> if m==n then Nothing else Just m) t + in (isSortedOK compare t') && (asListL t' == ([0..n-1]++[n+1..s-1])) + +-- | Test the mapMaybe function +testMapMaybe :: IO () +testMapMaybe = do title "mapMaybe" + exhaustiveTest test (take 6 allAVL) + where test _ s t = all testit [0..s] -- n==s should yield unmodified tree + where testit n = let t' = mapMaybe (\m -> if m==n then Nothing else Just m) t + in (isSortedOK compare t') && (asListL t' == ([0..n-1]++[n+1..s-1])) + +-- | Test splitAtL function +testSplitAtL :: IO () +testSplitAtL = do title "splitAtL" + exhaustiveTest test (take 6 allAVL) + where test _ s t = all splitTest0 [0..s-1] && all splitTest1 [s] + where tlist = asListL t + splitTest0 n = case splitAtL n t of + Left _ -> False + Right (l,r) -> (isBalanced l) && (isBalanced r) && + (size l == n) && (size r == s-n) && + (l `toListL` asListL r) == tlist + splitTest1 n = case splitAtL n t of + Left s_ -> s_==s + Right _ -> False + +-- | Test takeL function +testTakeL :: IO () +testTakeL = do title "takeL" + exhaustiveTest test (take 6 allAVL) + where test _ s t = all takeTest0 [0..s-1] && all takeTest1 [s] + where takeTest0 n = case takeL n t of + Left _ -> False + Right l -> (isBalanced l) && (asListL l) == [0..n-1] + takeTest1 n = case takeL n t of + Left s_ -> s_==s + Right _ -> False + +-- | Test dropL function +testDropL :: IO () +testDropL = do title "dropL" + exhaustiveTest test (take 6 allAVL) + where test _ s t = all dropTest0 [0..s-1] && all dropTest1 [s] + where dropTest0 n = case dropL n t of + Left _ -> False + Right r -> (isBalanced r) && (asListL r) == [n..s-1] + dropTest1 n = case dropL n t of + Left s_ -> s_==s + Right _ -> False + +-- | Test splitAtR function +testSplitAtR :: IO () +testSplitAtR = do title "splitAtR" + exhaustiveTest test (take 6 allAVL) + where test _ s t = all splitTest0 [0..s-1] && all splitTest1 [s] + where tlist = asListR t + splitTest0 n = case splitAtR n t of + Left _ -> False + Right (l,r) -> (isBalanced l) && (isBalanced r) && + (size r == n) && (size l == s-n) && + (r `toListR` asListR l) == tlist + splitTest1 n = case splitAtR n t of + Left s_ -> s_==s + Right _ -> False + +-- | Test takeR function +testTakeR :: IO () +testTakeR = do title "takeR" + exhaustiveTest test (take 6 allAVL) + where test _ s t = all takeTest0 [0..s-1] && all takeTest1 [s] + where takeTest0 n = case takeR n t of + Left _ -> False + Right r -> (isBalanced r) && (asListL r) == [s-n..s-1] + takeTest1 n = case takeR n t of + Left s_ -> s_==s + Right _ -> False + +-- | Test dropR function +testDropR :: IO () +testDropR = do title "dropR" + exhaustiveTest test (take 6 allAVL) + where test _ s t = all dropTest0 [0..s-1] && all dropTest1 [s] + where dropTest0 n = case dropR n t of + Left _ -> False + Right l -> (isBalanced l) && (asListL l) == [0..(s-1)-n] + dropTest1 n = case dropR n t of + Left s_ -> s_==s + Right _ -> False + +-- | Test spanL function +testSpanL :: IO () +testSpanL = do title "spanL" + exhaustiveTest test (take 6 allAVL) + where test _ s t = all spanTest [0..s] + where tlist = asListL t + spanTest n = let (l ,r ) = spanL (=n) t + (l_,r_) = span (>=n) tlist + in (isBalanced l) && (isBalanced r) && + (asListR l == r_) && (asListR r == l_) + +-- | Test takeWhileR function +testTakeWhileR :: IO () +testTakeWhileR = do title "takeWhileR" + exhaustiveTest test (take 6 allAVL) + where test _ s t = all spanTest [0..s] + where tlist = asListR t + spanTest n = let r = takeWhileR (>=n) t + r_ = takeWhile (>=n) tlist + in (isBalanced r) && (asListR r == r_) + +-- | Test dropWhileR function +testDropWhileR :: IO () +testDropWhileR = do title "dropWhileR" + exhaustiveTest test (take 6 allAVL) + where test _ s t = all spanTest [0..s] + where tlist = asListR t + spanTest n = let l = dropWhileR (>=n) t + l_ = dropWhile (>=n) tlist + in (isBalanced l) && (asListR l == l_) + +-- | Test rotateL function +testRotateL :: IO () +testRotateL = do title "rotateL" + exhaustiveTest test (take 6 allAVL) + where test _ s t = all isOK rotations + where rotations = take s $ tail $ iterate (map' (\n -> (n-1) `mod` s) . rotateL) t + isOK t_ = (isBalanced t_) && (asListL t_ == tlist) + tlist = asListL t +-- | Test rotateR function +testRotateR :: IO () +testRotateR = do title "rotateR" + exhaustiveTest test (take 6 allAVL) + where test _ s t = all isOK rotations + where rotations = take s $ tail $ iterate (map' (\n -> (n+1) `mod` s) . rotateR) t + isOK t_ = (isBalanced t_) && (asListL t_ == tlist) + tlist = asListL t + +-- | Test rotateByL function +testRotateByL :: IO () +testRotateByL = do title "rotateByL" + exhaustiveTest test (take 6 allAVL) + where test _ s t = all isOK $ L.map rotateIt [-1..s] + where rotateIt n = map' (\n_ -> (n_-n) `mod` s) $ rotateByL t n + isOK t_ = (isBalanced t_) && (asListL t_ == tlist) + tlist = asListL t + +-- | Test rotateByR function +testRotateByR :: IO () +testRotateByR = do title "rotateByR" + exhaustiveTest test (take 6 allAVL) + where test _ s t = all isOK $ L.map rotateIt [-1..s] + where rotateIt n = map' (\n_ -> (n_+n) `mod` s) $ rotateByR t n + isOK t_ = (isBalanced t_) && (asListL t_ == tlist) + tlist = asListL t + +-- | Test forkL function +testForkL :: IO () +testForkL = do title "forkL" + exhaustiveTest test (take 6 allAVL) + where test _ s t = all testFarkL [-1..s-1] + where tlist = asListL t + testFarkL n = let (l,r) = forkL (compare n) t + in (isBalanced l) && (isBalanced r) && + (size l == n+1) && (size r == s-(n+1)) && + (l `toListL` asListL r == tlist) + +-- | Test forkR function +testForkR :: IO () +testForkR = do title "forkR" + exhaustiveTest test (take 6 allAVL) + where test _ s t = all testFarkR [0..s] + where tlist = asListL t + testFarkR n = let (l,r) = forkR (compare n) t + in (isBalanced l) && (isBalanced r) && + (size l == n) && (size r == s-n) && + (l `toListL` asListL r == tlist) + + +-- | Test fork function +testFork :: IO () +testFork = do title "fork" + exhaustiveTest test (take 6 allAVL) + where test _ s t = all testFork0 [0..s-1] && testFork1 (-1) && testFork2 s + where tlist = asListL t + testFork0 n = let (l,mbn,r) = fork (fstCC n) t + in case mbn of + Just n_ -> (n_==n) && (isBalanced l) && (isBalanced r) && + (size l == n) && (size r == s-(n+1)) && + (l `toListL` (n : asListL r) == tlist) + _ -> False + testFork1 n = let (l,mbn,r) = fork (fstCC n) t + in case mbn of + Nothing -> (isEmpty l) && (isBalanced r) && (asListL r == tlist) + _ -> False + testFork2 n = let (l,mbn,r) = fork (fstCC n) t + in case mbn of + Nothing -> (isEmpty r) && (isBalanced l) && (asListL l == tlist) + _ -> False + +-- | Test takeLE function +testTakeLE :: IO () +testTakeLE = do title "takeLE" + exhaustiveTest test (take 6 allAVL) + where test _ s t = all testTikeLE [-1..s-1] + where testTikeLE n = let l = takeLE (compare n) t + in (isBalanced l) && (asListL l == [0..n]) + +-- | Test takeLT function +testTakeLT :: IO () +testTakeLT = do title "takeLT" + exhaustiveTest test (take 6 allAVL) + where test _ s t = all testTikeLT [0..s] + where testTikeLT n = let l = takeLT (compare n) t + in (isBalanced l) && (asListL l == [0..n-1]) + +-- | Test takeGT function +testTakeGT :: IO () +testTakeGT = do title "takeGT" + exhaustiveTest test (take 6 allAVL) + where test _ s t = all testTikeGT [-1..s-1] + where testTikeGT n = let r = takeGT (compare n) t + in (isBalanced r) && (asListL r == [n+1..s-1]) + +-- | Test takeGE function +testTakeGE :: IO () +testTakeGE = do title "takeGE" + exhaustiveTest test (take 6 allAVL) + where test _ s t = all testTikeGE [0..s] + where testTikeGE n = let r = takeGE (compare n) t + in (isBalanced r) && (asListL r == [n..s-1]) + +-- | Test the union function +testUnion :: IO () +testUnion = let trees = take num $ concatMap (\(_,ts) -> ts) allAVL + num = 1000 + in do title "union" + putStrLn $ "Testing " ++ show (num*num) ++ " tree pairs.." + if and [test l ls r rs | (l,ls) <- trees, (r,rs) <- trees] then passed else failed + where test l ls r rs = all (\f -> f l ls r rs) [test1,test2,test3] + test1 l ls r rs = let u = unionFst l r + in isBalanced u && (asListL u == [0 .. max ls rs - 1]) + test2 l ls r rs = and [test2_ n $ map' (n+) r | n <- [(-rs)..ls]] + where test2_ n r_ = let u = unionFst l r_ + in isBalanced u && (asListL u == [min n 0 .. max ls (rs+n) - 1]) + test3 l ls r rs = let l_ = map' (\n -> n+n ) l -- even + r_ = map' (\n -> n+n+1) r -- odd + u = unionFst l_ r_ + in isSortedOK compare u && (size u == ls+rs) + unionFst = union fstCC + +-- | Test the disjointUnion function +testDisjointUnion :: IO () +testDisjointUnion = + let trees = take num $ concatMap (\(_,ts) -> ts) allAVL + num = 1000 + in do title "disjointUnion" + putStrLn $ "Testing " ++ show (num*num) ++ " tree pairs.." + if and [test (map' (\n -> 2*n) l) ls (map' (\n -> 2*n+1) r) rs + | (l,ls) <- trees -- 0,2..2*ls-2 + , (r,rs) <- trees -- 1,3..2*rs-1 + ] + then passed + else failed + where test l ls r rs = all (\f -> f l ls r rs) [test1] + test1 l ls r rs = and [test1_ $ map' (+(2*n)) r | n <- [(-rs)..(ls-1)]] + where test1_ r_ = let u = disjointUnion compare l r_ + in isBalanced u && (asListL u == listUnion (asListL l) (asListL r_)) + +-- | Test the symDifference function +testSymDifference :: IO () +testSymDifference = + let trees = take num $ concatMap (\(_,ts) -> ts) allAVL + num = 1000 + in do title "symDifference" + putStrLn $ "Testing " ++ show (num*num) ++ " tree pairs.." + if and [test l ls r rs | (l,ls) <- trees, (r,rs) <- trees] then passed else failed + where test l ls r rs = all (\f -> f l ls r rs) [test1,test2,test3] + test1 l ls r rs = let u = symDiff l r + in isBalanced u && (asListL u == [min ls rs .. max ls rs - 1]) + test2 l ls r rs = and [test2_ n $ map' (n+) r | n <- [(-rs)..ls]] + where test2_ n r_ = let u = symDiff l r_ + in isBalanced u && (asListL u == [min n 0 .. max n 0 - 1] ++ + [min ls (rs+n) .. max ls (rs+n) - 1]) + test3 l ls r rs = let l_ = map' (\n -> n+n ) l -- even + r_ = map' (\n -> n+n+1) r -- odd + u = symDiff l_ r_ + in isSortedOK compare u && (size u == ls+rs) + symDiff = symDifference compare + +-- | Test the unionMaybe function +testUnionMaybe :: IO () +testUnionMaybe = let trees = take num $ concatMap (\(_,ts) -> ts) allAVL + num = 1000 + in do title "unionMaybe" + putStrLn $ "Testing " ++ show (num*num) ++ " tree pairs.." + if and [test l ls r rs | (l,ls) <- trees, (r,rs) <- trees] then passed else failed + where test l ls r rs = all (\f -> f l ls r rs) [test1,test2,test3] + test1 l ls r rs = let u = onion l r + mn = min ls rs + mx = max ls rs + in isBalanced u && (asListL u == [0,2 .. mn - 1] ++ [mn .. mx-1]) + test2 l ls r rs = and [test2_ n $ map' (n+) r | n <- [(-rs)..ls]] + where test2_ n r_ = let u = onion l r_ + n0 = min n 0 + n1 = max n 0 + n2 = min ls (rs+n) + n3 = max ls (rs+n) + in isBalanced u && (asListL u == [n0 .. n1-1] + ++ L.filter even [n1 .. n2-1] + ++ [n2..n3-1] + ) + test3 l ls r rs = let l_ = map' (\n -> n+n ) l -- even + r_ = map' (\n -> n+n+1) r -- odd + u = onion l_ r_ + in isSortedOK compare u && (size u == ls+rs) + onion = unionMaybe (withCC' com) + com a _ = if even a then Just a else Nothing + +-- | Test the intersection function +testIntersection :: IO () +testIntersection = let trees = take num $ concatMap (\(_,ts) -> ts) allAVL + num = 1000 + in do title "intersection" + putStrLn $ "Testing " ++ show (num*num) ++ " tree pairs.." + if and [test l ls r rs | (l,ls) <- trees, (r,rs) <- trees] then passed else failed + where test l ls r rs = all (\f -> f l ls r rs) [test1,test2,test3] + test1 l ls r rs = let u = intersection fstCC l r + in isBalanced u && (asListL u == [0 .. min ls rs - 1]) + test2 l ls r rs = and [test2_ n $ map' (n+) r | n <- [(-rs)..ls]] + where test2_ n r_ = let u = intersection fstCC l r_ + in isBalanced u && (asListL u == [max n 0 .. min ls (rs+n) - 1]) + test3 l _ r _ = let l_ = map' (\n -> n+n ) l -- even + r_ = map' (\n -> n+n+1) r -- odd + u = intersection fstCC l_ r_ + in isEmpty u + +-- | Test the intersectionMaybe function +testIntersectionMaybe :: IO () +testIntersectionMaybe = let trees = take num $ concatMap (\(_,ts) -> ts) allAVL + num = 1000 + in do title "intersectionMaybe" + putStrLn $ "Testing " ++ show (num*num) ++ " tree pairs.." + if and [test l ls r rs | (l,ls) <- trees, (r,rs) <- trees] then passed else failed + where test l ls r rs = all (\f -> f l ls r rs) [test1,test2,test3] + test1 l ls r rs = let u = insect l r + mn = min ls rs + in isBalanced u && (asListL u == [0,2 .. mn - 1]) + test2 l ls r rs = and [test2_ n $ map' (n+) r | n <- [(-rs)..ls]] + where test2_ n r_ = let u = insect l r_ + n1 = max n 0 + n2 = min ls (rs+n) + in isBalanced u && (asListL u == L.filter even [n1 .. n2-1]) + test3 l _ r _ = let l_ = map' (\n -> n+n ) l -- even + r_ = map' (\n -> n+n+1) r -- odd + u = insect l_ r_ + in isEmpty u + insect = intersectionMaybe (withCC' com) + com a _ = if even a then Just a else Nothing + +-- | Test the intersectionAsList function +testIntersectionAsList :: IO () +testIntersectionAsList = + let trees = take num $ concatMap (\(_,ts) -> ts) allAVL + num = 1000 + in do title "intersectionAsList" + putStrLn $ "Testing " ++ show (num*num) ++ " tree pairs.." + if and [test l ls r rs | (l,ls) <- trees, (r,rs) <- trees] then passed else failed + where test l ls r rs = all (\f -> f l ls r rs) [test1,test2,test3] + test1 l ls r rs = let u = intersectionAsList fstCC l r + in u == [0 .. min ls rs - 1] + test2 l ls r rs = and [test2_ n $ map' (n+) r | n <- [(-rs)..ls]] + where test2_ n r_ = let u = intersectionAsList fstCC l r_ + in u == [max n 0 .. min ls (rs+n) - 1] + test3 l _ r _ = let l_ = map' (\n -> n+n ) l -- even + r_ = map' (\n -> n+n+1) r -- odd + u = intersectionAsList fstCC l_ r_ + in null u + +-- | Test the intersectionMaybeAsList function +testIntersectionMaybeAsList :: IO () +testIntersectionMaybeAsList = + let trees = take num $ concatMap (\(_,ts) -> ts) allAVL + num = 1000 + in do title "intersectionMaybeAsList" + putStrLn $ "Testing " ++ show (num*num) ++ " tree pairs.." + if and [test l ls r rs | (l,ls) <- trees, (r,rs) <- trees] then passed else failed + where test l ls r rs = all (\f -> f l ls r rs) [test1,test2,test3] + test1 l ls r rs = let u = insect l r + mn = min ls rs + in u == [0,2 .. mn - 1] + test2 l ls r rs = and [test2_ n $ map' (n+) r | n <- [(-rs)..ls]] + where test2_ n r_ = let u = insect l r_ + n1 = max n 0 + n2 = min ls (rs+n) + in u == L.filter even [n1 .. n2-1] + test3 l _ r _ = let l_ = map' (\n -> n+n ) l -- even + r_ = map' (\n -> n+n+1) r -- odd + u = insect l_ r_ + in null u + insect = intersectionMaybeAsList (withCC' com) + com a _ = if even a then Just a else Nothing + +-- | Test the difference function +testDifference :: IO () +testDifference = let trees = take num $ concatMap (\(_,ts) -> ts) allAVL + num = 1000 + in do title "difference" + putStrLn $ "Testing " ++ show (num*num) ++ " tree pairs.." + if and [test l ls r rs | (l,ls) <- trees, (r,rs) <- trees] then passed else failed + where test l ls r rs = all (\f -> f l ls r rs) [test1,test2,test3] + test1 l ls r rs = let u = diff l r + in isBalanced u && (asListL u == [rs .. ls - 1]) + test2 l ls r rs = and [test2_ n $ map' (n+) r | n <- [(-rs)..ls]] + where test2_ n r_ = let u = diff l r_ + in isBalanced u && (asListL u == [0 .. n-1] ++ [rs+n .. ls-1]) + test3 l ls r rs = let l_ = map' (\n -> n+n ) l -- even + r_ = map' (\n -> n+n+1) r -- odd + u = diff l r_ + u_ = diff l_ r_ + mn = min (ls-1) (2*rs-1) + in isBalanced u && + (asListL u == L.filter even [0..mn] ++ [mn+1..ls-1]) && + isBalanced u_ && (asListL u_ == asListL l_) + diff = difference compare + +-- | Test the differenceMaybe function +testDifferenceMaybe :: IO () +testDifferenceMaybe = + let trees = take num $ concatMap (\(_,ts) -> ts) allAVL + num = 1000 + in do title "differenceMaybe" + putStrLn $ "Testing " ++ show (num*num) ++ " tree pairs.." + if and [test l ls r rs | (l,ls) <- trees, (r,rs) <- trees] then passed else failed + where c m n = case compare m n of + LT -> Lt + EQ -> if even m then (Eq Nothing) else (Eq (Just m)) + GT -> Gt + test l ls r rs = all (\f -> f l ls r rs) [test1,test2,test3] + test1 l ls r rs = let mn = min (ls-1) (rs-1) + u = differenceMaybe c l r + in isBalanced u && (asListL u == L.filter odd [0..mn] ++ [mn+1..ls-1]) + test2 l ls r rs = and [test2_ n $ map' (n+) r | n <- [(-rs)..ls]] + where test2_ n r_ = let u = differenceMaybe c l r_ + n0 = max 0 n + n1 = min (ls-1) (rs+n-1) + in isBalanced u && + (asListL u == [0..n0-1] ++ L.filter odd [n0..n1] ++ [n1+1..ls-1]) + test3 l ls r rs = let l_ = map' (\n -> n+n+1) l -- odd + r_ = map' (\n -> n+n ) r -- even + u = differenceMaybe c l r_ + u_ = differenceMaybe c l_ r_ + mn = min (ls-1) (2*rs-2) + mx = max (mn+1) 0 + listfil = L.filter odd [0..mn] + listrem = [mx..ls-1] + in isBalanced u && isBalanced u_ && (asListL u_ == asListL l_) && + (asListL u == listfil ++ listrem) + +-- | Test the isSubsetOf function +testIsSubsetOf :: IO () +testIsSubsetOf = let trees = take num $ concatMap (\(_,ts) -> ts) allAVL + num = 1000 + in do title "isSubsetOf" + putStrLn $ "Testing " ++ show (num*num) ++ " tree pairs.." + if and [test l ls r rs | (l,ls) <- trees, (r,rs) <- trees] then passed else failed + where test l ls r rs = all (\f -> f l ls r rs) [test1,test2] + test1 l ls r rs = (l `isSubset` r == (ls<=rs)) && + (r `isSubset` l == (rs<=ls)) + test2 l ls r rs = and [test2_ n $ map' (n+) r | n <- [(-rs)..ls]] + where test2_ n r_ = (l `isSubset` r_ == ((n<=0) && (rs+n>=ls))) && + (r_ `isSubset` l == ((n>=0) && (rs+n<=ls))) + isSubset = isSubsetOf compare + +-- | Test the isSubsetOfBy function +testIsSubsetOfBy :: IO () +testIsSubsetOfBy = let trees = take num $ concatMap (\(_,ts) -> ts) allAVL + num = 1000 + in do title "isSubsetOfBy" + putStrLn $ "Testing " ++ show (num*num) ++ " tree pairs.." + if and [test l ls r rs | (l,ls) <- trees, (r,rs) <- trees] then passed else failed + -- test1 & test2 chack same behaviour as isSubsetOf + -- test3 checks behviour for comarison functions that may return (Eq False) + where test l ls r rs = all (\f -> f l ls r rs) [test1,test2,test3] + test1 l ls r rs = (l `isSubset` r == (ls<=rs)) && + (r `isSubset` l == (rs<=ls)) + test2 l ls r rs = and [test2_ n $ map' (n+) r | n <- [(-rs)..ls]] + where test2_ n r_ = (l `isSubset` r_ == ((n<=0) && (rs+n>=ls))) && + (r_ `isSubset` l == ((n>=0) && (rs+n<=ls))) + isSubset = isSubsetOfBy (withCC (\_ _ -> True )) + test3 l ls r rs = and [test3_ n | n <- [0..max ls rs]] + where test3_ n = (l `isSubset'` r == ((ls<=rs) && (n>=ls))) && + (r `isSubset'` l == ((rs<=ls) && (n>=rs))) + where isSubset' = isSubsetOfBy (withCC (\m _ -> m /= n)) + +-- | Test the venn function. Also exercises disjointUnion +testVenn :: IO () +testVenn = + let trees = concatMap (\(_,ts) -> ts) (take 5 allAVL) -- All trees of height 4 or less = 335 trees (112,225 pairs) + num = length trees + in do title "venn" + putStrLn $ "Testing " ++ show (num*num) ++ " tree pairs.." + if and [test l ls r rs | (l,ls) <- trees, (r,rs) <- trees] then passed else failed + where test l ls r rs = all (\f -> f l ls r rs) [test1,test2] + test1 l ls r rs = let (lr,i,rl) = ven l r + in and [all isBalanced [lr,i,rl] + ,asListL lr == listDiff [0..ls-1] [0..rs-1] + ,asListL i == listIntersection [0..ls-1] [0..rs-1] + ,asListL rl == listDiff [0..rs-1] [0..ls-1] + ,asListL (disu i (disu rl lr)) == listUnion [0..ls-1] [0..rs-1] + ] + test2 l ls r rs = and [test2_ $ map' (n+) r | n <- [(-rs)..ls]] + where test2_ r_ = let (lr,i,rl) = ven l r_ + in and [all isBalanced [lr,i,rl] + ,asListL lr == listDiff (asListL l ) (asListL r_) + ,asListL i == listIntersection (asListL l ) (asListL r_) + ,asListL rl == listDiff (asListL r_) (asListL l ) + ,asListL (disu i (disu rl lr)) == listUnion (asListL l ) (asListL r_) + ] + ven = venn fstCC + disu = disjointUnion compare + +-- | Test the vennMaybe function. +testVennMaybe :: IO () +testVennMaybe = + let trees = concatMap (\(_,ts) -> ts) (take 5 allAVL) -- All trees of height 4 or less = 335 trees (112,225 pairs) + num = length trees + in do title "vennMaybe" + putStrLn $ "Testing " ++ show (num*num) ++ " tree pairs.." + if and [test l ls r rs | (l,ls) <- trees, (r,rs) <- trees] then passed else failed + where test l ls r rs = and [t cmp l ls r rs| t<-[test1], cmp<-[cmpAll,cmpNone,cmpEven,cmpOdd]] + test1 cmp l ls r rs = and [test1_ $ map' (n+) r | n <- [(-rs)..ls]] + where test1_ r_ = let (lr,i,rl) = vennMaybe cmp l r_ + in and [all isBalanced [lr,i,rl] + ,asListL lr == listDiff (asListL l ) (asListL r_) + ,asListL rl == listDiff (asListL r_) (asListL l ) + ,asListL i == listIntersectionMaybe cmp (asListL l ) (asListL r_) + ,asListL (disu i (disu rl lr)) == listUnion (asListL i) (listUnion (asListL lr) (asListL rl)) + ] + cmpAll = withCC' (\x _ -> Just x) + cmpNone = withCC' (\_ _ -> Nothing) + cmpEven = withCC' (\x _ -> if even x then Just x else Nothing) + cmpOdd = withCC' (\x _ -> if odd x then Just x else Nothing) + disu = disjointUnion compare + +-- | Test compareHeight function +testCompareHeight :: IO () +testCompareHeight = let trees = take num $ concatMap (\(h,ts) -> [(t,h)|(t,_)<-ts]) allAVL + num = 10000 + in do title "compareHeight" + putStrLn $ "Testing " ++ show (num*num) ++ " tree pairs.." + if and [test l lh r rh | (l,lh) <- trees, (r,rh) <- trees] then passed else failed + where test l lh r rh = compareHeight l r == compare lh rh + +-- | Test Zipper open\/close +testOpenClose :: IO () +testOpenClose = do title "Zipper open/close" + exhaustiveTest test (take 5 allNonEmptyAVL) + where test _ s t = all test_ [0..s-1] + where test_ n = let z = assertOpen (compare n) t + t_ = close z + in (getCurrent z == n) && (isBalanced t_) && (asListL t_ == [0..s-1]) +-- | Test Zipper delClose +testDelClose :: IO () +testDelClose = do title "Zipper delClose" + exhaustiveTest test (take 5 allNonEmptyAVL) + where test _ s t = all test_ [0..s-1] + where test_ n = let t_ = delClose $ assertOpen (compare n) t + in (isBalanced t_) -- && (L.insert n (asListL t_) == [0..s-1]) + +-- | Test Zipper assertOpenL\/close +testOpenLClose :: IO () +testOpenLClose = do title "Zipper assertOpenL/close" + exhaustiveTest test (take 5 allNonEmptyAVL) + where test _ s t = let z = assertOpenL t + t_ = close z + in (getCurrent z == 0) && (isBalanced t_) && (asListL t_ == [0..s-1]) + +-- | Test Zipper assertOpenR\/close +testOpenRClose :: IO () +testOpenRClose = do title "Zipper assertOpenR/close" + exhaustiveTest test (take 5 allNonEmptyAVL) + where test _ s t = let z = assertOpenR t + t_ = close z + in (getCurrent z == s-1) && (isBalanced t_) && (asListL t_ == [0..s-1]) + +-- | Test Zipper assertMoveL\/isRightmost +testMoveL :: IO () +testMoveL = do title "Zipper assertMoveL/isRightmost" + exhaustiveTest test (take 5 allNonEmptyAVL) + where test _ s t = let zavls@(z:zs) = take s $ iterate assertMoveL (assertOpenR t) + in (L.map getCurrent zavls == L.reverse [0..s-1]) && (all test_ zavls) && + (isRightmost z) && (not $ any isRightmost zs) + where test_ zavl = let t_ = close zavl + in (isBalanced t_) && (asListL t_ == [0..s-1]) + +-- | Test Zipper assertMoveR\/isLeftmost +testMoveR :: IO () +testMoveR = do title "Zipper assertMoveR/isLeftmost" + exhaustiveTest test (take 5 allNonEmptyAVL) + where test _ s t = let zavls@(z:zs) = take s $ iterate assertMoveR (assertOpenL t) + in (L.map getCurrent zavls == [0..s-1]) && (all test_ zavls) && + (isLeftmost z) && (not $ any isLeftmost zs) + where test_ zavl = let t_ = close zavl + in (isBalanced t_) && (asListL t_ == [0..s-1]) + +-- | Test Zipper insertL +testInsertL :: IO () +testInsertL = do title "Zipper insertL" + exhaustiveTest test (take 5 allNonEmptyAVL) + where test _ s t = all test_ [0..s-1] + where test_ n = let z = insertL s $ assertOpen (compare n) t + t_ = close z + in (getCurrent z == n) && (isBalanced t_) && + (asListL t_ == [0..n-1] ++ s:[n..s-1]) +-- | Test Zipper insertMoveL +testInsertMoveL :: IO () +testInsertMoveL = do title "Zipper insertMoveL" + exhaustiveTest test (take 5 allNonEmptyAVL) + where test _ s t = all test_ [0..s-1] + where test_ n = let z = insertMoveL s $ assertOpen (compare n) t + t_ = close z + in (getCurrent z == s) && (isBalanced t_) && + (asListL t_ == [0..n-1] ++ s:[n..s-1]) + +-- | Test Zipper insertR +testInsertR :: IO () +testInsertR = do title "Zipper insertR" + exhaustiveTest test (take 5 allNonEmptyAVL) + where test _ s t = all test_ [0..s-1] + where test_ n = let z = insertR (assertOpen (compare n) t) s + t_ = close z + in (getCurrent z == n) && (isBalanced t_) && + (asListL t_ == [0..n] ++ s:[(n+1)..s-1]) + +-- | Test Zipper insertMoveR +testInsertMoveR :: IO () +testInsertMoveR = do title "Zipper insertMoveR" + exhaustiveTest test (take 5 allNonEmptyAVL) + where test _ s t = all test_ [0..s-1] + where test_ n = let z = insertMoveR (assertOpen (compare n) t) s + t_ = close z + in (getCurrent z == s) && (isBalanced t_) && + (asListL t_ == [0..n] ++ s:[(n+1)..s-1]) + +-- | Test Zipper insertTreeL +testInsertTreeL :: IO () +testInsertTreeL = do title "Zipper insertTreeL" + exhaustiveTest test (take 5 allNonEmptyAVL) + where test _ s t = all test_ [0..s-1] + where test_ n = let z = insertTreeL t $ assertOpen (compare n) t + t_ = close z + in (getCurrent z == n) && (isBalanced t_) && + (asListL t_ == [0..n-1] ++ [0..s-1] ++ [n..s-1]) + +-- | Test Zipper insertTreeR +testInsertTreeR :: IO () +testInsertTreeR = do title "Zipper insertTreeR" + exhaustiveTest test (take 5 allNonEmptyAVL) + where test _ s t = all test_ [0..s-1] + where test_ n = let z = insertTreeR (assertOpen (compare n) t) t + t_ = close z + in (getCurrent z == n) && (isBalanced t_) && + (asListL t_ == [0..n] ++ [0..s-1] ++ [n+1..s-1]) +-- | Test Zipper assertDelMoveL +testDelMoveL :: IO () +testDelMoveL = do title "Zipper assertDelMoveL" + exhaustiveTest test (take 5 allNonEmptyAVL) + where test _ s t = let zavls = take s $ iterate assertDelMoveL $ insertR (assertOpenR t) s + in (L.map getCurrent zavls == L.reverse [0..s-1]) && + (and $ zipWith test_ zavls $ L.reverse [0..s-1]) + where test_ zavl s_ = let t_ = close zavl + in (isBalanced t_) && (asListL t_ == [0..s_] ++ [s]) + +-- | Test Zipper assertDelMoveR +testDelMoveR :: IO () +testDelMoveR = do title "Zipper assertDelMoveR" + exhaustiveTest test (take 5 allNonEmptyAVL) + where test _ s t = let zavls = take s $ iterate assertDelMoveR $ insertL s $ assertOpenL t + in (L.map getCurrent zavls == [0..s-1]) && + (and $ zipWith test_ zavls [0..s-1]) + where test_ zavl s_ = let t_ = close zavl + in (isBalanced t_) && (asListL t_ == s:[s_..s-1]) + +-- | Test Zipper delAllL +testDelAllL :: IO () +testDelAllL = do title "Zipper delAllL" + exhaustiveTest test (take 5 allNonEmptyAVL) + where test _ s t = all test_ [0..s-1] + where test_ n = let z = delAllL $ assertOpen (compare n) t + t_ = close z + t__ = close $ insertTreeL t z + in (isBalanced t_ ) && (asListL t_ == [n..s-1]) && + (isBalanced t__) && (asListL t__ == [0..s-1] ++ [n..s-1]) + +-- | Test Zipper delAllR +testDelAllR :: IO () +testDelAllR = do title "Zipper delAllR" + exhaustiveTest test (take 5 allNonEmptyAVL) + where test _ s t = all test_ [0..s-1] + where test_ n = let z = delAllR $ assertOpen (compare n) t + t_ = close z + t__ = close $ insertTreeR z t + in (isBalanced t_ ) && (asListL t_ == [0..n]) && + (isBalanced t__) && (asListL t__ == [0..n] ++ [0..s-1]) + +-- | Test Zipper delAllCloseL +testDelAllCloseL :: IO () +testDelAllCloseL = do title "Zipper delAllCloseL" + exhaustiveTest test (take 5 allNonEmptyAVL) + where test _ s t = all test_ [0..s-1] + where test_ n = let t_ = delAllCloseL $ assertOpen (compare n) t + in (isBalanced t_ ) && (asListL t_ == [n..s-1]) + +-- | Test Zipper delAllIncCloseL +testDelAllIncCloseL :: IO () +testDelAllIncCloseL = do title "Zipper delAllIncCloseL" + exhaustiveTest test (take 5 allNonEmptyAVL) + where test _ s t = all test_ [0..s-1] + where test_ n = let t_ = delAllIncCloseL $ assertOpen (compare n) t + in (isBalanced t_ ) && (asListL t_ == [n+1..s-1]) + +-- | Test Zipper delAllCloseR +testDelAllCloseR :: IO () +testDelAllCloseR = do title "Zipper delAllCloseR" + exhaustiveTest test (take 5 allNonEmptyAVL) + where test _ s t = all test_ [0..s-1] + where test_ n = let t_ = delAllCloseR $ assertOpen (compare n) t + in (isBalanced t_ ) && (asListL t_ == [0..n]) + +-- | Test Zipper delAllIncCloseR +testDelAllIncCloseR :: IO () +testDelAllIncCloseR = do title "Zipper delAllIncCloseR" + exhaustiveTest test (take 5 allNonEmptyAVL) + where test _ s t = all test_ [0..s-1] + where test_ n = let t_ = delAllIncCloseR $ assertOpen (compare n) t + in (isBalanced t_ ) && (asListL t_ == [0..n-1]) + +-- | Test Zipper sizeL\/sizeR\/sizeZAVL +testZipSize :: IO () +testZipSize = do title "Zipper sizeL/sizeR/sizeZAVL" + exhaustiveTest test (take 5 allNonEmptyAVL) + where test _ s t = all test_ [0..s-1] + where test_ n = let z = assertOpen (compare n) t + in (sizeL z == n) && (sizeR z == (s-1)-n) && (sizeZAVL z == s) + +-- | Test Zipper tryOpenGE +testTryOpenGE :: IO () +testTryOpenGE = do title "Zipper tryOpenGE" + exhaustiveTest test (take 5 allNonEmptyAVL) + where test _ s t = let t_ = map' (2*) t + in all (testE t_) [0,2..2*s-2] && all (testO t_) [(-1),1..2*s-3] + where testE t_ n = let Just z = tryOGE n t_ + t__ = close z + in (getCurrent z == n) && (isBalanced t__) && (asListL t__ == [0,2..2*s-2]) + testO t_ n = let Just z = tryOGE n t_ + t__ = close z + in (getCurrent z == n+1) && (isBalanced t__) && (asListL t__ == [0,2..2*s-2]) + tryOGE a = tryOpenGE (compare a) + +-- | Test Zipper tryOpenLE +testTryOpenLE :: IO () +testTryOpenLE = do title "Zipper tryOpenLE" + exhaustiveTest test (take 5 allNonEmptyAVL) + where test _ s t = let t_ = map' (2*) t + in all (testE t_) [0,2..2*s-2] && all (testO t_) [1,3..2*s-1] + where testE t_ n = let Just z = tryOLE n t_ + t__ = close z + in (getCurrent z == n) && (isBalanced t__) && (asListL t__ == [0,2..2*s-2]) + testO t_ n = let Just z = tryOLE n t_ + t__ = close z + in (getCurrent z == n-1) && (isBalanced t__) && (asListL t__ == [0,2..2*s-2]) + tryOLE a = tryOpenLE (compare a) + +-- | Test Zipper openEither (also tests fill and fillClose) +testOpenEither :: IO () +testOpenEither = do title "Zipper openEither" + exhaustiveTest test (take 6 allAVL) + where test _ s t = let t_ = map' (2*) t + in all (testE t_) [0,2..2*s-2] && all (testO t_) [-1,1..2*s-1] + where testE t_ n = let Right z = openEith n t_ + t__ = close z + in (getCurrent z == n) && (isBalanced t__) && (asListL t__ == [0,2..2*s-2]) + testO t_ n = let Left p = openEith n t_ + t__ = close (fill n p) + t___ = fillClose n p + in (isBalanced t__) && (isBalanced t___) && (t__ == t___) && + (asListL t__ == ([0,2..n-1] ++ n : [n+1,n+3..2*s-2])) + openEith a = openEither (compare a) + + + +-- | Test anyBAVLtoEither +testBAVLtoZipper :: IO () +testBAVLtoZipper = do title "BAVLtoZipper" + exhaustiveTest test (take 6 allAVL) + where test _ s t = let t_ = map' (2*) t + in all (testE t_) [0,2..2*s-2] && all (testO t_) [-1,1..2*s-1] + where testE t_ n = let bavl = oBAVL n t_ + Right z = anyBAVLtoEither bavl + t__ = close z + in (getCurrent z == n) && (isBalanced t__) && (asListL t__ == [0,2..2*s-2]) + testO t_ n = let bavl = oBAVL n t_ + Left p = anyBAVLtoEither bavl + t__ = fillClose n p + in (isBalanced t__) && (asListL t__ == ([0,2..n-1] ++ n : [n+1,n+3..2*s-2])) + oBAVL e = openBAVL (compare e) + + +-- | Test Show,Read,Eq instances +testShowReadEq :: IO () +testShowReadEq = do title "ShowReadEq" + exhaustiveTest test (take 5 allAVL) -- No need to get carried away with this one + where test _ _ t = t == (read $ show t) + +-- | Test readPath +testReadPath :: IO () +testReadPath = do title "ReadPath" + if all test [0..100] then passed else failed + where test n = let ASINT(n_)=n in (n == readPath n_ pathTree) + +title :: String -> IO () +title str = let titl = "* Test " ++ str ++ " *" + mark = L.replicate (length titl) '*' in putStrLn "" >> putStrLn mark >> putStrLn titl >> putStrLn mark passed :: IO () diff --git a/Data/Tree/AVL/Test/Utils.hs b/Data/Tree/AVL/Test/Utils.hs --- a/Data/Tree/AVL/Test/Utils.hs +++ b/Data/Tree/AVL/Test/Utils.hs @@ -25,7 +25,7 @@ ) where import Data.Tree.AVL.Types(AVL(..)) -import Data.Tree.AVL.List(mapAVL',asTreeLenL,asListL) +import Data.Tree.AVL.List(map',asTreeLenL,asListL) #ifdef __GLASGOW_HASKELL__ import GHC.Base @@ -142,7 +142,7 @@ 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 + r' = map' (addRight+) r t = r' `seq` con l rootEl r' in newSize `seq` t `seq` (t, newSize) -- interleave two lists (until one or other is []) diff --git a/Data/Tree/AVL/Types.hs b/Data/Tree/AVL/Types.hs --- a/Data/Tree/AVL/Types.hs +++ b/Data/Tree/AVL/Types.hs @@ -68,28 +68,29 @@ -- -- 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, +-- The 'AVL' tree data type is declared as non-strict in all it's fields, -- but all the functions in this library behave as though it is strict in its -- recursive fields (left and right sub-trees). Strictness in the element field is -- controlled either by using the strict variants of functions (defined in this library -- where appropriate), or using strict variants of the combinators defined in "Data.COrdering", -- or using 'seq' etc. in your own code (in any combining comparisons you define, for example). -- --- The Eq and Ord instances. +-- The 'Eq' and 'Ord' instances. -- -- Begining with version 3.0 these are now derived, and hence are defined in terms of -- strict structural equality, rather than observational equivalence. The reason for -- this change is that the observational equivalence abstraction was technically breakable -- with the exposed API. But since this change, some functions which were previously --- considered unsafe have become safe to expose (those that measure tree height). +-- considered unsafe have become safe to expose (those that measure tree height, for example). -- +-- The 'Read' and 'Show' instances. +-- +-- Begining with version 4.0 these are now derived to ensure consistency with 'Eq' instance. +-- (Show now reveals the exact tree structure). +-- + data AVL e = E -- ^ Empty Tree | N (AVL e) e (AVL e) -- ^ BF=-1 (right height > left height) | Z (AVL e) e (AVL e) -- ^ BF= 0 @@ -126,36 +127,36 @@ -- | Returns 'True' if an AVL tree is empty. -- -- Complexity: O(1) -{-# INLINE isEmpty #-} isEmpty :: AVL e -> Bool isEmpty E = True isEmpty _ = False +{-# INLINE isEmpty #-} -- | Returns 'True' if an AVL tree is non-empty. -- -- Complexity: O(1) -{-# INLINE isNonEmpty #-} isNonEmpty :: AVL e -> Bool isNonEmpty E = False isNonEmpty _ = True +{-# INLINE isNonEmpty #-} -- | Creates an AVL tree with just one element. -- -- Complexity: O(1) -{-# INLINE singleton #-} singleton :: e -> AVL e singleton e = Z E e E +{-# INLINE singleton #-} -- | Create an AVL tree of two elements, occuring in same order as the arguments. -{-# INLINE pair #-} pair :: e -> e -> AVL e pair e0 e1 = P (Z E e0 E) e1 E +{-# INLINE pair #-} -- | If the AVL tree is a singleton (has only one element @e@) then this function returns @('Just' e)@. -- Otherwise it returns Nothing. -- -- Complexity: O(1) -{-# 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 +{-# INLINE tryGetSingleton #-} diff --git a/Data/Tree/AVL/Write.hs b/Data/Tree/AVL/Write.hs --- a/Data/Tree/AVL/Write.hs +++ b/Data/Tree/AVL/Write.hs @@ -19,14 +19,14 @@ writeL,tryWriteL,writeR,tryWriteR, -- ** Writing to /sorted/ trees - genWrite,genWriteFast,genTryWrite,genWriteMaybe,genTryWriteMaybe + write,writeFast,tryWrite,writeMaybe,tryWriteMaybe ) where import Prelude -- so haddock finds the symbols there import Data.COrdering import Data.Tree.AVL.Types(AVL(..)) -import Data.Tree.AVL.BinPath(BinPath(..),genOpenPathWith,writePath) +import Data.Tree.AVL.BinPath(BinPath(..),openPathWith,writePath) --------------------------------------------------------------------------- -- writeL, tryWriteL -- @@ -137,61 +137,61 @@ -- 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 +write :: (e -> COrdering e) -> AVL e -> AVL e +write c t = case openPathWith c t of + FullBP pth e -> writePath pth e t + _ -> t --- | Functionally identical to 'genWrite', but returns an identical tree (one with all the nodes on +-- | Functionally identical to 'write', but returns an identical tree (one with all the nodes on -- the path duplicated) if the search fails. This should probably only be used if you know the -- search will succeed and will return an element which is different from that already present. -- -- Complexity: O(log n) -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' +writeFast :: (e -> COrdering e) -> AVL e -> AVL e +writeFast c = w where + w E = E + w (N l e r) = case c e of + Lt -> let l' = w l in l' `seq` N l' e r + Eq v -> N l v r + Gt -> let r' = w r in r' `seq` N l e r' + w (Z l e r) = case c e of + Lt -> let l' = w l in l' `seq` Z l' e r + Eq v -> Z l v r + Gt -> let r' = w r in r' `seq` Z l e r' + w (P l e r) = case c e of + Lt -> let l' = w l in l' `seq` P l' e r + Eq v -> P l v r + Gt -> let r' = w r in r' `seq` P l e r' -- | A general purpose function to perform a search of a tree, using the supplied selector. -- The found element is replaced by the value (@e@) of the @('Eq' e)@ constructor returned by -- the selector. This function returns 'Nothing' if the search failed. -- -- Complexity: O(log n) -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 +tryWrite :: (e -> COrdering e) -> AVL e -> Maybe (AVL e) +tryWrite c t = case openPathWith c t of + FullBP pth e -> Just $! writePath pth e t + _ -> Nothing --- | Similar to 'genWrite', but also returns the original tree if the search succeeds but +-- | Similar to 'write', but also returns the original tree if the search succeeds but -- the selector returns @('Eq' 'Nothing')@. (This version is intended to help reduce heap burn -- rate if it\'s likely that no modification of the value is needed.) -- -- Complexity: O(log n) -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 +writeMaybe :: (e -> COrdering (Maybe e)) -> AVL e -> AVL e +writeMaybe c t = case openPathWith c t of + FullBP pth (Just e) -> writePath pth e t + _ -> t --- | Similar to 'genTryWrite', but also returns the original tree if the search succeeds but +-- | Similar to 'tryWrite', but also returns the original tree if the search succeeds but -- the selector returns @('Eq' 'Nothing')@. (This version is intended to help reduce heap burn -- rate if it\'s likely that no modification of the value is needed.) -- -- Complexity: O(log n) -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 +tryWriteMaybe :: (e -> COrdering (Maybe e)) -> AVL e -> Maybe (AVL e) +tryWriteMaybe c t = case openPathWith c t of + FullBP pth (Just e) -> Just $! writePath pth e t + FullBP _ Nothing -> Just t + _ -> Nothing diff --git a/Data/Tree/AVL/Zipper.hs b/Data/Tree/AVL/Zipper.hs --- a/Data/Tree/AVL/Zipper.hs +++ b/Data/Tree/AVL/Zipper.hs @@ -44,9 +44,9 @@ -- ** Opening assertOpenL,assertOpenR, tryOpenL,tryOpenR, - genAssertOpen,genTryOpen, - genTryOpenGE,genTryOpenLE, - genOpenEither, + assertOpen,tryOpen, + tryOpenGE,tryOpenLE, + openEither, -- ** Closing close,fillClose, @@ -92,7 +92,7 @@ BAVL, -- *** Opening and closing - genOpenBAVL,closeBAVL, + openBAVL,closeBAVL, -- *** Inspecting status fullBAVL,emptyBAVL,tryReadBAVL,readFullBAVL, @@ -115,7 +115,7 @@ import Data.Tree.AVL.Internals.DelUtils(deletePath,popRN,popRZ,popRP,popLN,popLZ,popLP) import Data.Tree.AVL.Internals.HJoin(spliceH,joinH) import Data.Tree.AVL.Internals.HPush(pushHL,pushHR) -import Data.Tree.AVL.BinPath(BinPath(..),genOpenPath,writePath,insertPath,sel,goL,goR) +import Data.Tree.AVL.BinPath(BinPath(..),openPath,writePath,insertPath,sel,goL,goR) #ifdef __GLASGOW_HASKELL__ import GHC.Base @@ -194,10 +194,10 @@ -- 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 !! +assertOpen :: (e -> Ordering) -> AVL e -> ZAVL e +assertOpen c t = op EP L(0) t where -- Relative heights !! -- op :: (Path e) -> UINT -> AVL e -> ZAVL e - op _ _ E = error "genAssertOpen: No matching element." + op _ _ E = error "assertOpen: No matching element." op p h (N l e r) = case c e of LT -> let p_ = LP p e r DECINT1(h) in p_ `seq` op p_ DECINT2(h) l EQ -> ZAVL p l DECINT2(h) e r DECINT1(h) @@ -216,12 +216,12 @@ -- -- 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\" +-- is likely. In cases like this it may be better to use 'openBAVL', test for \"fullness\" -- using 'fullBAVL' and then convert to a 'ZAVL' using 'fullBAVLtoZAVL'. -- -- Complexity: O(log n) -genTryOpen :: (e -> Ordering) -> AVL e -> Maybe (ZAVL e) -genTryOpen c t = op EP L(0) t where -- Relative heights !! +tryOpen :: (e -> Ordering) -> AVL e -> Maybe (ZAVL e) +tryOpen c t = op EP L(0) t where -- Relative heights !! -- op :: (Path e) -> UINT -> AVL e -> Maybe (ZAVL e) op _ _ E = Nothing op p h (N l e r) = case c e of @@ -241,8 +241,8 @@ -- 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 !! +tryOpenGE :: (e -> Ordering) -> AVL e -> Maybe (ZAVL e) +tryOpenGE c t = op EP L(0) t where -- Relative heights !! -- op :: (Path e) -> UINT -> AVL e -> ZAVL e op p h E = backupR p E h where backupR EP _ _ = Nothing @@ -265,8 +265,8 @@ -- 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 !! +tryOpenLE :: (e -> Ordering) -> AVL e -> Maybe (ZAVL e) +tryOpenLE c t = op EP L(0) t where -- Relative heights !! -- op :: (Path e) -> UINT -> AVL e -> ZAVL e op p h E = backupL p E h where backupL EP _ _ = Nothing @@ -376,8 +376,8 @@ -- 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 !! +openEither :: (e -> Ordering) -> AVL e -> Either (PAVL e) (ZAVL e) +openEither c t = op EP L(0) t where -- Relative heights !! -- op :: (Path e) -> UINT -> AVL e -> Either (PAVL e) (ZAVL e) op p h E = Left $! PAVL p h op p h (N l e r) = case c e of @@ -784,10 +784,10 @@ -- 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 +openBAVL :: (e -> Ordering) -> AVL e -> BAVL e +{-# INLINE openBAVL #-} +openBAVL c t = bp `seq` BAVL t bp + where bp = openPath c t -- | Returns the original tree, extracted from the 'BAVL'. Typically you will not need this, as -- the original tree will still be in scope in most cases. diff --git a/Data/Tree/AVLX.hs b/Data/Tree/AVLX.hs --- a/Data/Tree/AVLX.hs +++ b/Data/Tree/AVLX.hs @@ -27,6 +27,7 @@ module Data.Tree.AVL.Write, module Data.Tree.AVL.Zipper, module Data.Tree.AVL.BinPath, + module Data.Tree.AVL.Deprecated, module Data.Tree.AVL.Internals.DelUtils, module Data.Tree.AVL.Internals.HAVL, module Data.Tree.AVL.Internals.HJoin, @@ -57,5 +58,6 @@ import Data.Tree.AVL.Internals.HSet import Data.Tree.AVL.Test.Counter import Data.Tree.AVL.Test.Utils +import Data.Tree.AVL.Deprecated