vector-algorithms 0.6.0.4 → 0.9.1.0
raw patch · 20 files changed
Files
- CHANGELOG.md +37/−0
- LICENSE +3/−2
- bench/Blocks.hs +0/−62
- bench/Main.hs +0/−194
- bench/simple/Blocks.hs +62/−0
- bench/simple/Main.hs +202/−0
- src/Data/Vector/Algorithms.hs +77/−0
- src/Data/Vector/Algorithms/AmericanFlag.hs +92/−30
- src/Data/Vector/Algorithms/Common.hs +85/−1
- src/Data/Vector/Algorithms/Heap.hs +132/−25
- src/Data/Vector/Algorithms/Insertion.hs +15/−1
- src/Data/Vector/Algorithms/Intro.hs +70/−21
- src/Data/Vector/Algorithms/Merge.hs +31/−10
- src/Data/Vector/Algorithms/Optimal.hs +16/−9
- src/Data/Vector/Algorithms/Search.hs +78/−5
- src/Data/Vector/Algorithms/Tim.hs +382/−0
- tests/properties/Optimal.hs +5/−5
- tests/properties/Properties.hs +46/−7
- tests/properties/Tests.hs +56/−23
- vector-algorithms.cabal +76/−30
+ CHANGELOG.md view
@@ -0,0 +1,37 @@+## Version 0.9.1.0 (2025-02-05)++- More inlining for `sort` and `nib` functions.++## Version 0.9.0.3 (2024-11-25)++- Fix an off-by-one error Heap.partialSort functions.+- Support latest ghcs.++## Version 0.9.0.2 (2024-05-23)++- Add `TypeOperators` pragma where needed.++## Version 0.9.0.1 (2022-07-28)++- Allow building with vector-0.13.*.++## Version 0.9.0.0 (2022-05-19)++- Add nub related functions.+- Add sortUniq related functions (sorts, then removes duplicates).++## Version 0.8.0.4 (2020-12-06)++- Fix out of range access in Intro.partialSort.+- Update QuickCheck dependency bounds.++## Version 0.8.0.3 (2019-12-02)++- Fix out-of-bounds access in Timsort.++## Version 0.8.0.2 (2019-11-28)++- Bump upper bounds on primitive and QuickCheck.+- Expose 'terminate' function from 'AmericanFlag' module.+- Fix an off-by-one error in Data.Vector.Algorithms.Heaps.heapInsert.+
LICENSE view
@@ -1,4 +1,5 @@-Copyright (c) 2008-2010 Dan Doel+Copyright (c) 2015 Dan Doel+Copyright (c) 2015 Tim Baumann All rights reserved. @@ -32,7 +33,7 @@ ------------------------------------------------------------------------------ The code in Data.Array.Vector.Algorithms.Mutable.Optimal is adapted from a C-algorithm for the same purpose. The folowing is the copyright notice for said+algorithm for the same purpose. The following is the copyright notice for said C code: Copyright (c) 2004 Paul Hsieh
− 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,194 +0,0 @@-{-# LANGUAGE Rank2Types #-}--module Main (main) where--import Prelude hiding (read, length)-import qualified Prelude as P--import Control.Monad.ST-import Control.Monad.Error--import Data.Char-import Data.Ord (comparing)-import Data.List (maximumBy)--import Data.Vector.Unboxed.Mutable--import qualified Data.Vector.Algorithms.Insertion as INS-import qualified Data.Vector.Algorithms.Intro as INT-import qualified Data.Vector.Algorithms.Heap as H-import qualified Data.Vector.Algorithms.Merge as M-import qualified Data.Vector.Algorithms.Radix as R-import qualified Data.Vector.Algorithms.AmericanFlag as AF--import System.Environment-import System.Console.GetOpt-import System.Random.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- 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- _ -> 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 = 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) => MVector RealWorld e+ -> Int+ -> (Int -> IO e)+ -> (MVector RealWorld e -> IO ())+ -> IO Integer+speedTest arr n fill algo = do+ initialize arr n fill+ t0 <- clock+ algo arr+ t1 <- clock+ return $ t1 - t0+{-# INLINE speedTest #-}++
+ bench/simple/Main.hs view
@@ -0,0 +1,202 @@+{-# LANGUAGE Rank2Types #-}++module Main (main) where++import Prelude hiding (read, length)+import qualified Prelude as P++import Control.Monad+import Control.Monad.ST++import Data.Char+import Data.Ord (comparing)+import Data.List (maximumBy)++import qualified Data.Vector.Unboxed.Mutable as UVector+import Data.Vector.Unboxed.Mutable (MVector, Unbox)++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 = (UVector.new (len `div` 2) :: IO (MVector RealWorld Int)) >> return ()+ where len = UVector.length arr++displayTime :: String -> Integer -> IO ()+displayTime s elapsed = putStrLn $+ s ++ " : " ++ show (fromIntegral elapsed / (1e12 :: Double)) ++ " 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+ arr <- UVector.new n+ putStrLn $ "Testing: " ++ str+ run "Random " $ speedTest arr n (rand g >=> modulo n) sort+ run "Sorted " $ speedTest arr n ascend sort+ run "Reverse-sorted " $ speedTest arr n (descend n) sort+ run "Random duplicates " $ speedTest arr n (rand g >=> modulo 1000) sort+ let m = 4 * (n `div` 4)+ run "Median killer " $ speedTest arr 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++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.hs view
@@ -0,0 +1,77 @@+{-# language BangPatterns, RankNTypes, ScopedTypeVariables #-}+module Data.Vector.Algorithms where++import Prelude hiding (length)+import Control.Monad+import Control.Monad.Primitive+import Control.Monad.ST (runST)++import Data.Vector.Generic.Mutable+import qualified Data.Vector.Generic as V+import qualified Data.Vector.Unboxed.Mutable as UMV+import qualified Data.Bit as Bit++import Data.Vector.Algorithms.Common (Comparison)+import Data.Vector.Algorithms.Intro (sortUniqBy)+import qualified Data.Vector.Algorithms.Search as S++-- | The `nub` function which removes duplicate elements from a vector.+nub :: forall v e . (V.Vector v e, Ord e) => v e -> v e+nub = nubBy compare+{-# INLINE nub #-}++-- | A version of `nub` with a custom comparison predicate.+--+-- /Note:/ This function makes use of `sortByUniq` using the intro+-- sort algorithm.+nubBy ::+ forall v e . (V.Vector v e) =>+ Comparison e -> v e -> v e+nubBy cmp vec = runST $ do+ mv <- V.unsafeThaw vec -- safe as the nubByMut algorithm copies the input+ destMV <- nubByMut sortUniqBy cmp mv+ v <- V.unsafeFreeze destMV+ pure (V.force v)+{-# INLINE nubBy #-}++-- | The `nubByMut` function takes in an in-place sort algorithm+-- and uses it to do a de-deduplicated sort. It then uses this to+-- remove duplicate elements from the input.+--+-- /Note:/ Since this algorithm needs the original input and so+-- copies before sorting in-place. As such, it is safe to use on+-- immutable inputs.+nubByMut ::+ forall m v e . (PrimMonad m, MVector v e) =>+ (Comparison e -> v (PrimState m) e -> m (v (PrimState m) e))+ -> Comparison e -> v (PrimState m) e -> m (v (PrimState m) e)+nubByMut alg cmp inp = do+ let len = length inp+ inp' <- clone inp+ sortUniqs <- alg cmp inp'+ let uniqLen = length sortUniqs+ bitmask <- UMV.replicate uniqLen (Bit.Bit False) -- bitmask to track which elements have+ -- already been seen.+ dest :: v (PrimState m) e <- unsafeNew uniqLen -- return vector+ let+ go :: Int -> Int -> m ()+ go !srcInd !destInd+ | srcInd == len = pure ()+ | destInd == uniqLen = pure ()+ | otherwise = do+ curr <- unsafeRead inp srcInd -- read current element+ sortInd <- S.binarySearchBy cmp sortUniqs curr -- find sorted index+ bit <- UMV.unsafeRead bitmask sortInd -- check if we have already seen+ -- this element in bitvector+ case bit of+ -- if we have seen it then iterate+ Bit.Bit True -> go (srcInd + 1) destInd+ -- if we haven't then write it into output+ -- and mark that it has been seen+ Bit.Bit False -> do+ UMV.unsafeWrite bitmask sortInd (Bit.Bit True)+ unsafeWrite dest destInd curr+ go (srcInd + 1) (destInd + 1)+ go 0 0+ pure dest+{-# INLINABLE nubByMut #-}
src/Data/Vector/Algorithms/AmericanFlag.hs view
@@ -27,7 +27,10 @@ -- rather than running for a set number of iterations. module Data.Vector.Algorithms.AmericanFlag ( sort+ , sortUniq , sortBy+ , sortUniqBy+ , terminate , Lexicographic(..) ) where @@ -36,6 +39,8 @@ import Control.Monad import Control.Monad.Primitive +import Data.Proxy+ import Data.Word import Data.Int import Data.Bits@@ -51,31 +56,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 +93,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 +105,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 +121,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 +137,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 +155,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 +167,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 +183,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 +199,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,16 +208,52 @@ | 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+sort v = sortBy compare terminate (size p) index v+ where p :: Proxy e+ p = Proxy {-# INLINE sort #-} +-- | A variant on `sort` that returns a vector of unique elements.+sortUniq :: forall e m v. (PrimMonad m, MVector v e, Lexicographic e, Ord e)+ => v (PrimState m) e -> m (v (PrimState m) e)+sortUniq v = sortUniqBy compare terminate (size p) index v+ where p :: Proxy e+ p = Proxy+{-# INLINE sortUniq #-}+ -- | A fully parameterized version of the sorting algorithm. Again, this -- function takes both radix information and a comparison, because the -- algorithms falls back to insertion sort for small arrays.@@ -227,6 +272,23 @@ flagLoop cmp stop radix count pile v {-# INLINE sortBy #-} +-- | A variant on `sortBy` which returns a vector of unique elements.+sortUniqBy :: (PrimMonad m, MVector v e)+ => Comparison e -- ^ a comparison for the insertion sort flalback+ -> (e -> Int -> Bool) -- ^ determines whether a stripe is complete+ -> Int -- ^ the number of buckets necessary+ -> (Int -> e -> Int) -- ^ the big-endian radix function+ -> v (PrimState m) e -- ^ the array to be sorted+ -> m (v (PrimState m) e)+sortUniqBy cmp stop buckets radix v+ | length v == 0 = return v+ | otherwise = do count <- new buckets+ pile <- new buckets+ countLoop (radix 0) v count+ flagLoop cmp stop radix count pile v+ uniqueMutableBy cmp v+{-# INLINE sortUniqBy #-}+ flagLoop :: (PrimMonad m, MVector v e) => Comparison e -> (e -> Int -> Bool) -- number of passes@@ -292,7 +354,7 @@ then unsafeRead count (r-1) else return 0 case () of- -- if the current element is alunsafeReady in the right pile,+ -- if the current element is already in the right pile, -- go to the end of the pile _ | m <= i && i < p -> go p -- if the current element happens to be in the right
src/Data/Vector/Algorithms/Common.hs view
@@ -1,5 +1,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE ScopedTypeVariables #-} -- --------------------------------------------------------------------------- -- |@@ -11,13 +13,22 @@ -- -- Common operations and utility functions for all sorts -module Data.Vector.Algorithms.Common where+module Data.Vector.Algorithms.Common+ ( type Comparison+ , copyOffset+ , inc+ , countLoop+ , midPoint+ , uniqueMutableBy+ )+ where import Prelude hiding (read, length) import Control.Monad.Primitive import Data.Vector.Generic.Mutable+import Data.Word (Word) import qualified Data.Vector.Primitive.Mutable as PV @@ -46,3 +57,76 @@ | 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 #-}++-- Adapted from Andrew Martin's uniquqMutable in the primitive-sort package+uniqueMutableBy :: forall m v a . (PrimMonad m, MVector v a)+ => Comparison a -> v (PrimState m) a -> m (v (PrimState m) a)+uniqueMutableBy cmp mv = do+ let !len = basicLength mv+ if len > 1+ then do+ !a0 <- unsafeRead mv 0+ let findFirstDuplicate :: a -> Int -> m Int+ findFirstDuplicate !prev !ix = if ix < len+ then do+ a <- unsafeRead mv ix+ if cmp a prev == EQ+ then return ix+ else findFirstDuplicate a (ix + 1)+ else return ix+ dupIx <- findFirstDuplicate a0 1+ if dupIx == len+ then return mv+ else do+ let deduplicate :: a -> Int -> Int -> m Int+ deduplicate !prev !srcIx !dstIx = if srcIx < len+ then do+ a <- unsafeRead mv srcIx+ if cmp a prev == EQ+ then deduplicate a (srcIx + 1) dstIx+ else do+ unsafeWrite mv dstIx a+ deduplicate a (srcIx + 1) (dstIx + 1)+ else return dstIx+ !a <- unsafeRead mv dupIx+ !reducedLen <- deduplicate a (dupIx + 1) dupIx+ resizeVector mv reducedLen+ else return mv+{-# INLINABLE uniqueMutableBy #-}++-- Used internally in uniqueMutableBy: copies the elements of a vector to one+-- of a smaller size.+resizeVector+ :: (MVector v a, PrimMonad m)+ => v (PrimState m) a -> Int -> m (v (PrimState m) a)+resizeVector !src !sz = do+ dst <- unsafeNew sz+ copyToSmaller dst src+ pure dst+{-# inline resizeVector #-}++-- Used internally in resizeVector: copy a vector from a larger to+-- smaller vector. Should not be used if the source vector+-- is smaller than the target vector.+copyToSmaller+ :: (MVector v a, PrimMonad m)+ => v (PrimState m) a -> v (PrimState m) a -> m ()+copyToSmaller !dst !src = stToPrim $ do_copy 0+ where+ !n = basicLength dst++ do_copy i | i < n = do+ x <- basicUnsafeRead src i+ basicUnsafeWrite dst i x+ do_copy (i+1)+ | otherwise = return ()
src/Data/Vector/Algorithms/Heap.hs view
@@ -4,7 +4,7 @@ -- --------------------------------------------------------------------------- -- | -- Module : Data.Vector.Algorithms.Heap--- Copyright : (c) 2008-2011 Dan Doel+-- Copyright : (c) 2008-2015 Dan Doel -- Maintainer : Dan Doel <dan.doel@gmail.com> -- Stability : Experimental -- Portability : Non-portable (type operators)@@ -19,7 +19,9 @@ module Data.Vector.Algorithms.Heap ( -- * Sorting sort+ , sortUniq , sortBy+ , sortUniqBy , sortByBounds -- * Selection , select@@ -34,6 +36,7 @@ , pop , popTo , sortHeap+ , heapInsert , Comparison ) where @@ -46,7 +49,7 @@ import Data.Vector.Generic.Mutable -import Data.Vector.Algorithms.Common (Comparison)+import Data.Vector.Algorithms.Common (Comparison, uniqueMutableBy) import qualified Data.Vector.Algorithms.Optimal as O @@ -55,14 +58,32 @@ sort = sortBy compare {-# INLINE sort #-} +-- | A variant on `sort` that returns a vector of unique elements.+sortUniq :: (PrimMonad m, MVector v e, Ord e) => v (PrimState m) e -> m (v (PrimState m) e)+sortUniq = sortUniqBy compare+{-# INLINE sortUniq #-}+ -- | Sorts an entire array using a custom ordering. sortBy :: (PrimMonad m, MVector v e) => Comparison e -> v (PrimState m) e -> m () sortBy cmp a = sortByBounds cmp a 0 (length a) {-# INLINE sortBy #-} +-- | A variant on `sortBy` which returns a vector of unique elements.+sortUniqBy :: (PrimMonad m, MVector v e)+ => Comparison e -> v (PrimState m) e -> m (v (PrimState m) e)+sortUniqBy cmp a = do+ sortByBounds cmp a 0 (length a)+ uniqueMutableBy cmp a+{-# INLINE sortUniqBy #-}+ -- | Sorts a portion of an array [l,u) using a custom ordering-sortByBounds :: (PrimMonad m, MVector v e)- => Comparison e -> v (PrimState m) e -> Int -> Int -> m ()+sortByBounds+ :: (PrimMonad m, MVector v e)+ => Comparison e+ -> v (PrimState m) e+ -> Int -- ^ lower index, l+ -> Int -- ^ upper index, u+ -> m () sortByBounds cmp a l u | len < 2 = return () | len == 2 = O.sort2ByOffset cmp a l@@ -74,22 +95,37 @@ -- | Moves the lowest k elements to the front of the array. -- The elements will be in no particular order.-select :: (PrimMonad m, MVector v e, Ord e) => v (PrimState m) e -> Int -> m ()+select+ :: (PrimMonad m, MVector v e, Ord e)+ => v (PrimState m) e+ -> Int -- ^ number of elements to select, k+ -> m () select = selectBy compare {-# INLINE select #-} --- | Moves the 'lowest' (as defined by the comparison) k elements+-- | Moves the lowest (as defined by the comparison) k elements -- to the front of the array. The elements will be in no particular -- order.-selectBy :: (PrimMonad m, MVector v e) => Comparison e -> v (PrimState m) e -> Int -> m ()+selectBy+ :: (PrimMonad m, MVector v e)+ => Comparison e+ -> v (PrimState m) e+ -> Int -- ^ number of elements to select, k+ -> m () selectBy cmp a k = selectByBounds cmp a k 0 (length a) {-# INLINE selectBy #-} -- | Moves the 'lowest' k elements in the portion [l,u) of the -- array into the positions [l,k+l). The elements will be in -- no particular order.-selectByBounds :: (PrimMonad m, MVector v e)- => Comparison e -> v (PrimState m) e -> Int -> Int -> Int -> m ()+selectByBounds+ :: (PrimMonad m, MVector v e)+ => Comparison e+ -> v (PrimState m) e+ -> Int -- ^ number of elements to select, k+ -> Int -- ^ lower index, l+ -> Int -- ^ upper index, u+ -> m () selectByBounds cmp a k l u | l + k <= u = heapify cmp a l (l + k) >> go l (l + k) (u - 1) | otherwise = return ()@@ -105,21 +141,42 @@ {-# INLINE selectByBounds #-} -- | Moves the lowest k elements to the front of the array, sorted.-partialSort :: (PrimMonad m, MVector v e, Ord e) => v (PrimState m) e -> Int -> m ()+--+-- The remaining values of the array will be in no particular order.+partialSort+ :: (PrimMonad m, MVector v e, Ord e)+ => v (PrimState m) e+ -> Int -- ^ number of elements to sort, k+ -> m () partialSort = partialSortBy compare {-# INLINE partialSort #-} -- | Moves the lowest k elements (as defined by the comparison) to -- the front of the array, sorted.-partialSortBy :: (PrimMonad m, MVector v e)- => Comparison e -> v (PrimState m) e -> Int -> m ()+--+-- The remaining values of the array will be in no particular order.+partialSortBy+ :: (PrimMonad m, MVector v e)+ => Comparison e+ -> v (PrimState m) e+ -> Int -- ^ number of elements to sort, k+ -> m () partialSortBy cmp a k = partialSortByBounds cmp a k 0 (length a) {-# INLINE partialSortBy #-} -- | Moves the lowest k elements in the portion [l,u) of the array -- into positions [l,k+l), sorted.-partialSortByBounds :: (PrimMonad m, MVector v e)- => Comparison e -> v (PrimState m) e -> Int -> Int -> Int -> m ()+--+-- The remaining values in [l,u) will be in no particular order. Values outside+-- the range [l,u) will be unaffected.+partialSortByBounds+ :: (PrimMonad m, MVector v e)+ => Comparison e+ -> v (PrimState m) e+ -> Int -- ^ number of elements to sort, k+ -> Int -- ^ lower index, l+ -> Int -- ^ upper index, u+ -> m () partialSortByBounds cmp a k l u -- this potentially does more work than absolutely required, -- but using a heap to find the least 2 of 4 elements@@ -131,16 +188,25 @@ | len == 3 = O.sort3ByOffset cmp a l | len == 4 = O.sort4ByOffset cmp a l | u <= l + k = sortByBounds cmp a l u- | otherwise = do selectByBounds cmp a k l u- sortHeap cmp a l (l + 4) (l + k)+ | otherwise = do selectByBounds cmp a (k + 1) l u+ sortHeap cmp a l (l + 4) (l + k + 1) O.sort4ByOffset cmp a l where len = u - l {-# INLINE partialSortByBounds #-} --- | Constructs a heap in a portion of an array [l, u)-heapify :: (PrimMonad m, MVector v e)- => Comparison e -> v (PrimState m) e -> Int -> Int -> m ()+-- | Constructs a heap in a portion of an array [l, u), using the values therein.+--+-- Note: 'heapify' is more efficient than constructing a heap by repeated+-- insertion. Repeated insertion has complexity O(n*log n) while 'heapify' is able+-- to construct a heap in O(n), where n is the number of elements in the heap.+heapify+ :: (PrimMonad m, MVector v e)+ => Comparison e+ -> v (PrimState m) e+ -> Int -- ^ lower index, l+ -> Int -- ^ upper index, u+ -> m () heapify cmp a l u = loop $ (len - 1) `shiftR` 2 where len = u - l@@ -152,15 +218,26 @@ -- | Given a heap stored in a portion of an array [l,u), swaps the -- top of the heap with the element at u and rebuilds the heap.-pop :: (PrimMonad m, MVector v e)- => Comparison e -> v (PrimState m) e -> Int -> Int -> m ()+pop+ :: (PrimMonad m, MVector v e)+ => Comparison e+ -> v (PrimState m) e+ -> Int -- ^ lower heap index, l+ -> Int -- ^ upper heap index, u+ -> m () pop cmp a l u = popTo cmp a l u u {-# INLINE pop #-} -- | Given a heap stored in a portion of an array [l,u) swaps the top -- of the heap with the element at position t, and rebuilds the heap.-popTo :: (PrimMonad m, MVector v e)- => Comparison e -> v (PrimState m) e -> Int -> Int -> Int -> m ()+popTo+ :: (PrimMonad m, MVector v e)+ => Comparison e+ -> v (PrimState m) e+ -> Int -- ^ lower heap index, l+ -> Int -- ^ upper heap index, u+ -> Int -- ^ index to pop to, t+ -> m () popTo cmp a l u t = do al <- unsafeRead a l at <- unsafeRead a t unsafeWrite a t al@@ -170,14 +247,44 @@ -- | Given a heap stored in a portion of an array [l,u), sorts the -- highest values into [m,u). The elements in [l,m) are not in any -- particular order.-sortHeap :: (PrimMonad m, MVector v e)- => Comparison e -> v (PrimState m) e -> Int -> Int -> Int -> m ()+sortHeap+ :: (PrimMonad m, MVector v e)+ => Comparison e+ -> v (PrimState m) e+ -> Int -- ^ lower heap index, l+ -> Int -- ^ lower bound of final sorted portion, m+ -> Int -- ^ upper heap index, u+ -> m () sortHeap cmp a l m u = loop (u-1) >> unsafeSwap a l m where loop k | m < k = pop cmp a l k >> loop (k-1) | otherwise = return () {-# INLINE sortHeap #-}++-- | Given a heap stored in a portion of an array [l,u) and an element e,+-- inserts the element into the heap, resulting in a heap in [l,u].+--+-- Note: it is best to only use this operation when incremental construction of+-- a heap is required. 'heapify' is capable of building a heap in O(n) time,+-- while repeated insertion takes O(n*log n) time.+heapInsert+ :: (PrimMonad m, MVector v e)+ => Comparison e+ -> v (PrimState m) e+ -> Int -- ^ lower heap index, l+ -> Int -- ^ upper heap index, u+ -> e -- ^ element to be inserted, e+ -> m ()+heapInsert cmp v l u e = sift (u - l)+ where+ sift k+ | k <= 0 = unsafeWrite v l e+ | otherwise = let pi = shiftR (k-1) 2+ in unsafeRead v (l + pi) >>= \p -> case cmp p e of+ LT -> unsafeWrite v (l + k) p >> sift pi+ _ -> unsafeWrite v (l + k) e+{-# INLINE heapInsert #-} -- Rebuilds a heap with a hole in it from start downwards. Afterward, -- the heap property should apply for [start + off, len + off). val
src/Data/Vector/Algorithms/Insertion.hs view
@@ -14,7 +14,9 @@ module Data.Vector.Algorithms.Insertion ( sort+ , sortUniq , sortBy+ , sortUniqBy , sortByBounds , sortByBounds' , Comparison@@ -27,7 +29,7 @@ import Data.Vector.Generic.Mutable -import Data.Vector.Algorithms.Common (Comparison)+import Data.Vector.Algorithms.Common (Comparison, uniqueMutableBy) import qualified Data.Vector.Algorithms.Optimal as O @@ -36,10 +38,22 @@ sort = sortBy compare {-# INLINE sort #-} +-- | A variant on `sort` that returns a vector of unique elements.+sortUniq :: (PrimMonad m, MVector v e, Ord e) => v (PrimState m) e -> m (v (PrimState m) e)+sortUniq = sortUniqBy compare+{-# INLINE sortUniq #-}+ -- | Sorts an entire array using a given comparison sortBy :: (PrimMonad m, MVector v e) => Comparison e -> v (PrimState m) e -> m () sortBy cmp a = sortByBounds cmp a 0 (length a) {-# INLINE sortBy #-}++-- | A variant on `sortBy` which returns a vector of unique elements.+sortUniqBy :: (PrimMonad m, MVector v e) => Comparison e -> v (PrimState m) e -> m (v (PrimState m) e)+sortUniqBy cmp a = do+ sortByBounds cmp a 0 (length a)+ uniqueMutableBy cmp a+{-# INLINE sortUniqBy #-} -- | Sorts the portion of an array delimited by [l,u) sortByBounds :: (PrimMonad m, MVector v e)
src/Data/Vector/Algorithms/Intro.hs view
@@ -6,7 +6,7 @@ -- --------------------------------------------------------------------------- -- | -- Module : Data.Vector.Algorithms.Intro--- Copyright : (c) 2008-2011 Dan Doel+-- Copyright : (c) 2008-2015 Dan Doel -- Maintainer : Dan Doel <dan.doel@gmail.com> -- Stability : Experimental -- Portability : Non-portable (type operators, bang patterns)@@ -35,7 +35,9 @@ module Data.Vector.Algorithms.Intro ( -- * Sorting sort+ , sortUniq , sortBy+ , sortUniqBy , sortByBounds -- * Selecting , select@@ -56,7 +58,7 @@ import Data.Bits import Data.Vector.Generic.Mutable -import Data.Vector.Algorithms.Common (Comparison)+import Data.Vector.Algorithms.Common (Comparison, midPoint, uniqueMutableBy) import qualified Data.Vector.Algorithms.Insertion as I import qualified Data.Vector.Algorithms.Optimal as O@@ -67,14 +69,32 @@ sort = sortBy compare {-# INLINE sort #-} --- | Sorts an entire array using a custom ordering.+-- | A variant on `sort` that returns a vector of unique elements.+sortUniq :: (PrimMonad m, MVector v e, Ord e) => v (PrimState m) e -> m (v (PrimState m) e)+sortUniq = sortUniqBy compare+{-# INLINE sortUniq #-}++-- | A variant on `sortBy` which returns a vector of unique elements. sortBy :: (PrimMonad m, MVector v e) => Comparison e -> v (PrimState m) e -> m () sortBy cmp a = sortByBounds cmp a 0 (length a) {-# INLINE sortBy #-} +-- | Sorts an entire array using a custom ordering returning a vector of+-- the unique elements.+sortUniqBy :: (PrimMonad m, MVector v e) => Comparison e -> v (PrimState m) e -> m (v (PrimState m) e)+sortUniqBy cmp a = do+ sortByBounds cmp a 0 (length a)+ uniqueMutableBy cmp a+{-# INLINE sortUniqBy #-}+ -- | Sorts a portion of an array [l,u) using a custom ordering-sortByBounds :: (PrimMonad m, MVector v e)- => Comparison e -> v (PrimState m) e -> Int -> Int -> m ()+sortByBounds+ :: (PrimMonad m, MVector v e)+ => Comparison e+ -> v (PrimState m) e+ -> Int -- ^ lower index, l+ -> Int -- ^ upper index, u+ -> m () sortByBounds cmp a l u | len < 2 = return () | len == 2 = O.sort2ByOffset cmp a l@@ -101,26 +121,40 @@ 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 -- no particular order.-select :: (PrimMonad m, MVector v e, Ord e) => v (PrimState m) e -> Int -> m ()+select+ :: (PrimMonad m, MVector v e, Ord e)+ => v (PrimState m) e+ -> Int -- ^ number of elements to select, k+ -> m () select = selectBy compare {-# INLINE select #-} -- | Moves the least k elements (as defined by the comparison) to -- the front of the array in no particular order.-selectBy :: (PrimMonad m, MVector v e)- => Comparison e -> v (PrimState m) e -> Int -> m ()+selectBy+ :: (PrimMonad m, MVector v e)+ => Comparison e+ -> v (PrimState m) e+ -> Int -- ^ number of elements to select, k+ -> m () selectBy cmp a k = selectByBounds cmp a k 0 (length a) {-# INLINE selectBy #-} -- | Moves the least k elements in the interval [l,u) to the positions -- [l,k+l) in no particular order.-selectByBounds :: (PrimMonad m, MVector v e)- => Comparison e -> v (PrimState m) e -> Int -> Int -> Int -> m ()+selectByBounds+ :: (PrimMonad m, MVector v e)+ => Comparison e+ -> v (PrimState m) e+ -> Int -- ^ number of elements to select, k+ -> Int -- ^ lower bound, l+ -> Int -- ^ upper bound, u+ -> m () selectByBounds cmp a k l u | l >= u = return () | otherwise = go (ilg len) l (l + k) u@@ -136,28 +170,45 @@ 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.-partialSort :: (PrimMonad m, MVector v e, Ord e) => v (PrimState m) e -> Int -> m ()+partialSort+ :: (PrimMonad m, MVector v e, Ord e)+ => v (PrimState m) e+ -> Int -- ^ number of elements to sort, k+ -> m () partialSort = partialSortBy compare {-# INLINE partialSort #-} -- | Moves the least k elements (as defined by the comparison) to -- the front of the array, sorted.-partialSortBy :: (PrimMonad m, MVector v e)- => Comparison e -> v (PrimState m) e -> Int -> m ()+partialSortBy+ :: (PrimMonad m, MVector v e)+ => Comparison e+ -> v (PrimState m) e+ -> Int -- ^ number of elements to sort, k+ -> m () partialSortBy cmp a k = partialSortByBounds cmp a k 0 (length a) {-# INLINE partialSortBy #-} -- | Moves the least k elements in the interval [l,u) to the positions -- [l,k+l), sorted.-partialSortByBounds :: (PrimMonad m, MVector v e)- => Comparison e -> v (PrimState m) e -> Int -> Int -> Int -> m ()+partialSortByBounds+ :: (PrimMonad m, MVector v e)+ => Comparison e+ -> v (PrimState m) e+ -> Int -- ^ number of elements to sort, k+ -> Int -- ^ lower index, l+ -> Int -- ^ upper index, u+ -> m () partialSortByBounds cmp a k l u | l >= u = return ()- | otherwise = go (ilg len) l (l + k) u+ | otherwise = let k' = min (u-l) k+ -- N.B. Clamp k to the length of the range+ -- being sorted.+ in go (ilg len) l (l + k') u where isort = introsort cmp a {-# INLINE [1] isort #-}@@ -174,15 +225,13 @@ 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) => Comparison e -> v (PrimState m) e -> e -> Int -> Int -> m Int partitionBy cmp a = partUp where- -- 6.10 panics without the signatures for partUp and partDown, 6.12 and later- -- versions don't need them partUp :: e -> Int -> Int -> m Int partUp p l u | l < u = do e <- unsafeRead a l
src/Data/Vector/Algorithms/Merge.hs view
@@ -16,7 +16,9 @@ module Data.Vector.Algorithms.Merge ( sort+ , sortUniq , sortBy+ , sortUniqBy , Comparison ) where @@ -27,7 +29,7 @@ import Data.Bits import Data.Vector.Generic.Mutable -import Data.Vector.Algorithms.Common (Comparison, copyOffset)+import Data.Vector.Algorithms.Common (Comparison, copyOffset, midPoint, uniqueMutableBy) import qualified Data.Vector.Algorithms.Optimal as O import qualified Data.Vector.Algorithms.Insertion as I@@ -37,19 +39,38 @@ sort = sortBy compare {-# INLINE sort #-} +-- | A variant on `sort` that returns a vector of unique elements.+sortUniq :: (PrimMonad m, MVector v e, Ord e) => v (PrimState m) e -> m (v (PrimState m) e)+sortUniq = sortUniqBy compare+{-# INLINE sortUniq #-}+ -- | Sorts an array using a custom comparison. sortBy :: (PrimMonad m, MVector v e) => Comparison e -> v (PrimState m) e -> m ()-sortBy cmp vec- | len <= 1 = return ()- | len == 2 = O.sort2ByOffset cmp vec 0- | len == 3 = O.sort3ByOffset cmp vec 0- | len == 4 = O.sort4ByOffset cmp vec 0- | otherwise = do buf <- new len- mergeSortWithBuf cmp vec buf+sortBy cmp vec = if len <= 4+ then if len <= 2+ then if len /= 2+ then return ()+ else O.sort2ByOffset cmp vec 0+ else if len == 3+ then O.sort3ByOffset cmp vec 0+ else O.sort4ByOffset cmp vec 0+ else if len < threshold+ then I.sortByBounds cmp vec 0 len+ else do buf <- new halfLen+ mergeSortWithBuf cmp vec buf where- len = length vec+ len = length vec+ -- odd lengths have a larger half that needs to fit, so use ceiling, not floor+ halfLen = (len + 1) `div` 2 {-# INLINE sortBy #-} +-- | A variant on `sortBy` which returns a vector of unique elements.+sortUniqBy :: (PrimMonad m, MVector v e) => Comparison e -> v (PrimState m) e -> m (v (PrimState m) e)+sortUniqBy cmp vec = do+ sortBy cmp vec+ uniqueMutableBy cmp vec+{-# INLINE sortUniqBy #-}+ mergeSortWithBuf :: (PrimMonad m, MVector v e) => Comparison e -> v (PrimState m) e -> v (PrimState m) e -> m () mergeSortWithBuf cmp src buf = loop 0 (length src)@@ -60,7 +81,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/Optimal.hs view
@@ -40,6 +40,13 @@ import Data.Vector.Algorithms.Common (Comparison) +#if MIN_VERSION_vector(0,13,0)+import qualified Data.Vector.Internal.Check as Ck+# define CHECK_INDEX(name, i, n) Ck.checkIndex Ck.Unsafe (i) (n)+#else+# define CHECK_INDEX(name, i, n) UNSAFE_CHECK(checkIndex) name (i) (n)+#endif+ #include "vector.h" -- | Sorts the elements at the positions 'off' and 'off + 1' in the given@@ -54,8 +61,8 @@ -- be the 'lower' of the two. sort2ByIndex :: (PrimMonad m, MVector v e) => Comparison e -> v (PrimState m) e -> Int -> Int -> m ()-sort2ByIndex cmp a i j = UNSAFE_CHECK(checkIndex) "sort2ByIndex" i (length a)- $ UNSAFE_CHECK(checkIndex) "sort2ByIndex" j (length a) $ do+sort2ByIndex cmp a i j = CHECK_INDEX("sort2ByIndex", i, length a)+ $ CHECK_INDEX("sort2ByIndex", j, length a) $ do a0 <- unsafeRead a i a1 <- unsafeRead a j case cmp a0 a1 of@@ -75,9 +82,9 @@ -- lowest position in the array. sort3ByIndex :: (PrimMonad m, MVector v e) => Comparison e -> v (PrimState m) e -> Int -> Int -> Int -> m ()-sort3ByIndex cmp a i j k = UNSAFE_CHECK(checkIndex) "sort3ByIndex" i (length a)- $ UNSAFE_CHECK(checkIndex) "sort3ByIndex" j (length a)- $ UNSAFE_CHECK(checkIndex) "sort3ByIndex" k (length a) $ do+sort3ByIndex cmp a i j k = CHECK_INDEX("sort3ByIndex", i, length a)+ $ CHECK_INDEX("sort3ByIndex", j, length a)+ $ CHECK_INDEX("sort3ByIndex", k, length a) $ do a0 <- unsafeRead a i a1 <- unsafeRead a j a2 <- unsafeRead a k@@ -114,10 +121,10 @@ -- it can be used to sort medians into particular positions and so on. sort4ByIndex :: (PrimMonad m, MVector v e) => Comparison e -> v (PrimState m) e -> Int -> Int -> Int -> Int -> m ()-sort4ByIndex cmp a i j k l = UNSAFE_CHECK(checkIndex) "sort4ByIndex" i (length a)- $ UNSAFE_CHECK(checkIndex) "sort4ByIndex" j (length a)- $ UNSAFE_CHECK(checkIndex) "sort4ByIndex" k (length a)- $ UNSAFE_CHECK(checkIndex) "sort4ByIndex" l (length a) $ do+sort4ByIndex cmp a i j k l = CHECK_INDEX("sort4ByIndex", i, length a)+ $ CHECK_INDEX("sort4ByIndex", j, length a)+ $ CHECK_INDEX("sort4ByIndex", k, length a)+ $ CHECK_INDEX("sort4ByIndex", l, length a) $ do a0 <- unsafeRead a i a1 <- unsafeRead a j a2 <- unsafeRead a k
src/Data/Vector/Algorithms/Search.hs view
@@ -4,7 +4,7 @@ -- --------------------------------------------------------------------------- -- | -- Module : Data.Vector.Algorithms.Search--- Copyright : (c) 2009-2010 Dan Doel+-- Copyright : (c) 2009-2015 Dan Doel, 2015 Tim Baumann -- Maintainer : Dan Doel <dan.doel@gmail.com> -- Stability : Experimental -- Portability : Non-portable (bang patterns)@@ -24,6 +24,10 @@ , binarySearchRByBounds , binarySearchP , binarySearchPBounds+ , gallopingSearchLeftP+ , gallopingSearchLeftPBounds+ , gallopingSearchRightP+ , gallopingSearchRightPBounds , Comparison ) where @@ -35,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.@@ -66,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@@ -115,7 +119,7 @@ where p e' = case cmp e' e of GT -> True ; _ -> False {-# INLINE binarySearchRByBounds #-} --- | Given a predicate that is guaraneteed to be monotone on the given vector,+-- | Given a predicate that is guaranteed to be monotone on the given vector, -- finds the first index at which the predicate returns True, or the length of -- the array if the predicate is false for the entire array. binarySearchP :: (PrimMonad m, MVector v e) => (e -> Bool) -> v (PrimState m) e -> m Int@@ -132,5 +136,74 @@ 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+-- in order, finds the index at which the predicate turns from False to True.+-- The length of the vector is returned if the predicate is False for the entire+-- vector.+--+-- Begins searching at the start of the vector, in increasing steps of size 2^n.+gallopingSearchLeftP+ :: (PrimMonad m, MVector v e) => (e -> Bool) -> v (PrimState m) e -> m Int+gallopingSearchLeftP p vec = gallopingSearchLeftPBounds p vec 0 (length vec)+{-# INLINE gallopingSearchLeftP #-}++-- | Given a predicate that is guaranteed to be monotone on the vector elements+-- in order, finds the index at which the predicate turns from False to True.+-- The length of the vector is returned if the predicate is False for the entire+-- vector.+--+-- Begins searching at the end of the vector, in increasing steps of size 2^n.+gallopingSearchRightP+ :: (PrimMonad m, MVector v e) => (e -> Bool) -> v (PrimState m) e -> m Int+gallopingSearchRightP p vec = gallopingSearchRightPBounds p vec 0 (length vec)+{-# INLINE gallopingSearchRightP #-}++-- | Given a predicate that is guaranteed to be monotone on the indices [l,u) in+-- a given vector, finds the index in [l,u] at which the predicate turns from+-- False to True (yielding u if the entire interval is False).+-- Begins searching at l, going right in increasing (2^n)-steps.+gallopingSearchLeftPBounds :: (PrimMonad m, MVector v e)+ => (e -> Bool)+ -> v (PrimState m) e+ -> Int -- ^ l+ -> Int -- ^ u+ -> m Int+gallopingSearchLeftPBounds p vec l u+ | u <= l = return l+ | otherwise = do x <- unsafeRead vec l+ if p x then return l else iter (l+1) l 2+ where+ binSearch = binarySearchPBounds p vec+ iter !i !j !_stepSize | i >= u - 1 = do+ x <- unsafeRead vec (u-1)+ if p x then binSearch (j+1) (u-1) else return u+ iter !i !j !stepSize = do+ x <- unsafeRead vec i+ if p x then binSearch (j+1) i else iter (i+stepSize) i (2*stepSize)+{-# INLINE gallopingSearchLeftPBounds #-}++-- | Given a predicate that is guaranteed to be monotone on the indices [l,u) in+-- a given vector, finds the index in [l,u] at which the predicate turns from+-- False to True (yielding u if the entire interval is False).+-- Begins searching at u, going left in increasing (2^n)-steps.+gallopingSearchRightPBounds :: (PrimMonad m, MVector v e)+ => (e -> Bool)+ -> v (PrimState m) e+ -> Int -- ^ l+ -> Int -- ^ u+ -> m Int+gallopingSearchRightPBounds p vec l u+ | u <= l = return l+ | otherwise = iter (u-1) (u-1) (-1)+ where+ binSearch = binarySearchPBounds p vec+ iter !i !j !_stepSize | i <= l = do+ x <- unsafeRead vec l+ if p x then return l else binSearch (l+1) j+ iter !i !j !stepSize = do+ x <- unsafeRead vec i+ if p x then iter (i+stepSize) i (2*stepSize) else binSearch (i+1) j+{-# INLINE gallopingSearchRightPBounds #-}
+ src/Data/Vector/Algorithms/Tim.hs view
@@ -0,0 +1,382 @@+{-# LANGUAGE BangPatterns #-}++-- ---------------------------------------------------------------------------+-- |+-- Module : Data.Vector.Algorithms.Tim+-- Copyright : (c) 2013-2015 Dan Doel, 2015 Tim Baumann+-- Maintainer : Dan Doel <dan.doel@gmail.com>+-- Stability : Experimental+-- Portability : Non-portable (bang patterns)+--+-- Timsort is a complex, adaptive, bottom-up merge sort. It is designed to+-- minimize comparisons as much as possible, even at some cost in overhead.+-- Thus, it may not be ideal for sorting simple primitive types, for which+-- comparison is cheap. It may, however, be significantly faster for sorting+-- arrays of complex values (strings would be an example, though an algorithm+-- not based on comparison would probably be superior in that particular+-- case).+--+-- For more information on the details of the algorithm, read on.+--+-- The first step of the algorithm is to identify runs of elements. These can+-- either be non-decreasing or strictly decreasing sequences of elements in+-- the input. Strictly decreasing sequences are used rather than+-- non-increasing so that they can be easily reversed in place without the+-- sort becoming unstable.+--+-- If the natural runs are too short, they are padded to a minimum value. The+-- minimum is chosen based on the length of the array, and padded runs are put+-- in order using insertion sort. The length of the minimum run size is+-- determined as follows:+--+-- * If the length of the array is less than 64, the minimum size is the+-- length of the array, and insertion sort is used for the entirety+--+-- * Otherwise, a value between 32 and 64 is chosen such that N/min is+-- either equal to or just below a power of two. This avoids having a+-- small chunk left over to merge into much larger chunks at the end.+--+-- This is accomplished by taking the the mininum to be the lowest six bits+-- containing the highest set bit, and adding one if any other bits are set.+-- For instance:+--+-- length: 00000000 00000000 00000000 00011011 = 25+-- min: 00000000 00000000 00000000 00011011 = 25+--+-- length: 00000000 11111100 00000000 00000000 = 63 * 2^18+-- min: 00000000 00000000 00000000 00111111 = 63+--+-- length: 00000000 11111100 00000000 00000001 = 63 * 2^18 + 1+-- min: 00000000 00000000 00000000 01000000 = 64+--+-- Once chunks can be produced, the next step is merging them. The indices of+-- all runs are stored in a stack. When we identify a new run, we push it onto+-- the stack. However, certain invariants are maintained of the stack entries.+-- Namely:+--+-- if stk = _ :> z :> y :> x+-- length x + length y < length z+--+-- if stk = _ :> y :> x+-- length x < length y+--+-- This ensures that the chunks stored are decreasing, and that the chunk+-- sizes follow something like the fibonacci sequence, ensuring there at most+-- log-many chunks at any time. If pushing a new chunk on the stack would+-- violate either of the invariants, we first perform a merge.+--+-- If length x + length y >= length z, then y is merged with the smaller of x+-- and z (if they are tied, x is chosen, because it is more likely to be+-- cached). If, further, length x >= length y then they are merged. These steps+-- are repeated until the invariants are established.+--+-- The last important piece of the algorithm is the merging. At first, two+-- chunks are merged element-wise. However, while doing so, counts are kept of+-- the number of elements taken from one chunk without any from its partner. If+-- this count exceeds a threshold, the merge switches to searching for elements+-- from one chunk in the other, and copying chunks at a time. If these chunks+-- start falling below the threshold, the merge switches back to element-wise.+--+-- The search used in the merge is also special. It uses a galloping strategy,+-- where exponentially increasing indices are tested, and once two such indices+-- are determined to bracket the desired value, binary search is used to find+-- the exact index within that range. This is asymptotically the same as simply+-- using binary search, but is likely to do fewer comparisons than binary search+-- would.+--+-- One aspect that is not yet implemented from the original Tim sort is the+-- adjustment of the above threshold. When galloping saves time, the threshold+-- is lowered, and when it doesn't, it is raised. This may be implemented in the+-- future.++module Data.Vector.Algorithms.Tim+ ( sort+ , sortUniq+ , sortBy+ , sortUniqBy+ ) where++import Prelude hiding (length, reverse)++import Control.Monad.Primitive+import Control.Monad (when)+import Data.Bits++import Data.Vector.Generic.Mutable++import Data.Vector.Algorithms.Search ( gallopingSearchRightPBounds+ , gallopingSearchLeftPBounds+ )+import Data.Vector.Algorithms.Insertion (sortByBounds', Comparison)+import Data.Vector.Algorithms.Common (uniqueMutableBy)++-- | 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 #-}++-- | A variant on `sort` that returns a vector of unique elements.+sortUniq :: (PrimMonad m, MVector v e, Ord e) => v (PrimState m) e -> m (v (PrimState m) e)+sortUniq = sortUniqBy compare+{-# INLINE sortUniq #-}++-- | Sorts an array using a custom comparison.+sortBy :: (PrimMonad m, MVector v e)+ => Comparison e -> v (PrimState m) e -> m ()+sortBy cmp vec+ | mr == len = iter [0] 0 (error "no merge buffer needed!")+ | otherwise = new 256 >>= iter [] 0+ where+ len = length vec+ mr = minrun len+ iter s i tmpBuf+ | i >= len = performRemainingMerges s tmpBuf+ | otherwise = do (order, runLen) <- nextRun cmp vec i len+ when (order == Descending) $+ reverse $ unsafeSlice i runLen vec+ let runEnd = min len (i + max runLen mr)+ sortByBounds' cmp vec i (i+runLen) runEnd+ (s', tmpBuf') <- performMerges (i : s) runEnd tmpBuf+ iter s' runEnd tmpBuf'+ runLengthInvariantBroken a b c i = (b - a <= i - b) || (c - b <= i - c)+ performMerges [b,a] i tmpBuf+ | i - b >= b - a = merge cmp vec a b i tmpBuf >>= performMerges [a] i+ performMerges (c:b:a:ss) i tmpBuf+ | runLengthInvariantBroken a b c i =+ if i - c <= b - a+ then merge cmp vec b c i tmpBuf >>= performMerges (b:a:ss) i+ else do tmpBuf' <- merge cmp vec a b c tmpBuf+ (ass', tmpBuf'') <- performMerges (a:ss) c tmpBuf'+ performMerges (c:ass') i tmpBuf''+ performMerges s _ tmpBuf = return (s, tmpBuf)+ performRemainingMerges (b:a:ss) tmpBuf =+ merge cmp vec a b len tmpBuf >>= performRemainingMerges (a:ss)+ performRemainingMerges _ _ = return ()+{-# INLINE sortBy #-}++-- | A variant on `sortBy` which returns a vector of unique elements.+sortUniqBy :: (PrimMonad m, MVector v e)+ => Comparison e -> v (PrimState m) e -> m (v (PrimState m) e)+sortUniqBy cmp vec = do+ sortBy cmp vec+ uniqueMutableBy cmp vec+{-# INLINE sortUniqBy #-}++-- | Computes the minimum run size for the sort. The goal is to choose a size+-- such that there are almost if not exactly 2^n chunks of that size in the+-- array.+minrun :: Int -> Int+minrun n0 = (n0 `unsafeShiftR` extra) + if (lowMask .&. n0) > 0 then 1 else 0+ where+ -- smear the bits down from the most significant bit+ !n1 = n0 .|. unsafeShiftR n0 1+ !n2 = n1 .|. unsafeShiftR n1 2+ !n3 = n2 .|. unsafeShiftR n2 4+ !n4 = n3 .|. unsafeShiftR n3 8+ !n5 = n4 .|. unsafeShiftR n4 16+ !n6 = n5 .|. unsafeShiftR n5 32++ -- mask for the bits lower than the 6 highest bits+ !lowMask = n6 `unsafeShiftR` 6++ !extra = popCount lowMask+{-# INLINE minrun #-}++data Order = Ascending | Descending deriving (Eq, Show)++-- | Identify the next run (that is a monotonically increasing or strictly+-- decreasing sequence) in the slice [l,u) in vec. Returns the order and length+-- of the run.+nextRun :: (PrimMonad m, MVector v e)+ => Comparison e+ -> v (PrimState m) e+ -> Int -- ^ l+ -> Int -- ^ u+ -> m (Order, Int)+nextRun _ _ i len | i+1 >= len = return (Ascending, 1)+nextRun cmp vec i len = do x <- unsafeRead vec i+ y <- unsafeRead vec (i+1)+ if x `gt` y then desc y 2 else asc y 2+ where+ gt a b = cmp a b == GT+ desc _ !k | i + k >= len = return (Descending, k)+ desc x !k = do y <- unsafeRead vec (i+k)+ if x `gt` y then desc y (k+1) else return (Descending, k)+ asc _ !k | i + k >= len = return (Ascending, k)+ asc x !k = do y <- unsafeRead vec (i+k)+ if x `gt` y then return (Ascending, k) else asc y (k+1)+{-# INLINE nextRun #-}++-- | Tests if a temporary buffer has a given size. If not, allocates a new+-- buffer and returns it instead of the old temporary buffer.+ensureCapacity :: (PrimMonad m, MVector v e)+ => Int -> v (PrimState m) e -> m (v (PrimState m) e)+ensureCapacity l tmpBuf+ | l <= length tmpBuf = return tmpBuf+ | otherwise = new (2*l)+{-# INLINE ensureCapacity #-}++-- | Copy the slice [i,i+len) from vec to tmpBuf. If tmpBuf is not large enough,+-- a new buffer is allocated and used. Returns the buffer.+cloneSlice :: (PrimMonad m, MVector v e)+ => Int -- ^ i+ -> Int -- ^ len+ -> v (PrimState m) e -- ^ vec+ -> v (PrimState m) e -- ^ tmpBuf+ -> m (v (PrimState m) e)+cloneSlice i len vec tmpBuf = do+ tmpBuf' <- ensureCapacity len tmpBuf+ unsafeCopy (unsafeSlice 0 len tmpBuf') (unsafeSlice i len vec)+ return tmpBuf'+{-# INLINE cloneSlice #-}++-- | Number of consecutive times merge chooses the element from the same run+-- before galloping mode is activated.+minGallop :: Int+minGallop = 7+{-# INLINE minGallop #-}++-- | Merge the adjacent sorted slices [l,m) and [m,u) in vec. This is done by+-- copying the slice [l,m) to a temporary buffer. Returns the (enlarged)+-- temporary buffer.+mergeLo :: (PrimMonad m, MVector v e)+ => Comparison e+ -> v (PrimState m) e -- ^ vec+ -> Int -- ^ l+ -> Int -- ^ m+ -> Int -- ^ u+ -> v (PrimState m) e -- ^ tmpBuf+ -> m (v (PrimState m) e)+mergeLo cmp vec l m u tempBuf' = do+ tmpBuf <- cloneSlice l tmpBufLen vec tempBuf'+ vi <- unsafeRead tmpBuf 0+ vj <- unsafeRead vec m+ iter tmpBuf 0 m l vi vj minGallop minGallop+ return tmpBuf+ where+ gt a b = cmp a b == GT+ gte a b = cmp a b /= LT+ tmpBufLen = m - l++ finalize tmpBuf i k = do+ let from = unsafeSlice i (tmpBufLen-i) tmpBuf+ to = unsafeSlice k (tmpBufLen-i) vec+ unsafeCopy to from++ iter _ i _ _ _ _ _ _ | i >= tmpBufLen = return ()+ iter tmpBuf i j k _ _ _ _ | j >= u = finalize tmpBuf i k+ iter tmpBuf i j k _ vj 0 _ = do+ i' <- gallopingSearchLeftPBounds (`gt` vj) tmpBuf i tmpBufLen+ let gallopLen = i' - i+ from = unsafeSlice i gallopLen tmpBuf+ to = unsafeSlice k gallopLen vec+ unsafeCopy to from+ when (i' < tmpBufLen) $ do+ vi' <- unsafeRead tmpBuf i'+ iter tmpBuf i' j (k+gallopLen) vi' vj minGallop minGallop+ iter tmpBuf i j k vi _ _ 0 = do+ j' <- gallopingSearchLeftPBounds (`gte` vi) vec j u+ let gallopLen = j' - j+ from = slice j gallopLen vec+ to = slice k gallopLen vec+ unsafeMove to from+ if j' >= u then finalize tmpBuf i (k + gallopLen) else do+ vj' <- unsafeRead vec j'+ iter tmpBuf i j' (k+gallopLen) vi vj' minGallop minGallop+ iter tmpBuf i j k vi vj ga gb+ | vj `gte` vi = do unsafeWrite vec k vi+ when (i + 1 < tmpBufLen) $ do+ vi' <- unsafeRead tmpBuf (i+1)+ iter tmpBuf (i+1) j (k+1) vi' vj (ga-1) minGallop+ | otherwise = do unsafeWrite vec k vj+ if j + 1 >= u then finalize tmpBuf i (k + 1) else do+ vj' <- unsafeRead vec (j+1)+ iter tmpBuf i (j+1) (k+1) vi vj' minGallop (gb-1)+{-# INLINE mergeLo #-}++-- | Merge the adjacent sorted slices [l,m) and [m,u) in vec. This is done by+-- copying the slice [j,k) to a temporary buffer. Returns the (enlarged)+-- temporary buffer.+mergeHi :: (PrimMonad m, MVector v e)+ => Comparison e+ -> v (PrimState m) e -- ^ vec+ -> Int -- ^ l+ -> Int -- ^ m+ -> Int -- ^ u+ -> v (PrimState m) e -- ^ tmpBuf+ -> m (v (PrimState m) e)+mergeHi cmp vec l m u tmpBuf' = do+ tmpBuf <- cloneSlice m tmpBufLen vec tmpBuf'+ vi <- unsafeRead vec (m-1)+ vj <- unsafeRead tmpBuf (tmpBufLen-1)+ iter tmpBuf (m-1) (tmpBufLen-1) (u-1) vi vj minGallop minGallop+ return tmpBuf+ where+ gt a b = cmp a b == GT+ gte a b = cmp a b /= LT+ tmpBufLen = u - m++ finalize tmpBuf j = do+ let from = unsafeSlice 0 (j+1) tmpBuf+ to = unsafeSlice l (j+1) vec+ unsafeCopy to from++ iter _ _ j _ _ _ _ _ | j < 0 = return ()+ iter tmpBuf i j _ _ _ _ _ | i < l = finalize tmpBuf j+ iter tmpBuf i j k _ vj 0 _ = do+ i' <- gallopingSearchRightPBounds (`gt` vj) vec l i+ let gallopLen = i - i'+ from = slice (i'+1) gallopLen vec+ to = slice (k-gallopLen+1) gallopLen vec+ unsafeMove to from+ if i' < l then finalize tmpBuf j else do+ vi' <- unsafeRead vec i'+ iter tmpBuf i' j (k-gallopLen) vi' vj minGallop minGallop+ iter tmpBuf i j k vi _ _ 0 = do+ j' <- gallopingSearchRightPBounds (`gte` vi) tmpBuf 0 j+ let gallopLen = j - j'+ from = slice (j'+1) gallopLen tmpBuf+ to = slice (k-gallopLen+1) gallopLen vec+ unsafeCopy to from+ when (j' >= 0) $ do+ vj' <- unsafeRead tmpBuf j'+ iter tmpBuf i j' (k-gallopLen) vi vj' minGallop minGallop+ iter tmpBuf i j k vi vj ga gb+ | vi `gt` vj = do unsafeWrite vec k vi+ if i - 1 < l then finalize tmpBuf j else do+ vi' <- unsafeRead vec (i-1)+ iter tmpBuf (i-1) j (k-1) vi' vj (ga-1) minGallop+ | otherwise = do unsafeWrite vec k vj+ when (j - 1 >= 0) $ do+ vj' <- unsafeRead tmpBuf (j-1)+ iter tmpBuf i (j-1) (k-1) vi vj' minGallop (gb-1)+{-# INLINE mergeHi #-}++-- | Merge the adjacent sorted slices A=[l,m) and B=[m,u) in vec. This begins+-- with galloping searches to find the index of vec[m] in A and the index of+-- vec[m-1] in B to reduce the sizes of A and B. Then it uses `mergeHi` or+-- `mergeLo` depending on whether A or B is larger. Returns the (enlarged)+-- temporary buffer.+merge :: (PrimMonad m, MVector v e)+ => Comparison e+ -> v (PrimState m) e -- ^ vec+ -> Int -- ^ l+ -> Int -- ^ m+ -> Int -- ^ u+ -> v (PrimState m) e -- ^ tmpBuf+ -> m (v (PrimState m) e)+merge cmp vec l m u tmpBuf = do+ vm <- unsafeRead vec m+ l' <- gallopingSearchLeftPBounds (`gt` vm) vec l m+ if l' >= m+ then return tmpBuf+ else do+ vn <- unsafeRead vec (m-1)+ u' <- gallopingSearchRightPBounds (`gte` vn) vec m u+ if u' <= m+ then return tmpBuf+ else (if (m-l') <= (u'-m) then mergeLo else mergeHi) cmp vec l' m u' tmpBuf+ where+ gt a b = cmp a b == GT+ gte a b = cmp a b /= LT+{-# INLINE merge #-}
tests/properties/Optimal.hs view
@@ -8,7 +8,7 @@ import Control.Arrow import Control.Monad -import Data.List+import qualified Data.List as List import Data.Function import Data.Vector.Generic hiding (map, zip, concatMap, (++), replicate, foldM)@@ -32,18 +32,18 @@ stability :: (Vector v (Int,Int)) => Int -> [v (Int, Int)] stability n = concatMap ( map fromList . foldM interleavings []- . groupBy ((==) `on` fst)+ . List.groupBy ((==) `on` fst) . flip zip [0..]) $ monotones (n-2) n sort2 :: (Vector v Int) => [v Int]-sort2 = map fromList $ permutations [0,1]+sort2 = map fromList $ List.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]+sort3 = map fromList $ List.permutations [0..2] {- stability3 :: [UArr (Int :*: Int)]@@ -58,5 +58,5 @@ -} sort4 :: (Vector v Int) => [v Int]-sort4 = map fromList $ permutations [0..3]+sort4 = map fromList $ List.permutations [0..3]
tests/properties/Properties.hs view
@@ -1,4 +1,7 @@-{-# LANGUAGE RankNTypes, FlexibleContexts #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeOperators #-} module Properties where @@ -21,13 +24,15 @@ import Data.Vector.Generic (modify) import qualified Data.Vector.Generic.Mutable as G+import qualified Data.Vector.Generic as GV import Data.Vector.Algorithms.Optimal (Comparison) import Data.Vector.Algorithms.Radix (radix, passes, size)+import qualified Data.Vector.Algorithms as Alg import qualified Data.Map as M -import Test.QuickCheck+import Test.QuickCheck hiding (Sorted) import Util @@ -38,6 +43,13 @@ check e arr | V.null arr = property True | otherwise = e <= V.head arr .&. check (V.head arr) (V.tail arr) +prop_sorted_uniq :: (Ord e) => Vector e -> Property+prop_sorted_uniq 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 []) @@ -45,6 +57,23 @@ => (forall s mv. G.MVector mv e => mv s e -> ST s ()) -> Vector e -> Property prop_fullsort algo arr = prop_sorted $ modify algo arr +runFreeze+ :: forall e . (Ord e)+ => (forall s mv . G.MVector mv e => mv s e -> ST s (mv s e))+ -> (forall s v mv. (GV.Vector v e, mv ~ GV.Mutable v) => mv s e -> ST s (v e))+runFreeze alg mv = do+ mv <- alg mv+ GV.unsafeFreeze mv++prop_full_sortUniq+ :: (Ord e, Show e)+ => (forall s . MV.MVector s e -> ST s (Vector e))+ -> Vector e -> Property+prop_full_sortUniq algo arr = runST $ do+ mv <- V.unsafeThaw arr+ arr' <- algo mv+ pure (prop_sorted_uniq arr')+ {- prop_schwartzian :: (UA e, UA k, Ord k) => (e -> k)@@ -68,8 +97,14 @@ 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_partialsort = prop_sized $ \algo k v -> do+ let newVec = modify algo v+ vhead = V.take k newVec+ vtail = V.drop k newVec+ prop_sorted vhead+ .&&.+ -- Every element in the head should be < every element in the tail.+ if V.null vtail then 1 == 1 else V.maximum vhead <= V.minimum vtail 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)@@ -104,7 +139,7 @@ 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) +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 =@@ -113,7 +148,7 @@ 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@@ -137,7 +172,7 @@ prop_permutation :: (Ord e) => (forall s mv. G.MVector mv e => mv s e -> ST s ()) -> Vector e -> Property-prop_permutation algo arr = property $ +prop_permutation algo arr = property $ toBag arr == toBag (modify algo arr) newtype SortedVec e = Sorted (Vector e)@@ -183,3 +218,7 @@ => (forall s. MVector s e -> e -> ST s Int) -> SortedVec e -> e -> Property prop_search_upbound = prop_search_insert (<=) (>)++prop_nub :: (Ord e, Show e) => Vector e -> Property+prop_nub v =+ V.fromList (nub (V.toList v)) === Alg.nub v
tests/properties/Tests.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE ImpredicativeTypes, RankNTypes, TypeOperators, FlexibleContexts #-}+{-# LANGUAGE RankNTypes, TypeOperators, FlexibleContexts, TypeApplications #-} module Main (main) where @@ -18,7 +18,9 @@ import Data.Vector (Vector) import qualified Data.Vector as V+import qualified Data.Vector.Mutable as BoxedMV +import qualified Data.Vector.Generic as G import Data.Vector.Generic.Mutable (MVector) import qualified Data.Vector.Generic.Mutable as MV @@ -29,44 +31,66 @@ 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.Tim as T 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+type MonoAlgo e r = forall s . BoxedMV.MVector s e -> ST s r +newtype WrappedAlgo e r = WrapAlgo { unWrapAlgo :: Algo e r }+newtype WrappedSizeAlgo e r = WrapSizeAlgo { unWrapSizeAlgo :: SizeAlgo e r }+newtype WrappedBoundAlgo e r = WrapBoundAlgo { unWrapBoundAlgo :: BoundAlgo e r }+newtype WrappedMonoAlgo e r = MonoAlgo { unWrapMonoAlgo :: MonoAlgo e r }+ args = stdArgs { maxSuccess = 1000 , maxDiscardRatio = 2 } check_Int_sort = forM_ algos $ \(name,algo) ->- quickCheckWith args (label name . prop_fullsort algo)+ quickCheckWith args (label name . prop_fullsort (unWrapAlgo algo)) where- algos :: [(String, Algo Int ())]- algos = [ ("introsort", INT.sort)- , ("insertion sort", INS.sort)- , ("merge sort", M.sort)- , ("heapsort", H.sort)+ algos :: [(String, WrappedAlgo Int ())]+ algos = [ ("introsort", WrapAlgo INT.sort)+ , ("insertion sort", WrapAlgo INS.sort)+ , ("merge sort", WrapAlgo M.sort)+ , ("heapsort", WrapAlgo H.sort)+ , ("timsort", WrapAlgo T.sort) ] +check_Int_sortUniq = forM_ algos $ \(name,algo) ->+ quickCheckWith args (label name . prop_full_sortUniq (unWrapMonoAlgo algo))+ where+ algos :: [(String, WrappedMonoAlgo Int (Vector Int))]+ algos = [ ("intro_sortUniq", MonoAlgo (runFreeze INT.sortUniq))+ , ("insertion sortUniq", MonoAlgo (runFreeze INS.sortUniq))+ , ("merge sortUniq", MonoAlgo (runFreeze M.sortUniq))+ , ("heap_sortUniq", MonoAlgo (runFreeze H.sortUniq))+ , ("tim_sortUniq", MonoAlgo (runFreeze T.sortUniq))+ ]+ check_Int_partialsort = forM_ algos $ \(name,algo) ->- quickCheckWith args (label name . prop_partialsort algo)+ quickCheckWith args (label name . prop_partialsort (unWrapSizeAlgo algo)) where- algos :: [(String, SizeAlgo Int ())]- algos = [ ("intro-partialsort", INT.partialSort)- , ("heap partialsort", H.partialSort)+ algos :: [(String, WrappedSizeAlgo Int ())]+ algos = [ ("intro-partialsort", WrapSizeAlgo INT.partialSort)+ , ("heap partialsort", WrapSizeAlgo H.partialSort) ] check_Int_select = forM_ algos $ \(name,algo) ->- quickCheckWith args (label name . prop_select algo)+ quickCheckWith args (label name . prop_select (unWrapSizeAlgo algo)) where- algos :: [(String, SizeAlgo Int ())]- algos = [ ("intro-select", INT.select)- , ("heap select", H.select)+ algos :: [(String, WrappedSizeAlgo Int ())]+ algos = [ ("intro-select", WrapSizeAlgo INT.select)+ , ("heap select", WrapSizeAlgo H.select) ] +check_nub = quickCheckWith args (label "nub Int" . (prop_nub @Int))++ check_radix_sorts = do qc (label "radix Word8" . prop_fullsort (R.sort :: Algo Word8 ())) qc (label "radix Word16" . prop_fullsort (R.sort :: Algo Word16 ()))@@ -104,7 +128,9 @@ check_stable = do quickCheckWith args (label "merge sort" . prop_stable M.sortBy) quickCheckWith args (label "radix sort" . prop_stable_radix R.sortBy)+ quickCheckWith args (label "tim sort" . prop_stable T.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@@ -113,16 +139,10 @@ 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 ()) qc $ label "radix I16" . prop_permutation (R.sort :: Algo Int16 ()) qc $ label "radix I32" . prop_permutation (R.sort :: Algo Int32 ())@@ -144,6 +164,15 @@ 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 (\x -> const (prop_permutation x))+ (INT.partialSort :: SizeAlgo Int ())+ qc $ label "introselect" . prop_sized (\x -> const (prop_permutation x))+ (INT.select :: SizeAlgo Int ())+ qc $ label "heappartial" . prop_sized (\x -> const (prop_permutation x))+ (H.partialSort :: SizeAlgo Int ())+ qc $ label "heapselect" . prop_sized (\x -> const (prop_permutation x))+ (H.select :: SizeAlgo Int ())+ where qc prop = quickCheckWith args prop @@ -155,6 +184,7 @@ 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 "timsort empty" $ prop_empty (T.sort :: Algo Int ()) qc "radixsort empty" $ prop_empty (R.sort :: Algo Int ()) qc "flagsort empty" $ prop_empty (AF.sort :: Algo Int ()) where@@ -179,6 +209,7 @@ main = do putStrLn "Int tests:" check_Int_sort+ check_Int_sortUniq check_Int_partialsort check_Int_select putStrLn "Radix sort tests:"@@ -195,3 +226,5 @@ check_search_range putStrLn "Corner cases:" check_corners+ putStrLn "Algorithms:"+ check_nub
vector-algorithms.cabal view
@@ -1,17 +1,36 @@+cabal-version: >= 1.10 name: vector-algorithms-version: 0.6.0.4+version: 0.9.1.0 license: BSD3 license-file: LICENSE author: Dan Doel maintainer: Dan Doel <dan.doel@gmail.com>-copyright: (c) 2008,2009,2010,2011,2012,2013,2014 Dan Doel-homepage: http://code.haskell.org/~dolio/+ 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: 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 +extra-source-files: CHANGELOG.md++tested-with:+ GHC == 9.12.1+ GHC == 9.10.1+ GHC == 9.8.2+ GHC == 9.6.3+ GHC == 9.4.7+ GHC == 9.2.8+ GHC == 9.0.2+ GHC == 8.10.7+ GHC == 8.8.4+ GHC == 8.6.5+ GHC == 8.4.4+ GHC == 8.2.2+ flag BoundsChecks description: Enable bounds checking default: True@@ -29,25 +48,35 @@ flag bench description: Build a benchmarking program to test vector-algorithms performance- default: False--flag properties- 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+ default-language: Haskell2010 - build-depends: base >= 3 && < 5,- vector >= 0.6 && < 0.11,- primitive >=0.3 && <0.7,- bytestring >= 0.9 && < 1.0+ build-depends: base >= 4.8 && < 5,+ bitvec >= 1.0 && < 1.2,+ vector >= 0.6 && < 0.14,+ primitive >= 0.6.2.0 && < 0.10,+ bytestring >= 0.9 && < 1 + if ! impl (ghc >= 7.8)+ build-depends: tagged >= 0.4 && < 0.9+ exposed-modules:+ Data.Vector.Algorithms Data.Vector.Algorithms.Optimal Data.Vector.Algorithms.Insertion Data.Vector.Algorithms.Intro@@ -56,14 +85,21 @@ Data.Vector.Algorithms.Search Data.Vector.Algorithms.Heap Data.Vector.Algorithms.AmericanFlag+ Data.Vector.Algorithms.Tim other-modules: 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 @@ -79,8 +115,10 @@ if flag(InternalChecks) cpp-options: -DVECTOR_INTERNAL_CHECKS -executable vector-algorithms-bench- hs-source-dirs: bench+benchmark simple-bench+ hs-source-dirs: bench/simple+ type: exitcode-stdio-1.0+ default-language: Haskell2010 if !flag(bench) buildable: False@@ -90,26 +128,34 @@ other-modules: Blocks - build-depends: base, mwc-random, vector, vector-algorithms, mtl- ghc-options: -Wall -Odph+ build-depends: base, mwc-random, vector, vector-algorithms+ 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 main-is: Tests.hs+ default-language: Haskell2010 other-modules: Optimal Properties Util - if !flag(properties)- buildable: False- else- build-depends:- base,- bytestring,- containers,- QuickCheck >= 2,- vector,- vector-algorithms+ build-depends:+ base >= 4.9,+ bytestring,+ containers,+ QuickCheck > 2.9 && < 2.16,+ vector,+ vector-algorithms++ if flag(llvm)+ ghc-options: -fllvm