diff --git a/core/grammar/eval.ml b/core/grammar/eval.ml index 7aea2f1d1..fd64332a2 100644 --- a/core/grammar/eval.ml +++ b/core/grammar/eval.ml @@ -122,14 +122,15 @@ let rules_of_ast ~debug_mode ~warning ?deps_machinery ~compile_mode_on Some d' in let unrate = compile_pure_alg ~debug_mode ~compile_mode_on rate in - fun ccs -> + fun (ccs, bool) -> (match Array.length ccs with | 0 | 1 -> let () = - warning ~pos (fun f -> - Format.pp_print_text f - "Useless molecular ambiguity, the rules is always considered \ - as unary.") + if not bool then + warning ~pos (fun f -> + Format.pp_print_text f + "Useless molecular ambiguity, the rules is always \ + considered as unary.") in unrate, None | 2 -> crp, Some (unrate, dist') @@ -140,9 +141,9 @@ let rules_of_ast ~debug_mode ~warning ?deps_machinery ~compile_mode_on ^ " connected components.", pos ))) in - let build deps (origin, ccs, syntax, (neg, pos)) = + let build deps ((origin, ccs, syntax, (neg, pos)), bool) = let ccs' = Array.map fst ccs in - let rate, unrate = unary_infos ccs' in + let rate, unrate = unary_infos (ccs', bool) in ( Option_util.map (fun x -> let origin = @@ -643,7 +644,6 @@ let compile ~outputs ~pause ~return ~sharing ~debug_mode ~compile_mode_on preenv' result.Ast.rules in let rule_nd = Array.of_list compiled_rules in - pause @@ fun () -> outputs (Data.Log "\t -interventions"); let preenv, alg_deps'', pert, has_tracking = diff --git a/core/term/pattern_compiler.ml b/core/term/pattern_compiler.ml index 1f3d191a9..583c32c57 100644 --- a/core/term/pattern_compiler.ml +++ b/core/term/pattern_compiler.ml @@ -122,7 +122,8 @@ let complete_with_candidate outs prevs ag ag_tail id todo p_id dst_info p_switch LKappa.ra_syntax = ag.LKappa.ra_syntax; } :: ag_tail), - todo ) + todo, + false ) :: acc ) else if s = LKappa.Erased && p_switch = LKappa.Freed then ( let ports' = Array.copy ag.LKappa.ra_ports in @@ -139,7 +140,8 @@ let complete_with_candidate outs prevs ag ag_tail id todo p_id dst_info p_switch LKappa.ra_syntax = ag.LKappa.ra_syntax; } :: ag_tail), - todo ) + todo, + false ) :: acc ) else acc @@ -165,7 +167,8 @@ let complete_with_candidate outs prevs ag ag_tail id todo p_id dst_info p_switch LKappa.ra_syntax = ag.LKappa.ra_syntax; } :: ag_tail), - todo' ) + todo', + false ) :: acc | [], _ -> acc | _ :: _ :: _, _ -> assert false @@ -194,15 +197,17 @@ let new_agent_with_one_link sigs ty_id port link dst_info switch = } let rec add_one_implicit_info sigs id (((port, ty_id), dst_info, s) as info) acc - out todo = function + fresh_only_acc out todo = function | [] -> ( List.rev_append acc [ new_agent_with_one_link sigs ty_id port id dst_info s ], - todo ) + todo, + fresh_only_acc ) :: out | ag :: ag_tail -> let out_tail = - add_one_implicit_info sigs id info (ag :: acc) out todo ag_tail + add_one_implicit_info sigs id info (ag :: acc) fresh_only_acc out todo + ag_tail in if ty_id = ag.LKappa.ra_type then complete_with_candidate out_tail acc ag ag_tail id todo port dst_info s @@ -212,11 +217,13 @@ let rec add_one_implicit_info sigs id (((port, ty_id), dst_info, s) as info) acc let add_implicit_infos sigs l = let rec aux acc = function | [] -> acc - | (m, []) :: t -> aux (m :: acc) t - | (m, (id, info, dst_info, s) :: todo') :: t -> - aux acc (add_one_implicit_info sigs id (info, dst_info, s) [] t todo' m) + | (m, [], only_fresh) :: t -> aux ((m, only_fresh) :: acc) t + | (m, (id, info, dst_info, s) :: todo', only_fresh) :: t -> + aux acc + (add_one_implicit_info sigs id (info, dst_info, s) [] only_fresh t todo' + m) in - aux [] l + aux [] (List.rev_map (fun (a, b) -> a, b, true) (List.rev l)) let is_linked_on_port me i id = function | (LKappa.LNK_VALUE (j, _), _), _ when i = j -> id <> me @@ -609,7 +616,8 @@ let incr_origin = function | (Operator.ALG _ | Operator.MODIF _) as x -> x | Operator.RULE i -> Operator.RULE (succ i) -let connected_components_of_mixture ~debug_mode created mix (env, origin) = +let connected_components_of_mixture ~debug_mode created (mix, bool) (env, origin) + = let sigs = Pattern.PreEnv.sigs env in let rec aux env transformations instantiations links_transf acc id = function | [] -> @@ -635,10 +643,11 @@ let connected_components_of_mixture ~debug_mode created mix (env, origin) = complete_with_creation sigs transformations' links_transf [] actions' 0 created in - ( ( origin, - Tools.array_rev_of_list acc, - { instantiations with Instantiation.actions = actions'' }, - transformations'' ), + ( ( ( origin, + Tools.array_rev_of_list acc, + { instantiations with Instantiation.actions = actions'' }, + transformations'' ), + bool ), (env, Option_util.map incr_origin origin) ) | h :: t -> let wk = Pattern.begin_new env in @@ -705,7 +714,7 @@ let connected_components_sum_of_ambiguous_rule ~debug_mode ~compile_mode_on let () = if compile_mode_on then Format.eprintf "@[_____(%i)@,%a@]@." (List.length all_mixs) - (Pp.list Pp.cut (fun f x -> + (Pp.list Pp.cut (fun f (x, _) -> Format.fprintf f "@[%a%a@]" (LKappa.print_rule_mixture ~noCounters sigs counters_info ~ltypes:true created) @@ -728,7 +737,7 @@ let connected_components_sum_of_ambiguous_mixture ~debug_mode ~compile_mode_on ( cc_env, List.rev_map (function - | _, l, event, ([], []) -> l, event.Instantiation.tests + | (_, l, event, ([], [])), _b -> l, event.Instantiation.tests | _ -> assert false) rules ) diff --git a/core/term/pattern_compiler.mli b/core/term/pattern_compiler.mli index 5e116f4bf..389fa34e8 100644 --- a/core/term/pattern_compiler.mli +++ b/core/term/pattern_compiler.mli @@ -28,11 +28,12 @@ val connected_components_sum_of_ambiguous_rule : ?origin:Operator.rev_dep -> LKappa.rule_mixture -> Raw_mixture.t -> - (Operator.rev_dep option - * (Pattern.id * Pattern.cc) array - * Instantiation.abstract Instantiation.event - * (Instantiation.abstract Primitives.Transformation.t list - * Instantiation.abstract Primitives.Transformation.t list)) + ((Operator.rev_dep option + * (Pattern.id * Pattern.cc) array + * Instantiation.abstract Instantiation.event + * (Instantiation.abstract Primitives.Transformation.t list + * Instantiation.abstract Primitives.Transformation.t list)) + * bool) list * (Pattern.PreEnv.t * Operator.rev_dep option)