packages feed

vector-algorithms 0.7.0.4 → 0.9.1.0

raw patch · 19 files changed

Files

+ 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
@@ -33,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/simple/Blocks.hs view
@@ -46,12 +46,12 @@  where initial n = fill n >>= unsafeWrite arr n >> when (n > 0) (initial $ n - 1) {-# INLINE initialize #-} -speedTest :: (Unbox e) => Int+speedTest :: (Unbox e) => MVector RealWorld e+                       -> Int                        -> (Int -> IO e)                        -> (MVector RealWorld e -> IO ())                        -> IO Integer-speedTest n fill algo = do-  arr <- new n+speedTest arr n fill algo = do   initialize arr n fill   t0 <- clock   algo arr
bench/simple/Main.hs view
@@ -5,14 +5,15 @@ import Prelude hiding (read, length) import qualified Prelude as P +import Control.Monad 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.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@@ -35,25 +36,26 @@ -- 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+          | 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) ++ " seconds"+    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 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+  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 m (medianKiller m) sort+  run "Median killer     " $ speedTest arr m (medianKiller m) sort  partialSortSuite :: String -> GenIO -> Int -> Int                  -> (MVector RealWorld Int -> Int -> IO ()) -> IO ()@@ -142,7 +144,6 @@   RadixSort          -> sortSuite        "radix sort"            g n   radixSort   AmericanFlagSort   -> sortSuite        "flag sort"             g n   flagSort   TimSort            -> sortSuite        "tim sort"              g n   timSort-  _                  -> putStrLn $ "Currently unsupported algorithm: " ++ show alg  mergeSort :: MVector RealWorld Int -> IO () mergeSort v = M.sort v
+ 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 @@ -241,8 +244,16 @@ sort v = sortBy compare terminate (size p) index v  where p :: Proxy e        p = Proxy-{-# INLINABLE sort #-}+{-# 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.@@ -260,6 +271,23 @@                        countLoop (radix 0) v count                        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
src/Data/Vector/Algorithms/Common.hs view
@@ -1,5 +1,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE ScopedTypeVariables #-}  -- --------------------------------------------------------------------------- -- |@@ -11,7 +13,15 @@ -- -- 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) @@ -57,3 +67,66 @@     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
@@ -19,7 +19,9 @@ module Data.Vector.Algorithms.Heap        ( -- * Sorting          sort+       , sortUniq        , sortBy+       , sortUniqBy        , sortByBounds          -- * Selection        , select@@ -47,20 +49,33 @@  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  -- | Sorts an entire array using the default ordering. sort :: (PrimMonad m, MVector v e, Ord e) => v (PrimState m) e -> m () sort = sortBy compare-{-# INLINABLE sort #-}+{-# 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)@@ -173,8 +188,8 @@   | 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@@ -265,8 +280,8 @@  where  sift k    | k <= 0    = unsafeWrite v l e-   | otherwise = let pi = l + shiftR (k-1) 2-                  in unsafeRead v pi >>= \p -> case cmp p e of+   | 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 #-}
src/Data/Vector/Algorithms/Insertion.hs view
@@ -14,7 +14,9 @@  module Data.Vector.Algorithms.Insertion        ( sort+       , sortUniq        , sortBy+       , sortUniqBy        , sortByBounds        , sortByBounds'        , Comparison@@ -27,19 +29,31 @@  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  -- | Sorts an entire array using the default comparison for the type sort :: (PrimMonad m, MVector v e, Ord e) => v (PrimState m) e -> m () sort = sortBy compare-{-# INLINABLE sort #-}+{-# 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
@@ -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, midPoint)+import Data.Vector.Algorithms.Common (Comparison, midPoint, uniqueMutableBy)  import qualified Data.Vector.Algorithms.Insertion as I import qualified Data.Vector.Algorithms.Optimal   as O@@ -65,13 +67,26 @@ -- | Sorts an entire array using the default ordering. sort :: (PrimMonad m, MVector v e, Ord e) => v (PrimState m) e -> m () sort = sortBy compare-{-# INLINABLE sort #-}+{-# 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)@@ -190,7 +205,10 @@   -> 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 #-}
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, midPoint)+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@@ -35,20 +37,39 @@ -- | Sorts an array using the default comparison. sort :: (PrimMonad m, MVector v e, Ord e) => v (PrimState m) e -> m () sort = sortBy compare-{-# INLINABLE sort #-}+{-# 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 ()
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/Radix.hs view
@@ -186,7 +186,7 @@  where  e :: e  e = undefined-{-# INLINABLE sort #-}+{-# INLINE sort #-}  -- | Radix sorts an array using custom radix information -- requires the number of passes to fully sort the array,
src/Data/Vector/Algorithms/Search.hs view
@@ -119,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
src/Data/Vector/Algorithms/Tim.hs view
@@ -91,7 +91,9 @@  module Data.Vector.Algorithms.Tim        ( sort+       , sortUniq        , sortBy+       , sortUniqBy        ) where  import Prelude hiding (length, reverse)@@ -106,12 +108,18 @@                                      , 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-{-# INLINABLE sort #-}+{-# 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 ()@@ -146,6 +154,14 @@  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.@@ -241,34 +257,41 @@  gt  a b = cmp a b == GT  gte a b = cmp a b /= LT  tmpBufLen = m - l- iter _ i _ _ _ _ _ _ | i >= tmpBufLen = return ()- iter tmpBuf i j k _ _ _ _ | j >= u = do++ 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-   vi' <- unsafeRead tmpBuf i'-   iter tmpBuf i' j (k+gallopLen) vi' vj minGallop minGallop+   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-   vj' <- unsafeRead vec j'-   iter tmpBuf i j' (k+gallopLen) vi vj' minGallop minGallop+   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-                      vi' <- unsafeRead tmpBuf (i+1)-                      iter tmpBuf (i+1) j (k+1) vi' vj (ga-1) minGallop+                      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-                      vj' <- unsafeRead vec (j+1)-                      iter tmpBuf i (j+1) (k+1) vi vj' minGallop (gb-1)+                      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@@ -292,34 +315,41 @@  gt  a b = cmp a b == GT  gte a b = cmp a b /= LT  tmpBufLen = u - m- iter _ _ j _ _ _ _ _ | j < 0 = return ()- iter tmpBuf i j _ _ _ _ _ | i < l = do++ 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-   vi' <- unsafeRead vec i'-   iter tmpBuf i' j (k-gallopLen) vi' vj minGallop minGallop+   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-   vj' <- unsafeRead tmpBuf j'-   iter tmpBuf i j' (k-gallopLen) vi vj' minGallop minGallop+   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-                     vi' <- unsafeRead vec (i-1)-                     iter tmpBuf (i-1) j (k-1) vi' vj (ga-1) minGallop+                     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-                     vj' <- unsafeRead tmpBuf (j-1)-                     iter tmpBuf i (j-1) (k-1) vi vj' minGallop (gb-1)+                     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
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 @@ -36,39 +38,59 @@ 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)-         , ("timsort", T.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 ()))@@ -142,16 +164,14 @@   qc $ label "flag W64"     . prop_permutation (AF.sort :: Algo Word64 ())   qc $ label "flag Word"    . prop_permutation (AF.sort :: Algo Word   ())   qc $ label "flag ByteString" . prop_permutation (AF.sort :: Algo B.ByteString ())-{--  qc $ label "intropartial" . prop_sized (const . prop_permutation)+  qc $ label "intropartial" . prop_sized (\x -> const (prop_permutation x))                                          (INT.partialSort :: SizeAlgo Int ())-  qc $ label "introselect"  . prop_sized (const . prop_permutation)+  qc $ label "introselect"  . prop_sized (\x -> const (prop_permutation x))                                          (INT.select :: SizeAlgo Int ())-  qc $ label "heappartial"  . prop_sized (const . prop_permutation)+  qc $ label "heappartial"  . prop_sized (\x -> const (prop_permutation x))                                          (H.partialSort :: SizeAlgo Int ())-  qc $ label "heapselect"   . prop_sized (const . prop_permutation)-                                         (H.select :: Algo Int ())--}+  qc $ label "heapselect"   . prop_sized (\x -> const (prop_permutation x))+                                         (H.select :: SizeAlgo Int ())   where  qc prop = quickCheckWith args prop@@ -189,6 +209,7 @@  main = do putStrLn "Int tests:"           check_Int_sort+          check_Int_sortUniq           check_Int_partialsort           check_Int_select           putStrLn "Radix sort tests:"@@ -205,3 +226,5 @@           check_search_range           putStrLn "Corner cases:"           check_corners+          putStrLn "Algorithms:"+          check_nub
vector-algorithms.cabal view
@@ -1,5 +1,6 @@+cabal-version:     >= 1.10 name:              vector-algorithms-version:           0.7.0.4+version:           0.9.1.0 license:           BSD3 license-file:      LICENSE author:            Dan Doel@@ -13,8 +14,23 @@ 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@@ -32,10 +48,6 @@ 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@@ -52,16 +64,19 @@  library   hs-source-dirs: src+  default-language: Haskell2010 -  build-depends: base >= 4.5 && < 5,-                 vector >= 0.6 && < 0.13,-                 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@@ -100,8 +115,10 @@   if flag(InternalChecks)     cpp-options: -DVECTOR_INTERNAL_CHECKS -executable simple-bench+benchmark simple-bench   hs-source-dirs: bench/simple+  type: exitcode-stdio-1.0+  default-language: Haskell2010    if !flag(bench)     buildable: False@@ -111,7 +128,7 @@   other-modules:     Blocks -  build-depends: base, mwc-random, vector, vector-algorithms, mtl+  build-depends: base, mwc-random, vector, vector-algorithms   ghc-options: -Wall    -- Cabal/Hackage complains about these@@ -125,22 +142,20 @@   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