Working for element only document (with arbitrary paths & negation).

[tatoo.git] / src / auto / ata.ml

diff --git a/src/auto/ata.ml b/src/auto/ata.ml
index f4f11db..275d657 100644 (file)
--- a/src/auto/ata.ml
+++ b/src/auto/ata.ml
@@ -14,27 +14,30 @@
 (***********************************************************************)
 
 (*
-  Time-stamp: <Last modified on 2013-03-05 16:31:57 CET by Kim Nguyen>
+  Time-stamp: <Last modified on 2013-03-05 18:25:03 CET by Kim Nguyen>
 *)
 
 INCLUDE "utils.ml"
 open Format
 open Utils
 
-type move = [ `Left | `Right | `Up1 | `Up2 | `Epsilon ]
+type move = [ `Left | `Right | `Up1 | `Up2 | `Epsilon |`Is1 |`Is2 ]
 type state_ctx = { mutable left : StateSet.t;
              mutable right : StateSet.t;
              mutable up1 : StateSet.t;
              mutable up2 : StateSet.t;
-             mutable epsilon : StateSet.t}
+             mutable epsilon : StateSet.t;
+             mutable is_left : bool;
+             mutable is_root : bool}
 
 type pred_ = move * bool * State.t
-let make_ctx a b c d e =
-  { left = a; right = b; up1 = c; up2 = d; epsilon = e }
+let make_ctx a b c d e f g =
+  { left = a; right = b; up1 = c; up2 = d; epsilon = e; is_left = f; is_root = g }
 
-let print_ctx fmt c = fprintf fmt "{ left : %a; right : %a; up1: %a ; up2 : %a; epsilon : %a }"
+let print_ctx fmt c = fprintf fmt "{ left : %a; right : %a; up1: %a ; up2 : %a; epsilon : %a ; is_left : %b; is_root : %b }"
   StateSet.print c.left StateSet.print c.right StateSet.print c.up1 StateSet.print c.up2
   StateSet.print c.epsilon
+  c.is_left c.is_root
 
 module Move : (Formula.PREDICATE with type data = pred_ and type ctx = state_ctx ) =
 struct
@@ -67,27 +70,40 @@ struct
       | `Epsilon -> Pretty.epsilon, ""
       | `Up1 -> Pretty.up_arrow, Pretty.subscript 1
       | `Up2 -> Pretty.up_arrow, Pretty.subscript 2
+      | `Is1 -> "?", Pretty.subscript 1
+      | `Is2 -> "?", Pretty.subscript 2
     in
     fprintf _str_fmt "%s%s" dir num;
-    State.print _str_fmt s;
+    if s != State.dummy then State.print _str_fmt s;
     let str = _flush_str_fmt () in
-    if b then fprintf ppf "%s" str
-    else Pretty.pp_overline ppf str
-
+    fprintf ppf "%s%s" (if b then "" else Pretty.lnot) str
   let neg p =
     let l, b, s = p.node in
     make (l, not b, s)
+
   exception NegativeAtom of (move*State.t)
+
   let eval ctx p =
     let l, b, s = p.node in
-    if not b then raise (NegativeAtom(l,s));
-    StateSet.mem s begin
-      match l with
-        `Left -> ctx.left
-      | `Right -> ctx.right
-      | `Up1 -> ctx.up1
-      | `Up2 -> ctx.up2
-      | `Epsilon -> ctx.epsilon
+    if s == State.dummy then
+      let dir =
+        match l with
+          | `Is1 -> ctx.is_left
+          | _ -> not ctx.is_left
+      in
+      let res = dir && not ctx.is_root in
+      res && b || (not (b || res))
+    else begin
+      if not b then raise (NegativeAtom(l,s));
+      StateSet.mem s begin
+        match l with
+            `Left -> ctx.left
+          | `Right -> ctx.right
+          | `Up1 -> ctx.up1
+          | `Up2 -> ctx.up2
+          | `Epsilon -> ctx.epsilon
+          | _ -> StateSet.empty
+      end
     end
 end
 
@@ -234,11 +250,13 @@ let normalize_negations auto =
     | Formula.And(f1, f2) -> (if b then SFormula.and_ else SFormula.or_)(flip b f1) (flip b f2)
     | Formula.Atom(a) -> begin
       let l, b', q = Move.node a in
-      if b == b' then begin
+      if q == State.dummy then if b then f else SFormula.not_ f
+      else
+        if b == b' then begin
         (* a appears positively, either no negation or double negation *)
-        if not (Hashtbl.mem memo_state (q,b)) then Queue.add (q,true) todo;
-        SFormula.atom_ (Move.make (l, true, q))
-      end else begin
+          if not (Hashtbl.mem memo_state (q,b)) then Queue.add (q,true) todo;
+          SFormula.atom_ (Move.make (l, true, q))
+        end else begin
         (* need to reverse the atom
            either we have a positive state deep below a negation
            or we have a negative state in a positive formula
@@ -253,10 +271,11 @@ let normalize_negations auto =
             Not_found ->
               (* create a new state and add it to the todo queue *)
               let nq = State.make () in
-              if not (StateSet.mem q auto.bottom_states) then
+              auto.states <- StateSet.add nq auto.states;
+(*              if not (StateSet.mem q auto.bottom_states) then
                 auto.bottom_states <- StateSet.add nq auto.bottom_states;
               if not (StateSet.mem q auto.top_states) then
-                auto.top_states <- StateSet.add nq auto.top_states;
+                auto.top_states <- StateSet.add nq auto.top_states; *)
               Hashtbl.add memo_state (q, false) nq;
               Queue.add (q, false) todo; nq
         in
@@ -276,10 +295,11 @@ let normalize_negations auto =
         Not_found ->
           let nq = if b then q else
               let nq = State.make () in
-              if not (StateSet.mem q auto.bottom_states) then
+              auto.states <- StateSet.add nq auto.states;
+(*              if not (StateSet.mem q auto.bottom_states) then
                 auto.bottom_states <- StateSet.add nq auto.bottom_states;
               if not (StateSet.mem q auto.top_states) then
-                auto.top_states <- StateSet.add nq auto.top_states;
+                auto.top_states <- StateSet.add nq auto.top_states; *)
               nq
           in
           Hashtbl.add memo_state key nq; nq