(*
 Oukseh Lee

 Copyright(c) 2000-2004 KAIST/SNU Research On Program Analysis System
 (National Creative Research Initiative Center 1998-2003)
 http://ropas.snu.ac.kr/n

 All rights reserved. This file is distributed under the terms of
 an Open Source License.
*)

(* It contains:
    signatures OrderedType, NSet, NMap
    functors   ListSetFn : OrderedType -> NSet
               OrderedListMapFn : OrderedType -> NMap
               MapFn: OrderedType -> NMap
               SetFn: OrderedType -> NSet
*)


(* Signatures are imported from Ocaml 2.04 *)

open Nml_setmaphash_

signature NSet = sig
    type elt
    type t
    val empty: t
    val is_empty: t -> bool
    val mem: elt -> t -> bool
    val add: elt -> t -> t
    val singleton: elt -> t
    val remove: elt -> t -> t
    val union: t -> t -> t
    val inter: t -> t -> t
    val diff: t -> t -> t
    val compare: t -> t -> int
    val equal: t -> t -> bool
    val subset: t -> t -> bool
    val iter: (elt -> unit) -> t -> unit
    val fold: (elt -> 'a -> 'a) -> t -> 'a -> 'a
    val cardinal: t -> int
    val elements: t -> elt list
    val min_elt: t -> elt
    val max_elt: t -> elt
    val choose: t -> elt
  end

signature NMap = sig
    type key
    type 'a t
    val empty: 'a t
    val add: key -> 'a -> 'a t -> 'a t
    val find: key -> 'a t -> 'a
    val remove: key -> 'a t -> 'a t
    val mem:  key -> 'a t -> bool
    val iter: (key -> 'a -> unit) -> 'a t -> unit
    val map: ('a -> 'b) -> 'a t -> 'b t
    val mapi: (key -> 'a -> 'b) -> 'a t -> 'b t
    val fold: (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b
    val list_of: 'a t -> (key * 'a) list
  end


(* OrderedListMapFn: OrderedType -> Map 

   It gives a map implemented by list.
   A list of ordered list map is assumed ordered.
     for example, [(0,"a"), (1,"b")] is well-formed,
             but, [(1,"a"), (0,"b")] is not.
*) 

functor OrderedListMapFn (K: OrderedType) : NMap 
    where type key = K.t and 'a t = (K.t * 'a) list = struct

  val comp = K.compare

  type key = K.t
  type 'a t = (key * 'a) list

  exception Invalid_map


  val empty = []


  fun add k v [] = [(k,v)]
    | add k v ((h,d)::t) = let val c = K.compare k h in
        if c=0 then (k,v)::t 
        else if c<0 then (k,v)::(h,d)::t
        else (h,d)::(add k v t)
       end

  fun binary_find k [] = None
    | binary_find k l = let
        fun tln 0 l = l
          | tln n (h::t) = tln (n-1) t
          | tln _ _ = raise Invalid_map
        fun search_in l 0 = None
          | search_in ((h,v)::_) 1 = if K.compare k h = 0 then Some v else None
          | search_in l n = let val half = n/2 in
              case tln half l of nil => raise Invalid_map | ((h,v)::t) => let
                val c = K.compare k h
               in if c=0 then Some v
                  else if c<0 then search_in l half
                  else search_in t ((n-1)/2)
               end
             end
       in search_in l (List.length l) end

  fun find k l = case binary_find k l of Some v => v | _ => raise Not_found
  fun mem k l = case binary_find k l of Some _ => true | _ => false

  fun remove k [] = []
    | remove k ((h,d)::t) = let val c = K.compare k h in
        if c<=0 then t else (h,d)::(remove k t)
       end

  fun mem k m = (find k m; true) handle Not_found => false  

  fun iter f [] = ()
    | iter f ((h,d)::t) = (f h d; iter f t)

  fun map f [] = []
    | map f ((h,d)::t) = let val d = f d in (h,d)::(map f t) end
   
  fun mapi f [] = []
    | mapi f ((h,d)::t) = let val d = f h d in (h,d)::(mapi f t) end

  fun fold f [] i = i
    | fold f ((h,d)::t) i = let val i = f h d i in fold f t i end

  fun list_of x = x
end  


(* ListSetFn : OrderedType -> Set *)

