uulib 0.9.10 → 0.9.11

raw patch · 11 files changed

+128/−6226 lines, 11 filesnew-uploaderPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• src/UU/DData/IntBag.hs +0/−368
• src/UU/DData/IntMap.hs +0/−1240
• src/UU/DData/IntSet.hs +0/−852
• src/UU/DData/Map.hs +0/−1544
• src/UU/DData/MultiSet.hs +0/−430
• src/UU/DData/Queue.hs +0/−281
• src/UU/DData/Scc.hs +0/−309
• src/UU/DData/Seq.hs +0/−91
• src/UU/DData/Set.hs +0/−1032
• src/UU/Parsing/Offside.hs +124/−72
• uulib.cabal +4/−7

@@ -1,368 +0,0 @@----------------------------------------------------------------------------------{-| Module      :  IntBag-    Copyright   :  (c) Daan Leijen 2002-    License     :  BSD-style--    Maintainer  :  daan@cs.uu.nl-    Stability   :  provisional-    Portability :  portable--  An efficient implementation of bags of integers on top of the "IntMap" module. --  Many operations have a worst-case complexity of /O(min(n,W))/. This means that the-  operation can become linear in the number of elements  with a maximum of /W/ -  -- the number of bits in an 'Int' (32 or 64). For more information, see-  the references in the "IntMap" module.--}----------------------------------------------------------------------------------}-module UU.DData.IntBag ( -            -- * Bag type-              IntBag          -- instance Eq,Show-            -            -- * Operators-            , (\\)--            -- *Query-            , isEmpty-            , size-            , distinctSize-            , member-            , occur--            , subset-            , properSubset-            -            -- * Construction-            , empty-            , single-            , insert-            , insertMany-            , delete-            , deleteAll-            -            -- * Combine-            , union-            , difference-            , intersection-            , unions-            -            -- * Filter-            , filter-            , partition--            -- * Fold-            , fold-            , foldOccur-           -            -- * Conversion-            , elems--            -- ** List-            , toList-            , fromList--            -- ** Ordered list-            , toAscList-            , fromAscList-            , fromDistinctAscList--            -- ** Occurrence lists-            , toOccurList-            , toAscOccurList-            , fromOccurList-            , fromAscOccurList--            -- ** IntMap-            , toMap-            , fromMap-            , fromOccurMap-            -            -- * Debugging-            , showTree-            , showTreeWith-            ) where--import Prelude   hiding  (map,filter)-import qualified Prelude (map,filter)--import qualified UU.DData.IntMap as M--{---------------------------------------------------------------------  Operators---------------------------------------------------------------------}-infixl 9 \\ ------ | /O(n+m)/. See 'difference'.-(\\) ::  IntBag -> IntBag -> IntBag-b1 \\ b2 = difference b1 b2--{---------------------------------------------------------------------  IntBags are a simple wrapper around Maps, 'Map.Map'---------------------------------------------------------------------}--- | A bag of integers.-newtype IntBag  = IntBag (M.IntMap Int)--{---------------------------------------------------------------------  Query---------------------------------------------------------------------}--- | /O(1)/. Is the bag empty?-isEmpty :: IntBag -> Bool-isEmpty (IntBag m)  -  = M.isEmpty m---- | /O(n)/. Returns the number of distinct elements in the bag, ie. (@distinctSize bag == length (nub (toList bag))@).-distinctSize :: IntBag -> Int-distinctSize (IntBag m)     -  = M.size m---- | /O(n)/. The number of elements in the bag.-size :: IntBag -> Int-size b-  = foldOccur (\x n m -> n+m) 0 b---- | /O(min(n,W))/. Is the element in the bag?-member ::  Int -> IntBag -> Bool-member x m-  = (occur x m > 0)---- | /O(min(n,W))/. The number of occurrences of an element in the bag.-occur ::  Int -> IntBag -> Int-occur x (IntBag m)-  = case M.lookup x m of-      Nothing -> 0-      Just n  -> n---- | /O(n+m)/. Is this a subset of the bag? -subset ::  IntBag -> IntBag -> Bool-subset (IntBag m1) (IntBag m2)-  = M.subsetBy (<=) m1 m2---- | /O(n+m)/. Is this a proper subset? (ie. a subset and not equal)-properSubset ::  IntBag -> IntBag -> Bool-properSubset b1 b2-  = subset b1 b2 && (b1 /= b2)--{---------------------------------------------------------------------  Construction---------------------------------------------------------------------}--- | /O(1)/. Create an empty bag.-empty :: IntBag-empty-  = IntBag (M.empty)---- | /O(1)/. Create a singleton bag.-single :: Int -> IntBag-single x -  = IntBag (M.single x 0)-    -{---------------------------------------------------------------------  Insertion, Deletion---------------------------------------------------------------------}--- | /O(min(n,W))/. Insert an element in the bag.-insert ::  Int -> IntBag -> IntBag-insert x (IntBag m)          -  = IntBag (M.insertWith (+) x 1 m)---- | /O(min(n,W))/. The expression (@insertMany x count bag@)--- inserts @count@ instances of @x@ in the bag @bag@.-insertMany ::  Int -> Int -> IntBag -> IntBag-insertMany x count (IntBag m)          -  = IntBag (M.insertWith (+) x count m)---- | /O(min(n,W))/. Delete a single element.-delete ::  Int -> IntBag -> IntBag-delete x (IntBag m)-  = IntBag (M.updateWithKey f x m)-  where-    f x n  | n > 0     = Just (n-1)-           | otherwise = Nothing---- | /O(min(n,W))/. Delete all occurrences of an element.-deleteAll ::  Int -> IntBag -> IntBag-deleteAll x (IntBag m)-  = IntBag (M.delete x m)--{---------------------------------------------------------------------  Combine---------------------------------------------------------------------}--- | /O(n+m)/. Union of two bags. The union adds the elements together.------ > IntBag\> union (fromList [1,1,2]) (fromList [1,2,2,3])--- > {1,1,1,2,2,2,3}-union ::  IntBag -> IntBag -> IntBag-union (IntBag t1) (IntBag t2)-  = IntBag (M.unionWith (+) t1 t2)---- | /O(n+m)/. Intersection of two bags.------ > IntBag\> intersection (fromList [1,1,2]) (fromList [1,2,2,3])--- > {1,2}-intersection ::  IntBag -> IntBag -> IntBag-intersection (IntBag t1) (IntBag t2)-  = IntBag (M.intersectionWith min t1 t2)---- | /O(n+m)/. Difference between two bags.------ > IntBag\> difference (fromList [1,1,2]) (fromList [1,2,2,3])--- > {1}-difference   ::  IntBag -> IntBag -> IntBag-difference (IntBag t1) (IntBag t2)-  = IntBag (M.differenceWithKey f t1 t2)-  where-    f x n m  | n-m > 0   = Just (n-m)-             | otherwise = Nothing---- | The union of a list of bags.-unions ::  [IntBag] -> IntBag-unions bags-  = IntBag (M.unions [m | IntBag m <- bags])--{---------------------------------------------------------------------  Filter and partition---------------------------------------------------------------------}--- | /O(n)/. Filter all elements that satisfy some predicate.-filter ::  (Int -> Bool) -> IntBag -> IntBag-filter p (IntBag m)-  = IntBag (M.filterWithKey (\x n -> p x) m)---- | /O(n)/. Partition the bag according to some predicate.-partition ::  (Int -> Bool) -> IntBag -> (IntBag,IntBag)-partition p (IntBag m)-  = (IntBag l,IntBag r)-  where-    (l,r) = M.partitionWithKey (\x n -> p x) m--{---------------------------------------------------------------------  Fold---------------------------------------------------------------------}--- | /O(n)/. Fold over each element in the bag.-fold :: (Int -> b -> b) -> b -> IntBag -> b-fold f z (IntBag m)-  = M.foldWithKey apply z m-  where-    apply x n z  | n > 0     = apply x (n-1) (f x z)-                 | otherwise = z---- | /O(n)/. Fold over all occurrences of an element at once. --- In a call (@foldOccur f z bag@), the function @f@ takes--- the element first and than the occur count.-foldOccur :: (Int -> Int -> b -> b) -> b -> IntBag -> b-foldOccur f z (IntBag m)-  = M.foldWithKey f z m--{---------------------------------------------------------------------  List variations ---------------------------------------------------------------------}--- | /O(n)/. The list of elements.-elems :: IntBag -> [Int]-elems s-  = toList s--{---------------------------------------------------------------------  Lists ---------------------------------------------------------------------}--- | /O(n)/. Create a list with all elements.-toList :: IntBag -> [Int]-toList s-  = toAscList s---- | /O(n)/. Create an ascending list of all elements.-toAscList :: IntBag -> [Int]-toAscList (IntBag m)-  = [y | (x,n) <- M.toAscList m, y <- replicate n x]----- | /O(n*min(n,W))/. Create a bag from a list of elements.-fromList ::  [Int] -> IntBag -fromList xs-  = IntBag (M.fromListWith (+) [(x,1) | x <- xs])---- | /O(n*min(n,W))/. Create a bag from an ascending list.-fromAscList :: [Int] -> IntBag -fromAscList xs-  = IntBag (M.fromAscListWith (+) [(x,1) | x <- xs])---- | /O(n*min(n,W))/. Create a bag from an ascending list of distinct elements.-fromDistinctAscList :: [Int] -> IntBag -fromDistinctAscList xs-  = IntBag (M.fromDistinctAscList [(x,1) | x <- xs])---- | /O(n)/. Create a list of element\/occurrence pairs.-toOccurList :: IntBag -> [(Int,Int)]-toOccurList b-  = toAscOccurList b---- | /O(n)/. Create an ascending list of element\/occurrence pairs.-toAscOccurList :: IntBag -> [(Int,Int)]-toAscOccurList (IntBag m)-  = M.toAscList m---- | /O(n*min(n,W))/. Create a bag from a list of element\/occurrence pairs.-fromOccurList ::  [(Int,Int)] -> IntBag-fromOccurList xs-  = IntBag (M.fromListWith (+) (Prelude.filter (\(x,i) -> i > 0) xs))---- | /O(n*min(n,W))/. Create a bag from an ascending list of element\/occurrence pairs.-fromAscOccurList ::  [(Int,Int)] -> IntBag-fromAscOccurList xs-  = IntBag (M.fromAscListWith (+) (Prelude.filter (\(x,i) -> i > 0) xs))--{---------------------------------------------------------------------  Maps---------------------------------------------------------------------}--- | /O(1)/. Convert to an 'IntMap.IntMap' from elements to number of occurrences.-toMap   :: IntBag -> M.IntMap Int-toMap (IntBag m)-  = m---- | /O(n)/. Convert a 'IntMap.IntMap' from elements to occurrences into a bag.-fromMap ::  M.IntMap Int -> IntBag-fromMap m-  = IntBag (M.filter (>0) m)---- | /O(1)/. Convert a 'IntMap.IntMap' from elements to occurrences into a bag.--- Assumes that the 'IntMap.IntMap' contains only elements that occur at least once.-fromOccurMap :: M.IntMap Int -> IntBag-fromOccurMap m-  = IntBag m--{---------------------------------------------------------------------  Eq, Ord---------------------------------------------------------------------}-instance Eq (IntBag) where-  (IntBag m1) == (IntBag m2)  = (m1==m2) -  (IntBag m1) /= (IntBag m2)  = (m1/=m2)--{---------------------------------------------------------------------  Show---------------------------------------------------------------------}-instance Show (IntBag) where-  showsPrec d b  = showSet (toAscList b)--showSet :: Show a => [a] -> ShowS-showSet []     -  = showString "{}" -showSet (x:xs) -  = showChar '{' . shows x . showTail xs-  where-    showTail []     = showChar '}'-    showTail (x:xs) = showChar ',' . shows x . showTail xs-    --{---------------------------------------------------------------------  Debugging---------------------------------------------------------------------}--- | /O(n)/. Show the tree structure that implements the 'IntBag'. The tree--- is shown as a compressed and /hanging/.-showTree :: IntBag -> String-showTree bag-  = showTreeWith True False bag---- | /O(n)/. The expression (@showTreeWith hang wide map@) shows--- the tree that implements the bag. The tree is shown /hanging/ when @hang@ is @True@ --- and otherwise as a /rotated/ tree. When @wide@ is @True@ an extra wide version--- is shown.-showTreeWith :: Bool -> Bool -> IntBag -> String-showTreeWith hang wide (IntBag m)-  = M.showTreeWith hang wide m-

