packages feed

vector-algorithms 0.8.0.4 → 0.9.0.1

raw patch · 17 files changed

+348/−30 lines, 17 filesdep +bitvecdep ~basedep ~bytestringdep ~primitive

Dependencies added: bitvec

Dependency ranges changed: base, bytestring, primitive, vector

Files

CHANGELOG.md view
@@ -1,3 +1,12 @@+## 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.
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/Main.hs view
@@ -12,7 +12,8 @@ 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,8 +36,8 @@ -- 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 $@@ -47,7 +48,7 @@  sortSuite :: String -> GenIO -> Int -> (MVector RealWorld Int -> IO ()) -> IO () sortSuite str g n sort = do-  arr <- new n+  arr <- UVector.new n   putStrLn $ "Testing: " ++ str   run "Random            " $ speedTest arr n (rand g >=> modulo n) sort   run "Sorted            " $ speedTest arr n ascend sort
+ src/Data/Vector/Algorithms.hs view
@@ -0,0 +1,74 @@+{-# 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++-- | 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)++-- | 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
src/Data/Vector/Algorithms/AmericanFlag.hs view
@@ -27,7 +27,9 @@ -- rather than running for a set number of iterations.  module Data.Vector.Algorithms.AmericanFlag ( sort+                                           , sortUniq                                            , sortBy+                                           , sortUniqBy                                            , terminate                                            , Lexicographic(..)                                            ) where@@ -244,6 +246,14 @@        p = Proxy {-# INLINABLE 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+{-# INLINABLE 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.@@ -261,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,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 @@ -56,10 +58,23 @@ sort = sortBy compare {-# INLINABLE 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+{-# INLINABLE 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
src/Data/Vector/Algorithms/Insertion.hs view
@@ -14,7 +14,9 @@  module Data.Vector.Algorithms.Insertion        ( sort+       , sortUniq        , sortBy+       , sortUniqBy        , sortByBounds        , sortByBounds'        , Comparison@@ -27,7 +29,7 @@  import Data.Vector.Generic.Mutable -import Data.Vector.Algorithms.Common (Comparison)+import Data.Vector.Algorithms.Common (Comparison, uniqueMutableBy)  import qualified Data.Vector.Algorithms.Optimal as O @@ -36,10 +38,22 @@ sort = sortBy compare {-# INLINABLE 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+{-# INLINABLE 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@@ -67,10 +69,23 @@ sort = sortBy compare {-# INLINABLE 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+{-# INLINABLE 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
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@@ -37,6 +39,11 @@ sort = sortBy compare {-# INLINABLE 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+{-# INLINABLE sortUniq #-}+ -- | Sorts an array using a custom comparison. sortBy :: (PrimMonad m, MVector v e) => Comparison e -> v (PrimState m) e -> m () sortBy cmp vec = if len <= 4@@ -56,6 +63,13 @@  -- 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/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 #-} +-- | 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+{-# INLINABLE sortUniq #-}+ -- | Sorts an array using a custom comparison. sortBy :: (PrimMonad m, MVector v e)        => Comparison e -> v (PrimState m) e -> m ()@@ -145,6 +153,14 @@    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
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,4 @@-{-# LANGUAGE RankNTypes, FlexibleContexts #-}+{-# LANGUAGE RankNTypes, FlexibleContexts, GADTs #-}  module Properties where @@ -21,9 +21,11 @@ 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 @@ -38,6 +40,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 +54,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)@@ -183,3 +209,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 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,10 +38,12 @@ 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@@ -57,6 +61,17 @@          , ("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 (unWrapSizeAlgo algo))  where@@ -73,6 +88,9 @@          , ("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 ()))@@ -191,6 +209,7 @@  main = do putStrLn "Int tests:"           check_Int_sort+          check_Int_sortUniq           check_Int_partialsort           check_Int_select           putStrLn "Radix sort tests:"@@ -207,3 +226,5 @@           check_search_range           putStrLn "Corner cases:"           check_corners+          putStrLn "Algorithms:"+          check_nub
vector-algorithms.cabal view
@@ -1,5 +1,5 @@ name:              vector-algorithms-version:           0.8.0.4+version:           0.9.0.1 license:           BSD3 license-file:      LICENSE author:            Dan Doel@@ -57,7 +57,8 @@   default-language: Haskell2010    build-depends: base >= 4.5 && < 5,-                 vector >= 0.6 && < 0.13,+                 bitvec >= 1.0 && < 1.2,+                 vector >= 0.6 && < 0.14,                  primitive >=0.3 && <0.8,                  bytestring >= 0.9 && < 1.0 @@ -65,6 +66,7 @@     build-depends: tagged >= 0.4 && < 0.9    exposed-modules:+    Data.Vector.Algorithms     Data.Vector.Algorithms.Optimal     Data.Vector.Algorithms.Insertion     Data.Vector.Algorithms.Intro