functor ListSetFn (K: OrderedType) : NSet where type elt = K.t and t = K.t list = struct
  val comp = K.compare
  type elt = K.t
  type t = elt list

  (* Assume that all sets are well-formed, 
     that is no redundant element in sets *)
 
  val empty = []
  val is_empty = fn [] => true | _ => false
  fun mem x [] = false
    | mem x (h::t) = if comp x h = 0 then true else mem x t
  fun remove x [] = []
    | remove x (h::t) = if comp x h = 0 then t else h::(remove x t)
  fun add x t = if mem x t then t else x::t
  fun singleton x = [x]
  fun union s1 s2 = List.fold_right add s1 s2
  fun inter s1 s2 = List.filter (fn x => mem x s2) s1
  fun diff s1 s2 = List.filter (fn x => not (mem x s2)) s1
  fun subset s1 s2 = (diff s1 s2 = [])
  fun equal s1 s2 = subset s1 s2 && subset s2 s1
  val iter = List.iter
  val fold = List.fold_right
  val for_all = List.for_all
  val exists = List.exists
  val filter = List.filter
  val partition = List.partition
  val cardinal = List.length

  fun elements x = x
  fun min_elt s = case s of
        [] => raise Not_found      
      | (h::nil) => h
      | (h::t) => let val t = min_elt t in if K.compare h t < 0 then h else t end
  fun max_elt s = case s of
        [] => raise Not_found
      | (h::nil) => h
      | (h::t) => let val t = max_elt t in if K.compare h t > 0 then h else t end
  val choose = max_elt

  fun compare s1 s2 = let val (c1,c2) = (cardinal s1,cardinal s2) in
        if c1 <> c2 then Pervasives.compare c1 c2
        else if s1 = [] && s2 = [] then 0
        else let
          fun f [] [] = 0
            | f s1 s2 = let
                val (m1,m2) = (max_elt s1,max_elt s2)
                val c = K.compare m1 m2
               in if c <> 0 then c else f (remove m1 s1) (remove m2 s2) end
         in f s1 s2 end
       end
end


(* SetFn : OrderedType -> Set
   
   imported from Ocaml 3.0 *)




