containers (empty) → 0.1.0.0
raw patch · 10 files changed
+7402/−0 lines, 10 filesdep +arraydep +basesetup-changed
Dependencies added: array, base
Files
- Data/Graph.hs +432/−0
- Data/IntMap.hs +1549/−0
- Data/IntSet.hs +1020/−0
- Data/Map.hs +1846/−0
- Data/Sequence.hs +1124/−0
- Data/Set.hs +1149/−0
- Data/Tree.hs +167/−0
- LICENSE +83/−0
- Setup.hs +6/−0
- containers.cabal +26/−0
+ Data/Graph.hs view
@@ -0,0 +1,432 @@+-----------------------------------------------------------------------------+-- |+-- Module : Data.Graph+-- Copyright : (c) The University of Glasgow 2002+-- License : BSD-style (see the file libraries/base/LICENSE)+-- +-- Maintainer : libraries@haskell.org+-- Stability : experimental+-- Portability : portable+--+-- A version of the graph algorithms described in:+--+-- /Lazy Depth-First Search and Linear Graph Algorithms in Haskell/,+-- by David King and John Launchbury.+--+-----------------------------------------------------------------------------++module Data.Graph(++ -- * External interface++ -- At present the only one with a "nice" external interface+ stronglyConnComp, stronglyConnCompR, SCC(..), flattenSCC, flattenSCCs,++ -- * Graphs++ Graph, Table, Bounds, Edge, Vertex,++ -- ** Building graphs++ graphFromEdges, graphFromEdges', buildG, transposeG,+ -- reverseE,++ -- ** Graph properties++ vertices, edges,+ outdegree, indegree,++ -- * Algorithms++ dfs, dff,+ topSort,+ components,+ scc,+ bcc,+ -- tree, back, cross, forward,+ reachable, path,++ module Data.Tree++ ) where++#if __GLASGOW_HASKELL__+# define USE_ST_MONAD 1+#endif++-- Extensions+#if USE_ST_MONAD+import Control.Monad.ST+import Data.Array.ST (STArray, newArray, readArray, writeArray)+#else+import Data.IntSet (IntSet)+import qualified Data.IntSet as Set+#endif+import Data.Tree (Tree(Node), Forest)++-- std interfaces+import Data.Maybe+import Data.Array+import Data.List++#ifdef __HADDOCK__+import Prelude+#endif++-------------------------------------------------------------------------+-- -+-- External interface+-- -+-------------------------------------------------------------------------++-- | Strongly connected component.+data SCC vertex = AcyclicSCC vertex -- ^ A single vertex that is not+ -- in any cycle.+ | CyclicSCC [vertex] -- ^ A maximal set of mutually+ -- reachable vertices.++-- | The vertices of a list of strongly connected components.+flattenSCCs :: [SCC a] -> [a]+flattenSCCs = concatMap flattenSCC++-- | The vertices of a strongly connected component.+flattenSCC :: SCC vertex -> [vertex]+flattenSCC (AcyclicSCC v) = [v]+flattenSCC (CyclicSCC vs) = vs++-- | The strongly connected components of a directed graph, topologically+-- sorted.+stronglyConnComp+ :: Ord key+ => [(node, key, [key])]+ -- ^ The graph: a list of nodes uniquely identified by keys,+ -- with a list of keys of nodes this node has edges to.+ -- The out-list may contain keys that don't correspond to+ -- nodes of the graph; such edges are ignored.+ -> [SCC node]++stronglyConnComp edges0+ = map get_node (stronglyConnCompR edges0)+ where+ get_node (AcyclicSCC (n, _, _)) = AcyclicSCC n+ get_node (CyclicSCC triples) = CyclicSCC [n | (n,_,_) <- triples]++-- | The strongly connected components of a directed graph, topologically+-- sorted. The function is the same as 'stronglyConnComp', except that+-- all the information about each node retained.+-- This interface is used when you expect to apply 'SCC' to+-- (some of) the result of 'SCC', so you don't want to lose the+-- dependency information.+stronglyConnCompR+ :: Ord key+ => [(node, key, [key])]+ -- ^ The graph: a list of nodes uniquely identified by keys,+ -- with a list of keys of nodes this node has edges to.+ -- The out-list may contain keys that don't correspond to+ -- nodes of the graph; such edges are ignored.+ -> [SCC (node, key, [key])] -- ^ Topologically sorted++stronglyConnCompR [] = [] -- added to avoid creating empty array in graphFromEdges -- SOF+stronglyConnCompR edges0+ = map decode forest+ where+ (graph, vertex_fn,_) = graphFromEdges edges0+ forest = scc graph+ decode (Node v []) | mentions_itself v = CyclicSCC [vertex_fn v]+ | otherwise = AcyclicSCC (vertex_fn v)+ decode other = CyclicSCC (dec other [])+ where+ dec (Node v ts) vs = vertex_fn v : foldr dec vs ts+ mentions_itself v = v `elem` (graph ! v)++-------------------------------------------------------------------------+-- -+-- Graphs+-- -+-------------------------------------------------------------------------++-- | Abstract representation of vertices.+type Vertex = Int+-- | Table indexed by a contiguous set of vertices.+type Table a = Array Vertex a+-- | Adjacency list representation of a graph, mapping each vertex to its+-- list of successors.+type Graph = Table [Vertex]+-- | The bounds of a 'Table'.+type Bounds = (Vertex, Vertex)+-- | An edge from the first vertex to the second.+type Edge = (Vertex, Vertex)++-- | All vertices of a graph.+vertices :: Graph -> [Vertex]+vertices = indices++-- | All edges of a graph.+edges :: Graph -> [Edge]+edges g = [ (v, w) | v <- vertices g, w <- g!v ]++mapT :: (Vertex -> a -> b) -> Table a -> Table b+mapT f t = array (bounds t) [ (,) v (f v (t!v)) | v <- indices t ]++-- | Build a graph from a list of edges.+buildG :: Bounds -> [Edge] -> Graph+buildG bounds0 edges0 = accumArray (flip (:)) [] bounds0 edges0++-- | The graph obtained by reversing all edges.+transposeG :: Graph -> Graph+transposeG g = buildG (bounds g) (reverseE g)++reverseE :: Graph -> [Edge]+reverseE g = [ (w, v) | (v, w) <- edges g ]++-- | A table of the count of edges from each node.+outdegree :: Graph -> Table Int+outdegree = mapT numEdges+ where numEdges _ ws = length ws++-- | A table of the count of edges into each node.+indegree :: Graph -> Table Int+indegree = outdegree . transposeG++-- | Identical to 'graphFromEdges', except that the return value+-- does not include the function which maps keys to vertices. This+-- version of 'graphFromEdges' is for backwards compatibility.+graphFromEdges'+ :: Ord key+ => [(node, key, [key])]+ -> (Graph, Vertex -> (node, key, [key]))+graphFromEdges' x = (a,b) where+ (a,b,_) = graphFromEdges x++-- | Build a graph from a list of nodes uniquely identified by keys,+-- with a list of keys of nodes this node should have edges to.+-- The out-list may contain keys that don't correspond to+-- nodes of the graph; they are ignored.+graphFromEdges+ :: Ord key+ => [(node, key, [key])]+ -> (Graph, Vertex -> (node, key, [key]), key -> Maybe Vertex)+graphFromEdges edges0+ = (graph, \v -> vertex_map ! v, key_vertex)+ where+ max_v = length edges0 - 1+ bounds0 = (0,max_v) :: (Vertex, Vertex)+ sorted_edges = sortBy lt edges0+ edges1 = zipWith (,) [0..] sorted_edges++ graph = array bounds0 [(,) v (mapMaybe key_vertex ks) | (,) v (_, _, ks) <- edges1]+ key_map = array bounds0 [(,) v k | (,) v (_, k, _ ) <- edges1]+ vertex_map = array bounds0 edges1++ (_,k1,_) `lt` (_,k2,_) = k1 `compare` k2++ -- key_vertex :: key -> Maybe Vertex+ -- returns Nothing for non-interesting vertices+ key_vertex k = findVertex 0 max_v+ where+ findVertex a b | a > b+ = Nothing+ findVertex a b = case compare k (key_map ! mid) of+ LT -> findVertex a (mid-1)+ EQ -> Just mid+ GT -> findVertex (mid+1) b+ where+ mid = (a + b) `div` 2++-------------------------------------------------------------------------+-- -+-- Depth first search+-- -+-------------------------------------------------------------------------++-- | A spanning forest of the graph, obtained from a depth-first search of+-- the graph starting from each vertex in an unspecified order.+dff :: Graph -> Forest Vertex+dff g = dfs g (vertices g)++-- | A spanning forest of the part of the graph reachable from the listed+-- vertices, obtained from a depth-first search of the graph starting at+-- each of the listed vertices in order.+dfs :: Graph -> [Vertex] -> Forest Vertex+dfs g vs = prune (bounds g) (map (generate g) vs)++generate :: Graph -> Vertex -> Tree Vertex+generate g v = Node v (map (generate g) (g!v))++prune :: Bounds -> Forest Vertex -> Forest Vertex+prune bnds ts = run bnds (chop ts)++chop :: Forest Vertex -> SetM s (Forest Vertex)+chop [] = return []+chop (Node v ts : us)+ = do+ visited <- contains v+ if visited then+ chop us+ else do+ include v+ as <- chop ts+ bs <- chop us+ return (Node v as : bs)++-- A monad holding a set of vertices visited so far.+#if USE_ST_MONAD++-- Use the ST monad if available, for constant-time primitives.++newtype SetM s a = SetM { runSetM :: STArray s Vertex Bool -> ST s a }++instance Monad (SetM s) where+ return x = SetM $ const (return x)+ SetM v >>= f = SetM $ \ s -> do { x <- v s; runSetM (f x) s }++run :: Bounds -> (forall s. SetM s a) -> a+run bnds act = runST (newArray bnds False >>= runSetM act)++contains :: Vertex -> SetM s Bool+contains v = SetM $ \ m -> readArray m v++include :: Vertex -> SetM s ()+include v = SetM $ \ m -> writeArray m v True++#else /* !USE_ST_MONAD */++-- Portable implementation using IntSet.++newtype SetM s a = SetM { runSetM :: IntSet -> (a, IntSet) }++instance Monad (SetM s) where+ return x = SetM $ \ s -> (x, s)+ SetM v >>= f = SetM $ \ s -> case v s of (x, s') -> runSetM (f x) s'++run :: Bounds -> SetM s a -> a+run _ act = fst (runSetM act Set.empty)++contains :: Vertex -> SetM s Bool+contains v = SetM $ \ m -> (Set.member v m, m)++include :: Vertex -> SetM s ()+include v = SetM $ \ m -> ((), Set.insert v m)++#endif /* !USE_ST_MONAD */++-------------------------------------------------------------------------+-- -+-- Algorithms+-- -+-------------------------------------------------------------------------++------------------------------------------------------------+-- Algorithm 1: depth first search numbering+------------------------------------------------------------++preorder :: Tree a -> [a]+preorder (Node a ts) = a : preorderF ts++preorderF :: Forest a -> [a]+preorderF ts = concat (map preorder ts)++tabulate :: Bounds -> [Vertex] -> Table Int+tabulate bnds vs = array bnds (zipWith (,) vs [1..])++preArr :: Bounds -> Forest Vertex -> Table Int+preArr bnds = tabulate bnds . preorderF++------------------------------------------------------------+-- Algorithm 2: topological sorting+------------------------------------------------------------++postorder :: Tree a -> [a]+postorder (Node a ts) = postorderF ts ++ [a]++postorderF :: Forest a -> [a]+postorderF ts = concat (map postorder ts)++postOrd :: Graph -> [Vertex]+postOrd = postorderF . dff++-- | A topological sort of the graph.+-- The order is partially specified by the condition that a vertex /i/+-- precedes /j/ whenever /j/ is reachable from /i/ but not vice versa.+topSort :: Graph -> [Vertex]+topSort = reverse . postOrd++------------------------------------------------------------+-- Algorithm 3: connected components+------------------------------------------------------------++-- | The connected components of a graph.+-- Two vertices are connected if there is a path between them, traversing+-- edges in either direction.+components :: Graph -> Forest Vertex+components = dff . undirected++undirected :: Graph -> Graph+undirected g = buildG (bounds g) (edges g ++ reverseE g)++-- Algorithm 4: strongly connected components++-- | The strongly connected components of a graph.+scc :: Graph -> Forest Vertex+scc g = dfs g (reverse (postOrd (transposeG g)))++------------------------------------------------------------+-- Algorithm 5: Classifying edges+------------------------------------------------------------++tree :: Bounds -> Forest Vertex -> Graph+tree bnds ts = buildG bnds (concat (map flat ts))+ where flat (Node v ts) = [ (v, w) | Node w _us <- ts ] ++ concat (map flat ts)++back :: Graph -> Table Int -> Graph+back g post = mapT select g+ where select v ws = [ w | w <- ws, post!v < post!w ]++cross :: Graph -> Table Int -> Table Int -> Graph+cross g pre post = mapT select g+ where select v ws = [ w | w <- ws, post!v > post!w, pre!v > pre!w ]++forward :: Graph -> Graph -> Table Int -> Graph+forward g tree pre = mapT select g+ where select v ws = [ w | w <- ws, pre!v < pre!w ] \\ tree!v++------------------------------------------------------------+-- Algorithm 6: Finding reachable vertices+------------------------------------------------------------++-- | A list of vertices reachable from a given vertex.+reachable :: Graph -> Vertex -> [Vertex]+reachable g v = preorderF (dfs g [v])++-- | Is the second vertex reachable from the first?+path :: Graph -> Vertex -> Vertex -> Bool+path g v w = w `elem` (reachable g v)++------------------------------------------------------------+-- Algorithm 7: Biconnected components+------------------------------------------------------------++-- | The biconnected components of a graph.+-- An undirected graph is biconnected if the deletion of any vertex+-- leaves it connected.+bcc :: Graph -> Forest [Vertex]+bcc g = (concat . map bicomps . map (do_label g dnum)) forest+ where forest = dff g+ dnum = preArr (bounds g) forest++do_label :: Graph -> Table Int -> Tree Vertex -> Tree (Vertex,Int,Int)+do_label g dnum (Node v ts) = Node (v,dnum!v,lv) us+ where us = map (do_label g dnum) ts+ lv = minimum ([dnum!v] ++ [dnum!w | w <- g!v]+ ++ [lu | Node (u,du,lu) xs <- us])++bicomps :: Tree (Vertex,Int,Int) -> Forest [Vertex]+bicomps (Node (v,_,_) ts)+ = [ Node (v:vs) us | (l,Node vs us) <- map collect ts]++collect :: Tree (Vertex,Int,Int) -> (Int, Tree [Vertex])+collect (Node (v,dv,lv) ts) = (lv, Node (v:vs) cs)+ where collected = map collect ts+ vs = concat [ ws | (lw, Node ws us) <- collected, lw<dv]+ cs = concat [ if lw<dv then us else [Node (v:ws) us]+ | (lw, Node ws us) <- collected ]
+ Data/IntMap.hs view
@@ -0,0 +1,1549 @@+{-# OPTIONS -cpp -fglasgow-exts -fno-bang-patterns #-} +-----------------------------------------------------------------------------+-- |+-- Module : Data.IntMap+-- Copyright : (c) Daan Leijen 2002+-- License : BSD-style+-- Maintainer : libraries@haskell.org+-- Stability : provisional+-- Portability : portable+--+-- An efficient implementation of maps from integer keys to values.+--+-- Since many function names (but not the type name) clash with+-- "Prelude" names, this module is usually imported @qualified@, e.g.+--+-- > import Data.IntMap (IntMap)+-- > import qualified Data.IntMap as IntMap+--+-- The implementation is based on /big-endian patricia trees/. This data+-- structure performs especially well on binary operations like 'union'+-- and 'intersection'. However, my benchmarks show that it is also+-- (much) faster on insertions and deletions when compared to a generic+-- size-balanced map implementation (see "Data.Map" and "Data.FiniteMap").+--+-- * Chris Okasaki and Andy Gill, \"/Fast Mergeable Integer Maps/\",+-- Workshop on ML, September 1998, pages 77-86,+-- <http://www.cse.ogi.edu/~andy/pub/finite.htm>+--+-- * D.R. Morrison, \"/PATRICIA -- Practical Algorithm To Retrieve+-- Information Coded In Alphanumeric/\", Journal of the ACM, 15(4),+-- October 1968, pages 514-534.+--+-- 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 Data.IntMap ( + -- * Map type+ IntMap, Key -- instance Eq,Show++ -- * Operators+ , (!), (\\)++ -- * Query+ , null+ , size+ , member+ , notMember+ , lookup+ , findWithDefault+ + -- * Construction+ , empty+ , singleton++ -- ** Insertion+ , insert+ , insertWith, insertWithKey, insertLookupWithKey+ + -- ** Delete\/Update+ , delete+ , adjust+ , adjustWithKey+ , update+ , updateWithKey+ , updateLookupWithKey+ , alter+ + -- * Combine++ -- ** Union+ , union + , unionWith + , unionWithKey+ , unions+ , unionsWith++ -- ** Difference+ , difference+ , differenceWith+ , differenceWithKey+ + -- ** Intersection+ , intersection + , intersectionWith+ , intersectionWithKey++ -- * Traversal+ -- ** Map+ , map+ , mapWithKey+ , mapAccum+ , mapAccumWithKey+ + -- ** Fold+ , fold+ , foldWithKey++ -- * Conversion+ , elems+ , keys+ , keysSet+ , assocs+ + -- ** Lists+ , toList+ , fromList+ , fromListWith+ , fromListWithKey++ -- ** Ordered lists+ , toAscList+ , fromAscList+ , fromAscListWith+ , fromAscListWithKey+ , fromDistinctAscList++ -- * Filter + , filter+ , filterWithKey+ , partition+ , partitionWithKey++ , mapMaybe+ , mapMaybeWithKey+ , mapEither+ , mapEitherWithKey++ , split + , splitLookup ++ -- * Submap+ , isSubmapOf, isSubmapOfBy+ , isProperSubmapOf, isProperSubmapOfBy+ + -- * Min\/Max++ , maxView+ , minView+ , findMin + , findMax+ , deleteMin+ , deleteMax+ , deleteFindMin+ , deleteFindMax+ , updateMin+ , updateMax+ , updateMinWithKey+ , updateMaxWithKey + , minViewWithKey+ , maxViewWithKey++ -- * Debugging+ , showTree+ , showTreeWith+ ) where+++import Prelude hiding (lookup,map,filter,foldr,foldl,null)+import Data.Bits +import qualified Data.IntSet as IntSet+import Data.Monoid (Monoid(..))+import Data.Typeable+import Data.Foldable (Foldable(foldMap))+import Control.Monad ( liftM )+import Control.Arrow (ArrowZero)+{-+-- just for testing+import qualified Prelude+import Debug.QuickCheck +import List (nub,sort)+import qualified List+-} ++#if __GLASGOW_HASKELL__+import Text.Read+import Data.Generics.Basics (Data(..), mkNorepType)+import Data.Generics.Instances ()+#endif++#if __GLASGOW_HASKELL__ >= 503+import GHC.Exts ( Word(..), Int(..), shiftRL# )+#elif __GLASGOW_HASKELL__+import Word+import GlaExts ( Word(..), Int(..), shiftRL# )+#else+import Data.Word+#endif++infixl 9 \\{-This comment teaches CPP correct behaviour -}++-- A "Nat" is a natural machine word (an unsigned Int)+type Nat = Word++natFromInt :: Key -> Nat+natFromInt i = fromIntegral i++intFromNat :: Nat -> Key+intFromNat w = fromIntegral w++shiftRL :: Nat -> Key -> Nat+#if __GLASGOW_HASKELL__+{--------------------------------------------------------------------+ GHC: use unboxing to get @shiftRL@ inlined.+--------------------------------------------------------------------}+shiftRL (W# x) (I# i)+ = W# (shiftRL# x i)+#else+shiftRL x i = shiftR x i+#endif++{--------------------------------------------------------------------+ Operators+--------------------------------------------------------------------}++-- | /O(min(n,W))/. Find the value at a key.+-- Calls 'error' when the element can not be found.++(!) :: IntMap a -> Key -> a+m ! k = find' k m++-- | /O(n+m)/. See 'difference'.+(\\) :: IntMap a -> IntMap b -> IntMap a+m1 \\ m2 = difference m1 m2++{--------------------------------------------------------------------+ Types +--------------------------------------------------------------------}+-- | A map of integers to values @a@.+data IntMap a = Nil+ | Tip {-# UNPACK #-} !Key a+ | Bin {-# UNPACK #-} !Prefix {-# UNPACK #-} !Mask !(IntMap a) !(IntMap a) ++type Prefix = Int+type Mask = Int+type Key = Int++instance Monoid (IntMap a) where+ mempty = empty+ mappend = union+ mconcat = unions++instance Foldable IntMap where+ foldMap f Nil = mempty+ foldMap f (Tip _k v) = f v+ foldMap f (Bin _ _ l r) = foldMap f l `mappend` foldMap f r++#if __GLASGOW_HASKELL__++{--------------------------------------------------------------------+ A Data instance +--------------------------------------------------------------------}++-- This instance preserves data abstraction at the cost of inefficiency.+-- We omit reflection services for the sake of data abstraction.++instance Data a => Data (IntMap a) where+ gfoldl f z im = z fromList `f` (toList im)+ toConstr _ = error "toConstr"+ gunfold _ _ = error "gunfold"+ dataTypeOf _ = mkNorepType "Data.IntMap.IntMap"+ dataCast1 f = gcast1 f++#endif++{--------------------------------------------------------------------+ Query+--------------------------------------------------------------------}+-- | /O(1)/. Is the map empty?+null :: IntMap a -> Bool+null Nil = True+null other = False++-- | /O(n)/. Number of elements in the map.+size :: IntMap a -> Int+size t+ = case t of+ Bin p m l r -> size l + size r+ Tip k x -> 1+ Nil -> 0++-- | /O(min(n,W))/. Is the key a member of the map?+member :: Key -> IntMap a -> Bool+member k m+ = case lookup k m of+ Nothing -> False+ Just x -> True+ +-- | /O(log n)/. Is the key not a member of the map?+notMember :: Key -> IntMap a -> Bool+notMember k m = not $ member k m++-- | /O(min(n,W))/. Lookup the value at a key in the map.+lookup :: (Monad m) => Key -> IntMap a -> m a+lookup k t = case lookup' k t of+ Just x -> return x+ Nothing -> fail "Data.IntMap.lookup: Key not found"++lookup' :: Key -> IntMap a -> Maybe a+lookup' k t+ = let nk = natFromInt k in seq nk (lookupN nk t)++lookupN :: Nat -> IntMap a -> Maybe a+lookupN k t+ = case t of+ Bin p m l r + | zeroN k (natFromInt m) -> lookupN k l+ | otherwise -> lookupN k r+ Tip kx x + | (k == natFromInt kx) -> Just x+ | otherwise -> Nothing+ Nil -> Nothing++find' :: Key -> IntMap a -> a+find' k m+ = case lookup k m of+ Nothing -> error ("IntMap.find: key " ++ show k ++ " is not an element of the map")+ Just x -> x+++-- | /O(min(n,W))/. The expression @('findWithDefault' def k map)@+-- returns the value at key @k@ or returns @def@ when the key is not an+-- element of the map.+findWithDefault :: a -> Key -> IntMap a -> a+findWithDefault def k m+ = case lookup k m of+ Nothing -> def+ Just x -> x++{--------------------------------------------------------------------+ Construction+--------------------------------------------------------------------}+-- | /O(1)/. The empty map.+empty :: IntMap a+empty+ = Nil++-- | /O(1)/. A map of one element.+singleton :: Key -> a -> IntMap a+singleton k x+ = Tip k x++{--------------------------------------------------------------------+ Insert+--------------------------------------------------------------------}+-- | /O(min(n,W))/. Insert a new key\/value pair in the map.+-- If the key is already present in the map, the associated value is+-- replaced with the supplied value, i.e. 'insert' is equivalent to+-- @'insertWith' 'const'@.+insert :: Key -> a -> IntMap a -> IntMap a+insert k x t+ = case t of+ Bin p m l r + | nomatch k p m -> join k (Tip k x) p t+ | zero k m -> Bin p m (insert k x l) r+ | otherwise -> Bin p m l (insert k x r)+ Tip ky y + | k==ky -> Tip k x+ | otherwise -> join k (Tip k x) ky t+ Nil -> Tip k x++-- right-biased insertion, used by 'union'+-- | /O(min(n,W))/. Insert with a combining function.+-- @'insertWith' f key value mp@ +-- will insert the pair (key, value) into @mp@ if key does+-- not exist in the map. If the key does exist, the function will+-- insert @f new_value old_value@.+insertWith :: (a -> a -> a) -> Key -> a -> IntMap a -> IntMap a+insertWith f k x t+ = insertWithKey (\k x y -> f x y) k x t++-- | /O(min(n,W))/. Insert with a combining function.+-- @'insertWithKey' f key value mp@ +-- will insert the pair (key, value) into @mp@ if key does+-- not exist in the map. If the key does exist, the function will+-- insert @f key new_value old_value@.+insertWithKey :: (Key -> a -> a -> a) -> Key -> a -> IntMap a -> IntMap a+insertWithKey f k x t+ = case t of+ Bin p m l r + | nomatch k p m -> join k (Tip k x) p t+ | zero k m -> Bin p m (insertWithKey f k x l) r+ | otherwise -> Bin p m l (insertWithKey f k x r)+ Tip ky y + | k==ky -> Tip k (f k x y)+ | otherwise -> join k (Tip k x) ky t+ Nil -> Tip k x+++-- | /O(min(n,W))/. The expression (@'insertLookupWithKey' f k x map@)+-- is a pair where the first element is equal to (@'lookup' k map@)+-- and the second element equal to (@'insertWithKey' f k x map@).+insertLookupWithKey :: (Key -> a -> a -> a) -> Key -> a -> IntMap a -> (Maybe a, IntMap a)+insertLookupWithKey f k x t+ = case t of+ Bin p m l r + | nomatch k p m -> (Nothing,join k (Tip k x) p t)+ | zero k m -> let (found,l') = insertLookupWithKey f k x l in (found,Bin p m l' r)+ | otherwise -> let (found,r') = insertLookupWithKey f k x r in (found,Bin p m l r')+ Tip ky y + | k==ky -> (Just y,Tip k (f k x y))+ | otherwise -> (Nothing,join k (Tip k x) ky t)+ Nil -> (Nothing,Tip k x)+++{--------------------------------------------------------------------+ Deletion+ [delete] is the inlined version of [deleteWith (\k x -> Nothing)]+--------------------------------------------------------------------}+-- | /O(min(n,W))/. Delete a key and its value from the map. When the key is not+-- a member of the map, the original map is returned.+delete :: Key -> IntMap a -> IntMap a+delete k t+ = case t of+ Bin p m l r + | nomatch k p m -> t+ | zero k m -> bin p m (delete k l) r+ | otherwise -> bin p m l (delete k r)+ Tip ky y + | k==ky -> Nil+ | otherwise -> t+ Nil -> Nil++-- | /O(min(n,W))/. Adjust a value at a specific key. When the key is not+-- a member of the map, the original map is returned.+adjust :: (a -> a) -> Key -> IntMap a -> IntMap a+adjust f k m+ = adjustWithKey (\k x -> f x) k m++-- | /O(min(n,W))/. Adjust a value at a specific key. When the key is not+-- a member of the map, the original map is returned.+adjustWithKey :: (Key -> a -> a) -> Key -> IntMap a -> IntMap a+adjustWithKey f k m+ = updateWithKey (\k x -> Just (f k x)) k m++-- | /O(min(n,W))/. The expression (@'update' f k map@) updates the value @x@+-- at @k@ (if it is in the map). If (@f x@) is 'Nothing', the element is+-- deleted. If it is (@'Just' y@), the key @k@ is bound to the new value @y@.+update :: (a -> Maybe a) -> Key -> IntMap a -> IntMap a+update f k m+ = updateWithKey (\k x -> f x) k m++-- | /O(min(n,W))/. The expression (@'update' f k map@) updates the value @x@+-- at @k@ (if it is in the map). If (@f k x@) is 'Nothing', the element is+-- deleted. If it is (@'Just' y@), the key @k@ is bound to the new value @y@.+updateWithKey :: (Key -> a -> Maybe a) -> Key -> IntMap a -> IntMap a+updateWithKey f k t+ = case t of+ Bin p m l r + | nomatch k p m -> t+ | zero k m -> bin p m (updateWithKey f k l) r+ | otherwise -> bin p m l (updateWithKey f k r)+ Tip ky y + | k==ky -> case (f k y) of+ Just y' -> Tip ky y'+ Nothing -> Nil+ | otherwise -> t+ Nil -> Nil++-- | /O(min(n,W))/. Lookup and update.+updateLookupWithKey :: (Key -> a -> Maybe a) -> Key -> IntMap a -> (Maybe a,IntMap a)+updateLookupWithKey f k t+ = case t of+ Bin p m l r + | nomatch k p m -> (Nothing,t)+ | zero k m -> let (found,l') = updateLookupWithKey f k l in (found,bin p m l' r)+ | otherwise -> let (found,r') = updateLookupWithKey f k r in (found,bin p m l r')+ Tip ky y + | k==ky -> case (f k y) of+ Just y' -> (Just y,Tip ky y')+ Nothing -> (Just y,Nil)+ | otherwise -> (Nothing,t)+ Nil -> (Nothing,Nil)++++-- | /O(log n)/. The expression (@'alter' f k map@) alters the value @x@ at @k@, or absence thereof.+-- 'alter' can be used to insert, delete, or update a value in a 'Map'.+-- In short : @'lookup' k ('alter' f k m) = f ('lookup' k m)@+alter f k t+ = case t of+ Bin p m l r + | nomatch k p m -> case f Nothing of + Nothing -> t+ Just x -> join k (Tip k x) p t+ | zero k m -> bin p m (alter f k l) r+ | otherwise -> bin p m l (alter f k r)+ Tip ky y + | k==ky -> case f (Just y) of+ Just x -> Tip ky x+ Nothing -> Nil+ | otherwise -> case f Nothing of+ Just x -> join k (Tip k x) ky t+ Nothing -> Tip ky y+ Nil -> case f Nothing of+ Just x -> Tip k x+ Nothing -> Nil+++{--------------------------------------------------------------------+ Union+--------------------------------------------------------------------}+-- | The union of a list of maps.+unions :: [IntMap a] -> IntMap a+unions xs+ = foldlStrict union empty xs++-- | The union of a list of maps, with a combining operation+unionsWith :: (a->a->a) -> [IntMap a] -> IntMap a+unionsWith f ts+ = foldlStrict (unionWith f) empty ts++-- | /O(n+m)/. The (left-biased) union of two maps. +-- It prefers the first map when duplicate keys are encountered,+-- i.e. (@'union' == 'unionWith' 'const'@).+union :: IntMap a -> IntMap a -> IntMap a+union t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)+ | shorter m1 m2 = union1+ | shorter m2 m1 = union2+ | p1 == p2 = Bin p1 m1 (union l1 l2) (union r1 r2)+ | otherwise = join p1 t1 p2 t2+ where+ union1 | nomatch p2 p1 m1 = join p1 t1 p2 t2+ | zero p2 m1 = Bin p1 m1 (union l1 t2) r1+ | otherwise = Bin p1 m1 l1 (union r1 t2)++ union2 | nomatch p1 p2 m2 = join p1 t1 p2 t2+ | zero p1 m2 = Bin p2 m2 (union t1 l2) r2+ | otherwise = Bin p2 m2 l2 (union t1 r2)++union (Tip k x) t = insert k x t+union t (Tip k x) = insertWith (\x y -> y) k x t -- right bias+union Nil t = t+union t Nil = t++-- | /O(n+m)/. The union with a combining function. +unionWith :: (a -> a -> a) -> IntMap a -> IntMap a -> IntMap a+unionWith f m1 m2+ = unionWithKey (\k x y -> f x y) m1 m2++-- | /O(n+m)/. The union with a combining function. +unionWithKey :: (Key -> a -> a -> a) -> IntMap a -> IntMap a -> IntMap a+unionWithKey f t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)+ | shorter m1 m2 = union1+ | shorter m2 m1 = union2+ | p1 == p2 = Bin p1 m1 (unionWithKey f l1 l2) (unionWithKey f r1 r2)+ | otherwise = join p1 t1 p2 t2+ where+ union1 | nomatch p2 p1 m1 = join p1 t1 p2 t2+ | zero p2 m1 = Bin p1 m1 (unionWithKey f l1 t2) r1+ | otherwise = Bin p1 m1 l1 (unionWithKey f r1 t2)++ union2 | nomatch p1 p2 m2 = join p1 t1 p2 t2+ | zero p1 m2 = Bin p2 m2 (unionWithKey f t1 l2) r2+ | otherwise = Bin p2 m2 l2 (unionWithKey f t1 r2)++unionWithKey f (Tip k x) t = insertWithKey f k x t+unionWithKey f t (Tip k x) = insertWithKey (\k x y -> f k y x) k x t -- right bias+unionWithKey f Nil t = t+unionWithKey f t Nil = t++{--------------------------------------------------------------------+ Difference+--------------------------------------------------------------------}+-- | /O(n+m)/. Difference between two maps (based on keys). +difference :: IntMap a -> IntMap b -> IntMap a+difference t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)+ | shorter m1 m2 = difference1+ | shorter m2 m1 = difference2+ | p1 == p2 = bin p1 m1 (difference l1 l2) (difference r1 r2)+ | otherwise = t1+ where+ difference1 | nomatch p2 p1 m1 = t1+ | zero p2 m1 = bin p1 m1 (difference l1 t2) r1+ | otherwise = bin p1 m1 l1 (difference r1 t2)++ difference2 | nomatch p1 p2 m2 = t1+ | zero p1 m2 = difference t1 l2+ | otherwise = difference t1 r2++difference t1@(Tip k x) t2 + | member k t2 = Nil+ | otherwise = t1++difference Nil t = Nil+difference t (Tip k x) = delete k t+difference t Nil = t++-- | /O(n+m)/. Difference with a combining function. +differenceWith :: (a -> b -> Maybe a) -> IntMap a -> IntMap b -> IntMap a+differenceWith f m1 m2+ = differenceWithKey (\k x y -> f x y) m1 m2++-- | /O(n+m)/. Difference with a combining function. When two equal keys are+-- encountered, the combining function is applied to the key and both values.+-- If it returns 'Nothing', the element is discarded (proper set difference).+-- If it returns (@'Just' y@), the element is updated with a new value @y@. +differenceWithKey :: (Key -> a -> b -> Maybe a) -> IntMap a -> IntMap b -> IntMap a+differenceWithKey f t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)+ | shorter m1 m2 = difference1+ | shorter m2 m1 = difference2+ | p1 == p2 = bin p1 m1 (differenceWithKey f l1 l2) (differenceWithKey f r1 r2)+ | otherwise = t1+ where+ difference1 | nomatch p2 p1 m1 = t1+ | zero p2 m1 = bin p1 m1 (differenceWithKey f l1 t2) r1+ | otherwise = bin p1 m1 l1 (differenceWithKey f r1 t2)++ difference2 | nomatch p1 p2 m2 = t1+ | zero p1 m2 = differenceWithKey f t1 l2+ | otherwise = differenceWithKey f t1 r2++differenceWithKey f t1@(Tip k x) t2 + = case lookup k t2 of+ Just y -> case f k x y of+ Just y' -> Tip k y'+ Nothing -> Nil+ Nothing -> t1++differenceWithKey f Nil t = Nil+differenceWithKey f t (Tip k y) = updateWithKey (\k x -> f k x y) k t+differenceWithKey f t Nil = t+++{--------------------------------------------------------------------+ Intersection+--------------------------------------------------------------------}+-- | /O(n+m)/. The (left-biased) intersection of two maps (based on keys). +intersection :: IntMap a -> IntMap b -> IntMap a+intersection t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)+ | shorter m1 m2 = intersection1+ | shorter m2 m1 = intersection2+ | p1 == p2 = bin p1 m1 (intersection l1 l2) (intersection r1 r2)+ | otherwise = Nil+ where+ intersection1 | nomatch p2 p1 m1 = Nil+ | zero p2 m1 = intersection l1 t2+ | otherwise = intersection r1 t2++ intersection2 | nomatch p1 p2 m2 = Nil+ | zero p1 m2 = intersection t1 l2+ | otherwise = intersection t1 r2++intersection t1@(Tip k x) t2 + | member k t2 = t1+ | otherwise = Nil+intersection t (Tip k x) + = case lookup k t of+ Just y -> Tip k y+ Nothing -> Nil+intersection Nil t = Nil+intersection t Nil = Nil++-- | /O(n+m)/. The intersection with a combining function. +intersectionWith :: (a -> b -> a) -> IntMap a -> IntMap b -> IntMap a+intersectionWith f m1 m2+ = intersectionWithKey (\k x y -> f x y) m1 m2++-- | /O(n+m)/. The intersection with a combining function. +intersectionWithKey :: (Key -> a -> b -> a) -> IntMap a -> IntMap b -> IntMap a+intersectionWithKey f t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)+ | shorter m1 m2 = intersection1+ | shorter m2 m1 = intersection2+ | p1 == p2 = bin p1 m1 (intersectionWithKey f l1 l2) (intersectionWithKey f r1 r2)+ | otherwise = Nil+ where+ intersection1 | nomatch p2 p1 m1 = Nil+ | zero p2 m1 = intersectionWithKey f l1 t2+ | otherwise = intersectionWithKey f r1 t2++ intersection2 | nomatch p1 p2 m2 = Nil+ | zero p1 m2 = intersectionWithKey f t1 l2+ | otherwise = intersectionWithKey f t1 r2++intersectionWithKey f t1@(Tip k x) t2 + = case lookup k t2 of+ Just y -> Tip k (f k x y)+ Nothing -> Nil+intersectionWithKey f t1 (Tip k y) + = case lookup k t1 of+ Just x -> Tip k (f k x y)+ Nothing -> Nil+intersectionWithKey f Nil t = Nil+intersectionWithKey f t Nil = Nil+++{--------------------------------------------------------------------+ Min\/Max+--------------------------------------------------------------------}++-- | /O(log n)/. Update the value at the minimal key.+updateMinWithKey :: (Key -> a -> a) -> IntMap a -> IntMap a+updateMinWithKey f t+ = case t of+ Bin p m l r | m < 0 -> let t' = updateMinWithKeyUnsigned f l in Bin p m t' r+ Bin p m l r -> let t' = updateMinWithKeyUnsigned f r in Bin p m l t'+ Tip k y -> Tip k (f k y)+ Nil -> error "maxView: empty map has no maximal element"++updateMinWithKeyUnsigned f t+ = case t of+ Bin p m l r -> let t' = updateMinWithKeyUnsigned f r in Bin p m l t'+ Tip k y -> Tip k (f k y)++-- | /O(log n)/. Update the value at the maximal key.+updateMaxWithKey :: (Key -> a -> a) -> IntMap a -> IntMap a+updateMaxWithKey f t+ = case t of+ Bin p m l r | m < 0 -> let t' = updateMaxWithKeyUnsigned f r in Bin p m r t'+ Bin p m l r -> let t' = updateMaxWithKeyUnsigned f l in Bin p m t' l+ Tip k y -> Tip k (f k y)+ Nil -> error "maxView: empty map has no maximal element"++updateMaxWithKeyUnsigned f t+ = case t of+ Bin p m l r -> let t' = updateMaxWithKeyUnsigned f r in Bin p m l t'+ Tip k y -> Tip k (f k y)+++-- | /O(log n)/. Retrieves the maximal (key,value) couple of the map, and the map stripped from that element.+-- @fail@s (in the monad) when passed an empty map.+maxViewWithKey :: (Monad m) => IntMap a -> m ((Key, a), IntMap a)+maxViewWithKey t+ = case t of+ Bin p m l r | m < 0 -> let (result, t') = maxViewUnsigned l in return (result, bin p m t' r)+ Bin p m l r -> let (result, t') = maxViewUnsigned r in return (result, bin p m l t')+ Tip k y -> return ((k,y), Nil)+ Nil -> fail "maxView: empty map has no maximal element"++maxViewUnsigned t + = case t of+ Bin p m l r -> let (result,t') = maxViewUnsigned r in (result,bin p m l t')+ Tip k y -> ((k,y), Nil)++-- | /O(log n)/. Retrieves the minimal (key,value) couple of the map, and the map stripped from that element.+-- @fail@s (in the monad) when passed an empty map.+minViewWithKey :: (Monad m) => IntMap a -> m ((Key, a), IntMap a)+minViewWithKey t+ = case t of+ Bin p m l r | m < 0 -> let (result, t') = minViewUnsigned r in return (result, bin p m l t')+ Bin p m l r -> let (result, t') = minViewUnsigned l in return (result, bin p m t' r)+ Tip k y -> return ((k,y),Nil)+ Nil -> fail "minView: empty map has no minimal element"++minViewUnsigned t + = case t of+ Bin p m l r -> let (result,t') = minViewUnsigned l in (result,bin p m t' r)+ Tip k y -> ((k,y),Nil)+++-- | /O(log n)/. Update the value at the maximal key.+updateMax :: (a -> a) -> IntMap a -> IntMap a+updateMax f = updateMaxWithKey (const f)++-- | /O(log n)/. Update the value at the minimal key.+updateMin :: (a -> a) -> IntMap a -> IntMap a+updateMin f = updateMinWithKey (const f)+++-- Duplicate the Identity monad here because base < mtl.+newtype Identity a = Identity { runIdentity :: a }+instance Monad Identity where+ return a = Identity a+ m >>= k = k (runIdentity m)+-- Similar to the Arrow instance.+first f (x,y) = (f x,y)+++-- | /O(log n)/. Retrieves the maximal key of the map, and the map stripped from that element.+-- @fail@s (in the monad) when passed an empty map.+maxView t = liftM (first snd) (maxViewWithKey t)++-- | /O(log n)/. Retrieves the minimal key of the map, and the map stripped from that element.+-- @fail@s (in the monad) when passed an empty map.+minView t = liftM (first snd) (minViewWithKey t)++-- | /O(log n)/. Delete and find the maximal element.+deleteFindMax = runIdentity . maxView++-- | /O(log n)/. Delete and find the minimal element.+deleteFindMin = runIdentity . minView++-- | /O(log n)/. The minimal key of the map.+findMin = fst . runIdentity . minView++-- | /O(log n)/. The maximal key of the map.+findMax = fst . runIdentity . maxView++-- | /O(log n)/. Delete the minimal key.+deleteMin = snd . runIdentity . minView++-- | /O(log n)/. Delete the maximal key.+deleteMax = snd . runIdentity . maxView+++{--------------------------------------------------------------------+ Submap+--------------------------------------------------------------------}+-- | /O(n+m)/. Is this a proper submap? (ie. a submap but not equal). +-- Defined as (@'isProperSubmapOf' = 'isProperSubmapOfBy' (==)@).+isProperSubmapOf :: Eq a => IntMap a -> IntMap a -> Bool+isProperSubmapOf m1 m2+ = isProperSubmapOfBy (==) m1 m2++{- | /O(n+m)/. Is this a proper submap? (ie. a submap but not equal).+ The expression (@'isProperSubmapOfBy' 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':+ + > isProperSubmapOfBy (==) (fromList [(1,1)]) (fromList [(1,1),(2,2)])+ > isProperSubmapOfBy (<=) (fromList [(1,1)]) (fromList [(1,1),(2,2)])++ But the following are all 'False':+ + > isProperSubmapOfBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1),(2,2)])+ > isProperSubmapOfBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1)])+ > isProperSubmapOfBy (<) (fromList [(1,1)]) (fromList [(1,1),(2,2)])+-}+isProperSubmapOfBy :: (a -> b -> Bool) -> IntMap a -> IntMap b -> Bool+isProperSubmapOfBy pred t1 t2+ = case submapCmp pred t1 t2 of + LT -> True+ ge -> False++submapCmp pred t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)+ | shorter m1 m2 = GT+ | shorter m2 m1 = submapCmpLt+ | p1 == p2 = submapCmpEq+ | otherwise = GT -- disjoint+ where+ submapCmpLt | nomatch p1 p2 m2 = GT+ | zero p1 m2 = submapCmp pred t1 l2+ | otherwise = submapCmp pred t1 r2+ submapCmpEq = case (submapCmp pred l1 l2, submapCmp pred r1 r2) of+ (GT,_ ) -> GT+ (_ ,GT) -> GT+ (EQ,EQ) -> EQ+ other -> LT++submapCmp pred (Bin p m l r) t = GT+submapCmp pred (Tip kx x) (Tip ky y) + | (kx == ky) && pred x y = EQ+ | otherwise = GT -- disjoint+submapCmp pred (Tip k x) t + = case lookup k t of+ Just y | pred x y -> LT+ other -> GT -- disjoint+submapCmp pred Nil Nil = EQ+submapCmp pred Nil t = LT++-- | /O(n+m)/. Is this a submap?+-- Defined as (@'isSubmapOf' = 'isSubmapOfBy' (==)@).+isSubmapOf :: Eq a => IntMap a -> IntMap a -> Bool+isSubmapOf m1 m2+ = isSubmapOfBy (==) m1 m2++{- | /O(n+m)/. + The expression (@'isSubmapOfBy' f m1 m2@) returns 'True' if+ all keys in @m1@ are in @m2@, and when @f@ returns 'True' when+ applied to their respective values. For example, the following + expressions are all 'True':+ + > isSubmapOfBy (==) (fromList [(1,1)]) (fromList [(1,1),(2,2)])+ > isSubmapOfBy (<=) (fromList [(1,1)]) (fromList [(1,1),(2,2)])+ > isSubmapOfBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1),(2,2)])++ But the following are all 'False':+ + > isSubmapOfBy (==) (fromList [(1,2)]) (fromList [(1,1),(2,2)])+ > isSubmapOfBy (<) (fromList [(1,1)]) (fromList [(1,1),(2,2)])+ > isSubmapOfBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1)])+-}++isSubmapOfBy :: (a -> b -> Bool) -> IntMap a -> IntMap b -> Bool+isSubmapOfBy pred t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)+ | shorter m1 m2 = False+ | shorter m2 m1 = match p1 p2 m2 && (if zero p1 m2 then isSubmapOfBy pred t1 l2+ else isSubmapOfBy pred t1 r2) + | otherwise = (p1==p2) && isSubmapOfBy pred l1 l2 && isSubmapOfBy pred r1 r2+isSubmapOfBy pred (Bin p m l r) t = False+isSubmapOfBy pred (Tip k x) t = case lookup k t of+ Just y -> pred x y+ Nothing -> False +isSubmapOfBy pred Nil t = True++{--------------------------------------------------------------------+ Mapping+--------------------------------------------------------------------}+-- | /O(n)/. Map a function over all values in the map.+map :: (a -> b) -> IntMap a -> IntMap b+map f m+ = mapWithKey (\k x -> f x) m++-- | /O(n)/. Map a function over all values in the map.+mapWithKey :: (Key -> a -> b) -> IntMap a -> IntMap b+mapWithKey f t + = case t of+ Bin p m l r -> Bin p m (mapWithKey f l) (mapWithKey f r)+ Tip k x -> Tip k (f k x)+ Nil -> Nil++-- | /O(n)/. The function @'mapAccum'@ threads an accumulating+-- argument through the map in ascending order of keys.+mapAccum :: (a -> b -> (a,c)) -> a -> IntMap b -> (a,IntMap c)+mapAccum f a m+ = mapAccumWithKey (\a k x -> f a x) a m++-- | /O(n)/. The function @'mapAccumWithKey'@ threads an accumulating+-- argument through the map in ascending order of keys.+mapAccumWithKey :: (a -> Key -> b -> (a,c)) -> a -> IntMap b -> (a,IntMap c)+mapAccumWithKey f a t+ = mapAccumL f a t++-- | /O(n)/. The function @'mapAccumL'@ threads an accumulating+-- argument through the map in ascending order of keys.+mapAccumL :: (a -> Key -> b -> (a,c)) -> a -> IntMap b -> (a,IntMap c)+mapAccumL f a t+ = case t of+ Bin p m l r -> let (a1,l') = mapAccumL f a l+ (a2,r') = mapAccumL f a1 r+ in (a2,Bin p m l' r')+ Tip k x -> let (a',x') = f a k x in (a',Tip k x')+ Nil -> (a,Nil)+++-- | /O(n)/. The function @'mapAccumR'@ threads an accumulating+-- argument throught the map in descending order of keys.+mapAccumR :: (a -> Key -> b -> (a,c)) -> a -> IntMap b -> (a,IntMap c)+mapAccumR f a t+ = case t of+ Bin p m l r -> let (a1,r') = mapAccumR f a r+ (a2,l') = mapAccumR f a1 l+ in (a2,Bin p m l' r')+ Tip k x -> let (a',x') = f a k x in (a',Tip k x')+ Nil -> (a,Nil)++{--------------------------------------------------------------------+ Filter+--------------------------------------------------------------------}+-- | /O(n)/. Filter all values that satisfy some predicate.+filter :: (a -> Bool) -> IntMap a -> IntMap a+filter p m+ = filterWithKey (\k x -> p x) m++-- | /O(n)/. Filter all keys\/values that satisfy some predicate.+filterWithKey :: (Key -> a -> Bool) -> IntMap a -> IntMap a+filterWithKey pred t+ = case t of+ Bin p m l r + -> bin p m (filterWithKey pred l) (filterWithKey pred r)+ Tip k x + | pred k x -> t+ | otherwise -> Nil+ Nil -> Nil++-- | /O(n)/. partition the map according to some predicate. The first+-- map contains all elements that satisfy the predicate, the second all+-- elements that fail the predicate. See also 'split'.+partition :: (a -> Bool) -> IntMap a -> (IntMap a,IntMap a)+partition p m+ = partitionWithKey (\k x -> p x) m++-- | /O(n)/. partition the map according to some predicate. The first+-- map contains all elements that satisfy the predicate, the second all+-- elements that fail the predicate. See also 'split'.+partitionWithKey :: (Key -> a -> Bool) -> IntMap a -> (IntMap a,IntMap a)+partitionWithKey pred t+ = case t of+ Bin p m l r + -> let (l1,l2) = partitionWithKey pred l+ (r1,r2) = partitionWithKey pred r+ in (bin p m l1 r1, bin p m l2 r2)+ Tip k x + | pred k x -> (t,Nil)+ | otherwise -> (Nil,t)+ Nil -> (Nil,Nil)++-- | /O(n)/. Map values and collect the 'Just' results.+mapMaybe :: (a -> Maybe b) -> IntMap a -> IntMap b+mapMaybe f m+ = mapMaybeWithKey (\k x -> f x) m++-- | /O(n)/. Map keys\/values and collect the 'Just' results.+mapMaybeWithKey :: (Key -> a -> Maybe b) -> IntMap a -> IntMap b+mapMaybeWithKey f (Bin p m l r)+ = bin p m (mapMaybeWithKey f l) (mapMaybeWithKey f r)+mapMaybeWithKey f (Tip k x) = case f k x of+ Just y -> Tip k y+ Nothing -> Nil+mapMaybeWithKey f Nil = Nil++-- | /O(n)/. Map values and separate the 'Left' and 'Right' results.+mapEither :: (a -> Either b c) -> IntMap a -> (IntMap b, IntMap c)+mapEither f m+ = mapEitherWithKey (\k x -> f x) m++-- | /O(n)/. Map keys\/values and separate the 'Left' and 'Right' results.+mapEitherWithKey :: (Key -> a -> Either b c) -> IntMap a -> (IntMap b, IntMap c)+mapEitherWithKey f (Bin p m l r)+ = (bin p m l1 r1, bin p m l2 r2)+ where+ (l1,l2) = mapEitherWithKey f l+ (r1,r2) = mapEitherWithKey f r+mapEitherWithKey f (Tip k x) = case f k x of+ Left y -> (Tip k y, Nil)+ Right z -> (Nil, Tip k z)+mapEitherWithKey f Nil = (Nil, Nil)++-- | /O(log n)/. The expression (@'split' k map@) is a pair @(map1,map2)@+-- where all keys in @map1@ are lower than @k@ and all keys in+-- @map2@ larger than @k@. Any key equal to @k@ is found in neither @map1@ nor @map2@.+split :: Key -> IntMap a -> (IntMap a,IntMap a)+split k t+ = case t of+ Bin p m l r + | m < 0 -> (if k >= 0 -- handle negative numbers.+ then let (lt,gt) = split' k l in (union r lt, gt)+ else let (lt,gt) = split' k r in (lt, union gt l))+ | otherwise -> split' k t+ Tip ky y + | k>ky -> (t,Nil)+ | k<ky -> (Nil,t)+ | otherwise -> (Nil,Nil)+ Nil -> (Nil,Nil)++split' :: Key -> IntMap a -> (IntMap a,IntMap a)+split' k t+ = case t of+ Bin p m l r+ | nomatch k p m -> if k>p then (t,Nil) else (Nil,t)+ | zero k m -> let (lt,gt) = split k l in (lt,union gt r)+ | otherwise -> let (lt,gt) = split k r in (union l lt,gt)+ Tip ky y + | k>ky -> (t,Nil)+ | k<ky -> (Nil,t)+ | otherwise -> (Nil,Nil)+ Nil -> (Nil,Nil)++-- | /O(log n)/. Performs a 'split' but also returns whether the pivot+-- key was found in the original map.+splitLookup :: Key -> IntMap a -> (IntMap a,Maybe a,IntMap a)+splitLookup k t+ = case t of+ Bin p m l r+ | m < 0 -> (if k >= 0 -- handle negative numbers.+ then let (lt,found,gt) = splitLookup' k l in (union r lt,found, gt)+ else let (lt,found,gt) = splitLookup' k r in (lt,found, union gt l))+ | otherwise -> splitLookup' k t+ Tip ky y + | k>ky -> (t,Nothing,Nil)+ | k<ky -> (Nil,Nothing,t)+ | otherwise -> (Nil,Just y,Nil)+ Nil -> (Nil,Nothing,Nil)++splitLookup' :: Key -> IntMap a -> (IntMap a,Maybe a,IntMap a)+splitLookup' k t+ = case t of+ Bin p m l r+ | nomatch k p m -> if k>p then (t,Nothing,Nil) else (Nil,Nothing,t)+ | zero k m -> let (lt,found,gt) = splitLookup k l in (lt,found,union gt r)+ | otherwise -> let (lt,found,gt) = splitLookup k r in (union l lt,found,gt)+ Tip ky y + | k>ky -> (t,Nothing,Nil)+ | k<ky -> (Nil,Nothing,t)+ | otherwise -> (Nil,Just y,Nil)+ Nil -> (Nil,Nothing,Nil)++{--------------------------------------------------------------------+ Fold+--------------------------------------------------------------------}+-- | /O(n)/. Fold the values in the map, such that+-- @'fold' f z == 'Prelude.foldr' f z . 'elems'@.+-- For example,+--+-- > elems map = fold (:) [] map+--+fold :: (a -> b -> b) -> b -> IntMap a -> b+fold f z t+ = foldWithKey (\k x y -> f x y) z t++-- | /O(n)/. Fold the keys and values in the map, such that+-- @'foldWithKey' f z == 'Prelude.foldr' ('uncurry' f) z . 'toAscList'@.+-- For example,+--+-- > keys map = foldWithKey (\k x ks -> k:ks) [] map+--+foldWithKey :: (Key -> a -> b -> b) -> b -> IntMap a -> b+foldWithKey f z t+ = foldr f z t++foldr :: (Key -> a -> b -> b) -> b -> IntMap a -> b+foldr f z t+ = case t of+ Bin 0 m l r | m < 0 -> foldr' f (foldr' f z l) r -- put negative numbers before.+ Bin _ _ _ _ -> foldr' f z t+ Tip k x -> f k x z+ Nil -> z++foldr' :: (Key -> a -> b -> b) -> b -> IntMap a -> b+foldr' f z t+ = case t of+ Bin p m l r -> foldr' f (foldr' f z r) l+ Tip k x -> f k x z+ Nil -> z++++{--------------------------------------------------------------------+ List variations +--------------------------------------------------------------------}+-- | /O(n)/.+-- Return all elements of the map in the ascending order of their keys.+elems :: IntMap a -> [a]+elems m+ = foldWithKey (\k x xs -> x:xs) [] m ++-- | /O(n)/. Return all keys of the map in ascending order.+keys :: IntMap a -> [Key]+keys m+ = foldWithKey (\k x ks -> k:ks) [] m++-- | /O(n*min(n,W))/. The set of all keys of the map.+keysSet :: IntMap a -> IntSet.IntSet+keysSet m = IntSet.fromDistinctAscList (keys m)+++-- | /O(n)/. Return all key\/value pairs in the map in ascending key order.+assocs :: IntMap a -> [(Key,a)]+assocs m+ = toList m+++{--------------------------------------------------------------------+ Lists +--------------------------------------------------------------------}+-- | /O(n)/. Convert the map to a list of key\/value pairs.+toList :: IntMap a -> [(Key,a)]+toList t+ = foldWithKey (\k x xs -> (k,x):xs) [] t++-- | /O(n)/. Convert the map to a list of key\/value pairs where the+-- keys are in ascending order.+toAscList :: IntMap a -> [(Key,a)]+toAscList t + = -- NOTE: the following algorithm only works for big-endian trees+ let (pos,neg) = span (\(k,x) -> k >=0) (foldr (\k x xs -> (k,x):xs) [] t) in neg ++ pos++-- | /O(n*min(n,W))/. Create a map from a list of key\/value pairs.+fromList :: [(Key,a)] -> IntMap a+fromList xs+ = foldlStrict ins empty xs+ where+ ins t (k,x) = insert k x t++-- | /O(n*min(n,W))/. Create a map from a list of key\/value pairs with a combining function. See also 'fromAscListWith'.+fromListWith :: (a -> a -> a) -> [(Key,a)] -> IntMap a +fromListWith f xs+ = fromListWithKey (\k x y -> f x y) xs++-- | /O(n*min(n,W))/. Build a map from a list of key\/value pairs with a combining function. See also fromAscListWithKey'.+fromListWithKey :: (Key -> a -> a -> a) -> [(Key,a)] -> IntMap a +fromListWithKey f xs + = foldlStrict ins empty xs+ where+ ins t (k,x) = insertWithKey f k x t++-- | /O(n*min(n,W))/. Build a map from a list of key\/value pairs where+-- the keys are in ascending order.+fromAscList :: [(Key,a)] -> IntMap a+fromAscList xs+ = fromList xs++-- | /O(n*min(n,W))/. Build a map from a list of key\/value pairs where+-- the keys are in ascending order, with a combining function on equal keys.+fromAscListWith :: (a -> a -> a) -> [(Key,a)] -> IntMap a+fromAscListWith f xs+ = fromListWith f xs++-- | /O(n*min(n,W))/. Build a map from a list of key\/value pairs where+-- the keys are in ascending order, with a combining function on equal keys.+fromAscListWithKey :: (Key -> a -> a -> a) -> [(Key,a)] -> IntMap a+fromAscListWithKey f xs+ = fromListWithKey f xs++-- | /O(n*min(n,W))/. Build a map from a list of key\/value pairs where+-- the keys are in ascending order and all distinct.+fromDistinctAscList :: [(Key,a)] -> IntMap a+fromDistinctAscList xs+ = fromList xs+++{--------------------------------------------------------------------+ Eq +--------------------------------------------------------------------}+instance Eq a => Eq (IntMap a) where+ t1 == t2 = equal t1 t2+ t1 /= t2 = nequal t1 t2++equal :: Eq a => IntMap a -> IntMap a -> Bool+equal (Bin p1 m1 l1 r1) (Bin p2 m2 l2 r2)+ = (m1 == m2) && (p1 == p2) && (equal l1 l2) && (equal r1 r2) +equal (Tip kx x) (Tip ky y)+ = (kx == ky) && (x==y)+equal Nil Nil = True+equal t1 t2 = False++nequal :: Eq a => IntMap a -> IntMap a -> Bool+nequal (Bin p1 m1 l1 r1) (Bin p2 m2 l2 r2)+ = (m1 /= m2) || (p1 /= p2) || (nequal l1 l2) || (nequal r1 r2) +nequal (Tip kx x) (Tip ky y)+ = (kx /= ky) || (x/=y)+nequal Nil Nil = False+nequal t1 t2 = True++{--------------------------------------------------------------------+ Ord +--------------------------------------------------------------------}++instance Ord a => Ord (IntMap a) where+ compare m1 m2 = compare (toList m1) (toList m2)++{--------------------------------------------------------------------+ Functor +--------------------------------------------------------------------}++instance Functor IntMap where+ fmap = map++{--------------------------------------------------------------------+ Show +--------------------------------------------------------------------}++instance Show a => Show (IntMap a) where+ showsPrec d m = showParen (d > 10) $+ showString "fromList " . shows (toList m)++showMap :: (Show a) => [(Key,a)] -> ShowS+showMap [] + = showString "{}" +showMap (x:xs) + = showChar '{' . showElem x . showTail xs+ where+ showTail [] = showChar '}'+ showTail (x:xs) = showChar ',' . showElem x . showTail xs+ + showElem (k,x) = shows k . showString ":=" . shows x++{--------------------------------------------------------------------+ Read+--------------------------------------------------------------------}+instance (Read e) => Read (IntMap e) where+#ifdef __GLASGOW_HASKELL__+ readPrec = parens $ prec 10 $ do+ Ident "fromList" <- lexP+ xs <- readPrec+ return (fromList xs)++ readListPrec = readListPrecDefault+#else+ readsPrec p = readParen (p > 10) $ \ r -> do+ ("fromList",s) <- lex r+ (xs,t) <- reads s+ return (fromList xs,t)+#endif++{--------------------------------------------------------------------+ Typeable+--------------------------------------------------------------------}++#include "Typeable.h"+INSTANCE_TYPEABLE1(IntMap,intMapTc,"IntMap")++{--------------------------------------------------------------------+ Debugging+--------------------------------------------------------------------}+-- | /O(n)/. Show the tree that implements the map. The tree is shown+-- in a compressed, hanging format.+showTree :: Show a => IntMap a -> String+showTree s+ = showTreeWith True False s+++{- | /O(n)/. The expression (@'showTreeWith' hang wide map@) shows+ the tree that implements the map. If @hang@ is+ 'True', a /hanging/ tree is shown otherwise a rotated tree is shown. If+ @wide@ is 'True', an extra wide version is shown.+-}+showTreeWith :: Show a => Bool -> Bool -> IntMap a -> String+showTreeWith hang wide t+ | hang = (showsTreeHang wide [] t) ""+ | otherwise = (showsTree wide [] [] t) ""++showsTree :: Show a => Bool -> [String] -> [String] -> IntMap a -> ShowS+showsTree wide lbars rbars t+ = case t of+ Bin p m l r+ -> showsTree wide (withBar rbars) (withEmpty rbars) r .+ showWide wide rbars .+ showsBars lbars . showString (showBin p m) . showString "\n" .+ showWide wide lbars .+ showsTree wide (withEmpty lbars) (withBar lbars) l+ Tip k x+ -> showsBars lbars . showString " " . shows k . showString ":=" . shows x . showString "\n" + Nil -> showsBars lbars . showString "|\n"++showsTreeHang :: Show a => Bool -> [String] -> IntMap a -> ShowS+showsTreeHang wide bars t+ = case t of+ Bin p m l r+ -> showsBars bars . showString (showBin p m) . showString "\n" . + showWide wide bars .+ showsTreeHang wide (withBar bars) l .+ showWide wide bars .+ showsTreeHang wide (withEmpty bars) r+ Tip k x+ -> showsBars bars . showString " " . shows k . showString ":=" . shows x . showString "\n" + Nil -> showsBars bars . showString "|\n" + +showBin p m+ = "*" -- ++ show (p,m)++showWide wide bars + | wide = showString (concat (reverse bars)) . showString "|\n" + | otherwise = id++showsBars :: [String] -> ShowS+showsBars bars+ = case bars of+ [] -> id+ _ -> showString (concat (reverse (tail bars))) . showString node++node = "+--"+withBar bars = "| ":bars+withEmpty bars = " ":bars+++{--------------------------------------------------------------------+ Helpers+--------------------------------------------------------------------}+{--------------------------------------------------------------------+ Join+--------------------------------------------------------------------}+join :: Prefix -> IntMap a -> Prefix -> IntMap a -> IntMap a+join p1 t1 p2 t2+ | zero p1 m = Bin p m t1 t2+ | otherwise = Bin p m t2 t1+ where+ m = branchMask p1 p2+ p = mask p1 m++{--------------------------------------------------------------------+ @bin@ assures that we never have empty trees within a tree.+--------------------------------------------------------------------}+bin :: Prefix -> Mask -> IntMap a -> IntMap a -> IntMap a+bin p m l Nil = l+bin p m Nil r = r+bin p m l r = Bin p m l r++ +{--------------------------------------------------------------------+ Endian independent bit twiddling+--------------------------------------------------------------------}+zero :: Key -> Mask -> Bool+zero i m+ = (natFromInt i) .&. (natFromInt m) == 0++nomatch,match :: Key -> Prefix -> Mask -> Bool+nomatch i p m+ = (mask i m) /= p++match i p m+ = (mask i m) == p++mask :: Key -> Mask -> Prefix+mask i m+ = maskW (natFromInt i) (natFromInt m)+++zeroN :: Nat -> Nat -> Bool+zeroN i m = (i .&. m) == 0++{--------------------------------------------------------------------+ Big endian operations +--------------------------------------------------------------------}+maskW :: Nat -> Nat -> Prefix+maskW i m+ = intFromNat (i .&. (complement (m-1) `xor` m))++shorter :: Mask -> Mask -> Bool+shorter m1 m2+ = (natFromInt m1) > (natFromInt m2)++branchMask :: Prefix -> Prefix -> Mask+branchMask p1 p2+ = intFromNat (highestBitMask (natFromInt p1 `xor` natFromInt p2))+ +{----------------------------------------------------------------------+ Finding the highest bit (mask) in a word [x] can be done efficiently in+ three ways:+ * convert to a floating point value and the mantissa tells us the + [log2(x)] that corresponds with the highest bit position. The mantissa + is retrieved either via the standard C function [frexp] or by some bit + twiddling on IEEE compatible numbers (float). Note that one needs to + use at least [double] precision for an accurate mantissa of 32 bit + numbers.+ * use bit twiddling, a logarithmic sequence of bitwise or's and shifts (bit).+ * use processor specific assembler instruction (asm).++ The most portable way would be [bit], but is it efficient enough?+ I have measured the cycle counts of the different methods on an AMD + Athlon-XP 1800 (~ Pentium III 1.8Ghz) using the RDTSC instruction:++ highestBitMask: method cycles+ --------------+ frexp 200+ float 33+ bit 11+ asm 12++ highestBit: method cycles+ --------------+ frexp 195+ float 33+ bit 11+ asm 11++ Wow, the bit twiddling is on today's RISC like machines even faster+ than a single CISC instruction (BSR)!+----------------------------------------------------------------------}++{----------------------------------------------------------------------+ [highestBitMask] returns a word where only the highest bit is set.+ It is found by first setting all bits in lower positions than the + highest bit and than taking an exclusive or with the original value.+ Allthough the function may look expensive, GHC compiles this into+ excellent C code that subsequently compiled into highly efficient+ machine code. The algorithm is derived from Jorg Arndt's FXT library.+----------------------------------------------------------------------}+highestBitMask :: Nat -> Nat+highestBitMask x+ = case (x .|. shiftRL x 1) of + x -> case (x .|. shiftRL x 2) of + x -> case (x .|. shiftRL x 4) of + x -> case (x .|. shiftRL x 8) of + x -> case (x .|. shiftRL x 16) of + x -> case (x .|. shiftRL x 32) of -- for 64 bit platforms+ x -> (x `xor` (shiftRL x 1))+++{--------------------------------------------------------------------+ Utilities +--------------------------------------------------------------------}+foldlStrict f z xs+ = case xs of+ [] -> z+ (x:xx) -> let z' = f z x in seq z' (foldlStrict f z' xx)++{-+{--------------------------------------------------------------------+ Testing+--------------------------------------------------------------------}+testTree :: [Int] -> IntMap Int+testTree xs = fromList [(x,x*x*30696 `mod` 65521) | x <- xs]+test1 = testTree [1..20]+test2 = testTree [30,29..10]+test3 = testTree [1,4,6,89,2323,53,43,234,5,79,12,9,24,9,8,423,8,42,4,8,9,3]++{--------------------------------------------------------------------+ QuickCheck+--------------------------------------------------------------------}+qcheck prop+ = check config prop+ where+ config = Config+ { configMaxTest = 500+ , configMaxFail = 5000+ , configSize = \n -> (div n 2 + 3)+ , configEvery = \n args -> let s = show n in s ++ [ '\b' | _ <- s ]+ }+++{--------------------------------------------------------------------+ Arbitrary, reasonably balanced trees+--------------------------------------------------------------------}+instance Arbitrary a => Arbitrary (IntMap a) where+ arbitrary = do{ ks <- arbitrary+ ; xs <- mapM (\k -> do{ x <- arbitrary; return (k,x)}) ks+ ; return (fromList xs)+ }+++{--------------------------------------------------------------------+ Single, Insert, Delete+--------------------------------------------------------------------}+prop_Single :: Key -> Int -> Bool+prop_Single k x+ = (insert k x empty == singleton k x)++prop_InsertDelete :: Key -> Int -> IntMap Int -> Property+prop_InsertDelete k x t+ = not (member k t) ==> delete k (insert k x t) == t++prop_UpdateDelete :: Key -> IntMap Int -> Bool +prop_UpdateDelete k t+ = update (const Nothing) k t == delete k t+++{--------------------------------------------------------------------+ Union+--------------------------------------------------------------------}+prop_UnionInsert :: Key -> Int -> IntMap Int -> Bool+prop_UnionInsert k x t+ = union (singleton k x) t == insert k x t++prop_UnionAssoc :: IntMap Int -> IntMap Int -> IntMap Int -> Bool+prop_UnionAssoc t1 t2 t3+ = union t1 (union t2 t3) == union (union t1 t2) t3++prop_UnionComm :: IntMap Int -> IntMap Int -> Bool+prop_UnionComm t1 t2+ = (union t1 t2 == unionWith (\x y -> y) t2 t1)+++prop_Diff :: [(Key,Int)] -> [(Key,Int)] -> Bool+prop_Diff xs ys+ = List.sort (keys (difference (fromListWith (+) xs) (fromListWith (+) ys))) + == List.sort ((List.\\) (nub (Prelude.map fst xs)) (nub (Prelude.map fst ys)))++prop_Int :: [(Key,Int)] -> [(Key,Int)] -> Bool+prop_Int xs ys+ = List.sort (keys (intersection (fromListWith (+) xs) (fromListWith (+) ys))) + == List.sort (nub ((List.intersect) (Prelude.map fst xs) (Prelude.map fst ys)))++{--------------------------------------------------------------------+ Lists+--------------------------------------------------------------------}+prop_Ordered+ = forAll (choose (5,100)) $ \n ->+ let xs = [(x,()) | x <- [0..n::Int]] + in fromAscList xs == fromList xs++prop_List :: [Key] -> Bool+prop_List xs+ = (sort (nub xs) == [x | (x,()) <- toAscList (fromList [(x,()) | x <- xs])])+-}
+ Data/IntSet.hs view
@@ -0,0 +1,1020 @@+{-# OPTIONS -cpp -fglasgow-exts #-}+-----------------------------------------------------------------------------+-- |+-- Module : Data.IntSet+-- Copyright : (c) Daan Leijen 2002+-- License : BSD-style+-- Maintainer : libraries@haskell.org+-- Stability : provisional+-- Portability : portable+--+-- An efficient implementation of integer sets.+--+-- Since many function names (but not the type name) clash with+-- "Prelude" names, this module is usually imported @qualified@, e.g.+--+-- > import Data.IntSet (IntSet)+-- > import qualified Data.IntSet as IntSet+--+-- 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 "Data.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.+--+-- 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 Data.IntSet ( + -- * Set type+ IntSet -- instance Eq,Show++ -- * Operators+ , (\\)++ -- * Query+ , null+ , size+ , member+ , notMember+ , isSubsetOf+ , isProperSubsetOf+ + -- * Construction+ , empty+ , singleton+ , insert+ , delete+ + -- * Combine+ , union, unions+ , difference+ , intersection+ + -- * Filter+ , filter+ , partition+ , split+ , splitMember++ -- * Min\/Max+ , findMin + , findMax+ , deleteMin+ , deleteMax+ , deleteFindMin+ , deleteFindMax+ , maxView+ , minView++ -- * Map+ , map++ -- * Fold+ , fold++ -- * Conversion+ -- ** List+ , elems+ , toList+ , fromList+ + -- ** Ordered list+ , toAscList+ , fromAscList+ , fromDistinctAscList+ + -- * Debugging+ , showTree+ , showTreeWith+ ) where+++import Prelude hiding (lookup,filter,foldr,foldl,null,map)+import Data.Bits ++import qualified Data.List as List+import Data.Monoid (Monoid(..))+import Data.Typeable++{-+-- just for testing+import QuickCheck +import List (nub,sort)+import qualified List+-}++#if __GLASGOW_HASKELL__+import Text.Read+import Data.Generics.Basics (Data(..), mkNorepType)+import Data.Generics.Instances ()+#endif++#if __GLASGOW_HASKELL__ >= 503+import GHC.Exts ( Word(..), Int(..), shiftRL# )+#elif __GLASGOW_HASKELL__+import Word+import GlaExts ( Word(..), Int(..), shiftRL# )+#else+import Data.Word+#endif++infixl 9 \\{-This comment teaches CPP correct behaviour -}++-- A "Nat" is a natural machine word (an unsigned Int)+type Nat = Word++natFromInt :: Int -> Nat+natFromInt i = fromIntegral i++intFromNat :: Nat -> Int+intFromNat w = fromIntegral w++shiftRL :: Nat -> Int -> Nat+#if __GLASGOW_HASKELL__+{--------------------------------------------------------------------+ GHC: use unboxing to get @shiftRL@ inlined.+--------------------------------------------------------------------}+shiftRL (W# x) (I# i)+ = W# (shiftRL# x i)+#else+shiftRL x i = shiftR x 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 {-# UNPACK #-} !Int+ | Bin {-# UNPACK #-} !Prefix {-# UNPACK #-} !Mask !IntSet !IntSet+-- Invariant: Nil is never found as a child of Bin.+++type Prefix = Int+type Mask = Int++instance Monoid IntSet where+ mempty = empty+ mappend = union+ mconcat = unions++#if __GLASGOW_HASKELL__++{--------------------------------------------------------------------+ A Data instance +--------------------------------------------------------------------}++-- This instance preserves data abstraction at the cost of inefficiency.+-- We omit reflection services for the sake of data abstraction.++instance Data IntSet where+ gfoldl f z is = z fromList `f` (toList is)+ toConstr _ = error "toConstr"+ gunfold _ _ = error "gunfold"+ dataTypeOf _ = mkNorepType "Data.IntSet.IntSet"++#endif++{--------------------------------------------------------------------+ Query+--------------------------------------------------------------------}+-- | /O(1)/. Is the set empty?+null :: IntSet -> Bool+null Nil = True+null 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+ +-- | /O(min(n,W))/. Is the element not in the set?+notMember :: Int -> IntSet -> Bool+notMember k = not . member k++-- 'lookup' is used by 'intersection' for left-biasing+lookup :: Int -> IntSet -> Maybe Int+lookup k t+ = let nk = natFromInt k in seq nk (lookupN nk t)++lookupN :: Nat -> IntSet -> Maybe Int+lookupN k t+ = case t of+ Bin p m l r + | zeroN k (natFromInt m) -> lookupN k l+ | otherwise -> lookupN k r+ Tip kx + | (k == natFromInt kx) -> Just kx+ | otherwise -> Nothing+ Nil -> Nothing++{--------------------------------------------------------------------+ Construction+--------------------------------------------------------------------}+-- | /O(1)/. The empty set.+empty :: IntSet+empty+ = Nil++-- | /O(1)/. A set of one element.+singleton :: Int -> IntSet+singleton 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).+isProperSubsetOf :: IntSet -> IntSet -> Bool+isProperSubsetOf 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?+-- @(s1 `isSubsetOf` s2)@ tells whether @s1@ is a subset of @s2@.++isSubsetOf :: IntSet -> IntSet -> Bool+isSubsetOf 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 isSubsetOf t1 l2+ else isSubsetOf t1 r2) + | otherwise = (p1==p2) && isSubsetOf l1 l2 && isSubsetOf r1 r2+isSubsetOf (Bin p m l r) t = False+isSubsetOf (Tip x) t = member x t+isSubsetOf 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(min(n,W))/. 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 3 (fromList [1..5]) == (fromList [1,2], fromList [3,4])+split :: Int -> IntSet -> (IntSet,IntSet)+split x t+ = case t of+ Bin p m l r+ | m < 0 -> if x >= 0 then let (lt,gt) = split' x l in (union r lt, gt)+ else let (lt,gt) = split' x r in (lt, union gt l)+ -- handle negative numbers.+ | otherwise -> split' x t+ Tip y + | x>y -> (t,Nil)+ | x<y -> (Nil,t)+ | otherwise -> (Nil,Nil)+ Nil -> (Nil, Nil)++split' :: Int -> IntSet -> (IntSet,IntSet)+split' x t+ = case t of+ Bin p m l r+ | match x p m -> if zero x m then let (lt,gt) = split' x l in (lt,union gt r)+ else let (lt,gt) = split' x r in (union l lt,gt)+ | otherwise -> if x < p then (Nil, t)+ else (t, Nil)+ Tip y + | x>y -> (t,Nil)+ | x<y -> (Nil,t)+ | otherwise -> (Nil,Nil)+ Nil -> (Nil,Nil)++-- | /O(min(n,W))/. Performs a 'split' but also returns whether the pivot+-- element was found in the original set.+splitMember :: Int -> IntSet -> (IntSet,Bool,IntSet)+splitMember x t+ = case t of+ Bin p m l r+ | m < 0 -> if x >= 0 then let (lt,found,gt) = splitMember' x l in (union r lt, found, gt)+ else let (lt,found,gt) = splitMember' x r in (lt, found, union gt l)+ -- handle negative numbers.+ | otherwise -> splitMember' x t+ Tip y + | x>y -> (t,False,Nil)+ | x<y -> (Nil,False,t)+ | otherwise -> (Nil,True,Nil)+ Nil -> (Nil,False,Nil)++splitMember' :: Int -> IntSet -> (IntSet,Bool,IntSet)+splitMember' x t+ = case t of+ Bin p m l r+ | match x p m -> if zero x m then let (lt,found,gt) = splitMember x l in (lt,found,union gt r)+ else let (lt,found,gt) = splitMember x r in (union l lt,found,gt)+ | otherwise -> if x < p then (Nil, False, t)+ else (t, False, Nil)+ Tip y + | x>y -> (t,False,Nil)+ | x<y -> (Nil,False,t)+ | otherwise -> (Nil,True,Nil)+ Nil -> (Nil,False,Nil)++{----------------------------------------------------------------------+ Min/Max+----------------------------------------------------------------------}++-- | /O(min(n,W))/. Retrieves the maximal key of the set, and the set stripped from that element+-- @fail@s (in the monad) when passed an empty set.+maxView :: (Monad m) => IntSet -> m (Int, IntSet)+maxView t+ = case t of+ Bin p m l r | m < 0 -> let (result,t') = maxViewUnsigned l in return (result, bin p m t' r)+ Bin p m l r -> let (result,t') = maxViewUnsigned r in return (result, bin p m l t') + Tip y -> return (y,Nil)+ Nil -> fail "maxView: empty set has no maximal element"++maxViewUnsigned :: IntSet -> (Int, IntSet)+maxViewUnsigned t + = case t of+ Bin p m l r -> let (result,t') = maxViewUnsigned r in (result, bin p m l t')+ Tip y -> (y, Nil)++-- | /O(min(n,W))/. Retrieves the minimal key of the set, and the set stripped from that element+-- @fail@s (in the monad) when passed an empty set.+minView :: (Monad m) => IntSet -> m (Int, IntSet)+minView t+ = case t of+ Bin p m l r | m < 0 -> let (result,t') = minViewUnsigned r in return (result, bin p m l t') + Bin p m l r -> let (result,t') = minViewUnsigned l in return (result, bin p m t' r)+ Tip y -> return (y, Nil)+ Nil -> fail "minView: empty set has no minimal element"++minViewUnsigned :: IntSet -> (Int, IntSet)+minViewUnsigned t + = case t of+ Bin p m l r -> let (result,t') = minViewUnsigned l in (result, bin p m t' r)+ Tip y -> (y, Nil)+++-- Duplicate the Identity monad here because base < mtl.+newtype Identity a = Identity { runIdentity :: a }+instance Monad Identity where+ return a = Identity a+ m >>= k = k (runIdentity m)+++-- | /O(min(n,W))/. Delete and find the minimal element.+-- +-- > deleteFindMin set = (findMin set, deleteMin set)+deleteFindMin :: IntSet -> (Int, IntSet)+deleteFindMin = runIdentity . minView++-- | /O(min(n,W))/. Delete and find the maximal element.+-- +-- > deleteFindMax set = (findMax set, deleteMax set)+deleteFindMax :: IntSet -> (Int, IntSet)+deleteFindMax = runIdentity . maxView++-- | /O(min(n,W))/. The minimal element of a set.+findMin :: IntSet -> Int+findMin = fst . runIdentity . minView++-- | /O(min(n,W))/. The maximal element of a set.+findMax :: IntSet -> Int+findMax = fst . runIdentity . maxView++-- | /O(min(n,W))/. Delete the minimal element.+deleteMin :: IntSet -> IntSet+deleteMin = snd . runIdentity . minView++-- | /O(min(n,W))/. Delete the maximal element.+deleteMax :: IntSet -> IntSet+deleteMax = snd . runIdentity . maxView++++{----------------------------------------------------------------------+ Map+----------------------------------------------------------------------}++-- | /O(n*min(n,W))/. +-- @'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 :: (Int->Int) -> IntSet -> IntSet+map f = fromList . List.map f . toList++{--------------------------------------------------------------------+ 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+ = case t of+ Bin 0 m l r | m < 0 -> foldr f (foldr f z l) r + -- put negative numbers before.+ Bin p m l r -> foldr f z t+ Tip x -> f x z+ Nil -> z++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. (For sets, this is equivalent to toList)+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 = toList t++-- | /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++{--------------------------------------------------------------------+ Ord +--------------------------------------------------------------------}++instance Ord IntSet where+ compare s1 s2 = compare (toAscList s1) (toAscList s2) + -- tentative implementation. See if more efficient exists.++{--------------------------------------------------------------------+ Show+--------------------------------------------------------------------}+instance Show IntSet where+ showsPrec p xs = showParen (p > 10) $+ showString "fromList " . shows (toList xs)++showSet :: [Int] -> ShowS+showSet [] + = showString "{}" +showSet (x:xs) + = showChar '{' . shows x . showTail xs+ where+ showTail [] = showChar '}'+ showTail (x:xs) = showChar ',' . shows x . showTail xs++{--------------------------------------------------------------------+ Read+--------------------------------------------------------------------}+instance Read IntSet where+#ifdef __GLASGOW_HASKELL__+ readPrec = parens $ prec 10 $ do+ Ident "fromList" <- lexP+ xs <- readPrec+ return (fromList xs)++ readListPrec = readListPrecDefault+#else+ readsPrec p = readParen (p > 10) $ \ r -> do+ ("fromList",s) <- lex r+ (xs,t) <- reads s+ return (fromList xs,t)+#endif++{--------------------------------------------------------------------+ Typeable+--------------------------------------------------------------------}++#include "Typeable.h"+INSTANCE_TYPEABLE0(IntSet,intSetTc,"IntSet")++{--------------------------------------------------------------------+ 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)++zeroN :: Nat -> Nat -> Bool+zeroN i m = (i .&. m) == 0++{--------------------------------------------------------------------+ 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 == singleton 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 (singleton 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))+-}
+ Data/Map.hs view
@@ -0,0 +1,1846 @@+{-# OPTIONS_GHC -fno-bang-patterns #-}++-----------------------------------------------------------------------------+-- |+-- Module : Data.Map+-- Copyright : (c) Daan Leijen 2002+-- License : BSD-style+-- Maintainer : libraries@haskell.org+-- Stability : provisional+-- Portability : portable+--+-- An efficient implementation of maps from keys to values (dictionaries).+--+-- Since many function names (but not the type name) clash with+-- "Prelude" names, this module is usually imported @qualified@, e.g.+--+-- > import Data.Map (Map)+-- > import qualified Data.Map as Map+--+-- 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.+--+-- Note that the implementation is /left-biased/ -- the elements of a+-- first argument are always preferred to the second, for example in+-- 'union' or 'insert'.+-----------------------------------------------------------------------------++module Data.Map ( + -- * Map type+ Map -- instance Eq,Show,Read++ -- * Operators+ , (!), (\\)+++ -- * Query+ , null+ , size+ , member+ , notMember+ , lookup+ , findWithDefault+ + -- * Construction+ , empty+ , singleton++ -- ** Insertion+ , insert+ , insertWith, insertWithKey, insertLookupWithKey+ , insertWith', insertWithKey'+ + -- ** Delete\/Update+ , delete+ , adjust+ , adjustWithKey+ , update+ , updateWithKey+ , updateLookupWithKey+ , alter++ -- * Combine++ -- ** Union+ , union + , unionWith + , unionWithKey+ , unions+ , unionsWith++ -- ** Difference+ , difference+ , differenceWith+ , differenceWithKey+ + -- ** Intersection+ , intersection + , intersectionWith+ , intersectionWithKey++ -- * Traversal+ -- ** Map+ , map+ , mapWithKey+ , mapAccum+ , mapAccumWithKey+ , mapKeys+ , mapKeysWith+ , mapKeysMonotonic++ -- ** Fold+ , fold+ , foldWithKey++ -- * Conversion+ , elems+ , keys+ , keysSet+ , assocs+ + -- ** Lists+ , toList+ , fromList+ , fromListWith+ , fromListWithKey++ -- ** Ordered lists+ , toAscList+ , fromAscList+ , fromAscListWith+ , fromAscListWithKey+ , fromDistinctAscList++ -- * Filter + , filter+ , filterWithKey+ , partition+ , partitionWithKey++ , mapMaybe+ , mapMaybeWithKey+ , mapEither+ , mapEitherWithKey++ , split + , splitLookup ++ -- * Submap+ , isSubmapOf, isSubmapOfBy+ , isProperSubmapOf, isProperSubmapOfBy++ -- * Indexed + , lookupIndex+ , findIndex+ , elemAt+ , updateAt+ , deleteAt++ -- * Min\/Max+ , findMin+ , findMax+ , deleteMin+ , deleteMax+ , deleteFindMin+ , deleteFindMax+ , updateMin+ , updateMax+ , updateMinWithKey+ , updateMaxWithKey+ , minView+ , maxView+ , minViewWithKey+ , maxViewWithKey+ + -- * Debugging+ , showTree+ , showTreeWith+ , valid+ ) where++import Prelude hiding (lookup,map,filter,foldr,foldl,null)+import qualified Data.Set as Set+import qualified Data.List as List+import Data.Monoid (Monoid(..))+import Data.Typeable+import Control.Applicative (Applicative(..), (<$>))+import Data.Traversable (Traversable(traverse))+import Data.Foldable (Foldable(foldMap))++{-+-- for quick check+import qualified Prelude+import qualified List+import Debug.QuickCheck +import List(nub,sort) +-}++#if __GLASGOW_HASKELL__+import Text.Read+import Data.Generics.Basics+import Data.Generics.Instances+#endif++{--------------------------------------------------------------------+ Operators+--------------------------------------------------------------------}+infixl 9 !,\\ --++-- | /O(log n)/. Find the value at a key.+-- Calls 'error' when the element can not be found.+(!) :: Ord k => Map k a -> k -> a+m ! k = find k m++-- | /O(n+m)/. See 'difference'.+(\\) :: Ord k => Map k a -> Map k b -> Map k a+m1 \\ m2 = difference m1 m2++{--------------------------------------------------------------------+ Size balanced trees.+--------------------------------------------------------------------}+-- | A Map from keys @k@ to values @a@. +data Map k a = Tip + | Bin {-# UNPACK #-} !Size !k a !(Map k a) !(Map k a) ++type Size = Int++instance (Ord k) => Monoid (Map k v) where+ mempty = empty+ mappend = union+ mconcat = unions++#if __GLASGOW_HASKELL__++{--------------------------------------------------------------------+ A Data instance +--------------------------------------------------------------------}++-- This instance preserves data abstraction at the cost of inefficiency.+-- We omit reflection services for the sake of data abstraction.++instance (Data k, Data a, Ord k) => Data (Map k a) where+ gfoldl f z map = z fromList `f` (toList map)+ toConstr _ = error "toConstr"+ gunfold _ _ = error "gunfold"+ dataTypeOf _ = mkNorepType "Data.Map.Map"+ dataCast2 f = gcast2 f++#endif++{--------------------------------------------------------------------+ Query+--------------------------------------------------------------------}+-- | /O(1)/. Is the map empty?+null :: Map k a -> Bool+null 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 at a key in the map. +--+-- The function will +-- @return@ the result in the monad or @fail@ in it the key isn't in the +-- map. Often, the monad to use is 'Maybe', so you get either +-- @('Just' result)@ or @'Nothing'@.+lookup :: (Monad m,Ord k) => k -> Map k a -> m a+lookup k t = case lookup' k t of+ Just x -> return x+ Nothing -> fail "Data.Map.lookup: Key not found"+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 ++lookupAssoc :: Ord k => k -> Map k a -> Maybe (k,a)+lookupAssoc k t+ = case t of+ Tip -> Nothing+ Bin sz kx x l r+ -> case compare k kx of+ LT -> lookupAssoc k l+ GT -> lookupAssoc k r+ EQ -> Just (kx,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)/. Is the key not a member of the map?+notMember :: Ord k => k -> Map k a -> Bool+notMember k m = not $ member k m++-- | /O(log n)/. Find the value at 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 at 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)/. The empty map.+empty :: Map k a+empty + = Tip++-- | /O(1)/. A map with a single element.+singleton :: k -> a -> Map k a+singleton k x + = Bin 1 k x Tip Tip++{--------------------------------------------------------------------+ Insertion+--------------------------------------------------------------------}+-- | /O(log n)/. Insert a new key and value in the map.+-- If the key is already present in the map, the associated value is+-- replaced with the supplied value, i.e. 'insert' is equivalent to+-- @'insertWith' 'const'@.+insert :: Ord k => k -> a -> Map k a -> Map k a+insert kx x t+ = case t of+ Tip -> singleton 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' f key value mp@ +-- will insert the pair (key, value) into @mp@ if key does+-- not exist in the map. If the key does exist, the function will+-- insert the pair @(key, f new_value old_value)@.+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++-- | Same as 'insertWith', but the combining function is applied strictly.+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' f key value mp@ +-- will insert the pair (key, value) into @mp@ if key does+-- not exist in the map. If the key does exist, the function will+-- insert the pair @(key,f key new_value old_value)@.+-- Note that the key passed to f is the same key passed to 'insertWithKey'.+insertWithKey :: Ord k => (k -> a -> a -> a) -> k -> a -> Map k a -> Map k a+insertWithKey f kx x t+ = case t of+ Tip -> singleton 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 kx (f kx x y) l r++-- | Same as 'insertWithKey', but the combining function is applied strictly.+insertWithKey' :: Ord k => (k -> a -> a -> a) -> k -> a -> Map k a -> Map k a+insertWithKey' f kx x t+ = case t of+ Tip -> singleton 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 -> let x' = f kx x y in seq x' (Bin sy kx x' 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, singleton 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 kx (f kx 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 (@'updateWithKey' 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)++-- | /O(log n)/. The expression (@'alter' f k map@) alters the value @x@ at @k@, or absence thereof.+-- 'alter' can be used to insert, delete, or update a value in a 'Map'.+-- In short : @'lookup' k ('alter' f k m) = f ('lookup' k m)@+alter :: Ord k => (Maybe a -> Maybe a) -> k -> Map k a -> Map k a+alter f k t+ = case t of+ Tip -> case f Nothing of+ Nothing -> Tip+ Just x -> singleton k x+ Bin sx kx x l r + -> case compare k kx of+ LT -> balance kx x (alter f k l) r+ GT -> balance kx x l (alter f k r)+ EQ -> case f (Just x) of+ Just x' -> Bin sx kx x' l r+ Nothing -> 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 :: (Monad m,Ord k) => k -> Map k a -> m Int+lookupIndex k t = case lookup 0 t of+ Nothing -> fail "Data.Map.lookupIndex: Key not found."+ Just x -> return x+ 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 -> balance kx x (updateAt f i l) r+ GT -> balance kx x l (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 map 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 map 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 value at 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 value at 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 value at 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 value at 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++-- | /O(log n)/. Retrieves the minimal (key,value) pair of the map, and the map stripped from that element+-- @fail@s (in the monad) when passed an empty map.+minViewWithKey :: Monad m => Map k a -> m ((k,a), Map k a)+minViewWithKey Tip = fail "Map.minView: empty map"+minViewWithKey x = return (deleteFindMin x)++-- | /O(log n)/. Retrieves the maximal (key,value) pair of the map, and the map stripped from that element+-- @fail@s (in the monad) when passed an empty map.+maxViewWithKey :: Monad m => Map k a -> m ((k,a), Map k a)+maxViewWithKey Tip = fail "Map.maxView: empty map"+maxViewWithKey x = return (deleteFindMax x)++-- | /O(log n)/. Retrieves the minimal key\'s value of the map, and the map stripped from that element+-- @fail@s (in the monad) when passed an empty map.+minView :: Monad m => Map k a -> m (a, Map k a)+minView Tip = fail "Map.minView: empty map"+minView x = return (first snd $ deleteFindMin x)++-- | /O(log n)/. Retrieves the maximal key\'s value of the map, and the map stripped from that element+-- @fail@s (in the monad) when passed an empty map.+maxView :: Monad m => Map k a -> m (a, Map k a)+maxView Tip = fail "Map.maxView: empty map"+maxView x = return (first snd $ deleteFindMax x)++-- Update the 1st component of a tuple (special case of Control.Arrow.first)+first :: (a -> b) -> (a,c) -> (b,c)+first f (x,y) = (f x, y)++{--------------------------------------------------------------------+ Union. +--------------------------------------------------------------------}+-- | The union of a list of maps:+-- (@'unions' == 'Prelude.foldl' 'union' 'empty'@).+unions :: Ord k => [Map k a] -> Map k a+unions ts+ = foldlStrict union empty ts++-- | The union of a list of maps, with a combining operation:+-- (@'unionsWith' f == 'Prelude.foldl' ('unionWith' f) 'empty'@).+unionsWith :: Ord k => (a->a->a) -> [Map k a] -> Map k a+unionsWith f ts+ = foldlStrict (unionWith f) 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,+-- i.e. (@'union' == 'unionWith' 'const'@).+-- The implementation uses the efficient /hedge-union/ algorithm.+-- Hedge-union is more efficient on (bigset `union` smallset)+union :: Ord k => Map k a -> Map k a -> Map k a+union Tip t2 = t2+union t1 Tip = t1+union t1 t2 = hedgeUnionL (const LT) (const GT) t1 t2++-- 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.+-- Hedge-union is more efficient on (bigset `union` smallset).+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 = hedgeUnionWithKey f (const LT) (const GT) t1 t2++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 b -> 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 -> b -> Maybe a) -> Map k a -> Map k b -> 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 -> b -> Maybe a) -> Map k a -> Map k b -> 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 (ky,y) -> + case f ky y x of+ Nothing -> merge tl tr+ Just z -> join ky 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 b -> 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 -> b -> c) -> Map k a -> Map k b -> Map k c+intersectionWith f m1 m2+ = intersectionWithKey (\k x y -> f x y) m1 m2++-- | /O(n+m)/. Intersection with a combining function.+-- Intersection is more efficient on (bigset `intersection` smallset)+--intersectionWithKey :: Ord k => (k -> a -> b -> c) -> Map k a -> Map k b -> Map k c+--intersectionWithKey f Tip t = Tip+--intersectionWithKey f t Tip = Tip+--intersectionWithKey f t1 t2 = intersectWithKey f t1 t2+--+--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+-- (lt,found,gt) = splitLookup kx t+-- tl = intersectWithKey f lt l+-- tr = intersectWithKey f gt r+++intersectionWithKey :: Ord k => (k -> a -> b -> c) -> Map k a -> Map k b -> Map k c+intersectionWithKey f Tip t = Tip+intersectionWithKey f t Tip = Tip+intersectionWithKey f t1@(Bin s1 k1 x1 l1 r1) t2@(Bin s2 k2 x2 l2 r2) =+ if s1 >= s2 then+ let (lt,found,gt) = splitLookupWithKey k2 t1+ tl = intersectionWithKey f lt l2+ tr = intersectionWithKey f gt r2+ in case found of+ Just (k,x) -> join k (f k x x2) tl tr+ Nothing -> merge tl tr+ else let (lt,found,gt) = splitLookup k1 t2+ tl = intersectionWithKey f l1 lt+ tr = intersectionWithKey f r1 gt+ in case found of+ Just x -> join k1 (f k1 x1 x) tl tr+ Nothing -> merge tl tr++++{--------------------------------------------------------------------+ Submap+--------------------------------------------------------------------}+-- | /O(n+m)/. +-- This function is defined as (@'isSubmapOf' = 'isSubmapOfBy' (==)@).+isSubmapOf :: (Ord k,Eq a) => Map k a -> Map k a -> Bool+isSubmapOf m1 m2+ = isSubmapOfBy (==) m1 m2++{- | /O(n+m)/. + The expression (@'isSubmapOfBy' 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':+ + > isSubmapOfBy (==) (fromList [('a',1)]) (fromList [('a',1),('b',2)])+ > isSubmapOfBy (<=) (fromList [('a',1)]) (fromList [('a',1),('b',2)])+ > isSubmapOfBy (==) (fromList [('a',1),('b',2)]) (fromList [('a',1),('b',2)])++ But the following are all 'False':+ + > isSubmapOfBy (==) (fromList [('a',2)]) (fromList [('a',1),('b',2)])+ > isSubmapOfBy (<) (fromList [('a',1)]) (fromList [('a',1),('b',2)])+ > isSubmapOfBy (==) (fromList [('a',1),('b',2)]) (fromList [('a',1)])+-}+isSubmapOfBy :: Ord k => (a->b->Bool) -> Map k a -> Map k b -> Bool+isSubmapOfBy f t1 t2+ = (size t1 <= size t2) && (submap' f t1 t2)++submap' f Tip t = True+submap' f t Tip = False+submap' f (Bin _ kx x l r) t+ = case found of+ Nothing -> False+ Just y -> f x y && submap' f l lt && submap' f r gt+ where+ (lt,found,gt) = splitLookup kx t++-- | /O(n+m)/. Is this a proper submap? (ie. a submap but not equal). +-- Defined as (@'isProperSubmapOf' = 'isProperSubmapOfBy' (==)@).+isProperSubmapOf :: (Ord k,Eq a) => Map k a -> Map k a -> Bool+isProperSubmapOf m1 m2+ = isProperSubmapOfBy (==) m1 m2++{- | /O(n+m)/. Is this a proper submap? (ie. a submap but not equal).+ The expression (@'isProperSubmapOfBy' 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':+ + > isProperSubmapOfBy (==) (fromList [(1,1)]) (fromList [(1,1),(2,2)])+ > isProperSubmapOfBy (<=) (fromList [(1,1)]) (fromList [(1,1),(2,2)])++ But the following are all 'False':+ + > isProperSubmapOfBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1),(2,2)])+ > isProperSubmapOfBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1)])+ > isProperSubmapOfBy (<) (fromList [(1,1)]) (fromList [(1,1),(2,2)])+-}+isProperSubmapOfBy :: Ord k => (a -> b -> Bool) -> Map k a -> Map k b -> Bool+isProperSubmapOfBy f t1 t2+ = (size t1 < size t2) && (submap' 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++-- | /O(n)/. Map values and collect the 'Just' results.+mapMaybe :: Ord k => (a -> Maybe b) -> Map k a -> Map k b+mapMaybe f m+ = mapMaybeWithKey (\k x -> f x) m++-- | /O(n)/. Map keys\/values and collect the 'Just' results.+mapMaybeWithKey :: Ord k => (k -> a -> Maybe b) -> Map k a -> Map k b+mapMaybeWithKey f Tip = Tip+mapMaybeWithKey f (Bin _ kx x l r) = case f kx x of+ Just y -> join kx y (mapMaybeWithKey f l) (mapMaybeWithKey f r)+ Nothing -> merge (mapMaybeWithKey f l) (mapMaybeWithKey f r)++-- | /O(n)/. Map values and separate the 'Left' and 'Right' results.+mapEither :: Ord k => (a -> Either b c) -> Map k a -> (Map k b, Map k c)+mapEither f m+ = mapEitherWithKey (\k x -> f x) m++-- | /O(n)/. Map keys\/values and separate the 'Left' and 'Right' results.+mapEitherWithKey :: Ord k =>+ (k -> a -> Either b c) -> Map k a -> (Map k b, Map k c)+mapEitherWithKey f Tip = (Tip, Tip)+mapEitherWithKey f (Bin _ kx x l r) = case f kx x of+ Left y -> (join kx y l1 r1, merge l2 r2)+ Right z -> (merge l1 r1, join kx z l2 r2)+ where+ (l1,l2) = mapEitherWithKey f l+ (r1,r2) = mapEitherWithKey f 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 ascending order of keys.+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 ascending order of keys.+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 order of keys.+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 order of keys.+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')++-- | /O(n*log n)/. +-- @'mapKeys' f s@ is the map obtained by applying @f@ to each key of @s@.+-- +-- The size of the result may be smaller if @f@ maps two or more distinct+-- keys to the same new key. In this case the value at the smallest of+-- these keys is retained.++mapKeys :: Ord k2 => (k1->k2) -> Map k1 a -> Map k2 a+mapKeys = mapKeysWith (\x y->x)++-- | /O(n*log n)/. +-- @'mapKeysWith' c f s@ is the map obtained by applying @f@ to each key of @s@.+-- +-- The size of the result may be smaller if @f@ maps two or more distinct+-- keys to the same new key. In this case the associated values will be+-- combined using @c@.++mapKeysWith :: Ord k2 => (a -> a -> a) -> (k1->k2) -> Map k1 a -> Map k2 a+mapKeysWith c f = fromListWith c . List.map fFirst . toList+ where fFirst (x,y) = (f x, y)+++-- | /O(n)/.+-- @'mapKeysMonotonic' f s == 'mapKeys' f s@, but works only when @f@+-- is strictly monotonic.+-- /The precondition is not checked./+-- Semi-formally, we have:+-- +-- > and [x < y ==> f x < f y | x <- ls, y <- ls] +-- > ==> mapKeysMonotonic f s == mapKeys f s+-- > where ls = keys s++mapKeysMonotonic :: (k1->k2) -> Map k1 a -> Map k2 a+mapKeysMonotonic f Tip = Tip+mapKeysMonotonic f (Bin sz k x l r) =+ Bin sz (f k) x (mapKeysMonotonic f l) (mapKeysMonotonic f r)++{--------------------------------------------------------------------+ Folds +--------------------------------------------------------------------}++-- | /O(n)/. Fold the values in the map, such that+-- @'fold' f z == 'Prelude.foldr' f z . 'elems'@.+-- For example,+--+-- > elems map = fold (:) [] map+--+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 keys and values in the map, such that+-- @'foldWithKey' f z == 'Prelude.foldr' ('uncurry' f) z . 'toAscList'@.+-- For example,+--+-- > keys map = foldWithKey (\k x ks -> k:ks) [] map+--+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 in the ascending order of their keys.+elems :: Map k a -> [a]+elems m+ = [x | (k,x) <- assocs m]++-- | /O(n)/. Return all keys of the map in ascending order.+keys :: Map k a -> [k]+keys m+ = [k | (k,x) <- assocs m]++-- | /O(n)/. The set of all keys of the map.+keysSet :: Map k a -> Set.Set k+keysSet m = Set.fromDistinctAscList (keys m)++-- | /O(n)/. Return all key\/value pairs in the map in ascending key order.+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.+-- /The precondition (input list is ascending) is not checked./+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.+-- /The precondition (input list is ascending) is not checked./+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.+-- /The precondition (input list is ascending) is not checked./+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.+-- /The precondition is not checked./+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 (singleton k1 x1) (singleton k3 x3)) (singleton 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 (k,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 -> (lookupAssoc lo t, t)+ le -> trimLookupLo lo cmphi l+ GT -> trimLookupLo lo cmphi r+ EQ -> (Just (kx,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@. Any key equal to @k@ is found in neither @map1@ nor @map2@.+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 -> (Map k a,Maybe a,Map k a)+splitLookup k Tip = (Tip,Nothing,Tip)+splitLookup k (Bin sx kx x l r)+ = case compare k kx of+ LT -> let (lt,z,gt) = splitLookup k l in (lt,z,join kx x gt r)+ GT -> let (lt,z,gt) = splitLookup k r in (join kx x l lt,z,gt)+ EQ -> (l,Just x,r)++-- | /O(log n)/.+splitLookupWithKey :: Ord k => k -> Map k a -> (Map k a,Maybe (k,a),Map k a)+splitLookupWithKey k Tip = (Tip,Nothing,Tip)+splitLookupWithKey k (Bin sx kx x l r)+ = case compare k kx of+ LT -> let (lt,z,gt) = splitLookupWithKey k l in (lt,z,join kx x gt r)+ GT -> let (lt,z,gt) = splitLookupWithKey k r in (join kx x l lt,z,gt)+ EQ -> (l,Just (kx, x),r)++-- | /O(log n)/. Performs a 'split' but also returns whether the pivot+-- element was found in the original set.+splitMember :: Ord k => k -> Map k a -> (Map k a,Bool,Map k a)+splitMember x t = let (l,m,r) = splitLookup x t in+ (l,maybe False (const True) m,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 -> singleton kx x+ Bin sz ky y l r+ -> balance ky y l (insertMax kx x r)+ +insertMin kx x t+ = case t of+ Tip -> singleton 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 automatic 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)++{--------------------------------------------------------------------+ Ord +--------------------------------------------------------------------}++instance (Ord k, Ord v) => Ord (Map k v) where+ compare m1 m2 = compare (toAscList m1) (toAscList m2)++{--------------------------------------------------------------------+ Functor+--------------------------------------------------------------------}+instance Functor (Map k) where+ fmap f m = map f m++instance Traversable (Map k) where+ traverse f Tip = pure Tip+ traverse f (Bin s k v l r)+ = flip (Bin s k) <$> traverse f l <*> f v <*> traverse f r++instance Foldable (Map k) where+ foldMap _f Tip = mempty+ foldMap f (Bin _s _k v l r)+ = foldMap f l `mappend` f v `mappend` foldMap f r++{--------------------------------------------------------------------+ Read+--------------------------------------------------------------------}+instance (Ord k, Read k, Read e) => Read (Map k e) where+#ifdef __GLASGOW_HASKELL__+ readPrec = parens $ prec 10 $ do+ Ident "fromList" <- lexP+ xs <- readPrec+ return (fromList xs)++ readListPrec = readListPrecDefault+#else+ readsPrec p = readParen (p > 10) $ \ r -> do+ ("fromList",s) <- lex r+ (xs,t) <- reads s+ return (fromList xs,t)+#endif++-- parses a pair of things with the syntax a:=b+readPair :: (Read a, Read b) => ReadS (a,b)+readPair s = do (a, ct1) <- reads s+ (":=", ct2) <- lex ct1+ (b, ct3) <- reads ct2+ return ((a,b), ct3)++{--------------------------------------------------------------------+ Show+--------------------------------------------------------------------}+instance (Show k, Show a) => Show (Map k a) where+ showsPrec d m = showParen (d > 10) $+ showString "fromList " . shows (toList 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) = showString ", " . 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> let t = fromDistinctAscList [(x,()) | x <- [1..5]]+> Map> putStrLn $ showTreeWith (\k x -> show (k,x)) True False t+> (4,())+> +--(2,())+> | +--(1,())+> | +--(3,())+> +--(5,())+>+> Map> putStrLn $ showTreeWith (\k x -> show (k,x)) True True t+> (4,())+> |+> +--(2,())+> | |+> | +--(1,())+> | |+> | +--(3,())+> |+> +--(5,())+>+> Map> putStrLn $ showTreeWith (\k x -> show (k,x)) False True t+> +--(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++{--------------------------------------------------------------------+ Typeable+--------------------------------------------------------------------}++#include "Typeable.h"+INSTANCE_TYPEABLE2(Map,mapTc,"Map")++{--------------------------------------------------------------------+ 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 == singleton 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 (singleton 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])])+-}
+ Data/Sequence.hs view
@@ -0,0 +1,1124 @@+{-# OPTIONS -cpp -fglasgow-exts #-}+-----------------------------------------------------------------------------+-- |+-- Module : Data.Sequence+-- Copyright : (c) Ross Paterson 2005+-- License : BSD-style+-- Maintainer : ross@soi.city.ac.uk+-- Stability : experimental+-- Portability : portable+--+-- General purpose finite sequences.+-- Apart from being finite and having strict operations, sequences+-- also differ from lists in supporting a wider variety of operations+-- efficiently.+--+-- An amortized running time is given for each operation, with /n/ referring+-- to the length of the sequence and /i/ being the integral index used by+-- some operations. These bounds hold even in a persistent (shared) setting.+--+-- The implementation uses 2-3 finger trees annotated with sizes,+-- as described in section 4.2 of+--+-- * Ralf Hinze and Ross Paterson,+-- \"Finger trees: a simple general-purpose data structure\",+-- /Journal of Functional Programming/ 16:2 (2006) pp 197-217.+-- <http://www.soi.city.ac.uk/~ross/papers/FingerTree.html>+--+-- /Note/: Many of these operations have the same names as similar+-- operations on lists in the "Prelude". The ambiguity may be resolved+-- using either qualification or the @hiding@ clause.+--+-----------------------------------------------------------------------------++module Data.Sequence (+ Seq,+ -- * Construction+ empty, -- :: Seq a+ singleton, -- :: a -> Seq a+ (<|), -- :: a -> Seq a -> Seq a+ (|>), -- :: Seq a -> a -> Seq a+ (><), -- :: Seq a -> Seq a -> Seq a+ fromList, -- :: [a] -> Seq a+ -- * Deconstruction+ -- | Additional functions for deconstructing sequences are available+ -- via the 'Foldable' instance of 'Seq'.++ -- ** Queries+ null, -- :: Seq a -> Bool+ length, -- :: Seq a -> Int+ -- ** Views+ ViewL(..),+ viewl, -- :: Seq a -> ViewL a+ ViewR(..),+ viewr, -- :: Seq a -> ViewR a+ -- ** Indexing+ index, -- :: Seq a -> Int -> a+ adjust, -- :: (a -> a) -> Int -> Seq a -> Seq a+ update, -- :: Int -> a -> Seq a -> Seq a+ take, -- :: Int -> Seq a -> Seq a+ drop, -- :: Int -> Seq a -> Seq a+ splitAt, -- :: Int -> Seq a -> (Seq a, Seq a)+ -- * Transformations+ reverse, -- :: Seq a -> Seq a+#if TESTING+ valid,+#endif+ ) where++import Prelude hiding (+ null, length, take, drop, splitAt, foldl, foldl1, foldr, foldr1,+ reverse)+import qualified Data.List (foldl')+import Control.Applicative (Applicative(..), (<$>))+import Control.Monad (MonadPlus(..))+import Data.Monoid (Monoid(..))+import Data.Foldable+import Data.Traversable+import Data.Typeable++#ifdef __GLASGOW_HASKELL__+import Text.Read (Lexeme(Ident), lexP, parens, prec,+ readPrec, readListPrec, readListPrecDefault)+import Data.Generics.Basics (Data(..), Fixity(..),+ constrIndex, mkConstr, mkDataType)+#endif++#if TESTING+import Control.Monad (liftM, liftM3, liftM4)+import Test.QuickCheck+#endif++infixr 5 `consTree`+infixl 5 `snocTree`++infixr 5 ><+infixr 5 <|, :<+infixl 5 |>, :>++class Sized a where+ size :: a -> Int++-- | General-purpose finite sequences.+newtype Seq a = Seq (FingerTree (Elem a))++instance Functor Seq where+ fmap f (Seq xs) = Seq (fmap (fmap f) xs)++instance Foldable Seq where+ foldr f z (Seq xs) = foldr (flip (foldr f)) z xs+ foldl f z (Seq xs) = foldl (foldl f) z xs++ foldr1 f (Seq xs) = getElem (foldr1 f' xs)+ where f' (Elem x) (Elem y) = Elem (f x y)++ foldl1 f (Seq xs) = getElem (foldl1 f' xs)+ where f' (Elem x) (Elem y) = Elem (f x y)++instance Traversable Seq where+ traverse f (Seq xs) = Seq <$> traverse (traverse f) xs++instance Monad Seq where+ return = singleton+ xs >>= f = foldl' add empty xs+ where add ys x = ys >< f x++instance MonadPlus Seq where+ mzero = empty+ mplus = (><)++instance Eq a => Eq (Seq a) where+ xs == ys = length xs == length ys && toList xs == toList ys++instance Ord a => Ord (Seq a) where+ compare xs ys = compare (toList xs) (toList ys)++#if TESTING+instance Show a => Show (Seq a) where+ showsPrec p (Seq x) = showsPrec p x+#else+instance Show a => Show (Seq a) where+ showsPrec p xs = showParen (p > 10) $+ showString "fromList " . shows (toList xs)+#endif++instance Read a => Read (Seq a) where+#ifdef __GLASGOW_HASKELL__+ readPrec = parens $ prec 10 $ do+ Ident "fromList" <- lexP+ xs <- readPrec+ return (fromList xs)++ readListPrec = readListPrecDefault+#else+ readsPrec p = readParen (p > 10) $ \ r -> do+ ("fromList",s) <- lex r+ (xs,t) <- reads s+ return (fromList xs,t)+#endif++instance Monoid (Seq a) where+ mempty = empty+ mappend = (><)++#include "Typeable.h"+INSTANCE_TYPEABLE1(Seq,seqTc,"Seq")++#if __GLASGOW_HASKELL__+instance Data a => Data (Seq a) where+ gfoldl f z s = case viewl s of+ EmptyL -> z empty+ x :< xs -> z (<|) `f` x `f` xs++ gunfold k z c = case constrIndex c of+ 1 -> z empty+ 2 -> k (k (z (<|)))+ _ -> error "gunfold"++ toConstr xs+ | null xs = emptyConstr+ | otherwise = consConstr++ dataTypeOf _ = seqDataType++ dataCast1 f = gcast1 f++emptyConstr = mkConstr seqDataType "empty" [] Prefix+consConstr = mkConstr seqDataType "<|" [] Infix+seqDataType = mkDataType "Data.Sequence.Seq" [emptyConstr, consConstr]+#endif++-- Finger trees++data FingerTree a+ = Empty+ | Single a+ | Deep {-# UNPACK #-} !Int !(Digit a) (FingerTree (Node a)) !(Digit a)+#if TESTING+ deriving Show+#endif++instance Sized a => Sized (FingerTree a) where+ {-# SPECIALIZE instance Sized (FingerTree (Elem a)) #-}+ {-# SPECIALIZE instance Sized (FingerTree (Node a)) #-}+ size Empty = 0+ size (Single x) = size x+ size (Deep v _ _ _) = v++instance Foldable FingerTree where+ foldr _ z Empty = z+ foldr f z (Single x) = x `f` z+ foldr f z (Deep _ pr m sf) =+ foldr f (foldr (flip (foldr f)) (foldr f z sf) m) pr++ foldl _ z Empty = z+ foldl f z (Single x) = z `f` x+ foldl f z (Deep _ pr m sf) =+ foldl f (foldl (foldl f) (foldl f z pr) m) sf++ foldr1 _ Empty = error "foldr1: empty sequence"+ foldr1 _ (Single x) = x+ foldr1 f (Deep _ pr m sf) =+ foldr f (foldr (flip (foldr f)) (foldr1 f sf) m) pr++ foldl1 _ Empty = error "foldl1: empty sequence"+ foldl1 _ (Single x) = x+ foldl1 f (Deep _ pr m sf) =+ foldl f (foldl (foldl f) (foldl1 f pr) m) sf++instance Functor FingerTree where+ fmap _ Empty = Empty+ fmap f (Single x) = Single (f x)+ fmap f (Deep v pr m sf) =+ Deep v (fmap f pr) (fmap (fmap f) m) (fmap f sf)++instance Traversable FingerTree where+ traverse _ Empty = pure Empty+ traverse f (Single x) = Single <$> f x+ traverse f (Deep v pr m sf) =+ Deep v <$> traverse f pr <*> traverse (traverse f) m <*>+ traverse f sf++{-# INLINE deep #-}+{-# SPECIALIZE deep :: Digit (Elem a) -> FingerTree (Node (Elem a)) -> Digit (Elem a) -> FingerTree (Elem a) #-}+{-# SPECIALIZE deep :: Digit (Node a) -> FingerTree (Node (Node a)) -> Digit (Node a) -> FingerTree (Node a) #-}+deep :: Sized a => Digit a -> FingerTree (Node a) -> Digit a -> FingerTree a+deep pr m sf = Deep (size pr + size m + size sf) pr m sf++-- Digits++data Digit a+ = One a+ | Two a a+ | Three a a a+ | Four a a a a+#if TESTING+ deriving Show+#endif++instance Foldable Digit where+ foldr f z (One a) = a `f` z+ foldr f z (Two a b) = a `f` (b `f` z)+ foldr f z (Three a b c) = a `f` (b `f` (c `f` z))+ foldr f z (Four a b c d) = a `f` (b `f` (c `f` (d `f` z)))++ foldl f z (One a) = z `f` a+ foldl f z (Two a b) = (z `f` a) `f` b+ foldl f z (Three a b c) = ((z `f` a) `f` b) `f` c+ foldl f z (Four a b c d) = (((z `f` a) `f` b) `f` c) `f` d++ foldr1 f (One a) = a+ foldr1 f (Two a b) = a `f` b+ foldr1 f (Three a b c) = a `f` (b `f` c)+ foldr1 f (Four a b c d) = a `f` (b `f` (c `f` d))++ foldl1 f (One a) = a+ foldl1 f (Two a b) = a `f` b+ foldl1 f (Three a b c) = (a `f` b) `f` c+ foldl1 f (Four a b c d) = ((a `f` b) `f` c) `f` d++instance Functor Digit where+ fmap = fmapDefault++instance Traversable Digit where+ traverse f (One a) = One <$> f a+ traverse f (Two a b) = Two <$> f a <*> f b+ traverse f (Three a b c) = Three <$> f a <*> f b <*> f c+ traverse f (Four a b c d) = Four <$> f a <*> f b <*> f c <*> f d++instance Sized a => Sized (Digit a) where+ {-# SPECIALIZE instance Sized (Digit (Elem a)) #-}+ {-# SPECIALIZE instance Sized (Digit (Node a)) #-}+ size xs = foldl (\ i x -> i + size x) 0 xs++{-# SPECIALIZE digitToTree :: Digit (Elem a) -> FingerTree (Elem a) #-}+{-# SPECIALIZE digitToTree :: Digit (Node a) -> FingerTree (Node a) #-}+digitToTree :: Sized a => Digit a -> FingerTree a+digitToTree (One a) = Single a+digitToTree (Two a b) = deep (One a) Empty (One b)+digitToTree (Three a b c) = deep (Two a b) Empty (One c)+digitToTree (Four a b c d) = deep (Two a b) Empty (Two c d)++-- Nodes++data Node a+ = Node2 {-# UNPACK #-} !Int a a+ | Node3 {-# UNPACK #-} !Int a a a+#if TESTING+ deriving Show+#endif++instance Foldable Node where+ foldr f z (Node2 _ a b) = a `f` (b `f` z)+ foldr f z (Node3 _ a b c) = a `f` (b `f` (c `f` z))++ foldl f z (Node2 _ a b) = (z `f` a) `f` b+ foldl f z (Node3 _ a b c) = ((z `f` a) `f` b) `f` c++instance Functor Node where+ fmap = fmapDefault++instance Traversable Node where+ traverse f (Node2 v a b) = Node2 v <$> f a <*> f b+ traverse f (Node3 v a b c) = Node3 v <$> f a <*> f b <*> f c++instance Sized (Node a) where+ size (Node2 v _ _) = v+ size (Node3 v _ _ _) = v++{-# INLINE node2 #-}+{-# SPECIALIZE node2 :: Elem a -> Elem a -> Node (Elem a) #-}+{-# SPECIALIZE node2 :: Node a -> Node a -> Node (Node a) #-}+node2 :: Sized a => a -> a -> Node a+node2 a b = Node2 (size a + size b) a b++{-# INLINE node3 #-}+{-# SPECIALIZE node3 :: Elem a -> Elem a -> Elem a -> Node (Elem a) #-}+{-# SPECIALIZE node3 :: Node a -> Node a -> Node a -> Node (Node a) #-}+node3 :: Sized a => a -> a -> a -> Node a+node3 a b c = Node3 (size a + size b + size c) a b c++nodeToDigit :: Node a -> Digit a+nodeToDigit (Node2 _ a b) = Two a b+nodeToDigit (Node3 _ a b c) = Three a b c++-- Elements++newtype Elem a = Elem { getElem :: a }++instance Sized (Elem a) where+ size _ = 1++instance Functor Elem where+ fmap f (Elem x) = Elem (f x)++instance Foldable Elem where+ foldr f z (Elem x) = f x z+ foldl f z (Elem x) = f z x++instance Traversable Elem where+ traverse f (Elem x) = Elem <$> f x++#ifdef TESTING+instance (Show a) => Show (Elem a) where+ showsPrec p (Elem x) = showsPrec p x+#endif++------------------------------------------------------------------------+-- Construction+------------------------------------------------------------------------++-- | /O(1)/. The empty sequence.+empty :: Seq a+empty = Seq Empty++-- | /O(1)/. A singleton sequence.+singleton :: a -> Seq a+singleton x = Seq (Single (Elem x))++-- | /O(1)/. Add an element to the left end of a sequence.+-- Mnemonic: a triangle with the single element at the pointy end.+(<|) :: a -> Seq a -> Seq a+x <| Seq xs = Seq (Elem x `consTree` xs)++{-# SPECIALIZE consTree :: Elem a -> FingerTree (Elem a) -> FingerTree (Elem a) #-}+{-# SPECIALIZE consTree :: Node a -> FingerTree (Node a) -> FingerTree (Node a) #-}+consTree :: Sized a => a -> FingerTree a -> FingerTree a+consTree a Empty = Single a+consTree a (Single b) = deep (One a) Empty (One b)+consTree a (Deep s (Four b c d e) m sf) = m `seq`+ Deep (size a + s) (Two a b) (node3 c d e `consTree` m) sf+consTree a (Deep s (Three b c d) m sf) =+ Deep (size a + s) (Four a b c d) m sf+consTree a (Deep s (Two b c) m sf) =+ Deep (size a + s) (Three a b c) m sf+consTree a (Deep s (One b) m sf) =+ Deep (size a + s) (Two a b) m sf++-- | /O(1)/. Add an element to the right end of a sequence.+-- Mnemonic: a triangle with the single element at the pointy end.+(|>) :: Seq a -> a -> Seq a+Seq xs |> x = Seq (xs `snocTree` Elem x)++{-# SPECIALIZE snocTree :: FingerTree (Elem a) -> Elem a -> FingerTree (Elem a) #-}+{-# SPECIALIZE snocTree :: FingerTree (Node a) -> Node a -> FingerTree (Node a) #-}+snocTree :: Sized a => FingerTree a -> a -> FingerTree a+snocTree Empty a = Single a+snocTree (Single a) b = deep (One a) Empty (One b)+snocTree (Deep s pr m (Four a b c d)) e = m `seq`+ Deep (s + size e) pr (m `snocTree` node3 a b c) (Two d e)+snocTree (Deep s pr m (Three a b c)) d =+ Deep (s + size d) pr m (Four a b c d)+snocTree (Deep s pr m (Two a b)) c =+ Deep (s + size c) pr m (Three a b c)+snocTree (Deep s pr m (One a)) b =+ Deep (s + size b) pr m (Two a b)++-- | /O(log(min(n1,n2)))/. Concatenate two sequences.+(><) :: Seq a -> Seq a -> Seq a+Seq xs >< Seq ys = Seq (appendTree0 xs ys)++-- The appendTree/addDigits gunk below is machine generated++appendTree0 :: FingerTree (Elem a) -> FingerTree (Elem a) -> FingerTree (Elem a)+appendTree0 Empty xs =+ xs+appendTree0 xs Empty =+ xs+appendTree0 (Single x) xs =+ x `consTree` xs+appendTree0 xs (Single x) =+ xs `snocTree` x+appendTree0 (Deep s1 pr1 m1 sf1) (Deep s2 pr2 m2 sf2) =+ Deep (s1 + s2) pr1 (addDigits0 m1 sf1 pr2 m2) sf2++addDigits0 :: FingerTree (Node (Elem a)) -> Digit (Elem a) -> Digit (Elem a) -> FingerTree (Node (Elem a)) -> FingerTree (Node (Elem a))+addDigits0 m1 (One a) (One b) m2 =+ appendTree1 m1 (node2 a b) m2+addDigits0 m1 (One a) (Two b c) m2 =+ appendTree1 m1 (node3 a b c) m2+addDigits0 m1 (One a) (Three b c d) m2 =+ appendTree2 m1 (node2 a b) (node2 c d) m2+addDigits0 m1 (One a) (Four b c d e) m2 =+ appendTree2 m1 (node3 a b c) (node2 d e) m2+addDigits0 m1 (Two a b) (One c) m2 =+ appendTree1 m1 (node3 a b c) m2+addDigits0 m1 (Two a b) (Two c d) m2 =+ appendTree2 m1 (node2 a b) (node2 c d) m2+addDigits0 m1 (Two a b) (Three c d e) m2 =+ appendTree2 m1 (node3 a b c) (node2 d e) m2+addDigits0 m1 (Two a b) (Four c d e f) m2 =+ appendTree2 m1 (node3 a b c) (node3 d e f) m2+addDigits0 m1 (Three a b c) (One d) m2 =+ appendTree2 m1 (node2 a b) (node2 c d) m2+addDigits0 m1 (Three a b c) (Two d e) m2 =+ appendTree2 m1 (node3 a b c) (node2 d e) m2+addDigits0 m1 (Three a b c) (Three d e f) m2 =+ appendTree2 m1 (node3 a b c) (node3 d e f) m2+addDigits0 m1 (Three a b c) (Four d e f g) m2 =+ appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2+addDigits0 m1 (Four a b c d) (One e) m2 =+ appendTree2 m1 (node3 a b c) (node2 d e) m2+addDigits0 m1 (Four a b c d) (Two e f) m2 =+ appendTree2 m1 (node3 a b c) (node3 d e f) m2+addDigits0 m1 (Four a b c d) (Three e f g) m2 =+ appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2+addDigits0 m1 (Four a b c d) (Four e f g h) m2 =+ appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2++appendTree1 :: FingerTree (Node a) -> Node a -> FingerTree (Node a) -> FingerTree (Node a)+appendTree1 Empty a xs =+ a `consTree` xs+appendTree1 xs a Empty =+ xs `snocTree` a+appendTree1 (Single x) a xs =+ x `consTree` a `consTree` xs+appendTree1 xs a (Single x) =+ xs `snocTree` a `snocTree` x+appendTree1 (Deep s1 pr1 m1 sf1) a (Deep s2 pr2 m2 sf2) =+ Deep (s1 + size a + s2) pr1 (addDigits1 m1 sf1 a pr2 m2) sf2++addDigits1 :: FingerTree (Node (Node a)) -> Digit (Node a) -> Node a -> Digit (Node a) -> FingerTree (Node (Node a)) -> FingerTree (Node (Node a))+addDigits1 m1 (One a) b (One c) m2 =+ appendTree1 m1 (node3 a b c) m2+addDigits1 m1 (One a) b (Two c d) m2 =+ appendTree2 m1 (node2 a b) (node2 c d) m2+addDigits1 m1 (One a) b (Three c d e) m2 =+ appendTree2 m1 (node3 a b c) (node2 d e) m2+addDigits1 m1 (One a) b (Four c d e f) m2 =+ appendTree2 m1 (node3 a b c) (node3 d e f) m2+addDigits1 m1 (Two a b) c (One d) m2 =+ appendTree2 m1 (node2 a b) (node2 c d) m2+addDigits1 m1 (Two a b) c (Two d e) m2 =+ appendTree2 m1 (node3 a b c) (node2 d e) m2+addDigits1 m1 (Two a b) c (Three d e f) m2 =+ appendTree2 m1 (node3 a b c) (node3 d e f) m2+addDigits1 m1 (Two a b) c (Four d e f g) m2 =+ appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2+addDigits1 m1 (Three a b c) d (One e) m2 =+ appendTree2 m1 (node3 a b c) (node2 d e) m2+addDigits1 m1 (Three a b c) d (Two e f) m2 =+ appendTree2 m1 (node3 a b c) (node3 d e f) m2+addDigits1 m1 (Three a b c) d (Three e f g) m2 =+ appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2+addDigits1 m1 (Three a b c) d (Four e f g h) m2 =+ appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2+addDigits1 m1 (Four a b c d) e (One f) m2 =+ appendTree2 m1 (node3 a b c) (node3 d e f) m2+addDigits1 m1 (Four a b c d) e (Two f g) m2 =+ appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2+addDigits1 m1 (Four a b c d) e (Three f g h) m2 =+ appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2+addDigits1 m1 (Four a b c d) e (Four f g h i) m2 =+ appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2++appendTree2 :: FingerTree (Node a) -> Node a -> Node a -> FingerTree (Node a) -> FingerTree (Node a)+appendTree2 Empty a b xs =+ a `consTree` b `consTree` xs+appendTree2 xs a b Empty =+ xs `snocTree` a `snocTree` b+appendTree2 (Single x) a b xs =+ x `consTree` a `consTree` b `consTree` xs+appendTree2 xs a b (Single x) =+ xs `snocTree` a `snocTree` b `snocTree` x+appendTree2 (Deep s1 pr1 m1 sf1) a b (Deep s2 pr2 m2 sf2) =+ Deep (s1 + size a + size b + s2) pr1 (addDigits2 m1 sf1 a b pr2 m2) sf2++addDigits2 :: FingerTree (Node (Node a)) -> Digit (Node a) -> Node a -> Node a -> Digit (Node a) -> FingerTree (Node (Node a)) -> FingerTree (Node (Node a))+addDigits2 m1 (One a) b c (One d) m2 =+ appendTree2 m1 (node2 a b) (node2 c d) m2+addDigits2 m1 (One a) b c (Two d e) m2 =+ appendTree2 m1 (node3 a b c) (node2 d e) m2+addDigits2 m1 (One a) b c (Three d e f) m2 =+ appendTree2 m1 (node3 a b c) (node3 d e f) m2+addDigits2 m1 (One a) b c (Four d e f g) m2 =+ appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2+addDigits2 m1 (Two a b) c d (One e) m2 =+ appendTree2 m1 (node3 a b c) (node2 d e) m2+addDigits2 m1 (Two a b) c d (Two e f) m2 =+ appendTree2 m1 (node3 a b c) (node3 d e f) m2+addDigits2 m1 (Two a b) c d (Three e f g) m2 =+ appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2+addDigits2 m1 (Two a b) c d (Four e f g h) m2 =+ appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2+addDigits2 m1 (Three a b c) d e (One f) m2 =+ appendTree2 m1 (node3 a b c) (node3 d e f) m2+addDigits2 m1 (Three a b c) d e (Two f g) m2 =+ appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2+addDigits2 m1 (Three a b c) d e (Three f g h) m2 =+ appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2+addDigits2 m1 (Three a b c) d e (Four f g h i) m2 =+ appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2+addDigits2 m1 (Four a b c d) e f (One g) m2 =+ appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2+addDigits2 m1 (Four a b c d) e f (Two g h) m2 =+ appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2+addDigits2 m1 (Four a b c d) e f (Three g h i) m2 =+ appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2+addDigits2 m1 (Four a b c d) e f (Four g h i j) m2 =+ appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2++appendTree3 :: FingerTree (Node a) -> Node a -> Node a -> Node a -> FingerTree (Node a) -> FingerTree (Node a)+appendTree3 Empty a b c xs =+ a `consTree` b `consTree` c `consTree` xs+appendTree3 xs a b c Empty =+ xs `snocTree` a `snocTree` b `snocTree` c+appendTree3 (Single x) a b c xs =+ x `consTree` a `consTree` b `consTree` c `consTree` xs+appendTree3 xs a b c (Single x) =+ xs `snocTree` a `snocTree` b `snocTree` c `snocTree` x+appendTree3 (Deep s1 pr1 m1 sf1) a b c (Deep s2 pr2 m2 sf2) =+ Deep (s1 + size a + size b + size c + s2) pr1 (addDigits3 m1 sf1 a b c pr2 m2) sf2++addDigits3 :: FingerTree (Node (Node a)) -> Digit (Node a) -> Node a -> Node a -> Node a -> Digit (Node a) -> FingerTree (Node (Node a)) -> FingerTree (Node (Node a))+addDigits3 m1 (One a) b c d (One e) m2 =+ appendTree2 m1 (node3 a b c) (node2 d e) m2+addDigits3 m1 (One a) b c d (Two e f) m2 =+ appendTree2 m1 (node3 a b c) (node3 d e f) m2+addDigits3 m1 (One a) b c d (Three e f g) m2 =+ appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2+addDigits3 m1 (One a) b c d (Four e f g h) m2 =+ appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2+addDigits3 m1 (Two a b) c d e (One f) m2 =+ appendTree2 m1 (node3 a b c) (node3 d e f) m2+addDigits3 m1 (Two a b) c d e (Two f g) m2 =+ appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2+addDigits3 m1 (Two a b) c d e (Three f g h) m2 =+ appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2+addDigits3 m1 (Two a b) c d e (Four f g h i) m2 =+ appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2+addDigits3 m1 (Three a b c) d e f (One g) m2 =+ appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2+addDigits3 m1 (Three a b c) d e f (Two g h) m2 =+ appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2+addDigits3 m1 (Three a b c) d e f (Three g h i) m2 =+ appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2+addDigits3 m1 (Three a b c) d e f (Four g h i j) m2 =+ appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2+addDigits3 m1 (Four a b c d) e f g (One h) m2 =+ appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2+addDigits3 m1 (Four a b c d) e f g (Two h i) m2 =+ appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2+addDigits3 m1 (Four a b c d) e f g (Three h i j) m2 =+ appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2+addDigits3 m1 (Four a b c d) e f g (Four h i j k) m2 =+ appendTree4 m1 (node3 a b c) (node3 d e f) (node3 g h i) (node2 j k) m2++appendTree4 :: FingerTree (Node a) -> Node a -> Node a -> Node a -> Node a -> FingerTree (Node a) -> FingerTree (Node a)+appendTree4 Empty a b c d xs =+ a `consTree` b `consTree` c `consTree` d `consTree` xs+appendTree4 xs a b c d Empty =+ xs `snocTree` a `snocTree` b `snocTree` c `snocTree` d+appendTree4 (Single x) a b c d xs =+ x `consTree` a `consTree` b `consTree` c `consTree` d `consTree` xs+appendTree4 xs a b c d (Single x) =+ xs `snocTree` a `snocTree` b `snocTree` c `snocTree` d `snocTree` x+appendTree4 (Deep s1 pr1 m1 sf1) a b c d (Deep s2 pr2 m2 sf2) =+ Deep (s1 + size a + size b + size c + size d + s2) pr1 (addDigits4 m1 sf1 a b c d pr2 m2) sf2++addDigits4 :: FingerTree (Node (Node a)) -> Digit (Node a) -> Node a -> Node a -> Node a -> Node a -> Digit (Node a) -> FingerTree (Node (Node a)) -> FingerTree (Node (Node a))+addDigits4 m1 (One a) b c d e (One f) m2 =+ appendTree2 m1 (node3 a b c) (node3 d e f) m2+addDigits4 m1 (One a) b c d e (Two f g) m2 =+ appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2+addDigits4 m1 (One a) b c d e (Three f g h) m2 =+ appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2+addDigits4 m1 (One a) b c d e (Four f g h i) m2 =+ appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2+addDigits4 m1 (Two a b) c d e f (One g) m2 =+ appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2+addDigits4 m1 (Two a b) c d e f (Two g h) m2 =+ appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2+addDigits4 m1 (Two a b) c d e f (Three g h i) m2 =+ appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2+addDigits4 m1 (Two a b) c d e f (Four g h i j) m2 =+ appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2+addDigits4 m1 (Three a b c) d e f g (One h) m2 =+ appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2+addDigits4 m1 (Three a b c) d e f g (Two h i) m2 =+ appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2+addDigits4 m1 (Three a b c) d e f g (Three h i j) m2 =+ appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2+addDigits4 m1 (Three a b c) d e f g (Four h i j k) m2 =+ appendTree4 m1 (node3 a b c) (node3 d e f) (node3 g h i) (node2 j k) m2+addDigits4 m1 (Four a b c d) e f g h (One i) m2 =+ appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2+addDigits4 m1 (Four a b c d) e f g h (Two i j) m2 =+ appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2+addDigits4 m1 (Four a b c d) e f g h (Three i j k) m2 =+ appendTree4 m1 (node3 a b c) (node3 d e f) (node3 g h i) (node2 j k) m2+addDigits4 m1 (Four a b c d) e f g h (Four i j k l) m2 =+ appendTree4 m1 (node3 a b c) (node3 d e f) (node3 g h i) (node3 j k l) m2++------------------------------------------------------------------------+-- Deconstruction+------------------------------------------------------------------------++-- | /O(1)/. Is this the empty sequence?+null :: Seq a -> Bool+null (Seq Empty) = True+null _ = False++-- | /O(1)/. The number of elements in the sequence.+length :: Seq a -> Int+length (Seq xs) = size xs++-- Views++data Maybe2 a b = Nothing2 | Just2 a b++-- | View of the left end of a sequence.+data ViewL a+ = EmptyL -- ^ empty sequence+ | a :< Seq a -- ^ leftmost element and the rest of the sequence+#ifndef __HADDOCK__+# if __GLASGOW_HASKELL__+ deriving (Eq, Ord, Show, Read, Data)+# else+ deriving (Eq, Ord, Show, Read)+# endif+#else+instance Eq a => Eq (ViewL a)+instance Ord a => Ord (ViewL a)+instance Show a => Show (ViewL a)+instance Read a => Read (ViewL a)+instance Data a => Data (ViewL a)+#endif++INSTANCE_TYPEABLE1(ViewL,viewLTc,"ViewL")++instance Functor ViewL where+ fmap = fmapDefault++instance Foldable ViewL where+ foldr f z EmptyL = z+ foldr f z (x :< xs) = f x (foldr f z xs)++ foldl f z EmptyL = z+ foldl f z (x :< xs) = foldl f (f z x) xs++ foldl1 f EmptyL = error "foldl1: empty view"+ foldl1 f (x :< xs) = foldl f x xs++instance Traversable ViewL where+ traverse _ EmptyL = pure EmptyL+ traverse f (x :< xs) = (:<) <$> f x <*> traverse f xs++-- | /O(1)/. Analyse the left end of a sequence.+viewl :: Seq a -> ViewL a+viewl (Seq xs) = case viewLTree xs of+ Nothing2 -> EmptyL+ Just2 (Elem x) xs' -> x :< Seq xs'++{-# SPECIALIZE viewLTree :: FingerTree (Elem a) -> Maybe2 (Elem a) (FingerTree (Elem a)) #-}+{-# SPECIALIZE viewLTree :: FingerTree (Node a) -> Maybe2 (Node a) (FingerTree (Node a)) #-}+viewLTree :: Sized a => FingerTree a -> Maybe2 a (FingerTree a)+viewLTree Empty = Nothing2+viewLTree (Single a) = Just2 a Empty+viewLTree (Deep s (One a) m sf) = Just2 a (case viewLTree m of+ Nothing2 -> digitToTree sf+ Just2 b m' -> Deep (s - size a) (nodeToDigit b) m' sf)+viewLTree (Deep s (Two a b) m sf) =+ Just2 a (Deep (s - size a) (One b) m sf)+viewLTree (Deep s (Three a b c) m sf) =+ Just2 a (Deep (s - size a) (Two b c) m sf)+viewLTree (Deep s (Four a b c d) m sf) =+ Just2 a (Deep (s - size a) (Three b c d) m sf)++-- | View of the right end of a sequence.+data ViewR a+ = EmptyR -- ^ empty sequence+ | Seq a :> a -- ^ the sequence minus the rightmost element,+ -- and the rightmost element+#ifndef __HADDOCK__+# if __GLASGOW_HASKELL__+ deriving (Eq, Ord, Show, Read, Data)+# else+ deriving (Eq, Ord, Show, Read)+# endif+#else+instance Eq a => Eq (ViewR a)+instance Ord a => Ord (ViewR a)+instance Show a => Show (ViewR a)+instance Read a => Read (ViewR a)+instance Data a => Data (ViewR a)+#endif++INSTANCE_TYPEABLE1(ViewR,viewRTc,"ViewR")++instance Functor ViewR where+ fmap = fmapDefault++instance Foldable ViewR where+ foldr f z EmptyR = z+ foldr f z (xs :> x) = foldr f (f x z) xs++ foldl f z EmptyR = z+ foldl f z (xs :> x) = f (foldl f z xs) x++ foldr1 f EmptyR = error "foldr1: empty view"+ foldr1 f (xs :> x) = foldr f x xs++instance Traversable ViewR where+ traverse _ EmptyR = pure EmptyR+ traverse f (xs :> x) = (:>) <$> traverse f xs <*> f x++-- | /O(1)/. Analyse the right end of a sequence.+viewr :: Seq a -> ViewR a+viewr (Seq xs) = case viewRTree xs of+ Nothing2 -> EmptyR+ Just2 xs' (Elem x) -> Seq xs' :> x++{-# SPECIALIZE viewRTree :: FingerTree (Elem a) -> Maybe2 (FingerTree (Elem a)) (Elem a) #-}+{-# SPECIALIZE viewRTree :: FingerTree (Node a) -> Maybe2 (FingerTree (Node a)) (Node a) #-}+viewRTree :: Sized a => FingerTree a -> Maybe2 (FingerTree a) a+viewRTree Empty = Nothing2+viewRTree (Single z) = Just2 Empty z+viewRTree (Deep s pr m (One z)) = Just2 (case viewRTree m of+ Nothing2 -> digitToTree pr+ Just2 m' y -> Deep (s - size z) pr m' (nodeToDigit y)) z+viewRTree (Deep s pr m (Two y z)) =+ Just2 (Deep (s - size z) pr m (One y)) z+viewRTree (Deep s pr m (Three x y z)) =+ Just2 (Deep (s - size z) pr m (Two x y)) z+viewRTree (Deep s pr m (Four w x y z)) =+ Just2 (Deep (s - size z) pr m (Three w x y)) z++-- Indexing++-- | /O(log(min(i,n-i)))/. The element at the specified position+index :: Seq a -> Int -> a+index (Seq xs) i+ | 0 <= i && i < size xs = case lookupTree i xs of+ Place _ (Elem x) -> x+ | otherwise = error "index out of bounds"++data Place a = Place {-# UNPACK #-} !Int a+#if TESTING+ deriving Show+#endif++{-# SPECIALIZE lookupTree :: Int -> FingerTree (Elem a) -> Place (Elem a) #-}+{-# SPECIALIZE lookupTree :: Int -> FingerTree (Node a) -> Place (Node a) #-}+lookupTree :: Sized a => Int -> FingerTree a -> Place a+lookupTree _ Empty = error "lookupTree of empty tree"+lookupTree i (Single x) = Place i x+lookupTree i (Deep _ pr m sf)+ | i < spr = lookupDigit i pr+ | i < spm = case lookupTree (i - spr) m of+ Place i' xs -> lookupNode i' xs+ | otherwise = lookupDigit (i - spm) sf+ where spr = size pr+ spm = spr + size m++{-# SPECIALIZE lookupNode :: Int -> Node (Elem a) -> Place (Elem a) #-}+{-# SPECIALIZE lookupNode :: Int -> Node (Node a) -> Place (Node a) #-}+lookupNode :: Sized a => Int -> Node a -> Place a+lookupNode i (Node2 _ a b)+ | i < sa = Place i a+ | otherwise = Place (i - sa) b+ where sa = size a+lookupNode i (Node3 _ a b c)+ | i < sa = Place i a+ | i < sab = Place (i - sa) b+ | otherwise = Place (i - sab) c+ where sa = size a+ sab = sa + size b++{-# SPECIALIZE lookupDigit :: Int -> Digit (Elem a) -> Place (Elem a) #-}+{-# SPECIALIZE lookupDigit :: Int -> Digit (Node a) -> Place (Node a) #-}+lookupDigit :: Sized a => Int -> Digit a -> Place a+lookupDigit i (One a) = Place i a+lookupDigit i (Two a b)+ | i < sa = Place i a+ | otherwise = Place (i - sa) b+ where sa = size a+lookupDigit i (Three a b c)+ | i < sa = Place i a+ | i < sab = Place (i - sa) b+ | otherwise = Place (i - sab) c+ where sa = size a+ sab = sa + size b+lookupDigit i (Four a b c d)+ | i < sa = Place i a+ | i < sab = Place (i - sa) b+ | i < sabc = Place (i - sab) c+ | otherwise = Place (i - sabc) d+ where sa = size a+ sab = sa + size b+ sabc = sab + size c++-- | /O(log(min(i,n-i)))/. Replace the element at the specified position+update :: Int -> a -> Seq a -> Seq a+update i x = adjust (const x) i++-- | /O(log(min(i,n-i)))/. Update the element at the specified position+adjust :: (a -> a) -> Int -> Seq a -> Seq a+adjust f i (Seq xs)+ | 0 <= i && i < size xs = Seq (adjustTree (const (fmap f)) i xs)+ | otherwise = Seq xs++{-# SPECIALIZE adjustTree :: (Int -> Elem a -> Elem a) -> Int -> FingerTree (Elem a) -> FingerTree (Elem a) #-}+{-# SPECIALIZE adjustTree :: (Int -> Node a -> Node a) -> Int -> FingerTree (Node a) -> FingerTree (Node a) #-}+adjustTree :: Sized a => (Int -> a -> a) ->+ Int -> FingerTree a -> FingerTree a+adjustTree _ _ Empty = error "adjustTree of empty tree"+adjustTree f i (Single x) = Single (f i x)+adjustTree f i (Deep s pr m sf)+ | i < spr = Deep s (adjustDigit f i pr) m sf+ | i < spm = Deep s pr (adjustTree (adjustNode f) (i - spr) m) sf+ | otherwise = Deep s pr m (adjustDigit f (i - spm) sf)+ where spr = size pr+ spm = spr + size m++{-# SPECIALIZE adjustNode :: (Int -> Elem a -> Elem a) -> Int -> Node (Elem a) -> Node (Elem a) #-}+{-# SPECIALIZE adjustNode :: (Int -> Node a -> Node a) -> Int -> Node (Node a) -> Node (Node a) #-}+adjustNode :: Sized a => (Int -> a -> a) -> Int -> Node a -> Node a+adjustNode f i (Node2 s a b)+ | i < sa = Node2 s (f i a) b+ | otherwise = Node2 s a (f (i - sa) b)+ where sa = size a+adjustNode f i (Node3 s a b c)+ | i < sa = Node3 s (f i a) b c+ | i < sab = Node3 s a (f (i - sa) b) c+ | otherwise = Node3 s a b (f (i - sab) c)+ where sa = size a+ sab = sa + size b++{-# SPECIALIZE adjustDigit :: (Int -> Elem a -> Elem a) -> Int -> Digit (Elem a) -> Digit (Elem a) #-}+{-# SPECIALIZE adjustDigit :: (Int -> Node a -> Node a) -> Int -> Digit (Node a) -> Digit (Node a) #-}+adjustDigit :: Sized a => (Int -> a -> a) -> Int -> Digit a -> Digit a+adjustDigit f i (One a) = One (f i a)+adjustDigit f i (Two a b)+ | i < sa = Two (f i a) b+ | otherwise = Two a (f (i - sa) b)+ where sa = size a+adjustDigit f i (Three a b c)+ | i < sa = Three (f i a) b c+ | i < sab = Three a (f (i - sa) b) c+ | otherwise = Three a b (f (i - sab) c)+ where sa = size a+ sab = sa + size b+adjustDigit f i (Four a b c d)+ | i < sa = Four (f i a) b c d+ | i < sab = Four a (f (i - sa) b) c d+ | i < sabc = Four a b (f (i - sab) c) d+ | otherwise = Four a b c (f (i- sabc) d)+ where sa = size a+ sab = sa + size b+ sabc = sab + size c++-- Splitting++-- | /O(log(min(i,n-i)))/. The first @i@ elements of a sequence.+take :: Int -> Seq a -> Seq a+take i = fst . splitAt i++-- | /O(log(min(i,n-i)))/. Elements of a sequence after the first @i@.+drop :: Int -> Seq a -> Seq a+drop i = snd . splitAt i++-- | /O(log(min(i,n-i)))/. Split a sequence at a given position.+splitAt :: Int -> Seq a -> (Seq a, Seq a)+splitAt i (Seq xs) = (Seq l, Seq r)+ where (l, r) = split i xs++split :: Int -> FingerTree (Elem a) ->+ (FingerTree (Elem a), FingerTree (Elem a))+split i Empty = i `seq` (Empty, Empty)+split i xs+ | size xs > i = (l, consTree x r)+ | otherwise = (xs, Empty)+ where Split l x r = splitTree i xs++data Split t a = Split t a t+#if TESTING+ deriving Show+#endif++{-# SPECIALIZE splitTree :: Int -> FingerTree (Elem a) -> Split (FingerTree (Elem a)) (Elem a) #-}+{-# SPECIALIZE splitTree :: Int -> FingerTree (Node a) -> Split (FingerTree (Node a)) (Node a) #-}+splitTree :: Sized a => Int -> FingerTree a -> Split (FingerTree a) a+splitTree _ Empty = error "splitTree of empty tree"+splitTree i (Single x) = i `seq` Split Empty x Empty+splitTree i (Deep _ pr m sf)+ | i < spr = case splitDigit i pr of+ Split l x r -> Split (maybe Empty digitToTree l) x (deepL r m sf)+ | i < spm = case splitTree im m of+ Split ml xs mr -> case splitNode (im - size ml) xs of+ Split l x r -> Split (deepR pr ml l) x (deepL r mr sf)+ | otherwise = case splitDigit (i - spm) sf of+ Split l x r -> Split (deepR pr m l) x (maybe Empty digitToTree r)+ where spr = size pr+ spm = spr + size m+ im = i - spr++{-# SPECIALIZE deepL :: Maybe (Digit (Elem a)) -> FingerTree (Node (Elem a)) -> Digit (Elem a) -> FingerTree (Elem a) #-}+{-# SPECIALIZE deepL :: Maybe (Digit (Node a)) -> FingerTree (Node (Node a)) -> Digit (Node a) -> FingerTree (Node a) #-}+deepL :: Sized a => Maybe (Digit a) -> FingerTree (Node a) -> Digit a -> FingerTree a+deepL Nothing m sf = case viewLTree m of+ Nothing2 -> digitToTree sf+ Just2 a m' -> deep (nodeToDigit a) m' sf+deepL (Just pr) m sf = deep pr m sf++{-# SPECIALIZE deepR :: Digit (Elem a) -> FingerTree (Node (Elem a)) -> Maybe (Digit (Elem a)) -> FingerTree (Elem a) #-}+{-# SPECIALIZE deepR :: Digit (Node a) -> FingerTree (Node (Node a)) -> Maybe (Digit (Node a)) -> FingerTree (Node a) #-}+deepR :: Sized a => Digit a -> FingerTree (Node a) -> Maybe (Digit a) -> FingerTree a+deepR pr m Nothing = case viewRTree m of+ Nothing2 -> digitToTree pr+ Just2 m' a -> deep pr m' (nodeToDigit a)+deepR pr m (Just sf) = deep pr m sf++{-# SPECIALIZE splitNode :: Int -> Node (Elem a) -> Split (Maybe (Digit (Elem a))) (Elem a) #-}+{-# SPECIALIZE splitNode :: Int -> Node (Node a) -> Split (Maybe (Digit (Node a))) (Node a) #-}+splitNode :: Sized a => Int -> Node a -> Split (Maybe (Digit a)) a+splitNode i (Node2 _ a b)+ | i < sa = Split Nothing a (Just (One b))+ | otherwise = Split (Just (One a)) b Nothing+ where sa = size a+splitNode i (Node3 _ a b c)+ | i < sa = Split Nothing a (Just (Two b c))+ | i < sab = Split (Just (One a)) b (Just (One c))+ | otherwise = Split (Just (Two a b)) c Nothing+ where sa = size a+ sab = sa + size b++{-# SPECIALIZE splitDigit :: Int -> Digit (Elem a) -> Split (Maybe (Digit (Elem a))) (Elem a) #-}+{-# SPECIALIZE splitDigit :: Int -> Digit (Node a) -> Split (Maybe (Digit (Node a))) (Node a) #-}+splitDigit :: Sized a => Int -> Digit a -> Split (Maybe (Digit a)) a+splitDigit i (One a) = i `seq` Split Nothing a Nothing+splitDigit i (Two a b)+ | i < sa = Split Nothing a (Just (One b))+ | otherwise = Split (Just (One a)) b Nothing+ where sa = size a+splitDigit i (Three a b c)+ | i < sa = Split Nothing a (Just (Two b c))+ | i < sab = Split (Just (One a)) b (Just (One c))+ | otherwise = Split (Just (Two a b)) c Nothing+ where sa = size a+ sab = sa + size b+splitDigit i (Four a b c d)+ | i < sa = Split Nothing a (Just (Three b c d))+ | i < sab = Split (Just (One a)) b (Just (Two c d))+ | i < sabc = Split (Just (Two a b)) c (Just (One d))+ | otherwise = Split (Just (Three a b c)) d Nothing+ where sa = size a+ sab = sa + size b+ sabc = sab + size c++------------------------------------------------------------------------+-- Lists+------------------------------------------------------------------------++-- | /O(n)/. Create a sequence from a finite list of elements.+-- There is a function 'toList' in the opposite direction for all+-- instances of the 'Foldable' class, including 'Seq'.+fromList :: [a] -> Seq a+fromList = Data.List.foldl' (|>) empty++------------------------------------------------------------------------+-- Reverse+------------------------------------------------------------------------++-- | /O(n)/. The reverse of a sequence.+reverse :: Seq a -> Seq a+reverse (Seq xs) = Seq (reverseTree id xs)++reverseTree :: (a -> a) -> FingerTree a -> FingerTree a+reverseTree _ Empty = Empty+reverseTree f (Single x) = Single (f x)+reverseTree f (Deep s pr m sf) =+ Deep s (reverseDigit f sf)+ (reverseTree (reverseNode f) m)+ (reverseDigit f pr)++reverseDigit :: (a -> a) -> Digit a -> Digit a+reverseDigit f (One a) = One (f a)+reverseDigit f (Two a b) = Two (f b) (f a)+reverseDigit f (Three a b c) = Three (f c) (f b) (f a)+reverseDigit f (Four a b c d) = Four (f d) (f c) (f b) (f a)++reverseNode :: (a -> a) -> Node a -> Node a+reverseNode f (Node2 s a b) = Node2 s (f b) (f a)+reverseNode f (Node3 s a b c) = Node3 s (f c) (f b) (f a)++#if TESTING++------------------------------------------------------------------------+-- QuickCheck+------------------------------------------------------------------------++instance Arbitrary a => Arbitrary (Seq a) where+ arbitrary = liftM Seq arbitrary+ coarbitrary (Seq x) = coarbitrary x++instance Arbitrary a => Arbitrary (Elem a) where+ arbitrary = liftM Elem arbitrary+ coarbitrary (Elem x) = coarbitrary x++instance (Arbitrary a, Sized a) => Arbitrary (FingerTree a) where+ arbitrary = sized arb+ where arb :: (Arbitrary a, Sized a) => Int -> Gen (FingerTree a)+ arb 0 = return Empty+ arb 1 = liftM Single arbitrary+ arb n = liftM3 deep arbitrary (arb (n `div` 2)) arbitrary++ coarbitrary Empty = variant 0+ coarbitrary (Single x) = variant 1 . coarbitrary x+ coarbitrary (Deep _ pr m sf) =+ variant 2 . coarbitrary pr . coarbitrary m . coarbitrary sf++instance (Arbitrary a, Sized a) => Arbitrary (Node a) where+ arbitrary = oneof [+ liftM2 node2 arbitrary arbitrary,+ liftM3 node3 arbitrary arbitrary arbitrary]++ coarbitrary (Node2 _ a b) = variant 0 . coarbitrary a . coarbitrary b+ coarbitrary (Node3 _ a b c) =+ variant 1 . coarbitrary a . coarbitrary b . coarbitrary c++instance Arbitrary a => Arbitrary (Digit a) where+ arbitrary = oneof [+ liftM One arbitrary,+ liftM2 Two arbitrary arbitrary,+ liftM3 Three arbitrary arbitrary arbitrary,+ liftM4 Four arbitrary arbitrary arbitrary arbitrary]++ coarbitrary (One a) = variant 0 . coarbitrary a+ coarbitrary (Two a b) = variant 1 . coarbitrary a . coarbitrary b+ coarbitrary (Three a b c) =+ variant 2 . coarbitrary a . coarbitrary b . coarbitrary c+ coarbitrary (Four a b c d) =+ variant 3 . coarbitrary a . coarbitrary b . coarbitrary c . coarbitrary d++------------------------------------------------------------------------+-- Valid trees+------------------------------------------------------------------------++class Valid a where+ valid :: a -> Bool++instance Valid (Elem a) where+ valid _ = True++instance Valid (Seq a) where+ valid (Seq xs) = valid xs++instance (Sized a, Valid a) => Valid (FingerTree a) where+ valid Empty = True+ valid (Single x) = valid x+ valid (Deep s pr m sf) =+ s == size pr + size m + size sf && valid pr && valid m && valid sf++instance (Sized a, Valid a) => Valid (Node a) where+ valid (Node2 s a b) = s == size a + size b && valid a && valid b+ valid (Node3 s a b c) =+ s == size a + size b + size c && valid a && valid b && valid c++instance Valid a => Valid (Digit a) where+ valid (One a) = valid a+ valid (Two a b) = valid a && valid b+ valid (Three a b c) = valid a && valid b && valid c+ valid (Four a b c d) = valid a && valid b && valid c && valid d++#endif
+ Data/Set.hs view
@@ -0,0 +1,1149 @@+-----------------------------------------------------------------------------+-- |+-- Module : Data.Set+-- Copyright : (c) Daan Leijen 2002+-- License : BSD-style+-- Maintainer : libraries@haskell.org+-- Stability : provisional+-- Portability : portable+--+-- An efficient implementation of sets.+--+-- Since many function names (but not the type name) clash with+-- "Prelude" names, this module is usually imported @qualified@, e.g.+--+-- > import Data.Set (Set)+-- > import qualified Data.Set as Set+--+-- 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.+--+-- Note that the implementation is /left-biased/ -- the elements of a+-- first argument are always preferred to the second, for example in+-- 'union' or 'insert'. Of course, left-biasing can only be observed+-- when equality is an equivalence relation instead of structural+-- equality.+-----------------------------------------------------------------------------++module Data.Set ( + -- * Set type+ Set -- instance Eq,Ord,Show,Read,Data,Typeable++ -- * Operators+ , (\\)++ -- * Query+ , null+ , size+ , member+ , notMember+ , isSubsetOf+ , isProperSubsetOf+ + -- * Construction+ , empty+ , singleton+ , insert+ , delete+ + -- * Combine+ , union, unions+ , difference+ , intersection+ + -- * Filter+ , filter+ , partition+ , split+ , splitMember++ -- * Map+ , map+ , mapMonotonic++ -- * Fold+ , fold++ -- * Min\/Max+ , findMin+ , findMax+ , deleteMin+ , deleteMax+ , deleteFindMin+ , deleteFindMax+ , maxView+ , minView++ -- * Conversion++ -- ** List+ , elems+ , toList+ , fromList+ + -- ** Ordered list+ , toAscList+ , fromAscList+ , fromDistinctAscList+ + -- * Debugging+ , showTree+ , showTreeWith+ , valid+ ) where++import Prelude hiding (filter,foldr,null,map)+import qualified Data.List as List+import Data.Monoid (Monoid(..))+import Data.Typeable+import Data.Foldable (Foldable(foldMap))++{-+-- just for testing+import QuickCheck +import List (nub,sort)+import qualified List+-}++#if __GLASGOW_HASKELL__+import Text.Read+import Data.Generics.Basics+import Data.Generics.Instances+#endif++{--------------------------------------------------------------------+ 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 {-# UNPACK #-} !Size a !(Set a) !(Set a) ++type Size = Int++instance Ord a => Monoid (Set a) where+ mempty = empty+ mappend = union+ mconcat = unions++instance Foldable Set where+ foldMap f Tip = mempty+ foldMap f (Bin _s k l r) = foldMap f l `mappend` f k `mappend` foldMap f r++#if __GLASGOW_HASKELL__++{--------------------------------------------------------------------+ A Data instance +--------------------------------------------------------------------}++-- This instance preserves data abstraction at the cost of inefficiency.+-- We omit reflection services for the sake of data abstraction.++instance (Data a, Ord a) => Data (Set a) where+ gfoldl f z set = z fromList `f` (toList set)+ toConstr _ = error "toConstr"+ gunfold _ _ = error "gunfold"+ dataTypeOf _ = mkNorepType "Data.Set.Set"+ dataCast1 f = gcast1 f++#endif++{--------------------------------------------------------------------+ Query+--------------------------------------------------------------------}+-- | /O(1)/. Is this the empty set?+null :: Set a -> Bool+null t+ = case t of+ Tip -> True+ Bin sz x l r -> False++-- | /O(1)/. The number of elements in the set.+size :: Set a -> Int+size t+ = case t of+ Tip -> 0+ Bin sz x l r -> sz++-- | /O(log n)/. Is the element in the set?+member :: Ord a => a -> Set a -> Bool+member x t+ = case t of+ Tip -> False+ Bin sz y l r+ -> case compare x y of+ LT -> member x l+ GT -> member x r+ EQ -> True ++-- | /O(log n)/. Is the element not in the set?+notMember :: Ord a => a -> Set a -> Bool+notMember x t = not $ member x t++{--------------------------------------------------------------------+ 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.+-- If the set already contains an element equal to the given value,+-- it is replaced with the new value.+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).+isProperSubsetOf :: Ord a => Set a -> Set a -> Bool+isProperSubsetOf s1 s2+ = (size s1 < size s2) && (isSubsetOf s1 s2)+++-- | /O(n+m)/. Is this a subset?+-- @(s1 `isSubsetOf` s2)@ tells whether @s1@ is a subset of @s2@.+isSubsetOf :: Ord a => Set a -> Set a -> Bool+isSubsetOf t1 t2+ = (size t1 <= size t2) && (isSubsetOfX t1 t2)++isSubsetOfX Tip t = True+isSubsetOfX t Tip = False+isSubsetOfX (Bin _ x l r) t+ = found && isSubsetOfX l lt && isSubsetOfX r gt+ where+ (lt,found,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, preferring the first set when+-- equal elements are encountered.+-- The implementation uses the efficient /hedge-union/ algorithm.+-- Hedge-union is more efficient on (bigset `union` smallset).+union :: Ord a => Set a -> Set a -> Set a+union Tip t2 = t2+union t1 Tip = t1+union t1 t2 = hedgeUnion (const LT) (const GT) t1 t2++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.+-- Elements of the result come from the first set, so for example+--+-- > import qualified Data.Set as S+-- > data AB = A | B deriving Show+-- > instance Ord AB where compare _ _ = EQ+-- > instance Eq AB where _ == _ = True+-- > main = print (S.singleton A `S.intersection` S.singleton B,+-- > S.singleton B `S.intersection` S.singleton A)+--+-- prints @(fromList [A],fromList [B])@.+intersection :: Ord a => Set a -> Set a -> Set a+intersection Tip t = Tip+intersection t Tip = Tip+intersection t1@(Bin s1 x1 l1 r1) t2@(Bin s2 x2 l2 r2) =+ if s1 >= s2 then+ let (lt,found,gt) = splitLookup x2 t1+ tl = intersection lt l2+ tr = intersection gt r2+ in case found of+ Just x -> join x tl tr+ Nothing -> merge tl tr+ else let (lt,found,gt) = splitMember x1 t2+ tl = intersection l1 lt+ tr = intersection r1 gt+ in if found then join x1 tl tr+ else merge tl tr++{--------------------------------------------------------------------+ 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 over the elements of a set in an unspecified order.+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 set from an ascending list in linear time.+-- /The precondition (input list is ascending) is not checked./+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.+-- /The precondition (input list is strictly ascending) is not checked./+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 p xs = showParen (p > 10) $+ showString "fromList " . shows (toList xs)++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++{--------------------------------------------------------------------+ Read+--------------------------------------------------------------------}+instance (Read a, Ord a) => Read (Set a) where+#ifdef __GLASGOW_HASKELL__+ readPrec = parens $ prec 10 $ do+ Ident "fromList" <- lexP+ xs <- readPrec+ return (fromList xs)++ readListPrec = readListPrecDefault+#else+ readsPrec p = readParen (p > 10) $ \ r -> do+ ("fromList",s) <- lex r+ (xs,t) <- reads s+ return (fromList xs,t)+#endif++{--------------------------------------------------------------------+ Typeable/Data+--------------------------------------------------------------------}++#include "Typeable.h"+INSTANCE_TYPEABLE1(Set,setTc,"Set")++{--------------------------------------------------------------------+ 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@. @x@ is not found in neither @set1@ nor @set2@.+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 -> (Set a,Bool,Set a)+splitMember x t = let (l,m,r) = splitLookup x t in+ (l,maybe False (const True) m,r)++-- | /O(log n)/. Performs a 'split' but also returns the pivot+-- element that was found in the original set.+splitLookup :: Ord a => a -> Set a -> (Set a,Maybe a,Set a)+splitLookup x Tip = (Tip,Nothing,Tip)+splitLookup x (Bin sy y l r)+ = case compare x y of+ LT -> let (lt,found,gt) = splitLookup x l in (lt,found,join y gt r)+ GT -> let (lt,found,gt) = splitLookup x r in (join y l lt,found,gt)+ EQ -> (l,Just y,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 = (findMin set, deleteMin set)++deleteFindMin :: Set a -> (a,Set a)+deleteFindMin t + = case t of+ Bin _ x Tip r -> (x,r)+ Bin _ x l r -> let (xm,l') = deleteFindMin l in (xm,balance x l' r)+ Tip -> (error "Set.deleteFindMin: can not return the minimal element of an empty set", Tip)++-- | /O(log n)/. Delete and find the maximal element.+-- +-- > deleteFindMax set = (findMax set, deleteMax set)+deleteFindMax :: Set a -> (a,Set a)+deleteFindMax t+ = case t of+ Bin _ x l Tip -> (x,l)+ Bin _ x l r -> let (xm,r') = deleteFindMax r in (xm,balance x l r')+ Tip -> (error "Set.deleteFindMax: can not return the maximal element of an empty set", Tip)++-- | /O(log n)/. Retrieves the minimal key of the set, and the set stripped from that element+-- @fail@s (in the monad) when passed an empty set.+minView :: Monad m => Set a -> m (a, Set a)+minView Tip = fail "Set.minView: empty set"+minView x = return (deleteFindMin x)++-- | /O(log n)/. Retrieves the maximal key of the set, and the set stripped from that element+-- @fail@s (in the monad) when passed an empty set.+maxView :: Monad m => Set a -> m (a, Set a)+maxView Tip = fail "Set.maxView: empty set"+maxView x = return (deleteFindMax x)+++{--------------------------------------------------------------------+ [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))+-}
+ Data/Tree.hs view
@@ -0,0 +1,167 @@+-----------------------------------------------------------------------------+-- |+-- Module : Data.Tree+-- Copyright : (c) The University of Glasgow 2002+-- License : BSD-style (see the file libraries/base/LICENSE)+-- +-- Maintainer : libraries@haskell.org+-- Stability : experimental+-- Portability : portable+--+-- Multi-way trees (/aka/ rose trees) and forests.+--+-----------------------------------------------------------------------------++module Data.Tree(+ Tree(..), Forest,+ -- * Two-dimensional drawing+ drawTree, drawForest,+ -- * Extraction+ flatten, levels,+ -- * Building trees+ unfoldTree, unfoldForest,+ unfoldTreeM, unfoldForestM,+ unfoldTreeM_BF, unfoldForestM_BF,+ ) where++#ifdef __HADDOCK__+import Prelude+#endif++import Control.Applicative (Applicative(..), (<$>))+import Control.Monad+import Data.Monoid (Monoid(..))+import Data.Sequence (Seq, empty, singleton, (<|), (|>), fromList,+ ViewL(..), ViewR(..), viewl, viewr)+import Data.Foldable (Foldable(foldMap), toList)+import Data.Traversable (Traversable(traverse))+import Data.Typeable++#ifdef __GLASGOW_HASKELL__+import Data.Generics.Basics (Data)+import Data.Generics.Instances+#endif++-- | Multi-way trees, also known as /rose trees/.+data Tree a = Node {+ rootLabel :: a, -- ^ label value+ subForest :: Forest a -- ^ zero or more child trees+ }+#ifndef __HADDOCK__+# ifdef __GLASGOW_HASKELL__+ deriving (Eq, Read, Show, Data)+# else+ deriving (Eq, Read, Show)+# endif+#else /* __HADDOCK__ (which can't figure these out by itself) */+instance Eq a => Eq (Tree a)+instance Read a => Read (Tree a)+instance Show a => Show (Tree a)+instance Data a => Data (Tree a)+#endif+type Forest a = [Tree a]++#include "Typeable.h"+INSTANCE_TYPEABLE1(Tree,treeTc,"Tree")++instance Functor Tree where+ fmap f (Node x ts) = Node (f x) (map (fmap f) ts)++instance Applicative Tree where+ pure x = Node x []+ Node f tfs <*> tx@(Node x txs) =+ Node (f x) (map (f <$>) txs ++ map (<*> tx) tfs)++instance Monad Tree where+ return x = Node x []+ Node x ts >>= f = Node x' (ts' ++ map (>>= f) ts)+ where Node x' ts' = f x++instance Traversable Tree where+ traverse f (Node x ts) = Node <$> f x <*> traverse (traverse f) ts++instance Foldable Tree where+ foldMap f (Node x ts) = f x `mappend` foldMap (foldMap f) ts++-- | Neat 2-dimensional drawing of a tree.+drawTree :: Tree String -> String+drawTree = unlines . draw++-- | Neat 2-dimensional drawing of a forest.+drawForest :: Forest String -> String+drawForest = unlines . map drawTree++draw :: Tree String -> [String]+draw (Node x ts0) = x : drawSubTrees ts0+ where drawSubTrees [] = []+ drawSubTrees [t] =+ "|" : shift "`- " " " (draw t)+ drawSubTrees (t:ts) =+ "|" : shift "+- " "| " (draw t) ++ drawSubTrees ts++ shift first other = zipWith (++) (first : repeat other)++-- | The elements of a tree in pre-order.+flatten :: Tree a -> [a]+flatten t = squish t []+ where squish (Node x ts) xs = x:Prelude.foldr squish xs ts++-- | Lists of nodes at each level of the tree.+levels :: Tree a -> [[a]]+levels t = map (map rootLabel) $+ takeWhile (not . null) $+ iterate (concatMap subForest) [t]++-- | Build a tree from a seed value+unfoldTree :: (b -> (a, [b])) -> b -> Tree a+unfoldTree f b = let (a, bs) = f b in Node a (unfoldForest f bs)++-- | Build a forest from a list of seed values+unfoldForest :: (b -> (a, [b])) -> [b] -> Forest a+unfoldForest f = map (unfoldTree f)++-- | Monadic tree builder, in depth-first order+unfoldTreeM :: Monad m => (b -> m (a, [b])) -> b -> m (Tree a)+unfoldTreeM f b = do+ (a, bs) <- f b+ ts <- unfoldForestM f bs+ return (Node a ts)++-- | Monadic forest builder, in depth-first order+#ifndef __NHC__+unfoldForestM :: Monad m => (b -> m (a, [b])) -> [b] -> m (Forest a)+#endif+unfoldForestM f = Prelude.mapM (unfoldTreeM f)++-- | Monadic tree builder, in breadth-first order,+-- using an algorithm adapted from+-- /Breadth-First Numbering: Lessons from a Small Exercise in Algorithm Design/,+-- by Chris Okasaki, /ICFP'00/.+unfoldTreeM_BF :: Monad m => (b -> m (a, [b])) -> b -> m (Tree a)+unfoldTreeM_BF f b = liftM getElement $ unfoldForestQ f (singleton b)+ where getElement xs = case viewl xs of+ x :< _ -> x+ EmptyL -> error "unfoldTreeM_BF"++-- | Monadic forest builder, in breadth-first order,+-- using an algorithm adapted from+-- /Breadth-First Numbering: Lessons from a Small Exercise in Algorithm Design/,+-- by Chris Okasaki, /ICFP'00/.+unfoldForestM_BF :: Monad m => (b -> m (a, [b])) -> [b] -> m (Forest a)+unfoldForestM_BF f = liftM toList . unfoldForestQ f . fromList++-- takes a sequence (queue) of seeds+-- produces a sequence (reversed queue) of trees of the same length+unfoldForestQ :: Monad m => (b -> m (a, [b])) -> Seq b -> m (Seq (Tree a))+unfoldForestQ f aQ = case viewl aQ of+ EmptyL -> return empty+ a :< aQ -> do+ (b, as) <- f a+ tQ <- unfoldForestQ f (Prelude.foldl (|>) aQ as)+ let (tQ', ts) = splitOnto [] as tQ+ return (Node b ts <| tQ')+ where splitOnto :: [a'] -> [b'] -> Seq a' -> (Seq a', [a'])+ splitOnto as [] q = (q, as)+ splitOnto as (_:bs) q = case viewr q of+ q' :> a -> splitOnto (a:as) bs q'+ EmptyR -> error "unfoldForestQ"
+ LICENSE view
@@ -0,0 +1,83 @@+This library (libraries/containers) is derived from code from several+sources: ++ * Code from the GHC project which is largely (c) The University of+ Glasgow, and distributable under a BSD-style license (see below),++ * Code from the Haskell 98 Report which is (c) Simon Peyton Jones+ and freely redistributable (but see the full license for+ restrictions).++ * Code from the Haskell Foreign Function Interface specification,+ which is (c) Manuel M. T. Chakravarty and freely redistributable+ (but see the full license for restrictions).++The full text of these licenses is reproduced below. All of the+licenses are BSD-style or compatible.++-----------------------------------------------------------------------------++The Glasgow Haskell Compiler License++Copyright 2004, The University Court of the University of Glasgow. +All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++- Redistributions of source code must retain the above copyright notice,+this list of conditions and the following disclaimer.+ +- Redistributions in binary form must reproduce the above copyright notice,+this list of conditions and the following disclaimer in the documentation+and/or other materials provided with the distribution.+ +- Neither name of the University nor the names of its contributors may be+used to endorse or promote products derived from this software without+specific prior written permission. ++THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF+GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES,+INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND+FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE+UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR+SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER+CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT+LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY+OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH+DAMAGE.++-----------------------------------------------------------------------------++Code derived from the document "Report on the Programming Language+Haskell 98", is distributed under the following license:++ Copyright (c) 2002 Simon Peyton Jones++ The authors intend this Report to belong to the entire Haskell+ community, and so we grant permission to copy and distribute it for+ any purpose, provided that it is reproduced in its entirety,+ including this Notice. Modified versions of this Report may also be+ copied and distributed for any purpose, provided that the modified+ version is clearly presented as such, and that it does not claim to+ be a definition of the Haskell 98 Language.++-----------------------------------------------------------------------------++Code derived from the document "The Haskell 98 Foreign Function+Interface, An Addendum to the Haskell 98 Report" is distributed under+the following license:++ Copyright (c) 2002 Manuel M. T. Chakravarty++ The authors intend this Report to belong to the entire Haskell+ community, and so we grant permission to copy and distribute it for+ any purpose, provided that it is reproduced in its entirety,+ including this Notice. Modified versions of this Report may also be+ copied and distributed for any purpose, provided that the modified+ version is clearly presented as such, and that it does not claim to+ be a definition of the Haskell 98 Foreign Function Interface.++-----------------------------------------------------------------------------
+ Setup.hs view
@@ -0,0 +1,6 @@+module Main (main) where++import Distribution.Simple++main :: IO ()+main = defaultMain
+ containers.cabal view
@@ -0,0 +1,26 @@+name: containers+version: 0.1.0.0+license: BSD3+license-file: LICENSE+maintainer: libraries@haskell.org+synopsis: Assorted concrete container types+description:+ This package contains efficient general-purpose implementations+ of various basic immutable container types. The declared cost of+ each operation is either worst-case or amortized, but remains+ valid even if structures are shared.+build-type: Simple+build-depends: base, array+exposed-modules:+ Data.Graph+ Data.IntMap+ Data.IntSet+ Data.Map+ Data.Sequence+ Data.Set+ Data.Tree+include-dirs: include+extensions: CPP+-- We need this for Data deriving, but we can't just turn on that+-- extension because we only try to do it when building with GHC.+ghc-options: -fglasgow-exts