- match xcno with
- | None -> tname
- | Some cno -> fst (List.nth cs (pred cno))
-with Invalid_argument _ -> failwith "A2P.get_ind_name"
-*)
-let get_inner_types st v =
-try
- let id = Ut.id_of_annterm v in
- try match Hashtbl.find st.types id with
- | {A.annsynthesized = st; A.annexpected = Some et} -> Some (st, et)
- | {A.annsynthesized = st; A.annexpected = None} -> Some (st, st)
- with Not_found -> None
-with Invalid_argument _ -> failwith "A2P.get_inner_types"
-
-let get_inner_sort st v =
-try
- let id = Ut.id_of_annterm v in
- try Hashtbl.find st.sorts id
- with Not_found -> `Type (CicUniv.fresh())
-with Invalid_argument _ -> failwith "A2P.get_sort"
-
-let get_type msg st bo =
-try
- let ty, _ = TC.type_of_aux' [] st.context (cic bo) Un.empty_ugraph in
- ty
-with e -> failwith (msg ^ ": " ^ Printexc.to_string e)
-
-(* proof construction *******************************************************)
-
-let unused_premise = "UNUSED"
-
-let defined_premise = "DEFINED"
-
-let convert st ?name v =
- match get_inner_types st v with
- | None -> []
- | Some (st, et) ->
- let cst, cet = cic st, cic et in
- if PER.alpha_equivalence cst cet then [] else
- let e = Cn.mk_pattern 0 (T.mk_arel 1 "") in
- match name with
- | None -> [T.Change (st, et, None, e, "")]
- | Some id -> [T.Change (st, et, Some (id, id), e, ""); T.ClearBody (id, "")]
-
-let get_intro name t =
-try
-match name with
- | C.Anonymous -> unused_premise
- | C.Name s ->
- if DTI.does_not_occur 1 (cic t) then unused_premise else s
-with Invalid_argument _ -> failwith "A2P.get_intro"
-
-let mk_intros st script =
-try
- if st.intros = [] then script else
- let count = List.length st.intros in
- T.Intros (Some count, List.rev st.intros, "") :: script
-with Invalid_argument _ -> failwith "A2P.mk_intros"
-
-let rec mk_atomic st dtext what =
- if T.is_atomic what then
- match what with
- | C.ARel (_, _, _, name) -> convert st ~name what, what
- | _ -> [], what
- else
- let name = defined_premise in
- let script = convert st ~name what in
- script @ mk_fwd_proof st dtext name what, T.mk_arel 0 name
-
-and mk_fwd_rewrite st dtext name tl direction =
- assert (List.length tl = 6);
- let what, where, predicate = List.nth tl 5, List.nth tl 3, List.nth tl 2 in
- let e = Cn.mk_pattern 1 predicate in
- match where with
- | C.ARel (_, _, _, premise) ->
- let script, what = mk_atomic st dtext what in
- T.Rewrite (direction, what, Some (premise, name), e, dtext) :: script
- | _ -> assert false
-
-and mk_rewrite st dtext script t what qs tl direction =
- assert (List.length tl = 5);
- let predicate = List.nth tl 2 in
- let e = Cn.mk_pattern 1 predicate in
- List.rev script @ convert st t @
- [T.Rewrite (direction, what, None, e, dtext); T.Branch (qs, "")]
-
-and mk_fwd_proof st dtext name = function
- | C.ALetIn (_, n, v, t) ->
- let entry = Some (n, C.Def (cic v, None)) in
- let intro = get_intro n t in
- let qt = mk_fwd_proof (add st entry intro) dtext name t in
- let qv = mk_fwd_proof st "" intro v in
- List.append qt qv
- | C.AAppl (_, hd :: tl) as v ->
- if is_fwd_rewrite_right hd tl then mk_fwd_rewrite st dtext name tl true else
- if is_fwd_rewrite_left hd tl then mk_fwd_rewrite st dtext name tl false else
- let ty = get_type "TC1" st hd in
- begin match get_inner_types st v with
- | Some (ity, _) when M.bkd st.context ty ->
- let qs = [[T.Id ""]; mk_proof (next st) v] in
- [T.Branch (qs, ""); T.Cut (name, ity, dtext)]
- | _ ->
- let (classes, rc) as h = Cl.classify st.context ty in
- let text = Printf.sprintf "%u %s" (List.length classes) (Cl.to_string h) in
- [T.LetIn (name, v, dtext ^ text)]
- end
- | C.AMutCase _ -> assert false
- | C.ACast _ -> assert false
- | v ->
- match get_inner_types st v with
- | Some (ity, _) ->
- let qs = [[T.Id ""]; mk_proof (next st) v] in
- [T.Branch (qs, ""); T.Cut (name, ity, dtext)]
- | _ ->
- [T.LetIn (name, v, dtext)]
-
-and mk_proof st = function
- | C.ALambda (_, name, v, t) ->
- let entry = Some (name, C.Decl (cic v)) in
- let intro = get_intro name t in
- mk_proof (add st entry intro) 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)) 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 = get_type "TC2" st hd in
- let (classes, rc) as h = Cl.classify st.context ty in
- let premises, _ = P.split st.context ty in
- assert (List.length classes - List.length tl = 0);
- let synth = I.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 && M.is_eliminator premises ->
- let classes, tl, _, what = split2_last classes tl in
- let script, what = mk_atomic st dtext what in
- let synth = I.S.add 1 synth in
- let qs = mk_bkd_proofs (next st) synth classes tl in
- if is_rewrite_right hd then
- mk_rewrite st dtext script t what qs tl false
- else if is_rewrite_left hd then
- mk_rewrite st dtext script t what qs tl true
- else
- let l = succ (List.length tl) in
- let predicate = List.nth tl (l - i) in
- let e = Cn.mk_pattern j predicate in
- let using = Some hd in
- List.rev script @ convert st t @
- [T.Elim (what, using, e, 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 _ -> assert false
- | C.ACast _ -> assert false
- | 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 I.overlaps synth inv then None else
- if I.S.is_empty inv then Some (mk_proof st v) else
- Some [T.Apply (v, dtext ^ "dependent")]