1signature Listsort =
2sig
3  val sort   : ('a * 'a -> order) -> 'a list -> 'a list
4  val sorted : ('a * 'a -> order) -> 'a list -> bool
5end
6
7
8structure Listsort :> Listsort =
9struct
10
11(** Smooth Applicative Merge Sort, Richard O'Keefe 1982        **)
12(** From L.C. Paulson: ML for the Working Programmer, CUP 1991 **)
13(** Optimized for Moscow ML **)
14
15fun sort ordr []          = []
16  | sort ordr (xs as [_]) = xs
17  | sort ordr (xs as [x1, x2]) =
18    (case ordr(x1, x2) of
19	 GREATER => [x2, x1]
20       | _       => xs)
21  | sort ordr xs =
22    let fun merge []      ys = ys
23          | merge xs      [] = xs
24          | merge (x::xs) (y::ys) =
25            if ordr(x, y) <> GREATER then x :: merge xs (y::ys)
26            else y :: merge (x::xs) ys
27        fun mergepairs l1  []              k = [l1]
28          | mergepairs l1 (ls as (l2::lr)) k =
29            if k mod 2 = 1 then l1::ls
30            else mergepairs (merge l1 l2) lr (k div 2)
31	fun nextrun run []      = (run, [])
32	  | nextrun run (xs as (x::xr)) =
33	    if ordr(x, List.hd run) = LESS then (run, xs)
34	    else nextrun (x::run) xr
35        fun sorting []      ls r = List.hd(mergepairs [] ls 0)
36          | sorting (x::xs) ls r =
37	    let val (revrun, tail) = nextrun [x] xs
38	    in sorting tail (mergepairs (List.rev revrun) ls (r+1)) (r+1) end
39    in sorting xs [] 0 end;
40
41fun sorted ordr []         = true
42  | sorted ordr (y1 :: yr) =
43    let fun h x0 []       = true
44	  | h x0 (x1::xr) = ordr(x0, x1) <> GREATER andalso h x1 xr
45    in h y1 yr end;
46end (* structure Listsort *)
47