[hcoop/debian/mlton.git] / mlyacc / src / utils.sml

(* ML-Yacc Parser Generator (c) 1989 Andrew W. Appel, David R. Tarditi *)

(* Implementation of ordered sets using ordered lists and red-black trees.  The
   code for red-black trees was originally written by Norris Boyd, which was
   modified for use here.
*)

(* ordered sets implemented using ordered lists.

   Upper bound running times for functions implemented here:

   app  = O(n)
   card = O(n)
   closure = O(n^2)
   difference = O(n+m), where n,m = the size of the two sets used here.
   empty = O(1)
   exists = O(n)
   find = O(n)
   fold = O(n)
   insert = O(n)
   is_empty = O(1)
   make_list = O(1)
   make_set = O(n^2)
   partition = O(n)
   remove = O(n)
   revfold = O(n)
   select_arb = O(1)
   set_eq = O(n), where n = the cardinality of the smaller set
   set_gt = O(n), ditto
   singleton = O(1)
   union = O(n+m)
*)

functor ListOrdSet(B : sig type elem
                        val gt : elem * elem -> bool
                        val eq : elem * elem -> bool
                    end ) : ORDSET =

struct
 type elem = B.elem
 val elem_gt = B.gt
 val elem_eq = B.eq

 type set = elem list
 exception Select_arb
 val empty = nil

 val insert = fn (key,s) =>
        let fun f (l as (h::t)) =
                 if elem_gt(key,h) then h::(f t)
                 else if elem_eq(key,h) then key::t
                 else key::l
              | f nil = [key]
        in f s
        end

 val select_arb = fn nil => raise Select_arb
                   | a::b => a

 val exists = fn (key,s) =>
        let fun f (h::t) = if elem_gt(key,h) then f t
                           else elem_eq(h,key)
              | f nil = false
        in f s
        end

 val find = fn (key,s) =>
        let fun f (h::t) = if elem_gt(key,h) then f t
                           else if elem_eq(h,key) then SOME h
                           else NONE
              | f nil = NONE
        in f s
        end

 fun revfold f lst init = List.foldl f init lst
 fun fold f lst init = List.foldr f init lst
 val app = List.app

