X-Git-Url: http://matita.cs.unibo.it/gitweb/?a=blobdiff_plain;f=matita%2Fcontribs%2Fformal_topology%2Fbin%2Ftheory_explorer.ml;h=39a021c9dc19abfbe805220c1fb85824248e38a4;hb=2aedc9a14cddce5c5bd86a796ff6ff5a02bf2059;hp=da4bd3cdea0818b1110f7f080b5832b18925624e;hpb=f5fa1028bbaa9092cd86133b923f83945fba6b10;p=helm.git

diff --git a/matita/contribs/formal_topology/bin/theory_explorer.ml b/matita/contribs/formal_topology/bin/theory_explorer.ml
index da4bd3cde..39a021c9d 100644
--- a/matita/contribs/formal_topology/bin/theory_explorer.ml
+++ b/matita/contribs/formal_topology/bin/theory_explorer.ml
@@ -343,6 +343,8 @@ let rec geq_reachable node =
   | (_,_,_,geq)::tl -> geq_reachable node (!geq@tl)
 ;;
 
+exception SameEquivalenceClass of set * equivalence_class * equivalence_class;;
+
 let locate_using_leq to_be_considered_and_now ((repr,_,leq,geq) as node)
  set start
 =
@@ -355,21 +357,30 @@ let locate_using_leq to_be_considered_and_now ((repr,_,leq,geq) as node)
        else if repr=repr' then aux set (node'::already_visited) (!geq'@tl)
        else if leq_reachable node' !leq then
         aux set (node'::already_visited) (!geq'@tl)
+       else if (List.exists (function n -> not (geq_reachable n [node'])) !geq)
+        then
+         aux set (node'::already_visited) tl
        else if test to_be_considered_and_now set SubsetEqual repr repr' then
         begin
-         let sup = remove node sup in
-         let inf =
-          if !geq' = [] then
-           let inf = remove node' inf in
-            if !geq = [] then
-             inf@@node
+         if List.exists (function n -> n===node') !geq then
+          (* We have found two equal nodes! *)
+          raise (SameEquivalenceClass (set,node,node'))
+         else
+          begin
+           let sup = remove node sup in
+           let inf =
+            if !geq' = [] then
+             let inf = remove node' inf in
+              if !geq = [] then
+               inf@@node
+              else
+               inf
             else
              inf
-          else
-           inf
-          in
-           leq_transitive_closure node node';
-           aux (nodes,inf,sup) (node'::already_visited) (!geq'@tl)
+            in
+             leq_transitive_closure node node';
+             aux (nodes,inf,sup) (node'::already_visited) (!geq'@tl)
+          end
         end
        else
         aux set (node'::already_visited) tl
@@ -377,8 +388,6 @@ let locate_using_leq to_be_considered_and_now ((repr,_,leq,geq) as node)
   aux set [] start
 ;;
 
-exception SameEquivalenceClass of set * equivalence_class * equivalence_class;;
-
 let locate_using_geq to_be_considered_and_now ((repr,_,leq,geq) as node)
  set start
 =
@@ -391,6 +400,9 @@ let locate_using_geq to_be_considered_and_now ((repr,_,leq,geq) as node)
        else if repr=repr' then aux set (node'::already_visited) (!leq'@tl)
        else if geq_reachable node' !geq then
         aux set (node'::already_visited) (!leq'@tl)
+       else if (List.exists (function n -> not (leq_reachable n [node'])) !leq)
+        then
+         aux set (node'::already_visited) tl
        else if test to_be_considered_and_now set SupersetEqual repr repr' then
         begin
          if List.exists (function n -> n===node') !leq then
@@ -432,18 +444,23 @@ if not (List.for_all (fun ((_,_,leq,_) as node) -> !leq = [] && let rec check_in
     let node = candidate,[],leq,geq in
     let nodes = nodes@[node] in
     let set = nodes,inf@[node],sup@[node] in
-    let start_inf,start_sup =
+    let set,start_inf,start_sup =
      let repr_node =
       match List.filter (fun (repr',_,_,_) -> repr=repr') nodes with
          [node] -> node
        | _ -> assert false
      in
-inf,sup(*
-     match hecandidate with
-        I -> inf,[repr_node]
-      | C -> [repr_node],sup
-      | M -> inf,sup
-*)
+      match hecandidate,repr with
+         I, I::_ -> raise (SameEquivalenceClass (set,node,repr_node))
+       | I, _ ->
+          add_leq_arc node repr_node;
+          (nodes,remove repr_node inf@[node],sup),inf,sup
+       | C, C::_ -> raise (SameEquivalenceClass (set,node,repr_node))
+       | C, _ ->
+          add_geq_arc node repr_node;
+          (nodes,inf,remove repr_node sup@[node]),inf,sup
+       | M, M::M::_ -> raise (SameEquivalenceClass (set,node,repr_node))
+       | M, _ -> set,inf,sup
     in
     let set =
      locate_using_leq (to_be_considered,Some repr,news) node set start_sup in