containers-accelerate (empty) → 0.1.0.0
raw patch · 15 files changed
+1500/−0 lines, 15 filesdep +acceleratedep +accelerate-llvm-nativedep +basesetup-changed
Dependencies added: accelerate, accelerate-llvm-native, base, containers, containers-accelerate, half, hashable-accelerate, hedgehog, tasty, tasty-hedgehog
Files
- CHANGELOG.md +14/−0
- LICENSE +30/−0
- README.md +22/−0
- Setup.hs +2/−0
- containers-accelerate.cabal +69/−0
- src/Data/Array/Accelerate/Data/HashMap.hs +317/−0
- src/Data/Array/Accelerate/Data/HashSet.hs +99/−0
- src/Data/Array/Accelerate/Data/Sort/Merge.hs +137/−0
- src/Data/Array/Accelerate/Data/Sort/Quick.hs +182/−0
- src/Data/Array/Accelerate/Data/Tree/Radix.hs +146/−0
- test/Gen.hs +125/−0
- test/HashMap.hs +160/−0
- test/Sort/Merge.hs +88/−0
- test/Sort/Quick.hs +88/−0
- test/Spec.hs +21/−0
+ CHANGELOG.md view
@@ -0,0 +1,14 @@+# Changelog for containers-accelerate++Notable changes to the project will be documented in this file.++The format is based on [Keep a Changelog](http://keepachangelog.com/) and the+project adheres to the [Haskell Package Versioning+Policy (PVP)](https://pvp.haskell.org)++## [0.1.0.0] - 2020-08-26+### New+ * Initial version++[0.1.0.0]: https://github.com/tmcdonell/containers-accelerate/compare/00ad293cefc684ed4dc3251d06a0de2df9bdaabe...v0.1.0.0+
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Trevor L. McDonell (c) 2020++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Author name here nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,22 @@+<div align="center">+<img width="450" src="https://github.com/AccelerateHS/accelerate/raw/master/images/accelerate-logo-text-v.png?raw=true" alt="henlo, my name is Theia"/>++# containers-accelerate++[](https://github.com/tmcdonell/containers-accelerate/actions)+[](https://gitter.im/AccelerateHS/Lobby)+<br>+[](https://stackage.org/lts/package/containers-accelerate)+[](https://stackage.org/nightly/package/containers-accelerate)+[](https://hackage.haskell.org/package/containers-accelerate)++</div>++Various container types and algorithms for use with [Accelerate][accelerate].++Contributions and bug reports are welcome!<br>+Please feel free to contact me through [GitHub][accelerate] or [gitter.im][gitter.im].++ [accelerate]: https://github.com/AccelerateHS/accelerate+ [gitter.im]: https://gitter.im/AccelerateHS/Lobby+
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ containers-accelerate.cabal view
@@ -0,0 +1,69 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.33.0.+--+-- see: https://github.com/sol/hpack+--+-- hash: ae9a1d664a428489004574fb4d46c181945819f4423f2cd12d994ba7e29e41de++name: containers-accelerate+version: 0.1.0.0+synopsis: Hashing-based container types+description: Please see the README on GitHub at <https://github.com/tmcdonell/containers-accelerate#readme>+category: Accelerate, Data+homepage: https://github.com/tmcdonell/containers-accelerate#readme+bug-reports: https://github.com/tmcdonell/containers-accelerate/issues+author: Trevor L. McDonell+maintainer: Trevor L. McDonell <trevor.mcdonell@gmail.com>+license: BSD3+license-file: LICENSE+build-type: Simple+extra-source-files:+ README.md+ CHANGELOG.md++source-repository head+ type: git+ location: https://github.com/tmcdonell/containers-accelerate++library+ exposed-modules:+ Data.Array.Accelerate.Data.HashMap+ Data.Array.Accelerate.Data.HashSet+ Data.Array.Accelerate.Data.Sort.Merge+ Data.Array.Accelerate.Data.Sort.Quick+ other-modules:+ Data.Array.Accelerate.Data.Tree.Radix+ hs-source-dirs:+ src+ ghc-options: -Wall -O2+ build-depends:+ accelerate >=1.3+ , base >=4.7 && <5+ , hashable-accelerate+ default-language: Haskell2010++test-suite containers-accelerate-test+ type: exitcode-stdio-1.0+ main-is: Spec.hs+ other-modules:+ Gen+ HashMap+ Sort.Merge+ Sort.Quick+ Paths_containers_accelerate+ hs-source-dirs:+ test+ ghc-options: -Wall -O2 -threaded -rtsopts -with-rtsopts=-N+ build-depends:+ accelerate+ , accelerate-llvm-native+ , base >=4.7 && <5+ , containers+ , containers-accelerate+ , half+ , hashable-accelerate+ , hedgehog+ , tasty+ , tasty-hedgehog+ default-language: Haskell2010
+ src/Data/Array/Accelerate/Data/HashMap.hs view
@@ -0,0 +1,317 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE RebindableSyntax #-}+{-# LANGUAGE TypeApplications #-}+-- |+-- Module : Data.Array.Accelerate.Data.HashMap+-- Copyright : [2020] Trevor L. McDonell+-- License : BSD3+--+-- Maintainer : Trevor L. McDonell <trevor.mcdonell@gmail.com>+-- Stability : experimental+-- Portability : non-portable (GHC extensions)+--++module Data.Array.Accelerate.Data.HashMap (++ HashMap, Hashable,++ -- * Construction+ fromVector,++ -- * Basic interface+ size,+ member,+ lookup,+ insert, insertWith, insertWithKey,+ delete,+ adjust, adjustWithKey,++ -- * Transformations+ map,+ mapWithKey,++ -- * Conversions+ keys,+ elems,+ assocs,++) where++import Data.Array.Accelerate hiding ( size, map )+import Data.Array.Accelerate.Data.Functor+import Data.Array.Accelerate.Unsafe+import Data.Array.Accelerate.Data.Bits+import Data.Array.Accelerate.Data.Maybe+import qualified Data.Array.Accelerate as A++import Data.Array.Accelerate.Data.Hashable+import Data.Array.Accelerate.Data.Tree.Radix+import Data.Array.Accelerate.Data.Sort.Quick++import Data.Function+++-- | A map from keys to values. The map can not contain duplicate keys.+--+data HashMap k v = HashMap (Vector Node) (Vector (k,v))+ deriving (Show, Generic, Arrays)++pattern HashMap_+ :: (Elt k, Elt v)+ => Acc (Vector Node) -- tree structure+ -> Acc (Vector (k,v)) -- (key,value) pairs+ -> Acc (HashMap k v)+pattern HashMap_ t kv = Pattern (t,kv)+{-# COMPLETE HashMap_ #-}+++-- | /O(1)/ Return the number of key-value mappings+--+size :: (Elt k, Elt v) => Acc (HashMap k v) -> Exp Int+size (HashMap_ _ kv) = length kv++-- | /O(k)/ Return 'True' if the specified key is present in the map,+-- 'False' otherwise+--+member :: (Eq k, Hashable k, Elt v) => Exp k -> Acc (HashMap k v) -> Exp Bool+member k m =+ if isJust (lookup k m)+ then True_+ else False_++-- | /O(k)/ Return the value to which the specified key is mapped, or+-- 'Nothing' if the map contains no mapping for the key.+--+lookup :: (Eq k, Hashable k, Elt v) => Exp k -> Acc (HashMap k v) -> Exp (Maybe v)+lookup k hm = snd `fmap` lookupWithIndex k hm++lookupWithIndex :: (Eq k, Hashable k, Elt v) => Exp k -> Acc (HashMap k v) -> Exp (Maybe (Int, v))+lookupWithIndex key (HashMap_ tree kv) = result+ where+ h = hash key+ n = length tree+ bits = finiteBitSize (undef @Key)+ index (Ptr_ x) = clearBit x (bits - 1)+ isLeaf (Ptr_ x) = testBit x (bits - 1)++ result =+ if length kv < 2+ then if length kv == 0+ then Nothing_ -- empty map!+ else let T2 k v = kv !! 0 -- the tree structure is empty+ in k == key ? (Just_ (T2 0 v), Nothing_)+ else+ snd $ while (\(T2 i _) -> i < n) search (T2 0 Nothing_)++ search (T2 i _) =+ let Node_ d l r p = tree !! i+ d' = fromIntegral d+ in if d' < bits+ then let m = testBit h (bits - d' - 1) ? (r, l)+ j = index m+ in if isLeaf m+ then let T2 k v = kv !! j+ in T2 n (k == key ? (Just_ (T2 j v), Nothing_))+ else T2 j Nothing_+ else+ -- there was a hash collision; exhaustively search this+ -- sub-tree comparing the keys+ let T3 _ _ x = while (\(T3 j _ c) -> isNothing c && j /= p)+ exhaust+ (T3 i (-1) Nothing_)+ in T2 n x++ exhaust (T3 i prev _) =+ let Node_ _ l r p = tree !! i+ fromLeft = index l == prev+ fromRight = index r == prev+ in if fromLeft+ then -- recurse right+ let j = index r+ in if isLeaf r+ then let T2 k v = kv !! j+ in T3 i j (k == key ? (Just_ (T2 j v), Nothing_))+ else T3 j i Nothing_+ else+ if fromRight+ then -- go up to the parent+ T3 p i Nothing_+ else -- recurse left+ let j = index l+ in if isLeaf l+ then let T2 k v = kv !! j+ in T3 i j (k == key ? (Just_ (T2 j v), Nothing_))+ else T3 j i Nothing_+++-- | Insert new (key,value) pairs into the map. If the key is already+-- present in the map, the associated value is replaced with the supplied+-- value.+--+insert :: (Eq k, Hashable k, Elt v)+ => Acc (Vector (k,v))+ -> Acc (HashMap k v)+ -> Acc (HashMap k v)+insert = insertWith const++-- | Insert with a function combining the new value and old value. Each+-- pair will be inserted into the map if the key does not already exist. If+-- the key exists, the pair '(key, f new_value old_value)' will be+-- inserted.+--+insertWith+ :: (Eq k, Hashable k, Elt v)+ => (Exp v -> Exp v -> Exp v)+ -> Acc (Vector (k,v))+ -> Acc (HashMap k v)+ -> Acc (HashMap k v)+insertWith f = insertWithKey (const f)++-- | /O(n log n)/ Insert values into the map using a function to combine+-- the new value and old value. Each pair will be inserted into the map if+-- the key does not already exist. If the key exists, the pair+-- '(key, f key new_value old_value)' will be inserted.+--+insertWithKey+ :: (Eq k, Hashable k, Elt v)+ => (Exp k -> Exp v -> Exp v -> Exp v)+ -> Acc (Vector (k,v))+ -> Acc (HashMap k v)+ -> Acc (HashMap k v)+insertWithKey f kv hm@(HashMap_ tree kv0) =+ let+ -- TODO: This is very inefficient. We should update the existing+ -- association array in-place to keep that part in sorted order, and+ -- then sort and merge in the new key-value pairs before recreating+ -- the tree structure. This should be quicker than sorting the entire+ -- combined association array.+ --+ -- TODO: Handle inputs containing non-unique keys++ -- Update the values of any keys which already exist in the map+ -- in-place. This keeps the main association array in sorted order+ --+ old = if the sz == length kv -- no existing values were updated+ then kv0+ else permute const kv0 (\ix -> let i = is ! ix in i < 0 ? (Nothing_, Just_ (I1 i))) kv'+ (is, kv') = unzip+ $ A.map (\(T2 k v) -> let mu = lookupWithIndex k hm+ in if isJust mu+ then let T2 i u = fromJust mu+ in T2 i (T2 k (f k v u))+ else T2 (-1) undef) kv++ -- Any keys which were not already in the map now need to be added+ --+ T2 new sz = filter (\(T2 i _) -> i < 0)+ $ zip is kv+ in+ if the sz == 0+ then HashMap_ tree old+ else fromVector (old ++ A.map snd new) -- TODO: merge sorted subarrays & rebuild tree+++-- | Delete a key and its value from the map. When the key is not a member+-- of the map, that key is ignored+--+delete :: (Eq k, Hashable k, Elt v)+ => Acc (Vector k)+ -> Acc (HashMap k v)+ -> Acc (HashMap k v)+delete ks hm =+ let+ -- determine indices of the association array which need to be removed+ T2 is sz = justs+ $ A.map (\k -> let mu = lookupWithIndex k hm+ in if isJust mu+ then let T2 i _ = fromJust mu+ in Just_ i+ else Nothing_) ks++ -- the (key,value) pairs are still in sorted order after knocking out+ -- the deleted elements, so we can recreate the tree directly+ T2 kv' _ = justs+ . scatter is (A.map Just_ (assocs hm))+ $ fill (shape is) Nothing_+ h' = A.map (bitcast . hash . fst) kv'+ tree' = binary_radix_tree h'+ in+ if the sz == 0+ then hm+ else HashMap_ tree' kv'+++-- | Update a value at a specific key using the provided function. When the+-- key is not a member of the map, that key is ignored.+--+adjust :: (Eq k, Hashable k, Elt v)+ => (Exp v -> Exp v)+ -> Acc (Vector k)+ -> Acc (HashMap k v)+ -> Acc (HashMap k v)+adjust f = adjustWithKey (const f)++-- | Update a value at a specific key using the provided function. When the+-- key is not a member of the map, that key is ignored.+--+adjustWithKey+ :: (Eq k, Hashable k, Elt v)+ => (Exp k -> Exp v -> Exp v)+ -> Acc (Vector k)+ -> Acc (HashMap k v)+ -> Acc (HashMap k v)+adjustWithKey f ks hm@(HashMap_ tree kvs) =+ let+ (is, new) = unzip iv+ T2 iv sz = justs+ $ A.map (\k -> let mv = lookupWithIndex k hm+ in if isJust mv+ then let T2 i v = fromJust mv+ in Just_ (T2 i (T2 k (f k v)))+ else Nothing_) ks+ in+ if the sz == 0+ then hm+ else HashMap_ tree (scatter is kvs new)+++-- | /O(n)/ Transform the map by applying a function to every value+--+map :: (Elt k, Elt v1, Elt v2) => (Exp v1 -> Exp v2) -> Acc (HashMap k v1) -> Acc (HashMap k v2)+map f = mapWithKey (const f)++-- | /O(n)/ Transform this map by applying a function to every value+--+mapWithKey :: (Elt k, Elt v1, Elt v2) => (Exp k -> Exp v1 -> Exp v2) -> Acc (HashMap k v1) -> Acc (HashMap k v2)+mapWithKey f (HashMap_ t kv)+ = HashMap_ t+ $ A.map (\(T2 k v) -> T2 k (f k v)) kv++-- | /O(1)/ Return this map's keys+--+keys :: (Elt k, Elt v) => Acc (HashMap k v) -> Acc (Vector k)+keys (HashMap_ _ kv) = A.map fst kv++-- | /O(1)/ Return this map's values+--+elems :: (Elt k, Elt v) => Acc (HashMap k v) -> Acc (Vector v)+elems (HashMap_ _ kv) = A.map snd kv++-- | /O(1)/ Return this map's (key,value) pairs+--+assocs :: (Elt k, Elt v) => Acc (HashMap k v) -> Acc (Vector (k,v))+assocs (HashMap_ _ kv) = kv++-- | /O(n log n)/ Construct a map from the supplied (key,value) pairs+--+fromVector :: (Hashable k, Elt v) => Acc (Vector (k,v)) -> Acc (HashMap k v)+fromVector v = HashMap_ tree kv+ where+ tree = binary_radix_tree h+ kv = gather p v+ (h, p) = unzip+ . sortBy (compare `on` fst)+ $ imap (\(I1 i) (T2 k _) -> T2 (bitcast (hash k)) i) v+
+ src/Data/Array/Accelerate/Data/HashSet.hs view
@@ -0,0 +1,99 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE RebindableSyntax #-}+-- |+-- Module : Data.Array.Accelerate.Data.HashSet+-- Copyright : [2020] Trevor L. McDonell+-- License : BSD3+--+-- Maintainer : Trevor L. McDonell <trevor.mcdonell@gmail.com>+-- Stability : experimental+-- Portability : non-portable (GHC extensions)+--++module Data.Array.Accelerate.Data.HashSet (++ HashSet, Hashable,++ -- * Construction+ fromVector,++ -- * Basic interface+ size,+ member,+ insert,+ delete,++ -- * Conversions+ elems,+ toMap,+ fromMap,++) where++import Data.Array.Accelerate hiding ( size )+import Data.Array.Accelerate.Data.HashMap ( HashMap, Hashable )+import qualified Data.Array.Accelerate as A+import qualified Data.Array.Accelerate.Data.HashMap as M+++-- | A set of values. A set can not contain duplicate values+--+data HashSet a = HashSet (HashMap a ())+ deriving (Show, Generic, Arrays)++pattern HashSet_+ :: Elt a+ => Acc (HashMap a ())+ -> Acc (HashSet a)+pattern HashSet_ hm = Pattern hm+{-# COMPLETE HashSet_ #-}++-- | /O(1)/ Return the number of key-value mappings+--+size :: Elt a => Acc (HashSet a) -> Exp Int+size = M.size . toMap++-- | /O(k)/ Return 'True' if the specified value is present in the set,+-- 'False' otherwise+--+member :: (Eq a, Hashable a) => Exp a -> Acc (HashSet a) -> Exp Bool+member k = M.member k . toMap++-- | Add the specified value to this set+--+insert :: (Eq a, Hashable a)+ => Acc (Vector a)+ -> Acc (HashSet a)+ -> Acc (HashSet a)+insert xs = fromMap . M.insert (A.map (\x -> T2 x (constant ())) xs) . toMap++-- | Remove the specified value from the set if present+--+delete :: (Eq a, Hashable a)+ => Acc (Vector a)+ -> Acc (HashSet a)+ -> Acc (HashSet a)+delete xs = fromMap . M.delete xs . toMap++-- | /O(1)/ Return the sets elements+--+elems :: Elt a => Acc (HashSet a) -> Acc (Vector a)+elems = M.keys . toMap++-- | /O(1)/ Convert to the equivalent 'HashMap'+--+toMap :: Elt a => Acc (HashSet a) -> Acc (HashMap a ())+toMap (HashSet_ m) = m++-- | /O(1)/ Convert from the equivalent 'HashMap'+--+fromMap :: Elt a => Acc (HashMap a ()) -> Acc (HashSet a)+fromMap = HashSet_++-- | /O(n log n)/ Construct the set from the specified values+--+fromVector :: Hashable a => Acc (Vector a) -> Acc (HashSet a)+fromVector = fromMap . M.fromVector . A.map (\x -> T2 x (constant ()))+
+ src/Data/Array/Accelerate/Data/Sort/Merge.hs view
@@ -0,0 +1,137 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE RebindableSyntax #-}+{-# LANGUAGE ScopedTypeVariables #-}+-- |+-- Module : Data.Array.Accelerate.Data.Sort.Merge+-- Copyright : [2020] Ivo Gabe de Wolff, Trevor L. McDonell+-- License : BSD3+--+-- Maintainer : Trevor L. McDonell <trevor.mcdonell@gmail.com>+-- Stability : experimental+-- Portability : non-portable (GHC extensions)+--++module Data.Array.Accelerate.Data.Sort.Merge (++ sort,+ sortBy,++) where++import Data.Array.Accelerate+import Data.Array.Accelerate.Unsafe+++-- | A stable merge sort. This is a special case of 'sortBy' which allows+-- the user to supply their own comparison function.+--+sort :: Ord a => Acc (Vector a) -> Acc (Vector a)+sort = sortBy compare++-- | A non-overloaded version of 'sort'+--+-- It is often convenient to use this together with 'Data.Function.on', for+-- instance: 'sortBy' ('compare' `on` 'fst').+--+sortBy :: Elt a => (Exp a -> Exp a -> Exp Ordering) -> Acc (Vector a) -> Acc (Vector a)+sortBy cmp input = output+ where+ n = length input+ T2 _ output = awhile condition step+ (T2 (unit insertion_segment_size) (insertion_sort cmp n input))++ condition (T2 blockSize _) = map (< length input) blockSize+ step (T2 blockSize' values) = T2 (unit $ blockSize * 2) values'+ where+ blockSize = the blockSize'+ newIndices = imap (newIndex values cmp n blockSize) values+ values' = scatter newIndices (fill (index1 n) undef) values+++insertion_segment_size :: Exp Int+insertion_segment_size = 32++insertion_sort+ :: Elt a+ => (Exp a -> Exp a -> Exp Ordering)+ -> Exp Int+ -> Acc (Vector a)+ -> Acc (Vector a)+insertion_sort cmp n xs = scatter indices (fill (I1 n) undef) xs+ where+ indices = imap f xs+ f (I1 ix) x = segment_start + offset+ where+ segment = ix `quot` insertion_segment_size+ segment_start = segment * insertion_segment_size+ segment_end = ((segment + 1) * insertion_segment_size) `min` n+ T2 _ offset = while+ (\(T2 i _) -> i < segment_end)+ (\(T2 i c) ->+ let x' = xs !! i+ smaller = let d = cmp x' x+ in d == LT_ || d == EQ_ && i > ix+ in+ T2 (i + 1) (c + (smaller ? (1, 0))))+ (T2 segment_start 0)++newIndex+ :: Elt a+ => Acc (Vector a)+ -> (Exp a -> Exp a -> Exp Ordering)+ -> Exp Int+ -> Exp Int+ -> Exp DIM1+ -> Exp a+ -> Exp Int+newIndex values cmp valueCount blockSize (I1 index) value = index + offset+ where+ blockIndex = index `quot` blockSize+ left = even blockIndex+ otherBlockIndex = blockIndex + (left ? (1, -1))++ searchMinIndex = otherBlockIndex * blockSize+ searchMaxIndex = min valueCount $ (otherBlockIndex + 1) * blockSize++ countOtherBlock = binarySearch values cmp value (not left) searchMinIndex searchMaxIndex++ -- We should base the indices of the right block also on the left+ -- block, hence we must subtract blockSize+ --+ offset = countOtherBlock - (left ? (0, blockSize))++-- Returns the number of elements a_i such that+-- * (a_i <= query) if inclusive is True; or+-- * (a_i < query) otherwise+-- where initialMinIndex <= i < initialMaxIndex.+--+-- The corresponding section of the input vector must be sorted.+--+binarySearch+ :: Elt a+ => Acc (Vector a)+ -> (Exp a -> Exp a -> Exp Ordering)+ -> Exp a+ -> Exp Bool+ -> Exp Int+ -> Exp Int+ -> Exp Int+binarySearch values cmp query inclusive initialMinIndex initialMaxIndex =+ index - initialMinIndex+ where+ -- The invariant of the loop is a_i `compare` query && not (a_j `compare` query)+ -- where a_initialMaxIndex is treated as infinity and+ -- a_{initialMinIndex - 1} as minus infinity+ --+ T2 _ index = while+ (\(T2 i j) -> i + 1 < j)+ (\(T2 i j) ->+ let m = (i + j) `quot` 2+ a_m = values !! m+ det = let c = a_m `cmp` query+ in c == LT_ || c == EQ_ && inclusive+ in+ det ? (T2 m j, T2 i m))+ (T2 (initialMinIndex - 1) initialMaxIndex)+
+ src/Data/Array/Accelerate/Data/Sort/Quick.hs view
@@ -0,0 +1,182 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE RebindableSyntax #-}+{-# LANGUAGE ScopedTypeVariables #-}+-- |+-- Module : Data.Array.Accelerate.Data.Sort.Quick+-- Copyright : [2020] Ivo Gabe de Wolff, Trevor L. McDonell+-- License : BSD3+--+-- Maintainer : Trevor L. McDonell <trevor.mcdonell@gmail.com>+-- Stability : experimental+-- Portability : non-portable (GHC extensions)+--++module Data.Array.Accelerate.Data.Sort.Quick (++ sort,+ sortBy,++) where++import Data.Array.Accelerate+import Data.Array.Accelerate.Unsafe+import Data.Array.Accelerate.Data.Bits+import Data.Array.Accelerate.Data.Maybe+++-- | A quick-ish stable sort. This is a special case of 'sortBy' which+-- allows the user to supply their own comparison function.+--+sort :: Ord a => Acc (Vector a) -> Acc (Vector a)+sort = sortBy compare++-- | A non-overloaded version of 'sort'.+--+-- It is often convenient to use this together with 'Data.Function.on', for+-- instance: 'sortBy' ('compare' `on` 'fst')+--+sortBy :: Elt a => (Exp a -> Exp a -> Exp Ordering) -> Acc (Vector a) -> Acc (Vector a)+sortBy cmp input = result+ where+ -- Initially, we have one segment, namely the whole array+ initialFlags = scatter (fill (I1 1) 0 ++ fill (I1 1) (length input)) emptyFlags fullFlags+ emptyFlags = fill (I1 (1 + length input)) False_+ fullFlags = fill (I1 2) True_++ -- We stop when each segment contains just one element, as segments of+ -- one element are sorted.+ T2 result _ = awhile condition (step cmp) $ T2 input initialFlags++type State a =+ ( Vector a -- Values+ , Vector Bool -- Head flags, denoting the starting points of the unsorted segments+ )++step :: Elt a => (Exp a -> Exp a -> Exp Ordering) -> Acc (State a) -> Acc (State a)+step cmp (T2 values headFlags) = (T2 values' headFlags')+ where+ -- Per element, the pivot of the segment of that element+ -- For each segment, we just take the first element as pivot+ pivots = propagateSegmentHead headFlags values++ -- Find which elements are larger than the pivot+ isLarger = zipWith (\v p -> cmp v p /= LT_) values pivots++ -- Propagate the start index of a segment to all elements+ startIndex = propagateSegmentHead headFlags (generate (shape values) unindex1)++ -- Compute the offsets to which the elements must be moved using a scan+ indicesLarger, indicesSmaller :: Acc (Vector Int)+ indicesLarger = map (\x -> x - 1) $ postscanSegHead (+) headFlags $ map (? (1, 0)) isLarger+ indicesSmaller = map (\x -> x - 1) $ postscanSegHead (+) headFlags $ map (? (0, 1)) isLarger++ -- Propagate the number of smaller elements to each segment+ -- This is needed as an offset for the larger elements+ countSmaller :: Acc (Vector Int)+ countSmaller = map (+1) $ propagateSegmentLast headFlags indicesSmaller++ -- Compute the new indices of the elements+ permutation = zipWith5 partitionPermuteIndex isLarger startIndex indicesSmaller indicesLarger countSmaller++ -- Perform the permutation+ values' = scatter permutation (fill (shape values) undef) values++ -- Update the head flags for the next iteration (the 'recursive call'+ -- in a traditional implementation)+ --+ -- Mark new section starts at:+ -- * the position of the pivot+ -- * the position of the pivot + 1+ headFlags' =+ let+ f :: Int -> Exp Bool -> Exp Int -> Exp Int -> Exp (Maybe DIM1)+ f inc headF start countSmall =+ if headF+ then Just_ (I1 (start + countSmall + constant inc))+ else Nothing_++ writes :: Int -> Acc (Vector (Maybe DIM1))+ writes inc = zipWith3 (f inc) headFlags startIndex countSmaller+ in+ -- Note that (writes 1) may go out of bounds of the values array.+ -- We made the headFlags array one larger to avoid this problem.+ writeFlags (writes 0) $ writeFlags (writes 1) $ headFlags++-- Checks whether all segments have length 1. If that is the case, then the+-- loop may terminate.+--+condition :: Elt a => Acc (State a) -> Acc (Scalar Bool)+condition (T2 _ headFlags) = map not $ fold (&&) True_ headFlags++-- Finds the new index of an element of the list, as the result of the+-- partition+--+partitionPermuteIndex :: Exp Bool -> Exp Int -> Exp Int -> Exp Int -> Exp Int -> Exp Int+partitionPermuteIndex isLarger start indexIfSmaller indexIfLarger countSmaller =+ start + (isLarger ? (countSmaller + indexIfLarger, indexIfSmaller))++-- Given head flags, propagates the value of the head to all elements in+-- the segment+--+propagateSegmentHead+ :: Elt a+ => Acc (Vector Bool)+ -> Acc (Vector a)+ -> Acc (Vector a)+propagateSegmentHead headFlags values+ = map fst+ $ postscanl f (T2 undef True_)+ $ zip values headFlags+ where+ f left (T2 rightValue rightFlag) =+ if rightFlag+ then T2 rightValue True_+ else left++-- Given head flags, propagates the value of the head to all elements in+-- the segment+--+propagateSegmentLast+ :: Elt a+ => Acc (Vector Bool)+ -> Acc (Vector a)+ -> Acc (Vector a)+propagateSegmentLast headFlags values+ = map fst+ $ postscanr f (T2 undef True_)+ $ zip values+ $ tail headFlags+ where+ f (T2 leftValue leftFlag) right =+ if leftFlag+ then T2 leftValue True_+ else right++-- Segmented postscan, where the segments are defined with head flags+--+postscanSegHead+ :: Elt a+ => (Exp a -> Exp a -> Exp a)+ -> Acc (Vector Bool)+ -> Acc (Vector a)+ -> Acc (Vector a)+postscanSegHead f headFlags values+ = map fst+ $ postscanl g (T2 undef True_)+ $ zip values headFlags+ where+ g (T2 leftValue leftFlag) (T2 rightValue rightFlag)+ = T2+ (rightFlag ? (rightValue, f leftValue rightValue))+ (leftFlag .|. rightFlag)++-- Writes True to the specified indices in a flags arrays+--+writeFlags+ :: Acc (Vector (Maybe DIM1))+ -> Acc (Vector Bool)+ -> Acc (Vector Bool)+writeFlags writes flags =+ permute const flags (writes !) (fill (shape writes) True_)+
+ src/Data/Array/Accelerate/Data/Tree/Radix.hs view
@@ -0,0 +1,146 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE RebindableSyntax #-}+{-# LANGUAGE TypeApplications #-}+-- |+-- Module : Data.Array.Accelerate.Data.Tree.Radix+-- Copyright : [2020] Trevor L. McDonell+-- License : BSD3+--+-- Maintainer : Trevor L. McDonell <trevor.mcdonell@gmail.com>+-- Stability : experimental+-- Portability : non-portable (GHC extensions)+--+-- Radix tree (Patricia tree) construction, based on the paper "Maximising+-- Parallelism in Construction of BVHs, Octrees, and k-d Trees", Tero+-- Karras, in High Performance Graphics (2012).+--++module Data.Array.Accelerate.Data.Tree.Radix+ where++import Data.Array.Accelerate+import Data.Array.Accelerate.Unsafe+import Data.Array.Accelerate.Data.Bits+import Data.Array.Accelerate.Data.Maybe++import qualified Data.Bits as P+import qualified Prelude as P+++data Node = Node !Word8 -- descriminator bit+ !Ptr -- left pointer+ !Ptr -- right pointer+ !Int -- parent node index+ deriving (Show, Generic, Elt)++pattern Node_ :: Exp Word8 -> Exp Ptr -> Exp Ptr -> Exp Int -> Exp Node+pattern Node_ b l r p = Pattern (b, l, r, p)+{-# COMPLETE Node_ #-}++-- If the MSB is set, then this is a leaf pointer. This is fine because who+-- uses signed integers for array indices anyway?? ¯\_(ツ)_/¯+--+newtype Ptr = Ptr Int+ deriving (Generic, Elt)++instance Show Ptr where+ showsPrec d (Ptr x)+ = P.showParen (d P.> 10)+ $ case P.testBit x (P.finiteBitSize (undefined :: Key) - 1) of+ True -> P.showString "Leaf " . P.showsPrec 11 (P.clearBit x (P.finiteBitSize (undefined :: Key) - 1))+ False -> P.showString "Inner " . P.showsPrec 11 x++pattern Ptr_ :: Exp Int -> Exp Ptr+pattern Ptr_ x = Pattern x+{-# COMPLETE Ptr_ #-}++type Key = Word++-- Construct the binary radix tree from the vector of keys. The keys must+-- be sorted.+--+binary_radix_tree :: Acc (Vector Key) -> Acc (Vector Node)+binary_radix_tree keys = zipWith4 Node_ deltas lefts rights parents+ where+ n = length keys+ bits = finiteBitSize (undef @Key)++ delta i j =+ if j >= 0 && j < n+ then+ let li = keys !! i+ lj = keys !! j+ -- handle duplicates using the index as a tiebreaker if+ -- necessary+ in if li == lj+ then bits + countLeadingZeros (i `xor` j)+ else countLeadingZeros (li `xor` lj)+ else -1++ node i =+ let -- determine direction of the range+ d = signum $ delta i (i+1) - delta i (i-1)++ -- compute upper bound for the length of the range+ delta_min = delta i (i-d)+ l_max = while (\l_max' -> delta i (i+l_max'*d) > delta_min)+ (*4) -- (*2)+ 128 -- 2++ -- find the other end using binary search+ T2 l _ = while (\(T2 _ t) -> t > 0)+ (\(T2 l' t) ->+ let t2 = t `quot` 2 in+ if delta i (i+(l'+t) * d) > delta_min+ then T2 (l' + t) t2+ else T2 l' t2)+ (T2 0 (l_max `quot` 2))+ j = i + l*d++ -- find the split position using binary search+ delta_node = delta i j+ T2 s _ = while (\(T2 _ q) -> q <= l)+ (\(T2 s' q) ->+ let r = q*2+ t = (l + r - 1) `quot` r+ in if delta i (i+(s'+t)*d) > delta_node+ then T2 (s'+t) r+ else T2 s' r)+ (T2 0 1)+ gamma = i + s*d + min d 0++ -- output child pointers+ T2 left left_parent =+ if min i j == gamma+ then T2 (leaf gamma) (-1)+ else T2 (inner gamma) gamma++ T2 right right_parent =+ if max i j == gamma + 1+ then T2 (leaf (gamma+1)) (-1)+ else T2 (inner (gamma+1)) (gamma+1)++ leaf x = Ptr_ (setBit x (bits-1))+ inner x = Ptr_ x+ in+ T5 (fromIntegral delta_node :: Exp Word8)+ left+ right+ left_parent+ right_parent++ (deltas, lefts, rights, left_parents, right_parents)+ = unzip5+ $ generate (I1 (n-1)) (node . unindex1)++ parents+ = let from = generate (I1 ((n-1)*2)) (\(I1 i) -> i < n-1 ? (i, i-n+1))+ dest = left_parents ++ right_parents+ in permute const+ (fill (I1 (n-1)) undef)+ (\ix -> let d = dest ! ix in+ if d < 0 then Nothing_ else Just_ (I1 d))+ from+
+ test/Gen.hs view
@@ -0,0 +1,125 @@+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeOperators #-}++module Gen where++import Data.Array.Accelerate ( Acc, Arrays, Array, Shape, Elt, DIM0, DIM1, DIM2, DIM3, Z(..), (:.)(..), fromList )+import Data.Array.Accelerate.Trafo ( Afunction )+import Data.Array.Accelerate.Trafo.Sharing ( AfunctionR )+import Data.Array.Accelerate.Sugar.Shape ( size )++import Data.Int+import Data.Word+import Control.Monad+import Numeric.Half+import Hedgehog+import qualified Hedgehog.Gen as G+import qualified Hedgehog.Range as R+++type Run = forall a. Arrays a => Acc a -> a+type RunN = forall f. Afunction f => f -> AfunctionR f++dim0 :: Gen DIM0+dim0 = return Z++dim1 :: Gen DIM1+dim1 = (Z :.) <$> G.int (R.linear 0 1024)++dim2 :: Gen DIM2+dim2 = do+ x <- G.int (R.linear 0 128)+ y <- G.int (R.linear 0 48)+ return (Z :. y :. x)++dim3 :: Gen DIM3+dim3 = do+ x <- G.int (R.linear 0 64)+ y <- G.int (R.linear 0 32)+ z <- G.int (R.linear 0 16)+ return (Z :. z :. y :. x)++array :: (Shape sh, Elt e) => sh -> Gen e -> Gen (Array sh e)+array sh gen = fromList sh <$> G.list (R.singleton (size sh)) gen++int :: Gen Int+int = G.int R.linearBounded++i8 :: Gen Int8+i8 = G.int8 R.linearBounded++i16 :: Gen Int16+i16 = G.int16 R.linearBounded++i32 :: Gen Int32+i32 = G.int32 R.linearBounded++i64 :: Gen Int64+i64 = G.int64 R.linearBounded++word :: Gen Word+word = G.word R.linearBounded++w8 :: Gen Word8+w8 = G.word8 R.linearBounded++w16 :: Gen Word16+w16 = G.word16 R.linearBounded++w32 :: Gen Word32+w32 = G.word32 R.linearBounded++w64 :: Gen Word64+w64 = G.word64 R.linearBounded++f16 :: Gen Half+f16 = G.realFloat (R.linearFracFrom 0 (-log_flt_max) log_flt_max)++f32 :: Gen Float+f32 = G.float (R.linearFracFrom 0 (-log_flt_max) log_flt_max)++f64 :: Gen Double+f64 = G.double (R.linearFracFrom 0 (-log_flt_max) log_flt_max)++-- v2 :: Prim a => Gen a -> Gen (V2 a)+-- v2 a = V2 <$> a <*> a++-- v3 :: Prim a => Gen a -> Gen (V3 a)+-- v3 a = V3 <$> a <*> a <*> a++-- v4 :: Prim a => Gen a -> Gen (V4 a)+-- v4 a = V4 <$> a <*> a <*> a <*> a++-- v8 :: Prim a => Gen a -> Gen (V8 a)+-- v8 a = V8 <$> a <*> a <*> a <*> a <*> a <*> a <*> a <*> a++-- v16 :: Prim a => Gen a -> Gen (V16 a)+-- v16 a = V16 <$> a <*> a <*> a <*> a <*> a <*> a <*> a <*> a+-- <*> a <*> a <*> a <*> a <*> a <*> a <*> a <*> a++log_flt_max :: RealFloat a => a+log_flt_max = log flt_max++flt_max :: RealFloat a => a+flt_max = x+ where+ n = floatDigits x+ b = floatRadix x+ (_,u) = floatRange x+ x = encodeFloat (b^n - 1) (u - n)++flt_min :: RealFloat a => a+flt_min = x+ where+ n = floatDigits x+ b = floatRadix x+ (l,_) = floatRange x+ x = encodeFloat (b^n - 1) (l - n - 1)++except :: Gen e -> (e -> Bool) -> Gen e+except gen f = do+ v <- gen+ when (f v) G.discard+ return v+
+ test/HashMap.hs view
@@ -0,0 +1,160 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}++module HashMap where++import Gen++import Data.Array.Accelerate as A+import Data.Array.Accelerate.Data.Bits as A+import Data.Array.Accelerate.Data.Hashable as A+import Data.Array.Accelerate.Data.HashMap as HashMap++import Data.Typeable+import Data.Function+import Data.List as P+import Prelude as P+import Data.Map.Strict ( Map )+import qualified Data.Map.Strict as Map++import Hedgehog+import qualified Hedgehog.Gen as G+import qualified Hedgehog.Range as R++import Test.Tasty+import Test.Tasty.Hedgehog+++test_hashmap :: RunN -> TestTree+test_hashmap runN =+ testGroup "hashmap"+ [ testElt int+ -- , testElt i8+ -- , testElt i16+ -- , testElt i32+ -- , testElt i64+ , testElt word+ -- , testElt w8+ -- , testElt w16+ -- , testElt w32+ -- , testElt w64+ , testElt f32+ , testElt f64+ ]+ where+ testElt :: forall e. (Show e, Typeable e, P.Ord e, A.Hashable e, A.Eq e)+ => Gen e+ -> TestTree+ testElt e =+ testGroup (show (typeOf (undefined :: e)))+ [ testProperty "lookup" $ test_lookup runN e int+ , testProperty "lookup-with-collision" $ test_lookup runN (collides e) int+ , testProperty "insert" $ test_insert runN e int+ , testProperty "delete" $ test_delete runN e int+ ]+++_MAX_SIZE :: Int+_MAX_SIZE = 1024++test_lookup+ :: (Show k, Show v, P.Ord k, P.Eq v, A.Hashable k, A.Eq k, A.Eq v)+ => RunN+ -> Gen k+ -> Gen v+ -> Property+test_lookup runN k v =+ property $ do+ m <- forAll $ G.map (R.linear 0 _MAX_SIZE) ((,) <$> k <*> v)+ let n = Map.size m+ t1 <- if Map.null m+ then return []+ else forAll $ G.list (R.linear 0 n) (G.element (Map.keys m))+ t2 <- forAll $ G.list (R.linear 0 n) k+ t <- forAll $ G.shuffle (t1 P.++ t2)+ let !go = runN $ \hm -> A.map (`HashMap.lookup` HashMap.fromVector hm)+ --+ A.toList (go (fromMap m) (A.fromList (Z :. P.length t) t)) === P.map (`Map.lookup` m) t+++test_insert+ :: (Show k, Show v, P.Ord k, P.Eq v, A.Hashable k, A.Eq k, A.Eq v)+ => RunN+ -> Gen k+ -> Gen v+ -> Property+test_insert runN = test_insertWith runN const const++test_insertWith+ :: (Show k, Show v, P.Ord k, P.Eq v, A.Hashable k, A.Eq k, A.Eq v)+ => RunN+ -> (Exp v -> Exp v -> Exp v)+ -> (v -> v -> v)+ -> Gen k+ -> Gen v+ -> Property+test_insertWith runN f g = test_insertWithKey runN (const f) (const g)++test_insertWithKey+ :: (Show k, Show v, P.Ord k, P.Eq v, A.Hashable k, A.Eq k, A.Eq v)+ => RunN+ -> (Exp k -> Exp v -> Exp v -> Exp v)+ -> (k -> v -> v -> v)+ -> Gen k+ -> Gen v+ -> Property+test_insertWithKey runN f g k v =+ property $ do+ m <- forAll $ G.map (R.linear 0 _MAX_SIZE) ((,) <$> k <*> v)+ n <- forAll $ G.map (R.linear 0 _MAX_SIZE) ((,) <$> k <*> v)+ let !go = runN (\hm kv -> HashMap.assocs $ HashMap.insertWithKey f kv (HashMap.fromVector hm))+ --+ P.sortBy (P.compare `on` P.fst) (A.toList (go (fromMap m) (fromMap n))) ===+ Map.toAscList (P.foldr (\(k',v') m' -> Map.insertWithKey g k' v' m') m (Map.toList n))+++test_delete+ :: (Show k, Show v, P.Ord k, P.Eq v, A.Hashable k, A.Eq k, A.Eq v)+ => RunN+ -> Gen k+ -> Gen v+ -> Property+test_delete runN k v =+ property $ do+ m <- forAll $ G.map (R.linear 0 _MAX_SIZE) ((,) <$> k <*> v)+ n <- forAll $ G.list (R.linear 0 _MAX_SIZE) k+ let !go = runN (\hm ks -> HashMap.assocs $ HashMap.delete ks (HashMap.fromVector hm))+ --+ P.sortBy (P.compare `on` P.fst) (A.toList (go (fromMap m) (fromList (Z :. P.length n) n))) ===+ Map.toAscList (P.foldr Map.delete m n)+++fromMap :: (Elt k, Elt v) => Map k v -> Vector (k,v)+fromMap m =+ let n = Map.size m+ in fromList (Z :. n) (Map.toList m)++collides :: Gen a -> Gen (Collides a)+collides g = Collides <$> g++newtype Collides a = Collides a+ deriving (Show, P.Eq, P.Ord, Generic, Elt)++pattern Collides_ :: Elt a => Exp a -> Exp (Collides a)+pattern Collides_ x = Pattern x+{-# COMPLETE Collides_ #-}++instance Hashable a => Hashable (Collides a) where+ hash (Collides_ x) = 0xffff .&. hash x+ hashWithSalt = defaultHashWithSalt++instance A.Eq a => A.Eq (Collides a) where+ Collides_ x == Collides_ y = x A.== y+ Collides_ x /= Collides_ y = x A./= y+
+ test/Sort/Merge.hs view
@@ -0,0 +1,88 @@+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}++module Sort.Merge where++import Gen++import Data.Array.Accelerate as A+import Data.Array.Accelerate.Data.Sort.Merge as A++import Data.Typeable+import Data.Function+import Data.List as P+import Prelude as P++import Hedgehog++import Test.Tasty+import Test.Tasty.Hedgehog+++test_mergesort :: RunN -> TestTree+test_mergesort runN =+ testGroup "mergesort"+ [ testElt int+ -- , testElt i8+ -- , testElt i16+ -- , testElt i32+ -- , testElt i64+ , testElt word+ -- , testElt w8+ -- , testElt w16+ -- , testElt w32+ -- , testElt w64+ , testElt f32+ , testElt f64+ ]+ where+ testElt :: forall e. (Show e, Typeable e, P.Ord e, A.Ord e)+ => Gen e+ -> TestTree+ testElt e =+ testGroup (show (typeOf (undefined :: e)))+ [ testProperty "ascending" $ test_sort_ascending runN e+ , testProperty "descending" $ test_sort_descending runN e+ , testProperty "key-value" $ test_sort_keyval runN e f64+ ]++test_sort_ascending+ :: (Show e, P.Ord e, A.Ord e)+ => RunN+ -> Gen e+ -> Property+test_sort_ascending runN e =+ property $ do+ sh <- forAll dim1+ xs <- forAll (array sh e)+ let !go = runN A.sort in go xs === sortRef P.compare xs++test_sort_descending+ :: (Show e, P.Ord e, A.Ord e)+ => RunN+ -> Gen e+ -> Property+test_sort_descending runN e =+ property $ do+ sh <- forAll dim1+ xs <- forAll (array sh e)+ let !go = runN (A.sortBy (flip A.compare)) in go xs === sortRef (flip P.compare) xs++test_sort_keyval+ :: (Show k, Show v, P.Ord k, P.Eq v, A.Ord k, A.Eq v)+ => RunN+ -> Gen k+ -> Gen v+ -> Property+test_sort_keyval runN k v =+ property $ do+ sh <- forAll dim1+ xs <- forAll (array sh ((,) <$> k <*> v))+ let !go = runN (A.sortBy (A.compare `on` A.fst)) in go xs === sortRef (P.compare `on` P.fst) xs++sortRef :: Elt a => (a -> a -> Ordering) -> Vector a -> Vector a+sortRef cmp xs = fromList (arrayShape xs) (P.sortBy cmp (toList xs))+
+ test/Sort/Quick.hs view
@@ -0,0 +1,88 @@+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}++module Sort.Quick where++import Gen++import Data.Array.Accelerate as A+import Data.Array.Accelerate.Data.Sort.Quick as A++import Data.Typeable+import Data.Function+import Data.List as P+import Prelude as P++import Hedgehog++import Test.Tasty+import Test.Tasty.Hedgehog+++test_quicksort :: RunN -> TestTree+test_quicksort runN =+ testGroup "quicksort"+ [ testElt int+ -- , testElt i8+ -- , testElt i16+ -- , testElt i32+ -- , testElt i64+ , testElt word+ -- , testElt w8+ -- , testElt w16+ -- , testElt w32+ -- , testElt w64+ , testElt f32+ , testElt f64+ ]+ where+ testElt :: forall e. (Show e, Typeable e, P.Ord e, A.Ord e)+ => Gen e+ -> TestTree+ testElt e =+ testGroup (show (typeOf (undefined :: e)))+ [ testProperty "ascending" $ test_sort_ascending runN e+ , testProperty "descending" $ test_sort_descending runN e+ , testProperty "key-value" $ test_sort_keyval runN e f64+ ]++test_sort_ascending+ :: (Show e, P.Ord e, A.Ord e)+ => RunN+ -> Gen e+ -> Property+test_sort_ascending runN e =+ property $ do+ sh <- forAll dim1+ xs <- forAll (array sh e)+ let !go = runN A.sort in go xs === sortRef P.compare xs++test_sort_descending+ :: (Show e, P.Ord e, A.Ord e)+ => RunN+ -> Gen e+ -> Property+test_sort_descending runN e =+ property $ do+ sh <- forAll dim1+ xs <- forAll (array sh e)+ let !go = runN (A.sortBy (flip A.compare)) in go xs === sortRef (flip P.compare) xs++test_sort_keyval+ :: (Show k, Show v, P.Ord k, P.Eq v, A.Ord k, A.Eq v)+ => RunN+ -> Gen k+ -> Gen v+ -> Property+test_sort_keyval runN k v =+ property $ do+ sh <- forAll dim1+ xs <- forAll (array sh ((,) <$> k <*> v))+ let !go = runN (A.sortBy (A.compare `on` A.fst)) in go xs === sortRef (P.compare `on` P.fst) xs++sortRef :: Elt a => (a -> a -> Ordering) -> Vector a -> Vector a+sortRef cmp xs = fromList (arrayShape xs) (P.sortBy cmp (toList xs))+
+ test/Spec.hs view
@@ -0,0 +1,21 @@++module Main where++import HashMap+import Sort.Merge+import Sort.Quick++-- import Data.Array.Accelerate.Interpreter+import Data.Array.Accelerate.LLVM.Native++import Test.Tasty++main :: IO ()+main =+ defaultMain $+ testGroup "containers-accelerate"+ [ test_quicksort runN+ -- , test_mergesort runN+ , test_hashmap runN+ ]+