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