vector-algorithms 0.5.3.1 → 0.5.4
raw patch · 11 files changed
+956/−2 lines, 11 filesdep ~bytestring
Dependency ranges changed: bytestring
Files
- Data/Vector/Algorithms/Combinators.hs +71/−0
- bench/Blocks.hs +62/−0
- bench/LICENSE +30/−0
- bench/Main.hs +195/−0
- bench/RadSieve.hs +97/−0
- bench/vector-algorithms-bench.cabal +22/−0
- tests/Optimal.hs +62/−0
- tests/Properties.hs +185/−0
- tests/Tests.hs +197/−0
- tests/Util.hs +33/−0
- vector-algorithms.cabal +2/−2
+ Data/Vector/Algorithms/Combinators.hs view
@@ -0,0 +1,71 @@+{-# 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 view
@@ -0,0 +1,62 @@+{-# 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 view
@@ -0,0 +1,30 @@+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 view
@@ -0,0 +1,195 @@+{-# 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 view
@@ -0,0 +1,97 @@+-- ------------------------------------------------------------------+--+-- 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 view
@@ -0,0 +1,22 @@+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 view
@@ -0,0 +1,62 @@+{-# 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 view
@@ -0,0 +1,185 @@+{-# 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 view
@@ -0,0 +1,197 @@+{-# 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 view
@@ -0,0 +1,33 @@+{-# 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.3.1+Version: 0.5.4 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+ bytestring >= 0.9 && < 0.10 Exposed-Modules: Data.Vector.Algorithms.Optimal