Sets et Maps avec egalite generique

git-svn-id: svn+ssh://scm.gforge.inria.fr/svn/coq/trunk@121 85f007b7-540e-0410-9357-904b9bb8a0f7

6 files changed, 481 insertions, 2 deletions

diff --git a/lib/gmap.ml b/lib/gmap.ml
new file mode 100644
index 0000000000..beb0a1994e
--- /dev/null
+++ b/lib/gmap.ml
@@ -0,0 +1,109 @@
+(* $Id$ *)
+
+(* Maps using the generic comparison function of ocaml. Code borrowed from
+   the ocaml standard library. *)
+
+    type ('a,'b) t =
+        Empty
+      | Node of ('a,'b) t * 'a * 'b * ('a,'b) t * int
+
+    let empty = Empty
+
+    let height = function
+        Empty -> 0
+      | Node(_,_,_,_,h) -> h
+
+    let create l x d r =
+      let hl = height l and hr = height r in
+      Node(l, x, d, r, (if hl >= hr then hl + 1 else hr + 1))
+
+    let bal l x d r =
+      let hl = match l with Empty -> 0 | Node(_,_,_,_,h) -> h in
+      let hr = match r with Empty -> 0 | Node(_,_,_,_,h) -> h in
+      if hl > hr + 2 then begin
+        match l with
+          Empty -> invalid_arg "Map.bal"
+        | Node(ll, lv, ld, lr, _) ->
+            if height ll >= height lr then
+              create ll lv ld (create lr x d r)
+            else begin
+              match lr with
+                Empty -> invalid_arg "Map.bal"
+              | Node(lrl, lrv, lrd, lrr, _)->
+                  create (create ll lv ld lrl) lrv lrd (create lrr x d r)
+            end
+      end else if hr > hl + 2 then begin
+        match r with
+          Empty -> invalid_arg "Map.bal"
+        | Node(rl, rv, rd, rr, _) ->
+            if height rr >= height rl then
+              create (create l x d rl) rv rd rr
+            else begin
+              match rl with
+                Empty -> invalid_arg "Map.bal"
+              | Node(rll, rlv, rld, rlr, _) ->
+                  create (create l x d rll) rlv rld (create rlr rv rd rr)
+            end
+      end else
+        Node(l, x, d, r, (if hl >= hr then hl + 1 else hr + 1))
+
+    let rec add x data = function
+        Empty ->
+          Node(Empty, x, data, Empty, 1)
+      | Node(l, v, d, r, h) as t ->
+          let c = Pervasives.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)
+
+    let rec find x = function
+        Empty ->
+          raise Not_found
+      | Node(l, v, d, r, _) ->
+          let c = Pervasives.compare x v in
+          if c = 0 then d
+          else find x (if c < 0 then l else r)
+
+    let rec mem x = function
+        Empty ->
+          false
+      | Node(l, v, d, r, _) ->
+          let c = Pervasives.compare x v in
+          c = 0 || mem x (if c < 0 then l else r)
+
+    let rec merge t1 t2 =
+      match (t1, t2) with
+        (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)
+
+    let rec remove x = function
+        Empty ->
+          Empty
+      | Node(l, v, d, r, h) as t ->
+          let c = Pervasives.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)
+
+    let rec iter f = function
+        Empty -> ()
+      | Node(l, v, d, r, _) ->
+          iter f l; f v d; iter f r
+
+    let rec map f = function
+        Empty               -> Empty
+      | Node(l, v, d, r, h) -> Node(map f l, v, f d, map f r, h)
+
+    let rec fold f m accu =
+      match m with
+        Empty -> accu
+      | Node(l, v, d, r, _) ->
+          fold f l (f v d (fold f r accu))
diff --git a/lib/gmap.mli b/lib/gmap.mli
new file mode 100644
index 0000000000..861e730e26
--- /dev/null
+++ b/lib/gmap.mli
@@ -0,0 +1,16 @@
+
+(* $Id$ *)
+
+(* Maps using the generic comparison function of ocaml. Same interface as
+   the module [Map] from the ocaml standard library. *)
+
+type ('a,'b) t
+
+val empty : ('a,'b) t
+val add : 'a -> 'b -> ('a,'b) t -> ('a,'b) t
+val find : 'a -> ('a,'b) t -> 'b
+val remove : 'a -> ('a,'b) t -> ('a,'b) t
+val mem :  'a -> ('a,'b) t -> bool
+val iter : ('a -> 'b -> unit) -> ('a,'b) t -> unit
+val map : ('b -> 'c) -> ('a,'b) t -> ('a,'c) t
+val fold : ('a -> 'b -> 'c -> 'c) -> ('a,'b) t -> 'c -> 'c
diff --git a/lib/gset.ml b/lib/gset.ml
new file mode 100644
index 0000000000..1dc710be0b
--- /dev/null
+++ b/lib/gset.ml
@@ -0,0 +1,235 @@
+
+(* $Id$ *)
+
+(* Sets using the generic comparison function of ocaml. Code borrowed from
+   the ocaml standard library. *)
+
+    type 'a t = Empty | Node of 'a t * 'a * 'a t * int
+
+    (* Sets are represented by balanced binary trees (the heights of the
+       children differ by at most 2 *)
+
+    let height = function
+        Empty -> 0
+      | Node(_, _, _, h) -> h
+
+    (* Creates a new node with left son l, value x and right son r.
+       l and r must be balanced and | height l - height r | <= 2.
+       Inline expansion of height for better speed. *)
+
+    let create l x r =
+      let hl = match l with Empty -> 0 | Node(_,_,_,h) -> h in
+      let hr = match r with Empty -> 0 | Node(_,_,_,h) -> h in
+      Node(l, x, r, (if hl >= hr then hl + 1 else hr + 1))
+
+    (* Same as create, but performs one step of rebalancing if necessary.
+       Assumes l and r balanced.
+       Inline expansion of create for better speed in the most frequent case
+       where no rebalancing is required. *)
+
+    let bal l x r =
+      let hl = match l with Empty -> 0 | Node(_,_,_,h) -> h in
+      let hr = match r with Empty -> 0 | Node(_,_,_,h) -> h in
+      if hl > hr + 2 then begin
+        match l with
+          Empty -> invalid_arg "Set.bal"
+        | Node(ll, lv, lr, _) ->
+            if height ll >= height lr then
+              create ll lv (create lr x r)
+            else begin
+              match lr with
+                Empty -> invalid_arg "Set.bal"
+              | Node(lrl, lrv, lrr, _)->
+                  create (create ll lv lrl) lrv (create lrr x r)
+            end
+      end else if hr > hl + 2 then begin
+        match r with
+          Empty -> invalid_arg "Set.bal"
+        | Node(rl, rv, rr, _) ->
+            if height rr >= height rl then
+              create (create l x rl) rv rr
+            else begin
+              match rl with
+                Empty -> invalid_arg "Set.bal"
+              | Node(rll, rlv, rlr, _) ->
+                  create (create l x rll) rlv (create rlr rv rr)
+            end
+      end else
+        Node(l, x, r, (if hl >= hr then hl + 1 else hr + 1))
+
+    (* Same as bal, but repeat rebalancing until the final result
+       is balanced. *)
+
+    let rec join l x r =
+      match bal l x r with
+        Empty -> invalid_arg "Set.join"
+      | Node(l', x', r', _) as t' ->
+          let d = height l' - height r' in
+          if d < -2 or d > 2 then join l' x' r' else t'
+
+    (* Merge two trees l and r into one.
+       All elements of l must precede the elements of r.
+       Assumes | height l - height r | <= 2. *)
+
+    let rec merge t1 t2 =
+      match (t1, t2) with
+        (Empty, t) -> t
+      | (t, Empty) -> t
+      | (Node(l1, v1, r1, h1), Node(l2, v2, r2, h2)) ->
+          bal l1 v1 (bal (merge r1 l2) v2 r2)
+
+    (* Same as merge, but does not assume anything about l and r. *)
+
+    let rec concat t1 t2 =
+      match (t1, t2) with
+        (Empty, t) -> t
+      | (t, Empty) -> t
+      | (Node(l1, v1, r1, h1), Node(l2, v2, r2, h2)) ->
+          join l1 v1 (join (concat r1 l2) v2 r2)
+
+    (* Splitting *)
+
+    let rec split x = function
+        Empty ->
+          (Empty, None, Empty)
+      | Node(l, v, r, _) ->
+          let c = Pervasives.compare x v in
+          if c = 0 then (l, Some v, r)
+          else if c < 0 then
+            let (ll, vl, rl) = split x l in (ll, vl, join rl v r)
+          else
+            let (lr, vr, rr) = split x r in (join l v lr, vr, rr)
+
+    (* Implementation of the set operations *)
+
+    let empty = Empty
+
+    let is_empty = function Empty -> true | _ -> false
+
+    let rec mem x = function
+        Empty -> false
+      | Node(l, v, r, _) ->
+          let c = Pervasives.compare x v in
+          c = 0 || mem x (if c < 0 then l else r)
+
+    let rec add x = function
+        Empty -> Node(Empty, x, Empty, 1)
+      | Node(l, v, r, _) as t ->
+          let c = Pervasives.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)
+
+    let singleton x = Node(Empty, x, Empty, 1)
+
+    let rec remove x = function
+        Empty -> Empty
+      | Node(l, v, r, _) ->
+          let c = Pervasives.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)
+
+    let rec union s1 s2 =
+      match (s1, s2) with
+        (Empty, t2) -> t2
+      | (t1, Empty) -> t1
+      | (Node(l1, v1, r1, h1), Node(l2, v2, r2, h2)) ->
+          if h1 >= h2 then
+            if h2 = 1 then add v2 s1 else begin
+              let (l2, _, r2) = split v1 s2 in
+              join (union l1 l2) v1 (union r1 r2)
+            end
+          else
+            if h1 = 1 then add v1 s2 else begin
+              let (l1, _, r1) = split v2 s1 in
+              join (union l1 l2) v2 (union r1 r2)
+            end
+
+    let rec inter s1 s2 =
+      match (s1, s2) with
+        (Empty, t2) -> Empty
+      | (t1, Empty) -> Empty
+      | (Node(l1, v1, r1, _), t2) ->
+          match split v1 t2 with
+            (l2, None, r2) ->
+              concat (inter l1 l2) (inter r1 r2)
+          | (l2, Some _, r2) ->
+              join (inter l1 l2) v1 (inter r1 r2)
+
+    let rec diff s1 s2 =
+      match (s1, s2) with
+        (Empty, t2) -> Empty
+      | (t1, Empty) -> t1
+      | (Node(l1, v1, r1, _), t2) ->
+          match split v1 t2 with
+            (l2, None, r2) ->
+              join (diff l1 l2) v1 (diff r1 r2)
+          | (l2, Some _, r2) ->
+              concat (diff l1 l2) (diff r1 r2)
+
+    let rec compare_aux l1 l2 =
+        match (l1, l2) with
+        ([], []) -> 0
+      | ([], _)  -> -1
+      | (_, []) -> 1
+      | (Empty :: t1, Empty :: t2) ->
+          compare_aux t1 t2
+      | (Node(Empty, v1, r1, _) :: t1, Node(Empty, v2, r2, _) :: t2) ->
+          let c = compare v1 v2 in
+          if c <> 0 then c else compare_aux (r1::t1) (r2::t2)
+      | (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)
+
+    let compare s1 s2 =
+      compare_aux [s1] [s2]
+
+    let equal s1 s2 =
+      compare s1 s2 = 0
+
+    let rec subset s1 s2 =
+      match (s1, s2) with
+        Empty, _ ->
+          true
+      | _, Empty ->
+          false
+      | Node (l1, v1, r1, _), (Node (l2, v2, r2, _) as t2) ->
+          let c = Pervasives.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
+
+    let rec iter f = function
+        Empty -> ()
+      | Node(l, v, r, _) -> iter f l; f v; iter f r
+
+    let rec fold f s accu =
+      match s with
+        Empty -> accu
+      | Node(l, v, r, _) -> fold f l (f v (fold f r accu))
+
+    let rec cardinal = function
+        Empty -> 0
+      | Node(l, v, r, _) -> cardinal l + 1 + cardinal r
+
+    let rec elements_aux accu = function
+        Empty -> accu
+      | Node(l, v, r, _) -> elements_aux (v :: elements_aux accu r) l
+
+    let elements s =
+      elements_aux [] s
+
+    let rec min_elt = function
+        Empty -> raise Not_found
+      | Node(Empty, v, r, _) -> v
+      | Node(l, v, r, _) -> min_elt l
+
+    let rec max_elt = function
+        Empty -> raise Not_found
+      | Node(l, v, Empty, _) -> v
+      | Node(l, v, r, _) -> max_elt r
+
+    let choose = min_elt
diff --git a/lib/gset.mli b/lib/gset.mli
new file mode 100644
index 0000000000..645a29cad4
--- /dev/null
+++ b/lib/gset.mli
@@ -0,0 +1,27 @@
+
+(* $Id$ *)
+
+(* Sets using the generic comparison function of ocaml. Same interface as
+   the module [Set] from the ocaml standard library. *)
+
+type 'a t
+
+val empty : 'a t
+val is_empty : 'a t -> bool
+val mem : 'a -> 'a t -> bool
+val add : 'a -> 'a t -> 'a t
+val singleton : 'a -> 'a t
+val remove : 'a -> 'a t -> 'a t
+val union : 'a t -> 'a t -> 'a t
+val inter : 'a t -> 'a t -> 'a t
+val diff : 'a t -> 'a t -> 'a t
+val compare : 'a t -> 'a t -> int
+val equal : 'a t -> 'a t -> bool
+val subset : 'a t -> 'a t -> bool
+val iter : ('a -> unit) -> 'a t -> unit
+val fold : ('a -> 'a -> 'a) -> 'a t -> 'a -> 'a
+val cardinal : 'a t -> int
+val elements : 'a t -> 'a list
+val min_elt : 'a t -> 'a
+val max_elt : 'a t -> 'a
+val choose : 'a t -> 'a
diff --git a/lib/tlm.ml b/lib/tlm.ml
new file mode 100644
index 0000000000..9b61de9336
--- /dev/null
+++ b/lib/tlm.ml
@@ -0,0 +1,92 @@
+
+(* $Id$ *)
+
+(* 1er choix : une liste
+module MySet = struct
+  type 'a t = 'a list
+  let mt = []
+  let add = add_set
+  let rmv = rmv_set
+  let toList l = l
+  let app = List.map
+end
+*)
+
+(* 2 ème choix : un arbre *)
+module MySet = struct
+  type 'a t = 'a Coq_set.t
+  let mt = Coq_set.empty
+  let add = Coq_set.add
+  let rmv = Coq_set.remove
+  let toList = Coq_set.elements
+  let app f l = Coq_set.fold (fun a b -> add (f a) b) l mt
+end
+
+module type MyMapType = sig
+  type ('a, 'b) t
+  val create : unit -> ('a,'b) t
+  val map : ('a,'b) t -> 'a -> 'b
+  val dom : ('a,'b) t -> 'a list
+  val rng : ('a,'b) t -> 'b list
+  val in_dom : ('a,'b) t -> 'a -> bool
+  val add : ('a,'b) t -> 'a * 'b -> ('a,'b) t
+  val remap : ('a,'b) t -> 'a -> 'b -> ('a,'b) t
+  val app : (('a * 'c) -> unit) -> ('a,'c) t -> unit
+  val toList : ('a,'b) t -> ('a * 'b) list
+end;;
+
+module MyMap = (Listmap : MyMapType);;
+
+type ('a,'b) t =
+    NODE of 'b MySet.t * ('a, ('a,'b) t) MyMap.t;;
+
+let create () = NODE(MySet.mt,MyMap.create());;
+
+let map (NODE (_,m)) lbl = MyMap.map m lbl;;
+let xtract (NODE (hereset,_)) = MySet.toList hereset;;
+let dom (NODE (_,m)) = MyMap.dom m;;
+let in_dom (NODE (_,m)) lbl = MyMap.in_dom m lbl;;
+
+let is_empty_node (NODE(a,b)) = (MySet.toList a = []) & (MyMap.toList b = []);;
+
+let assure_arc m lbl =
+    if MyMap.in_dom m lbl then m
+    else MyMap.add m (lbl,NODE (MySet.mt,MyMap.create()))
+;;
+
+let cleanse_arcs (NODE (hereset,m)) =
+let l = MyMap.rng m
+in NODE(hereset,if List.for_all is_empty_node l then MyMap.create() else m)
+;;
+
+let rec at_path f (NODE (hereset,m)) = function
+    [] -> cleanse_arcs(NODE(f hereset,m))
+  | h::t ->
+    let m = assure_arc m h
+    in cleanse_arcs(NODE(hereset,
+                         MyMap.remap m h (at_path f (MyMap.map m h) t)))
+;;
+
+let add tm (path,v) =
+    at_path (fun hereset -> MySet.add v hereset) tm path
+;;
+
+let rmv tm (path,v) =
+    at_path (fun hereset -> MySet.rmv v hereset) tm path
+;;
+
+let app f tlm = 
+ let rec apprec pfx (NODE(hereset,m)) =
+    let path = List.rev pfx
+    in (MySet.app (fun v -> f(path,v)) hereset;
+        MyMap.app (fun (l,tm) -> apprec (l::pfx) tm) m)
+ in apprec [] tlm
+;;
+    
+let toList tlm = 
+ let rec torec pfx (NODE(hereset,m)) =
+    let path = List.rev pfx
+    in List.flatten((List.map (fun v -> (path,v)) (MySet.toList hereset))::
+            (List.map (fun (l,tm) -> torec (l::pfx) tm) (MyMap.toList m)))
+ in torec [] tlm
+;;
diff --git a/lib/tlm.mli b/lib/tlm.mli
index abf1efc671..41af7c1aba 100644
--- a/lib/tlm.mli
+++ b/lib/tlm.mli
@@ -5,14 +5,14 @@ type ('a,'b) t
 
 val create : unit -> ('a,'b) t
 
-(* Work on labels, not on paths *)
+(* Work on labels, not on paths. *)
 
 val map : ('a,'b) t -> 'a -> ('a,'b) t
 val xtract : ('a,'b) t -> 'b list
 val dom : ('a,'b) t -> 'a list
 val in_dom : ('a,'b) t -> 'a -> bool
 
-(* Work on paths, not labels *)
+(* Work on paths, not on labels. *)
 
 val add : ('a,'b) t -> 'a list * 'b -> ('a,'b) t
 val rmv : ('a,'b) t -> ('a list * 'b) -> ('a,'b) t