AvlTree 4.1 → 4.2

raw patch · 19 files changed

+2932/−2096 lines, 19 filesdep ~COrderingPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: COrdering

API changes (from Hackage documentation)

Files

• AvlTree.cabal +3/−2
• CHANGELOG +7/−0
• Data/Tree/AVL.hs +21/−16
• Data/Tree/AVL/BinPath.hs +22/−7
• Data/Tree/AVL/Delete.hs +42/−43
• Data/Tree/AVL/Deprecated.hs +683/−0
• Data/Tree/AVL/Internals/HSet.hs +89/−13
• Data/Tree/AVL/List.hs +241/−218
• Data/Tree/AVL/Push.hs +37/−37
• Data/Tree/AVL/Read.hs +38/−38
• Data/Tree/AVL/Set.hs +79/−81
• Data/Tree/AVL/Size.hs +52/−33
• Data/Tree/AVL/Split.hs +95/−95
• Data/Tree/AVL/Test/AllTests.hs +1447/−1440
• Data/Tree/AVL/Test/Utils.hs +2/−2
• Data/Tree/AVL/Types.hs +14/−13
• Data/Tree/AVL/Write.hs +37/−37
• Data/Tree/AVL/Zipper.hs +21/−21
• Data/Tree/AVLX.hs +2/−0

@@ -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,

@@ -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
+

@@ -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

@@ -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

@@ -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

@@ -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 #-}

@@ -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)  

@@ -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 

@@ -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

@@ -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

@@ -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 #-} 

@@ -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

@@ -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 #-} 

