{-# LANGUAGE BangPatterns #-}

-- ---------------------------------------------------------------------------
-- |
-- Module      : Data.Vector.Algorithms.Tim
-- Copyright   : (c) 2013-2015 Dan Doel, 2015 Tim Baumann
-- Maintainer  : Dan Doel <dan.doel@gmail.com>
-- Stability   : Experimental
-- Portability : Non-portable (bang patterns)
--
-- Timsort is a complex, adaptive, bottom-up merge sort. It is designed to
-- minimize comparisons as much as possible, even at some cost in overhead.
-- Thus, it may not be ideal for sorting simple primitive types, for which
-- comparison is cheap. It may, however, be significantly faster for sorting
-- arrays of complex values (strings would be an example, though an algorithm
-- not based on comparison would probably be superior in that particular
-- case).
--
-- For more information on the details of the algorithm, read on.
--
-- The first step of the algorithm is to identify runs of elements. These can
-- either be non-decreasing or strictly decreasing sequences of elements in
-- the input. Strictly decreasing sequences are used rather than
-- non-increasing so that they can be easily reversed in place without the
-- sort becoming unstable.
--
-- If the natural runs are too short, they are padded to a minimum value. The
-- minimum is chosen based on the length of the array, and padded runs are put
-- in order using insertion sort. The length of the minimum run size is
-- determined as follows:
--
--   * If the length of the array is less than 64, the minimum size is the
--     length of the array, and insertion sort is used for the entirety
--
--   * Otherwise, a value between 32 and 64 is chosen such that N/min is
--     either equal to or just below a power of two. This avoids having a
--     small chunk left over to merge into much larger chunks at the end.
--
-- This is accomplished by taking the the mininum to be the lowest six bits
-- containing the highest set bit, and adding one if any other bits are set.
-- For instance:
--
--     length: 00000000 00000000 00000000 00011011 = 25
--     min:    00000000 00000000 00000000 00011011 = 25
--
--     length: 00000000 11111100 00000000 00000000 = 63 * 2^18
--     min:    00000000 00000000 00000000 00111111 = 63
--
--     length: 00000000 11111100 00000000 00000001 = 63 * 2^18 + 1
--     min:    00000000 00000000 00000000 01000000 = 64
--
-- Once chunks can be produced, the next step is merging them. The indices of
-- all runs are stored in a stack. When we identify a new run, we push it onto
-- the stack. However, certain invariants are maintained of the stack entries.
-- Namely:
--
--   if stk = _ :> z :> y :> x
--     length x + length y < length z
--
--   if stk = _ :> y :> x
--     length x < length y
--
-- This ensures that the chunks stored are decreasing, and that the chunk
-- sizes follow something like the fibonacci sequence, ensuring there at most
-- log-many chunks at any time. If pushing a new chunk on the stack would
-- violate either of the invariants, we first perform a merge.
--
-- If length x + length y >= length z, then y is merged with the smaller of x
-- and z (if they are tied, x is chosen, because it is more likely to be
-- cached). If, further,  length x >= length y then they are merged. These steps
-- are repeated until the invariants are established.
--
-- The last important piece of the algorithm is the merging. At first, two
-- chunks are merged element-wise. However, while doing so, counts are kept of
-- the number of elements taken from one chunk without any from its partner. If
-- this count exceeds a threshold, the merge switches to searching for elements
-- from one chunk in the other, and copying chunks at a time. If these chunks
-- start falling below the threshold, the merge switches back to element-wise.
--
-- The search used in the merge is also special. It uses a galloping strategy,
-- where exponentially increasing indices are tested, and once two such indices
-- are determined to bracket the desired value, binary search is used to find
-- the exact index within that range. This is asymptotically the same as simply
-- using binary search, but is likely to do fewer comparisons than binary search
-- would.
--
-- One aspect that is not yet implemented from the original Tim sort is the
-- adjustment of the above threshold. When galloping saves time, the threshold
-- is lowered, and when it doesn't, it is raised. This may be implemented in the
-- future.

module Data.Vector.Algorithms.Tim
       ( sort
       , sortUniq
       , sortBy
       , sortUniqBy
       ) where

import Prelude hiding (length, reverse)

import Control.Monad.Primitive
import Control.Monad (when)
import Data.Bits

import Data.Vector.Generic.Mutable

import Data.Vector.Algorithms.Search ( gallopingSearchRightPBounds
                                     , 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 :: v (PrimState m) e -> m ()
sort = Comparison e -> v (PrimState m) e -> m ()
forall (m :: * -> *) (v :: * -> * -> *) e.
(PrimMonad m, MVector v e) =>
Comparison e -> v (PrimState m) e -> m ()
sortBy Comparison e
forall a. Ord a => a -> a -> Ordering
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 :: v (PrimState m) e -> m (v (PrimState m) e)
sortUniq = Comparison e -> v (PrimState m) e -> m (v (PrimState m) e)
forall (m :: * -> *) (v :: * -> * -> *) e.
(PrimMonad m, MVector v e) =>
Comparison e -> v (PrimState m) e -> m (v (PrimState m) e)
sortUniqBy Comparison e
forall a. Ord a => a -> a -> Ordering
compare
{-# INLINABLE sortUniq #-}

-- | Sorts an array using a custom comparison.
sortBy :: (PrimMonad m, MVector v e)
       => Comparison e -> v (PrimState m) e -> m ()
sortBy :: Comparison e -> v (PrimState m) e -> m ()
sortBy Comparison e
cmp v (PrimState m) e
vec
  | Int
mr Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
len = [Int] -> Int -> v (PrimState m) e -> m ()
iter [Int
0] Int
0 ([Char] -> v (PrimState m) e
forall a. HasCallStack => [Char] -> a
error [Char]
"no merge buffer needed!")
  | Bool
otherwise = Int -> m (v (PrimState m) e)
forall (m :: * -> *) (v :: * -> * -> *) a.
(HasCallStack, PrimMonad m, MVector v a) =>
Int -> m (v (PrimState m) a)
new Int
256 m (v (PrimState m) e) -> (v (PrimState m) e -> m ()) -> m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [Int] -> Int -> v (PrimState m) e -> m ()
iter [] Int
0
 where
 len :: Int
len = v (PrimState m) e -> Int
forall (v :: * -> * -> *) a s. MVector v a => v s a -> Int
length v (PrimState m) e
vec
 mr :: Int
mr = Int -> Int
minrun Int
len
 iter :: [Int] -> Int -> v (PrimState m) e -> m ()
iter [Int]
s Int
i v (PrimState m) e
tmpBuf
   | Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
len  = [Int] -> v (PrimState m) e -> m ()
performRemainingMerges [Int]
s v (PrimState m) e
tmpBuf
   | Bool
otherwise = do (Order
order, Int
runLen) <- Comparison e -> v (PrimState m) e -> Int -> Int -> m (Order, Int)
forall (m :: * -> *) (v :: * -> * -> *) e.
(PrimMonad m, MVector v e) =>
Comparison e -> v (PrimState m) e -> Int -> Int -> m (Order, Int)
nextRun Comparison e
cmp v (PrimState m) e
vec Int
i Int
len
                    Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Order
order Order -> Order -> Bool
forall a. Eq a => a -> a -> Bool
== Order
Descending) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
                      v (PrimState m) e -> m ()
forall (m :: * -> *) (v :: * -> * -> *) a.
(PrimMonad m, MVector v a) =>
v (PrimState m) a -> m ()
reverse (v (PrimState m) e -> m ()) -> v (PrimState m) e -> m ()
forall a b. (a -> b) -> a -> b
$ Int -> Int -> v (PrimState m) e -> v (PrimState m) e
forall (v :: * -> * -> *) a s.
MVector v a =>
Int -> Int -> v s a -> v s a
unsafeSlice Int
i Int
runLen v (PrimState m) e
vec
                    let runEnd :: Int
runEnd = Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
len (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
runLen Int
mr)
                    Comparison e -> v (PrimState m) e -> Int -> Int -> Int -> m ()
forall (m :: * -> *) (v :: * -> * -> *) e.
(PrimMonad m, MVector v e) =>
Comparison e -> v (PrimState m) e -> Int -> Int -> Int -> m ()
sortByBounds' Comparison e
cmp v (PrimState m) e
vec Int
i (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
runLen) Int
runEnd
                    ([Int]
s', v (PrimState m) e
tmpBuf') <- [Int] -> Int -> v (PrimState m) e -> m ([Int], v (PrimState m) e)
performMerges (Int
i Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: [Int]
s) Int
runEnd v (PrimState m) e
tmpBuf
                    [Int] -> Int -> v (PrimState m) e -> m ()
iter [Int]
s' Int
runEnd v (PrimState m) e
tmpBuf'
 runLengthInvariantBroken :: a -> a -> a -> a -> Bool
runLengthInvariantBroken a
a a
b a
c a
i = (a
b a -> a -> a
forall a. Num a => a -> a -> a
- a
a a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<= a
i a -> a -> a
forall a. Num a => a -> a -> a
- a
b) Bool -> Bool -> Bool
|| (a
c a -> a -> a
forall a. Num a => a -> a -> a
- a
b a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<= a
i a -> a -> a
forall a. Num a => a -> a -> a
- a
c)
 performMerges :: [Int] -> Int -> v (PrimState m) e -> m ([Int], v (PrimState m) e)
performMerges [Int
b,Int
a] Int
i v (PrimState m) e
tmpBuf
   | Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
b Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
b Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
a = Comparison e
-> v (PrimState m) e
-> Int
-> Int
-> Int
-> v (PrimState m) e
-> m (v (PrimState m) e)
forall (m :: * -> *) (v :: * -> * -> *) e.
(PrimMonad m, MVector v e) =>
Comparison e
-> v (PrimState m) e
-> Int
-> Int
-> Int
-> v (PrimState m) e
-> m (v (PrimState m) e)
merge Comparison e
cmp v (PrimState m) e
vec Int
a Int
b Int
i v (PrimState m) e
tmpBuf m (v (PrimState m) e)
-> (v (PrimState m) e -> m ([Int], v (PrimState m) e))
-> m ([Int], v (PrimState m) e)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [Int] -> Int -> v (PrimState m) e -> m ([Int], v (PrimState m) e)
performMerges [Int
a] Int
i
 performMerges (Int
c:Int
b:Int
a:[Int]
ss) Int
i v (PrimState m) e
tmpBuf
   | Int -> Int -> Int -> Int -> Bool
forall a. (Ord a, Num a) => a -> a -> a -> a -> Bool
runLengthInvariantBroken Int
a Int
b Int
c Int
i =
     if Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
c Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
b Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
a
       then Comparison e
-> v (PrimState m) e
-> Int
-> Int
-> Int
-> v (PrimState m) e
-> m (v (PrimState m) e)
forall (m :: * -> *) (v :: * -> * -> *) e.
(PrimMonad m, MVector v e) =>
Comparison e
-> v (PrimState m) e
-> Int
-> Int
-> Int
-> v (PrimState m) e
-> m (v (PrimState m) e)
merge Comparison e
cmp v (PrimState m) e
vec Int
b Int
c Int
i v (PrimState m) e
tmpBuf m (v (PrimState m) e)
-> (v (PrimState m) e -> m ([Int], v (PrimState m) e))
-> m ([Int], v (PrimState m) e)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [Int] -> Int -> v (PrimState m) e -> m ([Int], v (PrimState m) e)
performMerges (Int
bInt -> [Int] -> [Int]
forall a. a -> [a] -> [a]
:Int
aInt -> [Int] -> [Int]
forall a. a -> [a] -> [a]
:[Int]
ss) Int
i
       else do v (PrimState m) e
tmpBuf' <- Comparison e
-> v (PrimState m) e
-> Int
-> Int
-> Int
-> v (PrimState m) e
-> m (v (PrimState m) e)
forall (m :: * -> *) (v :: * -> * -> *) e.
(PrimMonad m, MVector v e) =>
Comparison e
-> v (PrimState m) e
-> Int
-> Int
-> Int
-> v (PrimState m) e
-> m (v (PrimState m) e)
merge Comparison e
cmp v (PrimState m) e
vec Int
a Int
b Int
c v (PrimState m) e
tmpBuf
               ([Int]
ass', v (PrimState m) e
tmpBuf'') <- [Int] -> Int -> v (PrimState m) e -> m ([Int], v (PrimState m) e)
performMerges (Int
aInt -> [Int] -> [Int]
forall a. a -> [a] -> [a]
:[Int]
ss) Int
c v (PrimState m) e
tmpBuf'
               [Int] -> Int -> v (PrimState m) e -> m ([Int], v (PrimState m) e)
performMerges (Int
cInt -> [Int] -> [Int]
forall a. a -> [a] -> [a]
:[Int]
ass') Int
i v (PrimState m) e
tmpBuf''
 performMerges [Int]
s Int
_ v (PrimState m) e
tmpBuf = ([Int], v (PrimState m) e) -> m ([Int], v (PrimState m) e)
forall (m :: * -> *) a. Monad m => a -> m a
return ([Int]
s, v (PrimState m) e
tmpBuf)
 performRemainingMerges :: [Int] -> v (PrimState m) e -> m ()
performRemainingMerges (Int
b:Int
a:[Int]
ss) v (PrimState m) e
tmpBuf =
   Comparison e
-> v (PrimState m) e
-> Int
-> Int
-> Int
-> v (PrimState m) e
-> m (v (PrimState m) e)
forall (m :: * -> *) (v :: * -> * -> *) e.
(PrimMonad m, MVector v e) =>
Comparison e
-> v (PrimState m) e
-> Int
-> Int
-> Int
-> v (PrimState m) e
-> m (v (PrimState m) e)
merge Comparison e
cmp v (PrimState m) e
vec Int
a Int
b Int
len v (PrimState m) e
tmpBuf m (v (PrimState m) e) -> (v (PrimState m) e -> m ()) -> m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [Int] -> v (PrimState m) e -> m ()
performRemainingMerges (Int
aInt -> [Int] -> [Int]
forall a. a -> [a] -> [a]
:[Int]
ss)
 performRemainingMerges [Int]
_ v (PrimState m) e
_ = () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
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 :: Comparison e -> v (PrimState m) e -> m (v (PrimState m) e)
sortUniqBy Comparison e
cmp v (PrimState m) e
vec = do
  Comparison e -> v (PrimState m) e -> m ()
forall (m :: * -> *) (v :: * -> * -> *) e.
(PrimMonad m, MVector v e) =>
Comparison e -> v (PrimState m) e -> m ()
sortBy Comparison e
cmp v (PrimState m) e
vec
  Comparison e -> v (PrimState m) e -> m (v (PrimState m) e)
forall (m :: * -> *) (v :: * -> * -> *) e.
(PrimMonad m, MVector v e) =>
Comparison e -> v (PrimState m) e -> m (v (PrimState m) e)
uniqueMutableBy Comparison e
cmp v (PrimState m) e
vec
{-# INLINE sortUniqBy #-}

-- | Computes the minimum run size for the sort. The goal is to choose a size
-- such that there are almost if not exactly 2^n chunks of that size in the
-- array.
minrun :: Int -> Int
minrun :: Int -> Int
minrun Int
n0 = (Int
n0 Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`unsafeShiftR` Int
extra) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ if (Int
lowMask Int -> Int -> Int
forall a. Bits a => a -> a -> a
.&. Int
n0) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 then Int
1 else Int
0
 where
 -- smear the bits down from the most significant bit
 !n1 :: Int
n1 = Int
n0 Int -> Int -> Int
forall a. Bits a => a -> a -> a
.|. Int -> Int -> Int
forall a. Bits a => a -> Int -> a
unsafeShiftR Int
n0 Int
1
 !n2 :: Int
n2 = Int
n1 Int -> Int -> Int
forall a. Bits a => a -> a -> a
.|. Int -> Int -> Int
forall a. Bits a => a -> Int -> a
unsafeShiftR Int
n1 Int
2
 !n3 :: Int
n3 = Int
n2 Int -> Int -> Int
forall a. Bits a => a -> a -> a
.|. Int -> Int -> Int
forall a. Bits a => a -> Int -> a
unsafeShiftR Int
n2 Int
4
 !n4 :: Int
n4 = Int
n3 Int -> Int -> Int
forall a. Bits a => a -> a -> a
.|. Int -> Int -> Int
forall a. Bits a => a -> Int -> a
unsafeShiftR Int
n3 Int
8
 !n5 :: Int
n5 = Int
n4 Int -> Int -> Int
forall a. Bits a => a -> a -> a
.|. Int -> Int -> Int
forall a. Bits a => a -> Int -> a
unsafeShiftR Int
n4 Int
16
 !n6 :: Int
n6 = Int
n5 Int -> Int -> Int
forall a. Bits a => a -> a -> a
.|. Int -> Int -> Int
forall a. Bits a => a -> Int -> a
unsafeShiftR Int
n5 Int
32

 -- mask for the bits lower than the 6 highest bits
 !lowMask :: Int
lowMask = Int
n6 Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`unsafeShiftR` Int
6

 !extra :: Int
extra = Int -> Int
forall a. Bits a => a -> Int
popCount Int
lowMask
{-# INLINE minrun #-}

data Order = Ascending | Descending deriving (Order -> Order -> Bool
(Order -> Order -> Bool) -> (Order -> Order -> Bool) -> Eq Order
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Order -> Order -> Bool
$c/= :: Order -> Order -> Bool
== :: Order -> Order -> Bool
$c== :: Order -> Order -> Bool
Eq, Int -> Order -> ShowS
[Order] -> ShowS
Order -> [Char]
(Int -> Order -> ShowS)
-> (Order -> [Char]) -> ([Order] -> ShowS) -> Show Order
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [Order] -> ShowS
$cshowList :: [Order] -> ShowS
show :: Order -> [Char]
$cshow :: Order -> [Char]
showsPrec :: Int -> Order -> ShowS
$cshowsPrec :: Int -> Order -> ShowS
Show)

-- | Identify the next run (that is a monotonically increasing or strictly
-- decreasing sequence) in the slice [l,u) in vec. Returns the order and length
-- of the run.
nextRun :: (PrimMonad m, MVector v e)
        => Comparison e
        -> v (PrimState m) e
        -> Int -- ^ l
        -> Int -- ^ u
        -> m (Order, Int)
nextRun :: Comparison e -> v (PrimState m) e -> Int -> Int -> m (Order, Int)
nextRun Comparison e
_ v (PrimState m) e
_ Int
i Int
len | Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
len = (Order, Int) -> m (Order, Int)
forall (m :: * -> *) a. Monad m => a -> m a
return (Order
Ascending, Int
1)
nextRun Comparison e
cmp v (PrimState m) e
vec Int
i Int
len = do e
x <- v (PrimState m) e -> Int -> m e
forall (m :: * -> *) (v :: * -> * -> *) a.
(PrimMonad m, MVector v a) =>
v (PrimState m) a -> Int -> m a
unsafeRead v (PrimState m) e
vec Int
i
                           e
y <- v (PrimState m) e -> Int -> m e
forall (m :: * -> *) (v :: * -> * -> *) a.
(PrimMonad m, MVector v a) =>
v (PrimState m) a -> Int -> m a
unsafeRead v (PrimState m) e
vec (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)
                           if e
x e -> e -> Bool
`gt` e
y then e -> Int -> m (Order, Int)
desc e
y Int
2 else e -> Int -> m (Order, Int)
asc  e
y Int
2
 where
 gt :: e -> e -> Bool
gt e
a e
b = Comparison e
cmp e
a e
b Ordering -> Ordering -> Bool
forall a. Eq a => a -> a -> Bool
== Ordering
GT
 desc :: e -> Int -> m (Order, Int)
desc e
_ !Int
k | Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
k Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
len = (Order, Int) -> m (Order, Int)
forall (m :: * -> *) a. Monad m => a -> m a
return (Order
Descending, Int
k)
 desc e
x !Int
k = do e
y <- v (PrimState m) e -> Int -> m e
forall (m :: * -> *) (v :: * -> * -> *) a.
(PrimMonad m, MVector v a) =>
v (PrimState m) a -> Int -> m a
unsafeRead v (PrimState m) e
vec (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
k)
                if e
x e -> e -> Bool
`gt` e
y then e -> Int -> m (Order, Int)
desc e
y (Int
kInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) else (Order, Int) -> m (Order, Int)
forall (m :: * -> *) a. Monad m => a -> m a
return (Order
Descending, Int
k)
 asc :: e -> Int -> m (Order, Int)
asc e
_ !Int
k | Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
k Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
len = (Order, Int) -> m (Order, Int)
forall (m :: * -> *) a. Monad m => a -> m a
return (Order
Ascending, Int
k)
 asc e
x !Int
k = do e
y <- v (PrimState m) e -> Int -> m e
forall (m :: * -> *) (v :: * -> * -> *) a.
(PrimMonad m, MVector v a) =>
v (PrimState m) a -> Int -> m a
unsafeRead v (PrimState m) e
vec (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
k)
               if e
x e -> e -> Bool
`gt` e
y then (Order, Int) -> m (Order, Int)
forall (m :: * -> *) a. Monad m => a -> m a
return (Order
Ascending, Int
k) else e -> Int -> m (Order, Int)
asc e
y (Int
kInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)
{-# INLINE nextRun #-}

-- | Tests if a temporary buffer has a given size. If not, allocates a new
-- buffer and returns it instead of the old temporary buffer.
ensureCapacity :: (PrimMonad m, MVector v e)
               => Int -> v (PrimState m) e -> m (v (PrimState m) e)
ensureCapacity :: Int -> v (PrimState m) e -> m (v (PrimState m) e)
ensureCapacity Int
l v (PrimState m) e
tmpBuf
  | Int
l Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= v (PrimState m) e -> Int
forall (v :: * -> * -> *) a s. MVector v a => v s a -> Int
length v (PrimState m) e
tmpBuf = v (PrimState m) e -> m (v (PrimState m) e)
forall (m :: * -> *) a. Monad m => a -> m a
return v (PrimState m) e
tmpBuf
  | Bool
otherwise          = Int -> m (v (PrimState m) e)
forall (m :: * -> *) (v :: * -> * -> *) a.
(HasCallStack, PrimMonad m, MVector v a) =>
Int -> m (v (PrimState m) a)
new (Int
2Int -> Int -> Int
forall a. Num a => a -> a -> a
*Int
l)
{-# INLINE ensureCapacity #-}

-- | Copy the slice [i,i+len) from vec to tmpBuf. If tmpBuf is not large enough,
-- a new buffer is allocated and used. Returns the buffer.
cloneSlice :: (PrimMonad m, MVector v e)
           => Int -- ^ i
           -> Int -- ^ len
           -> v (PrimState m) e -- ^ vec
           -> v (PrimState m) e -- ^ tmpBuf
           -> m (v (PrimState m) e)
cloneSlice :: Int
-> Int
-> v (PrimState m) e
-> v (PrimState m) e
-> m (v (PrimState m) e)
cloneSlice Int
i Int
len v (PrimState m) e
vec v (PrimState m) e
tmpBuf = do
  v (PrimState m) e
tmpBuf' <- Int -> v (PrimState m) e -> m (v (PrimState m) e)
forall (m :: * -> *) (v :: * -> * -> *) e.
(PrimMonad m, MVector v e) =>
Int -> v (PrimState m) e -> m (v (PrimState m) e)
ensureCapacity Int
len v (PrimState m) e
tmpBuf
  v (PrimState m) e -> v (PrimState m) e -> m ()
forall (m :: * -> *) (v :: * -> * -> *) a.
(PrimMonad m, MVector v a) =>
v (PrimState m) a -> v (PrimState m) a -> m ()
unsafeCopy (Int -> Int -> v (PrimState m) e -> v (PrimState m) e
forall (v :: * -> * -> *) a s.
MVector v a =>
Int -> Int -> v s a -> v s a
unsafeSlice Int
0 Int
len v (PrimState m) e
tmpBuf') (Int -> Int -> v (PrimState m) e -> v (PrimState m) e
forall (v :: * -> * -> *) a s.
MVector v a =>
Int -> Int -> v s a -> v s a
unsafeSlice Int
i Int
len v (PrimState m) e
vec)
  v (PrimState m) e -> m (v (PrimState m) e)
forall (m :: * -> *) a. Monad m => a -> m a
return v (PrimState m) e
tmpBuf'
{-# INLINE cloneSlice #-}

-- | Number of consecutive times merge chooses the element from the same run
-- before galloping mode is activated.
minGallop :: Int
minGallop :: Int
minGallop = Int
7
{-# INLINE minGallop #-}

-- | Merge the adjacent sorted slices [l,m) and [m,u) in vec. This is done by
-- copying the slice [l,m) to a temporary buffer. Returns the (enlarged)
-- temporary buffer.
mergeLo :: (PrimMonad m, MVector v e)
        => Comparison e
        -> v (PrimState m) e -- ^ vec
        -> Int -- ^ l
        -> Int -- ^ m
        -> Int -- ^ u
        -> v (PrimState m) e -- ^ tmpBuf
        -> m (v (PrimState m) e)
mergeLo :: Comparison e
-> v (PrimState m) e
-> Int
-> Int
-> Int
-> v (PrimState m) e
-> m (v (PrimState m) e)
mergeLo Comparison e
cmp v (PrimState m) e
vec Int
l Int
m Int
u v (PrimState m) e
tempBuf' = do
  v (PrimState m) e
tmpBuf <- Int
-> Int
-> v (PrimState m) e
-> v (PrimState m) e
-> m (v (PrimState m) e)
forall (m :: * -> *) (v :: * -> * -> *) e.
(PrimMonad m, MVector v e) =>
Int
-> Int
-> v (PrimState m) e
-> v (PrimState m) e
-> m (v (PrimState m) e)
cloneSlice Int
l Int
tmpBufLen v (PrimState m) e
vec v (PrimState m) e
tempBuf'
  e
vi <- v (PrimState m) e -> Int -> m e
forall (m :: * -> *) (v :: * -> * -> *) a.
(PrimMonad m, MVector v a) =>
v (PrimState m) a -> Int -> m a
unsafeRead v (PrimState m) e
tmpBuf Int
0
  e
vj <- v (PrimState m) e -> Int -> m e
forall (m :: * -> *) (v :: * -> * -> *) a.
(PrimMonad m, MVector v a) =>
v (PrimState m) a -> Int -> m a
unsafeRead v (PrimState m) e
vec Int
m
  v (PrimState m) e
-> Int -> Int -> Int -> e -> e -> Int -> Int -> m ()
iter v (PrimState m) e
tmpBuf Int
0 Int
m Int
l e
vi e
vj Int
minGallop Int
minGallop
  v (PrimState m) e -> m (v (PrimState m) e)
forall (m :: * -> *) a. Monad m => a -> m a
return v (PrimState m) e
tmpBuf
 where
 gt :: e -> e -> Bool
gt  e
a e
b = Comparison e
cmp e
a e
b Ordering -> Ordering -> Bool
forall a. Eq a => a -> a -> Bool
== Ordering
GT
 gte :: e -> e -> Bool
gte e
a e
b = Comparison e
cmp e
a e
b Ordering -> Ordering -> Bool
forall a. Eq a => a -> a -> Bool
/= Ordering
LT
 tmpBufLen :: Int
tmpBufLen = Int
m Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
l

 finalize :: v (PrimState m) e -> Int -> Int -> m ()
finalize v (PrimState m) e
tmpBuf Int
i Int
k = do
   let from :: v (PrimState m) e
from = Int -> Int -> v (PrimState m) e -> v (PrimState m) e
forall (v :: * -> * -> *) a s.
MVector v a =>
Int -> Int -> v s a -> v s a
unsafeSlice Int
i (Int
tmpBufLenInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
i) v (PrimState m) e
tmpBuf
       to :: v (PrimState m) e
to   = Int -> Int -> v (PrimState m) e -> v (PrimState m) e
forall (v :: * -> * -> *) a s.
MVector v a =>
Int -> Int -> v s a -> v s a
unsafeSlice Int
k (Int
tmpBufLenInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
i) v (PrimState m) e
vec
   v (PrimState m) e -> v (PrimState m) e -> m ()
forall (m :: * -> *) (v :: * -> * -> *) a.
(PrimMonad m, MVector v a) =>
v (PrimState m) a -> v (PrimState m) a -> m ()
unsafeCopy v (PrimState m) e
to v (PrimState m) e
from

 iter :: v (PrimState m) e
-> Int -> Int -> Int -> e -> e -> Int -> Int -> m ()
iter v (PrimState m) e
_ Int
i Int
_ Int
_ e
_ e
_ Int
_ Int
_ | Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
tmpBufLen = () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
 iter v (PrimState m) e
tmpBuf Int
i Int
j Int
k e
_ e
_ Int
_ Int
_ | Int
j Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
u = v (PrimState m) e -> Int -> Int -> m ()
finalize v (PrimState m) e
tmpBuf Int
i Int
k
 iter v (PrimState m) e
tmpBuf Int
i Int
j Int
k e
_ e
vj Int
0 Int
_ = do
   Int
i' <- (e -> Bool) -> v (PrimState m) e -> Int -> Int -> m Int
forall (m :: * -> *) (v :: * -> * -> *) e.
(PrimMonad m, MVector v e) =>
(e -> Bool) -> v (PrimState m) e -> Int -> Int -> m Int
gallopingSearchLeftPBounds (e -> e -> Bool
`gt` e
vj) v (PrimState m) e
tmpBuf Int
i Int
tmpBufLen
   let gallopLen :: Int
gallopLen = Int
i' Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
i
       from :: v (PrimState m) e
from = Int -> Int -> v (PrimState m) e -> v (PrimState m) e
forall (v :: * -> * -> *) a s.
MVector v a =>
Int -> Int -> v s a -> v s a
unsafeSlice Int
i Int
gallopLen v (PrimState m) e
tmpBuf
       to :: v (PrimState m) e
to   = Int -> Int -> v (PrimState m) e -> v (PrimState m) e
forall (v :: * -> * -> *) a s.
MVector v a =>
Int -> Int -> v s a -> v s a
unsafeSlice Int
k Int
gallopLen v (PrimState m) e
vec
   v (PrimState m) e -> v (PrimState m) e -> m ()
forall (m :: * -> *) (v :: * -> * -> *) a.
(PrimMonad m, MVector v a) =>
v (PrimState m) a -> v (PrimState m) a -> m ()
unsafeCopy v (PrimState m) e
to v (PrimState m) e
from
   Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
i' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
tmpBufLen) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
     e
vi' <- v (PrimState m) e -> Int -> m e
forall (m :: * -> *) (v :: * -> * -> *) a.
(PrimMonad m, MVector v a) =>
v (PrimState m) a -> Int -> m a
unsafeRead v (PrimState m) e
tmpBuf Int
i'
     v (PrimState m) e
-> Int -> Int -> Int -> e -> e -> Int -> Int -> m ()
iter v (PrimState m) e
tmpBuf Int
i' Int
j (Int
kInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
gallopLen) e
vi' e
vj Int
minGallop Int
minGallop
 iter v (PrimState m) e
tmpBuf Int
i Int
j Int
k e
vi e
_ Int
_ Int
0 = do
   Int
j' <- (e -> Bool) -> v (PrimState m) e -> Int -> Int -> m Int
forall (m :: * -> *) (v :: * -> * -> *) e.
(PrimMonad m, MVector v e) =>
(e -> Bool) -> v (PrimState m) e -> Int -> Int -> m Int
gallopingSearchLeftPBounds (e -> e -> Bool
`gte` e
vi) v (PrimState m) e
vec Int
j Int
u
   let gallopLen :: Int
gallopLen = Int
j' Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
j
       from :: v (PrimState m) e
from = Int -> Int -> v (PrimState m) e -> v (PrimState m) e
forall (v :: * -> * -> *) a s.
(HasCallStack, MVector v a) =>
Int -> Int -> v s a -> v s a
slice Int
j Int
gallopLen v (PrimState m) e
vec
       to :: v (PrimState m) e
to   = Int -> Int -> v (PrimState m) e -> v (PrimState m) e
forall (v :: * -> * -> *) a s.
(HasCallStack, MVector v a) =>
Int -> Int -> v s a -> v s a
slice Int
k Int
gallopLen v (PrimState m) e
vec
   v (PrimState m) e -> v (PrimState m) e -> m ()
forall (m :: * -> *) (v :: * -> * -> *) a.
(PrimMonad m, MVector v a) =>
v (PrimState m) a -> v (PrimState m) a -> m ()
unsafeMove v (PrimState m) e
to v (PrimState m) e
from
   if Int
j' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
u then v (PrimState m) e -> Int -> Int -> m ()
finalize v (PrimState m) e
tmpBuf Int
i (Int
k Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
gallopLen) else do
     e
vj' <- v (PrimState m) e -> Int -> m e
forall (m :: * -> *) (v :: * -> * -> *) a.
(PrimMonad m, MVector v a) =>
v (PrimState m) a -> Int -> m a
unsafeRead v (PrimState m) e
vec Int
j'
     v (PrimState m) e
-> Int -> Int -> Int -> e -> e -> Int -> Int -> m ()
iter v (PrimState m) e
tmpBuf Int
i Int
j' (Int
kInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
gallopLen) e
vi e
vj' Int
minGallop Int
minGallop
 iter v (PrimState m) e
tmpBuf Int
i Int
j Int
k e
vi e
vj Int
ga Int
gb
   | e
vj e -> e -> Bool
`gte` e
vi = do v (PrimState m) e -> Int -> e -> m ()
forall (m :: * -> *) (v :: * -> * -> *) a.
(PrimMonad m, MVector v a) =>
v (PrimState m) a -> Int -> a -> m ()
unsafeWrite v (PrimState m) e
vec Int
k e
vi
                      Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
tmpBufLen) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
                        e
vi' <- v (PrimState m) e -> Int -> m e
forall (m :: * -> *) (v :: * -> * -> *) a.
(PrimMonad m, MVector v a) =>
v (PrimState m) a -> Int -> m a
unsafeRead v (PrimState m) e
tmpBuf (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)
                        v (PrimState m) e
-> Int -> Int -> Int -> e -> e -> Int -> Int -> m ()
iter v (PrimState m) e
tmpBuf (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) Int
j (Int
kInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) e
vi' e
vj (Int
gaInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) Int
minGallop
   | Bool
otherwise   = do v (PrimState m) e -> Int -> e -> m ()
forall (m :: * -> *) (v :: * -> * -> *) a.
(PrimMonad m, MVector v a) =>
v (PrimState m) a -> Int -> a -> m ()
unsafeWrite v (PrimState m) e
vec Int
k e
vj
                      if Int
j Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
u then v (PrimState m) e -> Int -> Int -> m ()
finalize v (PrimState m) e
tmpBuf Int
i (Int
k Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) else do
                        e
vj' <- v (PrimState m) e -> Int -> m e
forall (m :: * -> *) (v :: * -> * -> *) a.
(PrimMonad m, MVector v a) =>
v (PrimState m) a -> Int -> m a
unsafeRead v (PrimState m) e
vec (Int
jInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)
                        v (PrimState m) e
-> Int -> Int -> Int -> e -> e -> Int -> Int -> m ()
iter v (PrimState m) e
tmpBuf Int
i (Int
jInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) (Int
kInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) e
vi e
vj' Int
minGallop (Int
gbInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)
{-# INLINE mergeLo #-}

-- | Merge the adjacent sorted slices [l,m) and [m,u) in vec. This is done by
-- copying the slice [j,k) to a temporary buffer. Returns the (enlarged)
-- temporary buffer.
mergeHi :: (PrimMonad m, MVector v e)
        => Comparison e
        -> v (PrimState m) e -- ^ vec
        -> Int -- ^ l
        -> Int -- ^ m
        -> Int -- ^ u
        -> v (PrimState m) e -- ^ tmpBuf
        -> m (v (PrimState m) e)
mergeHi :: Comparison e
-> v (PrimState m) e
-> Int
-> Int
-> Int
-> v (PrimState m) e
-> m (v (PrimState m) e)
mergeHi Comparison e
cmp v (PrimState m) e
vec Int
l Int
m Int
u v (PrimState m) e
tmpBuf' = do
  v (PrimState m) e
tmpBuf <- Int
-> Int
-> v (PrimState m) e
-> v (PrimState m) e
-> m (v (PrimState m) e)
forall (m :: * -> *) (v :: * -> * -> *) e.
(PrimMonad m, MVector v e) =>
Int
-> Int
-> v (PrimState m) e
-> v (PrimState m) e
-> m (v (PrimState m) e)
cloneSlice Int
m Int
tmpBufLen v (PrimState m) e
vec v (PrimState m) e
tmpBuf'
  e
vi <- v (PrimState m) e -> Int -> m e
forall (m :: * -> *) (v :: * -> * -> *) a.
(PrimMonad m, MVector v a) =>
v (PrimState m) a -> Int -> m a
unsafeRead v (PrimState m) e
vec (Int
mInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)
  e
vj <- v (PrimState m) e -> Int -> m e
forall (m :: * -> *) (v :: * -> * -> *) a.
(PrimMonad m, MVector v a) =>
v (PrimState m) a -> Int -> m a
unsafeRead v (PrimState m) e
tmpBuf (Int
tmpBufLenInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)
  v (PrimState m) e
-> Int -> Int -> Int -> e -> e -> Int -> Int -> m ()
iter v (PrimState m) e
tmpBuf (Int
mInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) (Int
tmpBufLenInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) (Int
uInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) e
vi e
vj Int
minGallop Int
minGallop
  v (PrimState m) e -> m (v (PrimState m) e)
forall (m :: * -> *) a. Monad m => a -> m a
return v (PrimState m) e
tmpBuf
 where
 gt :: e -> e -> Bool
gt  e
a e
b = Comparison e
cmp e
a e
b Ordering -> Ordering -> Bool
forall a. Eq a => a -> a -> Bool
== Ordering
GT
 gte :: e -> e -> Bool
gte e
a e
b = Comparison e
cmp e
a e
b Ordering -> Ordering -> Bool
forall a. Eq a => a -> a -> Bool
/= Ordering
LT
 tmpBufLen :: Int
tmpBufLen = Int
u Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
m

 finalize :: v (PrimState m) e -> Int -> m ()
finalize v (PrimState m) e
tmpBuf Int
j = do
   let from :: v (PrimState m) e
from = Int -> Int -> v (PrimState m) e -> v (PrimState m) e
forall (v :: * -> * -> *) a s.
MVector v a =>
Int -> Int -> v s a -> v s a
unsafeSlice Int
0 (Int
jInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) v (PrimState m) e
tmpBuf
       to :: v (PrimState m) e
to   = Int -> Int -> v (PrimState m) e -> v (PrimState m) e
forall (v :: * -> * -> *) a s.
MVector v a =>
Int -> Int -> v s a -> v s a
unsafeSlice Int
l (Int
jInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) v (PrimState m) e
vec
   v (PrimState m) e -> v (PrimState m) e -> m ()
forall (m :: * -> *) (v :: * -> * -> *) a.
(PrimMonad m, MVector v a) =>
v (PrimState m) a -> v (PrimState m) a -> m ()
unsafeCopy v (PrimState m) e
to v (PrimState m) e
from

 iter :: v (PrimState m) e
-> Int -> Int -> Int -> e -> e -> Int -> Int -> m ()
iter v (PrimState m) e
_ Int
_ Int
j Int
_ e
_ e
_ Int
_ Int
_ | Int
j Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 = () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
 iter v (PrimState m) e
tmpBuf Int
i Int
j Int
_ e
_ e
_ Int
_ Int
_ | Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
l = v (PrimState m) e -> Int -> m ()
finalize v (PrimState m) e
tmpBuf Int
j
 iter v (PrimState m) e
tmpBuf Int
i Int
j Int
k e
_ e
vj Int
0 Int
_ = do
   Int
i' <- (e -> Bool) -> v (PrimState m) e -> Int -> Int -> m Int
forall (m :: * -> *) (v :: * -> * -> *) e.
(PrimMonad m, MVector v e) =>
(e -> Bool) -> v (PrimState m) e -> Int -> Int -> m Int
gallopingSearchRightPBounds (e -> e -> Bool
`gt` e
vj) v (PrimState m) e
vec Int
l Int
i
   let gallopLen :: Int
gallopLen = Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
i'
       from :: v (PrimState m) e
from = Int -> Int -> v (PrimState m) e -> v (PrimState m) e
forall (v :: * -> * -> *) a s.
(HasCallStack, MVector v a) =>
Int -> Int -> v s a -> v s a
slice (Int
i'Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) Int
gallopLen v (PrimState m) e
vec
       to :: v (PrimState m) e
to   = Int -> Int -> v (PrimState m) e -> v (PrimState m) e
forall (v :: * -> * -> *) a s.
(HasCallStack, MVector v a) =>
Int -> Int -> v s a -> v s a
slice (Int
kInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
gallopLenInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) Int
gallopLen v (PrimState m) e
vec
   v (PrimState m) e -> v (PrimState m) e -> m ()
forall (m :: * -> *) (v :: * -> * -> *) a.
(PrimMonad m, MVector v a) =>
v (PrimState m) a -> v (PrimState m) a -> m ()
unsafeMove v (PrimState m) e
to v (PrimState m) e
from
   if Int
i' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
l then v (PrimState m) e -> Int -> m ()
finalize v (PrimState m) e
tmpBuf Int
j else do
     e
vi' <- v (PrimState m) e -> Int -> m e
forall (m :: * -> *) (v :: * -> * -> *) a.
(PrimMonad m, MVector v a) =>
v (PrimState m) a -> Int -> m a
unsafeRead v (PrimState m) e
vec Int
i'
     v (PrimState m) e
-> Int -> Int -> Int -> e -> e -> Int -> Int -> m ()
iter v (PrimState m) e
tmpBuf Int
i' Int
j (Int
kInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
gallopLen) e
vi' e
vj Int
minGallop Int
minGallop
 iter v (PrimState m) e
tmpBuf Int
i Int
j Int
k e
vi e
_ Int
_ Int
0 = do
   Int
j' <- (e -> Bool) -> v (PrimState m) e -> Int -> Int -> m Int
forall (m :: * -> *) (v :: * -> * -> *) e.
(PrimMonad m, MVector v e) =>
(e -> Bool) -> v (PrimState m) e -> Int -> Int -> m Int
gallopingSearchRightPBounds (e -> e -> Bool
`gte` e
vi) v (PrimState m) e
tmpBuf Int
0 Int
j
   let gallopLen :: Int
gallopLen = Int
j Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
j'
       from :: v (PrimState m) e
from = Int -> Int -> v (PrimState m) e -> v (PrimState m) e
forall (v :: * -> * -> *) a s.
(HasCallStack, MVector v a) =>
Int -> Int -> v s a -> v s a
slice (Int
j'Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) Int
gallopLen v (PrimState m) e
tmpBuf
       to :: v (PrimState m) e
to   = Int -> Int -> v (PrimState m) e -> v (PrimState m) e
forall (v :: * -> * -> *) a s.
(HasCallStack, MVector v a) =>
Int -> Int -> v s a -> v s a
slice (Int
kInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
gallopLenInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) Int
gallopLen v (PrimState m) e
vec
   v (PrimState m) e -> v (PrimState m) e -> m ()
forall (m :: * -> *) (v :: * -> * -> *) a.
(PrimMonad m, MVector v a) =>
v (PrimState m) a -> v (PrimState m) a -> m ()
unsafeCopy v (PrimState m) e
to v (PrimState m) e
from
   Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
j' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
0) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
     e
vj' <- v (PrimState m) e -> Int -> m e
forall (m :: * -> *) (v :: * -> * -> *) a.
(PrimMonad m, MVector v a) =>
v (PrimState m) a -> Int -> m a
unsafeRead v (PrimState m) e
tmpBuf Int
j'
     v (PrimState m) e
-> Int -> Int -> Int -> e -> e -> Int -> Int -> m ()
iter v (PrimState m) e
tmpBuf Int
i Int
j' (Int
kInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
gallopLen) e
vi e
vj' Int
minGallop Int
minGallop
 iter v (PrimState m) e
tmpBuf Int
i Int
j Int
k e
vi e
vj Int
ga Int
gb
   | e
vi e -> e -> Bool
`gt` e
vj = do v (PrimState m) e -> Int -> e -> m ()
forall (m :: * -> *) (v :: * -> * -> *) a.
(PrimMonad m, MVector v a) =>
v (PrimState m) a -> Int -> a -> m ()
unsafeWrite v (PrimState m) e
vec Int
k e
vi
                     if Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
l then v (PrimState m) e -> Int -> m ()
finalize v (PrimState m) e
tmpBuf Int
j else do
                       e
vi' <- v (PrimState m) e -> Int -> m e
forall (m :: * -> *) (v :: * -> * -> *) a.
(PrimMonad m, MVector v a) =>
v (PrimState m) a -> Int -> m a
unsafeRead v (PrimState m) e
vec (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)
                       v (PrimState m) e
-> Int -> Int -> Int -> e -> e -> Int -> Int -> m ()
iter v (PrimState m) e
tmpBuf (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) Int
j (Int
kInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) e
vi' e
vj (Int
gaInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) Int
minGallop
   | Bool
otherwise  = do v (PrimState m) e -> Int -> e -> m ()
forall (m :: * -> *) (v :: * -> * -> *) a.
(PrimMonad m, MVector v a) =>
v (PrimState m) a -> Int -> a -> m ()
unsafeWrite v (PrimState m) e
vec Int
k e
vj
                     Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
j Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
0) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
                       e
vj' <- v (PrimState m) e -> Int -> m e
forall (m :: * -> *) (v :: * -> * -> *) a.
(PrimMonad m, MVector v a) =>
v (PrimState m) a -> Int -> m a
unsafeRead v (PrimState m) e
tmpBuf (Int
jInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)
                       v (PrimState m) e
-> Int -> Int -> Int -> e -> e -> Int -> Int -> m ()
iter v (PrimState m) e
tmpBuf Int
i (Int
jInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) (Int
kInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) e
vi e
vj' Int
minGallop (Int
gbInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)
{-# INLINE mergeHi #-}

-- | Merge the adjacent sorted slices A=[l,m) and B=[m,u) in vec. This begins
-- with galloping searches to find the index of vec[m] in A and the index of
-- vec[m-1] in B to reduce the sizes of A and B. Then it uses `mergeHi` or
-- `mergeLo` depending on whether A or B is larger. Returns the (enlarged)
-- temporary buffer.
merge :: (PrimMonad m, MVector v e)
      => Comparison e
      -> v (PrimState m) e -- ^ vec
      -> Int -- ^ l
      -> Int -- ^ m
      -> Int -- ^ u
      -> v (PrimState m) e -- ^ tmpBuf
      -> m (v (PrimState m) e)
merge :: Comparison e
-> v (PrimState m) e
-> Int
-> Int
-> Int
-> v (PrimState m) e
-> m (v (PrimState m) e)
merge Comparison e
cmp v (PrimState m) e
vec Int
l Int
m Int
u v (PrimState m) e
tmpBuf = do
  e
vm <- v (PrimState m) e -> Int -> m e
forall (m :: * -> *) (v :: * -> * -> *) a.
(PrimMonad m, MVector v a) =>
v (PrimState m) a -> Int -> m a
unsafeRead v (PrimState m) e
vec Int
m
  Int
l' <- (e -> Bool) -> v (PrimState m) e -> Int -> Int -> m Int
forall (m :: * -> *) (v :: * -> * -> *) e.
(PrimMonad m, MVector v e) =>
(e -> Bool) -> v (PrimState m) e -> Int -> Int -> m Int
gallopingSearchLeftPBounds (e -> e -> Bool
`gt` e
vm) v (PrimState m) e
vec Int
l Int
m
  if Int
l' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
m
    then v (PrimState m) e -> m (v (PrimState m) e)
forall (m :: * -> *) a. Monad m => a -> m a
return v (PrimState m) e
tmpBuf
    else do
      e
vn <- v (PrimState m) e -> Int -> m e
forall (m :: * -> *) (v :: * -> * -> *) a.
(PrimMonad m, MVector v a) =>
v (PrimState m) a -> Int -> m a
unsafeRead v (PrimState m) e
vec (Int
mInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)
      Int
u' <- (e -> Bool) -> v (PrimState m) e -> Int -> Int -> m Int
forall (m :: * -> *) (v :: * -> * -> *) e.
(PrimMonad m, MVector v e) =>
(e -> Bool) -> v (PrimState m) e -> Int -> Int -> m Int
gallopingSearchRightPBounds (e -> e -> Bool
`gte` e
vn) v (PrimState m) e
vec Int
m Int
u
      if Int
u' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
m
        then v (PrimState m) e -> m (v (PrimState m) e)
forall (m :: * -> *) a. Monad m => a -> m a
return v (PrimState m) e
tmpBuf
        else (if (Int
mInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
l') Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= (Int
u'Int -> Int -> Int
forall a. Num a => a -> a -> a
-Int
m) then Comparison e
-> v (PrimState m) e
-> Int
-> Int
-> Int
-> v (PrimState m) e
-> m (v (PrimState m) e)
forall (m :: * -> *) (v :: * -> * -> *) e.
(PrimMonad m, MVector v e) =>
Comparison e
-> v (PrimState m) e
-> Int
-> Int
-> Int
-> v (PrimState m) e
-> m (v (PrimState m) e)
mergeLo else Comparison e
-> v (PrimState m) e
-> Int
-> Int
-> Int
-> v (PrimState m) e
-> m (v (PrimState m) e)
forall (m :: * -> *) (v :: * -> * -> *) e.
(PrimMonad m, MVector v e) =>
Comparison e
-> v (PrimState m) e
-> Int
-> Int
-> Int
-> v (PrimState m) e
-> m (v (PrimState m) e)
mergeHi) Comparison e
cmp v (PrimState m) e
vec Int
l' Int
m Int
u' v (PrimState m) e
tmpBuf
 where
 gt :: e -> e -> Bool
gt  e
a e
b = Comparison e
cmp e
a e
b Ordering -> Ordering -> Bool
forall a. Eq a => a -> a -> Bool
== Ordering
GT
 gte :: e -> e -> Bool
gte e
a e
b = Comparison e
cmp e
a e
b Ordering -> Ordering -> Bool
forall a. Eq a => a -> a -> Bool
/= Ordering
LT
{-# INLINE merge #-}