diff options
Diffstat (limited to 'contrib')
50 files changed, 5696 insertions, 2422 deletions
diff --git a/contrib/dp/dp.ml b/contrib/dp/dp.ml index af684e6e..131dd029 100644 --- a/contrib/dp/dp.ml +++ b/contrib/dp/dp.ml @@ -639,8 +639,8 @@ let remove_files = List.iter (fun f -> try Sys.remove f with _ -> ()) let sprintf = Format.sprintf let call_simplify fwhy = - if Sys.command (sprintf "why --simplify %s" fwhy) <> 0 then - anomaly ("call to why --simplify " ^ fwhy ^ " failed; please report"); + let cmd = sprintf "why --simplify %s" fwhy in + if Sys.command cmd <> 0 then error ("Call to " ^ cmd ^ " failed"); let fsx = Filename.chop_suffix fwhy ".why" ^ "_why.sx" in let cmd = sprintf "timeout 10 Simplify %s > out 2>&1 && grep -q -w Valid out" fsx @@ -652,8 +652,7 @@ let call_simplify fwhy = let call_zenon fwhy = let cmd = sprintf "why --no-prelude --no-zenon-prelude --zenon %s" fwhy in - if Sys.command cmd <> 0 then - anomaly ("call to " ^ cmd ^ " failed; please report"); + if Sys.command cmd <> 0 then error ("call to " ^ cmd ^ " failed"); let fznn = Filename.chop_suffix fwhy ".why" ^ "_why.znn" in let cmd = sprintf "timeout 10 zenon %s > out 2>&1 && grep -q PROOF-FOUND out" fznn @@ -669,8 +668,8 @@ let call_zenon fwhy = r let call_cvcl fwhy = - if Sys.command (sprintf "why --cvcl %s" fwhy) <> 0 then - anomaly ("call to why --cvcl " ^ fwhy ^ " failed; please report"); + let cmd = sprintf "why --cvcl %s" fwhy in + if Sys.command cmd <> 0 then error ("call to " ^ cmd ^ " failed"); let fcvc = Filename.chop_suffix fwhy ".why" ^ "_why.cvc" in let cmd = sprintf "timeout 10 cvcl < %s > out 2>&1 && grep -q -w Valid out" fcvc @@ -681,8 +680,8 @@ let call_cvcl fwhy = r let call_harvey fwhy = - if Sys.command (sprintf "why --harvey %s" fwhy) <> 0 then - anomaly ("call to why --harvey " ^ fwhy ^ " failed; please report"); + let cmd = sprintf "why --harvey %s" fwhy in + if Sys.command cmd <> 0 then error ("call to " ^ cmd ^ " failed"); let frv = Filename.chop_suffix fwhy ".why" ^ "_why.rv" in let out = Sys.command (sprintf "rvc -e -t %s > /dev/null 2>&1" frv) in if out <> 0 then anomaly ("call to rvc -e -t " ^ frv ^ " failed"); diff --git a/contrib/extraction/extract_env.ml b/contrib/extraction/extract_env.ml index 2d425e9f..e31b701c 100644 --- a/contrib/extraction/extract_env.ml +++ b/contrib/extraction/extract_env.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: extract_env.ml 9310 2006-10-28 19:35:09Z herbelin $ i*) +(*i $Id: extract_env.ml 9486 2007-01-15 19:11:28Z letouzey $ i*) open Term open Declarations @@ -53,23 +53,55 @@ let environment_until dir_opt = | _ -> assert false in parse (Library.loaded_libraries ()) -type visit = - { mutable kn : KNset.t; mutable ref : Refset.t; mutable mp : MPset.t } -let in_kn v kn = KNset.mem kn v.kn -let in_ref v ref = Refset.mem ref v.ref -let in_mp v mp = MPset.mem mp v.mp - -let visit_mp v mp = v.mp <- MPset.union (prefixes_mp mp) v.mp -let visit_kn v kn = v.kn <- KNset.add kn v.kn; visit_mp v (modpath kn) -let visit_ref v r = - let r = - (* if we meet a constructor we must export the inductive definition *) - match r with - ConstructRef (r,_) -> IndRef r - | _ -> r - in - v.ref <- Refset.add r v.ref; visit_mp v (modpath_of_r r) +(*s Visit: + a structure recording the needed dependencies for the current extraction *) + +module type VISIT = sig + (* Reset the dependencies by emptying the visit lists *) + val reset : unit -> unit + + (* Add the module_path and all its prefixes to the mp visit list *) + val add_mp : module_path -> unit + + (* Add kernel_name / constant / reference / ... in the visit lists. + These functions silently add the mp of their arg in the mp list *) + val add_kn : kernel_name -> unit + val add_con : constant -> unit + val add_ref : global_reference -> unit + val add_decl_deps : ml_decl -> unit + val add_spec_deps : ml_spec -> unit + + (* Test functions: + is a particular object a needed dependency for the current extraction ? *) + val needed_kn : kernel_name -> bool + val needed_con : constant -> bool + val needed_mp : module_path -> bool +end + +module Visit : VISIT = struct + (* Thanks to C.S.C, what used to be in a single KNset should now be split + into a KNset (for inductives and modules names) and a Cset for constants + (and still the remaining MPset) *) + type must_visit = + { mutable kn : KNset.t; mutable con : Cset.t; mutable mp : MPset.t } + (* the imperative internal visit lists *) + let v = { kn = KNset.empty ; con = Cset.empty ; mp = MPset.empty } + (* the accessor functions *) + let reset () = v.kn <- KNset.empty; v.con <- Cset.empty; v.mp <- MPset.empty + let needed_kn kn = KNset.mem kn v.kn + let needed_con c = Cset.mem c v.con + let needed_mp mp = MPset.mem mp v.mp + let add_mp mp = v.mp <- MPset.union (prefixes_mp mp) v.mp + let add_kn kn = v.kn <- KNset.add kn v.kn; add_mp (modpath kn) + let add_con c = v.con <- Cset.add c v.con; add_mp (con_modpath c) + let add_ref = function + | ConstRef c -> add_con c + | IndRef (kn,_) | ConstructRef ((kn,_),_) -> add_kn kn + | VarRef _ -> assert false + let add_decl_deps = decl_iter_references add_ref add_ref add_ref + let add_spec_deps = spec_iter_references add_ref add_ref add_ref +end exception Impossible @@ -104,115 +136,108 @@ let factor_fix env l cb msb = labels, recd, msb'' end -let get_decl_references v d = - let f = visit_ref v in decl_iter_references f f f d - -let get_spec_references v s = - let f = visit_ref v in spec_iter_references f f f s - -let rec extract_msig env v mp = function +let rec extract_msig env mp = function | [] -> [] | (l,SPBconst cb) :: msig -> let kn = make_con mp empty_dirpath l in let s = extract_constant_spec env kn cb in - if logical_spec s then extract_msig env v mp msig + if logical_spec s then extract_msig env mp msig else begin - get_spec_references v s; - (l,Spec s) :: (extract_msig env v mp msig) + Visit.add_spec_deps s; + (l,Spec s) :: (extract_msig env mp msig) end | (l,SPBmind cb) :: msig -> let kn = make_kn mp empty_dirpath l in let s = Sind (kn, extract_inductive env kn) in - if logical_spec s then extract_msig env v mp msig + if logical_spec s then extract_msig env mp msig else begin - get_spec_references v s; - (l,Spec s) :: (extract_msig env v mp msig) + Visit.add_spec_deps s; + (l,Spec s) :: (extract_msig env mp msig) end | (l,SPBmodule {msb_modtype=mtb}) :: msig -> -(*i let mpo = Some (MPdot (mp,l)) in i*) - (l,Smodule (extract_mtb env v None (*i mpo i*) mtb)) :: (extract_msig env v mp msig) + (l,Smodule (extract_mtb env None mtb)) :: (extract_msig env mp msig) | (l,SPBmodtype mtb) :: msig -> - (l,Smodtype (extract_mtb env v None mtb)) :: (extract_msig env v mp msig) + (l,Smodtype (extract_mtb env None mtb)) :: (extract_msig env mp msig) -and extract_mtb env v mpo = function - | MTBident kn -> visit_kn v kn; MTident kn +and extract_mtb env mpo = function + | MTBident kn -> Visit.add_kn kn; MTident kn | MTBfunsig (mbid, mtb, mtb') -> let mp = MPbound mbid in let env' = Modops.add_module mp (Modops.module_body_of_type mtb) env in - MTfunsig (mbid, extract_mtb env v None mtb, - extract_mtb env' v None mtb') + MTfunsig (mbid, extract_mtb env None mtb, + extract_mtb env' None mtb') | MTBsig (msid, msig) -> let mp, msig = match mpo with | None -> MPself msid, msig | Some mp -> mp, Modops.subst_signature_msid msid mp msig in let env' = Modops.add_signature mp msig env in - MTsig (msid, extract_msig env' v mp msig) + MTsig (msid, extract_msig env' mp msig) -let rec extract_msb env v mp all = function +let rec extract_msb env mp all = function | [] -> [] | (l,SEBconst cb) :: msb -> (try let vl,recd,msb = factor_fix env l cb msb in - let vkn = Array.map (fun id -> make_con mp empty_dirpath id) vl in - let ms = extract_msb env v mp all msb in - let b = array_exists (fun con -> in_ref v (ConstRef con)) vkn in + let vc = Array.map (make_con mp empty_dirpath) vl in + let ms = extract_msb env mp all msb in + let b = array_exists Visit.needed_con vc in if all || b then - let d = extract_fixpoint env vkn recd in + let d = extract_fixpoint env vc recd in if (not b) && (logical_decl d) then ms - else begin get_decl_references v d; (l,SEdecl d) :: ms end + else begin Visit.add_decl_deps d; (l,SEdecl d) :: ms end else ms with Impossible -> - let ms = extract_msb env v mp all msb in - let kn = make_con mp empty_dirpath l in - let b = in_ref v (ConstRef kn) in + let ms = extract_msb env mp all msb in + let c = make_con mp empty_dirpath l in + let b = Visit.needed_con c in if all || b then - let d = extract_constant env kn cb in + let d = extract_constant env c cb in if (not b) && (logical_decl d) then ms - else begin get_decl_references v d; (l,SEdecl d) :: ms end + else begin Visit.add_decl_deps d; (l,SEdecl d) :: ms end else ms) | (l,SEBmind mib) :: msb -> - let ms = extract_msb env v mp all msb in + let ms = extract_msb env mp all msb in let kn = make_kn mp empty_dirpath l in - let b = in_ref v (IndRef (kn,0)) in (* 0 is dummy *) + let b = Visit.needed_kn kn in if all || b then let d = Dind (kn, extract_inductive env kn) in if (not b) && (logical_decl d) then ms - else begin get_decl_references v d; (l,SEdecl d) :: ms end + else begin Visit.add_decl_deps d; (l,SEdecl d) :: ms end else ms | (l,SEBmodule mb) :: msb -> - let ms = extract_msb env v mp all msb in + let ms = extract_msb env mp all msb in let mp = MPdot (mp,l) in - if all || in_mp v mp then - (l,SEmodule (extract_module env v mp true mb)) :: ms + if all || Visit.needed_mp mp then + (l,SEmodule (extract_module env mp true mb)) :: ms else ms | (l,SEBmodtype mtb) :: msb -> - let ms = extract_msb env v mp all msb in + let ms = extract_msb env mp all msb in let kn = make_kn mp empty_dirpath l in - if all || in_kn v kn then - (l,SEmodtype (extract_mtb env v None mtb)) :: ms + if all || Visit.needed_kn kn then + (l,SEmodtype (extract_mtb env None mtb)) :: ms else ms -and extract_meb env v mpo all = function +and extract_meb env mpo all = function | MEBident (MPfile d) -> error_MPfile_as_mod d (* temporary (I hope) *) - | MEBident mp -> visit_mp v mp; MEident mp + | MEBident mp -> Visit.add_mp mp; MEident mp | MEBapply (meb, meb',_) -> - MEapply (extract_meb env v None true meb, - extract_meb env v None true meb') + MEapply (extract_meb env None true meb, + extract_meb env None true meb') | MEBfunctor (mbid, mtb, meb) -> let mp = MPbound mbid in let env' = Modops.add_module mp (Modops.module_body_of_type mtb) env in - MEfunctor (mbid, extract_mtb env v None mtb, - extract_meb env' v None true meb) + MEfunctor (mbid, extract_mtb env None mtb, + extract_meb env' None true meb) | MEBstruct (msid, msb) -> let mp,msb = match mpo with | None -> MPself msid, msb | Some mp -> mp, subst_msb (map_msid msid mp) msb in let env' = add_structure mp msb env in - MEstruct (msid, extract_msb env' v mp all msb) + MEstruct (msid, extract_msb env' mp all msb) -and extract_module env v mp all mb = +and extract_module env mp all mb = (* [mb.mod_expr <> None ], since we look at modules from outside. *) (* Example of module with empty [mod_expr] is X inside a Module F [X:SIG]. *) let meb = out_some mb.mod_expr in @@ -220,25 +245,21 @@ and extract_module env v mp all mb = (* Because of the "with" construct, the module type can be [MTBsig] with *) (* a msid different from the one of the module. Here is the patch. *) let mtb = replicate_msid meb mtb in - { ml_mod_expr = extract_meb env v (Some mp) all meb; - ml_mod_type = extract_mtb env v None mtb } + { ml_mod_expr = extract_meb env (Some mp) all meb; + ml_mod_type = extract_mtb env None mtb } let unpack = function MEstruct (_,sel) -> sel | _ -> assert false let mono_environment refs mpl = - let l = environment_until None in - let v = - let add_ref r = Refset.add r in - let refs = List.fold_right add_ref refs Refset.empty in - let add_mp mp = MPset.union (prefixes_mp mp) in - let mps = List.fold_right add_mp mpl MPset.empty in - let mps = Refset.fold (fun k -> add_mp (modpath_of_r k)) refs mps in - { kn = KNset.empty; ref = refs; mp = mps } - in + Visit.reset (); + List.iter Visit.add_ref refs; + List.iter Visit.add_mp mpl; let env = Global.env () in - List.rev_map (fun (mp,m) -> mp, unpack (extract_meb env v (Some mp) false m)) - (List.rev l) + let l = List.rev (environment_until None) in + List.rev_map + (fun (mp,m) -> mp, unpack (extract_meb env (Some mp) false m)) l + (*s Recursive extraction in the Coq toplevel. The vernacular command is \verb!Recursive Extraction! [qualid1] ... [qualidn]. We use [extract_env] to get the saturated environment to extract. *) @@ -259,6 +280,7 @@ let mono_extraction (f,m) qualids = let prm = {modular=false; mod_name = m; to_appear= refs} in let struc = optimize_struct prm None (mono_environment refs mps) in print_structure_to_file f prm struc; + Visit.reset (); reset_tables () let extraction_rec = mono_extraction (None,id_of_string "Main") @@ -277,15 +299,15 @@ let extraction qid = let r = Nametab.global qid in if is_custom r then msgnl (str "User defined extraction:" ++ spc () ++ - str (find_custom r) ++ fnl ()) - else begin + str (find_custom r) ++ fnl ()) + else let prm = - { modular = false; mod_name = id_of_string "Main"; to_appear = [r]} in + { modular = false; mod_name = id_of_string "Main"; to_appear = [r]} in let struc = optimize_struct prm None (mono_environment [r] []) in let d = get_decl_in_structure r struc in print_one_decl struc (modpath_of_r r) d; - reset_tables () - end + Visit.reset (); + reset_tables () (*s Extraction to a file (necessarily recursive). The vernacular command is @@ -313,32 +335,33 @@ let extraction_file f vl = let extraction_module m = check_inside_section (); check_inside_module (); - match lang () with + begin match lang () with | Toplevel -> error_toplevel () | Scheme -> error_scheme () - | _ -> - let q = snd (qualid_of_reference m) in - let mp = - try Nametab.locate_module q - with Not_found -> error_unknown_module q - in - let b = is_modfile mp in - let prm = {modular=b; mod_name = id_of_string ""; to_appear= []} in - let l = environment_until None in - let v={ kn = KNset.empty ; ref = Refset.empty; mp = prefixes_mp mp } in - let env = Global.env () in - let struc = - List.rev_map - (fun (mp,m) -> mp, unpack (extract_meb env v (Some mp) b m)) - (List.rev l) - in - let struc = optimize_struct prm None struc in - let struc = - let bmp = base_mp mp in - try [bmp, List.assoc bmp struc] with Not_found -> assert false - in - print_structure_to_file None prm struc; - reset_tables () + | _ -> () + end; + let q = snd (qualid_of_reference m) in + let mp = + try Nametab.locate_module q with Not_found -> error_unknown_module q + in + let b = is_modfile mp in + let prm = {modular=b; mod_name = id_of_string ""; to_appear= []} in + Visit.reset (); + Visit.add_mp mp; + let env = Global.env () in + let l = List.rev (environment_until None) in + let struc = + List.rev_map (fun (mp,m) -> mp, unpack (extract_meb env (Some mp) b m)) l + in + let struc = optimize_struct prm None struc in + let struc = + let bmp = base_mp mp in + try [bmp, List.assoc bmp struc] with Not_found -> assert false + in + print_structure_to_file None prm struc; + Visit.reset (); + reset_tables () + (*s (Recursive) Extraction of a library. The vernacular command is \verb!(Recursive) Extraction Library! [M]. *) @@ -355,38 +378,38 @@ let dir_module_of_id m = let extraction_library is_rec m = check_inside_section (); check_inside_module (); - match lang () with + begin match lang () with | Toplevel -> error_toplevel () | Scheme -> error_scheme () - | _ -> - let dir_m = dir_module_of_id m in - let v = - { kn = KNset.empty; ref = Refset.empty; - mp = MPset.singleton (MPfile dir_m) } in - let l = environment_until (Some dir_m) in - let struc = - let env = Global.env () in - let select l (mp,meb) = - if in_mp v mp (* [mp] est long -> [in_mp] peut etre sans [long_mp] *) - then (mp, unpack (extract_meb env v (Some mp) true meb)) :: l - else l - in - List.fold_left select [] (List.rev l) - in - let dummy_prm = {modular=true; mod_name=m; to_appear=[]} in - let struc = optimize_struct dummy_prm None struc in - let rec print = function - | [] -> () - | (MPfile dir, _) :: l when not is_rec && dir <> dir_m -> print l - | (MPfile dir, sel) as e :: l -> - let short_m = snd (split_dirpath dir) in - let f = module_file_name short_m in - let prm = {modular=true;mod_name=short_m;to_appear=[]} in - print_structure_to_file (Some f) prm [e]; - print l - | _ -> assert false - in print struc; - reset_tables () + | _ -> () + end; + let dir_m = dir_module_of_id m in + Visit.reset (); + Visit.add_mp (MPfile dir_m); + let env = Global.env () in + let l = List.rev (environment_until (Some dir_m)) in + let select l (mp,meb) = + if Visit.needed_mp mp + then (mp, unpack (extract_meb env (Some mp) true meb)) :: l + else l + in + let struc = List.fold_left select [] l in + let dummy_prm = {modular=true; mod_name=m; to_appear=[]} in + let struc = optimize_struct dummy_prm None struc in + let rec print = function + | [] -> () + | (MPfile dir, _) :: l when not is_rec && dir <> dir_m -> print l + | (MPfile dir, sel) as e :: l -> + let short_m = snd (split_dirpath dir) in + let f = module_file_name short_m in + let prm = {modular=true;mod_name=short_m;to_appear=[]} in + print_structure_to_file (Some f) prm [e]; + print l + | _ -> assert false + in + print struc; + Visit.reset (); + reset_tables () diff --git a/contrib/extraction/extraction.ml b/contrib/extraction/extraction.ml index 52e7f1dd..6fd4a3cc 100644 --- a/contrib/extraction/extraction.ml +++ b/contrib/extraction/extraction.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: extraction.ml 9310 2006-10-28 19:35:09Z herbelin $ i*) +(*i $Id: extraction.ml 9456 2006-12-17 20:08:38Z letouzey $ i*) (*i*) open Util @@ -310,6 +310,9 @@ and extract_ind env kn = (* kn is supposed to be in long form *) with Not_found -> internal_call := KNset.add kn !internal_call; let mib = Environ.lookup_mind kn env in + (* First, if this inductive is aliased via a Module, *) + (* we process the original inductive. *) + option_iter (fun kn -> ignore (extract_ind env kn)) mib.mind_equiv; (* Everything concerning parameters. *) (* We do that first, since they are common to all the [mib]. *) let mip0 = mib.mind_packets.(0) in @@ -332,7 +335,11 @@ and extract_ind env kn = (* kn is supposed to be in long form *) ip_types = t }) mib.mind_packets in - add_ind kn {ind_info = Standard; ind_nparams = npar; ind_packets = packets}; + add_ind kn + {ind_info = Standard; + ind_nparams = npar; + ind_packets = packets; + ind_equiv = mib.mind_equiv }; (* Second pass: we extract constructors *) for i = 0 to mib.mind_ntypes - 1 do let p = packets.(i) in @@ -413,7 +420,11 @@ and extract_ind env kn = (* kn is supposed to be in long form *) Record field_glob with (I info) -> info in - let i = {ind_info = ind_info; ind_nparams = npar; ind_packets = packets} in + let i = {ind_info = ind_info; + ind_nparams = npar; + ind_packets = packets; + ind_equiv = mib.mind_equiv} + in add_ind kn i; internal_call := KNset.remove kn !internal_call; i diff --git a/contrib/extraction/miniml.mli b/contrib/extraction/miniml.mli index e34abe02..3b4146f8 100644 --- a/contrib/extraction/miniml.mli +++ b/contrib/extraction/miniml.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: miniml.mli 8724 2006-04-20 09:57:01Z letouzey $ i*) +(*i $Id: miniml.mli 9456 2006-12-17 20:08:38Z letouzey $ i*) (*s Target language for extraction: a core ML called MiniML. *) @@ -79,7 +79,9 @@ type ml_ind_packet = { type ml_ind = { ind_info : inductive_info; ind_nparams : int; - ind_packets : ml_ind_packet array } + ind_packets : ml_ind_packet array; + ind_equiv : kernel_name option +} (*s ML terms. *) diff --git a/contrib/extraction/modutil.ml b/contrib/extraction/modutil.ml index 46d4a5a6..c9d4e237 100644 --- a/contrib/extraction/modutil.ml +++ b/contrib/extraction/modutil.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: modutil.ml 8724 2006-04-20 09:57:01Z letouzey $ i*) +(*i $Id: modutil.ml 9456 2006-12-17 20:08:38Z letouzey $ i*) open Names open Declarations @@ -195,7 +195,10 @@ let ind_iter_references do_term do_cons do_type kn ind = let type_iter = type_iter_references do_type in let cons_iter cp l = do_cons (ConstructRef cp); List.iter type_iter l in let packet_iter ip p = - do_type (IndRef ip); Array.iteri (fun j -> cons_iter (ip,j+1)) p.ip_types + do_type (IndRef ip); + if lang () = Ocaml then + option_iter (fun kne -> do_type (IndRef (kne,snd ip))) ind.ind_equiv; + Array.iteri (fun j -> cons_iter (ip,j+1)) p.ip_types in if lang () = Ocaml then record_iter_references do_term ind.ind_info; Array.iteri (fun i -> packet_iter (kn,i)) ind.ind_packets diff --git a/contrib/extraction/ocaml.ml b/contrib/extraction/ocaml.ml index 483da236..35f9a83c 100644 --- a/contrib/extraction/ocaml.ml +++ b/contrib/extraction/ocaml.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: ocaml.ml 8930 2006-06-09 02:14:34Z letouzey $ i*) +(*i $Id: ocaml.ml 9472 2007-01-05 15:49:32Z letouzey $ i*) (*s Production of Ocaml syntax. *) @@ -392,7 +392,14 @@ let rec pp_Dfix init i ((rv,c,t) as fix) = (*s Pretty-printing of inductive types declaration. *) -let pp_one_ind prefix ip pl cv = +let pp_equiv param_list = function + | None -> mt () + | Some ip_equiv -> + str " = " ++ pp_parameters param_list ++ pp_global (IndRef ip_equiv) + +let pp_comment s = str "(* " ++ s ++ str " *)" + +let pp_one_ind prefix ip ip_equiv pl cv = let pl = rename_tvars keywords pl in let pp_constructor (r,l) = hov 2 (str " | " ++ pp_global r ++ @@ -402,13 +409,12 @@ let pp_one_ind prefix ip pl cv = prlist_with_sep (fun () -> spc () ++ str "* ") (pp_type true pl) l)) in - pp_parameters pl ++ str prefix ++ pp_global (IndRef ip) ++ str " =" ++ + pp_parameters pl ++ str prefix ++ pp_global (IndRef ip) ++ + pp_equiv pl ip_equiv ++ str " =" ++ if Array.length cv = 0 then str " unit (* empty inductive *)" else fnl () ++ v 0 (prvect_with_sep fnl pp_constructor (Array.mapi (fun i c -> ConstructRef (ip,i+1), c) cv)) -let pp_comment s = str "(* " ++ s ++ str " *)" - let pp_logical_ind packet = pp_comment (pr_id packet.ip_typename ++ str " : logical inductive") ++ fnl () ++ pp_comment (str "with constructors : " ++ @@ -422,10 +428,11 @@ let pp_singleton kn packet = pp_comment (str "singleton inductive, whose constructor was " ++ pr_id packet.ip_consnames.(0))) -let pp_record kn projs packet = +let pp_record kn projs ip_equiv packet = let l = List.combine projs packet.ip_types.(0) in let pl = rename_tvars keywords packet.ip_vars in - str "type " ++ pp_parameters pl ++ pp_global (IndRef (kn,0)) ++ str " = { "++ + str "type " ++ pp_parameters pl ++ pp_global (IndRef (kn,0)) ++ + pp_equiv pl ip_equiv ++ str " = { "++ hov 0 (prlist_with_sep (fun () -> str ";" ++ spc ()) (fun (r,t) -> pp_global r ++ str " : " ++ pp_type true pl t) l) ++ str " }" @@ -434,17 +441,20 @@ let pp_coind ip pl = let r = IndRef ip in let pl = rename_tvars keywords pl in pp_parameters pl ++ pp_global r ++ str " = " ++ - pp_parameters pl ++ str "__" ++ pp_global r ++ str " Lazy.t" + pp_parameters pl ++ str "__" ++ pp_global r ++ str " Lazy.t" ++ + fnl() ++ str "and " let pp_ind co kn ind = + let prefix = if co then "__" else "" in let some = ref false in let init= ref (str "type ") in let rec pp i = if i >= Array.length ind.ind_packets then mt () else let ip = (kn,i) in + let ip_equiv = option_map (fun kn -> (kn,i)) ind.ind_equiv in let p = ind.ind_packets.(i) in - if is_custom (IndRef (kn,i)) then pp (i+1) + if is_custom (IndRef ip) then pp (i+1) else begin some := true; if p.ip_logical then pp_logical_ind p ++ pp (i+1) @@ -453,8 +463,8 @@ let pp_ind co kn ind = begin init := (fnl () ++ str "and "); s ++ - (if co then pp_coind ip p.ip_vars ++ fnl () ++ str "and " else mt ()) - ++ pp_one_ind (if co then "__" else "") ip p.ip_vars p.ip_types ++ + (if co then pp_coind ip p.ip_vars else mt ()) + ++ pp_one_ind prefix ip ip_equiv p.ip_vars p.ip_types ++ pp (i+1) end end @@ -468,7 +478,9 @@ let pp_mind kn i = match i.ind_info with | Singleton -> pp_singleton kn i.ind_packets.(0) | Coinductive -> pp_ind true kn i - | Record projs -> pp_record kn projs i.ind_packets.(0) + | Record projs -> + let ip_equiv = option_map (fun kn -> (kn,0)) i.ind_equiv in + pp_record kn projs ip_equiv i.ind_packets.(0) | Standard -> pp_ind false kn i let pp_decl mpl = @@ -574,7 +586,7 @@ let rec pp_structure_elem mpl = function | (l,SEmodule m) -> hov 1 (str "module " ++ P.pp_module mpl (MPdot (List.hd mpl, l)) ++ - (* if you want signatures everywhere: *) + (*i if you want signatures everywhere: i*) (*i str " :" ++ fnl () ++ i*) (*i pp_module_type mpl None m.ml_mod_type ++ fnl () ++ i*) str " = " ++ diff --git a/contrib/extraction/test_extraction.v b/contrib/extraction/test_extraction.v deleted file mode 100644 index 0745f62d..00000000 --- a/contrib/extraction/test_extraction.v +++ /dev/null @@ -1,552 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -Require Import Arith. -Require Import List. - -(*** STANDARD EXAMPLES *) - -(** Functions. *) - -Definition idnat (x:nat) := x. -Extraction idnat. -(* let idnat x = x *) - -Definition id (X:Type) (x:X) := x. -Extraction id. (* let id x = x *) -Definition id' := id Set nat. -Extraction id'. (* type id' = nat *) - -Definition test2 (f:nat -> nat) (x:nat) := f x. -Extraction test2. -(* let test2 f x = f x *) - -Definition test3 (f:nat -> Set -> nat) (x:nat) := f x nat. -Extraction test3. -(* let test3 f x = f x __ *) - -Definition test4 (f:(nat -> nat) -> nat) (x:nat) (g:nat -> nat) := f g. -Extraction test4. -(* let test4 f x g = f g *) - -Definition test5 := (1, 0). -Extraction test5. -(* let test5 = Pair ((S O), O) *) - -Definition cf (x:nat) (_:x <= 0) := S x. -Extraction NoInline cf. -Definition test6 := cf 0 (le_n 0). -Extraction test6. -(* let test6 = cf O *) - -Definition test7 := (fun (X:Set) (x:X) => x) nat. -Extraction test7. -(* let test7 x = x *) - -Definition d (X:Type) := X. -Extraction d. (* type 'x d = 'x *) -Definition d2 := d Set. -Extraction d2. (* type d2 = __ d *) -Definition d3 (x:d Set) := 0. -Extraction d3. (* let d3 _ = O *) -Definition d4 := d nat. -Extraction d4. (* type d4 = nat d *) -Definition d5 := (fun x:d Type => 0) Type. -Extraction d5. (* let d5 = O *) -Definition d6 (x:d Type) := x. -Extraction d6. (* type 'x d6 = 'x *) - -Definition test8 := (fun (X:Type) (x:X) => x) Set nat. -Extraction test8. (* type test8 = nat *) - -Definition test9 := let t := nat in id Set t. -Extraction test9. (* type test9 = nat *) - -Definition test10 := (fun (X:Type) (x:X) => 0) Type Type. -Extraction test10. (* let test10 = O *) - -Definition test11 := let n := 0 in let p := S n in S p. -Extraction test11. (* let test11 = S (S O) *) - -Definition test12 := forall x:forall X:Type, X -> X, x Type Type. -Extraction test12. -(* type test12 = (__ -> __ -> __) -> __ *) - - -Definition test13 := match left True I with - | left x => 1 - | right x => 0 - end. -Extraction test13. (* let test13 = S O *) - - -(** example with more arguments that given by the type *) - -Definition test19 := - nat_rec (fun n:nat => nat -> nat) (fun n:nat => 0) - (fun (n:nat) (f:nat -> nat) => f) 0 0. -Extraction test19. -(* let test19 = - let rec f = function - | O -> (fun n0 -> O) - | S n0 -> f n0 - in f O O -*) - - -(** casts *) - -Definition test20 := True:Type. -Extraction test20. -(* type test20 = __ *) - - -(** Simple inductive type and recursor. *) - -Extraction nat. -(* -type nat = - | O - | S of nat -*) - -Extraction sumbool_rect. -(* -let sumbool_rect f f0 = function - | Left -> f __ - | Right -> f0 __ -*) - -(** Less simple inductive type. *) - -Inductive c (x:nat) : nat -> Set := - | refl : c x x - | trans : forall y z:nat, c x y -> y <= z -> c x z. -Extraction c. -(* -type c = - | Refl - | Trans of nat * nat * c -*) - -Definition Ensemble (U:Type) := U -> Prop. -Definition Empty_set (U:Type) (x:U) := False. -Definition Add (U:Type) (A:Ensemble U) (x y:U) := A y \/ x = y. - -Inductive Finite (U:Type) : Ensemble U -> Set := - | Empty_is_finite : Finite U (Empty_set U) - | Union_is_finite : - forall A:Ensemble U, - Finite U A -> forall x:U, ~ A x -> Finite U (Add U A x). -Extraction Finite. -(* -type 'u finite = - | Empty_is_finite - | Union_is_finite of 'u finite * 'u -*) - - -(** Mutual Inductive *) - -Inductive tree : Set := - Node : nat -> forest -> tree -with forest : Set := - | Leaf : nat -> forest - | Cons : tree -> forest -> forest. - -Extraction tree. -(* -type tree = - | Node of nat * forest -and forest = - | Leaf of nat - | Cons of tree * forest -*) - -Fixpoint tree_size (t:tree) : nat := - match t with - | Node a f => S (forest_size f) - end - - with forest_size (f:forest) : nat := - match f with - | Leaf b => 1 - | Cons t f' => tree_size t + forest_size f' - end. - -Extraction tree_size. -(* -let rec tree_size = function - | Node (a, f) -> S (forest_size f) -and forest_size = function - | Leaf b -> S O - | Cons (t, f') -> plus (tree_size t) (forest_size f') -*) - - -(** Eta-expansions of inductive constructor *) - -Inductive titi : Set := - tata : nat -> nat -> nat -> nat -> titi. -Definition test14 := tata 0. -Extraction test14. -(* let test14 x x0 x1 = Tata (O, x, x0, x1) *) -Definition test15 := tata 0 1. -Extraction test15. -(* let test15 x x0 = Tata (O, (S O), x, x0) *) - -Inductive eta : Set := - eta_c : nat -> Prop -> nat -> Prop -> eta. -Extraction eta_c. -(* -type eta = - | Eta_c of nat * nat -*) -Definition test16 := eta_c 0. -Extraction test16. -(* let test16 x = Eta_c (O, x) *) -Definition test17 := eta_c 0 True. -Extraction test17. -(* let test17 x = Eta_c (O, x) *) -Definition test18 := eta_c 0 True 0. -Extraction test18. -(* let test18 _ = Eta_c (O, O) *) - - -(** Example of singleton inductive type *) - -Inductive bidon (A:Prop) (B:Type) : Set := - tb : forall (x:A) (y:B), bidon A B. -Definition fbidon (A B:Type) (f:A -> B -> bidon True nat) - (x:A) (y:B) := f x y. -Extraction bidon. -(* type 'b bidon = 'b *) -Extraction tb. -(* tb : singleton inductive constructor *) -Extraction fbidon. -(* let fbidon f x y = - f x y -*) - -Definition fbidon2 := fbidon True nat (tb True nat). -Extraction fbidon2. (* let fbidon2 y = y *) -Extraction NoInline fbidon. -Extraction fbidon2. -(* let fbidon2 y = fbidon (fun _ x -> x) __ y *) - -(* NB: first argument of fbidon2 has type [True], so it disappears. *) - -(** mutual inductive on many sorts *) - -Inductive test_0 : Prop := - ctest0 : test_0 -with test_1 : Set := - ctest1 : test_0 -> test_1. -Extraction test_0. -(* test0 : logical inductive *) -Extraction test_1. -(* -type test1 = - | Ctest1 -*) - -(** logical singleton *) - -Extraction eq. -(* eq : logical inductive *) -Extraction eq_rect. -(* let eq_rect x f y = - f -*) - -(** No more propagation of type parameters. Obj.t instead. *) - -Inductive tp1 : Set := - T : forall (C:Set) (c:C), tp2 -> tp1 -with tp2 : Set := - T' : tp1 -> tp2. -Extraction tp1. -(* -type tp1 = - | T of __ * tp2 -and tp2 = - | T' of tp1 -*) - -Inductive tp1bis : Set := - Tbis : tp2bis -> tp1bis -with tp2bis : Set := - T'bis : forall (C:Set) (c:C), tp1bis -> tp2bis. -Extraction tp1bis. -(* -type tp1bis = - | Tbis of tp2bis -and tp2bis = - | T'bis of __ * tp1bis -*) - - -(** Strange inductive type. *) - -Inductive Truc : Set -> Set := - | chose : forall A:Set, Truc A - | machin : forall A:Set, A -> Truc bool -> Truc A. -Extraction Truc. -(* -type 'x truc = - | Chose - | Machin of 'x * bool truc -*) - - -(** Dependant type over Type *) - -Definition test24 := sigT (fun a:Set => option a). -Extraction test24. -(* type test24 = (__, __ option) sigT *) - - -(** Coq term non strongly-normalizable after extraction *) - -Require Import Gt. -Definition loop (Ax:Acc gt 0) := - (fix F (a:nat) (b:Acc gt a) {struct b} : nat := - F (S a) (Acc_inv b (S a) (gt_Sn_n a))) 0 Ax. -Extraction loop. -(* let loop _ = - let rec f a = - f (S a) - in f O -*) - -(*** EXAMPLES NEEDING OBJ.MAGIC *) - -(** False conversion of type: *) - -Lemma oups : forall H:nat = list nat, nat -> nat. -intros. -generalize H0; intros. -rewrite H in H1. -case H1. -exact H0. -intros. -exact n. -Qed. -Extraction oups. -(* -let oups h0 = - match Obj.magic h0 with - | Nil -> h0 - | Cons0 (n, l) -> n -*) - - -(** hybrids *) - -Definition horibilis (b:bool) := - if b as b return (if b then Type else nat) then Set else 0. -Extraction horibilis. -(* -let horibilis = function - | True -> Obj.magic __ - | False -> Obj.magic O -*) - -Definition PropSet (b:bool) := if b then Prop else Set. -Extraction PropSet. (* type propSet = __ *) - -Definition natbool (b:bool) := if b then nat else bool. -Extraction natbool. (* type natbool = __ *) - -Definition zerotrue (b:bool) := if b as x return natbool x then 0 else true. -Extraction zerotrue. -(* -let zerotrue = function - | True -> Obj.magic O - | False -> Obj.magic True -*) - -Definition natProp (b:bool) := if b return Type then nat else Prop. - -Definition natTrue (b:bool) := if b return Type then nat else True. - -Definition zeroTrue (b:bool) := if b as x return natProp x then 0 else True. -Extraction zeroTrue. -(* -let zeroTrue = function - | True -> Obj.magic O - | False -> Obj.magic __ -*) - -Definition natTrue2 (b:bool) := if b return Type then nat else True. - -Definition zeroprop (b:bool) := if b as x return natTrue x then 0 else I. -Extraction zeroprop. -(* -let zeroprop = function - | True -> Obj.magic O - | False -> Obj.magic __ -*) - -(** polymorphic f applied several times *) - -Definition test21 := (id nat 0, id bool true). -Extraction test21. -(* let test21 = Pair ((id O), (id True)) *) - -(** ok *) - -Definition test22 := - (fun f:forall X:Type, X -> X => (f nat 0, f bool true)) - (fun (X:Type) (x:X) => x). -Extraction test22. -(* let test22 = - let f = fun x -> x in Pair ((f O), (f True)) *) - -(* still ok via optim beta -> let *) - -Definition test23 (f:forall X:Type, X -> X) := (f nat 0, f bool true). -Extraction test23. -(* let test23 f = Pair ((Obj.magic f __ O), (Obj.magic f __ True)) *) - -(* problem: fun f -> (f 0, f true) not legal in ocaml *) -(* solution: magic ... *) - - -(** Dummy constant __ can be applied.... *) - -Definition f (X:Type) (x:nat -> X) (y:X -> bool) : bool := y (x 0). -Extraction f. -(* let f x y = - y (x O) -*) - -Definition f_prop := f (0 = 0) (fun _ => refl_equal 0) (fun _ => true). -Extraction NoInline f. -Extraction f_prop. -(* let f_prop = - f (Obj.magic __) (fun _ -> True) -*) - -Definition f_arity := f Set (fun _:nat => nat) (fun _:Set => true). -Extraction f_arity. -(* let f_arity = - f (Obj.magic __) (fun _ -> True) -*) - -Definition f_normal := - f nat (fun x => x) (fun x => match x with - | O => true - | _ => false - end). -Extraction f_normal. -(* let f_normal = - f (fun x -> x) (fun x -> match x with - | O -> True - | S n -> False) -*) - - -(* inductive with magic needed *) - -Inductive Boite : Set := - boite : forall b:bool, (if b then nat else (nat * nat)%type) -> Boite. -Extraction Boite. -(* -type boite = - | Boite of bool * __ -*) - - -Definition boite1 := boite true 0. -Extraction boite1. -(* let boite1 = Boite (True, (Obj.magic O)) *) - -Definition boite2 := boite false (0, 0). -Extraction boite2. -(* let boite2 = Boite (False, (Obj.magic (Pair (O, O)))) *) - -Definition test_boite (B:Boite) := - match B return nat with - | boite true n => n - | boite false n => fst n + snd n - end. -Extraction test_boite. -(* -let test_boite = function - | Boite (b0, n) -> - (match b0 with - | True -> Obj.magic n - | False -> plus (fst (Obj.magic n)) (snd (Obj.magic n))) -*) - -(* singleton inductive with magic needed *) - -Inductive Box : Set := - box : forall A:Set, A -> Box. -Extraction Box. -(* type box = __ *) - -Definition box1 := box nat 0. -Extraction box1. (* let box1 = Obj.magic O *) - -(* applied constant, magic needed *) - -Definition idzarb (b:bool) (x:if b then nat else bool) := x. -Definition zarb := idzarb true 0. -Extraction NoInline idzarb. -Extraction zarb. -(* let zarb = Obj.magic idzarb True (Obj.magic O) *) - -(** function of variable arity. *) -(** Fun n = nat -> nat -> ... -> nat *) - -Fixpoint Fun (n:nat) : Set := - match n with - | O => nat - | S n => nat -> Fun n - end. - -Fixpoint Const (k n:nat) {struct n} : Fun n := - match n as x return Fun x with - | O => k - | S n => fun p:nat => Const k n - end. - -Fixpoint proj (k n:nat) {struct n} : Fun n := - match n as x return Fun x with - | O => 0 (* ou assert false ....*) - | S n => - match k with - | O => fun x => Const x n - | S k => fun x => proj k n - end - end. - -Definition test_proj := proj 2 4 0 1 2 3. - -Eval compute in test_proj. - -Recursive Extraction test_proj. - - - -(*** TO SUM UP: ***) - - -Extraction - "test_extraction.ml" idnat id id' test2 test3 test4 test5 test6 test7 d d2 - d3 d4 d5 d6 test8 id id' test9 test10 test11 test12 - test13 test19 test20 nat sumbool_rect c Finite tree - tree_size test14 test15 eta_c test16 test17 test18 bidon - tb fbidon fbidon2 fbidon2 test_0 test_1 eq eq_rect tp1 - tp1bis Truc oups test24 loop horibilis PropSet natbool - zerotrue zeroTrue zeroprop test21 test22 test23 f f_prop - f_arity f_normal Boite boite1 boite2 test_boite Box box1 - zarb test_proj. - diff --git a/contrib/first-order/ground.ml b/contrib/first-order/ground.ml index bb096308..bccac6df 100644 --- a/contrib/first-order/ground.ml +++ b/contrib/first-order/ground.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: ground.ml 7909 2006-01-21 11:09:18Z herbelin $ *) +(* $Id: ground.ml 9537 2007-01-26 10:05:04Z corbinea $ *) open Formula open Sequent @@ -81,7 +81,7 @@ let ground_tac solver startseq gl= tclFAIL 0 (Pp.str "reversible in 1st order mode") else backtrack in - forall_tac backtrack continue (re_add seq1) + forall_tac backtrack1 continue (re_add seq1) | Rarrow-> arrow_tac backtrack continue (re_add seq1) | Ror-> diff --git a/contrib/funind/functional_principles_proofs.ml b/contrib/funind/functional_principles_proofs.ml index 14e2233f..ff4f7499 100644 --- a/contrib/funind/functional_principles_proofs.ml +++ b/contrib/funind/functional_principles_proofs.ml @@ -1380,219 +1380,6 @@ let is_valid_hypothesis predicates_name = | _ -> false in is_valid_hypothesis -(* -let fresh_id avoid na = - let id = - match na with - | Name id -> id - | Anonymous -> h_id - in - next_global_ident_away true id avoid - - -let prove_principle_for_gen - (f_ref,functional_ref,eq_ref) tcc_lemma_ref is_mes - rec_arg_num rec_arg_type relation = - fun g -> - let type_of_goal = pf_concl g in - let goal_ids = pf_ids_of_hyps g in - let goal_elim_infos = compute_elim_sig type_of_goal in - let params_names,ids = List.fold_left - (fun (params_names,avoid) (na,_,_) -> - let new_id = fresh_id avoid na in - (new_id::params_names,new_id::avoid) - ) - ([],goal_ids) - goal_elim_infos.params - in - let predicates_names,ids = - List.fold_left - (fun (predicates_names,avoid) (na,_,_) -> - let new_id = fresh_id avoid na in - (new_id::predicates_names,new_id::avoid) - ) - ([],ids) - goal_elim_infos.predicates - in - let branches_names,ids = - List.fold_left - (fun (branches_names,avoid) (na,_,_) -> - let new_id = fresh_id avoid na in - (new_id::branches_names,new_id::avoid) - ) - ([],ids) - goal_elim_infos.branches - in - let to_intro = params_names@predicates_names@branches_names in - let nparams = List.length params_names in - let rec_arg_num = rec_arg_num - nparams in - let tac_intro_static = h_intros to_intro in - let args_info = ref None in - let arg_tac g = (* introducing args *) - let ids = pf_ids_of_hyps g in - let func_body = def_of_const (mkConst functional_ref) in - (* let _ = Pp.msgnl (Printer.pr_lconstr func_body) in *) - let (f_name, _, body1) = destLambda func_body in - let f_id = - match f_name with - | Name f_id -> next_global_ident_away true f_id ids - | Anonymous -> anomaly "anonymous function" - in - let n_names_types,_ = decompose_lam body1 in - let n_ids,ids = - List.fold_left - (fun (n_ids,ids) (n_name,_) -> - match n_name with - | Name id -> - let n_id = next_global_ident_away true id ids in - n_id::n_ids,n_id::ids - | _ -> anomaly "anonymous argument" - ) - ([],(f_id::ids)) - n_names_types - in - let rec_arg_id = List.nth n_ids (rec_arg_num - 1 ) in - let args_ids = snd (list_chop nparams n_ids) in - args_info := Some (ids,args_ids,rec_arg_id); - h_intros args_ids g - in - let wf_tac = - if is_mes - then - (fun b -> Recdef.tclUSER_if_not_mes b None) - else fun _ -> prove_with_tcc tcc_lemma_ref [] - in - let start_tac g = - let ids,args_ids,rec_arg_id = out_some !args_info in - let nargs = List.length args_ids in - let pre_rec_arg = - List.rev_map - mkVar - (fst (list_chop (rec_arg_num - 1) args_ids)) - in - let args_before_rec = pre_rec_arg@(List.map mkVar params_names) in - let relation = substl args_before_rec relation in - let input_type = substl args_before_rec rec_arg_type in - let wf_thm = next_global_ident_away true (id_of_string ("wf_R")) ids in - let wf_rec_arg = - next_global_ident_away true - (id_of_string ("Acc_"^(string_of_id rec_arg_id))) - (wf_thm::ids) - in - let hrec = next_global_ident_away true hrec_id (wf_rec_arg::wf_thm::ids) in - let acc_inv = - lazy ( - mkApp ( - delayed_force acc_inv_id, - [|input_type;relation;mkVar rec_arg_id|] - ) - ) - in - (tclTHENS - (observe_tac - "first assert" - (assert_tac - true (* the assert thm is in first subgoal *) - (Name wf_rec_arg) - (mkApp (delayed_force acc_rel, - [|input_type;relation;mkVar rec_arg_id|]) - ) - ) - ) - [ - (* accesibility proof *) - tclTHENS - (observe_tac - "second assert" - (assert_tac - true - (Name wf_thm) - (mkApp (delayed_force well_founded,[|input_type;relation|])) - ) - ) - [ - (* interactive proof of the well_foundness of the relation *) - wf_tac is_mes; - (* well_foundness -> Acc for any element *) - observe_tac - "apply wf_thm" - (h_apply ((mkApp(mkVar wf_thm, - [|mkVar rec_arg_id |])),Rawterm.NoBindings) - ) - ] - ; - (* rest of the proof *) - tclTHENSEQ - [ - observe_tac "generalize" (fun g -> - let to_thin = - fst (list_chop ( nargs + 1) (pf_ids_of_hyps g)) - in - let to_thin_c = List.rev_map mkVar to_thin in - tclTHEN (generalize to_thin_c) (observe_tac "thin" (h_clear false to_thin)) g - ); - observe_tac "h_fix" (h_fix (Some hrec) (nargs+1)); - h_intros args_ids; - h_intro wf_rec_arg; - Equality.rewriteLR (mkConst eq_ref); - (fun g' -> - let body = - let _,args = destApp (pf_concl g') in - array_last args - in - let body_info rec_hyps = - { - nb_rec_hyps = List.length rec_hyps; - rec_hyps = rec_hyps; - eq_hyps = []; - info = body - } - in - let acc_inv = lazy (mkApp(Lazy.force acc_inv, [|mkVar wf_rec_arg|]) ) in - let pte_info = - { proving_tac = - (fun eqs -> - observe_tac "new_prove_with_tcc" - (new_prove_with_tcc is_mes acc_inv hrec tcc_lemma_ref (List.map mkVar eqs)) - ); - is_valid = is_valid_hypothesis predicates_names - } - in - let ptes_info : pte_info Idmap.t = - List.fold_left - (fun map pte_id -> - Idmap.add pte_id - pte_info - map - ) - Idmap.empty - predicates_names - in - let make_proof rec_hyps = - build_proof - false - [f_ref] - ptes_info - (body_info rec_hyps) - in - instanciate_hyps_with_args - make_proof - branches_names - args_ids - g' - - ) - ] - ] - g - ) - in - tclTHENSEQ - [tac_intro_static; - arg_tac; - start_tac - ] g -*) let prove_principle_for_gen (f_ref,functional_ref,eq_ref) tcc_lemma_ref is_mes @@ -1627,14 +1414,22 @@ let prove_principle_for_gen in let real_rec_arg_num = rec_arg_num - princ_info.nparams in let npost_rec_arg = princ_info.nargs - real_rec_arg_num + 1 in + observe ( + str "princ_type := " ++ pr_lconstr princ_type ++ fnl () ++ + str "princ_info.nparams := " ++ int princ_info.nparams ++ fnl () ++ + str "princ_info.nargs := " ++ int princ_info.nargs ++ fnl () ++ + str "rec_arg_num := " ++ int rec_arg_num ++ fnl() ++ + str "real_rec_arg_num := " ++ int real_rec_arg_num ++ fnl () ++ + str "npost_rec_arg := " ++ int npost_rec_arg ); let (post_rec_arg,pre_rec_arg) = Util.list_chop npost_rec_arg princ_info.args in let rec_arg_id = - match post_rec_arg with + match List.rev post_rec_arg with | (Name id,_,_)::_ -> id | _ -> assert false in + observe (str "rec_arg_id := " ++ pr_lconstr (mkVar rec_arg_id)); let subst_constrs = List.map (fun (na,_,_) -> mkVar (Nameops.out_name na)) (pre_rec_arg@princ_info.params) in let relation = substl subst_constrs relation in let input_type = substl subst_constrs rec_arg_type in @@ -1679,7 +1474,7 @@ let prove_principle_for_gen (mkApp (delayed_force acc_rel,[|input_type;relation;mkVar rec_arg_id|])) ); observe_tac "reverting" (revert (List.rev (acc_rec_arg_id::args_ids))); - observe_tac "h_fix" (h_fix (Some fix_id) (real_rec_arg_num + 1)); + observe_tac "h_fix" (h_fix (Some fix_id) (npost_rec_arg + 1)); h_intros (List.rev (acc_rec_arg_id::args_ids)); Equality.rewriteLR (mkConst eq_ref); observe_tac "finish" (fun gl' -> diff --git a/contrib/funind/functional_principles_types.ml b/contrib/funind/functional_principles_types.ml index 89ebb75a..8ad2e72b 100644 --- a/contrib/funind/functional_principles_types.ml +++ b/contrib/funind/functional_principles_types.ml @@ -405,11 +405,26 @@ let generate_functional_principle let (id,(entry,g_kind,hook)) = build_functional_principle interactive_proof old_princ_type new_sorts funs i proof_tac hook in + (* Pr 1278 : + Don't forget to close the goal if an error is raised !!!! + *) save false new_princ_name entry g_kind hook - with - | Defining_principle _ as e -> raise e - | e -> raise (Defining_principle e) - + with e -> + begin + begin + try + let id = Pfedit.get_current_proof_name () in + let s = string_of_id id in + let n = String.length "___________princ_________" in + if String.length s >= n + then if String.sub s 0 n = "___________princ_________" + then Pfedit.delete_current_proof () + else () + else () + with _ -> () + end; + raise (Defining_principle e) + end (* defined () *) diff --git a/contrib/funind/indfun.ml b/contrib/funind/indfun.ml index 82bb2869..6e2af224 100644 --- a/contrib/funind/indfun.ml +++ b/contrib/funind/indfun.ml @@ -266,7 +266,7 @@ let derive_inversion fix_names = ) with e -> msg_warning - (str "Cannot built inversion information" ++ + (str "Cannot build functional inversion principle" ++ if do_observe () then Cerrors.explain_exn e else mt ()) with _ -> () diff --git a/contrib/funind/rawtermops.ml b/contrib/funind/rawtermops.ml index ed46ec72..ba5c2bbd 100644 --- a/contrib/funind/rawtermops.ml +++ b/contrib/funind/rawtermops.ml @@ -561,7 +561,7 @@ let ids_of_rawterm c = | RCases (loc,rtntypopt,tml,brchl) -> List.flatten (List.map (fun (_,idl,patl,c) -> idl @ ids_of_rawterm [] c) brchl) | RRec _ -> failwith "Fix inside a constructor branch" - | (RSort _ | RHole _ | RRef _ | REvar _ | RPatVar _ | RDynamic _) as x -> [] + | (RSort _ | RHole _ | RRef _ | REvar _ | RPatVar _ | RDynamic _) -> [] in (* build the set *) List.fold_left (fun acc x -> Idset.add x acc) Idset.empty (ids_of_rawterm [] c) diff --git a/contrib/interface/ascent.mli b/contrib/interface/ascent.mli index b6cc55f6..ef1d095e 100644 --- a/contrib/interface/ascent.mli +++ b/contrib/interface/ascent.mli @@ -642,6 +642,7 @@ and ct_TACTIC_COM = | CT_elim_type of ct_FORMULA | CT_exact of ct_FORMULA | CT_exact_no_check of ct_FORMULA + | CT_vm_cast_no_check of ct_FORMULA | CT_exists of ct_SPEC_LIST | CT_fail of ct_ID_OR_INT * ct_STRING_OPT | CT_first of ct_TACTIC_COM * ct_TACTIC_COM list diff --git a/contrib/interface/parse.ml b/contrib/interface/parse.ml index 4d4df59f..8cca7614 100644 --- a/contrib/interface/parse.ml +++ b/contrib/interface/parse.ml @@ -315,21 +315,21 @@ let parse_file_action reqid file_name = fnl () ++ Cerrors.explain_exn e));; let add_rec_path_action reqid string_arg ident_arg = - let directory_name = glob string_arg in + let directory_name = expand_path_macros string_arg in begin add_rec_path directory_name (Libnames.dirpath_of_string ident_arg) end;; let add_path_action reqid string_arg = - let directory_name = glob string_arg in + let directory_name = expand_path_macros string_arg in begin add_path directory_name Names.empty_dirpath end;; let print_version_action () = msgnl (mt ()); - msgnl (str "$Id: parse.ml 7844 2006-01-11 16:36:14Z bertot $");; + msgnl (str "$Id: parse.ml 9397 2006-11-21 21:50:54Z herbelin $");; let load_syntax_action reqid module_name = msg (str "loading " ++ str module_name ++ str "... "); diff --git a/contrib/interface/vtp.ml b/contrib/interface/vtp.ml index fe227f99..166a0cbf 100644 --- a/contrib/interface/vtp.ml +++ b/contrib/interface/vtp.ml @@ -1549,6 +1549,9 @@ and fTACTIC_COM = function | CT_exact_no_check(x1) -> fFORMULA x1; fNODE "exact_no_check" 1 +| CT_vm_cast_no_check(x1) -> + fFORMULA x1; + fNODE "vm_cast_no_check" 1 | CT_exists(x1) -> fSPEC_LIST x1; fNODE "exists" 1 diff --git a/contrib/interface/xlate.ml b/contrib/interface/xlate.ml index 6c9e8239..60195229 100644 --- a/contrib/interface/xlate.ml +++ b/contrib/interface/xlate.ml @@ -1060,6 +1060,7 @@ and xlate_tac = | TacAssumption -> CT_assumption | TacExact c -> CT_exact (xlate_formula c) | TacExactNoCheck c -> CT_exact_no_check (xlate_formula c) + | TacVmCastNoCheck c -> CT_vm_cast_no_check (xlate_formula c) | TacDestructHyp (true, (_,id)) -> CT_cdhyp (xlate_ident id) | TacDestructHyp (false, (_,id)) -> CT_dhyp (xlate_ident id) | TacDestructConcl -> CT_dconcl @@ -1978,7 +1979,7 @@ let rec xlate_vernac = | VernacOpenCloseScope(false, true, s) -> CT_open_scope(CT_ident s) | VernacOpenCloseScope(true, false, s) -> CT_local_close_scope(CT_ident s) | VernacOpenCloseScope(false, false, s) -> CT_close_scope(CT_ident s) - | VernacArgumentsScope(qid, l) -> + | VernacArgumentsScope(true, qid, l) -> CT_arguments_scope(loc_qualid_to_ct_ID qid, CT_id_opt_list (List.map @@ -1986,6 +1987,8 @@ let rec xlate_vernac = match x with None -> ctv_ID_OPT_NONE | Some x -> ctf_ID_OPT_SOME(CT_ident x)) l)) + | VernacArgumentsScope(false, qid, l) -> + xlate_error "TODO: Arguments Scope Global" | VernacDelimiters(s1,s2) -> CT_delim_scope(CT_ident s1, CT_ident s2) | VernacBindScope(id, a::l) -> let xlate_class_rawexpr = function @@ -2060,7 +2063,7 @@ let rec xlate_vernac = | VernacNop -> CT_proof_no_op | VernacComments l -> CT_scomments(CT_scomment_content_list (List.map xlate_comment l)) - | VernacDeclareImplicits(id, opt_positions) -> + | VernacDeclareImplicits(true, id, opt_positions) -> CT_implicits (reference_to_ct_ID id, match opt_positions with @@ -2073,6 +2076,8 @@ let rec xlate_vernac = -> xlate_error "explication argument by rank is obsolete" | ExplByName id -> CT_ident (string_of_id id)) l))) + | VernacDeclareImplicits(false, id, opt_positions) -> + xlate_error "TODO: Implicit Arguments Global" | VernacReserve((_,a)::l, f) -> CT_reserve(CT_id_ne_list(xlate_ident a, List.map (fun (_,x) -> xlate_ident x) l), diff --git a/contrib/setoid_ring/ArithRing.v b/contrib/setoid_ring/ArithRing.v index 5060bc69..074f6ef7 100644 --- a/contrib/setoid_ring/ArithRing.v +++ b/contrib/setoid_ring/ArithRing.v @@ -7,20 +7,32 @@ (************************************************************************) Require Import Mult. +Require Import BinNat. +Require Import Nnat. Require Export Ring. Set Implicit Arguments. -Ltac isnatcst t := - let t := eval hnf in t in - match t with - O => true - | S ?p => isnatcst p - | _ => false - end. +Lemma natSRth : semi_ring_theory O (S O) plus mult (@eq nat). + Proof. + constructor. exact plus_0_l. exact plus_comm. exact plus_assoc. + exact mult_1_l. exact mult_0_l. exact mult_comm. exact mult_assoc. + exact mult_plus_distr_r. + Qed. + +Lemma nat_morph_N : + semi_morph 0 1 plus mult (eq (A:=nat)) + 0%N 1%N Nplus Nmult Neq_bool nat_of_N. +Proof. + constructor;trivial. + exact nat_of_Nplus. + exact nat_of_Nmult. + intros x y H;rewrite (Neq_bool_ok _ _ H);trivial. +Qed. + Ltac natcst t := match isnatcst t with - true => t - | _ => NotConstant + true => constr:(N_of_nat t) + | _ => InitialRing.NotConstant end. Ltac Ss_to_add f acc := @@ -43,28 +55,6 @@ Ltac natprering := | _ => idtac end. - Lemma natSRth : semi_ring_theory O (S O) plus mult (@eq nat). - Proof. - constructor. exact plus_0_l. exact plus_comm. exact plus_assoc. - exact mult_1_l. exact mult_0_l. exact mult_comm. exact mult_assoc. - exact mult_plus_distr_r. - Qed. - - -Unboxed Fixpoint nateq (n m:nat) {struct m} : bool := - match n, m with - | O, O => true - | S n', S m' => nateq n' m' - | _, _ => false - end. - -Lemma nateq_ok : forall n m:nat, nateq n m = true -> n = m. -Proof. - simple induction n; simple induction m; simpl; intros; try discriminate. - trivial. - rewrite (H n1 H1). - trivial. -Qed. - Add Ring natr : natSRth - (decidable nateq_ok, constants [natcst], preprocess [natprering]). + (morphism nat_morph_N, constants [natcst], preprocess [natprering]). + diff --git a/contrib/setoid_ring/BinList.v b/contrib/setoid_ring/BinList.v index 0d0fe5a4..50902004 100644 --- a/contrib/setoid_ring/BinList.v +++ b/contrib/setoid_ring/BinList.v @@ -10,7 +10,7 @@ Set Implicit Arguments. Require Import BinPos. Require Export List. Require Export ListTactics. -Open Scope positive_scope. +Open Local Scope positive_scope. Section MakeBinList. Variable A : Type. @@ -89,3 +89,5 @@ Section MakeBinList. Qed. End MakeBinList. + + diff --git a/contrib/setoid_ring/Field_tac.v b/contrib/setoid_ring/Field_tac.v index 786654ab..aad3a580 100644 --- a/contrib/setoid_ring/Field_tac.v +++ b/contrib/setoid_ring/Field_tac.v @@ -10,10 +10,10 @@ Require Import Ring_tac BinList Ring_polynom InitialRing. Require Export Field_theory. (* syntaxification *) - Ltac mkFieldexpr C Cst radd rmul rsub ropp rdiv rinv t fv := + Ltac mkFieldexpr C Cst CstPow radd rmul rsub ropp rdiv rinv rpow t fv := let rec mkP t := match Cst t with - | Ring_tac.NotConstant => + | InitialRing.NotConstant => match t with | (radd ?t1 ?t2) => let e1 := mkP t1 in @@ -31,6 +31,13 @@ Require Export Field_theory. let e2 := mkP t2 in constr:(FEdiv e1 e2) | (rinv ?t1) => let e1 := mkP t1 in constr:(FEinv e1) + | (rpow ?t1 ?n) => + match CstPow n with + | InitialRing.NotConstant => + let p := Find_at t fv in constr:(@FEX C p) + | ?c => let e1 := mkP t1 in constr:(FEpow e1 c) + end + | _ => let p := Find_at t fv in constr:(@FEX C p) end @@ -38,10 +45,10 @@ Require Export Field_theory. end in mkP t. -Ltac FFV Cst add mul sub opp div inv t fv := +Ltac FFV Cst CstPow add mul sub opp div inv pow t fv := let rec TFV t fv := match Cst t with - | Ring_tac.NotConstant => + | InitialRing.NotConstant => match t with | (add ?t1 ?t2) => TFV t2 ltac:(TFV t1 fv) | (mul ?t1 ?t2) => TFV t2 ltac:(TFV t1 fv) @@ -49,16 +56,24 @@ Ltac FFV Cst add mul sub opp div inv t fv := | (opp ?t1) => TFV t1 fv | (div ?t1 ?t2) => TFV t2 ltac:(TFV t1 fv) | (inv ?t1) => TFV t1 fv + | (pow ?t1 ?n) => + match CstPow n with + | InitialRing.NotConstant => AddFvTail t fv + | _ => TFV t1 fv + end | _ => AddFvTail t fv end | _ => fv end in TFV t fv. -Ltac ParseFieldComponents lemma req := +Ltac ParseFieldComponents lemma := match type of lemma with - | context [@FEeval ?R ?rO ?add ?mul ?sub ?opp ?div ?inv ?C ?phi _ _] => - (fun f => f add mul sub opp div inv C) + | context [ + (* PCond _ _ _ _ _ _ _ _ _ _ _ -> *) + (@FEeval ?R ?rO ?radd ?rmul ?rsub ?ropp ?rdiv ?rinv + ?C ?phi ?Cpow ?Cp_phi ?rpow _ _) ] => + (fun f => f radd rmul rsub ropp rdiv rinv rpow C) | _ => fail 1 "field anomaly: bad correctness lemma (parse)" end. @@ -78,91 +93,244 @@ Ltac fold_field_cond req := Ltac simpl_PCond req := protect_fv "field_cond"; - try (exact I); + (try exact I); + fold_field_cond req. + +Ltac simpl_PCond_BEURK req := + protect_fv "field_cond"; fold_field_cond req. (* Rewriting (field_simplify) *) -Ltac Field_simplify lemma Cond_lemma req Cst_tac := - let Make_tac := - match type of lemma with - | forall l fe nfe, - _ = nfe -> - PCond _ _ _ _ _ _ _ _ _ -> - req (FEeval ?rO ?radd ?rmul ?rsub ?ropp ?rdiv ?rinv (C:=?C) ?phi l fe) - _ => - let mkFV := FFV Cst_tac radd rmul rsub ropp rdiv rinv in - let mkFE := mkFieldexpr C Cst_tac radd rmul rsub ropp rdiv rinv in - let simpl_field H := protect_fv "field" in H in - fun f rl => f mkFV mkFE simpl_field lemma req rl; - try (apply Cond_lemma; simpl_PCond req) - | _ => fail 1 "field anomaly: bad correctness lemma (rewr)" - end in - Make_tac ReflexiveRewriteTactic. -(* Pb: second rewrite are applied to non-zero condition of first rewrite... *) - -Tactic Notation (at level 0) "field_simplify" constr_list(rl) := - field_lookup - (fun req cst_tac _ _ field_simplify_ok cond_ok pre post rl => - pre(); Field_simplify field_simplify_ok cond_ok req cst_tac rl; post()). - - -(* Generic form of field tactics *) -Ltac Field_Scheme FV_tac SYN_tac SIMPL_tac lemma Cond_lemma req := - let R := match type of req with ?R -> _ => R end in - let rec ParseExpr ilemma := - match type of ilemma with - forall nfe, ?fe = nfe -> _ => - (fun t => - let x := fresh "fld_expr" in - let H := fresh "norm_fld_expr" in - compute_assertion H x fe; - ParseExpr (ilemma x H) t; - try clear x H) - | _ => (fun t => t ilemma) - end in - let Main r1 r2 := - let fv := FV_tac r1 (@List.nil R) in - let fv := FV_tac r2 fv in - let fe1 := SYN_tac r1 fv in - let fe2 := SYN_tac r2 fv in - ParseExpr (lemma fv fe1 fe2) - ltac:(fun ilemma => - apply ilemma || fail "field anomaly: failed in applying lemma"; - [ SIMPL_tac | apply Cond_lemma; simpl_PCond req]) in - OnEquation req Main. +Ltac Field_norm_gen f Cst_tac Pow_tac lemma Cond_lemma req n lH rl := + let Main radd rmul rsub ropp rdiv rinv rpow C := + let mkFV := FV Cst_tac Pow_tac radd rmul rsub ropp rpow in + let mkPol := mkPolexpr C Cst_tac Pow_tac radd rmul rsub ropp rpow in + let mkFFV := FFV Cst_tac Pow_tac radd rmul rsub ropp rdiv rinv rpow in + let mkFE := + mkFieldexpr C Cst_tac Pow_tac radd rmul rsub ropp rdiv rinv rpow in + let fv := FV_hypo_tac mkFV req lH in + let simpl_field H := (protect_fv "field" in H;f H) in + let lemma_tac fv RW_tac := + let rr_lemma := fresh "f_rw_lemma" in + let lpe := mkHyp_tac C req ltac:(fun t => mkPol t fv) lH in + let vlpe := fresh "list_hyp" in + let vlmp := fresh "list_hyp_norm" in + let vlmp_eq := fresh "list_hyp_norm_eq" in + let prh := proofHyp_tac lH in + pose (vlpe := lpe); + match type of lemma with + | context [mk_monpol_list ?cO ?cI ?cadd ?cmul ?csub ?copp ?ceqb _] => + compute_assertion vlmp_eq vlmp + (mk_monpol_list cO cI cadd cmul csub copp ceqb vlpe); + (assert (rr_lemma := lemma n vlpe fv prh vlmp vlmp_eq) + || fail "type error when build the rewriting lemma"); + RW_tac rr_lemma; + try clear rr_lemma vlmp_eq vlmp vlpe + | _ => fail 1 "field_simplify anomaly: bad correctness lemma" + end in + ReflexiveRewriteTactic mkFFV mkFE simpl_field lemma_tac fv rl; + try (apply Cond_lemma; simpl_PCond req) in + ParseFieldComponents lemma Main. + +Ltac Field_simplify_gen f := + fun req cst_tac pow_tac _ _ field_simplify_ok _ cond_ok pre post lH rl => + pre(); + Field_norm_gen f cst_tac pow_tac field_simplify_ok cond_ok req + ring_subst_niter lH rl; + post(). + +Ltac Field_simplify := Field_simplify_gen ltac:(fun H => rewrite H). + +Tactic Notation (at level 0) + "field_simplify" constr_list(rl) := + match goal with [|- ?G] => field_lookup Field_simplify [] rl [G] end. + +Tactic Notation (at level 0) + "field_simplify" "[" constr_list(lH) "]" constr_list(rl) := + match goal with [|- ?G] => field_lookup Field_simplify [lH] rl [G] end. + +Tactic Notation "field_simplify" constr_list(rl) "in" hyp(H):= + let G := getGoal in + let t := type of H in + let g := fresh "goal" in + set (g:= G); + generalize H;clear H; + field_lookup Field_simplify [] rl [t]; + intro H; + unfold g;clear g. + +Tactic Notation "field_simplify" "["constr_list(lH) "]" constr_list(rl) "in" hyp(H):= + let G := getGoal in + let t := type of H in + let g := fresh "goal" in + set (g:= G); + generalize H;clear H; + field_lookup Field_simplify [lH] rl [t]; + intro H; + unfold g;clear g. + +(* +Ltac Field_simplify_in hyp:= + Field_simplify_gen ltac:(fun H => rewrite H in hyp). + +Tactic Notation (at level 0) + "field_simplify" constr_list(rl) "in" hyp(h) := + let t := type of h in + field_lookup (Field_simplify_in h) [] rl [t]. + +Tactic Notation (at level 0) + "field_simplify" "[" constr_list(lH) "]" constr_list(rl) "in" hyp(h) := + let t := type of h in + field_lookup (Field_simplify_in h) [lH] rl [t]. +*) + +(** Generic tactic for solving equations *) + +Ltac Field_Scheme Simpl_tac Cst_tac Pow_tac lemma Cond_lemma req n lH := + let Main radd rmul rsub ropp rdiv rinv rpow C := + let mkFV := FV Cst_tac Pow_tac radd rmul rsub ropp rpow in + let mkPol := mkPolexpr C Cst_tac Pow_tac radd rmul rsub ropp rpow in + let mkFFV := FFV Cst_tac Pow_tac radd rmul rsub ropp rdiv rinv rpow in + let mkFE := + mkFieldexpr C Cst_tac Pow_tac radd rmul rsub ropp rdiv rinv rpow in + let rec ParseExpr ilemma := + match type of ilemma with + forall nfe, ?fe = nfe -> _ => + (fun t => + let x := fresh "fld_expr" in + let H := fresh "norm_fld_expr" in + compute_assertion H x fe; + ParseExpr (ilemma x H) t; + try clear x H) + | _ => (fun t => t ilemma) + end in + let Main_eq t1 t2 := + let fv := FV_hypo_tac mkFV req lH in + let fv := mkFFV t1 fv in + let fv := mkFFV t2 fv in + let lpe := mkHyp_tac C req ltac:(fun t => mkPol t fv) lH in + let prh := proofHyp_tac lH in + let vlpe := fresh "list_hyp" in + let fe1 := mkFE t1 fv in + let fe2 := mkFE t2 fv in + pose (vlpe := lpe); + let nlemma := fresh "field_lemma" in + (assert (nlemma := lemma n fv vlpe fe1 fe2 prh) + || fail "field anomaly:failed to build lemma"); + ParseExpr nlemma + ltac:(fun ilemma => + apply ilemma + || fail "field anomaly: failed in applying lemma"; + [ Simpl_tac | apply Cond_lemma; simpl_PCond req]); + clear vlpe nlemma in + OnEquation req Main_eq in + ParseFieldComponents lemma Main. (* solve completely a field equation, leaving non-zero conditions to be proved (field) *) -Ltac Field lemma Cond_lemma req Cst_tac := - let Main radd rmul rsub ropp rdiv rinv C := - let mkFV := FFV Cst_tac radd rmul rsub ropp rdiv rinv in - let mkFE := mkFieldexpr C Cst_tac radd rmul rsub ropp rdiv rinv in - let Simpl := - vm_compute; reflexivity || fail "not a valid field equation" in - Field_Scheme mkFV mkFE Simpl lemma Cond_lemma req in - ParseFieldComponents lemma req Main. +Ltac FIELD := + let Simpl := vm_compute; reflexivity || fail "not a valid field equation" in + fun req cst_tac pow_tac field_ok _ _ _ cond_ok pre post lH rl => + pre(); + Field_Scheme Simpl cst_tac pow_tac field_ok cond_ok req + Ring_tac.ring_subst_niter lH; + try exact I; + post(). + Tactic Notation (at level 0) "field" := - field_lookup - (fun req cst_tac field_ok _ _ cond_ok pre post rl => - pre(); Field field_ok cond_ok req cst_tac; post()). + let G := getGoal in field_lookup FIELD [] [G]. + +Tactic Notation (at level 0) "field" "[" constr_list(lH) "]" := + let G := getGoal in field_lookup FIELD [lH] [G]. (* transforms a field equation to an equivalent (simplified) ring equation, and leaves non-zero conditions to be proved (field_simplify_eq) *) -Ltac Field_simplify_eq lemma Cond_lemma req Cst_tac := - let Main radd rmul rsub ropp rdiv rinv C := - let mkFV := FFV Cst_tac radd rmul rsub ropp rdiv rinv in - let mkFE := mkFieldexpr C Cst_tac radd rmul rsub ropp rdiv rinv in - let Simpl := (protect_fv "field") in - Field_Scheme mkFV mkFE Simpl lemma Cond_lemma req in - ParseFieldComponents lemma req Main. - -Tactic Notation (at level 0) "field_simplify_eq" := - field_lookup - (fun req cst_tac _ field_simplify_eq_ok _ cond_ok pre post rl => - pre(); Field_simplify_eq field_simplify_eq_ok cond_ok req cst_tac; - post()). +Ltac FIELD_SIMPL := + let Simpl := (protect_fv "field") in + fun req cst_tac pow_tac _ field_simplify_eq_ok _ _ cond_ok pre post lH rl => + pre(); + Field_Scheme Simpl cst_tac pow_tac field_simplify_eq_ok cond_ok + req Ring_tac.ring_subst_niter lH; + post(). + +Tactic Notation (at level 0) "field_simplify_eq" := + let G := getGoal in field_lookup FIELD_SIMPL [] [G]. + +Tactic Notation (at level 0) "field_simplify_eq" "[" constr_list(lH) "]" := + let G := getGoal in field_lookup FIELD_SIMPL [lH] [G]. + +(* Same as FIELD_SIMPL but in hypothesis *) + +Ltac Field_simplify_eq Cst_tac Pow_tac lemma Cond_lemma req n lH := + let Main radd rmul rsub ropp rdiv rinv rpow C := + let hyp := fresh "hyp" in + intro hyp; + match type of hyp with + | req ?t1 ?t2 => + let mkFV := FV Cst_tac Pow_tac radd rmul rsub ropp rpow in + let mkPol := mkPolexpr C Cst_tac Pow_tac radd rmul rsub ropp rpow in + let mkFFV := FFV Cst_tac Pow_tac radd rmul rsub ropp rdiv rinv rpow in + let mkFE := + mkFieldexpr C Cst_tac Pow_tac radd rmul rsub ropp rdiv rinv rpow in + let rec ParseExpr ilemma := + match type of ilemma with + | forall nfe, ?fe = nfe -> _ => + (fun t => + let x := fresh "fld_expr" in + let H := fresh "norm_fld_expr" in + compute_assertion H x fe; + ParseExpr (ilemma x H) t; + try clear H x) + | _ => (fun t => t ilemma) + end in + let fv := FV_hypo_tac mkFV req lH in + let fv := mkFFV t1 fv in + let fv := mkFFV t2 fv in + let lpe := mkHyp_tac C req ltac:(fun t => mkPol t fv) lH in + let prh := proofHyp_tac lH in + let fe1 := mkFE t1 fv in + let fe2 := mkFE t2 fv in + let vlpe := fresh "vlpe" in + ParseExpr (lemma n fv lpe fe1 fe2 prh) + ltac:(fun ilemma => + match type of ilemma with + | req _ _ -> _ -> ?EQ => + let tmp := fresh "tmp" in + assert (tmp : EQ); + [ apply ilemma; + [ exact hyp | apply Cond_lemma; simpl_PCond_BEURK req] + | protect_fv "field" in tmp; + generalize tmp;clear tmp ]; + clear hyp + end) + end in + ParseFieldComponents lemma Main. + +Ltac FIELD_SIMPL_EQ := + fun req cst_tac pow_tac _ _ _ lemma cond_ok pre post lH rl => + pre(); + Field_simplify_eq cst_tac pow_tac lemma cond_ok req + Ring_tac.ring_subst_niter lH; + post(). + +Tactic Notation (at level 0) "field_simplify_eq" "in" hyp(H) := + let t := type of H in + generalize H; + field_lookup FIELD_SIMPL_EQ [] [t]; + [ try exact I + | clear H;intro H]. + + +Tactic Notation (at level 0) + "field_simplify_eq" "[" constr_list(lH) "]" "in" hyp(H) := + let t := type of H in + generalize H; + field_lookup FIELD_SIMPL_EQ [lH] [t]; + [ try exact I + |clear H;intro H]. + (* Adding a new field *) Ltac ring_of_field f := @@ -179,22 +347,59 @@ Ltac coerce_to_almost_field set ext f := | semi_field_theory _ _ _ _ _ _ _ => constr:(SF2AF set f) end. -Ltac field_elements set ext fspec rk := +Ltac field_elements set ext fspec pspec sspec rk := let afth := coerce_to_almost_field set ext fspec in let rspec := ring_of_field fspec in - ring_elements set ext rspec rk - ltac:(fun arth ext_r morph f => f afth ext_r morph). - - -Ltac field_lemmas set ext inv_m fspec rk := - field_elements set ext fspec rk - ltac:(fun afth ext_r morph => - let field_ok := constr:(Field_correct set ext_r inv_m afth morph) in - let field_simpl_ok := - constr:(Pphi_dev_div_ok set ext_r inv_m afth morph) in - let field_simpl_eq_ok := - constr:(Field_simplify_eq_correct set ext_r inv_m afth morph) in - let cond1_ok := constr:(Pcond_simpl_gen set ext_r afth morph) in - let cond2_ok := constr:(Pcond_simpl_complete set ext_r afth morph) in - (fun f => f afth ext_r morph field_ok field_simpl_ok field_simpl_eq_ok - cond1_ok cond2_ok)). + ring_elements set ext rspec pspec sspec rk + ltac:(fun arth ext_r morph p_spec s_spec f => f afth ext_r morph p_spec s_spec). + +Ltac field_lemmas set ext inv_m fspec pspec sspec rk := + let simpl_eq_lemma := + match pspec with + | None => constr:(Field_simplify_eq_correct) + | Some _ => constr:(Field_simplify_eq_pow_correct) + end in + let simpl_eq_in_lemma := + match pspec with + | None => constr:(Field_simplify_eq_in_correct) + | Some _ => constr:(Field_simplify_eq_pow_in_correct) + end in + let rw_lemma := + match pspec with + | None => constr:(Field_rw_correct) + | Some _ => constr:(Field_rw_pow_correct) + end in + field_elements set ext fspec pspec sspec rk + ltac:(fun afth ext_r morph p_spec s_spec => + match p_spec with + | mkhypo ?pp_spec => match s_spec with + | mkhypo ?ss_spec => + let field_simpl_eq_ok := + constr:(simpl_eq_lemma _ _ _ _ _ _ _ _ _ _ + set ext_r inv_m afth + _ _ _ _ _ _ _ _ _ morph + _ _ _ pp_spec _ ss_spec) in + let field_simpl_ok := + constr:(rw_lemma _ _ _ _ _ _ _ _ _ _ + set ext_r inv_m afth + _ _ _ _ _ _ _ _ _ morph + _ _ _ pp_spec _ ss_spec) in + let field_simpl_eq_in := + constr:(simpl_eq_in_lemma _ _ _ _ _ _ _ _ _ _ + set ext_r inv_m afth + _ _ _ _ _ _ _ _ _ morph + _ _ _ pp_spec _ ss_spec) in + let field_ok := + constr:(Field_correct set ext_r inv_m afth morph pp_spec ss_spec) in + let cond1_ok := + constr:(Pcond_simpl_gen set ext_r afth morph pp_spec) in + let cond2_ok := + constr:(Pcond_simpl_complete set ext_r afth morph pp_spec) in + (fun f => + f afth ext_r morph field_ok field_simpl_ok field_simpl_eq_ok field_simpl_eq_in + cond1_ok cond2_ok) + | _ => fail 2 "bad sign specification" + end + | _ => fail 1 "bad power specification" + end). + diff --git a/contrib/setoid_ring/Field_theory.v b/contrib/setoid_ring/Field_theory.v index f810859c..ea8421cf 100644 --- a/contrib/setoid_ring/Field_theory.v +++ b/contrib/setoid_ring/Field_theory.v @@ -9,6 +9,7 @@ Require Ring. Import Ring_polynom Ring_tac Ring_theory InitialRing Setoid List. Require Import ZArith_base. +(*Require Import Omega.*) Set Implicit Arguments. Section MakeFieldPol. @@ -29,7 +30,7 @@ Section MakeFieldPol. Variable Rsth : Setoid_Theory R req. Variable Reqe : ring_eq_ext radd rmul ropp req. Variable SRinv_ext : forall p q, p == q -> / p == / q. - + (* Field properties *) Record almost_field_theory : Prop := mk_afield { AF_AR : almost_ring_theory rO rI radd rmul rsub ropp req; @@ -94,9 +95,20 @@ Hint Resolve (ARadd_0_l ARth) (ARadd_comm ARth) (ARadd_assoc ARth) (ARopp_mul_l ARth) (ARopp_add ARth) (ARsub_def ARth) . -Notation NPEeval := (PEeval rO radd rmul rsub ropp phi). -Notation Nnorm := (norm cO cI cadd cmul csub copp ceqb). -Notation NPphi_dev := (Pphi_dev rO rI radd rmul cO cI ceqb phi). + (* Power coefficients *) + Variable Cpow : Set. + Variable Cp_phi : N -> Cpow. + Variable rpow : R -> Cpow -> R. + Variable pow_th : power_theory rI rmul req Cp_phi rpow. + (* sign function *) + Variable get_sign : C -> option C. + Variable get_sign_spec : sign_theory ropp req phi get_sign. + +Notation NPEeval := (PEeval rO radd rmul rsub ropp phi Cp_phi rpow). +Notation Nnorm := (norm_subst cO cI cadd cmul csub copp ceqb). + +Notation NPphi_dev := (Pphi_dev rO rI radd rmul rsub ropp cO cI ceqb phi get_sign). +Notation NPphi_pow := (Pphi_pow rO rI radd rmul rsub ropp cO cI ceqb phi Cp_phi rpow get_sign). (* add abstract semi-ring to help with some proofs *) Add Ring Rring : (ARth_SRth ARth). @@ -105,7 +117,7 @@ Add Ring Rring : (ARth_SRth ARth). (* additional ring properties *) Lemma rsub_0_l : forall r, 0 - r == - r. -intros; rewrite (ARsub_def ARth) in |- *; ring. +intros; rewrite (ARsub_def ARth) in |- *;ring. Qed. Lemma rsub_0_r : forall r, r - 0 == r. @@ -352,6 +364,20 @@ intros H1; apply f_equal with ( f := xO ); auto. intros H1 H2; case H1; injection H2; auto. Qed. +Definition N_eq n1 n2 := + match n1, n2 with + | N0, N0 => true + | Npos p1, Npos p2 => positive_eq p1 p2 + | _, _ => false + end. + +Lemma N_eq_correct : forall n1 n2, if N_eq n1 n2 then n1 = n2 else n1 <> n2. +Proof. + intros [ |p1] [ |p2];simpl;trivial;try(intro H;discriminate H;fail). + assert (H:=positive_eq_correct p1 p2);destruct (positive_eq p1 p2); + [rewrite H;trivial | intro H1;injection H1;subst;apply H;trivial]. +Qed. + (* equality test *) Fixpoint PExpr_eq (e1 e2 : PExpr C) {struct e1} : bool := match e1, e2 with @@ -361,9 +387,25 @@ Fixpoint PExpr_eq (e1 e2 : PExpr C) {struct e1} : bool := | PEsub e3 e5, PEsub e4 e6 => if PExpr_eq e3 e4 then PExpr_eq e5 e6 else false | PEmul e3 e5, PEmul e4 e6 => if PExpr_eq e3 e4 then PExpr_eq e5 e6 else false | PEopp e3, PEopp e4 => PExpr_eq e3 e4 + | PEpow e3 n3, PEpow e4 n4 => if N_eq n3 n4 then PExpr_eq e3 e4 else false | _, _ => false end. +Add Morphism (pow_pos rmul) : pow_morph. +intros x y H p;induction p as [p IH| p IH|];simpl;auto;ring[IH]. +Qed. + +Add Morphism (pow_N rI rmul) : pow_N_morph. +intros x y H [|p];simpl;auto. apply pow_morph;trivial. +Qed. +(* +Lemma rpow_morph : forall x y n, x == y ->rpow x (Cp_phi n) == rpow y (Cp_phi n). +Proof. + intros; repeat rewrite pow_th.(rpow_pow_N). + destruct n;simpl. apply eq_refl. + induction p;simpl;try rewrite IHp;try rewrite H; apply eq_refl. +Qed. +*) Theorem PExpr_eq_semi_correct: forall l e1 e2, PExpr_eq e1 e2 = true -> NPEeval l e1 == NPEeval l e2. intros l e1; elim e1. @@ -387,6 +429,10 @@ intros e4 e6; generalize (rec1 e4); case (PExpr_eq e3 e4); intros e3 rec e2; (case e2; simpl; (try (intros; discriminate))). intros e4; generalize (rec e4); case (PExpr_eq e3 e4); (try (intros; discriminate)); auto. +intros e3 rec n3 e2;(case e2;simpl;(try (intros;discriminate))). +intros e4 n4;generalize (N_eq_correct n3 n4);destruct (N_eq n3 n4); +intros;try discriminate. +repeat rewrite pow_th.(rpow_pow_N);rewrite H;rewrite (rec _ H0);auto. Qed. (* add *) @@ -395,6 +441,7 @@ Definition NPEadd e1 e2 := PEc c1, PEc c2 => PEc (cadd c1 c2) | PEc c, _ => if ceqb c cO then e2 else PEadd e1 e2 | _, PEc c => if ceqb c cO then e1 else PEadd e1 e2 + (* Peut t'on factoriser ici ??? *) | _, _ => PEadd e1 e2 end. @@ -403,32 +450,68 @@ Theorem NPEadd_correct: Proof. intros l e1 e2. destruct e1; destruct e2; simpl in |- *; try reflexivity; try apply ceqb_rect; - try (intro eq_c; rewrite eq_c in |- *); simpl in |- *; - try rewrite (morph0 CRmorph) in |- *; try ring. -apply (morph_add CRmorph). + try (intro eq_c; rewrite eq_c in |- *); simpl in |- *;try apply eq_refl; + try ring [(morph0 CRmorph)]. + apply (morph_add CRmorph). +Qed. + +Definition NPEpow x n := + match n with + | N0 => PEc cI + | Npos p => + if positive_eq p xH then x else + match x with + | PEc c => + if ceqb c cI then PEc cI else if ceqb c cO then PEc cO else PEc (pow_pos cmul c p) + | _ => PEpow x n + end + end. + +Theorem NPEpow_correct : forall l e n, + NPEeval l (NPEpow e n) == NPEeval l (PEpow e n). +Proof. + destruct n;simpl. + rewrite pow_th.(rpow_pow_N);simpl;auto. + generalize (positive_eq_correct p xH). + destruct (positive_eq p 1);intros. + rewrite H;rewrite pow_th.(rpow_pow_N). trivial. + clear H;destruct e;simpl;auto. + repeat apply ceqb_rect;simpl;intros;rewrite pow_th.(rpow_pow_N);simpl. + symmetry;induction p;simpl;trivial; ring [IHp H CRmorph.(morph1)]. + symmetry; induction p;simpl;trivial;ring [IHp CRmorph.(morph0)]. + induction p;simpl;auto;repeat rewrite CRmorph.(morph_mul);ring [IHp]. Qed. (* mul *) -Definition NPEmul x y := +Fixpoint NPEmul (x y : PExpr C) {struct x} : PExpr C := match x, y with PEc c1, PEc c2 => PEc (cmul c1 c2) | PEc c, _ => if ceqb c cI then y else if ceqb c cO then PEc cO else PEmul x y | _, PEc c => if ceqb c cI then x else if ceqb c cO then PEc cO else PEmul x y - | _, _ => PEmul x y + | PEpow e1 n1, PEpow e2 n2 => + if N_eq n1 n2 then NPEpow (NPEmul e1 e2) n1 else PEmul x y + | _, _ => PEmul x y end. - + +Lemma pow_pos_mul : forall x y p, pow_pos rmul (x * y) p == pow_pos rmul x p * pow_pos rmul y p. +induction p;simpl;auto;try ring [IHp]. +Qed. + Theorem NPEmul_correct : forall l e1 e2, NPEeval l (NPEmul e1 e2) == NPEeval l (PEmul e1 e2). -intros l e1 e2. -destruct e1; destruct e2; simpl in |- *; try reflexivity; +induction e1;destruct e2; simpl in |- *;try reflexivity; repeat apply ceqb_rect; - try (intro eq_c; rewrite eq_c in |- *); simpl in |- *; - try rewrite (morph0 CRmorph) in |- *; - try rewrite (morph1 CRmorph) in |- *; - try ring. -apply (morph_mul CRmorph). + try (intro eq_c; rewrite eq_c in |- *); simpl in |- *; try reflexivity; + try ring [(morph0 CRmorph) (morph1 CRmorph)]. + apply (morph_mul CRmorph). +assert (H:=N_eq_correct n n0);destruct (N_eq n n0). +rewrite NPEpow_correct. simpl. +repeat rewrite pow_th.(rpow_pow_N). +rewrite IHe1;rewrite <- H;destruct n;simpl;try ring. +apply pow_pos_mul. +simpl;auto. Qed. (* sub *) @@ -437,6 +520,7 @@ Definition NPEsub e1 e2 := PEc c1, PEc c2 => PEc (csub c1 c2) | PEc c, _ => if ceqb c cO then PEopp e2 else PEsub e1 e2 | _, PEc c => if ceqb c cO then e1 else PEsub e1 e2 + (* Peut-on factoriser ici *) | _, _ => PEsub e1 e2 end. @@ -467,6 +551,7 @@ Fixpoint PExpr_simp (e : PExpr C) : PExpr C := | PEmul e1 e2 => NPEmul (PExpr_simp e1) (PExpr_simp e2) | PEsub e1 e2 => NPEsub (PExpr_simp e1) (PExpr_simp e2) | PEopp e1 => NPEopp (PExpr_simp e1) + | PEpow e1 n1 => NPEpow (PExpr_simp e1) n1 | _ => e end. @@ -489,6 +574,10 @@ intros e1 He1. transitivity (NPEeval l (PEopp (PExpr_simp e1))); auto. apply NPEopp_correct. simpl; auto. +intros e1 He1 n;simpl. +rewrite NPEpow_correct;simpl. +repeat rewrite pow_th.(rpow_pow_N). +rewrite He1;auto. Qed. @@ -508,8 +597,9 @@ Inductive FExpr : Type := | FEmul: FExpr -> FExpr -> FExpr | FEopp: FExpr -> FExpr | FEinv: FExpr -> FExpr - | FEdiv: FExpr -> FExpr -> FExpr . - + | FEdiv: FExpr -> FExpr -> FExpr + | FEpow: FExpr -> N -> FExpr . + Fixpoint FEeval (l : list R) (pe : FExpr) {struct pe} : R := match pe with | FEc c => phi c @@ -520,6 +610,7 @@ Fixpoint FEeval (l : list R) (pe : FExpr) {struct pe} : R := | FEopp x => - FEeval l x | FEinv x => / FEeval l x | FEdiv x y => FEeval l x / FEeval l y + | FEpow x n => rpow (FEeval l x) (Cp_phi n) end. (* The result of the normalisation *) @@ -538,8 +629,8 @@ Record linear : Type := mk_linear { Fixpoint PCond (l : list R) (le : list (PExpr C)) {struct le} : Prop := match le with | nil => True - | e1 :: nil => ~ req (PEeval rO radd rmul rsub ropp phi l e1) rO - | e1 :: l1 => ~ req (PEeval rO radd rmul rsub ropp phi l e1) rO /\ PCond l l1 + | e1 :: nil => ~ req (NPEeval l e1) rO + | e1 :: l1 => ~ req (NPEeval l e1) rO /\ PCond l l1 end. Theorem PCond_cons_inv_l : @@ -584,66 +675,170 @@ Qed. ***************************************************************************) - -Fixpoint isIn (e1 e2: PExpr C) {struct e2}: option (PExpr C) := +Fixpoint isIn (e1:PExpr C) (p1:positive) + (e2:PExpr C) (p2:positive) {struct e2}: option (N * PExpr C) := match e2 with | PEmul e3 e4 => - match isIn e1 e3 with - Some e5 => Some (NPEmul e5 e4) - | None => match isIn e1 e4 with - | Some e5 => Some (NPEmul e3 e5) - | None => None - end + match isIn e1 p1 e3 p2 with + | Some (N0, e5) => Some (N0, NPEmul e5 (NPEpow e4 (Npos p2))) + | Some (Npos p, e5) => + match isIn e1 p e4 p2 with + | Some (n, e6) => Some (n, NPEmul e5 e6) + | None => Some (Npos p, NPEmul e5 (NPEpow e4 (Npos p2))) + end + | None => + match isIn e1 p1 e4 p2 with + | Some (n, e5) => Some (n,NPEmul (NPEpow e3 (Npos p2)) e5) + | None => None + end end + | PEpow e3 N0 => None + | PEpow e3 (Npos p3) => isIn e1 p1 e3 (Pmult p3 p2) | _ => - if PExpr_eq e1 e2 then Some (PEc cI) else None + if PExpr_eq e1 e2 then + match Zminus (Zpos p1) (Zpos p2) with + | Zpos p => Some (Npos p, PEc cI) + | Z0 => Some (N0, PEc cI) + | Zneg p => Some (N0, NPEpow e2 (Npos p)) + end + else None end. + + Definition ZtoN z := match z with Zpos p => Npos p | _ => N0 end. + Definition NtoZ n := match n with Npos p => Zpos p | _ => Z0 end. + + Notation pow_pos_plus := (Ring_theory.pow_pos_Pplus _ Rsth Reqe.(Rmul_ext) + ARth.(ARmul_comm) ARth.(ARmul_assoc)). + + Lemma isIn_correct_aux : forall l e1 e2 p1 p2, + match + (if PExpr_eq e1 e2 then + match Zminus (Zpos p1) (Zpos p2) with + | Zpos p => Some (Npos p, PEc cI) + | Z0 => Some (N0, PEc cI) + | Zneg p => Some (N0, NPEpow e2 (Npos p)) + end + else None) + with + | Some(n, e3) => + NPEeval l (PEpow e2 (Npos p2)) == + NPEeval l (PEmul (PEpow e1 (ZtoN (Zpos p1 - NtoZ n))) e3) /\ + (Zpos p1 > NtoZ n)%Z + | _ => True + end. +Proof. + intros l e1 e2 p1 p2; generalize (PExpr_eq_semi_correct l e1 e2); + case (PExpr_eq e1 e2); simpl; auto; intros H. + case_eq ((p1 ?= p2)%positive Eq);intros;simpl. + repeat rewrite pow_th.(rpow_pow_N);simpl. split. 2:refine (refl_equal _). + rewrite (Pcompare_Eq_eq _ _ H0). + rewrite H;[trivial | ring [ (morph1 CRmorph)]]. + fold (NPEpow e2 (Npos (p2 - p1))). + rewrite NPEpow_correct;simpl. + repeat rewrite pow_th.(rpow_pow_N);simpl. + rewrite H;trivial. split. 2:refine (refl_equal _). + rewrite <- pow_pos_plus; rewrite Pplus_minus;auto. apply ZC2;trivial. + repeat rewrite pow_th.(rpow_pow_N);simpl. + rewrite H;trivial. + change (ZtoN + match (p1 ?= p1 - p2)%positive Eq with + | Eq => 0 + | Lt => Zneg (p1 - p2 - p1) + | Gt => Zpos (p1 - (p1 - p2)) + end) with (ZtoN (Zpos p1 - Zpos (p1 -p2))). + replace (Zpos (p1 - p2)) with (Zpos p1 - Zpos p2)%Z. + split. + repeat rewrite Zth.(Rsub_def). rewrite (Ring_theory.Ropp_add Zsth Zeqe Zth). + rewrite Zplus_assoc. simpl. rewrite Pcompare_refl. simpl. + ring [ (morph1 CRmorph)]. + assert (Zpos p1 > 0 /\ Zpos p2 > 0)%Z. split;refine (refl_equal _). + apply Zplus_gt_reg_l with (Zpos p2). + rewrite Zplus_minus. change (Zpos p2 + Zpos p1 > 0 + Zpos p1)%Z. + apply Zplus_gt_compat_r. refine (refl_equal _). + simpl;rewrite H0;trivial. +Qed. + +Lemma pow_pos_pow_pos : forall x p1 p2, pow_pos rmul (pow_pos rmul x p1) p2 == pow_pos rmul x (p1*p2). +induction p1;simpl;intros;repeat rewrite pow_pos_mul;repeat rewrite pow_pos_plus;simpl. +ring [(IHp1 p2)]. ring [(IHp1 p2)]. auto. +Qed. + -Theorem isIn_correct: forall l e1 e2, - match isIn e1 e2 with - (Some e3) => NPEeval l e2 == NPEeval l (NPEmul e1 e3) - | _ => True +Theorem isIn_correct: forall l e1 p1 e2 p2, + match isIn e1 p1 e2 p2 with + | Some(n, e3) => + NPEeval l (PEpow e2 (Npos p2)) == + NPEeval l (PEmul (PEpow e1 (ZtoN (Zpos p1 - NtoZ n))) e3) /\ + (Zpos p1 > NtoZ n)%Z + | _ => True end. Proof. -intros l e1 e2; elim e2; simpl; auto. - intros c; - generalize (PExpr_eq_semi_correct l e1 (PEc c)); - case (PExpr_eq e1 (PEc c)); simpl; auto; intros H. - rewrite NPEmul_correct; simpl; auto. - rewrite H; auto; simpl. - rewrite (morph1 CRmorph); rewrite (ARmul_1_r Rsth ARth); auto. - intros p; - generalize (PExpr_eq_semi_correct l e1 (PEX C p)); - case (PExpr_eq e1 (PEX C p)); simpl; auto; intros H. - rewrite NPEmul_correct; simpl; auto. - rewrite H; auto; simpl. - rewrite (morph1 CRmorph); rewrite (ARmul_1_r Rsth ARth); auto. - intros p Hrec p1 Hrec1. - generalize (PExpr_eq_semi_correct l e1 (PEadd p p1)); - case (PExpr_eq e1 (PEadd p p1)); simpl; auto; intros H. - rewrite NPEmul_correct; simpl; auto. - rewrite H; auto; simpl. - rewrite (morph1 CRmorph); rewrite (ARmul_1_r Rsth ARth); auto. - intros p Hrec p1 Hrec1. - generalize (PExpr_eq_semi_correct l e1 (PEsub p p1)); - case (PExpr_eq e1 (PEsub p p1)); simpl; auto; intros H. - rewrite NPEmul_correct; simpl; auto. - rewrite H; auto; simpl. - rewrite (morph1 CRmorph); rewrite (ARmul_1_r Rsth ARth); auto. - intros p; case (isIn e1 p). - intros p2 Hrec p1 Hrec1. - rewrite Hrec; auto; simpl. - repeat (rewrite NPEmul_correct; simpl; auto). - intros _ p1; case (isIn e1 p1); auto. - intros p2 H; rewrite H. - repeat (rewrite NPEmul_correct; simpl; auto). - ring. - intros p; - generalize (PExpr_eq_semi_correct l e1 (PEopp p)); - case (PExpr_eq e1 (PEopp p)); simpl; auto; intros H. - rewrite NPEmul_correct; simpl; auto. - rewrite H; auto; simpl. - rewrite (morph1 CRmorph); rewrite (ARmul_1_r Rsth ARth); auto. +Opaque NPEpow. +intros l e1 p1 e2; generalize p1;clear p1;elim e2; intros; + try (refine (isIn_correct_aux l e1 _ p1 p2);fail);simpl isIn. +generalize (H p1 p2);clear H;destruct (isIn e1 p1 p p2). destruct p3. +destruct n. + simpl. rewrite NPEmul_correct. simpl; rewrite NPEpow_correct;simpl. + repeat rewrite pow_th.(rpow_pow_N);simpl. + rewrite pow_pos_mul;intros (H,H1);split;[ring[H]|trivial]. + generalize (H0 p4 p2);clear H0;destruct (isIn e1 p4 p0 p2). destruct p5. + destruct n;simpl. + rewrite NPEmul_correct;repeat rewrite pow_th.(rpow_pow_N);simpl. + intros (H1,H2) (H3,H4). + unfold Zgt in H2, H4;simpl in H2,H4. rewrite H4 in H3;simpl in H3. + rewrite pow_pos_mul. rewrite H1;rewrite H3. + assert (pow_pos rmul (NPEeval l e1) (p1 - p4) * NPEeval l p3 * + (pow_pos rmul (NPEeval l e1) p4 * NPEeval l p5) == + pow_pos rmul (NPEeval l e1) p4 * pow_pos rmul (NPEeval l e1) (p1 - p4) * + NPEeval l p3 *NPEeval l p5) by ring. rewrite H;clear H. + rewrite <- pow_pos_plus. rewrite Pplus_minus. + split. symmetry;apply ARth.(ARmul_assoc). refine (refl_equal _). trivial. + repeat rewrite pow_th.(rpow_pow_N);simpl. + intros (H1,H2) (H3,H4). + unfold Zgt in H2, H4;simpl in H2,H4. rewrite H4 in H3;simpl in H3. + rewrite H2 in H1;simpl in H1. + assert (Zpos p1 > Zpos p6)%Z. + apply Zgt_trans with (Zpos p4). exact H4. exact H2. + unfold Zgt in H;simpl in H;rewrite H. + split. 2:exact H. + rewrite pow_pos_mul. simpl;rewrite H1;rewrite H3. + assert (pow_pos rmul (NPEeval l e1) (p1 - p4) * NPEeval l p3 * + (pow_pos rmul (NPEeval l e1) (p4 - p6) * NPEeval l p5) == + pow_pos rmul (NPEeval l e1) (p1 - p4) * pow_pos rmul (NPEeval l e1) (p4 - p6) * + NPEeval l p3 * NPEeval l p5) by ring. rewrite H0;clear H0. + rewrite <- pow_pos_plus. + replace (p1 - p4 + (p4 - p6))%positive with (p1 - p6)%positive. + rewrite NPEmul_correct. simpl;ring. + assert + (Zpos p1 - Zpos p6 = Zpos p1 - Zpos p4 + (Zpos p4 - Zpos p6))%Z. + change ((Zpos p1 - Zpos p6)%Z = (Zpos p1 + (- Zpos p4) + (Zpos p4 +(- Zpos p6)))%Z). + rewrite <- Zplus_assoc. rewrite (Zplus_assoc (- Zpos p4)). + simpl. rewrite Pcompare_refl. reflexivity. + unfold Zminus, Zopp in H0. simpl in H0. + rewrite H2 in H0;rewrite H4 in H0;rewrite H in H0. inversion H0;trivial. + simpl. repeat rewrite pow_th.(rpow_pow_N). + intros H1 (H2,H3). unfold Zgt in H3;simpl in H3. rewrite H3 in H2;rewrite H3. + rewrite NPEmul_correct;simpl;rewrite NPEpow_correct;simpl. + simpl in H2. rewrite pow_th.(rpow_pow_N);simpl. + rewrite pow_pos_mul. split. ring [H2]. exact H3. + generalize (H0 p1 p2);clear H0;destruct (isIn e1 p1 p0 p2). destruct p3. + destruct n;simpl. rewrite NPEmul_correct;simpl;rewrite NPEpow_correct;simpl. + repeat rewrite pow_th.(rpow_pow_N);simpl. + intros (H1,H2);split;trivial. rewrite pow_pos_mul;ring [H1]. + rewrite NPEmul_correct;simpl;rewrite NPEpow_correct;simpl. + repeat rewrite pow_th.(rpow_pow_N);simpl. rewrite pow_pos_mul. + intros (H1, H2);rewrite H1;split. + unfold Zgt in H2;simpl in H2;rewrite H2;rewrite H2 in H1. + simpl in H1;ring [H1]. trivial. + trivial. + destruct n. trivial. + generalize (H p1 (p0*p2)%positive);clear H;destruct (isIn e1 p1 p (p0*p2)). destruct p3. + destruct n;simpl. repeat rewrite pow_th.(rpow_pow_N). simpl. + intros (H1,H2);split. rewrite pow_pos_pow_pos. trivial. trivial. + repeat rewrite pow_th.(rpow_pow_N). simpl. + intros (H1,H2);split;trivial. + rewrite pow_pos_pow_pos;trivial. + trivial. Qed. Record rsplit : Type := mk_rsplit { @@ -652,90 +847,94 @@ Record rsplit : Type := mk_rsplit { rsplit_right : PExpr C}. (* Stupid name clash *) -Let left := rsplit_left. -Let right := rsplit_right. -Let common := rsplit_common. +Notation left := rsplit_left. +Notation right := rsplit_right. +Notation common := rsplit_common. -Fixpoint split (e1 e2: PExpr C) {struct e1}: rsplit := +Fixpoint split_aux (e1: PExpr C) (p:positive) (e2:PExpr C) {struct e1}: rsplit := match e1 with | PEmul e3 e4 => - let r1 := split e3 e2 in - let r2 := split e4 (right r1) in + let r1 := split_aux e3 p e2 in + let r2 := split_aux e4 p (right r1) in mk_rsplit (NPEmul (left r1) (left r2)) (NPEmul (common r1) (common r2)) (right r2) + | PEpow e3 N0 => mk_rsplit (PEc cI) (PEc cI) e2 + | PEpow e3 (Npos p3) => split_aux e3 (Pmult p3 p) e2 | _ => - match isIn e1 e2 with - Some e3 => mk_rsplit (PEc cI) e1 e3 - | None => mk_rsplit e1 (PEc cI) e2 + match isIn e1 p e2 xH with + | Some (N0,e3) => mk_rsplit (PEc cI) (NPEpow e1 (Npos p)) e3 + | Some (Npos q, e3) => mk_rsplit (NPEpow e1 (Npos q)) (NPEpow e1 (Npos (p - q))) e3 + | None => mk_rsplit (NPEpow e1 (Npos p)) (PEc cI) e2 end end. -Theorem split_correct: forall l e1 e2, - NPEeval l e1 == NPEeval l (NPEmul (left (split e1 e2)) - (common (split e1 e2))) -/\ - NPEeval l e2 == NPEeval l (NPEmul (right (split e1 e2)) - (common (split e1 e2))). +Lemma split_aux_correct_1 : forall l e1 p e2, + let res := match isIn e1 p e2 xH with + | Some (N0,e3) => mk_rsplit (PEc cI) (NPEpow e1 (Npos p)) e3 + | Some (Npos q, e3) => mk_rsplit (NPEpow e1 (Npos q)) (NPEpow e1 (Npos (p - q))) e3 + | None => mk_rsplit (NPEpow e1 (Npos p)) (PEc cI) e2 + end in + NPEeval l (PEpow e1 (Npos p)) == NPEeval l (NPEmul (left res) (common res)) + /\ + NPEeval l e2 == NPEeval l (NPEmul (right res) (common res)). Proof. -intros l e1; elim e1; simpl; auto. - intros c e2; generalize (isIn_correct l (PEc c) e2); - case (isIn (PEc c) e2); auto; intros p; - [intros Hp1; rewrite Hp1 | idtac]; - simpl left; simpl common; simpl right; auto; - repeat rewrite NPEmul_correct; simpl; split; - try rewrite (morph1 CRmorph); ring. - intros p e2; generalize (isIn_correct l (PEX C p) e2); - case (isIn (PEX C p) e2); auto; intros p1; - [intros Hp1; rewrite Hp1 | idtac]; - simpl left; simpl common; simpl right; auto; - repeat rewrite NPEmul_correct; simpl; split; - try rewrite (morph1 CRmorph); ring. - intros p1 _ p2 _ e2; generalize (isIn_correct l (PEadd p1 p2) e2); - case (isIn (PEadd p1 p2) e2); auto; intros p; - [intros Hp1; rewrite Hp1 | idtac]; - simpl left; simpl common; simpl right; auto; - repeat rewrite NPEmul_correct; simpl; split; - try rewrite (morph1 CRmorph); ring. - intros p1 _ p2 _ e2; generalize (isIn_correct l (PEsub p1 p2) e2); - case (isIn (PEsub p1 p2) e2); auto; intros p; - [intros Hp1; rewrite Hp1 | idtac]; - simpl left; simpl common; simpl right; auto; - repeat rewrite NPEmul_correct; simpl; split; - try rewrite (morph1 CRmorph); ring. - intros p1 Hp1 p2 Hp2 e2. - repeat rewrite NPEmul_correct; simpl; split. - case (Hp1 e2); case (Hp2 (right (split p1 e2))). - intros tmp1 _ tmp2 _; rewrite tmp1; rewrite tmp2. - repeat rewrite NPEmul_correct; simpl. - ring. - case (Hp1 e2); case (Hp2 (right (split p1 e2))). - intros _ tmp1 _ tmp2; rewrite tmp2; - repeat rewrite NPEmul_correct; simpl. - rewrite tmp1. - repeat rewrite NPEmul_correct; simpl. - ring. - intros p _ e2; generalize (isIn_correct l (PEopp p) e2); - case (isIn (PEopp p) e2); auto; intros p1; - [intros Hp1; rewrite Hp1 | idtac]; - simpl left; simpl common; simpl right; auto; - repeat rewrite NPEmul_correct; simpl; split; - try rewrite (morph1 CRmorph); ring. + intros. unfold res;clear res; generalize (isIn_correct l e1 p e2 xH). + destruct (isIn e1 p e2 1). destruct p0. + Opaque NPEpow NPEmul. + destruct n;simpl; + (repeat rewrite NPEmul_correct;simpl; + repeat rewrite NPEpow_correct;simpl; + repeat rewrite pow_th.(rpow_pow_N);simpl). + intros (H, Hgt);split;try ring [H CRmorph.(morph1)]. + intros (H, Hgt). unfold Zgt in Hgt;simpl in Hgt;rewrite Hgt in H. + simpl in H;split;try ring [H]. + rewrite <- pow_pos_plus. rewrite Pplus_minus. reflexivity. trivial. + simpl;intros. repeat rewrite NPEmul_correct;simpl. + rewrite NPEpow_correct;simpl. split;ring [CRmorph.(morph1)]. Qed. +Theorem split_aux_correct: forall l e1 p e2, + NPEeval l (PEpow e1 (Npos p)) == + NPEeval l (NPEmul (left (split_aux e1 p e2)) (common (split_aux e1 p e2))) +/\ + NPEeval l e2 == NPEeval l (NPEmul (right (split_aux e1 p e2)) + (common (split_aux e1 p e2))). +Proof. +intros l; induction e1;intros k e2; try refine (split_aux_correct_1 l _ k e2);simpl. +generalize (IHe1_1 k e2); clear IHe1_1. +generalize (IHe1_2 k (rsplit_right (split_aux e1_1 k e2))); clear IHe1_2. +simpl. repeat (rewrite NPEmul_correct;simpl). +repeat rewrite pow_th.(rpow_pow_N);simpl. +intros (H1,H2) (H3,H4);split. +rewrite pow_pos_mul. rewrite H1;rewrite H3. ring. +rewrite H4;rewrite H2;ring. +destruct n;simpl. +split. repeat rewrite pow_th.(rpow_pow_N);simpl. +rewrite NPEmul_correct. simpl. + induction k;simpl;try ring [CRmorph.(morph1)]; ring [IHk CRmorph.(morph1)]. + rewrite NPEmul_correct;simpl. ring [CRmorph.(morph1)]. +generalize (IHe1 (p*k)%positive e2);clear IHe1;simpl. +repeat rewrite NPEmul_correct;simpl. +repeat rewrite pow_th.(rpow_pow_N);simpl. +rewrite pow_pos_pow_pos. intros [H1 H2];split;ring [H1 H2]. +Qed. +Definition split e1 e2 := split_aux e1 xH e2. + Theorem split_correct_l: forall l e1 e2, NPEeval l e1 == NPEeval l (NPEmul (left (split e1 e2)) (common (split e1 e2))). Proof. -intros l e1 e2; case (split_correct l e1 e2); auto. +intros l e1 e2; case (split_aux_correct l e1 xH e2);simpl. +rewrite pow_th.(rpow_pow_N);simpl;auto. Qed. Theorem split_correct_r: forall l e1 e2, NPEeval l e2 == NPEeval l (NPEmul (right (split e1 e2)) (common (split e1 e2))). Proof. -intros l e1 e2; case (split_correct l e1 e2); auto. +intros l e1 e2; case (split_aux_correct l e1 xH e2);simpl;auto. Qed. Fixpoint Fnorm (e : FExpr) : linear := @@ -777,6 +976,9 @@ Fixpoint Fnorm (e : FExpr) : linear := mk_linear (NPEmul (num x) (denum y)) (NPEmul (denum x) (num y)) (num y :: condition x ++ condition y) + | FEpow e1 n => + let x := Fnorm e1 in + mk_linear (NPEpow (num x) n) (NPEpow (denum x) n) (condition x) end. @@ -789,6 +991,17 @@ Eval compute (FEadd (FEinv (FEX xH%positive)) (FEinv (FEX (xO xH)%positive))))). *) + Lemma pow_pos_not_0 : forall x, ~x==0 -> forall p, ~pow_pos rmul x p == 0. +Proof. + induction p;simpl. + intro Hp;assert (H1 := @rmul_reg_l _ (pow_pos rmul x p * pow_pos rmul x p) 0 H). + apply IHp. + rewrite (@rmul_reg_l _ (pow_pos rmul x p) 0 IHp). rewrite H1. rewrite Hp;ring. ring. + reflexivity. + intro Hp;apply IHp. rewrite (@rmul_reg_l _ (pow_pos rmul x p) 0 IHp). + rewrite Hp;ring. reflexivity. trivial. +Qed. + Theorem Pcond_Fnorm: forall l e, PCond l (condition (Fnorm e)) -> ~ NPEeval l (denum (Fnorm e)) == 0. @@ -849,6 +1062,11 @@ intros l e; elim e. specialize PCond_cons_inv_r with (1:=Hcond); intro Hcond1. apply PCond_app_inv_l with (1 := Hcond1). apply PCond_cons_inv_l with (1:=Hcond). + simpl;intros e1 Hrec1 n Hcond. + rewrite NPEpow_correct. + simpl;rewrite pow_th.(rpow_pow_N). + destruct n;simpl;intros. + apply AFth.(AF_1_neq_0). apply pow_pos_not_0;auto. Qed. Hint Resolve Pcond_Fnorm. @@ -928,6 +1146,23 @@ rewrite (He1 HH1); rewrite (He2 HH2). repeat rewrite NPEmul_correct;simpl. apply rdiv7; auto. apply PCond_cons_inv_l with ( 1 := HH ). + +intros e1 He1 n Hcond;assert (He1' := He1 Hcond);clear He1. +repeat rewrite NPEpow_correct;simpl;repeat rewrite pow_th.(rpow_pow_N). +rewrite He1';clear He1'. +destruct n;simpl. apply rdiv1. +generalize (NPEeval l (num (Fnorm e1))) (NPEeval l (denum (Fnorm e1))) + (Pcond_Fnorm _ _ Hcond). +intros r r0 Hdiff;induction p;simpl. +repeat (rewrite <- rdiv4;trivial). +intro Hp;apply (pow_pos_not_0 Hdiff p). +rewrite (@rmul_reg_l (pow_pos rmul r0 p) (pow_pos rmul r0 p) 0). + apply pow_pos_not_0;trivial. ring [Hp]. reflexivity. +apply pow_pos_not_0;trivial. apply pow_pos_not_0;trivial. +rewrite IHp;reflexivity. +rewrite <- rdiv4;trivial. apply pow_pos_not_0;trivial. apply pow_pos_not_0;trivial. +rewrite IHp;reflexivity. +reflexivity. Qed. Theorem Fnorm_crossproduct: @@ -951,17 +1186,22 @@ rewrite Fnorm_FEeval_PEeval in |- *. Qed. (* Correctness lemmas of reflexive tactics *) +Notation Ninterp_PElist := (interp_PElist rO radd rmul rsub ropp req phi Cp_phi rpow). +Notation Nmk_monpol_list := (mk_monpol_list cO cI cadd cmul csub copp ceqb). Theorem Fnorm_correct: - forall l fe, - Peq ceqb (Nnorm (num (Fnorm fe))) (Pc cO) = true -> - PCond l (condition (Fnorm fe)) -> FEeval l fe == 0. -intros l fe H H1; + forall n l lpe fe, + Ninterp_PElist l lpe -> + Peq ceqb (Nnorm n (Nmk_monpol_list lpe) (num (Fnorm fe))) (Pc cO) = true -> + PCond l (condition (Fnorm fe)) -> FEeval l fe == 0. +intros n l lpe fe Hlpe H H1; apply eq_trans with (1 := Fnorm_FEeval_PEeval l fe H1). apply rdiv8; auto. transitivity (NPEeval l (PEc cO)); auto. -apply (ring_correct Rsth Reqe ARth CRmorph); auto. -simpl; apply (morph0 CRmorph); auto. +rewrite (norm_subst_ok Rsth Reqe ARth CRmorph pow_th n l lpe);auto. +change (NPEeval l (PEc cO)) with (Pphi 0 radd rmul phi l (Pc cO)). +apply (Peq_ok Rsth Reqe CRmorph);auto. +simpl. apply (morph0 CRmorph); auto. Qed. (* simplify a field expression into a fraction *) @@ -969,31 +1209,50 @@ Qed. Definition display_linear l num den := NPphi_dev l num / NPphi_dev l den. -Theorem Pphi_dev_div_ok: - forall l fe nfe, - Fnorm fe = nfe -> - PCond l (condition nfe) -> - FEeval l fe == display_linear l (Nnorm (num nfe)) (Nnorm (denum nfe)). +Definition display_pow_linear l num den := + NPphi_pow l num / NPphi_pow l den. + +Theorem Field_rw_correct : + forall n lpe l, + Ninterp_PElist l lpe -> + forall lmp, Nmk_monpol_list lpe = lmp -> + forall fe nfe, Fnorm fe = nfe -> + PCond l (condition nfe) -> + FEeval l fe == display_linear l (Nnorm n lmp (num nfe)) (Nnorm n lmp (denum nfe)). Proof. - intros l fe nfe eq_nfe H; subst nfe. + intros n lpe l Hlpe lmp lmp_eq fe nfe eq_nfe H; subst nfe lmp. apply eq_trans with (1 := Fnorm_FEeval_PEeval _ _ H). unfold display_linear; apply SRdiv_ext; - apply (Pphi_dev_ok Rsth Reqe ARth CRmorph); reflexivity. + eapply (ring_rw_correct Rsth Reqe ARth CRmorph);eauto. +Qed. + +Theorem Field_rw_pow_correct : + forall n lpe l, + Ninterp_PElist l lpe -> + forall lmp, Nmk_monpol_list lpe = lmp -> + forall fe nfe, Fnorm fe = nfe -> + PCond l (condition nfe) -> + FEeval l fe == display_pow_linear l (Nnorm n lmp (num nfe)) (Nnorm n lmp (denum nfe)). +Proof. + intros n lpe l Hlpe lmp lmp_eq fe nfe eq_nfe H; subst nfe lmp. + apply eq_trans with (1 := Fnorm_FEeval_PEeval _ _ H). + unfold display_pow_linear; apply SRdiv_ext; + eapply (ring_rw_pow_correct Rsth Reqe ARth CRmorph);eauto. Qed. -(* solving a field equation *) Theorem Field_correct : - forall l fe1 fe2, + forall n l lpe fe1 fe2, Ninterp_PElist l lpe -> + forall lmp, Nmk_monpol_list lpe = lmp -> forall nfe1, Fnorm fe1 = nfe1 -> forall nfe2, Fnorm fe2 = nfe2 -> - Peq ceqb (Nnorm (PEmul (num nfe1) (denum nfe2))) - (Nnorm (PEmul (num nfe2) (denum nfe1))) = true -> + Peq ceqb (Nnorm n lmp (PEmul (num nfe1) (denum nfe2))) + (Nnorm n lmp (PEmul (num nfe2) (denum nfe1))) = true -> PCond l (condition nfe1 ++ condition nfe2) -> FEeval l fe1 == FEeval l fe2. Proof. -intros l fe1 fe2 nfe1 eq1 nfe2 eq2 Hnorm Hcond; subst nfe1 nfe2. +intros n l lpe fe1 fe2 Hlpe lmp eq_lmp nfe1 eq1 nfe2 eq2 Hnorm Hcond; subst nfe1 nfe2 lmp. apply Fnorm_crossproduct; trivial. -apply (ring_correct Rsth Reqe ARth CRmorph); trivial. +eapply (ring_correct Rsth Reqe ARth CRmorph); eauto. Qed. (* simplify a field equation : generate the crossproduct and simplify @@ -1002,47 +1261,204 @@ Theorem Field_simplify_eq_old_correct : forall l fe1 fe2 nfe1 nfe2, Fnorm fe1 = nfe1 -> Fnorm fe2 = nfe2 -> - NPphi_dev l (Nnorm (PEmul (num nfe1) (denum nfe2))) == - NPphi_dev l (Nnorm (PEmul (num nfe2) (denum nfe1))) -> + NPphi_dev l (Nnorm O nil (PEmul (num nfe1) (denum nfe2))) == + NPphi_dev l (Nnorm O nil (PEmul (num nfe2) (denum nfe1))) -> PCond l (condition nfe1 ++ condition nfe2) -> FEeval l fe1 == FEeval l fe2. Proof. intros l fe1 fe2 nfe1 nfe2 eq1 eq2 Hcrossprod Hcond; subst nfe1 nfe2. apply Fnorm_crossproduct; trivial. -rewrite (Pphi_dev_gen_ok Rsth Reqe ARth CRmorph) in |- *. -rewrite (Pphi_dev_gen_ok Rsth Reqe ARth CRmorph) in |- *. +match goal with + [ |- NPEeval l ?x == NPEeval l ?y] => + rewrite (ring_rw_correct Rsth Reqe ARth CRmorph pow_th get_sign_spec + O nil l I (refl_equal nil) x (refl_equal (Nnorm O nil x))); + rewrite (ring_rw_correct Rsth Reqe ARth CRmorph pow_th get_sign_spec + O nil l I (refl_equal nil) y (refl_equal (Nnorm O nil y))) + end. trivial. Qed. Theorem Field_simplify_eq_correct : - forall l fe1 fe2, + forall n l lpe fe1 fe2, + Ninterp_PElist l lpe -> + forall lmp, Nmk_monpol_list lpe = lmp -> forall nfe1, Fnorm fe1 = nfe1 -> forall nfe2, Fnorm fe2 = nfe2 -> forall den, split (denum nfe1) (denum nfe2) = den -> - NPphi_dev l (Nnorm (PEmul (num nfe1) (right den))) == - NPphi_dev l (Nnorm (PEmul (num nfe2) (left den))) -> + NPphi_dev l (Nnorm n lmp (PEmul (num nfe1) (right den))) == + NPphi_dev l (Nnorm n lmp (PEmul (num nfe2) (left den))) -> PCond l (condition nfe1 ++ condition nfe2) -> FEeval l fe1 == FEeval l fe2. Proof. -intros l fe1 fe2 nfe1 eq1 nfe2 eq2 den eq3 Hcrossprod Hcond; - subst nfe1 nfe2 den. +intros n l lpe fe1 fe2 Hlpe lmp Hlmp nfe1 eq1 nfe2 eq2 den eq3 Hcrossprod Hcond; + subst nfe1 nfe2 den lmp. apply Fnorm_crossproduct; trivial. simpl in |- *. -elim (split_correct l (denum (Fnorm fe1)) (denum (Fnorm fe2))); intros. -rewrite H in |- *. -rewrite H0 in |- *. -clear H H0. +rewrite (split_correct_l l (denum (Fnorm fe1)) (denum (Fnorm fe2))) in |- *. +rewrite (split_correct_r l (denum (Fnorm fe1)) (denum (Fnorm fe2))) in |- *. rewrite NPEmul_correct in |- *. rewrite NPEmul_correct in |- *. simpl in |- *. repeat rewrite (ARmul_assoc ARth) in |- *. -rewrite <- (Pphi_dev_gen_ok Rsth Reqe ARth CRmorph) in Hcrossprod. -rewrite <- (Pphi_dev_gen_ok Rsth Reqe ARth CRmorph) in Hcrossprod. +rewrite <-( + let x := PEmul (num (Fnorm fe1)) + (rsplit_right (split (denum (Fnorm fe1)) (denum (Fnorm fe2)))) in +ring_rw_correct Rsth Reqe ARth CRmorph pow_th get_sign_spec n lpe l + Hlpe (refl_equal (Nmk_monpol_list lpe)) + x (refl_equal (Nnorm n (Nmk_monpol_list lpe) x))) in Hcrossprod. +rewrite <-( + let x := (PEmul (num (Fnorm fe2)) + (rsplit_left + (split (denum (Fnorm fe1)) (denum (Fnorm fe2))))) in + ring_rw_correct Rsth Reqe ARth CRmorph pow_th get_sign_spec n lpe l + Hlpe (refl_equal (Nmk_monpol_list lpe)) + x (refl_equal (Nnorm n (Nmk_monpol_list lpe) x))) in Hcrossprod. simpl in Hcrossprod. rewrite Hcrossprod in |- *. reflexivity. Qed. +Theorem Field_simplify_eq_pow_correct : + forall n l lpe fe1 fe2, + Ninterp_PElist l lpe -> + forall lmp, Nmk_monpol_list lpe = lmp -> + forall nfe1, Fnorm fe1 = nfe1 -> + forall nfe2, Fnorm fe2 = nfe2 -> + forall den, split (denum nfe1) (denum nfe2) = den -> + NPphi_pow l (Nnorm n lmp (PEmul (num nfe1) (right den))) == + NPphi_pow l (Nnorm n lmp (PEmul (num nfe2) (left den))) -> + PCond l (condition nfe1 ++ condition nfe2) -> + FEeval l fe1 == FEeval l fe2. +Proof. +intros n l lpe fe1 fe2 Hlpe lmp Hlmp nfe1 eq1 nfe2 eq2 den eq3 Hcrossprod Hcond; + subst nfe1 nfe2 den lmp. +apply Fnorm_crossproduct; trivial. +simpl in |- *. +rewrite (split_correct_l l (denum (Fnorm fe1)) (denum (Fnorm fe2))) in |- *. +rewrite (split_correct_r l (denum (Fnorm fe1)) (denum (Fnorm fe2))) in |- *. +rewrite NPEmul_correct in |- *. +rewrite NPEmul_correct in |- *. +simpl in |- *. +repeat rewrite (ARmul_assoc ARth) in |- *. +rewrite <-( + let x := PEmul (num (Fnorm fe1)) + (rsplit_right (split (denum (Fnorm fe1)) (denum (Fnorm fe2)))) in +ring_rw_pow_correct Rsth Reqe ARth CRmorph pow_th get_sign_spec n lpe l + Hlpe (refl_equal (Nmk_monpol_list lpe)) + x (refl_equal (Nnorm n (Nmk_monpol_list lpe) x))) in Hcrossprod. +rewrite <-( + let x := (PEmul (num (Fnorm fe2)) + (rsplit_left + (split (denum (Fnorm fe1)) (denum (Fnorm fe2))))) in + ring_rw_pow_correct Rsth Reqe ARth CRmorph pow_th get_sign_spec n lpe l + Hlpe (refl_equal (Nmk_monpol_list lpe)) + x (refl_equal (Nnorm n (Nmk_monpol_list lpe) x))) in Hcrossprod. +simpl in Hcrossprod. +rewrite Hcrossprod in |- *. +reflexivity. +Qed. + +Theorem Field_simplify_eq_pow_in_correct : + forall n l lpe fe1 fe2, + Ninterp_PElist l lpe -> + forall lmp, Nmk_monpol_list lpe = lmp -> + forall nfe1, Fnorm fe1 = nfe1 -> + forall nfe2, Fnorm fe2 = nfe2 -> + forall den, split (denum nfe1) (denum nfe2) = den -> + forall np1, Nnorm n lmp (PEmul (num nfe1) (right den)) = np1 -> + forall np2, Nnorm n lmp (PEmul (num nfe2) (left den)) = np2 -> + FEeval l fe1 == FEeval l fe2 -> + PCond l (condition nfe1 ++ condition nfe2) -> + NPphi_pow l np1 == + NPphi_pow l np2. +Proof. + intros. subst nfe1 nfe2 lmp np1 np2. + repeat rewrite (Pphi_pow_ok Rsth Reqe ARth CRmorph pow_th get_sign_spec). + repeat (rewrite <- (norm_subst_ok Rsth Reqe ARth CRmorph pow_th);trivial). simpl. + assert (N1 := Pcond_Fnorm _ _ (PCond_app_inv_l _ _ _ H7)). + assert (N2 := Pcond_Fnorm _ _ (PCond_app_inv_r _ _ _ H7)). + apply (@rmul_reg_l (NPEeval l (rsplit_common den))). + intro Heq;apply N1. + rewrite (split_correct_l l (denum (Fnorm fe1)) (denum (Fnorm fe2))). + rewrite H3. rewrite NPEmul_correct. simpl. ring [Heq]. + repeat rewrite (ARth.(ARmul_comm) (NPEeval l (rsplit_common den))). + repeat rewrite <- ARth.(ARmul_assoc). + change (NPEeval l (rsplit_right den) * NPEeval l (rsplit_common den)) with + (NPEeval l (PEmul (rsplit_right den) (rsplit_common den))). + change (NPEeval l (rsplit_left den) * NPEeval l (rsplit_common den)) with + (NPEeval l (PEmul (rsplit_left den) (rsplit_common den))). + repeat rewrite <- NPEmul_correct. rewrite <- H3. rewrite <- split_correct_l. + rewrite <- split_correct_r. + apply (@rmul_reg_l (/NPEeval l (denum (Fnorm fe2)))). + intro Heq; apply AFth.(AF_1_neq_0). + rewrite <- (@AFinv_l AFth (NPEeval l (denum (Fnorm fe2))));trivial. + ring [Heq]. rewrite (ARth.(ARmul_comm) (/ NPEeval l (denum (Fnorm fe2)))). + repeat rewrite <- (ARth.(ARmul_assoc)). + rewrite <- (AFth.(AFdiv_def)). rewrite rdiv_r_r. trivial. + apply (@rmul_reg_l (/NPEeval l (denum (Fnorm fe1)))). + intro Heq; apply AFth.(AF_1_neq_0). + rewrite <- (@AFinv_l AFth (NPEeval l (denum (Fnorm fe1))));trivial. + ring [Heq]. repeat rewrite (ARth.(ARmul_comm) (/ NPEeval l (denum (Fnorm fe1)))). + repeat rewrite <- (ARth.(ARmul_assoc)). + repeat rewrite <- (AFth.(AFdiv_def)). rewrite rdiv_r_r. trivial. + rewrite (AFth.(AFdiv_def)). ring_simplify. unfold SRopp. + rewrite (ARth.(ARmul_comm) (/ NPEeval l (denum (Fnorm fe2)))). + repeat rewrite <- (AFth.(AFdiv_def)). + repeat rewrite <- Fnorm_FEeval_PEeval;trivial. + apply (PCond_app_inv_l _ _ _ H7). apply (PCond_app_inv_r _ _ _ H7). +Qed. + +Theorem Field_simplify_eq_in_correct : +forall n l lpe fe1 fe2, + Ninterp_PElist l lpe -> + forall lmp, Nmk_monpol_list lpe = lmp -> + forall nfe1, Fnorm fe1 = nfe1 -> + forall nfe2, Fnorm fe2 = nfe2 -> + forall den, split (denum nfe1) (denum nfe2) = den -> + forall np1, Nnorm n lmp (PEmul (num nfe1) (right den)) = np1 -> + forall np2, Nnorm n lmp (PEmul (num nfe2) (left den)) = np2 -> + FEeval l fe1 == FEeval l fe2 -> + PCond l (condition nfe1 ++ condition nfe2) -> + NPphi_dev l np1 == + NPphi_dev l np2. +Proof. + intros. subst nfe1 nfe2 lmp np1 np2. + repeat rewrite (Pphi_dev_ok Rsth Reqe ARth CRmorph get_sign_spec). + repeat (rewrite <- (norm_subst_ok Rsth Reqe ARth CRmorph pow_th);trivial). simpl. + assert (N1 := Pcond_Fnorm _ _ (PCond_app_inv_l _ _ _ H7)). + assert (N2 := Pcond_Fnorm _ _ (PCond_app_inv_r _ _ _ H7)). + apply (@rmul_reg_l (NPEeval l (rsplit_common den))). + intro Heq;apply N1. + rewrite (split_correct_l l (denum (Fnorm fe1)) (denum (Fnorm fe2))). + rewrite H3. rewrite NPEmul_correct. simpl. ring [Heq]. + repeat rewrite (ARth.(ARmul_comm) (NPEeval l (rsplit_common den))). + repeat rewrite <- ARth.(ARmul_assoc). + change (NPEeval l (rsplit_right den) * NPEeval l (rsplit_common den)) with + (NPEeval l (PEmul (rsplit_right den) (rsplit_common den))). + change (NPEeval l (rsplit_left den) * NPEeval l (rsplit_common den)) with + (NPEeval l (PEmul (rsplit_left den) (rsplit_common den))). + repeat rewrite <- NPEmul_correct;rewrite <- H3. rewrite <- split_correct_l. + rewrite <- split_correct_r. + apply (@rmul_reg_l (/NPEeval l (denum (Fnorm fe2)))). + intro Heq; apply AFth.(AF_1_neq_0). + rewrite <- (@AFinv_l AFth (NPEeval l (denum (Fnorm fe2))));trivial. + ring [Heq]. rewrite (ARth.(ARmul_comm) (/ NPEeval l (denum (Fnorm fe2)))). + repeat rewrite <- (ARth.(ARmul_assoc)). + rewrite <- (AFth.(AFdiv_def)). rewrite rdiv_r_r. trivial. + apply (@rmul_reg_l (/NPEeval l (denum (Fnorm fe1)))). + intro Heq; apply AFth.(AF_1_neq_0). + rewrite <- (@AFinv_l AFth (NPEeval l (denum (Fnorm fe1))));trivial. + ring [Heq]. repeat rewrite (ARth.(ARmul_comm) (/ NPEeval l (denum (Fnorm fe1)))). + repeat rewrite <- (ARth.(ARmul_assoc)). + repeat rewrite <- (AFth.(AFdiv_def)). rewrite rdiv_r_r. trivial. + rewrite (AFth.(AFdiv_def)). ring_simplify. unfold SRopp. + rewrite (ARth.(ARmul_comm) (/ NPEeval l (denum (Fnorm fe2)))). + repeat rewrite <- (AFth.(AFdiv_def)). + repeat rewrite <- Fnorm_FEeval_PEeval;trivial. + apply (PCond_app_inv_l _ _ _ H7). apply (PCond_app_inv_r _ _ _ H7). +Qed. + + Section Fcons_impl. Variable Fcons : PExpr C -> list (PExpr C) -> list (PExpr C). @@ -1100,7 +1516,7 @@ Fixpoint Fcons0 (e:PExpr C) (l:list (PExpr C)) {struct l} : list (PExpr C) := match l with nil => cons e nil | cons a l1 => - if Peq ceqb (Nnorm e) (Nnorm a) then l else cons a (Fcons0 e l1) + if Peq ceqb (Nnorm O nil e) (Nnorm O nil a) then l else cons a (Fcons0 e l1) end. Theorem PFcons0_fcons_inv: @@ -1108,8 +1524,8 @@ Theorem PFcons0_fcons_inv: intros l a l1; elim l1; simpl Fcons0; auto. simpl; auto. intros a0 l0. -generalize (ring_correct Rsth Reqe ARth CRmorph l a a0); - case (Peq ceqb (Nnorm a) (Nnorm a0)). +generalize (ring_correct Rsth Reqe ARth CRmorph pow_th O l nil a a0). simpl. + case (Peq ceqb (Nnorm O nil a) (Nnorm O nil a0)). intros H H0 H1; split; auto. rewrite H; auto. generalize (PCond_cons_inv_l _ _ _ H1); simpl; auto. @@ -1125,6 +1541,7 @@ Qed. Fixpoint Fcons00 (e:PExpr C) (l:list (PExpr C)) {struct e} : list (PExpr C) := match e with PEmul e1 e2 => Fcons00 e1 (Fcons00 e2 l) + | PEpow e1 _ => Fcons00 e1 l | _ => Fcons0 e l end. @@ -1137,9 +1554,12 @@ intros l a; elim a; try (intros; apply PFcons0_fcons_inv; auto; fail). case (H0 _ H3); intros H4 H5; split; auto. simpl in |- *. apply field_is_integral_domain; trivial. + simpl;intros. rewrite pow_th.(rpow_pow_N). + destruct (H _ H0);split;auto. + destruct n;simpl. apply AFth.(AF_1_neq_0). + apply pow_pos_not_0;trivial. Qed. - Definition Pcond_simpl_gen := fcons_correct _ PFcons00_fcons_inv. @@ -1167,6 +1587,7 @@ Qed. Fixpoint Fcons1 (e:PExpr C) (l:list (PExpr C)) {struct e} : list (PExpr C) := match e with PEmul e1 e2 => Fcons1 e1 (Fcons1 e2 l) + | PEpow e _ => Fcons1 e l | PEopp e => if ceqb (copp cI) cO then absurd_PCond else Fcons1 e l | PEc c => if ceqb c cO then absurd_PCond else l | _ => Fcons0 e l @@ -1196,6 +1617,9 @@ intros l a; elim a; try (intros; apply PFcons0_fcons_inv; auto; fail). rewrite (morph1 CRmorph) in H0. rewrite (morph0 CRmorph) in H0. trivial. + intros;simpl. destruct (H _ H0);split;trivial. + rewrite pow_th.(rpow_pow_N). destruct n;simpl. + apply AFth.(AF_1_neq_0). apply pow_pos_not_0;trivial. Qed. Definition Fcons2 e l := Fcons1 (PExpr_simp e) l. @@ -1214,30 +1638,6 @@ Definition Pcond_simpl_complete := End Fcons_simpl. -Let Mpc := MPcond_map cO cI cadd cmul csub copp ceqb. -Let Mp := MPcond_dev rO rI radd rmul req cO cI ceqb phi. -Let Subst := PNSubstL cO cI cadd cmul ceqb. - -(* simplification + rewriting *) -Theorem Field_subst_correct : -forall l ul fe m n, - PCond l (Fapp Fcons00 (condition (Fnorm fe)) nil) -> - Mp (Mpc ul) l -> - Peq ceqb (Subst (Nnorm (num (Fnorm fe))) (Mpc ul) m n) (Pc cO) = true -> - FEeval l fe == 0. -intros l ul fe m n H H1 H2. -assert (H3 := (Pcond_simpl_gen _ _ H)). -apply eq_trans with (1 := Fnorm_FEeval_PEeval l fe - (Pcond_simpl_gen _ _ H)). -apply rdiv8; auto. -rewrite (PNSubstL_dev_ok Rsth Reqe ARth CRmorph m n - _ (num (Fnorm fe)) l H1). -rewrite <-(Ring_polynom.Pphi_Pphi_dev Rsth Reqe ARth CRmorph). -rewrite (fun x => Peq_ok Rsth Reqe CRmorph x (Pc cO)); auto. -simpl; apply (morph0 CRmorph); auto. -Qed. - - End AlmostField. Section FieldAndSemiField. @@ -1457,4 +1857,3 @@ Qed. End Field. End Complete. - diff --git a/contrib/setoid_ring/InitialRing.v b/contrib/setoid_ring/InitialRing.v index 7df68cc0..bbdcd443 100644 --- a/contrib/setoid_ring/InitialRing.v +++ b/contrib/setoid_ring/InitialRing.v @@ -7,16 +7,21 @@ (************************************************************************) Require Import ZArith_base. +Require Import Zpow_def. Require Import BinInt. Require Import BinNat. Require Import Setoid. Require Import Ring_theory. -Require Import Ring_tac. Require Import Ring_polynom. + Set Implicit Arguments. Import RingSyntax. + +(* An object to return when an expression is not recognized as a constant *) +Definition NotConstant := false. + (** Z is a ring and a setoid*) Lemma Zsth : Setoid_Theory Z (@eq Z). @@ -88,6 +93,21 @@ Section ZMORPHISM. | Zneg p => -(gen_phiPOS p) end. Notation "[ x ]" := (gen_phiZ x). + + Definition get_signZ z := + match z with + | Zneg p => Some (Zpos p) + | _ => None + end. + + Lemma get_signZ_th : sign_theory ropp req gen_phiZ get_signZ. + Proof. + constructor. + destruct c;intros;try discriminate. + injection H;clear H;intros H1;subst c'. + simpl;rrefl. + Qed. + Section ALMOST_RING. Variable ARth : almost_ring_theory 0 1 radd rmul rsub ropp req. @@ -346,7 +366,8 @@ Section NMORPHISM. End NMORPHISM. (* syntaxification of constants in an abstract ring: - the inverse of gen_phiPOS *) + the inverse of gen_phiPOS + Why we do not reconnize only rI ?????? *) Ltac inv_gen_phi_pos rI add mul t := let rec inv_cst t := match t with @@ -396,65 +417,8 @@ End NMORPHISM. end end. -(* coefs = Z (abstract ring) *) -Module Zpol. - -Definition ring_gen_correct - R rO rI radd rmul rsub ropp req rSet req_th Rth := - @ring_correct R rO rI radd rmul rsub ropp req rSet req_th - (Rth_ARth rSet req_th Rth) - Z 0%Z 1%Z Zplus Zmult Zminus Zopp Zeq_bool - (@gen_phiZ R rO rI radd rmul ropp) - (gen_phiZ_morph rSet req_th Rth). - -Definition ring_rw_gen_correct - R rO rI radd rmul rsub ropp req rSet req_th Rth := - @Pphi_dev_ok R rO rI radd rmul rsub ropp req rSet req_th - (Rth_ARth rSet req_th Rth) - Z 0%Z 1%Z Zplus Zmult Zminus Zopp Zeq_bool - (@gen_phiZ R rO rI radd rmul ropp) - (gen_phiZ_morph rSet req_th Rth). - -Definition ring_gen_eq_correct R rO rI radd rmul rsub ropp Rth := - @ring_gen_correct - R rO rI radd rmul rsub ropp (@eq R) (Eqsth R) (Eq_ext _ _ _) Rth. - -Definition ring_rw_gen_eq_correct R rO rI radd rmul rsub ropp Rth := - @ring_rw_gen_correct - R rO rI radd rmul rsub ropp (@eq R) (Eqsth R) (Eq_ext _ _ _) Rth. - -End Zpol. - -(* coefs = N (abstract semi-ring) *) -Module Npol. - -Definition ring_gen_correct - R rO rI radd rmul req rSet req_th SRth := - @ring_correct R rO rI radd rmul (SRsub radd) (@SRopp R) req rSet - (SReqe_Reqe req_th) - (SRth_ARth rSet SRth) - N 0%N 1%N Nplus Nmult (SRsub Nplus) (@SRopp N) Neq_bool - (@gen_phiN R rO rI radd rmul) - (gen_phiN_morph rSet req_th SRth). - -Definition ring_rw_gen_correct - R rO rI radd rmul req rSet req_th SRth := - @Pphi_dev_ok R rO rI radd rmul (SRsub radd) (@SRopp R) req rSet - (SReqe_Reqe req_th) - (SRth_ARth rSet SRth) - N 0%N 1%N Nplus Nmult (SRsub Nplus) (@SRopp N) Neq_bool - (@gen_phiN R rO rI radd rmul) - (gen_phiN_morph rSet req_th SRth). - -Definition ring_gen_eq_correct R rO rI radd rmul SRth := - @ring_gen_correct - R rO rI radd rmul (@eq R) (Eqsth R) (Eq_s_ext _ _) SRth. - -Definition ring_rw_gen_eq_correct' R rO rI radd rmul SRth := - @ring_rw_gen_correct - R rO rI radd rmul (@eq R) (Eqsth R) (Eq_s_ext _ _) SRth. - -End Npol. +(* A simpl tactic reconninzing nothing *) + Ltac inv_morph_nothing t := constr:(NotConstant). Ltac coerce_to_almost_ring set ext rspec := @@ -481,7 +445,47 @@ Ltac abstract_ring_morphism set ext rspec := | _ => fail 1 "bad ring structure" end. -Ltac ring_elements set ext rspec rk := +Record hypo : Type := mkhypo { + hypo_type : Type; + hypo_proof : hypo_type + }. + +Ltac gen_ring_pow set arth pspec := + match pspec with + | None => + match type of arth with + | @almost_ring_theory ?R ?rO ?rI ?radd ?rmul ?rsub ?ropp ?req => + constr:(mkhypo (@pow_N_th R rI rmul req set)) + | _ => fail 1 "gen_ring_pow" + end + | Some ?t => constr:(t) + end. + +Ltac default_sign_spec morph := + match type of morph with + | @ring_morph ?R ?r0 ?rI ?radd ?rmul ?rsub ?ropp ?req + ?C ?c0 ?c1 ?cadd ?cmul ?csub ?copp ?ceq_b ?phi => + constr:(mkhypo (@get_sign_None_th R ropp req C phi)) + | _ => fail 1 "ring anomaly : default_sign_spec" + end. + +Ltac gen_ring_sign set rspec morph sspec rk := + match sspec with + | None => + match rk with + | Abstract => + match type of rspec with + | @ring_theory ?R ?rO ?rI ?radd ?rmul ?rsub ?ropp ?req => + constr:(mkhypo (@get_signZ_th R rO rI radd rmul ropp req set)) + | _ => default_sign_spec morph + end + | _ => default_sign_spec morph + end + | Some ?t => constr:(t) + end. + + +Ltac ring_elements set ext rspec pspec sspec rk := let arth := coerce_to_almost_ring set ext rspec in let ext_r := coerce_to_ring_ext ext in let morph := @@ -493,19 +497,85 @@ Ltac ring_elements set ext rspec rk := constr:(IDmorph rO rI add mul sub opp set _ reqb_ok) | _ => fail 2 "ring anomaly" end - | @Morphism ?m => m + | @Morphism ?m => + match type of m with + | ring_morph _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ => m + | @semi_morph _ _ _ _ _ _ _ _ _ _ _ _ _ => + constr:(SRmorph_Rmorph set m) + | _ => fail 2 " ici" + end | _ => fail 1 "ill-formed ring kind" end in - fun f => f arth ext_r morph. + let p_spec := gen_ring_pow set arth pspec in + let s_spec := gen_ring_sign set rspec morph sspec rk in + fun f => f arth ext_r morph p_spec s_spec. (* Given a ring structure and the kind of morphism, returns 2 lemmas (one for ring, and one for ring_simplify). *) +Ltac ring_lemmas set ext rspec pspec sspec rk := + let gen_lemma2 := + match pspec with + | None => constr:(ring_rw_correct) + | Some _ => constr:(ring_rw_pow_correct) + end in + ring_elements set ext rspec pspec sspec rk + ltac:(fun arth ext_r morph p_spec s_spec => + match p_spec with + | mkhypo ?pp_spec => + match s_spec with + | mkhypo ?ps_spec => + let lemma1 := + constr:(ring_correct set ext_r arth morph pp_spec) in + let lemma2 := + constr:(gen_lemma2 _ _ _ _ _ _ _ _ set ext_r arth + _ _ _ _ _ _ _ _ _ morph + _ _ _ pp_spec + _ ps_spec) in + fun f => f arth ext_r morph lemma1 lemma2 + | _ => fail 2 "bad sign specification" + end + | _ => fail 1 "bad power specification" + end). + +(* Tactic for constant *) +Ltac isnatcst t := + match t with + O => true + | S ?p => isnatcst p + | _ => false + end. + +Ltac isPcst t := + match t with + | xI ?p => isPcst p + | xO ?p => isPcst p + | xH => constr:true + (* nat -> positive *) + | P_of_succ_nat ?n => isnatcst n + | _ => false + end. + +Ltac isNcst t := + match t with + N0 => constr:true + | Npos ?p => isPcst p + | _ => constr:false + end. + +Ltac isZcst t := + match t with + Z0 => true + | Zpos ?p => isPcst p + | Zneg ?p => isPcst p + (* injection nat -> Z *) + | Z_of_nat ?n => isnatcst n + (* injection N -> Z *) + | Z_of_N ?n => isNcst n + (* *) + | _ => false + end. + + -Ltac ring_lemmas set ext rspec rk := - ring_elements set ext rspec rk - ltac:(fun arth ext_r morph => - let lemma1 := constr:(ring_correct set ext_r arth morph) in - let lemma2 := constr:(Pphi_dev_ok set ext_r arth morph) in - fun f => f arth ext_r morph lemma1 lemma2). diff --git a/contrib/setoid_ring/NArithRing.v b/contrib/setoid_ring/NArithRing.v index 33e3cb4e..ae067a8a 100644 --- a/contrib/setoid_ring/NArithRing.v +++ b/contrib/setoid_ring/NArithRing.v @@ -12,16 +12,6 @@ Import InitialRing. Set Implicit Arguments. -Ltac isNcst t := - let t := eval hnf in t in - match t with - N0 => constr:true - | Npos ?p => isNcst p - | xI ?p => isNcst p - | xO ?p => isNcst p - | xH => constr:true - | _ => constr:false - end. Ltac Ncst t := match isNcst t with true => t diff --git a/contrib/setoid_ring/RealField.v b/contrib/setoid_ring/RealField.v index 13896123..d0512dff 100644 --- a/contrib/setoid_ring/RealField.v +++ b/contrib/setoid_ring/RealField.v @@ -1,6 +1,9 @@ -Require Import Raxioms. -Require Import Rdefinitions. +Require Import Nnat. +Require Import ArithRing. Require Export Ring Field. +Require Import Rdefinitions. +Require Import Rpow_def. +Require Import Raxioms. Open Local Scope R_scope. @@ -102,4 +105,29 @@ Lemma Zeq_bool_complete : forall x y, Zeq_bool x y = true. Proof gen_phiZ_complete Rset Rext Rfield Rgen_phiPOS_not_0. -Add Field RField : Rfield (infinite Zeq_bool_complete). +Lemma Rdef_pow_add : forall (x:R) (n m:nat), pow x (n + m) = pow x n * pow x m. +Proof. + intros x n; elim n; simpl in |- *; auto with real. + intros n0 H' m; rewrite H'; auto with real. +Qed. + +Lemma R_power_theory : power_theory 1%R Rmult (eq (A:=R)) nat_of_N pow. +Proof. + constructor. destruct n. reflexivity. + simpl. induction p;simpl. + rewrite ZL6. rewrite Rdef_pow_add;rewrite IHp. reflexivity. + unfold nat_of_P;simpl;rewrite ZL6;rewrite Rdef_pow_add;rewrite IHp;trivial. + rewrite Rmult_comm;apply Rmult_1_l. +Qed. + +Ltac Rpow_tac t := + match isnatcst t with + | false => constr:(InitialRing.NotConstant) + | _ => constr:(N_of_nat t) + end. + +Add Field RField : Rfield + (completeness Zeq_bool_complete, power_tac R_power_theory [Rpow_tac]). + + + diff --git a/contrib/setoid_ring/Ring.v b/contrib/setoid_ring/Ring.v index 167e026f..1a4e1cc7 100644 --- a/contrib/setoid_ring/Ring.v +++ b/contrib/setoid_ring/Ring.v @@ -9,6 +9,7 @@ Require Import Bool. Require Export Ring_theory. Require Export Ring_base. +Require Export InitialRing. Require Export Ring_tac. Lemma BoolTheory : @@ -25,7 +26,7 @@ reflexivity. destruct x; reflexivity. Qed. -Unboxed Definition bool_eq (b1 b2:bool) := +Definition bool_eq (b1 b2:bool) := if b1 then b2 else negb b2. Lemma bool_eq_ok : forall b1 b2, bool_eq b1 b2 = true -> b1 = b2. diff --git a/contrib/setoid_ring/Ring_polynom.v b/contrib/setoid_ring/Ring_polynom.v index 7317ab21..b79f2fe2 100644 --- a/contrib/setoid_ring/Ring_polynom.v +++ b/contrib/setoid_ring/Ring_polynom.v @@ -1,5 +1,5 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) +(* V * The Coq Proof Assistant / The Coq Development Team *) (* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) @@ -10,9 +10,11 @@ Set Implicit Arguments. Require Import Setoid. Require Import BinList. Require Import BinPos. +Require Import BinNat. Require Import BinInt. Require Export Ring_theory. +Open Local Scope positive_scope. Import RingSyntax. Section MakeRingPol. @@ -35,6 +37,12 @@ Section MakeRingPol. Variable CRmorph : ring_morph rO rI radd rmul rsub ropp req cO cI cadd cmul csub copp ceqb phi. + (* Power coefficients *) + Variable Cpow : Set. + Variable Cp_phi : N -> Cpow. + Variable rpow : R -> Cpow -> R. + Variable pow_th : power_theory rI rmul req Cp_phi rpow. + (* R notations *) Notation "0" := rO. Notation "1" := rI. @@ -113,12 +121,23 @@ Section MakeRingPol. | _ => Pinj j P end. + Definition mkPinj_pred j P:= + match j with + | xH => P + | xO j => Pinj (Pdouble_minus_one j) P + | xI j => Pinj (xO j) P + end. + Definition mkPX P i Q := match P with | Pc c => if c ?=! cO then mkPinj xH Q else PX P i Q | Pinj _ _ => PX P i Q | PX P' i' Q' => if Q' ?== P0 then PX P' (i' + i) Q else PX P i Q end. + + Definition mkXi i := PX P1 i P0. + + Definition mkX := mkXi 1. (** Opposite of addition *) @@ -305,7 +324,34 @@ Section MakeRingPol. end. End PmulI. +(* A symmetric version of the multiplication *) + Fixpoint Pmul (P P'' : Pol) {struct P''} : Pol := + match P'' with + | Pc c => PmulC P c + | Pinj j' Q' => PmulI Pmul Q' j' P + | PX P' i' Q' => + match P with + | Pc c => PmulC P'' c + | Pinj j Q => + let QQ' := + match j with + | xH => Pmul Q Q' + | xO j => Pmul (Pinj (Pdouble_minus_one j) Q) Q' + | xI j => Pmul (Pinj (xO j) Q) Q' + end in + mkPX (Pmul P P') i' QQ' + | PX P i Q=> + let QQ' := Pmul Q Q' in + let PQ' := PmulI Pmul Q' xH P in + let QP' := Pmul (mkPinj xH Q) P' in + let PP' := Pmul P P' in + (mkPX (mkPX PP' i P0 ++ QP') i' P0) ++ mkPX PQ' i QQ' + end + end. + +(* Non symmetric *) +(* Fixpoint Pmul_aux (P P' : Pol) {struct P'} : Pol := match P' with | Pc c' => PmulC P c' @@ -319,10 +365,21 @@ Section MakeRingPol. | Pc c => PmulC P' c | Pinj j Q => PmulI Pmul_aux Q j P' | PX P i Q => - Padd (mkPX (Pmul_aux P P') i P0) (PmulI Pmul_aux Q xH P') + (mkPX (Pmul_aux P P') i P0) ++ (PmulI Pmul_aux Q xH P') end. +*) Notation "P ** P'" := (Pmul P P'). - + + Fixpoint Psquare (P:Pol) : Pol := + match P with + | Pc c => Pc (c *! c) + | Pinj j Q => Pinj j (Psquare Q) + | PX P i Q => + let twoPQ := Pmul P (mkPinj xH (PmulC Q (cI +! cI))) in + let Q2 := Psquare Q in + let P2 := Psquare P in + mkPX (mkPX P2 i P0 ++ twoPQ) i Q2 + end. (** Monomial **) @@ -331,29 +388,29 @@ Section MakeRingPol. | zmon: positive -> Mon -> Mon | vmon: positive -> Mon -> Mon. - Fixpoint pow (x:R) (i:positive) {struct i}: R := - match i with - | xH => x - | xO i => let p := pow x i in p * p - | xI i => let p := pow x i in x * p * p - end. - Fixpoint Mphi(l:list R) (M: Mon) {struct M} : R := match M with mon0 => rI | zmon j M1 => Mphi (jump j l) M1 | vmon i M1 => let x := hd 0 l in - let xi := pow x i in + let xi := pow_pos rmul x i in (Mphi (tail l) M1) * xi end. - Definition zmon_pred j M := - match j with xH => M | _ => zmon (Ppred j) M end. - Definition mkZmon j M := match M with mon0 => mon0 | _ => zmon j M end. + Definition zmon_pred j M := + match j with xH => M | _ => mkZmon (Ppred j) M end. + + Definition mkVmon i M := + match M with + | mon0 => vmon i mon0 + | zmon j m => vmon i (zmon_pred j m) + | vmon i' m => vmon (i+i') m + end. + Fixpoint MFactor (P: Pol) (M: Mon) {struct P}: Pol * Pol := match P, M with _, mon0 => (Pc cO, P) @@ -434,7 +491,7 @@ Section MakeRingPol. | Pinj j Q => Pphi (jump j l) Q | PX P i Q => let x := hd 0 l in - let xi := pow x i in + let xi := pow_pos rmul x i in (Pphi l P) * xi + (Pphi (tail l) Q) end. @@ -469,26 +526,6 @@ Section MakeRingPol. rewrite Psucc_o_double_minus_one_eq_xO;trivial. simpl;trivial. Qed. - - Lemma pow_Psucc : forall x j, pow x (Psucc j) == x * pow x j. - Proof. - induction j;simpl;rsimpl. - rewrite IHj;rsimpl;mul_push x;rrefl. - Qed. - - Lemma pow_Pplus : forall x i j, pow x (i + j) == pow x i * pow x j. - Proof. - intro x;induction i;intros. - rewrite xI_succ_xO;rewrite Pplus_one_succ_r. - rewrite <- Pplus_diag;repeat rewrite <- Pplus_assoc. - repeat rewrite IHi. - rewrite Pplus_comm;rewrite <- Pplus_one_succ_r;rewrite pow_Psucc. - simpl;rsimpl. - rewrite <- Pplus_diag;repeat rewrite <- Pplus_assoc. - repeat rewrite IHi;rsimpl. - rewrite Pplus_comm;rewrite <- Pplus_one_succ_r;rewrite pow_Psucc; - simpl;rsimpl. - Qed. Lemma Peq_ok : forall P P', (P ?== P') = true -> forall l, P@l == P'@ l. @@ -523,8 +560,11 @@ Section MakeRingPol. rewrite <-jump_Pplus;rewrite Pplus_comm;rrefl. Qed. + Let pow_pos_Pplus := + pow_pos_Pplus rmul Rsth Reqe.(Rmul_ext) ARth.(ARmul_comm) ARth.(ARmul_assoc). + Lemma mkPX_ok : forall l P i Q, - (mkPX P i Q)@l == P@l*(pow (hd 0 l) i) + Q@(tail l). + (mkPX P i Q)@l == P@l*(pow_pos rmul (hd 0 l) i) + Q@(tail l). Proof. intros l P i Q;unfold mkPX. destruct P;try (simpl;rrefl). @@ -533,7 +573,7 @@ Section MakeRingPol. rewrite mkPinj_ok;rsimpl;simpl;rrefl. assert (H := @Peq_ok P3 P0);destruct (P3 ?== P0);simpl;try rrefl. rewrite (H (refl_equal true));trivial. - rewrite Pphi0;rewrite pow_Pplus;rsimpl. + rewrite Pphi0. rewrite pow_pos_Pplus;rsimpl. Qed. Ltac Esimpl := @@ -622,19 +662,19 @@ Section MakeRingPol. Esimpl2;add_push [c];rrefl. destruct p0;simpl;Esimpl2. rewrite IHP'2;simpl. - rsimpl;add_push (P'1@l * (pow (hd 0 l) p));rrefl. + rsimpl;add_push (P'1@l * (pow_pos rmul (hd 0 l) p));rrefl. rewrite IHP'2;simpl. - rewrite jump_Pdouble_minus_one;rsimpl;add_push (P'1@l * (pow (hd 0 l) p));rrefl. + rewrite jump_Pdouble_minus_one;rsimpl;add_push (P'1@l * (pow_pos rmul (hd 0 l) p));rrefl. rewrite IHP'2;rsimpl. add_push (P @ (tail l));rrefl. assert (H := ZPminus_spec p0 p);destruct (ZPminus p0 p);Esimpl2. rewrite IHP'1;rewrite IHP'2;rsimpl. add_push (P3 @ (tail l));rewrite H;rrefl. rewrite IHP'1;rewrite IHP'2;simpl;Esimpl. rewrite H;rewrite Pplus_comm. - rewrite pow_Pplus;rsimpl. + rewrite pow_pos_Pplus;rsimpl. add_push (P3 @ (tail l));rrefl. assert (forall P k l, - (PaddX Padd P'1 k P) @ l == P@l + P'1@l * pow (hd 0 l) k). + (PaddX Padd P'1 k P) @ l == P@l + P'1@l * pow_pos rmul (hd 0 l) k). induction P;simpl;intros;try apply (ARadd_comm ARth). destruct p2;simpl;try apply (ARadd_comm ARth). rewrite jump_Pdouble_minus_one;apply (ARadd_comm ARth). @@ -642,15 +682,15 @@ Section MakeRingPol. rewrite IHP'1;rsimpl; rewrite H1;add_push (P5 @ (tail l0));rrefl. rewrite IHP'1;simpl;Esimpl. rewrite H1;rewrite Pplus_comm. - rewrite pow_Pplus;simpl;Esimpl. + rewrite pow_pos_Pplus;simpl;Esimpl. add_push (P5 @ (tail l0));rrefl. rewrite IHP1;rewrite H1;rewrite Pplus_comm. - rewrite pow_Pplus;simpl;rsimpl. + rewrite pow_pos_Pplus;simpl;rsimpl. add_push (P5 @ (tail l0));rrefl. rewrite H0;rsimpl. add_push (P3 @ (tail l)). rewrite H;rewrite Pplus_comm. - rewrite IHP'2;rewrite pow_Pplus;rsimpl. + rewrite IHP'2;rewrite pow_pos_Pplus;rsimpl. add_push (P3 @ (tail l));rrefl. Qed. @@ -674,20 +714,20 @@ Section MakeRingPol. destruct P;simpl. repeat rewrite Popp_ok;Esimpl2;rsimpl;add_push [c];try rrefl. destruct p0;simpl;Esimpl2. - rewrite IHP'2;simpl;rsimpl;add_push (P'1@l * (pow (hd 0 l) p));trivial. + rewrite IHP'2;simpl;rsimpl;add_push (P'1@l * (pow_pos rmul (hd 0 l) p));trivial. add_push (P @ (jump p0 (jump p0 (tail l))));rrefl. rewrite IHP'2;simpl;rewrite jump_Pdouble_minus_one;rsimpl. - add_push (- (P'1 @ l * pow (hd 0 l) p));rrefl. + add_push (- (P'1 @ l * pow_pos rmul (hd 0 l) p));rrefl. rewrite IHP'2;rsimpl;add_push (P @ (tail l));rrefl. assert (H := ZPminus_spec p0 p);destruct (ZPminus p0 p);Esimpl2. rewrite IHP'1; rewrite IHP'2;rsimpl. add_push (P3 @ (tail l));rewrite H;rrefl. rewrite IHP'1; rewrite IHP'2;rsimpl;simpl;Esimpl. rewrite H;rewrite Pplus_comm. - rewrite pow_Pplus;rsimpl. + rewrite pow_pos_Pplus;rsimpl. add_push (P3 @ (tail l));rrefl. assert (forall P k l, - (PsubX Psub P'1 k P) @ l == P@l + - P'1@l * pow (hd 0 l) k). + (PsubX Psub P'1 k P) @ l == P@l + - P'1@l * pow_pos rmul (hd 0 l) k). induction P;simpl;intros. rewrite Popp_ok;rsimpl;apply (ARadd_comm ARth);trivial. destruct p2;simpl;rewrite Popp_ok;rsimpl. @@ -697,17 +737,44 @@ Section MakeRingPol. assert (H1 := ZPminus_spec p2 k);destruct (ZPminus p2 k);Esimpl2;rsimpl. rewrite IHP'1;rsimpl;add_push (P5 @ (tail l0));rewrite H1;rrefl. rewrite IHP'1;rewrite H1;rewrite Pplus_comm. - rewrite pow_Pplus;simpl;Esimpl. + rewrite pow_pos_Pplus;simpl;Esimpl. add_push (P5 @ (tail l0));rrefl. rewrite IHP1;rewrite H1;rewrite Pplus_comm. - rewrite pow_Pplus;simpl;rsimpl. + rewrite pow_pos_Pplus;simpl;rsimpl. add_push (P5 @ (tail l0));rrefl. rewrite H0;rsimpl. rewrite IHP'2;rsimpl;add_push (P3 @ (tail l)). rewrite H;rewrite Pplus_comm. - rewrite pow_Pplus;rsimpl. + rewrite pow_pos_Pplus;rsimpl. Qed. - +(* Proof for the symmetriv version *) + + Lemma PmulI_ok : + forall P', + (forall (P : Pol) (l : list R), (Pmul P P') @ l == P @ l * P' @ l) -> + forall (P : Pol) (p : positive) (l : list R), + (PmulI Pmul P' p P) @ l == P @ l * P' @ (jump p l). + Proof. + induction P;simpl;intros. + Esimpl2;apply (ARmul_comm ARth). + assert (H1 := ZPminus_spec p p0);destruct (ZPminus p p0);Esimpl2. + rewrite H1; rewrite H;rrefl. + rewrite H1; rewrite H. + rewrite Pplus_comm. + rewrite jump_Pplus;simpl;rrefl. + rewrite H1;rewrite Pplus_comm. + rewrite jump_Pplus;rewrite IHP;rrefl. + destruct p0;Esimpl2. + rewrite IHP1;rewrite IHP2;simpl;rsimpl. + mul_push (pow_pos rmul (hd 0 l) p);rrefl. + rewrite IHP1;rewrite IHP2;simpl;rsimpl. + mul_push (pow_pos rmul (hd 0 l) p); rewrite jump_Pdouble_minus_one;rrefl. + rewrite IHP1;simpl;rsimpl. + mul_push (pow_pos rmul (hd 0 l) p). + rewrite H;rrefl. + Qed. + +(* Lemma PmulI_ok : forall P', (forall (P : Pol) (l : list R), (Pmul_aux P P') @ l == P @ l * P' @ l) -> @@ -725,11 +792,11 @@ Section MakeRingPol. rewrite jump_Pplus;rewrite IHP;rrefl. destruct p0;Esimpl2. rewrite IHP1;rewrite IHP2;simpl;rsimpl. - mul_push (pow (hd 0 l) p);rrefl. + mul_push (pow_pos rmul (hd 0 l) p);rrefl. rewrite IHP1;rewrite IHP2;simpl;rsimpl. - mul_push (pow (hd 0 l) p); rewrite jump_Pdouble_minus_one;rrefl. + mul_push (pow_pos rmul (hd 0 l) p); rewrite jump_Pdouble_minus_one;rrefl. rewrite IHP1;simpl;rsimpl. - mul_push (pow (hd 0 l) p). + mul_push (pow_pos rmul (hd 0 l) p). rewrite H;rrefl. Qed. @@ -741,9 +808,33 @@ Section MakeRingPol. rewrite Padd_ok;Esimpl2. rewrite (PmulI_ok P'2 IHP'2). rewrite IHP'1. rrefl. Qed. +*) +(* Proof for the symmetric version *) Lemma Pmul_ok : forall P P' l, (P**P')@l == P@l * P'@l. Proof. + intros P P';generalize P;clear P;induction P';simpl;intros. + apply PmulC_ok. apply PmulI_ok;trivial. + destruct P. + rewrite (ARmul_comm ARth);Esimpl2;Esimpl2. + Esimpl2. rewrite IHP'1;Esimpl2. + assert (match p0 with + | xI j => Pinj (xO j) P ** P'2 + | xO j => Pinj (Pdouble_minus_one j) P ** P'2 + | 1 => P ** P'2 + end @ (tail l) == P @ (jump p0 l) * P'2 @ (tail l)). + destruct p0;simpl;rewrite IHP'2;Esimpl. + rewrite jump_Pdouble_minus_one;Esimpl. + rewrite H;Esimpl. + rewrite Padd_ok; Esimpl2. rewrite Padd_ok; Esimpl2. + repeat (rewrite IHP'1 || rewrite IHP'2);simpl. + rewrite PmulI_ok;trivial. + mul_push (P'1@l). simpl. mul_push (P'2 @ (tail l)). Esimpl. + Qed. + +(* +Lemma Pmul_ok : forall P P' l, (P**P')@l == P@l * P'@l. + Proof. destruct P;simpl;intros. Esimpl2;apply (ARmul_comm ARth). rewrite (PmulI_ok P (Pmul_aux_ok P)). @@ -753,12 +844,38 @@ Section MakeRingPol. rewrite Pmul_aux_ok;mul_push (P' @ l). rewrite (ARmul_comm ARth (P' @ l));rrefl. Qed. +*) + + Lemma Psquare_ok : forall P l, (Psquare P)@l == P@l * P@l. + Proof. + induction P;simpl;intros;Esimpl2. + apply IHP. rewrite Padd_ok. rewrite Pmul_ok;Esimpl2. + rewrite IHP1;rewrite IHP2. + mul_push (pow_pos rmul (hd 0 l) p). mul_push (P2@l). + rrefl. + Qed. Lemma mkZmon_ok: forall M j l, Mphi l (mkZmon j M) == Mphi l (zmon j M). intros M j l; case M; simpl; intros; rsimpl. Qed. + + Lemma zmon_pred_ok : forall M j l, + Mphi (tail l) (zmon_pred j M) == Mphi l (zmon j M). + Proof. + destruct j; simpl;intros auto; rsimpl. + rewrite mkZmon_ok;rsimpl. + rewrite mkZmon_ok;simpl. rewrite jump_Pdouble_minus_one; rsimpl. + Qed. + + Lemma mkVmon_ok : forall M i l, Mphi l (mkVmon i M) == Mphi l M*pow_pos rmul (hd 0 l) i. + Proof. + destruct M;simpl;intros;rsimpl. + rewrite zmon_pred_ok;simpl;rsimpl. + rewrite Pplus_comm;rewrite pow_pos_Pplus;rsimpl. + Qed. + Lemma Mphi_ok: forall P M l, let (Q,R) := MFactor P M in @@ -798,8 +915,7 @@ Section MakeRingPol. rewrite (ARadd_comm ARth); rsimpl. apply radd_ext; rsimpl. rewrite (ARadd_comm ARth); rsimpl. - case j; simpl; auto; try intros j1; rsimpl. - rewrite jump_Pdouble_minus_one; rsimpl. + rewrite zmon_pred_ok;rsimpl. intros j M1. case_eq ((i ?= j) Eq); intros He; simpl. rewrite (Pcompare_Eq_eq _ _ He). @@ -827,7 +943,7 @@ Section MakeRingPol. apply rmul_ext; rsimpl. rewrite (ARmul_comm ARth); rsimpl. apply rmul_ext; rsimpl. - rewrite <- pow_Pplus. + rewrite <- pow_pos_Pplus. rewrite (Pplus_minus _ _ (ZC2 _ _ He)); rsimpl. generalize (Hrec1 (mkZmon 1 M1) l); case (MFactor P2 (mkZmon 1 M1)); @@ -847,13 +963,15 @@ Section MakeRingPol. repeat (rewrite <-(ARmul_assoc ARth)). rewrite (ARmul_comm ARth (Q3@l)); rsimpl. apply rmul_ext; rsimpl. - rewrite <- pow_Pplus. + rewrite <- pow_pos_Pplus. rewrite (Pplus_minus _ _ He); rsimpl. Qed. +(* Proof for the symmetric version *) Lemma POneSubst_ok: forall P1 M1 P2 P3 l, POneSubst P1 M1 P2 = Some P3 -> Mphi l M1 == P2@l -> P1@l == P3@l. + Proof. intros P2 M1 P3 P4 l; unfold POneSubst. generalize (Mphi_ok P2 M1 l); case (MFactor P2 M1); simpl; auto. intros Q1 R1; case R1. @@ -864,16 +982,40 @@ Section MakeRingPol. discriminate. intros _ H1 H2; injection H1; intros; subst. rewrite H2; rsimpl. - rewrite Padd_ok; rewrite Pmul_ok; rsimpl. + (* new version *) + rewrite Padd_ok; rewrite PmulC_ok; rsimpl. intros i P5 H; rewrite H. intros HH H1; injection HH; intros; subst; rsimpl. - rewrite Padd_ok; rewrite Pmul_ok; rewrite H1; rsimpl. + rewrite Padd_ok; rewrite PmulI_ok. intros;apply Pmul_ok. rewrite H1; rsimpl. intros i P5 P6 H1 H2 H3; rewrite H1; rewrite H3. - injection H2; intros; subst; rsimpl. - rewrite Padd_ok; rewrite Pmul_ok; rsimpl. + assert (P4 = Q1 ++ P3 ** PX i P5 P6). + injection H2; intros; subst;trivial. + rewrite H;rewrite Padd_ok;rewrite Pmul_ok;rsimpl. Qed. - - +(* + Lemma POneSubst_ok: forall P1 M1 P2 P3 l, + POneSubst P1 M1 P2 = Some P3 -> Mphi l M1 == P2@l -> P1@l == P3@l. +Proof. + intros P2 M1 P3 P4 l; unfold POneSubst. + generalize (Mphi_ok P2 M1 l); case (MFactor P2 M1); simpl; auto. + intros Q1 R1; case R1. + intros c H; rewrite H. + generalize (morph_eq CRmorph c cO); + case (c ?=! cO); simpl; auto. + intros H1 H2; rewrite H1; auto; rsimpl. + discriminate. + intros _ H1 H2; injection H1; intros; subst. + rewrite H2; rsimpl. + rewrite Padd_ok; rewrite Pmul_ok; rsimpl. + intros i P5 H; rewrite H. + intros HH H1; injection HH; intros; subst; rsimpl. + rewrite Padd_ok; rewrite Pmul_ok. rewrite H1; rsimpl. + intros i P5 P6 H1 H2 H3; rewrite H1; rewrite H3. + injection H2; intros; subst; rsimpl. + rewrite Padd_ok. + rewrite Pmul_ok; rsimpl. + Qed. +*) Lemma PNSubst1_ok: forall n P1 M1 P2 l, Mphi l M1 == P2@l -> P1@l == (PNSubst1 P1 M1 P2 n)@l. Proof. @@ -947,47 +1089,28 @@ Section MakeRingPol. | PEadd : PExpr -> PExpr -> PExpr | PEsub : PExpr -> PExpr -> PExpr | PEmul : PExpr -> PExpr -> PExpr - | PEopp : PExpr -> PExpr. - - (** normalisation towards polynomials *) - - Definition X := (PX P1 xH P0). - - Definition mkX j := - match j with - | xH => X - | xO j => Pinj (Pdouble_minus_one j) X - | xI j => Pinj (xO j) X - end. + | PEopp : PExpr -> PExpr + | PEpow : PExpr -> N -> PExpr. - Fixpoint norm (pe:PExpr) : Pol := - match pe with - | PEc c => Pc c - | PEX j => mkX j - | PEadd pe1 (PEopp pe2) => Psub (norm pe1) (norm pe2) - | PEadd (PEopp pe1) pe2 => Psub (norm pe2) (norm pe1) - | PEadd pe1 pe2 => Padd (norm pe1) (norm pe2) - | PEsub pe1 pe2 => Psub (norm pe1) (norm pe2) - | PEmul pe1 pe2 => Pmul (norm pe1) (norm pe2) - | PEopp pe1 => Popp (norm pe1) - end. + (** evaluation of polynomial expressions towards R *) + Definition mk_X j := mkPinj_pred j mkX. (** evaluation of polynomial expressions towards R *) - + Fixpoint PEeval (l:list R) (pe:PExpr) {struct pe} : R := - match pe with - | PEc c => phi c - | PEX j => nth 0 j l - | PEadd pe1 pe2 => (PEeval l pe1) + (PEeval l pe2) - | PEsub pe1 pe2 => (PEeval l pe1) - (PEeval l pe2) - | PEmul pe1 pe2 => (PEeval l pe1) * (PEeval l pe2) - | PEopp pe1 => - (PEeval l pe1) - end. + match pe with + | PEc c => phi c + | PEX j => nth 0 j l + | PEadd pe1 pe2 => (PEeval l pe1) + (PEeval l pe2) + | PEsub pe1 pe2 => (PEeval l pe1) - (PEeval l pe2) + | PEmul pe1 pe2 => (PEeval l pe1) * (PEeval l pe2) + | PEopp pe1 => - (PEeval l pe1) + | PEpow pe1 n => rpow (PEeval l pe1) (Cp_phi n) + end. (** Correctness proofs *) - - Lemma mkX_ok : forall p l, nth 0 p l == (mkX p) @ l. + Lemma mkX_ok : forall p l, nth 0 p l == (mk_X p) @ l. Proof. destruct p;simpl;intros;Esimpl;trivial. rewrite <-jump_tl;rewrite nth_jump;rrefl. @@ -995,238 +1118,579 @@ Section MakeRingPol. rewrite nth_Pdouble_minus_one;rrefl. Qed. - Lemma norm_PEopp : forall l pe, (norm (PEopp pe))@l == -(norm pe)@l. - Proof. - intros;simpl;apply Popp_ok. - Qed. - Ltac Esimpl3 := repeat match goal with | |- context [(?P1 ++ ?P2)@?l] => rewrite (Padd_ok P2 P1 l) | |- context [(?P1 -- ?P2)@?l] => rewrite (Psub_ok P2 P1 l) - | |- context [(norm (PEopp ?pe))@?l] => rewrite (norm_PEopp l pe) - end;Esimpl2;try rrefl;try apply (ARadd_comm ARth). + end;Esimpl2;try rrefl;try apply (ARadd_comm ARth). + +(* Power using the chinise algorithm *) +(*Section POWER. + Variable subst_l : Pol -> Pol. + Fixpoint Ppow_pos (P:Pol) (p:positive){struct p} : Pol := + match p with + | xH => P + | xO p => subst_l (Psquare (Ppow_pos P p)) + | xI p => subst_l (Pmul P (Psquare (Ppow_pos P p))) + end. + + Definition Ppow_N P n := + match n with + | N0 => P1 + | Npos p => Ppow_pos P p + end. + + Lemma Ppow_pos_ok : forall l, (forall P, subst_l P@l == P@l) -> + forall P p, (Ppow_pos P p)@l == (pow_pos Pmul P p)@l. + Proof. + intros l subst_l_ok P. + induction p;simpl;intros;try rrefl;try rewrite subst_l_ok. + repeat rewrite Pmul_ok;rewrite Psquare_ok;rewrite IHp;rrefl. + repeat rewrite Pmul_ok;rewrite Psquare_ok;rewrite IHp;rrefl. + Qed. + + Lemma Ppow_N_ok : forall l, (forall P, subst_l P@l == P@l) -> + forall P n, (Ppow_N P n)@l == (pow_N P1 Pmul P n)@l. + Proof. destruct n;simpl. rrefl. apply Ppow_pos_ok. trivial. Qed. + + End POWER. *) + +Section POWER. + Variable subst_l : Pol -> Pol. + Fixpoint Ppow_pos (res P:Pol) (p:positive){struct p} : Pol := + match p with + | xH => subst_l (Pmul res P) + | xO p => Ppow_pos (Ppow_pos res P p) P p + | xI p => subst_l (Pmul (Ppow_pos (Ppow_pos res P p) P p) P) + end. + + Definition Ppow_N P n := + match n with + | N0 => P1 + | Npos p => Ppow_pos P1 P p + end. + + Lemma Ppow_pos_ok : forall l, (forall P, subst_l P@l == P@l) -> + forall res P p, (Ppow_pos res P p)@l == res@l * (pow_pos Pmul P p)@l. + Proof. + intros l subst_l_ok res P p. generalize res;clear res. + induction p;simpl;intros;try rewrite subst_l_ok; repeat rewrite Pmul_ok;repeat rewrite IHp. + rsimpl. mul_push (P@l);rsimpl. rsimpl. rrefl. + Qed. + + Lemma Ppow_N_ok : forall l, (forall P, subst_l P@l == P@l) -> + forall P n, (Ppow_N P n)@l == (pow_N P1 Pmul P n)@l. + Proof. destruct n;simpl. rrefl. rewrite Ppow_pos_ok. trivial. Esimpl. Qed. + + End POWER. + + (** Normalization and rewriting *) + + Section NORM_SUBST_REC. + Variable n : nat. + Variable lmp:list (Mon*Pol). + Let subst_l P := PNSubstL P lmp n n. + Let Pmul_subst P1 P2 := subst_l (Pmul P1 P2). + Let Ppow_subst := Ppow_N subst_l. + + Fixpoint norm_aux (pe:PExpr) : Pol := + match pe with + | PEc c => Pc c + | PEX j => mk_X j + | PEadd (PEopp pe1) pe2 => Psub (norm_aux pe2) (norm_aux pe1) + | PEadd pe1 (PEopp pe2) => + Psub (norm_aux pe1) (norm_aux pe2) + | PEadd pe1 pe2 => Padd (norm_aux pe1) (norm_aux pe2) + | PEsub pe1 pe2 => Psub (norm_aux pe1) (norm_aux pe2) + | PEmul pe1 pe2 => Pmul (norm_aux pe1) (norm_aux pe2) + | PEopp pe1 => Popp (norm_aux pe1) + | PEpow pe1 n => Ppow_N (fun p => p) (norm_aux pe1) n + end. - Lemma norm_ok : forall l pe, PEeval l pe == (norm pe)@l. - Proof. - induction pe;simpl;Esimpl3. - apply mkX_ok. - rewrite IHpe1;rewrite IHpe2; destruct pe1;destruct pe2;Esimpl3. - rewrite IHpe1;rewrite IHpe2;rrefl. - rewrite Pmul_ok;rewrite IHpe1;rewrite IHpe2;rrefl. - rewrite IHpe;rrefl. - Qed. + Definition norm_subst pe := subst_l (norm_aux pe). + + (* + Fixpoint norm_subst (pe:PExpr) : Pol := + match pe with + | PEc c => Pc c + | PEX j => subst_l (mk_X j) + | PEadd (PEopp pe1) pe2 => Psub (norm_subst pe2) (norm_subst pe1) + | PEadd pe1 (PEopp pe2) => + Psub (norm_subst pe1) (norm_subst pe2) + | PEadd pe1 pe2 => Padd (norm_subst pe1) (norm_subst pe2) + | PEsub pe1 pe2 => Psub (norm_subst pe1) (norm_subst pe2) + | PEmul pe1 pe2 => Pmul_subst (norm_subst pe1) (norm_subst pe2) + | PEopp pe1 => Popp (norm_subst pe1) + | PEpow pe1 n => Ppow_subst (norm_subst pe1) n + end. - Lemma ring_correct : forall l pe1 pe2, - ((norm pe1) ?== (norm pe2)) = true -> (PEeval l pe1) == (PEeval l pe2). + Lemma norm_subst_spec : + forall l pe, MPcond lmp l -> + PEeval l pe == (norm_subst pe)@l. + Proof. + intros;assert (subst_l_ok:forall P, (subst_l P)@l == P@l). + unfold subst_l;intros. + rewrite <- PNSubstL_ok;trivial. rrefl. + assert (Pms_ok:forall P1 P2, (Pmul_subst P1 P2)@l == P1@l*P2@l). + intros;unfold Pmul_subst;rewrite subst_l_ok;rewrite Pmul_ok;rrefl. + induction pe;simpl;Esimpl3. + rewrite subst_l_ok;apply mkX_ok. + rewrite IHpe1;rewrite IHpe2;destruct pe1;destruct pe2;Esimpl3. + rewrite IHpe1;rewrite IHpe2;rrefl. + rewrite Pms_ok;rewrite IHpe1;rewrite IHpe2;rrefl. + rewrite IHpe;rrefl. + unfold Ppow_subst. rewrite Ppow_N_ok. trivial. + rewrite pow_th.(rpow_pow_N). destruct n0;Esimpl3. + induction p;simpl;try rewrite IHp;try rewrite IHpe;repeat rewrite Pms_ok; + repeat rewrite Pmul_ok;rrefl. + Qed. +*) + Lemma norm_aux_spec : + forall l pe, MPcond lmp l -> + PEeval l pe == (norm_aux pe)@l. + Proof. + intros. + induction pe;simpl;Esimpl3. + apply mkX_ok. + rewrite IHpe1;rewrite IHpe2;destruct pe1;destruct pe2;Esimpl3. + rewrite IHpe1;rewrite IHpe2;rrefl. + rewrite IHpe1;rewrite IHpe2. rewrite Pmul_ok. rrefl. + rewrite IHpe;rrefl. + rewrite Ppow_N_ok. intros;rrefl. + rewrite pow_th.(rpow_pow_N). destruct n0;Esimpl3. + induction p;simpl;try rewrite IHp;try rewrite IHpe;repeat rewrite Pms_ok; + repeat rewrite Pmul_ok;rrefl. + Qed. + + Lemma norm_subst_spec : + forall l pe, MPcond lmp l -> + PEeval l pe == (norm_subst pe)@l. Proof. - intros l pe1 pe2 H. - repeat rewrite norm_ok. - apply (Peq_ok (norm pe1) (norm pe2) H l). - Qed. - -(** Evaluation function avoiding parentheses *) - Fixpoint mkmult (r:R) (lm:list R) {struct lm}: R := - match lm with - | nil => r - | cons h t => mkmult (r*h) t - end. - - Definition mkadd_mult rP lm := - match lm with - | nil => rP + 1 - | cons h t => rP + mkmult h t + intros;unfold norm_subst. + unfold subst_l;rewrite <- PNSubstL_ok;trivial. apply norm_aux_spec. trivial. + Qed. + + End NORM_SUBST_REC. + + Fixpoint interp_PElist (l:list R) (lpe:list (PExpr*PExpr)) {struct lpe} : Prop := + match lpe with + | nil => True + | (me,pe)::lpe => + match lpe with + | nil => PEeval l me == PEeval l pe + | _ => PEeval l me == PEeval l pe /\ interp_PElist l lpe + end end. - Fixpoint powl (i:positive) (x:R) (l:list R) {struct i}: list R := - match i with - | xH => cons x l - | xO i => powl i x (powl i x l) - | xI i => powl i x (powl i x (cons x l)) - end. - - Fixpoint add_mult_dev (rP:R) (P:Pol) (fv lm:list R) {struct P} : R := - (* rP + P@l * lm *) + Fixpoint mon_of_pol (P:Pol) : option Mon := match P with - | Pc c => if c ?=! cI then mkadd_mult rP (rev' lm) - else mkadd_mult rP (cons [c] (rev' lm)) - | Pinj j Q => add_mult_dev rP Q (jump j fv) lm - | PX P i Q => - let rP := add_mult_dev rP P fv (powl i (hd 0 fv) lm) in - if Q ?== P0 then rP else add_mult_dev rP Q (tail fv) lm + | Pc c => if (c ?=! cI) then Some mon0 else None + | Pinj j P => + match mon_of_pol P with + | None => None + | Some m => Some (mkZmon j m) + end + | PX P i Q => + if Peq Q P0 then + match mon_of_pol P with + | None => None + | Some m => Some (mkVmon i m) + end + else None end. - - Definition mkmult1 lm := - match lm with - | nil => rI - | cons h t => mkmult h t + + Fixpoint mk_monpol_list (lpe:list (PExpr * PExpr)) : list (Mon*Pol) := + match lpe with + | nil => nil + | (me,pe)::lpe => + match mon_of_pol (norm_subst 0 nil me) with + | None => mk_monpol_list lpe + | Some m => (m,norm_subst 0 nil pe):: mk_monpol_list lpe + end end. + + Lemma mon_of_pol_ok : forall P m, mon_of_pol P = Some m -> + forall l, Mphi l m == P@l. + Proof. + induction P;simpl;intros;Esimpl. + assert (H1 := (morph_eq CRmorph) c cI). + destruct (c ?=! cI). + inversion H;rewrite H1;trivial;Esimpl. + discriminate. + generalize H;clear H;case_eq (mon_of_pol P);intros;try discriminate. + inversion H0. + rewrite mkZmon_ok;simpl;auto. + generalize H;clear H;change match P3 with + | Pc c => c ?=! cO + | Pinj _ _ => false + | PX _ _ _ => false + end with (P3 ?== P0). + assert (H := Peq_ok P3 P0). + destruct (P3 ?== P0). + case_eq (mon_of_pol P2);intros. + inversion H1. + rewrite mkVmon_ok;simpl. + rewrite H;trivial;Esimpl. rewrite IHP1;trivial;Esimpl. discriminate. + intros;discriminate. + Qed. + + Lemma interp_PElist_ok : forall l lpe, + interp_PElist l lpe -> MPcond (mk_monpol_list lpe) l. + Proof. + induction lpe;simpl. trivial. + destruct a;simpl;intros. + assert (HH:=mon_of_pol_ok (norm_subst 0 nil p)); + destruct (mon_of_pol (norm_subst 0 nil p)). + split. + rewrite <- norm_subst_spec. exact I. + destruct lpe;try destruct H;rewrite <- H; + rewrite (norm_subst_spec 0 nil); try exact I;apply HH;trivial. + apply IHlpe. destruct lpe;simpl;trivial. destruct H. exact H0. + apply IHlpe. destruct lpe;simpl;trivial. destruct H. exact H0. + Qed. + + Lemma norm_subst_ok : forall n l lpe pe, + interp_PElist l lpe -> + PEeval l pe == (norm_subst n (mk_monpol_list lpe) pe)@l. + Proof. + intros;apply norm_subst_spec. apply interp_PElist_ok;trivial. + Qed. + + Lemma ring_correct : forall n l lpe pe1 pe2, + interp_PElist l lpe -> + (let lmp := mk_monpol_list lpe in + norm_subst n lmp pe1 ?== norm_subst n lmp pe2) = true -> + PEeval l pe1 == PEeval l pe2. + Proof. + simpl;intros. + do 2 (rewrite (norm_subst_ok n l lpe);trivial). + apply Peq_ok;trivial. + Qed. + + + + (** Generic evaluation of polynomial towards R avoiding parenthesis *) + Variable get_sign : C -> option C. + Variable get_sign_spec : sign_theory ropp req phi get_sign. + + + Section EVALUATION. + + (* [mkpow x p] = x^p *) + Variable mkpow : R -> positive -> R. + (* [mkpow x p] = -(x^p) *) + Variable mkopp_pow : R -> positive -> R. + (* [mkmult_pow r x p] = r * x^p *) + Variable mkmult_pow : R -> R -> positive -> R. - Fixpoint mult_dev (P:Pol) (fv lm : list R) {struct P} : R := - (* P@l * lm *) + Fixpoint mkmult_rec (r:R) (lm:list (R*positive)) {struct lm}: R := + match lm with + | nil => r + | cons (x,p) t => mkmult_rec (mkmult_pow r x p) t + end. + + Definition mkmult1 lm := + match lm with + | nil => 1 + | cons (x,p) t => mkmult_rec (mkpow x p) t + end. + + Definition mkmultm1 lm := + match lm with + | nil => ropp rI + | cons (x,p) t => mkmult_rec (mkopp_pow x p) t + end. + + Definition mkmult_c_pos c lm := + if c ?=! cI then mkmult1 (rev' lm) + else mkmult_rec [c] (rev' lm). + + Definition mkmult_c c lm := + match get_sign c with + | None => mkmult_c_pos c lm + | Some c' => + if c' ?=! cI then mkmultm1 (rev' lm) + else mkmult_rec [c] (rev' lm) + end. + + Definition mkadd_mult rP c lm := + match get_sign c with + | None => rP + mkmult_c_pos c lm + | Some c' => rP - mkmult_c_pos c' lm + end. + + Definition add_pow_list (r:R) n l := + match n with + | N0 => l + | Npos p => (r,p)::l + end. + + Fixpoint add_mult_dev + (rP:R) (P:Pol) (fv:list R) (n:N) (lm:list (R*positive)) {struct P} : R := + match P with + | Pc c => + let lm := add_pow_list (hd 0 fv) n lm in + mkadd_mult rP c lm + | Pinj j Q => + add_mult_dev rP Q (jump j fv) N0 (add_pow_list (hd 0 fv) n lm) + | PX P i Q => + let rP := add_mult_dev rP P fv (Nplus (Npos i) n) lm in + if Q ?== P0 then rP + else add_mult_dev rP Q (tail fv) N0 (add_pow_list (hd 0 fv) n lm) + end. + + Fixpoint mult_dev (P:Pol) (fv : list R) (n:N) + (lm:list (R*positive)) {struct P} : R := + (* P@l * (hd 0 l)^n * lm *) match P with - | Pc c => if c ?=! cI then mkmult1 (rev' lm) else mkmult [c] (rev' lm) - | Pinj j Q => mult_dev Q (jump j fv) lm + | Pc c => mkmult_c c (add_pow_list (hd 0 fv) n lm) + | Pinj j Q => mult_dev Q (jump j fv) N0 (add_pow_list (hd 0 fv) n lm) | PX P i Q => - let rP := mult_dev P fv (powl i (hd 0 fv) lm) in - if Q ?== P0 then rP else add_mult_dev rP Q (tail fv) lm + let rP := mult_dev P fv (Nplus (Npos i) n) lm in + if Q ?== P0 then rP + else + let lmq := add_pow_list (hd 0 fv) n lm in + add_mult_dev rP Q (tail fv) N0 lmq end. - Definition Pphi_dev fv P := mult_dev P fv nil. + Definition Pphi_avoid fv P := mult_dev P fv N0 nil. + + Fixpoint r_list_pow (l:list (R*positive)) : R := + match l with + | nil => rI + | cons (r,p) l => pow_pos rmul r p * r_list_pow l + end. - Add Morphism mkmult : mkmult_ext. - intros r r0 eqr l;generalize l r r0 eqr;clear l r r0 eqr; - induction l;simpl;intros. - trivial. apply IHl; rewrite eqr;rrefl. - Qed. + Hypothesis mkpow_spec : forall r p, mkpow r p == pow_pos rmul r p. + Hypothesis mkopp_pow_spec : forall r p, mkopp_pow r p == - (pow_pos rmul r p). + Hypothesis mkmult_pow_spec : forall r x p, mkmult_pow r x p == r * pow_pos rmul x p. - Lemma mul_mkmult : forall lm r1 r2, r1 * mkmult r2 lm == mkmult (r1*r2) lm. + Lemma mkmult_rec_ok : forall lm r, mkmult_rec r lm == r * r_list_pow lm. Proof. - induction lm;simpl;intros;try rrefl. - rewrite IHlm. - setoid_replace (r1 * (r2 * a)) with (r1 * r2 * a);Esimpl. - Qed. + induction lm;intros;simpl;Esimpl. + destruct a as (x,p);Esimpl. + rewrite IHlm. rewrite mkmult_pow_spec. Esimpl. + Qed. - Lemma mkmult1_mkmult : forall lm r, r * mkmult1 lm == mkmult r lm. + Lemma mkmult1_ok : forall lm, mkmult1 lm == r_list_pow lm. Proof. - destruct lm;simpl;intros. Esimpl. - apply mul_mkmult. + destruct lm;simpl;Esimpl. + destruct p. rewrite mkmult_rec_ok;rewrite mkpow_spec;Esimpl. Qed. - - Lemma mkmult1_mkmult_1 : forall lm, mkmult1 lm == mkmult 1 lm. + + Lemma mkmultm1_ok : forall lm, mkmultm1 lm == - r_list_pow lm. Proof. - intros;rewrite <- mkmult1_mkmult;Esimpl. + destruct lm;simpl;Esimpl. + destruct p;rewrite mkmult_rec_ok. rewrite mkopp_pow_spec;Esimpl. Qed. - Lemma mkmult_rev_append : forall lm l r, - mkmult r (rev_append lm l) == mkmult (mkmult r l) lm. + Lemma r_list_pow_rev : forall l, r_list_pow (rev' l) == r_list_pow l. + Proof. + assert + (forall l lr : list (R * positive), r_list_pow (rev_append l lr) == r_list_pow lr * r_list_pow l). + induction l;intros;simpl;Esimpl. + destruct a;rewrite IHl;Esimpl. + rewrite (ARmul_comm ARth (pow_pos rmul r p)). rrefl. + intros;unfold rev'. rewrite H;simpl;Esimpl. + Qed. + + Lemma mkmult_c_pos_ok : forall c lm, mkmult_c_pos c lm == [c]* r_list_pow lm. Proof. - induction lm; simpl in |- *; intros. - rrefl. - rewrite IHlm; simpl in |- *. - repeat rewrite <- (ARmul_comm ARth a); rewrite <- mul_mkmult. - rrefl. + intros;unfold mkmult_c_pos;simpl. + assert (H := (morph_eq CRmorph) c cI). + rewrite <- r_list_pow_rev; destruct (c ?=! cI). + rewrite H;trivial;Esimpl. + apply mkmult1_ok. apply mkmult_rec_ok. Qed. - Lemma powl_mkmult_rev : forall p r x lm, - mkmult r (rev' (powl p x lm)) == mkmult (pow x p * r) (rev' lm). + Lemma mkmult_c_ok : forall c lm, mkmult_c c lm == [c] * r_list_pow lm. + Proof. + intros;unfold mkmult_c;simpl. + case_eq (get_sign c);intros. + assert (H1 := (morph_eq CRmorph) c0 cI). + destruct (c0 ?=! cI). + rewrite (get_sign_spec.(sign_spec) _ H). rewrite H1;trivial. + rewrite <- r_list_pow_rev;trivial;Esimpl. + apply mkmultm1_ok. + rewrite <- r_list_pow_rev; apply mkmult_rec_ok. + apply mkmult_c_pos_ok. +Qed. + + Lemma mkadd_mult_ok : forall rP c lm, mkadd_mult rP c lm == rP + [c]*r_list_pow lm. Proof. - induction p;simpl;intros. - repeat rewrite IHp. - unfold rev';simpl. - repeat rewrite mkmult_rev_append. - simpl. - setoid_replace (pow x p * (pow x p * r) * x) - with (x * pow x p * pow x p * r);Esimpl. - mul_push x;rrefl. - repeat rewrite IHp. - setoid_replace (pow x p * (pow x p * r) ) - with (pow x p * pow x p * r);Esimpl. - unfold rev';simpl. repeat rewrite mkmult_rev_append;simpl. - rewrite (ARmul_comm ARth);rrefl. + intros;unfold mkadd_mult. + case_eq (get_sign c);intros. + rewrite (get_sign_spec.(sign_spec) _ H). + rewrite mkmult_c_pos_ok;Esimpl. + rewrite mkmult_c_pos_ok;Esimpl. Qed. - Lemma Pphi_add_mult_dev : forall P rP fv lm, - rP + P@fv * mkmult1 (rev' lm) == add_mult_dev rP P fv lm. + Lemma add_pow_list_ok : + forall r n l, r_list_pow (add_pow_list r n l) == pow_N rI rmul r n * r_list_pow l. Proof. - induction P;simpl;intros. - assert (H := (morph_eq CRmorph) c cI). - destruct (c ?=! cI). - rewrite (H (refl_equal true));rewrite (morph1 CRmorph);Esimpl. - destruct (rev' lm);Esimpl;rrefl. - rewrite mkmult1_mkmult;rrefl. - apply IHP. - replace (match P3 with + destruct n;simpl;intros;Esimpl. + Qed. + + Lemma add_mult_dev_ok : forall P rP fv n lm, + add_mult_dev rP P fv n lm == rP + P@fv*pow_N rI rmul (hd 0 fv) n * r_list_pow lm. + Proof. + induction P;simpl;intros. + rewrite mkadd_mult_ok. rewrite add_pow_list_ok; Esimpl. + rewrite IHP. simpl. rewrite add_pow_list_ok; Esimpl. + change (match P3 with | Pc c => c ?=! cO | Pinj _ _ => false | PX _ _ _ => false - end) with (Peq P3 P0);trivial. + end) with (Peq P3 P0). + change match n with + | N0 => Npos p + | Npos q => Npos (p + q) + end with (Nplus (Npos p) n);trivial. assert (H := Peq_ok P3 P0). destruct (P3 ?== P0). - rewrite (H (refl_equal true));simpl;Esimpl. - rewrite <- IHP1. - repeat rewrite mkmult1_mkmult_1. - rewrite powl_mkmult_rev. - rewrite <- mul_mkmult;Esimpl. - rewrite <- IHP2. - rewrite <- IHP1. - repeat rewrite mkmult1_mkmult_1. - rewrite powl_mkmult_rev. - rewrite <- mul_mkmult;Esimpl. + rewrite (H (refl_equal true)). + rewrite IHP1. destruct n;simpl;Esimpl;rewrite pow_pos_Pplus;Esimpl. + rewrite IHP2. + rewrite IHP1. destruct n;simpl;Esimpl;rewrite pow_pos_Pplus;Esimpl. Qed. - - Lemma Pphi_mult_dev : forall P fv lm, - P@fv * mkmult1 (rev' lm) == mult_dev P fv lm. + + Lemma mult_dev_ok : forall P fv n lm, + mult_dev P fv n lm == P@fv * pow_N rI rmul (hd 0 fv) n * r_list_pow lm. Proof. - induction P;simpl;intros. - assert (H := (morph_eq CRmorph) c cI). - destruct (c ?=! cI). - rewrite (H (refl_equal true));rewrite (morph1 CRmorph);Esimpl. - apply mkmult1_mkmult. - apply IHP. - replace (match P3 with + induction P;simpl;intros;Esimpl. + rewrite mkmult_c_ok;rewrite add_pow_list_ok;Esimpl. + rewrite IHP. simpl;rewrite add_pow_list_ok;Esimpl. + change (match P3 with | Pc c => c ?=! cO | Pinj _ _ => false | PX _ _ _ => false - end) with (Peq P3 P0);trivial. + end) with (Peq P3 P0). + change match n with + | N0 => Npos p + | Npos q => Npos (p + q) + end with (Nplus (Npos p) n);trivial. assert (H := Peq_ok P3 P0). - destruct (P3 ?== P0). - rewrite (H (refl_equal true));simpl;Esimpl. - rewrite <- IHP1. - repeat rewrite mkmult1_mkmult_1. - rewrite powl_mkmult_rev. - rewrite <- mul_mkmult;Esimpl. - rewrite <- Pphi_add_mult_dev. - rewrite <- IHP1. - repeat rewrite mkmult1_mkmult_1. - rewrite powl_mkmult_rev. - rewrite <- mul_mkmult;Esimpl. - Qed. + destruct (P3 ?== P0). + rewrite (H (refl_equal true)). + rewrite IHP1. destruct n;simpl;Esimpl;rewrite pow_pos_Pplus;Esimpl. + rewrite add_mult_dev_ok. rewrite IHP1; rewrite add_pow_list_ok. + destruct n;simpl;Esimpl;rewrite pow_pos_Pplus;Esimpl. + Qed. - Lemma Pphi_Pphi_dev : forall P l, P@l == Pphi_dev l P. - Proof. - unfold Pphi_dev;intros. - rewrite <- Pphi_mult_dev;simpl;Esimpl. + Lemma Pphi_avoid_ok : forall P fv, Pphi_avoid fv P == P@fv. + Proof. + unfold Pphi_avoid;intros;rewrite mult_dev_ok;simpl;Esimpl. Qed. - Lemma Pphi_dev_gen_ok : forall l pe, PEeval l pe == Pphi_dev l (norm pe). + End EVALUATION. + + Definition Pphi_pow := + let mkpow x p := + match p with xH => x | _ => rpow x (Cp_phi (Npos p)) end in + let mkopp_pow x p := ropp (mkpow x p) in + let mkmult_pow r x p := rmul r (mkpow x p) in + Pphi_avoid mkpow mkopp_pow mkmult_pow. + + Lemma local_mkpow_ok : + forall (r : R) (p : positive), + match p with + | xI _ => rpow r (Cp_phi (Npos p)) + | xO _ => rpow r (Cp_phi (Npos p)) + | 1 => r + end == pow_pos rmul r p. + Proof. intros r p;destruct p;try rewrite pow_th.(rpow_pow_N);reflexivity. Qed. + + Lemma Pphi_pow_ok : forall P fv, Pphi_pow fv P == P@fv. Proof. - intros l pe;rewrite <- Pphi_Pphi_dev;apply norm_ok. + unfold Pphi_pow;intros;apply Pphi_avoid_ok;intros;try rewrite local_mkpow_ok;rrefl. Qed. - Lemma Pphi_dev_ok : - forall l pe npe, norm pe = npe -> PEeval l pe == Pphi_dev l npe. + Lemma ring_rw_pow_correct : forall n lH l, + interp_PElist l lH -> + forall lmp, mk_monpol_list lH = lmp -> + forall pe npe, norm_subst n lmp pe = npe -> + PEeval l pe == Pphi_pow l npe. Proof. - intros l pe npe npe_eq; subst npe; apply Pphi_dev_gen_ok. - Qed. + intros n lH l H1 lmp Heq1 pe npe Heq2. + rewrite Pphi_pow_ok. rewrite <- Heq2;rewrite <- Heq1. + apply norm_subst_ok. trivial. + Qed. - Fixpoint MPcond_dev (LM1: list (Mon * Pol)) (l: list R) {struct LM1} : Prop := - match LM1 with - cons (M1,P2) LM2 => (Mphi l M1 == Pphi_dev l P2) /\ (MPcond_dev LM2 l) - | _ => True + Fixpoint mkmult_pow (r x:R) (p: positive) {struct p} : R := + match p with + | xH => r*x + | xO p => mkmult_pow (mkmult_pow r x p) x p + | xI p => mkmult_pow (mkmult_pow (r*x) x p) x p + end. + + Definition mkpow x p := + match p with + | xH => x + | xO p => mkmult_pow x x (Pdouble_minus_one p) + | xI p => mkmult_pow x x (xO p) end. - - Fixpoint MPcond_map (LM1: list (Mon * PExpr)): list (Mon * Pol) := - match LM1 with - cons (M1,P2) LM2 => cons (M1, norm P2) (MPcond_map LM2) - | _ => nil + + Definition mkopp_pow x p := + match p with + | xH => -x + | xO p => mkmult_pow (-x) x (Pdouble_minus_one p) + | xI p => mkmult_pow (-x) x (xO p) end. - Lemma MP_cond_dev_imp_MP_cond: forall LM1 l, - MPcond_dev LM1 l -> MPcond LM1 l. + Definition Pphi_dev := Pphi_avoid mkpow mkopp_pow mkmult_pow. + + Lemma mkmult_pow_ok : forall p r x, mkmult_pow r x p == r*pow_pos rmul x p. + Proof. + induction p;intros;simpl;Esimpl. + repeat rewrite IHp;Esimpl. + repeat rewrite IHp;Esimpl. + Qed. + + Lemma mkpow_ok : forall p x, mkpow x p == pow_pos rmul x p. + Proof. + destruct p;simpl;intros;Esimpl. + repeat rewrite mkmult_pow_ok;Esimpl. + rewrite mkmult_pow_ok;Esimpl. + pattern x at 1;replace x with (pow_pos rmul x 1). + rewrite <- pow_pos_Pplus. + rewrite <- Pplus_one_succ_l. + rewrite Psucc_o_double_minus_one_eq_xO. + simpl;Esimpl. + trivial. + Qed. + + Lemma mkopp_pow_ok : forall p x, mkopp_pow x p == - pow_pos rmul x p. + Proof. + destruct p;simpl;intros;Esimpl. + repeat rewrite mkmult_pow_ok;Esimpl. + rewrite mkmult_pow_ok;Esimpl. + pattern x at 1;replace x with (pow_pos rmul x 1). + rewrite <- pow_pos_Pplus. + rewrite <- Pplus_one_succ_l. + rewrite Psucc_o_double_minus_one_eq_xO. + simpl;Esimpl. + trivial. + Qed. + + Lemma Pphi_dev_ok : forall P fv, Pphi_dev fv P == P@fv. + Proof. + unfold Pphi_dev;intros;apply Pphi_avoid_ok. + intros;apply mkpow_ok. + intros;apply mkopp_pow_ok. + intros;apply mkmult_pow_ok. + Qed. + + Lemma ring_rw_correct : forall n lH l, + interp_PElist l lH -> + forall lmp, mk_monpol_list lH = lmp -> + forall pe npe, norm_subst n lmp pe = npe -> + PEeval l pe == Pphi_dev l npe. Proof. - intros LM1; elim LM1; simpl; auto. - intros (M2,P2) LM2 Hrec l [H1 H2]; split; auto. - rewrite H1; rewrite Pphi_Pphi_dev; rsimpl. + intros n lH l H1 lmp Heq1 pe npe Heq2. + rewrite Pphi_dev_ok. rewrite <- Heq2;rewrite <- Heq1. + apply norm_subst_ok. trivial. Qed. - Lemma PNSubstL_dev_ok: forall m n lm pe l, - let LM := MPcond_map lm in - MPcond_dev LM l -> PEeval l pe == Pphi_dev l (PNSubstL (norm pe) LM m n). - intros m n lm p3 l LM H. - rewrite <- Pphi_Pphi_dev; rewrite <- PNSubstL_ok; auto. - apply MP_cond_dev_imp_MP_cond; auto. - rewrite Pphi_Pphi_dev; apply Pphi_dev_ok; auto. - Qed. -End MakeRingPol. +End MakeRingPol. + diff --git a/contrib/setoid_ring/Ring_tac.v b/contrib/setoid_ring/Ring_tac.v index 95efde7f..7419f184 100644 --- a/contrib/setoid_ring/Ring_tac.v +++ b/contrib/setoid_ring/Ring_tac.v @@ -3,16 +3,23 @@ Require Import Setoid. Require Import BinPos. Require Import Ring_polynom. Require Import BinList. +Require Import InitialRing. Declare ML Module "newring". - + (* adds a definition id' on the normal form of t and an hypothesis id stating that t = id' (tries to produces a proof as small as possible) *) Ltac compute_assertion id id' t := let t' := eval vm_compute in t in - (pose (id' := t'); - assert (id : t = id'); - [exact_no_check (refl_equal id')|idtac]). + pose (id' := t'); + assert (id : t = id'); + [vm_cast_no_check (refl_equal id')|idtac]. +(* [exact_no_check (refl_equal id'<: t = id')|idtac]). *) + +Ltac getGoal := + match goal with + | |- ?G => G + end. (********************************************************************) (* Tacticals to build reflexive tactics *) @@ -23,7 +30,6 @@ Ltac OnEquation req := | _ => fail 1 "Goal is not an equation (of expected equality)" end. - Ltac OnMainSubgoal H ty := match ty with | _ -> ?ty' => @@ -32,43 +38,54 @@ Ltac OnMainSubgoal H ty := | _ => (fun tac => tac) end. -Ltac ApplyLemmaAndSimpl tac lemma pe:= - let npe := fresh "ast_nf" in +Ltac ApplyLemmaThen lemma expr tac := + let nexpr := fresh "expr_nf" in + let H := fresh "eq_nf" in + let Heq := fresh "thm" in + let nf_spec := + match type of (lemma expr) with + forall x, ?nf_spec = x -> _ => nf_spec + | _ => fail 1 "ApplyLemmaThen: cannot find norm expression" + end in + (compute_assertion H nexpr nf_spec; + (assert (Heq:=lemma _ _ H) || fail "anomaly: failed to apply lemma"); + clear H; + OnMainSubgoal Heq ltac:(type of Heq) ltac:(tac Heq; clear Heq nexpr)). + +Ltac ApplyLemmaThenAndCont lemma expr tac CONT_tac cont_arg := + let npe := fresh "expr_nf" in let H := fresh "eq_nf" in let Heq := fresh "thm" in let npe_spec := - match type of (lemma pe) with + match type of (lemma expr) with forall npe, ?npe_spec = npe -> _ => npe_spec - | _ => fail 1 "ApplyLemmaAndSimpl: cannot find norm expression" + | _ => fail 1 "ApplyLemmaThenAndCont: cannot find norm expression" end in (compute_assertion H npe npe_spec; (assert (Heq:=lemma _ _ H) || fail "anomaly: failed to apply lemma"); clear H; OnMainSubgoal Heq ltac:(type of Heq) - ltac:(tac Heq; rewrite Heq; clear Heq npe)). + ltac:(try tac Heq; clear Heq npe;CONT_tac cont_arg)). (* General scheme of reflexive tactics using of correctness lemma that involves normalisation of one expression *) -Ltac ReflexiveRewriteTactic FV_tac SYN_tac SIMPL_tac lemma2 req rl := - let R := match type of req with ?R -> _ => R end in - (* build the atom list *) - let fv := list_fold_left FV_tac (@List.nil R) rl in - (* some type-checking to avoid late errors *) - (check_fv fv; - (* rewrite steps *) - list_iter - ltac:(fun r => - let ast := SYN_tac r fv in - try ApplyLemmaAndSimpl SIMPL_tac (lemma2 fv) ast) - rl). + +Ltac ReflexiveRewriteTactic FV_tac SYN_tac MAIN_tac LEMMA_tac fv terms := + (* extend the atom list *) + let fv := list_fold_left FV_tac fv terms in + let RW_tac lemma := + let fcons term CONT_tac cont_arg := + let expr := SYN_tac term fv in + (ApplyLemmaThenAndCont lemma expr MAIN_tac CONT_tac cont_arg) in + (* rewrite steps *) + lazy_list_fold_right fcons ltac:(idtac) terms in + LEMMA_tac fv RW_tac. (********************************************************) -(* An object to return when an expression is not recognized as a constant *) -Definition NotConstant := false. - + (* Building the atom list of a ring expression *) -Ltac FV Cst add mul sub opp t fv := +Ltac FV Cst CstPow add mul sub opp pow t fv := let rec TFV t fv := match Cst t with | NotConstant => @@ -77,6 +94,11 @@ Ltac FV Cst add mul sub opp t fv := | (mul ?t1 ?t2) => TFV t2 ltac:(TFV t1 fv) | (sub ?t1 ?t2) => TFV t2 ltac:(TFV t1 fv) | (opp ?t1) => TFV t1 fv + | (pow ?t1 ?n) => + match CstPow n with + | InitialRing.NotConstant => AddFvTail t fv + | _ => TFV t1 fv + end | _ => AddFvTail t fv end | _ => fv @@ -84,10 +106,10 @@ Ltac FV Cst add mul sub opp t fv := in TFV t fv. (* syntaxification of ring expressions *) - Ltac mkPolexpr C Cst radd rmul rsub ropp t fv := +Ltac mkPolexpr C Cst CstPow radd rmul rsub ropp rpow t fv := let rec mkP t := match Cst t with - | NotConstant => + | InitialRing.NotConstant => match t with | (radd ?t1 ?t2) => let e1 := mkP t1 in @@ -100,6 +122,12 @@ Ltac FV Cst add mul sub opp t fv := let e2 := mkP t2 in constr:(PEsub e1 e2) | (ropp ?t1) => let e1 := mkP t1 in constr:(PEopp e1) + | (rpow ?t1 ?n) => + match CstPow n with + | InitialRing.NotConstant => + let p := Find_at t fv in constr:(PEX C p) + | ?c => let e1 := mkP t1 in constr:(PEpow e1 c) + end | _ => let p := Find_at t fv in constr:(PEX C p) end @@ -107,54 +135,222 @@ Ltac FV Cst add mul sub opp t fv := end in mkP t. +Ltac ParseRingComponents lemma := + match type of lemma with + | context + [@PEeval ?R ?rO ?add ?mul ?sub ?opp ?C ?phi ?Cpow ?powphi ?pow _ _] => + (fun f => f R add mul sub opp pow C) + | _ => fail 1 "ring anomaly: bad correctness lemma (parse)" + end. + + (* ring tactics *) - Ltac Ring Cst_tac lemma1 req := - let Make_tac := - match type of lemma1 with - | forall (l:list ?R) (pe1 pe2:PExpr ?C), - _ = true -> - req (PEeval ?rO ?add ?mul ?sub ?opp ?phi l pe1) _ => - let mkFV := FV Cst_tac add mul sub opp in - let mkPol := mkPolexpr C Cst_tac add mul sub opp in - fun f => f R mkFV mkPol - | _ => fail 1 "ring anomaly: bad correctness lemma" +Ltac FV_hypo_tac mkFV req lH := + let R := match type of req with ?R -> _ => R end in + let FV_hypo_l_tac h := + match h with @mkhypo (req ?pe _) _ => mkFV pe end in + let FV_hypo_r_tac h := + match h with @mkhypo (req _ ?pe) _ => mkFV pe end in + let fv := list_fold_right FV_hypo_l_tac (@nil R) lH in + list_fold_right FV_hypo_r_tac fv lH. + +Ltac mkHyp_tac C req mkPE lH := + let mkHyp h res := + match h with + | @mkhypo (req ?r1 ?r2) _ => + let pe1 := mkPE r1 in + let pe2 := mkPE r2 in + constr:(cons (pe1,pe2) res) + | _ => fail "hypothesis is not a ring equality" + end in + list_fold_right mkHyp (@nil (PExpr C * PExpr C)) lH. + +Ltac proofHyp_tac lH := + let get_proof h := + match h with + | @mkhypo _ ?p => p end in - let Main r1 r2 R mkFV mkPol := - let fv := mkFV r1 (@List.nil R) in - let fv := mkFV r2 fv in - check_fv fv; - (let pe1 := mkPol r1 fv in - let pe2 := mkPol r2 fv in - apply (lemma1 fv pe1 pe2) || fail "typing error while applying ring"; - vm_compute; - exact (refl_equal true) || fail "not a valid ring equation") in - Make_tac ltac:(OnEquation req Main). - -Ltac Ring_simplify Cst_tac lemma2 req rl := - let Make_tac := - match type of lemma2 with - forall (l:list ?R) (pe:PExpr ?C) (npe:Pol ?C), - _ = npe -> - req (PEeval ?rO ?add ?mul ?sub ?opp ?phi l pe) _ => - let mkFV := FV Cst_tac add mul sub opp in - let mkPol := mkPolexpr C Cst_tac add mul sub opp in - let simpl_ring H := protect_fv "ring" in H in - (fun tac => tac mkFV mkPol simpl_ring lemma2 req rl) - | _ => fail 1 "ring anomaly: bad correctness lemma" + let rec bh l := + match l with + | nil => constr:(I) + | cons ?h nil => get_proof h + | cons ?h ?tl => + let l := get_proof h in + let r := bh tl in + constr:(conj l r) end in - Make_tac ReflexiveRewriteTactic. + bh lH. + +Definition ring_subst_niter := (10*10*10)%nat. + +Ltac Ring Cst_tac CstPow_tac lemma1 req n lH := + let Main lhs rhs R radd rmul rsub ropp rpow C := + let mkFV := FV Cst_tac CstPow_tac radd rmul rsub ropp rpow in + let mkPol := mkPolexpr C Cst_tac CstPow_tac radd rmul rsub ropp rpow in + let fv := FV_hypo_tac mkFV req lH in + let fv := mkFV lhs fv in + let fv := mkFV rhs fv in + check_fv fv; + let pe1 := mkPol lhs fv in + let pe2 := mkPol rhs fv in + let lpe := mkHyp_tac C req ltac:(fun t => mkPol t fv) lH in + let vlpe := fresh "hyp_list" in + let vfv := fresh "fv_list" in + pose (vlpe := lpe); + pose (vfv := fv); + (apply (lemma1 n vfv vlpe pe1 pe2) + || fail "typing error while applying ring"); + [ ((let prh := proofHyp_tac lH in exact prh) + || idtac "can not automatically proof hypothesis : maybe a left member of a hypothesis is not a monomial") + | vm_compute; + (exact (refl_equal true) || fail "not a valid ring equation")] in + ParseRingComponents lemma1 ltac:(OnEquation req Main). + +Ltac Ring_norm_gen f Cst_tac CstPow_tac lemma2 req n lH rl := + let Main R add mul sub opp pow C := + let mkFV := FV Cst_tac CstPow_tac add mul sub opp pow in + let mkPol := mkPolexpr C Cst_tac CstPow_tac add mul sub opp pow in + let fv := FV_hypo_tac mkFV req lH in + let simpl_ring H := (protect_fv "ring" in H; f H) in + let Coeffs := + match type of lemma2 with + | context [mk_monpol_list ?cO ?cI ?cadd ?cmul ?csub ?copp ?ceqb _] => + (fun f => f cO cI cadd cmul csub copp ceqb) + | _ => fail 1 "ring_simplify anomaly: bad correctness lemma" + end in + let lemma_tac fv RW_tac := + let rr_lemma := fresh "r_rw_lemma" in + let lpe := mkHyp_tac C req ltac:(fun t => mkPol t fv) lH in + let vlpe := fresh "list_hyp" in + let vlmp := fresh "list_hyp_norm" in + let vlmp_eq := fresh "list_hyp_norm_eq" in + let prh := proofHyp_tac lH in + pose (vlpe := lpe); + Coeffs ltac:(fun cO cI cadd cmul csub copp ceqb => + compute_assertion vlmp_eq vlmp + (mk_monpol_list cO cI cadd cmul csub copp ceqb vlpe); + assert (rr_lemma := lemma2 n vlpe fv prh vlmp vlmp_eq) + || fail "type error when build the rewriting lemma"; + RW_tac rr_lemma; + try clear rr_lemma vlmp_eq vlmp vlpe) in + ReflexiveRewriteTactic mkFV mkPol simpl_ring lemma_tac fv rl in + ParseRingComponents lemma2 Main. +Ltac Ring_gen + req sth ext morph arth cst_tac pow_tac lemma1 lemma2 pre post lH rl := + pre();Ring cst_tac pow_tac lemma1 req ring_subst_niter lH. Tactic Notation (at level 0) "ring" := - ring_lookup - (fun req sth ext morph arth cst_tac lemma1 lemma2 pre post rl => - pre(); Ring cst_tac lemma1 req). + let G := getGoal in ring_lookup Ring_gen [] [G]. + +Tactic Notation (at level 0) "ring" "[" constr_list(lH) "]" := + let G := getGoal in ring_lookup Ring_gen [lH] [G]. + +(* Simplification *) + +Ltac Ring_simplify_gen f := + fun req sth ext morph arth cst_tac pow_tac lemma1 lemma2 pre post lH rl => + let l := fresh "to_rewrite" in + pose (l:= rl); + generalize (refl_equal l); + unfold l at 2; + pre(); + match goal with + | [|- l = ?RL -> _ ] => + let Heq := fresh "Heq" in + intros Heq;clear Heq l; + Ring_norm_gen f cst_tac pow_tac lemma2 req ring_subst_niter lH RL; + post() + | _ => fail 1 "ring_simplify anomaly: bad goal after pre" + end. + +Ltac Ring_simplify := Ring_simplify_gen ltac:(fun H => rewrite H). + +Ltac Ring_nf Cst_tac lemma2 req rl f := + let on_rhs H := + match type of H with + | req _ ?rhs => clear H; f rhs + end in + Ring_norm_gen on_rhs Cst_tac lemma2 req rl. + + +Tactic Notation (at level 0) + "ring_simplify" "[" constr_list(lH) "]" constr_list(rl) := + let G := getGoal in ring_lookup Ring_simplify [lH] rl [G]. + +Tactic Notation (at level 0) + "ring_simplify" constr_list(rl) := + let G := getGoal in ring_lookup Ring_simplify [] rl [G]. + + +Tactic Notation "ring_simplify" constr_list(rl) "in" hyp(H):= + let G := getGoal in + let t := type of H in + let g := fresh "goal" in + set (g:= G); + generalize H;clear H; + ring_lookup Ring_simplify [] rl [t]; + intro H; + unfold g;clear g. + +Tactic Notation "ring_simplify" "["constr_list(lH)"]" constr_list(rl) "in" hyp(H):= + let G := getGoal in + let t := type of H in + let g := fresh "goal" in + set (g:= G); + generalize H;clear H; + ring_lookup Ring_simplify [lH] rl [t]; + intro H; + unfold g;clear g. + + +(* + +Ltac Ring_simplify_in hyp:= Ring_simplify_gen ltac:(fun H => rewrite H in hyp). + + +Tactic Notation (at level 0) + "ring_simplify" "[" constr_list(lH) "]" constr_list(rl) := + match goal with [|- ?G] => ring_lookup Ring_simplify [lH] rl [G] end. + +Tactic Notation (at level 0) + "ring_simplify" constr_list(rl) := + match goal with [|- ?G] => ring_lookup Ring_simplify [] rl [G] end. + +Tactic Notation (at level 0) + "ring_simplify" "[" constr_list(lH) "]" constr_list(rl) "in" hyp(h):= + let t := type of h in + ring_lookup + (fun req sth ext morph arth cst_tac pow_tac lemma1 lemma2 pre post lH rl => + pre(); + Ring_norm_gen ltac:(fun EQ => rewrite EQ in h) cst_tac pow_tac lemma2 req ring_subst_niter lH rl; + post()) + [lH] rl [t]. +(* ring_lookup ltac:(Ring_simplify_in h) [lH] rl [t]. NE MARCHE PAS ??? *) + +Ltac Ring_simpl_in hyp := Ring_norm_gen ltac:(fun H => rewrite H in hyp). + +Tactic Notation (at level 0) + "ring_simplify" constr_list(rl) "in" constr(h):= + let t := type of h in + ring_lookup + (fun req sth ext morph arth cst_tac pow_tac lemma1 lemma2 pre post lH rl => + pre(); + Ring_simpl_in h cst_tac pow_tac lemma2 req ring_subst_niter lH rl; + post()) + [] rl [t]. + +Ltac rw_in H Heq := rewrite Heq in H. + +Ltac simpl_in H := + let t := type of H in + ring_lookup + (fun req sth ext morph arth cst_tac pow_tac lemma1 lemma2 pre post lH rl => + pre(); + Ring_norm_gen ltac:(fun Heq => rewrite Heq in H) cst_tac pow_tac lemma2 req ring_subst_niter lH rl; + post()) + [] [t]. -Tactic Notation (at level 0) "ring_simplify" constr_list(rl) := - ring_lookup - (fun req sth ext morph arth cst_tac lemma1 lemma2 pre post rl => - pre(); Ring_simplify cst_tac lemma2 req rl; post()) rl. -(* A simple macro tactic to be prefered to ring_simplify *) -Ltac ring_replace t1 t2 := replace t1 with t2 by ring. +*) diff --git a/contrib/setoid_ring/Ring_theory.v b/contrib/setoid_ring/Ring_theory.v index 2f7378eb..5498911d 100644 --- a/contrib/setoid_ring/Ring_theory.v +++ b/contrib/setoid_ring/Ring_theory.v @@ -7,6 +7,9 @@ (************************************************************************) Require Import Setoid. +Require Import BinPos. +Require Import BinNat. + Set Implicit Arguments. Module RingSyntax. @@ -27,6 +30,71 @@ Reserved Notation "x == y" (at level 70, no associativity). End RingSyntax. Import RingSyntax. +Section Power. + Variable R:Type. + Variable rI : R. + Variable rmul : R -> R -> R. + Variable req : R -> R -> Prop. + Variable Rsth : Setoid_Theory R req. + Notation "x * y " := (rmul x y). + Notation "x == y" := (req x y). + + Hypothesis mul_ext : + forall x1 x2, x1 == x2 -> forall y1 y2, y1 == y2 -> x1 * y1 == x2 * y2. + Hypothesis mul_comm : forall x y, x * y == y * x. + Hypothesis mul_assoc : forall x y z, x * (y * z) == (x * y) * z. + Add Setoid R req Rsth as R_set_Power. + Add Morphism rmul : rmul_ext_Power. exact mul_ext. Qed. + + + Fixpoint pow_pos (x:R) (i:positive) {struct i}: R := + match i with + | xH => x + | xO i => let p := pow_pos x i in rmul p p + | xI i => let p := pow_pos x i in rmul x (rmul p p) + end. + + Lemma pow_pos_Psucc : forall x j, pow_pos x (Psucc j) == x * pow_pos x j. + Proof. + induction j;simpl. + rewrite IHj. + rewrite (mul_comm x (pow_pos x j *pow_pos x j)). + set (w:= x*pow_pos x j);unfold w at 2. + rewrite (mul_comm x (pow_pos x j));unfold w. + repeat rewrite mul_assoc. apply (Seq_refl _ _ Rsth). + repeat rewrite mul_assoc. apply (Seq_refl _ _ Rsth). + apply (Seq_refl _ _ Rsth). + Qed. + + Lemma pow_pos_Pplus : forall x i j, pow_pos x (i + j) == pow_pos x i * pow_pos x j. + Proof. + intro x;induction i;intros. + rewrite xI_succ_xO;rewrite Pplus_one_succ_r. + rewrite <- Pplus_diag;repeat rewrite <- Pplus_assoc. + repeat rewrite IHi. + rewrite Pplus_comm;rewrite <- Pplus_one_succ_r;rewrite pow_pos_Psucc. + simpl;repeat rewrite mul_assoc. apply (Seq_refl _ _ Rsth). + rewrite <- Pplus_diag;repeat rewrite <- Pplus_assoc. + repeat rewrite IHi;rewrite mul_assoc. apply (Seq_refl _ _ Rsth). + rewrite Pplus_comm;rewrite <- Pplus_one_succ_r;rewrite pow_pos_Psucc; + simpl. apply (Seq_refl _ _ Rsth). + Qed. + + Definition pow_N (x:R) (p:N) := + match p with + | N0 => rI + | Npos p => pow_pos x p + end. + + Definition id_phi_N (x:N) : N := x. + + Lemma pow_N_pow_N : forall x n, pow_N x (id_phi_N n) == pow_N x n. + Proof. + intros; apply (Seq_refl _ _ Rsth). + Qed. + +End Power. + Section DEFINITIONS. Variable R : Type. Variable (rO rI : R) (radd rmul rsub: R->R->R) (ropp : R -> R). @@ -126,6 +194,19 @@ Section DEFINITIONS. morph_opp : forall x, [-!x] == -[x]; morph_eq : forall x y, x?=!y = true -> [x] == [y] }. + + Section SIGN. + Variable get_sign : C -> option C. + Record sign_theory : Prop := mksign_th { + sign_spec : forall c c', get_sign c = Some c' -> [c] == - [c'] + }. + End SIGN. + + Definition get_sign_None (c:C) := @None C. + + Lemma get_sign_None_th : sign_theory get_sign_None. + Proof. constructor;intros;discriminate. Qed. + End MORPHISM. (** Identity is a morphism *) @@ -140,6 +221,20 @@ Section DEFINITIONS. try apply (Seq_refl _ _ Rsth);auto. Qed. + (** Specification of the power function *) + Section POWER. + Variable Cpow : Set. + Variable Cp_phi : N -> Cpow. + Variable rpow : R -> Cpow -> R. + + Record power_theory : Prop := mkpow_th { + rpow_pow_N : forall r n, req (rpow r (Cp_phi n)) (pow_N rI rmul r n) + }. + + End POWER. + + Definition pow_N_th := mkpow_th id_phi_N (pow_N rI rmul) (pow_N_pow_N rI rmul Rsth). + End DEFINITIONS. @@ -437,11 +532,12 @@ Qed. End ALMOST_RING. + Section AddRing. - Variable R : Type. +(* Variable R : Type. Variable (rO rI : R) (radd rmul rsub: R->R->R) (ropp : R -> R). - Variable req : R -> R -> Prop. + Variable req : R -> R -> Prop. *) Inductive ring_kind : Type := | Abstract @@ -461,6 +557,7 @@ Inductive ring_kind : Type := (_ : ring_morph rO rI radd rmul rsub ropp req cO cI cadd cmul csub copp ceqb phi). + End AddRing. diff --git a/contrib/setoid_ring/ZArithRing.v b/contrib/setoid_ring/ZArithRing.v index 4f47fff0..8de7021e 100644 --- a/contrib/setoid_ring/ZArithRing.v +++ b/contrib/setoid_ring/ZArithRing.v @@ -8,26 +8,49 @@ Require Export Ring. Require Import ZArith_base. +Require Import Zpow_def. + Import InitialRing. Set Implicit Arguments. -Ltac isZcst t := - let t := eval hnf in t in - match t with - Z0 => constr:true - | Zpos ?p => isZcst p - | Zneg ?p => isZcst p - | xI ?p => isZcst p - | xO ?p => isZcst p - | xH => constr:true - | _ => constr:false - end. Ltac Zcst t := match isZcst t with true => t | _ => NotConstant end. +Ltac isZpow_coef t := + match t with + | Zpos ?p => isPcst p + | Z0 => true + | _ => false + end. + +Definition N_of_Z x := + match x with + | Zpos p => Npos p + | _ => N0 + end. + +Ltac Zpow_tac t := + match isZpow_coef t with + | true => constr:(N_of_Z t) + | _ => constr:(NotConstant) + end. + +Ltac Zpower_neg := + repeat match goal with + | [|- ?G] => + match G with + | context c [Zpower _ (Zneg _)] => + let t := context c [Z0] in + change t + end + end. + + Add Ring Zr : Zth - (decidable Zeqb_ok, constants [Zcst], preprocess [unfold Zsucc]). + (decidable Zeqb_ok, constants [Zcst], preprocess [Zpower_neg;unfold Zsucc], + power_tac Zpower_theory [Zpow_tac]). + diff --git a/contrib/setoid_ring/newring.ml4 b/contrib/setoid_ring/newring.ml4 index daa2fedb..8b2ce26b 100644 --- a/contrib/setoid_ring/newring.ml4 +++ b/contrib/setoid_ring/newring.ml4 @@ -8,7 +8,7 @@ (*i camlp4deps: "parsing/grammar.cma" i*) -(*i $Id: newring.ml4 9302 2006-10-27 21:21:17Z barras $ i*) +(*i $Id: newring.ml4 9603 2007-02-07 00:41:16Z barras $ i*) open Pp open Util @@ -127,6 +127,12 @@ TACTIC EXTEND closed_term [ closed_term t l ] END ;; + +TACTIC EXTEND echo +| [ "echo" constr(t) ] -> + [ Pp.msg (Termops.print_constr t); Tacinterp.eval_tactic (TacId []) ] +END;; + (* let closed_term_ast l = TacFun([Some(id_of_string"t")], @@ -196,7 +202,8 @@ let constr_of = function let stdlib_modules = [["Coq";"Setoids";"Setoid"]; - ["Coq";"Lists";"List"] + ["Coq";"Lists";"List"]; + ["Coq";"Init";"Datatypes"] ] let coq_constant c = @@ -205,18 +212,24 @@ let coq_constant c = let coq_mk_Setoid = coq_constant "Build_Setoid_Theory" let coq_cons = coq_constant "cons" let coq_nil = coq_constant "nil" +let coq_None = coq_constant "None" +let coq_Some = coq_constant "Some" let lapp f args = mkApp(Lazy.force f,args) +let dest_rel0 t = + match kind_of_term t with + | App(f,args) when Array.length args >= 2 -> + let rel = mkApp(f,Array.sub args 0 (Array.length args - 2)) in + if closed0 rel then + (rel,args.(Array.length args - 2),args.(Array.length args - 1)) + else error "ring: cannot find relation (not closed)" + | _ -> error "ring: cannot find relation" + let rec dest_rel t = match kind_of_term t with - App(f,args) when Array.length args >= 2 -> - let rel = mkApp(f,Array.sub args 0 (Array.length args - 2)) in - if closed0 rel then - (rel,args.(Array.length args - 2),args.(Array.length args - 1)) - else error "ring: cannot find relation (not closed)" - | Prod(_,_,c) -> dest_rel c - | _ -> error "ring: cannot find relation" + | Prod(_,_,c) -> dest_rel c + | _ -> dest_rel0 t (****************************************************************************) (* Library linking *) @@ -265,11 +278,18 @@ let coq_mk_seqe = my_constant "mk_seqe" let ltac_inv_morphZ = zltac"inv_gen_phiZ" let ltac_inv_morphN = zltac"inv_gen_phiN" - let coq_abstract = my_constant"Abstract" let coq_comp = my_constant"Computational" let coq_morph = my_constant"Morphism" +(* power function *) +let ltac_inv_morph_nothing = zltac"inv_morph_nothing" +let coq_pow_N_pow_N = my_constant "pow_N_pow_N" + +(* hypothesis *) +let coq_mkhypo = my_constant "mkhypo" +let coq_hypo = my_constant "hypo" + (* Equality: do not evaluate but make recursive call on both sides *) let map_with_eq arg_map c = let (req,_,_) = dest_rel c in @@ -283,10 +303,12 @@ let _ = add_map "ring" coq_nil, (function -1->Eval|_ -> Prot); (* Pphi_dev: evaluate polynomial and coef operations, protect ring operations and make recursive call on the var map *) - pol_cst "Pphi_dev", (function -1|6|7|8|9|11->Eval|10->Rec|_->Prot); + pol_cst "Pphi_dev", (function -1|8|9|10|11|12|14->Eval|13->Rec|_->Prot); + pol_cst "Pphi_pow", + (function -1|8|9|10|11|13|15|17->Eval|16->Rec|_->Prot); (* PEeval: evaluate morphism and polynomial, protect ring operations and make recursive call on the var map *) - pol_cst "PEeval", (function -1|7|9->Eval|8->Rec|_->Prot)]) + pol_cst "PEeval", (function -1|7|9|12->Eval|11->Rec|_->Prot)]) (****************************************************************************) (* Ring database *) @@ -299,6 +321,7 @@ type ring_info = ring_morph : constr; ring_th : constr; ring_cst_tac : glob_tactic_expr; + ring_pow_tac : glob_tactic_expr; ring_lemma1 : constr; ring_lemma2 : constr; ring_pre_tac : glob_tactic_expr; @@ -316,7 +339,7 @@ let ring_lookup_by_name ref = Spmap.find (Nametab.locate_obj (snd(qualid_of_reference ref))) !from_name -let find_ring_structure env sigma l cl oname = +let find_ring_structure env sigma l oname = match oname, l with Some rf, _ -> (try ring_lookup_by_name rf @@ -337,13 +360,14 @@ let find_ring_structure env sigma l cl oname = errorlabstrm "ring" (str"cannot find a declared ring structure over"++ spc()++str"\""++pr_constr ty++str"\"")) - | None, [] -> + | None, [] -> assert false +(* let (req,_,_) = dest_rel cl in (try ring_for_relation req with Not_found -> errorlabstrm "ring" (str"cannot find a declared ring structure for equality"++ - spc()++str"\""++pr_constr req++str"\"")) + spc()++str"\""++pr_constr req++str"\"")) *) let _ = Summary.declare_summary "tactic-new-ring-table" @@ -378,6 +402,7 @@ let subst_th (_,subst,th) = let thm1' = subst_mps subst th.ring_lemma1 in let thm2' = subst_mps subst th.ring_lemma2 in let tac'= subst_tactic subst th.ring_cst_tac in + let pow_tac'= subst_tactic subst th.ring_pow_tac in let pretac'= subst_tactic subst th.ring_pre_tac in let posttac'= subst_tactic subst th.ring_post_tac in if c' == th.ring_carrier && @@ -389,6 +414,7 @@ let subst_th (_,subst,th) = thm1' == th.ring_lemma1 && thm2' == th.ring_lemma2 && tac' == th.ring_cst_tac && + pow_tac' == th.ring_pow_tac && pretac' == th.ring_pre_tac && posttac' == th.ring_post_tac then th else @@ -399,6 +425,7 @@ let subst_th (_,subst,th) = ring_morph = morph'; ring_th = th'; ring_cst_tac = tac'; + ring_pow_tac = pow_tac'; ring_lemma1 = thm1'; ring_lemma2 = thm2'; ring_pre_tac = pretac'; @@ -532,14 +559,50 @@ let interp_cst_tac kind (zero,one,add,mul,opp) cst_tac = TacArg(TacCall(dummy_loc,t,List.map carg [zero;one;add;mul;opp])) | _ -> error"a tactic must be specified for an almost_ring") -let add_theory name rth eqth morphth cst_tac (pre,post) = +let make_hyp env c = + let t = (Typeops.typing env c).uj_type in + lapp coq_mkhypo [|t;c|] + +let make_hyp_list env lH = + let carrier = Lazy.force coq_hypo in + List.fold_right + (fun c l -> lapp coq_cons [|carrier; (make_hyp env c); l|]) lH + (lapp coq_nil [|carrier|]) + +let interp_power env pow = + let carrier = Lazy.force coq_hypo in + match pow with + | None -> + let t = ArgArg(dummy_loc, Lazy.force ltac_inv_morph_nothing) in + (TacArg(TacCall(dummy_loc,t,[])), lapp coq_None [|carrier|]) + | Some (tac, spec) -> + let tac = + match tac with + | CstTac t -> Tacinterp.glob_tactic t + | Closed lc -> closed_term_ast (List.map Nametab.global lc) in + let spec = make_hyp env (ic spec) in + (tac, lapp coq_Some [|carrier; spec|]) + +let interp_sign env sign = + let carrier = Lazy.force coq_hypo in + match sign with + | None -> lapp coq_None [|carrier|] + | Some spec -> + let spec = make_hyp env (ic spec) in + lapp coq_Some [|carrier;spec|] + (* Same remark on ill-typed terms ... *) + +let add_theory name rth eqth morphth cst_tac (pre,post) power sign = let env = Global.env() in let sigma = Evd.empty in let (kind,r,zero,one,add,mul,sub,opp,req) = dest_ring env sigma rth in let (sth,ext) = build_setoid_params r add mul opp req eqth in + let (pow_tac, pspec) = interp_power env power in + let sspec = interp_sign env sign in let rk = reflect_coeff morphth in let params = - exec_tactic env 5 (zltac"ring_lemmas") (List.map carg[sth;ext;rth;rk]) in + exec_tactic env 5 (zltac "ring_lemmas") + (List.map carg[sth;ext;rth;pspec;sspec;rk]) in let lemma1 = constr_of params.(3) in let lemma2 = constr_of params.(4) in @@ -564,6 +627,7 @@ let add_theory name rth eqth morphth cst_tac (pre,post) = ring_morph = constr_of params.(2); ring_th = constr_of params.(0); ring_cst_tac = cst_tac; + ring_pow_tac = pow_tac; ring_lemma1 = lemma1; ring_lemma2 = lemma2; ring_pre_tac = pretac; @@ -576,6 +640,10 @@ type ring_mod = | Pre_tac of raw_tactic_expr | Post_tac of raw_tactic_expr | Setoid of Topconstr.constr_expr * Topconstr.constr_expr + | Pow_spec of cst_tac_spec * Topconstr.constr_expr + (* Syntaxification tactic , correctness lemma *) + | Sign_spec of Topconstr.constr_expr + VERNAC ARGUMENT EXTEND ring_mod | [ "decidable" constr(eq_test) ] -> [ Ring_kind(Computational (ic eq_test)) ] @@ -586,6 +654,11 @@ VERNAC ARGUMENT EXTEND ring_mod | [ "preprocess" "[" tactic(pre) "]" ] -> [ Pre_tac pre ] | [ "postprocess" "[" tactic(post) "]" ] -> [ Post_tac post ] | [ "setoid" constr(sth) constr(ext) ] -> [ Setoid(sth,ext) ] + | [ "sign" constr(sign_spec) ] -> [ Sign_spec sign_spec ] + | [ "power" constr(pow_spec) "[" ne_global_list(l) "]" ] -> + [ Pow_spec (Closed l, pow_spec) ] + | [ "power_tac" constr(pow_spec) "[" tactic(cst_tac) "]" ] -> + [ Pow_spec (CstTac cst_tac, pow_spec) ] END let set_once s r v = @@ -597,45 +670,54 @@ let process_ring_mods l = let cst_tac = ref None in let pre = ref None in let post = ref None in + let sign = ref None in + let power = ref None in List.iter(function Ring_kind k -> set_once "ring kind" kind k | Const_tac t -> set_once "tactic recognizing constants" cst_tac t | Pre_tac t -> set_once "preprocess tactic" pre t | Post_tac t -> set_once "postprocess tactic" post t - | Setoid(sth,ext) -> set_once "setoid" set (ic sth,ic ext)) l; + | Setoid(sth,ext) -> set_once "setoid" set (ic sth,ic ext) + | Pow_spec(t,spec) -> set_once "power" power (t,spec) + | Sign_spec t -> set_once "sign" sign t) l; let k = match !kind with Some k -> k | None -> Abstract in - (k, !set, !cst_tac, !pre, !post) + (k, !set, !cst_tac, !pre, !post, !power, !sign) VERNAC COMMAND EXTEND AddSetoidRing | [ "Add" "Ring" ident(id) ":" constr(t) ring_mods(l) ] -> - [ let (k,set,cst,pre,post) = process_ring_mods l in - add_theory id (ic t) set k cst (pre,post) ] + [ let (k,set,cst,pre,post,power,sign) = process_ring_mods l in + add_theory id (ic t) set k cst (pre,post) power sign ] END (*****************************************************************************) (* The tactics consist then only in a lookup in the ring database and call the appropriate ltac. *) -let make_term_list carrier rl gl = - let rl = - match rl with - [] -> let (_,t1,t2) = dest_rel (pf_concl gl) in [t1;t2] - | _ -> rl in +let make_args_list rl t = + match rl with + | [] -> let (_,t1,t2) = dest_rel0 t in [t1;t2] + | _ -> rl + +let make_term_list carrier rl = List.fold_right (fun x l -> lapp coq_cons [|carrier;x;l|]) rl (lapp coq_nil [|carrier|]) -let ring_lookup (f:glob_tactic_expr) rl gl = + +let ring_lookup (f:glob_tactic_expr) lH rl t gl = let env = pf_env gl in let sigma = project gl in - let e = find_ring_structure env sigma rl (pf_concl gl) None in - let rl = carg (make_term_list e.ring_carrier rl gl) in + let rl = make_args_list rl t in + let e = find_ring_structure env sigma rl None in + let rl = carg (make_term_list e.ring_carrier rl) in + let lH = carg (make_hyp_list env lH) in let req = carg e.ring_req in let sth = carg e.ring_setoid in let ext = carg e.ring_ext in let morph = carg e.ring_morph in let th = carg e.ring_th in let cst_tac = Tacexp e.ring_cst_tac in + let pow_tac = Tacexp e.ring_pow_tac in let lemma1 = carg e.ring_lemma1 in let lemma2 = carg e.ring_lemma2 in let pretac = Tacexp(TacFun([None],e.ring_pre_tac)) in @@ -644,12 +726,17 @@ let ring_lookup (f:glob_tactic_expr) rl gl = (TacLetIn ([(dummy_loc,id_of_string"f"),None,Tacexp f], ltac_lcall "f" - [req;sth;ext;morph;th;cst_tac;lemma1;lemma2;pretac;posttac;rl])) gl + [req;sth;ext;morph;th;cst_tac;pow_tac; + lemma1;lemma2;pretac;posttac;lH;rl])) gl TACTIC EXTEND ring_lookup -| [ "ring_lookup" tactic(f) constr_list(l) ] -> [ ring_lookup (fst f) l ] +| [ "ring_lookup" tactic(f) "[" constr_list(lH) "]" constr_list(lr) + "[" constr(t) "]" ] -> + [ring_lookup (fst f) lH lr t] END + + (***********************************************************************) let new_field_path = @@ -666,14 +753,20 @@ let _ = add_map "field" (* display_linear: evaluate polynomials and coef operations, protect field operations and make recursive call on the var map *) my_constant "display_linear", - (function -1|7|8|9|10|12|13->Eval|11->Rec|_->Prot); - (* Pphi_dev: evaluate polynomial and coef operations, protect + (function -1|9|10|11|12|13|15|16->Eval|14->Rec|_->Prot); + my_constant "display_pow_linear", + (function -1|9|10|11|12|13|14|16|18|19->Eval|17->Rec|_->Prot); + (* Pphi_dev: evaluate polynomial and coef operations, protect ring operations and make recursive call on the var map *) - my_constant "Pphi_dev", (function -1|6|7|8|9|11->Eval|10->Rec|_->Prot); + pol_cst "Pphi_dev", (function -1|8|9|10|11|12|14->Eval|13->Rec|_->Prot); + pol_cst "Pphi_pow", + (function -1|8|9|10|11|13|15|17->Eval|16->Rec|_->Prot); (* PEeval: evaluate morphism and polynomial, protect ring operations and make recursive call on the var map *) - my_constant "FEeval", (function -1|9|11->Eval|10->Rec|_->Prot)]);; - + pol_cst "PEeval", (function -1|7|9|12->Eval|11->Rec|_->Prot); + (* FEeval: evaluate morphism, protect field + operations and make recursive call on the var map *) + my_constant "FEeval", (function -1|8|9|10|11|14->Eval|13->Rec|_->Prot)]);; let _ = add_map "field_cond" (map_with_eq @@ -681,7 +774,8 @@ let _ = add_map "field_cond" coq_nil, (function -1->Eval|_ -> Prot); (* PCond: evaluate morphism and denum list, protect ring operations and make recursive call on the var map *) - my_constant "PCond", (function -1|8|10->Eval|9->Rec|_->Prot)]);; + my_constant "PCond", (function -1|8|10|13->Eval|12->Rec|_->Prot)]);; +(* (function -1|8|10->Eval|9->Rec|_->Prot)]);;*) let afield_theory = my_constant "almost_field_theory" @@ -715,9 +809,11 @@ type field_info = { field_carrier : types; field_req : constr; field_cst_tac : glob_tactic_expr; + field_pow_tac : glob_tactic_expr; field_ok : constr; field_simpl_eq_ok : constr; field_simpl_ok : constr; + field_simpl_eq_in_ok : constr; field_cond : constr; field_pre_tac : glob_tactic_expr; field_post_tac : glob_tactic_expr } @@ -734,7 +830,7 @@ let field_lookup_by_name ref = !field_from_name -let find_field_structure env sigma l cl oname = +let find_field_structure env sigma l oname = check_required_library (cdir@["Field_tac"]); match oname, l with Some rf, _ -> @@ -756,13 +852,13 @@ let find_field_structure env sigma l cl oname = errorlabstrm "field" (str"cannot find a declared field structure over"++ spc()++str"\""++pr_constr ty++str"\"")) - | None, [] -> - let (req,_,_) = dest_rel cl in + | None, [] -> assert false +(* let (req,_,_) = dest_rel cl in (try field_for_relation req with Not_found -> errorlabstrm "field" (str"cannot find a declared field structure for equality"++ - spc()++str"\""++pr_constr req++str"\"")) + spc()++str"\""++pr_constr req++str"\"")) *) let _ = Summary.declare_summary "tactic-new-field-table" @@ -796,8 +892,10 @@ let subst_th (_,subst,th) = let thm1' = subst_mps subst th.field_ok in let thm2' = subst_mps subst th.field_simpl_eq_ok in let thm3' = subst_mps subst th.field_simpl_ok in - let thm4' = subst_mps subst th.field_cond in + let thm4' = subst_mps subst th.field_simpl_eq_in_ok in + let thm5' = subst_mps subst th.field_cond in let tac'= subst_tactic subst th.field_cst_tac in + let pow_tac' = subst_tactic subst th.field_pow_tac in let pretac'= subst_tactic subst th.field_pre_tac in let posttac'= subst_tactic subst th.field_post_tac in if c' == th.field_carrier && @@ -805,18 +903,22 @@ let subst_th (_,subst,th) = thm1' == th.field_ok && thm2' == th.field_simpl_eq_ok && thm3' == th.field_simpl_ok && - thm4' == th.field_cond && + thm4' == th.field_simpl_eq_in_ok && + thm5' == th.field_cond && tac' == th.field_cst_tac && + pow_tac' == th.field_pow_tac && pretac' == th.field_pre_tac && posttac' == th.field_post_tac then th else { field_carrier = c'; field_req = eq'; field_cst_tac = tac'; + field_pow_tac = pow_tac'; field_ok = thm1'; field_simpl_eq_ok = thm2'; field_simpl_ok = thm3'; - field_cond = thm4'; + field_simpl_eq_in_ok = thm4'; + field_cond = thm5'; field_pre_tac = pretac'; field_post_tac = posttac' } @@ -850,30 +952,34 @@ let default_field_equality r inv req = error "field inverse should be declared as a morphism" in inv_m.lem -let add_field_theory name fth eqth morphth cst_tac inj (pre,post) = +let add_field_theory name fth eqth morphth cst_tac inj (pre,post) power sign = let env = Global.env() in let sigma = Evd.empty in let (kind,r,zero,one,add,mul,sub,opp,div,inv,req,rth) = dest_field env sigma fth in let (sth,ext) = build_setoid_params r add mul opp req eqth in let eqth = Some(sth,ext) in - let _ = add_theory name rth eqth morphth cst_tac (None,None) in + let _ = add_theory name rth eqth morphth cst_tac (None,None) power sign in + let (pow_tac, pspec) = interp_power env power in + let sspec = interp_sign env sign in let inv_m = default_field_equality r inv req in let rk = reflect_coeff morphth in let params = - exec_tactic env 8 (field_ltac"field_lemmas") - (List.map carg[sth;ext;inv_m;fth;rk]) in + exec_tactic env 9 (field_ltac"field_lemmas") + (List.map carg[sth;ext;inv_m;fth;pspec;sspec;rk]) in let lemma1 = constr_of params.(3) in let lemma2 = constr_of params.(4) in let lemma3 = constr_of params.(5) in + let lemma4 = constr_of params.(6) in let cond_lemma = match inj with - | Some thm -> mkApp(constr_of params.(7),[|thm|]) - | None -> constr_of params.(6) in + | Some thm -> mkApp(constr_of params.(8),[|thm|]) + | None -> constr_of params.(7) in let lemma1 = decl_constant (string_of_id name^"_field_lemma1") lemma1 in let lemma2 = decl_constant (string_of_id name^"_field_lemma2") lemma2 in let lemma3 = decl_constant (string_of_id name^"_field_lemma3") lemma3 in - let cond_lemma = decl_constant (string_of_id name^"_lemma4") cond_lemma in + let lemma4 = decl_constant (string_of_id name^"_field_lemma4") lemma4 in + let cond_lemma = decl_constant (string_of_id name^"_lemma5") cond_lemma in let cst_tac = interp_cst_tac kind (zero,one,add,mul,opp) cst_tac in let pretac = match pre with @@ -889,9 +995,11 @@ let add_field_theory name fth eqth morphth cst_tac inj (pre,post) = { field_carrier = r; field_req = req; field_cst_tac = cst_tac; + field_pow_tac = pow_tac; field_ok = lemma1; field_simpl_eq_ok = lemma2; field_simpl_ok = lemma3; + field_simpl_eq_in_ok = lemma4; field_cond = cond_lemma; field_pre_tac = pretac; field_post_tac = posttac }) in () @@ -902,7 +1010,7 @@ type field_mod = VERNAC ARGUMENT EXTEND field_mod | [ ring_mod(m) ] -> [ Ring_mod m ] - | [ "infinite" constr(inj) ] -> [ Inject inj ] + | [ "completeness" constr(inj) ] -> [ Inject inj ] END let process_field_mods l = @@ -911,7 +1019,9 @@ let process_field_mods l = let cst_tac = ref None in let pre = ref None in let post = ref None in - let inj = ref None in + let inj = ref None in + let sign = ref None in + let power = ref None in List.iter(function Ring_mod(Ring_kind k) -> set_once "field kind" kind k | Ring_mod(Const_tac t) -> @@ -919,26 +1029,32 @@ let process_field_mods l = | Ring_mod(Pre_tac t) -> set_once "preprocess tactic" pre t | Ring_mod(Post_tac t) -> set_once "postprocess tactic" post t | Ring_mod(Setoid(sth,ext)) -> set_once "setoid" set (ic sth,ic ext) + | Ring_mod(Pow_spec(t,spec)) -> set_once "power" power (t,spec) + | Ring_mod(Sign_spec t) -> set_once "sign" sign t | Inject i -> set_once "infinite property" inj (ic i)) l; let k = match !kind with Some k -> k | None -> Abstract in - (k, !set, !inj, !cst_tac, !pre, !post) + (k, !set, !inj, !cst_tac, !pre, !post, !power, !sign) VERNAC COMMAND EXTEND AddSetoidField | [ "Add" "Field" ident(id) ":" constr(t) field_mods(l) ] -> - [ let (k,set,inj,cst_tac,pre,post) = process_field_mods l in - add_field_theory id (ic t) set k cst_tac inj (pre,post) ] + [ let (k,set,inj,cst_tac,pre,post,power,sign) = process_field_mods l in + add_field_theory id (ic t) set k cst_tac inj (pre,post) power sign] END -let field_lookup (f:glob_tactic_expr) rl gl = +let field_lookup (f:glob_tactic_expr) lH rl t gl = let env = pf_env gl in let sigma = project gl in - let e = find_field_structure env sigma rl (pf_concl gl) None in - let rl = carg (make_term_list e.field_carrier rl gl) in + let rl = make_args_list rl t in + let e = find_field_structure env sigma rl None in + let rl = carg (make_term_list e.field_carrier rl) in + let lH = carg (make_hyp_list env lH) in let req = carg e.field_req in let cst_tac = Tacexp e.field_cst_tac in + let pow_tac = Tacexp e.field_pow_tac in let field_ok = carg e.field_ok in let field_simpl_ok = carg e.field_simpl_ok in let field_simpl_eq_ok = carg e.field_simpl_eq_ok in + let field_simpl_eq_in_ok = carg e.field_simpl_eq_in_ok in let cond_ok = carg e.field_cond in let pretac = Tacexp(TacFun([None],e.field_pre_tac)) in let posttac = Tacexp(TacFun([None],e.field_post_tac)) in @@ -946,9 +1062,11 @@ let field_lookup (f:glob_tactic_expr) rl gl = (TacLetIn ([(dummy_loc,id_of_string"f"),None,Tacexp f], ltac_lcall "f" - [req;cst_tac;field_ok;field_simpl_ok;field_simpl_eq_ok;cond_ok; - pretac;posttac;rl])) gl + [req;cst_tac;pow_tac;field_ok;field_simpl_ok;field_simpl_eq_ok; + field_simpl_eq_in_ok;cond_ok;pretac;posttac;lH;rl])) gl TACTIC EXTEND field_lookup -| [ "field_lookup" tactic(f) constr_list(l) ] -> [ field_lookup (fst f) l ] +| [ "field_lookup" tactic(f) "[" constr_list(lH) "]" constr_list(l) + "[" constr(t) "]" ] -> + [ field_lookup (fst f) lH l t ] END diff --git a/contrib/subtac/FixSub.v b/contrib/subtac/FixSub.v index ded069bf..46121ff1 100644 --- a/contrib/subtac/FixSub.v +++ b/contrib/subtac/FixSub.v @@ -1,37 +1,87 @@ Require Import Wf. +Require Import Coq.subtac.Utils. Section Well_founded. -Variable A : Set. -Variable R : A -> A -> Prop. -Hypothesis Rwf : well_founded R. + Variable A : Type. + Variable R : A -> A -> Prop. + Hypothesis Rwf : well_founded R. + + Section Acc. + + Variable P : A -> Type. + + Variable F_sub : forall x:A, (forall y: { y : A | R y x }, P (proj1_sig y)) -> P x. + + Fixpoint Fix_F_sub (x : A) (r : Acc R x) {struct r} : P x := + F_sub x (fun y: { y : A | R y x} => Fix_F_sub (proj1_sig y) + (Acc_inv r (proj1_sig y) (proj2_sig y))). + + Definition Fix_sub (x : A) := Fix_F_sub x (Rwf x). + End Acc. + + Section FixPoint. + Variable P : A -> Type. + + Variable F_sub : forall x:A, (forall y: { y : A | R y x }, P (proj1_sig y)) -> P x. + + Notation Fix_F := (Fix_F_sub P F_sub) (only parsing). (* alias *) + + Definition Fix (x:A) := Fix_F_sub P F_sub x (Rwf x). + + Hypothesis + F_ext : + forall (x:A) (f g:forall y:{y:A | R y x}, P (`y)), + (forall y:{ y:A | R y x}, f y = g y) -> F_sub x f = F_sub x g. -Section FixPoint. - -Variable P : A -> Set. + Lemma Fix_F_eq : + forall (x:A) (r:Acc R x), + F_sub x (fun (y:{y:A|R y x}) => Fix_F (`y) (Acc_inv r (proj1_sig y) (proj2_sig y))) = Fix_F x r. + Proof. + destruct r using Acc_inv_dep; auto. + Qed. + + Lemma Fix_F_inv : forall (x:A) (r s:Acc R x), Fix_F x r = Fix_F x s. + Proof. + intro x; induction (Rwf x); intros. + rewrite <- (Fix_F_eq x r); rewrite <- (Fix_F_eq x s); intros. + apply F_ext; auto. + intros. + rewrite (proof_irrelevance (Acc R x) r s) ; auto. + Qed. -Variable F_sub : forall x:A, (forall y: { y : A | R y x }, P (proj1_sig y)) -> P x. - -Fixpoint Fix_F_sub (x : A) (r : Acc R x) {struct r} : P x := - F_sub x (fun y: { y : A | R y x} => Fix_F_sub (proj1_sig y) - (Acc_inv r (proj1_sig y) (proj2_sig y))). + Lemma Fix_eq : forall x:A, Fix x = F_sub x (fun (y:{y:A|R y x}) => Fix (proj1_sig y)). + Proof. + intro x; unfold Fix in |- *. + rewrite <- (Fix_F_eq ). + apply F_ext; intros. + apply Fix_F_inv. + Qed. -Definition Fix_sub (x : A) := Fix_F_sub x (Rwf x). + Lemma fix_sub_eq : + forall x : A, + Fix_sub P F_sub x = + let f_sub := F_sub in + f_sub x (fun {y : A | R y x}=> Fix (`y)). + exact Fix_eq. + Qed. -End FixPoint. + End FixPoint. End Well_founded. +Extraction Inline Fix_F_sub Fix_sub. + Require Import Wf_nat. Require Import Lt. Section Well_founded_measure. -Variable A : Set. +Variable A : Type. Variable f : A -> nat. Definition R := fun x y => f x < f y. Section FixPoint. -Variable P : A -> Set. +Variable P : A -> Type. Variable F_sub : forall x:A, (forall y: { y : A | f y < f x }, P (proj1_sig y)) -> P x. @@ -44,3 +94,5 @@ Definition Fix_measure_sub (x : A) := Fix_measure_F_sub x (lt_wf (f x)). End FixPoint. End Well_founded_measure. + +Extraction Inline Fix_measure_F_sub Fix_measure_sub. diff --git a/contrib/subtac/FunctionalExtensionality.v b/contrib/subtac/FunctionalExtensionality.v new file mode 100644 index 00000000..1a12ac82 --- /dev/null +++ b/contrib/subtac/FunctionalExtensionality.v @@ -0,0 +1,25 @@ +Axiom fun_extensionality : forall A B (f g : A -> B), + (forall x, f x = g x) -> f = g. + +Axiom fun_extensionality_dep : forall A, forall B : (A -> Type), forall (f g : forall x : A, B x), + (forall x, f x = g x) -> f = g. + +Hint Resolve fun_extensionality fun_extensionality_dep : subtac. + +Require Import Coq.subtac.Utils. +Require Import Coq.subtac.FixSub. + +Lemma fix_sub_eq_ext : + forall (A : Set) (R : A -> A -> Prop) (Rwf : well_founded R) + (P : A -> Set) + (F_sub : forall x : A, (forall {y : A | R y x}, P (`y)) -> P x), + forall x : A, + Fix_sub A R Rwf P F_sub x = + F_sub x (fun {y : A | R y x}=> Fix A R Rwf P F_sub (`y)). +Proof. + intros ; apply Fix_eq ; auto. + intros. + assert(f = g). + apply (fun_extensionality_dep _ _ _ _ H). + rewrite H0 ; auto. +Qed. diff --git a/contrib/subtac/Subtac.v b/contrib/subtac/Subtac.v new file mode 100644 index 00000000..9912cd24 --- /dev/null +++ b/contrib/subtac/Subtac.v @@ -0,0 +1,2 @@ +Require Export Coq.subtac.Utils. +Require Export Coq.subtac.FixSub.
\ No newline at end of file diff --git a/contrib/subtac/Utils.v b/contrib/subtac/Utils.v index 219cd75b..4a2208ce 100644 --- a/contrib/subtac/Utils.v +++ b/contrib/subtac/Utils.v @@ -6,6 +6,8 @@ Notation "'fun' { x : A | P } => Q" := Notation "( x & ? )" := (@exist _ _ x _) : core_scope. +Notation " ! " := (False_rect _ _). + Definition ex_pi1 (A : Prop) (P : A -> Prop) (t : ex P) : A. intros. induction t. @@ -44,4 +46,30 @@ end. Ltac destruct_exists := repeat (destruct_one_pair) . +Ltac subtac_simpl := simpl ; intros ; destruct_exists ; simpl in * ; try subst ; auto with arith. + +(* Destructs calls to f in hypothesis or conclusion, useful if f creates a subset object *) +Ltac destruct_call f := + match goal with + | H : ?T |- _ => + match T with + context [f ?x ?y ?z] => destruct (f x y z) + | context [f ?x ?y] => destruct (f x y) + | context [f ?x] => destruct (f x) + end + | |- ?T => + match T with + context [f ?x ?y ?z] => let n := fresh "H" in set (n:=f x y z); destruct n + | context [f ?x ?y] => let n := fresh "H" in set (n:=f x y); destruct n + | context [f ?x] => let n := fresh "H" in set (n:=f x); destruct n + end + end. + Extraction Inline proj1_sig. +Extract Inductive unit => "unit" [ "()" ]. +Extract Inductive bool => "bool" [ "true" "false" ]. +Extract Inductive sumbool => "bool" [ "true" "false" ]. +Extract Inductive prod => "pair" [ "" ]. +Extract Inductive sigT => "pair" [ "" ]. + +Require Export ProofIrrelevance. diff --git a/contrib/subtac/eterm.ml b/contrib/subtac/eterm.ml index 790e61a0..1844fea5 100644 --- a/contrib/subtac/eterm.ml +++ b/contrib/subtac/eterm.ml @@ -52,8 +52,8 @@ let subst_evar_constr evs n t = anomaly ("eterm: existential variable " ^ string_of_int k ^ " not found") in seen := Intset.add id !seen; - (try trace (str "Evar " ++ int k ++ str " found, applied to " ++ int (Array.length args) ++ str "arguments," ++ - int (List.length hyps) ++ str " hypotheses"); with _ -> () ); +(* (try trace (str "Evar " ++ int k ++ str " found, applied to " ++ int (Array.length args) ++ str "arguments," ++ *) +(* int (List.length hyps) ++ str " hypotheses"); with _ -> () ); *) (* Evar arguments are created in inverse order, and we must not apply to defined ones (i.e. LetIn's) *) @@ -126,7 +126,6 @@ let eterm_obligations name nclen evm t tycon = (* 'Serialize' the evars, we assume that the types of the existentials refer to previous existentials in the list only *) let evl = List.rev (to_list evm) in - trace (str "Eterm, transformed to list"); let evn = let i = ref (-1) in List.rev_map (fun (id, ev) -> incr i; @@ -136,12 +135,9 @@ let eterm_obligations name nclen evm t tycon = (* Remove existential variables in types and build the corresponding products *) fold_right (fun (id, (n, nstr), ev) l -> - trace (str "Eterm: " ++ str "treating evar: " ++ int id); let hyps = Environ.named_context_of_val ev.evar_hyps in let hyps = trunc_named_context nclen hyps in - trace (str "Named context is: " ++ Printer.pr_named_context (Global.env ()) hyps); let evtyp, deps = etype_of_evar l ev hyps in - trace (str "Evar " ++ str (string_of_int n) ++ str "'s type is: " ++ Termops.print_constr_env (Global.env ()) evtyp); let y' = (id, ((n, nstr), hyps, evtyp, deps)) in y' :: l) evn [] @@ -152,17 +148,17 @@ let eterm_obligations name nclen evm t tycon = let evars = List.map (fun (_, ((_, name), _, typ, deps)) -> name, typ, deps) evts in - (try - trace (str "Term given to eterm" ++ spc () ++ - Termops.print_constr_env (Global.env ()) t); - trace (str "Term constructed in eterm" ++ spc () ++ - Termops.print_constr_env (Global.env ()) t'); - ignore(iter - (fun (name, typ, deps) -> - trace (str "Evar :" ++ spc () ++ str (string_of_id name) ++ - Termops.print_constr_env (Global.env ()) typ)) - evars); - with _ -> ()); +(* (try *) +(* trace (str "Term given to eterm" ++ spc () ++ *) +(* Termops.print_constr_env (Global.env ()) t); *) +(* trace (str "Term constructed in eterm" ++ spc () ++ *) +(* Termops.print_constr_env (Global.env ()) t'); *) +(* ignore(iter *) +(* (fun (name, typ, deps) -> *) +(* trace (str "Evar :" ++ spc () ++ str (string_of_id name) ++ *) +(* Termops.print_constr_env (Global.env ()) typ)) *) +(* evars); *) +(* with _ -> ()); *) Array.of_list (List.rev evars), t' let mkMetas n = diff --git a/contrib/subtac/g_subtac.ml4 b/contrib/subtac/g_subtac.ml4 index 243cb191..e31326e9 100644 --- a/contrib/subtac/g_subtac.ml4 +++ b/contrib/subtac/g_subtac.ml4 @@ -10,7 +10,7 @@ Syntax for the subtac terms and types. Elaborated from correctness/psyntax.ml4 by Jean-Christophe Filliâtre *) -(* $Id: g_subtac.ml4 9326 2006-10-31 12:57:26Z msozeau $ *) +(* $Id: g_subtac.ml4 9588 2007-02-02 16:17:13Z herbelin $ *) (*i camlp4deps: "parsing/grammar.cma" i*) @@ -37,6 +37,8 @@ struct let gec s = Gram.Entry.create ("Subtac."^s) (* types *) let subtac_gallina_loc : Vernacexpr.vernac_expr located Gram.Entry.e = gec "subtac_gallina_loc" + + let subtac_nameopt : identifier option Gram.Entry.e = gec "subtac_nameopt" end open SubtacGram @@ -46,12 +48,17 @@ open Pcoq let sigref = mkRefC (Qualid (dummy_loc, Libnames.qualid_of_string "Coq.Init.Specif.sig")) GEXTEND Gram - GLOBAL: subtac_gallina_loc Constr.binder_let Constr.binder; + GLOBAL: subtac_gallina_loc Constr.binder_let Constr.binder subtac_nameopt; subtac_gallina_loc: [ [ g = Vernac.gallina -> loc, g ] ] ; + subtac_nameopt: + [ [ "ofb"; id=Prim.ident -> Some (id) + | -> None ] ] + ; + Constr.binder_let: [ [ "("; id=Prim.name; ":"; t=Constr.lconstr; "|"; c=Constr.lconstr; ")" -> let typ = mkAppC (sigref, [mkLambdaC ([id], t, c)]) in @@ -60,8 +67,12 @@ GEXTEND Gram Constr.binder: [ [ "("; id=Prim.name; ":"; c=Constr.lconstr; "|"; p=Constr.lconstr; ")" -> - let typ = mkAppC (sigref, [mkLambdaC ([id], c, p)]) in - ([id], typ) ] ]; + ([id],mkAppC (sigref, [mkLambdaC ([id], c, p)])) + | "("; id=Prim.name; ":"; c=Constr.lconstr; ")" -> + ([id],c) + | "("; id=Prim.name; lid=LIST1 Prim.name; ":"; c=Constr.lconstr; ")" -> + (id::lid,c) + ] ]; END @@ -69,16 +80,42 @@ GEXTEND Gram type ('a,'b) gallina_loc_argtype = (Vernacexpr.vernac_expr located, 'a, 'b) Genarg.abstract_argument_type let (wit_subtac_gallina_loc : (Genarg.tlevel, Proof_type.tactic) gallina_loc_argtype), - (globwit_subtac_gallina_loc : (Genarg.glevel, Tacexpr.glob_tactic_expr) gallina_loc_argtype), + (globwit_subtac_gallina_loc : (Genarg.glevel, Tacexpr.glob_tactic_expr ) gallina_loc_argtype), (rawwit_subtac_gallina_loc : (Genarg.rlevel, Tacexpr.raw_tactic_expr) gallina_loc_argtype) = Genarg.create_arg "subtac_gallina_loc" +type 'a nameopt_argtype = (identifier option, 'a, 'a) Genarg.abstract_argument_type + +let (wit_subtac_nameopt : Genarg.tlevel nameopt_argtype), + (globwit_subtac_nameopt : Genarg.glevel nameopt_argtype), + (rawwit_subtac_nameopt : Genarg.rlevel nameopt_argtype) = + Genarg.create_arg "subtac_nameopt" + VERNAC COMMAND EXTEND Subtac [ "Program" subtac_gallina_loc(g) ] -> [ Subtac.subtac g ] -| [ "Obligation" integer(num) "of" ident(name) ] -> [ Subtac_obligations.subtac_obligation (num, Some name) ] -| [ "Obligation" integer(num) ] -> [ Subtac_obligations.subtac_obligation (num, None) ] + END + +VERNAC COMMAND EXTEND Subtac_Obligations +| [ "Obligation" integer(num) "of" ident(name) ":" lconstr(t) ] -> [ Subtac_obligations.subtac_obligation (num, Some name, Some t) ] +| [ "Obligation" integer(num) "of" ident(name) ] -> [ Subtac_obligations.subtac_obligation (num, Some name, None) ] +| [ "Obligation" integer(num) ":" lconstr(t) ] -> [ Subtac_obligations.subtac_obligation (num, None, Some t) ] +| [ "Obligation" integer(num) ] -> [ Subtac_obligations.subtac_obligation (num, None, None) ] +| [ "Next" "Obligation" "of" ident(name) ] -> [ Subtac_obligations.next_obligation (Some name) ] +| [ "Next" "Obligation" ] -> [ Subtac_obligations.next_obligation None ] +END + +VERNAC COMMAND EXTEND Subtac_Solve_Obligations | [ "Solve" "Obligations" "of" ident(name) "using" tactic(t) ] -> [ Subtac_obligations.solve_obligations (Some name) (Tacinterp.interp t) ] | [ "Solve" "Obligations" "using" tactic(t) ] -> [ Subtac_obligations.solve_obligations None (Tacinterp.interp t) ] +| [ "Admit" "Obligations" "of" ident(name) ] -> [ Subtac_obligations.admit_obligations (Some name) ] +| [ "Admit" "Obligations" ] -> [ Subtac_obligations.admit_obligations None ] + END + +VERNAC COMMAND EXTEND Subtac_Set_Solver +| [ "Obligations" "Tactic" ":=" tactic(t) ] -> [ Subtac_obligations.set_default_tactic (Tacinterp.interp t) ] +END + +VERNAC COMMAND EXTEND Subtac_Show_Obligations | [ "Obligations" "of" ident(name) ] -> [ Subtac_obligations.show_obligations (Some name) ] | [ "Obligations" ] -> [ Subtac_obligations.show_obligations None ] END diff --git a/contrib/subtac/subtac.ml b/contrib/subtac/subtac.ml index 26e8f715..5e46bead 100644 --- a/contrib/subtac/subtac.ml +++ b/contrib/subtac/subtac.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: subtac.ml 9284 2006-10-26 12:06:57Z msozeau $ *) +(* $Id: subtac.ml 9563 2007-01-31 09:37:18Z msozeau $ *) open Global open Pp @@ -120,6 +120,8 @@ let subtac_end_proof = function open Pp open Ppconstr open Decl_kinds +open Tacinterp +open Tacexpr let start_proof_com env isevars sopt kind (bl,t) hook = let id = match sopt with @@ -140,14 +142,27 @@ let start_proof_com env isevars sopt kind (bl,t) hook = let print_subgoals () = Options.if_verbose (fun () -> msg (Printer.pr_open_subgoals ())) () +let subtac_utils_path = + make_dirpath (List.map id_of_string ["Utils";contrib_name;"Coq"]) +let utils_tac s = + lazy(make_kn (MPfile subtac_utils_path) (make_dirpath []) (mk_label s)) + +let utils_call tac args = + TacArg(TacCall(dummy_loc, ArgArg(dummy_loc, Lazy.force (utils_tac tac)),args)) + let start_proof_and_print env isevars idopt k t hook = start_proof_com env isevars idopt k t hook; print_subgoals () (*if !pcoq <> None then (out_some !pcoq).start_proof ()*) +let _ = Subtac_obligations.set_default_tactic + (Tacinterp.eval_tactic (utils_call "subtac_simpl" [])) + + let subtac (loc, command) = check_required_library ["Coq";"Init";"Datatypes"]; check_required_library ["Coq";"Init";"Specif"]; + (* check_required_library ["Coq";"Logic";"JMeq"]; *) require_library "Coq.subtac.FixSub"; require_library "Coq.subtac.Utils"; let env = Global.env () in diff --git a/contrib/subtac/subtac_cases.ml b/contrib/subtac/subtac_cases.ml new file mode 100644 index 00000000..fbe1ac37 --- /dev/null +++ b/contrib/subtac/subtac_cases.ml @@ -0,0 +1,1925 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(* $Id: cases.ml 9399 2006-11-22 16:11:53Z herbelin $ *) + +open Util +open Names +open Nameops +open Term +open Termops +open Declarations +open Inductiveops +open Environ +open Sign +open Reductionops +open Typeops +open Type_errors + +open Rawterm +open Retyping +open Pretype_errors +open Evarutil +open Evarconv + +open Subtac_utils + +(* Pattern-matching errors *) + +type pattern_matching_error = + | BadPattern of constructor * constr + | BadConstructor of constructor * inductive + | WrongNumargConstructor of constructor * int + | WrongNumargInductive of inductive * int + | WrongPredicateArity of constr * constr * constr + | NeedsInversion of constr * constr + | UnusedClause of cases_pattern list + | NonExhaustive of cases_pattern list + | CannotInferPredicate of (constr * types) array + +exception PatternMatchingError of env * pattern_matching_error + +let raise_pattern_matching_error (loc,ctx,te) = + Stdpp.raise_with_loc loc (PatternMatchingError(ctx,te)) + +let error_bad_pattern_loc loc cstr ind = + raise_pattern_matching_error (loc, Global.env(), BadPattern (cstr,ind)) + +let error_bad_constructor_loc loc cstr ind = + raise_pattern_matching_error (loc, Global.env(), BadConstructor (cstr,ind)) + +let error_wrong_numarg_constructor_loc loc env c n = + raise_pattern_matching_error (loc, env, WrongNumargConstructor(c,n)) + +let error_wrong_numarg_inductive_loc loc env c n = + raise_pattern_matching_error (loc, env, WrongNumargInductive(c,n)) + +let error_wrong_predicate_arity_loc loc env c n1 n2 = + raise_pattern_matching_error (loc, env, WrongPredicateArity (c,n1,n2)) + +let error_needs_inversion env x t = + raise (PatternMatchingError (env, NeedsInversion (x,t))) + +module type S = sig + val compile_cases : + loc -> + (type_constraint -> env -> rawconstr -> unsafe_judgment) * + Evd.evar_defs ref -> + type_constraint -> + env -> rawconstr option * tomatch_tuple * cases_clauses -> + unsafe_judgment +end + +(************************************************************************) +(* Pattern-matching compilation (Cases) *) +(************************************************************************) + +(************************************************************************) +(* Configuration, errors and warnings *) + +open Pp + +let mssg_may_need_inversion () = + str "Found a matching with no clauses on a term unknown to have an empty inductive type" + +(* Utils *) +let make_anonymous_patvars = + list_tabulate (fun _ -> PatVar (dummy_loc,Anonymous)) + +(* Environment management *) +let push_rels vars env = List.fold_right push_rel vars env + +let push_rel_defs = + List.fold_right (fun (x,d,t) e -> push_rel (x,Some d,t) e) + +(* We have x1:t1...xn:tn,xi':ti,y1..yk |- c and re-generalize + over xi:ti to get x1:t1...xn:tn,xi':ti,y1..yk |- c[xi:=xi'] *) + +let regeneralize_rel i k j = if j = i+k then k else if j < i+k then j else j + +let rec regeneralize_index i k t = match kind_of_term t with + | Rel j when j = i+k -> mkRel (k+1) + | Rel j when j < i+k -> t + | Rel j when j > i+k -> t + | _ -> map_constr_with_binders succ (regeneralize_index i) k t + +type alias_constr = + | DepAlias + | NonDepAlias + +let mkSpecialLetInJudge j (na,(deppat,nondeppat,d,t)) = + { uj_val = + (match d with + | DepAlias -> mkLetIn (na,deppat,t,j.uj_val) + | NonDepAlias -> + if (not (dependent (mkRel 1) j.uj_type)) + or (* A leaf: *) isRel deppat + then + (* The body of pat is not needed to type j - see *) + (* insert_aliases - and both deppat and nondeppat have the *) + (* same type, then one can freely substitute one by the other *) + subst1 nondeppat j.uj_val + else + (* The body of pat is not needed to type j but its value *) + (* is dependent in the type of j; our choice is to *) + (* enforce this dependency *) + mkLetIn (na,deppat,t,j.uj_val)); + uj_type = subst1 deppat j.uj_type } + +(**********************************************************************) +(* Structures used in compiling pattern-matching *) + +type rhs = + { rhs_env : env; + avoid_ids : identifier list; + it : rawconstr; + } + +type equation = + { patterns : cases_pattern list; + rhs : rhs; + alias_stack : name list; + eqn_loc : loc; + used : bool ref; + tag : pattern_source } + +type matrix = equation list + +(* 1st argument of IsInd is the original ind before extracting the summary *) +type tomatch_type = + | IsInd of types * inductive_type + | NotInd of constr option * types + +type tomatch_status = + | Pushed of ((constr * tomatch_type) * int list) + | Alias of (constr * constr * alias_constr * constr) + | Abstract of rel_declaration + +type tomatch_stack = tomatch_status list + +(* The type [predicate_signature] types the terms to match and the rhs: + + - [PrLetIn (names,dep,pred)] types a pushed term ([Pushed]), + if dep<>Anonymous, the term is dependent, let n=|names|, if + n<>0 then the type of the pushed term is necessarily an + inductive with n real arguments. Otherwise, it may be + non inductive, or inductive without real arguments, or inductive + originating from a subterm in which case real args are not dependent; + it accounts for n+1 binders if dep or n binders if not dep + - [PrProd] types abstracted term ([Abstract]); it accounts for one binder + - [PrCcl] types the right-hand-side + - Aliases [Alias] have no trace in [predicate_signature] +*) + +type predicate_signature = + | PrLetIn of (name list * name) * predicate_signature + | PrProd of predicate_signature + | PrCcl of constr + +(* We keep a constr for aliases and a cases_pattern for error message *) + +type alias_builder = + | AliasLeaf + | AliasConstructor of constructor + +type pattern_history = + | Top + | MakeAlias of alias_builder * pattern_continuation + +and pattern_continuation = + | Continuation of int * cases_pattern list * pattern_history + | Result of cases_pattern list + +let start_history n = Continuation (n, [], Top) + +let initial_history = function Continuation (_,[],Top) -> true | _ -> false + +let feed_history arg = function + | Continuation (n, l, h) when n>=1 -> + Continuation (n-1, arg :: l, h) + | Continuation (n, _, _) -> + anomaly ("Bad number of expected remaining patterns: "^(string_of_int n)) + | Result _ -> + anomaly "Exhausted pattern history" + +(* This is for non exhaustive error message *) + +let rec rawpattern_of_partial_history args2 = function + | Continuation (n, args1, h) -> + let args3 = make_anonymous_patvars (n - (List.length args2)) in + build_rawpattern (List.rev_append args1 (args2@args3)) h + | Result pl -> pl + +and build_rawpattern args = function + | Top -> args + | MakeAlias (AliasLeaf, rh) -> + assert (args = []); + rawpattern_of_partial_history [PatVar (dummy_loc, Anonymous)] rh + | MakeAlias (AliasConstructor pci, rh) -> + rawpattern_of_partial_history + [PatCstr (dummy_loc, pci, args, Anonymous)] rh + +let complete_history = rawpattern_of_partial_history [] + +(* This is to build glued pattern-matching history and alias bodies *) + +let rec simplify_history = function + | Continuation (0, l, Top) -> Result (List.rev l) + | Continuation (0, l, MakeAlias (f, rh)) -> + let pargs = List.rev l in + let pat = match f with + | AliasConstructor pci -> + PatCstr (dummy_loc,pci,pargs,Anonymous) + | AliasLeaf -> + assert (l = []); + PatVar (dummy_loc, Anonymous) in + feed_history pat rh + | h -> h + +(* Builds a continuation expecting [n] arguments and building [ci] applied + to this [n] arguments *) + +let push_history_pattern n current cont = + Continuation (n, [], MakeAlias (current, cont)) + +(* A pattern-matching problem has the following form: + + env, isevars |- <pred> Cases tomatch of mat end + + where tomatch is some sequence of "instructions" (t1 ... tn) + + and mat is some matrix + (p11 ... p1n -> rhs1) + ( ... ) + (pm1 ... pmn -> rhsm) + + Terms to match: there are 3 kinds of instructions + + - "Pushed" terms to match are typed in [env]; these are usually just + Rel(n) except for the initial terms given by user and typed in [env] + - "Abstract" instructions means an abstraction has to be inserted in the + current branch to build (this means a pattern has been detected dependent + in another one and generalisation is necessary to ensure well-typing) + - "Alias" instructions means an alias has to be inserted (this alias + is usually removed at the end, except when its type is not the + same as the type of the matched term from which it comes - + typically because the inductive types are "real" parameters) + + Right-hand-sides: + + They consist of a raw term to type in an environment specific to the + clause they belong to: the names of declarations are those of the + variables present in the patterns. Therefore, they come with their + own [rhs_env] (actually it is the same as [env] except for the names + of variables). + +*) +type pattern_matching_problem = + { env : env; + isevars : Evd.evar_defs ref; + pred : predicate_signature option; + tomatch : tomatch_stack; + history : pattern_continuation; + mat : matrix; + caseloc : loc; + typing_function: type_constraint -> env -> rawconstr -> unsafe_judgment } + +(*--------------------------------------------------------------------------* + * A few functions to infer the inductive type from the patterns instead of * + * checking that the patterns correspond to the ind. type of the * + * destructurated object. Allows type inference of examples like * + * match n with O => true | _ => false end * + * match x in I with C => true | _ => false end * + *--------------------------------------------------------------------------*) + +(* Computing the inductive type from the matrix of patterns *) + +(* We use the "in I" clause to coerce the terms to match and otherwise + use the constructor to know in which type is the matching problem + + Note that insertion of coercions inside nested patterns is done + each time the matrix is expanded *) + +let rec find_row_ind = function + [] -> None + | PatVar _ :: l -> find_row_ind l + | PatCstr(loc,c,_,_) :: _ -> Some (loc,c) + +let inductive_template isevars env tmloc ind = + let arsign = get_full_arity_sign env ind in + let hole_source = match tmloc with + | Some loc -> fun i -> (loc, Evd.TomatchTypeParameter (ind,i)) + | None -> fun _ -> (dummy_loc, Evd.InternalHole) in + let (_,evarl,_) = + List.fold_right + (fun (na,b,ty) (subst,evarl,n) -> + match b with + | None -> + let ty' = substl subst ty in + let e = e_new_evar isevars env ~src:(hole_source n) ty' in + (e::subst,e::evarl,n+1) + | Some b -> + (b::subst,evarl,n+1)) + arsign ([],[],1) in + applist (mkInd ind,List.rev evarl) + + +(************************************************************************) +(* Utils *) + +let mkExistential env ?(src=(dummy_loc,Evd.InternalHole)) isevars = + e_new_evar isevars env ~src:src (new_Type ()) + +let evd_comb2 f isevars x y = + let (evd',y) = f !isevars x y in + isevars := evd'; + y + + +module Cases_F(Coercion : Coercion.S) : S = struct + +let inh_coerce_to_ind isevars env ty tyi = + let expected_typ = inductive_template isevars env None tyi in + (* devrait être indifférent d'exiger leq ou pas puisque pour + un inductif cela doit être égal *) + let _ = e_cumul env isevars expected_typ ty in () + +let unify_tomatch_with_patterns isevars env loc typ pats = + match find_row_ind pats with + | None -> NotInd (None,typ) + | Some (_,(ind,_)) -> + inh_coerce_to_ind isevars env typ ind; + try IsInd (typ,find_rectype env (Evd.evars_of !isevars) typ) + with Not_found -> NotInd (None,typ) + +let find_tomatch_tycon isevars env loc = function + (* Try if some 'in I ...' is present and can be used as a constraint *) + | Some (_,ind,_,_) -> mk_tycon (inductive_template isevars env loc ind) + | None -> empty_tycon + +let coerce_row typing_fun isevars env pats (tomatch,(_,indopt)) = + let loc = Some (loc_of_rawconstr tomatch) in + let tycon = find_tomatch_tycon isevars env loc indopt in + let j = typing_fun tycon env tomatch in + let evd, j = Coercion.inh_coerce_to_base (loc_of_rawconstr tomatch) env !isevars j in + isevars := evd; + let typ = nf_evar (Evd.evars_of !isevars) j.uj_type in + let t = + try IsInd (typ,find_rectype env (Evd.evars_of !isevars) typ) + with Not_found -> + unify_tomatch_with_patterns isevars env loc typ pats in + (j.uj_val,t) + +let coerce_to_indtype typing_fun isevars env matx tomatchl = + let pats = List.map (fun r -> r.patterns) matx in + let matx' = match matrix_transpose pats with + | [] -> List.map (fun _ -> []) tomatchl (* no patterns at all *) + | m -> m in + List.map2 (coerce_row typing_fun isevars env) matx' tomatchl + + + +let adjust_tomatch_to_pattern pb ((current,typ),deps) = + (* Ideally, we could find a common inductive type to which both the + term to match and the patterns coerce *) + (* In practice, we coerce the term to match if it is not already an + inductive type and it is not dependent; moreover, we use only + the first pattern type and forget about the others *) + let typ = match typ with IsInd (t,_) -> t | NotInd (_,t) -> t in + let typ = + try IsInd (typ,find_rectype pb.env (Evd.evars_of !(pb.isevars)) typ) + with Not_found -> NotInd (None,typ) in + let tomatch = ((current,typ),deps) in + match typ with + | NotInd (None,typ) -> + let tm1 = List.map (fun eqn -> List.hd eqn.patterns) pb.mat in + (match find_row_ind tm1 with + | None -> tomatch + | Some (_,(ind,_)) -> + let indt = inductive_template pb.isevars pb.env None ind in + let current = + if deps = [] & isEvar typ then + (* Don't insert coercions if dependent; only solve evars *) + let _ = e_cumul pb.env pb.isevars indt typ in + current + else + (evd_comb2 (Coercion.inh_conv_coerce_to dummy_loc pb.env) + pb.isevars (make_judge current typ) (mk_tycon_type indt)).uj_val in + let sigma = Evd.evars_of !(pb.isevars) in + let typ = IsInd (indt,find_rectype pb.env sigma indt) in + ((current,typ),deps)) + | _ -> tomatch + + (* extract some ind from [t], possibly coercing from constructors in [tm] *) +let to_mutind env isevars tm c t = +(* match c with + | Some body -> *) NotInd (c,t) +(* | None -> unify_tomatch_with_patterns isevars env t tm*) + +let type_of_tomatch = function + | IsInd (t,_) -> t + | NotInd (_,t) -> t + +let mkDeclTomatch na = function + | IsInd (t,_) -> (na,None,t) + | NotInd (c,t) -> (na,c,t) + +let map_tomatch_type f = function + | IsInd (t,ind) -> IsInd (f t,map_inductive_type f ind) + | NotInd (c,t) -> NotInd (option_map f c, f t) + +let liftn_tomatch_type n depth = map_tomatch_type (liftn n depth) +let lift_tomatch_type n = liftn_tomatch_type n 1 + +let lift_tomatch n ((current,typ),info) = + ((lift n current,lift_tomatch_type n typ),info) + +(**********************************************************************) +(* Utilities on patterns *) + +let current_pattern eqn = + match eqn.patterns with + | pat::_ -> pat + | [] -> anomaly "Empty list of patterns" + +let alias_of_pat = function + | PatVar (_,name) -> name + | PatCstr(_,_,_,name) -> name + +let unalias_pat = function + | PatVar (c,name) as p -> + if name = Anonymous then p else PatVar (c,Anonymous) + | PatCstr(a,b,c,name) as p -> + if name = Anonymous then p else PatCstr (a,b,c,Anonymous) + +let remove_current_pattern eqn = + match eqn.patterns with + | pat::pats -> + { eqn with + patterns = pats; + alias_stack = alias_of_pat pat :: eqn.alias_stack } + | [] -> anomaly "Empty list of patterns" + +let prepend_pattern tms eqn = {eqn with patterns = tms@eqn.patterns } + +(**********************************************************************) +(* Dealing with regular and default patterns *) +let is_regular eqn = eqn.tag = RegularPat + +let lower_pattern_status = function + | RegularPat -> DefaultPat 0 + | DefaultPat n -> DefaultPat (n+1) + +let pattern_status pats = + if array_exists ((=) RegularPat) pats then RegularPat + else + let min = + Array.fold_right + (fun pat n -> match pat with + | DefaultPat i when i<n -> i + | _ -> n) + pats 0 in + DefaultPat min + +(**********************************************************************) +(* Well-formedness tests *) +(* Partial check on patterns *) + +exception NotAdjustable + +let rec adjust_local_defs loc = function + | (pat :: pats, (_,None,_) :: decls) -> + pat :: adjust_local_defs loc (pats,decls) + | (pats, (_,Some _,_) :: decls) -> + PatVar (loc, Anonymous) :: adjust_local_defs loc (pats,decls) + | [], [] -> [] + | _ -> raise NotAdjustable + +let check_and_adjust_constructor env ind cstrs = function + | PatVar _ as pat -> pat + | PatCstr (loc,((_,i) as cstr),args,alias) as pat -> + (* Check it is constructor of the right type *) + let ind' = inductive_of_constructor cstr in + if Closure.mind_equiv env ind' ind then + (* Check the constructor has the right number of args *) + let ci = cstrs.(i-1) in + let nb_args_constr = ci.cs_nargs in + if List.length args = nb_args_constr then pat + else + try + let args' = adjust_local_defs loc (args, List.rev ci.cs_args) + in PatCstr (loc, cstr, args', alias) + with NotAdjustable -> + error_wrong_numarg_constructor_loc loc (Global.env()) + cstr nb_args_constr + else + (* Try to insert a coercion *) + try + Coercion.inh_pattern_coerce_to loc pat ind' ind + with Not_found -> + error_bad_constructor_loc loc cstr ind + +let check_all_variables typ mat = + List.iter + (fun eqn -> match current_pattern eqn with + | PatVar (_,id) -> () + | PatCstr (loc,cstr_sp,_,_) -> + error_bad_pattern_loc loc cstr_sp typ) + mat + +let check_unused_pattern env eqn = + if not !(eqn.used) then + raise_pattern_matching_error + (eqn.eqn_loc, env, UnusedClause eqn.patterns) + +let set_used_pattern eqn = eqn.used := true + +let extract_rhs pb = + match pb.mat with + | [] -> errorlabstrm "build_leaf" (mssg_may_need_inversion()) + | eqn::_ -> + set_used_pattern eqn; + eqn.tag, eqn.rhs + +(**********************************************************************) +(* Functions to deal with matrix factorization *) + +let occur_in_rhs na rhs = + match na with + | Anonymous -> false + | Name id -> occur_rawconstr id rhs.it + +let is_dep_patt eqn = function + | PatVar (_,name) -> occur_in_rhs name eqn.rhs + | PatCstr _ -> true + +let dependencies_in_rhs nargs eqns = + if eqns = [] then list_tabulate (fun _ -> false) nargs (* Only "_" patts *) + else + let deps = List.map (fun (tms,eqn) -> List.map (is_dep_patt eqn) tms) eqns in + let columns = matrix_transpose deps in + List.map (List.exists ((=) true)) columns + +let dependent_decl a = function + | (na,None,t) -> dependent a t + | (na,Some c,t) -> dependent a t || dependent a c + +(* Computing the matrix of dependencies *) + +(* We are in context d1...dn |- and [find_dependencies k 1 nextlist] + computes for declaration [k+1] in which of declarations in + [nextlist] (which corresponds to d(k+2)...dn) it depends; + declarations are expressed by index, e.g. in dependency list + [n-2;1], [1] points to [dn] and [n-2] to [d3] *) + +let rec find_dependency_list k n = function + | [] -> [] + | (used,tdeps,d)::rest -> + let deps = find_dependency_list k (n+1) rest in + if used && dependent_decl (mkRel n) d + then list_add_set (List.length rest + 1) (list_union deps tdeps) + else deps + +let find_dependencies is_dep_or_cstr_in_rhs d (k,nextlist) = + let deps = find_dependency_list k 1 nextlist in + if is_dep_or_cstr_in_rhs || deps <> [] + then (k-1,(true ,deps,d)::nextlist) + else (k-1,(false,[] ,d)::nextlist) + +let find_dependencies_signature deps_in_rhs typs = + let k = List.length deps_in_rhs in + let _,l = List.fold_right2 find_dependencies deps_in_rhs typs (k,[]) in + List.map (fun (_,deps,_) -> deps) l + +(******) + +(* A Pushed term to match has just been substituted by some + constructor t = (ci x1...xn) and the terms x1 ... xn have been added to + match + + - all terms to match and to push (dependent on t by definition) + must have (Rel depth) substituted by t and Rel's>depth lifted by n + - all pushed terms to match (non dependent on t by definition) must + be lifted by n + + We start with depth=1 +*) + +let regeneralize_index_tomatch n = + let rec genrec depth = function + | [] -> [] + | Pushed ((c,tm),l)::rest -> + let c = regeneralize_index n depth c in + let tm = map_tomatch_type (regeneralize_index n depth) tm in + let l = List.map (regeneralize_rel n depth) l in + Pushed ((c,tm),l)::(genrec depth rest) + | Alias (c1,c2,d,t)::rest -> + Alias (regeneralize_index n depth c1,c2,d,t)::(genrec depth rest) + | Abstract d::rest -> + Abstract (map_rel_declaration (regeneralize_index n depth) d) + ::(genrec (depth+1) rest) in + genrec 0 + +let rec replace_term n c k t = + if t = mkRel (n+k) then lift k c + else map_constr_with_binders succ (replace_term n c) k t + +let replace_tomatch n c = + let rec replrec depth = function + | [] -> [] + | Pushed ((b,tm),l)::rest -> + let b = replace_term n c depth b in + let tm = map_tomatch_type (replace_term n c depth) tm in + List.iter (fun i -> if i=n+depth then anomaly "replace_tomatch") l; + Pushed ((b,tm),l)::(replrec depth rest) + | Alias (c1,c2,d,t)::rest -> + Alias (replace_term n c depth c1,c2,d,t)::(replrec depth rest) + | Abstract d::rest -> + Abstract (map_rel_declaration (replace_term n c depth) d) + ::(replrec (depth+1) rest) in + replrec 0 + +let liftn_rel_declaration n k = map_rel_declaration (liftn n k) +let substnl_rel_declaration sigma k = map_rel_declaration (substnl sigma k) + +let rec liftn_tomatch_stack n depth = function + | [] -> [] + | Pushed ((c,tm),l)::rest -> + let c = liftn n depth c in + let tm = liftn_tomatch_type n depth tm in + let l = List.map (fun i -> if i<depth then i else i+n) l in + Pushed ((c,tm),l)::(liftn_tomatch_stack n depth rest) + | Alias (c1,c2,d,t)::rest -> + Alias (liftn n depth c1,liftn n depth c2,d,liftn n depth t) + ::(liftn_tomatch_stack n depth rest) + | Abstract d::rest -> + Abstract (map_rel_declaration (liftn n depth) d) + ::(liftn_tomatch_stack n (depth+1) rest) + + +let lift_tomatch_stack n = liftn_tomatch_stack n 1 + +(* if [current] has type [I(p1...pn u1...um)] and we consider the case + of constructor [ci] of type [I(p1...pn u'1...u'm)], then the + default variable [name] is expected to have which type? + Rem: [current] is [(Rel i)] except perhaps for initial terms to match *) + +(************************************************************************) +(* Some heuristics to get names for variables pushed in pb environment *) +(* Typical requirement: + + [match y with (S (S x)) => x | x => x end] should be compiled into + [match y with O => y | (S n) => match n with O => y | (S x) => x end end] + + and [match y with (S (S n)) => n | n => n end] into + [match y with O => y | (S n0) => match n0 with O => y | (S n) => n end end] + + i.e. user names should be preserved and created names should not + interfere with user names *) + +let merge_name get_name obj = function + | Anonymous -> get_name obj + | na -> na + +let merge_names get_name = List.map2 (merge_name get_name) + +let get_names env sign eqns = + let names1 = list_tabulate (fun _ -> Anonymous) (List.length sign) in + (* If any, we prefer names used in pats, from top to bottom *) + let names2 = + List.fold_right + (fun (pats,eqn) names -> merge_names alias_of_pat pats names) + eqns names1 in + (* Otherwise, we take names from the parameters of the constructor but + avoiding conflicts with user ids *) + let allvars = + List.fold_left (fun l (_,eqn) -> list_union l eqn.rhs.avoid_ids) [] eqns in + let names4,_ = + List.fold_left2 + (fun (l,avoid) d na -> + let na = + merge_name + (fun (na,_,t) -> Name (next_name_away (named_hd env t na) avoid)) + d na + in + (na::l,(out_name na)::avoid)) + ([],allvars) (List.rev sign) names2 in + names4 + +(************************************************************************) +(* Recovering names for variables pushed to the rhs' environment *) + +let recover_alias_names get_name = List.map2 (fun x (_,c,t) ->(get_name x,c,t)) + +let all_name sign = List.map (fun (n, b, t) -> let n = match n with Name _ -> n | Anonymous -> Name (id_of_string "Anonymous") in + (n, b, t)) sign + +let push_rels_eqn sign eqn = + let sign = all_name sign in +(* trace (str "push_rels_eqn: " ++ my_print_rel_context eqn.rhs.rhs_env sign ++ str "end"); *) +(* str " branch is " ++ my_print_constr (fst eqn.rhs.c_orig) (snd eqn.rhs.c_orig)); *) +(* let rhs = eqn.rhs in *) +(* let l, c, s, e = *) +(* List.fold_right *) +(* (fun (na, c, t) (itlift, it, sign, env) -> *) +(* (try trace (str "Pushing decl: " ++ pr_rel_decl env (na, c, t) ++ *) +(* str " lift is " ++ int itlift); *) +(* with _ -> trace (str "error in push_rels_eqn")); *) +(* let env' = push_rel (na, c, t) env in *) +(* match sign with *) +(* [] -> (itlift, lift 1 it, sign, env') *) +(* | (na', c, t) :: sign' -> *) +(* if na' = na then *) +(* (pred itlift, it, sign', env') *) +(* else ( *) +(* trace (str "skipping it"); *) +(* (itlift, liftn 1 itlift it, sign, env'))) *) +(* sign (rhs.rhs_lift, rhs.c_it, eqn.rhs.rhs_sign, eqn.rhs.rhs_env) *) +(* in *) + {eqn with rhs = {eqn.rhs with rhs_env = push_rels sign eqn.rhs.rhs_env; } } + +let push_rels_eqn_with_names sign eqn = + let pats = List.rev (list_firstn (List.length sign) eqn.patterns) in + let sign = recover_alias_names alias_of_pat pats sign in + push_rels_eqn sign eqn + +let build_aliases_context env sigma names allpats pats = + (* pats is the list of bodies to push as an alias *) + (* They all are defined in env and we turn them into a sign *) + (* cuts in sign need to be done in allpats *) + let rec insert env sign1 sign2 n newallpats oldallpats = function + | (deppat,_,_,_)::pats, Anonymous::names when not (isRel deppat) -> + (* Anonymous leaves must be considered named and treated in the *) + (* next clause because they may occur in implicit arguments *) + insert env sign1 sign2 + n newallpats (List.map List.tl oldallpats) (pats,names) + | (deppat,nondeppat,d,t)::pats, na::names -> + let nondeppat = lift n nondeppat in + let deppat = lift n deppat in + let newallpats = + List.map2 (fun l1 l2 -> List.hd l2::l1) newallpats oldallpats in + let oldallpats = List.map List.tl oldallpats in + let decl = (na,Some deppat,t) in + let a = (deppat,nondeppat,d,t) in + insert (push_rel decl env) (decl::sign1) ((na,a)::sign2) (n+1) + newallpats oldallpats (pats,names) + | [], [] -> newallpats, sign1, sign2, env + | _ -> anomaly "Inconsistent alias and name lists" in + let allpats = List.map (fun x -> [x]) allpats + in insert env [] [] 0 (List.map (fun _ -> []) allpats) allpats (pats, names) + +let insert_aliases_eqn sign eqnnames alias_rest eqn = + let thissign = List.map2 (fun na (_,c,t) -> (na,c,t)) eqnnames sign in + push_rels_eqn thissign { eqn with alias_stack = alias_rest; } + + +let insert_aliases env sigma alias eqns = + (* Là, y a une faiblesse, si un alias est utilisé dans un cas par *) + (* défaut présent mais inutile, ce qui est le cas général, l'alias *) + (* est introduit même s'il n'est pas utilisé dans les cas réguliers *) + let eqnsnames = List.map (fun eqn -> List.hd eqn.alias_stack) eqns in + let alias_rests = List.map (fun eqn -> List.tl eqn.alias_stack) eqns in + (* names2 takes the meet of all needed aliases *) + let names2 = + List.fold_right (merge_name (fun x -> x)) eqnsnames Anonymous in + (* Only needed aliases are kept by build_aliases_context *) + let eqnsnames, sign1, sign2, env = + build_aliases_context env sigma [names2] eqnsnames [alias] in + let eqns = list_map3 (insert_aliases_eqn sign1) eqnsnames alias_rests eqns in + sign2, env, eqns + +(**********************************************************************) +(* Functions to deal with elimination predicate *) + +exception Occur +let noccur_between_without_evar n m term = + let rec occur_rec n c = match kind_of_term c with + | Rel p -> if n<=p && p<n+m then raise Occur + | Evar (_,cl) -> () + | _ -> iter_constr_with_binders succ occur_rec n c + in + try occur_rec n term; true with Occur -> false + +(* Inferring the predicate *) +let prepare_unif_pb typ cs = + let n = List.length (assums_of_rel_context cs.cs_args) in + + (* We may need to invert ci if its parameters occur in typ *) + let typ' = + if noccur_between_without_evar 1 n typ then lift (-n) typ + else (* TODO4-1 *) + error "Unable to infer return clause of this pattern-matching problem" in + let args = extended_rel_list (-n) cs.cs_args in + let ci = applist (mkConstruct cs.cs_cstr, cs.cs_params@args) in + + (* This is the problem: finding P s.t. cs_args |- (P realargs ci) = typ' *) + (Array.map (lift (-n)) cs.cs_concl_realargs, ci, typ') + + +(* Infering the predicate *) +(* +The problem to solve is the following: + +We match Gamma |- t : I(u01..u0q) against the following constructors: + + Gamma, x11...x1p1 |- C1(x11..x1p1) : I(u11..u1q) + ... + Gamma, xn1...xnpn |- Cn(xn1..xnp1) : I(un1..unq) + +Assume the types in the branches are the following + + Gamma, x11...x1p1 |- branch1 : T1 + ... + Gamma, xn1...xnpn |- branchn : Tn + +Assume the type of the global case expression is Gamma |- T + +The predicate has the form phi = [y1..yq][z:I(y1..yq)]? and must satisfy +the following n+1 equations: + + Gamma, x11...x1p1 |- (phi u11..u1q (C1 x11..x1p1)) = T1 + ... + Gamma, xn1...xnpn |- (phi un1..unq (Cn xn1..xnpn)) = Tn + Gamma |- (phi u01..u0q t) = T + +Some hints: + +- Clearly, if xij occurs in Ti, then, a "match z with (Ci xi1..xipi) => ..." + should be inserted somewhere in Ti. + +- If T is undefined, an easy solution is to insert a "match z with (Ci + xi1..xipi) => ..." in front of each Ti + +- Otherwise, T1..Tn and T must be step by step unified, if some of them + diverge, then try to replace the diverging subterm by one of y1..yq or z. + +- The main problem is what to do when an existential variables is encountered + +let prepare_unif_pb typ cs = + let n = cs.cs_nargs in + let _,p = decompose_prod_n n typ in + let ci = build_dependent_constructor cs in + (* This is the problem: finding P s.t. cs_args |- (P realargs ci) = p *) + (n, cs.cs_concl_realargs, ci, p) + +let eq_operator_lift k (n,n') = function + | OpRel p, OpRel p' when p > k & p' > k -> + if p < k+n or p' < k+n' then false else p - n = p' - n' + | op, op' -> op = op' + +let rec transpose_args n = + if n=0 then [] + else + (Array.map (fun l -> List.hd l) lv):: + (transpose_args (m-1) (Array.init (fun l -> List.tl l))) + +let shift_operator k = function OpLambda _ | OpProd _ -> k+1 | _ -> k + +let reloc_operator (k,n) = function OpRel p when p > k -> +let rec unify_clauses k pv = + let pv'= Array.map (fun (n,sign,_,p) -> n,splay_constr (whd_betaiotaevar (push_rels (List.rev sign) env) (Evd.evars_of isevars)) p) pv in + let n1,op1 = let (n1,(op1,args1)) = pv'.(0) in n1,op1 in + if Array.for_all (fun (ni,(opi,_)) -> eq_operator_lift k (n1,ni) (op1,opi)) pv' + then + let argvl = transpose_args (List.length args1) pv' in + let k' = shift_operator k op1 in + let argl = List.map (unify_clauses k') argvl in + gather_constr (reloc_operator (k,n1) op1) argl +*) + +let abstract_conclusion typ cs = + let n = List.length (assums_of_rel_context cs.cs_args) in + let (sign,p) = decompose_prod_n n typ in + lam_it p sign + +let infer_predicate loc env isevars typs cstrs indf = + (* Il faudra substituer les isevars a un certain moment *) + if Array.length cstrs = 0 then (* "TODO4-3" *) + error "Inference of annotation for empty inductive types not implemented" + else + (* Empiric normalization: p may depend in a irrelevant way on args of the*) + (* cstr as in [c:{_:Alpha & Beta}] match c with (existS a b)=>(a,b) end *) + let typs = + Array.map (local_strong (whd_betaevar empty_env (Evd.evars_of !isevars))) typs + in + let eqns = array_map2 prepare_unif_pb typs cstrs in + (* First strategy: no dependencies at all *) +(* + let (mis,_) = dest_ind_family indf in + let (cclargs,_,typn) = eqns.(mis_nconstr mis -1) in +*) + let (sign,_) = get_arity env indf in + let mtyp = + if array_exists is_Type typs then + (* Heuristic to avoid comparison between non-variables algebric univs*) + new_Type () + else + mkExistential env ~src:(loc, Evd.CasesType) isevars + in + if array_for_all (fun (_,_,typ) -> e_cumul env isevars typ mtyp) eqns + then + (* Non dependent case -> turn it into a (dummy) dependent one *) + let sign = (Anonymous,None,build_dependent_inductive env indf)::sign in + let pred = it_mkLambda_or_LetIn (lift (List.length sign) mtyp) sign in + (true,pred) (* true = dependent -- par défaut *) + else +(* + let s = get_sort_of env (evars_of isevars) typs.(0) in + let predpred = it_mkLambda_or_LetIn (mkSort s) sign in + let caseinfo = make_default_case_info mis in + let brs = array_map2 abstract_conclusion typs cstrs in + let predbody = mkCase (caseinfo, (nf_betaiota predpred), mkRel 1, brs) in + let pred = it_mkLambda_or_LetIn (lift (List.length sign) mtyp) sign in +*) + (* "TODO4-2" *) + (* We skip parameters *) + let cis = + Array.map + (fun cs -> + applist (mkConstruct cs.cs_cstr, extended_rel_list 0 cs.cs_args)) + cstrs in + let ct = array_map2 (fun ci (_,_,t) -> (ci,t)) cis eqns in + raise_pattern_matching_error (loc,env, CannotInferPredicate ct) +(* + (true,pred) +*) + +(* Propagation of user-provided predicate through compilation steps *) + +let rec map_predicate f k = function + | PrCcl ccl -> PrCcl (f k ccl) + | PrProd pred -> + PrProd (map_predicate f (k+1) pred) + | PrLetIn ((names,dep as tm),pred) -> + let k' = List.length names + (if dep<>Anonymous then 1 else 0) in + PrLetIn (tm, map_predicate f (k+k') pred) + +let rec noccurn_predicate k = function + | PrCcl ccl -> noccurn k ccl + | PrProd pred -> noccurn_predicate (k+1) pred + | PrLetIn ((names,dep),pred) -> + let k' = List.length names + (if dep<>Anonymous then 1 else 0) in + noccurn_predicate (k+k') pred + +let liftn_predicate n = map_predicate (liftn n) + +let lift_predicate n = liftn_predicate n 1 + +let regeneralize_index_predicate n = map_predicate (regeneralize_index n) 0 + +let substnl_predicate sigma = map_predicate (substnl sigma) + +(* This is parallel bindings *) +let subst_predicate (args,copt) pred = + let sigma = match copt with + | None -> List.rev args + | Some c -> c::(List.rev args) in + substnl_predicate sigma 0 pred + +let specialize_predicate_var (cur,typ) = function + | PrProd _ | PrCcl _ -> + anomaly "specialize_predicate_var: a pattern-variable must be pushed" + | PrLetIn (([],dep),pred) -> + subst_predicate ([],if dep<>Anonymous then Some cur else None) pred + | PrLetIn ((_,dep),pred) -> + (match typ with + | IsInd (_,IndType (_,realargs)) -> + subst_predicate (realargs,if dep<>Anonymous then Some cur else None) pred + | _ -> anomaly "specialize_predicate_var") + +let ungeneralize_predicate = function + | PrLetIn _ | PrCcl _ -> anomaly "ungeneralize_predicate: expects a product" + | PrProd pred -> pred + +(*****************************************************************************) +(* We have pred = [X:=realargs;x:=c]P typed in Gamma1, x:I(realargs), Gamma2 *) +(* and we want to abstract P over y:t(x) typed in the same context to get *) +(* *) +(* pred' = [X:=realargs;x':=c](y':t(x'))P[y:=y'] *) +(* *) +(* We first need to lift t(x) s.t. it is typed in Gamma, X:=rargs, x' *) +(* then we have to replace x by x' in t(x) and y by y' in P *) +(*****************************************************************************) +let generalize_predicate ny d = function + | PrLetIn ((names,dep as tm),pred) -> + if dep=Anonymous then anomaly "Undetected dependency"; + let p = List.length names + 1 in + let pred = lift_predicate 1 pred in + let pred = regeneralize_index_predicate (ny+p+1) pred in + PrLetIn (tm, PrProd pred) + | PrProd _ | PrCcl _ -> + anomaly "generalize_predicate: expects a non trivial pattern" + +let rec extract_predicate l = function + | pred, Alias (deppat,nondeppat,_,_)::tms -> + let tms' = match kind_of_term nondeppat with + | Rel i -> replace_tomatch i deppat tms + | _ -> (* initial terms are not dependent *) tms in + extract_predicate l (pred,tms') + | PrProd pred, Abstract d'::tms -> + let d' = map_rel_declaration (lift (List.length l)) d' in + substl l (mkProd_or_LetIn d' (extract_predicate [] (pred,tms))) + | PrLetIn (([],dep),pred), Pushed ((cur,_),_)::tms -> + extract_predicate (if dep<>Anonymous then cur::l else l) (pred,tms) + | PrLetIn ((_,dep),pred), Pushed ((cur,IsInd (_,(IndType(_,realargs)))),_)::tms -> + let l = List.rev realargs@l in + extract_predicate (if dep<>Anonymous then cur::l else l) (pred,tms) + | PrCcl ccl, [] -> + substl l ccl + | _ -> anomaly"extract_predicate: predicate inconsistent with terms to match" + +let abstract_predicate env sigma indf cur tms = function + | (PrProd _ | PrCcl _) -> anomaly "abstract_predicate: must be some LetIn" + | PrLetIn ((names,dep),pred) -> + let sign = make_arity_signature env true indf in + (* n is the number of real args + 1 *) + let n = List.length sign in + let tms = lift_tomatch_stack n tms in + let tms = + match kind_of_term cur with + | Rel i -> regeneralize_index_tomatch (i+n) tms + | _ -> (* Initial case *) tms in + (* Depending on whether the predicate is dependent or not, and has real + args or not, we lift it to make room for [sign] *) + (* Even if not intrinsically dep, we move the predicate into a dep one *) + let sign,k = + if names = [] & n <> 1 then + (* Real args were not considered *) + (if dep<>Anonymous then + ((let (_,c,t) = List.hd sign in (dep,c,t)::List.tl sign),n-1) + else + (sign,n)) + else + (* Real args are OK *) + (List.map2 (fun na (_,c,t) -> (na,c,t)) (dep::names) sign, + if dep<>Anonymous then 0 else 1) in + let pred = lift_predicate k pred in + let pred = extract_predicate [] (pred,tms) in + (true, it_mkLambda_or_LetIn_name env pred sign) + +let rec known_dependent = function + | None -> false + | Some (PrLetIn ((_,dep),_)) -> dep<>Anonymous + | Some (PrCcl _) -> false + | Some (PrProd _) -> + anomaly "known_dependent: can only be used when patterns remain" + +(* [expand_arg] is used by [specialize_predicate] + it replaces gamma, x1...xn, x1...xk |- pred + by gamma, x1...xn, x1...xk-1 |- [X=realargs,xk=xk]pred (if dep) or + by gamma, x1...xn, x1...xk-1 |- [X=realargs]pred (if not dep) *) + +let expand_arg n alreadydep (na,t) deps (k,pred) = + (* current can occur in pred even if the original problem is not dependent *) + let dep = + if alreadydep<>Anonymous then alreadydep + else if deps = [] && noccurn_predicate 1 pred then Anonymous + else Name (id_of_string "x") in + let pred = if dep<>Anonymous then pred else lift_predicate (-1) pred in + (* There is no dependency in realargs for subpattern *) + (k-1, PrLetIn (([],dep), pred)) + + +(*****************************************************************************) +(* pred = [X:=realargs;x:=c]P types the following problem: *) +(* *) +(* Gamma |- match Pushed(c:I(realargs)) rest with...end: pred *) +(* *) +(* where the branch with constructor Ci:(x1:T1)...(xn:Tn)->I(realargsi) *) +(* is considered. Assume each Ti is some Ii(argsi). *) +(* We let e=Ci(x1,...,xn) and replace pred by *) +(* *) +(* pred' = [X1:=rargs1,x1:=x1']...[Xn:=rargsn,xn:=xn'](P[X:=realargsi;x:=e]) *) +(* *) +(* s.t Gamma,x1'..xn' |- match Pushed(x1')..Pushed(xn') rest with..end :pred'*) +(* *) +(*****************************************************************************) +let specialize_predicate tomatchs deps cs = function + | (PrProd _ | PrCcl _) -> + anomaly "specialize_predicate: a matched pattern must be pushed" + | PrLetIn ((names,isdep),pred) -> + (* Assume some gamma st: gamma, (X,x:=realargs,copt) |- pred *) + let nrealargs = List.length names in + let k = nrealargs + (if isdep<>Anonymous then 1 else 0) in + (* We adjust pred st: gamma, x1..xn, (X,x:=realargs,copt) |- pred' *) + let n = cs.cs_nargs in + let pred' = liftn_predicate n (k+1) pred in + let argsi = if nrealargs <> 0 then Array.to_list cs.cs_concl_realargs else [] in + let copti = if isdep<>Anonymous then Some (build_dependent_constructor cs) else None in + (* The substituends argsi, copti are all defined in gamma, x1...xn *) + (* We need _parallel_ bindings to get gamma, x1...xn |- pred'' *) + let pred'' = subst_predicate (argsi, copti) pred' in + (* We adjust pred st: gamma, x1..xn, x1..xn |- pred'' *) + let pred''' = liftn_predicate n (n+1) pred'' in + (* We finally get gamma,x1..xn |- [X1,x1:=R1,x1]..[Xn,xn:=Rn,xn]pred'''*) + snd (List.fold_right2 (expand_arg n isdep) tomatchs deps (n,pred''')) + +let find_predicate loc env isevars p typs cstrs current + (IndType (indf,realargs)) tms = + let (dep,pred) = + match p with + | Some p -> abstract_predicate env (Evd.evars_of !isevars) indf current tms p + | None -> infer_predicate loc env isevars typs cstrs indf in + let typ = whd_beta (applist (pred, realargs)) in + if dep then + (pred, whd_beta (applist (typ, [current])), new_Type ()) + else + (pred, typ, new_Type ()) + +(************************************************************************) +(* Sorting equations by constructor *) + +type inversion_problem = + (* the discriminating arg in some Ind and its order in Ind *) + | Incompatible of int * (int * int) + | Constraints of (int * constr) list + +let solve_constraints constr_info indt = + (* TODO *) + Constraints [] + +let rec irrefutable env = function + | PatVar (_,name) -> true + | PatCstr (_,cstr,args,_) -> + let ind = inductive_of_constructor cstr in + let (_,mip) = Inductive.lookup_mind_specif env ind in + let one_constr = Array.length mip.mind_user_lc = 1 in + one_constr & List.for_all (irrefutable env) args + +let first_clause_irrefutable env = function + | eqn::mat -> List.for_all (irrefutable env) eqn.patterns + | _ -> false + +let group_equations pb ind current cstrs mat = + let mat = + if first_clause_irrefutable pb.env mat then [List.hd mat] else mat in + let brs = Array.create (Array.length cstrs) [] in + let only_default = ref true in + let _ = + List.fold_right (* To be sure it's from bottom to top *) + (fun eqn () -> + let rest = remove_current_pattern eqn in + let pat = current_pattern eqn in + match check_and_adjust_constructor pb.env ind cstrs pat with + | PatVar (_,name) -> + (* This is a default clause that we expand *) + for i=1 to Array.length cstrs do + let n = cstrs.(i-1).cs_nargs in + let args = make_anonymous_patvars n in + let rest = {rest with tag = lower_pattern_status rest.tag } in + brs.(i-1) <- (args, rest) :: brs.(i-1) + done + | PatCstr (loc,((_,i)),args,_) -> + (* This is a regular clause *) + only_default := false; + brs.(i-1) <- (args,rest) :: brs.(i-1)) mat () in + (brs,!only_default) + +(************************************************************************) +(* Here starts the pattern-matching compilation algorithm *) + +(* Abstracting over dependent subterms to match *) +let rec generalize_problem pb = function + | [] -> pb + | i::l -> + let d = map_rel_declaration (lift i) (Environ.lookup_rel i pb.env) in + let pb' = generalize_problem pb l in + let tomatch = lift_tomatch_stack 1 pb'.tomatch in + let tomatch = regeneralize_index_tomatch (i+1) tomatch in + { pb with + tomatch = Abstract d :: tomatch; + pred = option_map (generalize_predicate i d) pb'.pred } + +(* No more patterns: typing the right-hand-side of equations *) +let build_leaf pb = + let tag, rhs = extract_rhs pb in + let tycon = match pb.pred with + | None -> anomaly "Predicate not found" + | Some (PrCcl typ) -> mk_tycon typ + | Some _ -> anomaly "not all parameters of pred have been consumed" in + tag, pb.typing_function tycon rhs.rhs_env rhs.it + +(* Building the sub-problem when all patterns are variables *) +let shift_problem (current,t) pb = + {pb with + tomatch = Alias (current,current,NonDepAlias,type_of_tomatch t)::pb.tomatch; + pred = option_map (specialize_predicate_var (current,t)) pb.pred; + history = push_history_pattern 0 AliasLeaf pb.history; + mat = List.map remove_current_pattern pb.mat } + +(* Building the sub-pattern-matching problem for a given branch *) +let build_branch current deps pb eqns const_info = + (* We remember that we descend through a constructor *) + let alias_type = + if Array.length const_info.cs_concl_realargs = 0 + & not (known_dependent pb.pred) & deps = [] + then + NonDepAlias + else + DepAlias + in + let history = + push_history_pattern const_info.cs_nargs + (AliasConstructor const_info.cs_cstr) + pb.history in + + (* We find matching clauses *) + let cs_args = (*assums_of_rel_context*) const_info.cs_args in + let names = get_names pb.env cs_args eqns in + let submat = List.map (fun (tms,eqn) -> prepend_pattern tms eqn) eqns in + if submat = [] then + raise_pattern_matching_error + (dummy_loc, pb.env, NonExhaustive (complete_history history)); + let typs = List.map2 (fun (_,c,t) na -> (na,c,t)) cs_args names in + let _,typs',_ = + List.fold_right + (fun (na,c,t as d) (env,typs,tms) -> + let tm1 = List.map List.hd tms in + let tms = List.map List.tl tms in + (push_rel d env, (na,to_mutind env pb.isevars tm1 c t)::typs,tms)) + typs (pb.env,[],List.map fst eqns) in + + let dep_sign = + find_dependencies_signature + (dependencies_in_rhs const_info.cs_nargs eqns) (List.rev typs) in + + (* The dependent term to subst in the types of the remaining UnPushed + terms is relative to the current context enriched by topushs *) + let ci = build_dependent_constructor const_info in + + (* We replace [(mkRel 1)] by its expansion [ci] *) + (* and context "Gamma = Gamma1, current, Gamma2" by "Gamma;typs;curalias" *) + (* This is done in two steps : first from "Gamma |- tms" *) + (* into "Gamma; typs; curalias |- tms" *) + let tomatch = lift_tomatch_stack const_info.cs_nargs pb.tomatch in + + let currents = + list_map2_i + (fun i (na,t) deps -> Pushed ((mkRel i, lift_tomatch_type i t), deps)) + 1 typs' (List.rev dep_sign) in + + let sign = List.map (fun (na,t) -> mkDeclTomatch na t) typs' in + let ind = + appvect ( + applist (mkInd (inductive_of_constructor const_info.cs_cstr), + List.map (lift const_info.cs_nargs) const_info.cs_params), + const_info.cs_concl_realargs) in + + let cur_alias = lift (List.length sign) current in + let currents = Alias (ci,cur_alias,alias_type,ind) :: currents in + let env' = push_rels sign pb.env in + let pred' = option_map (specialize_predicate (List.rev typs') dep_sign const_info) pb.pred in + sign, + { pb with + env = env'; + tomatch = List.rev_append currents tomatch; + pred = pred'; + history = history; + mat = List.map (push_rels_eqn_with_names sign) submat } + +(********************************************************************** + INVARIANT: + + pb = { env, subst, tomatch, mat, ...} + tomatch = list of Pushed (c:T) or Abstract (na:T) or Alias (c:T) + + "Pushed" terms and types are relative to env + "Abstract" types are relative to env enriched by the previous terms to match + +*) + +(**********************************************************************) +(* Main compiling descent *) +let rec compile pb = + match pb.tomatch with + | (Pushed cur)::rest -> match_current { pb with tomatch = rest } cur + | (Alias x)::rest -> compile_alias pb x rest + | (Abstract d)::rest -> compile_generalization pb d rest + | [] -> build_leaf pb + +and match_current pb tomatch = + let ((current,typ as ct),deps) = adjust_tomatch_to_pattern pb tomatch in + match typ with + | NotInd (_,typ) -> + check_all_variables typ pb.mat; + compile (shift_problem ct pb) + | IsInd (_,(IndType(indf,realargs) as indt)) -> + let mind,_ = dest_ind_family indf in + let cstrs = get_constructors pb.env indf in + let eqns,onlydflt = group_equations pb mind current cstrs pb.mat in + if (Array.length cstrs <> 0 or pb.mat <> []) & onlydflt then + compile (shift_problem ct pb) + else + let _constraints = Array.map (solve_constraints indt) cstrs in + + (* We generalize over terms depending on current term to match *) + let pb = generalize_problem pb deps in + + (* We compile branches *) + let brs = array_map2 (compile_branch current deps pb) eqns cstrs in + + (* We build the (elementary) case analysis *) + let tags = Array.map (fun (t,_,_) -> t) brs in + let brvals = Array.map (fun (_,v,_) -> v) brs in + let brtyps = Array.map (fun (_,_,t) -> t) brs in + let (pred,typ,s) = + find_predicate pb.caseloc pb.env pb.isevars + pb.pred brtyps cstrs current indt pb.tomatch in + let ci = make_case_info pb.env mind RegularStyle tags in + let case = mkCase (ci,nf_betaiota pred,current,brvals) in + let inst = List.map mkRel deps in + pattern_status tags, + { uj_val = applist (case, inst); + uj_type = substl inst typ } + +and compile_branch current deps pb eqn cstr = + let sign, pb = build_branch current deps pb eqn cstr in + let tag, j = compile pb in + (tag, it_mkLambda_or_LetIn j.uj_val sign, j.uj_type) + +and compile_generalization pb d rest = + let pb = + { pb with + env = push_rel d pb.env; + tomatch = rest; + pred = option_map ungeneralize_predicate pb.pred; + mat = List.map (push_rels_eqn [d]) pb.mat } in + let patstat,j = compile pb in + patstat, + { uj_val = mkLambda_or_LetIn d j.uj_val; + uj_type = mkProd_or_LetIn d j.uj_type } + +and compile_alias pb (deppat,nondeppat,d,t) rest = + let history = simplify_history pb.history in + let sign, newenv, mat = + insert_aliases pb.env (Evd.evars_of !(pb.isevars)) (deppat,nondeppat,d,t) pb.mat in + let n = List.length sign in + + (* We had Gamma1; x:current; Gamma2 |- tomatch(x) and we rebind x to get *) + (* Gamma1; x:current; Gamma2; typs; x':=curalias |- tomatch(x') *) + let tomatch = lift_tomatch_stack n rest in + let tomatch = match kind_of_term nondeppat with + | Rel i -> + if n = 1 then regeneralize_index_tomatch (i+n) tomatch + else replace_tomatch i deppat tomatch + | _ -> (* initial terms are not dependent *) tomatch in + + let pb = + {pb with + env = newenv; + tomatch = tomatch; + pred = option_map (lift_predicate n) pb.pred; + history = history; + mat = mat } in + let patstat,j = compile pb in + patstat, + List.fold_left mkSpecialLetInJudge j sign + +(* pour les alias des initiaux, enrichir les env de ce qu'il faut et +substituer après par les initiaux *) + +(**************************************************************************) +(* Preparation of the pattern-matching problem *) + +(* builds the matrix of equations testing that each eqn has n patterns + * and linearizing the _ patterns. + * Syntactic correctness has already been done in astterm *) +let matx_of_eqns env eqns = + let build_eqn (loc,ids,lpat,rhs) = + let rhs = + { rhs_env = env; + avoid_ids = ids@(ids_of_named_context (named_context env)); + it = rhs; + } in + { patterns = lpat; + tag = RegularPat; + alias_stack = []; + eqn_loc = loc; + used = ref false; + rhs = rhs } + in List.map build_eqn eqns + +(************************************************************************) +(* preparing the elimination predicate if any *) + +let build_expected_arity env isevars isdep tomatchl = + let cook n = function + | _,IsInd (_,IndType(indf,_)) -> + let indf' = lift_inductive_family n indf in + Some (build_dependent_inductive env indf', fst (get_arity env indf')) + | _,NotInd _ -> None + in + let rec buildrec n env = function + | [] -> new_Type () + | tm::ltm -> + match cook n tm with + | None -> buildrec n env ltm + | Some (ty1,aritysign) -> + let rec follow n env = function + | d::sign -> + mkProd_or_LetIn_name env + (follow (n+1) (push_rel d env) sign) d + | [] -> + if isdep then + mkProd (Anonymous, ty1, + buildrec (n+1) + (push_rel_assum (Anonymous, ty1) env) + ltm) + else buildrec n env ltm + in follow n env (List.rev aritysign) + in buildrec 0 env tomatchl + +let extract_predicate_conclusion isdep tomatchl pred = + let cook = function + | _,IsInd (_,IndType(_,args)) -> Some (List.length args) + | _,NotInd _ -> None in + let rec decomp_lam_force n l p = + if n=0 then (l,p) else + match kind_of_term p with + | Lambda (na,_,c) -> decomp_lam_force (n-1) (na::l) c + | _ -> (* eta-expansion *) + let na = Name (id_of_string "x") in + decomp_lam_force (n-1) (na::l) (applist (lift 1 p, [mkRel 1])) in + let rec buildrec allnames p = function + | [] -> (List.rev allnames,p) + | tm::ltm -> + match cook tm with + | None -> + let p = + (* adjust to a sign containing the NotInd's *) + if isdep then lift 1 p else p in + let names = if isdep then [Anonymous] else [] in + buildrec (names::allnames) p ltm + | Some n -> + let n = if isdep then n+1 else n in + let names,p = decomp_lam_force n [] p in + buildrec (names::allnames) p ltm + in buildrec [] pred tomatchl + +let set_arity_signature dep n arsign tomatchl pred x = + (* avoid is not exhaustive ! *) + let rec decomp_lam_force n avoid l p = + if n = 0 then (List.rev l,p,avoid) else + match p with + | RLambda (_,(Name id as na),_,c) -> + decomp_lam_force (n-1) (id::avoid) (na::l) c + | RLambda (_,(Anonymous as na),_,c) -> decomp_lam_force (n-1) avoid (na::l) c + | _ -> + let x = next_ident_away (id_of_string "x") avoid in + decomp_lam_force (n-1) (x::avoid) (Name x :: l) + (* eta-expansion *) + (let a = RVar (dummy_loc,x) in + match p with + | RApp (loc,p,l) -> RApp (loc,p,l@[a]) + | _ -> (RApp (dummy_loc,p,[a]))) in + let rec decomp_block avoid p = function + | ([], _) -> x := Some p + | ((_,IsInd (_,IndType(indf,realargs)))::l),(y::l') -> + let (ind,params) = dest_ind_family indf in + let (nal,p,avoid') = decomp_lam_force (List.length realargs) avoid [] p + in + let na,p,avoid' = + if dep then decomp_lam_force 1 avoid' [] p else [Anonymous],p,avoid' + in + y := + (List.hd na, + if List.for_all ((=) Anonymous) nal then + None + else + Some (dummy_loc, ind, (List.map (fun _ -> Anonymous) params)@nal)); + decomp_block avoid' p (l,l') + | (_::l),(y::l') -> + y := (Anonymous,None); + decomp_block avoid p (l,l') + | _ -> anomaly "set_arity_signature" + in + decomp_block [] pred (tomatchl,arsign) + +let prepare_predicate_from_tycon loc dep env isevars tomatchs sign c = + let cook (n, l, env, signs) = function + | c,IsInd (_,IndType(indf,realargs)) -> + let indf' = lift_inductive_family n indf in + let sign = make_arity_signature env dep indf' in + let p = List.length realargs in + if dep then + (n + p + 1, c::(List.rev realargs)@l, push_rels sign env,sign::signs) + else + (n + p, (List.rev realargs)@l, push_rels sign env,sign::signs) + | c,NotInd _ -> + (n, l, env, []::signs) in + let n, allargs, env, signs = List.fold_left cook (0, [], env, []) tomatchs in + let names = List.rev (List.map (List.map pi1) signs) in + let allargs = + List.map (fun c -> lift n (nf_betadeltaiota env (Evd.evars_of !isevars) c)) allargs in + let rec build_skeleton env c = + (* Don't put into normal form, it has effects on the synthesis of evars *) + (* let c = whd_betadeltaiota env (evars_of isevars) c in *) + (* We turn all subterms possibly dependent into an evar with maximum ctxt*) + if isEvar c or List.exists (eq_constr c) allargs then + e_new_evar isevars env ~src:(loc, Evd.CasesType) + (Retyping.get_type_of env (Evd.evars_of !isevars) c) + else + map_constr_with_full_binders push_rel build_skeleton env c + in + names, build_skeleton env (lift n c) + +(* Here, [pred] is assumed to be in the context built from all *) +(* realargs and terms to match *) +let build_initial_predicate isdep allnames pred = + let nar = List.fold_left (fun n names -> List.length names + n) 0 allnames in + let rec buildrec n pred = function + | [] -> PrCcl pred + | names::lnames -> + let names' = if isdep then List.tl names else names in + let n' = n + List.length names' in + let pred, p, user_p = + if isdep then + if dependent (mkRel (nar-n')) pred then pred, 1, 1 + else liftn (-1) (nar-n') pred, 0, 1 + else pred, 0, 0 in + let na = + if p=1 then + let na = List.hd names in + if na = Anonymous then + (* peut arriver en raison des evars *) + Name (id_of_string "x") (*Hum*) + else na + else Anonymous in + PrLetIn ((names',na), buildrec (n'+user_p) pred lnames) + in buildrec 0 pred allnames + +let extract_arity_signature env0 tomatchl tmsign = + let get_one_sign n tm (na,t) = + match tm with + | NotInd (bo,typ) -> + (match t with + | None -> [na,option_map (lift n) bo,lift n typ] + | Some (loc,_,_,_) -> + user_err_loc (loc,"", + str "Unexpected type annotation for a term of non inductive type")) + | IsInd (_,IndType(indf,realargs)) -> + let indf' = lift_inductive_family n indf in + let (ind,params) = dest_ind_family indf' in + let nrealargs = List.length realargs in + let realnal = + match t with + | Some (loc,ind',nparams,realnal) -> + if ind <> ind' then + user_err_loc (loc,"",str "Wrong inductive type"); + if List.length params <> nparams + or nrealargs <> List.length realnal then + anomaly "Ill-formed 'in' clause in cases"; + List.rev realnal + | None -> list_tabulate (fun _ -> Anonymous) nrealargs in + let arsign = fst (get_arity env0 indf') in + (na,None,build_dependent_inductive env0 indf') + ::(List.map2 (fun x (_,c,t) ->(x,c,t)) realnal arsign) in + let rec buildrec n = function + | [],[] -> [] + | (_,tm)::ltm, x::tmsign -> + let l = get_one_sign n tm x in + l :: buildrec (n + List.length l) (ltm,tmsign) + | _ -> assert false + in List.rev (buildrec 0 (tomatchl,tmsign)) + +let inh_conv_coerce_to_tycon loc env isevars j tycon = + match tycon with + | Some p -> + let (evd',j) = Coercion.inh_conv_coerce_to loc env !isevars j p in + isevars := evd'; + j + | None -> j + +let out_ind = function IsInd (_, IndType(x, y)) -> (x, y) | _ -> assert(false) + +let list_mapi f l = + let rec aux n = function + [] -> [] + | hd :: tl -> f n hd :: aux (succ n) tl + in aux 0 l + +let constr_of_pat env isevars ty pat idents = + let rec typ env ty pat idents = + trace (str "Typing pattern " ++ Printer.pr_cases_pattern pat ++ str " in env " ++ + print_env env ++ str" should have type: " ++ my_print_constr env ty); + match pat with + | PatVar (l,name) -> + let name, idents' = match name with + Name n -> name, idents + | Anonymous -> + let n' = next_ident_away_from (id_of_string "wildcard") idents in + Name n', n' :: idents + in +(* trace (str "Treating pattern variable " ++ str (string_of_id (id_of_name name))); *) + PatVar (l, name), [name, None, ty], mkRel 1, 1, idents' + | PatCstr (l,((_, i) as cstr),args,alias) -> + let _ind = inductive_of_constructor cstr in + let IndType (indf, realargs) = find_rectype env (Evd.evars_of !isevars) ty in + let ind, params = dest_ind_family indf in + let cstrs = get_constructors env indf in + let ci = cstrs.(i-1) in + let nb_args_constr = ci.cs_nargs in + assert(nb_args_constr = List.length args); + let idents' = idents in + let patargs, args, sign, env, n, m, idents' = + List.fold_right2 + (fun (na, c, t) ua (patargs, args, sign, env, n, m, idents) -> + let pat', sign', arg', n', idents' = typ env (lift (n - m) t) ua idents in + let args' = arg' :: List.map (lift n') args in + let env' = push_rels sign' env in + (pat' :: patargs, args', sign' @ sign, env', n' + n, succ m, idents')) + ci.cs_args (List.rev args) ([], [], [], env, 0, 0, idents') + in + let args = List.rev args in + let patargs = List.rev patargs in + let pat' = PatCstr (l, cstr, patargs, alias) in + let cstr = mkConstruct ci.cs_cstr in + let app = applistc cstr (List.map (lift (List.length sign)) params) in + let app = applistc app args in +(* trace (str "New pattern: " ++ Printer.pr_cases_pattern pat'); *) +(* let alname = if alias <> Anonymous then alias else Name (id_of_string "anon") in *) +(* let al = alname, Some (mkRel 1), lift 1 ty in *) + if alias <> Anonymous then + pat', (alias, Some app, ty) :: sign, lift 1 app, n + 1, idents' + else pat', sign, app, n, idents' + in + let pat', sign, y, z, idents = typ env ty pat idents in + let c = it_mkProd_or_LetIn y sign in + trace (str "Constr_of_pat gives: " ++ my_print_constr env c); + pat', (sign, y), idents + +let mk_refl typ a = mkApp (Lazy.force eq_refl, [| typ; a |]) + +let vars_of_ctx = + List.rev_map (fun (na, _, t) -> + match na with + Anonymous -> raise (Invalid_argument "vars_of_ctx") + | Name n -> RVar (dummy_loc, n)) + +(*let build_ineqs eqns pats = + List.fold_left + (fun (sign, c) eqn -> + let acc = fold_left3 + (fun acc prevpat (ppat_sign, ppat_c, ppat_ty) (pat, pat_c) -> + match acc with + None -> None + | Some (sign,len, c) -> + if is_included pat prevpat then + let lens = List.length ppat_sign in + let acc = + (lift_rels lens ppat_sign @ sign, + lens + len, + mkApp (Lazy.force eq_ind, + [| ppat_ty ; ppat_c ; + lift (lens + len) pat_c |]) :: c) + in Some acc + else None) + (sign, c) eqn.patterns eqn.c_patterns pats + in match acc with + None -> (sign, c) + | Some (sign, len, c) -> + it_mkProd_or_LetIn c sign + + ) + ([], []) eqns*) + +let constrs_of_pats typing_fun tycon env isevars eqns tomatchs = + let i = ref 0 in + List.fold_left + (fun (branches, eqns) eqn -> + let _, newpatterns, pats = + List.fold_right2 (fun pat (_, ty) (idents, newpatterns, pats) -> + let x, y, z = constr_of_pat env isevars (type_of_tomatch ty) pat idents in + (z, x :: newpatterns, y :: pats)) + eqn.patterns tomatchs ([], [], []) + in + let rhs_rels, signlen = + List.fold_left (fun (renv, n) (sign,_) -> + ((lift_rel_context n sign) @ renv, List.length sign + n)) + ([], 0) pats in + let eqs, _, _ = List.fold_left2 + (fun (eqs, n, slen) (sign, c) (tm, ty) -> + let len = n + signlen in (* Number of already defined equations + signature *) + let csignlen = List.length sign in + let slen' = slen - csignlen in (* Lift to get pattern variables signature *) + let c = liftn (signlen - slen) signlen c in (* Lift to jump over previous ind signatures for pattern variables outside sign + in c (e.g. type arguments of constructors instanciated by variables ) *) + let cstr = lift (slen' + n) c in +(* trace (str "lift " ++ my_print_constr (push_rels sign env) c ++ *) +(* str " by " ++ int ++ str " to get " ++ *) +(* my_print_constr (push_rels sign env) cstr); *) + let app = + mkApp (Lazy.force eq_ind, + [| lift len (type_of_tomatch ty); cstr; lift len tm |]) + in app :: eqs, succ n, slen') + ([], 0, signlen) pats tomatchs + in + let eqs_rels = List.map (fun eq -> Name (id_of_string "H"), None, eq) eqs in +(* let ineqs = build_ineqs eqns newpatterns in *) + let rhs_rels' = eqs_rels @ rhs_rels in + let rhs_env = push_rels rhs_rels' env in +(* (try trace (str "branch env: " ++ print_env rhs_env) *) +(* with _ -> trace (str "error in print branch env")); *) + let tycon = lift_tycon (List.length eqs + signlen) tycon in + + let j = typing_fun tycon rhs_env eqn.rhs.it in +(* (try trace (str "in env: " ++ my_print_env rhs_env ++ str"," ++ *) +(* str "Typed branch: " ++ Prettyp.print_judgment rhs_env j); *) +(* with _ -> *) +(* trace (str "Error in typed branch pretty printing")); *) + let bbody = it_mkLambda_or_LetIn j.uj_val rhs_rels' + and btype = it_mkProd_or_LetIn j.uj_type rhs_rels' in + let branch_name = id_of_string ("branch_" ^ (string_of_int !i)) in + let branch_decl = (Name branch_name, Some (lift !i bbody), (lift !i btype)) in +(* (try trace (str "Branch decl: " ++ pr_rel_decl env (Name branch_name, Some bbody, btype)) *) +(* with _ -> trace (str "Error in branch decl pp")); *) + let branch = + let bref = RVar (dummy_loc, branch_name) in + match vars_of_ctx rhs_rels with + [] -> bref + | l -> RApp (dummy_loc, bref, l) + in +(* let branch = *) +(* List.fold_left (fun br (eqH, _, t) -> RLambda (dummy_loc, eqH, RHole (dummy_loc, Evd.InternalHole), br)) branch eqs_rels *) +(* in *) +(* (try trace (str "New branch: " ++ Printer.pr_rawconstr branch) *) +(* with _ -> trace (str "Error in new branch pp")); *) + incr i; + let rhs = { eqn.rhs with it = branch } in + (branch_decl :: branches, + { eqn with patterns = newpatterns; rhs = rhs } :: eqns)) + ([], []) eqns + + +(* liftn_rel_declaration *) + + +(* Builds the predicate. If the predicate is dependent, its context is + * made of 1+nrealargs assumptions for each matched term in an inductive + * type and 1 assumption for each term not _syntactically_ in an + * inductive type. + + * Each matched terms are independently considered dependent or not. + + * A type constraint but no annotation case: it is assumed non dependent. + *) + +let prepare_predicate_from_tycon loc typing_fun isevars env tomatchs arsign tycon = + (* We extract the signature of the arity *) +(* List.iter *) +(* (fun arsign -> *) +(* trace (str "arity signature: " ++ my_print_rel_context env arsign)) *) +(* arsign; *) +(* let env = List.fold_right push_rels arsign env in *) + let allnames = List.rev (List.map (List.map pi1) arsign) in + let nar = List.fold_left (fun n names -> List.length names + n) 0 allnames in + let pred = out_some (valcon_of_tycon tycon) in + let predcclj, pred, neqs = + let _, _, eqs = + List.fold_left2 + (fun (neqs, slift, eqs) ctx (tm,ty) -> + let len = List.length ctx in + let _name, _, _typ' = List.hd ctx in (* FixMe: Ignoring dependent inductives *) + let eq = mkApp (Lazy.force eq_ind, + [| lift (neqs + nar) (type_of_tomatch ty); + mkRel (neqs + slift); + lift (neqs + nar) tm|]) + in + (succ neqs, slift - len, (Anonymous, None, eq) :: eqs)) + (0, nar, []) (List.rev arsign) tomatchs + in + let len = List.length eqs in + it_mkProd_wo_LetIn (lift (nar + len) pred) eqs, pred, len + in + let predccl = nf_isevar !isevars predcclj in +(* let env' = List.fold_right push_rel_context arsign env in *) +(* trace (str " Env:" ++ my_print_env env' ++ str" Predicate: " ++ my_print_constr env' predccl); *) + build_initial_predicate true allnames predccl, pred + +let prepare_predicate_from_rettyp loc typing_fun isevars env tomatchs sign tycon rtntyp = + (* We extract the signature of the arity *) + let arsign = extract_arity_signature env tomatchs sign in + let env = List.fold_right push_rels arsign env in + let allnames = List.rev (List.map (List.map pi1) arsign) in + let predcclj = typing_fun (mk_tycon (new_Type ())) env rtntyp in +(* let _ = *) +(* option_map (fun tycon -> *) +(* isevars := Coercion.inh_conv_coerces_to loc env !isevars predcclj.uj_val *) +(* (lift_tycon_type (List.length arsign) tycon)) *) +(* tycon *) +(* in *) + let predccl = (j_nf_isevar !isevars predcclj).uj_val in + Some (build_initial_predicate true allnames predccl) + +let lift_ctx n ctx = + let ctx', _ = + List.fold_right (fun (c, t) (ctx, n') -> (liftn n n' c, liftn_tomatch_type n n' t) :: ctx, succ n') ctx ([], 0) + in ctx' + +(* Turn matched terms into variables. *) +let abstract_tomatch env tomatchs = + let prev, ctx, names = + List.fold_left + (fun (prev, ctx, names) (c, t) -> + let lenctx = List.length ctx in + match kind_of_term c with + Rel n -> (lift lenctx c, lift_tomatch_type lenctx t) :: prev, ctx, names + | _ -> + let name = next_ident_away_from (id_of_string "filtered_var") names in + (mkRel 1, lift_tomatch_type 1 t) :: lift_ctx 1 prev, + (Name name, Some (lift lenctx c), lift lenctx $ type_of_tomatch t) :: ctx, + name :: names) + ([], [], []) tomatchs + in List.rev prev, ctx + +(**************************************************************************) +(* Main entry of the matching compilation *) + +let compile_cases loc (typing_fun, isevars) (tycon : Evarutil.type_constraint) env (predopt, tomatchl, eqns)= + let tycon0 = tycon in + (* We build the matrix of patterns and right-hand-side *) + let matx = matx_of_eqns env eqns in + + (* We build the vector of terms to match consistently with the *) + (* constructors found in patterns *) + let tomatchs = coerce_to_indtype typing_fun isevars env matx tomatchl in + let tomatchs, tomatchs_lets = abstract_tomatch env tomatchs in + let tomatchs_len = List.length tomatchs_lets in + let tycon = lift_tycon tomatchs_len tycon in + let env = push_rel_context tomatchs_lets env in + match predopt with + None -> + let lets, matx = constrs_of_pats typing_fun tycon env isevars matx tomatchs in + let matx = List.rev matx in + let len = List.length lets in + let sign = + let arsign = extract_arity_signature env tomatchs (List.map snd tomatchl) in + List.map (lift_rel_context len) arsign + in + let env = push_rels lets env in + let matx = List.map (fun eqn -> { eqn with rhs = { eqn.rhs with rhs_env = env } }) matx in + let tycon = lift_tycon len tycon in + let tomatchs = List.map (fun (x, y) -> lift len x, lift_tomatch_type len y) tomatchs in + let args = List.map (fun (tm,ty) -> mk_refl (type_of_tomatch ty) tm) tomatchs in + + (* We build the elimination predicate if any and check its consistency *) + (* with the type of arguments to match *) + let pred, opred = prepare_predicate_from_tycon loc typing_fun isevars env tomatchs sign tycon in + (* We push the initial terms to match and push their alias to rhs' envs *) + (* names of aliases will be recovered from patterns (hence Anonymous here) *) + let initial_pushed = List.map (fun tm -> Pushed (tm,[])) tomatchs in + + let pb = + { env = env; + isevars = isevars; + pred = Some pred; + tomatch = initial_pushed; + history = start_history (List.length initial_pushed); + mat = matx; + caseloc = loc; + typing_function = typing_fun } in + + let _, j = compile pb in + (* We check for unused patterns *) + List.iter (check_unused_pattern env) matx; + let ty = out_some (valcon_of_tycon tycon0) in + let body = it_mkLambda_or_LetIn (applistc j.uj_val args) lets in + let j = + { uj_val = it_mkLambda_or_LetIn body tomatchs_lets; + uj_type = ty; } + in + inh_conv_coerce_to_tycon loc env isevars j tycon0 + + | Some rtntyp -> + (* We build the elimination predicate if any and check its consistency *) + (* with the type of arguments to match *) + let tmsign = List.map snd tomatchl in + let pred = prepare_predicate_from_rettyp loc typing_fun isevars env tomatchs tmsign tycon rtntyp in + + (* We push the initial terms to match and push their alias to rhs' envs *) + (* names of aliases will be recovered from patterns (hence Anonymous here) *) + let initial_pushed = List.map (fun tm -> Pushed (tm,[])) tomatchs in + + let pb = + { env = env; + isevars = isevars; + pred = pred; + tomatch = initial_pushed; + history = start_history (List.length initial_pushed); + mat = matx; + caseloc = loc; + typing_function = typing_fun } in + + let _, j = compile pb in + (* We check for unused patterns *) + List.iter (check_unused_pattern env) matx; + let j = { j with uj_val = it_mkLambda_or_LetIn j.uj_val tomatchs_lets } in + inh_conv_coerce_to_tycon loc env isevars j tycon + +end + diff --git a/contrib/subtac/subtac_cases.mli b/contrib/subtac/subtac_cases.mli new file mode 100644 index 00000000..9e902126 --- /dev/null +++ b/contrib/subtac/subtac_cases.mli @@ -0,0 +1,50 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(*i $Id: cases.mli 8741 2006-04-26 22:30:32Z herbelin $ i*) + +(*i*) +open Util +open Names +open Term +open Evd +open Environ +open Inductiveops +open Rawterm +open Evarutil +(*i*) + +type pattern_matching_error = + | BadPattern of constructor * constr + | BadConstructor of constructor * inductive + | WrongNumargConstructor of constructor * int + | WrongNumargInductive of inductive * int + | WrongPredicateArity of constr * constr * constr + | NeedsInversion of constr * constr + | UnusedClause of cases_pattern list + | NonExhaustive of cases_pattern list + | CannotInferPredicate of (constr * types) array + +exception PatternMatchingError of env * pattern_matching_error + +val error_wrong_numarg_constructor_loc : loc -> env -> constructor -> int -> 'a + +val error_wrong_numarg_inductive_loc : loc -> env -> inductive -> int -> 'a + +(*s Compilation of pattern-matching. *) + +module type S = sig + val compile_cases : + loc -> + (type_constraint -> env -> rawconstr -> unsafe_judgment) * evar_defs ref -> + type_constraint -> + env -> rawconstr option * tomatch_tuple * cases_clauses -> + unsafe_judgment +end + +module Cases_F(C : Coercion.S) : S diff --git a/contrib/subtac/subtac_coercion.ml b/contrib/subtac/subtac_coercion.ml index da5c497c..3613ec4f 100644 --- a/contrib/subtac/subtac_coercion.ml +++ b/contrib/subtac/subtac_coercion.ml @@ -5,7 +5,7 @@ (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: subtac_coercion.ml 9284 2006-10-26 12:06:57Z msozeau $ *) +(* $Id: subtac_coercion.ml 9563 2007-01-31 09:37:18Z msozeau $ *) open Util open Names @@ -53,8 +53,6 @@ module Coercion = struct | _ -> None and disc_exist env x = - (try trace (str "Disc_exist: " ++ my_print_constr env x) - with _ -> ()); match kind_of_term x with | App (c, l) -> (match kind_of_term c with @@ -67,8 +65,6 @@ module Coercion = struct let disc_proj_exist env x = - (try trace (str "disc_proj_exist: " ++ my_print_constr env x); - with _ -> ()); match kind_of_term x with | App (c, l) -> (if Term.eq_constr c (Lazy.force sig_).proj1 @@ -108,27 +104,27 @@ module Coercion = struct : (Term.constr -> Term.constr) option = let x = nf_evar (evars_of !isevars) x and y = nf_evar (evars_of !isevars) y in - (try debug 1 (str "Coerce called for " ++ (my_print_constr env x) ++ - str " and "++ my_print_constr env y ++ - str " with evars: " ++ spc () ++ - my_print_evardefs !isevars); - with _ -> ()); +(* (try debug 1 (str "Coerce called for " ++ (my_print_constr env x) ++ *) +(* str " and "++ my_print_constr env y ++ *) +(* str " with evars: " ++ spc () ++ *) +(* my_print_evardefs !isevars); *) +(* with _ -> ()); *) let rec coerce_unify env x y = - (try debug 1 (str "coerce_unify from " ++ (my_print_constr env x) ++ - str " to "++ my_print_constr env y) - with _ -> ()); +(* (try debug 1 (str "coerce_unify from " ++ (my_print_constr env x) ++ *) +(* str " to "++ my_print_constr env y) *) +(* with _ -> ()); *) try isevars := the_conv_x_leq env x y !isevars; - (try debug 1 (str "Unified " ++ (my_print_constr env x) ++ - str " and "++ my_print_constr env y); - with _ -> ()); +(* (try debug 1 (str "Unified " ++ (my_print_constr env x) ++ *) +(* str " and "++ my_print_constr env y); *) +(* with _ -> ()); *) None with Reduction.NotConvertible -> coerce' env (hnf env isevars x) (hnf env isevars y) and coerce' env x y : (Term.constr -> Term.constr) option = let subco () = subset_coerce env isevars x y in - (try debug 1 (str "coerce' from " ++ (my_print_constr env x) ++ - str " to "++ my_print_constr env y); - with _ -> ()); +(* (try debug 1 (str "coerce' from " ++ (my_print_constr env x) ++ *) +(* str " to "++ my_print_constr env y); *) +(* with _ -> ()); *) match (kind_of_term x, kind_of_term y) with | Sort s, Sort s' -> (match s, s' with @@ -158,11 +154,11 @@ module Coercion = struct let existS = Lazy.force existS in let prod = Lazy.force prod in if len = Array.length l' && len = 2 && i = i' + && (i = Term.destInd existS.typ || i = Term.destInd prod.typ) then if i = Term.destInd existS.typ then begin - trace (str "In coerce sigma types"); let (a, pb), (a', pb') = pair_of_array l, pair_of_array l' in @@ -185,7 +181,6 @@ module Coercion = struct let c2 = coerce_unify env' b b' in match c1, c2 with None, None -> - trace (str "No coercion needed"); None | _, _ -> Some @@ -198,9 +193,8 @@ module Coercion = struct in mkApp (existS.intro, [| a'; pb'; x ; y |])) end - else if i = Term.destInd prod.typ then + else begin - debug 1 (str "In coerce prod types"); let (a, b), (a', b') = pair_of_array l, pair_of_array l' in @@ -219,14 +213,48 @@ module Coercion = struct in mkApp (prod.intro, [| a'; b'; x ; y |])) end - else subco () - else subco () - | _ -> subco ()) + else + (* if len = 1 && len = Array.length l' && i = i' then *) +(* let argx, argy = l.(0), l'.(0) in *) +(* let indtyp = Inductiveops.type_of_inductive env i in *) +(* let argname, argtype, _ = destProd indtyp in *) +(* let eq = *) +(* mkApp (Lazy.force eqind, [| argtype; argx; argy |]) *) +(* in *) +(* let pred = mkLambda (argname, argtype, *) +(* mkApp (mkInd i, [| mkRel 1 |])) *) +(* in *) +(* let evar = make_existential dummy_loc env isevars eq in *) +(* Some (fun x -> *) +(* mkApp (Lazy.force eqrec, *) +(* [| argtype; argx; pred; x; argy; evar |])) *) +(* else *)subco () + | x, y when x = y -> + let lam_type = Typing.type_of env (evars_of !isevars) c in + let rec coerce typ i co = + if i < Array.length l then + let hdx = l.(i) and hdy = l'.(i) in + let (n, eqT, restT) = destProd typ in + let pred = mkLambda (n, eqT, mkApp (lift 1 c, [| mkRel 1 |])) in + let eq = mkApp (Lazy.force eq_ind, [| eqT; hdx; hdy |]) in + let evar = make_existential dummy_loc env isevars eq in + let eq_app x = mkApp (Lazy.force eq_rect, + [| eqT; hdx; pred; x; hdy; evar|]) + in + coerce (subst1 hdy restT) (succ i) (fun x -> eq_app (co x)) + else co + in + if Array.length l = Array.length l' then ( + trace (str"Inserting coercion at application"); + Some (coerce lam_type 0 (fun x -> x)) + ) else subco () + | _ -> subco ()) | _, _ -> subco () and subset_coerce env isevars x y = match disc_subset x with Some (u, p) -> + (* trace (str "Inserting projection "); *) let c = coerce_unify env u y in let f x = app_opt c (mkApp ((Lazy.force sig_).proj1, @@ -372,13 +400,13 @@ module Coercion = struct with Reduction.NotConvertible -> raise NoCoercion let rec inh_conv_coerce_to_fail loc env isevars v t c1 = - (try - debug 1 (str "inh_conv_coerce_to_fail called for " ++ - Termops.print_constr_env env t ++ str " and "++ spc () ++ - Termops.print_constr_env env c1 ++ str " with evars: " ++ spc () ++ - Evd.pr_evar_defs isevars ++ str " in env: " ++ spc () ++ - Termops.print_env env); - with _ -> ()); +(* (try *) +(* debug 1 (str "inh_conv_coerce_to_fail called for " ++ *) +(* Termops.print_constr_env env t ++ str " and "++ spc () ++ *) +(* Termops.print_constr_env env c1 ++ str " with evars: " ++ spc () ++ *) +(* Subtac_utils.pr_evar_defs isevars ++ str " in env: " ++ spc () ++ *) +(* Termops.print_env env); *) +(* with _ -> ()); *) try (the_conv_x_leq env t c1 isevars, v, t) with Reduction.NotConvertible -> (try @@ -437,14 +465,14 @@ module Coercion = struct (* Look for cj' obtained from cj by inserting coercions, s.t. cj'.typ = t *) - let inh_conv_coerce_to loc env isevars cj ((n, t) as tycon) = - (try - debug 1 (str "Subtac_coercion.inh_conv_coerce_to called for " ++ - Termops.print_constr_env env cj.uj_type ++ str " and "++ spc () ++ - Evarutil.pr_tycon_type env tycon ++ str " with evars: " ++ spc () ++ - Evd.pr_evar_defs isevars ++ str " in env: " ++ spc () ++ - Termops.print_env env); - with _ -> ()); + let inh_conv_coerce_to loc env isevars cj ((n, t) as _tycon) = +(* (try *) +(* trace (str "Subtac_coercion.inh_conv_coerce_to called for " ++ *) +(* Termops.print_constr_env env cj.uj_type ++ str " and "++ spc () ++ *) +(* Evarutil.pr_tycon_type env tycon ++ str " with evars: " ++ spc () ++ *) +(* Subtac_utils.pr_evar_defs isevars ++ str " in env: " ++ spc () ++ *) +(* Termops.print_env env); *) +(* with _ -> ()); *) match n with None -> let (evd', val', type') = @@ -462,40 +490,38 @@ module Coercion = struct | Some (init, cur) -> (isevars, cj) - let inh_conv_coerces_to loc env isevars t ((abs, t') as tycon) = - (try - debug 1 (str "Subtac_coercion.inh_conv_coerces_to called for " ++ - Termops.print_constr_env env t ++ str " and "++ spc () ++ - Evarutil.pr_tycon_type env tycon ++ str " with evars: " ++ spc () ++ - Evd.pr_evar_defs isevars ++ str " in env: " ++ spc () ++ - Termops.print_env env); - with _ -> ()); + let inh_conv_coerces_to loc env isevars t ((abs, t') as _tycon) = +(* (try *) +(* trace (str "Subtac_coercion.inh_conv_coerces_to called for " ++ *) +(* Termops.print_constr_env env t ++ str " and "++ spc () ++ *) +(* Evarutil.pr_tycon_type env tycon ++ str " with evars: " ++ spc () ++ *) +(* Evd.pr_evar_defs isevars ++ str " in env: " ++ spc () ++ *) +(* Termops.print_env env); *) +(* with _ -> ()); *) let nabsinit, nabs = match abs with None -> 0, 0 | Some (init, cur) -> init, cur in - let (rels, rng) = (* a little more effort to get products is needed *) - try decompose_prod_n nabs t - with _ -> - trace (str "decompose_prod_n failed"); - raise (Invalid_argument "Subtac_coercion.inh_conv_coerces_to") - in - (* The final range free variables must have been replaced by evars, we accept only that evars - in rng are applied to free vars. *) - if noccur_with_meta 0 (succ nabsinit) rng then ( - trace (str "No occur between 0 and " ++ int (succ nabsinit)); - let env', t, t' = - let env' = List.fold_right (fun (n, t) env -> push_rel (n, None, t) env) rels env in - env', rng, lift nabs t' - in - try - pi1 (try inh_conv_coerce_to_fail loc env' isevars None t t' - with NoCoercion -> - coerce_itf loc env' isevars None t t') - with NoSubtacCoercion -> - let sigma = evars_of isevars in - error_cannot_coerce env' sigma (t, t')) - else isevars + try let rels, rng = decompose_prod_n nabs t in + (* The final range free variables must have been replaced by evars, we accept only that evars + in rng are applied to free vars. *) + if noccur_with_meta 0 (succ nabsinit) rng then ( +(* trace (str "No occur between 0 and " ++ int (succ nabsinit)); *) + let env', t, t' = + let env' = List.fold_right (fun (n, t) env -> push_rel (n, None, t) env) rels env in + env', rng, lift nabs t' + in + try + pi1 (try inh_conv_coerce_to_fail loc env' isevars None t t' + with NoCoercion -> + coerce_itf loc env' isevars None t t') + with NoSubtacCoercion -> + let sigma = evars_of isevars in + error_cannot_coerce env' sigma (t, t')) + else isevars + with _ -> isevars + (* trace (str "decompose_prod_n failed"); *) + (* raise (Invalid_argument "Subtac_coercion.inh_conv_coerces_to") *) end diff --git a/contrib/subtac/subtac_command.ml b/contrib/subtac/subtac_command.ml index b433af2c..68ab8c46 100644 --- a/contrib/subtac/subtac_command.ml +++ b/contrib/subtac/subtac_command.ml @@ -57,7 +57,7 @@ let interp_gen kind isevars env c = let c' = Constrintern.intern_gen (kind=IsType) ~impls ~allow_soapp ~ltacvars (Evd.evars_of !isevars) env c in let c' = Subtac_utils.rewrite_cases env c' in - (try trace (str "Pretyping " ++ my_print_constr_expr c) with _ -> ()); +(* (try trace (str "Pretyping " ++ my_print_constr_expr c) with _ -> ()); *) let c' = SPretyping.pretype_gen isevars env ([],[]) kind c' in evar_nf isevars c' @@ -150,14 +150,6 @@ let collect_non_rec env = in searchrec [] - -let filter_map f l = - let rec aux acc = function - hd :: tl -> (match f hd with Some t -> aux (t :: acc) tl - | None -> aux acc tl) - | [] -> List.rev acc - in aux [] l - let list_of_local_binders l = let rec aux acc = function Topconstr.LocalRawDef (n, c) :: tl -> aux ((n, Some c, None) :: acc) tl @@ -176,25 +168,29 @@ let rec gen_rels = function 0 -> [] | n -> mkRel n :: gen_rels (pred n) +let split_args n rel = match list_chop ((List.length rel) - n) rel with + (l1, x :: l2) -> l1, x, l2 + | _ -> assert(false) + let build_wellfounded (recname, n, bl,arityc,body) r measure notation boxed = let sigma = Evd.empty in let isevars = ref (Evd.create_evar_defs sigma) in let env = Global.env() in - let pr c = my_print_constr env c in - let prr = Printer.pr_rel_context env in - let prn = Printer.pr_named_context env in - let pr_rel env = Printer.pr_rel_context env in let nc = named_context env in let nc_len = named_context_length nc in - let _ = - try debug 2 (str "In named context: " ++ prn (named_context env) ++ str "Rewriting fixpoint: " ++ Ppconstr.pr_id recname ++ - Ppconstr.pr_binders bl ++ str " : " ++ - Ppconstr.pr_constr_expr arityc ++ str " := " ++ spc () ++ - Ppconstr.pr_constr_expr body) - with _ -> () - in +(* let pr c = my_print_constr env c in *) +(* let prr = Printer.pr_rel_context env in *) +(* let prn = Printer.pr_named_context env in *) +(* let pr_rel env = Printer.pr_rel_context env in *) +(* let _ = *) +(* try debug 2 (str "In named context: " ++ prn (named_context env) ++ str "Rewriting fixpoint: " ++ Ppconstr.pr_id recname ++ *) +(* Ppconstr.pr_binders bl ++ str " : " ++ *) +(* Ppconstr.pr_constr_expr arityc ++ str " := " ++ spc () ++ *) +(* Ppconstr.pr_constr_expr body) *) +(* with _ -> () *) + (* in *) let env', binders_rel = interp_context isevars env bl in - let after, ((argname, _, argtyp) as arg), before = list_chop_hd (succ n) binders_rel in + let after, ((argname, _, argtyp) as arg), before = split_args (succ n) binders_rel in let before_length, after_length = List.length before, List.length after in let argid = match argname with Name n -> n | _ -> assert(false) in let _liftafter = lift_binders 1 after_length after in @@ -226,15 +222,14 @@ let build_wellfounded (recname, n, bl,arityc,body) r measure notation boxed = in let argid' = id_of_string (string_of_id argid ^ "'") in let wfarg len = (Name argid', None, - mkSubset (Name argid') argtyp + mkSubset (Name argid') (lift len argtyp) (wf_rel_fun (mkRel 1) (mkRel (len + 1)))) in let top_bl = after @ (arg :: before) in let intern_bl = after @ (wfarg 1 :: arg :: before) in let top_env = push_rel_context top_bl env in - let intern_env = push_rel_context intern_bl env in + let _intern_env = push_rel_context intern_bl env in let top_arity = interp_type isevars top_env arityc in - (try debug 2 (str "Intern bl: " ++ prr intern_bl) with _ -> ()); let proj = (Lazy.force sig_).Coqlib.proj1 in let projection = mkApp (proj, [| argtyp ; @@ -243,32 +238,32 @@ let build_wellfounded (recname, n, bl,arityc,body) r measure notation boxed = mkRel 1 |]) in - (try debug 2 (str "Top arity: " ++ my_print_constr top_env top_arity) with _ -> ()); + (* (try debug 2 (str "Top arity: " ++ my_print_constr top_env top_arity) with _ -> ()); *) let intern_arity = substnl [projection] after_length top_arity in - (try debug 2 (str "Top arity after subst: " ++ my_print_constr intern_env intern_arity) with _ -> ()); +(* (try debug 2 (str "Top arity after subst: " ++ my_print_constr intern_env intern_arity) with _ -> ()); *) let intern_before_env = push_rel_context before env in let intern_fun_bl = after @ [wfarg 1] in - (try debug 2 (str "Intern fun bl: " ++ prr intern_fun_bl) with _ -> ()); +(* (try debug 2 (str "Intern fun bl: " ++ prr intern_fun_bl) with _ -> ()); *) let intern_fun_arity = intern_arity in - (try debug 2 (str "Intern fun arity: " ++ - my_print_constr intern_env intern_fun_arity) with _ -> ()); +(* (try debug 2 (str "Intern fun arity: " ++ *) +(* my_print_constr intern_env intern_fun_arity) with _ -> ()); *) let intern_fun_arity_prod = it_mkProd_or_LetIn intern_fun_arity intern_fun_bl in let intern_fun_binder = (Name recname, None, intern_fun_arity_prod) in let fun_bl = after @ (intern_fun_binder :: [arg]) in - (try debug 2 (str "Fun bl: " ++ pr_rel intern_before_env fun_bl ++ spc ()) with _ -> ()); +(* (try debug 2 (str "Fun bl: " ++ pr_rel intern_before_env fun_bl ++ spc ()) with _ -> ()); *) let fun_env = push_rel_context fun_bl intern_before_env in let fun_arity = interp_type isevars fun_env arityc in let intern_body = interp_casted_constr isevars fun_env body fun_arity in let intern_body_lam = it_mkLambda_or_LetIn intern_body fun_bl in - let _ = - try debug 2 (str "Fun bl: " ++ prr fun_bl ++ spc () ++ - str "Intern bl" ++ prr intern_bl ++ spc () ++ - str "Top bl" ++ prr top_bl ++ spc () ++ - str "Intern arity: " ++ pr intern_arity ++ - str "Top arity: " ++ pr top_arity ++ spc () ++ - str "Intern body " ++ pr intern_body_lam) - with _ -> () - in +(* let _ = *) +(* try debug 2 (str "Fun bl: " ++ prr fun_bl ++ spc () ++ *) +(* str "Intern bl" ++ prr intern_bl ++ spc () ++ *) +(* str "Top bl" ++ prr top_bl ++ spc () ++ *) +(* str "Intern arity: " ++ pr intern_arity ++ *) +(* str "Top arity: " ++ pr top_arity ++ spc () ++ *) +(* str "Intern body " ++ pr intern_body_lam) *) +(* with _ -> () *) +(* in *) let _impl = if Impargs.is_implicit_args() then Impargs.compute_implicits top_env top_arity @@ -292,53 +287,48 @@ let build_wellfounded (recname, n, bl,arityc,body) r measure notation boxed = let def_appl = applist (fix_def, gen_rels (after_length + 1)) in let def = it_mkLambda_or_LetIn def_appl binders_rel in let typ = it_mkProd_or_LetIn top_arity binders_rel in - debug 2 (str "Constructed def"); - debug 2 (my_print_constr intern_before_env def); - debug 2 (str "Type: " ++ my_print_constr env typ); let fullcoqc = Evarutil.nf_isevar !isevars def in let fullctyp = Evarutil.nf_isevar !isevars typ in - let _ = try trace (str "After evar normalization: " ++ spc () ++ - str "Coq term: " ++ my_print_constr env fullcoqc ++ spc () - ++ str "Coq type: " ++ my_print_constr env fullctyp) - with _ -> () - in +(* let _ = try trace (str "After evar normalization: " ++ spc () ++ *) +(* str "Coq term: " ++ my_print_constr env fullcoqc ++ spc () *) +(* ++ str "Coq type: " ++ my_print_constr env fullctyp) *) +(* with _ -> () *) +(* in *) let evm = non_instanciated_map env isevars in - let _ = try trace (str "Non instanciated evars map: " ++ Evd.pr_evar_map evm) with _ -> () in + (* let _ = try trace (str "Non instanciated evars map: " ++ Evd.pr_evar_map evm) with _ -> () in *) let evars, evars_def = Eterm.eterm_obligations recname nc_len evm fullcoqc (Some fullctyp) in - (try trace (str "Generated obligations : "); - Array.iter - (fun (n, t, _) -> trace (str "Evar " ++ str (string_of_id n) ++ spc () ++ my_print_constr env t)) - evars; - with _ -> ()); - trace (str "Adding to obligations list"); - Subtac_obligations.add_entry recname evars_def fullctyp evars; - trace (str "Added to obligations list") -(* + (* (try trace (str "Generated obligations : "); *) +(* Array.iter *) + (* (fun (n, t, _) -> trace (str "Evar " ++ str (string_of_id n) ++ spc () ++ my_print_constr env t)) *) + (* evars; *) + (* with _ -> ()); *) + Subtac_obligations.add_definition recname evars_def fullctyp evars + let build_mutrec l boxed = - let sigma = Evd.empty - and env0 = Global.env() - in + let sigma = Evd.empty and env = Global.env () in + let nc = named_context env in + let nc_len = named_context_length nc in let lnameargsardef = - (*List.map (fun (f, d) -> Subtac_interp_fixpoint.rewrite_fixpoint env0 protos (f, d))*) + (*List.map (fun (f, d) -> Subtac_interp_fixpoint.rewrite_fixpoint env protos (f, d))*) l in let lrecnames = List.map (fun ((f,_,_,_,_),_) -> f) lnameargsardef and nv = List.map (fun ((_,n,_,_,_),_) -> n) lnameargsardef in (* Build the recursive context and notations for the recursive types *) - let (rec_sign,rec_impls,arityl) = + let (rec_sign,rec_env,rec_impls,arityl) = List.fold_left - (fun (env,impls,arl) ((recname, n, bl,arityc,body),_) -> + (fun (sign,env,impls,arl) ((recname, n, bl,arityc,body),_) -> let isevars = ref (Evd.create_evar_defs sigma) in let arityc = Command.generalize_constr_expr arityc bl in - let arity = interp_type isevars env0 arityc in + let arity = interp_type isevars env arityc in let impl = if Impargs.is_implicit_args() - then Impargs.compute_implicits env0 arity + then Impargs.compute_implicits env arity else [] in let impls' =(recname,([],impl,compute_arguments_scope arity))::impls in - (Environ.push_named (recname,None,arity) env, impls', (isevars, None, arity)::arl)) - (env0,[],[]) lnameargsardef in + ((recname,None,arity) :: sign, Environ.push_named (recname,None,arity) env, impls', (isevars, None, arity)::arl)) + ([],env,[],[]) lnameargsardef in let arityl = List.rev arityl in let notations = List.fold_right (fun (_,ntnopt) l -> option_cons ntnopt l) @@ -357,11 +347,11 @@ let build_mutrec l boxed = match info with None -> let def = abstract_constr_expr def bl in - isevars, info, interp_casted_constr isevars rec_sign ~impls:([],rec_impls) + isevars, info, interp_casted_constr isevars rec_env ~impls:([],rec_impls) def arity | Some (n, artyp, wfrel, fun_bl, intern_bl, intern_arity) -> - let rec_sign = push_rel_context fun_bl rec_sign in - let cstr = interp_casted_constr isevars rec_sign ~impls:([],rec_impls) + let rec_env = push_rel_context fun_bl rec_env in + let cstr = interp_casted_constr isevars rec_env ~impls:([],rec_impls) def intern_arity in isevars, info, it_mkLambda_or_LetIn cstr fun_bl) lnameargsardef arityl @@ -369,162 +359,33 @@ let build_mutrec l boxed = States.unfreeze fs; raise e in States.unfreeze fs; def in - let (lnonrec,(namerec,defrec,arrec,nvrec)) = - collect_non_rec env0 lrecnames recdef arityl nv in - let declare arrec defrec = - let recvec = - Array.map (subst_vars (List.rev (Array.to_list namerec))) defrec in - let recdecls = (Array.map (fun id -> Name id) namerec, arrec, recvec) in - let rec declare i fi = - (try trace (str "Declaring: " ++ pr_id fi ++ spc () ++ - my_print_constr env0 (recvec.(i))); - with _ -> ()); - let ce = - { const_entry_body = mkFix ((nvrec,i),recdecls); - const_entry_type = Some arrec.(i); - const_entry_opaque = false; - const_entry_boxed = boxed} in - let kn = Declare.declare_constant fi (DefinitionEntry ce,IsDefinition Fixpoint) - in (ConstRef kn) - in - (* declare the recursive definitions *) - let lrefrec = Array.mapi declare namerec in - Options.if_verbose ppnl (recursive_message lrefrec); - - - (*(* The others are declared as normal definitions *) - let var_subst id = (id, Constrintern.global_reference id) in - let _ = - List.fold_left - (fun subst (f,def,t) -> - let ce = { const_entry_body = replace_vars subst def; - const_entry_type = Some t; - const_entry_opaque = false; - const_entry_boxed = boxed } in - let _ = - Declare.declare_constant f (DefinitionEntry ce,IsDefinition Definition) - in - warning ((string_of_id f)^" is non-recursively defined"); - (var_subst f) :: subst) - (List.map var_subst (Array.to_list namerec)) - lnonrec - in*) - List.iter (fun (df,c,scope) -> - Metasyntax.add_notation_interpretation df [] c scope) notations - in - let declare l = - let recvec = Array.of_list l - and arrec = Array.map pi3 arrec - in declare arrec recvec - in + collect_non_rec env lrecnames recdef arityl nv in let recdefs = Array.length defrec in - trace (int recdefs ++ str " recursive definitions"); (* Solve remaining evars *) let rec collect_evars i acc = if i < recdefs then let (isevars, info, def) = defrec.(i) in - let _ = try trace (str "In solve evars, isevars is: " ++ Evd.pr_evar_defs !isevars) with _ -> () in + (* let _ = try trace (str "In solve evars, isevars is: " ++ Evd.pr_evar_defs !isevars) with _ -> () in *) let def = evar_nf isevars def in let isevars = Evd.undefined_evars !isevars in - let _ = try trace (str "In solve evars, undefined is: " ++ Evd.pr_evar_defs isevars) with _ -> () in + (* let _ = try trace (str "In solve evars, undefined is: " ++ Evd.pr_evar_defs isevars) with _ -> () in *) let evm = Evd.evars_of isevars in let _, _, typ = arrec.(i) in let id = namerec.(i) in - (* Generalize by the recursive prototypes *) + (* Generalize by the recursive prototypes *) let def = - Termops.it_mkNamedLambda_or_LetIn def (Environ.named_context rec_sign) + Termops.it_mkNamedLambda_or_LetIn def rec_sign and typ = - Termops.it_mkNamedProd_or_LetIn typ (Environ.named_context rec_sign) + Termops.it_mkNamedProd_or_LetIn typ rec_sign in - let evars_def, evars_typ, evars = Eterm.eterm_term evm def (Some typ) in - (*let evars_typ = match evars_typ with Some t -> t | None -> assert(false) in*) - (*let fi = id_of_string (string_of_id id ^ "_evars") in*) - (*let ce = - { const_entry_body = evars_def; - const_entry_type = Some evars_typ; - const_entry_opaque = false; - const_entry_boxed = boxed} in - let kn = Declare.declare_constant fi (DefinitionEntry ce,IsDefinition Definition) in - definition_message fi; - trace (str (string_of_id fi) ++ str " is defined");*) - let evar_sum = - if evars = [] then None - else ( - (try trace (str "Building evars sum for : "); - List.iter - (fun (n, t) -> trace (str "Evar " ++ str (string_of_id n) ++ spc () ++ my_print_constr env0 t)) - evars; - with _ -> ()); - let sum = Subtac_utils.build_dependent_sum evars in - (try trace (str "Evars sum: " ++ my_print_constr env0 (snd sum)); - with _ -> ()); - Some sum) - in - collect_evars (succ i) ((id, evars_def, evar_sum) :: acc) + let evars, def = Eterm.eterm_obligations id nc_len evm def (Some typ) in + collect_evars (succ i) ((id, def, typ, evars) :: acc) else acc in let defs = collect_evars 0 [] in - - (* Solve evars then create the definitions *) - let real_evars = - filter_map (fun (id, kn, sum) -> - match sum with Some (sumtac, sumg) -> Some (id, kn, sumg, sumtac) | None -> None) - defs - in - match real_evars with - [] -> declare (List.rev_map (fun (id, c, _) -> - snd (decompose_lam_n recdefs c)) defs) - | l -> - - Subtac_utils.and_tac real_evars - (fun f _ gr -> - let _ = trace (str "Got a proof of: " ++ pr_global gr ++ - str "type: " ++ my_print_constr (Global.env ()) (Global.type_of_global gr)) in - let constant = match gr with Libnames.ConstRef c -> c - | _ -> assert(false) - in - try - (*let value = Environ.constant_value (Global.env ()) constant in*) - let pis = f (mkConst constant) in - (try (trace (str "Accessors: " ++ - List.fold_right (fun (_, _, _, c) acc -> my_print_constr env0 c ++ spc () ++ acc) - pis (mt())); - trace (str "Applied existentials: " ++ - (List.fold_right - (fun (id, kn, sumg, pi) acc -> - let args = Subtac_utils.destruct_ex pi sumg in - my_print_constr env0 (mkApp (kn, Array.of_list args))) - pis (mt ())))) - with _ -> ()); - let rec aux pis acc = function - (id, kn, sum) :: tl -> - (match sum with - None -> aux pis (kn :: acc) tl - | Some (_, sumg) -> - let (id, kn, sumg, pi), pis = List.hd pis, List.tl pis in - let args = Subtac_utils.destruct_ex pi sumg in - let args = - List.map (fun c -> - try Reductionops.whd_betadeltaiota (Global.env ()) Evd.empty c - with Not_found -> - trace (str "Not_found while reducing " ++ - my_print_constr (Global.env ()) c); - c - ) args - in - let _, newdef = decompose_lam_n (recdefs + List.length args) kn in - let constr = Term.substl (mkRel 1 :: List.rev args) newdef in - aux pis (constr :: acc) tl) - | [] -> List.rev acc - in - declare (aux pis [] defs) - with Environ.NotEvaluableConst cer -> - match cer with - Environ.NoBody -> trace (str "Constant has no body") - | Environ.Opaque -> trace (str "Constant is opaque") - ) -*) + Subtac_obligations.add_mutual_definitions (List.rev defs) nvrec + let out_n = function Some n -> n | None -> 0 @@ -544,8 +405,7 @@ let build_recursive (lnameargsardef:(fixpoint_expr * decl_notation) list) boxed errorlabstrm "Subtac_command.build_recursive" (str "Well-founded fixpoints not allowed in mutually recursive blocks")) lnameargsardef - in assert(false) - (*build_mutrec lnameargsardef boxed*) + in build_mutrec lnameargsardef boxed diff --git a/contrib/subtac/subtac_obligations.ml b/contrib/subtac/subtac_obligations.ml index 7b13b402..d6c1772f 100644 --- a/contrib/subtac/subtac_obligations.ml +++ b/contrib/subtac/subtac_obligations.ml @@ -12,6 +12,8 @@ open Decl_kinds open Util open Evd +type obligation_info = (Names.identifier * Term.types * Intset.t) array + type obligation = { obl_name : identifier; obl_type : types; @@ -24,15 +26,42 @@ type obligations = (obligation array * int) type program_info = { prg_name: identifier; prg_body: constr; - prg_type: types; + prg_type: constr; prg_obligations: obligations; + prg_deps : identifier list; + prg_nvrec : int array; } -let evar_of_obligation o = { evar_hyps = Environ.empty_named_context_val ; +let assumption_message id = + Options.if_verbose message ((string_of_id id) ^ " is assumed") + +let default_tactic : Proof_type.tactic ref = ref Refiner.tclIDTAC + +let set_default_tactic t = default_tactic := t + +let evar_of_obligation o = { evar_hyps = Global.named_context_val () ; evar_concl = o.obl_type ; evar_body = Evar_empty ; evar_extra = None } +let subst_deps obls deps t = + Intset.fold + (fun x acc -> + let xobl = obls.(x) in + debug 3 (str "Trying to get body of obligation " ++ int x); + let oblb = + try out_some xobl.obl_body + with _ -> + debug 3 (str "Couldn't get body of obligation " ++ int x); + assert(false) + in + Term.subst1 oblb (Term.subst_var xobl.obl_name acc)) + deps t + +let subst_deps_obl obls obl = + let t' = subst_deps obls obl.obl_deps obl.obl_type in + { obl with obl_type = t' } + module ProgMap = Map.Make(struct type t = identifier let compare = compare end) let map_replace k v m = ProgMap.add k v (ProgMap.remove k m) @@ -62,21 +91,6 @@ let _ = Summary.survive_module = false; Summary.survive_section = false } -let declare_definition prg = -(* let obls_constrs = - Array.fold_right (fun x acc -> (out_some x.obl_evar.evar_body) :: acc) (fst prg.prg_obligations) [] - in*) - let ce = - { const_entry_body = prg.prg_body; - const_entry_type = Some prg.prg_type; - const_entry_opaque = false; - const_entry_boxed = false} - in - let _constant = Declare.declare_constant - prg.prg_name (DefinitionEntry ce,IsDefinition Definition) - in - Subtac_utils.definition_message prg.prg_name - open Evd let terms_of_evar ev = @@ -88,14 +102,72 @@ let terms_of_evar ev = body, typ | _ -> assert(false) +let rec intset_to = function + -1 -> Intset.empty + | n -> Intset.add n (intset_to (pred n)) + +let subst_body prg = + let obls, _ = prg.prg_obligations in + subst_deps obls (intset_to (pred (Array.length obls))) prg.prg_body + +let declare_definition prg = + let body = subst_body prg in + (try trace (str "Declaring: " ++ Ppconstr.pr_id prg.prg_name ++ spc () ++ + my_print_constr (Global.env()) body); + with _ -> ()); + let ce = + { const_entry_body = body; + const_entry_type = Some prg.prg_type; + const_entry_opaque = false; + const_entry_boxed = false} + in + let _constant = Declare.declare_constant + prg.prg_name (DefinitionEntry ce,IsDefinition Definition) + in + Subtac_utils.definition_message prg.prg_name + +open Pp +open Ppconstr + +let declare_mutual_definition l = + let len = List.length l in + let namerec = Array.of_list (List.map (fun x -> x.prg_name) l) in + let arrec = + Array.of_list (List.map (fun x -> snd (decompose_prod_n len x.prg_type)) l) + in + let recvec = + Array.of_list + (List.map (fun x -> + let subs = (subst_body x) in + snd (decompose_lam_n len subs)) l) + in + let nvrec = (List.hd l).prg_nvrec in + let recdecls = (Array.map (fun id -> Name id) namerec, arrec, recvec) in + let rec declare i fi = + (try trace (str "Declaring: " ++ pr_id fi ++ spc () ++ + my_print_constr (Global.env()) (recvec.(i))); + with _ -> ()); + let ce = + { const_entry_body = mkFix ((nvrec,i),recdecls); + const_entry_type = Some arrec.(i); + const_entry_opaque = false; + const_entry_boxed = true} in + let kn = Declare.declare_constant fi (DefinitionEntry ce,IsDefinition Fixpoint) + in + ConstRef kn + in + let lrefrec = Array.mapi declare namerec in + Options.if_verbose ppnl (recursive_message lrefrec) + let declare_obligation obl body = let ce = { const_entry_body = body; const_entry_type = Some obl.obl_type; - const_entry_opaque = true; + const_entry_opaque = false; const_entry_boxed = false} in - let constant = Declare.declare_constant obl.obl_name (DefinitionEntry ce,IsProof Property) + let constant = Declare.declare_constant obl.obl_name + (DefinitionEntry ce,IsProof Property) in Subtac_utils.definition_message obl.obl_name; { obl with obl_body = Some (mkConst constant) } @@ -113,36 +185,30 @@ let try_tactics obls = | _ -> obl) obls -let add_entry n b t obls = - Options.if_verbose pp (str (string_of_id n) ++ str " has type-checked"); - let init_obls e = - Array.map - (fun (n, t, d) -> - { obl_name = n ; obl_body = None; obl_type = t; obl_deps = d }) - e +let red = Reductionops.nf_betaiota + +let init_prog_info n b t deps nvrec obls = + let obls' = + Array.mapi + (fun i (n, t, d) -> + debug 2 (str "Adding obligation " ++ int i ++ str " with deps : " ++ str (string_of_intset d)); + { obl_name = n ; obl_body = None; + obl_type = red t; + obl_deps = d }) + obls in - if Array.length obls = 0 then ( - Options.if_verbose ppnl (str "."); - declare_definition { prg_name = n ; prg_body = b ; prg_type = t ; prg_obligations = ([||], 0) } ) - else ( - let len = Array.length obls in - let _ = Options.if_verbose ppnl (str ", generating " ++ int len ++ str " obligation(s)") in - let obls = init_obls obls in - let rem = Array.fold_left (fun acc obl -> if obl.obl_body = None then succ acc else acc) 0 obls in - let prg = { prg_name = n ; prg_body = b ; prg_type = t ; prg_obligations = (obls, rem) } in - if rem < len then - Options.if_verbose ppnl (int rem ++ str " obligation(s) remaining."); - if rem = 0 then - declare_definition prg - else - from_prg := ProgMap.add n prg !from_prg) - -let error s = Util.error s + { prg_name = n ; prg_body = b; prg_type = red t; prg_obligations = (obls', Array.length obls'); + prg_deps = deps; prg_nvrec = nvrec; } + +let pperror cmd = Util.errorlabstrm "Subtac" cmd +let error s = pperror (str s) let get_prog name = let prg_infos = !from_prg in match name with - Some n -> ProgMap.find n prg_infos + Some n -> + (try ProgMap.find n prg_infos + with Not_found -> error ("No obligations for program " ^ string_of_id n)) | None -> (let n = map_cardinal prg_infos in match n with @@ -150,57 +216,67 @@ let get_prog name = | 1 -> map_first prg_infos | _ -> error "More than one program with unsolved obligations") +let obligations_solved prg = (snd prg.prg_obligations) = 0 + let update_obls prg obls rem = let prg' = { prg with prg_obligations = (obls, rem) } in - if rem > 1 then ( - debug 2 (int rem ++ str " obligations remaining"); - from_prg := map_replace prg.prg_name prg' !from_prg) + from_prg := map_replace prg.prg_name prg' !from_prg; + if rem > 0 then ( + Options.if_verbose msgnl (int rem ++ str " obligation(s) remaining"); + ) else ( - declare_definition prg'; - from_prg := ProgMap.remove prg.prg_name !from_prg - ) + Options.if_verbose msgnl (str "No more obligations remaining"); + match prg'.prg_deps with + [] -> + declare_definition prg'; + from_prg := ProgMap.remove prg.prg_name !from_prg + | l -> + let progs = List.map (fun x -> ProgMap.find x !from_prg) prg'.prg_deps in + if List.for_all (fun x -> obligations_solved x) progs then + (declare_mutual_definition progs; + from_prg := List.fold_left + (fun acc x -> ProgMap.remove x.prg_name acc) !from_prg progs)) let is_defined obls x = obls.(x).obl_body <> None -let deps_remaining obls x = - let deps = obls.(x).obl_deps in +let deps_remaining obls deps = Intset.fold (fun x acc -> if is_defined obls x then acc else x :: acc) deps [] -let subst_deps obls obl = - let t' = - Intset.fold - (fun x acc -> - let xobl = obls.(x) in - let oblb = out_some xobl.obl_body in - Term.subst1 oblb (Term.subst_var xobl.obl_name acc)) - obl.obl_deps obl.obl_type - in { obl with obl_type = t' } - -let subtac_obligation (user_num, name) = +let solve_obligation prg num = + let user_num = succ num in + let obls, rem = prg.prg_obligations in + let obl = obls.(num) in + if obl.obl_body <> None then + pperror (str "Obligation" ++ spc () ++ int user_num ++ str "already" ++ spc() ++ str "solved.") + else + match deps_remaining obls obl.obl_deps with + [] -> + let obl = subst_deps_obl obls obl in + Command.start_proof obl.obl_name Subtac_utils.goal_proof_kind obl.obl_type + (fun strength gr -> + debug 2 (str "Proof of obligation " ++ int user_num ++ str " finished"); + let obl = { obl with obl_body = Some (Libnames.constr_of_global gr) } in + let obls = Array.copy obls in + let _ = obls.(num) <- obl in + update_obls prg obls (pred rem)); + trace (str "Started obligation " ++ int user_num ++ str " proof: " ++ + Subtac_utils.my_print_constr (Global.env ()) obl.obl_type); + Pfedit.by !default_tactic + | l -> pperror (str "Obligation " ++ int user_num ++ str " depends on obligation(s) " + ++ str (string_of_list ", " (fun x -> string_of_int (succ x)) l)) + +let subtac_obligation (user_num, name, typ) = let num = pred user_num in let prg = get_prog name in let obls, rem = prg.prg_obligations in if num < Array.length obls then let obl = obls.(num) in match obl.obl_body with - None -> - (match deps_remaining obls num with - [] -> - let obl = subst_deps obls obl in - Command.start_proof obl.obl_name Subtac_utils.goal_proof_kind obl.obl_type - (fun strength gr -> - debug 2 (str "Proof of obligation " ++ int user_num ++ str " finished"); - let obl = { obl with obl_body = Some (Libnames.constr_of_global gr) } in - let obls = Array.copy obls in - let _ = obls.(num) <- obl in - update_obls prg obls (pred rem)); - trace (str "Started obligation " ++ int user_num ++ str " proof") - | l -> msgnl (str "Obligation " ++ int user_num ++ str " depends on obligation(s) " - ++ str (string_of_list ", " (fun x -> string_of_int (succ x)) l))) + None -> solve_obligation prg num | Some r -> error "Obligation already solved" else error (sprintf "Unknown obligation number %i" (succ num)) @@ -217,33 +293,102 @@ let obligations_of_evars evars = }) evars) in arr, Array.length arr +let solve_obligation_by_tac prg obls i tac = + let obl = obls.(i) in + match obl.obl_body with + Some _ -> false + | None -> + (try + if deps_remaining obls obl.obl_deps = [] then + let obl = subst_deps_obl obls obl in + let t = Subtac_utils.solve_by_tac (evar_of_obligation obl) tac in + obls.(i) <- { obl with obl_body = Some t }; + true + else false + with _ -> false) + let solve_obligations n tac = let prg = get_prog n in let obls, rem = prg.prg_obligations in let rem = ref rem in + let obls' = Array.copy obls in + let _ = + Array.iteri (fun i x -> + if solve_obligation_by_tac prg obls' i tac then + decr rem) + obls' + in + update_obls prg obls' !rem + +let add_definition n b t obls = + Options.if_verbose pp (str (string_of_id n) ++ str " has type-checked"); + let prg = init_prog_info n b t [] (Array.make 0 0) obls in + let obls,_ = prg.prg_obligations in + if Array.length obls = 0 then ( + Options.if_verbose ppnl (str "."); + declare_definition prg; + from_prg := ProgMap.remove prg.prg_name !from_prg) + else ( + let len = Array.length obls in + let _ = Options.if_verbose ppnl (str ", generating " ++ int len ++ str " obligation(s)") in + from_prg := ProgMap.add n prg !from_prg; + solve_obligations (Some n) !default_tactic) + +let add_mutual_definitions l nvrec = + let deps = List.map (fun (n, b, t, obls) -> n) l in + let upd = List.fold_left + (fun acc (n, b, t, obls) -> + let prg = init_prog_info n b t deps nvrec obls in + ProgMap.add n prg acc) + !from_prg l + in + from_prg := upd; + List.iter (fun x -> solve_obligations (Some x) !default_tactic) deps + +let admit_obligations n = + let prg = get_prog n in + let obls, rem = prg.prg_obligations in let obls' = - Array.map (fun x -> + Array.mapi (fun i x -> match x.obl_body with - Some _ -> x - | None -> - try - let t = Subtac_utils.solve_by_tac (evar_of_obligation x) tac in - decr rem; - { x with obl_body = Some t } - with _ -> x) + None -> + let kn = Declare.declare_constant x.obl_name (ParameterEntry x.obl_type, IsAssumption Conjectural) in + assumption_message x.obl_name; + { x with obl_body = Some (mkConst kn) } + | Some _ -> x) obls in - update_obls prg obls' !rem + update_obls prg obls' 0 +exception Found of int + +let array_find f arr = + try Array.iteri (fun i x -> if f x then raise (Found i)) arr; + raise Not_found + with Found i -> i + +let rec next_obligation n = + let prg = get_prog n in + let obls, rem = prg.prg_obligations in + let i = + array_find (fun x -> x.obl_body = None && deps_remaining obls x.obl_deps = []) + obls + in + if solve_obligation_by_tac prg obls i !default_tactic then ( + update_obls prg obls (pred rem); + next_obligation n + ) else solve_obligation prg i + open Pp let show_obligations n = let prg = get_prog n in + let n = prg.prg_name in let obls, rem = prg.prg_obligations in msgnl (int rem ++ str " obligation(s) remaining: "); Array.iteri (fun i x -> match x.obl_body with - None -> msgnl (int (succ i) ++ str " : " ++ spc () ++ - my_print_constr (Global.env ()) x.obl_type) + None -> msgnl (str "Obligation" ++ spc() ++ int (succ i) ++ spc () ++ str "of" ++ spc() ++ str (string_of_id n) ++ str ":" ++ spc () ++ + my_print_constr (Global.env ()) x.obl_type ++ str "." ++ fnl ()) | Some _ -> ()) obls diff --git a/contrib/subtac/subtac_obligations.mli b/contrib/subtac/subtac_obligations.mli index 7d93d57b..3981d4c6 100644 --- a/contrib/subtac/subtac_obligations.mli +++ b/contrib/subtac/subtac_obligations.mli @@ -1,10 +1,21 @@ open Util -val add_entry : Names.identifier -> Term.constr -> Term.types -> - (Names.identifier * Term.types * Intset.t) array -> unit +type obligation_info = (Names.identifier * Term.types * Intset.t) array -val subtac_obligation : int * Names.identifier option -> unit +val set_default_tactic : Proof_type.tactic -> unit + +val add_definition : Names.identifier -> Term.constr -> Term.types -> + obligation_info -> unit + +val add_mutual_definitions : + (Names.identifier * Term.constr * Term.types * obligation_info) list -> int array -> unit + +val subtac_obligation : int * Names.identifier option * Topconstr.constr_expr option -> unit + +val next_obligation : Names.identifier option -> unit val solve_obligations : Names.identifier option -> Proof_type.tactic -> unit val show_obligations : Names.identifier option -> unit + +val admit_obligations : Names.identifier option -> unit diff --git a/contrib/subtac/subtac_pretyping.ml b/contrib/subtac/subtac_pretyping.ml index a243ba34..4d1ac731 100644 --- a/contrib/subtac/subtac_pretyping.ml +++ b/contrib/subtac/subtac_pretyping.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: subtac_pretyping.ml 9326 2006-10-31 12:57:26Z msozeau $ *) +(* $Id: subtac_pretyping.ml 9563 2007-01-31 09:37:18Z msozeau $ *) open Global open Pp @@ -113,29 +113,23 @@ let env_with_binders env isevars l = in aux (env, []) l let subtac_process env isevars id l c tycon = - let evars () = evars_of !isevars in - let _ = trace (str "Creating env with binders") in let env_binders, binders_rel = env_with_binders env isevars l in - let _ = try (trace (str "New env created:" ++ my_print_context env_binders)) with _ -> () in let tycon = match tycon with None -> empty_tycon | Some t -> let t = coqintern !isevars env_binders t in - let _ = try trace (str "Internalized specification: " ++ my_print_rawconstr env_binders t) with _ -> () in let coqt, ttyp = interp env_binders isevars t empty_tycon in - let _ = try trace (str "Interpreted type: " ++ my_print_constr env_binders coqt) with _ -> () in mk_tycon coqt in let c = coqintern !isevars env_binders c in let c = Subtac_utils.rewrite_cases env c in - let _ = try trace (str "Internalized term: " ++ my_print_rawconstr env c) with _ -> () in let coqc, ctyp = interp env_binders isevars c tycon in - let _ = try trace (str "Interpreted term: " ++ my_print_constr env_binders coqc ++ spc () ++ - str "Coq type: " ++ my_print_constr env_binders ctyp) - with _ -> () - in - let _ = try trace (str "Original evar map: " ++ Evd.pr_evar_map (evars ())) with _ -> () in +(* let _ = try trace (str "Interpreted term: " ++ my_print_constr env_binders coqc ++ spc () ++ *) +(* str "Coq type: " ++ my_print_constr env_binders ctyp) *) +(* with _ -> () *) +(* in *) +(* let _ = try trace (str "Original evar map: " ++ Evd.pr_evar_map (evars ())) with _ -> () in *) let fullcoqc = it_mkLambda_or_LetIn coqc binders_rel and fullctyp = it_mkProd_or_LetIn ctyp binders_rel @@ -143,13 +137,13 @@ let subtac_process env isevars id l c tycon = let fullcoqc = Evarutil.nf_evar (evars_of !isevars) fullcoqc in let fullctyp = Evarutil.nf_evar (evars_of !isevars) fullctyp in - let _ = try trace (str "After evar normalization: " ++ spc () ++ - str "Coq term: " ++ my_print_constr env fullcoqc ++ spc () - ++ str "Coq type: " ++ my_print_constr env fullctyp) - with _ -> () - in +(* let _ = try trace (str "After evar normalization: " ++ spc () ++ *) +(* str "Coq term: " ++ my_print_constr env fullcoqc ++ spc () *) +(* ++ str "Coq type: " ++ my_print_constr env fullctyp) *) +(* with _ -> () *) +(* in *) let evm = non_instanciated_map env isevars in - let _ = try trace (str "Non instanciated evars map: " ++ Evd.pr_evar_map evm) with _ -> () in +(* let _ = try trace (str "Non instanciated evars map: " ++ Evd.pr_evar_map evm) with _ -> () in *) evm, fullcoqc, fullctyp open Subtac_obligations @@ -159,5 +153,4 @@ let subtac_proof env isevars id l c tycon = let nc_len = named_context_length nc in let evm, coqc, coqt = subtac_process env isevars id l c tycon in let evars, def = Eterm.eterm_obligations id nc_len evm coqc (Some coqt) in - trace (str "Adding to obligations list"); - add_entry id def coqt evars + add_definition id def coqt evars diff --git a/contrib/subtac/subtac_pretyping_F.ml b/contrib/subtac/subtac_pretyping_F.ml index 46af5886..6244aef3 100644 --- a/contrib/subtac/subtac_pretyping_F.ml +++ b/contrib/subtac/subtac_pretyping_F.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: subtac_pretyping_F.ml 9316 2006-10-29 22:49:11Z herbelin $ *) +(* $Id: subtac_pretyping_F.ml 9563 2007-01-31 09:37:18Z msozeau $ *) open Pp open Util @@ -40,7 +40,7 @@ open Inductiveops module SubtacPretyping_F (Coercion : Coercion.S) = struct - module Cases = Cases.Cases_F(Coercion) + module Cases = Subtac_cases.Cases_F(Coercion) (* Allow references to syntaxically inexistent variables (i.e., if applied on an inductive) *) let allow_anonymous_refs = ref true @@ -161,7 +161,12 @@ module SubtacPretyping_F (Coercion : Coercion.S) = struct (* [pretype tycon env isevars lvar lmeta cstr] attempts to type [cstr] *) (* in environment [env], with existential variables [(evars_of isevars)] and *) (* the type constraint tycon *) - let rec pretype (tycon : type_constraint) env isevars lvar = function + let rec pretype (tycon : type_constraint) env isevars lvar c = +(* let _ = try Subtac_utils.trace (str "pretype " ++ Subtac_utils.my_print_rawconstr env c ++ *) +(* str " with tycon " ++ Evarutil.pr_tycon env tycon) *) +(* with _ -> () *) +(* in *) + match c with | RRef (loc,ref) -> inh_conv_coerce_to_tycon loc env isevars (pretype_ref isevars env ref) @@ -321,7 +326,7 @@ module SubtacPretyping_F (Coercion : Coercion.S) = struct let t = Retyping.get_type_of env sigma c in make_judge c t | _ -> resj in - inh_conv_coerce_to_tycon loc env isevars resj tycon + inh_conv_coerce_to_tycon loc env isevars resj tycon | RLambda(loc,name,c1,c2) -> let (name',dom,rng) = evd_comb1 (split_tycon loc env) isevars tycon in diff --git a/contrib/subtac/subtac_utils.ml b/contrib/subtac/subtac_utils.ml index 7b96758a..01dee3e9 100644 --- a/contrib/subtac/subtac_utils.ml +++ b/contrib/subtac/subtac_utils.ml @@ -5,6 +5,8 @@ open Term open Names open Util +let ($) f x = f x + (****************************************************************************) (* Library linking *) @@ -45,10 +47,23 @@ let build_sig () = let sig_ = lazy (build_sig ()) -let eqind = lazy (init_constant ["Init"; "Logic"] "eq") -let eqind_ref = lazy (init_reference ["Init"; "Logic"] "eq") +let eq_ind = lazy (init_constant ["Init"; "Logic"] "eq") +let eq_rec = lazy (init_constant ["Init"; "Logic"] "eq_rec") +let eq_rect = lazy (init_constant ["Init"; "Logic"] "eq_rect") +let eq_refl = lazy (init_constant ["Init"; "Logic"] "refl_equal") +let eq_ind_ref = lazy (init_reference ["Init"; "Logic"] "eq") let refl_equal_ref = lazy (init_reference ["Init"; "Logic"] "refl_equal") +let eqdep_ind = lazy (init_constant [ "Logic";"Eqdep"] "eq_dep") +let eqdep_rec = lazy (init_constant ["Logic";"Eqdep"] "eq_dep_rec") +let eqdep_ind_ref = lazy (init_reference [ "Logic";"Eqdep"] "eq_dep") +let eqdep_intro_ref = lazy (init_reference [ "Logic";"Eqdep"] "eq_dep_intro") + +let jmeq_ind = lazy (init_constant ["Logic";"JMeq"] "JMeq") +let jmeq_rec = lazy (init_constant ["Logic";"JMeq"] "JMeq_rec") +let jmeq_ind_ref = lazy (init_reference ["Logic";"JMeq"] "JMeq") +let jmeq_refl_ref = lazy (init_reference ["Logic";"JMeq"] "JMeq_refl") + let ex_ind = lazy (init_constant ["Init"; "Logic"] "ex") let ex_intro = lazy (init_reference ["Init"; "Logic"] "ex_intro") @@ -79,6 +94,7 @@ open Pp let my_print_constr = Termops.print_constr_env let my_print_constr_expr = Ppconstr.pr_constr_expr +let my_print_rel_context env ctx = Printer.pr_rel_context env ctx let my_print_context = Termops.print_rel_context let my_print_named_context = Termops.print_named_context let my_print_env = Termops.print_env @@ -87,7 +103,7 @@ let my_print_evardefs = Evd.pr_evar_defs let my_print_tycon_type = Evarutil.pr_tycon_type -let debug_level = 1 +let debug_level = 2 let debug_on = true @@ -132,8 +148,9 @@ let print_args env args = let make_existential loc env isevars c = let evar = Evarutil.e_new_evar isevars env ~src:(loc, QuestionMark) c in let (key, args) = destEvar evar in - (try debug 2 (str "Constructed evar " ++ int key ++ str " applied to args: " ++ - print_args env args) with _ -> ()); + (try trace (str "Constructed evar " ++ int key ++ str " applied to args: " ++ + print_args env args ++ str " for type: "++ + my_print_constr env c) with _ -> ()); evar let make_existential_expr loc env c = @@ -177,6 +194,12 @@ open Tactics open Tacticals let id x = x +let filter_map f l = + let rec aux acc = function + hd :: tl -> (match f hd with Some t -> aux (t :: acc) tl + | None -> aux acc tl) + | [] -> List.rev acc + in aux [] l let build_dependent_sum l = let rec aux names conttac conttype = function @@ -279,45 +302,137 @@ let destruct_ex ext ex = open Rawterm - +let rec concatMap f l = + match l with + hd :: tl -> f hd @ concatMap f tl + | [] -> [] + let list_mapi f = let rec aux i = function hd :: tl -> f i hd :: aux (succ i) tl | [] -> [] in aux 0 -let rewrite_cases_aux (loc, po, tml, eqns) = - let tml = list_mapi (fun i (c, (n, opt)) -> c, - ((match n with - Name id -> (match c with - | RVar (_, id') when id = id' -> - Name (id_of_string (string_of_id id ^ "'")) - | _ -> n) - | Anonymous -> Name (id_of_string ("x" ^ string_of_int i))), - opt)) tml - in +(* +let make_discr (loc, po, tml, eqns) = let mkHole = RHole (dummy_loc, InternalHole) in - let mkeq c n = RApp (dummy_loc, RRef (dummy_loc, (Lazy.force eqind_ref)), - [mkHole; c; n]) + + let rec vars_of_pat = function + RPatVar (loc, n) -> (match n with Anonymous -> [] | Name n -> [n]) + | RPatCstr (loc, csrt, pats, _) -> + concatMap vars_of_pat pats in - let eqs_types = - List.map - (fun (c, (n, _)) -> - let id = match n with Name id -> id | _ -> assert false in - let heqid = id_of_string ("Heq" ^ string_of_id id) in - Name heqid, mkeq c (RVar (dummy_loc, id))) - tml + let rec constr_of_pat l = function + RPatVar (loc, n) -> + (match n with + Anonymous -> + let n = next_name_away_from "x" l in + RVar n, (n :: l) + | Name n -> RVar n, l) + | RPatCstr (loc, csrt, pats, _) -> + let (args, vars) = + List.fold_left + (fun (args, vars) x -> + let c, vars = constr_of_pat vars x in + c :: args, vars) + ([], l) pats + in + RApp ((RRef (dummy_loc, ConstructRef cstr)), args), vars in - let po = - List.fold_right - (fun (n,t) acc -> - RProd (dummy_loc, Anonymous, t, acc)) - eqs_types (match po with - Some e -> e - | None -> mkHole) + let rec constr_of_pat l = function + RPatVar (loc, n) -> + (match n with + Anonymous -> + let n = next_name_away_from "x" l in + RVar n, (n :: l) + | Name n -> RVar n, l) + | RPatCstr (loc, csrt, pats, _) -> + let (args, vars) = + List.fold_left + (fun (args, vars) x -> + let c, vars = constr_of_pat vars x in + c :: args, vars) + ([], l) pats + in + RApp ((RRef (dummy_loc, ConstructRef cstr)), args), vars in - let eqns = - List.map (fun (loc, idl, cpl, c) -> + let constrs_of_pats v l = + List.fold_left + (fun (v, acc) x -> + let x', v' = constr_of_pat v x in + (l', v' :: acc)) + (v, []) l + in + let rec pat_of_pat l = function + RPatVar (loc, n) -> + let n', l = match n with + Anonymous -> + let n = next_name_away_from "x" l in + n, n :: l + | Name n -> n, n :: l + in + RPatVar (loc, Name n'), l + | RPatCstr (loc, cstr, pats, (loc, alias)) -> + let args, vars, s = + List.fold_left (fun (args, vars) x -> + let pat', vars = pat_of_pat vars pat in + pat' :: args, vars) + ([], alias :: l) pats + in RPatCstr (loc, cstr, args, (loc, alias)), vars + in + let pats_of_pats l = + List.fold_left + (fun (v, acc) x -> + let x', v' = pat_of_pat v x in + (v', x' :: acc)) + ([], []) l + in + let eq_of_pat p used c = + let constr, vars' = constr_of_pat used p in + let eq = RApp (dummy_loc, RRef (dummy_loc, Lazy.force eqind_ref), [mkHole; constr; c]) in + vars', eq + in + let eqs_of_pats ps used cstrs = + List.fold_left2 + (fun (vars, eqs) pat c -> + let (vars', eq) = eq_of_pat pat c in + match eqs with + None -> Some eq + | Some eqs -> + Some (RApp (dummy_loc, RRef (dummy_loc, Lazy.force and_ref), [eq, eqs]))) + (used, None) ps cstrs + in + let quantify c l = + List.fold_left + (fun acc name -> RProd (dummy_loc, name, mkHole, acc)) + c l + in + let quantpats = + List.fold_left + (fun (acc, pats) ((loc, idl, cpl, c) as x) -> + let vars, cpl = pats_of_pats cpl in + let l', constrs = constrs_of_pats vars cpl in + let discrs = + List.map (fun (_, _, cpl', _) -> + let qvars, eqs = eqs_of_pats cpl' l' constrs in + let neg = RApp (dummy_loc, RRef (dummy_loc, Lazy.force not_ref), [out_some eqs]) in + let pat_ineq = quantify qvars neg in + + ) + pats in + + + + + + + + (x, pat_ineq)) + in + List.fold_left + (fun acc ((loc, idl, cpl, c0) pat) -> + + let c' = List.fold_left (fun acc (n, t) -> @@ -325,27 +440,74 @@ let rewrite_cases_aux (loc, po, tml, eqns) = c eqs_types in (loc, idl, cpl, c')) eqns - in - let mk_refl_equal c = RApp (dummy_loc, RRef (dummy_loc, Lazy.force refl_equal_ref), - [mkHole; c]) - in - let refls = List.map (fun (c, _) -> mk_refl_equal c) tml in - let case = RCases (loc,Some po,tml,eqns) in - let app = RApp (dummy_loc, case, refls) in - app - -let rec rewrite_cases c = - match c with - RCases _ -> let c' = map_rawconstr rewrite_cases c in - (match c' with - | RCases (x, y, z, w) -> rewrite_cases_aux (x,y,z,w) - | _ -> assert(false)) - | _ -> map_rawconstr rewrite_cases c + i +*) +(* let rewrite_cases_aux (loc, po, tml, eqns) = *) +(* let tml = list_mapi (fun i (c, (n, opt)) -> c, *) +(* ((match n with *) +(* Name id -> (match c with *) +(* | RVar (_, id') when id = id' -> *) +(* Name (id_of_string (string_of_id id ^ "'")) *) +(* | _ -> n) *) +(* | Anonymous -> Name (id_of_string ("x" ^ string_of_int i))), *) +(* opt)) tml *) +(* in *) +(* let mkHole = RHole (dummy_loc, InternalHole) in *) +(* (\* let mkeq c n = RApp (dummy_loc, RRef (dummy_loc, (Lazy.force eqind_ref)), *\) *) +(* (\* [mkHole; c; n]) *\) *) +(* (\* in *\) *) +(* let mkeq c n = RApp (dummy_loc, RRef (dummy_loc, (Lazy.force eqdep_ind_ref)), *) +(* [mkHole; c; mkHole; n]) *) +(* in *) +(* let eqs_types = *) +(* List.map *) +(* (fun (c, (n, _)) -> *) +(* let id = match n with Name id -> id | _ -> assert false in *) +(* let heqid = id_of_string ("Heq" ^ string_of_id id) in *) +(* Name heqid, mkeq c (RVar (dummy_loc, id))) *) +(* tml *) +(* in *) +(* let po = *) +(* List.fold_right *) +(* (fun (n,t) acc -> *) +(* RProd (dummy_loc, Anonymous, t, acc)) *) +(* eqs_types (match po with *) +(* Some e -> e *) +(* | None -> mkHole) *) +(* in *) +(* let eqns = *) +(* List.map (fun (loc, idl, cpl, c) -> *) +(* let c' = *) +(* List.fold_left *) +(* (fun acc (n, t) -> *) +(* RLambda (dummy_loc, n, mkHole, acc)) *) +(* c eqs_types *) +(* in (loc, idl, cpl, c')) *) +(* eqns *) +(* in *) +(* let mk_refl_equal c = RApp (dummy_loc, RRef (dummy_loc, Lazy.force refl_equal_ref), *) +(* [mkHole; c]) *) +(* in *) +(* (\*let mk_refl_equal c = RApp (dummy_loc, RRef (dummy_loc, Lazy.force refl_equal_ref), *) +(* [mkHole; c]) *) +(* in*\) *) +(* let refls = List.map (fun (c, _) -> mk_refl_equal c) tml in *) +(* let case = RCases (loc,Some po,tml,eqns) in *) +(* let app = RApp (dummy_loc, case, refls) in *) +(* app *) + +(* let rec rewrite_cases c = *) +(* match c with *) +(* RCases _ -> let c' = map_rawconstr rewrite_cases c in *) +(* (match c' with *) +(* | RCases (x, y, z, w) -> rewrite_cases_aux (x,y,z,w) *) +(* | _ -> assert(false)) *) +(* | _ -> map_rawconstr rewrite_cases c *) -let rewrite_cases env c = - let c' = rewrite_cases c in - let _ = trace (str "Rewrote cases: " ++ spc () ++ my_print_rawconstr env c') in - c' +(* let rewrite_cases env c = *) +(* let c' = rewrite_cases c in *) +(* let _ = trace (str "Rewrote cases: " ++ spc () ++ my_print_rawconstr env c') in *) +(* c' *) let list_mapi f = let rec aux i = function @@ -371,7 +533,7 @@ let rewrite_cases_aux (loc, po, tml, eqns) = in let mkHole = RHole (dummy_loc, InternalHole) in let mkCoerceCast c = RCast (dummy_loc, c, CastCoerce, mkHole) in - let mkeq c n = RApp (dummy_loc, RRef (dummy_loc, (Lazy.force eqind_ref)), + let mkeq c n = RApp (dummy_loc, RRef (dummy_loc, (Lazy.force eq_ind_ref)), [mkHole; c; n]) in let eqs_types = @@ -419,10 +581,10 @@ let rec rewrite_cases c = | _ -> assert(false)) | _ -> map_rawconstr rewrite_cases c -let rewrite_cases env c = - let c' = rewrite_cases c in - let _ = trace (str "Rewrote cases: " ++ spc () ++ my_print_rawconstr env c') in - c' +let rewrite_cases env c = c +(* let c' = rewrite_cases c in *) +(* let _ = trace (str "Rewrote cases: " ++ spc () ++ my_print_rawconstr env c') in *) +(* c' *) let id_of_name = function Name n -> n @@ -439,16 +601,107 @@ let recursive_message v = spc () ++ str "are recursively defined") (* Solve an obligation using tactics, return the corresponding proof term *) +(* let solve_by_tac ev t = debug 1 (str "Solving goal using tactics: " ++ Evd.pr_evar_info ev); let goal = Proof_trees.mk_goal ev.evar_hyps ev.evar_concl None in + debug 1 (str "Goal created"); let ts = Tacmach.mk_pftreestate goal in + debug 1 (str "Got pftreestate"); let solved_state = Tacmach.solve_pftreestate t ts in - let c = Tacmach.extract_pftreestate solved_state in + debug 1 (str "Solved goal"); + let _, l = Tacmach.extract_open_pftreestate solved_state in + List.iter (fun (_, x) -> debug 1 (str "left hole of type " ++ my_print_constr (Global.env()) x)) l; + let c = Tacmach.extract_pftreestate solved_state in + debug 1 (str "Extracted term"); debug 1 (str "Term constructed in solve by tac: " ++ my_print_constr (Global.env ()) c); c + *) + +let solve_by_tac evi t = + debug 2 (str "Solving goal using tactics: " ++ Evd.pr_evar_info evi); + let id = id_of_string "H" in + try + Pfedit.start_proof id goal_kind evi.evar_hyps evi.evar_concl + (fun _ _ -> ()); + debug 2 (str "Started proof"); + Pfedit.by (tclCOMPLETE t); + let _,(const,_,_) = Pfedit.cook_proof () in + Pfedit.delete_current_proof (); const.Entries.const_entry_body + with e -> + Pfedit.delete_current_proof(); + raise Exit let rec string_of_list sep f = function [] -> "" | x :: [] -> f x | x :: ((y :: _) as tl) -> f x ^ sep ^ string_of_list sep f tl + +let string_of_intset d = + string_of_list "," string_of_int (Intset.elements d) + +(**********************************************************) +(* Pretty-printing *) +open Printer +open Ppconstr +open Nameops +open Termops +open Evd + +let pr_meta_map evd = + let ml = meta_list evd in + let pr_name = function + Name id -> str"[" ++ pr_id id ++ str"]" + | _ -> mt() in + let pr_meta_binding = function + | (mv,Cltyp (na,b)) -> + hov 0 + (pr_meta mv ++ pr_name na ++ str " : " ++ + print_constr b.rebus ++ fnl ()) + | (mv,Clval(na,b,_)) -> + hov 0 + (pr_meta mv ++ pr_name na ++ str " := " ++ + print_constr b.rebus ++ fnl ()) + in + prlist pr_meta_binding ml + +let pr_idl idl = prlist_with_sep pr_spc pr_id idl + +let pr_evar_info evi = + let phyps = + (*pr_idl (List.rev (ids_of_named_context (evar_context evi))) *) + Printer.pr_named_context (Global.env()) (evar_context evi) + in + let pty = print_constr evi.evar_concl in + let pb = + match evi.evar_body with + | Evar_empty -> mt () + | Evar_defined c -> spc() ++ str"=> " ++ print_constr c + in + hov 2 (str"[" ++ phyps ++ spc () ++ str"|- " ++ pty ++ pb ++ str"]") + +let pr_evar_map sigma = + h 0 + (prlist_with_sep pr_fnl + (fun (ev,evi) -> + h 0 (str(string_of_existential ev)++str"=="++ pr_evar_info evi)) + (to_list sigma)) + +let pr_constraints pbs = + h 0 + (prlist_with_sep pr_fnl (fun (pbty,t1,t2) -> + print_constr t1 ++ spc() ++ + str (match pbty with + | Reduction.CONV -> "==" + | Reduction.CUMUL -> "<=") ++ + spc() ++ print_constr t2) pbs) + +let pr_evar_defs evd = + let pp_evm = + let evars = evars_of evd in + if evars = empty then mt() else + str"EVARS:"++brk(0,1)++pr_evar_map evars++fnl() in + let pp_met = + if meta_list evd = [] then mt() else + str"METAS:"++brk(0,1)++pr_meta_map evd in + v 0 (pp_evm ++ pp_met) diff --git a/contrib/subtac/subtac_utils.mli b/contrib/subtac/subtac_utils.mli index ebfc5123..482640f9 100644 --- a/contrib/subtac/subtac_utils.mli +++ b/contrib/subtac/subtac_utils.mli @@ -12,6 +12,7 @@ open Evarutil open Names open Sign +val ($) : ('a -> 'b) -> 'a -> 'b val contrib_name : string val subtac_dir : string list val fix_sub_module : string @@ -31,9 +32,19 @@ val proj1_sig_ref : reference val proj2_sig_ref : reference val build_sig : unit -> coq_sigma_data val sig_ : coq_sigma_data lazy_t -val eqind : constr lazy_t -val eqind_ref : global_reference lazy_t + +val eq_ind : constr lazy_t +val eq_rec : constr lazy_t +val eq_rect : constr lazy_t +val eq_refl : constr lazy_t +val eq_ind_ref : global_reference lazy_t val refl_equal_ref : global_reference lazy_t + +val eqdep_ind : constr lazy_t +val eqdep_rec : constr lazy_t +val eqdep_ind_ref : global_reference lazy_t +val eqdep_intro_ref : global_reference lazy_t + val boolind : constr lazy_t val sumboolind : constr lazy_t val natind : constr lazy_t @@ -48,10 +59,12 @@ val acc : constr lazy_t val acc_inv : constr lazy_t val extconstr : constr -> constr_expr val extsort : sorts -> constr_expr + val my_print_constr : env -> constr -> std_ppcmds val my_print_constr_expr : constr_expr -> std_ppcmds val my_print_evardefs : evar_defs -> std_ppcmds val my_print_context : env -> std_ppcmds +val my_print_rel_context : env -> rel_context -> std_ppcmds val my_print_named_context : env -> std_ppcmds val my_print_env : env -> std_ppcmds val my_print_rawconstr : env -> rawconstr -> std_ppcmds @@ -98,3 +111,6 @@ val recursive_message : global_reference array -> std_ppcmds val solve_by_tac : evar_info -> Tacmach.tactic -> constr val string_of_list : string -> ('a -> string) -> 'a list -> string +val string_of_intset : Intset.t -> string + +val pr_evar_defs : evar_defs -> Pp.std_ppcmds diff --git a/contrib/subtac/test/ListsTest.v b/contrib/subtac/test/ListsTest.v index 8429c267..b8d13fe6 100644 --- a/contrib/subtac/test/ListsTest.v +++ b/contrib/subtac/test/ListsTest.v @@ -1,95 +1,76 @@ +(* -*- coq-prog-args: ("-emacs-U" "-debug") -*- *) Require Import Coq.subtac.Utils. Require Import List. -Variable A : Set. - -Program Definition myhd : forall { l : list A | length l <> 0 }, A := - fun l => - match `l with - | nil => _ - | hd :: tl => hd - end. -Proof. - destruct l ; simpl ; intro H. - rewrite H in n ; intuition. -Defined. +Set Implicit Arguments. +Section Accessors. + Variable A : Set. -Extraction myhd. -Extraction Inline proj1_sig. + Program Definition myhd : forall { l : list A | length l <> 0 }, A := + fun l => + match l with + | nil => ! + | hd :: tl => hd + end. -Program Definition mytail : forall { l : list A | length l <> 0 }, list A := - fun l => + Program Definition mytail (l : list A | length l <> 0) : list A := match l with - | nil => _ - | hd :: tl => tl + | nil => ! + | hd :: tl => tl end. -Proof. -destruct l ; simpl ; intro H ; rewrite H in n ; intuition. -Defined. - -Extraction mytail. - -Variable a : A. +End Accessors. -Program Definition test_hd : A := myhd (cons a nil). -Proof. -simpl ; auto. -Defined. - -Extraction test_hd. +Program Definition test_hd : nat := myhd (cons 1 nil). +(*Eval compute in test_hd*) (*Program Definition test_tail : list A := mytail nil.*) +Section app. + Variable A : Set. + Program Fixpoint app (l : list A) (l' : list A) { struct l } : + { r : list A | length r = length l + length l' } := + match l with + | nil => l' + | hd :: tl => hd :: (tl ++ l') + end + where "x ++ y" := (app x y). + + Next Obligation. + intros. + destruct_call app ; subtac_simpl. + Defined. + + Program Lemma app_id_l : forall l : list A, l = nil ++ l. + Proof. + simpl ; auto. + Qed. + + Program Lemma app_id_r : forall l : list A, l = l ++ nil. + Proof. + induction l ; simpl ; auto. + rewrite <- IHl ; auto. + Qed. + +End app. + +Extraction app. + +Section Nth. + + Variable A : Set. + + Program Fixpoint nth (l : list A) (n : nat | n < length l) { struct l } : A := + match n, l with + | 0, hd :: _ => hd + | S n', _ :: tl => nth tl n' + | _, nil => ! + end. - - -Program Fixpoint append (l : list A) (l' : list A) { struct l } : - { r : list A | length r = length l + length l' } := - match l with - | nil => l' - | hd :: tl => hd :: (append tl l') - end. -subst ; auto. -simpl ; rewrite (subset_simpl (append tl0 l')). -simpl ; subst. -simpl ; auto. -Defined. - -Extraction append. - - -Program Lemma append_app' : forall l : list A, l = append nil l. -Proof. -simpl ; auto. -Qed. - -Program Lemma append_app : forall l : list A, l = append l nil. -Proof. -intros. -induction l ; simpl ; auto. -simpl in IHl. -rewrite <- IHl. -reflexivity. -Qed. - - - - - - - - - - - - - - - - - - - + Next Obligation. + Proof. + inversion l0. + Defined. +End Nth. diff --git a/contrib/subtac/test/euclid.v b/contrib/subtac/test/euclid.v index ba5bdf23..a5a8b85f 100644 --- a/contrib/subtac/test/euclid.v +++ b/contrib/subtac/test/euclid.v @@ -1,66 +1,27 @@ - -Notation "( x & y )" := (@existS _ _ x y) : core_scope. -Unset Printing All. - -Definition t := fun (Evar46 : forall a : nat, (fun y : nat => @eq nat a y) a) (a : nat) => -@existS nat (fun x : nat => @sig nat (fun y : nat => @eq nat x y)) a - (@exist nat (fun y : nat => @eq nat a y) a (Evar46 a)). - -Program Definition testsig (a : nat) : { x : nat & { y : nat | x = y } } := - (a & a). -reflexivity. -Defined. - -Extraction testsig. -Extraction sig. -Extract Inductive sig => "" [ "" ]. -Extraction testsig. - +Require Import Coq.subtac.Utils. Require Import Coq.Arith.Compare_dec. - -Require Import Omega. - -Lemma minus_eq_add : forall x y z w, y <= x -> x - y = y * z + w -> x = y * S z + w. -intros. -assert(y * S z = y * z + y). -auto. -rewrite H1. -omega. -Qed. - -Program Fixpoint euclid (a : nat) (b : { b : nat | b <> O }) {wf a lt} : +Notation "( x & y )" := (existS _ x y) : core_scope. + +Program Fixpoint euclid (a : nat) (b : { b : nat | b <> O }) {wf lt a} : { q : nat & { r : nat | a = b * q + r /\ r < b } } := if le_lt_dec b a then let (q', r) := euclid (a - b) b in (S q' & r) else (O & a). -intro euclid. -simpl ; intros. -Print euclid_evars. -eapply euclid_evars with euclid. -refine (euclid_evars _ _ _ euclid a Acc_a b). -; simpl ; intros. -Show Existentials. -induction b0 ; induction r. -simpl in H. -simpl. -simpl in p0. -destruct p0. -split. +Require Import Omega. + +Obligations. +Solve Obligations using subtac_simpl ; omega. + +Next Obligation. + assert(x0 * S q' = x0 * q' + x0) by auto with arith ; omega. +Defined. -apply minus_eq_add. -omega. -auto with arith. -auto. -simpl. -induction b0 ; simpl. -split ; auto. -omega. -exact (euclid a0 Acc_a0 b0). +Program Definition test_euclid : (prod nat nat) := let (q, r) := euclid 4 2 in (q, q). -exact (Acc_a). -auto. -auto. -Focus 1. +Eval lazy beta zeta delta iota in test_euclid. +Program Definition testsig (a : nat) : { x : nat & { y : nat | x < y } } := + (a & S a). +Check testsig. diff --git a/contrib/xml/proof2aproof.ml b/contrib/xml/proof2aproof.ml index 92cbf6df..30dc7b71 100644 --- a/contrib/xml/proof2aproof.ml +++ b/contrib/xml/proof2aproof.ml @@ -112,8 +112,6 @@ let extract_open_proof sigma pf = ProofTreeHash.add proof_tree_to_flattened_proof_tree node flat_proof ; proof_extractor vl flat_proof - | {PT.ref=Some(PT.Change_evars,[pf])} -> (proof_extractor vl) pf - | {PT.ref=None;PT.goal=goal} -> let visible_rels = Util.map_succeed diff --git a/contrib/xml/proofTree2Xml.ml4 b/contrib/xml/proofTree2Xml.ml4 index dbdc79a8..9afd07a6 100644 --- a/contrib/xml/proofTree2Xml.ml4 +++ b/contrib/xml/proofTree2Xml.ml4 @@ -93,7 +93,7 @@ let string_of_prim_rule x = match x with | Proof_type.ThinBody _-> "ThinBody" | Proof_type.Move (_,_,_) -> "Move" | Proof_type.Rename (_,_) -> "Rename" - + | Proof_type.Change_evars -> "Change_evars" let print_proof_tree curi sigma pf proof_tree_to_constr @@ -189,11 +189,6 @@ Pp.ppnl (Pp.(++) (Pp.str [<(build_hyps new_hyps) ; (aux flat_proof nhyps)>] end - | {PT.ref=Some(PT.Change_evars,nodes)} -> - X.xml_nempty "Change_evars" of_attribute - (List.fold_left - (fun i n -> [< i ; (aux n old_hyps) >]) [<>] nodes) - | {PT.ref=Some((PT.Nested(PT.Proof_instr (_,_),_)|PT.Decl_proof _),nodes)} -> Util.anomaly "Not Implemented" |