├── tests-ghc ├── datamap002.stdout ├── dataintset001.stdout ├── datamap001.stdout ├── sequence001.stdout ├── sequence001.hs ├── dataintset001.hs ├── datamap002.hs ├── Makefile ├── datamap001.hs └── all.T ├── prologue.txt ├── Setup.hs ├── .gitignore ├── Data ├── StrictPair.hs ├── IntMap.hs ├── Map.hs ├── Tree.hs ├── Map │ └── Lazy.hs ├── IntMap │ ├── Lazy.hs │ └── Strict.hs └── Graph.hs ├── benchmarks ├── Makefile ├── Sequence.hs ├── IntSet.hs ├── Set.hs ├── IntMap.hs └── Map.hs ├── include └── Typeable.h ├── LICENSE ├── containers.cabal └── tests ├── intset-properties.hs ├── set-properties.hs ├── seq-properties.hs └── intmap-properties.hs /tests-ghc/datamap002.stdout: -------------------------------------------------------------------------------- 1 | True 2 | -------------------------------------------------------------------------------- /tests-ghc/dataintset001.stdout: -------------------------------------------------------------------------------- 1 | True 2 | -------------------------------------------------------------------------------- /tests-ghc/datamap001.stdout: -------------------------------------------------------------------------------- 1 | fromList [(3,"b"),(5,"x")] 2 | -------------------------------------------------------------------------------- /tests-ghc/sequence001.stdout: -------------------------------------------------------------------------------- 1 | fromList [3,4,5] 2 | fromList [1,2,3] 3 | -------------------------------------------------------------------------------- /prologue.txt: -------------------------------------------------------------------------------- 1 | This package contains basic container classes and containers. 2 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | module Main (main) where 2 | 3 | import Distribution.Simple 4 | 5 | main :: IO () 6 | main = defaultMain 7 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | *.hi 2 | *.o 3 | *.p_hi 4 | *.prof 5 | *.tix 6 | .hpc/ 7 | /dist/* 8 | GNUmakefile 9 | dist-install 10 | ghc.mk 11 | -------------------------------------------------------------------------------- /tests-ghc/sequence001.hs: -------------------------------------------------------------------------------- 1 | 2 | module Main where 3 | 4 | import Data.Sequence 5 | 6 | main :: IO () 7 | main = do print $ dropWhileL (< 3) $ fromList [1..5] 8 | print $ dropWhileR (> 3) $ fromList [1..5] 9 | 10 | -------------------------------------------------------------------------------- /Data/StrictPair.hs: -------------------------------------------------------------------------------- 1 | module Data.StrictPair (strictPair) where 2 | 3 | -- | Evaluate both argument to WHNF and create a pair of the result. 4 | strictPair :: a -> b -> (a, b) 5 | strictPair x y = x `seq` y `seq` (x, y) 6 | {-# INLINE strictPair #-} 7 | -------------------------------------------------------------------------------- /tests-ghc/dataintset001.hs: -------------------------------------------------------------------------------- 1 | 2 | {- 3 | Through 6.8.1 this printed False, should be True. 4 | -} 5 | 6 | module Main (main) where 7 | 8 | import Data.IntSet 9 | 10 | main :: IO () 11 | main = print $ isProperSubsetOf (fromList [2,3]) $ fromList [2,3,4] 12 | -------------------------------------------------------------------------------- /tests-ghc/datamap002.hs: -------------------------------------------------------------------------------- 1 | 2 | -- In 6.12 this failed 3 | 4 | module Main (main) where 5 | 6 | import Data.Map 7 | 8 | main :: IO () 9 | main = print $ valid $ deleteMin $ deleteMin 10 | $ fromList [ (i, ()) | i <- [0,2,5,1,6,4,8,9,7,11,10,3] ] 11 | 12 | -------------------------------------------------------------------------------- /tests-ghc/Makefile: -------------------------------------------------------------------------------- 1 | # This Makefile runs the tests using GHC's testsuite framework. It 2 | # assumes the package is part of a GHC build tree with the testsuite 3 | # installed in ../../../testsuite. 4 | 5 | TOP=../../../testsuite 6 | include $(TOP)/mk/boilerplate.mk 7 | include $(TOP)/mk/test.mk 8 | -------------------------------------------------------------------------------- /tests-ghc/datamap001.hs: -------------------------------------------------------------------------------- 1 | 2 | {- 3 | In the 6.6 era this printed [(5,"x")]; should be [(3,"b"),(5,"a")] 4 | -} 5 | 6 | module Main (main) where 7 | 8 | import Data.Map 9 | 10 | main :: IO () 11 | main = do let m = fromList [(3,"b"),(5,"a")] 12 | f k a = Just "x" 13 | m' = updateAt f 1 m 14 | print m' 15 | -------------------------------------------------------------------------------- /tests-ghc/all.T: -------------------------------------------------------------------------------- 1 | # This is a test script for use with GHC's testsuite framework, see 2 | # http://darcs.haskell.org/testsuite 3 | 4 | test('datamap001', normal, compile_and_run, ['-package containers']) 5 | test('datamap002', normal, compile_and_run, ['-package containers']) 6 | test('dataintset001', normal, compile_and_run, ['-package containers']) 7 | test('sequence001', normal, compile_and_run, ['-package containers']) 8 | -------------------------------------------------------------------------------- /benchmarks/Makefile: -------------------------------------------------------------------------------- 1 | package := containers 2 | version := $(shell awk '/^version:/{print $$2}' ../$(package).cabal) 3 | lib := ../dist/build/libHS$(package)-$(version).a 4 | 5 | programs := bench-Map bench-Set bench-IntMap bench-IntSet bench-Sequence 6 | all: $(programs) 7 | run: $(patsubst %, %.csv, $(programs)) 8 | 9 | bench-%: %.hs ../Data/%.hs 10 | ghc -DTESTING -cpp -O2 -fregs-graph -rtsopts --make -fforce-recomp -i.. -o $@ $< 11 | 12 | bench-%.csv: bench-% 13 | ./bench-$* -u bench-$*.csv +RTS -K10M 14 | 15 | .PHONY: clean 16 | clean: 17 | -find . \( -name '*.o' -o -name '*.hi' \) -exec rm {} \; 18 | -rm -f $(programs) 19 | -------------------------------------------------------------------------------- /benchmarks/Sequence.hs: -------------------------------------------------------------------------------- 1 | -- > ghc -DTESTING --make -O2 -fforce-recomp -i.. Sequence.hs 2 | module Main where 3 | 4 | import Control.DeepSeq 5 | import Criterion.Main 6 | import Data.List (foldl') 7 | import qualified Data.Sequence as S 8 | import qualified Data.Foldable 9 | import System.Random 10 | 11 | main = do 12 | let s10 = S.fromList [1..10] :: S.Seq Int 13 | s100 = S.fromList [1..100] :: S.Seq Int 14 | s1000 = S.fromList [1..1000] :: S.Seq Int 15 | rnf [s10, s100, s1000] `seq` return () 16 | let g = mkStdGen 1 17 | let rlist n = map (`mod` (n+1)) (take 10000 (randoms g)) :: [Int] 18 | r10 = rlist 10 19 | r100 = rlist 100 20 | r1000 = rlist 1000 21 | rnf [r10, r100, r1000] `seq` return () 22 | defaultMain 23 | [ bench "splitAt/append 10" $ nf (shuffle r10) s10 24 | , bench "splitAt/append 100" $ nf (shuffle r100) s100 25 | , bench "splitAt/append 1000" $ nf (shuffle r1000) s1000 26 | ] 27 | 28 | -- splitAt+append: repeatedly cut the sequence at a random point 29 | -- and rejoin the pieces in the opposite order. 30 | -- Finally getting the middle element forces the whole spine. 31 | shuffle :: [Int] -> S.Seq Int -> Int 32 | shuffle ps s = case S.viewl (S.drop (S.length s `div` 2) (foldl' cut s ps)) of 33 | x S.:< _ -> x 34 | where cut xs p = let (front, back) = S.splitAt p xs in back S.>< front 35 | -------------------------------------------------------------------------------- /benchmarks/IntSet.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | 3 | module Main where 4 | 5 | import Control.DeepSeq 6 | import Control.Exception (evaluate) 7 | import Control.Monad.Trans (liftIO) 8 | import Criterion.Config 9 | import Criterion.Main 10 | import Data.List (foldl') 11 | import qualified Data.IntSet as S 12 | 13 | main = do 14 | let s = S.fromAscList elems :: S.IntSet 15 | s_even = S.fromAscList elems_even :: S.IntSet 16 | s_odd = S.fromAscList elems_odd :: S.IntSet 17 | defaultMainWith 18 | defaultConfig 19 | (liftIO . evaluate $ rnf [s, s_even, s_odd]) 20 | [ bench "member" $ nf (member elems) s 21 | , bench "insert" $ nf (ins elems) S.empty 22 | , bench "map" $ nf (S.map (+ 1)) s 23 | , bench "filter" $ nf (S.filter ((== 0) . (`mod` 2))) s 24 | , bench "partition" $ nf (S.partition ((== 0) . (`mod` 2))) s 25 | , bench "fold" $ nf (S.fold (:) []) s 26 | , bench "delete" $ nf (del elems) s 27 | , bench "findMin" $ nf S.findMin s 28 | , bench "findMax" $ nf S.findMax s 29 | , bench "deleteMin" $ nf S.deleteMin s 30 | , bench "deleteMax" $ nf S.deleteMax s 31 | , bench "unions" $ nf S.unions [s_even, s_odd] 32 | , bench "union" $ nf (S.union s_even) s_odd 33 | , bench "difference" $ nf (S.difference s) s_even 34 | , bench "intersection" $ nf (S.intersection s) s_even 35 | ] 36 | where 37 | elems = [1..2^10] 38 | elems_even = [2,4..2^10] 39 | elems_odd = [1,3..2^10] 40 | 41 | member :: [Int] -> S.IntSet -> Int 42 | member xs s = foldl' (\n x -> if S.member x s then n + 1 else n) 0 xs 43 | 44 | ins :: [Int] -> S.IntSet -> S.IntSet 45 | ins xs s0 = foldl' (\s a -> S.insert a s) s0 xs 46 | 47 | del :: [Int] -> S.IntSet -> S.IntSet 48 | del xs s0 = foldl' (\s k -> S.delete k s) s0 xs 49 | -------------------------------------------------------------------------------- /benchmarks/Set.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | 3 | -- > ghc -DTESTING --make -O2 -fforce-recomp -i.. Set.hs 4 | module Main where 5 | 6 | import Control.DeepSeq 7 | import Control.Exception (evaluate) 8 | import Control.Monad.Trans (liftIO) 9 | import Criterion.Config 10 | import Criterion.Main 11 | import Data.List (foldl') 12 | import qualified Data.Set as S 13 | 14 | main = do 15 | let s = S.fromAscList elems :: S.Set Int 16 | s_even = S.fromAscList elems_even :: S.Set Int 17 | s_odd = S.fromAscList elems_odd :: S.Set Int 18 | defaultMainWith 19 | defaultConfig 20 | (liftIO . evaluate $ rnf [s, s_even, s_odd]) 21 | [ bench "member" $ nf (member elems) s 22 | , bench "insert" $ nf (ins elems) S.empty 23 | , bench "map" $ nf (S.map (+ 1)) s 24 | , bench "filter" $ nf (S.filter ((== 0) . (`mod` 2))) s 25 | , bench "partition" $ nf (S.partition ((== 0) . (`mod` 2))) s 26 | , bench "fold" $ nf (S.fold (:) []) s 27 | , bench "delete" $ nf (del elems) s 28 | , bench "findMin" $ nf S.findMin s 29 | , bench "findMax" $ nf S.findMax s 30 | , bench "deleteMin" $ nf S.deleteMin s 31 | , bench "deleteMax" $ nf S.deleteMax s 32 | , bench "unions" $ nf S.unions [s_even, s_odd] 33 | , bench "union" $ nf (S.union s_even) s_odd 34 | , bench "difference" $ nf (S.difference s) s_even 35 | , bench "intersection" $ nf (S.intersection s) s_even 36 | ] 37 | where 38 | elems = [1..2^10] 39 | elems_even = [2,4..2^10] 40 | elems_odd = [1,3..2^10] 41 | 42 | member :: [Int] -> S.Set Int -> Int 43 | member xs s = foldl' (\n x -> if S.member x s then n + 1 else n) 0 xs 44 | 45 | ins :: [Int] -> S.Set Int -> S.Set Int 46 | ins xs s0 = foldl' (\s a -> S.insert a s) s0 xs 47 | 48 | del :: [Int] -> S.Set Int -> S.Set Int 49 | del xs s0 = foldl' (\s k -> S.delete k s) s0 xs 50 | -------------------------------------------------------------------------------- /include/Typeable.h: -------------------------------------------------------------------------------- 1 | {- -------------------------------------------------------------------------- 2 | // Macros to help make Typeable instances. 3 | // 4 | // INSTANCE_TYPEABLEn(tc,tcname,"tc") defines 5 | // 6 | // instance Typeable/n/ tc 7 | // instance Typeable a => Typeable/n-1/ (tc a) 8 | // instance (Typeable a, Typeable b) => Typeable/n-2/ (tc a b) 9 | // ... 10 | // instance (Typeable a1, ..., Typeable an) => Typeable (tc a1 ... an) 11 | // -------------------------------------------------------------------------- 12 | -} 13 | 14 | #ifndef TYPEABLE_H 15 | #define TYPEABLE_H 16 | 17 | #ifdef __GLASGOW_HASKELL__ 18 | 19 | -- // For GHC, we can use DeriveDataTypeable + StandaloneDeriving to 20 | -- // generate the instances. 21 | 22 | #define INSTANCE_TYPEABLE0(tycon,tcname,str) deriving instance Typeable tycon 23 | #define INSTANCE_TYPEABLE1(tycon,tcname,str) deriving instance Typeable1 tycon 24 | #define INSTANCE_TYPEABLE2(tycon,tcname,str) deriving instance Typeable2 tycon 25 | #define INSTANCE_TYPEABLE3(tycon,tcname,str) deriving instance Typeable3 tycon 26 | 27 | #else /* !__GLASGOW_HASKELL__ */ 28 | 29 | #define INSTANCE_TYPEABLE0(tycon,tcname,str) \ 30 | tcname :: TyCon; \ 31 | tcname = mkTyCon str; \ 32 | instance Typeable tycon where { typeOf _ = mkTyConApp tcname [] } 33 | 34 | #define INSTANCE_TYPEABLE1(tycon,tcname,str) \ 35 | tcname = mkTyCon str; \ 36 | instance Typeable1 tycon where { typeOf1 _ = mkTyConApp tcname [] }; \ 37 | instance Typeable a => Typeable (tycon a) where { typeOf = typeOfDefault } 38 | 39 | #define INSTANCE_TYPEABLE2(tycon,tcname,str) \ 40 | tcname = mkTyCon str; \ 41 | instance Typeable2 tycon where { typeOf2 _ = mkTyConApp tcname [] }; \ 42 | instance Typeable a => Typeable1 (tycon a) where { \ 43 | typeOf1 = typeOf1Default }; \ 44 | instance (Typeable a, Typeable b) => Typeable (tycon a b) where { \ 45 | typeOf = typeOfDefault } 46 | 47 | #define INSTANCE_TYPEABLE3(tycon,tcname,str) \ 48 | tcname = mkTyCon str; \ 49 | instance Typeable3 tycon where { typeOf3 _ = mkTyConApp tcname [] }; \ 50 | instance Typeable a => Typeable2 (tycon a) where { \ 51 | typeOf2 = typeOf2Default }; \ 52 | instance (Typeable a, Typeable b) => Typeable1 (tycon a b) where { \ 53 | typeOf1 = typeOf1Default }; \ 54 | instance (Typeable a, Typeable b, Typeable c) => Typeable (tycon a b c) where { \ 55 | typeOf = typeOfDefault } 56 | 57 | #endif /* !__GLASGOW_HASKELL__ */ 58 | 59 | #endif 60 | -------------------------------------------------------------------------------- /Data/IntMap.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | #if !defined(TESTING) && __GLASGOW_HASKELL__ >= 703 3 | {-# LANGUAGE Trustworthy #-} 4 | #endif 5 | ----------------------------------------------------------------------------- 6 | -- | 7 | -- Module : Data.IntMap 8 | -- Copyright : (c) Daan Leijen 2002 9 | -- (c) Andriy Palamarchuk 2008 10 | -- License : BSD-style 11 | -- Maintainer : libraries@haskell.org 12 | -- Stability : provisional 13 | -- Portability : portable 14 | -- 15 | -- An efficient implementation of maps from integer keys to values 16 | -- (dictionaries). 17 | -- 18 | -- This module re-exports the value lazy 'Data.IntMap.Lazy' API, plus 19 | -- several value strict functions from 'Data.IntMap.Strict'. 20 | -- 21 | -- These modules are intended to be imported qualified, to avoid name 22 | -- clashes with Prelude functions, e.g. 23 | -- 24 | -- > import Data.IntMap (IntMap) 25 | -- > import qualified Data.IntMap as IntMap 26 | -- 27 | -- The implementation is based on /big-endian patricia trees/. This data 28 | -- structure performs especially well on binary operations like 'union' 29 | -- and 'intersection'. However, my benchmarks show that it is also 30 | -- (much) faster on insertions and deletions when compared to a generic 31 | -- size-balanced map implementation (see "Data.Map"). 32 | -- 33 | -- * Chris Okasaki and Andy Gill, \"/Fast Mergeable Integer Maps/\", 34 | -- Workshop on ML, September 1998, pages 77-86, 35 | -- 36 | -- 37 | -- * D.R. Morrison, \"/PATRICIA -- Practical Algorithm To Retrieve 38 | -- Information Coded In Alphanumeric/\", Journal of the ACM, 15(4), 39 | -- October 1968, pages 514-534. 40 | -- 41 | -- Operation comments contain the operation time complexity in 42 | -- the Big-O notation . 43 | -- Many operations have a worst-case complexity of /O(min(n,W))/. 44 | -- This means that the operation can become linear in the number of 45 | -- elements with a maximum of /W/ -- the number of bits in an 'Int' 46 | -- (32 or 64). 47 | ----------------------------------------------------------------------------- 48 | 49 | module Data.IntMap 50 | ( module Data.IntMap.Lazy 51 | , insertWith' 52 | , insertWithKey' 53 | , fold 54 | , foldWithKey 55 | ) where 56 | 57 | import Prelude hiding (lookup,map,filter,foldr,foldl,null) 58 | import Data.IntMap.Lazy 59 | import qualified Data.IntMap.Strict as S 60 | 61 | -- | /Deprecated./ As of version 0.5, replaced by 'S.insertWith'. 62 | -- 63 | -- /O(log n)/. Same as 'insertWith', but the combining function is 64 | -- applied strictly. This function is deprecated, use 'insertWith' in 65 | -- "Data.IntMap.Strict" instead. 66 | insertWith' :: (a -> a -> a) -> Key -> a -> IntMap a -> IntMap a 67 | insertWith' = S.insertWith 68 | {-# INLINE insertWith' #-} 69 | 70 | -- | /Deprecated./ As of version 0.5, replaced by 'S.insertWithKey'. 71 | -- 72 | -- /O(log n)/. Same as 'insertWithKey', but the combining function is 73 | -- applied strictly. This function is deprecated, use 'insertWithKey' 74 | -- in "Data.IntMap.Strict" instead. 75 | insertWithKey' :: (Key -> a -> a -> a) -> Key -> a -> IntMap a -> IntMap a 76 | insertWithKey' = S.insertWithKey 77 | {-# INLINE insertWithKey' #-} 78 | 79 | -- | /Deprecated./ As of version 0.5, replaced by 'foldr'. 80 | -- 81 | -- /O(n)/. Fold the values in the map using the given 82 | -- right-associative binary operator. This function is an equivalent 83 | -- of 'foldr' and is present for compatibility only. 84 | fold :: (a -> b -> b) -> b -> IntMap a -> b 85 | fold = foldr 86 | {-# INLINE fold #-} 87 | 88 | -- | /Deprecated./ As of version 0.5, replaced by 'foldrWithKey'. 89 | -- 90 | -- /O(n)/. Fold the keys and values in the map using the given 91 | -- right-associative binary operator. This function is an equivalent 92 | -- of 'foldrWithKey' and is present for compatibility only. 93 | foldWithKey :: (Int -> a -> b -> b) -> b -> IntMap a -> b 94 | foldWithKey = foldrWithKey 95 | {-# INLINE foldWithKey #-} 96 | -------------------------------------------------------------------------------- /Data/Map.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | #if !defined(TESTING) && __GLASGOW_HASKELL__ >= 703 3 | {-# LANGUAGE Safe #-} 4 | #endif 5 | ----------------------------------------------------------------------------- 6 | -- | 7 | -- Module : Data.Map 8 | -- Copyright : (c) Daan Leijen 2002 9 | -- (c) Andriy Palamarchuk 2008 10 | -- License : BSD-style 11 | -- Maintainer : libraries@haskell.org 12 | -- Stability : provisional 13 | -- Portability : portable 14 | -- 15 | -- An efficient implementation of ordered maps from keys to values 16 | -- (dictionaries). 17 | -- 18 | -- This module re-exports the value lazy 'Data.Map.Lazy' API, plus 19 | -- several value strict functions from 'Data.Map.Strict'. 20 | -- 21 | -- These modules are intended to be imported qualified, to avoid name 22 | -- clashes with Prelude functions, e.g. 23 | -- 24 | -- > import qualified Data.Map as Map 25 | -- 26 | -- The implementation of 'Map' is based on /size balanced/ binary trees (or 27 | -- trees of /bounded balance/) as described by: 28 | -- 29 | -- * Stephen Adams, \"/Efficient sets: a balancing act/\", 30 | -- Journal of Functional Programming 3(4):553-562, October 1993, 31 | -- . 32 | -- 33 | -- * J. Nievergelt and E.M. Reingold, 34 | -- \"/Binary search trees of bounded balance/\", 35 | -- SIAM journal of computing 2(1), March 1973. 36 | -- 37 | -- Note that the implementation is /left-biased/ -- the elements of a 38 | -- first argument are always preferred to the second, for example in 39 | -- 'union' or 'insert'. 40 | -- 41 | -- Operation comments contain the operation time complexity in 42 | -- the Big-O notation (). 43 | ----------------------------------------------------------------------------- 44 | 45 | module Data.Map 46 | ( module Data.Map.Lazy 47 | , insertWith' 48 | , insertWithKey' 49 | , insertLookupWithKey' 50 | , fold 51 | , foldWithKey 52 | ) where 53 | 54 | import Data.Map.Lazy 55 | import qualified Data.Map.Lazy as L 56 | import qualified Data.Map.Strict as S 57 | 58 | -- | /Deprecated./ As of version 0.5, replaced by 'S.insertWith'. 59 | -- 60 | -- /O(log n)/. Same as 'insertWith', but the combining function is 61 | -- applied strictly. This is often the most desirable behavior. 62 | -- 63 | -- For example, to update a counter: 64 | -- 65 | -- > insertWith' (+) k 1 m 66 | -- 67 | insertWith' :: Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a 68 | insertWith' = S.insertWith 69 | {-# INLINE insertWith' #-} 70 | 71 | -- | /Deprecated./ As of version 0.5, replaced by 'S.insertWithKey'. 72 | -- 73 | -- /O(log n)/. Same as 'insertWithKey', but the combining function is 74 | -- applied strictly. 75 | insertWithKey' :: Ord k => (k -> a -> a -> a) -> k -> a -> Map k a -> Map k a 76 | insertWithKey' = S.insertWithKey 77 | {-# INLINE insertWithKey' #-} 78 | 79 | -- | /Deprecated./ As of version 0.5, replaced by 80 | -- 'S.insertLookupWithKey'. 81 | -- 82 | -- /O(log n)/. A strict version of 'insertLookupWithKey'. 83 | insertLookupWithKey' :: Ord k => (k -> a -> a -> a) -> k -> a -> Map k a 84 | -> (Maybe a, Map k a) 85 | insertLookupWithKey' = S.insertLookupWithKey 86 | {-# INLINE insertLookupWithKey' #-} 87 | 88 | -- | /Deprecated./ As of version 0.5, replaced by 'L.foldr'. 89 | -- 90 | -- /O(n)/. Fold the values in the map using the given right-associative 91 | -- binary operator. This function is an equivalent of 'foldr' and is present 92 | -- for compatibility only. 93 | fold :: (a -> b -> b) -> b -> Map k a -> b 94 | fold = L.foldr 95 | {-# INLINE fold #-} 96 | 97 | -- | /Deprecated./ As of version 0.4, replaced by 'L.foldrWithKey'. 98 | -- 99 | -- /O(n)/. Fold the keys and values in the map using the given right-associative 100 | -- binary operator. This function is an equivalent of 'foldrWithKey' and is present 101 | -- for compatibility only. 102 | foldWithKey :: (k -> a -> b -> b) -> b -> Map k a -> b 103 | foldWithKey = foldrWithKey 104 | {-# INLINE foldWithKey #-} 105 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | This library (libraries/containers) is derived from code from several 2 | sources: 3 | 4 | * Code from the GHC project which is largely (c) The University of 5 | Glasgow, and distributable under a BSD-style license (see below), 6 | 7 | * Code from the Haskell 98 Report which is (c) Simon Peyton Jones 8 | and freely redistributable (but see the full license for 9 | restrictions). 10 | 11 | * Code from the Haskell Foreign Function Interface specification, 12 | which is (c) Manuel M. T. Chakravarty and freely redistributable 13 | (but see the full license for restrictions). 14 | 15 | The full text of these licenses is reproduced below. All of the 16 | licenses are BSD-style or compatible. 17 | 18 | ----------------------------------------------------------------------------- 19 | 20 | The Glasgow Haskell Compiler License 21 | 22 | Copyright 2004, The University Court of the University of Glasgow. 23 | All rights reserved. 24 | 25 | Redistribution and use in source and binary forms, with or without 26 | modification, are permitted provided that the following conditions are met: 27 | 28 | - Redistributions of source code must retain the above copyright notice, 29 | this list of conditions and the following disclaimer. 30 | 31 | - Redistributions in binary form must reproduce the above copyright notice, 32 | this list of conditions and the following disclaimer in the documentation 33 | and/or other materials provided with the distribution. 34 | 35 | - Neither name of the University nor the names of its contributors may be 36 | used to endorse or promote products derived from this software without 37 | specific prior written permission. 38 | 39 | THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF 40 | GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, 41 | INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND 42 | FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE 43 | UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE 44 | FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 45 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR 46 | SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 47 | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 48 | LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY 49 | OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH 50 | DAMAGE. 51 | 52 | ----------------------------------------------------------------------------- 53 | 54 | Code derived from the document "Report on the Programming Language 55 | Haskell 98", is distributed under the following license: 56 | 57 | Copyright (c) 2002 Simon Peyton Jones 58 | 59 | The authors intend this Report to belong to the entire Haskell 60 | community, and so we grant permission to copy and distribute it for 61 | any purpose, provided that it is reproduced in its entirety, 62 | including this Notice. Modified versions of this Report may also be 63 | copied and distributed for any purpose, provided that the modified 64 | version is clearly presented as such, and that it does not claim to 65 | be a definition of the Haskell 98 Language. 66 | 67 | ----------------------------------------------------------------------------- 68 | 69 | Code derived from the document "The Haskell 98 Foreign Function 70 | Interface, An Addendum to the Haskell 98 Report" is distributed under 71 | the following license: 72 | 73 | Copyright (c) 2002 Manuel M. T. Chakravarty 74 | 75 | The authors intend this Report to belong to the entire Haskell 76 | community, and so we grant permission to copy and distribute it for 77 | any purpose, provided that it is reproduced in its entirety, 78 | including this Notice. Modified versions of this Report may also be 79 | copied and distributed for any purpose, provided that the modified 80 | version is clearly presented as such, and that it does not claim to 81 | be a definition of the Haskell 98 Foreign Function Interface. 82 | 83 | ----------------------------------------------------------------------------- 84 | -------------------------------------------------------------------------------- /benchmarks/IntMap.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | module Main where 3 | 4 | import Control.DeepSeq 5 | import Control.Exception (evaluate) 6 | import Control.Monad.Trans (liftIO) 7 | import Criterion.Config 8 | import Criterion.Main 9 | import Data.List (foldl') 10 | import qualified Data.IntMap as M 11 | import Data.Maybe (fromMaybe) 12 | import Prelude hiding (lookup) 13 | 14 | main = do 15 | let m = M.fromAscList elems :: M.IntMap Int 16 | defaultMainWith 17 | defaultConfig 18 | (liftIO . evaluate $ rnf [m]) 19 | [ bench "lookup" $ nf (lookup keys) m 20 | , bench "insert" $ nf (ins elems) M.empty 21 | {- , bench "insertWith empty" $ nf (insWith elems) M.empty 22 | , bench "insertWith update" $ nf (insWith elems) m 23 | -- , bench "insertWith' empty" $ nf (insWith' elems) M.empty 24 | -- , bench "insertWith' update" $ nf (insWith' elems) m 25 | , bench "insertWithKey empty" $ nf (insWithKey elems) M.empty 26 | , bench "insertWithKey update" $ nf (insWithKey elems) m 27 | -- , bench "insertWithKey' empty" $ nf (insWithKey' elems) M.empty 28 | -- , bench "insertWithKey' update" $ nf (insWithKey' elems) m 29 | , bench "insertLookupWithKey empty" $ 30 | nf (insLookupWithKey elems) M.empty 31 | , bench "insertLookupWithKey update" $ 32 | nf (insLookupWithKey elems) m 33 | -- , bench "insertLookupWithKey' empty" $ 34 | -- nf (insLookupWithKey' elems) M.empty 35 | -- , bench "insertLookupWithKey' update" $ 36 | -- nf (insLookupWithKey' elems) m 37 | -} 38 | , bench "map" $ nf (M.map (+ 1)) m 39 | , bench "mapWithKey" $ nf (M.mapWithKey (+)) m 40 | , bench "foldlWithKey" $ nf (ins elems) m 41 | -- , bench "foldlWithKey'" $ nf (M.foldlWithKey' sum 0) m 42 | -- , bench "foldrWithKey" $ nf (M.foldrWithKey consPair []) m 43 | , bench "delete" $ nf (del keys) m 44 | , bench "update" $ nf (upd keys) m 45 | , bench "updateLookupWithKey" $ nf (upd' keys) m 46 | , bench "alter" $ nf (alt keys) m 47 | , bench "mapMaybe" $ nf (M.mapMaybe maybeDel) m 48 | -- , bench "mapMaybeWithKey" $ nf (M.mapMaybeWithKey (const maybeDel)) m 49 | ] 50 | where 51 | elems = zip keys values 52 | keys = [1..2^12] 53 | values = [1..2^12] 54 | sum k v1 v2 = k + v1 + v2 55 | consPair k v xs = (k, v) : xs 56 | 57 | add3 :: Int -> Int -> Int -> Int 58 | add3 x y z = x + y + z 59 | {-# INLINE add3 #-} 60 | 61 | lookup :: [Int] -> M.IntMap Int -> Int 62 | lookup xs m = foldl' (\n k -> fromMaybe n (M.lookup k m)) 0 xs 63 | 64 | -- lookupIndex :: [Int] -> M.IntMap Int -> Int 65 | -- lookupIndex xs m = foldl' (\n k -> fromMaybe n (M.lookupIndex k m)) 0 xs 66 | 67 | ins :: [(Int, Int)] -> M.IntMap Int -> M.IntMap Int 68 | ins xs m = foldl' (\m (k, v) -> M.insert k v m) m xs 69 | 70 | insWith :: [(Int, Int)] -> M.IntMap Int -> M.IntMap Int 71 | insWith xs m = foldl' (\m (k, v) -> M.insertWith (+) k v m) m xs 72 | 73 | insWithKey :: [(Int, Int)] -> M.IntMap Int -> M.IntMap Int 74 | insWithKey xs m = foldl' (\m (k, v) -> M.insertWithKey add3 k v m) m xs 75 | 76 | -- insWith' :: [(Int, Int)] -> M.IntMap Int -> M.IntMap Int 77 | -- insWith' xs m = foldl' (\m (k, v) -> M.insertWith' (+) k v m) m xs 78 | 79 | -- insWithKey' :: [(Int, Int)] -> M.IntMap Int -> M.IntMap Int 80 | -- insWithKey' xs m = foldl' (\m (k, v) -> M.insertWithKey' add3 k v m) m xs 81 | 82 | data PairS a b = PS !a !b 83 | 84 | insLookupWithKey :: [(Int, Int)] -> M.IntMap Int -> (Int, M.IntMap Int) 85 | insLookupWithKey xs m = let !(PS a b) = foldl' f (PS 0 m) xs in (a, b) 86 | where 87 | f (PS n m) (k, v) = let !(n', m') = M.insertLookupWithKey add3 k v m 88 | in PS (fromMaybe 0 n' + n) m' 89 | 90 | {- 91 | insLookupWithKey' :: [(Int, Int)] -> M.Map Int Int -> (Int, M.Map Int Int) 92 | insLookupWithKey' xs m = let !(PS a b) = foldl' f (PS 0 m) xs in (a, b) 93 | where 94 | f (PS n m) (k, v) = let !(n', m') = M.insertLookupWithKey' add3 k v m 95 | in PS (fromMaybe 0 n' + n) m' 96 | -} 97 | 98 | del :: [Int] -> M.IntMap Int -> M.IntMap Int 99 | del xs m = foldl' (\m k -> M.delete k m) m xs 100 | 101 | upd :: [Int] -> M.IntMap Int -> M.IntMap Int 102 | upd xs m = foldl' (\m k -> M.update Just k m) m xs 103 | 104 | upd' :: [Int] -> M.IntMap Int -> M.IntMap Int 105 | upd' xs m = foldl' (\m k -> snd $ M.updateLookupWithKey (\_ a -> Just a) k m) m xs 106 | 107 | alt :: [Int] -> M.IntMap Int -> M.IntMap Int 108 | alt xs m = foldl' (\m k -> M.alter id k m) m xs 109 | 110 | maybeDel :: Int -> Maybe Int 111 | maybeDel n | n `mod` 3 == 0 = Nothing 112 | | otherwise = Just n 113 | -------------------------------------------------------------------------------- /containers.cabal: -------------------------------------------------------------------------------- 1 | name: containers 2 | version: 0.5.0.0 3 | license: BSD3 4 | license-file: LICENSE 5 | maintainer: fox@ucw.cz 6 | bug-reports: https://github.com/haskell/containers/issues 7 | synopsis: Assorted concrete container types 8 | category: Data Structures 9 | description: 10 | This package contains efficient general-purpose implementations 11 | of various basic immutable container types. The declared cost of 12 | each operation is either worst-case or amortized, but remains 13 | valid even if structures are shared. 14 | build-type: Simple 15 | cabal-version: >=1.8 16 | extra-source-files: include/Typeable.h 17 | 18 | source-repository head 19 | type: git 20 | location: http://github.com/haskell/containers.git 21 | 22 | Library 23 | build-depends: base >= 4.2 && < 5, array, deepseq >= 1.2 && < 1.4 24 | if impl(ghc>=6.10) 25 | build-depends: ghc-prim 26 | 27 | ghc-options: -O2 -Wall 28 | 29 | exposed-modules: 30 | Data.IntMap 31 | Data.IntMap.Lazy 32 | Data.IntMap.Strict 33 | Data.IntSet 34 | Data.Map 35 | Data.Map.Lazy 36 | Data.Map.Strict 37 | Data.Set 38 | if !impl(nhc98) 39 | exposed-modules: 40 | Data.Graph 41 | Data.Sequence 42 | Data.Tree 43 | other-modules: 44 | Data.IntMap.Base 45 | Data.Map.Base 46 | Data.StrictPair 47 | 48 | include-dirs: include 49 | 50 | if impl(ghc<7.0) 51 | extensions: MagicHash, DeriveDataTypeable, StandaloneDeriving, Rank2Types 52 | 53 | ------------------- 54 | -- T E S T I N G -- 55 | ------------------- 56 | 57 | -- Every test-suite contains the build-depends and options of the library, 58 | -- plus the testing stuff. 59 | 60 | -- Because the test-suites cannot contain conditionals in GHC 7.0, the extensions 61 | -- are switched on for every compiler to allow GHC < 7.0 to compile the tests 62 | -- (because GHC < 7.0 cannot handle conditional LANGUAGE pragmas). 63 | -- When testing with GHC < 7.0 is not needed, the extensions should be removed. 64 | 65 | Test-suite map-lazy-properties 66 | hs-source-dirs: tests, . 67 | main-is: map-properties.hs 68 | type: exitcode-stdio-1.0 69 | cpp-options: -DTESTING 70 | 71 | build-depends: base >= 4.2 && < 5, array, deepseq >= 1.2 && < 1.4, ghc-prim 72 | ghc-options: -O2 73 | extensions: MagicHash, DeriveDataTypeable, StandaloneDeriving, Rank2Types 74 | 75 | build-depends: 76 | HUnit, 77 | QuickCheck, 78 | test-framework, 79 | test-framework-hunit, 80 | test-framework-quickcheck2 81 | 82 | Test-suite map-strict-properties 83 | hs-source-dirs: tests, . 84 | main-is: map-properties.hs 85 | type: exitcode-stdio-1.0 86 | cpp-options: -DTESTING -DSTRICT 87 | 88 | build-depends: base >= 4.2 && < 5, array, deepseq >= 1.2 && < 1.4, ghc-prim 89 | ghc-options: -O2 90 | extensions: MagicHash, DeriveDataTypeable, StandaloneDeriving, Rank2Types 91 | 92 | build-depends: 93 | HUnit, 94 | QuickCheck, 95 | test-framework, 96 | test-framework-hunit, 97 | test-framework-quickcheck2 98 | 99 | Test-suite set-properties 100 | hs-source-dirs: tests, . 101 | main-is: set-properties.hs 102 | type: exitcode-stdio-1.0 103 | cpp-options: -DTESTING 104 | 105 | build-depends: base >= 4.2 && < 5, array, deepseq >= 1.2 && < 1.4, ghc-prim 106 | ghc-options: -O2 107 | extensions: MagicHash, DeriveDataTypeable, StandaloneDeriving, Rank2Types 108 | 109 | build-depends: 110 | QuickCheck, 111 | test-framework, 112 | test-framework-quickcheck2 113 | 114 | Test-suite intmap-lazy-properties 115 | hs-source-dirs: tests, . 116 | main-is: intmap-properties.hs 117 | type: exitcode-stdio-1.0 118 | cpp-options: -DTESTING 119 | 120 | build-depends: base >= 4.2 && < 5, array, deepseq >= 1.2 && < 1.4, ghc-prim 121 | ghc-options: -O2 122 | extensions: MagicHash, DeriveDataTypeable, StandaloneDeriving, Rank2Types 123 | 124 | build-depends: 125 | HUnit, 126 | QuickCheck, 127 | test-framework, 128 | test-framework-hunit, 129 | test-framework-quickcheck2 130 | 131 | Test-suite intmap-strict-properties 132 | hs-source-dirs: tests, . 133 | main-is: intmap-properties.hs 134 | type: exitcode-stdio-1.0 135 | cpp-options: -DTESTING -DSTRICT 136 | 137 | build-depends: base >= 4.2 && < 5, array, deepseq >= 1.2 && < 1.4, ghc-prim 138 | ghc-options: -O2 139 | extensions: MagicHash, DeriveDataTypeable, StandaloneDeriving, Rank2Types 140 | 141 | build-depends: 142 | HUnit, 143 | QuickCheck, 144 | test-framework, 145 | test-framework-hunit, 146 | test-framework-quickcheck2 147 | 148 | Test-suite intset-properties 149 | hs-source-dirs: tests, . 150 | main-is: intset-properties.hs 151 | type: exitcode-stdio-1.0 152 | cpp-options: -DTESTING 153 | 154 | build-depends: base >= 4.2 && < 5, array, deepseq >= 1.2 && < 1.4, ghc-prim 155 | ghc-options: -O2 156 | extensions: MagicHash, DeriveDataTypeable, StandaloneDeriving, Rank2Types 157 | 158 | build-depends: 159 | QuickCheck, 160 | test-framework, 161 | test-framework-quickcheck2 162 | 163 | Test-suite seq-properties 164 | hs-source-dirs: tests, . 165 | main-is: seq-properties.hs 166 | type: exitcode-stdio-1.0 167 | cpp-options: -DTESTING 168 | 169 | build-depends: base >= 4.2 && < 5, array, deepseq >= 1.2 && < 1.4, ghc-prim 170 | ghc-options: -O2 171 | extensions: MagicHash, DeriveDataTypeable, StandaloneDeriving, Rank2Types 172 | 173 | build-depends: 174 | QuickCheck, 175 | test-framework, 176 | test-framework-quickcheck2 177 | -------------------------------------------------------------------------------- /Data/Tree.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | #if __GLASGOW_HASKELL__ 3 | {-# LANGUAGE DeriveDataTypeable, StandaloneDeriving #-} 4 | #endif 5 | #if __GLASGOW_HASKELL__ >= 703 6 | {-# LANGUAGE Safe #-} 7 | #endif 8 | ----------------------------------------------------------------------------- 9 | -- | 10 | -- Module : Data.Tree 11 | -- Copyright : (c) The University of Glasgow 2002 12 | -- License : BSD-style (see the file libraries/base/LICENSE) 13 | -- 14 | -- Maintainer : libraries@haskell.org 15 | -- Stability : experimental 16 | -- Portability : portable 17 | -- 18 | -- Multi-way trees (/aka/ rose trees) and forests. 19 | -- 20 | ----------------------------------------------------------------------------- 21 | 22 | module Data.Tree( 23 | Tree(..), Forest, 24 | -- * Two-dimensional drawing 25 | drawTree, drawForest, 26 | -- * Extraction 27 | flatten, levels, 28 | -- * Building trees 29 | unfoldTree, unfoldForest, 30 | unfoldTreeM, unfoldForestM, 31 | unfoldTreeM_BF, unfoldForestM_BF, 32 | ) where 33 | 34 | import Control.Applicative (Applicative(..), (<$>)) 35 | import Control.Monad 36 | import Data.Monoid (Monoid(..)) 37 | import Data.Sequence (Seq, empty, singleton, (<|), (|>), fromList, 38 | ViewL(..), ViewR(..), viewl, viewr) 39 | import Data.Foldable (Foldable(foldMap), toList) 40 | import Data.Traversable (Traversable(traverse)) 41 | import Data.Typeable 42 | import Control.DeepSeq (NFData(rnf)) 43 | 44 | #ifdef __GLASGOW_HASKELL__ 45 | import Data.Data (Data) 46 | #endif 47 | 48 | -- | Multi-way trees, also known as /rose trees/. 49 | data Tree a = Node { 50 | rootLabel :: a, -- ^ label value 51 | subForest :: Forest a -- ^ zero or more child trees 52 | } 53 | #ifdef __GLASGOW_HASKELL__ 54 | deriving (Eq, Read, Show, Data) 55 | #else 56 | deriving (Eq, Read, Show) 57 | #endif 58 | type Forest a = [Tree a] 59 | 60 | #include "Typeable.h" 61 | INSTANCE_TYPEABLE1(Tree,treeTc,"Tree") 62 | 63 | instance Functor Tree where 64 | fmap f (Node x ts) = Node (f x) (map (fmap f) ts) 65 | 66 | instance Applicative Tree where 67 | pure x = Node x [] 68 | Node f tfs <*> tx@(Node x txs) = 69 | Node (f x) (map (f <$>) txs ++ map (<*> tx) tfs) 70 | 71 | instance Monad Tree where 72 | return x = Node x [] 73 | Node x ts >>= f = Node x' (ts' ++ map (>>= f) ts) 74 | where Node x' ts' = f x 75 | 76 | instance Traversable Tree where 77 | traverse f (Node x ts) = Node <$> f x <*> traverse (traverse f) ts 78 | 79 | instance Foldable Tree where 80 | foldMap f (Node x ts) = f x `mappend` foldMap (foldMap f) ts 81 | 82 | instance NFData a => NFData (Tree a) where 83 | rnf (Node x ts) = rnf x `seq` rnf ts 84 | 85 | -- | Neat 2-dimensional drawing of a tree. 86 | drawTree :: Tree String -> String 87 | drawTree = unlines . draw 88 | 89 | -- | Neat 2-dimensional drawing of a forest. 90 | drawForest :: Forest String -> String 91 | drawForest = unlines . map drawTree 92 | 93 | draw :: Tree String -> [String] 94 | draw (Node x ts0) = x : drawSubTrees ts0 95 | where 96 | drawSubTrees [] = [] 97 | drawSubTrees [t] = 98 | "|" : shift "`- " " " (draw t) 99 | drawSubTrees (t:ts) = 100 | "|" : shift "+- " "| " (draw t) ++ drawSubTrees ts 101 | 102 | shift first other = zipWith (++) (first : repeat other) 103 | 104 | -- | The elements of a tree in pre-order. 105 | flatten :: Tree a -> [a] 106 | flatten t = squish t [] 107 | where squish (Node x ts) xs = x:Prelude.foldr squish xs ts 108 | 109 | -- | Lists of nodes at each level of the tree. 110 | levels :: Tree a -> [[a]] 111 | levels t = 112 | map (map rootLabel) $ 113 | takeWhile (not . null) $ 114 | iterate (concatMap subForest) [t] 115 | 116 | -- | Build a tree from a seed value 117 | unfoldTree :: (b -> (a, [b])) -> b -> Tree a 118 | unfoldTree f b = let (a, bs) = f b in Node a (unfoldForest f bs) 119 | 120 | -- | Build a forest from a list of seed values 121 | unfoldForest :: (b -> (a, [b])) -> [b] -> Forest a 122 | unfoldForest f = map (unfoldTree f) 123 | 124 | -- | Monadic tree builder, in depth-first order 125 | unfoldTreeM :: Monad m => (b -> m (a, [b])) -> b -> m (Tree a) 126 | unfoldTreeM f b = do 127 | (a, bs) <- f b 128 | ts <- unfoldForestM f bs 129 | return (Node a ts) 130 | 131 | -- | Monadic forest builder, in depth-first order 132 | #ifndef __NHC__ 133 | unfoldForestM :: Monad m => (b -> m (a, [b])) -> [b] -> m (Forest a) 134 | #endif 135 | unfoldForestM f = Prelude.mapM (unfoldTreeM f) 136 | 137 | -- | Monadic tree builder, in breadth-first order, 138 | -- using an algorithm adapted from 139 | -- /Breadth-First Numbering: Lessons from a Small Exercise in Algorithm Design/, 140 | -- by Chris Okasaki, /ICFP'00/. 141 | unfoldTreeM_BF :: Monad m => (b -> m (a, [b])) -> b -> m (Tree a) 142 | unfoldTreeM_BF f b = liftM getElement $ unfoldForestQ f (singleton b) 143 | where 144 | getElement xs = case viewl xs of 145 | x :< _ -> x 146 | EmptyL -> error "unfoldTreeM_BF" 147 | 148 | -- | Monadic forest builder, in breadth-first order, 149 | -- using an algorithm adapted from 150 | -- /Breadth-First Numbering: Lessons from a Small Exercise in Algorithm Design/, 151 | -- by Chris Okasaki, /ICFP'00/. 152 | unfoldForestM_BF :: Monad m => (b -> m (a, [b])) -> [b] -> m (Forest a) 153 | unfoldForestM_BF f = liftM toList . unfoldForestQ f . fromList 154 | 155 | -- takes a sequence (queue) of seeds 156 | -- produces a sequence (reversed queue) of trees of the same length 157 | unfoldForestQ :: Monad m => (b -> m (a, [b])) -> Seq b -> m (Seq (Tree a)) 158 | unfoldForestQ f aQ = case viewl aQ of 159 | EmptyL -> return empty 160 | a :< aQ' -> do 161 | (b, as) <- f a 162 | tQ <- unfoldForestQ f (Prelude.foldl (|>) aQ' as) 163 | let (tQ', ts) = splitOnto [] as tQ 164 | return (Node b ts <| tQ') 165 | where 166 | splitOnto :: [a'] -> [b'] -> Seq a' -> (Seq a', [a']) 167 | splitOnto as [] q = (q, as) 168 | splitOnto as (_:bs) q = case viewr q of 169 | q' :> a -> splitOnto (a:as) bs q' 170 | EmptyR -> error "unfoldForestQ" 171 | -------------------------------------------------------------------------------- /benchmarks/Map.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | module Main where 3 | 4 | import Control.DeepSeq 5 | import Control.Exception (evaluate) 6 | import Control.Monad.Trans (liftIO) 7 | import Criterion.Config 8 | import Criterion.Main 9 | import Data.List (foldl') 10 | import qualified Data.Map as M 11 | import Data.Maybe (fromMaybe) 12 | import Prelude hiding (lookup) 13 | 14 | main = do 15 | let m = M.fromAscList elems :: M.Map Int Int 16 | m_even = M.fromAscList elems_even :: M.Map Int Int 17 | m_odd = M.fromAscList elems_odd :: M.Map Int Int 18 | defaultMainWith 19 | defaultConfig 20 | (liftIO . evaluate $ rnf [m, m_even, m_odd]) 21 | [ bench "lookup absent" $ nf (lookup evens) m_odd 22 | , bench "lookup present" $ nf (lookup evens) m_even 23 | , bench "insert absent" $ nf (ins elems_even) m_odd 24 | , bench "insert present" $ nf (ins elems_even) m_even 25 | , bench "insertWith absent" $ nf (insWith elems_even) m_odd 26 | , bench "insertWith present" $ nf (insWith elems_even) m_even 27 | , bench "insertWith' absent" $ nf (insWith' elems_even) m_odd 28 | , bench "insertWith' present" $ nf (insWith' elems_even) m_even 29 | , bench "insertWithKey absent" $ nf (insWithKey elems_even) m_odd 30 | , bench "insertWithKey present" $ nf (insWithKey elems_even) m_even 31 | , bench "insertWithKey' absent" $ nf (insWithKey' elems_even) m_odd 32 | , bench "insertWithKey' present" $ nf (insWithKey' elems_even) m_even 33 | , bench "insertLookupWithKey absent" $ 34 | nf (insLookupWithKey elems_even) m_odd 35 | , bench "insertLookupWithKey present" $ 36 | nf (insLookupWithKey elems_even) m_even 37 | , bench "insertLookupWithKey' absent" $ 38 | nf (insLookupWithKey' elems_even) m_odd 39 | , bench "insertLookupWithKey' present" $ 40 | nf (insLookupWithKey' elems_even) m_even 41 | , bench "map" $ nf (M.map (+ 1)) m 42 | , bench "mapWithKey" $ nf (M.mapWithKey (+)) m 43 | , bench "foldlWithKey" $ nf (ins elems) m 44 | -- , bench "foldlWithKey'" $ nf (M.foldlWithKey' sum 0) m 45 | , bench "foldrWithKey" $ nf (M.foldrWithKey consPair []) m 46 | , bench "delete absent" $ nf (del evens) m_odd 47 | , bench "delete present" $ nf (del evens) m 48 | , bench "update absent" $ nf (upd Just evens) m_odd 49 | , bench "update present" $ nf (upd Just evens) m_even 50 | , bench "update delete" $ nf (upd (const Nothing) evens) m 51 | , bench "updateLookupWithKey absent" $ nf (upd' Just evens) m_odd 52 | , bench "updateLookupWithKey present" $ nf (upd' Just evens) m_even 53 | , bench "updateLookupWithKey delete" $ nf (upd' (const Nothing) evens) m 54 | , bench "alter absent" $ nf (alt id evens) m_odd 55 | , bench "alter insert" $ nf (alt (const (Just 1)) evens) m_odd 56 | , bench "alter update" $ nf (alt id evens) m_even 57 | , bench "alter delete" $ nf (alt (const Nothing) evens) m 58 | , bench "mapMaybe" $ nf (M.mapMaybe maybeDel) m 59 | , bench "mapMaybeWithKey" $ nf (M.mapMaybeWithKey (const maybeDel)) m 60 | , bench "lookupIndex" $ nf (lookupIndex keys) m 61 | , bench "union" $ nf (M.union m_even) m_odd 62 | , bench "difference" $ nf (M.difference m) m_even 63 | , bench "intersection" $ nf (M.intersection m) m_even 64 | ] 65 | where 66 | bound = 2^10 67 | elems = zip keys values 68 | elems_even = zip evens evens 69 | elems_odd = zip odds odds 70 | keys = [1..bound] 71 | evens = [2,4..bound] 72 | odds = [1,3..bound] 73 | values = [1..bound] 74 | sum k v1 v2 = k + v1 + v2 75 | consPair k v xs = (k, v) : xs 76 | 77 | add3 :: Int -> Int -> Int -> Int 78 | add3 x y z = x + y + z 79 | {-# INLINE add3 #-} 80 | 81 | lookup :: [Int] -> M.Map Int Int -> Int 82 | lookup xs m = foldl' (\n k -> fromMaybe n (M.lookup k m)) 0 xs 83 | 84 | lookupIndex :: [Int] -> M.Map Int Int -> Int 85 | lookupIndex xs m = foldl' (\n k -> fromMaybe n (M.lookupIndex k m)) 0 xs 86 | 87 | ins :: [(Int, Int)] -> M.Map Int Int -> M.Map Int Int 88 | ins xs m = foldl' (\m (k, v) -> M.insert k v m) m xs 89 | 90 | insWith :: [(Int, Int)] -> M.Map Int Int -> M.Map Int Int 91 | insWith xs m = foldl' (\m (k, v) -> M.insertWith (+) k v m) m xs 92 | 93 | insWithKey :: [(Int, Int)] -> M.Map Int Int -> M.Map Int Int 94 | insWithKey xs m = foldl' (\m (k, v) -> M.insertWithKey add3 k v m) m xs 95 | 96 | insWith' :: [(Int, Int)] -> M.Map Int Int -> M.Map Int Int 97 | insWith' xs m = foldl' (\m (k, v) -> M.insertWith' (+) k v m) m xs 98 | 99 | insWithKey' :: [(Int, Int)] -> M.Map Int Int -> M.Map Int Int 100 | insWithKey' xs m = foldl' (\m (k, v) -> M.insertWithKey' add3 k v m) m xs 101 | 102 | data PairS a b = PS !a !b 103 | 104 | insLookupWithKey :: [(Int, Int)] -> M.Map Int Int -> (Int, M.Map Int Int) 105 | insLookupWithKey xs m = let !(PS a b) = foldl' f (PS 0 m) xs in (a, b) 106 | where 107 | f (PS n m) (k, v) = let !(n', m') = M.insertLookupWithKey add3 k v m 108 | in PS (fromMaybe 0 n' + n) m' 109 | 110 | insLookupWithKey' :: [(Int, Int)] -> M.Map Int Int -> (Int, M.Map Int Int) 111 | insLookupWithKey' xs m = let !(PS a b) = foldl' f (PS 0 m) xs in (a, b) 112 | where 113 | f (PS n m) (k, v) = let !(n', m') = M.insertLookupWithKey' add3 k v m 114 | in PS (fromMaybe 0 n' + n) m' 115 | 116 | del :: [Int] -> M.Map Int Int -> M.Map Int Int 117 | del xs m = foldl' (\m k -> M.delete k m) m xs 118 | 119 | upd :: (Int -> Maybe Int) -> [Int] -> M.Map Int Int -> M.Map Int Int 120 | upd f xs m = foldl' (\m k -> M.update f k m) m xs 121 | 122 | upd' :: (Int -> Maybe Int) -> [Int] -> M.Map Int Int -> M.Map Int Int 123 | upd' f xs m = foldl' (\m k -> snd $ M.updateLookupWithKey (\_ a -> f a) k m) m xs 124 | 125 | alt :: (Maybe Int -> Maybe Int) -> [Int] -> M.Map Int Int -> M.Map Int Int 126 | alt f xs m = foldl' (\m k -> M.alter f k m) m xs 127 | 128 | maybeDel :: Int -> Maybe Int 129 | maybeDel n | n `mod` 3 == 0 = Nothing 130 | | otherwise = Just n 131 | -------------------------------------------------------------------------------- /Data/Map/Lazy.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | #if !defined(TESTING) && __GLASGOW_HASKELL__ >= 703 3 | {-# LANGUAGE Safe #-} 4 | #endif 5 | ----------------------------------------------------------------------------- 6 | -- | 7 | -- Module : Data.Map.Lazy 8 | -- Copyright : (c) Daan Leijen 2002 9 | -- (c) Andriy Palamarchuk 2008 10 | -- License : BSD-style 11 | -- Maintainer : libraries@haskell.org 12 | -- Stability : provisional 13 | -- Portability : portable 14 | -- 15 | -- An efficient implementation of ordered maps from keys to values 16 | -- (dictionaries). 17 | -- 18 | -- API of this module is strict in the keys, but lazy in the values. 19 | -- If you need value-strict maps, use 'Data.Map.Strict' instead. 20 | -- The 'Map' type itself is shared between the lazy and strict modules, 21 | -- meaning that the same 'Map' value can be passed to functions in 22 | -- both modules (although that is rarely needed). 23 | -- 24 | -- These modules are intended to be imported qualified, to avoid name 25 | -- clashes with Prelude functions, e.g. 26 | -- 27 | -- > import qualified Data.Map.Lazy as Map 28 | -- 29 | -- The implementation of 'Map' is based on /size balanced/ binary trees (or 30 | -- trees of /bounded balance/) as described by: 31 | -- 32 | -- * Stephen Adams, \"/Efficient sets: a balancing act/\", 33 | -- Journal of Functional Programming 3(4):553-562, October 1993, 34 | -- . 35 | -- 36 | -- * J. Nievergelt and E.M. Reingold, 37 | -- \"/Binary search trees of bounded balance/\", 38 | -- SIAM journal of computing 2(1), March 1973. 39 | -- 40 | -- Note that the implementation is /left-biased/ -- the elements of a 41 | -- first argument are always preferred to the second, for example in 42 | -- 'union' or 'insert'. 43 | -- 44 | -- Operation comments contain the operation time complexity in 45 | -- the Big-O notation (). 46 | ----------------------------------------------------------------------------- 47 | 48 | module Data.Map.Lazy ( 49 | -- * Strictness properties 50 | -- $strictness 51 | 52 | -- * Map type 53 | #if !defined(TESTING) 54 | Map -- instance Eq,Show,Read 55 | #else 56 | Map(..) -- instance Eq,Show,Read 57 | #endif 58 | 59 | -- * Operators 60 | , (!), (\\) 61 | 62 | -- * Query 63 | , M.null 64 | , size 65 | , member 66 | , notMember 67 | , M.lookup 68 | , findWithDefault 69 | 70 | -- * Construction 71 | , empty 72 | , singleton 73 | 74 | -- ** Insertion 75 | , insert 76 | , insertWith 77 | , insertWithKey 78 | , insertLookupWithKey 79 | 80 | -- ** Delete\/Update 81 | , delete 82 | , adjust 83 | , adjustWithKey 84 | , update 85 | , updateWithKey 86 | , updateLookupWithKey 87 | , alter 88 | 89 | -- * Combine 90 | 91 | -- ** Union 92 | , union 93 | , unionWith 94 | , unionWithKey 95 | , unions 96 | , unionsWith 97 | 98 | -- ** Difference 99 | , difference 100 | , differenceWith 101 | , differenceWithKey 102 | 103 | -- ** Intersection 104 | , intersection 105 | , intersectionWith 106 | , intersectionWithKey 107 | 108 | -- * Traversal 109 | -- ** Map 110 | , M.map 111 | , mapWithKey 112 | , traverseWithKey 113 | , mapAccum 114 | , mapAccumWithKey 115 | , mapAccumRWithKey 116 | , mapKeys 117 | , mapKeysWith 118 | , mapKeysMonotonic 119 | 120 | -- * Folds 121 | , M.foldr 122 | , M.foldl 123 | , foldrWithKey 124 | , foldlWithKey 125 | -- ** Strict folds 126 | , foldr' 127 | , foldl' 128 | , foldrWithKey' 129 | , foldlWithKey' 130 | 131 | -- * Conversion 132 | , elems 133 | , keys 134 | , keysSet 135 | , assocs 136 | 137 | -- ** Lists 138 | , toList 139 | , fromList 140 | , fromListWith 141 | , fromListWithKey 142 | 143 | -- ** Ordered lists 144 | , toAscList 145 | , toDescList 146 | , fromAscList 147 | , fromAscListWith 148 | , fromAscListWithKey 149 | , fromDistinctAscList 150 | 151 | -- * Filter 152 | , M.filter 153 | , filterWithKey 154 | , partition 155 | , partitionWithKey 156 | 157 | , mapMaybe 158 | , mapMaybeWithKey 159 | , mapEither 160 | , mapEitherWithKey 161 | 162 | , split 163 | , splitLookup 164 | 165 | -- * Submap 166 | , isSubmapOf, isSubmapOfBy 167 | , isProperSubmapOf, isProperSubmapOfBy 168 | 169 | -- * Indexed 170 | , lookupIndex 171 | , findIndex 172 | , elemAt 173 | , updateAt 174 | , deleteAt 175 | 176 | -- * Min\/Max 177 | , findMin 178 | , findMax 179 | , deleteMin 180 | , deleteMax 181 | , deleteFindMin 182 | , deleteFindMax 183 | , updateMin 184 | , updateMax 185 | , updateMinWithKey 186 | , updateMaxWithKey 187 | , minView 188 | , maxView 189 | , minViewWithKey 190 | , maxViewWithKey 191 | 192 | -- * Debugging 193 | , showTree 194 | , showTreeWith 195 | , valid 196 | 197 | #if defined(TESTING) 198 | -- * Internals 199 | , bin 200 | , balanced 201 | , join 202 | , merge 203 | #endif 204 | 205 | ) where 206 | 207 | import Data.Map.Base as M 208 | 209 | -- $strictness 210 | -- 211 | -- This module satisfies the following strictness property: 212 | -- 213 | -- * Key arguments are evaluated to WHNF 214 | -- 215 | -- Here are some examples that illustrate the property: 216 | -- 217 | -- > insertWith (\ new old -> old) undefined v m == undefined 218 | -- > insertWith (\ new old -> old) k undefined m == OK 219 | -- > delete undefined m == undefined 220 | -------------------------------------------------------------------------------- /Data/IntMap/Lazy.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | #if !defined(TESTING) && __GLASGOW_HASKELL__ >= 703 3 | {-# LANGUAGE Trustworthy #-} 4 | #endif 5 | ----------------------------------------------------------------------------- 6 | -- | 7 | -- Module : Data.IntMap.Lazy 8 | -- Copyright : (c) Daan Leijen 2002 9 | -- (c) Andriy Palamarchuk 2008 10 | -- License : BSD-style 11 | -- Maintainer : libraries@haskell.org 12 | -- Stability : provisional 13 | -- Portability : portable 14 | -- 15 | -- An efficient implementation of maps from integer keys to values 16 | -- (dictionaries). 17 | -- 18 | -- API of this module is strict in the keys, but lazy in the values. 19 | -- If you need value-strict maps, use 'Data.IntMap.Strict' instead. 20 | -- The 'IntMap' type itself is shared between the lazy and strict modules, 21 | -- meaning that the same 'IntMap' value can be passed to functions in 22 | -- both modules (although that is rarely needed). 23 | -- 24 | -- These modules are intended to be imported qualified, to avoid name 25 | -- clashes with Prelude functions, e.g. 26 | -- 27 | -- > import Data.IntMap.Lazy (IntMap) 28 | -- > import qualified Data.IntMap.Lazy as IntMap 29 | -- 30 | -- The implementation is based on /big-endian patricia trees/. This data 31 | -- structure performs especially well on binary operations like 'union' 32 | -- and 'intersection'. However, my benchmarks show that it is also 33 | -- (much) faster on insertions and deletions when compared to a generic 34 | -- size-balanced map implementation (see "Data.Map"). 35 | -- 36 | -- * Chris Okasaki and Andy Gill, \"/Fast Mergeable Integer Maps/\", 37 | -- Workshop on ML, September 1998, pages 77-86, 38 | -- 39 | -- 40 | -- * D.R. Morrison, \"/PATRICIA -- Practical Algorithm To Retrieve 41 | -- Information Coded In Alphanumeric/\", Journal of the ACM, 15(4), 42 | -- October 1968, pages 514-534. 43 | -- 44 | -- Operation comments contain the operation time complexity in 45 | -- the Big-O notation . 46 | -- Many operations have a worst-case complexity of /O(min(n,W))/. 47 | -- This means that the operation can become linear in the number of 48 | -- elements with a maximum of /W/ -- the number of bits in an 'Int' 49 | -- (32 or 64). 50 | ----------------------------------------------------------------------------- 51 | 52 | module Data.IntMap.Lazy ( 53 | -- * Strictness properties 54 | -- $strictness 55 | 56 | -- * Map type 57 | #if !defined(TESTING) 58 | IntMap, Key -- instance Eq,Show 59 | #else 60 | IntMap(..), Key -- instance Eq,Show 61 | #endif 62 | 63 | -- * Operators 64 | , (!), (\\) 65 | 66 | -- * Query 67 | , IM.null 68 | , size 69 | , member 70 | , notMember 71 | , IM.lookup 72 | , findWithDefault 73 | 74 | -- * Construction 75 | , empty 76 | , singleton 77 | 78 | -- ** Insertion 79 | , insert 80 | , insertWith 81 | , insertWithKey 82 | , insertLookupWithKey 83 | 84 | -- ** Delete\/Update 85 | , delete 86 | , adjust 87 | , adjustWithKey 88 | , update 89 | , updateWithKey 90 | , updateLookupWithKey 91 | , alter 92 | 93 | -- * Combine 94 | 95 | -- ** Union 96 | , union 97 | , unionWith 98 | , unionWithKey 99 | , unions 100 | , unionsWith 101 | 102 | -- ** Difference 103 | , difference 104 | , differenceWith 105 | , differenceWithKey 106 | 107 | -- ** Intersection 108 | , intersection 109 | , intersectionWith 110 | , intersectionWithKey 111 | 112 | -- * Traversal 113 | -- ** Map 114 | , IM.map 115 | , mapWithKey 116 | , traverseWithKey 117 | , mapAccum 118 | , mapAccumWithKey 119 | , mapAccumRWithKey 120 | , mapKeys 121 | , mapKeysWith 122 | , mapKeysMonotonic 123 | 124 | -- * Folds 125 | , IM.foldr 126 | , IM.foldl 127 | , foldrWithKey 128 | , foldlWithKey 129 | -- ** Strict folds 130 | , foldr' 131 | , foldl' 132 | , foldrWithKey' 133 | , foldlWithKey' 134 | 135 | -- * Conversion 136 | , elems 137 | , keys 138 | , keysSet 139 | , assocs 140 | 141 | -- ** Lists 142 | , toList 143 | , fromList 144 | , fromListWith 145 | , fromListWithKey 146 | 147 | -- ** Ordered lists 148 | , toAscList 149 | , toDescList 150 | , fromAscList 151 | , fromAscListWith 152 | , fromAscListWithKey 153 | , fromDistinctAscList 154 | 155 | -- * Filter 156 | , IM.filter 157 | , filterWithKey 158 | , partition 159 | , partitionWithKey 160 | 161 | , mapMaybe 162 | , mapMaybeWithKey 163 | , mapEither 164 | , mapEitherWithKey 165 | 166 | , split 167 | , splitLookup 168 | 169 | -- * Submap 170 | , isSubmapOf, isSubmapOfBy 171 | , isProperSubmapOf, isProperSubmapOfBy 172 | 173 | -- * Min\/Max 174 | , findMin 175 | , findMax 176 | , deleteMin 177 | , deleteMax 178 | , deleteFindMin 179 | , deleteFindMax 180 | , updateMin 181 | , updateMax 182 | , updateMinWithKey 183 | , updateMaxWithKey 184 | , minView 185 | , maxView 186 | , minViewWithKey 187 | , maxViewWithKey 188 | 189 | -- * Debugging 190 | , showTree 191 | , showTreeWith 192 | ) where 193 | 194 | import Data.IntMap.Base as IM 195 | 196 | -- $strictness 197 | -- 198 | -- This module satisfies the following strictness property: 199 | -- 200 | -- * Key arguments are evaluated to WHNF 201 | -- 202 | -- Here are some examples that illustrate the property: 203 | -- 204 | -- > insertWith (\ new old -> old) undefined v m == undefined 205 | -- > insertWith (\ new old -> old) k undefined m == OK 206 | -- > delete undefined m == undefined 207 | -------------------------------------------------------------------------------- /tests/intset-properties.hs: -------------------------------------------------------------------------------- 1 | import Data.Bits ((.&.)) 2 | import Data.IntSet 3 | import Data.List (nub,sort) 4 | import qualified Data.List as List 5 | import Data.Monoid (mempty) 6 | import qualified Data.Set as Set 7 | import Prelude hiding (lookup, null, map, filter, foldr, foldl) 8 | import Test.QuickCheck hiding ((.&.)) 9 | import Test.Framework 10 | import Test.Framework.Providers.QuickCheck2 11 | 12 | main :: IO () 13 | main = defaultMainWithOpts [ testProperty "prop_Single" prop_Single 14 | , testProperty "prop_InsertDelete" prop_InsertDelete 15 | , testProperty "prop_MemberFromList" prop_MemberFromList 16 | , testProperty "prop_UnionInsert" prop_UnionInsert 17 | , testProperty "prop_UnionAssoc" prop_UnionAssoc 18 | , testProperty "prop_UnionComm" prop_UnionComm 19 | , testProperty "prop_Diff" prop_Diff 20 | , testProperty "prop_Int" prop_Int 21 | , testProperty "prop_Ordered" prop_Ordered 22 | , testProperty "prop_List" prop_List 23 | , testProperty "prop_DescList" prop_DescList 24 | , testProperty "prop_AscDescList" prop_AscDescList 25 | , testProperty "prop_fromList" prop_fromList 26 | , testProperty "prop_MaskPow2" prop_MaskPow2 27 | , testProperty "prop_Prefix" prop_Prefix 28 | , testProperty "prop_LeftRight" prop_LeftRight 29 | , testProperty "prop_isProperSubsetOf" prop_isProperSubsetOf 30 | , testProperty "prop_isProperSubsetOf2" prop_isProperSubsetOf2 31 | , testProperty "prop_isSubsetOf" prop_isSubsetOf 32 | , testProperty "prop_isSubsetOf2" prop_isSubsetOf2 33 | , testProperty "prop_size" prop_size 34 | , testProperty "prop_findMax" prop_findMax 35 | , testProperty "prop_findMin" prop_findMin 36 | , testProperty "prop_ord" prop_ord 37 | , testProperty "prop_readShow" prop_readShow 38 | , testProperty "prop_foldR" prop_foldR 39 | , testProperty "prop_foldR'" prop_foldR' 40 | , testProperty "prop_foldL" prop_foldL 41 | , testProperty "prop_foldL'" prop_foldL' 42 | , testProperty "prop_map" prop_map 43 | , testProperty "prop_maxView" prop_maxView 44 | , testProperty "prop_minView" prop_minView 45 | , testProperty "prop_split" prop_split 46 | , testProperty "prop_splitMember" prop_splitMember 47 | , testProperty "prop_partition" prop_partition 48 | , testProperty "prop_filter" prop_filter 49 | ] opts 50 | where 51 | opts = mempty { ropt_test_options = Just $ mempty { topt_maximum_generated_tests = Just 500 52 | , topt_maximum_unsuitable_generated_tests = Just 500 53 | } 54 | } 55 | 56 | {-------------------------------------------------------------------- 57 | Arbitrary, reasonably balanced trees 58 | --------------------------------------------------------------------} 59 | instance Arbitrary IntSet where 60 | arbitrary = do{ xs <- arbitrary 61 | ; return (fromList xs) 62 | } 63 | 64 | 65 | {-------------------------------------------------------------------- 66 | Single, Insert, Delete, Member, FromList 67 | --------------------------------------------------------------------} 68 | prop_Single :: Int -> Bool 69 | prop_Single x 70 | = (insert x empty == singleton x) 71 | 72 | prop_InsertDelete :: Int -> IntSet -> Property 73 | prop_InsertDelete k t 74 | = not (member k t) ==> delete k (insert k t) == t 75 | 76 | prop_MemberFromList :: [Int] -> Bool 77 | prop_MemberFromList xs 78 | = all (`member` t) abs_xs && all ((`notMember` t) . negate) abs_xs 79 | where abs_xs = [abs x | x <- xs, x /= 0] 80 | t = fromList abs_xs 81 | 82 | {-------------------------------------------------------------------- 83 | Union 84 | --------------------------------------------------------------------} 85 | prop_UnionInsert :: Int -> IntSet -> Bool 86 | prop_UnionInsert x t 87 | = union t (singleton x) == insert x t 88 | 89 | prop_UnionAssoc :: IntSet -> IntSet -> IntSet -> Bool 90 | prop_UnionAssoc t1 t2 t3 91 | = union t1 (union t2 t3) == union (union t1 t2) t3 92 | 93 | prop_UnionComm :: IntSet -> IntSet -> Bool 94 | prop_UnionComm t1 t2 95 | = (union t1 t2 == union t2 t1) 96 | 97 | prop_Diff :: [Int] -> [Int] -> Bool 98 | prop_Diff xs ys 99 | = toAscList (difference (fromList xs) (fromList ys)) 100 | == List.sort ((List.\\) (nub xs) (nub ys)) 101 | 102 | prop_Int :: [Int] -> [Int] -> Bool 103 | prop_Int xs ys 104 | = toAscList (intersection (fromList xs) (fromList ys)) 105 | == List.sort (nub ((List.intersect) (xs) (ys))) 106 | 107 | {-------------------------------------------------------------------- 108 | Lists 109 | --------------------------------------------------------------------} 110 | prop_Ordered 111 | = forAll (choose (5,100)) $ \n -> 112 | let xs = concat [[i-n,i-n]|i<-[0..2*n :: Int]] 113 | in fromAscList xs == fromList xs 114 | 115 | prop_List :: [Int] -> Bool 116 | prop_List xs 117 | = (sort (nub xs) == toAscList (fromList xs)) 118 | 119 | prop_DescList :: [Int] -> Bool 120 | prop_DescList xs = (reverse (sort (nub xs)) == toDescList (fromList xs)) 121 | 122 | prop_AscDescList :: [Int] -> Bool 123 | prop_AscDescList xs = toAscList s == reverse (toDescList s) 124 | where s = fromList xs 125 | 126 | prop_fromList :: [Int] -> Bool 127 | prop_fromList xs 128 | = case fromList xs of 129 | t -> t == fromAscList sort_xs && 130 | t == fromDistinctAscList nub_sort_xs && 131 | t == List.foldr insert empty xs 132 | where sort_xs = sort xs 133 | nub_sort_xs = List.map List.head $ List.group sort_xs 134 | 135 | {-------------------------------------------------------------------- 136 | Bin invariants 137 | --------------------------------------------------------------------} 138 | powersOf2 :: IntSet 139 | powersOf2 = fromList [2^i | i <- [0..63]] 140 | 141 | -- Check the invariant that the mask is a power of 2. 142 | prop_MaskPow2 :: IntSet -> Bool 143 | prop_MaskPow2 (Bin _ msk left right) = member msk powersOf2 && prop_MaskPow2 left && prop_MaskPow2 right 144 | prop_MaskPow2 _ = True 145 | 146 | -- Check that the prefix satisfies its invariant. 147 | prop_Prefix :: IntSet -> Bool 148 | prop_Prefix s@(Bin prefix msk left right) = all (\elem -> match elem prefix msk) (toList s) && prop_Prefix left && prop_Prefix right 149 | prop_Prefix _ = True 150 | 151 | -- Check that the left elements don't have the mask bit set, and the right 152 | -- ones do. 153 | prop_LeftRight :: IntSet -> Bool 154 | prop_LeftRight (Bin _ msk left right) = and [x .&. msk == 0 | x <- toList left] && and [x .&. msk == msk | x <- toList right] 155 | prop_LeftRight _ = True 156 | 157 | {-------------------------------------------------------------------- 158 | IntSet operations are like Set operations 159 | --------------------------------------------------------------------} 160 | toSet :: IntSet -> Set.Set Int 161 | toSet = Set.fromList . toList 162 | 163 | -- Check that IntSet.isProperSubsetOf is the same as Set.isProperSubsetOf. 164 | prop_isProperSubsetOf :: IntSet -> IntSet -> Bool 165 | prop_isProperSubsetOf a b = isProperSubsetOf a b == Set.isProperSubsetOf (toSet a) (toSet b) 166 | 167 | -- In the above test, isProperSubsetOf almost always returns False (since a 168 | -- random set is almost never a subset of another random set). So this second 169 | -- test checks the True case. 170 | prop_isProperSubsetOf2 :: IntSet -> IntSet -> Bool 171 | prop_isProperSubsetOf2 a b = isProperSubsetOf a c == (a /= c) where 172 | c = union a b 173 | 174 | prop_isSubsetOf :: IntSet -> IntSet -> Bool 175 | prop_isSubsetOf a b = isSubsetOf a b == Set.isSubsetOf (toSet a) (toSet b) 176 | 177 | prop_isSubsetOf2 :: IntSet -> IntSet -> Bool 178 | prop_isSubsetOf2 a b = isSubsetOf a (union a b) 179 | 180 | prop_size :: IntSet -> Bool 181 | prop_size s = size s == List.length (toList s) 182 | 183 | prop_findMax :: IntSet -> Property 184 | prop_findMax s = not (null s) ==> findMax s == maximum (toList s) 185 | 186 | prop_findMin :: IntSet -> Property 187 | prop_findMin s = not (null s) ==> findMin s == minimum (toList s) 188 | 189 | prop_ord :: IntSet -> IntSet -> Bool 190 | prop_ord s1 s2 = s1 `compare` s2 == toList s1 `compare` toList s2 191 | 192 | prop_readShow :: IntSet -> Bool 193 | prop_readShow s = s == read (show s) 194 | 195 | prop_foldR :: IntSet -> Bool 196 | prop_foldR s = foldr (:) [] s == toList s 197 | 198 | prop_foldR' :: IntSet -> Bool 199 | prop_foldR' s = foldr' (:) [] s == toList s 200 | 201 | prop_foldL :: IntSet -> Bool 202 | prop_foldL s = foldl (flip (:)) [] s == List.foldl (flip (:)) [] (toList s) 203 | 204 | prop_foldL' :: IntSet -> Bool 205 | prop_foldL' s = foldl' (flip (:)) [] s == List.foldl' (flip (:)) [] (toList s) 206 | 207 | prop_map :: IntSet -> Bool 208 | prop_map s = map id s == s 209 | 210 | prop_maxView :: IntSet -> Bool 211 | prop_maxView s = case maxView s of 212 | Nothing -> null s 213 | Just (m,s') -> m == maximum (toList s) && s == insert m s' && m `notMember` s' 214 | 215 | prop_minView :: IntSet -> Bool 216 | prop_minView s = case minView s of 217 | Nothing -> null s 218 | Just (m,s') -> m == minimum (toList s) && s == insert m s' && m `notMember` s' 219 | 220 | prop_split :: IntSet -> Int -> Bool 221 | prop_split s i = case split i s of 222 | (s1,s2) -> all (i) (toList s2) && i `delete` s == union s1 s2 223 | 224 | prop_splitMember :: IntSet -> Int -> Bool 225 | prop_splitMember s i = case splitMember i s of 226 | (s1,t,s2) -> all (i) (toList s2) && t == i `member` s && i `delete` s == union s1 s2 227 | 228 | prop_partition :: IntSet -> Int -> Bool 229 | prop_partition s i = case partition odd s of 230 | (s1,s2) -> all odd (toList s1) && all even (toList s2) && s == s1 `union` s2 231 | 232 | prop_filter :: IntSet -> Int -> Bool 233 | prop_filter s i = partition odd s == (filter odd s, filter even s) 234 | -------------------------------------------------------------------------------- /tests/set-properties.hs: -------------------------------------------------------------------------------- 1 | import qualified Data.IntSet as IntSet 2 | import Data.List (nub,sort) 3 | import qualified Data.List as List 4 | import Data.Monoid (mempty) 5 | import Data.Set 6 | import Prelude hiding (lookup, null, map, filter, foldr, foldl) 7 | import Test.QuickCheck 8 | import Test.Framework 9 | import Test.Framework.Providers.QuickCheck2 10 | 11 | main :: IO () 12 | main = defaultMainWithOpts [ testProperty "prop_Valid" prop_Valid 13 | , testProperty "prop_Single" prop_Single 14 | , testProperty "prop_InsertValid" prop_InsertValid 15 | , testProperty "prop_InsertDelete" prop_InsertDelete 16 | , testProperty "prop_DeleteValid" prop_DeleteValid 17 | , testProperty "prop_Join" prop_Join 18 | , testProperty "prop_Merge" prop_Merge 19 | , testProperty "prop_UnionValid" prop_UnionValid 20 | , testProperty "prop_UnionInsert" prop_UnionInsert 21 | , testProperty "prop_UnionAssoc" prop_UnionAssoc 22 | , testProperty "prop_UnionComm" prop_UnionComm 23 | , testProperty "prop_DiffValid" prop_DiffValid 24 | , testProperty "prop_Diff" prop_Diff 25 | , testProperty "prop_IntValid" prop_IntValid 26 | , testProperty "prop_Int" prop_Int 27 | , testProperty "prop_Ordered" prop_Ordered 28 | , testProperty "prop_List" prop_List 29 | , testProperty "prop_DescList" prop_DescList 30 | , testProperty "prop_AscDescList" prop_AscDescList 31 | , testProperty "prop_fromList" prop_fromList 32 | , testProperty "prop_isProperSubsetOf" prop_isProperSubsetOf 33 | , testProperty "prop_isProperSubsetOf2" prop_isProperSubsetOf2 34 | , testProperty "prop_isSubsetOf" prop_isSubsetOf 35 | , testProperty "prop_isSubsetOf2" prop_isSubsetOf2 36 | , testProperty "prop_size" prop_size 37 | , testProperty "prop_findMax" prop_findMax 38 | , testProperty "prop_findMin" prop_findMin 39 | , testProperty "prop_ord" prop_ord 40 | , testProperty "prop_readShow" prop_readShow 41 | , testProperty "prop_foldR" prop_foldR 42 | , testProperty "prop_foldR'" prop_foldR' 43 | , testProperty "prop_foldL" prop_foldL 44 | , testProperty "prop_foldL'" prop_foldL' 45 | , testProperty "prop_map" prop_map 46 | , testProperty "prop_maxView" prop_maxView 47 | , testProperty "prop_minView" prop_minView 48 | , testProperty "prop_split" prop_split 49 | , testProperty "prop_splitMember" prop_splitMember 50 | , testProperty "prop_partition" prop_partition 51 | , testProperty "prop_filter" prop_filter 52 | ] opts 53 | where 54 | opts = mempty { ropt_test_options = Just $ mempty { topt_maximum_generated_tests = Just 500 55 | , topt_maximum_unsuitable_generated_tests = Just 500 56 | } 57 | } 58 | 59 | {-------------------------------------------------------------------- 60 | Arbitrary, reasonably balanced trees 61 | --------------------------------------------------------------------} 62 | instance (Enum a) => Arbitrary (Set a) where 63 | arbitrary = sized (arbtree 0 maxkey) 64 | where maxkey = 10000 65 | 66 | arbtree :: (Enum a) => Int -> Int -> Int -> Gen (Set a) 67 | arbtree lo hi n = do t <- gentree lo hi n 68 | if balanced t then return t else arbtree lo hi n 69 | where gentree lo hi n 70 | | n <= 0 = return Tip 71 | | lo >= hi = return Tip 72 | | otherwise = do i <- choose (lo,hi) 73 | m <- choose (1,70) 74 | let (ml,mr) | m==(1::Int) = (1,2) 75 | | m==2 = (2,1) 76 | | m==3 = (1,1) 77 | | otherwise = (2,2) 78 | l <- gentree lo (i-1) (n `div` ml) 79 | r <- gentree (i+1) hi (n `div` mr) 80 | return (bin (toEnum i) l r) 81 | 82 | {-------------------------------------------------------------------- 83 | Valid tree's 84 | --------------------------------------------------------------------} 85 | forValid :: (Enum a,Show a,Testable b) => (Set a -> b) -> Property 86 | forValid f = forAll arbitrary $ \t -> 87 | -- classify (balanced t) "balanced" $ 88 | classify (size t == 0) "empty" $ 89 | classify (size t > 0 && size t <= 10) "small" $ 90 | classify (size t > 10 && size t <= 64) "medium" $ 91 | classify (size t > 64) "large" $ 92 | balanced t ==> f t 93 | 94 | forValidUnitTree :: Testable a => (Set Int -> a) -> Property 95 | forValidUnitTree f = forValid f 96 | 97 | prop_Valid :: Property 98 | prop_Valid = forValidUnitTree $ \t -> valid t 99 | 100 | {-------------------------------------------------------------------- 101 | Single, Insert, Delete 102 | --------------------------------------------------------------------} 103 | prop_Single :: Int -> Bool 104 | prop_Single x = (insert x empty == singleton x) 105 | 106 | prop_InsertValid :: Int -> Property 107 | prop_InsertValid k = forValidUnitTree $ \t -> valid (insert k t) 108 | 109 | prop_InsertDelete :: Int -> Set Int -> Property 110 | prop_InsertDelete k t = not (member k t) ==> delete k (insert k t) == t 111 | 112 | prop_DeleteValid :: Int -> Property 113 | prop_DeleteValid k = forValidUnitTree $ \t -> valid (delete k (insert k t)) 114 | 115 | {-------------------------------------------------------------------- 116 | Balance 117 | --------------------------------------------------------------------} 118 | prop_Join :: Int -> Property 119 | prop_Join x = forValidUnitTree $ \t -> 120 | let (l,r) = split x t 121 | in valid (join x l r) 122 | 123 | prop_Merge :: Int -> Property 124 | prop_Merge x = forValidUnitTree $ \t -> 125 | let (l,r) = split x t 126 | in valid (merge l r) 127 | 128 | {-------------------------------------------------------------------- 129 | Union 130 | --------------------------------------------------------------------} 131 | prop_UnionValid :: Property 132 | prop_UnionValid 133 | = forValidUnitTree $ \t1 -> 134 | forValidUnitTree $ \t2 -> 135 | valid (union t1 t2) 136 | 137 | prop_UnionInsert :: Int -> Set Int -> Bool 138 | prop_UnionInsert x t = union t (singleton x) == insert x t 139 | 140 | prop_UnionAssoc :: Set Int -> Set Int -> Set Int -> Bool 141 | prop_UnionAssoc t1 t2 t3 = union t1 (union t2 t3) == union (union t1 t2) t3 142 | 143 | prop_UnionComm :: Set Int -> Set Int -> Bool 144 | prop_UnionComm t1 t2 = (union t1 t2 == union t2 t1) 145 | 146 | prop_DiffValid :: Property 147 | prop_DiffValid = forValidUnitTree $ \t1 -> 148 | forValidUnitTree $ \t2 -> 149 | valid (difference t1 t2) 150 | 151 | prop_Diff :: [Int] -> [Int] -> Bool 152 | prop_Diff xs ys = toAscList (difference (fromList xs) (fromList ys)) 153 | == List.sort ((List.\\) (nub xs) (nub ys)) 154 | 155 | prop_IntValid :: Property 156 | prop_IntValid = forValidUnitTree $ \t1 -> 157 | forValidUnitTree $ \t2 -> 158 | valid (intersection t1 t2) 159 | 160 | prop_Int :: [Int] -> [Int] -> Bool 161 | prop_Int xs ys = toAscList (intersection (fromList xs) (fromList ys)) 162 | == List.sort (nub ((List.intersect) (xs) (ys))) 163 | 164 | {-------------------------------------------------------------------- 165 | Lists 166 | --------------------------------------------------------------------} 167 | prop_Ordered :: Property 168 | prop_Ordered = forAll (choose (5,100)) $ \n -> 169 | let xs = [0..n::Int] 170 | in fromAscList xs == fromList xs 171 | 172 | prop_List :: [Int] -> Bool 173 | prop_List xs = (sort (nub xs) == toList (fromList xs)) 174 | 175 | prop_DescList :: [Int] -> Bool 176 | prop_DescList xs = (reverse (sort (nub xs)) == toDescList (fromList xs)) 177 | 178 | prop_AscDescList :: [Int] -> Bool 179 | prop_AscDescList xs = toAscList s == reverse (toDescList s) 180 | where s = fromList xs 181 | 182 | prop_fromList :: [Int] -> Bool 183 | prop_fromList xs 184 | = case fromList xs of 185 | t -> t == fromAscList sort_xs && 186 | t == fromDistinctAscList nub_sort_xs && 187 | t == List.foldr insert empty xs 188 | where sort_xs = sort xs 189 | nub_sort_xs = List.map List.head $ List.group sort_xs 190 | 191 | {-------------------------------------------------------------------- 192 | Set operations are like IntSet operations 193 | --------------------------------------------------------------------} 194 | toIntSet :: Set Int -> IntSet.IntSet 195 | toIntSet = IntSet.fromList . toList 196 | 197 | -- Check that Set Int.isProperSubsetOf is the same as Set.isProperSubsetOf. 198 | prop_isProperSubsetOf :: Set Int -> Set Int -> Bool 199 | prop_isProperSubsetOf a b = isProperSubsetOf a b == IntSet.isProperSubsetOf (toIntSet a) (toIntSet b) 200 | 201 | -- In the above test, isProperSubsetOf almost always returns False (since a 202 | -- random set is almost never a subset of another random set). So this second 203 | -- test checks the True case. 204 | prop_isProperSubsetOf2 :: Set Int -> Set Int -> Bool 205 | prop_isProperSubsetOf2 a b = isProperSubsetOf a c == (a /= c) where 206 | c = union a b 207 | 208 | prop_isSubsetOf :: Set Int -> Set Int -> Bool 209 | prop_isSubsetOf a b = isSubsetOf a b == IntSet.isSubsetOf (toIntSet a) (toIntSet b) 210 | 211 | prop_isSubsetOf2 :: Set Int -> Set Int -> Bool 212 | prop_isSubsetOf2 a b = isSubsetOf a (union a b) 213 | 214 | prop_size :: Set Int -> Bool 215 | prop_size s = size s == List.length (toList s) 216 | 217 | prop_findMax :: Set Int -> Property 218 | prop_findMax s = not (null s) ==> findMax s == maximum (toList s) 219 | 220 | prop_findMin :: Set Int -> Property 221 | prop_findMin s = not (null s) ==> findMin s == minimum (toList s) 222 | 223 | prop_ord :: Set Int -> Set Int -> Bool 224 | prop_ord s1 s2 = s1 `compare` s2 == toList s1 `compare` toList s2 225 | 226 | prop_readShow :: Set Int -> Bool 227 | prop_readShow s = s == read (show s) 228 | 229 | prop_foldR :: Set Int -> Bool 230 | prop_foldR s = foldr (:) [] s == toList s 231 | 232 | prop_foldR' :: Set Int -> Bool 233 | prop_foldR' s = foldr' (:) [] s == toList s 234 | 235 | prop_foldL :: Set Int -> Bool 236 | prop_foldL s = foldl (flip (:)) [] s == List.foldl (flip (:)) [] (toList s) 237 | 238 | prop_foldL' :: Set Int -> Bool 239 | prop_foldL' s = foldl' (flip (:)) [] s == List.foldl' (flip (:)) [] (toList s) 240 | 241 | prop_map :: Set Int -> Bool 242 | prop_map s = map id s == s 243 | 244 | prop_maxView :: Set Int -> Bool 245 | prop_maxView s = case maxView s of 246 | Nothing -> null s 247 | Just (m,s') -> m == maximum (toList s) && s == insert m s' && m `notMember` s' 248 | 249 | prop_minView :: Set Int -> Bool 250 | prop_minView s = case minView s of 251 | Nothing -> null s 252 | Just (m,s') -> m == minimum (toList s) && s == insert m s' && m `notMember` s' 253 | 254 | prop_split :: Set Int -> Int -> Bool 255 | prop_split s i = case split i s of 256 | (s1,s2) -> all (i) (toList s2) && i `delete` s == union s1 s2 257 | 258 | prop_splitMember :: Set Int -> Int -> Bool 259 | prop_splitMember s i = case splitMember i s of 260 | (s1,t,s2) -> all (i) (toList s2) && t == i `member` s && i `delete` s == union s1 s2 261 | 262 | prop_partition :: Set Int -> Int -> Bool 263 | prop_partition s i = case partition odd s of 264 | (s1,s2) -> all odd (toList s1) && all even (toList s2) && s == s1 `union` s2 265 | 266 | prop_filter :: Set Int -> Int -> Bool 267 | prop_filter s i = partition odd s == (filter odd s, filter even s) 268 | -------------------------------------------------------------------------------- /Data/Graph.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | #if __GLASGOW_HASKELL__ 3 | {-# LANGUAGE Rank2Types #-} 4 | #endif 5 | #if __GLASGOW_HASKELL__ >= 703 6 | {-# LANGUAGE Trustworthy #-} 7 | #endif 8 | ----------------------------------------------------------------------------- 9 | -- | 10 | -- Module : Data.Graph 11 | -- Copyright : (c) The University of Glasgow 2002 12 | -- License : BSD-style (see the file libraries/base/LICENSE) 13 | -- 14 | -- Maintainer : libraries@haskell.org 15 | -- Stability : experimental 16 | -- Portability : portable 17 | -- 18 | -- A version of the graph algorithms described in: 19 | -- 20 | -- /Lazy Depth-First Search and Linear Graph Algorithms in Haskell/, 21 | -- by David King and John Launchbury. 22 | -- 23 | ----------------------------------------------------------------------------- 24 | 25 | module Data.Graph( 26 | 27 | -- * External interface 28 | 29 | -- At present the only one with a "nice" external interface 30 | stronglyConnComp, stronglyConnCompR, SCC(..), flattenSCC, flattenSCCs, 31 | 32 | -- * Graphs 33 | 34 | Graph, Table, Bounds, Edge, Vertex, 35 | 36 | -- ** Building graphs 37 | 38 | graphFromEdges, graphFromEdges', buildG, transposeG, 39 | -- reverseE, 40 | 41 | -- ** Graph properties 42 | 43 | vertices, edges, 44 | outdegree, indegree, 45 | 46 | -- * Algorithms 47 | 48 | dfs, dff, 49 | topSort, 50 | components, 51 | scc, 52 | bcc, 53 | -- tree, back, cross, forward, 54 | reachable, path, 55 | 56 | module Data.Tree 57 | 58 | ) where 59 | 60 | #if __GLASGOW_HASKELL__ 61 | # define USE_ST_MONAD 1 62 | #endif 63 | 64 | -- Extensions 65 | #if USE_ST_MONAD 66 | import Control.Monad.ST 67 | import Data.Array.ST (STArray, newArray, readArray, writeArray) 68 | #else 69 | import Data.IntSet (IntSet) 70 | import qualified Data.IntSet as Set 71 | #endif 72 | import Data.Tree (Tree(Node), Forest) 73 | 74 | -- std interfaces 75 | import Control.DeepSeq (NFData(rnf)) 76 | import Data.Maybe 77 | import Data.Array 78 | import Data.List 79 | 80 | ------------------------------------------------------------------------- 81 | -- - 82 | -- External interface 83 | -- - 84 | ------------------------------------------------------------------------- 85 | 86 | -- | Strongly connected component. 87 | data SCC vertex = AcyclicSCC vertex -- ^ A single vertex that is not 88 | -- in any cycle. 89 | | CyclicSCC [vertex] -- ^ A maximal set of mutually 90 | -- reachable vertices. 91 | 92 | instance NFData a => NFData (SCC a) where 93 | rnf (AcyclicSCC v) = rnf v 94 | rnf (CyclicSCC vs) = rnf vs 95 | 96 | -- | The vertices of a list of strongly connected components. 97 | flattenSCCs :: [SCC a] -> [a] 98 | flattenSCCs = concatMap flattenSCC 99 | 100 | -- | The vertices of a strongly connected component. 101 | flattenSCC :: SCC vertex -> [vertex] 102 | flattenSCC (AcyclicSCC v) = [v] 103 | flattenSCC (CyclicSCC vs) = vs 104 | 105 | -- | The strongly connected components of a directed graph, topologically 106 | -- sorted. 107 | stronglyConnComp 108 | :: Ord key 109 | => [(node, key, [key])] 110 | -- ^ The graph: a list of nodes uniquely identified by keys, 111 | -- with a list of keys of nodes this node has edges to. 112 | -- The out-list may contain keys that don't correspond to 113 | -- nodes of the graph; such edges are ignored. 114 | -> [SCC node] 115 | 116 | stronglyConnComp edges0 117 | = map get_node (stronglyConnCompR edges0) 118 | where 119 | get_node (AcyclicSCC (n, _, _)) = AcyclicSCC n 120 | get_node (CyclicSCC triples) = CyclicSCC [n | (n,_,_) <- triples] 121 | 122 | -- | The strongly connected components of a directed graph, topologically 123 | -- sorted. The function is the same as 'stronglyConnComp', except that 124 | -- all the information about each node retained. 125 | -- This interface is used when you expect to apply 'SCC' to 126 | -- (some of) the result of 'SCC', so you don't want to lose the 127 | -- dependency information. 128 | stronglyConnCompR 129 | :: Ord key 130 | => [(node, key, [key])] 131 | -- ^ The graph: a list of nodes uniquely identified by keys, 132 | -- with a list of keys of nodes this node has edges to. 133 | -- The out-list may contain keys that don't correspond to 134 | -- nodes of the graph; such edges are ignored. 135 | -> [SCC (node, key, [key])] -- ^ Topologically sorted 136 | 137 | stronglyConnCompR [] = [] -- added to avoid creating empty array in graphFromEdges -- SOF 138 | stronglyConnCompR edges0 139 | = map decode forest 140 | where 141 | (graph, vertex_fn,_) = graphFromEdges edges0 142 | forest = scc graph 143 | decode (Node v []) | mentions_itself v = CyclicSCC [vertex_fn v] 144 | | otherwise = AcyclicSCC (vertex_fn v) 145 | decode other = CyclicSCC (dec other []) 146 | where 147 | dec (Node v ts) vs = vertex_fn v : foldr dec vs ts 148 | mentions_itself v = v `elem` (graph ! v) 149 | 150 | ------------------------------------------------------------------------- 151 | -- - 152 | -- Graphs 153 | -- - 154 | ------------------------------------------------------------------------- 155 | 156 | -- | Abstract representation of vertices. 157 | type Vertex = Int 158 | -- | Table indexed by a contiguous set of vertices. 159 | type Table a = Array Vertex a 160 | -- | Adjacency list representation of a graph, mapping each vertex to its 161 | -- list of successors. 162 | type Graph = Table [Vertex] 163 | -- | The bounds of a 'Table'. 164 | type Bounds = (Vertex, Vertex) 165 | -- | An edge from the first vertex to the second. 166 | type Edge = (Vertex, Vertex) 167 | 168 | -- | All vertices of a graph. 169 | vertices :: Graph -> [Vertex] 170 | vertices = indices 171 | 172 | -- | All edges of a graph. 173 | edges :: Graph -> [Edge] 174 | edges g = [ (v, w) | v <- vertices g, w <- g!v ] 175 | 176 | mapT :: (Vertex -> a -> b) -> Table a -> Table b 177 | mapT f t = array (bounds t) [ (,) v (f v (t!v)) | v <- indices t ] 178 | 179 | -- | Build a graph from a list of edges. 180 | buildG :: Bounds -> [Edge] -> Graph 181 | buildG bounds0 edges0 = accumArray (flip (:)) [] bounds0 edges0 182 | 183 | -- | The graph obtained by reversing all edges. 184 | transposeG :: Graph -> Graph 185 | transposeG g = buildG (bounds g) (reverseE g) 186 | 187 | reverseE :: Graph -> [Edge] 188 | reverseE g = [ (w, v) | (v, w) <- edges g ] 189 | 190 | -- | A table of the count of edges from each node. 191 | outdegree :: Graph -> Table Int 192 | outdegree = mapT numEdges 193 | where numEdges _ ws = length ws 194 | 195 | -- | A table of the count of edges into each node. 196 | indegree :: Graph -> Table Int 197 | indegree = outdegree . transposeG 198 | 199 | -- | Identical to 'graphFromEdges', except that the return value 200 | -- does not include the function which maps keys to vertices. This 201 | -- version of 'graphFromEdges' is for backwards compatibility. 202 | graphFromEdges' 203 | :: Ord key 204 | => [(node, key, [key])] 205 | -> (Graph, Vertex -> (node, key, [key])) 206 | graphFromEdges' x = (a,b) where 207 | (a,b,_) = graphFromEdges x 208 | 209 | -- | Build a graph from a list of nodes uniquely identified by keys, 210 | -- with a list of keys of nodes this node should have edges to. 211 | -- The out-list may contain keys that don't correspond to 212 | -- nodes of the graph; they are ignored. 213 | graphFromEdges 214 | :: Ord key 215 | => [(node, key, [key])] 216 | -> (Graph, Vertex -> (node, key, [key]), key -> Maybe Vertex) 217 | graphFromEdges edges0 218 | = (graph, \v -> vertex_map ! v, key_vertex) 219 | where 220 | max_v = length edges0 - 1 221 | bounds0 = (0,max_v) :: (Vertex, Vertex) 222 | sorted_edges = sortBy lt edges0 223 | edges1 = zipWith (,) [0..] sorted_edges 224 | 225 | graph = array bounds0 [(,) v (mapMaybe key_vertex ks) | (,) v (_, _, ks) <- edges1] 226 | key_map = array bounds0 [(,) v k | (,) v (_, k, _ ) <- edges1] 227 | vertex_map = array bounds0 edges1 228 | 229 | (_,k1,_) `lt` (_,k2,_) = k1 `compare` k2 230 | 231 | -- key_vertex :: key -> Maybe Vertex 232 | -- returns Nothing for non-interesting vertices 233 | key_vertex k = findVertex 0 max_v 234 | where 235 | findVertex a b | a > b 236 | = Nothing 237 | findVertex a b = case compare k (key_map ! mid) of 238 | LT -> findVertex a (mid-1) 239 | EQ -> Just mid 240 | GT -> findVertex (mid+1) b 241 | where 242 | mid = (a + b) `div` 2 243 | 244 | ------------------------------------------------------------------------- 245 | -- - 246 | -- Depth first search 247 | -- - 248 | ------------------------------------------------------------------------- 249 | 250 | -- | A spanning forest of the graph, obtained from a depth-first search of 251 | -- the graph starting from each vertex in an unspecified order. 252 | dff :: Graph -> Forest Vertex 253 | dff g = dfs g (vertices g) 254 | 255 | -- | A spanning forest of the part of the graph reachable from the listed 256 | -- vertices, obtained from a depth-first search of the graph starting at 257 | -- each of the listed vertices in order. 258 | dfs :: Graph -> [Vertex] -> Forest Vertex 259 | dfs g vs = prune (bounds g) (map (generate g) vs) 260 | 261 | generate :: Graph -> Vertex -> Tree Vertex 262 | generate g v = Node v (map (generate g) (g!v)) 263 | 264 | prune :: Bounds -> Forest Vertex -> Forest Vertex 265 | prune bnds ts = run bnds (chop ts) 266 | 267 | chop :: Forest Vertex -> SetM s (Forest Vertex) 268 | chop [] = return [] 269 | chop (Node v ts : us) 270 | = do 271 | visited <- contains v 272 | if visited then 273 | chop us 274 | else do 275 | include v 276 | as <- chop ts 277 | bs <- chop us 278 | return (Node v as : bs) 279 | 280 | -- A monad holding a set of vertices visited so far. 281 | #if USE_ST_MONAD 282 | 283 | -- Use the ST monad if available, for constant-time primitives. 284 | 285 | newtype SetM s a = SetM { runSetM :: STArray s Vertex Bool -> ST s a } 286 | 287 | instance Monad (SetM s) where 288 | return x = SetM $ const (return x) 289 | SetM v >>= f = SetM $ \ s -> do { x <- v s; runSetM (f x) s } 290 | 291 | run :: Bounds -> (forall s. SetM s a) -> a 292 | run bnds act = runST (newArray bnds False >>= runSetM act) 293 | 294 | contains :: Vertex -> SetM s Bool 295 | contains v = SetM $ \ m -> readArray m v 296 | 297 | include :: Vertex -> SetM s () 298 | include v = SetM $ \ m -> writeArray m v True 299 | 300 | #else /* !USE_ST_MONAD */ 301 | 302 | -- Portable implementation using IntSet. 303 | 304 | newtype SetM s a = SetM { runSetM :: IntSet -> (a, IntSet) } 305 | 306 | instance Monad (SetM s) where 307 | return x = SetM $ \ s -> (x, s) 308 | SetM v >>= f = SetM $ \ s -> case v s of (x, s') -> runSetM (f x) s' 309 | 310 | run :: Bounds -> SetM s a -> a 311 | run _ act = fst (runSetM act Set.empty) 312 | 313 | contains :: Vertex -> SetM s Bool 314 | contains v = SetM $ \ m -> (Set.member v m, m) 315 | 316 | include :: Vertex -> SetM s () 317 | include v = SetM $ \ m -> ((), Set.insert v m) 318 | 319 | #endif /* !USE_ST_MONAD */ 320 | 321 | ------------------------------------------------------------------------- 322 | -- - 323 | -- Algorithms 324 | -- - 325 | ------------------------------------------------------------------------- 326 | 327 | ------------------------------------------------------------ 328 | -- Algorithm 1: depth first search numbering 329 | ------------------------------------------------------------ 330 | 331 | preorder' :: Tree a -> [a] -> [a] 332 | preorder' (Node a ts) = (a :) . preorderF' ts 333 | 334 | preorderF' :: Forest a -> [a] -> [a] 335 | preorderF' ts = foldr (.) id $ map preorder' ts 336 | 337 | preorderF :: Forest a -> [a] 338 | preorderF ts = preorderF' ts [] 339 | 340 | tabulate :: Bounds -> [Vertex] -> Table Int 341 | tabulate bnds vs = array bnds (zipWith (,) vs [1..]) 342 | 343 | preArr :: Bounds -> Forest Vertex -> Table Int 344 | preArr bnds = tabulate bnds . preorderF 345 | 346 | ------------------------------------------------------------ 347 | -- Algorithm 2: topological sorting 348 | ------------------------------------------------------------ 349 | 350 | postorder :: Tree a -> [a] -> [a] 351 | postorder (Node a ts) = postorderF ts . (a :) 352 | 353 | postorderF :: Forest a -> [a] -> [a] 354 | postorderF ts = foldr (.) id $ map postorder ts 355 | 356 | postOrd :: Graph -> [Vertex] 357 | postOrd g = postorderF (dff g) [] 358 | 359 | -- | A topological sort of the graph. 360 | -- The order is partially specified by the condition that a vertex /i/ 361 | -- precedes /j/ whenever /j/ is reachable from /i/ but not vice versa. 362 | topSort :: Graph -> [Vertex] 363 | topSort = reverse . postOrd 364 | 365 | ------------------------------------------------------------ 366 | -- Algorithm 3: connected components 367 | ------------------------------------------------------------ 368 | 369 | -- | The connected components of a graph. 370 | -- Two vertices are connected if there is a path between them, traversing 371 | -- edges in either direction. 372 | components :: Graph -> Forest Vertex 373 | components = dff . undirected 374 | 375 | undirected :: Graph -> Graph 376 | undirected g = buildG (bounds g) (edges g ++ reverseE g) 377 | 378 | -- Algorithm 4: strongly connected components 379 | 380 | -- | The strongly connected components of a graph. 381 | scc :: Graph -> Forest Vertex 382 | scc g = dfs g (reverse (postOrd (transposeG g))) 383 | 384 | ------------------------------------------------------------ 385 | -- Algorithm 5: Classifying edges 386 | ------------------------------------------------------------ 387 | 388 | {- 389 | XXX unused code 390 | 391 | tree :: Bounds -> Forest Vertex -> Graph 392 | tree bnds ts = buildG bnds (concat (map flat ts)) 393 | where flat (Node v ts') = [ (v, w) | Node w _us <- ts' ] 394 | ++ concat (map flat ts') 395 | 396 | back :: Graph -> Table Int -> Graph 397 | back g post = mapT select g 398 | where select v ws = [ w | w <- ws, post!v < post!w ] 399 | 400 | cross :: Graph -> Table Int -> Table Int -> Graph 401 | cross g pre post = mapT select g 402 | where select v ws = [ w | w <- ws, post!v > post!w, pre!v > pre!w ] 403 | 404 | forward :: Graph -> Graph -> Table Int -> Graph 405 | forward g tree' pre = mapT select g 406 | where select v ws = [ w | w <- ws, pre!v < pre!w ] \\ tree' ! v 407 | -} 408 | 409 | ------------------------------------------------------------ 410 | -- Algorithm 6: Finding reachable vertices 411 | ------------------------------------------------------------ 412 | 413 | -- | A list of vertices reachable from a given vertex. 414 | reachable :: Graph -> Vertex -> [Vertex] 415 | reachable g v = preorderF (dfs g [v]) 416 | 417 | -- | Is the second vertex reachable from the first? 418 | path :: Graph -> Vertex -> Vertex -> Bool 419 | path g v w = w `elem` (reachable g v) 420 | 421 | ------------------------------------------------------------ 422 | -- Algorithm 7: Biconnected components 423 | ------------------------------------------------------------ 424 | 425 | -- | The biconnected components of a graph. 426 | -- An undirected graph is biconnected if the deletion of any vertex 427 | -- leaves it connected. 428 | bcc :: Graph -> Forest [Vertex] 429 | bcc g = (concat . map bicomps . map (do_label g dnum)) forest 430 | where forest = dff g 431 | dnum = preArr (bounds g) forest 432 | 433 | do_label :: Graph -> Table Int -> Tree Vertex -> Tree (Vertex,Int,Int) 434 | do_label g dnum (Node v ts) = Node (v,dnum!v,lv) us 435 | where us = map (do_label g dnum) ts 436 | lv = minimum ([dnum!v] ++ [dnum!w | w <- g!v] 437 | ++ [lu | Node (_,_,lu) _ <- us]) 438 | 439 | bicomps :: Tree (Vertex,Int,Int) -> Forest [Vertex] 440 | bicomps (Node (v,_,_) ts) 441 | = [ Node (v:vs) us | (_,Node vs us) <- map collect ts] 442 | 443 | collect :: Tree (Vertex,Int,Int) -> (Int, Tree [Vertex]) 444 | collect (Node (v,dv,lv) ts) = (lv, Node (v:vs) cs) 445 | where collected = map collect ts 446 | vs = concat [ ws | (lw, Node ws _) <- collected, lw), (<$)) 7 | import Data.Maybe 8 | import Data.Monoid (Monoid(..)) 9 | import Data.Traversable (Traversable(traverse), sequenceA) 10 | import Prelude hiding ( 11 | null, length, take, drop, splitAt, 12 | foldl, foldl1, foldr, foldr1, scanl, scanl1, scanr, scanr1, 13 | filter, reverse, replicate, zip, zipWith, zip3, zipWith3, 14 | all, sum) 15 | import qualified Prelude 16 | import qualified Data.List 17 | import Test.QuickCheck hiding ((><)) 18 | import Test.QuickCheck.Poly 19 | import Test.Framework 20 | import Test.Framework.Providers.QuickCheck2 21 | 22 | 23 | main :: IO () 24 | main = defaultMainWithOpts 25 | [ testProperty "fmap" prop_fmap 26 | , testProperty "(<$)" prop_constmap 27 | , testProperty "foldr" prop_foldr 28 | , testProperty "foldr1" prop_foldr1 29 | , testProperty "foldl" prop_foldl 30 | , testProperty "foldl1" prop_foldl1 31 | , testProperty "(==)" prop_equals 32 | , testProperty "compare" prop_compare 33 | , testProperty "mappend" prop_mappend 34 | , testProperty "singleton" prop_singleton 35 | , testProperty "(<|)" prop_cons 36 | , testProperty "(|>)" prop_snoc 37 | , testProperty "(><)" prop_append 38 | , testProperty "fromList" prop_fromList 39 | , testProperty "replicate" prop_replicate 40 | , testProperty "replicateA" prop_replicateA 41 | , testProperty "replicateM" prop_replicateM 42 | , testProperty "iterateN" prop_iterateN 43 | , testProperty "unfoldr" prop_unfoldr 44 | , testProperty "unfoldl" prop_unfoldl 45 | , testProperty "null" prop_null 46 | , testProperty "length" prop_length 47 | , testProperty "viewl" prop_viewl 48 | , testProperty "viewr" prop_viewr 49 | , testProperty "scanl" prop_scanl 50 | , testProperty "scanl1" prop_scanl1 51 | , testProperty "scanr" prop_scanr 52 | , testProperty "scanr1" prop_scanr1 53 | , testProperty "tails" prop_tails 54 | , testProperty "inits" prop_inits 55 | , testProperty "takeWhileL" prop_takeWhileL 56 | , testProperty "takeWhileR" prop_takeWhileR 57 | , testProperty "dropWhileL" prop_dropWhileL 58 | , testProperty "dropWhileR" prop_dropWhileR 59 | , testProperty "spanl" prop_spanl 60 | , testProperty "spanr" prop_spanr 61 | , testProperty "breakl" prop_breakl 62 | , testProperty "breakr" prop_breakr 63 | , testProperty "partition" prop_partition 64 | , testProperty "filter" prop_filter 65 | , testProperty "sort" prop_sort 66 | , testProperty "sortBy" prop_sortBy 67 | , testProperty "unstableSort" prop_unstableSort 68 | , testProperty "unstableSortBy" prop_unstableSortBy 69 | , testProperty "index" prop_index 70 | , testProperty "adjust" prop_adjust 71 | , testProperty "update" prop_update 72 | , testProperty "take" prop_take 73 | , testProperty "drop" prop_drop 74 | , testProperty "splitAt" prop_splitAt 75 | , testProperty "elemIndexL" prop_elemIndexL 76 | , testProperty "elemIndicesL" prop_elemIndicesL 77 | , testProperty "elemIndexR" prop_elemIndexR 78 | , testProperty "elemIndicesR" prop_elemIndicesR 79 | , testProperty "findIndexL" prop_findIndexL 80 | , testProperty "findIndicesL" prop_findIndicesL 81 | , testProperty "findIndexR" prop_findIndexR 82 | , testProperty "findIndicesR" prop_findIndicesR 83 | , testProperty "foldlWithIndex" prop_foldlWithIndex 84 | , testProperty "foldrWithIndex" prop_foldrWithIndex 85 | , testProperty "mapWithIndex" prop_mapWithIndex 86 | , testProperty "reverse" prop_reverse 87 | , testProperty "zip" prop_zip 88 | , testProperty "zipWith" prop_zipWith 89 | , testProperty "zip3" prop_zip3 90 | , testProperty "zipWith3" prop_zipWith3 91 | , testProperty "zip4" prop_zip4 92 | , testProperty "zipWith4" prop_zipWith4 93 | ] opts 94 | 95 | where 96 | opts = mempty { ropt_test_options = Just $ mempty { topt_maximum_generated_tests = Just 500 97 | , topt_maximum_unsuitable_generated_tests = Just 500 98 | } 99 | } 100 | 101 | ------------------------------------------------------------------------ 102 | -- Arbitrary 103 | ------------------------------------------------------------------------ 104 | 105 | instance Arbitrary a => Arbitrary (Seq a) where 106 | arbitrary = Seq <$> arbitrary 107 | shrink (Seq x) = map Seq (shrink x) 108 | 109 | instance Arbitrary a => Arbitrary (Elem a) where 110 | arbitrary = Elem <$> arbitrary 111 | 112 | instance (Arbitrary a, Sized a) => Arbitrary (FingerTree a) where 113 | arbitrary = sized arb 114 | where 115 | arb :: (Arbitrary a, Sized a) => Int -> Gen (FingerTree a) 116 | arb 0 = return Empty 117 | arb 1 = Single <$> arbitrary 118 | arb n = deep <$> arbitrary <*> arb (n `div` 2) <*> arbitrary 119 | 120 | shrink (Deep _ (One a) Empty (One b)) = [Single a, Single b] 121 | shrink (Deep _ pr m sf) = 122 | [deep pr' m sf | pr' <- shrink pr] ++ 123 | [deep pr m' sf | m' <- shrink m] ++ 124 | [deep pr m sf' | sf' <- shrink sf] 125 | shrink (Single x) = map Single (shrink x) 126 | shrink Empty = [] 127 | 128 | instance (Arbitrary a, Sized a) => Arbitrary (Node a) where 129 | arbitrary = oneof [ 130 | node2 <$> arbitrary <*> arbitrary, 131 | node3 <$> arbitrary <*> arbitrary <*> arbitrary] 132 | 133 | shrink (Node2 _ a b) = 134 | [node2 a' b | a' <- shrink a] ++ 135 | [node2 a b' | b' <- shrink b] 136 | shrink (Node3 _ a b c) = 137 | [node2 a b, node2 a c, node2 b c] ++ 138 | [node3 a' b c | a' <- shrink a] ++ 139 | [node3 a b' c | b' <- shrink b] ++ 140 | [node3 a b c' | c' <- shrink c] 141 | 142 | instance Arbitrary a => Arbitrary (Digit a) where 143 | arbitrary = oneof [ 144 | One <$> arbitrary, 145 | Two <$> arbitrary <*> arbitrary, 146 | Three <$> arbitrary <*> arbitrary <*> arbitrary, 147 | Four <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary] 148 | 149 | shrink (One a) = map One (shrink a) 150 | shrink (Two a b) = [One a, One b] 151 | shrink (Three a b c) = [Two a b, Two a c, Two b c] 152 | shrink (Four a b c d) = [Three a b c, Three a b d, Three a c d, Three b c d] 153 | 154 | ------------------------------------------------------------------------ 155 | -- Valid trees 156 | ------------------------------------------------------------------------ 157 | 158 | class Valid a where 159 | valid :: a -> Bool 160 | 161 | instance Valid (Elem a) where 162 | valid _ = True 163 | 164 | instance Valid (Seq a) where 165 | valid (Seq xs) = valid xs 166 | 167 | instance (Sized a, Valid a) => Valid (FingerTree a) where 168 | valid Empty = True 169 | valid (Single x) = valid x 170 | valid (Deep s pr m sf) = 171 | s == size pr + size m + size sf && valid pr && valid m && valid sf 172 | 173 | instance (Sized a, Valid a) => Valid (Node a) where 174 | valid node = size node == sum (fmap size node) && all valid node 175 | 176 | instance Valid a => Valid (Digit a) where 177 | valid = all valid 178 | 179 | {-------------------------------------------------------------------- 180 | The general plan is to compare each function with a list equivalent. 181 | Each operation should produce a valid tree representing the same 182 | sequence as produced by its list counterpart on corresponding inputs. 183 | (The list versions are often lazier, but these properties ignore 184 | strictness.) 185 | --------------------------------------------------------------------} 186 | 187 | -- utilities for partial conversions 188 | 189 | infix 4 ~= 190 | 191 | (~=) :: Eq a => Maybe a -> a -> Bool 192 | (~=) = maybe (const False) (==) 193 | 194 | -- Partial conversion of an output sequence to a list. 195 | toList' :: Seq a -> Maybe [a] 196 | toList' xs 197 | | valid xs = Just (toList xs) 198 | | otherwise = Nothing 199 | 200 | toListList' :: Seq (Seq a) -> Maybe [[a]] 201 | toListList' xss = toList' xss >>= mapM toList' 202 | 203 | toListPair' :: (Seq a, Seq b) -> Maybe ([a], [b]) 204 | toListPair' (xs, ys) = (,) <$> toList' xs <*> toList' ys 205 | 206 | -- instances 207 | 208 | prop_fmap :: Seq Int -> Bool 209 | prop_fmap xs = 210 | toList' (fmap f xs) ~= map f (toList xs) 211 | where f = (+100) 212 | 213 | prop_constmap :: A -> Seq A -> Bool 214 | prop_constmap x xs = 215 | toList' (x <$ xs) ~= map (const x) (toList xs) 216 | 217 | prop_foldr :: Seq A -> Bool 218 | prop_foldr xs = 219 | foldr f z xs == Prelude.foldr f z (toList xs) 220 | where 221 | f = (:) 222 | z = [] 223 | 224 | prop_foldr1 :: Seq Int -> Property 225 | prop_foldr1 xs = 226 | not (null xs) ==> foldr1 f xs == Data.List.foldr1 f (toList xs) 227 | where f = (-) 228 | 229 | prop_foldl :: Seq A -> Bool 230 | prop_foldl xs = 231 | foldl f z xs == Prelude.foldl f z (toList xs) 232 | where 233 | f = flip (:) 234 | z = [] 235 | 236 | prop_foldl1 :: Seq Int -> Property 237 | prop_foldl1 xs = 238 | not (null xs) ==> foldl1 f xs == Data.List.foldl1 f (toList xs) 239 | where f = (-) 240 | 241 | prop_equals :: Seq OrdA -> Seq OrdA -> Bool 242 | prop_equals xs ys = 243 | (xs == ys) == (toList xs == toList ys) 244 | 245 | prop_compare :: Seq OrdA -> Seq OrdA -> Bool 246 | prop_compare xs ys = 247 | compare xs ys == compare (toList xs) (toList ys) 248 | 249 | prop_mappend :: Seq A -> Seq A -> Bool 250 | prop_mappend xs ys = 251 | toList' (mappend xs ys) ~= toList xs ++ toList ys 252 | 253 | -- * Construction 254 | 255 | {- 256 | toList' empty ~= [] 257 | -} 258 | 259 | prop_singleton :: A -> Bool 260 | prop_singleton x = 261 | toList' (singleton x) ~= [x] 262 | 263 | prop_cons :: A -> Seq A -> Bool 264 | prop_cons x xs = 265 | toList' (x <| xs) ~= x : toList xs 266 | 267 | prop_snoc :: Seq A -> A -> Bool 268 | prop_snoc xs x = 269 | toList' (xs |> x) ~= toList xs ++ [x] 270 | 271 | prop_append :: Seq A -> Seq A -> Bool 272 | prop_append xs ys = 273 | toList' (xs >< ys) ~= toList xs ++ toList ys 274 | 275 | prop_fromList :: [A] -> Bool 276 | prop_fromList xs = 277 | toList' (fromList xs) ~= xs 278 | 279 | -- ** Repetition 280 | 281 | prop_replicate :: NonNegative Int -> A -> Bool 282 | prop_replicate (NonNegative m) x = 283 | toList' (replicate n x) ~= Prelude.replicate n x 284 | where n = m `mod` 10000 285 | 286 | prop_replicateA :: NonNegative Int -> Bool 287 | prop_replicateA (NonNegative m) = 288 | traverse toList' (replicateA n a) ~= sequenceA (Prelude.replicate n a) 289 | where 290 | n = m `mod` 10000 291 | a = Action 1 0 :: M Int 292 | 293 | prop_replicateM :: NonNegative Int -> Bool 294 | prop_replicateM (NonNegative m) = 295 | traverse toList' (replicateM n a) ~= sequence (Prelude.replicate n a) 296 | where 297 | n = m `mod` 10000 298 | a = Action 1 0 :: M Int 299 | 300 | -- ** Iterative construction 301 | 302 | prop_iterateN :: NonNegative Int -> Int -> Bool 303 | prop_iterateN (NonNegative m) x = 304 | toList' (iterateN n f x) ~= Prelude.take n (Prelude.iterate f x) 305 | where 306 | n = m `mod` 10000 307 | f = (+1) 308 | 309 | prop_unfoldr :: [A] -> Bool 310 | prop_unfoldr z = 311 | toList' (unfoldr f z) ~= Data.List.unfoldr f z 312 | where 313 | f [] = Nothing 314 | f (x:xs) = Just (x, xs) 315 | 316 | prop_unfoldl :: [A] -> Bool 317 | prop_unfoldl z = 318 | toList' (unfoldl f z) ~= Data.List.reverse (Data.List.unfoldr (fmap swap . f) z) 319 | where 320 | f [] = Nothing 321 | f (x:xs) = Just (xs, x) 322 | swap (x,y) = (y,x) 323 | 324 | -- * Deconstruction 325 | 326 | -- ** Queries 327 | 328 | prop_null :: Seq A -> Bool 329 | prop_null xs = 330 | null xs == Prelude.null (toList xs) 331 | 332 | prop_length :: Seq A -> Bool 333 | prop_length xs = 334 | length xs == Prelude.length (toList xs) 335 | 336 | -- ** Views 337 | 338 | prop_viewl :: Seq A -> Bool 339 | prop_viewl xs = 340 | case viewl xs of 341 | EmptyL -> Prelude.null (toList xs) 342 | x :< xs' -> valid xs' && toList xs == x : toList xs' 343 | 344 | prop_viewr :: Seq A -> Bool 345 | prop_viewr xs = 346 | case viewr xs of 347 | EmptyR -> Prelude.null (toList xs) 348 | xs' :> x -> valid xs' && toList xs == toList xs' ++ [x] 349 | 350 | -- * Scans 351 | 352 | prop_scanl :: [A] -> Seq A -> Bool 353 | prop_scanl z xs = 354 | toList' (scanl f z xs) ~= Data.List.scanl f z (toList xs) 355 | where f = flip (:) 356 | 357 | prop_scanl1 :: Seq Int -> Property 358 | prop_scanl1 xs = 359 | not (null xs) ==> toList' (scanl1 f xs) ~= Data.List.scanl1 f (toList xs) 360 | where f = (-) 361 | 362 | prop_scanr :: [A] -> Seq A -> Bool 363 | prop_scanr z xs = 364 | toList' (scanr f z xs) ~= Data.List.scanr f z (toList xs) 365 | where f = (:) 366 | 367 | prop_scanr1 :: Seq Int -> Property 368 | prop_scanr1 xs = 369 | not (null xs) ==> toList' (scanr1 f xs) ~= Data.List.scanr1 f (toList xs) 370 | where f = (-) 371 | 372 | -- * Sublists 373 | 374 | prop_tails :: Seq A -> Bool 375 | prop_tails xs = 376 | toListList' (tails xs) ~= Data.List.tails (toList xs) 377 | 378 | prop_inits :: Seq A -> Bool 379 | prop_inits xs = 380 | toListList' (inits xs) ~= Data.List.inits (toList xs) 381 | 382 | -- ** Sequential searches 383 | -- We use predicates with varying density. 384 | 385 | prop_takeWhileL :: Positive Int -> Seq Int -> Bool 386 | prop_takeWhileL (Positive n) xs = 387 | toList' (takeWhileL p xs) ~= Prelude.takeWhile p (toList xs) 388 | where p x = x `mod` n == 0 389 | 390 | prop_takeWhileR :: Positive Int -> Seq Int -> Bool 391 | prop_takeWhileR (Positive n) xs = 392 | toList' (takeWhileR p xs) ~= Prelude.reverse (Prelude.takeWhile p (Prelude.reverse (toList xs))) 393 | where p x = x `mod` n == 0 394 | 395 | prop_dropWhileL :: Positive Int -> Seq Int -> Bool 396 | prop_dropWhileL (Positive n) xs = 397 | toList' (dropWhileL p xs) ~= Prelude.dropWhile p (toList xs) 398 | where p x = x `mod` n == 0 399 | 400 | prop_dropWhileR :: Positive Int -> Seq Int -> Bool 401 | prop_dropWhileR (Positive n) xs = 402 | toList' (dropWhileR p xs) ~= Prelude.reverse (Prelude.dropWhile p (Prelude.reverse (toList xs))) 403 | where p x = x `mod` n == 0 404 | 405 | prop_spanl :: Positive Int -> Seq Int -> Bool 406 | prop_spanl (Positive n) xs = 407 | toListPair' (spanl p xs) ~= Data.List.span p (toList xs) 408 | where p x = x `mod` n == 0 409 | 410 | prop_spanr :: Positive Int -> Seq Int -> Bool 411 | prop_spanr (Positive n) xs = 412 | toListPair' (spanr p xs) ~= (Prelude.reverse *** Prelude.reverse) (Data.List.span p (Prelude.reverse (toList xs))) 413 | where p x = x `mod` n == 0 414 | 415 | prop_breakl :: Positive Int -> Seq Int -> Bool 416 | prop_breakl (Positive n) xs = 417 | toListPair' (breakl p xs) ~= Data.List.break p (toList xs) 418 | where p x = x `mod` n == 0 419 | 420 | prop_breakr :: Positive Int -> Seq Int -> Bool 421 | prop_breakr (Positive n) xs = 422 | toListPair' (breakr p xs) ~= (Prelude.reverse *** Prelude.reverse) (Data.List.break p (Prelude.reverse (toList xs))) 423 | where p x = x `mod` n == 0 424 | 425 | prop_partition :: Positive Int -> Seq Int -> Bool 426 | prop_partition (Positive n) xs = 427 | toListPair' (partition p xs) ~= Data.List.partition p (toList xs) 428 | where p x = x `mod` n == 0 429 | 430 | prop_filter :: Positive Int -> Seq Int -> Bool 431 | prop_filter (Positive n) xs = 432 | toList' (filter p xs) ~= Prelude.filter p (toList xs) 433 | where p x = x `mod` n == 0 434 | 435 | -- * Sorting 436 | 437 | prop_sort :: Seq OrdA -> Bool 438 | prop_sort xs = 439 | toList' (sort xs) ~= Data.List.sort (toList xs) 440 | 441 | prop_sortBy :: Seq (OrdA, B) -> Bool 442 | prop_sortBy xs = 443 | toList' (sortBy f xs) ~= Data.List.sortBy f (toList xs) 444 | where f (x1, _) (x2, _) = compare x1 x2 445 | 446 | prop_unstableSort :: Seq OrdA -> Bool 447 | prop_unstableSort xs = 448 | toList' (unstableSort xs) ~= Data.List.sort (toList xs) 449 | 450 | prop_unstableSortBy :: Seq OrdA -> Bool 451 | prop_unstableSortBy xs = 452 | toList' (unstableSortBy compare xs) ~= Data.List.sort (toList xs) 453 | 454 | -- * Indexing 455 | 456 | prop_index :: Seq A -> Property 457 | prop_index xs = 458 | not (null xs) ==> forAll (choose (0, length xs-1)) $ \ i -> 459 | index xs i == toList xs !! i 460 | 461 | prop_adjust :: Int -> Int -> Seq Int -> Bool 462 | prop_adjust n i xs = 463 | toList' (adjust f i xs) ~= adjustList f i (toList xs) 464 | where f = (+n) 465 | 466 | prop_update :: Int -> A -> Seq A -> Bool 467 | prop_update i x xs = 468 | toList' (update i x xs) ~= adjustList (const x) i (toList xs) 469 | 470 | prop_take :: Int -> Seq A -> Bool 471 | prop_take n xs = 472 | toList' (take n xs) ~= Prelude.take n (toList xs) 473 | 474 | prop_drop :: Int -> Seq A -> Bool 475 | prop_drop n xs = 476 | toList' (drop n xs) ~= Prelude.drop n (toList xs) 477 | 478 | prop_splitAt :: Int -> Seq A -> Bool 479 | prop_splitAt n xs = 480 | toListPair' (splitAt n xs) ~= Prelude.splitAt n (toList xs) 481 | 482 | adjustList :: (a -> a) -> Int -> [a] -> [a] 483 | adjustList f i xs = 484 | [if j == i then f x else x | (j, x) <- Prelude.zip [0..] xs] 485 | 486 | -- ** Indexing with predicates 487 | -- The elem* tests have poor coverage, but for find* we use predicates 488 | -- of varying density. 489 | 490 | prop_elemIndexL :: A -> Seq A -> Bool 491 | prop_elemIndexL x xs = 492 | elemIndexL x xs == Data.List.elemIndex x (toList xs) 493 | 494 | prop_elemIndicesL :: A -> Seq A -> Bool 495 | prop_elemIndicesL x xs = 496 | elemIndicesL x xs == Data.List.elemIndices x (toList xs) 497 | 498 | prop_elemIndexR :: A -> Seq A -> Bool 499 | prop_elemIndexR x xs = 500 | elemIndexR x xs == listToMaybe (Prelude.reverse (Data.List.elemIndices x (toList xs))) 501 | 502 | prop_elemIndicesR :: A -> Seq A -> Bool 503 | prop_elemIndicesR x xs = 504 | elemIndicesR x xs == Prelude.reverse (Data.List.elemIndices x (toList xs)) 505 | 506 | prop_findIndexL :: Positive Int -> Seq Int -> Bool 507 | prop_findIndexL (Positive n) xs = 508 | findIndexL p xs == Data.List.findIndex p (toList xs) 509 | where p x = x `mod` n == 0 510 | 511 | prop_findIndicesL :: Positive Int -> Seq Int -> Bool 512 | prop_findIndicesL (Positive n) xs = 513 | findIndicesL p xs == Data.List.findIndices p (toList xs) 514 | where p x = x `mod` n == 0 515 | 516 | prop_findIndexR :: Positive Int -> Seq Int -> Bool 517 | prop_findIndexR (Positive n) xs = 518 | findIndexR p xs == listToMaybe (Prelude.reverse (Data.List.findIndices p (toList xs))) 519 | where p x = x `mod` n == 0 520 | 521 | prop_findIndicesR :: Positive Int -> Seq Int -> Bool 522 | prop_findIndicesR (Positive n) xs = 523 | findIndicesR p xs == Prelude.reverse (Data.List.findIndices p (toList xs)) 524 | where p x = x `mod` n == 0 525 | 526 | -- * Folds 527 | 528 | prop_foldlWithIndex :: [(Int, A)] -> Seq A -> Bool 529 | prop_foldlWithIndex z xs = 530 | foldlWithIndex f z xs == Data.List.foldl (uncurry . f) z (Data.List.zip [0..] (toList xs)) 531 | where f ys n y = (n,y):ys 532 | 533 | prop_foldrWithIndex :: [(Int, A)] -> Seq A -> Bool 534 | prop_foldrWithIndex z xs = 535 | foldrWithIndex f z xs == Data.List.foldr (uncurry f) z (Data.List.zip [0..] (toList xs)) 536 | where f n y ys = (n,y):ys 537 | 538 | -- * Transformations 539 | 540 | prop_mapWithIndex :: Seq A -> Bool 541 | prop_mapWithIndex xs = 542 | toList' (mapWithIndex f xs) ~= map (uncurry f) (Data.List.zip [0..] (toList xs)) 543 | where f = (,) 544 | 545 | prop_reverse :: Seq A -> Bool 546 | prop_reverse xs = 547 | toList' (reverse xs) ~= Prelude.reverse (toList xs) 548 | 549 | -- ** Zips 550 | 551 | prop_zip :: Seq A -> Seq B -> Bool 552 | prop_zip xs ys = 553 | toList' (zip xs ys) ~= Prelude.zip (toList xs) (toList ys) 554 | 555 | prop_zipWith :: Seq A -> Seq B -> Bool 556 | prop_zipWith xs ys = 557 | toList' (zipWith f xs ys) ~= Prelude.zipWith f (toList xs) (toList ys) 558 | where f = (,) 559 | 560 | prop_zip3 :: Seq A -> Seq B -> Seq C -> Bool 561 | prop_zip3 xs ys zs = 562 | toList' (zip3 xs ys zs) ~= Prelude.zip3 (toList xs) (toList ys) (toList zs) 563 | 564 | prop_zipWith3 :: Seq A -> Seq B -> Seq C -> Bool 565 | prop_zipWith3 xs ys zs = 566 | toList' (zipWith3 f xs ys zs) ~= Prelude.zipWith3 f (toList xs) (toList ys) (toList zs) 567 | where f = (,,) 568 | 569 | prop_zip4 :: Seq A -> Seq B -> Seq C -> Seq Int -> Bool 570 | prop_zip4 xs ys zs ts = 571 | toList' (zip4 xs ys zs ts) ~= Data.List.zip4 (toList xs) (toList ys) (toList zs) (toList ts) 572 | 573 | prop_zipWith4 :: Seq A -> Seq B -> Seq C -> Seq Int -> Bool 574 | prop_zipWith4 xs ys zs ts = 575 | toList' (zipWith4 f xs ys zs ts) ~= Data.List.zipWith4 f (toList xs) (toList ys) (toList zs) (toList ts) 576 | where f = (,,,) 577 | 578 | -- Simple test monad 579 | 580 | data M a = Action Int a 581 | deriving (Eq, Show) 582 | 583 | instance Functor M where 584 | fmap f (Action n x) = Action n (f x) 585 | 586 | instance Applicative M where 587 | pure x = Action 0 x 588 | Action m f <*> Action n x = Action (m+n) (f x) 589 | 590 | instance Monad M where 591 | return x = Action 0 x 592 | Action m x >>= f = let Action n y = f x in Action (m+n) y 593 | 594 | instance Foldable M where 595 | foldMap f (Action _ x) = f x 596 | 597 | instance Traversable M where 598 | traverse f (Action n x) = Action n <$> f x 599 | -------------------------------------------------------------------------------- /Data/IntMap/Strict.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | #if !defined(TESTING) && __GLASGOW_HASKELL__ >= 703 3 | {-# LANGUAGE Trustworthy #-} 4 | #endif 5 | ----------------------------------------------------------------------------- 6 | -- | 7 | -- Module : Data.IntMap.Strict 8 | -- Copyright : (c) Daan Leijen 2002 9 | -- (c) Andriy Palamarchuk 2008 10 | -- License : BSD-style 11 | -- Maintainer : libraries@haskell.org 12 | -- Stability : provisional 13 | -- Portability : portable 14 | -- 15 | -- An efficient implementation of maps from integer keys to values 16 | -- (dictionaries). 17 | -- 18 | -- API of this module is strict in both the keys and the values. 19 | -- If you need value-lazy maps, use 'Data.IntMap.Lazy' instead. 20 | -- The 'IntMap' type itself is shared between the lazy and strict modules, 21 | -- meaning that the same 'IntMap' value can be passed to functions in 22 | -- both modules (although that is rarely needed). 23 | -- 24 | -- These modules are intended to be imported qualified, to avoid name 25 | -- clashes with Prelude functions, e.g. 26 | -- 27 | -- > import Data.IntMap.Strict (IntMap) 28 | -- > import qualified Data.IntMap.Strict as IntMap 29 | -- 30 | -- The implementation is based on /big-endian patricia trees/. This data 31 | -- structure performs especially well on binary operations like 'union' 32 | -- and 'intersection'. However, my benchmarks show that it is also 33 | -- (much) faster on insertions and deletions when compared to a generic 34 | -- size-balanced map implementation (see "Data.Map"). 35 | -- 36 | -- * Chris Okasaki and Andy Gill, \"/Fast Mergeable Integer Maps/\", 37 | -- Workshop on ML, September 1998, pages 77-86, 38 | -- 39 | -- 40 | -- * D.R. Morrison, \"/PATRICIA -- Practical Algorithm To Retrieve 41 | -- Information Coded In Alphanumeric/\", Journal of the ACM, 15(4), 42 | -- October 1968, pages 514-534. 43 | -- 44 | -- Operation comments contain the operation time complexity in 45 | -- the Big-O notation . 46 | -- Many operations have a worst-case complexity of /O(min(n,W))/. 47 | -- This means that the operation can become linear in the number of 48 | -- elements with a maximum of /W/ -- the number of bits in an 'Int' 49 | -- (32 or 64). 50 | -- 51 | -- Be aware that the 'Functor', 'Traversable' and 'Data' instances 52 | -- are the same as for the 'Data.IntMap.Lazy' module, so if they are used 53 | -- on strict maps, the resulting maps will be lazy. 54 | ----------------------------------------------------------------------------- 55 | 56 | module Data.IntMap.Strict ( 57 | -- * Strictness properties 58 | -- $strictness 59 | 60 | -- * Map type 61 | #if !defined(TESTING) 62 | IntMap, Key -- instance Eq,Show 63 | #else 64 | IntMap(..), Key -- instance Eq,Show 65 | #endif 66 | 67 | -- * Operators 68 | , (!), (\\) 69 | 70 | -- * Query 71 | , null 72 | , size 73 | , member 74 | , notMember 75 | , lookup 76 | , findWithDefault 77 | 78 | -- * Construction 79 | , empty 80 | , singleton 81 | 82 | -- ** Insertion 83 | , insert 84 | , insertWith 85 | , insertWithKey 86 | , insertLookupWithKey 87 | 88 | -- ** Delete\/Update 89 | , delete 90 | , adjust 91 | , adjustWithKey 92 | , update 93 | , updateWithKey 94 | , updateLookupWithKey 95 | , alter 96 | 97 | -- * Combine 98 | 99 | -- ** Union 100 | , union 101 | , unionWith 102 | , unionWithKey 103 | , unions 104 | , unionsWith 105 | 106 | -- ** Difference 107 | , difference 108 | , differenceWith 109 | , differenceWithKey 110 | 111 | -- ** Intersection 112 | , intersection 113 | , intersectionWith 114 | , intersectionWithKey 115 | 116 | -- * Traversal 117 | -- ** Map 118 | , map 119 | , mapWithKey 120 | , traverseWithKey 121 | , mapAccum 122 | , mapAccumWithKey 123 | , mapAccumRWithKey 124 | , mapKeys 125 | , mapKeysWith 126 | , mapKeysMonotonic 127 | 128 | -- * Folds 129 | , foldr 130 | , foldl 131 | , foldrWithKey 132 | , foldlWithKey 133 | -- ** Strict folds 134 | , foldr' 135 | , foldl' 136 | , foldrWithKey' 137 | , foldlWithKey' 138 | 139 | -- * Conversion 140 | , elems 141 | , keys 142 | , keysSet 143 | , assocs 144 | 145 | -- ** Lists 146 | , toList 147 | , fromList 148 | , fromListWith 149 | , fromListWithKey 150 | 151 | -- ** Ordered lists 152 | , toAscList 153 | , toDescList 154 | , fromAscList 155 | , fromAscListWith 156 | , fromAscListWithKey 157 | , fromDistinctAscList 158 | 159 | -- * Filter 160 | , filter 161 | , filterWithKey 162 | , partition 163 | , partitionWithKey 164 | 165 | , mapMaybe 166 | , mapMaybeWithKey 167 | , mapEither 168 | , mapEitherWithKey 169 | 170 | , split 171 | , splitLookup 172 | 173 | -- * Submap 174 | , isSubmapOf, isSubmapOfBy 175 | , isProperSubmapOf, isProperSubmapOfBy 176 | 177 | -- * Min\/Max 178 | , findMin 179 | , findMax 180 | , deleteMin 181 | , deleteMax 182 | , deleteFindMin 183 | , deleteFindMax 184 | , updateMin 185 | , updateMax 186 | , updateMinWithKey 187 | , updateMaxWithKey 188 | , minView 189 | , maxView 190 | , minViewWithKey 191 | , maxViewWithKey 192 | 193 | -- * Debugging 194 | , showTree 195 | , showTreeWith 196 | ) where 197 | 198 | import Prelude hiding (lookup,map,filter,foldr,foldl,null) 199 | 200 | import Data.IntMap.Base hiding 201 | ( findWithDefault 202 | , singleton 203 | , insert 204 | , insertWith 205 | , insertWithKey 206 | , insertLookupWithKey 207 | , adjust 208 | , adjustWithKey 209 | , update 210 | , updateWithKey 211 | , updateLookupWithKey 212 | , alter 213 | , unionsWith 214 | , unionWith 215 | , unionWithKey 216 | , differenceWith 217 | , differenceWithKey 218 | , intersectionWith 219 | , intersectionWithKey 220 | , updateMinWithKey 221 | , updateMaxWithKey 222 | , updateMax 223 | , updateMin 224 | , map 225 | , mapWithKey 226 | , mapAccum 227 | , mapAccumWithKey 228 | , mapAccumRWithKey 229 | , mapKeysWith 230 | , mapMaybe 231 | , mapMaybeWithKey 232 | , mapEither 233 | , mapEitherWithKey 234 | , fromList 235 | , fromListWith 236 | , fromListWithKey 237 | , fromAscList 238 | , fromAscListWith 239 | , fromAscListWithKey 240 | , fromDistinctAscList 241 | ) 242 | import Data.StrictPair 243 | 244 | -- $strictness 245 | -- 246 | -- This module satisfies the following strictness properties: 247 | -- 248 | -- 1. Key and value arguments are evaluated to WHNF; 249 | -- 250 | -- 2. Keys and values are evaluated to WHNF before they are stored in 251 | -- the map. 252 | -- 253 | -- Here are some examples that illustrate the first property: 254 | -- 255 | -- > insertWith (\ new old -> old) k undefined m == undefined 256 | -- > delete undefined m == undefined 257 | -- 258 | -- Here are some examples that illustrate the second property: 259 | -- 260 | -- > map (\ v -> undefined) m == undefined -- m is not empty 261 | -- > mapKeys (\ k -> undefined) m == undefined -- m is not empty 262 | 263 | {-------------------------------------------------------------------- 264 | Query 265 | --------------------------------------------------------------------} 266 | 267 | -- | /O(min(n,W))/. The expression @('findWithDefault' def k map)@ 268 | -- returns the value at key @k@ or returns @def@ when the key is not an 269 | -- element of the map. 270 | -- 271 | -- > findWithDefault 'x' 1 (fromList [(5,'a'), (3,'b')]) == 'x' 272 | -- > findWithDefault 'x' 5 (fromList [(5,'a'), (3,'b')]) == 'a' 273 | 274 | findWithDefault :: a -> Key -> IntMap a -> a 275 | findWithDefault def k m 276 | = def `seq` case lookup k m of 277 | Nothing -> def 278 | Just x -> x 279 | 280 | {-------------------------------------------------------------------- 281 | Construction 282 | --------------------------------------------------------------------} 283 | -- | /O(1)/. A map of one element. 284 | -- 285 | -- > singleton 1 'a' == fromList [(1, 'a')] 286 | -- > size (singleton 1 'a') == 1 287 | 288 | singleton :: Key -> a -> IntMap a 289 | singleton k x 290 | = x `seq` Tip k x 291 | 292 | {-------------------------------------------------------------------- 293 | Insert 294 | --------------------------------------------------------------------} 295 | -- | /O(min(n,W))/. Insert a new key\/value pair in the map. 296 | -- If the key is already present in the map, the associated value is 297 | -- replaced with the supplied value, i.e. 'insert' is equivalent to 298 | -- @'insertWith' 'const'@. 299 | -- 300 | -- > insert 5 'x' (fromList [(5,'a'), (3,'b')]) == fromList [(3, 'b'), (5, 'x')] 301 | -- > insert 7 'x' (fromList [(5,'a'), (3,'b')]) == fromList [(3, 'b'), (5, 'a'), (7, 'x')] 302 | -- > insert 5 'x' empty == singleton 5 'x' 303 | 304 | insert :: Key -> a -> IntMap a -> IntMap a 305 | insert k x t = k `seq` x `seq` 306 | case t of 307 | Bin p m l r 308 | | nomatch k p m -> join k (Tip k x) p t 309 | | zero k m -> Bin p m (insert k x l) r 310 | | otherwise -> Bin p m l (insert k x r) 311 | Tip ky _ 312 | | k==ky -> Tip k x 313 | | otherwise -> join k (Tip k x) ky t 314 | Nil -> Tip k x 315 | 316 | -- right-biased insertion, used by 'union' 317 | -- | /O(min(n,W))/. Insert with a combining function. 318 | -- @'insertWith' f key value mp@ 319 | -- will insert the pair (key, value) into @mp@ if key does 320 | -- not exist in the map. If the key does exist, the function will 321 | -- insert @f new_value old_value@. 322 | -- 323 | -- > insertWith (++) 5 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "xxxa")] 324 | -- > insertWith (++) 7 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a"), (7, "xxx")] 325 | -- > insertWith (++) 5 "xxx" empty == singleton 5 "xxx" 326 | 327 | insertWith :: (a -> a -> a) -> Key -> a -> IntMap a -> IntMap a 328 | insertWith f k x t 329 | = insertWithKey (\_ x' y' -> f x' y') k x t 330 | 331 | -- | /O(min(n,W))/. Insert with a combining function. 332 | -- @'insertWithKey' f key value mp@ 333 | -- will insert the pair (key, value) into @mp@ if key does 334 | -- not exist in the map. If the key does exist, the function will 335 | -- insert @f key new_value old_value@. 336 | -- 337 | -- > let f key new_value old_value = (show key) ++ ":" ++ new_value ++ "|" ++ old_value 338 | -- > insertWithKey f 5 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "5:xxx|a")] 339 | -- > insertWithKey f 7 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a"), (7, "xxx")] 340 | -- > insertWithKey f 5 "xxx" empty == singleton 5 "xxx" 341 | -- 342 | -- If the key exists in the map, this function is lazy in @x@ but strict 343 | -- in the result of @f@. 344 | 345 | insertWithKey :: (Key -> a -> a -> a) -> Key -> a -> IntMap a -> IntMap a 346 | insertWithKey f k x t = k `seq` x `seq` 347 | case t of 348 | Bin p m l r 349 | | nomatch k p m -> join k (Tip k x) p t 350 | | zero k m -> Bin p m (insertWithKey f k x l) r 351 | | otherwise -> Bin p m l (insertWithKey f k x r) 352 | Tip ky y 353 | | k==ky -> Tip k $! f k x y 354 | | otherwise -> join k (Tip k x) ky t 355 | Nil -> Tip k x 356 | 357 | -- | /O(min(n,W))/. The expression (@'insertLookupWithKey' f k x map@) 358 | -- is a pair where the first element is equal to (@'lookup' k map@) 359 | -- and the second element equal to (@'insertWithKey' f k x map@). 360 | -- 361 | -- > let f key new_value old_value = (show key) ++ ":" ++ new_value ++ "|" ++ old_value 362 | -- > insertLookupWithKey f 5 "xxx" (fromList [(5,"a"), (3,"b")]) == (Just "a", fromList [(3, "b"), (5, "5:xxx|a")]) 363 | -- > insertLookupWithKey f 7 "xxx" (fromList [(5,"a"), (3,"b")]) == (Nothing, fromList [(3, "b"), (5, "a"), (7, "xxx")]) 364 | -- > insertLookupWithKey f 5 "xxx" empty == (Nothing, singleton 5 "xxx") 365 | -- 366 | -- This is how to define @insertLookup@ using @insertLookupWithKey@: 367 | -- 368 | -- > let insertLookup kx x t = insertLookupWithKey (\_ a _ -> a) kx x t 369 | -- > insertLookup 5 "x" (fromList [(5,"a"), (3,"b")]) == (Just "a", fromList [(3, "b"), (5, "x")]) 370 | -- > insertLookup 7 "x" (fromList [(5,"a"), (3,"b")]) == (Nothing, fromList [(3, "b"), (5, "a"), (7, "x")]) 371 | 372 | insertLookupWithKey :: (Key -> a -> a -> a) -> Key -> a -> IntMap a -> (Maybe a, IntMap a) 373 | insertLookupWithKey f k x t = k `seq` x `seq` 374 | case t of 375 | Bin p m l r 376 | | nomatch k p m -> Nothing `strictPair` join k (Tip k x) p t 377 | | zero k m -> let (found,l') = insertLookupWithKey f k x l in (found `strictPair` Bin p m l' r) 378 | | otherwise -> let (found,r') = insertLookupWithKey f k x r in (found `strictPair` Bin p m l r') 379 | Tip ky y 380 | | k==ky -> (Just y `strictPair` (Tip k $! f k x y)) 381 | | otherwise -> (Nothing `strictPair` join k (Tip k x) ky t) 382 | Nil -> Nothing `strictPair` Tip k x 383 | 384 | 385 | {-------------------------------------------------------------------- 386 | Deletion 387 | [delete] is the inlined version of [deleteWith (\k x -> Nothing)] 388 | --------------------------------------------------------------------} 389 | -- | /O(min(n,W))/. Adjust a value at a specific key. When the key is not 390 | -- a member of the map, the original map is returned. 391 | -- 392 | -- > adjust ("new " ++) 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "new a")] 393 | -- > adjust ("new " ++) 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")] 394 | -- > adjust ("new " ++) 7 empty == empty 395 | 396 | adjust :: (a -> a) -> Key -> IntMap a -> IntMap a 397 | adjust f k m 398 | = adjustWithKey (\_ x -> f x) k m 399 | 400 | -- | /O(min(n,W))/. Adjust a value at a specific key. When the key is not 401 | -- a member of the map, the original map is returned. 402 | -- 403 | -- > let f key x = (show key) ++ ":new " ++ x 404 | -- > adjustWithKey f 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "5:new a")] 405 | -- > adjustWithKey f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")] 406 | -- > adjustWithKey f 7 empty == empty 407 | 408 | adjustWithKey :: (Key -> a -> a) -> Key -> IntMap a -> IntMap a 409 | adjustWithKey f 410 | = updateWithKey (\k' x -> Just (f k' x)) 411 | 412 | -- | /O(min(n,W))/. The expression (@'update' f k map@) updates the value @x@ 413 | -- at @k@ (if it is in the map). If (@f x@) is 'Nothing', the element is 414 | -- deleted. If it is (@'Just' y@), the key @k@ is bound to the new value @y@. 415 | -- 416 | -- > let f x = if x == "a" then Just "new a" else Nothing 417 | -- > update f 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "new a")] 418 | -- > update f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")] 419 | -- > update f 3 (fromList [(5,"a"), (3,"b")]) == singleton 5 "a" 420 | 421 | update :: (a -> Maybe a) -> Key -> IntMap a -> IntMap a 422 | update f 423 | = updateWithKey (\_ x -> f x) 424 | 425 | -- | /O(min(n,W))/. The expression (@'update' f k map@) updates the value @x@ 426 | -- at @k@ (if it is in the map). If (@f k x@) is 'Nothing', the element is 427 | -- deleted. If it is (@'Just' y@), the key @k@ is bound to the new value @y@. 428 | -- 429 | -- > let f k x = if x == "a" then Just ((show k) ++ ":new a") else Nothing 430 | -- > updateWithKey f 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "5:new a")] 431 | -- > updateWithKey f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")] 432 | -- > updateWithKey f 3 (fromList [(5,"a"), (3,"b")]) == singleton 5 "a" 433 | 434 | updateWithKey :: (Key -> a -> Maybe a) -> Key -> IntMap a -> IntMap a 435 | updateWithKey f k t = k `seq` 436 | case t of 437 | Bin p m l r 438 | | nomatch k p m -> t 439 | | zero k m -> bin p m (updateWithKey f k l) r 440 | | otherwise -> bin p m l (updateWithKey f k r) 441 | Tip ky y 442 | | k==ky -> case f k y of 443 | Just y' -> y' `seq` Tip ky y' 444 | Nothing -> Nil 445 | | otherwise -> t 446 | Nil -> Nil 447 | 448 | -- | /O(min(n,W))/. Lookup and update. 449 | -- The function returns original value, if it is updated. 450 | -- This is different behavior than 'Data.Map.updateLookupWithKey'. 451 | -- Returns the original key value if the map entry is deleted. 452 | -- 453 | -- > let f k x = if x == "a" then Just ((show k) ++ ":new a") else Nothing 454 | -- > updateLookupWithKey f 5 (fromList [(5,"a"), (3,"b")]) == (Just "a", fromList [(3, "b"), (5, "5:new a")]) 455 | -- > updateLookupWithKey f 7 (fromList [(5,"a"), (3,"b")]) == (Nothing, fromList [(3, "b"), (5, "a")]) 456 | -- > updateLookupWithKey f 3 (fromList [(5,"a"), (3,"b")]) == (Just "b", singleton 5 "a") 457 | 458 | updateLookupWithKey :: (Key -> a -> Maybe a) -> Key -> IntMap a -> (Maybe a,IntMap a) 459 | updateLookupWithKey f k t = k `seq` 460 | case t of 461 | Bin p m l r 462 | | nomatch k p m -> (Nothing, t) 463 | | zero k m -> let (found,l') = updateLookupWithKey f k l in (found `strictPair` bin p m l' r) 464 | | otherwise -> let (found,r') = updateLookupWithKey f k r in (found `strictPair` bin p m l r') 465 | Tip ky y 466 | | k==ky -> case f k y of 467 | Just y' -> y' `seq` (Just y `strictPair` Tip ky y') 468 | Nothing -> (Just y, Nil) 469 | | otherwise -> (Nothing,t) 470 | Nil -> (Nothing,Nil) 471 | 472 | 473 | 474 | -- | /O(log n)/. The expression (@'alter' f k map@) alters the value @x@ at @k@, or absence thereof. 475 | -- 'alter' can be used to insert, delete, or update a value in an 'IntMap'. 476 | -- In short : @'lookup' k ('alter' f k m) = f ('lookup' k m)@. 477 | alter :: (Maybe a -> Maybe a) -> Key -> IntMap a -> IntMap a 478 | alter f k t = k `seq` 479 | case t of 480 | Bin p m l r 481 | | nomatch k p m -> case f Nothing of 482 | Nothing -> t 483 | Just x -> x `seq` join k (Tip k x) p t 484 | | zero k m -> bin p m (alter f k l) r 485 | | otherwise -> bin p m l (alter f k r) 486 | Tip ky y 487 | | k==ky -> case f (Just y) of 488 | Just x -> x `seq` Tip ky x 489 | Nothing -> Nil 490 | | otherwise -> case f Nothing of 491 | Just x -> x `seq` join k (Tip k x) ky t 492 | Nothing -> t 493 | Nil -> case f Nothing of 494 | Just x -> x `seq` Tip k x 495 | Nothing -> Nil 496 | 497 | 498 | {-------------------------------------------------------------------- 499 | Union 500 | --------------------------------------------------------------------} 501 | -- | The union of a list of maps, with a combining operation. 502 | -- 503 | -- > unionsWith (++) [(fromList [(5, "a"), (3, "b")]), (fromList [(5, "A"), (7, "C")]), (fromList [(5, "A3"), (3, "B3")])] 504 | -- > == fromList [(3, "bB3"), (5, "aAA3"), (7, "C")] 505 | 506 | unionsWith :: (a->a->a) -> [IntMap a] -> IntMap a 507 | unionsWith f ts 508 | = foldlStrict (unionWith f) empty ts 509 | 510 | -- | /O(n+m)/. The union with a combining function. 511 | -- 512 | -- > unionWith (++) (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == fromList [(3, "b"), (5, "aA"), (7, "C")] 513 | 514 | unionWith :: (a -> a -> a) -> IntMap a -> IntMap a -> IntMap a 515 | unionWith f m1 m2 516 | = unionWithKey (\_ x y -> f x y) m1 m2 517 | 518 | -- | /O(n+m)/. The union with a combining function. 519 | -- 520 | -- > let f key left_value right_value = (show key) ++ ":" ++ left_value ++ "|" ++ right_value 521 | -- > unionWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == fromList [(3, "b"), (5, "5:a|A"), (7, "C")] 522 | 523 | unionWithKey :: (Key -> a -> a -> a) -> IntMap a -> IntMap a -> IntMap a 524 | unionWithKey f t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2) 525 | | shorter m1 m2 = union1 526 | | shorter m2 m1 = union2 527 | | p1 == p2 = Bin p1 m1 (unionWithKey f l1 l2) (unionWithKey f r1 r2) 528 | | otherwise = join p1 t1 p2 t2 529 | where 530 | union1 | nomatch p2 p1 m1 = join p1 t1 p2 t2 531 | | zero p2 m1 = Bin p1 m1 (unionWithKey f l1 t2) r1 532 | | otherwise = Bin p1 m1 l1 (unionWithKey f r1 t2) 533 | 534 | union2 | nomatch p1 p2 m2 = join p1 t1 p2 t2 535 | | zero p1 m2 = Bin p2 m2 (unionWithKey f t1 l2) r2 536 | | otherwise = Bin p2 m2 l2 (unionWithKey f t1 r2) 537 | 538 | unionWithKey f (Tip k x) t = insertWithKey f k x t 539 | unionWithKey f t (Tip k x) = insertWithKey (\k' x' y' -> f k' y' x') k x t -- right bias 540 | unionWithKey _ Nil t = t 541 | unionWithKey _ t Nil = t 542 | 543 | {-------------------------------------------------------------------- 544 | Difference 545 | --------------------------------------------------------------------} 546 | 547 | -- | /O(n+m)/. Difference with a combining function. 548 | -- 549 | -- > let f al ar = if al == "b" then Just (al ++ ":" ++ ar) else Nothing 550 | -- > differenceWith f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (3, "B"), (7, "C")]) 551 | -- > == singleton 3 "b:B" 552 | 553 | differenceWith :: (a -> b -> Maybe a) -> IntMap a -> IntMap b -> IntMap a 554 | differenceWith f m1 m2 555 | = differenceWithKey (\_ x y -> f x y) m1 m2 556 | 557 | -- | /O(n+m)/. Difference with a combining function. When two equal keys are 558 | -- encountered, the combining function is applied to the key and both values. 559 | -- If it returns 'Nothing', the element is discarded (proper set difference). 560 | -- If it returns (@'Just' y@), the element is updated with a new value @y@. 561 | -- 562 | -- > let f k al ar = if al == "b" then Just ((show k) ++ ":" ++ al ++ "|" ++ ar) else Nothing 563 | -- > differenceWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (3, "B"), (10, "C")]) 564 | -- > == singleton 3 "3:b|B" 565 | 566 | differenceWithKey :: (Key -> a -> b -> Maybe a) -> IntMap a -> IntMap b -> IntMap a 567 | differenceWithKey f t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2) 568 | | shorter m1 m2 = difference1 569 | | shorter m2 m1 = difference2 570 | | p1 == p2 = bin p1 m1 (differenceWithKey f l1 l2) (differenceWithKey f r1 r2) 571 | | otherwise = t1 572 | where 573 | difference1 | nomatch p2 p1 m1 = t1 574 | | zero p2 m1 = bin p1 m1 (differenceWithKey f l1 t2) r1 575 | | otherwise = bin p1 m1 l1 (differenceWithKey f r1 t2) 576 | 577 | difference2 | nomatch p1 p2 m2 = t1 578 | | zero p1 m2 = differenceWithKey f t1 l2 579 | | otherwise = differenceWithKey f t1 r2 580 | 581 | differenceWithKey f t1@(Tip k x) t2 582 | = case lookup k t2 of 583 | Just y -> case f k x y of 584 | Just y' -> y' `seq` Tip k y' 585 | Nothing -> Nil 586 | Nothing -> t1 587 | 588 | differenceWithKey _ Nil _ = Nil 589 | differenceWithKey f t (Tip k y) = updateWithKey (\k' x -> f k' x y) k t 590 | differenceWithKey _ t Nil = t 591 | 592 | 593 | {-------------------------------------------------------------------- 594 | Intersection 595 | --------------------------------------------------------------------} 596 | 597 | -- | /O(n+m)/. The intersection with a combining function. 598 | -- 599 | -- > intersectionWith (++) (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 5 "aA" 600 | 601 | intersectionWith :: (a -> b -> c) -> IntMap a -> IntMap b -> IntMap c 602 | intersectionWith f m1 m2 603 | = intersectionWithKey (\_ x y -> f x y) m1 m2 604 | 605 | -- | /O(n+m)/. The intersection with a combining function. 606 | -- 607 | -- > let f k al ar = (show k) ++ ":" ++ al ++ "|" ++ ar 608 | -- > intersectionWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 5 "5:a|A" 609 | 610 | intersectionWithKey :: (Key -> a -> b -> c) -> IntMap a -> IntMap b -> IntMap c 611 | intersectionWithKey f t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2) 612 | | shorter m1 m2 = intersection1 613 | | shorter m2 m1 = intersection2 614 | | p1 == p2 = bin p1 m1 (intersectionWithKey f l1 l2) (intersectionWithKey f r1 r2) 615 | | otherwise = Nil 616 | where 617 | intersection1 | nomatch p2 p1 m1 = Nil 618 | | zero p2 m1 = intersectionWithKey f l1 t2 619 | | otherwise = intersectionWithKey f r1 t2 620 | 621 | intersection2 | nomatch p1 p2 m2 = Nil 622 | | zero p1 m2 = intersectionWithKey f t1 l2 623 | | otherwise = intersectionWithKey f t1 r2 624 | 625 | intersectionWithKey f (Tip k x) t2 626 | = case lookup k t2 of 627 | Just y -> Tip k $! f k x y 628 | Nothing -> Nil 629 | intersectionWithKey f t1 (Tip k y) 630 | = case lookup k t1 of 631 | Just x -> Tip k $! f k x y 632 | Nothing -> Nil 633 | intersectionWithKey _ Nil _ = Nil 634 | intersectionWithKey _ _ Nil = Nil 635 | 636 | 637 | {-------------------------------------------------------------------- 638 | Min\/Max 639 | --------------------------------------------------------------------} 640 | 641 | -- | /O(log n)/. Update the value at the minimal key. 642 | -- 643 | -- > updateMinWithKey (\ k a -> Just ((show k) ++ ":" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3,"3:b"), (5,"a")] 644 | -- > updateMinWithKey (\ _ _ -> Nothing) (fromList [(5,"a"), (3,"b")]) == singleton 5 "a" 645 | 646 | updateMinWithKey :: (Key -> a -> Maybe a) -> IntMap a -> IntMap a 647 | updateMinWithKey f t = 648 | case t of Bin p m l r | m < 0 -> bin p m l (go f r) 649 | _ -> go f t 650 | where 651 | go f' (Bin p m l r) = bin p m (go f' l) r 652 | go f' (Tip k y) = case f' k y of 653 | Just y' -> y' `seq` Tip k y' 654 | Nothing -> Nil 655 | go _ Nil = error "updateMinWithKey Nil" 656 | 657 | -- | /O(log n)/. Update the value at the maximal key. 658 | -- 659 | -- > updateMaxWithKey (\ k a -> Just ((show k) ++ ":" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3,"b"), (5,"5:a")] 660 | -- > updateMaxWithKey (\ _ _ -> Nothing) (fromList [(5,"a"), (3,"b")]) == singleton 3 "b" 661 | 662 | updateMaxWithKey :: (Key -> a -> Maybe a) -> IntMap a -> IntMap a 663 | updateMaxWithKey f t = 664 | case t of Bin p m l r | m < 0 -> bin p m (go f l) r 665 | _ -> go f t 666 | where 667 | go f' (Bin p m l r) = bin p m l (go f' r) 668 | go f' (Tip k y) = case f' k y of 669 | Just y' -> y' `seq` Tip k y' 670 | Nothing -> Nil 671 | go _ Nil = error "updateMaxWithKey Nil" 672 | 673 | -- | /O(log n)/. Update the value at the maximal key. 674 | -- 675 | -- > updateMax (\ a -> Just ("X" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "Xa")] 676 | -- > updateMax (\ _ -> Nothing) (fromList [(5,"a"), (3,"b")]) == singleton 3 "b" 677 | 678 | updateMax :: (a -> Maybe a) -> IntMap a -> IntMap a 679 | updateMax f = updateMaxWithKey (const f) 680 | 681 | -- | /O(log n)/. Update the value at the minimal key. 682 | -- 683 | -- > updateMin (\ a -> Just ("X" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3, "Xb"), (5, "a")] 684 | -- > updateMin (\ _ -> Nothing) (fromList [(5,"a"), (3,"b")]) == singleton 5 "a" 685 | 686 | updateMin :: (a -> Maybe a) -> IntMap a -> IntMap a 687 | updateMin f = updateMinWithKey (const f) 688 | 689 | 690 | {-------------------------------------------------------------------- 691 | Mapping 692 | --------------------------------------------------------------------} 693 | -- | /O(n)/. Map a function over all values in the map. 694 | -- 695 | -- > map (++ "x") (fromList [(5,"a"), (3,"b")]) == fromList [(3, "bx"), (5, "ax")] 696 | 697 | map :: (a -> b) -> IntMap a -> IntMap b 698 | map f = mapWithKey (\_ x -> f x) 699 | 700 | -- | /O(n)/. Map a function over all values in the map. 701 | -- 702 | -- > let f key x = (show key) ++ ":" ++ x 703 | -- > mapWithKey f (fromList [(5,"a"), (3,"b")]) == fromList [(3, "3:b"), (5, "5:a")] 704 | 705 | mapWithKey :: (Key -> a -> b) -> IntMap a -> IntMap b 706 | mapWithKey f t 707 | = case t of 708 | Bin p m l r -> Bin p m (mapWithKey f l) (mapWithKey f r) 709 | Tip k x -> Tip k $! f k x 710 | Nil -> Nil 711 | 712 | -- | /O(n)/. The function @'mapAccum'@ threads an accumulating 713 | -- argument through the map in ascending order of keys. 714 | -- 715 | -- > let f a b = (a ++ b, b ++ "X") 716 | -- > mapAccum f "Everything: " (fromList [(5,"a"), (3,"b")]) == ("Everything: ba", fromList [(3, "bX"), (5, "aX")]) 717 | 718 | mapAccum :: (a -> b -> (a,c)) -> a -> IntMap b -> (a,IntMap c) 719 | mapAccum f = mapAccumWithKey (\a' _ x -> f a' x) 720 | 721 | -- | /O(n)/. The function @'mapAccumWithKey'@ threads an accumulating 722 | -- argument through the map in ascending order of keys. 723 | -- 724 | -- > let f a k b = (a ++ " " ++ (show k) ++ "-" ++ b, b ++ "X") 725 | -- > mapAccumWithKey f "Everything:" (fromList [(5,"a"), (3,"b")]) == ("Everything: 3-b 5-a", fromList [(3, "bX"), (5, "aX")]) 726 | 727 | mapAccumWithKey :: (a -> Key -> b -> (a,c)) -> a -> IntMap b -> (a,IntMap c) 728 | mapAccumWithKey f a t 729 | = mapAccumL f a t 730 | 731 | -- | /O(n)/. The function @'mapAccumL'@ threads an accumulating 732 | -- argument through the map in ascending order of keys. Strict in 733 | -- the accumulating argument and the both elements of the 734 | -- result of the function. 735 | mapAccumL :: (a -> Key -> b -> (a,c)) -> a -> IntMap b -> (a,IntMap c) 736 | mapAccumL f a t 737 | = case t of 738 | Bin p m l r -> let (a1,l') = mapAccumL f a l 739 | (a2,r') = mapAccumL f a1 r 740 | in (a2 `strictPair` Bin p m l' r') 741 | Tip k x -> let (a',x') = f a k x in x' `seq` (a' `strictPair` Tip k x') 742 | Nil -> (a `strictPair` Nil) 743 | 744 | -- | /O(n)/. The function @'mapAccumR'@ threads an accumulating 745 | -- argument through the map in descending order of keys. 746 | mapAccumRWithKey :: (a -> Key -> b -> (a,c)) -> a -> IntMap b -> (a,IntMap c) 747 | mapAccumRWithKey f a t 748 | = case t of 749 | Bin p m l r -> let (a1,r') = mapAccumRWithKey f a r 750 | (a2,l') = mapAccumRWithKey f a1 l 751 | in (a2 `strictPair` Bin p m l' r') 752 | Tip k x -> let (a',x') = f a k x in x' `seq` (a' `strictPair` Tip k x') 753 | Nil -> (a `strictPair` Nil) 754 | 755 | -- | /O(n*log n)/. 756 | -- @'mapKeysWith' c f s@ is the map obtained by applying @f@ to each key of @s@. 757 | -- 758 | -- The size of the result may be smaller if @f@ maps two or more distinct 759 | -- keys to the same new key. In this case the associated values will be 760 | -- combined using @c@. 761 | -- 762 | -- > mapKeysWith (++) (\ _ -> 1) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) == singleton 1 "cdab" 763 | -- > mapKeysWith (++) (\ _ -> 3) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) == singleton 3 "cdab" 764 | 765 | mapKeysWith :: (a -> a -> a) -> (Key->Key) -> IntMap a -> IntMap a 766 | mapKeysWith c f = fromListWith c . foldrWithKey (\k x xs -> (f k, x) : xs) [] 767 | 768 | {-------------------------------------------------------------------- 769 | Filter 770 | --------------------------------------------------------------------} 771 | -- | /O(n)/. Map values and collect the 'Just' results. 772 | -- 773 | -- > let f x = if x == "a" then Just "new a" else Nothing 774 | -- > mapMaybe f (fromList [(5,"a"), (3,"b")]) == singleton 5 "new a" 775 | 776 | mapMaybe :: (a -> Maybe b) -> IntMap a -> IntMap b 777 | mapMaybe f = mapMaybeWithKey (\_ x -> f x) 778 | 779 | -- | /O(n)/. Map keys\/values and collect the 'Just' results. 780 | -- 781 | -- > let f k _ = if k < 5 then Just ("key : " ++ (show k)) else Nothing 782 | -- > mapMaybeWithKey f (fromList [(5,"a"), (3,"b")]) == singleton 3 "key : 3" 783 | 784 | mapMaybeWithKey :: (Key -> a -> Maybe b) -> IntMap a -> IntMap b 785 | mapMaybeWithKey f (Bin p m l r) 786 | = bin p m (mapMaybeWithKey f l) (mapMaybeWithKey f r) 787 | mapMaybeWithKey f (Tip k x) = case f k x of 788 | Just y -> y `seq` Tip k y 789 | Nothing -> Nil 790 | mapMaybeWithKey _ Nil = Nil 791 | 792 | -- | /O(n)/. Map values and separate the 'Left' and 'Right' results. 793 | -- 794 | -- > let f a = if a < "c" then Left a else Right a 795 | -- > mapEither f (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")]) 796 | -- > == (fromList [(3,"b"), (5,"a")], fromList [(1,"x"), (7,"z")]) 797 | -- > 798 | -- > mapEither (\ a -> Right a) (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")]) 799 | -- > == (empty, fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")]) 800 | 801 | mapEither :: (a -> Either b c) -> IntMap a -> (IntMap b, IntMap c) 802 | mapEither f m 803 | = mapEitherWithKey (\_ x -> f x) m 804 | 805 | -- | /O(n)/. Map keys\/values and separate the 'Left' and 'Right' results. 806 | -- 807 | -- > let f k a = if k < 5 then Left (k * 2) else Right (a ++ a) 808 | -- > mapEitherWithKey f (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")]) 809 | -- > == (fromList [(1,2), (3,6)], fromList [(5,"aa"), (7,"zz")]) 810 | -- > 811 | -- > mapEitherWithKey (\_ a -> Right a) (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")]) 812 | -- > == (empty, fromList [(1,"x"), (3,"b"), (5,"a"), (7,"z")]) 813 | 814 | mapEitherWithKey :: (Key -> a -> Either b c) -> IntMap a -> (IntMap b, IntMap c) 815 | mapEitherWithKey f (Bin p m l r) 816 | = bin p m l1 r1 `strictPair` bin p m l2 r2 817 | where 818 | (l1,l2) = mapEitherWithKey f l 819 | (r1,r2) = mapEitherWithKey f r 820 | mapEitherWithKey f (Tip k x) = case f k x of 821 | Left y -> y `seq` (Tip k y, Nil) 822 | Right z -> z `seq` (Nil, Tip k z) 823 | mapEitherWithKey _ Nil = (Nil, Nil) 824 | 825 | 826 | {-------------------------------------------------------------------- 827 | Lists 828 | --------------------------------------------------------------------} 829 | -- | /O(n*min(n,W))/. Create a map from a list of key\/value pairs. 830 | -- 831 | -- > fromList [] == empty 832 | -- > fromList [(5,"a"), (3,"b"), (5, "c")] == fromList [(5,"c"), (3,"b")] 833 | -- > fromList [(5,"c"), (3,"b"), (5, "a")] == fromList [(5,"a"), (3,"b")] 834 | 835 | fromList :: [(Key,a)] -> IntMap a 836 | fromList xs 837 | = foldlStrict ins empty xs 838 | where 839 | ins t (k,x) = insert k x t 840 | 841 | -- | /O(n*min(n,W))/. Create a map from a list of key\/value pairs with a combining function. See also 'fromAscListWith'. 842 | -- 843 | -- > fromListWith (++) [(5,"a"), (5,"b"), (3,"b"), (3,"a"), (5,"a")] == fromList [(3, "ab"), (5, "aba")] 844 | -- > fromListWith (++) [] == empty 845 | 846 | fromListWith :: (a -> a -> a) -> [(Key,a)] -> IntMap a 847 | fromListWith f xs 848 | = fromListWithKey (\_ x y -> f x y) xs 849 | 850 | -- | /O(n*min(n,W))/. Build a map from a list of key\/value pairs with a combining function. See also fromAscListWithKey'. 851 | -- 852 | -- > fromListWith (++) [(5,"a"), (5,"b"), (3,"b"), (3,"a"), (5,"a")] == fromList [(3, "ab"), (5, "aba")] 853 | -- > fromListWith (++) [] == empty 854 | 855 | fromListWithKey :: (Key -> a -> a -> a) -> [(Key,a)] -> IntMap a 856 | fromListWithKey f xs 857 | = foldlStrict ins empty xs 858 | where 859 | ins t (k,x) = insertWithKey f k x t 860 | 861 | -- | /O(n)/. Build a map from a list of key\/value pairs where 862 | -- the keys are in ascending order. 863 | -- 864 | -- > fromAscList [(3,"b"), (5,"a")] == fromList [(3, "b"), (5, "a")] 865 | -- > fromAscList [(3,"b"), (5,"a"), (5,"b")] == fromList [(3, "b"), (5, "b")] 866 | 867 | fromAscList :: [(Key,a)] -> IntMap a 868 | fromAscList xs 869 | = fromAscListWithKey (\_ x _ -> x) xs 870 | 871 | -- | /O(n)/. Build a map from a list of key\/value pairs where 872 | -- the keys are in ascending order, with a combining function on equal keys. 873 | -- /The precondition (input list is ascending) is not checked./ 874 | -- 875 | -- > fromAscListWith (++) [(3,"b"), (5,"a"), (5,"b")] == fromList [(3, "b"), (5, "ba")] 876 | 877 | fromAscListWith :: (a -> a -> a) -> [(Key,a)] -> IntMap a 878 | fromAscListWith f xs 879 | = fromAscListWithKey (\_ x y -> f x y) xs 880 | 881 | -- | /O(n)/. Build a map from a list of key\/value pairs where 882 | -- the keys are in ascending order, with a combining function on equal keys. 883 | -- /The precondition (input list is ascending) is not checked./ 884 | -- 885 | -- > fromAscListWith (++) [(3,"b"), (5,"a"), (5,"b")] == fromList [(3, "b"), (5, "ba")] 886 | 887 | fromAscListWithKey :: (Key -> a -> a -> a) -> [(Key,a)] -> IntMap a 888 | fromAscListWithKey _ [] = Nil 889 | fromAscListWithKey f (x0 : xs0) = fromDistinctAscList (combineEq x0 xs0) 890 | where 891 | -- [combineEq f xs] combines equal elements with function [f] in an ordered list [xs] 892 | combineEq z [] = [z] 893 | combineEq z@(kz,zz) (x@(kx,xx):xs) 894 | | kx==kz = let yy = f kx xx zz in yy `seq` combineEq (kx,yy) xs 895 | | otherwise = z:combineEq x xs 896 | 897 | -- | /O(n)/. Build a map from a list of key\/value pairs where 898 | -- the keys are in ascending order and all distinct. 899 | -- /The precondition (input list is strictly ascending) is not checked./ 900 | -- 901 | -- > fromDistinctAscList [(3,"b"), (5,"a")] == fromList [(3, "b"), (5, "a")] 902 | 903 | fromDistinctAscList :: [(Key,a)] -> IntMap a 904 | fromDistinctAscList [] = Nil 905 | fromDistinctAscList (z0 : zs0) = work z0 zs0 Nada 906 | where 907 | work (kx,vx) [] stk = vx `seq` finish kx (Tip kx vx) stk 908 | work (kx,vx) (z@(kz,_):zs) stk = vx `seq` reduce z zs (branchMask kx kz) kx (Tip kx vx) stk 909 | 910 | reduce :: (Key,a) -> [(Key,a)] -> Mask -> Prefix -> IntMap a -> Stack a -> IntMap a 911 | reduce z zs _ px tx Nada = work z zs (Push px tx Nada) 912 | reduce z zs m px tx stk@(Push py ty stk') = 913 | let mxy = branchMask px py 914 | pxy = mask px mxy 915 | in if shorter m mxy 916 | then reduce z zs m pxy (Bin pxy mxy ty tx) stk' 917 | else work z zs (Push px tx stk) 918 | 919 | finish _ t Nada = t 920 | finish px tx (Push py ty stk) = finish p (join py ty px tx) stk 921 | where m = branchMask px py 922 | p = mask px m 923 | 924 | data Stack a = Push {-# UNPACK #-} !Prefix !(IntMap a) !(Stack a) | Nada 925 | -------------------------------------------------------------------------------- /tests/intmap-properties.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | 3 | #ifdef STRICT 4 | import Data.IntMap.Strict as Data.IntMap 5 | #else 6 | import Data.IntMap.Lazy as Data.IntMap 7 | #endif 8 | 9 | import Data.Monoid 10 | import Data.Maybe hiding (mapMaybe) 11 | import Data.Ord 12 | import Data.Function 13 | import Prelude hiding (lookup, null, map, filter, foldr, foldl) 14 | import qualified Prelude (map) 15 | 16 | import Data.List (nub,sort) 17 | import qualified Data.List as List 18 | import qualified Data.IntSet 19 | import Test.Framework 20 | import Test.Framework.Providers.HUnit 21 | import Test.Framework.Providers.QuickCheck2 22 | import Test.HUnit hiding (Test, Testable) 23 | import Test.QuickCheck 24 | import Text.Show.Functions () 25 | 26 | default (Int) 27 | 28 | main :: IO () 29 | main = defaultMainWithOpts 30 | [ 31 | testCase "index" test_index 32 | , testCase "size" test_size 33 | , testCase "size2" test_size2 34 | , testCase "member" test_member 35 | , testCase "notMember" test_notMember 36 | , testCase "lookup" test_lookup 37 | , testCase "findWithDefault" test_findWithDefault 38 | , testCase "empty" test_empty 39 | , testCase "mempty" test_mempty 40 | , testCase "singleton" test_singleton 41 | , testCase "insert" test_insert 42 | , testCase "insertWith" test_insertWith 43 | , testCase "insertWithKey" test_insertWithKey 44 | , testCase "insertLookupWithKey" test_insertLookupWithKey 45 | , testCase "delete" test_delete 46 | , testCase "adjust" test_adjust 47 | , testCase "adjustWithKey" test_adjustWithKey 48 | , testCase "update" test_update 49 | , testCase "updateWithKey" test_updateWithKey 50 | , testCase "updateLookupWithKey" test_updateLookupWithKey 51 | , testCase "alter" test_alter 52 | , testCase "union" test_union 53 | , testCase "mappend" test_mappend 54 | , testCase "unionWith" test_unionWith 55 | , testCase "unionWithKey" test_unionWithKey 56 | , testCase "unions" test_unions 57 | , testCase "mconcat" test_mconcat 58 | , testCase "unionsWith" test_unionsWith 59 | , testCase "difference" test_difference 60 | , testCase "differenceWith" test_differenceWith 61 | , testCase "differenceWithKey" test_differenceWithKey 62 | , testCase "intersection" test_intersection 63 | , testCase "intersectionWith" test_intersectionWith 64 | , testCase "intersectionWithKey" test_intersectionWithKey 65 | , testCase "map" test_map 66 | , testCase "mapWithKey" test_mapWithKey 67 | , testCase "mapAccum" test_mapAccum 68 | , testCase "mapAccumWithKey" test_mapAccumWithKey 69 | , testCase "mapAccumRWithKey" test_mapAccumRWithKey 70 | , testCase "mapKeys" test_mapKeys 71 | , testCase "mapKeysWith" test_mapKeysWith 72 | , testCase "mapKeysMonotonic" test_mapKeysMonotonic 73 | , testCase "elems" test_elems 74 | , testCase "keys" test_keys 75 | , testCase "keysSet" test_keysSet 76 | , testCase "associative" test_assocs 77 | , testCase "toList" test_toList 78 | , testCase "fromList" test_fromList 79 | , testCase "fromListWith" test_fromListWith 80 | , testCase "fromListWithKey" test_fromListWithKey 81 | , testCase "toAscList" test_toAscList 82 | , testCase "toDescList" test_toDescList 83 | , testCase "showTree" test_showTree 84 | , testCase "fromAscList" test_fromAscList 85 | , testCase "fromAscListWith" test_fromAscListWith 86 | , testCase "fromAscListWithKey" test_fromAscListWithKey 87 | , testCase "fromDistinctAscList" test_fromDistinctAscList 88 | , testCase "filter" test_filter 89 | , testCase "filterWithKey" test_filteWithKey 90 | , testCase "partition" test_partition 91 | , testCase "partitionWithKey" test_partitionWithKey 92 | , testCase "mapMaybe" test_mapMaybe 93 | , testCase "mapMaybeWithKey" test_mapMaybeWithKey 94 | , testCase "mapEither" test_mapEither 95 | , testCase "mapEitherWithKey" test_mapEitherWithKey 96 | , testCase "split" test_split 97 | , testCase "splitLookup" test_splitLookup 98 | , testCase "isSubmapOfBy" test_isSubmapOfBy 99 | , testCase "isSubmapOf" test_isSubmapOf 100 | , testCase "isProperSubmapOfBy" test_isProperSubmapOfBy 101 | , testCase "isProperSubmapOf" test_isProperSubmapOf 102 | , testCase "findMin" test_findMin 103 | , testCase "findMax" test_findMax 104 | , testCase "deleteMin" test_deleteMin 105 | , testCase "deleteMax" test_deleteMax 106 | , testCase "deleteFindMin" test_deleteFindMin 107 | , testCase "deleteFindMax" test_deleteFindMax 108 | , testCase "updateMin" test_updateMin 109 | , testCase "updateMax" test_updateMax 110 | , testCase "updateMinWithKey" test_updateMinWithKey 111 | , testCase "updateMaxWithKey" test_updateMaxWithKey 112 | , testCase "minView" test_minView 113 | , testCase "maxView" test_maxView 114 | , testCase "minViewWithKey" test_minViewWithKey 115 | , testCase "maxViewWithKey" test_maxViewWithKey 116 | , testProperty "insert to singleton" prop_singleton 117 | , testProperty "insert then lookup" prop_lookup 118 | , testProperty "insert then delete" prop_insertDelete 119 | , testProperty "delete non member" prop_deleteNonMember 120 | , testProperty "union model" prop_unionModel 121 | , testProperty "union singleton" prop_unionSingleton 122 | , testProperty "union associative" prop_unionAssoc 123 | , testProperty "union+unionWith" prop_unionWith 124 | , testProperty "union sum" prop_unionSum 125 | , testProperty "difference model" prop_differenceModel 126 | , testProperty "intersection model" prop_intersectionModel 127 | , testProperty "intersectionWith model" prop_intersectionWithModel 128 | , testProperty "intersectionWithKey model" prop_intersectionWithKeyModel 129 | , testProperty "fromAscList" prop_ordered 130 | , testProperty "fromList then toList" prop_list 131 | , testProperty "toDescList" prop_descList 132 | , testProperty "toAscList+toDescList" prop_ascDescList 133 | , testProperty "alter" prop_alter 134 | , testProperty "index" prop_index 135 | , testProperty "null" prop_null 136 | , testProperty "member" prop_member 137 | , testProperty "notmember" prop_notmember 138 | , testProperty "findWithDefault" prop_findWithDefault 139 | , testProperty "findMin" prop_findMin 140 | , testProperty "findMax" prop_findMax 141 | , testProperty "deleteMin" prop_deleteMinModel 142 | , testProperty "deleteMax" prop_deleteMaxModel 143 | , testProperty "filter" prop_filter 144 | , testProperty "partition" prop_partition 145 | , testProperty "map" prop_map 146 | , testProperty "fmap" prop_fmap 147 | , testProperty "mapkeys" prop_mapkeys 148 | , testProperty "split" prop_splitModel 149 | , testProperty "foldr" prop_foldr 150 | , testProperty "foldr'" prop_foldr' 151 | , testProperty "foldl" prop_foldl 152 | , testProperty "foldl'" prop_foldl' 153 | ] opts 154 | 155 | where 156 | opts = mempty { ropt_test_options = Just $ mempty { topt_maximum_generated_tests = Just 500 157 | , topt_maximum_unsuitable_generated_tests = Just 500 158 | } 159 | } 160 | 161 | {-------------------------------------------------------------------- 162 | Arbitrary, reasonably balanced trees 163 | --------------------------------------------------------------------} 164 | 165 | instance Arbitrary a => Arbitrary (IntMap a) where 166 | arbitrary = do{ ks <- arbitrary 167 | ; xs <- arbitrary 168 | ; return (fromList (zip xs ks)) 169 | } 170 | 171 | 172 | ------------------------------------------------------------------------ 173 | 174 | type UMap = IntMap () 175 | type IMap = IntMap Int 176 | type SMap = IntMap String 177 | 178 | ---------------------------------------------------------------- 179 | 180 | tests :: [Test] 181 | tests = [ testGroup "Test Case" [ 182 | ] 183 | , testGroup "Property Test" [ 184 | ] 185 | ] 186 | 187 | 188 | ---------------------------------------------------------------- 189 | -- Unit tests 190 | ---------------------------------------------------------------- 191 | 192 | ---------------------------------------------------------------- 193 | -- Operators 194 | 195 | test_index :: Assertion 196 | test_index = fromList [(5,'a'), (3,'b')] ! 5 @?= 'a' 197 | 198 | ---------------------------------------------------------------- 199 | -- Query 200 | 201 | test_size :: Assertion 202 | test_size = do 203 | null (empty) @?= True 204 | null (singleton 1 'a') @?= False 205 | 206 | test_size2 :: Assertion 207 | test_size2 = do 208 | size empty @?= 0 209 | size (singleton 1 'a') @?= 1 210 | size (fromList([(1,'a'), (2,'c'), (3,'b')])) @?= 3 211 | 212 | test_member :: Assertion 213 | test_member = do 214 | member 5 (fromList [(5,'a'), (3,'b')]) @?= True 215 | member 1 (fromList [(5,'a'), (3,'b')]) @?= False 216 | 217 | test_notMember :: Assertion 218 | test_notMember = do 219 | notMember 5 (fromList [(5,'a'), (3,'b')]) @?= False 220 | notMember 1 (fromList [(5,'a'), (3,'b')]) @?= True 221 | 222 | test_lookup :: Assertion 223 | test_lookup = do 224 | employeeCurrency 1 @?= Just 1 225 | employeeCurrency 2 @?= Nothing 226 | where 227 | employeeDept = fromList([(1,2), (3,1)]) 228 | deptCountry = fromList([(1,1), (2,2)]) 229 | countryCurrency = fromList([(1, 2), (2, 1)]) 230 | employeeCurrency :: Int -> Maybe Int 231 | employeeCurrency name = do 232 | dept <- lookup name employeeDept 233 | country <- lookup dept deptCountry 234 | lookup country countryCurrency 235 | 236 | test_findWithDefault :: Assertion 237 | test_findWithDefault = do 238 | findWithDefault 'x' 1 (fromList [(5,'a'), (3,'b')]) @?= 'x' 239 | findWithDefault 'x' 5 (fromList [(5,'a'), (3,'b')]) @?= 'a' 240 | 241 | ---------------------------------------------------------------- 242 | -- Construction 243 | 244 | test_empty :: Assertion 245 | test_empty = do 246 | (empty :: UMap) @?= fromList [] 247 | size empty @?= 0 248 | 249 | test_mempty :: Assertion 250 | test_mempty = do 251 | (mempty :: UMap) @?= fromList [] 252 | size (mempty :: UMap) @?= 0 253 | 254 | test_singleton :: Assertion 255 | test_singleton = do 256 | singleton 1 'a' @?= fromList [(1, 'a')] 257 | size (singleton 1 'a') @?= 1 258 | 259 | test_insert :: Assertion 260 | test_insert = do 261 | insert 5 'x' (fromList [(5,'a'), (3,'b')]) @?= fromList [(3, 'b'), (5, 'x')] 262 | insert 7 'x' (fromList [(5,'a'), (3,'b')]) @?= fromList [(3, 'b'), (5, 'a'), (7, 'x')] 263 | insert 5 'x' empty @?= singleton 5 'x' 264 | 265 | test_insertWith :: Assertion 266 | test_insertWith = do 267 | insertWith (++) 5 "xxx" (fromList [(5,"a"), (3,"b")]) @?= fromList [(3, "b"), (5, "xxxa")] 268 | insertWith (++) 7 "xxx" (fromList [(5,"a"), (3,"b")]) @?= fromList [(3, "b"), (5, "a"), (7, "xxx")] 269 | insertWith (++) 5 "xxx" empty @?= singleton 5 "xxx" 270 | 271 | test_insertWithKey :: Assertion 272 | test_insertWithKey = do 273 | insertWithKey f 5 "xxx" (fromList [(5,"a"), (3,"b")]) @?= fromList [(3, "b"), (5, "5:xxx|a")] 274 | insertWithKey f 7 "xxx" (fromList [(5,"a"), (3,"b")]) @?= fromList [(3, "b"), (5, "a"), (7, "xxx")] 275 | insertWithKey f 5 "xxx" empty @?= singleton 5 "xxx" 276 | where 277 | f key new_value old_value = (show key) ++ ":" ++ new_value ++ "|" ++ old_value 278 | 279 | test_insertLookupWithKey :: Assertion 280 | test_insertLookupWithKey = do 281 | insertLookupWithKey f 5 "xxx" (fromList [(5,"a"), (3,"b")]) @?= (Just "a", fromList [(3, "b"), (5, "5:xxx|a")]) 282 | insertLookupWithKey f 2 "xxx" (fromList [(5,"a"), (3,"b")]) @?= (Nothing,fromList [(2,"xxx"),(3,"b"),(5,"a")]) 283 | insertLookupWithKey f 7 "xxx" (fromList [(5,"a"), (3,"b")]) @?= (Nothing, fromList [(3, "b"), (5, "a"), (7, "xxx")]) 284 | insertLookupWithKey f 5 "xxx" empty @?= (Nothing, singleton 5 "xxx") 285 | where 286 | f key new_value old_value = (show key) ++ ":" ++ new_value ++ "|" ++ old_value 287 | 288 | ---------------------------------------------------------------- 289 | -- Delete/Update 290 | 291 | test_delete :: Assertion 292 | test_delete = do 293 | delete 5 (fromList [(5,"a"), (3,"b")]) @?= singleton 3 "b" 294 | delete 7 (fromList [(5,"a"), (3,"b")]) @?= fromList [(3, "b"), (5, "a")] 295 | delete 5 empty @?= (empty :: IMap) 296 | 297 | test_adjust :: Assertion 298 | test_adjust = do 299 | adjust ("new " ++) 5 (fromList [(5,"a"), (3,"b")]) @?= fromList [(3, "b"), (5, "new a")] 300 | adjust ("new " ++) 7 (fromList [(5,"a"), (3,"b")]) @?= fromList [(3, "b"), (5, "a")] 301 | adjust ("new " ++) 7 empty @?= empty 302 | 303 | test_adjustWithKey :: Assertion 304 | test_adjustWithKey = do 305 | adjustWithKey f 5 (fromList [(5,"a"), (3,"b")]) @?= fromList [(3, "b"), (5, "5:new a")] 306 | adjustWithKey f 7 (fromList [(5,"a"), (3,"b")]) @?= fromList [(3, "b"), (5, "a")] 307 | adjustWithKey f 7 empty @?= empty 308 | where 309 | f key x = (show key) ++ ":new " ++ x 310 | 311 | test_update :: Assertion 312 | test_update = do 313 | update f 5 (fromList [(5,"a"), (3,"b")]) @?= fromList [(3, "b"), (5, "new a")] 314 | update f 7 (fromList [(5,"a"), (3,"b")]) @?= fromList [(3, "b"), (5, "a")] 315 | update f 3 (fromList [(5,"a"), (3,"b")]) @?= singleton 5 "a" 316 | where 317 | f x = if x == "a" then Just "new a" else Nothing 318 | 319 | test_updateWithKey :: Assertion 320 | test_updateWithKey = do 321 | updateWithKey f 5 (fromList [(5,"a"), (3,"b")]) @?= fromList [(3, "b"), (5, "5:new a")] 322 | updateWithKey f 7 (fromList [(5,"a"), (3,"b")]) @?= fromList [(3, "b"), (5, "a")] 323 | updateWithKey f 3 (fromList [(5,"a"), (3,"b")]) @?= singleton 5 "a" 324 | where 325 | f k x = if x == "a" then Just ((show k) ++ ":new a") else Nothing 326 | 327 | test_updateLookupWithKey :: Assertion 328 | test_updateLookupWithKey = do 329 | updateLookupWithKey f 5 (fromList [(5,"a"), (3,"b")]) @?= (Just "a", fromList [(3, "b"), (5, "5:new a")]) 330 | updateLookupWithKey f 7 (fromList [(5,"a"), (3,"b")]) @?= (Nothing, fromList [(3, "b"), (5, "a")]) 331 | updateLookupWithKey f 3 (fromList [(5,"a"), (3,"b")]) @?= (Just "b", singleton 5 "a") 332 | where 333 | f k x = if x == "a" then Just ((show k) ++ ":new a") else Nothing 334 | 335 | test_alter :: Assertion 336 | test_alter = do 337 | alter f 7 (fromList [(5,"a"), (3,"b")]) @?= fromList [(3, "b"), (5, "a")] 338 | alter f 5 (fromList [(5,"a"), (3,"b")]) @?= singleton 3 "b" 339 | alter g 7 (fromList [(5,"a"), (3,"b")]) @?= fromList [(3, "b"), (5, "a"), (7, "c")] 340 | alter g 5 (fromList [(5,"a"), (3,"b")]) @?= fromList [(3, "b"), (5, "c")] 341 | where 342 | f _ = Nothing 343 | g _ = Just "c" 344 | 345 | ---------------------------------------------------------------- 346 | -- Combine 347 | 348 | test_union :: Assertion 349 | test_union = union (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) @?= fromList [(3, "b"), (5, "a"), (7, "C")] 350 | 351 | test_mappend :: Assertion 352 | test_mappend = mappend (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) @?= fromList [(3, "b"), (5, "a"), (7, "C")] 353 | 354 | test_unionWith :: Assertion 355 | test_unionWith = unionWith (++) (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) @?= fromList [(3, "b"), (5, "aA"), (7, "C")] 356 | 357 | test_unionWithKey :: Assertion 358 | test_unionWithKey = unionWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) @?= fromList [(3, "b"), (5, "5:a|A"), (7, "C")] 359 | where 360 | f key left_value right_value = (show key) ++ ":" ++ left_value ++ "|" ++ right_value 361 | 362 | test_unions :: Assertion 363 | test_unions = do 364 | unions [(fromList [(5, "a"), (3, "b")]), (fromList [(5, "A"), (7, "C")]), (fromList [(5, "A3"), (3, "B3")])] 365 | @?= fromList [(3, "b"), (5, "a"), (7, "C")] 366 | unions [(fromList [(5, "A3"), (3, "B3")]), (fromList [(5, "A"), (7, "C")]), (fromList [(5, "a"), (3, "b")])] 367 | @?= fromList [(3, "B3"), (5, "A3"), (7, "C")] 368 | 369 | test_mconcat :: Assertion 370 | test_mconcat = do 371 | mconcat [(fromList [(5, "a"), (3, "b")]), (fromList [(5, "A"), (7, "C")]), (fromList [(5, "A3"), (3, "B3")])] 372 | @?= fromList [(3, "b"), (5, "a"), (7, "C")] 373 | mconcat [(fromList [(5, "A3"), (3, "B3")]), (fromList [(5, "A"), (7, "C")]), (fromList [(5, "a"), (3, "b")])] 374 | @?= fromList [(3, "B3"), (5, "A3"), (7, "C")] 375 | 376 | test_unionsWith :: Assertion 377 | test_unionsWith = unionsWith (++) [(fromList [(5, "a"), (3, "b")]), (fromList [(5, "A"), (7, "C")]), (fromList [(5, "A3"), (3, "B3")])] 378 | @?= fromList [(3, "bB3"), (5, "aAA3"), (7, "C")] 379 | 380 | test_difference :: Assertion 381 | test_difference = difference (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) @?= singleton 3 "b" 382 | 383 | test_differenceWith :: Assertion 384 | test_differenceWith = differenceWith f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (3, "B"), (7, "C")]) 385 | @?= singleton 3 "b:B" 386 | where 387 | f al ar = if al== "b" then Just (al ++ ":" ++ ar) else Nothing 388 | 389 | test_differenceWithKey :: Assertion 390 | test_differenceWithKey = differenceWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (3, "B"), (10, "C")]) 391 | @?= singleton 3 "3:b|B" 392 | where 393 | f k al ar = if al == "b" then Just ((show k) ++ ":" ++ al ++ "|" ++ ar) else Nothing 394 | 395 | test_intersection :: Assertion 396 | test_intersection = intersection (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) @?= singleton 5 "a" 397 | 398 | 399 | test_intersectionWith :: Assertion 400 | test_intersectionWith = intersectionWith (++) (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) @?= singleton 5 "aA" 401 | 402 | test_intersectionWithKey :: Assertion 403 | test_intersectionWithKey = intersectionWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) @?= singleton 5 "5:a|A" 404 | where 405 | f k al ar = (show k) ++ ":" ++ al ++ "|" ++ ar 406 | 407 | ---------------------------------------------------------------- 408 | -- Traversal 409 | 410 | test_map :: Assertion 411 | test_map = map (++ "x") (fromList [(5,"a"), (3,"b")]) @?= fromList [(3, "bx"), (5, "ax")] 412 | 413 | test_mapWithKey :: Assertion 414 | test_mapWithKey = mapWithKey f (fromList [(5,"a"), (3,"b")]) @?= fromList [(3, "3:b"), (5, "5:a")] 415 | where 416 | f key x = (show key) ++ ":" ++ x 417 | 418 | test_mapAccum :: Assertion 419 | test_mapAccum = mapAccum f "Everything: " (fromList [(5,"a"), (3,"b")]) @?= ("Everything: ba", fromList [(3, "bX"), (5, "aX")]) 420 | where 421 | f a b = (a ++ b, b ++ "X") 422 | 423 | test_mapAccumWithKey :: Assertion 424 | test_mapAccumWithKey = mapAccumWithKey f "Everything:" (fromList [(5,"a"), (3,"b")]) @?= ("Everything: 3-b 5-a", fromList [(3, "bX"), (5, "aX")]) 425 | where 426 | f a k b = (a ++ " " ++ (show k) ++ "-" ++ b, b ++ "X") 427 | 428 | test_mapAccumRWithKey :: Assertion 429 | test_mapAccumRWithKey = mapAccumRWithKey f "Everything:" (fromList [(5,"a"), (3,"b")]) @?= ("Everything: 5-a 3-b", fromList [(3, "bX"), (5, "aX")]) 430 | where 431 | f a k b = (a ++ " " ++ (show k) ++ "-" ++ b, b ++ "X") 432 | 433 | test_mapKeys :: Assertion 434 | test_mapKeys = do 435 | mapKeys (+ 1) (fromList [(5,"a"), (3,"b")]) @?= fromList [(4, "b"), (6, "a")] 436 | mapKeys (\ _ -> 1) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) @?= singleton 1 "c" 437 | mapKeys (\ _ -> 3) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) @?= singleton 3 "c" 438 | 439 | test_mapKeysWith :: Assertion 440 | test_mapKeysWith = do 441 | mapKeysWith (++) (\ _ -> 1) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) @?= singleton 1 "cdab" 442 | mapKeysWith (++) (\ _ -> 3) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) @?= singleton 3 "cdab" 443 | 444 | test_mapKeysMonotonic :: Assertion 445 | test_mapKeysMonotonic = do 446 | mapKeysMonotonic (+ 1) (fromList [(5,"a"), (3,"b")]) @?= fromList [(4, "b"), (6, "a")] 447 | mapKeysMonotonic (\ k -> k * 2) (fromList [(5,"a"), (3,"b")]) @?= fromList [(6, "b"), (10, "a")] 448 | 449 | ---------------------------------------------------------------- 450 | -- Conversion 451 | 452 | test_elems :: Assertion 453 | test_elems = do 454 | elems (fromList [(5,"a"), (3,"b")]) @?= ["b","a"] 455 | elems (empty :: UMap) @?= [] 456 | 457 | test_keys :: Assertion 458 | test_keys = do 459 | keys (fromList [(5,"a"), (3,"b")]) @?= [3,5] 460 | keys (empty :: UMap) @?= [] 461 | 462 | test_keysSet :: Assertion 463 | test_keysSet = do 464 | keysSet (fromList [(5,"a"), (3,"b")]) @?= Data.IntSet.fromList [3,5] 465 | keysSet (empty :: UMap) @?= Data.IntSet.empty 466 | 467 | test_assocs :: Assertion 468 | test_assocs = do 469 | assocs (fromList [(5,"a"), (3,"b")]) @?= [(3,"b"), (5,"a")] 470 | assocs (empty :: UMap) @?= [] 471 | 472 | ---------------------------------------------------------------- 473 | -- Lists 474 | 475 | test_toList :: Assertion 476 | test_toList = do 477 | toList (fromList [(5,"a"), (3,"b")]) @?= [(3,"b"), (5,"a")] 478 | toList (empty :: SMap) @?= [] 479 | 480 | test_fromList :: Assertion 481 | test_fromList = do 482 | fromList [] @?= (empty :: SMap) 483 | fromList [(5,"a"), (3,"b"), (5, "c")] @?= fromList [(5,"c"), (3,"b")] 484 | fromList [(5,"c"), (3,"b"), (5, "a")] @?= fromList [(5,"a"), (3,"b")] 485 | 486 | test_fromListWith :: Assertion 487 | test_fromListWith = do 488 | fromListWith (++) [(5,"a"), (5,"b"), (3,"b"), (3,"a"), (5,"a")] @?= fromList [(3, "ab"), (5, "aba")] 489 | fromListWith (++) [] @?= (empty :: SMap) 490 | 491 | test_fromListWithKey :: Assertion 492 | test_fromListWithKey = do 493 | fromListWithKey f [(5,"a"), (5,"b"), (3,"b"), (3,"a"), (5,"a")] @?= fromList [(3, "3ab"), (5, "5a5ba")] 494 | fromListWithKey f [] @?= (empty :: SMap) 495 | where 496 | f k a1 a2 = (show k) ++ a1 ++ a2 497 | 498 | ---------------------------------------------------------------- 499 | -- Ordered lists 500 | 501 | test_toAscList :: Assertion 502 | test_toAscList = toAscList (fromList [(5,"a"), (3,"b")]) @?= [(3,"b"), (5,"a")] 503 | 504 | test_toDescList :: Assertion 505 | test_toDescList = toDescList (fromList [(5,"a"), (3,"b")]) @?= [(5,"a"), (3,"b")] 506 | 507 | test_showTree :: Assertion 508 | test_showTree = 509 | (let t = fromDistinctAscList [(x,()) | x <- [1..5]] 510 | in showTree t) @?= "*\n+--*\n| +-- 1:=()\n| +--*\n| +-- 2:=()\n| +-- 3:=()\n+--*\n +-- 4:=()\n +-- 5:=()\n" 511 | 512 | test_fromAscList :: Assertion 513 | test_fromAscList = do 514 | fromAscList [(3,"b"), (5,"a")] @?= fromList [(3, "b"), (5, "a")] 515 | fromAscList [(3,"b"), (5,"a"), (5,"b")] @?= fromList [(3, "b"), (5, "b")] 516 | 517 | 518 | test_fromAscListWith :: Assertion 519 | test_fromAscListWith = do 520 | fromAscListWith (++) [(3,"b"), (5,"a"), (5,"b")] @?= fromList [(3, "b"), (5, "ba")] 521 | 522 | test_fromAscListWithKey :: Assertion 523 | test_fromAscListWithKey = do 524 | fromAscListWithKey f [(3,"b"), (5,"a"), (5,"b"), (5,"b")] @?= fromList [(3, "b"), (5, "5:b5:ba")] 525 | where 526 | f k a1 a2 = (show k) ++ ":" ++ a1 ++ a2 527 | 528 | test_fromDistinctAscList :: Assertion 529 | test_fromDistinctAscList = do 530 | fromDistinctAscList [(3,"b"), (5,"a")] @?= fromList [(3, "b"), (5, "a")] 531 | 532 | ---------------------------------------------------------------- 533 | -- Filter 534 | 535 | test_filter :: Assertion 536 | test_filter = do 537 | filter (> "a") (fromList [(5,"a"), (3,"b")]) @?= singleton 3 "b" 538 | filter (> "x") (fromList [(5,"a"), (3,"b")]) @?= empty 539 | filter (< "a") (fromList [(5,"a"), (3,"b")]) @?= empty 540 | 541 | test_filteWithKey :: Assertion 542 | test_filteWithKey = filterWithKey (\k _ -> k > 4) (fromList [(5,"a"), (3,"b")]) @?= singleton 5 "a" 543 | 544 | test_partition :: Assertion 545 | test_partition = do 546 | partition (> "a") (fromList [(5,"a"), (3,"b")]) @?= (singleton 3 "b", singleton 5 "a") 547 | partition (< "x") (fromList [(5,"a"), (3,"b")]) @?= (fromList [(3, "b"), (5, "a")], empty) 548 | partition (> "x") (fromList [(5,"a"), (3,"b")]) @?= (empty, fromList [(3, "b"), (5, "a")]) 549 | 550 | test_partitionWithKey :: Assertion 551 | test_partitionWithKey = do 552 | partitionWithKey (\ k _ -> k > 3) (fromList [(5,"a"), (3,"b")]) @?= (singleton 5 "a", singleton 3 "b") 553 | partitionWithKey (\ k _ -> k < 7) (fromList [(5,"a"), (3,"b")]) @?= (fromList [(3, "b"), (5, "a")], empty) 554 | partitionWithKey (\ k _ -> k > 7) (fromList [(5,"a"), (3,"b")]) @?= (empty, fromList [(3, "b"), (5, "a")]) 555 | 556 | test_mapMaybe :: Assertion 557 | test_mapMaybe = mapMaybe f (fromList [(5,"a"), (3,"b")]) @?= singleton 5 "new a" 558 | where 559 | f x = if x == "a" then Just "new a" else Nothing 560 | 561 | test_mapMaybeWithKey :: Assertion 562 | test_mapMaybeWithKey = mapMaybeWithKey f (fromList [(5,"a"), (3,"b")]) @?= singleton 3 "key : 3" 563 | where 564 | f k _ = if k < 5 then Just ("key : " ++ (show k)) else Nothing 565 | 566 | test_mapEither :: Assertion 567 | test_mapEither = do 568 | mapEither f (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")]) 569 | @?= (fromList [(3,"b"), (5,"a")], fromList [(1,"x"), (7,"z")]) 570 | mapEither (\ a -> Right a) (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")]) 571 | @?= ((empty :: SMap), fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")]) 572 | where 573 | f a = if a < "c" then Left a else Right a 574 | 575 | test_mapEitherWithKey :: Assertion 576 | test_mapEitherWithKey = do 577 | mapEitherWithKey f (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")]) 578 | @?= (fromList [(1,2), (3,6)], fromList [(5,"aa"), (7,"zz")]) 579 | mapEitherWithKey (\_ a -> Right a) (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")]) 580 | @?= ((empty :: SMap), fromList [(1,"x"), (3,"b"), (5,"a"), (7,"z")]) 581 | where 582 | f k a = if k < 5 then Left (k * 2) else Right (a ++ a) 583 | 584 | test_split :: Assertion 585 | test_split = do 586 | split 2 (fromList [(5,"a"), (3,"b")]) @?= (empty, fromList [(3,"b"), (5,"a")]) 587 | split 3 (fromList [(5,"a"), (3,"b")]) @?= (empty, singleton 5 "a") 588 | split 4 (fromList [(5,"a"), (3,"b")]) @?= (singleton 3 "b", singleton 5 "a") 589 | split 5 (fromList [(5,"a"), (3,"b")]) @?= (singleton 3 "b", empty) 590 | split 6 (fromList [(5,"a"), (3,"b")]) @?= (fromList [(3,"b"), (5,"a")], empty) 591 | 592 | test_splitLookup :: Assertion 593 | test_splitLookup = do 594 | splitLookup 2 (fromList [(5,"a"), (3,"b")]) @?= (empty, Nothing, fromList [(3,"b"), (5,"a")]) 595 | splitLookup 3 (fromList [(5,"a"), (3,"b")]) @?= (empty, Just "b", singleton 5 "a") 596 | splitLookup 4 (fromList [(5,"a"), (3,"b")]) @?= (singleton 3 "b", Nothing, singleton 5 "a") 597 | splitLookup 5 (fromList [(5,"a"), (3,"b")]) @?= (singleton 3 "b", Just "a", empty) 598 | splitLookup 6 (fromList [(5,"a"), (3,"b")]) @?= (fromList [(3,"b"), (5,"a")], Nothing, empty) 599 | 600 | ---------------------------------------------------------------- 601 | -- Submap 602 | 603 | test_isSubmapOfBy :: Assertion 604 | test_isSubmapOfBy = do 605 | isSubmapOfBy (==) (fromList [(fromEnum 'a',1)]) (fromList [(fromEnum 'a',1),(fromEnum 'b',2)]) @?= True 606 | isSubmapOfBy (<=) (fromList [(fromEnum 'a',1)]) (fromList [(fromEnum 'a',1),(fromEnum 'b',2)]) @?= True 607 | isSubmapOfBy (==) (fromList [(fromEnum 'a',1),(fromEnum 'b',2)]) (fromList [(fromEnum 'a',1),(fromEnum 'b',2)]) @?= True 608 | isSubmapOfBy (==) (fromList [(fromEnum 'a',2)]) (fromList [(fromEnum 'a',1),(fromEnum 'b',2)]) @?= False 609 | isSubmapOfBy (<) (fromList [(fromEnum 'a',1)]) (fromList [(fromEnum 'a',1),(fromEnum 'b',2)]) @?= False 610 | isSubmapOfBy (==) (fromList [(fromEnum 'a',1),(fromEnum 'b',2)]) (fromList [(fromEnum 'a',1)]) @?= False 611 | 612 | test_isSubmapOf :: Assertion 613 | test_isSubmapOf = do 614 | isSubmapOf (fromList [(fromEnum 'a',1)]) (fromList [(fromEnum 'a',1),(fromEnum 'b',2)]) @?= True 615 | isSubmapOf (fromList [(fromEnum 'a',1),(fromEnum 'b',2)]) (fromList [(fromEnum 'a',1),(fromEnum 'b',2)]) @?= True 616 | isSubmapOf (fromList [(fromEnum 'a',2)]) (fromList [(fromEnum 'a',1),(fromEnum 'b',2)]) @?= False 617 | isSubmapOf (fromList [(fromEnum 'a',1),(fromEnum 'b',2)]) (fromList [(fromEnum 'a',1)]) @?= False 618 | 619 | test_isProperSubmapOfBy :: Assertion 620 | test_isProperSubmapOfBy = do 621 | isProperSubmapOfBy (==) (fromList [(1,1)]) (fromList [(1,1),(2,2)]) @?= True 622 | isProperSubmapOfBy (<=) (fromList [(1,1)]) (fromList [(1,1),(2,2)]) @?= True 623 | isProperSubmapOfBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1),(2,2)]) @?= False 624 | isProperSubmapOfBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1)]) @?= False 625 | isProperSubmapOfBy (<) (fromList [(1,1)]) (fromList [(1,1),(2,2)]) @?= False 626 | 627 | test_isProperSubmapOf :: Assertion 628 | test_isProperSubmapOf = do 629 | isProperSubmapOf (fromList [(1,1)]) (fromList [(1,1),(2,2)]) @?= True 630 | isProperSubmapOf (fromList [(1,1),(2,2)]) (fromList [(1,1),(2,2)]) @?= False 631 | isProperSubmapOf (fromList [(1,1),(2,2)]) (fromList [(1,1)]) @?= False 632 | 633 | ---------------------------------------------------------------- 634 | -- Min/Max 635 | 636 | test_findMin :: Assertion 637 | test_findMin = findMin (fromList [(5,"a"), (3,"b")]) @?= (3,"b") 638 | 639 | test_findMax :: Assertion 640 | test_findMax = findMax (fromList [(5,"a"), (3,"b")]) @?= (5,"a") 641 | 642 | test_deleteMin :: Assertion 643 | test_deleteMin = do 644 | deleteMin (fromList [(5,"a"), (3,"b"), (7,"c")]) @?= fromList [(5,"a"), (7,"c")] 645 | deleteMin (empty :: SMap) @?= empty 646 | 647 | test_deleteMax :: Assertion 648 | test_deleteMax = do 649 | deleteMax (fromList [(5,"a"), (3,"b"), (7,"c")]) @?= fromList [(3,"b"), (5,"a")] 650 | deleteMax (empty :: SMap) @?= empty 651 | 652 | test_deleteFindMin :: Assertion 653 | test_deleteFindMin = deleteFindMin (fromList [(5,"a"), (3,"b"), (10,"c")]) @?= ((3,"b"), fromList[(5,"a"), (10,"c")]) 654 | 655 | test_deleteFindMax :: Assertion 656 | test_deleteFindMax = deleteFindMax (fromList [(5,"a"), (3,"b"), (10,"c")]) @?= ((10,"c"), fromList [(3,"b"), (5,"a")]) 657 | 658 | test_updateMin :: Assertion 659 | test_updateMin = do 660 | updateMin (\ a -> Just ("X" ++ a)) (fromList [(5,"a"), (3,"b")]) @?= fromList [(3, "Xb"), (5, "a")] 661 | updateMin (\ _ -> Nothing) (fromList [(5,"a"), (3,"b")]) @?= singleton 5 "a" 662 | 663 | test_updateMax :: Assertion 664 | test_updateMax = do 665 | updateMax (\ a -> Just ("X" ++ a)) (fromList [(5,"a"), (3,"b")]) @?= fromList [(3, "b"), (5, "Xa")] 666 | updateMax (\ _ -> Nothing) (fromList [(5,"a"), (3,"b")]) @?= singleton 3 "b" 667 | 668 | test_updateMinWithKey :: Assertion 669 | test_updateMinWithKey = do 670 | updateMinWithKey (\ k a -> Just ((show k) ++ ":" ++ a)) (fromList [(5,"a"), (3,"b")]) @?= fromList [(3,"3:b"), (5,"a")] 671 | updateMinWithKey (\ _ _ -> Nothing) (fromList [(5,"a"), (3,"b")]) @?= singleton 5 "a" 672 | 673 | test_updateMaxWithKey :: Assertion 674 | test_updateMaxWithKey = do 675 | updateMaxWithKey (\ k a -> Just ((show k) ++ ":" ++ a)) (fromList [(5,"a"), (3,"b")]) @?= fromList [(3,"b"), (5,"5:a")] 676 | updateMaxWithKey (\ _ _ -> Nothing) (fromList [(5,"a"), (3,"b")]) @?= singleton 3 "b" 677 | 678 | test_minView :: Assertion 679 | test_minView = do 680 | minView (fromList [(5,"a"), (3,"b")]) @?= Just ("b", singleton 5 "a") 681 | minView (empty :: SMap) @?= Nothing 682 | 683 | test_maxView :: Assertion 684 | test_maxView = do 685 | maxView (fromList [(5,"a"), (3,"b")]) @?= Just ("a", singleton 3 "b") 686 | maxView (empty :: SMap) @?= Nothing 687 | 688 | test_minViewWithKey :: Assertion 689 | test_minViewWithKey = do 690 | minViewWithKey (fromList [(5,"a"), (3,"b")]) @?= Just ((3,"b"), singleton 5 "a") 691 | minViewWithKey (empty :: SMap) @?= Nothing 692 | 693 | test_maxViewWithKey :: Assertion 694 | test_maxViewWithKey = do 695 | maxViewWithKey (fromList [(5,"a"), (3,"b")]) @?= Just ((5,"a"), singleton 3 "b") 696 | maxViewWithKey (empty :: SMap) @?= Nothing 697 | 698 | ---------------------------------------------------------------- 699 | -- QuickCheck 700 | ---------------------------------------------------------------- 701 | 702 | prop_singleton :: Int -> Int -> Bool 703 | prop_singleton k x = insert k x empty == singleton k x 704 | 705 | prop_lookup :: Int -> UMap -> Bool 706 | prop_lookup k t = lookup k (insert k () t) /= Nothing 707 | 708 | prop_insertDelete :: Int -> UMap -> Property 709 | prop_insertDelete k t = (lookup k t == Nothing) ==> (delete k (insert k () t) == t) 710 | 711 | prop_deleteNonMember :: Int -> UMap -> Property 712 | prop_deleteNonMember k t = (lookup k t == Nothing) ==> (delete k t == t) 713 | 714 | ---------------------------------------------------------------- 715 | 716 | prop_unionModel :: [(Int,Int)] -> [(Int,Int)] -> Bool 717 | prop_unionModel xs ys 718 | = sort (keys (union (fromList xs) (fromList ys))) 719 | == sort (nub (Prelude.map fst xs ++ Prelude.map fst ys)) 720 | 721 | prop_unionSingleton :: IMap -> Int -> Int -> Bool 722 | prop_unionSingleton t k x = union (singleton k x) t == insert k x t 723 | 724 | prop_unionAssoc :: IMap -> IMap -> IMap -> Bool 725 | prop_unionAssoc t1 t2 t3 = union t1 (union t2 t3) == union (union t1 t2) t3 726 | 727 | prop_unionWith :: IMap -> IMap -> Bool 728 | prop_unionWith t1 t2 = (union t1 t2 == unionWith (\_ y -> y) t2 t1) 729 | 730 | prop_unionSum :: [(Int,Int)] -> [(Int,Int)] -> Bool 731 | prop_unionSum xs ys 732 | = sum (elems (unionWith (+) (fromListWith (+) xs) (fromListWith (+) ys))) 733 | == (sum (Prelude.map snd xs) + sum (Prelude.map snd ys)) 734 | 735 | prop_differenceModel :: [(Int,Int)] -> [(Int,Int)] -> Bool 736 | prop_differenceModel xs ys 737 | = sort (keys (difference (fromListWith (+) xs) (fromListWith (+) ys))) 738 | == sort ((List.\\) (nub (Prelude.map fst xs)) (nub (Prelude.map fst ys))) 739 | 740 | prop_intersectionModel :: [(Int,Int)] -> [(Int,Int)] -> Bool 741 | prop_intersectionModel xs ys 742 | = sort (keys (intersection (fromListWith (+) xs) (fromListWith (+) ys))) 743 | == sort (nub ((List.intersect) (Prelude.map fst xs) (Prelude.map fst ys))) 744 | 745 | prop_intersectionWithModel :: [(Int,Int)] -> [(Int,Int)] -> Bool 746 | prop_intersectionWithModel xs ys 747 | = toList (intersectionWith f (fromList xs') (fromList ys')) 748 | == [(kx, f vx vy ) | (kx, vx) <- List.sort xs', (ky, vy) <- ys', kx == ky] 749 | where xs' = List.nubBy ((==) `on` fst) xs 750 | ys' = List.nubBy ((==) `on` fst) ys 751 | f l r = l + 2 * r 752 | 753 | prop_intersectionWithKeyModel :: [(Int,Int)] -> [(Int,Int)] -> Bool 754 | prop_intersectionWithKeyModel xs ys 755 | = toList (intersectionWithKey f (fromList xs') (fromList ys')) 756 | == [(kx, f kx vx vy) | (kx, vx) <- List.sort xs', (ky, vy) <- ys', kx == ky] 757 | where xs' = List.nubBy ((==) `on` fst) xs 758 | ys' = List.nubBy ((==) `on` fst) ys 759 | f k l r = k + 2 * l + 3 * r 760 | 761 | ---------------------------------------------------------------- 762 | 763 | prop_ordered :: Property 764 | prop_ordered 765 | = forAll (choose (5,100)) $ \n -> 766 | let xs = [(x,()) | x <- [0..n::Int]] 767 | in fromAscList xs == fromList xs 768 | 769 | prop_list :: [Int] -> Bool 770 | prop_list xs = (sort (nub xs) == [x | (x,()) <- toList (fromList [(x,()) | x <- xs])]) 771 | 772 | prop_descList :: [Int] -> Bool 773 | prop_descList xs = (reverse (sort (nub xs)) == [x | (x,()) <- toDescList (fromList [(x,()) | x <- xs])]) 774 | 775 | prop_ascDescList :: [Int] -> Bool 776 | prop_ascDescList xs = toAscList m == reverse (toDescList m) 777 | where m = fromList $ zip xs $ repeat () 778 | 779 | ---------------------------------------------------------------- 780 | 781 | prop_alter :: UMap -> Int -> Bool 782 | prop_alter t k = case lookup k t of 783 | Just _ -> (size t - 1) == size t' && lookup k t' == Nothing 784 | Nothing -> (size t + 1) == size t' && lookup k t' /= Nothing 785 | where 786 | t' = alter f k t 787 | f Nothing = Just () 788 | f (Just ()) = Nothing 789 | 790 | ------------------------------------------------------------------------ 791 | -- Compare against the list model (after nub on keys) 792 | 793 | prop_index :: [Int] -> Property 794 | prop_index xs = length xs > 0 ==> 795 | let m = fromList (zip xs xs) 796 | in xs == [ m ! i | i <- xs ] 797 | 798 | prop_null :: IMap -> Bool 799 | prop_null m = null m == (size m == 0) 800 | 801 | prop_member :: [Int] -> Int -> Bool 802 | prop_member xs n = 803 | let m = fromList (zip xs xs) 804 | in (n `elem` xs) == (n `member` m) 805 | 806 | prop_notmember :: [Int] -> Int -> Bool 807 | prop_notmember xs n = 808 | let m = fromList (zip xs xs) 809 | in (n `notElem` xs) == (n `notMember` m) 810 | 811 | prop_findWithDefault :: [(Int, Int)] -> Property 812 | prop_findWithDefault ys = length ys > 0 ==> 813 | let xs = List.nubBy ((==) `on` fst) ys 814 | m = fromList xs 815 | in and [ findWithDefault 0 i m == j | (i,j) <- xs ] 816 | 817 | prop_findMin :: [(Int, Int)] -> Property 818 | prop_findMin ys = length ys > 0 ==> 819 | let xs = List.nubBy ((==) `on` fst) ys 820 | m = fromList xs 821 | in findMin m == List.minimumBy (comparing fst) xs 822 | 823 | prop_findMax :: [(Int, Int)] -> Property 824 | prop_findMax ys = length ys > 0 ==> 825 | let xs = List.nubBy ((==) `on` fst) ys 826 | m = fromList xs 827 | in findMax m == List.maximumBy (comparing fst) xs 828 | 829 | prop_deleteMinModel :: [(Int, Int)] -> Property 830 | prop_deleteMinModel ys = length ys > 0 ==> 831 | let xs = List.nubBy ((==) `on` fst) ys 832 | m = fromList xs 833 | in toAscList (deleteMin m) == tail (sort xs) 834 | 835 | prop_deleteMaxModel :: [(Int, Int)] -> Property 836 | prop_deleteMaxModel ys = length ys > 0 ==> 837 | let xs = List.nubBy ((==) `on` fst) ys 838 | m = fromList xs 839 | in toAscList (deleteMax m) == init (sort xs) 840 | 841 | prop_filter :: (Int -> Bool) -> [(Int, Int)] -> Property 842 | prop_filter p ys = length ys > 0 ==> 843 | let xs = List.nubBy ((==) `on` fst) ys 844 | m = fromList xs 845 | in filter p m == fromList (List.filter (p . snd) xs) 846 | 847 | prop_partition :: (Int -> Bool) -> [(Int, Int)] -> Property 848 | prop_partition p ys = length ys > 0 ==> 849 | let xs = List.nubBy ((==) `on` fst) ys 850 | m = fromList xs 851 | in partition p m == let (a,b) = (List.partition (p . snd) xs) in (fromList a, fromList b) 852 | 853 | prop_map :: (Int -> Int) -> [(Int, Int)] -> Property 854 | prop_map f ys = length ys > 0 ==> 855 | let xs = List.nubBy ((==) `on` fst) ys 856 | m = fromList xs 857 | in map f m == fromList [ (a, f b) | (a,b) <- xs ] 858 | 859 | prop_fmap :: (Int -> Int) -> [(Int, Int)] -> Property 860 | prop_fmap f ys = length ys > 0 ==> 861 | let xs = List.nubBy ((==) `on` fst) ys 862 | m = fromList xs 863 | in fmap f m == fromList [ (a, f b) | (a,b) <- xs ] 864 | 865 | prop_mapkeys :: (Int -> Int) -> [(Int, Int)] -> Property 866 | prop_mapkeys f ys = length ys > 0 ==> 867 | let xs = List.nubBy ((==) `on` fst) ys 868 | m = fromList xs 869 | in mapKeys f m == (fromList $ List.nubBy ((==) `on` fst) $ reverse [ (f a, b) | (a,b) <- sort xs]) 870 | 871 | prop_splitModel :: Int -> [(Int, Int)] -> Property 872 | prop_splitModel n ys = length ys > 0 ==> 873 | let xs = List.nubBy ((==) `on` fst) ys 874 | (l, r) = split n $ fromList xs 875 | in toAscList l == sort [(k, v) | (k,v) <- xs, k < n] && 876 | toAscList r == sort [(k, v) | (k,v) <- xs, k > n] 877 | 878 | prop_foldr :: Int -> [(Int, Int)] -> Property 879 | prop_foldr n ys = length ys > 0 ==> 880 | let xs = List.nubBy ((==) `on` fst) ys 881 | m = fromList xs 882 | in foldr (+) n m == List.foldr (+) n (List.map snd xs) && 883 | foldr (:) [] m == List.map snd (List.sort xs) && 884 | foldrWithKey (\_ a b -> a + b) n m == List.foldr (+) n (List.map snd xs) && 885 | foldrWithKey (\k _ b -> k + b) n m == List.foldr (+) n (List.map fst xs) && 886 | foldrWithKey (\k x xs -> (k,x):xs) [] m == List.sort xs 887 | 888 | 889 | prop_foldr' :: Int -> [(Int, Int)] -> Property 890 | prop_foldr' n ys = length ys > 0 ==> 891 | let xs = List.nubBy ((==) `on` fst) ys 892 | m = fromList xs 893 | in foldr' (+) n m == List.foldr (+) n (List.map snd xs) && 894 | foldr' (:) [] m == List.map snd (List.sort xs) && 895 | foldrWithKey' (\_ a b -> a + b) n m == List.foldr (+) n (List.map snd xs) && 896 | foldrWithKey' (\k _ b -> k + b) n m == List.foldr (+) n (List.map fst xs) && 897 | foldrWithKey' (\k x xs -> (k,x):xs) [] m == List.sort xs 898 | 899 | prop_foldl :: Int -> [(Int, Int)] -> Property 900 | prop_foldl n ys = length ys > 0 ==> 901 | let xs = List.nubBy ((==) `on` fst) ys 902 | m = fromList xs 903 | in foldl (+) n m == List.foldr (+) n (List.map snd xs) && 904 | foldl (flip (:)) [] m == reverse (List.map snd (List.sort xs)) && 905 | foldlWithKey (\b _ a -> a + b) n m == List.foldr (+) n (List.map snd xs) && 906 | foldlWithKey (\b k _ -> k + b) n m == List.foldr (+) n (List.map fst xs) && 907 | foldlWithKey (\xs k x -> (k,x):xs) [] m == reverse (List.sort xs) 908 | 909 | prop_foldl' :: Int -> [(Int, Int)] -> Property 910 | prop_foldl' n ys = length ys > 0 ==> 911 | let xs = List.nubBy ((==) `on` fst) ys 912 | m = fromList xs 913 | in foldl' (+) n m == List.foldr (+) n (List.map snd xs) && 914 | foldl' (flip (:)) [] m == reverse (List.map snd (List.sort xs)) && 915 | foldlWithKey' (\b _ a -> a + b) n m == List.foldr (+) n (List.map snd xs) && 916 | foldlWithKey' (\b k _ -> k + b) n m == List.foldr (+) n (List.map fst xs) && 917 | foldlWithKey' (\xs k x -> (k,x):xs) [] m == reverse (List.sort xs) 918 | --------------------------------------------------------------------------------