(* Lecture 12: Functors *)

(* Exceptions revisited *)

(* Perfect binary trees *)
datatype tree = Empty | Node of tree * tree;
exception NotPerfect;

(* val depth : tree -> int *)
(* raises NotPerfect if tree is not perfect *)
fun depth (Empty) = 0
  | depth (Node(t1,t2)) =
      let
	  val d1 = depth t1
	  and d2 = depth t2
      in
	  if d1 = d2 then d1+1 else raise NotPerfect
      end;

(* val isPerfect : tree -> bool *)
fun isPerfect' (t) =
      (let val _ = depth t in true end)
      handle NotPerfect => false;

(* Equivalently: *)
fun isPerfect (t) = (depth t ; true) handle NotPerfect => false;

(* Value carrying exceptions *)

(* General rewriting *)

signature REWRITE =
sig
  exception Fail of string
  type 'a rewriter = 'a -> 'a (* may raise Fail(reason) *)

  (* infixr THEN ORELSE *)

  val THEN : 'a rewriter * 'a rewriter -> 'a rewriter
  val ID : 'a rewriter
  val ORELSE : 'a rewriter * 'a rewriter -> 'a rewriter
  val FAIL : string -> 'a rewriter
  val TRY : 'a rewriter -> 'a rewriter
  val REPEAT : 'a rewriter -> 'a rewriter
end;

structure Rewrite :> REWRITE =
struct

  exception Fail of string
  type 'a rewriter = 'a -> 'a (* may raise Fail(reason) *)

  infixr THEN ORELSE

  fun (f THEN g) x = g(f(x))
  fun ID x = x
  fun (f ORELSE g) x =
        f x handle Fail(msg1) =>
	  (g x handle Fail(msg2) =>
	    raise Fail("(" ^ msg1 ^ ") and (" ^ msg2 ^ ")"))
  fun FAIL msg x = raise Fail(msg)
  fun TRY f x = (f ORELSE ID) x
  fun REPEAT f x = TRY (f THEN (REPEAT f)) x

end;

datatype regExp
  = Char of char
  | Times of regExp * regExp
  | Epsilon
  | Plus of regExp * regExp
  | Empty
  | Star of regExp;

(* Factoring, using equations *)
(* RS+RT => R(S+T), RS+R => R(S+e), R+RS => R(e+S), RO => O *)
(* Assumes Times has been right-associated *)
(* val factor : regExp rewriter *)
fun factor (Plus(Times(r1,s),Times(r2,t))) =
       if r1 = r2 then Times(r1,Plus(s,t))
       else raise Rewrite.Fail("Left factors disagree")
  | factor (Plus(Times(r1,s),r2)) =
       if r1 = r2 then Times(r1,Plus(s,Epsilon))
       else raise Rewrite.Fail("Right alternative is not an initial segment of left alternative")
  | factor (Plus(r1,Times(r2,s))) =
       if r1 = r2 then Times(r1,Plus(Epsilon,s))
       else raise Rewrite.Fail("Left alternative is not an initial segment of right alternative")
  | factor (Times(r,Empty)) = Empty
  | factor _ = raise Rewrite.Fail("Does not match rule");

fun testFactor (r) =
      (factor(r) ; "OK")
      handle Rewrite.Fail(msg) => "Failure: " ^ msg;

val a = Char(#"a");
val b = Char(#"b");
val t1 = testFactor (a);
val t2 = testFactor (Plus(Times(a,b),Times(a,b)));
val t3 = testFactor (Plus(Times(a,b),Times(b,a)));


fun intPairCompare ((i1,i2), (j1,j2)) =
  (case Int.compare (i1,j1)
     of EQUAL => Int.compare (i2,j2)
      | GREATER => GREATER
      | LESS => LESS);

(* Functors, simple case *)

signature DICT =
sig
  type key = int * int
  type 'a entry = key * 'a

  type 'a dict

  val empty : 'a dict
  val lookup : 'a dict -> key -> 'a option
  val insert : 'a dict * 'a entry -> 'a dict
end;  (* signature DICT *)

(*
structure AssocList :> DICT = struct ... end; 
structure BinarySearchTree :> DICT = struct ... end;
structure RedBlackTree :> DICT = struct ... end;

structure Dict :> DICT = AssocList;
(* or *)
structure Dict :> DICT = BinarySearchTree;
(* or *)
structure Dict :> DICT = RedBlackTree;
*)

signature NQUEENS =
sig 
  val solvable : int -> bool
end;

(*
structure NQueens :> NQUEENS =
struct
 ...
 fun emptyBoard n = initialize n (Dict.empty) (n,n)
 ...
end;

functor NQueens (structure Dict : DICT) : NQUEENS =
struct
 ...
 fun emptyBoard n = initialize n (Dict.empty) (n,n)
 ...
end;

structure NQueens1 :> NQUEENS = NQueens (structure Dict = AssocList);
structure NQueens2 :> NQUEENS = NQueens (structure Dict = BinarySearchTree);
structure NQueens3 :> NQUEENS = NQueens (structure Dict = RedBlackTree);
*)

(* Functors, complex case *)

signature DICT =
sig
  type key   (* to be instantiated *)
  type 'a entry = key * 'a

  type 'a dict  (* abstract type *)

  val empty : 'a dict
  val lookup : 'a dict -> key -> 'a option
  val insert : 'a dict * 'a entry -> 'a dict
end;  (* signature DICT *)

signature INT_DICT = DICT where type key = int;
signature STRING_DICT = DICT where type key = string;

functor BinarySearchTree
  (type key'
   val compare : key' * key' -> order)
  :> DICT where type key = key' =
struct
  type key = key'
  type 'a entry = key * 'a

  datatype 'a tree =
    Empty
  | Node of 'a entry * 'a tree * 'a tree

  type 'a dict = 'a tree

  (* Representation Invariant *)
  (*
     The tree is ordered:
       For every node  Node((key1,datum1), left, right),
       every key in left is LESS than key1, and
       every key in right is GREATER than key1
  *)

  val empty = Empty

  fun lookup tree key =
    let fun lk (Empty) = NONE
	  | lk (Node((key1,datum1), left, right)) =
              (case compare(key,key1)
		 of EQUAL => SOME(datum1)
	          | LESS => lk left
	          | GREATER => lk right)
    in
      lk tree
    end

  fun insert (tree, entry as (key,datum)) =
    (* val ins : 'a dict -> 'a dict *)
    (* ins (tree) inserts entry into tree *)
    let fun ins (Empty) = Node(entry, Empty, Empty)
	  | ins (Node(entry1 as (key1,datum1), left, right)) =
              (case compare(key,key1)
		 of EQUAL => Node(entry, left, right)
	          | LESS => Node(entry1, ins left, right)
                  | GREATER => Node(entry1, left, ins right))
    in 
      ins tree
    end
end;  (* functor BinarySearchTree *)

structure IntDict :> INT_DICT =
  BinarySearchTree (type key' = int
		    val compare = Int.compare);

structure StringDict :> STRING_DICT =
  BinarySearchTree (type key' = string
		    val compare = String.compare);

fun intPairCompare ((i1,i2), (j1,j2)) =
  (case Int.compare (i1,j1)
     of EQUAL => Int.compare (i2,j2)
      | GREATER => GREATER
      | LESS => LESS);

signature BOARD = DICT where type key = int * int;
structure Board :> BOARD =
  BinarySearchTree (type key' = int * int
		    val compare = intPairCompare);

(*
functor NQueens (structure Board : BOARD) : NQUEENS =
struct
 ...
end;
*)