vector-algorithms 0.5.4 → 0.5.4.1
raw patch · 11 files changed
+2/−956 lines, 11 filesdep ~bytestring
Dependency ranges changed: bytestring
Files
- Data/Vector/Algorithms/Combinators.hs +0/−71
- bench/Blocks.hs +0/−62
- bench/LICENSE +0/−30
- bench/Main.hs +0/−195
- bench/RadSieve.hs +0/−97
- bench/vector-algorithms-bench.cabal +0/−22
- tests/Optimal.hs +0/−62
- tests/Properties.hs +0/−185
- tests/Tests.hs +0/−197
- tests/Util.hs +0/−33
- vector-algorithms.cabal +2/−2
− Data/Vector/Algorithms/Combinators.hs
@@ -1,71 +0,0 @@-{-# LANGUAGE Rank2Types, TypeOperators #-}---- ------------------------------------------------------------------------------ |--- Module : Data.Vector.Algorithms.Combinators--- Copyright : (c) 2008-2010 Dan Doel--- Maintainer : Dan Doel <dan.doel@gmail.com>--- Stability : Experimental--- Portability : Non-portable (rank-2 types)------ The purpose of this module is to supply various combinators for commonly--- used idioms for the algorithms in this package. Examples at the time of--- this writing include running an algorithm keyed on some function of the--- elements (but only computing said function once per element), and safely--- applying the algorithms on mutable arrays to immutable arrays.--module Data.Vector.Algorithms.Combinators- (--- , usingKeys--- , usingIxKeys- ) where--import Prelude hiding (length)--import Control.Monad.ST--import Data.Ord--import Data.Vector.Generic--import qualified Data.Vector.Generic.Mutable as M-import qualified Data.Vector.Generic.New as N--{---- | Uses a function to compute a key for each element which the--- algorithm should use in lieu of the actual element. For instance:------ > usingKeys sortBy f arr------ should produce the same results as:------ > sortBy (comparing f) arr------ the difference being that usingKeys computes each key only once--- which can be more efficient for expensive key functions.-usingKeys :: (UA e, UA k, Ord k)- => (forall e'. (UA e') => Comparison e' -> MUArr e' s -> ST s ())- -> (e -> k)- -> MUArr e s- -> ST s ()-usingKeys algo f arr = usingIxKeys algo (const f) arr-{-# INLINE usingKeys #-}---- | As usingKeys, only the key function has access to the array index--- at which each element is stored.-usingIxKeys :: (UA e, UA k, Ord k)- => (forall e'. (UA e') => Comparison e' -> MUArr e' s -> ST s ())- -> (Int -> e -> k)- -> MUArr e s- -> ST s ()-usingIxKeys algo f arr = do- keys <- newMU (lengthMU arr)- fill len keys- algo (comparing fstS) (unsafeZipMU keys arr)- where- len = lengthMU arr- fill k keys- | k < 0 = return ()- | otherwise = readMU arr k >>= writeMU keys k . f k >> fill (k-1) keys-{-# INLINE usingIxKeys #-}--}
− bench/Blocks.hs
@@ -1,62 +0,0 @@-{-# LANGUAGE Rank2Types #-}--module Blocks where--import Control.Monad-import Control.Monad.ST--import Data.Vector.Unboxed.Mutable--import System.CPUTime--import System.Random.Mersenne---- Some conveniences for doing evil stuff in the ST monad.--- All the tests get run in IO, but uvector stuff happens--- in ST, so we temporarily coerce.-clock :: IO Integer-clock = getCPUTime---- Strategies for filling the initial arrays-rand :: (MTRandom e) => MTGen -> Int -> IO e-rand g _ = random g--ascend :: Num e => Int -> IO e-ascend = return . fromIntegral--descend :: Num e => e -> Int -> IO e-descend m n = return $ m - fromIntegral n--modulo :: Integral e => e -> Int -> IO e-modulo m n = return $ fromIntegral n `mod` m---- This is the worst case for the median-of-three quicksort--- used in the introsort implementation.-medianKiller :: Integral e => e -> Int -> IO e-medianKiller m n'- | n < k = return $ if even n then n + 1 else n + k- | otherwise = return $ (n - k + 1) * 2- where- n = fromIntegral n'- k = m `div` 2-{-# INLINE medianKiller #-}--initialize :: (Unbox e) => MVector RealWorld e -> Int -> (Int -> IO e) -> IO ()-initialize arr len fill = init $ len - 1- where init n = fill n >>= unsafeWrite arr n >> when (n > 0) (init $ n - 1)-{-# INLINE initialize #-}--speedTest :: (Unbox e) => Int- -> (Int -> IO e)- -> (MVector RealWorld e -> IO ())- -> IO Integer-speedTest n fill algo = do- arr <- new n- initialize arr n fill- t0 <- clock- algo arr- t1 <- clock- return $ t1 - t0-{-# INLINE speedTest #-}--
− bench/LICENSE
@@ -1,30 +0,0 @@-Copyright (c) 2009 Dan Doel--All rights reserved.--Redistribution and use in source and binary forms, with or without-modification, are permitted provided that the following conditions-are met:--1. Redistributions of source code must retain the above copyright- notice, this list of conditions and the following disclaimer.--2. Redistributions in binary form must reproduce the above copyright- notice, this list of conditions and the following disclaimer in the- documentation and/or other materials provided with the distribution.--3. Neither the name of the author nor the names of his contributors- may be used to endorse or promote products derived from this software- without specific prior written permission.--THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR-IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED-WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE-DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR-ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL-DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS-OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)-HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,-STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN-ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE-POSSIBILITY OF SUCH DAMAGE.
− bench/Main.hs
@@ -1,195 +0,0 @@-{-# LANGUAGE Rank2Types #-}--module Main (main) where--import Prelude hiding (read, length)-import qualified Prelude as P--import Control.Monad.ST-import Control.Monad.Error--import Data.Char-import Data.Ord (comparing)-import Data.List (maximumBy)--import Data.Vector.Unboxed.Mutable--import qualified Data.Vector.Algorithms.Insertion as INS-import qualified Data.Vector.Algorithms.Intro as INT-import qualified Data.Vector.Algorithms.Heap as H-import qualified Data.Vector.Algorithms.Merge as M-import qualified Data.Vector.Algorithms.Radix as R-import qualified Data.Vector.Algorithms.AmericanFlag as AF--import System.Environment-import System.Console.GetOpt-import System.Random.Mersenne--import Blocks---- Does nothing. For testing the speed/heap allocation of the building blocks.-noalgo :: (Unbox e) => MVector RealWorld e -> IO ()-noalgo _ = return ()---- Allocates a temporary buffer, like mergesort for similar purposes as noalgo.-alloc :: (Unbox e) => MVector RealWorld e -> IO ()-alloc arr | len <= 4 = arr `seq` return ()- | otherwise = (new (len `div` 2) :: IO (MVector RealWorld Int)) >> return ()- where len = length arr--displayTime :: String -> Integer -> IO ()-displayTime s elapsed = putStrLn $- s ++ " : " ++ show (fromIntegral elapsed / 1e12) ++ " seconds"--run :: String -> IO Integer -> IO ()-run s t = t >>= displayTime s--sortSuite :: String -> MTGen -> Int -> (MVector RealWorld Int -> IO ()) -> IO ()-sortSuite str g n sort = do- putStrLn $ "Testing: " ++ str- run "Random " $ speedTest n (rand g >=> modulo n) sort- run "Sorted " $ speedTest n ascend sort- run "Reverse-sorted " $ speedTest n (descend n) sort- run "Random duplicates " $ speedTest n (rand g >=> modulo 1000) sort- let m = 4 * (n `div` 4)- run "Median killer " $ speedTest m (medianKiller m) sort--partialSortSuite :: String -> MTGen -> Int -> Int- -> (MVector RealWorld Int -> Int -> IO ()) -> IO ()-partialSortSuite str g n k sort = sortSuite str g n (\a -> sort a k)---- -------------------- Argument handling--- -------------------data Algorithm = DoNothing- | Allocate- | InsertionSort- | IntroSort- | IntroPartialSort- | IntroSelect- | HeapSort- | HeapPartialSort- | HeapSelect- | MergeSort- | RadixSort- | AmericanFlagSort- deriving (Show, Read, Enum, Bounded)--data Options = O { algos :: [Algorithm], elems :: Int, portion :: Int, usage :: Bool } deriving (Show)--defaultOptions :: Options-defaultOptions = O [] 10000 1000 False--type OptionsT = Options -> Either String Options--options :: [OptDescr OptionsT]-options = [ Option ['A'] ["algorithm"] (ReqArg parseAlgo "ALGO")- ("Specify an algorithm to be run. Options:\n" ++ algoOpts)- , Option ['n'] ["num-elems"] (ReqArg parseN "INT")- "Specify the size of arrays in algorithms."- , Option ['k'] ["portion"] (ReqArg parseK "INT")- "Specify the number of elements to partial sort/select in\nrelevant algorithms."- , Option ['?','v'] ["help"] (NoArg $ \o -> Right $ o { usage = True })- "Show options."- ]- where- allAlgos :: [Algorithm]- allAlgos = [minBound .. maxBound]- algoOpts = fmt allAlgos- fmt (x:y:zs) = '\t' : pad (show x) ++ show y ++ "\n" ++ fmt zs- fmt [x] = '\t' : show x ++ "\n"- fmt [] = ""- size = (" " ++) . maximumBy (comparing P.length) . map show $ allAlgos- pad str = zipWith const (str ++ repeat ' ') size--parseAlgo :: String -> Options -> Either String Options-parseAlgo "None" o = Right $ o { algos = [] }-parseAlgo "All" o = Right $ o { algos = [DoNothing .. AmericanFlagSort] }-parseAlgo s o = leftMap (\e -> "Unrecognized algorithm `" ++ e ++ "'")- . fmap (\v -> o { algos = v : algos o }) $ readEither s--leftMap :: (a -> b) -> Either a c -> Either b c-leftMap f (Left a) = Left (f a)-leftMap _ (Right c) = Right c--parseNum :: (Int -> Options) -> String -> Either String Options-parseNum f = leftMap (\e -> "Invalid numeric argument `" ++ e ++ "'") . fmap f . readEither--parseN, parseK :: String -> Options -> Either String Options-parseN s o = parseNum (\n -> o { elems = n }) s-parseK s o = parseNum (\k -> o { portion = k }) s--readEither :: Read a => String -> Either String a-readEither s = case reads s of- [(x,t)] | all isSpace t -> Right x- _ -> Left s--runTest :: MTGen -> Int -> Int -> Algorithm -> IO ()-runTest g n k alg = case alg of- DoNothing -> sortSuite "no algorithm" g n noalgo- Allocate -> sortSuite "allocate" g n alloc- InsertionSort -> sortSuite "insertion sort" g n insertionSort- IntroSort -> sortSuite "introsort" g n introSort- IntroPartialSort -> partialSortSuite "partial introsort" g n k introPSort- IntroSelect -> partialSortSuite "introselect" g n k introSelect- HeapSort -> sortSuite "heap sort" g n heapSort- HeapPartialSort -> partialSortSuite "partial heap sort" g n k heapPSort- HeapSelect -> partialSortSuite "heap select" g n k heapSelect- MergeSort -> sortSuite "merge sort" g n mergeSort- RadixSort -> sortSuite "radix sort" g n radixSort- AmericanFlagSort -> sortSuite "flag sort" g n flagSort- _ -> putStrLn $ "Currently unsupported algorithm: " ++ show alg--mergeSort :: MVector RealWorld Int -> IO ()-mergeSort v = M.sort v-{-# NOINLINE mergeSort #-}--introSort :: MVector RealWorld Int -> IO ()-introSort v = INT.sort v-{-# NOINLINE introSort #-}--introPSort :: MVector RealWorld Int -> Int -> IO ()-introPSort v k = INT.partialSort v k-{-# NOINLINE introPSort #-}--introSelect :: MVector RealWorld Int -> Int -> IO ()-introSelect v k = INT.select v k-{-# NOINLINE introSelect #-}--heapSort :: MVector RealWorld Int -> IO ()-heapSort v = H.sort v-{-# NOINLINE heapSort #-}--heapPSort :: MVector RealWorld Int -> Int -> IO ()-heapPSort v k = H.partialSort v k-{-# NOINLINE heapPSort #-}--heapSelect :: MVector RealWorld Int -> Int -> IO ()-heapSelect v k = H.select v k-{-# NOINLINE heapSelect #-}--insertionSort :: MVector RealWorld Int -> IO ()-insertionSort v = INS.sort v-{-# NOINLINE insertionSort #-}--radixSort :: MVector RealWorld Int -> IO ()-radixSort v = R.sort v-{-# NOINLINE radixSort #-}--flagSort :: MVector RealWorld Int -> IO ()-flagSort v = AF.sort v-{-# NOINLINE flagSort #-}--main :: IO ()-main = do args <- getArgs- gen <- getStdGen- case getOpt Permute options args of- (fs, _, []) -> case foldl (>>=) (Right defaultOptions) fs of- Left err -> putStrLn $ usageInfo err options- Right opts | not (usage opts) ->- mapM_ (runTest gen (elems opts) (portion opts)) (algos opts)- | otherwise -> putStrLn $ usageInfo "uvector-algorithms-bench" options- (_, _, errs) -> putStrLn $ usageInfo (concat errs) options--
− bench/RadSieve.hs
@@ -1,97 +0,0 @@--- ------------------------------------------------------------------------ Module : RadSieve--- Copyright : (c) 2009 Dan Doel------ --------------------------------------------------------------------- An implementation of a radical sieve, inspired by solving Project--- Euler problem #124.------ Reproduction fo the problem text:------ The radical of n, rad(n), is the product of distinct prime factors--- of n. For example, 504 = 23 × 32 × 7, so rad(504) = 2 × 3 × 7 = 42.------ If we calculate rad(n) for 1 ≤ n ≤ 10, then sort them on rad(n),--- and sorting on n if the radical values are equal, we get:------ Unsorted Sorted--- n rad(n) n rad(n) k--- 1 1 1 1 1--- 2 2 2 2 2--- 3 3 4 2 3--- 4 2 8 2 4--- 5 5 3 3 5--- 6 6 9 3 6--- 7 7 5 5 7--- 8 2 6 6 8--- 9 3 7 7 9--- 10 10 10 10 10------ Let E(k) be the kth element in the sorted n column; for example,--- E(4) = 8 and E(6) = 9.------ If rad(n) is sorted for 1 ≤ n ≤ 100000, find E(10000).--module RadSieve where--import Control.Monad-import Control.Monad.ST--import Data.Array.Vector---- Radicals can be sieved as follows:--- set a[1,n] = 1--- for i from 2 to n--- if a[i] == 1 -- i must be prime--- then a[j*i] *= i for positive integers j, j*i <= n--- else do nothing -- i is composite, so its prime factors--- -- have been accounted for------ This sieves for radicals up to the given integer.-radSieve :: Int -> ST s (MUArr Int s)-radSieve n = do arr <- newMU (n + 1)- fill arr n- sieve arr 1- return arr- where- fill arr i | i < 0 = return ()- | otherwise = writeMU arr i 1 >> fill arr (i-1)- sieve arr i | n < i = return ()- | otherwise = do e <- readMU arr i- when (e == 1) $ mark arr i i- sieve arr (i+1)- mark arr p j | n < j = return ()- | otherwise = readMU arr j >>= writeMU arr j . (*p)- >> mark arr p (j+p)---- Computes the answer to the above Project Euler problem. The correct--- answer is only generated for a stable sorting function.-stableSortedRad :: Int -> Int- -> (forall s e. UA e => Comparison e -> MUArr e s -> ST s ()) - -> Int-stableSortedRad n k sortBy = runST (do rads <- radSieve n- index <- newMU (n + 1)- fillUp index n- sortBy (comparing fstS)- (unsafeZipMU rads index)- readMU k index)- where- fillUp arr k | k < 0 = return ()- | otherwise = writeMU arr k k >> fillUp arr (k-1)---- Computes the answer to the above Project Euler problem. This version--- will generate the correct answer even for unstable sorts, but may be--- marginally slower.-unstableSortedRad :: Int -> Int- -> (forall s e. UA e => Comparison e -> MUArr e s -> ST s ()) - -> Int-unstableSortedRad n k sortBy = runST (do rads <- radSieve n- index <- newMU (n + 1)- fillUp index n- sortBy compare (unsafeZipMU rads index)- readMU k index)- where- fillUp arr k | k < 0 = return ()- | otherwise = writeMU arr k k >> fillUp arr (k-1)-
− bench/vector-algorithms-bench.cabal
@@ -1,22 +0,0 @@-name: vector-algorithms-bench-version: 0.3-license: BSD3-license-file: LICENSE-author: Dan Doel-maintainer: Dan Doel <dan.doel@gmail.com>-homepage: http://code.haskell.org/~doio/-category: Benchmark-synopsis: Benchmarks for vector-algorithms-description: A suite of various benchmarks for verifying the- performance of the algorithms in vector-algorithms.-build-type: Simple-cabal-version: >= 1.2--executable vec-bench- build-depends: base, mersenne-random, vector, vector-algorithms, mtl-- ghc-options: -Wall -Odph- main-is: Main.hs-- extensions:- Rank2Types
− tests/Optimal.hs
@@ -1,62 +0,0 @@-{-# LANGUAGE TypeOperators, FlexibleContexts #-}---- Exhaustive test sets for proper sorting and stability of--- optimal sorts--module Optimal where--import Control.Arrow-import Control.Monad--import Data.List-import Data.Function--import Data.Vector.Generic hiding (map, zip, concatMap, (++), replicate, foldM)--interleavings :: [a] -> [a] -> [[a]]-interleavings [ ] ys = [ys]-interleavings xs [ ] = [xs]-interleavings xs@(x:xt) ys@(y:yt) = map (x:) (interleavings xt ys)- ++ map (y:) (interleavings xs yt)--monotones :: Int -> Int -> [[Int]]-monotones k = atLeastOne 0- where- atLeastOne i 0 = [[]]- atLeastOne i n = map (i:) $ picks i (n-1)- picks _ 0 = [[]]- picks i n | i >= k = [replicate n k]- | otherwise = map (i:) (picks i (n-1)) ++ atLeastOne (i+1) n---stability :: (Vector v (Int,Int)) => Int -> [v (Int, Int)]-stability n = concatMap ( map fromList- . foldM interleavings []- . groupBy ((==) `on` fst)- . flip zip [0..])- $ monotones (n-2) n--sort2 :: (Vector v Int) => [v Int]-sort2 = map fromList $ permutations [0,1]--stability2 :: (Vector v (Int,Int)) => [v (Int, Int)]-stability2 = [fromList [(0, 0), (0, 1)]]--sort3 :: (Vector v Int) => [v Int]-sort3 = map fromList $ permutations [0..2]--{--stability3 :: [UArr (Int :*: Int)]-stability3 = map toU [ [0:*:0, 0:*:1, 0:*:2]- , [0:*:0, 0:*:1, 1:*:2]- , [0:*:0, 1:*:2, 0:*:1]- , [1:*:2, 0:*:0, 0:*:1]- , [0:*:0, 1:*:1, 1:*:2]- , [1:*:1, 0:*:0, 1:*:2]- , [1:*:1, 1:*:2, 0:*:0]- ]--}--sort4 :: (Vector v Int) => [v Int]-sort4 = map fromList $ permutations [0..3]-
− tests/Properties.hs
@@ -1,185 +0,0 @@-{-# LANGUAGE RankNTypes, FlexibleContexts #-}--module Properties where--import Prelude--import Optimal--import Control.Monad-import Control.Monad.ST--import Data.List-import Data.Ord--import Data.Vector (Vector)-import qualified Data.Vector as V--import Data.Vector.Mutable (MVector)-import qualified Data.Vector.Mutable as MV--import Data.Vector.Generic (modify)--import qualified Data.Vector.Generic.Mutable as G--import Data.Vector.Algorithms.Optimal (Comparison)-import Data.Vector.Algorithms.Radix (radix, passes, size)--import qualified Data.Map as M--import Test.QuickCheck--import Util--prop_sorted :: (Ord e) => Vector e -> Property-prop_sorted arr | V.length arr < 2 = property True- | otherwise = check (V.head arr) (V.tail arr)- where- check e arr | V.null arr = property True- | otherwise = e <= V.head arr .&. check (V.head arr) (V.tail arr)--prop_empty :: (Ord e) => (forall s. MV.MVector s e -> ST s ()) -> Property-prop_empty algo = prop_sorted (modify algo $ V.fromList [])--prop_fullsort :: (Ord e)- => (forall s mv. G.MVector mv e => mv s e -> ST s ()) -> Vector e -> Property-prop_fullsort algo arr = prop_sorted $ modify algo arr--{--prop_schwartzian :: (UA e, UA k, Ord k)- => (e -> k)- -> (forall e s. (UA e) => (e -> e -> Ordering) -> MUArr e s -> ST s ())- -> UArr e -> Property-prop_schwartzian f algo arr- | lengthU arr < 2 = property True- | otherwise = let srt = modify (algo `usingKeys` f) arr- in check (headU srt) (tailU srt)- where- check e arr | nullU arr = property True- | otherwise = f e <= f (headU arr) .&. check (headU arr) (tailU arr)--}--longGen :: (Arbitrary e) => Int -> Gen (Vector e)-longGen k = liftM2 (\l r -> V.fromList (l ++ r)) (vectorOf k arbitrary) arbitrary--sanity :: Int-sanity = 100--prop_partialsort :: (Ord e, Arbitrary e, Show e)- => (forall s mv. G.MVector mv e => mv s e -> Int -> ST s ())- -> Positive Int -> Property-prop_partialsort = prop_sized $ \algo k ->- prop_sorted . V.take k . modify algo--prop_sized_empty :: (Ord e) => (forall s. MV.MVector s e -> Int -> ST s ()) -> Property-prop_sized_empty algo = prop_empty (flip algo 0) .&&. prop_empty (flip algo 10)--prop_select :: (Ord e, Arbitrary e, Show e)- => (forall s mv. G.MVector mv e => mv s e -> Int -> ST s ())- -> Positive Int -> Property-prop_select = prop_sized $ \algo k arr ->- let vec' = modify algo arr- l = V.slice 0 k vec'- r = V.slice k (V.length vec' - k) vec'- in V.all (\e -> V.all (e <=) r) l--prop_sized :: (Arbitrary e, Show e, Testable prop)- => ((forall s mv. G.MVector mv e => mv s e -> ST s ())- -> Int -> Vector e -> prop)- -> (forall s mv. G.MVector mv e => mv s e -> Int -> ST s ())- -> Positive Int -> Property-prop_sized prop algo (Positive k) =- let k' = k `mod` sanity- in forAll (longGen k') $ prop (\marr -> algo marr k') k'--prop_stable :: (forall e s mv. G.MVector mv e => Comparison e -> mv s e -> ST s ())- -> Vector Int -> Property--- prop_stable algo arr = property $ modify algo arr == arr-prop_stable algo arr = stable $ modify (algo (comparing fst)) $ V.zip arr ix- where- ix = V.fromList [1 .. V.length arr]--stable arr | V.null arr = property True- | otherwise = let (e, i) = V.head arr- in V.all (\(e', i') -> e < e' || i < i') (V.tail arr)- .&. stable (V.tail arr)--prop_stable_radix :: (forall e s mv. G.MVector mv e => Int -> Int -> (Int -> e -> Int) - -> mv s e -> ST s ())- -> Vector Int -> Property-prop_stable_radix algo arr =- stable . modify (algo (passes e) (size e) (\k (e, _) -> radix k e))- $ V.zip arr ix- where- ix = V.fromList [1 .. V.length arr]- e = V.head arr- -prop_optimal :: Int- -> (forall e s mv. G.MVector mv e => Comparison e -> mv s e -> Int -> ST s ())- -> Property-prop_optimal n algo = label "sorting" sortn .&. label "stability" stabn- where- arrn = V.fromList [0..n-1]- sortn = all ( (== arrn)- . modify (\a -> algo compare a 0)- . V.fromList)- $ permutations [0..n-1]- stabn = all ( (== arrn)- . snd- . V.unzip- . modify (\a -> algo (comparing fst) a 0))- $ stability n--type Bag e = M.Map e Int--toBag :: (Ord e) => Vector e -> Bag e-toBag = M.fromListWith (+) . flip zip (repeat 1) . V.toList--prop_permutation :: (Ord e) => (forall s mv. G.MVector mv e => mv s e -> ST s ())- -> Vector e -> Property-prop_permutation algo arr = property $ - toBag arr == toBag (modify algo arr)--newtype SortedVec e = Sorted (Vector e)--instance (Show e) => Show (SortedVec e) where- show (Sorted a) = show a--instance (Arbitrary e, Ord e) => Arbitrary (SortedVec e) where- arbitrary = fmap (Sorted . V.fromList . sort)- $ liftM2 (++) (vectorOf 20 arbitrary) arbitrary--ixRanges :: Vector e -> Gen (Int, Int)-ixRanges vec = do i <- fmap (`mod` len) arbitrary- j <- fmap (`mod` len) arbitrary- return $ if i < j then (i, j) else (j, i)- where len = V.length vec--prop_search_inrange :: (Ord e)- => (forall s. MVector s e -> e -> Int -> Int -> ST s Int)- -> SortedVec e -> e -> Property-prop_search_inrange algo (Sorted arr) e = forAll (ixRanges arr) $ \(i, j) ->- let k = runST (mfromList (V.toList arr) >>= \marr -> algo marr e i j)- in property $ i <= k && k <= j- where- len = V.length arr--prop_search_insert :: (e -> e -> Bool) -> (e -> e -> Bool)- -> (forall s. MVector s e -> e -> ST s Int)- -> SortedVec e -> e -> Property-prop_search_insert lo hi algo (Sorted arr) e =- property $ (k == 0 || (arr V.! (k-1)) `lo` e)- && (k == len || (arr V.! k) `hi` e)- where- len = V.length arr- k = runST (mfromList (V.toList arr) >>= \marr -> algo marr e)--prop_search_lowbound :: (Ord e)- => (forall s. MVector s e -> e -> ST s Int)- -> SortedVec e -> e -> Property-prop_search_lowbound = prop_search_insert (<) (>=)--prop_search_upbound :: (Ord e)- => (forall s. MVector s e -> e -> ST s Int)- -> SortedVec e -> e -> Property-prop_search_upbound = prop_search_insert (<=) (>)
− tests/Tests.hs
@@ -1,197 +0,0 @@-{-# LANGUAGE ImpredicativeTypes, RankNTypes, TypeOperators, FlexibleContexts #-}--module Main (main) where--import Properties--import Util--import Test.QuickCheck--import Control.Monad-import Control.Monad.ST--import Data.Int-import Data.Word--import qualified Data.ByteString as B--import Data.Vector (Vector)-import qualified Data.Vector as V--import Data.Vector.Generic.Mutable (MVector)-import qualified Data.Vector.Generic.Mutable as MV--import qualified Data.Vector.Algorithms.Insertion as INS-import qualified Data.Vector.Algorithms.Intro as INT-import qualified Data.Vector.Algorithms.Merge as M-import qualified Data.Vector.Algorithms.Radix as R-import qualified Data.Vector.Algorithms.Heap as H-import qualified Data.Vector.Algorithms.Optimal as O-import qualified Data.Vector.Algorithms.AmericanFlag as AF--import qualified Data.Vector.Algorithms.Search as SR--type Algo e r = forall s mv. MVector mv e => mv s e -> ST s r-type SizeAlgo e r = forall s mv. MVector mv e => mv s e -> Int -> ST s r-type BoundAlgo e r = forall s mv. MVector mv e => mv s e -> Int -> Int -> ST s r--args = stdArgs- { maxSuccess = 1000- , maxDiscard = 200- }--check_Int_sort = forM_ algos $ \(name,algo) ->- quickCheckWith args (label name . prop_fullsort algo)- where- algos :: [(String, Algo Int ())]- algos = [ ("introsort", INT.sort)- , ("insertion sort", INS.sort)- , ("merge sort", M.sort)- , ("heapsort", H.sort)- ]--check_Int_partialsort = forM_ algos $ \(name,algo) ->- quickCheckWith args (label name . prop_partialsort algo)- where- algos :: [(String, SizeAlgo Int ())]- algos = [ ("intro-partialsort", INT.partialSort)- , ("heap partialsort", H.partialSort)- ]--check_Int_select = forM_ algos $ \(name,algo) ->- quickCheckWith args (label name . prop_select algo)- where- algos :: [(String, SizeAlgo Int ())]- algos = [ ("intro-select", INT.select)- , ("heap select", H.select)- ]--check_radix_sorts = do- qc (label "radix Word8" . prop_fullsort (R.sort :: Algo Word8 ()))- qc (label "radix Word16" . prop_fullsort (R.sort :: Algo Word16 ()))- qc (label "radix Word32" . prop_fullsort (R.sort :: Algo Word32 ()))- qc (label "radix Word64" . prop_fullsort (R.sort :: Algo Word64 ()))- qc (label "radix Word" . prop_fullsort (R.sort :: Algo Word ()))- qc (label "radix Int8" . prop_fullsort (R.sort :: Algo Int8 ()))- qc (label "radix Int16" . prop_fullsort (R.sort :: Algo Int16 ()))- qc (label "radix Int32" . prop_fullsort (R.sort :: Algo Int32 ()))- qc (label "radix Int64" . prop_fullsort (R.sort :: Algo Int64 ()))- qc (label "radix Int" . prop_fullsort (R.sort :: Algo Int ()))- qc (label "radix (Int, Int)" . prop_fullsort (R.sort :: Algo (Int, Int) ()))-- qc (label "flag Word8" . prop_fullsort (AF.sort :: Algo Word8 ()))- qc (label "flag Word16" . prop_fullsort (AF.sort :: Algo Word16 ()))- qc (label "flag Word32" . prop_fullsort (AF.sort :: Algo Word32 ()))- qc (label "flag Word64" . prop_fullsort (AF.sort :: Algo Word64 ()))- qc (label "flag Word" . prop_fullsort (AF.sort :: Algo Word ()))- qc (label "flag Int8" . prop_fullsort (AF.sort :: Algo Int8 ()))- qc (label "flag Int16" . prop_fullsort (AF.sort :: Algo Int16 ()))- qc (label "flag Int32" . prop_fullsort (AF.sort :: Algo Int32 ()))- qc (label "flag Int64" . prop_fullsort (AF.sort :: Algo Int64 ()))- qc (label "flag Int" . prop_fullsort (AF.sort :: Algo Int ()))- qc (label "flag ByteString" . prop_fullsort (AF.sort :: Algo B.ByteString ()))- where- qc algo = quickCheckWith args algo--{--check_schwartzian = do- quickCheckWith args (prop_schwartzian i2w INS.sortBy)- where- i2w :: Int -> Word- i2w = fromIntegral--}--check_stable = do quickCheckWith args (label "merge sort" . prop_stable M.sortBy)- quickCheckWith args (label "radix sort" . prop_stable_radix R.sortBy)--check_optimal = do qc . label "size 2" $ prop_optimal 2 O.sort2ByOffset- qc . label "size 3" $ prop_optimal 3 O.sort3ByOffset- qc . label "size 4" $ prop_optimal 4 O.sort4ByOffset- where- qc = quickCheck--check_permutation = do- qc $ label "introsort" . prop_permutation (INT.sort :: Algo Int ())- qc $ label "intropartial" . prop_sized (const . prop_permutation)- (INT.partialSort :: SizeAlgo Int ())- qc $ label "introselect" . prop_sized (const . prop_permutation)- (INT.select :: SizeAlgo Int ())- qc $ label "heapsort" . prop_permutation (H.sort :: Algo Int ())- qc $ label "heappartial" . prop_sized (const . prop_permutation)- (H.partialSort :: SizeAlgo Int ())- qc $ label "heapselect" . prop_sized (const . prop_permutation)- (H.select :: SizeAlgo Int ())- qc $ label "mergesort" . prop_permutation (M.sort :: Algo Int ())- qc $ label "radix I8" . prop_permutation (R.sort :: Algo Int8 ())- qc $ label "radix I16" . prop_permutation (R.sort :: Algo Int16 ())- qc $ label "radix I32" . prop_permutation (R.sort :: Algo Int32 ())- qc $ label "radix I64" . prop_permutation (R.sort :: Algo Int64 ())- qc $ label "radix Int" . prop_permutation (R.sort :: Algo Int ())- qc $ label "radix W8" . prop_permutation (R.sort :: Algo Word8 ())- qc $ label "radix W16" . prop_permutation (R.sort :: Algo Word16 ())- qc $ label "radix W32" . prop_permutation (R.sort :: Algo Word32 ())- qc $ label "radix W64" . prop_permutation (R.sort :: Algo Word64 ())- qc $ label "radix Word" . prop_permutation (R.sort :: Algo Word ())- qc $ label "flag I8" . prop_permutation (AF.sort :: Algo Int8 ())- qc $ label "flag I16" . prop_permutation (AF.sort :: Algo Int16 ())- qc $ label "flag I32" . prop_permutation (AF.sort :: Algo Int32 ())- qc $ label "flag I64" . prop_permutation (AF.sort :: Algo Int64 ())- qc $ label "flag Int" . prop_permutation (AF.sort :: Algo Int ())- qc $ label "flag W8" . prop_permutation (AF.sort :: Algo Word8 ())- qc $ label "flag W16" . prop_permutation (AF.sort :: Algo Word16 ())- qc $ label "flag W32" . prop_permutation (AF.sort :: Algo Word32 ())- qc $ label "flag W64" . prop_permutation (AF.sort :: Algo Word64 ())- qc $ label "flag Word" . prop_permutation (AF.sort :: Algo Word ())- qc $ label "flag ByteString" . prop_permutation (AF.sort :: Algo B.ByteString ())- where- qc prop = quickCheckWith args prop--check_corners = do- qc "introsort empty" $ prop_empty (INT.sort :: Algo Int ())- qc "intropartial empty" $ prop_sized_empty (INT.partialSort :: SizeAlgo Int ())- qc "introselect empty" $ prop_sized_empty (INT.select :: SizeAlgo Int ())- qc "heapsort empty" $ prop_empty (H.sort :: Algo Int ())- qc "heappartial empty" $ prop_sized_empty (H.partialSort :: SizeAlgo Int ())- qc "heapselect empty" $ prop_sized_empty (H.select :: SizeAlgo Int ())- qc "mergesort empty" $ prop_empty (M.sort :: Algo Int ())- qc "radixsort empty" $ prop_empty (R.sort :: Algo Int ())- qc "flagsort empty" $ prop_empty (AF.sort :: Algo Int ())- where- qc s prop = quickCheckWith (stdArgs { maxSuccess = 2 }) (label s prop)--type SAlgo e r = forall s mv. MVector mv e => mv s e -> e -> ST s r-type BoundSAlgo e r = forall s mv. MVector mv e => mv s e -> e -> Int -> Int -> ST s r--check_search_range = do- qc $ (label "binarySearchL" .)- . prop_search_inrange (SR.binarySearchLByBounds compare :: BoundSAlgo Int Int)- qc $ (label "binarySearchL lo-bound" .)- . prop_search_lowbound (SR.binarySearchL :: SAlgo Int Int)- qc $ (label "binarySearch" .)- . prop_search_inrange (SR.binarySearchByBounds compare :: BoundSAlgo Int Int)- qc $ (label "binarySearchR" .)- . prop_search_inrange (SR.binarySearchRByBounds compare :: BoundSAlgo Int Int)- qc $ (label "binarySearchR hi-bound" .)- . prop_search_upbound (SR.binarySearchR :: SAlgo Int Int)- where- qc prop = quickCheckWith args prop--main = do putStrLn "Int tests:"- check_Int_sort- check_Int_partialsort- check_Int_select- putStrLn "Radix sort tests:"- check_radix_sorts--- putStrLn "Schwartzian transform (Int -> Word):"--- check_schwartzian- putStrLn "Stability:"- check_stable- putStrLn "Optimals:"- check_optimal- putStrLn "Permutation:"- check_permutation- putStrLn "Search in range:"- check_search_range- putStrLn "Corner cases:"- check_corners
− tests/Util.hs
@@ -1,33 +0,0 @@-{-# LANGUAGE TypeOperators #-}--module Util where--import Control.Monad-import Control.Monad.ST--import Data.Word-import Data.Int--import qualified Data.ByteString as B--import qualified Data.Vector as V--import Data.Vector.Mutable hiding (length)--import Test.QuickCheck---mfromList :: [e] -> ST s (MVector s e)-mfromList l = do v <- new (length l)- fill l 0 v- where- fill [] _ v = return v- fill (x:xs) i v = do write v i x- fill xs (i+1) v--instance (Arbitrary e) => Arbitrary (V.Vector e) where- arbitrary = fmap V.fromList arbitrary--instance Arbitrary B.ByteString where- arbitrary = B.pack `fmap` arbitrary-
vector-algorithms.cabal view
@@ -1,5 +1,5 @@ Name: vector-algorithms-Version: 0.5.4+Version: 0.5.4.1 License: BSD3 License-File: LICENSE Author: Dan Doel@@ -29,7 +29,7 @@ Build-Depends: base >= 3 && < 5, vector >= 0.6 && < 0.10, primitive >=0.3 && <0.5,- bytestring >= 0.9 && < 0.10+ bytestring >= 0.9 && < 1.0 Exposed-Modules: Data.Vector.Algorithms.Optimal