diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -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. + diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -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 diff --git a/bench/Blocks.hs b/bench/Blocks.hs deleted file mode 100644 --- a/bench/Blocks.hs +++ /dev/null @@ -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 #-} - - diff --git a/bench/Main.hs b/bench/Main.hs deleted file mode 100644 --- a/bench/Main.hs +++ /dev/null @@ -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 - - diff --git a/bench/simple/Blocks.hs b/bench/simple/Blocks.hs new file mode 100644 --- /dev/null +++ b/bench/simple/Blocks.hs @@ -0,0 +1,62 @@ +{-# LANGUAGE Rank2Types #-} + +module Blocks where + +import Control.Monad +import Control.Monad.ST + +import Data.Vector.Unboxed.Mutable + +import System.CPUTime + +import System.Random.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 #-} + + diff --git a/bench/simple/Main.hs b/bench/simple/Main.hs new file mode 100644 --- /dev/null +++ b/bench/simple/Main.hs @@ -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 + + diff --git a/src/Data/Vector/Algorithms.hs b/src/Data/Vector/Algorithms.hs new file mode 100644 --- /dev/null +++ b/src/Data/Vector/Algorithms.hs @@ -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 #-} diff --git a/src/Data/Vector/Algorithms/AmericanFlag.hs b/src/Data/Vector/Algorithms/AmericanFlag.hs --- a/src/Data/Vector/Algorithms/AmericanFlag.hs +++ b/src/Data/Vector/Algorithms/AmericanFlag.hs @@ -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 diff --git a/src/Data/Vector/Algorithms/Common.hs b/src/Data/Vector/Algorithms/Common.hs --- a/src/Data/Vector/Algorithms/Common.hs +++ b/src/Data/Vector/Algorithms/Common.hs @@ -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 () diff --git a/src/Data/Vector/Algorithms/Heap.hs b/src/Data/Vector/Algorithms/Heap.hs --- a/src/Data/Vector/Algorithms/Heap.hs +++ b/src/Data/Vector/Algorithms/Heap.hs @@ -4,7 +4,7 @@ -- --------------------------------------------------------------------------- -- | -- Module : Data.Vector.Algorithms.Heap --- Copyright : (c) 2008-2011 Dan Doel +-- Copyright : (c) 2008-2015 Dan Doel -- Maintainer : Dan Doel -- 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 diff --git a/src/Data/Vector/Algorithms/Insertion.hs b/src/Data/Vector/Algorithms/Insertion.hs --- a/src/Data/Vector/Algorithms/Insertion.hs +++ b/src/Data/Vector/Algorithms/Insertion.hs @@ -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) diff --git a/src/Data/Vector/Algorithms/Intro.hs b/src/Data/Vector/Algorithms/Intro.hs --- a/src/Data/Vector/Algorithms/Intro.hs +++ b/src/Data/Vector/Algorithms/Intro.hs @@ -6,7 +6,7 @@ -- --------------------------------------------------------------------------- -- | -- Module : Data.Vector.Algorithms.Intro --- Copyright : (c) 2008-2011 Dan Doel +-- Copyright : (c) 2008-2015 Dan Doel -- Maintainer : Dan Doel -- 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 diff --git a/src/Data/Vector/Algorithms/Merge.hs b/src/Data/Vector/Algorithms/Merge.hs --- a/src/Data/Vector/Algorithms/Merge.hs +++ b/src/Data/Vector/Algorithms/Merge.hs @@ -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) diff --git a/src/Data/Vector/Algorithms/Optimal.hs b/src/Data/Vector/Algorithms/Optimal.hs --- a/src/Data/Vector/Algorithms/Optimal.hs +++ b/src/Data/Vector/Algorithms/Optimal.hs @@ -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 diff --git a/src/Data/Vector/Algorithms/Search.hs b/src/Data/Vector/Algorithms/Search.hs --- a/src/Data/Vector/Algorithms/Search.hs +++ b/src/Data/Vector/Algorithms/Search.hs @@ -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 -- 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 #-} diff --git a/src/Data/Vector/Algorithms/Tim.hs b/src/Data/Vector/Algorithms/Tim.hs new file mode 100644 --- /dev/null +++ b/src/Data/Vector/Algorithms/Tim.hs @@ -0,0 +1,382 @@ +{-# LANGUAGE BangPatterns #-} + +-- --------------------------------------------------------------------------- +-- | +-- Module : Data.Vector.Algorithms.Tim +-- Copyright : (c) 2013-2015 Dan Doel, 2015 Tim Baumann +-- Maintainer : Dan Doel +-- 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 #-} diff --git a/tests/properties/Optimal.hs b/tests/properties/Optimal.hs --- a/tests/properties/Optimal.hs +++ b/tests/properties/Optimal.hs @@ -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] diff --git a/tests/properties/Properties.hs b/tests/properties/Properties.hs --- a/tests/properties/Properties.hs +++ b/tests/properties/Properties.hs @@ -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 diff --git a/tests/properties/Tests.hs b/tests/properties/Tests.hs --- a/tests/properties/Tests.hs +++ b/tests/properties/Tests.hs @@ -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 diff --git a/vector-algorithms.cabal b/vector-algorithms.cabal --- a/vector-algorithms.cabal +++ b/vector-algorithms.cabal @@ -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 -copyright: (c) 2008,2009,2010,2011,2012,2013,2014 Dan Doel -homepage: http://code.haskell.org/~dolio/ + Erik de Castro Lopo +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