module S = CicSubstitution
module PT = PrimitiveTactics
module T = Tacticals
+module FNG = FreshNamesGenerator
let fail_msg1 = "no applicable simplification"
(* lapply *******************************************************************)
-let lapply_tac ?(mk_fresh_name_callback = FreshNamesGenerator.mk_fresh_name ~subst:[])
- (* ?(substs = []) *) ?to_what what =
- let cut_tac term = PT.cut_tac ~mk_fresh_name_callback term in
- let apply_tac term = PT.apply_tac term in
- let strip_dependent_prods metasenv context t =
- let irl = MI.identity_relocation_list_for_metavariable context in
- let rec aux metasenv p xcontext = function
- | Cic.Prod (name, t1, t2) when not (TC.does_not_occur xcontext 0 1 t2) ->
- let index = MI.new_meta metasenv [] in
- let metasenv = [index, context, t1] @ metasenv in
- let e, s = Some (name, Cic.Decl t1), Cic.Meta (index, irl) in
- aux metasenv (succ p) (e :: xcontext) (S.subst s t2)
- | Cic.Prod (name, t1, t2) -> metasenv, p, Some t1, t2
- | t -> metasenv, p, None, t
- in
- aux metasenv 0 context t
+let strip_dependent_prods metasenv context t =
+ let irl = MI.identity_relocation_list_for_metavariable context in
+ let mk_meta metasenv t =
+ let index = MI.new_meta metasenv [] in
+ let metasenv = [index, context, t] @ metasenv in
+ metasenv, Cic.Meta (index, irl)
in
- let rec mk_continuations p l =
- if p <= 0 then l else mk_continuations (pred p) (T.id_tac :: l)
+ let rec aux metasenv metas = function
+ | Cic.Prod (Cic.Name _ as name, t1, t2) ->
+ let metasenv, meta = mk_meta metasenv t1 in
+ aux metasenv (meta :: metas) (S.subst meta t2)
+ | Cic.Prod (Cic.Anonymous, t1, _) ->
+ let metasenv, meta = mk_meta metasenv t1 in
+ metasenv, metas, Some meta
+ | t -> metasenv, metas, None
in
+ aux metasenv [] t
+
+let lapply_tac ?(mk_fresh_name_callback = FreshNamesGenerator.mk_fresh_name ~subst:[])
+ (* ?(substs = []) *) ?to_what what =
+ let letin_tac term = PT.letin_tac ~mk_fresh_name_callback term in
let lapply_tac (proof, goal) =
let xuri, metasenv, u, t = proof in
let _, context, _ = CicUtil.lookup_meta goal metasenv in
let lemma, _ = TC.type_of_aux' metasenv context what U.empty_ugraph in
+ let lemma = FNG.clean_dummy_dependent_types lemma in
match strip_dependent_prods metasenv context lemma with
- | metasenv, p, Some premise, conclusion ->
- let premise_tac =
- match to_what with
- | None -> T.id_tac
- | Some term -> PT.apply_tac term
- in
+ | metasenv, metas, Some meta ->
+ let pippo = Cic.Appl (what :: List.rev (meta :: metas)) in
+ Printf.eprintf "lapply: %s\n" (CicPp.ppterm pippo); flush stderr;
+ let outer_tac = letin_tac pippo in
let status = (xuri, metasenv, u, t), goal in
- let tac = T.thens ~start:(cut_tac premise)
- ~continuations:[
- T.thens ~start:(cut_tac conclusion)
- ~continuations:[ T.id_tac;
- T.thens ~start:(PT.apply_tac what)
- ~continuations:(mk_continuations p [PT.apply_tac ~term:(Cic.Rel 1)])
- ]; premise_tac ]
- in
- PET.apply_tactic tac status
- | metasenv, p, None, conclusion ->
+ PET.apply_tactic outer_tac status
+ | metasenv, metas, None ->
failwith "lapply_tac: not implemented"
in
PET.mk_tactic lapply_tac
+
+(*
+
-
-
-
-
-
-
-
-
-(*
- let count_dependent_prods context t =
- let rec aux context p = function
- | Cic.Prod (name, t1, t2) ->
- if TC.does_not_occur context 0 1 t2 then p else
- let e = Some (name, Cic.Decl t1) in
- aux (e :: context) (succ p) t2
- | t -> p
- in
- aux context 0 t
- in
- let rec pad_context p context add_context =
- if List.length add_context >= p then add_context @ context
- else pad_context p context (None :: add_context)
+
+let skip_metas p =
+ let rec aux conts p =
+ if p <= 0 then conts else aux (T.id_tac :: conts) (pred p)
in
- let strip_dependent_prods metasenv context p t =
- let rec aux metasenv add_context q = function
- | Cic.Prod (name, t1, t2) when q > 0 ->
- let context_for_meta = pad_context p context add_context in
- let metasenv, index = MI.mk_implicit metasenv [] context_for_meta in
- let rs = MI.identity_relocation_list_for_metavariable context_for_meta in
- let e, s = Some (name, Cic.Decl t1), Cic.Meta (index, rs) in
- aux metasenv (e :: add_context) (pred q) (S.subst s t2)
- | t -> metasenv, add_context, t
- in
- aux metasenv [] p t
+ aux [] p
+
+let get_conclusion context t =
+ let rec aux p context = function
+ | Cic.Prod (name, t1, t2) ->
+ aux (succ p) (Some (name, Cic.Decl t1) :: context) t2
+ | Cic.LetIn (name, u1, t2) ->
+ aux (succ p) (Some (name, Cic.Def (u1, None)) :: context) t2
+ | Cic.Cast (t2, t1) -> aux p context t2
+ | t -> p, context, t
+ in aux 0 context t
+
+let get_conclusion_dependences context t =
+ let p, context, conclusion = get_conclusion context t in
+ let rec aux l q =
+ if q <= 0 then l else
+ let b = TC.does_not_occur context (pred q) q conclusion in
+ aux (b :: l) (pred q)
in
- let mk_body bo = function
- | Some (name, Cic.Decl t1) -> Cic.Lambda (name, t1, bo)
- | _ -> failwith "mk_body"
+ aux [] p
+
+let solve_independents ?with_what deps =
+ let rec aux p conts = function
+ | [] -> p, conts
+ | true :: tl ->
+ let cont = PT.apply_tac ~term:(Cic.Rel (succ p)) in
+ aux (succ p) (cont :: conts) tl
+ | false :: tl -> aux (succ p) conts tl
+ in
+ let p, conts = aux 0 [] deps in
+ match with_what with
+ | None -> conts
+ | Some t -> PT.apply_tac ~term:(S.lift p t) :: conts
+
+let lapply_tac ?(mk_fresh_name_callback = FreshNamesGenerator.mk_fresh_name ~subst:[])
+ (* ?(substs = []) *) ?to_what what =
+ let cut_tac term = PT.cut_tac ~mk_fresh_name_callback term in
+ let intros_tac () = PT.intros_tac ~mk_fresh_name_callback () in
+ let solve_conclusion_tac ?with_what p deps =
+ T.then_ ~start:(intros_tac ())
+ ~continuation:(
+ T.thens ~start:(PT.apply_tac what)
+ ~continuations:( [ T.id_tac; T.id_tac; T.id_tac ]
+(* skip_metas p @ solve_independents ?with_what deps *)
+ )
+ )
in
let lapply_tac (proof, goal) =
let xuri, metasenv, u, t = proof in
-(* preliminaries *)
- let metano, context, ty = CicUtil.lookup_meta goal metasenv in
+ let _, context, _ = CicUtil.lookup_meta goal metasenv in
let lemma, _ = TC.type_of_aux' metasenv context what U.empty_ugraph in
- let p = count_dependent_prods context lemma in
-(* stripping *)
- let metasenv, add_context, holed_lemma = strip_dependent_prods metasenv context p lemma in
- let proof = xuri, metasenv, u, t in
- let newmeta = MI.new_meta metasenv [] in
- let context = add_context @ context in
- let irl = MI.identity_relocation_list_for_metavariable context in
- let bo = List.fold_left mk_body (Cic.Meta (newmeta, irl)) add_context in
- let ty = S.lift p ty in
- let (xuri, metasenv, u, t), _ =
- PEH.subst_meta_in_proof proof metano bo [newmeta, context, ty]
- in
- prerr_endline (CicPp.ppterm holed_lemma);
-(* cut *)
- let status = (xuri, metasenv, u, t), newmeta in
- PET.apply_tactic (PT.cut_tac ~mk_fresh_name_callback holed_lemma) status
- in
- PET.mk_tactic lapply_tac
-*)
+ let lemma = FNG.clean_dummy_dependent_types lemma in
+ match strip_dependent_prods metasenv context lemma with
+ | metasenv, p, Some premise, conclusion ->
+ let deps = get_conclusion_dependences context conclusion in
+ let inner_tac = match to_what with
+ | None ->
+ T.thens ~start:(cut_tac premise)
+ ~continuations:[
+ solve_conclusion_tac ~with_what:(Cic.Rel 1) p deps;
+ T.id_tac
+ ]
+ | Some with_what ->
+ solve_conclusion_tac ~with_what p deps
+ in
+ let outer_tac =
+ T.thens ~start:(cut_tac conclusion)
+ ~continuations:[T.id_tac; T.id_tac (* inner_tac *)]
+ in
+*)
(* fwd **********************************************************************)
let fwd_simpl_tac ~what ~dbd =
projects / helm.git / blobdiff