functor SetFn(K: OrderedType) : NSet where type elt = K.t = struct
  type elt = K.t
  type t = Empty | Node of t * elt * t * int

    (* Sets are represented by balanced binary trees (the heights of the
       children differ by at most 2 *)

  exception Invalid_set

  fun height x = case x of Empty => 0 | Node(_,_,_,h) => h

  fun create l x r = let val (hl,hr) = (height l, height r)
                     in Node(l, x, r, if hl >= hr then hl+1 else hr+1) end
 
  fun bal l x r = let val (hl,hr) = (height l, height r) in
        if hl > hr+2 then (case l of Node(ll,lv,lr,_) =>
          if height ll >= height lr then
            create ll lv (create lr x r)
          else (case lr of Node(lrl,lrv,lrr,_) =>
            create (create ll lv lrl) lrv (create lrr x r)
          | _ => raise Invalid_set) | _ => raise Invalid_set)
        else if hr > hl+2 then (case r of Node(rl,rv,rr,_) =>
          if height rr >= height rl then
            create (create l x rl) rv rr
          else (case rl of Node(rll,rlv,rlr,_) =>
            create (create l x rll) rlv (create rlr rv rr)
          | _ => raise Invalid_set ) | _ => raise Invalid_set)
        else
          Node(l,x,r,if hl>=hr then hl+1 else hr+1)
       end

  fun join l x r = case bal l x r of t' as Node(l',x',r',_) => let
        val d = height l' - height r' 
       in 
        if d < -2 || d > 2 then join l' x' r' else t' 
       end
      | _ => raise Invalid_set
 
  fun merge t1 t2 = case (t1, t2) of
        (Empty, t) | (t, Empty) => t
      | (Node(l1, v1, r1, h1), Node(l2, v2, r2, h2)) =>
          bal l1 v1 (bal (merge r1 l2) v2 r2)

  fun concat t1 t2 = case (t1,t2) of
        (Empty, t) | (t, Empty) => t
      | (Node(l1, v1, r1, h1), Node(l2, v2, r2, h2)) =>
          join l1 v1 (join (concat r1 l2) v2 r2)

  fun split x y = case y of 
        Empty => (Empty, None, Empty)
      | Node(l,v,r,_) => let val c = K.compare x v in
          if c=0 then 
            (l, Some v, r)
          else if c<0 then
            let val (ll,vl,rl) = split x l in (ll,vl,join rl v r) end
          else
            let val (lr,vr,rr) = split x r in (join l v lr,vr,rr) end
         end

  val empty = Empty
  fun is_empty x = case x of Empty => true | _ => false
  fun singleton x = Node(Empty, x, Empty, 1)

  fun mem x s = case s of 
        Empty => false 
      | Node(l,v,r,_) => let val c = K.compare x v in 
          if c=0 then true
          else if c<0 then mem x l
          else mem x r
         end

  fun add x s = case s of
        Empty => singleton x
      | t as Node(l,v,r,_) => let val c = K.compare x v in 
          if c=0 then t
          else if c<0 then bal (add x l) v r
          else bal l v (add x r)
         end

  fun remove x s = case s of
        Empty => Empty
      | t as Node(l,v,r,_) => let val c = K.compare x v in 
          if c=0 then merge l r
          else if c<0 then bal (remove x l) v r
          else bal l v (remove x r)
         end

  fun union s1 s2 = case (s1,s2) of
        (Empty,t) | (t,Empty) => t
      | (Node(l1,v1,r1,h1),Node(l2,v2,r2,h2)) =>
          if h1 >= h2 then 
            if h2=1 then
              add v2 s1
            else let val (l2,_,r2)=split v1 s2 in join (union l1 l2) v1 (union r1 r2) end
          else
            if h1=1 then
              add v1 s2
            else let val (l1,_,r1)=split v2 s1 in join (union l1 l2) v1 (union r1 r2) end

  fun inter s1 s2 = case (s1,s2) of
        (Empty,t) | (t,Empty) => Empty
      | (Node(l1,v1,r1,_),t2) => (case split v1 t2 of
           (l2,None,r2) => concat (inter l1 l2) (inter r1 r2)
         | (l2,Some _,r2) => join (inter l1 l2) v1 (inter r1 r2))

  fun diff s1 s2 = case (s1,s2) of
        (Empty,t) => Empty
      | (t,Empty) => t
      | (Node(l1,v1,r1,_),t2) => (case split v1 t2 of
           (l2,None,r2) => join (diff l1 l2) v1 (diff r1 r2)
         | (l2,Some _,r2) => concat (diff l1 l2) (diff r1 r2))

  fun compare_aux l1 l2 = case (l1,l2) of
        ([],[]) => 0
      | ([],_) => -1
      | (_,[]) => 1
      | (Empty::t1, Empty::t2) => compare_aux t1 t2
      | (Node(Empty,v1,r1,_)::t1, Node(Empty,v2,r2,_)::t2) => 
          let val c = K.compare v1 v2 
          in if c<>0 then c else compare_aux (r1::t1) (r2::t2) end
      | (Node(l1,v1,r1,_)::t1,t2) =>
          compare_aux (l1::Node(Empty,v1,r1,0)::t1) t2
      | (t1,Node(l2,v2,r2,_)::t2) =>
          compare_aux t1 (l2::Node(Empty,v2,r2,0)::t2)

  fun compare s1 s2 = compare_aux [s1] [s2]
  
  fun equal s1 s2 = compare s1 s2 = 0

  fun subset s1 s2 = case (s1,s2) of
        (Empty, _) => true
      | (_,Empty) => false
      | (Node(l1,v1,r1,_), t2 as Node(l2,v2,r2,_)) => let val c = K.compare v1 v2 in
           if c=0 then subset l1 l2 && subset r1 r2
           else if c<0 then subset (Node(l1,v1,Empty,0)) l2 && subset r1 t2
           else subset (Node(Empty,v1,r1,0)) r2 && subset l1 t2
          end

  fun iter f = fn
        Empty => ()
      | (Node(l, v, r, _)) => (iter f l; f v; iter f r)


  fun fold f s accu =
      case s of
        Empty => accu
      | Node(l, v, r, _) => fold f l (f v (fold f r accu))

  fun for_all p = fn
        Empty => true
      | (Node(l, v, r, _)) => p v && for_all p l && for_all p r

  fun exists p = fn
        Empty => false
      | (Node(l, v, r, _)) => p v || exists p l || exists p r

  fun filter p s = let 
    fun filt accu = (fn
          Empty => accu
        | (Node(l, v, r, _)) =>
            filt (filt (if p v then add v accu else accu) l) r) in
      filt Empty s end

  fun partition p s = let
      fun part (t, f) = fn
          Empty => (t,f)
        | (Node(l, v, r, _)) =>
            part (part (if p v then (add v t, f) else (t, add v f)) l) r in
      part (Empty, Empty) s end

  fun cardinal Empty = 0
    | cardinal (Node(l, v, r, _)) = cardinal l + 1 + cardinal r

  fun elements_aux accu = fn 
        Empty => accu
      | (Node(l, v, r, _)) => elements_aux (v :: elements_aux accu r) l

  fun elements s =
      elements_aux [] s

  fun min_elt Empty = raise Not_found
    | min_elt (Node(Empty, v, r, _)) = v
    | min_elt (Node(l, v, r, _)) = min_elt l

  fun max_elt Empty = raise Not_found
    | max_elt (Node(l, v, Empty, _)) = v
    | max_elt (Node(l, v, r, _)) = max_elt r

  val choose = min_elt

