+
+-- insertMin and insertMax don't perform potentially expensive comparisons.
+insertMax,insertMin :: a -> Set a -> Set a
+insertMax x t
+ = case t of
+ Tip -> singleton x
+ Bin sz y l r
+ -> balance y l (insertMax x r)
+
+insertMin x t
+ = case t of
+ Tip -> singleton x
+ Bin sz y l r
+ -> balance y (insertMin x l) r
+
+{--------------------------------------------------------------------
+ [merge l r]: merges two trees.
+--------------------------------------------------------------------}
+merge :: Set a -> Set a -> Set a
+merge Tip r = r
+merge l Tip = l
+merge l@(Bin sizeL x lx rx) r@(Bin sizeR y ly ry)
+ | delta*sizeL <= sizeR = balance y (merge l ly) ry
+ | delta*sizeR <= sizeL = balance x lx (merge rx r)
+ | otherwise = glue l r
+
+{--------------------------------------------------------------------
+ [glue l r]: glues two trees together.
+ Assumes that [l] and [r] are already balanced with respect to each other.
+--------------------------------------------------------------------}
+glue :: Set a -> Set a -> Set a
+glue Tip r = r
+glue l Tip = l
+glue l r
+ | size l > size r = let (m,l') = deleteFindMax l in balance m l' r
+ | otherwise = let (m,r') = deleteFindMin r in balance m l r'
+
+
+-- | /O(log n)/. Delete and find the minimal element.
+--
+-- > deleteFindMin set = (findMin set, deleteMin set)
+
+deleteFindMin :: Set a -> (a,Set a)
+deleteFindMin t
+ = case t of
+ Bin _ x Tip r -> (x,r)
+ Bin _ x l r -> let (xm,l') = deleteFindMin l in (xm,balance x l' r)
+ Tip -> (error "Set.deleteFindMin: can not return the minimal element of an empty set", Tip)
+
+-- | /O(log n)/. Delete and find the maximal element.
+--
+-- > deleteFindMax set = (findMax set, deleteMax set)
+deleteFindMax :: Set a -> (a,Set a)
+deleteFindMax t
+ = case t of
+ Bin _ x l Tip -> (x,l)
+ Bin _ x l r -> let (xm,r') = deleteFindMax r in (xm,balance x l r')
+ Tip -> (error "Set.deleteFindMax: can not return the maximal element of an empty set", Tip)
+
+
+{--------------------------------------------------------------------
+ [balance x l r] balances two trees with value x.
+ The sizes of the trees should balance after decreasing the
+ size of one of them. (a rotation).
+
+ [delta] is the maximal relative difference between the sizes of
+ two trees, it corresponds with the [w] in Adams' paper,
+ or equivalently, [1/delta] corresponds with the $\alpha$
+ in Nievergelt's paper. Adams shows that [delta] should
+ be larger than 3.745 in order to garantee that the
+ rotations can always restore balance.
+
+ [ratio] is the ratio between an outer and inner sibling of the
+ heavier subtree in an unbalanced setting. It determines
+ whether a double or single rotation should be performed
+ to restore balance. It is correspondes with the inverse
+ of $\alpha$ in Adam's article.
+
+ Note that:
+ - [delta] should be larger than 4.646 with a [ratio] of 2.
+ - [delta] should be larger than 3.745 with a [ratio] of 1.534.
+
+ - A lower [delta] leads to a more 'perfectly' balanced tree.
+ - A higher [delta] performs less rebalancing.
+
+ - Balancing is automatic for random data and a balancing
+ scheme is only necessary to avoid pathological worst cases.
+ Almost any choice will do in practice
+
+ - Allthough it seems that a rather large [delta] may perform better
+ than smaller one, measurements have shown that the smallest [delta]
+ of 4 is actually the fastest on a wide range of operations. It
+ especially improves performance on worst-case scenarios like
+ a sequence of ordered insertions.
+
+ Note: in contrast to Adams' paper, we use a ratio of (at least) 2
+ to decide whether a single or double rotation is needed. Allthough
+ he actually proves that this ratio is needed to maintain the
+ invariants, his implementation uses a (invalid) ratio of 1.
+ He is aware of the problem though since he has put a comment in his
+ original source code that he doesn't care about generating a
+ slightly inbalanced tree since it doesn't seem to matter in practice.
+ However (since we use quickcheck :-) we will stick to strictly balanced
+ trees.
+--------------------------------------------------------------------}
+delta,ratio :: Int
+delta = 4
+ratio = 2
+
+balance :: a -> Set a -> Set a -> Set a
+balance x l r
+ | sizeL + sizeR <= 1 = Bin sizeX x l r
+ | sizeR >= delta*sizeL = rotateL x l r
+ | sizeL >= delta*sizeR = rotateR x l r
+ | otherwise = Bin sizeX x l r
+ where
+ sizeL = size l
+ sizeR = size r
+ sizeX = sizeL + sizeR + 1
+
+-- rotate
+rotateL x l r@(Bin _ _ ly ry)
+ | size ly < ratio*size ry = singleL x l r
+ | otherwise = doubleL x l r
+
+rotateR x l@(Bin _ _ ly ry) r
+ | size ry < ratio*size ly = singleR x l r
+ | otherwise = doubleR x l r
+
+-- basic rotations
+singleL x1 t1 (Bin _ x2 t2 t3) = bin x2 (bin x1 t1 t2) t3
+singleR x1 (Bin _ x2 t1 t2) t3 = bin x2 t1 (bin x1 t2 t3)
+
+doubleL x1 t1 (Bin _ x2 (Bin _ x3 t2 t3) t4) = bin x3 (bin x1 t1 t2) (bin x2 t3 t4)
+doubleR x1 (Bin _ x2 t1 (Bin _ x3 t2 t3)) t4 = bin x3 (bin x2 t1 t2) (bin x1 t3 t4)
+
+
+{--------------------------------------------------------------------
+ The bin constructor maintains the size of the tree
+--------------------------------------------------------------------}
+bin :: a -> Set a -> Set a -> Set a
+bin x l r
+ = Bin (size l + size r + 1) x l r
+
+
+{--------------------------------------------------------------------
+ Utilities
+--------------------------------------------------------------------}
+foldlStrict f z xs
+ = case xs of
+ [] -> z
+ (x:xx) -> let z' = f z x in seq z' (foldlStrict f z' xx)
+
+
+{--------------------------------------------------------------------
+ Debugging
+--------------------------------------------------------------------}
+-- | /O(n)/. Show the tree that implements the set. The tree is shown
+-- in a compressed, hanging format.
+showTree :: Show a => Set a -> String
+showTree s
+ = showTreeWith True False s
+
+
+{- | /O(n)/. The expression (@showTreeWith hang wide map@) shows
+ the tree that implements the set. If @hang@ is
+ @True@, a /hanging/ tree is shown otherwise a rotated tree is shown. If
+ @wide@ is true, an extra wide version is shown.
+
+> Set> putStrLn $ showTreeWith True False $ fromDistinctAscList [1..5]
+> 4
+> +--2
+> | +--1
+> | +--3
+> +--5
+>
+> Set> putStrLn $ showTreeWith True True $ fromDistinctAscList [1..5]
+> 4
+> |
+> +--2
+> | |
+> | +--1
+> | |
+> | +--3
+> |
+> +--5
+>
+> Set> putStrLn $ showTreeWith False True $ fromDistinctAscList [1..5]
+> +--5
+> |
+> 4
+> |
+> | +--3
+> | |
+> +--2
+> |
+> +--1
+
+-}
+showTreeWith :: Show a => Bool -> Bool -> Set a -> String
+showTreeWith hang wide t
+ | hang = (showsTreeHang wide [] t) ""
+ | otherwise = (showsTree wide [] [] t) ""
+
+showsTree :: Show a => Bool -> [String] -> [String] -> Set a -> ShowS
+showsTree wide lbars rbars t
+ = case t of
+ Tip -> showsBars lbars . showString "|\n"
+ Bin sz x Tip Tip
+ -> showsBars lbars . shows x . showString "\n"
+ Bin sz x l r
+ -> showsTree wide (withBar rbars) (withEmpty rbars) r .
+ showWide wide rbars .
+ showsBars lbars . shows x . showString "\n" .
+ showWide wide lbars .
+ showsTree wide (withEmpty lbars) (withBar lbars) l
+
+showsTreeHang :: Show a => Bool -> [String] -> Set a -> ShowS
+showsTreeHang wide bars t
+ = case t of
+ Tip -> showsBars bars . showString "|\n"
+ Bin sz x Tip Tip
+ -> showsBars bars . shows x . showString "\n"
+ Bin sz x l r
+ -> showsBars bars . shows x . showString "\n" .
+ showWide wide bars .
+ showsTreeHang wide (withBar bars) l .
+ showWide wide bars .
+ showsTreeHang wide (withEmpty bars) r
+
+
+showWide wide bars
+ | wide = showString (concat (reverse bars)) . showString "|\n"
+ | otherwise = id
+
+showsBars :: [String] -> ShowS
+showsBars bars
+ = case bars of
+ [] -> id
+ _ -> showString (concat (reverse (tail bars))) . showString node
+
+node = "+--"
+withBar bars = "| ":bars
+withEmpty bars = " ":bars
+
+{--------------------------------------------------------------------
+ Assertions
+--------------------------------------------------------------------}
+-- | /O(n)/. Test if the internal set structure is valid.
+valid :: Ord a => Set a -> Bool
+valid t
+ = balanced t && ordered t && validsize t
+
+ordered t
+ = bounded (const True) (const True) t
+ where
+ bounded lo hi t
+ = case t of
+ Tip -> True
+ Bin sz x l r -> (lo x) && (hi x) && bounded lo (<x) l && bounded (>x) hi r
+
+balanced :: Set a -> Bool
+balanced t
+ = case t of
+ Tip -> True
+ Bin sz x l r -> (size l + size r <= 1 || (size l <= delta*size r && size r <= delta*size l)) &&
+ balanced l && balanced r
+
+
+validsize t
+ = (realsize t == Just (size t))
+ where
+ realsize t
+ = case t of
+ Tip -> Just 0
+ Bin sz x l r -> case (realsize l,realsize r) of
+ (Just n,Just m) | n+m+1 == sz -> Just sz
+ other -> Nothing
+
+{-
+{--------------------------------------------------------------------
+ Testing
+--------------------------------------------------------------------}
+testTree :: [Int] -> Set Int
+testTree xs = fromList xs
+test1 = testTree [1..20]
+test2 = testTree [30,29..10]
+test3 = testTree [1,4,6,89,2323,53,43,234,5,79,12,9,24,9,8,423,8,42,4,8,9,3]
+
+{--------------------------------------------------------------------
+ QuickCheck
+--------------------------------------------------------------------}
+qcheck prop
+ = check config prop
+ where
+ config = Config
+ { configMaxTest = 500
+ , configMaxFail = 5000
+ , configSize = \n -> (div n 2 + 3)
+ , configEvery = \n args -> let s = show n in s ++ [ '\b' | _ <- s ]
+ }
+
+
+{--------------------------------------------------------------------
+ Arbitrary, reasonably balanced trees
+--------------------------------------------------------------------}
+instance (Enum a) => Arbitrary (Set a) where
+ arbitrary = sized (arbtree 0 maxkey)
+ where maxkey = 10000
+
+arbtree :: (Enum a) => Int -> Int -> Int -> Gen (Set a)
+arbtree lo hi n
+ | n <= 0 = return Tip
+ | lo >= hi = return Tip
+ | otherwise = do{ i <- choose (lo,hi)
+ ; m <- choose (1,30)
+ ; let (ml,mr) | m==(1::Int)= (1,2)
+ | m==2 = (2,1)
+ | m==3 = (1,1)
+ | otherwise = (2,2)
+ ; l <- arbtree lo (i-1) (n `div` ml)
+ ; r <- arbtree (i+1) hi (n `div` mr)
+ ; return (bin (toEnum i) l r)
+ }
+
+
+{--------------------------------------------------------------------
+ Valid tree's
+--------------------------------------------------------------------}
+forValid :: (Enum a,Show a,Testable b) => (Set a -> b) -> Property
+forValid f
+ = forAll arbitrary $ \t ->
+-- classify (balanced t) "balanced" $
+ classify (size t == 0) "empty" $
+ classify (size t > 0 && size t <= 10) "small" $
+ classify (size t > 10 && size t <= 64) "medium" $
+ classify (size t > 64) "large" $
+ balanced t ==> f t
+
+forValidIntTree :: Testable a => (Set Int -> a) -> Property
+forValidIntTree f
+ = forValid f
+
+forValidUnitTree :: Testable a => (Set Int -> a) -> Property
+forValidUnitTree f
+ = forValid f
+
+
+prop_Valid
+ = forValidUnitTree $ \t -> valid t
+
+{--------------------------------------------------------------------
+ Single, Insert, Delete
+--------------------------------------------------------------------}
+prop_Single :: Int -> Bool
+prop_Single x
+ = (insert x empty == singleton x)
+
+prop_InsertValid :: Int -> Property
+prop_InsertValid k
+ = forValidUnitTree $ \t -> valid (insert k t)
+
+prop_InsertDelete :: Int -> Set Int -> Property
+prop_InsertDelete k t
+ = not (member k t) ==> delete k (insert k t) == t
+
+prop_DeleteValid :: Int -> Property
+prop_DeleteValid k
+ = forValidUnitTree $ \t ->
+ valid (delete k (insert k t))
+
+{--------------------------------------------------------------------
+ Balance
+--------------------------------------------------------------------}
+prop_Join :: Int -> Property
+prop_Join x
+ = forValidUnitTree $ \t ->
+ let (l,r) = split x t
+ in valid (join x l r)
+
+prop_Merge :: Int -> Property
+prop_Merge x
+ = forValidUnitTree $ \t ->
+ let (l,r) = split x t
+ in valid (merge l r)
+
+
+{--------------------------------------------------------------------
+ Union
+--------------------------------------------------------------------}
+prop_UnionValid :: Property
+prop_UnionValid
+ = forValidUnitTree $ \t1 ->
+ forValidUnitTree $ \t2 ->
+ valid (union t1 t2)
+
+prop_UnionInsert :: Int -> Set Int -> Bool
+prop_UnionInsert x t
+ = union t (singleton x) == insert x t
+
+prop_UnionAssoc :: Set Int -> Set Int -> Set Int -> Bool
+prop_UnionAssoc t1 t2 t3
+ = union t1 (union t2 t3) == union (union t1 t2) t3
+
+prop_UnionComm :: Set Int -> Set Int -> Bool
+prop_UnionComm t1 t2
+ = (union t1 t2 == union t2 t1)
+
+
+prop_DiffValid
+ = forValidUnitTree $ \t1 ->
+ forValidUnitTree $ \t2 ->
+ valid (difference t1 t2)
+
+prop_Diff :: [Int] -> [Int] -> Bool
+prop_Diff xs ys
+ = toAscList (difference (fromList xs) (fromList ys))
+ == List.sort ((List.\\) (nub xs) (nub ys))
+
+prop_IntValid
+ = forValidUnitTree $ \t1 ->
+ forValidUnitTree $ \t2 ->
+ valid (intersection t1 t2)
+
+prop_Int :: [Int] -> [Int] -> Bool
+prop_Int xs ys
+ = toAscList (intersection (fromList xs) (fromList ys))
+ == List.sort (nub ((List.intersect) (xs) (ys)))
+
+{--------------------------------------------------------------------
+ Lists
+--------------------------------------------------------------------}
+prop_Ordered
+ = forAll (choose (5,100)) $ \n ->
+ let xs = [0..n::Int]
+ in fromAscList xs == fromList xs
+
+prop_List :: [Int] -> Bool
+prop_List xs
+ = (sort (nub xs) == toList (fromList xs))
+-}
+
+{--------------------------------------------------------------------
+ Old Data.Set compatibility interface
+--------------------------------------------------------------------}
+
+{-# DEPRECATED emptySet "Use empty instead" #-}
+emptySet :: Set a
+emptySet = empty
+
+{-# DEPRECATED mkSet "Equivalent to 'foldl insert empty'." #-}
+mkSet :: Ord a => [a] -> Set a
+mkSet = List.foldl' (flip insert) empty
+
+{-# DEPRECATED setToList "Use instead." #-}
+setToList :: Set a -> [a]
+setToList = elems
+
+{-# DEPRECATED unitSet "Use singleton instead." #-}
+unitSet :: a -> Set a
+unitSet = singleton
+
+{-# DEPRECATED elementOf "Use member instead." #-}