AvlTree 3.2 → 4.0
raw patch · 9 files changed
+581/−67 lines, 9 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
- Data.Tree.AVL: instance (Read e) => Read (AVL e)
- Data.Tree.AVL: instance (Show e) => Show (AVL e)
+ Data.Tree.AVL: genDisjointUnion :: (e -> e -> Ordering) -> AVL 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.Test.AllTests: testGenDisjointUnion :: IO ()
+ Data.Tree.AVL.Test.AllTests: testGenVenn :: IO ()
+ Data.Tree.AVL.Test.AllTests: testGenVennMaybe :: IO ()
Files
- AvlTree.cabal +1/−1
- CHANGELOG +17/−2
- Data/Tree/AVL.hs +2/−0
- Data/Tree/AVL/Internals/HSet.hs +311/−48
- Data/Tree/AVL/Set.hs +142/−15
- Data/Tree/AVL/Test/AllTests.hs +105/−0
- Data/Tree/AVL/Types.hs +1/−1
- include/ghcdefs.h +1/−0
- include/h98defs.h +1/−0
AvlTree.cabal view
@@ -1,5 +1,5 @@ Name: AvlTree-Version: 3.2+Version: 4.0 Cabal-Version: >= 1.2 Build-Type: Simple License: BSD3
CHANGELOG view
@@ -9,8 +9,8 @@ * Eq and Ord Instances now based on strict structural equality (derived) * Exposed height related functions -3.1 (Final release) -------------------- +3.1 +--- * Exposed BinPath primitives. * Removed AVL tree based sorts. * Removed Data.Map/Set conversions. This eliminates the containers package dependency. @@ -20,3 +20,18 @@ 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 +
Data/Tree/AVL.hs view
@@ -84,6 +84,7 @@ traverse = traverseAVL #endif +{- These are now derived since switch to structural equality! -- | Show is based on showing the list produced by 'asListL'. This definition has been placed here -- to avoid introducing cyclic dependency between Types.hs and List.hs instance Show e => Show (AVL e) where@@ -95,6 +96,7 @@ 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
Data/Tree/AVL/Internals/HSet.hs view
@@ -14,13 +14,16 @@ ----------------------------------------------------------------------------- module Data.Tree.AVL.Internals.HSet (-- * Union primitives.- unionH,unionMaybeH,+ unionH,unionMaybeH,disjointUnionH, -- * Intersection primitives. intersectionH,intersectionMaybeH, -- * Difference primitives. differenceH,differenceMaybeH,symDifferenceH,++ -- * Venn primitives+ vennH,vennMaybeH, ) where import Data.Tree.AVL.Types(AVL(..))@@ -40,7 +43,7 @@ -- 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.+-- 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@@ -119,7 +122,7 @@ -- | 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.+-- 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)@@ -207,13 +210,74 @@ ----------------------------------------------------------------------- +-- | 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.+-- Complexity: Not sure, but I\'d appreciate it if someone could figure it out. intersectionH :: (a -> b -> COrdering c) -> AVL a -> AVL b -> UBT2(AVL c,UINT)-intersectionH comp = i where+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))@@ -227,7 +291,7 @@ 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+ 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)@@ -270,7 +334,7 @@ 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+ 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_)@@ -284,7 +348,7 @@ 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+ 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)@@ -299,7 +363,7 @@ -- | 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.+-- 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)@@ -394,7 +458,7 @@ -- 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.+-- 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)@@ -484,7 +548,7 @@ -- 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.+-- 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)@@ -573,7 +637,7 @@ -- | 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.+-- 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)@@ -591,9 +655,9 @@ u_ l0 hl0 e0 r0 hr0 l1 hl1 e1 r1 hr1 = case c e0 e1 of -- e0 < e1, so (l0 < e0 < e1) & (e0 < e1 < r1)- LT -> case forkR r0 hr0 e1 of- UBT5(rl0,hrl0,be1,rr0,hrr0) -> case forkL e0 l1 hl1 of -- (e0 < rl0 < e1) & (e0 < e1 < rr0)- UBT5(ll1,hll1,be0,lr1,hlr1) -> -- (ll1 < e0 < e1) & (e0 < lr1 < e1)+ 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@@ -608,9 +672,9 @@ UBT2(l,hl) -> case u r0 hr0 r1 hr1 of UBT2(r,hr) -> joinH l hl r hr -- e1 < e0, so (l1 < e1 < e0) & (e1 < e0 < r0)- GT -> case forkL e0 r1 hr1 of- UBT5(rl1,hrl1,be0,rr1,hrr1) -> case forkR l0 hl0 e1 of -- (e1 < rl1 < e0) & (e1 < e0 < rr1)- UBT5(ll0,hll0,be1,lr0,hlr0) -> -- (ll0 < e1 < e0) & (e1 < lr0 < e0)+ 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@@ -620,36 +684,235 @@ ) of UBT2(t,ht) -> if be0 then spliceH t ht e0 r hr else joinH t ht r hr- -- We need 2 different versions of fork (L & R) to ensure that comparison arguments are used in- -- the right order (c e0 e1)- -- forkL :: e -> AVL e -> UINT -> UBT5(AVL e,UINT,Bool,AVL e,UINT)- forkL e0 t1 ht1 = forkL_ t1 ht1 where- forkL_ E _ = UBT5(E, L(0), True, E, L(0))- forkL_ (N l e r) h = forkL__ l DECINT2(h) e r DECINT1(h)- forkL_ (Z l e r) h = forkL__ l DECINT1(h) e r DECINT1(h)- forkL_ (P l e r) h = forkL__ l DECINT1(h) e r DECINT2(h)- forkL__ l hl e r hr = case c e0 e of- LT -> case forkL_ l hl of- UBT5(l0,hl0,be0,l1,hl1) -> case spliceH l1 hl1 e r hr of- UBT2(l1_,hl1_) -> UBT5(l0,hl0,be0,l1_,hl1_)- EQ -> UBT5(l,hl,False,r,hr)- GT -> case forkL_ r hr of- UBT5(l0,hl0,be0,l1,hl1) -> case spliceH l hl e l0 hl0 of- UBT2(l0_,hl0_) -> UBT5(l0_,hl0_,be0,l1,hl1)- -- forkR :: AVL e -> UINT -> e -> UBT5(AVL e,UINT,Bool,AVL e,UINT)- forkR t0 ht0 e1 = forkR_ t0 ht0 where- forkR_ E _ = UBT5(E, L(0), True, E, L(0))- forkR_ (N l e r) h = forkR__ l DECINT2(h) e r DECINT1(h)- forkR_ (Z l e r) h = forkR__ l DECINT1(h) e r DECINT1(h)- forkR_ (P l e r) h = forkR__ l DECINT1(h) e r DECINT2(h)- forkR__ l hl e r hr = case c e e1 of- LT -> case forkR_ r hr of- UBT5(l0,hl0,be1,l1,hl1) -> case spliceH l hl e l0 hl0 of- UBT2(l0_,hl0_) -> UBT5(l0_,hl0_,be1,l1,hl1)- EQ -> UBT5(l,hl,False,r,hr)- GT -> case forkR_ l hl of- UBT5(l0,hl0,be1,l1,hl1) -> case spliceH l1 hl1 e r hr of- UBT2(l1_,hl1_) -> UBT5(l0,hl0,be1,l1_,hl1_)+ -- 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 h = UBT5(E,h,Nothing,E,h)+ f (N l b r) h = f_ l DECINT2(h) b r DECINT1(h)+ f (Z l b r) h = f_ l DECINT1(h) b r DECINT1(h)+ f (P l b r) h = f_ l DECINT1(h) b r DECINT2(h)+ f_ 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)+forkb :: (a -> b -> COrdering c) -> b -> AVL a -> UINT -> UBT5(AVL a,UINT,Maybe c,AVL a,UINT)+forkb cmp b ta hta = f ta hta where+ f E h = UBT5(E,h,Nothing,E,h)+ f (N l a r) h = f_ l DECINT2(h) a r DECINT1(h)+ f (Z l a r) h = f_ l DECINT1(h) a r DECINT1(h)+ f (P l a r) h = f_ l DECINT1(h) a r DECINT2(h)+ f_ l hl a r hr = case cmp a b of+ Lt -> case f r hr of+ UBT5(rl,hrl,mbc,rr,hrr) -> case spliceH l hl a rl hrl of+ UBT2(l_,hl_) -> UBT5(l_,hl_,mbc,rr,hrr)+ Eq c -> UBT5(l,hl,Just c,r,hr)+ Gt -> case f l hl of+ UBT5(ll,hll,mbc,lr,hlr) -> case spliceH lr hlr a r hr of+ UBT2(r_,hr_) -> UBT5(ll,hll,mbc,r_,hr_)++
Data/Tree/AVL/Set.hs view
@@ -17,7 +17,7 @@ -- as a field value in a record). -- ** Union- genUnion,genUnionMaybe,genUnions,+ genUnion,genUnionMaybe,genDisjointUnion,genUnions, -- ** Difference genDifference,genDifferenceMaybe,genSymDifference,@@ -38,6 +38,20 @@ genIntersectionToListL,genIntersectionAsListL, genIntersectionMaybeToListL,genIntersectionMaybeAsListL, + -- ** \'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 'genDisjointUnion'.+ genVenn,genVennMaybe,++ -- *** \'Venn diagram\' operations with the intersection component as a List.+ -- | These variants are provided for the same reasons as the Intersection as List variants.+ genVennToList,genVennAsList,+ genVennMaybeToList,genVennMaybeAsList,+ -- ** Subset genIsSubsetOf,genIsSubsetOfBy @@ -47,9 +61,11 @@ 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,+import Data.Tree.AVL.Internals.HSet(unionH,unionMaybeH,disjointUnionH, intersectionH,intersectionMaybeH,+ vennH,vennMaybeH, differenceH,differenceMaybeH,symDifferenceH) import Data.COrdering@@ -65,7 +81,7 @@ -- 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.+-- Complexity: Not sure, but I\'d appreciate it if someone could figure it out. -- (Faster than Hedge union from Data.Set at any rate). genUnion :: (e -> e -> COrdering e) -> AVL e -> AVL e -> AVL e genUnion c = gu where -- This is to avoid O(log n) height calculation for empty sets@@ -85,7 +101,7 @@ -- | Similar to 'genUnion', but the resulting tree does not include elements in cases where -- the supplied combining comparison returns @(Eq Nothing)@. ----- Complexity: Not sure, but I'd appreciate it if someone could figure it out.+-- Complexity: Not sure, but I\'d appreciate it if someone could figure it out. genUnionMaybe :: (e -> e -> COrdering (Maybe e)) -> AVL e -> AVL e -> AVL e genUnionMaybe c = gu where -- This is to avoid O(log n) height calculation for empty sets gu E t1 = t1@@ -101,6 +117,28 @@ 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 'genUnion' but will raise an error if the+-- two sets intersect. Typically this would be used to re-combine the \"post-munge\" results+-- from one of the \"venn\" operations.+--+-- Complexity: Not sure, but I\'d appreciate it if someone could figure it out.+-- (Faster than Hedge union from Data.Set at any rate).+genDisjointUnion :: (e -> e -> Ordering) -> AVL e -> AVL e -> AVL e+genDisjointUnion c = gu where -- This is to avoid O(log n) height calculation for empty sets+ 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.. --@@ -116,14 +154,14 @@ -- | 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.+-- Complexity: Not sure, but I\'d appreciate it if someone could figure it out. genIntersection :: (a -> b -> COrdering c) -> AVL a -> AVL b -> AVL c genIntersection c t0 t1 = case intersectionH c t0 t1 of UBT2(t,_) -> t -- | Similar to 'genIntersection', but the resulting tree does not include elements in cases where -- the supplied combining comparison returns @(Eq Nothing)@. ----- Complexity: Not sure, but I'd appreciate it if someone could figure it out.+-- Complexity: Not sure, but I\'d appreciate it if someone could figure it out. genIntersectionMaybe :: (a -> b -> COrdering (Maybe c)) -> AVL a -> AVL b -> AVL c genIntersectionMaybe c t0 t1 = case intersectionMaybeH c t0 t1 of UBT2(t,_) -> t @@ -132,7 +170,7 @@ -- -- @genIntersectionToListL c setA setB cs = asListL (genIntersection c setA setB) ++ cs@ ----- Complexity: Not sure, but I'd appreciate it if someone could figure it out.+-- Complexity: Not sure, but I\'d appreciate it if someone could figure it out. genIntersectionToListL :: (a -> b -> COrdering c) -> AVL a -> AVL b -> [c] -> [c] genIntersectionToListL comp = i where -- i :: AVL a -> AVL b -> [c] -> [c]@@ -211,14 +249,14 @@ -- | Applies 'genIntersectionToListL' to the empty list. ----- Complexity: Not sure, but I'd appreciate it if someone could figure it out.+-- Complexity: Not sure, but I\'d appreciate it if someone could figure it out. genIntersectionAsListL :: (a -> b -> COrdering c) -> AVL a -> AVL b -> [c] genIntersectionAsListL c setA setB = genIntersectionToListL c setA setB [] -- | Similar to 'genIntersectionToListL', but the result does not include elements in cases where -- the supplied combining comparison returns @(Eq Nothing)@. ----- Complexity: Not sure, but I'd appreciate it if someone could figure it out.+-- Complexity: Not sure, but I\'d appreciate it if someone could figure it out. genIntersectionMaybeToListL :: (a -> b -> COrdering (Maybe c)) -> AVL a -> AVL b -> [c] -> [c] genIntersectionMaybeToListL comp = i where -- i :: AVL a -> AVL b -> [c] -> [c]@@ -299,7 +337,7 @@ -- | Applies 'genIntersectionMaybeToListL' to the empty list. ----- Complexity: Not sure, but I'd appreciate it if someone could figure it out.+-- Complexity: Not sure, but I\'d appreciate it if someone could figure it out. genIntersectionMaybeAsListL :: (a -> b -> COrdering (Maybe c)) -> AVL a -> AVL b -> [c] genIntersectionMaybeAsListL c setA setB = genIntersectionMaybeToListL c setA setB [] @@ -310,7 +348,7 @@ -- -- .. 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.+-- Complexity: Not sure, but I\'d appreciate it if someone could figure it out. genDifference :: (a -> b -> Ordering) -> AVL a -> AVL b -> AVL a -- N.B. differenceH works with relative heights on first tree, and needs no height for the second. genDifference c t0 t1 = case differenceH c t0 L(0) t1 of UBT2(t,_) -> t@@ -318,7 +356,7 @@ -- | Similar to 'genDifference', but the resulting tree also includes those elements a\' for which the -- combining comparison returns @(Eq (Just a\'))@. ----- Complexity: Not sure, but I'd appreciate it if someone could figure it out.+-- Complexity: Not sure, but I\'d appreciate it if someone could figure it out. genDifferenceMaybe :: (a -> b -> COrdering (Maybe a)) -> AVL a -> AVL b -> AVL a -- N.B. differenceMaybeH works with relative heights on first tree, and needs no height for the second. genDifferenceMaybe c t0 t1 = case differenceMaybeH c t0 L(0) t1 of UBT2(t,_) -> t@@ -333,7 +371,7 @@ -- -- * 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.+-- Complexity: Not sure, but I\'d appreciate it if someone could figure it out. genIsSubsetOf :: (a -> b -> Ordering) -> AVL a -> AVL b -> Bool genIsSubsetOf comp = s where -- s :: AVL a -> AVL b -> Bool@@ -401,7 +439,7 @@ -- | Similar to 'genIsSubsetOf', but also requires that the supplied combining -- comparison returns @('Eq' True)@ for matching elements. ----- Complexity: Not sure, but I'd appreciate it if someone could figure it out.+-- Complexity: Not sure, but I\'d appreciate it if someone could figure it out. genIsSubsetOfBy :: (a -> b -> COrdering Bool) -> AVL a -> AVL b -> Bool genIsSubsetOfBy comp = s where -- s :: AVL a -> AVL b -> Bool@@ -473,7 +511,7 @@ -- | 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.+-- Complexity: Not sure, but I\'d appreciate it if someone could figure it out. genSymDifference :: (e -> e -> Ordering) -> AVL e -> AVL e -> AVL e genSymDifference c = gu where -- This is to avoid O(log n) height calculation for empty sets gu E t1 = t1@@ -488,4 +526,93 @@ 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 'genVennMaybe'.+--+-- Complexity: Not sure, but I\'d appreciate it if someone could figure it out.+genVenn :: (a -> b -> COrdering c) -> AVL a -> AVL b -> (AVL a, AVL c, AVL b)+genVenn c = gu where -- This is to avoid O(log n) height calculation for empty sets+ 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,_) -> (tab,asTreeLenL ASINT(cl) cs,tba)++-- | Similar to 'genVenn', but intersection elements for which the combining comparison+-- returns @('Eq' 'Nothing')@ are deleted from the intersection result.+--+-- Complexity: Not sure, but I\'d appreciate it if someone could figure it out.+genVennMaybe :: (a -> b -> COrdering (Maybe c)) -> AVL a -> AVL b -> (AVL a, AVL c, AVL b)+genVennMaybe c = gu where -- This is to avoid O(log n) height calculation for empty sets+ 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,_) -> (tab,asTreeLenL ASINT(cl) cs,tba)++-- | Same as 'genVenn', but prepends the intersection component to the supplied list+-- in ascending order.+genVennToList :: (a -> b -> COrdering c) -> [c] -> AVL a -> AVL b -> (AVL a, [c], AVL b)+genVennToList cmp cs = gu where -- This is to avoid O(log n) height calculation for empty sets+ 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 'genVennMaybe', but prepends the intersection component to the supplied list+-- in ascending order.+genVennMaybeToList :: (a -> b -> COrdering (Maybe c)) -> [c] -> AVL a -> AVL b -> (AVL a, [c], AVL b)+genVennMaybeToList cmp cs = gu where -- This is to avoid O(log n) height calculation for empty sets+ 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 'genVenn', but returns the intersection component as a list in ascending order.+-- This is just 'genVennToList' applied to an empty initial intersection list.+genVennAsList :: (a -> b -> COrdering c) -> AVL a -> AVL b -> (AVL a, [c], AVL b)+{-# INLINE genVennAsList #-}+genVennAsList cmp = genVennToList cmp []++-- | Same as 'genVennMaybe', but returns the intersection component as a list in ascending order.+-- This is just 'genVennMaybeToList' applied to an empty initial intersection list.+genVennMaybeAsList :: (a -> b -> COrdering (Maybe c)) -> AVL a -> AVL b -> (AVL a, [c], AVL b)+{-# INLINE genVennMaybeAsList #-}+genVennMaybeAsList cmp = genVennMaybeToList cmp []
Data/Tree/AVL/Test/AllTests.hs view
@@ -81,6 +81,7 @@ ,testGenTakeGE ,testGenTakeLT ,testGenUnion+,testGenDisjointUnion ,testGenUnionMaybe ,testGenIntersection ,testGenIntersectionMaybe@@ -91,6 +92,8 @@ ,testGenSymDifference ,testGenIsSubsetOf ,testGenIsSubsetOfBy+,testGenVenn+,testGenVennMaybe ,testCompareHeight ,testShowReadEq -- Zipper tests@@ -206,6 +209,7 @@ testGenTakeGE testGenTakeLT testGenUnion+ testGenDisjointUnion testGenUnionMaybe testGenIntersection testGenIntersectionMaybe@@ -216,6 +220,8 @@ testGenSymDifference testGenIsSubsetOf testGenIsSubsetOfBy+ testGenVenn+ testGenVennMaybe testCompareHeight testShowReadEq -- Zipper tests@@ -887,6 +893,23 @@ in isSortedOK compare u && (size u == ls+rs) unionFst = genUnion fstCC +-- | Test the genDisjointUnion function+testGenDisjointUnion :: IO ()+testGenDisjointUnion =+ let trees = take num $ concatMap (\(_,ts) -> ts) allAVL+ num = 1000+ in do title "genDisjointUnion"+ putStrLn $ "Testing " ++ show (num*num) ++ " tree pairs.."+ if and [test (mapAVL' (\n -> 2*n) l) ls (mapAVL' (\n -> 2*n+1) r) rs+ | (l,ls) <- trees -- 0,2..2*ls-2+ , (r,rs) <- trees -- 1,3..2*rs-1+ ]+ then passed+ else failed+ where test l ls r rs = all (\f -> f l ls r rs) [test1]+ test1 l ls r rs = and [test1_ $ mapAVL' (+(2*n)) r | n <- [(-rs)..(ls-1)]]+ where test1_ r_ = let u = genDisjointUnion compare l r_+ in isBalanced u && (asListL u == listUnion (asListL l) (asListL r_)) -- | Test the genSymDifference function testGenSymDifference :: IO ()@@ -1114,7 +1137,51 @@ (r `isSubsetOf'` l == ((rs<=ls) && (n>=rs))) where isSubsetOf' = genIsSubsetOfBy (withCC (\m _ -> m /= n)) +-- | Test the genVenn function+testGenVenn :: IO ()+testGenVenn =+ let trees = concatMap (\(_,ts) -> ts) (take 5 allAVL) -- All trees of height 4 or less = 335 trees (112,225 pairs)+ num = length trees+ in do title "genVenn"+ putStrLn $ "Testing " ++ show (num*num) ++ " tree pairs.."+ if and [test l ls r rs | (l,ls) <- trees, (r,rs) <- trees] then passed else failed+ where test l ls r rs = all (\f -> f l ls r rs) [test1,test2]+ test1 l ls r rs = let (lr,i,rl) = venn l r+ in and [all isBalanced [lr,i,rl]+ ,asListL lr == listDiff [0..ls-1] [0..rs-1]+ ,asListL i == listIntersection [0..ls-1] [0..rs-1]+ ,asListL rl == listDiff [0..rs-1] [0..ls-1]+ ]+ test2 l ls r rs = and [test2_ $ mapAVL' (n+) r | n <- [(-rs)..ls]]+ where test2_ r_ = let (lr,i,rl) = venn l r_+ in and [all isBalanced [lr,i,rl]+ ,asListL lr == listDiff (asListL l ) (asListL r_)+ ,asListL i == listIntersection (asListL l ) (asListL r_)+ ,asListL rl == listDiff (asListL r_) (asListL l )+ ]+ venn = genVenn fstCC +-- | Test the genVennMaybe function+testGenVennMaybe :: IO ()+testGenVennMaybe =+ let trees = concatMap (\(_,ts) -> ts) (take 5 allAVL) -- All trees of height 4 or less = 335 trees (112,225 pairs)+ num = length trees+ in do title "genVennMaybe"+ putStrLn $ "Testing " ++ show (num*num) ++ " tree pairs.."+ if and [test l ls r rs | (l,ls) <- trees, (r,rs) <- trees] then passed else failed+ where test l ls r rs = and [t cmp l ls r rs| t<-[test1], cmp<-[cmpAll,cmpNone,cmpEven,cmpOdd]]+ test1 cmp l ls r rs = and [test1_ $ mapAVL' (n+) r | n <- [(-rs)..ls]]+ where test1_ r_ = let (lr,i,rl) = genVennMaybe cmp l r_+ in and [all isBalanced [lr,i,rl]+ ,asListL lr == listDiff (asListL l ) (asListL r_)+ ,asListL rl == listDiff (asListL r_) (asListL l )+ ,asListL i == listIntersectionMaybe cmp (asListL l ) (asListL r_)+ ]+ cmpAll = withCC' (\x _ -> Just x)+ cmpNone = withCC' (\_ _ -> Nothing)+ cmpEven = withCC' (\x _ -> if even x then Just x else Nothing)+ cmpOdd = withCC' (\x _ -> if odd x then Just x else Nothing)+ -- | Test compareHeight function testCompareHeight :: IO () testCompareHeight = let trees = take num $ concatMap (\(h,ts) -> [(t,h)|(t,_)<-ts]) allAVL@@ -1402,4 +1469,42 @@ 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/Types.hs view
@@ -94,7 +94,7 @@ | 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)+ deriving(Eq,Ord,Show,Read) -- A name for the AVL type constructor, fully qualified avlTyConName :: String
include/ghcdefs.h view
@@ -21,5 +21,6 @@ #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) (iShiftL# (m) (32#-#n))
include/h98defs.h view
@@ -21,5 +21,6 @@ #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))