(* lists.ML *)
(* Code from ADG's lectures on "Introduction to Functional Programming" *)
(* Based on code by LCP's "ML for the Working Programmer" *)
(* Last modified on Thu Jan 26 17:47:57 1995 by Andy Gordon *)

(* ====================================================================	*)
(* Lecture I: Introduction and Motivation.				*)
(* ====================================================================	*)

fun power (x,k) : real =
  if k=1 then x
  else if k mod 2 = 0
       then   power(x*x, k div 2)
       else x*power(x*x, k div 2);

(* ====================================================================	*)
(* Lecture II: Basic Types and Values in ML.				*)
(* ====================================================================	*)

fun fst(x,y) = x;
fun snd(x,y) = y;

(* ====================================================================	*)
(* Lecture III: Basic List Processing.					*)
(* ====================================================================	*)

fun null [] = true
  | null _ = false;

fun hd (x::xs) = x;
fun tl (x::xs) = xs;

fun take (k, []) = []
  | take (k, x::xs) =
      if k>0 then x::take(k-1,xs) else [];

fun drop (k, []) = []
  | drop (k, x::xs) =
      if k>0 then drop(k-1,xs) else x::xs;

fun combine ([], []) = []
  | combine (x::xs, y::ys) = (x,y) :: combine (xs,ys);

fun split [] = ([],[])
  | split ((x,y)::pairs) =
      let val (xs,ys) = split pairs
      in  (x::xs, y::ys)
      end;

fun nlength [] = 0
  | nlength (x::xs) = 1 + nlength xs;

fun addlen (n,[]) = n
  | addlen (n,x::xs) = addlen (n+1,xs);

fun length xs = addlen(0,xs);

(*membership in a list*)
infix mem;
fun x mem []  =  false
  | x mem (y::l)  =  (x=y) orelse (x mem l);

(*intersection of two sets represented as lists*)
fun inter([],ys) = []
  | inter(x::xs, ys) = 
        if x mem ys then x::inter(xs, ys)
                    else    inter(xs, ys);

(*union of two sets represented as lists*)
fun union([],ys) = ys
  | union(x::xs, ys) =
      union(xs, if x mem ys then ys else x::ys);

(* ====================================================================	*)
(* Lecture IV: Sorting Case Study.					*)
(* ====================================================================	*)

(* --------------------------------------------------------------------	*)
(* Random numbers; Park and Miller, CACM 1988.				*)
(* --------------------------------------------------------------------	*)

local
  val a = 16807.0 and m = 2147483647.0
in
  fun nextrand seed =
  let val t = a*seed
  in  t - m * real(floor(t/m))
  end
  fun truncto k r = 1 + floor((r / m) * (real k))
end;

fun randlist (n,seed,tail) =
  if n=0 then (seed,tail)
  else randlist(n-1, nextrand seed, seed::tail);

val (seed,rs) = randlist(300,1.0,[]);

(*Times on a Sun SPARCstation 5 for sorting 30,000 integers.*)
(*insort rs;		2440s *)
(*quick rs;		8.4s *)
(*quik(rs,[]);		6.8s *)
(*tmergesort rs;	6.0s *)
(*sorting(rs,[],0);	5.4s *)
(*samsort rs;		5.9s *)

(* --------------------------------------------------------------------	*)
(* Insertion sort. 							*)
(* --------------------------------------------------------------------	*)

fun ins (x:real, []) = [x]
  | ins (x:real, y::ys) =
      if x<=y then x::y::ys
	      else    y::ins(x,ys);

fun insort [] = []
  | insort (x::xs) = ins(x, insort xs);

(* --------------------------------------------------------------------	*)
(* Quick sort.								*)
(* --------------------------------------------------------------------	*)

fun quick [] = []
  | quick [x] = [x]
  | quick (a::bs) =
      let fun part (l,r,[]): real list =
		(quick l) @ (a :: quick r)
	    | part (l,r,x::xs) =
		if x<=a then part(x::l, r, xs)
			else part(l, x::r, xs)
      in  part([],[],bs)
      end;

fun quik([], sorted) = sorted
  | quik([x], sorted) = x::sorted
  | quik(a::bs, sorted) =
     let fun part (l,r,[]): real list = quik (l, a::quik(r,sorted))
	   | part (l,r,x::xs) = if x<=a then part(x::l, r, xs)
					else part(l, x::r, xs)
     in  part([],[],bs)
     end;

(* --------------------------------------------------------------------	*)
(* Top-down Merge sort.							*)
(* --------------------------------------------------------------------	*)

fun merge([],ys) = ys : real list
  | merge(xs,[]) = xs
  | merge(x::xs,y::ys) =
      if x<=y then x::merge(xs, y::ys)
	      else y::merge(x::xs, ys);

fun tmergesort [] = []
  | tmergesort [x] = [x]
  | tmergesort xs =
     let val k = length xs div 2
     in  merge (tmergesort (take (k, xs)), tmergesort (drop (k, xs)))
     end;

(* --------------------------------------------------------------------	*)
(* O'Keefe's Bottom-up merge sort.					*)
(*									*)
(* Here's how it works on a 16 element input list [A,B,C,...,O,P].	*)
(* The main function accumulates a list of lists lss, together with	*)
(* a number k, whose binary representation corresponds to the "shape"	*)
(* of lss.  For each element x of the input list, the main function	*)
(* calls mergepairs ([x]::lss, k+1), which performs a number of list	*)
(* merges, of equal length lists, according to k+1. The table shows the	*)
(* sequence of calls to mergepairs, in each row showing k+1, then the	*)
(* number of merges performed, the argument [x]::lss, and the result,	*)
(* if different from the argument.					*)
(*									*)
(*	1   0	[A]							*)
(*     10   1	[B,A]				[AB]			*)
(*     11   0	[C,AB]							*)
(*    100   2	[D,C,AB]			[ABCD]			*)
(*    101   0	[E,ABCD]						*)
(*    110   1	[F,E,ABCD]			[EF,ABCD]		*)
(*    111   0	[G,EF,ABCD]						*)
(*   1000   3	[H,G,EF,ABCD]			[ABCDEFGH]		*)
(*   1001   0	[I,ABCDEFGH]						*)
(*   1010   1	[J,I,ABCDEFGH]			[IJ,ABCDEFGH]		*)
(*   1011   0	[K,IJ,ABCDEFGH]						*)
(*   1100   2	[L,K,IJ,ABCDEFGH]		[IJKL,ABCDEFGH]		*)
(*   1101   0	[M,IJKL,ABCDEFGH]					*)
(*   1110   1	[N,M,IJKL,ABCDEFGH]		[MN,IJKL,ABCDEFGH]	*)
(*   1111   0	[O,MN,IJKL,ABCDEFGH]					*)
(*  10000   4	[P,O,MN,IJKL,ABCDEFGH]		[ABCDEFGHIJKLMNOP]	*)
(*									*)
(* This method avoids building the 16 singletons at once.  Parameter k	*)
(* ensures "even" merging; otherwise merge degenerates to insert.	*)
(* --------------------------------------------------------------------	*)

fun hd (x::xs) = x;

(* First argument is a list of sorted lists, second is its shape. *)
fun mergepairs ([l], k) = [l]
  | mergepairs (ls1::ls2::lss, k) =
      if k mod 2 = 1 then ls1::ls2::lss			(*odd ; do nothing*)
      else mergepairs(merge(ls1,ls2)::lss, k div 2);	(*even*)

fun sorting([], lss, k) = hd(mergepairs(lss,0))
  | sorting(x::xs, lss, k) =
	sorting(xs, mergepairs([x]::lss, k+1), k+1);

(* --------------------------------------------------------------------	*)
(* O'Keefe's smooth merge sort.						*)
(*									*)
(* A sort algorithm is *smooth* if it has linear execution time when	*)
(* its input is nearly sorted, otherwise n log n.			*)
(* It is an adaptation of the bottom-up merge sort above, except that	*)
(* the atoms (i.e., A,B,C,...) of the final sorted list are the		*)
(* ascending runs in the input, rather than singletons from the input.	*)
(* --------------------------------------------------------------------	*)

fun nextrun (run, []) = (rev run, []:real list)
  | nextrun (run, x::xs) =
	if x < hd run then (rev run, x::xs)
		      else nextrun(x::run, xs);

fun samsorting([], ls, k) = hd(mergepairs(ls,0))
  | samsorting(x::xs, ls, k) =
	let val (run,tail) = nextrun([x],xs)
	in  samsorting(tail, mergepairs(run::ls,k+1), k+1)
	end;

fun samsort [] = []
  | samsort xs = samsorting(xs, [], 0);