(* for ML lecture 4 *)

type comparison = Less | Equal | Greater

(* ORDERED_TYPE : signature for the types with *)
(*                  equality and comparability *)

module type ORDERED_TYPE = 
  sig
    type t
    val cmp : t -> t -> comparison
  end

(* MultiSet2: functor from any structure of ORDERED_TYPE *)
(*            to the definition of multiple set of that type *)

module MultiSet2 =
  functor (Elt: ORDERED_TYPE) ->
  struct
    exception Not_Found

    type elem = Elt.t
    type t = Leaf | Node of elem * t * t

    let empty = Leaf

    let rec add set elt =
      match set with
	Leaf -> Node(elt, Leaf, Leaf)
      | Node(e, left, right) as whole ->
	  match Elt.cmp e elt with
	    Less -> Node(e, left, add right elt)
	  | _ -> Node(e, add left elt, right)
	      
    let rec remove_biggest = function
	Leaf -> failwith "remove_biggest"
      |	Node(v, left, Leaf) -> (v, left)
      |	Node(v, left, right) -> 
	  let (m, t) = remove_biggest right in
	  (m, Node(v, left, t))

    let remove_top = function
	Leaf -> failwith "remove_top"
      |	Node(_, left, Leaf) -> left
      |	Node(_, Leaf, right) -> right
      |	Node(_, left, right) ->
	  let (t, newl) = remove_biggest left in
	  Node(t, newl, right)

    let rec remove set elt = match set with
      Leaf -> raise Not_Found
    | Node(top, left, right) as whole ->
	match Elt.cmp elt top with
	  Equal -> remove_top whole
	| Less -> Node(top, remove left elt, right)
	| Greater -> Node(top, left, remove right elt)

    let rec member set elt = match set with
      Leaf -> false
    | Node(top, left, right) ->
	match Elt.cmp elt top with
	  Equal -> true
	| Less -> member left elt
	| Greater -> member right elt
  end

(*
 > module MultiSet2 :
 >   functor (Elt : ORDERED_TYPE) ->
 >     sig
 > 	 exception Not_Found
 > 	 type elem = Elt.t
 > 	 and t = Leaf | Node of elem * t * t
 > 	 val empty : t
 > 	 val add : t -> elem -> t
 > 	 val remove_top : t -> t
 > 	 val remove : t -> Elt.t -> t
 > 	 val member : t -> Elt.t -> bool
 >     end
 >
*)

(* OrderedString : string with normal ordering *)

module OrderedString =
  struct
    type t = string
    let cmp x y = 
      if x = y then Equal
      else if x < y then Less
      else Greater
  end

(*
 > module OrderedString :
 >   sig type t = string val cmp : 'a -> 'a -> comparison end
*)

(* StringSet: multiple set for string *)

module StringSet = MultiSet2(OrderedString)
(*
 > module StringSet :
 >   sig
 >     exception Not_Found
 >     type elem = OrderedString.t
 >     and t = MultiSet2(OrderedString).t = Leaf | Node of elem * t * t
 >     val empty : t
 >     val add : t -> elem -> t
 >     val remove_top : t -> t
 >     val remove : t -> OrderedString.t -> t
 >     val member : t -> OrderedString.t -> bool
 >   end
*)

(* SETFUNCTOR : signature for the functor MultiSet2 *)

module type SETFUNCTOR =
    functor (Elt: ORDERED_TYPE) ->
  sig
    type elem = Elt.t (* not abstract *)
    type t            (* abstract *)
    val empty : t
    val add : t -> elem -> t
    val remove : t -> elem -> t
    val member : t -> elem -> bool
    exception Not_Found
  end

(* AbstractSet2 : abstract version of MultiSet2 *)

module AbstractSet2 = (MultiSet2 : SETFUNCTOR)

(*
 > module AbstractSet2 : SETFUNCTOR
*)
	      
module AbstractStringSet = AbstractSet2(OrderedString)
(*
 > module AbstractStringSet :
 >   sig
 >     type elem = OrderedString.t
 >     and t = AbstractSet2(OrderedString).t
 >     val empty : t
 >     val add : t -> elem -> t
 >     val remove : t -> elem -> t
 >     val member : t -> elem -> bool
 >     exception Not_Found
 >   end
*)

(* NCString: case-ignoring string *)

module NCString =
  struct
    open String
    type t = string
    let cmp x y = 
      let (x', y') = (lowercase x, lowercase y) in
      if x' = y' then Equal
      else if x' < y' then Less
      else Greater
  end
(*
 > module NCString :
 >   sig type t = string val cmp : string -> string -> comparison end
*)

module NCStringSet = AbstractSet2(NCString)
(*
 > module NCStringSet :
 >   sig
 >     type elem = NCString.t
 >     and t = AbstractSet2(NCString).t
 >     val empty : t
 >     val add : t -> elem -> t
 >     val remove : t -> elem -> t
 >     val member : t -> elem -> bool
 >     exception Not_Found
 >   end
*)