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