@@ -1,1240 +0,0 @@-{-# OPTIONS -cpp -fglasgow-exts #-} --------------------------------------------------------------------------------- -{-| Module      :  IntMap-    Copyright   :  (c) Daan Leijen 2002-    License     :  BSD-style--    Maintainer  :  daan@cs.uu.nl-    Stability   :  provisional-    Portability :  portable--  An efficient implementation of maps from integer keys to values. -  -  1) The module exports some names that clash with the "Prelude" -- 'lookup', 'map', and 'filter'. -      If you want to use "IntMap" unqualified, these functions should be hidden.--      > import Prelude hiding (map,lookup,filter)-      > import IntMap--      Another solution is to use qualified names. --      > import qualified IntMap-      >-      > ... IntMap.single "Paris" "France"--      Or, if you prefer a terse coding style:--      > import qualified IntMap as M-      >-      > ... M.single "Paris" "France"--  2) The implementation is based on /big-endian patricia trees/. This data structure -  performs especially well on binary operations like 'union' and 'intersection'. However,-  my benchmarks show that it is also (much) faster on insertions and deletions when -  compared to a generic size-balanced map implementation (see "Map" and "Data.FiniteMap").-   -  *  Chris Okasaki and Andy Gill,  \"/Fast Mergeable Integer Maps/\",-     Workshop on ML, September 1998, pages 77--86, <http://www.cse.ogi.edu/~andy/pub/finite.htm>--  *  D.R. Morrison, \"/PATRICIA -- Practical Algorithm To Retrieve Information-     Coded In Alphanumeric/\", Journal of the ACM, 15(4), October 1968, pages 514--534.--  3) Many operations have a worst-case complexity of /O(min(n,W))/. This means that the-    operation can become linear in the number of elements -    with a maximum of /W/ -- the number of bits in an 'Int' (32 or 64). --}---------------------------------------------------------------------------------- -module UU.DData.IntMap  ( -            -- * Map type-              IntMap, Key          -- instance Eq,Show--            -- * Operators-            , (!), (\\)--            -- * Query-            , isEmpty-            , size-            , member-            , lookup-            , find          -            , findWithDefault-            -            -- * Construction-            , empty-            , single--            -- ** Insertion-            , insert-            , insertWith, insertWithKey, insertLookupWithKey-            -            -- ** Delete\/Update-            , delete-            , adjust-            , adjustWithKey-            , update-            , updateWithKey-            , updateLookupWithKey-  -            -- * Combine--            -- ** Union-            , union         -            , unionWith          -            , unionWithKey-            , unions--            -- ** Difference-            , difference-            , differenceWith-            , differenceWithKey-            -            -- ** Intersection-            , intersection           -            , intersectionWith-            , intersectionWithKey--            -- * Traversal-            -- ** Map-            , map-            , mapWithKey-            , mapAccum-            , mapAccumWithKey-            -            -- ** Fold-            , fold-            , foldWithKey--            -- * Conversion-            , elems-            , keys-            , assocs-            -            -- ** Lists-            , toList-            , fromList-            , fromListWith-            , fromListWithKey--            -- ** Ordered lists-            , toAscList-            , fromAscList-            , fromAscListWith-            , fromAscListWithKey-            , fromDistinctAscList--            -- * Filter -            , filter-            , filterWithKey-            , partition-            , partitionWithKey--            , split         -            , splitLookup   --            -- * Subset-            , subset, subsetBy-            , properSubset, properSubsetBy-            -            -- * Debugging-            , showTree-            , showTreeWith-            ) where---import Prelude hiding (lookup,map,filter)-import Bits -import Int--{---- just for testing-import qualified Prelude-import Debug.QuickCheck -import List (nub,sort)-import qualified List--}  --#ifdef __GLASGOW_HASKELL__-{---------------------------------------------------------------------  GHC: use unboxing to get @shiftRL@ inlined.---------------------------------------------------------------------}-#if __GLASGOW_HASKELL__ >= 503-import GHC.Word-import GHC.Exts ( Word(..), Int(..), shiftRL# )-#else-import Word-import GlaExts ( Word(..), Int(..), shiftRL# )-#endif--type Nat = Word--natFromInt :: Key -> Nat-natFromInt i = fromIntegral i--intFromNat :: Nat -> Key-intFromNat w = fromIntegral w--shiftRL :: Nat -> Key -> Nat-shiftRL (W# x) (I# i)-  = W# (shiftRL# x i)--#elif __HUGS__-{--------------------------------------------------------------------- Hugs: - * raises errors on boundary values when using 'fromIntegral'-   but not with the deprecated 'fromInt/toInt'. - * Older Hugs doesn't define 'Word'.- * Newer Hugs defines 'Word' in the Prelude but no operations.---------------------------------------------------------------------}-import Word--type Nat = Word32   -- illegal on 64-bit platforms!--natFromInt :: Key -> Nat-natFromInt i = fromInt i--intFromNat :: Nat -> Key-intFromNat w = toInt w--shiftRL :: Nat -> Key -> Nat-shiftRL x i   = shiftR x i--#else-{---------------------------------------------------------------------  'Standard' Haskell-  * A "Nat" is a natural machine word (an unsigned Int)---------------------------------------------------------------------}-import Word--type Nat = Word--natFromInt :: Key -> Nat-natFromInt i = fromIntegral i--intFromNat :: Nat -> Key-intFromNat w = fromIntegral w--shiftRL :: Nat -> Key -> Nat-shiftRL w i   = shiftR w i--#endif--infixl 9 \\ ----{---------------------------------------------------------------------  Operators---------------------------------------------------------------------}---- | /O(min(n,W))/. See 'find'.-(!) :: IntMap a -> Key -> a-(!) m k    = find k m---- | /O(n+m)/. See 'difference'.-(\\) :: IntMap a -> IntMap a -> IntMap a-m1 \\ m2 = difference m1 m2--{---------------------------------------------------------------------  Types  ---------------------------------------------------------------------}--- | A map of integers to values @a@.-data IntMap a = Nil-              | Tip !Key a-              | Bin !Prefix !Mask !(IntMap a) !(IntMap a) --type Prefix = Int-type Mask   = Int-type Key    = Int--{---------------------------------------------------------------------  Query---------------------------------------------------------------------}--- | /O(1)/. Is the map empty?-isEmpty :: IntMap a -> Bool-isEmpty Nil   = True-isEmpty other = False---- | /O(n)/. Number of elements in the map.-size :: IntMap a -> Int-size t-  = case t of-      Bin p m l r -> size l + size r-      Tip k x -> 1-      Nil     -> 0---- | /O(min(n,W))/. Is the key a member of the map?-member :: Key -> IntMap a -> Bool-member k m-  = case lookup k m of-      Nothing -> False-      Just x  -> True-    --- | /O(min(n,W))/. Lookup the value of a key in the map.-lookup :: Key -> IntMap a -> Maybe a-lookup k t-  = case t of-      Bin p m l r -        | nomatch k p m -> Nothing-        | zero k m      -> lookup k l-        | otherwise     -> lookup k r-      Tip kx x -        | (k==kx)   -> Just x-        | otherwise -> Nothing-      Nil -> Nothing---- | /O(min(n,W))/. Find the value of a key. Calls @error@ when the element can not be found.-find :: Key -> IntMap a -> a-find k m-  = case lookup k m of-      Nothing -> error ("IntMap.find: key " ++ show k ++ " is not an element of the map")-      Just x  -> x---- | /O(min(n,W))/. The expression @(findWithDefault def k map)@ returns the value of key @k@ or returns @def@ when--- the key is not an element of the map.-findWithDefault :: a -> Key -> IntMap a -> a-findWithDefault def k m-  = case lookup k m of-      Nothing -> def-      Just x  -> x--{---------------------------------------------------------------------  Construction---------------------------------------------------------------------}--- | /O(1)/. The empty map.-empty :: IntMap a-empty-  = Nil---- | /O(1)/. A map of one element.-single :: Key -> a -> IntMap a-single k x-  = Tip k x--{---------------------------------------------------------------------  Insert-  'insert' is the inlined version of 'insertWith (\k x y -> x)'---------------------------------------------------------------------}--- | /O(min(n,W))/. Insert a new key\/value pair in the map. When the key --- is already an element of the set, it's value is replaced by the new value, --- ie. 'insert' is left-biased.-insert :: Key -> a -> IntMap a -> IntMap a-insert k x t-  = case t of-      Bin p m l r -        | nomatch k p m -> join k (Tip k x) p t-        | zero k m      -> Bin p m (insert k x l) r-        | otherwise     -> Bin p m l (insert k x r)-      Tip ky y -        | k==ky         -> Tip k x-        | otherwise     -> join k (Tip k x) ky t-      Nil -> Tip k x---- right-biased insertion, used by 'union'--- | /O(min(n,W))/. Insert with a combining function.-insertWith :: (a -> a -> a) -> Key -> a -> IntMap a -> IntMap a-insertWith f k x t-  = insertWithKey (\k x y -> f x y) k x t---- | /O(min(n,W))/. Insert with a combining function.-insertWithKey :: (Key -> a -> a -> a) -> Key -> a -> IntMap a -> IntMap a-insertWithKey f k x t-  = case t of-      Bin p m l r -        | nomatch k p m -> join k (Tip k x) p t-        | zero k m      -> Bin p m (insertWithKey f k x l) r-        | otherwise     -> Bin p m l (insertWithKey f k x r)-      Tip ky y -        | k==ky         -> Tip k (f k x y)-        | otherwise     -> join k (Tip k x) ky t-      Nil -> Tip k x----- | /O(min(n,W))/. The expression (@insertLookupWithKey f k x map@) is a pair where--- the first element is equal to (@lookup k map@) and the second element--- equal to (@insertWithKey f k x map@).-insertLookupWithKey :: (Key -> a -> a -> a) -> Key -> a -> IntMap a -> (Maybe a, IntMap a)-insertLookupWithKey f k x t-  = case t of-      Bin p m l r -        | nomatch k p m -> (Nothing,join k (Tip k x) p t)-        | zero k m      -> let (found,l') = insertLookupWithKey f k x l in (found,Bin p m l' r)-        | otherwise     -> let (found,r') = insertLookupWithKey f k x r in (found,Bin p m l r')-      Tip ky y -        | k==ky         -> (Just y,Tip k (f k x y))-        | otherwise     -> (Nothing,join k (Tip k x) ky t)-      Nil -> (Nothing,Tip k x)---{---------------------------------------------------------------------  Deletion-  [delete] is the inlined version of [deleteWith (\k x -> Nothing)]---------------------------------------------------------------------}--- | /O(min(n,W))/. Delete a key and its value from the map. When the key is not--- a member of the map, the original map is returned.-delete :: Key -> IntMap a -> IntMap a-delete k t-  = case t of-      Bin p m l r -        | nomatch k p m -> t-        | zero k m      -> bin p m (delete k l) r-        | otherwise     -> bin p m l (delete k r)-      Tip ky y -        | k==ky         -> Nil-        | otherwise     -> t-      Nil -> Nil---- | /O(min(n,W))/. Adjust a value at a specific key. When the key is not--- a member of the map, the original map is returned.-adjust ::  (a -> a) -> Key -> IntMap a -> IntMap a-adjust f k m-  = adjustWithKey (\k x -> f x) k m---- | /O(min(n,W))/. Adjust a value at a specific key. When the key is not--- a member of the map, the original map is returned.-adjustWithKey ::  (Key -> a -> a) -> Key -> IntMap a -> IntMap a-adjustWithKey f k m-  = updateWithKey (\k x -> Just (f k x)) k m---- | /O(min(n,W))/. The expression (@update f k map@) updates the value @x@--- at @k@ (if it is in the map). If (@f x@) is @Nothing@, the element is--- deleted. If it is (@Just y@), the key @k@ is bound to the new value @y@.-update ::  (a -> Maybe a) -> Key -> IntMap a -> IntMap a-update f k m-  = updateWithKey (\k x -> f x) k m---- | /O(min(n,W))/. The expression (@update f k map@) updates the value @x@--- at @k@ (if it is in the map). If (@f k x@) is @Nothing@, the element is--- deleted. If it is (@Just y@), the key @k@ is bound to the new value @y@.-updateWithKey ::  (Key -> a -> Maybe a) -> Key -> IntMap a -> IntMap a-updateWithKey f k t-  = case t of-      Bin p m l r -        | nomatch k p m -> t-        | zero k m      -> bin p m (updateWithKey f k l) r-        | otherwise     -> bin p m l (updateWithKey f k r)-      Tip ky y -        | k==ky         -> case (f k y) of-                             Just y' -> Tip ky y'-                             Nothing -> Nil-        | otherwise     -> t-      Nil -> Nil---- | /O(min(n,W))/. Lookup and update.-updateLookupWithKey ::  (Key -> a -> Maybe a) -> Key -> IntMap a -> (Maybe a,IntMap a)-updateLookupWithKey f k t-  = case t of-      Bin p m l r -        | nomatch k p m -> (Nothing,t)-        | zero k m      -> let (found,l') = updateLookupWithKey f k l in (found,bin p m l' r)-        | otherwise     -> let (found,r') = updateLookupWithKey f k r in (found,bin p m l r')-      Tip ky y -        | k==ky         -> case (f k y) of-                             Just y' -> (Just y,Tip ky y')-                             Nothing -> (Just y,Nil)-        | otherwise     -> (Nothing,t)-      Nil -> (Nothing,Nil)---{---------------------------------------------------------------------  Union---------------------------------------------------------------------}--- | The union of a list of maps.-unions :: [IntMap a] -> IntMap a-unions xs-  = foldlStrict union empty xs----- | /O(n+m)/. The (left-biased) union of two sets. -union :: IntMap a -> IntMap a -> IntMap a-union t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)-  | shorter m1 m2  = union1-  | shorter m2 m1  = union2-  | p1 == p2       = Bin p1 m1 (union l1 l2) (union r1 r2)-  | otherwise      = join p1 t1 p2 t2-  where-    union1  | nomatch p2 p1 m1  = join p1 t1 p2 t2-            | zero p2 m1        = Bin p1 m1 (union l1 t2) r1-            | otherwise         = Bin p1 m1 l1 (union r1 t2)--    union2  | nomatch p1 p2 m2  = join p1 t1 p2 t2-            | zero p1 m2        = Bin p2 m2 (union t1 l2) r2-            | otherwise         = Bin p2 m2 l2 (union t1 r2)--union (Tip k x) t = insert k x t-union t (Tip k x) = insertWith (\x y -> y) k x t  -- right bias-union Nil t       = t-union t Nil       = t---- | /O(n+m)/. The union with a combining function. -unionWith :: (a -> a -> a) -> IntMap a -> IntMap a -> IntMap a-unionWith f m1 m2-  = unionWithKey (\k x y -> f x y) m1 m2---- | /O(n+m)/. The union with a combining function. -unionWithKey :: (Key -> a -> a -> a) -> IntMap a -> IntMap a -> IntMap a-unionWithKey f t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)-  | shorter m1 m2  = union1-  | shorter m2 m1  = union2-  | p1 == p2       = Bin p1 m1 (unionWithKey f l1 l2) (unionWithKey f r1 r2)-  | otherwise      = join p1 t1 p2 t2-  where-    union1  | nomatch p2 p1 m1  = join p1 t1 p2 t2-            | zero p2 m1        = Bin p1 m1 (unionWithKey f l1 t2) r1-            | otherwise         = Bin p1 m1 l1 (unionWithKey f r1 t2)--    union2  | nomatch p1 p2 m2  = join p1 t1 p2 t2-            | zero p1 m2        = Bin p2 m2 (unionWithKey f t1 l2) r2-            | otherwise         = Bin p2 m2 l2 (unionWithKey f t1 r2)--unionWithKey f (Tip k x) t = insertWithKey f k x t-unionWithKey f t (Tip k x) = insertWithKey (\k x y -> f k y x) k x t  -- right bias-unionWithKey f Nil t  = t-unionWithKey f t Nil  = t--{---------------------------------------------------------------------  Difference---------------------------------------------------------------------}--- | /O(n+m)/. Difference between two maps (based on keys). -difference :: IntMap a -> IntMap a -> IntMap a-difference t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)-  | shorter m1 m2  = difference1-  | shorter m2 m1  = difference2-  | p1 == p2       = bin p1 m1 (difference l1 l2) (difference r1 r2)-  | otherwise      = t1-  where-    difference1 | nomatch p2 p1 m1  = t1-                | zero p2 m1        = bin p1 m1 (difference l1 t2) r1-                | otherwise         = bin p1 m1 l1 (difference r1 t2)--    difference2 | nomatch p1 p2 m2  = t1-                | zero p1 m2        = difference t1 l2-                | otherwise         = difference t1 r2--difference t1@(Tip k x) t2 -  | member k t2  = Nil-  | otherwise    = t1--difference Nil t       = Nil-difference t (Tip k x) = delete k t-difference t Nil       = t---- | /O(n+m)/. Difference with a combining function. -differenceWith :: (a -> a -> Maybe a) -> IntMap a -> IntMap a -> IntMap a-differenceWith f m1 m2-  = differenceWithKey (\k x y -> f x y) m1 m2---- | /O(n+m)/. Difference with a combining function. When two equal keys are--- encountered, the combining function is applied to the key and both values.--- If it returns @Nothing@, the element is discarded (proper set difference). If--- it returns (@Just y@), the element is updated with a new value @y@. -differenceWithKey :: (Key -> a -> a -> Maybe a) -> IntMap a -> IntMap a -> IntMap a-differenceWithKey f t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)-  | shorter m1 m2  = difference1-  | shorter m2 m1  = difference2-  | p1 == p2       = bin p1 m1 (differenceWithKey f l1 l2) (differenceWithKey f r1 r2)-  | otherwise      = t1-  where-    difference1 | nomatch p2 p1 m1  = t1-                | zero p2 m1        = bin p1 m1 (differenceWithKey f l1 t2) r1-                | otherwise         = bin p1 m1 l1 (differenceWithKey f r1 t2)--    difference2 | nomatch p1 p2 m2  = t1-                | zero p1 m2        = differenceWithKey f t1 l2-                | otherwise         = differenceWithKey f t1 r2--differenceWithKey f t1@(Tip k x) t2 -  = case lookup k t2 of-      Just y  -> case f k x y of-                   Just y' -> Tip k y'-                   Nothing -> Nil-      Nothing -> t1--differenceWithKey f Nil t       = Nil-differenceWithKey f t (Tip k y) = updateWithKey (\k x -> f k x y) k t-differenceWithKey f t Nil       = t---{---------------------------------------------------------------------  Intersection---------------------------------------------------------------------}--- | /O(n+m)/. The (left-biased) intersection of two maps (based on keys). -intersection :: IntMap a -> IntMap a -> IntMap a-intersection t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)-  | shorter m1 m2  = intersection1-  | shorter m2 m1  = intersection2-  | p1 == p2       = bin p1 m1 (intersection l1 l2) (intersection r1 r2)-  | otherwise      = Nil-  where-    intersection1 | nomatch p2 p1 m1  = Nil-                  | zero p2 m1        = intersection l1 t2-                  | otherwise         = intersection r1 t2--    intersection2 | nomatch p1 p2 m2  = Nil-                  | zero p1 m2        = intersection t1 l2-                  | otherwise         = intersection t1 r2--intersection t1@(Tip k x) t2 -  | member k t2  = t1-  | otherwise    = Nil-intersection t (Tip k x) -  = case lookup k t of-      Just y  -> Tip k y-      Nothing -> Nil-intersection Nil t = Nil-intersection t Nil = Nil---- | /O(n+m)/. The intersection with a combining function. -intersectionWith :: (a -> a -> a) -> IntMap a -> IntMap a -> IntMap a-intersectionWith f m1 m2-  = intersectionWithKey (\k x y -> f x y) m1 m2---- | /O(n+m)/. The intersection with a combining function. -intersectionWithKey :: (Key -> a -> a -> a) -> IntMap a -> IntMap a -> IntMap a-intersectionWithKey f t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)-  | shorter m1 m2  = intersection1-  | shorter m2 m1  = intersection2-  | p1 == p2       = bin p1 m1 (intersectionWithKey f l1 l2) (intersectionWithKey f r1 r2)-  | otherwise      = Nil-  where-    intersection1 | nomatch p2 p1 m1  = Nil-                  | zero p2 m1        = intersectionWithKey f l1 t2-                  | otherwise         = intersectionWithKey f r1 t2--    intersection2 | nomatch p1 p2 m2  = Nil-                  | zero p1 m2        = intersectionWithKey f t1 l2-                  | otherwise         = intersectionWithKey f t1 r2--intersectionWithKey f t1@(Tip k x) t2 -  = case lookup k t2 of-      Just y  -> Tip k (f k x y)-      Nothing -> Nil-intersectionWithKey f t1 (Tip k y) -  = case lookup k t1 of-      Just x  -> Tip k (f k x y)-      Nothing -> Nil-intersectionWithKey f Nil t = Nil-intersectionWithKey f t Nil = Nil---{---------------------------------------------------------------------  Subset---------------------------------------------------------------------}--- | /O(n+m)/. Is this a proper subset? (ie. a subset but not equal). --- Defined as (@properSubset = properSubsetBy (==)@).-properSubset :: Eq a => IntMap a -> IntMap a -> Bool-properSubset m1 m2-  = properSubsetBy (==) m1 m2--{- | /O(n+m)/. Is this a proper subset? (ie. a subset but not equal).- The expression (@properSubsetBy f m1 m2@) returns @True@ when- @m1@ and @m2@ are not equal,- all keys in @m1@ are in @m2@, and when @f@ returns @True@ when- applied to their respective values. For example, the following - expressions are all @True@.- -  > properSubsetBy (==) (fromList [(1,1)]) (fromList [(1,1),(2,2)])-  > properSubsetBy (<=) (fromList [(1,1)]) (fromList [(1,1),(2,2)])-- But the following are all @False@:- -  > properSubsetBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1),(2,2)])-  > properSubsetBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1)])-  > properSubsetBy (<)  (fromList [(1,1)])       (fromList [(1,1),(2,2)])--}-properSubsetBy :: (a -> a -> Bool) -> IntMap a -> IntMap a -> Bool-properSubsetBy pred t1 t2-  = case subsetCmp pred t1 t2 of -      LT -> True-      ge -> False--subsetCmp pred t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)-  | shorter m1 m2  = GT-  | shorter m2 m1  = subsetCmpLt-  | p1 == p2       = subsetCmpEq-  | otherwise      = GT  -- disjoint-  where-    subsetCmpLt | nomatch p1 p2 m2  = GT-                | zero p1 m2        = subsetCmp pred t1 l2-                | otherwise         = subsetCmp pred t1 r2-    subsetCmpEq = case (subsetCmp pred l1 l2, subsetCmp pred r1 r2) of-                    (GT,_ ) -> GT-                    (_ ,GT) -> GT-                    (EQ,EQ) -> EQ-                    other   -> LT--subsetCmp pred (Bin p m l r) t  = GT-subsetCmp pred (Tip kx x) (Tip ky y)  -  | (kx == ky) && pred x y = EQ-  | otherwise              = GT  -- disjoint-subsetCmp pred (Tip k x) t      -  = case lookup k t of-     Just y  | pred x y -> LT-     other   -> GT -- disjoint-subsetCmp pred Nil Nil = EQ-subsetCmp pred Nil t   = LT---- | /O(n+m)/. Is this a subset? Defined as (@subset = subsetBy (==)@).-subset :: Eq a => IntMap a -> IntMap a -> Bool-subset m1 m2-  = subsetBy (==) m1 m2--{- | /O(n+m)/. - The expression (@subsetBy f m1 m2@) returns @True@ if- all keys in @m1@ are in @m2@, and when @f@ returns @True@ when- applied to their respective values. For example, the following - expressions are all @True@.- -  > subsetBy (==) (fromList [(1,1)]) (fromList [(1,1),(2,2)])-  > subsetBy (<=) (fromList [(1,1)]) (fromList [(1,1),(2,2)])-  > subsetBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1),(2,2)])-- But the following are all @False@:- -  > subsetBy (==) (fromList [(1,2)]) (fromList [(1,1),(2,2)])-  > subsetBy (<) (fromList [(1,1)]) (fromList [(1,1),(2,2)])-  > subsetBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1)])--}--subsetBy :: (a -> a -> Bool) -> IntMap a -> IntMap a -> Bool-subsetBy pred t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)-  | shorter m1 m2  = False-  | shorter m2 m1  = match p1 p2 m2 && (if zero p1 m2 then subsetBy pred t1 l2-                                                      else subsetBy pred t1 r2)                     -  | otherwise      = (p1==p2) && subsetBy pred l1 l2 && subsetBy pred r1 r2-subsetBy pred (Bin p m l r) t  = False-subsetBy pred (Tip k x) t      = case lookup k t of-                                   Just y  -> pred x y-                                   Nothing -> False -subsetBy pred Nil t            = True--{---------------------------------------------------------------------  Mapping---------------------------------------------------------------------}--- | /O(n)/. Map a function over all values in the map.-map :: (a -> b) -> IntMap a -> IntMap b-map f m-  = mapWithKey (\k x -> f x) m---- | /O(n)/. Map a function over all values in the map.-mapWithKey :: (Key -> a -> b) -> IntMap a -> IntMap b-mapWithKey f t  -  = case t of-      Bin p m l r -> Bin p m (mapWithKey f l) (mapWithKey f r)-      Tip k x     -> Tip k (f k x)-      Nil         -> Nil---- | /O(n)/. The function @mapAccum@ threads an accumulating--- argument through the map in an unspecified order.-mapAccum :: (a -> b -> (a,c)) -> a -> IntMap b -> (a,IntMap c)-mapAccum f a m-  = mapAccumWithKey (\a k x -> f a x) a m---- | /O(n)/. The function @mapAccumWithKey@ threads an accumulating--- argument through the map in an unspecified order.-mapAccumWithKey :: (a -> Key -> b -> (a,c)) -> a -> IntMap b -> (a,IntMap c)-mapAccumWithKey f a t-  = mapAccumL f a t---- | /O(n)/. The function @mapAccumL@ threads an accumulating--- argument through the map in pre-order.-mapAccumL :: (a -> Key -> b -> (a,c)) -> a -> IntMap b -> (a,IntMap c)-mapAccumL f a t-  = case t of-      Bin p m l r -> let (a1,l') = mapAccumL f a l-                         (a2,r') = mapAccumL f a1 r-                     in (a2,Bin p m l' r')-      Tip k x     -> let (a',x') = f a k x in (a',Tip k x')-      Nil         -> (a,Nil)----- | /O(n)/. The function @mapAccumR@ threads an accumulating--- argument throught the map in post-order.-mapAccumR :: (a -> Key -> b -> (a,c)) -> a -> IntMap b -> (a,IntMap c)-mapAccumR f a t-  = case t of-      Bin p m l r -> let (a1,r') = mapAccumR f a r-                         (a2,l') = mapAccumR f a1 l-                     in (a2,Bin p m l' r')-      Tip k x     -> let (a',x') = f a k x in (a',Tip k x')-      Nil         -> (a,Nil)--{---------------------------------------------------------------------  Filter---------------------------------------------------------------------}--- | /O(n)/. Filter all values that satisfy some predicate.-filter :: (a -> Bool) -> IntMap a -> IntMap a-filter p m-  = filterWithKey (\k x -> p x) m---- | /O(n)/. Filter all keys\/values that satisfy some predicate.-filterWithKey :: (Key -> a -> Bool) -> IntMap a -> IntMap a-filterWithKey pred t-  = case t of-      Bin p m l r -        -> bin p m (filterWithKey pred l) (filterWithKey pred r)-      Tip k x -        | pred k x  -> t-        | otherwise -> Nil-      Nil -> Nil---- | /O(n)/. partition the map according to some predicate. The first--- map contains all elements that satisfy the predicate, the second all--- elements that fail the predicate. See also 'split'.-partition :: (a -> Bool) -> IntMap a -> (IntMap a,IntMap a)-partition p m-  = partitionWithKey (\k x -> p x) m---- | /O(n)/. partition the map according to some predicate. The first--- map contains all elements that satisfy the predicate, the second all--- elements that fail the predicate. See also 'split'.-partitionWithKey :: (Key -> a -> Bool) -> IntMap a -> (IntMap a,IntMap a)-partitionWithKey pred t-  = case t of-      Bin p m l r -        -> let (l1,l2) = partitionWithKey pred l-               (r1,r2) = partitionWithKey pred r-           in (bin p m l1 r1, bin p m l2 r2)-      Tip k x -        | pred k x  -> (t,Nil)-        | otherwise -> (Nil,t)-      Nil -> (Nil,Nil)----- | /O(log n)/. The expression (@split k map@) is a pair @(map1,map2)@--- where all keys in @map1@ are lower than @k@ and all keys in--- @map2@ larger than @k@.-split :: Key -> IntMap a -> (IntMap a,IntMap a)-split k t-  = case t of-      Bin p m l r-        | zero k m  -> let (lt,gt) = split k l in (lt,union gt r)-        | otherwise -> let (lt,gt) = split k r in (union l lt,gt)-      Tip ky y -        | k>ky      -> (t,Nil)-        | k<ky      -> (Nil,t)-        | otherwise -> (Nil,Nil)-      Nil -> (Nil,Nil)---- | /O(log n)/. Performs a 'split' but also returns whether the pivot--- key was found in the original map.-splitLookup :: Key -> IntMap a -> (Maybe a,IntMap a,IntMap a)-splitLookup k t-  = case t of-      Bin p m l r-        | zero k m  -> let (found,lt,gt) = splitLookup k l in (found,lt,union gt r)-        | otherwise -> let (found,lt,gt) = splitLookup k r in (found,union l lt,gt)-      Tip ky y -        | k>ky      -> (Nothing,t,Nil)-        | k<ky      -> (Nothing,Nil,t)-        | otherwise -> (Just y,Nil,Nil)-      Nil -> (Nothing,Nil,Nil)--{---------------------------------------------------------------------  Fold---------------------------------------------------------------------}--- | /O(n)/. Fold over the elements of a map in an unspecified order.------ > sum map   = fold (+) 0 map--- > elems map = fold (:) [] map-fold :: (a -> b -> b) -> b -> IntMap a -> b-fold f z t-  = foldWithKey (\k x y -> f x y) z t---- | /O(n)/. Fold over the elements of a map in an unspecified order.------ > keys map = foldWithKey (\k x ks -> k:ks) [] map-foldWithKey :: (Key -> a -> b -> b) -> b -> IntMap a -> b-foldWithKey f z t-  = foldR f z t--foldR :: (Key -> a -> b -> b) -> b -> IntMap a -> b-foldR f z t-  = case t of-      Bin p m l r -> foldR f (foldR f z r) l-      Tip k x     -> f k x z-      Nil         -> z--{---------------------------------------------------------------------  List variations ---------------------------------------------------------------------}--- | /O(n)/. Return all elements of the map.-elems :: IntMap a -> [a]-elems m-  = foldWithKey (\k x xs -> x:xs) [] m  ---- | /O(n)/. Return all keys of the map.-keys  :: IntMap a -> [Key]-keys m-  = foldWithKey (\k x ks -> k:ks) [] m---- | /O(n)/. Return all key\/value pairs in the map.-assocs :: IntMap a -> [(Key,a)]-assocs m-  = toList m---{---------------------------------------------------------------------  Lists ---------------------------------------------------------------------}--- | /O(n)/. Convert the map to a list of key\/value pairs.-toList :: IntMap a -> [(Key,a)]-toList t-  = foldWithKey (\k x xs -> (k,x):xs) [] t---- | /O(n)/. Convert the map to a list of key\/value pairs where the--- keys are in ascending order.-toAscList :: IntMap a -> [(Key,a)]-toAscList t   -  = -- NOTE: the following algorithm only works for big-endian trees-    let (pos,neg) = span (\(k,x) -> k >=0) (foldR (\k x xs -> (k,x):xs) [] t) in neg ++ pos---- | /O(n*min(n,W))/. Create a map from a list of key\/value pairs.-fromList :: [(Key,a)] -> IntMap a-fromList xs-  = foldlStrict ins empty xs-  where-    ins t (k,x)  = insert k x t---- | /O(n*min(n,W))/.  Create a map from a list of key\/value pairs with a combining function. See also 'fromAscListWith'.-fromListWith :: (a -> a -> a) -> [(Key,a)] -> IntMap a -fromListWith f xs-  = fromListWithKey (\k x y -> f x y) xs---- | /O(n*min(n,W))/.  Build a map from a list of key\/value pairs with a combining function. See also fromAscListWithKey'.-fromListWithKey :: (Key -> a -> a -> a) -> [(Key,a)] -> IntMap a -fromListWithKey f xs -  = foldlStrict ins empty xs-  where-    ins t (k,x) = insertWithKey f k x t---- | /O(n*min(n,W))/. Build a map from a list of key\/value pairs where--- the keys are in ascending order.-fromAscList :: [(Key,a)] -> IntMap a-fromAscList xs-  = fromList xs---- | /O(n*min(n,W))/. Build a map from a list of key\/value pairs where--- the keys are in ascending order, with a combining function on equal keys.-fromAscListWith :: (a -> a -> a) -> [(Key,a)] -> IntMap a-fromAscListWith f xs-  = fromListWith f xs---- | /O(n*min(n,W))/. Build a map from a list of key\/value pairs where--- the keys are in ascending order, with a combining function on equal keys.-fromAscListWithKey :: (Key -> a -> a -> a) -> [(Key,a)] -> IntMap a-fromAscListWithKey f xs-  = fromListWithKey f xs---- | /O(n*min(n,W))/. Build a map from a list of key\/value pairs where--- the keys are in ascending order and all distinct.-fromDistinctAscList :: [(Key,a)] -> IntMap a-fromDistinctAscList xs-  = fromList xs---{---------------------------------------------------------------------  Eq ---------------------------------------------------------------------}-instance Eq a => Eq (IntMap a) where-  t1 == t2  = equal t1 t2-  t1 /= t2  = nequal t1 t2--equal :: Eq a => IntMap a -> IntMap a -> Bool-equal (Bin p1 m1 l1 r1) (Bin p2 m2 l2 r2)-  = (m1 == m2) && (p1 == p2) && (equal l1 l2) && (equal r1 r2) -equal (Tip kx x) (Tip ky y)-  = (kx == ky) && (x==y)-equal Nil Nil = True-equal t1 t2   = False--nequal :: Eq a => IntMap a -> IntMap a -> Bool-nequal (Bin p1 m1 l1 r1) (Bin p2 m2 l2 r2)-  = (m1 /= m2) || (p1 /= p2) || (nequal l1 l2) || (nequal r1 r2) -nequal (Tip kx x) (Tip ky y)-  = (kx /= ky) || (x/=y)-nequal Nil Nil = False-nequal t1 t2   = True--instance Show a => Show (IntMap a) where-  showsPrec d t   = showMap (toList t)---showMap :: (Show a) => [(Key,a)] -> ShowS-showMap []     -  = showString "{}" -showMap (x:xs) -  = showChar '{' . showElem x . showTail xs-  where-    showTail []     = showChar '}'-    showTail (x:xs) = showChar ',' . showElem x . showTail xs-    -    showElem (k,x)  = shows k . showString ":=" . shows x-  -{---------------------------------------------------------------------  Debugging---------------------------------------------------------------------}--- | /O(n)/. Show the tree that implements the map. The tree is shown--- in a compressed, hanging format.-showTree :: Show a => IntMap a -> String-showTree s-  = showTreeWith True False s---{- | /O(n)/. The expression (@showTreeWith hang wide map@) shows- the tree that implements the map. 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.--}-showTreeWith :: Show a => Bool -> Bool -> IntMap a -> String-showTreeWith hang wide t-  | hang      = (showsTreeHang wide [] t) ""-  | otherwise = (showsTree wide [] [] t) ""--showsTree :: Show a => Bool -> [String] -> [String] -> IntMap a -> ShowS-showsTree wide lbars rbars t-  = case t of-      Bin p m l r-          -> showsTree wide (withBar rbars) (withEmpty rbars) r .-             showWide wide rbars .-             showsBars lbars . showString (showBin p m) . showString "\n" .-             showWide wide lbars .-             showsTree wide (withEmpty lbars) (withBar lbars) l-      Tip k x-          -> showsBars lbars . showString " " . shows k . showString ":=" . shows x . showString "\n" -      Nil -> showsBars lbars . showString "|\n"--showsTreeHang :: Show a => Bool -> [String] -> IntMap a -> ShowS-showsTreeHang wide bars t-  = case t of-      Bin p m l r-          -> showsBars bars . showString (showBin p m) . showString "\n" . -             showWide wide bars .-             showsTreeHang wide (withBar bars) l .-             showWide wide bars .-             showsTreeHang wide (withEmpty bars) r-      Tip k x-          -> showsBars bars . showString " " . shows k . showString ":=" . shows x . showString "\n" -      Nil -> showsBars bars . showString "|\n" -      -showBin p m-  = "*" -- ++ show (p,m)--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---{---------------------------------------------------------------------  Helpers---------------------------------------------------------------------}-{---------------------------------------------------------------------  Join---------------------------------------------------------------------}-join :: Prefix -> IntMap a -> Prefix -> IntMap a -> IntMap a-join p1 t1 p2 t2-  | zero p1 m = Bin p m t1 t2-  | otherwise = Bin p m t2 t1-  where-    m = branchMask p1 p2-    p = mask p1 m--{---------------------------------------------------------------------  @bin@ assures that we never have empty trees within a tree.---------------------------------------------------------------------}-bin :: Prefix -> Mask -> IntMap a -> IntMap a -> IntMap a-bin p m l Nil = l-bin p m Nil r = r-bin p m l r   = Bin p m l r--  -{---------------------------------------------------------------------  Endian independent bit twiddling---------------------------------------------------------------------}-zero :: Key -> Mask -> Bool-zero i m-  = (natFromInt i) .&. (natFromInt m) == 0--nomatch,match :: Key -> Prefix -> Mask -> Bool-nomatch i p m-  = (mask i m) /= p--match i p m-  = (mask i m) == p--mask :: Key -> Mask -> Prefix-mask i m-  = maskW (natFromInt i) (natFromInt m)---{---------------------------------------------------------------------  Big endian operations  ---------------------------------------------------------------------}-maskW :: Nat -> Nat -> Prefix-maskW i m-  = intFromNat (i .&. (complement (m-1) `xor` m))--shorter :: Mask -> Mask -> Bool-shorter m1 m2-  = (natFromInt m1) > (natFromInt m2)--branchMask :: Prefix -> Prefix -> Mask-branchMask p1 p2-  = intFromNat (highestBitMask (natFromInt p1 `xor` natFromInt p2))-  -{-----------------------------------------------------------------------  Finding the highest bit (mask) in a word [x] can be done efficiently in-  three ways:-  * convert to a floating point value and the mantissa tells us the -    [log2(x)] that corresponds with the highest bit position. The mantissa -    is retrieved either via the standard C function [frexp] or by some bit -    twiddling on IEEE compatible numbers (float). Note that one needs to -    use at least [double] precision for an accurate mantissa of 32 bit -    numbers.-  * use bit twiddling, a logarithmic sequence of bitwise or's and shifts (bit).-  * use processor specific assembler instruction (asm).--  The most portable way would be [bit], but is it efficient enough?-  I have measured the cycle counts of the different methods on an AMD -  Athlon-XP 1800 (~ Pentium III 1.8Ghz) using the RDTSC instruction:--  highestBitMask: method  cycles-                  ---------------                   frexp   200-                   float    33-                   bit      11-                   asm      12--  highestBit:     method  cycles-                  ---------------                   frexp   195-                   float    33-                   bit      11-                   asm      11--  Wow, the bit twiddling is on today's RISC like machines even faster-  than a single CISC instruction (BSR)!-----------------------------------------------------------------------}--{-----------------------------------------------------------------------  [highestBitMask] returns a word where only the highest bit is set.-  It is found by first setting all bits in lower positions than the -  highest bit and than taking an exclusive or with the original value.-  Allthough the function may look expensive, GHC compiles this into-  excellent C code that subsequently compiled into highly efficient-  machine code. The algorithm is derived from Jorg Arndt's FXT library.-----------------------------------------------------------------------}-highestBitMask :: Nat -> Nat-highestBitMask x-  = case (x .|. shiftRL x 1) of -     x -> case (x .|. shiftRL x 2) of -      x -> case (x .|. shiftRL x 4) of -       x -> case (x .|. shiftRL x 8) of -        x -> case (x .|. shiftRL x 16) of -         x -> case (x .|. shiftRL x 32) of   -- for 64 bit platforms-          x -> (x `xor` (shiftRL x 1))---{---------------------------------------------------------------------  Utilities ---------------------------------------------------------------------}-foldlStrict f z xs-  = case xs of-      []     -> z-      (x:xx) -> let z' = f z x in seq z' (foldlStrict f z' xx)--{--{---------------------------------------------------------------------  Testing---------------------------------------------------------------------}-testTree :: [Int] -> IntMap Int-testTree xs   = fromList [(x,x*x*30696 `mod` 65521) | x <- 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 Arbitrary a => Arbitrary (IntMap a) where-  arbitrary = do{ ks <- arbitrary-                ; xs <- mapM (\k -> do{ x <- arbitrary; return (k,x)}) ks-                ; return (fromList xs)-                }---{---------------------------------------------------------------------  Single, Insert, Delete---------------------------------------------------------------------}-prop_Single :: Key -> Int -> Bool-prop_Single k x-  = (insert k x empty == single k x)--prop_InsertDelete :: Key -> Int -> IntMap Int -> Property-prop_InsertDelete k x t-  = not (member k t) ==> delete k (insert k x t) == t--prop_UpdateDelete :: Key -> IntMap Int -> Bool  -prop_UpdateDelete k t-  = update (const Nothing) k t == delete k t---{---------------------------------------------------------------------  Union---------------------------------------------------------------------}-prop_UnionInsert :: Key -> Int -> IntMap Int -> Bool-prop_UnionInsert k x t-  = union (single k x) t == insert k x t--prop_UnionAssoc :: IntMap Int -> IntMap Int -> IntMap Int -> Bool-prop_UnionAssoc t1 t2 t3-  = union t1 (union t2 t3) == union (union t1 t2) t3--prop_UnionComm :: IntMap Int -> IntMap Int -> Bool-prop_UnionComm t1 t2-  = (union t1 t2 == unionWith (\x y -> y) t2 t1)---prop_Diff :: [(Key,Int)] -> [(Key,Int)] -> Bool-prop_Diff xs ys-  =  List.sort (keys (difference (fromListWith (+) xs) (fromListWith (+) ys))) -    == List.sort ((List.\\) (nub (Prelude.map fst xs))  (nub (Prelude.map fst ys)))--prop_Int :: [(Key,Int)] -> [(Key,Int)] -> Bool-prop_Int xs ys-  =  List.sort (keys (intersection (fromListWith (+) xs) (fromListWith (+) ys))) -    == List.sort (nub ((List.intersect) (Prelude.map fst xs)  (Prelude.map fst ys)))--{---------------------------------------------------------------------  Lists---------------------------------------------------------------------}-prop_Ordered-  = forAll (choose (5,100)) $ \n ->-    let xs = [(x,()) | x <- [0..n::Int]] -    in fromAscList xs == fromList xs--prop_List :: [Key] -> Bool-prop_List xs-  = (sort (nub xs) == [x | (x,()) <- toAscList (fromList [(x,()) | x <- xs])])--}

@@ -1,852 +0,0 @@-{-# OPTIONS -cpp -fglasgow-exts #-}----------------------------------------------------------------------------------{-| Module      :  IntSet-    Copyright   :  (c) Daan Leijen 2002-    License     :  BSD-style--    Maintainer  :  daan@cs.uu.nl-    Stability   :  provisional-    Portability :  portable--  An efficient implementation of integer sets.-  -  1) The 'filter' function clashes with the "Prelude". -      If you want to use "IntSet" unqualified, this function should be hidden.--      > import Prelude hiding (filter)-      > import IntSet--      Another solution is to use qualified names. --      > import qualified IntSet-      >-      > ... IntSet.fromList [1..5]--      Or, if you prefer a terse coding style:--      > import qualified IntSet as S-      >-      > ... S.fromList [1..5]--  2) The implementation is based on /big-endian patricia trees/. This data structure -  performs especially well on binary operations like 'union' and 'intersection'. However,-  my benchmarks show that it is also (much) faster on insertions and deletions when -  compared to a generic size-balanced set implementation (see "Set").-   -  *  Chris Okasaki and Andy Gill,  \"/Fast Mergeable Integer Maps/\",-     Workshop on ML, September 1998, pages 77--86, <http://www.cse.ogi.edu/~andy/pub/finite.htm>--  *  D.R. Morrison, \"/PATRICIA -- Practical Algorithm To Retrieve Information-     Coded In Alphanumeric/\", Journal of the ACM, 15(4), October 1968, pages 514--534.--  3) Many operations have a worst-case complexity of /O(min(n,W))/. This means that the-    operation can become linear in the number of elements -    with a maximum of /W/ -- the number of bits in an 'Int' (32 or 64). --}----------------------------------------------------------------------------------}-module UU.DData.IntSet  ( -            -- * Set type-              IntSet          -- instance Eq,Show--            -- * Operators-            , (\\)--            -- * Query-            , isEmpty-            , size-            , member-            , subset-            , properSubset-            -            -- * Construction-            , empty-            , single-            , insert-            , delete-            -            -- * Combine-            , union, unions-            , difference-            , intersection-            -            -- * Filter-            , filter-            , partition-            , split-            , splitMember--            -- * Fold-            , fold--            -- * Conversion-            -- ** List-            , elems-            , toList-            , fromList-            -            -- ** Ordered list-            , toAscList-            , fromAscList-            , fromDistinctAscList-                        -            -- * Debugging-            , showTree-            , showTreeWith-            ) where---import Prelude hiding (lookup,filter)-import Bits -import Int--{---- just for testing-import QuickCheck -import List (nub,sort)-import qualified List--}---#ifdef __GLASGOW_HASKELL__-{---------------------------------------------------------------------  GHC: use unboxing to get @shiftRL@ inlined.---------------------------------------------------------------------}-#if __GLASGOW_HASKELL__ >= 503-import GHC.Word-import GHC.Exts ( Word(..), Int(..), shiftRL# )-#else-import Word-import GlaExts ( Word(..), Int(..), shiftRL# )-#endif---type Nat = Word--natFromInt :: Int -> Nat-natFromInt i = fromIntegral i--intFromNat :: Nat -> Int-intFromNat w = fromIntegral w--shiftRL :: Nat -> Int -> Nat-shiftRL (W# x) (I# i)-  = W# (shiftRL# x i)--#elif __HUGS__-{--------------------------------------------------------------------- Hugs: - * raises errors on boundary values when using 'fromIntegral'-   but not with the deprecated 'fromInt/toInt'. - * Older Hugs doesn't define 'Word'.- * Newer Hugs defines 'Word' in the Prelude but no operations.---------------------------------------------------------------------}-import Word--type Nat = Word32   -- illegal on 64-bit platforms!--natFromInt :: Int -> Nat-natFromInt i = fromInt i--intFromNat :: Nat -> Int-intFromNat w = toInt w--shiftRL :: Nat -> Int -> Nat-shiftRL x i   = shiftR x i--#else-{---------------------------------------------------------------------  'Standard' Haskell-  * A "Nat" is a natural machine word (an unsigned Int)---------------------------------------------------------------------}-import Word--type Nat = Word--natFromInt :: Int -> Nat-natFromInt i = fromIntegral i--intFromNat :: Nat -> Int-intFromNat w = fromIntegral w--shiftRL :: Nat -> Int -> Nat-shiftRL w i   = shiftR w i--#endif--infixl 9 \\ ----{---------------------------------------------------------------------  Operators---------------------------------------------------------------------}--- | /O(n+m)/. See 'difference'.-(\\) :: IntSet -> IntSet -> IntSet-m1 \\ m2 = difference m1 m2--{---------------------------------------------------------------------  Types  ---------------------------------------------------------------------}--- | A set of integers.-data IntSet = Nil-            | Tip !Int-            | Bin !Prefix !Mask !IntSet !IntSet--type Prefix = Int-type Mask   = Int--{---------------------------------------------------------------------  Query---------------------------------------------------------------------}--- | /O(1)/. Is the set empty?-isEmpty :: IntSet -> Bool-isEmpty Nil   = True-isEmpty other = False---- | /O(n)/. Cardinality of the set.-size :: IntSet -> Int-size t-  = case t of-      Bin p m l r -> size l + size r-      Tip y -> 1-      Nil   -> 0---- | /O(min(n,W))/. Is the value a member of the set?-member :: Int -> IntSet -> Bool-member x t-  = case t of-      Bin p m l r -        | nomatch x p m -> False-        | zero x m      -> member x l-        | otherwise     -> member x r-      Tip y -> (x==y)-      Nil   -> False-    --- 'lookup' is used by 'intersection' for left-biasing-lookup :: Int -> IntSet -> Maybe Int-lookup x t-  = case t of-      Bin p m l r -        | nomatch x p m -> Nothing-        | zero x m      -> lookup x l-        | otherwise     -> lookup x r-      Tip y -        | (x==y)    -> Just y-        | otherwise -> Nothing-      Nil -> Nothing--{---------------------------------------------------------------------  Construction---------------------------------------------------------------------}--- | /O(1)/. The empty set.-empty :: IntSet-empty-  = Nil---- | /O(1)/. A set of one element.-single :: Int -> IntSet-single x-  = Tip x--{---------------------------------------------------------------------  Insert---------------------------------------------------------------------}--- | /O(min(n,W))/. Add a value to the set. When the value is already--- an element of the set, it is replaced by the new one, ie. 'insert'--- is left-biased.-insert :: Int -> IntSet -> IntSet-insert x t-  = case t of-      Bin p m l r -        | nomatch x p m -> join x (Tip x) p t-        | zero x m      -> Bin p m (insert x l) r-        | otherwise     -> Bin p m l (insert x r)-      Tip y -        | x==y          -> Tip x-        | otherwise     -> join x (Tip x) y t-      Nil -> Tip x---- right-biased insertion, used by 'union'-insertR :: Int -> IntSet -> IntSet-insertR x t-  = case t of-      Bin p m l r -        | nomatch x p m -> join x (Tip x) p t-        | zero x m      -> Bin p m (insert x l) r-        | otherwise     -> Bin p m l (insert x r)-      Tip y -        | x==y          -> t-        | otherwise     -> join x (Tip x) y t-      Nil -> Tip x---- | /O(min(n,W))/. Delete a value in the set. Returns the--- original set when the value was not present.-delete :: Int -> IntSet -> IntSet-delete x t-  = case t of-      Bin p m l r -        | nomatch x p m -> t-        | zero x m      -> bin p m (delete x l) r-        | otherwise     -> bin p m l (delete x r)-      Tip y -        | x==y          -> Nil-        | otherwise     -> t-      Nil -> Nil---{---------------------------------------------------------------------  Union---------------------------------------------------------------------}--- | The union of a list of sets.-unions :: [IntSet] -> IntSet-unions xs-  = foldlStrict union empty xs----- | /O(n+m)/. The union of two sets. -union :: IntSet -> IntSet -> IntSet-union t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)-  | shorter m1 m2  = union1-  | shorter m2 m1  = union2-  | p1 == p2       = Bin p1 m1 (union l1 l2) (union r1 r2)-  | otherwise      = join p1 t1 p2 t2-  where-    union1  | nomatch p2 p1 m1  = join p1 t1 p2 t2-            | zero p2 m1        = Bin p1 m1 (union l1 t2) r1-            | otherwise         = Bin p1 m1 l1 (union r1 t2)--    union2  | nomatch p1 p2 m2  = join p1 t1 p2 t2-            | zero p1 m2        = Bin p2 m2 (union t1 l2) r2-            | otherwise         = Bin p2 m2 l2 (union t1 r2)--union (Tip x) t = insert x t-union t (Tip x) = insertR x t  -- right bias-union Nil t     = t-union t Nil     = t---{---------------------------------------------------------------------  Difference---------------------------------------------------------------------}--- | /O(n+m)/. Difference between two sets. -difference :: IntSet -> IntSet -> IntSet-difference t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)-  | shorter m1 m2  = difference1-  | shorter m2 m1  = difference2-  | p1 == p2       = bin p1 m1 (difference l1 l2) (difference r1 r2)-  | otherwise      = t1-  where-    difference1 | nomatch p2 p1 m1  = t1-                | zero p2 m1        = bin p1 m1 (difference l1 t2) r1-                | otherwise         = bin p1 m1 l1 (difference r1 t2)--    difference2 | nomatch p1 p2 m2  = t1-                | zero p1 m2        = difference t1 l2-                | otherwise         = difference t1 r2--difference t1@(Tip x) t2 -  | member x t2  = Nil-  | otherwise    = t1--difference Nil t     = Nil-difference t (Tip x) = delete x t-difference t Nil     = t----{---------------------------------------------------------------------  Intersection---------------------------------------------------------------------}--- | /O(n+m)/. The intersection of two sets. -intersection :: IntSet -> IntSet -> IntSet-intersection t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)-  | shorter m1 m2  = intersection1-  | shorter m2 m1  = intersection2-  | p1 == p2       = bin p1 m1 (intersection l1 l2) (intersection r1 r2)-  | otherwise      = Nil-  where-    intersection1 | nomatch p2 p1 m1  = Nil-                  | zero p2 m1        = intersection l1 t2-                  | otherwise         = intersection r1 t2--    intersection2 | nomatch p1 p2 m2  = Nil-                  | zero p1 m2        = intersection t1 l2-                  | otherwise         = intersection t1 r2--intersection t1@(Tip x) t2 -  | member x t2  = t1-  | otherwise    = Nil-intersection t (Tip x) -  = case lookup x t of-      Just y  -> Tip y-      Nothing -> Nil-intersection Nil t = Nil-intersection t Nil = Nil----{---------------------------------------------------------------------  Subset---------------------------------------------------------------------}--- | /O(n+m)/. Is this a proper subset? (ie. a subset but not equal).-properSubset :: IntSet -> IntSet -> Bool-properSubset t1 t2-  = case subsetCmp t1 t2 of -      LT -> True-      ge -> False--subsetCmp t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)-  | shorter m1 m2  = GT-  | shorter m2 m1  = subsetCmpLt-  | p1 == p2       = subsetCmpEq-  | otherwise      = GT  -- disjoint-  where-    subsetCmpLt | nomatch p1 p2 m2  = GT-                | zero p1 m2        = subsetCmp t1 l2-                | otherwise         = subsetCmp t1 r2-    subsetCmpEq = case (subsetCmp l1 l2, subsetCmp r1 r2) of-                    (GT,_ ) -> GT-                    (_ ,GT) -> GT-                    (EQ,EQ) -> EQ-                    other   -> LT--subsetCmp (Bin p m l r) t  = GT-subsetCmp (Tip x) (Tip y)  -  | x==y       = EQ-  | otherwise  = GT  -- disjoint-subsetCmp (Tip x) t        -  | member x t = LT-  | otherwise  = GT  -- disjoint-subsetCmp Nil Nil = EQ-subsetCmp Nil t   = LT---- | /O(n+m)/. Is this a subset?-subset :: IntSet -> IntSet -> Bool-subset t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)-  | shorter m1 m2  = False-  | shorter m2 m1  = match p1 p2 m2 && (if zero p1 m2 then subset t1 l2-                                                      else subset t1 r2)                     -  | otherwise      = (p1==p2) && subset l1 l2 && subset r1 r2-subset (Bin p m l r) t  = False-subset (Tip x) t        = member x t-subset Nil t            = True---{---------------------------------------------------------------------  Filter---------------------------------------------------------------------}--- | /O(n)/. Filter all elements that satisfy some predicate.-filter :: (Int -> Bool) -> IntSet -> IntSet-filter pred t-  = case t of-      Bin p m l r -        -> bin p m (filter pred l) (filter pred r)-      Tip x -        | pred x    -> t-        | otherwise -> Nil-      Nil -> Nil---- | /O(n)/. partition the set according to some predicate.-partition :: (Int -> Bool) -> IntSet -> (IntSet,IntSet)-partition pred t-  = case t of-      Bin p m l r -        -> let (l1,l2) = partition pred l-               (r1,r2) = partition pred r-           in (bin p m l1 r1, bin p m l2 r2)-      Tip x -        | pred x    -> (t,Nil)-        | otherwise -> (Nil,t)-      Nil -> (Nil,Nil)----- | /O(log n)/. The expression (@split x set@) is a pair @(set1,set2)@--- where all elements in @set1@ are lower than @x@ and all elements in--- @set2@ larger than @x@.-split :: Int -> IntSet -> (IntSet,IntSet)-split x t-  = case t of-      Bin p m l r-        | zero x m  -> let (lt,gt) = split x l in (lt,union gt r)-        | otherwise -> let (lt,gt) = split x r in (union l lt,gt)-      Tip y -        | x>y       -> (t,Nil)-        | x<y       -> (Nil,t)-        | otherwise -> (Nil,Nil)-      Nil -> (Nil,Nil)---- | /O(log n)/. Performs a 'split' but also returns whether the pivot--- element was found in the original set.-splitMember :: Int -> IntSet -> (Bool,IntSet,IntSet)-splitMember x t-  = case t of-      Bin p m l r-        | zero x m  -> let (found,lt,gt) = splitMember x l in (found,lt,union gt r)-        | otherwise -> let (found,lt,gt) = splitMember x r in (found,union l lt,gt)-      Tip y -        | x>y       -> (False,t,Nil)-        | x<y       -> (False,Nil,t)-        | otherwise -> (True,Nil,Nil)-      Nil -> (False,Nil,Nil)---{---------------------------------------------------------------------  Fold---------------------------------------------------------------------}--- | /O(n)/. Fold over the elements of a set in an unspecified order.------ > sum set   = fold (+) 0 set--- > elems set = fold (:) [] set-fold :: (Int -> b -> b) -> b -> IntSet -> b-fold f z t-  = foldR f z t--foldR :: (Int -> b -> b) -> b -> IntSet -> b-foldR f z t-  = case t of-      Bin p m l r -> foldR f (foldR f z r) l-      Tip x       -> f x z-      Nil         -> z-          -{---------------------------------------------------------------------  List variations ---------------------------------------------------------------------}--- | /O(n)/. The elements of a set.-elems :: IntSet -> [Int]-elems s-  = toList s--{---------------------------------------------------------------------  Lists ---------------------------------------------------------------------}--- | /O(n)/. Convert the set to a list of elements.-toList :: IntSet -> [Int]-toList t-  = fold (:) [] t---- | /O(n)/. Convert the set to an ascending list of elements.-toAscList :: IntSet -> [Int]-toAscList t   -  = -- NOTE: the following algorithm only works for big-endian trees-    let (pos,neg) = span (>=0) (foldR (:) [] t) in neg ++ pos---- | /O(n*min(n,W))/. Create a set from a list of integers.-fromList :: [Int] -> IntSet-fromList xs-  = foldlStrict ins empty xs-  where-    ins t x  = insert x t---- | /O(n*min(n,W))/. Build a set from an ascending list of elements.-fromAscList :: [Int] -> IntSet -fromAscList xs-  = fromList xs---- | /O(n*min(n,W))/. Build a set from an ascending list of distinct elements.-fromDistinctAscList :: [Int] -> IntSet-fromDistinctAscList xs-  = fromList xs---{---------------------------------------------------------------------  Eq ---------------------------------------------------------------------}-instance Eq IntSet where-  t1 == t2  = equal t1 t2-  t1 /= t2  = nequal t1 t2--equal :: IntSet -> IntSet -> Bool-equal (Bin p1 m1 l1 r1) (Bin p2 m2 l2 r2)-  = (m1 == m2) && (p1 == p2) && (equal l1 l2) && (equal r1 r2) -equal (Tip x) (Tip y)-  = (x==y)-equal Nil Nil = True-equal t1 t2   = False--nequal :: IntSet -> IntSet -> Bool-nequal (Bin p1 m1 l1 r1) (Bin p2 m2 l2 r2)-  = (m1 /= m2) || (p1 /= p2) || (nequal l1 l2) || (nequal r1 r2) -nequal (Tip x) (Tip y)-  = (x/=y)-nequal Nil Nil = False-nequal t1 t2   = True--{---------------------------------------------------------------------  Show---------------------------------------------------------------------}-instance Show IntSet where-  showsPrec d s  = showSet (toList s)--showSet :: [Int] -> ShowS-showSet []     -  = showString "{}" -showSet (x:xs) -  = showChar '{' . shows x . showTail xs-  where-    showTail []     = showChar '}'-    showTail (x:xs) = showChar ',' . shows x . showTail xs--{---------------------------------------------------------------------  Debugging---------------------------------------------------------------------}--- | /O(n)/. Show the tree that implements the set. The tree is shown--- in a compressed, hanging format.-showTree :: IntSet -> 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.--}-showTreeWith :: Bool -> Bool -> IntSet -> String-showTreeWith hang wide t-  | hang      = (showsTreeHang wide [] t) ""-  | otherwise = (showsTree wide [] [] t) ""--showsTree :: Bool -> [String] -> [String] -> IntSet -> ShowS-showsTree wide lbars rbars t-  = case t of-      Bin p m l r-          -> showsTree wide (withBar rbars) (withEmpty rbars) r .-             showWide wide rbars .-             showsBars lbars . showString (showBin p m) . showString "\n" .-             showWide wide lbars .-             showsTree wide (withEmpty lbars) (withBar lbars) l-      Tip x-          -> showsBars lbars . showString " " . shows x . showString "\n" -      Nil -> showsBars lbars . showString "|\n"--showsTreeHang :: Bool -> [String] -> IntSet -> ShowS-showsTreeHang wide bars t-  = case t of-      Bin p m l r-          -> showsBars bars . showString (showBin p m) . showString "\n" . -             showWide wide bars .-             showsTreeHang wide (withBar bars) l .-             showWide wide bars .-             showsTreeHang wide (withEmpty bars) r-      Tip x-          -> showsBars bars . showString " " . shows x . showString "\n" -      Nil -> showsBars bars . showString "|\n" -      -showBin p m-  = "*" -- ++ show (p,m)--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---{---------------------------------------------------------------------  Helpers---------------------------------------------------------------------}-{---------------------------------------------------------------------  Join---------------------------------------------------------------------}-join :: Prefix -> IntSet -> Prefix -> IntSet -> IntSet-join p1 t1 p2 t2-  | zero p1 m = Bin p m t1 t2-  | otherwise = Bin p m t2 t1-  where-    m = branchMask p1 p2-    p = mask p1 m--{---------------------------------------------------------------------  @bin@ assures that we never have empty trees within a tree.---------------------------------------------------------------------}-bin :: Prefix -> Mask -> IntSet -> IntSet -> IntSet-bin p m l Nil = l-bin p m Nil r = r-bin p m l r   = Bin p m l r--  -{---------------------------------------------------------------------  Endian independent bit twiddling---------------------------------------------------------------------}-zero :: Int -> Mask -> Bool-zero i m-  = (natFromInt i) .&. (natFromInt m) == 0--nomatch,match :: Int -> Prefix -> Mask -> Bool-nomatch i p m-  = (mask i m) /= p--match i p m-  = (mask i m) == p--mask :: Int -> Mask -> Prefix-mask i m-  = maskW (natFromInt i) (natFromInt m)---{---------------------------------------------------------------------  Big endian operations  ---------------------------------------------------------------------}-maskW :: Nat -> Nat -> Prefix-maskW i m-  = intFromNat (i .&. (complement (m-1) `xor` m))--shorter :: Mask -> Mask -> Bool-shorter m1 m2-  = (natFromInt m1) > (natFromInt m2)--branchMask :: Prefix -> Prefix -> Mask-branchMask p1 p2-  = intFromNat (highestBitMask (natFromInt p1 `xor` natFromInt p2))-  -{-----------------------------------------------------------------------  Finding the highest bit (mask) in a word [x] can be done efficiently in-  three ways:-  * convert to a floating point value and the mantissa tells us the -    [log2(x)] that corresponds with the highest bit position. The mantissa -    is retrieved either via the standard C function [frexp] or by some bit -    twiddling on IEEE compatible numbers (float). Note that one needs to -    use at least [double] precision for an accurate mantissa of 32 bit -    numbers.-  * use bit twiddling, a logarithmic sequence of bitwise or's and shifts (bit).-  * use processor specific assembler instruction (asm).--  The most portable way would be [bit], but is it efficient enough?-  I have measured the cycle counts of the different methods on an AMD -  Athlon-XP 1800 (~ Pentium III 1.8Ghz) using the RDTSC instruction:--  highestBitMask: method  cycles-                  ---------------                   frexp   200-                   float    33-                   bit      11-                   asm      12--  highestBit:     method  cycles-                  ---------------                   frexp   195-                   float    33-                   bit      11-                   asm      11--  Wow, the bit twiddling is on today's RISC like machines even faster-  than a single CISC instruction (BSR)!-----------------------------------------------------------------------}--{-----------------------------------------------------------------------  [highestBitMask] returns a word where only the highest bit is set.-  It is found by first setting all bits in lower positions than the -  highest bit and than taking an exclusive or with the original value.-  Allthough the function may look expensive, GHC compiles this into-  excellent C code that subsequently compiled into highly efficient-  machine code. The algorithm is derived from Jorg Arndt's FXT library.-----------------------------------------------------------------------}-highestBitMask :: Nat -> Nat-highestBitMask x-  = case (x .|. shiftRL x 1) of -     x -> case (x .|. shiftRL x 2) of -      x -> case (x .|. shiftRL x 4) of -       x -> case (x .|. shiftRL x 8) of -        x -> case (x .|. shiftRL x 16) of -         x -> case (x .|. shiftRL x 32) of   -- for 64 bit platforms-          x -> (x `xor` (shiftRL x 1))---{---------------------------------------------------------------------  Utilities ---------------------------------------------------------------------}-foldlStrict f z xs-  = case xs of-      []     -> z-      (x:xx) -> let z' = f z x in seq z' (foldlStrict f z' xx)---{--{---------------------------------------------------------------------  Testing---------------------------------------------------------------------}-testTree :: [Int] -> IntSet-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 Arbitrary IntSet where-  arbitrary = do{ xs <- arbitrary-                ; return (fromList xs)-                }---{---------------------------------------------------------------------  Single, Insert, Delete---------------------------------------------------------------------}-prop_Single :: Int -> Bool-prop_Single x-  = (insert x empty == single x)--prop_InsertDelete :: Int -> IntSet -> Property-prop_InsertDelete k t-  = not (member k t) ==> delete k (insert k t) == t---{---------------------------------------------------------------------  Union---------------------------------------------------------------------}-prop_UnionInsert :: Int -> IntSet -> Bool-prop_UnionInsert x t-  = union t (single x) == insert x t--prop_UnionAssoc :: IntSet -> IntSet -> IntSet -> Bool-prop_UnionAssoc t1 t2 t3-  = union t1 (union t2 t3) == union (union t1 t2) t3--prop_UnionComm :: IntSet -> IntSet -> Bool-prop_UnionComm t1 t2-  = (union t1 t2 == union t2 t1)--prop_Diff :: [Int] -> [Int] -> Bool-prop_Diff xs ys-  =  toAscList (difference (fromList xs) (fromList ys))-    == List.sort ((List.\\) (nub xs)  (nub ys))--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) == toAscList (fromList xs))--}-

@@ -1,1544 +0,0 @@----------------------------------------------------------------------------------{-| Module      :  Map-    Copyright   :  (c) Daan Leijen 2002-    License     :  BSD-style--    Maintainer  :  daan@cs.uu.nl-    Stability   :  provisional-    Portability :  portable--  An efficient implementation of maps from keys to values (dictionaries). --  1) The module exports some names that clash with the "Prelude" -- 'lookup', 'map', and 'filter'. -      If you want to use "Map" unqualified, these functions should be hidden.--      > import Prelude hiding (lookup,map,filter)-      > import Map--      Another solution is to use qualified names. This is also the only way how-      a "Map", "Set", and "MultiSet" can be used within one module. --      > import qualified Map-      >-      > ... Map.single "Paris" "France"--      Or, if you prefer a terse coding style:--      > import qualified Map as M-      >-      > ... M.single "Berlin" "Germany"--  2) The implementation of "Map" is based on /size balanced/ binary trees (or-     trees of /bounded balance/) as described by:--     * Stephen Adams, \"/Efficient sets: a balancing act/\", Journal of Functional-       Programming 3(4):553-562, October 1993, <http://www.swiss.ai.mit.edu/~adams/BB>.--     * J. Nievergelt and E.M. Reingold, \"/Binary search trees of bounded balance/\",-       SIAM journal of computing 2(1), March 1973.-     -  3) Another implementation of finite maps based on size balanced trees-      exists as "Data.FiniteMap" in the Ghc libraries. The good part about this library -      is that it is highly tuned and thorougly tested. However, it is also fairly old, -      uses @#ifdef@'s all  over the place and only supports the basic finite map operations. -      The "Map" module overcomes some of these issues:-        -      * It tries to export a more complete and consistent set of operations, like-        'partition', 'adjust', 'mapAccum', 'elemAt' etc. -      -      * It uses the efficient /hedge/ algorithm for both 'union' and 'difference'-        (a /hedge/ algorithm is not applicable to 'intersection').-      -      * It converts ordered lists in linear time ('fromAscList').  --      * It takes advantage of the module system with names like 'empty' instead of 'Data.FiniteMap.emptyFM'.-      -      * It sticks to portable Haskell, avoiding @#ifdef@'s and other magic.--}------------------------------------------------------------------------------------module UU.DData.Map  ( -            -- * Map type-              Map          -- instance Eq,Show--            -- * Operators-            , (!), (\\)--            -- * Query-            , isEmpty-            , size-            , member-            , lookup-            , find          -            , findWithDefault-            -            -- * Construction-            , empty-            , single--            -- ** Insertion-            , insert-            , insertWith, insertWithKey, insertLookupWithKey-            -            -- ** Delete\/Update-            , delete-            , adjust-            , adjustWithKey-            , update-            , updateWithKey-            , updateLookupWithKey--            -- * Combine--            -- ** Union-            , union         -            , unionWith          -            , unionWithKey-            , unions--            -- ** Difference-            , difference-            , differenceWith-            , differenceWithKey-            -            -- ** Intersection-            , intersection           -            , intersectionWith-            , intersectionWithKey--            -- * Traversal-            -- ** Map-            , map-            , mapWithKey-            , mapAccum-            , mapAccumWithKey-            -            -- ** Fold-            , fold-            , foldWithKey--            -- * Conversion-            , elems-            , keys-            , assocs-            -            -- ** Lists-            , toList-            , fromList-            , fromListWith-            , fromListWithKey--            -- ** Ordered lists-            , toAscList-            , fromAscList-            , fromAscListWith-            , fromAscListWithKey-            , fromDistinctAscList--            -- * Filter -            , filter-            , filterWithKey-            , partition-            , partitionWithKey--            , split         -            , splitLookup   --            -- * Subset-            , subset, subsetBy-            , properSubset, properSubsetBy--            -- * Indexed -            , lookupIndex-            , findIndex-            , elemAt-            , updateAt-            , deleteAt--            -- * Min\/Max-            , findMin-            , findMax-            , deleteMin-            , deleteMax-            , deleteFindMin-            , deleteFindMax-            , updateMin-            , updateMax-            , updateMinWithKey-            , updateMaxWithKey-            -            -- * Debugging-            , showTree-            , showTreeWith-            , valid-            ) where--import Prelude hiding (lookup,map,filter)---{---- for quick check-import qualified Prelude-import qualified List-import Debug.QuickCheck       -import List(nub,sort)    --}--{---------------------------------------------------------------------  Operators---------------------------------------------------------------------}-infixl 9 !,\\ ------ | /O(log n)/. See 'find'.-(!) :: Ord k => Map k a -> k -> a-(!) m k    = find k m---- | /O(n+m)/. See 'difference'.-(\\) :: Ord k => Map k a -> Map k a -> Map k a-m1 \\ m2 = difference m1 m2--{---------------------------------------------------------------------  Size balanced trees.---------------------------------------------------------------------}--- | A Map from keys @k@ and values @a@. -data Map k a  = Tip -              | Bin !Size !k a !(Map k a) !(Map k a) --type Size     = Int--{---------------------------------------------------------------------  Query---------------------------------------------------------------------}--- | /O(1)/. Is the map empty?-isEmpty :: Map k a -> Bool-isEmpty t-  = case t of-      Tip             -> True-      Bin sz k x l r  -> False---- | /O(1)/. The number of elements in the map.-size :: Map k a -> Int-size t-  = case t of-      Tip             -> 0-      Bin sz k x l r  -> sz----- | /O(log n)/. Lookup the value of key in the map.-lookup :: Ord k => k -> Map k a -> Maybe a-lookup k t-  = case t of-      Tip -> Nothing-      Bin sz kx x l r-          -> case compare k kx of-               LT -> lookup k l-               GT -> lookup k r-               EQ -> Just x       ---- | /O(log n)/. Is the key a member of the map?-member :: Ord k => k -> Map k a -> Bool-member k m-  = case lookup k m of-      Nothing -> False-      Just x  -> True---- | /O(log n)/. Find the value of a key. Calls @error@ when the element can not be found.-find :: Ord k => k -> Map k a -> a-find k m-  = case lookup k m of-      Nothing -> error "Map.find: element not in the map"-      Just x  -> x---- | /O(log n)/. The expression @(findWithDefault def k map)@ returns the value of key @k@ or returns @def@ when--- the key is not in the map.-findWithDefault :: Ord k => a -> k -> Map k a -> a-findWithDefault def k m-  = case lookup k m of-      Nothing -> def-      Just x  -> x----{---------------------------------------------------------------------  Construction---------------------------------------------------------------------}--- | /O(1)/. Create an empty map.-empty :: Map k a-empty -  = Tip---- | /O(1)/. Create a map with a single element.-single :: k -> a -> Map k a-single k x  -  = Bin 1 k x Tip Tip--{---------------------------------------------------------------------  Insertion-  [insert] is the inlined version of [insertWith (\k x y -> x)]---------------------------------------------------------------------}--- | /O(log n)/. Insert a new key and value in the map.-insert :: Ord k => k -> a -> Map k a -> Map k a-insert kx x t-  = case t of-      Tip -> single kx x-      Bin sz ky y l r-          -> case compare kx ky of-               LT -> balance ky y (insert kx x l) r-               GT -> balance ky y l (insert kx x r)-               EQ -> Bin sz kx x l r---- | /O(log n)/. Insert with a combining function.-insertWith :: Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a-insertWith f k x m          -  = insertWithKey (\k x y -> f x y) k x m---- | /O(log n)/. Insert with a combining function.-insertWithKey :: Ord k => (k -> a -> a -> a) -> k -> a -> Map k a -> Map k a-insertWithKey f kx x t-  = case t of-      Tip -> single kx x-      Bin sy ky y l r-          -> case compare kx ky of-               LT -> balance ky y (insertWithKey f kx x l) r-               GT -> balance ky y l (insertWithKey f kx x r)-               EQ -> Bin sy ky (f ky x y) l r---- | /O(log n)/. The expression (@insertLookupWithKey f k x map@) is a pair where--- the first element is equal to (@lookup k map@) and the second element--- equal to (@insertWithKey f k x map@).-insertLookupWithKey :: Ord k => (k -> a -> a -> a) -> k -> a -> Map k a -> (Maybe a,Map k a)-insertLookupWithKey f kx x t-  = case t of-      Tip -> (Nothing, single kx x)-      Bin sy ky y l r-          -> case compare kx ky of-               LT -> let (found,l') = insertLookupWithKey f kx x l in (found,balance ky y l' r)-               GT -> let (found,r') = insertLookupWithKey f kx x r in (found,balance ky y l r')-               EQ -> (Just y, Bin sy ky (f ky x y) l r)--{---------------------------------------------------------------------  Deletion-  [delete] is the inlined version of [deleteWith (\k x -> Nothing)]---------------------------------------------------------------------}--- | /O(log n)/. Delete a key and its value from the map. When the key is not--- a member of the map, the original map is returned.-delete :: Ord k => k -> Map k a -> Map k a-delete k t-  = case t of-      Tip -> Tip-      Bin sx kx x l r -          -> case compare k kx of-               LT -> balance kx x (delete k l) r-               GT -> balance kx x l (delete k r)-               EQ -> glue l r---- | /O(log n)/. Adjust a value at a specific key. When the key is not--- a member of the map, the original map is returned.-adjust :: Ord k => (a -> a) -> k -> Map k a -> Map k a-adjust f k m-  = adjustWithKey (\k x -> f x) k m---- | /O(log n)/. Adjust a value at a specific key. When the key is not--- a member of the map, the original map is returned.-adjustWithKey :: Ord k => (k -> a -> a) -> k -> Map k a -> Map k a-adjustWithKey f k m-  = updateWithKey (\k x -> Just (f k x)) k m---- | /O(log n)/. The expression (@update f k map@) updates the value @x@--- at @k@ (if it is in the map). If (@f x@) is @Nothing@, the element is--- deleted. If it is (@Just y@), the key @k@ is bound to the new value @y@.-update :: Ord k => (a -> Maybe a) -> k -> Map k a -> Map k a-update f k m-  = updateWithKey (\k x -> f x) k m---- | /O(log n)/. The expression (@update f k map@) updates the value @x@--- at @k@ (if it is in the map). If (@f k x@) is @Nothing@, the element is--- deleted. If it is (@Just y@), the key @k@ is bound to the new value @y@.-updateWithKey :: Ord k => (k -> a -> Maybe a) -> k -> Map k a -> Map k a-updateWithKey f k t-  = case t of-      Tip -> Tip-      Bin sx kx x l r -          -> case compare k kx of-               LT -> balance kx x (updateWithKey f k l) r-               GT -> balance kx x l (updateWithKey f k r)-               EQ -> case f kx x of-                       Just x' -> Bin sx kx x' l r-                       Nothing -> glue l r---- | /O(log n)/. Lookup and update.-updateLookupWithKey :: Ord k => (k -> a -> Maybe a) -> k -> Map k a -> (Maybe a,Map k a)-updateLookupWithKey f k t-  = case t of-      Tip -> (Nothing,Tip)-      Bin sx kx x l r -          -> case compare k kx of-               LT -> let (found,l') = updateLookupWithKey f k l in (found,balance kx x l' r)-               GT -> let (found,r') = updateLookupWithKey f k r in (found,balance kx x l r') -               EQ -> case f kx x of-                       Just x' -> (Just x',Bin sx kx x' l r)-                       Nothing -> (Just x,glue l r)--{---------------------------------------------------------------------  Indexing---------------------------------------------------------------------}--- | /O(log n)/. Return the /index/ of a key. The index is a number from--- /0/ up to, but not including, the 'size' of the map. Calls 'error' when--- the key is not a 'member' of the map.-findIndex :: Ord k => k -> Map k a -> Int-findIndex k t-  = case lookupIndex k t of-      Nothing  -> error "Map.findIndex: element is not in the map"-      Just idx -> idx---- | /O(log n)/. Lookup the /index/ of a key. The index is a number from--- /0/ up to, but not including, the 'size' of the map. -lookupIndex :: Ord k => k -> Map k a -> Maybe Int-lookupIndex k t-  = lookup 0 t-  where-    lookup idx Tip  = Nothing-    lookup idx (Bin _ kx x l r)-      = case compare k kx of-          LT -> lookup idx l-          GT -> lookup (idx + size l + 1) r -          EQ -> Just (idx + size l)---- | /O(log n)/. Retrieve an element by /index/. Calls 'error' when an--- invalid index is used.-elemAt :: Int -> Map k a -> (k,a)-elemAt i Tip = error "Map.elemAt: index out of range"-elemAt i (Bin _ kx x l r)-  = case compare i sizeL of-      LT -> elemAt i l-      GT -> elemAt (i-sizeL-1) r-      EQ -> (kx,x)-  where-    sizeL = size l---- | /O(log n)/. Update the element at /index/. Calls 'error' when an--- invalid index is used.-updateAt :: (k -> a -> Maybe a) -> Int -> Map k a -> Map k a-updateAt f i Tip  = error "Map.updateAt: index out of range"-updateAt f i (Bin sx kx x l r)-  = case compare i sizeL of-      LT -> updateAt f i l-      GT -> updateAt f (i-sizeL-1) r-      EQ -> case f kx x of-              Just x' -> Bin sx kx x' l r-              Nothing -> glue l r-  where-    sizeL = size l---- | /O(log n)/. Delete the element at /index/. Defined as (@deleteAt i map = updateAt (\k x -> Nothing) i map@).-deleteAt :: Int -> Map k a -> Map k a-deleteAt i map-  = updateAt (\k x -> Nothing) i map---{---------------------------------------------------------------------  Minimal, Maximal---------------------------------------------------------------------}--- | /O(log n)/. The minimal key of the map.-findMin :: Map k a -> (k,a)-findMin (Bin _ kx x Tip r)  = (kx,x)-findMin (Bin _ kx x l r)    = findMin l-findMin Tip                 = error "Map.findMin: empty tree has no minimal element"---- | /O(log n)/. The maximal key of the map.-findMax :: Map k a -> (k,a)-findMax (Bin _ kx x l Tip)  = (kx,x)-findMax (Bin _ kx x l r)    = findMax r-findMax Tip                 = error "Map.findMax: empty tree has no maximal element"---- | /O(log n)/. Delete the minimal key-deleteMin :: Map k a -> Map k a-deleteMin (Bin _ kx x Tip r)  = r-deleteMin (Bin _ kx x l r)    = balance kx x (deleteMin l) r-deleteMin Tip                 = Tip---- | /O(log n)/. Delete the maximal key-deleteMax :: Map k a -> Map k a-deleteMax (Bin _ kx x l Tip)  = l-deleteMax (Bin _ kx x l r)    = balance kx x l (deleteMax r)-deleteMax Tip                 = Tip---- | /O(log n)/. Update the minimal key-updateMin :: (a -> Maybe a) -> Map k a -> Map k a-updateMin f m-  = updateMinWithKey (\k x -> f x) m---- | /O(log n)/. Update the maximal key-updateMax :: (a -> Maybe a) -> Map k a -> Map k a-updateMax f m-  = updateMaxWithKey (\k x -> f x) m----- | /O(log n)/. Update the minimal key-updateMinWithKey :: (k -> a -> Maybe a) -> Map k a -> Map k a-updateMinWithKey f t-  = case t of-      Bin sx kx x Tip r  -> case f kx x of-                              Nothing -> r-                              Just x' -> Bin sx kx x' Tip r-      Bin sx kx x l r    -> balance kx x (updateMinWithKey f l) r-      Tip                -> Tip---- | /O(log n)/. Update the maximal key-updateMaxWithKey :: (k -> a -> Maybe a) -> Map k a -> Map k a-updateMaxWithKey f t-  = case t of-      Bin sx kx x l Tip  -> case f kx x of-                              Nothing -> l-                              Just x' -> Bin sx kx x' l Tip-      Bin sx kx x l r    -> balance kx x l (updateMaxWithKey f r)-      Tip                -> Tip---{---------------------------------------------------------------------  Union. ---------------------------------------------------------------------}--- | The union of a list of maps: (@unions == foldl union empty@).-unions :: Ord k => [Map k a] -> Map k a-unions ts-  = foldlStrict union empty ts---- | /O(n+m)/.--- The expression (@'union' t1 t2@) takes the left-biased union of @t1@ and @t2@. --- It prefers @t1@ when duplicate keys are encountered, ie. (@union == unionWith const@).--- The implementation uses the efficient /hedge-union/ algorithm.-union :: Ord k => Map k a -> Map k a -> Map k a-union Tip t2  = t2-union t1 Tip  = t1-union t1 t2  -- hedge-union is more efficient on (bigset `union` smallset)-   | size t1 >= size t2  = hedgeUnionL (const LT) (const GT) t1 t2-   | otherwise           = hedgeUnionR (const LT) (const GT) t2 t1---- left-biased hedge union-hedgeUnionL cmplo cmphi t1 Tip -  = t1-hedgeUnionL cmplo cmphi Tip (Bin _ kx x l r)-  = join kx x (filterGt cmplo l) (filterLt cmphi r)-hedgeUnionL cmplo cmphi (Bin _ kx x l r) t2-  = join kx x (hedgeUnionL cmplo cmpkx l (trim cmplo cmpkx t2)) -              (hedgeUnionL cmpkx cmphi r (trim cmpkx cmphi t2))-  where-    cmpkx k  = compare kx k---- right-biased hedge union-hedgeUnionR cmplo cmphi t1 Tip -  = t1-hedgeUnionR cmplo cmphi Tip (Bin _ kx x l r)-  = join kx x (filterGt cmplo l) (filterLt cmphi r)-hedgeUnionR cmplo cmphi (Bin _ kx x l r) t2-  = join kx newx (hedgeUnionR cmplo cmpkx l lt) -                 (hedgeUnionR cmpkx cmphi r gt)-  where-    cmpkx k     = compare kx k-    lt          = trim cmplo cmpkx t2-    (found,gt)  = trimLookupLo kx cmphi t2-    newx        = case found of-                    Nothing -> x-                    Just y  -> y--{---------------------------------------------------------------------  Union with a combining function---------------------------------------------------------------------}--- | /O(n+m)/. Union with a combining function. The implementation uses the efficient /hedge-union/ algorithm.-unionWith :: Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a-unionWith f m1 m2-  = unionWithKey (\k x y -> f x y) m1 m2---- | /O(n+m)/.--- Union with a combining function. The implementation uses the efficient /hedge-union/ algorithm.-unionWithKey :: Ord k => (k -> a -> a -> a) -> Map k a -> Map k a -> Map k a-unionWithKey f Tip t2  = t2-unionWithKey f t1 Tip  = t1-unionWithKey f t1 t2  -- hedge-union is more efficient on (bigset `union` smallset)-  | size t1 >= size t2  = hedgeUnionWithKey f (const LT) (const GT) t1 t2-  | otherwise           = hedgeUnionWithKey flipf (const LT) (const GT) t2 t1-  where-    flipf k x y   = f k y x--hedgeUnionWithKey f cmplo cmphi t1 Tip -  = t1-hedgeUnionWithKey f cmplo cmphi Tip (Bin _ kx x l r)-  = join kx x (filterGt cmplo l) (filterLt cmphi r)-hedgeUnionWithKey f cmplo cmphi (Bin _ kx x l r) t2-  = join kx newx (hedgeUnionWithKey f cmplo cmpkx l lt) -                 (hedgeUnionWithKey f cmpkx cmphi r gt)-  where-    cmpkx k     = compare kx k-    lt          = trim cmplo cmpkx t2-    (found,gt)  = trimLookupLo kx cmphi t2-    newx        = case found of-                    Nothing -> x-                    Just y  -> f kx x y--{---------------------------------------------------------------------  Difference---------------------------------------------------------------------}--- | /O(n+m)/. Difference of two maps. --- The implementation uses an efficient /hedge/ algorithm comparable with /hedge-union/.-difference :: Ord k => Map k a -> Map k a -> Map k a-difference Tip t2  = Tip-difference t1 Tip  = t1-difference t1 t2   = hedgeDiff (const LT) (const GT) t1 t2--hedgeDiff cmplo cmphi Tip t     -  = Tip-hedgeDiff cmplo cmphi (Bin _ kx x l r) Tip -  = join kx x (filterGt cmplo l) (filterLt cmphi r)-hedgeDiff cmplo cmphi t (Bin _ kx x l r) -  = merge (hedgeDiff cmplo cmpkx (trim cmplo cmpkx t) l) -          (hedgeDiff cmpkx cmphi (trim cmpkx cmphi t) r)-  where-    cmpkx k = compare kx k   ---- | /O(n+m)/. Difference with a combining function. --- The implementation uses an efficient /hedge/ algorithm comparable with /hedge-union/.-differenceWith :: Ord k => (a -> a -> Maybe a) -> Map k a -> Map k a -> Map k a-differenceWith f m1 m2-  = differenceWithKey (\k x y -> f x y) m1 m2---- | /O(n+m)/. Difference with a combining function. When two equal keys are--- encountered, the combining function is applied to the key and both values.--- If it returns @Nothing@, the element is discarded (proper set difference). If--- it returns (@Just y@), the element is updated with a new value @y@. --- The implementation uses an efficient /hedge/ algorithm comparable with /hedge-union/.-differenceWithKey :: Ord k => (k -> a -> a -> Maybe a) -> Map k a -> Map k a -> Map k a-differenceWithKey f Tip t2  = Tip-differenceWithKey f t1 Tip  = t1-differenceWithKey f t1 t2   = hedgeDiffWithKey f (const LT) (const GT) t1 t2--hedgeDiffWithKey f cmplo cmphi Tip t     -  = Tip-hedgeDiffWithKey f cmplo cmphi (Bin _ kx x l r) Tip -  = join kx x (filterGt cmplo l) (filterLt cmphi r)-hedgeDiffWithKey f cmplo cmphi t (Bin _ kx x l r) -  = case found of-      Nothing -> merge tl tr-      Just y  -> case f kx y x of-                   Nothing -> merge tl tr-                   Just z  -> join kx z tl tr-  where-    cmpkx k     = compare kx k   -    lt          = trim cmplo cmpkx t-    (found,gt)  = trimLookupLo kx cmphi t-    tl          = hedgeDiffWithKey f cmplo cmpkx lt l-    tr          = hedgeDiffWithKey f cmpkx cmphi gt r----{---------------------------------------------------------------------  Intersection---------------------------------------------------------------------}--- | /O(n+m)/. Intersection of two maps. The values in the first--- map are returned, i.e. (@intersection m1 m2 == intersectionWith const m1 m2@).-intersection :: Ord k => Map k a -> Map k a -> Map k a-intersection m1 m2-  = intersectionWithKey (\k x y -> x) m1 m2---- | /O(n+m)/. Intersection with a combining function.-intersectionWith :: Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a-intersectionWith f m1 m2-  = intersectionWithKey (\k x y -> f x y) m1 m2---- | /O(n+m)/. Intersection with a combining function.-intersectionWithKey :: Ord k => (k -> a -> a -> a) -> Map k a -> Map k a -> Map k a-intersectionWithKey f Tip t = Tip-intersectionWithKey f t Tip = Tip-intersectionWithKey f t1 t2  -- intersection is more efficient on (bigset `intersection` smallset)-  | size t1 >= size t2  = intersectWithKey f t1 t2-  | otherwise           = intersectWithKey flipf t2 t1-  where-    flipf k x y   = f k y x--intersectWithKey f Tip t = Tip-intersectWithKey f t Tip = Tip-intersectWithKey f t (Bin _ kx x l r)-  = case found of-      Nothing -> merge tl tr-      Just y  -> join kx (f kx y x) tl tr-  where-    (found,lt,gt) = splitLookup kx t-    tl            = intersectWithKey f lt l-    tr            = intersectWithKey f gt r----{---------------------------------------------------------------------  Subset---------------------------------------------------------------------}--- | /O(n+m)/. --- This function is defined as (@subset = subsetBy (==)@).-subset :: (Ord k,Eq a) => Map k a -> Map k a -> Bool-subset m1 m2-  = subsetBy (==) m1 m2--{- | /O(n+m)/. - The expression (@subsetBy f t1 t2@) returns @True@ if- all keys in @t1@ are in tree @t2@, and when @f@ returns @True@ when- applied to their respective values. For example, the following - expressions are all @True@.- - > subsetBy (==) (fromList [('a',1)]) (fromList [('a',1),('b',2)])- > subsetBy (<=) (fromList [('a',1)]) (fromList [('a',1),('b',2)])- > subsetBy (==) (fromList [('a',1),('b',2)]) (fromList [('a',1),('b',2)])-- But the following are all @False@:- - > subsetBy (==) (fromList [('a',2)]) (fromList [('a',1),('b',2)])- > subsetBy (<)  (fromList [('a',1)]) (fromList [('a',1),('b',2)])- > subsetBy (==) (fromList [('a',1),('b',2)]) (fromList [('a',1)])--}-subsetBy :: Ord k => (a->a->Bool) -> Map k a -> Map k a -> Bool-subsetBy f t1 t2-  = (size t1 <= size t2) && (subset' f t1 t2)--subset' f Tip t = True-subset' f t Tip = False-subset' f (Bin _ kx x l r) t-  = case found of-      Nothing -> False-      Just y  -> f x y && subset' f l lt && subset' f r gt-  where-    (found,lt,gt) = splitLookup kx t---- | /O(n+m)/. Is this a proper subset? (ie. a subset but not equal). --- Defined as (@properSubset = properSubsetBy (==)@).-properSubset :: (Ord k,Eq a) => Map k a -> Map k a -> Bool-properSubset m1 m2-  = properSubsetBy (==) m1 m2--{- | /O(n+m)/. Is this a proper subset? (ie. a subset but not equal).- The expression (@properSubsetBy f m1 m2@) returns @True@ when- @m1@ and @m2@ are not equal,- all keys in @m1@ are in @m2@, and when @f@ returns @True@ when- applied to their respective values. For example, the following - expressions are all @True@.- -  > properSubsetBy (==) (fromList [(1,1)]) (fromList [(1,1),(2,2)])-  > properSubsetBy (<=) (fromList [(1,1)]) (fromList [(1,1),(2,2)])-- But the following are all @False@:- -  > properSubsetBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1),(2,2)])-  > properSubsetBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1)])-  > properSubsetBy (<)  (fromList [(1,1)])       (fromList [(1,1),(2,2)])--}-properSubsetBy :: (Ord k,Eq a) => (a -> a -> Bool) -> Map k a -> Map k a -> Bool-properSubsetBy f t1 t2-  = (size t1 < size t2) && (subset' f t1 t2)--{---------------------------------------------------------------------  Filter and partition---------------------------------------------------------------------}--- | /O(n)/. Filter all values that satisfy the predicate.-filter :: Ord k => (a -> Bool) -> Map k a -> Map k a-filter p m-  = filterWithKey (\k x -> p x) m---- | /O(n)/. Filter all keys\values that satisfy the predicate.-filterWithKey :: Ord k => (k -> a -> Bool) -> Map k a -> Map k a-filterWithKey p Tip = Tip-filterWithKey p (Bin _ kx x l r)-  | p kx x    = join kx x (filterWithKey p l) (filterWithKey p r)-  | otherwise = merge (filterWithKey p l) (filterWithKey p r)----- | /O(n)/. partition the map according to a predicate. The first--- map contains all elements that satisfy the predicate, the second all--- elements that fail the predicate. See also 'split'.-partition :: Ord k => (a -> Bool) -> Map k a -> (Map k a,Map k a)-partition p m-  = partitionWithKey (\k x -> p x) m---- | /O(n)/. partition the map according to a predicate. The first--- map contains all elements that satisfy the predicate, the second all--- elements that fail the predicate. See also 'split'.-partitionWithKey :: Ord k => (k -> a -> Bool) -> Map k a -> (Map k a,Map k a)-partitionWithKey p Tip = (Tip,Tip)-partitionWithKey p (Bin _ kx x l r)-  | p kx x    = (join kx x l1 r1,merge l2 r2)-  | otherwise = (merge l1 r1,join kx x l2 r2)-  where-    (l1,l2) = partitionWithKey p l-    (r1,r2) = partitionWithKey p r---{---------------------------------------------------------------------  Mapping---------------------------------------------------------------------}--- | /O(n)/. Map a function over all values in the map.-map :: (a -> b) -> Map k a -> Map k b-map f m-  = mapWithKey (\k x -> f x) m---- | /O(n)/. Map a function over all values in the map.-mapWithKey :: (k -> a -> b) -> Map k a -> Map k b-mapWithKey f Tip = Tip-mapWithKey f (Bin sx kx x l r) -  = Bin sx kx (f kx x) (mapWithKey f l) (mapWithKey f r)---- | /O(n)/. The function @mapAccum@ threads an accumulating--- argument through the map in an unspecified order.-mapAccum :: (a -> b -> (a,c)) -> a -> Map k b -> (a,Map k c)-mapAccum f a m-  = mapAccumWithKey (\a k x -> f a x) a m---- | /O(n)/. The function @mapAccumWithKey@ threads an accumulating--- argument through the map in unspecified order. (= ascending pre-order)-mapAccumWithKey :: (a -> k -> b -> (a,c)) -> a -> Map k b -> (a,Map k c)-mapAccumWithKey f a t-  = mapAccumL f a t---- | /O(n)/. The function @mapAccumL@ threads an accumulating--- argument throught the map in (ascending) pre-order.-mapAccumL :: (a -> k -> b -> (a,c)) -> a -> Map k b -> (a,Map k c)-mapAccumL f a t-  = case t of-      Tip -> (a,Tip)-      Bin sx kx x l r-          -> let (a1,l') = mapAccumL f a l-                 (a2,x') = f a1 kx x-                 (a3,r') = mapAccumL f a2 r-             in (a3,Bin sx kx x' l' r')---- | /O(n)/. The function @mapAccumR@ threads an accumulating--- argument throught the map in (descending) post-order.-mapAccumR :: (a -> k -> b -> (a,c)) -> a -> Map k b -> (a,Map k c)-mapAccumR f a t-  = case t of-      Tip -> (a,Tip)-      Bin sx kx x l r -          -> let (a1,r') = mapAccumR f a r-                 (a2,x') = f a1 kx x-                 (a3,l') = mapAccumR f a2 l-             in (a3,Bin sx kx x' l' r')--{---------------------------------------------------------------------  Folds  ---------------------------------------------------------------------}--- | /O(n)/. Fold the map in an unspecified order. (= descending post-order).-fold :: (a -> b -> b) -> b -> Map k a -> b-fold f z m-  = foldWithKey (\k x z -> f x z) z m---- | /O(n)/. Fold the map in an unspecified order. (= descending post-order).-foldWithKey :: (k -> a -> b -> b) -> b -> Map k a -> b-foldWithKey f z t-  = foldR f z t---- | /O(n)/. In-order fold.-foldI :: (k -> a -> b -> b -> b) -> b -> Map k a -> b -foldI f z Tip               = z-foldI f z (Bin _ kx x l r)  = f kx x (foldI f z l) (foldI f z r)---- | /O(n)/. Post-order fold.-foldR :: (k -> a -> b -> b) -> b -> Map k a -> b-foldR f z Tip              = z-foldR f z (Bin _ kx x l r) = foldR f (f kx x (foldR f z r)) l---- | /O(n)/. Pre-order fold.-foldL :: (b -> k -> a -> b) -> b -> Map k a -> b-foldL f z Tip              = z-foldL f z (Bin _ kx x l r) = foldL f (f (foldL f z l) kx x) r--{---------------------------------------------------------------------  List variations ---------------------------------------------------------------------}--- | /O(n)/. Return all elements of the map.-elems :: Map k a -> [a]-elems m-  = [x | (k,x) <- assocs m]---- | /O(n)/. Return all keys of the map.-keys  :: Map k a -> [k]-keys m-  = [k | (k,x) <- assocs m]---- | /O(n)/. Return all key\/value pairs in the map.-assocs :: Map k a -> [(k,a)]-assocs m-  = toList m--{---------------------------------------------------------------------  Lists -  use [foldlStrict] to reduce demand on the control-stack---------------------------------------------------------------------}--- | /O(n*log n)/. Build a map from a list of key\/value pairs. See also 'fromAscList'.-fromList :: Ord k => [(k,a)] -> Map k a -fromList xs       -  = foldlStrict ins empty xs-  where-    ins t (k,x) = insert k x t---- | /O(n*log n)/. Build a map from a list of key\/value pairs with a combining function. See also 'fromAscListWith'.-fromListWith :: Ord k => (a -> a -> a) -> [(k,a)] -> Map k a -fromListWith f xs-  = fromListWithKey (\k x y -> f x y) xs---- | /O(n*log n)/. Build a map from a list of key\/value pairs with a combining function. See also 'fromAscListWithKey'.-fromListWithKey :: Ord k => (k -> a -> a -> a) -> [(k,a)] -> Map k a -fromListWithKey f xs -  = foldlStrict ins empty xs-  where-    ins t (k,x) = insertWithKey f k x t---- | /O(n)/. Convert to a list of key\/value pairs.-toList :: Map k a -> [(k,a)]-toList t      = toAscList t---- | /O(n)/. Convert to an ascending list.-toAscList :: Map k a -> [(k,a)]-toAscList t   = foldR (\k x xs -> (k,x):xs) [] t---- | /O(n)/. -toDescList :: Map k a -> [(k,a)]-toDescList t  = foldL (\xs k x -> (k,x):xs) [] t---{---------------------------------------------------------------------  Building trees from ascending/descending lists can be done in linear time.-  -  Note that if [xs] is ascending that: -    fromAscList xs       == fromList xs-    fromAscListWith f xs == fromListWith f xs---------------------------------------------------------------------}--- | /O(n)/. Build a map from an ascending list in linear time.-fromAscList :: Eq k => [(k,a)] -> Map k a -fromAscList xs-  = fromAscListWithKey (\k x y -> x) xs---- | /O(n)/. Build a map from an ascending list in linear time with a combining function for equal keys.-fromAscListWith :: Eq k => (a -> a -> a) -> [(k,a)] -> Map k a -fromAscListWith f xs-  = fromAscListWithKey (\k x y -> f x y) xs---- | /O(n)/. Build a map from an ascending list in linear time with a combining function for equal keys-fromAscListWithKey :: Eq k => (k -> a -> a -> a) -> [(k,a)] -> Map k a -fromAscListWithKey f xs-  = fromDistinctAscList (combineEq f xs)-  where-  -- [combineEq f xs] combines equal elements with function [f] in an ordered list [xs]-  combineEq f xs-    = case xs of-        []     -> []-        [x]    -> [x]-        (x:xx) -> combineEq' x xx--  combineEq' z [] = [z]-  combineEq' z@(kz,zz) (x@(kx,xx):xs)-    | kx==kz    = let yy = f kx xx zz in combineEq' (kx,yy) xs-    | otherwise = z:combineEq' x xs----- | /O(n)/. Build a map from an ascending list of distinct elements in linear time.-fromDistinctAscList :: [(k,a)] -> Map k a -fromDistinctAscList xs-  = build const (length xs) xs-  where-    -- 1) use continutations so that we use heap space instead of stack space.-    -- 2) special case for n==5 to build bushier trees. -    build c 0 xs   = c Tip xs -    build c 5 xs   = case xs of-                       ((k1,x1):(k2,x2):(k3,x3):(k4,x4):(k5,x5):xx) -                            -> c (bin k4 x4 (bin k2 x2 (single k1 x1) (single k3 x3)) (single k5 x5)) xx-    build c n xs   = seq nr $ build (buildR nr c) nl xs-                   where-                     nl = n `div` 2-                     nr = n - nl - 1--    buildR n c l ((k,x):ys) = build (buildB l k x c) n ys-    buildB l k x c r zs     = c (bin k x l r) zs-                      ---{---------------------------------------------------------------------  Utility functions that return sub-ranges of the original-  tree. Some functions take a comparison function as argument to-  allow comparisons against infinite values. A function [cmplo k]-  should be read as [compare lo k].--  [trim cmplo cmphi t]  A tree that is either empty or where [cmplo k == LT]-                        and [cmphi k == GT] for the key [k] of the root.-  [filterGt cmp t]      A tree where for all keys [k]. [cmp k == LT]-  [filterLt cmp t]      A tree where for all keys [k]. [cmp k == GT]--  [split k t]           Returns two trees [l] and [r] where all keys-                        in [l] are <[k] and all keys in [r] are >[k].-  [splitLookup k t]     Just like [split] but also returns whether [k]-                        was found in the tree.---------------------------------------------------------------------}--{---------------------------------------------------------------------  [trim lo hi t] trims away all subtrees that surely contain no-  values between the range [lo] to [hi]. The returned tree is either-  empty or the key of the root is between @lo@ and @hi@.---------------------------------------------------------------------}-trim :: (k -> Ordering) -> (k -> Ordering) -> Map k a -> Map k a-trim cmplo cmphi Tip = Tip-trim cmplo cmphi t@(Bin sx kx x l r)-  = case cmplo kx of-      LT -> case cmphi kx of-              GT -> t-              le -> trim cmplo cmphi l-      ge -> trim cmplo cmphi r-              -trimLookupLo :: Ord k => k -> (k -> Ordering) -> Map k a -> (Maybe a, Map k a)-trimLookupLo lo cmphi Tip = (Nothing,Tip)-trimLookupLo lo cmphi t@(Bin sx kx x l r)-  = case compare lo kx of-      LT -> case cmphi kx of-              GT -> (lookup lo t, t)-              le -> trimLookupLo lo cmphi l-      GT -> trimLookupLo lo cmphi r-      EQ -> (Just x,trim (compare lo) cmphi r)---{---------------------------------------------------------------------  [filterGt k t] filter all keys >[k] from tree [t]-  [filterLt k t] filter all keys <[k] from tree [t]---------------------------------------------------------------------}-filterGt :: Ord k => (k -> Ordering) -> Map k a -> Map k a-filterGt cmp Tip = Tip-filterGt cmp (Bin sx kx x l r)-  = case cmp kx of-      LT -> join kx x (filterGt cmp l) r-      GT -> filterGt cmp r-      EQ -> r-      -filterLt :: Ord k => (k -> Ordering) -> Map k a -> Map k a-filterLt cmp Tip = Tip-filterLt cmp (Bin sx kx x l r)-  = case cmp kx of-      LT -> filterLt cmp l-      GT -> join kx x l (filterLt cmp r)-      EQ -> l--{---------------------------------------------------------------------  Split---------------------------------------------------------------------}--- | /O(log n)/. The expression (@split k map@) is a pair @(map1,map2)@ where--- the keys in @map1@ are smaller than @k@ and the keys in @map2@ larger than @k@.-split :: Ord k => k -> Map k a -> (Map k a,Map k a)-split k Tip = (Tip,Tip)-split k (Bin sx kx x l r)-  = case compare k kx of-      LT -> let (lt,gt) = split k l in (lt,join kx x gt r)-      GT -> let (lt,gt) = split k r in (join kx x l lt,gt)-      EQ -> (l,r)---- | /O(log n)/. The expression (@splitLookup k map@) splits a map just--- like 'split' but also returns @lookup k map@.-splitLookup :: Ord k => k -> Map k a -> (Maybe a,Map k a,Map k a)-splitLookup k Tip = (Nothing,Tip,Tip)-splitLookup k (Bin sx kx x l r)-  = case compare k kx of-      LT -> let (z,lt,gt) = splitLookup k l in (z,lt,join kx x gt r)-      GT -> let (z,lt,gt) = splitLookup k r in (z,join kx x l lt,gt)-      EQ -> (Just x,l,r)--{---------------------------------------------------------------------  Utility functions that maintain the balance properties of the tree.-  All constructors assume that all values in [l] < [k] and all values-  in [r] > [k], and that [l] and [r] are valid trees.-  -  In order of sophistication:-    [Bin sz k x l r]  The type constructor.-    [bin k x l r]     Maintains the correct size, assumes that both [l]-                      and [r] are balanced with respect to each other.-    [balance k x l r] Restores the balance and size.-                      Assumes that the original tree was balanced and-                      that [l] or [r] has changed by at most one element.-    [join k x l r]    Restores balance and size. --  Furthermore, we can construct a new tree from two trees. Both operations-  assume that all values in [l] < all values in [r] and that [l] and [r]-  are valid:-    [glue l r]        Glues [l] and [r] together. Assumes that [l] and-                      [r] are already balanced with respect to each other.-    [merge l r]       Merges two trees and restores balance.--  Note: in contrast to Adam's paper, we use (<=) comparisons instead-  of (<) comparisons in [join], [merge] and [balance]. -  Quickcheck (on [difference]) showed that this was necessary in order -  to maintain the invariants. It is quite unsatisfactory that I haven't -  been able to find out why this is actually the case! Fortunately, it -  doesn't hurt to be a bit more conservative.---------------------------------------------------------------------}--{---------------------------------------------------------------------  Join ---------------------------------------------------------------------}-join :: Ord k => k -> a -> Map k a -> Map k a -> Map k a-join kx x Tip r  = insertMin kx x r-join kx x l Tip  = insertMax kx x l-join kx x l@(Bin sizeL ky y ly ry) r@(Bin sizeR kz z lz rz)-  | delta*sizeL <= sizeR  = balance kz z (join kx x l lz) rz-  | delta*sizeR <= sizeL  = balance ky y ly (join kx x ry r)-  | otherwise             = bin kx x l r----- insertMin and insertMax don't perform potentially expensive comparisons.-insertMax,insertMin :: k -> a -> Map k a -> Map k a -insertMax kx x t-  = case t of-      Tip -> single kx x-      Bin sz ky y l r-          -> balance ky y l (insertMax kx x r)-             -insertMin kx x t-  = case t of-      Tip -> single kx x-      Bin sz ky y l r-          -> balance ky y (insertMin kx x l) r-             -{---------------------------------------------------------------------  [merge l r]: merges two trees.---------------------------------------------------------------------}-merge :: Map k a -> Map k a -> Map k a-merge Tip r   = r-merge l Tip   = l-merge l@(Bin sizeL kx x lx rx) r@(Bin sizeR ky y ly ry)-  | delta*sizeL <= sizeR = balance ky y (merge l ly) ry-  | delta*sizeR <= sizeL = balance kx 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 :: Map k a -> Map k a -> Map k a-glue Tip r = r-glue l Tip = l-glue l r   -  | size l > size r = let ((km,m),l') = deleteFindMax l in balance km m l' r-  | otherwise       = let ((km,m),r') = deleteFindMin r in balance km m l r'----- | /O(log n)/. Delete and find the minimal element.-deleteFindMin :: Map k a -> ((k,a),Map k a)-deleteFindMin t -  = case t of-      Bin _ k x Tip r -> ((k,x),r)-      Bin _ k x l r   -> let (km,l') = deleteFindMin l in (km,balance k x l' r)-      Tip             -> (error "Map.deleteFindMin: can not return the minimal element of an empty map", Tip)---- | /O(log n)/. Delete and find the maximal element.-deleteFindMax :: Map k a -> ((k,a),Map k a)-deleteFindMax t-  = case t of-      Bin _ k x l Tip -> ((k,x),l)-      Bin _ k x l r   -> let (km,r') = deleteFindMax r in (km,balance k x l r')-      Tip             -> (error "Map.deleteFindMax: can not return the maximal element of an empty map", Tip)---{---------------------------------------------------------------------  [balance l x 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.-  [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 automaic for random data and a balancing-    scheme is only necessary to avoid pathological worst cases.-    Almost any choice will do, and in practice, a rather large-    [delta] may perform better than smaller one.--  Note: in contrast to Adam's 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 an invalid ratio of [1].---------------------------------------------------------------------}-delta,ratio :: Int-delta = 5-ratio = 2--balance :: k -> a -> Map k a -> Map k a -> Map k a-balance k x l r-  | sizeL + sizeR <= 1    = Bin sizeX k x l r-  | sizeR >= delta*sizeL  = rotateL k x l r-  | sizeL >= delta*sizeR  = rotateR k x l r-  | otherwise             = Bin sizeX k x l r-  where-    sizeL = size l-    sizeR = size r-    sizeX = sizeL + sizeR + 1---- rotate-rotateL k x l r@(Bin _ _ _ ly ry)-  | size ly < ratio*size ry = singleL k x l r-  | otherwise               = doubleL k x l r--rotateR k x l@(Bin _ _ _ ly ry) r-  | size ry < ratio*size ly = singleR k x l r-  | otherwise               = doubleR k x l r---- basic rotations-singleL k1 x1 t1 (Bin _ k2 x2 t2 t3)  = bin k2 x2 (bin k1 x1 t1 t2) t3-singleR k1 x1 (Bin _ k2 x2 t1 t2) t3  = bin k2 x2 t1 (bin k1 x1 t2 t3)--doubleL k1 x1 t1 (Bin _ k2 x2 (Bin _ k3 x3 t2 t3) t4) = bin k3 x3 (bin k1 x1 t1 t2) (bin k2 x2 t3 t4)-doubleR k1 x1 (Bin _ k2 x2 t1 (Bin _ k3 x3 t2 t3)) t4 = bin k3 x3 (bin k2 x2 t1 t2) (bin k1 x1 t3 t4)---{---------------------------------------------------------------------  The bin constructor maintains the size of the tree---------------------------------------------------------------------}-bin :: k -> a -> Map k a -> Map k a -> Map k a-bin k x l r-  = Bin (size l + size r + 1) k x l r---{---------------------------------------------------------------------  Eq converts the tree to a list. In a lazy setting, this -  actually seems one of the faster methods to compare two trees -  and it is certainly the simplest :-)---------------------------------------------------------------------}-instance (Eq k,Eq a) => Eq (Map k a) where-  t1 == t2  = (size t1 == size t2) && (toAscList t1 == toAscList t2)--{---------------------------------------------------------------------  Functor---------------------------------------------------------------------}-instance Functor (Map k) where-  fmap f m  = map f m--{---------------------------------------------------------------------  Show---------------------------------------------------------------------}-instance (Show k, Show a) => Show (Map k a) where-  showsPrec d m  = showMap (toAscList m)--showMap :: (Show k,Show a) => [(k,a)] -> ShowS-showMap []     -  = showString "{}" -showMap (x:xs) -  = showChar '{' . showElem x . showTail xs-  where-    showTail []     = showChar '}'-    showTail (x:xs) = showChar ',' . showElem x . showTail xs-    -    showElem (k,x)  = shows k . showString ":=" . shows x-  ---- | /O(n)/. Show the tree that implements the map. The tree is shown--- in a compressed, hanging format.-showTree :: (Show k,Show a) => Map k a -> String-showTree m-  = showTreeWith showElem True False m-  where-    showElem k x  = show k ++ ":=" ++ show x---{- | /O(n)/. The expression (@showTreeWith showelem hang wide map@) shows- the tree that implements the map. Elements are shown using the @showElem@ function. 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.-->  Map> putStrLn $ showTreeWith (\k x -> show (k,x)) True False $ fromDistinctAscList [(x,()) | x <- [1..5]]->  (4,())->  +--(2,())->  |  +--(1,())->  |  +--(3,())->  +--(5,())->->  Map> putStrLn $ showTreeWith (\k x -> show (k,x)) True True $ fromDistinctAscList [(x,()) | x <- [1..5]]->  (4,())->  |->  +--(2,())->  |  |->  |  +--(1,())->  |  |->  |  +--(3,())->  |->  +--(5,())->->  Map> putStrLn $ showTreeWith (\k x -> show (k,x)) False True $ fromDistinctAscList [(x,()) | x <- [1..5]]->  +--(5,())->  |->  (4,())->  |->  |  +--(3,())->  |  |->  +--(2,())->     |->     +--(1,())---}-showTreeWith :: (k -> a -> String) -> Bool -> Bool -> Map k a -> String-showTreeWith showelem hang wide t-  | hang      = (showsTreeHang showelem wide [] t) ""-  | otherwise = (showsTree showelem wide [] [] t) ""--showsTree :: (k -> a -> String) -> Bool -> [String] -> [String] -> Map k a -> ShowS-showsTree showelem wide lbars rbars t-  = case t of-      Tip -> showsBars lbars . showString "|\n"-      Bin sz kx x Tip Tip-          -> showsBars lbars . showString (showelem kx x) . showString "\n" -      Bin sz kx x l r-          -> showsTree showelem wide (withBar rbars) (withEmpty rbars) r .-             showWide wide rbars .-             showsBars lbars . showString (showelem kx x) . showString "\n" .-             showWide wide lbars .-             showsTree showelem wide (withEmpty lbars) (withBar lbars) l--showsTreeHang :: (k -> a -> String) -> Bool -> [String] -> Map k a -> ShowS-showsTreeHang showelem wide bars t-  = case t of-      Tip -> showsBars bars . showString "|\n" -      Bin sz kx x Tip Tip-          -> showsBars bars . showString (showelem kx x) . showString "\n" -      Bin sz kx x l r-          -> showsBars bars . showString (showelem kx x) . showString "\n" . -             showWide wide bars .-             showsTreeHang showelem wide (withBar bars) l .-             showWide wide bars .-             showsTreeHang showelem 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 map structure is valid.-valid :: Ord k => Map k 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 kx x l r  -> (lo kx) && (hi kx) && bounded lo (<kx) l && bounded (>kx) hi r---- | Exported only for "Debug.QuickCheck"-balanced :: Map k a -> Bool-balanced t-  = case t of-      Tip              -> True-      Bin sz kx 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 kx x l r -> case (realsize l,realsize r) of-                              (Just n,Just m)  | n+m+1 == sz  -> Just sz-                              other            -> Nothing--{---------------------------------------------------------------------  Utilities---------------------------------------------------------------------}-foldlStrict f z xs-  = case xs of-      []     -> z-      (x:xx) -> let z' = f z x in seq z' (foldlStrict f z' xx)---{--{---------------------------------------------------------------------  Testing---------------------------------------------------------------------}-testTree xs   = fromList [(x,"*") | x <- 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 k,Arbitrary a) => Arbitrary (Map k a) where-  arbitrary = sized (arbtree 0 maxkey)-            where maxkey  = 10000--arbtree :: (Enum k,Arbitrary a) => Int -> Int -> Int -> Gen (Map k a)-arbtree lo hi n-  | n <= 0        = return Tip-  | lo >= hi      = return Tip-  | otherwise     = do{ x  <- arbitrary -                      ; 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) x l r)-                      }  ---{---------------------------------------------------------------------  Valid tree's---------------------------------------------------------------------}-forValid :: (Show k,Enum k,Show a,Arbitrary a,Testable b) => (Map k 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 => (Map Int Int -> a) -> Property-forValidIntTree f-  = forValid f--forValidUnitTree :: Testable a => (Map Int () -> a) -> Property-forValidUnitTree f-  = forValid f---prop_Valid -  = forValidUnitTree $ \t -> valid t--{---------------------------------------------------------------------  Single, Insert, Delete---------------------------------------------------------------------}-prop_Single :: Int -> Int -> Bool-prop_Single k x-  = (insert k x empty == single k x)--prop_InsertValid :: Int -> Property-prop_InsertValid k-  = forValidUnitTree $ \t -> valid (insert k () t)--prop_InsertDelete :: Int -> Map Int () -> Property-prop_InsertDelete k t-  = (lookup k t == Nothing) ==> 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 k -  = forValidUnitTree $ \t ->-    let (l,r) = split k t-    in valid (join k () l r)--prop_Merge :: Int -> Property -prop_Merge k-  = forValidUnitTree $ \t ->-    let (l,r) = split k t-    in valid (merge l r)---{---------------------------------------------------------------------  Union---------------------------------------------------------------------}-prop_UnionValid :: Property-prop_UnionValid-  = forValidUnitTree $ \t1 ->-    forValidUnitTree $ \t2 ->-    valid (union t1 t2)--prop_UnionInsert :: Int -> Int -> Map Int Int -> Bool-prop_UnionInsert k x t-  = union (single k x) t == insert k x t--prop_UnionAssoc :: Map Int Int -> Map Int Int -> Map Int Int -> Bool-prop_UnionAssoc t1 t2 t3-  = union t1 (union t2 t3) == union (union t1 t2) t3--prop_UnionComm :: Map Int Int -> Map Int Int -> Bool-prop_UnionComm t1 t2-  = (union t1 t2 == unionWith (\x y -> y) t2 t1)--prop_UnionWithValid -  = forValidIntTree $ \t1 ->-    forValidIntTree $ \t2 ->-    valid (unionWithKey (\k x y -> x+y) t1 t2)--prop_UnionWith :: [(Int,Int)] -> [(Int,Int)] -> Bool-prop_UnionWith xs ys-  = sum (elems (unionWith (+) (fromListWith (+) xs) (fromListWith (+) ys))) -    == (sum (Prelude.map snd xs) + sum (Prelude.map snd ys))--prop_DiffValid-  = forValidUnitTree $ \t1 ->-    forValidUnitTree $ \t2 ->-    valid (difference t1 t2)--prop_Diff :: [(Int,Int)] -> [(Int,Int)] -> Bool-prop_Diff xs ys-  =  List.sort (keys (difference (fromListWith (+) xs) (fromListWith (+) ys))) -    == List.sort ((List.\\) (nub (Prelude.map fst xs))  (nub (Prelude.map fst ys)))--prop_IntValid-  = forValidUnitTree $ \t1 ->-    forValidUnitTree $ \t2 ->-    valid (intersection t1 t2)--prop_Int :: [(Int,Int)] -> [(Int,Int)] -> Bool-prop_Int xs ys-  =  List.sort (keys (intersection (fromListWith (+) xs) (fromListWith (+) ys))) -    == List.sort (nub ((List.intersect) (Prelude.map fst xs)  (Prelude.map fst ys)))--{---------------------------------------------------------------------  Lists---------------------------------------------------------------------}-prop_Ordered-  = forAll (choose (5,100)) $ \n ->-    let xs = [(x,()) | x <- [0..n::Int]] -    in fromAscList xs == fromList xs--prop_List :: [Int] -> Bool-prop_List xs-  = (sort (nub xs) == [x | (x,()) <- toList (fromList [(x,()) | x <- xs])])--}

@@ -1,430 +0,0 @@----------------------------------------------------------------------------------{-| Module      :  MultiSet-    Copyright   :  (c) Daan Leijen 2002-    License     :  BSD-style--    Maintainer  :  daan@cs.uu.nl-    Stability   :  provisional-    Portability :  portable--  An implementation of multi sets on top of the "Map" module. A multi set-  differs from a /bag/ in the sense that it is represented as a map from elements-  to occurrence counts instead of retaining all elements. This means that equality -  on elements should be defined as a /structural/ equality instead of an -  equivalence relation.   If this is not the  case, operations that observe the -  elements, like 'filter' and 'fold',  should be used with care.--}----------------------------------------------------------------------------------}-module UU.DData.MultiSet ( -            -- * MultiSet type-              MultiSet          -- instance Eq,Show-            -            -- * Operators-            , (\\)--            -- *Query-            , isEmpty-            , size-            , distinctSize-            , member-            , occur--            , subset-            , properSubset-            -            -- * Construction-            , empty-            , single-            , insert-            , insertMany-            , delete-            , deleteAll-            -            -- * Combine-            , union-            , difference-            , intersection-            , unions-            -            -- * Filter-            , filter-            , partition--            -- * Fold-            , fold-            , foldOccur--            -- * Min\/Max-            , findMin-            , findMax-            , deleteMin-            , deleteMax-            , deleteMinAll-            , deleteMaxAll-            -            -- * Conversion-            , elems--            -- ** List-            , toList-            , fromList--            -- ** Ordered list-            , toAscList-            , fromAscList-            , fromDistinctAscList--            -- ** Occurrence lists-            , toOccurList-            , toAscOccurList-            , fromOccurList-            , fromAscOccurList--            -- ** Map-            , toMap-            , fromMap-            , fromOccurMap-            -            -- * Debugging-            , showTree-            , showTreeWith-            , valid-            ) where--import Prelude   hiding  (map,filter)-import qualified Prelude (map,filter)--import qualified UU.DData.Map as M--{---------------------------------------------------------------------  Operators---------------------------------------------------------------------}-infixl 9 \\ ------ | /O(n+m)/. See 'difference'.-(\\) :: Ord a => MultiSet a -> MultiSet a -> MultiSet a-b1 \\ b2 = difference b1 b2--{---------------------------------------------------------------------  MultiSets are a simple wrapper around Maps, 'Map.Map'---------------------------------------------------------------------}--- | A multi set of values @a@.-newtype MultiSet a  = MultiSet (M.Map a Int)--{---------------------------------------------------------------------  Query---------------------------------------------------------------------}--- | /O(1)/. Is the multi set empty?-isEmpty :: MultiSet a -> Bool-isEmpty (MultiSet m)  -  = M.isEmpty m---- | /O(1)/. Returns the number of distinct elements in the multi set, ie. (@distinctSize mset == Set.size ('toSet' mset)@).-distinctSize :: MultiSet a -> Int-distinctSize (MultiSet m)     -  = M.size m---- | /O(n)/. The number of elements in the multi set.-size :: MultiSet a -> Int-size b-  = foldOccur (\x n m -> n+m) 0 b---- | /O(log n)/. Is the element in the multi set?-member :: Ord a => a -> MultiSet a -> Bool-member x m-  = (occur x m > 0)---- | /O(log n)/. The number of occurrences of an element in the multi set.-occur :: Ord a => a -> MultiSet a -> Int-occur x (MultiSet m)-  = case M.lookup x m of-      Nothing -> 0-      Just n  -> n---- | /O(n+m)/. Is this a subset of the multi set? -subset :: Ord a => MultiSet a -> MultiSet a -> Bool-subset (MultiSet m1) (MultiSet m2)-  = M.subsetBy (<=) m1 m2---- | /O(n+m)/. Is this a proper subset? (ie. a subset and not equal)-properSubset :: Ord a => MultiSet a -> MultiSet a -> Bool-properSubset b1 b2-  | distinctSize b1 == distinctSize b2 = (subset b1 b2) && (b1 /= b2)-  | distinctSize b1 <  distinctSize b2 = (subset b1 b2)-  | otherwise                      = False--{---------------------------------------------------------------------  Construction---------------------------------------------------------------------}--- | /O(1)/. Create an empty multi set.-empty :: MultiSet a-empty-  = MultiSet (M.empty)---- | /O(1)/. Create a singleton multi set.-single :: a -> MultiSet a-single x -  = MultiSet (M.single x 1)-    -{---------------------------------------------------------------------  Insertion, Deletion---------------------------------------------------------------------}--- | /O(log n)/. Insert an element in the multi set.-insert :: Ord a => a -> MultiSet a -> MultiSet a-insert x (MultiSet m)          -  = MultiSet (M.insertWith (+) x 1 m)---- | /O(min(n,W))/. The expression (@insertMany x count mset@)--- inserts @count@ instances of @x@ in the multi set @mset@.-insertMany ::  Ord a => a -> Int -> MultiSet a -> MultiSet a--- We still expect not to get count < 0-insertMany x 0 multiset = multiset-insertMany x count (MultiSet m)          -  = MultiSet (M.insertWith (+) x count m)---- | /O(log n)/. Delete a single element.-delete :: Ord a => a -> MultiSet a -> MultiSet a-delete x (MultiSet m)-  = MultiSet (M.updateWithKey f x m)-  where-    f x n  | n > 1     = Just (n-1)-           | otherwise = Nothing---- | /O(log n)/. Delete all occurrences of an element.-deleteAll :: Ord a => a -> MultiSet a -> MultiSet a-deleteAll x (MultiSet m)-  = MultiSet (M.delete x m)--{---------------------------------------------------------------------  Combine---------------------------------------------------------------------}--- | /O(n+m)/. Union of two multisets. The union adds the elements together.------ > MultiSet\> union (fromList [1,1,2]) (fromList [1,2,2,3])--- > {1,1,1,2,2,2,3}-union :: Ord a => MultiSet a -> MultiSet a -> MultiSet a-union (MultiSet t1) (MultiSet t2)-  = MultiSet (M.unionWith (+) t1 t2)---- | /O(n+m)/. Intersection of two multisets.------ > MultiSet\> intersection (fromList [1,1,2]) (fromList [1,2,2,3])--- > {1,2}-intersection :: Ord a => MultiSet a -> MultiSet a -> MultiSet a-intersection (MultiSet t1) (MultiSet t2)-  = MultiSet (M.intersectionWith min t1 t2)---- | /O(n+m)/. Difference between two multisets.------ > MultiSet\> difference (fromList [1,1,2]) (fromList [1,2,2,3])--- > {1}-difference   :: Ord a => MultiSet a -> MultiSet a -> MultiSet a-difference (MultiSet t1) (MultiSet t2)-  = MultiSet (M.differenceWithKey f t1 t2)-  where-    f x n m  | n-m > 0   = Just (n-m)-             | otherwise = Nothing---- | The union of a list of multisets.-unions :: Ord a => [MultiSet a] -> MultiSet a-unions multisets-  -- Original, wrong-  -- = MultiSet (M.unions [m | MultiSet m <- multisets])-  -- Map has no unionsWith-  -- = MultiSet (M.unionsWith (+) [m | MultiSet m <- multisets])-  -- Correct, but requires Data.List.foldl'-  -- = MultiSet (foldl' (M.unionWith (+)) M.empty [m | MultiSet m <- multisets])-  -- Correct, but not strict like the original (M.unions uses foldStrict)-  = foldr union empty multisets--{---------------------------------------------------------------------  Filter and partition---------------------------------------------------------------------}--- | /O(n)/. Filter all elements that satisfy some predicate.-filter :: Ord a => (a -> Bool) -> MultiSet a -> MultiSet a-filter p (MultiSet m)-  = MultiSet (M.filterWithKey (\x n -> p x) m)---- | /O(n)/. Partition the multi set according to some predicate.-partition :: Ord a => (a -> Bool) -> MultiSet a -> (MultiSet a,MultiSet a)-partition p (MultiSet m)-  = (MultiSet l,MultiSet r)-  where-    (l,r) = M.partitionWithKey (\x n -> p x) m--{---------------------------------------------------------------------  Fold---------------------------------------------------------------------}--- | /O(n)/. Fold over each element in the multi set.-fold :: (a -> b -> b) -> b -> MultiSet a -> b-fold f z (MultiSet m)-  = M.foldWithKey apply z m-  where-    apply x n z  | n > 0     = apply x (n-1) (f x z)-                 | otherwise = z---- | /O(n)/. Fold over all occurrences of an element at once.-foldOccur :: (a -> Int -> b -> b) -> b -> MultiSet a -> b-foldOccur f z (MultiSet m)-  = M.foldWithKey f z m--{---------------------------------------------------------------------  Minimal, Maximal---------------------------------------------------------------------}--- | /O(log n)/. The minimal element of a multi set.-findMin :: MultiSet a -> a-findMin (MultiSet m)-  = fst (M.findMin m)---- | /O(log n)/. The maximal element of a multi set.-findMax :: MultiSet a -> a-findMax (MultiSet m)-  = fst (M.findMax m)---- | /O(log n)/. Delete the minimal element.-deleteMin :: MultiSet a -> MultiSet a-deleteMin (MultiSet m)-  = MultiSet (M.updateMin f m)-  where-    f n  | n > 0     = Just (n-1)-         | otherwise = Nothing---- | /O(log n)/. Delete the maximal element.-deleteMax :: MultiSet a -> MultiSet a-deleteMax (MultiSet m)-  = MultiSet (M.updateMax f m)-  where-    f n  | n > 0     = Just (n-1)-         | otherwise = Nothing---- | /O(log n)/. Delete all occurrences of the minimal element.-deleteMinAll :: MultiSet a -> MultiSet a-deleteMinAll (MultiSet m)-  = MultiSet (M.deleteMin m)---- | /O(log n)/. Delete all occurrences of the maximal element.-deleteMaxAll :: MultiSet a -> MultiSet a-deleteMaxAll (MultiSet m)-  = MultiSet (M.deleteMax m)---{---------------------------------------------------------------------  List variations ---------------------------------------------------------------------}--- | /O(n)/. The list of elements.-elems :: MultiSet a -> [a]-elems s-  = toList s--{---------------------------------------------------------------------  Lists ---------------------------------------------------------------------}--- | /O(n)/. Create a list with all elements.-toList :: MultiSet a -> [a]-toList s-  = toAscList s---- | /O(n)/. Create an ascending list of all elements.-toAscList :: MultiSet a -> [a]-toAscList (MultiSet m)-  = [y | (x,n) <- M.toAscList m, y <- replicate n x]----- | /O(n*log n)/. Create a multi set from a list of elements.-fromList :: Ord a => [a] -> MultiSet a -fromList xs-  = MultiSet (M.fromListWith (+) [(x,1) | x <- xs])---- | /O(n)/. Create a multi set from an ascending list in linear time.-fromAscList :: Eq a => [a] -> MultiSet a -fromAscList xs-  = MultiSet (M.fromAscListWith (+) [(x,1) | x <- xs])---- | /O(n)/. Create a multi set from an ascending list of distinct elements in linear time.-fromDistinctAscList :: [a] -> MultiSet a -fromDistinctAscList xs-  = MultiSet (M.fromDistinctAscList [(x,1) | x <- xs])---- | /O(n)/. Create a list of element\/occurrence pairs.-toOccurList :: MultiSet a -> [(a,Int)]-toOccurList b-  = toAscOccurList b---- | /O(n)/. Create an ascending list of element\/occurrence pairs.-toAscOccurList :: MultiSet a -> [(a,Int)]-toAscOccurList (MultiSet m)-  = M.toAscList m---- | /O(n*log n)/. Create a multi set from a list of element\/occurrence pairs.-fromOccurList :: Ord a => [(a,Int)] -> MultiSet a-fromOccurList xs-  = MultiSet (M.fromListWith (+) (Prelude.filter (\(x,i) -> i > 0) xs))---- | /O(n)/. Create a multi set from an ascending list of element\/occurrence pairs.-fromAscOccurList :: Ord a => [(a,Int)] -> MultiSet a-fromAscOccurList xs-  = MultiSet (M.fromAscListWith (+) (Prelude.filter (\(x,i) -> i > 0) xs))--{---------------------------------------------------------------------  Maps---------------------------------------------------------------------}--- | /O(1)/. Convert to a 'Map.Map' from elements to number of occurrences.-toMap   :: MultiSet a -> M.Map a Int-toMap (MultiSet m)-  = m---- | /O(n)/. Convert a 'Map.Map' from elements to occurrences into a multi set.-fromMap :: Ord a => M.Map a Int -> MultiSet a-fromMap m-  = MultiSet (M.filter (>0) m)---- | /O(1)/. Convert a 'Map.Map' from elements to occurrences into a multi set.--- Assumes that the 'Map.Map' contains only elements that occur at least once.-fromOccurMap :: M.Map a Int -> MultiSet a-fromOccurMap m-  = MultiSet m--{---------------------------------------------------------------------  Eq, Ord---------------------------------------------------------------------}-instance Eq a => Eq (MultiSet a) where-  (MultiSet m1) == (MultiSet m2)  = (m1==m2) --{---------------------------------------------------------------------  Show---------------------------------------------------------------------}-instance Show a => Show (MultiSet a) where-  showsPrec d b  = showSet (toAscList b)--showSet :: Show a => [a] -> ShowS-showSet []     -  = showString "{}" -showSet (x:xs) -  = showChar '{' . shows x . showTail xs-  where-    showTail []     = showChar '}'-    showTail (x:xs) = showChar ',' . shows x . showTail xs-    --{---------------------------------------------------------------------  Debugging---------------------------------------------------------------------}--- | /O(n)/. Show the tree structure that implements the 'MultiSet'. The tree--- is shown as a compressed and /hanging/.-showTree :: (Show a) => MultiSet a -> String-showTree mset-  = showTreeWith True False mset---- | /O(n)/. The expression (@showTreeWith hang wide map@) shows--- the tree that implements the multi set. The tree is shown /hanging/ when @hang@ is @True@ --- and otherwise as a /rotated/ tree. When @wide@ is @True@ an extra wide version--- is shown.-showTreeWith :: Show a => Bool -> Bool -> MultiSet a -> String-showTreeWith hang wide (MultiSet m)-  = M.showTreeWith (\x n -> show x ++ " (" ++ show n ++ ")") hang wide m----- | /O(n)/. Is this a valid multi set?-valid :: Ord a => MultiSet a -> Bool-valid (MultiSet m)-  = M.valid m && (M.isEmpty (M.filter (<=0) m))