@@ -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) &&-                                         (asListL l == l_) && (asListL r == r_)---- | Test takeWhileL function-testTakeWhileL :: IO ()-testTakeWhileL = do title "takeWhileL"-                    exhaustiveTest test (take 6 allAVL)-                 where test _ s t = all spanTest [0..s]-                        where tlist = asListL t-                              spanTest n = let l  = takeWhileL (<n) t-                                               l_ = takeWhile  (<n) tlist-                                           in (isBalanced l) && (asListL l == l_)---- | Test dropWhileL function-testDropWhileL :: IO ()-testDropWhileL = do title "dropWhileL"-                    exhaustiveTest test (take 6 allAVL)-                 where test _ s t = all spanTest [0..s]-                        where tlist = asListL t-                              spanTest n = let r  = dropWhileL (<n) t-                                               r_ = dropWhile  (<n) tlist-                                           in (isBalanced r) && (asListL r == r_)---- | Test spanR function-testSpanR :: IO ()-testSpanR = do title "spanR"-               exhaustiveTest test (take 6 allAVL)-            where test _ s t = all spanTest [0..s]-                   where tlist = asListR t-                         spanTest n = let (l ,r ) = spanR (>=n) t-                                          (l_,r_) = span  (>=n) tlist-                                      in (isBalanced l) && (isBalanced r) &&-                                         (asListR l == r_) && (asListR r == l_)---- | Test takeWhileR function-testTakeWhileR :: IO ()-testTakeWhileR = do title "takeWhileR"-                    exhaustiveTest test (take 6 allAVL)-                 where test _ s t = all spanTest [0..s]-                        where tlist = asListR t-                              spanTest n = let r  = takeWhileR (>=n) t-                                               r_ = takeWhile  (>=n) tlist-                                           in (isBalanced r) && (asListR r == r_)---- | Test dropWhileR function-testDropWhileR :: IO ()-testDropWhileR = do title "dropWhileR"-                    exhaustiveTest test (take 6 allAVL)-                 where test _ s t = all spanTest [0..s]-                        where tlist = asListR t-                              spanTest n = let l  = dropWhileR (>=n) t-                                               l_ = dropWhile  (>=n) tlist-                                           in (isBalanced l) && (asListR l == l_)---- | Test rotateL function-testRotateL :: IO ()-testRotateL = do title "rotateL"-                 exhaustiveTest test (take 6 allAVL)-              where test _ s t = all isOK rotations-                     where rotations = take s $ tail $ iterate (mapAVL' (\n -> (n-1) `mod` s) . rotateL) t-                           isOK t_ = (isBalanced t_) && (asListL t_ == tlist)-                           tlist   = asListL t--- | Test rotateR function-testRotateR :: IO ()-testRotateR = do title "rotateR"-                 exhaustiveTest test (take 6 allAVL)-              where test _ s t = all isOK rotations-                     where rotations = take s $ tail $ iterate (mapAVL' (\n -> (n+1) `mod` s) . rotateR) t-                           isOK t_ = (isBalanced t_) && (asListL t_ == tlist)-                           tlist   = asListL t---- | Test rotateByL function-testRotateByL :: IO ()-testRotateByL = do title "rotateByL"-                   exhaustiveTest test (take 6 allAVL)-                where test _ s t = all isOK $ map rotateIt [-1..s]-                       where rotateIt n = mapAVL' (\n_ -> (n_-n) `mod` s) $ rotateByL t n-                             isOK t_ = (isBalanced t_) && (asListL t_ == tlist)-                             tlist   = asListL t---- | Test rotateByR function-testRotateByR :: IO ()-testRotateByR = do title "rotateByR"-                   exhaustiveTest test (take 6 allAVL)-                where test _ s t = all isOK $ map rotateIt [-1..s]-                       where rotateIt n = mapAVL' (\n_ -> (n_+n) `mod` s) $ rotateByR t n-                             isOK t_ = (isBalanced t_) && (asListL t_ == tlist)-                             tlist   = asListL t---- | Test genForkL function-testGenForkL :: IO ()-testGenForkL = do title "genForkL"-                  exhaustiveTest test (take 6 allAVL)-               where test _ s t = all testForkL [-1..s-1]-                      where tlist = asListL t-                            testForkL n = let (l,r) = genForkL (compare n) t-                                          in (isBalanced l) && (isBalanced r) &&-                                             (size l == n+1) && (size r == s-(n+1)) &&-                                             (l `toListL` asListL r == tlist)---- | Test genForkR function-testGenForkR :: IO ()-testGenForkR = do title "genForkR"-                  exhaustiveTest test (take 6 allAVL)-               where test _ s t = all testForkR [0..s]-                      where tlist = asListL t-                            testForkR n = let (l,r) = genForkR (compare n) t-                                          in (isBalanced l) && (isBalanced r) &&-                                             (size l == n) && (size r == s-n) &&-                                             (l `toListL` asListL r == tlist)----- | Test genFork function-testGenFork :: IO ()-testGenFork = do title "genFork"-                 exhaustiveTest test (take 6 allAVL)-              where test _ s t = all testFork0 [0..s-1] && testFork1 (-1) && testFork2 s-                      where tlist = asListL t-                            testFork0 n = let (l,mbn,r) = genFork (fstCC n) t-                                          in case mbn of-                                             Just n_ -> (n_==n) && (isBalanced l) && (isBalanced r) &&-                                                        (size l == n) && (size r == s-(n+1)) &&-                                                        (l `toListL` (n : asListL r) == tlist)-                                             _       -> False-                            testFork1 n = let (l,mbn,r) = genFork (fstCC n) t-                                          in case mbn of-                                             Nothing -> (isEmpty l) && (isBalanced r) && (asListL r == tlist)-                                             _       -> False-                            testFork2 n = let (l,mbn,r) = genFork (fstCC n) t-                                          in case mbn of-                                             Nothing -> (isEmpty r) && (isBalanced l) && (asListL l == tlist)-                                             _       -> False---- | Test genTakeLE function-testGenTakeLE :: IO ()-testGenTakeLE = do title "genTakeLE"-                   exhaustiveTest test (take 6 allAVL)-                where test _ s t = all testTakeLE [-1..s-1]-                       where testTakeLE n = let l = genTakeLE (compare n) t-                                            in (isBalanced l) && (asListL l == [0..n])---- | Test genTakeLT function-testGenTakeLT :: IO ()-testGenTakeLT = do title "genTakeLT"-                   exhaustiveTest test (take 6 allAVL)-                where test _ s t = all testTakeLT [0..s]-                       where testTakeLT n = let l = genTakeLT (compare n) t-                                            in (isBalanced l) && (asListL l == [0..n-1])---- | Test genTakeGT function-testGenTakeGT :: IO ()-testGenTakeGT = do title "genTakeGT"-                   exhaustiveTest test (take 6 allAVL)-                where test _ s t = all testTakeGT [-1..s-1]-                       where testTakeGT n = let r = genTakeGT (compare n) t-                                            in (isBalanced r) && (asListL r == [n+1..s-1])---- | Test genTakeGE function-testGenTakeGE :: IO ()-testGenTakeGE = do title "genTakeGE"-                   exhaustiveTest test (take 6 allAVL)-                where test _ s t = all testTakeGE [0..s]-                       where testTakeGE n = let r = genTakeGE (compare n) t-                                            in (isBalanced r) && (asListL r == [n..s-1])---- | Test the genUnion function-testGenUnion :: IO ()-testGenUnion = let trees = take num $ concatMap (\(_,ts) -> ts) allAVL-                   num   = 1000-               in do title "genUnion"-                     putStrLn $ "Testing " ++ show (num*num) ++ " tree pairs.."-                     if and [test l ls r rs | (l,ls) <- trees, (r,rs) <- trees] then passed else failed-                  where test  l ls r rs = all (\f -> f l ls r rs) [test1,test2,test3]-                        test1 l ls r rs = let u = unionFst l r-                                          in isBalanced u && (asListL u == [0 .. max ls rs - 1])-                        test2 l ls r rs = and  [test2_ n $ mapAVL' (n+) r | n <- [(-rs)..ls]]-                         where test2_ n r_ = let u = unionFst l r_-                                             in isBalanced u && (asListL u == [min n 0 .. max ls (rs+n) - 1])-                        test3 l ls r rs = let l_ = mapAVL' (\n -> n+n  ) l -- even-                                              r_ = mapAVL' (\n -> n+n+1) r -- odd-                                              u  = unionFst l_ r_-                                          in isSortedOK compare u && (size u == ls+rs)-                        unionFst = genUnion fstCC---- | Test the 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) &&+                                         (asListL l == l_) && (asListL r == r_)++-- | Test takeWhileL function+testTakeWhileL :: IO ()+testTakeWhileL = do title "takeWhileL"+                    exhaustiveTest test (take 6 allAVL)+                 where test _ s t = all spanTest [0..s]+                        where tlist = asListL t+                              spanTest n = let l  = takeWhileL (<n) t+                                               l_ = takeWhile  (<n) tlist+                                           in (isBalanced l) && (asListL l == l_)++-- | Test dropWhileL function+testDropWhileL :: IO ()+testDropWhileL = do title "dropWhileL"+                    exhaustiveTest test (take 6 allAVL)+                 where test _ s t = all spanTest [0..s]+                        where tlist = asListL t+                              spanTest n = let r  = dropWhileL (<n) t+                                               r_ = dropWhile  (<n) tlist+                                           in (isBalanced r) && (asListL r == r_)++-- | Test spanR function+testSpanR :: IO ()+testSpanR = do title "spanR"+               exhaustiveTest test (take 6 allAVL)+            where test _ s t = all spanTest [0..s]+                   where tlist = asListR t+                         spanTest n = let (l ,r ) = spanR (>=n) t+                                          (l_,r_) = span  (>=n) tlist+                                      in (isBalanced l) && (isBalanced r) &&+                                         (asListR l == r_) && (asListR r == l_)++-- | Test takeWhileR function+testTakeWhileR :: IO ()+testTakeWhileR = do title "takeWhileR"+                    exhaustiveTest test (take 6 allAVL)+                 where test _ s t = all spanTest [0..s]+                        where tlist = asListR t+                              spanTest n = let r  = takeWhileR (>=n) t+                                               r_ = takeWhile  (>=n) tlist+                                           in (isBalanced r) && (asListR r == r_)++-- | Test dropWhileR function+testDropWhileR :: IO ()+testDropWhileR = do title "dropWhileR"+                    exhaustiveTest test (take 6 allAVL)+                 where test _ s t = all spanTest [0..s]+                        where tlist = asListR t+                              spanTest n = let l  = dropWhileR (>=n) t+                                               l_ = dropWhile  (>=n) tlist+                                           in (isBalanced l) && (asListR l == l_)++-- | Test rotateL function+testRotateL :: IO ()+testRotateL = do title "rotateL"+                 exhaustiveTest test (take 6 allAVL)+              where test _ s t = all isOK rotations+                     where rotations = take s $ tail $ iterate (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 ()

@@ -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 [])

@@ -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 #-}

@@ -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  

@@ -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.

@@ -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