From: Kim Nguyễn Date: Tue, 5 Mar 2013 15:36:26 +0000 (+0100) Subject: Add a first runtime function. Positive fragment seems to work. X-Git-Tag: v0.1~162 X-Git-Url: http://git.nguyen.vg/gitweb/?p=tatoo.git;a=commitdiff_plain;h=8026ca9faaa968ced3c2e75ca1d6b55f7270ca50 Add a first runtime function. Positive fragment seems to work. Negation of backward axes is buggy. --- diff --git a/src/auto.mlpack b/src/auto.mlpack index af2dae6..5c493b4 100644 --- a/src/auto.mlpack +++ b/src/auto.mlpack @@ -1,4 +1,5 @@ auto/Ata auto/Formula +auto/Eval auto/State auto/StateSet diff --git a/src/auto/ata.ml b/src/auto/ata.ml index 576941d..f4f11db 100644 --- a/src/auto/ata.ml +++ b/src/auto/ata.ml @@ -14,7 +14,7 @@ (***********************************************************************) (* - Time-stamp: + Time-stamp: *) INCLUDE "utils.ml" @@ -29,6 +29,12 @@ type state_ctx = { mutable left : StateSet.t; mutable epsilon : StateSet.t} 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 print_ctx fmt c = fprintf fmt "{ left : %a; right : %a; up1: %a ; up2 : %a; epsilon : %a }" + StateSet.print c.left StateSet.print c.right StateSet.print c.up1 StateSet.print c.up2 + StateSet.print c.epsilon module Move : (Formula.PREDICATE with type data = pred_ and type ctx = state_ctx ) = struct @@ -42,8 +48,6 @@ struct type ctx = state_ctx - let make_ctx a b c d e = - { left = a; right = b; up1 = c; up2 = d; epsilon = e } include Hcons.Make(Node) let _pr_buff = Buffer.create 10 @@ -76,7 +80,7 @@ struct exception NegativeAtom of (move*State.t) let eval ctx p = let l, b, s = p.node in - if b then raise (NegativeAtom(l,s)); + if not b then raise (NegativeAtom(l,s)); StateSet.mem s begin match l with `Left -> ctx.left @@ -91,8 +95,8 @@ module SFormula = Formula.Make(Move) type t = { id : Uid.t; mutable states : StateSet.t; -(* mutable top_states : StateSet.t; - mutable bottom_states: StateSet.t; *) + mutable top_states : StateSet.t; + mutable bottom_states: StateSet.t; mutable selection_states: StateSet.t; transitions: (State.t, (QNameSet.t*SFormula.t) list) Hashtbl.t; } @@ -101,13 +105,22 @@ let next = Uid.make_maker () let create () = { id = next (); states = StateSet.empty; -(* top_states = StateSet.empty; - bottom_states = StateSet.empty; *) + top_states = StateSet.empty; + bottom_states = StateSet.empty; selection_states = StateSet.empty; transitions = Hashtbl.create 17; } +let get_trans a states tag = + StateSet.fold (fun q acc0 -> + try + let trs = Hashtbl.find a.transitions q in + List.fold_left (fun acc1 (labs, phi) -> + if QNameSet.mem tag labs then (q,phi)::acc1 else acc1) acc0 trs + with Not_found -> acc0 + ) states [] + (* [add_trans a q labels f] adds a transition [(q,labels) -> f] to the automaton [a] but ensures that transitions remains pairwise disjoint @@ -146,10 +159,14 @@ let print fmt a = fprintf fmt "\nInternal UID: %i@\n\ States: %a@\n\ + Top states: %a@\n\ + Bottom states: %a@\n\ Selection states: %a@\n\ Alternating transitions:@\n" (a.id :> int) StateSet.print a.states + StateSet.print a.top_states + StateSet.print a.bottom_states StateSet.print a.selection_states; let trs = Hashtbl.fold @@ -207,7 +224,7 @@ let complete_transitions a = complementing the sub-automaton in the negative states. [TODO check the meaning of negative upward arrows] *) -let normalize_negations a = +let normalize_negations auto = let memo_state = Hashtbl.create 17 in let todo = Queue.create () in let rec flip b f = @@ -226,7 +243,7 @@ let normalize_negations a = either we have a positive state deep below a negation or we have a negative state in a positive formula b' = sign of the state - b = sign of the containing formula + b = sign of the enclosing formula *) let not_q = try @@ -236,6 +253,10 @@ let normalize_negations a = 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.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; Hashtbl.add memo_state (q, false) nq; Queue.add (q, false) todo; nq in @@ -243,7 +264,9 @@ let normalize_negations a = end end in - StateSet.iter (fun q -> Queue.add (q, true) todo) a.selection_states; + (* states that are not reachable from a selection stat are not interesting *) + StateSet.iter (fun q -> Queue.add (q, true) todo) auto.selection_states; + while not (Queue.is_empty todo) do let (q, b) as key = Queue.pop todo in let q' = @@ -251,10 +274,17 @@ let normalize_negations a = Hashtbl.find memo_state key with Not_found -> - let nq = if b then q else State.make () in + let nq = if b then q else + let nq = State.make () in + 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; + nq + in Hashtbl.add memo_state key nq; nq in - let trans = Hashtbl.find a.transitions q in + let trans = Hashtbl.find auto.transitions q in let trans' = List.map (fun (lab, f) -> lab, flip b f) trans in - Hashtbl.replace a.transitions q' trans' + Hashtbl.replace auto.transitions q' trans' done diff --git a/src/auto/eval.ml b/src/auto/eval.ml new file mode 100644 index 0000000..4647b84 --- /dev/null +++ b/src/auto/eval.ml @@ -0,0 +1,105 @@ +(***********************************************************************) +(* *) +(* TAToo *) +(* *) +(* Kim Nguyen, LRI UMR8623 *) +(* Université Paris-Sud & CNRS *) +(* *) +(* Copyright 2010-2013 Université Paris-Sud and Centre National de la *) +(* Recherche Scientifique. All rights reserved. This file is *) +(* distributed under the terms of the GNU Lesser General Public *) +(* License, with the special exception on linking described in file *) +(* ../LICENSE. *) +(* *) +(***********************************************************************) + +(* + Time-stamp: +*) + +INCLUDE "utils.ml" +open Format +open Utils + +module Make (T : Tree.Sig.S) = struct + + type cache = (int, StateSet.t) Hashtbl.t + + let get c t n = + try Hashtbl.find c (T.preorder t n) + with Not_found -> StateSet.empty + + let set c t n v = Hashtbl.replace c (T.preorder t n) v + + let eval_trans l ctx acc = + List.fold_left (fun (acct, accs) ((q, phi) as trs) -> + if Ata.SFormula.eval ctx phi then + (acct, StateSet.add q accs) + else + (trs::acct, accs) + ) ([], acc) l + + let top_down_run auto tree node cache i = + let redo = ref false in + let rec loop node is_left = + if node != T.nil then begin + let parent = T.parent tree node in + let fc = T.first_child tree node in + let ns = T.next_sibling tree node in + let states0 = get cache tree node in + let tag = T.tag tree node in + let trans0 = Ata.get_trans auto auto.Ata.states tag in + let parent_states = if parent == T.nil then auto.Ata.top_states else get cache tree parent in + let fc_states = if fc == T.nil then auto.Ata.bottom_states else get cache tree fc in + let ns_states = if ns == T.nil then auto.Ata.bottom_states else get cache tree ns in + let ctx0 = + if is_left then + Ata.make_ctx fc_states ns_states parent_states StateSet.empty states0 + else + Ata.make_ctx fc_states ns_states StateSet.empty parent_states states0 + in + eprintf "[Iteration % 4d] node: %a, context: %a\n%!" + i T.print_node node Ata.print_ctx ctx0; + List.iter (fun (q, phi) -> eprintf "%a -> %a\n" State.print q Ata.SFormula.print phi) trans0; + eprintf "----------------------\n%!"; + let trans1, states1 = eval_trans trans0 ctx0 StateSet.empty in + if states1 != states0 then set cache tree node states1; + let () = loop fc true in + let ctx1 = {ctx0 with Ata.left = (get cache tree fc) ; Ata.epsilon = states1 } in + let trans2, states2 = eval_trans trans1 ctx1 states1 in + if states2 != states1 then set cache tree node states2; + let () = loop ns false in + let ctx2 = { ctx1 with Ata.right = (get cache tree ns); Ata.epsilon = states2 } in + let _, states3 = eval_trans trans2 ctx2 states2 in + if states3 != states2 then set cache tree node states3; + if states0 != states3 && (not !redo) then redo := true + end + in + loop node true; + !redo + + let get_results auto tree node cache = + let rec loop node acc = + if node == T.nil then acc + else + let acc0 = loop (T.next_sibling tree node) acc in + let acc1 = loop (T.first_child tree node) acc0 in + + if StateSet.intersect (get cache tree node) auto.Ata.selection_states then + node::acc1 + else + acc1 + in + loop node [] + + let eval auto tree node = + let cache = Hashtbl.create 511 in + let redo = ref true in + let iter = ref 0 in + while !redo do + redo := top_down_run auto tree node cache !iter; + incr iter; + done; + get_results auto tree node cache + +end diff --git a/src/test.ml b/src/test.ml index 2dd1cae..3216e71 100644 --- a/src/test.ml +++ b/src/test.ml @@ -14,12 +14,12 @@ (***********************************************************************) (* - Time-stamp: + Time-stamp: *) (** use: xml_file "XPath querie" or : xml_file -f XPath_querie_file - only the first line of XPath_querie_file is read + only the first line of XPath_querie_file is read *) module F = Auto.Formula @@ -47,7 +47,13 @@ open Format let () = fprintf err_formatter "Query: %a\n%!" Xpath.Ast.print_path query; fprintf err_formatter "Automata: %a\n%!" Auto.Ata.print auto; - fprintf err_formatter "Document:\n%!"; - Tree.Naive.print_xml stderr doc (Tree.Naive.root doc); - exit 0 + fprintf err_formatter "Evaluating automaton:\n%!"; + let module Naive = Auto.Eval.Make(Tree.Naive) in + let results = Naive.eval auto doc (Tree.Naive.root doc) in + List.iter (fun n -> + Tree.Naive.print_xml stderr doc n; + flush stderr; + output_string stderr "\n-------------------\n"; + ) results + diff --git a/src/xpath/compile.ml b/src/xpath/compile.ml index b22a74b..f1212f2 100644 --- a/src/xpath/compile.ml +++ b/src/xpath/compile.ml @@ -14,7 +14,7 @@ (***********************************************************************) (* - Time-stamp: + Time-stamp: *) open Ast @@ -56,7 +56,7 @@ let compile_axis_test axis test phi trans states = | Descendant self -> (if self then (`Epsilon ** q) else (`Left ** q)), (q, [ test => phi; - QNameSet.any => (`Left ** q) %% (`Right ** q) ]) :: trans, + QNameSet.any => (`Left ** q) ++ (`Right ** q) ]) :: trans, states | Parent ->