{-# LANGUAGE Safe #-}

{- |
    Module      :  SDP.SortM.Tim
    Copyright   :  (c) Andrey Mulik 2019
    License     :  BSD-style
    Maintainer  :  work.a.mulik@gmail.com
    Portability :  non-portable (requires non-portable modules)
    
    "SDP.SortM.Tim" provides @InsertionSort@ and @TimSort@ algorithms.
-}
module SDP.SortM.Tim
(
  -- * TimSort
  timSort, timSortBy, timSortOn, minrunTS
)
where

import Prelude ()
import SDP.SafePrelude
import SDP.IndexedM

import SDP.SortM.Insertion

import Data.Bits

default ()

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

-- | 'timSort' is just synonym for @'timSortBy' 'compare'@.
{-# INLINE timSort #-}
timSort :: (LinearM m v e, BorderedM m v i, Ord e) => v -> m ()
timSort :: v -> m ()
timSort =  Compare e -> v -> m ()
forall (m :: * -> *) v e i.
(LinearM m v e, BorderedM m v i) =>
Compare e -> v -> m ()
timSortBy Compare e
forall a. Ord a => a -> a -> Ordering
compare

{- |
  'timSortOn' is a version of 'timSortBy' that uses a conversion function to
  compare elements.
-}
{-# INLINE timSortOn #-}
timSortOn :: (LinearM m v e, BorderedM m v i, Ord o) => (e -> o) -> v -> m ()
timSortOn :: (e -> o) -> v -> m ()
timSortOn =  Compare e -> v -> m ()
forall (m :: * -> *) v e i.
(LinearM m v e, BorderedM m v i) =>
Compare e -> v -> m ()
timSortBy (Compare e -> v -> m ())
-> ((e -> o) -> Compare e) -> (e -> o) -> v -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (e -> o) -> Compare e
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing

{- |
  'timSortBy' is a sorting procedure for mutable random access data structures
  using any comparison function and having @O(nlogn)@ complexity in the worst
  case.
-}
{-# INLINE timSortBy #-}
timSortBy :: (LinearM m v e, BorderedM m v i) => Compare e -> v -> m ()
timSortBy :: Compare e -> v -> m ()
timSortBy Compare e
cmp v
es = Int -> m ()
forall (m :: * -> *). LinearM m v e => Int -> m ()
sort' (Int -> m ()) -> m Int -> m ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< v -> m Int
forall (m :: * -> *) b i. BorderedM m b i => b -> m Int
getSizeOf v
es
  where
    gt :: e -> e -> Bool
gt = \ e
x e
y -> case Compare e
cmp e
x e
y of {Ordering
GT -> Bool
True; Ordering
_ -> Bool
False}
    
    sort' :: Int -> m ()
sort' Int
n
      |  Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0  = () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
64 = Compare e -> v -> Int -> Int -> Int -> m ()
forall (m :: * -> *) v e.
LinearM m v e =>
Compare e -> v -> Int -> Int -> Int -> m ()
unsafeInsertionSort Compare e
cmp v
es Int
0 Int
0 (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
      |   Bool
True  = Int -> Int -> m [Int]
forall (m :: * -> *) t.
(Num t, Eq t, LinearM m v e) =>
t -> Int -> m [Int]
iteratePreN (Int
3 :: Int) Int
0 m [Int] -> ([Int] -> m ()) -> m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [Int] -> m ()
forall (m :: * -> *). LinearM m v e => [Int] -> m ()
go
        where
          go :: [Int] -> m ()
go [Int
sx, Int
sy, Int
sz] = do
            [Int]
nxt <- Int -> Int -> m [Int]
forall (m :: * -> *) t.
(Num t, Eq t, LinearM m v e) =>
t -> Int -> m [Int]
iteratePreN (Int
1 :: Int) (Int
sx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
sy Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
sz)
            if (Int
sx Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
sy Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
sz Bool -> Bool -> Bool
&& Int
sy Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
sz) Bool -> Bool -> Bool
|| Int
sz Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
sx
              then do Int -> Int -> Int -> m ()
forall (m :: * -> *). LinearM m v e => Int -> Int -> Int -> m ()
merge Int
sx Int
sy Int
sz; [Int] -> m ()
go ([Int
sx, Int
sy Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
sz] [Int] -> [Int] -> [Int]
forall l e. Linear l e => l -> l -> l
++ [Int]
nxt)
              else do Int -> Int -> Int -> m ()
forall (m :: * -> *). LinearM m v e => Int -> Int -> Int -> m ()
merge Int
0  Int
sx Int
sy; [Int] -> m ()
go ([Int
sx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
sy, Int
sz] [Int] -> [Int] -> [Int]
forall l e. Linear l e => l -> l -> l
++ [Int]
nxt)
          go [Int
sx, Int
sy] = Int -> Int -> Int -> m ()
forall (m :: * -> *). LinearM m v e => Int -> Int -> Int -> m ()
merge Int
0 Int
sx Int
sy
          go     [Int]
_    = () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
          
          iteratePreN :: t -> Int -> m [Int]
iteratePreN t
0 Int
_ = [Int] -> m [Int]
forall (m :: * -> *) a. Monad m => a -> m a
return []
          iteratePreN t
j Int
o = case Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
o of
              Int
0 -> [Int] -> m [Int]
forall (m :: * -> *) a. Monad m => a -> m a
return []
              Int
1 -> [Int] -> m [Int]
forall (m :: * -> *) a. Monad m => a -> m a
return [Int
1]
              Int
2 -> do
                e
e0 <- v
es v -> Int -> m e
forall (m :: * -> *) l e. LinearM m l e => l -> Int -> m e
!#> Int
o
                e
e1 <- v
es v -> Int -> m e
forall (m :: * -> *) l e. LinearM m l e => l -> Int -> m e
!#> Int
o Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
                Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (e
e0 e -> e -> Bool
`gt` e
e1) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ v -> Int -> Int -> m ()
forall (m :: * -> *) l e. LinearM m l e => l -> Int -> Int -> m ()
swapM v
es Int
o (Int
o Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
                [Int] -> m [Int]
forall (m :: * -> *) a. Monad m => a -> m a
return [Int
2]
              Int
_ -> do
                Int
end <- Int -> m Int
forall (m :: * -> *). LinearM m v e => Int -> m Int
normalized (Int -> m Int) -> m Int -> m Int
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< m Int
actual
                Int
end Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 Bool -> m [Int] -> m [Int] -> m [Int]
forall a. Bool -> a -> a -> a
? [Int] -> m [Int]
forall (m :: * -> *) a. Monad m => a -> m a
return [Int
end Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
o] (m [Int] -> m [Int]) -> m [Int] -> m [Int]
forall a b. (a -> b) -> a -> b
$ (Int
end Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
o Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
:) ([Int] -> [Int]) -> m [Int] -> m [Int]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> t -> Int -> m [Int]
iteratePreN (t
j t -> t -> t
forall a. Num a => a -> a -> a
- t
1) Int
end
            where
              actual :: m Int
actual = (v
es v -> Int -> m e
forall (m :: * -> *) l e. LinearM m l e => l -> Int -> m e
!#> Int
o) m e -> m e -> (e -> e -> m Int) -> m Int
forall (m :: * -> *) a b c.
Monad m =>
m a -> m b -> (a -> b -> m c) -> m c
>>=<< (v
es v -> Int -> m e
forall (m :: * -> *) l e. LinearM m l e => l -> Int -> m e
!#> Int
o Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) ((e -> e -> m Int) -> m Int) -> (e -> e -> m Int) -> m Int
forall a b. (a -> b) -> a -> b
$ \ e
e0 e
e1 ->
                  e
e0 e -> e -> Bool
`gt` e
e1 Bool -> m Int -> m Int -> m Int
forall a. Bool -> a -> a -> a
? e -> Int -> m Int
forall (m :: * -> *). LinearM m v e => e -> Int -> m Int
desc e
e1 (Int
o Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2) (m Int -> m Int) -> m Int -> m Int
forall a b. (a -> b) -> a -> b
$ e -> Int -> m Int
forall (m :: * -> *). LinearM m v e => e -> Int -> m Int
asc e
e1 (Int
o Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2)
                where
                  desc :: e -> Int -> m Int
desc e
p Int
i = do e
c <- v
es v -> Int -> m e
forall (m :: * -> *) l e. LinearM m l e => l -> Int -> m e
!#> Int
i; e
c e -> e -> Bool
`gt` e
p Bool -> m Int -> m Int -> m Int
forall a. Bool -> a -> a -> a
? Int -> Int -> m Int
forall (m :: * -> *) e. LinearM m v e => Int -> Int -> m Int
rev' Int
o Int
i (m Int -> m Int) -> m Int -> m Int
forall a b. (a -> b) -> a -> b
$ Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1 Bool -> m Int -> m Int -> m Int
forall a. Bool -> a -> a -> a
? e -> Int -> m Int
desc e
c (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) (m Int -> m Int) -> m Int -> m Int
forall a b. (a -> b) -> a -> b
$ Int -> Int -> m Int
forall (m :: * -> *) e. LinearM m v e => Int -> Int -> m Int
rev' Int
o (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
                  asc :: e -> Int -> m Int
asc  e
p Int
i = do e
c <- v
es v -> Int -> m e
forall (m :: * -> *) l e. LinearM m l e => l -> Int -> m e
!#> Int
i; e
p e -> e -> Bool
`gt` e
c Bool -> m Int -> m Int -> m Int
forall a. Bool -> a -> a -> a
? Int -> m Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
i (m Int -> m Int) -> m Int -> m Int
forall a b. (a -> b) -> a -> b
$ Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1 Bool -> m Int -> m Int -> m Int
forall a. Bool -> a -> a -> a
? e -> Int -> m Int
asc  e
c (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) (m Int -> m Int) -> m Int -> m Int
forall a b. (a -> b) -> a -> b
$ Int -> m Int
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
                  rev :: Int -> Int -> f ()
rev  Int
f Int
l = Bool -> f () -> f ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
f Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
l) (f () -> f ()) -> f () -> f ()
forall a b. (a -> b) -> a -> b
$ do v -> Int -> Int -> f ()
forall (m :: * -> *) l e. LinearM m l e => l -> Int -> Int -> m ()
swapM v
es Int
f Int
l; Int -> Int -> f ()
rev (Int
f Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) (Int
l Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
                  rev' :: Int -> Int -> m Int
rev' Int
f Int
l = do Int -> Int -> m ()
forall (f :: * -> *) e. LinearM f v e => Int -> Int -> f ()
rev Int
f (Int
l Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1); Int -> m Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
l
              
              normalized :: Int -> m Int
normalized Int
s = do
                let ex :: Int
ex = Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
n (Int
o Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int -> Int
minrunTS Int
n) -- minimal expected ending
                Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
ex Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
s) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ Compare e -> v -> Int -> Int -> Int -> m ()
forall (m :: * -> *) v e.
LinearM m v e =>
Compare e -> v -> Int -> Int -> Int -> m ()
unsafeInsertionSort Compare e
cmp v
es Int
o (Int
s Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) (Int
ex Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
                Int -> m Int
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
ex Int -> Int -> Int
forall a. Ord a => a -> a -> a
`max` Int
s)
    
    merge :: Int -> Int -> Int -> m ()
merge Int
o Int
sx Int
sy = v -> Int -> Int -> m v
forall (m :: * -> *) l e. LinearM m l e => l -> Int -> Int -> m l
copied' v
es Int
o Int
sx m v -> (v -> m ()) -> m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Int -> Int -> Int -> v -> m ()
forall (m :: * -> *).
LinearM m v e =>
Int -> Int -> Int -> v -> m ()
mergeGo Int
o Int
0 (Int
o Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
sx)
      where
        mergeGo :: Int -> Int -> Int -> v -> m ()
mergeGo Int
ic Int
il Int
ir v
left
          | Int
il Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
lb = () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return () -- at least left is empty, merge is completed.
          | Int
ir Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
rb = v -> Int -> v -> Int -> Int -> m ()
forall (m :: * -> *) l e.
LinearM m l e =>
l -> Int -> l -> Int -> Int -> m ()
copyTo v
left Int
il v
es Int
ic (Int
lb Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
il)
          |   Bool
True   = (v
left v -> Int -> m e
forall (m :: * -> *) l e. LinearM m l e => l -> Int -> m e
!#> Int
il) m e -> m e -> (e -> e -> m ()) -> m ()
forall (m :: * -> *) a b c.
Monad m =>
m a -> m b -> (a -> b -> m c) -> m c
>>=<< (v
es v -> Int -> m e
forall (m :: * -> *) l e. LinearM m l e => l -> Int -> m e
!#> Int
ir) ((e -> e -> m ()) -> m ()) -> (e -> e -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$
            \ e
l e
r -> if e
r e -> e -> Bool
`gt` e
l
              then v -> Int -> e -> m ()
forall (m :: * -> *) l e. LinearM m l e => l -> Int -> e -> m ()
writeM v
es Int
ic e
l m () -> m () -> m ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Int -> Int -> Int -> v -> m ()
mergeGo (Int
ic Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) (Int
il Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Int
ir v
left
              else v -> Int -> e -> m ()
forall (m :: * -> *) l e. LinearM m l e => l -> Int -> e -> m ()
writeM v
es Int
ic e
r m () -> m () -> m ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Int -> Int -> Int -> v -> m ()
mergeGo (Int
ic Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Int
il (Int
ir Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) v
left
        rb :: Int
rb = Int
o Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
sx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
sy
        lb :: Int
lb = Int
sx

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

{-# INLINE minrunTS #-}
-- | 'minrunTS' returns @TimSort@ chunk size by given length.
minrunTS :: Int -> Int
minrunTS :: Int -> Int
minrunTS Int
i = Int -> Int -> Int
forall a. (Ord a, Num a, Bits a) => a -> a -> a
mr Int
i Int
0 where mr :: a -> a -> a
mr a
n a
r = a
n a -> a -> Bool
forall a. Ord a => a -> a -> Bool
>= a
64 Bool -> a -> a -> a
forall a. Bool -> a -> a -> a
? a -> a -> a
mr (a -> Int -> a
forall a. Bits a => a -> Int -> a
shiftR a
n Int
1) (a
n a -> a -> a
forall a. Bits a => a -> a -> a
.&. a
1) (a -> a) -> a -> a
forall a b. (a -> b) -> a -> b
$ a
n a -> a -> a
forall a. Num a => a -> a -> a
+ a
r