fun set_eq(h::t,h'::t') =
        (case elem_eq(h,h')
          of true => set_eq(t,t')
           | a => a)
  | set_eq(nil,nil) = true
  | set_eq _ = false

fun set_gt(h::t,h'::t') =
        (case elem_gt(h,h')
          of false => (case (elem_eq(h,h'))
                        of true => set_gt(t,t')
                         | a => a)
           |  a => a)
  | set_gt(_::_,nil) = true
  | set_gt _ = false

fun union(a as (h::t),b as (h'::t')) =
          if elem_gt(h',h) then h::union(t,b)
          else if elem_eq(h,h') then h::union(t,t')
          else h'::union(a,t')
  | union(nil,s) = s
  | union(s,nil) = s

val make_list = fn s => s

val is_empty = fn nil => true | _ => false

val make_set = fn l => List.foldr insert [] l

val partition = fn f => fn s =>
    fold (fn (e,(yes,no)) =>
            if (f e) then (e::yes,no) else (e::no,yes)) s (nil,nil)

val remove = fn (e,s) =>
    let fun f (l as (h::t)) = if elem_gt(h,e) then l
                              else if elem_eq(h,e) then t
                              else h::(f t)
          | f nil = nil
    in f s
    end

 (* difference: X-Y *)

 fun difference (nil,_) = nil
   | difference (r,nil) = r
   | difference (a as (h::t),b as (h'::t')) =
          if elem_gt (h',h) then h::difference(t,b)
          else if elem_eq(h',h) then difference(t,t')
          else difference(a,t')

 fun singleton X = [X]

 fun card(S) = fold (fn (a,count) => count+1) S 0

      local
            fun closure'(from, f, result) =
              if is_empty from then result
              else
                let val (more,result) =
                        fold (fn (a,(more',result')) =>
                                let val more = f a
                                    val new = difference(more,result)
                                in (union(more',new),union(result',new))
                                end) from
                                 (empty,result)
                in closure'(more,f,result)
                end
      in
         fun closure(start, f) = closure'(start, f, start)
      end
end

(* ordered set implemented using red-black trees:

   Upper bound running time of the functions below:

   app: O(n)
   card: O(n)
   closure: O(n^2 ln n)
   difference: O(n ln n)
   empty: O(1)
   exists: O(ln n)
   find: O(ln n)
   fold: O(n)
   insert: O(ln n)
   is_empty: O(1)
   make_list: O(n)
   make_set: O(n ln n)
   partition: O(n ln n)
   remove: O(n ln n)
   revfold: O(n)
   select_arb: O(1)
   set_eq: O(n)
   set_gt: O(n)
   singleton: O(1)
   union: O(n ln n)
*)

functor RbOrdSet (B : sig type elem
                         val eq : (elem*elem) -> bool
                         val gt : (elem*elem) -> bool
                     end
                ) : ORDSET =
struct

 type elem = B.elem
 val elem_gt = B.gt
 val elem_eq = B.eq

 datatype Color = RED | BLACK

 abstype set = EMPTY | TREE of (B.elem * Color * set * set)
 with exception Select_arb
      val empty = EMPTY

 fun insert(key,t) =
  let fun f EMPTY = TREE(key,RED,EMPTY,EMPTY)
        | f (TREE(k,BLACK,l,r)) =
            if elem_gt (key,k)
            then case f r
                 of r as TREE(rk,RED, rl as TREE(rlk,RED,rll,rlr),rr) =>
                        (case l
                         of TREE(lk,RED,ll,lr) =>
                                TREE(k,RED,TREE(lk,BLACK,ll,lr),
                                           TREE(rk,BLACK,rl,rr))
                          | _ => TREE(rlk,BLACK,TREE(k,RED,l,rll),
                                                TREE(rk,RED,rlr,rr)))
                  | r as TREE(rk,RED,rl, rr as TREE(rrk,RED,rrl,rrr)) =>
                        (case l
                         of TREE(lk,RED,ll,lr) =>
                                TREE(k,RED,TREE(lk,BLACK,ll,lr),
                                           TREE(rk,BLACK,rl,rr))
                          | _ => TREE(rk,BLACK,TREE(k,RED,l,rl),rr))
                  | r => TREE(k,BLACK,l,r)
            else if elem_gt(k,key)
            then case f l
                 of l as TREE(lk,RED,ll, lr as TREE(lrk,RED,lrl,lrr)) =>
                        (case r
                         of TREE(rk,RED,rl,rr) =>
                                TREE(k,RED,TREE(lk,BLACK,ll,lr),
                                           TREE(rk,BLACK,rl,rr))
                          | _ => TREE(lrk,BLACK,TREE(lk,RED,ll,lrl),
                                                TREE(k,RED,lrr,r)))
                  | l as TREE(lk,RED, ll as TREE(llk,RED,lll,llr), lr) =>
                        (case r
                         of TREE(rk,RED,rl,rr) =>
                                TREE(k,RED,TREE(lk,BLACK,ll,lr),
                                           TREE(rk,BLACK,rl,rr))
                          | _ => TREE(lk,BLACK,ll,TREE(k,RED,lr,r)))
                  | l => TREE(k,BLACK,l,r)
            else TREE(key,BLACK,l,r)
        | f (TREE(k,RED,l,r)) =
            if elem_gt(key,k) then TREE(k,RED,l, f r)
            else if elem_gt(k,key) then TREE(k,RED, f l, r)
            else TREE(key,RED,l,r)
   in case f t
      of TREE(k,RED, l as TREE(_,RED,_,_), r) => TREE(k,BLACK,l,r)
       | TREE(k,RED, l, r as TREE(_,RED,_,_)) => TREE(k,BLACK,l,r)
       | t => t
  end

 fun select_arb (TREE(k,_,l,r)) = k
   | select_arb EMPTY = raise Select_arb

 fun exists(key,t) =
  let fun look EMPTY = false
        | look (TREE(k,_,l,r)) =
                if elem_gt(k,key) then look l
                else if elem_gt(key,k) then look r
                else true
   in look t
   end

 fun find(key,t) =
  let fun look EMPTY = NONE
        | look (TREE(k,_,l,r)) =
                if elem_gt(k,key) then look l
                else if elem_gt(key,k) then look r
                else SOME k
   in look t
  end

  fun revfold f t start =
     let fun scan (EMPTY,value) = value
           | scan (TREE(k,_,l,r),value) = scan(r,f(k,scan(l,value)))
     in scan(t,start)
     end

   fun fold f t start =
        let fun scan(EMPTY,value) = value
              | scan(TREE(k,_,l,r),value) = scan(l,f(k,scan(r,value)))
        in scan(t,start)
        end

   fun app f t =
      let fun scan EMPTY = ()
            | scan(TREE(k,_,l,r)) = (scan l; f k; scan r)
      in scan t
      end

(* equal_tree : test if two trees are equal.  Two trees are equal if
   the set of leaves are equal *)

   fun set_eq (tree1 as (TREE _),tree2 as (TREE _)) =
     let datatype pos = L | R | M
         exception Done
         fun getvalue(stack as ((a,position)::b)) =
            (case a
             of (TREE(k,_,l,r)) =>
                (case position
                 of L => getvalue ((l,L)::(a,M)::b)
                  | M => (k,case r of  EMPTY => b | _ => (a,R)::b)
                  | R => getvalue ((r,L)::b)
                 )
              | EMPTY => getvalue b
             )
            | getvalue(nil) = raise Done
          fun f (nil,nil) = true
            | f (s1 as (_ :: _),s2 as (_ :: _ )) =
                          let val (v1,news1) = getvalue s1
                              and (v2,news2) = getvalue s2
                          in (elem_eq(v1,v2)) andalso f(news1,news2)
                          end
            | f _ = false
      in f ((tree1,L)::nil,(tree2,L)::nil) handle Done => false
      end
    | set_eq (EMPTY,EMPTY) = true
    | set_eq _ = false

   (* gt_tree : Test if tree1 is greater than tree 2 *)

   fun set_gt (tree1,tree2) =
     let datatype pos = L | R | M
         exception Done
         fun getvalue(stack as ((a,position)::b)) =
            (case a
             of (TREE(k,_,l,r)) =>
                (case position
                 of L => getvalue ((l,L)::(a,M)::b)
                  | M => (k,case r of EMPTY => b | _ => (a,R)::b)
                  | R => getvalue ((r,L)::b)
                 )
              | EMPTY => getvalue b
             )
            | getvalue(nil) = raise Done
          fun f (nil,nil) = false
            | f (s1 as (_ :: _),s2 as (_ :: _ )) =
                          let val (v1,news1) = getvalue s1
                              and (v2,news2) = getvalue s2
                          in (elem_gt(v1,v2)) orelse (elem_eq(v1,v2) andalso f(news1,news2))
                          end
            | f (_,nil) = true
            | f (nil,_) = false
      in f ((tree1,L)::nil,(tree2,L)::nil) handle Done => false
      end

      fun is_empty S = (let val _ = select_arb S in false end
                         handle Select_arb => true)

      fun make_list S = fold (op ::) S nil

      fun make_set l = List.foldr insert empty l

      fun partition F S = fold (fn (a,(Yes,No)) =>
                                if F(a) then (insert(a,Yes),No)
                                else (Yes,insert(a,No)))
                             S (empty,empty)

      fun remove(X, XSet) =
             let val (YSet, _) =
                        partition (fn a => not (elem_eq (X, a))) XSet
             in  YSet
             end

      fun difference(Xs, Ys) =
           fold (fn (p as (a,Xs')) =>
                      if exists(a,Ys) then Xs' else insert p)
           Xs empty

      fun singleton X = insert(X,empty)

      fun card(S) = fold (fn (_,count) => count+1) S 0

      fun union(Xs,Ys)= fold insert Ys Xs

      local
            fun closure'(from, f, result) =
              if is_empty from then result
              else
                let val (more,result) =
                        fold (fn (a,(more',result')) =>
                                let val more = f a
                                    val new = difference(more,result)
                                in (union(more',new),union(result',new))
                                end) from
                                 (empty,result)
                in closure'(more,f,result)
                end
      in
         fun closure(start, f) = closure'(start, f, start)
      end
   end
end

(* In utils.sig
signature TABLE =
   sig
        type 'a table
        type key
        val size : 'a table -> int
        val empty: 'a table
        val exists: (key * 'a table) -> bool
        val find : (key * 'a table)  ->  'a option
        val insert: ((key * 'a) * 'a table) -> 'a table
        val make_table : (key * 'a ) list -> 'a table
        val make_list : 'a table -> (key * 'a) list
        val fold : ((key * 'a) * 'b -> 'b) -> 'a table -> 'b -> 'b
   end
*)

functor Table (B : sig type key
                      val gt : (key * key) -> bool
                     end
                ) : TABLE =
struct

 datatype Color = RED | BLACK
 type key = B.key

 abstype 'a table = EMPTY
                  | TREE of ((B.key * 'a ) * Color * 'a table * 'a table)
 with

 val empty = EMPTY

 fun insert(elem as (key,data),t) =
  let val key_gt = fn (a,_) => B.gt(key,a)
      val key_lt = fn (a,_) => B.gt(a,key)
        fun f EMPTY = TREE(elem,RED,EMPTY,EMPTY)
        | f (TREE(k,BLACK,l,r)) =
            if key_gt k
            then case f r
                 of r as TREE(rk,RED, rl as TREE(rlk,RED,rll,rlr),rr) =>
                        (case l
                         of TREE(lk,RED,ll,lr) =>
                                TREE(k,RED,TREE(lk,BLACK,ll,lr),
                                           TREE(rk,BLACK,rl,rr))
                          | _ => TREE(rlk,BLACK,TREE(k,RED,l,rll),
                                                TREE(rk,RED,rlr,rr)))
                  | r as TREE(rk,RED,rl, rr as TREE(rrk,RED,rrl,rrr)) =>
                        (case l
                         of TREE(lk,RED,ll,lr) =>
                                TREE(k,RED,TREE(lk,BLACK,ll,lr),
                                           TREE(rk,BLACK,rl,rr))
                          | _ => TREE(rk,BLACK,TREE(k,RED,l,rl),rr))
                  | r => TREE(k,BLACK,l,r)
            else if key_lt k
            then case f l
                 of l as TREE(lk,RED,ll, lr as TREE(lrk,RED,lrl,lrr)) =>
                        (case r
                         of TREE(rk,RED,rl,rr) =>
                                TREE(k,RED,TREE(lk,BLACK,ll,lr),
                                           TREE(rk,BLACK,rl,rr))
                          | _ => TREE(lrk,BLACK,TREE(lk,RED,ll,lrl),
                                                TREE(k,RED,lrr,r)))
                  | l as TREE(lk,RED, ll as TREE(llk,RED,lll,llr), lr) =>
                        (case r
                         of TREE(rk,RED,rl,rr) =>
                                TREE(k,RED,TREE(lk,BLACK,ll,lr),
                                           TREE(rk,BLACK,rl,rr))
                          | _ => TREE(lk,BLACK,ll,TREE(k,RED,lr,r)))
                  | l => TREE(k,BLACK,l,r)
            else TREE(elem,BLACK,l,r)
        | f (TREE(k,RED,l,r)) =
            if key_gt k then TREE(k,RED,l, f r)
            else if key_lt k then TREE(k,RED, f l, r)
            else TREE(elem,RED,l,r)
   in case f t
      of TREE(k,RED, l as TREE(_,RED,_,_), r) => TREE(k,BLACK,l,r)
       | TREE(k,RED, l, r as TREE(_,RED,_,_)) => TREE(k,BLACK,l,r)
       | t => t
  end

 fun exists(key,t) =
  let fun look EMPTY = false
        | look (TREE((k,_),_,l,r)) =
                if B.gt(k,key) then look l
                else if B.gt(key,k) then look r
                else true
   in look t
   end

 fun find(key,t) =
  let fun look EMPTY = NONE
        | look (TREE((k,data),_,l,r)) =
                if B.gt(k,key) then look l
                else if B.gt(key,k) then look r
                else SOME data
   in look t
  end

  fun fold f t start =
        let fun scan(EMPTY,value) = value
              | scan(TREE(k,_,l,r),value) = scan(l,f(k,scan(r,value)))
        in scan(t,start)
        end

  fun make_table l = List.foldr insert empty l

  fun size S = fold (fn (_,count) => count+1) S 0

  fun make_list table = fold (op ::) table nil

  end
end;

(* assumes that a functor Table with signature TABLE from table.sml is
   in the environment *)

(* In utils.sig
signature HASH =
  sig
    type table
    type elem

    val size : table -> int
    val add : elem * table -> table
    val find : elem * table -> int option
    val exists : elem * table -> bool
    val empty : table
  end
*)

(* hash: creates a hash table of size n which assigns each distinct member
   a unique integer between 0 and n-1 *)

functor Hash(B : sig type elem
                     val gt : elem * elem -> bool
                 end) : HASH =
struct
    type elem=B.elem
    structure HashTable = Table(type key=B.elem
                                val gt = B.gt)

    type table = {count : int, table : int HashTable.table}

    val empty = {count=0,table=HashTable.empty}
    val size = fn {count,table} => count
    val add = fn (e,{count,table}) =>
                {count=count+1,table=HashTable.insert((e,count),table)}
    val find = fn (e,{table,count}) => HashTable.find(e,table)
    val exists = fn (e,{table,count}) => HashTable.exists(e,table)
end;
Commit	Line	Data
7f918cf1 CE	1	(* ML-Yacc Parser Generator (c) 1989 Andrew W. Appel, David R. Tarditi *)
	2
	3	(* Implementation of ordered sets using ordered lists and red-black trees. The
	4	code for red-black trees was originally written by Norris Boyd, which was
	5	modified for use here.
	6	*)
	7
	8	(* ordered sets implemented using ordered lists.
	9
	10	Upper bound running times for functions implemented here:
	11
	12	app = O(n)
	13	card = O(n)
	14	closure = O(n^2)
	15	difference = O(n+m), where n,m = the size of the two sets used here.
	16	empty = O(1)
	17	exists = O(n)
	18	find = O(n)
	19	fold = O(n)
	20	insert = O(n)
	21	is_empty = O(1)
	22	make_list = O(1)
	23	make_set = O(n^2)
	24	partition = O(n)
	25	remove = O(n)
	26	revfold = O(n)
	27	select_arb = O(1)
	28	set_eq = O(n), where n = the cardinality of the smaller set
	29	set_gt = O(n), ditto
	30	singleton = O(1)
	31	union = O(n+m)
	32	*)
	33
	34	functor ListOrdSet(B : sig type elem
	35	val gt : elem * elem -> bool
	36	val eq : elem * elem -> bool
	37	end ) : ORDSET =
	38
	39	struct
	40	type elem = B.elem
	41	val elem_gt = B.gt
	42	val elem_eq = B.eq
	43
	44	type set = elem list
	45	exception Select_arb
	46	val empty = nil
	47
	48	val insert = fn (key,s) =>
	49	let fun f (l as (h::t)) =
	50	if elem_gt(key,h) then h::(f t)
	51	else if elem_eq(key,h) then key::t
	52	else key::l
	53	\| f nil = [key]
	54	in f s
	55	end
	56
	57	val select_arb = fn nil => raise Select_arb
	58	\| a::b => a
	59
	60	val exists = fn (key,s) =>
	61	let fun f (h::t) = if elem_gt(key,h) then f t
	62	else elem_eq(h,key)
	63	\| f nil = false
	64	in f s
65	end
66
67	val find = fn (key,s) =>
68	let fun f (h::t) = if elem_gt(key,h) then f t
69	else if elem_eq(h,key) then SOME h
70	else NONE
71	\| f nil = NONE
72	in f s
73	end
74
75	fun revfold f lst init = List.foldl f init lst
76	fun fold f lst init = List.foldr f init lst
77	val app = List.app
78
79	fun set_eq(h::t,h'::t') =
80	(case elem_eq(h,h')
81	of true => set_eq(t,t')
82	\| a => a)
83	\| set_eq(nil,nil) = true
84	\| set_eq _ = false
85
86	fun set_gt(h::t,h'::t') =
87	(case elem_gt(h,h')
88	of false => (case (elem_eq(h,h'))
89	of true => set_gt(t,t')
90	\| a => a)
91	\| a => a)
92	\| set_gt(_::_,nil) = true
93	\| set_gt _ = false
94
95	fun union(a as (h::t),b as (h'::t')) =
96	if elem_gt(h',h) then h::union(t,b)
97	else if elem_eq(h,h') then h::union(t,t')
98	else h'::union(a,t')
99	\| union(nil,s) = s
100	\| union(s,nil) = s
101
102	val make_list = fn s => s
103
104	val is_empty = fn nil => true \| _ => false
105
106	val make_set = fn l => List.foldr insert [] l
107
108	val partition = fn f => fn s =>
109	fold (fn (e,(yes,no)) =>
110	if (f e) then (e::yes,no) else (e::no,yes)) s (nil,nil)
111
112	val remove = fn (e,s) =>
113	let fun f (l as (h::t)) = if elem_gt(h,e) then l
114	else if elem_eq(h,e) then t
115	else h::(f t)
116	\| f nil = nil
117	in f s
118	end
119
120	(* difference: X-Y *)
121
122	fun difference (nil,_) = nil
123	\| difference (r,nil) = r
124	\| difference (a as (h::t),b as (h'::t')) =
125	if elem_gt (h',h) then h::difference(t,b)
126	else if elem_eq(h',h) then difference(t,t')
127	else difference(a,t')
128
129	fun singleton X = [X]
130
131	fun card(S) = fold (fn (a,count) => count+1) S 0
132
133	local
134	fun closure'(from, f, result) =
135	if is_empty from then result
136	else
137	let val (more,result) =
138	fold (fn (a,(more',result')) =>
139	let val more = f a
140	val new = difference(more,result)
141	in (union(more',new),union(result',new))
142	end) from
143	(empty,result)
144	in closure'(more,f,result)
145	end
146	in
147	fun closure(start, f) = closure'(start, f, start)
148	end
149	end
150
151	(* ordered set implemented using red-black trees:
152
153	Upper bound running time of the functions below:
154
155	app: O(n)
156	card: O(n)
157	closure: O(n^2 ln n)
158	difference: O(n ln n)
159	empty: O(1)
160	exists: O(ln n)
161	find: O(ln n)
162	fold: O(n)
163	insert: O(ln n)
164	is_empty: O(1)
165	make_list: O(n)
166	make_set: O(n ln n)
167	partition: O(n ln n)
168	remove: O(n ln n)
169	revfold: O(n)
170	select_arb: O(1)
171	set_eq: O(n)
172	set_gt: O(n)
173	singleton: O(1)
174	union: O(n ln n)
175	*)
176
177	functor RbOrdSet (B : sig type elem
178	val eq : (elem*elem) -> bool
179	val gt : (elem*elem) -> bool
180	end
181	) : ORDSET =
182	struct
183
184	type elem = B.elem
185	val elem_gt = B.gt
186	val elem_eq = B.eq
187
188	datatype Color = RED \| BLACK
189
190	abstype set = EMPTY \| TREE of (B.elem * Color * set * set)
191	with exception Select_arb
192	val empty = EMPTY
193
194	fun insert(key,t) =
195	let fun f EMPTY = TREE(key,RED,EMPTY,EMPTY)
196	\| f (TREE(k,BLACK,l,r)) =
197	if elem_gt (key,k)
198	then case f r
199	of r as TREE(rk,RED, rl as TREE(rlk,RED,rll,rlr),rr) =>
200	(case l
201	of TREE(lk,RED,ll,lr) =>
202	TREE(k,RED,TREE(lk,BLACK,ll,lr),
203	TREE(rk,BLACK,rl,rr))
204	\| _ => TREE(rlk,BLACK,TREE(k,RED,l,rll),
205	TREE(rk,RED,rlr,rr)))
206	\| r as TREE(rk,RED,rl, rr as TREE(rrk,RED,rrl,rrr)) =>
207	(case l
208	of TREE(lk,RED,ll,lr) =>
209	TREE(k,RED,TREE(lk,BLACK,ll,lr),
210	TREE(rk,BLACK,rl,rr))
211	\| _ => TREE(rk,BLACK,TREE(k,RED,l,rl),rr))
212	\| r => TREE(k,BLACK,l,r)
213	else if elem_gt(k,key)
214	then case f l
215	of l as TREE(lk,RED,ll, lr as TREE(lrk,RED,lrl,lrr)) =>
216	(case r
217	of TREE(rk,RED,rl,rr) =>
218	TREE(k,RED,TREE(lk,BLACK,ll,lr),
219	TREE(rk,BLACK,rl,rr))
220	\| _ => TREE(lrk,BLACK,TREE(lk,RED,ll,lrl),
221	TREE(k,RED,lrr,r)))
222	\| l as TREE(lk,RED, ll as TREE(llk,RED,lll,llr), lr) =>
223	(case r
224	of TREE(rk,RED,rl,rr) =>
225	TREE(k,RED,TREE(lk,BLACK,ll,lr),
226	TREE(rk,BLACK,rl,rr))
227	\| _ => TREE(lk,BLACK,ll,TREE(k,RED,lr,r)))
228	\| l => TREE(k,BLACK,l,r)
229	else TREE(key,BLACK,l,r)
230	\| f (TREE(k,RED,l,r)) =
231	if elem_gt(key,k) then TREE(k,RED,l, f r)
232	else if elem_gt(k,key) then TREE(k,RED, f l, r)
233	else TREE(key,RED,l,r)
234	in case f t
235	of TREE(k,RED, l as TREE(_,RED,_,_), r) => TREE(k,BLACK,l,r)
236	\| TREE(k,RED, l, r as TREE(_,RED,_,_)) => TREE(k,BLACK,l,r)
237	\| t => t
238	end
239
240	fun select_arb (TREE(k,_,l,r)) = k
241	\| select_arb EMPTY = raise Select_arb
242
243	fun exists(key,t) =
244	let fun look EMPTY = false
245	\| look (TREE(k,_,l,r)) =
246	if elem_gt(k,key) then look l
247	else if elem_gt(key,k) then look r
248	else true
249	in look t
250	end
251
252	fun find(key,t) =
253	let fun look EMPTY = NONE
254	\| look (TREE(k,_,l,r)) =
255	if elem_gt(k,key) then look l
256	else if elem_gt(key,k) then look r
257	else SOME k
258	in look t
259	end
260
261	fun revfold f t start =
262	let fun scan (EMPTY,value) = value
263	\| scan (TREE(k,_,l,r),value) = scan(r,f(k,scan(l,value)))
264	in scan(t,start)
265	end
266
267	fun fold f t start =
268	let fun scan(EMPTY,value) = value
269	\| scan(TREE(k,_,l,r),value) = scan(l,f(k,scan(r,value)))
270	in scan(t,start)
271	end
272
273	fun app f t =
274	let fun scan EMPTY = ()
275	\| scan(TREE(k,_,l,r)) = (scan l; f k; scan r)
276	in scan t
277	end
278
279	(* equal_tree : test if two trees are equal. Two trees are equal if
280	the set of leaves are equal *)
281
282	fun set_eq (tree1 as (TREE _),tree2 as (TREE _)) =
283	let datatype pos = L \| R \| M
284	exception Done
285	fun getvalue(stack as ((a,position)::b)) =
286	(case a
287	of (TREE(k,_,l,r)) =>
288	(case position
289	of L => getvalue ((l,L)::(a,M)::b)
290	\| M => (k,case r of EMPTY => b \| _ => (a,R)::b)
291	\| R => getvalue ((r,L)::b)
292	)
293	\| EMPTY => getvalue b
294	)
295	\| getvalue(nil) = raise Done
296	fun f (nil,nil) = true
297	\| f (s1 as (_ :: _),s2 as (_ :: _ )) =
298	let val (v1,news1) = getvalue s1
299	and (v2,news2) = getvalue s2
300	in (elem_eq(v1,v2)) andalso f(news1,news2)
301	end
302	\| f _ = false
303	in f ((tree1,L)::nil,(tree2,L)::nil) handle Done => false
304	end
305	\| set_eq (EMPTY,EMPTY) = true
306	\| set_eq _ = false
307
308	(* gt_tree : Test if tree1 is greater than tree 2 *)
309
310	fun set_gt (tree1,tree2) =
311	let datatype pos = L \| R \| M
312	exception Done
313	fun getvalue(stack as ((a,position)::b)) =
314	(case a
315	of (TREE(k,_,l,r)) =>
316	(case position
317	of L => getvalue ((l,L)::(a,M)::b)
318	\| M => (k,case r of EMPTY => b \| _ => (a,R)::b)
319	\| R => getvalue ((r,L)::b)
320	)
321	\| EMPTY => getvalue b
322	)
323	\| getvalue(nil) = raise Done
324	fun f (nil,nil) = false
325	\| f (s1 as (_ :: _),s2 as (_ :: _ )) =
326	let val (v1,news1) = getvalue s1
327	and (v2,news2) = getvalue s2
328	in (elem_gt(v1,v2)) orelse (elem_eq(v1,v2) andalso f(news1,news2))
329	end
330	\| f (_,nil) = true
331	\| f (nil,_) = false
332	in f ((tree1,L)::nil,(tree2,L)::nil) handle Done => false
333	end
334
335	fun is_empty S = (let val _ = select_arb S in false end
336	handle Select_arb => true)
337
338	fun make_list S = fold (op ::) S nil
339
340	fun make_set l = List.foldr insert empty l
341
342	fun partition F S = fold (fn (a,(Yes,No)) =>
343	if F(a) then (insert(a,Yes),No)
344	else (Yes,insert(a,No)))
345	S (empty,empty)
346
347	fun remove(X, XSet) =
348	let val (YSet, _) =
349	partition (fn a => not (elem_eq (X, a))) XSet
350	in YSet
351	end
352
353	fun difference(Xs, Ys) =
354	fold (fn (p as (a,Xs')) =>
355	if exists(a,Ys) then Xs' else insert p)
356	Xs empty
357
358	fun singleton X = insert(X,empty)
359
360	fun card(S) = fold (fn (_,count) => count+1) S 0
361
362	fun union(Xs,Ys)= fold insert Ys Xs
363
364	local
365	fun closure'(from, f, result) =
366	if is_empty from then result
367	else
368	let val (more,result) =
369	fold (fn (a,(more',result')) =>
370	let val more = f a
371	val new = difference(more,result)
372	in (union(more',new),union(result',new))
373	end) from
374	(empty,result)
375	in closure'(more,f,result)
376	end
377	in
378	fun closure(start, f) = closure'(start, f, start)
379	end
380	end
381	end
382
383	(* In utils.sig
384	signature TABLE =
385	sig
386	type 'a table
387	type key
388	val size : 'a table -> int
389	val empty: 'a table
390	val exists: (key * 'a table) -> bool
391	val find : (key * 'a table) -> 'a option
392	val insert: ((key * 'a) * 'a table) -> 'a table
393	val make_table : (key * 'a ) list -> 'a table
394	val make_list : 'a table -> (key * 'a) list
395	val fold : ((key * 'a) * 'b -> 'b) -> 'a table -> 'b -> 'b
396	end
397	*)
398
399	functor Table (B : sig type key
400	val gt : (key * key) -> bool
401	end
402	) : TABLE =
403	struct
404
405	datatype Color = RED \| BLACK
406	type key = B.key
407
408	abstype 'a table = EMPTY
409	\| TREE of ((B.key * 'a ) * Color * 'a table * 'a table)
410	with
411
412	val empty = EMPTY
413
414	fun insert(elem as (key,data),t) =
415	let val key_gt = fn (a,_) => B.gt(key,a)
416	val key_lt = fn (a,_) => B.gt(a,key)
417	fun f EMPTY = TREE(elem,RED,EMPTY,EMPTY)
418	\| f (TREE(k,BLACK,l,r)) =
419	if key_gt k
420	then case f r
421	of r as TREE(rk,RED, rl as TREE(rlk,RED,rll,rlr),rr) =>
422	(case l
423	of TREE(lk,RED,ll,lr) =>
424	TREE(k,RED,TREE(lk,BLACK,ll,lr),
425	TREE(rk,BLACK,rl,rr))
426	\| _ => TREE(rlk,BLACK,TREE(k,RED,l,rll),
427	TREE(rk,RED,rlr,rr)))
428	\| r as TREE(rk,RED,rl, rr as TREE(rrk,RED,rrl,rrr)) =>
429	(case l
430	of TREE(lk,RED,ll,lr) =>
431	TREE(k,RED,TREE(lk,BLACK,ll,lr),
432	TREE(rk,BLACK,rl,rr))
433	\| _ => TREE(rk,BLACK,TREE(k,RED,l,rl),rr))
434	\| r => TREE(k,BLACK,l,r)
435	else if key_lt k
436	then case f l
437	of l as TREE(lk,RED,ll, lr as TREE(lrk,RED,lrl,lrr)) =>
438	(case r
439	of TREE(rk,RED,rl,rr) =>
440	TREE(k,RED,TREE(lk,BLACK,ll,lr),
441	TREE(rk,BLACK,rl,rr))
442	\| _ => TREE(lrk,BLACK,TREE(lk,RED,ll,lrl),
443	TREE(k,RED,lrr,r)))
444	\| l as TREE(lk,RED, ll as TREE(llk,RED,lll,llr), lr) =>
445	(case r
446	of TREE(rk,RED,rl,rr) =>
447	TREE(k,RED,TREE(lk,BLACK,ll,lr),
448	TREE(rk,BLACK,rl,rr))
449	\| _ => TREE(lk,BLACK,ll,TREE(k,RED,lr,r)))
450	\| l => TREE(k,BLACK,l,r)
451	else TREE(elem,BLACK,l,r)
452	\| f (TREE(k,RED,l,r)) =
453	if key_gt k then TREE(k,RED,l, f r)
454	else if key_lt k then TREE(k,RED, f l, r)
455	else TREE(elem,RED,l,r)
456	in case f t
457	of TREE(k,RED, l as TREE(_,RED,_,_), r) => TREE(k,BLACK,l,r)
458	\| TREE(k,RED, l, r as TREE(_,RED,_,_)) => TREE(k,BLACK,l,r)
459	\| t => t
460	end
461
462	fun exists(key,t) =
463	let fun look EMPTY = false
464	\| look (TREE((k,_),_,l,r)) =
465	if B.gt(k,key) then look l
466	else if B.gt(key,k) then look r
467	else true
468	in look t
469	end
470
471	fun find(key,t) =
472	let fun look EMPTY = NONE
473	\| look (TREE((k,data),_,l,r)) =
474	if B.gt(k,key) then look l
475	else if B.gt(key,k) then look r
476	else SOME data
477	in look t
478	end
479
480	fun fold f t start =
481	let fun scan(EMPTY,value) = value
482	\| scan(TREE(k,_,l,r),value) = scan(l,f(k,scan(r,value)))
483	in scan(t,start)
484	end
485
486	fun make_table l = List.foldr insert empty l
487
488	fun size S = fold (fn (_,count) => count+1) S 0
489
490	fun make_list table = fold (op ::) table nil
491
492	end
493	end;
494
495	(* assumes that a functor Table with signature TABLE from table.sml is
496	in the environment *)
497
498	(* In utils.sig
499	signature HASH =
500	sig
501	type table
502	type elem
503
504	val size : table -> int
505	val add : elem * table -> table
506	val find : elem * table -> int option
507	val exists : elem * table -> bool
508	val empty : table
509	end
510	*)
511
512	(* hash: creates a hash table of size n which assigns each distinct member
513	a unique integer between 0 and n-1 *)
514
515	functor Hash(B : sig type elem
516	val gt : elem * elem -> bool
517	end) : HASH =
518	struct
519	type elem=B.elem
520	structure HashTable = Table(type key=B.elem
521	val gt = B.gt)
522
523	type table = {count : int, table : int HashTable.table}
524
525	val empty = {count=0,table=HashTable.empty}
526	val size = fn {count,table} => count
527	val add = fn (e,{count,table}) =>
528	{count=count+1,table=HashTable.insert((e,count),table)}
529	val find = fn (e,{table,count}) => HashTable.find(e,table)
530	val exists = fn (e,{table,count}) => HashTable.exists(e,table)
531	end;