[MLton-commit] r5789

[Vesa Karvonen]

Added List.sort and List.stableSort.
----------------------------------------------------------------------

U   mltonlib/trunk/com/ssh/extended-basis/unstable/detail/sequence/list.sml
U   mltonlib/trunk/com/ssh/extended-basis/unstable/extensions.mlb
U   mltonlib/trunk/com/ssh/extended-basis/unstable/public/sequence/list.sig

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

Modified: mltonlib/trunk/com/ssh/extended-basis/unstable/detail/sequence/list.sml
===================================================================
--- mltonlib/trunk/com/ssh/extended-basis/unstable/detail/sequence/list.sml	2007-07-25 04:43:21 UTC (rev 5788)
+++ mltonlib/trunk/com/ssh/extended-basis/unstable/detail/sequence/list.sml	2007-07-25 07:04:26 UTC (rev 5789)
@@ -112,4 +112,55 @@
    fun nubByEq eq =
        rev o foldl (fn (x, ys) =>
                        if exists (Fn.curry eq x) ys then ys else x::ys) []
+   fun revMerge compare (xs, ys) = let
+      fun lp ([],       ys, zs) = (ys, zs)
+        | lp (xs,       [], zs) = (xs, zs)
+        | lp (x::xs, y::ys, zs) =
+          case compare (x, y) of
+             LESS    => lp (xs, y::ys, x::zs)
+           | EQUAL   => lp (x::xs, ys, y::zs)
+           | GREATER => lp (x::xs, ys, y::zs)
+   in
+      revAppend (lp (xs, ys, []))
+   end
+   fun stableSort compare xs = let
+      (* This optimized implementation of merge sort tries to minimize
+       * list reversals by performing reverse merges and flipping the
+       * compare direction as appropriate.
+       *)
+      fun revOdd (w, l) = if Word.isEven w then l else rev l
+      fun merge (r, xsys) =
+          (r+0w1,
+           if Word.isEven r
+           then revMerge compare xsys
+           else revMerge (compare o Pair.swap) (Pair.swap xsys))
+      val finish =
+          fn []    => []
+           | e::es =>
+             revOdd
+                (foldl
+                    (fn ((r1, l1), (r0, l0)) =>
+                        merge (r1, (revOdd (r1-r0, l0), l1)))
+                    e es)
+      fun build (args as ((r0, l0)::(r1, l1)::rest, xs)) =
+          if r0 = r1 then build (merge (r1, (l0, l1))::rest, xs) else push args
+        | build args = push args
+      and push (stack,    []) = finish stack
+        | push (stack, x::xs) = let
+             fun lp (y, ys,    []) = finish ((0w1, y::ys)::stack)
+               | lp (y, ys, x::xs) =
+                 case compare (x, y)
+                  of GREATER => lp (x, y::ys, xs)
+                   | EQUAL   => lp (x, y::ys, xs)
+                   | LESS    =>
+                     build (if null ys
+                            then ((0w1, [y, x])::stack, xs)
+                            else ((0w1, y::ys)::stack, x::xs))
+          in
+             lp (x, [], xs)
+          end
+   in
+      push ([], xs)
+   end
+   val sort = stableSort
 end

Modified: mltonlib/trunk/com/ssh/extended-basis/unstable/extensions.mlb
===================================================================
--- mltonlib/trunk/com/ssh/extended-basis/unstable/extensions.mlb	2007-07-25 04:43:21 UTC (rev 5788)
+++ mltonlib/trunk/com/ssh/extended-basis/unstable/extensions.mlb	2007-07-25 07:04:26 UTC (rev 5789)
@@ -212,6 +212,20 @@
          public/data/option.sig
          detail/data/option.sml
 
+         (* Scalars *)
+         public/numeric/integer.sig
+         public/numeric/int-inf.sig
+         public/numeric/real.sig
+         public/numeric/word.sig
+         detail/numeric/mk-integer-ext.fun
+         detail/numeric/mk-int-inf-ext.fun
+         detail/numeric/mk-real-ext.fun
+         detail/numeric/mk-word-ext.fun
+         detail/ml/common/scalars.sml
+         detail/ml/$(SML_COMPILER)/ints.sml
+         detail/ml/$(SML_COMPILER)/reals.sml
+         detail/ml/$(SML_COMPILER)/words.sml
+
          (* List *)
          public/sequence/list.sig
          detail/sequence/list.sml
@@ -237,20 +251,6 @@
          public/control/exit.sig
          detail/control/exit.sml
 
-         (* Scalars *)
-         public/numeric/integer.sig
-         public/numeric/int-inf.sig
-         public/numeric/real.sig
-         public/numeric/word.sig
-         detail/numeric/mk-integer-ext.fun
-         detail/numeric/mk-int-inf-ext.fun
-         detail/numeric/mk-real-ext.fun
-         detail/numeric/mk-word-ext.fun
-         detail/ml/common/scalars.sml
-         detail/ml/$(SML_COMPILER)/ints.sml
-         detail/ml/$(SML_COMPILER)/reals.sml
-         detail/ml/$(SML_COMPILER)/words.sml
-
          (* MonoSeqs *)
          public/sequence/mono-vector.sig
          public/sequence/mono-vector-slice.sig

Modified: mltonlib/trunk/com/ssh/extended-basis/unstable/public/sequence/list.sig
===================================================================
--- mltonlib/trunk/com/ssh/extended-basis/unstable/public/sequence/list.sig	2007-07-25 04:43:21 UTC (rev 5788)
+++ mltonlib/trunk/com/ssh/extended-basis/unstable/public/sequence/list.sig	2007-07-25 07:04:26 UTC (rev 5789)
@@ -93,7 +93,7 @@
    val unfoldr : ('a -> ('b * 'a) Option.t) -> 'a -> 'b t
    val unfoldr' : ('a -> ('b * 'a) Option.t) -> 'a -> 'b t * 'a
 
-   (** == Extracting sublists == *)
+   (** == Extracting Sublists == *)
 
    val split : 'a t * Int.t -> 'a t Sq.t
    (**
@@ -120,6 +120,14 @@
    val contains : ''a t -> ''a UnPr.t
    (** {contains l x = exists (x <\ op =) l} *)
 
+   (** == Sorted Lists == *)
+
+   val sort : 'a Cmp.t -> 'a t UnOp.t
+   (** Sorts given list to ascending order with respect to given ordering. *)
+
+   val stableSort : 'a Cmp.t -> 'a t UnOp.t
+   (** Like {sort}, but retains the relative ordering of equal elements. *)
+
    (** == Equality == *)
 
    val equal : 'a BinPr.t -> 'a t BinPr.t