+(* performs steps of rewrite with the universe, obtaining if possible
+ * a trivial goal *)
+let solve_rewrite ~automation_cache ~params:(univ,params) (proof,goal)=
+ let steps = int_of_string (string params "steps" "4") in
+ let use_context = bool params "use_context" true in
+ let universe, tables, cache =
+ init_cache_and_tables ~use_library:false ~use_context
+ automation_cache univ (proof,goal)
+ in
+ let actives, passives, bag = tables in
+ let pa,metasenv,subst,pb,pc,pd = proof in
+ let _,context,ty = CicUtil.lookup_meta goal metasenv in
+ let metasenv = CicMetaSubst.apply_subst_metasenv subst metasenv in
+ let context = CicMetaSubst.apply_subst_context subst context in
+ let ty = CicMetaSubst.apply_subst subst ty in
+ let eq_uri = eq_of_goal ty in
+ let initgoal = [], metasenv, ty in
+ let table =
+ let equalities = (Saturation.list_of_passive passives) in
+ List.fold_left (fun tbl eq -> Indexing.index tbl eq) (snd actives) equalities
+ in
+ let env = metasenv,context,CicUniv.oblivion_ugraph in
+ debug_print (lazy ("demod to solve: " ^ CicPp.ppterm ty));
+ match Indexing.solve_demodulating bag env table initgoal steps with
+ | Some (bag, gproof, metasenv, sub_subst, proof) ->
+ let subst_candidates,extra_infos =
+ List.split
+ (HExtlib.filter_map
+ (fun (i,c,_) ->
+ if i <> goal && c = context then Some (i,(c,ty)) else None)
+ metasenv)
+ in
+ let proofterm,proto_subst =
+ let proof = Equality.add_subst sub_subst proof in
+ Equality.build_goal_proof
+ bag eq_uri gproof proof ty subst_candidates context metasenv
+ in
+ let proofterm = Subst.apply_subst sub_subst proofterm in
+ let extrasubst =
+ HExtlib.filter_map
+ (fun (i,((c,ty),t)) ->
+ match t with
+ | Cic.Meta (j,_) when i=j -> None
+ | _ -> Some (i,(c,t,ty)))
+ (List.combine subst_candidates
+ (List.combine extra_infos proto_subst))
+ in
+ let subst = subst @ extrasubst in
+ let metasenv = CicMetaSubst.apply_subst_metasenv subst metasenv in
+ let proofterm, _, metasenv,subst, _ =
+ CicRefine.type_of metasenv subst context proofterm
+ CicUniv.oblivion_ugraph
+ in
+ let status = (pa,metasenv,subst,pb,pc,pd), goal in
+ ProofEngineTypes.apply_tactic
+ (PrimitiveTactics.apply_tac ~term:proofterm) status
+ | None ->
+ raise
+ (ProofEngineTypes.Fail (lazy
+ ("Unable to solve with " ^ string_of_int steps ^ " demodulations")))
+;;
+
+(* Demodulate thorem *)
+let open_type ty bo =
+ let rec open_type_aux context ty k args =
+ match ty with
+ | Cic.Prod (n,s,t) ->
+ let n' =
+ FreshNamesGenerator.mk_fresh_name [] context n ~typ:s ~subst:[] in
+ let entry = match n' with
+ | Cic.Name _ -> Some (n',(Cic.Decl s))
+ | Cic.Anonymous -> None
+ in
+ open_type_aux (entry::context) t (k+1) ((Cic.Rel k)::args)
+ | Cic.LetIn (n,s,sty,t) ->
+ let entry = Some (n,(Cic.Def (s,sty)))
+ in
+ open_type_aux (entry::context) t (k+1) args
+ | _ -> context, ty, args
+ in
+ let context, ty, args = open_type_aux [] ty 1 [] in
+ match args with
+ | [] -> context, ty, bo
+ | _ -> context, ty, Cic.Appl (bo::args)
+;;
+
+let rec close_type bo ty context =
+ match context with
+ | [] -> assert_proof_is_valid bo [] [] ty; (bo,ty)
+ | Some (n,(Cic.Decl s))::tl ->
+ close_type (Cic.Lambda (n,s,bo)) (Cic.Prod (n,s,ty)) tl
+ | Some (n,(Cic.Def (s,sty)))::tl ->
+ close_type (Cic.LetIn (n,s,sty,bo)) (Cic.LetIn (n,s,sty,ty)) tl
+ | _ -> assert false
+;;
+
+let is_subsumed univ context ty =
+ let candidates = Universe.get_candidates univ ty in
+ List.fold_left
+ (fun res cand ->
+ match res with
+ | Some found -> Some found
+ | None ->
+ try
+ let mk_irl =
+ CicMkImplicit.identity_relocation_list_for_metavariable in
+ let metasenv = [(0,context,ty)] in
+ let fake_proof =
+ None,metasenv,[] , (lazy (Cic.Meta(0,mk_irl context))),ty,[]
+ in
+ let (_,metasenv,subst,_,_,_), open_goals =
+ ProofEngineTypes.apply_tactic
+ (PrimitiveTactics.apply_tac ~term:cand)
+ (fake_proof,0)
+ in
+ let prop_goals, other =
+ split_goals_in_prop metasenv subst open_goals
+ in
+ if prop_goals = [] then Some cand else None
+ with
+ | ProofEngineTypes.Fail s -> None
+ | CicUnification.Uncertain s -> None
+ ) None candidates
+;;
+
+let demodulate_theorem ~automation_cache uri =
+ let eq_uri =
+ match LibraryObjects.eq_URI () with
+ | Some (uri) -> uri
+ | None -> raise (ProofEngineTypes.Fail (lazy "equality not declared")) in
+ let obj,_ = CicEnvironment.get_cooked_obj CicUniv.empty_ugraph uri
+ in
+ let context,ty,bo =
+ match obj with
+ | Cic.Constant(n, _, ty ,_, _) -> open_type ty (Cic.Const(uri,[]))
+ | _ -> raise (ProofEngineTypes.Fail (lazy "not a theorem"))
+ in
+ if CicUtil.is_closed ty then
+ raise (ProofEngineTypes.Fail (lazy ("closed term: dangerous reduction")));
+ let initgoal = [], [], ty in
+ (* compute the signature *)
+ let signature =
+ let ty_set = MetadataConstraints.constants_of ty in
+ let hyp_set = MetadataQuery.signature_of_hypothesis context [] in
+ let set = MetadataConstraints.UriManagerSet.union ty_set hyp_set in
+ MetadataQuery.close_with_types set [] context
+ in
+ (* retrieve equations from the universe universe *)
+ (* XXX automation_cache *)
+ let universe = automation_cache.AutomationCache.univ in
+ let equations =
+ retrieve_equations true signature universe AutoCache.cache_empty context []
+ in
+ debug_print
+ (lazy ("ho trovato equazioni n. "^(string_of_int (List.length equations))));
+ let eqs_and_types =
+ HExtlib.filter_map
+ (fun t ->
+ let ty,_ =
+ CicTypeChecker.type_of_aux' [] context t CicUniv.oblivion_ugraph
+ in
+ (* retrieve_equations could also return flexible terms *)
+ if is_an_equality ty then Some(t,ty)
+ else
+ try
+ let ty' = unfold context ty in
+ if is_an_equality ty' then Some(t,ty') else None
+ with ProofEngineTypes.Fail _ -> None)
+ equations
+ in
+ let bag = Equality.mk_equality_bag () in
+
+ let bag, units, _, newmeta =
+ partition_unit_equalities context [] (CicMkImplicit.new_meta [] []) bag eqs_and_types
+ in
+ let table =
+ List.fold_left
+ (fun tbl eq -> Indexing.index tbl eq)
+ Indexing.empty units
+ in
+ let changed,(newproof,newmetasenv, newty) =
+ Indexing.demod bag
+ ([],context,CicUniv.oblivion_ugraph) table initgoal in
+ if changed then
+ begin
+ let oldproof = Equality.Exact bo in
+ let proofterm,_ =
+ Equality.build_goal_proof (~contextualize:false) (~forward:true) bag
+ eq_uri newproof oldproof ty [] context newmetasenv
+ in
+ if newmetasenv <> [] then
+ raise (ProofEngineTypes.Fail (lazy ("metasenv not empty")))
+ else
+ begin
+ assert_proof_is_valid proofterm newmetasenv context newty;
+ match is_subsumed universe context newty with
+ | Some t -> raise
+ (ProofEngineTypes.Fail (lazy ("subsumed by " ^ CicPp.ppterm t)))
+ | None -> close_type proofterm newty context
+ end