From: Ian Lynagh Date: Wed, 1 Aug 2007 22:38:58 +0000 (+0000) Subject: Remove a number of modules now in a "containers" package X-Git-Tag: 2007-09-13~24 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=f1584248fa7ad8639fce36f23540bf38db253c39;p=ghc-base.git Remove a number of modules now in a "containers" package --- diff --git a/Data/Foldable.hs b/Data/Foldable.hs deleted file mode 100644 index 096a347..0000000 --- a/Data/Foldable.hs +++ /dev/null @@ -1,301 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Data.Foldable --- Copyright : Ross Paterson 2005 --- License : BSD-style (see the LICENSE file in the distribution) --- --- Maintainer : ross@soi.city.ac.uk --- Stability : experimental --- Portability : portable --- --- Class of data structures that can be folded to a summary value. --- --- Many of these functions generalize "Prelude", "Control.Monad" and --- "Data.List" functions of the same names from lists to any 'Foldable' --- functor. To avoid ambiguity, either import those modules hiding --- these names or qualify uses of these function names with an alias --- for this module. - -module Data.Foldable ( - -- * Folds - Foldable(..), - -- ** Special biased folds - foldr', - foldl', - foldrM, - foldlM, - -- ** Folding actions - -- *** Applicative actions - traverse_, - for_, - sequenceA_, - asum, - -- *** Monadic actions - mapM_, - forM_, - sequence_, - msum, - -- ** Specialized folds - toList, - concat, - concatMap, - and, - or, - any, - all, - sum, - product, - maximum, - maximumBy, - minimum, - minimumBy, - -- ** Searches - elem, - notElem, - find - ) where - -import Prelude hiding (foldl, foldr, foldl1, foldr1, mapM_, sequence_, - elem, notElem, concat, concatMap, and, or, any, all, - sum, product, maximum, minimum) -import qualified Prelude (foldl, foldr, foldl1, foldr1) -import Control.Applicative -import Control.Monad (MonadPlus(..)) -import Data.Maybe (fromMaybe, listToMaybe) -import Data.Monoid -import Data.Array - -#ifdef __NHC__ -import Control.Arrow (ArrowZero(..)) -- work around nhc98 typechecker problem -#endif - -#ifdef __GLASGOW_HASKELL__ -import GHC.Exts (build) -#endif - --- | Data structures that can be folded. --- --- Minimal complete definition: 'foldMap' or 'foldr'. --- --- For example, given a data type --- --- > data Tree a = Empty | Leaf a | Node (Tree a) a (Tree a) --- --- a suitable instance would be --- --- > instance Foldable Tree --- > foldMap f Empty = mempty --- > foldMap f (Leaf x) = f x --- > foldMap f (Node l k r) = foldMap f l `mappend` f k `mappend` foldMap f r --- --- This is suitable even for abstract types, as the monoid is assumed --- to satisfy the monoid laws. --- -class Foldable t where - -- | Combine the elements of a structure using a monoid. - fold :: Monoid m => t m -> m - fold = foldMap id - - -- | Map each element of the structure to a monoid, - -- and combine the results. - foldMap :: Monoid m => (a -> m) -> t a -> m - foldMap f = foldr (mappend . f) mempty - - -- | Right-associative fold of a structure. - -- - -- @'foldr' f z = 'Prelude.foldr' f z . 'toList'@ - foldr :: (a -> b -> b) -> b -> t a -> b - foldr f z t = appEndo (foldMap (Endo . f) t) z - - -- | Left-associative fold of a structure. - -- - -- @'foldl' f z = 'Prelude.foldl' f z . 'toList'@ - foldl :: (a -> b -> a) -> a -> t b -> a - foldl f z t = appEndo (getDual (foldMap (Dual . Endo . flip f) t)) z - - -- | A variant of 'foldr' that has no base case, - -- and thus may only be applied to non-empty structures. - -- - -- @'foldr1' f = 'Prelude.foldr1' f . 'toList'@ - foldr1 :: (a -> a -> a) -> t a -> a - foldr1 f xs = fromMaybe (error "foldr1: empty structure") - (foldr mf Nothing xs) - where mf x Nothing = Just x - mf x (Just y) = Just (f x y) - - -- | A variant of 'foldl' that has no base case, - -- and thus may only be applied to non-empty structures. - -- - -- @'foldl1' f = 'Prelude.foldl1' f . 'toList'@ - foldl1 :: (a -> a -> a) -> t a -> a - foldl1 f xs = fromMaybe (error "foldl1: empty structure") - (foldl mf Nothing xs) - where mf Nothing y = Just y - mf (Just x) y = Just (f x y) - --- instances for Prelude types - -instance Foldable Maybe where - foldr f z Nothing = z - foldr f z (Just x) = f x z - - foldl f z Nothing = z - foldl f z (Just x) = f z x - -instance Foldable [] where - foldr = Prelude.foldr - foldl = Prelude.foldl - foldr1 = Prelude.foldr1 - foldl1 = Prelude.foldl1 - -instance Ix i => Foldable (Array i) where - foldr f z = Prelude.foldr f z . elems - --- | Fold over the elements of a structure, --- associating to the right, but strictly. -foldr' :: Foldable t => (a -> b -> b) -> b -> t a -> b -foldr' f z xs = foldl f' id xs z - where f' k x z = k $! f x z - --- | Monadic fold over the elements of a structure, --- associating to the right, i.e. from right to left. -foldrM :: (Foldable t, Monad m) => (a -> b -> m b) -> b -> t a -> m b -foldrM f z xs = foldl f' return xs z - where f' k x z = f x z >>= k - --- | Fold over the elements of a structure, --- associating to the left, but strictly. -foldl' :: Foldable t => (a -> b -> a) -> a -> t b -> a -foldl' f z xs = foldr f' id xs z - where f' x k z = k $! f z x - --- | Monadic fold over the elements of a structure, --- associating to the left, i.e. from left to right. -foldlM :: (Foldable t, Monad m) => (a -> b -> m a) -> a -> t b -> m a -foldlM f z xs = foldr f' return xs z - where f' x k z = f z x >>= k - --- | Map each element of a structure to an action, evaluate --- these actions from left to right, and ignore the results. -traverse_ :: (Foldable t, Applicative f) => (a -> f b) -> t a -> f () -traverse_ f = foldr ((*>) . f) (pure ()) - --- | 'for_' is 'traverse_' with its arguments flipped. -for_ :: (Foldable t, Applicative f) => t a -> (a -> f b) -> f () -{-# INLINE for_ #-} -for_ = flip traverse_ - --- | Map each element of a structure to a monadic action, evaluate --- these actions from left to right, and ignore the results. -mapM_ :: (Foldable t, Monad m) => (a -> m b) -> t a -> m () -mapM_ f = foldr ((>>) . f) (return ()) - --- | 'forM_' is 'mapM_' with its arguments flipped. -forM_ :: (Foldable t, Monad m) => t a -> (a -> m b) -> m () -{-# INLINE forM_ #-} -forM_ = flip mapM_ - --- | Evaluate each action in the structure from left to right, --- and ignore the results. -sequenceA_ :: (Foldable t, Applicative f) => t (f a) -> f () -sequenceA_ = foldr (*>) (pure ()) - --- | Evaluate each monadic action in the structure from left to right, --- and ignore the results. -sequence_ :: (Foldable t, Monad m) => t (m a) -> m () -sequence_ = foldr (>>) (return ()) - --- | The sum of a collection of actions, generalizing 'concat'. -asum :: (Foldable t, Alternative f) => t (f a) -> f a -{-# INLINE asum #-} -asum = foldr (<|>) empty - --- | The sum of a collection of actions, generalizing 'concat'. -msum :: (Foldable t, MonadPlus m) => t (m a) -> m a -{-# INLINE msum #-} -msum = foldr mplus mzero - --- These use foldr rather than foldMap to avoid repeated concatenation. - --- | List of elements of a structure. -toList :: Foldable t => t a -> [a] -#ifdef __GLASGOW_HASKELL__ -toList t = build (\ c n -> foldr c n t) -#else -toList = foldr (:) [] -#endif - --- | The concatenation of all the elements of a container of lists. -concat :: Foldable t => t [a] -> [a] -concat = fold - --- | Map a function over all the elements of a container and concatenate --- the resulting lists. -concatMap :: Foldable t => (a -> [b]) -> t a -> [b] -concatMap = foldMap - --- | 'and' returns the conjunction of a container of Bools. For the --- result to be 'True', the container must be finite; 'False', however, --- results from a 'False' value finitely far from the left end. -and :: Foldable t => t Bool -> Bool -and = getAll . foldMap All - --- | 'or' returns the disjunction of a container of Bools. For the --- result to be 'False', the container must be finite; 'True', however, --- results from a 'True' value finitely far from the left end. -or :: Foldable t => t Bool -> Bool -or = getAny . foldMap Any - --- | Determines whether any element of the structure satisfies the predicate. -any :: Foldable t => (a -> Bool) -> t a -> Bool -any p = getAny . foldMap (Any . p) - --- | Determines whether all elements of the structure satisfy the predicate. -all :: Foldable t => (a -> Bool) -> t a -> Bool -all p = getAll . foldMap (All . p) - --- | The 'sum' function computes the sum of the numbers of a structure. -sum :: (Foldable t, Num a) => t a -> a -sum = getSum . foldMap Sum - --- | The 'product' function computes the product of the numbers of a structure. -product :: (Foldable t, Num a) => t a -> a -product = getProduct . foldMap Product - --- | The largest element of a non-empty structure. -maximum :: (Foldable t, Ord a) => t a -> a -maximum = foldr1 max - --- | The largest element of a non-empty structure with respect to the --- given comparison function. -maximumBy :: Foldable t => (a -> a -> Ordering) -> t a -> a -maximumBy cmp = foldr1 max' - where max' x y = case cmp x y of - GT -> x - _ -> y - --- | The least element of a non-empty structure. -minimum :: (Foldable t, Ord a) => t a -> a -minimum = foldr1 min - --- | The least element of a non-empty structure with respect to the --- given comparison function. -minimumBy :: Foldable t => (a -> a -> Ordering) -> t a -> a -minimumBy cmp = foldr1 min' - where min' x y = case cmp x y of - GT -> y - _ -> x - --- | Does the element occur in the structure? -elem :: (Foldable t, Eq a) => a -> t a -> Bool -elem = any . (==) - --- | 'notElem' is the negation of 'elem'. -notElem :: (Foldable t, Eq a) => a -> t a -> Bool -notElem x = not . elem x - --- | The 'find' function takes a predicate and a structure and returns --- the leftmost element of the structure matching the predicate, or --- 'Nothing' if there is no such element. -find :: Foldable t => (a -> Bool) -> t a -> Maybe a -find p = listToMaybe . concatMap (\ x -> if p x then [x] else []) diff --git a/Data/Graph.hs b/Data/Graph.hs deleted file mode 100644 index 701675c..0000000 --- a/Data/Graph.hs +++ /dev/null @@ -1,432 +0,0 @@ ------------------------------------------------------------------------------ --- | --- 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 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, --- --- --- * 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 (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 (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 (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 (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])]) --} diff --git a/Data/IntSet.hs b/Data/IntSet.hs deleted file mode 100644 index 1622608..0000000 --- a/Data/IntSet.hs +++ /dev/null @@ -1,1020 +0,0 @@ -{-# 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, --- --- --- * 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 (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 (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 (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 (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)) --} diff --git a/Data/Map.hs b/Data/Map.hs deleted file mode 100644 index b8fcf71..0000000 --- a/Data/Map.hs +++ /dev/null @@ -1,1846 +0,0 @@ -{-# 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, --- . --- --- * 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) 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])]) --} diff --git a/Data/Sequence.hs b/Data/Sequence.hs deleted file mode 100644 index 318dc20..0000000 --- a/Data/Sequence.hs +++ /dev/null @@ -1,1124 +0,0 @@ -{-# 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. --- --- --- /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 diff --git a/Data/Set.hs b/Data/Set.hs deleted file mode 100644 index 04d0100..0000000 --- a/Data/Set.hs +++ /dev/null @@ -1,1149 +0,0 @@ ------------------------------------------------------------------------------ --- | --- 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, --- . --- --- * 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) 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)) --} diff --git a/Data/Traversable.hs b/Data/Traversable.hs deleted file mode 100644 index 32347d7..0000000 --- a/Data/Traversable.hs +++ /dev/null @@ -1,139 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Data.Traversable --- Copyright : Conor McBride and Ross Paterson 2005 --- License : BSD-style (see the LICENSE file in the distribution) --- --- Maintainer : ross@soi.city.ac.uk --- Stability : experimental --- Portability : portable --- --- Class of data structures that can be traversed from left to right, --- performing an action on each element. --- --- See also --- --- * /Applicative Programming with Effects/, --- by Conor McBride and Ross Paterson, online at --- . --- --- * /The Essence of the Iterator Pattern/, --- by Jeremy Gibbons and Bruno Oliveira, --- in /Mathematically-Structured Functional Programming/, 2006, and online at --- . --- --- Note that the functions 'mapM' and 'sequence' generalize "Prelude" --- functions of the same names from lists to any 'Traversable' functor. --- To avoid ambiguity, either import the "Prelude" hiding these names --- or qualify uses of these function names with an alias for this module. - -module Data.Traversable ( - Traversable(..), - for, - forM, - fmapDefault, - foldMapDefault, - ) where - -import Prelude hiding (mapM, sequence, foldr) -import qualified Prelude (mapM, foldr) -import Control.Applicative -import Data.Foldable (Foldable()) -import Data.Monoid (Monoid) -import Data.Array - --- | Functors representing data structures that can be traversed from --- left to right. --- --- Minimal complete definition: 'traverse' or 'sequenceA'. --- --- Instances are similar to 'Functor', e.g. given a data type --- --- > data Tree a = Empty | Leaf a | Node (Tree a) a (Tree a) --- --- a suitable instance would be --- --- > instance Traversable Tree --- > traverse f Empty = pure Empty --- > traverse f (Leaf x) = Leaf <$> f x --- > traverse f (Node l k r) = Node <$> traverse f l <*> f k <*> traverse f r --- --- This is suitable even for abstract types, as the laws for '<*>' --- imply a form of associativity. --- --- The superclass instances should satisfy the following: --- --- * In the 'Functor' instance, 'fmap' should be equivalent to traversal --- with the identity applicative functor ('fmapDefault'). --- --- * In the 'Foldable' instance, 'Data.Foldable.foldMap' should be --- equivalent to traversal with a constant applicative functor --- ('foldMapDefault'). --- -class (Functor t, Foldable t) => Traversable t where - -- | Map each element of a structure to an action, evaluate - -- these actions from left to right, and collect the results. - traverse :: Applicative f => (a -> f b) -> t a -> f (t b) - traverse f = sequenceA . fmap f - - -- | Evaluate each action in the structure from left to right, - -- and collect the results. - sequenceA :: Applicative f => t (f a) -> f (t a) - sequenceA = traverse id - - -- | Map each element of a structure to a monadic action, evaluate - -- these actions from left to right, and collect the results. - mapM :: Monad m => (a -> m b) -> t a -> m (t b) - mapM f = unwrapMonad . traverse (WrapMonad . f) - - -- | Evaluate each monadic action in the structure from left to right, - -- and collect the results. - sequence :: Monad m => t (m a) -> m (t a) - sequence = mapM id - --- instances for Prelude types - -instance Traversable Maybe where - traverse f Nothing = pure Nothing - traverse f (Just x) = Just <$> f x - -instance Traversable [] where - traverse f = Prelude.foldr cons_f (pure []) - where cons_f x ys = (:) <$> f x <*> ys - - mapM = Prelude.mapM - -instance Ix i => Traversable (Array i) where - traverse f arr = listArray (bounds arr) <$> traverse f (elems arr) - --- general functions - --- | 'for' is 'traverse' with its arguments flipped. -for :: (Traversable t, Applicative f) => t a -> (a -> f b) -> f (t b) -{-# INLINE for #-} -for = flip traverse - --- | 'forM' is 'mapM' with its arguments flipped. -forM :: (Traversable t, Monad m) => t a -> (a -> m b) -> m (t b) -{-# INLINE forM #-} -forM = flip mapM - --- | This function may be used as a value for `fmap` in a `Functor` instance. -fmapDefault :: Traversable t => (a -> b) -> t a -> t b -fmapDefault f = getId . traverse (Id . f) - --- | This function may be used as a value for `Data.Foldable.foldMap` --- in a `Foldable` instance. -foldMapDefault :: (Traversable t, Monoid m) => (a -> m) -> t a -> m -foldMapDefault f = getConst . traverse (Const . f) - --- local instances - -newtype Id a = Id { getId :: a } - -instance Functor Id where - fmap f (Id x) = Id (f x) - -instance Applicative Id where - pure = Id - Id f <*> Id x = Id (f x) diff --git a/Data/Tree.hs b/Data/Tree.hs deleted file mode 100644 index c159a74..0000000 --- a/Data/Tree.hs +++ /dev/null @@ -1,166 +0,0 @@ ------------------------------------------------------------------------------ --- | --- 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) -#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" diff --git a/base.cabal b/base.cabal index a9148dd..08dd8f9 100644 --- a/base.cabal +++ b/base.cabal @@ -100,19 +100,14 @@ Library { Data.Dynamic, Data.Either, Data.Eq, - Data.Foldable, Data.Fixed, Data.Function, - Data.Graph, Data.HashTable, Data.IORef, Data.Int, - Data.IntMap, - Data.IntSet, Data.Ix, Data.List, Data.Maybe, - Data.Map, Data.Monoid, Data.Ord, Data.PackedString, @@ -120,11 +115,7 @@ Library { Data.STRef, Data.STRef.Lazy, Data.STRef.Strict, - Data.Sequence, - Data.Set, Data.String, - Data.Tree, - Data.Traversable, Data.Tuple, Data.Typeable, Data.Unique,