prefix: string;
max_depth: int option;
depth: int;
- entries: C.context;
+ context: C.context;
intros: string list;
ety: C.annterm option
}
(* helpers ******************************************************************)
+let id x = x
+
+let comp f g x = f (g x)
+
let cic = D.deannotate_term
let split2_last l1 l2 =
| C.AMeta _ -> "meta"
| C.AImplicit _ -> "implict"
-let next st = {st with depth = succ st.depth; intros = []; ety = None}
+let clear st = {st with intros = []; ety = None}
+
+let next st = {(clear st) with depth = succ st.depth}
let set_ety st ety =
if st.ety = None then {st with ety = ety} else st
let add st entry intro ety =
let st = set_ety st ety in
- {st with entries = entry :: st.entries; intros = intro :: st.intros}
+ {st with context = entry :: st.context; intros = intro :: st.intros}
let test_depth st =
try
let msg = Printf.sprintf "Depth %u: " st.depth in
match st.max_depth with
| None -> true, ""
- | Some d ->
- if st.depth < d then true, msg else false, "DEPTH EXCEDED"
+ | Some d -> if st.depth < d then true, msg else false, "DEPTH EXCEDED: "
with Invalid_argument _ -> failwith "A2P.test_depth"
let is_rewrite_right = function
let assumed_premise = "ASSUMED"
+let expanded_premise = "EXPANDED"
+
+let eta_expand n t =
+ let ty = C.AImplicit ("", None) in
+ let name i = Printf.sprintf "%s%u" expanded_premise i in
+ let lambda i t = C.ALambda ("", C.Name (name i), ty, t) in
+ let arg i n = T.mk_arel (n - i) (name i) in
+ let rec aux i f a =
+ if i >= n then f, a else aux (succ i) (comp f (lambda i)) (arg i n :: a)
+ in
+ let absts, args = aux 0 id [] in
+ match Cn.lift 1 n t with
+ | C.AAppl (id, ts) -> absts (C.AAppl (id, ts @ args))
+ | t -> absts (C.AAppl ("", t :: args))
+
+let appl_expand n = function
+ | C.AAppl (id, ts) ->
+ let before, after = T.list_split (List.length ts + n) ts in
+ C.AAppl ("", C.AAppl (id, before) :: after)
+ | _ -> assert false
+
let get_intro name t =
try
match name with
| Some ety when Cn.need_whd count ety -> p0 :: p1 :: script
| _ -> p1 :: script
with Invalid_argument _ -> failwith "A2P.mk_intros"
-(*
-let rec mk_premise st dtext = function
- | C.ARel (_, _, _, binder) -> [], binder
- | where ->
- let name = contracted_premise in
- mk_fwd_proof st dtext name where, name
-*)
-let rec mk_fwd_rewrite st dtext name tl direction =
+
+let rec mk_atomic st dtext what =
+ if T.is_atomic what then [], what else
+ let name = defined_premise in
+ mk_fwd_proof st dtext name what, T.mk_arel 0 name
+
+and mk_fwd_rewrite st dtext name tl direction =
let what, where = List.nth tl 5, List.nth tl 3 in
let rewrite premise =
- [T.Rewrite (direction, what, Some (premise, name), dtext)]
+ let script, what = mk_atomic st dtext what in
+ T.Rewrite (direction, what, Some (premise, name), dtext) :: script
in
match where with
| C.ARel (_, _, _, binder) -> rewrite binder
let qs = [[T.Id ""]; mk_proof (next st) v] in
[T.Branch (qs, ""); T.Cut (name, ity, dtext)]
| None ->
- let ty, _ = TC.type_of_aux' [] st.entries (cic hd) Un.empty_ugraph in
- let (classes, rc) as h = Cl.classify ty in
+ 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 text = Printf.sprintf "%u %s" (List.length classes) (Cl.to_string h) in
[T.LetIn (name, v, dtext ^ text)]
end
| None -> None
in
mk_proof (add st entry intro ety) t
- | C.ALetIn (_, name, v, t) as what ->
+ | 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
[T.Apply (what, dtext)]
in
mk_intros st script
- | C.ARel _ as what ->
+ | 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 ->
+ | 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 ->
+ | 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.entries (cic hd) Un.empty_ugraph in
- let (classes, rc) as h = Cl.classify ty in
- let synth = Cl.S.singleton 0 in
+ 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 ->
+ | 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
- [T.Rewrite (false, what, None, dtext); T.Branch (qs, "")]
+ List.rev script @
+ [T.Rewrite (false, what, None, dtext); T.Branch (qs, "")]
else if is_rewrite_left hd then
- [T.Rewrite (true, what, None, dtext); T.Branch (qs, "")]
+ List.rev script @
+ [T.Rewrite (true, what, None, dtext); T.Branch (qs, "")]
else
let using = Some hd in
+ List.rev script @
[T.Elim (what, using, dtext ^ text); T.Branch (qs, "")]
- | _ ->
+ | _ ->
let qs = mk_bkd_proofs (next st) synth classes tl in
- [T.Apply (hd, dtext ^ text); T.Branch (qs, "")]
+ let script, hd = mk_atomic st dtext hd in
+ List.rev script @
+ [T.Apply (hd, dtext ^ text); T.Branch (qs, "")]
else
[T.Apply (t, dtext)]
in
mk_intros st script
- | t ->
+ | t ->
let text = Printf.sprintf "%s: %s" "UNEXPANDED" (string_of_head t) in
let script = [T.Note text] in
mk_intros st script
if Cl.S.is_empty inv then Some (mk_proof st v) else
Some [T.Apply (v, dtext ^ "dependent")]
in
- let l1, l2 = List.length classes, List.length ts in
- if l1 > l2 then failwith "partial application" else
- if l1 < l2 then failwith "too many arguments" else
T.list_map2_filter aux classes ts
with Invalid_argument _ -> failwith "A2P.mk_bkd_proofs"
(* interface functions ******************************************************)
-let acic2procedural ~ids_to_inner_sorts ~ids_to_inner_types prefix aobj =
+let acic2procedural ~ids_to_inner_sorts ~ids_to_inner_types ?depth prefix aobj =
let st = {
sorts = ids_to_inner_sorts;
types = ids_to_inner_types;
prefix = prefix;
- max_depth = None;
+ max_depth = depth;
depth = 0;
- entries = [];
+ context = [];
intros = [];
ety = None
} in
projects / helm.git / blobdiff