diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -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 + diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,22 @@ +
+henlo, my name is Theia + +# containers-accelerate + +[![GitHub CI](https://github.com/tmcdonell/containers-accelerate/workflows/CI/badge.svg)](https://github.com/tmcdonell/containers-accelerate/actions) +[![Gitter](https://img.shields.io/gitter/room/nwjs/nw.js.svg)](https://gitter.im/AccelerateHS/Lobby) +
+[![Stackage LTS](https://stackage.org/package/containers-accelerate/badge/lts)](https://stackage.org/lts/package/containers-accelerate) +[![Stackage Nightly](https://stackage.org/package/containers-accelerate/badge/nightly)](https://stackage.org/nightly/package/containers-accelerate) +[![Hackage](https://img.shields.io/hackage/v/containers-accelerate.svg)](https://hackage.haskell.org/package/containers-accelerate) + +
+ +Various container types and algorithms for use with [Accelerate][accelerate]. + +Contributions and bug reports are welcome!
+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 + diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/containers-accelerate.cabal b/containers-accelerate.cabal new file mode 100644 --- /dev/null +++ b/containers-accelerate.cabal @@ -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 +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 +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 diff --git a/src/Data/Array/Accelerate/Data/HashMap.hs b/src/Data/Array/Accelerate/Data/HashMap.hs new file mode 100644 --- /dev/null +++ b/src/Data/Array/Accelerate/Data/HashMap.hs @@ -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 +-- 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 + diff --git a/src/Data/Array/Accelerate/Data/HashSet.hs b/src/Data/Array/Accelerate/Data/HashSet.hs new file mode 100644 --- /dev/null +++ b/src/Data/Array/Accelerate/Data/HashSet.hs @@ -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 +-- 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 ())) + diff --git a/src/Data/Array/Accelerate/Data/Sort/Merge.hs b/src/Data/Array/Accelerate/Data/Sort/Merge.hs new file mode 100644 --- /dev/null +++ b/src/Data/Array/Accelerate/Data/Sort/Merge.hs @@ -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 +-- 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) + diff --git a/src/Data/Array/Accelerate/Data/Sort/Quick.hs b/src/Data/Array/Accelerate/Data/Sort/Quick.hs new file mode 100644 --- /dev/null +++ b/src/Data/Array/Accelerate/Data/Sort/Quick.hs @@ -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 +-- 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_) + diff --git a/src/Data/Array/Accelerate/Data/Tree/Radix.hs b/src/Data/Array/Accelerate/Data/Tree/Radix.hs new file mode 100644 --- /dev/null +++ b/src/Data/Array/Accelerate/Data/Tree/Radix.hs @@ -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 +-- 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 + diff --git a/test/Gen.hs b/test/Gen.hs new file mode 100644 --- /dev/null +++ b/test/Gen.hs @@ -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 + diff --git a/test/HashMap.hs b/test/HashMap.hs new file mode 100644 --- /dev/null +++ b/test/HashMap.hs @@ -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 + diff --git a/test/Sort/Merge.hs b/test/Sort/Merge.hs new file mode 100644 --- /dev/null +++ b/test/Sort/Merge.hs @@ -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)) + diff --git a/test/Sort/Quick.hs b/test/Sort/Quick.hs new file mode 100644 --- /dev/null +++ b/test/Sort/Quick.hs @@ -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)) + diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -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 + ] +