diff --git a/Data/Vector/Algorithms/Combinators.hs b/Data/Vector/Algorithms/Combinators.hs new file mode 100644 --- /dev/null +++ b/Data/Vector/Algorithms/Combinators.hs @@ -0,0 +1,71 @@ +{-# LANGUAGE Rank2Types, TypeOperators #-} + +-- --------------------------------------------------------------------------- +-- | +-- Module : Data.Vector.Algorithms.Combinators +-- Copyright : (c) 2008-2010 Dan Doel +-- Maintainer : Dan Doel +-- 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 #-} +-} diff --git a/bench/Blocks.hs b/bench/Blocks.hs new file mode 100644 --- /dev/null +++ b/bench/Blocks.hs @@ -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 #-} + + diff --git a/bench/LICENSE b/bench/LICENSE new file mode 100644 --- /dev/null +++ b/bench/LICENSE @@ -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. diff --git a/bench/Main.hs b/bench/Main.hs new file mode 100644 --- /dev/null +++ b/bench/Main.hs @@ -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 + + diff --git a/bench/RadSieve.hs b/bench/RadSieve.hs new file mode 100644 --- /dev/null +++ b/bench/RadSieve.hs @@ -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) + diff --git a/bench/vector-algorithms-bench.cabal b/bench/vector-algorithms-bench.cabal new file mode 100644 --- /dev/null +++ b/bench/vector-algorithms-bench.cabal @@ -0,0 +1,22 @@ +name: vector-algorithms-bench +version: 0.3 +license: BSD3 +license-file: LICENSE +author: Dan Doel +maintainer: Dan Doel +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 diff --git a/tests/Optimal.hs b/tests/Optimal.hs new file mode 100644 --- /dev/null +++ b/tests/Optimal.hs @@ -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] + diff --git a/tests/Properties.hs b/tests/Properties.hs new file mode 100644 --- /dev/null +++ b/tests/Properties.hs @@ -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 (<=) (>) diff --git a/tests/Tests.hs b/tests/Tests.hs new file mode 100644 --- /dev/null +++ b/tests/Tests.hs @@ -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 diff --git a/tests/Util.hs b/tests/Util.hs new file mode 100644 --- /dev/null +++ b/tests/Util.hs @@ -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 + diff --git a/vector-algorithms.cabal b/vector-algorithms.cabal --- a/vector-algorithms.cabal +++ b/vector-algorithms.cabal @@ -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