diff --git a/AvlTree.cabal b/AvlTree.cabal --- a/AvlTree.cabal +++ b/AvlTree.cabal @@ -1,5 +1,5 @@ Name: AvlTree -Version: 3.2 +Version: 4.0 Cabal-Version: >= 1.2 Build-Type: Simple License: BSD3 diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -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 + diff --git a/Data/Tree/AVL.hs b/Data/Tree/AVL.hs --- a/Data/Tree/AVL.hs +++ b/Data/Tree/AVL.hs @@ -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 diff --git a/Data/Tree/AVL/Internals/HSet.hs b/Data/Tree/AVL/Internals/HSet.hs --- a/Data/Tree/AVL/Internals/HSet.hs +++ b/Data/Tree/AVL/Internals/HSet.hs @@ -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_) + + diff --git a/Data/Tree/AVL/Set.hs b/Data/Tree/AVL/Set.hs --- a/Data/Tree/AVL/Set.hs +++ b/Data/Tree/AVL/Set.hs @@ -17,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 [] diff --git a/Data/Tree/AVL/Test/AllTests.hs b/Data/Tree/AVL/Test/AllTests.hs --- a/Data/Tree/AVL/Test/AllTests.hs +++ b/Data/Tree/AVL/Test/AllTests.hs @@ -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' diff --git a/Data/Tree/AVL/Types.hs b/Data/Tree/AVL/Types.hs --- a/Data/Tree/AVL/Types.hs +++ b/Data/Tree/AVL/Types.hs @@ -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 diff --git a/include/ghcdefs.h b/include/ghcdefs.h --- a/include/ghcdefs.h +++ b/include/ghcdefs.h @@ -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)) diff --git a/include/h98defs.h b/include/h98defs.h --- a/include/h98defs.h +++ b/include/h98defs.h @@ -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))