Wed Mar 19 16:31:52 WET 2008 Miguel Vilaca <jmvilaca@di.uminho.pt>
* Clean unnecessary stuff
{
hunk ./Makefile 46
-DDATA = lib/DData/IntBag.hs lib/DData/IntMap.hs lib/DData/IntSet.hs \
- lib/DData/Map.hs lib/DData/MultiSet.hs \
- lib/DData/Queue.hs lib/DData/Scc.hs \
- lib/DData/Seq.hs lib/DData/Set.hs \
+DDATA = lib/DData/IntMap.hs
hunk ./Makefile 122
-lib/DData/Set.o : lib/DData/Set.hs
-lib/DData/Seq.o : lib/DData/Seq.hs
-lib/DData/Queue.o : lib/DData/Queue.hs
-lib/DData/Map.o : lib/DData/Map.hs
-lib/DData/MultiSet.o : lib/DData/MultiSet.hs
-lib/DData/MultiSet.o : lib/DData/Map.hi
-lib/DData/Scc.o : lib/DData/Scc.hs
-lib/DData/Scc.o : lib/DData/Set.hi
-lib/DData/Scc.o : lib/DData/Map.hi
-lib/DData/IntSet.o : lib/DData/IntSet.hs
hunk ./Makefile 123
-lib/DData/IntBag.o : lib/DData/IntBag.hs
-lib/DData/IntBag.o : lib/DData/IntMap.hi
hunk ./lib/DData/IntBag.hs 1
---------------------------------------------------------------------------------
-{-| 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 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 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
-
rmfile ./lib/DData/IntBag.hs
hunk ./lib/DData/IntSet.hs 1
-{-# 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 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
-
-infixl 9 \\ -- cpp nonsense
-
-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
-infixl 9 \\
-
-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
-infixl 9 \\
-
-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
-
-{--------------------------------------------------------------------
- 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))
--}
rmfile ./lib/DData/IntSet.hs
hunk ./lib/DData/Map.hs 1
---------------------------------------------------------------------------------
-{-| Module : Map
- Copyright : (c) Daan Leijen 2002
- License : BSD-style
hunk ./lib/DData/Map.hs 2
- 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 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])])
--}
rmfile ./lib/DData/Map.hs
hunk ./lib/DData/MultiSet.hs 1
---------------------------------------------------------------------------------
-{-| 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 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 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 0)
- [_$_]
-{--------------------------------------------------------------------
- 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
-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 > 0 = 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
- = MultiSet (M.unions [m | MultiSet m <- 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))
rmfile ./lib/DData/MultiSet.hs
hunk ./lib/DData/Queue.hs 1
---------------------------------------------------------------------------------
-{-| Module : Queue
- Copyright : (c) Daan Leijen 2002
- License : BSD-style
hunk ./lib/DData/Queue.hs 2
- 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 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)))
--}
rmfile ./lib/DData/Queue.hs
hunk ./lib/DData/Scc.hs 1
---------------------------------------------------------------------------------
-{-| Module : Scc
- Copyright : (c) Daan Leijen 2002
- License : BSD-style
hunk ./lib/DData/Scc.hs 2
- 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 Scc ( scc ) where
-
-import qualified Map [_$_]
-import qualified 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
-
--}
rmfile ./lib/DData/Scc.hs
hunk ./lib/DData/Seq.hs 1
---------------------------------------------------------------------------------
-{-| 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 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)
-
-
-
-
-
-
-
-
rmfile ./lib/DData/Seq.hs
hunk ./lib/DData/Set.hs 1
---------------------------------------------------------------------------------
-{-| 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.singleton "Paris" [_$_]
-
- Or, if you prefer a terse coding style:
-
- > import qualified Set as S
- >
- > ... S.singleton "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 Set ( [_$_]
- -- * Set type
- Set -- instance Eq,Show
-
- -- * Operators
- , (\\)
-
- -- * Query
- , isEmpty
- , Set.null
- , size
- , member
- , subset
- , properSubset
- [_$_]
- -- * Construction
- , empty
- , singleton
- , insert
- , delete
- [_$_]
- -- * Combine
- , union, unions
- , difference
- , intersection
- [_$_]
- -- * Filter
- , filter
- , partition
- , split
- , splitMember
-
- -- * Fold
- , Set.map
- , mapMonotonic
- , 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,map)
-import List (map)
-
-{-
--- 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
-
-null :: Set a -> Bool
-null = isEmpty
-
--- | /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.
-singleton :: a -> Set a
-singleton 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 -> singleton 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
-
-{----------------------------------------------------------------------
- Map
-----------------------------------------------------------------------}
-
--- | /O(n*log n)/. [_$_]
--- @'map' f s@ is the set obtained by applying @f@ to each element of @s@.
--- [_$_]
--- It's worth noting that the size of the result may be smaller if,
--- for some @(x,y)@, @x \/= y && f x == f y@
-
-map :: (Ord a, Ord b) => (a->b) -> Set a -> Set b
-map f = fromList . List.map f . toList
-
--- | /O(n)/. The [_$_]
---
--- @'mapMonotonic' f s == 'map' f s@, but works only when @f@ is monotonic.
--- /The precondition is not checked./
--- Semi-formally, we have:
--- [_$_]
--- > and [x < y ==> f x < f y | x <- ls, y <- ls] [_$_]
--- > ==> mapMonotonic f s == map f s
--- > where ls = toList s
-
-mapMonotonic :: (a->b) -> Set a -> Set b
-mapMonotonic f Tip = Tip
-mapMonotonic f (Bin sz x l r) =
- Bin sz (f x) (mapMonotonic f l) (mapMonotonic f 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 (singleton x1) (singleton x3)) (singleton 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)
-
-{--------------------------------------------------------------------
- Ord
---------------------------------------------------------------------}
-instance Ord a => Ord (Set a) where
- compare s1 s2 = compare (toAscList s1) (toAscList s2)
-
-{--------------------------------------------------------------------
- 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 -> singleton x
- Bin sz y l r
- -> balance y l (insertMax x r)
- [_$_]
-insertMin x t
- = case t of
- Tip -> singleton x
- Bin sz y l r
- -> balance y (insertMin x l) r
- [_$_]
-{--------------------------------------------------------------------
- [merge l r]: merges two trees.
---------------------------------------------------------------------}
-merge :: Set a -> Set a -> Set a
-merge Tip r = r
-merge l Tip = l
-merge l@(Bin sizeL x lx rx) r@(Bin sizeR y ly ry)
- | delta*sizeL <= sizeR = balance y (merge l ly) ry
- | delta*sizeR <= sizeL = balance x lx (merge rx r)
- | otherwise = glue l r
-
-{--------------------------------------------------------------------
- [glue l r]: glues two trees together.
- Assumes that [l] and [r] are already balanced with respect to each other.
---------------------------------------------------------------------}
-glue :: Set a -> Set a -> Set a
-glue Tip r = r
-glue l Tip = l
-glue l r [_$_]
- | size l > size r = let (m,l') = deleteFindMax l in balance m l' r
- | otherwise = let (m,r') = deleteFindMin r in balance m l r'
-
-
--- | /O(log n)/. Delete and find the minimal element.
-deleteFindMin :: Set 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 == singleton x)
-
-prop_InsertValid :: Int -> Property
-prop_InsertValid k
- = forValidUnitTree $ \t -> valid (insert k t)
-
-prop_InsertDelete :: Int -> Set Int -> Property
-prop_InsertDelete k t
- = not (member k t) ==> delete k (insert k t) == t
-
-prop_DeleteValid :: Int -> Property
-prop_DeleteValid k
- = forValidUnitTree $ \t -> [_$_]
- valid (delete k (insert k t))
-
-{--------------------------------------------------------------------
- Balance
---------------------------------------------------------------------}
-prop_Join :: Int -> Property [_$_]
-prop_Join x
- = forValidUnitTree $ \t ->
- let (l,r) = split x t
- in valid (join x l r)
-
-prop_Merge :: Int -> Property [_$_]
-prop_Merge x
- = forValidUnitTree $ \t ->
- let (l,r) = split x t
- in valid (merge l r)
-
-
-{--------------------------------------------------------------------
- Union
---------------------------------------------------------------------}
-prop_UnionValid :: Property
-prop_UnionValid
- = forValidUnitTree $ \t1 ->
- forValidUnitTree $ \t2 ->
- valid (union t1 t2)
-
-prop_UnionInsert :: Int -> Set Int -> Bool
-prop_UnionInsert x t
- = union t (singleton x) == insert x t
-
-prop_UnionAssoc :: Set Int -> Set Int -> Set Int -> Bool
-prop_UnionAssoc t1 t2 t3
- = union t1 (union t2 t3) == union (union t1 t2) t3
-
-prop_UnionComm :: Set Int -> Set Int -> Bool
-prop_UnionComm t1 t2
- = (union t1 t2 == union t2 t1)
-
-
-prop_DiffValid
- = forValidUnitTree $ \t1 ->
- forValidUnitTree $ \t2 ->
- valid (difference t1 t2)
-
-prop_Diff :: [Int] -> [Int] -> Bool
-prop_Diff xs ys
- = toAscList (difference (fromList xs) (fromList ys))
- == List.sort ((List.\\) (nub xs) (nub ys))
-
-prop_IntValid
- = forValidUnitTree $ \t1 ->
- forValidUnitTree $ \t2 ->
- valid (intersection t1 t2)
-
-prop_Int :: [Int] -> [Int] -> Bool
-prop_Int xs ys
- = toAscList (intersection (fromList xs) (fromList ys))
- == List.sort (nub ((List.intersect) (xs) (ys)))
-
-{--------------------------------------------------------------------
- Lists
---------------------------------------------------------------------}
-prop_Ordered
- = forAll (choose (5,100)) $ \n ->
- let xs = [0..n::Int]
- in fromAscList xs == fromList xs
-
-prop_List :: [Int] -> Bool
-prop_List xs
- = (sort (nub xs) == toList (fromList xs))
--}
rmfile ./lib/DData/Set.hs
}