{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE UnboxedTuples #-}

-- |
-- Copyright: (c) 2024 Soumik Sarkar
-- License: BSD-3-Clause
--
-- A stable adaptive mergesort implementation.
--
-- The merging strategy used is "2-merge" as described by
--
-- * Sam Buss, Alexander Knop,
--   /\"Strategies for Stable Merge Sorting\"/,
--   2018,
--   https://arxiv.org/abs/1801.04641
--
module Data.SamSort
  ( sortArrayBy
  , sortIntArrayBy
  ) where

import Control.Monad (when)
import Data.Bits (finiteBitSize, countLeadingZeros, shiftR)

import GHC.ST (ST(..))
import GHC.Exts
  ( Int#
  , Int(..)
  , MutableArray#
  , MutableByteArray#
  , (*#)
  , copyMutableArray#
  , copyMutableByteArray#
  , newArray#
  , newByteArray#
  , readArray#
  , readIntArray#
  , writeArray#
  , writeIntArray#
  )

-- | \(O(n \log n)\). Sort a slice of a @MutableArray#@ using a comparison
-- function.
--
-- The comparison must form a total order, as required by the 'Ord' laws.
--
-- @offset@ and @length@ must be valid, i.e.
--
-- * @0 <= offset < array size@ .
-- * @0 <= length@ .
-- * @offset + length <= array size@ .
--
-- This function will inline to get the best performance out of statically
-- known comparison functions. To avoid code duplication, create a wrapping
-- definition and reuse it as necessary.
--
sortArrayBy
  :: (a -> a -> Ordering)  -- ^ comparison
  -> MutableArray# s a
  -> Int                   -- ^ offset
  -> Int                   -- ^ length
  -> ST s ()
sortArrayBy :: forall a s.
(a -> a -> Ordering) -> MutableArray# s a -> Int -> Int -> ST s ()
sortArrayBy a -> a -> Ordering
cmp =  -- Inline with 1 arg
  \MutableArray# s a
ma# !Int
off !Int
len -> (a -> a -> Ordering) -> MA s a -> Int -> Int -> ST s ()
forall a s. (a -> a -> Ordering) -> MA s a -> Int -> Int -> ST s ()
sortArrayBy' a -> a -> Ordering
cmp (MutableArray# s a -> MA s a
forall s a. MutableArray# s a -> MA s a
MA MutableArray# s a
ma#) Int
off Int
len
{-# INLINE sortArrayBy #-}

sortArrayBy'
  :: (a -> a -> Ordering)
  -> MA s a
  -> Int
  -> Int
  -> ST s ()
sortArrayBy' :: forall a s. (a -> a -> Ordering) -> MA s a -> Int -> Int -> ST s ()
sortArrayBy' a -> a -> Ordering
_ !MA s a
_ !Int
_ Int
len | Int
len Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
2 = () -> ST s ()
forall a. a -> ST s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
sortArrayBy' a -> a -> Ordering
cmp MA s a
ma Int
off Int
len = do
  -- See Note [Algorithm overview]

  !MA s a
swp <- Int -> a -> ST s (MA s a)
forall a s. Int -> a -> ST s (MA s a)
newA (Int
len Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`shiftR` Int
1) a
forall a. a
errorElement
  !MIA s
stk <- Int -> ST s (MIA s)
forall s. Int -> ST s (MIA s)
newI (Int -> Int
lg Int
len)

  let -- Merge [i1,i2) and [i2,i3)
      -- Precondition: i1 < i2 < i3
      merge :: Int -> Int -> Int -> ST s ()
merge !Int
i1 !Int
i2 !Int
i3
        | Int
i2Int -> Int -> Int
forall a. Num a => a -> a -> a
-Int
i1 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
i3Int -> Int -> Int
forall a. Num a => a -> a -> a
-Int
i2 = Int -> Int -> Int -> ST s ()
mergeCopyLeft1 Int
i1 Int
i2 Int
i3
        | Bool
otherwise = Int -> Int -> Int -> ST s ()
mergeCopyRight1 Int
i1 Int
i2 Int
i3

      mergeCopyLeft1 :: Int -> Int -> Int -> ST s ()
mergeCopyLeft1 !Int
i1 !Int
i2 !Int
i3 = do
        a
x0 <- MA s a -> Int -> ST s a
forall s a. MA s a -> Int -> ST s a
readA MA s a
ma Int
i1 -- See Note [First iteration]
        a
y <- MA s a -> Int -> ST s a
forall s a. MA s a -> Int -> ST s a
readA MA s a
ma Int
i2
        if a
y a -> a -> Bool
`lt` a
x0
        then Int -> Int -> Int -> ST s ()
mergeCopyLeft2 Int
i1 Int
i2 Int
i3
        else do
          let skip :: Int -> ST s ()
skip Int
i | Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
i2 = () -> ST s ()
forall a. a -> ST s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
              skip Int
i = do
                a
x <- MA s a -> Int -> ST s a
forall s a. MA s a -> Int -> ST s a
readA MA s a
ma Int
i
                if a
y a -> a -> Bool
`lt` a
x
                then Int -> Int -> Int -> ST s ()
mergeCopyLeft2 Int
i Int
i2 Int
i3
                else Int -> ST s ()
skip (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)
          Int -> ST s ()
skip (Int
i1Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)

      -- Precondition: i1 < i2 < i3, (ma!i2) `lt` (ma!i1)
      mergeCopyLeft2 :: Int -> Int -> Int -> ST s ()
mergeCopyLeft2 !Int
i1 !Int
i2 !Int
i3 = do
        MA s a -> Int -> MA s a -> Int -> Int -> ST s ()
forall s a. MA s a -> Int -> MA s a -> Int -> Int -> ST s ()
copyA MA s a
ma Int
i1 MA s a
swp Int
0 (Int
i2Int -> Int -> Int
forall a. Num a => a -> a -> a
-Int
i1)
        MA s a -> Int -> ST s a
forall s a. MA s a -> Int -> ST s a
readA MA s a
ma Int
i2 ST s a -> (a -> ST s ()) -> ST s ()
forall a b. ST s a -> (a -> ST s b) -> ST s b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= MA s a -> Int -> a -> ST s ()
forall s a. MA s a -> Int -> a -> ST s ()
writeA MA s a
ma Int
i1
        if Int
i2Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
i3
        then Int -> Int -> Int -> ST s ()
loop Int
0 (Int
i2Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) (Int
i1Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)
        else MA s a -> Int -> MA s a -> Int -> Int -> ST s ()
forall s a. MA s a -> Int -> MA s a -> Int -> Int -> ST s ()
copyA MA s a
swp Int
0 MA s a
ma (Int
i1Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) Int
len1
        where
          !len1 :: Int
len1 = Int
i2Int -> Int -> Int
forall a. Num a => a -> a -> a
-Int
i1
          loop :: Int -> Int -> Int -> ST s ()
loop !Int
h !Int
j !Int
k = do
            a
x <- MA s a -> Int -> ST s a
forall s a. MA s a -> Int -> ST s a
readA MA s a
swp Int
h
            a
y0 <- MA s a -> Int -> ST s a
forall s a. MA s a -> Int -> ST s a
readA MA s a
ma Int
j -- See Note [First iteration]
            let nxt :: Int -> Int -> ST s ()
nxt !Int
j1 !Int
k1 = do
                  MA s a -> Int -> a -> ST s ()
forall s a. MA s a -> Int -> a -> ST s ()
writeA MA s a
ma Int
k1 a
x
                  Bool -> ST s () -> ST s ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
hInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
len1) (ST s () -> ST s ()) -> ST s () -> ST s ()
forall a b. (a -> b) -> a -> b
$
                    Int -> Int -> Int -> ST s ()
loop (Int
hInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) Int
j1 (Int
k1Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)
            if a
y0 a -> a -> Bool
`lt` a
x
            then do
              let loop2 :: Int -> Int -> ST s ()
loop2 Int
j1 !Int
k1 | Int
j1 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
i3 = MA s a -> Int -> MA s a -> Int -> Int -> ST s ()
forall s a. MA s a -> Int -> MA s a -> Int -> Int -> ST s ()
copyA MA s a
swp Int
h MA s a
ma Int
k1 (Int
len1Int -> Int -> Int
forall a. Num a => a -> a -> a
-Int
h)
                  loop2 Int
j1 Int
k1 = do
                    a
y <- MA s a -> Int -> ST s a
forall s a. MA s a -> Int -> ST s a
readA MA s a
ma Int
j1
                    if a
y a -> a -> Bool
`lt` a
x
                    then do
                      MA s a -> Int -> a -> ST s ()
forall s a. MA s a -> Int -> a -> ST s ()
writeA MA s a
ma Int
k1 a
y
                      Int -> Int -> ST s ()
loop2 (Int
j1Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) (Int
k1Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)
                    else
                      Int -> Int -> ST s ()
nxt Int
j1 Int
k1
              MA s a -> Int -> a -> ST s ()
forall s a. MA s a -> Int -> a -> ST s ()
writeA MA s a
ma Int
k a
y0
              Int -> Int -> ST s ()
loop2 (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)
            else
              Int -> Int -> ST s ()
nxt Int
j Int
k

      mergeCopyRight1 :: Int -> Int -> Int -> ST s ()
mergeCopyRight1 !Int
i1 !Int
i2 !Int
i3 = do
        a
x <- MA s a -> Int -> ST s a
forall s a. MA s a -> Int -> ST s a
readA MA s a
ma (Int
i2Int -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)
        a
y0 <- MA s a -> Int -> ST s a
forall s a. MA s a -> Int -> ST s a
readA MA s a
ma (Int
i3Int -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) -- See Note [First iteration]
        if a
y0 a -> a -> Bool
`lt` a
x
        then Int -> Int -> Int -> ST s ()
mergeCopyRight2 Int
i1 Int
i2 Int
i3
        else do
          let skip :: Int -> ST s ()
skip Int
j | Int
j Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
i2 = () -> ST s ()
forall a. a -> ST s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
              skip Int
j = do
                a
y <- MA s a -> Int -> ST s a
forall s a. MA s a -> Int -> ST s a
readA MA s a
ma Int
j
                if a
y a -> a -> Bool
`lt` a
x
                then Int -> Int -> Int -> ST s ()
mergeCopyRight2 Int
i1 Int
i2 (Int
jInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)
                else Int -> ST s ()
skip (Int
jInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)
          Int -> ST s ()
skip (Int
i3Int -> Int -> Int
forall a. Num a => a -> a -> a
-Int
2)

      -- Precondition: i1 < i2 < i3, (ma!(i3-1)) `lt` (ma!(i2-1))
      mergeCopyRight2 :: Int -> Int -> Int -> ST s ()
mergeCopyRight2 !Int
i1 !Int
i2 !Int
i3 = do
        MA s a -> Int -> MA s a -> Int -> Int -> ST s ()
forall s a. MA s a -> Int -> MA s a -> Int -> Int -> ST s ()
copyA MA s a
ma Int
i2 MA s a
swp Int
0 (Int
i3Int -> Int -> Int
forall a. Num a => a -> a -> a
-Int
i2)
        MA s a -> Int -> ST s a
forall s a. MA s a -> Int -> ST s a
readA MA s a
ma (Int
i2Int -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) ST s a -> (a -> ST s ()) -> ST s ()
forall a b. ST s a -> (a -> ST s b) -> ST s b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= MA s a -> Int -> a -> ST s ()
forall s a. MA s a -> Int -> a -> ST s ()
writeA MA s a
ma (Int
i3Int -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)
        if Int
i2Int -> Int -> Int
forall a. Num a => a -> a -> a
-Int
2 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
i1
        then Int -> Int -> Int -> ST s ()
loop (Int
i2Int -> Int -> Int
forall a. Num a => a -> a -> a
-Int
2) (Int
i3Int -> Int -> Int
forall a. Num a => a -> a -> a
-Int
i2Int -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) (Int
i3Int -> Int -> Int
forall a. Num a => a -> a -> a
-Int
2)
        else MA s a -> Int -> MA s a -> Int -> Int -> ST s ()
forall s a. MA s a -> Int -> MA s a -> Int -> Int -> ST s ()
copyA MA s a
swp Int
0 MA s a
ma Int
i1 (Int
i3Int -> Int -> Int
forall a. Num a => a -> a -> a
-Int
i2)
        where
          loop :: Int -> Int -> Int -> ST s ()
loop !Int
h !Int
j !Int
k = do
            a
x0 <- MA s a -> Int -> ST s a
forall s a. MA s a -> Int -> ST s a
readA MA s a
ma Int
h -- See Note [First iteration]
            a
y <- MA s a -> Int -> ST s a
forall s a. MA s a -> Int -> ST s a
readA MA s a
swp Int
j
            let nxt :: Int -> Int -> ST s ()
nxt !Int
h1 !Int
k1 = do
                  MA s a -> Int -> a -> ST s ()
forall s a. MA s a -> Int -> a -> ST s ()
writeA MA s a
ma Int
k1 a
y
                  Bool -> ST s () -> ST s ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
j Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0) (ST s () -> ST s ()) -> ST s () -> ST s ()
forall a b. (a -> b) -> a -> b
$
                    Int -> Int -> Int -> ST s ()
loop Int
h1 (Int
jInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) (Int
k1Int -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)
            if a
y a -> a -> Bool
`lt` a
x0
            then do
              let loop2 :: Int -> Int -> ST s ()
loop2 Int
h1 !Int
_ | Int
h1 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
i1 = MA s a -> Int -> MA s a -> Int -> Int -> ST s ()
forall s a. MA s a -> Int -> MA s a -> Int -> Int -> ST s ()
copyA MA s a
swp Int
0 MA s a
ma Int
i1 (Int
jInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)
                  loop2 Int
h1 Int
k1 = do
                    a
x <- MA s a -> Int -> ST s a
forall s a. MA s a -> Int -> ST s a
readA MA s a
ma Int
h1
                    if a
y a -> a -> Bool
`lt` a
x
                    then do
                      MA s a -> Int -> a -> ST s ()
forall s a. MA s a -> Int -> a -> ST s ()
writeA MA s a
ma Int
k1 a
x
                      Int -> Int -> ST s ()
loop2 (Int
h1Int -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) (Int
k1Int -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)
                    else
                      Int -> Int -> ST s ()
nxt Int
h1 Int
k1
              MA s a -> Int -> a -> ST s ()
forall s a. MA s a -> Int -> a -> ST s ()
writeA MA s a
ma Int
k a
x0
              Int -> Int -> ST s ()
loop2 (Int
hInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) (Int
kInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)
            else
              Int -> Int -> ST s ()
nxt Int
h Int
k

  (Int -> Int -> Int -> ST s ())
-> (Int -> ST s Int) -> MIA s -> Int -> Int -> ST s ()
forall s.
(Int -> Int -> Int -> ST s ())
-> (Int -> ST s Int) -> MIA s -> Int -> Int -> ST s ()
mergeStrategy Int -> Int -> Int -> ST s ()
merge Int -> ST s Int
getRun MIA s
stk Int
off Int
end

  where
    lt :: a -> a -> Bool
lt a
x a
y = case a -> a -> Ordering
cmp a
x a
y of Ordering
LT -> Bool
True; Ordering
_ -> Bool
False
    {-# INLINE lt #-}
    -- Note: Use lt instead of gt. Why? Because `compare` for types like Int and
    -- Word are defined in a way that needs one `<` op for LT but two (`<`,`==`)
    -- for GT.

    !end :: Int
end = Int
off Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
len

    getRun :: Int -> ST s Int
getRun = (a -> a -> Bool)
-> (Int -> ST s a)
-> (Int -> a -> ST s ())
-> (Int -> Int -> ST s ())
-> Int
-> Int
-> ST s Int
forall a s.
(a -> a -> Bool)
-> (Int -> ST s a)
-> (Int -> a -> ST s ())
-> (Int -> Int -> ST s ())
-> Int
-> Int
-> ST s Int
mkGetRun a -> a -> Bool
lt (MA s a -> Int -> ST s a
forall s a. MA s a -> Int -> ST s a
readA MA s a
ma) (MA s a -> Int -> a -> ST s ()
forall s a. MA s a -> Int -> a -> ST s ()
writeA MA s a
ma) (MA s a -> Int -> Int -> ST s ()
forall s a. MA s a -> Int -> Int -> ST s ()
reverseA MA s a
ma) Int
end
{-# INLINE sortArrayBy' #-}

-- | \(O(n \log n)\). Sort a slice of a @MutableByteArray#@ interpreted as an
-- array of @Int#@s using a comparison function.
--
-- The comparison must form a total order, as required by the 'Ord' laws.
--
-- @offset@ and @length@ must be valid, i.e.
--
-- * @0 <= offset < array size@ .
-- * @0 <= length@ .
-- * @offset + length <= array size@ .
--
-- This function will inline to get the best performance out of statically
-- known comparison functions. To avoid code duplication, create a wrapping
-- definition and reuse it as necessary.
--
sortIntArrayBy
  :: (Int -> Int -> Ordering)  -- ^ comparison
  -> MutableByteArray# s
  -> Int                       -- ^ offset in @Int#@s
  -> Int                       -- ^ length in @Int#@s
  -> ST s ()
sortIntArrayBy :: forall s.
(Int -> Int -> Ordering)
-> MutableByteArray# s -> Int -> Int -> ST s ()
sortIntArrayBy Int -> Int -> Ordering
cmp =  -- Inline with 1 arg
  \MutableByteArray# s
ma# !Int
off !Int
len -> (Int -> Int -> Ordering) -> MIA s -> Int -> Int -> ST s ()
forall s.
(Int -> Int -> Ordering) -> MIA s -> Int -> Int -> ST s ()
sortIntArrayBy' Int -> Int -> Ordering
cmp (MutableByteArray# s -> MIA s
forall s. MutableByteArray# s -> MIA s
MIA MutableByteArray# s
ma#) Int
off Int
len
{-# INLINE sortIntArrayBy #-}

sortIntArrayBy'
  :: (Int -> Int -> Ordering)
  -> MIA s
  -> Int
  -> Int
  -> ST s ()
sortIntArrayBy' :: forall s.
(Int -> Int -> Ordering) -> MIA s -> Int -> Int -> ST s ()
sortIntArrayBy' Int -> Int -> Ordering
_ !MIA s
_ !Int
_ Int
len | Int
len Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
2 = () -> ST s ()
forall a. a -> ST s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
sortIntArrayBy' Int -> Int -> Ordering
cmp MIA s
ma Int
off Int
len = do
  -- See Note [Algorithm overview]

  !MIA s
swp <- Int -> ST s (MIA s)
forall s. Int -> ST s (MIA s)
newI (Int
len Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`shiftR` Int
1)
  !MIA s
stk <- Int -> ST s (MIA s)
forall s. Int -> ST s (MIA s)
newI (Int -> Int
lg Int
len)

  let -- Merge [i1,i2) and [i2,i3)
      -- Precondition: i1 < i2 < i3
      merge :: Int -> Int -> Int -> ST s ()
merge !Int
i1 !Int
i2 !Int
i3
        | Int
i2Int -> Int -> Int
forall a. Num a => a -> a -> a
-Int
i1 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
i3Int -> Int -> Int
forall a. Num a => a -> a -> a
-Int
i2 = Int -> Int -> Int -> ST s ()
mergeCopyLeft1 Int
i1 Int
i2 Int
i3
        | Bool
otherwise = Int -> Int -> Int -> ST s ()
mergeCopyRight1 Int
i1 Int
i2 Int
i3

      mergeCopyLeft1 :: Int -> Int -> Int -> ST s ()
mergeCopyLeft1 !Int
i1 !Int
i2 !Int
i3 = MIA s -> Int -> ST s Int
forall s. MIA s -> Int -> ST s Int
readI MIA s
ma Int
i2 ST s Int -> (Int -> ST s ()) -> ST s ()
forall a b. ST s a -> (a -> ST s b) -> ST s b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Int -> Int -> ST s ()
skip Int
i1
        where
          skip :: Int -> Int -> ST s ()
skip !Int
i !Int
y = do
            Int
x <- MIA s -> Int -> ST s Int
forall s. MIA s -> Int -> ST s Int
readI MIA s
ma Int
i
            if Int
y Int -> Int -> Bool
`lt` Int
x
            then Int -> Int -> Int -> ST s ()
mergeCopyLeft2 Int
i Int
i2 Int
i3
            else
              Bool -> ST s () -> ST s ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
i2) (ST s () -> ST s ()) -> ST s () -> ST s ()
forall a b. (a -> b) -> a -> b
$
                Int -> Int -> ST s ()
skip (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) Int
y

      -- Precondition: i1 < i2 < i3, (ma!i2) `lt` (ma!i1)
      mergeCopyLeft2 :: Int -> Int -> Int -> ST s ()
mergeCopyLeft2 !Int
i1 !Int
i2 !Int
i3 = do
        MIA s -> Int -> MIA s -> Int -> Int -> ST s ()
forall s. MIA s -> Int -> MIA s -> Int -> Int -> ST s ()
copyI MIA s
ma Int
i1 MIA s
swp Int
0 (Int
i2Int -> Int -> Int
forall a. Num a => a -> a -> a
-Int
i1)
        MIA s -> Int -> ST s Int
forall s. MIA s -> Int -> ST s Int
readI MIA s
ma Int
i2 ST s Int -> (Int -> ST s ()) -> ST s ()
forall a b. ST s a -> (a -> ST s b) -> ST s b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= MIA s -> Int -> Int -> ST s ()
forall s. MIA s -> Int -> Int -> ST s ()
writeI MIA s
ma Int
i1
        if Int
i2Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
i3
        then Int -> Int -> Int -> ST s ()
loop Int
0 (Int
i2Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) (Int
i1Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)
        else MIA s -> Int -> MIA s -> Int -> Int -> ST s ()
forall s. MIA s -> Int -> MIA s -> Int -> Int -> ST s ()
copyI MIA s
swp Int
0 MIA s
ma (Int
i1Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) Int
len1
        where
          !len1 :: Int
len1 = Int
i2Int -> Int -> Int
forall a. Num a => a -> a -> a
-Int
i1
          loop :: Int -> Int -> Int -> ST s ()
loop !Int
h !Int
j !Int
k = MIA s -> Int -> ST s Int
forall s. MIA s -> Int -> ST s Int
readI MIA s
swp Int
h ST s Int -> (Int -> ST s ()) -> ST s ()
forall a b. ST s a -> (a -> ST s b) -> ST s b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Int -> Int -> Int -> Int -> ST s ()
loop2 Int
j Int
k Int
h
          loop2 :: Int -> Int -> Int -> Int -> ST s ()
loop2 Int
j1 !Int
k1 !Int
h !Int
_ | Int
j1 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
i3 = MIA s -> Int -> MIA s -> Int -> Int -> ST s ()
forall s. MIA s -> Int -> MIA s -> Int -> Int -> ST s ()
copyI MIA s
swp Int
h MIA s
ma Int
k1 (Int
len1Int -> Int -> Int
forall a. Num a => a -> a -> a
-Int
h)
          loop2 Int
j1 Int
k1 Int
h Int
x = do
            Int
y <- MIA s -> Int -> ST s Int
forall s. MIA s -> Int -> ST s Int
readI MIA s
ma Int
j1
            if Int
y Int -> Int -> Bool
`lt` Int
x
            then do
              MIA s -> Int -> Int -> ST s ()
forall s. MIA s -> Int -> Int -> ST s ()
writeI MIA s
ma Int
k1 Int
y
              Int -> Int -> Int -> Int -> ST s ()
loop2 (Int
j1Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) (Int
k1Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) Int
h Int
x
            else do
              MIA s -> Int -> Int -> ST s ()
forall s. MIA s -> Int -> Int -> ST s ()
writeI MIA s
ma Int
k1 Int
x
              Bool -> ST s () -> ST s ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
hInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
len1) (ST s () -> ST s ()) -> ST s () -> ST s ()
forall a b. (a -> b) -> a -> b
$
                Int -> Int -> Int -> ST s ()
loop (Int
hInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) Int
j1 (Int
k1Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)

      mergeCopyRight1 :: Int -> Int -> Int -> ST s ()
mergeCopyRight1 !Int
i1 !Int
i2 !Int
i3 = MIA s -> Int -> ST s Int
forall s. MIA s -> Int -> ST s Int
readI MIA s
ma (Int
i2Int -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) ST s Int -> (Int -> ST s ()) -> ST s ()
forall a b. ST s a -> (a -> ST s b) -> ST s b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Int -> Int -> ST s ()
skip (Int
i3Int -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)
        where
          skip :: Int -> Int -> ST s ()
skip !Int
j !Int
x = do
            Int
y <- MIA s -> Int -> ST s Int
forall s. MIA s -> Int -> ST s Int
readI MIA s
ma Int
j
            if Int
y Int -> Int -> Bool
`lt` Int
x
            then Int -> Int -> Int -> ST s ()
mergeCopyRight2 Int
i1 Int
i2 (Int
jInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)
            else
              Bool -> ST s () -> ST s ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
j Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
i2) (ST s () -> ST s ()) -> ST s () -> ST s ()
forall a b. (a -> b) -> a -> b
$
                Int -> Int -> ST s ()
skip (Int
jInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) Int
x

      -- Precondition: i1 < i2 < i3, (ma!(i3-1)) `lt` (ma!(i2-1))
      mergeCopyRight2 :: Int -> Int -> Int -> ST s ()
mergeCopyRight2 !Int
i1 !Int
i2 !Int
i3 = do
        MIA s -> Int -> MIA s -> Int -> Int -> ST s ()
forall s. MIA s -> Int -> MIA s -> Int -> Int -> ST s ()
copyI MIA s
ma Int
i2 MIA s
swp Int
0 (Int
i3Int -> Int -> Int
forall a. Num a => a -> a -> a
-Int
i2)
        MIA s -> Int -> ST s Int
forall s. MIA s -> Int -> ST s Int
readI MIA s
ma (Int
i2Int -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) ST s Int -> (Int -> ST s ()) -> ST s ()
forall a b. ST s a -> (a -> ST s b) -> ST s b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= MIA s -> Int -> Int -> ST s ()
forall s. MIA s -> Int -> Int -> ST s ()
writeI MIA s
ma (Int
i3Int -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)
        if Int
i2Int -> Int -> Int
forall a. Num a => a -> a -> a
-Int
2 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
i1
        then Int -> Int -> Int -> ST s ()
loop (Int
i2Int -> Int -> Int
forall a. Num a => a -> a -> a
-Int
2) (Int
i3Int -> Int -> Int
forall a. Num a => a -> a -> a
-Int
i2Int -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) (Int
i3Int -> Int -> Int
forall a. Num a => a -> a -> a
-Int
2)
        else MIA s -> Int -> MIA s -> Int -> Int -> ST s ()
forall s. MIA s -> Int -> MIA s -> Int -> Int -> ST s ()
copyI MIA s
swp Int
0 MIA s
ma Int
i1 (Int
i3Int -> Int -> Int
forall a. Num a => a -> a -> a
-Int
i2)
        where
          loop :: Int -> Int -> Int -> ST s ()
loop !Int
h !Int
j !Int
k = MIA s -> Int -> ST s Int
forall s. MIA s -> Int -> ST s Int
readI MIA s
swp Int
j ST s Int -> (Int -> ST s ()) -> ST s ()
forall a b. ST s a -> (a -> ST s b) -> ST s b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Int -> Int -> Int -> Int -> ST s ()
loop2 Int
h Int
k Int
j
          loop2 :: Int -> Int -> Int -> Int -> ST s ()
loop2 Int
h1 !Int
_ !Int
j !Int
_ | Int
h1 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
i1 = MIA s -> Int -> MIA s -> Int -> Int -> ST s ()
forall s. MIA s -> Int -> MIA s -> Int -> Int -> ST s ()
copyI MIA s
swp Int
0 MIA s
ma Int
i1 (Int
jInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)
          loop2 Int
h1 Int
k1 Int
j Int
y = do
            Int
x <- MIA s -> Int -> ST s Int
forall s. MIA s -> Int -> ST s Int
readI MIA s
ma Int
h1
            if Int
y Int -> Int -> Bool
`lt` Int
x
            then do
              MIA s -> Int -> Int -> ST s ()
forall s. MIA s -> Int -> Int -> ST s ()
writeI MIA s
ma Int
k1 Int
x
              Int -> Int -> Int -> Int -> ST s ()
loop2 (Int
h1Int -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) (Int
k1Int -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) Int
j Int
y
            else do
              MIA s -> Int -> Int -> ST s ()
forall s. MIA s -> Int -> Int -> ST s ()
writeI MIA s
ma Int
k1 Int
y
              Bool -> ST s () -> ST s ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
j Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0) (ST s () -> ST s ()) -> ST s () -> ST s ()
forall a b. (a -> b) -> a -> b
$
                Int -> Int -> Int -> ST s ()
loop Int
h1 (Int
jInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) (Int
k1Int -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)

  (Int -> Int -> Int -> ST s ())
-> (Int -> ST s Int) -> MIA s -> Int -> Int -> ST s ()
forall s.
(Int -> Int -> Int -> ST s ())
-> (Int -> ST s Int) -> MIA s -> Int -> Int -> ST s ()
mergeStrategy Int -> Int -> Int -> ST s ()
merge Int -> ST s Int
getRun MIA s
stk Int
off Int
end

  where
    lt :: Int -> Int -> Bool
lt !Int
x !Int
y = case Int -> Int -> Ordering
cmp Int
x Int
y of Ordering
LT -> Bool
True; Ordering
_ -> Bool
False
    {-# INLINE lt #-}
    -- Note: Use lt instead of gt. Why? Because `compare` for types like Int and
    -- Word are defined in a way that needs one `<` op for LT but two (`<`,`==`)
    -- for GT.

    !end :: Int
end = Int
off Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
len

    getRun :: Int -> ST s Int
getRun = (Int -> Int -> Bool)
-> (Int -> ST s Int)
-> (Int -> Int -> ST s ())
-> (Int -> Int -> ST s ())
-> Int
-> Int
-> ST s Int
forall a s.
(a -> a -> Bool)
-> (Int -> ST s a)
-> (Int -> a -> ST s ())
-> (Int -> Int -> ST s ())
-> Int
-> Int
-> ST s Int
mkGetRun Int -> Int -> Bool
lt (MIA s -> Int -> ST s Int
forall s. MIA s -> Int -> ST s Int
readI MIA s
ma) (MIA s -> Int -> Int -> ST s ()
forall s. MIA s -> Int -> Int -> ST s ()
writeI MIA s
ma) (MIA s -> Int -> Int -> ST s ()
forall s. MIA s -> Int -> Int -> ST s ()
reverseI MIA s
ma) Int
end
{-# INLINE sortIntArrayBy' #-}

mkGetRun
  :: (a -> a -> Bool)        -- comparison
  -> (Int -> ST s a)         -- read
  -> (Int -> a -> ST s ())   -- write
  -> (Int -> Int -> ST s ()) -- reverse
  -> Int                     -- end
  -> (Int -> ST s Int)
mkGetRun :: forall a s.
(a -> a -> Bool)
-> (Int -> ST s a)
-> (Int -> a -> ST s ())
-> (Int -> Int -> ST s ())
-> Int
-> Int
-> ST s Int
mkGetRun a -> a -> Bool
lt Int -> ST s a
rd Int -> a -> ST s ()
wt Int -> Int -> ST s ()
rev !Int
end = Int -> ST s Int
getRun
  where
    runAsc :: Int -> ST s Int
runAsc Int
i | Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
end = Int -> ST s Int
forall a. a -> ST s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
i
    runAsc Int
i = do
      a
x <- Int -> ST s a
rd (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)
      a
y <- Int -> ST s a
rd Int
i
      if a
y a -> a -> Bool
`lt` a
x
      then Int -> ST s Int
forall a. a -> ST s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
i
      else Int -> ST s Int
runAsc (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)

    runDesc :: Int -> ST s Int
runDesc Int
i | Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
end = Int -> ST s Int
forall a. a -> ST s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
i
    runDesc Int
i = do
      a
x <- Int -> ST s a
rd (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)
      a
y <- Int -> ST s a
rd Int
i
      if a
y a -> a -> Bool
`lt` a
x
      then Int -> ST s Int
runDesc (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)
      else Int -> ST s Int
forall a. a -> ST s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
i

    -- Insertion sort [i2,i3) into [i1,i3)
    -- Precondition: i1 < i2, i1 < i3
    insLoop :: Int -> Int -> Int -> ST s Int
insLoop !Int
_ Int
i2 Int
i3 | Int
i2 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
i3 = Int -> ST s Int
forall a. a -> ST s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
i2
    insLoop Int
i1 Int
i2 Int
i3 = do
      a
x0 <- Int -> ST s a
rd (Int
i2Int -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)
      a
y <- Int -> ST s a
rd Int
i2
      Bool -> ST s () -> ST s ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (a
y a -> a -> Bool
`lt` a
x0) (ST s () -> ST s ()) -> ST s () -> ST s ()
forall a b. (a -> b) -> a -> b
$ do
        let ins :: Int -> ST s ()
ins Int
j | Int
j Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
i1 = Int -> a -> ST s ()
wt Int
j a
y
            ins Int
j = do
              a
x <- Int -> ST s a
rd (Int
jInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)
              if a
y a -> a -> Bool
`lt` a
x
              then Int -> a -> ST s ()
wt Int
j a
x ST s () -> ST s () -> ST s ()
forall a b. ST s a -> ST s b -> ST s b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Int -> ST s ()
ins (Int
jInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)
              else Int -> a -> ST s ()
wt Int
j a
y
        Int -> a -> ST s ()
wt Int
i2 a
x0 ST s () -> ST s () -> ST s ()
forall a b. ST s a -> ST s b -> ST s b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Int -> ST s ()
ins (Int
i2Int -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)
      Int -> Int -> Int -> ST s Int
insLoop Int
i1 (Int
i2Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) Int
i3

    getRun :: Int -> ST s Int
getRun Int
i | Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
end Bool -> Bool -> Bool
|| Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
end = Int -> ST s Int
forall a. a -> ST s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
end
    getRun Int
i = do
      a
x <- Int -> ST s a
rd Int
i
      a
y <- Int -> ST s a
rd (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)
      !Int
j <- if a
y a -> a -> Bool
`lt` a
x
        then do
          Int
j <- Int -> ST s Int
runDesc (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
2)
          Int
j Int -> ST s () -> ST s Int
forall a b. a -> ST s b -> ST s a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Int -> Int -> ST s ()
rev Int
i (Int
jInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)
        else Int -> ST s Int
runAsc (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
2)
      let k :: Int
k = Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
minRunLen
          k' :: Int
k' = if Int
k Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0 -- overflowed
               then Int
end
               else Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
end Int
k
      Int -> Int -> Int -> ST s Int
insLoop Int
i Int
j Int
k'
{-# INLINE mkGetRun #-}

minRunLen :: Int
minRunLen :: Int
minRunLen = Int
8

mergeStrategy
  :: (Int -> Int -> Int -> ST s ()) -- merge
  -> (Int -> ST s Int)              -- get next run
  -> MIA s                          -- stack
  -> Int                            -- offset
  -> Int                            -- end
  -> ST s ()
mergeStrategy :: forall s.
(Int -> Int -> Int -> ST s ())
-> (Int -> ST s Int) -> MIA s -> Int -> Int -> ST s ()
mergeStrategy Int -> Int -> Int -> ST s ()
merge Int -> ST s Int
getRun !MIA s
stk !Int
off !Int
end = Int -> ST s Int
getRun Int
off ST s Int -> (Int -> ST s ()) -> ST s ()
forall a b. ST s a -> (a -> ST s b) -> ST s b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Int -> Int -> Int -> ST s ()
mergeRuns (-Int
1) Int
off
  where
    -- [i,j) is the last run. Runs before it are on the stack.
    mergeRuns :: Int -> Int -> Int -> ST s ()
mergeRuns !Int
top !Int
i Int
j
      | Int
j Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
end = Int -> Int -> ST s ()
finish Int
top Int
i
      | Bool
otherwise = Int -> ST s Int
getRun Int
j ST s Int -> (Int -> ST s ()) -> ST s ()
forall a b. ST s a -> (a -> ST s b) -> ST s b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Int -> Int -> Int -> Int -> ST s ()
popPush Int
top Int
i Int
j

    -- Maintain stack invariants
    popPush :: Int -> Int -> Int -> Int -> ST s ()
popPush !Int
top !Int
i2 !Int
i3 !Int
i4
      | Bool -> Bool
not (Int -> Int -> Int -> Bool
badYZ Int
i2 Int
i3 Int
i4) = do
          MIA s -> Int -> Int -> ST s ()
forall s. MIA s -> Int -> Int -> ST s ()
writeI MIA s
stk (Int
topInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) Int
i2
          Int -> Int -> Int -> ST s ()
mergeRuns (Int
topInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) Int
i3 Int
i4
      | Int
top Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 = do
          Int -> Int -> Int -> ST s ()
merge Int
i2 Int
i3 Int
i4
          Int -> Int -> Int -> ST s ()
mergeRuns Int
top Int
i2 Int
i4
      | Bool
otherwise = do
          Int
i1 <- MIA s -> Int -> ST s Int
forall s. MIA s -> Int -> ST s Int
readI MIA s
stk Int
top
          if Int -> Int -> Int -> Int -> Bool
mergeWithLeft Int
i1 Int
i2 Int
i3 Int
i4
          then do
            Int -> Int -> Int -> ST s ()
merge Int
i1 Int
i2 Int
i3
            Int -> Int -> Int -> Int -> ST s ()
popPush (Int
topInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) Int
i1 Int
i3 Int
i4
          else do
            Int -> Int -> Int -> ST s ()
merge Int
i2 Int
i3 Int
i4
            Int -> Int -> Int -> Int -> ST s ()
popPush (Int
topInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) Int
i1 Int
i2 Int
i4

    finish :: Int -> Int -> ST s ()
finish Int
top !Int
_ | Int
top Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 = () -> ST s ()
forall a. a -> ST s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    finish Int
top Int
j = do
      Int
i <- MIA s -> Int -> ST s Int
forall s. MIA s -> Int -> ST s Int
readI MIA s
stk Int
top
      Int -> Int -> Int -> ST s ()
merge Int
i Int
j Int
end
      Int -> Int -> ST s ()
finish (Int
topInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) Int
i
{-# INLINE mergeStrategy #-}

badYZ :: Int -> Int -> Int -> Bool
badYZ :: Int -> Int -> Int -> Bool
badYZ Int
i1 Int
i2 Int
i3 = (Int
i2Int -> Int -> Int
forall a. Num a => a -> a -> a
-Int
i1) Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`shiftR` Int
1 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< (Int
i3Int -> Int -> Int
forall a. Num a => a -> a -> a
-Int
i2)
{-# INLINE badYZ #-}

mergeWithLeft :: Int -> Int -> Int -> Int -> Bool
mergeWithLeft :: Int -> Int -> Int -> Int -> Bool
mergeWithLeft Int
i1 Int
i2 Int
i3 Int
i4 = (Int
i2Int -> Int -> Int
forall a. Num a => a -> a -> a
-Int
i1) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< (Int
i4Int -> Int -> Int
forall a. Num a => a -> a -> a
-Int
i3)
{-# INLINE mergeWithLeft #-}

reverseA
  :: MA s a
  -> Int     -- ^ Start
  -> Int     -- ^ End (inclusive)
  -> ST s ()
reverseA :: forall s a. MA s a -> Int -> Int -> ST s ()
reverseA !MA s a
ma = Int -> Int -> ST s ()
loop
  where
    loop :: Int -> Int -> ST s ()
loop Int
i Int
j | Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
j = () -> ST s ()
forall a. a -> ST s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    loop Int
i Int
j = do
      a
x <- MA s a -> Int -> ST s a
forall s a. MA s a -> Int -> ST s a
readA MA s a
ma Int
i
      MA s a -> Int -> ST s a
forall s a. MA s a -> Int -> ST s a
readA MA s a
ma Int
j ST s a -> (a -> ST s ()) -> ST s ()
forall a b. ST s a -> (a -> ST s b) -> ST s b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= MA s a -> Int -> a -> ST s ()
forall s a. MA s a -> Int -> a -> ST s ()
writeA MA s a
ma Int
i
      MA s a -> Int -> a -> ST s ()
forall s a. MA s a -> Int -> a -> ST s ()
writeA MA s a
ma Int
j a
x
      Int -> Int -> ST s ()
loop (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) (Int
jInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)

reverseI
  :: MIA s
  -> Int     -- ^ Start
  -> Int     -- ^ End (inclusive)
  -> ST s ()
reverseI :: forall s. MIA s -> Int -> Int -> ST s ()
reverseI !MIA s
ma = Int -> Int -> ST s ()
loop
  where
    loop :: Int -> Int -> ST s ()
loop Int
i Int
j | Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
j = () -> ST s ()
forall a. a -> ST s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    loop Int
i Int
j = do
      Int
x <- MIA s -> Int -> ST s Int
forall s. MIA s -> Int -> ST s Int
readI MIA s
ma Int
i
      MIA s -> Int -> ST s Int
forall s. MIA s -> Int -> ST s Int
readI MIA s
ma Int
j ST s Int -> (Int -> ST s ()) -> ST s ()
forall a b. ST s a -> (a -> ST s b) -> ST s b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= MIA s -> Int -> Int -> ST s ()
forall s. MIA s -> Int -> Int -> ST s ()
writeI MIA s
ma Int
i
      MIA s -> Int -> Int -> ST s ()
forall s. MIA s -> Int -> Int -> ST s ()
writeI MIA s
ma Int
j Int
x
      Int -> Int -> ST s ()
loop (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) (Int
jInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)

lg :: Int -> Int
lg :: Int -> Int
lg Int
0 = Int
0
lg Int
i = Int -> Int
forall b. FiniteBits b => b -> Int
finiteBitSize Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int -> Int
forall b. FiniteBits b => b -> Int
countLeadingZeros Int
i
{-# INLINE lg #-}

errorElement :: a
errorElement :: forall a. a
errorElement = [Char] -> a
forall a. HasCallStack => [Char] -> a
error [Char]
"errorElement"

--------------------

-- The boxed wrappers MA, MIA, and functions operating on them are for the
-- convenience of working in ST. All of it should get optimized away.

data MA s a = MA (MutableArray# s a)

newA :: Int -> a -> ST s (MA s a)
newA :: forall a s. Int -> a -> ST s (MA s a)
newA (I# Int#
n#) a
x = STRep s (MA s a) -> ST s (MA s a)
forall s a. STRep s a -> ST s a
ST (STRep s (MA s a) -> ST s (MA s a))
-> STRep s (MA s a) -> ST s (MA s a)
forall a b. (a -> b) -> a -> b
$ \State# s
s ->
  case Int# -> a -> State# s -> (# State# s, MutableArray# s a #)
forall a d.
Int# -> a -> State# d -> (# State# d, MutableArray# d a #)
newArray# Int#
n# a
x State# s
s of (# State# s
s1, MutableArray# s a
ma# #) -> (# State# s
s1, MutableArray# s a -> MA s a
forall s a. MutableArray# s a -> MA s a
MA MutableArray# s a
ma# #)
{-# INLINE newA #-}

readA :: MA s a -> Int -> ST s a
readA :: forall s a. MA s a -> Int -> ST s a
readA (MA MutableArray# s a
ma#) (I# Int#
i#) = STRep s a -> ST s a
forall s a. STRep s a -> ST s a
ST (STRep s a -> ST s a) -> STRep s a -> ST s a
forall a b. (a -> b) -> a -> b
$ MutableArray# s a -> Int# -> STRep s a
forall d a.
MutableArray# d a -> Int# -> State# d -> (# State# d, a #)
readArray# MutableArray# s a
ma# Int#
i#
{-# INLINE readA #-}

writeA :: MA s a -> Int -> a -> ST s ()
writeA :: forall s a. MA s a -> Int -> a -> ST s ()
writeA (MA MutableArray# s a
ma#) (I# Int#
i#) a
x = STRep s () -> ST s ()
forall s a. STRep s a -> ST s a
ST (STRep s () -> ST s ()) -> STRep s () -> ST s ()
forall a b. (a -> b) -> a -> b
$ \State# s
s ->
  case MutableArray# s a -> Int# -> a -> State# s -> State# s
forall d a. MutableArray# d a -> Int# -> a -> State# d -> State# d
writeArray# MutableArray# s a
ma# Int#
i# a
x State# s
s of State# s
s1 -> (# State# s
s1, () #)
{-# INLINE writeA #-}

copyA :: MA s a -> Int -> MA s a -> Int -> Int -> ST s ()
copyA :: forall s a. MA s a -> Int -> MA s a -> Int -> Int -> ST s ()
copyA (MA MutableArray# s a
src#) (I# Int#
srcOff#) (MA MutableArray# s a
dst#) (I# Int#
dstOff#) (I# Int#
len#) = STRep s () -> ST s ()
forall s a. STRep s a -> ST s a
ST (STRep s () -> ST s ()) -> STRep s () -> ST s ()
forall a b. (a -> b) -> a -> b
$ \State# s
s ->
  case MutableArray# s a
-> Int#
-> MutableArray# s a
-> Int#
-> Int#
-> State# s
-> State# s
forall d a.
MutableArray# d a
-> Int#
-> MutableArray# d a
-> Int#
-> Int#
-> State# d
-> State# d
copyMutableArray# MutableArray# s a
src# Int#
srcOff# MutableArray# s a
dst# Int#
dstOff# Int#
len# State# s
s of State# s
s1 -> (# State# s
s1, () #)
{-# INLINE copyA #-}

data MIA s = MIA (MutableByteArray# s)

newI :: Int -> ST s (MIA s)
newI :: forall s. Int -> ST s (MIA s)
newI (I# Int#
n#) = STRep s (MIA s) -> ST s (MIA s)
forall s a. STRep s a -> ST s a
ST (STRep s (MIA s) -> ST s (MIA s))
-> STRep s (MIA s) -> ST s (MIA s)
forall a b. (a -> b) -> a -> b
$ \State# s
s ->
  case Int# -> State# s -> (# State# s, MutableByteArray# s #)
forall d. Int# -> State# d -> (# State# d, MutableByteArray# d #)
newByteArray# (Int#
n# Int# -> Int# -> Int#
*# (# #) -> Int#
intSize# (# #)) State# s
s of (# State# s
s1, MutableByteArray# s
ma# #) -> (# State# s
s1, MutableByteArray# s -> MIA s
forall s. MutableByteArray# s -> MIA s
MIA MutableByteArray# s
ma# #)
{-# INLINE newI #-}

readI :: MIA s -> Int -> ST s Int
readI :: forall s. MIA s -> Int -> ST s Int
readI (MIA MutableByteArray# s
ma#) (I# Int#
i#) = STRep s Int -> ST s Int
forall s a. STRep s a -> ST s a
ST (STRep s Int -> ST s Int) -> STRep s Int -> ST s Int
forall a b. (a -> b) -> a -> b
$ \State# s
s ->
  case MutableByteArray# s -> Int# -> State# s -> (# State# s, Int# #)
forall d.
MutableByteArray# d -> Int# -> State# d -> (# State# d, Int# #)
readIntArray# MutableByteArray# s
ma# Int#
i# State# s
s of (# State# s
s1, Int#
x# #) -> (# State# s
s1, Int# -> Int
I# Int#
x# #)
{-# INLINE readI #-}

writeI :: MIA s -> Int -> Int -> ST s ()
writeI :: forall s. MIA s -> Int -> Int -> ST s ()
writeI (MIA MutableByteArray# s
ma#) (I# Int#
i#) (I# Int#
x#) = STRep s () -> ST s ()
forall s a. STRep s a -> ST s a
ST (STRep s () -> ST s ()) -> STRep s () -> ST s ()
forall a b. (a -> b) -> a -> b
$ \State# s
s ->
  case MutableByteArray# s -> Int# -> Int# -> State# s -> State# s
forall d.
MutableByteArray# d -> Int# -> Int# -> State# d -> State# d
writeIntArray# MutableByteArray# s
ma# Int#
i# Int#
x# State# s
s of State# s
s1 -> (# State# s
s1, () #)
{-# INLINE writeI #-}

copyI :: MIA s -> Int -> MIA s -> Int -> Int -> ST s ()
copyI :: forall s. MIA s -> Int -> MIA s -> Int -> Int -> ST s ()
copyI (MIA MutableByteArray# s
src#) (I# Int#
srcOff#) (MIA MutableByteArray# s
dst#) (I# Int#
dstOff#) (I# Int#
len#) = STRep s () -> ST s ()
forall s a. STRep s a -> ST s a
ST (STRep s () -> ST s ()) -> STRep s () -> ST s ()
forall a b. (a -> b) -> a -> b
$ \State# s
s ->
  case MutableByteArray# s
-> Int#
-> MutableByteArray# s
-> Int#
-> Int#
-> State# s
-> State# s
forall d.
MutableByteArray# d
-> Int#
-> MutableByteArray# d
-> Int#
-> Int#
-> State# d
-> State# d
copyMutableByteArray#
         MutableByteArray# s
src#
         (Int#
srcOff# Int# -> Int# -> Int#
*# (# #) -> Int#
intSize# (# #))
         MutableByteArray# s
dst#
         (Int#
dstOff# Int# -> Int# -> Int#
*# (# #) -> Int#
intSize# (# #))
         (Int#
len# Int# -> Int# -> Int#
*# (# #) -> Int#
intSize# (# #))
         State# s
s of
    State# s
s1 -> (# State# s
s1, () #)
{-# INLINE copyI #-}

intSize# :: (# #) -> Int#
intSize# :: (# #) -> Int#
intSize# (# #)
_ = case Int -> Int
forall b. FiniteBits b => b -> Int
finiteBitSize (Int
0 :: Int) Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`shiftR` Int
3 of I# Int#
wsz# -> Int#
wsz#

--------------------

-- Note [Algorithm overview]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~
-- Find non-decreasing and decreasing runs. Decreasing runs are reversed in
-- place. If a run is shorter than minRunLen, extend it to minRunLen using
-- insertion sort. Maintain a stack of runs. As each run is found, add it to
-- the stack and maintain stack invariants according to the 2-merge strategy.
-- This involves merging adjacent runs. Merging two runs is done by copying the
-- smaller run to a swap array, then merging into the main array. Elements of
-- the smaller array that can stay in place are skipped and not copied. After
-- all runs are found, runs on the stack are merged to get the final sorted
-- array.

-- Note [First iteration]
-- ~~~~~~~~~~~~~~~~~~~~~~
-- In certain places, the first iteration of a loop is pulled out of the loop
-- when many elements need to be compared with one element. This is to make GHC
-- aware that if the comparison is strict, the one element can be evaluated and
-- perhaps unboxed for subsequent comparisons. This could also be achieved by
-- being strict in the element, but we want to allow the comparison function
-- to be potentially lazy.

-- Note [Integer overflows]
-- ~~~~~~~~~~~~~~~~~~~~~~~~
-- We (reasonably) assume that end=off+len fits in an Int.
-- If that holds, this implementation /should/ work without encountering any
-- bugs due to overflow. But it is unclear how that can be tested without too
-- much trouble.