@@ -1,281 +0,0 @@----------------------------------------------------------------------------------{-| Module      :  Queue-    Copyright   :  (c) Daan Leijen 2002-    License     :  BSD-style--    Maintainer  :  daan@cs.uu.nl-    Stability   :  provisional-    Portability :  portable--  An efficient implementation of queues (FIFO buffers). Based on:--  * Chris Okasaki, \"/Simple and Efficient Purely Functional Queues and Deques/\",-    Journal of Functional Programming 5(4):583-592, October 1995.--}----------------------------------------------------------------------------------}-module UU.DData.Queue ( -            -- * Queue type-              Queue          -- instance Eq,Show--            -- * Operators-            , (<>)-            -            -- * Query-            , isEmpty-            , length-            , head-            , tail-            , front--            -- * Construction-            , empty-            , single-            , insert-            , append-            -            -- * Filter-            , filter-            , partition--            -- * Fold-            , foldL-            , foldR-           -            -- * Conversion-            , elems--            -- ** List-            , toList-            , fromList-            ) where--import qualified Prelude as P (length,filter)-import Prelude   hiding       (length,head,tail,filter)-import qualified List---- just for testing--- import QuickCheck --{---------------------------------------------------------------------  Operators---------------------------------------------------------------------}-infixr 5 <>---- | /O(n)/. Append two queues, see 'append'.-(<>) :: Queue a -> Queue a -> Queue a-s <> t-  = append s t--{---------------------------------------------------------------------  Queue.-  Invariants for @(Queue xs ys zs)@:-  * @length ys <= length xs@-  * @length zs == length xs - length ys@---------------------------------------------------------------------}--- A queue of elements @a@.-data Queue a  = Queue [a] [a] [a]--{---------------------------------------------------------------------  Query---------------------------------------------------------------------}---- | /O(1)/. Is the queue empty?-isEmpty :: Queue a -> Bool-isEmpty (Queue xs ys zs)-  = null xs---- | /O(n)/. The number of elements in the queue.-length :: Queue a -> Int-length (Queue xs ys zs)-  = P.length xs + P.length ys---- | /O(1)/. The element in front of the queue. Raises an error--- when the queue is empty.-head :: Queue a -> a-head (Queue xs ys zs)-  = case xs of-      (x:xx)  -> x-      []      -> error "Queue.head: empty queue"---- | /O(1)/. The tail of the queue.--- Raises an error when the queue is empty.-tail :: Queue a -> Queue a-tail (Queue xs ys zs)-  = case xs of-      (x:xx)  -> queue xx ys zs-      []      -> error "Queue.tail: empty queue"---- | /O(1)/. The head and tail of the queue.-front :: Queue a -> Maybe (a,Queue a)-front (Queue xs ys zs)-  = case xs of-      (x:xx)  -> Just (x,queue xx ys zs)-      []      -> Nothing---{---------------------------------------------------------------------  Construction  ---------------------------------------------------------------------}--- | /O(1)/. The empty queue.-empty :: Queue a-empty -  = Queue [] [] []---- | /O(1)/. A queue of one element.-single :: a -> Queue a-single x-  = Queue [x] [] [x]---- | /O(1)/. Insert an element at the back of a queue.-insert :: a -> Queue a -> Queue a-insert x (Queue xs ys zs)-  = queue xs (x:ys) zs----- | /O(n)/. Append two queues.-append :: Queue a -> Queue a -> Queue a-append (Queue xs1 ys1 zs1) (Queue xs2 ys2 zs2)-  = Queue (xs1++xs2) (ys1++ys2) (zs1++zs2)--{---------------------------------------------------------------------  Filter---------------------------------------------------------------------}--- | /O(n)/. Filter elements according to some predicate.-filter :: (a -> Bool) -> Queue a -> Queue a-filter pred (Queue xs ys zs)-  = balance xs' ys'-  where-    xs' = P.filter pred xs-    ys' = P.filter pred ys---- | /O(n)/. Partition the elements according to some predicate.-partition :: (a -> Bool) -> Queue a -> (Queue a,Queue a)-partition pred (Queue xs ys zs)-  = (balance xs1 ys1, balance xs2 ys2)-  where-    (xs1,xs2) = List.partition pred xs-    (ys1,ys2) = List.partition pred ys---{---------------------------------------------------------------------  Fold---------------------------------------------------------------------}--- | /O(n)/. Fold over the elements from left to right (ie. head to tail).-foldL :: (b -> a -> b) -> b -> Queue a -> b-foldL f z (Queue xs ys zs)-  = foldr (flip f) (foldl f z xs) ys---- | /O(n)/. Fold over the elements from right to left (ie. tail to head).-foldR :: (a -> b -> b) -> b -> Queue a -> b-foldR f z (Queue xs ys zs)-  = foldr f (foldl (flip f) z ys) xs---{---------------------------------------------------------------------  Conversion---------------------------------------------------------------------}--- | /O(n)/. The elements of a queue.-elems :: Queue a -> [a]-elems q-  = toList q---- | /O(n)/. Convert to a list.-toList :: Queue a -> [a]-toList (Queue xs ys zs)-  = xs ++ reverse ys---- | /O(n)/. Convert from a list.-fromList :: [a] -> Queue a-fromList xs-  = Queue xs [] xs---{---------------------------------------------------------------------  instance Eq, Show---------------------------------------------------------------------}-instance Eq a => Eq (Queue a) where-  q1 == q2  = toList q1 == toList q2--instance Show a => Show (Queue a) where-  showsPrec d q  = showsPrec d (toList q)---{---------------------------------------------------------------------  Smart constructor:-  Note that @(queue xs ys zs)@ is always called with -    @(length zs == length xs - length ys + 1)@. and thus-  @rotate@ is always called when @(length xs == length ys+1)@.---------------------------------------------------------------------}-balance :: [a] -> [a] -> Queue a-balance xs ys-  = Queue qs [] qs-  where-    qs = xs ++ reverse ys--queue :: [a] -> [a] -> [a] -> Queue a-queue xs ys (z:zs) = Queue xs ys zs-queue xs ys []     = Queue qs [] qs-                   where-                     qs = rotate xs ys []---- @(rotate xs ys []) == xs ++ reverse ys)@ -rotate :: [a] -> [a] -> [a] -> [a]-rotate []     [y]    zs  = y:zs-rotate (x:xs) (y:ys) zs  = x:rotate xs ys (y:zs) -rotate xs     ys     zs  = error "Queue.rotate: unbalanced queue"---valid :: Queue a -> Bool-valid (Queue xs ys zs)-  = (P.length zs == P.length xs - P.length ys) && (P.length ys <= P.length xs)--{--{---------------------------------------------------------------------  QuickCheck---------------------------------------------------------------------}-qcheck prop-  = check config prop-  where-    config = Config-      { configMaxTest = 500-      , configMaxFail = 10000-      , configSize    = \n -> (div n 2 + 3)-      , configEvery   = \n args -> let s = show n in s ++ [ '\b' | _ <- s ]-      }---{---------------------------------------------------------------------  Arbitrary, reasonably balanced queues---------------------------------------------------------------------}-instance Arbitrary a => Arbitrary (Queue a) where-  arbitrary = do{ qs <- arbitrary-                ; let (ys,xs) = splitAt (P.length qs `div` 2) qs-                ; return (Queue xs ys (xs ++ reverse ys))-                }---prop_Valid :: Queue Int -> Bool-prop_Valid q-  = valid q--prop_InsertLast :: [Int] -> Property-prop_InsertLast xs-  = not (null xs) ==> head (foldr insert empty xs) == last xs--prop_InsertValid :: [Int] -> Bool-prop_InsertValid xs-  = valid (foldr insert empty xs)--prop_Queue :: [Int] -> Bool-prop_Queue xs-  = toList (foldl (flip insert) empty xs) == foldr (:) [] xs-  -prop_List :: [Int] -> Bool-prop_List xs-  = toList (fromList xs) == xs--prop_TailValid :: [Int] -> Bool-prop_TailValid xs-  = valid (tail (foldr insert empty (1:xs)))--}-

@@ -1,309 +0,0 @@----------------------------------------------------------------------------------{-| Module      :  Scc-    Copyright   :  (c) Daan Leijen 2002-    License     :  BSD-style--    Maintainer  :  daan@cs.uu.nl-    Stability   :  provisional-    Portability :  portable--  Compute the /strongly connected components/ of a directed graph.-  The implementation is based on the following article:--  * David King and John Launchbury, /Lazy Depth-First Search and Linear Graph Algorithms in Haskell/,-    ACM Principles of Programming Languages, San Francisco, 1995.--  In contrast to their description, this module doesn't use lazy state-  threads but is instead purely functional -- using the "Map" and "Set" module.-  This means that the complexity of 'scc' is /O(n*log n)/ instead of /O(n)/ but-  due to the hidden constant factor, this implementation performs very well in practice.--}----------------------------------------------------------------------------------}-module UU.DData.Scc ( scc ) where--import qualified UU.DData.Map as Map-import qualified UU.DData.Set as Set --{---- just for testing-import Debug.QuickCheck       -import List(nub,sort)    --}--{---------------------------------------------------------------------  Graph---------------------------------------------------------------------}--- | A @Graph v@ is a directed graph with nodes @v@.-newtype Graph v = Graph (Map.Map v [v])---- | An @Edge v@ is a pair @(x,y)@ that represents an arrow from--- node @x@ to node @y@.-type Edge v     = (v,v)-type Node v     = (v,[v])--{---------------------------------------------------------------------  Conversion---------------------------------------------------------------------}-nodes :: Graph v -> [Node v]-nodes (Graph g)-  = Map.toList g--graph :: Ord v => [Node v] -> Graph v-graph es-  = Graph (Map.fromListWith (++) es)--{---------------------------------------------------------------------  Graph functions---------------------------------------------------------------------}-edges :: Graph v -> [Edge v]-edges g-  = [(v,w) | (v,vs) <- nodes g, w <- vs]--vertices :: Graph v -> [v]-vertices g-  = [v | (v,vs) <- nodes g]--successors :: Ord v => v -> Graph v -> [v]-successors v (Graph g)-  = Map.findWithDefault [] v g--transpose :: Ord v => Graph v -> Graph v-transpose g@(Graph m)-  = Graph (foldr add empty (edges g))-  where-    empty       = Map.map (const []) m-    add (v,w) m = Map.adjust (v:) w m---{---------------------------------------------------------------------  Depth first search and forests---------------------------------------------------------------------}-data Tree v   = Node v (Forest v) -type Forest v = [Tree v]--dff :: Ord v => Graph v -> Forest v-dff g-  = dfs g (vertices g)--dfs :: Ord v => Graph v -> [v] -> Forest v-dfs g vs      -  = prune (map (tree g) vs)--tree :: Ord v => Graph v -> v -> Tree v-tree g v  -  = Node v (map (tree g) (successors v g))--prune :: Ord v => Forest v -> Forest v-prune fs-  = snd (chop Set.empty  fs)-  where-    chop ms []  = (ms,[])-    chop ms (Node v vs:fs)-      | visited   = chop ms fs-      | otherwise = let ms0       = Set.insert v ms-                        (ms1,vs') = chop ms0 vs-                        (ms2,fs') = chop ms1 fs-                    in (ms2,Node v vs':fs')-      where-        visited   = Set.member v ms--{---------------------------------------------------------------------  Orderings---------------------------------------------------------------------}-preorder :: Ord v => Graph v -> [v]-preorder g-  = preorderF (dff g)--preorderF fs-  = concatMap preorderT fs--preorderT (Node v fs)-  = v:preorderF fs--postorder :: Ord v => Graph v -> [v]-postorder g-  = postorderF (dff g) --postorderT t-  = postorderF [t]--postorderF ts-  = postorderF' ts []-  where-    -- efficient concatenation by passing the tail around.-    postorderF' [] tl          = tl-    postorderF' (t:ts) tl      = postorderT' t (postorderF' ts tl)-    postorderT' (Node v fs) tl = postorderF' fs (v:tl)---{---------------------------------------------------------------------  Strongly connected components ---------------------------------------------------------------------}--{- | - Compute the strongly connected components of a graph. The algorithm- is tailored toward the needs of compiler writers that need to compute- recursive binding groups (for example, the original order is preserved- as much as possible). - - The expression (@scc xs@) computes the strongly connectected components- of graph @xs@. A graph is a list of nodes @(v,ws)@ where @v@ is the node - label and @ws@ a list of nodes where @v@ points to, ie. there is an - arrow\/dependency from @v@ to each node in @ws@. Here is an example- of @scc@:-->  Scc\> scc [(0,[1]),(1,[1,2,3]),(2,[1]),(3,[]),(4,[])]->  [[3],[1,2],[0],[4]]-- In an expression @(scc xs)@, the graph @xs@ should contain an entry for - every node in the graph, ie:-->  all (`elem` nodes) targets->  where nodes   = map fst xs->        targets = concat (map snd xs)-- Furthermore, the returned components consist exactly of the original nodes:-->  sort (concat (scc xs)) == sort (map fst xs)-- The connected components are sorted by dependency, ie. there are- no arrows\/dependencies from left-to-right. Furthermore, the original order- is preserved as much as possible. --}-scc :: Ord v => [(v,[v])] -> [[v]]-scc nodes-  = sccG (graph nodes)--sccG :: Ord v => Graph v -> [[v]]-sccG g-  = map preorderT (sccF g)--sccF :: Ord v => Graph v -> Forest v-sccF g         -  = reverse (dfs (transpose g) (topsort g))--topsort g-  = reverse (postorder g)--{---------------------------------------------------------------------  Reachable and path---------------------------------------------------------------------}-reachable v g-  = preorderF (dfs g [v])--path v w g-  = elem w (reachable v g)---{---------------------------------------------------------------------  Show---------------------------------------------------------------------}-instance Show v => Show (Graph v) where-  showsPrec d (Graph m) = shows m-  -instance Show v => Show (Tree v) where-  showsPrec d (Node v []) = shows v -  showsPrec d (Node v fs) = shows v . showList fs---{---------------------------------------------------------------------  Quick Test---------------------------------------------------------------------}-tgraph0 :: Graph Int-tgraph0 = graph -          [(0,[1])-          ,(1,[2,1,3])-          ,(2,[1])-          ,(3,[])-          ]--tgraph1 = graph-          [  ('a',"jg") -          ,  ('b',"ia")-          ,  ('c',"he")-          ,  ('d',"")-          ,  ('e',"jhd")-          ,  ('f',"i")-          ,  ('g',"fb")-          ,  ('h',"")-          ]--{--{---------------------------------------------------------------------  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 Graph's---------------------------------------------------------------------}-instance (Ord v,Arbitrary v) => Arbitrary (Graph v) where-  arbitrary   = sized arbgraph---arbgraph :: (Ord v,Arbitrary v) => Int -> Gen (Graph v)-arbgraph n-  = do nodes <- arbitrary-       g     <- mapM (targets nodes) nodes-       return (graph g)-  where-    targets nodes v-      = do sz <- choose (0,length nodes-1)-           ts <- mapM (target nodes) [1..sz]-           return (v,ts)-        -    target nodes _-      = do idx <- choose (0,length nodes-1)-           return (nodes!!idx)--{---------------------------------------------------------------------  Properties---------------------------------------------------------------------}-prop_ValidGraph :: Graph Int -> Bool-prop_ValidGraph g-  = all (`elem` srcs) targets-  where-    srcs    = map fst (nodes g)-    targets = concatMap snd (nodes g)---- all scc nodes are in the original graph and the other way around-prop_SccComplete :: Graph Int -> Bool-prop_SccComplete g-  = sort (concat (sccG g)) == sort (vertices g)---- all scc nodes have only backward dependencies-prop_SccForward :: Graph Int -> Bool-prop_SccForward g-  = all noforwards (zip prevs ss) -  where-    ss      = sccG g-    prevs   = scanl1 (++) ss--    noforwards (prev,xs)-      = all (noforward prev) xs-  -    noforward prev x-      = all (`elem` prev) (successors x g)---- all strongly connected components refer to each other-prop_SccConnected :: Graph Int -> Bool-prop_SccConnected g-  = all connected (sccG g)-  where-    connected xs-      = all (paths xs) xs--    paths xs x-      = all (\y -> path x y g) xs---}-

@@ -1,91 +0,0 @@----------------------------------------------------------------------------------{-| Module      :  Seq-    Copyright   :  (c) Daan Leijen 2002-    License     :  BSD-style--    Maintainer  :  daan@cs.uu.nl-    Stability   :  provisional-    Portability :  portable--  An implementation of John Hughes's efficient catenable sequence type. A lazy sequence-  @Seq a@ can be concatenated in /O(1)/ time. After-  construction, the sequence in converted in /O(n)/ time into a list.--}----------------------------------------------------------------------------------}-module UU.DData.Seq( -- * Type-            Seq-            -- * Operators-          , (<>)--            -- * Construction-          , empty-          , single-          , cons-          , append--            -- * Conversion-          , toList-          , fromList-          ) where---{---------------------------------------------------------------------  Operators---------------------------------------------------------------------}-infixr 5 <>---- | /O(1)/. Append two sequences, see 'append'.-(<>) :: Seq a -> Seq a -> Seq a-s <> t-  = append s t--{---------------------------------------------------------------------  Type---------------------------------------------------------------------}--- | Sequences of values @a@.-newtype Seq a = Seq ([a] -> [a])--{---------------------------------------------------------------------  Construction---------------------------------------------------------------------}--- | /O(1)/. Create an empty sequence.-empty :: Seq a-empty-  = Seq (\ts -> ts)---- | /O(1)/. Create a sequence of one element.-single :: a -> Seq a-single x-  = Seq (\ts -> x:ts)---- | /O(1)/. Put a value in front of a sequence.-cons :: a -> Seq a -> Seq a-cons x (Seq f)-  = Seq (\ts -> x:f ts)---- | /O(1)/. Append two sequences.-append :: Seq a -> Seq a -> Seq a-append (Seq f) (Seq g)-  = Seq (\ts -> f (g ts))---{---------------------------------------------------------------------  Conversion---------------------------------------------------------------------}--- | /O(n)/. Convert a sequence to a list.-toList :: Seq a -> [a]-toList (Seq f)-  = f []---- | /O(n)/. Create a sequence from a list.-fromList :: [a] -> Seq a-fromList xs-  = Seq (\ts -> xs++ts)--------

@@ -1,1032 +0,0 @@----------------------------------------------------------------------------------{-| Module      :  Set-    Copyright   :  (c) Daan Leijen 2002-    License     :  BSD-style--    Maintainer  :  daan@cs.uu.nl-    Stability   :  provisional-    Portability :  portable--  An efficient implementation of sets. --  1) The 'filter' function clashes with the "Prelude". -      If you want to use "Set" unqualified, this function should be hidden.--      > import Prelude hiding (filter)-      > import Set--      Another solution is to use qualified names. This is also the only way how-      a "Map", "Set", and "MultiSet" can be used within one module. --      > import qualified Set-      >-      > ... Set.single "Paris" --      Or, if you prefer a terse coding style:--      > import qualified Set as S-      >-      > ... S.single "Berlin" -  -  2) The implementation of "Set" is based on /size balanced/ binary trees (or-     trees of /bounded balance/) as described by:--     * Stephen Adams, \"/Efficient sets: a balancing act/\", Journal of Functional-       Programming 3(4):553-562, October 1993, <http://www.swiss.ai.mit.edu/~adams/BB>.--     * J. Nievergelt and E.M. Reingold, \"/Binary search trees of bounded balance/\",-       SIAM journal of computing 2(1), March 1973.--  3) Note that the implementation /left-biased/ -- the elements of a first argument-      are always perferred to the second, for example in 'union' or 'insert'.-      Off course, left-biasing can only be observed when equality an equivalence relation-      instead of structural equality.--  4) Another implementation of sets based on size balanced trees-      exists as "Data.Set" in the Ghc libraries. The good part about this library -      is that it is highly tuned and thorougly tested. However, it is also fairly old, -      it is implemented indirectly on top of "Data.FiniteMap" and only supports -      the basic set operations. -      The "Set" module overcomes some of these issues:-        -      * It tries to export a more complete and consistent set of operations, like-        'partition', 'subset' etc. --      * It uses the efficient /hedge/ algorithm for both 'union' and 'difference'-        (a /hedge/ algorithm is not applicable to 'intersection').-      -      * It converts ordered lists in linear time ('fromAscList').  --      * It takes advantage of the module system with names like 'empty' instead of 'Data.Set.emptySet'.-      -      * It is implemented directly, instead of using a seperate finite map implementation. --}-----------------------------------------------------------------------------------module UU.DData.Set  ( -            -- * Set type-              Set          -- instance Eq,Show--            -- * Operators-            , (\\)--            -- * Query-            , isEmpty-            , size-            , member-            , subset-            , properSubset-            -            -- * Construction-            , empty-            , single-            , insert-            , delete-            -            -- * Combine-            , union, unions-            , difference-            , intersection-            -            -- * Filter-            , filter-            , partition-            , split-            , splitMember--            -- * Fold-            , fold--            -- * Min\/Max-            , findMin-            , findMax-            , deleteMin-            , deleteMax-            , deleteFindMin-            , deleteFindMax--            -- * Conversion--            -- ** List-            , elems-            , toList-            , fromList-            -            -- ** Ordered list-            , toAscList-            , fromAscList-            , fromDistinctAscList-                        -            -- * Debugging-            , showTree-            , showTreeWith-            , valid-            ) where--import Prelude hiding (filter)--{---- just for testing-import QuickCheck -import List (nub,sort)-import qualified List--}--{---------------------------------------------------------------------  Operators---------------------------------------------------------------------}-infixl 9 \\ ------ | /O(n+m)/. See 'difference'.-(\\) :: Ord a => Set a -> Set a -> Set a-m1 \\ m2 = difference m1 m2--{---------------------------------------------------------------------  Sets are size balanced trees---------------------------------------------------------------------}--- | A set of values @a@.-data Set a    = Tip -              | Bin !Size a !(Set a) !(Set a) --type Size     = Int--{---------------------------------------------------------------------  Query---------------------------------------------------------------------}--- | /O(1)/. Is this the empty set?-isEmpty :: Set a -> Bool-isEmpty t-  = case t of-      Tip           -> True-      Bin sz x l r  -> False---- | /O(1)/. The number of elements in the set.-size :: Set a -> Int-size t-  = case t of-      Tip           -> 0-      Bin sz x l r  -> sz---- | /O(log n)/. Is the element in the set?-member :: Ord a => a -> Set a -> Bool-member x t-  = case t of-      Tip -> False-      Bin sz y l r-          -> case compare x y of-               LT -> member x l-               GT -> member x r-               EQ -> True       --{---------------------------------------------------------------------  Construction---------------------------------------------------------------------}--- | /O(1)/. The empty set.-empty  :: Set a-empty-  = Tip---- | /O(1)/. Create a singleton set.-single :: a -> Set a-single x -  = Bin 1 x Tip Tip--{---------------------------------------------------------------------  Insertion, Deletion---------------------------------------------------------------------}--- | /O(log n)/. Insert an element in a set.-insert :: Ord a => a -> Set a -> Set a-insert x t-  = case t of-      Tip -> single x-      Bin sz y l r-          -> case compare x y of-               LT -> balance y (insert x l) r-               GT -> balance y l (insert x r)-               EQ -> Bin sz x l r----- | /O(log n)/. Delete an element from a set.-delete :: Ord a => a -> Set a -> Set a-delete x t-  = case t of-      Tip -> Tip-      Bin sz y l r -          -> case compare x y of-               LT -> balance y (delete x l) r-               GT -> balance y l (delete x r)-               EQ -> glue l r--{---------------------------------------------------------------------  Subset---------------------------------------------------------------------}--- | /O(n+m)/. Is this a proper subset? (ie. a subset but not equal).-properSubset :: Ord a => Set a -> Set a -> Bool-properSubset s1 s2-  = (size s1 < size s2) && (subset s1 s2)----- | /O(n+m)/. Is this a subset?-subset :: Ord a => Set a -> Set a -> Bool-subset t1 t2-  = (size t1 <= size t2) && (subsetX t1 t2)--subsetX Tip t = True-subsetX t Tip = False-subsetX (Bin _ x l r) t-  = found && subsetX l lt && subsetX r gt-  where-    (found,lt,gt) = splitMember x t---{---------------------------------------------------------------------  Minimal, Maximal---------------------------------------------------------------------}--- | /O(log n)/. The minimal element of a set.-findMin :: Set a -> a-findMin (Bin _ x Tip r) = x-findMin (Bin _ x l r)   = findMin l-findMin Tip             = error "Set.findMin: empty set has no minimal element"---- | /O(log n)/. The maximal element of a set.-findMax :: Set a -> a-findMax (Bin _ x l Tip)  = x-findMax (Bin _ x l r)    = findMax r-findMax Tip              = error "Set.findMax: empty set has no maximal element"---- | /O(log n)/. Delete the minimal element.-deleteMin :: Set a -> Set a-deleteMin (Bin _ x Tip r) = r-deleteMin (Bin _ x l r)   = balance x (deleteMin l) r-deleteMin Tip             = Tip---- | /O(log n)/. Delete the maximal element.-deleteMax :: Set a -> Set a-deleteMax (Bin _ x l Tip) = l-deleteMax (Bin _ x l r)   = balance x l (deleteMax r)-deleteMax Tip             = Tip---{---------------------------------------------------------------------  Union. ---------------------------------------------------------------------}--- | The union of a list of sets: (@unions == foldl union empty@).-unions :: Ord a => [Set a] -> Set a-unions ts-  = foldlStrict union empty ts----- | /O(n+m)/. The union of two sets. Uses the efficient /hedge-union/ algorithm.-union :: Ord a => Set a -> Set a -> Set a-union Tip t2  = t2-union t1 Tip  = t1-union t1 t2  -- hedge-union is more efficient on (bigset `union` smallset)-  | size t1 >= size t2  = hedgeUnion (const LT) (const GT) t1 t2-  | otherwise           = hedgeUnion (const LT) (const GT) t2 t1--hedgeUnion cmplo cmphi t1 Tip -  = t1-hedgeUnion cmplo cmphi Tip (Bin _ x l r)-  = join x (filterGt cmplo l) (filterLt cmphi r)-hedgeUnion cmplo cmphi (Bin _ x l r) t2-  = join x (hedgeUnion cmplo cmpx l (trim cmplo cmpx t2)) -           (hedgeUnion cmpx cmphi r (trim cmpx cmphi t2))-  where-    cmpx y  = compare x y--{---------------------------------------------------------------------  Difference---------------------------------------------------------------------}--- | /O(n+m)/. Difference of two sets. --- The implementation uses an efficient /hedge/ algorithm comparable with /hedge-union/.-difference :: Ord a => Set a -> Set a -> Set a-difference Tip t2  = Tip-difference t1 Tip  = t1-difference t1 t2   = hedgeDiff (const LT) (const GT) t1 t2--hedgeDiff cmplo cmphi Tip t     -  = Tip-hedgeDiff cmplo cmphi (Bin _ x l r) Tip -  = join x (filterGt cmplo l) (filterLt cmphi r)-hedgeDiff cmplo cmphi t (Bin _ x l r) -  = merge (hedgeDiff cmplo cmpx (trim cmplo cmpx t) l) -          (hedgeDiff cmpx cmphi (trim cmpx cmphi t) r)-  where-    cmpx y = compare x y--{---------------------------------------------------------------------  Intersection---------------------------------------------------------------------}--- | /O(n+m)/. The intersection of two sets.-intersection :: Ord a => Set a -> Set a -> Set a-intersection Tip t = Tip-intersection t Tip = Tip-intersection t1 t2  -- intersection is more efficient on (bigset `intersection` smallset)-  | size t1 >= size t2  = intersect t1 t2-  | otherwise           = intersect t2 t1--intersect Tip t = Tip-intersect t Tip = Tip-intersect t (Bin _ x l r)-  | found     = join x tl tr-  | otherwise = merge tl tr-  where-    (found,lt,gt) = splitMember x t-    tl            = intersect lt l-    tr            = intersect gt r---{---------------------------------------------------------------------  Filter and partition---------------------------------------------------------------------}--- | /O(n)/. Filter all elements that satisfy the predicate.-filter :: Ord a => (a -> Bool) -> Set a -> Set a-filter p Tip = Tip-filter p (Bin _ x l r)-  | p x       = join x (filter p l) (filter p r)-  | otherwise = merge (filter p l) (filter p r)---- | /O(n)/. Partition the set into two sets, one with all elements that satisfy--- the predicate and one with all elements that don't satisfy the predicate.--- See also 'split'.-partition :: Ord a => (a -> Bool) -> Set a -> (Set a,Set a)-partition p Tip = (Tip,Tip)-partition p (Bin _ x l r)-  | p x       = (join x l1 r1,merge l2 r2)-  | otherwise = (merge l1 r1,join x l2 r2)-  where-    (l1,l2) = partition p l-    (r1,r2) = partition p r--{---------------------------------------------------------------------  Fold---------------------------------------------------------------------}--- | /O(n)/. Fold the elements of a set.-fold :: (a -> b -> b) -> b -> Set a -> b-fold f z s-  = foldR f z s---- | /O(n)/. Post-order fold.-foldR :: (a -> b -> b) -> b -> Set a -> b-foldR f z Tip           = z-foldR f z (Bin _ x l r) = foldR f (f x (foldR f z r)) l---{---------------------------------------------------------------------  List variations ---------------------------------------------------------------------}--- | /O(n)/. The elements of a set.-elems :: Set a -> [a]-elems s-  = toList s--{---------------------------------------------------------------------  Lists ---------------------------------------------------------------------}--- | /O(n)/. Convert the set to a list of elements.-toList :: Set a -> [a]-toList s-  = toAscList s---- | /O(n)/. Convert the set to an ascending list of elements.-toAscList :: Set a -> [a]-toAscList t   -  = foldR (:) [] t----- | /O(n*log n)/. Create a set from a list of elements.-fromList :: Ord a => [a] -> Set a -fromList xs -  = foldlStrict ins empty xs-  where-    ins t x = insert x t--{---------------------------------------------------------------------  Building trees from ascending/descending lists can be done in linear time.-  -  Note that if [xs] is ascending that: -    fromAscList xs == fromList xs---------------------------------------------------------------------}--- | /O(n)/. Build a map from an ascending list in linear time.-fromAscList :: Eq a => [a] -> Set a -fromAscList xs-  = fromDistinctAscList (combineEq xs)-  where-  -- [combineEq xs] combines equal elements with [const] in an ordered list [xs]-  combineEq xs-    = case xs of-        []     -> []-        [x]    -> [x]-        (x:xx) -> combineEq' x xx--  combineEq' z [] = [z]-  combineEq' z (x:xs)-    | z==x      = combineEq' z xs-    | otherwise = z:combineEq' x xs----- | /O(n)/. Build a set from an ascending list of distinct elements in linear time.-fromDistinctAscList :: [a] -> Set a -fromDistinctAscList xs-  = build const (length xs) xs-  where-    -- 1) use continutations so that we use heap space instead of stack space.-    -- 2) special case for n==5 to build bushier trees. -    build c 0 xs   = c Tip xs -    build c 5 xs   = case xs of-                       (x1:x2:x3:x4:x5:xx) -                            -> c (bin x4 (bin x2 (single x1) (single x3)) (single x5)) xx-    build c n xs   = seq nr $ build (buildR nr c) nl xs-                   where-                     nl = n `div` 2-                     nr = n - nl - 1--    buildR n c l (x:ys) = build (buildB l x c) n ys-    buildB l x c r zs   = c (bin x l r) zs--{---------------------------------------------------------------------  Eq converts the set to a list. In a lazy setting, this -  actually seems one of the faster methods to compare two trees -  and it is certainly the simplest :-)---------------------------------------------------------------------}-instance Eq a => Eq (Set a) where-  t1 == t2  = (size t1 == size t2) && (toAscList t1 == toAscList t2)--{---------------------------------------------------------------------  Show---------------------------------------------------------------------}-instance Show a => Show (Set a) where-  showsPrec d s  = showSet (toAscList s)--showSet :: (Show a) => [a] -> ShowS-showSet []     -  = showString "{}" -showSet (x:xs) -  = showChar '{' . shows x . showTail xs-  where-    showTail []     = showChar '}'-    showTail (x:xs) = showChar ',' . shows x . showTail xs-    --{---------------------------------------------------------------------  Utility functions that return sub-ranges of the original-  tree. Some functions take a comparison function as argument to-  allow comparisons against infinite values. A function [cmplo x]-  should be read as [compare lo x].--  [trim cmplo cmphi t]  A tree that is either empty or where [cmplo x == LT]-                        and [cmphi x == GT] for the value [x] of the root.-  [filterGt cmp t]      A tree where for all values [k]. [cmp k == LT]-  [filterLt cmp t]      A tree where for all values [k]. [cmp k == GT]--  [split k t]           Returns two trees [l] and [r] where all values-                        in [l] are <[k] and all keys in [r] are >[k].-  [splitMember k t]     Just like [split] but also returns whether [k]-                        was found in the tree.---------------------------------------------------------------------}--{---------------------------------------------------------------------  [trim lo hi t] trims away all subtrees that surely contain no-  values between the range [lo] to [hi]. The returned tree is either-  empty or the key of the root is between @lo@ and @hi@.---------------------------------------------------------------------}-trim :: (a -> Ordering) -> (a -> Ordering) -> Set a -> Set a-trim cmplo cmphi Tip = Tip-trim cmplo cmphi t@(Bin sx x l r)-  = case cmplo x of-      LT -> case cmphi x of-              GT -> t-              le -> trim cmplo cmphi l-      ge -> trim cmplo cmphi r-              -trimMemberLo :: Ord a => a -> (a -> Ordering) -> Set a -> (Bool, Set a)-trimMemberLo lo cmphi Tip = (False,Tip)-trimMemberLo lo cmphi t@(Bin sx x l r)-  = case compare lo x of-      LT -> case cmphi x of-              GT -> (member lo t, t)-              le -> trimMemberLo lo cmphi l-      GT -> trimMemberLo lo cmphi r-      EQ -> (True,trim (compare lo) cmphi r)---{---------------------------------------------------------------------  [filterGt x t] filter all values >[x] from tree [t]-  [filterLt x t] filter all values <[x] from tree [t]---------------------------------------------------------------------}-filterGt :: (a -> Ordering) -> Set a -> Set a-filterGt cmp Tip = Tip-filterGt cmp (Bin sx x l r)-  = case cmp x of-      LT -> join x (filterGt cmp l) r-      GT -> filterGt cmp r-      EQ -> r-      -filterLt :: (a -> Ordering) -> Set a -> Set a-filterLt cmp Tip = Tip-filterLt cmp (Bin sx x l r)-  = case cmp x of-      LT -> filterLt cmp l-      GT -> join x l (filterLt cmp r)-      EQ -> l---{---------------------------------------------------------------------  Split---------------------------------------------------------------------}--- | /O(log n)/. The expression (@split x set@) is a pair @(set1,set2)@--- where all elements in @set1@ are lower than @x@ and all elements in--- @set2@ larger than @x@.-split :: Ord a => a -> Set a -> (Set a,Set a)-split x Tip = (Tip,Tip)-split x (Bin sy y l r)-  = case compare x y of-      LT -> let (lt,gt) = split x l in (lt,join y gt r)-      GT -> let (lt,gt) = split x r in (join y l lt,gt)-      EQ -> (l,r)---- | /O(log n)/. Performs a 'split' but also returns whether the pivot--- element was found in the original set.-splitMember :: Ord a => a -> Set a -> (Bool,Set a,Set a)-splitMember x Tip = (False,Tip,Tip)-splitMember x (Bin sy y l r)-  = case compare x y of-      LT -> let (found,lt,gt) = splitMember x l in (found,lt,join y gt r)-      GT -> let (found,lt,gt) = splitMember x r in (found,join y l lt,gt)-      EQ -> (True,l,r)--{---------------------------------------------------------------------  Utility functions that maintain the balance properties of the tree.-  All constructors assume that all values in [l] < [x] and all values-  in [r] > [x], and that [l] and [r] are valid trees.-  -  In order of sophistication:-    [Bin sz x l r]    The type constructor.-    [bin x l r]       Maintains the correct size, assumes that both [l]-                      and [r] are balanced with respect to each other.-    [balance x l r]   Restores the balance and size.-                      Assumes that the original tree was balanced and-                      that [l] or [r] has changed by at most one element.-    [join x l r]      Restores balance and size. --  Furthermore, we can construct a new tree from two trees. Both operations-  assume that all values in [l] < all values in [r] and that [l] and [r]-  are valid:-    [glue l r]        Glues [l] and [r] together. Assumes that [l] and-                      [r] are already balanced with respect to each other.-    [merge l r]       Merges two trees and restores balance.--  Note: in contrast to Adam's paper, we use (<=) comparisons instead-  of (<) comparisons in [join], [merge] and [balance]. -  Quickcheck (on [difference]) showed that this was necessary in order -  to maintain the invariants. It is quite unsatisfactory that I haven't -  been able to find out why this is actually the case! Fortunately, it -  doesn't hurt to be a bit more conservative.---------------------------------------------------------------------}--{---------------------------------------------------------------------  Join ---------------------------------------------------------------------}-join :: a -> Set a -> Set a -> Set a-join x Tip r  = insertMin x r-join x l Tip  = insertMax x l-join x l@(Bin sizeL y ly ry) r@(Bin sizeR z lz rz)-  | delta*sizeL <= sizeR  = balance z (join x l lz) rz-  | delta*sizeR <= sizeL  = balance y ly (join x ry r)-  | otherwise             = bin x l r----- insertMin and insertMax don't perform potentially expensive comparisons.-insertMax,insertMin :: a -> Set a -> Set a -insertMax x t-  = case t of-      Tip -> single x-      Bin sz y l r-          -> balance y l (insertMax x r)-             -insertMin x t-  = case t of-      Tip -> single 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 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 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 == single 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 (single 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))--}

@@ -5,7 +5,9 @@                          , pOpen                           , pClose                           , pSeparator -                         , scanOffside +                         , scanOffside+                         , scanOffsideWithTriggers+                         , OffsideTrigger(..)                          , OffsideSymbol(..)                          , OffsideInput                          , Stream@@ -13,100 +15,118 @@                          ) where                           import GHC.Prim+import Data.Maybe import UU.Parsing.Interface import UU.Parsing.Machine import UU.Parsing.Derived(opt, pFoldr1Sep,pList,pList1, pList1Sep) import UU.Scanner.Position -data OffsideSymbol s = -                Symbol s-              | SemiColon-              | CloseBrace-              | OpenBrace-              deriving (Ord,Eq,Show)+data OffsideTrigger+  = Trigger_IndentGT+  | Trigger_IndentGE+  deriving Eq +data OffsideSymbol s+  = Symbol s+  | SemiColon+  | CloseBrace+  | OpenBrace+  deriving (Ord,Eq,Show) +data Stream inp s p+  = Cons (OffsideSymbol s) (OffsideInput inp s p) +  | End inp++data IndentContext+  = Cxt     Bool                -- properties: allows nesting on equal indentation (triggered by Trigger_IndentGE)+            Int					-- indentation++data OffsideInput inp s p+  = Off p                                   -- position+        (Stream inp s p)                    -- input stream+        (Maybe (OffsideInput inp s p))      -- next in stack of nested OffsideInput's+ scanOffside :: (InputState i s p, Position p, Eq s)              =>  s ->  s -> s -> [s] -> i -> OffsideInput i s p  -scanOffside mod open close triggers ts = start ts []+scanOffside mod open close triggers ts+  = scanOffsideWithTriggers mod open close (zip (repeat Trigger_IndentGT) triggers) ts++scanOffsideWithTriggers :: (InputState i s p, Position p, Eq s) +            =>  s ->  s -> s -> [(OffsideTrigger,s)] -> i -> OffsideInput i s p  +scanOffsideWithTriggers mod open close triggers ts = start ts []  where- isModule  t = t == mod - isOpen    t = t == open- isClose   t = t == close- isTrigger t = t `elem` triggers+ isModule    t = t == mod + isOpen      t = t == open+ isClose     t = t == close+ isTrigger tr  = \t -> t `elem` triggers'+               where triggers' = [ s | (tr',s) <- triggers, tr == tr' ]+ isTriggerGT   = isTrigger Trigger_IndentGT+ isTriggerGE   = isTrigger Trigger_IndentGE  end ts    = Off (getPosition ts) (End ts)  cons :: p -> OffsideSymbol s -> OffsideInput i s p -> OffsideInput i s p  cons p s r =  Off p (Cons s r) Nothing    start = case splitStateE ts of-          Left' t _ | not (isModule t || isOpen t) -> implicitL 0 (column (getPosition ts) )+          Left' t _ | not (isModule t || isOpen t) -> implicitL 0 (Cxt False (column (getPosition ts)))           _                                        -> layoutL   0  - -- L (<n>:ts) (m:ms) 	= ; : (L ts (m:ms)) 	if m = n - --	                = } : (L (<n>:ts) ms) 	if n < m - -- L (<n>:ts) ms 	= L ts ms - startlnL l n ts (m:ms) | m == n  = cons (getPosition ts) SemiColon  (layoutL (line (getPosition ts)) ts (m:ms))    -                          | n <  m  = cons (getPosition ts) CloseBrace (startlnL l n ts ms)- startlnL l n ts ms               = layoutL (line (getPosition ts))  ts ms- -- L  ({n}:ts)  (m:ms) = { : (L  ts (n:m:ms))     if n > m    (Note  1) - -- L  ({n}:ts)  []     = { : (L  ts [n])          if n > 0    (Note  1) + -- L (<n>:ts) (m:ms)   = ; : (L ts (m:ms))     if m = n + --                     = } : (L (<n>:ts) ms)   if n < m + -- L (<n>:ts) ms       = L ts ms + startlnL  l n ts (m:ms) | m == n    = cons (getPosition ts) SemiColon  (layoutL (line (getPosition ts)) ts (m:ms))    +                         | n <  m    = cons (getPosition ts) CloseBrace (startlnL l n ts ms)+ startlnL  l n ts ms                 = layoutL (line (getPosition ts))  ts ms++ -- L  ({n}:ts)  (m:ms) = { : (L  ts (n:m:ms))     if n >  m    (Note  1) + -- L  ({n}:ts)  (m:ms) = { : (L  ts (n:m:ms))     if n >= m    (as per Haskell2010, inside a do only) + -- L  ({n}:ts)  []     = { : (L  ts [n])          if n >  0    (Note  1)   -- L  ({n}:ts)  ms     = { : } : (L  (<n>:ts) ms) (Note  2) - implicitL l n ts (m:ms) | n > m  = cons (getPosition ts) OpenBrace (layoutL (line (getPosition ts)) ts (n:m:ms))- implicitL l n ts []     | n > 0  = cons (getPosition ts) OpenBrace (layoutL (line (getPosition ts)) ts [n])- implicitL l n ts ms              = cons (getPosition ts) OpenBrace (cons (getPosition ts) CloseBrace (startlnL l n ts ms))- layoutL ln ts ms | ln /= sln = startln (column pos) ts ms-                    | otherwise     = sameln ts ms+ implicitL l (Cxt ge n) ts (m:ms) |     n >  m+                                    || (n >= m && ge)+                                              = cons (getPosition ts) OpenBrace (layoutL (line (getPosition ts)) ts (n:m:ms))+ implicitL l (Cxt _  n) ts []     | n >  0    = cons (getPosition ts) OpenBrace (layoutL (line (getPosition ts)) ts [n])+ implicitL l (Cxt _  n) ts ms                 = cons (getPosition ts) OpenBrace (cons (getPosition ts) CloseBrace (startlnL l n ts ms))++ layoutL   ln  ts ms     | ln /= sln = startln (column pos) ts ms+                         | otherwise = sameln ts ms       -  where sln = line pos-        pos   = getPosition ts+  where sln       = line pos+        pos       = getPosition ts         layout    = layoutL ln               implicit  = implicitL ln-        startln = startlnL ln    +        startln   = startlnL ln             -- If a let ,where ,do , or of keyword is not followed by the lexeme {,           -- the token {n} is inserted after the keyword, where nis the indentation of         -- the  next lexeme if there is one, or 0 if the end of file has been reached. -        aftertrigger ts ms = case splitStateE ts of-                                Left' t _  | isOpen t  -> layout ts ms-                                           | otherwise -> implicit (column(getPosition ts)) ts ms-                                Right' _               -> implicit 0 ts ms+        aftertrigger isTriggerGE ts ms+          = case splitStateE ts of+              Left' t _  | isOpen t  -> layout ts ms+                         | otherwise -> implicit (Cxt isTriggerGE (column(getPosition ts))) ts ms+              Right' _               -> implicit (Cxt False       0                       ) ts ms           -- L  ( }:ts)  (0:ms) = } : (L  ts ms)          (Note  3) -        --              L  ( }:ts)  ms     = parse-error             (Note  3), matching of implicit/explicit braces is handled by parser+        -- L  ( }:ts)  ms     = parse-error             (Note  3), matching of implicit/explicit braces is handled by parser         -- L  ( {:ts)  ms     = {: (L  ts (0:ms))       (Note  4)          -- L  (t:ts)  (m:ms)  = }: (L  (t:ts)  ms)      if  m /= 0  and  parse-error(t) (Note  5)          -- L  (t:ts)  ms      = t : (L  ts ms) -        sameln tts ms = case splitStateE tts of+        sameln tts ms+          = case splitStateE tts of               Left'  t ts  ->                         let tail-                              | isTrigger t  = aftertrigger ts ms-                              | isClose t    = case ms of-                                                         0:rs -> layout ts rs-                                                         _    -> layout ts ms+                              | isTriggerGE t = aftertrigger True  ts ms+                              | isTriggerGT t = aftertrigger False ts ms+                              | isClose     t = case ms of+                                                  0:rs -> layout ts rs+                                                  _    -> layout ts ms -                              | isOpen t    = layout ts (0:ms)-                              | otherwise   = layout ts ms+                              | isOpen      t = layout ts (0:ms)+                              | otherwise     = layout ts ms                             parseError = case ms of                                            m:ms  | m /= 0 -> Just (layout tts ms)                                            _              -> Nothing                         in  Off pos (Cons (Symbol t) tail) parseError               Right' rest -> endofinput pos rest ms           where pos = getPosition tts-{--        sameln tts ms = case splitStateE tts of-                Left'  t ts  | isTrigger t -> cons pos (Symbol t) (aftertrigger ts ms)-                             | isClose t   -> cons pos (Symbol t) -                                                (case ms of-                                                   0:ms -> layout ts ms-                                                   _    -> layout ts ms-                                                )   -                             | isOpen t    -> cons pos (Symbol t) (layout ts (0:ms))                            -                             | otherwise   -> let parseError = case ms of-                                                                  m:ms  | m /= 0 -> Just (layout tts ms)-                                                                  _              -> Nothing-                                              in Off pos (Cons (Symbol t) (layout ts ms)) parseError-                Right' rest -> endofinput pos rest ms-          where pos = getPosition tts                        --}          -- L  []  []          = []          -- L  []  (m:ms)      = } : L  []  ms           if m /=0   (Note  6) @@ -116,18 +136,17 @@                                    | otherwise = endofinput pos rest ms  -data Stream inp s p = Cons (OffsideSymbol s) (OffsideInput inp s p) -                    | End inp--data OffsideInput inp s p = Off p (Stream inp s p) (Maybe (OffsideInput inp s p))- instance InputState inp s p => InputState (OffsideInput inp s p) (OffsideSymbol s) p where-  splitStateE inp@(Off p stream _) = case stream of-                                     Cons s rest -> Left' s rest-                                     _           -> Right' inp                                 -  splitState (Off _ stream _) = -           case stream of-            Cons s rest -> (# s ,rest #)                        +  splitStateE inp@(Off p stream _)+    = case stream of+        Cons s rest -> Left' s rest+                    where take 0 _                    = []+                          take _ (Off _ (End _)    _) = []+                          take n (Off _ (Cons h t) _) = h : take (n-1) t+        _           -> Right' inp                                 +  splitState (Off _ stream _)+    = case stream of+        Cons s rest -> (# s, rest #)    getPosition (Off pos _ _ ) = pos   @@ -140,7 +159,7 @@   symBefore s = case s of                  Symbol s   -> Symbol (symBefore s)                  SemiColon  -> error "Symbol.symBefore SemiColon"-                 OpenBrace  -> error "Symbol.symBeforeOpenBrace"+                 OpenBrace  -> error "Symbol.symBefore OpenBrace"                  CloseBrace -> error "Symbol.symBefore CloseBrace"   symAfter s = case s of                  Symbol s   -> Symbol (symAfter s)@@ -198,9 +217,12 @@ pClose = OP (pWrap f g ( () <$ pSym CloseBrace) )   where g state steps1 k = (state,ar,k)           where ar = case state of-                               Off _ _ (Just state') -> let steps2 = k state'-                                                        in if not (hasSuccess steps1) && hasSuccess steps2 then steps2 else steps1-                               _                     -> steps1+                               Off _ _ (Just state')+                                 -> let steps2 = k state'+                                    in if not (hasSuccess steps1) && hasSuccess steps2+                                       then Cost 1# steps2+                                       else steps1+                               _ -> steps1                      f acc state steps k = let (stl,ar,str2rr) = g state (val snd steps)  k                               in (stl ,val (acc ()) ar , str2rr )@@ -224,11 +246,18 @@        -> OffsideParser i o s p a         -> OffsideParser i o s p [a] pBlock open sep close p =  pOffside open close explicit implicit+ where elem = (Just <$> p) `opt` Nothing+       sep' = () <$ sep        +       elems s = (\h t -> catMaybes (h:t)) <$> elem <*> pList (s *> elem)+       explicit = elems sep'+       implicit = elems (sep' <|> pSeparator)+{-  where elem = (:) <$> p `opt` id        sep' = () <$ sep                elems s = ($[]) <$> pFoldr1Sep ((.),id) s elem        explicit = elems sep'        implicit = elems (sep' <|> pSeparator)+-}  pBlock1 :: (InputState i s p, OutputState o, Position p, Symbol s, Ord s)         => OffsideParser i o s p x @@ -237,11 +266,34 @@        -> OffsideParser i o s p a         -> OffsideParser i o s p [a] pBlock1 open sep close p =  pOffside open close explicit implicit+ where elem = (Just <$> p) `opt` Nothing+       sep' = () <$ sep+       elems s = (\h t -> catMaybes (h:t)) <$ pList s <*> (Just <$> p) <*> pList (s *> elem)+       explicit = elems sep'+       implicit = elems (sep' <|> pSeparator)+{-+ where elem = (Just <$> p) `opt` Nothing+       sep' = () <$ sep+       elems s = (\h t -> catMaybes (h:t)) <$ pList s <*> (Just <$> p) <*> pList ( s *> elem)+       explicit = elems sep'+       implicit = elems (sep' <|> pSeparator)+-}+{-+pBlock1 open sep close p =  pOffside open close explicit implicit+ where elem = (Just <$> p) <|> pSucceed Nothing+       sep' = () <$ sep+       elems s = (\h t -> catMaybes (h:t)) <$ pList s <*> (Just <$> p) <*> pList ( s *> elem)+       explicit = elems sep'+       implicit = elems (sep' <|> pSeparator)+-}+{-+pBlock1 open sep close p =  pOffside open close explicit implicit  where elem = (:) <$> p `opt` id        sep' = () <$ sep        elems s = (:) <$ pList s <*> p <*> (($[]) <$> pFoldr1Sep ((.),id) s elem)        explicit = elems sep'        implicit = elems (sep' <|> pSeparator)+-} {- pBlock1 open sep close p =  pOffside open close explicit implicit  where sep'    = () <$ sep

@@ -1,7 +1,7 @@ cabal-version: >=1.1 build-type: Simple name: uulib-version: 0.9.10+version: 0.9.11 license: LGPL license-file: COPYRIGHT maintainer: Arie Middelkoop <ariem@cs.uu.nl>@@ -21,24 +21,21 @@   description: ghc-prim as separate module library   if flag(have_ghc_prim)-    build-depends: base>=4, ghc-prim+    build-depends: base>=4 && <10, ghc-prim   else     build-depends: base<4   build-depends: haskell98   exposed-modules: UU.Parsing.CharParser UU.Parsing.Derived                    UU.Parsing.Interface UU.Parsing.MachineInterface                    UU.Parsing.Merge UU.Parsing.Offside UU.Parsing.Perms-                   UU.Parsing.StateParser UU.Parsing UU.DData.IntBag -                   UU.DData.Map UU.DData.MultiSet UU.DData.Queue-                   UU.DData.Scc UU.DData.Seq UU.DData.Set UU.PPrint+                   UU.Parsing.StateParser UU.Parsing+                   UU.PPrint                    UU.Pretty.Ext UU.Pretty UU.Scanner.GenToken UU.Scanner.GenTokenOrd                    UU.Scanner.GenTokenParser UU.Scanner.GenTokenSymbol                    UU.Scanner.Position UU.Scanner.Scanner                    UU.Scanner.Token UU.Scanner.TokenParser UU.Scanner.TokenShow                    UU.Scanner UU.Util.BinaryTrees UU.Util.PermTree UU.Util.Utils                    UU.Pretty.Basic UU.Parsing.Machine    -                   UU.DData.IntMap  -                   UU.DData.IntSet           extensions:  RankNTypes FunctionalDependencies TypeSynonymInstances UndecidableInstances FlexibleInstances MultiParamTypeClasses FlexibleContexts CPP ExistentialQuantification   ghc-options: -fglasgow-exts   hs-source-dirs: src