+++ /dev/null
------------------------------------------------------------------------------
--- |
--- 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 [])
+++ /dev/null
------------------------------------------------------------------------------
--- |
--- Module : Data.Graph
--- Copyright : (c) The University of Glasgow 2002
--- License : BSD-style (see the file libraries/base/LICENSE)
---
--- Maintainer : libraries@haskell.org
--- Stability : experimental
--- Portability : portable
---
--- A version of the graph algorithms described in:
---
--- /Lazy Depth-First Search and Linear Graph Algorithms in Haskell/,
--- by David King and John Launchbury.
---
------------------------------------------------------------------------------
-
-module Data.Graph(
-
- -- * External interface
-
- -- At present the only one with a "nice" external interface
- stronglyConnComp, stronglyConnCompR, SCC(..), flattenSCC, flattenSCCs,
-
- -- * Graphs
-
- Graph, Table, Bounds, Edge, Vertex,
-
- -- ** Building graphs
-
- graphFromEdges, graphFromEdges', buildG, transposeG,
- -- reverseE,
-
- -- ** Graph properties
-
- vertices, edges,
- outdegree, indegree,
-
- -- * Algorithms
-
- dfs, dff,
- topSort,
- components,
- scc,
- bcc,
- -- tree, back, cross, forward,
- reachable, path,
-
- module Data.Tree
-
- ) where
-
-#if __GLASGOW_HASKELL__
-# define USE_ST_MONAD 1
-#endif
-
--- Extensions
-#if USE_ST_MONAD
-import Control.Monad.ST
-import Data.Array.ST (STArray, newArray, readArray, writeArray)
-#else
-import Data.IntSet (IntSet)
-import qualified Data.IntSet as Set
-#endif
-import Data.Tree (Tree(Node), Forest)
-
--- std interfaces
-import Data.Maybe
-import Data.Array
-import Data.List
-
-#ifdef __HADDOCK__
-import Prelude
-#endif
-
--------------------------------------------------------------------------
--- -
--- External interface
--- -
--------------------------------------------------------------------------
-
--- | Strongly connected component.
-data SCC vertex = AcyclicSCC vertex -- ^ A single vertex that is not
- -- in any cycle.
- | CyclicSCC [vertex] -- ^ A maximal set of mutually
- -- reachable vertices.
-
--- | The vertices of a list of strongly connected components.
-flattenSCCs :: [SCC a] -> [a]
-flattenSCCs = concatMap flattenSCC
-
--- | The vertices of a strongly connected component.
-flattenSCC :: SCC vertex -> [vertex]
-flattenSCC (AcyclicSCC v) = [v]
-flattenSCC (CyclicSCC vs) = vs
-
--- | The strongly connected components of a directed graph, topologically
--- sorted.
-stronglyConnComp
- :: Ord key
- => [(node, key, [key])]
- -- ^ The graph: a list of nodes uniquely identified by keys,
- -- with a list of keys of nodes this node has edges to.
- -- The out-list may contain keys that don't correspond to
- -- nodes of the graph; such edges are ignored.
- -> [SCC node]
-
-stronglyConnComp edges0
- = map get_node (stronglyConnCompR edges0)
- where
- get_node (AcyclicSCC (n, _, _)) = AcyclicSCC n
- get_node (CyclicSCC triples) = CyclicSCC [n | (n,_,_) <- triples]
-
--- | The strongly connected components of a directed graph, topologically
--- sorted. The function is the same as 'stronglyConnComp', except that
--- all the information about each node retained.
--- This interface is used when you expect to apply 'SCC' to
--- (some of) the result of 'SCC', so you don't want to lose the
--- dependency information.
-stronglyConnCompR
- :: Ord key
- => [(node, key, [key])]
- -- ^ The graph: a list of nodes uniquely identified by keys,
- -- with a list of keys of nodes this node has edges to.
- -- The out-list may contain keys that don't correspond to
- -- nodes of the graph; such edges are ignored.
- -> [SCC (node, key, [key])] -- ^ Topologically sorted
-
-stronglyConnCompR [] = [] -- added to avoid creating empty array in graphFromEdges -- SOF
-stronglyConnCompR edges0
- = map decode forest
- where
- (graph, vertex_fn,_) = graphFromEdges edges0
- forest = scc graph
- decode (Node v []) | mentions_itself v = CyclicSCC [vertex_fn v]
- | otherwise = AcyclicSCC (vertex_fn v)
- decode other = CyclicSCC (dec other [])
- where
- dec (Node v ts) vs = vertex_fn v : foldr dec vs ts
- mentions_itself v = v `elem` (graph ! v)
-
--------------------------------------------------------------------------
--- -
--- Graphs
--- -
--------------------------------------------------------------------------
-
--- | Abstract representation of vertices.
-type Vertex = Int
--- | Table indexed by a contiguous set of vertices.
-type Table a = Array Vertex a
--- | Adjacency list representation of a graph, mapping each vertex to its
--- list of successors.
-type Graph = Table [Vertex]
--- | The bounds of a 'Table'.
-type Bounds = (Vertex, Vertex)
--- | An edge from the first vertex to the second.
-type Edge = (Vertex, Vertex)
-
--- | All vertices of a graph.
-vertices :: Graph -> [Vertex]
-vertices = indices
-
--- | All edges of a graph.
-edges :: Graph -> [Edge]
-edges g = [ (v, w) | v <- vertices g, w <- g!v ]
-
-mapT :: (Vertex -> a -> b) -> Table a -> Table b
-mapT f t = array (bounds t) [ (,) v (f v (t!v)) | v <- indices t ]
-
--- | Build a graph from a list of edges.
-buildG :: Bounds -> [Edge] -> Graph
-buildG bounds0 edges0 = accumArray (flip (:)) [] bounds0 edges0
-
--- | The graph obtained by reversing all edges.
-transposeG :: Graph -> Graph
-transposeG g = buildG (bounds g) (reverseE g)
-
-reverseE :: Graph -> [Edge]
-reverseE g = [ (w, v) | (v, w) <- edges g ]
-
--- | A table of the count of edges from each node.
-outdegree :: Graph -> Table Int
-outdegree = mapT numEdges
- where numEdges _ ws = length ws
-
--- | A table of the count of edges into each node.
-indegree :: Graph -> Table Int
-indegree = outdegree . transposeG
-
--- | Identical to 'graphFromEdges', except that the return value
--- does not include the function which maps keys to vertices. This
--- version of 'graphFromEdges' is for backwards compatibility.
-graphFromEdges'
- :: Ord key
- => [(node, key, [key])]
- -> (Graph, Vertex -> (node, key, [key]))
-graphFromEdges' x = (a,b) where
- (a,b,_) = graphFromEdges x
-
--- | Build a graph from a list of nodes uniquely identified by keys,
--- with a list of keys of nodes this node should have edges to.
--- The out-list may contain keys that don't correspond to
--- nodes of the graph; they are ignored.
-graphFromEdges
- :: Ord key
- => [(node, key, [key])]
- -> (Graph, Vertex -> (node, key, [key]), key -> Maybe Vertex)
-graphFromEdges edges0
- = (graph, \v -> vertex_map ! v, key_vertex)
- where
- max_v = length edges0 - 1
- bounds0 = (0,max_v) :: (Vertex, Vertex)
- sorted_edges = sortBy lt edges0
- edges1 = zipWith (,) [0..] sorted_edges
-
- graph = array bounds0 [(,) v (mapMaybe key_vertex ks) | (,) v (_, _, ks) <- edges1]
- key_map = array bounds0 [(,) v k | (,) v (_, k, _ ) <- edges1]
- vertex_map = array bounds0 edges1
-
- (_,k1,_) `lt` (_,k2,_) = k1 `compare` k2
-
- -- key_vertex :: key -> Maybe Vertex
- -- returns Nothing for non-interesting vertices
- key_vertex k = findVertex 0 max_v
- where
- findVertex a b | a > b
- = Nothing
- findVertex a b = case compare k (key_map ! mid) of
- LT -> findVertex a (mid-1)
- EQ -> Just mid
- GT -> findVertex (mid+1) b
- where
- mid = (a + b) `div` 2
-
--------------------------------------------------------------------------
--- -
--- Depth first search
--- -
--------------------------------------------------------------------------
-
--- | A spanning forest of the graph, obtained from a depth-first search of
--- the graph starting from each vertex in an unspecified order.
-dff :: Graph -> Forest Vertex
-dff g = dfs g (vertices g)
-
--- | A spanning forest of the part of the graph reachable from the listed
--- vertices, obtained from a depth-first search of the graph starting at
--- each of the listed vertices in order.
-dfs :: Graph -> [Vertex] -> Forest Vertex
-dfs g vs = prune (bounds g) (map (generate g) vs)
-
-generate :: Graph -> Vertex -> Tree Vertex
-generate g v = Node v (map (generate g) (g!v))
-
-prune :: Bounds -> Forest Vertex -> Forest Vertex
-prune bnds ts = run bnds (chop ts)
-
-chop :: Forest Vertex -> SetM s (Forest Vertex)
-chop [] = return []
-chop (Node v ts : us)
- = do
- visited <- contains v
- if visited then
- chop us
- else do
- include v
- as <- chop ts
- bs <- chop us
- return (Node v as : bs)
-
--- A monad holding a set of vertices visited so far.
-#if USE_ST_MONAD
-
--- Use the ST monad if available, for constant-time primitives.
-
-newtype SetM s a = SetM { runSetM :: STArray s Vertex Bool -> ST s a }
-
-instance Monad (SetM s) where
- return x = SetM $ const (return x)
- SetM v >>= f = SetM $ \ s -> do { x <- v s; runSetM (f x) s }
-
-run :: Bounds -> (forall s. SetM s a) -> a
-run bnds act = runST (newArray bnds False >>= runSetM act)
-
-contains :: Vertex -> SetM s Bool
-contains v = SetM $ \ m -> readArray m v
-
-include :: Vertex -> SetM s ()
-include v = SetM $ \ m -> writeArray m v True
-
-#else /* !USE_ST_MONAD */
-
--- Portable implementation using IntSet.
-
-newtype SetM s a = SetM { runSetM :: IntSet -> (a, IntSet) }
-
-instance Monad (SetM s) where
- return x = SetM $ \ s -> (x, s)
- SetM v >>= f = SetM $ \ s -> case v s of (x, s') -> runSetM (f x) s'
-
-run :: Bounds -> SetM s a -> a
-run _ act = fst (runSetM act Set.empty)
-
-contains :: Vertex -> SetM s Bool
-contains v = SetM $ \ m -> (Set.member v m, m)
-
-include :: Vertex -> SetM s ()
-include v = SetM $ \ m -> ((), Set.insert v m)
-
-#endif /* !USE_ST_MONAD */
-
--------------------------------------------------------------------------
--- -
--- Algorithms
--- -
--------------------------------------------------------------------------
-
-------------------------------------------------------------
--- Algorithm 1: depth first search numbering
-------------------------------------------------------------
-
-preorder :: Tree a -> [a]
-preorder (Node a ts) = a : preorderF ts
-
-preorderF :: Forest a -> [a]
-preorderF ts = concat (map preorder ts)
-
-tabulate :: Bounds -> [Vertex] -> Table Int
-tabulate bnds vs = array bnds (zipWith (,) vs [1..])
-
-preArr :: Bounds -> Forest Vertex -> Table Int
-preArr bnds = tabulate bnds . preorderF
-
-------------------------------------------------------------
--- Algorithm 2: topological sorting
-------------------------------------------------------------
-
-postorder :: Tree a -> [a]
-postorder (Node a ts) = postorderF ts ++ [a]
-
-postorderF :: Forest a -> [a]
-postorderF ts = concat (map postorder ts)
-
-postOrd :: Graph -> [Vertex]
-postOrd = postorderF . dff
-
--- | A topological sort of the graph.
--- The order is partially specified by the condition that a vertex /i/
--- precedes /j/ whenever /j/ is reachable from /i/ but not vice versa.
-topSort :: Graph -> [Vertex]
-topSort = reverse . postOrd
-
-------------------------------------------------------------
--- Algorithm 3: connected components
-------------------------------------------------------------
-
--- | The connected components of a graph.
--- Two vertices are connected if there is a path between them, traversing
--- edges in either direction.
-components :: Graph -> Forest Vertex
-components = dff . undirected
-
-undirected :: Graph -> Graph
-undirected g = buildG (bounds g) (edges g ++ reverseE g)
-
--- Algorithm 4: strongly connected components
-
--- | The strongly connected components of a graph.
-scc :: Graph -> Forest Vertex
-scc g = dfs g (reverse (postOrd (transposeG g)))
-
-------------------------------------------------------------
--- Algorithm 5: Classifying edges
-------------------------------------------------------------
-
-tree :: Bounds -> Forest Vertex -> Graph
-tree bnds ts = buildG bnds (concat (map flat ts))
- where flat (Node v ts) = [ (v, w) | Node w _us <- ts ] ++ concat (map flat ts)
-
-back :: Graph -> Table Int -> Graph
-back g post = mapT select g
- where select v ws = [ w | w <- ws, post!v < post!w ]
-
-cross :: Graph -> Table Int -> Table Int -> Graph
-cross g pre post = mapT select g
- where select v ws = [ w | w <- ws, post!v > post!w, pre!v > pre!w ]
-
-forward :: Graph -> Graph -> Table Int -> Graph
-forward g tree pre = mapT select g
- where select v ws = [ w | w <- ws, pre!v < pre!w ] \\ tree!v
-
-------------------------------------------------------------
--- Algorithm 6: Finding reachable vertices
-------------------------------------------------------------
-
--- | A list of vertices reachable from a given vertex.
-reachable :: Graph -> Vertex -> [Vertex]
-reachable g v = preorderF (dfs g [v])
-
--- | Is the second vertex reachable from the first?
-path :: Graph -> Vertex -> Vertex -> Bool
-path g v w = w `elem` (reachable g v)
-
-------------------------------------------------------------
--- Algorithm 7: Biconnected components
-------------------------------------------------------------
-
--- | The biconnected components of a graph.
--- An undirected graph is biconnected if the deletion of any vertex
--- leaves it connected.
-bcc :: Graph -> Forest [Vertex]
-bcc g = (concat . map bicomps . map (do_label g dnum)) forest
- where forest = dff g
- dnum = preArr (bounds g) forest
-
-do_label :: Graph -> Table Int -> Tree Vertex -> Tree (Vertex,Int,Int)
-do_label g dnum (Node v ts) = Node (v,dnum!v,lv) us
- where us = map (do_label g dnum) ts
- lv = minimum ([dnum!v] ++ [dnum!w | w <- g!v]
- ++ [lu | Node (u,du,lu) xs <- us])
-
-bicomps :: Tree (Vertex,Int,Int) -> Forest [Vertex]
-bicomps (Node (v,_,_) ts)
- = [ Node (v:vs) us | (l,Node vs us) <- map collect ts]
-
-collect :: Tree (Vertex,Int,Int) -> (Int, Tree [Vertex])
-collect (Node (v,dv,lv) ts) = (lv, Node (v:vs) cs)
- where collected = map collect ts
- vs = concat [ ws | (lw, Node ws us) <- collected, lw<dv]
- cs = concat [ if lw<dv then us else [Node (v:ws) us]
- | (lw, Node ws us) <- collected ]
+++ /dev/null
-{-# OPTIONS -cpp -fglasgow-exts -fno-bang-patterns #-}
------------------------------------------------------------------------------
--- |
--- Module : Data.IntMap
--- Copyright : (c) Daan Leijen 2002
--- License : BSD-style
--- Maintainer : libraries@haskell.org
--- Stability : provisional
--- Portability : portable
---
--- An efficient implementation of maps from integer keys to values.
---
--- Since many function names (but not the type name) clash with
--- "Prelude" names, this module is usually imported @qualified@, e.g.
---
--- > import Data.IntMap (IntMap)
--- > import qualified Data.IntMap as IntMap
---
--- The implementation is based on /big-endian patricia trees/. This data
--- structure performs especially well on binary operations like 'union'
--- and 'intersection'. However, my benchmarks show that it is also
--- (much) faster on insertions and deletions when compared to a generic
--- size-balanced map implementation (see "Data.Map" and "Data.FiniteMap").
---
--- * Chris Okasaki and Andy Gill, \"/Fast Mergeable Integer Maps/\",
--- Workshop on ML, September 1998, pages 77-86,
--- <http://www.cse.ogi.edu/~andy/pub/finite.htm>
---
--- * D.R. Morrison, \"/PATRICIA -- Practical Algorithm To Retrieve
--- Information Coded In Alphanumeric/\", Journal of the ACM, 15(4),
--- October 1968, pages 514-534.
---
--- Many operations have a worst-case complexity of /O(min(n,W))/.
--- This means that the operation can become linear in the number of
--- elements with a maximum of /W/ -- the number of bits in an 'Int'
--- (32 or 64).
------------------------------------------------------------------------------
-
-module Data.IntMap (
- -- * Map type
- IntMap, Key -- instance Eq,Show
-
- -- * Operators
- , (!), (\\)
-
- -- * Query
- , null
- , size
- , member
- , notMember
- , lookup
- , findWithDefault
-
- -- * Construction
- , empty
- , singleton
-
- -- ** Insertion
- , insert
- , insertWith, insertWithKey, insertLookupWithKey
-
- -- ** Delete\/Update
- , delete
- , adjust
- , adjustWithKey
- , update
- , updateWithKey
- , updateLookupWithKey
- , alter
-
- -- * Combine
-
- -- ** Union
- , union
- , unionWith
- , unionWithKey
- , unions
- , unionsWith
-
- -- ** Difference
- , difference
- , differenceWith
- , differenceWithKey
-
- -- ** Intersection
- , intersection
- , intersectionWith
- , intersectionWithKey
-
- -- * Traversal
- -- ** Map
- , map
- , mapWithKey
- , mapAccum
- , mapAccumWithKey
-
- -- ** Fold
- , fold
- , foldWithKey
-
- -- * Conversion
- , elems
- , keys
- , keysSet
- , assocs
-
- -- ** Lists
- , toList
- , fromList
- , fromListWith
- , fromListWithKey
-
- -- ** Ordered lists
- , toAscList
- , fromAscList
- , fromAscListWith
- , fromAscListWithKey
- , fromDistinctAscList
-
- -- * Filter
- , filter
- , filterWithKey
- , partition
- , partitionWithKey
-
- , mapMaybe
- , mapMaybeWithKey
- , mapEither
- , mapEitherWithKey
-
- , split
- , splitLookup
-
- -- * Submap
- , isSubmapOf, isSubmapOfBy
- , isProperSubmapOf, isProperSubmapOfBy
-
- -- * Min\/Max
-
- , maxView
- , minView
- , findMin
- , findMax
- , deleteMin
- , deleteMax
- , deleteFindMin
- , deleteFindMax
- , updateMin
- , updateMax
- , updateMinWithKey
- , updateMaxWithKey
- , minViewWithKey
- , maxViewWithKey
-
- -- * Debugging
- , showTree
- , showTreeWith
- ) where
-
-
-import Prelude hiding (lookup,map,filter,foldr,foldl,null)
-import Data.Bits
-import qualified Data.IntSet as IntSet
-import Data.Monoid (Monoid(..))
-import Data.Typeable
-import Data.Foldable (Foldable(foldMap))
-import Control.Monad ( liftM )
-import Control.Arrow (ArrowZero)
-{-
--- just for testing
-import qualified Prelude
-import Debug.QuickCheck
-import List (nub,sort)
-import qualified List
--}
-
-#if __GLASGOW_HASKELL__
-import Text.Read
-import Data.Generics.Basics (Data(..), mkNorepType)
-import Data.Generics.Instances ()
-#endif
-
-#if __GLASGOW_HASKELL__ >= 503
-import GHC.Exts ( Word(..), Int(..), shiftRL# )
-#elif __GLASGOW_HASKELL__
-import Word
-import GlaExts ( Word(..), Int(..), shiftRL# )
-#else
-import Data.Word
-#endif
-
-infixl 9 \\{-This comment teaches CPP correct behaviour -}
-
--- A "Nat" is a natural machine word (an unsigned Int)
-type Nat = Word
-
-natFromInt :: Key -> Nat
-natFromInt i = fromIntegral i
-
-intFromNat :: Nat -> Key
-intFromNat w = fromIntegral w
-
-shiftRL :: Nat -> Key -> Nat
-#if __GLASGOW_HASKELL__
-{--------------------------------------------------------------------
- GHC: use unboxing to get @shiftRL@ inlined.
---------------------------------------------------------------------}
-shiftRL (W# x) (I# i)
- = W# (shiftRL# x i)
-#else
-shiftRL x i = shiftR x i
-#endif
-
-{--------------------------------------------------------------------
- Operators
---------------------------------------------------------------------}
-
--- | /O(min(n,W))/. Find the value at a key.
--- Calls 'error' when the element can not be found.
-
-(!) :: IntMap a -> Key -> a
-m ! k = find' k m
-
--- | /O(n+m)/. See 'difference'.
-(\\) :: IntMap a -> IntMap b -> IntMap a
-m1 \\ m2 = difference m1 m2
-
-{--------------------------------------------------------------------
- Types
---------------------------------------------------------------------}
--- | A map of integers to values @a@.
-data IntMap a = Nil
- | Tip {-# UNPACK #-} !Key a
- | Bin {-# UNPACK #-} !Prefix {-# UNPACK #-} !Mask !(IntMap a) !(IntMap a)
-
-type Prefix = Int
-type Mask = Int
-type Key = Int
-
-instance Monoid (IntMap a) where
- mempty = empty
- mappend = union
- mconcat = unions
-
-instance Foldable IntMap where
- foldMap f Nil = mempty
- foldMap f (Tip _k v) = f v
- foldMap f (Bin _ _ l r) = foldMap f l `mappend` foldMap f r
-
-#if __GLASGOW_HASKELL__
-
-{--------------------------------------------------------------------
- A Data instance
---------------------------------------------------------------------}
-
--- This instance preserves data abstraction at the cost of inefficiency.
--- We omit reflection services for the sake of data abstraction.
-
-instance Data a => Data (IntMap a) where
- gfoldl f z im = z fromList `f` (toList im)
- toConstr _ = error "toConstr"
- gunfold _ _ = error "gunfold"
- dataTypeOf _ = mkNorepType "Data.IntMap.IntMap"
- dataCast1 f = gcast1 f
-
-#endif
-
-{--------------------------------------------------------------------
- Query
---------------------------------------------------------------------}
--- | /O(1)/. Is the map empty?
-null :: IntMap a -> Bool
-null Nil = True
-null other = False
-
--- | /O(n)/. Number of elements in the map.
-size :: IntMap a -> Int
-size t
- = case t of
- Bin p m l r -> size l + size r
- Tip k x -> 1
- Nil -> 0
-
--- | /O(min(n,W))/. Is the key a member of the map?
-member :: Key -> IntMap a -> Bool
-member k m
- = case lookup k m of
- Nothing -> False
- Just x -> True
-
--- | /O(log n)/. Is the key not a member of the map?
-notMember :: Key -> IntMap a -> Bool
-notMember k m = not $ member k m
-
--- | /O(min(n,W))/. Lookup the value at a key in the map.
-lookup :: (Monad m) => Key -> IntMap a -> m a
-lookup k t = case lookup' k t of
- Just x -> return x
- Nothing -> fail "Data.IntMap.lookup: Key not found"
-
-lookup' :: Key -> IntMap a -> Maybe a
-lookup' k t
- = let nk = natFromInt k in seq nk (lookupN nk t)
-
-lookupN :: Nat -> IntMap a -> Maybe a
-lookupN k t
- = case t of
- Bin p m l r
- | zeroN k (natFromInt m) -> lookupN k l
- | otherwise -> lookupN k r
- Tip kx x
- | (k == natFromInt kx) -> Just x
- | otherwise -> Nothing
- Nil -> Nothing
-
-find' :: Key -> IntMap a -> a
-find' k m
- = case lookup k m of
- Nothing -> error ("IntMap.find: key " ++ show k ++ " is not an element of the map")
- Just x -> x
-
-
--- | /O(min(n,W))/. The expression @('findWithDefault' def k map)@
--- returns the value at key @k@ or returns @def@ when the key is not an
--- element of the map.
-findWithDefault :: a -> Key -> IntMap a -> a
-findWithDefault def k m
- = case lookup k m of
- Nothing -> def
- Just x -> x
-
-{--------------------------------------------------------------------
- Construction
---------------------------------------------------------------------}
--- | /O(1)/. The empty map.
-empty :: IntMap a
-empty
- = Nil
-
--- | /O(1)/. A map of one element.
-singleton :: Key -> a -> IntMap a
-singleton k x
- = Tip k x
-
-{--------------------------------------------------------------------
- Insert
---------------------------------------------------------------------}
--- | /O(min(n,W))/. Insert a new key\/value pair in the map.
--- If the key is already present in the map, the associated value is
--- replaced with the supplied value, i.e. 'insert' is equivalent to
--- @'insertWith' 'const'@.
-insert :: Key -> a -> IntMap a -> IntMap a
-insert k x t
- = case t of
- Bin p m l r
- | nomatch k p m -> join k (Tip k x) p t
- | zero k m -> Bin p m (insert k x l) r
- | otherwise -> Bin p m l (insert k x r)
- Tip ky y
- | k==ky -> Tip k x
- | otherwise -> join k (Tip k x) ky t
- Nil -> Tip k x
-
--- right-biased insertion, used by 'union'
--- | /O(min(n,W))/. Insert with a combining function.
--- @'insertWith' f key value mp@
--- will insert the pair (key, value) into @mp@ if key does
--- not exist in the map. If the key does exist, the function will
--- insert @f new_value old_value@.
-insertWith :: (a -> a -> a) -> Key -> a -> IntMap a -> IntMap a
-insertWith f k x t
- = insertWithKey (\k x y -> f x y) k x t
-
--- | /O(min(n,W))/. Insert with a combining function.
--- @'insertWithKey' f key value mp@
--- will insert the pair (key, value) into @mp@ if key does
--- not exist in the map. If the key does exist, the function will
--- insert @f key new_value old_value@.
-insertWithKey :: (Key -> a -> a -> a) -> Key -> a -> IntMap a -> IntMap a
-insertWithKey f k x t
- = case t of
- Bin p m l r
- | nomatch k p m -> join k (Tip k x) p t
- | zero k m -> Bin p m (insertWithKey f k x l) r
- | otherwise -> Bin p m l (insertWithKey f k x r)
- Tip ky y
- | k==ky -> Tip k (f k x y)
- | otherwise -> join k (Tip k x) ky t
- Nil -> Tip k x
-
-
--- | /O(min(n,W))/. The expression (@'insertLookupWithKey' f k x map@)
--- is a pair where the first element is equal to (@'lookup' k map@)
--- and the second element equal to (@'insertWithKey' f k x map@).
-insertLookupWithKey :: (Key -> a -> a -> a) -> Key -> a -> IntMap a -> (Maybe a, IntMap a)
-insertLookupWithKey f k x t
- = case t of
- Bin p m l r
- | nomatch k p m -> (Nothing,join k (Tip k x) p t)
- | zero k m -> let (found,l') = insertLookupWithKey f k x l in (found,Bin p m l' r)
- | otherwise -> let (found,r') = insertLookupWithKey f k x r in (found,Bin p m l r')
- Tip ky y
- | k==ky -> (Just y,Tip k (f k x y))
- | otherwise -> (Nothing,join k (Tip k x) ky t)
- Nil -> (Nothing,Tip k x)
-
-
-{--------------------------------------------------------------------
- Deletion
- [delete] is the inlined version of [deleteWith (\k x -> Nothing)]
---------------------------------------------------------------------}
--- | /O(min(n,W))/. Delete a key and its value from the map. When the key is not
--- a member of the map, the original map is returned.
-delete :: Key -> IntMap a -> IntMap a
-delete k t
- = case t of
- Bin p m l r
- | nomatch k p m -> t
- | zero k m -> bin p m (delete k l) r
- | otherwise -> bin p m l (delete k r)
- Tip ky y
- | k==ky -> Nil
- | otherwise -> t
- Nil -> Nil
-
--- | /O(min(n,W))/. Adjust a value at a specific key. When the key is not
--- a member of the map, the original map is returned.
-adjust :: (a -> a) -> Key -> IntMap a -> IntMap a
-adjust f k m
- = adjustWithKey (\k x -> f x) k m
-
--- | /O(min(n,W))/. Adjust a value at a specific key. When the key is not
--- a member of the map, the original map is returned.
-adjustWithKey :: (Key -> a -> a) -> Key -> IntMap a -> IntMap a
-adjustWithKey f k m
- = updateWithKey (\k x -> Just (f k x)) k m
-
--- | /O(min(n,W))/. The expression (@'update' f k map@) updates the value @x@
--- at @k@ (if it is in the map). If (@f x@) is 'Nothing', the element is
--- deleted. If it is (@'Just' y@), the key @k@ is bound to the new value @y@.
-update :: (a -> Maybe a) -> Key -> IntMap a -> IntMap a
-update f k m
- = updateWithKey (\k x -> f x) k m
-
--- | /O(min(n,W))/. The expression (@'update' f k map@) updates the value @x@
--- at @k@ (if it is in the map). If (@f k x@) is 'Nothing', the element is
--- deleted. If it is (@'Just' y@), the key @k@ is bound to the new value @y@.
-updateWithKey :: (Key -> a -> Maybe a) -> Key -> IntMap a -> IntMap a
-updateWithKey f k t
- = case t of
- Bin p m l r
- | nomatch k p m -> t
- | zero k m -> bin p m (updateWithKey f k l) r
- | otherwise -> bin p m l (updateWithKey f k r)
- Tip ky y
- | k==ky -> case (f k y) of
- Just y' -> Tip ky y'
- Nothing -> Nil
- | otherwise -> t
- Nil -> Nil
-
--- | /O(min(n,W))/. Lookup and update.
-updateLookupWithKey :: (Key -> a -> Maybe a) -> Key -> IntMap a -> (Maybe a,IntMap a)
-updateLookupWithKey f k t
- = case t of
- Bin p m l r
- | nomatch k p m -> (Nothing,t)
- | zero k m -> let (found,l') = updateLookupWithKey f k l in (found,bin p m l' r)
- | otherwise -> let (found,r') = updateLookupWithKey f k r in (found,bin p m l r')
- Tip ky y
- | k==ky -> case (f k y) of
- Just y' -> (Just y,Tip ky y')
- Nothing -> (Just y,Nil)
- | otherwise -> (Nothing,t)
- Nil -> (Nothing,Nil)
-
-
-
--- | /O(log n)/. The expression (@'alter' f k map@) alters the value @x@ at @k@, or absence thereof.
--- 'alter' can be used to insert, delete, or update a value in a 'Map'.
--- In short : @'lookup' k ('alter' f k m) = f ('lookup' k m)@
-alter f k t
- = case t of
- Bin p m l r
- | nomatch k p m -> case f Nothing of
- Nothing -> t
- Just x -> join k (Tip k x) p t
- | zero k m -> bin p m (alter f k l) r
- | otherwise -> bin p m l (alter f k r)
- Tip ky y
- | k==ky -> case f (Just y) of
- Just x -> Tip ky x
- Nothing -> Nil
- | otherwise -> case f Nothing of
- Just x -> join k (Tip k x) ky t
- Nothing -> Tip ky y
- Nil -> case f Nothing of
- Just x -> Tip k x
- Nothing -> Nil
-
-
-{--------------------------------------------------------------------
- Union
---------------------------------------------------------------------}
--- | The union of a list of maps.
-unions :: [IntMap a] -> IntMap a
-unions xs
- = foldlStrict union empty xs
-
--- | The union of a list of maps, with a combining operation
-unionsWith :: (a->a->a) -> [IntMap a] -> IntMap a
-unionsWith f ts
- = foldlStrict (unionWith f) empty ts
-
--- | /O(n+m)/. The (left-biased) union of two maps.
--- It prefers the first map when duplicate keys are encountered,
--- i.e. (@'union' == 'unionWith' 'const'@).
-union :: IntMap a -> IntMap a -> IntMap a
-union t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)
- | shorter m1 m2 = union1
- | shorter m2 m1 = union2
- | p1 == p2 = Bin p1 m1 (union l1 l2) (union r1 r2)
- | otherwise = join p1 t1 p2 t2
- where
- union1 | nomatch p2 p1 m1 = join p1 t1 p2 t2
- | zero p2 m1 = Bin p1 m1 (union l1 t2) r1
- | otherwise = Bin p1 m1 l1 (union r1 t2)
-
- union2 | nomatch p1 p2 m2 = join p1 t1 p2 t2
- | zero p1 m2 = Bin p2 m2 (union t1 l2) r2
- | otherwise = Bin p2 m2 l2 (union t1 r2)
-
-union (Tip k x) t = insert k x t
-union t (Tip k x) = insertWith (\x y -> y) k x t -- right bias
-union Nil t = t
-union t Nil = t
-
--- | /O(n+m)/. The union with a combining function.
-unionWith :: (a -> a -> a) -> IntMap a -> IntMap a -> IntMap a
-unionWith f m1 m2
- = unionWithKey (\k x y -> f x y) m1 m2
-
--- | /O(n+m)/. The union with a combining function.
-unionWithKey :: (Key -> a -> a -> a) -> IntMap a -> IntMap a -> IntMap a
-unionWithKey f t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)
- | shorter m1 m2 = union1
- | shorter m2 m1 = union2
- | p1 == p2 = Bin p1 m1 (unionWithKey f l1 l2) (unionWithKey f r1 r2)
- | otherwise = join p1 t1 p2 t2
- where
- union1 | nomatch p2 p1 m1 = join p1 t1 p2 t2
- | zero p2 m1 = Bin p1 m1 (unionWithKey f l1 t2) r1
- | otherwise = Bin p1 m1 l1 (unionWithKey f r1 t2)
-
- union2 | nomatch p1 p2 m2 = join p1 t1 p2 t2
- | zero p1 m2 = Bin p2 m2 (unionWithKey f t1 l2) r2
- | otherwise = Bin p2 m2 l2 (unionWithKey f t1 r2)
-
-unionWithKey f (Tip k x) t = insertWithKey f k x t
-unionWithKey f t (Tip k x) = insertWithKey (\k x y -> f k y x) k x t -- right bias
-unionWithKey f Nil t = t
-unionWithKey f t Nil = t
-
-{--------------------------------------------------------------------
- Difference
---------------------------------------------------------------------}
--- | /O(n+m)/. Difference between two maps (based on keys).
-difference :: IntMap a -> IntMap b -> IntMap a
-difference t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)
- | shorter m1 m2 = difference1
- | shorter m2 m1 = difference2
- | p1 == p2 = bin p1 m1 (difference l1 l2) (difference r1 r2)
- | otherwise = t1
- where
- difference1 | nomatch p2 p1 m1 = t1
- | zero p2 m1 = bin p1 m1 (difference l1 t2) r1
- | otherwise = bin p1 m1 l1 (difference r1 t2)
-
- difference2 | nomatch p1 p2 m2 = t1
- | zero p1 m2 = difference t1 l2
- | otherwise = difference t1 r2
-
-difference t1@(Tip k x) t2
- | member k t2 = Nil
- | otherwise = t1
-
-difference Nil t = Nil
-difference t (Tip k x) = delete k t
-difference t Nil = t
-
--- | /O(n+m)/. Difference with a combining function.
-differenceWith :: (a -> b -> Maybe a) -> IntMap a -> IntMap b -> IntMap a
-differenceWith f m1 m2
- = differenceWithKey (\k x y -> f x y) m1 m2
-
--- | /O(n+m)/. Difference with a combining function. When two equal keys are
--- encountered, the combining function is applied to the key and both values.
--- If it returns 'Nothing', the element is discarded (proper set difference).
--- If it returns (@'Just' y@), the element is updated with a new value @y@.
-differenceWithKey :: (Key -> a -> b -> Maybe a) -> IntMap a -> IntMap b -> IntMap a
-differenceWithKey f t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)
- | shorter m1 m2 = difference1
- | shorter m2 m1 = difference2
- | p1 == p2 = bin p1 m1 (differenceWithKey f l1 l2) (differenceWithKey f r1 r2)
- | otherwise = t1
- where
- difference1 | nomatch p2 p1 m1 = t1
- | zero p2 m1 = bin p1 m1 (differenceWithKey f l1 t2) r1
- | otherwise = bin p1 m1 l1 (differenceWithKey f r1 t2)
-
- difference2 | nomatch p1 p2 m2 = t1
- | zero p1 m2 = differenceWithKey f t1 l2
- | otherwise = differenceWithKey f t1 r2
-
-differenceWithKey f t1@(Tip k x) t2
- = case lookup k t2 of
- Just y -> case f k x y of
- Just y' -> Tip k y'
- Nothing -> Nil
- Nothing -> t1
-
-differenceWithKey f Nil t = Nil
-differenceWithKey f t (Tip k y) = updateWithKey (\k x -> f k x y) k t
-differenceWithKey f t Nil = t
-
-
-{--------------------------------------------------------------------
- Intersection
---------------------------------------------------------------------}
--- | /O(n+m)/. The (left-biased) intersection of two maps (based on keys).
-intersection :: IntMap a -> IntMap b -> IntMap a
-intersection t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)
- | shorter m1 m2 = intersection1
- | shorter m2 m1 = intersection2
- | p1 == p2 = bin p1 m1 (intersection l1 l2) (intersection r1 r2)
- | otherwise = Nil
- where
- intersection1 | nomatch p2 p1 m1 = Nil
- | zero p2 m1 = intersection l1 t2
- | otherwise = intersection r1 t2
-
- intersection2 | nomatch p1 p2 m2 = Nil
- | zero p1 m2 = intersection t1 l2
- | otherwise = intersection t1 r2
-
-intersection t1@(Tip k x) t2
- | member k t2 = t1
- | otherwise = Nil
-intersection t (Tip k x)
- = case lookup k t of
- Just y -> Tip k y
- Nothing -> Nil
-intersection Nil t = Nil
-intersection t Nil = Nil
-
--- | /O(n+m)/. The intersection with a combining function.
-intersectionWith :: (a -> b -> a) -> IntMap a -> IntMap b -> IntMap a
-intersectionWith f m1 m2
- = intersectionWithKey (\k x y -> f x y) m1 m2
-
--- | /O(n+m)/. The intersection with a combining function.
-intersectionWithKey :: (Key -> a -> b -> a) -> IntMap a -> IntMap b -> IntMap a
-intersectionWithKey f t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)
- | shorter m1 m2 = intersection1
- | shorter m2 m1 = intersection2
- | p1 == p2 = bin p1 m1 (intersectionWithKey f l1 l2) (intersectionWithKey f r1 r2)
- | otherwise = Nil
- where
- intersection1 | nomatch p2 p1 m1 = Nil
- | zero p2 m1 = intersectionWithKey f l1 t2
- | otherwise = intersectionWithKey f r1 t2
-
- intersection2 | nomatch p1 p2 m2 = Nil
- | zero p1 m2 = intersectionWithKey f t1 l2
- | otherwise = intersectionWithKey f t1 r2
-
-intersectionWithKey f t1@(Tip k x) t2
- = case lookup k t2 of
- Just y -> Tip k (f k x y)
- Nothing -> Nil
-intersectionWithKey f t1 (Tip k y)
- = case lookup k t1 of
- Just x -> Tip k (f k x y)
- Nothing -> Nil
-intersectionWithKey f Nil t = Nil
-intersectionWithKey f t Nil = Nil
-
-
-{--------------------------------------------------------------------
- Min\/Max
---------------------------------------------------------------------}
-
--- | /O(log n)/. Update the value at the minimal key.
-updateMinWithKey :: (Key -> a -> a) -> IntMap a -> IntMap a
-updateMinWithKey f t
- = case t of
- Bin p m l r | m < 0 -> let t' = updateMinWithKeyUnsigned f l in Bin p m t' r
- Bin p m l r -> let t' = updateMinWithKeyUnsigned f r in Bin p m l t'
- Tip k y -> Tip k (f k y)
- Nil -> error "maxView: empty map has no maximal element"
-
-updateMinWithKeyUnsigned f t
- = case t of
- Bin p m l r -> let t' = updateMinWithKeyUnsigned f r in Bin p m l t'
- Tip k y -> Tip k (f k y)
-
--- | /O(log n)/. Update the value at the maximal key.
-updateMaxWithKey :: (Key -> a -> a) -> IntMap a -> IntMap a
-updateMaxWithKey f t
- = case t of
- Bin p m l r | m < 0 -> let t' = updateMaxWithKeyUnsigned f r in Bin p m r t'
- Bin p m l r -> let t' = updateMaxWithKeyUnsigned f l in Bin p m t' l
- Tip k y -> Tip k (f k y)
- Nil -> error "maxView: empty map has no maximal element"
-
-updateMaxWithKeyUnsigned f t
- = case t of
- Bin p m l r -> let t' = updateMaxWithKeyUnsigned f r in Bin p m l t'
- Tip k y -> Tip k (f k y)
-
-
--- | /O(log n)/. Retrieves the maximal (key,value) couple of the map, and the map stripped from that element.
--- @fail@s (in the monad) when passed an empty map.
-maxViewWithKey :: (Monad m) => IntMap a -> m ((Key, a), IntMap a)
-maxViewWithKey t
- = case t of
- Bin p m l r | m < 0 -> let (result, t') = maxViewUnsigned l in return (result, bin p m t' r)
- Bin p m l r -> let (result, t') = maxViewUnsigned r in return (result, bin p m l t')
- Tip k y -> return ((k,y), Nil)
- Nil -> fail "maxView: empty map has no maximal element"
-
-maxViewUnsigned t
- = case t of
- Bin p m l r -> let (result,t') = maxViewUnsigned r in (result,bin p m l t')
- Tip k y -> ((k,y), Nil)
-
--- | /O(log n)/. Retrieves the minimal (key,value) couple of the map, and the map stripped from that element.
--- @fail@s (in the monad) when passed an empty map.
-minViewWithKey :: (Monad m) => IntMap a -> m ((Key, a), IntMap a)
-minViewWithKey t
- = case t of
- Bin p m l r | m < 0 -> let (result, t') = minViewUnsigned r in return (result, bin p m l t')
- Bin p m l r -> let (result, t') = minViewUnsigned l in return (result, bin p m t' r)
- Tip k y -> return ((k,y),Nil)
- Nil -> fail "minView: empty map has no minimal element"
-
-minViewUnsigned t
- = case t of
- Bin p m l r -> let (result,t') = minViewUnsigned l in (result,bin p m t' r)
- Tip k y -> ((k,y),Nil)
-
-
--- | /O(log n)/. Update the value at the maximal key.
-updateMax :: (a -> a) -> IntMap a -> IntMap a
-updateMax f = updateMaxWithKey (const f)
-
--- | /O(log n)/. Update the value at the minimal key.
-updateMin :: (a -> a) -> IntMap a -> IntMap a
-updateMin f = updateMinWithKey (const f)
-
-
--- Duplicate the Identity monad here because base < mtl.
-newtype Identity a = Identity { runIdentity :: a }
-instance Monad Identity where
- return a = Identity a
- m >>= k = k (runIdentity m)
--- Similar to the Arrow instance.
-first f (x,y) = (f x,y)
-
-
--- | /O(log n)/. Retrieves the maximal key of the map, and the map stripped from that element.
--- @fail@s (in the monad) when passed an empty map.
-maxView t = liftM (first snd) (maxViewWithKey t)
-
--- | /O(log n)/. Retrieves the minimal key of the map, and the map stripped from that element.
--- @fail@s (in the monad) when passed an empty map.
-minView t = liftM (first snd) (minViewWithKey t)
-
--- | /O(log n)/. Delete and find the maximal element.
-deleteFindMax = runIdentity . maxView
-
--- | /O(log n)/. Delete and find the minimal element.
-deleteFindMin = runIdentity . minView
-
--- | /O(log n)/. The minimal key of the map.
-findMin = fst . runIdentity . minView
-
--- | /O(log n)/. The maximal key of the map.
-findMax = fst . runIdentity . maxView
-
--- | /O(log n)/. Delete the minimal key.
-deleteMin = snd . runIdentity . minView
-
--- | /O(log n)/. Delete the maximal key.
-deleteMax = snd . runIdentity . maxView
-
-
-{--------------------------------------------------------------------
- Submap
---------------------------------------------------------------------}
--- | /O(n+m)/. Is this a proper submap? (ie. a submap but not equal).
--- Defined as (@'isProperSubmapOf' = 'isProperSubmapOfBy' (==)@).
-isProperSubmapOf :: Eq a => IntMap a -> IntMap a -> Bool
-isProperSubmapOf m1 m2
- = isProperSubmapOfBy (==) m1 m2
-
-{- | /O(n+m)/. Is this a proper submap? (ie. a submap but not equal).
- The expression (@'isProperSubmapOfBy' f m1 m2@) returns 'True' when
- @m1@ and @m2@ are not equal,
- all keys in @m1@ are in @m2@, and when @f@ returns 'True' when
- applied to their respective values. For example, the following
- expressions are all 'True':
-
- > isProperSubmapOfBy (==) (fromList [(1,1)]) (fromList [(1,1),(2,2)])
- > isProperSubmapOfBy (<=) (fromList [(1,1)]) (fromList [(1,1),(2,2)])
-
- But the following are all 'False':
-
- > isProperSubmapOfBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1),(2,2)])
- > isProperSubmapOfBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1)])
- > isProperSubmapOfBy (<) (fromList [(1,1)]) (fromList [(1,1),(2,2)])
--}
-isProperSubmapOfBy :: (a -> b -> Bool) -> IntMap a -> IntMap b -> Bool
-isProperSubmapOfBy pred t1 t2
- = case submapCmp pred t1 t2 of
- LT -> True
- ge -> False
-
-submapCmp pred t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)
- | shorter m1 m2 = GT
- | shorter m2 m1 = submapCmpLt
- | p1 == p2 = submapCmpEq
- | otherwise = GT -- disjoint
- where
- submapCmpLt | nomatch p1 p2 m2 = GT
- | zero p1 m2 = submapCmp pred t1 l2
- | otherwise = submapCmp pred t1 r2
- submapCmpEq = case (submapCmp pred l1 l2, submapCmp pred r1 r2) of
- (GT,_ ) -> GT
- (_ ,GT) -> GT
- (EQ,EQ) -> EQ
- other -> LT
-
-submapCmp pred (Bin p m l r) t = GT
-submapCmp pred (Tip kx x) (Tip ky y)
- | (kx == ky) && pred x y = EQ
- | otherwise = GT -- disjoint
-submapCmp pred (Tip k x) t
- = case lookup k t of
- Just y | pred x y -> LT
- other -> GT -- disjoint
-submapCmp pred Nil Nil = EQ
-submapCmp pred Nil t = LT
-
--- | /O(n+m)/. Is this a submap?
--- Defined as (@'isSubmapOf' = 'isSubmapOfBy' (==)@).
-isSubmapOf :: Eq a => IntMap a -> IntMap a -> Bool
-isSubmapOf m1 m2
- = isSubmapOfBy (==) m1 m2
-
-{- | /O(n+m)/.
- The expression (@'isSubmapOfBy' f m1 m2@) returns 'True' if
- all keys in @m1@ are in @m2@, and when @f@ returns 'True' when
- applied to their respective values. For example, the following
- expressions are all 'True':
-
- > isSubmapOfBy (==) (fromList [(1,1)]) (fromList [(1,1),(2,2)])
- > isSubmapOfBy (<=) (fromList [(1,1)]) (fromList [(1,1),(2,2)])
- > isSubmapOfBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1),(2,2)])
-
- But the following are all 'False':
-
- > isSubmapOfBy (==) (fromList [(1,2)]) (fromList [(1,1),(2,2)])
- > isSubmapOfBy (<) (fromList [(1,1)]) (fromList [(1,1),(2,2)])
- > isSubmapOfBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1)])
--}
-
-isSubmapOfBy :: (a -> b -> Bool) -> IntMap a -> IntMap b -> Bool
-isSubmapOfBy pred t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)
- | shorter m1 m2 = False
- | shorter m2 m1 = match p1 p2 m2 && (if zero p1 m2 then isSubmapOfBy pred t1 l2
- else isSubmapOfBy pred t1 r2)
- | otherwise = (p1==p2) && isSubmapOfBy pred l1 l2 && isSubmapOfBy pred r1 r2
-isSubmapOfBy pred (Bin p m l r) t = False
-isSubmapOfBy pred (Tip k x) t = case lookup k t of
- Just y -> pred x y
- Nothing -> False
-isSubmapOfBy pred Nil t = True
-
-{--------------------------------------------------------------------
- Mapping
---------------------------------------------------------------------}
--- | /O(n)/. Map a function over all values in the map.
-map :: (a -> b) -> IntMap a -> IntMap b
-map f m
- = mapWithKey (\k x -> f x) m
-
--- | /O(n)/. Map a function over all values in the map.
-mapWithKey :: (Key -> a -> b) -> IntMap a -> IntMap b
-mapWithKey f t
- = case t of
- Bin p m l r -> Bin p m (mapWithKey f l) (mapWithKey f r)
- Tip k x -> Tip k (f k x)
- Nil -> Nil
-
--- | /O(n)/. The function @'mapAccum'@ threads an accumulating
--- argument through the map in ascending order of keys.
-mapAccum :: (a -> b -> (a,c)) -> a -> IntMap b -> (a,IntMap c)
-mapAccum f a m
- = mapAccumWithKey (\a k x -> f a x) a m
-
--- | /O(n)/. The function @'mapAccumWithKey'@ threads an accumulating
--- argument through the map in ascending order of keys.
-mapAccumWithKey :: (a -> Key -> b -> (a,c)) -> a -> IntMap b -> (a,IntMap c)
-mapAccumWithKey f a t
- = mapAccumL f a t
-
--- | /O(n)/. The function @'mapAccumL'@ threads an accumulating
--- argument through the map in ascending order of keys.
-mapAccumL :: (a -> Key -> b -> (a,c)) -> a -> IntMap b -> (a,IntMap c)
-mapAccumL f a t
- = case t of
- Bin p m l r -> let (a1,l') = mapAccumL f a l
- (a2,r') = mapAccumL f a1 r
- in (a2,Bin p m l' r')
- Tip k x -> let (a',x') = f a k x in (a',Tip k x')
- Nil -> (a,Nil)
-
-
--- | /O(n)/. The function @'mapAccumR'@ threads an accumulating
--- argument throught the map in descending order of keys.
-mapAccumR :: (a -> Key -> b -> (a,c)) -> a -> IntMap b -> (a,IntMap c)
-mapAccumR f a t
- = case t of
- Bin p m l r -> let (a1,r') = mapAccumR f a r
- (a2,l') = mapAccumR f a1 l
- in (a2,Bin p m l' r')
- Tip k x -> let (a',x') = f a k x in (a',Tip k x')
- Nil -> (a,Nil)
-
-{--------------------------------------------------------------------
- Filter
---------------------------------------------------------------------}
--- | /O(n)/. Filter all values that satisfy some predicate.
-filter :: (a -> Bool) -> IntMap a -> IntMap a
-filter p m
- = filterWithKey (\k x -> p x) m
-
--- | /O(n)/. Filter all keys\/values that satisfy some predicate.
-filterWithKey :: (Key -> a -> Bool) -> IntMap a -> IntMap a
-filterWithKey pred t
- = case t of
- Bin p m l r
- -> bin p m (filterWithKey pred l) (filterWithKey pred r)
- Tip k x
- | pred k x -> t
- | otherwise -> Nil
- Nil -> Nil
-
--- | /O(n)/. partition the map according to some predicate. The first
--- map contains all elements that satisfy the predicate, the second all
--- elements that fail the predicate. See also 'split'.
-partition :: (a -> Bool) -> IntMap a -> (IntMap a,IntMap a)
-partition p m
- = partitionWithKey (\k x -> p x) m
-
--- | /O(n)/. partition the map according to some predicate. The first
--- map contains all elements that satisfy the predicate, the second all
--- elements that fail the predicate. See also 'split'.
-partitionWithKey :: (Key -> a -> Bool) -> IntMap a -> (IntMap a,IntMap a)
-partitionWithKey pred t
- = case t of
- Bin p m l r
- -> let (l1,l2) = partitionWithKey pred l
- (r1,r2) = partitionWithKey pred r
- in (bin p m l1 r1, bin p m l2 r2)
- Tip k x
- | pred k x -> (t,Nil)
- | otherwise -> (Nil,t)
- Nil -> (Nil,Nil)
-
--- | /O(n)/. Map values and collect the 'Just' results.
-mapMaybe :: (a -> Maybe b) -> IntMap a -> IntMap b
-mapMaybe f m
- = mapMaybeWithKey (\k x -> f x) m
-
--- | /O(n)/. Map keys\/values and collect the 'Just' results.
-mapMaybeWithKey :: (Key -> a -> Maybe b) -> IntMap a -> IntMap b
-mapMaybeWithKey f (Bin p m l r)
- = bin p m (mapMaybeWithKey f l) (mapMaybeWithKey f r)
-mapMaybeWithKey f (Tip k x) = case f k x of
- Just y -> Tip k y
- Nothing -> Nil
-mapMaybeWithKey f Nil = Nil
-
--- | /O(n)/. Map values and separate the 'Left' and 'Right' results.
-mapEither :: (a -> Either b c) -> IntMap a -> (IntMap b, IntMap c)
-mapEither f m
- = mapEitherWithKey (\k x -> f x) m
-
--- | /O(n)/. Map keys\/values and separate the 'Left' and 'Right' results.
-mapEitherWithKey :: (Key -> a -> Either b c) -> IntMap a -> (IntMap b, IntMap c)
-mapEitherWithKey f (Bin p m l r)
- = (bin p m l1 r1, bin p m l2 r2)
- where
- (l1,l2) = mapEitherWithKey f l
- (r1,r2) = mapEitherWithKey f r
-mapEitherWithKey f (Tip k x) = case f k x of
- Left y -> (Tip k y, Nil)
- Right z -> (Nil, Tip k z)
-mapEitherWithKey f Nil = (Nil, Nil)
-
--- | /O(log n)/. The expression (@'split' k map@) is a pair @(map1,map2)@
--- where all keys in @map1@ are lower than @k@ and all keys in
--- @map2@ larger than @k@. Any key equal to @k@ is found in neither @map1@ nor @map2@.
-split :: Key -> IntMap a -> (IntMap a,IntMap a)
-split k t
- = case t of
- Bin p m l r
- | m < 0 -> (if k >= 0 -- handle negative numbers.
- then let (lt,gt) = split' k l in (union r lt, gt)
- else let (lt,gt) = split' k r in (lt, union gt l))
- | otherwise -> split' k t
- Tip ky y
- | k>ky -> (t,Nil)
- | k<ky -> (Nil,t)
- | otherwise -> (Nil,Nil)
- Nil -> (Nil,Nil)
-
-split' :: Key -> IntMap a -> (IntMap a,IntMap a)
-split' k t
- = case t of
- Bin p m l r
- | nomatch k p m -> if k>p then (t,Nil) else (Nil,t)
- | zero k m -> let (lt,gt) = split k l in (lt,union gt r)
- | otherwise -> let (lt,gt) = split k r in (union l lt,gt)
- Tip ky y
- | k>ky -> (t,Nil)
- | k<ky -> (Nil,t)
- | otherwise -> (Nil,Nil)
- Nil -> (Nil,Nil)
-
--- | /O(log n)/. Performs a 'split' but also returns whether the pivot
--- key was found in the original map.
-splitLookup :: Key -> IntMap a -> (IntMap a,Maybe a,IntMap a)
-splitLookup k t
- = case t of
- Bin p m l r
- | m < 0 -> (if k >= 0 -- handle negative numbers.
- then let (lt,found,gt) = splitLookup' k l in (union r lt,found, gt)
- else let (lt,found,gt) = splitLookup' k r in (lt,found, union gt l))
- | otherwise -> splitLookup' k t
- Tip ky y
- | k>ky -> (t,Nothing,Nil)
- | k<ky -> (Nil,Nothing,t)
- | otherwise -> (Nil,Just y,Nil)
- Nil -> (Nil,Nothing,Nil)
-
-splitLookup' :: Key -> IntMap a -> (IntMap a,Maybe a,IntMap a)
-splitLookup' k t
- = case t of
- Bin p m l r
- | nomatch k p m -> if k>p then (t,Nothing,Nil) else (Nil,Nothing,t)
- | zero k m -> let (lt,found,gt) = splitLookup k l in (lt,found,union gt r)
- | otherwise -> let (lt,found,gt) = splitLookup k r in (union l lt,found,gt)
- Tip ky y
- | k>ky -> (t,Nothing,Nil)
- | k<ky -> (Nil,Nothing,t)
- | otherwise -> (Nil,Just y,Nil)
- Nil -> (Nil,Nothing,Nil)
-
-{--------------------------------------------------------------------
- Fold
---------------------------------------------------------------------}
--- | /O(n)/. Fold the values in the map, such that
--- @'fold' f z == 'Prelude.foldr' f z . 'elems'@.
--- For example,
---
--- > elems map = fold (:) [] map
---
-fold :: (a -> b -> b) -> b -> IntMap a -> b
-fold f z t
- = foldWithKey (\k x y -> f x y) z t
-
--- | /O(n)/. Fold the keys and values in the map, such that
--- @'foldWithKey' f z == 'Prelude.foldr' ('uncurry' f) z . 'toAscList'@.
--- For example,
---
--- > keys map = foldWithKey (\k x ks -> k:ks) [] map
---
-foldWithKey :: (Key -> a -> b -> b) -> b -> IntMap a -> b
-foldWithKey f z t
- = foldr f z t
-
-foldr :: (Key -> a -> b -> b) -> b -> IntMap a -> b
-foldr f z t
- = case t of
- Bin 0 m l r | m < 0 -> foldr' f (foldr' f z l) r -- put negative numbers before.
- Bin _ _ _ _ -> foldr' f z t
- Tip k x -> f k x z
- Nil -> z
-
-foldr' :: (Key -> a -> b -> b) -> b -> IntMap a -> b
-foldr' f z t
- = case t of
- Bin p m l r -> foldr' f (foldr' f z r) l
- Tip k x -> f k x z
- Nil -> z
-
-
-
-{--------------------------------------------------------------------
- List variations
---------------------------------------------------------------------}
--- | /O(n)/.
--- Return all elements of the map in the ascending order of their keys.
-elems :: IntMap a -> [a]
-elems m
- = foldWithKey (\k x xs -> x:xs) [] m
-
--- | /O(n)/. Return all keys of the map in ascending order.
-keys :: IntMap a -> [Key]
-keys m
- = foldWithKey (\k x ks -> k:ks) [] m
-
--- | /O(n*min(n,W))/. The set of all keys of the map.
-keysSet :: IntMap a -> IntSet.IntSet
-keysSet m = IntSet.fromDistinctAscList (keys m)
-
-
--- | /O(n)/. Return all key\/value pairs in the map in ascending key order.
-assocs :: IntMap a -> [(Key,a)]
-assocs m
- = toList m
-
-
-{--------------------------------------------------------------------
- Lists
---------------------------------------------------------------------}
--- | /O(n)/. Convert the map to a list of key\/value pairs.
-toList :: IntMap a -> [(Key,a)]
-toList t
- = foldWithKey (\k x xs -> (k,x):xs) [] t
-
--- | /O(n)/. Convert the map to a list of key\/value pairs where the
--- keys are in ascending order.
-toAscList :: IntMap a -> [(Key,a)]
-toAscList t
- = -- NOTE: the following algorithm only works for big-endian trees
- let (pos,neg) = span (\(k,x) -> k >=0) (foldr (\k x xs -> (k,x):xs) [] t) in neg ++ pos
-
--- | /O(n*min(n,W))/. Create a map from a list of key\/value pairs.
-fromList :: [(Key,a)] -> IntMap a
-fromList xs
- = foldlStrict ins empty xs
- where
- ins t (k,x) = insert k x t
-
--- | /O(n*min(n,W))/. Create a map from a list of key\/value pairs with a combining function. See also 'fromAscListWith'.
-fromListWith :: (a -> a -> a) -> [(Key,a)] -> IntMap a
-fromListWith f xs
- = fromListWithKey (\k x y -> f x y) xs
-
--- | /O(n*min(n,W))/. Build a map from a list of key\/value pairs with a combining function. See also fromAscListWithKey'.
-fromListWithKey :: (Key -> a -> a -> a) -> [(Key,a)] -> IntMap a
-fromListWithKey f xs
- = foldlStrict ins empty xs
- where
- ins t (k,x) = insertWithKey f k x t
-
--- | /O(n*min(n,W))/. Build a map from a list of key\/value pairs where
--- the keys are in ascending order.
-fromAscList :: [(Key,a)] -> IntMap a
-fromAscList xs
- = fromList xs
-
--- | /O(n*min(n,W))/. Build a map from a list of key\/value pairs where
--- the keys are in ascending order, with a combining function on equal keys.
-fromAscListWith :: (a -> a -> a) -> [(Key,a)] -> IntMap a
-fromAscListWith f xs
- = fromListWith f xs
-
--- | /O(n*min(n,W))/. Build a map from a list of key\/value pairs where
--- the keys are in ascending order, with a combining function on equal keys.
-fromAscListWithKey :: (Key -> a -> a -> a) -> [(Key,a)] -> IntMap a
-fromAscListWithKey f xs
- = fromListWithKey f xs
-
--- | /O(n*min(n,W))/. Build a map from a list of key\/value pairs where
--- the keys are in ascending order and all distinct.
-fromDistinctAscList :: [(Key,a)] -> IntMap a
-fromDistinctAscList xs
- = fromList xs
-
-
-{--------------------------------------------------------------------
- Eq
---------------------------------------------------------------------}
-instance Eq a => Eq (IntMap a) where
- t1 == t2 = equal t1 t2
- t1 /= t2 = nequal t1 t2
-
-equal :: Eq a => IntMap a -> IntMap a -> Bool
-equal (Bin p1 m1 l1 r1) (Bin p2 m2 l2 r2)
- = (m1 == m2) && (p1 == p2) && (equal l1 l2) && (equal r1 r2)
-equal (Tip kx x) (Tip ky y)
- = (kx == ky) && (x==y)
-equal Nil Nil = True
-equal t1 t2 = False
-
-nequal :: Eq a => IntMap a -> IntMap a -> Bool
-nequal (Bin p1 m1 l1 r1) (Bin p2 m2 l2 r2)
- = (m1 /= m2) || (p1 /= p2) || (nequal l1 l2) || (nequal r1 r2)
-nequal (Tip kx x) (Tip ky y)
- = (kx /= ky) || (x/=y)
-nequal Nil Nil = False
-nequal t1 t2 = True
-
-{--------------------------------------------------------------------
- Ord
---------------------------------------------------------------------}
-
-instance Ord a => Ord (IntMap a) where
- compare m1 m2 = compare (toList m1) (toList m2)
-
-{--------------------------------------------------------------------
- Functor
---------------------------------------------------------------------}
-
-instance Functor IntMap where
- fmap = map
-
-{--------------------------------------------------------------------
- Show
---------------------------------------------------------------------}
-
-instance Show a => Show (IntMap a) where
- showsPrec d m = showParen (d > 10) $
- showString "fromList " . shows (toList m)
-
-showMap :: (Show a) => [(Key,a)] -> ShowS
-showMap []
- = showString "{}"
-showMap (x:xs)
- = showChar '{' . showElem x . showTail xs
- where
- showTail [] = showChar '}'
- showTail (x:xs) = showChar ',' . showElem x . showTail xs
-
- showElem (k,x) = shows k . showString ":=" . shows x
-
-{--------------------------------------------------------------------
- Read
---------------------------------------------------------------------}
-instance (Read e) => Read (IntMap e) where
-#ifdef __GLASGOW_HASKELL__
- readPrec = parens $ prec 10 $ do
- Ident "fromList" <- lexP
- xs <- readPrec
- return (fromList xs)
-
- readListPrec = readListPrecDefault
-#else
- readsPrec p = readParen (p > 10) $ \ r -> do
- ("fromList",s) <- lex r
- (xs,t) <- reads s
- return (fromList xs,t)
-#endif
-
-{--------------------------------------------------------------------
- Typeable
---------------------------------------------------------------------}
-
-#include "Typeable.h"
-INSTANCE_TYPEABLE1(IntMap,intMapTc,"IntMap")
-
-{--------------------------------------------------------------------
- Debugging
---------------------------------------------------------------------}
--- | /O(n)/. Show the tree that implements the map. The tree is shown
--- in a compressed, hanging format.
-showTree :: Show a => IntMap a -> String
-showTree s
- = showTreeWith True False s
-
-
-{- | /O(n)/. The expression (@'showTreeWith' hang wide map@) shows
- the tree that implements the map. If @hang@ is
- 'True', a /hanging/ tree is shown otherwise a rotated tree is shown. If
- @wide@ is 'True', an extra wide version is shown.
--}
-showTreeWith :: Show a => Bool -> Bool -> IntMap a -> String
-showTreeWith hang wide t
- | hang = (showsTreeHang wide [] t) ""
- | otherwise = (showsTree wide [] [] t) ""
-
-showsTree :: Show a => Bool -> [String] -> [String] -> IntMap a -> ShowS
-showsTree wide lbars rbars t
- = case t of
- Bin p m l r
- -> showsTree wide (withBar rbars) (withEmpty rbars) r .
- showWide wide rbars .
- showsBars lbars . showString (showBin p m) . showString "\n" .
- showWide wide lbars .
- showsTree wide (withEmpty lbars) (withBar lbars) l
- Tip k x
- -> showsBars lbars . showString " " . shows k . showString ":=" . shows x . showString "\n"
- Nil -> showsBars lbars . showString "|\n"
-
-showsTreeHang :: Show a => Bool -> [String] -> IntMap a -> ShowS
-showsTreeHang wide bars t
- = case t of
- Bin p m l r
- -> showsBars bars . showString (showBin p m) . showString "\n" .
- showWide wide bars .
- showsTreeHang wide (withBar bars) l .
- showWide wide bars .
- showsTreeHang wide (withEmpty bars) r
- Tip k x
- -> showsBars bars . showString " " . shows k . showString ":=" . shows x . showString "\n"
- Nil -> showsBars bars . showString "|\n"
-
-showBin p m
- = "*" -- ++ show (p,m)
-
-showWide wide bars
- | wide = showString (concat (reverse bars)) . showString "|\n"
- | otherwise = id
-
-showsBars :: [String] -> ShowS
-showsBars bars
- = case bars of
- [] -> id
- _ -> showString (concat (reverse (tail bars))) . showString node
-
-node = "+--"
-withBar bars = "| ":bars
-withEmpty bars = " ":bars
-
-
-{--------------------------------------------------------------------
- Helpers
---------------------------------------------------------------------}
-{--------------------------------------------------------------------
- Join
---------------------------------------------------------------------}
-join :: Prefix -> IntMap a -> Prefix -> IntMap a -> IntMap a
-join p1 t1 p2 t2
- | zero p1 m = Bin p m t1 t2
- | otherwise = Bin p m t2 t1
- where
- m = branchMask p1 p2
- p = mask p1 m
-
-{--------------------------------------------------------------------
- @bin@ assures that we never have empty trees within a tree.
---------------------------------------------------------------------}
-bin :: Prefix -> Mask -> IntMap a -> IntMap a -> IntMap a
-bin p m l Nil = l
-bin p m Nil r = r
-bin p m l r = Bin p m l r
-
-
-{--------------------------------------------------------------------
- Endian independent bit twiddling
---------------------------------------------------------------------}
-zero :: Key -> Mask -> Bool
-zero i m
- = (natFromInt i) .&. (natFromInt m) == 0
-
-nomatch,match :: Key -> Prefix -> Mask -> Bool
-nomatch i p m
- = (mask i m) /= p
-
-match i p m
- = (mask i m) == p
-
-mask :: Key -> Mask -> Prefix
-mask i m
- = maskW (natFromInt i) (natFromInt m)
-
-
-zeroN :: Nat -> Nat -> Bool
-zeroN i m = (i .&. m) == 0
-
-{--------------------------------------------------------------------
- Big endian operations
---------------------------------------------------------------------}
-maskW :: Nat -> Nat -> Prefix
-maskW i m
- = intFromNat (i .&. (complement (m-1) `xor` m))
-
-shorter :: Mask -> Mask -> Bool
-shorter m1 m2
- = (natFromInt m1) > (natFromInt m2)
-
-branchMask :: Prefix -> Prefix -> Mask
-branchMask p1 p2
- = intFromNat (highestBitMask (natFromInt p1 `xor` natFromInt p2))
-
-{----------------------------------------------------------------------
- Finding the highest bit (mask) in a word [x] can be done efficiently in
- three ways:
- * convert to a floating point value and the mantissa tells us the
- [log2(x)] that corresponds with the highest bit position. The mantissa
- is retrieved either via the standard C function [frexp] or by some bit
- twiddling on IEEE compatible numbers (float). Note that one needs to
- use at least [double] precision for an accurate mantissa of 32 bit
- numbers.
- * use bit twiddling, a logarithmic sequence of bitwise or's and shifts (bit).
- * use processor specific assembler instruction (asm).
-
- The most portable way would be [bit], but is it efficient enough?
- I have measured the cycle counts of the different methods on an AMD
- Athlon-XP 1800 (~ Pentium III 1.8Ghz) using the RDTSC instruction:
-
- highestBitMask: method cycles
- --------------
- frexp 200
- float 33
- bit 11
- asm 12
-
- highestBit: method cycles
- --------------
- frexp 195
- float 33
- bit 11
- asm 11
-
- Wow, the bit twiddling is on today's RISC like machines even faster
- than a single CISC instruction (BSR)!
-----------------------------------------------------------------------}
-
-{----------------------------------------------------------------------
- [highestBitMask] returns a word where only the highest bit is set.
- It is found by first setting all bits in lower positions than the
- highest bit and than taking an exclusive or with the original value.
- Allthough the function may look expensive, GHC compiles this into
- excellent C code that subsequently compiled into highly efficient
- machine code. The algorithm is derived from Jorg Arndt's FXT library.
-----------------------------------------------------------------------}
-highestBitMask :: Nat -> Nat
-highestBitMask x
- = case (x .|. shiftRL x 1) of
- x -> case (x .|. shiftRL x 2) of
- x -> case (x .|. shiftRL x 4) of
- x -> case (x .|. shiftRL x 8) of
- x -> case (x .|. shiftRL x 16) of
- x -> case (x .|. shiftRL x 32) of -- for 64 bit platforms
- x -> (x `xor` (shiftRL x 1))
-
-
-{--------------------------------------------------------------------
- Utilities
---------------------------------------------------------------------}
-foldlStrict f z xs
- = case xs of
- [] -> z
- (x:xx) -> let z' = f z x in seq z' (foldlStrict f z' xx)
-
-{-
-{--------------------------------------------------------------------
- Testing
---------------------------------------------------------------------}
-testTree :: [Int] -> IntMap Int
-testTree xs = fromList [(x,x*x*30696 `mod` 65521) | x <- xs]
-test1 = testTree [1..20]
-test2 = testTree [30,29..10]
-test3 = testTree [1,4,6,89,2323,53,43,234,5,79,12,9,24,9,8,423,8,42,4,8,9,3]
-
-{--------------------------------------------------------------------
- QuickCheck
---------------------------------------------------------------------}
-qcheck prop
- = check config prop
- where
- config = Config
- { configMaxTest = 500
- , configMaxFail = 5000
- , configSize = \n -> (div n 2 + 3)
- , configEvery = \n args -> let s = show n in s ++ [ '\b' | _ <- s ]
- }
-
-
-{--------------------------------------------------------------------
- Arbitrary, reasonably balanced trees
---------------------------------------------------------------------}
-instance Arbitrary a => Arbitrary (IntMap a) where
- arbitrary = do{ ks <- arbitrary
- ; xs <- mapM (\k -> do{ x <- arbitrary; return (k,x)}) ks
- ; return (fromList xs)
- }
-
-
-{--------------------------------------------------------------------
- Single, Insert, Delete
---------------------------------------------------------------------}
-prop_Single :: Key -> Int -> Bool
-prop_Single k x
- = (insert k x empty == singleton k x)
-
-prop_InsertDelete :: Key -> Int -> IntMap Int -> Property
-prop_InsertDelete k x t
- = not (member k t) ==> delete k (insert k x t) == t
-
-prop_UpdateDelete :: Key -> IntMap Int -> Bool
-prop_UpdateDelete k t
- = update (const Nothing) k t == delete k t
-
-
-{--------------------------------------------------------------------
- Union
---------------------------------------------------------------------}
-prop_UnionInsert :: Key -> Int -> IntMap Int -> Bool
-prop_UnionInsert k x t
- = union (singleton k x) t == insert k x t
-
-prop_UnionAssoc :: IntMap Int -> IntMap Int -> IntMap Int -> Bool
-prop_UnionAssoc t1 t2 t3
- = union t1 (union t2 t3) == union (union t1 t2) t3
-
-prop_UnionComm :: IntMap Int -> IntMap Int -> Bool
-prop_UnionComm t1 t2
- = (union t1 t2 == unionWith (\x y -> y) t2 t1)
-
-
-prop_Diff :: [(Key,Int)] -> [(Key,Int)] -> Bool
-prop_Diff xs ys
- = List.sort (keys (difference (fromListWith (+) xs) (fromListWith (+) ys)))
- == List.sort ((List.\\) (nub (Prelude.map fst xs)) (nub (Prelude.map fst ys)))
-
-prop_Int :: [(Key,Int)] -> [(Key,Int)] -> Bool
-prop_Int xs ys
- = List.sort (keys (intersection (fromListWith (+) xs) (fromListWith (+) ys)))
- == List.sort (nub ((List.intersect) (Prelude.map fst xs) (Prelude.map fst ys)))
-
-{--------------------------------------------------------------------
- Lists
---------------------------------------------------------------------}
-prop_Ordered
- = forAll (choose (5,100)) $ \n ->
- let xs = [(x,()) | x <- [0..n::Int]]
- in fromAscList xs == fromList xs
-
-prop_List :: [Key] -> Bool
-prop_List xs
- = (sort (nub xs) == [x | (x,()) <- toAscList (fromList [(x,()) | x <- xs])])
--}
+++ /dev/null
-{-# OPTIONS -cpp -fglasgow-exts #-}
------------------------------------------------------------------------------
--- |
--- Module : Data.IntSet
--- Copyright : (c) Daan Leijen 2002
--- License : BSD-style
--- Maintainer : libraries@haskell.org
--- Stability : provisional
--- Portability : portable
---
--- An efficient implementation of integer sets.
---
--- Since many function names (but not the type name) clash with
--- "Prelude" names, this module is usually imported @qualified@, e.g.
---
--- > import Data.IntSet (IntSet)
--- > import qualified Data.IntSet as IntSet
---
--- The implementation is based on /big-endian patricia trees/. This data
--- structure performs especially well on binary operations like 'union'
--- and 'intersection'. However, my benchmarks show that it is also
--- (much) faster on insertions and deletions when compared to a generic
--- size-balanced set implementation (see "Data.Set").
---
--- * Chris Okasaki and Andy Gill, \"/Fast Mergeable Integer Maps/\",
--- Workshop on ML, September 1998, pages 77-86,
--- <http://www.cse.ogi.edu/~andy/pub/finite.htm>
---
--- * D.R. Morrison, \"/PATRICIA -- Practical Algorithm To Retrieve
--- Information Coded In Alphanumeric/\", Journal of the ACM, 15(4),
--- October 1968, pages 514-534.
---
--- Many operations have a worst-case complexity of /O(min(n,W))/.
--- This means that the operation can become linear in the number of
--- elements with a maximum of /W/ -- the number of bits in an 'Int'
--- (32 or 64).
------------------------------------------------------------------------------
-
-module Data.IntSet (
- -- * Set type
- IntSet -- instance Eq,Show
-
- -- * Operators
- , (\\)
-
- -- * Query
- , null
- , size
- , member
- , notMember
- , isSubsetOf
- , isProperSubsetOf
-
- -- * Construction
- , empty
- , singleton
- , insert
- , delete
-
- -- * Combine
- , union, unions
- , difference
- , intersection
-
- -- * Filter
- , filter
- , partition
- , split
- , splitMember
-
- -- * Min\/Max
- , findMin
- , findMax
- , deleteMin
- , deleteMax
- , deleteFindMin
- , deleteFindMax
- , maxView
- , minView
-
- -- * Map
- , map
-
- -- * Fold
- , fold
-
- -- * Conversion
- -- ** List
- , elems
- , toList
- , fromList
-
- -- ** Ordered list
- , toAscList
- , fromAscList
- , fromDistinctAscList
-
- -- * Debugging
- , showTree
- , showTreeWith
- ) where
-
-
-import Prelude hiding (lookup,filter,foldr,foldl,null,map)
-import Data.Bits
-
-import qualified Data.List as List
-import Data.Monoid (Monoid(..))
-import Data.Typeable
-
-{-
--- just for testing
-import QuickCheck
-import List (nub,sort)
-import qualified List
--}
-
-#if __GLASGOW_HASKELL__
-import Text.Read
-import Data.Generics.Basics (Data(..), mkNorepType)
-import Data.Generics.Instances ()
-#endif
-
-#if __GLASGOW_HASKELL__ >= 503
-import GHC.Exts ( Word(..), Int(..), shiftRL# )
-#elif __GLASGOW_HASKELL__
-import Word
-import GlaExts ( Word(..), Int(..), shiftRL# )
-#else
-import Data.Word
-#endif
-
-infixl 9 \\{-This comment teaches CPP correct behaviour -}
-
--- A "Nat" is a natural machine word (an unsigned Int)
-type Nat = Word
-
-natFromInt :: Int -> Nat
-natFromInt i = fromIntegral i
-
-intFromNat :: Nat -> Int
-intFromNat w = fromIntegral w
-
-shiftRL :: Nat -> Int -> Nat
-#if __GLASGOW_HASKELL__
-{--------------------------------------------------------------------
- GHC: use unboxing to get @shiftRL@ inlined.
---------------------------------------------------------------------}
-shiftRL (W# x) (I# i)
- = W# (shiftRL# x i)
-#else
-shiftRL x i = shiftR x i
-#endif
-
-{--------------------------------------------------------------------
- Operators
---------------------------------------------------------------------}
--- | /O(n+m)/. See 'difference'.
-(\\) :: IntSet -> IntSet -> IntSet
-m1 \\ m2 = difference m1 m2
-
-{--------------------------------------------------------------------
- Types
---------------------------------------------------------------------}
--- | A set of integers.
-data IntSet = Nil
- | Tip {-# UNPACK #-} !Int
- | Bin {-# UNPACK #-} !Prefix {-# UNPACK #-} !Mask !IntSet !IntSet
--- Invariant: Nil is never found as a child of Bin.
-
-
-type Prefix = Int
-type Mask = Int
-
-instance Monoid IntSet where
- mempty = empty
- mappend = union
- mconcat = unions
-
-#if __GLASGOW_HASKELL__
-
-{--------------------------------------------------------------------
- A Data instance
---------------------------------------------------------------------}
-
--- This instance preserves data abstraction at the cost of inefficiency.
--- We omit reflection services for the sake of data abstraction.
-
-instance Data IntSet where
- gfoldl f z is = z fromList `f` (toList is)
- toConstr _ = error "toConstr"
- gunfold _ _ = error "gunfold"
- dataTypeOf _ = mkNorepType "Data.IntSet.IntSet"
-
-#endif
-
-{--------------------------------------------------------------------
- Query
---------------------------------------------------------------------}
--- | /O(1)/. Is the set empty?
-null :: IntSet -> Bool
-null Nil = True
-null other = False
-
--- | /O(n)/. Cardinality of the set.
-size :: IntSet -> Int
-size t
- = case t of
- Bin p m l r -> size l + size r
- Tip y -> 1
- Nil -> 0
-
--- | /O(min(n,W))/. Is the value a member of the set?
-member :: Int -> IntSet -> Bool
-member x t
- = case t of
- Bin p m l r
- | nomatch x p m -> False
- | zero x m -> member x l
- | otherwise -> member x r
- Tip y -> (x==y)
- Nil -> False
-
--- | /O(min(n,W))/. Is the element not in the set?
-notMember :: Int -> IntSet -> Bool
-notMember k = not . member k
-
--- 'lookup' is used by 'intersection' for left-biasing
-lookup :: Int -> IntSet -> Maybe Int
-lookup k t
- = let nk = natFromInt k in seq nk (lookupN nk t)
-
-lookupN :: Nat -> IntSet -> Maybe Int
-lookupN k t
- = case t of
- Bin p m l r
- | zeroN k (natFromInt m) -> lookupN k l
- | otherwise -> lookupN k r
- Tip kx
- | (k == natFromInt kx) -> Just kx
- | otherwise -> Nothing
- Nil -> Nothing
-
-{--------------------------------------------------------------------
- Construction
---------------------------------------------------------------------}
--- | /O(1)/. The empty set.
-empty :: IntSet
-empty
- = Nil
-
--- | /O(1)/. A set of one element.
-singleton :: Int -> IntSet
-singleton x
- = Tip x
-
-{--------------------------------------------------------------------
- Insert
---------------------------------------------------------------------}
--- | /O(min(n,W))/. Add a value to the set. When the value is already
--- an element of the set, it is replaced by the new one, ie. 'insert'
--- is left-biased.
-insert :: Int -> IntSet -> IntSet
-insert x t
- = case t of
- Bin p m l r
- | nomatch x p m -> join x (Tip x) p t
- | zero x m -> Bin p m (insert x l) r
- | otherwise -> Bin p m l (insert x r)
- Tip y
- | x==y -> Tip x
- | otherwise -> join x (Tip x) y t
- Nil -> Tip x
-
--- right-biased insertion, used by 'union'
-insertR :: Int -> IntSet -> IntSet
-insertR x t
- = case t of
- Bin p m l r
- | nomatch x p m -> join x (Tip x) p t
- | zero x m -> Bin p m (insert x l) r
- | otherwise -> Bin p m l (insert x r)
- Tip y
- | x==y -> t
- | otherwise -> join x (Tip x) y t
- Nil -> Tip x
-
--- | /O(min(n,W))/. Delete a value in the set. Returns the
--- original set when the value was not present.
-delete :: Int -> IntSet -> IntSet
-delete x t
- = case t of
- Bin p m l r
- | nomatch x p m -> t
- | zero x m -> bin p m (delete x l) r
- | otherwise -> bin p m l (delete x r)
- Tip y
- | x==y -> Nil
- | otherwise -> t
- Nil -> Nil
-
-
-{--------------------------------------------------------------------
- Union
---------------------------------------------------------------------}
--- | The union of a list of sets.
-unions :: [IntSet] -> IntSet
-unions xs
- = foldlStrict union empty xs
-
-
--- | /O(n+m)/. The union of two sets.
-union :: IntSet -> IntSet -> IntSet
-union t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)
- | shorter m1 m2 = union1
- | shorter m2 m1 = union2
- | p1 == p2 = Bin p1 m1 (union l1 l2) (union r1 r2)
- | otherwise = join p1 t1 p2 t2
- where
- union1 | nomatch p2 p1 m1 = join p1 t1 p2 t2
- | zero p2 m1 = Bin p1 m1 (union l1 t2) r1
- | otherwise = Bin p1 m1 l1 (union r1 t2)
-
- union2 | nomatch p1 p2 m2 = join p1 t1 p2 t2
- | zero p1 m2 = Bin p2 m2 (union t1 l2) r2
- | otherwise = Bin p2 m2 l2 (union t1 r2)
-
-union (Tip x) t = insert x t
-union t (Tip x) = insertR x t -- right bias
-union Nil t = t
-union t Nil = t
-
-
-{--------------------------------------------------------------------
- Difference
---------------------------------------------------------------------}
--- | /O(n+m)/. Difference between two sets.
-difference :: IntSet -> IntSet -> IntSet
-difference t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)
- | shorter m1 m2 = difference1
- | shorter m2 m1 = difference2
- | p1 == p2 = bin p1 m1 (difference l1 l2) (difference r1 r2)
- | otherwise = t1
- where
- difference1 | nomatch p2 p1 m1 = t1
- | zero p2 m1 = bin p1 m1 (difference l1 t2) r1
- | otherwise = bin p1 m1 l1 (difference r1 t2)
-
- difference2 | nomatch p1 p2 m2 = t1
- | zero p1 m2 = difference t1 l2
- | otherwise = difference t1 r2
-
-difference t1@(Tip x) t2
- | member x t2 = Nil
- | otherwise = t1
-
-difference Nil t = Nil
-difference t (Tip x) = delete x t
-difference t Nil = t
-
-
-
-{--------------------------------------------------------------------
- Intersection
---------------------------------------------------------------------}
--- | /O(n+m)/. The intersection of two sets.
-intersection :: IntSet -> IntSet -> IntSet
-intersection t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)
- | shorter m1 m2 = intersection1
- | shorter m2 m1 = intersection2
- | p1 == p2 = bin p1 m1 (intersection l1 l2) (intersection r1 r2)
- | otherwise = Nil
- where
- intersection1 | nomatch p2 p1 m1 = Nil
- | zero p2 m1 = intersection l1 t2
- | otherwise = intersection r1 t2
-
- intersection2 | nomatch p1 p2 m2 = Nil
- | zero p1 m2 = intersection t1 l2
- | otherwise = intersection t1 r2
-
-intersection t1@(Tip x) t2
- | member x t2 = t1
- | otherwise = Nil
-intersection t (Tip x)
- = case lookup x t of
- Just y -> Tip y
- Nothing -> Nil
-intersection Nil t = Nil
-intersection t Nil = Nil
-
-
-
-{--------------------------------------------------------------------
- Subset
---------------------------------------------------------------------}
--- | /O(n+m)/. Is this a proper subset? (ie. a subset but not equal).
-isProperSubsetOf :: IntSet -> IntSet -> Bool
-isProperSubsetOf t1 t2
- = case subsetCmp t1 t2 of
- LT -> True
- ge -> False
-
-subsetCmp t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)
- | shorter m1 m2 = GT
- | shorter m2 m1 = subsetCmpLt
- | p1 == p2 = subsetCmpEq
- | otherwise = GT -- disjoint
- where
- subsetCmpLt | nomatch p1 p2 m2 = GT
- | zero p1 m2 = subsetCmp t1 l2
- | otherwise = subsetCmp t1 r2
- subsetCmpEq = case (subsetCmp l1 l2, subsetCmp r1 r2) of
- (GT,_ ) -> GT
- (_ ,GT) -> GT
- (EQ,EQ) -> EQ
- other -> LT
-
-subsetCmp (Bin p m l r) t = GT
-subsetCmp (Tip x) (Tip y)
- | x==y = EQ
- | otherwise = GT -- disjoint
-subsetCmp (Tip x) t
- | member x t = LT
- | otherwise = GT -- disjoint
-subsetCmp Nil Nil = EQ
-subsetCmp Nil t = LT
-
--- | /O(n+m)/. Is this a subset?
--- @(s1 `isSubsetOf` s2)@ tells whether @s1@ is a subset of @s2@.
-
-isSubsetOf :: IntSet -> IntSet -> Bool
-isSubsetOf t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)
- | shorter m1 m2 = False
- | shorter m2 m1 = match p1 p2 m2 && (if zero p1 m2 then isSubsetOf t1 l2
- else isSubsetOf t1 r2)
- | otherwise = (p1==p2) && isSubsetOf l1 l2 && isSubsetOf r1 r2
-isSubsetOf (Bin p m l r) t = False
-isSubsetOf (Tip x) t = member x t
-isSubsetOf Nil t = True
-
-
-{--------------------------------------------------------------------
- Filter
---------------------------------------------------------------------}
--- | /O(n)/. Filter all elements that satisfy some predicate.
-filter :: (Int -> Bool) -> IntSet -> IntSet
-filter pred t
- = case t of
- Bin p m l r
- -> bin p m (filter pred l) (filter pred r)
- Tip x
- | pred x -> t
- | otherwise -> Nil
- Nil -> Nil
-
--- | /O(n)/. partition the set according to some predicate.
-partition :: (Int -> Bool) -> IntSet -> (IntSet,IntSet)
-partition pred t
- = case t of
- Bin p m l r
- -> let (l1,l2) = partition pred l
- (r1,r2) = partition pred r
- in (bin p m l1 r1, bin p m l2 r2)
- Tip x
- | pred x -> (t,Nil)
- | otherwise -> (Nil,t)
- Nil -> (Nil,Nil)
-
-
--- | /O(min(n,W))/. The expression (@'split' x set@) is a pair @(set1,set2)@
--- where all elements in @set1@ are lower than @x@ and all elements in
--- @set2@ larger than @x@.
---
--- > split 3 (fromList [1..5]) == (fromList [1,2], fromList [3,4])
-split :: Int -> IntSet -> (IntSet,IntSet)
-split x t
- = case t of
- Bin p m l r
- | m < 0 -> if x >= 0 then let (lt,gt) = split' x l in (union r lt, gt)
- else let (lt,gt) = split' x r in (lt, union gt l)
- -- handle negative numbers.
- | otherwise -> split' x t
- Tip y
- | x>y -> (t,Nil)
- | x<y -> (Nil,t)
- | otherwise -> (Nil,Nil)
- Nil -> (Nil, Nil)
-
-split' :: Int -> IntSet -> (IntSet,IntSet)
-split' x t
- = case t of
- Bin p m l r
- | match x p m -> if zero x m then let (lt,gt) = split' x l in (lt,union gt r)
- else let (lt,gt) = split' x r in (union l lt,gt)
- | otherwise -> if x < p then (Nil, t)
- else (t, Nil)
- Tip y
- | x>y -> (t,Nil)
- | x<y -> (Nil,t)
- | otherwise -> (Nil,Nil)
- Nil -> (Nil,Nil)
-
--- | /O(min(n,W))/. Performs a 'split' but also returns whether the pivot
--- element was found in the original set.
-splitMember :: Int -> IntSet -> (IntSet,Bool,IntSet)
-splitMember x t
- = case t of
- Bin p m l r
- | m < 0 -> if x >= 0 then let (lt,found,gt) = splitMember' x l in (union r lt, found, gt)
- else let (lt,found,gt) = splitMember' x r in (lt, found, union gt l)
- -- handle negative numbers.
- | otherwise -> splitMember' x t
- Tip y
- | x>y -> (t,False,Nil)
- | x<y -> (Nil,False,t)
- | otherwise -> (Nil,True,Nil)
- Nil -> (Nil,False,Nil)
-
-splitMember' :: Int -> IntSet -> (IntSet,Bool,IntSet)
-splitMember' x t
- = case t of
- Bin p m l r
- | match x p m -> if zero x m then let (lt,found,gt) = splitMember x l in (lt,found,union gt r)
- else let (lt,found,gt) = splitMember x r in (union l lt,found,gt)
- | otherwise -> if x < p then (Nil, False, t)
- else (t, False, Nil)
- Tip y
- | x>y -> (t,False,Nil)
- | x<y -> (Nil,False,t)
- | otherwise -> (Nil,True,Nil)
- Nil -> (Nil,False,Nil)
-
-{----------------------------------------------------------------------
- Min/Max
-----------------------------------------------------------------------}
-
--- | /O(min(n,W))/. Retrieves the maximal key of the set, and the set stripped from that element
--- @fail@s (in the monad) when passed an empty set.
-maxView :: (Monad m) => IntSet -> m (Int, IntSet)
-maxView t
- = case t of
- Bin p m l r | m < 0 -> let (result,t') = maxViewUnsigned l in return (result, bin p m t' r)
- Bin p m l r -> let (result,t') = maxViewUnsigned r in return (result, bin p m l t')
- Tip y -> return (y,Nil)
- Nil -> fail "maxView: empty set has no maximal element"
-
-maxViewUnsigned :: IntSet -> (Int, IntSet)
-maxViewUnsigned t
- = case t of
- Bin p m l r -> let (result,t') = maxViewUnsigned r in (result, bin p m l t')
- Tip y -> (y, Nil)
-
--- | /O(min(n,W))/. Retrieves the minimal key of the set, and the set stripped from that element
--- @fail@s (in the monad) when passed an empty set.
-minView :: (Monad m) => IntSet -> m (Int, IntSet)
-minView t
- = case t of
- Bin p m l r | m < 0 -> let (result,t') = minViewUnsigned r in return (result, bin p m l t')
- Bin p m l r -> let (result,t') = minViewUnsigned l in return (result, bin p m t' r)
- Tip y -> return (y, Nil)
- Nil -> fail "minView: empty set has no minimal element"
-
-minViewUnsigned :: IntSet -> (Int, IntSet)
-minViewUnsigned t
- = case t of
- Bin p m l r -> let (result,t') = minViewUnsigned l in (result, bin p m t' r)
- Tip y -> (y, Nil)
-
-
--- Duplicate the Identity monad here because base < mtl.
-newtype Identity a = Identity { runIdentity :: a }
-instance Monad Identity where
- return a = Identity a
- m >>= k = k (runIdentity m)
-
-
--- | /O(min(n,W))/. Delete and find the minimal element.
---
--- > deleteFindMin set = (findMin set, deleteMin set)
-deleteFindMin :: IntSet -> (Int, IntSet)
-deleteFindMin = runIdentity . minView
-
--- | /O(min(n,W))/. Delete and find the maximal element.
---
--- > deleteFindMax set = (findMax set, deleteMax set)
-deleteFindMax :: IntSet -> (Int, IntSet)
-deleteFindMax = runIdentity . maxView
-
--- | /O(min(n,W))/. The minimal element of a set.
-findMin :: IntSet -> Int
-findMin = fst . runIdentity . minView
-
--- | /O(min(n,W))/. The maximal element of a set.
-findMax :: IntSet -> Int
-findMax = fst . runIdentity . maxView
-
--- | /O(min(n,W))/. Delete the minimal element.
-deleteMin :: IntSet -> IntSet
-deleteMin = snd . runIdentity . minView
-
--- | /O(min(n,W))/. Delete the maximal element.
-deleteMax :: IntSet -> IntSet
-deleteMax = snd . runIdentity . maxView
-
-
-
-{----------------------------------------------------------------------
- Map
-----------------------------------------------------------------------}
-
--- | /O(n*min(n,W))/.
--- @'map' f s@ is the set obtained by applying @f@ to each element of @s@.
---
--- It's worth noting that the size of the result may be smaller if,
--- for some @(x,y)@, @x \/= y && f x == f y@
-
-map :: (Int->Int) -> IntSet -> IntSet
-map f = fromList . List.map f . toList
-
-{--------------------------------------------------------------------
- Fold
---------------------------------------------------------------------}
--- | /O(n)/. Fold over the elements of a set in an unspecified order.
---
--- > sum set == fold (+) 0 set
--- > elems set == fold (:) [] set
-fold :: (Int -> b -> b) -> b -> IntSet -> b
-fold f z t
- = case t of
- Bin 0 m l r | m < 0 -> foldr f (foldr f z l) r
- -- put negative numbers before.
- Bin p m l r -> foldr f z t
- Tip x -> f x z
- Nil -> z
-
-foldr :: (Int -> b -> b) -> b -> IntSet -> b
-foldr f z t
- = case t of
- Bin p m l r -> foldr f (foldr f z r) l
- Tip x -> f x z
- Nil -> z
-
-{--------------------------------------------------------------------
- List variations
---------------------------------------------------------------------}
--- | /O(n)/. The elements of a set. (For sets, this is equivalent to toList)
-elems :: IntSet -> [Int]
-elems s
- = toList s
-
-{--------------------------------------------------------------------
- Lists
---------------------------------------------------------------------}
--- | /O(n)/. Convert the set to a list of elements.
-toList :: IntSet -> [Int]
-toList t
- = fold (:) [] t
-
--- | /O(n)/. Convert the set to an ascending list of elements.
-toAscList :: IntSet -> [Int]
-toAscList t = toList t
-
--- | /O(n*min(n,W))/. Create a set from a list of integers.
-fromList :: [Int] -> IntSet
-fromList xs
- = foldlStrict ins empty xs
- where
- ins t x = insert x t
-
--- | /O(n*min(n,W))/. Build a set from an ascending list of elements.
-fromAscList :: [Int] -> IntSet
-fromAscList xs
- = fromList xs
-
--- | /O(n*min(n,W))/. Build a set from an ascending list of distinct elements.
-fromDistinctAscList :: [Int] -> IntSet
-fromDistinctAscList xs
- = fromList xs
-
-
-{--------------------------------------------------------------------
- Eq
---------------------------------------------------------------------}
-instance Eq IntSet where
- t1 == t2 = equal t1 t2
- t1 /= t2 = nequal t1 t2
-
-equal :: IntSet -> IntSet -> Bool
-equal (Bin p1 m1 l1 r1) (Bin p2 m2 l2 r2)
- = (m1 == m2) && (p1 == p2) && (equal l1 l2) && (equal r1 r2)
-equal (Tip x) (Tip y)
- = (x==y)
-equal Nil Nil = True
-equal t1 t2 = False
-
-nequal :: IntSet -> IntSet -> Bool
-nequal (Bin p1 m1 l1 r1) (Bin p2 m2 l2 r2)
- = (m1 /= m2) || (p1 /= p2) || (nequal l1 l2) || (nequal r1 r2)
-nequal (Tip x) (Tip y)
- = (x/=y)
-nequal Nil Nil = False
-nequal t1 t2 = True
-
-{--------------------------------------------------------------------
- Ord
---------------------------------------------------------------------}
-
-instance Ord IntSet where
- compare s1 s2 = compare (toAscList s1) (toAscList s2)
- -- tentative implementation. See if more efficient exists.
-
-{--------------------------------------------------------------------
- Show
---------------------------------------------------------------------}
-instance Show IntSet where
- showsPrec p xs = showParen (p > 10) $
- showString "fromList " . shows (toList xs)
-
-showSet :: [Int] -> ShowS
-showSet []
- = showString "{}"
-showSet (x:xs)
- = showChar '{' . shows x . showTail xs
- where
- showTail [] = showChar '}'
- showTail (x:xs) = showChar ',' . shows x . showTail xs
-
-{--------------------------------------------------------------------
- Read
---------------------------------------------------------------------}
-instance Read IntSet where
-#ifdef __GLASGOW_HASKELL__
- readPrec = parens $ prec 10 $ do
- Ident "fromList" <- lexP
- xs <- readPrec
- return (fromList xs)
-
- readListPrec = readListPrecDefault
-#else
- readsPrec p = readParen (p > 10) $ \ r -> do
- ("fromList",s) <- lex r
- (xs,t) <- reads s
- return (fromList xs,t)
-#endif
-
-{--------------------------------------------------------------------
- Typeable
---------------------------------------------------------------------}
-
-#include "Typeable.h"
-INSTANCE_TYPEABLE0(IntSet,intSetTc,"IntSet")
-
-{--------------------------------------------------------------------
- Debugging
---------------------------------------------------------------------}
--- | /O(n)/. Show the tree that implements the set. The tree is shown
--- in a compressed, hanging format.
-showTree :: IntSet -> String
-showTree s
- = showTreeWith True False s
-
-
-{- | /O(n)/. The expression (@'showTreeWith' hang wide map@) shows
- the tree that implements the set. If @hang@ is
- 'True', a /hanging/ tree is shown otherwise a rotated tree is shown. If
- @wide@ is 'True', an extra wide version is shown.
--}
-showTreeWith :: Bool -> Bool -> IntSet -> String
-showTreeWith hang wide t
- | hang = (showsTreeHang wide [] t) ""
- | otherwise = (showsTree wide [] [] t) ""
-
-showsTree :: Bool -> [String] -> [String] -> IntSet -> ShowS
-showsTree wide lbars rbars t
- = case t of
- Bin p m l r
- -> showsTree wide (withBar rbars) (withEmpty rbars) r .
- showWide wide rbars .
- showsBars lbars . showString (showBin p m) . showString "\n" .
- showWide wide lbars .
- showsTree wide (withEmpty lbars) (withBar lbars) l
- Tip x
- -> showsBars lbars . showString " " . shows x . showString "\n"
- Nil -> showsBars lbars . showString "|\n"
-
-showsTreeHang :: Bool -> [String] -> IntSet -> ShowS
-showsTreeHang wide bars t
- = case t of
- Bin p m l r
- -> showsBars bars . showString (showBin p m) . showString "\n" .
- showWide wide bars .
- showsTreeHang wide (withBar bars) l .
- showWide wide bars .
- showsTreeHang wide (withEmpty bars) r
- Tip x
- -> showsBars bars . showString " " . shows x . showString "\n"
- Nil -> showsBars bars . showString "|\n"
-
-showBin p m
- = "*" -- ++ show (p,m)
-
-showWide wide bars
- | wide = showString (concat (reverse bars)) . showString "|\n"
- | otherwise = id
-
-showsBars :: [String] -> ShowS
-showsBars bars
- = case bars of
- [] -> id
- _ -> showString (concat (reverse (tail bars))) . showString node
-
-node = "+--"
-withBar bars = "| ":bars
-withEmpty bars = " ":bars
-
-
-{--------------------------------------------------------------------
- Helpers
---------------------------------------------------------------------}
-{--------------------------------------------------------------------
- Join
---------------------------------------------------------------------}
-join :: Prefix -> IntSet -> Prefix -> IntSet -> IntSet
-join p1 t1 p2 t2
- | zero p1 m = Bin p m t1 t2
- | otherwise = Bin p m t2 t1
- where
- m = branchMask p1 p2
- p = mask p1 m
-
-{--------------------------------------------------------------------
- @bin@ assures that we never have empty trees within a tree.
---------------------------------------------------------------------}
-bin :: Prefix -> Mask -> IntSet -> IntSet -> IntSet
-bin p m l Nil = l
-bin p m Nil r = r
-bin p m l r = Bin p m l r
-
-
-{--------------------------------------------------------------------
- Endian independent bit twiddling
---------------------------------------------------------------------}
-zero :: Int -> Mask -> Bool
-zero i m
- = (natFromInt i) .&. (natFromInt m) == 0
-
-nomatch,match :: Int -> Prefix -> Mask -> Bool
-nomatch i p m
- = (mask i m) /= p
-
-match i p m
- = (mask i m) == p
-
-mask :: Int -> Mask -> Prefix
-mask i m
- = maskW (natFromInt i) (natFromInt m)
-
-zeroN :: Nat -> Nat -> Bool
-zeroN i m = (i .&. m) == 0
-
-{--------------------------------------------------------------------
- Big endian operations
---------------------------------------------------------------------}
-maskW :: Nat -> Nat -> Prefix
-maskW i m
- = intFromNat (i .&. (complement (m-1) `xor` m))
-
-shorter :: Mask -> Mask -> Bool
-shorter m1 m2
- = (natFromInt m1) > (natFromInt m2)
-
-branchMask :: Prefix -> Prefix -> Mask
-branchMask p1 p2
- = intFromNat (highestBitMask (natFromInt p1 `xor` natFromInt p2))
-
-{----------------------------------------------------------------------
- Finding the highest bit (mask) in a word [x] can be done efficiently in
- three ways:
- * convert to a floating point value and the mantissa tells us the
- [log2(x)] that corresponds with the highest bit position. The mantissa
- is retrieved either via the standard C function [frexp] or by some bit
- twiddling on IEEE compatible numbers (float). Note that one needs to
- use at least [double] precision for an accurate mantissa of 32 bit
- numbers.
- * use bit twiddling, a logarithmic sequence of bitwise or's and shifts (bit).
- * use processor specific assembler instruction (asm).
-
- The most portable way would be [bit], but is it efficient enough?
- I have measured the cycle counts of the different methods on an AMD
- Athlon-XP 1800 (~ Pentium III 1.8Ghz) using the RDTSC instruction:
-
- highestBitMask: method cycles
- --------------
- frexp 200
- float 33
- bit 11
- asm 12
-
- highestBit: method cycles
- --------------
- frexp 195
- float 33
- bit 11
- asm 11
-
- Wow, the bit twiddling is on today's RISC like machines even faster
- than a single CISC instruction (BSR)!
-----------------------------------------------------------------------}
-
-{----------------------------------------------------------------------
- [highestBitMask] returns a word where only the highest bit is set.
- It is found by first setting all bits in lower positions than the
- highest bit and than taking an exclusive or with the original value.
- Allthough the function may look expensive, GHC compiles this into
- excellent C code that subsequently compiled into highly efficient
- machine code. The algorithm is derived from Jorg Arndt's FXT library.
-----------------------------------------------------------------------}
-highestBitMask :: Nat -> Nat
-highestBitMask x
- = case (x .|. shiftRL x 1) of
- x -> case (x .|. shiftRL x 2) of
- x -> case (x .|. shiftRL x 4) of
- x -> case (x .|. shiftRL x 8) of
- x -> case (x .|. shiftRL x 16) of
- x -> case (x .|. shiftRL x 32) of -- for 64 bit platforms
- x -> (x `xor` (shiftRL x 1))
-
-
-{--------------------------------------------------------------------
- Utilities
---------------------------------------------------------------------}
-foldlStrict f z xs
- = case xs of
- [] -> z
- (x:xx) -> let z' = f z x in seq z' (foldlStrict f z' xx)
-
-
-{-
-{--------------------------------------------------------------------
- Testing
---------------------------------------------------------------------}
-testTree :: [Int] -> IntSet
-testTree xs = fromList xs
-test1 = testTree [1..20]
-test2 = testTree [30,29..10]
-test3 = testTree [1,4,6,89,2323,53,43,234,5,79,12,9,24,9,8,423,8,42,4,8,9,3]
-
-{--------------------------------------------------------------------
- QuickCheck
---------------------------------------------------------------------}
-qcheck prop
- = check config prop
- where
- config = Config
- { configMaxTest = 500
- , configMaxFail = 5000
- , configSize = \n -> (div n 2 + 3)
- , configEvery = \n args -> let s = show n in s ++ [ '\b' | _ <- s ]
- }
-
-
-{--------------------------------------------------------------------
- Arbitrary, reasonably balanced trees
---------------------------------------------------------------------}
-instance Arbitrary IntSet where
- arbitrary = do{ xs <- arbitrary
- ; return (fromList xs)
- }
-
-
-{--------------------------------------------------------------------
- Single, Insert, Delete
---------------------------------------------------------------------}
-prop_Single :: Int -> Bool
-prop_Single x
- = (insert x empty == singleton x)
-
-prop_InsertDelete :: Int -> IntSet -> Property
-prop_InsertDelete k t
- = not (member k t) ==> delete k (insert k t) == t
-
-
-{--------------------------------------------------------------------
- Union
---------------------------------------------------------------------}
-prop_UnionInsert :: Int -> IntSet -> Bool
-prop_UnionInsert x t
- = union t (singleton x) == insert x t
-
-prop_UnionAssoc :: IntSet -> IntSet -> IntSet -> Bool
-prop_UnionAssoc t1 t2 t3
- = union t1 (union t2 t3) == union (union t1 t2) t3
-
-prop_UnionComm :: IntSet -> IntSet -> Bool
-prop_UnionComm t1 t2
- = (union t1 t2 == union t2 t1)
-
-prop_Diff :: [Int] -> [Int] -> Bool
-prop_Diff xs ys
- = toAscList (difference (fromList xs) (fromList ys))
- == List.sort ((List.\\) (nub xs) (nub ys))
-
-prop_Int :: [Int] -> [Int] -> Bool
-prop_Int xs ys
- = toAscList (intersection (fromList xs) (fromList ys))
- == List.sort (nub ((List.intersect) (xs) (ys)))
-
-{--------------------------------------------------------------------
- Lists
---------------------------------------------------------------------}
-prop_Ordered
- = forAll (choose (5,100)) $ \n ->
- let xs = [0..n::Int]
- in fromAscList xs == fromList xs
-
-prop_List :: [Int] -> Bool
-prop_List xs
- = (sort (nub xs) == toAscList (fromList xs))
--}
+++ /dev/null
-{-# OPTIONS_GHC -fno-bang-patterns #-}
-
------------------------------------------------------------------------------
--- |
--- Module : Data.Map
--- Copyright : (c) Daan Leijen 2002
--- License : BSD-style
--- Maintainer : libraries@haskell.org
--- Stability : provisional
--- Portability : portable
---
--- An efficient implementation of maps from keys to values (dictionaries).
---
--- Since many function names (but not the type name) clash with
--- "Prelude" names, this module is usually imported @qualified@, e.g.
---
--- > import Data.Map (Map)
--- > import qualified Data.Map as Map
---
--- The implementation of 'Map' is based on /size balanced/ binary trees (or
--- trees of /bounded balance/) as described by:
---
--- * Stephen Adams, \"/Efficient sets: a balancing act/\",
--- Journal of Functional Programming 3(4):553-562, October 1993,
--- <http://www.swiss.ai.mit.edu/~adams/BB>.
---
--- * J. Nievergelt and E.M. Reingold,
--- \"/Binary search trees of bounded balance/\",
--- SIAM journal of computing 2(1), March 1973.
---
--- Note that the implementation is /left-biased/ -- the elements of a
--- first argument are always preferred to the second, for example in
--- 'union' or 'insert'.
------------------------------------------------------------------------------
-
-module Data.Map (
- -- * Map type
- Map -- instance Eq,Show,Read
-
- -- * Operators
- , (!), (\\)
-
-
- -- * Query
- , null
- , size
- , member
- , notMember
- , lookup
- , findWithDefault
-
- -- * Construction
- , empty
- , singleton
-
- -- ** Insertion
- , insert
- , insertWith, insertWithKey, insertLookupWithKey
- , insertWith', insertWithKey'
-
- -- ** Delete\/Update
- , delete
- , adjust
- , adjustWithKey
- , update
- , updateWithKey
- , updateLookupWithKey
- , alter
-
- -- * Combine
-
- -- ** Union
- , union
- , unionWith
- , unionWithKey
- , unions
- , unionsWith
-
- -- ** Difference
- , difference
- , differenceWith
- , differenceWithKey
-
- -- ** Intersection
- , intersection
- , intersectionWith
- , intersectionWithKey
-
- -- * Traversal
- -- ** Map
- , map
- , mapWithKey
- , mapAccum
- , mapAccumWithKey
- , mapKeys
- , mapKeysWith
- , mapKeysMonotonic
-
- -- ** Fold
- , fold
- , foldWithKey
-
- -- * Conversion
- , elems
- , keys
- , keysSet
- , assocs
-
- -- ** Lists
- , toList
- , fromList
- , fromListWith
- , fromListWithKey
-
- -- ** Ordered lists
- , toAscList
- , fromAscList
- , fromAscListWith
- , fromAscListWithKey
- , fromDistinctAscList
-
- -- * Filter
- , filter
- , filterWithKey
- , partition
- , partitionWithKey
-
- , mapMaybe
- , mapMaybeWithKey
- , mapEither
- , mapEitherWithKey
-
- , split
- , splitLookup
-
- -- * Submap
- , isSubmapOf, isSubmapOfBy
- , isProperSubmapOf, isProperSubmapOfBy
-
- -- * Indexed
- , lookupIndex
- , findIndex
- , elemAt
- , updateAt
- , deleteAt
-
- -- * Min\/Max
- , findMin
- , findMax
- , deleteMin
- , deleteMax
- , deleteFindMin
- , deleteFindMax
- , updateMin
- , updateMax
- , updateMinWithKey
- , updateMaxWithKey
- , minView
- , maxView
- , minViewWithKey
- , maxViewWithKey
-
- -- * Debugging
- , showTree
- , showTreeWith
- , valid
- ) where
-
-import Prelude hiding (lookup,map,filter,foldr,foldl,null)
-import qualified Data.Set as Set
-import qualified Data.List as List
-import Data.Monoid (Monoid(..))
-import Data.Typeable
-import Control.Applicative (Applicative(..), (<$>))
-import Data.Traversable (Traversable(traverse))
-import Data.Foldable (Foldable(foldMap))
-
-{-
--- for quick check
-import qualified Prelude
-import qualified List
-import Debug.QuickCheck
-import List(nub,sort)
--}
-
-#if __GLASGOW_HASKELL__
-import Text.Read
-import Data.Generics.Basics
-import Data.Generics.Instances
-#endif
-
-{--------------------------------------------------------------------
- Operators
---------------------------------------------------------------------}
-infixl 9 !,\\ --
-
--- | /O(log n)/. Find the value at a key.
--- Calls 'error' when the element can not be found.
-(!) :: Ord k => Map k a -> k -> a
-m ! k = find k m
-
--- | /O(n+m)/. See 'difference'.
-(\\) :: Ord k => Map k a -> Map k b -> Map k a
-m1 \\ m2 = difference m1 m2
-
-{--------------------------------------------------------------------
- Size balanced trees.
---------------------------------------------------------------------}
--- | A Map from keys @k@ to values @a@.
-data Map k a = Tip
- | Bin {-# UNPACK #-} !Size !k a !(Map k a) !(Map k a)
-
-type Size = Int
-
-instance (Ord k) => Monoid (Map k v) where
- mempty = empty
- mappend = union
- mconcat = unions
-
-#if __GLASGOW_HASKELL__
-
-{--------------------------------------------------------------------
- A Data instance
---------------------------------------------------------------------}
-
--- This instance preserves data abstraction at the cost of inefficiency.
--- We omit reflection services for the sake of data abstraction.
-
-instance (Data k, Data a, Ord k) => Data (Map k a) where
- gfoldl f z map = z fromList `f` (toList map)
- toConstr _ = error "toConstr"
- gunfold _ _ = error "gunfold"
- dataTypeOf _ = mkNorepType "Data.Map.Map"
- dataCast2 f = gcast2 f
-
-#endif
-
-{--------------------------------------------------------------------
- Query
---------------------------------------------------------------------}
--- | /O(1)/. Is the map empty?
-null :: Map k a -> Bool
-null t
- = case t of
- Tip -> True
- Bin sz k x l r -> False
-
--- | /O(1)/. The number of elements in the map.
-size :: Map k a -> Int
-size t
- = case t of
- Tip -> 0
- Bin sz k x l r -> sz
-
-
--- | /O(log n)/. Lookup the value at a key in the map.
---
--- The function will
--- @return@ the result in the monad or @fail@ in it the key isn't in the
--- map. Often, the monad to use is 'Maybe', so you get either
--- @('Just' result)@ or @'Nothing'@.
-lookup :: (Monad m,Ord k) => k -> Map k a -> m a
-lookup k t = case lookup' k t of
- Just x -> return x
- Nothing -> fail "Data.Map.lookup: Key not found"
-lookup' :: Ord k => k -> Map k a -> Maybe a
-lookup' k t
- = case t of
- Tip -> Nothing
- Bin sz kx x l r
- -> case compare k kx of
- LT -> lookup' k l
- GT -> lookup' k r
- EQ -> Just x
-
-lookupAssoc :: Ord k => k -> Map k a -> Maybe (k,a)
-lookupAssoc k t
- = case t of
- Tip -> Nothing
- Bin sz kx x l r
- -> case compare k kx of
- LT -> lookupAssoc k l
- GT -> lookupAssoc k r
- EQ -> Just (kx,x)
-
--- | /O(log n)/. Is the key a member of the map?
-member :: Ord k => k -> Map k a -> Bool
-member k m
- = case lookup k m of
- Nothing -> False
- Just x -> True
-
--- | /O(log n)/. Is the key not a member of the map?
-notMember :: Ord k => k -> Map k a -> Bool
-notMember k m = not $ member k m
-
--- | /O(log n)/. Find the value at a key.
--- Calls 'error' when the element can not be found.
-find :: Ord k => k -> Map k a -> a
-find k m
- = case lookup k m of
- Nothing -> error "Map.find: element not in the map"
- Just x -> x
-
--- | /O(log n)/. The expression @('findWithDefault' def k map)@ returns
--- the value at key @k@ or returns @def@ when the key is not in the map.
-findWithDefault :: Ord k => a -> k -> Map k a -> a
-findWithDefault def k m
- = case lookup k m of
- Nothing -> def
- Just x -> x
-
-
-
-{--------------------------------------------------------------------
- Construction
---------------------------------------------------------------------}
--- | /O(1)/. The empty map.
-empty :: Map k a
-empty
- = Tip
-
--- | /O(1)/. A map with a single element.
-singleton :: k -> a -> Map k a
-singleton k x
- = Bin 1 k x Tip Tip
-
-{--------------------------------------------------------------------
- Insertion
---------------------------------------------------------------------}
--- | /O(log n)/. Insert a new key and value in the map.
--- If the key is already present in the map, the associated value is
--- replaced with the supplied value, i.e. 'insert' is equivalent to
--- @'insertWith' 'const'@.
-insert :: Ord k => k -> a -> Map k a -> Map k a
-insert kx x t
- = case t of
- Tip -> singleton kx x
- Bin sz ky y l r
- -> case compare kx ky of
- LT -> balance ky y (insert kx x l) r
- GT -> balance ky y l (insert kx x r)
- EQ -> Bin sz kx x l r
-
--- | /O(log n)/. Insert with a combining function.
--- @'insertWith' f key value mp@
--- will insert the pair (key, value) into @mp@ if key does
--- not exist in the map. If the key does exist, the function will
--- insert the pair @(key, f new_value old_value)@.
-insertWith :: Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
-insertWith f k x m
- = insertWithKey (\k x y -> f x y) k x m
-
--- | Same as 'insertWith', but the combining function is applied strictly.
-insertWith' :: Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
-insertWith' f k x m
- = insertWithKey' (\k x y -> f x y) k x m
-
-
--- | /O(log n)/. Insert with a combining function.
--- @'insertWithKey' f key value mp@
--- will insert the pair (key, value) into @mp@ if key does
--- not exist in the map. If the key does exist, the function will
--- insert the pair @(key,f key new_value old_value)@.
--- Note that the key passed to f is the same key passed to 'insertWithKey'.
-insertWithKey :: Ord k => (k -> a -> a -> a) -> k -> a -> Map k a -> Map k a
-insertWithKey f kx x t
- = case t of
- Tip -> singleton kx x
- Bin sy ky y l r
- -> case compare kx ky of
- LT -> balance ky y (insertWithKey f kx x l) r
- GT -> balance ky y l (insertWithKey f kx x r)
- EQ -> Bin sy kx (f kx x y) l r
-
--- | Same as 'insertWithKey', but the combining function is applied strictly.
-insertWithKey' :: Ord k => (k -> a -> a -> a) -> k -> a -> Map k a -> Map k a
-insertWithKey' f kx x t
- = case t of
- Tip -> singleton kx x
- Bin sy ky y l r
- -> case compare kx ky of
- LT -> balance ky y (insertWithKey' f kx x l) r
- GT -> balance ky y l (insertWithKey' f kx x r)
- EQ -> let x' = f kx x y in seq x' (Bin sy kx x' l r)
-
-
--- | /O(log n)/. The expression (@'insertLookupWithKey' f k x map@)
--- is a pair where the first element is equal to (@'lookup' k map@)
--- and the second element equal to (@'insertWithKey' f k x map@).
-insertLookupWithKey :: Ord k => (k -> a -> a -> a) -> k -> a -> Map k a -> (Maybe a,Map k a)
-insertLookupWithKey f kx x t
- = case t of
- Tip -> (Nothing, singleton kx x)
- Bin sy ky y l r
- -> case compare kx ky of
- LT -> let (found,l') = insertLookupWithKey f kx x l in (found,balance ky y l' r)
- GT -> let (found,r') = insertLookupWithKey f kx x r in (found,balance ky y l r')
- EQ -> (Just y, Bin sy kx (f kx x y) l r)
-
-{--------------------------------------------------------------------
- Deletion
- [delete] is the inlined version of [deleteWith (\k x -> Nothing)]
---------------------------------------------------------------------}
--- | /O(log n)/. Delete a key and its value from the map. When the key is not
--- a member of the map, the original map is returned.
-delete :: Ord k => k -> Map k a -> Map k a
-delete k t
- = case t of
- Tip -> Tip
- Bin sx kx x l r
- -> case compare k kx of
- LT -> balance kx x (delete k l) r
- GT -> balance kx x l (delete k r)
- EQ -> glue l r
-
--- | /O(log n)/. Adjust a value at a specific key. When the key is not
--- a member of the map, the original map is returned.
-adjust :: Ord k => (a -> a) -> k -> Map k a -> Map k a
-adjust f k m
- = adjustWithKey (\k x -> f x) k m
-
--- | /O(log n)/. Adjust a value at a specific key. When the key is not
--- a member of the map, the original map is returned.
-adjustWithKey :: Ord k => (k -> a -> a) -> k -> Map k a -> Map k a
-adjustWithKey f k m
- = updateWithKey (\k x -> Just (f k x)) k m
-
--- | /O(log n)/. The expression (@'update' f k map@) updates the value @x@
--- at @k@ (if it is in the map). If (@f x@) is 'Nothing', the element is
--- deleted. If it is (@'Just' y@), the key @k@ is bound to the new value @y@.
-update :: Ord k => (a -> Maybe a) -> k -> Map k a -> Map k a
-update f k m
- = updateWithKey (\k x -> f x) k m
-
--- | /O(log n)/. The expression (@'updateWithKey' f k map@) updates the
--- value @x@ at @k@ (if it is in the map). If (@f k x@) is 'Nothing',
--- the element is deleted. If it is (@'Just' y@), the key @k@ is bound
--- to the new value @y@.
-updateWithKey :: Ord k => (k -> a -> Maybe a) -> k -> Map k a -> Map k a
-updateWithKey f k t
- = case t of
- Tip -> Tip
- Bin sx kx x l r
- -> case compare k kx of
- LT -> balance kx x (updateWithKey f k l) r
- GT -> balance kx x l (updateWithKey f k r)
- EQ -> case f kx x of
- Just x' -> Bin sx kx x' l r
- Nothing -> glue l r
-
--- | /O(log n)/. Lookup and update.
-updateLookupWithKey :: Ord k => (k -> a -> Maybe a) -> k -> Map k a -> (Maybe a,Map k a)
-updateLookupWithKey f k t
- = case t of
- Tip -> (Nothing,Tip)
- Bin sx kx x l r
- -> case compare k kx of
- LT -> let (found,l') = updateLookupWithKey f k l in (found,balance kx x l' r)
- GT -> let (found,r') = updateLookupWithKey f k r in (found,balance kx x l r')
- EQ -> case f kx x of
- Just x' -> (Just x',Bin sx kx x' l r)
- Nothing -> (Just x,glue l r)
-
--- | /O(log n)/. The expression (@'alter' f k map@) alters the value @x@ at @k@, or absence thereof.
--- 'alter' can be used to insert, delete, or update a value in a 'Map'.
--- In short : @'lookup' k ('alter' f k m) = f ('lookup' k m)@
-alter :: Ord k => (Maybe a -> Maybe a) -> k -> Map k a -> Map k a
-alter f k t
- = case t of
- Tip -> case f Nothing of
- Nothing -> Tip
- Just x -> singleton k x
- Bin sx kx x l r
- -> case compare k kx of
- LT -> balance kx x (alter f k l) r
- GT -> balance kx x l (alter f k r)
- EQ -> case f (Just x) of
- Just x' -> Bin sx kx x' l r
- Nothing -> glue l r
-
-{--------------------------------------------------------------------
- Indexing
---------------------------------------------------------------------}
--- | /O(log n)/. Return the /index/ of a key. The index is a number from
--- /0/ up to, but not including, the 'size' of the map. Calls 'error' when
--- the key is not a 'member' of the map.
-findIndex :: Ord k => k -> Map k a -> Int
-findIndex k t
- = case lookupIndex k t of
- Nothing -> error "Map.findIndex: element is not in the map"
- Just idx -> idx
-
--- | /O(log n)/. Lookup the /index/ of a key. The index is a number from
--- /0/ up to, but not including, the 'size' of the map.
-lookupIndex :: (Monad m,Ord k) => k -> Map k a -> m Int
-lookupIndex k t = case lookup 0 t of
- Nothing -> fail "Data.Map.lookupIndex: Key not found."
- Just x -> return x
- where
- lookup idx Tip = Nothing
- lookup idx (Bin _ kx x l r)
- = case compare k kx of
- LT -> lookup idx l
- GT -> lookup (idx + size l + 1) r
- EQ -> Just (idx + size l)
-
--- | /O(log n)/. Retrieve an element by /index/. Calls 'error' when an
--- invalid index is used.
-elemAt :: Int -> Map k a -> (k,a)
-elemAt i Tip = error "Map.elemAt: index out of range"
-elemAt i (Bin _ kx x l r)
- = case compare i sizeL of
- LT -> elemAt i l
- GT -> elemAt (i-sizeL-1) r
- EQ -> (kx,x)
- where
- sizeL = size l
-
--- | /O(log n)/. Update the element at /index/. Calls 'error' when an
--- invalid index is used.
-updateAt :: (k -> a -> Maybe a) -> Int -> Map k a -> Map k a
-updateAt f i Tip = error "Map.updateAt: index out of range"
-updateAt f i (Bin sx kx x l r)
- = case compare i sizeL of
- LT -> balance kx x (updateAt f i l) r
- GT -> balance kx x l (updateAt f (i-sizeL-1) r)
- EQ -> case f kx x of
- Just x' -> Bin sx kx x' l r
- Nothing -> glue l r
- where
- sizeL = size l
-
--- | /O(log n)/. Delete the element at /index/.
--- Defined as (@'deleteAt' i map = 'updateAt' (\k x -> 'Nothing') i map@).
-deleteAt :: Int -> Map k a -> Map k a
-deleteAt i map
- = updateAt (\k x -> Nothing) i map
-
-
-{--------------------------------------------------------------------
- Minimal, Maximal
---------------------------------------------------------------------}
--- | /O(log n)/. The minimal key of the map.
-findMin :: Map k a -> (k,a)
-findMin (Bin _ kx x Tip r) = (kx,x)
-findMin (Bin _ kx x l r) = findMin l
-findMin Tip = error "Map.findMin: empty map has no minimal element"
-
--- | /O(log n)/. The maximal key of the map.
-findMax :: Map k a -> (k,a)
-findMax (Bin _ kx x l Tip) = (kx,x)
-findMax (Bin _ kx x l r) = findMax r
-findMax Tip = error "Map.findMax: empty map has no maximal element"
-
--- | /O(log n)/. Delete the minimal key.
-deleteMin :: Map k a -> Map k a
-deleteMin (Bin _ kx x Tip r) = r
-deleteMin (Bin _ kx x l r) = balance kx x (deleteMin l) r
-deleteMin Tip = Tip
-
--- | /O(log n)/. Delete the maximal key.
-deleteMax :: Map k a -> Map k a
-deleteMax (Bin _ kx x l Tip) = l
-deleteMax (Bin _ kx x l r) = balance kx x l (deleteMax r)
-deleteMax Tip = Tip
-
--- | /O(log n)/. Update the value at the minimal key.
-updateMin :: (a -> Maybe a) -> Map k a -> Map k a
-updateMin f m
- = updateMinWithKey (\k x -> f x) m
-
--- | /O(log n)/. Update the value at the maximal key.
-updateMax :: (a -> Maybe a) -> Map k a -> Map k a
-updateMax f m
- = updateMaxWithKey (\k x -> f x) m
-
-
--- | /O(log n)/. Update the value at the minimal key.
-updateMinWithKey :: (k -> a -> Maybe a) -> Map k a -> Map k a
-updateMinWithKey f t
- = case t of
- Bin sx kx x Tip r -> case f kx x of
- Nothing -> r
- Just x' -> Bin sx kx x' Tip r
- Bin sx kx x l r -> balance kx x (updateMinWithKey f l) r
- Tip -> Tip
-
--- | /O(log n)/. Update the value at the maximal key.
-updateMaxWithKey :: (k -> a -> Maybe a) -> Map k a -> Map k a
-updateMaxWithKey f t
- = case t of
- Bin sx kx x l Tip -> case f kx x of
- Nothing -> l
- Just x' -> Bin sx kx x' l Tip
- Bin sx kx x l r -> balance kx x l (updateMaxWithKey f r)
- Tip -> Tip
-
--- | /O(log n)/. Retrieves the minimal (key,value) pair of the map, and the map stripped from that element
--- @fail@s (in the monad) when passed an empty map.
-minViewWithKey :: Monad m => Map k a -> m ((k,a), Map k a)
-minViewWithKey Tip = fail "Map.minView: empty map"
-minViewWithKey x = return (deleteFindMin x)
-
--- | /O(log n)/. Retrieves the maximal (key,value) pair of the map, and the map stripped from that element
--- @fail@s (in the monad) when passed an empty map.
-maxViewWithKey :: Monad m => Map k a -> m ((k,a), Map k a)
-maxViewWithKey Tip = fail "Map.maxView: empty map"
-maxViewWithKey x = return (deleteFindMax x)
-
--- | /O(log n)/. Retrieves the minimal key\'s value of the map, and the map stripped from that element
--- @fail@s (in the monad) when passed an empty map.
-minView :: Monad m => Map k a -> m (a, Map k a)
-minView Tip = fail "Map.minView: empty map"
-minView x = return (first snd $ deleteFindMin x)
-
--- | /O(log n)/. Retrieves the maximal key\'s value of the map, and the map stripped from that element
--- @fail@s (in the monad) when passed an empty map.
-maxView :: Monad m => Map k a -> m (a, Map k a)
-maxView Tip = fail "Map.maxView: empty map"
-maxView x = return (first snd $ deleteFindMax x)
-
--- Update the 1st component of a tuple (special case of Control.Arrow.first)
-first :: (a -> b) -> (a,c) -> (b,c)
-first f (x,y) = (f x, y)
-
-{--------------------------------------------------------------------
- Union.
---------------------------------------------------------------------}
--- | The union of a list of maps:
--- (@'unions' == 'Prelude.foldl' 'union' 'empty'@).
-unions :: Ord k => [Map k a] -> Map k a
-unions ts
- = foldlStrict union empty ts
-
--- | The union of a list of maps, with a combining operation:
--- (@'unionsWith' f == 'Prelude.foldl' ('unionWith' f) 'empty'@).
-unionsWith :: Ord k => (a->a->a) -> [Map k a] -> Map k a
-unionsWith f ts
- = foldlStrict (unionWith f) empty ts
-
--- | /O(n+m)/.
--- The expression (@'union' t1 t2@) takes the left-biased union of @t1@ and @t2@.
--- It prefers @t1@ when duplicate keys are encountered,
--- i.e. (@'union' == 'unionWith' 'const'@).
--- The implementation uses the efficient /hedge-union/ algorithm.
--- Hedge-union is more efficient on (bigset `union` smallset)
-union :: Ord k => Map k a -> Map k a -> Map k a
-union Tip t2 = t2
-union t1 Tip = t1
-union t1 t2 = hedgeUnionL (const LT) (const GT) t1 t2
-
--- left-biased hedge union
-hedgeUnionL cmplo cmphi t1 Tip
- = t1
-hedgeUnionL cmplo cmphi Tip (Bin _ kx x l r)
- = join kx x (filterGt cmplo l) (filterLt cmphi r)
-hedgeUnionL cmplo cmphi (Bin _ kx x l r) t2
- = join kx x (hedgeUnionL cmplo cmpkx l (trim cmplo cmpkx t2))
- (hedgeUnionL cmpkx cmphi r (trim cmpkx cmphi t2))
- where
- cmpkx k = compare kx k
-
--- right-biased hedge union
-hedgeUnionR cmplo cmphi t1 Tip
- = t1
-hedgeUnionR cmplo cmphi Tip (Bin _ kx x l r)
- = join kx x (filterGt cmplo l) (filterLt cmphi r)
-hedgeUnionR cmplo cmphi (Bin _ kx x l r) t2
- = join kx newx (hedgeUnionR cmplo cmpkx l lt)
- (hedgeUnionR cmpkx cmphi r gt)
- where
- cmpkx k = compare kx k
- lt = trim cmplo cmpkx t2
- (found,gt) = trimLookupLo kx cmphi t2
- newx = case found of
- Nothing -> x
- Just (_,y) -> y
-
-{--------------------------------------------------------------------
- Union with a combining function
---------------------------------------------------------------------}
--- | /O(n+m)/. Union with a combining function. The implementation uses the efficient /hedge-union/ algorithm.
-unionWith :: Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
-unionWith f m1 m2
- = unionWithKey (\k x y -> f x y) m1 m2
-
--- | /O(n+m)/.
--- Union with a combining function. The implementation uses the efficient /hedge-union/ algorithm.
--- Hedge-union is more efficient on (bigset `union` smallset).
-unionWithKey :: Ord k => (k -> a -> a -> a) -> Map k a -> Map k a -> Map k a
-unionWithKey f Tip t2 = t2
-unionWithKey f t1 Tip = t1
-unionWithKey f t1 t2 = hedgeUnionWithKey f (const LT) (const GT) t1 t2
-
-hedgeUnionWithKey f cmplo cmphi t1 Tip
- = t1
-hedgeUnionWithKey f cmplo cmphi Tip (Bin _ kx x l r)
- = join kx x (filterGt cmplo l) (filterLt cmphi r)
-hedgeUnionWithKey f cmplo cmphi (Bin _ kx x l r) t2
- = join kx newx (hedgeUnionWithKey f cmplo cmpkx l lt)
- (hedgeUnionWithKey f cmpkx cmphi r gt)
- where
- cmpkx k = compare kx k
- lt = trim cmplo cmpkx t2
- (found,gt) = trimLookupLo kx cmphi t2
- newx = case found of
- Nothing -> x
- Just (_,y) -> f kx x y
-
-{--------------------------------------------------------------------
- Difference
---------------------------------------------------------------------}
--- | /O(n+m)/. Difference of two maps.
--- The implementation uses an efficient /hedge/ algorithm comparable with /hedge-union/.
-difference :: Ord k => Map k a -> Map k b -> Map k a
-difference Tip t2 = Tip
-difference t1 Tip = t1
-difference t1 t2 = hedgeDiff (const LT) (const GT) t1 t2
-
-hedgeDiff cmplo cmphi Tip t
- = Tip
-hedgeDiff cmplo cmphi (Bin _ kx x l r) Tip
- = join kx x (filterGt cmplo l) (filterLt cmphi r)
-hedgeDiff cmplo cmphi t (Bin _ kx x l r)
- = merge (hedgeDiff cmplo cmpkx (trim cmplo cmpkx t) l)
- (hedgeDiff cmpkx cmphi (trim cmpkx cmphi t) r)
- where
- cmpkx k = compare kx k
-
--- | /O(n+m)/. Difference with a combining function.
--- The implementation uses an efficient /hedge/ algorithm comparable with /hedge-union/.
-differenceWith :: Ord k => (a -> b -> Maybe a) -> Map k a -> Map k b -> Map k a
-differenceWith f m1 m2
- = differenceWithKey (\k x y -> f x y) m1 m2
-
--- | /O(n+m)/. Difference with a combining function. When two equal keys are
--- encountered, the combining function is applied to the key and both values.
--- If it returns 'Nothing', the element is discarded (proper set difference). If
--- it returns (@'Just' y@), the element is updated with a new value @y@.
--- The implementation uses an efficient /hedge/ algorithm comparable with /hedge-union/.
-differenceWithKey :: Ord k => (k -> a -> b -> Maybe a) -> Map k a -> Map k b -> Map k a
-differenceWithKey f Tip t2 = Tip
-differenceWithKey f t1 Tip = t1
-differenceWithKey f t1 t2 = hedgeDiffWithKey f (const LT) (const GT) t1 t2
-
-hedgeDiffWithKey f cmplo cmphi Tip t
- = Tip
-hedgeDiffWithKey f cmplo cmphi (Bin _ kx x l r) Tip
- = join kx x (filterGt cmplo l) (filterLt cmphi r)
-hedgeDiffWithKey f cmplo cmphi t (Bin _ kx x l r)
- = case found of
- Nothing -> merge tl tr
- Just (ky,y) ->
- case f ky y x of
- Nothing -> merge tl tr
- Just z -> join ky z tl tr
- where
- cmpkx k = compare kx k
- lt = trim cmplo cmpkx t
- (found,gt) = trimLookupLo kx cmphi t
- tl = hedgeDiffWithKey f cmplo cmpkx lt l
- tr = hedgeDiffWithKey f cmpkx cmphi gt r
-
-
-
-{--------------------------------------------------------------------
- Intersection
---------------------------------------------------------------------}
--- | /O(n+m)/. Intersection of two maps. The values in the first
--- map are returned, i.e. (@'intersection' m1 m2 == 'intersectionWith' 'const' m1 m2@).
-intersection :: Ord k => Map k a -> Map k b -> Map k a
-intersection m1 m2
- = intersectionWithKey (\k x y -> x) m1 m2
-
--- | /O(n+m)/. Intersection with a combining function.
-intersectionWith :: Ord k => (a -> b -> c) -> Map k a -> Map k b -> Map k c
-intersectionWith f m1 m2
- = intersectionWithKey (\k x y -> f x y) m1 m2
-
--- | /O(n+m)/. Intersection with a combining function.
--- Intersection is more efficient on (bigset `intersection` smallset)
---intersectionWithKey :: Ord k => (k -> a -> b -> c) -> Map k a -> Map k b -> Map k c
---intersectionWithKey f Tip t = Tip
---intersectionWithKey f t Tip = Tip
---intersectionWithKey f t1 t2 = intersectWithKey f t1 t2
---
---intersectWithKey f Tip t = Tip
---intersectWithKey f t Tip = Tip
---intersectWithKey f t (Bin _ kx x l r)
--- = case found of
--- Nothing -> merge tl tr
--- Just y -> join kx (f kx y x) tl tr
--- where
--- (lt,found,gt) = splitLookup kx t
--- tl = intersectWithKey f lt l
--- tr = intersectWithKey f gt r
-
-
-intersectionWithKey :: Ord k => (k -> a -> b -> c) -> Map k a -> Map k b -> Map k c
-intersectionWithKey f Tip t = Tip
-intersectionWithKey f t Tip = Tip
-intersectionWithKey f t1@(Bin s1 k1 x1 l1 r1) t2@(Bin s2 k2 x2 l2 r2) =
- if s1 >= s2 then
- let (lt,found,gt) = splitLookupWithKey k2 t1
- tl = intersectionWithKey f lt l2
- tr = intersectionWithKey f gt r2
- in case found of
- Just (k,x) -> join k (f k x x2) tl tr
- Nothing -> merge tl tr
- else let (lt,found,gt) = splitLookup k1 t2
- tl = intersectionWithKey f l1 lt
- tr = intersectionWithKey f r1 gt
- in case found of
- Just x -> join k1 (f k1 x1 x) tl tr
- Nothing -> merge tl tr
-
-
-
-{--------------------------------------------------------------------
- Submap
---------------------------------------------------------------------}
--- | /O(n+m)/.
--- This function is defined as (@'isSubmapOf' = 'isSubmapOfBy' (==)@).
-isSubmapOf :: (Ord k,Eq a) => Map k a -> Map k a -> Bool
-isSubmapOf m1 m2
- = isSubmapOfBy (==) m1 m2
-
-{- | /O(n+m)/.
- The expression (@'isSubmapOfBy' f t1 t2@) returns 'True' if
- all keys in @t1@ are in tree @t2@, and when @f@ returns 'True' when
- applied to their respective values. For example, the following
- expressions are all 'True':
-
- > isSubmapOfBy (==) (fromList [('a',1)]) (fromList [('a',1),('b',2)])
- > isSubmapOfBy (<=) (fromList [('a',1)]) (fromList [('a',1),('b',2)])
- > isSubmapOfBy (==) (fromList [('a',1),('b',2)]) (fromList [('a',1),('b',2)])
-
- But the following are all 'False':
-
- > isSubmapOfBy (==) (fromList [('a',2)]) (fromList [('a',1),('b',2)])
- > isSubmapOfBy (<) (fromList [('a',1)]) (fromList [('a',1),('b',2)])
- > isSubmapOfBy (==) (fromList [('a',1),('b',2)]) (fromList [('a',1)])
--}
-isSubmapOfBy :: Ord k => (a->b->Bool) -> Map k a -> Map k b -> Bool
-isSubmapOfBy f t1 t2
- = (size t1 <= size t2) && (submap' f t1 t2)
-
-submap' f Tip t = True
-submap' f t Tip = False
-submap' f (Bin _ kx x l r) t
- = case found of
- Nothing -> False
- Just y -> f x y && submap' f l lt && submap' f r gt
- where
- (lt,found,gt) = splitLookup kx t
-
--- | /O(n+m)/. Is this a proper submap? (ie. a submap but not equal).
--- Defined as (@'isProperSubmapOf' = 'isProperSubmapOfBy' (==)@).
-isProperSubmapOf :: (Ord k,Eq a) => Map k a -> Map k a -> Bool
-isProperSubmapOf m1 m2
- = isProperSubmapOfBy (==) m1 m2
-
-{- | /O(n+m)/. Is this a proper submap? (ie. a submap but not equal).
- The expression (@'isProperSubmapOfBy' f m1 m2@) returns 'True' when
- @m1@ and @m2@ are not equal,
- all keys in @m1@ are in @m2@, and when @f@ returns 'True' when
- applied to their respective values. For example, the following
- expressions are all 'True':
-
- > isProperSubmapOfBy (==) (fromList [(1,1)]) (fromList [(1,1),(2,2)])
- > isProperSubmapOfBy (<=) (fromList [(1,1)]) (fromList [(1,1),(2,2)])
-
- But the following are all 'False':
-
- > isProperSubmapOfBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1),(2,2)])
- > isProperSubmapOfBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1)])
- > isProperSubmapOfBy (<) (fromList [(1,1)]) (fromList [(1,1),(2,2)])
--}
-isProperSubmapOfBy :: Ord k => (a -> b -> Bool) -> Map k a -> Map k b -> Bool
-isProperSubmapOfBy f t1 t2
- = (size t1 < size t2) && (submap' f t1 t2)
-
-{--------------------------------------------------------------------
- Filter and partition
---------------------------------------------------------------------}
--- | /O(n)/. Filter all values that satisfy the predicate.
-filter :: Ord k => (a -> Bool) -> Map k a -> Map k a
-filter p m
- = filterWithKey (\k x -> p x) m
-
--- | /O(n)/. Filter all keys\/values that satisfy the predicate.
-filterWithKey :: Ord k => (k -> a -> Bool) -> Map k a -> Map k a
-filterWithKey p Tip = Tip
-filterWithKey p (Bin _ kx x l r)
- | p kx x = join kx x (filterWithKey p l) (filterWithKey p r)
- | otherwise = merge (filterWithKey p l) (filterWithKey p r)
-
-
--- | /O(n)/. partition the map according to a predicate. The first
--- map contains all elements that satisfy the predicate, the second all
--- elements that fail the predicate. See also 'split'.
-partition :: Ord k => (a -> Bool) -> Map k a -> (Map k a,Map k a)
-partition p m
- = partitionWithKey (\k x -> p x) m
-
--- | /O(n)/. partition the map according to a predicate. The first
--- map contains all elements that satisfy the predicate, the second all
--- elements that fail the predicate. See also 'split'.
-partitionWithKey :: Ord k => (k -> a -> Bool) -> Map k a -> (Map k a,Map k a)
-partitionWithKey p Tip = (Tip,Tip)
-partitionWithKey p (Bin _ kx x l r)
- | p kx x = (join kx x l1 r1,merge l2 r2)
- | otherwise = (merge l1 r1,join kx x l2 r2)
- where
- (l1,l2) = partitionWithKey p l
- (r1,r2) = partitionWithKey p r
-
--- | /O(n)/. Map values and collect the 'Just' results.
-mapMaybe :: Ord k => (a -> Maybe b) -> Map k a -> Map k b
-mapMaybe f m
- = mapMaybeWithKey (\k x -> f x) m
-
--- | /O(n)/. Map keys\/values and collect the 'Just' results.
-mapMaybeWithKey :: Ord k => (k -> a -> Maybe b) -> Map k a -> Map k b
-mapMaybeWithKey f Tip = Tip
-mapMaybeWithKey f (Bin _ kx x l r) = case f kx x of
- Just y -> join kx y (mapMaybeWithKey f l) (mapMaybeWithKey f r)
- Nothing -> merge (mapMaybeWithKey f l) (mapMaybeWithKey f r)
-
--- | /O(n)/. Map values and separate the 'Left' and 'Right' results.
-mapEither :: Ord k => (a -> Either b c) -> Map k a -> (Map k b, Map k c)
-mapEither f m
- = mapEitherWithKey (\k x -> f x) m
-
--- | /O(n)/. Map keys\/values and separate the 'Left' and 'Right' results.
-mapEitherWithKey :: Ord k =>
- (k -> a -> Either b c) -> Map k a -> (Map k b, Map k c)
-mapEitherWithKey f Tip = (Tip, Tip)
-mapEitherWithKey f (Bin _ kx x l r) = case f kx x of
- Left y -> (join kx y l1 r1, merge l2 r2)
- Right z -> (merge l1 r1, join kx z l2 r2)
- where
- (l1,l2) = mapEitherWithKey f l
- (r1,r2) = mapEitherWithKey f r
-
-{--------------------------------------------------------------------
- Mapping
---------------------------------------------------------------------}
--- | /O(n)/. Map a function over all values in the map.
-map :: (a -> b) -> Map k a -> Map k b
-map f m
- = mapWithKey (\k x -> f x) m
-
--- | /O(n)/. Map a function over all values in the map.
-mapWithKey :: (k -> a -> b) -> Map k a -> Map k b
-mapWithKey f Tip = Tip
-mapWithKey f (Bin sx kx x l r)
- = Bin sx kx (f kx x) (mapWithKey f l) (mapWithKey f r)
-
--- | /O(n)/. The function 'mapAccum' threads an accumulating
--- argument through the map in ascending order of keys.
-mapAccum :: (a -> b -> (a,c)) -> a -> Map k b -> (a,Map k c)
-mapAccum f a m
- = mapAccumWithKey (\a k x -> f a x) a m
-
--- | /O(n)/. The function 'mapAccumWithKey' threads an accumulating
--- argument through the map in ascending order of keys.
-mapAccumWithKey :: (a -> k -> b -> (a,c)) -> a -> Map k b -> (a,Map k c)
-mapAccumWithKey f a t
- = mapAccumL f a t
-
--- | /O(n)/. The function 'mapAccumL' threads an accumulating
--- argument throught the map in ascending order of keys.
-mapAccumL :: (a -> k -> b -> (a,c)) -> a -> Map k b -> (a,Map k c)
-mapAccumL f a t
- = case t of
- Tip -> (a,Tip)
- Bin sx kx x l r
- -> let (a1,l') = mapAccumL f a l
- (a2,x') = f a1 kx x
- (a3,r') = mapAccumL f a2 r
- in (a3,Bin sx kx x' l' r')
-
--- | /O(n)/. The function 'mapAccumR' threads an accumulating
--- argument throught the map in descending order of keys.
-mapAccumR :: (a -> k -> b -> (a,c)) -> a -> Map k b -> (a,Map k c)
-mapAccumR f a t
- = case t of
- Tip -> (a,Tip)
- Bin sx kx x l r
- -> let (a1,r') = mapAccumR f a r
- (a2,x') = f a1 kx x
- (a3,l') = mapAccumR f a2 l
- in (a3,Bin sx kx x' l' r')
-
--- | /O(n*log n)/.
--- @'mapKeys' f s@ is the map obtained by applying @f@ to each key of @s@.
---
--- The size of the result may be smaller if @f@ maps two or more distinct
--- keys to the same new key. In this case the value at the smallest of
--- these keys is retained.
-
-mapKeys :: Ord k2 => (k1->k2) -> Map k1 a -> Map k2 a
-mapKeys = mapKeysWith (\x y->x)
-
--- | /O(n*log n)/.
--- @'mapKeysWith' c f s@ is the map obtained by applying @f@ to each key of @s@.
---
--- The size of the result may be smaller if @f@ maps two or more distinct
--- keys to the same new key. In this case the associated values will be
--- combined using @c@.
-
-mapKeysWith :: Ord k2 => (a -> a -> a) -> (k1->k2) -> Map k1 a -> Map k2 a
-mapKeysWith c f = fromListWith c . List.map fFirst . toList
- where fFirst (x,y) = (f x, y)
-
-
--- | /O(n)/.
--- @'mapKeysMonotonic' f s == 'mapKeys' f s@, but works only when @f@
--- is strictly monotonic.
--- /The precondition is not checked./
--- Semi-formally, we have:
---
--- > and [x < y ==> f x < f y | x <- ls, y <- ls]
--- > ==> mapKeysMonotonic f s == mapKeys f s
--- > where ls = keys s
-
-mapKeysMonotonic :: (k1->k2) -> Map k1 a -> Map k2 a
-mapKeysMonotonic f Tip = Tip
-mapKeysMonotonic f (Bin sz k x l r) =
- Bin sz (f k) x (mapKeysMonotonic f l) (mapKeysMonotonic f r)
-
-{--------------------------------------------------------------------
- Folds
---------------------------------------------------------------------}
-
--- | /O(n)/. Fold the values in the map, such that
--- @'fold' f z == 'Prelude.foldr' f z . 'elems'@.
--- For example,
---
--- > elems map = fold (:) [] map
---
-fold :: (a -> b -> b) -> b -> Map k a -> b
-fold f z m
- = foldWithKey (\k x z -> f x z) z m
-
--- | /O(n)/. Fold the keys and values in the map, such that
--- @'foldWithKey' f z == 'Prelude.foldr' ('uncurry' f) z . 'toAscList'@.
--- For example,
---
--- > keys map = foldWithKey (\k x ks -> k:ks) [] map
---
-foldWithKey :: (k -> a -> b -> b) -> b -> Map k a -> b
-foldWithKey f z t
- = foldr f z t
-
--- | /O(n)/. In-order fold.
-foldi :: (k -> a -> b -> b -> b) -> b -> Map k a -> b
-foldi f z Tip = z
-foldi f z (Bin _ kx x l r) = f kx x (foldi f z l) (foldi f z r)
-
--- | /O(n)/. Post-order fold.
-foldr :: (k -> a -> b -> b) -> b -> Map k a -> b
-foldr f z Tip = z
-foldr f z (Bin _ kx x l r) = foldr f (f kx x (foldr f z r)) l
-
--- | /O(n)/. Pre-order fold.
-foldl :: (b -> k -> a -> b) -> b -> Map k a -> b
-foldl f z Tip = z
-foldl f z (Bin _ kx x l r) = foldl f (f (foldl f z l) kx x) r
-
-{--------------------------------------------------------------------
- List variations
---------------------------------------------------------------------}
--- | /O(n)/.
--- Return all elements of the map in the ascending order of their keys.
-elems :: Map k a -> [a]
-elems m
- = [x | (k,x) <- assocs m]
-
--- | /O(n)/. Return all keys of the map in ascending order.
-keys :: Map k a -> [k]
-keys m
- = [k | (k,x) <- assocs m]
-
--- | /O(n)/. The set of all keys of the map.
-keysSet :: Map k a -> Set.Set k
-keysSet m = Set.fromDistinctAscList (keys m)
-
--- | /O(n)/. Return all key\/value pairs in the map in ascending key order.
-assocs :: Map k a -> [(k,a)]
-assocs m
- = toList m
-
-{--------------------------------------------------------------------
- Lists
- use [foldlStrict] to reduce demand on the control-stack
---------------------------------------------------------------------}
--- | /O(n*log n)/. Build a map from a list of key\/value pairs. See also 'fromAscList'.
-fromList :: Ord k => [(k,a)] -> Map k a
-fromList xs
- = foldlStrict ins empty xs
- where
- ins t (k,x) = insert k x t
-
--- | /O(n*log n)/. Build a map from a list of key\/value pairs with a combining function. See also 'fromAscListWith'.
-fromListWith :: Ord k => (a -> a -> a) -> [(k,a)] -> Map k a
-fromListWith f xs
- = fromListWithKey (\k x y -> f x y) xs
-
--- | /O(n*log n)/. Build a map from a list of key\/value pairs with a combining function. See also 'fromAscListWithKey'.
-fromListWithKey :: Ord k => (k -> a -> a -> a) -> [(k,a)] -> Map k a
-fromListWithKey f xs
- = foldlStrict ins empty xs
- where
- ins t (k,x) = insertWithKey f k x t
-
--- | /O(n)/. Convert to a list of key\/value pairs.
-toList :: Map k a -> [(k,a)]
-toList t = toAscList t
-
--- | /O(n)/. Convert to an ascending list.
-toAscList :: Map k a -> [(k,a)]
-toAscList t = foldr (\k x xs -> (k,x):xs) [] t
-
--- | /O(n)/.
-toDescList :: Map k a -> [(k,a)]
-toDescList t = foldl (\xs k x -> (k,x):xs) [] t
-
-
-{--------------------------------------------------------------------
- Building trees from ascending/descending lists can be done in linear time.
-
- Note that if [xs] is ascending that:
- fromAscList xs == fromList xs
- fromAscListWith f xs == fromListWith f xs
---------------------------------------------------------------------}
--- | /O(n)/. Build a map from an ascending list in linear time.
--- /The precondition (input list is ascending) is not checked./
-fromAscList :: Eq k => [(k,a)] -> Map k a
-fromAscList xs
- = fromAscListWithKey (\k x y -> x) xs
-
--- | /O(n)/. Build a map from an ascending list in linear time with a combining function for equal keys.
--- /The precondition (input list is ascending) is not checked./
-fromAscListWith :: Eq k => (a -> a -> a) -> [(k,a)] -> Map k a
-fromAscListWith f xs
- = fromAscListWithKey (\k x y -> f x y) xs
-
--- | /O(n)/. Build a map from an ascending list in linear time with a
--- combining function for equal keys.
--- /The precondition (input list is ascending) is not checked./
-fromAscListWithKey :: Eq k => (k -> a -> a -> a) -> [(k,a)] -> Map k a
-fromAscListWithKey f xs
- = fromDistinctAscList (combineEq f xs)
- where
- -- [combineEq f xs] combines equal elements with function [f] in an ordered list [xs]
- combineEq f xs
- = case xs of
- [] -> []
- [x] -> [x]
- (x:xx) -> combineEq' x xx
-
- combineEq' z [] = [z]
- combineEq' z@(kz,zz) (x@(kx,xx):xs)
- | kx==kz = let yy = f kx xx zz in combineEq' (kx,yy) xs
- | otherwise = z:combineEq' x xs
-
-
--- | /O(n)/. Build a map from an ascending list of distinct elements in linear time.
--- /The precondition is not checked./
-fromDistinctAscList :: [(k,a)] -> Map k a
-fromDistinctAscList xs
- = build const (length xs) xs
- where
- -- 1) use continutations so that we use heap space instead of stack space.
- -- 2) special case for n==5 to build bushier trees.
- build c 0 xs = c Tip xs
- build c 5 xs = case xs of
- ((k1,x1):(k2,x2):(k3,x3):(k4,x4):(k5,x5):xx)
- -> c (bin k4 x4 (bin k2 x2 (singleton k1 x1) (singleton k3 x3)) (singleton k5 x5)) xx
- build c n xs = seq nr $ build (buildR nr c) nl xs
- where
- nl = n `div` 2
- nr = n - nl - 1
-
- buildR n c l ((k,x):ys) = build (buildB l k x c) n ys
- buildB l k x c r zs = c (bin k x l r) zs
-
-
-
-{--------------------------------------------------------------------
- Utility functions that return sub-ranges of the original
- tree. Some functions take a comparison function as argument to
- allow comparisons against infinite values. A function [cmplo k]
- should be read as [compare lo k].
-
- [trim cmplo cmphi t] A tree that is either empty or where [cmplo k == LT]
- and [cmphi k == GT] for the key [k] of the root.
- [filterGt cmp t] A tree where for all keys [k]. [cmp k == LT]
- [filterLt cmp t] A tree where for all keys [k]. [cmp k == GT]
-
- [split k t] Returns two trees [l] and [r] where all keys
- in [l] are <[k] and all keys in [r] are >[k].
- [splitLookup k t] Just like [split] but also returns whether [k]
- was found in the tree.
---------------------------------------------------------------------}
-
-{--------------------------------------------------------------------
- [trim lo hi t] trims away all subtrees that surely contain no
- values between the range [lo] to [hi]. The returned tree is either
- empty or the key of the root is between @lo@ and @hi@.
---------------------------------------------------------------------}
-trim :: (k -> Ordering) -> (k -> Ordering) -> Map k a -> Map k a
-trim cmplo cmphi Tip = Tip
-trim cmplo cmphi t@(Bin sx kx x l r)
- = case cmplo kx of
- LT -> case cmphi kx of
- GT -> t
- le -> trim cmplo cmphi l
- ge -> trim cmplo cmphi r
-
-trimLookupLo :: Ord k => k -> (k -> Ordering) -> Map k a -> (Maybe (k,a), Map k a)
-trimLookupLo lo cmphi Tip = (Nothing,Tip)
-trimLookupLo lo cmphi t@(Bin sx kx x l r)
- = case compare lo kx of
- LT -> case cmphi kx of
- GT -> (lookupAssoc lo t, t)
- le -> trimLookupLo lo cmphi l
- GT -> trimLookupLo lo cmphi r
- EQ -> (Just (kx,x),trim (compare lo) cmphi r)
-
-
-{--------------------------------------------------------------------
- [filterGt k t] filter all keys >[k] from tree [t]
- [filterLt k t] filter all keys <[k] from tree [t]
---------------------------------------------------------------------}
-filterGt :: Ord k => (k -> Ordering) -> Map k a -> Map k a
-filterGt cmp Tip = Tip
-filterGt cmp (Bin sx kx x l r)
- = case cmp kx of
- LT -> join kx x (filterGt cmp l) r
- GT -> filterGt cmp r
- EQ -> r
-
-filterLt :: Ord k => (k -> Ordering) -> Map k a -> Map k a
-filterLt cmp Tip = Tip
-filterLt cmp (Bin sx kx x l r)
- = case cmp kx of
- LT -> filterLt cmp l
- GT -> join kx x l (filterLt cmp r)
- EQ -> l
-
-{--------------------------------------------------------------------
- Split
---------------------------------------------------------------------}
--- | /O(log n)/. The expression (@'split' k map@) is a pair @(map1,map2)@ where
--- the keys in @map1@ are smaller than @k@ and the keys in @map2@ larger than @k@. Any key equal to @k@ is found in neither @map1@ nor @map2@.
-split :: Ord k => k -> Map k a -> (Map k a,Map k a)
-split k Tip = (Tip,Tip)
-split k (Bin sx kx x l r)
- = case compare k kx of
- LT -> let (lt,gt) = split k l in (lt,join kx x gt r)
- GT -> let (lt,gt) = split k r in (join kx x l lt,gt)
- EQ -> (l,r)
-
--- | /O(log n)/. The expression (@'splitLookup' k map@) splits a map just
--- like 'split' but also returns @'lookup' k map@.
-splitLookup :: Ord k => k -> Map k a -> (Map k a,Maybe a,Map k a)
-splitLookup k Tip = (Tip,Nothing,Tip)
-splitLookup k (Bin sx kx x l r)
- = case compare k kx of
- LT -> let (lt,z,gt) = splitLookup k l in (lt,z,join kx x gt r)
- GT -> let (lt,z,gt) = splitLookup k r in (join kx x l lt,z,gt)
- EQ -> (l,Just x,r)
-
--- | /O(log n)/.
-splitLookupWithKey :: Ord k => k -> Map k a -> (Map k a,Maybe (k,a),Map k a)
-splitLookupWithKey k Tip = (Tip,Nothing,Tip)
-splitLookupWithKey k (Bin sx kx x l r)
- = case compare k kx of
- LT -> let (lt,z,gt) = splitLookupWithKey k l in (lt,z,join kx x gt r)
- GT -> let (lt,z,gt) = splitLookupWithKey k r in (join kx x l lt,z,gt)
- EQ -> (l,Just (kx, x),r)
-
--- | /O(log n)/. Performs a 'split' but also returns whether the pivot
--- element was found in the original set.
-splitMember :: Ord k => k -> Map k a -> (Map k a,Bool,Map k a)
-splitMember x t = let (l,m,r) = splitLookup x t in
- (l,maybe False (const True) m,r)
-
-
-{--------------------------------------------------------------------
- Utility functions that maintain the balance properties of the tree.
- All constructors assume that all values in [l] < [k] and all values
- in [r] > [k], and that [l] and [r] are valid trees.
-
- In order of sophistication:
- [Bin sz k x l r] The type constructor.
- [bin k x l r] Maintains the correct size, assumes that both [l]
- and [r] are balanced with respect to each other.
- [balance k x l r] Restores the balance and size.
- Assumes that the original tree was balanced and
- that [l] or [r] has changed by at most one element.
- [join k x l r] Restores balance and size.
-
- Furthermore, we can construct a new tree from two trees. Both operations
- assume that all values in [l] < all values in [r] and that [l] and [r]
- are valid:
- [glue l r] Glues [l] and [r] together. Assumes that [l] and
- [r] are already balanced with respect to each other.
- [merge l r] Merges two trees and restores balance.
-
- Note: in contrast to Adam's paper, we use (<=) comparisons instead
- of (<) comparisons in [join], [merge] and [balance].
- Quickcheck (on [difference]) showed that this was necessary in order
- to maintain the invariants. It is quite unsatisfactory that I haven't
- been able to find out why this is actually the case! Fortunately, it
- doesn't hurt to be a bit more conservative.
---------------------------------------------------------------------}
-
-{--------------------------------------------------------------------
- Join
---------------------------------------------------------------------}
-join :: Ord k => k -> a -> Map k a -> Map k a -> Map k a
-join kx x Tip r = insertMin kx x r
-join kx x l Tip = insertMax kx x l
-join kx x l@(Bin sizeL ky y ly ry) r@(Bin sizeR kz z lz rz)
- | delta*sizeL <= sizeR = balance kz z (join kx x l lz) rz
- | delta*sizeR <= sizeL = balance ky y ly (join kx x ry r)
- | otherwise = bin kx x l r
-
-
--- insertMin and insertMax don't perform potentially expensive comparisons.
-insertMax,insertMin :: k -> a -> Map k a -> Map k a
-insertMax kx x t
- = case t of
- Tip -> singleton kx x
- Bin sz ky y l r
- -> balance ky y l (insertMax kx x r)
-
-insertMin kx x t
- = case t of
- Tip -> singleton kx x
- Bin sz ky y l r
- -> balance ky y (insertMin kx x l) r
-
-{--------------------------------------------------------------------
- [merge l r]: merges two trees.
---------------------------------------------------------------------}
-merge :: Map k a -> Map k a -> Map k a
-merge Tip r = r
-merge l Tip = l
-merge l@(Bin sizeL kx x lx rx) r@(Bin sizeR ky y ly ry)
- | delta*sizeL <= sizeR = balance ky y (merge l ly) ry
- | delta*sizeR <= sizeL = balance kx x lx (merge rx r)
- | otherwise = glue l r
-
-{--------------------------------------------------------------------
- [glue l r]: glues two trees together.
- Assumes that [l] and [r] are already balanced with respect to each other.
---------------------------------------------------------------------}
-glue :: Map k a -> Map k a -> Map k a
-glue Tip r = r
-glue l Tip = l
-glue l r
- | size l > size r = let ((km,m),l') = deleteFindMax l in balance km m l' r
- | otherwise = let ((km,m),r') = deleteFindMin r in balance km m l r'
-
-
--- | /O(log n)/. Delete and find the minimal element.
-deleteFindMin :: Map k a -> ((k,a),Map k a)
-deleteFindMin t
- = case t of
- Bin _ k x Tip r -> ((k,x),r)
- Bin _ k x l r -> let (km,l') = deleteFindMin l in (km,balance k x l' r)
- Tip -> (error "Map.deleteFindMin: can not return the minimal element of an empty map", Tip)
-
--- | /O(log n)/. Delete and find the maximal element.
-deleteFindMax :: Map k a -> ((k,a),Map k a)
-deleteFindMax t
- = case t of
- Bin _ k x l Tip -> ((k,x),l)
- Bin _ k x l r -> let (km,r') = deleteFindMax r in (km,balance k x l r')
- Tip -> (error "Map.deleteFindMax: can not return the maximal element of an empty map", Tip)
-
-
-{--------------------------------------------------------------------
- [balance l x r] balances two trees with value x.
- The sizes of the trees should balance after decreasing the
- size of one of them. (a rotation).
-
- [delta] is the maximal relative difference between the sizes of
- two trees, it corresponds with the [w] in Adams' paper.
- [ratio] is the ratio between an outer and inner sibling of the
- heavier subtree in an unbalanced setting. It determines
- whether a double or single rotation should be performed
- to restore balance. It is correspondes with the inverse
- of $\alpha$ in Adam's article.
-
- Note that:
- - [delta] should be larger than 4.646 with a [ratio] of 2.
- - [delta] should be larger than 3.745 with a [ratio] of 1.534.
-
- - A lower [delta] leads to a more 'perfectly' balanced tree.
- - A higher [delta] performs less rebalancing.
-
- - Balancing is automatic for random data and a balancing
- scheme is only necessary to avoid pathological worst cases.
- Almost any choice will do, and in practice, a rather large
- [delta] may perform better than smaller one.
-
- Note: in contrast to Adam's paper, we use a ratio of (at least) [2]
- to decide whether a single or double rotation is needed. Allthough
- he actually proves that this ratio is needed to maintain the
- invariants, his implementation uses an invalid ratio of [1].
---------------------------------------------------------------------}
-delta,ratio :: Int
-delta = 5
-ratio = 2
-
-balance :: k -> a -> Map k a -> Map k a -> Map k a
-balance k x l r
- | sizeL + sizeR <= 1 = Bin sizeX k x l r
- | sizeR >= delta*sizeL = rotateL k x l r
- | sizeL >= delta*sizeR = rotateR k x l r
- | otherwise = Bin sizeX k x l r
- where
- sizeL = size l
- sizeR = size r
- sizeX = sizeL + sizeR + 1
-
--- rotate
-rotateL k x l r@(Bin _ _ _ ly ry)
- | size ly < ratio*size ry = singleL k x l r
- | otherwise = doubleL k x l r
-
-rotateR k x l@(Bin _ _ _ ly ry) r
- | size ry < ratio*size ly = singleR k x l r
- | otherwise = doubleR k x l r
-
--- basic rotations
-singleL k1 x1 t1 (Bin _ k2 x2 t2 t3) = bin k2 x2 (bin k1 x1 t1 t2) t3
-singleR k1 x1 (Bin _ k2 x2 t1 t2) t3 = bin k2 x2 t1 (bin k1 x1 t2 t3)
-
-doubleL k1 x1 t1 (Bin _ k2 x2 (Bin _ k3 x3 t2 t3) t4) = bin k3 x3 (bin k1 x1 t1 t2) (bin k2 x2 t3 t4)
-doubleR k1 x1 (Bin _ k2 x2 t1 (Bin _ k3 x3 t2 t3)) t4 = bin k3 x3 (bin k2 x2 t1 t2) (bin k1 x1 t3 t4)
-
-
-{--------------------------------------------------------------------
- The bin constructor maintains the size of the tree
---------------------------------------------------------------------}
-bin :: k -> a -> Map k a -> Map k a -> Map k a
-bin k x l r
- = Bin (size l + size r + 1) k x l r
-
-
-{--------------------------------------------------------------------
- Eq converts the tree to a list. In a lazy setting, this
- actually seems one of the faster methods to compare two trees
- and it is certainly the simplest :-)
---------------------------------------------------------------------}
-instance (Eq k,Eq a) => Eq (Map k a) where
- t1 == t2 = (size t1 == size t2) && (toAscList t1 == toAscList t2)
-
-{--------------------------------------------------------------------
- Ord
---------------------------------------------------------------------}
-
-instance (Ord k, Ord v) => Ord (Map k v) where
- compare m1 m2 = compare (toAscList m1) (toAscList m2)
-
-{--------------------------------------------------------------------
- Functor
---------------------------------------------------------------------}
-instance Functor (Map k) where
- fmap f m = map f m
-
-instance Traversable (Map k) where
- traverse f Tip = pure Tip
- traverse f (Bin s k v l r)
- = flip (Bin s k) <$> traverse f l <*> f v <*> traverse f r
-
-instance Foldable (Map k) where
- foldMap _f Tip = mempty
- foldMap f (Bin _s _k v l r)
- = foldMap f l `mappend` f v `mappend` foldMap f r
-
-{--------------------------------------------------------------------
- Read
---------------------------------------------------------------------}
-instance (Ord k, Read k, Read e) => Read (Map k e) where
-#ifdef __GLASGOW_HASKELL__
- readPrec = parens $ prec 10 $ do
- Ident "fromList" <- lexP
- xs <- readPrec
- return (fromList xs)
-
- readListPrec = readListPrecDefault
-#else
- readsPrec p = readParen (p > 10) $ \ r -> do
- ("fromList",s) <- lex r
- (xs,t) <- reads s
- return (fromList xs,t)
-#endif
-
--- parses a pair of things with the syntax a:=b
-readPair :: (Read a, Read b) => ReadS (a,b)
-readPair s = do (a, ct1) <- reads s
- (":=", ct2) <- lex ct1
- (b, ct3) <- reads ct2
- return ((a,b), ct3)
-
-{--------------------------------------------------------------------
- Show
---------------------------------------------------------------------}
-instance (Show k, Show a) => Show (Map k a) where
- showsPrec d m = showParen (d > 10) $
- showString "fromList " . shows (toList m)
-
-showMap :: (Show k,Show a) => [(k,a)] -> ShowS
-showMap []
- = showString "{}"
-showMap (x:xs)
- = showChar '{' . showElem x . showTail xs
- where
- showTail [] = showChar '}'
- showTail (x:xs) = showString ", " . showElem x . showTail xs
-
- showElem (k,x) = shows k . showString " := " . shows x
-
-
--- | /O(n)/. Show the tree that implements the map. The tree is shown
--- in a compressed, hanging format.
-showTree :: (Show k,Show a) => Map k a -> String
-showTree m
- = showTreeWith showElem True False m
- where
- showElem k x = show k ++ ":=" ++ show x
-
-
-{- | /O(n)/. The expression (@'showTreeWith' showelem hang wide map@) shows
- the tree that implements the map. Elements are shown using the @showElem@ function. If @hang@ is
- 'True', a /hanging/ tree is shown otherwise a rotated tree is shown. If
- @wide@ is 'True', an extra wide version is shown.
-
-> Map> let t = fromDistinctAscList [(x,()) | x <- [1..5]]
-> Map> putStrLn $ showTreeWith (\k x -> show (k,x)) True False t
-> (4,())
-> +--(2,())
-> | +--(1,())
-> | +--(3,())
-> +--(5,())
->
-> Map> putStrLn $ showTreeWith (\k x -> show (k,x)) True True t
-> (4,())
-> |
-> +--(2,())
-> | |
-> | +--(1,())
-> | |
-> | +--(3,())
-> |
-> +--(5,())
->
-> Map> putStrLn $ showTreeWith (\k x -> show (k,x)) False True t
-> +--(5,())
-> |
-> (4,())
-> |
-> | +--(3,())
-> | |
-> +--(2,())
-> |
-> +--(1,())
-
--}
-showTreeWith :: (k -> a -> String) -> Bool -> Bool -> Map k a -> String
-showTreeWith showelem hang wide t
- | hang = (showsTreeHang showelem wide [] t) ""
- | otherwise = (showsTree showelem wide [] [] t) ""
-
-showsTree :: (k -> a -> String) -> Bool -> [String] -> [String] -> Map k a -> ShowS
-showsTree showelem wide lbars rbars t
- = case t of
- Tip -> showsBars lbars . showString "|\n"
- Bin sz kx x Tip Tip
- -> showsBars lbars . showString (showelem kx x) . showString "\n"
- Bin sz kx x l r
- -> showsTree showelem wide (withBar rbars) (withEmpty rbars) r .
- showWide wide rbars .
- showsBars lbars . showString (showelem kx x) . showString "\n" .
- showWide wide lbars .
- showsTree showelem wide (withEmpty lbars) (withBar lbars) l
-
-showsTreeHang :: (k -> a -> String) -> Bool -> [String] -> Map k a -> ShowS
-showsTreeHang showelem wide bars t
- = case t of
- Tip -> showsBars bars . showString "|\n"
- Bin sz kx x Tip Tip
- -> showsBars bars . showString (showelem kx x) . showString "\n"
- Bin sz kx x l r
- -> showsBars bars . showString (showelem kx x) . showString "\n" .
- showWide wide bars .
- showsTreeHang showelem wide (withBar bars) l .
- showWide wide bars .
- showsTreeHang showelem wide (withEmpty bars) r
-
-
-showWide wide bars
- | wide = showString (concat (reverse bars)) . showString "|\n"
- | otherwise = id
-
-showsBars :: [String] -> ShowS
-showsBars bars
- = case bars of
- [] -> id
- _ -> showString (concat (reverse (tail bars))) . showString node
-
-node = "+--"
-withBar bars = "| ":bars
-withEmpty bars = " ":bars
-
-{--------------------------------------------------------------------
- Typeable
---------------------------------------------------------------------}
-
-#include "Typeable.h"
-INSTANCE_TYPEABLE2(Map,mapTc,"Map")
-
-{--------------------------------------------------------------------
- Assertions
---------------------------------------------------------------------}
--- | /O(n)/. Test if the internal map structure is valid.
-valid :: Ord k => Map k a -> Bool
-valid t
- = balanced t && ordered t && validsize t
-
-ordered t
- = bounded (const True) (const True) t
- where
- bounded lo hi t
- = case t of
- Tip -> True
- Bin sz kx x l r -> (lo kx) && (hi kx) && bounded lo (<kx) l && bounded (>kx) hi r
-
--- | Exported only for "Debug.QuickCheck"
-balanced :: Map k a -> Bool
-balanced t
- = case t of
- Tip -> True
- Bin sz kx x l r -> (size l + size r <= 1 || (size l <= delta*size r && size r <= delta*size l)) &&
- balanced l && balanced r
-
-
-validsize t
- = (realsize t == Just (size t))
- where
- realsize t
- = case t of
- Tip -> Just 0
- Bin sz kx x l r -> case (realsize l,realsize r) of
- (Just n,Just m) | n+m+1 == sz -> Just sz
- other -> Nothing
-
-{--------------------------------------------------------------------
- Utilities
---------------------------------------------------------------------}
-foldlStrict f z xs
- = case xs of
- [] -> z
- (x:xx) -> let z' = f z x in seq z' (foldlStrict f z' xx)
-
-
-{-
-{--------------------------------------------------------------------
- Testing
---------------------------------------------------------------------}
-testTree xs = fromList [(x,"*") | x <- xs]
-test1 = testTree [1..20]
-test2 = testTree [30,29..10]
-test3 = testTree [1,4,6,89,2323,53,43,234,5,79,12,9,24,9,8,423,8,42,4,8,9,3]
-
-{--------------------------------------------------------------------
- QuickCheck
---------------------------------------------------------------------}
-qcheck prop
- = check config prop
- where
- config = Config
- { configMaxTest = 500
- , configMaxFail = 5000
- , configSize = \n -> (div n 2 + 3)
- , configEvery = \n args -> let s = show n in s ++ [ '\b' | _ <- s ]
- }
-
-
-{--------------------------------------------------------------------
- Arbitrary, reasonably balanced trees
---------------------------------------------------------------------}
-instance (Enum k,Arbitrary a) => Arbitrary (Map k a) where
- arbitrary = sized (arbtree 0 maxkey)
- where maxkey = 10000
-
-arbtree :: (Enum k,Arbitrary a) => Int -> Int -> Int -> Gen (Map k a)
-arbtree lo hi n
- | n <= 0 = return Tip
- | lo >= hi = return Tip
- | otherwise = do{ x <- arbitrary
- ; i <- choose (lo,hi)
- ; m <- choose (1,30)
- ; let (ml,mr) | m==(1::Int)= (1,2)
- | m==2 = (2,1)
- | m==3 = (1,1)
- | otherwise = (2,2)
- ; l <- arbtree lo (i-1) (n `div` ml)
- ; r <- arbtree (i+1) hi (n `div` mr)
- ; return (bin (toEnum i) x l r)
- }
-
-
-{--------------------------------------------------------------------
- Valid tree's
---------------------------------------------------------------------}
-forValid :: (Show k,Enum k,Show a,Arbitrary a,Testable b) => (Map k a -> b) -> Property
-forValid f
- = forAll arbitrary $ \t ->
--- classify (balanced t) "balanced" $
- classify (size t == 0) "empty" $
- classify (size t > 0 && size t <= 10) "small" $
- classify (size t > 10 && size t <= 64) "medium" $
- classify (size t > 64) "large" $
- balanced t ==> f t
-
-forValidIntTree :: Testable a => (Map Int Int -> a) -> Property
-forValidIntTree f
- = forValid f
-
-forValidUnitTree :: Testable a => (Map Int () -> a) -> Property
-forValidUnitTree f
- = forValid f
-
-
-prop_Valid
- = forValidUnitTree $ \t -> valid t
-
-{--------------------------------------------------------------------
- Single, Insert, Delete
---------------------------------------------------------------------}
-prop_Single :: Int -> Int -> Bool
-prop_Single k x
- = (insert k x empty == singleton k x)
-
-prop_InsertValid :: Int -> Property
-prop_InsertValid k
- = forValidUnitTree $ \t -> valid (insert k () t)
-
-prop_InsertDelete :: Int -> Map Int () -> Property
-prop_InsertDelete k t
- = (lookup k t == Nothing) ==> delete k (insert k () t) == t
-
-prop_DeleteValid :: Int -> Property
-prop_DeleteValid k
- = forValidUnitTree $ \t ->
- valid (delete k (insert k () t))
-
-{--------------------------------------------------------------------
- Balance
---------------------------------------------------------------------}
-prop_Join :: Int -> Property
-prop_Join k
- = forValidUnitTree $ \t ->
- let (l,r) = split k t
- in valid (join k () l r)
-
-prop_Merge :: Int -> Property
-prop_Merge k
- = forValidUnitTree $ \t ->
- let (l,r) = split k t
- in valid (merge l r)
-
-
-{--------------------------------------------------------------------
- Union
---------------------------------------------------------------------}
-prop_UnionValid :: Property
-prop_UnionValid
- = forValidUnitTree $ \t1 ->
- forValidUnitTree $ \t2 ->
- valid (union t1 t2)
-
-prop_UnionInsert :: Int -> Int -> Map Int Int -> Bool
-prop_UnionInsert k x t
- = union (singleton k x) t == insert k x t
-
-prop_UnionAssoc :: Map Int Int -> Map Int Int -> Map Int Int -> Bool
-prop_UnionAssoc t1 t2 t3
- = union t1 (union t2 t3) == union (union t1 t2) t3
-
-prop_UnionComm :: Map Int Int -> Map Int Int -> Bool
-prop_UnionComm t1 t2
- = (union t1 t2 == unionWith (\x y -> y) t2 t1)
-
-prop_UnionWithValid
- = forValidIntTree $ \t1 ->
- forValidIntTree $ \t2 ->
- valid (unionWithKey (\k x y -> x+y) t1 t2)
-
-prop_UnionWith :: [(Int,Int)] -> [(Int,Int)] -> Bool
-prop_UnionWith xs ys
- = sum (elems (unionWith (+) (fromListWith (+) xs) (fromListWith (+) ys)))
- == (sum (Prelude.map snd xs) + sum (Prelude.map snd ys))
-
-prop_DiffValid
- = forValidUnitTree $ \t1 ->
- forValidUnitTree $ \t2 ->
- valid (difference t1 t2)
-
-prop_Diff :: [(Int,Int)] -> [(Int,Int)] -> Bool
-prop_Diff xs ys
- = List.sort (keys (difference (fromListWith (+) xs) (fromListWith (+) ys)))
- == List.sort ((List.\\) (nub (Prelude.map fst xs)) (nub (Prelude.map fst ys)))
-
-prop_IntValid
- = forValidUnitTree $ \t1 ->
- forValidUnitTree $ \t2 ->
- valid (intersection t1 t2)
-
-prop_Int :: [(Int,Int)] -> [(Int,Int)] -> Bool
-prop_Int xs ys
- = List.sort (keys (intersection (fromListWith (+) xs) (fromListWith (+) ys)))
- == List.sort (nub ((List.intersect) (Prelude.map fst xs) (Prelude.map fst ys)))
-
-{--------------------------------------------------------------------
- Lists
---------------------------------------------------------------------}
-prop_Ordered
- = forAll (choose (5,100)) $ \n ->
- let xs = [(x,()) | x <- [0..n::Int]]
- in fromAscList xs == fromList xs
-
-prop_List :: [Int] -> Bool
-prop_List xs
- = (sort (nub xs) == [x | (x,()) <- toList (fromList [(x,()) | x <- xs])])
--}
+++ /dev/null
-{-# OPTIONS -cpp -fglasgow-exts #-}
------------------------------------------------------------------------------
--- |
--- Module : Data.Sequence
--- Copyright : (c) Ross Paterson 2005
--- License : BSD-style
--- Maintainer : ross@soi.city.ac.uk
--- Stability : experimental
--- Portability : portable
---
--- General purpose finite sequences.
--- Apart from being finite and having strict operations, sequences
--- also differ from lists in supporting a wider variety of operations
--- efficiently.
---
--- An amortized running time is given for each operation, with /n/ referring
--- to the length of the sequence and /i/ being the integral index used by
--- some operations. These bounds hold even in a persistent (shared) setting.
---
--- The implementation uses 2-3 finger trees annotated with sizes,
--- as described in section 4.2 of
---
--- * Ralf Hinze and Ross Paterson,
--- \"Finger trees: a simple general-purpose data structure\",
--- /Journal of Functional Programming/ 16:2 (2006) pp 197-217.
--- <http://www.soi.city.ac.uk/~ross/papers/FingerTree.html>
---
--- /Note/: Many of these operations have the same names as similar
--- operations on lists in the "Prelude". The ambiguity may be resolved
--- using either qualification or the @hiding@ clause.
---
------------------------------------------------------------------------------
-
-module Data.Sequence (
- Seq,
- -- * Construction
- empty, -- :: Seq a
- singleton, -- :: a -> Seq a
- (<|), -- :: a -> Seq a -> Seq a
- (|>), -- :: Seq a -> a -> Seq a
- (><), -- :: Seq a -> Seq a -> Seq a
- fromList, -- :: [a] -> Seq a
- -- * Deconstruction
- -- | Additional functions for deconstructing sequences are available
- -- via the 'Foldable' instance of 'Seq'.
-
- -- ** Queries
- null, -- :: Seq a -> Bool
- length, -- :: Seq a -> Int
- -- ** Views
- ViewL(..),
- viewl, -- :: Seq a -> ViewL a
- ViewR(..),
- viewr, -- :: Seq a -> ViewR a
- -- ** Indexing
- index, -- :: Seq a -> Int -> a
- adjust, -- :: (a -> a) -> Int -> Seq a -> Seq a
- update, -- :: Int -> a -> Seq a -> Seq a
- take, -- :: Int -> Seq a -> Seq a
- drop, -- :: Int -> Seq a -> Seq a
- splitAt, -- :: Int -> Seq a -> (Seq a, Seq a)
- -- * Transformations
- reverse, -- :: Seq a -> Seq a
-#if TESTING
- valid,
-#endif
- ) where
-
-import Prelude hiding (
- null, length, take, drop, splitAt, foldl, foldl1, foldr, foldr1,
- reverse)
-import qualified Data.List (foldl')
-import Control.Applicative (Applicative(..), (<$>))
-import Control.Monad (MonadPlus(..))
-import Data.Monoid (Monoid(..))
-import Data.Foldable
-import Data.Traversable
-import Data.Typeable
-
-#ifdef __GLASGOW_HASKELL__
-import Text.Read (Lexeme(Ident), lexP, parens, prec,
- readPrec, readListPrec, readListPrecDefault)
-import Data.Generics.Basics (Data(..), Fixity(..),
- constrIndex, mkConstr, mkDataType)
-#endif
-
-#if TESTING
-import Control.Monad (liftM, liftM3, liftM4)
-import Test.QuickCheck
-#endif
-
-infixr 5 `consTree`
-infixl 5 `snocTree`
-
-infixr 5 ><
-infixr 5 <|, :<
-infixl 5 |>, :>
-
-class Sized a where
- size :: a -> Int
-
--- | General-purpose finite sequences.
-newtype Seq a = Seq (FingerTree (Elem a))
-
-instance Functor Seq where
- fmap f (Seq xs) = Seq (fmap (fmap f) xs)
-
-instance Foldable Seq where
- foldr f z (Seq xs) = foldr (flip (foldr f)) z xs
- foldl f z (Seq xs) = foldl (foldl f) z xs
-
- foldr1 f (Seq xs) = getElem (foldr1 f' xs)
- where f' (Elem x) (Elem y) = Elem (f x y)
-
- foldl1 f (Seq xs) = getElem (foldl1 f' xs)
- where f' (Elem x) (Elem y) = Elem (f x y)
-
-instance Traversable Seq where
- traverse f (Seq xs) = Seq <$> traverse (traverse f) xs
-
-instance Monad Seq where
- return = singleton
- xs >>= f = foldl' add empty xs
- where add ys x = ys >< f x
-
-instance MonadPlus Seq where
- mzero = empty
- mplus = (><)
-
-instance Eq a => Eq (Seq a) where
- xs == ys = length xs == length ys && toList xs == toList ys
-
-instance Ord a => Ord (Seq a) where
- compare xs ys = compare (toList xs) (toList ys)
-
-#if TESTING
-instance Show a => Show (Seq a) where
- showsPrec p (Seq x) = showsPrec p x
-#else
-instance Show a => Show (Seq a) where
- showsPrec p xs = showParen (p > 10) $
- showString "fromList " . shows (toList xs)
-#endif
-
-instance Read a => Read (Seq a) where
-#ifdef __GLASGOW_HASKELL__
- readPrec = parens $ prec 10 $ do
- Ident "fromList" <- lexP
- xs <- readPrec
- return (fromList xs)
-
- readListPrec = readListPrecDefault
-#else
- readsPrec p = readParen (p > 10) $ \ r -> do
- ("fromList",s) <- lex r
- (xs,t) <- reads s
- return (fromList xs,t)
-#endif
-
-instance Monoid (Seq a) where
- mempty = empty
- mappend = (><)
-
-#include "Typeable.h"
-INSTANCE_TYPEABLE1(Seq,seqTc,"Seq")
-
-#if __GLASGOW_HASKELL__
-instance Data a => Data (Seq a) where
- gfoldl f z s = case viewl s of
- EmptyL -> z empty
- x :< xs -> z (<|) `f` x `f` xs
-
- gunfold k z c = case constrIndex c of
- 1 -> z empty
- 2 -> k (k (z (<|)))
- _ -> error "gunfold"
-
- toConstr xs
- | null xs = emptyConstr
- | otherwise = consConstr
-
- dataTypeOf _ = seqDataType
-
- dataCast1 f = gcast1 f
-
-emptyConstr = mkConstr seqDataType "empty" [] Prefix
-consConstr = mkConstr seqDataType "<|" [] Infix
-seqDataType = mkDataType "Data.Sequence.Seq" [emptyConstr, consConstr]
-#endif
-
--- Finger trees
-
-data FingerTree a
- = Empty
- | Single a
- | Deep {-# UNPACK #-} !Int !(Digit a) (FingerTree (Node a)) !(Digit a)
-#if TESTING
- deriving Show
-#endif
-
-instance Sized a => Sized (FingerTree a) where
- {-# SPECIALIZE instance Sized (FingerTree (Elem a)) #-}
- {-# SPECIALIZE instance Sized (FingerTree (Node a)) #-}
- size Empty = 0
- size (Single x) = size x
- size (Deep v _ _ _) = v
-
-instance Foldable FingerTree where
- foldr _ z Empty = z
- foldr f z (Single x) = x `f` z
- foldr f z (Deep _ pr m sf) =
- foldr f (foldr (flip (foldr f)) (foldr f z sf) m) pr
-
- foldl _ z Empty = z
- foldl f z (Single x) = z `f` x
- foldl f z (Deep _ pr m sf) =
- foldl f (foldl (foldl f) (foldl f z pr) m) sf
-
- foldr1 _ Empty = error "foldr1: empty sequence"
- foldr1 _ (Single x) = x
- foldr1 f (Deep _ pr m sf) =
- foldr f (foldr (flip (foldr f)) (foldr1 f sf) m) pr
-
- foldl1 _ Empty = error "foldl1: empty sequence"
- foldl1 _ (Single x) = x
- foldl1 f (Deep _ pr m sf) =
- foldl f (foldl (foldl f) (foldl1 f pr) m) sf
-
-instance Functor FingerTree where
- fmap _ Empty = Empty
- fmap f (Single x) = Single (f x)
- fmap f (Deep v pr m sf) =
- Deep v (fmap f pr) (fmap (fmap f) m) (fmap f sf)
-
-instance Traversable FingerTree where
- traverse _ Empty = pure Empty
- traverse f (Single x) = Single <$> f x
- traverse f (Deep v pr m sf) =
- Deep v <$> traverse f pr <*> traverse (traverse f) m <*>
- traverse f sf
-
-{-# INLINE deep #-}
-{-# SPECIALIZE deep :: Digit (Elem a) -> FingerTree (Node (Elem a)) -> Digit (Elem a) -> FingerTree (Elem a) #-}
-{-# SPECIALIZE deep :: Digit (Node a) -> FingerTree (Node (Node a)) -> Digit (Node a) -> FingerTree (Node a) #-}
-deep :: Sized a => Digit a -> FingerTree (Node a) -> Digit a -> FingerTree a
-deep pr m sf = Deep (size pr + size m + size sf) pr m sf
-
--- Digits
-
-data Digit a
- = One a
- | Two a a
- | Three a a a
- | Four a a a a
-#if TESTING
- deriving Show
-#endif
-
-instance Foldable Digit where
- foldr f z (One a) = a `f` z
- foldr f z (Two a b) = a `f` (b `f` z)
- foldr f z (Three a b c) = a `f` (b `f` (c `f` z))
- foldr f z (Four a b c d) = a `f` (b `f` (c `f` (d `f` z)))
-
- foldl f z (One a) = z `f` a
- foldl f z (Two a b) = (z `f` a) `f` b
- foldl f z (Three a b c) = ((z `f` a) `f` b) `f` c
- foldl f z (Four a b c d) = (((z `f` a) `f` b) `f` c) `f` d
-
- foldr1 f (One a) = a
- foldr1 f (Two a b) = a `f` b
- foldr1 f (Three a b c) = a `f` (b `f` c)
- foldr1 f (Four a b c d) = a `f` (b `f` (c `f` d))
-
- foldl1 f (One a) = a
- foldl1 f (Two a b) = a `f` b
- foldl1 f (Three a b c) = (a `f` b) `f` c
- foldl1 f (Four a b c d) = ((a `f` b) `f` c) `f` d
-
-instance Functor Digit where
- fmap = fmapDefault
-
-instance Traversable Digit where
- traverse f (One a) = One <$> f a
- traverse f (Two a b) = Two <$> f a <*> f b
- traverse f (Three a b c) = Three <$> f a <*> f b <*> f c
- traverse f (Four a b c d) = Four <$> f a <*> f b <*> f c <*> f d
-
-instance Sized a => Sized (Digit a) where
- {-# SPECIALIZE instance Sized (Digit (Elem a)) #-}
- {-# SPECIALIZE instance Sized (Digit (Node a)) #-}
- size xs = foldl (\ i x -> i + size x) 0 xs
-
-{-# SPECIALIZE digitToTree :: Digit (Elem a) -> FingerTree (Elem a) #-}
-{-# SPECIALIZE digitToTree :: Digit (Node a) -> FingerTree (Node a) #-}
-digitToTree :: Sized a => Digit a -> FingerTree a
-digitToTree (One a) = Single a
-digitToTree (Two a b) = deep (One a) Empty (One b)
-digitToTree (Three a b c) = deep (Two a b) Empty (One c)
-digitToTree (Four a b c d) = deep (Two a b) Empty (Two c d)
-
--- Nodes
-
-data Node a
- = Node2 {-# UNPACK #-} !Int a a
- | Node3 {-# UNPACK #-} !Int a a a
-#if TESTING
- deriving Show
-#endif
-
-instance Foldable Node where
- foldr f z (Node2 _ a b) = a `f` (b `f` z)
- foldr f z (Node3 _ a b c) = a `f` (b `f` (c `f` z))
-
- foldl f z (Node2 _ a b) = (z `f` a) `f` b
- foldl f z (Node3 _ a b c) = ((z `f` a) `f` b) `f` c
-
-instance Functor Node where
- fmap = fmapDefault
-
-instance Traversable Node where
- traverse f (Node2 v a b) = Node2 v <$> f a <*> f b
- traverse f (Node3 v a b c) = Node3 v <$> f a <*> f b <*> f c
-
-instance Sized (Node a) where
- size (Node2 v _ _) = v
- size (Node3 v _ _ _) = v
-
-{-# INLINE node2 #-}
-{-# SPECIALIZE node2 :: Elem a -> Elem a -> Node (Elem a) #-}
-{-# SPECIALIZE node2 :: Node a -> Node a -> Node (Node a) #-}
-node2 :: Sized a => a -> a -> Node a
-node2 a b = Node2 (size a + size b) a b
-
-{-# INLINE node3 #-}
-{-# SPECIALIZE node3 :: Elem a -> Elem a -> Elem a -> Node (Elem a) #-}
-{-# SPECIALIZE node3 :: Node a -> Node a -> Node a -> Node (Node a) #-}
-node3 :: Sized a => a -> a -> a -> Node a
-node3 a b c = Node3 (size a + size b + size c) a b c
-
-nodeToDigit :: Node a -> Digit a
-nodeToDigit (Node2 _ a b) = Two a b
-nodeToDigit (Node3 _ a b c) = Three a b c
-
--- Elements
-
-newtype Elem a = Elem { getElem :: a }
-
-instance Sized (Elem a) where
- size _ = 1
-
-instance Functor Elem where
- fmap f (Elem x) = Elem (f x)
-
-instance Foldable Elem where
- foldr f z (Elem x) = f x z
- foldl f z (Elem x) = f z x
-
-instance Traversable Elem where
- traverse f (Elem x) = Elem <$> f x
-
-#ifdef TESTING
-instance (Show a) => Show (Elem a) where
- showsPrec p (Elem x) = showsPrec p x
-#endif
-
-------------------------------------------------------------------------
--- Construction
-------------------------------------------------------------------------
-
--- | /O(1)/. The empty sequence.
-empty :: Seq a
-empty = Seq Empty
-
--- | /O(1)/. A singleton sequence.
-singleton :: a -> Seq a
-singleton x = Seq (Single (Elem x))
-
--- | /O(1)/. Add an element to the left end of a sequence.
--- Mnemonic: a triangle with the single element at the pointy end.
-(<|) :: a -> Seq a -> Seq a
-x <| Seq xs = Seq (Elem x `consTree` xs)
-
-{-# SPECIALIZE consTree :: Elem a -> FingerTree (Elem a) -> FingerTree (Elem a) #-}
-{-# SPECIALIZE consTree :: Node a -> FingerTree (Node a) -> FingerTree (Node a) #-}
-consTree :: Sized a => a -> FingerTree a -> FingerTree a
-consTree a Empty = Single a
-consTree a (Single b) = deep (One a) Empty (One b)
-consTree a (Deep s (Four b c d e) m sf) = m `seq`
- Deep (size a + s) (Two a b) (node3 c d e `consTree` m) sf
-consTree a (Deep s (Three b c d) m sf) =
- Deep (size a + s) (Four a b c d) m sf
-consTree a (Deep s (Two b c) m sf) =
- Deep (size a + s) (Three a b c) m sf
-consTree a (Deep s (One b) m sf) =
- Deep (size a + s) (Two a b) m sf
-
--- | /O(1)/. Add an element to the right end of a sequence.
--- Mnemonic: a triangle with the single element at the pointy end.
-(|>) :: Seq a -> a -> Seq a
-Seq xs |> x = Seq (xs `snocTree` Elem x)
-
-{-# SPECIALIZE snocTree :: FingerTree (Elem a) -> Elem a -> FingerTree (Elem a) #-}
-{-# SPECIALIZE snocTree :: FingerTree (Node a) -> Node a -> FingerTree (Node a) #-}
-snocTree :: Sized a => FingerTree a -> a -> FingerTree a
-snocTree Empty a = Single a
-snocTree (Single a) b = deep (One a) Empty (One b)
-snocTree (Deep s pr m (Four a b c d)) e = m `seq`
- Deep (s + size e) pr (m `snocTree` node3 a b c) (Two d e)
-snocTree (Deep s pr m (Three a b c)) d =
- Deep (s + size d) pr m (Four a b c d)
-snocTree (Deep s pr m (Two a b)) c =
- Deep (s + size c) pr m (Three a b c)
-snocTree (Deep s pr m (One a)) b =
- Deep (s + size b) pr m (Two a b)
-
--- | /O(log(min(n1,n2)))/. Concatenate two sequences.
-(><) :: Seq a -> Seq a -> Seq a
-Seq xs >< Seq ys = Seq (appendTree0 xs ys)
-
--- The appendTree/addDigits gunk below is machine generated
-
-appendTree0 :: FingerTree (Elem a) -> FingerTree (Elem a) -> FingerTree (Elem a)
-appendTree0 Empty xs =
- xs
-appendTree0 xs Empty =
- xs
-appendTree0 (Single x) xs =
- x `consTree` xs
-appendTree0 xs (Single x) =
- xs `snocTree` x
-appendTree0 (Deep s1 pr1 m1 sf1) (Deep s2 pr2 m2 sf2) =
- Deep (s1 + s2) pr1 (addDigits0 m1 sf1 pr2 m2) sf2
-
-addDigits0 :: FingerTree (Node (Elem a)) -> Digit (Elem a) -> Digit (Elem a) -> FingerTree (Node (Elem a)) -> FingerTree (Node (Elem a))
-addDigits0 m1 (One a) (One b) m2 =
- appendTree1 m1 (node2 a b) m2
-addDigits0 m1 (One a) (Two b c) m2 =
- appendTree1 m1 (node3 a b c) m2
-addDigits0 m1 (One a) (Three b c d) m2 =
- appendTree2 m1 (node2 a b) (node2 c d) m2
-addDigits0 m1 (One a) (Four b c d e) m2 =
- appendTree2 m1 (node3 a b c) (node2 d e) m2
-addDigits0 m1 (Two a b) (One c) m2 =
- appendTree1 m1 (node3 a b c) m2
-addDigits0 m1 (Two a b) (Two c d) m2 =
- appendTree2 m1 (node2 a b) (node2 c d) m2
-addDigits0 m1 (Two a b) (Three c d e) m2 =
- appendTree2 m1 (node3 a b c) (node2 d e) m2
-addDigits0 m1 (Two a b) (Four c d e f) m2 =
- appendTree2 m1 (node3 a b c) (node3 d e f) m2
-addDigits0 m1 (Three a b c) (One d) m2 =
- appendTree2 m1 (node2 a b) (node2 c d) m2
-addDigits0 m1 (Three a b c) (Two d e) m2 =
- appendTree2 m1 (node3 a b c) (node2 d e) m2
-addDigits0 m1 (Three a b c) (Three d e f) m2 =
- appendTree2 m1 (node3 a b c) (node3 d e f) m2
-addDigits0 m1 (Three a b c) (Four d e f g) m2 =
- appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
-addDigits0 m1 (Four a b c d) (One e) m2 =
- appendTree2 m1 (node3 a b c) (node2 d e) m2
-addDigits0 m1 (Four a b c d) (Two e f) m2 =
- appendTree2 m1 (node3 a b c) (node3 d e f) m2
-addDigits0 m1 (Four a b c d) (Three e f g) m2 =
- appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
-addDigits0 m1 (Four a b c d) (Four e f g h) m2 =
- appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
-
-appendTree1 :: FingerTree (Node a) -> Node a -> FingerTree (Node a) -> FingerTree (Node a)
-appendTree1 Empty a xs =
- a `consTree` xs
-appendTree1 xs a Empty =
- xs `snocTree` a
-appendTree1 (Single x) a xs =
- x `consTree` a `consTree` xs
-appendTree1 xs a (Single x) =
- xs `snocTree` a `snocTree` x
-appendTree1 (Deep s1 pr1 m1 sf1) a (Deep s2 pr2 m2 sf2) =
- Deep (s1 + size a + s2) pr1 (addDigits1 m1 sf1 a pr2 m2) sf2
-
-addDigits1 :: FingerTree (Node (Node a)) -> Digit (Node a) -> Node a -> Digit (Node a) -> FingerTree (Node (Node a)) -> FingerTree (Node (Node a))
-addDigits1 m1 (One a) b (One c) m2 =
- appendTree1 m1 (node3 a b c) m2
-addDigits1 m1 (One a) b (Two c d) m2 =
- appendTree2 m1 (node2 a b) (node2 c d) m2
-addDigits1 m1 (One a) b (Three c d e) m2 =
- appendTree2 m1 (node3 a b c) (node2 d e) m2
-addDigits1 m1 (One a) b (Four c d e f) m2 =
- appendTree2 m1 (node3 a b c) (node3 d e f) m2
-addDigits1 m1 (Two a b) c (One d) m2 =
- appendTree2 m1 (node2 a b) (node2 c d) m2
-addDigits1 m1 (Two a b) c (Two d e) m2 =
- appendTree2 m1 (node3 a b c) (node2 d e) m2
-addDigits1 m1 (Two a b) c (Three d e f) m2 =
- appendTree2 m1 (node3 a b c) (node3 d e f) m2
-addDigits1 m1 (Two a b) c (Four d e f g) m2 =
- appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
-addDigits1 m1 (Three a b c) d (One e) m2 =
- appendTree2 m1 (node3 a b c) (node2 d e) m2
-addDigits1 m1 (Three a b c) d (Two e f) m2 =
- appendTree2 m1 (node3 a b c) (node3 d e f) m2
-addDigits1 m1 (Three a b c) d (Three e f g) m2 =
- appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
-addDigits1 m1 (Three a b c) d (Four e f g h) m2 =
- appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
-addDigits1 m1 (Four a b c d) e (One f) m2 =
- appendTree2 m1 (node3 a b c) (node3 d e f) m2
-addDigits1 m1 (Four a b c d) e (Two f g) m2 =
- appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
-addDigits1 m1 (Four a b c d) e (Three f g h) m2 =
- appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
-addDigits1 m1 (Four a b c d) e (Four f g h i) m2 =
- appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2
-
-appendTree2 :: FingerTree (Node a) -> Node a -> Node a -> FingerTree (Node a) -> FingerTree (Node a)
-appendTree2 Empty a b xs =
- a `consTree` b `consTree` xs
-appendTree2 xs a b Empty =
- xs `snocTree` a `snocTree` b
-appendTree2 (Single x) a b xs =
- x `consTree` a `consTree` b `consTree` xs
-appendTree2 xs a b (Single x) =
- xs `snocTree` a `snocTree` b `snocTree` x
-appendTree2 (Deep s1 pr1 m1 sf1) a b (Deep s2 pr2 m2 sf2) =
- Deep (s1 + size a + size b + s2) pr1 (addDigits2 m1 sf1 a b pr2 m2) sf2
-
-addDigits2 :: FingerTree (Node (Node a)) -> Digit (Node a) -> Node a -> Node a -> Digit (Node a) -> FingerTree (Node (Node a)) -> FingerTree (Node (Node a))
-addDigits2 m1 (One a) b c (One d) m2 =
- appendTree2 m1 (node2 a b) (node2 c d) m2
-addDigits2 m1 (One a) b c (Two d e) m2 =
- appendTree2 m1 (node3 a b c) (node2 d e) m2
-addDigits2 m1 (One a) b c (Three d e f) m2 =
- appendTree2 m1 (node3 a b c) (node3 d e f) m2
-addDigits2 m1 (One a) b c (Four d e f g) m2 =
- appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
-addDigits2 m1 (Two a b) c d (One e) m2 =
- appendTree2 m1 (node3 a b c) (node2 d e) m2
-addDigits2 m1 (Two a b) c d (Two e f) m2 =
- appendTree2 m1 (node3 a b c) (node3 d e f) m2
-addDigits2 m1 (Two a b) c d (Three e f g) m2 =
- appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
-addDigits2 m1 (Two a b) c d (Four e f g h) m2 =
- appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
-addDigits2 m1 (Three a b c) d e (One f) m2 =
- appendTree2 m1 (node3 a b c) (node3 d e f) m2
-addDigits2 m1 (Three a b c) d e (Two f g) m2 =
- appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
-addDigits2 m1 (Three a b c) d e (Three f g h) m2 =
- appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
-addDigits2 m1 (Three a b c) d e (Four f g h i) m2 =
- appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2
-addDigits2 m1 (Four a b c d) e f (One g) m2 =
- appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
-addDigits2 m1 (Four a b c d) e f (Two g h) m2 =
- appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
-addDigits2 m1 (Four a b c d) e f (Three g h i) m2 =
- appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2
-addDigits2 m1 (Four a b c d) e f (Four g h i j) m2 =
- appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2
-
-appendTree3 :: FingerTree (Node a) -> Node a -> Node a -> Node a -> FingerTree (Node a) -> FingerTree (Node a)
-appendTree3 Empty a b c xs =
- a `consTree` b `consTree` c `consTree` xs
-appendTree3 xs a b c Empty =
- xs `snocTree` a `snocTree` b `snocTree` c
-appendTree3 (Single x) a b c xs =
- x `consTree` a `consTree` b `consTree` c `consTree` xs
-appendTree3 xs a b c (Single x) =
- xs `snocTree` a `snocTree` b `snocTree` c `snocTree` x
-appendTree3 (Deep s1 pr1 m1 sf1) a b c (Deep s2 pr2 m2 sf2) =
- Deep (s1 + size a + size b + size c + s2) pr1 (addDigits3 m1 sf1 a b c pr2 m2) sf2
-
-addDigits3 :: FingerTree (Node (Node a)) -> Digit (Node a) -> Node a -> Node a -> Node a -> Digit (Node a) -> FingerTree (Node (Node a)) -> FingerTree (Node (Node a))
-addDigits3 m1 (One a) b c d (One e) m2 =
- appendTree2 m1 (node3 a b c) (node2 d e) m2
-addDigits3 m1 (One a) b c d (Two e f) m2 =
- appendTree2 m1 (node3 a b c) (node3 d e f) m2
-addDigits3 m1 (One a) b c d (Three e f g) m2 =
- appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
-addDigits3 m1 (One a) b c d (Four e f g h) m2 =
- appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
-addDigits3 m1 (Two a b) c d e (One f) m2 =
- appendTree2 m1 (node3 a b c) (node3 d e f) m2
-addDigits3 m1 (Two a b) c d e (Two f g) m2 =
- appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
-addDigits3 m1 (Two a b) c d e (Three f g h) m2 =
- appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
-addDigits3 m1 (Two a b) c d e (Four f g h i) m2 =
- appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2
-addDigits3 m1 (Three a b c) d e f (One g) m2 =
- appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
-addDigits3 m1 (Three a b c) d e f (Two g h) m2 =
- appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
-addDigits3 m1 (Three a b c) d e f (Three g h i) m2 =
- appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2
-addDigits3 m1 (Three a b c) d e f (Four g h i j) m2 =
- appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2
-addDigits3 m1 (Four a b c d) e f g (One h) m2 =
- appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
-addDigits3 m1 (Four a b c d) e f g (Two h i) m2 =
- appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2
-addDigits3 m1 (Four a b c d) e f g (Three h i j) m2 =
- appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2
-addDigits3 m1 (Four a b c d) e f g (Four h i j k) m2 =
- appendTree4 m1 (node3 a b c) (node3 d e f) (node3 g h i) (node2 j k) m2
-
-appendTree4 :: FingerTree (Node a) -> Node a -> Node a -> Node a -> Node a -> FingerTree (Node a) -> FingerTree (Node a)
-appendTree4 Empty a b c d xs =
- a `consTree` b `consTree` c `consTree` d `consTree` xs
-appendTree4 xs a b c d Empty =
- xs `snocTree` a `snocTree` b `snocTree` c `snocTree` d
-appendTree4 (Single x) a b c d xs =
- x `consTree` a `consTree` b `consTree` c `consTree` d `consTree` xs
-appendTree4 xs a b c d (Single x) =
- xs `snocTree` a `snocTree` b `snocTree` c `snocTree` d `snocTree` x
-appendTree4 (Deep s1 pr1 m1 sf1) a b c d (Deep s2 pr2 m2 sf2) =
- Deep (s1 + size a + size b + size c + size d + s2) pr1 (addDigits4 m1 sf1 a b c d pr2 m2) sf2
-
-addDigits4 :: FingerTree (Node (Node a)) -> Digit (Node a) -> Node a -> Node a -> Node a -> Node a -> Digit (Node a) -> FingerTree (Node (Node a)) -> FingerTree (Node (Node a))
-addDigits4 m1 (One a) b c d e (One f) m2 =
- appendTree2 m1 (node3 a b c) (node3 d e f) m2
-addDigits4 m1 (One a) b c d e (Two f g) m2 =
- appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
-addDigits4 m1 (One a) b c d e (Three f g h) m2 =
- appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
-addDigits4 m1 (One a) b c d e (Four f g h i) m2 =
- appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2
-addDigits4 m1 (Two a b) c d e f (One g) m2 =
- appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
-addDigits4 m1 (Two a b) c d e f (Two g h) m2 =
- appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
-addDigits4 m1 (Two a b) c d e f (Three g h i) m2 =
- appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2
-addDigits4 m1 (Two a b) c d e f (Four g h i j) m2 =
- appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2
-addDigits4 m1 (Three a b c) d e f g (One h) m2 =
- appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
-addDigits4 m1 (Three a b c) d e f g (Two h i) m2 =
- appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2
-addDigits4 m1 (Three a b c) d e f g (Three h i j) m2 =
- appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2
-addDigits4 m1 (Three a b c) d e f g (Four h i j k) m2 =
- appendTree4 m1 (node3 a b c) (node3 d e f) (node3 g h i) (node2 j k) m2
-addDigits4 m1 (Four a b c d) e f g h (One i) m2 =
- appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2
-addDigits4 m1 (Four a b c d) e f g h (Two i j) m2 =
- appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2
-addDigits4 m1 (Four a b c d) e f g h (Three i j k) m2 =
- appendTree4 m1 (node3 a b c) (node3 d e f) (node3 g h i) (node2 j k) m2
-addDigits4 m1 (Four a b c d) e f g h (Four i j k l) m2 =
- appendTree4 m1 (node3 a b c) (node3 d e f) (node3 g h i) (node3 j k l) m2
-
-------------------------------------------------------------------------
--- Deconstruction
-------------------------------------------------------------------------
-
--- | /O(1)/. Is this the empty sequence?
-null :: Seq a -> Bool
-null (Seq Empty) = True
-null _ = False
-
--- | /O(1)/. The number of elements in the sequence.
-length :: Seq a -> Int
-length (Seq xs) = size xs
-
--- Views
-
-data Maybe2 a b = Nothing2 | Just2 a b
-
--- | View of the left end of a sequence.
-data ViewL a
- = EmptyL -- ^ empty sequence
- | a :< Seq a -- ^ leftmost element and the rest of the sequence
-#ifndef __HADDOCK__
-# if __GLASGOW_HASKELL__
- deriving (Eq, Ord, Show, Read, Data)
-# else
- deriving (Eq, Ord, Show, Read)
-# endif
-#else
-instance Eq a => Eq (ViewL a)
-instance Ord a => Ord (ViewL a)
-instance Show a => Show (ViewL a)
-instance Read a => Read (ViewL a)
-instance Data a => Data (ViewL a)
-#endif
-
-INSTANCE_TYPEABLE1(ViewL,viewLTc,"ViewL")
-
-instance Functor ViewL where
- fmap = fmapDefault
-
-instance Foldable ViewL where
- foldr f z EmptyL = z
- foldr f z (x :< xs) = f x (foldr f z xs)
-
- foldl f z EmptyL = z
- foldl f z (x :< xs) = foldl f (f z x) xs
-
- foldl1 f EmptyL = error "foldl1: empty view"
- foldl1 f (x :< xs) = foldl f x xs
-
-instance Traversable ViewL where
- traverse _ EmptyL = pure EmptyL
- traverse f (x :< xs) = (:<) <$> f x <*> traverse f xs
-
--- | /O(1)/. Analyse the left end of a sequence.
-viewl :: Seq a -> ViewL a
-viewl (Seq xs) = case viewLTree xs of
- Nothing2 -> EmptyL
- Just2 (Elem x) xs' -> x :< Seq xs'
-
-{-# SPECIALIZE viewLTree :: FingerTree (Elem a) -> Maybe2 (Elem a) (FingerTree (Elem a)) #-}
-{-# SPECIALIZE viewLTree :: FingerTree (Node a) -> Maybe2 (Node a) (FingerTree (Node a)) #-}
-viewLTree :: Sized a => FingerTree a -> Maybe2 a (FingerTree a)
-viewLTree Empty = Nothing2
-viewLTree (Single a) = Just2 a Empty
-viewLTree (Deep s (One a) m sf) = Just2 a (case viewLTree m of
- Nothing2 -> digitToTree sf
- Just2 b m' -> Deep (s - size a) (nodeToDigit b) m' sf)
-viewLTree (Deep s (Two a b) m sf) =
- Just2 a (Deep (s - size a) (One b) m sf)
-viewLTree (Deep s (Three a b c) m sf) =
- Just2 a (Deep (s - size a) (Two b c) m sf)
-viewLTree (Deep s (Four a b c d) m sf) =
- Just2 a (Deep (s - size a) (Three b c d) m sf)
-
--- | View of the right end of a sequence.
-data ViewR a
- = EmptyR -- ^ empty sequence
- | Seq a :> a -- ^ the sequence minus the rightmost element,
- -- and the rightmost element
-#ifndef __HADDOCK__
-# if __GLASGOW_HASKELL__
- deriving (Eq, Ord, Show, Read, Data)
-# else
- deriving (Eq, Ord, Show, Read)
-# endif
-#else
-instance Eq a => Eq (ViewR a)
-instance Ord a => Ord (ViewR a)
-instance Show a => Show (ViewR a)
-instance Read a => Read (ViewR a)
-instance Data a => Data (ViewR a)
-#endif
-
-INSTANCE_TYPEABLE1(ViewR,viewRTc,"ViewR")
-
-instance Functor ViewR where
- fmap = fmapDefault
-
-instance Foldable ViewR where
- foldr f z EmptyR = z
- foldr f z (xs :> x) = foldr f (f x z) xs
-
- foldl f z EmptyR = z
- foldl f z (xs :> x) = f (foldl f z xs) x
-
- foldr1 f EmptyR = error "foldr1: empty view"
- foldr1 f (xs :> x) = foldr f x xs
-
-instance Traversable ViewR where
- traverse _ EmptyR = pure EmptyR
- traverse f (xs :> x) = (:>) <$> traverse f xs <*> f x
-
--- | /O(1)/. Analyse the right end of a sequence.
-viewr :: Seq a -> ViewR a
-viewr (Seq xs) = case viewRTree xs of
- Nothing2 -> EmptyR
- Just2 xs' (Elem x) -> Seq xs' :> x
-
-{-# SPECIALIZE viewRTree :: FingerTree (Elem a) -> Maybe2 (FingerTree (Elem a)) (Elem a) #-}
-{-# SPECIALIZE viewRTree :: FingerTree (Node a) -> Maybe2 (FingerTree (Node a)) (Node a) #-}
-viewRTree :: Sized a => FingerTree a -> Maybe2 (FingerTree a) a
-viewRTree Empty = Nothing2
-viewRTree (Single z) = Just2 Empty z
-viewRTree (Deep s pr m (One z)) = Just2 (case viewRTree m of
- Nothing2 -> digitToTree pr
- Just2 m' y -> Deep (s - size z) pr m' (nodeToDigit y)) z
-viewRTree (Deep s pr m (Two y z)) =
- Just2 (Deep (s - size z) pr m (One y)) z
-viewRTree (Deep s pr m (Three x y z)) =
- Just2 (Deep (s - size z) pr m (Two x y)) z
-viewRTree (Deep s pr m (Four w x y z)) =
- Just2 (Deep (s - size z) pr m (Three w x y)) z
-
--- Indexing
-
--- | /O(log(min(i,n-i)))/. The element at the specified position
-index :: Seq a -> Int -> a
-index (Seq xs) i
- | 0 <= i && i < size xs = case lookupTree i xs of
- Place _ (Elem x) -> x
- | otherwise = error "index out of bounds"
-
-data Place a = Place {-# UNPACK #-} !Int a
-#if TESTING
- deriving Show
-#endif
-
-{-# SPECIALIZE lookupTree :: Int -> FingerTree (Elem a) -> Place (Elem a) #-}
-{-# SPECIALIZE lookupTree :: Int -> FingerTree (Node a) -> Place (Node a) #-}
-lookupTree :: Sized a => Int -> FingerTree a -> Place a
-lookupTree _ Empty = error "lookupTree of empty tree"
-lookupTree i (Single x) = Place i x
-lookupTree i (Deep _ pr m sf)
- | i < spr = lookupDigit i pr
- | i < spm = case lookupTree (i - spr) m of
- Place i' xs -> lookupNode i' xs
- | otherwise = lookupDigit (i - spm) sf
- where spr = size pr
- spm = spr + size m
-
-{-# SPECIALIZE lookupNode :: Int -> Node (Elem a) -> Place (Elem a) #-}
-{-# SPECIALIZE lookupNode :: Int -> Node (Node a) -> Place (Node a) #-}
-lookupNode :: Sized a => Int -> Node a -> Place a
-lookupNode i (Node2 _ a b)
- | i < sa = Place i a
- | otherwise = Place (i - sa) b
- where sa = size a
-lookupNode i (Node3 _ a b c)
- | i < sa = Place i a
- | i < sab = Place (i - sa) b
- | otherwise = Place (i - sab) c
- where sa = size a
- sab = sa + size b
-
-{-# SPECIALIZE lookupDigit :: Int -> Digit (Elem a) -> Place (Elem a) #-}
-{-# SPECIALIZE lookupDigit :: Int -> Digit (Node a) -> Place (Node a) #-}
-lookupDigit :: Sized a => Int -> Digit a -> Place a
-lookupDigit i (One a) = Place i a
-lookupDigit i (Two a b)
- | i < sa = Place i a
- | otherwise = Place (i - sa) b
- where sa = size a
-lookupDigit i (Three a b c)
- | i < sa = Place i a
- | i < sab = Place (i - sa) b
- | otherwise = Place (i - sab) c
- where sa = size a
- sab = sa + size b
-lookupDigit i (Four a b c d)
- | i < sa = Place i a
- | i < sab = Place (i - sa) b
- | i < sabc = Place (i - sab) c
- | otherwise = Place (i - sabc) d
- where sa = size a
- sab = sa + size b
- sabc = sab + size c
-
--- | /O(log(min(i,n-i)))/. Replace the element at the specified position
-update :: Int -> a -> Seq a -> Seq a
-update i x = adjust (const x) i
-
--- | /O(log(min(i,n-i)))/. Update the element at the specified position
-adjust :: (a -> a) -> Int -> Seq a -> Seq a
-adjust f i (Seq xs)
- | 0 <= i && i < size xs = Seq (adjustTree (const (fmap f)) i xs)
- | otherwise = Seq xs
-
-{-# SPECIALIZE adjustTree :: (Int -> Elem a -> Elem a) -> Int -> FingerTree (Elem a) -> FingerTree (Elem a) #-}
-{-# SPECIALIZE adjustTree :: (Int -> Node a -> Node a) -> Int -> FingerTree (Node a) -> FingerTree (Node a) #-}
-adjustTree :: Sized a => (Int -> a -> a) ->
- Int -> FingerTree a -> FingerTree a
-adjustTree _ _ Empty = error "adjustTree of empty tree"
-adjustTree f i (Single x) = Single (f i x)
-adjustTree f i (Deep s pr m sf)
- | i < spr = Deep s (adjustDigit f i pr) m sf
- | i < spm = Deep s pr (adjustTree (adjustNode f) (i - spr) m) sf
- | otherwise = Deep s pr m (adjustDigit f (i - spm) sf)
- where spr = size pr
- spm = spr + size m
-
-{-# SPECIALIZE adjustNode :: (Int -> Elem a -> Elem a) -> Int -> Node (Elem a) -> Node (Elem a) #-}
-{-# SPECIALIZE adjustNode :: (Int -> Node a -> Node a) -> Int -> Node (Node a) -> Node (Node a) #-}
-adjustNode :: Sized a => (Int -> a -> a) -> Int -> Node a -> Node a
-adjustNode f i (Node2 s a b)
- | i < sa = Node2 s (f i a) b
- | otherwise = Node2 s a (f (i - sa) b)
- where sa = size a
-adjustNode f i (Node3 s a b c)
- | i < sa = Node3 s (f i a) b c
- | i < sab = Node3 s a (f (i - sa) b) c
- | otherwise = Node3 s a b (f (i - sab) c)
- where sa = size a
- sab = sa + size b
-
-{-# SPECIALIZE adjustDigit :: (Int -> Elem a -> Elem a) -> Int -> Digit (Elem a) -> Digit (Elem a) #-}
-{-# SPECIALIZE adjustDigit :: (Int -> Node a -> Node a) -> Int -> Digit (Node a) -> Digit (Node a) #-}
-adjustDigit :: Sized a => (Int -> a -> a) -> Int -> Digit a -> Digit a
-adjustDigit f i (One a) = One (f i a)
-adjustDigit f i (Two a b)
- | i < sa = Two (f i a) b
- | otherwise = Two a (f (i - sa) b)
- where sa = size a
-adjustDigit f i (Three a b c)
- | i < sa = Three (f i a) b c
- | i < sab = Three a (f (i - sa) b) c
- | otherwise = Three a b (f (i - sab) c)
- where sa = size a
- sab = sa + size b
-adjustDigit f i (Four a b c d)
- | i < sa = Four (f i a) b c d
- | i < sab = Four a (f (i - sa) b) c d
- | i < sabc = Four a b (f (i - sab) c) d
- | otherwise = Four a b c (f (i- sabc) d)
- where sa = size a
- sab = sa + size b
- sabc = sab + size c
-
--- Splitting
-
--- | /O(log(min(i,n-i)))/. The first @i@ elements of a sequence.
-take :: Int -> Seq a -> Seq a
-take i = fst . splitAt i
-
--- | /O(log(min(i,n-i)))/. Elements of a sequence after the first @i@.
-drop :: Int -> Seq a -> Seq a
-drop i = snd . splitAt i
-
--- | /O(log(min(i,n-i)))/. Split a sequence at a given position.
-splitAt :: Int -> Seq a -> (Seq a, Seq a)
-splitAt i (Seq xs) = (Seq l, Seq r)
- where (l, r) = split i xs
-
-split :: Int -> FingerTree (Elem a) ->
- (FingerTree (Elem a), FingerTree (Elem a))
-split i Empty = i `seq` (Empty, Empty)
-split i xs
- | size xs > i = (l, consTree x r)
- | otherwise = (xs, Empty)
- where Split l x r = splitTree i xs
-
-data Split t a = Split t a t
-#if TESTING
- deriving Show
-#endif
-
-{-# SPECIALIZE splitTree :: Int -> FingerTree (Elem a) -> Split (FingerTree (Elem a)) (Elem a) #-}
-{-# SPECIALIZE splitTree :: Int -> FingerTree (Node a) -> Split (FingerTree (Node a)) (Node a) #-}
-splitTree :: Sized a => Int -> FingerTree a -> Split (FingerTree a) a
-splitTree _ Empty = error "splitTree of empty tree"
-splitTree i (Single x) = i `seq` Split Empty x Empty
-splitTree i (Deep _ pr m sf)
- | i < spr = case splitDigit i pr of
- Split l x r -> Split (maybe Empty digitToTree l) x (deepL r m sf)
- | i < spm = case splitTree im m of
- Split ml xs mr -> case splitNode (im - size ml) xs of
- Split l x r -> Split (deepR pr ml l) x (deepL r mr sf)
- | otherwise = case splitDigit (i - spm) sf of
- Split l x r -> Split (deepR pr m l) x (maybe Empty digitToTree r)
- where spr = size pr
- spm = spr + size m
- im = i - spr
-
-{-# SPECIALIZE deepL :: Maybe (Digit (Elem a)) -> FingerTree (Node (Elem a)) -> Digit (Elem a) -> FingerTree (Elem a) #-}
-{-# SPECIALIZE deepL :: Maybe (Digit (Node a)) -> FingerTree (Node (Node a)) -> Digit (Node a) -> FingerTree (Node a) #-}
-deepL :: Sized a => Maybe (Digit a) -> FingerTree (Node a) -> Digit a -> FingerTree a
-deepL Nothing m sf = case viewLTree m of
- Nothing2 -> digitToTree sf
- Just2 a m' -> deep (nodeToDigit a) m' sf
-deepL (Just pr) m sf = deep pr m sf
-
-{-# SPECIALIZE deepR :: Digit (Elem a) -> FingerTree (Node (Elem a)) -> Maybe (Digit (Elem a)) -> FingerTree (Elem a) #-}
-{-# SPECIALIZE deepR :: Digit (Node a) -> FingerTree (Node (Node a)) -> Maybe (Digit (Node a)) -> FingerTree (Node a) #-}
-deepR :: Sized a => Digit a -> FingerTree (Node a) -> Maybe (Digit a) -> FingerTree a
-deepR pr m Nothing = case viewRTree m of
- Nothing2 -> digitToTree pr
- Just2 m' a -> deep pr m' (nodeToDigit a)
-deepR pr m (Just sf) = deep pr m sf
-
-{-# SPECIALIZE splitNode :: Int -> Node (Elem a) -> Split (Maybe (Digit (Elem a))) (Elem a) #-}
-{-# SPECIALIZE splitNode :: Int -> Node (Node a) -> Split (Maybe (Digit (Node a))) (Node a) #-}
-splitNode :: Sized a => Int -> Node a -> Split (Maybe (Digit a)) a
-splitNode i (Node2 _ a b)
- | i < sa = Split Nothing a (Just (One b))
- | otherwise = Split (Just (One a)) b Nothing
- where sa = size a
-splitNode i (Node3 _ a b c)
- | i < sa = Split Nothing a (Just (Two b c))
- | i < sab = Split (Just (One a)) b (Just (One c))
- | otherwise = Split (Just (Two a b)) c Nothing
- where sa = size a
- sab = sa + size b
-
-{-# SPECIALIZE splitDigit :: Int -> Digit (Elem a) -> Split (Maybe (Digit (Elem a))) (Elem a) #-}
-{-# SPECIALIZE splitDigit :: Int -> Digit (Node a) -> Split (Maybe (Digit (Node a))) (Node a) #-}
-splitDigit :: Sized a => Int -> Digit a -> Split (Maybe (Digit a)) a
-splitDigit i (One a) = i `seq` Split Nothing a Nothing
-splitDigit i (Two a b)
- | i < sa = Split Nothing a (Just (One b))
- | otherwise = Split (Just (One a)) b Nothing
- where sa = size a
-splitDigit i (Three a b c)
- | i < sa = Split Nothing a (Just (Two b c))
- | i < sab = Split (Just (One a)) b (Just (One c))
- | otherwise = Split (Just (Two a b)) c Nothing
- where sa = size a
- sab = sa + size b
-splitDigit i (Four a b c d)
- | i < sa = Split Nothing a (Just (Three b c d))
- | i < sab = Split (Just (One a)) b (Just (Two c d))
- | i < sabc = Split (Just (Two a b)) c (Just (One d))
- | otherwise = Split (Just (Three a b c)) d Nothing
- where sa = size a
- sab = sa + size b
- sabc = sab + size c
-
-------------------------------------------------------------------------
--- Lists
-------------------------------------------------------------------------
-
--- | /O(n)/. Create a sequence from a finite list of elements.
--- There is a function 'toList' in the opposite direction for all
--- instances of the 'Foldable' class, including 'Seq'.
-fromList :: [a] -> Seq a
-fromList = Data.List.foldl' (|>) empty
-
-------------------------------------------------------------------------
--- Reverse
-------------------------------------------------------------------------
-
--- | /O(n)/. The reverse of a sequence.
-reverse :: Seq a -> Seq a
-reverse (Seq xs) = Seq (reverseTree id xs)
-
-reverseTree :: (a -> a) -> FingerTree a -> FingerTree a
-reverseTree _ Empty = Empty
-reverseTree f (Single x) = Single (f x)
-reverseTree f (Deep s pr m sf) =
- Deep s (reverseDigit f sf)
- (reverseTree (reverseNode f) m)
- (reverseDigit f pr)
-
-reverseDigit :: (a -> a) -> Digit a -> Digit a
-reverseDigit f (One a) = One (f a)
-reverseDigit f (Two a b) = Two (f b) (f a)
-reverseDigit f (Three a b c) = Three (f c) (f b) (f a)
-reverseDigit f (Four a b c d) = Four (f d) (f c) (f b) (f a)
-
-reverseNode :: (a -> a) -> Node a -> Node a
-reverseNode f (Node2 s a b) = Node2 s (f b) (f a)
-reverseNode f (Node3 s a b c) = Node3 s (f c) (f b) (f a)
-
-#if TESTING
-
-------------------------------------------------------------------------
--- QuickCheck
-------------------------------------------------------------------------
-
-instance Arbitrary a => Arbitrary (Seq a) where
- arbitrary = liftM Seq arbitrary
- coarbitrary (Seq x) = coarbitrary x
-
-instance Arbitrary a => Arbitrary (Elem a) where
- arbitrary = liftM Elem arbitrary
- coarbitrary (Elem x) = coarbitrary x
-
-instance (Arbitrary a, Sized a) => Arbitrary (FingerTree a) where
- arbitrary = sized arb
- where arb :: (Arbitrary a, Sized a) => Int -> Gen (FingerTree a)
- arb 0 = return Empty
- arb 1 = liftM Single arbitrary
- arb n = liftM3 deep arbitrary (arb (n `div` 2)) arbitrary
-
- coarbitrary Empty = variant 0
- coarbitrary (Single x) = variant 1 . coarbitrary x
- coarbitrary (Deep _ pr m sf) =
- variant 2 . coarbitrary pr . coarbitrary m . coarbitrary sf
-
-instance (Arbitrary a, Sized a) => Arbitrary (Node a) where
- arbitrary = oneof [
- liftM2 node2 arbitrary arbitrary,
- liftM3 node3 arbitrary arbitrary arbitrary]
-
- coarbitrary (Node2 _ a b) = variant 0 . coarbitrary a . coarbitrary b
- coarbitrary (Node3 _ a b c) =
- variant 1 . coarbitrary a . coarbitrary b . coarbitrary c
-
-instance Arbitrary a => Arbitrary (Digit a) where
- arbitrary = oneof [
- liftM One arbitrary,
- liftM2 Two arbitrary arbitrary,
- liftM3 Three arbitrary arbitrary arbitrary,
- liftM4 Four arbitrary arbitrary arbitrary arbitrary]
-
- coarbitrary (One a) = variant 0 . coarbitrary a
- coarbitrary (Two a b) = variant 1 . coarbitrary a . coarbitrary b
- coarbitrary (Three a b c) =
- variant 2 . coarbitrary a . coarbitrary b . coarbitrary c
- coarbitrary (Four a b c d) =
- variant 3 . coarbitrary a . coarbitrary b . coarbitrary c . coarbitrary d
-
-------------------------------------------------------------------------
--- Valid trees
-------------------------------------------------------------------------
-
-class Valid a where
- valid :: a -> Bool
-
-instance Valid (Elem a) where
- valid _ = True
-
-instance Valid (Seq a) where
- valid (Seq xs) = valid xs
-
-instance (Sized a, Valid a) => Valid (FingerTree a) where
- valid Empty = True
- valid (Single x) = valid x
- valid (Deep s pr m sf) =
- s == size pr + size m + size sf && valid pr && valid m && valid sf
-
-instance (Sized a, Valid a) => Valid (Node a) where
- valid (Node2 s a b) = s == size a + size b && valid a && valid b
- valid (Node3 s a b c) =
- s == size a + size b + size c && valid a && valid b && valid c
-
-instance Valid a => Valid (Digit a) where
- valid (One a) = valid a
- valid (Two a b) = valid a && valid b
- valid (Three a b c) = valid a && valid b && valid c
- valid (Four a b c d) = valid a && valid b && valid c && valid d
-
-#endif
+++ /dev/null
------------------------------------------------------------------------------
--- |
--- Module : Data.Set
--- Copyright : (c) Daan Leijen 2002
--- License : BSD-style
--- Maintainer : libraries@haskell.org
--- Stability : provisional
--- Portability : portable
---
--- An efficient implementation of sets.
---
--- Since many function names (but not the type name) clash with
--- "Prelude" names, this module is usually imported @qualified@, e.g.
---
--- > import Data.Set (Set)
--- > import qualified Data.Set as Set
---
--- The implementation of 'Set' is based on /size balanced/ binary trees (or
--- trees of /bounded balance/) as described by:
---
--- * Stephen Adams, \"/Efficient sets: a balancing act/\",
--- Journal of Functional Programming 3(4):553-562, October 1993,
--- <http://www.swiss.ai.mit.edu/~adams/BB>.
---
--- * J. Nievergelt and E.M. Reingold,
--- \"/Binary search trees of bounded balance/\",
--- SIAM journal of computing 2(1), March 1973.
---
--- Note that the implementation is /left-biased/ -- the elements of a
--- first argument are always preferred to the second, for example in
--- 'union' or 'insert'. Of course, left-biasing can only be observed
--- when equality is an equivalence relation instead of structural
--- equality.
------------------------------------------------------------------------------
-
-module Data.Set (
- -- * Set type
- Set -- instance Eq,Ord,Show,Read,Data,Typeable
-
- -- * Operators
- , (\\)
-
- -- * Query
- , null
- , size
- , member
- , notMember
- , isSubsetOf
- , isProperSubsetOf
-
- -- * Construction
- , empty
- , singleton
- , insert
- , delete
-
- -- * Combine
- , union, unions
- , difference
- , intersection
-
- -- * Filter
- , filter
- , partition
- , split
- , splitMember
-
- -- * Map
- , map
- , mapMonotonic
-
- -- * Fold
- , fold
-
- -- * Min\/Max
- , findMin
- , findMax
- , deleteMin
- , deleteMax
- , deleteFindMin
- , deleteFindMax
- , maxView
- , minView
-
- -- * Conversion
-
- -- ** List
- , elems
- , toList
- , fromList
-
- -- ** Ordered list
- , toAscList
- , fromAscList
- , fromDistinctAscList
-
- -- * Debugging
- , showTree
- , showTreeWith
- , valid
- ) where
-
-import Prelude hiding (filter,foldr,null,map)
-import qualified Data.List as List
-import Data.Monoid (Monoid(..))
-import Data.Typeable
-import Data.Foldable (Foldable(foldMap))
-
-{-
--- just for testing
-import QuickCheck
-import List (nub,sort)
-import qualified List
--}
-
-#if __GLASGOW_HASKELL__
-import Text.Read
-import Data.Generics.Basics
-import Data.Generics.Instances
-#endif
-
-{--------------------------------------------------------------------
- Operators
---------------------------------------------------------------------}
-infixl 9 \\ --
-
--- | /O(n+m)/. See 'difference'.
-(\\) :: Ord a => Set a -> Set a -> Set a
-m1 \\ m2 = difference m1 m2
-
-{--------------------------------------------------------------------
- Sets are size balanced trees
---------------------------------------------------------------------}
--- | A set of values @a@.
-data Set a = Tip
- | Bin {-# UNPACK #-} !Size a !(Set a) !(Set a)
-
-type Size = Int
-
-instance Ord a => Monoid (Set a) where
- mempty = empty
- mappend = union
- mconcat = unions
-
-instance Foldable Set where
- foldMap f Tip = mempty
- foldMap f (Bin _s k l r) = foldMap f l `mappend` f k `mappend` foldMap f r
-
-#if __GLASGOW_HASKELL__
-
-{--------------------------------------------------------------------
- A Data instance
---------------------------------------------------------------------}
-
--- This instance preserves data abstraction at the cost of inefficiency.
--- We omit reflection services for the sake of data abstraction.
-
-instance (Data a, Ord a) => Data (Set a) where
- gfoldl f z set = z fromList `f` (toList set)
- toConstr _ = error "toConstr"
- gunfold _ _ = error "gunfold"
- dataTypeOf _ = mkNorepType "Data.Set.Set"
- dataCast1 f = gcast1 f
-
-#endif
-
-{--------------------------------------------------------------------
- Query
---------------------------------------------------------------------}
--- | /O(1)/. Is this the empty set?
-null :: Set a -> Bool
-null t
- = case t of
- Tip -> True
- Bin sz x l r -> False
-
--- | /O(1)/. The number of elements in the set.
-size :: Set a -> Int
-size t
- = case t of
- Tip -> 0
- Bin sz x l r -> sz
-
--- | /O(log n)/. Is the element in the set?
-member :: Ord a => a -> Set a -> Bool
-member x t
- = case t of
- Tip -> False
- Bin sz y l r
- -> case compare x y of
- LT -> member x l
- GT -> member x r
- EQ -> True
-
--- | /O(log n)/. Is the element not in the set?
-notMember :: Ord a => a -> Set a -> Bool
-notMember x t = not $ member x t
-
-{--------------------------------------------------------------------
- Construction
---------------------------------------------------------------------}
--- | /O(1)/. The empty set.
-empty :: Set a
-empty
- = Tip
-
--- | /O(1)/. Create a singleton set.
-singleton :: a -> Set a
-singleton x
- = Bin 1 x Tip Tip
-
-{--------------------------------------------------------------------
- Insertion, Deletion
---------------------------------------------------------------------}
--- | /O(log n)/. Insert an element in a set.
--- If the set already contains an element equal to the given value,
--- it is replaced with the new value.
-insert :: Ord a => a -> Set a -> Set a
-insert x t
- = case t of
- Tip -> singleton x
- Bin sz y l r
- -> case compare x y of
- LT -> balance y (insert x l) r
- GT -> balance y l (insert x r)
- EQ -> Bin sz x l r
-
-
--- | /O(log n)/. Delete an element from a set.
-delete :: Ord a => a -> Set a -> Set a
-delete x t
- = case t of
- Tip -> Tip
- Bin sz y l r
- -> case compare x y of
- LT -> balance y (delete x l) r
- GT -> balance y l (delete x r)
- EQ -> glue l r
-
-{--------------------------------------------------------------------
- Subset
---------------------------------------------------------------------}
--- | /O(n+m)/. Is this a proper subset? (ie. a subset but not equal).
-isProperSubsetOf :: Ord a => Set a -> Set a -> Bool
-isProperSubsetOf s1 s2
- = (size s1 < size s2) && (isSubsetOf s1 s2)
-
-
--- | /O(n+m)/. Is this a subset?
--- @(s1 `isSubsetOf` s2)@ tells whether @s1@ is a subset of @s2@.
-isSubsetOf :: Ord a => Set a -> Set a -> Bool
-isSubsetOf t1 t2
- = (size t1 <= size t2) && (isSubsetOfX t1 t2)
-
-isSubsetOfX Tip t = True
-isSubsetOfX t Tip = False
-isSubsetOfX (Bin _ x l r) t
- = found && isSubsetOfX l lt && isSubsetOfX r gt
- where
- (lt,found,gt) = splitMember x t
-
-
-{--------------------------------------------------------------------
- Minimal, Maximal
---------------------------------------------------------------------}
--- | /O(log n)/. The minimal element of a set.
-findMin :: Set a -> a
-findMin (Bin _ x Tip r) = x
-findMin (Bin _ x l r) = findMin l
-findMin Tip = error "Set.findMin: empty set has no minimal element"
-
--- | /O(log n)/. The maximal element of a set.
-findMax :: Set a -> a
-findMax (Bin _ x l Tip) = x
-findMax (Bin _ x l r) = findMax r
-findMax Tip = error "Set.findMax: empty set has no maximal element"
-
--- | /O(log n)/. Delete the minimal element.
-deleteMin :: Set a -> Set a
-deleteMin (Bin _ x Tip r) = r
-deleteMin (Bin _ x l r) = balance x (deleteMin l) r
-deleteMin Tip = Tip
-
--- | /O(log n)/. Delete the maximal element.
-deleteMax :: Set a -> Set a
-deleteMax (Bin _ x l Tip) = l
-deleteMax (Bin _ x l r) = balance x l (deleteMax r)
-deleteMax Tip = Tip
-
-
-{--------------------------------------------------------------------
- Union.
---------------------------------------------------------------------}
--- | The union of a list of sets: (@'unions' == 'foldl' 'union' 'empty'@).
-unions :: Ord a => [Set a] -> Set a
-unions ts
- = foldlStrict union empty ts
-
-
--- | /O(n+m)/. The union of two sets, preferring the first set when
--- equal elements are encountered.
--- The implementation uses the efficient /hedge-union/ algorithm.
--- Hedge-union is more efficient on (bigset `union` smallset).
-union :: Ord a => Set a -> Set a -> Set a
-union Tip t2 = t2
-union t1 Tip = t1
-union t1 t2 = hedgeUnion (const LT) (const GT) t1 t2
-
-hedgeUnion cmplo cmphi t1 Tip
- = t1
-hedgeUnion cmplo cmphi Tip (Bin _ x l r)
- = join x (filterGt cmplo l) (filterLt cmphi r)
-hedgeUnion cmplo cmphi (Bin _ x l r) t2
- = join x (hedgeUnion cmplo cmpx l (trim cmplo cmpx t2))
- (hedgeUnion cmpx cmphi r (trim cmpx cmphi t2))
- where
- cmpx y = compare x y
-
-{--------------------------------------------------------------------
- Difference
---------------------------------------------------------------------}
--- | /O(n+m)/. Difference of two sets.
--- The implementation uses an efficient /hedge/ algorithm comparable with /hedge-union/.
-difference :: Ord a => Set a -> Set a -> Set a
-difference Tip t2 = Tip
-difference t1 Tip = t1
-difference t1 t2 = hedgeDiff (const LT) (const GT) t1 t2
-
-hedgeDiff cmplo cmphi Tip t
- = Tip
-hedgeDiff cmplo cmphi (Bin _ x l r) Tip
- = join x (filterGt cmplo l) (filterLt cmphi r)
-hedgeDiff cmplo cmphi t (Bin _ x l r)
- = merge (hedgeDiff cmplo cmpx (trim cmplo cmpx t) l)
- (hedgeDiff cmpx cmphi (trim cmpx cmphi t) r)
- where
- cmpx y = compare x y
-
-{--------------------------------------------------------------------
- Intersection
---------------------------------------------------------------------}
--- | /O(n+m)/. The intersection of two sets.
--- Elements of the result come from the first set, so for example
---
--- > import qualified Data.Set as S
--- > data AB = A | B deriving Show
--- > instance Ord AB where compare _ _ = EQ
--- > instance Eq AB where _ == _ = True
--- > main = print (S.singleton A `S.intersection` S.singleton B,
--- > S.singleton B `S.intersection` S.singleton A)
---
--- prints @(fromList [A],fromList [B])@.
-intersection :: Ord a => Set a -> Set a -> Set a
-intersection Tip t = Tip
-intersection t Tip = Tip
-intersection t1@(Bin s1 x1 l1 r1) t2@(Bin s2 x2 l2 r2) =
- if s1 >= s2 then
- let (lt,found,gt) = splitLookup x2 t1
- tl = intersection lt l2
- tr = intersection gt r2
- in case found of
- Just x -> join x tl tr
- Nothing -> merge tl tr
- else let (lt,found,gt) = splitMember x1 t2
- tl = intersection l1 lt
- tr = intersection r1 gt
- in if found then join x1 tl tr
- else merge tl tr
-
-{--------------------------------------------------------------------
- Filter and partition
---------------------------------------------------------------------}
--- | /O(n)/. Filter all elements that satisfy the predicate.
-filter :: Ord a => (a -> Bool) -> Set a -> Set a
-filter p Tip = Tip
-filter p (Bin _ x l r)
- | p x = join x (filter p l) (filter p r)
- | otherwise = merge (filter p l) (filter p r)
-
--- | /O(n)/. Partition the set into two sets, one with all elements that satisfy
--- the predicate and one with all elements that don't satisfy the predicate.
--- See also 'split'.
-partition :: Ord a => (a -> Bool) -> Set a -> (Set a,Set a)
-partition p Tip = (Tip,Tip)
-partition p (Bin _ x l r)
- | p x = (join x l1 r1,merge l2 r2)
- | otherwise = (merge l1 r1,join x l2 r2)
- where
- (l1,l2) = partition p l
- (r1,r2) = partition p r
-
-{----------------------------------------------------------------------
- Map
-----------------------------------------------------------------------}
-
--- | /O(n*log n)/.
--- @'map' f s@ is the set obtained by applying @f@ to each element of @s@.
---
--- It's worth noting that the size of the result may be smaller if,
--- for some @(x,y)@, @x \/= y && f x == f y@
-
-map :: (Ord a, Ord b) => (a->b) -> Set a -> Set b
-map f = fromList . List.map f . toList
-
--- | /O(n)/. The
---
--- @'mapMonotonic' f s == 'map' f s@, but works only when @f@ is monotonic.
--- /The precondition is not checked./
--- Semi-formally, we have:
---
--- > and [x < y ==> f x < f y | x <- ls, y <- ls]
--- > ==> mapMonotonic f s == map f s
--- > where ls = toList s
-
-mapMonotonic :: (a->b) -> Set a -> Set b
-mapMonotonic f Tip = Tip
-mapMonotonic f (Bin sz x l r) =
- Bin sz (f x) (mapMonotonic f l) (mapMonotonic f r)
-
-
-{--------------------------------------------------------------------
- Fold
---------------------------------------------------------------------}
--- | /O(n)/. Fold over the elements of a set in an unspecified order.
-fold :: (a -> b -> b) -> b -> Set a -> b
-fold f z s
- = foldr f z s
-
--- | /O(n)/. Post-order fold.
-foldr :: (a -> b -> b) -> b -> Set a -> b
-foldr f z Tip = z
-foldr f z (Bin _ x l r) = foldr f (f x (foldr f z r)) l
-
-{--------------------------------------------------------------------
- List variations
---------------------------------------------------------------------}
--- | /O(n)/. The elements of a set.
-elems :: Set a -> [a]
-elems s
- = toList s
-
-{--------------------------------------------------------------------
- Lists
---------------------------------------------------------------------}
--- | /O(n)/. Convert the set to a list of elements.
-toList :: Set a -> [a]
-toList s
- = toAscList s
-
--- | /O(n)/. Convert the set to an ascending list of elements.
-toAscList :: Set a -> [a]
-toAscList t
- = foldr (:) [] t
-
-
--- | /O(n*log n)/. Create a set from a list of elements.
-fromList :: Ord a => [a] -> Set a
-fromList xs
- = foldlStrict ins empty xs
- where
- ins t x = insert x t
-
-{--------------------------------------------------------------------
- Building trees from ascending/descending lists can be done in linear time.
-
- Note that if [xs] is ascending that:
- fromAscList xs == fromList xs
---------------------------------------------------------------------}
--- | /O(n)/. Build a set from an ascending list in linear time.
--- /The precondition (input list is ascending) is not checked./
-fromAscList :: Eq a => [a] -> Set a
-fromAscList xs
- = fromDistinctAscList (combineEq xs)
- where
- -- [combineEq xs] combines equal elements with [const] in an ordered list [xs]
- combineEq xs
- = case xs of
- [] -> []
- [x] -> [x]
- (x:xx) -> combineEq' x xx
-
- combineEq' z [] = [z]
- combineEq' z (x:xs)
- | z==x = combineEq' z xs
- | otherwise = z:combineEq' x xs
-
-
--- | /O(n)/. Build a set from an ascending list of distinct elements in linear time.
--- /The precondition (input list is strictly ascending) is not checked./
-fromDistinctAscList :: [a] -> Set a
-fromDistinctAscList xs
- = build const (length xs) xs
- where
- -- 1) use continutations so that we use heap space instead of stack space.
- -- 2) special case for n==5 to build bushier trees.
- build c 0 xs = c Tip xs
- build c 5 xs = case xs of
- (x1:x2:x3:x4:x5:xx)
- -> c (bin x4 (bin x2 (singleton x1) (singleton x3)) (singleton x5)) xx
- build c n xs = seq nr $ build (buildR nr c) nl xs
- where
- nl = n `div` 2
- nr = n - nl - 1
-
- buildR n c l (x:ys) = build (buildB l x c) n ys
- buildB l x c r zs = c (bin x l r) zs
-
-{--------------------------------------------------------------------
- Eq converts the set to a list. In a lazy setting, this
- actually seems one of the faster methods to compare two trees
- and it is certainly the simplest :-)
---------------------------------------------------------------------}
-instance Eq a => Eq (Set a) where
- t1 == t2 = (size t1 == size t2) && (toAscList t1 == toAscList t2)
-
-{--------------------------------------------------------------------
- Ord
---------------------------------------------------------------------}
-
-instance Ord a => Ord (Set a) where
- compare s1 s2 = compare (toAscList s1) (toAscList s2)
-
-{--------------------------------------------------------------------
- Show
---------------------------------------------------------------------}
-instance Show a => Show (Set a) where
- showsPrec p xs = showParen (p > 10) $
- showString "fromList " . shows (toList xs)
-
-showSet :: (Show a) => [a] -> ShowS
-showSet []
- = showString "{}"
-showSet (x:xs)
- = showChar '{' . shows x . showTail xs
- where
- showTail [] = showChar '}'
- showTail (x:xs) = showChar ',' . shows x . showTail xs
-
-{--------------------------------------------------------------------
- Read
---------------------------------------------------------------------}
-instance (Read a, Ord a) => Read (Set a) where
-#ifdef __GLASGOW_HASKELL__
- readPrec = parens $ prec 10 $ do
- Ident "fromList" <- lexP
- xs <- readPrec
- return (fromList xs)
-
- readListPrec = readListPrecDefault
-#else
- readsPrec p = readParen (p > 10) $ \ r -> do
- ("fromList",s) <- lex r
- (xs,t) <- reads s
- return (fromList xs,t)
-#endif
-
-{--------------------------------------------------------------------
- Typeable/Data
---------------------------------------------------------------------}
-
-#include "Typeable.h"
-INSTANCE_TYPEABLE1(Set,setTc,"Set")
-
-{--------------------------------------------------------------------
- Utility functions that return sub-ranges of the original
- tree. Some functions take a comparison function as argument to
- allow comparisons against infinite values. A function [cmplo x]
- should be read as [compare lo x].
-
- [trim cmplo cmphi t] A tree that is either empty or where [cmplo x == LT]
- and [cmphi x == GT] for the value [x] of the root.
- [filterGt cmp t] A tree where for all values [k]. [cmp k == LT]
- [filterLt cmp t] A tree where for all values [k]. [cmp k == GT]
-
- [split k t] Returns two trees [l] and [r] where all values
- in [l] are <[k] and all keys in [r] are >[k].
- [splitMember k t] Just like [split] but also returns whether [k]
- was found in the tree.
---------------------------------------------------------------------}
-
-{--------------------------------------------------------------------
- [trim lo hi t] trims away all subtrees that surely contain no
- values between the range [lo] to [hi]. The returned tree is either
- empty or the key of the root is between @lo@ and @hi@.
---------------------------------------------------------------------}
-trim :: (a -> Ordering) -> (a -> Ordering) -> Set a -> Set a
-trim cmplo cmphi Tip = Tip
-trim cmplo cmphi t@(Bin sx x l r)
- = case cmplo x of
- LT -> case cmphi x of
- GT -> t
- le -> trim cmplo cmphi l
- ge -> trim cmplo cmphi r
-
-trimMemberLo :: Ord a => a -> (a -> Ordering) -> Set a -> (Bool, Set a)
-trimMemberLo lo cmphi Tip = (False,Tip)
-trimMemberLo lo cmphi t@(Bin sx x l r)
- = case compare lo x of
- LT -> case cmphi x of
- GT -> (member lo t, t)
- le -> trimMemberLo lo cmphi l
- GT -> trimMemberLo lo cmphi r
- EQ -> (True,trim (compare lo) cmphi r)
-
-
-{--------------------------------------------------------------------
- [filterGt x t] filter all values >[x] from tree [t]
- [filterLt x t] filter all values <[x] from tree [t]
---------------------------------------------------------------------}
-filterGt :: (a -> Ordering) -> Set a -> Set a
-filterGt cmp Tip = Tip
-filterGt cmp (Bin sx x l r)
- = case cmp x of
- LT -> join x (filterGt cmp l) r
- GT -> filterGt cmp r
- EQ -> r
-
-filterLt :: (a -> Ordering) -> Set a -> Set a
-filterLt cmp Tip = Tip
-filterLt cmp (Bin sx x l r)
- = case cmp x of
- LT -> filterLt cmp l
- GT -> join x l (filterLt cmp r)
- EQ -> l
-
-
-{--------------------------------------------------------------------
- Split
---------------------------------------------------------------------}
--- | /O(log n)/. The expression (@'split' x set@) is a pair @(set1,set2)@
--- where all elements in @set1@ are lower than @x@ and all elements in
--- @set2@ larger than @x@. @x@ is not found in neither @set1@ nor @set2@.
-split :: Ord a => a -> Set a -> (Set a,Set a)
-split x Tip = (Tip,Tip)
-split x (Bin sy y l r)
- = case compare x y of
- LT -> let (lt,gt) = split x l in (lt,join y gt r)
- GT -> let (lt,gt) = split x r in (join y l lt,gt)
- EQ -> (l,r)
-
--- | /O(log n)/. Performs a 'split' but also returns whether the pivot
--- element was found in the original set.
-splitMember :: Ord a => a -> Set a -> (Set a,Bool,Set a)
-splitMember x t = let (l,m,r) = splitLookup x t in
- (l,maybe False (const True) m,r)
-
--- | /O(log n)/. Performs a 'split' but also returns the pivot
--- element that was found in the original set.
-splitLookup :: Ord a => a -> Set a -> (Set a,Maybe a,Set a)
-splitLookup x Tip = (Tip,Nothing,Tip)
-splitLookup x (Bin sy y l r)
- = case compare x y of
- LT -> let (lt,found,gt) = splitLookup x l in (lt,found,join y gt r)
- GT -> let (lt,found,gt) = splitLookup x r in (join y l lt,found,gt)
- EQ -> (l,Just y,r)
-
-{--------------------------------------------------------------------
- Utility functions that maintain the balance properties of the tree.
- All constructors assume that all values in [l] < [x] and all values
- in [r] > [x], and that [l] and [r] are valid trees.
-
- In order of sophistication:
- [Bin sz x l r] The type constructor.
- [bin x l r] Maintains the correct size, assumes that both [l]
- and [r] are balanced with respect to each other.
- [balance x l r] Restores the balance and size.
- Assumes that the original tree was balanced and
- that [l] or [r] has changed by at most one element.
- [join x l r] Restores balance and size.
-
- Furthermore, we can construct a new tree from two trees. Both operations
- assume that all values in [l] < all values in [r] and that [l] and [r]
- are valid:
- [glue l r] Glues [l] and [r] together. Assumes that [l] and
- [r] are already balanced with respect to each other.
- [merge l r] Merges two trees and restores balance.
-
- Note: in contrast to Adam's paper, we use (<=) comparisons instead
- of (<) comparisons in [join], [merge] and [balance].
- Quickcheck (on [difference]) showed that this was necessary in order
- to maintain the invariants. It is quite unsatisfactory that I haven't
- been able to find out why this is actually the case! Fortunately, it
- doesn't hurt to be a bit more conservative.
---------------------------------------------------------------------}
-
-{--------------------------------------------------------------------
- Join
---------------------------------------------------------------------}
-join :: a -> Set a -> Set a -> Set a
-join x Tip r = insertMin x r
-join x l Tip = insertMax x l
-join x l@(Bin sizeL y ly ry) r@(Bin sizeR z lz rz)
- | delta*sizeL <= sizeR = balance z (join x l lz) rz
- | delta*sizeR <= sizeL = balance y ly (join x ry r)
- | otherwise = bin x l r
-
-
--- insertMin and insertMax don't perform potentially expensive comparisons.
-insertMax,insertMin :: a -> Set a -> Set a
-insertMax x t
- = case t of
- Tip -> singleton x
- Bin sz y l r
- -> balance y l (insertMax x r)
-
-insertMin x t
- = case t of
- Tip -> singleton x
- Bin sz y l r
- -> balance y (insertMin x l) r
-
-{--------------------------------------------------------------------
- [merge l r]: merges two trees.
---------------------------------------------------------------------}
-merge :: Set a -> Set a -> Set a
-merge Tip r = r
-merge l Tip = l
-merge l@(Bin sizeL x lx rx) r@(Bin sizeR y ly ry)
- | delta*sizeL <= sizeR = balance y (merge l ly) ry
- | delta*sizeR <= sizeL = balance x lx (merge rx r)
- | otherwise = glue l r
-
-{--------------------------------------------------------------------
- [glue l r]: glues two trees together.
- Assumes that [l] and [r] are already balanced with respect to each other.
---------------------------------------------------------------------}
-glue :: Set a -> Set a -> Set a
-glue Tip r = r
-glue l Tip = l
-glue l r
- | size l > size r = let (m,l') = deleteFindMax l in balance m l' r
- | otherwise = let (m,r') = deleteFindMin r in balance m l r'
-
-
--- | /O(log n)/. Delete and find the minimal element.
---
--- > deleteFindMin set = (findMin set, deleteMin set)
-
-deleteFindMin :: Set a -> (a,Set a)
-deleteFindMin t
- = case t of
- Bin _ x Tip r -> (x,r)
- Bin _ x l r -> let (xm,l') = deleteFindMin l in (xm,balance x l' r)
- Tip -> (error "Set.deleteFindMin: can not return the minimal element of an empty set", Tip)
-
--- | /O(log n)/. Delete and find the maximal element.
---
--- > deleteFindMax set = (findMax set, deleteMax set)
-deleteFindMax :: Set a -> (a,Set a)
-deleteFindMax t
- = case t of
- Bin _ x l Tip -> (x,l)
- Bin _ x l r -> let (xm,r') = deleteFindMax r in (xm,balance x l r')
- Tip -> (error "Set.deleteFindMax: can not return the maximal element of an empty set", Tip)
-
--- | /O(log n)/. Retrieves the minimal key of the set, and the set stripped from that element
--- @fail@s (in the monad) when passed an empty set.
-minView :: Monad m => Set a -> m (a, Set a)
-minView Tip = fail "Set.minView: empty set"
-minView x = return (deleteFindMin x)
-
--- | /O(log n)/. Retrieves the maximal key of the set, and the set stripped from that element
--- @fail@s (in the monad) when passed an empty set.
-maxView :: Monad m => Set a -> m (a, Set a)
-maxView Tip = fail "Set.maxView: empty set"
-maxView x = return (deleteFindMax x)
-
-
-{--------------------------------------------------------------------
- [balance x l r] balances two trees with value x.
- The sizes of the trees should balance after decreasing the
- size of one of them. (a rotation).
-
- [delta] is the maximal relative difference between the sizes of
- two trees, it corresponds with the [w] in Adams' paper,
- or equivalently, [1/delta] corresponds with the $\alpha$
- in Nievergelt's paper. Adams shows that [delta] should
- be larger than 3.745 in order to garantee that the
- rotations can always restore balance.
-
- [ratio] is the ratio between an outer and inner sibling of the
- heavier subtree in an unbalanced setting. It determines
- whether a double or single rotation should be performed
- to restore balance. It is correspondes with the inverse
- of $\alpha$ in Adam's article.
-
- Note that:
- - [delta] should be larger than 4.646 with a [ratio] of 2.
- - [delta] should be larger than 3.745 with a [ratio] of 1.534.
-
- - A lower [delta] leads to a more 'perfectly' balanced tree.
- - A higher [delta] performs less rebalancing.
-
- - Balancing is automatic for random data and a balancing
- scheme is only necessary to avoid pathological worst cases.
- Almost any choice will do in practice
-
- - Allthough it seems that a rather large [delta] may perform better
- than smaller one, measurements have shown that the smallest [delta]
- of 4 is actually the fastest on a wide range of operations. It
- especially improves performance on worst-case scenarios like
- a sequence of ordered insertions.
-
- Note: in contrast to Adams' paper, we use a ratio of (at least) 2
- to decide whether a single or double rotation is needed. Allthough
- he actually proves that this ratio is needed to maintain the
- invariants, his implementation uses a (invalid) ratio of 1.
- He is aware of the problem though since he has put a comment in his
- original source code that he doesn't care about generating a
- slightly inbalanced tree since it doesn't seem to matter in practice.
- However (since we use quickcheck :-) we will stick to strictly balanced
- trees.
---------------------------------------------------------------------}
-delta,ratio :: Int
-delta = 4
-ratio = 2
-
-balance :: a -> Set a -> Set a -> Set a
-balance x l r
- | sizeL + sizeR <= 1 = Bin sizeX x l r
- | sizeR >= delta*sizeL = rotateL x l r
- | sizeL >= delta*sizeR = rotateR x l r
- | otherwise = Bin sizeX x l r
- where
- sizeL = size l
- sizeR = size r
- sizeX = sizeL + sizeR + 1
-
--- rotate
-rotateL x l r@(Bin _ _ ly ry)
- | size ly < ratio*size ry = singleL x l r
- | otherwise = doubleL x l r
-
-rotateR x l@(Bin _ _ ly ry) r
- | size ry < ratio*size ly = singleR x l r
- | otherwise = doubleR x l r
-
--- basic rotations
-singleL x1 t1 (Bin _ x2 t2 t3) = bin x2 (bin x1 t1 t2) t3
-singleR x1 (Bin _ x2 t1 t2) t3 = bin x2 t1 (bin x1 t2 t3)
-
-doubleL x1 t1 (Bin _ x2 (Bin _ x3 t2 t3) t4) = bin x3 (bin x1 t1 t2) (bin x2 t3 t4)
-doubleR x1 (Bin _ x2 t1 (Bin _ x3 t2 t3)) t4 = bin x3 (bin x2 t1 t2) (bin x1 t3 t4)
-
-
-{--------------------------------------------------------------------
- The bin constructor maintains the size of the tree
---------------------------------------------------------------------}
-bin :: a -> Set a -> Set a -> Set a
-bin x l r
- = Bin (size l + size r + 1) x l r
-
-
-{--------------------------------------------------------------------
- Utilities
---------------------------------------------------------------------}
-foldlStrict f z xs
- = case xs of
- [] -> z
- (x:xx) -> let z' = f z x in seq z' (foldlStrict f z' xx)
-
-
-{--------------------------------------------------------------------
- Debugging
---------------------------------------------------------------------}
--- | /O(n)/. Show the tree that implements the set. The tree is shown
--- in a compressed, hanging format.
-showTree :: Show a => Set a -> String
-showTree s
- = showTreeWith True False s
-
-
-{- | /O(n)/. The expression (@showTreeWith hang wide map@) shows
- the tree that implements the set. If @hang@ is
- @True@, a /hanging/ tree is shown otherwise a rotated tree is shown. If
- @wide@ is 'True', an extra wide version is shown.
-
-> Set> putStrLn $ showTreeWith True False $ fromDistinctAscList [1..5]
-> 4
-> +--2
-> | +--1
-> | +--3
-> +--5
->
-> Set> putStrLn $ showTreeWith True True $ fromDistinctAscList [1..5]
-> 4
-> |
-> +--2
-> | |
-> | +--1
-> | |
-> | +--3
-> |
-> +--5
->
-> Set> putStrLn $ showTreeWith False True $ fromDistinctAscList [1..5]
-> +--5
-> |
-> 4
-> |
-> | +--3
-> | |
-> +--2
-> |
-> +--1
-
--}
-showTreeWith :: Show a => Bool -> Bool -> Set a -> String
-showTreeWith hang wide t
- | hang = (showsTreeHang wide [] t) ""
- | otherwise = (showsTree wide [] [] t) ""
-
-showsTree :: Show a => Bool -> [String] -> [String] -> Set a -> ShowS
-showsTree wide lbars rbars t
- = case t of
- Tip -> showsBars lbars . showString "|\n"
- Bin sz x Tip Tip
- -> showsBars lbars . shows x . showString "\n"
- Bin sz x l r
- -> showsTree wide (withBar rbars) (withEmpty rbars) r .
- showWide wide rbars .
- showsBars lbars . shows x . showString "\n" .
- showWide wide lbars .
- showsTree wide (withEmpty lbars) (withBar lbars) l
-
-showsTreeHang :: Show a => Bool -> [String] -> Set a -> ShowS
-showsTreeHang wide bars t
- = case t of
- Tip -> showsBars bars . showString "|\n"
- Bin sz x Tip Tip
- -> showsBars bars . shows x . showString "\n"
- Bin sz x l r
- -> showsBars bars . shows x . showString "\n" .
- showWide wide bars .
- showsTreeHang wide (withBar bars) l .
- showWide wide bars .
- showsTreeHang wide (withEmpty bars) r
-
-
-showWide wide bars
- | wide = showString (concat (reverse bars)) . showString "|\n"
- | otherwise = id
-
-showsBars :: [String] -> ShowS
-showsBars bars
- = case bars of
- [] -> id
- _ -> showString (concat (reverse (tail bars))) . showString node
-
-node = "+--"
-withBar bars = "| ":bars
-withEmpty bars = " ":bars
-
-{--------------------------------------------------------------------
- Assertions
---------------------------------------------------------------------}
--- | /O(n)/. Test if the internal set structure is valid.
-valid :: Ord a => Set a -> Bool
-valid t
- = balanced t && ordered t && validsize t
-
-ordered t
- = bounded (const True) (const True) t
- where
- bounded lo hi t
- = case t of
- Tip -> True
- Bin sz x l r -> (lo x) && (hi x) && bounded lo (<x) l && bounded (>x) hi r
-
-balanced :: Set a -> Bool
-balanced t
- = case t of
- Tip -> True
- Bin sz x l r -> (size l + size r <= 1 || (size l <= delta*size r && size r <= delta*size l)) &&
- balanced l && balanced r
-
-
-validsize t
- = (realsize t == Just (size t))
- where
- realsize t
- = case t of
- Tip -> Just 0
- Bin sz x l r -> case (realsize l,realsize r) of
- (Just n,Just m) | n+m+1 == sz -> Just sz
- other -> Nothing
-
-{-
-{--------------------------------------------------------------------
- Testing
---------------------------------------------------------------------}
-testTree :: [Int] -> Set Int
-testTree xs = fromList xs
-test1 = testTree [1..20]
-test2 = testTree [30,29..10]
-test3 = testTree [1,4,6,89,2323,53,43,234,5,79,12,9,24,9,8,423,8,42,4,8,9,3]
-
-{--------------------------------------------------------------------
- QuickCheck
---------------------------------------------------------------------}
-qcheck prop
- = check config prop
- where
- config = Config
- { configMaxTest = 500
- , configMaxFail = 5000
- , configSize = \n -> (div n 2 + 3)
- , configEvery = \n args -> let s = show n in s ++ [ '\b' | _ <- s ]
- }
-
-
-{--------------------------------------------------------------------
- Arbitrary, reasonably balanced trees
---------------------------------------------------------------------}
-instance (Enum a) => Arbitrary (Set a) where
- arbitrary = sized (arbtree 0 maxkey)
- where maxkey = 10000
-
-arbtree :: (Enum a) => Int -> Int -> Int -> Gen (Set a)
-arbtree lo hi n
- | n <= 0 = return Tip
- | lo >= hi = return Tip
- | otherwise = do{ i <- choose (lo,hi)
- ; m <- choose (1,30)
- ; let (ml,mr) | m==(1::Int)= (1,2)
- | m==2 = (2,1)
- | m==3 = (1,1)
- | otherwise = (2,2)
- ; l <- arbtree lo (i-1) (n `div` ml)
- ; r <- arbtree (i+1) hi (n `div` mr)
- ; return (bin (toEnum i) l r)
- }
-
-
-{--------------------------------------------------------------------
- Valid tree's
---------------------------------------------------------------------}
-forValid :: (Enum a,Show a,Testable b) => (Set a -> b) -> Property
-forValid f
- = forAll arbitrary $ \t ->
--- classify (balanced t) "balanced" $
- classify (size t == 0) "empty" $
- classify (size t > 0 && size t <= 10) "small" $
- classify (size t > 10 && size t <= 64) "medium" $
- classify (size t > 64) "large" $
- balanced t ==> f t
-
-forValidIntTree :: Testable a => (Set Int -> a) -> Property
-forValidIntTree f
- = forValid f
-
-forValidUnitTree :: Testable a => (Set Int -> a) -> Property
-forValidUnitTree f
- = forValid f
-
-
-prop_Valid
- = forValidUnitTree $ \t -> valid t
-
-{--------------------------------------------------------------------
- Single, Insert, Delete
---------------------------------------------------------------------}
-prop_Single :: Int -> Bool
-prop_Single x
- = (insert x empty == singleton x)
-
-prop_InsertValid :: Int -> Property
-prop_InsertValid k
- = forValidUnitTree $ \t -> valid (insert k t)
-
-prop_InsertDelete :: Int -> Set Int -> Property
-prop_InsertDelete k t
- = not (member k t) ==> delete k (insert k t) == t
-
-prop_DeleteValid :: Int -> Property
-prop_DeleteValid k
- = forValidUnitTree $ \t ->
- valid (delete k (insert k t))
-
-{--------------------------------------------------------------------
- Balance
---------------------------------------------------------------------}
-prop_Join :: Int -> Property
-prop_Join x
- = forValidUnitTree $ \t ->
- let (l,r) = split x t
- in valid (join x l r)
-
-prop_Merge :: Int -> Property
-prop_Merge x
- = forValidUnitTree $ \t ->
- let (l,r) = split x t
- in valid (merge l r)
-
-
-{--------------------------------------------------------------------
- Union
---------------------------------------------------------------------}
-prop_UnionValid :: Property
-prop_UnionValid
- = forValidUnitTree $ \t1 ->
- forValidUnitTree $ \t2 ->
- valid (union t1 t2)
-
-prop_UnionInsert :: Int -> Set Int -> Bool
-prop_UnionInsert x t
- = union t (singleton x) == insert x t
-
-prop_UnionAssoc :: Set Int -> Set Int -> Set Int -> Bool
-prop_UnionAssoc t1 t2 t3
- = union t1 (union t2 t3) == union (union t1 t2) t3
-
-prop_UnionComm :: Set Int -> Set Int -> Bool
-prop_UnionComm t1 t2
- = (union t1 t2 == union t2 t1)
-
-
-prop_DiffValid
- = forValidUnitTree $ \t1 ->
- forValidUnitTree $ \t2 ->
- valid (difference t1 t2)
-
-prop_Diff :: [Int] -> [Int] -> Bool
-prop_Diff xs ys
- = toAscList (difference (fromList xs) (fromList ys))
- == List.sort ((List.\\) (nub xs) (nub ys))
-
-prop_IntValid
- = forValidUnitTree $ \t1 ->
- forValidUnitTree $ \t2 ->
- valid (intersection t1 t2)
-
-prop_Int :: [Int] -> [Int] -> Bool
-prop_Int xs ys
- = toAscList (intersection (fromList xs) (fromList ys))
- == List.sort (nub ((List.intersect) (xs) (ys)))
-
-{--------------------------------------------------------------------
- Lists
---------------------------------------------------------------------}
-prop_Ordered
- = forAll (choose (5,100)) $ \n ->
- let xs = [0..n::Int]
- in fromAscList xs == fromList xs
-
-prop_List :: [Int] -> Bool
-prop_List xs
- = (sort (nub xs) == toList (fromList xs))
--}
+++ /dev/null
------------------------------------------------------------------------------
--- |
--- 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
--- <http://www.soi.city.ac.uk/~ross/papers/Applicative.html>.
---
--- * /The Essence of the Iterator Pattern/,
--- by Jeremy Gibbons and Bruno Oliveira,
--- in /Mathematically-Structured Functional Programming/, 2006, and online at
--- <http://web.comlab.ox.ac.uk/oucl/work/jeremy.gibbons/publications/#iterator>.
---
--- 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)
+++ /dev/null
------------------------------------------------------------------------------
--- |
--- 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"
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,
Data.STRef,
Data.STRef.Lazy,
Data.STRef.Strict,
- Data.Sequence,
- Data.Set,
Data.String,
- Data.Tree,
- Data.Traversable,
Data.Tuple,
Data.Typeable,
Data.Unique,
projects / ghc-base.git / commitdiff