+ let pos, (_, proof', (ty, what, other, _), menv', args') = eq_found in
+ let what, other = if pos = Utils.Left then what, other else other, what in
+ let newterm, newproof =
+ let bo = (* M. *)apply_subst subst (S.subst other t) in
+ let t' =
+ let name = C.Name ("x_Demod_" ^ (string_of_int !demod_counter)) in
+ incr demod_counter;
+ let l, r =
+ if is_left then t, S.lift 1 right else S.lift 1 left, t in
+ (name, ty, S.lift 1 eq_ty, l, r)
+ in
+ if sign = Utils.Positive then
+ (bo,
+ Inference.ProofBlock (subst, eq_URI, t', eq_found, proof))
+ else
+ let metaproof =
+ incr maxmeta;
+ let irl =
+ CicMkImplicit.identity_relocation_list_for_metavariable context in
+ Printf.printf "\nADDING META: %d\n" !maxmeta;
+ print_newline ();
+ C.Meta (!maxmeta, irl)
+ in
+ let target' =
+ let eq_found =
+ let proof' =
+ let ens =
+ if pos = Utils.Left then
+ build_ens_for_sym_eq ty what other
+ else
+ build_ens_for_sym_eq ty other what
+ in
+ Inference.ProofSymBlock (ens, proof')
+ in
+ let what, other =
+ if pos = Utils.Left then what, other else other, what
+ in
+ pos, (0, proof', (ty, other, what, Utils.Incomparable),
+ menv', args')
+ in
+ let target_proof =
+ let pb =
+ Inference.ProofBlock (subst, eq_URI, t', eq_found,
+ Inference.BasicProof metaproof)
+ in
+ match proof with
+ | Inference.BasicProof _ ->
+ print_endline "replacing a BasicProof";
+ pb
+ | Inference.ProofGoalBlock (_, parent_eq) ->
+ print_endline "replacing another ProofGoalBlock";
+ Inference.ProofGoalBlock (pb, parent_eq)
+ | _ -> assert false
+ in
+ (0, target_proof, (eq_ty, left, right, order), metas, args)
+ in
+ let refl =
+ C.Appl [C.MutConstruct (* reflexivity *)
+ (HelmLibraryObjects.Logic.eq_URI, 0, 1, []);
+ eq_ty; if is_left then right else left]
+ in
+ (bo,
+ Inference.ProofGoalBlock (Inference.BasicProof refl, target'))
+ in
+ let left, right = if is_left then newterm, right else left, newterm in
+ let m = (Inference.metas_of_term left) @ (Inference.metas_of_term right) in
+ let newmetasenv = List.filter (fun (i, _, _) -> List.mem i m) metas
+ and newargs =
+ List.filter
+ (function C.Meta (i, _) -> List.mem i m | _ -> assert false)
+ args
+ in
+ let ordering = !Utils.compare_terms left right in
+
+ let time2 = Unix.gettimeofday () in
+ build_newtarget_time := !build_newtarget_time +. (time2 -. time1);
+
+ let res =
+ let w = Utils.compute_equality_weight eq_ty left right in
+ (w, newproof, (eq_ty, left, right, ordering), newmetasenv, newargs)
+ in
+(* if sign = Utils.Positive then ( *)
+(* let newm, res = Inference.fix_metas !maxmeta res in *)
+(* maxmeta := newm; *)
+(* !maxmeta, res *)
+(* ) else *)
+ !maxmeta(* newmeta *), res
+ in
+ let res = demodulate_term metasenv' context ugraph table 0 left in
+(* let build_identity (w, p, (t, l, r, o), m, a) = *)
+(* match o with *)
+(* | Utils.Gt -> (w, p, (t, r, r, Utils.Eq), m, a) *)
+(* | _ -> (w, p, (t, l, l, Utils.Eq), m, a) *)
+(* in *)
+ match res with
+ | Some t ->
+ let newmeta, newtarget = build_newtarget true t in
+ if (Inference.is_identity (metasenv', context, ugraph) newtarget) ||
+ (Inference.meta_convertibility_eq target newtarget) then
+ newmeta, newtarget
+ else
+(* if subsumption env table newtarget then *)
+(* newmeta, build_identity newtarget *)
+(* else *)
+ demodulation newmeta env table sign newtarget
+ | None ->
+ let res = demodulate_term metasenv' context ugraph table 0 right in
+ match res with
+ | Some t ->
+ let newmeta, newtarget = build_newtarget false t in
+ if (Inference.is_identity (metasenv', context, ugraph) newtarget) ||
+ (Inference.meta_convertibility_eq target newtarget) then
+ newmeta, newtarget
+ else
+(* if subsumption env table newtarget then *)
+(* newmeta, build_identity newtarget *)
+(* else *)
+ demodulation newmeta env table sign newtarget
+ | None ->
+ newmeta, target
+;;
+
+
+let rec betaexpand_term metasenv context ugraph table lift_amount term =
+ let module C = Cic in
+ let module S = CicSubstitution in
+ let module M = CicMetaSubst in
+ let module HL = HelmLibraryObjects in
+ let candidates = get_candidates Unification table term in
+ let res, lifted_term =
+ match term with
+ | C.Meta (i, l) ->
+ let l', lifted_l =
+ List.fold_right
+ (fun arg (res, lifted_tl) ->
+ match arg with
+ | Some arg ->
+ let arg_res, lifted_arg =
+ betaexpand_term metasenv context ugraph table
+ lift_amount arg in
+ let l1 =
+ List.map
+ (fun (t, s, m, ug, eq_found) ->
+ (Some t)::lifted_tl, s, m, ug, eq_found)
+ arg_res
+ in
+ (l1 @
+ (List.map
+ (fun (l, s, m, ug, eq_found) ->
+ (Some lifted_arg)::l, s, m, ug, eq_found)
+ res),
+ (Some lifted_arg)::lifted_tl)
+ | None ->
+ (List.map
+ (fun (r, s, m, ug, eq_found) ->
+ None::r, s, m, ug, eq_found) res,
+ None::lifted_tl)
+ ) l ([], [])
+ in
+ let e =
+ List.map
+ (fun (l, s, m, ug, eq_found) ->
+ (C.Meta (i, l), s, m, ug, eq_found)) l'
+ in
+ e, C.Meta (i, lifted_l)
+
+ | C.Rel m ->
+ [], if m <= lift_amount then C.Rel m else C.Rel (m+1)
+
+ | C.Prod (nn, s, t) ->
+ let l1, lifted_s =
+ betaexpand_term metasenv context ugraph table lift_amount s in
+ let l2, lifted_t =
+ betaexpand_term metasenv ((Some (nn, C.Decl s))::context) ugraph
+ table (lift_amount+1) t in
+ let l1' =
+ List.map
+ (fun (t, s, m, ug, eq_found) ->
+ C.Prod (nn, t, lifted_t), s, m, ug, eq_found) l1
+ and l2' =
+ List.map
+ (fun (t, s, m, ug, eq_found) ->
+ C.Prod (nn, lifted_s, t), s, m, ug, eq_found) l2 in
+ l1' @ l2', C.Prod (nn, lifted_s, lifted_t)
+
+ | C.Appl l ->
+ let l', lifted_l =
+ List.fold_right
+ (fun arg (res, lifted_tl) ->
+ let arg_res, lifted_arg =
+ betaexpand_term metasenv context ugraph table lift_amount arg
+ in
+ let l1 =
+ List.map
+ (fun (a, s, m, ug, eq_found) ->
+ a::lifted_tl, s, m, ug, eq_found)
+ arg_res
+ in
+ (l1 @
+ (List.map
+ (fun (r, s, m, ug, eq_found) ->
+ lifted_arg::r, s, m, ug, eq_found)
+ res),
+ lifted_arg::lifted_tl)
+ ) l ([], [])
+ in
+ (List.map
+ (fun (l, s, m, ug, eq_found) -> (C.Appl l, s, m, ug, eq_found)) l',
+ C.Appl lifted_l)
+
+ | t -> [], (S.lift lift_amount t)
+ in
+ match term with
+ | C.Meta _ -> res, lifted_term
+ | term ->
+ let r =
+ find_all_matches metasenv context ugraph lift_amount term candidates
+ in
+ r @ res, lifted_term
+;;
+
+
+let sup_l_counter = ref 1;;
+
+let superposition_left newmeta (metasenv, context, ugraph) table target =
+ let module C = Cic in
+ let module S = CicSubstitution in
+ let module M = CicMetaSubst in
+ let module HL = HelmLibraryObjects in
+ let module CR = CicReduction in
+ let module U = Utils in
+ let weight, proof, (eq_ty, left, right, ordering), _, _ = target in
+ let expansions, _ =
+ let term = if ordering = U.Gt then left else right in
+ betaexpand_term metasenv context ugraph table 0 term
+ in
+ let maxmeta = ref newmeta in
+ let build_new (bo, s, m, ug, (eq_found, eq_URI)) =
+
+ print_endline "\nSUPERPOSITION LEFT\n";
+
+ let time1 = Unix.gettimeofday () in
+
+ let pos, (_, proof', (ty, what, other, _), menv', args') = eq_found in
+ let what, other = if pos = Utils.Left then what, other else other, what in
+ let newgoal, newproof =
+ let bo' = (* M. *)apply_subst s (S.subst other bo) in
+ let t' =
+ let name = C.Name ("x_SupL_" ^ (string_of_int !sup_l_counter)) in
+ incr sup_l_counter;
+ let l, r =
+ if ordering = U.Gt then bo, S.lift 1 right else S.lift 1 left, bo in
+ (name, ty, S.lift 1 eq_ty, l, r)
+ in
+(* let bo'' = *)
+(* C.Appl ( *)
+(* [C.MutInd (HL.Logic.eq_URI, 0, []); *)
+(* S.lift 1 eq_ty] @ *)
+(* if ordering = U.Gt then [S.lift 1 bo'; S.lift 1 right] *)
+(* else [S.lift 1 left; S.lift 1 bo']) *)
+(* in *)
+(* let t' = *)
+(* let name = C.Name ("x_SupL_" ^ (string_of_int !sup_l_counter)) in *)
+(* incr sup_l_counter; *)
+(* C.Lambda (name, ty, bo'') *)
+(* in *)
+ incr maxmeta;
+ let metaproof =
+ let irl =
+ CicMkImplicit.identity_relocation_list_for_metavariable context in
+ C.Meta (!maxmeta, irl)
+ in
+ let target' =
+ let eq_found =
+ let proof' =
+ let ens =
+ if pos = Utils.Left then
+ build_ens_for_sym_eq ty what other
+ else
+ build_ens_for_sym_eq ty other what
+ in
+ Inference.ProofSymBlock (ens, proof')
+ in
+ let what, other =
+ if pos = Utils.Left then what, other else other, what
+ in
+ pos, (0, proof', (ty, other, what, Utils.Incomparable), menv', args')
+ in
+ let target_proof =
+ let pb =
+ Inference.ProofBlock (s, eq_URI, t', eq_found,
+ Inference.BasicProof metaproof)
+ in
+ match proof with
+ | Inference.BasicProof _ ->
+ print_endline "replacing a BasicProof";
+ pb
+ | Inference.ProofGoalBlock (_, parent_eq) ->
+ print_endline "replacing another ProofGoalBlock";
+ Inference.ProofGoalBlock (pb, parent_eq)
+ | _ -> assert false
+ in
+ (weight, target_proof, (eq_ty, left, right, ordering), [], [])
+ in
+ let refl =
+ C.Appl [C.MutConstruct (* reflexivity *)
+ (HelmLibraryObjects.Logic.eq_URI, 0, 1, []);
+ eq_ty; if ordering = U.Gt then right else left]
+ in
+ (bo',
+ Inference.ProofGoalBlock (Inference.BasicProof refl, target'))
+ in
+ let left, right =
+ if ordering = U.Gt then newgoal, right else left, newgoal in
+ let neworder = !Utils.compare_terms left right in
+
+ let time2 = Unix.gettimeofday () in
+ build_newtarget_time := !build_newtarget_time +. (time2 -. time1);
+
+ let res =
+ let w = Utils.compute_equality_weight eq_ty left right in
+ (w, newproof, (eq_ty, left, right, neworder), [], [])
+ in
+ res
+ in
+ !maxmeta, List.map build_new expansions
+;;
+
+
+let sup_r_counter = ref 1;;
+
+let superposition_right newmeta (metasenv, context, ugraph) table target =
+ let module C = Cic in
+ let module S = CicSubstitution in
+ let module M = CicMetaSubst in
+ let module HL = HelmLibraryObjects in
+ let module CR = CicReduction in
+ let module U = Utils in
+ let _, eqproof, (eq_ty, left, right, ordering), newmetas, args = target in
+ let metasenv' = metasenv @ newmetas in
+ let maxmeta = ref newmeta in
+ let res1, res2 =
+ match ordering with
+ | U.Gt -> fst (betaexpand_term metasenv' context ugraph table 0 left), []
+ | U.Lt -> [], fst (betaexpand_term metasenv' context ugraph table 0 right)
+ | _ ->
+ let res l r =
+ List.filter
+ (fun (_, subst, _, _, _) ->
+ let subst = (* M. *)apply_subst subst in
+ let o = !Utils.compare_terms (subst l) (subst r) in
+ o <> U.Lt && o <> U.Le)
+ (fst (betaexpand_term metasenv' context ugraph table 0 l))
+ in
+ (res left right), (res right left)
+ in
+ let build_new ordering (bo, s, m, ug, (eq_found, eq_URI)) =
+
+ let time1 = Unix.gettimeofday () in