Home My Page Projects Code Snippets Project Openings SML/NJ
 Summary Activity Forums Tracker Lists Tasks Docs Surveys News SCM Files

# SCM Repository

[smlnj] Diff of /smlnj-lib/branches/rt-transition/Util/list-mergesort.sml
 [smlnj] / smlnj-lib / branches / rt-transition / Util / list-mergesort.sml

# Diff of /smlnj-lib/branches/rt-transition/Util/list-mergesort.sml

revision 4069, Tue Jun 9 20:52:48 2015 UTC revision 4070, Thu Jun 11 12:33:25 2015 UTC
# Line 1  Line 1
1  (* listsort.sml  (* list-mergesort.sml
2   *   *
3   * COPYRIGHT (c) 1993 by AT&T Bell Laboratories.  See COPYRIGHT file for details.   * COPYRIGHT (c) 2014 The Fellowship of SML/NJ (http://www.smlnj.org)
* List sorting routines using a smooth applicative merge sort
* Taken from, ML for the Working Programmer, LCPaulson. pg 99-100
5   *)   *)
6
7  structure ListMergeSort : LIST_SORT =  structure ListMergeSort : LIST_SORT =
8    struct    struct
9
10      fun sort (op > : 'a * 'a -> bool) ls = let    (* Given a ">" relation, sort the list into increasing order.  This sort
11            fun merge([],ys) = ys     * detects initial increasing and decreasing runs and thus is linear
12              | merge(xs,[]) = xs     * time on ordered input.
13              | merge(x::xs,y::ys) =     *)
14                  if x > y then y::merge(x::xs,ys) else x::merge(xs,y::ys)      fun sort gt = let
15            fun mergepairs(ls as [l], k) = ls            fun revAppend ([], ys) = ys
16              | mergepairs(l1::l2::ls,k) =              | revAppend (x::xs, ys) = revAppend(xs, x::ys)
17                  if k mod 2 = 1 then l1::l2::ls            fun merge ([], ys, acc) = revAppend(acc, ys)
18                  else mergepairs(merge(l1,l2)::ls, k div 2)              | merge (xs, [], acc) = revAppend(acc, xs)
19              | mergepairs _ = raise LibBase.Impossible "ListSort.sort"              | merge (xs as (x::xr), ys as (y::yr), acc) =
20            fun nextrun(run,[])    = (rev run,[])                  if gt(x, y)
21              | nextrun(run,x::xs) = if x > hd run then nextrun(x::run,xs)                    then merge (xs, yr, y::acc)
22                                     else (rev run,x::xs)                    else merge (xr, ys, x::acc)
23            fun samsorting([], ls, k)    = hd(mergepairs(ls,0))            fun mergeNeighbors ([], yss) = finishPass yss
24              | samsorting(x::xs, ls, k) = let              | mergeNeighbors ([xs], yss) = finishPass (xs::yss)
25                  val (run,tail) = nextrun([x],xs)              | mergeNeighbors (xs1::xs2::xss, yss) =
26                  in samsorting(tail, mergepairs(run::ls,k+1), k+1)                  mergeNeighbors (xss, merge(xs1, xs2, [])::yss)
27                  end            and finishPass [] = []
28                | finishPass [xs] = xs
29                | finishPass xss = mergeNeighbors (xss, [])
30              fun init (prev, [], yss) = mergeNeighbors ([prev]::yss, [])
31                | init (prev, x::xs, yss) = if gt(prev, x)
32                    then runDn (x, xs, [prev], yss)
33                    else runUp (x, xs, [prev], yss)
34              and runUp (prev, [], run, yss) = mergeNeighbors (revAppend(prev::run, [])::yss, [])
35                | runUp (prev, x::xr, run, yss) =
36                    if gt(prev, x)
37                      then init (x, xr, revAppend(prev::run, [])::yss)
38                      else runUp (x, xr, prev::run, yss)
39              and runDn (prev, [], run, yss) = mergeNeighbors ((prev::run)::yss, [])
40                | runDn (prev, x::xr, run, yss) =
41                    if gt(x, prev)
42                      then init (x, xr, (prev::run)::yss)
43                      else runDn (x, xr, prev::run, yss)
44            in            in
45              case ls of [] => [] | _ => samsorting(ls, [], 0)              fn [] => [] | (x::xs) => init(x, xs, [])
46            end            end
47
48      fun uniqueSort cmpfn ls = let    (* Given a comparison function, sort the sequence in ascending order while eliminating
49            open LibBase     * duplicates.  This sort detects initial increasing and decreasing runs and thus is linear
50            fun merge([],ys) = ys     * time on ordered input.
51              | merge(xs,[]) = xs     *)
52              | merge(x::xs,y::ys) =      fun uniqueSort cmp = let
53                  case cmpfn (x,y) of            fun revAppend ([], ys) = ys
54                    GREATER => y::merge(x::xs,ys)              | revAppend (x::xs, ys) = revAppend(xs, x::ys)
55                  | EQUAL   => merge(x::xs,ys)            fun merge ([], ys, acc) = revAppend(acc, ys)
56                  | _       => x::merge(xs,y::ys)              | merge (xs, [], acc) = revAppend(acc, xs)
57            fun mergepairs(ls as [l], k) = ls              | merge (xs as (x::xr), ys as (y::yr), acc) = (
58              | mergepairs(l1::l2::ls,k) =                  case cmp (x, y)
59                  if k mod 2 = 1 then l1::l2::ls                   of LESS => merge (xr, ys, x::acc)
60                  else mergepairs(merge(l1,l2)::ls, k div 2)                    | EQUAL => merge (xr, yr, x::acc)  (* discard duplicate *)
61              | mergepairs _ = raise LibBase.Impossible "ListSort.uniqueSort"                    | GREATER => merge (xs, yr, y::acc)
62            fun nextrun(run,[])    = (rev run,[])                  (* end case *))
63              | nextrun(run,x::xs) =            fun mergeNeighbors ([], yss) = finishPass yss
64                  case cmpfn(x, hd run) of              | mergeNeighbors ([xs], yss) = finishPass (xs::yss)
65                    GREATER => nextrun(x::run,xs)              | mergeNeighbors (xs1::xs2::xss, yss) =
66                  | EQUAL   => nextrun(run,xs)                  mergeNeighbors (xss, merge(xs1, xs2, [])::yss)
67                  | _       => (rev run,x::xs)            and finishPass [] = []
68            fun samsorting([], ls, k)    = hd(mergepairs(ls,0))              | finishPass [xs] = xs
69              | samsorting(x::xs, ls, k) = let              | finishPass xss = mergeNeighbors (xss, [])
70                  val (run,tail) = nextrun([x],xs)            fun init (prev, [], yss) = mergeNeighbors ([prev]::yss, [])
71                  in samsorting(tail, mergepairs(run::ls,k+1), k+1)              | init (prev, x::xs, yss) = (case cmp(prev, x)
72                  end                   of LESS => runUp (x, xs, [prev], yss)
73                      | EQUAL => init (prev, xs, yss) (* discard duplicate *)
74                      | GREATER => runDn (x, xs, [prev], yss)
75                    (* end case *))
76              and runUp (prev, [], run, yss) = mergeNeighbors (revAppend(prev::run, [])::yss, [])
77                | runUp (prev, x::xr, run, yss) = (case cmp (prev, x)
78                     of LESS => runUp (x, xr, prev::run, yss)
79                      | EQUAL => runUp (prev, xr, run, yss) (* discard duplicate *)
80                      | GREATER => init (x, xr, revAppend(prev::run, [])::yss)
81                    (* end case *))
82              and runDn (prev, [], run, yss) = mergeNeighbors ((prev::run)::yss, [])
83                | runDn (prev, x::xr, run, yss) = (case cmp (prev, x)
84                     of LESS => init (x, xr, (prev::run)::yss)
85                      | EQUAL => runDn (prev, xr, run, yss) (* discard duplicate *)
86                      | GREATER => runDn (x, xr, prev::run, yss)
87                    (* end case *))
88            in            in
89              case ls of [] => [] | _ => samsorting(ls, [], 0)              fn [] => [] | (x::xs) => init(x, xs, [])
90            end            end
91
92      (* is the list sorted in ascending order according to the given ">" relation? *)
93      fun sorted (op >) = let      fun sorted (op >) = let
94            fun s (x::(rest as (y::_))) = not(x>y) andalso s rest            fun chk (_, []) = true
95              | s l = true              | chk (x1, x2::xs) = not(x1>x2) andalso chk(x2, xs)
96            in s end            in
97                fn [] => true
98                 | (x::xs) => chk(x, xs)
99              end
100
101    end (* ListMergeSort *)    end (* ListMergeSort *)

Legend:
 Removed from v.4069 changed lines Added in v.4070