- | v ->
- [T.LetIn (name, v, dtext)]
-
-and mk_proof st = function
- | C.ALambda (_, name, v, t) as what ->
- let entry = Some (name, C.Decl (cic v)) in
- let intro = get_intro name t in
- let ety = match get_inner_types st what with
- | Some (_, ety) -> Some ety
- | None -> None
- in
- mk_proof (add st entry intro ety) t
- | C.ALetIn (_, name, v, t) as what ->
- let proceed, dtext = test_depth st in
- let script = if proceed then
- let entry = Some (name, C.Def (cic v, None)) in
- let intro = get_intro name t in
- let q = mk_proof (next (add st entry intro None)) t in
- List.rev_append (mk_fwd_proof st dtext intro v) q
- else
- [T.Apply (what, dtext)]
- in
- mk_intros st script
- | C.ARel _ as what ->
- let _, dtext = test_depth st in
- let text = "assumption" in
- let script = [T.Apply (what, dtext ^ text)] in
- mk_intros st script
- | C.AMutConstruct _ as what ->
- let _, dtext = test_depth st in
- let script = [T.Apply (what, dtext)] in
- mk_intros st script
- | C.AAppl (_, hd :: tl) as t ->
- let proceed, dtext = test_depth st in
- let script = if proceed then
- let ty, _ = TC.type_of_aux' [] st.context (cic hd) Un.empty_ugraph in
- let (classes, rc) as h = Cl.classify st.context ty in
- let decurry = List.length classes - List.length tl in
- if decurry < 0 then mk_proof (clear st) (appl_expand decurry t) else
- if decurry > 0 then mk_proof (clear st) (eta_expand decurry t) else
- let synth = Cl.S.singleton 0 in
- let text = Printf.sprintf "%u %s" (List.length classes) (Cl.to_string h) in
- match rc with
- | Some (i, j) when i > 1 && i <= List.length classes ->
- let classes, tl, _, what = split2_last classes tl in
- let script, what = mk_atomic st dtext what in
- let synth = Cl.S.add 1 synth in
- let qs = mk_bkd_proofs (next st) synth classes tl in
- if is_rewrite_right hd then
- List.rev script @ convert st t @
- [T.Rewrite (false, what, None, dtext); T.Branch (qs, "")]
- else if is_rewrite_left hd then
- List.rev script @ convert st t @
- [T.Rewrite (true, what, None, dtext); T.Branch (qs, "")]
- else
- let using = Some hd in
- List.rev script @ convert st t @
- [T.Elim (what, using, dtext ^ text); T.Branch (qs, "")]
- | _ ->
- let qs = mk_bkd_proofs (next st) synth classes tl in
- let script, hd = mk_atomic st dtext hd in
- List.rev script @ convert st t @
- [T.Apply (hd, dtext ^ text); T.Branch (qs, "")]
- else
- [T.Apply (t, dtext)]
- in
- mk_intros st script
- | C.AMutCase (id, uri, tyno, outty, arg, cases) ->
- begin match Cn.mk_ind st.context id uri tyno outty arg cases with
- | None ->
- let text = Printf.sprintf "%s" "UNEXPANDED: mutcase" in
- let script = [T.Note text] in
- mk_intros st script
- | Some t -> mk_proof st t
- end
- | t ->
- let text = Printf.sprintf "%s: %s" "UNEXPANDED" (string_of_head t) in
- let script = [T.Note text] in
- mk_intros st script
-
-and mk_bkd_proofs st synth classes ts =
-try
- let _, dtext = test_depth st in
- let aux inv v =
- if Cl.overlaps synth inv then None else
- if Cl.S.is_empty inv then Some (mk_proof st v) else
- Some [T.Apply (v, dtext ^ "dependent")]
- in
- T.list_map2_filter aux classes ts
-with Invalid_argument _ -> failwith "A2P.mk_bkd_proofs"
-
-(* object costruction *******************************************************)
-
-let is_theorem pars =
- List.mem (`Flavour `Theorem) pars || List.mem (`Flavour `Fact) pars ||
- List.mem (`Flavour `Remark) pars || List.mem (`Flavour `Lemma) pars
-
-let mk_obj st = function
- | C.AConstant (_, _, s, Some v, t, [], pars) when is_theorem pars ->
- let ast = mk_proof (set_ety st (Some t)) v in
- let count = T.count_steps 0 ast in
- let text = Printf.sprintf "tactics: %u" count in
- T.Theorem (s, t, text) :: ast @ [T.Qed ""]
- | _ ->
- failwith "not a theorem"