end


  
(* MapFn : OrderedType -> Map 

   imported from Ocaml 3.0 *)


functor MapFn (K: OrderedType): NMap where type key = K.t = struct
  type key = K.t
  open Map
  structure M = Make(K)
  type 'a t = 'a M.t
  val empty = M.empty
  val add = M.add
  val find = M.find
  val remove = M.remove
  val mem = M.mem
  val iter = M.iter
  val map = M.map
  val fold = M.fold
  fun list_of m = fold (fn k v l => (k,v)::l) m []
  fun height m = fold (fn _ _ n => n+1) m 0
  fun mapi f m = fold (fn k v m => add k (f k v) m) m empty
end

(*
functor MapFn (K: OrderedType): NMap where type key = K.t = struct

  type key = K.t
  type 'a t =
      Empty
    | Node of 'a t * key * 'a * 'a t * int

  val empty = Empty
  exception Invalid_map
   
    fun height x = case x of
        Empty => 0
      | Node(_,_,_,_,h) => h

    fun create l x d r = let 
      val (hl,hr) = (height l,height r) 
     in
      Node(l, x, d, r, if hl >= hr then hl + 1 else hr + 1) 
     end

    fun bal l x d r = let 
      val (hl,hr) = (height l,height r) 
     in
      if hl > hr + 2 then (case l of Node(ll, lv, ld, lr, _) =>
        if height ll >= height lr then
          create ll lv ld (create lr x d r)
        else (case lr of Node(lrl, lrv, lrd, lrr, _) =>
          create (create ll lv ld lrl) lrv lrd (create lrr x d r)
       | _=> raise Invalid_map)
       | _=> raise Invalid_map)
      else if hr > hl + 2 then (case r of Node(rl, rv, rd, rr, _) =>
        if height rr >= height rl then
          create (create l x d rl) rv rd rr
        else (case rl of Node(rll, rlv, rld, rlr, _) =>
          create (create l x d rll) rlv rld (create rlr rv rd rr)
       | _ => raise Invalid_map)
       | _ => raise Invalid_map)
      else
        Node(l, x, d, r, if hl >= hr then hl + 1 else hr + 1)
     end

    fun add x data m = case m of 
        Empty => Node(Empty, x, data, Empty, 1)
      | t as Node(l, v, d, r, h) => let 
           val c = K.compare x v 
          in
           if c = 0 then Node(l, x, data, r, h)
           else if c < 0 then bal (add x data l) v d r
           else bal l v d (add x data r)
          end

    fun find x m = case m of
        Empty => raise Not_found
      | Node(l, v, d, r, _) => let
           val c = K.compare x v 
          in
           if c = 0 then d
           else find x (if c < 0 then l else r)
          end

    fun mem x m = (find x m; true) handle Not_found => false

    fun merge t1 t2 = case (t1, t2) of 
        (Empty, t) => t
      | (t, Empty) => t
      | (Node(l1, v1, d1, r1, h1), Node(l2, v2, d2, r2, h2)) =>
          bal l1 v1 d1 (bal (merge r1 l2) v2 d2 r2)

    fun remove x m = case m of
        Empty => Empty
      | t as Node(l, v, d, r, h) => let 
          val c = K.compare x v 
         in
          if c = 0 then merge l r
          else if c < 0 then bal (remove x l) v d r
          else bal l v d (remove x r)
         end

    fun iter f m = case m of
        Empty => ()
      | Node(l, v, d, r, _) => (iter f l; f v d; iter f r)

    fun map f m = case m of 
        Empty => Empty
      | Node(l, v, d, r, h) => Node(map f l, v, f d, map f r, h)

    fun mapi f m = case m of
        Empty => Empty
      | Node(l, v, d, r, h) => Node(mapi f l, v, f v d, mapi f r, h)

    fun fold f m accu = case m of
        Empty => accu
      | Node(l, v, d, r, _) => fold f l (f v d (fold f r accu))

    fun list_of m = fold (fn k v l => (k,v)::l) m []

end
*)