X-Git-Url: http://matita.cs.unibo.it/gitweb/?a=blobdiff_plain;f=helm%2Fsoftware%2Fcomponents%2Fng_tactics%2FnCicElim.ml;h=359d93bbd5c72c48ff5700060fb82c4935ce0026;hb=b367de0252e88d6b0476648d5ceac7e4aeffca27;hp=1401ed48f8b6ecc7fe9849e02496a8fb62428031;hpb=b939bfdb17f3ce464c31db7463586d5f88a9700c;p=helm.git diff --git a/helm/software/components/ng_tactics/nCicElim.ml b/helm/software/components/ng_tactics/nCicElim.ml index 1401ed48f..359d93bbd 100644 --- a/helm/software/components/ng_tactics/nCicElim.ml +++ b/helm/software/components/ng_tactics/nCicElim.ml @@ -38,10 +38,11 @@ let mk_appl = function [] -> assert false | [x] -> x + | CicNotationPt.Appl l1 :: l2 -> CicNotationPt.Appl (l1 @ l2) | l -> CicNotationPt.Appl l ;; -let mk_elim uri leftno [it] (outsort,suffix) = +let mk_elim uri leftno it (outsort,suffix) pragma = let _,ind_name,ty,cl = it in let srec_name = ind_name ^ "_" ^ suffix in let rec_name = mk_id srec_name in @@ -52,30 +53,34 @@ let mk_elim uri leftno [it] (outsort,suffix) = let args,sort = NCicReduction.split_prods ~subst:[] [] (-1) ty in let args = List.rev_map (function name,_ -> mk_id name) args in let rec_arg = mk_id (fresh_name ()) in - let p_ty = + let mk_prods = List.fold_right - (fun name res -> CicNotationPt.Binder (`Forall,(name,None),res)) args + (fun name res -> CicNotationPt.Binder (`Forall,(name,None),res)) in + let p_ty = mk_prods args (CicNotationPt.Binder (`Forall, (rec_arg,Some (mk_appl (mk_id ind_name :: params @ args))), CicNotationPt.Sort outsort)) in + let mk_arrs n = mk_prods (HExtlib.mk_list (mk_id "_") n) in let args = args @ [rec_arg] in let k_names = List.map (function _,name,_ -> name_of_k name) cl in + (* let final_params = List.map (function name -> name, None) params @ [p_name,Some p_ty] @ List.map (function name -> name, None) k_names @ List.map (function name -> name, None) args in + *) let cty = mk_appl (p_name :: args) in let ty = Some cty in - let branches = + let branches_with_args = List.map (function (_,name,ty) -> let _,ty = NCicReduction.split_prods ~subst:[] [] leftno ty in let cargs,ty= my_split_prods ~subst:[] [] (-1) ty in - let cargs_and_recursive_args = - List.rev_map - (function + let cargs_recargs_nih = + List.fold_left + (fun (acc,nih) -> function _,NCic.Def _ -> assert false | name,NCic.Decl ty -> let context,ty = my_split_prods ~subst:[] [] (-1) ty in @@ -88,7 +93,7 @@ let mk_elim uri leftno [it] (outsort,suffix) = -> let abs = List.rev_map (fun id,_ -> mk_id id) context in let name = mk_id name in - name, Some ( + (name, Some ( List.fold_right (fun id res -> CicNotationPt.Binder (`Lambda,(id,None),res)) @@ -98,18 +103,31 @@ let mk_elim uri leftno [it] (outsort,suffix) = params @ [p_name] @ k_names @ - List.map (fun _ -> CicNotationPt.Implicit) + List.map (fun _ -> CicNotationPt.Implicit `JustOne) (List.tl args) @ - [mk_appl (name::abs)]))) - | _ -> mk_id name,None - ) cargs in + [mk_appl (name::abs)]))))::acc, nih + 1 + | _ -> (mk_id name,None)::acc,nih + ) ([],0) cargs in + let cargs_and_recursive_args, nih = cargs_recargs_nih in let cargs,recursive_args = List.split cargs_and_recursive_args in let recursive_args = HExtlib.filter_map (fun x -> x) recursive_args in - CicNotationPt.Pattern (name,None,List.map (fun x -> x,None) cargs), - mk_appl (name_of_k name :: cargs @ recursive_args) + (CicNotationPt.Pattern (name,None,List.map (fun x -> x,None) cargs), + mk_appl (name_of_k name :: cargs @ recursive_args)), (name,cargs, nih) ) cl in - let bo = CicNotationPt.Case (rec_arg,None,None,branches) in + let branches, branch_args = List.split branches_with_args in + let bo = CicNotationPt.Case (rec_arg,Some (ind_name,None),Some p_name,branches) in + let final_params = + List.map (function name -> name, None) params @ + [p_name,Some p_ty] @ + List.map (function name, cargs, nih -> + name_of_k name, + Some (mk_prods cargs (mk_arrs nih + (mk_appl + (p_name::HExtlib.mk_list (CicNotationPt.Implicit `JustOne) + (List.length args - 1) @ + [mk_appl (mk_id name :: params @ cargs)]))))) branch_args @ + List.map (function name -> name, None) args in let recno = List.length final_params in let where = recno - 1 in let res = @@ -148,21 +166,156 @@ let mk_elim uri leftno [it] (outsort,suffix) = (function x::_ -> x | _ -> assert false) 80 (CicNotationPres.mpres_of_box boxml))); *) - CicNotationPt.Theorem (`Definition,srec_name,CicNotationPt.Implicit,Some res) + CicNotationPt.Theorem + (`Definition,srec_name, + CicNotationPt.Implicit `JustOne,Some res,pragma) +;; + +let ast_of_sort s = + let headrm prefix s = + try + let len_prefix = String.length prefix in + assert (String.sub s 0 len_prefix = prefix); + String.sub s len_prefix (String.length s - len_prefix) + with Invalid_argument _ -> assert false + in + match s with + | NCic.Prop -> `Prop,"ind" + | NCic.Type [] -> `NType "", "rect_Type" + | NCic.Type ((`Type,u) :: _) -> + let name = NUri.name_of_uri u in + `NType (headrm "Type" name), "rect_" ^ name + | NCic.Type ((`CProp,u) :: _) -> + let name = NUri.name_of_uri u in + `NCProp (headrm "Type" name), + "rect_" ^ Str.replace_first (Str.regexp "Type") "CProp" name + | _ -> assert false ;; let mk_elims (uri,_,_,_,obj) = - let ast_of_sort s = - match s with - NCic.Prop -> `Prop,"ind" - | NCic.Type u -> - let u = NCicPp.ppterm ~metasenv:[] ~subst:[] ~context:[] (NCic.Sort s) in - `NType u, "rect_" ^ u - in match obj with - NCic.Inductive (true,leftno,itl,_) -> - List.map (fun s -> mk_elim uri leftno itl (ast_of_sort s)) + NCic.Inductive (true,leftno,[itl],_) -> + List.map (fun s -> mk_elim uri leftno itl (ast_of_sort s) (`Elim s)) (NCic.Prop:: List.map (fun s -> NCic.Type s) (NCicEnvironment.get_universes ())) | _ -> [] ;; + +(********************* Projections **********************) + +let mk_lambda = + function + [] -> assert false + | [t] -> t + | l -> CicNotationPt.Appl l +;; + +let rec count_prods = function NCic.Prod (_,_,t) -> 1 + count_prods t | _ -> 0;; + +let rec nth_prod projs n ty = + match ty with + NCic.Prod (_,s,_) when n=0 -> projs, s + | NCic.Prod (name,_,t) -> nth_prod (name::projs) (n-1) t + | _ -> assert false +;; + +(* this code should be unified with NTermCicContent.nast_of_cic0, + but the two contexts have different types *) +let rec pp rels = + function + NCic.Rel i -> List.nth rels (i - 1) + | NCic.Const _ as t -> + CicNotationPt.Ident + (NCicPp.ppterm ~metasenv:[] ~subst:[] ~context:[] t,None) + | NCic.Sort s -> CicNotationPt.Sort (fst (ast_of_sort s)) + | NCic.Meta _ + | NCic.Implicit _ -> assert false + | NCic.Appl l -> CicNotationPt.Appl (List.map (pp rels) l) + | NCic.Prod (n,s,t) -> + let n = mk_id n in + CicNotationPt.Binder (`Pi, (n,Some (pp rels s)), pp (n::rels) t) + | NCic.Lambda (n,s,t) -> + let n = mk_id n in + CicNotationPt.Binder (`Lambda, (n,Some (pp rels s)), pp (n::rels) t) + | NCic.LetIn (n,s,ty,t) -> + let n = mk_id n in + CicNotationPt.LetIn ((n, Some (pp rels ty)), pp rels s, pp (n::rels) t) + | NCic.Match (NReference.Ref (uri,_) as r,outty,te,patterns) -> + let name = NUri.name_of_uri uri in + let case_indty = Some (name, None) in + let constructors, leftno = + let _,leftno,tys,_,n = NCicEnvironment.get_checked_indtys r in + let _,_,_,cl = List.nth tys n in + cl,leftno + in + let rec eat_branch n rels ty pat = + match (ty, pat) with + | NCic.Prod (name, s, t), _ when n > 0 -> + eat_branch (pred n) rels t pat + | NCic.Prod (_, _, t), NCic.Lambda (name, s, t') -> + let cv, rhs = eat_branch 0 ((mk_id name)::rels) t t' in + (mk_id name, Some (pp rels s)) :: cv, rhs + | _, _ -> [], pp rels pat + in + let patterns = + try + List.map2 + (fun (_, name, ty) pat -> + let capture_variables,rhs = eat_branch leftno rels ty pat in + CicNotationPt.Pattern (name, None, capture_variables), rhs + ) constructors patterns + with Invalid_argument _ -> assert false + in + CicNotationPt.Case (pp rels te, case_indty, Some (pp rels outty), patterns) +;; + +let mk_projection leftno tyname consname consty (projname,_,_) i = + let argsno = count_prods consty - leftno in + let rec aux names ty leftno = + match leftno,ty with + | 0,_ -> + let arg = mk_id "xxx" in + let arg_ty = mk_appl (mk_id tyname :: List.rev names) in + let bvar = mk_id "yyy" in + let underscore = CicNotationPt.Ident ("_",None),None in + let bvars = + HExtlib.mk_list underscore i @ [bvar,None] @ + HExtlib.mk_list underscore (argsno - i -1) in + let branch = CicNotationPt.Pattern (consname,None,bvars), bvar in + let projs,outtype = nth_prod [] i ty in + let rels = + List.map + (fun name -> mk_appl (mk_id name :: List.rev names @ [arg])) projs + @ names in + let outtype = pp rels outtype in + let outtype= CicNotationPt.Binder (`Lambda, (arg, Some arg_ty), outtype) in + [arg, Some arg_ty], CicNotationPt.Case (arg,None,Some outtype,[branch]) + | _,NCic.Prod (name,_,t) -> + let name = mk_id name in + let params,body = aux (name::names) t (leftno - 1) in + (name,None)::params, body + | _,_ -> assert false + in + let params,bo = aux [] consty leftno in + let pprojname = mk_id projname in + let res = + CicNotationPt.LetRec (`Inductive, + [params, (pprojname,None), bo, leftno], pprojname) in +(* prerr_endline + (BoxPp.render_to_string + ~map_unicode_to_tex:false + (function x::_ -> x | _ -> assert false) + 80 (CicNotationPres.render (fun _ -> None) + (TermContentPres.pp_ast res)));*) + CicNotationPt.Theorem + (`Definition,projname,CicNotationPt.Implicit `JustOne,Some res,`Projection) +;; + +let mk_projections (_,_,_,_,obj) = + match obj with + NCic.Inductive + (true,leftno,[_,tyname,_,[_,consname,consty]],(_,`Record fields)) + -> + HExtlib.list_mapi (mk_projection leftno tyname consname consty) fields + | _ -> [] +;;