CS1 Supervision 3.sml

(* The permutation method I talked about from last time *)

fun allWithOneRemovedStateful []      ys = []
  | allWithOneRemovedStateful (x::xs) ys =
    (x, xs @ ys) :: allWithOneRemovedStateful xs (x::ys);

(* Dude, I do this painfully often. Is there any way
   of avoiding this, given my dislike for pseudo-random
   extra state arguments? *)

fun allWithOneRemoved xs = allWithOneRemovedStateful xs [];

fun prepend x y = x::y

fun permutations [] = [[]]
  | permutations xs = List.concat (
          (* Get the permutations for all Vector.sublists and put the value
          removed back on the head of each permutaton. *)
          map (fn (elem, rest) => map (prepend elem) (permutations rest))
              (allWithOneRemoved xs)
      );

(* Potentially with a proper double-ended queue and clever referencing, the
   append could be made O(1), in which case this would be less inefficient.
   After all, though, I didn't manage to improve upon the original.

   I'm still working on the iterator version with vectors and mutation.
   Here's a *start*, for part of one iteration of Shimon Even's algorithm.
   It's very much a subsystem, not a permuter.

   An outer iterator should run step, keeping track of whether the head
   element is actively moving and if it's not doing the search for the
   new tempoary head. This will keep it amortized O(1). *)

datatype Direction = left | still | right;

