sortOn functions using same heap as sort and unstableSort (#500)
authorDonnacha Oisín Kidney <oisdk@users.noreply.github.com>
Mon, 22 Jan 2018 05:38:36 +0000 (05:38 +0000)
committerDavid Feuer <David.Feuer@gmail.com>
Mon, 22 Jan 2018 05:38:36 +0000 (00:38 -0500)
Add

```haskell
sortOn, unstableSortOn :: Ord b => (a -> b) -> Seq a -> Seq a
```

analogous to `Data.List.sortOn`. We minimize the performance cost by integrating the decorate-sort-undecorate paradigm into the heap structure. It will still be somewhat faster to use ``sortBy (compare `on` f)`` than `sortOn f` if `f` is very cheap, but otherwise `sortOn` will be faster.

Data/Sequence.hs
Data/Sequence/Internal.hs
Data/Sequence/Internal/Sorting.hs [new file with mode: 0644]
Data/Sequence/Internal/sorting.md [new file with mode: 0644]
Data/Sequence/sorting.md [deleted file]
Utils/Containers/Internal/State.hs [new file with mode: 0644]
benchmarks/Sequence.hs
containers.cabal
tests/seq-properties.hs

index ea912df..5689c41 100644 (file)
@@ -175,8 +175,10 @@ module Data.Sequence (
     -- * Sorting
     sort,           -- :: Ord a => Seq a -> Seq a
     sortBy,         -- :: (a -> a -> Ordering) -> Seq a -> Seq a
+    sortOn,         -- :: Ord b => (a -> b) -> Seq a -> Seq a
     unstableSort,   -- :: Ord a => Seq a -> Seq a
     unstableSortBy, -- :: (a -> a -> Ordering) -> Seq a -> Seq a
+    unstableSortOn, -- :: Ord b => (a -> b) -> Seq a -> Seq a
     -- * Indexing
     lookup,         -- :: Int -> Seq a -> Maybe a
     (!?),           -- :: Seq a -> Int -> Maybe a
@@ -223,6 +225,7 @@ module Data.Sequence (
     ) where
 
 import Data.Sequence.Internal
+import Data.Sequence.Internal.Sorting
 import Prelude ()
 #ifdef __HADDOCK_VERSION__
 import Control.Monad (Monad (..))
index e58ae2b..3c5dcf4 100644 (file)
@@ -86,6 +86,12 @@ module Data.Sequence.Internal (
 #else
     Seq (..),
 #endif
+    State(..),
+    execState,
+    foldDigit,
+    foldNode,
+    foldWithIndexDigit,
+    foldWithIndexNode,
 
     -- * Construction
     empty,          -- :: Seq a
@@ -137,11 +143,6 @@ module Data.Sequence.Internal (
     breakr,         -- :: (a -> Bool) -> Seq a -> (Seq a, Seq a)
     partition,      -- :: (a -> Bool) -> Seq a -> (Seq a, Seq a)
     filter,         -- :: (a -> Bool) -> Seq a -> Seq a
-    -- * Sorting
-    sort,           -- :: Ord a => Seq a -> Seq a
-    sortBy,         -- :: (a -> a -> Ordering) -> Seq a -> Seq a
-    unstableSort,   -- :: Ord a => Seq a -> Seq a
-    unstableSortBy, -- :: (a -> a -> Ordering) -> Seq a -> Seq a
     -- * Indexing
     lookup,         -- :: Int -> Seq a -> Maybe a
     (!?),           -- :: Seq a -> Int -> Maybe a
@@ -206,12 +207,13 @@ import Prelude hiding (
     unzip, takeWhile, dropWhile, iterate, reverse, filter, mapM, sum, all)
 import qualified Data.List
 import Control.Applicative (Applicative(..), (<$>), (<**>),  Alternative,
-                            liftA, liftA2, liftA3)
+                            liftA2, liftA3)
 import qualified Control.Applicative as Applicative
 import Control.DeepSeq (NFData(rnf))
-import Control.Monad (MonadPlus(..), ap)
+import Control.Monad (MonadPlus(..))
 import Data.Monoid (Monoid(..))
 import Data.Functor (Functor(..))
+import Utils.Containers.Internal.State (State(..), execState)
 #if MIN_VERSION_base(4,6,0)
 import Data.Foldable (Foldable(foldl, foldl1, foldr, foldr1, foldMap, foldl', foldr'), toList)
 #else
@@ -975,11 +977,15 @@ data Digit a
     deriving Show
 #endif
 
+foldDigit :: (b -> b -> b) -> (a -> b) -> Digit a -> b
+foldDigit _     f (One a) = f a
+foldDigit (<+>) f (Two a b) = f a <+> f b
+foldDigit (<+>) f (Three a b c) = f a <+> f b <+> f c
+foldDigit (<+>) f (Four a b c d) = f a <+> f b <+> f c <+> f d
+{-# INLINE foldDigit #-}
+
 instance Foldable Digit where
-    foldMap f (One a) = f a
-    foldMap f (Two a b) = f a <> f b
-    foldMap f (Three a b c) = f a <> f b <> f c
-    foldMap f (Four a b c d) = f a <> f b <> f c <> f d
+    foldMap = foldDigit mappend
 
     foldr f z (One a) = a `f` z
     foldr f z (Two a b) = a `f` (b `f` z)
@@ -1062,9 +1068,13 @@ data Node a
     deriving Show
 #endif
 
+foldNode :: (b -> b -> b) -> (a -> b) -> Node a -> b
+foldNode (<+>) f (Node2 _ a b) = f a <+> f b
+foldNode (<+>) f (Node3 _ a b c) = f a <+> f b <+> f c
+{-# INLINE foldNode #-}
+
 instance Foldable Node where
-    foldMap f (Node2 _ a b) = f a <> f b
-    foldMap f (Node3 _ a b c) = f a <> f b <> f c
+    foldMap = foldNode mappend
 
     foldr f z (Node2 _ a b) = a `f` (b `f` z)
     foldr f z (Node3 _ a b c) = a `f` (b `f` (c `f` z))
@@ -1162,27 +1172,6 @@ instance Applicative Identity where
     Identity f <*> Identity x = Identity (f x)
 #endif
 
--- | This is essentially a clone of Control.Monad.State.Strict.
-newtype State s a = State {runState :: s -> (s, a)}
-
-instance Functor (State s) where
-    fmap = liftA
-
-instance Monad (State s) where
-    {-# INLINE return #-}
-    {-# INLINE (>>=) #-}
-    return = pure
-    m >>= k = State $ \ s -> case runState m s of
-        (s', x) -> runState (k x) s'
-
-instance Applicative (State s) where
-    {-# INLINE pure #-}
-    pure x = State $ \ s -> (s, x)
-    (<*>) = ap
-
-execState :: State s a -> s -> a
-execState m x = snd (runState m x)
-
 -- | 'applicativeTree' takes an Applicative-wrapped construction of a
 -- piece of a FingerTree, assumed to always have the same size (which
 -- is put in the second argument), and replicates it as many times as
@@ -2656,6 +2645,32 @@ mapWithIndex f' (Seq xs') = Seq $ mapWithIndexTree (\s (Elem a) -> Elem (f' s a)
  #-}
 #endif
 
+{-# INLINE foldWithIndexDigit #-}
+foldWithIndexDigit :: Sized a => (b -> b -> b) -> (Int -> a -> b) -> Int -> Digit a -> b
+foldWithIndexDigit _ f !s (One a) = f s a
+foldWithIndexDigit (<+>) f s (Two a b) = f s a <+> f sPsa b
+  where
+    !sPsa = s + size a
+foldWithIndexDigit (<+>) f s (Three a b c) = f s a <+> f sPsa b <+> f sPsab c
+  where
+    !sPsa = s + size a
+    !sPsab = sPsa + size b
+foldWithIndexDigit (<+>) f s (Four a b c d) =
+    f s a <+> f sPsa b <+> f sPsab c <+> f sPsabc d
+  where
+    !sPsa = s + size a
+    !sPsab = sPsa + size b
+    !sPsabc = sPsab + size c
+
+{-# INLINE foldWithIndexNode #-}
+foldWithIndexNode :: Sized a => (m -> m -> m) -> (Int -> a -> m) -> Int -> Node a -> m
+foldWithIndexNode (<+>) f !s (Node2 _ a b) = f s a <+> f sPsa b
+  where
+    !sPsa = s + size a
+foldWithIndexNode (<+>) f s (Node3 _ a b c) = f s a <+> f sPsa b <+> f sPsab c
+  where
+    !sPsa = s + size a
+    !sPsab = sPsa + size b
 
 -- A generalization of 'foldMap', 'foldMapWithIndex' takes a folding
 -- function that also depends on the element's index, and applies it to every
@@ -2699,45 +2714,16 @@ foldMapWithIndex f' (Seq xs') = foldMapWithIndexTreeE (lift_elem f') 0 xs'
       !sPsprm = sPspr + size m
 
   foldMapWithIndexDigitE :: Monoid m => (Int -> Elem a -> m) -> Int -> Digit (Elem a) -> m
-  foldMapWithIndexDigitE f i t = foldMapWithIndexDigit f i t
+  foldMapWithIndexDigitE f i t = foldWithIndexDigit (<>) f i t
 
   foldMapWithIndexDigitN :: Monoid m => (Int -> Node a -> m) -> Int -> Digit (Node a) -> m
-  foldMapWithIndexDigitN f i t = foldMapWithIndexDigit f i t
-
-  {-# INLINE foldMapWithIndexDigit #-}
-  foldMapWithIndexDigit :: (Monoid m, Sized a) => (Int -> a -> m) -> Int -> Digit a -> m
-  foldMapWithIndexDigit f !s (One a) = f s a
-  foldMapWithIndexDigit f s (Two a b) = f s a <> f sPsa b
-    where
-      !sPsa = s + size a
-  foldMapWithIndexDigit f s (Three a b c) =
-                                      f s a <> f sPsa b <> f sPsab c
-    where
-      !sPsa = s + size a
-      !sPsab = sPsa + size b
-  foldMapWithIndexDigit f s (Four a b c d) =
-                          f s a <> f sPsa b <> f sPsab c <> f sPsabc d
-    where
-      !sPsa = s + size a
-      !sPsab = sPsa + size b
-      !sPsabc = sPsab + size c
+  foldMapWithIndexDigitN f i t = foldWithIndexDigit (<>) f i t
 
   foldMapWithIndexNodeE :: Monoid m => (Int -> Elem a -> m) -> Int -> Node (Elem a) -> m
-  foldMapWithIndexNodeE f i t = foldMapWithIndexNode f i t
+  foldMapWithIndexNodeE f i t = foldWithIndexNode (<>) f i t
 
   foldMapWithIndexNodeN :: Monoid m => (Int -> Node a -> m) -> Int -> Node (Node a) -> m
-  foldMapWithIndexNodeN f i t = foldMapWithIndexNode f i t
-
-  {-# INLINE foldMapWithIndexNode #-}
-  foldMapWithIndexNode :: (Monoid m, Sized a) => (Int -> a -> m) -> Int -> Node a -> m
-  foldMapWithIndexNode f !s (Node2 _ a b) = f s a <> f sPsa b
-    where
-      !sPsa = s + size a
-  foldMapWithIndexNode f s (Node3 _ a b c) =
-                                     f s a <> f sPsa b <> f sPsab c
-    where
-      !sPsa = s + size a
-      !sPsab = sPsa + size b
+  foldMapWithIndexNodeN f i t = foldWithIndexNode (<>) f i t
 
 #if __GLASGOW_HASKELL__
 {-# INLINABLE foldMapWithIndex #-}
@@ -4473,159 +4459,6 @@ zipWith4 f s1 s2 s3 s4 = zipWith' ($) (zipWith3' f s1' s2' s3') s4'
     s3' = take minLen s3
     s4' = take minLen s4
 
-------------------------------------------------------------------------
--- Sorting
---
--- Unstable sorting is performed by a heap sort implementation based on
--- pairing heaps.  Because the internal structure of sequences is quite
--- varied, it is difficult to get blocks of elements of roughly the same
--- length, which would improve merge sort performance.  Pairing heaps,
--- on the other hand, are relatively resistant to the effects of merging
--- heaps of wildly different sizes, as guaranteed by its amortized
--- constant-time merge operation.  Moreover, extensive use of SpecConstr
--- transformations can be done on pairing heaps, especially when we're
--- only constructing them to immediately be unrolled.
---
--- On purely random sequences of length 50000, with no RTS options,
--- I get the following statistics, in which heapsort is about 42.5%
--- faster:  (all comparisons done with -O2)
---
--- Times (ms)            min      mean    +/-sd    median    max
--- to/from list:       103.802  108.572    7.487  106.436  143.339
--- unstable heapsort:   60.686   62.968    4.275   61.187   79.151
---
--- Heapsort, it would seem, is less of a memory hog than Data.List.sortBy.
--- The gap is narrowed when more memory is available, but heapsort still
--- wins, 15% faster, with +RTS -H128m:
---
--- Times (ms)            min    mean    +/-sd  median    max
--- to/from list:       42.692  45.074   2.596  44.600  56.601
--- unstable heapsort:  37.100  38.344   3.043  37.715  55.526
---
--- In addition, on strictly increasing sequences the gap is even wider
--- than normal; heapsort is 68.5% faster with no RTS options:
--- Times (ms)            min    mean    +/-sd  median    max
--- to/from list:       52.236  53.574   1.987  53.034  62.098
--- unstable heapsort:  16.433  16.919   0.931  16.681  21.622
---
--- This may be attributed to the elegant nature of the pairing heap.
---
--- wasserman.louis@gmail.com, 7/20/09
-------------------------------------------------------------------------
--- David Feuer wrote an unstable sort for arbitrary traversables,
--- https://www.reddit.com/r/haskell/comments/63a4ea/fast_total_sorting_of_arbitrary_traversable/,
--- which turned out to be competitive with the unstable sort here.
--- Feuer suggested that this indicated some room to improve on the
--- unstable sort.
---
--- The two main improvements to the original function are a specialize
--- pragma on replicateA (this gives a 26.5% speedup) and removal of the
--- intermediate list (a further 11.7% speedup). These numbers are all on
--- purely random sequences of length 50000:
---
--- Times (ms)            min    est    max  std dev   R²
--- to/from list:        70.90  72.44  75.07  2.224  0.998
--- 7/20/09 heapsort:    59.84  61.44  63.08  1.554  0.998
--- 7/20/09 w/pragma:    44.22  45.14  46.25  1.631  0.998
--- 4/30/17 heapsort:    38.21  39.86  40.87  1.203  0.996
---
--- It should also be noted that Data.List.sortBy has become
--- significantly quicker. Data.List.sortBy also now recognizes strictly
--- increasing sequences, making it much quicker for that case:
---
--- Times (ms)            min    est    max  std dev   R²
--- to/from list:        7.140  7.351  7.634  0.335  0.993
--- 7/20/09 heapsort:    19.52  19.78  20.13  0.445  0.999
--- 7/20/09 w/pragma:    8.050  8.271  8.514  0.357  0.995
--- 4/30/17 heapsort:    7.240  7.612  7.925  0.389  0.991
---
--- Another happy result of the specialization of 'replicateA' is that
--- the stable sort seems to speed up by 10-20%, and 'iterateN' looks
--- like it's about three times as fast.
---
--- mail@doisinkidney.com, 4/30/17
-------------------------------------------------------------------------
--- The sort and sortBy functions are implemented by tagging each element
--- in the input sequence with its position, and using that to
--- discriminate between elements which are equivalent according to the
--- comparator. This makes the sort stable.
---
--- The algorithm is effectively the same as the unstable sorts, except
--- the queue is constructed while giving each element a tag.
---
--- It's quicker than the old implementation (which used Data.List.sort)
--- in the general case (all times are on sequences of length 50000):
---
--- Times (ms)            min    est    max  std dev   r²
--- to/from list:        64.23  64.50  64.81  0.432  1.000
--- 1/11/18 stable heap: 38.87  39.40  40.09  0.457  0.999
---
--- Slightly slower in the case of already sorted lists:
---
--- Times (ms)            min    est    max  std dev   r²
--- to/from list:        6.806  6.861  6.901  0.234  1.000
--- 1/11/18 stable heap: 8.211  8.268  8.328  0.111  1.000
---
--- And quicker in the case of lists sorted in reverse:
---
--- Times (ms)            min    est    max  std dev   r²
--- to/from list:        26.79  28.34  30.55  1.219  0.988
--- 1/11/18 stable heap: 9.405  10.13  10.91  0.670  0.977
---
--- Interestingly, the stable sort is now competitive with the unstable:
---
--- Times (ms)            min    est    max  std dev   r²
--- unstable:            34.71  35.10  35.38  0.845  1.000
--- stable:              38.84  39.22  39.59  0.564  0.999
---
--- And even beats it in the case of already-sorted lists:
---
--- Times (ms)            min    est    max  std dev   r²
--- unstable:            8.457  8.499  8.536  0.069  1.000
--- stable:              8.160  8.230  8.334  0.158  0.999
---
--- mail@doisinkidney.com, 1/11/18
-------------------------------------------------------------------------
--- Further notes are available in the file sorting.md (in this
--- directory).
-------------------------------------------------------------------------
-
--- | \( O(n \log n) \).  'sort' sorts the specified 'Seq' by the natural
--- ordering of its elements.  The sort is stable.  If stability is not
--- required, 'unstableSort' can be slightly faster.
-sort :: Ord a => Seq a -> Seq a
-sort = sortBy compare
-
--- | \( O(n \log n) \).  'sortBy' sorts the specified 'Seq' according to the
--- specified comparator.  The sort is stable.  If stability is not required,
--- 'unstableSortBy' can be slightly faster.
-sortBy :: (a -> a -> Ordering) -> Seq a -> Seq a
-sortBy cmp (Seq xs) =
-    maybe
-        (Seq EmptyT)
-        (execState (replicateA (size xs) (popMinS cmp)))
-        (toPQS cmp (Seq xs))
-
--- | \( O(n \log n) \).  'unstableSort' sorts the specified 'Seq' by
--- the natural ordering of its elements, but the sort is not stable.
--- This algorithm is frequently faster and uses less memory than 'sort'.
-
--- Notes on the implementation and choice of heap are available in
--- the file sorting.md (in this directory).
-unstableSort :: Ord a => Seq a -> Seq a
-unstableSort = unstableSortBy compare
-
--- | \( O(n \log n) \).  A generalization of 'unstableSort', 'unstableSortBy'
--- takes an arbitrary comparator and sorts the specified sequence.
--- The sort is not stable.  This algorithm is frequently faster and
--- uses less memory than 'sortBy'.
-unstableSortBy :: (a -> a -> Ordering) -> Seq a -> Seq a
-unstableSortBy cmp (Seq xs) =
-    maybe
-        (Seq EmptyT)
-        (execState (replicateA (size xs) (popMin cmp)))
-        (toPQ cmp (Seq xs))
-
 -- | fromList2, given a list and its length, constructs a completely
 -- balanced Seq whose elements are that list using the replicateA
 -- generalization.
@@ -4634,169 +4467,3 @@ fromList2 n = execState (replicateA n (State ht))
   where
     ht (x:xs) = (xs, x)
     ht []     = error "fromList2: short list"
-
--- | A 'PQueue' is a simple pairing heap.
-data PQueue e = PQueue e (PQL e)
-data PQL e = Nil | {-# UNPACK #-} !(PQueue e) :& PQL e
-
-infixr 8 :&
-
-#ifdef TESTING
-
-instance Functor PQueue where
-    fmap f (PQueue x ts) = PQueue (f x) (fmap f ts)
-
-instance Functor PQL where
-    fmap f (q :& qs) = fmap f q :& fmap f qs
-    fmap _ Nil = Nil
-
-instance Show e => Show (PQueue e) where
-    show = unlines . draw . fmap show
-
--- borrowed wholesale from Data.Tree, as Data.Tree actually depends
--- on Data.Sequence
-draw :: PQueue String -> [String]
-draw (PQueue x ts0) = x : drawSubTrees ts0
-  where
-    drawSubTrees Nil = []
-    drawSubTrees (t :& Nil) =
-        "|" : shift "`- " "   " (draw t)
-    drawSubTrees (t :& ts) =
-        "|" : shift "+- " "|  " (draw t) ++ drawSubTrees ts
-
-    shift first other = Data.List.zipWith (++) (first : repeat other)
-#endif
-
--- | 'popMin', given an ordering function, constructs a stateful action
--- which pops the smallest elements from a queue. This action will fail
--- on empty queues.
-popMin :: (e -> e -> Ordering) -> State (PQueue e) e
-popMin cmp = State unrollPQ'
-  where
-    {-# INLINE unrollPQ' #-}
-    unrollPQ' (PQueue x ts) = (mergePQs ts, x)
-    mergePQs (t :& Nil) = t
-    mergePQs (t1 :& t2 :& Nil) = t1 <+> t2
-    mergePQs (t1 :& t2 :& ts) = (t1 <+> t2) <+> mergePQs ts
-    mergePQs Nil = error "popMin: tried to pop from empty queue"
-    (<+>) = mergePQ cmp
-
--- | 'toPQ', given an ordering function and a mechanism for queueifying
--- elements, converts a 'Seq' to a 'PQueue'.
-toPQ :: (e -> e -> Ordering) -> Seq e -> Maybe (PQueue e)
-toPQ cmp' (Seq xs') = toPQTree cmp' (\(Elem a) -> PQueue a Nil) xs'
-  where
-    toPQTree :: (b -> b -> Ordering) -> (a -> PQueue b) -> FingerTree a -> Maybe (PQueue b)
-    toPQTree _ _ EmptyT = Nothing
-    toPQTree _ f (Single xs) = Just (f xs)
-    toPQTree cmp f (Deep _ pr m sf) =
-        Just (maybe (pr' <+> sf') ((pr' <+> sf') <+>) m')
-      where
-        pr' = toPQDigit cmp f pr
-        sf' = toPQDigit cmp f sf
-        m' = toPQTree cmp (toPQNode cmp f) m
-        (<+>) = mergePQ cmp
-    toPQDigit :: (b -> b -> Ordering) -> (a -> PQueue b) -> Digit a -> PQueue b
-    toPQDigit cmp f dig =
-        case dig of
-            One a -> f a
-            Two a b -> f a <+> f b
-            Three a b c -> f a <+> f b <+> f c
-            Four a b c d -> (f a <+> f b) <+> (f c <+> f d)
-      where
-        (<+>) = mergePQ cmp
-    toPQNode :: (b -> b -> Ordering) -> (a -> PQueue b) -> Node a -> PQueue b
-    toPQNode cmp f node =
-        case node of
-            Node2 _ a b -> f a <+> f b
-            Node3 _ a b c -> f a <+> f b <+> f c
-      where
-        (<+>) = mergePQ cmp
-
--- | 'mergePQ' merges two 'PQueue's.
-mergePQ :: (a -> a -> Ordering) -> PQueue a -> PQueue a -> PQueue a
-mergePQ cmp q1@(PQueue x1 ts1) q2@(PQueue x2 ts2)
-  | cmp x1 x2 == GT     = PQueue x2 (q1 :& ts2)
-  | otherwise           = PQueue x1 (q2 :& ts1)
-
--- | A pairing heap tagged with the original position of elements,
--- to allow for stable sorting.
-data PQS e = PQS {-# UNPACK #-} !Int e (PQSL e)
-data PQSL e = Nl | {-# UNPACK #-} !(PQS e) :&& PQSL e
-
-infixr 8 :&&
-
--- | 'popMinS', given an ordering function, constructs a stateful action
--- which pops the smallest elements from a queue. This action will fail
--- on empty queues.
-popMinS :: (e -> e -> Ordering) -> State (PQS e) e
-popMinS cmp = State unrollPQ'
-  where
-    {-# INLINE unrollPQ' #-}
-    unrollPQ' (PQS _ x ts) = (mergePQs ts, x)
-    mergePQs (t :&& Nl) = t
-    mergePQs (t1 :&& t2 :&& Nl) = t1 <+> t2
-    mergePQs (t1 :&& t2 :&& ts) = (t1 <+> t2) <+> mergePQs ts
-    mergePQs Nl = error "popMin: tried to pop from empty queue"
-    (<+>) = mergePQS cmp
-
--- | 'toPQS', given an ordering function, converts a 'Seq' to a
--- 'PQS'.
-toPQS :: (e -> e -> Ordering) -> Seq e -> Maybe (PQS e)
-toPQS cmp' (Seq xs') = toPQSTree cmp' (\s (Elem a) -> PQS s a Nl) 0 xs'
-  where
-    {-# SPECIALISE toPQSTree :: (b -> b -> Ordering) -> (Int -> Elem y -> PQS b) -> Int -> FingerTree (Elem y) -> Maybe (PQS b) #-}
-    {-# SPECIALISE toPQSTree :: (b -> b -> Ordering) -> (Int -> Node y -> PQS b) -> Int -> FingerTree (Node y) -> Maybe (PQS b) #-}
-    toPQSTree :: Sized a => (b -> b -> Ordering) -> (Int -> a -> PQS b) -> Int -> FingerTree a -> Maybe (PQS b)
-    toPQSTree _ _ !_s EmptyT = Nothing
-    toPQSTree _ f s (Single xs) = Just (f s xs)
-    toPQSTree cmp f s (Deep _ pr m sf) =
-        Just (maybe (pr' <+> sf') ((pr' <+> sf') <+>) m')
-      where
-        pr' = toPQSDigit cmp f s pr
-        sf' = toPQSDigit cmp f sPsprm sf
-        m' = toPQSTree cmp (toPQSNode cmp f) sPspr m
-        !sPspr = s + size pr
-        !sPsprm = sPspr + size m
-        (<+>) = mergePQS cmp
-    {-# SPECIALISE toPQSDigit :: (b -> b -> Ordering) -> (Int -> Elem y -> PQS b) -> Int -> Digit (Elem y) -> PQS b #-}
-    {-# SPECIALISE toPQSDigit :: (b -> b -> Ordering) -> (Int -> Node y -> PQS b) -> Int -> Digit (Node y) -> PQS b #-}
-    toPQSDigit :: Sized a => (b -> b -> Ordering) -> (Int -> a -> PQS b) -> Int -> Digit a -> PQS b
-    toPQSDigit _ f !s (One a) = f s a
-    toPQSDigit cmp f s (Two a b) = f s a <+> f sPsa b
-      where
-        !sPsa = s + size a
-        (<+>) = mergePQS cmp
-    toPQSDigit cmp f s (Three a b c) = f s a <+> f sPsa b <+> f sPsab c
-      where
-        !sPsa = s + size a
-        !sPsab = sPsa + size b
-        (<+>) = mergePQS cmp
-    toPQSDigit cmp f s (Four a b c d) =
-        (f s a <+> f sPsa b) <+> (f sPsab c <+> f sPsabc d)
-      where
-        !sPsa = s + size a
-        !sPsab = sPsa + size b
-        !sPsabc = sPsab + size c
-        (<+>) = mergePQS cmp
-    {-# SPECIALISE toPQSNode :: (b -> b -> Ordering) -> (Int -> Elem y -> PQS b) -> Int -> Node (Elem y) -> PQS b #-}
-    {-# SPECIALISE toPQSNode :: (b -> b -> Ordering) -> (Int -> Node y -> PQS b) -> Int -> Node (Node y) -> PQS b #-}
-    toPQSNode :: Sized a => (b -> b -> Ordering) -> (Int -> a -> PQS b) -> Int -> Node a -> PQS b
-    toPQSNode cmp f s (Node2 _ a b) = f s a <+> f sPsa b
-      where
-        !sPsa = s + size a
-        (<+>) = mergePQS cmp
-    toPQSNode cmp f s (Node3 _ a b c) = f s a <+> f sPsa b <+> f sPsab c
-      where
-        !sPsa = s + size a
-        !sPsab = sPsa + size b
-        (<+>) = mergePQS cmp
-
--- | 'mergePQS' merges two PQS, taking into account the original
--- position of the elements.
-mergePQS :: (a -> a -> Ordering) -> PQS a -> PQS a -> PQS a
-mergePQS cmp q1@(PQS i1 x1 ts1) q2@(PQS i2 x2 ts2) =
-    case cmp x1 x2 of
-        LT -> PQS i1 x1 (q2 :&& ts1)
-        EQ | i1 <= i2 -> PQS i1 x1 (q2 :&& ts1)
-        _ -> PQS i2 x2 (q1 :&& ts2)
diff --git a/Data/Sequence/Internal/Sorting.hs b/Data/Sequence/Internal/Sorting.hs
new file mode 100644 (file)
index 0000000..ba0973e
--- /dev/null
@@ -0,0 +1,425 @@
+{-# LANGUAGE BangPatterns #-}
+
+{-# OPTIONS_HADDOCK not-home #-}
+
+-- |
+--
+-- = WARNING
+--
+-- This module is considered __internal__.
+--
+-- The Package Versioning Policy __does not apply__.
+--
+-- This contents of this module may change __in any way whatsoever__
+-- and __without any warning__ between minor versions of this package.
+--
+-- Authors importing this module are expected to track development
+-- closely.
+--
+-- = Description
+--
+-- This module provides the various sorting implementations for
+-- "Data.Sequence". Further notes are available in the file sorting.md
+-- (in this directory).
+
+module Data.Sequence.Internal.Sorting
+  (
+   -- * Sort Functions
+   sort
+  ,sortBy
+  ,sortOn
+  ,unstableSort
+  ,unstableSortBy
+  ,unstableSortOn
+  ,
+   -- * Heaps
+   -- $heaps
+   Queue(..)
+  ,QList(..)
+  ,IndexedQueue(..)
+  ,IQList(..)
+  ,TaggedQueue(..)
+  ,TQList(..)
+  ,IndexedTaggedQueue(..)
+  ,ITQList(..)
+  ,
+   -- * Merges
+   -- $merges
+   mergeQ
+  ,mergeIQ
+  ,mergeTQ
+  ,mergeITQ
+  ,
+   -- * popMin
+   -- $popMin
+   popMinQ
+  ,popMinIQ
+  ,popMinTQ
+  ,popMinITQ
+  ,
+   -- * Building
+   -- $building
+   buildQ
+  ,buildIQ
+  ,buildTQ
+  ,buildITQ
+  ,
+   -- * Special folds
+   -- $folds
+   foldToMaybeTree
+  ,foldToMaybeWithIndexTree)
+  where
+
+import Data.Sequence.Internal
+       (Elem(..), Seq(..), Node(..), Digit(..), Sized(..), FingerTree(..),
+        replicateA, foldDigit, foldNode, foldWithIndexDigit,
+        foldWithIndexNode)
+import Utils.Containers.Internal.State (State(..), execState)
+-- | \( O(n \log n) \).  'sort' sorts the specified 'Seq' by the natural
+-- ordering of its elements.  The sort is stable.  If stability is not
+-- required, 'unstableSort' can be slightly faster.
+sort :: Ord a => Seq a -> Seq a
+sort = sortBy compare
+
+-- | \( O(n \log n) \).  'sortBy' sorts the specified 'Seq' according to the
+-- specified comparator.  The sort is stable.  If stability is not required,
+-- 'unstableSortBy' can be slightly faster.
+sortBy :: (a -> a -> Ordering) -> Seq a -> Seq a
+sortBy cmp (Seq xs) =
+    maybe
+        (Seq EmptyT)
+        (execState (replicateA (size xs) (State (popMinIQ cmp))))
+        (buildIQ cmp (\s (Elem x) -> IQ s x IQNil) 0 xs)
+
+-- | \( O(n \log n) \). 'sortOn' sorts the specified 'Seq' by comparing
+-- the results of a key function applied to each element. @'sortOn' f@ is
+-- equivalent to @'sortBy' ('compare' ``Data.Function.on`` f)@, but has the
+-- performance advantage of only evaluating @f@ once for each element in the
+-- input list. This is called the decorate-sort-undecorate paradigm, or
+-- Schwartzian transform.
+--
+-- An example of using 'sortOn' might be to sort a 'Seq' of strings
+-- according to their length:
+--
+-- > sortOn length (fromList ["alligator", "monkey", "zebra"]) == fromList ["zebra", "monkey", "alligator"]
+--
+-- If, instead, 'sortBy' had been used, 'length' would be evaluated on
+-- every comparison, giving \( O(n \log n) \) evaluations, rather than
+-- \( O(n) \).
+--
+-- If @f@ is very cheap (for example a record selector, or 'fst'),
+-- @'sortBy' ('compare' ``Data.Function.on`` f)@ will be faster than
+-- @'sortOn' f@.
+sortOn :: Ord b => (a -> b) -> Seq a -> Seq a
+sortOn f (Seq xs) =
+    maybe
+       (Seq EmptyT)
+       (execState (replicateA (size xs) (State (popMinITQ compare))))
+       (buildITQ compare (\s (Elem x) -> ITQ s (f x) x ITQNil) 0 xs)
+
+-- | \( O(n \log n) \).  'unstableSort' sorts the specified 'Seq' by
+-- the natural ordering of its elements, but the sort is not stable.
+-- This algorithm is frequently faster and uses less memory than 'sort'.
+
+-- Notes on the implementation and choice of heap are available in
+-- the file sorting.md (in this directory).
+unstableSort :: Ord a => Seq a -> Seq a
+unstableSort = unstableSortBy compare
+
+-- | \( O(n \log n) \).  A generalization of 'unstableSort', 'unstableSortBy'
+-- takes an arbitrary comparator and sorts the specified sequence.
+-- The sort is not stable.  This algorithm is frequently faster and
+-- uses less memory than 'sortBy'.
+unstableSortBy :: (a -> a -> Ordering) -> Seq a -> Seq a
+unstableSortBy cmp (Seq xs) =
+    maybe
+        (Seq EmptyT)
+        (execState (replicateA (size xs) (State (popMinQ cmp))))
+        (buildQ cmp (\(Elem x) -> Q x Nil) xs)
+
+-- | \( O(n \log n) \). 'unstableSortOn' sorts the specified 'Seq' by
+-- comparing the results of a key function applied to each element.
+-- @'unstableSortOn' f@ is equivalent to @'unstableSortBy' ('compare' ``Data.Function.on`` f)@,
+-- but has the performance advantage of only evaluating @f@ once for each
+-- element in the input list. This is called the
+-- decorate-sort-undecorate paradigm, or Schwartzian transform.
+--
+-- An example of using 'unstableSortOn' might be to sort a 'Seq' of strings
+-- according to their length:
+--
+-- > unstableSortOn length (fromList ["alligator", "monkey", "zebra"]) == fromList ["zebra", "monkey", "alligator"]
+--
+-- If, instead, 'unstableSortBy' had been used, 'length' would be evaluated on
+-- every comparison, giving \( O(n \log n) \) evaluations, rather than
+-- \( O(n) \).
+--
+-- If @f@ is very cheap (for example a record selector, or 'fst'),
+-- @'unstableSortBy' ('compare' ``Data.Function.on`` f)@ will be faster than
+-- @'unstableSortOn' f@.
+unstableSortOn :: Ord b => (a -> b) -> Seq a -> Seq a
+unstableSortOn f (Seq xs) =
+    maybe
+       (Seq EmptyT)
+       (execState (replicateA (size xs) (State (popMinTQ compare))))
+       (buildTQ compare (\(Elem x) -> TQ (f x) x TQNil) xs)
+
+------------------------------------------------------------------------
+-- $heaps
+--
+-- The following are definitions for various specialized pairing heaps.
+--
+-- All of the heaps are defined to be non-empty, which speeds up the
+-- merge functions.
+------------------------------------------------------------------------
+
+-- | A simple pairing heap.
+data Queue e = Q !e (QList e)
+data QList e
+    = Nil
+    | QCons {-# UNPACK #-} !(Queue e)
+            (QList e)
+
+-- | A pairing heap tagged with the original position of elements,
+-- to allow for stable sorting.
+data IndexedQueue e =
+    IQ {-# UNPACK #-} !Int !e (IQList e)
+data IQList e
+    = IQNil
+    | IQCons {-# UNPACK #-} !(IndexedQueue e)
+             (IQList e)
+
+-- | A pairing heap tagged with some key for sorting elements, for use
+-- in 'unstableSortOn'.
+data TaggedQueue a b =
+    TQ !a b (TQList a b)
+data TQList a b
+    = TQNil
+    | TQCons {-# UNPACK #-} !(TaggedQueue a b)
+             (TQList a b)
+
+-- | A pairing heap tagged with both a key and the original position
+-- of its elements, for use in 'sortOn'.
+data IndexedTaggedQueue e a =
+    ITQ {-# UNPACK #-} !Int !e a (ITQList e a)
+data ITQList e a
+    = ITQNil
+    | ITQCons {-# UNPACK #-} !(IndexedTaggedQueue e a)
+              (ITQList e a)
+
+infixr 8 `ITQCons`, `TQCons`, `QCons`, `IQCons`
+
+------------------------------------------------------------------------
+-- $merges
+--
+-- The following are definitions for "merge" for each of the heaps
+-- above. Each takes a comparison function which is used to order the
+-- elements.
+------------------------------------------------------------------------
+
+-- | 'mergeQ' merges two 'Queue's.
+mergeQ :: (a -> a -> Ordering) -> Queue a -> Queue a -> Queue a
+mergeQ cmp q1@(Q x1 ts1) q2@(Q x2 ts2)
+  | cmp x1 x2 == GT = Q x2 (q1 `QCons` ts2)
+  | otherwise       = Q x1 (q2 `QCons` ts1)
+
+-- | 'mergeTQ' merges two 'TaggedQueue's, based on the tag value.
+mergeTQ :: (a -> a -> Ordering)
+        -> TaggedQueue a b
+        -> TaggedQueue a b
+        -> TaggedQueue a b
+mergeTQ cmp q1@(TQ x1 y1 ts1) q2@(TQ x2 y2 ts2)
+  | cmp x1 x2 == GT = TQ x2 y2 (q1 `TQCons` ts2)
+  | otherwise       = TQ x1 y1 (q2 `TQCons` ts1)
+
+-- | 'mergeIQ' merges two 'IndexedQueue's, taking into account the
+-- original position of the elements.
+mergeIQ :: (a -> a -> Ordering)
+        -> IndexedQueue a
+        -> IndexedQueue a
+        -> IndexedQueue a
+mergeIQ cmp q1@(IQ i1 x1 ts1) q2@(IQ i2 x2 ts2) =
+    case cmp x1 x2 of
+        LT -> IQ i1 x1 (q2 `IQCons` ts1)
+        EQ | i1 <= i2 -> IQ i1 x1 (q2 `IQCons` ts1)
+        _ -> IQ i2 x2 (q1 `IQCons` ts2)
+
+-- | 'mergeITQ' merges two 'IndexedTaggedQueue's, based on the tag
+-- value, taking into account the original position of the elements.
+mergeITQ
+    :: (a -> a -> Ordering)
+    -> IndexedTaggedQueue a b
+    -> IndexedTaggedQueue a b
+    -> IndexedTaggedQueue a b
+mergeITQ cmp q1@(ITQ i1 x1 y1 ts1) q2@(ITQ i2 x2 y2 ts2) =
+    case cmp x1 x2 of
+        LT -> ITQ i1 x1 y1 (q2 `ITQCons` ts1)
+        EQ | i1 <= i2 -> ITQ i1 x1 y1 (q2 `ITQCons` ts1)
+        _ -> ITQ i2 x2 y2 (q1 `ITQCons` ts2)
+
+------------------------------------------------------------------------
+-- $popMin
+--
+-- The following are definitions for @popMin@, a function which
+-- constructs a stateful action which pops the smallest element from the
+-- queue, where "smallest" is according to the supplied comparison
+-- function.
+--
+-- All of the functions fail on an empty queue.
+--
+-- Each of these functions is structured something like this:
+--
+-- @popMinQ cmp (Q x ts) = (mergeQs ts, x)@
+--
+-- The reason the call to @mergeQs@ is lazy is that it will be bottom
+-- for the last element in the queue, preventing us from evaluating the
+-- fully sorted sequence.
+------------------------------------------------------------------------
+
+-- | Pop the smallest element from the queue, using the supplied
+-- comparator.
+popMinQ :: (e -> e -> Ordering) -> Queue e -> (Queue e, e)
+popMinQ cmp (Q x xs) = (mergeQs xs, x)
+  where
+    mergeQs (t `QCons` Nil) = t
+    mergeQs (t1 `QCons` t2 `QCons` Nil) = t1 <+> t2
+    mergeQs (t1 `QCons` t2 `QCons` ts) = (t1 <+> t2) <+> mergeQs ts
+    mergeQs Nil = error "popMinQ: tried to pop from empty queue"
+    (<+>) = mergeQ cmp
+
+-- | Pop the smallest element from the queue, using the supplied
+-- comparator, deferring to the item's original position when the
+-- comparator returns 'EQ'.
+popMinIQ :: (e -> e -> Ordering) -> IndexedQueue e -> (IndexedQueue e, e)
+popMinIQ cmp (IQ _ x xs) = (mergeQs xs, x)
+  where
+    mergeQs (t `IQCons` IQNil) = t
+    mergeQs (t1 `IQCons` t2 `IQCons` IQNil) = t1 <+> t2
+    mergeQs (t1 `IQCons` t2 `IQCons` ts) = (t1 <+> t2) <+> mergeQs ts
+    mergeQs IQNil = error "popMinQ: tried to pop from empty queue"
+    (<+>) = mergeIQ cmp
+
+-- | Pop the smallest element from the queue, using the supplied
+-- comparator on the tag.
+popMinTQ :: (a -> a -> Ordering) -> TaggedQueue a b -> (TaggedQueue a b, b)
+popMinTQ cmp (TQ _ x xs) = (mergeQs xs, x)
+  where
+    mergeQs (t `TQCons` TQNil) = t
+    mergeQs (t1 `TQCons` t2 `TQCons` TQNil) = t1 <+> t2
+    mergeQs (t1 `TQCons` t2 `TQCons` ts) = (t1 <+> t2) <+> mergeQs ts
+    mergeQs TQNil = error "popMinQ: tried to pop from empty queue"
+    (<+>) = mergeTQ cmp
+
+-- | Pop the smallest element from the queue, using the supplied
+-- comparator on the tag, deferring to the item's original position
+-- when the comparator returns 'EQ'.
+popMinITQ :: (e -> e -> Ordering)
+          -> IndexedTaggedQueue e b
+          -> (IndexedTaggedQueue e b, b)
+popMinITQ cmp (ITQ _ _ x xs) = (mergeQs xs, x)
+  where
+    mergeQs (t `ITQCons` ITQNil) = t
+    mergeQs (t1 `ITQCons` t2 `ITQCons` ITQNil) = t1 <+> t2
+    mergeQs (t1 `ITQCons` t2 `ITQCons` ts) = (t1 <+> t2) <+> mergeQs ts
+    mergeQs ITQNil = error "popMinQ: tried to pop from empty queue"
+    (<+>) = mergeITQ cmp
+
+------------------------------------------------------------------------
+-- $building
+--
+-- The following are definitions for functions to build queues, given a
+-- comparison function.
+------------------------------------------------------------------------
+
+buildQ :: (b -> b -> Ordering) -> (a -> Queue b) -> FingerTree a -> Maybe (Queue b)
+buildQ cmp = foldToMaybeTree (mergeQ cmp)
+
+buildIQ
+    :: (b -> b -> Ordering)
+    -> (Int -> Elem y -> IndexedQueue b)
+    -> Int
+    -> FingerTree (Elem y)
+    -> Maybe (IndexedQueue b)
+buildIQ cmp = foldToMaybeWithIndexTree (mergeIQ cmp)
+
+buildTQ
+    :: (b -> b -> Ordering)
+    -> (a -> TaggedQueue b c)
+    -> FingerTree a
+    -> Maybe (TaggedQueue b c)
+buildTQ cmp = foldToMaybeTree (mergeTQ cmp)
+
+buildITQ
+    :: (b -> b -> Ordering)
+    -> (Int -> Elem y -> IndexedTaggedQueue b c)
+    -> Int
+    -> FingerTree (Elem y)
+    -> Maybe (IndexedTaggedQueue b c)
+buildITQ cmp = foldToMaybeWithIndexTree (mergeITQ cmp)
+
+------------------------------------------------------------------------
+-- $folds
+--
+-- A big part of what makes the heaps fast is that they're non empty,
+-- so the merge function can avoid an extra case match. To take
+-- advantage of this, though, we need specialized versions of 'foldMap'
+-- and 'Data.Sequence.foldMapWithIndex', which can alternate between
+-- calling the faster semigroup-like merge when folding over non empty
+-- structures (like 'Node' and 'Digit'), and the
+-- 'Data.Semirgroup.Option'-like mappend, when folding over structures
+-- which can be empty (like 'FingerTree').
+------------------------------------------------------------------------
+
+-- | A 'foldMap'-like function, specialized to the
+-- 'Data.Semigroup.Option' monoid, which takes advantage of the
+-- internal structure of 'Seq' to avoid wrapping in 'Maybe' at certain
+-- points.
+foldToMaybeTree :: (b -> b -> b) -> (a -> b) -> FingerTree a -> Maybe b
+foldToMaybeTree _ _ EmptyT = Nothing
+foldToMaybeTree _ f (Single xs) = Just (f xs)
+foldToMaybeTree (<+>) f (Deep _ pr m sf) =
+    Just (maybe (pr' <+> sf') ((pr' <+> sf') <+>) m')
+  where
+    pr' = foldDigit (<+>) f pr
+    sf' = foldDigit (<+>) f sf
+    m' = foldToMaybeTree (<+>) (foldNode (<+>) f) m
+{-# INLINE foldToMaybeTree #-}
+
+-- | A 'foldMapWithIndex'-like function, specialized to the
+-- 'Data.Semigroup.Option' monoid, which takes advantage of the
+-- internal structure of 'Seq' to avoid wrapping in 'Maybe' at certain
+-- points.
+foldToMaybeWithIndexTree :: (b -> b -> b)
+                         -> (Int -> Elem y -> b)
+                         -> Int
+                         -> FingerTree (Elem y)
+                         -> Maybe b
+foldToMaybeWithIndexTree = foldToMaybeWithIndexTree'
+  where
+    {-# SPECIALISE foldToMaybeWithIndexTree' :: (b -> b -> b) -> (Int -> Elem y -> b) -> Int -> FingerTree (Elem y) -> Maybe b #-}
+    {-# SPECIALISE foldToMaybeWithIndexTree' :: (b -> b -> b) -> (Int -> Node y -> b) -> Int -> FingerTree (Node y) -> Maybe b #-}
+    foldToMaybeWithIndexTree'
+        :: Sized a
+        => (b -> b -> b) -> (Int -> a -> b) -> Int -> FingerTree a -> Maybe b
+    foldToMaybeWithIndexTree' _ _ !_s EmptyT = Nothing
+    foldToMaybeWithIndexTree' _ f s (Single xs) = Just (f s xs)
+    foldToMaybeWithIndexTree' (<+>) f s (Deep _ pr m sf) =
+        Just (maybe (pr' <+> sf') ((pr' <+> sf') <+>) m')
+      where
+        pr' = digit (<+>) f s pr
+        sf' = digit (<+>) f sPsprm sf
+        m' = foldToMaybeWithIndexTree' (<+>) (node (<+>) f) sPspr m
+        !sPspr = s + size pr
+        !sPsprm = sPspr + size m
+    {-# SPECIALISE digit :: (b -> b -> b) -> (Int -> Elem y -> b) -> Int -> Digit (Elem y) -> b #-}
+    {-# SPECIALISE digit :: (b -> b -> b) -> (Int -> Node y -> b) -> Int -> Digit (Node y) -> b #-}
+    digit
+        :: Sized a
+        => (b -> b -> b) -> (Int -> a -> b) -> Int -> Digit a -> b
+    digit = foldWithIndexDigit
+    {-# SPECIALISE node :: (b -> b -> b) -> (Int -> Elem y -> b) -> Int -> Node (Elem y) -> b #-}
+    {-# SPECIALISE node :: (b -> b -> b) -> (Int -> Node y -> b) -> Int -> Node (Node y) -> b #-}
+    node
+        :: Sized a
+        => (b -> b -> b) -> (Int -> a -> b) -> Int -> Node a -> b
+    node = foldWithIndexNode
+{-# INLINE foldToMaybeWithIndexTree #-}
diff --git a/Data/Sequence/Internal/sorting.md b/Data/Sequence/Internal/sorting.md
new file mode 100644 (file)
index 0000000..86f6716
--- /dev/null
@@ -0,0 +1,252 @@
+# Sorting
+
+## Unstable Sorting
+
+Unstable sorting is performed by a heap sort implementation based on
+pairing heaps.  Because the internal structure of sequences is quite
+varied, it is difficult to get blocks of elements of roughly the same
+length, which would improve merge sort performance.  Pairing heaps,
+on the other hand, are relatively resistant to the effects of merging
+heaps of wildly different sizes, as guaranteed by its amortized
+constant-time merge operation.  Moreover, extensive use of SpecConstr
+transformations can be done on pairing heaps, especially when we're
+only constructing them to immediately be unrolled.
+
+On purely random sequences of length 50000, with no RTS options,
+I get the following statistics, in which heapsort is about 42.5%
+faster:  (all comparisons done with -O2)
+
+Times (ms)        |  min  |  mean  | +/-sd | median |  max
+------------------|-------|--------|-------|--------|-------
+to/from list:     |103.802| 108.572|  7.487| 106.436|143.339
+unstable heapsort:| 60.686|  62.968|  4.275|  61.187| 79.151
+
+Heapsort, it would seem, is less of a memory hog than Data.List.sortBy.
+The gap is narrowed when more memory is available, but heapsort still
+wins, 15% faster, with +RTS -H128m:
+
+Times (ms)        |  min  | mean | +/-sd | median |  max
+------------------|-------|------|-------|--------|-------
+to/from list:     | 42.692|45.074|  2.596|  44.600| 56.601
+unstable heapsort:| 37.100|38.344|  3.043|  37.715| 55.526
+
+In addition, on strictly increasing sequences the gap is even wider
+than normal; heapsort is 68.5% faster with no RTS options:
+
+Times (ms)        |  min  | mean | +/-sd | median |  max
+------------------|-------|------|-------|--------|-------
+to/from list:     | 52.236|53.574|  1.987|  53.034| 62.098
+unstable heapsort:| 16.433|16.919|  0.931|  16.681| 21.622
+
+This may be attributed to the elegant nature of the pairing heap.
+
+wasserman.louis@gmail.com, 7/20/09
+
+----------------------------------------------------------------------
+
+David Feuer wrote an unstable sort for arbitrary traversables,
+https://www.reddit.com/r/haskell/comments/63a4ea/fast_total_sorting_of_arbitrary_traversable/,
+which turned out to be competitive with the unstable sort here.
+Feuer suggested that this indicated some room to improve on the
+unstable sort.
+
+The two main improvements to the original function are a specialize
+pragma on replicateA (this gives a 26.5% speedup) and removal of the
+intermediate list (a further 11.7% speedup). These numbers are all on
+purely random sequences of length 50000:
+
+Times (ms)       | min | est | max |std dev|  r²
+-----------------|-----|-----|-----|-------|-----
+to/from list:    |70.90|72.44|75.07|  2.224|0.998
+7/20/09 heapsort:|59.84|61.44|63.08|  1.554|0.998
+7/20/09 w/pragma:|44.22|45.14|46.25|  1.631|0.998
+4/30/17 heapsort:|38.21|39.86|40.87|  1.203|0.996
+
+It should also be noted that Data.List.sortBy has become
+significantly quicker. Data.List.sortBy also now recognizes strictly
+increasing sequences, making it much quicker for that case:
+
+Times (ms)       | min | est | max |std dev|  r²
+-----------------|-----|-----|-----|-------|-----
+to/from list:    |7.140|7.351|7.634|  0.335|0.993
+7/20/09 heapsort:|19.52|19.78|20.13|  0.445|0.999
+7/20/09 w/pragma:|8.050|8.271|8.514|  0.357|0.995
+4/30/17 heapsort:|7.240|7.612|7.925|  0.389|0.991
+
+Another happy result of the specialization of 'replicateA' is that
+the stable sort seems to speed up by 10-20%, and 'iterateN' looks
+like it's about three times as fast.
+
+mail@doisinkidney.com, 4/30/17
+
+## Stable Sorting
+
+Stable sorting was previously accomplished by converting to a list,
+applying Data.List.sort, and rebuilding the sequence. Data.List.sort is
+designed to maximize laziness, which doesn't apply for Data.Sequence,
+and it can't take advantage of the structure of the finger tree. As a
+result, simply tagging each element with its position, then applying
+the unstable sort (using the tag to discriminate between elements for
+which the comparator is equal) is faster. The current implementation
+doesn't use the actual `unstableSort`: to perform the building of the
+queue and tagging in one pass, a specialized version is used.
+
+The algorithm is effectively the same as the unstable sorts, except
+the queue is constructed while giving each element a tag.
+
+It's quicker than the old implementation (which used Data.List.sort)
+in the general case (all times are on sequences of length 50000):
+
+Times (ms)          | min | est | max |std dev|  r²
+--------------------|-----|-----|-----|-------|-----
+to/from list:       |64.23|64.50|64.81|  0.432|1.000
+1/11/18 stable heap:|38.87|39.40|40.09|  0.457|0.999
+
+Slightly slower in the case of already sorted lists:
+
+Times (ms)          | min | est | max |std dev|  r²
+--------------------|-----|-----|-----|-------|-----
+to/from list:       |6.806|6.861|6.901|  0.234|1.000
+1/11/18 stable heap:|8.211|8.268|8.328|  0.111|1.000
+
+And quicker in the case of lists sorted in reverse:
+
+Times (ms)          | min | est | max |std dev|  r²
+--------------------|-----|-----|-----|-------|-----
+to/from list:       |26.79|28.34|30.55|  1.219|0.988
+1/11/18 stable heap:|9.405|10.13|10.91|  0.670|0.977
+
+Interestingly, the stable sort is now competitive with the unstable:
+
+Times (ms)| min | est | max |std dev|  r²
+----------|-----|-----|-----|-------|-----
+unstable: |34.71|35.10|35.38|  0.845|1.000
+stable:   |38.84|39.22|39.59|  0.564|0.999
+
+And even beats it in the case of already-sorted lists:
+
+Times (ms)| min | est | max |std dev|  r²
+----------|-----|-----|-----|-------|-----
+unstable: |8.457|8.499|8.536|  0.069|1.000
+stable:   |8.160|8.230|8.334|  0.158|0.999
+
+mail@doisinkidney.com, 1/11/18
+
+## sortOn Functions
+
+The `sortOn` and `unstableSortOn` functions perform the Schwartzian transform, however instead of the following implementation:
+
+```haskell
+sortOn f = fmap snd . sortBy (conparing fst) . fmap (\x -> (f x, x))
+```
+
+The `fmap`s are fused manually with the creation of the queue, avoiding the two extra traversals. It still suffers a slowdown of roughly 20%:
+
+Times (ms)     | min | est | max |std dev|  r²
+---------------|-----|-----|-----|-------|-----
+unstableSortOn |43.68|44.58|45.95|  0.677|0.999
+unstableSort   |36.55|37.43|38.33|  0.533|0.999
+sortOn         |48.22|49.03|50.09|  1.110|0.998
+sort           |41.81|43.17|45.31|  1.172|0.996
+
+The heaps are also specialized to avoid the creation of a tuple.
+
+## Other Heaps
+
+The pairing heap seems to particularly suit the structure of the finger tree, as other heaps have not managed to beat it. Specifically, when compared to a skew heap:
+
+```haskell
+unstableSortBy :: (a -> a -> Ordering) -> Seq a -> Seq a
+unstableSortBy cmp (Seq xs) =
+    execState (replicateA (size xs) (popMin cmp)) (toSkew cmp (Seq xs))
+
+data Skew a = Nil | Br a !(Skew a) !(Skew a)
+
+popMin :: (e -> e -> Ordering) -> State (Skew e) e
+popMin cmp = State unrollPQ'
+  where
+    {-# INLINE unrollPQ' #-}
+    unrollPQ' (Br x ls rs) = (mergeSkew cmp ls rs, x)
+
+toSkew :: (e -> e -> Ordering) -> Seq e -> Skew e
+toSkew cmp (Seq xs') = toSkewTree cmp (\(Elem a) -> Br a Nil Nil) xs'
+  where
+    toSkewTree :: (b -> b -> Ordering) -> (a -> Skew b) -> FingerTree a -> Skew b
+    toSkewTree _ _ EmptyT = Nil
+    toSkewTree _ f (Single xs) = f xs
+    toSkewTree cmp f (Deep n pr m sf) = pr' <+> sf' <+> m'
+      where
+        pr' = toSkewDigit cmp f pr
+        sf' = toSkewDigit cmp f sf
+        m' = toSkewTree cmp (toSkewNode cmp f) m
+        (<+>) = mergeSkew cmp
+    toSkewDigit :: (b -> b -> Ordering) -> (a -> Skew b) -> Digit a -> Skew b
+    toSkewDigit cmp f dig =
+        case dig of
+            One a -> f a
+            Two a b -> f a <+> f b
+            Three a b c -> f a <+> f b <+> f c
+            Four a b c d -> (f a <+> f b) <+> (f c <+> f d)
+      where
+        (<+>) = mergeSkew cmp
+    toSkewNode cmp f node =
+        case node of
+            Node2 _ a b -> f a <+> f b
+            Node3 _ a b c -> f a <+> f b <+> f c
+      where
+        (<+>) = mergeSkew cmp
+
+mergeSkew :: (a -> a -> Ordering) -> Skew a -> Skew a -> Skew a
+mergeSkew cmp Nil ys = ys
+mergeSkew cmp xs Nil = xs
+mergeSkew cmp h1@(Br x lx rx) h2@(Br y ly ry)
+  | cmp x y == GT = Br y (mergeSkew cmp h1 ry) ly
+  | otherwise     = Br x (mergeSkew cmp h2 rx) lx
+```
+
+The pairing heap implementation is faster in every aspect:
+
+```
+benchmarking 1000000/unsorted/pairing
+time                 2.005 s    (NaN s .. 2.102 s)
+                     1.000 R²   (0.998 R² .. 1.000 R²)
+mean                 2.069 s    (2.060 s .. 2.075 s)
+std dev              9.340 ms   (0.0 s .. 10.67 ms)
+variance introduced by outliers: 19% (moderately inflated)
+             
+benchmarking 1000000/unsorted/skew
+time                 2.042 s    (1.637 s .. 2.267 s)
+                     0.995 R²   (0.990 R² .. NaN R²)
+mean                 2.165 s    (2.065 s .. 2.217 s)
+std dev              87.10 ms   (0.0 s .. 91.26 ms)
+variance introduced by outliers: 19% (moderately inflated)
+             
+benchmarking 1000000/ascending/pairing
+time                 191.4 ms   (187.8 ms .. 193.5 ms)
+                     1.000 R²   (0.999 R² .. 1.000 R²)
+mean                 197.0 ms   (194.7 ms .. 200.0 ms)
+std dev              3.221 ms   (2.441 ms .. 3.924 ms)
+variance introduced by outliers: 14% (moderately inflated)
+             
+benchmarking 1000000/ascending/skew
+time                 232.3 ms   (227.0 ms .. 238.9 ms)
+                     0.999 R²   (0.997 R² .. 1.000 R²)
+mean                 233.9 ms   (230.6 ms .. 236.2 ms)
+std dev              3.678 ms   (2.790 ms .. 4.777 ms)
+variance introduced by outliers: 14% (moderately inflated)
+             
+benchmarking 1000000/descending/pairing
+time                 204.6 ms   (190.2 ms .. 214.1 ms)
+                     0.998 R²   (0.991 R² .. 1.000 R²)
+mean                 208.4 ms   (204.1 ms .. 210.6 ms)
+std dev              4.051 ms   (1.299 ms .. 5.288 ms)
+variance introduced by outliers: 14% (moderately inflated)
+             
+benchmarking 1000000/descending/skew
+time                 229.9 ms   (212.7 ms .. 240.1 ms)
+                     0.998 R²   (0.996 R² .. 1.000 R²)
+mean                 238.8 ms   (231.3 ms .. 241.4 ms)
+std dev              5.006 ms   (269.0 μs .. 6.151 ms)
+variance introduced by outliers: 16% (moderately inflated)
+```
+
diff --git a/Data/Sequence/sorting.md b/Data/Sequence/sorting.md
deleted file mode 100644 (file)
index d493e40..0000000
+++ /dev/null
@@ -1,108 +0,0 @@
-# Sorting
-
-Data.Sequence exports two methods of sorting: stable and unstable. The stable sort is simply a call to Data.List.Sort, whereas the unstable sort constructs a pairing heap, and uses it to perform heap sort.
-
-The pairing heap seems to particularly suit the structure of the finger tree, as other heaps have not managed to beat it. Specifically, when compared to a skew heap:
-
-```haskell
-unstableSortBy :: (a -> a -> Ordering) -> Seq a -> Seq a
-unstableSortBy cmp (Seq xs) =
-    execState (replicateA (size xs) (popMin cmp)) (toSkew cmp (Seq xs))
-
-data Skew a = Nil | Br a !(Skew a) !(Skew a)
-
-popMin :: (e -> e -> Ordering) -> State (Skew e) e
-popMin cmp = State unrollPQ'
-  where
-    {-# INLINE unrollPQ' #-}
-    unrollPQ' (Br x ls rs) = (mergeSkew cmp ls rs, x)
-
-toSkew :: (e -> e -> Ordering) -> Seq e -> Skew e
-toSkew cmp (Seq xs') = toSkewTree cmp (\(Elem a) -> Br a Nil Nil) xs'
-  where
-    toSkewTree :: (b -> b -> Ordering) -> (a -> Skew b) -> FingerTree a -> Skew b
-    toSkewTree _ _ EmptyT = Nil
-    toSkewTree _ f (Single xs) = f xs
-    toSkewTree cmp f (Deep n pr m sf) = pr' <+> sf' <+> m'
-      where
-        pr' = toSkewDigit cmp f pr
-        sf' = toSkewDigit cmp f sf
-        m' = toSkewTree cmp (toSkewNode cmp f) m
-        (<+>) = mergeSkew cmp
-    toSkewDigit :: (b -> b -> Ordering) -> (a -> Skew b) -> Digit a -> Skew b
-    toSkewDigit cmp f dig =
-        case dig of
-            One a -> f a
-            Two a b -> f a <+> f b
-            Three a b c -> f a <+> f b <+> f c
-            Four a b c d -> (f a <+> f b) <+> (f c <+> f d)
-      where
-        (<+>) = mergeSkew cmp
-    toSkewNode cmp f node =
-        case node of
-            Node2 _ a b -> f a <+> f b
-            Node3 _ a b c -> f a <+> f b <+> f c
-      where
-        (<+>) = mergeSkew cmp
-
-mergeSkew :: (a -> a -> Ordering) -> Skew a -> Skew a -> Skew a
-mergeSkew cmp Nil ys = ys
-mergeSkew cmp xs Nil = xs
-mergeSkew cmp h1@(Br x lx rx) h2@(Br y ly ry)
-  | cmp x y == GT = Br y (mergeSkew cmp h1 ry) ly
-  | otherwise     = Br x (mergeSkew cmp h2 rx) lx
-```
-
-The pairing heap implementation is faster in every aspect:
-
-```
-benchmarking 1000000/unsorted/pairing
-time                 2.005 s    (NaN s .. 2.102 s)
-                     1.000 R²   (0.998 R² .. 1.000 R²)
-mean                 2.069 s    (2.060 s .. 2.075 s)
-std dev              9.340 ms   (0.0 s .. 10.67 ms)
-variance introduced by outliers: 19% (moderately inflated)
-             
-benchmarking 1000000/unsorted/skew
-time                 2.042 s    (1.637 s .. 2.267 s)
-                     0.995 R²   (0.990 R² .. NaN R²)
-mean                 2.165 s    (2.065 s .. 2.217 s)
-std dev              87.10 ms   (0.0 s .. 91.26 ms)
-variance introduced by outliers: 19% (moderately inflated)
-             
-benchmarking 1000000/ascending/pairing
-time                 191.4 ms   (187.8 ms .. 193.5 ms)
-                     1.000 R²   (0.999 R² .. 1.000 R²)
-mean                 197.0 ms   (194.7 ms .. 200.0 ms)
-std dev              3.221 ms   (2.441 ms .. 3.924 ms)
-variance introduced by outliers: 14% (moderately inflated)
-             
-benchmarking 1000000/ascending/skew
-time                 232.3 ms   (227.0 ms .. 238.9 ms)
-                     0.999 R²   (0.997 R² .. 1.000 R²)
-mean                 233.9 ms   (230.6 ms .. 236.2 ms)
-std dev              3.678 ms   (2.790 ms .. 4.777 ms)
-variance introduced by outliers: 14% (moderately inflated)
-             
-benchmarking 1000000/descending/pairing
-time                 204.6 ms   (190.2 ms .. 214.1 ms)
-                     0.998 R²   (0.991 R² .. 1.000 R²)
-mean                 208.4 ms   (204.1 ms .. 210.6 ms)
-std dev              4.051 ms   (1.299 ms .. 5.288 ms)
-variance introduced by outliers: 14% (moderately inflated)
-             
-benchmarking 1000000/descending/skew
-time                 229.9 ms   (212.7 ms .. 240.1 ms)
-                     0.998 R²   (0.996 R² .. 1.000 R²)
-mean                 238.8 ms   (231.3 ms .. 241.4 ms)
-std dev              5.006 ms   (269.0 μs .. 6.151 ms)
-variance introduced by outliers: 16% (moderately inflated)
-```
-
-## Stable Sorting
-
-Stable sorting was previously accomplished by converting to a list, applying Data.List.sort, and rebuilding the sequence. Data.List.sort is designed to maximize laziness, which doesn't apply for Data.Sequence, and it can't take advantage of the structure of the finger tree. As a result, simply tagging each element with its position, then applying the unstable sort (using the tag to discriminate between elements for which the comparator is equal) is faster. The current implementation doesn't use the actual `unstableSort`: to perform the building of the queue and tagging in one pass, a specialized version is used.
-
-Times (ms)            min    est    max  std dev   r²
-to/from list:        64.23  64.50  64.81  0.432  1.000
-1/11/18 stable heap: 38.87  39.40  40.09  0.457  0.999
diff --git a/Utils/Containers/Internal/State.hs b/Utils/Containers/Internal/State.hs
new file mode 100644 (file)
index 0000000..0df0415
--- /dev/null
@@ -0,0 +1,35 @@
+{-# LANGUAGE CPP #-}
+#include "containers.h"
+{-# OPTIONS_HADDOCK hide #-}
+
+-- | A clone of Control.Monad.State.Strict.
+module Utils.Containers.Internal.State where
+
+import Prelude hiding (
+#if MIN_VERSION_base(4,8,0)
+    Applicative
+#endif
+    )
+
+import Control.Monad (ap)
+import Control.Applicative (Applicative(..), liftA)
+
+newtype State s a = State {runState :: s -> (s, a)}
+
+instance Functor (State s) where
+    fmap = liftA
+
+instance Monad (State s) where
+    {-# INLINE return #-}
+    {-# INLINE (>>=) #-}
+    return = pure
+    m >>= k = State $ \ s -> case runState m s of
+        (s', x) -> runState (k x) s'
+
+instance Applicative (State s) where
+    {-# INLINE pure #-}
+    pure x = State $ \ s -> (s, x)
+    (<*>) = ap
+
+execState :: State s a -> s -> a
+execState m x = snd (runState m x)
index 1600c3f..1fc930f 100644 (file)
@@ -157,6 +157,18 @@ main = do
             , bench "1000" $ nf S.unstableSort rs1000
             , bench "10000" $ nf S.unstableSort rs10000]
          ]
+      , bgroup "unstableSortOn"
+         [ bgroup "already sorted"
+            [ bench "10" $ nf S.unstableSortOn id s10
+            , bench "100" $ nf S.unstableSortOn id s100
+            , bench "1000" $ nf S.unstableSortOn id s1000
+            , bench "10000" $ nf S.unstableSortOn id s10000]
+         , bgroup "random"
+            [ bench "10" $ nf S.unstableSortOn id rs10
+            , bench "100" $ nf S.unstableSortOn id rs100
+            , bench "1000" $ nf S.unstableSortOn id rs1000
+            , bench "10000" $ nf S.unstableSortOn id rs10000]
+         ]
       ]
 
 {-
index 1cb3d29..2746294 100644 (file)
@@ -73,12 +73,14 @@ Library
         Data.Graph
         Data.Sequence
         Data.Sequence.Internal
+        Data.Sequence.Internal.Sorting
         Data.Tree
         Utils.Containers.Internal.BitUtil
         Utils.Containers.Internal.BitQueue
         Utils.Containers.Internal.StrictPair
 
     other-modules:
+        Utils.Containers.Internal.State
         Utils.Containers.Internal.StrictFold
         Utils.Containers.Internal.StrictMaybe
         Utils.Containers.Internal.PtrEquality
index 8272ac9..d420b1b 100644 (file)
@@ -23,6 +23,7 @@ import Data.Array (listArray)
 import Data.Foldable (Foldable(foldl, foldl1, foldr, foldr1, foldMap, fold), toList, all, sum, foldl', foldr')
 import Data.Functor ((<$>), (<$))
 import Data.Maybe
+import Data.Function (on)
 import Data.Monoid (Monoid(..), All(..), Endo(..), Dual(..))
 import Data.Traversable (Traversable(traverse), sequenceA)
 import Prelude hiding (
@@ -95,8 +96,10 @@ main = defaultMain
        , testProperty "filter" prop_filter
        , testProperty "sort" prop_sort
        , testProperty "sortBy" prop_sortBy
+       , testProperty "sortOn" prop_sortOn
        , testProperty "unstableSort" prop_unstableSort
        , testProperty "unstableSortBy" prop_unstableSortBy
+       , testProperty "unstableSortOn" prop_unstableSortOn
        , testProperty "index" prop_index
        , testProperty "(!?)" prop_safeIndex
        , testProperty "adjust" prop_adjust
@@ -540,6 +543,16 @@ prop_sortBy xs =
     toList' (sortBy f xs) ~= Data.List.sortBy f (toList xs)
   where f (x1, _) (x2, _) = compare x1 x2
 
+prop_sortOn :: Fun A OrdB -> Seq A -> Bool
+prop_sortOn (Fun _ f) xs =
+    toList' (sortOn f xs) ~= listSortOn f (toList xs)
+  where
+#if MIN_VERSION_base(4,8,0)
+    listSortOn = Data.List.sortOn
+#else
+    listSortOn k = Data.List.sortBy (compare `on` k)
+#endif
+
 prop_unstableSort :: Seq OrdA -> Bool
 prop_unstableSort xs =
     toList' (unstableSort xs) ~= Data.List.sort (toList xs)
@@ -548,6 +561,10 @@ prop_unstableSortBy :: Seq OrdA -> Bool
 prop_unstableSortBy xs =
     toList' (unstableSortBy compare xs) ~= Data.List.sort (toList xs)
 
+prop_unstableSortOn :: Fun A OrdB -> Seq A -> Property
+prop_unstableSortOn (Fun _ f) xs =
+    toList' (unstableSortBy (compare `on` f) xs) === toList' (unstableSortOn f xs)
+
 -- * Indexing
 
 prop_index :: Seq A -> Property