AvlTree 4.2 → 4.3
raw patch · 53 files changed
+9909/−10981 lines, 53 filesdep +AvlTreedep ~COrderingdep ~basesetup-changednew-uploaderPVP ok
version bump matches the API change (PVP)
Dependencies added: AvlTree
Dependency ranges changed: COrdering, base
API changes (from Hackage documentation)
- Data.Tree.AVL: E :: AVL e
- Data.Tree.AVL: N :: (AVL e) -> e -> (AVL e) -> AVL e
- Data.Tree.AVL: P :: (AVL e) -> e -> (AVL e) -> AVL e
- Data.Tree.AVL: Z :: (AVL e) -> e -> (AVL e) -> AVL e
- Data.Tree.AVL: fastAddSize :: Int# -> AVL e -> Int#
- Data.Tree.AVL: filterAVL :: (e -> Bool) -> AVL e -> AVL e
- Data.Tree.AVL: findPath :: (e -> Ordering) -> AVL e -> Int#
- Data.Tree.AVL: foldl1AVL :: (e -> e -> e) -> AVL e -> e
- Data.Tree.AVL: foldl1AVL' :: (e -> e -> e) -> AVL e -> e
- Data.Tree.AVL: foldl2AVL :: (a -> e -> a) -> (e -> a) -> AVL e -> a
- Data.Tree.AVL: foldl2AVL' :: (a -> e -> a) -> (e -> a) -> AVL e -> a
- Data.Tree.AVL: foldlAVL :: (a -> e -> a) -> a -> AVL e -> a
- Data.Tree.AVL: foldlAVL' :: (a -> e -> a) -> a -> AVL e -> a
- Data.Tree.AVL: foldr1AVL :: (e -> e -> e) -> AVL e -> e
- Data.Tree.AVL: foldr1AVL' :: (e -> e -> e) -> AVL e -> e
- Data.Tree.AVL: foldr2AVL :: (e -> a -> a) -> (e -> a) -> AVL e -> a
- Data.Tree.AVL: foldr2AVL' :: (e -> a -> a) -> (e -> a) -> AVL e -> a
- Data.Tree.AVL: foldrAVL :: (e -> a -> a) -> a -> AVL e -> a
- Data.Tree.AVL: foldrAVL' :: (e -> a -> a) -> a -> AVL e -> a
- Data.Tree.AVL: foldrAVL_UINT :: (e -> Int# -> Int#) -> Int# -> AVL e -> Int#
- Data.Tree.AVL: genAsTree :: (e -> e -> COrdering e) -> [e] -> AVL e
- Data.Tree.AVL: genAssertOpen :: (e -> Ordering) -> AVL e -> ZAVL e
- Data.Tree.AVL: genAssertPop :: (e -> COrdering a) -> AVL e -> (a, AVL e)
- Data.Tree.AVL: genAssertPopIf :: (e -> COrdering (a, Bool)) -> AVL e -> (a, AVL e)
- Data.Tree.AVL: genAssertPopMaybe :: (e -> COrdering (a, Maybe e)) -> AVL e -> (a, AVL e)
- Data.Tree.AVL: genAssertRead :: AVL e -> (e -> COrdering a) -> a
- Data.Tree.AVL: genContains :: AVL e -> (e -> Ordering) -> Bool
- Data.Tree.AVL: genDefaultRead :: a -> AVL e -> (e -> COrdering a) -> a
- Data.Tree.AVL: genDel :: (e -> Ordering) -> AVL e -> AVL e
- Data.Tree.AVL: genDelFast :: (e -> Ordering) -> AVL e -> AVL e
- Data.Tree.AVL: genDelIf :: (e -> COrdering Bool) -> AVL e -> AVL e
- Data.Tree.AVL: genDelMaybe :: (e -> COrdering (Maybe e)) -> AVL e -> AVL e
- Data.Tree.AVL: genDifference :: (a -> b -> Ordering) -> AVL a -> AVL b -> AVL a
- Data.Tree.AVL: genDifferenceMaybe :: (a -> b -> COrdering (Maybe a)) -> AVL a -> AVL b -> AVL a
- Data.Tree.AVL: genDisjointUnion :: (e -> e -> Ordering) -> AVL e -> AVL e -> AVL e
- Data.Tree.AVL: genDropGE :: (e -> Ordering) -> AVL e -> AVL e
- Data.Tree.AVL: genDropGT :: (e -> Ordering) -> AVL e -> AVL e
- Data.Tree.AVL: genDropLE :: (e -> Ordering) -> AVL e -> AVL e
- Data.Tree.AVL: genDropLT :: (e -> Ordering) -> AVL e -> AVL e
- Data.Tree.AVL: genFindPath :: (e -> Ordering) -> AVL e -> Int#
- Data.Tree.AVL: genFork :: (e -> COrdering a) -> AVL e -> (AVL e, Maybe a, AVL e)
- Data.Tree.AVL: genForkL :: (e -> Ordering) -> AVL e -> (AVL e, AVL e)
- Data.Tree.AVL: genForkR :: (e -> Ordering) -> AVL e -> (AVL e, AVL e)
- Data.Tree.AVL: genIntersection :: (a -> b -> COrdering c) -> AVL a -> AVL b -> AVL c
- Data.Tree.AVL: genIntersectionAsListL :: (a -> b -> COrdering c) -> AVL a -> AVL b -> [c]
- Data.Tree.AVL: genIntersectionMaybe :: (a -> b -> COrdering (Maybe c)) -> AVL a -> AVL b -> AVL c
- Data.Tree.AVL: genIntersectionMaybeAsListL :: (a -> b -> COrdering (Maybe c)) -> AVL a -> AVL b -> [c]
- Data.Tree.AVL: genIntersectionMaybeToListL :: (a -> b -> COrdering (Maybe c)) -> AVL a -> AVL b -> [c] -> [c]
- Data.Tree.AVL: genIntersectionToListL :: (a -> b -> COrdering c) -> AVL a -> AVL b -> [c] -> [c]
- Data.Tree.AVL: genIsSubsetOf :: (a -> b -> Ordering) -> AVL a -> AVL b -> Bool
- Data.Tree.AVL: genIsSubsetOfBy :: (a -> b -> COrdering Bool) -> AVL a -> AVL b -> Bool
- Data.Tree.AVL: genOpenBAVL :: (e -> Ordering) -> AVL e -> BAVL e
- Data.Tree.AVL: genOpenEither :: (e -> Ordering) -> AVL e -> Either (PAVL e) (ZAVL e)
- Data.Tree.AVL: genOpenPath :: (e -> Ordering) -> AVL e -> BinPath e
- Data.Tree.AVL: genOpenPathWith :: (e -> COrdering a) -> AVL e -> BinPath a
- Data.Tree.AVL: genPush :: (e -> COrdering e) -> e -> AVL e -> AVL e
- Data.Tree.AVL: genPush' :: (e -> COrdering e) -> e -> AVL e -> AVL e
- Data.Tree.AVL: genPushMaybe :: (e -> COrdering (Maybe e)) -> e -> AVL e -> AVL e
- Data.Tree.AVL: genPushMaybe' :: (e -> COrdering (Maybe e)) -> e -> AVL e -> AVL e
- Data.Tree.AVL: genSymDifference :: (e -> e -> Ordering) -> AVL e -> AVL e -> AVL e
- Data.Tree.AVL: genTakeGE :: (e -> Ordering) -> AVL e -> AVL e
- Data.Tree.AVL: genTakeGT :: (e -> Ordering) -> AVL e -> AVL e
- Data.Tree.AVL: genTakeLE :: (e -> Ordering) -> AVL e -> AVL e
- Data.Tree.AVL: genTakeLT :: (e -> Ordering) -> AVL e -> AVL e
- Data.Tree.AVL: genTryOpen :: (e -> Ordering) -> AVL e -> Maybe (ZAVL e)
- Data.Tree.AVL: genTryOpenGE :: (e -> Ordering) -> AVL e -> Maybe (ZAVL e)
- Data.Tree.AVL: genTryOpenLE :: (e -> Ordering) -> AVL e -> Maybe (ZAVL e)
- Data.Tree.AVL: genTryPop :: (e -> COrdering a) -> AVL e -> Maybe (a, AVL e)
- Data.Tree.AVL: genTryPopIf :: (e -> COrdering (a, Bool)) -> AVL e -> Maybe (a, AVL e)
- Data.Tree.AVL: genTryPopMaybe :: (e -> COrdering (a, Maybe e)) -> AVL e -> Maybe (a, AVL e)
- Data.Tree.AVL: genTryRead :: AVL e -> (e -> COrdering a) -> Maybe a
- Data.Tree.AVL: genTryReadMaybe :: AVL e -> (e -> COrdering (Maybe a)) -> Maybe a
- Data.Tree.AVL: genTryWrite :: (e -> COrdering e) -> AVL e -> Maybe (AVL e)
- Data.Tree.AVL: genTryWriteMaybe :: (e -> COrdering (Maybe e)) -> AVL e -> Maybe (AVL e)
- Data.Tree.AVL: genUnion :: (e -> e -> COrdering e) -> AVL e -> AVL e -> AVL e
- Data.Tree.AVL: genUnionMaybe :: (e -> e -> COrdering (Maybe e)) -> AVL e -> AVL e -> AVL e
- Data.Tree.AVL: genUnions :: (e -> e -> COrdering e) -> [AVL e] -> AVL e
- Data.Tree.AVL: genVenn :: (a -> b -> COrdering c) -> AVL a -> AVL b -> (AVL a, AVL c, AVL b)
- Data.Tree.AVL: genVennAsList :: (a -> b -> COrdering c) -> AVL a -> AVL b -> (AVL a, [c], AVL b)
- Data.Tree.AVL: genVennMaybe :: (a -> b -> COrdering (Maybe c)) -> AVL a -> AVL b -> (AVL a, AVL c, AVL b)
- Data.Tree.AVL: genVennMaybeAsList :: (a -> b -> COrdering (Maybe c)) -> AVL a -> AVL b -> (AVL a, [c], AVL b)
- Data.Tree.AVL: genVennMaybeToList :: (a -> b -> COrdering (Maybe c)) -> [c] -> AVL a -> AVL b -> (AVL a, [c], AVL b)
- Data.Tree.AVL: genVennToList :: (a -> b -> COrdering c) -> [c] -> AVL a -> AVL b -> (AVL a, [c], AVL b)
- Data.Tree.AVL: genWrite :: (e -> COrdering e) -> AVL e -> AVL e
- Data.Tree.AVL: genWriteFast :: (e -> COrdering e) -> AVL e -> AVL e
- Data.Tree.AVL: genWriteMaybe :: (e -> COrdering (Maybe e)) -> AVL e -> AVL e
- Data.Tree.AVL: instance Functor AVL
- Data.Tree.AVL: instance Traversable AVL
- Data.Tree.AVL: mapAVL :: (a -> b) -> AVL a -> AVL b
- Data.Tree.AVL: mapAVL' :: (a -> b) -> AVL a -> AVL b
- Data.Tree.AVL: mapAccumLAVL :: (z -> a -> (z, b)) -> z -> AVL a -> (z, AVL b)
- Data.Tree.AVL: mapAccumLAVL' :: (z -> a -> (z, b)) -> z -> AVL a -> (z, AVL b)
- Data.Tree.AVL: mapAccumLAVL'' :: (z -> a -> (# z, b #)) -> z -> AVL a -> (z, AVL b)
- Data.Tree.AVL: mapAccumRAVL :: (z -> a -> (z, b)) -> z -> AVL a -> (z, AVL b)
- Data.Tree.AVL: mapAccumRAVL' :: (z -> a -> (z, b)) -> z -> AVL a -> (z, AVL b)
- Data.Tree.AVL: mapAccumRAVL'' :: (z -> a -> (# z, b #)) -> z -> AVL a -> (z, AVL b)
- Data.Tree.AVL: mapMaybeAVL :: (a -> Maybe b) -> AVL a -> AVL b
- Data.Tree.AVL: partitionAVL :: (e -> Bool) -> AVL e -> (AVL e, AVL e)
- Data.Tree.AVL: replicateAVL :: Int -> e -> AVL e
- Data.Tree.AVL: reverseAVL :: AVL e -> AVL e
- Data.Tree.AVL.Test.AllTests: allTests :: IO ()
- Data.Tree.AVL.Test.AllTests: testAssertDelL :: IO ()
- Data.Tree.AVL.Test.AllTests: testAssertDelR :: IO ()
- Data.Tree.AVL.Test.AllTests: testAssertPop :: IO ()
- Data.Tree.AVL.Test.AllTests: testAssertPopL :: IO ()
- Data.Tree.AVL.Test.AllTests: testAssertPopR :: IO ()
- Data.Tree.AVL.Test.AllTests: testBAVLtoZipper :: IO ()
- Data.Tree.AVL.Test.AllTests: testClipSize :: IO ()
- Data.Tree.AVL.Test.AllTests: testCompareHeight :: IO ()
- Data.Tree.AVL.Test.AllTests: testConcatAVL :: IO ()
- Data.Tree.AVL.Test.AllTests: testDelAllCloseL :: IO ()
- Data.Tree.AVL.Test.AllTests: testDelAllCloseR :: IO ()
- Data.Tree.AVL.Test.AllTests: testDelAllIncCloseL :: IO ()
- Data.Tree.AVL.Test.AllTests: testDelAllIncCloseR :: IO ()
- Data.Tree.AVL.Test.AllTests: testDelAllL :: IO ()
- Data.Tree.AVL.Test.AllTests: testDelAllR :: IO ()
- Data.Tree.AVL.Test.AllTests: testDelClose :: IO ()
- Data.Tree.AVL.Test.AllTests: testDelMoveL :: IO ()
- Data.Tree.AVL.Test.AllTests: testDelMoveR :: IO ()
- Data.Tree.AVL.Test.AllTests: testDelete :: IO ()
- Data.Tree.AVL.Test.AllTests: testDifference :: IO ()
- Data.Tree.AVL.Test.AllTests: testDifferenceMaybe :: IO ()
- Data.Tree.AVL.Test.AllTests: testDisjointUnion :: IO ()
- Data.Tree.AVL.Test.AllTests: testDropL :: IO ()
- Data.Tree.AVL.Test.AllTests: testDropR :: IO ()
- Data.Tree.AVL.Test.AllTests: testDropWhileL :: IO ()
- Data.Tree.AVL.Test.AllTests: testDropWhileR :: IO ()
- Data.Tree.AVL.Test.AllTests: testFilter :: IO ()
- Data.Tree.AVL.Test.AllTests: testFilterViaList :: IO ()
- Data.Tree.AVL.Test.AllTests: testFlatConcat :: IO ()
- Data.Tree.AVL.Test.AllTests: testFlatten :: IO ()
- Data.Tree.AVL.Test.AllTests: testFoldl :: IO ()
- Data.Tree.AVL.Test.AllTests: testFoldl' :: IO ()
- Data.Tree.AVL.Test.AllTests: testFoldl1 :: IO ()
- Data.Tree.AVL.Test.AllTests: testFoldl1' :: IO ()
- Data.Tree.AVL.Test.AllTests: testFoldr :: IO ()
- Data.Tree.AVL.Test.AllTests: testFoldr' :: IO ()
- Data.Tree.AVL.Test.AllTests: testFoldr1 :: IO ()
- Data.Tree.AVL.Test.AllTests: testFoldr1' :: IO ()
- Data.Tree.AVL.Test.AllTests: testFork :: IO ()
- Data.Tree.AVL.Test.AllTests: testForkL :: IO ()
- Data.Tree.AVL.Test.AllTests: testForkR :: IO ()
- Data.Tree.AVL.Test.AllTests: testInsertL :: IO ()
- Data.Tree.AVL.Test.AllTests: testInsertMoveL :: IO ()
- Data.Tree.AVL.Test.AllTests: testInsertMoveR :: IO ()
- Data.Tree.AVL.Test.AllTests: testInsertR :: IO ()
- Data.Tree.AVL.Test.AllTests: testInsertTreeL :: IO ()
- Data.Tree.AVL.Test.AllTests: testInsertTreeR :: IO ()
- Data.Tree.AVL.Test.AllTests: testIntersection :: IO ()
- Data.Tree.AVL.Test.AllTests: testIntersectionAsList :: IO ()
- Data.Tree.AVL.Test.AllTests: testIntersectionMaybe :: IO ()
- Data.Tree.AVL.Test.AllTests: testIntersectionMaybeAsList :: IO ()
- Data.Tree.AVL.Test.AllTests: testIsBalanced :: IO ()
- Data.Tree.AVL.Test.AllTests: testIsSorted :: IO ()
- Data.Tree.AVL.Test.AllTests: testIsSubsetOf :: IO ()
- Data.Tree.AVL.Test.AllTests: testIsSubsetOfBy :: IO ()
- Data.Tree.AVL.Test.AllTests: testJoin :: IO ()
- Data.Tree.AVL.Test.AllTests: testJoinHAVL :: IO ()
- Data.Tree.AVL.Test.AllTests: testMapAccumL :: IO ()
- Data.Tree.AVL.Test.AllTests: testMapAccumL' :: IO ()
- Data.Tree.AVL.Test.AllTests: testMapAccumL'' :: IO ()
- Data.Tree.AVL.Test.AllTests: testMapAccumR :: IO ()
- Data.Tree.AVL.Test.AllTests: testMapAccumR' :: IO ()
- Data.Tree.AVL.Test.AllTests: testMapAccumR'' :: IO ()
- Data.Tree.AVL.Test.AllTests: testMapMaybe :: IO ()
- Data.Tree.AVL.Test.AllTests: testMapMaybeViaList :: IO ()
- Data.Tree.AVL.Test.AllTests: testMoveL :: IO ()
- Data.Tree.AVL.Test.AllTests: testMoveR :: IO ()
- Data.Tree.AVL.Test.AllTests: testOpenClose :: IO ()
- Data.Tree.AVL.Test.AllTests: testOpenEither :: IO ()
- Data.Tree.AVL.Test.AllTests: testOpenLClose :: IO ()
- Data.Tree.AVL.Test.AllTests: testOpenRClose :: IO ()
- Data.Tree.AVL.Test.AllTests: testPopHL :: IO ()
- Data.Tree.AVL.Test.AllTests: testPush :: IO ()
- Data.Tree.AVL.Test.AllTests: testPushL :: IO ()
- Data.Tree.AVL.Test.AllTests: testPushR :: IO ()
- Data.Tree.AVL.Test.AllTests: testReadPath :: IO ()
- Data.Tree.AVL.Test.AllTests: testRotateByL :: IO ()
- Data.Tree.AVL.Test.AllTests: testRotateByR :: IO ()
- Data.Tree.AVL.Test.AllTests: testRotateL :: IO ()
- Data.Tree.AVL.Test.AllTests: testRotateR :: IO ()
- Data.Tree.AVL.Test.AllTests: testShowReadEq :: IO ()
- Data.Tree.AVL.Test.AllTests: testSize :: IO ()
- Data.Tree.AVL.Test.AllTests: testSpanL :: IO ()
- Data.Tree.AVL.Test.AllTests: testSpanR :: IO ()
- Data.Tree.AVL.Test.AllTests: testSplitAtL :: IO ()
- Data.Tree.AVL.Test.AllTests: testSplitAtR :: IO ()
- Data.Tree.AVL.Test.AllTests: testSymDifference :: IO ()
- Data.Tree.AVL.Test.AllTests: testTakeGE :: IO ()
- Data.Tree.AVL.Test.AllTests: testTakeGT :: IO ()
- Data.Tree.AVL.Test.AllTests: testTakeL :: IO ()
- Data.Tree.AVL.Test.AllTests: testTakeLE :: IO ()
- Data.Tree.AVL.Test.AllTests: testTakeLT :: IO ()
- Data.Tree.AVL.Test.AllTests: testTakeR :: IO ()
- Data.Tree.AVL.Test.AllTests: testTakeWhileL :: IO ()
- Data.Tree.AVL.Test.AllTests: testTakeWhileR :: IO ()
- Data.Tree.AVL.Test.AllTests: testTryOpenGE :: IO ()
- Data.Tree.AVL.Test.AllTests: testTryOpenLE :: IO ()
- Data.Tree.AVL.Test.AllTests: testUnion :: IO ()
- Data.Tree.AVL.Test.AllTests: testUnionMaybe :: IO ()
- Data.Tree.AVL.Test.AllTests: testVenn :: IO ()
- Data.Tree.AVL.Test.AllTests: testVennMaybe :: IO ()
- Data.Tree.AVL.Test.AllTests: testWrite :: IO ()
- Data.Tree.AVL.Test.AllTests: testZipSize :: IO ()
- Data.Tree.AVL.Test.Counter: XInt :: Int -> XInt
- Data.Tree.AVL.Test.Counter: getCount :: IO Int
- Data.Tree.AVL.Test.Counter: instance Eq XInt
- Data.Tree.AVL.Test.Counter: instance Ord XInt
- Data.Tree.AVL.Test.Counter: instance Read XInt
- Data.Tree.AVL.Test.Counter: instance Show XInt
- Data.Tree.AVL.Test.Counter: newtype XInt
- Data.Tree.AVL.Test.Counter: resetCount :: IO ()
+ Data.Tree.AVL: instance Data.Traversable.Traversable Data.Tree.AVL.Internals.Types.AVL
+ Data.Tree.AVL: instance GHC.Base.Functor Data.Tree.AVL.Internals.Types.AVL
Files
- AvlTree.cabal +80/−67
- CHANGELOG +0/−47
- CHANGELOG.md +51/−0
- Data/Tree/AVL.hs +0/−109
- Data/Tree/AVL/BinPath.hs +0/−392
- Data/Tree/AVL/Delete.hs +0/−533
- Data/Tree/AVL/Deprecated.hs +0/−683
- Data/Tree/AVL/Height.hs +0/−99
- Data/Tree/AVL/Internals/DelUtils.hs +0/−790
- Data/Tree/AVL/Internals/HAVL.hs +0/−98
- Data/Tree/AVL/Internals/HJoin.hs +0/−329
- Data/Tree/AVL/Internals/HPush.hs +0/−189
- Data/Tree/AVL/Internals/HSet.hs +0/−994
- Data/Tree/AVL/Join.hs +0/−121
- Data/Tree/AVL/List.hs +0/−852
- Data/Tree/AVL/Push.hs +0/−715
- Data/Tree/AVL/Read.hs +0/−168
- Data/Tree/AVL/Set.hs +0/−618
- Data/Tree/AVL/Size.hs +0/−193
- Data/Tree/AVL/Split.hs +0/−837
- Data/Tree/AVL/Test/AllTests.hs +0/−1517
- Data/Tree/AVL/Test/Counter.hs +0/−49
- Data/Tree/AVL/Test/Utils.hs +0/−221
- Data/Tree/AVL/Types.hs +0/−162
- Data/Tree/AVL/Write.hs +0/−197
- Data/Tree/AVL/Zipper.hs +0/−903
- Data/Tree/AVLX.hs +0/−63
- Setup.hs +0/−3
- Test/Test.hs +0/−6
- include/h98defs.h +0/−26
- src/Data/Tree/AVL.hs +358/−0
- src/Data/Tree/AVL/BinPath.hs +353/−0
- src/Data/Tree/AVL/Delete.hs +514/−0
- src/Data/Tree/AVL/Height.hs +84/−0
- src/Data/Tree/AVL/Internals/DelUtils.hs +731/−0
- src/Data/Tree/AVL/Internals/HAVL.hs +87/−0
- src/Data/Tree/AVL/Internals/HJoin.hs +305/−0
- src/Data/Tree/AVL/Internals/HPush.hs +171/−0
- src/Data/Tree/AVL/Internals/HSet.hs +950/−0
- src/Data/Tree/AVL/Internals/Types.hs +89/−0
- src/Data/Tree/AVL/Join.hs +108/−0
- src/Data/Tree/AVL/List.hs +838/−0
- src/Data/Tree/AVL/Push.hs +692/−0
- src/Data/Tree/AVL/Read.hs +163/−0
- src/Data/Tree/AVL/Set.hs +596/−0
- src/Data/Tree/AVL/Size.hs +158/−0
- src/Data/Tree/AVL/Split.hs +790/−0
- src/Data/Tree/AVL/Test/Utils.hs +112/−0
- src/Data/Tree/AVL/Utils.hs +55/−0
- src/Data/Tree/AVL/Write.hs +192/−0
- src/Data/Tree/AVL/Zipper.hs +895/−0
- tests/AllTests.hs +1409/−0
- tests/Utils.hs +128/−0
AvlTree.cabal view
@@ -1,68 +1,81 @@-Name: AvlTree-Version: 4.2-Cabal-Version: >= 1.2-Build-Type: Simple-License: BSD3-License-File: LICENSE-Copyright: (c) Adrian Hey 2004-2008-Author: Adrian Hey-Maintainer: Adrian Hey http://homepages.nildram.co.uk/~ahey/em.png-Stability: Stable-Homepage:-Package-Url:-Synopsis: Balanced binary trees using the AVL algorithm.-Description: A comprehensive and efficient implementation of AVL trees. The raw AVL- API has been designed with efficiency and generality in mind, not elagance or- safety. It contains all the stuff you really don't want to write yourself if you- can avoid it. This library may be useful for rolling your own Sets, Maps, Sequences,- Queues (for example).-Category: Data Structures-Tested-With: GHC == 6.8.3, GHC == 6.8.2, GHC == 6.8.1-Data-Files:-Extra-Source-Files: AUTHORS, CHANGELOG, MasterTable.txt, Test/Test.hs, include/ghcdefs.h, include/h98defs.h-Extra-Tmp-Files:+cabal-version: 2.2+name: AvlTree+version: 4.3+license: BSD-3-Clause+license-file: LICENSE+copyright: (c) Adrian Hey 2004-2008+maintainer: Bodigrim+author: Adrian Hey+tested-with:+ ghc ==8.4.4 ghc ==8.6.5 ghc ==8.8.4 ghc ==8.10.1 ghc ==9.0.2+ ghc ==9.2.8 ghc ==9.4.8 ghc ==9.6.7 ghc ==9.8.4 ghc ==9.10.3+ ghc ==9.12.2 ghc ==9.14.1 -Library- Buildable: True- Build-Depends: base, COrdering >= 2.3- Exposed-Modules: Data.Tree.AVL,- Data.Tree.AVL.Test.AllTests,- Data.Tree.AVL.Test.Counter- Other-Modules: Data.Tree.AVLX,- Data.Tree.AVL.Delete,- Data.Tree.AVL.Join,- Data.Tree.AVL.List,- Data.Tree.AVL.Push,- Data.Tree.AVL.Read,- Data.Tree.AVL.Set,- Data.Tree.AVL.Size,- Data.Tree.AVL.Height,- Data.Tree.AVL.Split,- Data.Tree.AVL.Types,- Data.Tree.AVL.Write,- Data.Tree.AVL.Zipper,- Data.Tree.AVL.BinPath,- Data.Tree.AVL.Deprecated,- Data.Tree.AVL.Test.Utils,- Data.Tree.AVL.Internals.DelUtils,- Data.Tree.AVL.Internals.HAVL,- Data.Tree.AVL.Internals.HJoin,- Data.Tree.AVL.Internals.HPush,- Data.Tree.AVL.Internals.HSet- Extensions: CPP- Hs-Source-Dirs: .- Build-Tools:- Ghc-Options: -Wall- Ghc-Prof-Options:- Ghc-Shared-Options:- Hugs-Options:- Nhc98-Options:- Includes:- Install-Includes:- Include-Dirs: include- C-Sources:- Extra-Libraries:- Extra-Lib-Dirs:- CC-Options:- LD-Options:- Pkgconfig-Depends:+synopsis: Balanced binary trees using the AVL algorithm.+description:+ A comprehensive and efficient implementation of AVL trees. The raw AVL+ API has been designed with efficiency and generality in mind, not elagance or+ safety. It contains all the stuff you really don't want to write yourself if you+ can avoid it. This library may be useful for rolling your own Sets, Maps, Sequences,+ Queues (for example).++category: Data+build-type: Simple+extra-source-files: include/ghcdefs.h+extra-doc-files:+ AUTHORS+ CHANGELOG.md+ MasterTable.txt++source-repository head+ type: git+ location: https://github.com/Bodigrim/AvlTree.git++library+ exposed-modules:+ Data.Tree.AVL+ Data.Tree.AVL.Internals.Types++ hs-source-dirs: src+ other-modules:+ Data.Tree.AVL.Write+ Data.Tree.AVL.Zipper+ Data.Tree.AVL.Delete+ Data.Tree.AVL.Join+ Data.Tree.AVL.List+ Data.Tree.AVL.Push+ Data.Tree.AVL.Internals.HAVL+ Data.Tree.AVL.Read+ Data.Tree.AVL.Set+ Data.Tree.AVL.Size+ Data.Tree.AVL.Height+ Data.Tree.AVL.Split+ Data.Tree.AVL.Utils+ Data.Tree.AVL.BinPath+ Data.Tree.AVL.Internals.DelUtils+ Data.Tree.AVL.Internals.HJoin+ Data.Tree.AVL.Internals.HPush+ Data.Tree.AVL.Internals.HSet+ Data.Tree.AVL.Test.Utils++ default-language: Haskell2010+ default-extensions: CPP MagicHash UnboxedTuples+ include-dirs: include+ ghc-options: -Wall+ build-depends:+ base >=4.11 && <5,+ COrdering >=2.3 && <2.4++test-suite AvlTree-tests+ type: exitcode-stdio-1.0+ main-is: AllTests.hs+ hs-source-dirs: tests+ other-modules: Utils+ default-language: Haskell2010+ default-extensions: CPP MagicHash UnboxedTuples+ include-dirs: include+ ghc-options: -Wall+ build-depends:+ base >=4.11 && <5,+ COrdering >=2.3 && <2.4,+ AvlTree
− CHANGELOG
@@ -1,47 +0,0 @@-2.4 ---- -* Initial Hackage/Cabal release. - Version set to 2.4 to distinguish from the 2.3 (non-cabal) release on my home page. - -3.0 ---- -* Included MasterTable.txt in the distro. -* Eq and Ord Instances now based on strict structural equality (derived) -* Exposed height related functions - -3.1 ---- -* Exposed BinPath primitives. -* Removed AVL tree based sorts. -* Removed Data.Map/Set conversions. This eliminates the containers package dependency. -* Removed link to Haskell wiki homepage as this will never be done. -* Removed link to maintainer email. - -3.2 ---- -No code changes, just reclaiming ownership and bumping version No. - -4.0 ---- -* Changed to derived Read/Show instances (instead of via lists). - Hence the instances are incompatible with earlier versions. -* Added: - genDisjointUnion,testGenDisjointUnion - genVenn,testGenVenn - genVennMaybe,testGenVennMaybe - genVennToList, - genVennAsList - genVennMaybeToList - genVennMaybeAsList -* Added UBT6 cpp macro to ghcdefs/h98defs - -4.1 ---- -* Added missing strictness to genVenn,genVennMaybe - -4.2 ---- -* A lot of function renaming (old names still available but deprecated). -* Gather all deprecations in 1 new module: Data.Tree.AVL.Deprecated -* Added findEmptyPath,nub,nubBy -
+ CHANGELOG.md view
@@ -0,0 +1,51 @@+# 4.3 + +* Remove previously deprecated functions. +* Class `Typeable1` is no longer a thing. + +# 4.2 + +* A lot of function renaming (old names still available but deprecated). +* Gather all deprecations in 1 new module: `Data.Tree.AVL.Deprecated`. +* Added `findEmptyPath`, `nub`, `nubBy`. + +# 4.1 + +* Added missing strictness to `genVenn`, `genVennMaybe`. + +# 4.0 + +* Changed to derived `Read` / `Show` instances (instead of via lists). + Hence the instances are incompatible with earlier versions. +* Added: + * `genDisjointUnion`,`testGenDisjointUnion`, + * `genVenn`,`testGenVenn`, + * `genVennMaybe`,`testGenVennMaybe`, + * `genVennToList`, + * `genVennAsList`, + * `genVennMaybeToList`, + * `genVennMaybeAsList`. +* Added `UBT6` cpp macro to `ghcdefs.h` / `h98defs.h`. + +# 3.2 + +* No code changes, just reclaiming ownership and bumping version No. + +# 3.1 + +* Exposed `BinPath` primitives. +* Removed AVL tree based sorts. +* Removed `Data.Map` / `Data.Set` conversions. This eliminates the `containers` package dependency. +* Removed link to Haskell wiki homepage as this will never be done. +* Removed link to maintainer email. + +# 3.0 + +* Included `MasterTable.txt` in the distro. +* `Eq` and `Ord` Instances now based on strict structural equality (derived). +* Exposed height-related functions. + +# 2.4 + +* Initial Hackage/Cabal release. + Version set to 2.4 to distinguish from the 2.3 (non-cabal) release on my home page.
− Data/Tree/AVL.hs
@@ -1,109 +0,0 @@-{-# OPTIONS_GHC -fno-warn-orphans #-}--------------------------------------------------------------------------------- |--- Module : Data.Tree.AVL--- Copyright : (c) Adrian Hey 2004,2008--- License : BSD3------ Maintainer : http://homepages.nildram.co.uk/~ahey/em.png--- Stability : stable--- Portability : portable------ Many of the functions defined by this package make use of generalised comparison functions--- which return a variant of the Prelude 'Prelude.Ordering' data type: 'Data.COrdering.COrdering'. These--- are refered to as \"combining comparisons\". (This is because they combine \"equal\"--- values in some manner defined by the user.)------ The idea is that using this simple mechanism you can define many practical and--- useful variations of tree (or general set) operations from a few generic primitives,--- something that would not be so easy using plain 'Prelude.Ordering' comparisons--- (overloaded or otherwise).------ Functions which involve searching a tree really only require a single argument--- function which takes the current tree element value as argument and returns--- an 'Prelude.Ordering' or 'Data.COrdering.COrdering' to direct the next stage of the search down--- the left or right sub-trees (or stop at the current element). For documentation--- purposes, these functions are called \"selectors\" throughout this library.--- Typically a selector will be obtained by partially applying the appropriate--- combining comparison with the value or key being searched for. For example..------ @--- mySelector :: Int -> Ordering Tree elements are Ints--- or..--- mySelector :: (key,val) -> COrdering val Tree elements are (key,val) pairs--- @----------------------------------------------------------------------------------module Data.Tree.AVL-(module Data.Tree.AVL.Types,- module Data.Tree.AVL.Read,- module Data.Tree.AVL.Write,- module Data.Tree.AVL.Push,- module Data.Tree.AVL.Delete,- module Data.Tree.AVL.Set,- module Data.Tree.AVL.Zipper,- module Data.Tree.AVL.Join,- module Data.Tree.AVL.List,- module Data.Tree.AVL.Split,- module Data.Tree.AVL.Size,- module Data.Tree.AVL.Height,-- -- * Low level Binary Path utilities.- -- | This is the low level (unsafe) API used by the 'BAVL' type.- BinPath(..),findFullPath,findEmptyPath,openPath,openPathWith,readPath,writePath,insertPath,deletePath,-- -- * Correctness checking.- isBalanced,isSorted,isSortedOK,-- -- * Tree parameter utilities.- minElements,maxElements,-- module Data.Tree.AVL.Deprecated,-) where--import Prelude hiding (map) -- so haddock finds the symbols there--import Data.Tree.AVL.Types hiding (E,N,P,Z)-import Data.Tree.AVL.Size-import Data.Tree.AVL.Height-import Data.Tree.AVL.Read-import Data.Tree.AVL.Write-import Data.Tree.AVL.Push-import Data.Tree.AVL.Delete-import Data.Tree.AVL.List-import Data.Tree.AVL.Join-import Data.Tree.AVL.Split-import Data.Tree.AVL.Set-import Data.Tree.AVL.Zipper-import Data.Tree.AVL.Test.Utils(isBalanced,isSorted,isSortedOK,minElements,maxElements)-import Data.Tree.AVL.BinPath(BinPath(..),findFullPath,findEmptyPath,openPath,openPathWith,readPath,writePath,insertPath)-import Data.Tree.AVL.Internals.DelUtils(deletePath)-import Data.Tree.AVL.Deprecated-#if __GLASGOW_HASKELL__ > 604-import Data.Traversable-#endif---{- These are now derived since switch to structural equality!--- | Show is based on showing the list produced by 'asListL'. This definition has been placed here--- to avoid introducing cyclic dependency between Types.hs and List.hs-instance Show e => Show (AVL e) where- -- showsPrec :: Int -> AVL e -> Shows -- type Shows = String -> String- showsPrec _ t = ("AVL " ++) . showList (asListL t)--instance Read e => Read (AVL e) where- -- readsPrec :: Int -> ReadS a -- type ReadS a = String -> [(a,String)]- readsPrec _ str = case lex str of- [("AVL",str')] -> [(asTreeL es, str'') | (es,str'') <- readList str']- _ -> []--}---- | AVL trees are an instance of 'Functor'. This definition has been placed here--- to avoid introducing cyclic dependency between Types.hs and List.hs-instance Functor AVL where- fmap = map -- The lazy version.--#if __GLASGOW_HASKELL__ > 604-instance Traversable AVL where- traverse = traverseAVL-#endif
− Data/Tree/AVL/BinPath.hs
@@ -1,392 +0,0 @@-{-# OPTIONS_GHC -fglasgow-exts #-}--------------------------------------------------------------------------------- |--- Module : Data.Tree.AVL.Internals.BinPath--- Copyright : (c) Adrian Hey 2005--- License : BSD3------ Maintainer : http://homepages.nildram.co.uk/~ahey/em.png--- Stability : stable--- Portability : portable------ This module provides a cheap but extremely limited and dangerous alternative--- to using the Zipper. A BinPath provides a way of finding a particular element--- in an AVL tree again without doing any comparisons. But a BinPath is ONLY VALID--- IF THE TREE SHAPE DOES NOT CHANGE.------ See the BAVL type in Data.Tree.AVL.Zipper module for a safer wrapper round these--- functions.-------------------------------------------------------------------------------module Data.Tree.AVL.BinPath- (BinPath(..),findFullPath,findEmptyPath,openPath,openPathWith,readPath,writePath,insertPath,- -- These are used by deletePath, which currently resides in Data.Tree.AVL.Internals.DelUtils- sel,goL,goR,- ) where--- N.B. The deletePath function should really be here too, but has been put--- in Data.Tree.AVL.Internals.DelUtils instead because deletion is a tangled web of circular--- depencency.--import Data.Tree.AVL.Types(AVL(..))-import Data.COrdering--#if __GLASGOW_HASKELL__-import GHC.Base-#include "ghcdefs.h"---- Test path LSB-bit0 :: Int# -> Bool-{-# INLINE bit0 #-}-bit0 p = word2Int# (and# (int2Word# p) (int2Word# 1#)) ==# 1#---- A pseudo comparison..--- N.B. If the path was bit reversed, this could be a straight comparison.??-sel :: Int# -> Ordering-{-# INLINE sel #-}-sel p = if p ==# 0# then EQ- else if bit0 p then LT -- Left if Bit 0 == 1- else GT -- Right if Bit 0 == 0----- Modify path for entering left subtree-goL :: Int# -> Int#-{-# INLINE goL #-}-goL p = iShiftRL# p 1#---- Modify path for entering right subtree-goR :: Int# -> Int#-{-# INLINE goR #-}-goR p = iShiftRL# (p -# 1#) 1#--#else-#include "h98defs.h"-import Data.Bits((.&.),shiftL)---- A pseudo comparison..--- N.B. If the path was bit reversed, this could be a straight comparison.??-sel :: Int -> Ordering-{-# INLINE sel #-}-sel p = if p == 0 then EQ- else if bit0 p then LT -- Left if Bit 0 == 1- else GT -- Right if Bit 0 == 0-bit0 :: Int -> Bool-{-# INLINE bit0 #-}-bit0 p = (p .&. 1) == 1---- Modify path for entering left subtree-goL :: Int -> Int-{-# INLINE goL #-}-goL p = shiftL p 1---- Modify path for entering right subtree-goR :: Int -> Int-{-# INLINE goR #-}-goR p = shiftL (p-1) 1-#endif---- | A BinPath is full if the search succeeded, empty otherwise.-data BinPath a = FullBP {-# UNPACK #-} !UINT a -- Found- | EmptyBP {-# UNPACK #-} !UINT -- Not Found--{-------------------------------------------------------------------------------------------- Notes:----------------------------------------------------------------------------------------------The Binary paths are based on an indexing scheme that:- 1- Uniquely identifies each tree node- 2- Provides a simple algorithm for path generation.- 3- Provides a simple algorithm to locate a node in the tree, given it's path.--Imagine an infinite Binary Tree, with nodes indexed as follows:-- _____00_____ <- d=1- / \- _01_ _02_ <- d=2- / \ / \- 03 05 04 06 <- d=4- / \ / \ / \ / \- 07 11 09 13 08 12 10 14 <- d=8- <-------- More Layers ------->--To generate the node index (path) as we move down the tree we..- 1- Initialise index (i) to 0, and a parameter (d) to 1- 2- If we've arrived where we want, output i.- 3- Either Move left: i <- i+d, d <- 2d, goto 2- or Move right: i <- i+2d, d <- 2d, goto 2--To find a node, given its index (path) i, we..- 1- If i=0 then stop, we've arrived.- 2- If i is odd then move left , i <- (i-1)>>1, goto 1 -- (i-1)>>1 = i>>1 if i is odd- else move right, i <- (i-1)>>1, goto 1 -- (i-1)>>1 = (i>>1)-1 if i is even-Examples:- i=05: (left ,i<-2):(right,i<-0):(stop)- i=12: (right,i<-5):(left ,i<-2):(right,i<-0):(stop)--See also: pathTree in Data.Tree.AVL.Test.Utils for recursive implementation of the indexing scheme.---------------------------------------------------------------------------------------------}---- | Find the path to a AVL tree element, returns -1 (invalid path) if element not found------ Complexity: O(log n)-findFullPath :: (e -> Ordering) -> AVL e -> UINT--- ?? What about strictness if UINT is boxed (i.e. non-ghc)?-findFullPath c t = find L(1) L(0) t where- find _ _ E = L(-1)- find d i (N l e r) = find' d i l e r- find d i (Z l e r) = find' d i l e r- find d i (P l e r) = find' d i l e r- find' d i l e r = case c e of- LT -> let d_ = ADDINT(d,d) in find d_ ADDINT(i,d ) l- EQ -> i- GT -> let d_ = ADDINT(d,d) in find d_ ADDINT(i,d_) r -- d_ = 2d---- | Find the path to a non-existant AVL tree element, returns -1 (invalid path) if element is found------ Complexity: O(log n)-findEmptyPath :: (e -> Ordering) -> AVL e -> UINT--- ?? What about strictness if UINT is boxed (i.e. non-ghc)?-findEmptyPath c t = find L(1) L(0) t where- find _ i E = i- find d i (N l e r) = find' d i l e r- find d i (Z l e r) = find' d i l e r- find d i (P l e r) = find' d i l e r- find' d i l e r = case c e of- LT -> let d_ = ADDINT(d,d) in find d_ ADDINT(i,d ) l- EQ -> L(-1)- GT -> let d_ = ADDINT(d,d) in find d_ ADDINT(i,d_) r -- d_ = 2d---- | Get the BinPath of an element using the supplied selector.------ Complexity: O(log n)-openPath :: (e -> Ordering) -> AVL e -> BinPath e-openPath c t = find L(1) L(0) t where- find _ i E = EmptyBP i- find d i (N l e r) = find' d i l e r- find d i (Z l e r) = find' d i l e r- find d i (P l e r) = find' d i l e r- find' d i l e r = case c e of- LT -> let d_ = ADDINT(d,d) in find d_ ADDINT(i,d ) l- EQ -> FullBP i e- GT -> let d_ = ADDINT(d,d) in find d_ ADDINT(i,d_) r -- d_ = 2d---- | Get the BinPath of an element using the supplied (combining) selector.------ Complexity: O(log n)-openPathWith :: (e -> COrdering a) -> AVL e -> BinPath a-openPathWith c t = find L(1) L(0) t where- find _ i E = EmptyBP i- find d i (N l e r) = find' d i l e r- find d i (Z l e r) = find' d i l e r- find d i (P l e r) = find' d i l e r- find' d i l e r = case c e of- Lt -> let d_ = ADDINT(d,d) in find d_ ADDINT(i,d ) l- Eq a -> FullBP i a- Gt -> let d_ = ADDINT(d,d) in find d_ ADDINT(i,d_) r -- d_ = 2d---- | Overwrite a tree element. Assumes the path bits were extracted from 'FullBP' constructor.--- Raises an error if the path leads to an empty tree.------ N.B This operation does not change tree shape (no insertion occurs).------ Complexity: O(log n)-writePath :: UINT -> e -> AVL e -> AVL e-writePath i0 e' t = wp i0 t where- wp L(0) E = error "writePath: Bug0" -- Needed to force strictness in path- wp L(0) (N l _ r) = N l e' r- wp L(0) (Z l _ r) = Z l e' r- wp L(0) (P l _ r) = P l e' r- wp _ E = error "writePath: Bug1"- wp i (N l e r) = if bit0 i then let l' = wp (goL i) l in l' `seq` N l' e r- else let r' = wp (goR i) r in r' `seq` N l e r'- wp i (Z l e r) = if bit0 i then let l' = wp (goL i) l in l' `seq` Z l' e r- else let r' = wp (goR i) r in r' `seq` Z l e r'- wp i (P l e r) = if bit0 i then let l' = wp (goL i) l in l' `seq` P l' e r- else let r' = wp (goR i) r in r' `seq` P l e r'---- | Read a tree element. Assumes the path bits were extracted from 'FullBP' constructor.--- Raises an error if the path leads to an empty tree.------ Complexity: O(log n)-readPath :: UINT -> AVL e -> e-readPath L(0) E = error "readPath: Bug0" -- Needed to force strictness in path-readPath L(0) (N _ e _) = e-readPath L(0) (Z _ e _) = e-readPath L(0) (P _ e _) = e-readPath _ E = error "readPath: Bug1"-readPath i (N l _ r) = readPath_ i l r-readPath i (Z l _ r) = readPath_ i l r-readPath i (P l _ r) = readPath_ i l r-readPath_ :: UINT -> AVL e -> AVL e -> e-readPath_ i l r = if bit0 i then readPath (goL i) l- else readPath (goR i) r---- | Inserts a new tree element. Assumes the path bits were extracted from a 'EmptyBP' constructor.--- This function replaces the first Empty node it encounters with the supplied value, regardless--- of the current path bits (which are not checked). DO NOT USE THIS FOR REPLACING ELEMENTS ALREADY--- PRESENT IN THE TREE (use 'writePath' for this).------ Complexity: O(log n)-insertPath :: UINT -> e -> AVL e -> AVL e-insertPath i0 e0 t = put i0 t where- ----------------------------- LEVEL 0 ---------------------------------- -- put --- ------------------------------------------------------------------------ put _ E = Z E e0 E- put i (N l e r) = putN i l e r- put i (Z l e r) = putZ i l e r- put i (P l e r) = putP i l e r-- ----------------------------- LEVEL 1 ---------------------------------- -- putN, putZ, putP --- ------------------------------------------------------------------------ -- Put in (N l e r), BF=-1 , (never returns P)- putN i l e r = if bit0 i then putNL i l e r -- put in L subtree- else putNR i l e r -- put in R subtree-- -- Put in (Z l e r), BF= 0- putZ i l e r = if bit0 i then putZL i l e r -- put in L subtree- else putZR i l e r -- put in R subtree-- -- Put in (P l e r), BF=+1 , (never returns N)- putP i l e r = if bit0 i then putPL i l e r -- put in L subtree- else putPR i l e r -- put in R subtree-- ----------------------------- LEVEL 2 ---------------------------------- -- putNL, putZL, putPL --- -- putNR, putZR, putPR --- ------------------------------------------------------------------------- -- (putNL l e r): Put in L subtree of (N l e r), BF=-1 (Never requires rebalancing) , (never returns P)- {-# INLINE putNL #-}- putNL _ E e r = Z (Z E e0 E) e r -- L subtree empty, H:0->1, parent BF:-1-> 0- putNL i (N ll le lr) e r = let l' = putN (goL i) ll le lr -- L subtree BF<>0, H:h->h, parent BF:-1->-1- in l' `seq` N l' e r- putNL i (P ll le lr) e r = let l' = putP (goL i) ll le lr -- L subtree BF<>0, H:h->h, parent BF:-1->-1- in l' `seq` N l' e r- putNL i (Z ll le lr) e r = let l' = putZ (goL i) ll le lr -- L subtree BF= 0, so need to look for changes- in case l' of- E -> error "insertPath: Bug0" -- impossible- Z _ _ _ -> N l' e r -- L subtree BF:0-> 0, H:h->h , parent BF:-1->-1- _ -> Z l' e r -- L subtree BF:0->+/-1, H:h->h+1, parent BF:-1-> 0-- -- (putZL l e r): Put in L subtree of (Z l e r), BF= 0 (Never requires rebalancing) , (never returns N)- {-# INLINE putZL #-}- putZL _ E e r = P (Z E e0 E) e r -- L subtree H:0->1, parent BF: 0->+1- putZL i (N ll le lr) e r = let l' = putN (goL i) ll le lr -- L subtree BF<>0, H:h->h, parent BF: 0-> 0- in l' `seq` Z l' e r- putZL i (P ll le lr) e r = let l' = putP (goL i) ll le lr -- L subtree BF<>0, H:h->h, parent BF: 0-> 0- in l' `seq` Z l' e r- putZL i (Z ll le lr) e r = let l' = putZ (goL i) ll le lr -- L subtree BF= 0, so need to look for changes- in case l' of- E -> error "insertPath: Bug1" -- impossible- Z _ _ _ -> Z l' e r -- L subtree BF: 0-> 0, H:h->h , parent BF: 0-> 0- _ -> P l' e r -- L subtree BF: 0->+/-1, H:h->h+1, parent BF: 0->+1-- -- (putZR l e r): Put in R subtree of (Z l e r), BF= 0 (Never requires rebalancing) , (never returns P)- {-# INLINE putZR #-}- putZR _ l e E = N l e (Z E e0 E) -- R subtree H:0->1, parent BF: 0->-1- putZR i l e (N rl re rr) = let r' = putN (goR i) rl re rr -- R subtree BF<>0, H:h->h, parent BF: 0-> 0- in r' `seq` Z l e r'- putZR i l e (P rl re rr) = let r' = putP (goR i) rl re rr -- R subtree BF<>0, H:h->h, parent BF: 0-> 0- in r' `seq` Z l e r'- putZR i l e (Z rl re rr) = let r' = putZ (goR i) rl re rr -- R subtree BF= 0, so need to look for changes- in case r' of- E -> error "insertPath: Bug2" -- impossible- Z _ _ _ -> Z l e r' -- R subtree BF: 0-> 0, H:h->h , parent BF: 0-> 0- _ -> N l e r' -- R subtree BF: 0->+/-1, H:h->h+1, parent BF: 0->-1-- -- (putPR l e r): Put in R subtree of (P l e r), BF=+1 (Never requires rebalancing) , (never returns N)- {-# INLINE putPR #-}- putPR _ l e E = Z l e (Z E e0 E) -- R subtree empty, H:0->1, parent BF:+1-> 0- putPR i l e (N rl re rr) = let r' = putN (goR i) rl re rr -- R subtree BF<>0, H:h->h, parent BF:+1->+1- in r' `seq` P l e r'- putPR i l e (P rl re rr) = let r' = putP (goR i) rl re rr -- R subtree BF<>0, H:h->h, parent BF:+1->+1- in r' `seq` P l e r'- putPR i l e (Z rl re rr) = let r' = putZ (goR i) rl re rr -- R subtree BF= 0, so need to look for changes- in case r' of- E -> error "insertPath: Bug3" -- impossible- Z _ _ _ -> P l e r' -- R subtree BF:0-> 0, H:h->h , parent BF:+1->+1- _ -> Z l e r' -- R subtree BF:0->+/-1, H:h->h+1, parent BF:+1-> 0-- -------- These 2 cases (NR and PL) may need rebalancing if they go to LEVEL 3 ----------- -- (putNR l e r): Put in R subtree of (N l e r), BF=-1 , (never returns P)- {-# INLINE putNR #-}- putNR _ _ _ E = error "insertPath: Bug4" -- impossible if BF=-1- putNR i l e (N rl re rr) = let r' = putN (goR i) rl re rr -- R subtree BF<>0, H:h->h, parent BF:-1->-1- in r' `seq` N l e r'- putNR i l e (P rl re rr) = let r' = putP (goR i) rl re rr -- R subtree BF<>0, H:h->h, parent BF:-1->-1- in r' `seq` N l e r'- putNR i l e (Z rl re rr) = let i' = goR i in if bit0 i' then putNRL i' l e rl re rr -- RL (never returns P)- else putNRR i' l e rl re rr -- RR (never returns P)-- -- (putPL l e r): Put in L subtree of (P l e r), BF=+1 , (never returns N)- {-# INLINE putPL #-}- putPL _ E _ _ = error "insertPath: Bug5" -- impossible if BF=+1- putPL i (N ll le lr) e r = let l' = putN (goL i) ll le lr -- L subtree BF<>0, H:h->h, parent BF:+1->+1- in l' `seq` P l' e r- putPL i (P ll le lr) e r = let l' = putP (goL i) ll le lr -- L subtree BF<>0, H:h->h, parent BF:+1->+1- in l' `seq` P l' e r- putPL i (Z ll le lr) e r = let i' = goL i in if bit0 i' then putPLL i' ll le lr e r -- LL (never returns N)- else putPLR i' ll le lr e r -- LR (never returns N)-- ----------------------------- LEVEL 3 ---------------------------------- -- putNRR, putPLL --- -- putNRL, putPLR --- ------------------------------------------------------------------------- -- (putNRR l e rl re rr): Put in RR subtree of (N l e (Z rl re rr)) , (never returns P)- {-# INLINE putNRR #-}- putNRR _ l e rl re E = Z (Z l e rl) re (Z E e0 E) -- l and rl must also be E, special CASE RR!!- putNRR i l e rl re (N rrl rre rrr) = let rr' = putN (goR i) rrl rre rrr -- RR subtree BF<>0, H:h->h, so no change- in rr' `seq` N l e (Z rl re rr')- putNRR i l e rl re (P rrl rre rrr) = let rr' = putP (goR i) rrl rre rrr -- RR subtree BF<>0, H:h->h, so no change- in rr' `seq` N l e (Z rl re rr')- putNRR i l e rl re (Z rrl rre rrr) = let rr' = putZ (goR i) rrl rre rrr -- RR subtree BF= 0, so need to look for changes- in case rr' of- E -> error "insertPath: Bug6" -- impossible- Z _ _ _ -> N l e (Z rl re rr') -- RR subtree BF: 0-> 0, H:h->h, so no change- _ -> Z (Z l e rl) re rr' -- RR subtree BF: 0->+/-1, H:h->h+1, parent BF:-1->-2, CASE RR !!-- -- (putPLL ll le lr e r): Put in LL subtree of (P (Z ll le lr) e r) , (never returns N)- {-# INLINE putPLL #-}- putPLL _ E le lr e r = Z (Z E e0 E) le (Z lr e r) -- r and lr must also be E, special CASE LL!!- putPLL i (N lll lle llr) le lr e r = let ll' = putN (goL i) lll lle llr -- LL subtree BF<>0, H:h->h, so no change- in ll' `seq` P (Z ll' le lr) e r- putPLL i (P lll lle llr) le lr e r = let ll' = putP (goL i) lll lle llr -- LL subtree BF<>0, H:h->h, so no change- in ll' `seq` P (Z ll' le lr) e r- putPLL i (Z lll lle llr) le lr e r = let ll' = putZ (goL i) lll lle llr -- LL subtree BF= 0, so need to look for changes- in case ll' of- E -> error "insertPath: Bug7" -- impossible- Z _ _ _ -> P (Z ll' le lr) e r -- LL subtree BF: 0-> 0, H:h->h, so no change- _ -> Z ll' le (Z lr e r) -- LL subtree BF: 0->+/-1, H:h->h+1, parent BF:-1->-2, CASE LL !!-- -- (putNRL l e rl re rr): Put in RL subtree of (N l e (Z rl re rr)) , (never returns P)- {-# INLINE putNRL #-}- putNRL _ l e E re rr = Z (Z l e E) e0 (Z E re rr) -- l and rr must also be E, special CASE LR !!- putNRL i l e (N rll rle rlr) re rr = let rl' = putN (goL i) rll rle rlr -- RL subtree BF<>0, H:h->h, so no change- in rl' `seq` N l e (Z rl' re rr)- putNRL i l e (P rll rle rlr) re rr = let rl' = putP (goL i) rll rle rlr -- RL subtree BF<>0, H:h->h, so no change- in rl' `seq` N l e (Z rl' re rr)- putNRL i l e (Z rll rle rlr) re rr = let rl' = putZ (goL i) rll rle rlr -- RL subtree BF= 0, so need to look for changes- in case rl' of- E -> error "insertPath: Bug8" -- impossible- Z _ _ _ -> N l e (Z rl' re rr) -- RL subtree BF: 0-> 0, H:h->h, so no change- N rll' rle' rlr' -> Z (P l e rll') rle' (Z rlr' re rr) -- RL subtree BF: 0->-1, SO.. CASE RL(1) !!- P rll' rle' rlr' -> Z (Z l e rll') rle' (N rlr' re rr) -- RL subtree BF: 0->+1, SO.. CASE RL(2) !!-- -- (putPLR ll le lr e r): Put in LR subtree of (P (Z ll le lr) e r) , (never returns N)- {-# INLINE putPLR #-}- putPLR _ ll le E e r = Z (Z ll le E) e0 (Z E e r) -- r and ll must also be E, special CASE LR !!- putPLR i ll le (N lrl lre lrr) e r = let lr' = putN (goR i) lrl lre lrr -- LR subtree BF<>0, H:h->h, so no change- in lr' `seq` P (Z ll le lr') e r- putPLR i ll le (P lrl lre lrr) e r = let lr' = putP (goR i) lrl lre lrr -- LR subtree BF<>0, H:h->h, so no change- in lr' `seq` P (Z ll le lr') e r- putPLR i ll le (Z lrl lre lrr) e r = let lr' = putZ (goR i) lrl lre lrr -- LR subtree BF= 0, so need to look for changes- in case lr' of- E -> error "insertPath: Bug9" -- impossible- Z _ _ _ -> P (Z ll le lr') e r -- LR subtree BF: 0-> 0, H:h->h, so no change- N lrl' lre' lrr' -> Z (P ll le lrl') lre' (Z lrr' e r) -- LR subtree BF: 0->-1, SO.. CASE LR(2) !!- P lrl' lre' lrr' -> Z (Z ll le lrl') lre' (N lrr' e r) -- LR subtree BF: 0->+1, SO.. CASE LR(1) !!------------------------------------------------------------------------------------------------ insertPath Ends Here ---------------------------------------------------------------------------------------------------
− Data/Tree/AVL/Delete.hs
@@ -1,533 +0,0 @@-{-# OPTIONS_GHC -fglasgow-exts #-}--------------------------------------------------------------------------------- |--- Module : Data.Tree.AVL.Delete--- Copyright : (c) Adrian Hey 2004,2005--- License : BSD3------ Maintainer : http://homepages.nildram.co.uk/~ahey/em.png--- Stability : stable--- Portability : portable-------------------------------------------------------------------------------module Data.Tree.AVL.Delete-(-- * Deleting elements from AVL trees-- -- ** Deleting from extreme left or right- delL,delR,assertDelL,assertDelR,tryDelL,tryDelR,-- -- ** Deleting from /sorted/ trees- delete,deleteFast,deleteIf,deleteMaybe,-- -- * \"Popping\" elements from AVL trees- -- | \"Popping\" means reading and deleting a tree element in a single operation.-- -- ** Popping from extreme left or right- assertPopL,assertPopR,tryPopL,tryPopR,-- -- ** Popping from /sorted/ trees- assertPop,tryPop,assertPopMaybe,tryPopMaybe,assertPopIf,tryPopIf,-) where--import Prelude -- so haddock finds the symbols there--import Data.COrdering-import Data.Tree.AVL.Types(AVL(..))-import Data.Tree.AVL.BinPath(BinPath(..),findFullPath,openPathWith,writePath)--import Data.Tree.AVL.Internals.DelUtils- (-- Deleting Utilities- delRN,delRZ,delRP,delLN,delLZ,delLP,- -- Popping Utilities.- popRN,popRZ,popRP,popLN,popLZ,popLP,- -- Balancing Utilities- chkLN,chkLZ,chkLP,chkRN,chkRZ,chkRP,- chkLN',chkLZ',chkLP',chkRN',chkRZ',chkRP',- -- Node substitution utilities.- subN,subZR,subZL,subP,- -- BinPath related- deletePath- )--#ifdef __GLASGOW_HASKELL__-import GHC.Base-#include "ghcdefs.h"-#else-#include "h98defs.h"-#endif---- | Delete the left-most element of an AVL tree. If the tree is sorted this will be the--- least element. This function returns an empty tree if it's argument is an empty tree.------ Complexity: O(log n)-delL :: AVL e -> AVL e-delL E = E-delL (N l e r) = delLN l e r-delL (Z l e r) = delLZ l e r-delL (P l e r) = delLP l e r---- | Delete the left-most element of a /non-empty/ AVL tree. If the tree is sorted this will be the--- least element. This function raises an error if it's argument is an empty tree.------ Complexity: O(log n)-assertDelL :: AVL e -> AVL e-assertDelL E = error "assertDelL: Empty tree."-assertDelL (N l e r) = delLN l e r-assertDelL (Z l e r) = delLZ l e r-assertDelL (P l e r) = delLP l e r---- | Try to delete the left-most element of a /non-empty/ AVL tree. If the tree is sorted this will be the--- least element. This function returns 'Nothing' if it's argument is an empty tree.------ Complexity: O(log n)-tryDelL :: AVL e -> Maybe (AVL e)-tryDelL E = Nothing-tryDelL (N l e r) = Just $! delLN l e r-tryDelL (Z l e r) = Just $! delLZ l e r-tryDelL (P l e r) = Just $! delLP l e r---- | Delete the right-most element of an AVL tree. If the tree is sorted this will be the--- greatest element. This function returns an empty tree if it's argument is an empty tree.------ Complexity: O(log n)-delR :: AVL e -> AVL e-delR E = E-delR (N l e r) = delRN l e r-delR (Z l e r) = delRZ l e r-delR (P l e r) = delRP l e r---- | Delete the right-most element of a /non-empty/ AVL tree. If the tree is sorted this will be the--- greatest element. This function raises an error if it's argument is an empty tree.------ Complexity: O(log n)-assertDelR :: AVL e -> AVL e-assertDelR E = error "assertDelR: Empty tree."-assertDelR (N l e r) = delRN l e r-assertDelR (Z l e r) = delRZ l e r-assertDelR (P l e r) = delRP l e r---- | Try to delete the right-most element of a /non-empty/ AVL tree. If the tree is sorted this will be the--- greatest element. This function returns 'Nothing' if it's argument is an empty tree.------ Complexity: O(log n)-tryDelR :: AVL e -> Maybe (AVL e)-tryDelR E = Nothing-tryDelR (N l e r) = Just $! delRN l e r-tryDelR (Z l e r) = Just $! delRZ l e r-tryDelR (P l e r) = Just $! delRP l e r---- | Pop the left-most element from a non-empty AVL tree, returning the popped element and the--- modified AVL tree. If the tree is sorted this will be the least element.--- This function raises an error if it's argument is an empty tree.------ Complexity: O(log n)-assertPopL :: AVL e -> (e,AVL e)-assertPopL E = error "assertPopL: Empty tree."-assertPopL (N l e r) = case popLN l e r of UBT2(v,t) -> (v,t)-assertPopL (Z l e r) = case popLZ l e r of UBT2(v,t) -> (v,t)-assertPopL (P l e r) = case popLP l e r of UBT2(v,t) -> (v,t)---- | Same as 'assertPopL', except this version returns 'Nothing' if it's argument is an empty tree.------ Complexity: O(log n)-tryPopL :: AVL e -> Maybe (e,AVL e)-tryPopL E = Nothing-tryPopL (N l e r) = Just $! case popLN l e r of UBT2(v,t) -> (v,t)-tryPopL (Z l e r) = Just $! case popLZ l e r of UBT2(v,t) -> (v,t)-tryPopL (P l e r) = Just $! case popLP l e r of UBT2(v,t) -> (v,t)----- | Pop the right-most element from a non-empty AVL tree, returning the popped element and the--- modified AVL tree. If the tree is sorted this will be the greatest element.--- This function raises an error if it's argument is an empty tree.------ Complexity: O(log n)-assertPopR :: AVL e -> (AVL e,e)-assertPopR E = error "assertPopR: Empty tree."-assertPopR (N l e r) = case popRN l e r of UBT2(t,v) -> (t,v)-assertPopR (Z l e r) = case popRZ l e r of UBT2(t,v) -> (t,v)-assertPopR (P l e r) = case popRP l e r of UBT2(t,v) -> (t,v)---- | Same as 'assertPopR', except this version returns 'Nothing' if it's argument is an empty tree.------ Complexity: O(log n)-tryPopR :: AVL e -> Maybe (AVL e,e)-tryPopR E = Nothing-tryPopR (N l e r) = Just $! case popRN l e r of UBT2(t,v) -> (t,v)-tryPopR (Z l e r) = Just $! case popRZ l e r of UBT2(t,v) -> (t,v)-tryPopR (P l e r) = Just $! case popRP l e r of UBT2(t,v) -> (t,v)---- | General purpose function for deletion of elements from a sorted AVL tree.--- If a matching element is not found then this function returns the original tree.------ Complexity: O(log n)-delete :: (e -> Ordering) -> AVL e -> AVL e-delete c t = case findFullPath c t of- L(-1) -> t -- Not found, p<0- p -> deletePath p t -- Found, so delete---- | This version only deletes the element if the supplied selector returns @('Eq' 'True')@.--- If it returns @('Eq' 'False')@ or if no matching element is found then this function returns--- the original tree.------ Complexity: O(log n)-deleteIf :: (e -> COrdering Bool) -> AVL e -> AVL e-deleteIf c t = case openPathWith c t of- FullBP p True -> deletePath p t- _ -> t---- | This version only deletes the element if the supplied selector returns @('Eq' 'Nothing')@.--- If it returns @('Eq' ('Just' e))@ then the matching element is replaced by e.--- If no matching element is found then this function returns the original tree.------ Complexity: O(log n)-deleteMaybe :: (e -> COrdering (Maybe e)) -> AVL e -> AVL e-deleteMaybe c t = case openPathWith c t of- FullBP p Nothing -> deletePath p t- FullBP p (Just e) -> writePath p e t- _ -> t---- | Functionally identical to 'delete', but returns an identical tree (one with all the nodes on--- the path duplicated) if the search fails. This should probably only be used if you know the--- search will succeed.------ Complexity: O(log n)-deleteFast :: (e -> Ordering) -> AVL e -> AVL e--- This was the old delete so it's been tested OK, but as a different name.-deleteFast c = delete' where- delete' E = E- delete' (N l e r) = delN l e r- delete' (Z l e r) = delZ l e r- delete' (P l e r) = delP l e r-- ----------------------------- LEVEL 1 ---------------------------------- -- delN, delZ, delP --- ------------------------------------------------------------------------- -- Delete from (N l e r)- delN l e r = case c e of- LT -> delNL l e r- EQ -> subN l r- GT -> delNR l e r-- -- Delete from (Z l e r)- delZ l e r = case c e of- LT -> delZL l e r- EQ -> subZR l r- GT -> delZR l e r-- -- Delete from (P l e r)- delP l e r = case c e of- LT -> delPL l e r- EQ -> subP l r- GT -> delPR l e r-- ----------------------------- LEVEL 2 ---------------------------------- -- delNL, delZL, delPL --- -- delNR, delZR, delPR --- ------------------------------------------------------------------------- -- Delete from the left subtree of (N l e r)- delNL E e r = N E e r -- Left sub-tree is empty- delNL (N ll le lr) e r = case c le of- LT -> chkLN (delNL ll le lr) e r- EQ -> chkLN (subN ll lr) e r- GT -> chkLN (delNR ll le lr) e r- delNL (Z ll le lr) e r = case c le of- LT -> let l' = delZL ll le lr in l' `seq` N l' e r -- height can't change- EQ -> chkLN' (subZR ll lr) e r -- << But it can here- GT -> let l' = delZR ll le lr in l' `seq` N l' e r -- height can't change- delNL (P ll le lr) e r = case c le of- LT -> chkLN (delPL ll le lr) e r- EQ -> chkLN (subP ll lr) e r- GT -> chkLN (delPR ll le lr) e r-- -- Delete from the right subtree of (N l e r)- delNR _ _ E = error "delNR: Bug0" -- Impossible- delNR l e (N rl re rr) = case c re of- LT -> chkRN l e (delNL rl re rr)- EQ -> chkRN l e (subN rl rr)- GT -> chkRN l e (delNR rl re rr)- delNR l e (Z rl re rr) = case c re of- LT -> let r' = delZL rl re rr in r' `seq` N l e r' -- height can't change- EQ -> chkRN' l e (subZL rl rr) -- << But it can here- GT -> let r' = delZR rl re rr in r' `seq` N l e r' -- height can't change- delNR l e (P rl re rr) = case c re of- LT -> chkRN l e (delPL rl re rr)- EQ -> chkRN l e (subP rl rr)- GT -> chkRN l e (delPR rl re rr)-- -- Delete from the left subtree of (Z l e r)- delZL E e r = Z E e r -- Left sub-tree is empty- delZL (N ll le lr) e r = case c le of- LT -> chkLZ (delNL ll le lr) e r- EQ -> chkLZ (subN ll lr) e r- GT -> chkLZ (delNR ll le lr) e r- delZL (Z ll le lr) e r = case c le of- LT -> let l' = delZL ll le lr in l' `seq` Z l' e r -- height can't change- EQ -> chkLZ' (subZR ll lr) e r -- << But it can here- GT -> let l' = delZR ll le lr in l' `seq` Z l' e r -- height can't change- delZL (P ll le lr) e r = case c le of- LT -> chkLZ (delPL ll le lr) e r- EQ -> chkLZ (subP ll lr) e r- GT -> chkLZ (delPR ll le lr) e r-- -- Delete from the right subtree of (Z l e r)- delZR l e E = Z l e E -- Right sub-tree is empty- delZR l e (N rl re rr) = case c re of- LT -> chkRZ l e (delNL rl re rr)- EQ -> chkRZ l e (subN rl rr)- GT -> chkRZ l e (delNR rl re rr)- delZR l e (Z rl re rr) = case c re of- LT -> let r' = delZL rl re rr in r' `seq` Z l e r' -- height can't change- EQ -> chkRZ' l e (subZL rl rr) -- << But it can here- GT -> let r' = delZR rl re rr in r' `seq` Z l e r' -- height can't change- delZR l e (P rl re rr) = case c re of- LT -> chkRZ l e (delPL rl re rr)- EQ -> chkRZ l e (subP rl rr)- GT -> chkRZ l e (delPR rl re rr)-- -- Delete from the left subtree of (P l e r)- delPL E _ _ = error "delPL: Bug0" -- Impossible- delPL (N ll le lr) e r = case c le of- LT -> chkLP (delNL ll le lr) e r- EQ -> chkLP (subN ll lr) e r- GT -> chkLP (delNR ll le lr) e r- delPL (Z ll le lr) e r = case c le of- LT -> let l' = delZL ll le lr in l' `seq` P l' e r -- height can't change- EQ -> chkLP' (subZR ll lr) e r -- << But it can here- GT -> let l' = delZR ll le lr in l' `seq` P l' e r -- height can't change- delPL (P ll le lr) e r = case c le of- LT -> chkLP (delPL ll le lr) e r- EQ -> chkLP (subP ll lr) e r- GT -> chkLP (delPR ll le lr) e r-- -- Delete from the right subtree of (P l e r)- delPR l e E = P l e E -- Right sub-tree is empty- delPR l e (N rl re rr) = case c re of- LT -> chkRP l e (delNL rl re rr)- EQ -> chkRP l e (subN rl rr)- GT -> chkRP l e (delNR rl re rr)- delPR l e (Z rl re rr) = case c re of- LT -> let r' = delZL rl re rr in r' `seq` P l e r' -- height can't change- EQ -> chkRP' l e (subZL rl rr) -- << But it can here- GT -> let r' = delZR rl re rr in r' `seq` P l e r' -- height can't change- delPR l e (P rl re rr) = case c re of- LT -> chkRP l e (delPL rl re rr)- EQ -> chkRP l e (subP rl rr)- GT -> chkRP l e (delPR rl re rr)-------------------------------------------------------------------------------------------------- deleteFast Ends Here ---------------------------------------------------------------------------------------------------- | General purpose function for popping elements from a sorted AVL tree.--- An error is raised if a matching element is not found. The pair returned--- by this function consists of the popped value and the modified tree.------ Complexity: O(log n)-assertPop :: (e -> COrdering a) -> AVL e -> (a,AVL e)-assertPop c = genPop_ where- genPop_ E = error "assertPop: element not found."- genPop_ (N l e r) = case popN l e r of UBT2(v,t) -> (v,t)- genPop_ (Z l e r) = case popZ l e r of UBT2(v,t) -> (v,t)- genPop_ (P l e r) = case popP l e r of UBT2(v,t) -> (v,t)-- ----------------------------- LEVEL 1 ---------------------------------- -- popN, popZ, popP --- ------------------------------------------------------------------------- -- Pop from (N l e r)- popN l e r = case c e of- Lt -> popNL l e r- Eq a -> let t = subN l r in t `seq` UBT2(a,t)- Gt -> popNR l e r-- -- Pop from (Z l e r)- popZ l e r = case c e of- Lt -> popZL l e r- Eq a -> let t = subZR l r in t `seq` UBT2(a,t)- Gt -> popZR l e r-- -- Pop from (P l e r)- popP l e r = case c e of- Lt -> popPL l e r- Eq a -> let t = subP l r in t `seq` UBT2(a,t)- Gt -> popPR l e r-- ----------------------------- LEVEL 2 ---------------------------------- -- popNL, popZL, popPL --- -- popNR, popZR, popPR --- ------------------------------------------------------------------------- -- Pop from the left subtree of (N l e r)- popNL E _ _ = error "assertPop: element not found." -- Left sub-tree is empty- popNL (N ll le lr) e r = case c le of- Lt -> case popNL ll le lr of- UBT2(a,l_) -> let t = chkLN l_ e r in t `seq` UBT2(a,t)- Eq a -> let t = chkLN (subN ll lr) e r in t `seq` UBT2(a,t)- Gt -> case popNR ll le lr of- UBT2(a,l_) -> let t = chkLN l_ e r in t `seq` UBT2(a,t)- popNL (Z ll le lr) e r = case c le of- Lt -> case popZL ll le lr of UBT2(a,l_) -> UBT2(a, N l_ e r)- Eq a -> let t = chkLN' (subZR ll lr) e r- in t `seq` UBT2(a,t)- Gt -> case popZR ll le lr of UBT2(a,l_) -> UBT2(a, N l_ e r)- popNL (P ll le lr) e r = case c le of- Lt -> case popPL ll le lr of- UBT2(a,l_) -> let t = chkLN l_ e r in t `seq` UBT2(a,t)- Eq a -> let t = chkLN (subP ll lr) e r in t `seq` UBT2(a,t)- Gt -> case popPR ll le lr of- UBT2(a,l_) -> let t = chkLN l_ e r in t `seq` UBT2(a,t)-- -- Pop from the right subtree of (N l e r)- popNR _ _ E = error "genPop.popNR: Bug!" -- Impossible- popNR l e (N rl re rr) = case c re of- Lt -> case popNL rl re rr of- UBT2(a,r_) -> let t = chkRN l e r_ in t `seq` UBT2(a,t)- Eq a -> let t = chkRN l e (subN rl rr) in t `seq` UBT2(a,t)- Gt -> case popNR rl re rr of- UBT2(a,r_) -> let t = chkRN l e r_ in t `seq` UBT2(a,t)- popNR l e (Z rl re rr) = case c re of- Lt -> case popZL rl re rr of UBT2(a,r_) -> UBT2(a, N l e r_)- Eq a -> let t = chkRN' l e (subZL rl rr)- in t `seq` UBT2(a,t)- Gt -> case popZR rl re rr of UBT2(a,r_) -> UBT2(a, N l e r_)- popNR l e (P rl re rr) = case c re of- Lt -> case popPL rl re rr of- UBT2(a,r_) -> let t = chkRN l e r_ in t `seq` UBT2(a,t)- Eq a -> let t = chkRN l e (subP rl rr) in t `seq` UBT2(a,t)- Gt -> case popPR rl re rr of- UBT2(a,r_) -> let t = chkRN l e r_ in t `seq` UBT2(a,t)-- -- Pop from the left subtree of (Z l e r)- popZL E _ _ = error "assertPop: element not found." -- Left sub-tree is empty- popZL (N ll le lr) e r = case c le of- Lt -> case popNL ll le lr of- UBT2(a,l_) -> let t = chkLZ l_ e r in t `seq` UBT2(a,t)- Eq a -> let t = chkLZ (subN ll lr) e r in t `seq` UBT2(a,t)- Gt -> case popNR ll le lr of- UBT2(a,l_) -> let t = chkLZ l_ e r in t `seq` UBT2(a,t)- popZL (Z ll le lr) e r = case c le of- Lt -> case popZL ll le lr of UBT2(a,l_) -> UBT2(a, Z l_ e r)- Eq a -> let t = chkLZ' (subZR ll lr) e r- in t `seq` UBT2(a,t)- Gt -> case popZR ll le lr of UBT2(a,l_) -> UBT2(a, Z l_ e r)- popZL (P ll le lr) e r = case c le of- Lt -> case popPL ll le lr of- UBT2(a,l_) -> let t = chkLZ l_ e r in t `seq` UBT2(a,t)- Eq a -> let t = chkLZ (subP ll lr) e r in t `seq` UBT2(a,t)- Gt -> case popPR ll le lr of- UBT2(a,l_) -> let t = chkLZ l_ e r in t `seq` UBT2(a,t)-- -- Pop from the right subtree of (Z l e r)- popZR _ _ E = error "assertPop: element not found." -- Right sub-tree is empty- popZR l e (N rl re rr) = case c re of- Lt -> case popNL rl re rr of- UBT2(a,r_) -> let t = chkRZ l e r_ in t `seq` UBT2(a,t)- Eq a -> let t = chkRZ l e (subN rl rr) in t `seq` UBT2(a,t)- Gt -> case popNR rl re rr of- UBT2(a,r_) -> let t = chkRZ l e r_ in t `seq` UBT2(a,t)- popZR l e (Z rl re rr) = case c re of- Lt -> case popZL rl re rr of UBT2(a,r_) -> UBT2(a, Z l e r_)- Eq a -> let t = chkRZ' l e (subZL rl rr)- in t `seq` UBT2(a,t)- Gt -> case popZR rl re rr of UBT2(a,r_) -> UBT2(a, Z l e r_)- popZR l e (P rl re rr) = case c re of- Lt -> case popPL rl re rr of- UBT2(a,r_) -> let t = chkRZ l e r_ in t `seq` UBT2(a,t)- Eq a -> let t = chkRZ l e (subP rl rr) in t `seq` UBT2(a,t)- Gt -> case popPR rl re rr of- UBT2(a,r_) -> let t = chkRZ l e r_ in t `seq` UBT2(a,t)-- -- Pop from the left subtree of (P l e r)- popPL E _ _ = error "genPop.popPL: Bug!" -- Impossible- popPL (N ll le lr) e r = case c le of- Lt -> case popNL ll le lr of- UBT2(a,l_) -> let t = chkLP l_ e r in t `seq` UBT2(a,t)- Eq a -> let t = chkLP (subN ll lr) e r in t `seq` UBT2(a,t)- Gt -> case popNR ll le lr of- UBT2(a,l_) -> let t = chkLP l_ e r in t `seq` UBT2(a,t)- popPL (Z ll le lr) e r = case c le of- Lt -> case popZL ll le lr of UBT2(a,l_) -> UBT2(a, P l_ e r)- Eq a -> let t = chkLP' (subZR ll lr) e r- in t `seq` UBT2(a,t)- Gt -> case popZR ll le lr of UBT2(a,l_) -> UBT2(a, P l_ e r)- popPL (P ll le lr) e r = case c le of- Lt -> case popPL ll le lr of- UBT2(a,l_) -> let t = chkLP l_ e r in t `seq` UBT2(a,t)- Eq a -> let t = chkLP (subP ll lr) e r in t `seq` UBT2(a,t)- Gt -> case popPR ll le lr of- UBT2(a,l_) -> let t = chkLP l_ e r in t `seq` UBT2(a,t)-- -- Pop from the right subtree of (P l e r)- popPR _ _ E = error "assertPop: element not found." -- Right sub-tree is empty- popPR l e (N rl re rr) = case c re of- Lt -> case popNL rl re rr of- UBT2(a,r_) -> let t = chkRP l e r_ in t `seq` UBT2(a,t)- Eq a -> let t = chkRP l e (subN rl rr) in t `seq` UBT2(a,t)- Gt -> case popNR rl re rr of- UBT2(a,r_) -> let t = chkRP l e r_ in t `seq` UBT2(a,t)- popPR l e (Z rl re rr) = case c re of- Lt -> case popZL rl re rr of UBT2(a,r_) -> UBT2(a, P l e r_)- Eq a -> let t = chkRP' l e (subZL rl rr)- in t `seq` UBT2(a,t)- Gt -> case popZR rl re rr of UBT2(a,r_) -> UBT2(a, P l e r_)- popPR l e (P rl re rr) = case c re of- Lt -> case popPL rl re rr of- UBT2(a,r_) -> let t = chkRP l e r_ in t `seq` UBT2(a,t)- Eq a -> let t = chkRP l e (subP rl rr) in t `seq` UBT2(a,t)- Gt -> case popPR rl re rr of- UBT2(a,r_) -> let t = chkRP l e r_ in t `seq` UBT2(a,t)------------------------------------------------------------------------------------------------- assertPop Ends Here --------------------------------------------------------------------------------------------------- | Similar to 'genPop', but this function returns 'Nothing' if the search fails.------ Complexity: O(log n)-tryPop :: (e -> COrdering a) -> AVL e -> Maybe (a,AVL e)-tryPop c t = case openPathWith c t of- FullBP pth a -> let t' = deletePath pth t in t' `seq` Just (a,t')- _ -> Nothing---- | In this case the selector returns two values if a search succeeds.--- If the second is @('Just' e)@ then the new value (@e@) is substituted in the same place in the tree.--- If the second is 'Nothing' then the corresponding tree element is deleted.--- This function raises an error if the search fails.------ Complexity: O(log n)-assertPopMaybe :: (e -> COrdering (a,Maybe e)) -> AVL e -> (a,AVL e)-assertPopMaybe c t = case openPathWith c t of- FullBP pth (a,Just e ) -> let t' = writePath pth e t in t' `seq` (a,t')- FullBP pth (a,Nothing) -> let t' = deletePath pth t in t' `seq` (a,t')- _ -> error "assertPopMaybe: element not found."---- | Similar to 'assertPopMaybe', but returns 'Nothing' if the search fails.------ Complexity: O(log n)-tryPopMaybe :: (e -> COrdering (a,Maybe e)) -> AVL e -> Maybe (a,AVL e)-tryPopMaybe c t = case openPathWith c t of- FullBP pth (a,Just e ) -> let t' = writePath pth e t in t' `seq` Just (a,t')- FullBP pth (a,Nothing) -> let t' = deletePath pth t in t' `seq` Just (a,t')- _ -> Nothing----- | A simpler version of 'assertPopMaybe'. The corresponding element is deleted if the second value--- returned by the selector is 'True'. If it\'s 'False', the original tree is returned.--- This function raises an error if the search fails.------ Complexity: O(log n)-assertPopIf :: (e -> COrdering (a,Bool)) -> AVL e -> (a,AVL e)-assertPopIf c t = case openPathWith c t of- FullBP _ (a,False) -> (a,t)- FullBP pth (a,True ) -> let t' = deletePath pth t in t' `seq` (a,t')- _ -> error "assertPopIf: element not found."---- | Similar to 'genPopIf', but returns 'Nothing' if the search fails.------ Complexity: O(log n)-tryPopIf :: (e -> COrdering (a,Bool)) -> AVL e -> Maybe (a,AVL e)-tryPopIf c t = case openPathWith c t of- FullBP _ (a,False) -> Just (a,t)- FullBP pth (a,True ) -> let t' = deletePath pth t in t' `seq` Just (a,t')- _ -> Nothing-
− Data/Tree/AVL/Deprecated.hs
@@ -1,683 +0,0 @@-{-# OPTIONS_GHC -fglasgow-exts #-}--------------------------------------------------------------------------------- |--- Module : Data.Tree.AVL.Deprecated--- Copyright : (c) Adrian Hey 2004,2008--- License : BSD3------ Maintainer : http://homepages.nildram.co.uk/~ahey/em.png--- Stability : unstable--- Portability : portable-------------------------------------------------------------------------------module Data.Tree.AVL.Deprecated-(-- * Deprecated-- -- ** Deprecated names- -- | These functions are all still available, but with more sensible names.- -- They will dissapear on the next major version so you should amend your code- -- accordingly soon.-- genUnion,genUnionMaybe,genDisjointUnion,genUnions,- genDifference,genDifferenceMaybe,genSymDifference,- genIntersection,genIntersectionMaybe,- genIntersectionToListL,genIntersectionAsListL,- genIntersectionMaybeToListL,genIntersectionMaybeAsListL,- genVenn,genVennMaybe,- genVennToList,genVennAsList,- genVennMaybeToList,genVennMaybeAsList,- genIsSubsetOf,genIsSubsetOfBy,-- genAssertRead,genTryRead,genTryReadMaybe,genDefaultRead,genContains,-- genWrite,genWriteFast,genTryWrite,genWriteMaybe,genTryWriteMaybe,-- genDel,genDelFast,genDelIf,genDelMaybe,- genAssertPop,genTryPop,genAssertPopMaybe,genTryPopMaybe,genAssertPopIf,genTryPopIf,-- genPush,genPush',genPushMaybe,genPushMaybe',-- genAsTree,-- genForkL,genForkR,genFork,- genTakeLE,genDropGT,- genTakeLT,genDropGE,- genTakeGT,genDropLE,- genTakeGE,genDropLT,-- genAssertOpen,genTryOpen,- genTryOpenGE,genTryOpenLE,- genOpenEither,- genOpenBAVL,-- genFindPath,genOpenPath,genOpenPathWith,-- fastAddSize,-- reverseAVL,mapAVL,mapAVL',- mapAccumLAVL ,mapAccumRAVL ,- mapAccumLAVL' ,mapAccumRAVL' ,-#ifdef __GLASGOW_HASKELL__- mapAccumLAVL'',mapAccumRAVL'',-#endif- replicateAVL,- filterAVL,mapMaybeAVL,- partitionAVL,- foldrAVL,foldrAVL',foldr1AVL,foldr1AVL',foldr2AVL,foldr2AVL',- foldlAVL,foldlAVL',foldl1AVL,foldl1AVL',foldl2AVL,foldl2AVL',- foldrAVL_UINT,-- findPath,--{-- -- ** Deprecated functions- -- | Any functions listed here are deprecated, with no direct replacement.- -- They will continue to live \"forever\" here, but should not be used- -- (ideally).--}--) where--import Prelude hiding (reverse,map,replicate,filter,foldr,foldr1,foldl,foldl1) -- so haddock finds the symbols there--import Data.COrdering(COrdering)-import Data.Tree.AVL.Types(AVL)-import Data.Tree.AVL.Set-import Data.Tree.AVL.Read-import Data.Tree.AVL.Write-import Data.Tree.AVL.Delete-import Data.Tree.AVL.Push-import Data.Tree.AVL.Split-import Data.Tree.AVL.List-import Data.Tree.AVL.Zipper-import Data.Tree.AVL.BinPath-import Data.Tree.AVL.Size--#ifdef __GLASGOW_HASKELL__-import GHC.Base(Int#)-#include "ghcdefs.h"-#else-#include "h98defs.h"-#endif--{-# DEPRECATED genUnion "This is now called union." #-}--- | This name is /deprecated/. Instead use 'union'.-genUnion :: (e -> e -> COrdering e) -> AVL e -> AVL e -> AVL e-genUnion = union-{-# INLINE genUnion #-}--{-# DEPRECATED genUnionMaybe "This is now called unionMaybe." #-}--- | This name is /deprecated/. Instead use 'unionMaybe'.-genUnionMaybe :: (e -> e -> COrdering (Maybe e)) -> AVL e -> AVL e -> AVL e-genUnionMaybe = unionMaybe-{-# INLINE genUnionMaybe #-}--{-# DEPRECATED genDisjointUnion "This is now called disjointUnion." #-}--- | This name is /deprecated/. Instead use 'disjointUnion'.-genDisjointUnion :: (e -> e -> Ordering) -> AVL e -> AVL e -> AVL e-genDisjointUnion = disjointUnion-{-# INLINE genDisjointUnion #-}--{-# DEPRECATED genUnions "This is now called unions." #-}--- | This name is /deprecated/. Instead use 'unions'.-genUnions :: (e -> e -> COrdering e) -> [AVL e] -> AVL e-genUnions = unions-{-# INLINE genUnions #-}--{-# DEPRECATED genDifference "This is now called difference." #-}--- | This name is /deprecated/. Instead use 'difference'.-genDifference :: (a -> b -> Ordering) -> AVL a -> AVL b -> AVL a-genDifference = difference-{-# INLINE genDifference #-}--{-# DEPRECATED genDifferenceMaybe "This is now called differenceMaybe." #-}--- | This name is /deprecated/. Instead use 'differenceMaybe'.-genDifferenceMaybe :: (a -> b -> COrdering (Maybe a)) -> AVL a -> AVL b -> AVL a-genDifferenceMaybe = differenceMaybe-{-# INLINE genDifferenceMaybe #-}--{-# DEPRECATED genSymDifference "This is now called symDifference." #-}--- | This name is /deprecated/. Instead use 'symDifference'.-genSymDifference :: (e -> e -> Ordering) -> AVL e -> AVL e -> AVL e-genSymDifference = symDifference-{-# INLINE genSymDifference #-}--{-# DEPRECATED genIntersection "This is now called intersection." #-}--- | This name is /deprecated/. Instead use 'intersection'.-genIntersection :: (a -> b -> COrdering c) -> AVL a -> AVL b -> AVL c-genIntersection = intersection-{-# INLINE genIntersection #-}--{-# DEPRECATED genIntersectionMaybe "This is now called intersectionMaybe." #-}--- | This name is /deprecated/. Instead use 'intersectionMaybe'.-genIntersectionMaybe :: (a -> b -> COrdering (Maybe c)) -> AVL a -> AVL b -> AVL c-genIntersectionMaybe = intersectionMaybe-{-# INLINE genIntersectionMaybe #-}--{-# DEPRECATED genIntersectionToListL "This is now called intersectionToList." #-}--- | This name is /deprecated/. Instead use 'intersectionToList'.-genIntersectionToListL :: (a -> b -> COrdering c) -> AVL a -> AVL b -> [c] -> [c]-genIntersectionToListL = intersectionToList-{-# INLINE genIntersectionToListL #-}--{-# DEPRECATED genIntersectionAsListL "This is now called intersectionAsList." #-}--- | This name is /deprecated/. Instead use 'intersectionAsList'.-genIntersectionAsListL :: (a -> b -> COrdering c) -> AVL a -> AVL b -> [c]-genIntersectionAsListL = intersectionAsList-{-# INLINE genIntersectionAsListL #-}--{-# DEPRECATED genIntersectionMaybeToListL "This is now called intersectionMaybeToList." #-}--- | This name is /deprecated/. Instead use 'intersectionMaybeToList'.-genIntersectionMaybeToListL :: (a -> b -> COrdering (Maybe c)) -> AVL a -> AVL b -> [c] -> [c]-genIntersectionMaybeToListL = intersectionMaybeToList-{-# INLINE genIntersectionMaybeToListL #-}--{-# DEPRECATED genIntersectionMaybeAsListL "This is now called intersectionMaybeAsList." #-}--- | This name is /deprecated/. Instead use 'intersectionMaybeAsList'.-genIntersectionMaybeAsListL :: (a -> b -> COrdering (Maybe c)) -> AVL a -> AVL b -> [c]-genIntersectionMaybeAsListL = intersectionMaybeAsList-{-# INLINE genIntersectionMaybeAsListL #-}--{-# DEPRECATED genVenn "This is now called venn." #-}--- | This name is /deprecated/. Instead use 'venn'.-genVenn :: (a -> b -> COrdering c) -> AVL a -> AVL b -> (AVL a, AVL c, AVL b)-genVenn = venn-{-# INLINE genVenn #-}--{-# DEPRECATED genVennMaybe "This is now called vennMaybe." #-}--- | This name is /deprecated/. Instead use 'vennMaybe'.-genVennMaybe :: (a -> b -> COrdering (Maybe c)) -> AVL a -> AVL b -> (AVL a, AVL c, AVL b)-genVennMaybe = vennMaybe-{-# INLINE genVennMaybe #-}--{-# DEPRECATED genVennToList "This is now called vennToList." #-}--- | This name is /deprecated/. Instead use 'vennToList'.-genVennToList :: (a -> b -> COrdering c) -> [c] -> AVL a -> AVL b -> (AVL a, [c], AVL b)-genVennToList = vennToList-{-# INLINE genVennToList #-}--{-# DEPRECATED genVennAsList "This is now called vennAsList." #-}--- | This name is /deprecated/. Instead use 'vennAsList'.-genVennAsList :: (a -> b -> COrdering c) -> AVL a -> AVL b -> (AVL a, [c], AVL b)-genVennAsList = vennAsList-{-# INLINE genVennAsList #-}--{-# DEPRECATED genVennMaybeToList "This is now called vennMaybeToList." #-}--- | This name is /deprecated/. Instead use 'vennMaybeToList'.-genVennMaybeToList :: (a -> b -> COrdering (Maybe c)) -> [c] -> AVL a -> AVL b -> (AVL a, [c], AVL b)-genVennMaybeToList = vennMaybeToList-{-# INLINE genVennMaybeToList #-}--{-# DEPRECATED genVennMaybeAsList "This is now called vennMaybeAsList." #-}--- | This name is /deprecated/. Instead use 'vennMaybeAsList'.-genVennMaybeAsList :: (a -> b -> COrdering (Maybe c)) -> AVL a -> AVL b -> (AVL a, [c], AVL b)-genVennMaybeAsList = vennMaybeAsList-{-# INLINE genVennMaybeAsList #-}--{-# DEPRECATED genIsSubsetOf "This is now called isSubsetOf." #-}--- | This name is /deprecated/. Instead use 'isSubsetOf'.-genIsSubsetOf :: (a -> b -> Ordering) -> AVL a -> AVL b -> Bool-genIsSubsetOf = isSubsetOf-{-# INLINE genIsSubsetOf #-}--{-# DEPRECATED genIsSubsetOfBy "This is now called isSubsetOfBy." #-}--- | This name is /deprecated/. Instead use 'isSubsetOfBy'.-genIsSubsetOfBy :: (a -> b -> COrdering Bool) -> AVL a -> AVL b -> Bool-genIsSubsetOfBy = isSubsetOfBy-{-# INLINE genIsSubsetOfBy #-}--{-# DEPRECATED genAssertRead "This is now called assertRead." #-}--- | This name is /deprecated/. Instead use 'assertRead'.-genAssertRead :: AVL e -> (e -> COrdering a) -> a-genAssertRead = assertRead-{-# INLINE genAssertRead #-}--{-# DEPRECATED genTryRead "This is now called tryRead." #-}--- | This name is /deprecated/. Instead use 'tryRead'.-genTryRead :: AVL e -> (e -> COrdering a) -> Maybe a-genTryRead = tryRead-{-# INLINE genTryRead #-}--{-# DEPRECATED genTryReadMaybe "This is now called tryReadMaybe." #-}--- | This name is /deprecated/. Instead use 'tryReadMaybe'.-genTryReadMaybe :: AVL e -> (e -> COrdering (Maybe a)) -> Maybe a-genTryReadMaybe = tryReadMaybe-{-# INLINE genTryReadMaybe #-}--{-# DEPRECATED genDefaultRead "This is now called defaultRead." #-}--- | This name is /deprecated/. Instead use 'defaultRead'.-genDefaultRead :: a -> AVL e -> (e -> COrdering a) -> a-genDefaultRead = defaultRead-{-# INLINE genDefaultRead #-}--{-# DEPRECATED genContains "This is now called contains." #-}--- | This name is /deprecated/. Instead use 'contains'.-genContains :: AVL e -> (e -> Ordering) -> Bool-genContains = contains-{-# INLINE genContains #-}--{-# DEPRECATED genWrite "This is now called write." #-}--- | This name is /deprecated/. Instead use 'write'.-genWrite :: (e -> COrdering e) -> AVL e -> AVL e-genWrite = write-{-# INLINE genWrite #-}--{-# DEPRECATED genWriteFast "This is now called writeFast." #-}--- | This name is /deprecated/. Instead use 'writeFast'.-genWriteFast :: (e -> COrdering e) -> AVL e -> AVL e-genWriteFast = writeFast-{-# INLINE genWriteFast #-}--{-# DEPRECATED genTryWrite "This is now called tryWrite." #-}--- | This name is /deprecated/. Instead use 'tryWrite'.-genTryWrite :: (e -> COrdering e) -> AVL e -> Maybe (AVL e)-genTryWrite = tryWrite-{-# INLINE genTryWrite #-}--{-# DEPRECATED genWriteMaybe "This is now called writeMaybe." #-}--- | This name is /deprecated/. Instead use 'writeMaybe'.-genWriteMaybe :: (e -> COrdering (Maybe e)) -> AVL e -> AVL e-genWriteMaybe = writeMaybe-{-# INLINE genWriteMaybe #-}--{-# DEPRECATED genTryWriteMaybe "This is now called tryWriteMaybe." #-}--- | This name is /deprecated/. Instead use 'tryWriteMaybe'.-genTryWriteMaybe :: (e -> COrdering (Maybe e)) -> AVL e -> Maybe (AVL e)-genTryWriteMaybe = tryWriteMaybe-{-# INLINE genTryWriteMaybe #-}--{-# DEPRECATED genDel "This is now called delete." #-}--- | This name is /deprecated/. Instead use 'delete'.-genDel :: (e -> Ordering) -> AVL e -> AVL e-genDel = delete-{-# INLINE genDel #-}--{-# DEPRECATED genDelFast "This is now called deleteFast." #-}--- | This name is /deprecated/. Instead use 'deleteFast'.-genDelFast :: (e -> Ordering) -> AVL e -> AVL e-genDelFast = deleteFast-{-# INLINE genDelFast #-}--{-# DEPRECATED genDelIf "This is now called deleteIf." #-}--- | This name is /deprecated/. Instead use 'deleteIf'.-genDelIf :: (e -> COrdering Bool) -> AVL e -> AVL e-genDelIf = deleteIf-{-# INLINE genDelIf #-}--{-# DEPRECATED genDelMaybe "This is now called deleteMaybe." #-}--- | This name is /deprecated/. Instead use 'deleteMaybe'.-genDelMaybe :: (e -> COrdering (Maybe e)) -> AVL e -> AVL e-genDelMaybe = deleteMaybe-{-# INLINE genDelMaybe #-}--{-# DEPRECATED genAssertPop "This is now called assertPop." #-}--- | This name is /deprecated/. Instead use 'assertPop'.-genAssertPop :: (e -> COrdering a) -> AVL e -> (a,AVL e)-genAssertPop = assertPop-{-# INLINE genAssertPop #-}--{-# DEPRECATED genTryPop "This is now called tryPop." #-}--- | This name is /deprecated/. Instead use 'tryPop'.-genTryPop :: (e -> COrdering a) -> AVL e -> Maybe (a,AVL e)-genTryPop = tryPop-{-# INLINE genTryPop #-}--{-# DEPRECATED genAssertPopMaybe "This is now called assertPopMaybe." #-}--- | This name is /deprecated/. Instead use 'assertPopMaybe'.-genAssertPopMaybe :: (e -> COrdering (a,Maybe e)) -> AVL e -> (a,AVL e)-genAssertPopMaybe = assertPopMaybe-{-# INLINE genAssertPopMaybe #-}--{-# DEPRECATED genTryPopMaybe "This is now called tryPopMaybe." #-}--- | This name is /deprecated/. Instead use 'tryPopMaybe'.-genTryPopMaybe :: (e -> COrdering (a,Maybe e)) -> AVL e -> Maybe (a,AVL e)-genTryPopMaybe = tryPopMaybe-{-# INLINE genTryPopMaybe #-}--{-# DEPRECATED genAssertPopIf "This is now called assertPopIf." #-}--- | This name is /deprecated/. Instead use 'assertPopIf'.-genAssertPopIf :: (e -> COrdering (a,Bool)) -> AVL e -> (a,AVL e)-genAssertPopIf = assertPopIf-{-# INLINE genAssertPopIf #-}--{-# DEPRECATED genTryPopIf "This is now called tryPopIf." #-}--- | This name is /deprecated/. Instead use 'tryPopIf'.-genTryPopIf :: (e -> COrdering (a,Bool)) -> AVL e -> Maybe (a,AVL e)-genTryPopIf = tryPopIf-{-# INLINE genTryPopIf #-}--{-# DEPRECATED genPush "This is now called push." #-}--- | This name is /deprecated/. Instead use 'push'.-genPush :: (e -> COrdering e) -> e -> AVL e -> AVL e-genPush = push-{-# INLINE genPush #-}--{-# DEPRECATED genPush' "This is now called push'." #-}--- | This name is /deprecated/. Instead use ' push''.-genPush' :: (e -> COrdering e) -> e -> AVL e -> AVL e-genPush' = push'-{-# INLINE genPush' #-}--{-# DEPRECATED genPushMaybe "This is now called pushMaybe." #-}--- | This name is /deprecated/. Instead use 'pushMaybe'.-genPushMaybe :: (e -> COrdering (Maybe e)) -> e -> AVL e -> AVL e-genPushMaybe = pushMaybe-{-# INLINE genPushMaybe #-}--{-# DEPRECATED genPushMaybe' "This is now called pushMaybe'." #-}--- | This name is /deprecated/. Instead use 'pushMaybe''.-genPushMaybe' :: (e -> COrdering (Maybe e)) -> e -> AVL e -> AVL e-genPushMaybe' = pushMaybe'-{-# INLINE genPushMaybe' #-}--{-# DEPRECATED genAsTree "This is now called asTree." #-}--- | This name is /deprecated/. Instead use 'asTree'.-genAsTree :: (e -> e -> COrdering e) -> [e] -> AVL e-genAsTree = asTree-{-# INLINE genAsTree #-}--{-# DEPRECATED genForkL "This is now called forkL." #-}--- | This name is /deprecated/. Instead use 'forkL'.-genForkL :: (e -> Ordering) -> AVL e -> (AVL e, AVL e)-genForkL = forkL-{-# INLINE genForkL #-}--{-# DEPRECATED genForkR "This is now called forkR." #-}--- | This name is /deprecated/. Instead use 'forkR'.-genForkR :: (e -> Ordering) -> AVL e -> (AVL e, AVL e)-genForkR = forkR-{-# INLINE genForkR #-}--{-# DEPRECATED genFork "This is now called fork." #-}--- | This name is /deprecated/. Instead use 'fork'.-genFork :: (e -> COrdering a) -> AVL e -> (AVL e, Maybe a, AVL e)-genFork = fork-{-# INLINE genFork #-}--{-# DEPRECATED genTakeLE "This is now called takeLE." #-}--- | This name is /deprecated/. Instead use 'takeLE'.-genTakeLE :: (e -> Ordering) -> AVL e -> AVL e-genTakeLE = takeLE-{-# INLINE genTakeLE #-}--{-# DEPRECATED genDropGT "This is now called dropGT." #-}--- | This name is /deprecated/. Instead use 'dropGT'.-genDropGT :: (e -> Ordering) -> AVL e -> AVL e-genDropGT = dropGT-{-# INLINE genDropGT #-}--{-# DEPRECATED genTakeLT "This is now called takeLT." #-}--- | This name is /deprecated/. Instead use 'takeLT'.-genTakeLT :: (e -> Ordering) -> AVL e -> AVL e-genTakeLT = takeLT-{-# INLINE genTakeLT #-}--{-# DEPRECATED genDropGE "This is now called dropGE." #-}--- | This name is /deprecated/. Instead use 'dropGE'.-genDropGE :: (e -> Ordering) -> AVL e -> AVL e-genDropGE = dropGE-{-# INLINE genDropGE #-}--{-# DEPRECATED genTakeGT "This is now called takeGT." #-}--- | This name is /deprecated/. Instead use 'takeGT'.-genTakeGT :: (e -> Ordering) -> AVL e -> AVL e-genTakeGT = takeGT-{-# INLINE genTakeGT #-}--{-# DEPRECATED genDropLE "This is now called dropLE." #-}--- | This name is /deprecated/. Instead use 'dropLE'.-genDropLE :: (e -> Ordering) -> AVL e -> AVL e-genDropLE = dropLE-{-# INLINE genDropLE #-}--{-# DEPRECATED genTakeGE "This is now called takeGE." #-}--- | This name is /deprecated/. Instead use 'takeGE'.-genTakeGE :: (e -> Ordering) -> AVL e -> AVL e-genTakeGE = takeGE-{-# INLINE genTakeGE #-}--{-# DEPRECATED genDropLT "This is now called dropLT." #-}--- | This name is /deprecated/. Instead use 'dropLT'.-genDropLT :: (e -> Ordering) -> AVL e -> AVL e-genDropLT = dropLT-{-# INLINE genDropLT #-}--{-# DEPRECATED genAssertOpen "This is now called assertOpen." #-}--- | This name is /deprecated/. Instead use 'assertOpen'.-genAssertOpen :: (e -> Ordering) -> AVL e -> ZAVL e-genAssertOpen = assertOpen-{-# INLINE genAssertOpen #-}--{-# DEPRECATED genTryOpen "This is now called tryOpen." #-}--- | This name is /deprecated/. Instead use 'tryOpen'.-genTryOpen :: (e -> Ordering) -> AVL e -> Maybe (ZAVL e)-genTryOpen = tryOpen-{-# INLINE genTryOpen #-}--{-# DEPRECATED genTryOpenGE "This is now called tryOpenGE." #-}--- | This name is /deprecated/. Instead use 'tryOpenGE'.-genTryOpenGE :: (e -> Ordering) -> AVL e -> Maybe (ZAVL e)-genTryOpenGE = tryOpenGE-{-# INLINE genTryOpenGE #-}--{-# DEPRECATED genTryOpenLE "This is now called tryOpenLE." #-}--- | This name is /deprecated/. Instead use 'tryOpenLE'.-genTryOpenLE :: (e -> Ordering) -> AVL e -> Maybe (ZAVL e)-genTryOpenLE = tryOpenLE-{-# INLINE genTryOpenLE #-}--{-# DEPRECATED genOpenEither "This is now called openEither." #-}--- | This name is /deprecated/. Instead use 'openEither'.-genOpenEither :: (e -> Ordering) -> AVL e -> Either (PAVL e) (ZAVL e)-genOpenEither = openEither-{-# INLINE genOpenEither #-}--{-# DEPRECATED genOpenBAVL "This is now called openBAVL." #-}--- | This name is /deprecated/. Instead use 'openBAVL'.-genOpenBAVL :: (e -> Ordering) -> AVL e -> BAVL e-genOpenBAVL = openBAVL-{-# INLINE genOpenBAVL #-}--{-# DEPRECATED genFindPath "This is now called findPath." #-}--- | This name is /deprecated/. Instead use 'findPath'.-genFindPath :: (e -> Ordering) -> AVL e -> UINT-genFindPath = findPath-{-# INLINE genFindPath #-}--{-# DEPRECATED genOpenPath "This is now called openPath." #-}--- | This name is /deprecated/. Instead use 'openPath'.-genOpenPath :: (e -> Ordering) -> AVL e -> BinPath e-genOpenPath = openPath-{-# INLINE genOpenPath #-}--{-# DEPRECATED genOpenPathWith "This is now called openPathWith." #-}--- | This name is /deprecated/. Instead use 'openPathWith'.-genOpenPathWith :: (e -> COrdering a) -> AVL e -> BinPath a-genOpenPathWith = openPathWith-{-# INLINE genOpenPathWith #-}--{-# DEPRECATED fastAddSize "Use addSize or addSize#." #-}--- | This name is /deprecated/. Instead use 'addSize' or 'addSize#'.-fastAddSize :: UINT -> AVL e -> UINT-#ifdef __GLASGOW_HASKELL__-fastAddSize = addSize#-#else-fastAddSize = addSize-#endif-{-# INLINE fastAddSize #-}----{-# DEPRECATED reverseAVL "This is now called reverse." #-}--- | This name is /deprecated/. Instead use 'reverse'.-reverseAVL :: AVL e -> AVL e-reverseAVL = reverse-{-# INLINE reverseAVL #-}--{-# DEPRECATED mapAVL "This is now called map." #-}--- | This name is /deprecated/. Instead use 'map'.-mapAVL :: (a -> b) -> AVL a -> AVL b-mapAVL = map-{-# INLINE mapAVL #-}--{-# DEPRECATED mapAVL' "This is now called map'." #-}--- | This name is /deprecated/. Instead use 'map''.-mapAVL' :: (a -> b) -> AVL a -> AVL b-mapAVL' = map'-{-# INLINE mapAVL' #-}--{-# DEPRECATED mapAccumLAVL "This is now called mapAccumL." #-}--- | This name is /deprecated/. Instead use 'mapAccumL'.-mapAccumLAVL :: (z -> a -> (z, b)) -> z -> AVL a -> (z, AVL b)-mapAccumLAVL = mapAccumL-{-# INLINE mapAccumLAVL #-}--{-# DEPRECATED mapAccumRAVL "This is now called mapAccumR." #-}--- | This name is /deprecated/. Instead use 'mapAccumR'.-mapAccumRAVL :: (z -> a -> (z, b)) -> z -> AVL a -> (z, AVL b)-mapAccumRAVL = mapAccumR-{-# INLINE mapAccumRAVL #-}--{-# DEPRECATED mapAccumLAVL' "This is now called mapAccumL'." #-}--- | This name is /deprecated/. Instead use 'mapAccumL''.-mapAccumLAVL' :: (z -> a -> (z, b)) -> z -> AVL a -> (z, AVL b)-mapAccumLAVL' = mapAccumL'-{-# INLINE mapAccumLAVL' #-}--{-# DEPRECATED mapAccumRAVL' "This is now called mapAccumR'." #-}--- | This name is /deprecated/. Instead use 'mapAccumR''.-mapAccumRAVL' :: (z -> a -> (z, b)) -> z -> AVL a -> (z, AVL b)-mapAccumRAVL' = mapAccumR'-{-# INLINE mapAccumRAVL' #-}--#ifdef __GLASGOW_HASKELL__-{-# DEPRECATED mapAccumLAVL'' "This is now called mapAccumL''." #-}--- | This name is /deprecated/. Instead use 'mapAccumL'''.-mapAccumLAVL''- :: (z -> a -> UBT2(z, b)) -> z -> AVL a -> (z, AVL b)-mapAccumLAVL'' = mapAccumL''-{-# INLINE mapAccumLAVL'' #-}--{-# DEPRECATED mapAccumRAVL'' "This is now called mapAccumR''." #-}--- | This name is /deprecated/. Instead use 'mapAccumR'''.-mapAccumRAVL''- :: (z -> a -> UBT2(z, b)) -> z -> AVL a -> (z, AVL b)-mapAccumRAVL'' = mapAccumR''-{-# INLINE mapAccumRAVL'' #-}--{-# DEPRECATED foldrAVL_UINT "This is now called foldrInt#." #-}--- | This name is /deprecated/. Instead use 'foldrInt#'.-foldrAVL_UINT :: (e -> UINT -> UINT) -> UINT -> AVL e -> UINT-foldrAVL_UINT = foldrInt#-{-# INLINE foldrAVL_UINT #-}--#else--{-# DEPRECATED foldrAVL_UINT "This is deprecated, use foldr'." #-}--- | This name is /deprecated/. Instead use 'foldr''.-foldrAVL_UINT :: (e -> UINT -> UINT) -> UINT -> AVL e -> UINT-foldrAVL_UINT = foldr'-{-# INLINE foldrAVL_UINT #-}--#endif--{-# DEPRECATED replicateAVL "This is now called replicate." #-}--- | This name is /deprecated/. Instead use 'replicate'.-replicateAVL :: Int -> e -> AVL e-replicateAVL = replicate-{-# INLINE replicateAVL #-}--{-# DEPRECATED filterAVL "This is now called filter." #-}--- | This name is /deprecated/. Instead use 'filter'.-filterAVL :: (e -> Bool) -> AVL e -> AVL e-filterAVL = filter-{-# INLINE filterAVL #-}--{-# DEPRECATED mapMaybeAVL "This is now called mapMaybe." #-}--- | This name is /deprecated/. Instead use 'mapMaybe'.-mapMaybeAVL :: (a -> Maybe b) -> AVL a -> AVL b-mapMaybeAVL = mapMaybe-{-# INLINE mapMaybeAVL #-}--{-# DEPRECATED partitionAVL "This is now called partition." #-}--- | This name is /deprecated/. Instead use 'partition'.-partitionAVL :: (e -> Bool) -> AVL e -> (AVL e, AVL e)-partitionAVL = partition-{-# INLINE partitionAVL #-}--{-# DEPRECATED foldrAVL "This is now called foldr." #-}--- | This name is /deprecated/. Instead use 'foldr'.-foldrAVL :: (e -> a -> a) -> a -> AVL e -> a-foldrAVL = foldr-{-# INLINE foldrAVL #-}--{-# DEPRECATED foldrAVL' "This is now called foldr'." #-}--- | This name is /deprecated/. Instead use 'foldr''.-foldrAVL' :: (e -> a -> a) -> a -> AVL e -> a-foldrAVL' = foldr'-{-# INLINE foldrAVL' #-}--{-# DEPRECATED foldr1AVL "This is now called foldr1." #-}--- | This name is /deprecated/. Instead use 'foldr1'.-foldr1AVL :: (e -> e -> e) -> AVL e -> e-foldr1AVL = foldr1-{-# INLINE foldr1AVL #-}--{-# DEPRECATED foldr1AVL' "This is now called foldr1'." #-}--- | This name is /deprecated/. Instead use 'foldr1''.-foldr1AVL' :: (e -> e -> e) -> AVL e -> e-foldr1AVL' = foldr1'-{-# INLINE foldr1AVL' #-}--{-# DEPRECATED foldr2AVL "This is now called foldr2." #-}--- | This name is /deprecated/. Instead use 'foldr2'.-foldr2AVL :: (e -> a -> a) -> (e -> a) -> AVL e -> a-foldr2AVL = foldr2-{-# INLINE foldr2AVL #-}--{-# DEPRECATED foldr2AVL' "This is now called foldr2'." #-}--- | This name is /deprecated/. Instead use 'foldr2''.-foldr2AVL' :: (e -> a -> a) -> (e -> a) -> AVL e -> a-foldr2AVL' = foldr2'-{-# INLINE foldr2AVL' #-}--{-# DEPRECATED foldlAVL "This is now called foldl." #-}--- | This name is /deprecated/. Instead use 'foldl'.-foldlAVL :: (a -> e -> a) -> a -> AVL e -> a-foldlAVL = foldl-{-# INLINE foldlAVL #-}--{-# DEPRECATED foldlAVL' "This is now called foldl'." #-}--- | This name is /deprecated/. Instead use 'foldl''.-foldlAVL' :: (a -> e -> a) -> a -> AVL e -> a-foldlAVL' = foldl'-{-# INLINE foldlAVL' #-}--{-# DEPRECATED foldl1AVL "This is now called foldl1." #-}--- | This name is /deprecated/. Instead use 'foldl1'.-foldl1AVL :: (e -> e -> e) -> AVL e -> e-foldl1AVL = foldl1-{-# INLINE foldl1AVL #-}--{-# DEPRECATED foldl1AVL' "This is now called foldl1'." #-}--- | This name is /deprecated/. Instead use 'foldl1''.-foldl1AVL' :: (e -> e -> e) -> AVL e -> e-foldl1AVL' = foldl1'-{-# INLINE foldl1AVL' #-}--{-# DEPRECATED foldl2AVL "This is now called foldl2." #-}--- | This name is /deprecated/. Instead use 'foldl2'.-foldl2AVL :: (a -> e -> a) -> (e -> a) -> AVL e -> a-foldl2AVL = foldl2-{-# INLINE foldl2AVL #-}--{-# DEPRECATED foldl2AVL' "This is now called foldl2'." #-}--- | This name is /deprecated/. Instead use 'foldl2''.-foldl2AVL' :: (a -> e -> a) -> (e -> a) -> AVL e -> a-foldl2AVL' = foldl2'-{-# INLINE foldl2AVL' #-}--{-# DEPRECATED findPath "This is now called findFullPath." #-}--- | This name is /deprecated/. Instead use 'findFullPath'.-findPath :: (e -> Ordering) -> AVL e -> UINT-findPath = findFullPath-{-# INLINE findPath #-}
− Data/Tree/AVL/Height.hs
@@ -1,99 +0,0 @@-{-# OPTIONS_GHC -fglasgow-exts #-}--------------------------------------------------------------------------------- |--- Module : Data.Tree.AVL.Height--- Copyright : (c) Adrian Hey 2004,2005--- License : BSD3------ Maintainer : http://homepages.nildram.co.uk/~ahey/em.png--- Stability : stable--- Portability : portable------ AVL tree height related utilities.------ The functions defined here are not exported by the main Data.Tree.AVL module--- because they violate the policy for AVL tree equality used elsewhere in this library.--- You need to import this module explicitly if you want to use any of these functions.-------------------------------------------------------------------------------module Data.Tree.AVL.Height- (-- * AVL tree height utilities.- height,addHeight,compareHeight, -- heightInt,- ) where--import Data.Tree.AVL.Types(AVL(..))--#ifdef __GLASGOW_HASKELL__-import GHC.Base-#include "ghcdefs.h"-#else-#include "h98defs.h"-#endif---- {-# INLINE heightInt #-} -- Don't want this--- heightInt :: AVL e -> Int--- heightInt t = ASINT(addHeight L(0) t)---- | Determine the height of an AVL tree.------ Complexity: O(log n)-{-# INLINE height #-}-height :: AVL e -> UINT-height t = addHeight L(0) t---- | Adds the height of a tree to the first argument.------ Complexity: O(log n)-addHeight :: UINT -> AVL e -> UINT-addHeight h E = h-addHeight h (N l _ _) = addHeight INCINT2(h) l-addHeight h (Z l _ _) = addHeight INCINT1(h) l-addHeight h (P _ _ r) = addHeight INCINT2(h) r---- | A fast algorithm for comparing the heights of two trees. This algorithm avoids the need--- to compute the heights of both trees and should offer better performance if the trees differ--- significantly in height. But if you need the heights anyway it will be quicker to just evaluate--- them both and compare the results.------ Complexity: O(log n), where n is the size of the smaller of the two trees.-compareHeight :: AVL a -> AVL b -> Ordering-compareHeight = ch L(0) where -- d = hA-hB- ch :: UINT -> AVL a -> AVL b -> Ordering- ch d E E = COMPAREUINT d L(0)- ch d E (N l1 _ _ ) = chA DECINT2(d) l1- ch d E (Z l1 _ _ ) = chA DECINT1(d) l1- ch d E (P _ _ r1) = chA DECINT2(d) r1- ch d (N l0 _ _ ) E = chB INCINT2(d) l0- ch d (N l0 _ _ ) (N l1 _ _ ) = ch d l0 l1- ch d (N l0 _ _ ) (Z l1 _ _ ) = ch INCINT1(d) l0 l1- ch d (N l0 _ _ ) (P _ _ r1) = ch d l0 r1- ch d (Z l0 _ _ ) E = chB INCINT1(d) l0- ch d (Z l0 _ _ ) (N l1 _ _ ) = ch DECINT1(d) l0 l1- ch d (Z l0 _ _ ) (Z l1 _ _ ) = ch d l0 l1- ch d (Z l0 _ _ ) (P _ _ r1) = ch DECINT1(d) l0 r1- ch d (P _ _ r0) E = chB INCINT2(d) r0- ch d (P _ _ r0) (N l1 _ _ ) = ch d r0 l1- ch d (P _ _ r0) (Z l1 _ _ ) = ch INCINT1(d) r0 l1- ch d (P _ _ r0) (P _ _ r1) = ch d r0 r1- -- Tree A ended first, continue with Tree B until hA-hB<0, or Tree B ends- chA d tB = case COMPAREUINT d L(0) of- LT -> LT- EQ -> case tB of- E -> EQ- _ -> LT- GT -> case tB of- E -> GT- N l _ _ -> chA DECINT2(d) l- Z l _ _ -> chA DECINT1(d) l- P _ _ r -> chA DECINT2(d) r- -- Tree B ended first, continue with Tree A until hA-hB>0, or Tree A ends- chB d tA = case COMPAREUINT d L(0) of- GT -> GT- EQ -> case tA of- E -> EQ- _ -> GT- LT -> case tA of- E -> LT- N l _ _ -> chB INCINT2(d) l- Z l _ _ -> chB INCINT1(d) l- P _ _ r -> chB INCINT2(d) r-
− Data/Tree/AVL/Internals/DelUtils.hs
@@ -1,790 +0,0 @@-{-# OPTIONS_GHC -fglasgow-exts #-}--------------------------------------------------------------------------------- |--- Module : Data.Tree.AVL.Internals.DelUtils--- Copyright : (c) Adrian Hey 2004,2005--- License : BSD3------ Maintainer : http://homepages.nildram.co.uk/~ahey/em.png--- Stability : stable--- Portability : portable------ This module defines utility functions for deleting elements from AVL trees.-------------------------------------------------------------------------------module Data.Tree.AVL.Internals.DelUtils- (-- * Deleting utilities.- delRN,delRZ,delRP,delLN,delLZ,delLP,-- -- * Popping utilities.- popRN,popRZ,popRP,popLN,popLZ,popLP,- popHL,popHLN,popHLZ,popHLP,-- -- * Balancing utilities.- chkLN,chkLZ,chkLP,chkRN,chkRZ,chkRP,- chkLN',chkLZ',chkLP',chkRN',chkRZ',chkRP',-- -- * Node substitution utilities.- subN,subZR,subZL,subP,-- -- * BinPath related.- deletePath,- ) where--import Data.Tree.AVL.Types(AVL(..))-import Data.Tree.AVL.BinPath(sel,goL,goR)--#ifdef __GLASGOW_HASKELL__-import GHC.Base-#include "ghcdefs.h"-#else-#include "h98defs.h"-#endif--{------------------------------------------------------------------------------------------------------------------------------- -------------------------------------- Notes about Deletion and Rebalancing -------------------------------------------------- -------------------------------------------------------------------------------------------------------------------------------If you go through a similar analysis to that indicated in the Push.hs module (which I haven't illustrated-here with ASCII art) it can be seen that (as with insertion) the height change in a tree which occurs-as a result of deletion of a node can be infered from the change in BF, (whether or not a re-balancing-rotation was required). The rules are:- BF +/-1 -> 0, height decreased by 1- BF 0 -> +/-1, height unchanged.- BF unchanged , height unchanged.- BF +/-1 -> -/+1, height unchanged.--Unlike insertion, rebalancing on deletion requires pattern matching on nodes which aren't on the-current path, hence the existance of separate rebalancing functions (rebalN and rebalP).-------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------}--------------------------------------------------------------------------------------------------- delL Starts Here -------------------------------------------------------------------------------------------------------------------------------- delL LEVEL 1 ---------------------------------- delLN, delLZ, delLP ----------------------------------------------------------------------------- Delete leftmost from (N l e r)-delLN :: AVL e -> e -> AVL e -> AVL e-delLN E _ r = r -- Terminal case, r must be of form (Z E re E)-delLN (N ll le lr) e r = chkLN (delLN ll le lr) e r-delLN (Z ll le lr) e r = delLNZ ll le lr e r-delLN (P ll le lr) e r = chkLN (delLP ll le lr) e r---- Delete leftmost from (Z l e r)-delLZ :: AVL e -> e -> AVL e -> AVL e-delLZ E _ _ = E -- Terminal case, r must be E-delLZ (N ll le lr) e r = delLZN ll le lr e r-delLZ (Z ll le lr) e r = delLZZ ll le lr e r-delLZ (P ll le lr) e r = delLZP ll le lr e r---- Delete leftmost from (P l e r)-delLP :: AVL e -> e -> AVL e -> AVL e-delLP E _ _ = error "delLP: Bug0" -- Impossible if BF=+1-delLP (N ll le lr) e r = chkLP (delLN ll le lr) e r-delLP (Z ll le lr) e r = delLPZ ll le lr e r-delLP (P ll le lr) e r = chkLP (delLP ll le lr) e r---------------------------- delL LEVEL 2 ---------------------------------- delLNZ, delLZZ, delLPZ ----- delLZN, delLZP ------------------------------------------------------------------------------ Delete leftmost from (N (Z ll le lr) e r), height of left sub-tree can't change in this case-{-# INLINE delLNZ #-}-delLNZ :: AVL e -> e -> AVL e -> e -> AVL e -> AVL e-delLNZ E _ _ e r = rebalN E e r -- Terminal case, Needs rebalancing-delLNZ (N lll lle llr) le lr e r = let l' = delLZN lll lle llr le lr in l' `seq` N l' e r-delLNZ (Z lll lle llr) le lr e r = let l' = delLZZ lll lle llr le lr in l' `seq` N l' e r-delLNZ (P lll lle llr) le lr e r = let l' = delLZP lll lle llr le lr in l' `seq` N l' e r---- Delete leftmost from (Z (Z ll le lr) e r), height of left sub-tree can't change in this case--- Don't inline-delLZZ :: AVL e -> e -> AVL e -> e -> AVL e -> AVL e-delLZZ E _ _ e r = N E e r -- Terminal case-delLZZ (N lll lle llr) le lr e r = let l' = delLZN lll lle llr le lr in l' `seq` Z l' e r-delLZZ (Z lll lle llr) le lr e r = let l' = delLZZ lll lle llr le lr in l' `seq` Z l' e r-delLZZ (P lll lle llr) le lr e r = let l' = delLZP lll lle llr le lr in l' `seq` Z l' e r---- Delete leftmost from (P (Z ll le lr) e r), height of left sub-tree can't change in this case-{-# INLINE delLPZ #-}-delLPZ :: AVL e -> e -> AVL e -> e -> AVL e -> AVL e-delLPZ E _ _ e _ = Z E e E -- Terminal case-delLPZ (N lll lle llr) le lr e r = let l' = delLZN lll lle llr le lr in l' `seq` P l' e r-delLPZ (Z lll lle llr) le lr e r = let l' = delLZZ lll lle llr le lr in l' `seq` P l' e r-delLPZ (P lll lle llr) le lr e r = let l' = delLZP lll lle llr le lr in l' `seq` P l' e r---- Delete leftmost from (Z (N ll le lr) e r)-{-# INLINE delLZN #-}-delLZN :: AVL e -> e -> AVL e -> e -> AVL e -> AVL e-delLZN ll le lr e r = chkLZ (delLN ll le lr) e r---- Delete leftmost from (Z (P ll le lr) e r)-{-# INLINE delLZP #-}-delLZP :: AVL e -> e -> AVL e -> e -> AVL e -> AVL e-delLZP ll le lr e r = chkLZ (delLP ll le lr) e r--------------------------------------------------------------------------------------------------- delL Ends Here --------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------- delR Starts Here -------------------------------------------------------------------------------------------------------------------------------- delR LEVEL 1 ---------------------------------- delRN, delRZ, delRP ----------------------------------------------------------------------------- Delete rightmost from (N l e r)-delRN :: AVL e -> e -> AVL e -> AVL e-delRN _ _ E = error "delRN: Bug0" -- Impossible if BF=-1-delRN l e (N rl re rr) = chkRN l e (delRN rl re rr)-delRN l e (Z rl re rr) = delRNZ l e rl re rr-delRN l e (P rl re rr) = chkRN l e (delRP rl re rr)---- Delete rightmost from (Z l e r)-delRZ :: AVL e -> e -> AVL e -> AVL e-delRZ _ _ E = E -- Terminal case, l must be E-delRZ l e (N rl re rr) = delRZN l e rl re rr-delRZ l e (Z rl re rr) = delRZZ l e rl re rr-delRZ l e (P rl re rr) = delRZP l e rl re rr---- Delete rightmost from (P l e r)-delRP :: AVL e -> e -> AVL e -> AVL e-delRP l _ E = l -- Terminal case, l must be of form (Z E le E)-delRP l e (N rl re rr) = chkRP l e (delRN rl re rr)-delRP l e (Z rl re rr) = delRPZ l e rl re rr-delRP l e (P rl re rr) = chkRP l e (delRP rl re rr)---------------------------- delR LEVEL 2 ---------------------------------- delRNZ, delRZZ, delRPZ ----- delRZN, delRZP ------------------------------------------------------------------------------ Delete rightmost from (N l e (Z rl re rr)), height of right sub-tree can't change in this case-delRNZ :: AVL e -> e -> AVL e -> e -> AVL e -> AVL e-{-# INLINE delRNZ #-}-delRNZ _ e _ _ E = Z E e E -- Terminal case-delRNZ l e rl re (N rrl rre rrr) = let r' = delRZN rl re rrl rre rrr in r' `seq` N l e r'-delRNZ l e rl re (Z rrl rre rrr) = let r' = delRZZ rl re rrl rre rrr in r' `seq` N l e r'-delRNZ l e rl re (P rrl rre rrr) = let r' = delRZP rl re rrl rre rrr in r' `seq` N l e r'---- Delete rightmost from (Z l e (Z rl re rr)), height of right sub-tree can't change in this case-delRZZ :: AVL e -> e -> AVL e -> e -> AVL e -> AVL e-delRZZ l e _ _ E = P l e E -- Terminal case-delRZZ l e rl re (N rrl rre rrr) = let r' = delRZN rl re rrl rre rrr in r' `seq` Z l e r'-delRZZ l e rl re (Z rrl rre rrr) = let r' = delRZZ rl re rrl rre rrr in r' `seq` Z l e r'-delRZZ l e rl re (P rrl rre rrr) = let r' = delRZP rl re rrl rre rrr in r' `seq` Z l e r'---- Delete rightmost from (P l e (Z rl re rr)), height of right sub-tree can't change in this case-delRPZ :: AVL e -> e -> AVL e -> e -> AVL e -> AVL e-{-# INLINE delRPZ #-}-delRPZ l e _ _ E = rebalP l e E -- Terminal case, Needs rebalancing-delRPZ l e rl re (N rrl rre rrr) = let r' = delRZN rl re rrl rre rrr in r' `seq` P l e r'-delRPZ l e rl re (Z rrl rre rrr) = let r' = delRZZ rl re rrl rre rrr in r' `seq` P l e r'-delRPZ l e rl re (P rrl rre rrr) = let r' = delRZP rl re rrl rre rrr in r' `seq` P l e r'---- Delete rightmost from (Z l e (N rl re rr))-delRZN :: AVL e -> e -> AVL e -> e -> AVL e -> AVL e-{-# INLINE delRZN #-}-delRZN l e rl re rr = chkRZ l e (delRN rl re rr)---- Delete rightmost from (Z l e (P rl re rr))-delRZP :: AVL e -> e -> AVL e -> e -> AVL e -> AVL e-{-# INLINE delRZP #-}-delRZP l e rl re rr = chkRZ l e (delRP rl re rr)--------------------------------------------------------------------------------------------------- delR Ends Here --------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------- popL Starts Here -------------------------------------------------------------------------------------------------------------------------------- popL LEVEL 1 ---------------------------------- popLN, popLZ, popLP ----------------------------------------------------------------------------- Delete leftmost from (N l e r)-popLN :: AVL e -> e -> AVL e -> UBT2(e,AVL e)-popLN E e r = UBT2(e,r) -- Terminal case, r must be of form (Z E re E)-popLN (N ll le lr) e r = case popLN ll le lr of- UBT2(v,l) -> let t = chkLN l e r in t `seq` UBT2(v,t)-popLN (Z ll le lr) e r = popLNZ ll le lr e r-popLN (P ll le lr) e r = case popLP ll le lr of- UBT2(v,l) -> let t = chkLN l e r in t `seq` UBT2(v,t)---- Delete leftmost from (Z l e r)-popLZ :: AVL e -> e -> AVL e -> UBT2(e,AVL e)-popLZ E e _ = UBT2(e,E) -- Terminal case, r must be E-popLZ (N ll le lr) e r = popLZN ll le lr e r-popLZ (Z ll le lr) e r = popLZZ ll le lr e r-popLZ (P ll le lr) e r = popLZP ll le lr e r---- Delete leftmost from (P l e r)-popLP :: AVL e -> e -> AVL e -> UBT2(e,AVL e)-popLP E _ _ = error "popLP: Bug!" -- Impossible if BF=+1-popLP (N ll le lr) e r = case popLN ll le lr of- UBT2(v,l) -> let t = chkLP l e r in t `seq` UBT2(v,t)-popLP (Z ll le lr) e r = popLPZ ll le lr e r-popLP (P ll le lr) e r = case popLP ll le lr of- UBT2(v,l) -> let t = chkLP l e r in t `seq` UBT2(v,t)---------------------------- popL LEVEL 2 ---------------------------------- popLNZ, popLZZ, popLPZ ----- popLZN, popLZP ------------------------------------------------------------------------------ Delete leftmost from (N (Z ll le lr) e r), height of left sub-tree can't change in this case-popLNZ :: AVL e -> e -> AVL e -> e -> AVL e -> UBT2(e,AVL e)-{-# INLINE popLNZ #-}-popLNZ E le _ e r = let t = rebalN E e r -- Terminal case, Needs rebalancing- in t `seq` UBT2(le,t)-popLNZ (N lll lle llr) le lr e r = case popLZN lll lle llr le lr of- UBT2(v,l) -> UBT2(v, N l e r)-popLNZ (Z lll lle llr) le lr e r = case popLZZ lll lle llr le lr of- UBT2(v,l) -> UBT2(v, N l e r)-popLNZ (P lll lle llr) le lr e r = case popLZP lll lle llr le lr of- UBT2(v,l) -> UBT2(v, N l e r)---- Delete leftmost from (Z (Z ll le lr) e r), height of left sub-tree can't change in this case--- Don't INLINE this!-popLZZ :: AVL e -> e -> AVL e -> e -> AVL e -> UBT2(e,AVL e)-popLZZ E le _ e r = UBT2(le, N E e r) -- Terminal case-popLZZ (N lll lle llr) le lr e r = case popLZN lll lle llr le lr of- UBT2(v,l) -> UBT2(v, Z l e r)-popLZZ (Z lll lle llr) le lr e r = case popLZZ lll lle llr le lr of- UBT2(v,l) -> UBT2(v, Z l e r)-popLZZ (P lll lle llr) le lr e r = case popLZP lll lle llr le lr of- UBT2(v,l) -> UBT2(v, Z l e r)---- Delete leftmost from (P (Z ll le lr) e r), height of left sub-tree can't change in this case-popLPZ :: AVL e -> e -> AVL e -> e -> AVL e -> UBT2(e,AVL e)-{-# INLINE popLPZ #-}-popLPZ E le _ e _ = UBT2(le, Z E e E) -- Terminal case-popLPZ (N lll lle llr) le lr e r = case popLZN lll lle llr le lr of- UBT2(v,l) -> UBT2(v, P l e r)-popLPZ (Z lll lle llr) le lr e r = case popLZZ lll lle llr le lr of- UBT2(v,l) -> UBT2(v, P l e r)-popLPZ (P lll lle llr) le lr e r = case popLZP lll lle llr le lr of- UBT2(v,l) -> UBT2(v, P l e r)---- Delete leftmost from (Z (N ll le lr) e r)--- Don't INLINE this!-popLZN :: AVL e -> e -> AVL e -> e -> AVL e -> UBT2(e,AVL e)-popLZN ll le lr e r = case popLN ll le lr of- UBT2(v,l) -> let t = chkLZ l e r in t `seq` UBT2(v,t)--- Delete leftmost from (Z (P ll le lr) e r)--- Don't INLINE this!-popLZP :: AVL e -> e -> AVL e -> e -> AVL e -> UBT2(e,AVL e)-popLZP ll le lr e r = case popLP ll le lr of- UBT2(v,l) -> let t = chkLZ l e r in t `seq` UBT2(v,t)--------------------------------------------------------------------------------------------------- popL Ends Here --------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------- popR Starts Here -------------------------------------------------------------------------------------------------------------------------------- popR LEVEL 1 ---------------------------------- popRN, popRZ, popRP ----------------------------------------------------------------------------- Delete rightmost from (N l e r)-popRN :: AVL e -> e -> AVL e -> UBT2(AVL e,e)-popRN _ _ E = error "popRN: Bug!" -- Impossible if BF=-1-popRN l e (N rl re rr) = case popRN rl re rr of- UBT2(r,v) -> let t = chkRN l e r in t `seq` UBT2(t,v)-popRN l e (Z rl re rr) = popRNZ l e rl re rr-popRN l e (P rl re rr) = case popRP rl re rr of- UBT2(r,v) -> let t = chkRN l e r in t `seq` UBT2(t,v)---- Delete rightmost from (Z l e r)-popRZ :: AVL e -> e -> AVL e -> UBT2(AVL e,e)-popRZ _ e E = UBT2(E,e) -- Terminal case, l must be E-popRZ l e (N rl re rr) = popRZN l e rl re rr-popRZ l e (Z rl re rr) = popRZZ l e rl re rr-popRZ l e (P rl re rr) = popRZP l e rl re rr---- Delete rightmost from (P l e r)-popRP :: AVL e -> e -> AVL e -> UBT2(AVL e,e)-popRP l e E = UBT2(l,e) -- Terminal case, l must be of form (Z E le E)-popRP l e (N rl re rr) = case popRN rl re rr of- UBT2(r,v) -> let t = chkRP l e r in t `seq` UBT2(t,v)-popRP l e (Z rl re rr) = popRPZ l e rl re rr-popRP l e (P rl re rr) = case popRP rl re rr of- UBT2(r,v) -> let t = chkRP l e r in t `seq` UBT2(t,v)---------------------------- popR LEVEL 2 ---------------------------------- popRNZ, popRZZ, popRPZ ----- popRZN, popRZP ------------------------------------------------------------------------------ Delete rightmost from (N l e (Z rl re rr)), height of right sub-tree can't change in this case-popRNZ :: AVL e -> e -> AVL e -> e -> AVL e -> UBT2(AVL e,e)-{-# INLINE popRNZ #-}-popRNZ _ e _ re E = UBT2(Z E e E, re) -- Terminal case-popRNZ l e rl re (N rrl rre rrr) = case popRZN rl re rrl rre rrr of- UBT2(r,v) -> UBT2(N l e r, v)-popRNZ l e rl re (Z rrl rre rrr) = case popRZZ rl re rrl rre rrr of- UBT2(r,v) -> UBT2(N l e r, v)-popRNZ l e rl re (P rrl rre rrr) = case popRZP rl re rrl rre rrr of- UBT2(r,v) -> UBT2(N l e r, v)---- Delete rightmost from (Z l e (Z rl re rr)), height of right sub-tree can't change in this case--- Don't INLINE this!-popRZZ :: AVL e -> e -> AVL e -> e -> AVL e -> UBT2(AVL e,e)-popRZZ l e _ re E = UBT2(P l e E, re) -- Terminal case-popRZZ l e rl re (N rrl rre rrr) = case popRZN rl re rrl rre rrr of- UBT2(r,v) -> UBT2(Z l e r, v)-popRZZ l e rl re (Z rrl rre rrr) = case popRZZ rl re rrl rre rrr of- UBT2(r,v) -> UBT2(Z l e r, v)-popRZZ l e rl re (P rrl rre rrr) = case popRZP rl re rrl rre rrr of- UBT2(r,v) -> UBT2(Z l e r, v)---- Delete rightmost from (P l e (Z rl re rr)), height of right sub-tree can't change in this case-popRPZ :: AVL e -> e -> AVL e -> e -> AVL e -> UBT2(AVL e,e)-{-# INLINE popRPZ #-}-popRPZ l e _ re E = let t = rebalP l e E -- Terminal case, Needs rebalancing- in t `seq` UBT2(t,re)-popRPZ l e rl re (N rrl rre rrr) = case popRZN rl re rrl rre rrr of- UBT2(r,v) -> UBT2(P l e r, v)-popRPZ l e rl re (Z rrl rre rrr) = case popRZZ rl re rrl rre rrr of- UBT2(r,v) -> UBT2(P l e r, v)-popRPZ l e rl re (P rrl rre rrr) = case popRZP rl re rrl rre rrr of- UBT2(r,v) -> UBT2(P l e r, v)---- Delete rightmost from (Z l e (N rl re rr))--- Don't INLINE this!-popRZN :: AVL e -> e -> AVL e -> e -> AVL e -> UBT2(AVL e,e)-popRZN l e rl re rr = case popRN rl re rr of- UBT2(r,v) -> let t = chkRZ l e r in t `seq` UBT2(t,v)---- Delete rightmost from (Z l e (P rl re rr))--- Don't INLINE this!-popRZP :: AVL e -> e -> AVL e -> e -> AVL e -> UBT2(AVL e,e)-popRZP l e rl re rr = case popRP rl re rr of- UBT2(r,v) -> let t = chkRZ l e r in t `seq` UBT2(t,v)--------------------------------------------------------------------------------------------------- popR Ends Here ------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------ deletePath Starts Here ----------------------------------------------------------------------------------------------------- | Deletes a tree element. Assumes the path bits were extracted from a 'FullBP' constructor.------ Complexity: O(log n)-deletePath :: UINT -> AVL e -> AVL e-deletePath _ E = error "deletePath: Element not found."-deletePath p (N l e r) = delN p l e r-deletePath p (Z l e r) = delZ p l e r-deletePath p (P l e r) = delP p l e r------------------------------- LEVEL 1 ------------------------------------ delN, delZ, delP ------------------------------------------------------------------------------ Delete from (N l e r)-delN :: UINT -> AVL e -> e -> AVL e -> AVL e-delN p l e r = case sel p of- LT -> delNL p l e r- EQ -> subN l r- GT -> delNR p l e r---- Delete from (Z l e r)-delZ :: UINT -> AVL e -> e -> AVL e -> AVL e-delZ p l e r = case sel p of- LT -> delZL p l e r- EQ -> subZR l r- GT -> delZR p l e r---- Delete from (P l e r)-delP :: UINT -> AVL e -> e -> AVL e -> AVL e-delP p l e r = case sel p of- LT -> delPL p l e r- EQ -> subP l r- GT -> delPR p l e r------------------------------- LEVEL 2 ------------------------------------ delNL, delZL, delPL ----- delNR, delZR, delPR ------------------------------------------------------------------------------ Delete from the left subtree of (N l e r)-delNL :: UINT -> AVL e -> e -> AVL e -> AVL e-delNL p t = dNL (goL p) t-{-# INLINE dNL #-}-dNL :: UINT -> AVL e -> e -> AVL e -> AVL e-dNL _ E _ _ = error "deletePath: Element not found." -- Left sub-tree is empty-dNL p (N ll le lr) e r = case sel p of- LT -> chkLN (delNL p ll le lr) e r- EQ -> chkLN (subN ll lr) e r- GT -> chkLN (delNR p ll le lr) e r-dNL p (Z ll le lr) e r = case sel p of- LT -> let l' = delZL p ll le lr in l' `seq` N l' e r -- height can't change- EQ -> chkLN' (subZR ll lr) e r -- << But it can here- GT -> let l' = delZR p ll le lr in l' `seq` N l' e r -- height can't change-dNL p (P ll le lr) e r = case sel p of- LT -> chkLN (delPL p ll le lr) e r- EQ -> chkLN (subP ll lr) e r- GT -> chkLN (delPR p ll le lr) e r---- Delete from the right subtree of (N l e r)-delNR :: UINT -> AVL e -> e -> AVL e -> AVL e-delNR p t = dNR (goR p) t-{-# INLINE dNR #-}-dNR :: UINT -> AVL e -> e -> AVL e -> AVL e-dNR _ _ _ E = error "delNR: Bug0" -- Impossible-dNR p l e (N rl re rr) = case sel p of- LT -> chkRN l e (delNL p rl re rr)- EQ -> chkRN l e (subN rl rr)- GT -> chkRN l e (delNR p rl re rr)-dNR p l e (Z rl re rr) = case sel p of- LT -> let r' = delZL p rl re rr in r' `seq` N l e r' -- height can't change- EQ -> chkRN' l e (subZL rl rr) -- << But it can here- GT -> let r' = delZR p rl re rr in r' `seq` N l e r' -- height can't change-dNR p l e (P rl re rr) = case sel p of- LT -> chkRN l e (delPL p rl re rr)- EQ -> chkRN l e (subP rl rr)- GT -> chkRN l e (delPR p rl re rr)---- Delete from the left subtree of (Z l e r)-delZL :: UINT -> AVL e -> e -> AVL e -> AVL e-delZL p t = dZL (goL p) t-{-# INLINE dZL #-}-dZL :: UINT -> AVL e -> e -> AVL e -> AVL e-dZL _ E _ _ = error "deletePath: Element not found." -- Left sub-tree is empty-dZL p (N ll le lr) e r = case sel p of- LT -> chkLZ (delNL p ll le lr) e r- EQ -> chkLZ (subN ll lr) e r- GT -> chkLZ (delNR p ll le lr) e r-dZL p (Z ll le lr) e r = case sel p of- LT -> let l' = delZL p ll le lr in l' `seq` Z l' e r -- height can't change- EQ -> chkLZ' (subZR ll lr) e r -- << But it can here- GT -> let l' = delZR p ll le lr in l' `seq` Z l' e r -- height can't change-dZL p (P ll le lr) e r = case sel p of- LT -> chkLZ (delPL p ll le lr) e r- EQ -> chkLZ (subP ll lr) e r- GT -> chkLZ (delPR p ll le lr) e r---- Delete from the right subtree of (Z l e r)-delZR :: UINT -> AVL e -> e -> AVL e -> AVL e-delZR p t = dZR (goR p) t-{-# INLINE dZR #-}-dZR :: UINT -> AVL e -> e -> AVL e -> AVL e-dZR _ _ _ E = error "deletePath: Element not found." -- Right sub-tree is empty-dZR p l e (N rl re rr) = case sel p of- LT -> chkRZ l e (delNL p rl re rr)- EQ -> chkRZ l e (subN rl rr)- GT -> chkRZ l e (delNR p rl re rr)-dZR p l e (Z rl re rr) = case sel p of- LT -> let r' = delZL p rl re rr in r' `seq` Z l e r' -- height can't change- EQ -> chkRZ' l e (subZL rl rr) -- << But it can here- GT -> let r' = delZR p rl re rr in r' `seq` Z l e r' -- height can't change-dZR p l e (P rl re rr) = case sel p of- LT -> chkRZ l e (delPL p rl re rr)- EQ -> chkRZ l e (subP rl rr)- GT -> chkRZ l e (delPR p rl re rr)---- Delete from the left subtree of (P l e r)-delPL :: UINT -> AVL e -> e -> AVL e -> AVL e-delPL p t = dPL (goL p) t-{-# INLINE dPL #-}-dPL :: UINT -> AVL e -> e -> AVL e -> AVL e-dPL _ E _ _ = error "delPL: Bug0" -- Impossible-dPL p (N ll le lr) e r = case sel p of- LT -> chkLP (delNL p ll le lr) e r- EQ -> chkLP (subN ll lr) e r- GT -> chkLP (delNR p ll le lr) e r-dPL p (Z ll le lr) e r = case sel p of- LT -> let l' = delZL p ll le lr in l' `seq` P l' e r -- height can't change- EQ -> chkLP' (subZR ll lr) e r -- << But it can here- GT -> let l' = delZR p ll le lr in l' `seq` P l' e r -- height can't change-dPL p (P ll le lr) e r = case sel p of- LT -> chkLP (delPL p ll le lr) e r- EQ -> chkLP (subP ll lr) e r- GT -> chkLP (delPR p ll le lr) e r---- Delete from the right subtree of (P l e r)-delPR :: UINT -> AVL e -> e -> AVL e -> AVL e-delPR p t = dPR (goR p) t-{-# INLINE dPR #-}-dPR :: UINT -> AVL e -> e -> AVL e -> AVL e-dPR _ _ _ E = error "deletePath: Element not found." -- Right sub-tree is empty-dPR p l e (N rl re rr) = case sel p of- LT -> chkRP l e (delNL p rl re rr)- EQ -> chkRP l e (subN rl rr)- GT -> chkRP l e (delNR p rl re rr)-dPR p l e (Z rl re rr) = case sel p of- LT -> let r' = delZL p rl re rr in r' `seq` P l e r' -- height can't change- EQ -> chkRP' l e (subZL rl rr) -- << But it can here- GT -> let r' = delZR p rl re rr in r' `seq` P l e r' -- height can't change-dPR p l e (P rl re rr) = case sel p of- LT -> chkRP l e (delPL p rl re rr)- EQ -> chkRP l e (subP rl rr)- GT -> chkRP l e (delPR p rl re rr)------------------------------------------------------------------------------------------------ deletePath Ends Here ---------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------- This is a modified version of popL which returns the (popped) tree height as well.---------------------------------------------------------------------------------------popHL :: AVL e -> UBT3(e,AVL e,UINT)-popHL E = error "popHL: Empty tree."-popHL (N l e r) = popHLN l e r-popHL (Z l e r) = popHLZ l e r-popHL (P l e r) = popHLP l e r--popHLN :: AVL e -> e -> AVL e -> UBT3(e,AVL e,UINT)-popHLN l e r = case popHLN_ L(2) l e r of- UBT3(e_,t,h) -> case t of- E -> error "popHLN: Bug0" -- impossible- Z _ _ _ -> UBT3(e_,t,DECINT1(h)) -- dH = -1- _ -> UBT3(e_,t, h ) -- dH = 0--popHLZ :: AVL e -> e -> AVL e -> UBT3(e,AVL e,UINT)-popHLZ l e r = case popHLZ_ L(1) l e r of- UBT3(e_,t,h) -> case t of- E -> UBT3(e,E,L(0)) -- Resulting tree is empty- P _ _ _ -> error "popHLZ: Bug0" -- impossible- _ -> UBT3(e_,t, h ) -- dH = 0--popHLP :: AVL e -> e -> AVL e -> UBT3(e,AVL e,UINT)-popHLP l e r = case popHLP_ L(1) l e r of- UBT3(e_,t,h) -> case t of- Z _ _ _ -> UBT3(e_,t,DECINT1(h)) -- dH = -1- P _ _ _ -> UBT3(e_,t, h ) -- dH = 0- _ -> error "popHLP: Bug0" -- impossible---------------------------- popHL LEVEL 1 --------------------------------- popHLN_, popHLZ_, popHLP_ ----------------------------------------------------------------------------- Delete leftmost from (N l e r)-popHLN_ :: UINT -> AVL e -> e -> AVL e -> UBT3(e,AVL e,UINT)-popHLN_ h E e r = UBT3(e,r,h) -- Terminal case, r must be of form (Z E re E)-popHLN_ h (N ll le lr) e r = case popHLN_ INCINT2(h) ll le lr of- UBT3(e_,l,hl) -> let t = chkLN l e r in t `seq` UBT3(e_,t,hl)-popHLN_ h (Z ll le lr) e r = popHLNZ INCINT1(h) ll le lr e r-popHLN_ h (P ll le lr) e r = case popHLP_ INCINT1(h) ll le lr of- UBT3(e_,l,hl) -> let t = chkLN l e r in t `seq` UBT3(e_,t,hl)---- Delete leftmost from (Z l e r)-{-# INLINE popHLZ_ #-}-popHLZ_ :: UINT -> AVL e -> e -> AVL e -> UBT3(e,AVL e,UINT)-popHLZ_ h E e _ = UBT3(e,E,h) -- Terminal case, r must be E-popHLZ_ h (N ll le lr) e r = popHLZN INCINT2(h) ll le lr e r-popHLZ_ h (Z ll le lr) e r = popHLZZ INCINT1(h) ll le lr e r-popHLZ_ h (P ll le lr) e r = popHLZP INCINT1(h) ll le lr e r---- Delete leftmost from (P l e r)-popHLP_ :: UINT -> AVL e -> e -> AVL e -> UBT3(e,AVL e,UINT)-popHLP_ _ E _ _ = error "popHLP_: Bug0" -- Impossible if BF=+1-popHLP_ h (N ll le lr) e r = case popHLN_ INCINT2(h) ll le lr of- UBT3(e_,l,hl) -> let t = chkLP l e r in t `seq` UBT3(e_,t,hl)-popHLP_ h (Z ll le lr) e r = popHLPZ INCINT1(h) ll le lr e r-popHLP_ h (P ll le lr) e r = case popHLP_ INCINT1(h) ll le lr of- UBT3(e_,l,hl) -> let t = chkLP l e r in t `seq` UBT3(e_,t,hl)---------------------------- popHL LEVEL 2 --------------------------------- popHLNZ, popHLZZ, popHLPZ ----- popHLZN, popHLZP ------------------------------------------------------------------------------ Delete leftmost from (N (Z ll le lr) e r), height of left sub-tree can't change in this case-{-# INLINE popHLNZ #-}-popHLNZ :: UINT -> AVL e -> e -> AVL e -> e -> AVL e -> UBT3(e,AVL e,UINT)-popHLNZ h E le _ e r = let t = rebalN E e r -- Terminal case, Needs rebalancing- in t `seq` UBT3(le,t,h)-popHLNZ h (N lll lle llr) le lr e r = case popHLZN INCINT2(h) lll lle llr le lr of- UBT3(e_,l,hl) -> UBT3(e_, N l e r, hl)-popHLNZ h (Z lll lle llr) le lr e r = case popHLZZ INCINT1(h) lll lle llr le lr of- UBT3(e_,l,hl) -> UBT3(e_, N l e r, hl)-popHLNZ h (P lll lle llr) le lr e r = case popHLZP INCINT1(h) lll lle llr le lr of- UBT3(e_,l,hl) -> UBT3(e_, N l e r, hl)---- Delete leftmost from (Z (Z ll le lr) e r), height of left sub-tree can't change in this case--- Don't INLINE this!-popHLZZ :: UINT -> AVL e -> e -> AVL e -> e -> AVL e -> UBT3(e,AVL e,UINT)-popHLZZ h E le _ e r = UBT3(le, N E e r, h) -- Terminal case-popHLZZ h (N lll lle llr) le lr e r = case popHLZN INCINT2(h) lll lle llr le lr of- UBT3(e_,l,hl) -> UBT3(e_, Z l e r, hl)-popHLZZ h (Z lll lle llr) le lr e r = case popHLZZ INCINT1(h) lll lle llr le lr of- UBT3(e_,l,hl) -> UBT3(e_, Z l e r, hl)-popHLZZ h (P lll lle llr) le lr e r = case popHLZP INCINT1(h) lll lle llr le lr of- UBT3(e_,l,hl) -> UBT3(e_, Z l e r, hl)---- Delete leftmost from (P (Z ll le lr) e r), height of left sub-tree can't change in this case-{-# INLINE popHLPZ #-}-popHLPZ :: UINT -> AVL e -> e -> AVL e -> e -> AVL e -> UBT3(e,AVL e,UINT)-popHLPZ h E le _ e _ = UBT3(le, Z E e E, h) -- Terminal case-popHLPZ h (N lll lle llr) le lr e r = case popHLZN INCINT2(h) lll lle llr le lr of- UBT3(e_,l,hl) -> UBT3(e_, P l e r, hl)-popHLPZ h (Z lll lle llr) le lr e r = case popHLZZ INCINT1(h) lll lle llr le lr of- UBT3(e_,l,hl) -> UBT3(e_, P l e r, hl)-popHLPZ h (P lll lle llr) le lr e r = case popHLZP INCINT1(h) lll lle llr le lr of- UBT3(e_,l,hl) -> UBT3(e_, P l e r, hl)---- Delete leftmost from (Z (N ll le lr) e r)--- Don't INLINE this!-popHLZN :: UINT -> AVL e -> e -> AVL e -> e -> AVL e -> UBT3(e,AVL e,UINT)-popHLZN h ll le lr e r = case popHLN_ h ll le lr of- UBT3(e_,l,hl) -> let t = chkLZ l e r in t `seq` UBT3(e_,t,hl)--- Delete leftmost from (Z (P ll le lr) e r)--- Don't INLINE this!-popHLZP :: UINT -> AVL e -> e -> AVL e -> e -> AVL e -> UBT3(e,AVL e,UINT)-popHLZP h ll le lr e r = case popHLP_ h ll le lr of- UBT3(e_,l,hl) -> let t = chkLZ l e r in t `seq` UBT3(e_,t,hl)-------------------------------------------------------------------------------------------------- popHL Ends Here -------------------------------------------------------------------------------------------------------{-************************** Balancing Utilities Below Here ************************************-}---- Rebalance a tree of form (N l e r) which has become unbalanced as--- a result of the height of the left sub-tree (l) decreasing by 1.--- N.B Result is never of form (N _ _ _) (or E!)-rebalN :: AVL e -> e -> AVL e -> AVL e-rebalN _ _ E = error "rebalN: Bug0" -- impossible case-rebalN l e (N rl re rr) = Z (Z l e rl) re rr -- N->Z, dH=-1-rebalN l e (Z rl re rr) = P (N l e rl) re rr -- N->P, dH= 0-rebalN _ _ (P E _ _) = error "rebalN: Bug1" -- impossible case-rebalN l e (P (N rll rle rlr) re rr) = Z (P l e rll) rle (Z rlr re rr) -- N->Z, dH=-1-rebalN l e (P (Z rll rle rlr) re rr) = Z (Z l e rll) rle (Z rlr re rr) -- N->Z, dH=-1-rebalN l e (P (P rll rle rlr) re rr) = Z (Z l e rll) rle (N rlr re rr) -- N->Z, dH=-1---- Rebalance a tree of form (P l e r) which has become unbalanced as--- a result of the height of the right sub-tree (r) decreasing by 1.--- N.B Result is never of form (P _ _ _) (or E!)-rebalP :: AVL e -> e -> AVL e -> AVL e-rebalP E _ _ = error "rebalP: Bug0" -- impossible case-rebalP (P ll le lr ) e r = Z ll le (Z lr e r) -- P->Z, dH=-1-rebalP (Z ll le lr ) e r = N ll le (P lr e r) -- P->N, dH= 0-rebalP (N _ _ E ) _ _ = error "rebalP: Bug1" -- impossible case-rebalP (N ll le (P lrl lre lrr)) e r = Z (Z ll le lrl) lre (N lrr e r) -- P->Z, dH=-1-rebalP (N ll le (Z lrl lre lrr)) e r = Z (Z ll le lrl) lre (Z lrr e r) -- P->Z, dH=-1-rebalP (N ll le (N lrl lre lrr)) e r = Z (P ll le lrl) lre (Z lrr e r) -- P->Z, dH=-1---- Check for height changes in left subtree of (N l e r),--- where l was (N ll le lr) or (P ll le lr)-chkLN :: AVL e -> e -> AVL e -> AVL e-chkLN l e r = case l of- E -> error "chkLN: Bug0" -- impossible if BF<>0- N _ _ _ -> N l e r -- BF +/-1 -> -1, so dH= 0- Z _ _ _ -> rebalN l e r -- BF +/-1 -> 0, so dH=-1- P _ _ _ -> N l e r -- BF +/-1 -> +1, so dH= 0--- Check for height changes in left subtree of (Z l e r),--- where l was (N ll le lr) or (P ll le lr)-chkLZ :: AVL e -> e -> AVL e -> AVL e-chkLZ l e r = case l of- E -> error "chkLZ: Bug0" -- impossible if BF<>0- N _ _ _ -> Z l e r -- BF +/-1 -> -1, so dH= 0- Z _ _ _ -> N l e r -- BF +/-1 -> 0, so dH=-1- P _ _ _ -> Z l e r -- BF +/-1 -> +1, so dH= 0--- Check for height changes in left subtree of (P l e r),--- where l was (N ll le lr) or (P ll le lr)-chkLP :: AVL e -> e -> AVL e -> AVL e-chkLP l e r = case l of- E -> error "chkLP: Bug0" -- impossible if BF<>0- N _ _ _ -> P l e r -- BF +/-1 -> -1, so dH= 0- Z _ _ _ -> Z l e r -- BF +/-1 -> 0, so dH=-1- P _ _ _ -> P l e r -- BF +/-1 -> +1, so dH= 0--- Check for height changes in right subtree of (N l e r),--- where r was (N rl re rr) or (P rl re rr)-chkRN :: AVL e -> e -> AVL e -> AVL e-chkRN l e r = case r of- E -> error "chkRN: Bug0" -- impossible if BF<>0- N _ _ _ -> N l e r -- BF +/-1 -> -1, so dH= 0- Z _ _ _ -> Z l e r -- BF +/-1 -> 0, so dH=-1- P _ _ _ -> N l e r -- BF +/-1 -> +1, so dH= 0--- Check for height changes in right subtree of (Z l e r),--- where r was (N rl re rr) or (P rl re rr)-chkRZ :: AVL e -> e -> AVL e -> AVL e-chkRZ l e r = case r of- E -> error "chkRZ: Bug0" -- impossible if BF<>0- N _ _ _ -> Z l e r -- BF +/-1 -> -1, so dH= 0- Z _ _ _ -> P l e r -- BF +/-1 -> 0, so dH=-1- P _ _ _ -> Z l e r -- BF +/-1 -> +1, so dH= 0--- Check for height changes in right subtree of (P l e r),--- where l was (N rl re rr) or (P rl re rr)-chkRP :: AVL e -> e -> AVL e -> AVL e-chkRP l e r = case r of- E -> error "chkRP: Bug0" -- impossible if BF<>0- N _ _ _ -> P l e r -- BF +/-1 -> -1, so dH= 0- Z _ _ _ -> rebalP l e r -- BF +/-1 -> 0, so dH=-1- P _ _ _ -> P l e r -- BF +/-1 -> +1, so dH= 0---- Substitute deleted element from (N l _ r)-subN :: AVL e -> AVL e -> AVL e-subN _ E = error "subN: Bug0" -- Impossible-subN l (N rl re rr) = case popLN rl re rr of UBT2(e,r_) -> chkRN l e r_-subN l (Z rl re rr) = case popLZ rl re rr of UBT2(e,r_) -> chkRN' l e r_-subN l (P rl re rr) = case popLP rl re rr of UBT2(e,r_) -> chkRN l e r_---- Substitute deleted element from (Z l _ r)--- Pops the replacement from the right sub-tree, so result may be (P _ _ _)-subZR :: AVL e -> AVL e -> AVL e-subZR _ E = E -- Both left and right subtrees must have been empty-subZR l (N rl re rr) = case popLN rl re rr of UBT2(e,r_) -> chkRZ l e r_-subZR l (Z rl re rr) = case popLZ rl re rr of UBT2(e,r_) -> chkRZ' l e r_-subZR l (P rl re rr) = case popLP rl re rr of UBT2(e,r_) -> chkRZ l e r_---- Local utility to substitute deleted element from (Z l _ r)--- Pops the replacement from the left sub-tree, so result may be (N _ _ _)-subZL :: AVL e -> AVL e -> AVL e-subZL E _ = E -- Both left and right subtrees must have been empty-subZL (N ll le lr) r = case popRN ll le lr of UBT2(l_,e) -> chkLZ l_ e r-subZL (Z ll le lr) r = case popRZ ll le lr of UBT2(l_,e) -> chkLZ' l_ e r-subZL (P ll le lr) r = case popRP ll le lr of UBT2(l_,e) -> chkLZ l_ e r---- Substitute deleted element from (P l _ r)-subP :: AVL e -> AVL e -> AVL e-subP E _ = error "subP: Bug0" -- Impossible-subP (N ll le lr) r = case popRN ll le lr of UBT2(l_,e) -> chkLP l_ e r-subP (Z ll le lr) r = case popRZ ll le lr of UBT2(l_,e) -> chkLP' l_ e r-subP (P ll le lr) r = case popRP ll le lr of UBT2(l_,e) -> chkLP l_ e r---- Check for height changes in left subtree of (N l e r),--- where l was (Z ll le lr)-chkLN' :: AVL e -> e -> AVL e -> AVL e-chkLN' l e r = case l of- E -> rebalN l e r -- BF 0 -> E, so dH=-1- _ -> N l e r -- Otherwise dH=0--- Check for height changes in left subtree of (Z l e r),--- where l was (Z ll le lr)-chkLZ' :: AVL e -> e -> AVL e -> AVL e-chkLZ' l e r = case l of- E -> N l e r -- BF 0 -> E, so dH=-1- _ -> Z l e r -- Otherwise dH=0--- Check for height changes in left subtree of (P l e r),--- where l was (Z ll le lr)-chkLP' :: AVL e -> e -> AVL e -> AVL e-chkLP' l e r = case l of- E -> Z l e r -- BF 0 -> E, so dH=-1- _ -> P l e r -- Otherwise dH=0--- Check for height changes in right subtree of (N l e r),--- where r was (Z rl re rr)-chkRN' :: AVL e -> e -> AVL e -> AVL e-chkRN' l e r = case r of- E -> Z l e r -- BF 0 -> E, so dH=-1- _ -> N l e r -- Otherwise dH=0--- Check for height changes in right subtree of (Z l e r),--- where r was (Z rl re rr)-chkRZ' :: AVL e -> e -> AVL e -> AVL e-chkRZ' l e r = case r of- E -> P l e r -- BF 0 -> E, so dH=-1- _ -> Z l e r -- Otherwise dH=0--- Check for height changes in right subtree of (P l e r),--- where l was (Z rl re rr)-chkRP' :: AVL e -> e -> AVL e -> AVL e-chkRP' l e r = case r of- E -> rebalP l e r -- BF 0 -> E, so dH=-1- _ -> P l e r -- Otherwise dH=0-
− Data/Tree/AVL/Internals/HAVL.hs
@@ -1,98 +0,0 @@-{-# OPTIONS_GHC -fglasgow-exts #-}--------------------------------------------------------------------------------- |--- Module : Data.Tree.AVL.Internals.HAVL--- Copyright : (c) Adrian Hey 2004,2005--- License : BSD3------ Maintainer : http://homepages.nildram.co.uk/~ahey/em.png--- Stability : stable--- Portability : portable------ HAVL data type and related utilities-------------------------------------------------------------------------------module Data.Tree.AVL.Internals.HAVL- (- HAVL(HAVL),emptyHAVL,toHAVL,isEmptyHAVL,isNonEmptyHAVL,- spliceHAVL,joinHAVL,- pushLHAVL,pushRHAVL- ) where--import Data.Tree.AVL.Types(AVL(..))-import Data.Tree.AVL.Height(addHeight)-import Data.Tree.AVL.Internals.HJoin(spliceH,joinH)-import Data.Tree.AVL.Internals.HPush(pushHL,pushHR)--#ifdef __GLASGOW_HASKELL__-import GHC.Base-#include "ghcdefs.h"-#else-#include "h98defs.h"-#endif---- | An HAVL represents an AVL tree of known height.-data HAVL e = HAVL (AVL e) {-# UNPACK #-} !UINT---- | Empty HAVL (height is 0).-emptyHAVL :: HAVL e-emptyHAVL = HAVL E L(0)---- | Returns 'True' if the AVL component of an HAVL tree is empty. Note that height component--- is ignored, so it's OK to use this function in cases where the height is relative.------ Complexity: O(1)-{-# INLINE isEmptyHAVL #-}-isEmptyHAVL :: HAVL e -> Bool-isEmptyHAVL (HAVL E _) = True-isEmptyHAVL (HAVL _ _) = False---- | Returns 'True' if the AVL component of an HAVL tree is non-empty. Note that height component--- is ignored, so it's OK to use this function in cases where the height is relative.------ Complexity: O(1)-{-# INLINE isNonEmptyHAVL #-}-isNonEmptyHAVL :: HAVL e -> Bool-isNonEmptyHAVL (HAVL E _) = False-isNonEmptyHAVL (HAVL _ _) = True---- | Converts an AVL to HAVL-toHAVL :: AVL e -> HAVL e-toHAVL t = HAVL t (addHeight L(0) t)---- | Splice two HAVL trees using the supplied bridging element.--- That is, the bridging element appears "in the middle" of the resulting HAVL tree.--- The elements of the first tree argument are to the left of the bridging element and--- the elements of the second tree are to the right of the bridging element.------ This function does not require that the AVL heights are absolutely correct, only that--- the difference in supplied heights is equal to the difference in actual heights. So it's--- OK if the input heights both have the same unknown constant offset. (The output height--- will also have the same constant offset in this case.)------ Complexity: O(d), where d is the absolute difference in tree heights.-{-# INLINE spliceHAVL #-}-spliceHAVL :: HAVL e -> e -> HAVL e -> HAVL e-spliceHAVL (HAVL l hl) e (HAVL r hr) = case spliceH l hl e r hr of UBT2(t,ht) -> HAVL t ht---- | Join two HAVL trees.--- It's OK if heights are relative (I.E. if they share same fixed offset).------ Complexity: O(d), where d is the absolute difference in tree heights.-{-# INLINE joinHAVL #-}-joinHAVL :: HAVL e -> HAVL e -> HAVL e-joinHAVL (HAVL l hl) (HAVL r hr) = case joinH l hl r hr of UBT2(t,ht) -> HAVL t ht---- | A version of 'pushL' for HAVL trees.--- It's OK if height is relative, with fixed offset. In this case the height of the result--- will have the same fixed offset.-{-# INLINE pushLHAVL #-}-pushLHAVL :: e -> HAVL e -> HAVL e-pushLHAVL e (HAVL t ht) = case pushHL e t ht of UBT2(t_,ht_) -> HAVL t_ ht_---- | A version of 'pushR' for HAVL trees.--- It's OK if height is relative, with fixed offset. In this case the height of the result--- will have the same fixed offset.-{-# INLINE pushRHAVL #-}-pushRHAVL :: HAVL e -> e -> HAVL e-pushRHAVL (HAVL t ht) e = case pushHR t ht e of UBT2(t_,ht_) -> HAVL t_ ht_-
− Data/Tree/AVL/Internals/HJoin.hs
@@ -1,329 +0,0 @@-{-# OPTIONS_GHC -fglasgow-exts #-}--------------------------------------------------------------------------------- |--- Module : Data.Tree.AVL.Internals.HJoin--- Copyright : (c) Adrian Hey 2004,2005--- License : BSD3------ Maintainer : http://homepages.nildram.co.uk/~ahey/em.png--- Stability : stable--- Portability : portable------ Functions for joining AVL trees of known height.-------------------------------------------------------------------------------module Data.Tree.AVL.Internals.HJoin- ( spliceH,joinH,joinH',- ) where--import Data.Tree.AVL.Types(AVL(..))-import Data.Tree.AVL.Push(pushL,pushR)-import Data.Tree.AVL.Internals.HPush(pushHL_,pushHR_)-import Data.Tree.AVL.Internals.DelUtils(popRN,popRZ,popRP,popLN,popLZ,popLP)--#if __GLASGOW_HASKELL__-import GHC.Base-#include "ghcdefs.h"-#else-#include "h98defs.h"-#endif---- | Join two trees of known height, returning an AVL tree.--- It's OK if heights are relative (I.E. if they share same fixed offset).------ Complexity: O(d), where d is the absolute difference in tree heights.-joinH'- :: AVL e -> UINT -> AVL e -> UINT -> AVL e-joinH' l hl r hr- = if hl LEQ hr then let d = SUBINT(hr,hl) in joinHL d l r- else let d = SUBINT(hl,hr) in joinHR d l r---- hr >= hl, join l to left subtree of r.--- Int argument is absolute difference in tree height, hr-hl (>=0)-{-# INLINE joinHL #-}-joinHL :: UINT -> AVL e -> AVL e -> AVL e-joinHL _ E r = r -- l was empty-joinHL d (N ll le lr) r = case popRN ll le lr of- UBT2(l_,e) -> case l_ of- E -> error "joinHL: Bug0" -- impossible if BF=-1- Z _ _ _ -> spliceL l_ e INCINT1(d) r -- hl2=hl-1- _ -> spliceL l_ e d r -- hl2=hl-joinHL d (Z ll le lr) r = case popRZ ll le lr of- UBT2(l_,e) -> case l_ of- E -> e `pushL` r -- l had only one element- _ -> spliceL l_ e d r -- hl2=hl-joinHL d (P ll le lr) r = case popRP ll le lr of- UBT2(l_,e) -> case l_ of- E -> error "joinHL: Bug1" -- impossible if BF=+1- Z _ _ _ -> spliceL l_ e INCINT1(d) r -- hl2=hl-1- _ -> spliceL l_ e d r -- hl2=hl----- hl >= hr, join r to right subtree of l.--- Int argument is absolute difference in tree height, hl-hr (>=0)-{-# INLINE joinHR #-}-joinHR :: UINT -> AVL e -> AVL e -> AVL e-joinHR _ l E = l -- r was empty-joinHR d l (N rl re rr) = case popLN rl re rr of- UBT2(e,r_) -> case r_ of- E -> error "joinHR: Bug0" -- impossible if BF=-1- Z _ _ _ -> spliceR r_ e INCINT1(d) l -- hr2=hr-1- _ -> spliceR r_ e d l -- hr2=hr-joinHR d l (Z rl re rr) = case popLZ rl re rr of- UBT2(e,r_) -> case r_ of- E -> l `pushR` e -- r had only one element- _ -> spliceR r_ e d l -- hr2=hr-joinHR d l (P rl re rr) = case popLP rl re rr of- UBT2(e,r_) -> case r_ of- E -> error "joinHL: Bug1" -- impossible if BF=+1- Z _ _ _ -> spliceR r_ e INCINT1(d) l -- hr2=hr-1- _ -> spliceR r_ e d l -- hr2=hr---------------------------------------------------------------------------------------------------- joinH' Ends Here ------------------------------------------------------------------------------------------------------ | Join two AVL trees of known height, returning an AVL tree of known height.--- It's OK if heights are relative (I.E. if they share same fixed offset).------ Complexity: O(d), where d is the absolute difference in tree heights.-joinH :: AVL e -> UINT -> AVL e -> UINT -> UBT2(AVL e,UINT)-joinH l hl r hr =- case COMPAREUINT hl hr of- -- hr > hl- LT -> case l of- E -> UBT2(r,hr)- N ll le lr -> case popRN ll le lr of- UBT2(l_,e) -> case l_ of- Z _ _ _ -> spliceHL l_ DECINT1(hl) e r hr -- dH=-1- _ -> spliceHL l_ hl e r hr -- dH= 0- Z ll le lr -> case popRZ ll le lr of- UBT2(l_,e) -> case l_ of- E -> pushHL_ l r hr -- l had only 1 element- _ -> spliceHL l_ hl e r hr -- dH=0- P ll le lr -> case popRP ll le lr of- UBT2(l_,e) -> case l_ of- Z _ _ _ -> spliceHL l_ DECINT1(hl) e r hr -- dH=-1- _ -> spliceHL l_ hl e r hr -- dH= 0- -- hr = hl- EQ -> case l of- E -> UBT2(l,hl) -- r must be empty too, don't use emptyAVL!- N ll le lr -> case popRN ll le lr of- UBT2(l_,e) -> case l_ of- Z _ _ _ -> spliceHL l_ DECINT1(hl) e r hr -- dH=-1- _ -> UBT2(Z l_ e r, INCINT1(hr)) -- dH= 0- Z ll le lr -> case popRZ ll le lr of- UBT2(l_,e) -> case l_ of- E -> pushHL_ l r hr -- l had only 1 element- _ -> UBT2(Z l_ e r, INCINT1(hr)) -- dH= 0- P ll le lr -> case popRP ll le lr of- UBT2(l_,e) -> case l_ of- Z _ _ _ -> spliceHL l_ DECINT1(hl) e r hr -- dH=-1- _ -> UBT2(Z l_ e r, INCINT1(hr)) -- dH= 0- -- hl > hr- GT -> case r of- E -> UBT2(l,hl)- N rl re rr -> case popLN rl re rr of- UBT2(e,r_) -> case r_ of- Z _ _ _ -> spliceHR l hl e r_ DECINT1(hr) -- dH=-1- _ -> spliceHR l hl e r_ hr -- dH= 0- Z rl re rr -> case popLZ rl re rr of- UBT2(e,r_) -> case r_ of- E -> pushHR_ l hl r -- r had only 1 element- _ -> spliceHR l hl e r_ hr -- dH=0- P rl re rr -> case popLP rl re rr of- UBT2(e,r_) -> case r_ of- Z _ _ _ -> spliceHR l hl e r_ DECINT1(hr) -- dH=-1- _ -> spliceHR l hl e r_ hr -- dH= 0----- | Splice two AVL trees of known height using the supplied bridging element.--- That is, the bridging element appears \"in the middle\" of the resulting AVL tree.--- The elements of the first tree argument are to the left of the bridging element and--- the elements of the second tree are to the right of the bridging element.------ This function does not require that the AVL heights are absolutely correct, only that--- the difference in supplied heights is equal to the difference in actual heights. So it's--- OK if the input heights both have the same unknown constant offset. (The output height--- will also have the same constant offset in this case.)------ Complexity: O(d), where d is the absolute difference in tree heights.-spliceH :: AVL e -> UINT -> e -> AVL e -> UINT -> UBT2(AVL e,UINT)--- You'd think inlining this function would make a significant difference to many functions--- (such as set operations), but it doesn't. It makes them marginally slower!!-spliceH l hl b r hr =- case COMPAREUINT hl hr of- LT -> spliceHL l hl b r hr- EQ -> UBT2(Z l b r, INCINT1(hl))- GT -> spliceHR l hl b r hr---- Splice two trees of known relative height where hr>hl, using the supplied bridging element,--- returning another tree of known relative height.-spliceHL :: AVL e -> UINT -> e -> AVL e -> UINT -> UBT2(AVL e,UINT)-spliceHL l hl b r hr = let d = SUBINT(hr,hl)- in if d EQL L(1) then UBT2(N l b r, INCINT1(hr))- else spliceHL_ hr d l b r---- Splice two trees of known relative height where hl>hr, using the supplied bridging element,--- returning another tree of known relative height.-spliceHR :: AVL e -> UINT -> e -> AVL e -> UINT -> UBT2(AVL e,UINT)-spliceHR l hl b r hr = let d = SUBINT(hl,hr)- in if d EQL L(1) then UBT2(P l b r, INCINT1(hl))- else spliceHR_ hl d l b r---- Splice two trees of known relative height where hr>hl+1, using the supplied bridging element,--- returning another tree of known relative height. d >= 2-{-# INLINE spliceHL_ #-}-spliceHL_ :: UINT -> UINT -> AVL e -> e -> AVL e -> UBT2(AVL e,UINT)-spliceHL_ _ _ _ _ E = error "spliceHL_: Bug0" -- impossible if hr>hl-spliceHL_ hr d l b (N rl re rr) = let r_ = spliceLN l b DECINT2(d) rl re rr- in r_ `seq` UBT2(r_,hr)-spliceHL_ hr d l b (Z rl re rr) = let r_ = spliceLZ l b DECINT1(d) rl re rr- in case r_ of- E -> error "spliceHL_: Bug1"- Z _ _ _ -> UBT2(r_, hr )- _ -> UBT2(r_,INCINT1(hr))-spliceHL_ hr d l b (P rl re rr) = let r_ = spliceLP l b DECINT1(d) rl re rr- in r_ `seq` UBT2(r_,hr)---- Splice two trees of known relative height where hl>hr+1, using the supplied bridging element,--- returning another tree of known relative height. d >= 2 !!-{-# INLINE spliceHR_ #-}-spliceHR_ :: UINT -> UINT -> AVL e -> e -> AVL e -> UBT2(AVL e,UINT)-spliceHR_ _ _ E _ _ = error "spliceHR_: Bug0" -- impossible if hl>hr-spliceHR_ hl d (N ll le lr) b r = let l_ = spliceRN r b DECINT1(d) ll le lr- in l_ `seq` UBT2(l_,hl)-spliceHR_ hl d (Z ll le lr) b r = let l_ = spliceRZ r b DECINT1(d) ll le lr- in case l_ of- E -> error "spliceHR_: Bug1"- Z _ _ _ -> UBT2(l_, hl )- _ -> UBT2(l_,INCINT1(hl))-spliceHR_ hl d (P ll le lr) b r = let l_ = spliceRP r b DECINT2(d) ll le lr- in l_ `seq` UBT2(l_,hl)--------------------------------------------------------------------------------------------------- spliceH Ends Here ------------------------------------------------------------------------------------------------------ hr >= hl, splice s to left subtree of r, using b as the bridge--- The Int argument is the absolute difference in tree height, hr-hl (>=0)-spliceL :: AVL e -> e -> UINT -> AVL e -> AVL e-spliceL s b L(0) r = Z s b r-spliceL s b L(1) r = N s b r-spliceL s b d (N rl re rr) = spliceLN s b DECINT2(d) rl re rr -- height diff of rl is two less-spliceL s b d (Z rl re rr) = spliceLZ s b DECINT1(d) rl re rr -- height diff of rl is one less-spliceL s b d (P rl re rr) = spliceLP s b DECINT1(d) rl re rr -- height diff of rl is one less-spliceL _ _ _ E = error "spliceL: Bug0" -- r can't be empty---- Splice into left subtree of (N l e r), height cannot change as a result of this-spliceLN :: AVL e -> e -> UINT -> AVL e -> e -> AVL e -> AVL e-spliceLN s b L(0) l e r = Z (Z s b l) e r -- dH=0-spliceLN s b L(1) l e r = Z (N s b l) e r -- dH=0-spliceLN s b d (N ll le lr) e r = let l_ = spliceLN s b DECINT2(d) ll le lr in l_ `seq` N l_ e r-spliceLN s b d (Z ll le lr) e r = let l_ = spliceLZ s b DECINT1(d) ll le lr- in case l_ of- Z _ _ _ -> N l_ e r -- dH=0- P _ _ _ -> Z l_ e r -- dH=0- _ -> error "spliceLN: Bug0" -- impossible-spliceLN s b d (P ll le lr) e r = let l_ = spliceLP s b DECINT1(d) ll le lr in l_ `seq` N l_ e r-spliceLN _ _ _ E _ _ = error "spliceLN: Bug1" -- impossible---- Splice into left subtree of (Z l e r), Z->P if dH=1, Z->Z if dH=0-spliceLZ :: AVL e -> e -> UINT -> AVL e -> e -> AVL e -> AVL e-spliceLZ s b L(1) l e r = P (N s b l) e r -- Z->P, dH=1-spliceLZ s b d (N ll le lr) e r = let l_ = spliceLN s b DECINT2(d) ll le lr in l_ `seq` Z l_ e r -- Z->Z, dH=0-spliceLZ s b d (Z ll le lr) e r = let l_ = spliceLZ s b DECINT1(d) ll le lr- in case l_ of- Z _ _ _ -> Z l_ e r -- Z->Z, dH=0- P _ _ _ -> P l_ e r -- Z->P, dH=1- _ -> error "spliceLZ: Bug0" -- impossible-spliceLZ s b d (P ll le lr) e r = let l_ = spliceLP s b DECINT1(d) ll le lr in l_ `seq` Z l_ e r -- Z->Z, dH=0-spliceLZ _ _ _ E _ _ = error "spliceLZ: Bug1" -- impossible---- Splice into left subtree of (P l e r), height cannot change as a result of this-spliceLP :: AVL e -> e -> UINT -> AVL e -> e -> AVL e -> AVL e-spliceLP s b L(1) (N ll le lr) e r = Z (P s b ll) le (Z lr e r) -- dH=0-spliceLP s b L(1) (Z ll le lr) e r = Z (Z s b ll) le (Z lr e r) -- dH=0-spliceLP s b L(1) (P ll le lr) e r = Z (Z s b ll) le (N lr e r) -- dH=0-spliceLP s b d (N ll le lr) e r = let l_ = spliceLN s b DECINT2(d) ll le lr in l_ `seq` P l_ e r -- dH=0-spliceLP s b d (Z ll le lr) e r = spliceLPZ s b DECINT1(d) ll le lr e r -- dH=0-spliceLP s b d (P ll le lr) e r = let l_ = spliceLP s b DECINT1(d) ll le lr in l_ `seq` P l_ e r -- dH=0-spliceLP _ _ _ E _ _ = error "spliceLP: Bug0"---- Splice into left subtree of (P (Z ll le lr) e r)-{-# INLINE spliceLPZ #-}-spliceLPZ :: AVL e -> e -> UINT -> AVL e -> e -> AVL e -> e -> AVL e -> AVL e-spliceLPZ s b L(1) ll le lr e r = Z (N s b ll) le (Z lr e r) -- dH=0-spliceLPZ s b d (N lll lle llr) le lr e r = let ll_ = spliceLN s b DECINT2(d) lll lle llr -- dH=0- in ll_ `seq` P (Z ll_ le lr) e r-spliceLPZ s b d (Z lll lle llr) le lr e r = let ll_ = spliceLZ s b DECINT1(d) lll lle llr -- dH=0- in case ll_ of- Z _ _ _ -> P (Z ll_ le lr) e r -- dH=0- P _ _ _ -> Z ll_ le (Z lr e r) -- dH=0- _ -> error "spliceLPZ: Bug0" -- impossible-spliceLPZ s b d (P lll lle llr) le lr e r = let ll_ = spliceLP s b DECINT1(d) lll lle llr -- dH=0- in ll_ `seq` P (Z ll_ le lr) e r-spliceLPZ _ _ _ E _ _ _ _ = error "spliceLPZ: Bug1"--------------------------------------------------------------------------------------------------- spliceL Ends Here ------------------------------------------------------------------------------------------------------ hl >= hr, splice s to right subtree of l, using b as the bridge--- The Int argument is the absolute difference in tree height, hl-hr (>=0)-spliceR :: AVL e -> e -> UINT -> AVL e -> AVL e-spliceR s b L(0) l = Z l b s-spliceR s b L(1) l = P l b s-spliceR s b d (N ll le lr) = spliceRN s b DECINT1(d) ll le lr -- height diff of lr is one less-spliceR s b d (Z ll le lr) = spliceRZ s b DECINT1(d) ll le lr -- height diff of lr is one less-spliceR s b d (P ll le lr) = spliceRP s b DECINT2(d) ll le lr -- height diff of lr is two less-spliceR _ _ _ E = error "spliceR: Bug0" -- l can't be empty---- Splice into right subtree of (P l e r), height cannot change as a result of this-spliceRP :: AVL e -> e -> UINT -> AVL e -> e -> AVL e -> AVL e-spliceRP s b L(0) l e r = Z l e (Z r b s) -- dH=0-spliceRP s b L(1) l e r = Z l e (P r b s) -- dH=0-spliceRP s b d l e (N rl re rr) = let r_ = spliceRN s b DECINT1(d) rl re rr in r_ `seq` P l e r_-spliceRP s b d l e (Z rl re rr) = let r_ = spliceRZ s b DECINT1(d) rl re rr- in case r_ of- Z _ _ _ -> P l e r_ -- dH=0- N _ _ _ -> Z l e r_ -- dH=0- _ -> error "spliceRP: Bug0" -- impossible-spliceRP s b d l e (P rl re rr) = let r_ = spliceRP s b DECINT2(d) rl re rr in r_ `seq` P l e r_-spliceRP _ _ _ _ _ E = error "spliceRP: Bug1" -- impossible---- Splice into right subtree of (Z l e r), Z->N if dH=1, Z->Z if dH=0-spliceRZ :: AVL e -> e -> UINT -> AVL e -> e -> AVL e -> AVL e-spliceRZ s b L(1) l e r = N l e (P r b s) -- Z->N, dH=1-spliceRZ s b d l e (N rl re rr) = let r_ = spliceRN s b DECINT1(d) rl re rr in r_ `seq` Z l e r_ -- Z->Z, dH=0-spliceRZ s b d l e (Z rl re rr) = let r_ = spliceRZ s b DECINT1(d) rl re rr- in case r_ of- Z _ _ _ -> Z l e r_ -- Z->Z, dH=0- N _ _ _ -> N l e r_ -- Z->N, dH=1- _ -> error "spliceRZ: Bug0" -- impossible-spliceRZ s b d l e (P rl re rr) = let r_ = spliceRP s b DECINT2(d) rl re rr in r_ `seq` Z l e r_ -- Z->Z, dH=0-spliceRZ _ _ _ _ _ E = error "spliceRZ: Bug1" -- impossible---- Splice into right subtree of (N l e r), height cannot change as a result of this-spliceRN :: AVL e -> e -> UINT -> AVL e -> e -> AVL e -> AVL e-spliceRN s b L(1) l e (N rl re rr) = Z (P l e rl) re (Z rr b s) -- dH=0-spliceRN s b L(1) l e (Z rl re rr) = Z (Z l e rl) re (Z rr b s) -- dH=0-spliceRN s b L(1) l e (P rl re rr) = Z (Z l e rl) re (N rr b s) -- dH=0-spliceRN s b d l e (N rl re rr) = let r_ = spliceRN s b DECINT1(d) rl re rr in r_ `seq` N l e r_ -- dH=0-spliceRN s b d l e (Z rl re rr) = spliceRNZ s b DECINT1(d) l e rl re rr -- dH=0-spliceRN s b d l e (P rl re rr) = let r_ = spliceRP s b DECINT2(d) rl re rr in r_ `seq` N l e r_ -- dH=0-spliceRN _ _ _ _ _ E = error "spliceRN: Bug0"---- Splice into right subtree of (N l e (Z rl re rr))-{-# INLINE spliceRNZ #-}-spliceRNZ :: AVL e -> e -> UINT -> AVL e -> e -> AVL e -> e -> AVL e -> AVL e-spliceRNZ s b L(1) l e rl re rr = Z (Z l e rl) re (P rr b s) -- dH=0-spliceRNZ s b d l e rl re (N rrl rre rrr) = let rr_ = spliceRN s b DECINT1(d) rrl rre rrr- in rr_ `seq` N l e (Z rl re rr_) -- dH=0-spliceRNZ s b d l e rl re (Z rrl rre rrr) = let rr_ = spliceRZ s b DECINT1(d) rrl rre rrr -- dH=0- in case rr_ of- Z _ _ _ -> N l e (Z rl re rr_) -- dH=0- N _ _ _ -> Z (Z l e rl) re rr_ -- dH=0- _ -> error "spliceRNZ: Bug0" -- impossible-spliceRNZ s b d l e rl re (P rrl rre rrr) = let rr_ = spliceRP s b DECINT2(d) rrl rre rrr -- dH=0- in rr_ `seq` N l e (Z rl re rr_)-spliceRNZ _ _ _ _ _ _ _ E = error "spliceRNZ: Bug1"--------------------------------------------------------------------------------------------------- spliceR Ends Here --------------------------------------------------------------------------------------------------
− Data/Tree/AVL/Internals/HPush.hs
@@ -1,189 +0,0 @@-{-# OPTIONS_GHC -fglasgow-exts #-}--------------------------------------------------------------------------------- |--- Module : Data.Tree.AVL.Internals.HPush--- Copyright : (c) Adrian Hey 2004,2005--- License : BSD3------ Maintainer : http://homepages.nildram.co.uk/~ahey/em.png--- Stability : stable--- Portability : portable------ Functions for pushing elements into trees of known height.-------------------------------------------------------------------------------module Data.Tree.AVL.Internals.HPush- (pushHL,pushHR,pushHL_,pushHR_,- ) where--import Data.Tree.AVL.Types(AVL(..))--#ifdef __GLASGOW_HASKELL__-import GHC.Base-#include "ghcdefs.h"-#else-#include "h98defs.h"-#endif---- | A version of 'pushL' for an AVL tree of known height. Returns an AVL tree of known height.--- It's OK if height is relative, with fixed offset. In this case the height of the result--- will have the same fixed offset.-{-# INLINE pushHL #-}-pushHL :: e -> AVL e -> UINT -> UBT2(AVL e,UINT)-pushHL e t h = pushHL_ (Z E e E) t h---- | A version of 'pushR' for an AVL tree of known height. Returns an AVL tree of known height.--- It's OK if height is relative, with fixed offset. In this case the height of the result--- will have the same fixed offset.-{-# INLINE pushHR #-}-pushHR :: AVL e -> UINT -> e -> UBT2(AVL e,UINT)-pushHR t h e = pushHR_ t h (Z E e E)---- | Push a singleton tree (first arg) in the leftmost position of an AVL tree of known height,--- returning an AVL tree of known height. It's OK if height is relative, with fixed offset.--- In this case the height of the result will have the same fixed offset.------ Complexity: O(log n)-pushHL_ :: AVL e -> AVL e -> UINT -> UBT2(AVL e,UINT)-pushHL_ t0 t h = case t of- E -> UBT2(t0, INCINT1(h)) -- Relative Heights- N l e r -> let t_ = putNL l e r in t_ `seq` UBT2(t_,h)- P l e r -> let t_ = putPL l e r in t_ `seq` UBT2(t_,h)- Z l e r -> let t_ = putZL l e r- in case t_ of- Z _ _ _ -> UBT2(t_, h )- P _ _ _ -> UBT2(t_, INCINT1(h))- _ -> error "pushHL_: Bug0" -- impossible- where- ----------------------------- LEVEL 2 ---------------------------------- -- putNL, putZL, putPL --- ------------------------------------------------------------------------- -- (putNL l e r): Put in L subtree of (N l e r), BF=-1 (Never requires rebalancing) , (never returns P)- putNL E e r = Z t0 e r -- L subtree empty, H:0->1, parent BF:-1-> 0- putNL (N ll le lr) e r = let l' = putNL ll le lr -- L subtree BF<>0, H:h->h, parent BF:-1->-1- in l' `seq` N l' e r- putNL (P ll le lr) e r = let l' = putPL ll le lr -- L subtree BF<>0, H:h->h, parent BF:-1->-1- in l' `seq` N l' e r- putNL (Z ll le lr) e r = let l' = putZL ll le lr -- L subtree BF= 0, so need to look for changes- in case l' of- Z _ _ _ -> N l' e r -- L subtree BF:0-> 0, H:h->h , parent BF:-1->-1- P _ _ _ -> Z l' e r -- L subtree BF:0->+1, H:h->h+1, parent BF:-1-> 0- _ -> error "pushHL_: Bug1" -- impossible-- -- (putZL l e r): Put in L subtree of (Z l e r), BF= 0 (Never requires rebalancing) , (never returns N)- putZL E e r = P t0 e r -- L subtree H:0->1, parent BF: 0->+1- putZL (N ll le lr) e r = let l' = putNL ll le lr -- L subtree BF<>0, H:h->h, parent BF: 0-> 0- in l' `seq` Z l' e r- putZL (P ll le lr) e r = let l' = putPL ll le lr -- L subtree BF<>0, H:h->h, parent BF: 0-> 0- in l' `seq` Z l' e r- putZL (Z ll le lr) e r = let l' = putZL ll le lr -- L subtree BF= 0, so need to look for changes- in case l' of- Z _ _ _ -> Z l' e r -- L subtree BF: 0-> 0, H:h->h , parent BF: 0-> 0- N _ _ _ -> error "pushHL_: Bug2" -- impossible- _ -> P l' e r -- L subtree BF: 0->+1, H:h->h+1, parent BF: 0->+1-- -------- This case (PL) may need rebalancing if it goes to LEVEL 3 ----------- -- (putPL l e r): Put in L subtree of (P l e r), BF=+1 , (never returns N)- putPL E _ _ = error "pushHL_: Bug3" -- impossible if BF=+1- putPL (N ll le lr) e r = let l' = putNL ll le lr -- L subtree BF<>0, H:h->h, parent BF:+1->+1- in l' `seq` P l' e r- putPL (P ll le lr) e r = let l' = putPL ll le lr -- L subtree BF<>0, H:h->h, parent BF:+1->+1- in l' `seq` P l' e r- putPL (Z ll le lr) e r = putPLL ll le lr e r -- LL (never returns N)-- ----------------------------- LEVEL 3 ---------------------------------- -- putPLL --- ------------------------------------------------------------------------- -- (putPLL ll le lr e r): Put in LL subtree of (P (Z ll le lr) e r) , (never returns N)- {-# INLINE putPLL #-}- putPLL E le lr e r = Z t0 le (Z lr e r) -- r and lr must also be E, special CASE LL!!- putPLL (N lll lle llr) le lr e r = let ll' = putNL lll lle llr -- LL subtree BF<>0, H:h->h, so no change- in ll' `seq` P (Z ll' le lr) e r- putPLL (P lll lle llr) le lr e r = let ll' = putPL lll lle llr -- LL subtree BF<>0, H:h->h, so no change- in ll' `seq` P (Z ll' le lr) e r- putPLL (Z lll lle llr) le lr e r = let ll' = putZL lll lle llr -- LL subtree BF= 0, so need to look for changes- in case ll' of- Z _ _ _ -> P (Z ll' le lr) e r -- LL subtree BF: 0-> 0, H:h->h, so no change- N _ _ _ -> error "pushHL_: Bug4" -- impossible- _ -> Z ll' le (Z lr e r) -- LL subtree BF: 0->+1, H:h->h+1, parent BF:-1->-2, CASE LL !!--------------------------------------------------------------------------------------------------- pushHL_ Ends Here ------------------------------------------------------------------------------------------------------- | Push a singleton tree (third arg) in the rightmost position of an AVL tree of known height,--- returning an AVL tree of known height. It's OK if height is relative, with fixed offset.--- In this case the height of the result will have the same fixed offset.------ Complexity: O(log n)-pushHR_ :: AVL e -> UINT -> AVL e -> UBT2(AVL e,UINT)-pushHR_ t h t0 = case t of- E -> UBT2(t0, INCINT1(h)) -- Relative Heights- N l e r -> let t_ = putNR l e r in t_ `seq` UBT2(t_,h)- P l e r -> let t_ = putPR l e r in t_ `seq` UBT2(t_,h)- Z l e r -> let t_ = putZR l e r- in case t_ of- Z _ _ _ -> UBT2(t_, h )- N _ _ _ -> UBT2(t_, INCINT1(h))- _ -> error "pushHR_: Bug0" -- impossible- where- ----------------------------- LEVEL 2 ---------------------------------- -- putNR, putZR, putPR --- ------------------------------------------------------------------------- -- (putZR l e r): Put in R subtree of (Z l e r), BF= 0 (Never requires rebalancing) , (never returns P)- putZR l e E = N l e t0 -- R subtree H:0->1, parent BF: 0->-1- putZR l e (N rl re rr) = let r' = putNR rl re rr -- R subtree BF<>0, H:h->h, parent BF: 0-> 0- in r' `seq` Z l e r'- putZR l e (P rl re rr) = let r' = putPR rl re rr -- R subtree BF<>0, H:h->h, parent BF: 0-> 0- in r' `seq` Z l e r'- putZR l e (Z rl re rr) = let r' = putZR rl re rr -- R subtree BF= 0, so need to look for changes- in case r' of- Z _ _ _ -> Z l e r' -- R subtree BF: 0-> 0, H:h->h , parent BF: 0-> 0- N _ _ _ -> N l e r' -- R subtree BF: 0->-1, H:h->h+1, parent BF: 0->-1- _ -> error "pushHR_: Bug1" -- impossible-- -- (putPR l e r): Put in R subtree of (P l e r), BF=+1 (Never requires rebalancing) , (never returns N)- putPR l e E = Z l e t0 -- R subtree empty, H:0->1, parent BF:+1-> 0- putPR l e (N rl re rr) = let r' = putNR rl re rr -- R subtree BF<>0, H:h->h, parent BF:+1->+1- in r' `seq` P l e r'- putPR l e (P rl re rr) = let r' = putPR rl re rr -- R subtree BF<>0, H:h->h, parent BF:+1->+1- in r' `seq` P l e r'- putPR l e (Z rl re rr) = let r' = putZR rl re rr -- R subtree BF= 0, so need to look for changes- in case r' of- Z _ _ _ -> P l e r' -- R subtree BF:0-> 0, H:h->h , parent BF:+1->+1- N _ _ _ -> Z l e r' -- R subtree BF:0->-1, H:h->h+1, parent BF:+1-> 0- _ -> error "pushHR_: Bug2" -- impossible-- -------- This case (NR) may need rebalancing if it goes to LEVEL 3 ----------- -- (putNR l e r): Put in R subtree of (N l e r), BF=-1 , (never returns P)- putNR _ _ E = error "pushHR_: Bug3" -- impossible if BF=-1- putNR l e (N rl re rr) = let r' = putNR rl re rr -- R subtree BF<>0, H:h->h, parent BF:-1->-1- in r' `seq` N l e r'- putNR l e (P rl re rr) = let r' = putPR rl re rr -- R subtree BF<>0, H:h->h, parent BF:-1->-1- in r' `seq` N l e r'- putNR l e (Z rl re rr) = putNRR l e rl re rr -- RR (never returns P)-- ----------------------------- LEVEL 3 ---------------------------------- -- putNRR --- ------------------------------------------------------------------------- -- (putNRR l e rl re rr): Put in RR subtree of (N l e (Z rl re rr)) , (never returns P)- {-# INLINE putNRR #-}- putNRR l e rl re E = Z (Z l e rl) re t0 -- l and rl must also be E, special CASE RR!!- putNRR l e rl re (N rrl rre rrr) = let rr' = putNR rrl rre rrr -- RR subtree BF<>0, H:h->h, so no change- in rr' `seq` N l e (Z rl re rr')- putNRR l e rl re (P rrl rre rrr) = let rr' = putPR rrl rre rrr -- RR subtree BF<>0, H:h->h, so no change- in rr' `seq` N l e (Z rl re rr')- putNRR l e rl re (Z rrl rre rrr) = let rr' = putZR rrl rre rrr -- RR subtree BF= 0, so need to look for changes- in case rr' of- Z _ _ _ -> N l e (Z rl re rr') -- RR subtree BF: 0-> 0, H:h->h, so no change- N _ _ _ -> Z (Z l e rl) re rr' -- RR subtree BF: 0->-1, H:h->h+1, parent BF:-1->-2, CASE RR !!- _ -> error "pushHR_: Bug4" -- impossible--------------------------------------------------------------------------------------------------- pushHR_ Ends Here ---------------------------------------------------------------------------------------------------
− Data/Tree/AVL/Internals/HSet.hs
@@ -1,994 +0,0 @@-{-# OPTIONS_GHC -fglasgow-exts #-}--------------------------------------------------------------------------------- |--- Module : Data.Tree.AVL.Internals.HSet--- Copyright : (c) Adrian Hey 2004,2005--- License : BSD3------ Maintainer : http://homepages.nildram.co.uk/~ahey/em.png--- Stability : stable--- Portability : portable------ Set primitives on AVL trees with (height information supplied where needed).--- All the functions in this module use essentially the same symetric \"Divide and Conquer\" algorithm.-------------------------------------------------------------------------------module Data.Tree.AVL.Internals.HSet- (-- * Union primitives.- unionH,unionMaybeH,disjointUnionH,-- -- * Intersection primitives.- intersectionH,intersectionMaybeH,-- -- * Difference primitives.- differenceH,differenceMaybeH,symDifferenceH,-- -- * Venn primitives- vennH,vennMaybeH,- ) where--import Data.Tree.AVL.Types(AVL(..))-import Data.Tree.AVL.Internals.HJoin(spliceH,joinH)--import Data.COrdering--#ifdef __GLASGOW_HASKELL__-import GHC.Base-#include "ghcdefs.h"-#else-#include "h98defs.h"-#endif---- | Uses the supplied combining comparison to evaluate the union of two sets represented as--- sorted AVL trees of known height. Whenever the combining comparison is applied, the first--- comparison argument is an element of the first tree and the second comparison argument is--- an element of the second tree.------ Complexity: Not sure, but I\'d appreciate it if someone could figure it out.--- (Faster than Hedge union from Data.Set at any rate).-unionH :: (e -> e -> COrdering e) -> AVL e -> UINT -> AVL e -> UINT -> UBT2(AVL e,UINT)-unionH c = u where- -- u :: AVL e -> UINT -> AVL e -> UINT -> UBT2(AVL e,UINT)- u E _ t1 h1 = UBT2(t1,h1)- u t0 h0 E _ = UBT2(t0,h0)- u (N l0 e0 r0) h0 (N l1 e1 r1) h1 = u_ l0 DECINT2(h0) e0 r0 DECINT1(h0) l1 DECINT2(h1) e1 r1 DECINT1(h1)- u (N l0 e0 r0) h0 (Z l1 e1 r1) h1 = u_ l0 DECINT2(h0) e0 r0 DECINT1(h0) l1 DECINT1(h1) e1 r1 DECINT1(h1)- u (N l0 e0 r0) h0 (P l1 e1 r1) h1 = u_ l0 DECINT2(h0) e0 r0 DECINT1(h0) l1 DECINT1(h1) e1 r1 DECINT2(h1)- u (Z l0 e0 r0) h0 (N l1 e1 r1) h1 = u_ l0 DECINT1(h0) e0 r0 DECINT1(h0) l1 DECINT2(h1) e1 r1 DECINT1(h1)- u (Z l0 e0 r0) h0 (Z l1 e1 r1) h1 = u_ l0 DECINT1(h0) e0 r0 DECINT1(h0) l1 DECINT1(h1) e1 r1 DECINT1(h1)- u (Z l0 e0 r0) h0 (P l1 e1 r1) h1 = u_ l0 DECINT1(h0) e0 r0 DECINT1(h0) l1 DECINT1(h1) e1 r1 DECINT2(h1)- u (P l0 e0 r0) h0 (N l1 e1 r1) h1 = u_ l0 DECINT1(h0) e0 r0 DECINT2(h0) l1 DECINT2(h1) e1 r1 DECINT1(h1)- u (P l0 e0 r0) h0 (Z l1 e1 r1) h1 = u_ l0 DECINT1(h0) e0 r0 DECINT2(h0) l1 DECINT1(h1) e1 r1 DECINT1(h1)- u (P l0 e0 r0) h0 (P l1 e1 r1) h1 = u_ l0 DECINT1(h0) e0 r0 DECINT2(h0) l1 DECINT1(h1) e1 r1 DECINT2(h1)- u_ l0 hl0 e0 r0 hr0 l1 hl1 e1 r1 hr1 =- case c e0 e1 of- -- e0 < e1, so (l0 < e0 < e1) & (e0 < e1 < r1)- Lt -> case forkR r0 hr0 e1 of- UBT5(rl0,hrl0,e1_,rr0,hrr0) -> case forkL e0 l1 hl1 of -- (e0 < rl0 < e1) & (e0 < e1 < rr0)- UBT5(ll1,hll1,e0_,lr1,hlr1) -> -- (ll1 < e0 < e1) & (e0 < lr1 < e1)- -- (l0 + ll1) < e0 < (rl0 + lr1) < e1 < (rr0 + r1)- case u l0 hl0 ll1 hll1 of- UBT2(l,hl) -> case u rl0 hrl0 lr1 hlr1 of- UBT2(m,hm) -> case u rr0 hrr0 r1 hr1 of- UBT2(r,hr) -> case spliceH m hm e1_ r hr of- UBT2(t,ht) -> spliceH l hl e0_ t ht- -- e0 = e1- Eq e -> case u l0 hl0 l1 hl1 of- UBT2(l,hl) -> case u r0 hr0 r1 hr1 of- UBT2(r,hr) -> spliceH l hl e r hr- -- e1 < e0, so (l1 < e1 < e0) & (e1 < e0 < r0)- Gt -> case forkL e0 r1 hr1 of- UBT5(rl1,hrl1,e0_,rr1,hrr1) -> case forkR l0 hl0 e1 of -- (e1 < rl1 < e0) & (e1 < e0 < rr1)- UBT5(ll0,hll0,e1_,lr0,hlr0) -> -- (ll0 < e1 < e0) & (e1 < lr0 < e0)- -- (ll0 + l1) < e1 < (lr0 + rl1) < e0 < (r0 + rr1)- case u ll0 hll0 l1 hl1 of- UBT2(l,hl) -> case u lr0 hlr0 rl1 hrl1 of- UBT2(m,hm) -> case u r0 hr0 rr1 hrr1 of- UBT2(r,hr) -> case spliceH l hl e1_ m hm of- UBT2(t,ht) -> spliceH t ht e0_ r hr- -- We need 2 different versions of fork (L & R) to ensure that comparison arguments are used in- -- the right order (c e0 e1)- -- forkL :: e -> AVL e -> UINT -> UBT5(AVL e,UINT,e,AVL e,UINT)- forkL e0 t1 ht1 = forkL_ t1 ht1 where- forkL_ E _ = UBT5(E, L(0), e0, E, L(0))- forkL_ (N l e r) h = forkL__ l DECINT2(h) e r DECINT1(h)- forkL_ (Z l e r) h = forkL__ l DECINT1(h) e r DECINT1(h)- forkL_ (P l e r) h = forkL__ l DECINT1(h) e r DECINT2(h)- forkL__ l hl e r hr = case c e0 e of- Lt -> case forkL_ l hl of- UBT5(l0,hl0,e0_,l1,hl1) -> case spliceH l1 hl1 e r hr of- UBT2(l1_,hl1_) -> UBT5(l0,hl0,e0_,l1_,hl1_)- Eq e0_ -> UBT5(l,hl,e0_,r,hr)- Gt -> case forkL_ r hr of- UBT5(l0,hl0,e0_,l1,hl1) -> case spliceH l hl e l0 hl0 of- UBT2(l0_,hl0_) -> UBT5(l0_,hl0_,e0_,l1,hl1)- -- forkR :: AVL e -> UINT -> e -> UBT5(AVL e,UINT,e,AVL e,UINT)- forkR t0 ht0 e1 = forkR_ t0 ht0 where- forkR_ E _ = UBT5(E, L(0), e1, E, L(0))- forkR_ (N l e r) h = forkR__ l DECINT2(h) e r DECINT1(h)- forkR_ (Z l e r) h = forkR__ l DECINT1(h) e r DECINT1(h)- forkR_ (P l e r) h = forkR__ l DECINT1(h) e r DECINT2(h)- forkR__ l hl e r hr = case c e e1 of- Lt -> case forkR_ r hr of- UBT5(l0,hl0,e1_,l1,hl1) -> case spliceH l hl e l0 hl0 of- UBT2(l0_,hl0_) -> UBT5(l0_,hl0_,e1_,l1,hl1)- Eq e1_ -> UBT5(l,hl,e1_,r,hr)- Gt -> case forkR_ l hl of- UBT5(l0,hl0,e1_,l1,hl1) -> case spliceH l1 hl1 e r hr of- UBT2(l1_,hl1_) -> UBT5(l0,hl0,e1_,l1_,hl1_)--------------------------------------------------------------------------------------------------- unionH Ends Here ------------------------------------------------------------------------------------------------------- | Similar to _unionH_, but the resulting tree does not include elements in cases where--- the supplied combining comparison returns @(Eq Nothing)@.------ Complexity: Not sure, but I\'d appreciate it if someone could figure it out.-unionMaybeH :: (e -> e -> COrdering (Maybe e)) -> AVL e -> UINT -> AVL e -> UINT -> UBT2(AVL e,UINT)-unionMaybeH c = u where- -- u :: AVL e -> UINT -> AVL e -> UINT -> UBT2(AVL e,UINT)- u E _ t1 h1 = UBT2(t1,h1)- u t0 h0 E _ = UBT2(t0,h0)- u (N l0 e0 r0) h0 (N l1 e1 r1) h1 = u_ l0 DECINT2(h0) e0 r0 DECINT1(h0) l1 DECINT2(h1) e1 r1 DECINT1(h1)- u (N l0 e0 r0) h0 (Z l1 e1 r1) h1 = u_ l0 DECINT2(h0) e0 r0 DECINT1(h0) l1 DECINT1(h1) e1 r1 DECINT1(h1)- u (N l0 e0 r0) h0 (P l1 e1 r1) h1 = u_ l0 DECINT2(h0) e0 r0 DECINT1(h0) l1 DECINT1(h1) e1 r1 DECINT2(h1)- u (Z l0 e0 r0) h0 (N l1 e1 r1) h1 = u_ l0 DECINT1(h0) e0 r0 DECINT1(h0) l1 DECINT2(h1) e1 r1 DECINT1(h1)- u (Z l0 e0 r0) h0 (Z l1 e1 r1) h1 = u_ l0 DECINT1(h0) e0 r0 DECINT1(h0) l1 DECINT1(h1) e1 r1 DECINT1(h1)- u (Z l0 e0 r0) h0 (P l1 e1 r1) h1 = u_ l0 DECINT1(h0) e0 r0 DECINT1(h0) l1 DECINT1(h1) e1 r1 DECINT2(h1)- u (P l0 e0 r0) h0 (N l1 e1 r1) h1 = u_ l0 DECINT1(h0) e0 r0 DECINT2(h0) l1 DECINT2(h1) e1 r1 DECINT1(h1)- u (P l0 e0 r0) h0 (Z l1 e1 r1) h1 = u_ l0 DECINT1(h0) e0 r0 DECINT2(h0) l1 DECINT1(h1) e1 r1 DECINT1(h1)- u (P l0 e0 r0) h0 (P l1 e1 r1) h1 = u_ l0 DECINT1(h0) e0 r0 DECINT2(h0) l1 DECINT1(h1) e1 r1 DECINT2(h1)- u_ l0 hl0 e0 r0 hr0 l1 hl1 e1 r1 hr1 =- case c e0 e1 of- -- e0 < e1, so (l0 < e0 < e1) & (e0 < e1 < r1)- Lt -> case forkR r0 hr0 e1 of- UBT5(rl0,hrl0,mbe1_,rr0,hrr0) -> case forkL e0 l1 hl1 of -- (e0 < rl0 < e1) & (e0 < e1 < rr0)- UBT5(ll1,hll1,mbe0_,lr1,hlr1) -> -- (ll1 < e0 < e1) & (e0 < lr1 < e1)- -- (l0 + ll1) < e0 < (rl0 + lr1) < e1 < (rr0 + r1)- case u l0 hl0 ll1 hll1 of- UBT2(l,hl) -> case u rl0 hrl0 lr1 hlr1 of- UBT2(m,hm) -> case u rr0 hrr0 r1 hr1 of- UBT2(r,hr) -> case (case mbe1_ of- Just e1_ -> spliceH m hm e1_ r hr- Nothing -> joinH m hm r hr- ) of- UBT2(t,ht) -> case mbe0_ of- Just e0_ -> spliceH l hl e0_ t ht- Nothing -> joinH l hl t ht- -- e0 = e1- Eq mbe -> case u l0 hl0 l1 hl1 of- UBT2(l,hl) -> case u r0 hr0 r1 hr1 of- UBT2(r,hr) -> case mbe of- Just e -> spliceH l hl e r hr- Nothing -> joinH l hl r hr- -- e1 < e0, so (l1 < e1 < e0) & (e1 < e0 < r0)- Gt -> case forkL e0 r1 hr1 of- UBT5(rl1,hrl1,mbe0_,rr1,hrr1) -> case forkR l0 hl0 e1 of -- (e1 < rl1 < e0) & (e1 < e0 < rr1)- UBT5(ll0,hll0,mbe1_,lr0,hlr0) -> -- (ll0 < e1 < e0) & (e1 < lr0 < e0)- -- (ll0 + l1) < e1 < (lr0 + rl1) < e0 < (r0 + rr1)- case u ll0 hll0 l1 hl1 of- UBT2(l,hl) -> case u lr0 hlr0 rl1 hrl1 of- UBT2(m,hm) -> case u r0 hr0 rr1 hrr1 of- UBT2(r,hr) -> case (case mbe1_ of- Just e1_ -> spliceH l hl e1_ m hm- Nothing -> joinH l hl m hm- ) of- UBT2(t,ht) -> case mbe0_ of- Just e0_ -> spliceH t ht e0_ r hr- Nothing -> joinH t ht r hr- -- We need 2 different versions of fork (L & R) to ensure that comparison arguments are used in- -- the right order (c e0 e1)- -- forkL :: e -> AVL e -> UINT -> UBT5(AVL e,UINT,Maybe e,AVL e,UINT)- forkL e0 t1 ht1 = forkL_ t1 ht1 where- forkL_ E _ = UBT5(E, L(0), Just e0, E, L(0))- forkL_ (N l e r) h = forkL__ l DECINT2(h) e r DECINT1(h)- forkL_ (Z l e r) h = forkL__ l DECINT1(h) e r DECINT1(h)- forkL_ (P l e r) h = forkL__ l DECINT1(h) e r DECINT2(h)- forkL__ l hl e r hr = case c e0 e of- Lt -> case forkL_ l hl of- UBT5(l0,hl0,mbe0_,l1,hl1) -> case spliceH l1 hl1 e r hr of- UBT2(l1_,hl1_) -> UBT5(l0,hl0,mbe0_,l1_,hl1_)- Eq mbe0_ -> UBT5(l,hl,mbe0_,r,hr)- Gt -> case forkL_ r hr of- UBT5(l0,hl0,mbe0_,l1,hl1) -> case spliceH l hl e l0 hl0 of- UBT2(l0_,hl0_) -> UBT5(l0_,hl0_,mbe0_,l1,hl1)- -- forkR :: AVL e -> UINT -> e -> UBT5(AVL e,UINT,Maybe e,AVL e,UINT)- forkR t0 ht0 e1 = forkR_ t0 ht0 where- forkR_ E _ = UBT5(E, L(0), Just e1, E, L(0))- forkR_ (N l e r) h = forkR__ l DECINT2(h) e r DECINT1(h)- forkR_ (Z l e r) h = forkR__ l DECINT1(h) e r DECINT1(h)- forkR_ (P l e r) h = forkR__ l DECINT1(h) e r DECINT2(h)- forkR__ l hl e r hr = case c e e1 of- Lt -> case forkR_ r hr of- UBT5(l0,hl0,mbe1_,l1,hl1) -> case spliceH l hl e l0 hl0 of- UBT2(l0_,hl0_) -> UBT5(l0_,hl0_,mbe1_,l1,hl1)- Eq mbe1_ -> UBT5(l,hl,mbe1_,r,hr)- Gt -> case forkR_ l hl of- UBT5(l0,hl0,mbe1_,l1,hl1) -> case spliceH l1 hl1 e r hr of- UBT2(l1_,hl1_) -> UBT5(l0,hl0,mbe1_,l1_,hl1_)------------------------------------------------------------------------------------------------ unionMaybeH Ends Here ------------------------------------------------------------------------------------------------------ | Uses the supplied comparison to evaluate the union of two /disjoint/ sets represented as--- sorted AVL trees of known height. This function raises an error if the two sets intersect.------ Complexity: Not sure, but I\'d appreciate it if someone could figure it out.--- (Faster than Hedge union from Data.Set at any rate).-disjointUnionH :: (e -> e -> Ordering) -> AVL e -> UINT -> AVL e -> UINT -> UBT2(AVL e,UINT)-disjointUnionH c = u where- -- u :: AVL e -> UINT -> AVL e -> UINT -> UBT2(AVL e,UINT)- u E _ t1 h1 = UBT2(t1,h1)- u t0 h0 E _ = UBT2(t0,h0)- u (N l0 e0 r0) h0 (N l1 e1 r1) h1 = u_ l0 DECINT2(h0) e0 r0 DECINT1(h0) l1 DECINT2(h1) e1 r1 DECINT1(h1)- u (N l0 e0 r0) h0 (Z l1 e1 r1) h1 = u_ l0 DECINT2(h0) e0 r0 DECINT1(h0) l1 DECINT1(h1) e1 r1 DECINT1(h1)- u (N l0 e0 r0) h0 (P l1 e1 r1) h1 = u_ l0 DECINT2(h0) e0 r0 DECINT1(h0) l1 DECINT1(h1) e1 r1 DECINT2(h1)- u (Z l0 e0 r0) h0 (N l1 e1 r1) h1 = u_ l0 DECINT1(h0) e0 r0 DECINT1(h0) l1 DECINT2(h1) e1 r1 DECINT1(h1)- u (Z l0 e0 r0) h0 (Z l1 e1 r1) h1 = u_ l0 DECINT1(h0) e0 r0 DECINT1(h0) l1 DECINT1(h1) e1 r1 DECINT1(h1)- u (Z l0 e0 r0) h0 (P l1 e1 r1) h1 = u_ l0 DECINT1(h0) e0 r0 DECINT1(h0) l1 DECINT1(h1) e1 r1 DECINT2(h1)- u (P l0 e0 r0) h0 (N l1 e1 r1) h1 = u_ l0 DECINT1(h0) e0 r0 DECINT2(h0) l1 DECINT2(h1) e1 r1 DECINT1(h1)- u (P l0 e0 r0) h0 (Z l1 e1 r1) h1 = u_ l0 DECINT1(h0) e0 r0 DECINT2(h0) l1 DECINT1(h1) e1 r1 DECINT1(h1)- u (P l0 e0 r0) h0 (P l1 e1 r1) h1 = u_ l0 DECINT1(h0) e0 r0 DECINT2(h0) l1 DECINT1(h1) e1 r1 DECINT2(h1)- u_ l0 hl0 e0 r0 hr0 l1 hl1 e1 r1 hr1 =- case c e0 e1 of- -- e0 < e1, so (l0 < e0 < e1) & (e0 < e1 < r1)- LT -> case fork e1 r0 hr0 of- UBT4(rl0,hrl0,rr0,hrr0) -> case fork e0 l1 hl1 of -- (e0 < rl0 < e1) & (e0 < e1 < rr0)- UBT4(ll1,hll1,lr1,hlr1) -> -- (ll1 < e0 < e1) & (e0 < lr1 < e1)- -- (l0 + ll1) < e0 < (rl0 + lr1) < e1 < (rr0 + r1)- case u l0 hl0 ll1 hll1 of- UBT2(l,hl) -> case u rl0 hrl0 lr1 hlr1 of- UBT2(m,hm) -> case u rr0 hrr0 r1 hr1 of- UBT2(r,hr) -> case spliceH m hm e1 r hr of- UBT2(t,ht) -> spliceH l hl e0 t ht- -- e0 = e1- EQ -> error "disjointUnionH: Trees intersect" `seq` UBT2(E,L(0))- -- e1 < e0, so (l1 < e1 < e0) & (e1 < e0 < r0)- GT -> case fork e0 r1 hr1 of- UBT4(rl1,hrl1,rr1,hrr1) -> case fork e1 l0 hl0 of -- (e1 < rl1 < e0) & (e1 < e0 < rr1)- UBT4(ll0,hll0,lr0,hlr0) -> -- (ll0 < e1 < e0) & (e1 < lr0 < e0)- -- (ll0 + l1) < e1 < (lr0 + rl1) < e0 < (r0 + rr1)- case u ll0 hll0 l1 hl1 of- UBT2(l,hl) -> case u lr0 hlr0 rl1 hrl1 of- UBT2(m,hm) -> case u r0 hr0 rr1 hrr1 of- UBT2(r,hr) -> case spliceH l hl e1 m hm of- UBT2(t,ht) -> spliceH t ht e0 r hr- -- fork :: e -> AVL e -> UINT -> UBT4(AVL e,UINT,AVL e,UINT)- fork e0 t1 ht1 = fork_ t1 ht1 where- fork_ E _ = UBT4(E, L(0), E, L(0))- fork_ (N l e r) h = fork__ l DECINT2(h) e r DECINT1(h)- fork_ (Z l e r) h = fork__ l DECINT1(h) e r DECINT1(h)- fork_ (P l e r) h = fork__ l DECINT1(h) e r DECINT2(h)- fork__ l hl e r hr = case c e0 e of- LT -> case fork_ l hl of- UBT4(l0,hl0,l1,hl1) -> case spliceH l1 hl1 e r hr of- UBT2(l1_,hl1_) -> UBT4(l0,hl0,l1_,hl1_)- EQ -> error "disjointUnionH: Trees intersect" `seq` UBT4(E, L(0), E, L(0))- GT -> case fork_ r hr of- UBT4(l0,hl0,l1,hl1) -> case spliceH l hl e l0 hl0 of- UBT2(l0_,hl0_) -> UBT4(l0_,hl0_,l1,hl1)----------------------------------------------------------------------------------------------- disjointUnionH Ends Here --------------------------------------------------------------------------------------------------- | Uses the supplied combining comparison to evaluate the intersection of two sets represented as--- sorted AVL trees. This function requires no height information at all for--- the two tree inputs. The absolute height of the resulting tree is returned also.------ Complexity: Not sure, but I\'d appreciate it if someone could figure it out.-intersectionH :: (a -> b -> COrdering c) -> AVL a -> AVL b -> UBT2(AVL c,UINT)-intersectionH cmp = i where- -- i :: AVL a -> AVL b -> UBT2(AVL c,UINT)- i E _ = UBT2(E,L(0))- i _ E = UBT2(E,L(0))- i (N l0 e0 r0) (N l1 e1 r1) = i_ l0 e0 r0 l1 e1 r1- i (N l0 e0 r0) (Z l1 e1 r1) = i_ l0 e0 r0 l1 e1 r1- i (N l0 e0 r0) (P l1 e1 r1) = i_ l0 e0 r0 l1 e1 r1- i (Z l0 e0 r0) (N l1 e1 r1) = i_ l0 e0 r0 l1 e1 r1- i (Z l0 e0 r0) (Z l1 e1 r1) = i_ l0 e0 r0 l1 e1 r1- i (Z l0 e0 r0) (P l1 e1 r1) = i_ l0 e0 r0 l1 e1 r1- i (P l0 e0 r0) (N l1 e1 r1) = i_ l0 e0 r0 l1 e1 r1- i (P l0 e0 r0) (Z l1 e1 r1) = i_ l0 e0 r0 l1 e1 r1- i (P l0 e0 r0) (P l1 e1 r1) = i_ l0 e0 r0 l1 e1 r1- i_ l0 e0 r0 l1 e1 r1 =- case cmp e0 e1 of- -- e0 < e1, so (l0 < e0 < e1) & (e0 < e1 < r1)- Lt -> case forkR r0 e1 of- UBT5(rl0,_,mbc1,rr0,_) -> case forkL e0 l1 of -- (e0 < rl0 < e1) & (e0 < e1 < rr0)- UBT5(ll1,_,mbc0,lr1,_) -> -- (ll1 < e0 < e1) & (e0 < lr1 < e1)- -- (l0 + ll1) < e0 < (rl0 + lr1) < e1 < (rr0 + r1)- case i rr0 r1 of- UBT2(r,hr) -> case i rl0 lr1 of- UBT2(m,hm) -> case i l0 ll1 of- UBT2(l,hl) -> case (case mbc1 of- Just c1 -> spliceH m hm c1 r hr- Nothing -> joinH m hm r hr- ) of- UBT2(t,ht) -> case mbc0 of- Just c0 -> spliceH l hl c0 t ht- Nothing -> joinH l hl t ht- -- e0 = e1- Eq c -> case i l0 l1 of- UBT2(l,hl) -> case i r0 r1 of- UBT2(r,hr) -> spliceH l hl c r hr- -- e1 < e0, so (l1 < e1 < e0) & (e1 < e0 < r0)- Gt -> case forkL e0 r1 of- UBT5(rl1,_,mbc0,rr1,_) -> case forkR l0 e1 of -- (e1 < rl1 < e0) & (e1 < e0 < rr1)- UBT5(ll0,_,mbc1,lr0,_) -> -- (ll0 < e1 < e0) & (e1 < lr0 < e0)- -- (ll0 + l1) < e1 < (lr0 + rl1) < e0 < (r0 + rr1)- case i r0 rr1 of- UBT2(r,hr) -> case i lr0 rl1 of- UBT2(m,hm) -> case i ll0 l1 of- UBT2(l,hl) -> case (case mbc0 of- Just c0 -> spliceH m hm c0 r hr- Nothing -> joinH m hm r hr- ) of- UBT2(t,ht) -> case mbc1 of- Just c1 -> spliceH l hl c1 t ht- Nothing -> joinH l hl t ht- -- We need 2 different versions of fork (L & R) to ensure that comparison arguments are used in- -- the right order (c e0 e1)- -- forkL :: a -> AVL b -> UBT5(AVL b,UINT,Maybe c,AVL b,UINT)- forkL e0 t1 = forkL_ t1 L(0) where- forkL_ E h = UBT5(E,h,Nothing,E,h) -- Relative heights!!- forkL_ (N l e r) h = forkL__ l DECINT2(h) e r DECINT1(h)- forkL_ (Z l e r) h = forkL__ l DECINT1(h) e r DECINT1(h)- forkL_ (P l e r) h = forkL__ l DECINT1(h) e r DECINT2(h)- forkL__ l hl e r hr = case cmp e0 e of- Lt -> case forkL_ l hl of- UBT5(l0,hl0,mbc0,l1,hl1) -> case spliceH l1 hl1 e r hr of- UBT2(l1_,hl1_) -> UBT5(l0,hl0,mbc0,l1_,hl1_)- Eq c0 -> UBT5(l,hl,Just c0,r,hr)- Gt -> case forkL_ r hr of- UBT5(l0,hl0,mbc0,l1,hl1) -> case spliceH l hl e l0 hl0 of- UBT2(l0_,hl0_) -> UBT5(l0_,hl0_,mbc0,l1,hl1)- -- forkR :: AVL a -> b -> UBT5(AVL a,UINT,Maybe c,AVL a,UINT)- forkR t0 e1 = forkR_ t0 L(0) where- forkR_ E h = UBT5(E,h,Nothing,E,h) -- Relative heights!!- forkR_ (N l e r) h = forkR__ l DECINT2(h) e r DECINT1(h)- forkR_ (Z l e r) h = forkR__ l DECINT1(h) e r DECINT1(h)- forkR_ (P l e r) h = forkR__ l DECINT1(h) e r DECINT2(h)- forkR__ l hl e r hr = case cmp e e1 of- Lt -> case forkR_ r hr of- UBT5(l0,hl0,mbc1,l1,hl1) -> case spliceH l hl e l0 hl0 of- UBT2(l0_,hl0_) -> UBT5(l0_,hl0_,mbc1,l1,hl1)- Eq c1 -> UBT5(l,hl,Just c1,r,hr)- Gt -> case forkR_ l hl of- UBT5(l0,hl0,mbc1,l1,hl1) -> case spliceH l1 hl1 e r hr of- UBT2(l1_,hl1_) -> UBT5(l0,hl0,mbc1,l1_,hl1_)----------------------------------------------------------------------------------------------- intersectionH Ends Here ---------------------------------------------------------------------------------------------------- | Similar to _intersectionH_, but the resulting tree does not include elements in cases where--- the supplied combining comparison returns @(Eq Nothing)@.------ Complexity: Not sure, but I\'d appreciate it if someone could figure it out.-intersectionMaybeH :: (a -> b -> COrdering (Maybe c)) -> AVL a -> AVL b -> UBT2(AVL c,UINT)-intersectionMaybeH comp = i where- -- i :: AVL a -> AVL b -> UBT2(AVL c,UINT)- i E _ = UBT2(E,L(0))- i _ E = UBT2(E,L(0))- i (N l0 e0 r0) (N l1 e1 r1) = i_ l0 e0 r0 l1 e1 r1- i (N l0 e0 r0) (Z l1 e1 r1) = i_ l0 e0 r0 l1 e1 r1- i (N l0 e0 r0) (P l1 e1 r1) = i_ l0 e0 r0 l1 e1 r1- i (Z l0 e0 r0) (N l1 e1 r1) = i_ l0 e0 r0 l1 e1 r1- i (Z l0 e0 r0) (Z l1 e1 r1) = i_ l0 e0 r0 l1 e1 r1- i (Z l0 e0 r0) (P l1 e1 r1) = i_ l0 e0 r0 l1 e1 r1- i (P l0 e0 r0) (N l1 e1 r1) = i_ l0 e0 r0 l1 e1 r1- i (P l0 e0 r0) (Z l1 e1 r1) = i_ l0 e0 r0 l1 e1 r1- i (P l0 e0 r0) (P l1 e1 r1) = i_ l0 e0 r0 l1 e1 r1- i_ l0 e0 r0 l1 e1 r1 =- case comp e0 e1 of- -- e0 < e1, so (l0 < e0 < e1) & (e0 < e1 < r1)- Lt -> case forkR r0 e1 of- UBT5(rl0,_,mbc1,rr0,_) -> case forkL e0 l1 of -- (e0 < rl0 < e1) & (e0 < e1 < rr0)- UBT5(ll1,_,mbc0,lr1,_) -> -- (ll1 < e0 < e1) & (e0 < lr1 < e1)- -- (l0 + ll1) < e0 < (rl0 + lr1) < e1 < (rr0 + r1)- case i rr0 r1 of- UBT2(r,hr) -> case i rl0 lr1 of- UBT2(m,hm) -> case i l0 ll1 of- UBT2(l,hl) -> case (case mbc1 of- Just c1 -> spliceH m hm c1 r hr- Nothing -> joinH m hm r hr- ) of- UBT2(t,ht) -> case mbc0 of- Just c0 -> spliceH l hl c0 t ht- Nothing -> joinH l hl t ht- -- e0 = e1- Eq mbc -> case i l0 l1 of- UBT2(l,hl) -> case i r0 r1 of- UBT2(r,hr) -> case mbc of- Just c -> spliceH l hl c r hr- Nothing -> joinH l hl r hr- -- e1 < e0, so (l1 < e1 < e0) & (e1 < e0 < r0)- Gt -> case forkL e0 r1 of- UBT5(rl1,_,mbc0,rr1,_) -> case forkR l0 e1 of -- (e1 < rl1 < e0) & (e1 < e0 < rr1)- UBT5(ll0,_,mbc1,lr0,_) -> -- (ll0 < e1 < e0) & (e1 < lr0 < e0)- -- (ll0 + l1) < e1 < (lr0 + rl1) < e0 < (r0 + rr1)- case i r0 rr1 of- UBT2(r,hr) -> case i lr0 rl1 of- UBT2(m,hm) -> case i ll0 l1 of- UBT2(l,hl) -> case (case mbc0 of- Just c0 -> spliceH m hm c0 r hr- Nothing -> joinH m hm r hr- ) of- UBT2(t,ht) -> case mbc1 of- Just c1 -> spliceH l hl c1 t ht- Nothing -> joinH l hl t ht- -- We need 2 different versions of fork (L & R) to ensure that comparison arguments are used in- -- the right order (c e0 e1)- -- forkL :: a -> AVL b -> UBT5(AVL b,UINT,Maybe c,AVL b,UINT)- forkL e0 t1 = forkL_ t1 L(0) where- forkL_ E h = UBT5(E,h,Nothing,E,h) -- Relative heights!!- forkL_ (N l e r) h = forkL__ l DECINT2(h) e r DECINT1(h)- forkL_ (Z l e r) h = forkL__ l DECINT1(h) e r DECINT1(h)- forkL_ (P l e r) h = forkL__ l DECINT1(h) e r DECINT2(h)- forkL__ l hl e r hr = case comp e0 e of- Lt -> case forkL_ l hl of- UBT5(l0,hl0,mbc0,l1,hl1) -> case spliceH l1 hl1 e r hr of- UBT2(l1_,hl1_) -> UBT5(l0,hl0,mbc0,l1_,hl1_)- Eq mbc0_ -> UBT5(l,hl,mbc0_,r,hr)- Gt -> case forkL_ r hr of- UBT5(l0,hl0,mbc0,l1,hl1) -> case spliceH l hl e l0 hl0 of- UBT2(l0_,hl0_) -> UBT5(l0_,hl0_,mbc0,l1,hl1)- -- forkR :: AVL a -> b -> UBT5(AVL a,UINT,Maybe c,AVL a,UINT)- forkR t0 e1 = forkR_ t0 L(0) where- forkR_ E h = UBT5(E,h,Nothing,E,h) -- Relative heights!!- forkR_ (N l e r) h = forkR__ l DECINT2(h) e r DECINT1(h)- forkR_ (Z l e r) h = forkR__ l DECINT1(h) e r DECINT1(h)- forkR_ (P l e r) h = forkR__ l DECINT1(h) e r DECINT2(h)- forkR__ l hl e r hr = case comp e e1 of- Lt -> case forkR_ r hr of- UBT5(l0,hl0,mbc1,l1,hl1) -> case spliceH l hl e l0 hl0 of- UBT2(l0_,hl0_) -> UBT5(l0_,hl0_,mbc1,l1,hl1)- Eq mbc1_ -> UBT5(l,hl,mbc1_,r,hr)- Gt -> case forkR_ l hl of- UBT5(l0,hl0,mbc1,l1,hl1) -> case spliceH l1 hl1 e r hr of- UBT2(l1_,hl1_) -> UBT5(l0,hl0,mbc1,l1_,hl1_)--------------------------------------------------------------------------------------------- intersectionMaybeH Ends Here ------------------------------------------------------------------------------------------------- | Uses the supplied comparison to evaluate the difference between two sets represented as--- sorted AVL trees.------ N.B. This function works with relative heights for the first tree and needs no height--- information for the second tree, so it_s OK to initialise the height of the first to zero,--- rather than calculating the absolute height. However, if you do this the height of the resulting--- tree will be incorrect also (it will have the same fixed offset as the first tree).------ Complexity: Not sure, but I\'d appreciate it if someone could figure it out.-differenceH :: (a -> b -> Ordering) -> AVL a -> UINT -> AVL b -> UBT2(AVL a,UINT)-differenceH comp = d where- -- d :: AVL a -> UINT -> AVL b -> UBT2(AVL a,UINT)- d E h0 _ = UBT2(E ,h0) -- Relative heights!!- d t0 h0 E = UBT2(t0,h0)- d (N l0 e0 r0) h0 (N l1 e1 r1) = d_ l0 DECINT2(h0) e0 r0 DECINT1(h0) l1 e1 r1- d (N l0 e0 r0) h0 (Z l1 e1 r1) = d_ l0 DECINT2(h0) e0 r0 DECINT1(h0) l1 e1 r1- d (N l0 e0 r0) h0 (P l1 e1 r1) = d_ l0 DECINT2(h0) e0 r0 DECINT1(h0) l1 e1 r1- d (Z l0 e0 r0) h0 (N l1 e1 r1) = d_ l0 DECINT1(h0) e0 r0 DECINT1(h0) l1 e1 r1- d (Z l0 e0 r0) h0 (Z l1 e1 r1) = d_ l0 DECINT1(h0) e0 r0 DECINT1(h0) l1 e1 r1- d (Z l0 e0 r0) h0 (P l1 e1 r1) = d_ l0 DECINT1(h0) e0 r0 DECINT1(h0) l1 e1 r1- d (P l0 e0 r0) h0 (N l1 e1 r1) = d_ l0 DECINT1(h0) e0 r0 DECINT2(h0) l1 e1 r1- d (P l0 e0 r0) h0 (Z l1 e1 r1) = d_ l0 DECINT1(h0) e0 r0 DECINT2(h0) l1 e1 r1- d (P l0 e0 r0) h0 (P l1 e1 r1) = d_ l0 DECINT1(h0) e0 r0 DECINT2(h0) l1 e1 r1- d_ l0 hl0 e0 r0 hr0 l1 e1 r1 =- case comp e0 e1 of- -- e0 < e1, so (l0 < e0 < e1) & (e0 < e1 < r1)- LT -> case forkR r0 hr0 e1 of- UBT4(rl0,hrl0, rr0,hrr0) -> case forkL e0 l1 of -- (e0 < rl0 < e1) & (e0 < e1 < rr0)- UBT5(ll1,_ ,be0,lr1,_ ) -> -- (ll1 < e0 < e1) & (e0 < lr1 < e1)- -- (l0 + ll1) < e0 < (rl0 + lr1) < e1 < (rr0 + r1)- case d rr0 hrr0 r1 of -- right- UBT2(r,hr) -> case d rl0 hrl0 lr1 of -- middle- UBT2(m,hm) -> case d l0 hl0 ll1 of -- left- UBT2(l,hl) -> case joinH m hm r hr of -- join middle right- UBT2(y,hy) -> if be0- then spliceH l hl e0 y hy- else joinH l hl y hy- -- e0 = e1- EQ -> case d r0 hr0 r1 of -- right- UBT2(r,hr) -> case d l0 hl0 l1 of -- left- UBT2(l,hl) -> joinH l hl r hr- -- e1 < e0, so (l1 < e1 < e0) & (e1 < e0 < r0)- GT -> case forkL e0 r1 of- UBT5(rl1,_ ,be0,rr1,_ ) -> case forkR l0 hl0 e1 of -- (e1 < rl1 < e0) & (e1 < e0 < rr1)- UBT4(ll0,hll0, lr0,hlr0) -> -- (ll0 < e1 < e0) & (e1 < lr0 < e0)- -- (ll0 + l1) < e1 < (lr0 + rl1) < e0 < (r0 + rr1)- case d r0 hr0 rr1 of -- right- UBT2(r,hr) -> case d lr0 hlr0 rl1 of -- middle- UBT2(m,hm) -> case d ll0 hll0 l1 of -- left- UBT2(l,hl) -> case joinH l hl m hm of -- join left middle- UBT2(x,hx) -> if be0- then spliceH x hx e0 r hr- else joinH x hx r hr- -- We need 2 different versions of fork (L & R) to ensure that comparison arguments are used in- -- the right order (c e0 e1), and for other algorithmic reasons in this case.- -- N.B. forkL returns True if t1 does not contain e0 (I.E. If e0 is an element of the result).- -- forkL :: a -> AVL b -> UBT5(AVL b, UINT, Bool, AVL b, UINT)- forkL e0 t1 = forkL_ t1 L(0) where- forkL_ E h = UBT5(E,h,True,E,h) -- Relative heights!!- forkL_ (N l e r) h = forkL__ l DECINT2(h) e r DECINT1(h)- forkL_ (Z l e r) h = forkL__ l DECINT1(h) e r DECINT1(h)- forkL_ (P l e r) h = forkL__ l DECINT1(h) e r DECINT2(h)- forkL__ l hl e r hr = case comp e0 e of- LT -> case forkL_ l hl of- UBT5(x0,hx0,be0,x1,hx1) -> case spliceH x1 hx1 e r hr of- UBT2(x1_,hx1_) -> UBT5(x0,hx0,be0,x1_,hx1_)- EQ -> UBT5(l,hl,False,r,hr)- GT -> case forkL_ r hr of- UBT5(x0,hx0,be0,x1,hx1) -> case spliceH l hl e x0 hx0 of- UBT2(x0_,hx0_) -> UBT5(x0_,hx0_,be0,x1,hx1)- -- N.B. forkR t0, according to e1. Neither of the resulting forks will contain an element- -- which is "equal" to e1.- -- forkR :: AVL a -> UINT -> b -> UBT4(AVL a, UINT, AVL a, UINT)- forkR t0 ht0 e1 = forkR_ t0 ht0 where- forkR_ E h = UBT4(E,h,E,h) -- Relative heights!!- forkR_ (N l e r) h = forkR__ l DECINT2(h) e r DECINT1(h)- forkR_ (Z l e r) h = forkR__ l DECINT1(h) e r DECINT1(h)- forkR_ (P l e r) h = forkR__ l DECINT1(h) e r DECINT2(h)- forkR__ l hl e r hr = case comp e e1 of- LT -> case forkR_ r hr of- UBT4(x0,hx0,x1,hx1) -> case spliceH l hl e x0 hx0 of- UBT2(x0_,hx0_) -> UBT4(x0_,hx0_,x1,hx1)- EQ -> UBT4(l,hl,r,hr) -- e1 is dropped.- GT -> case forkR_ l hl of- UBT4(x0,hx0,x1,hx1) -> case spliceH x1 hx1 e r hr of- UBT2(x1_,hx1_) -> UBT4(x0,hx0,x1_,hx1_)------------------------------------------------------------------------------------------------ differenceH Ends Here ----------------------------------------------------------------------------------------------------- | Similar to _differenceH_, but the resulting tree also includes those elements a\_ for which the--- combining comparison returns @Eq (Just a\_)@.------ N.B. This function works with relative heights for the first tree and needs no height--- information for the second tree, so it_s OK to initialise the height of the first to zero,--- rather than calculating the absolute height. However, if you do this the height of the resulting--- tree will be incorrect also (it will have the same fixed offset as the first tree).------ Complexity: Not sure, but I\'d appreciate it if someone could figure it out.-differenceMaybeH :: (a -> b -> COrdering (Maybe a)) -> AVL a -> UINT -> AVL b -> UBT2(AVL a,UINT)-differenceMaybeH comp = d where- -- d :: AVL a -> UINT -> AVL b -> UBT2(AVL a,UINT)- d E h0 _ = UBT2(E ,h0) -- Relative heights!!- d t0 h0 E = UBT2(t0,h0)- d (N l0 e0 r0) h0 (N l1 e1 r1) = d_ l0 DECINT2(h0) e0 r0 DECINT1(h0) l1 e1 r1- d (N l0 e0 r0) h0 (Z l1 e1 r1) = d_ l0 DECINT2(h0) e0 r0 DECINT1(h0) l1 e1 r1- d (N l0 e0 r0) h0 (P l1 e1 r1) = d_ l0 DECINT2(h0) e0 r0 DECINT1(h0) l1 e1 r1- d (Z l0 e0 r0) h0 (N l1 e1 r1) = d_ l0 DECINT1(h0) e0 r0 DECINT1(h0) l1 e1 r1- d (Z l0 e0 r0) h0 (Z l1 e1 r1) = d_ l0 DECINT1(h0) e0 r0 DECINT1(h0) l1 e1 r1- d (Z l0 e0 r0) h0 (P l1 e1 r1) = d_ l0 DECINT1(h0) e0 r0 DECINT1(h0) l1 e1 r1- d (P l0 e0 r0) h0 (N l1 e1 r1) = d_ l0 DECINT1(h0) e0 r0 DECINT2(h0) l1 e1 r1- d (P l0 e0 r0) h0 (Z l1 e1 r1) = d_ l0 DECINT1(h0) e0 r0 DECINT2(h0) l1 e1 r1- d (P l0 e0 r0) h0 (P l1 e1 r1) = d_ l0 DECINT1(h0) e0 r0 DECINT2(h0) l1 e1 r1- d_ l0 hl0 e0 r0 hr0 l1 e1 r1 =- case comp e0 e1 of- -- e0 < e1, so (l0 < e0 < e1) & (e0 < e1 < r1)- Lt -> case forkR r0 hr0 e1 of- UBT5( rl0,hrl0,mbe1,rr0,hrr0) -> case forkL e0 l1 of -- (e0 < rl0 < e1) & (e0 < e1 < rr0)- UBT5(ll1,_ ,mbe0,lr1,_ ) -> -- (ll1 < e0 < e1) & (e0 < lr1 < e1)- -- (l0 + ll1) < e0 < (rl0 + lr1) < e1 < (rr0 + r1)- case d rr0 hrr0 r1 of -- right- UBT2(r,hr) -> case d rl0 hrl0 lr1 of -- middle- UBT2(m,hm) -> case d l0 hl0 ll1 of -- left- UBT2(l,hl) -> case (case mbe1 of- Just e1_ -> spliceH m hm e1_ r hr -- splice middle right with e1_- Nothing -> joinH m hm r hr) of -- join middle right- UBT2(y,hy) -> case mbe0 of- Just e0_ -> spliceH l hl e0_ y hy- Nothing -> joinH l hl y hy- -- e0 = e1- Eq mbe0 -> case d r0 hr0 r1 of -- right- UBT2(r,hr) -> case d l0 hl0 l1 of -- left- UBT2(l,hl) -> case mbe0 of- Just e0_ -> spliceH l hl e0_ r hr -- retain updated e0- Nothing -> joinH l hl r hr -- discard original e0- -- e1 < e0, so (l1 < e1 < e0) & (e1 < e0 < r0)- Gt -> case forkL e0 r1 of- UBT5( rl1,_ ,mbe0,rr1,_ ) -> case forkR l0 hl0 e1 of -- (e1 < rl1 < e0) & (e1 < e0 < rr1)- UBT5(ll0,hll0,mbe1,lr0,hlr0) -> -- (ll0 < e1 < e0) & (e1 < lr0 < e0)- -- (ll0 + l1) < e1 < (lr0 + rl1) < e0 < (r0 + rr1)- case d r0 hr0 rr1 of -- right- UBT2(r,hr) -> case d lr0 hlr0 rl1 of -- middle- UBT2(m,hm) -> case d ll0 hll0 l1 of -- left- UBT2(l,hl) -> case (case mbe1 of- Just e1_ -> spliceH l hl e1_ m hm -- splice left middle with e1_- Nothing -> joinH l hl m hm) of -- join left middle- UBT2(x,hx) -> case mbe0 of- Just e0_ -> spliceH x hx e0_ r hr- Nothing -> joinH x hx r hr- -- We need 2 different versions of fork (L & R) to ensure that comparison arguments are used in- -- the right order (c e0 e1), and for other algorithmic reasons in this case.- -- N.B. forkL returns (Just e0) if t1 does not contain e0 (I.E. If original e0 is an element of the result).- -- forkL :: a -> AVL b -> UBT5(AVL b, UINT, Maybe a, AVL b, UINT)- forkL e0 t1 = forkL_ t1 L(0) where- forkL_ E h = UBT5(E,h,Just e0,E,h) -- Relative heights!!- forkL_ (N l e r) h = forkL__ l DECINT2(h) e r DECINT1(h)- forkL_ (Z l e r) h = forkL__ l DECINT1(h) e r DECINT1(h)- forkL_ (P l e r) h = forkL__ l DECINT1(h) e r DECINT2(h)- forkL__ l hl e r hr = case comp e0 e of- Lt -> case forkL_ l hl of- UBT5(x0,hx0,mbe0,x1,hx1) -> case spliceH x1 hx1 e r hr of- UBT2(x1_,hx1_) -> UBT5(x0,hx0,mbe0,x1_,hx1_)- Eq mbe0 -> UBT5(l,hl,mbe0,r,hr)- Gt -> case forkL_ r hr of- UBT5(x0,hx0,mbe0,x1,hx1) -> case spliceH l hl e x0 hx0 of- UBT2(x0_,hx0_) -> UBT5(x0_,hx0_,mbe0,x1,hx1)- -- N.B. forkR t0, according to e1. Returns Nothing if t0 does not contain e1.- -- forkR :: AVL a -> UINT -> b -> UBT5(AVL a, UINT, Maybe a, AVL a, UINT)- forkR t0 ht0 e1 = forkR_ t0 ht0 where- forkR_ E h = UBT5(E,h,Nothing,E,h) -- Relative heights!!- forkR_ (N l e r) h = forkR__ l DECINT2(h) e r DECINT1(h)- forkR_ (Z l e r) h = forkR__ l DECINT1(h) e r DECINT1(h)- forkR_ (P l e r) h = forkR__ l DECINT1(h) e r DECINT2(h)- forkR__ l hl e r hr = case comp e e1 of- Lt -> case forkR_ r hr of- UBT5(x0,hx0,mbe1,x1,hx1) -> case spliceH l hl e x0 hx0 of- UBT2(x0_,hx0_) -> UBT5(x0_,hx0_,mbe1,x1,hx1)- Eq mbe1 -> UBT5(l,hl,mbe1,r,hr)- Gt -> case forkR_ l hl of- UBT5(x0,hx0,mbe1,x1,hx1) -> case spliceH x1 hx1 e r hr of- UBT2(x1_,hx1_) -> UBT5(x0,hx0,mbe1,x1_,hx1_)---------------------------------------------------------------------------------------------- differenceMaybeH Ends Here -------------------------------------------------------------------------------------------------- | The symmetric difference is the set of elements which occur in one set or the other but /not both/.------ Complexity: Not sure, but I\'d appreciate it if someone could figure it out.-symDifferenceH :: (e -> e -> Ordering) -> AVL e -> UINT -> AVL e -> UINT -> UBT2(AVL e,UINT)-symDifferenceH c = u where- -- u :: AVL e -> UINT -> AVL e -> UINT -> UBT2(AVL e,UINT)- u E _ t1 h1 = UBT2(t1,h1)- u t0 h0 E _ = UBT2(t0,h0)- u (N l0 e0 r0) h0 (N l1 e1 r1) h1 = u_ l0 DECINT2(h0) e0 r0 DECINT1(h0) l1 DECINT2(h1) e1 r1 DECINT1(h1)- u (N l0 e0 r0) h0 (Z l1 e1 r1) h1 = u_ l0 DECINT2(h0) e0 r0 DECINT1(h0) l1 DECINT1(h1) e1 r1 DECINT1(h1)- u (N l0 e0 r0) h0 (P l1 e1 r1) h1 = u_ l0 DECINT2(h0) e0 r0 DECINT1(h0) l1 DECINT1(h1) e1 r1 DECINT2(h1)- u (Z l0 e0 r0) h0 (N l1 e1 r1) h1 = u_ l0 DECINT1(h0) e0 r0 DECINT1(h0) l1 DECINT2(h1) e1 r1 DECINT1(h1)- u (Z l0 e0 r0) h0 (Z l1 e1 r1) h1 = u_ l0 DECINT1(h0) e0 r0 DECINT1(h0) l1 DECINT1(h1) e1 r1 DECINT1(h1)- u (Z l0 e0 r0) h0 (P l1 e1 r1) h1 = u_ l0 DECINT1(h0) e0 r0 DECINT1(h0) l1 DECINT1(h1) e1 r1 DECINT2(h1)- u (P l0 e0 r0) h0 (N l1 e1 r1) h1 = u_ l0 DECINT1(h0) e0 r0 DECINT2(h0) l1 DECINT2(h1) e1 r1 DECINT1(h1)- u (P l0 e0 r0) h0 (Z l1 e1 r1) h1 = u_ l0 DECINT1(h0) e0 r0 DECINT2(h0) l1 DECINT1(h1) e1 r1 DECINT1(h1)- u (P l0 e0 r0) h0 (P l1 e1 r1) h1 = u_ l0 DECINT1(h0) e0 r0 DECINT2(h0) l1 DECINT1(h1) e1 r1 DECINT2(h1)- u_ l0 hl0 e0 r0 hr0 l1 hl1 e1 r1 hr1 =- case c e0 e1 of- -- e0 < e1, so (l0 < e0 < e1) & (e0 < e1 < r1)- LT -> case fork e1 r0 hr0 of- UBT5(rl0,hrl0,be1,rr0,hrr0) -> case fork e0 l1 hl1 of -- (e0 < rl0 < e1) & (e0 < e1 < rr0)- UBT5(ll1,hll1,be0,lr1,hlr1) -> -- (ll1 < e0 < e1) & (e0 < lr1 < e1)- -- (l0 + ll1) < e0 < (rl0 + lr1) < e1 < (rr0 + r1)- case u l0 hl0 ll1 hll1 of- UBT2(l,hl) -> case u rl0 hrl0 lr1 hlr1 of- UBT2(m,hm) -> case u rr0 hrr0 r1 hr1 of- UBT2(r,hr) -> case (if be1 then spliceH m hm e1 r hr- else joinH m hm r hr- ) of- UBT2(t,ht) -> if be0 then spliceH l hl e0 t ht- else joinH l hl t ht- -- e0 = e1- EQ -> case u l0 hl0 l1 hl1 of- UBT2(l,hl) -> case u r0 hr0 r1 hr1 of- UBT2(r,hr) -> joinH l hl r hr- -- e1 < e0, so (l1 < e1 < e0) & (e1 < e0 < r0)- GT -> case fork e0 r1 hr1 of- UBT5(rl1,hrl1,be0,rr1,hrr1) -> case fork e1 l0 hl0 of -- (e1 < rl1 < e0) & (e1 < e0 < rr1)- UBT5(ll0,hll0,be1,lr0,hlr0) -> -- (ll0 < e1 < e0) & (e1 < lr0 < e0)- -- (ll0 + l1) < e1 < (lr0 + rl1) < e0 < (r0 + rr1)- case u ll0 hll0 l1 hl1 of- UBT2(l,hl) -> case u lr0 hlr0 rl1 hrl1 of- UBT2(m,hm) -> case u r0 hr0 rr1 hrr1 of- UBT2(r,hr) -> case (if be1 then spliceH l hl e1 m hm- else joinH l hl m hm- ) of- UBT2(t,ht) -> if be0 then spliceH t ht e0 r hr- else joinH t ht r hr- -- fork :: e -> AVL e -> UINT -> UBT5(AVL e,UINT,Bool,AVL e,UINT)- fork e0 t1 ht1 = fork_ t1 ht1 where- fork_ E _ = UBT5(E, L(0), True, E, L(0))- fork_ (N l e r) h = fork__ l DECINT2(h) e r DECINT1(h)- fork_ (Z l e r) h = fork__ l DECINT1(h) e r DECINT1(h)- fork_ (P l e r) h = fork__ l DECINT1(h) e r DECINT2(h)- fork__ l hl e r hr = case c e0 e of- LT -> case fork_ l hl of- UBT5(l0,hl0,be0,l1,hl1) -> case spliceH l1 hl1 e r hr of- UBT2(l1_,hl1_) -> UBT5(l0,hl0,be0,l1_,hl1_)- EQ -> UBT5(l,hl,False,r,hr)- GT -> case fork_ r hr of- UBT5(l0,hl0,be0,l1,hl1) -> case spliceH l hl e l0 hl0 of- UBT2(l0_,hl0_) -> UBT5(l0_,hl0_,be0,l1,hl1)------------------------------------------------------------------------------------------------ symDifferenceH Ends Here --------------------------------------------------------------------------------------------------- | Given two Sets @A@ and @B@ represented as sorted AVL trees, this function extracts--- the \'Venn diagram\' components @A-B@, @A.B@ and @B-A@.--- The two difference components are sorted AVL trees.--- The intersection component is prepended to the input List in ascending sorted in ascending order.--- The number of elements prepended is added to the corresponding Int argument (which may or may--- not be the List length).--- See also 'vennMaybeH'.------ Complexity: Not sure, but I\'d appreciate it if someone could figure it out.-vennH :: (a -> b -> COrdering c) -> [c] -> UINT -> AVL a -> UINT -> AVL b -> UINT -> UBT6(AVL a,UINT,[c],UINT,AVL b,UINT)-vennH cmp = v where- -- v :: [c] -> UINT -> AVL a -> UINT -> AVL b -> UINT -> UBT6(AVL a,UINT,[c],UINT,AVL b,UINT)- v cs cl E ha tb hb = UBT6(E ,ha,cs,cl,tb,hb)- v cs cl ta ha E hb = UBT6(ta,ha,cs,cl,E ,hb)- v cs cl (N la a ra) ha (N lb b rb) hb = v_ cs cl la DECINT2(ha) a ra DECINT1(ha) lb DECINT2(hb) b rb DECINT1(hb)- v cs cl (N la a ra) ha (Z lb b rb) hb = v_ cs cl la DECINT2(ha) a ra DECINT1(ha) lb DECINT1(hb) b rb DECINT1(hb)- v cs cl (N la a ra) ha (P lb b rb) hb = v_ cs cl la DECINT2(ha) a ra DECINT1(ha) lb DECINT1(hb) b rb DECINT2(hb)- v cs cl (Z la a ra) ha (N lb b rb) hb = v_ cs cl la DECINT1(ha) a ra DECINT1(ha) lb DECINT2(hb) b rb DECINT1(hb)- v cs cl (Z la a ra) ha (Z lb b rb) hb = v_ cs cl la DECINT1(ha) a ra DECINT1(ha) lb DECINT1(hb) b rb DECINT1(hb)- v cs cl (Z la a ra) ha (P lb b rb) hb = v_ cs cl la DECINT1(ha) a ra DECINT1(ha) lb DECINT1(hb) b rb DECINT2(hb)- v cs cl (P la a ra) ha (N lb b rb) hb = v_ cs cl la DECINT1(ha) a ra DECINT2(ha) lb DECINT2(hb) b rb DECINT1(hb)- v cs cl (P la a ra) ha (Z lb b rb) hb = v_ cs cl la DECINT1(ha) a ra DECINT2(ha) lb DECINT1(hb) b rb DECINT1(hb)- v cs cl (P la a ra) ha (P lb b rb) hb = v_ cs cl la DECINT1(ha) a ra DECINT2(ha) lb DECINT1(hb) b rb DECINT2(hb)- v_ cs cl la hla a ra hra lb hlb b rb hrb =- case cmp a b of- -- a < b, so (la < a < b) & (a < b < rb)- Lt -> case forka cmp a lb hlb of- UBT5(llb,hllb,mbca,rlb,hrlb) -> case forkb cmp b ra hra of- UBT5(lra,hlra,mbcb,rra,hrra) ->- -- (la + llb) < a < (lra + rlb) < b < (rra + rb)- case v cs cl rra hrra rb hrb of- UBT6(rab,hrab,cs0,cl0,rba,hrba) -> case (case mbcb of- Nothing -> case v cs0 cl0 lra hlra rlb hrlb of- UBT6(mab,hmab,cs1,cl1,mba,hmba) -> case spliceH mba hmba b rba hrba of- UBT2(mrba,hmrba) -> UBT6(mab,hmab,cs1,cl1,mrba,hmrba)- Just cb -> case v (cb:cs0) INCINT1(cl0) lra hlra rlb hrlb of- UBT6(mab,hmab,cs1,cl1,mba,hmba) -> case joinH mba hmba rba hrba of- UBT2(mrba,hmrba) -> UBT6(mab,hmab,cs1,cl1,mrba,hmrba)- ) of- UBT6(mab,hmab,cs1,cl1,mrba,hmrba) -> case joinH mab hmab rab hrab of- UBT2(mrab,hmrab) -> case (case mbca of- Nothing -> case v cs1 cl1 la hla llb hllb of- UBT6(lab,hlab,cs2,cl2,lba,hlba) -> case spliceH lab hlab a mrab hmrab of- UBT2(ab,hab) -> UBT6(ab,hab,cs2,cl2,lba,hlba)- Just ca -> case v (ca:cs1) INCINT1(cl1) la hla llb hllb of- UBT6(lab,hlab,cs2,cl2,lba,hlba) -> case joinH lab hlab mrab hmrab of- UBT2(ab,hab) -> UBT6(ab,hab,cs2,cl2,lba,hlba)- ) of- UBT6(ab,hab,cs2,cl2,lba,hlba) -> case joinH lba hlba mrba hmrba of- UBT2(ba,hba) -> UBT6(ab,hab,cs2,cl2,ba,hba)- -- a = b- Eq c -> case v cs cl ra hra rb hrb of- UBT6(rab,hrab,cs0,cl0,rba,hrba) -> case v (c:cs0) INCINT1(cl0) la hla lb hlb of- UBT6(lab,hlab,cs1,cl1,lba,hlba) -> case joinH lab hlab rab hrab of- UBT2(ab,hab) -> case joinH lba hlba rba hrba of- UBT2(ba,hba) -> UBT6(ab,hab,cs1,cl1,ba,hba)- -- b < a, so (lb < b < a) & (b < a < ra)- Gt -> case forka cmp a rb hrb of- UBT5(lrb,hlrb,mbca,rrb,hrrb) -> case forkb cmp b la hla of- UBT5(lla,hlla,mbcb,rla,hrla) ->- -- (lla + lb) < b < (rla + lrb) < a < (ra + rrb)- case v cs cl ra hra rrb hrrb of- UBT6(rab,hrab,cs0,cl0,rba,hrba) -> case (case mbca of- Nothing -> case v cs0 cl0 rla hrla lrb hlrb of- UBT6(mab,hmab,cs1,cl1,mba,hmba) -> case spliceH mab hmab a rab hrab of- UBT2(mrab,hmrab) -> UBT6(mrab,hmrab,cs1,cl1,mba,hmba)- Just ca -> case v (ca:cs0) INCINT1(cl0) rla hrla lrb hlrb of- UBT6(mab,hmab,cs1,cl1,mba,hmba) -> case joinH mab hmab rab hrab of- UBT2(mrab,hmrab) -> UBT6(mrab,hmrab,cs1,cl1,mba,hmba)- ) of- UBT6(mrab,hmrab,cs1,cl1,mba,hmba) -> case joinH mba hmba rba hrba of- UBT2(mrba,hmrba) -> case (case mbcb of- Nothing -> case v cs1 cl1 lla hlla lb hlb of- UBT6(lab,hlab,cs2,cl2,lba,hlba) -> case spliceH lba hlba b mrba hmrba of- UBT2(ba,hba) -> UBT6(lab,hlab,cs2,cl2,ba,hba)- Just cb -> case v (cb:cs1) INCINT1(cl1) lla hlla lb hlb of- UBT6(lab,hlab,cs2,cl2,lba,hlba) -> case joinH lba hlba mrba hmrba of- UBT2(ba,hba) -> UBT6(lab,hlab,cs2,cl2,ba,hba)- ) of- UBT6(lab,hlab,cs2,cl2,ba,hba) -> case joinH lab hlab mrab hmrab of- UBT2(ab,hab) -> UBT6(ab,hab,cs2,cl2,ba,hba)---------------------------------------------------------------------------------------------------- vennH Ends Here ------------------------------------------------------------------------------------------------------- | Similar to 'vennH', but intersection elements for which the combining comparison--- returns @('Eq' 'Nothing')@ are deleted from the intersection list.------ Complexity: Not sure, but I\'d appreciate it if someone could figure it out.-vennMaybeH :: (a -> b -> COrdering (Maybe c)) -> [c] -> UINT -> AVL a -> UINT -> AVL b -> UINT -> UBT6(AVL a,UINT,[c],UINT,AVL b,UINT)-vennMaybeH cmp = v where- -- v :: [c] -> UINT -> AVL a -> UINT -> AVL b -> UINT -> UBT6(AVL a,UINT,[c],UINT,AVL b,UINT)- v cs cl E ha tb hb = UBT6(E ,ha,cs,cl,tb,hb)- v cs cl ta ha E hb = UBT6(ta,ha,cs,cl,E ,hb)- v cs cl (N la a ra) ha (N lb b rb) hb = v_ cs cl la DECINT2(ha) a ra DECINT1(ha) lb DECINT2(hb) b rb DECINT1(hb)- v cs cl (N la a ra) ha (Z lb b rb) hb = v_ cs cl la DECINT2(ha) a ra DECINT1(ha) lb DECINT1(hb) b rb DECINT1(hb)- v cs cl (N la a ra) ha (P lb b rb) hb = v_ cs cl la DECINT2(ha) a ra DECINT1(ha) lb DECINT1(hb) b rb DECINT2(hb)- v cs cl (Z la a ra) ha (N lb b rb) hb = v_ cs cl la DECINT1(ha) a ra DECINT1(ha) lb DECINT2(hb) b rb DECINT1(hb)- v cs cl (Z la a ra) ha (Z lb b rb) hb = v_ cs cl la DECINT1(ha) a ra DECINT1(ha) lb DECINT1(hb) b rb DECINT1(hb)- v cs cl (Z la a ra) ha (P lb b rb) hb = v_ cs cl la DECINT1(ha) a ra DECINT1(ha) lb DECINT1(hb) b rb DECINT2(hb)- v cs cl (P la a ra) ha (N lb b rb) hb = v_ cs cl la DECINT1(ha) a ra DECINT2(ha) lb DECINT2(hb) b rb DECINT1(hb)- v cs cl (P la a ra) ha (Z lb b rb) hb = v_ cs cl la DECINT1(ha) a ra DECINT2(ha) lb DECINT1(hb) b rb DECINT1(hb)- v cs cl (P la a ra) ha (P lb b rb) hb = v_ cs cl la DECINT1(ha) a ra DECINT2(ha) lb DECINT1(hb) b rb DECINT2(hb)- v_ cs cl la hla a ra hra lb hlb b rb hrb =- case cmp a b of- -- a < b, so (la < a < b) & (a < b < rb)- Lt -> case forka cmp a lb hlb of- UBT5(llb,hllb,mbmbca,rlb,hrlb) -> case forkb cmp b ra hra of- UBT5(lra,hlra,mbmbcb,rra,hrra) ->- -- (la + llb) < a < (lra + rlb) < b < (rra + rb)- case v cs cl rra hrra rb hrb of- UBT6(rab,hrab,cs0,cl0,rba,hrba) -> case (case mbmbcb of- Nothing -> case v cs0 cl0 lra hlra rlb hrlb of- UBT6(mab,hmab,cs1,cl1,mba,hmba) -> case spliceH mba hmba b rba hrba of- UBT2(mrba,hmrba) -> UBT6(mab,hmab,cs1,cl1,mrba,hmrba)- Just mbcb -> case (case mbcb of- Nothing -> v cs0 cl0 lra hlra rlb hrlb- Just cb -> v (cb:cs0) INCINT1(cl0) lra hlra rlb hrlb- ) of- UBT6(mab,hmab,cs1,cl1,mba,hmba) -> case joinH mba hmba rba hrba of- UBT2(mrba,hmrba) -> UBT6(mab,hmab,cs1,cl1,mrba,hmrba)- ) of- UBT6(mab,hmab,cs1,cl1,mrba,hmrba) -> case joinH mab hmab rab hrab of- UBT2(mrab,hmrab) -> case (case mbmbca of- Nothing -> case v cs1 cl1 la hla llb hllb of- UBT6(lab,hlab,cs2,cl2,lba,hlba) -> case spliceH lab hlab a mrab hmrab of- UBT2(ab,hab) -> UBT6(ab,hab,cs2,cl2,lba,hlba)- Just mbca -> case (case mbca of- Nothing -> v cs1 cl1 la hla llb hllb- Just ca -> v (ca:cs1) INCINT1(cl1) la hla llb hllb- ) of- UBT6(lab,hlab,cs2,cl2,lba,hlba) -> case joinH lab hlab mrab hmrab of- UBT2(ab,hab) -> UBT6(ab,hab,cs2,cl2,lba,hlba)- ) of- UBT6(ab,hab,cs2,cl2,lba,hlba) -> case joinH lba hlba mrba hmrba of- UBT2(ba,hba) -> UBT6(ab,hab,cs2,cl2,ba,hba)- -- a = b- Eq mbc -> case v cs cl ra hra rb hrb of- UBT6(rab,hrab,cs0,cl0,rba,hrba) -> case (case mbc of- Nothing -> v cs0 cl0 la hla lb hlb- Just c -> v (c:cs0) INCINT1(cl0) la hla lb hlb- ) of- UBT6(lab,hlab,cs1,cl1,lba,hlba) -> case joinH lab hlab rab hrab of- UBT2(ab,hab) -> case joinH lba hlba rba hrba of- UBT2(ba,hba) -> UBT6(ab,hab,cs1,cl1,ba,hba)- -- b < a, so (lb < b < a) & (b < a < ra)- Gt -> case forka cmp a rb hrb of- UBT5(lrb,hlrb,mbmbca,rrb,hrrb) -> case forkb cmp b la hla of- UBT5(lla,hlla,mbmbcb,rla,hrla) ->- -- (lla + lb) < b < (rla + lrb) < a < (ra + rrb)- case v cs cl ra hra rrb hrrb of- UBT6(rab,hrab,cs0,cl0,rba,hrba) -> case (case mbmbca of- Nothing -> case v cs0 cl0 rla hrla lrb hlrb of- UBT6(mab,hmab,cs1,cl1,mba,hmba) -> case spliceH mab hmab a rab hrab of- UBT2(mrab,hmrab) -> UBT6(mrab,hmrab,cs1,cl1,mba,hmba)- Just mbca -> case (case mbca of- Nothing -> v cs0 cl0 rla hrla lrb hlrb- Just ca -> v (ca:cs0) INCINT1(cl0) rla hrla lrb hlrb- ) of- UBT6(mab,hmab,cs1,cl1,mba,hmba) -> case joinH mab hmab rab hrab of- UBT2(mrab,hmrab) -> UBT6(mrab,hmrab,cs1,cl1,mba,hmba)- ) of- UBT6(mrab,hmrab,cs1,cl1,mba,hmba) -> case joinH mba hmba rba hrba of- UBT2(mrba,hmrba) -> case (case mbmbcb of- Nothing -> case v cs1 cl1 lla hlla lb hlb of- UBT6(lab,hlab,cs2,cl2,lba,hlba) -> case spliceH lba hlba b mrba hmrba of- UBT2(ba,hba) -> UBT6(lab,hlab,cs2,cl2,ba,hba)- Just mbcb -> case (case mbcb of- Nothing -> v cs1 cl1 lla hlla lb hlb- Just cb -> v (cb:cs1) INCINT1(cl1) lla hlla lb hlb- ) of- UBT6(lab,hlab,cs2,cl2,lba,hlba) -> case joinH lba hlba mrba hmrba of- UBT2(ba,hba) -> UBT6(lab,hlab,cs2,cl2,ba,hba)- ) of- UBT6(lab,hlab,cs2,cl2,ba,hba) -> case joinH lab hlab mrab hmrab of- UBT2(ab,hab) -> UBT6(ab,hab,cs2,cl2,ba,hba)------------------------------------------------------------------------------------------------- vennMaybeH Ends Here ----------------------------------------------------------------------------------------------------- Common forks used by vennH,vennMaybeH--- We need 2 different versions of fork to ensure that comparison arguments are used in--- the right order (c a b)-forka :: (a -> b -> COrdering c) -> a -> AVL b -> UINT -> UBT5(AVL b,UINT,Maybe c,AVL b,UINT)-forka cmp a tb htb = f tb htb where- f E _ = UBT5(E,L(0),Nothing,E,L(0))- f n@(N _ b r) L(2) = case cmp a b of -- l must be E, r must be Z- Lt -> UBT5(E,L(0),Nothing,n,L(2))- Eq c -> UBT5(E,L(0),Just c ,r,L(1))- Gt -> case r of- Z _ br _ -> case cmp a br of -- l & r must be E- Lt -> UBT5(Z E b E,L(1),Nothing,r,L(1))- Eq c -> UBT5(Z E b E,L(1),Just c ,E,L(0))- Gt -> UBT5(n ,L(2),Nothing,E,L(0))- _ -> undefined `seq` UBT5(E,L(0),Nothing,E,L(0))- f (N l b r) h = f_ l DECINT2(h) b r DECINT1(h)- f z@(Z l b r) L(2) = case cmp a b of -- l & r must be Z- Lt -> case l of- Z _ bl _ -> case cmp a bl of -- l & r must be E- Lt -> UBT5(E,L(0),Nothing,z ,L(2))- Eq c -> UBT5(E,L(0),Just c ,N E b r,L(2))- Gt -> UBT5(l,L(1),Nothing,N E b r,L(2))- _ -> undefined `seq` UBT5(E,L(0),Nothing,E,L(0))- Eq c -> UBT5(l,L(1),Just c,r,L(1))- Gt -> case r of- Z _ br _ -> case cmp a br of -- l & r must be E- Lt -> UBT5(P l b E,L(2),Nothing,r,L(1))- Eq c -> UBT5(P l b E,L(2),Just c ,E,L(0))- Gt -> UBT5(z ,L(2),Nothing,E,L(0))- _ -> undefined `seq` UBT5(E,L(0),Nothing,E,L(0))- f z@(Z _ b _) L(1) = case cmp a b of -- l & r must be E- Lt -> UBT5(E,L(0),Nothing,z,L(1))- Eq c -> UBT5(E,L(0),Just c ,E,L(0))- Gt -> UBT5(z,L(1),Nothing,E,L(0))- f (Z l b r) h = f_ l DECINT1(h) b r DECINT1(h)- f p@(P l b _) L(2) = case cmp a b of -- l must be Z, r must be E- Lt -> case l of- Z _ bl _ -> case cmp a bl of -- l & r must be E- Lt -> UBT5(E,L(0),Nothing,p ,L(2))- Eq c -> UBT5(E,L(0),Just c ,Z E b E,L(1))- Gt -> UBT5(l,L(1),Nothing,Z E b E,L(1))- _ -> undefined `seq` UBT5(E,L(0),Nothing,E,L(0))- Eq c -> UBT5(l,L(1),Just c ,E,L(0))- Gt -> UBT5(p,L(2),Nothing,E,L(0))- f (P l b r) h = f_ l DECINT1(h) b r DECINT2(h)- f_ l hl b r hr = case cmp a b of- Lt -> case f l hl of- UBT5(ll,hll,mbc,lr,hlr) -> case spliceH lr hlr b r hr of- UBT2(r_,hr_) -> UBT5(ll,hll,mbc,r_,hr_)- Eq c -> UBT5(l,hl,Just c,r,hr)- Gt -> case f r hr of- UBT5(rl,hrl,mbc,rr,hrr) -> case spliceH l hl b rl hrl of- UBT2(l_,hl_) -> UBT5(l_,hl_,mbc,rr,hrr)---- This should be exactly the same as forka, but with the following swaps:--- * a <-> b, except is compare!--- * Lt <-> Gt (becasuse we didn't swap in compare)-forkb :: (a -> b -> COrdering c) -> b -> AVL a -> UINT -> UBT5(AVL a,UINT,Maybe c,AVL a,UINT)-forkb cmp b ta hta = f ta hta where- f E _ = UBT5(E,L(0),Nothing,E,L(0))- f n@(N _ a r) L(2) = case cmp a b of -- l must be E, r must be Z- Gt -> UBT5(E,L(0),Nothing,n,L(2))- Eq c -> UBT5(E,L(0),Just c ,r,L(1))- Lt -> case r of- Z _ ar _ -> case cmp ar b of -- l & r must be E- Gt -> UBT5(Z E a E,L(1),Nothing,r,L(1))- Eq c -> UBT5(Z E a E,L(1),Just c ,E,L(0))- Lt -> UBT5(n ,L(2),Nothing,E,L(0))- _ -> undefined `seq` UBT5(E,L(0),Nothing,E,L(0))- f (N l a r) h = f_ l DECINT2(h) a r DECINT1(h)- f z@(Z l a r) L(2) = case cmp a b of -- l & r must be Z- Gt -> case l of- Z _ al _ -> case cmp al b of -- l & r must be E- Gt -> UBT5(E,L(0),Nothing,z ,L(2))- Eq c -> UBT5(E,L(0),Just c ,N E a r,L(2))- Lt -> UBT5(l,L(1),Nothing,N E a r,L(2))- _ -> undefined `seq` UBT5(E,L(0),Nothing,E,L(0))- Eq c -> UBT5(l,L(1),Just c,r,L(1))- Lt -> case r of- Z _ ar _ -> case cmp ar b of -- l & r must be E- Gt -> UBT5(P l a E,L(2),Nothing,r,L(1))- Eq c -> UBT5(P l a E,L(2),Just c ,E,L(0))- Lt -> UBT5(z ,L(2),Nothing,E,L(0))- _ -> undefined `seq` UBT5(E,L(0),Nothing,E,L(0))- f z@(Z _ a _) L(1) = case cmp a b of -- l & r must be E- Gt -> UBT5(E,L(0),Nothing,z,L(1))- Eq c -> UBT5(E,L(0),Just c ,E,L(0))- Lt -> UBT5(z,L(1),Nothing,E,L(0))- f (Z l a r) h = f_ l DECINT1(h) a r DECINT1(h)- f p@(P l a _) L(2) = case cmp a b of -- l must be Z, r must be E- Gt -> case l of- Z _ al _ -> case cmp al b of -- l & r must be E- Gt -> UBT5(E,L(0),Nothing,p ,L(2))- Eq c -> UBT5(E,L(0),Just c ,Z E a E,L(1))- Lt -> UBT5(l,L(1),Nothing,Z E a E,L(1))- _ -> undefined `seq` UBT5(E,L(0),Nothing,E,L(0))- Eq c -> UBT5(l,L(1),Just c ,E,L(0))- Lt -> UBT5(p,L(2),Nothing,E,L(0))- f (P l a r) h = f_ l DECINT1(h) a r DECINT2(h)- f_ l hl a r hr = case cmp a b of- Gt -> case f l hl of- UBT5(ll,hll,mbc,lr,hlr) -> case spliceH lr hlr a r hr of- UBT2(r_,hr_) -> UBT5(ll,hll,mbc,r_,hr_)- Eq c -> UBT5(l,hl,Just c,r,hr)- Lt -> case f r hr of- UBT5(rl,hrl,mbc,rr,hrr) -> case spliceH l hl a rl hrl of- UBT2(l_,hl_) -> UBT5(l_,hl_,mbc,rr,hrr)--
− Data/Tree/AVL/Join.hs
@@ -1,121 +0,0 @@-{-# OPTIONS_GHC -fglasgow-exts #-}--------------------------------------------------------------------------------- |--- Module : Data.Tree.AVL.Join--- Copyright : (c) Adrian Hey 2004,2005--- License : BSD3------ Maintainer : http://homepages.nildram.co.uk/~ahey/em.png--- Stability : stable--- Portability : portable-------------------------------------------------------------------------------module Data.Tree.AVL.Join-(-- * Joining AVL trees- join,concatAVL,flatConcat,-) where--import Data.Tree.AVL.Types(AVL(..))-import Data.Tree.AVL.Size(addSize)-import Data.Tree.AVL.List(asTreeLenL,toListL)-import Data.Tree.AVL.Internals.DelUtils(popHLN,popHLZ,popHLP)-import Data.Tree.AVL.Height(height,addHeight)-import Data.Tree.AVL.Internals.HJoin(joinH',spliceH)--import Data.List(foldl')--#ifdef __GLASGOW_HASKELL__-import GHC.Base-#include "ghcdefs.h"-#else-#include "h98defs.h"-#endif---- | Join two AVL trees. This is the AVL equivalent of (++).------ > asListL (l `join` r) = asListL l ++ asListL r------ Complexity: O(log n), where n is the size of the larger of the two trees.-join :: AVL e -> AVL e -> AVL e-join l r = joinH' l (height l) r (height r)---- Specialised list of AVL trees of known height, with leftmost element popped.--- (used by concatAVL).-data HAVLS e = HE | H e (AVL e) UINT (HAVLS e)---- | Concatenate a /finite/ list of AVL trees. During construction of the resulting tree the--- input list is consumed lazily, but it will be consumed entirely before the result is returned.------ > asListL (concatAVL avls) = concatMap asListL avls------ Complexity: Umm..Dunno. Uses a divide and conquer approach to splice adjacent pairs of--- trees in the list recursively, until only one tree remains. The complexity of each splice--- is proportional to the difference in tree heights.-concatAVL :: [AVL e] -> AVL e-concatAVL [] = E-concatAVL ( E :ts) = concatAVL ts-concatAVL (t@(N l _ _):ts) = concatHAVLS t (addHeight L(2) l) (mkHAVLS ts)-concatAVL (t@(Z l _ _):ts) = concatHAVLS t (addHeight L(1) l) (mkHAVLS ts)-concatAVL (t@(P _ _ r):ts) = concatHAVLS t (addHeight L(2) r) (mkHAVLS ts)---- Recursively call mergePairs until only one tree remains.--- The head of the current list has to be treated specially becuase it has no associated--- bridging element.-concatHAVLS :: AVL e -> UINT -> HAVLS e -> AVL e-concatHAVLS l _ HE = l-concatHAVLS l hl (H e r hr hs) = case mergePairs l hl e r hr hs of- UBT3(t,ht,hs_) -> concatHAVLS t ht hs_----- Merge adjacent pairs in the current list.--- The head of the current list has to be treated specially becuase it has no associated--- bridging element.--- This function is strict in both elements of the result pair.-{-# INLINE mergePairs #-}-mergePairs :: AVL e -> UINT -> e -> AVL e -> UINT -> HAVLS e -> UBT3(AVL e,UINT,HAVLS e)-mergePairs l hl e r hr hs = case spliceH l hl e r hr of- UBT2(t,ht) -> case hs of- HE -> UBT3(t,ht,HE)- H e_ t_ ht_ hs_ -> let hs__ = mergePairs_ e_ t_ ht_ hs_- in hs__ `seq` UBT3(t,ht,hs__)---- Deals with the rest of mergePairs after the head of the current list has been dealt with.--- This function is strict in the resulting list head and lazy in the tail.-mergePairs_ :: e -> AVL e -> UINT -> HAVLS e -> HAVLS e-mergePairs_ e l hl HE = H e l hl HE-mergePairs_ e l hl (H e_ r hr hs) = case spliceH l hl e_ r hr of- UBT2(t,ht) -> case hs of- HE -> H e t ht HE- H e__ r_ hr_ hs_ -> H e t ht (mergePairs_ e__ r_ hr_ hs_)---- Uses popHL to get the leftmost element from each tree and calculate the (popped) tree height.--- The popped element is used as a bridging element for splicing purposes.--- Empty and singleton trees get special treatment.--- This function is strict in the resulting list head and lazy in the tail.-mkHAVLS :: [AVL e] -> HAVLS e-mkHAVLS [] = HE-mkHAVLS ( E :ts) = mkHAVLS ts -- Discard empty trees-mkHAVLS ((N l e r):ts) = case popHLN l e r of -- Never a singlton with N- UBT3(e_,t,ht) -> H e_ t ht (mkHAVLS ts)-mkHAVLS ((Z l e r):ts) = case popHLZ l e r of- UBT3(e_,t,ht) -> if ht EQL L(0)- then mkHAVLS_ e_ ts -- Deal with singleton- else H e_ t ht (mkHAVLS ts) -- Otherwise treat as normal-mkHAVLS ((P l e r):ts) = case popHLP l e r of -- Never a singlton with P- UBT3(e_,t,ht) -> H e_ t ht (mkHAVLS ts)--- Deals with singletons (avoids unnecessary popHL in next in list)-mkHAVLS_ :: e -> [AVL e] -> HAVLS e-mkHAVLS_ e [] = H e E L(0) HE -- End of list reached anyway-mkHAVLS_ e ( E :ts) = mkHAVLS_ e ts -- Discard empty trees-mkHAVLS_ e (t@(N l _ _):ts) = H e t (addHeight L(2) l) (mkHAVLS ts)-mkHAVLS_ e (t@(Z l _ _):ts) = H e t (addHeight L(1) l) (mkHAVLS ts)-mkHAVLS_ e (t@(P _ _ r):ts) = H e t (addHeight L(2) r) (mkHAVLS ts)----------------------------------------------------------------------------------------------- concatAVL Ends Here -------------------------------------------------------------------------------------------------------- | Similar to 'concatAVL', except the resulting tree is flat.--- This function evaluates the entire list of trees before constructing the result.------ Complexity: O(n), where n is the total number of elements in the resulting tree.-flatConcat :: [AVL e] -> AVL e-flatConcat avls = asTreeLenL (foldl' addSize 0 avls) (foldr toListL [] avls)
− Data/Tree/AVL/List.hs
@@ -1,852 +0,0 @@-{-# OPTIONS_GHC -fglasgow-exts #-}--------------------------------------------------------------------------------- |--- Module : Data.Tree.AVL.List--- Copyright : (c) Adrian Hey 2004,2005--- License : BSD3------ Maintainer : http://homepages.nildram.co.uk/~ahey/em.png--- Stability : stable--- Portability : portable-------------------------------------------------------------------------------module Data.Tree.AVL.List-(-- * List related utilities for AVL trees-- -- ** Converting AVL trees to Lists (fixed element order).- -- | These functions are lazy and allow normal lazy list processing- -- style to be used (without necessarily converting the entire tree- -- to a list in one gulp).- asListL,toListL,asListR,toListR,-- -- ** Converting Lists to AVL trees (fixed element order)- asTreeLenL,asTreeL,- asTreeLenR,asTreeR,-- -- ** Converting unsorted Lists to sorted AVL trees- asTree,-- -- ** \"Pushing\" unsorted Lists in sorted AVL trees- pushList,-- -- * Some analogues of common List functions- reverse,map,map',- mapAccumL ,mapAccumR ,- mapAccumL' ,mapAccumR' ,- replicate,- filter,mapMaybe,- filterViaList,mapMaybeViaList,- partition,-#if __GLASGOW_HASKELL__ > 604- traverseAVL,-#endif-- -- ** Folds- -- | Note that unlike folds over lists ('foldr' and 'foldl'), there is no- -- significant difference between left and right folds in AVL trees, other- -- than which side of the tree each starts with.- -- Therefore this library provides strict and lazy versions of both.- foldr,foldr',foldr1,foldr1',foldr2,foldr2',- foldl,foldl',foldl1,foldl1',foldl2,foldl2',--#ifdef __GLASGOW_HASKELL__- -- ** (GHC Only)- mapAccumL'',mapAccumR'', foldrInt#,-#endif-- -- * Some clones of common List functions- -- | These are a cure for the horrible @O(n^2)@ complexity the noddy Data.List definitions.- nub,nubBy,-- -- * \"Flattening\" AVL trees- -- | These functions can be improve search times by reducing a tree of given size to- -- the minimum possible height.- flatten,- flatReverse,flatMap,flatMap',-) where--import Prelude hiding (reverse,map,replicate,filter,foldr,foldr1,foldl,foldl1) -- so haddock finds the symbols there--import Data.COrdering-import Data.Tree.AVL.Types(AVL(..),empty)-import Data.Tree.AVL.Size(size)-import Data.Tree.AVL.Push(push)-import Data.Tree.AVL.BinPath(findEmptyPath,insertPath)-import Data.Tree.AVL.Internals.HJoin(spliceH,joinH)--import Data.Bits(shiftR,(.&.))-import qualified Data.List as List (foldl',map)-#if __GLASGOW_HASKELL__ > 604-import Control.Applicative hiding (empty)-#endif--#ifdef __GLASGOW_HASKELL__-import GHC.Base(Int#,(-#))-#include "ghcdefs.h"-#else-#include "h98defs.h"-#endif---- | List AVL tree contents in left to right order.--- The resulting list in ascending order if the tree is sorted.------ Complexity: O(n)-asListL :: AVL e -> [e]-asListL avl = toListL avl []---- | Join the AVL tree contents to an existing list in left to right order.--- This is a ++ free function which behaves as if defined thusly..------ > avl `toListL` as = (asListL avl) ++ as------ Complexity: O(n)-toListL :: AVL e -> [e] -> [e]-toListL E es = es-toListL (N l e r) es = toListL' l e r es-toListL (Z l e r) es = toListL' l e r es-toListL (P l e r) es = toListL' l e r es-toListL' :: AVL e -> e -> AVL e -> [e] -> [e]-toListL' l e r es = toListL l (e:(toListL r es))---- | List AVL tree contents in right to left order.--- The resulting list in descending order if the tree is sorted.------ Complexity: O(n)-asListR :: AVL e -> [e]-asListR avl = toListR avl []---- | Join the AVL tree contents to an existing list in right to left order.--- This is a ++ free function which behaves as if defined thusly..------ > avl `toListR` as = (asListR avl) ++ as------ Complexity: O(n)-toListR :: AVL e -> [e] -> [e]-toListR E es = es-toListR (N l e r) es = toListR' l e r es-toListR (Z l e r) es = toListR' l e r es-toListR (P l e r) es = toListR' l e r es-toListR' :: AVL e -> e -> AVL e -> [e] -> [e]-toListR' l e r es = toListR r (e:(toListR l es))---- | The AVL equivalent of 'foldr' on lists. This is a the lazy version (as lazy as the folding function--- anyway). Using this version with a function that is strict in it's second argument will result in O(n)--- stack use. See 'foldr'' for a strict version.------ It behaves as if defined..------ > foldr f a avl = foldr f a (asListL avl)------ For example, the 'asListL' function could be defined..------ > asListL = foldr (:) []------ Complexity: O(n)-foldr :: (e -> a -> a) -> a -> AVL e -> a-foldr f = foldU where- foldU a E = a- foldU a (N l e r) = foldV a l e r- foldU a (Z l e r) = foldV a l e r- foldU a (P l e r) = foldV a l e r- foldV a l e r = foldU (f e (foldU a r)) l---- | The strict version of 'foldr', which is useful for functions which are strict in their second--- argument. The advantage of this version is that it reduces the stack use from the O(n) that the lazy--- version gives (when used with strict functions) to O(log n).------ Complexity: O(n)-foldr' :: (e -> a -> a) -> a -> AVL e -> a-foldr' f = foldU where- foldU a E = a- foldU a (N l e r) = foldV a l e r- foldU a (Z l e r) = foldV a l e r- foldU a (P l e r) = foldV a l e r- foldV a l e r = let a' = foldU a r- a'' = f e a'- in a' `seq` a'' `seq` foldU a'' l---- | The AVL equivalent of 'foldr1' on lists. This is a the lazy version (as lazy as the folding function--- anyway). Using this version with a function that is strict in it's second argument will result in O(n)--- stack use. See 'foldr1'' for a strict version.------ > foldr1 f avl = foldr1 f (asListL avl)------ This function raises an error if the tree is empty.------ Complexity: O(n)-foldr1 :: (e -> e -> e) -> AVL e -> e-foldr1 f = foldU where- foldU E = error "foldr1: Empty Tree"- foldU (N l e r) = foldV l e r -- r can't be E- foldU (Z l e r) = foldW l e r -- r might be E- foldU (P l e r) = foldW l e r -- r might be E- -- Use this when r can't be E- foldV l e r = foldr f (f e (foldU r)) l- -- Use this when r might be E- foldW l e E = foldr f e l- foldW l e (N rl re rr) = foldr f (f e (foldV rl re rr)) l -- rr can't be E- foldW l e (Z rl re rr) = foldX l e rl re rr -- rr might be E- foldW l e (P rl re rr) = foldX l e rl re rr -- rr might be E- -- Common code for foldW (Z and P cases)- foldX l e rl re rr = foldr f (f e (foldW rl re rr)) l---- | The strict version of 'foldr1', which is useful for functions which are strict in their second--- argument. The advantage of this version is that it reduces the stack use from the O(n) that the lazy--- version gives (when used with strict functions) to O(log n).------ Complexity: O(n)-foldr1' :: (e -> e -> e) -> AVL e -> e-foldr1' f = foldU where- foldU E = error "foldr1': Empty Tree"- foldU (N l e r) = foldV l e r -- r can't be E- foldU (Z l e r) = foldW l e r -- r might be E- foldU (P l e r) = foldW l e r -- r might be E- -- Use this when r can't be E- foldV l e r = let a = foldU r- a' = f e a- in a `seq` a' `seq` foldr' f a' l- -- Use this when r might be E- foldW l e E = foldr' f e l- foldW l e (N rl re rr) = let a = foldV rl re rr -- rr can't be E- a' = f e a- in a `seq` a' `seq` foldr' f a' l- foldW l e (Z rl re rr) = foldX l e rl re rr -- rr might be E- foldW l e (P rl re rr) = foldX l e rl re rr -- rr might be E- -- Common code for foldW (Z and P cases)- foldX l e rl re rr = let a = foldW rl re rr- a' = f e a- in a `seq` a' `seq` foldr' f a' l---- | This fold is a hybrid between 'foldr' and 'foldr1'. As with 'foldr1', it requires--- a non-empty tree, but instead of treating the rightmost element as an initial value, it applies--- a function to it (second function argument) and uses the result instead. This allows--- a more flexible type for the main folding function (same type as that used by 'foldr').--- As with 'foldr' and 'foldr1', this function is lazy, so it's best not to use it with functions--- that are strict in their second argument. See 'foldr2'' for a strict version.------ Complexity: O(n)-foldr2 :: (e -> a -> a) -> (e -> a) -> AVL e -> a-foldr2 f g = foldU where- foldU E = error "foldr2: Empty Tree"- foldU (N l e r) = foldV l e r -- r can't be E- foldU (Z l e r) = foldW l e r -- r might be E- foldU (P l e r) = foldW l e r -- r might be E- -- Use this when r can't be E- foldV l e r = foldr f (f e (foldU r)) l- -- Use this when r might be E- foldW l e E = foldr f (g e) l- foldW l e (N rl re rr) = foldr f (f e (foldV rl re rr)) l -- rr can't be E- foldW l e (Z rl re rr) = foldX l e rl re rr -- rr might be E- foldW l e (P rl re rr) = foldX l e rl re rr -- rr might be E- -- Common code for foldW (Z and P cases)- foldX l e rl re rr = foldr f (f e (foldW rl re rr)) l---- | The strict version of 'foldr2', which is useful for functions which are strict in their second--- argument. The advantage of this version is that it reduces the stack use from the O(n) that the lazy--- version gives (when used with strict functions) to O(log n).------ Complexity: O(n)-foldr2' :: (e -> a -> a) -> (e -> a) -> AVL e -> a-foldr2' f g = foldU where- foldU E = error "foldr2': Empty Tree"- foldU (N l e r) = foldV l e r -- r can't be E- foldU (Z l e r) = foldW l e r -- r might be E- foldU (P l e r) = foldW l e r -- r might be E- -- Use this when r can't be E- foldV l e r = let a = foldU r- a' = f e a- in a `seq` a' `seq` foldr' f a' l- -- Use this when r might be E- foldW l e E = let a = g e in a `seq` foldr' f a l- foldW l e (N rl re rr) = let a = foldV rl re rr -- rr can't be E- a' = f e a- in a `seq` a' `seq` foldr' f a' l- foldW l e (Z rl re rr) = foldX l e rl re rr -- rr might be E- foldW l e (P rl re rr) = foldX l e rl re rr -- rr might be E- -- Common code for foldW (Z and P cases)- foldX l e rl re rr = let a = foldW rl re rr- a' = f e a- in a `seq` a' `seq` foldr' f a' l----- | The AVL equivalent of 'foldl' on lists. This is a the lazy version (as lazy as the folding function--- anyway). Using this version with a function that is strict in it's first argument will result in O(n)--- stack use. See 'foldl'' for a strict version.------ > foldl f a avl = foldl f a (asListL avl)------ For example, the 'asListR' function could be defined..------ > asListR = foldl (flip (:)) []------ Complexity: O(n)-foldl :: (a -> e -> a) -> a -> AVL e -> a-foldl f = foldU where- foldU a E = a- foldU a (N l e r) = foldV a l e r- foldU a (Z l e r) = foldV a l e r- foldU a (P l e r) = foldV a l e r- foldV a l e r = foldU (f (foldU a l) e) r---- | The strict version of 'foldl', which is useful for functions which are strict in their first--- argument. The advantage of this version is that it reduces the stack use from the O(n) that the lazy--- version gives (when used with strict functions) to O(log n).------ Complexity: O(n)-foldl' :: (a -> e -> a) -> a -> AVL e -> a-foldl' f = foldU where- foldU a E = a- foldU a (N l e r) = foldV a l e r- foldU a (Z l e r) = foldV a l e r- foldU a (P l e r) = foldV a l e r- foldV a l e r = let a' = foldU a l- a'' = f a' e- in a' `seq` a'' `seq` foldU a'' r---- | The AVL equivalent of 'foldl1' on lists. This is a the lazy version (as lazy as the folding function--- anyway). Using this version with a function that is strict in it's first argument will result in O(n)--- stack use. See 'foldl1'' for a strict version.------ > foldl1 f avl = foldl1 f (asListL avl)------ This function raises an error if the tree is empty.------ Complexity: O(n)-foldl1 :: (e -> e -> e) -> AVL e -> e-foldl1 f = foldU where- foldU E = error "foldl1: Empty Tree"- foldU (N l e r) = foldW l e r -- l might be E- foldU (Z l e r) = foldW l e r -- l might be E- foldU (P l e r) = foldV l e r -- l can't be E- -- Use this when l can't be E- foldV l e r = foldl f (f (foldU l) e) r- -- Use this when l might be E- foldW E e r = foldl f e r- foldW (N ll le lr) e r = foldX ll le lr e r -- ll might be E- foldW (Z ll le lr) e r = foldX ll le lr e r -- ll might be E- foldW (P ll le lr) e r = foldl f (f (foldV ll le lr) e) r -- ll can't be E- -- Common code for foldW (Z and P cases)- foldX ll le lr e r = foldl f (f (foldW ll le lr) e) r---- | The strict version of 'foldl1', which is useful for functions which are strict in their first--- argument. The advantage of this version is that it reduces the stack use from the O(n) that the lazy--- version gives (when used with strict functions) to O(log n).------ Complexity: O(n)-foldl1' :: (e -> e -> e) -> AVL e -> e-foldl1' f = foldU where- foldU E = error "foldl1': Empty Tree"- foldU (N l e r) = foldW l e r -- l might be E- foldU (Z l e r) = foldW l e r -- l might be E- foldU (P l e r) = foldV l e r -- l can't be E- -- Use this when l can't be E- foldV l e r = let a = foldU l- a' = f a e- in a `seq` a' `seq` foldl' f a' r- -- Use this when l might be E- foldW E e r = foldl' f e r- foldW (N ll le lr) e r = foldX ll le lr e r -- ll might be E- foldW (Z ll le lr) e r = foldX ll le lr e r -- ll might be E- foldW (P ll le lr) e r = let a = foldV ll le lr -- ll can't be E- a' = f a e- in a `seq` a' `seq` foldl' f a' r- -- Common code for foldW (Z and P cases)- foldX ll le lr e r = let a = foldW ll le lr- a' = f a e- in a `seq` a' `seq` foldl' f a' r---- | This fold is a hybrid between 'foldl' and 'foldl1'. As with 'foldl1', it requires--- a non-empty tree, but instead of treating the leftmost element as an initial value, it applies--- a function to it (second function argument) and uses the result instead. This allows--- a more flexible type for the main folding function (same type as that used by 'foldl').--- As with 'foldl' and 'foldl1', this function is lazy, so it's best not to use it with functions--- that are strict in their first argument. See 'foldl2'' for a strict version.------ Complexity: O(n)-foldl2 :: (a -> e -> a) -> (e -> a) -> AVL e -> a-foldl2 f g = foldU where- foldU E = error "foldl2: Empty Tree"- foldU (N l e r) = foldW l e r -- l might be E- foldU (Z l e r) = foldW l e r -- l might be E- foldU (P l e r) = foldV l e r -- l can't be E- -- Use this when l can't be E- foldV l e r = foldl f (f (foldU l) e) r- -- Use this when l might be E- foldW E e r = foldl f (g e) r- foldW (N ll le lr) e r = foldX ll le lr e r -- ll might be E- foldW (Z ll le lr) e r = foldX ll le lr e r -- ll might be E- foldW (P ll le lr) e r = foldl f (f (foldV ll le lr) e) r -- ll can't be E- -- Common code for foldW (Z and P cases)- foldX ll le lr e r = foldl f (f (foldW ll le lr) e) r---- | The strict version of 'foldl2', which is useful for functions which are strict in their first--- argument. The advantage of this version is that it reduces the stack use from the O(n) that the lazy--- version gives (when used with strict functions) to O(log n).------ Complexity: O(n)-foldl2' :: (a -> e -> a) -> (e -> a) -> AVL e -> a-foldl2' f g = foldU where- foldU E = error "foldl2': Empty Tree"- foldU (N l e r) = foldW l e r -- l might be E- foldU (Z l e r) = foldW l e r -- l might be E- foldU (P l e r) = foldV l e r -- l can't be E- -- Use this when l can't be E- foldV l e r = let a = foldU l- a' = f a e- in a `seq` a' `seq` foldl' f a' r- -- Use this when l might be E- foldW E e r = let a = g e in a `seq` foldl' f a r- foldW (N ll le lr) e r = foldX ll le lr e r -- ll might be E- foldW (Z ll le lr) e r = foldX ll le lr e r -- ll might be E- foldW (P ll le lr) e r = let a = foldV ll le lr -- ll can't be E- a' = f a e- in a `seq` a' `seq` foldl' f a' r- -- Common code for foldW (Z and P cases)- foldX ll le lr e r = let a = foldW ll le lr- a' = f a e- in a `seq` a' `seq` foldl' f a' r--#ifdef __GLASGOW_HASKELL__--- | This is a specialised version of 'foldr'' for use with an--- /unboxed/ Int accumulator.------ Complexity: O(n)-foldrInt# :: (e -> UINT -> UINT) -> UINT -> AVL e -> UINT-foldrInt# f = foldU where- foldU a E = a- foldU a (N l e r) = foldV a l e r- foldU a (Z l e r) = foldV a l e r- foldU a (P l e r) = foldV a l e r- foldV a l e r = foldU (f e (foldU a r)) l-#endif---- | The AVL equivalent of 'Data.List.mapAccumL' on lists.--- It behaves like a combination of 'map' and 'foldl'.--- It applies a function to each element of a tree, passing an accumulating parameter from--- left to right, and returning a final value of this accumulator together with the new tree.------ Using this version with a function that is strict in it's first argument will result in--- O(n) stack use. See 'mapAccumL'' for a strict version.------ Complexity: O(n)-mapAccumL :: (z -> a -> (z, b)) -> z -> AVL a -> (z, AVL b)-mapAccumL f z ta = case mapAL z ta of- UBT2(zt,tb) -> (zt,tb)- where mapAL z_ E = UBT2(z_,E)- mapAL z_ (N la a ra) = mapAL' z_ N la a ra- mapAL z_ (Z la a ra) = mapAL' z_ Z la a ra- mapAL z_ (P la a ra) = mapAL' z_ P la a ra- {-# INLINE mapAL' #-}- mapAL' z' c la a ra = case mapAL z' la of- UBT2(zl,lb) -> let (za,b) = f zl a- in case mapAL za ra of- UBT2(zr,rb) -> UBT2(zr, c lb b rb)---- | This is a strict version of 'mapAccumL', which is useful for functions which--- are strict in their first argument. The advantage of this version is that it reduces--- the stack use from the O(n) that the lazy version gives (when used with strict functions)--- to O(log n).------ Complexity: O(n)-mapAccumL' :: (z -> a -> (z, b)) -> z -> AVL a -> (z, AVL b)-mapAccumL' f z ta = case mapAL z ta of- UBT2(zt,tb) -> (zt,tb)- where mapAL z_ E = UBT2(z_,E)- mapAL z_ (N la a ra) = mapAL' z_ N la a ra- mapAL z_ (Z la a ra) = mapAL' z_ Z la a ra- mapAL z_ (P la a ra) = mapAL' z_ P la a ra- {-# INLINE mapAL' #-}- mapAL' z' c la a ra = case mapAL z' la of- UBT2(zl,lb) -> case f zl a of- (za,b) -> case mapAL za ra of- UBT2(zr,rb) -> UBT2(zr, c lb b rb)----- | The AVL equivalent of 'Data.List.mapAccumR' on lists.--- It behaves like a combination of 'map' and 'foldr'.--- It applies a function to each element of a tree, passing an accumulating parameter from--- right to left, and returning a final value of this accumulator together with the new tree.------ Using this version with a function that is strict in it's first argument will result in--- O(n) stack use. See 'mapAccumR'' for a strict version.------ Complexity: O(n)-mapAccumR :: (z -> a -> (z, b)) -> z -> AVL a -> (z, AVL b)-mapAccumR f z ta = case mapAR z ta of- UBT2(zt,tb) -> (zt,tb)- where mapAR z_ E = UBT2(z_,E)- mapAR z_ (N la a ra) = mapAR' z_ N la a ra- mapAR z_ (Z la a ra) = mapAR' z_ Z la a ra- mapAR z_ (P la a ra) = mapAR' z_ P la a ra- {-# INLINE mapAR' #-}- mapAR' z' c la a ra = case mapAR z' ra of- UBT2(zr,rb) -> let (za,b) = f zr a- in case mapAR za la of- UBT2(zl,lb) -> UBT2(zl, c lb b rb)---- | This is a strict version of 'mapAccumR', which is useful for functions which--- are strict in their first argument. The advantage of this version is that it reduces--- the stack use from the O(n) that the lazy version gives (when used with strict functions)--- to O(log n).------ Complexity: O(n)-mapAccumR' :: (z -> a -> (z, b)) -> z -> AVL a -> (z, AVL b)-mapAccumR' f z ta = case mapAR z ta of- UBT2(zt,tb) -> (zt,tb)- where mapAR z_ E = UBT2(z_,E)- mapAR z_ (N la a ra) = mapAR' z_ N la a ra- mapAR z_ (Z la a ra) = mapAR' z_ Z la a ra- mapAR z_ (P la a ra) = mapAR' z_ P la a ra- {-# INLINE mapAR' #-}- mapAR' z' c la a ra = case mapAR z' ra of- UBT2(zr,rb) -> case f zr a of- (za,b) -> case mapAR za la of- UBT2(zl,lb) -> UBT2(zl, c lb b rb)----------------------------------------------------------------------------------------------------- These two functions attempt to make the strict mapAccums more efficient and reduce heap--- burn rate with ghc by using an accumulating function that returns an unboxed pair.--------------------------------------------------------------------------------------------------#ifdef __GLASGOW_HASKELL__--- | Glasgow Haskell only. Similar to 'mapAccumL'' but uses an unboxed pair in the--- accumulating function.------ Complexity: O(n)-mapAccumL''- :: (z -> a -> UBT2(z, b)) -> z -> AVL a -> (z, AVL b)-mapAccumL'' f z ta = case mapAL z ta of- UBT2(zt,tb) -> (zt,tb)- where mapAL z_ E = UBT2(z_,E)- mapAL z_ (N la a ra) = mapAL' z_ N la a ra- mapAL z_ (Z la a ra) = mapAL' z_ Z la a ra- mapAL z_ (P la a ra) = mapAL' z_ P la a ra- {-# INLINE mapAL' #-}- mapAL' z' c la a ra = case mapAL z' la of- UBT2(zl,lb) -> case f zl a of- UBT2(za,b) -> case mapAL za ra of- UBT2(zr,rb) -> UBT2(zr, c lb b rb)---- | Glasgow Haskell only. Similar to 'mapAccumR'' but uses an unboxed pair in the--- accumulating function.------ Complexity: O(n)-mapAccumR''- :: (z -> a -> UBT2(z, b)) -> z -> AVL a -> (z, AVL b)-mapAccumR'' f z ta = case mapAR z ta of- UBT2(zt,tb) -> (zt,tb)- where mapAR z_ E = UBT2(z_,E)- mapAR z_ (N la a ra) = mapAR' z_ N la a ra- mapAR z_ (Z la a ra) = mapAR' z_ Z la a ra- mapAR z_ (P la a ra) = mapAR' z_ P la a ra- {-# INLINE mapAR' #-}- mapAR' z' c la a ra = case mapAR z' ra of- UBT2(zr,rb) -> case f zr a of- UBT2(za,b) -> case mapAR za la of- UBT2(zl,lb) -> UBT2(zl, c lb b rb)--#endif------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------ | Convert a list of known length into an AVL tree, such that the head of the list becomes--- the leftmost tree element. The resulting tree is flat (and also sorted if the supplied list--- is sorted in ascending order).------ If the actual length of the list is not the same as the supplied length then--- an error will be raised.------ Complexity: O(n)-asTreeLenL :: Int -> [e] -> AVL e-asTreeLenL n es = case subst (replicate n ()) es of- UBT2(tree,es_) -> case es_ of- [] -> tree- _ -> error "asTreeLenL: List too long."- where- -- Substitute template values for real values taken from the list- subst E as = UBT2(E,as)- subst (N l _ r) as = subst' N l r as- subst (Z l _ r) as = subst' Z l r as- subst (P l _ r) as = subst' P l r as- {-# INLINE subst' #-}- subst' f l r as = case subst l as of- UBT2(l_,xs) -> case xs of- a:as' -> case subst r as' of- UBT2(r_,as__) -> let t_ = f l_ a r_- in t_ `seq` UBT2(t_,as__)- [] -> error "asTreeLenL: List too short."----- | As 'asTreeLenL', except the length of the list is calculated internally, not supplied--- as an argument.------ Complexity: O(n)-asTreeL :: [e] -> AVL e-asTreeL es = asTreeLenL (length es) es---- | Convert a list of known length into an AVL tree, such that the head of the list becomes--- the rightmost tree element. The resulting tree is flat (and also sorted if the supplied list--- is sorted in descending order).------ If the actual length of the list is not the same as the supplied length then--- an error will be raised.------ Complexity: O(n)-asTreeLenR :: Int -> [e] -> AVL e-asTreeLenR n es = case subst (replicate n ()) es of- UBT2(tree,es_) -> case es_ of- [] -> tree- _ -> error "asTreeLenR: List too long."- where- -- Substitute template values for real values taken from the list- subst E as = UBT2(E,as)- subst (N l _ r) as = subst' N l r as- subst (Z l _ r) as = subst' Z l r as- subst (P l _ r) as = subst' P l r as- {-# INLINE subst' #-}- subst' f l r as = case subst r as of- UBT2(r_,xs) -> case xs of- a:as' -> case subst l as' of- UBT2(l_,as__) -> let t_ = f l_ a r_- in t_ `seq` UBT2(t_,as__)- [] -> error "asTreeLenR: List too short."---- | As 'asTreeLenR', except the length of the list is calculated internally, not supplied--- as an argument.------ Complexity: O(n)-asTreeR :: [e] -> AVL e-asTreeR es = asTreeLenR (length es) es---- | Reverse an AVL tree (swaps and reverses left and right sub-trees).--- The resulting tree is the mirror image of the original.------ Complexity: O(n)-reverse :: AVL e -> AVL e-reverse E = E-reverse (N l e r) = let l' = reverse l- r' = reverse r- in l' `seq` r' `seq` P r' e l'-reverse (Z l e r) = let l' = reverse l- r' = reverse r- in l' `seq` r' `seq` Z r' e l'-reverse (P l e r) = let l' = reverse l- r' = reverse r- in l' `seq` r' `seq` N r' e l'---- | Apply a function to every element in an AVL tree. This function preserves the tree shape.--- There is also a strict version of this function ('map'').------ N.B. If the tree is sorted the result of this operation will only be sorted if--- the applied function preserves ordering (for some suitable ordering definition).------ Complexity: O(n)-map :: (a -> b) -> AVL a -> AVL b-map f = mp where- mp E = E- mp (N l a r) = let l' = mp l- r' = mp r- in l' `seq` r' `seq` N l' (f a) r'- mp (Z l a r) = let l' = mp l- r' = mp r- in l' `seq` r' `seq` Z l' (f a) r'- mp (P l a r) = let l' = mp l- r' = mp r- in l' `seq` r' `seq` P l' (f a) r'---- | Similar to 'map', but the supplied function is applied strictly.------ Complexity: O(n)-map' :: (a -> b) -> AVL a -> AVL b-map' f = mp' where- mp' E = E- mp' (N l a r) = let l' = mp' l- r' = mp' r- b = f a- in b `seq` l' `seq` r' `seq` N l' b r'- mp' (Z l a r) = let l' = mp' l- r' = mp' r- b = f a- in b `seq` l' `seq` r' `seq` Z l' b r'- mp' (P l a r) = let l' = mp' l- r' = mp' r- b = f a- in b `seq` l' `seq` r' `seq` P l' b r'----- | Construct a flat AVL tree of size n (n>=0), where all elements are identical.------ Complexity: O(log n)-replicate :: Int -> e -> AVL e-replicate m e = rep m where -- Functional spaghetti follows :-)- rep n | odd n = repOdd n -- n is odd , >=1- rep n = repEvn n -- n is even, >=0- -- n is known to be odd (>=1), so left and right sub-trees are identical- repOdd n = let sub = rep (n `shiftR` 1) in sub `seq` Z sub e sub- -- n is known to be even (>=0)- repEvn n | n .&. (n-1) == 0 = repP2 n -- treat exact powers of 2 specially, traps n=0 too- repEvn n = let nl = n `shiftR` 1 -- size of left subtree (odd or even)- nr = nl - 1 -- size of right subtree (even or odd)- in if odd nr- then let l = repEvn nl -- right sub-tree is odd , so left is even (>=2)- r = repOdd nr- in l `seq` r `seq` Z l e r- else let l = repOdd nl -- right sub-tree is even, so left is odd (>=2)- r = repEvn nr- in l `seq` r `seq` Z l e r- -- n is an exact power of 2 (or 0), I.E. 0,1,2,4,8,16..- repP2 0 = E- repP2 1 = Z E e E- repP2 n = let nl = n `shiftR` 1 -- nl is also an exact power of 2- nr = nl - 1 -- nr is one less that an exact power of 2- l = repP2 nl- r = repP2M1 nr- in l `seq` r `seq` P l e r -- BF=+1- -- n is one less than an exact power of 2, I.E. 0,1,3,7,15..- repP2M1 0 = E- repP2M1 n = let sub = repP2M1 (n `shiftR` 1) in sub `seq` Z sub e sub---- | Flatten an AVL tree, preserving the ordering of the tree elements.------ Complexity: O(n)-flatten :: AVL e -> AVL e-flatten t = asTreeLenL (size t) (asListL t)---- | Similar to 'flatten', but the tree elements are reversed. This function has higher constant--- factor overhead than 'reverse'.------ Complexity: O(n)-flatReverse :: AVL e -> AVL e-flatReverse t = asTreeLenL (size t) (asListR t)---- | Similar to 'map', but the resulting tree is flat.--- This function has higher constant factor overhead than 'map'.------ Complexity: O(n)-flatMap :: (a -> b) -> AVL a -> AVL b-flatMap f t = asTreeLenL (size t) (List.map f (asListL t))---- | Same as 'flatMap', but the supplied function is applied strictly.------ Complexity: O(n)-flatMap' :: (a -> b) -> AVL a -> AVL b-flatMap' f t = asTreeLenL (size t) (mp' f (asListL t)) where- mp' _ [] = []- mp' g (a:as) = let b = g a in b `seq` (b : mp' f as)---- | Remove all AVL tree elements which do not satisfy the supplied predicate.--- Element ordering is preserved. The resulting tree is flat.--- See 'filter' for an alternative implementation which is probably more efficient.------ Complexity: O(n)-filterViaList :: (e -> Bool) -> AVL e -> AVL e-filterViaList p t = filter' [] 0 (asListR t) where- filter' se n [] = asTreeLenL n se- filter' se n (e:es) = if p e then let n'=n+1 in n' `seq` filter' (e:se) n' es- else filter' se n es---- | Remove all AVL tree elements which do not satisfy the supplied predicate.--- Element ordering is preserved.------ Complexity: O(n)-filter :: (e -> Bool) -> AVL e -> AVL e-filter p t0 = case filter_ L(0) t0 of UBT3(_,t_,_) -> t_ -- Work with relative heights!!- where filter_ h t = case t of- E -> UBT3(False,E,h)- N l e r -> f l DECINT2(h) e r DECINT1(h)- Z l e r -> f l DECINT1(h) e r DECINT1(h)- P l e r -> f l DECINT1(h) e r DECINT2(h)- where f l hl e r hr = case filter_ hl l of- UBT3(bl,l_,hl_) -> case filter_ hr r of- UBT3(br,r_,hr_) -> if p e- then if bl || br- then case spliceH l_ hl_ e r_ hr_ of- UBT2(t_,h_) -> UBT3(True,t_,h_)- else UBT3(False,t,h)- else case joinH l_ hl_ r_ hr_ of- UBT2(t_,h_) -> UBT3(True,t_,h_)---- | Partition an AVL tree using the supplied predicate. The first AVL tree in the--- resulting pair contains all elements for which the predicate is True, the second--- contains all those for which the predicate is False. Element ordering is preserved.--- Both of the resulting trees are flat.------ Complexity: O(n)-partition :: (e -> Bool) -> AVL e -> (AVL e, AVL e)-partition p t = part 0 [] 0 [] (asListR t) where- part nT lstT nF lstF [] = let avlT = asTreeLenL nT lstT- avlF = asTreeLenL nF lstF- in (avlT,avlF) -- Non strict in avlT, avlF !!- part nT lstT nF lstF (e:es) = if p e then let nT'=nT+1 in nT' `seq` part nT' (e:lstT) nF lstF es- else let nF'=nF+1 in nF' `seq` part nT lstT nF' (e:lstF) es---- | Remove all AVL tree elements for which the supplied function returns 'Nothing'.--- Element ordering is preserved. The resulting tree is flat.--- See 'mapMaybe' for an alternative implementation which is probably more efficient.------ Complexity: O(n)-mapMaybeViaList :: (a -> Maybe b) -> AVL a -> AVL b-mapMaybeViaList f t = mp' [] 0 (asListR t) where- mp' sb n [] = asTreeLenL n sb- mp' sb n (a:as) = case f a of- Just b -> let n'=n+1 in n' `seq` mp' (b:sb) n' as- Nothing -> mp' sb n as---- | Remove all AVL tree elements for which the supplied function returns 'Nothing'.--- Element ordering is preserved.------ Complexity: O(n)-mapMaybe :: (a -> Maybe b) -> AVL a -> AVL b-mapMaybe f t0 = case mapMaybe_ L(0) t0 of UBT2(t_,_) -> t_ -- Work with relative heights!!- where mapMaybe_ h t = case t of- E -> UBT2(E,h)- N l a r -> m l DECINT2(h) a r DECINT1(h)- Z l a r -> m l DECINT1(h) a r DECINT1(h)- P l a r -> m l DECINT1(h) a r DECINT2(h)- where m l hl a r hr = case mapMaybe_ hl l of- UBT2(l_,hl_) -> case mapMaybe_ hr r of- UBT2(r_,hr_) -> case f a of- Just b -> spliceH l_ hl_ b r_ hr_- Nothing -> joinH l_ hl_ r_ hr_---- | Invokes 'pushList' on the empty AVL tree.------ Complexity: O(n.(log n))-asTree :: (e -> e -> COrdering e) -> [e] -> AVL e-asTree c = pushList c empty-{-# INLINE asTree #-}---- | Push the elements of an unsorted List in a sorted AVL tree using the supplied combining comparison.------ Complexity: O(n.(log (m+n))) where n is the list length, m is the tree size.-pushList :: (e -> e -> COrdering e) -> AVL e -> [e] -> AVL e-pushList c avl = List.foldl' addElem avl- where addElem t e = push (c e) e t---- | A fast alternative implementation for 'Data.List.nub'.--- Deletes all but the first occurrence of an element from the input list.------ Complexity: O(n.(log n))-nub :: Ord a => [a] -> [a]-nub = nubBy compare-{-# INLINE nub #-}---- | A fast alternative implementation for 'Data.List.nubBy'.--- Deletes all but the first occurrence of an element from the input list.------ Complexity: O(n.(log n))-nubBy :: (a -> a -> Ordering) -> [a] -> [a]-nubBy c = nubbit E where- nubbit _ [] = []- nubbit avl (a:as) = case findEmptyPath (c a) avl of- L(-1) -> nubbit avl as -- Already encountered- p -> let avl' = insertPath p a avl -- First encounter- in avl' `seq` (a : nubbit avl' as)--#if __GLASGOW_HASKELL__ > 604--- | This is the non-overloaded version of the 'Data.Traversable.traverse' method for AVL trees.-traverseAVL :: Applicative f => (a -> f b) -> AVL a -> f (AVL b)-traverseAVL _f E = pure E-traverseAVL f (N l v r) = N <$> traverseAVL f l <*> f v <*> traverseAVL f r-traverseAVL f (Z l v r) = Z <$> traverseAVL f l <*> f v <*> traverseAVL f r-traverseAVL f (P l v r) = P <$> traverseAVL f l <*> f v <*> traverseAVL f r-#endif-
− Data/Tree/AVL/Push.hs
@@ -1,715 +0,0 @@--------------------------------------------------------------------------------- |--- Module : Data.Tree.AVL.Push--- Copyright : (c) Adrian Hey 2004,2005--- License : BSD3------ Maintainer : http://homepages.nildram.co.uk/~ahey/em.png--- Stability : stable--- Portability : portable-------------------------------------------------------------------------------module Data.Tree.AVL.Push-(-- * \"Pushing\" new elements into AVL trees- -- | \"Pushing\" is another word for insertion. (c.f \"Popping\".)-- -- ** Pushing on extreme left or right- pushL,pushR,-- -- ** Pushing on /sorted/ AVL trees- push,push',pushMaybe,pushMaybe',-) where--import Prelude -- so haddock finds the symbols there--import Data.COrdering-import Data.Tree.AVL.Types(AVL(..))-import Data.Tree.AVL.BinPath(BinPath(..),openPathWith,writePath,insertPath)--{------------------------------------------------------------------------------------------------------------------------------- -------------------------------------- Notes about Insertion and Rebalancing -------------------------------------------------- ------------------------------------------------------------------------------------------------------------------------------- If we forget about tree rebalancing, and consider what changes in BF tell us about changes in H- under ordinary circumstances, we can make the following observations:-- (1) Insertion can never reduce the height of a (sub)tree.- (2) Insertion can only change the height of a (sub)tree by +1 at most. Therefore the BF of the- root can change by +/- 1 most.- (2) If insertion changes the BF from 0 -> +/- 1, then this must be because either the left or- right subtrees has grown in height by 1. Since they were equal before (BF=0), the overall- height of the root must also have grown by 1.- (3) If insertion changes the BF from +/-1 -> 0, then this must be because one either the left- or right subtree has grown by 1 so that it is now equal in height to the opposing subtree.- Since height of the root is determined by the maximum height of the subtrees, it is left- unchanged.- (4) If insertion leaves the BF unchanged, then this must be because the height of neither- subtree has changed. Therefore the height of the root is left unchanged.- (5) It follows from (2) and (3), that changes in height, and hence BF can (and will) propogate- up the tree (along the insertion path) as far as the first node with non-zero BF, and no further.- (6) If insertion changes the BF from +/-1 -> +/-2 then we have a problem. This is dealt with by- one of four possible rebalancing 'rotations' (there are two possiblities for each of the left- and right subtrees). However, it's appropriate to mention an important property of the rotations- now. The net effect of unbalancing and rebalancing is to give the root BF=0 and leave the height- unchanged. So the combined effect of the unbalance-rebalance operation appears like a special- case of (3). Another important property of rebalancing is that it /preserves/ the tree sorting.- (7) It follows from (6) and (5) any single insertion will cause most one unbalance-rebalance operation.-- So in summary we have a set of rules to enable us to infer changes in height of a subtree (if any) from- changes in the BF of the subtree, and hence the changes (if any) in the BF of the root. The rules are:- BF 0 -> +/-1, height increased by 1- BF +/-1 -> 0, height unchanged.- BF unchanged , height unchanged.- BF +/-1 -> -/+1, NEVER OCCURS-- It should also be observed that these observations and rules apply to INSERTION only (not deletion).--Rebalancing: CASE RR---------------------- Consider inserting into the right subtree of the right subtree (RR subtree). From the obsevations above we can- say this is only going to unbalance the root if:- The height of the RR subtree is increased by 1 (we determine this from looking at changes in it's BF)- ..and.. The right subtree has BF=0 prior to insertion (observation 5)- ..and.. THe root has BF=-1 prior to insertion (observation 2)-- In pictures..-- ----- ----- ------ | B | | B | | D |- |H=h+2| |H=h+3| |H=h+2| <- Note- |BF=-1| |BF=-2| <-- Unbalanced! |BF= 0| <- Note- /-----\ /-----\ /-----\- / \ / \ / \- / \ / \ / \- -----/ \----- -----/ \----- -----/ \------ | A | | D | E grows | A | | D | Rebalance | B | | E |- | H=h | |H=h+1| by 1 | H=h | |H=h+2| --------> |H=h+1| |H=h+1|- | | |BF= 0| ------> | | |BF=-1| |BF= 0| | |- ----- /-----\ h -> h+1 ----- /-----\ /-----\ ------ / \ / \ / \- / \ / \ / \- -----/ \----- -----/ \----- -----/ \------ | C | | E | | C | | E | | A | | C |- | H=h | | H=h | | H=h | |H=h+1| | H=h | | H=h |- | | | | | | | | | | | |- ----- ----- ----- ----- ----- ------- Unfortunately, if you try this for insertion into the right left subtree (C) it doesn't work. To deal with- this case we need a more complicated re-balancing rotation involving 3 nodes. There are 2 distinct cases, which- both use the same rotation, but details re. BF and H are different.--Rebalancing: CASE RL(1)-------------------------- ----- ----- ------ | B | | B | | D |- |H=h+3| |H=h+4| |H=h+3| <- Note- |BF=-1| |BF=-2| <-- Unbalanced! |BF= 0| <- Note- /-----\ /-----\ /-----\- / \ / \ / \- / \ / \ / \- -----/ \----- -----/ \----- / \- | A | | F | E grows | A | | F | Rebalance -----/ \------ |H=h+1| |H=h+2| by 1 |H=h+1| |H=h+3| --------> | B | | F |- | | |BF= 0| ------> | | |BF=+1| |H=h+2| |H=h+2|- ----- /-----\ h -> h+1 ----- /-----\ |BF=+1| |BF= 0|- / \ / \ -----/-----\----- -----/-----\------ / \ / \ | A | | C | | E | | G |- -----/ \----- -----/ \----- |H=h+1| | H=h | |H=h+1| |H=h+1|- | D | | G | | D | | G | | | | | | | | |- |H=h+1| |H=h+1| |H=h+2| |H=h+1| ----- ----- ----- ------ |BF= 0| | | |BF=-1| | |- /-----\ ----- /-----\ ------ / \ / \- / \ / \- -----/ \----- -----/ \------ | C | | E | | C | | E |- | H=h | | H=h | | H=h | |H=h+1|- | | | | | | | |- ----- ----- ----- -------Rebalancing: CASE RL(2)-------------------------- ----- ----- ------ | B | | B | | D |- |H=h+3| |H=h+4| |H=h+3| <- Note- |BF=-1| |BF=-2| <-- Unbalanced! |BF= 0| <- Note- /-----\ /-----\ /-----\- / \ / \ / \- / \ / \ / \- -----/ \----- -----/ \----- / \- | A | | F | C grows | A | | F | Rebalance -----/ \------ |H=h+1| |H=h+2| by 1 |H=h+1| |H=h+3| --------> | B | | F |- | | |BF= 0| ------> | | |BF=+1| |H=h+2| |H=h+2|- ----- /-----\ h -> h+1 ----- /-----\ |BF= 0| |BF=-1|- / \ / \ -----/-----\----- -----/-----\------ / \ / \ | A | | C | | E | | G |- -----/ \----- -----/ \----- |H=h+1| |H=h+1| | H=h | |H=h+1|- | D | | G | | D | | G | | | | | | | | |- |H=h+1| |H=h+1| |H=h+2| |H=h+1| ----- ----- ----- ------ |BF= 0| | | |BF=+1| | |- /-----\ ----- /-----\ ------ / \ / \- / \ / \- -----/ \----- -----/ \------ | C | | E | | C | | E |- | H=h | | H=h | |H=h+1| | H=h |- | | | | | | | |- ----- ----- ----- -----------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------}---- | General push. This function searches the AVL tree using the supplied selector. If a matching element--- is found it's replaced by the value (@e@) returned in the @('Eq' e)@ constructor returned by the selector.--- If no match is found then the default element value is added at in the appropriate position in the tree.------ Note that for this to work properly requires that the selector behave as if it were comparing the--- (potentially) new default element with existing tree elements, even if it isn't.------ Note also that this function is /non-strict/ in it\'s second argument (the default value which--- is inserted if the search fails or is discarded if the search succeeds). If you want--- to force evaluation, but only if it\'s actually incorprated in the tree, then use 'push''------ Complexity: O(log n)-push :: (e -> COrdering e) -> e -> AVL e -> AVL e-push c e0 = put where -- there now follows a huge collection of functions requiring- -- pattern matching from hell in which c and e0 are free variables--- This may look longwinded, it's been done this way to..--- * Avoid doing case analysis on the same node more than once.--- * Minimise heap burn rate (by avoiding explicit rebalancing operations).- ----------------------------- LEVEL 0 ---------------------------------- -- put --- ------------------------------------------------------------------------ put E = Z E e0 E- put (N l e r) = putN l e r- put (Z l e r) = putZ l e r- put (P l e r) = putP l e r-- ----------------------------- LEVEL 1 ---------------------------------- -- putN, putZ, putP --- ------------------------------------------------------------------------- -- Put in (N l e r), BF=-1 , (never returns P)- putN l e r = case c e of- Lt -> putNL l e r -- <e, so put in L subtree- Eq e' -> N l e' r -- =e, so update existing- Gt -> putNR l e r -- >e, so put in R subtree-- -- Put in (Z l e r), BF= 0- putZ l e r = case c e of- Lt -> putZL l e r -- <e, so put in L subtree- Eq e' -> Z l e' r -- =e, so update existing- Gt -> putZR l e r -- >e, so put in R subtree-- -- Put in (P l e r), BF=+1 , (never returns N)- putP l e r = case c e of- Lt -> putPL l e r -- <e, so put in L subtree- Eq e' -> P l e' r -- =e, so update existing- Gt -> putPR l e r -- >e, so put in R subtree-- ----------------------------- LEVEL 2 ---------------------------------- -- putNL, putZL, putPL --- -- putNR, putZR, putPR --- ------------------------------------------------------------------------- -- (putNL l e r): Put in L subtree of (N l e r), BF=-1 (Never requires rebalancing) , (never returns P)- {-# INLINE putNL #-}- putNL E e r = Z (Z E e0 E ) e r -- L subtree empty, H:0->1, parent BF:-1-> 0- putNL (N ll le lr) e r = let l' = putN ll le lr -- L subtree BF<>0, H:h->h, parent BF:-1->-1- in l' `seq` N l' e r- putNL (P ll le lr) e r = let l' = putP ll le lr -- L subtree BF<>0, H:h->h, parent BF:-1->-1- in l' `seq` N l' e r- putNL (Z ll le lr) e r = let l' = putZ ll le lr -- L subtree BF= 0, so need to look for changes- in case l' of- E -> error "push: Bug0" -- impossible- Z _ _ _ -> N l' e r -- L subtree BF:0-> 0, H:h->h , parent BF:-1->-1- _ -> Z l' e r -- L subtree BF:0->+/-1, H:h->h+1, parent BF:-1-> 0-- -- (putZL l e r): Put in L subtree of (Z l e r), BF= 0 (Never requires rebalancing) , (never returns N)- {-# INLINE putZL #-}- putZL E e r = P (Z E e0 E ) e r -- L subtree H:0->1, parent BF: 0->+1- putZL (N ll le lr) e r = let l' = putN ll le lr -- L subtree BF<>0, H:h->h, parent BF: 0-> 0- in l' `seq` Z l' e r- putZL (P ll le lr) e r = let l' = putP ll le lr -- L subtree BF<>0, H:h->h, parent BF: 0-> 0- in l' `seq` Z l' e r- putZL (Z ll le lr) e r = let l' = putZ ll le lr -- L subtree BF= 0, so need to look for changes- in case l' of- E -> error "push: Bug1" -- impossible- Z _ _ _ -> Z l' e r -- L subtree BF: 0-> 0, H:h->h , parent BF: 0-> 0- _ -> P l' e r -- L subtree BF: 0->+/-1, H:h->h+1, parent BF: 0->+1-- -- (putZR l e r): Put in R subtree of (Z l e r), BF= 0 (Never requires rebalancing) , (never returns P)- {-# INLINE putZR #-}- putZR l e E = N l e (Z E e0 E ) -- R subtree H:0->1, parent BF: 0->-1- putZR l e (N rl re rr) = let r' = putN rl re rr -- R subtree BF<>0, H:h->h, parent BF: 0-> 0- in r' `seq` Z l e r'- putZR l e (P rl re rr) = let r' = putP rl re rr -- R subtree BF<>0, H:h->h, parent BF: 0-> 0- in r' `seq` Z l e r'- putZR l e (Z rl re rr) = let r' = putZ rl re rr -- R subtree BF= 0, so need to look for changes- in case r' of- E -> error "push: Bug2" -- impossible- Z _ _ _ -> Z l e r' -- R subtree BF: 0-> 0, H:h->h , parent BF: 0-> 0- _ -> N l e r' -- R subtree BF: 0->+/-1, H:h->h+1, parent BF: 0->-1-- -- (putPR l e r): Put in R subtree of (P l e r), BF=+1 (Never requires rebalancing) , (never returns N)- {-# INLINE putPR #-}- putPR l e E = Z l e (Z E e0 E ) -- R subtree empty, H:0->1, parent BF:+1-> 0- putPR l e (N rl re rr) = let r' = putN rl re rr -- R subtree BF<>0, H:h->h, parent BF:+1->+1- in r' `seq` P l e r'- putPR l e (P rl re rr) = let r' = putP rl re rr -- R subtree BF<>0, H:h->h, parent BF:+1->+1- in r' `seq` P l e r'- putPR l e (Z rl re rr) = let r' = putZ rl re rr -- R subtree BF= 0, so need to look for changes- in case r' of- E -> error "push: Bug3" -- impossible- Z _ _ _ -> P l e r' -- R subtree BF:0-> 0, H:h->h , parent BF:+1->+1- _ -> Z l e r' -- R subtree BF:0->+/-1, H:h->h+1, parent BF:+1-> 0-- -------- These 2 cases (NR and PL) may need rebalancing if they go to LEVEL 3 ----------- -- (putNR l e r): Put in R subtree of (N l e r), BF=-1 , (never returns P)- {-# INLINE putNR #-}- putNR _ _ E = error "push: Bug4" -- impossible if BF=-1- putNR l e (N rl re rr) = let r' = putN rl re rr -- R subtree BF<>0, H:h->h, parent BF:-1->-1- in r' `seq` N l e r'- putNR l e (P rl re rr) = let r' = putP rl re rr -- R subtree BF<>0, H:h->h, parent BF:-1->-1- in r' `seq` N l e r'- putNR l e (Z rl re rr) = case c re of -- determine if RR or RL- Lt -> putNRL l e rl re rr -- RL (never returns P)- Eq re' -> N l e (Z rl re' rr) -- new re- Gt -> putNRR l e rl re rr -- RR (never returns P)-- -- (putPL l e r): Put in L subtree of (P l e r), BF=+1 , (never returns N)- {-# INLINE putPL #-}- putPL E _ _ = error "push: Bug5" -- impossible if BF=+1- putPL (N ll le lr) e r = let l' = putN ll le lr -- L subtree BF<>0, H:h->h, parent BF:+1->+1- in l' `seq` P l' e r- putPL (P ll le lr) e r = let l' = putP ll le lr -- L subtree BF<>0, H:h->h, parent BF:+1->+1- in l' `seq` P l' e r- putPL (Z ll le lr) e r = case c le of -- determine if LL or LR- Lt -> putPLL ll le lr e r -- LL (never returns N)- Eq le' -> P (Z ll le' lr) e r -- new le- Gt -> putPLR ll le lr e r -- LR (never returns N)-- ----------------------------- LEVEL 3 ---------------------------------- -- putNRR, putPLL --- -- putNRL, putPLR --- ------------------------------------------------------------------------- -- (putNRR l e rl re rr): Put in RR subtree of (N l e (Z rl re rr)) , (never returns P)- {-# INLINE putNRR #-}- putNRR l e rl re E = Z (Z l e rl) re (Z E e0 E) -- l and rl must also be E, special CASE RR!!- putNRR l e rl re (N rrl rre rrr) = let rr' = putN rrl rre rrr -- RR subtree BF<>0, H:h->h, so no change- in rr' `seq` N l e (Z rl re rr')- putNRR l e rl re (P rrl rre rrr) = let rr' = putP rrl rre rrr -- RR subtree BF<>0, H:h->h, so no change- in rr' `seq` N l e (Z rl re rr')- putNRR l e rl re (Z rrl rre rrr) = let rr' = putZ rrl rre rrr -- RR subtree BF= 0, so need to look for changes- in case rr' of- E -> error "push: Bug6" -- impossible- Z _ _ _ -> N l e (Z rl re rr') -- RR subtree BF: 0-> 0, H:h->h, so no change- _ -> Z (Z l e rl) re rr' -- RR subtree BF: 0->+/-1, H:h->h+1, parent BF:-1->-2, CASE RR !!-- -- (putPLL ll le lr e r): Put in LL subtree of (P (Z ll le lr) e r) , (never returns N)- {-# INLINE putPLL #-}- putPLL E le lr e r = Z (Z E e0 E) le (Z lr e r) -- r and lr must also be E, special CASE LL!!- putPLL (N lll lle llr) le lr e r = let ll' = putN lll lle llr -- LL subtree BF<>0, H:h->h, so no change- in ll' `seq` P (Z ll' le lr) e r- putPLL (P lll lle llr) le lr e r = let ll' = putP lll lle llr -- LL subtree BF<>0, H:h->h, so no change- in ll' `seq` P (Z ll' le lr) e r- putPLL (Z lll lle llr) le lr e r = let ll' = putZ lll lle llr -- LL subtree BF= 0, so need to look for changes- in case ll' of- E -> error "push: Bug7" -- impossible- Z _ _ _ -> P (Z ll' le lr) e r -- LL subtree BF: 0-> 0, H:h->h, so no change- _ -> Z ll' le (Z lr e r) -- LL subtree BF: 0->+/-1, H:h->h+1, parent BF:-1->-2, CASE LL !!-- -- (putNRL l e rl re rr): Put in RL subtree of (N l e (Z rl re rr)) , (never returns P)- {-# INLINE putNRL #-}- putNRL l e E re rr = Z (Z l e E) e0 (Z E re rr) -- l and rr must also be E, special CASE LR !!- putNRL l e (N rll rle rlr) re rr = let rl' = putN rll rle rlr -- RL subtree BF<>0, H:h->h, so no change- in rl' `seq` N l e (Z rl' re rr)- putNRL l e (P rll rle rlr) re rr = let rl' = putP rll rle rlr -- RL subtree BF<>0, H:h->h, so no change- in rl' `seq` N l e (Z rl' re rr)- putNRL l e (Z rll rle rlr) re rr = let rl' = putZ rll rle rlr -- RL subtree BF= 0, so need to look for changes- in case rl' of- E -> error "push: Bug8" -- impossible- Z _ _ _ -> N l e (Z rl' re rr) -- RL subtree BF: 0-> 0, H:h->h, so no change- N rll' rle' rlr' -> Z (P l e rll') rle' (Z rlr' re rr) -- RL subtree BF: 0->-1, SO.. CASE RL(1) !!- P rll' rle' rlr' -> Z (Z l e rll') rle' (N rlr' re rr) -- RL subtree BF: 0->+1, SO.. CASE RL(2) !!-- -- (putPLR ll le lr e r): Put in LR subtree of (P (Z ll le lr) e r) , (never returns N)- {-# INLINE putPLR #-}- putPLR ll le E e r = Z (Z ll le E) e0 (Z E e r) -- r and ll must also be E, special CASE LR !!- putPLR ll le (N lrl lre lrr) e r = let lr' = putN lrl lre lrr -- LR subtree BF<>0, H:h->h, so no change- in lr' `seq` P (Z ll le lr') e r- putPLR ll le (P lrl lre lrr) e r = let lr' = putP lrl lre lrr -- LR subtree BF<>0, H:h->h, so no change- in lr' `seq` P (Z ll le lr') e r- putPLR ll le (Z lrl lre lrr) e r = let lr' = putZ lrl lre lrr -- LR subtree BF= 0, so need to look for changes- in case lr' of- E -> error "push: Bug9" -- impossible- Z _ _ _ -> P (Z ll le lr') e r -- LR subtree BF: 0-> 0, H:h->h, so no change- N lrl' lre' lrr' -> Z (P ll le lrl') lre' (Z lrr' e r) -- LR subtree BF: 0->-1, SO.. CASE LR(2) !!- P lrl' lre' lrr' -> Z (Z ll le lrl') lre' (N lrr' e r) -- LR subtree BF: 0->+1, SO.. CASE LR(1) !!-------------------------------------------------------------------------------------------------- push Ends Here -------------------------------------------------------------------------------------------------------- | Almost identical to 'push', but this version forces evaluation of the default new element--- (second argument) if no matching element is found. Note that it does /not/ do this if--- a matching element is found, because in this case the default new element is discarded--- anyway. Note also that it does not force evaluation of any replacement value provided by the--- selector (if it returns Eq). (You have to do that yourself if that\'s what you want.)------ Complexity: O(log n)-push' :: (e -> COrdering e) -> e -> AVL e -> AVL e-push' c e0 = put where- ----------------------------- LEVEL 0 ---------------------------------- -- put --- ------------------------------------------------------------------------ put E = e0 `seq` Z E e0 E- put (N l e r) = putN l e r- put (Z l e r) = putZ l e r- put (P l e r) = putP l e r-- ----------------------------- LEVEL 1 ---------------------------------- -- putN, putZ, putP --- ------------------------------------------------------------------------- -- Put in (N l e r), BF=-1 , (never returns P)- putN l e r = case c e of- Lt -> putNL l e r -- <e, so put in L subtree- Eq e' -> N l e' r -- =e, so update existing- Gt -> putNR l e r -- >e, so put in R subtree-- -- Put in (Z l e r), BF= 0- putZ l e r = case c e of- Lt -> putZL l e r -- <e, so put in L subtree- Eq e' -> Z l e' r -- =e, so update existing- Gt -> putZR l e r -- >e, so put in R subtree-- -- Put in (P l e r), BF=+1 , (never returns N)- putP l e r = case c e of- Lt -> putPL l e r -- <e, so put in L subtree- Eq e' -> P l e' r -- =e, so update existing- Gt -> putPR l e r -- >e, so put in R subtree-- ----------------------------- LEVEL 2 ---------------------------------- -- putNL, putZL, putPL --- -- putNR, putZR, putPR --- ------------------------------------------------------------------------- -- (putNL l e r): Put in L subtree of (N l e r), BF=-1 (Never requires rebalancing) , (never returns P)- {-# INLINE putNL #-}- putNL E e r = e0 `seq` Z (Z E e0 E ) e r -- L subtree empty, H:0->1, parent BF:-1-> 0- putNL (N ll le lr) e r = let l' = putN ll le lr -- L subtree BF<>0, H:h->h, parent BF:-1->-1- in l' `seq` N l' e r- putNL (P ll le lr) e r = let l' = putP ll le lr -- L subtree BF<>0, H:h->h, parent BF:-1->-1- in l' `seq` N l' e r- putNL (Z ll le lr) e r = let l' = putZ ll le lr -- L subtree BF= 0, so need to look for changes- in case l' of- E -> error "push': Bug0" -- impossible- Z _ _ _ -> N l' e r -- L subtree BF:0-> 0, H:h->h , parent BF:-1->-1- _ -> Z l' e r -- L subtree BF:0->+/-1, H:h->h+1, parent BF:-1-> 0-- -- (putZL l e r): Put in L subtree of (Z l e r), BF= 0 (Never requires rebalancing) , (never returns N)- {-# INLINE putZL #-}- putZL E e r = e0 `seq` P (Z E e0 E ) e r -- L subtree H:0->1, parent BF: 0->+1- putZL (N ll le lr) e r = let l' = putN ll le lr -- L subtree BF<>0, H:h->h, parent BF: 0-> 0- in l' `seq` Z l' e r- putZL (P ll le lr) e r = let l' = putP ll le lr -- L subtree BF<>0, H:h->h, parent BF: 0-> 0- in l' `seq` Z l' e r- putZL (Z ll le lr) e r = let l' = putZ ll le lr -- L subtree BF= 0, so need to look for changes- in case l' of- E -> error "push': Bug1" -- impossible- Z _ _ _ -> Z l' e r -- L subtree BF: 0-> 0, H:h->h , parent BF: 0-> 0- _ -> P l' e r -- L subtree BF: 0->+/-1, H:h->h+1, parent BF: 0->+1-- -- (putZR l e r): Put in R subtree of (Z l e r), BF= 0 (Never requires rebalancing) , (never returns P)- {-# INLINE putZR #-}- putZR l e E = e0 `seq` N l e (Z E e0 E) -- R subtree H:0->1, parent BF: 0->-1- putZR l e (N rl re rr) = let r' = putN rl re rr -- R subtree BF<>0, H:h->h, parent BF: 0-> 0- in r' `seq` Z l e r'- putZR l e (P rl re rr) = let r' = putP rl re rr -- R subtree BF<>0, H:h->h, parent BF: 0-> 0- in r' `seq` Z l e r'- putZR l e (Z rl re rr) = let r' = putZ rl re rr -- R subtree BF= 0, so need to look for changes- in case r' of- E -> error "push': Bug2" -- impossible- Z _ _ _ -> Z l e r' -- R subtree BF: 0-> 0, H:h->h , parent BF: 0-> 0- _ -> N l e r' -- R subtree BF: 0->+/-1, H:h->h+1, parent BF: 0->-1-- -- (putPR l e r): Put in R subtree of (P l e r), BF=+1 (Never requires rebalancing) , (never returns N)- {-# INLINE putPR #-}- putPR l e E = e0 `seq` Z l e (Z E e0 E) -- R subtree empty, H:0->1, parent BF:+1-> 0- putPR l e (N rl re rr) = let r' = putN rl re rr -- R subtree BF<>0, H:h->h, parent BF:+1->+1- in r' `seq` P l e r'- putPR l e (P rl re rr) = let r' = putP rl re rr -- R subtree BF<>0, H:h->h, parent BF:+1->+1- in r' `seq` P l e r'- putPR l e (Z rl re rr) = let r' = putZ rl re rr -- R subtree BF= 0, so need to look for changes- in case r' of- E -> error "push': Bug3" -- impossible- Z _ _ _ -> P l e r' -- R subtree BF:0-> 0, H:h->h , parent BF:+1->+1- _ -> Z l e r' -- R subtree BF:0->+/-1, H:h->h+1, parent BF:+1-> 0-- -------- These 2 cases (NR and PL) may need rebalancing if they go to LEVEL 3 ----------- -- (putNR l e r): Put in R subtree of (N l e r), BF=-1 , (never returns P)- {-# INLINE putNR #-}- putNR _ _ E = error "push': Bug4" -- impossible if BF=-1- putNR l e (N rl re rr) = let r' = putN rl re rr -- R subtree BF<>0, H:h->h, parent BF:-1->-1- in r' `seq` N l e r'- putNR l e (P rl re rr) = let r' = putP rl re rr -- R subtree BF<>0, H:h->h, parent BF:-1->-1- in r' `seq` N l e r'- putNR l e (Z rl re rr) = case c re of -- determine if RR or RL- Lt -> putNRL l e rl re rr -- RL (never returns P)- Eq re' -> N l e (Z rl re' rr) -- new re- Gt -> putNRR l e rl re rr -- RR (never returns P)-- -- (putPL l e r): Put in L subtree of (P l e r), BF=+1 , (never returns N)- {-# INLINE putPL #-}- putPL E _ _ = error "push': Bug5" -- impossible if BF=+1- putPL (N ll le lr) e r = let l' = putN ll le lr -- L subtree BF<>0, H:h->h, parent BF:+1->+1- in l' `seq` P l' e r- putPL (P ll le lr) e r = let l' = putP ll le lr -- L subtree BF<>0, H:h->h, parent BF:+1->+1- in l' `seq` P l' e r- putPL (Z ll le lr) e r = case c le of -- determine if LL or LR- Lt -> putPLL ll le lr e r -- LL (never returns N)- Eq le' -> P (Z ll le' lr) e r -- new le- Gt -> putPLR ll le lr e r -- LR (never returns N)-- ----------------------------- LEVEL 3 ---------------------------------- -- putNRR, putPLL --- -- putNRL, putPLR --- ------------------------------------------------------------------------- -- (putNRR l e rl re rr): Put in RR subtree of (N l e (Z rl re rr)) , (never returns P)- {-# INLINE putNRR #-}- putNRR l e rl re E = e0 `seq` Z (Z l e rl) re (Z E e0 E) -- l and rl must also be E, special CASE RR!!- putNRR l e rl re (N rrl rre rrr) = let rr' = putN rrl rre rrr -- RR subtree BF<>0, H:h->h, so no change- in rr' `seq` N l e (Z rl re rr')- putNRR l e rl re (P rrl rre rrr) = let rr' = putP rrl rre rrr -- RR subtree BF<>0, H:h->h, so no change- in rr' `seq` N l e (Z rl re rr')- putNRR l e rl re (Z rrl rre rrr) = let rr' = putZ rrl rre rrr -- RR subtree BF= 0, so need to look for changes- in case rr' of- E -> error "push': Bug6" -- impossible- Z _ _ _ -> N l e (Z rl re rr') -- RR subtree BF: 0-> 0, H:h->h, so no change- _ -> Z (Z l e rl) re rr' -- RR subtree BF: 0->+/-1, H:h->h+1, parent BF:-1->-2, CASE RR !!-- -- (putPLL ll le lr e r): Put in LL subtree of (P (Z ll le lr) e r) , (never returns N)- {-# INLINE putPLL #-}- putPLL E le lr e r = e0 `seq` Z (Z E e0 E) le (Z lr e r) -- r and lr must also be E, special CASE LL!!- putPLL (N lll lle llr) le lr e r = let ll' = putN lll lle llr -- LL subtree BF<>0, H:h->h, so no change- in ll' `seq` P (Z ll' le lr) e r- putPLL (P lll lle llr) le lr e r = let ll' = putP lll lle llr -- LL subtree BF<>0, H:h->h, so no change- in ll' `seq` P (Z ll' le lr) e r- putPLL (Z lll lle llr) le lr e r = let ll' = putZ lll lle llr -- LL subtree BF= 0, so need to look for changes- in case ll' of- E -> error "push': Bug7" -- impossible- Z _ _ _ -> P (Z ll' le lr) e r -- LL subtree BF: 0-> 0, H:h->h, so no change- _ -> Z ll' le (Z lr e r) -- LL subtree BF: 0->+/-1, H:h->h+1, parent BF:-1->-2, CASE LL !!-- -- (putNRL l e rl re rr): Put in RL subtree of (N l e (Z rl re rr)) , (never returns P)- {-# INLINE putNRL #-}- putNRL l e E re rr = e0 `seq` Z (Z l e E) e0 (Z E re rr) -- l and rr must also be E, special CASE LR !!- putNRL l e (N rll rle rlr) re rr = let rl' = putN rll rle rlr -- RL subtree BF<>0, H:h->h, so no change- in rl' `seq` N l e (Z rl' re rr)- putNRL l e (P rll rle rlr) re rr = let rl' = putP rll rle rlr -- RL subtree BF<>0, H:h->h, so no change- in rl' `seq` N l e (Z rl' re rr)- putNRL l e (Z rll rle rlr) re rr = let rl' = putZ rll rle rlr -- RL subtree BF= 0, so need to look for changes- in case rl' of- E -> error "push': Bug8" -- impossible- Z _ _ _ -> N l e (Z rl' re rr) -- RL subtree BF: 0-> 0, H:h->h, so no change- N rll' rle' rlr' -> Z (P l e rll') rle' (Z rlr' re rr) -- RL subtree BF: 0->-1, SO.. CASE RL(1) !!- P rll' rle' rlr' -> Z (Z l e rll') rle' (N rlr' re rr) -- RL subtree BF: 0->+1, SO.. CASE RL(2) !!-- -- (putPLR ll le lr e r): Put in LR subtree of (P (Z ll le lr) e r) , (never returns N)- {-# INLINE putPLR #-}- putPLR ll le E e r = e0 `seq` Z (Z ll le E) e0 (Z E e r) -- r and ll must also be E, special CASE LR !!- putPLR ll le (N lrl lre lrr) e r = let lr' = putN lrl lre lrr -- LR subtree BF<>0, H:h->h, so no change- in lr' `seq` P (Z ll le lr') e r- putPLR ll le (P lrl lre lrr) e r = let lr' = putP lrl lre lrr -- LR subtree BF<>0, H:h->h, so no change- in lr' `seq` P (Z ll le lr') e r- putPLR ll le (Z lrl lre lrr) e r = let lr' = putZ lrl lre lrr -- LR subtree BF= 0, so need to look for changes- in case lr' of- E -> error "push': Bug9" -- impossible- Z _ _ _ -> P (Z ll le lr') e r -- LR subtree BF: 0-> 0, H:h->h, so no change- N lrl' lre' lrr' -> Z (P ll le lrl') lre' (Z lrr' e r) -- LR subtree BF: 0->-1, SO.. CASE LR(2) !!- P lrl' lre' lrr' -> Z (Z ll le lrl') lre' (N lrr' e r) -- LR subtree BF: 0->+1, SO.. CASE LR(1) !!-------------------------------------------------------------------------------------------------- push' Ends Here -------------------------------------------------------------------------------------------------------- | Similar to 'push', but returns the original tree if the combining comparison returns--- @('Eq' 'Nothing')@. So this function can be used reduce heap burn rate by avoiding duplication--- of nodes on the insertion path. But it may also be marginally slower otherwise.------ Note that this function is /non-strict/ in it\'s second argument (the default value which--- is inserted in the search fails or is discarded if the search succeeds). If you want--- to force evaluation, but only if it\'s actually incorprated in the tree, then use 'pushMaybe''------ Complexity: O(log n)-pushMaybe :: (e -> COrdering (Maybe e)) -> e -> AVL e -> AVL e-pushMaybe c e t = case openPathWith c t of- FullBP _ Nothing -> t- FullBP p (Just e') -> writePath p e' t- EmptyBP p -> insertPath p e t---- | Almost identical to 'pushMaybe', but this version forces evaluation of the default new element--- (second argument) if no matching element is found. Note that it does /not/ do this if--- a matching element is found, because in this case the default new element is discarded--- anyway.------ Complexity: O(log n)-pushMaybe' :: (e -> COrdering (Maybe e)) -> e -> AVL e -> AVL e-pushMaybe' c e t = case openPathWith c t of- FullBP _ Nothing -> t- FullBP p (Just e') -> writePath p e' t- EmptyBP p -> e `seq` insertPath p e t---- | Push a new element in the leftmost position of an AVL tree. No comparison or searching is involved.------ Complexity: O(log n)-pushL :: e -> AVL e -> AVL e-pushL e0 = pushL' where -- There now follows a cut down version of the more general put.- -- Insertion is always on the left subtree.- -- Re-Balancing cases RR,RL/LR(1/2) never occur. Only LL!- -- There are also more impossible cases (putZL never returns N)- ----------------------------- LEVEL 0 ---------------------------------- -- pushL' --- ------------------------------------------------------------------------ pushL' E = Z E e0 E- pushL' (N l e r) = putNL l e r- pushL' (Z l e r) = putZL l e r- pushL' (P l e r) = putPL l e r-- ----------------------------- LEVEL 2 ---------------------------------- -- putNL, putZL, putPL --- ------------------------------------------------------------------------- -- (putNL l e r): Put in L subtree of (N l e r), BF=-1 (Never requires rebalancing) , (never returns P)- putNL E e r = Z (Z E e0 E) e r -- L subtree empty, H:0->1, parent BF:-1-> 0- putNL (N ll le lr) e r = let l' = putNL ll le lr -- L subtree BF<>0, H:h->h, parent BF:-1->-1- in l' `seq` N l' e r- putNL (P ll le lr) e r = let l' = putPL ll le lr -- L subtree BF<>0, H:h->h, parent BF:-1->-1- in l' `seq` N l' e r- putNL (Z ll le lr) e r = let l' = putZL ll le lr -- L subtree BF= 0, so need to look for changes- in case l' of- Z _ _ _ -> N l' e r -- L subtree BF:0-> 0, H:h->h , parent BF:-1->-1- P _ _ _ -> Z l' e r -- L subtree BF:0->+1, H:h->h+1, parent BF:-1-> 0- _ -> error "pushL: Bug0" -- impossible-- -- (putZL l e r): Put in L subtree of (Z l e r), BF= 0 (Never requires rebalancing) , (never returns N)- putZL E e r = P (Z E e0 E) e r -- L subtree H:0->1, parent BF: 0->+1- putZL (N ll le lr) e r = let l' = putNL ll le lr -- L subtree BF<>0, H:h->h, parent BF: 0-> 0- in l' `seq` Z l' e r- putZL (P ll le lr) e r = let l' = putPL ll le lr -- L subtree BF<>0, H:h->h, parent BF: 0-> 0- in l' `seq` Z l' e r- putZL (Z ll le lr) e r = let l' = putZL ll le lr -- L subtree BF= 0, so need to look for changes- in case l' of- Z _ _ _ -> Z l' e r -- L subtree BF: 0-> 0, H:h->h , parent BF: 0-> 0- N _ _ _ -> error "pushL: Bug1" -- impossible- _ -> P l' e r -- L subtree BF: 0->+1, H:h->h+1, parent BF: 0->+1-- -------- This case (PL) may need rebalancing if it goes to LEVEL 3 ----------- -- (putPL l e r): Put in L subtree of (P l e r), BF=+1 , (never returns N)- putPL E _ _ = error "pushL: Bug2" -- impossible if BF=+1- putPL (N ll le lr) e r = let l' = putNL ll le lr -- L subtree BF<>0, H:h->h, parent BF:+1->+1- in l' `seq` P l' e r- putPL (P ll le lr) e r = let l' = putPL ll le lr -- L subtree BF<>0, H:h->h, parent BF:+1->+1- in l' `seq` P l' e r- putPL (Z ll le lr) e r = putPLL ll le lr e r -- LL (never returns N)-- ----------------------------- LEVEL 3 ---------------------------------- -- putPLL --- ------------------------------------------------------------------------- -- (putPLL ll le lr e r): Put in LL subtree of (P (Z ll le lr) e r) , (never returns N)- {-# INLINE putPLL #-}- putPLL E le lr e r = Z (Z E e0 E) le (Z lr e r) -- r and lr must also be E, special CASE LL!!- putPLL (N lll lle llr) le lr e r = let ll' = putNL lll lle llr -- LL subtree BF<>0, H:h->h, so no change- in ll' `seq` P (Z ll' le lr) e r- putPLL (P lll lle llr) le lr e r = let ll' = putPL lll lle llr -- LL subtree BF<>0, H:h->h, so no change- in ll' `seq` P (Z ll' le lr) e r- putPLL (Z lll lle llr) le lr e r = let ll' = putZL lll lle llr -- LL subtree BF= 0, so need to look for changes- in case ll' of- Z _ _ _ -> P (Z ll' le lr) e r -- LL subtree BF: 0-> 0, H:h->h, so no change- N _ _ _ -> error "pushL: Bug3" -- impossible- _ -> Z ll' le (Z lr e r) -- LL subtree BF: 0->+1, H:h->h+1, parent BF:-1->-2, CASE LL !!---------------------------------------------------------------------------------------------------- pushL Ends Here -------------------------------------------------------------------------------------------------------- | Push a new element in the rightmost position of an AVL tree. No comparison or searching is involved.------ Complexity: O(log n)-pushR :: AVL e -> e -> AVL e-pushR t e0 = pushR' t where -- There now follows a cut down version of the more general put.- -- Insertion is always on the right subtree.- -- Re-Balancing cases LL,RL/LR(1/2) never occur. Only RR!- -- There are also more impossible cases (putZR never returns P)-- ----------------------------- LEVEL 0 ---------------------------------- -- pushR' --- ------------------------------------------------------------------------ pushR' E = Z E e0 E- pushR' (N l e r) = putNR l e r- pushR' (Z l e r) = putZR l e r- pushR' (P l e r) = putPR l e r-- ----------------------------- LEVEL 2 ---------------------------------- -- putNR, putZR, putPR --- ------------------------------------------------------------------------- -- (putZR l e r): Put in R subtree of (Z l e r), BF= 0 (Never requires rebalancing) , (never returns P)- putZR l e E = N l e (Z E e0 E) -- R subtree H:0->1, parent BF: 0->-1- putZR l e (N rl re rr) = let r' = putNR rl re rr -- R subtree BF<>0, H:h->h, parent BF: 0-> 0- in r' `seq` Z l e r'- putZR l e (P rl re rr) = let r' = putPR rl re rr -- R subtree BF<>0, H:h->h, parent BF: 0-> 0- in r' `seq` Z l e r'- putZR l e (Z rl re rr) = let r' = putZR rl re rr -- R subtree BF= 0, so need to look for changes- in case r' of- Z _ _ _ -> Z l e r' -- R subtree BF: 0-> 0, H:h->h , parent BF: 0-> 0- N _ _ _ -> N l e r' -- R subtree BF: 0->-1, H:h->h+1, parent BF: 0->-1- _ -> error "pushR: Bug0" -- impossible-- -- (putPR l e r): Put in R subtree of (P l e r), BF=+1 (Never requires rebalancing) , (never returns N)- putPR l e E = Z l e (Z E e0 E) -- R subtree empty, H:0->1, parent BF:+1-> 0- putPR l e (N rl re rr) = let r' = putNR rl re rr -- R subtree BF<>0, H:h->h, parent BF:+1->+1- in r' `seq` P l e r'- putPR l e (P rl re rr) = let r' = putPR rl re rr -- R subtree BF<>0, H:h->h, parent BF:+1->+1- in r' `seq` P l e r'- putPR l e (Z rl re rr) = let r' = putZR rl re rr -- R subtree BF= 0, so need to look for changes- in case r' of- Z _ _ _ -> P l e r' -- R subtree BF:0-> 0, H:h->h , parent BF:+1->+1- N _ _ _ -> Z l e r' -- R subtree BF:0->-1, H:h->h+1, parent BF:+1-> 0- _ -> error "pushR: Bug1" -- impossible-- -------- This case (NR) may need rebalancing if it goes to LEVEL 3 ----------- -- (putNR l e r): Put in R subtree of (N l e r), BF=-1 , (never returns P)- putNR _ _ E = error "pushR: Bug2" -- impossible if BF=-1- putNR l e (N rl re rr) = let r' = putNR rl re rr -- R subtree BF<>0, H:h->h, parent BF:-1->-1- in r' `seq` N l e r'- putNR l e (P rl re rr) = let r' = putPR rl re rr -- R subtree BF<>0, H:h->h, parent BF:-1->-1- in r' `seq` N l e r'- putNR l e (Z rl re rr) = putNRR l e rl re rr -- RR (never returns P)-- ----------------------------- LEVEL 3 ---------------------------------- -- putNRR --- ------------------------------------------------------------------------- -- (putNRR l e rl re rr): Put in RR subtree of (N l e (Z rl re rr)) , (never returns P)- {-# INLINE putNRR #-}- putNRR l e rl re E = Z (Z l e rl) re (Z E e0 E) -- l and rl must also be E, special CASE RR!!- putNRR l e rl re (N rrl rre rrr) = let rr' = putNR rrl rre rrr -- RR subtree BF<>0, H:h->h, so no change- in rr' `seq` N l e (Z rl re rr')- putNRR l e rl re (P rrl rre rrr) = let rr' = putPR rrl rre rrr -- RR subtree BF<>0, H:h->h, so no change- in rr' `seq` N l e (Z rl re rr')- putNRR l e rl re (Z rrl rre rrr) = let rr' = putZR rrl rre rrr -- RR subtree BF= 0, so need to look for changes- in case rr' of- Z _ _ _ -> N l e (Z rl re rr') -- RR subtree BF: 0-> 0, H:h->h, so no change- N _ _ _ -> Z (Z l e rl) re rr' -- RR subtree BF: 0->-1, H:h->h+1, parent BF:-1->-2, CASE RR !!- _ -> error "pushR: Bug3" -- impossible---------------------------------------------------------------------------------------------------- pushR Ends Here -----------------------------------------------------------------------------------------------------
− Data/Tree/AVL/Read.hs
@@ -1,168 +0,0 @@--------------------------------------------------------------------------------- |--- Module : Data.Tree.AVL.Read--- Copyright : (c) Adrian Hey 2004,2005--- License : BSD3------ Maintainer : http://homepages.nildram.co.uk/~ahey/em.png--- Stability : stable--- Portability : portable-------------------------------------------------------------------------------module Data.Tree.AVL.Read-(-- * Reading from AVL trees-- -- ** Reading from extreme left or right- assertReadL,tryReadL,- assertReadR,tryReadR,-- -- ** Reading from /sorted/ AVL trees- assertRead,tryRead,tryReadMaybe,defaultRead,-- -- ** Simple searches of /sorted/ AVL trees- contains,-) where--import Prelude -- so haddock finds the symbols there--import Data.COrdering-import Data.Tree.AVL.Types(AVL(..))---- | Read the leftmost element from a /non-empty/ tree. Raises an error if the tree is empty.--- If the tree is sorted this will return the least element.------ Complexity: O(log n)-assertReadL :: AVL e -> e-assertReadL E = error "assertReadL: Empty tree."-assertReadL (N l e _) = readLE l e-assertReadL (Z l e _) = readLE l e-assertReadL (P l _ _) = readLNE l -- BF=+1, so left sub-tree cannot be empty.---- | Similar to 'assertReadL' but returns 'Nothing' if the tree is empty.------ Complexity: O(log n)-tryReadL :: AVL e -> Maybe e-tryReadL E = Nothing-tryReadL (N l e _) = Just $! readLE l e-tryReadL (Z l e _) = Just $! readLE l e-tryReadL (P l _ _) = Just $! readLNE l -- BF=+1, so left sub-tree cannot be empty.---- Local utilities for the above-readLNE :: AVL e -> e-readLNE E = error "readLNE: Bug."-readLNE (N l e _) = readLE l e-readLNE (Z l e _) = readLE l e-readLNE (P l _ _) = readLNE l -- BF=+1, so left sub-tree cannot be empty.-readLE :: AVL e -> e -> e-readLE E e = e-readLE (N l e _) _ = readLE l e-readLE (Z l e _) _ = readLE l e-readLE (P l _ _) _ = readLNE l -- BF=+1, so left sub-tree cannot be empty.----- | Read the rightmost element from a /non-empty/ tree. Raises an error if the tree is empty.--- If the tree is sorted this will return the greatest element.------ Complexity: O(log n)-assertReadR :: AVL e -> e-assertReadR E = error "assertReadR: Empty tree."-assertReadR (P _ e r) = readRE r e-assertReadR (Z _ e r) = readRE r e-assertReadR (N _ _ r) = readRNE r -- BF=-1, so right sub-tree cannot be empty.---- | Similar to 'assertReadR' but returns 'Nothing' if the tree is empty.------ Complexity: O(log n)-tryReadR :: AVL e -> Maybe e-tryReadR E = Nothing-tryReadR (P _ e r) = Just $! readRE r e-tryReadR (Z _ e r) = Just $! readRE r e-tryReadR (N _ _ r) = Just $! readRNE r -- BF=-1, so right sub-tree cannot be empty.---- Local utilities for the above-readRNE :: AVL e -> e-readRNE E = error "readRNE: Bug."-readRNE (P _ e r) = readRE r e-readRNE (Z _ e r) = readRE r e-readRNE (N _ _ r) = readRNE r -- BF=-1, so right sub-tree cannot be empty.-readRE :: AVL e -> e -> e-readRE E e = e-readRE (P _ e r) _ = readRE r e-readRE (Z _ e r) _ = readRE r e-readRE (N _ _ r) _ = readRNE r -- BF=-1, so right sub-tree cannot be empty.----- | General purpose function to perform a search of a sorted tree, using the supplied selector.--- This function raises a error if the search fails.------ Complexity: O(log n)-assertRead :: AVL e -> (e -> COrdering a) -> a-assertRead t c = genRead' t where- genRead' E = error "assertRead failed."- genRead' (N l e r) = genRead'' l e r- genRead' (Z l e r) = genRead'' l e r- genRead' (P l e r) = genRead'' l e r- genRead'' l e r = case c e of- Lt -> genRead' l- Eq a -> a- Gt -> genRead' r---- | General purpose function to perform a search of a sorted tree, using the supplied selector.--- This function is similar to 'assertRead', but returns 'Nothing' if the search failed.------ Complexity: O(log n)-tryRead :: AVL e -> (e -> COrdering a) -> Maybe a-tryRead t c = tryRead' t where- tryRead' E = Nothing- tryRead' (N l e r) = tryRead'' l e r- tryRead' (Z l e r) = tryRead'' l e r- tryRead' (P l e r) = tryRead'' l e r- tryRead'' l e r = case c e of- Lt -> tryRead' l- Eq a -> Just a- Gt -> tryRead' r---- | This version returns the result of the selector (without adding a 'Just' wrapper) if the search--- succeeds, or 'Nothing' if it fails.------ Complexity: O(log n)-tryReadMaybe :: AVL e -> (e -> COrdering (Maybe a)) -> Maybe a-tryReadMaybe t c = tryRead' t where- tryRead' E = Nothing- tryRead' (N l e r) = tryRead'' l e r- tryRead' (Z l e r) = tryRead'' l e r- tryRead' (P l e r) = tryRead'' l e r- tryRead'' l e r = case c e of- Lt -> tryRead' l- Eq mba -> mba- Gt -> tryRead' r---- | General purpose function to perform a search of a sorted tree, using the supplied selector.--- This function is similar to 'assertRead', but returns a the default value (first argument) if--- the search fails.------ Complexity: O(log n)-defaultRead :: a -> AVL e -> (e -> COrdering a) -> a-defaultRead d t c = genRead' t where- genRead' E = d- genRead' (N l e r) = genRead'' l e r- genRead' (Z l e r) = genRead'' l e r- genRead' (P l e r) = genRead'' l e r- genRead'' l e r = case c e of- Lt -> genRead' l- Eq a -> a- Gt -> genRead' r---- | General purpose function to perform a search of a sorted tree, using the supplied selector.--- Returns True if matching element is found.------ Complexity: O(log n)-contains :: AVL e -> (e -> Ordering) -> Bool-contains t c = contains' t where- contains' E = False- contains' (N l e r) = contains'' l e r- contains' (Z l e r) = contains'' l e r- contains' (P l e r) = contains'' l e r- contains'' l e r = case c e of- LT -> contains' l- EQ -> True- GT -> contains' r
− Data/Tree/AVL/Set.hs
@@ -1,618 +0,0 @@-{-# OPTIONS_GHC -fglasgow-exts #-}--------------------------------------------------------------------------------- |--- Module : Data.Tree.AVL.Set--- Copyright : (c) Adrian Hey 2004,2005--- License : BSD3------ Maintainer : http://homepages.nildram.co.uk/~ahey/em.png--- Stability : stable--- Portability : portable-------------------------------------------------------------------------------module Data.Tree.AVL.Set-(-- * Set operations- -- | Functions for manipulating AVL trees which represent ordered sets (I.E. /sorted/ trees).- -- Note that although many of these functions work with a variety of different element- -- types they all require that elements are sorted according to the same criterion (such- -- as a field value in a record).-- -- ** Union- union,unionMaybe,disjointUnion,unions,-- -- ** Difference- difference,differenceMaybe,symDifference,-- -- ** Intersection- intersection,intersectionMaybe,-- -- *** Intersection with the result as a list- -- | Sometimes you don\'t want intersection to give a tree, particularly if the- -- resulting elements are not orderered or sorted according to whatever criterion was- -- used to sort the elements of the input sets.- --- -- The reason these variants are provided for intersection only (and not the other- -- set functions) is that the (tree returning) intersections always construct an entirely- -- new tree, whereas with the others the resulting tree will typically share sub-trees- -- with one or both of the originals. (Of course the results of the others can easily be- -- converted to a list too if required.)- intersectionToList,intersectionAsList,- intersectionMaybeToList,intersectionMaybeAsList,-- -- ** \'Venn diagram\' operations- -- | Given two sets A and B represented as sorted AVL trees, the venn operations evaluate- -- components @A-B@, @A.B@ and @B-A@. The intersection part may be obtained as a List- -- rather than AVL tree if required.- --- -- Note that in all cases the three resulting sets are /disjoint/ and can safely be re-combined- -- after most \"munging\" operations using 'disjointUnion'.- venn,vennMaybe,-- -- *** \'Venn diagram\' operations with the intersection component as a List.- -- | These variants are provided for the same reasons as the Intersection as List variants.- vennToList,vennAsList,- vennMaybeToList,vennMaybeAsList,-- -- ** Subset- isSubsetOf,isSubsetOfBy,-) where--import Prelude -- so haddock finds the symbols there--import Data.Tree.AVL.Types(AVL(..))-import Data.Tree.AVL.Height(addHeight)-import Data.Tree.AVL.List(asTreeLenL)-import Data.Tree.AVL.Internals.HJoin(spliceH)-import Data.Tree.AVL.Internals.HSet(unionH,unionMaybeH,disjointUnionH,- intersectionH,intersectionMaybeH,- vennH,vennMaybeH,- differenceH,differenceMaybeH,symDifferenceH)--import Data.COrdering--#ifdef __GLASGOW_HASKELL__-import GHC.Base-#include "ghcdefs.h"-#else-#include "h98defs.h"-#endif---- | Uses the supplied combining comparison to evaluate the union of two sets represented as--- sorted AVL trees. Whenever the combining comparison is applied, the first comparison argument is--- an element of the first tree and the second comparison argument is an element of the second tree.------ Complexity: Not sure, but I\'d appreciate it if someone could figure it out.-union :: (e -> e -> COrdering e) -> AVL e -> AVL e -> AVL e-union c = gu where -- This is to avoid O(log n) height calculation for empty sets- gu E t1 = t1- gu t0 E = t0- gu t0@(N l0 _ _ ) t1@(N l1 _ _ ) = gu_ t0 (addHeight L(2) l0) t1 (addHeight L(2) l1)- gu t0@(N l0 _ _ ) t1@(Z l1 _ _ ) = gu_ t0 (addHeight L(2) l0) t1 (addHeight L(1) l1)- gu t0@(N l0 _ _ ) t1@(P _ _ r1) = gu_ t0 (addHeight L(2) l0) t1 (addHeight L(2) r1)- gu t0@(Z l0 _ _ ) t1@(N l1 _ _ ) = gu_ t0 (addHeight L(1) l0) t1 (addHeight L(2) l1)- gu t0@(Z l0 _ _ ) t1@(Z l1 _ _ ) = gu_ t0 (addHeight L(1) l0) t1 (addHeight L(1) l1)- gu t0@(Z l0 _ _ ) t1@(P _ _ r1) = gu_ t0 (addHeight L(1) l0) t1 (addHeight L(2) r1)- gu t0@(P _ _ r0) t1@(N l1 _ _ ) = gu_ t0 (addHeight L(2) r0) t1 (addHeight L(2) l1)- gu t0@(P _ _ r0) t1@(Z l1 _ _ ) = gu_ t0 (addHeight L(2) r0) t1 (addHeight L(1) l1)- gu t0@(P _ _ r0) t1@(P _ _ r1) = gu_ t0 (addHeight L(2) r0) t1 (addHeight L(2) r1)- gu_ t0 h0 t1 h1 = case unionH c t0 h0 t1 h1 of UBT2(t,_) -> t---- | Similar to 'union', but the resulting tree does not include elements in cases where--- the supplied combining comparison returns @(Eq Nothing)@.------ Complexity: Not sure, but I\'d appreciate it if someone could figure it out.-unionMaybe :: (e -> e -> COrdering (Maybe e)) -> AVL e -> AVL e -> AVL e-unionMaybe c = gu where -- This is to avoid O(log n) height calculation for empty sets- gu E t1 = t1- gu t0 E = t0- gu t0@(N l0 _ _ ) t1@(N l1 _ _ ) = gu_ t0 (addHeight L(2) l0) t1 (addHeight L(2) l1)- gu t0@(N l0 _ _ ) t1@(Z l1 _ _ ) = gu_ t0 (addHeight L(2) l0) t1 (addHeight L(1) l1)- gu t0@(N l0 _ _ ) t1@(P _ _ r1) = gu_ t0 (addHeight L(2) l0) t1 (addHeight L(2) r1)- gu t0@(Z l0 _ _ ) t1@(N l1 _ _ ) = gu_ t0 (addHeight L(1) l0) t1 (addHeight L(2) l1)- gu t0@(Z l0 _ _ ) t1@(Z l1 _ _ ) = gu_ t0 (addHeight L(1) l0) t1 (addHeight L(1) l1)- gu t0@(Z l0 _ _ ) t1@(P _ _ r1) = gu_ t0 (addHeight L(1) l0) t1 (addHeight L(2) r1)- gu t0@(P _ _ r0) t1@(N l1 _ _ ) = gu_ t0 (addHeight L(2) r0) t1 (addHeight L(2) l1)- gu t0@(P _ _ r0) t1@(Z l1 _ _ ) = gu_ t0 (addHeight L(2) r0) t1 (addHeight L(1) l1)- gu t0@(P _ _ r0) t1@(P _ _ r1) = gu_ t0 (addHeight L(2) r0) t1 (addHeight L(2) r1)- gu_ t0 h0 t1 h1 = case unionMaybeH c t0 h0 t1 h1 of UBT2(t,_) -> t---- | Uses the supplied comparison to evaluate the union of two /disjoint/ sets represented as--- sorted AVL trees. It will be slightly faster than 'union' but will raise an error if the--- two sets intersect. Typically this would be used to re-combine the \"post-munge\" results--- from one of the \"venn\" operations.------ Complexity: Not sure, but I\'d appreciate it if someone could figure it out.--- (Faster than Hedge union from Data.Set at any rate).-disjointUnion :: (e -> e -> Ordering) -> AVL e -> AVL e -> AVL e-disjointUnion c = gu where -- This is to avoid O(log n) height calculation for empty sets- gu E t1 = t1- gu t0 E = t0- gu t0@(N l0 _ _ ) t1@(N l1 _ _ ) = gu_ t0 (addHeight L(2) l0) t1 (addHeight L(2) l1)- gu t0@(N l0 _ _ ) t1@(Z l1 _ _ ) = gu_ t0 (addHeight L(2) l0) t1 (addHeight L(1) l1)- gu t0@(N l0 _ _ ) t1@(P _ _ r1) = gu_ t0 (addHeight L(2) l0) t1 (addHeight L(2) r1)- gu t0@(Z l0 _ _ ) t1@(N l1 _ _ ) = gu_ t0 (addHeight L(1) l0) t1 (addHeight L(2) l1)- gu t0@(Z l0 _ _ ) t1@(Z l1 _ _ ) = gu_ t0 (addHeight L(1) l0) t1 (addHeight L(1) l1)- gu t0@(Z l0 _ _ ) t1@(P _ _ r1) = gu_ t0 (addHeight L(1) l0) t1 (addHeight L(2) r1)- gu t0@(P _ _ r0) t1@(N l1 _ _ ) = gu_ t0 (addHeight L(2) r0) t1 (addHeight L(2) l1)- gu t0@(P _ _ r0) t1@(Z l1 _ _ ) = gu_ t0 (addHeight L(2) r0) t1 (addHeight L(1) l1)- gu t0@(P _ _ r0) t1@(P _ _ r1) = gu_ t0 (addHeight L(2) r0) t1 (addHeight L(2) r1)- gu_ t0 h0 t1 h1 = case disjointUnionH c t0 h0 t1 h1 of UBT2(t,_) -> t---- | Uses the supplied combining comparison to evaluate the union of all sets in a list--- of sets represented as sorted AVL trees. Behaves as if defined..------ @unions ccmp avls = foldl' ('union' ccmp) empty avls@-unions :: (e -> e -> COrdering e) -> [AVL e] -> AVL e-unions c = gus E L(0) where- gus a _ [] = a- gus a ha ( E :avls) = gus a ha avls- gus a ha (t@(N l _ _):avls) = case unionH c a ha t (addHeight L(2) l) of UBT2(a_,ha_) -> gus a_ ha_ avls- gus a ha (t@(Z l _ _):avls) = case unionH c a ha t (addHeight L(1) l) of UBT2(a_,ha_) -> gus a_ ha_ avls- gus a ha (t@(P _ _ r):avls) = case unionH c a ha t (addHeight L(2) r) of UBT2(a_,ha_) -> gus a_ ha_ avls---- | Uses the supplied combining comparison to evaluate the intersection of two sets represented as--- sorted AVL trees.------ Complexity: Not sure, but I\'d appreciate it if someone could figure it out.-intersection :: (a -> b -> COrdering c) -> AVL a -> AVL b -> AVL c-intersection c t0 t1 = case intersectionH c t0 t1 of UBT2(t,_) -> t---- | Similar to 'intersection', but the resulting tree does not include elements in cases where--- the supplied combining comparison returns @(Eq Nothing)@.------ Complexity: Not sure, but I\'d appreciate it if someone could figure it out.-intersectionMaybe :: (a -> b -> COrdering (Maybe c)) -> AVL a -> AVL b -> AVL c-intersectionMaybe c t0 t1 = case intersectionMaybeH c t0 t1 of UBT2(t,_) -> t---- | Similar to 'intersection', but prepends the result to the supplied list in--- ascending order. This is a (++) free function which behaves as if defined:------ @intersectionToList c setA setB cs = asListL (intersection c setA setB) ++ cs@------ Complexity: Not sure, but I\'d appreciate it if someone could figure it out.-intersectionToList :: (a -> b -> COrdering c) -> AVL a -> AVL b -> [c] -> [c]-intersectionToList comp = i where- -- i :: AVL a -> AVL b -> [c] -> [c]- i E _ cs = cs- i _ E cs = cs- i (N l0 e0 r0) (N l1 e1 r1) cs = i' l0 e0 r0 l1 e1 r1 cs- i (N l0 e0 r0) (Z l1 e1 r1) cs = i' l0 e0 r0 l1 e1 r1 cs- i (N l0 e0 r0) (P l1 e1 r1) cs = i' l0 e0 r0 l1 e1 r1 cs- i (Z l0 e0 r0) (N l1 e1 r1) cs = i' l0 e0 r0 l1 e1 r1 cs- i (Z l0 e0 r0) (Z l1 e1 r1) cs = i' l0 e0 r0 l1 e1 r1 cs- i (Z l0 e0 r0) (P l1 e1 r1) cs = i' l0 e0 r0 l1 e1 r1 cs- i (P l0 e0 r0) (N l1 e1 r1) cs = i' l0 e0 r0 l1 e1 r1 cs- i (P l0 e0 r0) (Z l1 e1 r1) cs = i' l0 e0 r0 l1 e1 r1 cs- i (P l0 e0 r0) (P l1 e1 r1) cs = i' l0 e0 r0 l1 e1 r1 cs- i' l0 e0 r0 l1 e1 r1 cs =- case comp e0 e1 of- -- e0 < e1, so (l0 < e0 < e1) & (e0 < e1 < r1)- Lt -> case forkR r0 e1 of- UBT5(rl0,_,mbc1,rr0,_) -> case forkL e0 l1 of -- (e0 < rl0 < e1) & (e0 < e1 < rr0)- UBT5(ll1,_,mbc0,lr1,_) -> -- (ll1 < e0 < e1) & (e0 < lr1 < e1)- -- (l0 + ll1) < e0 < (rl0 + lr1) < e1 < (rr0 + r1)- let cs' = i rr0 r1 cs- cs'' = cs' `seq` case mbc1 of- Nothing -> i rl0 lr1 cs'- Just c1 -> i rl0 lr1 (c1:cs')- in cs'' `seq` case mbc0 of- Nothing -> i l0 ll1 cs''- Just c0 -> i l0 ll1 (c0:cs'')- -- e0 = e1- Eq c -> let cs' = i r0 r1 cs in cs' `seq` i l0 l1 (c:cs')- -- e1 < e0, so (l1 < e1 < e0) & (e1 < e0 < r0)- Gt -> case forkL e0 r1 of- UBT5(rl1,_,mbc0,rr1,_) -> case forkR l0 e1 of -- (e1 < rl1 < e0) & (e1 < e0 < rr1)- UBT5(ll0,_,mbc1,lr0,_) -> -- (ll0 < e1 < e0) & (e1 < lr0 < e0)- -- (ll0 + l1) < e1 < (lr0 + rl1) < e0 < (r0 + rr1)- let cs' = i r0 rr1 cs- cs'' = cs' `seq` case mbc0 of- Nothing -> i lr0 rl1 cs'- Just c0 -> i lr0 rl1 (c0:cs')- in cs'' `seq` case mbc1 of- Nothing -> i ll0 l1 cs''- Just c1 -> i ll0 l1 (c1:cs'')- -- We need 2 different versions of fork (L & R) to ensure that comparison arguments are used in- -- the right order (c e0 e1)- -- forkL :: a -> AVL b -> UBT5(AVL b,UINT,Maybe c,AVL b,UINT)- forkL e0 t1 = forkL_ t1 L(0) where- forkL_ E h = UBT5(E,h,Nothing,E,h) -- Relative heights!!- forkL_ (N l e r) h = forkL__ l DECINT2(h) e r DECINT1(h)- forkL_ (Z l e r) h = forkL__ l DECINT1(h) e r DECINT1(h)- forkL_ (P l e r) h = forkL__ l DECINT1(h) e r DECINT2(h)- forkL__ l hl e r hr = case comp e0 e of- Lt -> case forkL_ l hl of- UBT5(l0,hl0,mbc0,l1,hl1) -> case spliceH l1 hl1 e r hr of- UBT2(l1_,hl1_) -> UBT5(l0,hl0,mbc0,l1_,hl1_)- Eq c0 -> UBT5(l,hl,Just c0,r,hr)- Gt -> case forkL_ r hr of- UBT5(l0,hl0,mbc0,l1,hl1) -> case spliceH l hl e l0 hl0 of- UBT2(l0_,hl0_) -> UBT5(l0_,hl0_,mbc0,l1,hl1)- -- forkR :: AVL a -> b -> UBT5(AVL a,UINT,Maybe c,AVL a,UINT)- forkR t0 e1 = forkR_ t0 L(0) where- forkR_ E h = UBT5(E,h,Nothing,E,h) -- Relative heights!!- forkR_ (N l e r) h = forkR__ l DECINT2(h) e r DECINT1(h)- forkR_ (Z l e r) h = forkR__ l DECINT1(h) e r DECINT1(h)- forkR_ (P l e r) h = forkR__ l DECINT1(h) e r DECINT2(h)- forkR__ l hl e r hr = case comp e e1 of- Lt -> case forkR_ r hr of- UBT5(l0,hl0,mbc1,l1,hl1) -> case spliceH l hl e l0 hl0 of- UBT2(l0_,hl0_) -> UBT5(l0_,hl0_,mbc1,l1,hl1)- Eq c1 -> UBT5(l,hl,Just c1,r,hr)- Gt -> case forkR_ l hl of- UBT5(l0,hl0,mbc1,l1,hl1) -> case spliceH l1 hl1 e r hr of- UBT2(l1_,hl1_) -> UBT5(l0,hl0,mbc1,l1_,hl1_)------------------------------------------------------------------------------------------- intersectionToList Ends Here ----------------------------------------------------------------------------------------------- | Applies 'intersectionToList' to the empty list.------ Complexity: Not sure, but I\'d appreciate it if someone could figure it out.-intersectionAsList :: (a -> b -> COrdering c) -> AVL a -> AVL b -> [c]-intersectionAsList c setA setB = intersectionToList c setA setB []---- | Similar to 'intersectionToList', but the result does not include elements in cases where--- the supplied combining comparison returns @(Eq Nothing)@.------ Complexity: Not sure, but I\'d appreciate it if someone could figure it out.-intersectionMaybeToList :: (a -> b -> COrdering (Maybe c)) -> AVL a -> AVL b -> [c] -> [c]-intersectionMaybeToList comp = i where- -- i :: AVL a -> AVL b -> [c] -> [c]- i E _ cs = cs- i _ E cs = cs- i (N l0 e0 r0) (N l1 e1 r1) cs = i' l0 e0 r0 l1 e1 r1 cs- i (N l0 e0 r0) (Z l1 e1 r1) cs = i' l0 e0 r0 l1 e1 r1 cs- i (N l0 e0 r0) (P l1 e1 r1) cs = i' l0 e0 r0 l1 e1 r1 cs- i (Z l0 e0 r0) (N l1 e1 r1) cs = i' l0 e0 r0 l1 e1 r1 cs- i (Z l0 e0 r0) (Z l1 e1 r1) cs = i' l0 e0 r0 l1 e1 r1 cs- i (Z l0 e0 r0) (P l1 e1 r1) cs = i' l0 e0 r0 l1 e1 r1 cs- i (P l0 e0 r0) (N l1 e1 r1) cs = i' l0 e0 r0 l1 e1 r1 cs- i (P l0 e0 r0) (Z l1 e1 r1) cs = i' l0 e0 r0 l1 e1 r1 cs- i (P l0 e0 r0) (P l1 e1 r1) cs = i' l0 e0 r0 l1 e1 r1 cs- i' l0 e0 r0 l1 e1 r1 cs =- case comp e0 e1 of- -- e0 < e1, so (l0 < e0 < e1) & (e0 < e1 < r1)- Lt -> case forkR r0 e1 of- UBT5(rl0,_,mbc1,rr0,_) -> case forkL e0 l1 of -- (e0 < rl0 < e1) & (e0 < e1 < rr0)- UBT5(ll1,_,mbc0,lr1,_) -> -- (ll1 < e0 < e1) & (e0 < lr1 < e1)- -- (l0 + ll1) < e0 < (rl0 + lr1) < e1 < (rr0 + r1)- let cs' = i rr0 r1 cs- cs'' = cs' `seq` case mbc1 of- Nothing -> i rl0 lr1 cs'- Just c1 -> i rl0 lr1 (c1:cs')- in cs'' `seq` case mbc0 of- Nothing -> i l0 ll1 cs''- Just c0 -> i l0 ll1 (c0:cs'')- -- e0 = e1- Eq mbc -> let cs' = i r0 r1 cs in cs' `seq` case mbc of- Nothing -> i l0 l1 cs'- Just c -> i l0 l1 (c:cs')- -- e1 < e0, so (l1 < e1 < e0) & (e1 < e0 < r0)- Gt -> case forkL e0 r1 of- UBT5(rl1,_,mbc0,rr1,_) -> case forkR l0 e1 of -- (e1 < rl1 < e0) & (e1 < e0 < rr1)- UBT5(ll0,_,mbc1,lr0,_) -> -- (ll0 < e1 < e0) & (e1 < lr0 < e0)- -- (ll0 + l1) < e1 < (lr0 + rl1) < e0 < (r0 + rr1)- let cs' = i r0 rr1 cs- cs'' = cs' `seq` case mbc0 of- Nothing -> i lr0 rl1 cs'- Just c0 -> i lr0 rl1 (c0:cs')- in cs'' `seq` case mbc1 of- Nothing -> i ll0 l1 cs''- Just c1 -> i ll0 l1 (c1:cs'')- -- We need 2 different versions of fork (L & R) to ensure that comparison arguments are used in- -- the right order (c e0 e1)- -- forkL :: a -> AVL b -> UBT5(AVL b,UINT,Maybe c,AVL b,UINT)- forkL e0 t1 = forkL_ t1 L(0) where- forkL_ E h = UBT5(E,h,Nothing,E,h) -- Relative heights!!- forkL_ (N l e r) h = forkL__ l DECINT2(h) e r DECINT1(h)- forkL_ (Z l e r) h = forkL__ l DECINT1(h) e r DECINT1(h)- forkL_ (P l e r) h = forkL__ l DECINT1(h) e r DECINT2(h)- forkL__ l hl e r hr = case comp e0 e of- Lt -> case forkL_ l hl of- UBT5(l0,hl0,mbc0,l1,hl1) -> case spliceH l1 hl1 e r hr of- UBT2(l1_,hl1_) -> UBT5(l0,hl0,mbc0,l1_,hl1_)- Eq mbc0 -> UBT5(l,hl,mbc0,r,hr)- Gt -> case forkL_ r hr of- UBT5(l0,hl0,mbc0,l1,hl1) -> case spliceH l hl e l0 hl0 of- UBT2(l0_,hl0_) -> UBT5(l0_,hl0_,mbc0,l1,hl1)- -- forkR :: AVL a -> b -> UBT5(AVL a,UINT,Maybe c,AVL a,UINT)- forkR t0 e1 = forkR_ t0 L(0) where- forkR_ E h = UBT5(E,h,Nothing,E,h) -- Relative heights!!- forkR_ (N l e r) h = forkR__ l DECINT2(h) e r DECINT1(h)- forkR_ (Z l e r) h = forkR__ l DECINT1(h) e r DECINT1(h)- forkR_ (P l e r) h = forkR__ l DECINT1(h) e r DECINT2(h)- forkR__ l hl e r hr = case comp e e1 of- Lt -> case forkR_ r hr of- UBT5(l0,hl0,mbc1,l1,hl1) -> case spliceH l hl e l0 hl0 of- UBT2(l0_,hl0_) -> UBT5(l0_,hl0_,mbc1,l1,hl1)- Eq mbc1 -> UBT5(l,hl,mbc1,r,hr)- Gt -> case forkR_ l hl of- UBT5(l0,hl0,mbc1,l1,hl1) -> case spliceH l1 hl1 e r hr of- UBT2(l1_,hl1_) -> UBT5(l0,hl0,mbc1,l1_,hl1_)----------------------------------------------------------------------------------------- intersectionMaybeToList Ends Here -------------------------------------------------------------------------------------------- | Applies 'intersectionMaybeToList' to the empty list.------ Complexity: Not sure, but I\'d appreciate it if someone could figure it out.-intersectionMaybeAsList :: (a -> b -> COrdering (Maybe c)) -> AVL a -> AVL b -> [c]-intersectionMaybeAsList c setA setB = intersectionMaybeToList c setA setB []---- | Uses the supplied comparison to evaluate the difference between two sets represented as--- sorted AVL trees. The expression..------ > difference cmp setA setB------ .. is a set containing all those elements of @setA@ which do not appear in @setB@.------ Complexity: Not sure, but I\'d appreciate it if someone could figure it out.-difference :: (a -> b -> Ordering) -> AVL a -> AVL b -> AVL a--- N.B. differenceH works with relative heights on first tree, and needs no height for the second.-difference c t0 t1 = case differenceH c t0 L(0) t1 of UBT2(t,_) -> t---- | Similar to 'difference', but the resulting tree also includes those elements a\' for which the--- combining comparison returns @(Eq (Just a\'))@.------ Complexity: Not sure, but I\'d appreciate it if someone could figure it out.-differenceMaybe :: (a -> b -> COrdering (Maybe a)) -> AVL a -> AVL b -> AVL a--- N.B. differenceMaybeH works with relative heights on first tree, and needs no height for the second.-differenceMaybe c t0 t1 = case differenceMaybeH c t0 L(0) t1 of UBT2(t,_) -> t---- | Uses the supplied comparison to test whether the first set is a subset of the second,--- both sets being represented as sorted AVL trees. This function returns True if any of--- the following conditions hold..------ * The first set is empty (the empty set is a subset of any set).------ * The two sets are equal.------ * The first set is a proper subset of the second set.------ Complexity: Not sure, but I\'d appreciate it if someone could figure it out.-isSubsetOf :: (a -> b -> Ordering) -> AVL a -> AVL b -> Bool-isSubsetOf comp = s where- -- s :: AVL a -> AVL b -> Bool- s E _ = True- s _ E = False- s (N l0 e0 r0) (N l1 e1 r1) = s' l0 e0 r0 l1 e1 r1- s (N l0 e0 r0) (Z l1 e1 r1) = s' l0 e0 r0 l1 e1 r1- s (N l0 e0 r0) (P l1 e1 r1) = s' l0 e0 r0 l1 e1 r1- s (Z l0 e0 r0) (N l1 e1 r1) = s' l0 e0 r0 l1 e1 r1- s (Z l0 e0 r0) (Z l1 e1 r1) = s' l0 e0 r0 l1 e1 r1- s (Z l0 e0 r0) (P l1 e1 r1) = s' l0 e0 r0 l1 e1 r1- s (P l0 e0 r0) (N l1 e1 r1) = s' l0 e0 r0 l1 e1 r1- s (P l0 e0 r0) (Z l1 e1 r1) = s' l0 e0 r0 l1 e1 r1- s (P l0 e0 r0) (P l1 e1 r1) = s' l0 e0 r0 l1 e1 r1- s' l0 e0 r0 l1 e1 r1 =- case comp e0 e1 of- -- e0 < e1, so (l0 < e0 < e1) & (e0 < e1 < r1)- LT -> case forkL e0 l1 of- UBT5(False,_ ,_,_ ,_) -> False- UBT5(True ,ll1,_,lr1,_) -> (s l0 ll1) && case forkR r0 e1 of -- (ll1 < e0 < e1) & (e0 < lr1 < e1)- UBT4(rl0,_,rr0,_) -> (s rl0 lr1) && (s rr0 r1) -- (e0 < rl0 < e1) & (e0 < e1 < rr0)- -- e0 = e1- EQ -> (s l0 l1) && (s r0 r1)- -- e1 < e0, so (l1 < e1 < e0) & (e1 < e0 < r0)- GT -> case forkL e0 r1 of- UBT5(False,_ ,_,_ ,_) -> False- UBT5(True ,rl1,_,rr1,_) -> (s r0 rr1) && case forkR l0 e1 of -- (e1 < rl1 < e0) & (e1 < e0 < rr1)- UBT4(ll0,_,lr0,_) -> (s lr0 rl1) && (s ll0 l1) -- (ll0 < e1 < e0) & (e1 < lr0 < e0)- -- forkL returns False if t1 does not contain e0 (which implies set 0 cannot be a subset of set 1)- -- forkL :: a -> AVL b -> UBT5(Bool,AVL b,UINT,AVL b,UINT) -- Vals 1..4 only valid if Bool is True!- forkL e0 t = forkL_ t L(0) where- forkL_ E h = UBT5(False,E,h,E,h)- forkL_ (N l e r) h = forkL__ l DECINT2(h) e r DECINT1(h)- forkL_ (Z l e r) h = forkL__ l DECINT1(h) e r DECINT1(h)- forkL_ (P l e r) h = forkL__ l DECINT1(h) e r DECINT2(h)- forkL__ l hl e r hr = case comp e0 e of- LT -> case forkL_ l hl of- UBT5(False,t0,ht0,t1,ht1) -> UBT5(False,t0,ht0,t1,ht1)- UBT5(True ,t0,ht0,t1,ht1) -> case spliceH t1 ht1 e r hr of- UBT2(t1_,ht1_) -> UBT5(True,t0,ht0,t1_,ht1_)- EQ -> UBT5(True,l,hl,r,hr)- GT -> case forkL_ r hr of- UBT5(False,t0,ht0,t1,ht1) -> UBT5(False,t0,ht0,t1,ht1)- UBT5(True ,t0,ht0,t1,ht1) -> case spliceH l hl e t0 ht0 of- UBT2(t0_,ht0_) -> UBT5(True,t0_,ht0_,t1,ht1)- -- forkR discards an element from set 0 if it is equal to the element from set 1- -- forkR :: AVL a -> b -> UBT4(AVL a,UINT,AVL a,UINT)- forkR t e1 = forkR_ t L(0) where- forkR_ E h = UBT4(E,h,E,h) -- Relative heights!!- forkR_ (N l e r) h = forkR__ l DECINT2(h) e r DECINT1(h)- forkR_ (Z l e r) h = forkR__ l DECINT1(h) e r DECINT1(h)- forkR_ (P l e r) h = forkR__ l DECINT1(h) e r DECINT2(h)- forkR__ l hl e r hr = case comp e e1 of- LT -> case forkR_ r hr of- UBT4(t0,ht0,t1,ht1) -> case spliceH l hl e t0 ht0 of- UBT2(t0_,ht0_) -> UBT4(t0_,ht0_,t1,ht1)- EQ -> UBT4(l,hl,r,hr) -- e is discarded from set 0- GT -> case forkR_ l hl of- UBT4(t0,ht0,t1,ht1) -> case spliceH t1 ht1 e r hr of- UBT2(t1_,ht1_) -> UBT4(t0,ht0,t1_,ht1_)------------------------------------------------------------------------------------------------- isSubsetOf Ends Here -------------------------------------------------------------------------------------------------- | Similar to 'isSubsetOf', but also requires that the supplied combining--- comparison returns @('Eq' True)@ for matching elements.------ Complexity: Not sure, but I\'d appreciate it if someone could figure it out.-isSubsetOfBy :: (a -> b -> COrdering Bool) -> AVL a -> AVL b -> Bool-isSubsetOfBy comp = s where- -- s :: AVL a -> AVL b -> Bool- s E _ = True- s _ E = False- s (N l0 e0 r0) (N l1 e1 r1) = s' l0 e0 r0 l1 e1 r1- s (N l0 e0 r0) (Z l1 e1 r1) = s' l0 e0 r0 l1 e1 r1- s (N l0 e0 r0) (P l1 e1 r1) = s' l0 e0 r0 l1 e1 r1- s (Z l0 e0 r0) (N l1 e1 r1) = s' l0 e0 r0 l1 e1 r1- s (Z l0 e0 r0) (Z l1 e1 r1) = s' l0 e0 r0 l1 e1 r1- s (Z l0 e0 r0) (P l1 e1 r1) = s' l0 e0 r0 l1 e1 r1- s (P l0 e0 r0) (N l1 e1 r1) = s' l0 e0 r0 l1 e1 r1- s (P l0 e0 r0) (Z l1 e1 r1) = s' l0 e0 r0 l1 e1 r1- s (P l0 e0 r0) (P l1 e1 r1) = s' l0 e0 r0 l1 e1 r1- s' l0 e0 r0 l1 e1 r1 =- case comp e0 e1 of- -- e0 < e1, so (l0 < e0 < e1) & (e0 < e1 < r1)- Lt -> case forkL e0 l1 of- UBT5(False,_ ,_,_ ,_) -> False- UBT5(True ,ll1,_,lr1,_) -> (s l0 ll1) && case forkR r0 e1 of -- (ll1 < e0 < e1) & (e0 < lr1 < e1)- UBT5(False,_ ,_,_ ,_) -> False- UBT5(True ,rl0,_,rr0,_) -> (s rl0 lr1) && (s rr0 r1) -- (e0 < rl0 < e1) & (e0 < e1 < rr0)- -- e0 = e1- Eq True -> (s l0 l1) && (s r0 r1)- Eq False -> False- -- e1 < e0, so (l1 < e1 < e0) & (e1 < e0 < r0)- Gt -> case forkL e0 r1 of- UBT5(False,_ ,_,_ ,_) -> False- UBT5(True ,rl1,_,rr1,_) -> (s r0 rr1) && case forkR l0 e1 of -- (e1 < rl1 < e0) & (e1 < e0 < rr1)- UBT5(False,_ ,_,_ ,_) -> False- UBT5(True ,ll0,_,lr0,_) -> (s lr0 rl1) && (s ll0 l1) -- (ll0 < e1 < e0) & (e1 < lr0 < e0)- -- forkL returns False if t1 does not contain e0 (which implies set 0 cannot be a subset of set 1)- -- forkL :: a -> AVL b -> UBT5(Bool,AVL b,UINT,AVL b,UINT) -- Vals 1..4 only valid if Bool is True!- forkL e0 t = forkL_ t L(0) where- forkL_ E h = UBT5(False,E,h,E,h)- forkL_ (N l e r) h = forkL__ l DECINT2(h) e r DECINT1(h)- forkL_ (Z l e r) h = forkL__ l DECINT1(h) e r DECINT1(h)- forkL_ (P l e r) h = forkL__ l DECINT1(h) e r DECINT2(h)- forkL__ l hl e r hr = case comp e0 e of- Lt -> case forkL_ l hl of- UBT5(False,t0,ht0,t1,ht1) -> UBT5(False,t0,ht0,t1,ht1)- UBT5(True ,t0,ht0,t1,ht1) -> case spliceH t1 ht1 e r hr of- UBT2(t1_,ht1_) -> UBT5(True,t0,ht0,t1_,ht1_)- Eq b -> UBT5(b,l,hl,r,hr)- Gt -> case forkL_ r hr of- UBT5(False,t0,ht0,t1,ht1) -> UBT5(False,t0,ht0,t1,ht1)- UBT5(True ,t0,ht0,t1,ht1) -> case spliceH l hl e t0 ht0 of- UBT2(t0_,ht0_) -> UBT5(True,t0_,ht0_,t1,ht1)- -- forkR discards an element from set 0 if it is equal to the element from set 1- -- forkR :: AVL a -> b -> UBT5(Bool,AVL a,UINT,AVL a,UINT) -- Vals 1..4 only valid if Bool is True!- forkR t e1 = forkR_ t L(0) where- forkR_ E h = UBT5(True,E,h,E,h) -- Relative heights!!- forkR_ (N l e r) h = forkR__ l DECINT2(h) e r DECINT1(h)- forkR_ (Z l e r) h = forkR__ l DECINT1(h) e r DECINT1(h)- forkR_ (P l e r) h = forkR__ l DECINT1(h) e r DECINT2(h)- forkR__ l hl e r hr = case comp e e1 of- Lt -> case forkR_ r hr of- UBT5(False,t0,ht0,t1,ht1) -> UBT5(False,t0,ht0,t1,ht1)- UBT5(True ,t0,ht0,t1,ht1) -> case spliceH l hl e t0 ht0 of- UBT2(t0_,ht0_) -> UBT5(True,t0_,ht0_,t1,ht1)- Eq b -> UBT5(b,l,hl,r,hr) -- e is discarded from set 0- Gt -> case forkR_ l hl of- UBT5(False,t0,ht0,t1,ht1) -> UBT5(False,t0,ht0,t1,ht1)- UBT5(True ,t0,ht0,t1,ht1) -> case spliceH t1 ht1 e r hr of- UBT2(t1_,ht1_) -> UBT5(True,t0,ht0,t1_,ht1_)------------------------------------------------------------------------------------------------ isSubsetOfBy Ends Here ------------------------------------------------------------------------------------------------- | The symmetric difference is the set of elements which occur in one set or the other but /not both/.------ Complexity: Not sure, but I\'d appreciate it if someone could figure it out.-symDifference :: (e -> e -> Ordering) -> AVL e -> AVL e -> AVL e-symDifference c = gu where -- This is to avoid O(log n) height calculation for empty sets- gu E t1 = t1- gu t0 E = t0- gu t0@(N l0 _ _ ) t1@(N l1 _ _ ) = gu_ t0 (addHeight L(2) l0) t1 (addHeight L(2) l1)- gu t0@(N l0 _ _ ) t1@(Z l1 _ _ ) = gu_ t0 (addHeight L(2) l0) t1 (addHeight L(1) l1)- gu t0@(N l0 _ _ ) t1@(P _ _ r1) = gu_ t0 (addHeight L(2) l0) t1 (addHeight L(2) r1)- gu t0@(Z l0 _ _ ) t1@(N l1 _ _ ) = gu_ t0 (addHeight L(1) l0) t1 (addHeight L(2) l1)- gu t0@(Z l0 _ _ ) t1@(Z l1 _ _ ) = gu_ t0 (addHeight L(1) l0) t1 (addHeight L(1) l1)- gu t0@(Z l0 _ _ ) t1@(P _ _ r1) = gu_ t0 (addHeight L(1) l0) t1 (addHeight L(2) r1)- gu t0@(P _ _ r0) t1@(N l1 _ _ ) = gu_ t0 (addHeight L(2) r0) t1 (addHeight L(2) l1)- gu t0@(P _ _ r0) t1@(Z l1 _ _ ) = gu_ t0 (addHeight L(2) r0) t1 (addHeight L(1) l1)- gu t0@(P _ _ r0) t1@(P _ _ r1) = gu_ t0 (addHeight L(2) r0) t1 (addHeight L(2) r1)- gu_ t0 h0 t1 h1 = case symDifferenceH c t0 h0 t1 h1 of UBT2(t,_) -> t---- | Given two Sets @A@ and @B@ represented as sorted AVL trees, this function--- extracts the \'Venn diagram\' components @A-B@, @A.B@ and @B-A@.--- See also 'vennMaybe'.------ Complexity: Not sure, but I\'d appreciate it if someone could figure it out.-venn :: (a -> b -> COrdering c) -> AVL a -> AVL b -> (AVL a, AVL c, AVL b)-venn c = gu where -- This is to avoid O(log n) height calculation for empty sets- gu E t1 = (E ,E,t1)- gu t0 E = (t0,E,E )- gu t0@(N l0 _ _ ) t1@(N l1 _ _ ) = gu_ t0 (addHeight L(2) l0) t1 (addHeight L(2) l1)- gu t0@(N l0 _ _ ) t1@(Z l1 _ _ ) = gu_ t0 (addHeight L(2) l0) t1 (addHeight L(1) l1)- gu t0@(N l0 _ _ ) t1@(P _ _ r1) = gu_ t0 (addHeight L(2) l0) t1 (addHeight L(2) r1)- gu t0@(Z l0 _ _ ) t1@(N l1 _ _ ) = gu_ t0 (addHeight L(1) l0) t1 (addHeight L(2) l1)- gu t0@(Z l0 _ _ ) t1@(Z l1 _ _ ) = gu_ t0 (addHeight L(1) l0) t1 (addHeight L(1) l1)- gu t0@(Z l0 _ _ ) t1@(P _ _ r1) = gu_ t0 (addHeight L(1) l0) t1 (addHeight L(2) r1)- gu t0@(P _ _ r0) t1@(N l1 _ _ ) = gu_ t0 (addHeight L(2) r0) t1 (addHeight L(2) l1)- gu t0@(P _ _ r0) t1@(Z l1 _ _ ) = gu_ t0 (addHeight L(2) r0) t1 (addHeight L(1) l1)- gu t0@(P _ _ r0) t1@(P _ _ r1) = gu_ t0 (addHeight L(2) r0) t1 (addHeight L(2) r1)- gu_ t0 h0 t1 h1 = case vennH c [] L(0) t0 h0 t1 h1 of- UBT6(tab,_,cs,cl,tba,_) -> let tc = asTreeLenL ASINT(cl) cs- in tc `seq` (tab,tc,tba)---- | Similar to 'venn', but intersection elements for which the combining comparison--- returns @('Eq' 'Nothing')@ are deleted from the intersection result.------ Complexity: Not sure, but I\'d appreciate it if someone could figure it out.-vennMaybe :: (a -> b -> COrdering (Maybe c)) -> AVL a -> AVL b -> (AVL a, AVL c, AVL b)-vennMaybe c = gu where -- This is to avoid O(log n) height calculation for empty sets- gu E t1 = (E ,E,t1)- gu t0 E = (t0,E,E )- gu t0@(N l0 _ _ ) t1@(N l1 _ _ ) = gu_ t0 (addHeight L(2) l0) t1 (addHeight L(2) l1)- gu t0@(N l0 _ _ ) t1@(Z l1 _ _ ) = gu_ t0 (addHeight L(2) l0) t1 (addHeight L(1) l1)- gu t0@(N l0 _ _ ) t1@(P _ _ r1) = gu_ t0 (addHeight L(2) l0) t1 (addHeight L(2) r1)- gu t0@(Z l0 _ _ ) t1@(N l1 _ _ ) = gu_ t0 (addHeight L(1) l0) t1 (addHeight L(2) l1)- gu t0@(Z l0 _ _ ) t1@(Z l1 _ _ ) = gu_ t0 (addHeight L(1) l0) t1 (addHeight L(1) l1)- gu t0@(Z l0 _ _ ) t1@(P _ _ r1) = gu_ t0 (addHeight L(1) l0) t1 (addHeight L(2) r1)- gu t0@(P _ _ r0) t1@(N l1 _ _ ) = gu_ t0 (addHeight L(2) r0) t1 (addHeight L(2) l1)- gu t0@(P _ _ r0) t1@(Z l1 _ _ ) = gu_ t0 (addHeight L(2) r0) t1 (addHeight L(1) l1)- gu t0@(P _ _ r0) t1@(P _ _ r1) = gu_ t0 (addHeight L(2) r0) t1 (addHeight L(2) r1)- gu_ t0 h0 t1 h1 = case vennMaybeH c [] L(0) t0 h0 t1 h1 of- UBT6(tab,_,cs,cl,tba,_) -> let tc = asTreeLenL ASINT(cl) cs- in tc `seq` (tab,tc,tba)---- | Same as 'venn', but prepends the intersection component to the supplied list--- in ascending order.-vennToList :: (a -> b -> COrdering c) -> [c] -> AVL a -> AVL b -> (AVL a, [c], AVL b)-vennToList cmp cs = gu where -- This is to avoid O(log n) height calculation for empty sets- gu E t1 = (E ,cs,t1)- gu t0 E = (t0,cs,E )- gu t0@(N l0 _ _ ) t1@(N l1 _ _ ) = gu_ t0 (addHeight L(2) l0) t1 (addHeight L(2) l1)- gu t0@(N l0 _ _ ) t1@(Z l1 _ _ ) = gu_ t0 (addHeight L(2) l0) t1 (addHeight L(1) l1)- gu t0@(N l0 _ _ ) t1@(P _ _ r1) = gu_ t0 (addHeight L(2) l0) t1 (addHeight L(2) r1)- gu t0@(Z l0 _ _ ) t1@(N l1 _ _ ) = gu_ t0 (addHeight L(1) l0) t1 (addHeight L(2) l1)- gu t0@(Z l0 _ _ ) t1@(Z l1 _ _ ) = gu_ t0 (addHeight L(1) l0) t1 (addHeight L(1) l1)- gu t0@(Z l0 _ _ ) t1@(P _ _ r1) = gu_ t0 (addHeight L(1) l0) t1 (addHeight L(2) r1)- gu t0@(P _ _ r0) t1@(N l1 _ _ ) = gu_ t0 (addHeight L(2) r0) t1 (addHeight L(2) l1)- gu t0@(P _ _ r0) t1@(Z l1 _ _ ) = gu_ t0 (addHeight L(2) r0) t1 (addHeight L(1) l1)- gu t0@(P _ _ r0) t1@(P _ _ r1) = gu_ t0 (addHeight L(2) r0) t1 (addHeight L(2) r1)- gu_ t0 h0 t1 h1 = case vennH cmp cs L(0) t0 h0 t1 h1 of- UBT6(tab,_,cs_,_,tba,_) -> (tab,cs_,tba)---- | Same as 'vennMaybe', but prepends the intersection component to the supplied list--- in ascending order.-vennMaybeToList :: (a -> b -> COrdering (Maybe c)) -> [c] -> AVL a -> AVL b -> (AVL a, [c], AVL b)-vennMaybeToList cmp cs = gu where -- This is to avoid O(log n) height calculation for empty sets- gu E t1 = (E ,cs,t1)- gu t0 E = (t0,cs,E )- gu t0@(N l0 _ _ ) t1@(N l1 _ _ ) = gu_ t0 (addHeight L(2) l0) t1 (addHeight L(2) l1)- gu t0@(N l0 _ _ ) t1@(Z l1 _ _ ) = gu_ t0 (addHeight L(2) l0) t1 (addHeight L(1) l1)- gu t0@(N l0 _ _ ) t1@(P _ _ r1) = gu_ t0 (addHeight L(2) l0) t1 (addHeight L(2) r1)- gu t0@(Z l0 _ _ ) t1@(N l1 _ _ ) = gu_ t0 (addHeight L(1) l0) t1 (addHeight L(2) l1)- gu t0@(Z l0 _ _ ) t1@(Z l1 _ _ ) = gu_ t0 (addHeight L(1) l0) t1 (addHeight L(1) l1)- gu t0@(Z l0 _ _ ) t1@(P _ _ r1) = gu_ t0 (addHeight L(1) l0) t1 (addHeight L(2) r1)- gu t0@(P _ _ r0) t1@(N l1 _ _ ) = gu_ t0 (addHeight L(2) r0) t1 (addHeight L(2) l1)- gu t0@(P _ _ r0) t1@(Z l1 _ _ ) = gu_ t0 (addHeight L(2) r0) t1 (addHeight L(1) l1)- gu t0@(P _ _ r0) t1@(P _ _ r1) = gu_ t0 (addHeight L(2) r0) t1 (addHeight L(2) r1)- gu_ t0 h0 t1 h1 = case vennMaybeH cmp cs L(0) t0 h0 t1 h1 of- UBT6(tab,_,cs_,_,tba,_) -> (tab,cs_,tba)---- | Same as 'venn', but returns the intersection component as a list in ascending order.--- This is just 'vennToList' applied to an empty initial intersection list.-vennAsList :: (a -> b -> COrdering c) -> AVL a -> AVL b -> (AVL a, [c], AVL b)-vennAsList cmp = vennToList cmp []-{-# INLINE vennAsList #-}---- | Same as 'vennMaybe', but returns the intersection component as a list in ascending order.--- This is just 'vennMaybeToList' applied to an empty initial intersection list.-vennMaybeAsList :: (a -> b -> COrdering (Maybe c)) -> AVL a -> AVL b -> (AVL a, [c], AVL b)-vennMaybeAsList cmp = vennMaybeToList cmp []-{-# INLINE vennMaybeAsList #-}-
− Data/Tree/AVL/Size.hs
@@ -1,193 +0,0 @@-{-# OPTIONS_GHC -fglasgow-exts #-}--------------------------------------------------------------------------------- |--- Module : Data.Tree.AVL.Size--- Copyright : (c) Adrian Hey 2004,2005--- License : BSD3------ Maintainer : http://homepages.nildram.co.uk/~ahey/em.png--- Stability : stable--- Portability : portable------ AVL Tree size related utilities.-------------------------------------------------------------------------------module Data.Tree.AVL.Size- (-- * AVL tree size utilities.- size,addSize,clipSize,--#ifdef __GLASGOW_HASKELL__- -- ** (GHC Only)- addSize#,size#,-#endif- ) where--import Data.Tree.AVL.Types(AVL(..))-import Data.Tree.AVL.Height(addHeight)--#ifdef __GLASGOW_HASKELL__-import GHC.Base-#include "ghcdefs.h"-#else-#include "h98defs.h"-#endif--#ifdef __GLASGOW_HASKELL__-import GHC.Base-#include "ghcdefs.h"---- | A convenience wrapper for 'addSize#'.-size :: AVL e -> Int-size t = ASINT(addSize# L(0) t)-{-# INLINE size #-}---- | A convenience wrapper for 'addSize#'.-size# :: AVL e -> UINT-size# t = addSize# L(0) t-{-# INLINE size# #-}---- | See 'addSize#'.-addSize :: Int -> AVL e -> Int-addSize ASINT(n) t = ASINT(addSize# n t)-{-# INLINE addSize #-}--#define AddSize addSize#-#else-#include "h98defs.h"---- | A convenience wrapper for 'addSize'.-size :: AVL e -> Int-size t = addSize 0 t-{-# INLINE size #-}--#define AddSize addSize-#endif--{------------------------------------------Notes for fast size calculation.- case (h,avl)- (0,_ ) -> 0 -- Must be E- (1,_ ) -> 1 -- Must be (Z E _ E )- (2,N _ _ _) -> 2 -- Must be (N E _ (Z E _ E))- (2,Z _ _ _) -> 3 -- Must be (Z (Z E _ E) _ (Z E _ E))- (2,P _ _ _) -> 2 -- Must be (P (Z E _ E) _ E )- (3,N _ _ r) -> 2 + size 2 r -- Must be (N (Z E _ E) _ r )- (3,P l _ _) -> 2 + size 2 l -- Must be (P l _ (Z E _ E))-------------------------------------------}---- | Fast algorithm to add the size of a tree to the first argument. This avoids visiting about 50% of tree nodes--- by using fact that trees with small heights can only have particular shapes.--- So it's still O(n), but with substantial saving in constant factors.------ Complexity: O(n)-AddSize :: UINT -> AVL e -> UINT-AddSize n E = n-AddSize n (N l _ r) = case addHeight L(2) l of- L(2) -> INCINT2(n)- L(3) -> fas2 INCINT2(n) r- h -> fasNP n h l r-AddSize n (Z l _ r) = case addHeight L(1) l of- L(1) -> INCINT1(n)- L(2) -> INCINT3(n)- L(3) -> fas2 (fas2 INCINT1(n) l) r- h -> fasZ n h l r-AddSize n (P l _ r) = case addHeight L(2) r of- L(2) -> INCINT2(n)- L(3) -> fas2 INCINT2(n) l- h -> fasNP n h r l--- Parent Height (h) >= 4 !!-fasNP,fasZ :: UINT -> UINT -> AVL e -> AVL e -> UINT-fasNP n h l r = fasG3 (fasG2 INCINT1(n) DECINT2(h) l) DECINT1(h) r-fasZ n h l r = fasG3 (fasG3 INCINT1(n) DECINT1(h) l) DECINT1(h) r--- h>=2 !!-fasG2 :: UINT -> UINT -> AVL e -> UINT-fasG2 n L(2) t = fas2 n t-fasG2 n h t = fasG3 n h t-{-# INLINE fasG2 #-}--- h>=3 !!-fasG3 :: UINT -> UINT -> AVL e -> UINT-fasG3 n L(3) (N _ _ r) = fas2 INCINT2(n) r-fasG3 n L(3) (Z l _ r) = fas2 (fas2 INCINT1(n) l) r-fasG3 n L(3) (P l _ _) = fas2 INCINT2(n) l-fasG3 n h (N l _ r) = fasNP n h l r -- h>=4-fasG3 n h (Z l _ r) = fasZ n h l r -- h>=4-fasG3 n h (P l _ r) = fasNP n h r l -- h>=4-fasG3 _ _ E = error "AddSize: Bad Tree." -- impossible--- h=2 !!-fas2 :: UINT -> AVL e -> UINT-fas2 n (N _ _ _) = INCINT2(n)-fas2 n (Z _ _ _) = INCINT3(n)-fas2 n (P _ _ _) = INCINT2(n)-fas2 _ E = error "AddSize: Bad Tree." -- impossible-{-# INLINE fas2 #-}------------------------------------------------------------------------------------------------ fastAddSize Ends Here ----------------------------------------------------------------------------------------------------- | Returns the exact tree size in the form @('Just' n)@ if this is less than or--- equal to the input clip value. Returns @'Nothing'@ of the size is greater than--- the clip value. This function exploits the same optimisation as 'addSize'.------ Complexity: O(min n c) where n is tree size and c is clip value.-clipSize :: Int -> AVL e -> Maybe Int-clipSize ASINT(c) t = let c_ = cSzh c t in if c_ LTN L(0)- then Nothing- else Just ASINT(SUBINT(c,c_))--- First entry calculates initial height-cSzh :: UINT -> AVL e -> UINT-cSzh c E = c-cSzh c (N l _ r) = case addHeight L(2) l of- L(2) -> DECINT2(c)- L(3) -> cSzNP3 c r- h -> cSzNP c h l r-cSzh c (Z l _ r) = case addHeight L(1) l of- L(1) -> DECINT1(c)- L(2) -> DECINT3(c)- L(3) -> cSzZ3 c l r- h -> cSzZ c h l r-cSzh c (P l _ r) = case addHeight L(2) r of- L(2) -> DECINT2(c)- L(3) -> cSzNP3 c l- h -> cSzNP c h r l--- Parent Height = 3 !!-cSzNP3 :: UINT -> AVL e -> UINT-cSzNP3 c t = if c LTN L(4) then L(-1) else cSz2 DECINT2(c) t-cSzZ3 :: UINT -> AVL e -> AVL e -> UINT-cSzZ3 c l r = if c LTN L(5) then L(-1)- else let c_ = cSz2 DECINT1(c) l- in if c_ LTN L(2) then L(-1)- else cSz2 c_ r--- Parent Height (h) >= 4 !!-cSzNP,cSzZ :: UINT -> UINT -> AVL e -> AVL e -> UINT-cSzNP c h l r = if c LTN L(7) then L(-1)- else let c_ = cSzG2 DECINT1(c) DECINT2(h) l -- (h-2) >= 2- in if c_ LTN L(4) then L(-1)- else cSzG3 c_ DECINT1(h) r -- (h-1) >= 3-cSzZ c h l r = if c LTN L(9) then L(-1)- else let c_ = cSzG3 DECINT1(c) DECINT1(h) l -- (h-1) >= 3- in if c_ LTN L(4) then L(-1)- else cSzG3 c_ DECINT1(h) r -- (h-1) >= 3--- h>=2 !!-cSzG2 :: UINT -> UINT -> AVL e -> UINT-cSzG2 c L(2) t = cSz2 c t-cSzG2 c h t = cSzG3 c h t-{-# INLINE cSzG2 #-}--- h>=3 !!-cSzG3 :: UINT -> UINT -> AVL e -> UINT-cSzG3 c L(3) (N _ _ r) = cSzNP3 c r-cSzG3 c L(3) (Z l _ r) = cSzZ3 c l r-cSzG3 c L(3) (P l _ _) = cSzNP3 c l-cSzG3 c h (N l _ r) = cSzNP c h l r -- h>=4-cSzG3 c h (Z l _ r) = cSzZ c h l r -- h>=4-cSzG3 c h (P l _ r) = cSzNP c h r l -- h>=4-cSzG3 _ _ E = error "clipSize: Bad Tree." -- impossible--- h=2 !!-cSz2 :: UINT -> AVL e -> UINT-cSz2 c (N _ _ _) = DECINT2(c)-cSz2 c (Z _ _ _) = DECINT3(c)-cSz2 c (P _ _ _) = DECINT2(c)-cSz2 _ E = error "clipSize: Bad Tree." -- impossible-{-# INLINE cSz2 #-}-------------------------------------------------------------------------------------------------- clipSize Ends Here ---------------------------------------------------------------------------------------------------
− Data/Tree/AVL/Split.hs
@@ -1,837 +0,0 @@-{-# OPTIONS_GHC -fglasgow-exts #-}--------------------------------------------------------------------------------- |--- Module : Data.Tree.AVL.Split--- Copyright : (c) Adrian Hey 2004,2005--- License : BSD3------ Maintainer : http://homepages.nildram.co.uk/~ahey/em.png--- Stability : stable--- Portability : portable-------------------------------------------------------------------------------module Data.Tree.AVL.Split-(-- * Splitting AVL trees-- -- ** Taking fixed size lumps of tree- -- | Bear in mind that the tree size (s) is not stored in the AVL data structure, but if it is- -- already known for other reasons then for (n > s\/2) using the appropriate complementary- -- function with argument (s-n) will be faster.- -- But it's probably not worth invoking 'Data.Tree.AVL.Types.size' for no reason other than to- -- exploit this optimisation (because this is O(s) anyway).- splitAtL,splitAtR,takeL,takeR,dropL,dropR,-- -- ** Rotations- -- | Bear in mind that the tree size (s) is not stored in the AVL data structure, but if it is- -- already known for other reasons then for (n > s\/2) using the appropriate complementary- -- function with argument (s-n) will be faster.- -- But it's probably not worth invoking 'Data.Tree.AVL.Types.size' for no reason other than to exploit this optimisation- -- (because this is O(s) anyway).- rotateL,rotateR,popRotateL,popRotateR,rotateByL,rotateByR,-- -- ** Taking lumps of tree according to a supplied predicate- spanL,spanR,takeWhileL,dropWhileL,takeWhileR,dropWhileR,-- -- ** Taking lumps of /sorted/ trees- -- | Prepare to get confused. All these functions adhere to the same Ordering convention as- -- is used for searches. That is, if the supplied selector returns LT that means the search- -- key is less than the current tree element. Or put another way, the current tree element- -- is greater than the search key.- --- -- So (for example) the result of the 'takeLT' function is a tree containing all those elements- -- which are less than the notional search key. That is, all those elements for which the- -- supplied selector returns GT (not LT as you might expect). I know that seems backwards, but- -- it's consistent if you think about it.- forkL,forkR,fork,- takeLE,dropGT,- takeLT,dropGE,- takeGT,dropLE,- takeGE,dropLT,-) where--import Prelude -- so haddock finds the symbols there---import Data.COrdering(COrdering(..))-import Data.Tree.AVL.Types(AVL(..))-import Data.Tree.AVL.Push(pushL,pushR)-import Data.Tree.AVL.Internals.DelUtils(popRN,popRZ,popRP,popLN,popLZ,popLP)-import Data.Tree.AVL.Internals.HAVL(HAVL(HAVL),spliceHAVL,pushLHAVL,pushRHAVL)-import Data.Tree.AVL.Internals.HJoin(joinH')--#ifdef __GLASGOW_HASKELL__-import GHC.Base-#include "ghcdefs.h"-#else-#include "h98defs.h"-#endif---- Local Datatype for results of split operations.-data SplitResult e = All (HAVL e) (HAVL e) -- Two tree/height pairs. Non Strict!!- | More {-# UNPACK #-} !UINT -- No of tree elements still required (>=0!!)---- | Split an AVL tree from the Left. The 'Int' argument n (n >= 0) specifies the split point.--- This function raises an error if n is negative.------ If the tree size is greater than n the result is (Right (l,r)) where l contains--- the leftmost n elements and r contains the remaining rightmost elements (r will be non-empty).------ If the tree size is less than or equal to n then the result is (Left s), where s is tree size.------ An empty tree will always yield a result of (Left 0).------ Complexity: O(n)-splitAtL :: Int -> AVL e -> Either Int (AVL e, AVL e)-splitAtL n _ | n < 0 = error "splitAtL: Negative argument."-splitAtL 0 E = Left 0 -- Treat this case specially-splitAtL 0 t = Right (E,t)-splitAtL ASINT(n) t = case splitL n t L(0) of -- Tree Heights are relative!!- More n_ -> Left ASINT(SUBINT(n,n_))- All (HAVL l _) (HAVL r _) -> Right (l,r)---- n > 0 !!--- N.B Never returns a result of form (ALL lhavl rhavl) where rhavl is empty-splitL :: UINT -> AVL e -> UINT -> SplitResult e-splitL n E _ = More n-splitL n (N l e r) h = splitL_ n l DECINT2(h) e r DECINT1(h)-splitL n (Z l e r) h = splitL_ n l DECINT1(h) e r DECINT1(h)-splitL n (P l e r) h = splitL_ n l DECINT1(h) e r DECINT2(h)---- n > 0 !!--- N.B Never returns a result of form (ALL lhavl rhavl) where rhavl is empty-splitL_ :: UINT -> AVL e -> UINT -> e -> AVL e -> UINT -> SplitResult e-splitL_ n l hl e r hr =- case splitL n l hl of- More L(0) -> let rhavl = pushLHAVL e (HAVL r hr); lhavl = HAVL l hl- in lhavl `seq` rhavl `seq` All lhavl rhavl- More L(1) -> case r of- E -> More L(0)- _ -> let lhavl = pushRHAVL (HAVL l hl) e- rhavl = HAVL r hr- in lhavl `seq` rhavl `seq` All lhavl rhavl- More n_ -> let sr = splitL DECINT1(n_) r hr- in case sr of- More _ -> sr- All havl0 havl1 -> let havl0' = spliceHAVL (HAVL l hl) e havl0- in havl0' `seq` All havl0' havl1- All havl0 havl1 -> let havl1' = spliceHAVL havl1 e (HAVL r hr)- in havl1' `seq` All havl0 havl1'-------------------------------------------------------------------------------------------------- splitAtL Ends Here ------------------------------------------------------------------------------------------------------ | Split an AVL tree from the Right. The 'Int' argument n (n >= 0) specifies the split point.--- This function raises an error if n is negative.------ If the tree size is greater than n the result is (Right (l,r)) where r contains--- the rightmost n elements and l contains the remaining leftmost elements (l will be non-empty).------ If the tree size is less than or equal to n then the result is (Left s), where s is tree size.------ An empty tree will always yield a result of (Left 0).------ Complexity: O(n)-splitAtR :: Int -> AVL e -> Either Int (AVL e, AVL e)-splitAtR n _ | n < 0 = error "splitAtR: Negative argument."-splitAtR 0 E = Left 0 -- Treat this case specially-splitAtR 0 t = Right (t,E)-splitAtR ASINT(n) t = case splitR n t L(0) of -- Tree Heights are relative!!- More n_ -> Left ASINT(SUBINT(n,n_))- All (HAVL l _) (HAVL r _) -> Right (l,r)---- n > 0 !!--- N.B Never returns a result of form (ALL lhavl rhavl) where lhavl is empty-splitR :: UINT -> AVL e -> UINT -> SplitResult e-splitR n E _ = More n-splitR n (N l e r) h = splitR_ n l DECINT2(h) e r DECINT1(h)-splitR n (Z l e r) h = splitR_ n l DECINT1(h) e r DECINT1(h)-splitR n (P l e r) h = splitR_ n l DECINT1(h) e r DECINT2(h)---- n > 0 !!--- N.B Never returns a result of form (ALL lhavl rhavl) where lhavl is empty-splitR_ :: UINT -> AVL e -> UINT -> e -> AVL e -> UINT -> SplitResult e-splitR_ n l hl e r hr =- case splitR n r hr of- More L(0) -> let lhavl = pushRHAVL (HAVL l hl) e; rhavl = HAVL r hr- in lhavl `seq` rhavl `seq` All lhavl rhavl- More L(1) -> case l of- E -> More L(0)- _ -> let rhavl = pushLHAVL e (HAVL r hr)- lhavl = HAVL l hl- in lhavl `seq` rhavl `seq` All lhavl rhavl- More n_ -> let sr = splitR DECINT1(n_) l hl- in case sr of- More _ -> sr- All havl0 havl1 -> let havl1' = spliceHAVL havl1 e (HAVL r hr)- in havl1' `seq` All havl0 havl1'- All havl0 havl1 -> let havlO' = spliceHAVL (HAVL l hl) e havl0- in havlO' `seq` All havlO' havl1-------------------------------------------------------------------------------------------------- splitAtR Ends Here ------------------------------------------------------------------------------------------------------ Local Datatype for results of take/drop operations.-data TakeResult e = AllTR (HAVL e) -- The resulting Tree- | MoreTR {-# UNPACK #-} !UINT -- No of tree elements still required (>=0!!)---- | This is a simplified version of 'splitAtL' which does not return the remaining tree.--- The 'Int' argument n (n >= 0) specifies the number of elements to take (from the left).--- This function raises an error if n is negative.------ If the tree size is greater than n the result is (Right l) where l contains--- the leftmost n elements.------ If the tree size is less than or equal to n then the result is (Left s), where s is tree size.------ An empty tree will always yield a result of (Left 0).------ Complexity: O(n)-takeL :: Int -> AVL e -> Either Int (AVL e)-takeL n _ | n < 0 = error "takeL: Negative argument."-takeL 0 E = Left 0 -- Treat this case specially-takeL 0 _ = Right E-takeL ASINT(n) t = case takeL_ n t L(0) of -- Tree Heights are relative!!- MoreTR n_ -> Left ASINT(SUBINT(n,n_))- AllTR (HAVL t' _) -> Right t'---- n > 0 !!-takeL_ :: UINT -> AVL e -> UINT -> TakeResult e-takeL_ n E _ = MoreTR n-takeL_ n (N l e r) h = takeL__ n l DECINT2(h) e r DECINT1(h)-takeL_ n (Z l e r) h = takeL__ n l DECINT1(h) e r DECINT1(h)-takeL_ n (P l e r) h = takeL__ n l DECINT1(h) e r DECINT2(h)---- n > 0 !!-takeL__ :: UINT -> AVL e -> UINT -> e -> AVL e -> UINT -> TakeResult e-takeL__ n l hl e r hr =- let takel = takeL_ n l hl- in case takel of- MoreTR L(0) -> let lhavl = HAVL l hl- in lhavl `seq` AllTR lhavl- MoreTR L(1) -> case r of- E -> MoreTR L(0)- _ -> let lhavl = pushRHAVL (HAVL l hl) e- in lhavl `seq` AllTR lhavl- MoreTR n_ -> let taker = takeL_ DECINT1(n_) r hr- in case taker of- AllTR havl0 -> let havl0' = spliceHAVL (HAVL l hl) e havl0- in havl0' `seq` AllTR havl0'- _ -> taker- _ -> takel--------------------------------------------------------------------------------------------------- takeL Ends Here -------------------------------------------------------------------------------------------------------- | This is a simplified version of 'splitAtR' which does not return the remaining tree.--- The 'Int' argument n (n >= 0) specifies the number of elements to take (from the right).--- This function raises an error if n is negative.------ If the tree size is greater than n the result is (Right r) where r contains--- the rightmost n elements.------ If the tree size is less than or equal to n then the result is (Left s), where s is tree size.------ An empty tree will always yield a result of (Left 0).------ Complexity: O(n)-takeR :: Int -> AVL e -> Either Int (AVL e)-takeR n _ | n < 0 = error "takeR: Negative argument."-takeR 0 E = Left 0 -- Treat this case specially-takeR 0 _ = Right E-takeR ASINT(n) t = case takeR_ n t L(0) of -- Tree Heights are relative!!- MoreTR n_ -> Left ASINT(SUBINT(n,n_))- AllTR (HAVL t' _) -> Right t'---- n > 0 !!-takeR_ :: UINT -> AVL e -> UINT -> TakeResult e-takeR_ n E _ = MoreTR n-takeR_ n (N l e r) h = takeR__ n l DECINT2(h) e r DECINT1(h)-takeR_ n (Z l e r) h = takeR__ n l DECINT1(h) e r DECINT1(h)-takeR_ n (P l e r) h = takeR__ n l DECINT1(h) e r DECINT2(h)---- n > 0 !!-takeR__ :: UINT -> AVL e -> UINT -> e -> AVL e -> UINT -> TakeResult e-takeR__ n l hl e r hr =- let taker = takeR_ n r hr- in case taker of- MoreTR L(0) -> let rhavl = HAVL r hr- in rhavl `seq` AllTR rhavl- MoreTR L(1) -> case l of- E -> MoreTR L(0)- _ -> let rhavl = pushLHAVL e (HAVL r hr)- in rhavl `seq` AllTR rhavl- MoreTR n_ -> let takel = takeR_ DECINT1(n_) l hl- in case takel of- AllTR havl0 -> let havl0' = spliceHAVL havl0 e (HAVL r hr)- in havl0' `seq` AllTR havl0'- _ -> takel- _ -> taker--------------------------------------------------------------------------------------------------- takeR Ends Here -------------------------------------------------------------------------------------------------------- | This is a simplified version of 'splitAtL' which returns the remaining tree only (rightmost elements).--- This function raises an error if n is negative.------ If the tree size is greater than n the result is (Right r) where r contains--- the remaining elements (r will be non-empty).------ If the tree size is less than or equal to n then the result is (Left s), where s is tree size.------ An empty tree will always yield a result of (Left 0).------ Complexity: O(n)-dropL :: Int -> AVL e -> Either Int (AVL e)-dropL n _ | n < 0 = error "dropL: Negative argument."-dropL 0 E = Left 0 -- Treat this case specially-dropL 0 t = Right t-dropL ASINT(n) t = case dropL_ n t L(0) of -- Tree Heights are relative!!- MoreTR n_ -> Left ASINT(SUBINT(n,n_))- AllTR (HAVL r _) -> Right r---- n > 0 !!--- N.B Never returns a result of form (AllTR rhavl) where rhavl is empty-dropL_ :: UINT -> AVL e -> UINT -> TakeResult e-dropL_ n E _ = MoreTR n-dropL_ n (N l e r) h = dropL__ n l DECINT2(h) e r DECINT1(h)-dropL_ n (Z l e r) h = dropL__ n l DECINT1(h) e r DECINT1(h)-dropL_ n (P l e r) h = dropL__ n l DECINT1(h) e r DECINT2(h)---- n > 0 !!--- N.B Never returns a result of form (AllTR rhavl) where rhavl is empty-dropL__ :: UINT -> AVL e -> UINT -> e -> AVL e -> UINT -> TakeResult e-dropL__ n l hl e r hr =- case dropL_ n l hl of- MoreTR L(0) -> let rhavl = pushLHAVL e (HAVL r hr)- in rhavl `seq` AllTR rhavl- MoreTR L(1) -> case r of- E -> MoreTR L(0)- _ -> let rhavl = HAVL r hr in rhavl `seq` AllTR rhavl- MoreTR n_ -> dropL_ DECINT1(n_) r hr- AllTR havl1 -> let havl1' = spliceHAVL havl1 e (HAVL r hr)- in havl1' `seq` AllTR havl1'---------------------------------------------------------------------------------------------------- dropL Ends Here ------------------------------------------------------------------------------------------------------- | This is a simplified version of 'splitAtR' which returns the remaining tree only (leftmost elements).--- This function raises an error if n is negative.------ If the tree size is greater than n the result is (Right l) where l contains--- the remaining elements (l will be non-empty).------ If the tree size is less than or equal to n then the result is (Left s), where s is tree size.------ An empty tree will always yield a result of (Left 0).------ Complexity: O(n)-dropR :: Int -> AVL e -> Either Int (AVL e)-dropR n _ | n < 0 = error "dropL: Negative argument."-dropR 0 E = Left 0 -- Treat this case specially-dropR 0 t = Right t-dropR ASINT(n) t = case dropR_ n t L(0) of -- Tree Heights are relative!!- MoreTR n_ -> Left ASINT(SUBINT(n,n_))- AllTR (HAVL l _) -> Right l---- n > 0 !!--- N.B Never returns a result of form (AllTR lhavl) where lhavl is empty-dropR_ :: UINT -> AVL e -> UINT -> TakeResult e-dropR_ n E _ = MoreTR n-dropR_ n (N l e r) h = dropR__ n l DECINT2(h) e r DECINT1(h)-dropR_ n (Z l e r) h = dropR__ n l DECINT1(h) e r DECINT1(h)-dropR_ n (P l e r) h = dropR__ n l DECINT1(h) e r DECINT2(h)---- n > 0 !!--- N.B Never returns a result of form (AllTR lhavl) where lhavl is empty-dropR__ :: UINT -> AVL e -> UINT -> e -> AVL e -> UINT -> TakeResult e-dropR__ n l hl e r hr =- case dropR_ n r hr of- MoreTR L(0) -> let lhavl = pushRHAVL (HAVL l hl) e- in lhavl `seq` AllTR lhavl- MoreTR L(1) -> case l of- E -> MoreTR L(0)- _ -> let lhavl = HAVL l hl in lhavl `seq` AllTR lhavl- MoreTR n_ -> dropR_ DECINT1(n_) l hl- AllTR havl0 -> let havl0' = spliceHAVL (HAVL l hl) e havl0- in havl0' `seq` AllTR havl0'---------------------------------------------------------------------------------------------------- dropR Ends Here -------------------------------------------------------------------------------------------------------- Local Datatype for results of span operations.-data SpanResult e = Some (HAVL e) (HAVL e) -- Two tree/height pairs. Non Strict!!- | TheLot -- The Lot satisfied---- | Span an AVL tree from the left, using the supplied predicate. This function returns--- a pair of trees (l,r), where l contains the leftmost consecutive elements which--- satisfy the predicate. The leftmost element of r (if any) is the first to fail--- the predicate. Either of the resulting trees may be empty. Element ordering is preserved.------ Complexity: O(n), where n is the size of l.-spanL :: (e -> Bool) -> AVL e -> (AVL e, AVL e)-spanL p t = case spanIt t L(0) of -- Tree heights are relative- TheLot -> (t, E) -- All satisfied- Some (HAVL l _) (HAVL r _) -> (l, r) -- Some satisfied- where- spanIt E _ = TheLot- spanIt (N l e r) h = spanIt_ l DECINT2(h) e r DECINT1(h)- spanIt (Z l e r) h = spanIt_ l DECINT1(h) e r DECINT1(h)- spanIt (P l e r) h = spanIt_ l DECINT1(h) e r DECINT2(h)- -- N.B: Never Returns (Some _ (HAVL E _)) (== TheLot)- spanIt_ l hl e r hr =- case spanIt l hl of- Some havl0 havl1 -> let havl1_ = spliceHAVL havl1 e (HAVL r hr)- in havl1_ `seq` Some havl0 havl1_- TheLot -> if p e- then let spanItr = spanIt r hr- in case spanItr of- Some havl0 havl1 -> let havl0_ = spliceHAVL (HAVL l hl) e havl0- in havl0_ `seq` Some havl0_ havl1- _ -> spanItr- else let rhavl = pushLHAVL e (HAVL r hr)- lhavl = HAVL l hl- in lhavl `seq` rhavl `seq` Some lhavl rhavl---------------------------------------------------------------------------------------------------- spanL Ends Here ------------------------------------------------------------------------------------------------------- | Span an AVL tree from the right, using the supplied predicate. This function returns--- a pair of trees (l,r), where r contains the rightmost consecutive elements which--- satisfy the predicate. The rightmost element of l (if any) is the first to fail--- the predicate. Either of the resulting trees may be empty. Element ordering is preserved.------ Complexity: O(n), where n is the size of r.-spanR :: (e -> Bool) -> AVL e -> (AVL e, AVL e)-spanR p t = case spanIt t L(0) of -- Tree heights are relative- TheLot -> (E, t) -- All satisfied- Some (HAVL l _) (HAVL r _) -> (l, r) -- Some satisfied- where- spanIt E _ = TheLot- spanIt (N l e r) h = spanIt_ l DECINT2(h) e r DECINT1(h)- spanIt (Z l e r) h = spanIt_ l DECINT1(h) e r DECINT1(h)- spanIt (P l e r) h = spanIt_ l DECINT1(h) e r DECINT2(h)- -- N.B: Never Returns (Some (HAVL E _) _) (== TheLot)- spanIt_ l hl e r hr =- case spanIt r hr of- Some havl0 havl1 -> let havl0_ = spliceHAVL (HAVL l hl) e havl0- in havl0_ `seq` Some havl0_ havl1- TheLot -> if p e- then let spanItl = spanIt l hl- in case spanItl of- Some havl0 havl1 -> let havl1_ = spliceHAVL havl1 e (HAVL r hr)- in havl1_ `seq` Some havl0 havl1_- _ -> spanItl- else let lhavl = pushRHAVL (HAVL l hl) e- rhavl = HAVL r hr- in lhavl `seq` rhavl `seq` Some lhavl rhavl---------------------------------------------------------------------------------------------------- spanR Ends Here ------------------------------------------------------------------------------------------------------- Local Datatype for results of takeWhile/DropWhile operations.-data TakeWhileResult e = SomeTW (HAVL e)- | TheLotTW---- | This is a simplified version of 'spanL' which does not return the remaining tree--- The result is the leftmost consecutive sequence of elements which satisfy the--- supplied predicate (which may be empty).------ Complexity: O(n), where n is the size of the result.-takeWhileL :: (e -> Bool) -> AVL e -> AVL e-takeWhileL p t = case spanIt t L(0) of -- Tree heights are relative- TheLotTW -> t -- All satisfied- SomeTW (HAVL l _) -> l -- Some satisfied- where- spanIt E _ = TheLotTW- spanIt (N l e r) h = spanIt_ l DECINT2(h) e r DECINT1(h)- spanIt (Z l e r) h = spanIt_ l DECINT1(h) e r DECINT1(h)- spanIt (P l e r) h = spanIt_ l DECINT1(h) e r DECINT2(h)- spanIt_ l hl e r hr =- let twl = spanIt l hl- in case twl of- TheLotTW -> if p e- then let twr = spanIt r hr- in case twr of- SomeTW havl0 -> let havl0_ = spliceHAVL (HAVL l hl) e havl0- in havl0_ `seq` SomeTW havl0_- _ -> twr- else let lhavl = HAVL l hl in lhavl `seq` SomeTW lhavl- _ -> twl-------------------------------------------------------------------------------------------------- takeWhileL Ends Here ---------------------------------------------------------------------------------------------------- | This is a simplified version of 'spanR' which does not return the remaining tree--- The result is the rightmost consecutive sequence of elements which satisfy the--- supplied predicate (which may be empty).------ Complexity: O(n), where n is the size of the result.-takeWhileR :: (e -> Bool) -> AVL e -> AVL e-takeWhileR p t = case spanIt t L(0) of -- Tree heights are relative- TheLotTW -> t -- All satisfied- SomeTW (HAVL r _) -> r -- Some satisfied- where- spanIt E _ = TheLotTW- spanIt (N l e r) h = spanIt_ l DECINT2(h) e r DECINT1(h)- spanIt (Z l e r) h = spanIt_ l DECINT1(h) e r DECINT1(h)- spanIt (P l e r) h = spanIt_ l DECINT1(h) e r DECINT2(h)- spanIt_ l hl e r hr =- let twr = spanIt r hr- in case twr of- TheLotTW -> if p e- then let twl = spanIt l hl- in case twl of- SomeTW havl1 -> let havl1_ = spliceHAVL havl1 e (HAVL r hr)- in havl1_ `seq` SomeTW havl1_- _ -> twl- else let rhavl = HAVL r hr in rhavl `seq` SomeTW rhavl- _ -> twr-------------------------------------------------------------------------------------------------- takeWhileR Ends Here ---------------------------------------------------------------------------------------------------- | This is a simplified version of 'spanL' which does not return the tree containing--- the elements which satisfy the supplied predicate.--- The result is a tree whose leftmost element is the first to fail the predicate, starting from--- the left (which may be empty).------ Complexity: O(n), where n is the number of elements dropped.-dropWhileL :: (e -> Bool) -> AVL e -> AVL e-dropWhileL p t = case spanIt t L(0) of -- Tree heights are relative- TheLotTW -> E -- All satisfied- SomeTW (HAVL r _) -> r -- Some satisfied- where- spanIt E _ = TheLotTW- spanIt (N l e r) h = spanIt_ l DECINT2(h) e r DECINT1(h)- spanIt (Z l e r) h = spanIt_ l DECINT1(h) e r DECINT1(h)- spanIt (P l e r) h = spanIt_ l DECINT1(h) e r DECINT2(h)- spanIt_ l hl e r hr =- case spanIt l hl of- SomeTW havl1 -> let havl1_ = spliceHAVL havl1 e (HAVL r hr)- in havl1_ `seq` SomeTW havl1_- TheLotTW -> if p e- then spanIt r hr- else let rhavl = pushLHAVL e (HAVL r hr)- in rhavl `seq` SomeTW rhavl----------------------------------------------------------------------------------------------- dropWhileL Ends Here ------------------------------------------------------------------------------------------------------- | This is a simplified version of 'spanR' which does not return the tree containing--- the elements which satisfy the supplied predicate.--- The result is a tree whose rightmost element is the first to fail the predicate, starting from--- the right (which may be empty).------ Complexity: O(n), where n is the number of elements dropped.-dropWhileR :: (e -> Bool) -> AVL e -> AVL e-dropWhileR p t = case spanIt t L(0) of -- Tree heights are relative- TheLotTW -> E -- All satisfied- SomeTW (HAVL l _) -> l -- Some satisfied- where- spanIt E _ = TheLotTW- spanIt (N l e r) h = spanIt_ l DECINT2(h) e r DECINT1(h)- spanIt (Z l e r) h = spanIt_ l DECINT1(h) e r DECINT1(h)- spanIt (P l e r) h = spanIt_ l DECINT1(h) e r DECINT2(h)- spanIt_ l hl e r hr =- case spanIt r hr of- SomeTW havl0 -> let havl0_ = spliceHAVL (HAVL l hl) e havl0- in havl0_ `seq` SomeTW havl0_- TheLotTW -> if p e- then spanIt l hl- else let lhavl = pushRHAVL (HAVL l hl) e- in lhavl `seq` SomeTW lhavl----------------------------------------------------------------------------------------------- dropWhileR Ends Here -------------------------------------------------------------------------------------------------------- | Rotate an AVL tree one place left. This function pops the leftmost element and pushes into--- the rightmost position. An empty tree yields an empty tree.------ Complexity: O(log n)-rotateL :: AVL e -> AVL e-rotateL E = E-rotateL (N l e r) = case popLN l e r of UBT2(e_,t) -> pushR t e_-rotateL (Z l e r) = case popLZ l e r of UBT2(e_,t) -> pushR t e_-rotateL (P l e r) = case popLP l e r of UBT2(e_,t) -> pushR t e_---- | Rotate an AVL tree one place right. This function pops the rightmost element and pushes into--- the leftmost position. An empty tree yields an empty tree.------ Complexity: O(log n)-rotateR :: AVL e -> AVL e-rotateR E = E-rotateR (N l e r) = case popRN l e r of UBT2(t,e_) -> pushL e_ t-rotateR (Z l e r) = case popRZ l e r of UBT2(t,e_) -> pushL e_ t-rotateR (P l e r) = case popRP l e r of UBT2(t,e_) -> pushL e_ t---- | Similar to 'rotateL', but returns the rotated element. This function raises an error if--- applied to an empty tree.------ Complexity: O(log n)-popRotateL :: AVL e -> (e, AVL e)-popRotateL E = error "popRotateL: Empty tree."-popRotateL (N l e r) = case popLN l e r of UBT2(e_,t) -> popRotateL' e_ t-popRotateL (Z l e r) = case popLZ l e r of UBT2(e_,t) -> popRotateL' e_ t-popRotateL (P l e r) = case popLP l e r of UBT2(e_,t) -> popRotateL' e_ t-popRotateL' :: e -> AVL e -> (e, AVL e)-popRotateL' e t = let t' = pushR t e in t' `seq` (e,t')---- | Similar to 'rotateR', but returns the rotated element. This function raises an error if--- applied to an empty tree.------ Complexity: O(log n)-popRotateR :: AVL e -> (AVL e, e)-popRotateR E = error "popRotateR: Empty tree."-popRotateR (N l e r) = case popRN l e r of UBT2(t,e_) -> popRotateR' t e_-popRotateR (Z l e r) = case popRZ l e r of UBT2(t,e_) -> popRotateR' t e_-popRotateR (P l e r) = case popRP l e r of UBT2(t,e_) -> popRotateR' t e_-popRotateR' :: AVL e -> e -> (AVL e, e)-popRotateR' t e = let t' = pushL e t in t' `seq` (t',e)----- | Rotate an AVL tree left by n places. If s is the size of the tree then ordinarily n--- should be in the range [0..s-1]. However, this function will deliver a correct result--- for any n (n\<0 or n\>=s), the actual rotation being given by (n \`mod\` s) in such cases.--- The result of rotating an empty tree is an empty tree.------ Complexity: O(n)-rotateByL :: AVL e -> Int -> AVL e-rotateByL t ASINT(n) = case COMPAREUINT n L(0) of- LT -> rotateByR__ t NEGATE(n)- EQ -> t- GT -> rotateByL__ t n--- n>=0!!-{-# INLINE rotateByL_ #-}-rotateByL_ :: AVL e -> UINT -> AVL e-rotateByL_ t L(0) = t-rotateByL_ t n = rotateByL__ t n--- n>0!!-rotateByL__ :: AVL e -> UINT -> AVL e-rotateByL__ E _ = E-rotateByL__ t n = case splitL n t L(0) of -- Tree Heights are relative!!- More L(0) -> t- More m -> let s = SUBINT(n,m) -- Actual size of tree, > 0!!- n_ = _MODULO_(n,s) -- Actual shift required, 0..s-1- in if ADDINT(n_,n_) LEQ s- then rotateByL_ t n_ -- n_ may be 0 !!- else rotateByR__ t SUBINT(s,n_) -- (s-n_) can't be 0- All (HAVL l hl) (HAVL r hr) -> joinH' r hr l hl----- | Rotate an AVL tree right by n places. If s is the size of the tree then ordinarily n--- should be in the range [0..s-1]. However, this function will deliver a correct result--- for any n (n\<0 or n\>=s), the actual rotation being given by (n \`mod\` s) in such cases.--- The result of rotating an empty tree is an empty tree.------ Complexity: O(n)-rotateByR :: AVL e -> Int -> AVL e-rotateByR t ASINT(n) = case COMPAREUINT n L(0) of- LT -> rotateByL__ t NEGATE(n)- EQ -> t- GT -> rotateByR__ t n--- n>=0!!-{-# INLINE rotateByR_ #-}-rotateByR_ :: AVL e -> UINT -> AVL e-rotateByR_ t L(0) = t-rotateByR_ t n = rotateByR__ t n--- n>0!!-rotateByR__ :: AVL e -> UINT -> AVL e-rotateByR__ E _ = E-rotateByR__ t n = case splitR n t L(0) of -- Tree Heights are relative!!- More L(0) -> t- More m -> let s = SUBINT(n,m) -- Actual size of tree, > 0!!- n_ = _MODULO_(n,s) -- Actual shift required, 0..s-1- in if ADDINT(n_,n_) LEQ s- then rotateByR_ t n_ -- n_ may be 0 !!- else rotateByL__ t SUBINT(s,n_) -- (s-n_) can_t be 0- All (HAVL l hl) (HAVL r hr) -> joinH' r hr l hl----- | Divide a sorted AVL tree into left and right sorted trees (l,r), such that l contains all the--- elements less than or equal to according to the supplied selector and r contains all the elements greater than--- according to the supplied selector.------ Complexity: O(log n)-forkL :: (e -> Ordering) -> AVL e -> (AVL e, AVL e)-forkL c avl = let (HAVL l _,HAVL r _) = forkL_ L(0) avl -- Tree heights are relative- in (l,r)- where- forkL_ h E = (HAVL E h, HAVL E h)- forkL_ h (N l e r) = forkL__ l DECINT2(h) e r DECINT1(h)- forkL_ h (Z l e r) = forkL__ l DECINT1(h) e r DECINT1(h)- forkL_ h (P l e r) = forkL__ l DECINT1(h) e r DECINT2(h)- forkL__ l hl e r hr = case c e of- -- Current element > pivot, so goes in right half- LT -> let (havl0,havl1) = forkL_ hl l- havl1_ = spliceHAVL havl1 e (HAVL r hr)- in havl1_ `seq` (havl0, havl1_)- -- Current element = pivot, so goes in left half and stop here- EQ -> let lhavl = pushRHAVL (HAVL l hl) e- rhavl = HAVL r hr- in lhavl `seq` rhavl `seq` (lhavl,rhavl)- -- Current element < pivot, so goes in left half- GT -> let (havl0,havl1) = forkL_ hr r- havl0_ = spliceHAVL (HAVL l hl) e havl0- in havl0_ `seq` (havl0_, havl1)---- | Divide a sorted AVL tree into left and right sorted trees (l,r), such that l contains all the--- elements less than supplied selector and r contains all the elements greater than or equal to the--- supplied selector.------ Complexity: O(log n)-forkR :: (e -> Ordering) -> AVL e -> (AVL e, AVL e)-forkR c avl = let (HAVL l _,HAVL r _) = forkR_ L(0) avl -- Tree heights are relative- in (l,r)- where- forkR_ h E = (HAVL E h, HAVL E h)- forkR_ h (N l e r) = forkR__ l DECINT2(h) e r DECINT1(h)- forkR_ h (Z l e r) = forkR__ l DECINT1(h) e r DECINT1(h)- forkR_ h (P l e r) = forkR__ l DECINT1(h) e r DECINT2(h)- forkR__ l hl e r hr = case c e of- -- Current element > pivot, so goes in right half- LT -> let (havl0,havl1) = forkR_ hl l- havl1_ = spliceHAVL havl1 e (HAVL r hr)- in havl1_ `seq` (havl0, havl1_)- -- Current element = pivot, so goes in right half and stop here- EQ -> let rhavl = pushLHAVL e (HAVL r hr)- lhavl = HAVL l hl- in lhavl `seq` rhavl `seq` (lhavl, rhavl)- -- Current element < pivot, so goes in left half- GT -> let (havl0,havl1) = forkR_ hr r- havl0_ = spliceHAVL (HAVL l hl) e havl0- in havl0_ `seq` (havl0_, havl1)----- | Similar to 'forkL' and 'forkR', but returns any equal element found (instead of--- incorporating it into the left or right tree results respectively).------ Complexity: O(log n)-fork :: (e -> COrdering a) -> AVL e -> (AVL e, Maybe a, AVL e)-fork c avl = let (HAVL l _, mba, HAVL r _) = fork_ L(0) avl -- Tree heights are relative- in (l,mba,r)- where- fork_ h E = (HAVL E h, Nothing, HAVL E h)- fork_ h (N l e r) = fork__ l DECINT2(h) e r DECINT1(h)- fork_ h (Z l e r) = fork__ l DECINT1(h) e r DECINT1(h)- fork_ h (P l e r) = fork__ l DECINT1(h) e r DECINT2(h)- fork__ l hl e r hr = case c e of- -- Current element > pivot- Lt -> let (havl0,mba,havl1) = fork_ hl l- havl1_ = spliceHAVL havl1 e (HAVL r hr)- in havl1_ `seq` (havl0, mba, havl1_)- -- Current element = pivot- Eq a -> let lhavl = HAVL l hl- rhavl = HAVL r hr- in lhavl `seq` rhavl `seq` (lhavl, Just a, rhavl)- -- Current element < pivot- Gt -> let (havl0,mba,havl1) = fork_ hr r- havl0_ = spliceHAVL (HAVL l hl) e havl0- in havl0_ `seq` (havl0_, mba, havl1)---- | This is a simplified version of 'forkL' which returns a sorted tree containing--- only those elements which are less than or equal to according to the supplied selector.--- This function also has the synonym 'dropGT'.------ Complexity: O(log n)-takeLE :: (e -> Ordering) -> AVL e -> AVL e-takeLE c avl = let HAVL l _ = forkL_ L(0) avl -- Tree heights are relative- in l- where- forkL_ h E = HAVL E h- forkL_ h (N l e r) = forkL__ l DECINT2(h) e r DECINT1(h)- forkL_ h (Z l e r) = forkL__ l DECINT1(h) e r DECINT1(h)- forkL_ h (P l e r) = forkL__ l DECINT1(h) e r DECINT2(h)- forkL__ l hl e r hr = case c e of- LT -> forkL_ hl l- EQ -> pushRHAVL (HAVL l hl) e- GT -> let havl0 = forkL_ hr r- in spliceHAVL (HAVL l hl) e havl0----- | A synonym for 'takeLE'.------ Complexity: O(log n)-dropGT :: (e -> Ordering) -> AVL e -> AVL e-dropGT = takeLE-{-# INLINE dropGT #-}---- | This is a simplified version of 'forkL' which returns a sorted tree containing--- only those elements which are greater according to the supplied selector.--- This function also has the synonym 'dropLE'.------ Complexity: O(log n)-takeGT :: (e -> Ordering) -> AVL e -> AVL e-takeGT c avl = let HAVL r _ = forkL_ L(0) avl -- Tree heights are relative- in r- where- forkL_ h E = HAVL E h- forkL_ h (N l e r) = forkL__ l DECINT2(h) e r DECINT1(h)- forkL_ h (Z l e r) = forkL__ l DECINT1(h) e r DECINT1(h)- forkL_ h (P l e r) = forkL__ l DECINT1(h) e r DECINT2(h)- forkL__ l hl e r hr = case c e of- LT -> let havl1 = forkL_ hl l- in spliceHAVL havl1 e (HAVL r hr)- EQ -> HAVL r hr- GT -> forkL_ hr r---- | A synonym for 'takeGT'.------ Complexity: O(log n)-dropLE :: (e -> Ordering) -> AVL e -> AVL e-dropLE = takeGT-{-# INLINE dropLE #-}---- | This is a simplified version of 'forkR' which returns a sorted tree containing--- only those elements which are less than according to the supplied selector.--- This function also has the synonym 'dropGE'.------ Complexity: O(log n)-takeLT :: (e -> Ordering) -> AVL e -> AVL e-takeLT c avl = let HAVL l _ = forkL_ L(0) avl -- Tree heights are relative- in l- where- forkL_ h E = HAVL E h- forkL_ h (N l e r) = forkL__ l DECINT2(h) e r DECINT1(h)- forkL_ h (Z l e r) = forkL__ l DECINT1(h) e r DECINT1(h)- forkL_ h (P l e r) = forkL__ l DECINT1(h) e r DECINT2(h)- forkL__ l hl e r hr = case c e of- LT -> forkL_ hl l- EQ -> HAVL l hl- GT -> let havl0 = forkL_ hr r- in spliceHAVL (HAVL l hl) e havl0----- | A synonym for 'takeLT'.------ Complexity: O(log n)-dropGE :: (e -> Ordering) -> AVL e -> AVL e-dropGE = takeLT-{-# INLINE dropGE #-}---- | This is a simplified version of 'forkR' which returns a sorted tree containing--- only those elements which are greater or equal to according to the supplied selector.--- This function also has the synonym 'dropLT'.------ Complexity: O(log n)-takeGE :: (e -> Ordering) -> AVL e -> AVL e-takeGE c avl = let HAVL r _ = forkL_ L(0) avl -- Tree heights are relative- in r- where- forkL_ h E = HAVL E h- forkL_ h (N l e r) = forkL__ l DECINT2(h) e r DECINT1(h)- forkL_ h (Z l e r) = forkL__ l DECINT1(h) e r DECINT1(h)- forkL_ h (P l e r) = forkL__ l DECINT1(h) e r DECINT2(h)- forkL__ l hl e r hr = case c e of- LT -> let havl1 = forkL_ hl l- in spliceHAVL havl1 e (HAVL r hr)- EQ -> pushLHAVL e (HAVL r hr)- GT -> forkL_ hr r---- | A synonym for 'takeGE'.------ Complexity: O(log n)-dropLT :: (e -> Ordering) -> AVL e -> AVL e-dropLT = takeGE-{-# INLINE dropLT #-}-
− Data/Tree/AVL/Test/AllTests.hs
@@ -1,1517 +0,0 @@-{-# OPTIONS -fglasgow-exts #-}--------------------------------------------------------------------------------- |--- Module : Data.Tree.AVL.Test.AllTests--- Copyright : (c) Adrian Hey 2004,2005,2006,2007--- License : BSD3------ Maintainer : http://homepages.nildram.co.uk/~ahey/em.png--- Stability : unstable--- Portability : portable------ This module contains a large set of fairly comprehensive but extremely--- time consuming tests of AVL tree functions (not based on QuickCheck).------ They can all be run using 'allTests', or they can be run individually.-------------------------------------------------------------------------------module Data.Tree.AVL.Test.AllTests-(allTests-,testReadPath-,testIsBalanced-,testIsSorted-,testSize-,testClipSize-,testWrite-,testPush-,testPushL-,testPushR-,testDelete-,testAssertDelL-,testAssertDelR-,testAssertPopL-,testPopHL-,testAssertPopR-,testAssertPop-,testFlatten-,testJoin-,testJoinHAVL-,testConcatAVL-,testFlatConcat-,testFoldr-,testFoldr'-,testFoldl-,testFoldl'-,testFoldr1-,testFoldr1'-,testFoldl1-,testFoldl1'-,testMapAccumL-,testMapAccumR-,testMapAccumL'-,testMapAccumR'-#ifdef __GLASGOW_HASKELL__-,testMapAccumL''-,testMapAccumR''-#endif-,testSplitAtL-,testFilterViaList-,testFilter-,testMapMaybeViaList-,testMapMaybe-,testTakeL-,testDropL-,testSplitAtR-,testTakeR-,testDropR-,testSpanL-,testTakeWhileL-,testDropWhileL-,testSpanR-,testTakeWhileR-,testDropWhileR-,testRotateL-,testRotateR-,testRotateByL-,testRotateByR-,testForkL-,testForkR-,testFork-,testTakeLE-,testTakeGT-,testTakeGE-,testTakeLT-,testUnion-,testDisjointUnion-,testUnionMaybe-,testIntersection-,testIntersectionMaybe-,testIntersectionAsList-,testIntersectionMaybeAsList-,testDifference-,testDifferenceMaybe-,testSymDifference-,testIsSubsetOf-,testIsSubsetOfBy-,testVenn-,testVennMaybe-,testCompareHeight-,testShowReadEq--- Zipper tests-,testOpenClose-,testDelClose-,testOpenLClose-,testOpenRClose-,testMoveL-,testMoveR-,testInsertL-,testInsertMoveL-,testInsertR-,testInsertMoveR-,testInsertTreeL-,testInsertTreeR-,testDelMoveL-,testDelMoveR-,testDelAllL-,testDelAllR-,testDelAllCloseL-,testDelAllIncCloseL-,testDelAllCloseR-,testDelAllIncCloseR-,testZipSize-,testTryOpenLE-,testTryOpenGE-,testOpenEither-,testBAVLtoZipper-) where--import Prelude hiding (reverse,map,replicate,filter,foldr,foldr1,foldl,foldl1) -- so haddock finds the symbols there--import Data.COrdering-import Data.Tree.AVLX--import qualified Data.List as L (replicate,reverse,filter,foldr1,foldl1,map,insert,mapAccumL,mapAccumR)-import System.Exit(exitFailure)--#ifdef __GLASGOW_HASKELL__-import GHC.Base(Int#,Int(..))-#include "ghcdefs.h"-#else-#include "h98defs.h"-#endif----- import Debug.Trace(trace)--- import System.IO.Unsafe(unsafePerformIO)---- | Run every test in this module (takes a very long time).-allTests :: IO ()-allTests =- do testReadPath- testIsBalanced- testIsSorted- testSize- testClipSize- testWrite- testPush- testPushL- testPushR- testDelete- testAssertDelL- testAssertDelR- testAssertPopL- testPopHL- testAssertPopR- testAssertPop- testFlatten- testJoin- testJoinHAVL- testConcatAVL- testFlatConcat- testFoldr- testFoldr'- testFoldl- testFoldl'- testFoldr1- testFoldr1'- testFoldl1- testFoldl1'- testMapAccumL- testMapAccumR- testMapAccumL'- testMapAccumR'-#ifdef __GLASGOW_HASKELL__- testMapAccumL''- testMapAccumR''-#endif- testSplitAtL- testFilterViaList- testFilter- testMapMaybeViaList- testMapMaybe- testTakeL- testDropL- testSplitAtR- testTakeR- testDropR- testSpanL- testTakeWhileL- testDropWhileL- testSpanR- testTakeWhileR- testDropWhileR- testRotateL- testRotateR- testRotateByL- testRotateByR- testForkL- testForkR- testFork- testTakeLE- testTakeGT- testTakeGE- testTakeLT- testUnion- testDisjointUnion- testUnionMaybe- testIntersection- testIntersectionMaybe- testIntersectionAsList- testIntersectionMaybeAsList- testDifference- testDifferenceMaybe- testSymDifference- testIsSubsetOf- testIsSubsetOfBy- testVenn- testVennMaybe- testCompareHeight- testShowReadEq--- Zipper tests- testOpenClose- testDelClose- testOpenLClose- testOpenRClose- testMoveL- testMoveR- testInsertL- testInsertMoveL- testInsertR- testInsertMoveR- testInsertTreeL- testInsertTreeR- testDelMoveL- testDelMoveR- testDelAllL- testDelAllR- testDelAllCloseL- testDelAllIncCloseL- testDelAllCloseR- testDelAllIncCloseR- testZipSize- testTryOpenLE- testTryOpenGE- testOpenEither- testBAVLtoZipper----- | Test isBalanced is capable of failing for a few non-AVL trees.-testIsBalanced :: IO ()-testIsBalanced = do title "isBalanced"- if or [isBalanced t | t <- nonAVLs] then failed else passed- where nonAVLs :: [AVL Int]- nonAVLs = [Z E 0 (Z E 0 E)- ,Z (Z E 0 E) 0 E- ,N E 0 E- ,P E 0 E- ]---- | Test isSorted is capable of failing for a few non-sorted trees.-testIsSorted :: IO ()-testIsSorted = do title "isSorted"- if or [isSorted compare (asTreeL l) | l <- nonSorted] then failed else passed- where nonSorted = ["AA","BA"- ,"AAA","ABA","ABB","AAB"- ,"AABC","ACBA","ABCC","ABBB","AAAB"- ]---- | Test size function-testSize :: IO ()-testSize = do title "size"- exhaustiveTest test (take 6 allAVL)- where test _ s t = size t == s---- | Test clipSize function-testClipSize :: IO ()-testClipSize = do title "clipSize"- exhaustiveTest test (take 6 allAVL)- where test _ s t = all (== Nothing) [clipSize n t | n <- [0..s-1 ]] &&- all (== Just s ) [clipSize n t | n <- [s..s+10]]---- | Test write function-testWrite :: IO ()-testWrite = do title "write"- exhaustiveTest test (take 5 allNonEmptyAVL)- where test _ s t = all test_ [0..s-1]- where test_ n = let t_ = write (withCC' (+) n) t- in isBalanced t_ && (asListL t_ == [0..n-1]++(n+n):[n+1..s-1])----- | Test push function-testPush :: IO ()--- Also exercises: map' and contains-testPush = do title "push"- exhaustiveTest test (take 6 allAVL)- where test h s t = all oddTest odds && all evenTest evens- where t_ = map' (\n -> 2*n+1) t -- t_ elements are odd, 1,3..2*s-1- odds = [1,3..2*s-1]- evens = [0,2..2*s ]- oddTest n = let t__ = psh n t_ -- Should yield identical trees- s__ = size t__- h__ = ASINT(height t__)- in (s__ == s) && (isSortedOK compare t__) && (h__== h)- evenTest n = let t__ = psh n t_- s__ = size t__- h__ = ASINT(height t__)- in (s__ == s+1) && (isSortedOK compare t__) && (h__-h <= 1) && (t__ `contns` n)- psh e = push (sndCC e) e- contns avl e = contains avl (compare e)---- | Test delete function-testDelete :: IO ()-testDelete = do title "delete"- exhaustiveTest test (take 5 allNonEmptyAVL)- where test h s t = all oddTest odds && all evenTest evens- where t_ = map' (\n -> 2*n+1) t -- t_ elements are odd, 1,3..2*s-1- odds = [1,3..2*s-1]- evens = [0,2..2*s ]- oddTest n = let t__ = del n t_- in case checkHeight t__ of- Just h_ -> (h-h_<=1) && (L.insert n (asListL t__) == odds)- Nothing -> False- evenTest n = let t__ = del n t_- in case checkHeight t__ of- Just h_ -> (h==h_) && (asListL t__ == odds)- Nothing -> False- del e = delete (compare e)---- | Test assertPop function-testAssertPop :: IO ()-testAssertPop =- do title "assertPop"- exhaustiveTest test (take 5 allNonEmptyAVL)- where test h s t = all testElem elems- where elems = [0,1..s-1]- testElem n = let (n_,t_) = assertPop (fstCC n) t- in case checkHeight t_ of- Just h_ -> (h-h_<=1) && (L.insert n_ (asListL t_) == elems)- Nothing -> False---- | Test pushL function--- Also exercises: asListL-testPushL :: IO ()-testPushL = do title "pushL"- exhaustiveTest test (take 6 allAVL)- where test h _ t = let t_ = 0 `pushL` t- in case checkHeight t_ of- Just h_ | (h_==h+1) || (h_==h) -> asListL t_ == (0 : asListL t)- _ -> False---- | Test pushR function--- Also exercises: asListR-testPushR :: IO ()-testPushR = do title "pushR"- exhaustiveTest test (take 6 allAVL)- where test h s t = let t_ = t `pushR` s- in case checkHeight t_ of- Just h_ | (h_==h+1) || (h_==h) -> asListR t_ == (s : asListR t)- _ -> False---- | Test assertDelL function--- Also exercises: asListL-testAssertDelL :: IO ()-testAssertDelL =- do title "assertDelL"- exhaustiveTest test (take 5 allNonEmptyAVL)- where test h _ t = let t_ = assertDelL t- in case checkHeight t_ of- Just h_ | (h_==h-1) || (h_==h) -> asListL t_ == (tail $ asListL t)- _ -> False---- | Test delR function--- Also exercises: asListR-testAssertDelR :: IO ()-testAssertDelR =- do title "assertDelR"- exhaustiveTest test (take 5 allNonEmptyAVL)- where test h _ t = let t_ = assertDelR t- in case checkHeight t_ of- Just h_ | (h_==h-1) || (h_==h) -> asListR t_ == (tail $ asListR t)- _ -> False---- | Test assertPopL function--- Also exercises: asListL-testAssertPopL :: IO ()-testAssertPopL =- do title "assertPopL"- exhaustiveTest test (take 5 allNonEmptyAVL)- where test h _ t = let (v,t_) = assertPopL t- in case checkHeight t_ of- Just h_ | (h_==h-1) || (h_==h) -> (v : asListL t_) == asListL t- _ -> False---- | Test popHL function--- This test can only be run if popHL and HAVL are not hidden.--- However, popHL is exercised by indirectly by testConcatAVL anyway-testPopHL :: IO ()-testPopHL = do title "popHL"- exhaustiveTest test (take 5 allNonEmptyAVL)- where test _ _ t = let UBT3(v, t_,h) = popHL t- in case checkHeight t_ of- Just h_ | (h_== ASINT(h)) -> (v : asListL t_) == asListL t- _ -> False----- | Test assertPopR function--- Also exercises: asListR-testAssertPopR :: IO ()-testAssertPopR =- do title "assertPopR"- exhaustiveTest test (take 5 allNonEmptyAVL)- where test h _ t = let (t_,v) = assertPopR t- in case checkHeight t_ of- Just h_ | (h_==h-1) || (h_==h) -> (v : asListR t_) == asListR t- _ -> False---- | Test flatten function--- Also exercises: asListL,replicateAVL-testFlatten :: IO ()-testFlatten = do title "flatten"- exhaustiveTest test (take 6 allAVL)- where test _ _ t = let t_ = flatten t- in isBalanced t_ && (asListL t == asListL t_)---- | Test foldr-testFoldr :: IO ()-testFoldr = do title "foldr"- exhaustiveTest test (take 6 allAVL)- where test _ s t = foldr (:) [] t == [0..s-1]--- | Test foldr'-testFoldr' :: IO ()-testFoldr' = do title "foldr'"- exhaustiveTest test (take 6 allAVL)- where test _ s t = foldr' (:) [] t == [0..s-1]--- | Test foldl-testFoldl :: IO ()-testFoldl = do title "foldl"- exhaustiveTest test (take 6 allAVL)- where test _ s t = foldl (flip (:)) [] t == [s-1,s-2..0]--- | Test foldl'-testFoldl' :: IO ()-testFoldl' = do title "foldl'"- exhaustiveTest test (take 6 allAVL)- where test _ s t = foldl' (flip (:)) [] t == [s-1,s-2..0]--- | Test foldr1-testFoldr1 :: IO ()-testFoldr1 = do title "foldr1"- exhaustiveTest test (take 5 allNonEmptyAVL)- where test _ s t = foldr1 (-) t == L.foldr1 (-) [0..s-1]--- | Test foldr1'-testFoldr1' :: IO ()-testFoldr1' = do title "foldr1'"- exhaustiveTest test (take 5 allNonEmptyAVL)- where test _ s t = foldr1' (-) t == L.foldr1 (-) [0..s-1]--- | Test foldl1-testFoldl1 :: IO ()-testFoldl1 = do title "foldl1"- exhaustiveTest test (take 5 allNonEmptyAVL)- where test _ s t = foldl1 (-) t == L.foldl1 (-) [0..s-1]--- | Test foldl1'-testFoldl1' :: IO ()-testFoldl1' = do title "foldl1'"- exhaustiveTest test (take 5 allNonEmptyAVL)- where test _ s t = foldl1' (-) t == L.foldl1 (-) [0..s-1]---- | Test mapAccumL-testMapAccumL :: IO ()-testMapAccumL = do title "mapAccumL"- exhaustiveTest test (take 6 allAVL)- where test _ _ t = let (nt,t') = mapAccumL f 0 t- (nl,l ) = L.mapAccumL f 0 (asListL t)- in (nt==nl) && ((asListL t') == l) && (isSortedOK compare t')- f acc n = (acc+n,n+1)---- | Test mapAccumR-testMapAccumR :: IO ()-testMapAccumR = do title "mapAccumR"- exhaustiveTest test (take 6 allAVL)- where test _ _ t = let (nt,t') = mapAccumR f 0 t- (nl,l ) = L.mapAccumR f 0 (asListL t)- in (nt==nl) && ((asListL t') == l) && (isSortedOK compare t')- f acc n = (acc+n,n+1)---- | Test mapAccumL'-testMapAccumL' :: IO ()-testMapAccumL' = do title "mapAccumL'"- exhaustiveTest test (take 6 allAVL)- where test _ _ t = let (nt,t') = mapAccumL' f 0 t- (nl,l ) = L.mapAccumL f 0 (asListL t)- in (nt==nl) && ((asListL t') == l) && (isSortedOK compare t')- f acc n = (acc+n,n+1)---- | Test mapAccumR'-testMapAccumR' :: IO ()-testMapAccumR' = do title "mapAccumR'"- exhaustiveTest test (take 6 allAVL)- where test _ _ t = let (nt,t') = mapAccumR' f 0 t- (nl,l ) = L.mapAccumR f 0 (asListL t)- in (nt==nl) && ((asListL t') == l) && (isSortedOK compare t')- f acc n = (acc+n,n+1)--#ifdef __GLASGOW_HASKELL__--- | Test mapAccumL''-testMapAccumL'' :: IO ()-testMapAccumL'' = do title "mapAccumL''"- exhaustiveTest test (take 6 allAVL)- where test _ _ t = let (nt,t') = mapAccumL'' f_ 0 t- (nl,l ) = L.mapAccumL f 0 (asListL t)- in (nt==nl) && ((asListL t') == l) && (isSortedOK compare t')- f_ acc n = UBT2(acc+n,n+1)- f acc n = (acc+n,n+1)---- | Test mapAccumR''-testMapAccumR'' :: IO ()-testMapAccumR'' = do title "mapAccumR''"- exhaustiveTest test (take 6 allAVL)- where test _ _ t = let (nt,t') = mapAccumR'' f_ 0 t- (nl,l ) = L.mapAccumR f 0 (asListL t)- in (nt==nl) && ((asListL t') == l) && (isSortedOK compare t')- f_ acc n = UBT2(acc+n,n+1)- f acc n = (acc+n,n+1)-#endif---- | Test the join function-testJoin :: IO ()-testJoin = let trees = take num $ concatMap (\(_,ts) -> ts) allAVL- num = 2000- in do title "join"- putStrLn $ "Testing " ++ show (num*num) ++ " tree pairs.."- if and [test l $ map (ls+) r | (l,ls) <- trees, (r,_) <- trees] then passed else failed- where test l r = let j = l `join` r- in isBalanced j && (asListL j == l `toListL` asListL r)---- | Test the joinHAVL function-testJoinHAVL :: IO ()-testJoinHAVL = let trees = take num $ concatMap (\(_,ts) -> ts) allAVL- num = 2000- in do title "joinHAVL"- putStrLn $ "Testing " ++ show (num*num) ++ " tree pairs.."- if and [test l $ map (ls+) r | (l,ls) <- trees, (r,_) <- trees] then passed else failed- where test l r = let (HAVL j hj) = (toHAVL l) `joinHAVL` (toHAVL r)- in case checkHeight j of- Nothing -> False- Just hj_ -> (ASINT(hj) == hj_) && (asListL j == l `toListL` asListL r)---- | Test the concatAVL function.-testConcatAVL :: IO ()-testConcatAVL = let trees = take num $ concatMap (\(_,ts) -> ts) allAVL- num = 2000- in do title "concatAVL"- putStrLn $ "Testing " ++ show (num*num) ++ " tree pairs.."- if others && and [test ls l $ map (\n -> n+(ls+1)) r- | (l,ls) <- trees, (r,_) <- trees]- then passed else failed- where test ls l r = let j = concatAVL $ [empty,empty,l,empty,singleton ls,empty,r,empty,empty]- in isBalanced j && (asListL j == l `toListL` (ls:asListL r))- others = all (isEmpty . concatAVL) [[],[empty],[empty,empty],[empty,empty,empty]]- && (all test1 $ concatMap (\ss -> [ss,"":ss,"Z":ss])- [[""]- ,["A"]- ,["","A","BC","","D","","EFGH","I"]- ]- )- test1 ss = let t = concatAVL $ L.map asTreeL ss- in isBalanced t && (asListL t == concat ss)---- | Test the flatConcat function.-testFlatConcat :: IO ()-testFlatConcat = let trees = take num $ concatMap (\(_,ts) -> ts) allAVL- num = 2000- in do title "flatConcat"- putStrLn $ "Testing " ++ show (num*num) ++ " tree pairs.."- if others && and [test ls l $ map (\n -> n+(ls+1)) r- | (l,ls) <- trees, (r,_) <- trees]- then passed else failed- where test ls l r = let j = flatConcat $ [empty,empty,l,empty,singleton ls,empty,r,empty,empty]- in isBalanced j && (asListL j == l `toListL` (ls:asListL r))- others = all (isEmpty . flatConcat) [[],[empty],[empty,empty],[empty,empty,empty]]- && (all test1 $ concatMap (\ss -> [ss,"":ss,"Z":ss])- [[""]- ,["A"]- ,["","A","BC","","D","","EFGH","I"]- ]- )- test1 ss = let t = flatConcat $ L.map asTreeL ss- in isBalanced t && (asListL t == concat ss)---- | Test the filterViaList function-testFilterViaList :: IO ()-testFilterViaList = do title "filterViaList"- exhaustiveTest test (take 6 allAVL)- where test _ s t = all testit [0..s] -- n==s should yield unmodified tree- where testit n = let t' = filterViaList (/= n) t- in (isSortedOK compare t') && (asListL t' == ([0..n-1]++[n+1..s-1]))---- | Test the filter function-testFilter :: IO ()-testFilter = do title "filter"- exhaustiveTest test (take 6 allAVL)- where test _ s t = all testit [0..s] -- n==s should yield unmodified tree- where testit n = let t' = filter (/= n) t- in (isSortedOK compare t') && (asListL t' == ([0..n-1]++[n+1..s-1]))---- | Test the mapMaybeViaList function-testMapMaybeViaList :: IO ()-testMapMaybeViaList = do title "mapMaybeViaList"- exhaustiveTest test (take 6 allAVL)- where test _ s t = all testit [0..s] -- n==s should yield unmodified tree- where testit n = let t' = mapMaybeViaList (\m -> if m==n then Nothing else Just m) t- in (isSortedOK compare t') && (asListL t' == ([0..n-1]++[n+1..s-1]))---- | Test the mapMaybe function-testMapMaybe :: IO ()-testMapMaybe = do title "mapMaybe"- exhaustiveTest test (take 6 allAVL)- where test _ s t = all testit [0..s] -- n==s should yield unmodified tree- where testit n = let t' = mapMaybe (\m -> if m==n then Nothing else Just m) t- in (isSortedOK compare t') && (asListL t' == ([0..n-1]++[n+1..s-1]))---- | Test splitAtL function-testSplitAtL :: IO ()-testSplitAtL = do title "splitAtL"- exhaustiveTest test (take 6 allAVL)- where test _ s t = all splitTest0 [0..s-1] && all splitTest1 [s]- where tlist = asListL t- splitTest0 n = case splitAtL n t of- Left _ -> False- Right (l,r) -> (isBalanced l) && (isBalanced r) &&- (size l == n) && (size r == s-n) &&- (l `toListL` asListL r) == tlist- splitTest1 n = case splitAtL n t of- Left s_ -> s_==s- Right _ -> False---- | Test takeL function-testTakeL :: IO ()-testTakeL = do title "takeL"- exhaustiveTest test (take 6 allAVL)- where test _ s t = all takeTest0 [0..s-1] && all takeTest1 [s]- where takeTest0 n = case takeL n t of- Left _ -> False- Right l -> (isBalanced l) && (asListL l) == [0..n-1]- takeTest1 n = case takeL n t of- Left s_ -> s_==s- Right _ -> False---- | Test dropL function-testDropL :: IO ()-testDropL = do title "dropL"- exhaustiveTest test (take 6 allAVL)- where test _ s t = all dropTest0 [0..s-1] && all dropTest1 [s]- where dropTest0 n = case dropL n t of- Left _ -> False- Right r -> (isBalanced r) && (asListL r) == [n..s-1]- dropTest1 n = case dropL n t of- Left s_ -> s_==s- Right _ -> False---- | Test splitAtR function-testSplitAtR :: IO ()-testSplitAtR = do title "splitAtR"- exhaustiveTest test (take 6 allAVL)- where test _ s t = all splitTest0 [0..s-1] && all splitTest1 [s]- where tlist = asListR t- splitTest0 n = case splitAtR n t of- Left _ -> False- Right (l,r) -> (isBalanced l) && (isBalanced r) &&- (size r == n) && (size l == s-n) &&- (r `toListR` asListR l) == tlist- splitTest1 n = case splitAtR n t of- Left s_ -> s_==s- Right _ -> False---- | Test takeR function-testTakeR :: IO ()-testTakeR = do title "takeR"- exhaustiveTest test (take 6 allAVL)- where test _ s t = all takeTest0 [0..s-1] && all takeTest1 [s]- where takeTest0 n = case takeR n t of- Left _ -> False- Right r -> (isBalanced r) && (asListL r) == [s-n..s-1]- takeTest1 n = case takeR n t of- Left s_ -> s_==s- Right _ -> False---- | Test dropR function-testDropR :: IO ()-testDropR = do title "dropR"- exhaustiveTest test (take 6 allAVL)- where test _ s t = all dropTest0 [0..s-1] && all dropTest1 [s]- where dropTest0 n = case dropR n t of- Left _ -> False- Right l -> (isBalanced l) && (asListL l) == [0..(s-1)-n]- dropTest1 n = case dropR n t of- Left s_ -> s_==s- Right _ -> False---- | Test spanL function-testSpanL :: IO ()-testSpanL = do title "spanL"- exhaustiveTest test (take 6 allAVL)- where test _ s t = all spanTest [0..s]- where tlist = asListL t- spanTest n = let (l ,r ) = spanL (<n) t- (l_,r_) = span (<n) tlist- in (isBalanced l) && (isBalanced r) &&- (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 ()-passed = putStrLn "Passed"--failed :: IO ()-failed = do putStrLn "!! FAILED !!"- exitFailure----- List union (of ascending Ints)-listUnion :: [Int] -> [Int] -> [Int]-listUnion [] ys = ys-listUnion xs [] = xs-listUnion xs@(x:xs') ys@(y:ys') = case compare x y of- LT -> x:(listUnion xs' ys )- EQ -> x:(listUnion xs' ys') -- Eliminate duplicates- GT -> y:(listUnion xs ys')---- List intersection (of ascending Ints)-listIntersection :: [Int] -> [Int] -> [Int]-listIntersection [] _ = []-listIntersection _ [] = []-listIntersection xs@(x:xs') ys@(y:ys') = case compare x y of- LT -> listIntersection xs' ys- EQ -> x:(listIntersection xs' ys')- GT -> listIntersection xs ys'---- List intersection maybe (of ascending Ints)-listIntersectionMaybe :: (Int -> Int -> COrdering (Maybe Int)) -> [Int] -> [Int] -> [Int]-listIntersectionMaybe _ [] _ = []-listIntersectionMaybe _ _ [] = []-listIntersectionMaybe cmp xs@(x:xs') ys@(y:ys') = case cmp x y of- Lt -> listIntersectionMaybe cmp xs' ys- Eq (Just i) -> i:(listIntersectionMaybe cmp xs' ys')- Eq Nothing -> listIntersectionMaybe cmp xs' ys'- Gt -> listIntersectionMaybe cmp xs ys'---- List Difference (of ascending Ints)-listDiff :: [Int] -> [Int] -> [Int]-listDiff [] _ = []-listDiff xs [] = xs-listDiff xs@(x:xs') ys@(y:ys') = case compare x y of- LT -> x:(listDiff xs' ys)- EQ -> listDiff xs' ys'- GT -> listDiff xs ys'-
− Data/Tree/AVL/Test/Counter.hs
@@ -1,49 +0,0 @@--------------------------------------------------------------------------------- |--- Module : Data.Tree.AVL.Test.Counter--- Copyright : (c) Adrian Hey 2004,2005--- License : BSD3------ Maintainer : http://homepages.nildram.co.uk/~ahey/em.png--- Stability : stable--- Portability : portable------ This module defines the 'XInt' type which is a specialised instance of 'Ord' which allows--- the number of comparisons performed to be counted. This may be used evaluate various--- algorithms. The functions defined here are not exported by the main "Data.Tree.AVL"--- module. You need to import this module explicitly if you want to use any of them.-------------------------------------------------------------------------------module Data.Tree.AVL.Test.Counter- (XInt(..),- getCount,resetCount,- ) where--import System.IO.Unsafe(unsafePerformIO)-import Data.IORef(IORef,newIORef,readIORef,writeIORef)--{-# NOINLINE count #-}-count :: IORef Int-count = unsafePerformIO $ newIORef 0---- Increment the counter.-incCount :: IO ()-incCount = do c <- readIORef count- let c' = c+1 in c' `seq` writeIORef count c'---- | Read the current comparison counter.-getCount :: IO Int-getCount = readIORef count---- | Reset the comparison counter to zero.-resetCount :: IO ()-resetCount = writeIORef count 0---- | Basic data type.-newtype XInt = XInt Int deriving (Eq,Show,Read)---- | A side effecting instance of Ord.-instance Ord XInt where- compare (XInt x) (XInt y) = unsafePerformIO $ do incCount- return $! compare x y--
− Data/Tree/AVL/Test/Utils.hs
@@ -1,221 +0,0 @@-{-# OPTIONS_GHC -fglasgow-exts #-}--------------------------------------------------------------------------------- |--- Module : Data.Tree.AVL.Test.Utils--- Copyright : (c) Adrian Hey 2004,2005--- License : BSD3------ Maintainer : http://homepages.nildram.co.uk/~ahey/em.png--- Stability : stable--- Portability : portable------ 'AVL' tree related test and verification utilities.-------------------------------------------------------------------------------module Data.Tree.AVL.Test.Utils- (-- * Correctness checking.- isBalanced,checkHeight,isSorted,isSortedOK,- -- * Test data generation.- TestTrees,allAVL, allNonEmptyAVL, numTrees, flatAVL,- -- * Exhaustive tests.- exhaustiveTest,- -- * Tree parameter utilities.- minElements,maxElements,- -- * Testing BinPath module.- pathTree,- ) where--import Data.Tree.AVL.Types(AVL(..))-import Data.Tree.AVL.List(map',asTreeLenL,asListL)--#ifdef __GLASGOW_HASKELL__-import GHC.Base-#include "ghcdefs.h"-#else-#include "h98defs.h"-#endif---- | Infinite test tree. Used for test purposes for BinPath module.--- Value at each node is the path to that node.-pathTree :: AVL Int-pathTree = Z l 0 r where- l = mapIt (\n -> 2*n+1) pathTree- r = mapIt (\n -> 2*n+2) pathTree- -- Need special lazy map for this recursive tree defn- mapIt f (Z l' n r') = let n'= f n in n' `seq` Z (mapIt f l') n' (mapIt f r')- mapIt _ _ = undefined---- | Verify that a tree is height balanced and that the BF of each node is correct.------ Complexity: O(n)-isBalanced :: AVL e -> Bool-isBalanced t = not (cH t EQL L(-1))---- | Verify that a tree is balanced and the BF of each node is correct.--- Returns (Just height) if so, otherwise Nothing.------ Complexity: O(n)-checkHeight :: AVL e -> Maybe Int-checkHeight t = let ht = cH t in if ht EQL L(-1) then Nothing else Just ASINT(ht)---- Local utility, returns height if balanced, -1 if not-cH :: AVL e -> UINT-cH E = L(0)-cH (N l _ r) = cH_ L(1) l r -- (hr-hl) = 1-cH (Z l _ r) = cH_ L(0) l r -- (hr-hl) = 0-cH (P l _ r) = cH_ L(1) r l -- (hl-hr) = 1-cH_ :: UINT -> AVL e -> AVL e -> UINT-cH_ delta l r = let hl = cH l- in if hl EQL L(-1) then hl- else let hr = cH r- in if hr EQL L(-1) then hr- else if SUBINT(hr,hl) EQL delta then INCINT1(hr)- else L(-1)---- | Verify that a tree is sorted.------ Complexity: O(n)-isSorted :: (e -> e -> Ordering) -> AVL e -> Bool-isSorted c = isSorted' where- isSorted' E = True- isSorted' (N l e r) = isSorted'' l e r- isSorted' (Z l e r) = isSorted'' l e r- isSorted' (P l e r) = isSorted'' l e r- isSorted'' l e r = (isSortedU l e) && (isSortedL e r)- -- Verify tree is sorted and rightmost element is less than an upper limit (ul)- isSortedU E _ = True- isSortedU (N l e r) ul = isSortedU' l e r ul- isSortedU (Z l e r) ul = isSortedU' l e r ul- isSortedU (P l e r) ul = isSortedU' l e r ul- isSortedU' l e r ul = case c e ul of- LT -> (isSortedU l e) && (isSortedLU e r ul)- _ -> False- -- Verify tree is sorted and leftmost element is greater than a lower limit (ll)- isSortedL _ E = True- isSortedL ll (N l e r) = isSortedL' ll l e r- isSortedL ll (Z l e r) = isSortedL' ll l e r- isSortedL ll (P l e r) = isSortedL' ll l e r- isSortedL' ll l e r = case c e ll of- GT -> (isSortedLU ll l e) && (isSortedL e r)- _ -> False- -- Verify tree is sorted and leftmost element is greater than a lower limit (ll)- -- and rightmost element is less than an upper limit (ul)- isSortedLU _ E _ = True- isSortedLU ll (N l e r) ul = isSortedLU' ll l e r ul- isSortedLU ll (Z l e r) ul = isSortedLU' ll l e r ul- isSortedLU ll (P l e r) ul = isSortedLU' ll l e r ul- isSortedLU' ll l e r ul = case c e ll of- GT -> case c e ul of- LT -> (isSortedLU ll l e) && (isSortedLU e r ul)- _ -> False- _ -> False--- isSorted ends -------------------------- | Verify that a tree is sorted, height balanced and the BF of each node is correct.------ Complexity: O(n)-isSortedOK :: (e -> e -> Ordering) -> AVL e -> Bool-isSortedOK c t = (isBalanced t) && (isSorted c t)---- | AVL Tree test data. Each element of a the list is a pair consisting of a height,--- and list of all possible sorted trees of the same height, paired with their sizes.--- The elements of each tree of size s are 0..s-1.-type TestTrees = [(Int, [(AVL Int, Int)])]---- | All possible sorted AVL trees.-allAVL :: TestTrees-allAVL = p0 : p1 : moreTrees p1 p0 where- p0 = (0, [(E , 0)]) -- All possible trees of height 0- p1 = (1, [(Z E 0 E, 1)]) -- All possible trees of height 1- -- Generate more trees of height N, from existing trees of height N-1 and N-2- moreTrees :: (Int, [(AVL Int, Int)]) -> (Int, [(AVL Int, Int)]) -> [(Int, [(AVL Int, Int)])]- moreTrees pN1@(hN1, tpsN1) -- Height N-1- (_ , tpsN2) = -- Height N-2- let hN0 = hN1 + 1 -- Height N- tsN0 = interleave (interleave [newTree P l r | r <- tpsN2 , l <- tpsN1] -- BF=+1- [newTree N l r | l <- tpsN2 , r <- tpsN1]) -- BF=-1- [newTree Z l r | l <- tpsN1 , r <- tpsN1] -- BF= 0- pN0 = (hN0,tsN0)- in hN0 `seq` pN0 : moreTrees pN0 pN1- -- Generate a new (tree,size) pair using the supplied constructor- newTree con (l,sizel) (r,sizer) =- let rootEl = sizel -- Value of new root element- addRight = sizel+1 -- Offset to add to elements of right sub-tree- newSize = addRight + sizer -- Size of the new tree- r' = map' (addRight+) r- t = r' `seq` con l rootEl r'- in newSize `seq` t `seq` (t, newSize)- -- interleave two lists (until one or other is [])- interleave [] ys = ys- interleave xs [] = xs- interleave (x:xs) (y:ys) = (x:y:interleave xs ys)----- | Same as 'allAVL', but excluding the empty tree (of height 0).-allNonEmptyAVL :: TestTrees-allNonEmptyAVL = tail allAVL---- | Returns the number of possible AVL trees of a given height.------ Behaves as if defined..------ > numTrees h = (\(_,xs) -> length xs) (allAVL !! h)------ and satisfies this recurrence relation..------ @--- numTrees 0 = 1--- numTrees 1 = 1--- numTrees h = (2*(numTrees (h-2)) + (numTrees (h-1))) * (numTrees (h-1))--- @-numTrees :: Int -> Integer-numTrees 0 = 1-numTrees 1 = 1-numTrees n = numTrees' 1 1 n where- numTrees' n1 n2 2 = (2*n2 + n1)*n1- numTrees' n1 n2 m = numTrees' ((2*n2 + n1)*n1) n1 (m-1)---- | Apply the test function to each AVL tree in the TestTrees argument, and report--- progress as test proceeds. The first two arguments of the test function are--- tree height and size respectively.-exhaustiveTest :: (Int -> Int -> AVL Int -> Bool) -> TestTrees -> IO ()-exhaustiveTest f xs = mapM_ test xs where- test (h,tps) = do putStr "Tree Height : " >> print h- putStr "Number Of Trees: " >> print (numTrees h)- mapM_ test' tps- putStrLn "Done."- where test' (t,s) = if f h s t then return () -- putStr "."- else error $ show $ asListL t -- Temporary Hack---- | Generates a flat AVL tree of n elements [0..n-1].-flatAVL :: Int -> AVL Int-flatAVL n = asTreeLenL n [0..n-1]---- | Detetermine the minimum number of elements in an AVL tree of given height.--- This function satisfies this recurrence relation..------ @--- minElements 0 = 0--- minElements 1 = 1--- minElements h = 1 + minElements (h-1) + minElements (h-2)--- -- = Some weird expression involving the golden ratio--- @-minElements :: Int -> Integer-minElements 0 = 0-minElements 1 = 1-minElements h = minElements' 0 1 h where- minElements' n1 n2 2 = 1 + n1 + n2- minElements' n1 n2 m = minElements' n2 (1 + n1 + n2) (m-1)---- | Detetermine the maximum number of elements in an AVL tree of given height.--- This function satisfies this recurrence relation..------ @--- maxElements 0 = 0--- maxElements h = 1 + 2 * maxElements (h-1) -- = 2^h-1--- @-maxElements :: Int -> Integer-maxElements 0 = 0-maxElements h = maxElements' 0 h where- maxElements' n1 1 = 1 + 2*n1- maxElements' n1 m = maxElements' (1 + 2*n1) (m-1)
− Data/Tree/AVL/Types.hs
@@ -1,162 +0,0 @@-{-# OPTIONS_GHC -fglasgow-exts #-}--------------------------------------------------------------------------------- |--- Module : Data.Tree.AVL.Types--- Copyright : (c) Adrian Hey 2004,2005--- License : BSD3------ Maintainer : http://homepages.nildram.co.uk/~ahey/em.png--- Stability : stable--- Portability : portable------ AVL Tree data type definition and a few simple utility functions.-------------------------------------------------------------------------------module Data.Tree.AVL.Types- ( -- * Types.- AVL(..),-- -- * Simple AVL related utilities.- empty,isEmpty,isNonEmpty,singleton,pair,tryGetSingleton,-- ) where--import Prelude -- so haddock finds the symbols there--import Data.Typeable-#if __GLASGOW_HASKELL__ > 604-import Data.Foldable-import Data.Monoid-#endif---- | AVL tree data type.------ The balance factor (BF) of an 'AVL' tree node is defined as the difference between the height of--- the left and right sub-trees. An 'AVL' tree is ALWAYS height balanced, such that |BF| <= 1.--- The functions in this library ("Data.Tree.AVL") are designed so that they never construct--- an unbalanced tree (well that's assuming they're not broken). The 'AVL' tree type defined here--- has the BF encoded the constructors.------ Some functions in this library return 'AVL' trees that are also \"flat\", which (in the context--- of this library) means that the sizes of left and right sub-trees differ by at most one and--- are also flat. Flat sorted trees should give slightly shorter searches than sorted trees which--- are merely height balanced. Whether or not flattening is worth the effort depends on the number--- of times the tree will be searched and the cost of element comparison.------ In cases where the tree elements are sorted, all the relevant 'AVL' functions follow the--- convention that the leftmost tree element is least and the rightmost tree element is--- the greatest. Bear this in mind when defining general comparison functions. It should--- also be noted that all functions in this library for sorted trees require that the tree--- does not contain multiple elements which are \"equal\" (according to whatever criterion--- has been used to sort the elements).------ It is important to be consistent about argument ordering when defining general purpose--- comparison functions (or selectors) for searching a sorted tree, such as ..------ @--- myComp :: (k -> e -> Ordering)--- -- or..--- myCComp :: (k -> e -> COrdering a)--- @------ In these cases the first argument is the search key and the second argument is an element of--- the 'AVL' tree. For example..------ @--- key \`myCComp\` element -> Lt implies key < element, proceed down the left sub-tree--- key \`myCComp\` element -> Gt implies key > element, proceed down the right sub-tree--- @------ This convention is same as that used by the overloaded 'compare' method from 'Ord' class.------ Controlling Strictness.------ The 'AVL' tree data type is declared as non-strict in all it's fields,--- but all the functions in this library behave as though it is strict in its--- recursive fields (left and right sub-trees). Strictness in the element field is--- controlled either by using the strict variants of functions (defined in this library--- where appropriate), or using strict variants of the combinators defined in "Data.COrdering",--- or using 'seq' etc. in your own code (in any combining comparisons you define, for example).------ The 'Eq' and 'Ord' instances.------ Begining with version 3.0 these are now derived, and hence are defined in terms of--- strict structural equality, rather than observational equivalence. The reason for--- this change is that the observational equivalence abstraction was technically breakable--- with the exposed API. But since this change, some functions which were previously--- considered unsafe have become safe to expose (those that measure tree height, for example).------ The 'Read' and 'Show' instances.------ Begining with version 4.0 these are now derived to ensure consistency with 'Eq' instance.--- (Show now reveals the exact tree structure).-----data AVL e = E -- ^ Empty Tree- | N (AVL e) e (AVL e) -- ^ BF=-1 (right height > left height)- | Z (AVL e) e (AVL e) -- ^ BF= 0- | P (AVL e) e (AVL e) -- ^ BF=+1 (left height > right height)- deriving(Eq,Ord,Show,Read)---- A name for the AVL type constructor, fully qualified-avlTyConName :: String-avlTyConName = "Data.Tree.AVL.AVL"---- A Typeable1 instance-instance Typeable1 AVL where- typeOf1 _ = mkTyConApp (mkTyCon avlTyConName) []--#ifndef __GLASGOW_HASKELL__--- A Typeable instance (not needed by ghc, but Haddock fails to document this instance)-instance Typeable e => Typeable (AVL e) where- typeOf = typeOfDefault-#endif--#if __GLASGOW_HASKELL__ > 604-instance Foldable AVL where- foldMap _f E = mempty- foldMap f (N l v r) = foldMap f l `mappend` f v `mappend` foldMap f r- foldMap f (Z l v r) = foldMap f l `mappend` f v `mappend` foldMap f r- foldMap f (P l v r) = foldMap f l `mappend` f v `mappend` foldMap f r-#endif---- | The empty AVL tree.-{-# INLINE empty #-}-empty :: AVL e-empty = E---- | Returns 'True' if an AVL tree is empty.------ Complexity: O(1)-isEmpty :: AVL e -> Bool-isEmpty E = True-isEmpty _ = False-{-# INLINE isEmpty #-}---- | Returns 'True' if an AVL tree is non-empty.------ Complexity: O(1)-isNonEmpty :: AVL e -> Bool-isNonEmpty E = False-isNonEmpty _ = True-{-# INLINE isNonEmpty #-}---- | Creates an AVL tree with just one element.------ Complexity: O(1)-singleton :: e -> AVL e-singleton e = Z E e E-{-# INLINE singleton #-}---- | Create an AVL tree of two elements, occuring in same order as the arguments.-pair :: e -> e -> AVL e-pair e0 e1 = P (Z E e0 E) e1 E-{-# INLINE pair #-}---- | If the AVL tree is a singleton (has only one element @e@) then this function returns @('Just' e)@.--- Otherwise it returns Nothing.------ Complexity: O(1)-tryGetSingleton :: AVL e -> Maybe e-tryGetSingleton (Z E e _) = Just e -- Right subtree must be E too, but no need to waste time checking-tryGetSingleton _ = Nothing-{-# INLINE tryGetSingleton #-}
− Data/Tree/AVL/Write.hs
@@ -1,197 +0,0 @@--------------------------------------------------------------------------------- |--- Module : Data.Tree.AVL.Write--- Copyright : (c) Adrian Hey 2004,2005--- License : BSD3------ Maintainer : http://homepages.nildram.co.uk/~ahey/em.png--- Stability : stable--- Portability : portable-------------------------------------------------------------------------------module Data.Tree.AVL.Write-(-- * Writing to AVL trees- -- | These functions alter the content of a tree (values of tree elements) but not the structure- -- of a tree.-- -- ** Writing to extreme left or right- -- | I'm not sure these are likely to be much use in practice, but they're- -- simple enough to implement so are included for the sake of completeness.- writeL,tryWriteL,writeR,tryWriteR,-- -- ** Writing to /sorted/ trees- write,writeFast,tryWrite,writeMaybe,tryWriteMaybe-) where--import Prelude -- so haddock finds the symbols there--import Data.COrdering-import Data.Tree.AVL.Types(AVL(..))-import Data.Tree.AVL.BinPath(BinPath(..),openPathWith,writePath)-------------------------------------------------------------------------------- writeL, tryWriteL --------------------------------------------------------------------------------- | Replace the left most element of a tree with the supplied new element.--- This function raises an error if applied to an empty tree.------ Complexity: O(log n)-writeL :: e -> AVL e -> AVL e-writeL _ E = error "writeL: Empty Tree"-writeL e' (N l e r) = writeLN e' l e r-writeL e' (Z l e r) = writeLZ e' l e r-writeL e' (P l e r) = writeLP e' l e r---- | Similar to 'writeL', but returns 'Nothing' if applied to an empty tree.------ Complexity: O(log n)-tryWriteL :: e -> AVL e -> Maybe (AVL e)-tryWriteL _ E = Nothing-tryWriteL e' (N l e r) = Just $! writeLN e' l e r-tryWriteL e' (Z l e r) = Just $! writeLZ e' l e r-tryWriteL e' (P l e r) = Just $! writeLP e' l e r---- This version of writeL is for trees which are known to be non-empty.-writeL' :: e -> AVL e -> AVL e-writeL' _ E = error "writeL': Bug0"-writeL' e' (N l e r) = writeLN e' l e r -- l may be empty-writeL' e' (Z l e r) = writeLZ e' l e r -- l may be empty-writeL' e' (P l e r) = writeLP e' l e r -- l can't be empty---- Write to left sub-tree of N l e r, or here if l is empty-writeLN :: e -> AVL e -> e -> AVL e -> AVL e-writeLN e' E _ r = N E e' r-writeLN e' (N ll le lr) e r = let l' = writeLN e' ll le lr in l' `seq` N l' e r-writeLN e' (Z ll le lr) e r = let l' = writeLZ e' ll le lr in l' `seq` N l' e r-writeLN e' (P ll le lr) e r = let l' = writeLP e' ll le lr in l' `seq` N l' e r---- Write to left sub-tree of Z l e r, or here if l is empty-writeLZ :: e -> AVL e -> e -> AVL e -> AVL e-writeLZ e' E _ r = Z E e' r -- r must be E too!-writeLZ e' (N ll le lr) e r = let l' = writeLN e' ll le lr in l' `seq` Z l' e r-writeLZ e' (Z ll le lr) e r = let l' = writeLZ e' ll le lr in l' `seq` Z l' e r-writeLZ e' (P ll le lr) e r = let l' = writeLP e' ll le lr in l' `seq` Z l' e r---- Write to left sub-tree of P l e r (l can't be empty)-{-# INLINE writeLP #-}-writeLP :: e -> AVL e -> e -> AVL e -> AVL e-writeLP e' l e r = let l' = writeL' e' l in l' `seq` P l' e r------------------------------------------------------------------------------- writeL, tryWriteL end here --------------------------------------------------------------------------------------------------------------------------------------------------------------- writeR, tryWriteR --------------------------------------------------------------------------------- | Replace the right most element of a tree with the supplied new element.--- This function raises an error if applied to an empty tree.------ Complexity: O(log n)-writeR :: AVL e -> e -> AVL e-writeR E _ = error "writeR: Empty Tree"-writeR (N l e r) e' = writeRN l e r e'-writeR (Z l e r) e' = writeRZ l e r e'-writeR (P l e r) e' = writeRP l e r e'---- | Similar to 'writeR', but returns 'Nothing' if applied to an empty tree.------ Complexity: O(log n)-tryWriteR :: AVL e -> e -> Maybe (AVL e)-tryWriteR E _ = Nothing-tryWriteR (N l e r) e' = Just $! writeRN l e r e'-tryWriteR (Z l e r) e' = Just $! writeRZ l e r e'-tryWriteR (P l e r) e' = Just $! writeRP l e r e'---- This version of writeR is for trees which are known to be non-empty.-writeR' :: AVL e -> e -> AVL e-writeR' E _ = error "writeR': Bug0"-writeR' (N l e r) e' = writeRN l e r e' -- r can't be empty-writeR' (Z l e r) e' = writeRZ l e r e' -- r may be empty-writeR' (P l e r) e' = writeRP l e r e' -- r may be empty---- Write to right sub-tree of N l e r (r can't be empty)-{-# INLINE writeRN #-}-writeRN :: AVL e -> e -> AVL e -> e -> AVL e-writeRN l e r e' = let r' = writeR' r e' in r' `seq` N l e r'---- Write to right sub-tree of Z l e r, or here if r is empty-writeRZ :: AVL e -> e -> AVL e -> e -> AVL e-writeRZ l _ E e' = Z l e' E -- l must be E too!-writeRZ l e (N rl re rr) e' = let r' = writeRN rl re rr e' in r' `seq` Z l e r'-writeRZ l e (Z rl re rr) e' = let r' = writeRZ rl re rr e' in r' `seq` Z l e r'-writeRZ l e (P rl re rr) e' = let r' = writeRP rl re rr e' in r' `seq` Z l e r'---- Write to right sub-tree of P l e r, or here if r is empty-writeRP :: AVL e -> e -> AVL e -> e -> AVL e-writeRP l _ E e' = P l e' E-writeRP l e (N rl re rr) e' = let r' = writeRN rl re rr e' in r' `seq` P l e r'-writeRP l e (Z rl re rr) e' = let r' = writeRZ rl re rr e' in r' `seq` P l e r'-writeRP l e (P rl re rr) e' = let r' = writeRP rl re rr e' in r' `seq` P l e r'------------------------------------------------------------------------------- writeR, tryWriteR end here ----------------------------------------------------------------------------------- | A general purpose function to perform a search of a tree, using the supplied selector.--- If the search succeeds the found element is replaced by the value (@e@) of the @('Eq' e)@--- constructor returned by the selector. If the search fails this function returns the original tree.------ Complexity: O(log n)-write :: (e -> COrdering e) -> AVL e -> AVL e-write c t = case openPathWith c t of- FullBP pth e -> writePath pth e t- _ -> t---- | Functionally identical to 'write', but returns an identical tree (one with all the nodes on--- the path duplicated) if the search fails. This should probably only be used if you know the--- search will succeed and will return an element which is different from that already present.------ Complexity: O(log n)-writeFast :: (e -> COrdering e) -> AVL e -> AVL e-writeFast c = w where- w E = E- w (N l e r) = case c e of- Lt -> let l' = w l in l' `seq` N l' e r- Eq v -> N l v r- Gt -> let r' = w r in r' `seq` N l e r'- w (Z l e r) = case c e of- Lt -> let l' = w l in l' `seq` Z l' e r- Eq v -> Z l v r- Gt -> let r' = w r in r' `seq` Z l e r'- w (P l e r) = case c e of- Lt -> let l' = w l in l' `seq` P l' e r- Eq v -> P l v r- Gt -> let r' = w r in r' `seq` P l e r'---- | A general purpose function to perform a search of a tree, using the supplied selector.--- The found element is replaced by the value (@e@) of the @('Eq' e)@ constructor returned by--- the selector. This function returns 'Nothing' if the search failed.------ Complexity: O(log n)-tryWrite :: (e -> COrdering e) -> AVL e -> Maybe (AVL e)-tryWrite c t = case openPathWith c t of- FullBP pth e -> Just $! writePath pth e t- _ -> Nothing---- | Similar to 'write', but also returns the original tree if the search succeeds but--- the selector returns @('Eq' 'Nothing')@. (This version is intended to help reduce heap burn--- rate if it\'s likely that no modification of the value is needed.)------ Complexity: O(log n)-writeMaybe :: (e -> COrdering (Maybe e)) -> AVL e -> AVL e-writeMaybe c t = case openPathWith c t of- FullBP pth (Just e) -> writePath pth e t- _ -> t---- | Similar to 'tryWrite', but also returns the original tree if the search succeeds but--- the selector returns @('Eq' 'Nothing')@. (This version is intended to help reduce heap burn--- rate if it\'s likely that no modification of the value is needed.)------ Complexity: O(log n)-tryWriteMaybe :: (e -> COrdering (Maybe e)) -> AVL e -> Maybe (AVL e)-tryWriteMaybe c t = case openPathWith c t of- FullBP pth (Just e) -> Just $! writePath pth e t- FullBP _ Nothing -> Just t- _ -> Nothing--
− Data/Tree/AVL/Zipper.hs
@@ -1,903 +0,0 @@-{-# OPTIONS_GHC -fglasgow-exts #-}--------------------------------------------------------------------------------- |--- Module : Data.Tree.AVL.Zipper--- Copyright : (c) Adrian Hey 2004,2005--- License : BSD3------ Maintainer : http://homepages.nildram.co.uk/~ahey/em.png--- Stability : stable--- Portability : portable----------------------------------------------------------------------------------module Data.Tree.AVL.Zipper-(-- * The AVL Zipper- -- | An implementation of \"The Zipper\" for AVL trees. This can be used like- -- a functional pointer to a serial data structure which can be navigated- -- and modified, without having to worry about all those tricky tree balancing- -- issues. See JFP Vol.7 part 5 or ..- --- -- <http://haskell.org/haskellwiki/Zipper>- --- -- Notes about efficiency:- --- -- The functions defined here provide a useful way to achieve those awkward- -- operations which may not be covered by the rest of this package. They're- -- reasonably efficient (mostly O(log n) or better), but zipper flexibility- -- is bought at the expense of keeping path information explicitly as a heap- -- data structure rather than implicitly on the stack. Since heap storage- -- probably costs more, zipper operations will are likely to incur higher- -- constant factors than equivalent non-zipper operations (if available).- --- -- Some of the functions provided here may appear to be weird combinations of- -- functions from a more logical set of primitives. They are provided because- -- they are not really simple combinations of the corresponding primitives.- -- They are more efficient, so you should use them if possible (e.g combining- -- deleting with Zipper closing).- --- -- Also, consider using the 'BAVL' as a cheaper alternative if you don't- -- need to navigate the tree.-- -- ** Types- ZAVL,PAVL,-- -- ** Opening- assertOpenL,assertOpenR,- tryOpenL,tryOpenR,- assertOpen,tryOpen,- tryOpenGE,tryOpenLE,- openEither,-- -- ** Closing- close,fillClose,-- -- ** Manipulating the current element.- getCurrent,putCurrent,applyCurrent,applyCurrent',-- -- ** Moving- assertMoveL,assertMoveR,tryMoveL,tryMoveR,-- -- ** Inserting elements- insertL,insertR,insertMoveL,insertMoveR,fill,-- -- ** Deleting elements- delClose,- assertDelMoveL,assertDelMoveR,tryDelMoveR,tryDelMoveL,- delAllL,delAllR,- delAllCloseL,delAllCloseR,- delAllIncCloseL,delAllIncCloseR,-- -- ** Inserting AVL trees- insertTreeL,insertTreeR,-- -- ** Current element status- isLeftmost,isRightmost,- sizeL,sizeR,-- -- ** Operations on whole zippers- sizeZAVL,-- -- ** A cheaper option is to use BAVL- -- | These are a cheaper but more restrictive alternative to using the full Zipper.- -- They use \"Binary Paths\" (Ints) to point to a particular element of an 'AVL' tree.- -- Use these when you don't need to navigate the tree, you just want to look at a- -- particular element (and perhaps modify or delete it). The advantage of these is- -- that they don't create the usual Zipper heap structure, so they will be faster- -- (and reduce heap burn rate too).- --- -- If you subsequently decide you need a Zipper rather than a BAVL then some conversion- -- utilities are provided.-- -- *** Types- BAVL,-- -- *** Opening and closing- openBAVL,closeBAVL,-- -- *** Inspecting status- fullBAVL,emptyBAVL,tryReadBAVL,readFullBAVL,-- -- *** Modifying the tree- pushBAVL,deleteBAVL,-- -- *** Converting to BAVL to Zipper- -- | These are O(log n) operations but with low constant factors because no comparisons- -- are required (and the tree nodes on the path will most likely still be in cache as- -- a result of opening the BAVL in the first place).- fullBAVLtoZAVL,emptyBAVLtoPAVL,anyBAVLtoEither,-) where--import Prelude -- so haddock finds the symbols there--import Data.Tree.AVL.Types(AVL(..))-import Data.Tree.AVL.Size(size,addSize)-import Data.Tree.AVL.Height(height,addHeight)-import Data.Tree.AVL.Internals.DelUtils(deletePath,popRN,popRZ,popRP,popLN,popLZ,popLP)-import Data.Tree.AVL.Internals.HJoin(spliceH,joinH)-import Data.Tree.AVL.Internals.HPush(pushHL,pushHR)-import Data.Tree.AVL.BinPath(BinPath(..),openPath,writePath,insertPath,sel,goL,goR)--#ifdef __GLASGOW_HASKELL__-import GHC.Base-#include "ghcdefs.h"-#else-#include "h98defs.h"-#endif---- N.B. Zippers are always opened using relative heights for efficiency reasons. On the--- whole this causes no problems, except when inserting entire AVL trees or substituting--- the empty tree. (These cases have some minor height computation overhead).---- | Abstract data type for a successfully opened AVL tree. All ZAVL\'s are non-empty!--- A ZAVL can be tought of as a functional pointer to an AVL tree element.-data ZAVL e = ZAVL (Path e) (AVL e) !UINT e (AVL e) !UINT---- | Abstract data type for an unsuccessfully opened AVL tree.--- A PAVL can be thought of as a functional pointer to the gap--- where the expected element should be (but isn't). You can fill this gap using--- the 'fill' function, or fill and close at the same time using the 'fillClose' function.-data PAVL e = PAVL (Path e) !UINT--data Path e = EP -- Empty Path- | LP (Path e) e (AVL e) !UINT -- Left subtree was taken- | RP (Path e) e (AVL e) !UINT -- Right subtree was taken---- Local Closing Utility-close_ :: Path e -> AVL e -> UINT -> AVL e-close_ EP t _ = t-close_ (LP p e r hr) l hl = case spliceH l hl e r hr of UBT2(t,ht) -> close_ p t ht-close_ (RP p e l hl) r hr = case spliceH l hl e r hr of UBT2(t,ht) -> close_ p t ht---- Local Utility to remove all left paths from a path-noLP :: Path e -> Path e-noLP EP = EP-noLP (LP p _ _ _ ) = noLP p-noLP (RP p e l hl) = let p_ = noLP p in p_ `seq` RP p_ e l hl---- Local Utility to remove all right paths from a path-noRP :: Path e -> Path e-noRP EP = EP-noRP (LP p e r hr) = let p_ = noRP p in p_ `seq` LP p_ e r hr-noRP (RP p _ _ _ ) = noRP p---- Local Closing Utility which ignores all left paths-closeNoLP :: Path e -> AVL e -> UINT -> AVL e-closeNoLP EP t _ = t-closeNoLP (LP p _ _ _ ) l hl = closeNoLP p l hl-closeNoLP (RP p e l hl) r hr = case spliceH l hl e r hr of UBT2(t,ht) -> closeNoLP p t ht---- Local Closing Utility which ignores all right paths-closeNoRP :: Path e -> AVL e -> UINT -> AVL e-closeNoRP EP t _ = t-closeNoRP (LP p e r hr) l hl = case spliceH l hl e r hr of UBT2(t,ht) -> closeNoRP p t ht-closeNoRP (RP p _ _ _ ) r hr = closeNoRP p r hr---- Add size of all path elements.-addSizeP :: Int -> Path e -> Int-addSizeP n EP = n-addSizeP n (LP p _ r _) = addSizeP (addSize (n+1) r) p-addSizeP n (RP p _ l _) = addSizeP (addSize (n+1) l) p---- Add size of all RP path elements.-addSizeRP :: Int -> Path e -> Int-addSizeRP n EP = n-addSizeRP n (LP p _ _ _) = addSizeRP n p-addSizeRP n (RP p _ l _) = addSizeRP (addSize (n+1) l) p---- Add size of all LP path elements.-addSizeLP :: Int -> Path e -> Int-addSizeLP n EP = n-addSizeLP n (LP p _ r _) = addSizeLP (addSize (n+1) r) p-addSizeLP n (RP p _ _ _) = addSizeLP n p---- | Opens a sorted AVL tree at the element given by the supplied selector. This function--- raises an error if the tree does not contain such an element.------ Complexity: O(log n)-assertOpen :: (e -> Ordering) -> AVL e -> ZAVL e-assertOpen c t = op EP L(0) t where -- Relative heights !!- -- op :: (Path e) -> UINT -> AVL e -> ZAVL e- op _ _ E = error "assertOpen: No matching element."- op p h (N l e r) = case c e of- LT -> let p_ = LP p e r DECINT1(h) in p_ `seq` op p_ DECINT2(h) l- EQ -> ZAVL p l DECINT2(h) e r DECINT1(h)- GT -> let p_ = RP p e l DECINT2(h) in p_ `seq` op p_ DECINT1(h) r- op p h (Z l e r) = case c e of- LT -> let p_ = LP p e r DECINT1(h) in p_ `seq` op p_ DECINT1(h) l- EQ -> ZAVL p l DECINT1(h) e r DECINT1(h)- GT -> let p_ = RP p e l DECINT1(h) in p_ `seq` op p_ DECINT1(h) r- op p h (P l e r) = case c e of- LT -> let p_ = LP p e r DECINT2(h) in p_ `seq` op p_ DECINT1(h) l- EQ -> ZAVL p l DECINT1(h) e r DECINT2(h)- GT -> let p_ = RP p e l DECINT1(h) in p_ `seq` op p_ DECINT2(h) r---- | Attempts to open a sorted AVL tree at the element given by the supplied selector.--- This function returns 'Nothing' if there is no such element.------ Note that this operation will still create a zipper path structure on the heap (which--- is promptly discarded) if the search fails, and so is potentially inefficient if failure--- is likely. In cases like this it may be better to use 'openBAVL', test for \"fullness\"--- using 'fullBAVL' and then convert to a 'ZAVL' using 'fullBAVLtoZAVL'.------ Complexity: O(log n)-tryOpen :: (e -> Ordering) -> AVL e -> Maybe (ZAVL e)-tryOpen c t = op EP L(0) t where -- Relative heights !!- -- op :: (Path e) -> UINT -> AVL e -> Maybe (ZAVL e)- op _ _ E = Nothing- op p h (N l e r) = case c e of- LT -> let p_ = LP p e r DECINT1(h) in p_ `seq` op p_ DECINT2(h) l- EQ -> Just $! ZAVL p l DECINT2(h) e r DECINT1(h)- GT -> let p_ = RP p e l DECINT2(h) in p_ `seq` op p_ DECINT1(h) r- op p h (Z l e r) = case c e of- LT -> let p_ = LP p e r DECINT1(h) in p_ `seq` op p_ DECINT1(h) l- EQ -> Just $! ZAVL p l DECINT1(h) e r DECINT1(h)- GT -> let p_ = RP p e l DECINT1(h) in p_ `seq` op p_ DECINT1(h) r- op p h (P l e r) = case c e of- LT -> let p_ = LP p e r DECINT2(h) in p_ `seq` op p_ DECINT1(h) l- EQ -> Just $! ZAVL p l DECINT1(h) e r DECINT2(h)- GT -> let p_ = RP p e l DECINT1(h) in p_ `seq` op p_ DECINT2(h) r---- | Attempts to open a sorted AVL tree at the least element which is greater than or equal, according to--- the supplied selector. This function returns 'Nothing' if the tree does not contain such an element.------ Complexity: O(log n)-tryOpenGE :: (e -> Ordering) -> AVL e -> Maybe (ZAVL e)-tryOpenGE c t = op EP L(0) t where -- Relative heights !!- -- op :: (Path e) -> UINT -> AVL e -> ZAVL e- op p h E = backupR p E h where- backupR EP _ _ = Nothing- backupR (LP p_ e r hr) l hl = Just $! ZAVL p_ l hl e r hr- backupR (RP p_ e l hl) r hr = case spliceH l hl e r hr of UBT2(t_,ht_) -> backupR p_ t_ ht_- op p h (N l e r) = case c e of- LT -> let p_ = LP p e r DECINT1(h) in p_ `seq` op p_ DECINT2(h) l- EQ -> Just $! ZAVL p l DECINT2(h) e r DECINT1(h)- GT -> let p_ = RP p e l DECINT2(h) in p_ `seq` op p_ DECINT1(h) r- op p h (Z l e r) = case c e of- LT -> let p_ = LP p e r DECINT1(h) in p_ `seq` op p_ DECINT1(h) l- EQ -> Just $! ZAVL p l DECINT1(h) e r DECINT1(h)- GT -> let p_ = RP p e l DECINT1(h) in p_ `seq` op p_ DECINT1(h) r- op p h (P l e r) = case c e of- LT -> let p_ = LP p e r DECINT2(h) in p_ `seq` op p_ DECINT1(h) l- EQ -> Just $! ZAVL p l DECINT1(h) e r DECINT2(h)- GT -> let p_ = RP p e l DECINT1(h) in p_ `seq` op p_ DECINT2(h) r---- | Attempts to open a sorted AVL tree at the greatest element which is less than or equal, according to--- the supplied selector. This function returns _Nothing_ if the tree does not contain such an element.------ Complexity: O(log n)-tryOpenLE :: (e -> Ordering) -> AVL e -> Maybe (ZAVL e)-tryOpenLE c t = op EP L(0) t where -- Relative heights !!- -- op :: (Path e) -> UINT -> AVL e -> ZAVL e- op p h E = backupL p E h where- backupL EP _ _ = Nothing- backupL (LP p_ e r hr) l hl = case spliceH l hl e r hr of UBT2(t_,ht_) -> backupL p_ t_ ht_- backupL (RP p_ e l hl) r hr = Just $! ZAVL p_ l hl e r hr- op p h (N l e r) = case c e of- LT -> let p_ = LP p e r DECINT1(h) in p_ `seq` op p_ DECINT2(h) l- EQ -> Just $! ZAVL p l DECINT2(h) e r DECINT1(h)- GT -> let p_ = RP p e l DECINT2(h) in p_ `seq` op p_ DECINT1(h) r- op p h (Z l e r) = case c e of- LT -> let p_ = LP p e r DECINT1(h) in p_ `seq` op p_ DECINT1(h) l- EQ -> Just $! ZAVL p l DECINT1(h) e r DECINT1(h)- GT -> let p_ = RP p e l DECINT1(h) in p_ `seq` op p_ DECINT1(h) r- op p h (P l e r) = case c e of- LT -> let p_ = LP p e r DECINT2(h) in p_ `seq` op p_ DECINT1(h) l- EQ -> Just $! ZAVL p l DECINT1(h) e r DECINT2(h)- GT -> let p_ = RP p e l DECINT1(h) in p_ `seq` op p_ DECINT2(h) r---- | Opens a non-empty AVL tree at the leftmost element.--- This function raises an error if the tree is empty.------ Complexity: O(log n)-assertOpenL :: AVL e -> ZAVL e-assertOpenL E = error "assertOpenL: Empty tree."-assertOpenL (N l e r) = openLN EP L(0) l e r -- Relative heights !!-assertOpenL (Z l e r) = openLZ EP L(0) l e r -- Relative heights !!-assertOpenL (P l e r) = openL_ (LP EP e r L(0)) L(1) l -- Relative heights !!---- | Attempts to open a non-empty AVL tree at the leftmost element.--- This function returns 'Nothing' if the tree is empty.------ Complexity: O(log n)-tryOpenL :: AVL e -> Maybe (ZAVL e)-tryOpenL E = Nothing-tryOpenL (N l e r) = Just $! openLN EP L(0) l e r -- Relative heights !!-tryOpenL (Z l e r) = Just $! openLZ EP L(0) l e r -- Relative heights !!-tryOpenL (P l e r) = Just $! openL_ (LP EP e r L(0)) L(1) l -- Relative heights !!---- Local utility for opening at the leftmost element, using current path and height.-openL_ :: (Path e) -> UINT -> AVL e -> ZAVL e-openL_ _ _ E = error "openL_: Bug0"-openL_ p h (N l e r) = openLN p h l e r-openL_ p h (Z l e r) = openLZ p h l e r-openL_ p h (P l e r) = let p_ = LP p e r DECINT2(h) in p_ `seq` openL_ p_ DECINT1(h) l---- Open leftmost of (N l e r), where l may be E-openLN :: (Path e) -> UINT -> AVL e -> e -> AVL e -> ZAVL e-openLN p h E e r = ZAVL p E DECINT2(h) e r DECINT1(h)-openLN p h (N ll le lr) e r = let p_ = LP p e r DECINT1(h) in p_ `seq` openLN p_ DECINT2(h) ll le lr-openLN p h (Z ll le lr) e r = let p_ = LP p e r DECINT1(h) in p_ `seq` openLZ p_ DECINT2(h) ll le lr-openLN p h (P ll le lr) e r = let p_ = LP p e r DECINT1(h)- p__ = p_ `seq` LP p_ le lr DECINT4(h)- in p__ `seq` openL_ p__ DECINT3(h) ll--- Open leftmost of (Z l e r), where l may be E-openLZ :: (Path e) -> UINT -> AVL e -> e -> AVL e -> ZAVL e-openLZ p h E e r = ZAVL p E DECINT1(h) e r DECINT1(h)-openLZ p h (N ll le lr) e r = let p_ = LP p e r DECINT1(h) in p_ `seq` openLN p_ DECINT1(h) ll le lr-openLZ p h (Z ll le lr) e r = let p_ = LP p e r DECINT1(h) in p_ `seq` openLZ p_ DECINT1(h) ll le lr-openLZ p h (P ll le lr) e r = let p_ = LP p e r DECINT1(h)- p__ = p_ `seq` LP p_ le lr DECINT3(h)- in p__ `seq` openL_ p__ DECINT2(h) ll---- | Opens a non-empty AVL tree at the rightmost element.--- This function raises an error if the tree is empty.------ Complexity: O(log n)-assertOpenR :: AVL e -> ZAVL e-assertOpenR E = error "assertOpenR: Empty tree."-assertOpenR (N l e r) = openR_ (RP EP e l L(0)) L(1) r -- Relative heights !!-assertOpenR (Z l e r) = openRZ EP L(0) l e r -- Relative heights !!-assertOpenR (P l e r) = openRP EP L(0) l e r -- Relative heights !!---- | Attempts to open a non-empty AVL tree at the rightmost element.--- This function returns 'Nothing' if the tree is empty.------ Complexity: O(log n)-tryOpenR :: AVL e -> Maybe (ZAVL e)-tryOpenR E = Nothing-tryOpenR (N l e r) = Just $! openR_ (RP EP e l L(0)) L(1) r -- Relative heights !!-tryOpenR (Z l e r) = Just $! openRZ EP L(0) l e r -- Relative heights !!-tryOpenR (P l e r) = Just $! openRP EP L(0) l e r -- Relative heights !!---- Local utility for opening at the rightmost element, using current path and height.-openR_ :: (Path e) -> UINT -> AVL e -> ZAVL e-openR_ _ _ E = error "openR_: Bug0"-openR_ p h (N l e r) = let p_ = RP p e l DECINT2(h) in p_ `seq` openR_ p_ DECINT1(h) r-openR_ p h (Z l e r) = openRZ p h l e r-openR_ p h (P l e r) = openRP p h l e r--- Open rightmost of (P l e r), where r may be E-openRP :: (Path e) -> UINT -> AVL e -> e -> AVL e -> ZAVL e-openRP p h l e E = ZAVL p l DECINT1(h) e E DECINT2(h)-openRP p h l e (N rl re rr) = let p_ = RP p e l DECINT1(h)- p__ = p_ `seq` RP p_ re rl DECINT4(h)- in p__ `seq` openR_ p__ DECINT3(h) rr-openRP p h l e (Z rl re rr) = let p_ = RP p e l DECINT1(h) in p_ `seq` openRZ p_ DECINT2(h) rl re rr-openRP p h l e (P rl re rr) = let p_ = RP p e l DECINT1(h) in p_ `seq` openRP p_ DECINT2(h) rl re rr--- Open rightmost of (Z l e r), where r may be E-openRZ :: (Path e) -> UINT -> AVL e -> e -> AVL e -> ZAVL e-openRZ p h l e E = ZAVL p l DECINT1(h) e E DECINT1(h)-openRZ p h l e (N rl re rr) = let p_ = RP p e l DECINT1(h)- p__ = p_ `seq` RP p_ re rl DECINT3(h)- in p__ `seq` openR_ p__ DECINT2(h) rr-openRZ p h l e (Z rl re rr) = let p_ = RP p e l DECINT1(h) in p_ `seq` openRZ p_ DECINT1(h) rl re rr-openRZ p h l e (P rl re rr) = let p_ = RP p e l DECINT1(h) in p_ `seq` openRP p_ DECINT1(h) rl re rr---- | Returns @('Right' zavl)@ if the expected element was found, @('Left' pavl)@ if the--- expected element was not found. It's OK to use this function on empty trees.------ Complexity: O(log n)-openEither :: (e -> Ordering) -> AVL e -> Either (PAVL e) (ZAVL e)-openEither c t = op EP L(0) t where -- Relative heights !!- -- op :: (Path e) -> UINT -> AVL e -> Either (PAVL e) (ZAVL e)- op p h E = Left $! PAVL p h- op p h (N l e r) = case c e of- LT -> let p_ = LP p e r DECINT1(h) in p_ `seq` op p_ DECINT2(h) l- EQ -> Right $! ZAVL p l DECINT2(h) e r DECINT1(h)- GT -> let p_ = RP p e l DECINT2(h) in p_ `seq` op p_ DECINT1(h) r- op p h (Z l e r) = case c e of- LT -> let p_ = LP p e r DECINT1(h) in p_ `seq` op p_ DECINT1(h) l- EQ -> Right $! ZAVL p l DECINT1(h) e r DECINT1(h)- GT -> let p_ = RP p e l DECINT1(h) in p_ `seq` op p_ DECINT1(h) r- op p h (P l e r) = case c e of- LT -> let p_ = LP p e r DECINT2(h) in p_ `seq` op p_ DECINT1(h) l- EQ -> Right $! ZAVL p l DECINT1(h) e r DECINT2(h)- GT -> let p_ = RP p e l DECINT1(h) in p_ `seq` op p_ DECINT2(h) r---- | Fill the gap pointed to by a 'PAVL' with the supplied element, which becomes--- the current element of the resulting 'ZAVL'. The supplied filling element should--- be \"equal\" to the value used in the search which created the 'PAVL'.------ Complexity: O(1)-fill :: e -> PAVL e -> ZAVL e-fill e (PAVL p h) = ZAVL p E h e E h---- | Essentially the same operation as 'fill', but the resulting 'ZAVL' is closed--- immediately.------ Complexity: O(log n)-fillClose :: e -> PAVL e -> AVL e-fillClose e (PAVL p h) = close_ p (Z E e E) INCINT1(h)---- | Closes a Zipper.------ Complexity: O(log n)-close :: ZAVL e -> AVL e-close (ZAVL p l hl e r hr) = case spliceH l hl e r hr of UBT2(t,ht) -> close_ p t ht---- | Deletes the current element and then closes the Zipper.------ Complexity: O(log n)-delClose :: ZAVL e -> AVL e-delClose (ZAVL p l hl _ r hr) = case joinH l hl r hr of UBT2(t,ht) -> close_ p t ht---- | Gets the current element of a Zipper.------ Complexity: O(1)-getCurrent :: ZAVL e -> e-getCurrent (ZAVL _ _ _ e _ _) = e---- | Overwrites the current element of a Zipper.------ Complexity: O(1)-putCurrent :: e -> ZAVL e -> ZAVL e-putCurrent e (ZAVL p l hl _ r hr) = ZAVL p l hl e r hr---- | Applies a function to the current element of a Zipper (lazily).--- See also 'applyCurrent'' for a strict version of this function.------ Complexity: O(1)-applyCurrent :: (e -> e) -> ZAVL e -> ZAVL e-applyCurrent f (ZAVL p l hl e r hr) = ZAVL p l hl (f e) r hr---- | Applies a function to the current element of a Zipper strictly.--- See also 'applyCurrent' for a non-strict version of this function.------ Complexity: O(1)-applyCurrent' :: (e -> e) -> ZAVL e -> ZAVL e-applyCurrent' f (ZAVL p l hl e r hr) = let e_ = f e in e_ `seq` ZAVL p l hl e_ r hr---- | Moves one step left.--- This function raises an error if the current element is already the leftmost element.------ Complexity: O(1) average, O(log n) worst case.-assertMoveL :: ZAVL e -> ZAVL e-assertMoveL (ZAVL p E _ e r hr) = case pushHL e r hr of UBT2(t,ht) -> cR p t ht- where cR EP _ _ = error "assertMoveL: Can't move left."- cR (LP p_ e_ r_ hr_) l_ hl_ = case spliceH l_ hl_ e_ r_ hr_ of UBT2(t,ht) -> cR p_ t ht- cR (RP p_ e_ l_ hl_) r_ hr_ = ZAVL p_ l_ hl_ e_ r_ hr_-assertMoveL (ZAVL p (N ll le lr) hl e r hr) = let p_ = RP (LP p e r hr) le ll DECINT2(hl)- in p_ `seq` openR_ p_ DECINT1(hl) lr-assertMoveL (ZAVL p (Z ll le lr) hl e r hr) = openRZ (LP p e r hr) hl ll le lr-assertMoveL (ZAVL p (P ll le lr) hl e r hr) = openRP (LP p e r hr) hl ll le lr---- | Attempts to move one step left.--- This function returns 'Nothing' if the current element is already the leftmost element.------ Complexity: O(1) average, O(log n) worst case.-tryMoveL :: ZAVL e -> Maybe (ZAVL e)-tryMoveL (ZAVL p E _ e r hr) = case pushHL e r hr of UBT2(t,ht) -> cR p t ht- where cR EP _ _ = Nothing- cR (LP p_ e_ r_ hr_) l_ hl_ = case spliceH l_ hl_ e_ r_ hr_ of UBT2(t,ht) -> cR p_ t ht- cR (RP p_ e_ l_ hl_) r_ hr_ = Just $! ZAVL p_ l_ hl_ e_ r_ hr_-tryMoveL (ZAVL p (N ll le lr) hl e r hr) = Just $! let p_ = RP (LP p e r hr) le ll DECINT2(hl)- in p_ `seq` openR_ p_ DECINT1(hl) lr-tryMoveL (ZAVL p (Z ll le lr) hl e r hr) = Just $! openRZ (LP p e r hr) hl ll le lr-tryMoveL (ZAVL p (P ll le lr) hl e r hr) = Just $! openRP (LP p e r hr) hl ll le lr---- | Moves one step right.--- This function raises an error if the current element is already the rightmost element.------ Complexity: O(1) average, O(log n) worst case.-assertMoveR :: ZAVL e -> ZAVL e-assertMoveR (ZAVL p l hl e E _ ) = case pushHR l hl e of UBT2(t,ht) -> cL p t ht- where cL EP _ _ = error "assertMoveR: Can't move right."- cL (RP p_ e_ l_ hl_) r_ hr_ = case spliceH l_ hl_ e_ r_ hr_ of UBT2(t,ht) -> cL p_ t ht- cL (LP p_ e_ r_ hr_) l_ hl_ = ZAVL p_ l_ hl_ e_ r_ hr_-assertMoveR (ZAVL p l hl e (N rl re rr) hr) = openLN (RP p e l hl) hr rl re rr-assertMoveR (ZAVL p l hl e (Z rl re rr) hr) = openLZ (RP p e l hl) hr rl re rr-assertMoveR (ZAVL p l hl e (P rl re rr) hr) = let p_ = LP (RP p e l hl) re rr DECINT2(hr)- in p_ `seq` openL_ p_ DECINT1(hr) rl---- | Attempts to move one step right.--- This function returns 'Nothing' if the current element is already the rightmost element.------ Complexity: O(1) average, O(log n) worst case.-tryMoveR :: ZAVL e -> Maybe (ZAVL e)-tryMoveR (ZAVL p l hl e E _ ) = case pushHR l hl e of UBT2(t,ht) -> cL p t ht- where cL EP _ _ = Nothing- cL (RP p_ e_ l_ hl_) r_ hr_ = case spliceH l_ hl_ e_ r_ hr_ of UBT2(t,ht) -> cL p_ t ht- cL (LP p_ e_ r_ hr_) l_ hl_ = Just $! ZAVL p_ l_ hl_ e_ r_ hr_-tryMoveR (ZAVL p l hl e (N rl re rr) hr) = Just $! openLN (RP p e l hl) hr rl re rr-tryMoveR (ZAVL p l hl e (Z rl re rr) hr) = Just $! openLZ (RP p e l hl) hr rl re rr-tryMoveR (ZAVL p l hl e (P rl re rr) hr) = Just $! let p_ = LP (RP p e l hl) re rr DECINT2(hr)- in p_ `seq` openL_ p_ DECINT1(hr) rl---- | Returns 'True' if the current element is the leftmost element.------ Complexity: O(1) average, O(log n) worst case.-isLeftmost :: ZAVL e -> Bool-isLeftmost (ZAVL p E _ _ _ _) = iL p- where iL EP = True- iL (LP p_ _ _ _) = iL p_- iL (RP _ _ _ _) = False-isLeftmost (ZAVL _ _ _ _ _ _) = False---- | Returns 'True' if the current element is the rightmost element.------ Complexity: O(1) average, O(log n) worst case.-isRightmost :: ZAVL e -> Bool-isRightmost (ZAVL p _ _ _ E _) = iR p- where iR EP = True- iR (RP p_ _ _ _) = iR p_- iR (LP _ _ _ _) = False-isRightmost (ZAVL _ _ _ _ _ _) = False---- | Inserts a new element to the immediate left of the current element.------ Complexity: O(1) average, O(log n) worst case.-insertL :: e -> ZAVL e -> ZAVL e-insertL e0 (ZAVL p l hl e1 r hr) = case pushHR l hl e0 of UBT2(l_,hl_) -> ZAVL p l_ hl_ e1 r hr---- | Inserts a new element to the immediate left of the current element and then--- moves one step left (so the newly inserted element becomes the current element).------ Complexity: O(1) average, O(log n) worst case.-insertMoveL :: e -> ZAVL e -> ZAVL e-insertMoveL e0 (ZAVL p l hl e1 r hr) = case pushHL e1 r hr of UBT2(r_,hr_) -> ZAVL p l hl e0 r_ hr_---- | Inserts a new element to the immediate right of the current element.------ Complexity: O(1) average, O(log n) worst case.-insertR :: ZAVL e -> e -> ZAVL e-insertR (ZAVL p l hl e0 r hr) e1 = case pushHL e1 r hr of UBT2(r_,hr_) -> ZAVL p l hl e0 r_ hr_---- | Inserts a new element to the immediate right of the current element and then--- moves one step right (so the newly inserted element becomes the current element).------ Complexity: O(1) average, O(log n) worst case.-insertMoveR :: ZAVL e -> e -> ZAVL e-insertMoveR (ZAVL p l hl e0 r hr) e1 = case pushHR l hl e0 of UBT2(l_,hl_) -> ZAVL p l_ hl_ e1 r hr---- | Inserts a new AVL tree to the immediate left of the current element.------ Complexity: O(log n), where n is the size of the inserted tree.-insertTreeL :: AVL e -> ZAVL e -> ZAVL e-insertTreeL E zavl = zavl-insertTreeL t@(N l _ _) zavl = insertLH t (addHeight L(2) l) zavl -- Absolute height required!!-insertTreeL t@(Z l _ _) zavl = insertLH t (addHeight L(1) l) zavl -- Absolute height required!!-insertTreeL t@(P _ _ r) zavl = insertLH t (addHeight L(2) r) zavl -- Absolute height required!!----- Local utility to insert an AVL to the immediate left of the current element.--- This operation carries a minor overhead in that we must convert the absolute--- AVL height into a relative height with the same offset as the rest of the ZAVL.--- This requires calculation of the absolute height at the current position, but--- this should be relatively cheap because the overwhelming majority of elements will--- be close to the bottom of any tree.-insertLH :: AVL e -> UINT -> ZAVL e -> ZAVL e-insertLH t ht (ZAVL p l hl e r hr) =- let offset = case COMPAREUINT hl hr of -- chose smaller sub-tree to calculate absolute height- LT -> SUBINT(hl,height l)- EQ -> SUBINT(hl,height l)- GT -> SUBINT(hr,height r)- in case joinH l hl t ADDINT(ht,offset) of UBT2(l_,hl_) -> ZAVL p l_ hl_ e r hr---- | Inserts a new AVL tree to the immediate right of the current element.------ Complexity: O(log n), where n is the size of the inserted tree.-insertTreeR :: ZAVL e -> AVL e -> ZAVL e-insertTreeR zavl E = zavl-insertTreeR zavl t@(N l _ _) = insertRH t (addHeight L(2) l) zavl -- Absolute height required!!-insertTreeR zavl t@(Z l _ _) = insertRH t (addHeight L(1) l) zavl -- Absolute height required!!-insertTreeR zavl t@(P _ _ r) = insertRH t (addHeight L(2) r) zavl -- Absolute height required!!---- Local utility to insert an AVL to the immediate right of the current element.--- This operation carries a minor overhead in that we must convert the absolute--- AVL height into a relative height with the same offset as the rest of the ZAVL.--- This requires calculation of the absolute height at the current position, but--- this should be relatively cheap because the overwhelming majority of elements will--- be close to the bottom of any tree.-insertRH :: AVL e -> UINT -> ZAVL e -> ZAVL e-insertRH t ht (ZAVL p l hl e r hr) =- let offset = case COMPAREUINT hl hr of -- chose smaller sub-tree to calculate absolute height- LT -> SUBINT(hl,height l)- EQ -> SUBINT(hr,height r)- GT -> SUBINT(hr,height r)- in case joinH t ADDINT(ht,offset) r hr of UBT2(r_,hr_) -> ZAVL p l hl e r_ hr_----- | Deletes the current element and moves one step left.--- This function raises an error if the current element is already the leftmost element.------ Complexity: O(1) average, O(log n) worst case.-assertDelMoveL :: ZAVL e -> ZAVL e-assertDelMoveL (ZAVL p E _ _ r hr) = dR p r hr- where dR EP _ _ = error "assertDelMoveL: Can't move left."- dR (LP p_ e_ r_ hr_) l_ hl_ = case spliceH l_ hl_ e_ r_ hr_ of UBT2(t,ht) -> dR p_ t ht- dR (RP p_ e_ l_ hl_) r_ hr_ = ZAVL p_ l_ hl_ e_ r_ hr_-assertDelMoveL (ZAVL p (N ll le lr) hl _ r hr) = case popRN ll le lr of- UBT2(l,e) -> case l of- Z _ _ _ -> ZAVL p l DECINT1(hl) e r hr- N _ _ _ -> ZAVL p l hl e r hr- _ -> error "assertDelMoveL: Bug0" -- impossible-assertDelMoveL (ZAVL p (Z ll le lr) hl _ r hr) = case popRZ ll le lr of- UBT2(l,e) -> case l of- E -> ZAVL p l DECINT1(hl) e r hr -- Don't use E!!- N _ _ _ -> error "assertDelMoveL: Bug1" -- impossible- _ -> ZAVL p l hl e r hr-assertDelMoveL (ZAVL p (P ll le lr) hl _ r hr) = case popRP ll le lr of- UBT2(l,e) -> case l of- E -> error "assertDelMoveL: Bug2" -- impossible- Z _ _ _ -> ZAVL p l DECINT1(hl) e r hr- _ -> ZAVL p l hl e r hr----- | Attempts to delete the current element and move one step left.--- This function returns 'Nothing' if the current element is already the leftmost element.------ Complexity: O(1) average, O(log n) worst case.-tryDelMoveL :: ZAVL e -> Maybe (ZAVL e)-tryDelMoveL (ZAVL p E _ _ r hr) = dR p r hr- where dR EP _ _ = Nothing- dR (LP p_ e_ r_ hr_) l_ hl_ = case spliceH l_ hl_ e_ r_ hr_ of UBT2(t,ht) -> dR p_ t ht- dR (RP p_ e_ l_ hl_) r_ hr_ = Just $! ZAVL p_ l_ hl_ e_ r_ hr_-tryDelMoveL (ZAVL p (N ll le lr) hl _ r hr) = Just $! case popRN ll le lr of- UBT2(l,e) -> case l of- Z _ _ _ -> ZAVL p l DECINT1(hl) e r hr- N _ _ _ -> ZAVL p l hl e r hr- _ -> error "tryDelMoveL: Bug0" -- impossible-tryDelMoveL (ZAVL p (Z ll le lr) hl _ r hr) = Just $! case popRZ ll le lr of- UBT2(l,e) -> case l of- E -> ZAVL p l DECINT1(hl) e r hr -- Don't use E!!- N _ _ _ -> error "tryDelMoveL: Bug1" -- impossible- _ -> ZAVL p l hl e r hr-tryDelMoveL (ZAVL p (P ll le lr) hl _ r hr) = Just $! case popRP ll le lr of- UBT2(l,e) -> case l of- E -> error "tryDelMoveL: Bug2" -- impossible- Z _ _ _ -> ZAVL p l DECINT1(hl) e r hr- _ -> ZAVL p l hl e r hr----- | Deletes the current element and moves one step right.--- This function raises an error if the current element is already the rightmost element.------ Complexity: O(1) average, O(log n) worst case.-assertDelMoveR :: ZAVL e -> ZAVL e-assertDelMoveR (ZAVL p l hl _ E _ ) = dL p l hl- where dL EP _ _ = error "delMoveR: Can't move right."- dL (LP p_ e_ r_ hr_) l_ hl_ = ZAVL p_ l_ hl_ e_ r_ hr_- dL (RP p_ e_ l_ hl_) r_ hr_ = case spliceH l_ hl_ e_ r_ hr_ of UBT2(t,ht) -> dL p_ t ht-assertDelMoveR (ZAVL p l hl _ (N rl re rr) hr) = case popLN rl re rr of- UBT2(e,r) -> case r of- E -> error "delMoveR: Bug0" -- impossible- Z _ _ _ -> ZAVL p l hl e r DECINT1(hr)- _ -> ZAVL p l hl e r hr-assertDelMoveR (ZAVL p l hl _ (Z rl re rr) hr) = case popLZ rl re rr of- UBT2(e,r) -> case r of- E -> ZAVL p l hl e r DECINT1(hr) -- Don't use E!!- P _ _ _ -> error "delMoveR: Bug1" -- impossible- _ -> ZAVL p l hl e r hr-assertDelMoveR (ZAVL p l hl _ (P rl re rr) hr) = case popLP rl re rr of- UBT2(e,r) -> case r of- Z _ _ _ -> ZAVL p l hl e r DECINT1(hr)- P _ _ _ -> ZAVL p l hl e r hr- _ -> error "delMoveR: Bug2" -- impossible----- | Attempts to delete the current element and move one step right.--- This function returns 'Nothing' if the current element is already the rightmost element.------ Complexity: O(1) average, O(log n) worst case.-tryDelMoveR :: ZAVL e -> Maybe (ZAVL e)-tryDelMoveR (ZAVL p l hl _ E _ ) = dL p l hl- where dL EP _ _ = Nothing- dL (LP p_ e_ r_ hr_) l_ hl_ = Just $! ZAVL p_ l_ hl_ e_ r_ hr_- dL (RP p_ e_ l_ hl_) r_ hr_ = case spliceH l_ hl_ e_ r_ hr_ of UBT2(t,ht) -> dL p_ t ht-tryDelMoveR (ZAVL p l hl _ (N rl re rr) hr) = Just $! case popLN rl re rr of- UBT2(e,r) -> case r of- E -> error "tryDelMoveR: Bug0" -- impossible- Z _ _ _ -> ZAVL p l hl e r DECINT1(hr)- _ -> ZAVL p l hl e r hr-tryDelMoveR (ZAVL p l hl _ (Z rl re rr) hr) = Just $! case popLZ rl re rr of- UBT2(e,r) -> case r of- E -> ZAVL p l hl e r DECINT1(hr) -- Don't use E!!- P _ _ _ -> error "tryDelMoveR: Bug1" -- impossible- _ -> ZAVL p l hl e r hr-tryDelMoveR (ZAVL p l hl _ (P rl re rr) hr) = Just $! case popLP rl re rr of- UBT2(e,r) -> case r of- Z _ _ _ -> ZAVL p l hl e r DECINT1(hr)- P _ _ _ -> ZAVL p l hl e r hr- _ -> error "tryDelMoveR: Bug2" -- impossible----- | Delete all elements to the left of the current element.------ Complexity: O(log n)-delAllL :: ZAVL e -> ZAVL e-delAllL (ZAVL p l hl e r hr) =- let hE = case COMPAREUINT hl hr of -- Calculate relative offset and use this as height of empty tree- LT -> SUBINT(hl,height l)- EQ -> SUBINT(hr,height r)- GT -> SUBINT(hr,height r)- p_ = noRP p -- remove right paths (current element becomes leftmost)- in p_ `seq` ZAVL p_ E hE e r hr---- | Delete all elements to the right of the current element.------ Complexity: O(log n)-delAllR :: ZAVL e -> ZAVL e-delAllR (ZAVL p l hl e r hr) =- let hE = case COMPAREUINT hl hr of -- Calculate relative offset and use this as height of empty tree- LT -> SUBINT(hl,height l)- EQ -> SUBINT(hl,height l)- GT -> SUBINT(hr,height r)- p_ = noLP p -- remove left paths (current element becomes rightmost)- in p_ `seq` ZAVL p_ l hl e E hE---- | Similar to 'delAllL', in that all elements to the left of the current element are deleted,--- but this function also closes the tree in the process.------ Complexity: O(log n)-delAllCloseL :: ZAVL e -> AVL e-delAllCloseL (ZAVL p _ _ e r hr) = case pushHL e r hr of UBT2(t,ht) -> closeNoRP p t ht---- | Similar to 'delAllR', in that all elements to the right of the current element are deleted,--- but this function also closes the tree in the process.------ Complexity: O(log n)-delAllCloseR :: ZAVL e -> AVL e-delAllCloseR (ZAVL p l hl e _ _) = case pushHR l hl e of UBT2(t,ht) -> closeNoLP p t ht---- | Similar to 'delAllCloseL', but in this case the current element and all--- those to the left of the current element are deleted.------ Complexity: O(log n)-delAllIncCloseL :: ZAVL e -> AVL e-delAllIncCloseL (ZAVL p _ _ _ r hr) = closeNoRP p r hr---- | Similar to 'delAllCloseR', but in this case the current element and all--- those to the right of the current element are deleted.------ Complexity: O(log n)-delAllIncCloseR :: ZAVL e -> AVL e-delAllIncCloseR (ZAVL p l hl _ _ _) = closeNoLP p l hl---- | Counts the number of elements to the left of the current element--- (this does not include the current element).------ Complexity: O(n), where n is the count result.-sizeL :: ZAVL e -> Int-sizeL (ZAVL p l _ _ _ _) = addSizeRP (size l) p---- | Counts the number of elements to the right of the current element--- (this does not include the current element).------ Complexity: O(n), where n is the count result.-sizeR :: ZAVL e -> Int-sizeR (ZAVL p _ _ _ r _) = addSizeLP (size r) p---- | Counts the total number of elements in a ZAVL.------ Complexity: O(n)-sizeZAVL :: ZAVL e -> Int-sizeZAVL (ZAVL p l _ _ r _) = addSizeP (addSize (addSize 1 l) r) p---{-------------------- BAVL stuff below ----------------------------------}---- | A 'BAVL' is like a pointer reference to somewhere inside an 'AVL' tree. It may be either \"full\"--- (meaning it points to an actual tree node containing an element), or \"empty\" (meaning it--- points to the position in a tree where an element was expected but wasn\'t found).-data BAVL e = BAVL (AVL e) (BinPath e)---- | Search for an element in a /sorted/ 'AVL' tree using the supplied selector.--- Returns a \"full\" 'BAVL' if a matching element was found, otherwise returns an \"empty\" 'BAVL'.------ Complexity: O(log n)-openBAVL :: (e -> Ordering) -> AVL e -> BAVL e-{-# INLINE openBAVL #-}-openBAVL c t = bp `seq` BAVL t bp- where bp = openPath c t---- | Returns the original tree, extracted from the 'BAVL'. Typically you will not need this, as--- the original tree will still be in scope in most cases.------ Complexity: O(1)-closeBAVL :: BAVL e -> AVL e-{-# INLINE closeBAVL #-}-closeBAVL (BAVL t _) = t---- | Returns 'True' if the 'BAVL' is \"full\" (a corresponding element was found).------ Complexity: O(1)-fullBAVL :: BAVL e -> Bool-{-# INLINE fullBAVL #-}-fullBAVL (BAVL _ (FullBP _ _)) = True-fullBAVL (BAVL _ (EmptyBP _ )) = False---- | Returns 'True' if the 'BAVL' is \"empty\" (no corresponding element was found).------ Complexity: O(1)-emptyBAVL :: BAVL e -> Bool-{-# INLINE emptyBAVL #-}-emptyBAVL (BAVL _ (FullBP _ _)) = False-emptyBAVL (BAVL _ (EmptyBP _ )) = True---- | Read the element value from a \"full\" 'BAVL'.--- This function returns 'Nothing' if applied to an \"empty\" 'BAVL'.------ Complexity: O(1)-tryReadBAVL :: BAVL e -> Maybe e-{-# INLINE tryReadBAVL #-}-tryReadBAVL (BAVL _ (FullBP _ e)) = Just e-tryReadBAVL (BAVL _ (EmptyBP _ )) = Nothing---- | Read the element value from a \"full\" 'BAVL'.--- This function raises an error if applied to an \"empty\" 'BAVL'.------ Complexity: O(1)-readFullBAVL :: BAVL e -> e-{-# INLINE readFullBAVL #-}-readFullBAVL (BAVL _ (FullBP _ e)) = e-readFullBAVL (BAVL _ (EmptyBP _ )) = error "readFullBAVL: Empty BAVL."---- | If the 'BAVL' is \"full\", this function returns the original tree with the corresponding--- element replaced by the new element (first argument). If it\'s \"empty\" the original tree is returned--- with the new element inserted.------ Complexity: O(log n)-pushBAVL :: e -> BAVL e -> AVL e-{-# INLINE pushBAVL #-}-pushBAVL e (BAVL t (FullBP p _)) = writePath p e t-pushBAVL e (BAVL t (EmptyBP p )) = insertPath p e t---- | If the 'BAVL' is \"full\", this function returns the original tree with the corresponding--- element deleted. If it\'s \"empty\" the original tree is returned unmodified.------ Complexity: O(log n) (or O(1) for an empty 'BAVL')-deleteBAVL :: BAVL e -> AVL e-{-# INLINE deleteBAVL #-}-deleteBAVL (BAVL t (FullBP p _)) = deletePath p t-deleteBAVL (BAVL t (EmptyBP _ )) = t---- | Converts a \"full\" 'BAVL' as a 'ZAVL'. Raises an error if applied to an \"empty\" 'BAVL'.------ Complexity: O(log n)-fullBAVLtoZAVL :: BAVL e -> ZAVL e-fullBAVLtoZAVL (BAVL t (FullBP i _)) = openFull i EP L(0) t -- Relative heights !!-fullBAVLtoZAVL (BAVL _ (EmptyBP _ )) = error "fullBAVLtoZAVL: Empty BAVL."--- Local Utility-openFull :: UINT -> (Path e) -> UINT -> AVL e -> ZAVL e-openFull _ _ _ E = error "openFull: Bug0."-openFull i p h (N l e r) = case sel i of- LT -> let p_ = LP p e r DECINT1(h) in p_ `seq` openFull (goL i) p_ DECINT2(h) l- EQ -> ZAVL p l DECINT2(h) e r DECINT1(h)- GT -> let p_ = RP p e l DECINT2(h) in p_ `seq` openFull (goR i) p_ DECINT1(h) r-openFull i p h (Z l e r) = case sel i of- LT -> let p_ = LP p e r DECINT1(h) in p_ `seq` openFull (goL i) p_ DECINT1(h) l- EQ -> ZAVL p l DECINT1(h) e r DECINT1(h)- GT -> let p_ = RP p e l DECINT1(h) in p_ `seq` openFull (goR i) p_ DECINT1(h) r-openFull i p h (P l e r) = case sel i of- LT -> let p_ = LP p e r DECINT2(h) in p_ `seq` openFull (goL i) p_ DECINT1(h) l- EQ -> ZAVL p l DECINT1(h) e r DECINT2(h)- GT -> let p_ = RP p e l DECINT1(h) in p_ `seq` openFull (goR i) p_ DECINT2(h) r---- | Converts an \"empty\" 'BAVL' as a 'PAVL'. Raises an error if applied to a \"full\" 'BAVL'.------ Complexity: O(log n)-emptyBAVLtoPAVL :: BAVL e -> PAVL e-emptyBAVLtoPAVL (BAVL _ (FullBP _ _)) = error "emptyBAVLtoPAVL: Full BAVL."-emptyBAVLtoPAVL (BAVL t (EmptyBP i )) = openEmpty i EP L(0) t -- Relative heights !!--- Local Utility-openEmpty :: UINT -> (Path e) -> UINT -> AVL e -> PAVL e-openEmpty _ p h E = PAVL p h -- Test for i==0 ??-openEmpty i p h (N l e r) = case sel i of- LT -> let p_ = LP p e r DECINT1(h) in p_ `seq` openEmpty (goL i) p_ DECINT2(h) l- EQ -> error "openEmpty: Bug0"- GT -> let p_ = RP p e l DECINT2(h) in p_ `seq` openEmpty (goR i) p_ DECINT1(h) r-openEmpty i p h (Z l e r) = case sel i of- LT -> let p_ = LP p e r DECINT1(h) in p_ `seq` openEmpty (goL i) p_ DECINT1(h) l- EQ -> error "openEmpty: Bug1"- GT -> let p_ = RP p e l DECINT1(h) in p_ `seq` openEmpty (goR i) p_ DECINT1(h) r-openEmpty i p h (P l e r) = case sel i of- LT -> let p_ = LP p e r DECINT2(h) in p_ `seq` openEmpty (goL i) p_ DECINT1(h) l- EQ -> error "openEmpty: Bug2"- GT -> let p_ = RP p e l DECINT1(h) in p_ `seq` openEmpty (goR i) p_ DECINT2(h) r----- | Converts a 'BAVL' to either a 'PAVL' or 'ZAVL' (depending on whether it is \"empty\" or \"full\").------ Complexity: O(log n)-anyBAVLtoEither :: BAVL e -> Either (PAVL e) (ZAVL e)-anyBAVLtoEither (BAVL t (FullBP i _)) = Right (openFull i EP L(0) t) -- Relative heights !!-anyBAVLtoEither (BAVL t (EmptyBP i )) = Left (openEmpty i EP L(0) t) -- Relative heights !!
− Data/Tree/AVLX.hs
@@ -1,63 +0,0 @@-{-# OPTIONS_GHC -fno-warn-duplicate-exports #-}--------------------------------------------------------------------------------- |--- Module : Data.Tree.AVLX--- Copyright : (c) Adrian Hey 2004,2005,2006,2007--- License : BSD3------ Maintainer : http://homepages.nildram.co.uk/~ahey/em.png--- Stability : unstable--- Portability : portable------ This module exports everything AVL, for test purposes only.--- Not for general consumption.-------------------------------------------------------------------------------module Data.Tree.AVLX-(module Data.Tree.AVL,- module Data.Tree.AVL.Delete,- module Data.Tree.AVL.Join,- module Data.Tree.AVL.List,- module Data.Tree.AVL.Push,- module Data.Tree.AVL.Read,- module Data.Tree.AVL.Set,- module Data.Tree.AVL.Size,- module Data.Tree.AVL.Height,- module Data.Tree.AVL.Split,- module Data.Tree.AVL.Types,- module Data.Tree.AVL.Write,- module Data.Tree.AVL.Zipper,- module Data.Tree.AVL.BinPath,- module Data.Tree.AVL.Deprecated,- module Data.Tree.AVL.Internals.DelUtils,- module Data.Tree.AVL.Internals.HAVL,- module Data.Tree.AVL.Internals.HJoin,- module Data.Tree.AVL.Internals.HPush,- module Data.Tree.AVL.Internals.HSet,- module Data.Tree.AVL.Test.Counter,- module Data.Tree.AVL.Test.Utils,-) where--import Data.Tree.AVL-import Data.Tree.AVL.Delete-import Data.Tree.AVL.Join-import Data.Tree.AVL.List-import Data.Tree.AVL.Push-import Data.Tree.AVL.Read-import Data.Tree.AVL.Set-import Data.Tree.AVL.Size-import Data.Tree.AVL.Height-import Data.Tree.AVL.Split-import Data.Tree.AVL.Types-import Data.Tree.AVL.Write-import Data.Tree.AVL.Zipper-import Data.Tree.AVL.BinPath-import Data.Tree.AVL.Internals.DelUtils-import Data.Tree.AVL.Internals.HAVL-import Data.Tree.AVL.Internals.HJoin-import Data.Tree.AVL.Internals.HPush-import Data.Tree.AVL.Internals.HSet-import Data.Tree.AVL.Test.Counter-import Data.Tree.AVL.Test.Utils-import Data.Tree.AVL.Deprecated--
− Setup.hs
@@ -1,3 +0,0 @@-#!/usr/bin/runhaskell-import Distribution.Simple-main = defaultMain
− Test/Test.hs
@@ -1,6 +0,0 @@--- Run me after installation to test AVL lib. --- Takes a long time! -import Data.Tree.AVL.Test.AllTests(allTests) - -main :: IO () -main = allTests
− include/h98defs.h
@@ -1,26 +0,0 @@-#define UINT Int-#define COMPAREUINT compare-#define INCINT1(n) ((n) + 1)-#define INCINT2(n) ((n) + 2)-#define INCINT3(n) ((n) + 3)-#define INCINT4(n) ((n) + 4)-#define DECINT1(n) ((n) - 1)-#define DECINT2(n) ((n) - 2)-#define DECINT3(n) ((n) - 3)-#define DECINT4(n) ((n) - 4)-#define SUBINT(m,n) ((m)- (n))-#define ADDINT(m,n) ((m)+ (n))-#define L(n) n-#define LEQ <=-#define LTN <-#define EQL ==-#define ASINT(n) (n)-#define NEGATE(n) (0 - (n))-#define _MODULO_(n,m) (n `mod` m)-#define UBT2(y,z) ( y,z )-#define UBT3(x,y,z) ( x,y,z )-#define UBT4(w,x,y,z) ( w,x,y,z )-#define UBT5(v,w,x,y,z) ( v,w,x,y,z )-#define UBT6(u,v,w,x,y,z) ( u,v,w,x,y,z )-#define IS_NEG(n) (n < 0)-#define LEFT_JUSTIFY_INT(m,n) (shiftL (m) (32-n))
+ src/Data/Tree/AVL.hs view
@@ -0,0 +1,358 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+-- |+-- Copyright : (c) Adrian Hey 2004,2008+-- License : BSD3+--+-- Many of the functions defined by this package make use of generalised comparison functions+-- which return a variant of the Prelude 'Prelude.Ordering' data type: 'Data.COrdering.COrdering'. These+-- are refered to as \"combining comparisons\". (This is because they combine \"equal\"+-- values in some manner defined by the user.)+--+-- The idea is that using this simple mechanism you can define many practical and+-- useful variations of tree (or general set) operations from a few generic primitives,+-- something that would not be so easy using plain 'Prelude.Ordering' comparisons+-- (overloaded or otherwise).+--+-- Functions which involve searching a tree really only require a single argument+-- function which takes the current tree element value as argument and returns+-- an 'Prelude.Ordering' or 'Data.COrdering.COrdering' to direct the next stage of the search down+-- the left or right sub-trees (or stop at the current element). For documentation+-- purposes, these functions are called \"selectors\" throughout this library.+-- Typically a selector will be obtained by partially applying the appropriate+-- combining comparison with the value or key being searched for. For example..+--+-- @+-- mySelector :: Int -> Ordering Tree elements are Ints+-- -- or+-- mySelector :: (key, val) -> COrdering val Tree elements are (key, val) pairs+-- @+--+module Data.Tree.AVL+(-- * Types+ AVL,++ -- * Simple AVL related utilities+ empty,isEmpty,isNonEmpty,singleton,pair,tryGetSingleton,++ -- * Reading from AVL trees++ -- ** Reading from extreme left or right+ assertReadL,tryReadL,+ assertReadR,tryReadR,++ -- ** Reading from /sorted/ AVL trees+ assertRead,tryRead,tryReadMaybe,defaultRead,++ -- ** Simple searches of /sorted/ AVL trees+ contains,++ -- * Writing to AVL trees+ -- | These functions alter the content of a tree (values of tree elements) but not the structure+ -- of a tree.++ -- ** Writing to extreme left or right+ -- | I'm not sure these are likely to be much use in practice, but they're+ -- simple enough to implement so are included for the sake of completeness.+ writeL,tryWriteL,writeR,tryWriteR,++ -- ** Writing to /sorted/ trees+ write,writeFast,tryWrite,writeMaybe,tryWriteMaybe,++ -- * \"Pushing\" new elements into AVL trees+ -- | \"Pushing\" is another word for insertion. (c.f \"Popping\".)++ -- ** Pushing on extreme left or right+ pushL,pushR,++ -- ** Pushing on /sorted/ AVL trees+ push,push',pushMaybe,pushMaybe',++ -- * Deleting elements from AVL trees++ -- ** Deleting from extreme left or right+ delL,delR,assertDelL,assertDelR,tryDelL,tryDelR,++ -- ** Deleting from /sorted/ trees+ delete,deleteFast,deleteIf,deleteMaybe,++ -- * \"Popping\" elements from AVL trees+ -- | \"Popping\" means reading and deleting a tree element in a single operation.++ -- ** Popping from extreme left or right+ assertPopL,assertPopR,tryPopL,tryPopR,++ -- ** Popping from /sorted/ trees+ assertPop,tryPop,assertPopMaybe,tryPopMaybe,assertPopIf,tryPopIf,++ -- * Set operations+ -- | Functions for manipulating AVL trees which represent ordered sets (I.E. /sorted/ trees).+ -- Note that although many of these functions work with a variety of different element+ -- types they all require that elements are sorted according to the same criterion (such+ -- as a field value in a record).++ -- ** Union+ union,unionMaybe,disjointUnion,unions,++ -- ** Difference+ difference,differenceMaybe,symDifference,++ -- ** Intersection+ intersection,intersectionMaybe,++ -- *** Intersection with the result as a list+ -- | Sometimes you don\'t want intersection to give a tree, particularly if the+ -- resulting elements are not orderered or sorted according to whatever criterion was+ -- used to sort the elements of the input sets.+ --+ -- The reason these variants are provided for intersection only (and not the other+ -- set functions) is that the (tree returning) intersections always construct an entirely+ -- new tree, whereas with the others the resulting tree will typically share sub-trees+ -- with one or both of the originals. (Of course the results of the others can easily be+ -- converted to a list too if required.)+ intersectionToList,intersectionAsList,+ intersectionMaybeToList,intersectionMaybeAsList,++ -- ** \'Venn diagram\' operations+ -- | Given two sets A and B represented as sorted AVL trees, the venn operations evaluate+ -- components @A-B@, @A.B@ and @B-A@. The intersection part may be obtained as a List+ -- rather than AVL tree if required.+ --+ -- Note that in all cases the three resulting sets are /disjoint/ and can safely be re-combined+ -- after most \"munging\" operations using 'disjointUnion'.+ venn,vennMaybe,++ -- *** \'Venn diagram\' operations with the intersection component as a List.+ -- | These variants are provided for the same reasons as the Intersection as List variants.+ vennToList,vennAsList,+ vennMaybeToList,vennMaybeAsList,++ -- ** Subset+ isSubsetOf,isSubsetOfBy,++ -- * The AVL Zipper+ -- | An implementation of \"The Zipper\" for AVL trees. This can be used like+ -- a functional pointer to a serial data structure which can be navigated+ -- and modified, without having to worry about all those tricky tree balancing+ -- issues. See JFP Vol.7 part 5 or <http://haskell.org/haskellwiki/Zipper>.+ --+ -- Notes about efficiency:+ --+ -- The functions defined here provide a useful way to achieve those awkward+ -- operations which may not be covered by the rest of this package. They're+ -- reasonably efficient (mostly O(log n) or better), but zipper flexibility+ -- is bought at the expense of keeping path information explicitly as a heap+ -- data structure rather than implicitly on the stack. Since heap storage+ -- probably costs more, zipper operations will are likely to incur higher+ -- constant factors than equivalent non-zipper operations (if available).+ --+ -- Some of the functions provided here may appear to be weird combinations of+ -- functions from a more logical set of primitives. They are provided because+ -- they are not really simple combinations of the corresponding primitives.+ -- They are more efficient, so you should use them if possible (e.g combining+ -- deleting with Zipper closing).+ --+ -- Also, consider using the t'BAVL' as a cheaper alternative if you don't+ -- need to navigate the tree.++ -- ** Types+ ZAVL,PAVL,++ -- ** Opening+ assertOpenL,assertOpenR,+ tryOpenL,tryOpenR,+ assertOpen,tryOpen,+ tryOpenGE,tryOpenLE,+ openEither,++ -- ** Closing+ close,fillClose,++ -- ** Manipulating the current element.+ getCurrent,putCurrent,applyCurrent,applyCurrent',++ -- ** Moving+ assertMoveL,assertMoveR,tryMoveL,tryMoveR,++ -- ** Inserting elements+ insertL,insertR,insertMoveL,insertMoveR,fill,++ -- ** Deleting elements+ delClose,+ assertDelMoveL,assertDelMoveR,tryDelMoveR,tryDelMoveL,+ delAllL,delAllR,+ delAllCloseL,delAllCloseR,+ delAllIncCloseL,delAllIncCloseR,++ -- ** Inserting AVL trees+ insertTreeL,insertTreeR,++ -- ** Current element status+ isLeftmost,isRightmost,+ sizeL,sizeR,++ -- ** Operations on whole zippers+ sizeZAVL,++ -- ** A cheaper option is to use BAVL+ -- | These are a cheaper but more restrictive alternative to using the full Zipper.+ -- They use \"Binary Paths\" (Ints) to point to a particular element of an 'AVL' tree.+ -- Use these when you don't need to navigate the tree, you just want to look at a+ -- particular element (and perhaps modify or delete it). The advantage of these is+ -- that they don't create the usual Zipper heap structure, so they will be faster+ -- (and reduce heap burn rate too).+ --+ -- If you subsequently decide you need a Zipper rather than a BAVL then some conversion+ -- utilities are provided.++ -- *** Types+ BAVL,++ -- *** Opening and closing+ openBAVL,closeBAVL,++ -- *** Inspecting status+ fullBAVL,emptyBAVL,tryReadBAVL,readFullBAVL,++ -- *** Modifying the tree+ pushBAVL,deleteBAVL,++ -- *** Converting to BAVL to Zipper+ -- | These are O(log n) operations but with low constant factors because no comparisons+ -- are required (and the tree nodes on the path will most likely still be in cache as+ -- a result of opening the BAVL in the first place).+ fullBAVLtoZAVL,emptyBAVLtoPAVL,anyBAVLtoEither,++ -- * Joining AVL trees+ join,concatAVL,flatConcat,++ -- * List related utilities for AVL trees++ -- ** Converting AVL trees to Lists (fixed element order).+ -- | These functions are lazy and allow normal lazy list processing+ -- style to be used (without necessarily converting the entire tree+ -- to a list in one gulp).+ asListL,toListL,asListR,toListR,++ -- ** Converting Lists to AVL trees (fixed element order)+ asTreeLenL,asTreeL,+ asTreeLenR,asTreeR,++ -- ** Converting unsorted Lists to sorted AVL trees+ asTree,++ -- ** \"Pushing\" unsorted Lists in sorted AVL trees+ pushList,++ -- * Some analogues of common List functions+ reverse,map,map',+ mapAccumL ,mapAccumR ,+ mapAccumL' ,mapAccumR' ,+ replicate,+ filter,mapMaybe,+ filterViaList,mapMaybeViaList,+ partition,+ traverseAVL,++ -- ** Folds+ -- | Note that unlike folds over lists ('foldr' and 'foldl'), there is no+ -- significant difference between left and right folds in AVL trees, other+ -- than which side of the tree each starts with.+ -- Therefore this library provides strict and lazy versions of both.+ foldr,foldr',foldr1,foldr1',foldr2,foldr2',+ foldl,foldl',foldl1,foldl1',foldl2,foldl2',++ -- ** (GHC Only)+ mapAccumL'',mapAccumR'', foldrInt#,++ -- * Some clones of common List functions+ -- | These are a cure for the horrible @O(n^2)@ complexity the noddy Data.List definitions.+ nub,nubBy,++ -- * \"Flattening\" AVL trees+ -- | These functions can be improve search times by reducing a tree of given size to+ -- the minimum possible height.+ flatten,+ flatReverse,flatMap,flatMap',++ -- * Splitting AVL trees++ -- ** Taking fixed size lumps of tree+ -- | Bear in mind that the tree size (s) is not stored in the AVL data structure, but if it is+ -- already known for other reasons then for (n > s\/2) using the appropriate complementary+ -- function with argument (s-n) will be faster.+ -- But it's probably not worth invoking 'Data.Tree.AVL.Internals.Types.size' for no reason other than to+ -- exploit this optimisation (because this is O(s) anyway).+ splitAtL,splitAtR,takeL,takeR,dropL,dropR,++ -- ** Rotations+ -- | Bear in mind that the tree size (s) is not stored in the AVL data structure, but if it is+ -- already known for other reasons then for (n > s\/2) using the appropriate complementary+ -- function with argument (s-n) will be faster.+ -- But it's probably not worth invoking 'Data.Tree.AVL.Internals.Types.size' for no reason other than to exploit this optimisation+ -- (because this is O(s) anyway).+ rotateL,rotateR,popRotateL,popRotateR,rotateByL,rotateByR,++ -- ** Taking lumps of tree according to a supplied predicate+ spanL,spanR,takeWhileL,dropWhileL,takeWhileR,dropWhileR,++ -- ** Taking lumps of /sorted/ trees+ -- | Prepare to get confused. All these functions adhere to the same Ordering convention as+ -- is used for searches. That is, if the supplied selector returns LT that means the search+ -- key is less than the current tree element. Or put another way, the current tree element+ -- is greater than the search key.+ --+ -- So (for example) the result of the 'takeLT' function is a tree containing all those elements+ -- which are less than the notional search key. That is, all those elements for which the+ -- supplied selector returns GT (not LT as you might expect). I know that seems backwards, but+ -- it's consistent if you think about it.+ forkL,forkR,fork,+ takeLE,dropGT,+ takeLT,dropGE,+ takeGT,dropLE,+ takeGE,dropLT,++ -- * AVL tree size utilities+ size,addSize,clipSize,+ addSize#,size#,++-- * AVL tree height utilities+ height,addHeight,compareHeight,++ -- * Low level Binary Path utilities+ -- | This is the low level (unsafe) API used by the t'BAVL' type+ BinPath(..),findFullPath,findEmptyPath,openPath,openPathWith,readPath,writePath,insertPath,deletePath,++ -- * Correctness checking+ isBalanced,isSorted,isSortedOK,++ -- * Tree parameter utilities+ minElements,maxElements,+) where++import Prelude ()+import Data.Functor (Functor, fmap)+import Data.Traversable (Traversable, traverse)+import Data.Tree.AVL.Internals.Types hiding (E,N,P,Z)+import Data.Tree.AVL.Utils+import Data.Tree.AVL.Size+import Data.Tree.AVL.Height+import Data.Tree.AVL.Read+import Data.Tree.AVL.Write+import Data.Tree.AVL.Push+import Data.Tree.AVL.Delete+import Data.Tree.AVL.List+import Data.Tree.AVL.Join+import Data.Tree.AVL.Split+import Data.Tree.AVL.Set+import Data.Tree.AVL.Zipper+import Data.Tree.AVL.Test.Utils(isBalanced,isSorted,isSortedOK,minElements,maxElements)+import Data.Tree.AVL.BinPath(BinPath(..),findFullPath,findEmptyPath,openPath,openPathWith,readPath,writePath,insertPath)+import Data.Tree.AVL.Internals.DelUtils(deletePath)++-- This definition has been placed here+-- to avoid introducing cyclic dependency between Types.hs and List.hs+instance Functor AVL where+ fmap = map -- The lazy version.++instance Traversable AVL where+ traverse = traverseAVL
+ src/Data/Tree/AVL/BinPath.hs view
@@ -0,0 +1,353 @@+-- |+-- Copyright : (c) Adrian Hey 2005+-- License : BSD3+--+-- This module provides a cheap but extremely limited and dangerous alternative+-- to using the Zipper. A BinPath provides a way of finding a particular element+-- in an AVL tree again without doing any comparisons. But a BinPath is ONLY VALID+-- IF THE TREE SHAPE DOES NOT CHANGE.+--+-- See the BAVL type in Data.Tree.AVL.Zipper module for a safer wrapper round these+-- functions.+module Data.Tree.AVL.BinPath+ (BinPath(..),findFullPath,findEmptyPath,openPath,openPathWith,readPath,writePath,insertPath,+ -- These are used by deletePath, which currently resides in Data.Tree.AVL.Internals.DelUtils+ sel,goL,goR,+ ) where+-- N.B. The deletePath function should really be here too, but has been put+-- in Data.Tree.AVL.Internals.DelUtils instead because deletion is a tangled web of circular+-- depencency.++import Data.Tree.AVL.Internals.Types(AVL(..))+import Data.COrdering++import GHC.Base+#include "ghcdefs.h"++-- Test path LSB+bit0 :: Int# -> Bool+{-# INLINE bit0 #-}+bit0 p = isTrue# (word2Int# (and# (int2Word# p) (int2Word# 1#)) ==# 1#)++-- | A pseudo comparison.+-- N.B. If the path was bit reversed, this could be a straight comparison?..+sel :: Int# -> Ordering+{-# INLINE sel #-}+sel p = if isTrue# (p ==# 0#) then EQ+ else if bit0 p then LT -- Left if Bit 0 == 1+ else GT -- Right if Bit 0 == 0+++-- | Modify path for entering left subtree+goL :: Int# -> Int#+{-# INLINE goL #-}+goL p = iShiftRL# p 1#++-- | Modify path for entering right subtree+goR :: Int# -> Int#+{-# INLINE goR #-}+goR p = iShiftRL# (p -# 1#) 1#++-- | A BinPath is full if the search succeeded, empty otherwise.+data BinPath a = FullBP {-# UNPACK #-} !UINT a -- Found+ | EmptyBP {-# UNPACK #-} !UINT -- Not Found++{-------------------------------------------------------------------------------------------+ Notes:+--------------------------------------------------------------------------------------------+The Binary paths are based on an indexing scheme that:+ 1- Uniquely identifies each tree node+ 2- Provides a simple algorithm for path generation.+ 3- Provides a simple algorithm to locate a node in the tree, given it's path.++Imagine an infinite Binary Tree, with nodes indexed as follows:++ _____00_____ <- d=1+ / \+ _01_ _02_ <- d=2+ / \ / \+ 03 05 04 06 <- d=4+ / \ / \ / \ / \+ 07 11 09 13 08 12 10 14 <- d=8+ <-------- More Layers ------->++To generate the node index (path) as we move down the tree we..+ 1- Initialise index (i) to 0, and a parameter (d) to 1+ 2- If we've arrived where we want, output i.+ 3- Either Move left: i <- i+d, d <- 2d, goto 2+ or Move right: i <- i+2d, d <- 2d, goto 2++To find a node, given its index (path) i, we..+ 1- If i=0 then stop, we've arrived.+ 2- If i is odd then move left , i <- (i-1)>>1, goto 1 -- (i-1)>>1 = i>>1 if i is odd+ else move right, i <- (i-1)>>1, goto 1 -- (i-1)>>1 = (i>>1)-1 if i is even+Examples:+ i=05: (left ,i<-2):(right,i<-0):(stop)+ i=12: (right,i<-5):(left ,i<-2):(right,i<-0):(stop)++See also: pathTree in Data.Tree.AVL.Test.Utils for recursive implementation of the indexing scheme.+--------------------------------------------------------------------------------------------}++-- | Find the path to a AVL tree element, returns -1 (invalid path) if element not found+--+-- Complexity: O(log n)+findFullPath :: (e -> Ordering) -> AVL e -> UINT+-- ?? What about strictness if UINT is boxed (i.e. non-ghc)?+findFullPath c t = find L(1) L(0) t where+ find _ _ E = L(-1)+ find d i (N l e r) = find' d i l e r+ find d i (Z l e r) = find' d i l e r+ find d i (P l e r) = find' d i l e r+ find' d i l e r = case c e of+ LT -> let d_ = ADDINT(d,d) in find d_ ADDINT(i,d ) l+ EQ -> i+ GT -> let d_ = ADDINT(d,d) in find d_ ADDINT(i,d_) r -- d_ = 2d++-- | Find the path to a non-existant AVL tree element, returns -1 (invalid path) if element is found+--+-- Complexity: O(log n)+findEmptyPath :: (e -> Ordering) -> AVL e -> UINT+-- ?? What about strictness if UINT is boxed (i.e. non-ghc)?+findEmptyPath c t = find L(1) L(0) t where+ find _ i E = i+ find d i (N l e r) = find' d i l e r+ find d i (Z l e r) = find' d i l e r+ find d i (P l e r) = find' d i l e r+ find' d i l e r = case c e of+ LT -> let d_ = ADDINT(d,d) in find d_ ADDINT(i,d ) l+ EQ -> L(-1)+ GT -> let d_ = ADDINT(d,d) in find d_ ADDINT(i,d_) r -- d_ = 2d++-- | Get the BinPath of an element using the supplied selector.+--+-- Complexity: O(log n)+openPath :: (e -> Ordering) -> AVL e -> BinPath e+openPath c t = find L(1) L(0) t where+ find _ i E = EmptyBP i+ find d i (N l e r) = find' d i l e r+ find d i (Z l e r) = find' d i l e r+ find d i (P l e r) = find' d i l e r+ find' d i l e r = case c e of+ LT -> let d_ = ADDINT(d,d) in find d_ ADDINT(i,d ) l+ EQ -> FullBP i e+ GT -> let d_ = ADDINT(d,d) in find d_ ADDINT(i,d_) r -- d_ = 2d++-- | Get the BinPath of an element using the supplied (combining) selector.+--+-- Complexity: O(log n)+openPathWith :: (e -> COrdering a) -> AVL e -> BinPath a+openPathWith c t = find L(1) L(0) t where+ find _ i E = EmptyBP i+ find d i (N l e r) = find' d i l e r+ find d i (Z l e r) = find' d i l e r+ find d i (P l e r) = find' d i l e r+ find' d i l e r = case c e of+ Lt -> let d_ = ADDINT(d,d) in find d_ ADDINT(i,d ) l+ Eq a -> FullBP i a+ Gt -> let d_ = ADDINT(d,d) in find d_ ADDINT(i,d_) r -- d_ = 2d++-- | Overwrite a tree element. Assumes the path bits were extracted from 'FullBP' constructor.+-- Raises an error if the path leads to an empty tree.+--+-- N.B This operation does not change tree shape (no insertion occurs).+--+-- Complexity: O(log n)+writePath :: UINT -> e -> AVL e -> AVL e+writePath i0 e' t = wp i0 t where+ wp L(0) E = error "writePath: Bug0" -- Needed to force strictness in path+ wp L(0) (N l _ r) = N l e' r+ wp L(0) (Z l _ r) = Z l e' r+ wp L(0) (P l _ r) = P l e' r+ wp _ E = error "writePath: Bug1"+ wp i (N l e r) = if bit0 i then let l' = wp (goL i) l in l' `seq` N l' e r+ else let r' = wp (goR i) r in r' `seq` N l e r'+ wp i (Z l e r) = if bit0 i then let l' = wp (goL i) l in l' `seq` Z l' e r+ else let r' = wp (goR i) r in r' `seq` Z l e r'+ wp i (P l e r) = if bit0 i then let l' = wp (goL i) l in l' `seq` P l' e r+ else let r' = wp (goR i) r in r' `seq` P l e r'++-- | Read a tree element. Assumes the path bits were extracted from 'FullBP' constructor.+-- Raises an error if the path leads to an empty tree.+--+-- Complexity: O(log n)+readPath :: UINT -> AVL e -> e+readPath L(0) E = error "readPath: Bug0" -- Needed to force strictness in path+readPath L(0) (N _ e _) = e+readPath L(0) (Z _ e _) = e+readPath L(0) (P _ e _) = e+readPath _ E = error "readPath: Bug1"+readPath i (N l _ r) = readPath_ i l r+readPath i (Z l _ r) = readPath_ i l r+readPath i (P l _ r) = readPath_ i l r+readPath_ :: UINT -> AVL e -> AVL e -> e+readPath_ i l r = if bit0 i then readPath (goL i) l+ else readPath (goR i) r++-- | Inserts a new tree element. Assumes the path bits were extracted from a 'EmptyBP' constructor.+-- This function replaces the first Empty node it encounters with the supplied value, regardless+-- of the current path bits (which are not checked). DO NOT USE THIS FOR REPLACING ELEMENTS ALREADY+-- PRESENT IN THE TREE (use 'writePath' for this).+--+-- Complexity: O(log n)+insertPath :: UINT -> e -> AVL e -> AVL e+insertPath i0 e0 t = put i0 t where+ ----------------------------- LEVEL 0 ---------------------------------+ -- put --+ -----------------------------------------------------------------------+ put _ E = Z E e0 E+ put i (N l e r) = putN i l e r+ put i (Z l e r) = putZ i l e r+ put i (P l e r) = putP i l e r++ ----------------------------- LEVEL 1 ---------------------------------+ -- putN, putZ, putP --+ -----------------------------------------------------------------------+ -- Put in (N l e r), BF=-1 , (never returns P)+ putN i l e r = if bit0 i then putNL i l e r -- put in L subtree+ else putNR i l e r -- put in R subtree++ -- Put in (Z l e r), BF= 0+ putZ i l e r = if bit0 i then putZL i l e r -- put in L subtree+ else putZR i l e r -- put in R subtree++ -- Put in (P l e r), BF=+1 , (never returns N)+ putP i l e r = if bit0 i then putPL i l e r -- put in L subtree+ else putPR i l e r -- put in R subtree++ ----------------------------- LEVEL 2 ---------------------------------+ -- putNL, putZL, putPL --+ -- putNR, putZR, putPR --+ -----------------------------------------------------------------------++ -- (putNL l e r): Put in L subtree of (N l e r), BF=-1 (Never requires rebalancing) , (never returns P)+ {-# INLINE putNL #-}+ putNL _ E e r = Z (Z E e0 E) e r -- L subtree empty, H:0->1, parent BF:-1-> 0+ putNL i (N ll le lr) e r = let l' = putN (goL i) ll le lr -- L subtree BF<>0, H:h->h, parent BF:-1->-1+ in l' `seq` N l' e r+ putNL i (P ll le lr) e r = let l' = putP (goL i) ll le lr -- L subtree BF<>0, H:h->h, parent BF:-1->-1+ in l' `seq` N l' e r+ putNL i (Z ll le lr) e r = let l' = putZ (goL i) ll le lr -- L subtree BF= 0, so need to look for changes+ in case l' of+ E -> error "insertPath: Bug0" -- impossible+ Z _ _ _ -> N l' e r -- L subtree BF:0-> 0, H:h->h , parent BF:-1->-1+ _ -> Z l' e r -- L subtree BF:0->+/-1, H:h->h+1, parent BF:-1-> 0++ -- (putZL l e r): Put in L subtree of (Z l e r), BF= 0 (Never requires rebalancing) , (never returns N)+ {-# INLINE putZL #-}+ putZL _ E e r = P (Z E e0 E) e r -- L subtree H:0->1, parent BF: 0->+1+ putZL i (N ll le lr) e r = let l' = putN (goL i) ll le lr -- L subtree BF<>0, H:h->h, parent BF: 0-> 0+ in l' `seq` Z l' e r+ putZL i (P ll le lr) e r = let l' = putP (goL i) ll le lr -- L subtree BF<>0, H:h->h, parent BF: 0-> 0+ in l' `seq` Z l' e r+ putZL i (Z ll le lr) e r = let l' = putZ (goL i) ll le lr -- L subtree BF= 0, so need to look for changes+ in case l' of+ E -> error "insertPath: Bug1" -- impossible+ Z _ _ _ -> Z l' e r -- L subtree BF: 0-> 0, H:h->h , parent BF: 0-> 0+ _ -> P l' e r -- L subtree BF: 0->+/-1, H:h->h+1, parent BF: 0->+1++ -- (putZR l e r): Put in R subtree of (Z l e r), BF= 0 (Never requires rebalancing) , (never returns P)+ {-# INLINE putZR #-}+ putZR _ l e E = N l e (Z E e0 E) -- R subtree H:0->1, parent BF: 0->-1+ putZR i l e (N rl re rr) = let r' = putN (goR i) rl re rr -- R subtree BF<>0, H:h->h, parent BF: 0-> 0+ in r' `seq` Z l e r'+ putZR i l e (P rl re rr) = let r' = putP (goR i) rl re rr -- R subtree BF<>0, H:h->h, parent BF: 0-> 0+ in r' `seq` Z l e r'+ putZR i l e (Z rl re rr) = let r' = putZ (goR i) rl re rr -- R subtree BF= 0, so need to look for changes+ in case r' of+ E -> error "insertPath: Bug2" -- impossible+ Z _ _ _ -> Z l e r' -- R subtree BF: 0-> 0, H:h->h , parent BF: 0-> 0+ _ -> N l e r' -- R subtree BF: 0->+/-1, H:h->h+1, parent BF: 0->-1++ -- (putPR l e r): Put in R subtree of (P l e r), BF=+1 (Never requires rebalancing) , (never returns N)+ {-# INLINE putPR #-}+ putPR _ l e E = Z l e (Z E e0 E) -- R subtree empty, H:0->1, parent BF:+1-> 0+ putPR i l e (N rl re rr) = let r' = putN (goR i) rl re rr -- R subtree BF<>0, H:h->h, parent BF:+1->+1+ in r' `seq` P l e r'+ putPR i l e (P rl re rr) = let r' = putP (goR i) rl re rr -- R subtree BF<>0, H:h->h, parent BF:+1->+1+ in r' `seq` P l e r'+ putPR i l e (Z rl re rr) = let r' = putZ (goR i) rl re rr -- R subtree BF= 0, so need to look for changes+ in case r' of+ E -> error "insertPath: Bug3" -- impossible+ Z _ _ _ -> P l e r' -- R subtree BF:0-> 0, H:h->h , parent BF:+1->+1+ _ -> Z l e r' -- R subtree BF:0->+/-1, H:h->h+1, parent BF:+1-> 0++ -------- These 2 cases (NR and PL) may need rebalancing if they go to LEVEL 3 ---------++ -- (putNR l e r): Put in R subtree of (N l e r), BF=-1 , (never returns P)+ {-# INLINE putNR #-}+ putNR _ _ _ E = error "insertPath: Bug4" -- impossible if BF=-1+ putNR i l e (N rl re rr) = let r' = putN (goR i) rl re rr -- R subtree BF<>0, H:h->h, parent BF:-1->-1+ in r' `seq` N l e r'+ putNR i l e (P rl re rr) = let r' = putP (goR i) rl re rr -- R subtree BF<>0, H:h->h, parent BF:-1->-1+ in r' `seq` N l e r'+ putNR i l e (Z rl re rr) = let i' = goR i in if bit0 i' then putNRL i' l e rl re rr -- RL (never returns P)+ else putNRR i' l e rl re rr -- RR (never returns P)++ -- (putPL l e r): Put in L subtree of (P l e r), BF=+1 , (never returns N)+ {-# INLINE putPL #-}+ putPL _ E _ _ = error "insertPath: Bug5" -- impossible if BF=+1+ putPL i (N ll le lr) e r = let l' = putN (goL i) ll le lr -- L subtree BF<>0, H:h->h, parent BF:+1->+1+ in l' `seq` P l' e r+ putPL i (P ll le lr) e r = let l' = putP (goL i) ll le lr -- L subtree BF<>0, H:h->h, parent BF:+1->+1+ in l' `seq` P l' e r+ putPL i (Z ll le lr) e r = let i' = goL i in if bit0 i' then putPLL i' ll le lr e r -- LL (never returns N)+ else putPLR i' ll le lr e r -- LR (never returns N)++ ----------------------------- LEVEL 3 ---------------------------------+ -- putNRR, putPLL --+ -- putNRL, putPLR --+ -----------------------------------------------------------------------++ -- (putNRR l e rl re rr): Put in RR subtree of (N l e (Z rl re rr)) , (never returns P)+ {-# INLINE putNRR #-}+ putNRR _ l e rl re E = Z (Z l e rl) re (Z E e0 E) -- l and rl must also be E, special CASE RR!!+ putNRR i l e rl re (N rrl rre rrr) = let rr' = putN (goR i) rrl rre rrr -- RR subtree BF<>0, H:h->h, so no change+ in rr' `seq` N l e (Z rl re rr')+ putNRR i l e rl re (P rrl rre rrr) = let rr' = putP (goR i) rrl rre rrr -- RR subtree BF<>0, H:h->h, so no change+ in rr' `seq` N l e (Z rl re rr')+ putNRR i l e rl re (Z rrl rre rrr) = let rr' = putZ (goR i) rrl rre rrr -- RR subtree BF= 0, so need to look for changes+ in case rr' of+ E -> error "insertPath: Bug6" -- impossible+ Z _ _ _ -> N l e (Z rl re rr') -- RR subtree BF: 0-> 0, H:h->h, so no change+ _ -> Z (Z l e rl) re rr' -- RR subtree BF: 0->+/-1, H:h->h+1, parent BF:-1->-2, CASE RR !!++ -- (putPLL ll le lr e r): Put in LL subtree of (P (Z ll le lr) e r) , (never returns N)+ {-# INLINE putPLL #-}+ putPLL _ E le lr e r = Z (Z E e0 E) le (Z lr e r) -- r and lr must also be E, special CASE LL!!+ putPLL i (N lll lle llr) le lr e r = let ll' = putN (goL i) lll lle llr -- LL subtree BF<>0, H:h->h, so no change+ in ll' `seq` P (Z ll' le lr) e r+ putPLL i (P lll lle llr) le lr e r = let ll' = putP (goL i) lll lle llr -- LL subtree BF<>0, H:h->h, so no change+ in ll' `seq` P (Z ll' le lr) e r+ putPLL i (Z lll lle llr) le lr e r = let ll' = putZ (goL i) lll lle llr -- LL subtree BF= 0, so need to look for changes+ in case ll' of+ E -> error "insertPath: Bug7" -- impossible+ Z _ _ _ -> P (Z ll' le lr) e r -- LL subtree BF: 0-> 0, H:h->h, so no change+ _ -> Z ll' le (Z lr e r) -- LL subtree BF: 0->+/-1, H:h->h+1, parent BF:-1->-2, CASE LL !!++ -- (putNRL l e rl re rr): Put in RL subtree of (N l e (Z rl re rr)) , (never returns P)+ {-# INLINE putNRL #-}+ putNRL _ l e E re rr = Z (Z l e E) e0 (Z E re rr) -- l and rr must also be E, special CASE LR !!+ putNRL i l e (N rll rle rlr) re rr = let rl' = putN (goL i) rll rle rlr -- RL subtree BF<>0, H:h->h, so no change+ in rl' `seq` N l e (Z rl' re rr)+ putNRL i l e (P rll rle rlr) re rr = let rl' = putP (goL i) rll rle rlr -- RL subtree BF<>0, H:h->h, so no change+ in rl' `seq` N l e (Z rl' re rr)+ putNRL i l e (Z rll rle rlr) re rr = let rl' = putZ (goL i) rll rle rlr -- RL subtree BF= 0, so need to look for changes+ in case rl' of+ E -> error "insertPath: Bug8" -- impossible+ Z _ _ _ -> N l e (Z rl' re rr) -- RL subtree BF: 0-> 0, H:h->h, so no change+ N rll' rle' rlr' -> Z (P l e rll') rle' (Z rlr' re rr) -- RL subtree BF: 0->-1, SO.. CASE RL(1) !!+ P rll' rle' rlr' -> Z (Z l e rll') rle' (N rlr' re rr) -- RL subtree BF: 0->+1, SO.. CASE RL(2) !!++ -- (putPLR ll le lr e r): Put in LR subtree of (P (Z ll le lr) e r) , (never returns N)+ {-# INLINE putPLR #-}+ putPLR _ ll le E e r = Z (Z ll le E) e0 (Z E e r) -- r and ll must also be E, special CASE LR !!+ putPLR i ll le (N lrl lre lrr) e r = let lr' = putN (goR i) lrl lre lrr -- LR subtree BF<>0, H:h->h, so no change+ in lr' `seq` P (Z ll le lr') e r+ putPLR i ll le (P lrl lre lrr) e r = let lr' = putP (goR i) lrl lre lrr -- LR subtree BF<>0, H:h->h, so no change+ in lr' `seq` P (Z ll le lr') e r+ putPLR i ll le (Z lrl lre lrr) e r = let lr' = putZ (goR i) lrl lre lrr -- LR subtree BF= 0, so need to look for changes+ in case lr' of+ E -> error "insertPath: Bug9" -- impossible+ Z _ _ _ -> P (Z ll le lr') e r -- LR subtree BF: 0-> 0, H:h->h, so no change+ N lrl' lre' lrr' -> Z (P ll le lrl') lre' (Z lrr' e r) -- LR subtree BF: 0->-1, SO.. CASE LR(2) !!+ P lrl' lre' lrr' -> Z (Z ll le lrl') lre' (N lrr' e r) -- LR subtree BF: 0->+1, SO.. CASE LR(1) !!
+ src/Data/Tree/AVL/Delete.hs view
@@ -0,0 +1,514 @@+-- |+-- Copyright : (c) Adrian Hey 2004,2005+-- License : BSD3+--+{-# OPTIONS_HADDOCK hide #-}+module Data.Tree.AVL.Delete+(-- * Deleting elements from AVL trees++ -- ** Deleting from extreme left or right+ delL,delR,assertDelL,assertDelR,tryDelL,tryDelR,++ -- ** Deleting from /sorted/ trees+ delete,deleteFast,deleteIf,deleteMaybe,++ -- * \"Popping\" elements from AVL trees+ -- | \"Popping\" means reading and deleting a tree element in a single operation.++ -- ** Popping from extreme left or right+ assertPopL,assertPopR,tryPopL,tryPopR,++ -- ** Popping from /sorted/ trees+ assertPop,tryPop,assertPopMaybe,tryPopMaybe,assertPopIf,tryPopIf,+) where++import Data.COrdering+import Data.Tree.AVL.Internals.Types(AVL(..))+import Data.Tree.AVL.BinPath(BinPath(..),findFullPath,openPathWith,writePath)++import Data.Tree.AVL.Internals.DelUtils+ (-- Deleting Utilities+ delRN,delRZ,delRP,delLN,delLZ,delLP,+ -- Popping Utilities.+ popRN,popRZ,popRP,popLN,popLZ,popLP,+ -- Balancing Utilities+ chkLN,chkLZ,chkLP,chkRN,chkRZ,chkRP,+ chkLN',chkLZ',chkLP',chkRN',chkRZ',chkRP',+ -- Node substitution utilities.+ subN,subZR,subZL,subP,+ -- BinPath related+ deletePath+ )++#include "ghcdefs.h"++-- | Delete the left-most element of an AVL tree. If the tree is sorted this will be the+-- least element. This function returns an empty tree if it's argument is an empty tree.+--+-- Complexity: O(log n)+delL :: AVL e -> AVL e+delL E = E+delL (N l e r) = delLN l e r+delL (Z l e r) = delLZ l e r+delL (P l e r) = delLP l e r++-- | Delete the left-most element of a /non-empty/ AVL tree. If the tree is sorted this will be the+-- least element. This function raises an error if it's argument is an empty tree.+--+-- Complexity: O(log n)+assertDelL :: AVL e -> AVL e+assertDelL E = error "assertDelL: Empty tree."+assertDelL (N l e r) = delLN l e r+assertDelL (Z l e r) = delLZ l e r+assertDelL (P l e r) = delLP l e r++-- | Try to delete the left-most element of a /non-empty/ AVL tree. If the tree is sorted this will be the+-- least element. This function returns 'Nothing' if it's argument is an empty tree.+--+-- Complexity: O(log n)+tryDelL :: AVL e -> Maybe (AVL e)+tryDelL E = Nothing+tryDelL (N l e r) = Just $! delLN l e r+tryDelL (Z l e r) = Just $! delLZ l e r+tryDelL (P l e r) = Just $! delLP l e r++-- | Delete the right-most element of an AVL tree. If the tree is sorted this will be the+-- greatest element. This function returns an empty tree if it's argument is an empty tree.+--+-- Complexity: O(log n)+delR :: AVL e -> AVL e+delR E = E+delR (N l e r) = delRN l e r+delR (Z l e r) = delRZ l e r+delR (P l e r) = delRP l e r++-- | Delete the right-most element of a /non-empty/ AVL tree. If the tree is sorted this will be the+-- greatest element. This function raises an error if it's argument is an empty tree.+--+-- Complexity: O(log n)+assertDelR :: AVL e -> AVL e+assertDelR E = error "assertDelR: Empty tree."+assertDelR (N l e r) = delRN l e r+assertDelR (Z l e r) = delRZ l e r+assertDelR (P l e r) = delRP l e r++-- | Try to delete the right-most element of a /non-empty/ AVL tree. If the tree is sorted this will be the+-- greatest element. This function returns 'Nothing' if it's argument is an empty tree.+--+-- Complexity: O(log n)+tryDelR :: AVL e -> Maybe (AVL e)+tryDelR E = Nothing+tryDelR (N l e r) = Just $! delRN l e r+tryDelR (Z l e r) = Just $! delRZ l e r+tryDelR (P l e r) = Just $! delRP l e r++-- | Pop the left-most element from a non-empty AVL tree, returning the popped element and the+-- modified AVL tree. If the tree is sorted this will be the least element.+-- This function raises an error if it's argument is an empty tree.+--+-- Complexity: O(log n)+assertPopL :: AVL e -> (e,AVL e)+assertPopL E = error "assertPopL: Empty tree."+assertPopL (N l e r) = case popLN l e r of UBT2(v,t) -> (v,t)+assertPopL (Z l e r) = case popLZ l e r of UBT2(v,t) -> (v,t)+assertPopL (P l e r) = case popLP l e r of UBT2(v,t) -> (v,t)++-- | Same as 'assertPopL', except this version returns 'Nothing' if it's argument is an empty tree.+--+-- Complexity: O(log n)+tryPopL :: AVL e -> Maybe (e,AVL e)+tryPopL E = Nothing+tryPopL (N l e r) = Just $! case popLN l e r of UBT2(v,t) -> (v,t)+tryPopL (Z l e r) = Just $! case popLZ l e r of UBT2(v,t) -> (v,t)+tryPopL (P l e r) = Just $! case popLP l e r of UBT2(v,t) -> (v,t)+++-- | Pop the right-most element from a non-empty AVL tree, returning the popped element and the+-- modified AVL tree. If the tree is sorted this will be the greatest element.+-- This function raises an error if it's argument is an empty tree.+--+-- Complexity: O(log n)+assertPopR :: AVL e -> (AVL e,e)+assertPopR E = error "assertPopR: Empty tree."+assertPopR (N l e r) = case popRN l e r of UBT2(t,v) -> (t,v)+assertPopR (Z l e r) = case popRZ l e r of UBT2(t,v) -> (t,v)+assertPopR (P l e r) = case popRP l e r of UBT2(t,v) -> (t,v)++-- | Same as 'assertPopR', except this version returns 'Nothing' if it's argument is an empty tree.+--+-- Complexity: O(log n)+tryPopR :: AVL e -> Maybe (AVL e,e)+tryPopR E = Nothing+tryPopR (N l e r) = Just $! case popRN l e r of UBT2(t,v) -> (t,v)+tryPopR (Z l e r) = Just $! case popRZ l e r of UBT2(t,v) -> (t,v)+tryPopR (P l e r) = Just $! case popRP l e r of UBT2(t,v) -> (t,v)++-- | General purpose function for deletion of elements from a sorted AVL tree.+-- If a matching element is not found then this function returns the original tree.+--+-- Complexity: O(log n)+delete :: (e -> Ordering) -> AVL e -> AVL e+delete c t = case findFullPath c t of+ L(-1) -> t -- Not found, p<0+ p -> deletePath p t -- Found, so delete++-- | This version only deletes the element if the supplied selector returns @('Data.COrdering.Eq' 'True')@.+-- If it returns @('Data.COrdering.Eq' 'False')@ or if no matching element is found then this function returns+-- the original tree.+--+-- Complexity: O(log n)+deleteIf :: (e -> COrdering Bool) -> AVL e -> AVL e+deleteIf c t = case openPathWith c t of+ FullBP p True -> deletePath p t+ _ -> t++-- | This version only deletes the element if the supplied selector returns @('Data.COrdering.Eq' 'Nothing')@.+-- If it returns @('Data.COrdering.Eq' ('Just' e))@ then the matching element is replaced by e.+-- If no matching element is found then this function returns the original tree.+--+-- Complexity: O(log n)+deleteMaybe :: (e -> COrdering (Maybe e)) -> AVL e -> AVL e+deleteMaybe c t = case openPathWith c t of+ FullBP p Nothing -> deletePath p t+ FullBP p (Just e) -> writePath p e t+ _ -> t++-- | Functionally identical to 'delete', but returns an identical tree (one with all the nodes on+-- the path duplicated) if the search fails. This should probably only be used if you know the+-- search will succeed.+--+-- Complexity: O(log n)+deleteFast :: (e -> Ordering) -> AVL e -> AVL e+-- This was the old delete so it's been tested OK, but as a different name.+deleteFast c = delete' where+ delete' E = E+ delete' (N l e r) = delN l e r+ delete' (Z l e r) = delZ l e r+ delete' (P l e r) = delP l e r++ ----------------------------- LEVEL 1 ---------------------------------+ -- delN, delZ, delP --+ -----------------------------------------------------------------------++ -- Delete from (N l e r)+ delN l e r = case c e of+ LT -> delNL l e r+ EQ -> subN l r+ GT -> delNR l e r++ -- Delete from (Z l e r)+ delZ l e r = case c e of+ LT -> delZL l e r+ EQ -> subZR l r+ GT -> delZR l e r++ -- Delete from (P l e r)+ delP l e r = case c e of+ LT -> delPL l e r+ EQ -> subP l r+ GT -> delPR l e r++ ----------------------------- LEVEL 2 ---------------------------------+ -- delNL, delZL, delPL --+ -- delNR, delZR, delPR --+ -----------------------------------------------------------------------++ -- Delete from the left subtree of (N l e r)+ delNL E e r = N E e r -- Left sub-tree is empty+ delNL (N ll le lr) e r = case c le of+ LT -> chkLN (delNL ll le lr) e r+ EQ -> chkLN (subN ll lr) e r+ GT -> chkLN (delNR ll le lr) e r+ delNL (Z ll le lr) e r = case c le of+ LT -> let l' = delZL ll le lr in l' `seq` N l' e r -- height can't change+ EQ -> chkLN' (subZR ll lr) e r -- << But it can here+ GT -> let l' = delZR ll le lr in l' `seq` N l' e r -- height can't change+ delNL (P ll le lr) e r = case c le of+ LT -> chkLN (delPL ll le lr) e r+ EQ -> chkLN (subP ll lr) e r+ GT -> chkLN (delPR ll le lr) e r++ -- Delete from the right subtree of (N l e r)+ delNR _ _ E = error "delNR: Bug0" -- Impossible+ delNR l e (N rl re rr) = case c re of+ LT -> chkRN l e (delNL rl re rr)+ EQ -> chkRN l e (subN rl rr)+ GT -> chkRN l e (delNR rl re rr)+ delNR l e (Z rl re rr) = case c re of+ LT -> let r' = delZL rl re rr in r' `seq` N l e r' -- height can't change+ EQ -> chkRN' l e (subZL rl rr) -- << But it can here+ GT -> let r' = delZR rl re rr in r' `seq` N l e r' -- height can't change+ delNR l e (P rl re rr) = case c re of+ LT -> chkRN l e (delPL rl re rr)+ EQ -> chkRN l e (subP rl rr)+ GT -> chkRN l e (delPR rl re rr)++ -- Delete from the left subtree of (Z l e r)+ delZL E e r = Z E e r -- Left sub-tree is empty+ delZL (N ll le lr) e r = case c le of+ LT -> chkLZ (delNL ll le lr) e r+ EQ -> chkLZ (subN ll lr) e r+ GT -> chkLZ (delNR ll le lr) e r+ delZL (Z ll le lr) e r = case c le of+ LT -> let l' = delZL ll le lr in l' `seq` Z l' e r -- height can't change+ EQ -> chkLZ' (subZR ll lr) e r -- << But it can here+ GT -> let l' = delZR ll le lr in l' `seq` Z l' e r -- height can't change+ delZL (P ll le lr) e r = case c le of+ LT -> chkLZ (delPL ll le lr) e r+ EQ -> chkLZ (subP ll lr) e r+ GT -> chkLZ (delPR ll le lr) e r++ -- Delete from the right subtree of (Z l e r)+ delZR l e E = Z l e E -- Right sub-tree is empty+ delZR l e (N rl re rr) = case c re of+ LT -> chkRZ l e (delNL rl re rr)+ EQ -> chkRZ l e (subN rl rr)+ GT -> chkRZ l e (delNR rl re rr)+ delZR l e (Z rl re rr) = case c re of+ LT -> let r' = delZL rl re rr in r' `seq` Z l e r' -- height can't change+ EQ -> chkRZ' l e (subZL rl rr) -- << But it can here+ GT -> let r' = delZR rl re rr in r' `seq` Z l e r' -- height can't change+ delZR l e (P rl re rr) = case c re of+ LT -> chkRZ l e (delPL rl re rr)+ EQ -> chkRZ l e (subP rl rr)+ GT -> chkRZ l e (delPR rl re rr)++ -- Delete from the left subtree of (P l e r)+ delPL E _ _ = error "delPL: Bug0" -- Impossible+ delPL (N ll le lr) e r = case c le of+ LT -> chkLP (delNL ll le lr) e r+ EQ -> chkLP (subN ll lr) e r+ GT -> chkLP (delNR ll le lr) e r+ delPL (Z ll le lr) e r = case c le of+ LT -> let l' = delZL ll le lr in l' `seq` P l' e r -- height can't change+ EQ -> chkLP' (subZR ll lr) e r -- << But it can here+ GT -> let l' = delZR ll le lr in l' `seq` P l' e r -- height can't change+ delPL (P ll le lr) e r = case c le of+ LT -> chkLP (delPL ll le lr) e r+ EQ -> chkLP (subP ll lr) e r+ GT -> chkLP (delPR ll le lr) e r++ -- Delete from the right subtree of (P l e r)+ delPR l e E = P l e E -- Right sub-tree is empty+ delPR l e (N rl re rr) = case c re of+ LT -> chkRP l e (delNL rl re rr)+ EQ -> chkRP l e (subN rl rr)+ GT -> chkRP l e (delNR rl re rr)+ delPR l e (Z rl re rr) = case c re of+ LT -> let r' = delZL rl re rr in r' `seq` P l e r' -- height can't change+ EQ -> chkRP' l e (subZL rl rr) -- << But it can here+ GT -> let r' = delZR rl re rr in r' `seq` P l e r' -- height can't change+ delPR l e (P rl re rr) = case c re of+ LT -> chkRP l e (delPL rl re rr)+ EQ -> chkRP l e (subP rl rr)+ GT -> chkRP l e (delPR rl re rr)++-- | General purpose function for popping elements from a sorted AVL tree.+-- An error is raised if a matching element is not found. The pair returned+-- by this function consists of the popped value and the modified tree.+--+-- Complexity: O(log n)+assertPop :: (e -> COrdering a) -> AVL e -> (a,AVL e)+assertPop c = genPop_ where+ genPop_ E = error "assertPop: element not found."+ genPop_ (N l e r) = case popN l e r of UBT2(v,t) -> (v,t)+ genPop_ (Z l e r) = case popZ l e r of UBT2(v,t) -> (v,t)+ genPop_ (P l e r) = case popP l e r of UBT2(v,t) -> (v,t)++ ----------------------------- LEVEL 1 ---------------------------------+ -- popN, popZ, popP --+ -----------------------------------------------------------------------++ -- Pop from (N l e r)+ popN l e r = case c e of+ Lt -> popNL l e r+ Eq a -> let t = subN l r in t `seq` UBT2(a,t)+ Gt -> popNR l e r++ -- Pop from (Z l e r)+ popZ l e r = case c e of+ Lt -> popZL l e r+ Eq a -> let t = subZR l r in t `seq` UBT2(a,t)+ Gt -> popZR l e r++ -- Pop from (P l e r)+ popP l e r = case c e of+ Lt -> popPL l e r+ Eq a -> let t = subP l r in t `seq` UBT2(a,t)+ Gt -> popPR l e r++ ----------------------------- LEVEL 2 ---------------------------------+ -- popNL, popZL, popPL --+ -- popNR, popZR, popPR --+ -----------------------------------------------------------------------++ -- Pop from the left subtree of (N l e r)+ popNL E _ _ = error "assertPop: element not found." -- Left sub-tree is empty+ popNL (N ll le lr) e r = case c le of+ Lt -> case popNL ll le lr of+ UBT2(a,l_) -> let t = chkLN l_ e r in t `seq` UBT2(a,t)+ Eq a -> let t = chkLN (subN ll lr) e r in t `seq` UBT2(a,t)+ Gt -> case popNR ll le lr of+ UBT2(a,l_) -> let t = chkLN l_ e r in t `seq` UBT2(a,t)+ popNL (Z ll le lr) e r = case c le of+ Lt -> case popZL ll le lr of UBT2(a,l_) -> UBT2(a, N l_ e r)+ Eq a -> let t = chkLN' (subZR ll lr) e r+ in t `seq` UBT2(a,t)+ Gt -> case popZR ll le lr of UBT2(a,l_) -> UBT2(a, N l_ e r)+ popNL (P ll le lr) e r = case c le of+ Lt -> case popPL ll le lr of+ UBT2(a,l_) -> let t = chkLN l_ e r in t `seq` UBT2(a,t)+ Eq a -> let t = chkLN (subP ll lr) e r in t `seq` UBT2(a,t)+ Gt -> case popPR ll le lr of+ UBT2(a,l_) -> let t = chkLN l_ e r in t `seq` UBT2(a,t)++ -- Pop from the right subtree of (N l e r)+ popNR _ _ E = error "genPop.popNR: Bug!" -- Impossible+ popNR l e (N rl re rr) = case c re of+ Lt -> case popNL rl re rr of+ UBT2(a,r_) -> let t = chkRN l e r_ in t `seq` UBT2(a,t)+ Eq a -> let t = chkRN l e (subN rl rr) in t `seq` UBT2(a,t)+ Gt -> case popNR rl re rr of+ UBT2(a,r_) -> let t = chkRN l e r_ in t `seq` UBT2(a,t)+ popNR l e (Z rl re rr) = case c re of+ Lt -> case popZL rl re rr of UBT2(a,r_) -> UBT2(a, N l e r_)+ Eq a -> let t = chkRN' l e (subZL rl rr)+ in t `seq` UBT2(a,t)+ Gt -> case popZR rl re rr of UBT2(a,r_) -> UBT2(a, N l e r_)+ popNR l e (P rl re rr) = case c re of+ Lt -> case popPL rl re rr of+ UBT2(a,r_) -> let t = chkRN l e r_ in t `seq` UBT2(a,t)+ Eq a -> let t = chkRN l e (subP rl rr) in t `seq` UBT2(a,t)+ Gt -> case popPR rl re rr of+ UBT2(a,r_) -> let t = chkRN l e r_ in t `seq` UBT2(a,t)++ -- Pop from the left subtree of (Z l e r)+ popZL E _ _ = error "assertPop: element not found." -- Left sub-tree is empty+ popZL (N ll le lr) e r = case c le of+ Lt -> case popNL ll le lr of+ UBT2(a,l_) -> let t = chkLZ l_ e r in t `seq` UBT2(a,t)+ Eq a -> let t = chkLZ (subN ll lr) e r in t `seq` UBT2(a,t)+ Gt -> case popNR ll le lr of+ UBT2(a,l_) -> let t = chkLZ l_ e r in t `seq` UBT2(a,t)+ popZL (Z ll le lr) e r = case c le of+ Lt -> case popZL ll le lr of UBT2(a,l_) -> UBT2(a, Z l_ e r)+ Eq a -> let t = chkLZ' (subZR ll lr) e r+ in t `seq` UBT2(a,t)+ Gt -> case popZR ll le lr of UBT2(a,l_) -> UBT2(a, Z l_ e r)+ popZL (P ll le lr) e r = case c le of+ Lt -> case popPL ll le lr of+ UBT2(a,l_) -> let t = chkLZ l_ e r in t `seq` UBT2(a,t)+ Eq a -> let t = chkLZ (subP ll lr) e r in t `seq` UBT2(a,t)+ Gt -> case popPR ll le lr of+ UBT2(a,l_) -> let t = chkLZ l_ e r in t `seq` UBT2(a,t)++ -- Pop from the right subtree of (Z l e r)+ popZR _ _ E = error "assertPop: element not found." -- Right sub-tree is empty+ popZR l e (N rl re rr) = case c re of+ Lt -> case popNL rl re rr of+ UBT2(a,r_) -> let t = chkRZ l e r_ in t `seq` UBT2(a,t)+ Eq a -> let t = chkRZ l e (subN rl rr) in t `seq` UBT2(a,t)+ Gt -> case popNR rl re rr of+ UBT2(a,r_) -> let t = chkRZ l e r_ in t `seq` UBT2(a,t)+ popZR l e (Z rl re rr) = case c re of+ Lt -> case popZL rl re rr of UBT2(a,r_) -> UBT2(a, Z l e r_)+ Eq a -> let t = chkRZ' l e (subZL rl rr)+ in t `seq` UBT2(a,t)+ Gt -> case popZR rl re rr of UBT2(a,r_) -> UBT2(a, Z l e r_)+ popZR l e (P rl re rr) = case c re of+ Lt -> case popPL rl re rr of+ UBT2(a,r_) -> let t = chkRZ l e r_ in t `seq` UBT2(a,t)+ Eq a -> let t = chkRZ l e (subP rl rr) in t `seq` UBT2(a,t)+ Gt -> case popPR rl re rr of+ UBT2(a,r_) -> let t = chkRZ l e r_ in t `seq` UBT2(a,t)++ -- Pop from the left subtree of (P l e r)+ popPL E _ _ = error "genPop.popPL: Bug!" -- Impossible+ popPL (N ll le lr) e r = case c le of+ Lt -> case popNL ll le lr of+ UBT2(a,l_) -> let t = chkLP l_ e r in t `seq` UBT2(a,t)+ Eq a -> let t = chkLP (subN ll lr) e r in t `seq` UBT2(a,t)+ Gt -> case popNR ll le lr of+ UBT2(a,l_) -> let t = chkLP l_ e r in t `seq` UBT2(a,t)+ popPL (Z ll le lr) e r = case c le of+ Lt -> case popZL ll le lr of UBT2(a,l_) -> UBT2(a, P l_ e r)+ Eq a -> let t = chkLP' (subZR ll lr) e r+ in t `seq` UBT2(a,t)+ Gt -> case popZR ll le lr of UBT2(a,l_) -> UBT2(a, P l_ e r)+ popPL (P ll le lr) e r = case c le of+ Lt -> case popPL ll le lr of+ UBT2(a,l_) -> let t = chkLP l_ e r in t `seq` UBT2(a,t)+ Eq a -> let t = chkLP (subP ll lr) e r in t `seq` UBT2(a,t)+ Gt -> case popPR ll le lr of+ UBT2(a,l_) -> let t = chkLP l_ e r in t `seq` UBT2(a,t)++ -- Pop from the right subtree of (P l e r)+ popPR _ _ E = error "assertPop: element not found." -- Right sub-tree is empty+ popPR l e (N rl re rr) = case c re of+ Lt -> case popNL rl re rr of+ UBT2(a,r_) -> let t = chkRP l e r_ in t `seq` UBT2(a,t)+ Eq a -> let t = chkRP l e (subN rl rr) in t `seq` UBT2(a,t)+ Gt -> case popNR rl re rr of+ UBT2(a,r_) -> let t = chkRP l e r_ in t `seq` UBT2(a,t)+ popPR l e (Z rl re rr) = case c re of+ Lt -> case popZL rl re rr of UBT2(a,r_) -> UBT2(a, P l e r_)+ Eq a -> let t = chkRP' l e (subZL rl rr)+ in t `seq` UBT2(a,t)+ Gt -> case popZR rl re rr of UBT2(a,r_) -> UBT2(a, P l e r_)+ popPR l e (P rl re rr) = case c re of+ Lt -> case popPL rl re rr of+ UBT2(a,r_) -> let t = chkRP l e r_ in t `seq` UBT2(a,t)+ Eq a -> let t = chkRP l e (subP rl rr) in t `seq` UBT2(a,t)+ Gt -> case popPR rl re rr of+ UBT2(a,r_) -> let t = chkRP l e r_ in t `seq` UBT2(a,t)++-- | Similar to 'assertPop', but this function returns 'Nothing' if the search fails.+--+-- Complexity: O(log n)+tryPop :: (e -> COrdering a) -> AVL e -> Maybe (a,AVL e)+tryPop c t = case openPathWith c t of+ FullBP pth a -> let t' = deletePath pth t in t' `seq` Just (a,t')+ _ -> Nothing++-- | In this case the selector returns two values if a search succeeds.+-- If the second is @('Just' e)@ then the new value (@e@) is substituted in the same place in the tree.+-- If the second is 'Nothing' then the corresponding tree element is deleted.+-- This function raises an error if the search fails.+--+-- Complexity: O(log n)+assertPopMaybe :: (e -> COrdering (a,Maybe e)) -> AVL e -> (a,AVL e)+assertPopMaybe c t = case openPathWith c t of+ FullBP pth (a,Just e ) -> let t' = writePath pth e t in t' `seq` (a,t')+ FullBP pth (a,Nothing) -> let t' = deletePath pth t in t' `seq` (a,t')+ _ -> error "assertPopMaybe: element not found."++-- | Similar to 'assertPopMaybe', but returns 'Nothing' if the search fails.+--+-- Complexity: O(log n)+tryPopMaybe :: (e -> COrdering (a,Maybe e)) -> AVL e -> Maybe (a,AVL e)+tryPopMaybe c t = case openPathWith c t of+ FullBP pth (a,Just e ) -> let t' = writePath pth e t in t' `seq` Just (a,t')+ FullBP pth (a,Nothing) -> let t' = deletePath pth t in t' `seq` Just (a,t')+ _ -> Nothing+++-- | A simpler version of 'assertPopMaybe'. The corresponding element is deleted if the second value+-- returned by the selector is 'True'. If it\'s 'False', the original tree is returned.+-- This function raises an error if the search fails.+--+-- Complexity: O(log n)+assertPopIf :: (e -> COrdering (a,Bool)) -> AVL e -> (a,AVL e)+assertPopIf c t = case openPathWith c t of+ FullBP _ (a,False) -> (a,t)+ FullBP pth (a,True ) -> let t' = deletePath pth t in t' `seq` (a,t')+ _ -> error "assertPopIf: element not found."++-- | Similar to 'assertPopIf', but returns 'Nothing' if the search fails.+--+-- Complexity: O(log n)+tryPopIf :: (e -> COrdering (a,Bool)) -> AVL e -> Maybe (a,AVL e)+tryPopIf c t = case openPathWith c t of+ FullBP _ (a,False) -> Just (a,t)+ FullBP pth (a,True ) -> let t' = deletePath pth t in t' `seq` Just (a,t')+ _ -> Nothing+
+ src/Data/Tree/AVL/Height.hs view
@@ -0,0 +1,84 @@+-- |+-- Copyright : (c) Adrian Hey 2004,2005+-- License : BSD3+--+-- AVL tree height related utilities.+--+-- The functions defined here are not exported by the main Data.Tree.AVL module+-- because they violate the policy for AVL tree equality used elsewhere in this library.+-- You need to import this module explicitly if you want to use any of these functions.+{-# OPTIONS_HADDOCK hide #-}+module Data.Tree.AVL.Height+ (-- * AVL tree height utilities.+ height,addHeight,compareHeight,+ ) where++import Data.Tree.AVL.Internals.Types(AVL(..))++import GHC.Base+#include "ghcdefs.h"++-- | Determine the height of an AVL tree.+--+-- Complexity: O(log n)+{-# INLINE height #-}+height :: AVL e -> UINT+height t = addHeight L(0) t++-- | Adds the height of a tree to the first argument.+--+-- Complexity: O(log n)+addHeight :: UINT -> AVL e -> UINT+addHeight h E = h+addHeight h (N l _ _) = addHeight INCINT2(h) l+addHeight h (Z l _ _) = addHeight INCINT1(h) l+addHeight h (P _ _ r) = addHeight INCINT2(h) r++-- | A fast algorithm for comparing the heights of two trees. This algorithm avoids the need+-- to compute the heights of both trees and should offer better performance if the trees differ+-- significantly in height. But if you need the heights anyway it will be quicker to just evaluate+-- them both and compare the results.+--+-- Complexity: O(log n), where n is the size of the smaller of the two trees.+compareHeight :: AVL a -> AVL b -> Ordering+compareHeight = ch L(0) where -- d = hA-hB+ ch :: UINT -> AVL a -> AVL b -> Ordering+ ch d E E = COMPAREUINT d L(0)+ ch d E (N l1 _ _ ) = chA DECINT2(d) l1+ ch d E (Z l1 _ _ ) = chA DECINT1(d) l1+ ch d E (P _ _ r1) = chA DECINT2(d) r1+ ch d (N l0 _ _ ) E = chB INCINT2(d) l0+ ch d (N l0 _ _ ) (N l1 _ _ ) = ch d l0 l1+ ch d (N l0 _ _ ) (Z l1 _ _ ) = ch INCINT1(d) l0 l1+ ch d (N l0 _ _ ) (P _ _ r1) = ch d l0 r1+ ch d (Z l0 _ _ ) E = chB INCINT1(d) l0+ ch d (Z l0 _ _ ) (N l1 _ _ ) = ch DECINT1(d) l0 l1+ ch d (Z l0 _ _ ) (Z l1 _ _ ) = ch d l0 l1+ ch d (Z l0 _ _ ) (P _ _ r1) = ch DECINT1(d) l0 r1+ ch d (P _ _ r0) E = chB INCINT2(d) r0+ ch d (P _ _ r0) (N l1 _ _ ) = ch d r0 l1+ ch d (P _ _ r0) (Z l1 _ _ ) = ch INCINT1(d) r0 l1+ ch d (P _ _ r0) (P _ _ r1) = ch d r0 r1+ -- Tree A ended first, continue with Tree B until hA-hB<0, or Tree B ends+ chA d tB = case COMPAREUINT d L(0) of+ LT -> LT+ EQ -> case tB of+ E -> EQ+ _ -> LT+ GT -> case tB of+ E -> GT+ N l _ _ -> chA DECINT2(d) l+ Z l _ _ -> chA DECINT1(d) l+ P _ _ r -> chA DECINT2(d) r+ -- Tree B ended first, continue with Tree A until hA-hB>0, or Tree A ends+ chB d tA = case COMPAREUINT d L(0) of+ GT -> GT+ EQ -> case tA of+ E -> EQ+ _ -> GT+ LT -> case tA of+ E -> LT+ N l _ _ -> chB INCINT2(d) l+ Z l _ _ -> chB INCINT1(d) l+ P _ _ r -> chB INCINT2(d) r+
+ src/Data/Tree/AVL/Internals/DelUtils.hs view
@@ -0,0 +1,731 @@+-- |+-- Copyright : (c) Adrian Hey 2004,2005+-- License : BSD3+--+-- This module defines utility functions for deleting elements from AVL trees.+module Data.Tree.AVL.Internals.DelUtils+ (-- * Deleting utilities.+ delRN,delRZ,delRP,delLN,delLZ,delLP,++ -- * Popping utilities.+ popRN,popRZ,popRP,popLN,popLZ,popLP,+ popHL,popHLN,popHLZ,popHLP,++ -- * Balancing utilities.+ chkLN,chkLZ,chkLP,chkRN,chkRZ,chkRP,+ chkLN',chkLZ',chkLP',chkRN',chkRZ',chkRP',++ -- * Node substitution utilities.+ subN,subZR,subZL,subP,++ -- * BinPath related.+ deletePath,+ ) where++import Data.Tree.AVL.Internals.Types(AVL(..))+import Data.Tree.AVL.BinPath(sel,goL,goR)++import GHC.Base+#include "ghcdefs.h"++{------------------------------------------------------------------------------------------------------------------------------+ -------------------------------------- Notes about Deletion and Rebalancing -------------------------------------------------+ ------------------------------------------------------------------------------------------------------------------------------+If you go through a similar analysis to that indicated in the Push.hs module (which I haven't illustrated+here with ASCII art) it can be seen that (as with insertion) the height change in a tree which occurs+as a result of deletion of a node can be infered from the change in BF, (whether or not a re-balancing+rotation was required). The rules are:+ BF +/-1 -> 0, height decreased by 1+ BF 0 -> +/-1, height unchanged.+ BF unchanged , height unchanged.+ BF +/-1 -> -/+1, height unchanged.++Unlike insertion, rebalancing on deletion requires pattern matching on nodes which aren't on the+current path, hence the existance of separate rebalancing functions (rebalN and rebalP).+-}++-------------------------- delL LEVEL 1 -------------------------------+-- delLN, delLZ, delLP --+-----------------------------------------------------------------------+-- | Delete leftmost from (N l e r)+delLN :: AVL e -> e -> AVL e -> AVL e+delLN E _ r = r -- Terminal case, r must be of form (Z E re E)+delLN (N ll le lr) e r = chkLN (delLN ll le lr) e r+delLN (Z ll le lr) e r = delLNZ ll le lr e r+delLN (P ll le lr) e r = chkLN (delLP ll le lr) e r++-- | Delete leftmost from (Z l e r)+delLZ :: AVL e -> e -> AVL e -> AVL e+delLZ E _ _ = E -- Terminal case, r must be E+delLZ (N ll le lr) e r = delLZN ll le lr e r+delLZ (Z ll le lr) e r = delLZZ ll le lr e r+delLZ (P ll le lr) e r = delLZP ll le lr e r++-- | Delete leftmost from (P l e r)+delLP :: AVL e -> e -> AVL e -> AVL e+delLP E _ _ = error "delLP: Bug0" -- Impossible if BF=+1+delLP (N ll le lr) e r = chkLP (delLN ll le lr) e r+delLP (Z ll le lr) e r = delLPZ ll le lr e r+delLP (P ll le lr) e r = chkLP (delLP ll le lr) e r++-------------------------- delL LEVEL 2 -------------------------------+-- delLNZ, delLZZ, delLPZ --+-- delLZN, delLZP --+-----------------------------------------------------------------------++-- Delete leftmost from (N (Z ll le lr) e r), height of left sub-tree can't change in this case+{-# INLINE delLNZ #-}+delLNZ :: AVL e -> e -> AVL e -> e -> AVL e -> AVL e+delLNZ E _ _ e r = rebalN E e r -- Terminal case, Needs rebalancing+delLNZ (N lll lle llr) le lr e r = let l' = delLZN lll lle llr le lr in l' `seq` N l' e r+delLNZ (Z lll lle llr) le lr e r = let l' = delLZZ lll lle llr le lr in l' `seq` N l' e r+delLNZ (P lll lle llr) le lr e r = let l' = delLZP lll lle llr le lr in l' `seq` N l' e r++-- Delete leftmost from (Z (Z ll le lr) e r), height of left sub-tree can't change in this case+-- Don't inline+delLZZ :: AVL e -> e -> AVL e -> e -> AVL e -> AVL e+delLZZ E _ _ e r = N E e r -- Terminal case+delLZZ (N lll lle llr) le lr e r = let l' = delLZN lll lle llr le lr in l' `seq` Z l' e r+delLZZ (Z lll lle llr) le lr e r = let l' = delLZZ lll lle llr le lr in l' `seq` Z l' e r+delLZZ (P lll lle llr) le lr e r = let l' = delLZP lll lle llr le lr in l' `seq` Z l' e r++-- Delete leftmost from (P (Z ll le lr) e r), height of left sub-tree can't change in this case+{-# INLINE delLPZ #-}+delLPZ :: AVL e -> e -> AVL e -> e -> AVL e -> AVL e+delLPZ E _ _ e _ = Z E e E -- Terminal case+delLPZ (N lll lle llr) le lr e r = let l' = delLZN lll lle llr le lr in l' `seq` P l' e r+delLPZ (Z lll lle llr) le lr e r = let l' = delLZZ lll lle llr le lr in l' `seq` P l' e r+delLPZ (P lll lle llr) le lr e r = let l' = delLZP lll lle llr le lr in l' `seq` P l' e r++-- Delete leftmost from (Z (N ll le lr) e r)+{-# INLINE delLZN #-}+delLZN :: AVL e -> e -> AVL e -> e -> AVL e -> AVL e+delLZN ll le lr e r = chkLZ (delLN ll le lr) e r++-- Delete leftmost from (Z (P ll le lr) e r)+{-# INLINE delLZP #-}+delLZP :: AVL e -> e -> AVL e -> e -> AVL e -> AVL e+delLZP ll le lr e r = chkLZ (delLP ll le lr) e r++-------------------------- delR LEVEL 1 -------------------------------+-- delRN, delRZ, delRP --+-----------------------------------------------------------------------+-- | Delete rightmost from (N l e r)+delRN :: AVL e -> e -> AVL e -> AVL e+delRN _ _ E = error "delRN: Bug0" -- Impossible if BF=-1+delRN l e (N rl re rr) = chkRN l e (delRN rl re rr)+delRN l e (Z rl re rr) = delRNZ l e rl re rr+delRN l e (P rl re rr) = chkRN l e (delRP rl re rr)++-- | Delete rightmost from (Z l e r)+delRZ :: AVL e -> e -> AVL e -> AVL e+delRZ _ _ E = E -- Terminal case, l must be E+delRZ l e (N rl re rr) = delRZN l e rl re rr+delRZ l e (Z rl re rr) = delRZZ l e rl re rr+delRZ l e (P rl re rr) = delRZP l e rl re rr++-- | Delete rightmost from (P l e r)+delRP :: AVL e -> e -> AVL e -> AVL e+delRP l _ E = l -- Terminal case, l must be of form (Z E le E)+delRP l e (N rl re rr) = chkRP l e (delRN rl re rr)+delRP l e (Z rl re rr) = delRPZ l e rl re rr+delRP l e (P rl re rr) = chkRP l e (delRP rl re rr)++-------------------------- delR LEVEL 2 -------------------------------+-- delRNZ, delRZZ, delRPZ --+-- delRZN, delRZP --+-----------------------------------------------------------------------++-- Delete rightmost from (N l e (Z rl re rr)), height of right sub-tree can't change in this case+delRNZ :: AVL e -> e -> AVL e -> e -> AVL e -> AVL e+{-# INLINE delRNZ #-}+delRNZ _ e _ _ E = Z E e E -- Terminal case+delRNZ l e rl re (N rrl rre rrr) = let r' = delRZN rl re rrl rre rrr in r' `seq` N l e r'+delRNZ l e rl re (Z rrl rre rrr) = let r' = delRZZ rl re rrl rre rrr in r' `seq` N l e r'+delRNZ l e rl re (P rrl rre rrr) = let r' = delRZP rl re rrl rre rrr in r' `seq` N l e r'++-- Delete rightmost from (Z l e (Z rl re rr)), height of right sub-tree can't change in this case+delRZZ :: AVL e -> e -> AVL e -> e -> AVL e -> AVL e+delRZZ l e _ _ E = P l e E -- Terminal case+delRZZ l e rl re (N rrl rre rrr) = let r' = delRZN rl re rrl rre rrr in r' `seq` Z l e r'+delRZZ l e rl re (Z rrl rre rrr) = let r' = delRZZ rl re rrl rre rrr in r' `seq` Z l e r'+delRZZ l e rl re (P rrl rre rrr) = let r' = delRZP rl re rrl rre rrr in r' `seq` Z l e r'++-- Delete rightmost from (P l e (Z rl re rr)), height of right sub-tree can't change in this case+delRPZ :: AVL e -> e -> AVL e -> e -> AVL e -> AVL e+{-# INLINE delRPZ #-}+delRPZ l e _ _ E = rebalP l e E -- Terminal case, Needs rebalancing+delRPZ l e rl re (N rrl rre rrr) = let r' = delRZN rl re rrl rre rrr in r' `seq` P l e r'+delRPZ l e rl re (Z rrl rre rrr) = let r' = delRZZ rl re rrl rre rrr in r' `seq` P l e r'+delRPZ l e rl re (P rrl rre rrr) = let r' = delRZP rl re rrl rre rrr in r' `seq` P l e r'++-- Delete rightmost from (Z l e (N rl re rr))+delRZN :: AVL e -> e -> AVL e -> e -> AVL e -> AVL e+{-# INLINE delRZN #-}+delRZN l e rl re rr = chkRZ l e (delRN rl re rr)++-- Delete rightmost from (Z l e (P rl re rr))+delRZP :: AVL e -> e -> AVL e -> e -> AVL e -> AVL e+{-# INLINE delRZP #-}+delRZP l e rl re rr = chkRZ l e (delRP rl re rr)++-------------------------- popL LEVEL 1 -------------------------------+-- popLN, popLZ, popLP --+-----------------------------------------------------------------------+-- | Delete leftmost from (N l e r)+popLN :: AVL e -> e -> AVL e -> UBT2(e,AVL e)+popLN E e r = UBT2(e,r) -- Terminal case, r must be of form (Z E re E)+popLN (N ll le lr) e r = case popLN ll le lr of+ UBT2(v,l) -> let t = chkLN l e r in t `seq` UBT2(v,t)+popLN (Z ll le lr) e r = popLNZ ll le lr e r+popLN (P ll le lr) e r = case popLP ll le lr of+ UBT2(v,l) -> let t = chkLN l e r in t `seq` UBT2(v,t)++-- | Delete leftmost from (Z l e r)+popLZ :: AVL e -> e -> AVL e -> UBT2(e,AVL e)+popLZ E e _ = UBT2(e,E) -- Terminal case, r must be E+popLZ (N ll le lr) e r = popLZN ll le lr e r+popLZ (Z ll le lr) e r = popLZZ ll le lr e r+popLZ (P ll le lr) e r = popLZP ll le lr e r++-- | Delete leftmost from (P l e r)+popLP :: AVL e -> e -> AVL e -> UBT2(e,AVL e)+popLP E _ _ = error "popLP: Bug!" -- Impossible if BF=+1+popLP (N ll le lr) e r = case popLN ll le lr of+ UBT2(v,l) -> let t = chkLP l e r in t `seq` UBT2(v,t)+popLP (Z ll le lr) e r = popLPZ ll le lr e r+popLP (P ll le lr) e r = case popLP ll le lr of+ UBT2(v,l) -> let t = chkLP l e r in t `seq` UBT2(v,t)++-------------------------- popL LEVEL 2 -------------------------------+-- popLNZ, popLZZ, popLPZ --+-- popLZN, popLZP --+-----------------------------------------------------------------------++-- Delete leftmost from (N (Z ll le lr) e r), height of left sub-tree can't change in this case+popLNZ :: AVL e -> e -> AVL e -> e -> AVL e -> UBT2(e,AVL e)+{-# INLINE popLNZ #-}+popLNZ E le _ e r = let t = rebalN E e r -- Terminal case, Needs rebalancing+ in t `seq` UBT2(le,t)+popLNZ (N lll lle llr) le lr e r = case popLZN lll lle llr le lr of+ UBT2(v,l) -> UBT2(v, N l e r)+popLNZ (Z lll lle llr) le lr e r = case popLZZ lll lle llr le lr of+ UBT2(v,l) -> UBT2(v, N l e r)+popLNZ (P lll lle llr) le lr e r = case popLZP lll lle llr le lr of+ UBT2(v,l) -> UBT2(v, N l e r)++-- Delete leftmost from (Z (Z ll le lr) e r), height of left sub-tree can't change in this case+-- Don't INLINE this!+popLZZ :: AVL e -> e -> AVL e -> e -> AVL e -> UBT2(e,AVL e)+popLZZ E le _ e r = UBT2(le, N E e r) -- Terminal case+popLZZ (N lll lle llr) le lr e r = case popLZN lll lle llr le lr of+ UBT2(v,l) -> UBT2(v, Z l e r)+popLZZ (Z lll lle llr) le lr e r = case popLZZ lll lle llr le lr of+ UBT2(v,l) -> UBT2(v, Z l e r)+popLZZ (P lll lle llr) le lr e r = case popLZP lll lle llr le lr of+ UBT2(v,l) -> UBT2(v, Z l e r)++-- Delete leftmost from (P (Z ll le lr) e r), height of left sub-tree can't change in this case+popLPZ :: AVL e -> e -> AVL e -> e -> AVL e -> UBT2(e,AVL e)+{-# INLINE popLPZ #-}+popLPZ E le _ e _ = UBT2(le, Z E e E) -- Terminal case+popLPZ (N lll lle llr) le lr e r = case popLZN lll lle llr le lr of+ UBT2(v,l) -> UBT2(v, P l e r)+popLPZ (Z lll lle llr) le lr e r = case popLZZ lll lle llr le lr of+ UBT2(v,l) -> UBT2(v, P l e r)+popLPZ (P lll lle llr) le lr e r = case popLZP lll lle llr le lr of+ UBT2(v,l) -> UBT2(v, P l e r)++-- Delete leftmost from (Z (N ll le lr) e r)+-- Don't INLINE this!+popLZN :: AVL e -> e -> AVL e -> e -> AVL e -> UBT2(e,AVL e)+popLZN ll le lr e r = case popLN ll le lr of+ UBT2(v,l) -> let t = chkLZ l e r in t `seq` UBT2(v,t)+-- Delete leftmost from (Z (P ll le lr) e r)+-- Don't INLINE this!+popLZP :: AVL e -> e -> AVL e -> e -> AVL e -> UBT2(e,AVL e)+popLZP ll le lr e r = case popLP ll le lr of+ UBT2(v,l) -> let t = chkLZ l e r in t `seq` UBT2(v,t)++-------------------------- popR LEVEL 1 -------------------------------+-- popRN, popRZ, popRP --+-----------------------------------------------------------------------+-- | Delete rightmost from (N l e r)+popRN :: AVL e -> e -> AVL e -> UBT2(AVL e,e)+popRN _ _ E = error "popRN: Bug!" -- Impossible if BF=-1+popRN l e (N rl re rr) = case popRN rl re rr of+ UBT2(r,v) -> let t = chkRN l e r in t `seq` UBT2(t,v)+popRN l e (Z rl re rr) = popRNZ l e rl re rr+popRN l e (P rl re rr) = case popRP rl re rr of+ UBT2(r,v) -> let t = chkRN l e r in t `seq` UBT2(t,v)++-- | Delete rightmost from (Z l e r)+popRZ :: AVL e -> e -> AVL e -> UBT2(AVL e,e)+popRZ _ e E = UBT2(E,e) -- Terminal case, l must be E+popRZ l e (N rl re rr) = popRZN l e rl re rr+popRZ l e (Z rl re rr) = popRZZ l e rl re rr+popRZ l e (P rl re rr) = popRZP l e rl re rr++-- | Delete rightmost from (P l e r)+popRP :: AVL e -> e -> AVL e -> UBT2(AVL e,e)+popRP l e E = UBT2(l,e) -- Terminal case, l must be of form (Z E le E)+popRP l e (N rl re rr) = case popRN rl re rr of+ UBT2(r,v) -> let t = chkRP l e r in t `seq` UBT2(t,v)+popRP l e (Z rl re rr) = popRPZ l e rl re rr+popRP l e (P rl re rr) = case popRP rl re rr of+ UBT2(r,v) -> let t = chkRP l e r in t `seq` UBT2(t,v)++-------------------------- popR LEVEL 2 -------------------------------+-- popRNZ, popRZZ, popRPZ --+-- popRZN, popRZP --+-----------------------------------------------------------------------++-- Delete rightmost from (N l e (Z rl re rr)), height of right sub-tree can't change in this case+popRNZ :: AVL e -> e -> AVL e -> e -> AVL e -> UBT2(AVL e,e)+{-# INLINE popRNZ #-}+popRNZ _ e _ re E = UBT2(Z E e E, re) -- Terminal case+popRNZ l e rl re (N rrl rre rrr) = case popRZN rl re rrl rre rrr of+ UBT2(r,v) -> UBT2(N l e r, v)+popRNZ l e rl re (Z rrl rre rrr) = case popRZZ rl re rrl rre rrr of+ UBT2(r,v) -> UBT2(N l e r, v)+popRNZ l e rl re (P rrl rre rrr) = case popRZP rl re rrl rre rrr of+ UBT2(r,v) -> UBT2(N l e r, v)++-- Delete rightmost from (Z l e (Z rl re rr)), height of right sub-tree can't change in this case+-- Don't INLINE this!+popRZZ :: AVL e -> e -> AVL e -> e -> AVL e -> UBT2(AVL e,e)+popRZZ l e _ re E = UBT2(P l e E, re) -- Terminal case+popRZZ l e rl re (N rrl rre rrr) = case popRZN rl re rrl rre rrr of+ UBT2(r,v) -> UBT2(Z l e r, v)+popRZZ l e rl re (Z rrl rre rrr) = case popRZZ rl re rrl rre rrr of+ UBT2(r,v) -> UBT2(Z l e r, v)+popRZZ l e rl re (P rrl rre rrr) = case popRZP rl re rrl rre rrr of+ UBT2(r,v) -> UBT2(Z l e r, v)++-- Delete rightmost from (P l e (Z rl re rr)), height of right sub-tree can't change in this case+popRPZ :: AVL e -> e -> AVL e -> e -> AVL e -> UBT2(AVL e,e)+{-# INLINE popRPZ #-}+popRPZ l e _ re E = let t = rebalP l e E -- Terminal case, Needs rebalancing+ in t `seq` UBT2(t,re)+popRPZ l e rl re (N rrl rre rrr) = case popRZN rl re rrl rre rrr of+ UBT2(r,v) -> UBT2(P l e r, v)+popRPZ l e rl re (Z rrl rre rrr) = case popRZZ rl re rrl rre rrr of+ UBT2(r,v) -> UBT2(P l e r, v)+popRPZ l e rl re (P rrl rre rrr) = case popRZP rl re rrl rre rrr of+ UBT2(r,v) -> UBT2(P l e r, v)++-- Delete rightmost from (Z l e (N rl re rr))+-- Don't INLINE this!+popRZN :: AVL e -> e -> AVL e -> e -> AVL e -> UBT2(AVL e,e)+popRZN l e rl re rr = case popRN rl re rr of+ UBT2(r,v) -> let t = chkRZ l e r in t `seq` UBT2(t,v)++-- Delete rightmost from (Z l e (P rl re rr))+-- Don't INLINE this!+popRZP :: AVL e -> e -> AVL e -> e -> AVL e -> UBT2(AVL e,e)+popRZP l e rl re rr = case popRP rl re rr of+ UBT2(r,v) -> let t = chkRZ l e r in t `seq` UBT2(t,v)++-- | Deletes a tree element. Assumes the path bits were extracted+-- from a 'Data.Tree.AVL.FullBP' constructor.+--+-- Complexity: O(log n)+deletePath :: UINT -> AVL e -> AVL e+deletePath _ E = error "deletePath: Element not found."+deletePath p (N l e r) = delN p l e r+deletePath p (Z l e r) = delZ p l e r+deletePath p (P l e r) = delP p l e r++----------------------------- LEVEL 1 ---------------------------------+-- delN, delZ, delP --+-----------------------------------------------------------------------++-- Delete from (N l e r)+delN :: UINT -> AVL e -> e -> AVL e -> AVL e+delN p l e r = case sel p of+ LT -> delNL p l e r+ EQ -> subN l r+ GT -> delNR p l e r++-- Delete from (Z l e r)+delZ :: UINT -> AVL e -> e -> AVL e -> AVL e+delZ p l e r = case sel p of+ LT -> delZL p l e r+ EQ -> subZR l r+ GT -> delZR p l e r++-- Delete from (P l e r)+delP :: UINT -> AVL e -> e -> AVL e -> AVL e+delP p l e r = case sel p of+ LT -> delPL p l e r+ EQ -> subP l r+ GT -> delPR p l e r++----------------------------- LEVEL 2 ---------------------------------+-- delNL, delZL, delPL --+-- delNR, delZR, delPR --+-----------------------------------------------------------------------++-- Delete from the left subtree of (N l e r)+delNL :: UINT -> AVL e -> e -> AVL e -> AVL e+delNL p t = dNL (goL p) t+{-# INLINE dNL #-}+dNL :: UINT -> AVL e -> e -> AVL e -> AVL e+dNL _ E _ _ = error "deletePath: Element not found." -- Left sub-tree is empty+dNL p (N ll le lr) e r = case sel p of+ LT -> chkLN (delNL p ll le lr) e r+ EQ -> chkLN (subN ll lr) e r+ GT -> chkLN (delNR p ll le lr) e r+dNL p (Z ll le lr) e r = case sel p of+ LT -> let l' = delZL p ll le lr in l' `seq` N l' e r -- height can't change+ EQ -> chkLN' (subZR ll lr) e r -- << But it can here+ GT -> let l' = delZR p ll le lr in l' `seq` N l' e r -- height can't change+dNL p (P ll le lr) e r = case sel p of+ LT -> chkLN (delPL p ll le lr) e r+ EQ -> chkLN (subP ll lr) e r+ GT -> chkLN (delPR p ll le lr) e r++-- Delete from the right subtree of (N l e r)+delNR :: UINT -> AVL e -> e -> AVL e -> AVL e+delNR p t = dNR (goR p) t+{-# INLINE dNR #-}+dNR :: UINT -> AVL e -> e -> AVL e -> AVL e+dNR _ _ _ E = error "delNR: Bug0" -- Impossible+dNR p l e (N rl re rr) = case sel p of+ LT -> chkRN l e (delNL p rl re rr)+ EQ -> chkRN l e (subN rl rr)+ GT -> chkRN l e (delNR p rl re rr)+dNR p l e (Z rl re rr) = case sel p of+ LT -> let r' = delZL p rl re rr in r' `seq` N l e r' -- height can't change+ EQ -> chkRN' l e (subZL rl rr) -- << But it can here+ GT -> let r' = delZR p rl re rr in r' `seq` N l e r' -- height can't change+dNR p l e (P rl re rr) = case sel p of+ LT -> chkRN l e (delPL p rl re rr)+ EQ -> chkRN l e (subP rl rr)+ GT -> chkRN l e (delPR p rl re rr)++-- Delete from the left subtree of (Z l e r)+delZL :: UINT -> AVL e -> e -> AVL e -> AVL e+delZL p t = dZL (goL p) t+{-# INLINE dZL #-}+dZL :: UINT -> AVL e -> e -> AVL e -> AVL e+dZL _ E _ _ = error "deletePath: Element not found." -- Left sub-tree is empty+dZL p (N ll le lr) e r = case sel p of+ LT -> chkLZ (delNL p ll le lr) e r+ EQ -> chkLZ (subN ll lr) e r+ GT -> chkLZ (delNR p ll le lr) e r+dZL p (Z ll le lr) e r = case sel p of+ LT -> let l' = delZL p ll le lr in l' `seq` Z l' e r -- height can't change+ EQ -> chkLZ' (subZR ll lr) e r -- << But it can here+ GT -> let l' = delZR p ll le lr in l' `seq` Z l' e r -- height can't change+dZL p (P ll le lr) e r = case sel p of+ LT -> chkLZ (delPL p ll le lr) e r+ EQ -> chkLZ (subP ll lr) e r+ GT -> chkLZ (delPR p ll le lr) e r++-- Delete from the right subtree of (Z l e r)+delZR :: UINT -> AVL e -> e -> AVL e -> AVL e+delZR p t = dZR (goR p) t+{-# INLINE dZR #-}+dZR :: UINT -> AVL e -> e -> AVL e -> AVL e+dZR _ _ _ E = error "deletePath: Element not found." -- Right sub-tree is empty+dZR p l e (N rl re rr) = case sel p of+ LT -> chkRZ l e (delNL p rl re rr)+ EQ -> chkRZ l e (subN rl rr)+ GT -> chkRZ l e (delNR p rl re rr)+dZR p l e (Z rl re rr) = case sel p of+ LT -> let r' = delZL p rl re rr in r' `seq` Z l e r' -- height can't change+ EQ -> chkRZ' l e (subZL rl rr) -- << But it can here+ GT -> let r' = delZR p rl re rr in r' `seq` Z l e r' -- height can't change+dZR p l e (P rl re rr) = case sel p of+ LT -> chkRZ l e (delPL p rl re rr)+ EQ -> chkRZ l e (subP rl rr)+ GT -> chkRZ l e (delPR p rl re rr)++-- Delete from the left subtree of (P l e r)+delPL :: UINT -> AVL e -> e -> AVL e -> AVL e+delPL p t = dPL (goL p) t+{-# INLINE dPL #-}+dPL :: UINT -> AVL e -> e -> AVL e -> AVL e+dPL _ E _ _ = error "delPL: Bug0" -- Impossible+dPL p (N ll le lr) e r = case sel p of+ LT -> chkLP (delNL p ll le lr) e r+ EQ -> chkLP (subN ll lr) e r+ GT -> chkLP (delNR p ll le lr) e r+dPL p (Z ll le lr) e r = case sel p of+ LT -> let l' = delZL p ll le lr in l' `seq` P l' e r -- height can't change+ EQ -> chkLP' (subZR ll lr) e r -- << But it can here+ GT -> let l' = delZR p ll le lr in l' `seq` P l' e r -- height can't change+dPL p (P ll le lr) e r = case sel p of+ LT -> chkLP (delPL p ll le lr) e r+ EQ -> chkLP (subP ll lr) e r+ GT -> chkLP (delPR p ll le lr) e r++-- Delete from the right subtree of (P l e r)+delPR :: UINT -> AVL e -> e -> AVL e -> AVL e+delPR p t = dPR (goR p) t+{-# INLINE dPR #-}+dPR :: UINT -> AVL e -> e -> AVL e -> AVL e+dPR _ _ _ E = error "deletePath: Element not found." -- Right sub-tree is empty+dPR p l e (N rl re rr) = case sel p of+ LT -> chkRP l e (delNL p rl re rr)+ EQ -> chkRP l e (subN rl rr)+ GT -> chkRP l e (delNR p rl re rr)+dPR p l e (Z rl re rr) = case sel p of+ LT -> let r' = delZL p rl re rr in r' `seq` P l e r' -- height can't change+ EQ -> chkRP' l e (subZL rl rr) -- << But it can here+ GT -> let r' = delZR p rl re rr in r' `seq` P l e r' -- height can't change+dPR p l e (P rl re rr) = case sel p of+ LT -> chkRP l e (delPL p rl re rr)+ EQ -> chkRP l e (subP rl rr)+ GT -> chkRP l e (delPR p rl re rr)++-- | This is a modified version of popL which returns the (popped) tree height as well.+popHL :: AVL e -> UBT3(e,AVL e,UINT)+popHL E = error "popHL: Empty tree."+popHL (N l e r) = popHLN l e r+popHL (Z l e r) = popHLZ l e r+popHL (P l e r) = popHLP l e r++popHLN :: AVL e -> e -> AVL e -> UBT3(e,AVL e,UINT)+popHLN l e r = case popHLN_ L(2) l e r of+ UBT3(e_,t,h) -> case t of+ E -> error "popHLN: Bug0" -- impossible+ Z _ _ _ -> UBT3(e_,t,DECINT1(h)) -- dH = -1+ _ -> UBT3(e_,t, h ) -- dH = 0++popHLZ :: AVL e -> e -> AVL e -> UBT3(e,AVL e,UINT)+popHLZ l e r = case popHLZ_ L(1) l e r of+ UBT3(e_,t,h) -> case t of+ E -> UBT3(e,E,L(0)) -- Resulting tree is empty+ P _ _ _ -> error "popHLZ: Bug0" -- impossible+ _ -> UBT3(e_,t, h ) -- dH = 0++popHLP :: AVL e -> e -> AVL e -> UBT3(e,AVL e,UINT)+popHLP l e r = case popHLP_ L(1) l e r of+ UBT3(e_,t,h) -> case t of+ Z _ _ _ -> UBT3(e_,t,DECINT1(h)) -- dH = -1+ P _ _ _ -> UBT3(e_,t, h ) -- dH = 0+ _ -> error "popHLP: Bug0" -- impossible++-------------------------- popHL LEVEL 1 ------------------------------+-- popHLN_, popHLZ_, popHLP_ --+-----------------------------------------------------------------------+-- Delete leftmost from (N l e r)+popHLN_ :: UINT -> AVL e -> e -> AVL e -> UBT3(e,AVL e,UINT)+popHLN_ h E e r = UBT3(e,r,h) -- Terminal case, r must be of form (Z E re E)+popHLN_ h (N ll le lr) e r = case popHLN_ INCINT2(h) ll le lr of+ UBT3(e_,l,hl) -> let t = chkLN l e r in t `seq` UBT3(e_,t,hl)+popHLN_ h (Z ll le lr) e r = popHLNZ INCINT1(h) ll le lr e r+popHLN_ h (P ll le lr) e r = case popHLP_ INCINT1(h) ll le lr of+ UBT3(e_,l,hl) -> let t = chkLN l e r in t `seq` UBT3(e_,t,hl)++-- Delete leftmost from (Z l e r)+{-# INLINE popHLZ_ #-}+popHLZ_ :: UINT -> AVL e -> e -> AVL e -> UBT3(e,AVL e,UINT)+popHLZ_ h E e _ = UBT3(e,E,h) -- Terminal case, r must be E+popHLZ_ h (N ll le lr) e r = popHLZN INCINT2(h) ll le lr e r+popHLZ_ h (Z ll le lr) e r = popHLZZ INCINT1(h) ll le lr e r+popHLZ_ h (P ll le lr) e r = popHLZP INCINT1(h) ll le lr e r++-- Delete leftmost from (P l e r)+popHLP_ :: UINT -> AVL e -> e -> AVL e -> UBT3(e,AVL e,UINT)+popHLP_ _ E _ _ = error "popHLP_: Bug0" -- Impossible if BF=+1+popHLP_ h (N ll le lr) e r = case popHLN_ INCINT2(h) ll le lr of+ UBT3(e_,l,hl) -> let t = chkLP l e r in t `seq` UBT3(e_,t,hl)+popHLP_ h (Z ll le lr) e r = popHLPZ INCINT1(h) ll le lr e r+popHLP_ h (P ll le lr) e r = case popHLP_ INCINT1(h) ll le lr of+ UBT3(e_,l,hl) -> let t = chkLP l e r in t `seq` UBT3(e_,t,hl)++-------------------------- popHL LEVEL 2 ------------------------------+-- popHLNZ, popHLZZ, popHLPZ --+-- popHLZN, popHLZP --+-----------------------------------------------------------------------++-- Delete leftmost from (N (Z ll le lr) e r), height of left sub-tree can't change in this case+{-# INLINE popHLNZ #-}+popHLNZ :: UINT -> AVL e -> e -> AVL e -> e -> AVL e -> UBT3(e,AVL e,UINT)+popHLNZ h E le _ e r = let t = rebalN E e r -- Terminal case, Needs rebalancing+ in t `seq` UBT3(le,t,h)+popHLNZ h (N lll lle llr) le lr e r = case popHLZN INCINT2(h) lll lle llr le lr of+ UBT3(e_,l,hl) -> UBT3(e_, N l e r, hl)+popHLNZ h (Z lll lle llr) le lr e r = case popHLZZ INCINT1(h) lll lle llr le lr of+ UBT3(e_,l,hl) -> UBT3(e_, N l e r, hl)+popHLNZ h (P lll lle llr) le lr e r = case popHLZP INCINT1(h) lll lle llr le lr of+ UBT3(e_,l,hl) -> UBT3(e_, N l e r, hl)++-- Delete leftmost from (Z (Z ll le lr) e r), height of left sub-tree can't change in this case+-- Don't INLINE this!+popHLZZ :: UINT -> AVL e -> e -> AVL e -> e -> AVL e -> UBT3(e,AVL e,UINT)+popHLZZ h E le _ e r = UBT3(le, N E e r, h) -- Terminal case+popHLZZ h (N lll lle llr) le lr e r = case popHLZN INCINT2(h) lll lle llr le lr of+ UBT3(e_,l,hl) -> UBT3(e_, Z l e r, hl)+popHLZZ h (Z lll lle llr) le lr e r = case popHLZZ INCINT1(h) lll lle llr le lr of+ UBT3(e_,l,hl) -> UBT3(e_, Z l e r, hl)+popHLZZ h (P lll lle llr) le lr e r = case popHLZP INCINT1(h) lll lle llr le lr of+ UBT3(e_,l,hl) -> UBT3(e_, Z l e r, hl)++-- Delete leftmost from (P (Z ll le lr) e r), height of left sub-tree can't change in this case+{-# INLINE popHLPZ #-}+popHLPZ :: UINT -> AVL e -> e -> AVL e -> e -> AVL e -> UBT3(e,AVL e,UINT)+popHLPZ h E le _ e _ = UBT3(le, Z E e E, h) -- Terminal case+popHLPZ h (N lll lle llr) le lr e r = case popHLZN INCINT2(h) lll lle llr le lr of+ UBT3(e_,l,hl) -> UBT3(e_, P l e r, hl)+popHLPZ h (Z lll lle llr) le lr e r = case popHLZZ INCINT1(h) lll lle llr le lr of+ UBT3(e_,l,hl) -> UBT3(e_, P l e r, hl)+popHLPZ h (P lll lle llr) le lr e r = case popHLZP INCINT1(h) lll lle llr le lr of+ UBT3(e_,l,hl) -> UBT3(e_, P l e r, hl)++-- Delete leftmost from (Z (N ll le lr) e r)+-- Don't INLINE this!+popHLZN :: UINT -> AVL e -> e -> AVL e -> e -> AVL e -> UBT3(e,AVL e,UINT)+popHLZN h ll le lr e r = case popHLN_ h ll le lr of+ UBT3(e_,l,hl) -> let t = chkLZ l e r in t `seq` UBT3(e_,t,hl)+-- Delete leftmost from (Z (P ll le lr) e r)+-- Don't INLINE this!+popHLZP :: UINT -> AVL e -> e -> AVL e -> e -> AVL e -> UBT3(e,AVL e,UINT)+popHLZP h ll le lr e r = case popHLP_ h ll le lr of+ UBT3(e_,l,hl) -> let t = chkLZ l e r in t `seq` UBT3(e_,t,hl)++{-************************** Balancing Utilities Below Here ************************************-}++-- Rebalance a tree of form (N l e r) which has become unbalanced as+-- a result of the height of the left sub-tree (l) decreasing by 1.+-- N.B Result is never of form (N _ _ _) (or E!)+rebalN :: AVL e -> e -> AVL e -> AVL e+rebalN _ _ E = error "rebalN: Bug0" -- impossible case+rebalN l e (N rl re rr) = Z (Z l e rl) re rr -- N->Z, dH=-1+rebalN l e (Z rl re rr) = P (N l e rl) re rr -- N->P, dH= 0+rebalN _ _ (P E _ _) = error "rebalN: Bug1" -- impossible case+rebalN l e (P (N rll rle rlr) re rr) = Z (P l e rll) rle (Z rlr re rr) -- N->Z, dH=-1+rebalN l e (P (Z rll rle rlr) re rr) = Z (Z l e rll) rle (Z rlr re rr) -- N->Z, dH=-1+rebalN l e (P (P rll rle rlr) re rr) = Z (Z l e rll) rle (N rlr re rr) -- N->Z, dH=-1++-- Rebalance a tree of form (P l e r) which has become unbalanced as+-- a result of the height of the right sub-tree (r) decreasing by 1.+-- N.B Result is never of form (P _ _ _) (or E!)+rebalP :: AVL e -> e -> AVL e -> AVL e+rebalP E _ _ = error "rebalP: Bug0" -- impossible case+rebalP (P ll le lr ) e r = Z ll le (Z lr e r) -- P->Z, dH=-1+rebalP (Z ll le lr ) e r = N ll le (P lr e r) -- P->N, dH= 0+rebalP (N _ _ E ) _ _ = error "rebalP: Bug1" -- impossible case+rebalP (N ll le (P lrl lre lrr)) e r = Z (Z ll le lrl) lre (N lrr e r) -- P->Z, dH=-1+rebalP (N ll le (Z lrl lre lrr)) e r = Z (Z ll le lrl) lre (Z lrr e r) -- P->Z, dH=-1+rebalP (N ll le (N lrl lre lrr)) e r = Z (P ll le lrl) lre (Z lrr e r) -- P->Z, dH=-1++-- | Check for height changes in left subtree of (N l e r),+-- where l was (N ll le lr) or (P ll le lr)+chkLN :: AVL e -> e -> AVL e -> AVL e+chkLN l e r = case l of+ E -> error "chkLN: Bug0" -- impossible if BF<>0+ N _ _ _ -> N l e r -- BF +/-1 -> -1, so dH= 0+ Z _ _ _ -> rebalN l e r -- BF +/-1 -> 0, so dH=-1+ P _ _ _ -> N l e r -- BF +/-1 -> +1, so dH= 0+-- | Check for height changes in left subtree of (Z l e r),+-- where l was (N ll le lr) or (P ll le lr)+chkLZ :: AVL e -> e -> AVL e -> AVL e+chkLZ l e r = case l of+ E -> error "chkLZ: Bug0" -- impossible if BF<>0+ N _ _ _ -> Z l e r -- BF +/-1 -> -1, so dH= 0+ Z _ _ _ -> N l e r -- BF +/-1 -> 0, so dH=-1+ P _ _ _ -> Z l e r -- BF +/-1 -> +1, so dH= 0+-- | Check for height changes in left subtree of (P l e r),+-- where l was (N ll le lr) or (P ll le lr)+chkLP :: AVL e -> e -> AVL e -> AVL e+chkLP l e r = case l of+ E -> error "chkLP: Bug0" -- impossible if BF<>0+ N _ _ _ -> P l e r -- BF +/-1 -> -1, so dH= 0+ Z _ _ _ -> Z l e r -- BF +/-1 -> 0, so dH=-1+ P _ _ _ -> P l e r -- BF +/-1 -> +1, so dH= 0+-- | Check for height changes in right subtree of (N l e r),+-- where r was (N rl re rr) or (P rl re rr)+chkRN :: AVL e -> e -> AVL e -> AVL e+chkRN l e r = case r of+ E -> error "chkRN: Bug0" -- impossible if BF<>0+ N _ _ _ -> N l e r -- BF +/-1 -> -1, so dH= 0+ Z _ _ _ -> Z l e r -- BF +/-1 -> 0, so dH=-1+ P _ _ _ -> N l e r -- BF +/-1 -> +1, so dH= 0+-- | Check for height changes in right subtree of (Z l e r),+-- where r was (N rl re rr) or (P rl re rr)+chkRZ :: AVL e -> e -> AVL e -> AVL e+chkRZ l e r = case r of+ E -> error "chkRZ: Bug0" -- impossible if BF<>0+ N _ _ _ -> Z l e r -- BF +/-1 -> -1, so dH= 0+ Z _ _ _ -> P l e r -- BF +/-1 -> 0, so dH=-1+ P _ _ _ -> Z l e r -- BF +/-1 -> +1, so dH= 0+-- | Check for height changes in right subtree of (P l e r),+-- where l was (N rl re rr) or (P rl re rr)+chkRP :: AVL e -> e -> AVL e -> AVL e+chkRP l e r = case r of+ E -> error "chkRP: Bug0" -- impossible if BF<>0+ N _ _ _ -> P l e r -- BF +/-1 -> -1, so dH= 0+ Z _ _ _ -> rebalP l e r -- BF +/-1 -> 0, so dH=-1+ P _ _ _ -> P l e r -- BF +/-1 -> +1, so dH= 0++-- | Substitute deleted element from (N l _ r)+subN :: AVL e -> AVL e -> AVL e+subN _ E = error "subN: Bug0" -- Impossible+subN l (N rl re rr) = case popLN rl re rr of UBT2(e,r_) -> chkRN l e r_+subN l (Z rl re rr) = case popLZ rl re rr of UBT2(e,r_) -> chkRN' l e r_+subN l (P rl re rr) = case popLP rl re rr of UBT2(e,r_) -> chkRN l e r_++-- | Substitute deleted element from (Z l _ r)+-- Pops the replacement from the right sub-tree, so result may be (P _ _ _)+subZR :: AVL e -> AVL e -> AVL e+subZR _ E = E -- Both left and right subtrees must have been empty+subZR l (N rl re rr) = case popLN rl re rr of UBT2(e,r_) -> chkRZ l e r_+subZR l (Z rl re rr) = case popLZ rl re rr of UBT2(e,r_) -> chkRZ' l e r_+subZR l (P rl re rr) = case popLP rl re rr of UBT2(e,r_) -> chkRZ l e r_++-- | Local utility to substitute deleted element from (Z l _ r)+-- Pops the replacement from the left sub-tree, so result may be (N _ _ _)+subZL :: AVL e -> AVL e -> AVL e+subZL E _ = E -- Both left and right subtrees must have been empty+subZL (N ll le lr) r = case popRN ll le lr of UBT2(l_,e) -> chkLZ l_ e r+subZL (Z ll le lr) r = case popRZ ll le lr of UBT2(l_,e) -> chkLZ' l_ e r+subZL (P ll le lr) r = case popRP ll le lr of UBT2(l_,e) -> chkLZ l_ e r++-- | Substitute deleted element from (P l _ r)+subP :: AVL e -> AVL e -> AVL e+subP E _ = error "subP: Bug0" -- Impossible+subP (N ll le lr) r = case popRN ll le lr of UBT2(l_,e) -> chkLP l_ e r+subP (Z ll le lr) r = case popRZ ll le lr of UBT2(l_,e) -> chkLP' l_ e r+subP (P ll le lr) r = case popRP ll le lr of UBT2(l_,e) -> chkLP l_ e r++-- | Check for height changes in left subtree of (N l e r),+-- where l was (Z ll le lr)+chkLN' :: AVL e -> e -> AVL e -> AVL e+chkLN' l e r = case l of+ E -> rebalN l e r -- BF 0 -> E, so dH=-1+ _ -> N l e r -- Otherwise dH=0+-- | Check for height changes in left subtree of (Z l e r),+-- where l was (Z ll le lr)+chkLZ' :: AVL e -> e -> AVL e -> AVL e+chkLZ' l e r = case l of+ E -> N l e r -- BF 0 -> E, so dH=-1+ _ -> Z l e r -- Otherwise dH=0+-- | Check for height changes in left subtree of (P l e r),+-- where l was (Z ll le lr)+chkLP' :: AVL e -> e -> AVL e -> AVL e+chkLP' l e r = case l of+ E -> Z l e r -- BF 0 -> E, so dH=-1+ _ -> P l e r -- Otherwise dH=0+-- | Check for height changes in right subtree of (N l e r),+-- where r was (Z rl re rr)+chkRN' :: AVL e -> e -> AVL e -> AVL e+chkRN' l e r = case r of+ E -> Z l e r -- BF 0 -> E, so dH=-1+ _ -> N l e r -- Otherwise dH=0+-- | Check for height changes in right subtree of (Z l e r),+-- where r was (Z rl re rr)+chkRZ' :: AVL e -> e -> AVL e -> AVL e+chkRZ' l e r = case r of+ E -> P l e r -- BF 0 -> E, so dH=-1+ _ -> Z l e r -- Otherwise dH=0+-- | Check for height changes in right subtree of (P l e r),+-- where l was (Z rl re rr)+chkRP' :: AVL e -> e -> AVL e -> AVL e+chkRP' l e r = case r of+ E -> rebalP l e r -- BF 0 -> E, so dH=-1+ _ -> P l e r -- Otherwise dH=0+
+ src/Data/Tree/AVL/Internals/HAVL.hs view
@@ -0,0 +1,87 @@+-- |+-- Copyright : (c) Adrian Hey 2004,2005+-- License : BSD3+--+-- HAVL data type and related utilities+{-# OPTIONS_HADDOCK hide #-}+module Data.Tree.AVL.Internals.HAVL+ (+ HAVL(HAVL),emptyHAVL,toHAVL,isEmptyHAVL,isNonEmptyHAVL,+ spliceHAVL,joinHAVL,+ pushLHAVL,pushRHAVL+ ) where++import Data.Tree.AVL.Internals.Types(AVL(..))+import Data.Tree.AVL.Height(addHeight)+import Data.Tree.AVL.Internals.HJoin(spliceH,joinH)+import Data.Tree.AVL.Internals.HPush(pushHL,pushHR)++import GHC.Base+#include "ghcdefs.h"++-- | An HAVL represents an AVL tree of known height.+data HAVL e = HAVL (AVL e) {-# UNPACK #-} !UINT++-- | Empty HAVL (height is 0).+emptyHAVL :: HAVL e+emptyHAVL = HAVL E L(0)++-- | Returns 'True' if the AVL component of an HAVL tree is empty. Note that height component+-- is ignored, so it's OK to use this function in cases where the height is relative.+--+-- Complexity: O(1)+{-# INLINE isEmptyHAVL #-}+isEmptyHAVL :: HAVL e -> Bool+isEmptyHAVL (HAVL E _) = True+isEmptyHAVL (HAVL _ _) = False++-- | Returns 'True' if the AVL component of an HAVL tree is non-empty. Note that height component+-- is ignored, so it's OK to use this function in cases where the height is relative.+--+-- Complexity: O(1)+{-# INLINE isNonEmptyHAVL #-}+isNonEmptyHAVL :: HAVL e -> Bool+isNonEmptyHAVL (HAVL E _) = False+isNonEmptyHAVL (HAVL _ _) = True++-- | Converts an AVL to HAVL+toHAVL :: AVL e -> HAVL e+toHAVL t = HAVL t (addHeight L(0) t)++-- | Splice two HAVL trees using the supplied bridging element.+-- That is, the bridging element appears "in the middle" of the resulting HAVL tree.+-- The elements of the first tree argument are to the left of the bridging element and+-- the elements of the second tree are to the right of the bridging element.+--+-- This function does not require that the AVL heights are absolutely correct, only that+-- the difference in supplied heights is equal to the difference in actual heights. So it's+-- OK if the input heights both have the same unknown constant offset. (The output height+-- will also have the same constant offset in this case.)+--+-- Complexity: O(d), where d is the absolute difference in tree heights.+{-# INLINE spliceHAVL #-}+spliceHAVL :: HAVL e -> e -> HAVL e -> HAVL e+spliceHAVL (HAVL l hl) e (HAVL r hr) = case spliceH l hl e r hr of UBT2(t,ht) -> HAVL t ht++-- | Join two HAVL trees.+-- It's OK if heights are relative (I.E. if they share same fixed offset).+--+-- Complexity: O(d), where d is the absolute difference in tree heights.+{-# INLINE joinHAVL #-}+joinHAVL :: HAVL e -> HAVL e -> HAVL e+joinHAVL (HAVL l hl) (HAVL r hr) = case joinH l hl r hr of UBT2(t,ht) -> HAVL t ht++-- | A version of 'Data.Tree.AVL.pushL' for HAVL trees.+-- It's OK if height is relative, with fixed offset. In this case the height of the result+-- will have the same fixed offset.+{-# INLINE pushLHAVL #-}+pushLHAVL :: e -> HAVL e -> HAVL e+pushLHAVL e (HAVL t ht) = case pushHL e t ht of UBT2(t_,ht_) -> HAVL t_ ht_++-- | A version of 'Data.Tree.AVL.pushR' for HAVL trees.+-- It's OK if height is relative, with fixed offset. In this case the height of the result+-- will have the same fixed offset.+{-# INLINE pushRHAVL #-}+pushRHAVL :: HAVL e -> e -> HAVL e+pushRHAVL (HAVL t ht) e = case pushHR t ht e of UBT2(t_,ht_) -> HAVL t_ ht_+
+ src/Data/Tree/AVL/Internals/HJoin.hs view
@@ -0,0 +1,305 @@+-- |+-- Copyright : (c) Adrian Hey 2004,2005+-- License : BSD3+--+-- Functions for joining AVL trees of known height.+module Data.Tree.AVL.Internals.HJoin+ ( spliceH,joinH,joinH',+ ) where++import Data.Tree.AVL.Internals.Types(AVL(..))+import Data.Tree.AVL.Push(pushL,pushR)+import Data.Tree.AVL.Internals.HPush(pushHL_,pushHR_)+import Data.Tree.AVL.Internals.DelUtils(popRN,popRZ,popRP,popLN,popLZ,popLP)++import GHC.Base+#include "ghcdefs.h"++-- | Join two trees of known height, returning an AVL tree.+-- It's OK if heights are relative (I.E. if they share same fixed offset).+--+-- Complexity: O(d), where d is the absolute difference in tree heights.+joinH'+ :: AVL e -> UINT -> AVL e -> UINT -> AVL e+joinH' l hl r hr+ = if isTrue# (hl LEQ hr) then let d = SUBINT(hr,hl) in joinHL d l r+ else let d = SUBINT(hl,hr) in joinHR d l r++-- hr >= hl, join l to left subtree of r.+-- Int argument is absolute difference in tree height, hr-hl (>=0)+{-# INLINE joinHL #-}+joinHL :: UINT -> AVL e -> AVL e -> AVL e+joinHL _ E r = r -- l was empty+joinHL d (N ll le lr) r = case popRN ll le lr of+ UBT2(l_,e) -> case l_ of+ E -> error "joinHL: Bug0" -- impossible if BF=-1+ Z _ _ _ -> spliceL l_ e INCINT1(d) r -- hl2=hl-1+ _ -> spliceL l_ e d r -- hl2=hl+joinHL d (Z ll le lr) r = case popRZ ll le lr of+ UBT2(l_,e) -> case l_ of+ E -> e `pushL` r -- l had only one element+ _ -> spliceL l_ e d r -- hl2=hl+joinHL d (P ll le lr) r = case popRP ll le lr of+ UBT2(l_,e) -> case l_ of+ E -> error "joinHL: Bug1" -- impossible if BF=+1+ Z _ _ _ -> spliceL l_ e INCINT1(d) r -- hl2=hl-1+ _ -> spliceL l_ e d r -- hl2=hl+++-- hl >= hr, join r to right subtree of l.+-- Int argument is absolute difference in tree height, hl-hr (>=0)+{-# INLINE joinHR #-}+joinHR :: UINT -> AVL e -> AVL e -> AVL e+joinHR _ l E = l -- r was empty+joinHR d l (N rl re rr) = case popLN rl re rr of+ UBT2(e,r_) -> case r_ of+ E -> error "joinHR: Bug0" -- impossible if BF=-1+ Z _ _ _ -> spliceR r_ e INCINT1(d) l -- hr2=hr-1+ _ -> spliceR r_ e d l -- hr2=hr+joinHR d l (Z rl re rr) = case popLZ rl re rr of+ UBT2(e,r_) -> case r_ of+ E -> l `pushR` e -- r had only one element+ _ -> spliceR r_ e d l -- hr2=hr+joinHR d l (P rl re rr) = case popLP rl re rr of+ UBT2(e,r_) -> case r_ of+ E -> error "joinHL: Bug1" -- impossible if BF=+1+ Z _ _ _ -> spliceR r_ e INCINT1(d) l -- hr2=hr-1+ _ -> spliceR r_ e d l -- hr2=hr++-- | Join two AVL trees of known height, returning an AVL tree of known height.+-- It's OK if heights are relative (I.E. if they share same fixed offset).+--+-- Complexity: O(d), where d is the absolute difference in tree heights.+joinH :: AVL e -> UINT -> AVL e -> UINT -> UBT2(AVL e,UINT)+joinH l hl r hr =+ case COMPAREUINT hl hr of+ -- hr > hl+ LT -> case l of+ E -> UBT2(r,hr)+ N ll le lr -> case popRN ll le lr of+ UBT2(l_,e) -> case l_ of+ Z _ _ _ -> spliceHL l_ DECINT1(hl) e r hr -- dH=-1+ _ -> spliceHL l_ hl e r hr -- dH= 0+ Z ll le lr -> case popRZ ll le lr of+ UBT2(l_,e) -> case l_ of+ E -> pushHL_ l r hr -- l had only 1 element+ _ -> spliceHL l_ hl e r hr -- dH=0+ P ll le lr -> case popRP ll le lr of+ UBT2(l_,e) -> case l_ of+ Z _ _ _ -> spliceHL l_ DECINT1(hl) e r hr -- dH=-1+ _ -> spliceHL l_ hl e r hr -- dH= 0+ -- hr = hl+ EQ -> case l of+ E -> UBT2(l,hl) -- r must be empty too, don't use emptyAVL!+ N ll le lr -> case popRN ll le lr of+ UBT2(l_,e) -> case l_ of+ Z _ _ _ -> spliceHL l_ DECINT1(hl) e r hr -- dH=-1+ _ -> UBT2(Z l_ e r, INCINT1(hr)) -- dH= 0+ Z ll le lr -> case popRZ ll le lr of+ UBT2(l_,e) -> case l_ of+ E -> pushHL_ l r hr -- l had only 1 element+ _ -> UBT2(Z l_ e r, INCINT1(hr)) -- dH= 0+ P ll le lr -> case popRP ll le lr of+ UBT2(l_,e) -> case l_ of+ Z _ _ _ -> spliceHL l_ DECINT1(hl) e r hr -- dH=-1+ _ -> UBT2(Z l_ e r, INCINT1(hr)) -- dH= 0+ -- hl > hr+ GT -> case r of+ E -> UBT2(l,hl)+ N rl re rr -> case popLN rl re rr of+ UBT2(e,r_) -> case r_ of+ Z _ _ _ -> spliceHR l hl e r_ DECINT1(hr) -- dH=-1+ _ -> spliceHR l hl e r_ hr -- dH= 0+ Z rl re rr -> case popLZ rl re rr of+ UBT2(e,r_) -> case r_ of+ E -> pushHR_ l hl r -- r had only 1 element+ _ -> spliceHR l hl e r_ hr -- dH=0+ P rl re rr -> case popLP rl re rr of+ UBT2(e,r_) -> case r_ of+ Z _ _ _ -> spliceHR l hl e r_ DECINT1(hr) -- dH=-1+ _ -> spliceHR l hl e r_ hr -- dH= 0+++-- | Splice two AVL trees of known height using the supplied bridging element.+-- That is, the bridging element appears \"in the middle\" of the resulting AVL tree.+-- The elements of the first tree argument are to the left of the bridging element and+-- the elements of the second tree are to the right of the bridging element.+--+-- This function does not require that the AVL heights are absolutely correct, only that+-- the difference in supplied heights is equal to the difference in actual heights. So it's+-- OK if the input heights both have the same unknown constant offset. (The output height+-- will also have the same constant offset in this case.)+--+-- Complexity: O(d), where d is the absolute difference in tree heights.+spliceH :: AVL e -> UINT -> e -> AVL e -> UINT -> UBT2(AVL e,UINT)+-- You'd think inlining this function would make a significant difference to many functions+-- (such as set operations), but it doesn't. It makes them marginally slower!!+spliceH l hl b r hr =+ case COMPAREUINT hl hr of+ LT -> spliceHL l hl b r hr+ EQ -> UBT2(Z l b r, INCINT1(hl))+ GT -> spliceHR l hl b r hr++-- Splice two trees of known relative height where hr>hl, using the supplied bridging element,+-- returning another tree of known relative height.+spliceHL :: AVL e -> UINT -> e -> AVL e -> UINT -> UBT2(AVL e,UINT)+spliceHL l hl b r hr = let d = SUBINT(hr,hl)+ in if isTrue# (d EQL L(1)) then UBT2(N l b r, INCINT1(hr))+ else spliceHL_ hr d l b r++-- Splice two trees of known relative height where hl>hr, using the supplied bridging element,+-- returning another tree of known relative height.+spliceHR :: AVL e -> UINT -> e -> AVL e -> UINT -> UBT2(AVL e,UINT)+spliceHR l hl b r hr = let d = SUBINT(hl,hr)+ in if isTrue# (d EQL L(1)) then UBT2(P l b r, INCINT1(hl))+ else spliceHR_ hl d l b r++-- Splice two trees of known relative height where hr>hl+1, using the supplied bridging element,+-- returning another tree of known relative height. d >= 2+{-# INLINE spliceHL_ #-}+spliceHL_ :: UINT -> UINT -> AVL e -> e -> AVL e -> UBT2(AVL e,UINT)+spliceHL_ _ _ _ _ E = error "spliceHL_: Bug0" -- impossible if hr>hl+spliceHL_ hr d l b (N rl re rr) = let r_ = spliceLN l b DECINT2(d) rl re rr+ in r_ `seq` UBT2(r_,hr)+spliceHL_ hr d l b (Z rl re rr) = let r_ = spliceLZ l b DECINT1(d) rl re rr+ in case r_ of+ E -> error "spliceHL_: Bug1"+ Z _ _ _ -> UBT2(r_, hr )+ _ -> UBT2(r_,INCINT1(hr))+spliceHL_ hr d l b (P rl re rr) = let r_ = spliceLP l b DECINT1(d) rl re rr+ in r_ `seq` UBT2(r_,hr)++-- Splice two trees of known relative height where hl>hr+1, using the supplied bridging element,+-- returning another tree of known relative height. d >= 2 !!+{-# INLINE spliceHR_ #-}+spliceHR_ :: UINT -> UINT -> AVL e -> e -> AVL e -> UBT2(AVL e,UINT)+spliceHR_ _ _ E _ _ = error "spliceHR_: Bug0" -- impossible if hl>hr+spliceHR_ hl d (N ll le lr) b r = let l_ = spliceRN r b DECINT1(d) ll le lr+ in l_ `seq` UBT2(l_,hl)+spliceHR_ hl d (Z ll le lr) b r = let l_ = spliceRZ r b DECINT1(d) ll le lr+ in case l_ of+ E -> error "spliceHR_: Bug1"+ Z _ _ _ -> UBT2(l_, hl )+ _ -> UBT2(l_,INCINT1(hl))+spliceHR_ hl d (P ll le lr) b r = let l_ = spliceRP r b DECINT2(d) ll le lr+ in l_ `seq` UBT2(l_,hl)++-- hr >= hl, splice s to left subtree of r, using b as the bridge+-- The Int argument is the absolute difference in tree height, hr-hl (>=0)+spliceL :: AVL e -> e -> UINT -> AVL e -> AVL e+spliceL s b L(0) r = Z s b r+spliceL s b L(1) r = N s b r+spliceL s b d (N rl re rr) = spliceLN s b DECINT2(d) rl re rr -- height diff of rl is two less+spliceL s b d (Z rl re rr) = spliceLZ s b DECINT1(d) rl re rr -- height diff of rl is one less+spliceL s b d (P rl re rr) = spliceLP s b DECINT1(d) rl re rr -- height diff of rl is one less+spliceL _ _ _ E = error "spliceL: Bug0" -- r can't be empty++-- Splice into left subtree of (N l e r), height cannot change as a result of this+spliceLN :: AVL e -> e -> UINT -> AVL e -> e -> AVL e -> AVL e+spliceLN s b L(0) l e r = Z (Z s b l) e r -- dH=0+spliceLN s b L(1) l e r = Z (N s b l) e r -- dH=0+spliceLN s b d (N ll le lr) e r = let l_ = spliceLN s b DECINT2(d) ll le lr in l_ `seq` N l_ e r+spliceLN s b d (Z ll le lr) e r = let l_ = spliceLZ s b DECINT1(d) ll le lr+ in case l_ of+ Z _ _ _ -> N l_ e r -- dH=0+ P _ _ _ -> Z l_ e r -- dH=0+ _ -> error "spliceLN: Bug0" -- impossible+spliceLN s b d (P ll le lr) e r = let l_ = spliceLP s b DECINT1(d) ll le lr in l_ `seq` N l_ e r+spliceLN _ _ _ E _ _ = error "spliceLN: Bug1" -- impossible++-- Splice into left subtree of (Z l e r), Z->P if dH=1, Z->Z if dH=0+spliceLZ :: AVL e -> e -> UINT -> AVL e -> e -> AVL e -> AVL e+spliceLZ s b L(1) l e r = P (N s b l) e r -- Z->P, dH=1+spliceLZ s b d (N ll le lr) e r = let l_ = spliceLN s b DECINT2(d) ll le lr in l_ `seq` Z l_ e r -- Z->Z, dH=0+spliceLZ s b d (Z ll le lr) e r = let l_ = spliceLZ s b DECINT1(d) ll le lr+ in case l_ of+ Z _ _ _ -> Z l_ e r -- Z->Z, dH=0+ P _ _ _ -> P l_ e r -- Z->P, dH=1+ _ -> error "spliceLZ: Bug0" -- impossible+spliceLZ s b d (P ll le lr) e r = let l_ = spliceLP s b DECINT1(d) ll le lr in l_ `seq` Z l_ e r -- Z->Z, dH=0+spliceLZ _ _ _ E _ _ = error "spliceLZ: Bug1" -- impossible++-- Splice into left subtree of (P l e r), height cannot change as a result of this+spliceLP :: AVL e -> e -> UINT -> AVL e -> e -> AVL e -> AVL e+spliceLP s b L(1) (N ll le lr) e r = Z (P s b ll) le (Z lr e r) -- dH=0+spliceLP s b L(1) (Z ll le lr) e r = Z (Z s b ll) le (Z lr e r) -- dH=0+spliceLP s b L(1) (P ll le lr) e r = Z (Z s b ll) le (N lr e r) -- dH=0+spliceLP s b d (N ll le lr) e r = let l_ = spliceLN s b DECINT2(d) ll le lr in l_ `seq` P l_ e r -- dH=0+spliceLP s b d (Z ll le lr) e r = spliceLPZ s b DECINT1(d) ll le lr e r -- dH=0+spliceLP s b d (P ll le lr) e r = let l_ = spliceLP s b DECINT1(d) ll le lr in l_ `seq` P l_ e r -- dH=0+spliceLP _ _ _ E _ _ = error "spliceLP: Bug0"++-- Splice into left subtree of (P (Z ll le lr) e r)+{-# INLINE spliceLPZ #-}+spliceLPZ :: AVL e -> e -> UINT -> AVL e -> e -> AVL e -> e -> AVL e -> AVL e+spliceLPZ s b L(1) ll le lr e r = Z (N s b ll) le (Z lr e r) -- dH=0+spliceLPZ s b d (N lll lle llr) le lr e r = let ll_ = spliceLN s b DECINT2(d) lll lle llr -- dH=0+ in ll_ `seq` P (Z ll_ le lr) e r+spliceLPZ s b d (Z lll lle llr) le lr e r = let ll_ = spliceLZ s b DECINT1(d) lll lle llr -- dH=0+ in case ll_ of+ Z _ _ _ -> P (Z ll_ le lr) e r -- dH=0+ P _ _ _ -> Z ll_ le (Z lr e r) -- dH=0+ _ -> error "spliceLPZ: Bug0" -- impossible+spliceLPZ s b d (P lll lle llr) le lr e r = let ll_ = spliceLP s b DECINT1(d) lll lle llr -- dH=0+ in ll_ `seq` P (Z ll_ le lr) e r+spliceLPZ _ _ _ E _ _ _ _ = error "spliceLPZ: Bug1"++-- hl >= hr, splice s to right subtree of l, using b as the bridge+-- The Int argument is the absolute difference in tree height, hl-hr (>=0)+spliceR :: AVL e -> e -> UINT -> AVL e -> AVL e+spliceR s b L(0) l = Z l b s+spliceR s b L(1) l = P l b s+spliceR s b d (N ll le lr) = spliceRN s b DECINT1(d) ll le lr -- height diff of lr is one less+spliceR s b d (Z ll le lr) = spliceRZ s b DECINT1(d) ll le lr -- height diff of lr is one less+spliceR s b d (P ll le lr) = spliceRP s b DECINT2(d) ll le lr -- height diff of lr is two less+spliceR _ _ _ E = error "spliceR: Bug0" -- l can't be empty++-- Splice into right subtree of (P l e r), height cannot change as a result of this+spliceRP :: AVL e -> e -> UINT -> AVL e -> e -> AVL e -> AVL e+spliceRP s b L(0) l e r = Z l e (Z r b s) -- dH=0+spliceRP s b L(1) l e r = Z l e (P r b s) -- dH=0+spliceRP s b d l e (N rl re rr) = let r_ = spliceRN s b DECINT1(d) rl re rr in r_ `seq` P l e r_+spliceRP s b d l e (Z rl re rr) = let r_ = spliceRZ s b DECINT1(d) rl re rr+ in case r_ of+ Z _ _ _ -> P l e r_ -- dH=0+ N _ _ _ -> Z l e r_ -- dH=0+ _ -> error "spliceRP: Bug0" -- impossible+spliceRP s b d l e (P rl re rr) = let r_ = spliceRP s b DECINT2(d) rl re rr in r_ `seq` P l e r_+spliceRP _ _ _ _ _ E = error "spliceRP: Bug1" -- impossible++-- Splice into right subtree of (Z l e r), Z->N if dH=1, Z->Z if dH=0+spliceRZ :: AVL e -> e -> UINT -> AVL e -> e -> AVL e -> AVL e+spliceRZ s b L(1) l e r = N l e (P r b s) -- Z->N, dH=1+spliceRZ s b d l e (N rl re rr) = let r_ = spliceRN s b DECINT1(d) rl re rr in r_ `seq` Z l e r_ -- Z->Z, dH=0+spliceRZ s b d l e (Z rl re rr) = let r_ = spliceRZ s b DECINT1(d) rl re rr+ in case r_ of+ Z _ _ _ -> Z l e r_ -- Z->Z, dH=0+ N _ _ _ -> N l e r_ -- Z->N, dH=1+ _ -> error "spliceRZ: Bug0" -- impossible+spliceRZ s b d l e (P rl re rr) = let r_ = spliceRP s b DECINT2(d) rl re rr in r_ `seq` Z l e r_ -- Z->Z, dH=0+spliceRZ _ _ _ _ _ E = error "spliceRZ: Bug1" -- impossible++-- Splice into right subtree of (N l e r), height cannot change as a result of this+spliceRN :: AVL e -> e -> UINT -> AVL e -> e -> AVL e -> AVL e+spliceRN s b L(1) l e (N rl re rr) = Z (P l e rl) re (Z rr b s) -- dH=0+spliceRN s b L(1) l e (Z rl re rr) = Z (Z l e rl) re (Z rr b s) -- dH=0+spliceRN s b L(1) l e (P rl re rr) = Z (Z l e rl) re (N rr b s) -- dH=0+spliceRN s b d l e (N rl re rr) = let r_ = spliceRN s b DECINT1(d) rl re rr in r_ `seq` N l e r_ -- dH=0+spliceRN s b d l e (Z rl re rr) = spliceRNZ s b DECINT1(d) l e rl re rr -- dH=0+spliceRN s b d l e (P rl re rr) = let r_ = spliceRP s b DECINT2(d) rl re rr in r_ `seq` N l e r_ -- dH=0+spliceRN _ _ _ _ _ E = error "spliceRN: Bug0"++-- Splice into right subtree of (N l e (Z rl re rr))+{-# INLINE spliceRNZ #-}+spliceRNZ :: AVL e -> e -> UINT -> AVL e -> e -> AVL e -> e -> AVL e -> AVL e+spliceRNZ s b L(1) l e rl re rr = Z (Z l e rl) re (P rr b s) -- dH=0+spliceRNZ s b d l e rl re (N rrl rre rrr) = let rr_ = spliceRN s b DECINT1(d) rrl rre rrr+ in rr_ `seq` N l e (Z rl re rr_) -- dH=0+spliceRNZ s b d l e rl re (Z rrl rre rrr) = let rr_ = spliceRZ s b DECINT1(d) rrl rre rrr -- dH=0+ in case rr_ of+ Z _ _ _ -> N l e (Z rl re rr_) -- dH=0+ N _ _ _ -> Z (Z l e rl) re rr_ -- dH=0+ _ -> error "spliceRNZ: Bug0" -- impossible+spliceRNZ s b d l e rl re (P rrl rre rrr) = let rr_ = spliceRP s b DECINT2(d) rrl rre rrr -- dH=0+ in rr_ `seq` N l e (Z rl re rr_)+spliceRNZ _ _ _ _ _ _ _ E = error "spliceRNZ: Bug1"
+ src/Data/Tree/AVL/Internals/HPush.hs view
@@ -0,0 +1,171 @@+-- |+-- Copyright : (c) Adrian Hey 2004,2005+-- License : BSD3+--+-- Functions for pushing elements into trees of known height.+module Data.Tree.AVL.Internals.HPush+ (pushHL,pushHR,pushHL_,pushHR_,+ ) where++import Data.Tree.AVL.Internals.Types(AVL(..))++import GHC.Base+#include "ghcdefs.h"++-- | A version of 'Data.Tree.AVL.pushL' for an AVL tree of known height.+-- Returns an AVL tree of known height.+-- It's OK if height is relative, with fixed offset. In this case the height of the result+-- will have the same fixed offset.+{-# INLINE pushHL #-}+pushHL :: e -> AVL e -> UINT -> UBT2(AVL e,UINT)+pushHL e t h = pushHL_ (Z E e E) t h++-- | A version of 'Data.Tree.AVL.pushR' for an AVL tree of known height.+-- Returns an AVL tree of known height.+-- It's OK if height is relative, with fixed offset. In this case the height of the result+-- will have the same fixed offset.+{-# INLINE pushHR #-}+pushHR :: AVL e -> UINT -> e -> UBT2(AVL e,UINT)+pushHR t h e = pushHR_ t h (Z E e E)++-- | Push a singleton tree (first arg) in the leftmost position of an AVL tree of known height,+-- returning an AVL tree of known height. It's OK if height is relative, with fixed offset.+-- In this case the height of the result will have the same fixed offset.+--+-- Complexity: O(log n)+pushHL_ :: AVL e -> AVL e -> UINT -> UBT2(AVL e,UINT)+pushHL_ t0 t h = case t of+ E -> UBT2(t0, INCINT1(h)) -- Relative Heights+ N l e r -> let t_ = putNL l e r in t_ `seq` UBT2(t_,h)+ P l e r -> let t_ = putPL l e r in t_ `seq` UBT2(t_,h)+ Z l e r -> let t_ = putZL l e r+ in case t_ of+ Z _ _ _ -> UBT2(t_, h )+ P _ _ _ -> UBT2(t_, INCINT1(h))+ _ -> error "pushHL_: Bug0" -- impossible+ where+ ----------------------------- LEVEL 2 ---------------------------------+ -- putNL, putZL, putPL --+ -----------------------------------------------------------------------++ -- (putNL l e r): Put in L subtree of (N l e r), BF=-1 (Never requires rebalancing) , (never returns P)+ putNL E e r = Z t0 e r -- L subtree empty, H:0->1, parent BF:-1-> 0+ putNL (N ll le lr) e r = let l' = putNL ll le lr -- L subtree BF<>0, H:h->h, parent BF:-1->-1+ in l' `seq` N l' e r+ putNL (P ll le lr) e r = let l' = putPL ll le lr -- L subtree BF<>0, H:h->h, parent BF:-1->-1+ in l' `seq` N l' e r+ putNL (Z ll le lr) e r = let l' = putZL ll le lr -- L subtree BF= 0, so need to look for changes+ in case l' of+ Z _ _ _ -> N l' e r -- L subtree BF:0-> 0, H:h->h , parent BF:-1->-1+ P _ _ _ -> Z l' e r -- L subtree BF:0->+1, H:h->h+1, parent BF:-1-> 0+ _ -> error "pushHL_: Bug1" -- impossible++ -- (putZL l e r): Put in L subtree of (Z l e r), BF= 0 (Never requires rebalancing) , (never returns N)+ putZL E e r = P t0 e r -- L subtree H:0->1, parent BF: 0->+1+ putZL (N ll le lr) e r = let l' = putNL ll le lr -- L subtree BF<>0, H:h->h, parent BF: 0-> 0+ in l' `seq` Z l' e r+ putZL (P ll le lr) e r = let l' = putPL ll le lr -- L subtree BF<>0, H:h->h, parent BF: 0-> 0+ in l' `seq` Z l' e r+ putZL (Z ll le lr) e r = let l' = putZL ll le lr -- L subtree BF= 0, so need to look for changes+ in case l' of+ Z _ _ _ -> Z l' e r -- L subtree BF: 0-> 0, H:h->h , parent BF: 0-> 0+ N _ _ _ -> error "pushHL_: Bug2" -- impossible+ _ -> P l' e r -- L subtree BF: 0->+1, H:h->h+1, parent BF: 0->+1++ -------- This case (PL) may need rebalancing if it goes to LEVEL 3 ---------++ -- (putPL l e r): Put in L subtree of (P l e r), BF=+1 , (never returns N)+ putPL E _ _ = error "pushHL_: Bug3" -- impossible if BF=+1+ putPL (N ll le lr) e r = let l' = putNL ll le lr -- L subtree BF<>0, H:h->h, parent BF:+1->+1+ in l' `seq` P l' e r+ putPL (P ll le lr) e r = let l' = putPL ll le lr -- L subtree BF<>0, H:h->h, parent BF:+1->+1+ in l' `seq` P l' e r+ putPL (Z ll le lr) e r = putPLL ll le lr e r -- LL (never returns N)++ ----------------------------- LEVEL 3 ---------------------------------+ -- putPLL --+ -----------------------------------------------------------------------++ -- (putPLL ll le lr e r): Put in LL subtree of (P (Z ll le lr) e r) , (never returns N)+ {-# INLINE putPLL #-}+ putPLL E le lr e r = Z t0 le (Z lr e r) -- r and lr must also be E, special CASE LL!!+ putPLL (N lll lle llr) le lr e r = let ll' = putNL lll lle llr -- LL subtree BF<>0, H:h->h, so no change+ in ll' `seq` P (Z ll' le lr) e r+ putPLL (P lll lle llr) le lr e r = let ll' = putPL lll lle llr -- LL subtree BF<>0, H:h->h, so no change+ in ll' `seq` P (Z ll' le lr) e r+ putPLL (Z lll lle llr) le lr e r = let ll' = putZL lll lle llr -- LL subtree BF= 0, so need to look for changes+ in case ll' of+ Z _ _ _ -> P (Z ll' le lr) e r -- LL subtree BF: 0-> 0, H:h->h, so no change+ N _ _ _ -> error "pushHL_: Bug4" -- impossible+ _ -> Z ll' le (Z lr e r) -- LL subtree BF: 0->+1, H:h->h+1, parent BF:-1->-2, CASE LL !!++-- | Push a singleton tree (third arg) in the rightmost position of an AVL tree of known height,+-- returning an AVL tree of known height. It's OK if height is relative, with fixed offset.+-- In this case the height of the result will have the same fixed offset.+--+-- Complexity: O(log n)+pushHR_ :: AVL e -> UINT -> AVL e -> UBT2(AVL e,UINT)+pushHR_ t h t0 = case t of+ E -> UBT2(t0, INCINT1(h)) -- Relative Heights+ N l e r -> let t_ = putNR l e r in t_ `seq` UBT2(t_,h)+ P l e r -> let t_ = putPR l e r in t_ `seq` UBT2(t_,h)+ Z l e r -> let t_ = putZR l e r+ in case t_ of+ Z _ _ _ -> UBT2(t_, h )+ N _ _ _ -> UBT2(t_, INCINT1(h))+ _ -> error "pushHR_: Bug0" -- impossible+ where+ ----------------------------- LEVEL 2 ---------------------------------+ -- putNR, putZR, putPR --+ -----------------------------------------------------------------------++ -- (putZR l e r): Put in R subtree of (Z l e r), BF= 0 (Never requires rebalancing) , (never returns P)+ putZR l e E = N l e t0 -- R subtree H:0->1, parent BF: 0->-1+ putZR l e (N rl re rr) = let r' = putNR rl re rr -- R subtree BF<>0, H:h->h, parent BF: 0-> 0+ in r' `seq` Z l e r'+ putZR l e (P rl re rr) = let r' = putPR rl re rr -- R subtree BF<>0, H:h->h, parent BF: 0-> 0+ in r' `seq` Z l e r'+ putZR l e (Z rl re rr) = let r' = putZR rl re rr -- R subtree BF= 0, so need to look for changes+ in case r' of+ Z _ _ _ -> Z l e r' -- R subtree BF: 0-> 0, H:h->h , parent BF: 0-> 0+ N _ _ _ -> N l e r' -- R subtree BF: 0->-1, H:h->h+1, parent BF: 0->-1+ _ -> error "pushHR_: Bug1" -- impossible++ -- (putPR l e r): Put in R subtree of (P l e r), BF=+1 (Never requires rebalancing) , (never returns N)+ putPR l e E = Z l e t0 -- R subtree empty, H:0->1, parent BF:+1-> 0+ putPR l e (N rl re rr) = let r' = putNR rl re rr -- R subtree BF<>0, H:h->h, parent BF:+1->+1+ in r' `seq` P l e r'+ putPR l e (P rl re rr) = let r' = putPR rl re rr -- R subtree BF<>0, H:h->h, parent BF:+1->+1+ in r' `seq` P l e r'+ putPR l e (Z rl re rr) = let r' = putZR rl re rr -- R subtree BF= 0, so need to look for changes+ in case r' of+ Z _ _ _ -> P l e r' -- R subtree BF:0-> 0, H:h->h , parent BF:+1->+1+ N _ _ _ -> Z l e r' -- R subtree BF:0->-1, H:h->h+1, parent BF:+1-> 0+ _ -> error "pushHR_: Bug2" -- impossible++ -------- This case (NR) may need rebalancing if it goes to LEVEL 3 ---------++ -- (putNR l e r): Put in R subtree of (N l e r), BF=-1 , (never returns P)+ putNR _ _ E = error "pushHR_: Bug3" -- impossible if BF=-1+ putNR l e (N rl re rr) = let r' = putNR rl re rr -- R subtree BF<>0, H:h->h, parent BF:-1->-1+ in r' `seq` N l e r'+ putNR l e (P rl re rr) = let r' = putPR rl re rr -- R subtree BF<>0, H:h->h, parent BF:-1->-1+ in r' `seq` N l e r'+ putNR l e (Z rl re rr) = putNRR l e rl re rr -- RR (never returns P)++ ----------------------------- LEVEL 3 ---------------------------------+ -- putNRR --+ -----------------------------------------------------------------------++ -- (putNRR l e rl re rr): Put in RR subtree of (N l e (Z rl re rr)) , (never returns P)+ {-# INLINE putNRR #-}+ putNRR l e rl re E = Z (Z l e rl) re t0 -- l and rl must also be E, special CASE RR!!+ putNRR l e rl re (N rrl rre rrr) = let rr' = putNR rrl rre rrr -- RR subtree BF<>0, H:h->h, so no change+ in rr' `seq` N l e (Z rl re rr')+ putNRR l e rl re (P rrl rre rrr) = let rr' = putPR rrl rre rrr -- RR subtree BF<>0, H:h->h, so no change+ in rr' `seq` N l e (Z rl re rr')+ putNRR l e rl re (Z rrl rre rrr) = let rr' = putZR rrl rre rrr -- RR subtree BF= 0, so need to look for changes+ in case rr' of+ Z _ _ _ -> N l e (Z rl re rr') -- RR subtree BF: 0-> 0, H:h->h, so no change+ N _ _ _ -> Z (Z l e rl) re rr' -- RR subtree BF: 0->-1, H:h->h+1, parent BF:-1->-2, CASE RR !!+ _ -> error "pushHR_: Bug4" -- impossible
+ src/Data/Tree/AVL/Internals/HSet.hs view
@@ -0,0 +1,950 @@+-- |+-- Copyright : (c) Adrian Hey 2004,2005+-- License : BSD3+--+-- Set primitives on AVL trees with (height information supplied where needed).+-- All the functions in this module use essentially the same symetric \"Divide and Conquer\" algorithm.+module Data.Tree.AVL.Internals.HSet+ (-- * Union primitives.+ unionH,unionMaybeH,disjointUnionH,++ -- * Intersection primitives.+ intersectionH,intersectionMaybeH,++ -- * Difference primitives.+ differenceH,differenceMaybeH,symDifferenceH,++ -- * Venn primitives+ vennH,vennMaybeH,+ ) where++import Data.Tree.AVL.Internals.Types(AVL(..))+import Data.Tree.AVL.Internals.HJoin(spliceH,joinH)++import Data.COrdering++import GHC.Base+#include "ghcdefs.h"++-- | Uses the supplied combining comparison to evaluate the union of two sets represented as+-- sorted AVL trees of known height. Whenever the combining comparison is applied, the first+-- comparison argument is an element of the first tree and the second comparison argument is+-- an element of the second tree.+--+-- Complexity: Not sure, but I\'d appreciate it if someone could figure it out.+-- (Faster than Hedge union from Data.Set at any rate).+unionH :: (e -> e -> COrdering e) -> AVL e -> UINT -> AVL e -> UINT -> UBT2(AVL e,UINT)+unionH c = u where+ -- u :: AVL e -> UINT -> AVL e -> UINT -> UBT2(AVL e,UINT)+ u E _ t1 h1 = UBT2(t1,h1)+ u t0 h0 E _ = UBT2(t0,h0)+ u (N l0 e0 r0) h0 (N l1 e1 r1) h1 = u_ l0 DECINT2(h0) e0 r0 DECINT1(h0) l1 DECINT2(h1) e1 r1 DECINT1(h1)+ u (N l0 e0 r0) h0 (Z l1 e1 r1) h1 = u_ l0 DECINT2(h0) e0 r0 DECINT1(h0) l1 DECINT1(h1) e1 r1 DECINT1(h1)+ u (N l0 e0 r0) h0 (P l1 e1 r1) h1 = u_ l0 DECINT2(h0) e0 r0 DECINT1(h0) l1 DECINT1(h1) e1 r1 DECINT2(h1)+ u (Z l0 e0 r0) h0 (N l1 e1 r1) h1 = u_ l0 DECINT1(h0) e0 r0 DECINT1(h0) l1 DECINT2(h1) e1 r1 DECINT1(h1)+ u (Z l0 e0 r0) h0 (Z l1 e1 r1) h1 = u_ l0 DECINT1(h0) e0 r0 DECINT1(h0) l1 DECINT1(h1) e1 r1 DECINT1(h1)+ u (Z l0 e0 r0) h0 (P l1 e1 r1) h1 = u_ l0 DECINT1(h0) e0 r0 DECINT1(h0) l1 DECINT1(h1) e1 r1 DECINT2(h1)+ u (P l0 e0 r0) h0 (N l1 e1 r1) h1 = u_ l0 DECINT1(h0) e0 r0 DECINT2(h0) l1 DECINT2(h1) e1 r1 DECINT1(h1)+ u (P l0 e0 r0) h0 (Z l1 e1 r1) h1 = u_ l0 DECINT1(h0) e0 r0 DECINT2(h0) l1 DECINT1(h1) e1 r1 DECINT1(h1)+ u (P l0 e0 r0) h0 (P l1 e1 r1) h1 = u_ l0 DECINT1(h0) e0 r0 DECINT2(h0) l1 DECINT1(h1) e1 r1 DECINT2(h1)+ u_ l0 hl0 e0 r0 hr0 l1 hl1 e1 r1 hr1 =+ case c e0 e1 of+ -- e0 < e1, so (l0 < e0 < e1) & (e0 < e1 < r1)+ Lt -> case forkR r0 hr0 e1 of+ UBT5(rl0,hrl0,e1_,rr0,hrr0) -> case forkL e0 l1 hl1 of -- (e0 < rl0 < e1) & (e0 < e1 < rr0)+ UBT5(ll1,hll1,e0_,lr1,hlr1) -> -- (ll1 < e0 < e1) & (e0 < lr1 < e1)+ -- (l0 + ll1) < e0 < (rl0 + lr1) < e1 < (rr0 + r1)+ case u l0 hl0 ll1 hll1 of+ UBT2(l,hl) -> case u rl0 hrl0 lr1 hlr1 of+ UBT2(m,hm) -> case u rr0 hrr0 r1 hr1 of+ UBT2(r,hr) -> case spliceH m hm e1_ r hr of+ UBT2(t,ht) -> spliceH l hl e0_ t ht+ -- e0 = e1+ Eq e -> case u l0 hl0 l1 hl1 of+ UBT2(l,hl) -> case u r0 hr0 r1 hr1 of+ UBT2(r,hr) -> spliceH l hl e r hr+ -- e1 < e0, so (l1 < e1 < e0) & (e1 < e0 < r0)+ Gt -> case forkL e0 r1 hr1 of+ UBT5(rl1,hrl1,e0_,rr1,hrr1) -> case forkR l0 hl0 e1 of -- (e1 < rl1 < e0) & (e1 < e0 < rr1)+ UBT5(ll0,hll0,e1_,lr0,hlr0) -> -- (ll0 < e1 < e0) & (e1 < lr0 < e0)+ -- (ll0 + l1) < e1 < (lr0 + rl1) < e0 < (r0 + rr1)+ case u ll0 hll0 l1 hl1 of+ UBT2(l,hl) -> case u lr0 hlr0 rl1 hrl1 of+ UBT2(m,hm) -> case u r0 hr0 rr1 hrr1 of+ UBT2(r,hr) -> case spliceH l hl e1_ m hm of+ UBT2(t,ht) -> spliceH t ht e0_ r hr+ -- We need 2 different versions of fork (L & R) to ensure that comparison arguments are used in+ -- the right order (c e0 e1)+ -- forkL :: e -> AVL e -> UINT -> UBT5(AVL e,UINT,e,AVL e,UINT)+ forkL e0 t1 ht1 = forkL_ t1 ht1 where+ forkL_ E _ = UBT5(E, L(0), e0, E, L(0))+ forkL_ (N l e r) h = forkL__ l DECINT2(h) e r DECINT1(h)+ forkL_ (Z l e r) h = forkL__ l DECINT1(h) e r DECINT1(h)+ forkL_ (P l e r) h = forkL__ l DECINT1(h) e r DECINT2(h)+ forkL__ l hl e r hr = case c e0 e of+ Lt -> case forkL_ l hl of+ UBT5(l0,hl0,e0_,l1,hl1) -> case spliceH l1 hl1 e r hr of+ UBT2(l1_,hl1_) -> UBT5(l0,hl0,e0_,l1_,hl1_)+ Eq e0_ -> UBT5(l,hl,e0_,r,hr)+ Gt -> case forkL_ r hr of+ UBT5(l0,hl0,e0_,l1,hl1) -> case spliceH l hl e l0 hl0 of+ UBT2(l0_,hl0_) -> UBT5(l0_,hl0_,e0_,l1,hl1)+ -- forkR :: AVL e -> UINT -> e -> UBT5(AVL e,UINT,e,AVL e,UINT)+ forkR t0 ht0 e1 = forkR_ t0 ht0 where+ forkR_ E _ = UBT5(E, L(0), e1, E, L(0))+ forkR_ (N l e r) h = forkR__ l DECINT2(h) e r DECINT1(h)+ forkR_ (Z l e r) h = forkR__ l DECINT1(h) e r DECINT1(h)+ forkR_ (P l e r) h = forkR__ l DECINT1(h) e r DECINT2(h)+ forkR__ l hl e r hr = case c e e1 of+ Lt -> case forkR_ r hr of+ UBT5(l0,hl0,e1_,l1,hl1) -> case spliceH l hl e l0 hl0 of+ UBT2(l0_,hl0_) -> UBT5(l0_,hl0_,e1_,l1,hl1)+ Eq e1_ -> UBT5(l,hl,e1_,r,hr)+ Gt -> case forkR_ l hl of+ UBT5(l0,hl0,e1_,l1,hl1) -> case spliceH l1 hl1 e r hr of+ UBT2(l1_,hl1_) -> UBT5(l0,hl0,e1_,l1_,hl1_)++-- | Similar to _unionH_, but the resulting tree does not include elements in cases where+-- the supplied combining comparison returns @(Eq Nothing)@.+--+-- Complexity: Not sure, but I\'d appreciate it if someone could figure it out.+unionMaybeH :: (e -> e -> COrdering (Maybe e)) -> AVL e -> UINT -> AVL e -> UINT -> UBT2(AVL e,UINT)+unionMaybeH c = u where+ -- u :: AVL e -> UINT -> AVL e -> UINT -> UBT2(AVL e,UINT)+ u E _ t1 h1 = UBT2(t1,h1)+ u t0 h0 E _ = UBT2(t0,h0)+ u (N l0 e0 r0) h0 (N l1 e1 r1) h1 = u_ l0 DECINT2(h0) e0 r0 DECINT1(h0) l1 DECINT2(h1) e1 r1 DECINT1(h1)+ u (N l0 e0 r0) h0 (Z l1 e1 r1) h1 = u_ l0 DECINT2(h0) e0 r0 DECINT1(h0) l1 DECINT1(h1) e1 r1 DECINT1(h1)+ u (N l0 e0 r0) h0 (P l1 e1 r1) h1 = u_ l0 DECINT2(h0) e0 r0 DECINT1(h0) l1 DECINT1(h1) e1 r1 DECINT2(h1)+ u (Z l0 e0 r0) h0 (N l1 e1 r1) h1 = u_ l0 DECINT1(h0) e0 r0 DECINT1(h0) l1 DECINT2(h1) e1 r1 DECINT1(h1)+ u (Z l0 e0 r0) h0 (Z l1 e1 r1) h1 = u_ l0 DECINT1(h0) e0 r0 DECINT1(h0) l1 DECINT1(h1) e1 r1 DECINT1(h1)+ u (Z l0 e0 r0) h0 (P l1 e1 r1) h1 = u_ l0 DECINT1(h0) e0 r0 DECINT1(h0) l1 DECINT1(h1) e1 r1 DECINT2(h1)+ u (P l0 e0 r0) h0 (N l1 e1 r1) h1 = u_ l0 DECINT1(h0) e0 r0 DECINT2(h0) l1 DECINT2(h1) e1 r1 DECINT1(h1)+ u (P l0 e0 r0) h0 (Z l1 e1 r1) h1 = u_ l0 DECINT1(h0) e0 r0 DECINT2(h0) l1 DECINT1(h1) e1 r1 DECINT1(h1)+ u (P l0 e0 r0) h0 (P l1 e1 r1) h1 = u_ l0 DECINT1(h0) e0 r0 DECINT2(h0) l1 DECINT1(h1) e1 r1 DECINT2(h1)+ u_ l0 hl0 e0 r0 hr0 l1 hl1 e1 r1 hr1 =+ case c e0 e1 of+ -- e0 < e1, so (l0 < e0 < e1) & (e0 < e1 < r1)+ Lt -> case forkR r0 hr0 e1 of+ UBT5(rl0,hrl0,mbe1_,rr0,hrr0) -> case forkL e0 l1 hl1 of -- (e0 < rl0 < e1) & (e0 < e1 < rr0)+ UBT5(ll1,hll1,mbe0_,lr1,hlr1) -> -- (ll1 < e0 < e1) & (e0 < lr1 < e1)+ -- (l0 + ll1) < e0 < (rl0 + lr1) < e1 < (rr0 + r1)+ case u l0 hl0 ll1 hll1 of+ UBT2(l,hl) -> case u rl0 hrl0 lr1 hlr1 of+ UBT2(m,hm) -> case u rr0 hrr0 r1 hr1 of+ UBT2(r,hr) -> case (case mbe1_ of+ Just e1_ -> spliceH m hm e1_ r hr+ Nothing -> joinH m hm r hr+ ) of+ UBT2(t,ht) -> case mbe0_ of+ Just e0_ -> spliceH l hl e0_ t ht+ Nothing -> joinH l hl t ht+ -- e0 = e1+ Eq mbe -> case u l0 hl0 l1 hl1 of+ UBT2(l,hl) -> case u r0 hr0 r1 hr1 of+ UBT2(r,hr) -> case mbe of+ Just e -> spliceH l hl e r hr+ Nothing -> joinH l hl r hr+ -- e1 < e0, so (l1 < e1 < e0) & (e1 < e0 < r0)+ Gt -> case forkL e0 r1 hr1 of+ UBT5(rl1,hrl1,mbe0_,rr1,hrr1) -> case forkR l0 hl0 e1 of -- (e1 < rl1 < e0) & (e1 < e0 < rr1)+ UBT5(ll0,hll0,mbe1_,lr0,hlr0) -> -- (ll0 < e1 < e0) & (e1 < lr0 < e0)+ -- (ll0 + l1) < e1 < (lr0 + rl1) < e0 < (r0 + rr1)+ case u ll0 hll0 l1 hl1 of+ UBT2(l,hl) -> case u lr0 hlr0 rl1 hrl1 of+ UBT2(m,hm) -> case u r0 hr0 rr1 hrr1 of+ UBT2(r,hr) -> case (case mbe1_ of+ Just e1_ -> spliceH l hl e1_ m hm+ Nothing -> joinH l hl m hm+ ) of+ UBT2(t,ht) -> case mbe0_ of+ Just e0_ -> spliceH t ht e0_ r hr+ Nothing -> joinH t ht r hr+ -- We need 2 different versions of fork (L & R) to ensure that comparison arguments are used in+ -- the right order (c e0 e1)+ -- forkL :: e -> AVL e -> UINT -> UBT5(AVL e,UINT,Maybe e,AVL e,UINT)+ forkL e0 t1 ht1 = forkL_ t1 ht1 where+ forkL_ E _ = UBT5(E, L(0), Just e0, E, L(0))+ forkL_ (N l e r) h = forkL__ l DECINT2(h) e r DECINT1(h)+ forkL_ (Z l e r) h = forkL__ l DECINT1(h) e r DECINT1(h)+ forkL_ (P l e r) h = forkL__ l DECINT1(h) e r DECINT2(h)+ forkL__ l hl e r hr = case c e0 e of+ Lt -> case forkL_ l hl of+ UBT5(l0,hl0,mbe0_,l1,hl1) -> case spliceH l1 hl1 e r hr of+ UBT2(l1_,hl1_) -> UBT5(l0,hl0,mbe0_,l1_,hl1_)+ Eq mbe0_ -> UBT5(l,hl,mbe0_,r,hr)+ Gt -> case forkL_ r hr of+ UBT5(l0,hl0,mbe0_,l1,hl1) -> case spliceH l hl e l0 hl0 of+ UBT2(l0_,hl0_) -> UBT5(l0_,hl0_,mbe0_,l1,hl1)+ -- forkR :: AVL e -> UINT -> e -> UBT5(AVL e,UINT,Maybe e,AVL e,UINT)+ forkR t0 ht0 e1 = forkR_ t0 ht0 where+ forkR_ E _ = UBT5(E, L(0), Just e1, E, L(0))+ forkR_ (N l e r) h = forkR__ l DECINT2(h) e r DECINT1(h)+ forkR_ (Z l e r) h = forkR__ l DECINT1(h) e r DECINT1(h)+ forkR_ (P l e r) h = forkR__ l DECINT1(h) e r DECINT2(h)+ forkR__ l hl e r hr = case c e e1 of+ Lt -> case forkR_ r hr of+ UBT5(l0,hl0,mbe1_,l1,hl1) -> case spliceH l hl e l0 hl0 of+ UBT2(l0_,hl0_) -> UBT5(l0_,hl0_,mbe1_,l1,hl1)+ Eq mbe1_ -> UBT5(l,hl,mbe1_,r,hr)+ Gt -> case forkR_ l hl of+ UBT5(l0,hl0,mbe1_,l1,hl1) -> case spliceH l1 hl1 e r hr of+ UBT2(l1_,hl1_) -> UBT5(l0,hl0,mbe1_,l1_,hl1_)++-- | Uses the supplied comparison to evaluate the union of two /disjoint/ sets represented as+-- sorted AVL trees of known height. This function raises an error if the two sets intersect.+--+-- Complexity: Not sure, but I\'d appreciate it if someone could figure it out.+-- (Faster than Hedge union from Data.Set at any rate).+disjointUnionH :: (e -> e -> Ordering) -> AVL e -> UINT -> AVL e -> UINT -> UBT2(AVL e,UINT)+disjointUnionH c = u where+ -- u :: AVL e -> UINT -> AVL e -> UINT -> UBT2(AVL e,UINT)+ u E _ t1 h1 = UBT2(t1,h1)+ u t0 h0 E _ = UBT2(t0,h0)+ u (N l0 e0 r0) h0 (N l1 e1 r1) h1 = u_ l0 DECINT2(h0) e0 r0 DECINT1(h0) l1 DECINT2(h1) e1 r1 DECINT1(h1)+ u (N l0 e0 r0) h0 (Z l1 e1 r1) h1 = u_ l0 DECINT2(h0) e0 r0 DECINT1(h0) l1 DECINT1(h1) e1 r1 DECINT1(h1)+ u (N l0 e0 r0) h0 (P l1 e1 r1) h1 = u_ l0 DECINT2(h0) e0 r0 DECINT1(h0) l1 DECINT1(h1) e1 r1 DECINT2(h1)+ u (Z l0 e0 r0) h0 (N l1 e1 r1) h1 = u_ l0 DECINT1(h0) e0 r0 DECINT1(h0) l1 DECINT2(h1) e1 r1 DECINT1(h1)+ u (Z l0 e0 r0) h0 (Z l1 e1 r1) h1 = u_ l0 DECINT1(h0) e0 r0 DECINT1(h0) l1 DECINT1(h1) e1 r1 DECINT1(h1)+ u (Z l0 e0 r0) h0 (P l1 e1 r1) h1 = u_ l0 DECINT1(h0) e0 r0 DECINT1(h0) l1 DECINT1(h1) e1 r1 DECINT2(h1)+ u (P l0 e0 r0) h0 (N l1 e1 r1) h1 = u_ l0 DECINT1(h0) e0 r0 DECINT2(h0) l1 DECINT2(h1) e1 r1 DECINT1(h1)+ u (P l0 e0 r0) h0 (Z l1 e1 r1) h1 = u_ l0 DECINT1(h0) e0 r0 DECINT2(h0) l1 DECINT1(h1) e1 r1 DECINT1(h1)+ u (P l0 e0 r0) h0 (P l1 e1 r1) h1 = u_ l0 DECINT1(h0) e0 r0 DECINT2(h0) l1 DECINT1(h1) e1 r1 DECINT2(h1)+ u_ l0 hl0 e0 r0 hr0 l1 hl1 e1 r1 hr1 =+ case c e0 e1 of+ -- e0 < e1, so (l0 < e0 < e1) & (e0 < e1 < r1)+ LT -> case fork e1 r0 hr0 of+ UBT4(rl0,hrl0,rr0,hrr0) -> case fork e0 l1 hl1 of -- (e0 < rl0 < e1) & (e0 < e1 < rr0)+ UBT4(ll1,hll1,lr1,hlr1) -> -- (ll1 < e0 < e1) & (e0 < lr1 < e1)+ -- (l0 + ll1) < e0 < (rl0 + lr1) < e1 < (rr0 + r1)+ case u l0 hl0 ll1 hll1 of+ UBT2(l,hl) -> case u rl0 hrl0 lr1 hlr1 of+ UBT2(m,hm) -> case u rr0 hrr0 r1 hr1 of+ UBT2(r,hr) -> case spliceH m hm e1 r hr of+ UBT2(t,ht) -> spliceH l hl e0 t ht+ -- e0 = e1+ EQ -> error "disjointUnionH: Trees intersect" `seq` UBT2(E,L(0))+ -- e1 < e0, so (l1 < e1 < e0) & (e1 < e0 < r0)+ GT -> case fork e0 r1 hr1 of+ UBT4(rl1,hrl1,rr1,hrr1) -> case fork e1 l0 hl0 of -- (e1 < rl1 < e0) & (e1 < e0 < rr1)+ UBT4(ll0,hll0,lr0,hlr0) -> -- (ll0 < e1 < e0) & (e1 < lr0 < e0)+ -- (ll0 + l1) < e1 < (lr0 + rl1) < e0 < (r0 + rr1)+ case u ll0 hll0 l1 hl1 of+ UBT2(l,hl) -> case u lr0 hlr0 rl1 hrl1 of+ UBT2(m,hm) -> case u r0 hr0 rr1 hrr1 of+ UBT2(r,hr) -> case spliceH l hl e1 m hm of+ UBT2(t,ht) -> spliceH t ht e0 r hr+ -- fork :: e -> AVL e -> UINT -> UBT4(AVL e,UINT,AVL e,UINT)+ fork e0 t1 ht1 = fork_ t1 ht1 where+ fork_ E _ = UBT4(E, L(0), E, L(0))+ fork_ (N l e r) h = fork__ l DECINT2(h) e r DECINT1(h)+ fork_ (Z l e r) h = fork__ l DECINT1(h) e r DECINT1(h)+ fork_ (P l e r) h = fork__ l DECINT1(h) e r DECINT2(h)+ fork__ l hl e r hr = case c e0 e of+ LT -> case fork_ l hl of+ UBT4(l0,hl0,l1,hl1) -> case spliceH l1 hl1 e r hr of+ UBT2(l1_,hl1_) -> UBT4(l0,hl0,l1_,hl1_)+ EQ -> error "disjointUnionH: Trees intersect" `seq` UBT4(E, L(0), E, L(0))+ GT -> case fork_ r hr of+ UBT4(l0,hl0,l1,hl1) -> case spliceH l hl e l0 hl0 of+ UBT2(l0_,hl0_) -> UBT4(l0_,hl0_,l1,hl1)++-- | Uses the supplied combining comparison to evaluate the intersection of two sets represented as+-- sorted AVL trees. This function requires no height information at all for+-- the two tree inputs. The absolute height of the resulting tree is returned also.+--+-- Complexity: Not sure, but I\'d appreciate it if someone could figure it out.+intersectionH :: (a -> b -> COrdering c) -> AVL a -> AVL b -> UBT2(AVL c,UINT)+intersectionH cmp = i where+ -- i :: AVL a -> AVL b -> UBT2(AVL c,UINT)+ i E _ = UBT2(E,L(0))+ i _ E = UBT2(E,L(0))+ i (N l0 e0 r0) (N l1 e1 r1) = i_ l0 e0 r0 l1 e1 r1+ i (N l0 e0 r0) (Z l1 e1 r1) = i_ l0 e0 r0 l1 e1 r1+ i (N l0 e0 r0) (P l1 e1 r1) = i_ l0 e0 r0 l1 e1 r1+ i (Z l0 e0 r0) (N l1 e1 r1) = i_ l0 e0 r0 l1 e1 r1+ i (Z l0 e0 r0) (Z l1 e1 r1) = i_ l0 e0 r0 l1 e1 r1+ i (Z l0 e0 r0) (P l1 e1 r1) = i_ l0 e0 r0 l1 e1 r1+ i (P l0 e0 r0) (N l1 e1 r1) = i_ l0 e0 r0 l1 e1 r1+ i (P l0 e0 r0) (Z l1 e1 r1) = i_ l0 e0 r0 l1 e1 r1+ i (P l0 e0 r0) (P l1 e1 r1) = i_ l0 e0 r0 l1 e1 r1+ i_ l0 e0 r0 l1 e1 r1 =+ case cmp e0 e1 of+ -- e0 < e1, so (l0 < e0 < e1) & (e0 < e1 < r1)+ Lt -> case forkR r0 e1 of+ UBT5(rl0,_,mbc1,rr0,_) -> case forkL e0 l1 of -- (e0 < rl0 < e1) & (e0 < e1 < rr0)+ UBT5(ll1,_,mbc0,lr1,_) -> -- (ll1 < e0 < e1) & (e0 < lr1 < e1)+ -- (l0 + ll1) < e0 < (rl0 + lr1) < e1 < (rr0 + r1)+ case i rr0 r1 of+ UBT2(r,hr) -> case i rl0 lr1 of+ UBT2(m,hm) -> case i l0 ll1 of+ UBT2(l,hl) -> case (case mbc1 of+ Just c1 -> spliceH m hm c1 r hr+ Nothing -> joinH m hm r hr+ ) of+ UBT2(t,ht) -> case mbc0 of+ Just c0 -> spliceH l hl c0 t ht+ Nothing -> joinH l hl t ht+ -- e0 = e1+ Eq c -> case i l0 l1 of+ UBT2(l,hl) -> case i r0 r1 of+ UBT2(r,hr) -> spliceH l hl c r hr+ -- e1 < e0, so (l1 < e1 < e0) & (e1 < e0 < r0)+ Gt -> case forkL e0 r1 of+ UBT5(rl1,_,mbc0,rr1,_) -> case forkR l0 e1 of -- (e1 < rl1 < e0) & (e1 < e0 < rr1)+ UBT5(ll0,_,mbc1,lr0,_) -> -- (ll0 < e1 < e0) & (e1 < lr0 < e0)+ -- (ll0 + l1) < e1 < (lr0 + rl1) < e0 < (r0 + rr1)+ case i r0 rr1 of+ UBT2(r,hr) -> case i lr0 rl1 of+ UBT2(m,hm) -> case i ll0 l1 of+ UBT2(l,hl) -> case (case mbc0 of+ Just c0 -> spliceH m hm c0 r hr+ Nothing -> joinH m hm r hr+ ) of+ UBT2(t,ht) -> case mbc1 of+ Just c1 -> spliceH l hl c1 t ht+ Nothing -> joinH l hl t ht+ -- We need 2 different versions of fork (L & R) to ensure that comparison arguments are used in+ -- the right order (c e0 e1)+ -- forkL :: a -> AVL b -> UBT5(AVL b,UINT,Maybe c,AVL b,UINT)+ forkL e0 t1 = forkL_ t1 L(0) where+ forkL_ E h = UBT5(E,h,Nothing,E,h) -- Relative heights!!+ forkL_ (N l e r) h = forkL__ l DECINT2(h) e r DECINT1(h)+ forkL_ (Z l e r) h = forkL__ l DECINT1(h) e r DECINT1(h)+ forkL_ (P l e r) h = forkL__ l DECINT1(h) e r DECINT2(h)+ forkL__ l hl e r hr = case cmp e0 e of+ Lt -> case forkL_ l hl of+ UBT5(l0,hl0,mbc0,l1,hl1) -> case spliceH l1 hl1 e r hr of+ UBT2(l1_,hl1_) -> UBT5(l0,hl0,mbc0,l1_,hl1_)+ Eq c0 -> UBT5(l,hl,Just c0,r,hr)+ Gt -> case forkL_ r hr of+ UBT5(l0,hl0,mbc0,l1,hl1) -> case spliceH l hl e l0 hl0 of+ UBT2(l0_,hl0_) -> UBT5(l0_,hl0_,mbc0,l1,hl1)+ -- forkR :: AVL a -> b -> UBT5(AVL a,UINT,Maybe c,AVL a,UINT)+ forkR t0 e1 = forkR_ t0 L(0) where+ forkR_ E h = UBT5(E,h,Nothing,E,h) -- Relative heights!!+ forkR_ (N l e r) h = forkR__ l DECINT2(h) e r DECINT1(h)+ forkR_ (Z l e r) h = forkR__ l DECINT1(h) e r DECINT1(h)+ forkR_ (P l e r) h = forkR__ l DECINT1(h) e r DECINT2(h)+ forkR__ l hl e r hr = case cmp e e1 of+ Lt -> case forkR_ r hr of+ UBT5(l0,hl0,mbc1,l1,hl1) -> case spliceH l hl e l0 hl0 of+ UBT2(l0_,hl0_) -> UBT5(l0_,hl0_,mbc1,l1,hl1)+ Eq c1 -> UBT5(l,hl,Just c1,r,hr)+ Gt -> case forkR_ l hl of+ UBT5(l0,hl0,mbc1,l1,hl1) -> case spliceH l1 hl1 e r hr of+ UBT2(l1_,hl1_) -> UBT5(l0,hl0,mbc1,l1_,hl1_)++-- | Similar to _intersectionH_, but the resulting tree does not include elements in cases where+-- the supplied combining comparison returns @(Eq Nothing)@.+--+-- Complexity: Not sure, but I\'d appreciate it if someone could figure it out.+intersectionMaybeH :: (a -> b -> COrdering (Maybe c)) -> AVL a -> AVL b -> UBT2(AVL c,UINT)+intersectionMaybeH comp = i where+ -- i :: AVL a -> AVL b -> UBT2(AVL c,UINT)+ i E _ = UBT2(E,L(0))+ i _ E = UBT2(E,L(0))+ i (N l0 e0 r0) (N l1 e1 r1) = i_ l0 e0 r0 l1 e1 r1+ i (N l0 e0 r0) (Z l1 e1 r1) = i_ l0 e0 r0 l1 e1 r1+ i (N l0 e0 r0) (P l1 e1 r1) = i_ l0 e0 r0 l1 e1 r1+ i (Z l0 e0 r0) (N l1 e1 r1) = i_ l0 e0 r0 l1 e1 r1+ i (Z l0 e0 r0) (Z l1 e1 r1) = i_ l0 e0 r0 l1 e1 r1+ i (Z l0 e0 r0) (P l1 e1 r1) = i_ l0 e0 r0 l1 e1 r1+ i (P l0 e0 r0) (N l1 e1 r1) = i_ l0 e0 r0 l1 e1 r1+ i (P l0 e0 r0) (Z l1 e1 r1) = i_ l0 e0 r0 l1 e1 r1+ i (P l0 e0 r0) (P l1 e1 r1) = i_ l0 e0 r0 l1 e1 r1+ i_ l0 e0 r0 l1 e1 r1 =+ case comp e0 e1 of+ -- e0 < e1, so (l0 < e0 < e1) & (e0 < e1 < r1)+ Lt -> case forkR r0 e1 of+ UBT5(rl0,_,mbc1,rr0,_) -> case forkL e0 l1 of -- (e0 < rl0 < e1) & (e0 < e1 < rr0)+ UBT5(ll1,_,mbc0,lr1,_) -> -- (ll1 < e0 < e1) & (e0 < lr1 < e1)+ -- (l0 + ll1) < e0 < (rl0 + lr1) < e1 < (rr0 + r1)+ case i rr0 r1 of+ UBT2(r,hr) -> case i rl0 lr1 of+ UBT2(m,hm) -> case i l0 ll1 of+ UBT2(l,hl) -> case (case mbc1 of+ Just c1 -> spliceH m hm c1 r hr+ Nothing -> joinH m hm r hr+ ) of+ UBT2(t,ht) -> case mbc0 of+ Just c0 -> spliceH l hl c0 t ht+ Nothing -> joinH l hl t ht+ -- e0 = e1+ Eq mbc -> case i l0 l1 of+ UBT2(l,hl) -> case i r0 r1 of+ UBT2(r,hr) -> case mbc of+ Just c -> spliceH l hl c r hr+ Nothing -> joinH l hl r hr+ -- e1 < e0, so (l1 < e1 < e0) & (e1 < e0 < r0)+ Gt -> case forkL e0 r1 of+ UBT5(rl1,_,mbc0,rr1,_) -> case forkR l0 e1 of -- (e1 < rl1 < e0) & (e1 < e0 < rr1)+ UBT5(ll0,_,mbc1,lr0,_) -> -- (ll0 < e1 < e0) & (e1 < lr0 < e0)+ -- (ll0 + l1) < e1 < (lr0 + rl1) < e0 < (r0 + rr1)+ case i r0 rr1 of+ UBT2(r,hr) -> case i lr0 rl1 of+ UBT2(m,hm) -> case i ll0 l1 of+ UBT2(l,hl) -> case (case mbc0 of+ Just c0 -> spliceH m hm c0 r hr+ Nothing -> joinH m hm r hr+ ) of+ UBT2(t,ht) -> case mbc1 of+ Just c1 -> spliceH l hl c1 t ht+ Nothing -> joinH l hl t ht+ -- We need 2 different versions of fork (L & R) to ensure that comparison arguments are used in+ -- the right order (c e0 e1)+ -- forkL :: a -> AVL b -> UBT5(AVL b,UINT,Maybe c,AVL b,UINT)+ forkL e0 t1 = forkL_ t1 L(0) where+ forkL_ E h = UBT5(E,h,Nothing,E,h) -- Relative heights!!+ forkL_ (N l e r) h = forkL__ l DECINT2(h) e r DECINT1(h)+ forkL_ (Z l e r) h = forkL__ l DECINT1(h) e r DECINT1(h)+ forkL_ (P l e r) h = forkL__ l DECINT1(h) e r DECINT2(h)+ forkL__ l hl e r hr = case comp e0 e of+ Lt -> case forkL_ l hl of+ UBT5(l0,hl0,mbc0,l1,hl1) -> case spliceH l1 hl1 e r hr of+ UBT2(l1_,hl1_) -> UBT5(l0,hl0,mbc0,l1_,hl1_)+ Eq mbc0_ -> UBT5(l,hl,mbc0_,r,hr)+ Gt -> case forkL_ r hr of+ UBT5(l0,hl0,mbc0,l1,hl1) -> case spliceH l hl e l0 hl0 of+ UBT2(l0_,hl0_) -> UBT5(l0_,hl0_,mbc0,l1,hl1)+ -- forkR :: AVL a -> b -> UBT5(AVL a,UINT,Maybe c,AVL a,UINT)+ forkR t0 e1 = forkR_ t0 L(0) where+ forkR_ E h = UBT5(E,h,Nothing,E,h) -- Relative heights!!+ forkR_ (N l e r) h = forkR__ l DECINT2(h) e r DECINT1(h)+ forkR_ (Z l e r) h = forkR__ l DECINT1(h) e r DECINT1(h)+ forkR_ (P l e r) h = forkR__ l DECINT1(h) e r DECINT2(h)+ forkR__ l hl e r hr = case comp e e1 of+ Lt -> case forkR_ r hr of+ UBT5(l0,hl0,mbc1,l1,hl1) -> case spliceH l hl e l0 hl0 of+ UBT2(l0_,hl0_) -> UBT5(l0_,hl0_,mbc1,l1,hl1)+ Eq mbc1_ -> UBT5(l,hl,mbc1_,r,hr)+ Gt -> case forkR_ l hl of+ UBT5(l0,hl0,mbc1,l1,hl1) -> case spliceH l1 hl1 e r hr of+ UBT2(l1_,hl1_) -> UBT5(l0,hl0,mbc1,l1_,hl1_)++-- | Uses the supplied comparison to evaluate the difference between two sets represented as+-- sorted AVL trees.+--+-- N.B. This function works with relative heights for the first tree and needs no height+-- information for the second tree, so it_s OK to initialise the height of the first to zero,+-- rather than calculating the absolute height. However, if you do this the height of the resulting+-- tree will be incorrect also (it will have the same fixed offset as the first tree).+--+-- Complexity: Not sure, but I\'d appreciate it if someone could figure it out.+differenceH :: (a -> b -> Ordering) -> AVL a -> UINT -> AVL b -> UBT2(AVL a,UINT)+differenceH comp = d where+ -- d :: AVL a -> UINT -> AVL b -> UBT2(AVL a,UINT)+ d E h0 _ = UBT2(E ,h0) -- Relative heights!!+ d t0 h0 E = UBT2(t0,h0)+ d (N l0 e0 r0) h0 (N l1 e1 r1) = d_ l0 DECINT2(h0) e0 r0 DECINT1(h0) l1 e1 r1+ d (N l0 e0 r0) h0 (Z l1 e1 r1) = d_ l0 DECINT2(h0) e0 r0 DECINT1(h0) l1 e1 r1+ d (N l0 e0 r0) h0 (P l1 e1 r1) = d_ l0 DECINT2(h0) e0 r0 DECINT1(h0) l1 e1 r1+ d (Z l0 e0 r0) h0 (N l1 e1 r1) = d_ l0 DECINT1(h0) e0 r0 DECINT1(h0) l1 e1 r1+ d (Z l0 e0 r0) h0 (Z l1 e1 r1) = d_ l0 DECINT1(h0) e0 r0 DECINT1(h0) l1 e1 r1+ d (Z l0 e0 r0) h0 (P l1 e1 r1) = d_ l0 DECINT1(h0) e0 r0 DECINT1(h0) l1 e1 r1+ d (P l0 e0 r0) h0 (N l1 e1 r1) = d_ l0 DECINT1(h0) e0 r0 DECINT2(h0) l1 e1 r1+ d (P l0 e0 r0) h0 (Z l1 e1 r1) = d_ l0 DECINT1(h0) e0 r0 DECINT2(h0) l1 e1 r1+ d (P l0 e0 r0) h0 (P l1 e1 r1) = d_ l0 DECINT1(h0) e0 r0 DECINT2(h0) l1 e1 r1+ d_ l0 hl0 e0 r0 hr0 l1 e1 r1 =+ case comp e0 e1 of+ -- e0 < e1, so (l0 < e0 < e1) & (e0 < e1 < r1)+ LT -> case forkR r0 hr0 e1 of+ UBT4(rl0,hrl0, rr0,hrr0) -> case forkL e0 l1 of -- (e0 < rl0 < e1) & (e0 < e1 < rr0)+ UBT5(ll1,_ ,be0,lr1,_ ) -> -- (ll1 < e0 < e1) & (e0 < lr1 < e1)+ -- (l0 + ll1) < e0 < (rl0 + lr1) < e1 < (rr0 + r1)+ case d rr0 hrr0 r1 of -- right+ UBT2(r,hr) -> case d rl0 hrl0 lr1 of -- middle+ UBT2(m,hm) -> case d l0 hl0 ll1 of -- left+ UBT2(l,hl) -> case joinH m hm r hr of -- join middle right+ UBT2(y,hy) -> if be0+ then spliceH l hl e0 y hy+ else joinH l hl y hy+ -- e0 = e1+ EQ -> case d r0 hr0 r1 of -- right+ UBT2(r,hr) -> case d l0 hl0 l1 of -- left+ UBT2(l,hl) -> joinH l hl r hr+ -- e1 < e0, so (l1 < e1 < e0) & (e1 < e0 < r0)+ GT -> case forkL e0 r1 of+ UBT5(rl1,_ ,be0,rr1,_ ) -> case forkR l0 hl0 e1 of -- (e1 < rl1 < e0) & (e1 < e0 < rr1)+ UBT4(ll0,hll0, lr0,hlr0) -> -- (ll0 < e1 < e0) & (e1 < lr0 < e0)+ -- (ll0 + l1) < e1 < (lr0 + rl1) < e0 < (r0 + rr1)+ case d r0 hr0 rr1 of -- right+ UBT2(r,hr) -> case d lr0 hlr0 rl1 of -- middle+ UBT2(m,hm) -> case d ll0 hll0 l1 of -- left+ UBT2(l,hl) -> case joinH l hl m hm of -- join left middle+ UBT2(x,hx) -> if be0+ then spliceH x hx e0 r hr+ else joinH x hx r hr+ -- We need 2 different versions of fork (L & R) to ensure that comparison arguments are used in+ -- the right order (c e0 e1), and for other algorithmic reasons in this case.+ -- N.B. forkL returns True if t1 does not contain e0 (I.E. If e0 is an element of the result).+ -- forkL :: a -> AVL b -> UBT5(AVL b, UINT, Bool, AVL b, UINT)+ forkL e0 t1 = forkL_ t1 L(0) where+ forkL_ E h = UBT5(E,h,True,E,h) -- Relative heights!!+ forkL_ (N l e r) h = forkL__ l DECINT2(h) e r DECINT1(h)+ forkL_ (Z l e r) h = forkL__ l DECINT1(h) e r DECINT1(h)+ forkL_ (P l e r) h = forkL__ l DECINT1(h) e r DECINT2(h)+ forkL__ l hl e r hr = case comp e0 e of+ LT -> case forkL_ l hl of+ UBT5(x0,hx0,be0,x1,hx1) -> case spliceH x1 hx1 e r hr of+ UBT2(x1_,hx1_) -> UBT5(x0,hx0,be0,x1_,hx1_)+ EQ -> UBT5(l,hl,False,r,hr)+ GT -> case forkL_ r hr of+ UBT5(x0,hx0,be0,x1,hx1) -> case spliceH l hl e x0 hx0 of+ UBT2(x0_,hx0_) -> UBT5(x0_,hx0_,be0,x1,hx1)+ -- N.B. forkR t0, according to e1. Neither of the resulting forks will contain an element+ -- which is "equal" to e1.+ -- forkR :: AVL a -> UINT -> b -> UBT4(AVL a, UINT, AVL a, UINT)+ forkR t0 ht0 e1 = forkR_ t0 ht0 where+ forkR_ E h = UBT4(E,h,E,h) -- Relative heights!!+ forkR_ (N l e r) h = forkR__ l DECINT2(h) e r DECINT1(h)+ forkR_ (Z l e r) h = forkR__ l DECINT1(h) e r DECINT1(h)+ forkR_ (P l e r) h = forkR__ l DECINT1(h) e r DECINT2(h)+ forkR__ l hl e r hr = case comp e e1 of+ LT -> case forkR_ r hr of+ UBT4(x0,hx0,x1,hx1) -> case spliceH l hl e x0 hx0 of+ UBT2(x0_,hx0_) -> UBT4(x0_,hx0_,x1,hx1)+ EQ -> UBT4(l,hl,r,hr) -- e1 is dropped.+ GT -> case forkR_ l hl of+ UBT4(x0,hx0,x1,hx1) -> case spliceH x1 hx1 e r hr of+ UBT2(x1_,hx1_) -> UBT4(x0,hx0,x1_,hx1_)++-- | Similar to _differenceH_, but the resulting tree also includes those elements a\_ for which the+-- combining comparison returns @Eq (Just a\_)@.+--+-- N.B. This function works with relative heights for the first tree and needs no height+-- information for the second tree, so it_s OK to initialise the height of the first to zero,+-- rather than calculating the absolute height. However, if you do this the height of the resulting+-- tree will be incorrect also (it will have the same fixed offset as the first tree).+--+-- Complexity: Not sure, but I\'d appreciate it if someone could figure it out.+differenceMaybeH :: (a -> b -> COrdering (Maybe a)) -> AVL a -> UINT -> AVL b -> UBT2(AVL a,UINT)+differenceMaybeH comp = d where+ -- d :: AVL a -> UINT -> AVL b -> UBT2(AVL a,UINT)+ d E h0 _ = UBT2(E ,h0) -- Relative heights!!+ d t0 h0 E = UBT2(t0,h0)+ d (N l0 e0 r0) h0 (N l1 e1 r1) = d_ l0 DECINT2(h0) e0 r0 DECINT1(h0) l1 e1 r1+ d (N l0 e0 r0) h0 (Z l1 e1 r1) = d_ l0 DECINT2(h0) e0 r0 DECINT1(h0) l1 e1 r1+ d (N l0 e0 r0) h0 (P l1 e1 r1) = d_ l0 DECINT2(h0) e0 r0 DECINT1(h0) l1 e1 r1+ d (Z l0 e0 r0) h0 (N l1 e1 r1) = d_ l0 DECINT1(h0) e0 r0 DECINT1(h0) l1 e1 r1+ d (Z l0 e0 r0) h0 (Z l1 e1 r1) = d_ l0 DECINT1(h0) e0 r0 DECINT1(h0) l1 e1 r1+ d (Z l0 e0 r0) h0 (P l1 e1 r1) = d_ l0 DECINT1(h0) e0 r0 DECINT1(h0) l1 e1 r1+ d (P l0 e0 r0) h0 (N l1 e1 r1) = d_ l0 DECINT1(h0) e0 r0 DECINT2(h0) l1 e1 r1+ d (P l0 e0 r0) h0 (Z l1 e1 r1) = d_ l0 DECINT1(h0) e0 r0 DECINT2(h0) l1 e1 r1+ d (P l0 e0 r0) h0 (P l1 e1 r1) = d_ l0 DECINT1(h0) e0 r0 DECINT2(h0) l1 e1 r1+ d_ l0 hl0 e0 r0 hr0 l1 e1 r1 =+ case comp e0 e1 of+ -- e0 < e1, so (l0 < e0 < e1) & (e0 < e1 < r1)+ Lt -> case forkR r0 hr0 e1 of+ UBT5( rl0,hrl0,mbe1,rr0,hrr0) -> case forkL e0 l1 of -- (e0 < rl0 < e1) & (e0 < e1 < rr0)+ UBT5(ll1,_ ,mbe0,lr1,_ ) -> -- (ll1 < e0 < e1) & (e0 < lr1 < e1)+ -- (l0 + ll1) < e0 < (rl0 + lr1) < e1 < (rr0 + r1)+ case d rr0 hrr0 r1 of -- right+ UBT2(r,hr) -> case d rl0 hrl0 lr1 of -- middle+ UBT2(m,hm) -> case d l0 hl0 ll1 of -- left+ UBT2(l,hl) -> case (case mbe1 of+ Just e1_ -> spliceH m hm e1_ r hr -- splice middle right with e1_+ Nothing -> joinH m hm r hr) of -- join middle right+ UBT2(y,hy) -> case mbe0 of+ Just e0_ -> spliceH l hl e0_ y hy+ Nothing -> joinH l hl y hy+ -- e0 = e1+ Eq mbe0 -> case d r0 hr0 r1 of -- right+ UBT2(r,hr) -> case d l0 hl0 l1 of -- left+ UBT2(l,hl) -> case mbe0 of+ Just e0_ -> spliceH l hl e0_ r hr -- retain updated e0+ Nothing -> joinH l hl r hr -- discard original e0+ -- e1 < e0, so (l1 < e1 < e0) & (e1 < e0 < r0)+ Gt -> case forkL e0 r1 of+ UBT5( rl1,_ ,mbe0,rr1,_ ) -> case forkR l0 hl0 e1 of -- (e1 < rl1 < e0) & (e1 < e0 < rr1)+ UBT5(ll0,hll0,mbe1,lr0,hlr0) -> -- (ll0 < e1 < e0) & (e1 < lr0 < e0)+ -- (ll0 + l1) < e1 < (lr0 + rl1) < e0 < (r0 + rr1)+ case d r0 hr0 rr1 of -- right+ UBT2(r,hr) -> case d lr0 hlr0 rl1 of -- middle+ UBT2(m,hm) -> case d ll0 hll0 l1 of -- left+ UBT2(l,hl) -> case (case mbe1 of+ Just e1_ -> spliceH l hl e1_ m hm -- splice left middle with e1_+ Nothing -> joinH l hl m hm) of -- join left middle+ UBT2(x,hx) -> case mbe0 of+ Just e0_ -> spliceH x hx e0_ r hr+ Nothing -> joinH x hx r hr+ -- We need 2 different versions of fork (L & R) to ensure that comparison arguments are used in+ -- the right order (c e0 e1), and for other algorithmic reasons in this case.+ -- N.B. forkL returns (Just e0) if t1 does not contain e0 (I.E. If original e0 is an element of the result).+ -- forkL :: a -> AVL b -> UBT5(AVL b, UINT, Maybe a, AVL b, UINT)+ forkL e0 t1 = forkL_ t1 L(0) where+ forkL_ E h = UBT5(E,h,Just e0,E,h) -- Relative heights!!+ forkL_ (N l e r) h = forkL__ l DECINT2(h) e r DECINT1(h)+ forkL_ (Z l e r) h = forkL__ l DECINT1(h) e r DECINT1(h)+ forkL_ (P l e r) h = forkL__ l DECINT1(h) e r DECINT2(h)+ forkL__ l hl e r hr = case comp e0 e of+ Lt -> case forkL_ l hl of+ UBT5(x0,hx0,mbe0,x1,hx1) -> case spliceH x1 hx1 e r hr of+ UBT2(x1_,hx1_) -> UBT5(x0,hx0,mbe0,x1_,hx1_)+ Eq mbe0 -> UBT5(l,hl,mbe0,r,hr)+ Gt -> case forkL_ r hr of+ UBT5(x0,hx0,mbe0,x1,hx1) -> case spliceH l hl e x0 hx0 of+ UBT2(x0_,hx0_) -> UBT5(x0_,hx0_,mbe0,x1,hx1)+ -- N.B. forkR t0, according to e1. Returns Nothing if t0 does not contain e1.+ -- forkR :: AVL a -> UINT -> b -> UBT5(AVL a, UINT, Maybe a, AVL a, UINT)+ forkR t0 ht0 e1 = forkR_ t0 ht0 where+ forkR_ E h = UBT5(E,h,Nothing,E,h) -- Relative heights!!+ forkR_ (N l e r) h = forkR__ l DECINT2(h) e r DECINT1(h)+ forkR_ (Z l e r) h = forkR__ l DECINT1(h) e r DECINT1(h)+ forkR_ (P l e r) h = forkR__ l DECINT1(h) e r DECINT2(h)+ forkR__ l hl e r hr = case comp e e1 of+ Lt -> case forkR_ r hr of+ UBT5(x0,hx0,mbe1,x1,hx1) -> case spliceH l hl e x0 hx0 of+ UBT2(x0_,hx0_) -> UBT5(x0_,hx0_,mbe1,x1,hx1)+ Eq mbe1 -> UBT5(l,hl,mbe1,r,hr)+ Gt -> case forkR_ l hl of+ UBT5(x0,hx0,mbe1,x1,hx1) -> case spliceH x1 hx1 e r hr of+ UBT2(x1_,hx1_) -> UBT5(x0,hx0,mbe1,x1_,hx1_)++-- | The symmetric difference is the set of elements which occur in one set or the other but /not both/.+--+-- Complexity: Not sure, but I\'d appreciate it if someone could figure it out.+symDifferenceH :: (e -> e -> Ordering) -> AVL e -> UINT -> AVL e -> UINT -> UBT2(AVL e,UINT)+symDifferenceH c = u where+ -- u :: AVL e -> UINT -> AVL e -> UINT -> UBT2(AVL e,UINT)+ u E _ t1 h1 = UBT2(t1,h1)+ u t0 h0 E _ = UBT2(t0,h0)+ u (N l0 e0 r0) h0 (N l1 e1 r1) h1 = u_ l0 DECINT2(h0) e0 r0 DECINT1(h0) l1 DECINT2(h1) e1 r1 DECINT1(h1)+ u (N l0 e0 r0) h0 (Z l1 e1 r1) h1 = u_ l0 DECINT2(h0) e0 r0 DECINT1(h0) l1 DECINT1(h1) e1 r1 DECINT1(h1)+ u (N l0 e0 r0) h0 (P l1 e1 r1) h1 = u_ l0 DECINT2(h0) e0 r0 DECINT1(h0) l1 DECINT1(h1) e1 r1 DECINT2(h1)+ u (Z l0 e0 r0) h0 (N l1 e1 r1) h1 = u_ l0 DECINT1(h0) e0 r0 DECINT1(h0) l1 DECINT2(h1) e1 r1 DECINT1(h1)+ u (Z l0 e0 r0) h0 (Z l1 e1 r1) h1 = u_ l0 DECINT1(h0) e0 r0 DECINT1(h0) l1 DECINT1(h1) e1 r1 DECINT1(h1)+ u (Z l0 e0 r0) h0 (P l1 e1 r1) h1 = u_ l0 DECINT1(h0) e0 r0 DECINT1(h0) l1 DECINT1(h1) e1 r1 DECINT2(h1)+ u (P l0 e0 r0) h0 (N l1 e1 r1) h1 = u_ l0 DECINT1(h0) e0 r0 DECINT2(h0) l1 DECINT2(h1) e1 r1 DECINT1(h1)+ u (P l0 e0 r0) h0 (Z l1 e1 r1) h1 = u_ l0 DECINT1(h0) e0 r0 DECINT2(h0) l1 DECINT1(h1) e1 r1 DECINT1(h1)+ u (P l0 e0 r0) h0 (P l1 e1 r1) h1 = u_ l0 DECINT1(h0) e0 r0 DECINT2(h0) l1 DECINT1(h1) e1 r1 DECINT2(h1)+ u_ l0 hl0 e0 r0 hr0 l1 hl1 e1 r1 hr1 =+ case c e0 e1 of+ -- e0 < e1, so (l0 < e0 < e1) & (e0 < e1 < r1)+ LT -> case fork e1 r0 hr0 of+ UBT5(rl0,hrl0,be1,rr0,hrr0) -> case fork e0 l1 hl1 of -- (e0 < rl0 < e1) & (e0 < e1 < rr0)+ UBT5(ll1,hll1,be0,lr1,hlr1) -> -- (ll1 < e0 < e1) & (e0 < lr1 < e1)+ -- (l0 + ll1) < e0 < (rl0 + lr1) < e1 < (rr0 + r1)+ case u l0 hl0 ll1 hll1 of+ UBT2(l,hl) -> case u rl0 hrl0 lr1 hlr1 of+ UBT2(m,hm) -> case u rr0 hrr0 r1 hr1 of+ UBT2(r,hr) -> case (if be1 then spliceH m hm e1 r hr+ else joinH m hm r hr+ ) of+ UBT2(t,ht) -> if be0 then spliceH l hl e0 t ht+ else joinH l hl t ht+ -- e0 = e1+ EQ -> case u l0 hl0 l1 hl1 of+ UBT2(l,hl) -> case u r0 hr0 r1 hr1 of+ UBT2(r,hr) -> joinH l hl r hr+ -- e1 < e0, so (l1 < e1 < e0) & (e1 < e0 < r0)+ GT -> case fork e0 r1 hr1 of+ UBT5(rl1,hrl1,be0,rr1,hrr1) -> case fork e1 l0 hl0 of -- (e1 < rl1 < e0) & (e1 < e0 < rr1)+ UBT5(ll0,hll0,be1,lr0,hlr0) -> -- (ll0 < e1 < e0) & (e1 < lr0 < e0)+ -- (ll0 + l1) < e1 < (lr0 + rl1) < e0 < (r0 + rr1)+ case u ll0 hll0 l1 hl1 of+ UBT2(l,hl) -> case u lr0 hlr0 rl1 hrl1 of+ UBT2(m,hm) -> case u r0 hr0 rr1 hrr1 of+ UBT2(r,hr) -> case (if be1 then spliceH l hl e1 m hm+ else joinH l hl m hm+ ) of+ UBT2(t,ht) -> if be0 then spliceH t ht e0 r hr+ else joinH t ht r hr+ -- fork :: e -> AVL e -> UINT -> UBT5(AVL e,UINT,Bool,AVL e,UINT)+ fork e0 t1 ht1 = fork_ t1 ht1 where+ fork_ E _ = UBT5(E, L(0), True, E, L(0))+ fork_ (N l e r) h = fork__ l DECINT2(h) e r DECINT1(h)+ fork_ (Z l e r) h = fork__ l DECINT1(h) e r DECINT1(h)+ fork_ (P l e r) h = fork__ l DECINT1(h) e r DECINT2(h)+ fork__ l hl e r hr = case c e0 e of+ LT -> case fork_ l hl of+ UBT5(l0,hl0,be0,l1,hl1) -> case spliceH l1 hl1 e r hr of+ UBT2(l1_,hl1_) -> UBT5(l0,hl0,be0,l1_,hl1_)+ EQ -> UBT5(l,hl,False,r,hr)+ GT -> case fork_ r hr of+ UBT5(l0,hl0,be0,l1,hl1) -> case spliceH l hl e l0 hl0 of+ UBT2(l0_,hl0_) -> UBT5(l0_,hl0_,be0,l1,hl1)++-- | Given two Sets @A@ and @B@ represented as sorted AVL trees, this function extracts+-- the \'Venn diagram\' components @A-B@, @A.B@ and @B-A@.+-- The two difference components are sorted AVL trees.+-- The intersection component is prepended to the input List in ascending sorted in ascending order.+-- The number of elements prepended is added to the corresponding Int argument (which may or may+-- not be the List length).+-- See also 'vennMaybeH'.+--+-- Complexity: Not sure, but I\'d appreciate it if someone could figure it out.+vennH :: (a -> b -> COrdering c) -> [c] -> UINT -> AVL a -> UINT -> AVL b -> UINT -> UBT6(AVL a,UINT,[c],UINT,AVL b,UINT)+vennH cmp = v where+ -- v :: [c] -> UINT -> AVL a -> UINT -> AVL b -> UINT -> UBT6(AVL a,UINT,[c],UINT,AVL b,UINT)+ v cs cl E ha tb hb = UBT6(E ,ha,cs,cl,tb,hb)+ v cs cl ta ha E hb = UBT6(ta,ha,cs,cl,E ,hb)+ v cs cl (N la a ra) ha (N lb b rb) hb = v_ cs cl la DECINT2(ha) a ra DECINT1(ha) lb DECINT2(hb) b rb DECINT1(hb)+ v cs cl (N la a ra) ha (Z lb b rb) hb = v_ cs cl la DECINT2(ha) a ra DECINT1(ha) lb DECINT1(hb) b rb DECINT1(hb)+ v cs cl (N la a ra) ha (P lb b rb) hb = v_ cs cl la DECINT2(ha) a ra DECINT1(ha) lb DECINT1(hb) b rb DECINT2(hb)+ v cs cl (Z la a ra) ha (N lb b rb) hb = v_ cs cl la DECINT1(ha) a ra DECINT1(ha) lb DECINT2(hb) b rb DECINT1(hb)+ v cs cl (Z la a ra) ha (Z lb b rb) hb = v_ cs cl la DECINT1(ha) a ra DECINT1(ha) lb DECINT1(hb) b rb DECINT1(hb)+ v cs cl (Z la a ra) ha (P lb b rb) hb = v_ cs cl la DECINT1(ha) a ra DECINT1(ha) lb DECINT1(hb) b rb DECINT2(hb)+ v cs cl (P la a ra) ha (N lb b rb) hb = v_ cs cl la DECINT1(ha) a ra DECINT2(ha) lb DECINT2(hb) b rb DECINT1(hb)+ v cs cl (P la a ra) ha (Z lb b rb) hb = v_ cs cl la DECINT1(ha) a ra DECINT2(ha) lb DECINT1(hb) b rb DECINT1(hb)+ v cs cl (P la a ra) ha (P lb b rb) hb = v_ cs cl la DECINT1(ha) a ra DECINT2(ha) lb DECINT1(hb) b rb DECINT2(hb)+ v_ cs cl la hla a ra hra lb hlb b rb hrb =+ case cmp a b of+ -- a < b, so (la < a < b) & (a < b < rb)+ Lt -> case forka cmp a lb hlb of+ UBT5(llb,hllb,mbca,rlb,hrlb) -> case forkb cmp b ra hra of+ UBT5(lra,hlra,mbcb,rra,hrra) ->+ -- (la + llb) < a < (lra + rlb) < b < (rra + rb)+ case v cs cl rra hrra rb hrb of+ UBT6(rab,hrab,cs0,cl0,rba,hrba) -> case (case mbcb of+ Nothing -> case v cs0 cl0 lra hlra rlb hrlb of+ UBT6(mab,hmab,cs1,cl1,mba,hmba) -> case spliceH mba hmba b rba hrba of+ UBT2(mrba,hmrba) -> UBT6(mab,hmab,cs1,cl1,mrba,hmrba)+ Just cb -> case v (cb:cs0) INCINT1(cl0) lra hlra rlb hrlb of+ UBT6(mab,hmab,cs1,cl1,mba,hmba) -> case joinH mba hmba rba hrba of+ UBT2(mrba,hmrba) -> UBT6(mab,hmab,cs1,cl1,mrba,hmrba)+ ) of+ UBT6(mab,hmab,cs1,cl1,mrba,hmrba) -> case joinH mab hmab rab hrab of+ UBT2(mrab,hmrab) -> case (case mbca of+ Nothing -> case v cs1 cl1 la hla llb hllb of+ UBT6(lab,hlab,cs2,cl2,lba,hlba) -> case spliceH lab hlab a mrab hmrab of+ UBT2(ab,hab) -> UBT6(ab,hab,cs2,cl2,lba,hlba)+ Just ca -> case v (ca:cs1) INCINT1(cl1) la hla llb hllb of+ UBT6(lab,hlab,cs2,cl2,lba,hlba) -> case joinH lab hlab mrab hmrab of+ UBT2(ab,hab) -> UBT6(ab,hab,cs2,cl2,lba,hlba)+ ) of+ UBT6(ab,hab,cs2,cl2,lba,hlba) -> case joinH lba hlba mrba hmrba of+ UBT2(ba,hba) -> UBT6(ab,hab,cs2,cl2,ba,hba)+ -- a = b+ Eq c -> case v cs cl ra hra rb hrb of+ UBT6(rab,hrab,cs0,cl0,rba,hrba) -> case v (c:cs0) INCINT1(cl0) la hla lb hlb of+ UBT6(lab,hlab,cs1,cl1,lba,hlba) -> case joinH lab hlab rab hrab of+ UBT2(ab,hab) -> case joinH lba hlba rba hrba of+ UBT2(ba,hba) -> UBT6(ab,hab,cs1,cl1,ba,hba)+ -- b < a, so (lb < b < a) & (b < a < ra)+ Gt -> case forka cmp a rb hrb of+ UBT5(lrb,hlrb,mbca,rrb,hrrb) -> case forkb cmp b la hla of+ UBT5(lla,hlla,mbcb,rla,hrla) ->+ -- (lla + lb) < b < (rla + lrb) < a < (ra + rrb)+ case v cs cl ra hra rrb hrrb of+ UBT6(rab,hrab,cs0,cl0,rba,hrba) -> case (case mbca of+ Nothing -> case v cs0 cl0 rla hrla lrb hlrb of+ UBT6(mab,hmab,cs1,cl1,mba,hmba) -> case spliceH mab hmab a rab hrab of+ UBT2(mrab,hmrab) -> UBT6(mrab,hmrab,cs1,cl1,mba,hmba)+ Just ca -> case v (ca:cs0) INCINT1(cl0) rla hrla lrb hlrb of+ UBT6(mab,hmab,cs1,cl1,mba,hmba) -> case joinH mab hmab rab hrab of+ UBT2(mrab,hmrab) -> UBT6(mrab,hmrab,cs1,cl1,mba,hmba)+ ) of+ UBT6(mrab,hmrab,cs1,cl1,mba,hmba) -> case joinH mba hmba rba hrba of+ UBT2(mrba,hmrba) -> case (case mbcb of+ Nothing -> case v cs1 cl1 lla hlla lb hlb of+ UBT6(lab,hlab,cs2,cl2,lba,hlba) -> case spliceH lba hlba b mrba hmrba of+ UBT2(ba,hba) -> UBT6(lab,hlab,cs2,cl2,ba,hba)+ Just cb -> case v (cb:cs1) INCINT1(cl1) lla hlla lb hlb of+ UBT6(lab,hlab,cs2,cl2,lba,hlba) -> case joinH lba hlba mrba hmrba of+ UBT2(ba,hba) -> UBT6(lab,hlab,cs2,cl2,ba,hba)+ ) of+ UBT6(lab,hlab,cs2,cl2,ba,hba) -> case joinH lab hlab mrab hmrab of+ UBT2(ab,hab) -> UBT6(ab,hab,cs2,cl2,ba,hba)++-- | Similar to 'vennH', but intersection elements for which the combining comparison+-- returns @('Data.COrdering.Eq' 'Nothing')@ are deleted from the intersection list.+--+-- Complexity: Not sure, but I\'d appreciate it if someone could figure it out.+vennMaybeH :: (a -> b -> COrdering (Maybe c)) -> [c] -> UINT -> AVL a -> UINT -> AVL b -> UINT -> UBT6(AVL a,UINT,[c],UINT,AVL b,UINT)+vennMaybeH cmp = v where+ -- v :: [c] -> UINT -> AVL a -> UINT -> AVL b -> UINT -> UBT6(AVL a,UINT,[c],UINT,AVL b,UINT)+ v cs cl E ha tb hb = UBT6(E ,ha,cs,cl,tb,hb)+ v cs cl ta ha E hb = UBT6(ta,ha,cs,cl,E ,hb)+ v cs cl (N la a ra) ha (N lb b rb) hb = v_ cs cl la DECINT2(ha) a ra DECINT1(ha) lb DECINT2(hb) b rb DECINT1(hb)+ v cs cl (N la a ra) ha (Z lb b rb) hb = v_ cs cl la DECINT2(ha) a ra DECINT1(ha) lb DECINT1(hb) b rb DECINT1(hb)+ v cs cl (N la a ra) ha (P lb b rb) hb = v_ cs cl la DECINT2(ha) a ra DECINT1(ha) lb DECINT1(hb) b rb DECINT2(hb)+ v cs cl (Z la a ra) ha (N lb b rb) hb = v_ cs cl la DECINT1(ha) a ra DECINT1(ha) lb DECINT2(hb) b rb DECINT1(hb)+ v cs cl (Z la a ra) ha (Z lb b rb) hb = v_ cs cl la DECINT1(ha) a ra DECINT1(ha) lb DECINT1(hb) b rb DECINT1(hb)+ v cs cl (Z la a ra) ha (P lb b rb) hb = v_ cs cl la DECINT1(ha) a ra DECINT1(ha) lb DECINT1(hb) b rb DECINT2(hb)+ v cs cl (P la a ra) ha (N lb b rb) hb = v_ cs cl la DECINT1(ha) a ra DECINT2(ha) lb DECINT2(hb) b rb DECINT1(hb)+ v cs cl (P la a ra) ha (Z lb b rb) hb = v_ cs cl la DECINT1(ha) a ra DECINT2(ha) lb DECINT1(hb) b rb DECINT1(hb)+ v cs cl (P la a ra) ha (P lb b rb) hb = v_ cs cl la DECINT1(ha) a ra DECINT2(ha) lb DECINT1(hb) b rb DECINT2(hb)+ v_ cs cl la hla a ra hra lb hlb b rb hrb =+ case cmp a b of+ -- a < b, so (la < a < b) & (a < b < rb)+ Lt -> case forka cmp a lb hlb of+ UBT5(llb,hllb,mbmbca,rlb,hrlb) -> case forkb cmp b ra hra of+ UBT5(lra,hlra,mbmbcb,rra,hrra) ->+ -- (la + llb) < a < (lra + rlb) < b < (rra + rb)+ case v cs cl rra hrra rb hrb of+ UBT6(rab,hrab,cs0,cl0,rba,hrba) -> case (case mbmbcb of+ Nothing -> case v cs0 cl0 lra hlra rlb hrlb of+ UBT6(mab,hmab,cs1,cl1,mba,hmba) -> case spliceH mba hmba b rba hrba of+ UBT2(mrba,hmrba) -> UBT6(mab,hmab,cs1,cl1,mrba,hmrba)+ Just mbcb -> case (case mbcb of+ Nothing -> v cs0 cl0 lra hlra rlb hrlb+ Just cb -> v (cb:cs0) INCINT1(cl0) lra hlra rlb hrlb+ ) of+ UBT6(mab,hmab,cs1,cl1,mba,hmba) -> case joinH mba hmba rba hrba of+ UBT2(mrba,hmrba) -> UBT6(mab,hmab,cs1,cl1,mrba,hmrba)+ ) of+ UBT6(mab,hmab,cs1,cl1,mrba,hmrba) -> case joinH mab hmab rab hrab of+ UBT2(mrab,hmrab) -> case (case mbmbca of+ Nothing -> case v cs1 cl1 la hla llb hllb of+ UBT6(lab,hlab,cs2,cl2,lba,hlba) -> case spliceH lab hlab a mrab hmrab of+ UBT2(ab,hab) -> UBT6(ab,hab,cs2,cl2,lba,hlba)+ Just mbca -> case (case mbca of+ Nothing -> v cs1 cl1 la hla llb hllb+ Just ca -> v (ca:cs1) INCINT1(cl1) la hla llb hllb+ ) of+ UBT6(lab,hlab,cs2,cl2,lba,hlba) -> case joinH lab hlab mrab hmrab of+ UBT2(ab,hab) -> UBT6(ab,hab,cs2,cl2,lba,hlba)+ ) of+ UBT6(ab,hab,cs2,cl2,lba,hlba) -> case joinH lba hlba mrba hmrba of+ UBT2(ba,hba) -> UBT6(ab,hab,cs2,cl2,ba,hba)+ -- a = b+ Eq mbc -> case v cs cl ra hra rb hrb of+ UBT6(rab,hrab,cs0,cl0,rba,hrba) -> case (case mbc of+ Nothing -> v cs0 cl0 la hla lb hlb+ Just c -> v (c:cs0) INCINT1(cl0) la hla lb hlb+ ) of+ UBT6(lab,hlab,cs1,cl1,lba,hlba) -> case joinH lab hlab rab hrab of+ UBT2(ab,hab) -> case joinH lba hlba rba hrba of+ UBT2(ba,hba) -> UBT6(ab,hab,cs1,cl1,ba,hba)+ -- b < a, so (lb < b < a) & (b < a < ra)+ Gt -> case forka cmp a rb hrb of+ UBT5(lrb,hlrb,mbmbca,rrb,hrrb) -> case forkb cmp b la hla of+ UBT5(lla,hlla,mbmbcb,rla,hrla) ->+ -- (lla + lb) < b < (rla + lrb) < a < (ra + rrb)+ case v cs cl ra hra rrb hrrb of+ UBT6(rab,hrab,cs0,cl0,rba,hrba) -> case (case mbmbca of+ Nothing -> case v cs0 cl0 rla hrla lrb hlrb of+ UBT6(mab,hmab,cs1,cl1,mba,hmba) -> case spliceH mab hmab a rab hrab of+ UBT2(mrab,hmrab) -> UBT6(mrab,hmrab,cs1,cl1,mba,hmba)+ Just mbca -> case (case mbca of+ Nothing -> v cs0 cl0 rla hrla lrb hlrb+ Just ca -> v (ca:cs0) INCINT1(cl0) rla hrla lrb hlrb+ ) of+ UBT6(mab,hmab,cs1,cl1,mba,hmba) -> case joinH mab hmab rab hrab of+ UBT2(mrab,hmrab) -> UBT6(mrab,hmrab,cs1,cl1,mba,hmba)+ ) of+ UBT6(mrab,hmrab,cs1,cl1,mba,hmba) -> case joinH mba hmba rba hrba of+ UBT2(mrba,hmrba) -> case (case mbmbcb of+ Nothing -> case v cs1 cl1 lla hlla lb hlb of+ UBT6(lab,hlab,cs2,cl2,lba,hlba) -> case spliceH lba hlba b mrba hmrba of+ UBT2(ba,hba) -> UBT6(lab,hlab,cs2,cl2,ba,hba)+ Just mbcb -> case (case mbcb of+ Nothing -> v cs1 cl1 lla hlla lb hlb+ Just cb -> v (cb:cs1) INCINT1(cl1) lla hlla lb hlb+ ) of+ UBT6(lab,hlab,cs2,cl2,lba,hlba) -> case joinH lba hlba mrba hmrba of+ UBT2(ba,hba) -> UBT6(lab,hlab,cs2,cl2,ba,hba)+ ) of+ UBT6(lab,hlab,cs2,cl2,ba,hba) -> case joinH lab hlab mrab hmrab of+ UBT2(ab,hab) -> UBT6(ab,hab,cs2,cl2,ba,hba)++-- Common forks used by vennH,vennMaybeH+-- We need 2 different versions of fork to ensure that comparison arguments are used in+-- the right order (c a b)+forka :: (a -> b -> COrdering c) -> a -> AVL b -> UINT -> UBT5(AVL b,UINT,Maybe c,AVL b,UINT)+forka cmp a tb htb = f tb htb where+ f E _ = UBT5(E,L(0),Nothing,E,L(0))+ f n@(N _ b r) L(2) = case cmp a b of -- l must be E, r must be Z+ Lt -> UBT5(E,L(0),Nothing,n,L(2))+ Eq c -> UBT5(E,L(0),Just c ,r,L(1))+ Gt -> case r of+ Z _ br _ -> case cmp a br of -- l & r must be E+ Lt -> UBT5(Z E b E,L(1),Nothing,r,L(1))+ Eq c -> UBT5(Z E b E,L(1),Just c ,E,L(0))+ Gt -> UBT5(n ,L(2),Nothing,E,L(0))+ _ -> undefined `seq` UBT5(E,L(0),Nothing,E,L(0))+ f (N l b r) h = f_ l DECINT2(h) b r DECINT1(h)+ f z@(Z l b r) L(2) = case cmp a b of -- l & r must be Z+ Lt -> case l of+ Z _ bl _ -> case cmp a bl of -- l & r must be E+ Lt -> UBT5(E,L(0),Nothing,z ,L(2))+ Eq c -> UBT5(E,L(0),Just c ,N E b r,L(2))+ Gt -> UBT5(l,L(1),Nothing,N E b r,L(2))+ _ -> undefined `seq` UBT5(E,L(0),Nothing,E,L(0))+ Eq c -> UBT5(l,L(1),Just c,r,L(1))+ Gt -> case r of+ Z _ br _ -> case cmp a br of -- l & r must be E+ Lt -> UBT5(P l b E,L(2),Nothing,r,L(1))+ Eq c -> UBT5(P l b E,L(2),Just c ,E,L(0))+ Gt -> UBT5(z ,L(2),Nothing,E,L(0))+ _ -> undefined `seq` UBT5(E,L(0),Nothing,E,L(0))+ f z@(Z _ b _) L(1) = case cmp a b of -- l & r must be E+ Lt -> UBT5(E,L(0),Nothing,z,L(1))+ Eq c -> UBT5(E,L(0),Just c ,E,L(0))+ Gt -> UBT5(z,L(1),Nothing,E,L(0))+ f (Z l b r) h = f_ l DECINT1(h) b r DECINT1(h)+ f p@(P l b _) L(2) = case cmp a b of -- l must be Z, r must be E+ Lt -> case l of+ Z _ bl _ -> case cmp a bl of -- l & r must be E+ Lt -> UBT5(E,L(0),Nothing,p ,L(2))+ Eq c -> UBT5(E,L(0),Just c ,Z E b E,L(1))+ Gt -> UBT5(l,L(1),Nothing,Z E b E,L(1))+ _ -> undefined `seq` UBT5(E,L(0),Nothing,E,L(0))+ Eq c -> UBT5(l,L(1),Just c ,E,L(0))+ Gt -> UBT5(p,L(2),Nothing,E,L(0))+ f (P l b r) h = f_ l DECINT1(h) b r DECINT2(h)+ f_ l hl b r hr = case cmp a b of+ Lt -> case f l hl of+ UBT5(ll,hll,mbc,lr,hlr) -> case spliceH lr hlr b r hr of+ UBT2(r_,hr_) -> UBT5(ll,hll,mbc,r_,hr_)+ Eq c -> UBT5(l,hl,Just c,r,hr)+ Gt -> case f r hr of+ UBT5(rl,hrl,mbc,rr,hrr) -> case spliceH l hl b rl hrl of+ UBT2(l_,hl_) -> UBT5(l_,hl_,mbc,rr,hrr)++-- This should be exactly the same as forka, but with the following swaps:+-- * a <-> b, except is compare!+-- * Lt <-> Gt (becasuse we didn't swap in compare)+forkb :: (a -> b -> COrdering c) -> b -> AVL a -> UINT -> UBT5(AVL a,UINT,Maybe c,AVL a,UINT)+forkb cmp b ta hta = f ta hta where+ f E _ = UBT5(E,L(0),Nothing,E,L(0))+ f n@(N _ a r) L(2) = case cmp a b of -- l must be E, r must be Z+ Gt -> UBT5(E,L(0),Nothing,n,L(2))+ Eq c -> UBT5(E,L(0),Just c ,r,L(1))+ Lt -> case r of+ Z _ ar _ -> case cmp ar b of -- l & r must be E+ Gt -> UBT5(Z E a E,L(1),Nothing,r,L(1))+ Eq c -> UBT5(Z E a E,L(1),Just c ,E,L(0))+ Lt -> UBT5(n ,L(2),Nothing,E,L(0))+ _ -> undefined `seq` UBT5(E,L(0),Nothing,E,L(0))+ f (N l a r) h = f_ l DECINT2(h) a r DECINT1(h)+ f z@(Z l a r) L(2) = case cmp a b of -- l & r must be Z+ Gt -> case l of+ Z _ al _ -> case cmp al b of -- l & r must be E+ Gt -> UBT5(E,L(0),Nothing,z ,L(2))+ Eq c -> UBT5(E,L(0),Just c ,N E a r,L(2))+ Lt -> UBT5(l,L(1),Nothing,N E a r,L(2))+ _ -> undefined `seq` UBT5(E,L(0),Nothing,E,L(0))+ Eq c -> UBT5(l,L(1),Just c,r,L(1))+ Lt -> case r of+ Z _ ar _ -> case cmp ar b of -- l & r must be E+ Gt -> UBT5(P l a E,L(2),Nothing,r,L(1))+ Eq c -> UBT5(P l a E,L(2),Just c ,E,L(0))+ Lt -> UBT5(z ,L(2),Nothing,E,L(0))+ _ -> undefined `seq` UBT5(E,L(0),Nothing,E,L(0))+ f z@(Z _ a _) L(1) = case cmp a b of -- l & r must be E+ Gt -> UBT5(E,L(0),Nothing,z,L(1))+ Eq c -> UBT5(E,L(0),Just c ,E,L(0))+ Lt -> UBT5(z,L(1),Nothing,E,L(0))+ f (Z l a r) h = f_ l DECINT1(h) a r DECINT1(h)+ f p@(P l a _) L(2) = case cmp a b of -- l must be Z, r must be E+ Gt -> case l of+ Z _ al _ -> case cmp al b of -- l & r must be E+ Gt -> UBT5(E,L(0),Nothing,p ,L(2))+ Eq c -> UBT5(E,L(0),Just c ,Z E a E,L(1))+ Lt -> UBT5(l,L(1),Nothing,Z E a E,L(1))+ _ -> undefined `seq` UBT5(E,L(0),Nothing,E,L(0))+ Eq c -> UBT5(l,L(1),Just c ,E,L(0))+ Lt -> UBT5(p,L(2),Nothing,E,L(0))+ f (P l a r) h = f_ l DECINT1(h) a r DECINT2(h)+ f_ l hl a r hr = case cmp a b of+ Gt -> case f l hl of+ UBT5(ll,hll,mbc,lr,hlr) -> case spliceH lr hlr a r hr of+ UBT2(r_,hr_) -> UBT5(ll,hll,mbc,r_,hr_)+ Eq c -> UBT5(l,hl,Just c,r,hr)+ Lt -> case f r hr of+ UBT5(rl,hrl,mbc,rr,hrr) -> case spliceH l hl a rl hrl of+ UBT2(l_,hl_) -> UBT5(l_,hl_,mbc,rr,hrr)++
+ src/Data/Tree/AVL/Internals/Types.hs view
@@ -0,0 +1,89 @@+-- |+-- Copyright : (c) Adrian Hey 2004,2005+-- License : BSD3+--+-- AVL Tree data type definition.+--+-- This is an internal unstable module, it's contents may change+-- in any way whatsoever and without any warning between minor versions of this package.+-- PVP does not apply.+{-# OPTIONS_HADDOCK hide #-}+module Data.Tree.AVL.Internals.Types+ ( -- * Types+ AVL(..),+ ) where++-- | AVL tree data type.+--+-- The balance factor (BF) of an 'AVL' tree node is defined as the difference between the height of+-- the left and right sub-trees. An 'AVL' tree is ALWAYS height balanced, such that |BF| <= 1.+-- The functions in this library ("Data.Tree.AVL") are designed so that they never construct+-- an unbalanced tree (well that's assuming they're not broken). The 'AVL' tree type defined here+-- has the BF encoded the constructors.+--+-- Some functions in this library return 'AVL' trees that are also \"flat\", which (in the context+-- of this library) means that the sizes of left and right sub-trees differ by at most one and+-- are also flat. Flat sorted trees should give slightly shorter searches than sorted trees which+-- are merely height balanced. Whether or not flattening is worth the effort depends on the number+-- of times the tree will be searched and the cost of element comparison.+--+-- In cases where the tree elements are sorted, all the relevant 'AVL' functions follow the+-- convention that the leftmost tree element is least and the rightmost tree element is+-- the greatest. Bear this in mind when defining general comparison functions. It should+-- also be noted that all functions in this library for sorted trees require that the tree+-- does not contain multiple elements which are \"equal\" (according to whatever criterion+-- has been used to sort the elements).+--+-- It is important to be consistent about argument ordering when defining general purpose+-- comparison functions (or selectors) for searching a sorted tree, such as ..+--+-- @+-- myComp :: (k -> e -> Ordering)+-- -- or+-- myCComp :: (k -> e -> COrdering a)+-- @+--+-- In these cases the first argument is the search key and the second argument is an element of+-- the 'AVL' tree. For example..+--+-- @+-- key \`myCComp\` element -> Lt implies key < element, proceed down the left sub-tree+-- key \`myCComp\` element -> Gt implies key > element, proceed down the right sub-tree+-- @+--+-- This convention is same as that used by the overloaded 'compare' method from 'Ord' class.+--+-- Controlling Strictness.+--+-- The 'AVL' tree data type is declared as non-strict in all it's fields,+-- but all the functions in this library behave as though it is strict in its+-- recursive fields (left and right sub-trees). Strictness in the element field is+-- controlled either by using the strict variants of functions (defined in this library+-- where appropriate), or using strict variants of the combinators defined in "Data.COrdering",+-- or using 'seq' etc. in your own code (in any combining comparisons you define, for example).+--+-- The 'Eq' and 'Ord' instances.+--+-- Begining with version 3.0 these are now derived, and hence are defined in terms of+-- strict structural equality, rather than observational equivalence. The reason for+-- this change is that the observational equivalence abstraction was technically breakable+-- with the exposed API. But since this change, some functions which were previously+-- considered unsafe have become safe to expose (those that measure tree height, for example).+--+-- The 'Read' and 'Show' instances.+--+-- Begining with version 4.0 these are now derived to ensure consistency with 'Eq' instance.+-- (Show now reveals the exact tree structure).+--++data AVL e = E -- ^ Empty Tree+ | N (AVL e) e (AVL e) -- ^ BF=-1 (right height > left height)+ | Z (AVL e) e (AVL e) -- ^ BF= 0+ | P (AVL e) e (AVL e) -- ^ BF=+1 (left height > right height)+ deriving(Eq,Ord,Show,Read)++instance Foldable AVL where+ foldMap _f E = mempty+ foldMap f (N l v r) = foldMap f l `mappend` f v `mappend` foldMap f r+ foldMap f (Z l v r) = foldMap f l `mappend` f v `mappend` foldMap f r+ foldMap f (P l v r) = foldMap f l `mappend` f v `mappend` foldMap f r
+ src/Data/Tree/AVL/Join.hs view
@@ -0,0 +1,108 @@+-- |+-- Copyright : (c) Adrian Hey 2004,2005+-- License : BSD3+--+{-# OPTIONS_HADDOCK hide #-}+module Data.Tree.AVL.Join+(-- * Joining AVL trees+ join,concatAVL,flatConcat,+) where++import Prelude ()+import Data.Tree.AVL.Internals.Types(AVL(..))+import Data.Tree.AVL.Size(addSize)+import Data.Tree.AVL.List(asTreeLenL,toListL)+import Data.Tree.AVL.Internals.DelUtils(popHLN,popHLZ,popHLP)+import Data.Tree.AVL.Height(height,addHeight)+import Data.Tree.AVL.Internals.HJoin(joinH',spliceH)+import Data.Foldable (foldl', foldr)++import GHC.Exts+#include "ghcdefs.h"++-- | Join two AVL trees. This is the AVL equivalent of (++).+--+-- > asListL (l `join` r) = asListL l ++ asListL r+--+-- Complexity: O(log n), where n is the size of the larger of the two trees.+join :: AVL e -> AVL e -> AVL e+join l r = joinH' l (height l) r (height r)++-- Specialised list of AVL trees of known height, with leftmost element popped.+-- (used by concatAVL).+data HAVLS e = HE | H e (AVL e) UINT (HAVLS e)++-- | Concatenate a /finite/ list of AVL trees. During construction of the resulting tree the+-- input list is consumed lazily, but it will be consumed entirely before the result is returned.+--+-- > asListL (concatAVL avls) = concatMap asListL avls+--+-- Complexity: Umm..Dunno. Uses a divide and conquer approach to splice adjacent pairs of+-- trees in the list recursively, until only one tree remains. The complexity of each splice+-- is proportional to the difference in tree heights.+concatAVL :: [AVL e] -> AVL e+concatAVL [] = E+concatAVL ( E :ts) = concatAVL ts+concatAVL (t@(N l _ _):ts) = concatHAVLS t (addHeight L(2) l) (mkHAVLS ts)+concatAVL (t@(Z l _ _):ts) = concatHAVLS t (addHeight L(1) l) (mkHAVLS ts)+concatAVL (t@(P _ _ r):ts) = concatHAVLS t (addHeight L(2) r) (mkHAVLS ts)++-- Recursively call mergePairs until only one tree remains.+-- The head of the current list has to be treated specially becuase it has no associated+-- bridging element.+concatHAVLS :: AVL e -> UINT -> HAVLS e -> AVL e+concatHAVLS l _ HE = l+concatHAVLS l hl (H e r hr hs) = case mergePairs l hl e r hr hs of+ UBT3(t,ht,hs_) -> concatHAVLS t ht hs_+++-- Merge adjacent pairs in the current list.+-- The head of the current list has to be treated specially becuase it has no associated+-- bridging element.+-- This function is strict in both elements of the result pair.+{-# INLINE mergePairs #-}+mergePairs :: AVL e -> UINT -> e -> AVL e -> UINT -> HAVLS e -> UBT3(AVL e,UINT,HAVLS e)+mergePairs l hl e r hr hs = case spliceH l hl e r hr of+ UBT2(t,ht) -> case hs of+ HE -> UBT3(t,ht,HE)+ H e_ t_ ht_ hs_ -> let hs__ = mergePairs_ e_ t_ ht_ hs_+ in hs__ `seq` UBT3(t,ht,hs__)++-- Deals with the rest of mergePairs after the head of the current list has been dealt with.+-- This function is strict in the resulting list head and lazy in the tail.+mergePairs_ :: e -> AVL e -> UINT -> HAVLS e -> HAVLS e+mergePairs_ e l hl HE = H e l hl HE+mergePairs_ e l hl (H e_ r hr hs) = case spliceH l hl e_ r hr of+ UBT2(t,ht) -> case hs of+ HE -> H e t ht HE+ H e__ r_ hr_ hs_ -> H e t ht (mergePairs_ e__ r_ hr_ hs_)++-- Uses popHL to get the leftmost element from each tree and calculate the (popped) tree height.+-- The popped element is used as a bridging element for splicing purposes.+-- Empty and singleton trees get special treatment.+-- This function is strict in the resulting list head and lazy in the tail.+mkHAVLS :: [AVL e] -> HAVLS e+mkHAVLS [] = HE+mkHAVLS ( E :ts) = mkHAVLS ts -- Discard empty trees+mkHAVLS ((N l e r):ts) = case popHLN l e r of -- Never a singlton with N+ UBT3(e_,t,ht) -> H e_ t ht (mkHAVLS ts)+mkHAVLS ((Z l e r):ts) = case popHLZ l e r of+ UBT3(e_,t,ht) -> if isTrue# (ht EQL L(0))+ then mkHAVLS_ e_ ts -- Deal with singleton+ else H e_ t ht (mkHAVLS ts) -- Otherwise treat as normal+mkHAVLS ((P l e r):ts) = case popHLP l e r of -- Never a singlton with P+ UBT3(e_,t,ht) -> H e_ t ht (mkHAVLS ts)+-- Deals with singletons (avoids unnecessary popHL in next in list)+mkHAVLS_ :: e -> [AVL e] -> HAVLS e+mkHAVLS_ e [] = H e E L(0) HE -- End of list reached anyway+mkHAVLS_ e ( E :ts) = mkHAVLS_ e ts -- Discard empty trees+mkHAVLS_ e (t@(N l _ _):ts) = H e t (addHeight L(2) l) (mkHAVLS ts)+mkHAVLS_ e (t@(Z l _ _):ts) = H e t (addHeight L(1) l) (mkHAVLS ts)+mkHAVLS_ e (t@(P _ _ r):ts) = H e t (addHeight L(2) r) (mkHAVLS ts)++-- | Similar to 'concatAVL', except the resulting tree is flat.+-- This function evaluates the entire list of trees before constructing the result.+--+-- Complexity: O(n), where n is the total number of elements in the resulting tree.+flatConcat :: [AVL e] -> AVL e+flatConcat avls = asTreeLenL (foldl' addSize 0 avls) (foldr toListL [] avls)
+ src/Data/Tree/AVL/List.hs view
@@ -0,0 +1,838 @@+-- |+-- Copyright : (c) Adrian Hey 2004,2005+-- License : BSD3+--+{-# OPTIONS_HADDOCK hide #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Data.Tree.AVL.List+(-- * List related utilities for AVL trees++ -- ** Converting AVL trees to Lists (fixed element order).+ -- | These functions are lazy and allow normal lazy list processing+ -- style to be used (without necessarily converting the entire tree+ -- to a list in one gulp).+ asListL,toListL,asListR,toListR,++ -- ** Converting Lists to AVL trees (fixed element order)+ asTreeLenL,asTreeL,+ asTreeLenR,asTreeR,++ -- ** Converting unsorted Lists to sorted AVL trees+ asTree,++ -- ** \"Pushing\" unsorted Lists in sorted AVL trees+ pushList,++ -- * Some analogues of common List functions+ reverse,map,map',+ mapAccumL ,mapAccumR ,+ mapAccumL' ,mapAccumR' ,+ replicate,+ filter,mapMaybe,+ filterViaList,mapMaybeViaList,+ partition,+ traverseAVL,++ -- ** Folds+ -- | Note that unlike folds over lists ('foldr' and 'foldl'), there is no+ -- significant difference between left and right folds in AVL trees, other+ -- than which side of the tree each starts with.+ -- Therefore this library provides strict and lazy versions of both.+ foldr,foldr',foldr1,foldr1',foldr2,foldr2',+ foldl,foldl',foldl1,foldl1',foldl2,foldl2',++ -- ** (GHC Only)+ mapAccumL'',mapAccumR'', foldrInt#,++ -- * Some clones of common List functions+ -- | These are a cure for the horrible @O(n^2)@ complexity the noddy Data.List definitions.+ nub,nubBy,++ -- * \"Flattening\" AVL trees+ -- | These functions can be improve search times by reducing a tree of given size to+ -- the minimum possible height.+ flatten,+ flatReverse,flatMap,flatMap',+) where++import Prelude (seq, (+), (-), odd, error)+import Data.Eq ((==))+import Data.Bool (Bool(..), (||))+import Data.Int (Int)+import Data.Foldable (length)+import Data.Maybe (Maybe(..))+import Data.Ord (Ord, compare, Ordering)+import Data.COrdering+import Data.Tree.AVL.Internals.Types(AVL(..))+import Data.Tree.AVL.Utils(empty)+import Data.Tree.AVL.Size(size)+import Data.Tree.AVL.Push(push)+import Data.Tree.AVL.BinPath(findEmptyPath,insertPath)+import Data.Tree.AVL.Internals.HJoin(spliceH,joinH)++import Data.Bits(shiftR,(.&.))+import qualified Data.List as List (foldl',map)+import Control.Applicative hiding (empty)++import GHC.Base(Int#,(-#))+#include "ghcdefs.h"++-- | List AVL tree contents in left to right order.+-- The resulting list in ascending order if the tree is sorted.+--+-- Complexity: O(n)+asListL :: AVL e -> [e]+asListL avl = toListL avl []++-- | Join the AVL tree contents to an existing list in left to right order.+-- This is a ++ free function which behaves as if defined thusly..+--+-- > avl `toListL` as = (asListL avl) ++ as+--+-- Complexity: O(n)+toListL :: AVL e -> [e] -> [e]+toListL E es = es+toListL (N l e r) es = toListL' l e r es+toListL (Z l e r) es = toListL' l e r es+toListL (P l e r) es = toListL' l e r es+toListL' :: AVL e -> e -> AVL e -> [e] -> [e]+toListL' l e r es = toListL l (e:(toListL r es))++-- | List AVL tree contents in right to left order.+-- The resulting list in descending order if the tree is sorted.+--+-- Complexity: O(n)+asListR :: AVL e -> [e]+asListR avl = toListR avl []++-- | Join the AVL tree contents to an existing list in right to left order.+-- This is a ++ free function which behaves as if defined thusly..+--+-- > avl `toListR` as = (asListR avl) ++ as+--+-- Complexity: O(n)+toListR :: AVL e -> [e] -> [e]+toListR E es = es+toListR (N l e r) es = toListR' l e r es+toListR (Z l e r) es = toListR' l e r es+toListR (P l e r) es = toListR' l e r es+toListR' :: AVL e -> e -> AVL e -> [e] -> [e]+toListR' l e r es = toListR r (e:(toListR l es))++-- | The AVL equivalent of 'foldr' on lists. This is a the lazy version (as lazy as the folding function+-- anyway). Using this version with a function that is strict in it's second argument will result in O(n)+-- stack use. See 'foldr'' for a strict version.+--+-- It behaves as if defined..+--+-- > foldr f a avl = foldr f a (asListL avl)+--+-- For example, the 'asListL' function could be defined..+--+-- > asListL = foldr (:) []+--+-- Complexity: O(n)+foldr :: (e -> a -> a) -> a -> AVL e -> a+foldr f = foldU where+ foldU a E = a+ foldU a (N l e r) = foldV a l e r+ foldU a (Z l e r) = foldV a l e r+ foldU a (P l e r) = foldV a l e r+ foldV a l e r = foldU (f e (foldU a r)) l++-- | The strict version of 'foldr', which is useful for functions which are strict in their second+-- argument. The advantage of this version is that it reduces the stack use from the O(n) that the lazy+-- version gives (when used with strict functions) to O(log n).+--+-- Complexity: O(n)+foldr' :: (e -> a -> a) -> a -> AVL e -> a+foldr' f = foldU where+ foldU a E = a+ foldU a (N l e r) = foldV a l e r+ foldU a (Z l e r) = foldV a l e r+ foldU a (P l e r) = foldV a l e r+ foldV a l e r = let a' = foldU a r+ a'' = f e a'+ in a' `seq` a'' `seq` foldU a'' l++-- | The AVL equivalent of 'foldr1' on lists. This is a the lazy version (as lazy as the folding function+-- anyway). Using this version with a function that is strict in it's second argument will result in O(n)+-- stack use. See 'foldr1'' for a strict version.+--+-- > foldr1 f avl = foldr1 f (asListL avl)+--+-- This function raises an error if the tree is empty.+--+-- Complexity: O(n)+foldr1 :: (e -> e -> e) -> AVL e -> e+foldr1 f = foldU where+ foldU E = error "foldr1: Empty Tree"+ foldU (N l e r) = foldV l e r -- r can't be E+ foldU (Z l e r) = foldW l e r -- r might be E+ foldU (P l e r) = foldW l e r -- r might be E+ -- Use this when r can't be E+ foldV l e r = foldr f (f e (foldU r)) l+ -- Use this when r might be E+ foldW l e E = foldr f e l+ foldW l e (N rl re rr) = foldr f (f e (foldV rl re rr)) l -- rr can't be E+ foldW l e (Z rl re rr) = foldX l e rl re rr -- rr might be E+ foldW l e (P rl re rr) = foldX l e rl re rr -- rr might be E+ -- Common code for foldW (Z and P cases)+ foldX l e rl re rr = foldr f (f e (foldW rl re rr)) l++-- | The strict version of 'foldr1', which is useful for functions which are strict in their second+-- argument. The advantage of this version is that it reduces the stack use from the O(n) that the lazy+-- version gives (when used with strict functions) to O(log n).+--+-- Complexity: O(n)+foldr1' :: (e -> e -> e) -> AVL e -> e+foldr1' f = foldU where+ foldU E = error "foldr1': Empty Tree"+ foldU (N l e r) = foldV l e r -- r can't be E+ foldU (Z l e r) = foldW l e r -- r might be E+ foldU (P l e r) = foldW l e r -- r might be E+ -- Use this when r can't be E+ foldV l e r = let a = foldU r+ a' = f e a+ in a `seq` a' `seq` foldr' f a' l+ -- Use this when r might be E+ foldW l e E = foldr' f e l+ foldW l e (N rl re rr) = let a = foldV rl re rr -- rr can't be E+ a' = f e a+ in a `seq` a' `seq` foldr' f a' l+ foldW l e (Z rl re rr) = foldX l e rl re rr -- rr might be E+ foldW l e (P rl re rr) = foldX l e rl re rr -- rr might be E+ -- Common code for foldW (Z and P cases)+ foldX l e rl re rr = let a = foldW rl re rr+ a' = f e a+ in a `seq` a' `seq` foldr' f a' l++-- | This fold is a hybrid between 'foldr' and 'foldr1'. As with 'foldr1', it requires+-- a non-empty tree, but instead of treating the rightmost element as an initial value, it applies+-- a function to it (second function argument) and uses the result instead. This allows+-- a more flexible type for the main folding function (same type as that used by 'foldr').+-- As with 'foldr' and 'foldr1', this function is lazy, so it's best not to use it with functions+-- that are strict in their second argument. See 'foldr2'' for a strict version.+--+-- Complexity: O(n)+foldr2 :: (e -> a -> a) -> (e -> a) -> AVL e -> a+foldr2 f g = foldU where+ foldU E = error "foldr2: Empty Tree"+ foldU (N l e r) = foldV l e r -- r can't be E+ foldU (Z l e r) = foldW l e r -- r might be E+ foldU (P l e r) = foldW l e r -- r might be E+ -- Use this when r can't be E+ foldV l e r = foldr f (f e (foldU r)) l+ -- Use this when r might be E+ foldW l e E = foldr f (g e) l+ foldW l e (N rl re rr) = foldr f (f e (foldV rl re rr)) l -- rr can't be E+ foldW l e (Z rl re rr) = foldX l e rl re rr -- rr might be E+ foldW l e (P rl re rr) = foldX l e rl re rr -- rr might be E+ -- Common code for foldW (Z and P cases)+ foldX l e rl re rr = foldr f (f e (foldW rl re rr)) l++-- | The strict version of 'foldr2', which is useful for functions which are strict in their second+-- argument. The advantage of this version is that it reduces the stack use from the O(n) that the lazy+-- version gives (when used with strict functions) to O(log n).+--+-- Complexity: O(n)+foldr2' :: (e -> a -> a) -> (e -> a) -> AVL e -> a+foldr2' f g = foldU where+ foldU E = error "foldr2': Empty Tree"+ foldU (N l e r) = foldV l e r -- r can't be E+ foldU (Z l e r) = foldW l e r -- r might be E+ foldU (P l e r) = foldW l e r -- r might be E+ -- Use this when r can't be E+ foldV l e r = let a = foldU r+ a' = f e a+ in a `seq` a' `seq` foldr' f a' l+ -- Use this when r might be E+ foldW l e E = let a = g e in a `seq` foldr' f a l+ foldW l e (N rl re rr) = let a = foldV rl re rr -- rr can't be E+ a' = f e a+ in a `seq` a' `seq` foldr' f a' l+ foldW l e (Z rl re rr) = foldX l e rl re rr -- rr might be E+ foldW l e (P rl re rr) = foldX l e rl re rr -- rr might be E+ -- Common code for foldW (Z and P cases)+ foldX l e rl re rr = let a = foldW rl re rr+ a' = f e a+ in a `seq` a' `seq` foldr' f a' l+++-- | The AVL equivalent of 'foldl' on lists. This is a the lazy version (as lazy as the folding function+-- anyway). Using this version with a function that is strict in it's first argument will result in O(n)+-- stack use. See 'foldl'' for a strict version.+--+-- > foldl f a avl = foldl f a (asListL avl)+--+-- For example, the 'asListR' function could be defined..+--+-- > asListR = foldl (flip (:)) []+--+-- Complexity: O(n)+foldl :: (a -> e -> a) -> a -> AVL e -> a+foldl f = foldU where+ foldU a E = a+ foldU a (N l e r) = foldV a l e r+ foldU a (Z l e r) = foldV a l e r+ foldU a (P l e r) = foldV a l e r+ foldV a l e r = foldU (f (foldU a l) e) r++-- | The strict version of 'foldl', which is useful for functions which are strict in their first+-- argument. The advantage of this version is that it reduces the stack use from the O(n) that the lazy+-- version gives (when used with strict functions) to O(log n).+--+-- Complexity: O(n)+foldl' :: (a -> e -> a) -> a -> AVL e -> a+foldl' f = foldU where+ foldU a E = a+ foldU a (N l e r) = foldV a l e r+ foldU a (Z l e r) = foldV a l e r+ foldU a (P l e r) = foldV a l e r+ foldV a l e r = let a' = foldU a l+ a'' = f a' e+ in a' `seq` a'' `seq` foldU a'' r++-- | The AVL equivalent of 'foldl1' on lists. This is a the lazy version (as lazy as the folding function+-- anyway). Using this version with a function that is strict in it's first argument will result in O(n)+-- stack use. See 'foldl1'' for a strict version.+--+-- > foldl1 f avl = foldl1 f (asListL avl)+--+-- This function raises an error if the tree is empty.+--+-- Complexity: O(n)+foldl1 :: (e -> e -> e) -> AVL e -> e+foldl1 f = foldU where+ foldU E = error "foldl1: Empty Tree"+ foldU (N l e r) = foldW l e r -- l might be E+ foldU (Z l e r) = foldW l e r -- l might be E+ foldU (P l e r) = foldV l e r -- l can't be E+ -- Use this when l can't be E+ foldV l e r = foldl f (f (foldU l) e) r+ -- Use this when l might be E+ foldW E e r = foldl f e r+ foldW (N ll le lr) e r = foldX ll le lr e r -- ll might be E+ foldW (Z ll le lr) e r = foldX ll le lr e r -- ll might be E+ foldW (P ll le lr) e r = foldl f (f (foldV ll le lr) e) r -- ll can't be E+ -- Common code for foldW (Z and P cases)+ foldX ll le lr e r = foldl f (f (foldW ll le lr) e) r++-- | The strict version of 'foldl1', which is useful for functions which are strict in their first+-- argument. The advantage of this version is that it reduces the stack use from the O(n) that the lazy+-- version gives (when used with strict functions) to O(log n).+--+-- Complexity: O(n)+foldl1' :: (e -> e -> e) -> AVL e -> e+foldl1' f = foldU where+ foldU E = error "foldl1': Empty Tree"+ foldU (N l e r) = foldW l e r -- l might be E+ foldU (Z l e r) = foldW l e r -- l might be E+ foldU (P l e r) = foldV l e r -- l can't be E+ -- Use this when l can't be E+ foldV l e r = let a = foldU l+ a' = f a e+ in a `seq` a' `seq` foldl' f a' r+ -- Use this when l might be E+ foldW E e r = foldl' f e r+ foldW (N ll le lr) e r = foldX ll le lr e r -- ll might be E+ foldW (Z ll le lr) e r = foldX ll le lr e r -- ll might be E+ foldW (P ll le lr) e r = let a = foldV ll le lr -- ll can't be E+ a' = f a e+ in a `seq` a' `seq` foldl' f a' r+ -- Common code for foldW (Z and P cases)+ foldX ll le lr e r = let a = foldW ll le lr+ a' = f a e+ in a `seq` a' `seq` foldl' f a' r++-- | This fold is a hybrid between 'foldl' and 'foldl1'. As with 'foldl1', it requires+-- a non-empty tree, but instead of treating the leftmost element as an initial value, it applies+-- a function to it (second function argument) and uses the result instead. This allows+-- a more flexible type for the main folding function (same type as that used by 'foldl').+-- As with 'foldl' and 'foldl1', this function is lazy, so it's best not to use it with functions+-- that are strict in their first argument. See 'foldl2'' for a strict version.+--+-- Complexity: O(n)+foldl2 :: (a -> e -> a) -> (e -> a) -> AVL e -> a+foldl2 f g = foldU where+ foldU E = error "foldl2: Empty Tree"+ foldU (N l e r) = foldW l e r -- l might be E+ foldU (Z l e r) = foldW l e r -- l might be E+ foldU (P l e r) = foldV l e r -- l can't be E+ -- Use this when l can't be E+ foldV l e r = foldl f (f (foldU l) e) r+ -- Use this when l might be E+ foldW E e r = foldl f (g e) r+ foldW (N ll le lr) e r = foldX ll le lr e r -- ll might be E+ foldW (Z ll le lr) e r = foldX ll le lr e r -- ll might be E+ foldW (P ll le lr) e r = foldl f (f (foldV ll le lr) e) r -- ll can't be E+ -- Common code for foldW (Z and P cases)+ foldX ll le lr e r = foldl f (f (foldW ll le lr) e) r++-- | The strict version of 'foldl2', which is useful for functions which are strict in their first+-- argument. The advantage of this version is that it reduces the stack use from the O(n) that the lazy+-- version gives (when used with strict functions) to O(log n).+--+-- Complexity: O(n)+foldl2' :: (a -> e -> a) -> (e -> a) -> AVL e -> a+foldl2' f g = foldU where+ foldU E = error "foldl2': Empty Tree"+ foldU (N l e r) = foldW l e r -- l might be E+ foldU (Z l e r) = foldW l e r -- l might be E+ foldU (P l e r) = foldV l e r -- l can't be E+ -- Use this when l can't be E+ foldV l e r = let a = foldU l+ a' = f a e+ in a `seq` a' `seq` foldl' f a' r+ -- Use this when l might be E+ foldW E e r = let a = g e in a `seq` foldl' f a r+ foldW (N ll le lr) e r = foldX ll le lr e r -- ll might be E+ foldW (Z ll le lr) e r = foldX ll le lr e r -- ll might be E+ foldW (P ll le lr) e r = let a = foldV ll le lr -- ll can't be E+ a' = f a e+ in a `seq` a' `seq` foldl' f a' r+ -- Common code for foldW (Z and P cases)+ foldX ll le lr e r = let a = foldW ll le lr+ a' = f a e+ in a `seq` a' `seq` foldl' f a' r++-- | This is a specialised version of 'foldr'' for use with an+-- /unboxed/ Int accumulator.+--+-- Complexity: O(n)+foldrInt# :: (e -> UINT -> UINT) -> UINT -> AVL e -> UINT+foldrInt# f = foldU where+ foldU a E = a+ foldU a (N l e r) = foldV a l e r+ foldU a (Z l e r) = foldV a l e r+ foldU a (P l e r) = foldV a l e r+ foldV a l e r = foldU (f e (foldU a r)) l++-- | The AVL equivalent of 'Data.List.mapAccumL' on lists.+-- It behaves like a combination of 'map' and 'foldl'.+-- It applies a function to each element of a tree, passing an accumulating parameter from+-- left to right, and returning a final value of this accumulator together with the new tree.+--+-- Using this version with a function that is strict in it's first argument will result in+-- O(n) stack use. See 'mapAccumL'' for a strict version.+--+-- Complexity: O(n)+mapAccumL :: (z -> a -> (z, b)) -> z -> AVL a -> (z, AVL b)+mapAccumL f z ta = case mapAL z ta of+ UBT2(zt,tb) -> (zt,tb)+ where mapAL z_ E = UBT2(z_,E)+ mapAL z_ (N la a ra) = mapAL' z_ N la a ra+ mapAL z_ (Z la a ra) = mapAL' z_ Z la a ra+ mapAL z_ (P la a ra) = mapAL' z_ P la a ra+ {-# INLINE mapAL' #-}+ mapAL' z' c la a ra = case mapAL z' la of+ UBT2(zl,lb) -> let (za,b) = f zl a+ in case mapAL za ra of+ UBT2(zr,rb) -> UBT2(zr, c lb b rb)++-- | This is a strict version of 'mapAccumL', which is useful for functions which+-- are strict in their first argument. The advantage of this version is that it reduces+-- the stack use from the O(n) that the lazy version gives (when used with strict functions)+-- to O(log n).+--+-- Complexity: O(n)+mapAccumL' :: (z -> a -> (z, b)) -> z -> AVL a -> (z, AVL b)+mapAccumL' f z ta = case mapAL z ta of+ UBT2(zt,tb) -> (zt,tb)+ where mapAL z_ E = UBT2(z_,E)+ mapAL z_ (N la a ra) = mapAL' z_ N la a ra+ mapAL z_ (Z la a ra) = mapAL' z_ Z la a ra+ mapAL z_ (P la a ra) = mapAL' z_ P la a ra+ {-# INLINE mapAL' #-}+ mapAL' z' c la a ra = case mapAL z' la of+ UBT2(zl,lb) -> case f zl a of+ (za,b) -> case mapAL za ra of+ UBT2(zr,rb) -> UBT2(zr, c lb b rb)+++-- | The AVL equivalent of 'Data.List.mapAccumR' on lists.+-- It behaves like a combination of 'map' and 'foldr'.+-- It applies a function to each element of a tree, passing an accumulating parameter from+-- right to left, and returning a final value of this accumulator together with the new tree.+--+-- Using this version with a function that is strict in it's first argument will result in+-- O(n) stack use. See 'mapAccumR'' for a strict version.+--+-- Complexity: O(n)+mapAccumR :: (z -> a -> (z, b)) -> z -> AVL a -> (z, AVL b)+mapAccumR f z ta = case mapAR z ta of+ UBT2(zt,tb) -> (zt,tb)+ where mapAR z_ E = UBT2(z_,E)+ mapAR z_ (N la a ra) = mapAR' z_ N la a ra+ mapAR z_ (Z la a ra) = mapAR' z_ Z la a ra+ mapAR z_ (P la a ra) = mapAR' z_ P la a ra+ {-# INLINE mapAR' #-}+ mapAR' z' c la a ra = case mapAR z' ra of+ UBT2(zr,rb) -> let (za,b) = f zr a+ in case mapAR za la of+ UBT2(zl,lb) -> UBT2(zl, c lb b rb)++-- | This is a strict version of 'mapAccumR', which is useful for functions which+-- are strict in their first argument. The advantage of this version is that it reduces+-- the stack use from the O(n) that the lazy version gives (when used with strict functions)+-- to O(log n).+--+-- Complexity: O(n)+mapAccumR' :: (z -> a -> (z, b)) -> z -> AVL a -> (z, AVL b)+mapAccumR' f z ta = case mapAR z ta of+ UBT2(zt,tb) -> (zt,tb)+ where mapAR z_ E = UBT2(z_,E)+ mapAR z_ (N la a ra) = mapAR' z_ N la a ra+ mapAR z_ (Z la a ra) = mapAR' z_ Z la a ra+ mapAR z_ (P la a ra) = mapAR' z_ P la a ra+ {-# INLINE mapAR' #-}+ mapAR' z' c la a ra = case mapAR z' ra of+ UBT2(zr,rb) -> case f zr a of+ (za,b) -> case mapAR za la of+ UBT2(zl,lb) -> UBT2(zl, c lb b rb)++-- These two functions attempt to make the strict mapAccums more efficient and reduce heap+-- burn rate with ghc by using an accumulating function that returns an unboxed pair.++-- | Similar to 'mapAccumL'' but uses an unboxed pair in the+-- accumulating function.+--+-- Complexity: O(n)+mapAccumL''+ :: (z -> a -> UBT2(z, b)) -> z -> AVL a -> (z, AVL b)+mapAccumL'' f z ta = case mapAL z ta of+ UBT2(zt,tb) -> (zt,tb)+ where mapAL z_ E = UBT2(z_,E)+ mapAL z_ (N la a ra) = mapAL' z_ N la a ra+ mapAL z_ (Z la a ra) = mapAL' z_ Z la a ra+ mapAL z_ (P la a ra) = mapAL' z_ P la a ra+ {-# INLINE mapAL' #-}+ mapAL' z' c la a ra = case mapAL z' la of+ UBT2(zl,lb) -> case f zl a of+ UBT2(za,b) -> case mapAL za ra of+ UBT2(zr,rb) -> UBT2(zr, c lb b rb)++-- | Similar to 'mapAccumR'' but uses an unboxed pair in the+-- accumulating function.+--+-- Complexity: O(n)+mapAccumR''+ :: (z -> a -> UBT2(z, b)) -> z -> AVL a -> (z, AVL b)+mapAccumR'' f z ta = case mapAR z ta of+ UBT2(zt,tb) -> (zt,tb)+ where mapAR z_ E = UBT2(z_,E)+ mapAR z_ (N la a ra) = mapAR' z_ N la a ra+ mapAR z_ (Z la a ra) = mapAR' z_ Z la a ra+ mapAR z_ (P la a ra) = mapAR' z_ P la a ra+ {-# INLINE mapAR' #-}+ mapAR' z' c la a ra = case mapAR z' ra of+ UBT2(zr,rb) -> case f zr a of+ UBT2(za,b) -> case mapAR za la of+ UBT2(zl,lb) -> UBT2(zl, c lb b rb)++--------------------------------------+-- | Convert a list of known length into an AVL tree, such that the head of the list becomes+-- the leftmost tree element. The resulting tree is flat (and also sorted if the supplied list+-- is sorted in ascending order).+--+-- If the actual length of the list is not the same as the supplied length then+-- an error will be raised.+--+-- Complexity: O(n)+asTreeLenL :: Int -> [e] -> AVL e+asTreeLenL n es = case subst (replicate n ()) es of+ UBT2(tree,es_) -> case es_ of+ [] -> tree+ _ -> error "asTreeLenL: List too long."+ where+ -- Substitute template values for real values taken from the list+ subst E as = UBT2(E,as)+ subst (N l _ r) as = subst' N l r as+ subst (Z l _ r) as = subst' Z l r as+ subst (P l _ r) as = subst' P l r as+ {-# INLINE subst' #-}+ subst' f l r as = case subst l as of+ UBT2(l_,xs) -> case xs of+ a:as' -> case subst r as' of+ UBT2(r_,as__) -> let t_ = f l_ a r_+ in t_ `seq` UBT2(t_,as__)+ [] -> error "asTreeLenL: List too short."+++-- | As 'asTreeLenL', except the length of the list is calculated internally, not supplied+-- as an argument.+--+-- Complexity: O(n)+asTreeL :: [e] -> AVL e+asTreeL es = asTreeLenL (length es) es++-- | Convert a list of known length into an AVL tree, such that the head of the list becomes+-- the rightmost tree element. The resulting tree is flat (and also sorted if the supplied list+-- is sorted in descending order).+--+-- If the actual length of the list is not the same as the supplied length then+-- an error will be raised.+--+-- Complexity: O(n)+asTreeLenR :: Int -> [e] -> AVL e+asTreeLenR n es = case subst (replicate n ()) es of+ UBT2(tree,es_) -> case es_ of+ [] -> tree+ _ -> error "asTreeLenR: List too long."+ where+ -- Substitute template values for real values taken from the list+ subst E as = UBT2(E,as)+ subst (N l _ r) as = subst' N l r as+ subst (Z l _ r) as = subst' Z l r as+ subst (P l _ r) as = subst' P l r as+ {-# INLINE subst' #-}+ subst' f l r as = case subst r as of+ UBT2(r_,xs) -> case xs of+ a:as' -> case subst l as' of+ UBT2(l_,as__) -> let t_ = f l_ a r_+ in t_ `seq` UBT2(t_,as__)+ [] -> error "asTreeLenR: List too short."++-- | As 'asTreeLenR', except the length of the list is calculated internally, not supplied+-- as an argument.+--+-- Complexity: O(n)+asTreeR :: [e] -> AVL e+asTreeR es = asTreeLenR (length es) es++-- | Reverse an AVL tree (swaps and reverses left and right sub-trees).+-- The resulting tree is the mirror image of the original.+--+-- Complexity: O(n)+reverse :: AVL e -> AVL e+reverse E = E+reverse (N l e r) = let l' = reverse l+ r' = reverse r+ in l' `seq` r' `seq` P r' e l'+reverse (Z l e r) = let l' = reverse l+ r' = reverse r+ in l' `seq` r' `seq` Z r' e l'+reverse (P l e r) = let l' = reverse l+ r' = reverse r+ in l' `seq` r' `seq` N r' e l'++-- | Apply a function to every element in an AVL tree. This function preserves the tree shape.+-- There is also a strict version of this function ('map'').+--+-- N.B. If the tree is sorted the result of this operation will only be sorted if+-- the applied function preserves ordering (for some suitable ordering definition).+--+-- Complexity: O(n)+map :: (a -> b) -> AVL a -> AVL b+map f = mp where+ mp E = E+ mp (N l a r) = let l' = mp l+ r' = mp r+ in l' `seq` r' `seq` N l' (f a) r'+ mp (Z l a r) = let l' = mp l+ r' = mp r+ in l' `seq` r' `seq` Z l' (f a) r'+ mp (P l a r) = let l' = mp l+ r' = mp r+ in l' `seq` r' `seq` P l' (f a) r'++-- | Similar to 'map', but the supplied function is applied strictly.+--+-- Complexity: O(n)+map' :: (a -> b) -> AVL a -> AVL b+map' f = mp' where+ mp' E = E+ mp' (N l a r) = let l' = mp' l+ r' = mp' r+ b = f a+ in b `seq` l' `seq` r' `seq` N l' b r'+ mp' (Z l a r) = let l' = mp' l+ r' = mp' r+ b = f a+ in b `seq` l' `seq` r' `seq` Z l' b r'+ mp' (P l a r) = let l' = mp' l+ r' = mp' r+ b = f a+ in b `seq` l' `seq` r' `seq` P l' b r'+++-- | Construct a flat AVL tree of size n (n>=0), where all elements are identical.+--+-- Complexity: O(log n)+replicate :: Int -> e -> AVL e+replicate m e = rep m where -- Functional spaghetti follows :-)+ rep n | odd n = repOdd n -- n is odd , >=1+ rep n = repEvn n -- n is even, >=0+ -- n is known to be odd (>=1), so left and right sub-trees are identical+ repOdd n = let sub = rep (n `shiftR` 1) in sub `seq` Z sub e sub+ -- n is known to be even (>=0)+ repEvn n | n .&. (n-1) == 0 = repP2 n -- treat exact powers of 2 specially, traps n=0 too+ repEvn n = let nl = n `shiftR` 1 -- size of left subtree (odd or even)+ nr = nl - 1 -- size of right subtree (even or odd)+ in if odd nr+ then let l = repEvn nl -- right sub-tree is odd , so left is even (>=2)+ r = repOdd nr+ in l `seq` r `seq` Z l e r+ else let l = repOdd nl -- right sub-tree is even, so left is odd (>=2)+ r = repEvn nr+ in l `seq` r `seq` Z l e r+ -- n is an exact power of 2 (or 0), I.E. 0,1,2,4,8,16..+ repP2 0 = E+ repP2 1 = Z E e E+ repP2 n = let nl = n `shiftR` 1 -- nl is also an exact power of 2+ nr = nl - 1 -- nr is one less that an exact power of 2+ l = repP2 nl+ r = repP2M1 nr+ in l `seq` r `seq` P l e r -- BF=+1+ -- n is one less than an exact power of 2, I.E. 0,1,3,7,15..+ repP2M1 0 = E+ repP2M1 n = let sub = repP2M1 (n `shiftR` 1) in sub `seq` Z sub e sub++-- | Flatten an AVL tree, preserving the ordering of the tree elements.+--+-- Complexity: O(n)+flatten :: AVL e -> AVL e+flatten t = asTreeLenL (size t) (asListL t)++-- | Similar to 'flatten', but the tree elements are reversed. This function has higher constant+-- factor overhead than 'reverse'.+--+-- Complexity: O(n)+flatReverse :: AVL e -> AVL e+flatReverse t = asTreeLenL (size t) (asListR t)++-- | Similar to 'map', but the resulting tree is flat.+-- This function has higher constant factor overhead than 'map'.+--+-- Complexity: O(n)+flatMap :: (a -> b) -> AVL a -> AVL b+flatMap f t = asTreeLenL (size t) (List.map f (asListL t))++-- | Same as 'flatMap', but the supplied function is applied strictly.+--+-- Complexity: O(n)+flatMap' :: (a -> b) -> AVL a -> AVL b+flatMap' f t = asTreeLenL (size t) (mp' f (asListL t)) where+ mp' _ [] = []+ mp' g (a:as) = let b = g a in b `seq` (b : mp' f as)++-- | Remove all AVL tree elements which do not satisfy the supplied predicate.+-- Element ordering is preserved. The resulting tree is flat.+-- See 'filter' for an alternative implementation which is probably more efficient.+--+-- Complexity: O(n)+filterViaList :: (e -> Bool) -> AVL e -> AVL e+filterViaList p t = filter' [] 0 (asListR t) where+ filter' se n [] = asTreeLenL n se+ filter' se n (e:es) = if p e then let n'=n+1 in n' `seq` filter' (e:se) n' es+ else filter' se n es++-- | Remove all AVL tree elements which do not satisfy the supplied predicate.+-- Element ordering is preserved.+--+-- Complexity: O(n)+filter :: forall e. (e -> Bool) -> AVL e -> AVL e+filter p t0 = case filter_ L(0) t0 of UBT3(_,t_,_) -> t_ -- Work with relative heights!!+ where+ filter_ :: UINT -> AVL e -> UBT3(Bool, AVL e, UINT)+ filter_ h t = case t of+ E -> UBT3(False,E,h)+ N l e r -> f l DECINT2(h) e r DECINT1(h)+ Z l e r -> f l DECINT1(h) e r DECINT1(h)+ P l e r -> f l DECINT1(h) e r DECINT2(h)+ where f l hl e r hr = case filter_ hl l of+ UBT3(bl,l_,hl_) -> case filter_ hr r of+ UBT3(br,r_,hr_) -> if p e+ then if bl || br+ then case spliceH l_ hl_ e r_ hr_ of+ UBT2(t_,h_) -> UBT3(True,t_,h_)+ else UBT3(False,t,h)+ else case joinH l_ hl_ r_ hr_ of+ UBT2(t_,h_) -> UBT3(True,t_,h_)++-- | Partition an AVL tree using the supplied predicate. The first AVL tree in the+-- resulting pair contains all elements for which the predicate is True, the second+-- contains all those for which the predicate is False. Element ordering is preserved.+-- Both of the resulting trees are flat.+--+-- Complexity: O(n)+partition :: (e -> Bool) -> AVL e -> (AVL e, AVL e)+partition p t = part 0 [] 0 [] (asListR t) where+ part nT lstT nF lstF [] = let avlT = asTreeLenL nT lstT+ avlF = asTreeLenL nF lstF+ in (avlT,avlF) -- Non strict in avlT, avlF !!+ part nT lstT nF lstF (e:es) = if p e then let nT'=nT+1 in nT' `seq` part nT' (e:lstT) nF lstF es+ else let nF'=nF+1 in nF' `seq` part nT lstT nF' (e:lstF) es++-- | Remove all AVL tree elements for which the supplied function returns 'Nothing'.+-- Element ordering is preserved. The resulting tree is flat.+-- See 'mapMaybe' for an alternative implementation which is probably more efficient.+--+-- Complexity: O(n)+mapMaybeViaList :: (a -> Maybe b) -> AVL a -> AVL b+mapMaybeViaList f t = mp' [] 0 (asListR t) where+ mp' sb n [] = asTreeLenL n sb+ mp' sb n (a:as) = case f a of+ Just b -> let n'=n+1 in n' `seq` mp' (b:sb) n' as+ Nothing -> mp' sb n as++-- | Remove all AVL tree elements for which the supplied function returns 'Nothing'.+-- Element ordering is preserved.+--+-- Complexity: O(n)+mapMaybe :: forall a b. (a -> Maybe b) -> AVL a -> AVL b+mapMaybe f t0 = case mapMaybe_ L(0) t0 of UBT2(t_,_) -> t_ -- Work with relative heights!!+ where+ mapMaybe_ :: UINT -> AVL a -> UBT2(AVL b, UINT)+ mapMaybe_ h t = case t of+ E -> UBT2(E,h)+ N l a r -> m l DECINT2(h) a r DECINT1(h)+ Z l a r -> m l DECINT1(h) a r DECINT1(h)+ P l a r -> m l DECINT1(h) a r DECINT2(h)+ where m l hl a r hr = case mapMaybe_ hl l of+ UBT2(l_,hl_) -> case mapMaybe_ hr r of+ UBT2(r_,hr_) -> case f a of+ Just b -> spliceH l_ hl_ b r_ hr_+ Nothing -> joinH l_ hl_ r_ hr_++-- | Invokes 'pushList' on the empty AVL tree.+--+-- Complexity: O(n.(log n))+asTree :: (e -> e -> COrdering e) -> [e] -> AVL e+asTree c = pushList c empty+{-# INLINE asTree #-}++-- | Push the elements of an unsorted List in a sorted AVL tree using the supplied combining comparison.+--+-- Complexity: O(n.(log (m+n))) where n is the list length, m is the tree size.+pushList :: (e -> e -> COrdering e) -> AVL e -> [e] -> AVL e+pushList c avl = List.foldl' addElem avl+ where addElem t e = push (c e) e t++-- | A fast alternative implementation for 'Data.List.nub'.+-- Deletes all but the first occurrence of an element from the input list.+--+-- Complexity: O(n.(log n))+nub :: Ord a => [a] -> [a]+nub = nubBy compare+{-# INLINE nub #-}++-- | A fast alternative implementation for 'Data.List.nubBy'.+-- Deletes all but the first occurrence of an element from the input list.+--+-- Complexity: O(n.(log n))+nubBy :: (a -> a -> Ordering) -> [a] -> [a]+nubBy c = nubbit E where+ nubbit _ [] = []+ nubbit avl (a:as) = case findEmptyPath (c a) avl of+ L(-1) -> nubbit avl as -- Already encountered+ p -> let avl' = insertPath p a avl -- First encounter+ in avl' `seq` (a : nubbit avl' as)++-- | This is the non-overloaded version of the 'Data.Traversable.traverse' method for AVL trees.+traverseAVL :: Applicative f => (a -> f b) -> AVL a -> f (AVL b)+traverseAVL _f E = pure E+traverseAVL f (N l v r) = N <$> traverseAVL f l <*> f v <*> traverseAVL f r+traverseAVL f (Z l v r) = Z <$> traverseAVL f l <*> f v <*> traverseAVL f r+traverseAVL f (P l v r) = P <$> traverseAVL f l <*> f v <*> traverseAVL f r
+ src/Data/Tree/AVL/Push.hs view
@@ -0,0 +1,692 @@+-- |+-- Copyright : (c) Adrian Hey 2004,2005+-- License : BSD3+--+{-# OPTIONS_HADDOCK hide #-}+module Data.Tree.AVL.Push+(-- * \"Pushing\" new elements into AVL trees+ -- | \"Pushing\" is another word for insertion. (c.f \"Popping\".)++ -- ** Pushing on extreme left or right+ pushL,pushR,++ -- ** Pushing on /sorted/ AVL trees+ push,push',pushMaybe,pushMaybe',+) where++import Data.COrdering+import Data.Tree.AVL.Internals.Types(AVL(..))+import Data.Tree.AVL.BinPath(BinPath(..),openPathWith,writePath,insertPath)++{------------------------------------------------------------------------------------------------------------------------------+ -------------------------------------- Notes about Insertion and Rebalancing -------------------------------------------------+ ------------------------------------------------------------------------------------------------------------------------------+ If we forget about tree rebalancing, and consider what changes in BF tell us about changes in H+ under ordinary circumstances, we can make the following observations:++ (1) Insertion can never reduce the height of a (sub)tree.+ (2) Insertion can only change the height of a (sub)tree by +1 at most. Therefore the BF of the+ root can change by +/- 1 most.+ (2) If insertion changes the BF from 0 -> +/- 1, then this must be because either the left or+ right subtrees has grown in height by 1. Since they were equal before (BF=0), the overall+ height of the root must also have grown by 1.+ (3) If insertion changes the BF from +/-1 -> 0, then this must be because one either the left+ or right subtree has grown by 1 so that it is now equal in height to the opposing subtree.+ Since height of the root is determined by the maximum height of the subtrees, it is left+ unchanged.+ (4) If insertion leaves the BF unchanged, then this must be because the height of neither+ subtree has changed. Therefore the height of the root is left unchanged.+ (5) It follows from (2) and (3), that changes in height, and hence BF can (and will) propogate+ up the tree (along the insertion path) as far as the first node with non-zero BF, and no further.+ (6) If insertion changes the BF from +/-1 -> +/-2 then we have a problem. This is dealt with by+ one of four possible rebalancing 'rotations' (there are two possiblities for each of the left+ and right subtrees). However, it's appropriate to mention an important property of the rotations+ now. The net effect of unbalancing and rebalancing is to give the root BF=0 and leave the height+ unchanged. So the combined effect of the unbalance-rebalance operation appears like a special+ case of (3). Another important property of rebalancing is that it /preserves/ the tree sorting.+ (7) It follows from (6) and (5) any single insertion will cause most one unbalance-rebalance operation.++ So in summary we have a set of rules to enable us to infer changes in height of a subtree (if any) from+ changes in the BF of the subtree, and hence the changes (if any) in the BF of the root. The rules are:+ BF 0 -> +/-1, height increased by 1+ BF +/-1 -> 0, height unchanged.+ BF unchanged , height unchanged.+ BF +/-1 -> -/+1, NEVER OCCURS++ It should also be observed that these observations and rules apply to INSERTION only (not deletion).++Rebalancing: CASE RR+--------------------+ Consider inserting into the right subtree of the right subtree (RR subtree). From the obsevations above we can+ say this is only going to unbalance the root if:+ The height of the RR subtree is increased by 1 (we determine this from looking at changes in it's BF)+ ..and.. The right subtree has BF=0 prior to insertion (observation 5)+ ..and.. THe root has BF=-1 prior to insertion (observation 2)++ In pictures..++ ----- ----- -----+ | B | | B | | D |+ |H=h+2| |H=h+3| |H=h+2| <- Note+ |BF=-1| |BF=-2| <-- Unbalanced! |BF= 0| <- Note+ /-----\ /-----\ /-----\+ / \ / \ / \+ / \ / \ / \+ -----/ \----- -----/ \----- -----/ \-----+ | A | | D | E grows | A | | D | Rebalance | B | | E |+ | H=h | |H=h+1| by 1 | H=h | |H=h+2| --------> |H=h+1| |H=h+1|+ | | |BF= 0| ------> | | |BF=-1| |BF= 0| | |+ ----- /-----\ h -> h+1 ----- /-----\ /-----\ -----+ / \ / \ / \+ / \ / \ / \+ -----/ \----- -----/ \----- -----/ \-----+ | C | | E | | C | | E | | A | | C |+ | H=h | | H=h | | H=h | |H=h+1| | H=h | | H=h |+ | | | | | | | | | | | |+ ----- ----- ----- ----- ----- -----++ Unfortunately, if you try this for insertion into the right left subtree (C) it doesn't work. To deal with+ this case we need a more complicated re-balancing rotation involving 3 nodes. There are 2 distinct cases, which+ both use the same rotation, but details re. BF and H are different.++Rebalancing: CASE RL(1)+-----------------------++ ----- ----- -----+ | B | | B | | D |+ |H=h+3| |H=h+4| |H=h+3| <- Note+ |BF=-1| |BF=-2| <-- Unbalanced! |BF= 0| <- Note+ /-----\ /-----\ /-----\+ / \ / \ / \+ / \ / \ / \+ -----/ \----- -----/ \----- / \+ | A | | F | E grows | A | | F | Rebalance -----/ \-----+ |H=h+1| |H=h+2| by 1 |H=h+1| |H=h+3| --------> | B | | F |+ | | |BF= 0| ------> | | |BF=+1| |H=h+2| |H=h+2|+ ----- /-----\ h -> h+1 ----- /-----\ |BF=+1| |BF= 0|+ / \ / \ -----/-----\----- -----/-----\-----+ / \ / \ | A | | C | | E | | G |+ -----/ \----- -----/ \----- |H=h+1| | H=h | |H=h+1| |H=h+1|+ | D | | G | | D | | G | | | | | | | | |+ |H=h+1| |H=h+1| |H=h+2| |H=h+1| ----- ----- ----- -----+ |BF= 0| | | |BF=-1| | |+ /-----\ ----- /-----\ -----+ / \ / \+ / \ / \+ -----/ \----- -----/ \-----+ | C | | E | | C | | E |+ | H=h | | H=h | | H=h | |H=h+1|+ | | | | | | | |+ ----- ----- ----- -----++Rebalancing: CASE RL(2)+-----------------------++ ----- ----- -----+ | B | | B | | D |+ |H=h+3| |H=h+4| |H=h+3| <- Note+ |BF=-1| |BF=-2| <-- Unbalanced! |BF= 0| <- Note+ /-----\ /-----\ /-----\+ / \ / \ / \+ / \ / \ / \+ -----/ \----- -----/ \----- / \+ | A | | F | C grows | A | | F | Rebalance -----/ \-----+ |H=h+1| |H=h+2| by 1 |H=h+1| |H=h+3| --------> | B | | F |+ | | |BF= 0| ------> | | |BF=+1| |H=h+2| |H=h+2|+ ----- /-----\ h -> h+1 ----- /-----\ |BF= 0| |BF=-1|+ / \ / \ -----/-----\----- -----/-----\-----+ / \ / \ | A | | C | | E | | G |+ -----/ \----- -----/ \----- |H=h+1| |H=h+1| | H=h | |H=h+1|+ | D | | G | | D | | G | | | | | | | | |+ |H=h+1| |H=h+1| |H=h+2| |H=h+1| ----- ----- ----- -----+ |BF= 0| | | |BF=+1| | |+ /-----\ ----- /-----\ -----+ / \ / \+ / \ / \+ -----/ \----- -----/ \-----+ | C | | E | | C | | E |+ | H=h | | H=h | |H=h+1| | H=h |+ | | | | | | | |+ ----- ----- ----- -----+-}++-- | General push. This function searches the AVL tree using the supplied selector. If a matching element+-- is found it's replaced by the value (@e@) returned in the @('Data.COrdering.Eq' e)@ constructor returned by the selector.+-- If no match is found then the default element value is added at in the appropriate position in the tree.+--+-- Note that for this to work properly requires that the selector behave as if it were comparing the+-- (potentially) new default element with existing tree elements, even if it isn't.+--+-- Note also that this function is /non-strict/ in it\'s second argument (the default value which+-- is inserted if the search fails or is discarded if the search succeeds). If you want+-- to force evaluation, but only if it\'s actually incorprated in the tree, then use 'push''+--+-- Complexity: O(log n)+push :: (e -> COrdering e) -> e -> AVL e -> AVL e+push c e0 = put where -- there now follows a huge collection of functions requiring+ -- pattern matching from hell in which c and e0 are free variables+-- This may look longwinded, it's been done this way to..+-- * Avoid doing case analysis on the same node more than once.+-- * Minimise heap burn rate (by avoiding explicit rebalancing operations).+ ----------------------------- LEVEL 0 ---------------------------------+ -- put --+ -----------------------------------------------------------------------+ put E = Z E e0 E+ put (N l e r) = putN l e r+ put (Z l e r) = putZ l e r+ put (P l e r) = putP l e r++ ----------------------------- LEVEL 1 ---------------------------------+ -- putN, putZ, putP --+ -----------------------------------------------------------------------++ -- Put in (N l e r), BF=-1 , (never returns P)+ putN l e r = case c e of+ Lt -> putNL l e r -- <e, so put in L subtree+ Eq e' -> N l e' r -- =e, so update existing+ Gt -> putNR l e r -- >e, so put in R subtree++ -- Put in (Z l e r), BF= 0+ putZ l e r = case c e of+ Lt -> putZL l e r -- <e, so put in L subtree+ Eq e' -> Z l e' r -- =e, so update existing+ Gt -> putZR l e r -- >e, so put in R subtree++ -- Put in (P l e r), BF=+1 , (never returns N)+ putP l e r = case c e of+ Lt -> putPL l e r -- <e, so put in L subtree+ Eq e' -> P l e' r -- =e, so update existing+ Gt -> putPR l e r -- >e, so put in R subtree++ ----------------------------- LEVEL 2 ---------------------------------+ -- putNL, putZL, putPL --+ -- putNR, putZR, putPR --+ -----------------------------------------------------------------------++ -- (putNL l e r): Put in L subtree of (N l e r), BF=-1 (Never requires rebalancing) , (never returns P)+ {-# INLINE putNL #-}+ putNL E e r = Z (Z E e0 E ) e r -- L subtree empty, H:0->1, parent BF:-1-> 0+ putNL (N ll le lr) e r = let l' = putN ll le lr -- L subtree BF<>0, H:h->h, parent BF:-1->-1+ in l' `seq` N l' e r+ putNL (P ll le lr) e r = let l' = putP ll le lr -- L subtree BF<>0, H:h->h, parent BF:-1->-1+ in l' `seq` N l' e r+ putNL (Z ll le lr) e r = let l' = putZ ll le lr -- L subtree BF= 0, so need to look for changes+ in case l' of+ E -> error "push: Bug0" -- impossible+ Z _ _ _ -> N l' e r -- L subtree BF:0-> 0, H:h->h , parent BF:-1->-1+ _ -> Z l' e r -- L subtree BF:0->+/-1, H:h->h+1, parent BF:-1-> 0++ -- (putZL l e r): Put in L subtree of (Z l e r), BF= 0 (Never requires rebalancing) , (never returns N)+ {-# INLINE putZL #-}+ putZL E e r = P (Z E e0 E ) e r -- L subtree H:0->1, parent BF: 0->+1+ putZL (N ll le lr) e r = let l' = putN ll le lr -- L subtree BF<>0, H:h->h, parent BF: 0-> 0+ in l' `seq` Z l' e r+ putZL (P ll le lr) e r = let l' = putP ll le lr -- L subtree BF<>0, H:h->h, parent BF: 0-> 0+ in l' `seq` Z l' e r+ putZL (Z ll le lr) e r = let l' = putZ ll le lr -- L subtree BF= 0, so need to look for changes+ in case l' of+ E -> error "push: Bug1" -- impossible+ Z _ _ _ -> Z l' e r -- L subtree BF: 0-> 0, H:h->h , parent BF: 0-> 0+ _ -> P l' e r -- L subtree BF: 0->+/-1, H:h->h+1, parent BF: 0->+1++ -- (putZR l e r): Put in R subtree of (Z l e r), BF= 0 (Never requires rebalancing) , (never returns P)+ {-# INLINE putZR #-}+ putZR l e E = N l e (Z E e0 E ) -- R subtree H:0->1, parent BF: 0->-1+ putZR l e (N rl re rr) = let r' = putN rl re rr -- R subtree BF<>0, H:h->h, parent BF: 0-> 0+ in r' `seq` Z l e r'+ putZR l e (P rl re rr) = let r' = putP rl re rr -- R subtree BF<>0, H:h->h, parent BF: 0-> 0+ in r' `seq` Z l e r'+ putZR l e (Z rl re rr) = let r' = putZ rl re rr -- R subtree BF= 0, so need to look for changes+ in case r' of+ E -> error "push: Bug2" -- impossible+ Z _ _ _ -> Z l e r' -- R subtree BF: 0-> 0, H:h->h , parent BF: 0-> 0+ _ -> N l e r' -- R subtree BF: 0->+/-1, H:h->h+1, parent BF: 0->-1++ -- (putPR l e r): Put in R subtree of (P l e r), BF=+1 (Never requires rebalancing) , (never returns N)+ {-# INLINE putPR #-}+ putPR l e E = Z l e (Z E e0 E ) -- R subtree empty, H:0->1, parent BF:+1-> 0+ putPR l e (N rl re rr) = let r' = putN rl re rr -- R subtree BF<>0, H:h->h, parent BF:+1->+1+ in r' `seq` P l e r'+ putPR l e (P rl re rr) = let r' = putP rl re rr -- R subtree BF<>0, H:h->h, parent BF:+1->+1+ in r' `seq` P l e r'+ putPR l e (Z rl re rr) = let r' = putZ rl re rr -- R subtree BF= 0, so need to look for changes+ in case r' of+ E -> error "push: Bug3" -- impossible+ Z _ _ _ -> P l e r' -- R subtree BF:0-> 0, H:h->h , parent BF:+1->+1+ _ -> Z l e r' -- R subtree BF:0->+/-1, H:h->h+1, parent BF:+1-> 0++ -------- These 2 cases (NR and PL) may need rebalancing if they go to LEVEL 3 ---------++ -- (putNR l e r): Put in R subtree of (N l e r), BF=-1 , (never returns P)+ {-# INLINE putNR #-}+ putNR _ _ E = error "push: Bug4" -- impossible if BF=-1+ putNR l e (N rl re rr) = let r' = putN rl re rr -- R subtree BF<>0, H:h->h, parent BF:-1->-1+ in r' `seq` N l e r'+ putNR l e (P rl re rr) = let r' = putP rl re rr -- R subtree BF<>0, H:h->h, parent BF:-1->-1+ in r' `seq` N l e r'+ putNR l e (Z rl re rr) = case c re of -- determine if RR or RL+ Lt -> putNRL l e rl re rr -- RL (never returns P)+ Eq re' -> N l e (Z rl re' rr) -- new re+ Gt -> putNRR l e rl re rr -- RR (never returns P)++ -- (putPL l e r): Put in L subtree of (P l e r), BF=+1 , (never returns N)+ {-# INLINE putPL #-}+ putPL E _ _ = error "push: Bug5" -- impossible if BF=+1+ putPL (N ll le lr) e r = let l' = putN ll le lr -- L subtree BF<>0, H:h->h, parent BF:+1->+1+ in l' `seq` P l' e r+ putPL (P ll le lr) e r = let l' = putP ll le lr -- L subtree BF<>0, H:h->h, parent BF:+1->+1+ in l' `seq` P l' e r+ putPL (Z ll le lr) e r = case c le of -- determine if LL or LR+ Lt -> putPLL ll le lr e r -- LL (never returns N)+ Eq le' -> P (Z ll le' lr) e r -- new le+ Gt -> putPLR ll le lr e r -- LR (never returns N)++ ----------------------------- LEVEL 3 ---------------------------------+ -- putNRR, putPLL --+ -- putNRL, putPLR --+ -----------------------------------------------------------------------++ -- (putNRR l e rl re rr): Put in RR subtree of (N l e (Z rl re rr)) , (never returns P)+ {-# INLINE putNRR #-}+ putNRR l e rl re E = Z (Z l e rl) re (Z E e0 E) -- l and rl must also be E, special CASE RR!!+ putNRR l e rl re (N rrl rre rrr) = let rr' = putN rrl rre rrr -- RR subtree BF<>0, H:h->h, so no change+ in rr' `seq` N l e (Z rl re rr')+ putNRR l e rl re (P rrl rre rrr) = let rr' = putP rrl rre rrr -- RR subtree BF<>0, H:h->h, so no change+ in rr' `seq` N l e (Z rl re rr')+ putNRR l e rl re (Z rrl rre rrr) = let rr' = putZ rrl rre rrr -- RR subtree BF= 0, so need to look for changes+ in case rr' of+ E -> error "push: Bug6" -- impossible+ Z _ _ _ -> N l e (Z rl re rr') -- RR subtree BF: 0-> 0, H:h->h, so no change+ _ -> Z (Z l e rl) re rr' -- RR subtree BF: 0->+/-1, H:h->h+1, parent BF:-1->-2, CASE RR !!++ -- (putPLL ll le lr e r): Put in LL subtree of (P (Z ll le lr) e r) , (never returns N)+ {-# INLINE putPLL #-}+ putPLL E le lr e r = Z (Z E e0 E) le (Z lr e r) -- r and lr must also be E, special CASE LL!!+ putPLL (N lll lle llr) le lr e r = let ll' = putN lll lle llr -- LL subtree BF<>0, H:h->h, so no change+ in ll' `seq` P (Z ll' le lr) e r+ putPLL (P lll lle llr) le lr e r = let ll' = putP lll lle llr -- LL subtree BF<>0, H:h->h, so no change+ in ll' `seq` P (Z ll' le lr) e r+ putPLL (Z lll lle llr) le lr e r = let ll' = putZ lll lle llr -- LL subtree BF= 0, so need to look for changes+ in case ll' of+ E -> error "push: Bug7" -- impossible+ Z _ _ _ -> P (Z ll' le lr) e r -- LL subtree BF: 0-> 0, H:h->h, so no change+ _ -> Z ll' le (Z lr e r) -- LL subtree BF: 0->+/-1, H:h->h+1, parent BF:-1->-2, CASE LL !!++ -- (putNRL l e rl re rr): Put in RL subtree of (N l e (Z rl re rr)) , (never returns P)+ {-# INLINE putNRL #-}+ putNRL l e E re rr = Z (Z l e E) e0 (Z E re rr) -- l and rr must also be E, special CASE LR !!+ putNRL l e (N rll rle rlr) re rr = let rl' = putN rll rle rlr -- RL subtree BF<>0, H:h->h, so no change+ in rl' `seq` N l e (Z rl' re rr)+ putNRL l e (P rll rle rlr) re rr = let rl' = putP rll rle rlr -- RL subtree BF<>0, H:h->h, so no change+ in rl' `seq` N l e (Z rl' re rr)+ putNRL l e (Z rll rle rlr) re rr = let rl' = putZ rll rle rlr -- RL subtree BF= 0, so need to look for changes+ in case rl' of+ E -> error "push: Bug8" -- impossible+ Z _ _ _ -> N l e (Z rl' re rr) -- RL subtree BF: 0-> 0, H:h->h, so no change+ N rll' rle' rlr' -> Z (P l e rll') rle' (Z rlr' re rr) -- RL subtree BF: 0->-1, SO.. CASE RL(1) !!+ P rll' rle' rlr' -> Z (Z l e rll') rle' (N rlr' re rr) -- RL subtree BF: 0->+1, SO.. CASE RL(2) !!++ -- (putPLR ll le lr e r): Put in LR subtree of (P (Z ll le lr) e r) , (never returns N)+ {-# INLINE putPLR #-}+ putPLR ll le E e r = Z (Z ll le E) e0 (Z E e r) -- r and ll must also be E, special CASE LR !!+ putPLR ll le (N lrl lre lrr) e r = let lr' = putN lrl lre lrr -- LR subtree BF<>0, H:h->h, so no change+ in lr' `seq` P (Z ll le lr') e r+ putPLR ll le (P lrl lre lrr) e r = let lr' = putP lrl lre lrr -- LR subtree BF<>0, H:h->h, so no change+ in lr' `seq` P (Z ll le lr') e r+ putPLR ll le (Z lrl lre lrr) e r = let lr' = putZ lrl lre lrr -- LR subtree BF= 0, so need to look for changes+ in case lr' of+ E -> error "push: Bug9" -- impossible+ Z _ _ _ -> P (Z ll le lr') e r -- LR subtree BF: 0-> 0, H:h->h, so no change+ N lrl' lre' lrr' -> Z (P ll le lrl') lre' (Z lrr' e r) -- LR subtree BF: 0->-1, SO.. CASE LR(2) !!+ P lrl' lre' lrr' -> Z (Z ll le lrl') lre' (N lrr' e r) -- LR subtree BF: 0->+1, SO.. CASE LR(1) !!++-- | Almost identical to 'push', but this version forces evaluation of the default new element+-- (second argument) if no matching element is found. Note that it does /not/ do this if+-- a matching element is found, because in this case the default new element is discarded+-- anyway. Note also that it does not force evaluation of any replacement value provided by the+-- selector (if it returns Eq). (You have to do that yourself if that\'s what you want.)+--+-- Complexity: O(log n)+push' :: (e -> COrdering e) -> e -> AVL e -> AVL e+push' c e0 = put where+ ----------------------------- LEVEL 0 ---------------------------------+ -- put --+ -----------------------------------------------------------------------+ put E = e0 `seq` Z E e0 E+ put (N l e r) = putN l e r+ put (Z l e r) = putZ l e r+ put (P l e r) = putP l e r++ ----------------------------- LEVEL 1 ---------------------------------+ -- putN, putZ, putP --+ -----------------------------------------------------------------------++ -- Put in (N l e r), BF=-1 , (never returns P)+ putN l e r = case c e of+ Lt -> putNL l e r -- <e, so put in L subtree+ Eq e' -> N l e' r -- =e, so update existing+ Gt -> putNR l e r -- >e, so put in R subtree++ -- Put in (Z l e r), BF= 0+ putZ l e r = case c e of+ Lt -> putZL l e r -- <e, so put in L subtree+ Eq e' -> Z l e' r -- =e, so update existing+ Gt -> putZR l e r -- >e, so put in R subtree++ -- Put in (P l e r), BF=+1 , (never returns N)+ putP l e r = case c e of+ Lt -> putPL l e r -- <e, so put in L subtree+ Eq e' -> P l e' r -- =e, so update existing+ Gt -> putPR l e r -- >e, so put in R subtree++ ----------------------------- LEVEL 2 ---------------------------------+ -- putNL, putZL, putPL --+ -- putNR, putZR, putPR --+ -----------------------------------------------------------------------++ -- (putNL l e r): Put in L subtree of (N l e r), BF=-1 (Never requires rebalancing) , (never returns P)+ {-# INLINE putNL #-}+ putNL E e r = e0 `seq` Z (Z E e0 E ) e r -- L subtree empty, H:0->1, parent BF:-1-> 0+ putNL (N ll le lr) e r = let l' = putN ll le lr -- L subtree BF<>0, H:h->h, parent BF:-1->-1+ in l' `seq` N l' e r+ putNL (P ll le lr) e r = let l' = putP ll le lr -- L subtree BF<>0, H:h->h, parent BF:-1->-1+ in l' `seq` N l' e r+ putNL (Z ll le lr) e r = let l' = putZ ll le lr -- L subtree BF= 0, so need to look for changes+ in case l' of+ E -> error "push': Bug0" -- impossible+ Z _ _ _ -> N l' e r -- L subtree BF:0-> 0, H:h->h , parent BF:-1->-1+ _ -> Z l' e r -- L subtree BF:0->+/-1, H:h->h+1, parent BF:-1-> 0++ -- (putZL l e r): Put in L subtree of (Z l e r), BF= 0 (Never requires rebalancing) , (never returns N)+ {-# INLINE putZL #-}+ putZL E e r = e0 `seq` P (Z E e0 E ) e r -- L subtree H:0->1, parent BF: 0->+1+ putZL (N ll le lr) e r = let l' = putN ll le lr -- L subtree BF<>0, H:h->h, parent BF: 0-> 0+ in l' `seq` Z l' e r+ putZL (P ll le lr) e r = let l' = putP ll le lr -- L subtree BF<>0, H:h->h, parent BF: 0-> 0+ in l' `seq` Z l' e r+ putZL (Z ll le lr) e r = let l' = putZ ll le lr -- L subtree BF= 0, so need to look for changes+ in case l' of+ E -> error "push': Bug1" -- impossible+ Z _ _ _ -> Z l' e r -- L subtree BF: 0-> 0, H:h->h , parent BF: 0-> 0+ _ -> P l' e r -- L subtree BF: 0->+/-1, H:h->h+1, parent BF: 0->+1++ -- (putZR l e r): Put in R subtree of (Z l e r), BF= 0 (Never requires rebalancing) , (never returns P)+ {-# INLINE putZR #-}+ putZR l e E = e0 `seq` N l e (Z E e0 E) -- R subtree H:0->1, parent BF: 0->-1+ putZR l e (N rl re rr) = let r' = putN rl re rr -- R subtree BF<>0, H:h->h, parent BF: 0-> 0+ in r' `seq` Z l e r'+ putZR l e (P rl re rr) = let r' = putP rl re rr -- R subtree BF<>0, H:h->h, parent BF: 0-> 0+ in r' `seq` Z l e r'+ putZR l e (Z rl re rr) = let r' = putZ rl re rr -- R subtree BF= 0, so need to look for changes+ in case r' of+ E -> error "push': Bug2" -- impossible+ Z _ _ _ -> Z l e r' -- R subtree BF: 0-> 0, H:h->h , parent BF: 0-> 0+ _ -> N l e r' -- R subtree BF: 0->+/-1, H:h->h+1, parent BF: 0->-1++ -- (putPR l e r): Put in R subtree of (P l e r), BF=+1 (Never requires rebalancing) , (never returns N)+ {-# INLINE putPR #-}+ putPR l e E = e0 `seq` Z l e (Z E e0 E) -- R subtree empty, H:0->1, parent BF:+1-> 0+ putPR l e (N rl re rr) = let r' = putN rl re rr -- R subtree BF<>0, H:h->h, parent BF:+1->+1+ in r' `seq` P l e r'+ putPR l e (P rl re rr) = let r' = putP rl re rr -- R subtree BF<>0, H:h->h, parent BF:+1->+1+ in r' `seq` P l e r'+ putPR l e (Z rl re rr) = let r' = putZ rl re rr -- R subtree BF= 0, so need to look for changes+ in case r' of+ E -> error "push': Bug3" -- impossible+ Z _ _ _ -> P l e r' -- R subtree BF:0-> 0, H:h->h , parent BF:+1->+1+ _ -> Z l e r' -- R subtree BF:0->+/-1, H:h->h+1, parent BF:+1-> 0++ -------- These 2 cases (NR and PL) may need rebalancing if they go to LEVEL 3 ---------++ -- (putNR l e r): Put in R subtree of (N l e r), BF=-1 , (never returns P)+ {-# INLINE putNR #-}+ putNR _ _ E = error "push': Bug4" -- impossible if BF=-1+ putNR l e (N rl re rr) = let r' = putN rl re rr -- R subtree BF<>0, H:h->h, parent BF:-1->-1+ in r' `seq` N l e r'+ putNR l e (P rl re rr) = let r' = putP rl re rr -- R subtree BF<>0, H:h->h, parent BF:-1->-1+ in r' `seq` N l e r'+ putNR l e (Z rl re rr) = case c re of -- determine if RR or RL+ Lt -> putNRL l e rl re rr -- RL (never returns P)+ Eq re' -> N l e (Z rl re' rr) -- new re+ Gt -> putNRR l e rl re rr -- RR (never returns P)++ -- (putPL l e r): Put in L subtree of (P l e r), BF=+1 , (never returns N)+ {-# INLINE putPL #-}+ putPL E _ _ = error "push': Bug5" -- impossible if BF=+1+ putPL (N ll le lr) e r = let l' = putN ll le lr -- L subtree BF<>0, H:h->h, parent BF:+1->+1+ in l' `seq` P l' e r+ putPL (P ll le lr) e r = let l' = putP ll le lr -- L subtree BF<>0, H:h->h, parent BF:+1->+1+ in l' `seq` P l' e r+ putPL (Z ll le lr) e r = case c le of -- determine if LL or LR+ Lt -> putPLL ll le lr e r -- LL (never returns N)+ Eq le' -> P (Z ll le' lr) e r -- new le+ Gt -> putPLR ll le lr e r -- LR (never returns N)++ ----------------------------- LEVEL 3 ---------------------------------+ -- putNRR, putPLL --+ -- putNRL, putPLR --+ -----------------------------------------------------------------------++ -- (putNRR l e rl re rr): Put in RR subtree of (N l e (Z rl re rr)) , (never returns P)+ {-# INLINE putNRR #-}+ putNRR l e rl re E = e0 `seq` Z (Z l e rl) re (Z E e0 E) -- l and rl must also be E, special CASE RR!!+ putNRR l e rl re (N rrl rre rrr) = let rr' = putN rrl rre rrr -- RR subtree BF<>0, H:h->h, so no change+ in rr' `seq` N l e (Z rl re rr')+ putNRR l e rl re (P rrl rre rrr) = let rr' = putP rrl rre rrr -- RR subtree BF<>0, H:h->h, so no change+ in rr' `seq` N l e (Z rl re rr')+ putNRR l e rl re (Z rrl rre rrr) = let rr' = putZ rrl rre rrr -- RR subtree BF= 0, so need to look for changes+ in case rr' of+ E -> error "push': Bug6" -- impossible+ Z _ _ _ -> N l e (Z rl re rr') -- RR subtree BF: 0-> 0, H:h->h, so no change+ _ -> Z (Z l e rl) re rr' -- RR subtree BF: 0->+/-1, H:h->h+1, parent BF:-1->-2, CASE RR !!++ -- (putPLL ll le lr e r): Put in LL subtree of (P (Z ll le lr) e r) , (never returns N)+ {-# INLINE putPLL #-}+ putPLL E le lr e r = e0 `seq` Z (Z E e0 E) le (Z lr e r) -- r and lr must also be E, special CASE LL!!+ putPLL (N lll lle llr) le lr e r = let ll' = putN lll lle llr -- LL subtree BF<>0, H:h->h, so no change+ in ll' `seq` P (Z ll' le lr) e r+ putPLL (P lll lle llr) le lr e r = let ll' = putP lll lle llr -- LL subtree BF<>0, H:h->h, so no change+ in ll' `seq` P (Z ll' le lr) e r+ putPLL (Z lll lle llr) le lr e r = let ll' = putZ lll lle llr -- LL subtree BF= 0, so need to look for changes+ in case ll' of+ E -> error "push': Bug7" -- impossible+ Z _ _ _ -> P (Z ll' le lr) e r -- LL subtree BF: 0-> 0, H:h->h, so no change+ _ -> Z ll' le (Z lr e r) -- LL subtree BF: 0->+/-1, H:h->h+1, parent BF:-1->-2, CASE LL !!++ -- (putNRL l e rl re rr): Put in RL subtree of (N l e (Z rl re rr)) , (never returns P)+ {-# INLINE putNRL #-}+ putNRL l e E re rr = e0 `seq` Z (Z l e E) e0 (Z E re rr) -- l and rr must also be E, special CASE LR !!+ putNRL l e (N rll rle rlr) re rr = let rl' = putN rll rle rlr -- RL subtree BF<>0, H:h->h, so no change+ in rl' `seq` N l e (Z rl' re rr)+ putNRL l e (P rll rle rlr) re rr = let rl' = putP rll rle rlr -- RL subtree BF<>0, H:h->h, so no change+ in rl' `seq` N l e (Z rl' re rr)+ putNRL l e (Z rll rle rlr) re rr = let rl' = putZ rll rle rlr -- RL subtree BF= 0, so need to look for changes+ in case rl' of+ E -> error "push': Bug8" -- impossible+ Z _ _ _ -> N l e (Z rl' re rr) -- RL subtree BF: 0-> 0, H:h->h, so no change+ N rll' rle' rlr' -> Z (P l e rll') rle' (Z rlr' re rr) -- RL subtree BF: 0->-1, SO.. CASE RL(1) !!+ P rll' rle' rlr' -> Z (Z l e rll') rle' (N rlr' re rr) -- RL subtree BF: 0->+1, SO.. CASE RL(2) !!++ -- (putPLR ll le lr e r): Put in LR subtree of (P (Z ll le lr) e r) , (never returns N)+ {-# INLINE putPLR #-}+ putPLR ll le E e r = e0 `seq` Z (Z ll le E) e0 (Z E e r) -- r and ll must also be E, special CASE LR !!+ putPLR ll le (N lrl lre lrr) e r = let lr' = putN lrl lre lrr -- LR subtree BF<>0, H:h->h, so no change+ in lr' `seq` P (Z ll le lr') e r+ putPLR ll le (P lrl lre lrr) e r = let lr' = putP lrl lre lrr -- LR subtree BF<>0, H:h->h, so no change+ in lr' `seq` P (Z ll le lr') e r+ putPLR ll le (Z lrl lre lrr) e r = let lr' = putZ lrl lre lrr -- LR subtree BF= 0, so need to look for changes+ in case lr' of+ E -> error "push': Bug9" -- impossible+ Z _ _ _ -> P (Z ll le lr') e r -- LR subtree BF: 0-> 0, H:h->h, so no change+ N lrl' lre' lrr' -> Z (P ll le lrl') lre' (Z lrr' e r) -- LR subtree BF: 0->-1, SO.. CASE LR(2) !!+ P lrl' lre' lrr' -> Z (Z ll le lrl') lre' (N lrr' e r) -- LR subtree BF: 0->+1, SO.. CASE LR(1) !!++-- | Similar to 'push', but returns the original tree if the combining comparison returns+-- @('Data.COrdering.Eq' 'Nothing')@. So this function can be used reduce heap burn rate by avoiding duplication+-- of nodes on the insertion path. But it may also be marginally slower otherwise.+--+-- Note that this function is /non-strict/ in it\'s second argument (the default value which+-- is inserted in the search fails or is discarded if the search succeeds). If you want+-- to force evaluation, but only if it\'s actually incorprated in the tree, then use 'pushMaybe''+--+-- Complexity: O(log n)+pushMaybe :: (e -> COrdering (Maybe e)) -> e -> AVL e -> AVL e+pushMaybe c e t = case openPathWith c t of+ FullBP _ Nothing -> t+ FullBP p (Just e') -> writePath p e' t+ EmptyBP p -> insertPath p e t++-- | Almost identical to 'pushMaybe', but this version forces evaluation of the default new element+-- (second argument) if no matching element is found. Note that it does /not/ do this if+-- a matching element is found, because in this case the default new element is discarded+-- anyway.+--+-- Complexity: O(log n)+pushMaybe' :: (e -> COrdering (Maybe e)) -> e -> AVL e -> AVL e+pushMaybe' c e t = case openPathWith c t of+ FullBP _ Nothing -> t+ FullBP p (Just e') -> writePath p e' t+ EmptyBP p -> e `seq` insertPath p e t++-- | Push a new element in the leftmost position of an AVL tree. No comparison or searching is involved.+--+-- Complexity: O(log n)+pushL :: e -> AVL e -> AVL e+pushL e0 = pushL' where -- There now follows a cut down version of the more general put.+ -- Insertion is always on the left subtree.+ -- Re-Balancing cases RR,RL/LR(1/2) never occur. Only LL!+ -- There are also more impossible cases (putZL never returns N)+ ----------------------------- LEVEL 0 ---------------------------------+ -- pushL' --+ -----------------------------------------------------------------------+ pushL' E = Z E e0 E+ pushL' (N l e r) = putNL l e r+ pushL' (Z l e r) = putZL l e r+ pushL' (P l e r) = putPL l e r++ ----------------------------- LEVEL 2 ---------------------------------+ -- putNL, putZL, putPL --+ -----------------------------------------------------------------------++ -- (putNL l e r): Put in L subtree of (N l e r), BF=-1 (Never requires rebalancing) , (never returns P)+ putNL E e r = Z (Z E e0 E) e r -- L subtree empty, H:0->1, parent BF:-1-> 0+ putNL (N ll le lr) e r = let l' = putNL ll le lr -- L subtree BF<>0, H:h->h, parent BF:-1->-1+ in l' `seq` N l' e r+ putNL (P ll le lr) e r = let l' = putPL ll le lr -- L subtree BF<>0, H:h->h, parent BF:-1->-1+ in l' `seq` N l' e r+ putNL (Z ll le lr) e r = let l' = putZL ll le lr -- L subtree BF= 0, so need to look for changes+ in case l' of+ Z _ _ _ -> N l' e r -- L subtree BF:0-> 0, H:h->h , parent BF:-1->-1+ P _ _ _ -> Z l' e r -- L subtree BF:0->+1, H:h->h+1, parent BF:-1-> 0+ _ -> error "pushL: Bug0" -- impossible++ -- (putZL l e r): Put in L subtree of (Z l e r), BF= 0 (Never requires rebalancing) , (never returns N)+ putZL E e r = P (Z E e0 E) e r -- L subtree H:0->1, parent BF: 0->+1+ putZL (N ll le lr) e r = let l' = putNL ll le lr -- L subtree BF<>0, H:h->h, parent BF: 0-> 0+ in l' `seq` Z l' e r+ putZL (P ll le lr) e r = let l' = putPL ll le lr -- L subtree BF<>0, H:h->h, parent BF: 0-> 0+ in l' `seq` Z l' e r+ putZL (Z ll le lr) e r = let l' = putZL ll le lr -- L subtree BF= 0, so need to look for changes+ in case l' of+ Z _ _ _ -> Z l' e r -- L subtree BF: 0-> 0, H:h->h , parent BF: 0-> 0+ N _ _ _ -> error "pushL: Bug1" -- impossible+ _ -> P l' e r -- L subtree BF: 0->+1, H:h->h+1, parent BF: 0->+1++ -------- This case (PL) may need rebalancing if it goes to LEVEL 3 ---------++ -- (putPL l e r): Put in L subtree of (P l e r), BF=+1 , (never returns N)+ putPL E _ _ = error "pushL: Bug2" -- impossible if BF=+1+ putPL (N ll le lr) e r = let l' = putNL ll le lr -- L subtree BF<>0, H:h->h, parent BF:+1->+1+ in l' `seq` P l' e r+ putPL (P ll le lr) e r = let l' = putPL ll le lr -- L subtree BF<>0, H:h->h, parent BF:+1->+1+ in l' `seq` P l' e r+ putPL (Z ll le lr) e r = putPLL ll le lr e r -- LL (never returns N)++ ----------------------------- LEVEL 3 ---------------------------------+ -- putPLL --+ -----------------------------------------------------------------------++ -- (putPLL ll le lr e r): Put in LL subtree of (P (Z ll le lr) e r) , (never returns N)+ {-# INLINE putPLL #-}+ putPLL E le lr e r = Z (Z E e0 E) le (Z lr e r) -- r and lr must also be E, special CASE LL!!+ putPLL (N lll lle llr) le lr e r = let ll' = putNL lll lle llr -- LL subtree BF<>0, H:h->h, so no change+ in ll' `seq` P (Z ll' le lr) e r+ putPLL (P lll lle llr) le lr e r = let ll' = putPL lll lle llr -- LL subtree BF<>0, H:h->h, so no change+ in ll' `seq` P (Z ll' le lr) e r+ putPLL (Z lll lle llr) le lr e r = let ll' = putZL lll lle llr -- LL subtree BF= 0, so need to look for changes+ in case ll' of+ Z _ _ _ -> P (Z ll' le lr) e r -- LL subtree BF: 0-> 0, H:h->h, so no change+ N _ _ _ -> error "pushL: Bug3" -- impossible+ _ -> Z ll' le (Z lr e r) -- LL subtree BF: 0->+1, H:h->h+1, parent BF:-1->-2, CASE LL !!++-- | Push a new element in the rightmost position of an AVL tree. No comparison or searching is involved.+--+-- Complexity: O(log n)+pushR :: AVL e -> e -> AVL e+pushR t e0 = pushR' t where -- There now follows a cut down version of the more general put.+ -- Insertion is always on the right subtree.+ -- Re-Balancing cases LL,RL/LR(1/2) never occur. Only RR!+ -- There are also more impossible cases (putZR never returns P)++ ----------------------------- LEVEL 0 ---------------------------------+ -- pushR' --+ -----------------------------------------------------------------------+ pushR' E = Z E e0 E+ pushR' (N l e r) = putNR l e r+ pushR' (Z l e r) = putZR l e r+ pushR' (P l e r) = putPR l e r++ ----------------------------- LEVEL 2 ---------------------------------+ -- putNR, putZR, putPR --+ -----------------------------------------------------------------------++ -- (putZR l e r): Put in R subtree of (Z l e r), BF= 0 (Never requires rebalancing) , (never returns P)+ putZR l e E = N l e (Z E e0 E) -- R subtree H:0->1, parent BF: 0->-1+ putZR l e (N rl re rr) = let r' = putNR rl re rr -- R subtree BF<>0, H:h->h, parent BF: 0-> 0+ in r' `seq` Z l e r'+ putZR l e (P rl re rr) = let r' = putPR rl re rr -- R subtree BF<>0, H:h->h, parent BF: 0-> 0+ in r' `seq` Z l e r'+ putZR l e (Z rl re rr) = let r' = putZR rl re rr -- R subtree BF= 0, so need to look for changes+ in case r' of+ Z _ _ _ -> Z l e r' -- R subtree BF: 0-> 0, H:h->h , parent BF: 0-> 0+ N _ _ _ -> N l e r' -- R subtree BF: 0->-1, H:h->h+1, parent BF: 0->-1+ _ -> error "pushR: Bug0" -- impossible++ -- (putPR l e r): Put in R subtree of (P l e r), BF=+1 (Never requires rebalancing) , (never returns N)+ putPR l e E = Z l e (Z E e0 E) -- R subtree empty, H:0->1, parent BF:+1-> 0+ putPR l e (N rl re rr) = let r' = putNR rl re rr -- R subtree BF<>0, H:h->h, parent BF:+1->+1+ in r' `seq` P l e r'+ putPR l e (P rl re rr) = let r' = putPR rl re rr -- R subtree BF<>0, H:h->h, parent BF:+1->+1+ in r' `seq` P l e r'+ putPR l e (Z rl re rr) = let r' = putZR rl re rr -- R subtree BF= 0, so need to look for changes+ in case r' of+ Z _ _ _ -> P l e r' -- R subtree BF:0-> 0, H:h->h , parent BF:+1->+1+ N _ _ _ -> Z l e r' -- R subtree BF:0->-1, H:h->h+1, parent BF:+1-> 0+ _ -> error "pushR: Bug1" -- impossible++ -------- This case (NR) may need rebalancing if it goes to LEVEL 3 ---------++ -- (putNR l e r): Put in R subtree of (N l e r), BF=-1 , (never returns P)+ putNR _ _ E = error "pushR: Bug2" -- impossible if BF=-1+ putNR l e (N rl re rr) = let r' = putNR rl re rr -- R subtree BF<>0, H:h->h, parent BF:-1->-1+ in r' `seq` N l e r'+ putNR l e (P rl re rr) = let r' = putPR rl re rr -- R subtree BF<>0, H:h->h, parent BF:-1->-1+ in r' `seq` N l e r'+ putNR l e (Z rl re rr) = putNRR l e rl re rr -- RR (never returns P)++ ----------------------------- LEVEL 3 ---------------------------------+ -- putNRR --+ -----------------------------------------------------------------------++ -- (putNRR l e rl re rr): Put in RR subtree of (N l e (Z rl re rr)) , (never returns P)+ {-# INLINE putNRR #-}+ putNRR l e rl re E = Z (Z l e rl) re (Z E e0 E) -- l and rl must also be E, special CASE RR!!+ putNRR l e rl re (N rrl rre rrr) = let rr' = putNR rrl rre rrr -- RR subtree BF<>0, H:h->h, so no change+ in rr' `seq` N l e (Z rl re rr')+ putNRR l e rl re (P rrl rre rrr) = let rr' = putPR rrl rre rrr -- RR subtree BF<>0, H:h->h, so no change+ in rr' `seq` N l e (Z rl re rr')+ putNRR l e rl re (Z rrl rre rrr) = let rr' = putZR rrl rre rrr -- RR subtree BF= 0, so need to look for changes+ in case rr' of+ Z _ _ _ -> N l e (Z rl re rr') -- RR subtree BF: 0-> 0, H:h->h, so no change+ N _ _ _ -> Z (Z l e rl) re rr' -- RR subtree BF: 0->-1, H:h->h+1, parent BF:-1->-2, CASE RR !!+ _ -> error "pushR: Bug3" -- impossible
+ src/Data/Tree/AVL/Read.hs view
@@ -0,0 +1,163 @@+-- |+-- Copyright : (c) Adrian Hey 2004,2005+-- License : BSD3+--+{-# OPTIONS_HADDOCK hide #-}+module Data.Tree.AVL.Read+(-- * Reading from AVL trees++ -- ** Reading from extreme left or right+ assertReadL,tryReadL,+ assertReadR,tryReadR,++ -- ** Reading from /sorted/ AVL trees+ assertRead,tryRead,tryReadMaybe,defaultRead,++ -- ** Simple searches of /sorted/ AVL trees+ contains,+) where++import Prelude -- so haddock finds the symbols there++import Data.COrdering+import Data.Tree.AVL.Internals.Types(AVL(..))++-- | Read the leftmost element from a /non-empty/ tree. Raises an error if the tree is empty.+-- If the tree is sorted this will return the least element.+--+-- Complexity: O(log n)+assertReadL :: AVL e -> e+assertReadL E = error "assertReadL: Empty tree."+assertReadL (N l e _) = readLE l e+assertReadL (Z l e _) = readLE l e+assertReadL (P l _ _) = readLNE l -- BF=+1, so left sub-tree cannot be empty.++-- | Similar to 'assertReadL' but returns 'Nothing' if the tree is empty.+--+-- Complexity: O(log n)+tryReadL :: AVL e -> Maybe e+tryReadL E = Nothing+tryReadL (N l e _) = Just $! readLE l e+tryReadL (Z l e _) = Just $! readLE l e+tryReadL (P l _ _) = Just $! readLNE l -- BF=+1, so left sub-tree cannot be empty.++-- Local utilities for the above+readLNE :: AVL e -> e+readLNE E = error "readLNE: Bug."+readLNE (N l e _) = readLE l e+readLNE (Z l e _) = readLE l e+readLNE (P l _ _) = readLNE l -- BF=+1, so left sub-tree cannot be empty.+readLE :: AVL e -> e -> e+readLE E e = e+readLE (N l e _) _ = readLE l e+readLE (Z l e _) _ = readLE l e+readLE (P l _ _) _ = readLNE l -- BF=+1, so left sub-tree cannot be empty.+++-- | Read the rightmost element from a /non-empty/ tree. Raises an error if the tree is empty.+-- If the tree is sorted this will return the greatest element.+--+-- Complexity: O(log n)+assertReadR :: AVL e -> e+assertReadR E = error "assertReadR: Empty tree."+assertReadR (P _ e r) = readRE r e+assertReadR (Z _ e r) = readRE r e+assertReadR (N _ _ r) = readRNE r -- BF=-1, so right sub-tree cannot be empty.++-- | Similar to 'assertReadR' but returns 'Nothing' if the tree is empty.+--+-- Complexity: O(log n)+tryReadR :: AVL e -> Maybe e+tryReadR E = Nothing+tryReadR (P _ e r) = Just $! readRE r e+tryReadR (Z _ e r) = Just $! readRE r e+tryReadR (N _ _ r) = Just $! readRNE r -- BF=-1, so right sub-tree cannot be empty.++-- Local utilities for the above+readRNE :: AVL e -> e+readRNE E = error "readRNE: Bug."+readRNE (P _ e r) = readRE r e+readRNE (Z _ e r) = readRE r e+readRNE (N _ _ r) = readRNE r -- BF=-1, so right sub-tree cannot be empty.+readRE :: AVL e -> e -> e+readRE E e = e+readRE (P _ e r) _ = readRE r e+readRE (Z _ e r) _ = readRE r e+readRE (N _ _ r) _ = readRNE r -- BF=-1, so right sub-tree cannot be empty.+++-- | General purpose function to perform a search of a sorted tree, using the supplied selector.+-- This function raises a error if the search fails.+--+-- Complexity: O(log n)+assertRead :: AVL e -> (e -> COrdering a) -> a+assertRead t c = genRead' t where+ genRead' E = error "assertRead failed."+ genRead' (N l e r) = genRead'' l e r+ genRead' (Z l e r) = genRead'' l e r+ genRead' (P l e r) = genRead'' l e r+ genRead'' l e r = case c e of+ Lt -> genRead' l+ Eq a -> a+ Gt -> genRead' r++-- | General purpose function to perform a search of a sorted tree, using the supplied selector.+-- This function is similar to 'assertRead', but returns 'Nothing' if the search failed.+--+-- Complexity: O(log n)+tryRead :: AVL e -> (e -> COrdering a) -> Maybe a+tryRead t c = tryRead' t where+ tryRead' E = Nothing+ tryRead' (N l e r) = tryRead'' l e r+ tryRead' (Z l e r) = tryRead'' l e r+ tryRead' (P l e r) = tryRead'' l e r+ tryRead'' l e r = case c e of+ Lt -> tryRead' l+ Eq a -> Just a+ Gt -> tryRead' r++-- | This version returns the result of the selector (without adding a 'Just' wrapper) if the search+-- succeeds, or 'Nothing' if it fails.+--+-- Complexity: O(log n)+tryReadMaybe :: AVL e -> (e -> COrdering (Maybe a)) -> Maybe a+tryReadMaybe t c = tryRead' t where+ tryRead' E = Nothing+ tryRead' (N l e r) = tryRead'' l e r+ tryRead' (Z l e r) = tryRead'' l e r+ tryRead' (P l e r) = tryRead'' l e r+ tryRead'' l e r = case c e of+ Lt -> tryRead' l+ Eq mba -> mba+ Gt -> tryRead' r++-- | General purpose function to perform a search of a sorted tree, using the supplied selector.+-- This function is similar to 'assertRead', but returns a the default value (first argument) if+-- the search fails.+--+-- Complexity: O(log n)+defaultRead :: a -> AVL e -> (e -> COrdering a) -> a+defaultRead d t c = genRead' t where+ genRead' E = d+ genRead' (N l e r) = genRead'' l e r+ genRead' (Z l e r) = genRead'' l e r+ genRead' (P l e r) = genRead'' l e r+ genRead'' l e r = case c e of+ Lt -> genRead' l+ Eq a -> a+ Gt -> genRead' r++-- | General purpose function to perform a search of a sorted tree, using the supplied selector.+-- Returns True if matching element is found.+--+-- Complexity: O(log n)+contains :: AVL e -> (e -> Ordering) -> Bool+contains t c = contains' t where+ contains' E = False+ contains' (N l e r) = contains'' l e r+ contains' (Z l e r) = contains'' l e r+ contains' (P l e r) = contains'' l e r+ contains'' l e r = case c e of+ LT -> contains' l+ EQ -> True+ GT -> contains' r
+ src/Data/Tree/AVL/Set.hs view
@@ -0,0 +1,596 @@+-- |+-- Copyright : (c) Adrian Hey 2004,2005+-- License : BSD3+--+{-# OPTIONS_HADDOCK hide #-}+module Data.Tree.AVL.Set+(-- * Set operations+ -- | Functions for manipulating AVL trees which represent ordered sets (I.E. /sorted/ trees).+ -- Note that although many of these functions work with a variety of different element+ -- types they all require that elements are sorted according to the same criterion (such+ -- as a field value in a record).++ -- ** Union+ union,unionMaybe,disjointUnion,unions,++ -- ** Difference+ difference,differenceMaybe,symDifference,++ -- ** Intersection+ intersection,intersectionMaybe,++ -- *** Intersection with the result as a list+ -- | Sometimes you don\'t want intersection to give a tree, particularly if the+ -- resulting elements are not orderered or sorted according to whatever criterion was+ -- used to sort the elements of the input sets.+ --+ -- The reason these variants are provided for intersection only (and not the other+ -- set functions) is that the (tree returning) intersections always construct an entirely+ -- new tree, whereas with the others the resulting tree will typically share sub-trees+ -- with one or both of the originals. (Of course the results of the others can easily be+ -- converted to a list too if required.)+ intersectionToList,intersectionAsList,+ intersectionMaybeToList,intersectionMaybeAsList,++ -- ** \'Venn diagram\' operations+ -- | Given two sets A and B represented as sorted AVL trees, the venn operations evaluate+ -- components @A-B@, @A.B@ and @B-A@. The intersection part may be obtained as a List+ -- rather than AVL tree if required.+ --+ -- Note that in all cases the three resulting sets are /disjoint/ and can safely be re-combined+ -- after most \"munging\" operations using 'disjointUnion'.+ venn,vennMaybe,++ -- *** \'Venn diagram\' operations with the intersection component as a List.+ -- | These variants are provided for the same reasons as the Intersection as List variants.+ vennToList,vennAsList,+ vennMaybeToList,vennMaybeAsList,++ -- ** Subset+ isSubsetOf,isSubsetOfBy,+) where++import Prelude -- so haddock finds the symbols there++import Data.Tree.AVL.Internals.Types(AVL(..))+import Data.Tree.AVL.Height(addHeight)+import Data.Tree.AVL.List(asTreeLenL)+import Data.Tree.AVL.Internals.HJoin(spliceH)+import Data.Tree.AVL.Internals.HSet(unionH,unionMaybeH,disjointUnionH,+ intersectionH,intersectionMaybeH,+ vennH,vennMaybeH,+ differenceH,differenceMaybeH,symDifferenceH)++import Data.COrdering++import GHC.Base+#include "ghcdefs.h"++-- | Uses the supplied combining comparison to evaluate the union of two sets represented as+-- sorted AVL trees. Whenever the combining comparison is applied, the first comparison argument is+-- an element of the first tree and the second comparison argument is an element of the second tree.+--+-- Complexity: Not sure, but I\'d appreciate it if someone could figure it out.+union :: (e -> e -> COrdering e) -> AVL e -> AVL e -> AVL e+union c = gu where -- This is to avoid O(log n) height calculation for empty sets+ gu E t1 = t1+ gu t0 E = t0+ gu t0@(N l0 _ _ ) t1@(N l1 _ _ ) = gu_ t0 (addHeight L(2) l0) t1 (addHeight L(2) l1)+ gu t0@(N l0 _ _ ) t1@(Z l1 _ _ ) = gu_ t0 (addHeight L(2) l0) t1 (addHeight L(1) l1)+ gu t0@(N l0 _ _ ) t1@(P _ _ r1) = gu_ t0 (addHeight L(2) l0) t1 (addHeight L(2) r1)+ gu t0@(Z l0 _ _ ) t1@(N l1 _ _ ) = gu_ t0 (addHeight L(1) l0) t1 (addHeight L(2) l1)+ gu t0@(Z l0 _ _ ) t1@(Z l1 _ _ ) = gu_ t0 (addHeight L(1) l0) t1 (addHeight L(1) l1)+ gu t0@(Z l0 _ _ ) t1@(P _ _ r1) = gu_ t0 (addHeight L(1) l0) t1 (addHeight L(2) r1)+ gu t0@(P _ _ r0) t1@(N l1 _ _ ) = gu_ t0 (addHeight L(2) r0) t1 (addHeight L(2) l1)+ gu t0@(P _ _ r0) t1@(Z l1 _ _ ) = gu_ t0 (addHeight L(2) r0) t1 (addHeight L(1) l1)+ gu t0@(P _ _ r0) t1@(P _ _ r1) = gu_ t0 (addHeight L(2) r0) t1 (addHeight L(2) r1)+ gu_ t0 h0 t1 h1 = case unionH c t0 h0 t1 h1 of UBT2(t,_) -> t++-- | Similar to 'union', but the resulting tree does not include elements in cases where+-- the supplied combining comparison returns @(Eq Nothing)@.+--+-- Complexity: Not sure, but I\'d appreciate it if someone could figure it out.+unionMaybe :: (e -> e -> COrdering (Maybe e)) -> AVL e -> AVL e -> AVL e+unionMaybe c = gu where -- This is to avoid O(log n) height calculation for empty sets+ gu E t1 = t1+ gu t0 E = t0+ gu t0@(N l0 _ _ ) t1@(N l1 _ _ ) = gu_ t0 (addHeight L(2) l0) t1 (addHeight L(2) l1)+ gu t0@(N l0 _ _ ) t1@(Z l1 _ _ ) = gu_ t0 (addHeight L(2) l0) t1 (addHeight L(1) l1)+ gu t0@(N l0 _ _ ) t1@(P _ _ r1) = gu_ t0 (addHeight L(2) l0) t1 (addHeight L(2) r1)+ gu t0@(Z l0 _ _ ) t1@(N l1 _ _ ) = gu_ t0 (addHeight L(1) l0) t1 (addHeight L(2) l1)+ gu t0@(Z l0 _ _ ) t1@(Z l1 _ _ ) = gu_ t0 (addHeight L(1) l0) t1 (addHeight L(1) l1)+ gu t0@(Z l0 _ _ ) t1@(P _ _ r1) = gu_ t0 (addHeight L(1) l0) t1 (addHeight L(2) r1)+ gu t0@(P _ _ r0) t1@(N l1 _ _ ) = gu_ t0 (addHeight L(2) r0) t1 (addHeight L(2) l1)+ gu t0@(P _ _ r0) t1@(Z l1 _ _ ) = gu_ t0 (addHeight L(2) r0) t1 (addHeight L(1) l1)+ gu t0@(P _ _ r0) t1@(P _ _ r1) = gu_ t0 (addHeight L(2) r0) t1 (addHeight L(2) r1)+ gu_ t0 h0 t1 h1 = case unionMaybeH c t0 h0 t1 h1 of UBT2(t,_) -> t++-- | Uses the supplied comparison to evaluate the union of two /disjoint/ sets represented as+-- sorted AVL trees. It will be slightly faster than 'union' but will raise an error if the+-- two sets intersect. Typically this would be used to re-combine the \"post-munge\" results+-- from one of the \"venn\" operations.+--+-- Complexity: Not sure, but I\'d appreciate it if someone could figure it out.+-- (Faster than Hedge union from Data.Set at any rate).+disjointUnion :: (e -> e -> Ordering) -> AVL e -> AVL e -> AVL e+disjointUnion c = gu where -- This is to avoid O(log n) height calculation for empty sets+ gu E t1 = t1+ gu t0 E = t0+ gu t0@(N l0 _ _ ) t1@(N l1 _ _ ) = gu_ t0 (addHeight L(2) l0) t1 (addHeight L(2) l1)+ gu t0@(N l0 _ _ ) t1@(Z l1 _ _ ) = gu_ t0 (addHeight L(2) l0) t1 (addHeight L(1) l1)+ gu t0@(N l0 _ _ ) t1@(P _ _ r1) = gu_ t0 (addHeight L(2) l0) t1 (addHeight L(2) r1)+ gu t0@(Z l0 _ _ ) t1@(N l1 _ _ ) = gu_ t0 (addHeight L(1) l0) t1 (addHeight L(2) l1)+ gu t0@(Z l0 _ _ ) t1@(Z l1 _ _ ) = gu_ t0 (addHeight L(1) l0) t1 (addHeight L(1) l1)+ gu t0@(Z l0 _ _ ) t1@(P _ _ r1) = gu_ t0 (addHeight L(1) l0) t1 (addHeight L(2) r1)+ gu t0@(P _ _ r0) t1@(N l1 _ _ ) = gu_ t0 (addHeight L(2) r0) t1 (addHeight L(2) l1)+ gu t0@(P _ _ r0) t1@(Z l1 _ _ ) = gu_ t0 (addHeight L(2) r0) t1 (addHeight L(1) l1)+ gu t0@(P _ _ r0) t1@(P _ _ r1) = gu_ t0 (addHeight L(2) r0) t1 (addHeight L(2) r1)+ gu_ t0 h0 t1 h1 = case disjointUnionH c t0 h0 t1 h1 of UBT2(t,_) -> t++-- | Uses the supplied combining comparison to evaluate the union of all sets in a list+-- of sets represented as sorted AVL trees. Behaves as if defined..+--+-- @unions ccmp avls = foldl' ('union' ccmp) empty avls@+unions :: (e -> e -> COrdering e) -> [AVL e] -> AVL e+unions c = gus E L(0) where+ gus a _ [] = a+ gus a ha ( E :avls) = gus a ha avls+ gus a ha (t@(N l _ _):avls) = case unionH c a ha t (addHeight L(2) l) of UBT2(a_,ha_) -> gus a_ ha_ avls+ gus a ha (t@(Z l _ _):avls) = case unionH c a ha t (addHeight L(1) l) of UBT2(a_,ha_) -> gus a_ ha_ avls+ gus a ha (t@(P _ _ r):avls) = case unionH c a ha t (addHeight L(2) r) of UBT2(a_,ha_) -> gus a_ ha_ avls++-- | Uses the supplied combining comparison to evaluate the intersection of two sets represented as+-- sorted AVL trees.+--+-- Complexity: Not sure, but I\'d appreciate it if someone could figure it out.+intersection :: (a -> b -> COrdering c) -> AVL a -> AVL b -> AVL c+intersection c t0 t1 = case intersectionH c t0 t1 of UBT2(t,_) -> t++-- | Similar to 'intersection', but the resulting tree does not include elements in cases where+-- the supplied combining comparison returns @(Eq Nothing)@.+--+-- Complexity: Not sure, but I\'d appreciate it if someone could figure it out.+intersectionMaybe :: (a -> b -> COrdering (Maybe c)) -> AVL a -> AVL b -> AVL c+intersectionMaybe c t0 t1 = case intersectionMaybeH c t0 t1 of UBT2(t,_) -> t++-- | Similar to 'intersection', but prepends the result to the supplied list in+-- ascending order. This is a (++) free function which behaves as if defined:+--+-- @intersectionToList c setA setB cs = asListL (intersection c setA setB) ++ cs@+--+-- Complexity: Not sure, but I\'d appreciate it if someone could figure it out.+intersectionToList :: (a -> b -> COrdering c) -> AVL a -> AVL b -> [c] -> [c]+intersectionToList comp = i where+ -- i :: AVL a -> AVL b -> [c] -> [c]+ i E _ cs = cs+ i _ E cs = cs+ i (N l0 e0 r0) (N l1 e1 r1) cs = i' l0 e0 r0 l1 e1 r1 cs+ i (N l0 e0 r0) (Z l1 e1 r1) cs = i' l0 e0 r0 l1 e1 r1 cs+ i (N l0 e0 r0) (P l1 e1 r1) cs = i' l0 e0 r0 l1 e1 r1 cs+ i (Z l0 e0 r0) (N l1 e1 r1) cs = i' l0 e0 r0 l1 e1 r1 cs+ i (Z l0 e0 r0) (Z l1 e1 r1) cs = i' l0 e0 r0 l1 e1 r1 cs+ i (Z l0 e0 r0) (P l1 e1 r1) cs = i' l0 e0 r0 l1 e1 r1 cs+ i (P l0 e0 r0) (N l1 e1 r1) cs = i' l0 e0 r0 l1 e1 r1 cs+ i (P l0 e0 r0) (Z l1 e1 r1) cs = i' l0 e0 r0 l1 e1 r1 cs+ i (P l0 e0 r0) (P l1 e1 r1) cs = i' l0 e0 r0 l1 e1 r1 cs+ i' l0 e0 r0 l1 e1 r1 cs =+ case comp e0 e1 of+ -- e0 < e1, so (l0 < e0 < e1) & (e0 < e1 < r1)+ Lt -> case forkR r0 e1 of+ UBT5(rl0,_,mbc1,rr0,_) -> case forkL e0 l1 of -- (e0 < rl0 < e1) & (e0 < e1 < rr0)+ UBT5(ll1,_,mbc0,lr1,_) -> -- (ll1 < e0 < e1) & (e0 < lr1 < e1)+ -- (l0 + ll1) < e0 < (rl0 + lr1) < e1 < (rr0 + r1)+ let cs' = i rr0 r1 cs+ cs'' = cs' `seq` case mbc1 of+ Nothing -> i rl0 lr1 cs'+ Just c1 -> i rl0 lr1 (c1:cs')+ in cs'' `seq` case mbc0 of+ Nothing -> i l0 ll1 cs''+ Just c0 -> i l0 ll1 (c0:cs'')+ -- e0 = e1+ Eq c -> let cs' = i r0 r1 cs in cs' `seq` i l0 l1 (c:cs')+ -- e1 < e0, so (l1 < e1 < e0) & (e1 < e0 < r0)+ Gt -> case forkL e0 r1 of+ UBT5(rl1,_,mbc0,rr1,_) -> case forkR l0 e1 of -- (e1 < rl1 < e0) & (e1 < e0 < rr1)+ UBT5(ll0,_,mbc1,lr0,_) -> -- (ll0 < e1 < e0) & (e1 < lr0 < e0)+ -- (ll0 + l1) < e1 < (lr0 + rl1) < e0 < (r0 + rr1)+ let cs' = i r0 rr1 cs+ cs'' = cs' `seq` case mbc0 of+ Nothing -> i lr0 rl1 cs'+ Just c0 -> i lr0 rl1 (c0:cs')+ in cs'' `seq` case mbc1 of+ Nothing -> i ll0 l1 cs''+ Just c1 -> i ll0 l1 (c1:cs'')+ -- We need 2 different versions of fork (L & R) to ensure that comparison arguments are used in+ -- the right order (c e0 e1)+ -- forkL :: a -> AVL b -> UBT5(AVL b,UINT,Maybe c,AVL b,UINT)+ forkL e0 t1 = forkL_ t1 L(0) where+ forkL_ E h = UBT5(E,h,Nothing,E,h) -- Relative heights!!+ forkL_ (N l e r) h = forkL__ l DECINT2(h) e r DECINT1(h)+ forkL_ (Z l e r) h = forkL__ l DECINT1(h) e r DECINT1(h)+ forkL_ (P l e r) h = forkL__ l DECINT1(h) e r DECINT2(h)+ forkL__ l hl e r hr = case comp e0 e of+ Lt -> case forkL_ l hl of+ UBT5(l0,hl0,mbc0,l1,hl1) -> case spliceH l1 hl1 e r hr of+ UBT2(l1_,hl1_) -> UBT5(l0,hl0,mbc0,l1_,hl1_)+ Eq c0 -> UBT5(l,hl,Just c0,r,hr)+ Gt -> case forkL_ r hr of+ UBT5(l0,hl0,mbc0,l1,hl1) -> case spliceH l hl e l0 hl0 of+ UBT2(l0_,hl0_) -> UBT5(l0_,hl0_,mbc0,l1,hl1)+ -- forkR :: AVL a -> b -> UBT5(AVL a,UINT,Maybe c,AVL a,UINT)+ forkR t0 e1 = forkR_ t0 L(0) where+ forkR_ E h = UBT5(E,h,Nothing,E,h) -- Relative heights!!+ forkR_ (N l e r) h = forkR__ l DECINT2(h) e r DECINT1(h)+ forkR_ (Z l e r) h = forkR__ l DECINT1(h) e r DECINT1(h)+ forkR_ (P l e r) h = forkR__ l DECINT1(h) e r DECINT2(h)+ forkR__ l hl e r hr = case comp e e1 of+ Lt -> case forkR_ r hr of+ UBT5(l0,hl0,mbc1,l1,hl1) -> case spliceH l hl e l0 hl0 of+ UBT2(l0_,hl0_) -> UBT5(l0_,hl0_,mbc1,l1,hl1)+ Eq c1 -> UBT5(l,hl,Just c1,r,hr)+ Gt -> case forkR_ l hl of+ UBT5(l0,hl0,mbc1,l1,hl1) -> case spliceH l1 hl1 e r hr of+ UBT2(l1_,hl1_) -> UBT5(l0,hl0,mbc1,l1_,hl1_)++-- | Applies 'intersectionToList' to the empty list.+--+-- Complexity: Not sure, but I\'d appreciate it if someone could figure it out.+intersectionAsList :: (a -> b -> COrdering c) -> AVL a -> AVL b -> [c]+intersectionAsList c setA setB = intersectionToList c setA setB []++-- | Similar to 'intersectionToList', but the result does not include elements in cases where+-- the supplied combining comparison returns @(Eq Nothing)@.+--+-- Complexity: Not sure, but I\'d appreciate it if someone could figure it out.+intersectionMaybeToList :: (a -> b -> COrdering (Maybe c)) -> AVL a -> AVL b -> [c] -> [c]+intersectionMaybeToList comp = i where+ -- i :: AVL a -> AVL b -> [c] -> [c]+ i E _ cs = cs+ i _ E cs = cs+ i (N l0 e0 r0) (N l1 e1 r1) cs = i' l0 e0 r0 l1 e1 r1 cs+ i (N l0 e0 r0) (Z l1 e1 r1) cs = i' l0 e0 r0 l1 e1 r1 cs+ i (N l0 e0 r0) (P l1 e1 r1) cs = i' l0 e0 r0 l1 e1 r1 cs+ i (Z l0 e0 r0) (N l1 e1 r1) cs = i' l0 e0 r0 l1 e1 r1 cs+ i (Z l0 e0 r0) (Z l1 e1 r1) cs = i' l0 e0 r0 l1 e1 r1 cs+ i (Z l0 e0 r0) (P l1 e1 r1) cs = i' l0 e0 r0 l1 e1 r1 cs+ i (P l0 e0 r0) (N l1 e1 r1) cs = i' l0 e0 r0 l1 e1 r1 cs+ i (P l0 e0 r0) (Z l1 e1 r1) cs = i' l0 e0 r0 l1 e1 r1 cs+ i (P l0 e0 r0) (P l1 e1 r1) cs = i' l0 e0 r0 l1 e1 r1 cs+ i' l0 e0 r0 l1 e1 r1 cs =+ case comp e0 e1 of+ -- e0 < e1, so (l0 < e0 < e1) & (e0 < e1 < r1)+ Lt -> case forkR r0 e1 of+ UBT5(rl0,_,mbc1,rr0,_) -> case forkL e0 l1 of -- (e0 < rl0 < e1) & (e0 < e1 < rr0)+ UBT5(ll1,_,mbc0,lr1,_) -> -- (ll1 < e0 < e1) & (e0 < lr1 < e1)+ -- (l0 + ll1) < e0 < (rl0 + lr1) < e1 < (rr0 + r1)+ let cs' = i rr0 r1 cs+ cs'' = cs' `seq` case mbc1 of+ Nothing -> i rl0 lr1 cs'+ Just c1 -> i rl0 lr1 (c1:cs')+ in cs'' `seq` case mbc0 of+ Nothing -> i l0 ll1 cs''+ Just c0 -> i l0 ll1 (c0:cs'')+ -- e0 = e1+ Eq mbc -> let cs' = i r0 r1 cs in cs' `seq` case mbc of+ Nothing -> i l0 l1 cs'+ Just c -> i l0 l1 (c:cs')+ -- e1 < e0, so (l1 < e1 < e0) & (e1 < e0 < r0)+ Gt -> case forkL e0 r1 of+ UBT5(rl1,_,mbc0,rr1,_) -> case forkR l0 e1 of -- (e1 < rl1 < e0) & (e1 < e0 < rr1)+ UBT5(ll0,_,mbc1,lr0,_) -> -- (ll0 < e1 < e0) & (e1 < lr0 < e0)+ -- (ll0 + l1) < e1 < (lr0 + rl1) < e0 < (r0 + rr1)+ let cs' = i r0 rr1 cs+ cs'' = cs' `seq` case mbc0 of+ Nothing -> i lr0 rl1 cs'+ Just c0 -> i lr0 rl1 (c0:cs')+ in cs'' `seq` case mbc1 of+ Nothing -> i ll0 l1 cs''+ Just c1 -> i ll0 l1 (c1:cs'')+ -- We need 2 different versions of fork (L & R) to ensure that comparison arguments are used in+ -- the right order (c e0 e1)+ -- forkL :: a -> AVL b -> UBT5(AVL b,UINT,Maybe c,AVL b,UINT)+ forkL e0 t1 = forkL_ t1 L(0) where+ forkL_ E h = UBT5(E,h,Nothing,E,h) -- Relative heights!!+ forkL_ (N l e r) h = forkL__ l DECINT2(h) e r DECINT1(h)+ forkL_ (Z l e r) h = forkL__ l DECINT1(h) e r DECINT1(h)+ forkL_ (P l e r) h = forkL__ l DECINT1(h) e r DECINT2(h)+ forkL__ l hl e r hr = case comp e0 e of+ Lt -> case forkL_ l hl of+ UBT5(l0,hl0,mbc0,l1,hl1) -> case spliceH l1 hl1 e r hr of+ UBT2(l1_,hl1_) -> UBT5(l0,hl0,mbc0,l1_,hl1_)+ Eq mbc0 -> UBT5(l,hl,mbc0,r,hr)+ Gt -> case forkL_ r hr of+ UBT5(l0,hl0,mbc0,l1,hl1) -> case spliceH l hl e l0 hl0 of+ UBT2(l0_,hl0_) -> UBT5(l0_,hl0_,mbc0,l1,hl1)+ -- forkR :: AVL a -> b -> UBT5(AVL a,UINT,Maybe c,AVL a,UINT)+ forkR t0 e1 = forkR_ t0 L(0) where+ forkR_ E h = UBT5(E,h,Nothing,E,h) -- Relative heights!!+ forkR_ (N l e r) h = forkR__ l DECINT2(h) e r DECINT1(h)+ forkR_ (Z l e r) h = forkR__ l DECINT1(h) e r DECINT1(h)+ forkR_ (P l e r) h = forkR__ l DECINT1(h) e r DECINT2(h)+ forkR__ l hl e r hr = case comp e e1 of+ Lt -> case forkR_ r hr of+ UBT5(l0,hl0,mbc1,l1,hl1) -> case spliceH l hl e l0 hl0 of+ UBT2(l0_,hl0_) -> UBT5(l0_,hl0_,mbc1,l1,hl1)+ Eq mbc1 -> UBT5(l,hl,mbc1,r,hr)+ Gt -> case forkR_ l hl of+ UBT5(l0,hl0,mbc1,l1,hl1) -> case spliceH l1 hl1 e r hr of+ UBT2(l1_,hl1_) -> UBT5(l0,hl0,mbc1,l1_,hl1_)++-- | Applies 'intersectionMaybeToList' to the empty list.+--+-- Complexity: Not sure, but I\'d appreciate it if someone could figure it out.+intersectionMaybeAsList :: (a -> b -> COrdering (Maybe c)) -> AVL a -> AVL b -> [c]+intersectionMaybeAsList c setA setB = intersectionMaybeToList c setA setB []++-- | Uses the supplied comparison to evaluate the difference between two sets represented as+-- sorted AVL trees. The expression..+--+-- > difference cmp setA setB+--+-- .. is a set containing all those elements of @setA@ which do not appear in @setB@.+--+-- Complexity: Not sure, but I\'d appreciate it if someone could figure it out.+difference :: (a -> b -> Ordering) -> AVL a -> AVL b -> AVL a+-- N.B. differenceH works with relative heights on first tree, and needs no height for the second.+difference c t0 t1 = case differenceH c t0 L(0) t1 of UBT2(t,_) -> t++-- | Similar to 'difference', but the resulting tree also includes those elements a\' for which the+-- combining comparison returns @(Eq (Just a\'))@.+--+-- Complexity: Not sure, but I\'d appreciate it if someone could figure it out.+differenceMaybe :: (a -> b -> COrdering (Maybe a)) -> AVL a -> AVL b -> AVL a+-- N.B. differenceMaybeH works with relative heights on first tree, and needs no height for the second.+differenceMaybe c t0 t1 = case differenceMaybeH c t0 L(0) t1 of UBT2(t,_) -> t++-- | Uses the supplied comparison to test whether the first set is a subset of the second,+-- both sets being represented as sorted AVL trees. This function returns True if any of+-- the following conditions hold..+--+-- * The first set is empty (the empty set is a subset of any set).+--+-- * The two sets are equal.+--+-- * The first set is a proper subset of the second set.+--+-- Complexity: Not sure, but I\'d appreciate it if someone could figure it out.+isSubsetOf :: (a -> b -> Ordering) -> AVL a -> AVL b -> Bool+isSubsetOf comp = s where+ -- s :: AVL a -> AVL b -> Bool+ s E _ = True+ s _ E = False+ s (N l0 e0 r0) (N l1 e1 r1) = s' l0 e0 r0 l1 e1 r1+ s (N l0 e0 r0) (Z l1 e1 r1) = s' l0 e0 r0 l1 e1 r1+ s (N l0 e0 r0) (P l1 e1 r1) = s' l0 e0 r0 l1 e1 r1+ s (Z l0 e0 r0) (N l1 e1 r1) = s' l0 e0 r0 l1 e1 r1+ s (Z l0 e0 r0) (Z l1 e1 r1) = s' l0 e0 r0 l1 e1 r1+ s (Z l0 e0 r0) (P l1 e1 r1) = s' l0 e0 r0 l1 e1 r1+ s (P l0 e0 r0) (N l1 e1 r1) = s' l0 e0 r0 l1 e1 r1+ s (P l0 e0 r0) (Z l1 e1 r1) = s' l0 e0 r0 l1 e1 r1+ s (P l0 e0 r0) (P l1 e1 r1) = s' l0 e0 r0 l1 e1 r1+ s' l0 e0 r0 l1 e1 r1 =+ case comp e0 e1 of+ -- e0 < e1, so (l0 < e0 < e1) & (e0 < e1 < r1)+ LT -> case forkL e0 l1 of+ UBT5(False,_ ,_,_ ,_) -> False+ UBT5(True ,ll1,_,lr1,_) -> (s l0 ll1) && case forkR r0 e1 of -- (ll1 < e0 < e1) & (e0 < lr1 < e1)+ UBT4(rl0,_,rr0,_) -> (s rl0 lr1) && (s rr0 r1) -- (e0 < rl0 < e1) & (e0 < e1 < rr0)+ -- e0 = e1+ EQ -> (s l0 l1) && (s r0 r1)+ -- e1 < e0, so (l1 < e1 < e0) & (e1 < e0 < r0)+ GT -> case forkL e0 r1 of+ UBT5(False,_ ,_,_ ,_) -> False+ UBT5(True ,rl1,_,rr1,_) -> (s r0 rr1) && case forkR l0 e1 of -- (e1 < rl1 < e0) & (e1 < e0 < rr1)+ UBT4(ll0,_,lr0,_) -> (s lr0 rl1) && (s ll0 l1) -- (ll0 < e1 < e0) & (e1 < lr0 < e0)+ -- forkL returns False if t1 does not contain e0 (which implies set 0 cannot be a subset of set 1)+ -- forkL :: a -> AVL b -> UBT5(Bool,AVL b,UINT,AVL b,UINT) -- Vals 1..4 only valid if Bool is True!+ forkL e0 t = forkL_ t L(0) where+ forkL_ E h = UBT5(False,E,h,E,h)+ forkL_ (N l e r) h = forkL__ l DECINT2(h) e r DECINT1(h)+ forkL_ (Z l e r) h = forkL__ l DECINT1(h) e r DECINT1(h)+ forkL_ (P l e r) h = forkL__ l DECINT1(h) e r DECINT2(h)+ forkL__ l hl e r hr = case comp e0 e of+ LT -> case forkL_ l hl of+ UBT5(False,t0,ht0,t1,ht1) -> UBT5(False,t0,ht0,t1,ht1)+ UBT5(True ,t0,ht0,t1,ht1) -> case spliceH t1 ht1 e r hr of+ UBT2(t1_,ht1_) -> UBT5(True,t0,ht0,t1_,ht1_)+ EQ -> UBT5(True,l,hl,r,hr)+ GT -> case forkL_ r hr of+ UBT5(False,t0,ht0,t1,ht1) -> UBT5(False,t0,ht0,t1,ht1)+ UBT5(True ,t0,ht0,t1,ht1) -> case spliceH l hl e t0 ht0 of+ UBT2(t0_,ht0_) -> UBT5(True,t0_,ht0_,t1,ht1)+ -- forkR discards an element from set 0 if it is equal to the element from set 1+ -- forkR :: AVL a -> b -> UBT4(AVL a,UINT,AVL a,UINT)+ forkR t e1 = forkR_ t L(0) where+ forkR_ E h = UBT4(E,h,E,h) -- Relative heights!!+ forkR_ (N l e r) h = forkR__ l DECINT2(h) e r DECINT1(h)+ forkR_ (Z l e r) h = forkR__ l DECINT1(h) e r DECINT1(h)+ forkR_ (P l e r) h = forkR__ l DECINT1(h) e r DECINT2(h)+ forkR__ l hl e r hr = case comp e e1 of+ LT -> case forkR_ r hr of+ UBT4(t0,ht0,t1,ht1) -> case spliceH l hl e t0 ht0 of+ UBT2(t0_,ht0_) -> UBT4(t0_,ht0_,t1,ht1)+ EQ -> UBT4(l,hl,r,hr) -- e is discarded from set 0+ GT -> case forkR_ l hl of+ UBT4(t0,ht0,t1,ht1) -> case spliceH t1 ht1 e r hr of+ UBT2(t1_,ht1_) -> UBT4(t0,ht0,t1_,ht1_)++-- | Similar to 'isSubsetOf', but also requires that the supplied combining+-- comparison returns @('Data.COrdering.Eq' True)@ for matching elements.+--+-- Complexity: Not sure, but I\'d appreciate it if someone could figure it out.+isSubsetOfBy :: (a -> b -> COrdering Bool) -> AVL a -> AVL b -> Bool+isSubsetOfBy comp = s where+ -- s :: AVL a -> AVL b -> Bool+ s E _ = True+ s _ E = False+ s (N l0 e0 r0) (N l1 e1 r1) = s' l0 e0 r0 l1 e1 r1+ s (N l0 e0 r0) (Z l1 e1 r1) = s' l0 e0 r0 l1 e1 r1+ s (N l0 e0 r0) (P l1 e1 r1) = s' l0 e0 r0 l1 e1 r1+ s (Z l0 e0 r0) (N l1 e1 r1) = s' l0 e0 r0 l1 e1 r1+ s (Z l0 e0 r0) (Z l1 e1 r1) = s' l0 e0 r0 l1 e1 r1+ s (Z l0 e0 r0) (P l1 e1 r1) = s' l0 e0 r0 l1 e1 r1+ s (P l0 e0 r0) (N l1 e1 r1) = s' l0 e0 r0 l1 e1 r1+ s (P l0 e0 r0) (Z l1 e1 r1) = s' l0 e0 r0 l1 e1 r1+ s (P l0 e0 r0) (P l1 e1 r1) = s' l0 e0 r0 l1 e1 r1+ s' l0 e0 r0 l1 e1 r1 =+ case comp e0 e1 of+ -- e0 < e1, so (l0 < e0 < e1) & (e0 < e1 < r1)+ Lt -> case forkL e0 l1 of+ UBT5(False,_ ,_,_ ,_) -> False+ UBT5(True ,ll1,_,lr1,_) -> (s l0 ll1) && case forkR r0 e1 of -- (ll1 < e0 < e1) & (e0 < lr1 < e1)+ UBT5(False,_ ,_,_ ,_) -> False+ UBT5(True ,rl0,_,rr0,_) -> (s rl0 lr1) && (s rr0 r1) -- (e0 < rl0 < e1) & (e0 < e1 < rr0)+ -- e0 = e1+ Eq True -> (s l0 l1) && (s r0 r1)+ Eq False -> False+ -- e1 < e0, so (l1 < e1 < e0) & (e1 < e0 < r0)+ Gt -> case forkL e0 r1 of+ UBT5(False,_ ,_,_ ,_) -> False+ UBT5(True ,rl1,_,rr1,_) -> (s r0 rr1) && case forkR l0 e1 of -- (e1 < rl1 < e0) & (e1 < e0 < rr1)+ UBT5(False,_ ,_,_ ,_) -> False+ UBT5(True ,ll0,_,lr0,_) -> (s lr0 rl1) && (s ll0 l1) -- (ll0 < e1 < e0) & (e1 < lr0 < e0)+ -- forkL returns False if t1 does not contain e0 (which implies set 0 cannot be a subset of set 1)+ -- forkL :: a -> AVL b -> UBT5(Bool,AVL b,UINT,AVL b,UINT) -- Vals 1..4 only valid if Bool is True!+ forkL e0 t = forkL_ t L(0) where+ forkL_ E h = UBT5(False,E,h,E,h)+ forkL_ (N l e r) h = forkL__ l DECINT2(h) e r DECINT1(h)+ forkL_ (Z l e r) h = forkL__ l DECINT1(h) e r DECINT1(h)+ forkL_ (P l e r) h = forkL__ l DECINT1(h) e r DECINT2(h)+ forkL__ l hl e r hr = case comp e0 e of+ Lt -> case forkL_ l hl of+ UBT5(False,t0,ht0,t1,ht1) -> UBT5(False,t0,ht0,t1,ht1)+ UBT5(True ,t0,ht0,t1,ht1) -> case spliceH t1 ht1 e r hr of+ UBT2(t1_,ht1_) -> UBT5(True,t0,ht0,t1_,ht1_)+ Eq b -> UBT5(b,l,hl,r,hr)+ Gt -> case forkL_ r hr of+ UBT5(False,t0,ht0,t1,ht1) -> UBT5(False,t0,ht0,t1,ht1)+ UBT5(True ,t0,ht0,t1,ht1) -> case spliceH l hl e t0 ht0 of+ UBT2(t0_,ht0_) -> UBT5(True,t0_,ht0_,t1,ht1)+ -- forkR discards an element from set 0 if it is equal to the element from set 1+ -- forkR :: AVL a -> b -> UBT5(Bool,AVL a,UINT,AVL a,UINT) -- Vals 1..4 only valid if Bool is True!+ forkR t e1 = forkR_ t L(0) where+ forkR_ E h = UBT5(True,E,h,E,h) -- Relative heights!!+ forkR_ (N l e r) h = forkR__ l DECINT2(h) e r DECINT1(h)+ forkR_ (Z l e r) h = forkR__ l DECINT1(h) e r DECINT1(h)+ forkR_ (P l e r) h = forkR__ l DECINT1(h) e r DECINT2(h)+ forkR__ l hl e r hr = case comp e e1 of+ Lt -> case forkR_ r hr of+ UBT5(False,t0,ht0,t1,ht1) -> UBT5(False,t0,ht0,t1,ht1)+ UBT5(True ,t0,ht0,t1,ht1) -> case spliceH l hl e t0 ht0 of+ UBT2(t0_,ht0_) -> UBT5(True,t0_,ht0_,t1,ht1)+ Eq b -> UBT5(b,l,hl,r,hr) -- e is discarded from set 0+ Gt -> case forkR_ l hl of+ UBT5(False,t0,ht0,t1,ht1) -> UBT5(False,t0,ht0,t1,ht1)+ UBT5(True ,t0,ht0,t1,ht1) -> case spliceH t1 ht1 e r hr of+ UBT2(t1_,ht1_) -> UBT5(True,t0,ht0,t1_,ht1_)++-- | The symmetric difference is the set of elements which occur in one set or the other but /not both/.+--+-- Complexity: Not sure, but I\'d appreciate it if someone could figure it out.+symDifference :: (e -> e -> Ordering) -> AVL e -> AVL e -> AVL e+symDifference c = gu where -- This is to avoid O(log n) height calculation for empty sets+ gu E t1 = t1+ gu t0 E = t0+ gu t0@(N l0 _ _ ) t1@(N l1 _ _ ) = gu_ t0 (addHeight L(2) l0) t1 (addHeight L(2) l1)+ gu t0@(N l0 _ _ ) t1@(Z l1 _ _ ) = gu_ t0 (addHeight L(2) l0) t1 (addHeight L(1) l1)+ gu t0@(N l0 _ _ ) t1@(P _ _ r1) = gu_ t0 (addHeight L(2) l0) t1 (addHeight L(2) r1)+ gu t0@(Z l0 _ _ ) t1@(N l1 _ _ ) = gu_ t0 (addHeight L(1) l0) t1 (addHeight L(2) l1)+ gu t0@(Z l0 _ _ ) t1@(Z l1 _ _ ) = gu_ t0 (addHeight L(1) l0) t1 (addHeight L(1) l1)+ gu t0@(Z l0 _ _ ) t1@(P _ _ r1) = gu_ t0 (addHeight L(1) l0) t1 (addHeight L(2) r1)+ gu t0@(P _ _ r0) t1@(N l1 _ _ ) = gu_ t0 (addHeight L(2) r0) t1 (addHeight L(2) l1)+ gu t0@(P _ _ r0) t1@(Z l1 _ _ ) = gu_ t0 (addHeight L(2) r0) t1 (addHeight L(1) l1)+ gu t0@(P _ _ r0) t1@(P _ _ r1) = gu_ t0 (addHeight L(2) r0) t1 (addHeight L(2) r1)+ gu_ t0 h0 t1 h1 = case symDifferenceH c t0 h0 t1 h1 of UBT2(t,_) -> t++-- | Given two Sets @A@ and @B@ represented as sorted AVL trees, this function+-- extracts the \'Venn diagram\' components @A-B@, @A.B@ and @B-A@.+-- See also 'vennMaybe'.+--+-- Complexity: Not sure, but I\'d appreciate it if someone could figure it out.+venn :: (a -> b -> COrdering c) -> AVL a -> AVL b -> (AVL a, AVL c, AVL b)+venn c = gu where -- This is to avoid O(log n) height calculation for empty sets+ gu E t1 = (E ,E,t1)+ gu t0 E = (t0,E,E )+ gu t0@(N l0 _ _ ) t1@(N l1 _ _ ) = gu_ t0 (addHeight L(2) l0) t1 (addHeight L(2) l1)+ gu t0@(N l0 _ _ ) t1@(Z l1 _ _ ) = gu_ t0 (addHeight L(2) l0) t1 (addHeight L(1) l1)+ gu t0@(N l0 _ _ ) t1@(P _ _ r1) = gu_ t0 (addHeight L(2) l0) t1 (addHeight L(2) r1)+ gu t0@(Z l0 _ _ ) t1@(N l1 _ _ ) = gu_ t0 (addHeight L(1) l0) t1 (addHeight L(2) l1)+ gu t0@(Z l0 _ _ ) t1@(Z l1 _ _ ) = gu_ t0 (addHeight L(1) l0) t1 (addHeight L(1) l1)+ gu t0@(Z l0 _ _ ) t1@(P _ _ r1) = gu_ t0 (addHeight L(1) l0) t1 (addHeight L(2) r1)+ gu t0@(P _ _ r0) t1@(N l1 _ _ ) = gu_ t0 (addHeight L(2) r0) t1 (addHeight L(2) l1)+ gu t0@(P _ _ r0) t1@(Z l1 _ _ ) = gu_ t0 (addHeight L(2) r0) t1 (addHeight L(1) l1)+ gu t0@(P _ _ r0) t1@(P _ _ r1) = gu_ t0 (addHeight L(2) r0) t1 (addHeight L(2) r1)+ gu_ t0 h0 t1 h1 = case vennH c [] L(0) t0 h0 t1 h1 of+ UBT6(tab,_,cs,cl,tba,_) -> let tc = asTreeLenL ASINT(cl) cs+ in tc `seq` (tab,tc,tba)++-- | Similar to 'venn', but intersection elements for which the combining comparison+-- returns @('Data.COrdering.Eq' 'Nothing')@ are deleted from the intersection result.+--+-- Complexity: Not sure, but I\'d appreciate it if someone could figure it out.+vennMaybe :: (a -> b -> COrdering (Maybe c)) -> AVL a -> AVL b -> (AVL a, AVL c, AVL b)+vennMaybe c = gu where -- This is to avoid O(log n) height calculation for empty sets+ gu E t1 = (E ,E,t1)+ gu t0 E = (t0,E,E )+ gu t0@(N l0 _ _ ) t1@(N l1 _ _ ) = gu_ t0 (addHeight L(2) l0) t1 (addHeight L(2) l1)+ gu t0@(N l0 _ _ ) t1@(Z l1 _ _ ) = gu_ t0 (addHeight L(2) l0) t1 (addHeight L(1) l1)+ gu t0@(N l0 _ _ ) t1@(P _ _ r1) = gu_ t0 (addHeight L(2) l0) t1 (addHeight L(2) r1)+ gu t0@(Z l0 _ _ ) t1@(N l1 _ _ ) = gu_ t0 (addHeight L(1) l0) t1 (addHeight L(2) l1)+ gu t0@(Z l0 _ _ ) t1@(Z l1 _ _ ) = gu_ t0 (addHeight L(1) l0) t1 (addHeight L(1) l1)+ gu t0@(Z l0 _ _ ) t1@(P _ _ r1) = gu_ t0 (addHeight L(1) l0) t1 (addHeight L(2) r1)+ gu t0@(P _ _ r0) t1@(N l1 _ _ ) = gu_ t0 (addHeight L(2) r0) t1 (addHeight L(2) l1)+ gu t0@(P _ _ r0) t1@(Z l1 _ _ ) = gu_ t0 (addHeight L(2) r0) t1 (addHeight L(1) l1)+ gu t0@(P _ _ r0) t1@(P _ _ r1) = gu_ t0 (addHeight L(2) r0) t1 (addHeight L(2) r1)+ gu_ t0 h0 t1 h1 = case vennMaybeH c [] L(0) t0 h0 t1 h1 of+ UBT6(tab,_,cs,cl,tba,_) -> let tc = asTreeLenL ASINT(cl) cs+ in tc `seq` (tab,tc,tba)++-- | Same as 'venn', but prepends the intersection component to the supplied list+-- in ascending order.+vennToList :: (a -> b -> COrdering c) -> [c] -> AVL a -> AVL b -> (AVL a, [c], AVL b)+vennToList cmp cs = gu where -- This is to avoid O(log n) height calculation for empty sets+ gu E t1 = (E ,cs,t1)+ gu t0 E = (t0,cs,E )+ gu t0@(N l0 _ _ ) t1@(N l1 _ _ ) = gu_ t0 (addHeight L(2) l0) t1 (addHeight L(2) l1)+ gu t0@(N l0 _ _ ) t1@(Z l1 _ _ ) = gu_ t0 (addHeight L(2) l0) t1 (addHeight L(1) l1)+ gu t0@(N l0 _ _ ) t1@(P _ _ r1) = gu_ t0 (addHeight L(2) l0) t1 (addHeight L(2) r1)+ gu t0@(Z l0 _ _ ) t1@(N l1 _ _ ) = gu_ t0 (addHeight L(1) l0) t1 (addHeight L(2) l1)+ gu t0@(Z l0 _ _ ) t1@(Z l1 _ _ ) = gu_ t0 (addHeight L(1) l0) t1 (addHeight L(1) l1)+ gu t0@(Z l0 _ _ ) t1@(P _ _ r1) = gu_ t0 (addHeight L(1) l0) t1 (addHeight L(2) r1)+ gu t0@(P _ _ r0) t1@(N l1 _ _ ) = gu_ t0 (addHeight L(2) r0) t1 (addHeight L(2) l1)+ gu t0@(P _ _ r0) t1@(Z l1 _ _ ) = gu_ t0 (addHeight L(2) r0) t1 (addHeight L(1) l1)+ gu t0@(P _ _ r0) t1@(P _ _ r1) = gu_ t0 (addHeight L(2) r0) t1 (addHeight L(2) r1)+ gu_ t0 h0 t1 h1 = case vennH cmp cs L(0) t0 h0 t1 h1 of+ UBT6(tab,_,cs_,_,tba,_) -> (tab,cs_,tba)++-- | Same as 'vennMaybe', but prepends the intersection component to the supplied list+-- in ascending order.+vennMaybeToList :: (a -> b -> COrdering (Maybe c)) -> [c] -> AVL a -> AVL b -> (AVL a, [c], AVL b)+vennMaybeToList cmp cs = gu where -- This is to avoid O(log n) height calculation for empty sets+ gu E t1 = (E ,cs,t1)+ gu t0 E = (t0,cs,E )+ gu t0@(N l0 _ _ ) t1@(N l1 _ _ ) = gu_ t0 (addHeight L(2) l0) t1 (addHeight L(2) l1)+ gu t0@(N l0 _ _ ) t1@(Z l1 _ _ ) = gu_ t0 (addHeight L(2) l0) t1 (addHeight L(1) l1)+ gu t0@(N l0 _ _ ) t1@(P _ _ r1) = gu_ t0 (addHeight L(2) l0) t1 (addHeight L(2) r1)+ gu t0@(Z l0 _ _ ) t1@(N l1 _ _ ) = gu_ t0 (addHeight L(1) l0) t1 (addHeight L(2) l1)+ gu t0@(Z l0 _ _ ) t1@(Z l1 _ _ ) = gu_ t0 (addHeight L(1) l0) t1 (addHeight L(1) l1)+ gu t0@(Z l0 _ _ ) t1@(P _ _ r1) = gu_ t0 (addHeight L(1) l0) t1 (addHeight L(2) r1)+ gu t0@(P _ _ r0) t1@(N l1 _ _ ) = gu_ t0 (addHeight L(2) r0) t1 (addHeight L(2) l1)+ gu t0@(P _ _ r0) t1@(Z l1 _ _ ) = gu_ t0 (addHeight L(2) r0) t1 (addHeight L(1) l1)+ gu t0@(P _ _ r0) t1@(P _ _ r1) = gu_ t0 (addHeight L(2) r0) t1 (addHeight L(2) r1)+ gu_ t0 h0 t1 h1 = case vennMaybeH cmp cs L(0) t0 h0 t1 h1 of+ UBT6(tab,_,cs_,_,tba,_) -> (tab,cs_,tba)++-- | Same as 'venn', but returns the intersection component as a list in ascending order.+-- This is just 'vennToList' applied to an empty initial intersection list.+vennAsList :: (a -> b -> COrdering c) -> AVL a -> AVL b -> (AVL a, [c], AVL b)+vennAsList cmp = vennToList cmp []+{-# INLINE vennAsList #-}++-- | Same as 'vennMaybe', but returns the intersection component as a list in ascending order.+-- This is just 'vennMaybeToList' applied to an empty initial intersection list.+vennMaybeAsList :: (a -> b -> COrdering (Maybe c)) -> AVL a -> AVL b -> (AVL a, [c], AVL b)+vennMaybeAsList cmp = vennMaybeToList cmp []+{-# INLINE vennMaybeAsList #-}+
+ src/Data/Tree/AVL/Size.hs view
@@ -0,0 +1,158 @@+-- |+-- Copyright : (c) Adrian Hey 2004,2005+-- License : BSD3+--+-- AVL Tree size related utilities.++{-# OPTIONS_HADDOCK hide #-}+module Data.Tree.AVL.Size+ (-- * AVL tree size utilities+ size,addSize,clipSize,+ addSize#,size#,+ ) where++import Data.Tree.AVL.Internals.Types(AVL(..))+import Data.Tree.AVL.Height(addHeight)++import GHC.Base+#include "ghcdefs.h"++-- | A convenience wrapper for 'addSize#'.+size :: AVL e -> Int+size t = ASINT(addSize# L(0) t)+{-# INLINE size #-}++-- | A convenience wrapper for 'addSize#'.+size# :: AVL e -> UINT+size# t = addSize# L(0) t+{-# INLINE size# #-}++-- | See 'addSize#'.+addSize :: Int -> AVL e -> Int+addSize ASINT(n) t = ASINT(addSize# n t)+{-# INLINE addSize #-}++#define AddSize addSize#++{-----------------------------------------+Notes for fast size calculation.+ case (h,avl)+ (0,_ ) -> 0 -- Must be E+ (1,_ ) -> 1 -- Must be (Z E _ E )+ (2,N _ _ _) -> 2 -- Must be (N E _ (Z E _ E))+ (2,Z _ _ _) -> 3 -- Must be (Z (Z E _ E) _ (Z E _ E))+ (2,P _ _ _) -> 2 -- Must be (P (Z E _ E) _ E )+ (3,N _ _ r) -> 2 + size 2 r -- Must be (N (Z E _ E) _ r )+ (3,P l _ _) -> 2 + size 2 l -- Must be (P l _ (Z E _ E))+------------------------------------------}++-- | Fast algorithm to add the size of a tree to the first argument. This avoids visiting about 50% of tree nodes+-- by using fact that trees with small heights can only have particular shapes.+-- So it's still O(n), but with substantial saving in constant factors.+--+-- Complexity: O(n)+AddSize :: UINT -> AVL e -> UINT+AddSize n E = n+AddSize n (N l _ r) = case addHeight L(2) l of+ L(2) -> INCINT2(n)+ L(3) -> fas2 INCINT2(n) r+ h -> fasNP n h l r+AddSize n (Z l _ r) = case addHeight L(1) l of+ L(1) -> INCINT1(n)+ L(2) -> INCINT3(n)+ L(3) -> fas2 (fas2 INCINT1(n) l) r+ h -> fasZ n h l r+AddSize n (P l _ r) = case addHeight L(2) r of+ L(2) -> INCINT2(n)+ L(3) -> fas2 INCINT2(n) l+ h -> fasNP n h r l+-- Parent Height (h) >= 4 !!+fasNP,fasZ :: UINT -> UINT -> AVL e -> AVL e -> UINT+fasNP n h l r = fasG3 (fasG2 INCINT1(n) DECINT2(h) l) DECINT1(h) r+fasZ n h l r = fasG3 (fasG3 INCINT1(n) DECINT1(h) l) DECINT1(h) r+-- h>=2 !!+fasG2 :: UINT -> UINT -> AVL e -> UINT+fasG2 n L(2) t = fas2 n t+fasG2 n h t = fasG3 n h t+{-# INLINE fasG2 #-}+-- h>=3 !!+fasG3 :: UINT -> UINT -> AVL e -> UINT+fasG3 n L(3) (N _ _ r) = fas2 INCINT2(n) r+fasG3 n L(3) (Z l _ r) = fas2 (fas2 INCINT1(n) l) r+fasG3 n L(3) (P l _ _) = fas2 INCINT2(n) l+fasG3 n h (N l _ r) = fasNP n h l r -- h>=4+fasG3 n h (Z l _ r) = fasZ n h l r -- h>=4+fasG3 n h (P l _ r) = fasNP n h r l -- h>=4+fasG3 _ _ E = error "AddSize: Bad Tree." -- impossible+-- h=2 !!+fas2 :: UINT -> AVL e -> UINT+fas2 n (N _ _ _) = INCINT2(n)+fas2 n (Z _ _ _) = INCINT3(n)+fas2 n (P _ _ _) = INCINT2(n)+fas2 _ E = error "AddSize: Bad Tree." -- impossible+{-# INLINE fas2 #-}++-- | Returns the exact tree size in the form @('Just' n)@ if this is less than or+-- equal to the input clip value. Returns @'Nothing'@ of the size is greater than+-- the clip value. This function exploits the same optimisation as 'addSize'.+--+-- Complexity: O(min n c) where n is tree size and c is clip value.+clipSize :: Int -> AVL e -> Maybe Int+clipSize ASINT(c) t = let c_ = cSzh c t in if isTrue# (c_ LTN L(0))+ then Nothing+ else Just ASINT(SUBINT(c,c_))+-- First entry calculates initial height+cSzh :: UINT -> AVL e -> UINT+cSzh c E = c+cSzh c (N l _ r) = case addHeight L(2) l of+ L(2) -> DECINT2(c)+ L(3) -> cSzNP3 c r+ h -> cSzNP c h l r+cSzh c (Z l _ r) = case addHeight L(1) l of+ L(1) -> DECINT1(c)+ L(2) -> DECINT3(c)+ L(3) -> cSzZ3 c l r+ h -> cSzZ c h l r+cSzh c (P l _ r) = case addHeight L(2) r of+ L(2) -> DECINT2(c)+ L(3) -> cSzNP3 c l+ h -> cSzNP c h r l+-- Parent Height = 3 !!+cSzNP3 :: UINT -> AVL e -> UINT+cSzNP3 c t = if isTrue# (c LTN L(4)) then L(-1) else cSz2 DECINT2(c) t+cSzZ3 :: UINT -> AVL e -> AVL e -> UINT+cSzZ3 c l r = if isTrue# (c LTN L(5)) then L(-1)+ else let c_ = cSz2 DECINT1(c) l+ in if isTrue# (c_ LTN L(2)) then L(-1)+ else cSz2 c_ r+-- Parent Height (h) >= 4 !!+cSzNP,cSzZ :: UINT -> UINT -> AVL e -> AVL e -> UINT+cSzNP c h l r = if isTrue# (c LTN L(7)) then L(-1)+ else let c_ = cSzG2 DECINT1(c) DECINT2(h) l -- (h-2) >= 2+ in if isTrue# (c_ LTN L(4)) then L(-1)+ else cSzG3 c_ DECINT1(h) r -- (h-1) >= 3+cSzZ c h l r = if isTrue# (c LTN L(9)) then L(-1)+ else let c_ = cSzG3 DECINT1(c) DECINT1(h) l -- (h-1) >= 3+ in if isTrue# (c_ LTN L(4)) then L(-1)+ else cSzG3 c_ DECINT1(h) r -- (h-1) >= 3+-- h>=2 !!+cSzG2 :: UINT -> UINT -> AVL e -> UINT+cSzG2 c L(2) t = cSz2 c t+cSzG2 c h t = cSzG3 c h t+{-# INLINE cSzG2 #-}+-- h>=3 !!+cSzG3 :: UINT -> UINT -> AVL e -> UINT+cSzG3 c L(3) (N _ _ r) = cSzNP3 c r+cSzG3 c L(3) (Z l _ r) = cSzZ3 c l r+cSzG3 c L(3) (P l _ _) = cSzNP3 c l+cSzG3 c h (N l _ r) = cSzNP c h l r -- h>=4+cSzG3 c h (Z l _ r) = cSzZ c h l r -- h>=4+cSzG3 c h (P l _ r) = cSzNP c h r l -- h>=4+cSzG3 _ _ E = error "clipSize: Bad Tree." -- impossible+-- h=2 !!+cSz2 :: UINT -> AVL e -> UINT+cSz2 c (N _ _ _) = DECINT2(c)+cSz2 c (Z _ _ _) = DECINT3(c)+cSz2 c (P _ _ _) = DECINT2(c)+cSz2 _ E = error "clipSize: Bad Tree." -- impossible+{-# INLINE cSz2 #-}
+ src/Data/Tree/AVL/Split.hs view
@@ -0,0 +1,790 @@+-- |+-- Copyright : (c) Adrian Hey 2004,2005+-- License : BSD3+--+{-# OPTIONS_HADDOCK hide #-}+module Data.Tree.AVL.Split+(-- * Splitting AVL trees++ -- ** Taking fixed size lumps of tree+ -- | Bear in mind that the tree size (s) is not stored in the AVL data structure, but if it is+ -- already known for other reasons then for (n > s\/2) using the appropriate complementary+ -- function with argument (s-n) will be faster.+ -- But it's probably not worth invoking 'Data.Tree.AVL.Internals.Types.size' for no reason other than to+ -- exploit this optimisation (because this is O(s) anyway).+ splitAtL,splitAtR,takeL,takeR,dropL,dropR,++ -- ** Rotations+ -- | Bear in mind that the tree size (s) is not stored in the AVL data structure, but if it is+ -- already known for other reasons then for (n > s\/2) using the appropriate complementary+ -- function with argument (s-n) will be faster.+ -- But it's probably not worth invoking 'Data.Tree.AVL.Internals.Types.size' for no reason other than to exploit this optimisation+ -- (because this is O(s) anyway).+ rotateL,rotateR,popRotateL,popRotateR,rotateByL,rotateByR,++ -- ** Taking lumps of tree according to a supplied predicate+ spanL,spanR,takeWhileL,dropWhileL,takeWhileR,dropWhileR,++ -- ** Taking lumps of /sorted/ trees+ -- | Prepare to get confused. All these functions adhere to the same Ordering convention as+ -- is used for searches. That is, if the supplied selector returns LT that means the search+ -- key is less than the current tree element. Or put another way, the current tree element+ -- is greater than the search key.+ --+ -- So (for example) the result of the 'takeLT' function is a tree containing all those elements+ -- which are less than the notional search key. That is, all those elements for which the+ -- supplied selector returns GT (not LT as you might expect). I know that seems backwards, but+ -- it's consistent if you think about it.+ forkL,forkR,fork,+ takeLE,dropGT,+ takeLT,dropGE,+ takeGT,dropLE,+ takeGE,dropLT,+) where++import Prelude -- so haddock finds the symbols there+++import Data.COrdering(COrdering(..))+import Data.Tree.AVL.Internals.Types(AVL(..))+import Data.Tree.AVL.Push(pushL,pushR)+import Data.Tree.AVL.Internals.DelUtils(popRN,popRZ,popRP,popLN,popLZ,popLP)+import Data.Tree.AVL.Internals.HAVL(HAVL(HAVL),spliceHAVL,pushLHAVL,pushRHAVL)+import Data.Tree.AVL.Internals.HJoin(joinH')++import GHC.Base+#include "ghcdefs.h"++-- Local Datatype for results of split operations.+data SplitResult e = All (HAVL e) (HAVL e) -- Two tree/height pairs. Non Strict!!+ | More {-# UNPACK #-} !UINT -- No of tree elements still required (>=0!!)++-- | Split an AVL tree from the Left. The 'Int' argument n (n >= 0) specifies the split point.+-- This function raises an error if n is negative.+--+-- If the tree size is greater than n the result is (Right (l,r)) where l contains+-- the leftmost n elements and r contains the remaining rightmost elements (r will be non-empty).+--+-- If the tree size is less than or equal to n then the result is (Left s), where s is tree size.+--+-- An empty tree will always yield a result of (Left 0).+--+-- Complexity: O(n)+splitAtL :: Int -> AVL e -> Either Int (AVL e, AVL e)+splitAtL n _ | n < 0 = error "splitAtL: Negative argument."+splitAtL 0 E = Left 0 -- Treat this case specially+splitAtL 0 t = Right (E,t)+splitAtL ASINT(n) t = case splitL n t L(0) of -- Tree Heights are relative!!+ More n_ -> Left ASINT(SUBINT(n,n_))+ All (HAVL l _) (HAVL r _) -> Right (l,r)++-- n > 0 !!+-- N.B Never returns a result of form (ALL lhavl rhavl) where rhavl is empty+splitL :: UINT -> AVL e -> UINT -> SplitResult e+splitL n E _ = More n+splitL n (N l e r) h = splitL_ n l DECINT2(h) e r DECINT1(h)+splitL n (Z l e r) h = splitL_ n l DECINT1(h) e r DECINT1(h)+splitL n (P l e r) h = splitL_ n l DECINT1(h) e r DECINT2(h)++-- n > 0 !!+-- N.B Never returns a result of form (ALL lhavl rhavl) where rhavl is empty+splitL_ :: UINT -> AVL e -> UINT -> e -> AVL e -> UINT -> SplitResult e+splitL_ n l hl e r hr =+ case splitL n l hl of+ More L(0) -> let rhavl = pushLHAVL e (HAVL r hr); lhavl = HAVL l hl+ in lhavl `seq` rhavl `seq` All lhavl rhavl+ More L(1) -> case r of+ E -> More L(0)+ _ -> let lhavl = pushRHAVL (HAVL l hl) e+ rhavl = HAVL r hr+ in lhavl `seq` rhavl `seq` All lhavl rhavl+ More n_ -> let sr = splitL DECINT1(n_) r hr+ in case sr of+ More _ -> sr+ All havl0 havl1 -> let havl0' = spliceHAVL (HAVL l hl) e havl0+ in havl0' `seq` All havl0' havl1+ All havl0 havl1 -> let havl1' = spliceHAVL havl1 e (HAVL r hr)+ in havl1' `seq` All havl0 havl1'++-- | Split an AVL tree from the Right. The 'Int' argument n (n >= 0) specifies the split point.+-- This function raises an error if n is negative.+--+-- If the tree size is greater than n the result is (Right (l,r)) where r contains+-- the rightmost n elements and l contains the remaining leftmost elements (l will be non-empty).+--+-- If the tree size is less than or equal to n then the result is (Left s), where s is tree size.+--+-- An empty tree will always yield a result of (Left 0).+--+-- Complexity: O(n)+splitAtR :: Int -> AVL e -> Either Int (AVL e, AVL e)+splitAtR n _ | n < 0 = error "splitAtR: Negative argument."+splitAtR 0 E = Left 0 -- Treat this case specially+splitAtR 0 t = Right (t,E)+splitAtR ASINT(n) t = case splitR n t L(0) of -- Tree Heights are relative!!+ More n_ -> Left ASINT(SUBINT(n,n_))+ All (HAVL l _) (HAVL r _) -> Right (l,r)++-- n > 0 !!+-- N.B Never returns a result of form (ALL lhavl rhavl) where lhavl is empty+splitR :: UINT -> AVL e -> UINT -> SplitResult e+splitR n E _ = More n+splitR n (N l e r) h = splitR_ n l DECINT2(h) e r DECINT1(h)+splitR n (Z l e r) h = splitR_ n l DECINT1(h) e r DECINT1(h)+splitR n (P l e r) h = splitR_ n l DECINT1(h) e r DECINT2(h)++-- n > 0 !!+-- N.B Never returns a result of form (ALL lhavl rhavl) where lhavl is empty+splitR_ :: UINT -> AVL e -> UINT -> e -> AVL e -> UINT -> SplitResult e+splitR_ n l hl e r hr =+ case splitR n r hr of+ More L(0) -> let lhavl = pushRHAVL (HAVL l hl) e; rhavl = HAVL r hr+ in lhavl `seq` rhavl `seq` All lhavl rhavl+ More L(1) -> case l of+ E -> More L(0)+ _ -> let rhavl = pushLHAVL e (HAVL r hr)+ lhavl = HAVL l hl+ in lhavl `seq` rhavl `seq` All lhavl rhavl+ More n_ -> let sr = splitR DECINT1(n_) l hl+ in case sr of+ More _ -> sr+ All havl0 havl1 -> let havl1' = spliceHAVL havl1 e (HAVL r hr)+ in havl1' `seq` All havl0 havl1'+ All havl0 havl1 -> let havlO' = spliceHAVL (HAVL l hl) e havl0+ in havlO' `seq` All havlO' havl1++-- Local Datatype for results of take/drop operations.+data TakeResult e = AllTR (HAVL e) -- The resulting Tree+ | MoreTR {-# UNPACK #-} !UINT -- No of tree elements still required (>=0!!)++-- | This is a simplified version of 'splitAtL' which does not return the remaining tree.+-- The 'Int' argument n (n >= 0) specifies the number of elements to take (from the left).+-- This function raises an error if n is negative.+--+-- If the tree size is greater than n the result is (Right l) where l contains+-- the leftmost n elements.+--+-- If the tree size is less than or equal to n then the result is (Left s), where s is tree size.+--+-- An empty tree will always yield a result of (Left 0).+--+-- Complexity: O(n)+takeL :: Int -> AVL e -> Either Int (AVL e)+takeL n _ | n < 0 = error "takeL: Negative argument."+takeL 0 E = Left 0 -- Treat this case specially+takeL 0 _ = Right E+takeL ASINT(n) t = case takeL_ n t L(0) of -- Tree Heights are relative!!+ MoreTR n_ -> Left ASINT(SUBINT(n,n_))+ AllTR (HAVL t' _) -> Right t'++-- n > 0 !!+takeL_ :: UINT -> AVL e -> UINT -> TakeResult e+takeL_ n E _ = MoreTR n+takeL_ n (N l e r) h = takeL__ n l DECINT2(h) e r DECINT1(h)+takeL_ n (Z l e r) h = takeL__ n l DECINT1(h) e r DECINT1(h)+takeL_ n (P l e r) h = takeL__ n l DECINT1(h) e r DECINT2(h)++-- n > 0 !!+takeL__ :: UINT -> AVL e -> UINT -> e -> AVL e -> UINT -> TakeResult e+takeL__ n l hl e r hr =+ let takel = takeL_ n l hl+ in case takel of+ MoreTR L(0) -> let lhavl = HAVL l hl+ in lhavl `seq` AllTR lhavl+ MoreTR L(1) -> case r of+ E -> MoreTR L(0)+ _ -> let lhavl = pushRHAVL (HAVL l hl) e+ in lhavl `seq` AllTR lhavl+ MoreTR n_ -> let taker = takeL_ DECINT1(n_) r hr+ in case taker of+ AllTR havl0 -> let havl0' = spliceHAVL (HAVL l hl) e havl0+ in havl0' `seq` AllTR havl0'+ _ -> taker+ _ -> takel++-- | This is a simplified version of 'splitAtR' which does not return the remaining tree.+-- The 'Int' argument n (n >= 0) specifies the number of elements to take (from the right).+-- This function raises an error if n is negative.+--+-- If the tree size is greater than n the result is (Right r) where r contains+-- the rightmost n elements.+--+-- If the tree size is less than or equal to n then the result is (Left s), where s is tree size.+--+-- An empty tree will always yield a result of (Left 0).+--+-- Complexity: O(n)+takeR :: Int -> AVL e -> Either Int (AVL e)+takeR n _ | n < 0 = error "takeR: Negative argument."+takeR 0 E = Left 0 -- Treat this case specially+takeR 0 _ = Right E+takeR ASINT(n) t = case takeR_ n t L(0) of -- Tree Heights are relative!!+ MoreTR n_ -> Left ASINT(SUBINT(n,n_))+ AllTR (HAVL t' _) -> Right t'++-- n > 0 !!+takeR_ :: UINT -> AVL e -> UINT -> TakeResult e+takeR_ n E _ = MoreTR n+takeR_ n (N l e r) h = takeR__ n l DECINT2(h) e r DECINT1(h)+takeR_ n (Z l e r) h = takeR__ n l DECINT1(h) e r DECINT1(h)+takeR_ n (P l e r) h = takeR__ n l DECINT1(h) e r DECINT2(h)++-- n > 0 !!+takeR__ :: UINT -> AVL e -> UINT -> e -> AVL e -> UINT -> TakeResult e+takeR__ n l hl e r hr =+ let taker = takeR_ n r hr+ in case taker of+ MoreTR L(0) -> let rhavl = HAVL r hr+ in rhavl `seq` AllTR rhavl+ MoreTR L(1) -> case l of+ E -> MoreTR L(0)+ _ -> let rhavl = pushLHAVL e (HAVL r hr)+ in rhavl `seq` AllTR rhavl+ MoreTR n_ -> let takel = takeR_ DECINT1(n_) l hl+ in case takel of+ AllTR havl0 -> let havl0' = spliceHAVL havl0 e (HAVL r hr)+ in havl0' `seq` AllTR havl0'+ _ -> takel+ _ -> taker++-- | This is a simplified version of 'splitAtL' which returns the remaining tree only (rightmost elements).+-- This function raises an error if n is negative.+--+-- If the tree size is greater than n the result is (Right r) where r contains+-- the remaining elements (r will be non-empty).+--+-- If the tree size is less than or equal to n then the result is (Left s), where s is tree size.+--+-- An empty tree will always yield a result of (Left 0).+--+-- Complexity: O(n)+dropL :: Int -> AVL e -> Either Int (AVL e)+dropL n _ | n < 0 = error "dropL: Negative argument."+dropL 0 E = Left 0 -- Treat this case specially+dropL 0 t = Right t+dropL ASINT(n) t = case dropL_ n t L(0) of -- Tree Heights are relative!!+ MoreTR n_ -> Left ASINT(SUBINT(n,n_))+ AllTR (HAVL r _) -> Right r++-- n > 0 !!+-- N.B Never returns a result of form (AllTR rhavl) where rhavl is empty+dropL_ :: UINT -> AVL e -> UINT -> TakeResult e+dropL_ n E _ = MoreTR n+dropL_ n (N l e r) h = dropL__ n l DECINT2(h) e r DECINT1(h)+dropL_ n (Z l e r) h = dropL__ n l DECINT1(h) e r DECINT1(h)+dropL_ n (P l e r) h = dropL__ n l DECINT1(h) e r DECINT2(h)++-- n > 0 !!+-- N.B Never returns a result of form (AllTR rhavl) where rhavl is empty+dropL__ :: UINT -> AVL e -> UINT -> e -> AVL e -> UINT -> TakeResult e+dropL__ n l hl e r hr =+ case dropL_ n l hl of+ MoreTR L(0) -> let rhavl = pushLHAVL e (HAVL r hr)+ in rhavl `seq` AllTR rhavl+ MoreTR L(1) -> case r of+ E -> MoreTR L(0)+ _ -> let rhavl = HAVL r hr in rhavl `seq` AllTR rhavl+ MoreTR n_ -> dropL_ DECINT1(n_) r hr+ AllTR havl1 -> let havl1' = spliceHAVL havl1 e (HAVL r hr)+ in havl1' `seq` AllTR havl1'++-- | This is a simplified version of 'splitAtR' which returns the remaining tree only (leftmost elements).+-- This function raises an error if n is negative.+--+-- If the tree size is greater than n the result is (Right l) where l contains+-- the remaining elements (l will be non-empty).+--+-- If the tree size is less than or equal to n then the result is (Left s), where s is tree size.+--+-- An empty tree will always yield a result of (Left 0).+--+-- Complexity: O(n)+dropR :: Int -> AVL e -> Either Int (AVL e)+dropR n _ | n < 0 = error "dropL: Negative argument."+dropR 0 E = Left 0 -- Treat this case specially+dropR 0 t = Right t+dropR ASINT(n) t = case dropR_ n t L(0) of -- Tree Heights are relative!!+ MoreTR n_ -> Left ASINT(SUBINT(n,n_))+ AllTR (HAVL l _) -> Right l++-- n > 0 !!+-- N.B Never returns a result of form (AllTR lhavl) where lhavl is empty+dropR_ :: UINT -> AVL e -> UINT -> TakeResult e+dropR_ n E _ = MoreTR n+dropR_ n (N l e r) h = dropR__ n l DECINT2(h) e r DECINT1(h)+dropR_ n (Z l e r) h = dropR__ n l DECINT1(h) e r DECINT1(h)+dropR_ n (P l e r) h = dropR__ n l DECINT1(h) e r DECINT2(h)++-- n > 0 !!+-- N.B Never returns a result of form (AllTR lhavl) where lhavl is empty+dropR__ :: UINT -> AVL e -> UINT -> e -> AVL e -> UINT -> TakeResult e+dropR__ n l hl e r hr =+ case dropR_ n r hr of+ MoreTR L(0) -> let lhavl = pushRHAVL (HAVL l hl) e+ in lhavl `seq` AllTR lhavl+ MoreTR L(1) -> case l of+ E -> MoreTR L(0)+ _ -> let lhavl = HAVL l hl in lhavl `seq` AllTR lhavl+ MoreTR n_ -> dropR_ DECINT1(n_) l hl+ AllTR havl0 -> let havl0' = spliceHAVL (HAVL l hl) e havl0+ in havl0' `seq` AllTR havl0'+++-- Local Datatype for results of span operations.+data SpanResult e = Some (HAVL e) (HAVL e) -- Two tree/height pairs. Non Strict!!+ | TheLot -- The Lot satisfied++-- | Span an AVL tree from the left, using the supplied predicate. This function returns+-- a pair of trees (l,r), where l contains the leftmost consecutive elements which+-- satisfy the predicate. The leftmost element of r (if any) is the first to fail+-- the predicate. Either of the resulting trees may be empty. Element ordering is preserved.+--+-- Complexity: O(n), where n is the size of l.+spanL :: (e -> Bool) -> AVL e -> (AVL e, AVL e)+spanL p t = case spanIt t L(0) of -- Tree heights are relative+ TheLot -> (t, E) -- All satisfied+ Some (HAVL l _) (HAVL r _) -> (l, r) -- Some satisfied+ where+ spanIt E _ = TheLot+ spanIt (N l e r) h = spanIt_ l DECINT2(h) e r DECINT1(h)+ spanIt (Z l e r) h = spanIt_ l DECINT1(h) e r DECINT1(h)+ spanIt (P l e r) h = spanIt_ l DECINT1(h) e r DECINT2(h)+ -- N.B: Never Returns (Some _ (HAVL E _)) (== TheLot)+ spanIt_ l hl e r hr =+ case spanIt l hl of+ Some havl0 havl1 -> let havl1_ = spliceHAVL havl1 e (HAVL r hr)+ in havl1_ `seq` Some havl0 havl1_+ TheLot -> if p e+ then let spanItr = spanIt r hr+ in case spanItr of+ Some havl0 havl1 -> let havl0_ = spliceHAVL (HAVL l hl) e havl0+ in havl0_ `seq` Some havl0_ havl1+ _ -> spanItr+ else let rhavl = pushLHAVL e (HAVL r hr)+ lhavl = HAVL l hl+ in lhavl `seq` rhavl `seq` Some lhavl rhavl++-- | Span an AVL tree from the right, using the supplied predicate. This function returns+-- a pair of trees (l,r), where r contains the rightmost consecutive elements which+-- satisfy the predicate. The rightmost element of l (if any) is the first to fail+-- the predicate. Either of the resulting trees may be empty. Element ordering is preserved.+--+-- Complexity: O(n), where n is the size of r.+spanR :: (e -> Bool) -> AVL e -> (AVL e, AVL e)+spanR p t = case spanIt t L(0) of -- Tree heights are relative+ TheLot -> (E, t) -- All satisfied+ Some (HAVL l _) (HAVL r _) -> (l, r) -- Some satisfied+ where+ spanIt E _ = TheLot+ spanIt (N l e r) h = spanIt_ l DECINT2(h) e r DECINT1(h)+ spanIt (Z l e r) h = spanIt_ l DECINT1(h) e r DECINT1(h)+ spanIt (P l e r) h = spanIt_ l DECINT1(h) e r DECINT2(h)+ -- N.B: Never Returns (Some (HAVL E _) _) (== TheLot)+ spanIt_ l hl e r hr =+ case spanIt r hr of+ Some havl0 havl1 -> let havl0_ = spliceHAVL (HAVL l hl) e havl0+ in havl0_ `seq` Some havl0_ havl1+ TheLot -> if p e+ then let spanItl = spanIt l hl+ in case spanItl of+ Some havl0 havl1 -> let havl1_ = spliceHAVL havl1 e (HAVL r hr)+ in havl1_ `seq` Some havl0 havl1_+ _ -> spanItl+ else let lhavl = pushRHAVL (HAVL l hl) e+ rhavl = HAVL r hr+ in lhavl `seq` rhavl `seq` Some lhavl rhavl++-- Local Datatype for results of takeWhile/DropWhile operations.+data TakeWhileResult e = SomeTW (HAVL e)+ | TheLotTW++-- | This is a simplified version of 'spanL' which does not return the remaining tree+-- The result is the leftmost consecutive sequence of elements which satisfy the+-- supplied predicate (which may be empty).+--+-- Complexity: O(n), where n is the size of the result.+takeWhileL :: (e -> Bool) -> AVL e -> AVL e+takeWhileL p t = case spanIt t L(0) of -- Tree heights are relative+ TheLotTW -> t -- All satisfied+ SomeTW (HAVL l _) -> l -- Some satisfied+ where+ spanIt E _ = TheLotTW+ spanIt (N l e r) h = spanIt_ l DECINT2(h) e r DECINT1(h)+ spanIt (Z l e r) h = spanIt_ l DECINT1(h) e r DECINT1(h)+ spanIt (P l e r) h = spanIt_ l DECINT1(h) e r DECINT2(h)+ spanIt_ l hl e r hr =+ let twl = spanIt l hl+ in case twl of+ TheLotTW -> if p e+ then let twr = spanIt r hr+ in case twr of+ SomeTW havl0 -> let havl0_ = spliceHAVL (HAVL l hl) e havl0+ in havl0_ `seq` SomeTW havl0_+ _ -> twr+ else let lhavl = HAVL l hl in lhavl `seq` SomeTW lhavl+ _ -> twl++-- | This is a simplified version of 'spanR' which does not return the remaining tree+-- The result is the rightmost consecutive sequence of elements which satisfy the+-- supplied predicate (which may be empty).+--+-- Complexity: O(n), where n is the size of the result.+takeWhileR :: (e -> Bool) -> AVL e -> AVL e+takeWhileR p t = case spanIt t L(0) of -- Tree heights are relative+ TheLotTW -> t -- All satisfied+ SomeTW (HAVL r _) -> r -- Some satisfied+ where+ spanIt E _ = TheLotTW+ spanIt (N l e r) h = spanIt_ l DECINT2(h) e r DECINT1(h)+ spanIt (Z l e r) h = spanIt_ l DECINT1(h) e r DECINT1(h)+ spanIt (P l e r) h = spanIt_ l DECINT1(h) e r DECINT2(h)+ spanIt_ l hl e r hr =+ let twr = spanIt r hr+ in case twr of+ TheLotTW -> if p e+ then let twl = spanIt l hl+ in case twl of+ SomeTW havl1 -> let havl1_ = spliceHAVL havl1 e (HAVL r hr)+ in havl1_ `seq` SomeTW havl1_+ _ -> twl+ else let rhavl = HAVL r hr in rhavl `seq` SomeTW rhavl+ _ -> twr++-- | This is a simplified version of 'spanL' which does not return the tree containing+-- the elements which satisfy the supplied predicate.+-- The result is a tree whose leftmost element is the first to fail the predicate, starting from+-- the left (which may be empty).+--+-- Complexity: O(n), where n is the number of elements dropped.+dropWhileL :: (e -> Bool) -> AVL e -> AVL e+dropWhileL p t = case spanIt t L(0) of -- Tree heights are relative+ TheLotTW -> E -- All satisfied+ SomeTW (HAVL r _) -> r -- Some satisfied+ where+ spanIt E _ = TheLotTW+ spanIt (N l e r) h = spanIt_ l DECINT2(h) e r DECINT1(h)+ spanIt (Z l e r) h = spanIt_ l DECINT1(h) e r DECINT1(h)+ spanIt (P l e r) h = spanIt_ l DECINT1(h) e r DECINT2(h)+ spanIt_ l hl e r hr =+ case spanIt l hl of+ SomeTW havl1 -> let havl1_ = spliceHAVL havl1 e (HAVL r hr)+ in havl1_ `seq` SomeTW havl1_+ TheLotTW -> if p e+ then spanIt r hr+ else let rhavl = pushLHAVL e (HAVL r hr)+ in rhavl `seq` SomeTW rhavl++-- | This is a simplified version of 'spanR' which does not return the tree containing+-- the elements which satisfy the supplied predicate.+-- The result is a tree whose rightmost element is the first to fail the predicate, starting from+-- the right (which may be empty).+--+-- Complexity: O(n), where n is the number of elements dropped.+dropWhileR :: (e -> Bool) -> AVL e -> AVL e+dropWhileR p t = case spanIt t L(0) of -- Tree heights are relative+ TheLotTW -> E -- All satisfied+ SomeTW (HAVL l _) -> l -- Some satisfied+ where+ spanIt E _ = TheLotTW+ spanIt (N l e r) h = spanIt_ l DECINT2(h) e r DECINT1(h)+ spanIt (Z l e r) h = spanIt_ l DECINT1(h) e r DECINT1(h)+ spanIt (P l e r) h = spanIt_ l DECINT1(h) e r DECINT2(h)+ spanIt_ l hl e r hr =+ case spanIt r hr of+ SomeTW havl0 -> let havl0_ = spliceHAVL (HAVL l hl) e havl0+ in havl0_ `seq` SomeTW havl0_+ TheLotTW -> if p e+ then spanIt l hl+ else let lhavl = pushRHAVL (HAVL l hl) e+ in lhavl `seq` SomeTW lhavl++-- | Rotate an AVL tree one place left. This function pops the leftmost element and pushes into+-- the rightmost position. An empty tree yields an empty tree.+--+-- Complexity: O(log n)+rotateL :: AVL e -> AVL e+rotateL E = E+rotateL (N l e r) = case popLN l e r of UBT2(e_,t) -> pushR t e_+rotateL (Z l e r) = case popLZ l e r of UBT2(e_,t) -> pushR t e_+rotateL (P l e r) = case popLP l e r of UBT2(e_,t) -> pushR t e_++-- | Rotate an AVL tree one place right. This function pops the rightmost element and pushes into+-- the leftmost position. An empty tree yields an empty tree.+--+-- Complexity: O(log n)+rotateR :: AVL e -> AVL e+rotateR E = E+rotateR (N l e r) = case popRN l e r of UBT2(t,e_) -> pushL e_ t+rotateR (Z l e r) = case popRZ l e r of UBT2(t,e_) -> pushL e_ t+rotateR (P l e r) = case popRP l e r of UBT2(t,e_) -> pushL e_ t++-- | Similar to 'rotateL', but returns the rotated element. This function raises an error if+-- applied to an empty tree.+--+-- Complexity: O(log n)+popRotateL :: AVL e -> (e, AVL e)+popRotateL E = error "popRotateL: Empty tree."+popRotateL (N l e r) = case popLN l e r of UBT2(e_,t) -> popRotateL' e_ t+popRotateL (Z l e r) = case popLZ l e r of UBT2(e_,t) -> popRotateL' e_ t+popRotateL (P l e r) = case popLP l e r of UBT2(e_,t) -> popRotateL' e_ t+popRotateL' :: e -> AVL e -> (e, AVL e)+popRotateL' e t = let t' = pushR t e in t' `seq` (e,t')++-- | Similar to 'rotateR', but returns the rotated element. This function raises an error if+-- applied to an empty tree.+--+-- Complexity: O(log n)+popRotateR :: AVL e -> (AVL e, e)+popRotateR E = error "popRotateR: Empty tree."+popRotateR (N l e r) = case popRN l e r of UBT2(t,e_) -> popRotateR' t e_+popRotateR (Z l e r) = case popRZ l e r of UBT2(t,e_) -> popRotateR' t e_+popRotateR (P l e r) = case popRP l e r of UBT2(t,e_) -> popRotateR' t e_+popRotateR' :: AVL e -> e -> (AVL e, e)+popRotateR' t e = let t' = pushL e t in t' `seq` (t',e)+++-- | Rotate an AVL tree left by n places. If s is the size of the tree then ordinarily n+-- should be in the range [0..s-1]. However, this function will deliver a correct result+-- for any n (n\<0 or n\>=s), the actual rotation being given by (n \`mod\` s) in such cases.+-- The result of rotating an empty tree is an empty tree.+--+-- Complexity: O(n)+rotateByL :: AVL e -> Int -> AVL e+rotateByL t ASINT(n) = case COMPAREUINT n L(0) of+ LT -> rotateByR__ t NEGATE(n)+ EQ -> t+ GT -> rotateByL__ t n+-- n>=0!!+{-# INLINE rotateByL_ #-}+rotateByL_ :: AVL e -> UINT -> AVL e+rotateByL_ t L(0) = t+rotateByL_ t n = rotateByL__ t n+-- n>0!!+rotateByL__ :: AVL e -> UINT -> AVL e+rotateByL__ E _ = E+rotateByL__ t n = case splitL n t L(0) of -- Tree Heights are relative!!+ More L(0) -> t+ More m -> let s = SUBINT(n,m) -- Actual size of tree, > 0!!+ n_ = _MODULO_(n,s) -- Actual shift required, 0..s-1+ in if isTrue# (ADDINT(n_,n_) LEQ s)+ then rotateByL_ t n_ -- n_ may be 0 !!+ else rotateByR__ t SUBINT(s,n_) -- (s-n_) can't be 0+ All (HAVL l hl) (HAVL r hr) -> joinH' r hr l hl+++-- | Rotate an AVL tree right by n places. If s is the size of the tree then ordinarily n+-- should be in the range [0..s-1]. However, this function will deliver a correct result+-- for any n (n\<0 or n\>=s), the actual rotation being given by (n \`mod\` s) in such cases.+-- The result of rotating an empty tree is an empty tree.+--+-- Complexity: O(n)+rotateByR :: AVL e -> Int -> AVL e+rotateByR t ASINT(n) = case COMPAREUINT n L(0) of+ LT -> rotateByL__ t NEGATE(n)+ EQ -> t+ GT -> rotateByR__ t n+-- n>=0!!+{-# INLINE rotateByR_ #-}+rotateByR_ :: AVL e -> UINT -> AVL e+rotateByR_ t L(0) = t+rotateByR_ t n = rotateByR__ t n+-- n>0!!+rotateByR__ :: AVL e -> UINT -> AVL e+rotateByR__ E _ = E+rotateByR__ t n = case splitR n t L(0) of -- Tree Heights are relative!!+ More L(0) -> t+ More m -> let s = SUBINT(n,m) -- Actual size of tree, > 0!!+ n_ = _MODULO_(n,s) -- Actual shift required, 0..s-1+ in if isTrue# (ADDINT(n_,n_) LEQ s)+ then rotateByR_ t n_ -- n_ may be 0 !!+ else rotateByL__ t SUBINT(s,n_) -- (s-n_) can_t be 0+ All (HAVL l hl) (HAVL r hr) -> joinH' r hr l hl+++-- | Divide a sorted AVL tree into left and right sorted trees (l,r), such that l contains all the+-- elements less than or equal to according to the supplied selector and r contains all the elements greater than+-- according to the supplied selector.+--+-- Complexity: O(log n)+forkL :: (e -> Ordering) -> AVL e -> (AVL e, AVL e)+forkL c avl = let (HAVL l _,HAVL r _) = forkL_ L(0) avl -- Tree heights are relative+ in (l,r)+ where+ forkL_ h E = (HAVL E h, HAVL E h)+ forkL_ h (N l e r) = forkL__ l DECINT2(h) e r DECINT1(h)+ forkL_ h (Z l e r) = forkL__ l DECINT1(h) e r DECINT1(h)+ forkL_ h (P l e r) = forkL__ l DECINT1(h) e r DECINT2(h)+ forkL__ l hl e r hr = case c e of+ -- Current element > pivot, so goes in right half+ LT -> let (havl0,havl1) = forkL_ hl l+ havl1_ = spliceHAVL havl1 e (HAVL r hr)+ in havl1_ `seq` (havl0, havl1_)+ -- Current element = pivot, so goes in left half and stop here+ EQ -> let lhavl = pushRHAVL (HAVL l hl) e+ rhavl = HAVL r hr+ in lhavl `seq` rhavl `seq` (lhavl,rhavl)+ -- Current element < pivot, so goes in left half+ GT -> let (havl0,havl1) = forkL_ hr r+ havl0_ = spliceHAVL (HAVL l hl) e havl0+ in havl0_ `seq` (havl0_, havl1)++-- | Divide a sorted AVL tree into left and right sorted trees (l,r), such that l contains all the+-- elements less than supplied selector and r contains all the elements greater than or equal to the+-- supplied selector.+--+-- Complexity: O(log n)+forkR :: (e -> Ordering) -> AVL e -> (AVL e, AVL e)+forkR c avl = let (HAVL l _,HAVL r _) = forkR_ L(0) avl -- Tree heights are relative+ in (l,r)+ where+ forkR_ h E = (HAVL E h, HAVL E h)+ forkR_ h (N l e r) = forkR__ l DECINT2(h) e r DECINT1(h)+ forkR_ h (Z l e r) = forkR__ l DECINT1(h) e r DECINT1(h)+ forkR_ h (P l e r) = forkR__ l DECINT1(h) e r DECINT2(h)+ forkR__ l hl e r hr = case c e of+ -- Current element > pivot, so goes in right half+ LT -> let (havl0,havl1) = forkR_ hl l+ havl1_ = spliceHAVL havl1 e (HAVL r hr)+ in havl1_ `seq` (havl0, havl1_)+ -- Current element = pivot, so goes in right half and stop here+ EQ -> let rhavl = pushLHAVL e (HAVL r hr)+ lhavl = HAVL l hl+ in lhavl `seq` rhavl `seq` (lhavl, rhavl)+ -- Current element < pivot, so goes in left half+ GT -> let (havl0,havl1) = forkR_ hr r+ havl0_ = spliceHAVL (HAVL l hl) e havl0+ in havl0_ `seq` (havl0_, havl1)+++-- | Similar to 'forkL' and 'forkR', but returns any equal element found (instead of+-- incorporating it into the left or right tree results respectively).+--+-- Complexity: O(log n)+fork :: (e -> COrdering a) -> AVL e -> (AVL e, Maybe a, AVL e)+fork c avl = let (HAVL l _, mba, HAVL r _) = fork_ L(0) avl -- Tree heights are relative+ in (l,mba,r)+ where+ fork_ h E = (HAVL E h, Nothing, HAVL E h)+ fork_ h (N l e r) = fork__ l DECINT2(h) e r DECINT1(h)+ fork_ h (Z l e r) = fork__ l DECINT1(h) e r DECINT1(h)+ fork_ h (P l e r) = fork__ l DECINT1(h) e r DECINT2(h)+ fork__ l hl e r hr = case c e of+ -- Current element > pivot+ Lt -> let (havl0,mba,havl1) = fork_ hl l+ havl1_ = spliceHAVL havl1 e (HAVL r hr)+ in havl1_ `seq` (havl0, mba, havl1_)+ -- Current element = pivot+ Eq a -> let lhavl = HAVL l hl+ rhavl = HAVL r hr+ in lhavl `seq` rhavl `seq` (lhavl, Just a, rhavl)+ -- Current element < pivot+ Gt -> let (havl0,mba,havl1) = fork_ hr r+ havl0_ = spliceHAVL (HAVL l hl) e havl0+ in havl0_ `seq` (havl0_, mba, havl1)++-- | This is a simplified version of 'forkL' which returns a sorted tree containing+-- only those elements which are less than or equal to according to the supplied selector.+-- This function also has the synonym 'dropGT'.+--+-- Complexity: O(log n)+takeLE :: (e -> Ordering) -> AVL e -> AVL e+takeLE c avl = let HAVL l _ = forkL_ L(0) avl -- Tree heights are relative+ in l+ where+ forkL_ h E = HAVL E h+ forkL_ h (N l e r) = forkL__ l DECINT2(h) e r DECINT1(h)+ forkL_ h (Z l e r) = forkL__ l DECINT1(h) e r DECINT1(h)+ forkL_ h (P l e r) = forkL__ l DECINT1(h) e r DECINT2(h)+ forkL__ l hl e r hr = case c e of+ LT -> forkL_ hl l+ EQ -> pushRHAVL (HAVL l hl) e+ GT -> let havl0 = forkL_ hr r+ in spliceHAVL (HAVL l hl) e havl0+++-- | A synonym for 'takeLE'.+--+-- Complexity: O(log n)+dropGT :: (e -> Ordering) -> AVL e -> AVL e+dropGT = takeLE+{-# INLINE dropGT #-}++-- | This is a simplified version of 'forkL' which returns a sorted tree containing+-- only those elements which are greater according to the supplied selector.+-- This function also has the synonym 'dropLE'.+--+-- Complexity: O(log n)+takeGT :: (e -> Ordering) -> AVL e -> AVL e+takeGT c avl = let HAVL r _ = forkL_ L(0) avl -- Tree heights are relative+ in r+ where+ forkL_ h E = HAVL E h+ forkL_ h (N l e r) = forkL__ l DECINT2(h) e r DECINT1(h)+ forkL_ h (Z l e r) = forkL__ l DECINT1(h) e r DECINT1(h)+ forkL_ h (P l e r) = forkL__ l DECINT1(h) e r DECINT2(h)+ forkL__ l hl e r hr = case c e of+ LT -> let havl1 = forkL_ hl l+ in spliceHAVL havl1 e (HAVL r hr)+ EQ -> HAVL r hr+ GT -> forkL_ hr r++-- | A synonym for 'takeGT'.+--+-- Complexity: O(log n)+dropLE :: (e -> Ordering) -> AVL e -> AVL e+dropLE = takeGT+{-# INLINE dropLE #-}++-- | This is a simplified version of 'forkR' which returns a sorted tree containing+-- only those elements which are less than according to the supplied selector.+-- This function also has the synonym 'dropGE'.+--+-- Complexity: O(log n)+takeLT :: (e -> Ordering) -> AVL e -> AVL e+takeLT c avl = let HAVL l _ = forkL_ L(0) avl -- Tree heights are relative+ in l+ where+ forkL_ h E = HAVL E h+ forkL_ h (N l e r) = forkL__ l DECINT2(h) e r DECINT1(h)+ forkL_ h (Z l e r) = forkL__ l DECINT1(h) e r DECINT1(h)+ forkL_ h (P l e r) = forkL__ l DECINT1(h) e r DECINT2(h)+ forkL__ l hl e r hr = case c e of+ LT -> forkL_ hl l+ EQ -> HAVL l hl+ GT -> let havl0 = forkL_ hr r+ in spliceHAVL (HAVL l hl) e havl0+++-- | A synonym for 'takeLT'.+--+-- Complexity: O(log n)+dropGE :: (e -> Ordering) -> AVL e -> AVL e+dropGE = takeLT+{-# INLINE dropGE #-}++-- | This is a simplified version of 'forkR' which returns a sorted tree containing+-- only those elements which are greater or equal to according to the supplied selector.+-- This function also has the synonym 'dropLT'.+--+-- Complexity: O(log n)+takeGE :: (e -> Ordering) -> AVL e -> AVL e+takeGE c avl = let HAVL r _ = forkL_ L(0) avl -- Tree heights are relative+ in r+ where+ forkL_ h E = HAVL E h+ forkL_ h (N l e r) = forkL__ l DECINT2(h) e r DECINT1(h)+ forkL_ h (Z l e r) = forkL__ l DECINT1(h) e r DECINT1(h)+ forkL_ h (P l e r) = forkL__ l DECINT1(h) e r DECINT2(h)+ forkL__ l hl e r hr = case c e of+ LT -> let havl1 = forkL_ hl l+ in spliceHAVL havl1 e (HAVL r hr)+ EQ -> pushLHAVL e (HAVL r hr)+ GT -> forkL_ hr r++-- | A synonym for 'takeGE'.+--+-- Complexity: O(log n)+dropLT :: (e -> Ordering) -> AVL e -> AVL e+dropLT = takeGE+{-# INLINE dropLT #-}+
+ src/Data/Tree/AVL/Test/Utils.hs view
@@ -0,0 +1,112 @@+-- |+-- Copyright : (c) Adrian Hey 2004,2005+-- License : BSD3+--+--+-- 'AVL' tree related test and verification utilities.+module Data.Tree.AVL.Test.Utils+ (-- * Correctness checking.+ isBalanced,isSorted,isSortedOK,+ -- * Tree parameter utilities.+ minElements,maxElements,+ ) where++import Data.Tree.AVL.Internals.Types(AVL(..))++import GHC.Base+#include "ghcdefs.h"++-- | Verify that a tree is height balanced and that the BF of each node is correct.+--+-- Complexity: O(n)+isBalanced :: AVL e -> Bool+isBalanced t = not (isTrue# (cH t EQL L(-1)))++-- Local utility, returns height if balanced, -1 if not+cH :: AVL e -> UINT+cH E = L(0)+cH (N l _ r) = cH_ L(1) l r -- (hr-hl) = 1+cH (Z l _ r) = cH_ L(0) l r -- (hr-hl) = 0+cH (P l _ r) = cH_ L(1) r l -- (hl-hr) = 1+cH_ :: UINT -> AVL e -> AVL e -> UINT+cH_ delta l r = let hl = cH l+ in if isTrue# (hl EQL L(-1)) then hl+ else let hr = cH r+ in if isTrue# (hr EQL L(-1)) then hr+ else if isTrue# (SUBINT(hr,hl) EQL delta) then INCINT1(hr)+ else L(-1)++-- | Verify that a tree is sorted.+--+-- Complexity: O(n)+isSorted :: (e -> e -> Ordering) -> AVL e -> Bool+isSorted c = isSorted' where+ isSorted' E = True+ isSorted' (N l e r) = isSorted'' l e r+ isSorted' (Z l e r) = isSorted'' l e r+ isSorted' (P l e r) = isSorted'' l e r+ isSorted'' l e r = (isSortedU l e) && (isSortedL e r)+ -- Verify tree is sorted and rightmost element is less than an upper limit (ul)+ isSortedU E _ = True+ isSortedU (N l e r) ul = isSortedU' l e r ul+ isSortedU (Z l e r) ul = isSortedU' l e r ul+ isSortedU (P l e r) ul = isSortedU' l e r ul+ isSortedU' l e r ul = case c e ul of+ LT -> (isSortedU l e) && (isSortedLU e r ul)+ _ -> False+ -- Verify tree is sorted and leftmost element is greater than a lower limit (ll)+ isSortedL _ E = True+ isSortedL ll (N l e r) = isSortedL' ll l e r+ isSortedL ll (Z l e r) = isSortedL' ll l e r+ isSortedL ll (P l e r) = isSortedL' ll l e r+ isSortedL' ll l e r = case c e ll of+ GT -> (isSortedLU ll l e) && (isSortedL e r)+ _ -> False+ -- Verify tree is sorted and leftmost element is greater than a lower limit (ll)+ -- and rightmost element is less than an upper limit (ul)+ isSortedLU _ E _ = True+ isSortedLU ll (N l e r) ul = isSortedLU' ll l e r ul+ isSortedLU ll (Z l e r) ul = isSortedLU' ll l e r ul+ isSortedLU ll (P l e r) ul = isSortedLU' ll l e r ul+ isSortedLU' ll l e r ul = case c e ll of+ GT -> case c e ul of+ LT -> (isSortedLU ll l e) && (isSortedLU e r ul)+ _ -> False+ _ -> False+-- isSorted ends --+-------------------++-- | Verify that a tree is sorted, height balanced and the BF of each node is correct.+--+-- Complexity: O(n)+isSortedOK :: (e -> e -> Ordering) -> AVL e -> Bool+isSortedOK c t = (isBalanced t) && (isSorted c t)++-- | Detetermine the minimum number of elements in an AVL tree of given height.+-- This function satisfies this recurrence relation..+--+-- @+-- minElements 0 = 0+-- minElements 1 = 1+-- minElements h = 1 + minElements (h-1) + minElements (h-2)+-- -- = Some weird expression involving the golden ratio+-- @+minElements :: Int -> Integer+minElements 0 = 0+minElements 1 = 1+minElements h = minElements' 0 1 h where+ minElements' n1 n2 2 = 1 + n1 + n2+ minElements' n1 n2 m = minElements' n2 (1 + n1 + n2) (m-1)++-- | Detetermine the maximum number of elements in an AVL tree of given height.+-- This function satisfies this recurrence relation..+--+-- @+-- maxElements 0 = 0+-- maxElements h = 1 + 2 * maxElements (h-1) -- = 2^h-1+-- @+maxElements :: Int -> Integer+maxElements 0 = 0+maxElements h = maxElements' 0 h where+ maxElements' n1 1 = 1 + 2*n1+ maxElements' n1 m = maxElements' (1 + 2*n1) (m-1)
+ src/Data/Tree/AVL/Utils.hs view
@@ -0,0 +1,55 @@+-- |+-- Copyright : (c) Adrian Hey 2004,2005+-- License : BSD3+--+-- A few simple utility functions.+{-# OPTIONS_HADDOCK hide #-}+module Data.Tree.AVL.Utils+ ( -- * Simple AVL related utilities+ empty,isEmpty,isNonEmpty,singleton,pair,tryGetSingleton,++ ) where++import Data.Tree.AVL.Internals.Types (AVL(..))++-- | The empty AVL tree.+{-# INLINE empty #-}+empty :: AVL e+empty = E++-- | Returns 'True' if an AVL tree is empty.+--+-- Complexity: O(1)+isEmpty :: AVL e -> Bool+isEmpty E = True+isEmpty _ = False+{-# INLINE isEmpty #-}++-- | Returns 'True' if an AVL tree is non-empty.+--+-- Complexity: O(1)+isNonEmpty :: AVL e -> Bool+isNonEmpty E = False+isNonEmpty _ = True+{-# INLINE isNonEmpty #-}++-- | Creates an AVL tree with just one element.+--+-- Complexity: O(1)+singleton :: e -> AVL e+singleton e = Z E e E+{-# INLINE singleton #-}++-- | Create an AVL tree of two elements, occuring in same order as the arguments.+pair :: e -> e -> AVL e+pair e0 e1 = P (Z E e0 E) e1 E+{-# INLINE pair #-}++-- | If the AVL tree is a singleton (has only one element @e@) then this function returns @('Just' e)@.+-- Otherwise it returns Nothing.+--+-- Complexity: O(1)+tryGetSingleton :: AVL e -> Maybe e+tryGetSingleton (Z E e _) = Just e -- Right subtree must be E too, but no need to waste time checking+tryGetSingleton _ = Nothing+{-# INLINE tryGetSingleton #-}
+ src/Data/Tree/AVL/Write.hs view
@@ -0,0 +1,192 @@+-- |+-- Copyright : (c) Adrian Hey 2004,2005+-- License : BSD3+--+{-# OPTIONS_HADDOCK hide #-}+module Data.Tree.AVL.Write+(-- * Writing to AVL trees+ -- | These functions alter the content of a tree (values of tree elements) but not the structure+ -- of a tree.++ -- ** Writing to extreme left or right+ -- | I'm not sure these are likely to be much use in practice, but they're+ -- simple enough to implement so are included for the sake of completeness.+ writeL,tryWriteL,writeR,tryWriteR,++ -- ** Writing to /sorted/ trees+ write,writeFast,tryWrite,writeMaybe,tryWriteMaybe+) where++import Prelude -- so haddock finds the symbols there++import Data.COrdering+import Data.Tree.AVL.Internals.Types(AVL(..))+import Data.Tree.AVL.BinPath(BinPath(..),openPathWith,writePath)++---------------------------------------------------------------------------+-- writeL, tryWriteL --+---------------------------------------------------------------------------+-- | Replace the left most element of a tree with the supplied new element.+-- This function raises an error if applied to an empty tree.+--+-- Complexity: O(log n)+writeL :: e -> AVL e -> AVL e+writeL _ E = error "writeL: Empty Tree"+writeL e' (N l e r) = writeLN e' l e r+writeL e' (Z l e r) = writeLZ e' l e r+writeL e' (P l e r) = writeLP e' l e r++-- | Similar to 'writeL', but returns 'Nothing' if applied to an empty tree.+--+-- Complexity: O(log n)+tryWriteL :: e -> AVL e -> Maybe (AVL e)+tryWriteL _ E = Nothing+tryWriteL e' (N l e r) = Just $! writeLN e' l e r+tryWriteL e' (Z l e r) = Just $! writeLZ e' l e r+tryWriteL e' (P l e r) = Just $! writeLP e' l e r++-- This version of writeL is for trees which are known to be non-empty.+writeL' :: e -> AVL e -> AVL e+writeL' _ E = error "writeL': Bug0"+writeL' e' (N l e r) = writeLN e' l e r -- l may be empty+writeL' e' (Z l e r) = writeLZ e' l e r -- l may be empty+writeL' e' (P l e r) = writeLP e' l e r -- l can't be empty++-- Write to left sub-tree of N l e r, or here if l is empty+writeLN :: e -> AVL e -> e -> AVL e -> AVL e+writeLN e' E _ r = N E e' r+writeLN e' (N ll le lr) e r = let l' = writeLN e' ll le lr in l' `seq` N l' e r+writeLN e' (Z ll le lr) e r = let l' = writeLZ e' ll le lr in l' `seq` N l' e r+writeLN e' (P ll le lr) e r = let l' = writeLP e' ll le lr in l' `seq` N l' e r++-- Write to left sub-tree of Z l e r, or here if l is empty+writeLZ :: e -> AVL e -> e -> AVL e -> AVL e+writeLZ e' E _ r = Z E e' r -- r must be E too!+writeLZ e' (N ll le lr) e r = let l' = writeLN e' ll le lr in l' `seq` Z l' e r+writeLZ e' (Z ll le lr) e r = let l' = writeLZ e' ll le lr in l' `seq` Z l' e r+writeLZ e' (P ll le lr) e r = let l' = writeLP e' ll le lr in l' `seq` Z l' e r++-- Write to left sub-tree of P l e r (l can't be empty)+{-# INLINE writeLP #-}+writeLP :: e -> AVL e -> e -> AVL e -> AVL e+writeLP e' l e r = let l' = writeL' e' l in l' `seq` P l' e r+---------------------------------------------------------------------------+-- writeL, tryWriteL end here --+---------------------------------------------------------------------------+++---------------------------------------------------------------------------+-- writeR, tryWriteR --+---------------------------------------------------------------------------+-- | Replace the right most element of a tree with the supplied new element.+-- This function raises an error if applied to an empty tree.+--+-- Complexity: O(log n)+writeR :: AVL e -> e -> AVL e+writeR E _ = error "writeR: Empty Tree"+writeR (N l e r) e' = writeRN l e r e'+writeR (Z l e r) e' = writeRZ l e r e'+writeR (P l e r) e' = writeRP l e r e'++-- | Similar to 'writeR', but returns 'Nothing' if applied to an empty tree.+--+-- Complexity: O(log n)+tryWriteR :: AVL e -> e -> Maybe (AVL e)+tryWriteR E _ = Nothing+tryWriteR (N l e r) e' = Just $! writeRN l e r e'+tryWriteR (Z l e r) e' = Just $! writeRZ l e r e'+tryWriteR (P l e r) e' = Just $! writeRP l e r e'++-- This version of writeR is for trees which are known to be non-empty.+writeR' :: AVL e -> e -> AVL e+writeR' E _ = error "writeR': Bug0"+writeR' (N l e r) e' = writeRN l e r e' -- r can't be empty+writeR' (Z l e r) e' = writeRZ l e r e' -- r may be empty+writeR' (P l e r) e' = writeRP l e r e' -- r may be empty++-- Write to right sub-tree of N l e r (r can't be empty)+{-# INLINE writeRN #-}+writeRN :: AVL e -> e -> AVL e -> e -> AVL e+writeRN l e r e' = let r' = writeR' r e' in r' `seq` N l e r'++-- Write to right sub-tree of Z l e r, or here if r is empty+writeRZ :: AVL e -> e -> AVL e -> e -> AVL e+writeRZ l _ E e' = Z l e' E -- l must be E too!+writeRZ l e (N rl re rr) e' = let r' = writeRN rl re rr e' in r' `seq` Z l e r'+writeRZ l e (Z rl re rr) e' = let r' = writeRZ rl re rr e' in r' `seq` Z l e r'+writeRZ l e (P rl re rr) e' = let r' = writeRP rl re rr e' in r' `seq` Z l e r'++-- Write to right sub-tree of P l e r, or here if r is empty+writeRP :: AVL e -> e -> AVL e -> e -> AVL e+writeRP l _ E e' = P l e' E+writeRP l e (N rl re rr) e' = let r' = writeRN rl re rr e' in r' `seq` P l e r'+writeRP l e (Z rl re rr) e' = let r' = writeRZ rl re rr e' in r' `seq` P l e r'+writeRP l e (P rl re rr) e' = let r' = writeRP rl re rr e' in r' `seq` P l e r'+---------------------------------------------------------------------------+-- writeR, tryWriteR end here --+---------------------------------------------------------------------------+++-- | A general purpose function to perform a search of a tree, using the supplied selector.+-- If the search succeeds the found element is replaced by the value (@e@) of the @('Data.COrdering.Eq' e)@+-- constructor returned by the selector. If the search fails this function returns the original tree.+--+-- Complexity: O(log n)+write :: (e -> COrdering e) -> AVL e -> AVL e+write c t = case openPathWith c t of+ FullBP pth e -> writePath pth e t+ _ -> t++-- | Functionally identical to 'write', but returns an identical tree (one with all the nodes on+-- the path duplicated) if the search fails. This should probably only be used if you know the+-- search will succeed and will return an element which is different from that already present.+--+-- Complexity: O(log n)+writeFast :: (e -> COrdering e) -> AVL e -> AVL e+writeFast c = w where+ w E = E+ w (N l e r) = case c e of+ Lt -> let l' = w l in l' `seq` N l' e r+ Eq v -> N l v r+ Gt -> let r' = w r in r' `seq` N l e r'+ w (Z l e r) = case c e of+ Lt -> let l' = w l in l' `seq` Z l' e r+ Eq v -> Z l v r+ Gt -> let r' = w r in r' `seq` Z l e r'+ w (P l e r) = case c e of+ Lt -> let l' = w l in l' `seq` P l' e r+ Eq v -> P l v r+ Gt -> let r' = w r in r' `seq` P l e r'++-- | A general purpose function to perform a search of a tree, using the supplied selector.+-- The found element is replaced by the value (@e@) of the @('Data.COrdering.Eq' e)@ constructor returned by+-- the selector. This function returns 'Nothing' if the search failed.+--+-- Complexity: O(log n)+tryWrite :: (e -> COrdering e) -> AVL e -> Maybe (AVL e)+tryWrite c t = case openPathWith c t of+ FullBP pth e -> Just $! writePath pth e t+ _ -> Nothing++-- | Similar to 'write', but also returns the original tree if the search succeeds but+-- the selector returns @('Data.COrdering.Eq' 'Nothing')@. (This version is intended to help reduce heap burn+-- rate if it\'s likely that no modification of the value is needed.)+--+-- Complexity: O(log n)+writeMaybe :: (e -> COrdering (Maybe e)) -> AVL e -> AVL e+writeMaybe c t = case openPathWith c t of+ FullBP pth (Just e) -> writePath pth e t+ _ -> t++-- | Similar to 'tryWrite', but also returns the original tree if the search succeeds but+-- the selector returns @('Data.COrdering.Eq' 'Nothing')@. (This version is intended to help reduce heap burn+-- rate if it\'s likely that no modification of the value is needed.)+--+-- Complexity: O(log n)+tryWriteMaybe :: (e -> COrdering (Maybe e)) -> AVL e -> Maybe (AVL e)+tryWriteMaybe c t = case openPathWith c t of+ FullBP pth (Just e) -> Just $! writePath pth e t+ FullBP _ Nothing -> Just t+ _ -> Nothing++
+ src/Data/Tree/AVL/Zipper.hs view
@@ -0,0 +1,895 @@+-- |+-- Copyright : (c) Adrian Hey 2004,2005+-- License : BSD3+--+{-# OPTIONS_HADDOCK hide #-}+module Data.Tree.AVL.Zipper+(-- * The AVL Zipper+ -- | An implementation of \"The Zipper\" for AVL trees. This can be used like+ -- a functional pointer to a serial data structure which can be navigated+ -- and modified, without having to worry about all those tricky tree balancing+ -- issues. See JFP Vol.7 part 5 or <http://haskell.org/haskellwiki/Zipper>.+ --+ -- Notes about efficiency:+ --+ -- The functions defined here provide a useful way to achieve those awkward+ -- operations which may not be covered by the rest of this package. They're+ -- reasonably efficient (mostly O(log n) or better), but zipper flexibility+ -- is bought at the expense of keeping path information explicitly as a heap+ -- data structure rather than implicitly on the stack. Since heap storage+ -- probably costs more, zipper operations will are likely to incur higher+ -- constant factors than equivalent non-zipper operations (if available).+ --+ -- Some of the functions provided here may appear to be weird combinations of+ -- functions from a more logical set of primitives. They are provided because+ -- they are not really simple combinations of the corresponding primitives.+ -- They are more efficient, so you should use them if possible (e.g combining+ -- deleting with Zipper closing).+ --+ -- Also, consider using the t'BAVL' as a cheaper alternative if you don't+ -- need to navigate the tree.++ -- ** Types+ ZAVL,PAVL,++ -- ** Opening+ assertOpenL,assertOpenR,+ tryOpenL,tryOpenR,+ assertOpen,tryOpen,+ tryOpenGE,tryOpenLE,+ openEither,++ -- ** Closing+ close,fillClose,++ -- ** Manipulating the current element.+ getCurrent,putCurrent,applyCurrent,applyCurrent',++ -- ** Moving+ assertMoveL,assertMoveR,tryMoveL,tryMoveR,++ -- ** Inserting elements+ insertL,insertR,insertMoveL,insertMoveR,fill,++ -- ** Deleting elements+ delClose,+ assertDelMoveL,assertDelMoveR,tryDelMoveR,tryDelMoveL,+ delAllL,delAllR,+ delAllCloseL,delAllCloseR,+ delAllIncCloseL,delAllIncCloseR,++ -- ** Inserting AVL trees+ insertTreeL,insertTreeR,++ -- ** Current element status+ isLeftmost,isRightmost,+ sizeL,sizeR,++ -- ** Operations on whole zippers+ sizeZAVL,++ -- ** A cheaper option is to use BAVL+ -- | These are a cheaper but more restrictive alternative to using the full Zipper.+ -- They use \"Binary Paths\" (Ints) to point to a particular element of an 'AVL' tree.+ -- Use these when you don't need to navigate the tree, you just want to look at a+ -- particular element (and perhaps modify or delete it). The advantage of these is+ -- that they don't create the usual Zipper heap structure, so they will be faster+ -- (and reduce heap burn rate too).+ --+ -- If you subsequently decide you need a Zipper rather than a BAVL then some conversion+ -- utilities are provided.++ -- *** Types+ BAVL,++ -- *** Opening and closing+ openBAVL,closeBAVL,++ -- *** Inspecting status+ fullBAVL,emptyBAVL,tryReadBAVL,readFullBAVL,++ -- *** Modifying the tree+ pushBAVL,deleteBAVL,++ -- *** Converting to BAVL to Zipper+ -- | These are O(log n) operations but with low constant factors because no comparisons+ -- are required (and the tree nodes on the path will most likely still be in cache as+ -- a result of opening the BAVL in the first place).+ fullBAVLtoZAVL,emptyBAVLtoPAVL,anyBAVLtoEither,+) where++import Prelude -- so haddock finds the symbols there++import Data.Tree.AVL.Internals.Types(AVL(..))+import Data.Tree.AVL.Size(size,addSize)+import Data.Tree.AVL.Height(height,addHeight)+import Data.Tree.AVL.Internals.DelUtils(deletePath,popRN,popRZ,popRP,popLN,popLZ,popLP)+import Data.Tree.AVL.Internals.HJoin(spliceH,joinH)+import Data.Tree.AVL.Internals.HPush(pushHL,pushHR)+import Data.Tree.AVL.BinPath(BinPath(..),openPath,writePath,insertPath,sel,goL,goR)++import GHC.Base+#include "ghcdefs.h"++-- N.B. Zippers are always opened using relative heights for efficiency reasons. On the+-- whole this causes no problems, except when inserting entire AVL trees or substituting+-- the empty tree. (These cases have some minor height computation overhead).++-- | Abstract data type for a successfully opened AVL tree. All ZAVL\'s are non-empty!+-- A ZAVL can be tought of as a functional pointer to an AVL tree element.+data ZAVL e = ZAVL (Path e) (AVL e) !UINT e (AVL e) !UINT++-- | Abstract data type for an unsuccessfully opened AVL tree.+-- A PAVL can be thought of as a functional pointer to the gap+-- where the expected element should be (but isn't). You can fill this gap using+-- the 'fill' function, or fill and close at the same time using the 'fillClose' function.+data PAVL e = PAVL (Path e) !UINT++data Path e = EP -- Empty Path+ | LP (Path e) e (AVL e) !UINT -- Left subtree was taken+ | RP (Path e) e (AVL e) !UINT -- Right subtree was taken++-- Local Closing Utility+close_ :: Path e -> AVL e -> UINT -> AVL e+close_ EP t _ = t+close_ (LP p e r hr) l hl = case spliceH l hl e r hr of UBT2(t,ht) -> close_ p t ht+close_ (RP p e l hl) r hr = case spliceH l hl e r hr of UBT2(t,ht) -> close_ p t ht++-- Local Utility to remove all left paths from a path+noLP :: Path e -> Path e+noLP EP = EP+noLP (LP p _ _ _ ) = noLP p+noLP (RP p e l hl) = let p_ = noLP p in p_ `seq` RP p_ e l hl++-- Local Utility to remove all right paths from a path+noRP :: Path e -> Path e+noRP EP = EP+noRP (LP p e r hr) = let p_ = noRP p in p_ `seq` LP p_ e r hr+noRP (RP p _ _ _ ) = noRP p++-- Local Closing Utility which ignores all left paths+closeNoLP :: Path e -> AVL e -> UINT -> AVL e+closeNoLP EP t _ = t+closeNoLP (LP p _ _ _ ) l hl = closeNoLP p l hl+closeNoLP (RP p e l hl) r hr = case spliceH l hl e r hr of UBT2(t,ht) -> closeNoLP p t ht++-- Local Closing Utility which ignores all right paths+closeNoRP :: Path e -> AVL e -> UINT -> AVL e+closeNoRP EP t _ = t+closeNoRP (LP p e r hr) l hl = case spliceH l hl e r hr of UBT2(t,ht) -> closeNoRP p t ht+closeNoRP (RP p _ _ _ ) r hr = closeNoRP p r hr++-- Add size of all path elements.+addSizeP :: Int -> Path e -> Int+addSizeP n EP = n+addSizeP n (LP p _ r _) = addSizeP (addSize (n+1) r) p+addSizeP n (RP p _ l _) = addSizeP (addSize (n+1) l) p++-- Add size of all RP path elements.+addSizeRP :: Int -> Path e -> Int+addSizeRP n EP = n+addSizeRP n (LP p _ _ _) = addSizeRP n p+addSizeRP n (RP p _ l _) = addSizeRP (addSize (n+1) l) p++-- Add size of all LP path elements.+addSizeLP :: Int -> Path e -> Int+addSizeLP n EP = n+addSizeLP n (LP p _ r _) = addSizeLP (addSize (n+1) r) p+addSizeLP n (RP p _ _ _) = addSizeLP n p++-- | Opens a sorted AVL tree at the element given by the supplied selector. This function+-- raises an error if the tree does not contain such an element.+--+-- Complexity: O(log n)+assertOpen :: (e -> Ordering) -> AVL e -> ZAVL e+assertOpen c t = op EP L(0) t where -- Relative heights !!+ -- op :: (Path e) -> UINT -> AVL e -> ZAVL e+ op _ _ E = error "assertOpen: No matching element."+ op p h (N l e r) = case c e of+ LT -> let p_ = LP p e r DECINT1(h) in p_ `seq` op p_ DECINT2(h) l+ EQ -> ZAVL p l DECINT2(h) e r DECINT1(h)+ GT -> let p_ = RP p e l DECINT2(h) in p_ `seq` op p_ DECINT1(h) r+ op p h (Z l e r) = case c e of+ LT -> let p_ = LP p e r DECINT1(h) in p_ `seq` op p_ DECINT1(h) l+ EQ -> ZAVL p l DECINT1(h) e r DECINT1(h)+ GT -> let p_ = RP p e l DECINT1(h) in p_ `seq` op p_ DECINT1(h) r+ op p h (P l e r) = case c e of+ LT -> let p_ = LP p e r DECINT2(h) in p_ `seq` op p_ DECINT1(h) l+ EQ -> ZAVL p l DECINT1(h) e r DECINT2(h)+ GT -> let p_ = RP p e l DECINT1(h) in p_ `seq` op p_ DECINT2(h) r++-- | Attempts to open a sorted AVL tree at the element given by the supplied selector.+-- This function returns 'Nothing' if there is no such element.+--+-- Note that this operation will still create a zipper path structure on the heap (which+-- is promptly discarded) if the search fails, and so is potentially inefficient if failure+-- is likely. In cases like this it may be better to use 'openBAVL', test for \"fullness\"+-- using 'fullBAVL' and then convert to a t'ZAVL' using 'fullBAVLtoZAVL'.+--+-- Complexity: O(log n)+tryOpen :: (e -> Ordering) -> AVL e -> Maybe (ZAVL e)+tryOpen c t = op EP L(0) t where -- Relative heights !!+ -- op :: (Path e) -> UINT -> AVL e -> Maybe (ZAVL e)+ op _ _ E = Nothing+ op p h (N l e r) = case c e of+ LT -> let p_ = LP p e r DECINT1(h) in p_ `seq` op p_ DECINT2(h) l+ EQ -> Just $! ZAVL p l DECINT2(h) e r DECINT1(h)+ GT -> let p_ = RP p e l DECINT2(h) in p_ `seq` op p_ DECINT1(h) r+ op p h (Z l e r) = case c e of+ LT -> let p_ = LP p e r DECINT1(h) in p_ `seq` op p_ DECINT1(h) l+ EQ -> Just $! ZAVL p l DECINT1(h) e r DECINT1(h)+ GT -> let p_ = RP p e l DECINT1(h) in p_ `seq` op p_ DECINT1(h) r+ op p h (P l e r) = case c e of+ LT -> let p_ = LP p e r DECINT2(h) in p_ `seq` op p_ DECINT1(h) l+ EQ -> Just $! ZAVL p l DECINT1(h) e r DECINT2(h)+ GT -> let p_ = RP p e l DECINT1(h) in p_ `seq` op p_ DECINT2(h) r++-- | Attempts to open a sorted AVL tree at the least element which is greater than or equal, according to+-- the supplied selector. This function returns 'Nothing' if the tree does not contain such an element.+--+-- Complexity: O(log n)+tryOpenGE :: (e -> Ordering) -> AVL e -> Maybe (ZAVL e)+tryOpenGE c t = op EP L(0) t where -- Relative heights !!+ -- op :: (Path e) -> UINT -> AVL e -> ZAVL e+ op p h E = backupR p E h where+ backupR EP _ _ = Nothing+ backupR (LP p_ e r hr) l hl = Just $! ZAVL p_ l hl e r hr+ backupR (RP p_ e l hl) r hr = case spliceH l hl e r hr of UBT2(t_,ht_) -> backupR p_ t_ ht_+ op p h (N l e r) = case c e of+ LT -> let p_ = LP p e r DECINT1(h) in p_ `seq` op p_ DECINT2(h) l+ EQ -> Just $! ZAVL p l DECINT2(h) e r DECINT1(h)+ GT -> let p_ = RP p e l DECINT2(h) in p_ `seq` op p_ DECINT1(h) r+ op p h (Z l e r) = case c e of+ LT -> let p_ = LP p e r DECINT1(h) in p_ `seq` op p_ DECINT1(h) l+ EQ -> Just $! ZAVL p l DECINT1(h) e r DECINT1(h)+ GT -> let p_ = RP p e l DECINT1(h) in p_ `seq` op p_ DECINT1(h) r+ op p h (P l e r) = case c e of+ LT -> let p_ = LP p e r DECINT2(h) in p_ `seq` op p_ DECINT1(h) l+ EQ -> Just $! ZAVL p l DECINT1(h) e r DECINT2(h)+ GT -> let p_ = RP p e l DECINT1(h) in p_ `seq` op p_ DECINT2(h) r++-- | Attempts to open a sorted AVL tree at the greatest element which is less than or equal, according to+-- the supplied selector. This function returns _Nothing_ if the tree does not contain such an element.+--+-- Complexity: O(log n)+tryOpenLE :: (e -> Ordering) -> AVL e -> Maybe (ZAVL e)+tryOpenLE c t = op EP L(0) t where -- Relative heights !!+ -- op :: (Path e) -> UINT -> AVL e -> ZAVL e+ op p h E = backupL p E h where+ backupL EP _ _ = Nothing+ backupL (LP p_ e r hr) l hl = case spliceH l hl e r hr of UBT2(t_,ht_) -> backupL p_ t_ ht_+ backupL (RP p_ e l hl) r hr = Just $! ZAVL p_ l hl e r hr+ op p h (N l e r) = case c e of+ LT -> let p_ = LP p e r DECINT1(h) in p_ `seq` op p_ DECINT2(h) l+ EQ -> Just $! ZAVL p l DECINT2(h) e r DECINT1(h)+ GT -> let p_ = RP p e l DECINT2(h) in p_ `seq` op p_ DECINT1(h) r+ op p h (Z l e r) = case c e of+ LT -> let p_ = LP p e r DECINT1(h) in p_ `seq` op p_ DECINT1(h) l+ EQ -> Just $! ZAVL p l DECINT1(h) e r DECINT1(h)+ GT -> let p_ = RP p e l DECINT1(h) in p_ `seq` op p_ DECINT1(h) r+ op p h (P l e r) = case c e of+ LT -> let p_ = LP p e r DECINT2(h) in p_ `seq` op p_ DECINT1(h) l+ EQ -> Just $! ZAVL p l DECINT1(h) e r DECINT2(h)+ GT -> let p_ = RP p e l DECINT1(h) in p_ `seq` op p_ DECINT2(h) r++-- | Opens a non-empty AVL tree at the leftmost element.+-- This function raises an error if the tree is empty.+--+-- Complexity: O(log n)+assertOpenL :: AVL e -> ZAVL e+assertOpenL E = error "assertOpenL: Empty tree."+assertOpenL (N l e r) = openLN EP L(0) l e r -- Relative heights !!+assertOpenL (Z l e r) = openLZ EP L(0) l e r -- Relative heights !!+assertOpenL (P l e r) = openL_ (LP EP e r L(0)) L(1) l -- Relative heights !!++-- | Attempts to open a non-empty AVL tree at the leftmost element.+-- This function returns 'Nothing' if the tree is empty.+--+-- Complexity: O(log n)+tryOpenL :: AVL e -> Maybe (ZAVL e)+tryOpenL E = Nothing+tryOpenL (N l e r) = Just $! openLN EP L(0) l e r -- Relative heights !!+tryOpenL (Z l e r) = Just $! openLZ EP L(0) l e r -- Relative heights !!+tryOpenL (P l e r) = Just $! openL_ (LP EP e r L(0)) L(1) l -- Relative heights !!++-- Local utility for opening at the leftmost element, using current path and height.+openL_ :: (Path e) -> UINT -> AVL e -> ZAVL e+openL_ _ _ E = error "openL_: Bug0"+openL_ p h (N l e r) = openLN p h l e r+openL_ p h (Z l e r) = openLZ p h l e r+openL_ p h (P l e r) = let p_ = LP p e r DECINT2(h) in p_ `seq` openL_ p_ DECINT1(h) l++-- Open leftmost of (N l e r), where l may be E+openLN :: (Path e) -> UINT -> AVL e -> e -> AVL e -> ZAVL e+openLN p h E e r = ZAVL p E DECINT2(h) e r DECINT1(h)+openLN p h (N ll le lr) e r = let p_ = LP p e r DECINT1(h) in p_ `seq` openLN p_ DECINT2(h) ll le lr+openLN p h (Z ll le lr) e r = let p_ = LP p e r DECINT1(h) in p_ `seq` openLZ p_ DECINT2(h) ll le lr+openLN p h (P ll le lr) e r = let p_ = LP p e r DECINT1(h)+ p__ = p_ `seq` LP p_ le lr DECINT4(h)+ in p__ `seq` openL_ p__ DECINT3(h) ll+-- Open leftmost of (Z l e r), where l may be E+openLZ :: (Path e) -> UINT -> AVL e -> e -> AVL e -> ZAVL e+openLZ p h E e r = ZAVL p E DECINT1(h) e r DECINT1(h)+openLZ p h (N ll le lr) e r = let p_ = LP p e r DECINT1(h) in p_ `seq` openLN p_ DECINT1(h) ll le lr+openLZ p h (Z ll le lr) e r = let p_ = LP p e r DECINT1(h) in p_ `seq` openLZ p_ DECINT1(h) ll le lr+openLZ p h (P ll le lr) e r = let p_ = LP p e r DECINT1(h)+ p__ = p_ `seq` LP p_ le lr DECINT3(h)+ in p__ `seq` openL_ p__ DECINT2(h) ll++-- | Opens a non-empty AVL tree at the rightmost element.+-- This function raises an error if the tree is empty.+--+-- Complexity: O(log n)+assertOpenR :: AVL e -> ZAVL e+assertOpenR E = error "assertOpenR: Empty tree."+assertOpenR (N l e r) = openR_ (RP EP e l L(0)) L(1) r -- Relative heights !!+assertOpenR (Z l e r) = openRZ EP L(0) l e r -- Relative heights !!+assertOpenR (P l e r) = openRP EP L(0) l e r -- Relative heights !!++-- | Attempts to open a non-empty AVL tree at the rightmost element.+-- This function returns 'Nothing' if the tree is empty.+--+-- Complexity: O(log n)+tryOpenR :: AVL e -> Maybe (ZAVL e)+tryOpenR E = Nothing+tryOpenR (N l e r) = Just $! openR_ (RP EP e l L(0)) L(1) r -- Relative heights !!+tryOpenR (Z l e r) = Just $! openRZ EP L(0) l e r -- Relative heights !!+tryOpenR (P l e r) = Just $! openRP EP L(0) l e r -- Relative heights !!++-- Local utility for opening at the rightmost element, using current path and height.+openR_ :: (Path e) -> UINT -> AVL e -> ZAVL e+openR_ _ _ E = error "openR_: Bug0"+openR_ p h (N l e r) = let p_ = RP p e l DECINT2(h) in p_ `seq` openR_ p_ DECINT1(h) r+openR_ p h (Z l e r) = openRZ p h l e r+openR_ p h (P l e r) = openRP p h l e r+-- Open rightmost of (P l e r), where r may be E+openRP :: (Path e) -> UINT -> AVL e -> e -> AVL e -> ZAVL e+openRP p h l e E = ZAVL p l DECINT1(h) e E DECINT2(h)+openRP p h l e (N rl re rr) = let p_ = RP p e l DECINT1(h)+ p__ = p_ `seq` RP p_ re rl DECINT4(h)+ in p__ `seq` openR_ p__ DECINT3(h) rr+openRP p h l e (Z rl re rr) = let p_ = RP p e l DECINT1(h) in p_ `seq` openRZ p_ DECINT2(h) rl re rr+openRP p h l e (P rl re rr) = let p_ = RP p e l DECINT1(h) in p_ `seq` openRP p_ DECINT2(h) rl re rr+-- Open rightmost of (Z l e r), where r may be E+openRZ :: (Path e) -> UINT -> AVL e -> e -> AVL e -> ZAVL e+openRZ p h l e E = ZAVL p l DECINT1(h) e E DECINT1(h)+openRZ p h l e (N rl re rr) = let p_ = RP p e l DECINT1(h)+ p__ = p_ `seq` RP p_ re rl DECINT3(h)+ in p__ `seq` openR_ p__ DECINT2(h) rr+openRZ p h l e (Z rl re rr) = let p_ = RP p e l DECINT1(h) in p_ `seq` openRZ p_ DECINT1(h) rl re rr+openRZ p h l e (P rl re rr) = let p_ = RP p e l DECINT1(h) in p_ `seq` openRP p_ DECINT1(h) rl re rr++-- | Returns @('Right' zavl)@ if the expected element was found, @('Left' pavl)@ if the+-- expected element was not found. It's OK to use this function on empty trees.+--+-- Complexity: O(log n)+openEither :: (e -> Ordering) -> AVL e -> Either (PAVL e) (ZAVL e)+openEither c t = op EP L(0) t where -- Relative heights !!+ -- op :: (Path e) -> UINT -> AVL e -> Either (PAVL e) (ZAVL e)+ op p h E = Left $! PAVL p h+ op p h (N l e r) = case c e of+ LT -> let p_ = LP p e r DECINT1(h) in p_ `seq` op p_ DECINT2(h) l+ EQ -> Right $! ZAVL p l DECINT2(h) e r DECINT1(h)+ GT -> let p_ = RP p e l DECINT2(h) in p_ `seq` op p_ DECINT1(h) r+ op p h (Z l e r) = case c e of+ LT -> let p_ = LP p e r DECINT1(h) in p_ `seq` op p_ DECINT1(h) l+ EQ -> Right $! ZAVL p l DECINT1(h) e r DECINT1(h)+ GT -> let p_ = RP p e l DECINT1(h) in p_ `seq` op p_ DECINT1(h) r+ op p h (P l e r) = case c e of+ LT -> let p_ = LP p e r DECINT2(h) in p_ `seq` op p_ DECINT1(h) l+ EQ -> Right $! ZAVL p l DECINT1(h) e r DECINT2(h)+ GT -> let p_ = RP p e l DECINT1(h) in p_ `seq` op p_ DECINT2(h) r++-- | Fill the gap pointed to by a t'PAVL' with the supplied element, which becomes+-- the current element of the resulting t'ZAVL'. The supplied filling element should+-- be \"equal\" to the value used in the search which created the t'PAVL'.+--+-- Complexity: O(1)+fill :: e -> PAVL e -> ZAVL e+fill e (PAVL p h) = ZAVL p E h e E h++-- | Essentially the same operation as 'fill', but the resulting t'ZAVL' is closed+-- immediately.+--+-- Complexity: O(log n)+fillClose :: e -> PAVL e -> AVL e+fillClose e (PAVL p h) = close_ p (Z E e E) INCINT1(h)++-- | Closes a Zipper.+--+-- Complexity: O(log n)+close :: ZAVL e -> AVL e+close (ZAVL p l hl e r hr) = case spliceH l hl e r hr of UBT2(t,ht) -> close_ p t ht++-- | Deletes the current element and then closes the Zipper.+--+-- Complexity: O(log n)+delClose :: ZAVL e -> AVL e+delClose (ZAVL p l hl _ r hr) = case joinH l hl r hr of UBT2(t,ht) -> close_ p t ht++-- | Gets the current element of a Zipper.+--+-- Complexity: O(1)+getCurrent :: ZAVL e -> e+getCurrent (ZAVL _ _ _ e _ _) = e++-- | Overwrites the current element of a Zipper.+--+-- Complexity: O(1)+putCurrent :: e -> ZAVL e -> ZAVL e+putCurrent e (ZAVL p l hl _ r hr) = ZAVL p l hl e r hr++-- | Applies a function to the current element of a Zipper (lazily).+-- See also 'applyCurrent'' for a strict version of this function.+--+-- Complexity: O(1)+applyCurrent :: (e -> e) -> ZAVL e -> ZAVL e+applyCurrent f (ZAVL p l hl e r hr) = ZAVL p l hl (f e) r hr++-- | Applies a function to the current element of a Zipper strictly.+-- See also 'applyCurrent' for a non-strict version of this function.+--+-- Complexity: O(1)+applyCurrent' :: (e -> e) -> ZAVL e -> ZAVL e+applyCurrent' f (ZAVL p l hl e r hr) = let e_ = f e in e_ `seq` ZAVL p l hl e_ r hr++-- | Moves one step left.+-- This function raises an error if the current element is already the leftmost element.+--+-- Complexity: O(1) average, O(log n) worst case.+assertMoveL :: ZAVL e -> ZAVL e+assertMoveL (ZAVL p E _ e r hr) = case pushHL e r hr of UBT2(t,ht) -> cR p t ht+ where cR EP _ _ = error "assertMoveL: Can't move left."+ cR (LP p_ e_ r_ hr_) l_ hl_ = case spliceH l_ hl_ e_ r_ hr_ of UBT2(t,ht) -> cR p_ t ht+ cR (RP p_ e_ l_ hl_) r_ hr_ = ZAVL p_ l_ hl_ e_ r_ hr_+assertMoveL (ZAVL p (N ll le lr) hl e r hr) = let p_ = RP (LP p e r hr) le ll DECINT2(hl)+ in p_ `seq` openR_ p_ DECINT1(hl) lr+assertMoveL (ZAVL p (Z ll le lr) hl e r hr) = openRZ (LP p e r hr) hl ll le lr+assertMoveL (ZAVL p (P ll le lr) hl e r hr) = openRP (LP p e r hr) hl ll le lr++-- | Attempts to move one step left.+-- This function returns 'Nothing' if the current element is already the leftmost element.+--+-- Complexity: O(1) average, O(log n) worst case.+tryMoveL :: ZAVL e -> Maybe (ZAVL e)+tryMoveL (ZAVL p E _ e r hr) = case pushHL e r hr of UBT2(t,ht) -> cR p t ht+ where cR EP _ _ = Nothing+ cR (LP p_ e_ r_ hr_) l_ hl_ = case spliceH l_ hl_ e_ r_ hr_ of UBT2(t,ht) -> cR p_ t ht+ cR (RP p_ e_ l_ hl_) r_ hr_ = Just $! ZAVL p_ l_ hl_ e_ r_ hr_+tryMoveL (ZAVL p (N ll le lr) hl e r hr) = Just $! let p_ = RP (LP p e r hr) le ll DECINT2(hl)+ in p_ `seq` openR_ p_ DECINT1(hl) lr+tryMoveL (ZAVL p (Z ll le lr) hl e r hr) = Just $! openRZ (LP p e r hr) hl ll le lr+tryMoveL (ZAVL p (P ll le lr) hl e r hr) = Just $! openRP (LP p e r hr) hl ll le lr++-- | Moves one step right.+-- This function raises an error if the current element is already the rightmost element.+--+-- Complexity: O(1) average, O(log n) worst case.+assertMoveR :: ZAVL e -> ZAVL e+assertMoveR (ZAVL p l hl e E _ ) = case pushHR l hl e of UBT2(t,ht) -> cL p t ht+ where cL EP _ _ = error "assertMoveR: Can't move right."+ cL (RP p_ e_ l_ hl_) r_ hr_ = case spliceH l_ hl_ e_ r_ hr_ of UBT2(t,ht) -> cL p_ t ht+ cL (LP p_ e_ r_ hr_) l_ hl_ = ZAVL p_ l_ hl_ e_ r_ hr_+assertMoveR (ZAVL p l hl e (N rl re rr) hr) = openLN (RP p e l hl) hr rl re rr+assertMoveR (ZAVL p l hl e (Z rl re rr) hr) = openLZ (RP p e l hl) hr rl re rr+assertMoveR (ZAVL p l hl e (P rl re rr) hr) = let p_ = LP (RP p e l hl) re rr DECINT2(hr)+ in p_ `seq` openL_ p_ DECINT1(hr) rl++-- | Attempts to move one step right.+-- This function returns 'Nothing' if the current element is already the rightmost element.+--+-- Complexity: O(1) average, O(log n) worst case.+tryMoveR :: ZAVL e -> Maybe (ZAVL e)+tryMoveR (ZAVL p l hl e E _ ) = case pushHR l hl e of UBT2(t,ht) -> cL p t ht+ where cL EP _ _ = Nothing+ cL (RP p_ e_ l_ hl_) r_ hr_ = case spliceH l_ hl_ e_ r_ hr_ of UBT2(t,ht) -> cL p_ t ht+ cL (LP p_ e_ r_ hr_) l_ hl_ = Just $! ZAVL p_ l_ hl_ e_ r_ hr_+tryMoveR (ZAVL p l hl e (N rl re rr) hr) = Just $! openLN (RP p e l hl) hr rl re rr+tryMoveR (ZAVL p l hl e (Z rl re rr) hr) = Just $! openLZ (RP p e l hl) hr rl re rr+tryMoveR (ZAVL p l hl e (P rl re rr) hr) = Just $! let p_ = LP (RP p e l hl) re rr DECINT2(hr)+ in p_ `seq` openL_ p_ DECINT1(hr) rl++-- | Returns 'True' if the current element is the leftmost element.+--+-- Complexity: O(1) average, O(log n) worst case.+isLeftmost :: ZAVL e -> Bool+isLeftmost (ZAVL p E _ _ _ _) = iL p+ where iL EP = True+ iL (LP p_ _ _ _) = iL p_+ iL (RP _ _ _ _) = False+isLeftmost (ZAVL _ _ _ _ _ _) = False++-- | Returns 'True' if the current element is the rightmost element.+--+-- Complexity: O(1) average, O(log n) worst case.+isRightmost :: ZAVL e -> Bool+isRightmost (ZAVL p _ _ _ E _) = iR p+ where iR EP = True+ iR (RP p_ _ _ _) = iR p_+ iR (LP _ _ _ _) = False+isRightmost (ZAVL _ _ _ _ _ _) = False++-- | Inserts a new element to the immediate left of the current element.+--+-- Complexity: O(1) average, O(log n) worst case.+insertL :: e -> ZAVL e -> ZAVL e+insertL e0 (ZAVL p l hl e1 r hr) = case pushHR l hl e0 of UBT2(l_,hl_) -> ZAVL p l_ hl_ e1 r hr++-- | Inserts a new element to the immediate left of the current element and then+-- moves one step left (so the newly inserted element becomes the current element).+--+-- Complexity: O(1) average, O(log n) worst case.+insertMoveL :: e -> ZAVL e -> ZAVL e+insertMoveL e0 (ZAVL p l hl e1 r hr) = case pushHL e1 r hr of UBT2(r_,hr_) -> ZAVL p l hl e0 r_ hr_++-- | Inserts a new element to the immediate right of the current element.+--+-- Complexity: O(1) average, O(log n) worst case.+insertR :: ZAVL e -> e -> ZAVL e+insertR (ZAVL p l hl e0 r hr) e1 = case pushHL e1 r hr of UBT2(r_,hr_) -> ZAVL p l hl e0 r_ hr_++-- | Inserts a new element to the immediate right of the current element and then+-- moves one step right (so the newly inserted element becomes the current element).+--+-- Complexity: O(1) average, O(log n) worst case.+insertMoveR :: ZAVL e -> e -> ZAVL e+insertMoveR (ZAVL p l hl e0 r hr) e1 = case pushHR l hl e0 of UBT2(l_,hl_) -> ZAVL p l_ hl_ e1 r hr++-- | Inserts a new AVL tree to the immediate left of the current element.+--+-- Complexity: O(log n), where n is the size of the inserted tree.+insertTreeL :: AVL e -> ZAVL e -> ZAVL e+insertTreeL E zavl = zavl+insertTreeL t@(N l _ _) zavl = insertLH t (addHeight L(2) l) zavl -- Absolute height required!!+insertTreeL t@(Z l _ _) zavl = insertLH t (addHeight L(1) l) zavl -- Absolute height required!!+insertTreeL t@(P _ _ r) zavl = insertLH t (addHeight L(2) r) zavl -- Absolute height required!!+++-- Local utility to insert an AVL to the immediate left of the current element.+-- This operation carries a minor overhead in that we must convert the absolute+-- AVL height into a relative height with the same offset as the rest of the ZAVL.+-- This requires calculation of the absolute height at the current position, but+-- this should be relatively cheap because the overwhelming majority of elements will+-- be close to the bottom of any tree.+insertLH :: AVL e -> UINT -> ZAVL e -> ZAVL e+insertLH t ht (ZAVL p l hl e r hr) =+ let offset = case COMPAREUINT hl hr of -- chose smaller sub-tree to calculate absolute height+ LT -> SUBINT(hl,height l)+ EQ -> SUBINT(hl,height l)+ GT -> SUBINT(hr,height r)+ in case joinH l hl t ADDINT(ht,offset) of UBT2(l_,hl_) -> ZAVL p l_ hl_ e r hr++-- | Inserts a new AVL tree to the immediate right of the current element.+--+-- Complexity: O(log n), where n is the size of the inserted tree.+insertTreeR :: ZAVL e -> AVL e -> ZAVL e+insertTreeR zavl E = zavl+insertTreeR zavl t@(N l _ _) = insertRH t (addHeight L(2) l) zavl -- Absolute height required!!+insertTreeR zavl t@(Z l _ _) = insertRH t (addHeight L(1) l) zavl -- Absolute height required!!+insertTreeR zavl t@(P _ _ r) = insertRH t (addHeight L(2) r) zavl -- Absolute height required!!++-- Local utility to insert an AVL to the immediate right of the current element.+-- This operation carries a minor overhead in that we must convert the absolute+-- AVL height into a relative height with the same offset as the rest of the ZAVL.+-- This requires calculation of the absolute height at the current position, but+-- this should be relatively cheap because the overwhelming majority of elements will+-- be close to the bottom of any tree.+insertRH :: AVL e -> UINT -> ZAVL e -> ZAVL e+insertRH t ht (ZAVL p l hl e r hr) =+ let offset = case COMPAREUINT hl hr of -- chose smaller sub-tree to calculate absolute height+ LT -> SUBINT(hl,height l)+ EQ -> SUBINT(hr,height r)+ GT -> SUBINT(hr,height r)+ in case joinH t ADDINT(ht,offset) r hr of UBT2(r_,hr_) -> ZAVL p l hl e r_ hr_+++-- | Deletes the current element and moves one step left.+-- This function raises an error if the current element is already the leftmost element.+--+-- Complexity: O(1) average, O(log n) worst case.+assertDelMoveL :: ZAVL e -> ZAVL e+assertDelMoveL (ZAVL p E _ _ r hr) = dR p r hr+ where dR EP _ _ = error "assertDelMoveL: Can't move left."+ dR (LP p_ e_ r_ hr_) l_ hl_ = case spliceH l_ hl_ e_ r_ hr_ of UBT2(t,ht) -> dR p_ t ht+ dR (RP p_ e_ l_ hl_) r_ hr_ = ZAVL p_ l_ hl_ e_ r_ hr_+assertDelMoveL (ZAVL p (N ll le lr) hl _ r hr) = case popRN ll le lr of+ UBT2(l,e) -> case l of+ Z _ _ _ -> ZAVL p l DECINT1(hl) e r hr+ N _ _ _ -> ZAVL p l hl e r hr+ _ -> error "assertDelMoveL: Bug0" -- impossible+assertDelMoveL (ZAVL p (Z ll le lr) hl _ r hr) = case popRZ ll le lr of+ UBT2(l,e) -> case l of+ E -> ZAVL p l DECINT1(hl) e r hr -- Don't use E!!+ N _ _ _ -> error "assertDelMoveL: Bug1" -- impossible+ _ -> ZAVL p l hl e r hr+assertDelMoveL (ZAVL p (P ll le lr) hl _ r hr) = case popRP ll le lr of+ UBT2(l,e) -> case l of+ E -> error "assertDelMoveL: Bug2" -- impossible+ Z _ _ _ -> ZAVL p l DECINT1(hl) e r hr+ _ -> ZAVL p l hl e r hr+++-- | Attempts to delete the current element and move one step left.+-- This function returns 'Nothing' if the current element is already the leftmost element.+--+-- Complexity: O(1) average, O(log n) worst case.+tryDelMoveL :: ZAVL e -> Maybe (ZAVL e)+tryDelMoveL (ZAVL p E _ _ r hr) = dR p r hr+ where dR EP _ _ = Nothing+ dR (LP p_ e_ r_ hr_) l_ hl_ = case spliceH l_ hl_ e_ r_ hr_ of UBT2(t,ht) -> dR p_ t ht+ dR (RP p_ e_ l_ hl_) r_ hr_ = Just $! ZAVL p_ l_ hl_ e_ r_ hr_+tryDelMoveL (ZAVL p (N ll le lr) hl _ r hr) = Just $! case popRN ll le lr of+ UBT2(l,e) -> case l of+ Z _ _ _ -> ZAVL p l DECINT1(hl) e r hr+ N _ _ _ -> ZAVL p l hl e r hr+ _ -> error "tryDelMoveL: Bug0" -- impossible+tryDelMoveL (ZAVL p (Z ll le lr) hl _ r hr) = Just $! case popRZ ll le lr of+ UBT2(l,e) -> case l of+ E -> ZAVL p l DECINT1(hl) e r hr -- Don't use E!!+ N _ _ _ -> error "tryDelMoveL: Bug1" -- impossible+ _ -> ZAVL p l hl e r hr+tryDelMoveL (ZAVL p (P ll le lr) hl _ r hr) = Just $! case popRP ll le lr of+ UBT2(l,e) -> case l of+ E -> error "tryDelMoveL: Bug2" -- impossible+ Z _ _ _ -> ZAVL p l DECINT1(hl) e r hr+ _ -> ZAVL p l hl e r hr+++-- | Deletes the current element and moves one step right.+-- This function raises an error if the current element is already the rightmost element.+--+-- Complexity: O(1) average, O(log n) worst case.+assertDelMoveR :: ZAVL e -> ZAVL e+assertDelMoveR (ZAVL p l hl _ E _ ) = dL p l hl+ where dL EP _ _ = error "delMoveR: Can't move right."+ dL (LP p_ e_ r_ hr_) l_ hl_ = ZAVL p_ l_ hl_ e_ r_ hr_+ dL (RP p_ e_ l_ hl_) r_ hr_ = case spliceH l_ hl_ e_ r_ hr_ of UBT2(t,ht) -> dL p_ t ht+assertDelMoveR (ZAVL p l hl _ (N rl re rr) hr) = case popLN rl re rr of+ UBT2(e,r) -> case r of+ E -> error "delMoveR: Bug0" -- impossible+ Z _ _ _ -> ZAVL p l hl e r DECINT1(hr)+ _ -> ZAVL p l hl e r hr+assertDelMoveR (ZAVL p l hl _ (Z rl re rr) hr) = case popLZ rl re rr of+ UBT2(e,r) -> case r of+ E -> ZAVL p l hl e r DECINT1(hr) -- Don't use E!!+ P _ _ _ -> error "delMoveR: Bug1" -- impossible+ _ -> ZAVL p l hl e r hr+assertDelMoveR (ZAVL p l hl _ (P rl re rr) hr) = case popLP rl re rr of+ UBT2(e,r) -> case r of+ Z _ _ _ -> ZAVL p l hl e r DECINT1(hr)+ P _ _ _ -> ZAVL p l hl e r hr+ _ -> error "delMoveR: Bug2" -- impossible+++-- | Attempts to delete the current element and move one step right.+-- This function returns 'Nothing' if the current element is already the rightmost element.+--+-- Complexity: O(1) average, O(log n) worst case.+tryDelMoveR :: ZAVL e -> Maybe (ZAVL e)+tryDelMoveR (ZAVL p l hl _ E _ ) = dL p l hl+ where dL EP _ _ = Nothing+ dL (LP p_ e_ r_ hr_) l_ hl_ = Just $! ZAVL p_ l_ hl_ e_ r_ hr_+ dL (RP p_ e_ l_ hl_) r_ hr_ = case spliceH l_ hl_ e_ r_ hr_ of UBT2(t,ht) -> dL p_ t ht+tryDelMoveR (ZAVL p l hl _ (N rl re rr) hr) = Just $! case popLN rl re rr of+ UBT2(e,r) -> case r of+ E -> error "tryDelMoveR: Bug0" -- impossible+ Z _ _ _ -> ZAVL p l hl e r DECINT1(hr)+ _ -> ZAVL p l hl e r hr+tryDelMoveR (ZAVL p l hl _ (Z rl re rr) hr) = Just $! case popLZ rl re rr of+ UBT2(e,r) -> case r of+ E -> ZAVL p l hl e r DECINT1(hr) -- Don't use E!!+ P _ _ _ -> error "tryDelMoveR: Bug1" -- impossible+ _ -> ZAVL p l hl e r hr+tryDelMoveR (ZAVL p l hl _ (P rl re rr) hr) = Just $! case popLP rl re rr of+ UBT2(e,r) -> case r of+ Z _ _ _ -> ZAVL p l hl e r DECINT1(hr)+ P _ _ _ -> ZAVL p l hl e r hr+ _ -> error "tryDelMoveR: Bug2" -- impossible+++-- | Delete all elements to the left of the current element.+--+-- Complexity: O(log n)+delAllL :: ZAVL e -> ZAVL e+delAllL (ZAVL p l hl e r hr) =+ let hE = case COMPAREUINT hl hr of -- Calculate relative offset and use this as height of empty tree+ LT -> SUBINT(hl,height l)+ EQ -> SUBINT(hr,height r)+ GT -> SUBINT(hr,height r)+ p_ = noRP p -- remove right paths (current element becomes leftmost)+ in p_ `seq` ZAVL p_ E hE e r hr++-- | Delete all elements to the right of the current element.+--+-- Complexity: O(log n)+delAllR :: ZAVL e -> ZAVL e+delAllR (ZAVL p l hl e r hr) =+ let hE = case COMPAREUINT hl hr of -- Calculate relative offset and use this as height of empty tree+ LT -> SUBINT(hl,height l)+ EQ -> SUBINT(hl,height l)+ GT -> SUBINT(hr,height r)+ p_ = noLP p -- remove left paths (current element becomes rightmost)+ in p_ `seq` ZAVL p_ l hl e E hE++-- | Similar to 'delAllL', in that all elements to the left of the current element are deleted,+-- but this function also closes the tree in the process.+--+-- Complexity: O(log n)+delAllCloseL :: ZAVL e -> AVL e+delAllCloseL (ZAVL p _ _ e r hr) = case pushHL e r hr of UBT2(t,ht) -> closeNoRP p t ht++-- | Similar to 'delAllR', in that all elements to the right of the current element are deleted,+-- but this function also closes the tree in the process.+--+-- Complexity: O(log n)+delAllCloseR :: ZAVL e -> AVL e+delAllCloseR (ZAVL p l hl e _ _) = case pushHR l hl e of UBT2(t,ht) -> closeNoLP p t ht++-- | Similar to 'delAllCloseL', but in this case the current element and all+-- those to the left of the current element are deleted.+--+-- Complexity: O(log n)+delAllIncCloseL :: ZAVL e -> AVL e+delAllIncCloseL (ZAVL p _ _ _ r hr) = closeNoRP p r hr++-- | Similar to 'delAllCloseR', but in this case the current element and all+-- those to the right of the current element are deleted.+--+-- Complexity: O(log n)+delAllIncCloseR :: ZAVL e -> AVL e+delAllIncCloseR (ZAVL p l hl _ _ _) = closeNoLP p l hl++-- | Counts the number of elements to the left of the current element+-- (this does not include the current element).+--+-- Complexity: O(n), where n is the count result.+sizeL :: ZAVL e -> Int+sizeL (ZAVL p l _ _ _ _) = addSizeRP (size l) p++-- | Counts the number of elements to the right of the current element+-- (this does not include the current element).+--+-- Complexity: O(n), where n is the count result.+sizeR :: ZAVL e -> Int+sizeR (ZAVL p _ _ _ r _) = addSizeLP (size r) p++-- | Counts the total number of elements in a ZAVL.+--+-- Complexity: O(n)+sizeZAVL :: ZAVL e -> Int+sizeZAVL (ZAVL p l _ _ r _) = addSizeP (addSize (addSize 1 l) r) p+++{-------------------- BAVL stuff below ----------------------------------}++-- | A t'BAVL' is like a pointer reference to somewhere inside an 'AVL' tree. It may be either \"full\"+-- (meaning it points to an actual tree node containing an element), or \"empty\" (meaning it+-- points to the position in a tree where an element was expected but wasn\'t found).+data BAVL e = BAVL (AVL e) (BinPath e)++-- | Search for an element in a /sorted/ 'AVL' tree using the supplied selector.+-- Returns a \"full\" t'BAVL' if a matching element was found,+-- otherwise returns an \"empty\" t'BAVL'.+--+-- Complexity: O(log n)+openBAVL :: (e -> Ordering) -> AVL e -> BAVL e+{-# INLINE openBAVL #-}+openBAVL c t = bp `seq` BAVL t bp+ where bp = openPath c t++-- | Returns the original tree, extracted from the t'BAVL'.+-- Typically you will not need this, as+-- the original tree will still be in scope in most cases.+--+-- Complexity: O(1)+closeBAVL :: BAVL e -> AVL e+{-# INLINE closeBAVL #-}+closeBAVL (BAVL t _) = t++-- | Returns 'True' if the t'BAVL' is \"full\" (a corresponding element was found).+--+-- Complexity: O(1)+fullBAVL :: BAVL e -> Bool+{-# INLINE fullBAVL #-}+fullBAVL (BAVL _ (FullBP _ _)) = True+fullBAVL (BAVL _ (EmptyBP _ )) = False++-- | Returns 'True' if the t'BAVL' is \"empty\" (no corresponding element was found).+--+-- Complexity: O(1)+emptyBAVL :: BAVL e -> Bool+{-# INLINE emptyBAVL #-}+emptyBAVL (BAVL _ (FullBP _ _)) = False+emptyBAVL (BAVL _ (EmptyBP _ )) = True++-- | Read the element value from a \"full\" t'BAVL'.+-- This function returns 'Nothing' if applied to an \"empty\" t'BAVL'.+--+-- Complexity: O(1)+tryReadBAVL :: BAVL e -> Maybe e+{-# INLINE tryReadBAVL #-}+tryReadBAVL (BAVL _ (FullBP _ e)) = Just e+tryReadBAVL (BAVL _ (EmptyBP _ )) = Nothing++-- | Read the element value from a \"full\" t'BAVL'.+-- This function raises an error if applied to an \"empty\" t'BAVL'.+--+-- Complexity: O(1)+readFullBAVL :: BAVL e -> e+{-# INLINE readFullBAVL #-}+readFullBAVL (BAVL _ (FullBP _ e)) = e+readFullBAVL (BAVL _ (EmptyBP _ )) = error "readFullBAVL: Empty BAVL."++-- | If the t'BAVL' is \"full\", this function returns the original tree with the corresponding+-- element replaced by the new element (first argument). If it\'s \"empty\" the original tree is returned+-- with the new element inserted.+--+-- Complexity: O(log n)+pushBAVL :: e -> BAVL e -> AVL e+{-# INLINE pushBAVL #-}+pushBAVL e (BAVL t (FullBP p _)) = writePath p e t+pushBAVL e (BAVL t (EmptyBP p )) = insertPath p e t++-- | If the t'BAVL' is \"full\", this function returns the original tree with the corresponding+-- element deleted. If it\'s \"empty\" the original tree is returned unmodified.+--+-- Complexity: O(log n) (or O(1) for an empty t'BAVL')+deleteBAVL :: BAVL e -> AVL e+{-# INLINE deleteBAVL #-}+deleteBAVL (BAVL t (FullBP p _)) = deletePath p t+deleteBAVL (BAVL t (EmptyBP _ )) = t++-- | Converts a \"full\" t'BAVL' as a t'ZAVL'.+-- Raises an error if applied to an \"empty\" t'BAVL'.+--+-- Complexity: O(log n)+fullBAVLtoZAVL :: BAVL e -> ZAVL e+fullBAVLtoZAVL (BAVL t (FullBP i _)) = openFull i EP L(0) t -- Relative heights !!+fullBAVLtoZAVL (BAVL _ (EmptyBP _ )) = error "fullBAVLtoZAVL: Empty BAVL."+-- Local Utility+openFull :: UINT -> (Path e) -> UINT -> AVL e -> ZAVL e+openFull _ _ _ E = error "openFull: Bug0."+openFull i p h (N l e r) = case sel i of+ LT -> let p_ = LP p e r DECINT1(h) in p_ `seq` openFull (goL i) p_ DECINT2(h) l+ EQ -> ZAVL p l DECINT2(h) e r DECINT1(h)+ GT -> let p_ = RP p e l DECINT2(h) in p_ `seq` openFull (goR i) p_ DECINT1(h) r+openFull i p h (Z l e r) = case sel i of+ LT -> let p_ = LP p e r DECINT1(h) in p_ `seq` openFull (goL i) p_ DECINT1(h) l+ EQ -> ZAVL p l DECINT1(h) e r DECINT1(h)+ GT -> let p_ = RP p e l DECINT1(h) in p_ `seq` openFull (goR i) p_ DECINT1(h) r+openFull i p h (P l e r) = case sel i of+ LT -> let p_ = LP p e r DECINT2(h) in p_ `seq` openFull (goL i) p_ DECINT1(h) l+ EQ -> ZAVL p l DECINT1(h) e r DECINT2(h)+ GT -> let p_ = RP p e l DECINT1(h) in p_ `seq` openFull (goR i) p_ DECINT2(h) r++-- | Converts an \"empty\" t'BAVL' as a t'PAVL'.+-- Raises an error if applied to a \"full\" t'BAVL'.+--+-- Complexity: O(log n)+emptyBAVLtoPAVL :: BAVL e -> PAVL e+emptyBAVLtoPAVL (BAVL _ (FullBP _ _)) = error "emptyBAVLtoPAVL: Full BAVL."+emptyBAVLtoPAVL (BAVL t (EmptyBP i )) = openEmpty i EP L(0) t -- Relative heights !!+-- Local Utility+openEmpty :: UINT -> (Path e) -> UINT -> AVL e -> PAVL e+openEmpty _ p h E = PAVL p h -- Test for i==0 ??+openEmpty i p h (N l e r) = case sel i of+ LT -> let p_ = LP p e r DECINT1(h) in p_ `seq` openEmpty (goL i) p_ DECINT2(h) l+ EQ -> error "openEmpty: Bug0"+ GT -> let p_ = RP p e l DECINT2(h) in p_ `seq` openEmpty (goR i) p_ DECINT1(h) r+openEmpty i p h (Z l e r) = case sel i of+ LT -> let p_ = LP p e r DECINT1(h) in p_ `seq` openEmpty (goL i) p_ DECINT1(h) l+ EQ -> error "openEmpty: Bug1"+ GT -> let p_ = RP p e l DECINT1(h) in p_ `seq` openEmpty (goR i) p_ DECINT1(h) r+openEmpty i p h (P l e r) = case sel i of+ LT -> let p_ = LP p e r DECINT2(h) in p_ `seq` openEmpty (goL i) p_ DECINT1(h) l+ EQ -> error "openEmpty: Bug2"+ GT -> let p_ = RP p e l DECINT1(h) in p_ `seq` openEmpty (goR i) p_ DECINT2(h) r+++-- | Converts a t'BAVL' to either a t'PAVL' or t'ZAVL'+-- (depending on whether it is \"empty\" or \"full\").+--+-- Complexity: O(log n)+anyBAVLtoEither :: BAVL e -> Either (PAVL e) (ZAVL e)+anyBAVLtoEither (BAVL t (FullBP i _)) = Right (openFull i EP L(0) t) -- Relative heights !!+anyBAVLtoEither (BAVL t (EmptyBP i )) = Left (openEmpty i EP L(0) t) -- Relative heights !!
+ tests/AllTests.hs view
@@ -0,0 +1,1409 @@+-- |+-- Copyright : (c) Adrian Hey 2004,2005,2006,2007+-- License : BSD3+--+-- This module contains a large set of fairly comprehensive but extremely+-- time consuming tests of AVL tree functions (not based on QuickCheck).+--++{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}+{-# OPTIONS_GHC -Wno-unbanged-strict-patterns #-}++module Main+(main+) where++import Prelude ((+), (*), (-), odd, even, mod)+import Data.Bool (Bool(..), (&&), (||), not)+import Text.Read (read)+import Data.Function (($), (.), flip)+import Text.Show (show)+import Data.Eq ((==), (/=))+import Data.Foldable (length, all, and, any, or, concatMap, null, concat)+import Data.List ((++), take, zipWith, iterate, dropWhile, takeWhile, span, drop)+import Control.Monad ((>>))+import Data.Either (Either(..))+import Data.String (String)+import Data.Maybe (Maybe(..))+import System.IO (IO, putStrLn)+import Data.Ord (Ordering(..), compare, (>=), (<=), max, min, (<))+import Data.COrdering+import Data.Tree.AVL+import qualified Data.List as L (replicate,reverse,filter,foldr1,foldl1,map,insert,mapAccumL,mapAccumR)+import System.Exit(exitFailure)++import Data.Tree.AVL.Internals.Types (AVL(..))+-- import Data.Tree.AVL.Internals.HAVL (HAVL(..), toHAVL, joinHAVL)+import Utils (exhaustiveTest, pathTree, allAVL, allNonEmptyAVL, checkHeight)++import GHC.Base(Int(..))+#include "ghcdefs.h"++-- | Run every test in this module (takes a very long time).+main :: IO ()+main =+ do testReadPath+ testIsBalanced+ testIsSorted+ testSize+ testClipSize+ testWrite+ testPush+ testPushL+ testPushR+ testDelete+ testAssertDelL+ testAssertDelR+ testAssertPopL+ -- testPopHL+ testAssertPopR+ testAssertPop+ testFlatten+ testJoin+ -- testJoinHAVL+ testConcatAVL+ testFlatConcat+ testFoldr+ testFoldr'+ testFoldl+ testFoldl'+ testFoldr1+ testFoldr1'+ testFoldl1+ testFoldl1'+ testMapAccumL+ testMapAccumR+ testMapAccumL'+ testMapAccumR'+ testMapAccumL''+ testMapAccumR''+ testSplitAtL+ testFilterViaList+ testFilter+ testMapMaybeViaList+ testMapMaybe+ testTakeL+ testDropL+ testSplitAtR+ testTakeR+ testDropR+ testSpanL+ testTakeWhileL+ testDropWhileL+ testSpanR+ testTakeWhileR+ testDropWhileR+ testRotateL+ testRotateR+ testRotateByL+ testRotateByR+ testForkL+ testForkR+ testFork+ testTakeLE+ testTakeGT+ testTakeGE+ testTakeLT+ testUnion+ testDisjointUnion+ testUnionMaybe+ testIntersection+ testIntersectionMaybe+ testIntersectionAsList+ testIntersectionMaybeAsList+ testDifference+ testDifferenceMaybe+ testSymDifference+ testIsSubsetOf+ testIsSubsetOfBy+ testVenn+ testVennMaybe+ testCompareHeight+ testShowReadEq+-- Zipper tests+ testOpenClose+ testDelClose+ testOpenLClose+ testOpenRClose+ testMoveL+ testMoveR+ testInsertL+ testInsertMoveL+ testInsertR+ testInsertMoveR+ testInsertTreeL+ testInsertTreeR+ testDelMoveL+ testDelMoveR+ testDelAllL+ testDelAllR+ testDelAllCloseL+ testDelAllIncCloseL+ testDelAllCloseR+ testDelAllIncCloseR+ testZipSize+ testTryOpenLE+ testTryOpenGE+ testOpenEither+ testBAVLtoZipper+++-- | Test isBalanced is capable of failing for a few non-AVL trees.+testIsBalanced :: IO ()+testIsBalanced = do title "isBalanced"+ if or [isBalanced t | t <- nonAVLs] then failed else passed+ where nonAVLs :: [AVL Int]+ nonAVLs = [Z E 0 (Z E 0 E)+ ,Z (Z E 0 E) 0 E+ ,N E 0 E+ ,P E 0 E+ ]++-- | Test isSorted is capable of failing for a few non-sorted trees.+testIsSorted :: IO ()+testIsSorted = do title "isSorted"+ if or [isSorted compare (asTreeL l) | l <- nonSorted] then failed else passed+ where nonSorted = ["AA","BA"+ ,"AAA","ABA","ABB","AAB"+ ,"AABC","ACBA","ABCC","ABBB","AAAB"+ ]++-- | Test size function+testSize :: IO ()+testSize = do title "size"+ exhaustiveTest test (take 6 allAVL)+ where test _ s t = size t == s++-- | Test clipSize function+testClipSize :: IO ()+testClipSize = do title "clipSize"+ exhaustiveTest test (take 6 allAVL)+ where test _ s t = all (== Nothing) [clipSize n t | n <- [0..s-1 ]] &&+ all (== Just s ) [clipSize n t | n <- [s..s+10]]++-- | Test write function+testWrite :: IO ()+testWrite = do title "write"+ exhaustiveTest test (take 5 allNonEmptyAVL)+ where test _ s t = all test_ [0..s-1]+ where test_ n = let t_ = write (withCC' (+) n) t+ in isBalanced t_ && (asListL t_ == [0..n-1]++(n+n):[n+1..s-1])+++-- | Test push function+testPush :: IO ()+-- Also exercises: map' and contains+testPush = do title "push"+ exhaustiveTest test (take 6 allAVL)+ where test h s t = all oddTest odds && all evenTest evens+ where t_ = map' (\n -> 2*n+1) t -- t_ elements are odd, 1,3..2*s-1+ odds = [1,3..2*s-1]+ evens = [0,2..2*s ]+ oddTest n = let t__ = psh n t_ -- Should yield identical trees+ s__ = size t__+ h__ = ASINT(height t__)+ in (s__ == s) && (isSortedOK compare t__) && (h__== h)+ evenTest n = let t__ = psh n t_+ s__ = size t__+ h__ = ASINT(height t__)+ in (s__ == s+1) && (isSortedOK compare t__) && (h__-h <= 1) && (t__ `contns` n)+ psh e = push (sndCC e) e+ contns avl e = contains avl (compare e)++-- | Test delete function+testDelete :: IO ()+testDelete = do title "delete"+ exhaustiveTest test (take 5 allNonEmptyAVL)+ where test h s t = all oddTest odds && all evenTest evens+ where t_ = map' (\n -> 2*n+1) t -- t_ elements are odd, 1,3..2*s-1+ odds = [1,3..2*s-1]+ evens = [0,2..2*s ]+ oddTest n = let t__ = del n t_+ in case checkHeight t__ of+ Just h_ -> (h-h_<=1) && (L.insert n (asListL t__) == odds)+ Nothing -> False+ evenTest n = let t__ = del n t_+ in case checkHeight t__ of+ Just h_ -> (h==h_) && (asListL t__ == odds)+ Nothing -> False+ del e = delete (compare e)++-- | Test assertPop function+testAssertPop :: IO ()+testAssertPop =+ do title "assertPop"+ exhaustiveTest test (take 5 allNonEmptyAVL)+ where test h s t = all testElem elems+ where elems = [0,1..s-1]+ testElem n = let (n_,t_) = assertPop (fstCC n) t+ in case checkHeight t_ of+ Just h_ -> (h-h_<=1) && (L.insert n_ (asListL t_) == elems)+ Nothing -> False++-- | Test pushL function+-- Also exercises: asListL+testPushL :: IO ()+testPushL = do title "pushL"+ exhaustiveTest test (take 6 allAVL)+ where test h _ t = let t_ = 0 `pushL` t+ in case checkHeight t_ of+ Just h_ | (h_==h+1) || (h_==h) -> asListL t_ == (0 : asListL t)+ _ -> False++-- | Test pushR function+-- Also exercises: asListR+testPushR :: IO ()+testPushR = do title "pushR"+ exhaustiveTest test (take 6 allAVL)+ where test h s t = let t_ = t `pushR` s+ in case checkHeight t_ of+ Just h_ | (h_==h+1) || (h_==h) -> asListR t_ == (s : asListR t)+ _ -> False++-- | Test assertDelL function+-- Also exercises: asListL+testAssertDelL :: IO ()+testAssertDelL =+ do title "assertDelL"+ exhaustiveTest test (take 5 allNonEmptyAVL)+ where test h _ t = let t_ = assertDelL t+ in case checkHeight t_ of+ Just h_ | (h_==h-1) || (h_==h) -> asListL t_ == (drop 1 $ asListL t)+ _ -> False++-- | Test delR function+-- Also exercises: asListR+testAssertDelR :: IO ()+testAssertDelR =+ do title "assertDelR"+ exhaustiveTest test (take 5 allNonEmptyAVL)+ where test h _ t = let t_ = assertDelR t+ in case checkHeight t_ of+ Just h_ | (h_==h-1) || (h_==h) -> asListR t_ == (drop 1 $ asListR t)+ _ -> False++-- | Test assertPopL function+-- Also exercises: asListL+testAssertPopL :: IO ()+testAssertPopL =+ do title "assertPopL"+ exhaustiveTest test (take 5 allNonEmptyAVL)+ where test h _ t = let (v,t_) = assertPopL t+ in case checkHeight t_ of+ Just h_ | (h_==h-1) || (h_==h) -> (v : asListL t_) == asListL t+ _ -> False++-- -- | Test popHL function+-- -- This test can only be run if popHL and HAVL are not hidden.+-- -- However, popHL is exercised by indirectly by testConcatAVL anyway+-- testPopHL :: IO ()+-- testPopHL = do title "popHL"+-- exhaustiveTest test (take 5 allNonEmptyAVL)+-- where test _ _ t = let UBT3(v, t_,h) = popHL t+-- in case checkHeight t_ of+-- Just h_ | (h_== ASINT(h)) -> (v : asListL t_) == asListL t+-- _ -> False+++-- | Test assertPopR function+-- Also exercises: asListR+testAssertPopR :: IO ()+testAssertPopR =+ do title "assertPopR"+ exhaustiveTest test (take 5 allNonEmptyAVL)+ where test h _ t = let (t_,v) = assertPopR t+ in case checkHeight t_ of+ Just h_ | (h_==h-1) || (h_==h) -> (v : asListR t_) == asListR t+ _ -> False++-- | Test flatten function+-- Also exercises: asListL,replicateAVL+testFlatten :: IO ()+testFlatten = do title "flatten"+ exhaustiveTest test (take 6 allAVL)+ where test _ _ t = let t_ = flatten t+ in isBalanced t_ && (asListL t == asListL t_)++-- | Test foldr+testFoldr :: IO ()+testFoldr = do title "foldr"+ exhaustiveTest test (take 6 allAVL)+ where test _ s t = foldr (:) [] t == [0..s-1]+-- | Test foldr'+testFoldr' :: IO ()+testFoldr' = do title "foldr'"+ exhaustiveTest test (take 6 allAVL)+ where test _ s t = foldr' (:) [] t == [0..s-1]+-- | Test foldl+testFoldl :: IO ()+testFoldl = do title "foldl"+ exhaustiveTest test (take 6 allAVL)+ where test _ s t = foldl (flip (:)) [] t == [s-1,s-2..0]+-- | Test foldl'+testFoldl' :: IO ()+testFoldl' = do title "foldl'"+ exhaustiveTest test (take 6 allAVL)+ where test _ s t = foldl' (flip (:)) [] t == [s-1,s-2..0]+-- | Test foldr1+testFoldr1 :: IO ()+testFoldr1 = do title "foldr1"+ exhaustiveTest test (take 5 allNonEmptyAVL)+ where test _ s t = foldr1 (-) t == L.foldr1 (-) [0..s-1]+-- | Test foldr1'+testFoldr1' :: IO ()+testFoldr1' = do title "foldr1'"+ exhaustiveTest test (take 5 allNonEmptyAVL)+ where test _ s t = foldr1' (-) t == L.foldr1 (-) [0..s-1]+-- | Test foldl1+testFoldl1 :: IO ()+testFoldl1 = do title "foldl1"+ exhaustiveTest test (take 5 allNonEmptyAVL)+ where test _ s t = foldl1 (-) t == L.foldl1 (-) [0..s-1]+-- | Test foldl1'+testFoldl1' :: IO ()+testFoldl1' = do title "foldl1'"+ exhaustiveTest test (take 5 allNonEmptyAVL)+ where test _ s t = foldl1' (-) t == L.foldl1 (-) [0..s-1]++-- | Test mapAccumL+testMapAccumL :: IO ()+testMapAccumL = do title "mapAccumL"+ exhaustiveTest test (take 6 allAVL)+ where test _ _ t = let (nt,t') = mapAccumL f 0 t+ (nl,l ) = L.mapAccumL f 0 (asListL t)+ in (nt==nl) && ((asListL t') == l) && (isSortedOK compare t')+ f acc n = (acc+n,n+1)++-- | Test mapAccumR+testMapAccumR :: IO ()+testMapAccumR = do title "mapAccumR"+ exhaustiveTest test (take 6 allAVL)+ where test _ _ t = let (nt,t') = mapAccumR f 0 t+ (nl,l ) = L.mapAccumR f 0 (asListL t)+ in (nt==nl) && ((asListL t') == l) && (isSortedOK compare t')+ f acc n = (acc+n,n+1)++-- | Test mapAccumL'+testMapAccumL' :: IO ()+testMapAccumL' = do title "mapAccumL'"+ exhaustiveTest test (take 6 allAVL)+ where test _ _ t = let (nt,t') = mapAccumL' f 0 t+ (nl,l ) = L.mapAccumL f 0 (asListL t)+ in (nt==nl) && ((asListL t') == l) && (isSortedOK compare t')+ f acc n = (acc+n,n+1)++-- | Test mapAccumR'+testMapAccumR' :: IO ()+testMapAccumR' = do title "mapAccumR'"+ exhaustiveTest test (take 6 allAVL)+ where test _ _ t = let (nt,t') = mapAccumR' f 0 t+ (nl,l ) = L.mapAccumR f 0 (asListL t)+ in (nt==nl) && ((asListL t') == l) && (isSortedOK compare t')+ f acc n = (acc+n,n+1)++-- | Test mapAccumL''+testMapAccumL'' :: IO ()+testMapAccumL'' = do title "mapAccumL''"+ exhaustiveTest test (take 6 allAVL)+ where test _ _ t = let (nt,t') = mapAccumL'' f_ 0 t+ (nl,l ) = L.mapAccumL f 0 (asListL t)+ in (nt==nl) && ((asListL t') == l) && (isSortedOK compare t')+ f_ acc n = UBT2(acc+n,n+1)+ f acc n = (acc+n,n+1)++-- | Test mapAccumR''+testMapAccumR'' :: IO ()+testMapAccumR'' = do title "mapAccumR''"+ exhaustiveTest test (take 6 allAVL)+ where test _ _ t = let (nt,t') = mapAccumR'' f_ 0 t+ (nl,l ) = L.mapAccumR f 0 (asListL t)+ in (nt==nl) && ((asListL t') == l) && (isSortedOK compare t')+ f_ acc n = UBT2(acc+n,n+1)+ f acc n = (acc+n,n+1)++-- | Test the join function+testJoin :: IO ()+testJoin = let trees = take num $ concatMap (\(_,ts) -> ts) allAVL+ num = 2000+ in do title "join"+ putStrLn $ "Testing " ++ show (num*num) ++ " tree pairs.."+ if and [test l $ map (ls+) r | (l,ls) <- trees, (r,_) <- trees] then passed else failed+ where test l r = let j = l `join` r+ in isBalanced j && (asListL j == l `toListL` asListL r)++-- -- | Test the joinHAVL function+-- testJoinHAVL :: IO ()+-- testJoinHAVL = let trees = take num $ concatMap (\(_,ts) -> ts) allAVL+-- num = 2000+-- in do title "joinHAVL"+-- putStrLn $ "Testing " ++ show (num*num) ++ " tree pairs.."+-- if and [test l $ map (ls+) r | (l,ls) <- trees, (r,_) <- trees] then passed else failed+-- where test l r = let (HAVL j hj) = (toHAVL l) `joinHAVL` (toHAVL r)+-- in case checkHeight j of+-- Nothing -> False+-- Just hj_ -> (ASINT(hj) == hj_) && (asListL j == l `toListL` asListL r)++-- | Test the concatAVL function.+testConcatAVL :: IO ()+testConcatAVL = let trees = take num $ concatMap (\(_,ts) -> ts) allAVL+ num = 2000+ in do title "concatAVL"+ putStrLn $ "Testing " ++ show (num*num) ++ " tree pairs.."+ if others && and [test ls l $ map (\n -> n+(ls+1)) r+ | (l,ls) <- trees, (r,_) <- trees]+ then passed else failed+ where test ls l r = let j = concatAVL $ [empty,empty,l,empty,singleton ls,empty,r,empty,empty]+ in isBalanced j && (asListL j == l `toListL` (ls:asListL r))+ others = all (isEmpty . concatAVL) [[],[empty],[empty,empty],[empty,empty,empty]]+ && (all test1 $ concatMap (\ss -> [ss,"":ss,"Z":ss])+ [[""]+ ,["A"]+ ,["","A","BC","","D","","EFGH","I"]+ ]+ )+ test1 ss = let t = concatAVL $ L.map asTreeL ss+ in isBalanced t && (asListL t == concat ss)++-- | Test the flatConcat function.+testFlatConcat :: IO ()+testFlatConcat = let trees = take num $ concatMap (\(_,ts) -> ts) allAVL+ num = 2000+ in do title "flatConcat"+ putStrLn $ "Testing " ++ show (num*num) ++ " tree pairs.."+ if others && and [test ls l $ map (\n -> n+(ls+1)) r+ | (l,ls) <- trees, (r,_) <- trees]+ then passed else failed+ where test ls l r = let j = flatConcat $ [empty,empty,l,empty,singleton ls,empty,r,empty,empty]+ in isBalanced j && (asListL j == l `toListL` (ls:asListL r))+ others = all (isEmpty . flatConcat) [[],[empty],[empty,empty],[empty,empty,empty]]+ && (all test1 $ concatMap (\ss -> [ss,"":ss,"Z":ss])+ [[""]+ ,["A"]+ ,["","A","BC","","D","","EFGH","I"]+ ]+ )+ test1 ss = let t = flatConcat $ L.map asTreeL ss+ in isBalanced t && (asListL t == concat ss)++-- | Test the filterViaList function+testFilterViaList :: IO ()+testFilterViaList = do title "filterViaList"+ exhaustiveTest test (take 6 allAVL)+ where test _ s t = all testit [0..s] -- n==s should yield unmodified tree+ where testit n = let t' = filterViaList (/= n) t+ in (isSortedOK compare t') && (asListL t' == ([0..n-1]++[n+1..s-1]))++-- | Test the filter function+testFilter :: IO ()+testFilter = do title "filter"+ exhaustiveTest test (take 6 allAVL)+ where test _ s t = all testit [0..s] -- n==s should yield unmodified tree+ where testit n = let t' = filter (/= n) t+ in (isSortedOK compare t') && (asListL t' == ([0..n-1]++[n+1..s-1]))++-- | Test the mapMaybeViaList function+testMapMaybeViaList :: IO ()+testMapMaybeViaList = do title "mapMaybeViaList"+ exhaustiveTest test (take 6 allAVL)+ where test _ s t = all testit [0..s] -- n==s should yield unmodified tree+ where testit n = let t' = mapMaybeViaList (\m -> if m==n then Nothing else Just m) t+ in (isSortedOK compare t') && (asListL t' == ([0..n-1]++[n+1..s-1]))++-- | Test the mapMaybe function+testMapMaybe :: IO ()+testMapMaybe = do title "mapMaybe"+ exhaustiveTest test (take 6 allAVL)+ where test _ s t = all testit [0..s] -- n==s should yield unmodified tree+ where testit n = let t' = mapMaybe (\m -> if m==n then Nothing else Just m) t+ in (isSortedOK compare t') && (asListL t' == ([0..n-1]++[n+1..s-1]))++-- | Test splitAtL function+testSplitAtL :: IO ()+testSplitAtL = do title "splitAtL"+ exhaustiveTest test (take 6 allAVL)+ where test _ s t = all splitTest0 [0..s-1] && all splitTest1 [s]+ where tlist = asListL t+ splitTest0 n = case splitAtL n t of+ Left _ -> False+ Right (l,r) -> (isBalanced l) && (isBalanced r) &&+ (size l == n) && (size r == s-n) &&+ (l `toListL` asListL r) == tlist+ splitTest1 n = case splitAtL n t of+ Left s_ -> s_==s+ Right _ -> False++-- | Test takeL function+testTakeL :: IO ()+testTakeL = do title "takeL"+ exhaustiveTest test (take 6 allAVL)+ where test _ s t = all takeTest0 [0..s-1] && all takeTest1 [s]+ where takeTest0 n = case takeL n t of+ Left _ -> False+ Right l -> (isBalanced l) && (asListL l) == [0..n-1]+ takeTest1 n = case takeL n t of+ Left s_ -> s_==s+ Right _ -> False++-- | Test dropL function+testDropL :: IO ()+testDropL = do title "dropL"+ exhaustiveTest test (take 6 allAVL)+ where test _ s t = all dropTest0 [0..s-1] && all dropTest1 [s]+ where dropTest0 n = case dropL n t of+ Left _ -> False+ Right r -> (isBalanced r) && (asListL r) == [n..s-1]+ dropTest1 n = case dropL n t of+ Left s_ -> s_==s+ Right _ -> False++-- | Test splitAtR function+testSplitAtR :: IO ()+testSplitAtR = do title "splitAtR"+ exhaustiveTest test (take 6 allAVL)+ where test _ s t = all splitTest0 [0..s-1] && all splitTest1 [s]+ where tlist = asListR t+ splitTest0 n = case splitAtR n t of+ Left _ -> False+ Right (l,r) -> (isBalanced l) && (isBalanced r) &&+ (size r == n) && (size l == s-n) &&+ (r `toListR` asListR l) == tlist+ splitTest1 n = case splitAtR n t of+ Left s_ -> s_==s+ Right _ -> False++-- | Test takeR function+testTakeR :: IO ()+testTakeR = do title "takeR"+ exhaustiveTest test (take 6 allAVL)+ where test _ s t = all takeTest0 [0..s-1] && all takeTest1 [s]+ where takeTest0 n = case takeR n t of+ Left _ -> False+ Right r -> (isBalanced r) && (asListL r) == [s-n..s-1]+ takeTest1 n = case takeR n t of+ Left s_ -> s_==s+ Right _ -> False++-- | Test dropR function+testDropR :: IO ()+testDropR = do title "dropR"+ exhaustiveTest test (take 6 allAVL)+ where test _ s t = all dropTest0 [0..s-1] && all dropTest1 [s]+ where dropTest0 n = case dropR n t of+ Left _ -> False+ Right l -> (isBalanced l) && (asListL l) == [0..(s-1)-n]+ dropTest1 n = case dropR n t of+ Left s_ -> s_==s+ Right _ -> False++-- | Test spanL function+testSpanL :: IO ()+testSpanL = do title "spanL"+ exhaustiveTest test (take 6 allAVL)+ where test _ s t = all spanTest [0..s]+ where tlist = asListL t+ spanTest n = let (l ,r ) = spanL (<n) t+ (l_,r_) = span (<n) tlist+ in (isBalanced l) && (isBalanced r) &&+ (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 $ drop 1 $ iterate (map' (\n -> (n-1) `mod` s) . rotateL) t+ isOK t_ = (isBalanced t_) && (asListL t_ == tlist)+ tlist = asListL t+-- | Test rotateR function+testRotateR :: IO ()+testRotateR = do title "rotateR"+ exhaustiveTest test (take 6 allAVL)+ where test _ s t = all isOK rotations+ where rotations = take s $ drop 1 $ iterate (map' (\n -> (n+1) `mod` s) . rotateR) t+ isOK t_ = (isBalanced t_) && (asListL t_ == tlist)+ tlist = asListL t++-- | Test rotateByL function+testRotateByL :: IO ()+testRotateByL = do title "rotateByL"+ exhaustiveTest test (take 6 allAVL)+ where test _ s t = all isOK $ L.map rotateIt [-1..s]+ where rotateIt n = map' (\n_ -> (n_-n) `mod` s) $ rotateByL t n+ isOK t_ = (isBalanced t_) && (asListL t_ == tlist)+ tlist = asListL t++-- | Test rotateByR function+testRotateByR :: IO ()+testRotateByR = do title "rotateByR"+ exhaustiveTest test (take 6 allAVL)+ where test _ s t = all isOK $ L.map rotateIt [-1..s]+ where rotateIt n = map' (\n_ -> (n_+n) `mod` s) $ rotateByR t n+ isOK t_ = (isBalanced t_) && (asListL t_ == tlist)+ tlist = asListL t++-- | Test forkL function+testForkL :: IO ()+testForkL = do title "forkL"+ exhaustiveTest test (take 6 allAVL)+ where test _ s t = all testFarkL [-1..s-1]+ where tlist = asListL t+ testFarkL n = let (l,r) = forkL (compare n) t+ in (isBalanced l) && (isBalanced r) &&+ (size l == n+1) && (size r == s-(n+1)) &&+ (l `toListL` asListL r == tlist)++-- | Test forkR function+testForkR :: IO ()+testForkR = do title "forkR"+ exhaustiveTest test (take 6 allAVL)+ where test _ s t = all testFarkR [0..s]+ where tlist = asListL t+ testFarkR n = let (l,r) = forkR (compare n) t+ in (isBalanced l) && (isBalanced r) &&+ (size l == n) && (size r == s-n) &&+ (l `toListL` asListL r == tlist)+++-- | Test fork function+testFork :: IO ()+testFork = do title "fork"+ exhaustiveTest test (take 6 allAVL)+ where test _ s t = all testFork0 [0..s-1] && testFork1 (-1) && testFork2 s+ where tlist = asListL t+ testFork0 n = let (l,mbn,r) = fork (fstCC n) t+ in case mbn of+ Just n_ -> (n_==n) && (isBalanced l) && (isBalanced r) &&+ (size l == n) && (size r == s-(n+1)) &&+ (l `toListL` (n : asListL r) == tlist)+ _ -> False+ testFork1 n = let (l,mbn,r) = fork (fstCC n) t+ in case mbn of+ Nothing -> (isEmpty l) && (isBalanced r) && (asListL r == tlist)+ _ -> False+ testFork2 n = let (l,mbn,r) = fork (fstCC n) t+ in case mbn of+ Nothing -> (isEmpty r) && (isBalanced l) && (asListL l == tlist)+ _ -> False++-- | Test takeLE function+testTakeLE :: IO ()+testTakeLE = do title "takeLE"+ exhaustiveTest test (take 6 allAVL)+ where test _ s t = all testTikeLE [-1..s-1]+ where testTikeLE n = let l = takeLE (compare n) t+ in (isBalanced l) && (asListL l == [0..n])++-- | Test takeLT function+testTakeLT :: IO ()+testTakeLT = do title "takeLT"+ exhaustiveTest test (take 6 allAVL)+ where test _ s t = all testTikeLT [0..s]+ where testTikeLT n = let l = takeLT (compare n) t+ in (isBalanced l) && (asListL l == [0..n-1])++-- | Test takeGT function+testTakeGT :: IO ()+testTakeGT = do title "takeGT"+ exhaustiveTest test (take 6 allAVL)+ where test _ s t = all testTikeGT [-1..s-1]+ where testTikeGT n = let r = takeGT (compare n) t+ in (isBalanced r) && (asListL r == [n+1..s-1])++-- | Test takeGE function+testTakeGE :: IO ()+testTakeGE = do title "takeGE"+ exhaustiveTest test (take 6 allAVL)+ where test _ s t = all testTikeGE [0..s]+ where testTikeGE n = let r = takeGE (compare n) t+ in (isBalanced r) && (asListL r == [n..s-1])++-- | Test the union function+testUnion :: IO ()+testUnion = let trees = take num $ concatMap (\(_,ts) -> ts) allAVL+ num = 1000+ in do title "union"+ putStrLn $ "Testing " ++ show (num*num) ++ " tree pairs.."+ if and [test l ls r rs | (l,ls) <- trees, (r,rs) <- trees] then passed else failed+ where test l ls r rs = all (\f -> f l ls r rs) [test1,test2,test3]+ test1 l ls r rs = let u = unionFst l r+ in isBalanced u && (asListL u == [0 .. max ls rs - 1])+ test2 l ls r rs = and [test2_ n $ map' (n+) r | n <- [(-rs)..ls]]+ where test2_ n r_ = let u = unionFst l r_+ in isBalanced u && (asListL u == [min n 0 .. max ls (rs+n) - 1])+ test3 l ls r rs = let l_ = map' (\n -> n+n ) l -- even+ r_ = map' (\n -> n+n+1) r -- odd+ u = unionFst l_ r_+ in isSortedOK compare u && (size u == ls+rs)+ unionFst = union fstCC++-- | Test the disjointUnion function+testDisjointUnion :: IO ()+testDisjointUnion =+ let trees = take num $ concatMap (\(_,ts) -> ts) allAVL+ num = 1000+ in do title "disjointUnion"+ putStrLn $ "Testing " ++ show (num*num) ++ " tree pairs.."+ if and [test (map' (\n -> 2*n) l) ls (map' (\n -> 2*n+1) r) rs+ | (l,ls) <- trees -- 0,2..2*ls-2+ , (r,rs) <- trees -- 1,3..2*rs-1+ ]+ then passed+ else failed+ where test l ls r rs = all (\f -> f l ls r rs) [test1]+ test1 l ls r rs = and [test1_ $ map' (+(2*n)) r | n <- [(-rs)..(ls-1)]]+ where test1_ r_ = let u = disjointUnion compare l r_+ in isBalanced u && (asListL u == listUnion (asListL l) (asListL r_))++-- | Test the symDifference function+testSymDifference :: IO ()+testSymDifference =+ let trees = take num $ concatMap (\(_,ts) -> ts) allAVL+ num = 1000+ in do title "symDifference"+ putStrLn $ "Testing " ++ show (num*num) ++ " tree pairs.."+ if and [test l ls r rs | (l,ls) <- trees, (r,rs) <- trees] then passed else failed+ where test l ls r rs = all (\f -> f l ls r rs) [test1,test2,test3]+ test1 l ls r rs = let u = symDiff l r+ in isBalanced u && (asListL u == [min ls rs .. max ls rs - 1])+ test2 l ls r rs = and [test2_ n $ map' (n+) r | n <- [(-rs)..ls]]+ where test2_ n r_ = let u = symDiff l r_+ in isBalanced u && (asListL u == [min n 0 .. max n 0 - 1] +++ [min ls (rs+n) .. max ls (rs+n) - 1])+ test3 l ls r rs = let l_ = map' (\n -> n+n ) l -- even+ r_ = map' (\n -> n+n+1) r -- odd+ u = symDiff l_ r_+ in isSortedOK compare u && (size u == ls+rs)+ symDiff = symDifference compare++-- | Test the unionMaybe function+testUnionMaybe :: IO ()+testUnionMaybe = let trees = take num $ concatMap (\(_,ts) -> ts) allAVL+ num = 1000+ in do title "unionMaybe"+ putStrLn $ "Testing " ++ show (num*num) ++ " tree pairs.."+ if and [test l ls r rs | (l,ls) <- trees, (r,rs) <- trees] then passed else failed+ where test l ls r rs = all (\f -> f l ls r rs) [test1,test2,test3]+ test1 l ls r rs = let u = onion l r+ mn = min ls rs+ mx = max ls rs+ in isBalanced u && (asListL u == [0,2 .. mn - 1] ++ [mn .. mx-1])+ test2 l ls r rs = and [test2_ n $ map' (n+) r | n <- [(-rs)..ls]]+ where test2_ n r_ = let u = onion l r_+ n0 = min n 0+ n1 = max n 0+ n2 = min ls (rs+n)+ n3 = max ls (rs+n)+ in isBalanced u && (asListL u == [n0 .. n1-1]+ ++ L.filter even [n1 .. n2-1]+ ++ [n2..n3-1]+ )+ test3 l ls r rs = let l_ = map' (\n -> n+n ) l -- even+ r_ = map' (\n -> n+n+1) r -- odd+ u = onion l_ r_+ in isSortedOK compare u && (size u == ls+rs)+ onion = unionMaybe (withCC' com)+ com a _ = if even a then Just a else Nothing++-- | Test the intersection function+testIntersection :: IO ()+testIntersection = let trees = take num $ concatMap (\(_,ts) -> ts) allAVL+ num = 1000+ in do title "intersection"+ putStrLn $ "Testing " ++ show (num*num) ++ " tree pairs.."+ if and [test l ls r rs | (l,ls) <- trees, (r,rs) <- trees] then passed else failed+ where test l ls r rs = all (\f -> f l ls r rs) [test1,test2,test3]+ test1 l ls r rs = let u = intersection fstCC l r+ in isBalanced u && (asListL u == [0 .. min ls rs - 1])+ test2 l ls r rs = and [test2_ n $ map' (n+) r | n <- [(-rs)..ls]]+ where test2_ n r_ = let u = intersection fstCC l r_+ in isBalanced u && (asListL u == [max n 0 .. min ls (rs+n) - 1])+ test3 l _ r _ = let l_ = map' (\n -> n+n ) l -- even+ r_ = map' (\n -> n+n+1) r -- odd+ u = intersection fstCC l_ r_+ in isEmpty u++-- | Test the intersectionMaybe function+testIntersectionMaybe :: IO ()+testIntersectionMaybe = let trees = take num $ concatMap (\(_,ts) -> ts) allAVL+ num = 1000+ in do title "intersectionMaybe"+ putStrLn $ "Testing " ++ show (num*num) ++ " tree pairs.."+ if and [test l ls r rs | (l,ls) <- trees, (r,rs) <- trees] then passed else failed+ where test l ls r rs = all (\f -> f l ls r rs) [test1,test2,test3]+ test1 l ls r rs = let u = insect l r+ mn = min ls rs+ in isBalanced u && (asListL u == [0,2 .. mn - 1])+ test2 l ls r rs = and [test2_ n $ map' (n+) r | n <- [(-rs)..ls]]+ where test2_ n r_ = let u = insect l r_+ n1 = max n 0+ n2 = min ls (rs+n)+ in isBalanced u && (asListL u == L.filter even [n1 .. n2-1])+ test3 l _ r _ = let l_ = map' (\n -> n+n ) l -- even+ r_ = map' (\n -> n+n+1) r -- odd+ u = insect l_ r_+ in isEmpty u+ insect = intersectionMaybe (withCC' com)+ com a _ = if even a then Just a else Nothing++-- | Test the intersectionAsList function+testIntersectionAsList :: IO ()+testIntersectionAsList =+ let trees = take num $ concatMap (\(_,ts) -> ts) allAVL+ num = 1000+ in do title "intersectionAsList"+ putStrLn $ "Testing " ++ show (num*num) ++ " tree pairs.."+ if and [test l ls r rs | (l,ls) <- trees, (r,rs) <- trees] then passed else failed+ where test l ls r rs = all (\f -> f l ls r rs) [test1,test2,test3]+ test1 l ls r rs = let u = intersectionAsList fstCC l r+ in u == [0 .. min ls rs - 1]+ test2 l ls r rs = and [test2_ n $ map' (n+) r | n <- [(-rs)..ls]]+ where test2_ n r_ = let u = intersectionAsList fstCC l r_+ in u == [max n 0 .. min ls (rs+n) - 1]+ test3 l _ r _ = let l_ = map' (\n -> n+n ) l -- even+ r_ = map' (\n -> n+n+1) r -- odd+ u = intersectionAsList fstCC l_ r_+ in null u++-- | Test the intersectionMaybeAsList function+testIntersectionMaybeAsList :: IO ()+testIntersectionMaybeAsList =+ let trees = take num $ concatMap (\(_,ts) -> ts) allAVL+ num = 1000+ in do title "intersectionMaybeAsList"+ putStrLn $ "Testing " ++ show (num*num) ++ " tree pairs.."+ if and [test l ls r rs | (l,ls) <- trees, (r,rs) <- trees] then passed else failed+ where test l ls r rs = all (\f -> f l ls r rs) [test1,test2,test3]+ test1 l ls r rs = let u = insect l r+ mn = min ls rs+ in u == [0,2 .. mn - 1]+ test2 l ls r rs = and [test2_ n $ map' (n+) r | n <- [(-rs)..ls]]+ where test2_ n r_ = let u = insect l r_+ n1 = max n 0+ n2 = min ls (rs+n)+ in u == L.filter even [n1 .. n2-1]+ test3 l _ r _ = let l_ = map' (\n -> n+n ) l -- even+ r_ = map' (\n -> n+n+1) r -- odd+ u = insect l_ r_+ in null u+ insect = intersectionMaybeAsList (withCC' com)+ com a _ = if even a then Just a else Nothing++-- | Test the difference function+testDifference :: IO ()+testDifference = let trees = take num $ concatMap (\(_,ts) -> ts) allAVL+ num = 1000+ in do title "difference"+ putStrLn $ "Testing " ++ show (num*num) ++ " tree pairs.."+ if and [test l ls r rs | (l,ls) <- trees, (r,rs) <- trees] then passed else failed+ where test l ls r rs = all (\f -> f l ls r rs) [test1,test2,test3]+ test1 l ls r rs = let u = diff l r+ in isBalanced u && (asListL u == [rs .. ls - 1])+ test2 l ls r rs = and [test2_ n $ map' (n+) r | n <- [(-rs)..ls]]+ where test2_ n r_ = let u = diff l r_+ in isBalanced u && (asListL u == [0 .. n-1] ++ [rs+n .. ls-1])+ test3 l ls r rs = let l_ = map' (\n -> n+n ) l -- even+ r_ = map' (\n -> n+n+1) r -- odd+ u = diff l r_+ u_ = diff l_ r_+ mn = min (ls-1) (2*rs-1)+ in isBalanced u &&+ (asListL u == L.filter even [0..mn] ++ [mn+1..ls-1]) &&+ isBalanced u_ && (asListL u_ == asListL l_)+ diff = difference compare++-- | Test the differenceMaybe function+testDifferenceMaybe :: IO ()+testDifferenceMaybe =+ let trees = take num $ concatMap (\(_,ts) -> ts) allAVL+ num = 1000+ in do title "differenceMaybe"+ putStrLn $ "Testing " ++ show (num*num) ++ " tree pairs.."+ if and [test l ls r rs | (l,ls) <- trees, (r,rs) <- trees] then passed else failed+ where c m n = case compare m n of+ LT -> Lt+ EQ -> if even m then (Eq Nothing) else (Eq (Just m))+ GT -> Gt+ test l ls r rs = all (\f -> f l ls r rs) [test1,test2,test3]+ test1 l ls r rs = let mn = min (ls-1) (rs-1)+ u = differenceMaybe c l r+ in isBalanced u && (asListL u == L.filter odd [0..mn] ++ [mn+1..ls-1])+ test2 l ls r rs = and [test2_ n $ map' (n+) r | n <- [(-rs)..ls]]+ where test2_ n r_ = let u = differenceMaybe c l r_+ n0 = max 0 n+ n1 = min (ls-1) (rs+n-1)+ in isBalanced u &&+ (asListL u == [0..n0-1] ++ L.filter odd [n0..n1] ++ [n1+1..ls-1])+ test3 l ls r rs = let l_ = map' (\n -> n+n+1) l -- odd+ r_ = map' (\n -> n+n ) r -- even+ u = differenceMaybe c l r_+ u_ = differenceMaybe c l_ r_+ mn = min (ls-1) (2*rs-2)+ mx = max (mn+1) 0+ listfil = L.filter odd [0..mn]+ listrem = [mx..ls-1]+ in isBalanced u && isBalanced u_ && (asListL u_ == asListL l_) &&+ (asListL u == listfil ++ listrem)++-- | Test the isSubsetOf function+testIsSubsetOf :: IO ()+testIsSubsetOf = let trees = take num $ concatMap (\(_,ts) -> ts) allAVL+ num = 1000+ in do title "isSubsetOf"+ putStrLn $ "Testing " ++ show (num*num) ++ " tree pairs.."+ if and [test l ls r rs | (l,ls) <- trees, (r,rs) <- trees] then passed else failed+ where test l ls r rs = all (\f -> f l ls r rs) [test1,test2]+ test1 l ls r rs = (l `isSubset` r == (ls<=rs)) &&+ (r `isSubset` l == (rs<=ls))+ test2 l ls r rs = and [test2_ n $ map' (n+) r | n <- [(-rs)..ls]]+ where test2_ n r_ = (l `isSubset` r_ == ((n<=0) && (rs+n>=ls))) &&+ (r_ `isSubset` l == ((n>=0) && (rs+n<=ls)))+ isSubset = isSubsetOf compare++-- | Test the isSubsetOfBy function+testIsSubsetOfBy :: IO ()+testIsSubsetOfBy = let trees = take num $ concatMap (\(_,ts) -> ts) allAVL+ num = 1000+ in do title "isSubsetOfBy"+ putStrLn $ "Testing " ++ show (num*num) ++ " tree pairs.."+ if and [test l ls r rs | (l,ls) <- trees, (r,rs) <- trees] then passed else failed+ -- test1 & test2 chack same behaviour as isSubsetOf+ -- test3 checks behviour for comarison functions that may return (Eq False)+ where test l ls r rs = all (\f -> f l ls r rs) [test1,test2,test3]+ test1 l ls r rs = (l `isSubset` r == (ls<=rs)) &&+ (r `isSubset` l == (rs<=ls))+ test2 l ls r rs = and [test2_ n $ map' (n+) r | n <- [(-rs)..ls]]+ where test2_ n r_ = (l `isSubset` r_ == ((n<=0) && (rs+n>=ls))) &&+ (r_ `isSubset` l == ((n>=0) && (rs+n<=ls)))+ isSubset = isSubsetOfBy (withCC (\_ _ -> True ))+ test3 l ls r rs = and [test3_ n | n <- [0..max ls rs]]+ where test3_ n = (l `isSubset'` r == ((ls<=rs) && (n>=ls))) &&+ (r `isSubset'` l == ((rs<=ls) && (n>=rs)))+ where isSubset' = isSubsetOfBy (withCC (\m _ -> m /= n))++-- | Test the venn function. Also exercises disjointUnion+testVenn :: IO ()+testVenn =+ let trees = concatMap (\(_,ts) -> ts) (take 5 allAVL) -- All trees of height 4 or less = 335 trees (112,225 pairs)+ num = length trees+ in do title "venn"+ putStrLn $ "Testing " ++ show (num*num) ++ " tree pairs.."+ if and [test l ls r rs | (l,ls) <- trees, (r,rs) <- trees] then passed else failed+ where test l ls r rs = all (\f -> f l ls r rs) [test1,test2]+ test1 l ls r rs = let (lr,i,rl) = ven l r+ in and [all isBalanced [lr,i,rl]+ ,asListL lr == listDiff [0..ls-1] [0..rs-1]+ ,asListL i == listIntersection [0..ls-1] [0..rs-1]+ ,asListL rl == listDiff [0..rs-1] [0..ls-1]+ ,asListL (disu i (disu rl lr)) == listUnion [0..ls-1] [0..rs-1]+ ]+ test2 l ls r rs = and [test2_ $ map' (n+) r | n <- [(-rs)..ls]]+ where test2_ r_ = let (lr,i,rl) = ven l r_+ in and [all isBalanced [lr,i,rl]+ ,asListL lr == listDiff (asListL l ) (asListL r_)+ ,asListL i == listIntersection (asListL l ) (asListL r_)+ ,asListL rl == listDiff (asListL r_) (asListL l )+ ,asListL (disu i (disu rl lr)) == listUnion (asListL l ) (asListL r_)+ ]+ ven = venn fstCC+ disu = disjointUnion compare++-- | Test the vennMaybe function.+testVennMaybe :: IO ()+testVennMaybe =+ let trees = concatMap (\(_,ts) -> ts) (take 5 allAVL) -- All trees of height 4 or less = 335 trees (112,225 pairs)+ num = length trees+ in do title "vennMaybe"+ putStrLn $ "Testing " ++ show (num*num) ++ " tree pairs.."+ if and [test l ls r rs | (l,ls) <- trees, (r,rs) <- trees] then passed else failed+ where test l ls r rs = and [t cmp l ls r rs| t<-[test1], cmp<-[cmpAll,cmpNone,cmpEven,cmpOdd]]+ test1 cmp l ls r rs = and [test1_ $ map' (n+) r | n <- [(-rs)..ls]]+ where test1_ r_ = let (lr,i,rl) = vennMaybe cmp l r_+ in and [all isBalanced [lr,i,rl]+ ,asListL lr == listDiff (asListL l ) (asListL r_)+ ,asListL rl == listDiff (asListL r_) (asListL l )+ ,asListL i == listIntersectionMaybe cmp (asListL l ) (asListL r_)+ ,asListL (disu i (disu rl lr)) == listUnion (asListL i) (listUnion (asListL lr) (asListL rl))+ ]+ cmpAll = withCC' (\x _ -> Just x)+ cmpNone = withCC' (\_ _ -> Nothing)+ cmpEven = withCC' (\x _ -> if even x then Just x else Nothing)+ cmpOdd = withCC' (\x _ -> if odd x then Just x else Nothing)+ disu = disjointUnion compare++-- | Test compareHeight function+testCompareHeight :: IO ()+testCompareHeight = let trees = take num $ concatMap (\(h,ts) -> [(t,h)|(t,_)<-ts]) allAVL+ num = 10000+ in do title "compareHeight"+ putStrLn $ "Testing " ++ show (num*num) ++ " tree pairs.."+ if and [test l lh r rh | (l,lh) <- trees, (r,rh) <- trees] then passed else failed+ where test l lh r rh = compareHeight l r == compare lh rh++-- | Test Zipper open\/close+testOpenClose :: IO ()+testOpenClose = do title "Zipper open/close"+ exhaustiveTest test (take 5 allNonEmptyAVL)+ where test _ s t = all test_ [0..s-1]+ where test_ n = let z = assertOpen (compare n) t+ t_ = close z+ in (getCurrent z == n) && (isBalanced t_) && (asListL t_ == [0..s-1])+-- | Test Zipper delClose+testDelClose :: IO ()+testDelClose = do title "Zipper delClose"+ exhaustiveTest test (take 5 allNonEmptyAVL)+ where test _ s t = all test_ [0..s-1]+ where test_ n = let t_ = delClose $ assertOpen (compare n) t+ in (isBalanced t_) -- && (L.insert n (asListL t_) == [0..s-1])++-- | Test Zipper assertOpenL\/close+testOpenLClose :: IO ()+testOpenLClose = do title "Zipper assertOpenL/close"+ exhaustiveTest test (take 5 allNonEmptyAVL)+ where test _ s t = let z = assertOpenL t+ t_ = close z+ in (getCurrent z == 0) && (isBalanced t_) && (asListL t_ == [0..s-1])++-- | Test Zipper assertOpenR\/close+testOpenRClose :: IO ()+testOpenRClose = do title "Zipper assertOpenR/close"+ exhaustiveTest test (take 5 allNonEmptyAVL)+ where test _ s t = let z = assertOpenR t+ t_ = close z+ in (getCurrent z == s-1) && (isBalanced t_) && (asListL t_ == [0..s-1])++-- | Test Zipper assertMoveL\/isRightmost+testMoveL :: IO ()+testMoveL = do title "Zipper assertMoveL/isRightmost"+ exhaustiveTest test (take 5 allNonEmptyAVL)+ where test _ s t = let zavls@(z:zs) = take s $ iterate assertMoveL (assertOpenR t)+ in (L.map getCurrent zavls == L.reverse [0..s-1]) && (all test_ zavls) &&+ (isRightmost z) && (not $ any isRightmost zs)+ where test_ zavl = let t_ = close zavl+ in (isBalanced t_) && (asListL t_ == [0..s-1])++-- | Test Zipper assertMoveR\/isLeftmost+testMoveR :: IO ()+testMoveR = do title "Zipper assertMoveR/isLeftmost"+ exhaustiveTest test (take 5 allNonEmptyAVL)+ where test _ s t = let zavls@(z:zs) = take s $ iterate assertMoveR (assertOpenL t)+ in (L.map getCurrent zavls == [0..s-1]) && (all test_ zavls) &&+ (isLeftmost z) && (not $ any isLeftmost zs)+ where test_ zavl = let t_ = close zavl+ in (isBalanced t_) && (asListL t_ == [0..s-1])++-- | Test Zipper insertL+testInsertL :: IO ()+testInsertL = do title "Zipper insertL"+ exhaustiveTest test (take 5 allNonEmptyAVL)+ where test _ s t = all test_ [0..s-1]+ where test_ n = let z = insertL s $ assertOpen (compare n) t+ t_ = close z+ in (getCurrent z == n) && (isBalanced t_) &&+ (asListL t_ == [0..n-1] ++ s:[n..s-1])+-- | Test Zipper insertMoveL+testInsertMoveL :: IO ()+testInsertMoveL = do title "Zipper insertMoveL"+ exhaustiveTest test (take 5 allNonEmptyAVL)+ where test _ s t = all test_ [0..s-1]+ where test_ n = let z = insertMoveL s $ assertOpen (compare n) t+ t_ = close z+ in (getCurrent z == s) && (isBalanced t_) &&+ (asListL t_ == [0..n-1] ++ s:[n..s-1])++-- | Test Zipper insertR+testInsertR :: IO ()+testInsertR = do title "Zipper insertR"+ exhaustiveTest test (take 5 allNonEmptyAVL)+ where test _ s t = all test_ [0..s-1]+ where test_ n = let z = insertR (assertOpen (compare n) t) s+ t_ = close z+ in (getCurrent z == n) && (isBalanced t_) &&+ (asListL t_ == [0..n] ++ s:[(n+1)..s-1])++-- | Test Zipper insertMoveR+testInsertMoveR :: IO ()+testInsertMoveR = do title "Zipper insertMoveR"+ exhaustiveTest test (take 5 allNonEmptyAVL)+ where test _ s t = all test_ [0..s-1]+ where test_ n = let z = insertMoveR (assertOpen (compare n) t) s+ t_ = close z+ in (getCurrent z == s) && (isBalanced t_) &&+ (asListL t_ == [0..n] ++ s:[(n+1)..s-1])++-- | Test Zipper insertTreeL+testInsertTreeL :: IO ()+testInsertTreeL = do title "Zipper insertTreeL"+ exhaustiveTest test (take 5 allNonEmptyAVL)+ where test _ s t = all test_ [0..s-1]+ where test_ n = let z = insertTreeL t $ assertOpen (compare n) t+ t_ = close z+ in (getCurrent z == n) && (isBalanced t_) &&+ (asListL t_ == [0..n-1] ++ [0..s-1] ++ [n..s-1])++-- | Test Zipper insertTreeR+testInsertTreeR :: IO ()+testInsertTreeR = do title "Zipper insertTreeR"+ exhaustiveTest test (take 5 allNonEmptyAVL)+ where test _ s t = all test_ [0..s-1]+ where test_ n = let z = insertTreeR (assertOpen (compare n) t) t+ t_ = close z+ in (getCurrent z == n) && (isBalanced t_) &&+ (asListL t_ == [0..n] ++ [0..s-1] ++ [n+1..s-1])+-- | Test Zipper assertDelMoveL+testDelMoveL :: IO ()+testDelMoveL = do title "Zipper assertDelMoveL"+ exhaustiveTest test (take 5 allNonEmptyAVL)+ where test _ s t = let zavls = take s $ iterate assertDelMoveL $ insertR (assertOpenR t) s+ in (L.map getCurrent zavls == L.reverse [0..s-1]) &&+ (and $ zipWith test_ zavls $ L.reverse [0..s-1])+ where test_ zavl s_ = let t_ = close zavl+ in (isBalanced t_) && (asListL t_ == [0..s_] ++ [s])++-- | Test Zipper assertDelMoveR+testDelMoveR :: IO ()+testDelMoveR = do title "Zipper assertDelMoveR"+ exhaustiveTest test (take 5 allNonEmptyAVL)+ where test _ s t = let zavls = take s $ iterate assertDelMoveR $ insertL s $ assertOpenL t+ in (L.map getCurrent zavls == [0..s-1]) &&+ (and $ zipWith test_ zavls [0..s-1])+ where test_ zavl s_ = let t_ = close zavl+ in (isBalanced t_) && (asListL t_ == s:[s_..s-1])++-- | Test Zipper delAllL+testDelAllL :: IO ()+testDelAllL = do title "Zipper delAllL"+ exhaustiveTest test (take 5 allNonEmptyAVL)+ where test _ s t = all test_ [0..s-1]+ where test_ n = let z = delAllL $ assertOpen (compare n) t+ t_ = close z+ t__ = close $ insertTreeL t z+ in (isBalanced t_ ) && (asListL t_ == [n..s-1]) &&+ (isBalanced t__) && (asListL t__ == [0..s-1] ++ [n..s-1])++-- | Test Zipper delAllR+testDelAllR :: IO ()+testDelAllR = do title "Zipper delAllR"+ exhaustiveTest test (take 5 allNonEmptyAVL)+ where test _ s t = all test_ [0..s-1]+ where test_ n = let z = delAllR $ assertOpen (compare n) t+ t_ = close z+ t__ = close $ insertTreeR z t+ in (isBalanced t_ ) && (asListL t_ == [0..n]) &&+ (isBalanced t__) && (asListL t__ == [0..n] ++ [0..s-1])++-- | Test Zipper delAllCloseL+testDelAllCloseL :: IO ()+testDelAllCloseL = do title "Zipper delAllCloseL"+ exhaustiveTest test (take 5 allNonEmptyAVL)+ where test _ s t = all test_ [0..s-1]+ where test_ n = let t_ = delAllCloseL $ assertOpen (compare n) t+ in (isBalanced t_ ) && (asListL t_ == [n..s-1])++-- | Test Zipper delAllIncCloseL+testDelAllIncCloseL :: IO ()+testDelAllIncCloseL = do title "Zipper delAllIncCloseL"+ exhaustiveTest test (take 5 allNonEmptyAVL)+ where test _ s t = all test_ [0..s-1]+ where test_ n = let t_ = delAllIncCloseL $ assertOpen (compare n) t+ in (isBalanced t_ ) && (asListL t_ == [n+1..s-1])++-- | Test Zipper delAllCloseR+testDelAllCloseR :: IO ()+testDelAllCloseR = do title "Zipper delAllCloseR"+ exhaustiveTest test (take 5 allNonEmptyAVL)+ where test _ s t = all test_ [0..s-1]+ where test_ n = let t_ = delAllCloseR $ assertOpen (compare n) t+ in (isBalanced t_ ) && (asListL t_ == [0..n])++-- | Test Zipper delAllIncCloseR+testDelAllIncCloseR :: IO ()+testDelAllIncCloseR = do title "Zipper delAllIncCloseR"+ exhaustiveTest test (take 5 allNonEmptyAVL)+ where test _ s t = all test_ [0..s-1]+ where test_ n = let t_ = delAllIncCloseR $ assertOpen (compare n) t+ in (isBalanced t_ ) && (asListL t_ == [0..n-1])++-- | Test Zipper sizeL\/sizeR\/sizeZAVL+testZipSize :: IO ()+testZipSize = do title "Zipper sizeL/sizeR/sizeZAVL"+ exhaustiveTest test (take 5 allNonEmptyAVL)+ where test _ s t = all test_ [0..s-1]+ where test_ n = let z = assertOpen (compare n) t+ in (sizeL z == n) && (sizeR z == (s-1)-n) && (sizeZAVL z == s)++-- | Test Zipper tryOpenGE+testTryOpenGE :: IO ()+testTryOpenGE = do title "Zipper tryOpenGE"+ exhaustiveTest test (take 5 allNonEmptyAVL)+ where test _ s t = let t_ = map' (2*) t+ in all (testE t_) [0,2..2*s-2] && all (testO t_) [(-1),1..2*s-3]+ where testE t_ n = let Just z = tryOGE n t_+ t__ = close z+ in (getCurrent z == n) && (isBalanced t__) && (asListL t__ == [0,2..2*s-2])+ testO t_ n = let Just z = tryOGE n t_+ t__ = close z+ in (getCurrent z == n+1) && (isBalanced t__) && (asListL t__ == [0,2..2*s-2])+ tryOGE a = tryOpenGE (compare a)++-- | Test Zipper tryOpenLE+testTryOpenLE :: IO ()+testTryOpenLE = do title "Zipper tryOpenLE"+ exhaustiveTest test (take 5 allNonEmptyAVL)+ where test _ s t = let t_ = map' (2*) t+ in all (testE t_) [0,2..2*s-2] && all (testO t_) [1,3..2*s-1]+ where testE t_ n = let Just z = tryOLE n t_+ t__ = close z+ in (getCurrent z == n) && (isBalanced t__) && (asListL t__ == [0,2..2*s-2])+ testO t_ n = let Just z = tryOLE n t_+ t__ = close z+ in (getCurrent z == n-1) && (isBalanced t__) && (asListL t__ == [0,2..2*s-2])+ tryOLE a = tryOpenLE (compare a)++-- | Test Zipper openEither (also tests fill and fillClose)+testOpenEither :: IO ()+testOpenEither = do title "Zipper openEither"+ exhaustiveTest test (take 6 allAVL)+ where test _ s t = let t_ = map' (2*) t+ in all (testE t_) [0,2..2*s-2] && all (testO t_) [-1,1..2*s-1]+ where testE t_ n = let Right z = openEith n t_+ t__ = close z+ in (getCurrent z == n) && (isBalanced t__) && (asListL t__ == [0,2..2*s-2])+ testO t_ n = let Left p = openEith n t_+ t__ = close (fill n p)+ t___ = fillClose n p+ in (isBalanced t__) && (isBalanced t___) && (t__ == t___) &&+ (asListL t__ == ([0,2..n-1] ++ n : [n+1,n+3..2*s-2]))+ openEith a = openEither (compare a)++++-- | Test anyBAVLtoEither+testBAVLtoZipper :: IO ()+testBAVLtoZipper = do title "BAVLtoZipper"+ exhaustiveTest test (take 6 allAVL)+ where test _ s t = let t_ = map' (2*) t+ in all (testE t_) [0,2..2*s-2] && all (testO t_) [-1,1..2*s-1]+ where testE t_ n = let bavl = oBAVL n t_+ Right z = anyBAVLtoEither bavl+ t__ = close z+ in (getCurrent z == n) && (isBalanced t__) && (asListL t__ == [0,2..2*s-2])+ testO t_ n = let bavl = oBAVL n t_+ Left p = anyBAVLtoEither bavl+ t__ = fillClose n p+ in (isBalanced t__) && (asListL t__ == ([0,2..n-1] ++ n : [n+1,n+3..2*s-2]))+ oBAVL e = openBAVL (compare e)+++-- | Test Show,Read,Eq instances+testShowReadEq :: IO ()+testShowReadEq = do title "ShowReadEq"+ exhaustiveTest test (take 5 allAVL) -- No need to get carried away with this one+ where test _ _ t = t == (read $ show t)++-- | Test readPath+testReadPath :: IO ()+testReadPath = do title "ReadPath"+ if all test [0..100] then passed else failed+ where test n = let ASINT(n_)=n in (n == readPath n_ pathTree)++title :: String -> IO ()+title str = let titl = "* Test " ++ str ++ " *"+ mark = L.replicate (length titl) '*'+ in putStrLn "" >> putStrLn mark >> putStrLn titl >> putStrLn mark++passed :: IO ()+passed = putStrLn "Passed"++failed :: IO ()+failed = do putStrLn "!! FAILED !!"+ exitFailure+++-- List union (of ascending Ints)+listUnion :: [Int] -> [Int] -> [Int]+listUnion [] ys = ys+listUnion xs [] = xs+listUnion xs@(x:xs') ys@(y:ys') = case compare x y of+ LT -> x:(listUnion xs' ys )+ EQ -> x:(listUnion xs' ys') -- Eliminate duplicates+ GT -> y:(listUnion xs ys')++-- List intersection (of ascending Ints)+listIntersection :: [Int] -> [Int] -> [Int]+listIntersection [] _ = []+listIntersection _ [] = []+listIntersection xs@(x:xs') ys@(y:ys') = case compare x y of+ LT -> listIntersection xs' ys+ EQ -> x:(listIntersection xs' ys')+ GT -> listIntersection xs ys'++-- List intersection maybe (of ascending Ints)+listIntersectionMaybe :: (Int -> Int -> COrdering (Maybe Int)) -> [Int] -> [Int] -> [Int]+listIntersectionMaybe _ [] _ = []+listIntersectionMaybe _ _ [] = []+listIntersectionMaybe cmp xs@(x:xs') ys@(y:ys') = case cmp x y of+ Lt -> listIntersectionMaybe cmp xs' ys+ Eq (Just i) -> i:(listIntersectionMaybe cmp xs' ys')+ Eq Nothing -> listIntersectionMaybe cmp xs' ys'+ Gt -> listIntersectionMaybe cmp xs ys'++-- List Difference (of ascending Ints)+listDiff :: [Int] -> [Int] -> [Int]+listDiff [] _ = []+listDiff xs [] = xs+listDiff xs@(x:xs') ys@(y:ys') = case compare x y of+ LT -> x:(listDiff xs' ys)+ EQ -> listDiff xs' ys'+ GT -> listDiff xs ys'+
+ tests/Utils.hs view
@@ -0,0 +1,128 @@+-- |+-- Copyright : (c) Adrian Hey 2004,2005+-- License : BSD3+--+--+-- 'AVL' tree related test and verification utilities.+module Utils+ (-- * Correctness checking.+ checkHeight,+ -- * Test data generation.+ TestTrees,allAVL, allNonEmptyAVL, numTrees, flatAVL,+ -- * Exhaustive tests.+ exhaustiveTest,+ -- * Testing BinPath module.+ pathTree,+ ) where++import Data.Tree.AVL+import Data.Tree.AVL.Internals.Types (AVL(..))++import GHC.Base+#include "ghcdefs.h"++-- | Infinite test tree. Used for test purposes for BinPath module.+-- Value at each node is the path to that node.+pathTree :: AVL Int+pathTree = Z l 0 r where+ l = mapIt (\n -> 2*n+1) pathTree+ r = mapIt (\n -> 2*n+2) pathTree+ -- Need special lazy map for this recursive tree defn+ mapIt f (Z l' n r') = let n'= f n in n' `seq` Z (mapIt f l') n' (mapIt f r')+ mapIt _ _ = undefined++-- | Verify that a tree is balanced and the BF of each node is correct.+-- Returns (Just height) if so, otherwise Nothing.+--+-- Complexity: O(n)+checkHeight :: AVL e -> Maybe Int+checkHeight t = let ht = cH t in if isTrue# (ht EQL L(-1)) then Nothing else Just ASINT(ht)++-- Local utility, returns height if balanced, -1 if not+cH :: AVL e -> UINT+cH E = L(0)+cH (N l _ r) = cH_ L(1) l r -- (hr-hl) = 1+cH (Z l _ r) = cH_ L(0) l r -- (hr-hl) = 0+cH (P l _ r) = cH_ L(1) r l -- (hl-hr) = 1+cH_ :: UINT -> AVL e -> AVL e -> UINT+cH_ delta l r = let hl = cH l+ in if isTrue# (hl EQL L(-1)) then hl+ else let hr = cH r+ in if isTrue# (hr EQL L(-1)) then hr+ else if isTrue# (SUBINT(hr,hl) EQL delta) then INCINT1(hr)+ else L(-1)+++-- | AVL Tree test data. Each element of a the list is a pair consisting of a height,+-- and list of all possible sorted trees of the same height, paired with their sizes.+-- The elements of each tree of size s are 0..s-1.+type TestTrees = [(Int, [(AVL Int, Int)])]++-- | All possible sorted AVL trees.+allAVL :: TestTrees+allAVL = p0 : p1 : moreTrees p1 p0 where+ p0 = (0, [(E , 0)]) -- All possible trees of height 0+ p1 = (1, [(Z E 0 E, 1)]) -- All possible trees of height 1+ -- Generate more trees of height N, from existing trees of height N-1 and N-2+ moreTrees :: (Int, [(AVL Int, Int)]) -> (Int, [(AVL Int, Int)]) -> [(Int, [(AVL Int, Int)])]+ moreTrees pN1@(hN1, tpsN1) -- Height N-1+ (_ , tpsN2) = -- Height N-2+ let hN0 = hN1 + 1 -- Height N+ tsN0 = interleave (interleave [newTree P l r | r <- tpsN2 , l <- tpsN1] -- BF=+1+ [newTree N l r | l <- tpsN2 , r <- tpsN1]) -- BF=-1+ [newTree Z l r | l <- tpsN1 , r <- tpsN1] -- BF= 0+ pN0 = (hN0,tsN0)+ in hN0 `seq` pN0 : moreTrees pN0 pN1+ -- Generate a new (tree,size) pair using the supplied constructor+ newTree con (l,sizel) (r,sizer) =+ let rootEl = sizel -- Value of new root element+ addRight = sizel+1 -- Offset to add to elements of right sub-tree+ newSize = addRight + sizer -- Size of the new tree+ r' = map' (addRight+) r+ t = r' `seq` con l rootEl r'+ in newSize `seq` t `seq` (t, newSize)+ -- interleave two lists (until one or other is [])+ interleave [] ys = ys+ interleave xs [] = xs+ interleave (x:xs) (y:ys) = (x:y:interleave xs ys)+++-- | Same as 'allAVL', but excluding the empty tree (of height 0).+allNonEmptyAVL :: TestTrees+allNonEmptyAVL = drop 1 allAVL++-- | Returns the number of possible AVL trees of a given height.+--+-- Behaves as if defined..+--+-- > numTrees h = (\(_,xs) -> length xs) (allAVL !! h)+--+-- and satisfies this recurrence relation..+--+-- @+-- numTrees 0 = 1+-- numTrees 1 = 1+-- numTrees h = (2*(numTrees (h-2)) + (numTrees (h-1))) * (numTrees (h-1))+-- @+numTrees :: Int -> Integer+numTrees 0 = 1+numTrees 1 = 1+numTrees n = numTrees' 1 1 n where+ numTrees' n1 n2 2 = (2*n2 + n1)*n1+ numTrees' n1 n2 m = numTrees' ((2*n2 + n1)*n1) n1 (m-1)++-- | Apply the test function to each AVL tree in the TestTrees argument, and report+-- progress as test proceeds. The first two arguments of the test function are+-- tree height and size respectively.+exhaustiveTest :: (Int -> Int -> AVL Int -> Bool) -> TestTrees -> IO ()+exhaustiveTest f xs = mapM_ test xs where+ test (h,tps) = do putStr "Tree Height : " >> print h+ putStr "Number Of Trees: " >> print (numTrees h)+ mapM_ test' tps+ putStrLn "Done."+ where test' (t,s) = if f h s t then return () -- putStr "."+ else error $ show $ asListL t -- Temporary Hack++-- | Generates a flat AVL tree of n elements [0..n-1].+flatAVL :: Int -> AVL Int+flatAVL n = asTreeLenL n [0..n-1]