{-# LANGUAGE TypeOperators, PatternGuards, RankNTypes, ScopedTypeVariables, BangPatterns, FlexibleContexts #-}
{-# OPTIONS -fno-warn-incomplete-patterns #-}
import Data.Array.Repa.Algorithms.Complex
import Data.Array.Repa as R
import Data.Array.Repa.Eval as R
import Data.Array.Repa.Unsafe as R
import Prelude as P
import Data.Bits
import Data.List as List
import Criterion.Main
import System.Random
import Control.Parallel.Strategies
import Control.Parallel
import Control.DeepSeq
{--
GHC flags
-Odph -rtsopts -threaded -fno-liberate-case -funfolding-use-threshold1000
-funfolding-keeness-factor1000 -fllvm -optlo-O3
or if you don't have llvm
-Odph -rtsopts -threaded -fno-liberate-case -funfolding-use-threshold1000 -funfolding-keeness-factor1000 -optlo-O3
--}
-- bit manipulations
flipLSBsTo :: (Num a, Bits a) => Int -> a -> a
flipLSBsTo i = (`xor` (oneBits (i+1)))
oneBits :: (Num a, Bits a) => Int -> a
oneBits i = bit i - 1
-- assume input array has length a power of 2 for this and similar functions
-- using arrays of Int to keep types shorter
vee :: (Shape sh, Monad m) => (Int -> Int -> Int) -> (Int -> Int -> Int)
-> Int -> Array U (sh :. Int) Int -> m (Array U (sh :. Int) Int)
vee f g s arr = let sh = extent arr in computeUnboxedP $ fromFunction sh ixf
where
ixf (sh :. ix) = if (testBit ix s) then (g a b) else (f a b)
where
a = arr ! (sh :. ix)
b = arr ! (sh :. newix)
newix = flipLSBsTo s ix
dee :: (Shape sh, Monad m) => (Int -> Int -> Int) -> (Int -> Int -> Int)
-> Int -> Array U (sh :. Int) Int -> m (Array U (sh :. Int) Int)
dee f g s arr = let sh = extent arr in computeUnboxedP $ fromFunction sh ixf
where
ixf (sh :. i) = if (testBit i s) then (g a b) else (f a b)
where
a = arr ! (sh :. i)
b = arr ! (sh :. (i `xor` s2))
s2 = (1::Int) `shiftL` s
-- assume input array has length a power of 2^(n+k), n > 0, k>=0
-- performs bitonic merge on sub-parts of length 2^n
bitonicMerge
:: (Monad m, Shape sh) =>
Int -> Array U (sh :. Int) Int -> m (Array U (sh :. Int) Int)
bitonicMerge n = compose [dee max min (n-i) | i <- [1..n]]
tmerge
:: (Monad m, Shape sh) =>
Int -> Array U (sh :. Int) Int -> m (Array U (sh :. Int) Int)
tmerge n = compose $ vee min max (n-1) : [dee min max (n-i) | i <- [2..n]]
tsort
:: (Monad m, Shape sh) =>
Int -> Array U (sh :. Int) Int -> m (Array U (sh :. Int) Int)
tsort n = compose [tmerge i | i <- [1..n]]
compose :: Monad m => [a -> m a] -> a -> m a
compose [] arr = return arr
compose (f:fs) arr
= do
arr1 <- f arr
compose fs arr1
-- Anders Persson's quicksort
qsortkpd :: Int -> [Int] -> [Int]
qsortkpd limit xs = go limit xs
where
go _ [] = []
go _ [x] = [x]
go _ [x,y] = if x > y then [y,x] else [x,y]
go 0 xs = qsort3 xs
go d (p:xs) = rnf g `par` e `par` l `pseq` (l P.++ e P.++ g)
where
l = go (d-1) lesser
e = equal
g = go (d-1) greater
(lesser, equal, greater) = List.foldl' part ([], [p], []) xs
part (!l, !e, !g) x =
case compare x p of
LT -> (x:l, e, g)
GT -> ( l, e, x:g)
EQ -> ( l, x:e, g)
qsort3 xs = qcat xs []
where
qcat (x:xs) zs = part x xs zs [] [] []
qcat [] zs = zs
qapp (x:xs) zs = x:qapp xs zs
qapp [] zs = zs
part x [] zs !a !b !c = qcat a $ qapp (x : b) $ qcat c zs
part x (y:ys) zs !a !b !c =
case compare y x of
LT -> part x ys zs (y:a) b c
EQ -> part x ys zs a (y:b) c
GT -> part x ys zs a b (y:c)
main = let k = 20 in
defaultMain
-- [bench "tsort" (tsort k (tstinp k) :: IO (Array U DIM1 Int))]
-- [bench "List.sort" (nf List.sort (randomInts k))]
[bench "psort" (nf (qsortkpd 5) (randomInts k))]
tstinp n = fromListUnboxed (Z :. (2^n::Int)) $ randomInts n
randomInts n =
take (2^n) (randoms (mkStdGen 211570155))
:: [Int]