fun step index direction vector =
    let val offset      = if direction = left then ~1 else 1
        val target      = index + offset
        val index_v     = ! (Vector.sub (vector, index))
        val target_v    = ! (Vector.sub (vector, target))

    in  Vector.sub (vector, index)  := target_v;
        Vector.sub (vector, target) := index_v;

        if     (#2 index_v < #2 (! (Vector.sub (vector, target + offset))))
        orelse (#2 index_v = 0)
        orelse (#2 index_v = Vector.length vector)
        then   (Vector.sub (vector, target) := (still, #2 target_v); false)
        else   true

    end;


(* The actual work. *)


(* 5.1 *)

(* This is obviously quadratic time as each extractSmallestR call
   takes O(n) from traversing the list, and is called O(n) times. *)

(* 5.2 *)

fun extractSmallestR accum active []      = (active, accum)
  | extractSmallestR accum active (x::xs) =
    (* Two comarisons is probably no slower than one when compared to the list allocation. *)
    extractSmallestR ((Int.max (active, x))::accum) (Int.min (active, x)) xs;

fun extractSmallest []      = raise Match
  | extractSmallest (x::xs) = extractSmallestR [] x xs;

fun selectionSort []  = []
  | selectionSort lst =
    let val (smallest, rest) = extractSmallest lst
    in  smallest :: (selectionSort rest)
    end;

(* Alternatively, Inspired by (but not copied from) the internets *)

fun extractSmallest []      = raise Match
  | extractSmallest (x::xs) = foldl
    (fn (x, (active, rest)) =>
        (Int.min(active, x), Int.max(active, x)::rest)
    ) (x, []) xs;

fun selectionSort []  = []
  | selectionSort lst =
    let val (smallest, rest) = extractSmallest lst
    in  smallest :: (selectionSort rest)
    end;

(* 5.3 *)

(* This is obviously quadratic time as each bubbleOnce call takes O(n) from
   traversing the list, and is called at worst O(n) times.

   This is known because each call can only move an item one place, and an
   item can be displaced by up to n-1 places. *)

(* 5.4 *)

fun bubbleOnceR hasbubbled (x::y::rest) =
        let val (hasbubbled, bubbledRest) = bubbleOnceR hasbubbled ((Int.max (x, y))::rest)
        in  (x > y orelse hasbubbled, (Int.min (x, y))::bubbledRest)
        end
  | bubbleOnceR hasbubbled lst = (hasbubbled, lst);

val bubbleOnce = bubbleOnceR false;

fun bubbleSort lst =
    let val (hasbubbled, lst') = bubbleOnce lst
    in  (if hasbubbled then bubbleSort lst' else lst')
    end;

(* And again, implementing the dynamic length cropping. *)

fun bubbleOnceToNR hasbubbled 0 lst = (hasbubbled, lst)
  | bubbleOnceToNR hasbubbled n (x::y::rest) =
        let val (hasbubbled, bubbledRest) = bubbleOnceToNR hasbubbled (n-1) ((Int.max (x, y))::rest)
        in  (x > y orelse hasbubbled, (Int.min (x, y))::bubbledRest)
        end
  | bubbleOnceToNR hasbubbled n lst = (hasbubbled, lst);

val bubbleOnceToN = bubbleOnceToNR false;

fun bubbleSortR 0 lst = lst
  | bubbleSortR n lst =
    let val (hasbubbled, lst') = bubbleOnceToN n lst
    in  (if hasbubbled then bubbleSortR (n-1) lst' else lst')
    end;

fun bubbleSort' lst = bubbleSortR (length lst) lst;

(* 6.1 *)

datatype Weekday = Monday | Tuesday | Wednesday | Thursday | Friday | Saturday | Sunday;

(* Personally this is of marginal use; a calendar app would much rather work on integer
   forms under modulo and then use a mapping from said integers to strings, which can
   be used for display.

   Constants might be of use; in a language with classes you might rightly be tempted
   to make a Weekday a subclass of the integers, or an integer ABC. This would help
   especially during debugging.

   An advantage of the Weekday datatype is that you are restricted to the 7 choices and
   there isn't the false equivalence of a day to a number. However, I imagine the
   ability of a date program to store types relationally (so that Wednesday and Thursday
   are adjacent) far outweighs this, especially when dealing with the already-difficult
   timezone problems.

   It could well be OK to use this datatype in conjunction with a record type, but it's
   a bit of an annoying abstraction.

   (Also handwritten.) *)


(* 6.2 *)

datatype 'a tree = Lf | Br of ('a * 'a tree * 'a tree);

fun treeSum Lf = 0
  | treeSum (Br (head, left, right)) = head + treeSum left + treeSum right;

(* 6.4 *)

datatype Expression = Number of real
                    | Variable of string
                    | Negation of Expression
                    | Sum of Expression * Expression
                    | Product of Expression * Expression;

(* 6.5 *)

exception NameError string;

fun evaluate (Number n)         = n
  | evaluate (Variable v)       = raise NameError v
  | evaluate (Negation E)       = ~ (evaluate E)
  | evaluate (Sum (E1, E2))     = evaluate E1 + evaluate E2
  | evaluate (Product (E1, E2)) = evaluate E1 * evaluate E2;

infix ++;
infix **;
val ## = Number;
val %% = Variable;
val ~~ = Negation;
val ++ = Sum;
val ** = Product;

evaluate (
    Negation (
        Sum (
            Number 34.0,
            Product (
                Number 76.0,
                Number 2.0
            )
        )
    )
);

evaluate (~~ (##34.0 ++ (##76.0 ** ##2.0)));

~ (34.0 + (76.0 * 2.0));


(* 7.2 *)

datatype 'a tree = Lf | Br of ('a * 'a tree * 'a tree);

exception Subscript;
exception Collision;

fun insert (Lf, 1, w) = Br (w, Lf, Lf)
  | insert (Lf, _, w) = raise Subscript
  | insert (_,  1, w) = raise Collision
  | insert (Br (v, t1, t2), k, w) =
        if k mod 2 = 0
        then Br (v, insert (t1, k div 2, w), t2)
        else Br (v, t1, insert (t2, k div 2, w));

(* 7.5 *)

fun delete Lf k = raise Subscript
  | delete (Br (v, Lf, Lf)) 1 = Lf
  | delete (Br (v, t1, t2)) 1 = raise Subscript
  | delete (Br (v, t1, t2)) k =
        if k mod 2 = 0
        then Br (v, delete t1 (k div 2), t2)
        else Br (v, t1, delete t2 (k div 2));

(* 7.8 *)

fun hdArray Lf = raise Subscript
  | hdArray (Br (v, _, _)) = v;

fun tlArray Lf = raise Subscript
  | tlArray (Br (v, Lf, Lf)) = Lf
  | tlArray (Br (v, t1, t2)) = Br (hdArray t1, t2, tlArray t1);