X-Git-Url: http://matita.cs.unibo.it/gitweb/?a=blobdiff_plain;f=components%2Fcontent_pres%2Facic2Procedural.ml;h=adfe4b05cdf8d647f26e68359332737e4c0097fc;hb=2e3e85acace6942eebcfac570ce6b33134d1a3dd;hp=c92d108e5500f3ed4bb0c159a04399fdc68d4fa3;hpb=5cd2bfac5e47232f9e1a8f6189bcc49a3e73007f;p=helm.git diff --git a/components/content_pres/acic2Procedural.ml b/components/content_pres/acic2Procedural.ml index c92d108e5..adfe4b05c 100644 --- a/components/content_pres/acic2Procedural.ml +++ b/components/content_pres/acic2Procedural.ml @@ -45,13 +45,17 @@ type status = { 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 = @@ -80,22 +84,23 @@ let string_of_head = function | 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 @@ -146,6 +151,27 @@ let defined_premise = "DEFINED" 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 @@ -164,17 +190,17 @@ try | 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 @@ -200,8 +226,8 @@ and mk_fwd_proof st dtext name = function 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 @@ -217,7 +243,7 @@ and mk_proof st = function | 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 @@ -228,42 +254,51 @@ and mk_proof st = function [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 @@ -276,9 +311,6 @@ try 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" @@ -299,14 +331,14 @@ let mk_obj st = function (* 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