```{-# 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).
--
--
-- 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 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
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
{-# 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
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
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
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
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
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
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
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
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
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
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
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
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
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
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
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
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
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
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 #-}
```