vector-algorithms 0.7.0.1 → 0.7.0.2
raw patch · 14 files changed
+399/−325 lines, 14 filesdep ~basenew-component:exe:simple-benchnew-uploader
Dependency ranges changed: base
Files
- bench/Blocks.hs +0/−62
- bench/Main.hs +0/−201
- bench/simple/Blocks.hs +62/−0
- bench/simple/Main.hs +201/−0
- src/Data/Vector/Algorithms/AmericanFlag.hs +64/−30
- src/Data/Vector/Algorithms/Common.hs +10/−0
- src/Data/Vector/Algorithms/Heap.hs +1/−1
- src/Data/Vector/Algorithms/Insertion.hs +1/−1
- src/Data/Vector/Algorithms/Intro.hs +5/−5
- src/Data/Vector/Algorithms/Merge.hs +3/−3
- src/Data/Vector/Algorithms/Radix.hs +1/−1
- src/Data/Vector/Algorithms/Search.hs +3/−3
- tests/properties/Tests.hs +12/−8
- vector-algorithms.cabal +36/−10
− 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.MWC (GenIO, Variate(..))---- 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 :: Variate e => GenIO -> Int -> IO e-rand g _ = uniform 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/Main.hs
@@ -1,201 +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 qualified Data.Vector.Algorithms.Tim as T--import System.Environment-import System.Console.GetOpt-import System.Random.MWC--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 -> GenIO -> 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 -> GenIO -> 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- | TimSort- 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 :: GenIO -> 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- TimSort -> sortSuite "tim sort" g n timSort- _ -> 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 #-}--timSort :: MVector RealWorld Int -> IO ()-timSort v = T.sort v-{-# NOINLINE timSort #-}--main :: IO ()-main = getArgs >>= \args -> withSystemRandom $ \gen ->- 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/simple/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.MWC (GenIO, Variate(..))++-- 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 :: Variate e => GenIO -> Int -> IO e+rand g _ = uniform 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 = initial $ len - 1+ where initial n = fill n >>= unsafeWrite arr n >> when (n > 0) (initial $ 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/simple/Main.hs view
@@ -0,0 +1,201 @@+{-# 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 qualified Data.Vector.Algorithms.Tim as T++import System.Environment+import System.Console.GetOpt+import System.Random.MWC++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 -> GenIO -> 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 -> GenIO -> 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+ | TimSort+ 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 :: GenIO -> 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+ TimSort -> sortSuite "tim sort" g n timSort+ _ -> 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 #-}++timSort :: MVector RealWorld Int -> IO ()+timSort v = T.sort v+{-# NOINLINE timSort #-}++main :: IO ()+main = getArgs >>= \args -> withSystemRandom $ \gen ->+ 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 "vector-algorithms-bench" options+ (_, _, errs) -> putStrLn $ usageInfo (concat errs) options++
src/Data/Vector/Algorithms/AmericanFlag.hs view
@@ -36,6 +36,8 @@ import Control.Monad import Control.Monad.Primitive +import Data.Proxy+ import Data.Word import Data.Int import Data.Bits@@ -51,31 +53,35 @@ import qualified Data.Vector.Algorithms.Insertion as I +import Foreign.Storable+ -- | The methods of this class specify the information necessary to sort -- arrays using the default ordering. The name 'Lexicographic' is meant -- to convey that index should return results in a similar way to indexing -- into a string. class Lexicographic e where- -- | Given a representative of a stripe and an index number, this- -- function should determine whether to stop sorting.- terminate :: e -> Int -> Bool+ -- | Computes the length of a representative of a stripe. It should take 'n'+ -- passes to sort values of extent 'n'. The extent may not be uniform across+ -- all values of the type.+ extent :: e -> Int+ -- | The size of the bucket array necessary for sorting es- size :: e -> Int+ size :: Proxy e -> Int -- | Determines which bucket a given element should inhabit for a -- particular iteration. index :: Int -> e -> Int instance Lexicographic Word8 where- terminate _ n = n > 0- {-# INLINE terminate #-}+ extent _ = 1+ {-# INLINE extent #-} size _ = 256 {-# INLINE size #-} index _ n = fromIntegral n {-# INLINE index #-} instance Lexicographic Word16 where- terminate _ n = n > 1- {-# INLINE terminate #-}+ extent _ = 2+ {-# INLINE extent #-} size _ = 256 {-# INLINE size #-} index 0 n = fromIntegral $ (n `shiftR` 8) .&. 255@@ -84,8 +90,8 @@ {-# INLINE index #-} instance Lexicographic Word32 where- terminate _ n = n > 3- {-# INLINE terminate #-}+ extent _ = 4+ {-# INLINE extent #-} size _ = 256 {-# INLINE size #-} index 0 n = fromIntegral $ (n `shiftR` 24) .&. 255@@ -96,8 +102,8 @@ {-# INLINE index #-} instance Lexicographic Word64 where- terminate _ n = n > 7- {-# INLINE terminate #-}+ extent _ = 8+ {-# INLINE extent #-} size _ = 256 {-# INLINE size #-} index 0 n = fromIntegral $ (n `shiftR` 56) .&. 255@@ -112,8 +118,8 @@ {-# INLINE index #-} instance Lexicographic Word where- terminate _ n = n > 7- {-# INLINE terminate #-}+ extent _ = sizeOf (0 :: Word)+ {-# INLINE extent #-} size _ = 256 {-# INLINE size #-} index 0 n = fromIntegral $ (n `shiftR` 56) .&. 255@@ -128,16 +134,16 @@ {-# INLINE index #-} instance Lexicographic Int8 where- terminate _ n = n > 0- {-# INLINE terminate #-}+ extent _ = 1+ {-# INLINE extent #-} size _ = 256 {-# INLINE size #-} index _ n = 255 .&. fromIntegral n `xor` 128 {-# INLINE index #-} instance Lexicographic Int16 where- terminate _ n = n > 1- {-# INLINE terminate #-}+ extent _ = 2+ {-# INLINE extent #-} size _ = 256 {-# INLINE size #-} index 0 n = fromIntegral $ ((n `xor` minBound) `shiftR` 8) .&. 255@@ -146,8 +152,8 @@ {-# INLINE index #-} instance Lexicographic Int32 where- terminate _ n = n > 3- {-# INLINE terminate #-}+ extent _ = 4+ {-# INLINE extent #-} size _ = 256 {-# INLINE size #-} index 0 n = fromIntegral $ ((n `xor` minBound) `shiftR` 24) .&. 255@@ -158,8 +164,8 @@ {-# INLINE index #-} instance Lexicographic Int64 where- terminate _ n = n > 7- {-# INLINE terminate #-}+ extent _ = 8+ {-# INLINE extent #-} size _ = 256 {-# INLINE size #-} index 0 n = fromIntegral $ ((n `xor` minBound) `shiftR` 56) .&. 255@@ -174,8 +180,8 @@ {-# INLINE index #-} instance Lexicographic Int where- terminate _ n = n > 7- {-# INLINE terminate #-}+ extent _ = sizeOf (0 :: Int)+ {-# INLINE extent #-} size _ = 256 {-# INLINE size #-} index 0 n = ((n `xor` minBound) `shiftR` 56) .&. 255@@ -190,8 +196,8 @@ {-# INLINE index #-} instance Lexicographic B.ByteString where- terminate b i = i >= B.length b- {-# INLINE terminate #-}+ extent = B.length+ {-# INLINE extent #-} size _ = 257 {-# INLINE size #-} index i b@@ -199,15 +205,43 @@ | otherwise = fromIntegral (B.index b i) + 1 {-# INLINE index #-} +instance (Lexicographic a, Lexicographic b) => Lexicographic (a, b) where+ extent (a,b) = extent a + extent b+ {-# INLINE extent #-}+ size _ = size (Proxy :: Proxy a) `max` size (Proxy :: Proxy b)+ {-# INLINE size #-}+ index i (a,b)+ | i >= extent a = index i b+ | otherwise = index i a+ {-# INLINE index #-}++instance (Lexicographic a, Lexicographic b) => Lexicographic (Either a b) where+ extent (Left a) = 1 + extent a+ extent (Right b) = 1 + extent b+ {-# INLINE extent #-}+ size _ = size (Proxy :: Proxy a) `max` size (Proxy :: Proxy b)+ {-# INLINE size #-}+ index 0 (Left _) = 0+ index 0 (Right _) = 1+ index n (Left a) = index (n-1) a+ index n (Right b) = index (n-1) b+ {-# INLINE index #-}++-- | Given a representative of a stripe and an index number, this+-- function determines whether to stop sorting.+terminate :: Lexicographic e => e -> Int -> Bool+terminate e i = i >= extent e+{-# INLINE terminate #-}+ -- | Sorts an array using the default ordering. Both Lexicographic and -- Ord are necessary because the algorithm falls back to insertion sort -- for sufficiently small arrays. sort :: forall e m v. (PrimMonad m, MVector v e, Lexicographic e, Ord e) => v (PrimState m) e -> m ()-sort v = sortBy compare terminate (size e) index v- where e :: e- e = undefined-{-# INLINE sort #-}+sort v = sortBy compare terminate (size p) index v+ where p :: Proxy e+ p = Proxy+{-# INLINABLE sort #-} -- | A fully parameterized version of the sorting algorithm. Again, this -- function takes both radix information and a comparison, because the
src/Data/Vector/Algorithms/Common.hs view
@@ -46,3 +46,13 @@ | otherwise = return () {-# INLINE countLoop #-} +midPoint :: Int -> Int -> Int+midPoint a b =+ toInt $ (toWord a + toWord b) `div` 2+ where+ toWord :: Int -> Word+ toWord = fromIntegral++ toInt :: Word -> Int+ toInt = fromIntegral+{-# INLINE midPoint #-}
src/Data/Vector/Algorithms/Heap.hs view
@@ -54,7 +54,7 @@ -- | Sorts an entire array using the default ordering. sort :: (PrimMonad m, MVector v e, Ord e) => v (PrimState m) e -> m () sort = sortBy compare-{-# INLINE sort #-}+{-# INLINABLE sort #-} -- | Sorts an entire array using a custom ordering. sortBy :: (PrimMonad m, MVector v e) => Comparison e -> v (PrimState m) e -> m ()
src/Data/Vector/Algorithms/Insertion.hs view
@@ -34,7 +34,7 @@ -- | Sorts an entire array using the default comparison for the type sort :: (PrimMonad m, MVector v e, Ord e) => v (PrimState m) e -> m () sort = sortBy compare-{-# INLINE sort #-}+{-# INLINABLE sort #-} -- | Sorts an entire array using a given comparison sortBy :: (PrimMonad m, MVector v e) => Comparison e -> v (PrimState m) e -> m ()
src/Data/Vector/Algorithms/Intro.hs view
@@ -56,7 +56,7 @@ import Data.Bits import Data.Vector.Generic.Mutable -import Data.Vector.Algorithms.Common (Comparison)+import Data.Vector.Algorithms.Common (Comparison, midPoint) import qualified Data.Vector.Algorithms.Insertion as I import qualified Data.Vector.Algorithms.Optimal as O@@ -65,7 +65,7 @@ -- | Sorts an entire array using the default ordering. sort :: (PrimMonad m, MVector v e, Ord e) => v (PrimState m) e -> m () sort = sortBy compare-{-# INLINE sort #-}+{-# INLINABLE sort #-} -- | Sorts an entire array using a custom ordering. sortBy :: (PrimMonad m, MVector v e) => Comparison e -> v (PrimState m) e -> m ()@@ -106,7 +106,7 @@ sort (d-1) l (mid - 1) where len = u - l- c = (u + l) `div` 2+ c = midPoint u l {-# INLINE introsort #-} -- | Moves the least k elements to the front of the array in@@ -155,7 +155,7 @@ else if m < mid - 1 then go (n-1) l m (mid - 1) else return ()- where c = (u + l) `div` 2+ where c = midPoint u l {-# INLINE selectByBounds #-} -- | Moves the least k elements to the front of the array, sorted.@@ -207,7 +207,7 @@ go (n-1) mid m u EQ -> isort (n-1) l m LT -> go n l m (mid - 1)- where c = (u + l) `div` 2+ where c = midPoint u l {-# INLINE partialSortByBounds #-} partitionBy :: forall m v e. (PrimMonad m, MVector v e)
src/Data/Vector/Algorithms/Merge.hs view
@@ -27,7 +27,7 @@ import Data.Bits import Data.Vector.Generic.Mutable -import Data.Vector.Algorithms.Common (Comparison, copyOffset)+import Data.Vector.Algorithms.Common (Comparison, copyOffset, midPoint) import qualified Data.Vector.Algorithms.Optimal as O import qualified Data.Vector.Algorithms.Insertion as I@@ -35,7 +35,7 @@ -- | Sorts an array using the default comparison. sort :: (PrimMonad m, MVector v e, Ord e) => v (PrimState m) e -> m () sort = sortBy compare-{-# INLINE sort #-}+{-# INLINABLE sort #-} -- | Sorts an array using a custom comparison. sortBy :: (PrimMonad m, MVector v e) => Comparison e -> v (PrimState m) e -> m ()@@ -60,7 +60,7 @@ loop mid u merge cmp (unsafeSlice l len src) buf (mid - l) where len = u - l- mid = (u + l) `shiftR` 1+ mid = midPoint u l {-# INLINE mergeSortWithBuf #-} merge :: (PrimMonad m, MVector v e)
src/Data/Vector/Algorithms/Radix.hs view
@@ -186,7 +186,7 @@ where e :: e e = undefined-{-# INLINE sort #-}+{-# INLINABLE sort #-} -- | Radix sorts an array using custom radix information -- requires the number of passes to fully sort the array,
src/Data/Vector/Algorithms/Search.hs view
@@ -39,7 +39,7 @@ import Data.Vector.Generic.Mutable -import Data.Vector.Algorithms.Common (Comparison)+import Data.Vector.Algorithms.Common (Comparison, midPoint) -- | Finds an index in a given sorted vector at which the given element could -- be inserted while maintaining the sortedness of the vector.@@ -70,7 +70,7 @@ LT -> loop (k+1) u EQ -> return k GT -> loop l k- where k = (u + l) `shiftR` 1+ where k = midPoint u l {-# INLINE binarySearchByBounds #-} -- | Finds the lowest index in a given sorted vector at which the given element@@ -136,7 +136,7 @@ loop !l !u | u <= l = return l | otherwise = unsafeRead vec k >>= \e -> if p e then loop l k else loop (k+1) u- where k = (u + l) `shiftR` 1+ where k = midPoint u l {-# INLINE binarySearchPBounds #-} -- | Given a predicate that is guaranteed to be monotone on the vector elements
tests/properties/Tests.hs view
@@ -117,15 +117,8 @@ 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 "timsort" . prop_permutation (T.sort :: Algo Int ()) qc $ label "radix I8" . prop_permutation (R.sort :: Algo Int8 ())@@ -149,6 +142,17 @@ 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 ())+{-+ 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 "heappartial" . prop_sized (const . prop_permutation)+ (H.partialSort :: SizeAlgo Int ())+ qc $ label "heapselect" . prop_sized (const . prop_permutation)+ (H.select :: Algo Int ())+-}+ where qc prop = quickCheckWith args prop
vector-algorithms.cabal view
@@ -1,15 +1,17 @@ name: vector-algorithms-version: 0.7.0.1+version: 0.7.0.2 license: BSD3 license-file: LICENSE author: Dan Doel maintainer: Dan Doel <dan.doel@gmail.com>+ Erik de Castro Lopo <erikd@mega-nerd.com> copyright: (c) 2008,2009,2010,2011,2012,2013,2014,2015 Dan Doel (c) 2015 Tim Baumann-homepage: http://code.haskell.org/~dolio/+homepage: https://github.com/erikd/vector-algorithms/ category: Data synopsis: Efficient algorithms for vector arrays-description: Efficient algorithms for vector arrays+description: Efficient algorithms for sorting vector arrays. At some stage+ other vector algorithms may be added. build-type: Simple cabal-version: >= 1.9.2 @@ -36,15 +38,23 @@ description: Enable the quickcheck tests default: True +-- flag dump-simpl+-- description: Dumps the simplified core during compilation+-- default: False++flag llvm+ description: Build using llvm+ default: False+ source-repository head- type: darcs- location: http://hub.darcs.net/dolio/vector-algorithms+ type: git+ location: https://github.com/erikd/vector-algorithms/ library hs-source-dirs: src build-depends: base >= 4.5 && < 5,- vector >= 0.6 && < 0.12,+ vector >= 0.6 && < 0.13, primitive >=0.3 && <0.7, bytestring >= 0.9 && < 1.0 @@ -63,9 +73,15 @@ Data.Vector.Algorithms.Common ghc-options:- -Odph -funbox-strict-fields + -- Cabal/Hackage complains about these+ -- if flag(dump-simpl)+ -- ghc-options: -ddump-simpl -ddump-to-file++ if flag(llvm)+ ghc-options: -fllvm+ include-dirs: include @@ -81,8 +97,8 @@ if flag(InternalChecks) cpp-options: -DVECTOR_INTERNAL_CHECKS -executable vector-algorithms-bench- hs-source-dirs: bench+executable simple-bench+ hs-source-dirs: bench/simple if !flag(bench) buildable: False@@ -93,8 +109,15 @@ Blocks build-depends: base, mwc-random, vector, vector-algorithms, mtl- ghc-options: -Wall -Odph+ ghc-options: -Wall + -- Cabal/Hackage complains about these+ -- if flag(dump-simpl)+ -- ghc-options: -ddump-simpl -ddump-to-file++ if flag(llvm)+ ghc-options: -fllvm+ test-suite properties hs-source-dirs: tests/properties type: exitcode-stdio-1.0@@ -115,3 +138,6 @@ QuickCheck >= 2, vector, vector-algorithms++ if flag(llvm)+ ghc-options: -fllvm