+ fprintf fmt "%s" (Pretty.padding (max_pre - Pretty.length s1 - Pretty.length s2));
+ fprintf fmt " %s %s@\n" Pretty.right_arrow s3;
+ ) strs_strings;
+ fprintf fmt "%s@\n" line
+
+(*
+ [complete transitions a] ensures that for each state q
+ and each symbols s in the alphabet, a transition q, s exists.
+ (adding q, s -> F when necessary).
+*)
+
+let complete_transitions a =
+ StateSet.iter (fun q ->
+ let qtrans = Hashtbl.find a.transitions q in
+ let rem =
+ List.fold_left (fun rem (labels, _) ->
+ QNameSet.diff rem labels) QNameSet.any qtrans
+ in
+ let nqtrans =
+ if QNameSet.is_empty rem then qtrans
+ else
+ (rem, Formula.false_) :: qtrans
+ in
+ Hashtbl.replace a.transitions q nqtrans
+ ) a.states
+
+let cleanup_states a =
+ let memo = ref StateSet.empty in
+ let rec loop q =
+ if not (StateSet.mem q !memo) then begin
+ memo := StateSet.add q !memo;
+ let trs = try Hashtbl.find a.transitions q with Not_found -> [] in
+ List.iter (fun (_, phi) ->
+ StateSet.iter loop (Formula.get_states phi)) trs
+ end
+ in
+ StateSet.iter loop a.selecting_states;
+ let unused = StateSet.diff a.states !memo in
+ StateSet.iter (fun q -> Hashtbl.remove a.transitions q) unused;
+ a.states <- !memo
+
+(* [normalize_negations a] removes negative atoms in the formula
+ complementing the sub-automaton in the negative states.
+ [TODO check the meaning of negative upward arrows]
+*)
+
+let normalize_negations auto =
+ let memo_state = Hashtbl.create 17 in
+ let todo = Queue.create () in
+ let rec flip b f =
+ match Formula.expr f with
+ Boolean.True | Boolean.False -> if b then f else Formula.not_ f
+ | Boolean.Or(f1, f2) -> (if b then Formula.or_ else Formula.and_)(flip b f1) (flip b f2)
+ | Boolean.And(f1, f2) -> (if b then Formula.and_ else Formula.or_)(flip b f1) (flip b f2)
+ | Boolean.Atom(a, b') -> begin
+ match a.Atom.node with
+ | Move (m, q) ->
+ 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;
+ Formula.mk_atom (Move(m, 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
+ b' = sign of the state
+ b = sign of the enclosing formula
+ *)
+ let not_q =
+ try
+ (* does the inverted state of q exist ? *)
+ Hashtbl.find memo_state (q, false)
+ with
+ Not_found ->
+ (* create a new state and add it to the todo queue *)
+ let nq = State.make () in
+ auto.states <- StateSet.add nq auto.states;
+ Hashtbl.add memo_state (q, false) nq;
+ Queue.add (q, false) todo; nq
+ in
+ Formula.mk_atom (Move (m,not_q))
+ end
+ | _ -> if b then f else Formula.not_ f
+ end
+ in
+ (* states that are not reachable from a selection stat are not interesting *)
+ StateSet.iter (fun q -> Queue.add (q, true) todo) auto.selecting_states;
+
+ while not (Queue.is_empty todo) do
+ let (q, b) as key = Queue.pop todo in
+ let q' =
+ try
+ Hashtbl.find memo_state key
+ with
+ Not_found ->
+ let nq = if b then q else
+ let nq = State.make () in
+ auto.states <- StateSet.add nq auto.states;
+ nq
+ in
+ Hashtbl.add memo_state key nq; nq
+ in
+ let trans = Hashtbl.find auto.transitions q in
+ let trans' = List.map (fun (lab, f) -> lab, flip b f) trans in
+ Hashtbl.replace auto.transitions q' trans';
+ done;
+ cleanup_states auto
+
+
+module Builder =
+ struct
+ type auto = t
+ type t = auto
+ let next = Uid.make_maker ()
+
+ let make () =
+ let auto =
+ {
+ id = next ();
+ states = StateSet.empty;
+ selecting_states = StateSet.empty;
+ transitions = Hashtbl.create MED_H_SIZE;
+ }
+ in
+ (*
+ at_exit (fun () ->
+ let n4 = ref 0 in
+ let n2 = ref 0 in
+ Cache.N2.iteri (fun _ _ _ b -> if b then incr n2) auto.cache2;
+ Cache.N4.iteri (fun _ _ _ _ _ b -> if b then incr n4) auto.cache4;
+ Logger.msg `STATS "automaton %i, cache2: %i entries, cache6: %i entries"
+ (auto.id :> int) !n2 !n4;
+ let c2l, c2u = Cache.N2.stats auto.cache2 in
+ let c4l, c4u = Cache.N4.stats auto.cache4 in
+ Logger.msg `STATS
+ "cache2: length: %i, used: %i, occupation: %f"
+ c2l c2u (float c2u /. float c2l);
+ Logger.msg `STATS
+ "cache4: length: %i, used: %i, occupation: %f"
+ c4l c4u (float c4u /. float c4l)
+
+ ); *)
+ auto
+
+ let add_state a ?(selecting=false) q =
+ a.states <- StateSet.add q a.states;
+ if selecting then a.selecting_states <- StateSet.add q a.selecting_states
+
+ let add_trans a q s f =
+ if not (StateSet.mem q a.states) then add_state a q;
+ let trs = try Hashtbl.find a.transitions q with Not_found -> [] in
+ let cup, ntrs =
+ List.fold_left (fun (acup, atrs) (labs, phi) ->
+ let lab1 = QNameSet.inter labs s in
+ let lab2 = QNameSet.diff labs s in
+ let tr1 =
+ if QNameSet.is_empty lab1 then []
+ else [ (lab1, Formula.or_ phi f) ]
+ in
+ let tr2 =
+ if QNameSet.is_empty lab2 then []
+ else [ (lab2, Formula.or_ phi f) ]
+ in
+ (QNameSet.union acup labs, tr1@ tr2 @ atrs)
+ ) (QNameSet.empty, []) trs
+ in
+ let rem = QNameSet.diff s cup in
+ let ntrs = if QNameSet.is_empty rem then ntrs
+ else (rem, f) :: ntrs
+ in
+ Hashtbl.replace a.transitions q ntrs
+
+ let finalize a =
+ complete_transitions a;
+ normalize_negations a;
+ a
+ end