diff options
Diffstat (limited to 'contrib')
263 files changed, 24083 insertions, 16756 deletions
diff --git a/contrib/cc/ccalgo.ml b/contrib/cc/ccalgo.ml index 8bdae54b..e67797e4 100644 --- a/contrib/cc/ccalgo.ml +++ b/contrib/cc/ccalgo.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: ccalgo.ml 9151 2006-09-19 13:32:22Z corbinea $ *) +(* $Id: ccalgo.ml 10579 2008-02-21 13:54:00Z corbinea $ *) (* This file implements the basic congruence-closure algorithm by *) (* Downey,Sethi and Tarjan. *) @@ -16,13 +16,16 @@ open Pp open Goptions open Names open Term +open Tacmach +open Evd +open Proof_type let init_size=5 let cc_verbose=ref false -let debug msg (stdpp:std_ppcmds) = - if !cc_verbose then msg stdpp +let debug f x = + if !cc_verbose then f x let _= let gdopt= @@ -97,7 +100,8 @@ type cinfo= type term= Symb of constr - | Eps + | Product of sorts_family * sorts_family + | Eps of identifier | Appli of term*term | Constructor of cinfo (* constructor arity + nhyps *) @@ -122,14 +126,19 @@ type equality = rule eq type disequality = from eq +type patt_kind = + Normal + | Trivial of types + | Creates_variables + type quant_eq = {qe_hyp_id: identifier; qe_pol: bool; qe_nvars:int; qe_lhs: ccpattern; - qe_lhs_valid:bool; + qe_lhs_valid:patt_kind; qe_rhs: ccpattern; - qe_rhs_valid:bool} + qe_rhs_valid:patt_kind} let swap eq : equality = let swap_rule=match eq.rule with @@ -145,10 +154,11 @@ type inductive_status = | Total of (int * pa_constructor) type representative= - {mutable nfathers:int; + {mutable weight:int; mutable lfathers:Intset.t; mutable fathers:Intset.t; mutable inductive_status: inductive_status; + class_type : Term.types; mutable functions: Intset.t PafMap.t; mutable constructors: int PacMap.t} (*pac -> term = app(constr,t) *) @@ -179,9 +189,11 @@ type state = mutable diseq: disequality list; mutable quant: quant_eq list; mutable pa_classes: Intset.t; - q_history: (constr,unit) Hashtbl.t; + q_history: (identifier,int array) Hashtbl.t; mutable rew_depth:int; - mutable changed:bool} + mutable changed:bool; + by_type: (types,Intset.t) Hashtbl.t; + mutable gls:Proof_type.goal Tacmach.sigma} let dummy_node = {clas=Eqto(min_int,{lhs=min_int;rhs=min_int;rule=Congruence}); @@ -189,7 +201,7 @@ let dummy_node = vertex=Leaf; term=Symb (mkRel min_int)} -let empty depth:state = +let empty depth gls:state = {uf= {max_size=init_size; size=0; @@ -206,7 +218,9 @@ let empty depth:state = pa_classes=Intset.empty; q_history=Hashtbl.create init_size; rew_depth=depth; - changed=false} + by_type=Hashtbl.create init_size; + changed=false; + gls=gls} let forest state = state.uf @@ -233,7 +247,7 @@ let get_constructor_info uf i= | _ -> anomaly "get_constructor: not a constructor" let size uf i= - (get_representative uf i).nfathers + (get_representative uf i).weight let axioms uf = uf.axioms @@ -241,13 +255,13 @@ let epsilons uf = uf.epsilons let add_lfather uf i t= let r=get_representative uf i in - r.nfathers<-r.nfathers+1; + r.weight<-r.weight+1; r.lfathers<-Intset.add t r.lfathers; r.fathers <-Intset.add t r.fathers let add_rfather uf i t= let r=get_representative uf i in - r.nfathers<-r.nfathers+1; + r.weight<-r.weight+1; r.fathers <-Intset.add t r.fathers exception Discriminable of int * pa_constructor * int * pa_constructor @@ -295,19 +309,29 @@ let next uf= uf.size<-nsize; size -let new_representative ()= - {nfathers=0; +let new_representative typ = + {weight=0; lfathers=Intset.empty; fathers=Intset.empty; inductive_status=Unknown; + class_type=typ; functions=PafMap.empty; constructors=PacMap.empty} (* rebuild a constr from an applicative term *) +let _A_ = Name (id_of_string "A") +let _B_ = Name (id_of_string "A") +let _body_ = mkProd(Anonymous,mkRel 2,mkRel 2) + +let cc_product s1 s2 = + mkLambda(_A_,mkSort(Termops.new_sort_in_family s1), + mkLambda(_B_,mkSort(Termops.new_sort_in_family s2),_body_)) + let rec constr_of_term = function Symb s->s - | Eps -> anomaly "epsilon constant has no value" + | Product(s1,s2) -> cc_product s1 s2 + | Eps id -> mkVar id | Constructor cinfo -> mkConstruct cinfo.ci_constr | Appli (s1,s2)-> make_app [(constr_of_term s2)] s1 @@ -330,24 +354,31 @@ let rec inst_pattern subst = function (fun spat f -> Appli (f,inst_pattern subst spat)) args t +let pr_idx_term state i = str "[" ++ int i ++ str ":=" ++ + Termops.print_constr (constr_of_term (term state.uf i)) ++ str "]" + +let pr_term t = str "[" ++ + Termops.print_constr (constr_of_term t) ++ str "]" + let rec add_term state t= let uf=state.uf in try Hashtbl.find uf.syms t with Not_found -> let b=next uf in + let typ = pf_type_of state.gls (constr_of_term t) in let new_node= match t with - Symb _ -> + Symb _ | Product (_,_) -> let paf = {fsym=b; fnargs=0} in Queue.add (b,Fmark paf) state.marks; - {clas= Rep (new_representative ()); + {clas= Rep (new_representative typ); cpath= -1; vertex= Leaf; term= t} - | Eps -> - {clas= Rep (new_representative ()); + | Eps id -> + {clas= Rep (new_representative typ); cpath= -1; vertex= Leaf; term= t} @@ -356,7 +387,7 @@ let rec add_term state t= add_lfather uf (find uf i1) b; add_rfather uf (find uf i2) b; state.terms<-Intset.add b state.terms; - {clas= Rep (new_representative ()); + {clas= Rep (new_representative typ); cpath= -1; vertex= Node(i1,i2); term= t} @@ -370,13 +401,17 @@ let rec add_term state t= arity= cinfo.ci_arity; args=[]} in Queue.add (b,Cmark pac) state.marks; - {clas=Rep (new_representative ()); + {clas=Rep (new_representative typ); cpath= -1; vertex=Leaf; term=t} in uf.map.(b)<-new_node; Hashtbl.add uf.syms t b; + Hashtbl.replace state.by_type typ + (Intset.add b + (try Hashtbl.find state.by_type typ with + Not_found -> Intset.empty)); b let add_equality state c s t= @@ -400,32 +435,53 @@ let add_quant state id pol (nvars,valid1,patt1,valid2,patt2) = qe_rhs= patt2; qe_rhs_valid=valid2}::state.quant +let is_redundant state id args = + try + let norm_args = Array.map (find state.uf) args in + let prev_args = Hashtbl.find_all state.q_history id in + List.exists + (fun old_args -> + Util.array_for_all2 (fun i j -> i = find state.uf j) + norm_args old_args) + prev_args + with Not_found -> false + let add_inst state (inst,int_subst) = - if state.rew_depth > 0 then - let subst = build_subst (forest state) int_subst in - let prfhead= mkVar inst.qe_hyp_id in - let args = Array.map constr_of_term subst in - let _ = array_rev args in (* highest deBruijn index first *) - let prf= mkApp(prfhead,args) in - try Hashtbl.find state.q_history prf - with Not_found -> - (* this instance is new, we can go on *) - let s = inst_pattern subst inst.qe_lhs - and t = inst_pattern subst inst.qe_rhs in - state.changed<-true; - state.rew_depth<-pred state.rew_depth; - if inst.qe_pol then - begin - debug msgnl - (str "adding new equality, depth="++ int state.rew_depth); - add_equality state prf s t - end - else - begin - debug msgnl (str "adding new disequality, depth="++ - int state.rew_depth); - add_disequality state (Hyp prf) s t - end + check_for_interrupt (); + if state.rew_depth > 0 then + if is_redundant state inst.qe_hyp_id int_subst then + debug msgnl (str "discarding redundant (dis)equality") + else + begin + Hashtbl.add state.q_history inst.qe_hyp_id int_subst; + let subst = build_subst (forest state) int_subst in + let prfhead= mkVar inst.qe_hyp_id in + let args = Array.map constr_of_term subst in + let _ = array_rev args in (* highest deBruijn index first *) + let prf= mkApp(prfhead,args) in + let s = inst_pattern subst inst.qe_lhs + and t = inst_pattern subst inst.qe_rhs in + state.changed<-true; + state.rew_depth<-pred state.rew_depth; + if inst.qe_pol then + begin + debug (fun () -> + msgnl + (str "Adding new equality, depth="++ int state.rew_depth); + msgnl (str " [" ++ Termops.print_constr prf ++ str " : " ++ + pr_term s ++ str " == " ++ pr_term t ++ str "]")) (); + add_equality state prf s t + end + else + begin + debug (fun () -> + msgnl + (str "Adding new disequality, depth="++ int state.rew_depth); + msgnl (str " [" ++ Termops.print_constr prf ++ str " : " ++ + pr_term s ++ str " <> " ++ pr_term t ++ str "]")) (); + add_disequality state (Hyp prf) s t + end + end let link uf i j eq = (* links i -> j *) let node=uf.map.(i) in @@ -448,12 +504,17 @@ let join_path uf i j= min_path (down_path uf i [],down_path uf j []) let union state i1 i2 eq= - debug msgnl (str "Linking " ++ int i1 ++ str " and " ++ int i2 ++ str "."); + debug (fun () -> msgnl (str "Linking " ++ pr_idx_term state i1 ++ + str " and " ++ pr_idx_term state i2 ++ str ".")) (); let r1= get_representative state.uf i1 and r2= get_representative state.uf i2 in link state.uf i1 i2 eq; + Hashtbl.replace state.by_type r1.class_type + (Intset.remove i1 + (try Hashtbl.find state.by_type r1.class_type with + Not_found -> Intset.empty)); let f= Intset.union r1.fathers r2.fathers in - r2.nfathers<-Intset.cardinal f; + r2.weight<-Intset.cardinal f; r2.fathers<-f; r2.lfathers<-Intset.union r1.lfathers r2.lfathers; ST.delete_set state.sigtable r1.fathers; @@ -483,8 +544,9 @@ let union state i1 i2 eq= | _,_ -> () let merge eq state = (* merge and no-merge *) - debug msgnl - (str "Merging " ++ int eq.lhs ++ str " and " ++ int eq.rhs ++ str "."); + debug (fun () -> msgnl + (str "Merging " ++ pr_idx_term state eq.lhs ++ + str " and " ++ pr_idx_term state eq.rhs ++ str ".")) (); let uf=state.uf in let i=find uf eq.lhs and j=find uf eq.rhs in @@ -495,8 +557,8 @@ let merge eq state = (* merge and no-merge *) union state j i (swap eq) let update t state = (* update 1 and 2 *) - debug msgnl - (str "Updating term " ++ int t ++ str "."); + debug (fun () -> msgnl + (str "Updating term " ++ pr_idx_term state t ++ str ".")) (); let (i,j) as sign = signature state.uf t in let (u,v) = subterms state.uf t in let rep = get_representative state.uf i in @@ -556,8 +618,8 @@ let process_constructor_mark t i rep pac state = end let process_mark t m state = - debug msgnl - (str "Processing mark for term " ++ int t ++ str "."); + debug (fun () -> msgnl + (str "Processing mark for term " ++ pr_idx_term state t ++ str ".")) (); let i=find state.uf t in let rep=get_representative state.uf i in match m with @@ -573,9 +635,9 @@ let check_disequalities state = let uf=state.uf in let rec check_aux = function dis::q -> - debug msg - (str "Checking if " ++ int dis.lhs ++ str " = " ++ - int dis.rhs ++ str " ... "); + debug (fun () -> msg + (str "Checking if " ++ pr_idx_term state dis.lhs ++ str " = " ++ + pr_idx_term state dis.rhs ++ str " ... ")) (); if find uf dis.lhs=find uf dis.rhs then begin debug msgnl (str "Yes");Some dis end else @@ -601,16 +663,35 @@ let one_step state = update t state; true with Not_found -> false - + +let __eps__ = id_of_string "_eps_" + +let new_state_var typ state = + let id = pf_get_new_id __eps__ state.gls in + state.gls<- + {state.gls with it = + {state.gls.it with evar_hyps = + Environ.push_named_context_val (id,None,typ) + state.gls.it.evar_hyps}}; + id let complete_one_class state i= match (get_representative state.uf i).inductive_status with Partial pac -> - let rec app t n = + let rec app t typ n = if n<=0 then t else - app (Appli(t,Eps)) (n-1) in + let _,etyp,rest= destProd typ in + let id = new_state_var etyp state in + app (Appli(t,Eps id)) (substl [mkVar id] rest) (n-1) in + let _c = pf_type_of state.gls + (constr_of_term (term state.uf pac.cnode)) in + let _args = + List.map (fun i -> constr_of_term (term state.uf i)) + pac.args in + let typ = prod_applist _c (List.rev _args) in + let ct = app (term state.uf i) typ pac.arity in state.uf.epsilons <- pac :: state.uf.epsilons; - ignore (add_term state (app (term state.uf i) pac.arity)) + ignore (add_term state ct) | _ -> anomaly "wrong incomplete class" let complete state = @@ -624,18 +705,18 @@ type matching_problem = let make_fun_table state = let uf= state.uf in let funtab=ref PafMap.empty in - for cl=0 to pred uf.size do - match uf.map.(cl).clas with - Rep rep -> - PafMap.iter - (fun paf _ -> - let elem = - try PafMap.find paf !funtab - with Not_found -> Intset.empty in - funtab:= PafMap.add paf (Intset.add cl elem) !funtab) - rep.functions - | _ -> () - done; + Array.iteri + (fun i inode -> if i < uf.size then + match inode.clas with + Rep rep -> + PafMap.iter + (fun paf _ -> + let elem = + try PafMap.find paf !funtab + with Not_found -> Intset.empty in + funtab:= PafMap.add paf (Intset.add i elem) !funtab) + rep.functions + | _ -> ()) state.uf.map; !funtab @@ -656,6 +737,7 @@ let rec do_match state res pb_stack = else if mp.mp_subst.(pred i) = cl then Stack.push {mp with mp_stack=remains} pb_stack + else (* mismatch for non-linear variable in pattern *) () | PApp (f,[]) -> begin try let j=Hashtbl.find uf.syms f in @@ -665,19 +747,19 @@ let rec do_match state res pb_stack = end | PApp(f, ((last_arg::rem_args) as args)) -> try - let j=Hashtbl.find uf.syms f in + let j=Hashtbl.find uf.syms f in let paf={fsym=j;fnargs=List.length args} in let rep=get_representative uf cl in let good_terms = PafMap.find paf rep.functions in let aux i = - let (s,t) = ST.rev_query i state.sigtable in + let (s,t) = signature state.uf i in Stack.push {mp with mp_subst=Array.copy mp.mp_subst; mp_stack= (PApp(f,rem_args),s) :: (last_arg,t) :: remains} pb_stack in - Intset.iter aux good_terms + Intset.iter aux good_terms with Not_found -> () let paf_of_patt syms = function @@ -692,28 +774,50 @@ let init_pb_stack state = let funtab = make_fun_table state in let aux inst = begin - if inst.qe_lhs_valid then - try - let paf= paf_of_patt syms inst.qe_lhs in - let good_classes = PafMap.find paf funtab in - Intset.iter (fun i -> - Stack.push - {mp_subst = Array.make inst.qe_nvars (-1); - mp_inst=inst; - mp_stack=[inst.qe_lhs,i]} pb_stack) good_classes - with Not_found -> () + let good_classes = + match inst.qe_lhs_valid with + Creates_variables -> Intset.empty + | Normal -> + begin + try + let paf= paf_of_patt syms inst.qe_lhs in + PafMap.find paf funtab + with Not_found -> Intset.empty + end + | Trivial typ -> + begin + try + Hashtbl.find state.by_type typ + with Not_found -> Intset.empty + end in + Intset.iter (fun i -> + Stack.push + {mp_subst = Array.make inst.qe_nvars (-1); + mp_inst=inst; + mp_stack=[inst.qe_lhs,i]} pb_stack) good_classes end; begin - if inst.qe_rhs_valid then - try - let paf= paf_of_patt syms inst.qe_rhs in - let good_classes = PafMap.find paf funtab in - Intset.iter (fun i -> - Stack.push - {mp_subst = Array.make inst.qe_nvars (-1); - mp_inst=inst; - mp_stack=[inst.qe_rhs,i]} pb_stack) good_classes - with Not_found -> () + let good_classes = + match inst.qe_rhs_valid with + Creates_variables -> Intset.empty + | Normal -> + begin + try + let paf= paf_of_patt syms inst.qe_rhs in + PafMap.find paf funtab + with Not_found -> Intset.empty + end + | Trivial typ -> + begin + try + Hashtbl.find state.by_type typ + with Not_found -> Intset.empty + end in + Intset.iter (fun i -> + Stack.push + {mp_subst = Array.make inst.qe_nvars (-1); + mp_inst=inst; + mp_stack=[inst.qe_rhs,i]} pb_stack) good_classes end in List.iter aux state.quant; pb_stack @@ -724,7 +828,8 @@ let find_instances state = let _ = debug msgnl (str "Running E-matching algorithm ... "); try - while true do + while true do + check_for_interrupt (); do_match state res pb_stack done; anomaly "get out of here !" @@ -734,7 +839,9 @@ let find_instances state = let rec execute first_run state = debug msgnl (str "Executing ... "); try - while one_step state do () + while + check_for_interrupt (); + one_step state do () done; match check_disequalities state with None -> diff --git a/contrib/cc/ccalgo.mli b/contrib/cc/ccalgo.mli index 05a5c4d1..cdc0065e 100644 --- a/contrib/cc/ccalgo.mli +++ b/contrib/cc/ccalgo.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: ccalgo.mli 9151 2006-09-19 13:32:22Z corbinea $ *) +(* $Id: ccalgo.mli 10579 2008-02-21 13:54:00Z corbinea $ *) open Util open Term @@ -19,10 +19,16 @@ type cinfo = type term = Symb of constr - | Eps + | Product of sorts_family * sorts_family + | Eps of identifier | Appli of term*term | Constructor of cinfo (* constructor arity + nhyps *) +type patt_kind = + Normal + | Trivial of types + | Creates_variables + type ccpattern = PApp of term * ccpattern list | PVar of int @@ -70,7 +76,7 @@ val axioms : forest -> (constr, term * term) Hashtbl.t val epsilons : forest -> pa_constructor list -val empty : int -> state +val empty : int -> Proof_type.goal Tacmach.sigma -> state val add_term : state -> term -> int @@ -79,8 +85,7 @@ val add_equality : state -> constr -> term -> term -> unit val add_disequality : state -> from -> term -> term -> unit val add_quant : state -> identifier -> bool -> - int * bool * ccpattern * bool * ccpattern -> unit - + int * patt_kind * ccpattern * patt_kind * ccpattern -> unit val tail_pac : pa_constructor -> pa_constructor @@ -102,9 +107,9 @@ type quant_eq= qe_pol: bool; qe_nvars:int; qe_lhs: ccpattern; - qe_lhs_valid:bool; + qe_lhs_valid:patt_kind; qe_rhs: ccpattern; - qe_rhs_valid:bool} + qe_rhs_valid:patt_kind} type pa_fun= diff --git a/contrib/cc/ccproof.ml b/contrib/cc/ccproof.ml index d336f599..a459b18f 100644 --- a/contrib/cc/ccproof.ml +++ b/contrib/cc/ccproof.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: ccproof.ml 9856 2007-05-24 14:05:40Z corbinea $ *) +(* $Id: ccproof.ml 9857 2007-05-24 14:21:08Z corbinea $ *) (* This file uses the (non-compressed) union-find structure to generate *) (* proof-trees that will be transformed into proof-terms in cctac.ml4 *) diff --git a/contrib/cc/ccproof.mli b/contrib/cc/ccproof.mli index 572b2c53..0eb97efe 100644 --- a/contrib/cc/ccproof.mli +++ b/contrib/cc/ccproof.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: ccproof.mli 9856 2007-05-24 14:05:40Z corbinea $ *) +(* $Id: ccproof.mli 9857 2007-05-24 14:21:08Z corbinea $ *) open Ccalgo open Names diff --git a/contrib/cc/cctac.ml b/contrib/cc/cctac.ml index dc0dec0e..871d7521 100644 --- a/contrib/cc/cctac.ml +++ b/contrib/cc/cctac.ml @@ -8,7 +8,7 @@ (*i camlp4deps: "parsing/grammar.cma" i*) -(* $Id: cctac.ml 10121 2007-09-14 09:45:40Z corbinea $ *) +(* $Id: cctac.ml 10670 2008-03-14 19:30:48Z letouzey $ *) (* This file is the interface between the c-c algorithm and Coq *) @@ -24,6 +24,7 @@ open Termops open Tacmach open Tactics open Tacticals +open Typing open Ccalgo open Tacinterp open Ccproof @@ -49,6 +50,8 @@ let _False = constant ["Init";"Logic"] "False" (* decompose member of equality in an applicative format *) +let sf_of env sigma c = family_of_sort (destSort (type_of env sigma c)) + let whd env= let infos=Closure.create_clos_infos Closure.betaiotazeta env in (fun t -> Closure.whd_val infos (Closure.inject t)) @@ -57,12 +60,19 @@ let whd_delta env= let infos=Closure.create_clos_infos Closure.betadeltaiota env in (fun t -> Closure.whd_val infos (Closure.inject t)) -let rec decompose_term env t= +let rec decompose_term env sigma t= match kind_of_term (whd env t) with App (f,args)-> - let tf=decompose_term env f in - let targs=Array.map (decompose_term env) args in + let tf=decompose_term env sigma f in + let targs=Array.map (decompose_term env sigma) args in Array.fold_left (fun s t->Appli (s,t)) tf targs + | Prod (_,a,_b) when not (dependent (mkRel 1) _b) -> + let b = pop _b in + let sort_b = sf_of env sigma b in + let sort_a = sf_of env sigma a in + Appli(Appli(Product (sort_a,sort_b) , + decompose_term env sigma a), + decompose_term env sigma b) | Construct c-> let (oib,_)=Global.lookup_inductive (fst c) in let nargs=mis_constructor_nargs_env env c in @@ -73,95 +83,111 @@ let rec decompose_term env t= (* decompose equality in members and type *) -let atom_of_constr env term = +let atom_of_constr env sigma term = let wh = (whd_delta env term) in let kot = kind_of_term wh in match kot with App (f,args)-> if eq_constr f (Lazy.force _eq) && (Array.length args)=3 then `Eq (args.(0), - decompose_term env args.(1), - decompose_term env args.(2)) - else `Other (decompose_term env term) - | _ -> `Other (decompose_term env term) + decompose_term env sigma args.(1), + decompose_term env sigma args.(2)) + else `Other (decompose_term env sigma term) + | _ -> `Other (decompose_term env sigma term) -let rec pattern_of_constr env c = +let rec pattern_of_constr env sigma c = match kind_of_term (whd env c) with App (f,args)-> - let pf = decompose_term env f in + let pf = decompose_term env sigma f in let pargs,lrels = List.split - (array_map_to_list (pattern_of_constr env) args) in + (array_map_to_list (pattern_of_constr env sigma) args) in PApp (pf,List.rev pargs), - List.fold_left Intset.union Intset.empty lrels + List.fold_left Intset.union Intset.empty lrels + | Prod (_,a,_b) when not (dependent (mkRel 1) _b) -> + let b =pop _b in + let pa,sa = pattern_of_constr env sigma a in + let pb,sb = pattern_of_constr env sigma (pop b) in + let sort_b = sf_of env sigma b in + let sort_a = sf_of env sigma a in + PApp(Product (sort_a,sort_b), + [pa;pb]),(Intset.union sa sb) | Rel i -> PVar i,Intset.singleton i | _ -> - let pf = decompose_term env c in + let pf = decompose_term env sigma c in PApp (pf,[]),Intset.empty let non_trivial = function PVar _ -> false | _ -> true -let patterns_of_constr env nrels term= +let patterns_of_constr env sigma nrels term= let f,args= try destApp (whd_delta env term) with _ -> raise Not_found in if eq_constr f (Lazy.force _eq) && (Array.length args)=3 then - let patt1,rels1 = pattern_of_constr env args.(1) - and patt2,rels2 = pattern_of_constr env args.(2) in - let valid1 = (Intset.cardinal rels1 = nrels && non_trivial patt1) - and valid2 = (Intset.cardinal rels2 = nrels && non_trivial patt2) in - if valid1 || valid2 then + let patt1,rels1 = pattern_of_constr env sigma args.(1) + and patt2,rels2 = pattern_of_constr env sigma args.(2) in + let valid1 = + if Intset.cardinal rels1 <> nrels then Creates_variables + else if non_trivial patt1 then Normal + else Trivial args.(0) + and valid2 = + if Intset.cardinal rels2 <> nrels then Creates_variables + else if non_trivial patt2 then Normal + else Trivial args.(0) in + if valid1 <> Creates_variables + || valid2 <> Creates_variables then nrels,valid1,patt1,valid2,patt2 else raise Not_found else raise Not_found -let rec quantified_atom_of_constr env nrels term = +let rec quantified_atom_of_constr env sigma nrels term = match kind_of_term (whd_delta env term) with Prod (_,atom,ff) -> if eq_constr ff (Lazy.force _False) then - let patts=patterns_of_constr env nrels atom in + let patts=patterns_of_constr env sigma nrels atom in `Nrule patts else - quantified_atom_of_constr env (succ nrels) ff + quantified_atom_of_constr env sigma (succ nrels) ff | _ -> - let patts=patterns_of_constr env nrels term in + let patts=patterns_of_constr env sigma nrels term in `Rule patts -let litteral_of_constr env term= +let litteral_of_constr env sigma term= match kind_of_term (whd_delta env term) with | Prod (_,atom,ff) -> if eq_constr ff (Lazy.force _False) then - match (atom_of_constr env atom) with + match (atom_of_constr env sigma atom) with `Eq(t,a,b) -> `Neq(t,a,b) | `Other(p) -> `Nother(p) else begin try - quantified_atom_of_constr env 1 ff + quantified_atom_of_constr env sigma 1 ff with Not_found -> - `Other (decompose_term env term) + `Other (decompose_term env sigma term) end | _ -> - atom_of_constr env term + atom_of_constr env sigma term (* store all equalities from the context *) let rec make_prb gls depth additionnal_terms = let env=pf_env gls in - let state = empty depth in + let sigma=sig_sig gls in + let state = empty depth gls in let pos_hyps = ref [] in let neg_hyps =ref [] in List.iter (fun c -> - let t = decompose_term env c in + let t = decompose_term env sigma c in ignore (add_term state t)) additionnal_terms; List.iter (fun (id,_,e) -> begin let cid=mkVar id in - match litteral_of_constr env e with + match litteral_of_constr env sigma e with `Eq (t,a,b) -> add_equality state cid a b | `Neq (t,a,b) -> add_disequality state (Hyp cid) a b | `Other ph -> @@ -180,7 +206,7 @@ let rec make_prb gls depth additionnal_terms = | `Nrule patts -> add_quant state id false patts end) (Environ.named_context_of_val gls.it.evar_hyps); begin - match atom_of_constr env gls.it.evar_concl with + match atom_of_constr env sigma gls.it.evar_concl with `Eq (t,a,b) -> add_disequality state Goal a b | `Other g -> List.iter @@ -209,7 +235,7 @@ let build_projection intype outtype (cstr:constructor) special default gls= let branches=Array.init lp branch in let casee=mkRel 1 in let pred=mkLambda(Anonymous,intype,outtype) in - let case_info=make_default_case_info (pf_env gls) RegularStyle ind in + let case_info=make_case_info (pf_env gls) ind RegularStyle in let body= mkCase(case_info, pred, casee, branches) in let id=pf_get_new_id (id_of_string "t") gls in mkLambda(Name id,intype,body) @@ -224,19 +250,19 @@ let rec proof_tac p gls = | SymAx c -> let l=constr_of_term p.p_lhs and r=constr_of_term p.p_rhs in - let typ = pf_type_of gls l in + let typ = refresh_universes (pf_type_of gls l) in exact_check (mkApp(Lazy.force _sym_eq,[|typ;r;l;c|])) gls | Refl t -> let lr = constr_of_term t in - let typ = pf_type_of gls lr in + let typ = refresh_universes (pf_type_of gls lr) in exact_check (mkApp(Lazy.force _refl_equal,[|typ;constr_of_term t|])) gls | Trans (p1,p2)-> let t1 = constr_of_term p1.p_lhs and t2 = constr_of_term p1.p_rhs and t3 = constr_of_term p2.p_rhs in - let typ = pf_type_of gls t2 in + let typ = refresh_universes (pf_type_of gls t2) in let prf = mkApp(Lazy.force _trans_eq,[|typ;t1;t2;t3;_M 1;_M 2|]) in tclTHENS (refine prf) [(proof_tac p1);(proof_tac p2)] gls @@ -245,16 +271,17 @@ let rec proof_tac p gls = and tx1=constr_of_term p2.p_lhs and tf2=constr_of_term p1.p_rhs and tx2=constr_of_term p2.p_rhs in - let typf = pf_type_of gls tf1 in - let typx = pf_type_of gls tx1 in - let typfx = pf_type_of gls (mkApp (tf1,[|tx1|])) in + let typf = refresh_universes (pf_type_of gls tf1) in + let typx = refresh_universes (pf_type_of gls tx1) in + let typfx = refresh_universes (pf_type_of gls (mkApp (tf1,[|tx1|]))) in let id = pf_get_new_id (id_of_string "f") gls in let appx1 = mkLambda(Name id,typf,mkApp(mkRel 1,[|tx1|])) in let lemma1 = mkApp(Lazy.force _f_equal, [|typf;typfx;appx1;tf1;tf2;_M 1|]) in let lemma2= - mkApp(Lazy.force _f_equal,[|typx;typfx;tf2;tx1;tx2;_M 1|]) in + mkApp(Lazy.force _f_equal, + [|typx;typfx;tf2;tx1;tx2;_M 1|]) in let prf = mkApp(Lazy.force _trans_eq, [|typfx; @@ -274,8 +301,8 @@ let rec proof_tac p gls = let ti=constr_of_term prf.p_lhs in let tj=constr_of_term prf.p_rhs in let default=constr_of_term p.p_lhs in - let intype=pf_type_of gls ti in - let outtype=pf_type_of gls default in + let intype=refresh_universes (pf_type_of gls ti) in + let outtype=refresh_universes (pf_type_of gls default) in let special=mkRel (1+nargs-argind) in let proj=build_projection intype outtype cstr special default gls in let injt= @@ -284,7 +311,7 @@ let rec proof_tac p gls = let refute_tac c t1 t2 p gls = let tt1=constr_of_term t1 and tt2=constr_of_term t2 in - let intype=pf_type_of gls tt1 in + let intype=refresh_universes (pf_type_of gls tt1) in let neweq= mkApp(Lazy.force _eq, [|intype;tt1;tt2|]) in @@ -295,7 +322,7 @@ let refute_tac c t1 t2 p gls = let convert_to_goal_tac c t1 t2 p gls = let tt1=constr_of_term t1 and tt2=constr_of_term t2 in - let sort=pf_type_of gls tt2 in + let sort=refresh_universes (pf_type_of gls tt2) in let neweq=mkApp(Lazy.force _eq,[|sort;tt1;tt2|]) in let e=pf_get_new_id (id_of_string "e") gls in let x=pf_get_new_id (id_of_string "X") gls in @@ -315,7 +342,7 @@ let convert_to_hyp_tac c1 t1 c2 t2 p gls = let discriminate_tac cstr p gls = let t1=constr_of_term p.p_lhs and t2=constr_of_term p.p_rhs in - let intype=pf_type_of gls t1 in + let intype=refresh_universes (pf_type_of gls t1) in let concl=pf_concl gls in let outsort=mkType (new_univ ()) in let xid=pf_get_new_id (id_of_string "X") gls in @@ -403,3 +430,29 @@ let congruence_tac depth l = tclORELSE (tclTHEN (tclREPEAT introf) (cc_tactic depth l)) cc_fail + +(* The [f_equal] tactic. + + It mimics the use of lemmas [f_equal], [f_equal2], etc. + This isn't particularly related with congruence, apart from + the fact that congruence is called internally. +*) + +let f_equal gl = + let cut_eq c1 c2 = + let ty = refresh_universes (pf_type_of gl c1) in + tclTHENTRY + (Tactics.cut (mkApp (Lazy.force _eq, [|ty; c1; c2|]))) reflexivity + in + try match kind_of_term (pf_concl gl) with + | App (r,[|_;t;t'|]) when eq_constr r (Lazy.force _eq) -> + begin match kind_of_term t, kind_of_term t' with + | App (f,v), App (f',v') when Array.length v = Array.length v' -> + let rec cuts i = + if i < 0 then tclTRY (congruence_tac 1000 []) + else tclTHENFIRST (cut_eq v.(i) v'.(i)) (cuts (i-1)) + in cuts (Array.length v - 1) gl + | _ -> tclIDTAC gl + end + | _ -> tclIDTAC gl + with Type_errors.TypeError _ -> tclIDTAC gl diff --git a/contrib/cc/cctac.mli b/contrib/cc/cctac.mli index ffc4b9c4..57ad0558 100644 --- a/contrib/cc/cctac.mli +++ b/contrib/cc/cctac.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: cctac.mli 10121 2007-09-14 09:45:40Z corbinea $ *) +(* $Id: cctac.mli 10637 2008-03-07 23:52:56Z letouzey $ *) open Term open Proof_type @@ -18,3 +18,5 @@ val cc_tactic : int -> constr list -> tactic val cc_fail : tactic val congruence_tac : int -> constr list -> tactic + +val f_equal : tactic diff --git a/contrib/cc/g_congruence.ml4 b/contrib/cc/g_congruence.ml4 index 693aebb4..9877e6fc 100644 --- a/contrib/cc/g_congruence.ml4 +++ b/contrib/cc/g_congruence.ml4 @@ -8,7 +8,7 @@ (*i camlp4deps: "parsing/grammar.cma" i*) -(* $Id: g_congruence.ml4 9151 2006-09-19 13:32:22Z corbinea $ *) +(* $Id: g_congruence.ml4 10637 2008-03-07 23:52:56Z letouzey $ *) open Cctac open Tactics @@ -17,9 +17,13 @@ open Tacticals (* Tactic registration *) TACTIC EXTEND cc - [ "congruence" ] -> [ congruence_tac 0 [] ] + [ "congruence" ] -> [ congruence_tac 1000 [] ] |[ "congruence" integer(n) ] -> [ congruence_tac n [] ] - |[ "congruence" "with" ne_constr_list(l) ] -> [ congruence_tac 0 l ] + |[ "congruence" "with" ne_constr_list(l) ] -> [ congruence_tac 1000 l ] |[ "congruence" integer(n) "with" ne_constr_list(l) ] -> [ congruence_tac n l ] END + +TACTIC EXTEND f_equal + [ "f_equal" ] -> [ f_equal ] +END diff --git a/contrib/correctness/ProgramsExtraction.v b/contrib/correctness/ProgramsExtraction.v index 5f7dfdbf..70f4b730 100644 --- a/contrib/correctness/ProgramsExtraction.v +++ b/contrib/correctness/ProgramsExtraction.v @@ -8,9 +8,7 @@ (* Certification of Imperative Programs / Jean-Christophe Filliâtre *) -(* $Id: ProgramsExtraction.v 5920 2004-07-16 20:01:26Z herbelin $ *) - -Require Export Extraction. +(* $Id: ProgramsExtraction.v 10290 2007-11-06 01:27:17Z letouzey $ *) Extract Inductive unit => unit [ "()" ]. Extract Inductive bool => bool [ true false ]. diff --git a/contrib/correctness/past.mli b/contrib/correctness/past.mli deleted file mode 100644 index 70328704..00000000 --- a/contrib/correctness/past.mli +++ /dev/null @@ -1,97 +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 *) -(************************************************************************) - -(* Certification of Imperative Programs / Jean-Christophe Filliâtre *) - -(* $Id: past.mli 5920 2004-07-16 20:01:26Z herbelin $ *) - -(*s Abstract syntax of imperative programs. *) - -open Names -open Ptype -open Topconstr - -type termination = - | RecArg of int - | Wf of constr_expr * constr_expr - -type variable = identifier - -type pattern = - | PatVar of identifier - | PatConstruct of identifier * ((kernel_name * int) * int) - | PatAlias of pattern * identifier - | PatPair of pattern * pattern - | PatApp of pattern list - -type epattern = - | ExnConstant of identifier - | ExnBind of identifier * identifier - -type ('a, 'b) block_st = - | Label of string - | Assert of 'b Ptype.assertion - | Statement of 'a - -type ('a, 'b) block = ('a, 'b) block_st list - -type ('a, 'b) t = { - desc : ('a, 'b) t_desc; - pre : 'b Ptype.precondition list; - post : 'b Ptype.postcondition option; - loc : Util.loc; - info : 'a -} - -and ('a, 'b) t_desc = - | Variable of variable - | Acc of variable - | Aff of variable * ('a, 'b) t - | TabAcc of bool * variable * ('a, 'b) t - | TabAff of bool * variable * ('a, 'b) t * ('a, 'b) t - | Seq of (('a, 'b) t, 'b) block - | While of ('a, 'b) t * 'b Ptype.assertion option * ('b * 'b) * - (('a, 'b) t, 'b) block - | If of ('a, 'b) t * ('a, 'b) t * ('a, 'b) t - | Lam of 'b Ptype.ml_type_v Ptype.binder list * ('a, 'b) t - | Apply of ('a, 'b) t * ('a, 'b) arg list - | SApp of ('a, 'b) t_desc list * ('a, 'b) t list - | LetRef of variable * ('a, 'b) t * ('a, 'b) t - | Let of variable * ('a, 'b) t * ('a, 'b) t - | LetRec of variable * 'b Ptype.ml_type_v Ptype.binder list * - 'b Ptype.ml_type_v * ('b * 'b) * ('a, 'b) t - | PPoint of string * ('a, 'b) t_desc - | Expression of Term.constr - | Debug of string * ('a, 'b) t - -and ('a, 'b) arg = - | Term of ('a, 'b) t - | Refarg of variable - | Type of 'b Ptype.ml_type_v - -type program = (unit, Topconstr.constr_expr) t - -(*s Intermediate type for CC terms. *) - -type cc_type = Term.constr - -type cc_bind_type = - | CC_typed_binder of cc_type - | CC_untyped_binder - -type cc_binder = variable * cc_bind_type - -type cc_term = - | CC_var of variable - | CC_letin of bool * cc_type * cc_binder list * cc_term * cc_term - | CC_lam of cc_binder list * cc_term - | CC_app of cc_term * cc_term list - | CC_tuple of bool * cc_type list * cc_term list - | CC_case of cc_type * cc_term * cc_term list - | CC_expr of Term.constr - | CC_hole of cc_type diff --git a/contrib/correctness/pcic.ml b/contrib/correctness/pcic.ml deleted file mode 100644 index 041cd81f..00000000 --- a/contrib/correctness/pcic.ml +++ /dev/null @@ -1,231 +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 *) -(************************************************************************) - -(* Certification of Imperative Programs / Jean-Christophe Filliâtre *) - -(* $Id: pcic.ml 5920 2004-07-16 20:01:26Z herbelin $ *) - -open Util -open Names -open Nameops -open Libnames -open Term -open Termops -open Nametab -open Declarations -open Indtypes -open Sign -open Rawterm -open Typeops -open Entries -open Topconstr - -open Pmisc -open Past - - -(* Here we translate intermediates terms (cc_term) into CCI terms (constr) *) - -let make_hole c = mkCast (isevar, c) - -(* Tuples are defined in file Tuples.v - * and their constructors are called Build_tuple_n or exists_n, - * wether they are dependant (last element only) or not. - * If necessary, tuples are generated ``on the fly''. *) - -let tuple_exists id = - try let _ = Nametab.locate (make_short_qualid id) in true - with Not_found -> false - -let ast_set = CSort (dummy_loc,RProp Pos) - -let tuple_n n = - let id = make_ident "tuple_" (Some n) in - let l1n = Util.interval 1 n in - let params = - List.map (fun i -> - (LocalRawAssum ([dummy_loc,Name (make_ident "T" (Some i))], ast_set))) - l1n in - let fields = - List.map - (fun i -> - let id = make_ident ("proj_" ^ string_of_int n ^ "_") (Some i) in - let id' = make_ident "T" (Some i) in - (false, Vernacexpr.AssumExpr ((dummy_loc,Name id), mkIdentC id'))) - l1n - in - let cons = make_ident "Build_tuple_" (Some n) in - Record.definition_structure - ((false, (dummy_loc,id)), params, fields, cons, mk_Set) - -(*s [(sig_n n)] generates the inductive - \begin{verbatim} - Inductive sig_n [T1,...,Tn:Set; P:T1->...->Tn->Prop] : Set := - exist_n : (x1:T1)...(xn:Tn)(P x1 ... xn) -> (sig_n T1 ... Tn P). - \end{verbatim} *) - -let sig_n n = - let id = make_ident "sig_" (Some n) in - let l1n = Util.interval 1 n in - let lT = List.map (fun i -> make_ident "T" (Some i)) l1n in - let lx = List.map (fun i -> make_ident "x" (Some i)) l1n in - let idp = make_ident "P" None in - let params = - let typ = List.fold_right (fun _ c -> mkArrow (mkRel n) c) lT mkProp in - (idp, LocalAssum typ) :: - (List.rev_map (fun id -> (id, LocalAssum mkSet)) lT) - in - let lc = - let app_sig = mkApp(mkRel (2*n+3), - Array.init (n+1) (fun i -> mkRel (2*n+2-i))) in - let app_p = mkApp(mkRel (n+1), - Array.init n (fun i -> mkRel (n-i))) in - let c = mkArrow app_p app_sig in - List.fold_right (fun id c -> mkProd (Name id, mkRel (n+1), c)) lx c - in - let cname = make_ident "exist_" (Some n) in - Declare.declare_mind - { mind_entry_finite = true; - mind_entry_inds = - [ { mind_entry_params = params; - mind_entry_typename = id; - mind_entry_arity = mkSet; - mind_entry_consnames = [ cname ]; - mind_entry_lc = [ lc ] } ] } - -(*s On the fly generation of needed (possibly dependent) tuples. *) - -let check_product_n n = - if n > 2 then - let s = Printf.sprintf "tuple_%d" n in - if not (tuple_exists (id_of_string s)) then tuple_n n - -let check_dep_product_n n = - if n > 1 then - let s = Printf.sprintf "sig_%d" n in - if not (tuple_exists (id_of_string s)) then ignore (sig_n n) - -(*s Constructors for the tuples. *) - -let pair = ConstructRef ((coq_constant ["Init"; "Datatypes"] "prod",0),1) -let exist = ConstructRef ((coq_constant ["Init"; "Specif"] "sig",0),1) - -let tuple_ref dep n = - if n = 2 & not dep then - pair - else - let n = n - (if dep then 1 else 0) in - if dep then - if n = 1 then - exist - else begin - let id = make_ident "exist_" (Some n) in - if not (tuple_exists id) then ignore (sig_n n); - Nametab.locate (make_short_qualid id) - end - else begin - let id = make_ident "Build_tuple_" (Some n) in - if not (tuple_exists id) then tuple_n n; - Nametab.locate (make_short_qualid id) - end - -(* Binders. *) - -let trad_binder avoid nenv id = function - | CC_untyped_binder -> RHole (dummy_loc,BinderType (Name id)) - | CC_typed_binder ty -> Detyping.detype (false,Global.env()) avoid nenv ty - -let rec push_vars avoid nenv = function - | [] -> ([],avoid,nenv) - | (id,b) :: bl -> - let b' = trad_binder avoid nenv id b in - let bl',avoid',nenv' = - push_vars (id :: avoid) (add_name (Name id) nenv) bl - in - ((id,b') :: bl', avoid', nenv') - -let rec raw_lambda bl v = match bl with - | [] -> - v - | (id,ty) :: bl' -> - RLambda (dummy_loc, Name id, ty, raw_lambda bl' v) - -(* The translation itself is quite easy. - letin are translated into Cases constructions *) - -let rawconstr_of_prog p = - let rec trad avoid nenv = function - | CC_var id -> - RVar (dummy_loc, id) - - (*i optimisation : let x = <constr> in e2 => e2[x<-constr] - | CC_letin (_,_,[id,_],CC_expr c,e2) -> - real_subst_in_constr [id,c] (trad e2) - | CC_letin (_,_,([_] as b),CC_expr e1,e2) -> - let (b',avoid',nenv') = push_vars avoid nenv b in - let c1 = Detyping.detype avoid nenv e1 - and c2 = trad avoid' nenv' e2 in - let id = Name (fst (List.hd b')) in - RLetIn (dummy_loc, id, c1, c2) - i*) - - | CC_letin (_,_,([_] as b),e1,e2) -> - let (b',avoid',nenv') = push_vars avoid nenv b in - let c1 = trad avoid nenv e1 - and c2 = trad avoid' nenv' e2 in - RApp (dummy_loc, raw_lambda b' c2, [c1]) - - | CC_letin (dep,ty,bl,e1,e2) -> - let (bl',avoid',nenv') = push_vars avoid nenv bl in - let c1 = trad avoid nenv e1 - and c2 = trad avoid' nenv' e2 in - ROrderedCase (dummy_loc, LetStyle, None, c1, [| raw_lambda bl' c2 |], ref None) - - | CC_lam (bl,e) -> - let bl',avoid',nenv' = push_vars avoid nenv bl in - let c = trad avoid' nenv' e in - raw_lambda bl' c - - | CC_app (f,args) -> - let c = trad avoid nenv f - and cargs = List.map (trad avoid nenv) args in - RApp (dummy_loc, c, cargs) - - | CC_tuple (_,_,[e]) -> - trad avoid nenv e - - | CC_tuple (false,_,[e1;e2]) -> - let c1 = trad avoid nenv e1 - and c2 = trad avoid nenv e2 in - RApp (dummy_loc, RRef (dummy_loc,pair), - [RHole (dummy_loc,ImplicitArg (pair,1)); - RHole (dummy_loc,ImplicitArg (pair,2));c1;c2]) - - | CC_tuple (dep,tyl,l) -> - let n = List.length l in - let cl = List.map (trad avoid nenv) l in - let tuple = tuple_ref dep n in - let tyl = List.map (Detyping.detype (false,Global.env()) avoid nenv) tyl in - let args = tyl @ cl in - RApp (dummy_loc, RRef (dummy_loc, tuple), args) - - | CC_case (ty,b,el) -> - let c = trad avoid nenv b in - let cl = List.map (trad avoid nenv) el in - let ty = Detyping.detype (false,Global.env()) avoid nenv ty in - ROrderedCase (dummy_loc, RegularStyle, Some ty, c, Array.of_list cl, ref None) - - | CC_expr c -> - Detyping.detype (false,Global.env()) avoid nenv c - - | CC_hole c -> - RCast (dummy_loc, RHole (dummy_loc, QuestionMark), - Detyping.detype (false,Global.env()) avoid nenv c) - - in - trad [] empty_names_context p diff --git a/contrib/correctness/pcic.mli b/contrib/correctness/pcic.mli deleted file mode 100644 index 67b152f3..00000000 --- a/contrib/correctness/pcic.mli +++ /dev/null @@ -1,24 +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 *) -(************************************************************************) - -(* Certification of Imperative Programs / Jean-Christophe Filliâtre *) - -(*i $Id: pcic.mli 5920 2004-07-16 20:01:26Z herbelin $ i*) - -open Past -open Rawterm - -(* On-the-fly generation of needed (possibly dependent) tuples. *) - -val check_product_n : int -> unit -val check_dep_product_n : int -> unit - -(* transforms intermediate functional programs into (raw) CIC terms *) - -val rawconstr_of_prog : cc_term -> rawconstr - diff --git a/contrib/correctness/pcicenv.ml b/contrib/correctness/pcicenv.ml deleted file mode 100644 index 368d0281..00000000 --- a/contrib/correctness/pcicenv.ml +++ /dev/null @@ -1,118 +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 *) -(************************************************************************) - -(* Certification of Imperative Programs / Jean-Christophe Filliâtre *) - -(* $Id: pcicenv.ml 5920 2004-07-16 20:01:26Z herbelin $ *) - -open Names -open Term -open Sign - -open Pmisc -open Putil -open Ptype -open Past - -(* on redéfinit add_sign pour éviter de construire des environnements - * avec des doublons (qui font planter la résolution des implicites !) *) - -(* VERY UGLY!! find some work around *) -let modify_sign id t s = - fold_named_context - (fun ((x,b,ty) as d) sign -> - if x=id then add_named_decl (x,b,t) sign else add_named_decl d sign) - s ~init:empty_named_context - -let add_sign (id,t) s = - try - let _ = lookup_named id s in - modify_sign id t s - with Not_found -> - add_named_decl (id,None,t) s - -let cast_set c = mkCast (c, mkSet) - -let set = mkCast (mkSet, mkType Univ.prop_univ) - -(* [cci_sign_of env] construit un environnement pour CIC ne comprenant que - * les objets fonctionnels de l'environnement de programes [env] - *) - -let cci_sign_of ren env = - Penv.fold_all - (fun (id,v) sign -> - match v with - | Penv.TypeV (Ref _ | Array _) -> sign - | Penv.TypeV v -> - let ty = Pmonad.trad_ml_type_v ren env v in - add_sign (id,cast_set ty) sign - | Penv.Set -> add_sign (id,set) sign) - env (Global.named_context ()) - -(* [sign_meta ren env fadd ini] - * construit un environnement pour CIC qui prend en compte les variables - * de programme. - * pour cela, cette fonction parcours tout l'envrionnement (global puis - * local [env]) et pour chaque déclaration, ajoute ce qu'il faut avec la - * fonction [fadd] s'il s'agit d'un mutable et directement sinon, - * en partant de [ini]. - *) - -let sign_meta ren env fast ini = - Penv.fold_all - (fun (id,v) sign -> - match v with - | Penv.TypeV (Ref _ | Array _ as v) -> - let ty = Pmonad.trad_imp_type ren env v in - fast sign id ty - | Penv.TypeV v -> - let ty = Pmonad.trad_ml_type_v ren env v in - add_sign (id,cast_set ty) sign - | Penv.Set -> add_sign (id,set) sign) - env ini - -let add_sign_d dates (id,c) sign = - let sign = - List.fold_left (fun sign d -> add_sign (at_id id d,c) sign) sign dates - in - add_sign (id,c) sign - -let sign_of add ren env = - sign_meta ren env - (fun sign id c -> let c = cast_set c in add (id,c) sign) - (Global.named_context ()) - -let result_of sign = function - None -> sign - | Some (id,c) -> add_sign (id, cast_set c) sign - -let before_after_result_sign_of res ren env = - let dates = "" :: Prename.all_dates ren in - result_of (sign_of (add_sign_d dates) ren env) res - -let before_after_sign_of ren = - let dates = "" :: Prename.all_dates ren in - sign_of (add_sign_d dates) ren - -let before_sign_of ren = - let dates = Prename.all_dates ren in - sign_of (add_sign_d dates) ren - -let now_sign_of = - sign_of (add_sign_d []) - - -(* environnement après traduction *) - -let trad_sign_of ren = - sign_of - (fun (id,c) sign -> add_sign (Prename.current_var ren id,c) sign) - ren - - diff --git a/contrib/correctness/pcicenv.mli b/contrib/correctness/pcicenv.mli deleted file mode 100644 index 365fa960..00000000 --- a/contrib/correctness/pcicenv.mli +++ /dev/null @@ -1,38 +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 *) -(************************************************************************) - -(* Certification of Imperative Programs / Jean-Christophe Filliâtre *) - -(* $Id: pcicenv.mli 5920 2004-07-16 20:01:26Z herbelin $ *) - -open Penv -open Names -open Term -open Sign - -(* Translation of local programs environments into Coq signatures. - * It is mainly used to type the pre/post conditions in the good - * environment *) - -(* cci_sign_of: uniquement les objets purement fonctionnels de l'env. *) -val cci_sign_of : Prename.t -> local_env -> named_context - -(* env. Coq avec seulement les variables X de l'env. *) -val now_sign_of : Prename.t -> local_env -> named_context - -(* + les variables X@d pour toutes les dates de l'env. *) -val before_sign_of : Prename.t -> local_env -> named_context - -(* + les variables `avant' X@ *) -val before_after_sign_of : Prename.t -> local_env -> named_context -val before_after_result_sign_of : ((identifier * constr) option) - -> Prename.t -> local_env -> named_context - -(* env. des programmes traduits, avec les variables rennomées *) -val trad_sign_of : Prename.t -> local_env -> named_context - diff --git a/contrib/correctness/pdb.ml b/contrib/correctness/pdb.ml deleted file mode 100644 index 759e9133..00000000 --- a/contrib/correctness/pdb.ml +++ /dev/null @@ -1,165 +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 *) -(************************************************************************) - -(* Certification of Imperative Programs / Jean-Christophe Filliâtre *) - -(* $Id: pdb.ml 5920 2004-07-16 20:01:26Z herbelin $ *) - -open Names -open Term -open Termops -open Nametab -open Constrintern - -open Ptype -open Past -open Penv - -let cci_global id = - try - global_reference id - with - _ -> raise Not_found - -let lookup_var ids locop id = - if List.mem id ids then - None - else begin - try Some (cci_global id) - with Not_found -> Perror.unbound_variable id locop - end - -let check_ref idl loc id = - if (not (List.mem id idl)) & (not (Penv.is_global id)) then - Perror.unbound_reference id loc - -(* db types : only check the references for the moment *) - -let rec check_type_v refs = function - | Ref v -> - check_type_v refs v - | Array (c,v) -> - check_type_v refs v - | Arrow (bl,c) -> - check_binder refs c bl - | TypePure _ -> - () - -and check_type_c refs ((_,v),e,_,_) = - check_type_v refs v; - List.iter (check_ref refs None) (Peffect.get_reads e); - List.iter (check_ref refs None) (Peffect.get_writes e) - (* TODO: check_condition on p and q *) - -and check_binder refs c = function - | [] -> - check_type_c refs c - | (id, BindType (Ref _ | Array _ as v)) :: bl -> - check_type_v refs v; - check_binder (id :: refs) c bl - | (_, BindType v) :: bl -> - check_type_v refs v; - check_binder refs c bl - | _ :: bl -> - check_binder refs c bl - -(* db binders *) - -let rec db_binders ((tids,pids,refs) as idl) = function - | [] -> - idl, [] - | (id, BindType (Ref _ | Array _ as v)) as b :: rem -> - check_type_v refs v; - let idl',rem' = db_binders (tids,pids,id::refs) rem in - idl', b :: rem' - | (id, BindType v) as b :: rem -> - check_type_v refs v; - let idl',rem' = db_binders (tids,id::pids,refs) rem in - idl', b :: rem' - | ((id, BindSet) as t) :: rem -> - let idl',rem' = db_binders (id::tids,pids,refs) rem in - idl', t :: rem' - | a :: rem -> - let idl',rem' = db_binders idl rem in idl', a :: rem' - - -(* db programs *) - -let db_prog e = - (* tids = type identifiers, ids = variables, refs = references and arrays *) - let rec db_desc ((tids,ids,refs) as idl) = function - | (Variable x) as t -> - (match lookup_var ids (Some e.loc) x with - None -> t - | Some c -> Expression c) - | (Acc x) as t -> - check_ref refs (Some e.loc) x; - t - | Aff (x,e1) -> - check_ref refs (Some e.loc) x; - Aff (x, db idl e1) - | TabAcc (b,x,e1) -> - check_ref refs (Some e.loc) x; - TabAcc(b,x,db idl e1) - | TabAff (b,x,e1,e2) -> - check_ref refs (Some e.loc) x; - TabAff (b,x, db idl e1, db idl e2) - | Seq bl -> - Seq (List.map (function - Statement p -> Statement (db idl p) - | x -> x) bl) - | If (e1,e2,e3) -> - If (db idl e1, db idl e2, db idl e3) - | While (b,inv,var,bl) -> - let bl' = List.map (function - Statement p -> Statement (db idl p) - | x -> x) bl in - While (db idl b, inv, var, bl') - - | Lam (bl,e) -> - let idl',bl' = db_binders idl bl in Lam(bl', db idl' e) - | Apply (e1,l) -> - Apply (db idl e1, List.map (db_arg idl) l) - | SApp (dl,l) -> - SApp (dl, List.map (db idl) l) - | LetRef (x,e1,e2) -> - LetRef (x, db idl e1, db (tids,ids,x::refs) e2) - | Let (x,e1,e2) -> - Let (x, db idl e1, db (tids,x::ids,refs) e2) - - | LetRec (f,bl,v,var,e) -> - let (tids',ids',refs'),bl' = db_binders idl bl in - check_type_v refs' v; - LetRec (f, bl, v, var, db (tids',f::ids',refs') e) - - | Debug (s,e1) -> - Debug (s, db idl e1) - - | Expression _ as x -> x - | PPoint (s,d) -> PPoint (s, db_desc idl d) - - and db_arg ((tids,_,refs) as idl) = function - | Term ({ desc = Variable id } as t) -> - if List.mem id refs then Refarg id else Term (db idl t) - | Term t -> Term (db idl t) - | Type v as ty -> check_type_v refs v; ty - | Refarg _ -> assert false - - and db idl e = - { desc = db_desc idl e.desc ; - pre = e.pre; post = e.post; - loc = e.loc; info = e.info } - - in - let ids = Termops.ids_of_named_context (Global.named_context ()) in - (* TODO: separer X:Set et x:V:Set - virer le reste (axiomes, etc.) *) - let vars,refs = all_vars (), all_refs () in - db ([],vars@ids,refs) e -;; - diff --git a/contrib/correctness/pdb.mli b/contrib/correctness/pdb.mli deleted file mode 100644 index d6e647b7..00000000 --- a/contrib/correctness/pdb.mli +++ /dev/null @@ -1,25 +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 *) -(************************************************************************) - -(* Certification of Imperative Programs / Jean-Christophe Filliâtre *) - -(* $Id: pdb.mli 5920 2004-07-16 20:01:26Z herbelin $ *) - -open Ptype -open Past - - -(* Here we separate local and global variables, we check the use of - * references and arrays w.r.t the local and global environments, etc. - * These functions directly raise UserError exceptions on bad programs. - *) - -val check_type_v : Names.identifier list -> 'a ml_type_v -> unit - -val db_prog : program -> program - diff --git a/contrib/correctness/peffect.ml b/contrib/correctness/peffect.ml deleted file mode 100644 index faf5f3d3..00000000 --- a/contrib/correctness/peffect.ml +++ /dev/null @@ -1,159 +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 *) -(************************************************************************) - -(* Certification of Imperative Programs / Jean-Christophe Filliâtre *) - -(* $Id: peffect.ml 5920 2004-07-16 20:01:26Z herbelin $ *) - -open Names -open Nameops -open Pmisc - -(* The type of effects. - * - * An effect is composed of two lists (r,w) of variables. - * The first one is the list of read-only variables - * and the second one is the list of read-write variables. - * - * INVARIANT: 1. each list is sorted in decreasing order for Pervasives.compare - * 2. there are no duplicate elements in each list - * 3. the two lists are disjoint - *) - -type t = identifier list * identifier list - - -(* the empty effect *) - -let bottom = ([], []) - -(* basic operations *) - -let push x l = - let rec push_rec = function - [] -> [x] - | (y::rem) as l -> - if x = y then l else if x > y then x::l else y :: push_rec rem - in - push_rec l - -let basic_remove x l = - let rec rem_rec = function - [] -> [] - | y::l -> if x = y then l else y :: rem_rec l - in - rem_rec l - -let mem x (r,w) = (List.mem x r) or (List.mem x w) - -let rec basic_union = function - [], s2 -> s2 - | s1, [] -> s1 - | ((v1::l1) as s1), ((v2::l2) as s2) -> - if v1 > v2 then - v1 :: basic_union (l1,s2) - else if v1 < v2 then - v2 :: basic_union (s1,l2) - else - v1 :: basic_union (l1,l2) - -(* adds reads and writes variables *) - -let add_read id ((r,w) as e) = - (* if the variable is already a RW it is ok, otherwise adds it as a RO. *) - if List.mem id w then - e - else - push id r, w - -let add_write id (r,w) = - (* if the variable is a RO then removes it from RO. Adds it to RW. *) - if List.mem id r then - basic_remove id r, push id w - else - r, push id w - -(* access *) - -let get_reads = basic_union -let get_writes = snd -let get_repr e = (get_reads e, get_writes e) - -(* tests *) - -let is_read (r,_) id = List.mem id r -let is_write (_,w) id = List.mem id w - -(* union and disjunction *) - -let union (r1,w1) (r2,w2) = basic_union (r1,r2), basic_union (w1,w2) - -let rec diff = function - [], s2 -> [] - | s1, [] -> s1 - | ((v1::l1) as s1), ((v2::l2) as s2) -> - if v1 > v2 then - v1 :: diff (l1,s2) - else if v1 < v2 then - diff (s1,l2) - else - diff (l1,l2) - -let disj (r1,w1) (r2,w2) = - let w1_w2 = diff (w1,w2) and w2_w1 = diff (w2,w1) in - let r = basic_union (basic_union (r1,r2), basic_union (w1_w2,w2_w1)) - and w = basic_union (w1,w2) in - r,w - -(* comparison relation *) - -let le e1 e2 = failwith "effects: le: not yet implemented" - -let inf e1 e2 = failwith "effects: inf: not yet implemented" - -(* composition *) - -let compose (r1,w1) (r2,w2) = - let r = basic_union (r1, diff (r2,w1)) in - let w = basic_union (w1,w2) in - r,w - -(* remove *) - -let remove (r,w) name = basic_remove name r, basic_remove name w - -(* substitution *) - -let subst_list (x,x') l = - if List.mem x l then push x' (basic_remove x l) else l - -let subst_one (r,w) s = subst_list s r, subst_list s w - -let subst s e = List.fold_left subst_one e s - -(* pretty-print *) - -open Pp -open Util -open Himsg - -let pp (r,w) = - hov 0 (if r<>[] then - (str"reads " ++ - prlist_with_sep (fun () -> (str"," ++ spc ())) pr_id r) - else (mt ()) ++ - spc () ++ - if w<>[] then - (str"writes " ++ - prlist_with_sep (fun ()-> (str"," ++ spc ())) pr_id w) - else (mt ()) -) - -let ppr e = - Pp.pp (pp e) - diff --git a/contrib/correctness/peffect.mli b/contrib/correctness/peffect.mli deleted file mode 100644 index 9a10dea4..00000000 --- a/contrib/correctness/peffect.mli +++ /dev/null @@ -1,42 +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 *) -(************************************************************************) - -(* Certification of Imperative Programs / Jean-Christophe Filliâtre *) - -(* $Id: peffect.mli 5920 2004-07-16 20:01:26Z herbelin $ *) - -open Names - -(* The abstract type of effects *) - -type t - -val bottom : t -val add_read : identifier -> t -> t -val add_write : identifier -> t -> t - -val get_reads : t -> identifier list -val get_writes : t -> identifier list -val get_repr : t -> (identifier list) * (identifier list) - -val is_read : t -> identifier -> bool (* read-only *) -val is_write : t -> identifier -> bool (* read-write *) - -val compose : t -> t -> t - -val union : t -> t -> t -val disj : t -> t -> t - -val remove : t -> identifier -> t - -val subst : (identifier * identifier) list -> t -> t - - -val pp : t -> Pp.std_ppcmds -val ppr : t -> unit - diff --git a/contrib/correctness/penv.ml b/contrib/correctness/penv.ml deleted file mode 100644 index 7f89b1e1..00000000 --- a/contrib/correctness/penv.ml +++ /dev/null @@ -1,240 +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 *) -(************************************************************************) - -(* Certification of Imperative Programs / Jean-Christophe Filliâtre *) - -(* $Id: penv.ml 5920 2004-07-16 20:01:26Z herbelin $ *) - -open Pmisc -open Past -open Ptype -open Names -open Nameops -open Libobject -open Library -open Term - -(* Environments for imperative programs. - * - * An environment of programs is an association tables - * from identifiers (Names.identifier) to types of values with effects - * (ProgAst.ml_type_v), together with a list of these associations, since - * the order is relevant (we have dependent types e.g. [x:nat; t:(array x T)]) - *) - -module Env = struct - type 'a t = ('a Idmap.t) - * ((identifier * 'a) list) - * ((identifier * (identifier * variant)) list) - let empty = Idmap.empty, [], [] - let add id v (m,l,r) = (Idmap.add id v m, (id,v)::l, r) - let find id (m,_,_) = Idmap.find id m - let fold f (_,l,_) x0 = List.fold_right f l x0 - let add_rec (id,var) (m,l,r) = (m,l,(id,var)::r) - let find_rec id (_,_,r) = List.assoc id r -end - -(* Local environments *) - -type type_info = Set | TypeV of type_v - -type local_env = type_info Env.t - -let empty = (Env.empty : local_env) - -let add (id,v) = Env.add id (TypeV v) - -let add_set id = Env.add id Set - -let find id env = - match Env.find id env with TypeV v -> v | Set -> raise Not_found - -let is_local env id = - try - match Env.find id env with TypeV _ -> true | Set -> false - with - Not_found -> false - -let is_local_set env id = - try - match Env.find id env with TypeV _ -> false | Set -> true - with - Not_found -> false - - -(* typed programs *) - -type typing_info = { - env : local_env; - kappa : constr ml_type_c -} - -type typed_program = (typing_info, constr) t - - -(* The global environment. - * - * We have a global typing environment env - * We also keep a table of programs for extraction purposes - * and a table of initializations (still for extraction) - *) - -let (env : type_info Env.t ref) = ref Env.empty - -let (pgm_table : (typed_program option) Idmap.t ref) = ref Idmap.empty - -let (init_table : constr Idmap.t ref) = ref Idmap.empty - -let freeze () = (!env, !pgm_table, !init_table) -let unfreeze (e,p,i) = env := e; pgm_table := p; init_table := i -let init () = - env := Env.empty; pgm_table := Idmap.empty; init_table := Idmap.empty -;; - -Summary.declare_summary "programs-environment" - { Summary.freeze_function = freeze; - Summary.unfreeze_function = unfreeze; - Summary.init_function = init; - Summary.survive_module = false; - Summary.survive_section = false } -;; - -(* Operations on the global environment. *) - -let add_pgm id p = pgm_table := Idmap.add id p !pgm_table - -let cache_global (_,(id,v,p)) = - env := Env.add id v !env; add_pgm id p - -let type_info_app f = function Set -> Set | TypeV v -> TypeV (f v) - -let subst_global (_,s,(id,v,p)) = (id, type_info_app (type_v_knsubst s) v, p) - -let (inProg,outProg) = - declare_object { object_name = "programs-objects"; - cache_function = cache_global; - load_function = (fun _ -> cache_global); - open_function = (fun _ _ -> ()); - classify_function = (fun (_,x) -> Substitute x); - subst_function = subst_global; - export_function = (fun x -> Some x) } - -let is_mutable = function Ref _ | Array _ -> true | _ -> false - -let add_global id v p = - try - let _ = Env.find id !env in - Perror.clash id None - with - Not_found -> begin - let id' = - if is_mutable v then id - else id_of_string ("prog_" ^ (string_of_id id)) - in - Lib.add_leaf id' (inProg (id,TypeV v,p)) - end - -let add_global_set id = - try - let _ = Env.find id !env in - Perror.clash id None - with - Not_found -> Lib.add_leaf id (inProg (id,Set,None)) - -let is_global id = - try - match Env.find id !env with TypeV _ -> true | Set -> false - with - Not_found -> false - -let is_global_set id = - try - match Env.find id !env with TypeV _ -> false | Set -> true - with - Not_found -> false - - -let lookup_global id = - match Env.find id !env with TypeV v -> v | Set -> raise Not_found - -let find_pgm id = Idmap.find id !pgm_table - -let all_vars () = - Env.fold - (fun (id,v) l -> match v with TypeV (Arrow _|TypePure _) -> id::l | _ -> l) - !env [] - -let all_refs () = - Env.fold - (fun (id,v) l -> match v with TypeV (Ref _ | Array _) -> id::l | _ -> l) - !env [] - -(* initializations *) - -let cache_init (_,(id,c)) = - init_table := Idmap.add id c !init_table - -let subst_init (_,s,(id,c)) = (id, subst_mps s c) - -let (inInit,outInit) = - declare_object { object_name = "programs-objects-init"; - cache_function = cache_init; - load_function = (fun _ -> cache_init); - open_function = (fun _ _-> ()); - classify_function = (fun (_,x) -> Substitute x); - subst_function = subst_init; - export_function = (fun x -> Some x) } - -let initialize id c = Lib.add_anonymous_leaf (inInit (id,c)) - -let find_init id = Idmap.find id !init_table - - -(* access in env, local then global *) - -let type_in_env env id = - try find id env with Not_found -> lookup_global id - -let is_in_env env id = - (is_global id) or (is_local env id) - -let fold_all f lenv x0 = - let x1 = Env.fold f !env x0 in - Env.fold f lenv x1 - - -(* recursions *) - -let add_recursion = Env.add_rec - -let find_recursion = Env.find_rec - - -(* We also maintain a table of the currently edited proofs of programs - * in order to add them in the environnement when the user does Save *) - -open Pp -open Himsg - -let (edited : (type_v * typed_program) Idmap.t ref) = ref Idmap.empty - -let new_edited id v = - edited := Idmap.add id v !edited - -let is_edited id = - try let _ = Idmap.find id !edited in true with Not_found -> false - -let register id id' = - try - let (v,p) = Idmap.find id !edited in - let _ = add_global id' v (Some p) in - Options.if_verbose - msgnl (hov 0 (str"Program " ++ pr_id id' ++ spc () ++ str"is defined")); - edited := Idmap.remove id !edited - with Not_found -> () - diff --git a/contrib/correctness/penv.mli b/contrib/correctness/penv.mli deleted file mode 100644 index 6743b465..00000000 --- a/contrib/correctness/penv.mli +++ /dev/null @@ -1,87 +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 *) -(************************************************************************) - -(* Certification of Imperative Programs / Jean-Christophe Filliâtre *) - -(* $Id: penv.mli 5920 2004-07-16 20:01:26Z herbelin $ *) - -open Ptype -open Past -open Names -open Libnames -open Term - -(* Environment for imperative programs. - * - * Here we manage the global environment, which is imperative, - * and we provide a functional local environment. - * - * The most important functions, is_in_env, type_in_env and fold_all - * first look in the local environment then in the global one. - *) - -(* local environments *) - -type local_env - -val empty : local_env -val add : (identifier * type_v) -> local_env -> local_env -val add_set : identifier -> local_env -> local_env -val is_local : local_env -> identifier -> bool -val is_local_set : local_env -> identifier -> bool - -(* typed programs *) - -type typing_info = { - env : local_env; - kappa : constr ml_type_c -} - -type typed_program = (typing_info, constr) t - -(* global environment *) - -val add_global : identifier -> type_v -> typed_program option -> object_name -val add_global_set : identifier -> object_name -val is_global : identifier -> bool -val is_global_set : identifier -> bool -val lookup_global : identifier -> type_v - -val all_vars : unit -> identifier list -val all_refs : unit -> identifier list - -(* a table keeps the program (for extraction) *) - -val find_pgm : identifier -> typed_program option - -(* a table keeps the initializations of mutable objects *) - -val initialize : identifier -> constr -> unit -val find_init : identifier -> constr - -(* access in env (local then global) *) - -val type_in_env : local_env -> identifier -> type_v -val is_in_env : local_env -> identifier -> bool - -type type_info = Set | TypeV of type_v -val fold_all : (identifier * type_info -> 'a -> 'a) -> local_env -> 'a -> 'a - -(* local environnements also contains a list of recursive functions - * with the associated variant *) - -val add_recursion : identifier * (identifier*variant) -> local_env -> local_env -val find_recursion : identifier -> local_env -> identifier * variant - -(* We also maintain a table of the currently edited proofs of programs - * in order to add them in the environnement when the user does Save *) - -val new_edited : identifier -> type_v * typed_program -> unit -val is_edited : identifier -> bool -val register : identifier -> identifier -> unit - diff --git a/contrib/correctness/perror.ml b/contrib/correctness/perror.ml deleted file mode 100644 index 8415e96d..00000000 --- a/contrib/correctness/perror.ml +++ /dev/null @@ -1,172 +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 *) -(************************************************************************) - -(* Certification of Imperative Programs / Jean-Christophe Filliâtre *) - -(* $Id: perror.ml 5920 2004-07-16 20:01:26Z herbelin $ *) - -open Pp -open Util -open Names -open Nameops -open Term -open Himsg - -open Ptype -open Past - -let is_mutable = function Ref _ | Array _ -> true | _ -> false -let is_pure = function TypePure _ -> true | _ -> false - -let raise_with_loc = function - | None -> raise - | Some loc -> Stdpp.raise_with_loc loc - -let unbound_variable id loc = - raise_with_loc loc - (UserError ("Perror.unbound_variable", - (hov 0 (str"Unbound variable" ++ spc () ++ pr_id id ++ fnl ())))) - -let unbound_reference id loc = - raise_with_loc loc - (UserError ("Perror.unbound_reference", - (hov 0 (str"Unbound reference" ++ spc () ++ pr_id id ++ fnl ())))) - -let clash id loc = - raise_with_loc loc - (UserError ("Perror.clash", - (hov 0 (str"Clash with previous constant" ++ spc () ++ - str(string_of_id id) ++ fnl ())))) - -let not_defined id = - raise - (UserError ("Perror.not_defined", - (hov 0 (str"The object" ++ spc () ++ pr_id id ++ spc () ++ - str"is not defined" ++ fnl ())))) - -let check_for_reference loc id = function - Ref _ -> () - | _ -> Stdpp.raise_with_loc loc - (UserError ("Perror.check_for_reference", - hov 0 (pr_id id ++ spc () ++ - str"is not a reference"))) - -let check_for_array loc id = function - Array _ -> () - | _ -> Stdpp.raise_with_loc loc - (UserError ("Perror.check_for_array", - hov 0 (pr_id id ++ spc () ++ - str"is not an array"))) - -let is_constant_type s = function - TypePure c -> - let id = id_of_string s in - let c' = Constrintern.global_reference id in - Reductionops.is_conv (Global.env()) Evd.empty c c' - | _ -> false - -let check_for_index_type loc v = - let is_index = is_constant_type "Z" v in - if not is_index then - Stdpp.raise_with_loc loc - (UserError ("Perror.check_for_index", - hov 0 (str"This expression is an index" ++ spc () ++ - str"and should have type int (Z)"))) - -let check_no_effect loc ef = - if not (Peffect.get_writes ef = []) then - Stdpp.raise_with_loc loc - (UserError ("Perror.check_no_effect", - hov 0 (str"A boolean should not have side effects" -))) - -let should_be_boolean loc = - Stdpp.raise_with_loc loc - (UserError ("Perror.should_be_boolean", - hov 0 (str"This expression is a test:" ++ spc () ++ - str"it should have type bool"))) - -let test_should_be_annotated loc = - Stdpp.raise_with_loc loc - (UserError ("Perror.test_should_be_annotated", - hov 0 (str"This test should be annotated"))) - -let if_branches loc = - Stdpp.raise_with_loc loc - (UserError ("Perror.if_branches", - hov 0 (str"The two branches of an `if' expression" ++ spc () ++ - str"should have the same type"))) - -let check_for_not_mutable loc v = - if is_mutable v then - Stdpp.raise_with_loc loc - (UserError ("Perror.check_for_not_mutable", - hov 0 (str"This expression cannot be a mutable"))) - -let check_for_pure_type loc v = - if not (is_pure v) then - Stdpp.raise_with_loc loc - (UserError ("Perror.check_for_pure_type", - hov 0 (str"This expression must be pure" ++ spc () ++ - str"(neither a mutable nor a function)"))) - -let check_for_let_ref loc v = - if not (is_pure v) then - Stdpp.raise_with_loc loc - (UserError ("Perror.check_for_let_ref", - hov 0 (str"References can only be bound in pure terms"))) - -let informative loc s = - Stdpp.raise_with_loc loc - (UserError ("Perror.variant_informative", - hov 0 (str s ++ spc () ++ str"must be informative"))) - -let variant_informative loc = informative loc "Variant" -let should_be_informative loc = informative loc "This term" - -let app_of_non_function loc = - Stdpp.raise_with_loc loc - (UserError ("Perror.app_of_non_function", - hov 0 (str"This term cannot be applied" ++ spc () ++ - str"(either it is not a function" ++ spc () ++ - str"or it is applied to non pure arguments)"))) - -let partial_app loc = - Stdpp.raise_with_loc loc - (UserError ("Perror.partial_app", - hov 0 (str"This function does not have" ++ - spc () ++ str"the right number of arguments"))) - -let expected_type loc s = - Stdpp.raise_with_loc loc - (UserError ("Perror.expected_type", - hov 0 (str"Argument is expected to have type" ++ spc () ++ s))) - -let expects_a_type id loc = - Stdpp.raise_with_loc loc - (UserError ("Perror.expects_a_type", - hov 0 (str"The argument " ++ pr_id id ++ spc () ++ - str"in this application is supposed to be a type"))) - -let expects_a_term id = - raise - (UserError ("Perror.expects_a_type", - hov 0 (str"The argument " ++ pr_id id ++ spc () ++ - str"in this application is supposed to be a term"))) - -let should_be_a_variable loc = - Stdpp.raise_with_loc loc - (UserError ("Perror.should_be_a_variable", - hov 0 (str"Argument should be a variable"))) - -let should_be_a_reference loc = - Stdpp.raise_with_loc loc - (UserError ("Perror.should_be_a_reference", - hov 0 (str"Argument of function should be a reference"))) - - diff --git a/contrib/correctness/perror.mli b/contrib/correctness/perror.mli deleted file mode 100644 index 45b2acdc..00000000 --- a/contrib/correctness/perror.mli +++ /dev/null @@ -1,47 +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 *) -(************************************************************************) - -(* Certification of Imperative Programs / Jean-Christophe Filliâtre *) - -(* $Id: perror.mli 5920 2004-07-16 20:01:26Z herbelin $ *) - -open Pp -open Util -open Names -open Ptype -open Past - -val unbound_variable : identifier -> loc option -> 'a -val unbound_reference : identifier -> loc option -> 'a - -val clash : identifier -> loc option -> 'a -val not_defined : identifier -> 'a - -val check_for_reference : loc -> identifier -> type_v -> unit -val check_for_array : loc -> identifier -> type_v -> unit - -val check_for_index_type : loc -> type_v -> unit -val check_no_effect : loc -> Peffect.t -> unit -val should_be_boolean : loc -> 'a -val test_should_be_annotated : loc -> 'a -val if_branches : loc -> 'a - -val check_for_not_mutable : loc -> type_v -> unit -val check_for_pure_type : loc -> type_v -> unit -val check_for_let_ref : loc -> type_v -> unit - -val variant_informative : loc -> 'a -val should_be_informative : loc -> 'a - -val app_of_non_function : loc -> 'a -val partial_app : loc -> 'a -val expected_type : loc -> std_ppcmds -> 'a -val expects_a_type : identifier -> loc -> 'a -val expects_a_term : identifier -> 'a -val should_be_a_variable : loc -> 'a -val should_be_a_reference : loc -> 'a diff --git a/contrib/correctness/pextract.ml b/contrib/correctness/pextract.ml deleted file mode 100644 index 407567ad..00000000 --- a/contrib/correctness/pextract.ml +++ /dev/null @@ -1,473 +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 *) -(************************************************************************) - -(* Certification of Imperative Programs / Jean-Christophe Filliâtre *) - -(* $Id: pextract.ml 5920 2004-07-16 20:01:26Z herbelin $ *) - -open Pp_control -open Pp -open Util -open System -open Names -open Term -open Himsg -open Reduction - -open Putil -open Ptype -open Past -open Penv -open Putil - -let extraction env c = - let ren = initial_renaming env in - let sign = Pcicenv.now_sign_of ren env in - let fsign = Mach.fsign_of_sign (Evd.mt_evd()) sign in - match Mach.infexecute (Evd.mt_evd()) (sign,fsign) c with - | (_,Inf j) -> j._VAL - | (_,Logic) -> failwith "Prog_extract.pp: should be informative" - -(* les tableaux jouent un role particulier, puisqu'ils seront extraits - * vers des tableaux ML *) - -let sp_access = coq_constant ["correctness"; "Arrays"] "access" -let access = ConstRef sp_access - -let has_array = ref false - -let pp_conversions () = - (str"\ -let rec int_of_pos = function - XH -> 1 - | XI p -> 2 * (int_of_pos p) + 1 - | XO p -> 2 * (int_of_pos p) - ++ ++ - -let int_of_z = function - ZERO -> 0 - | POS p -> int_of_pos p - | NEG p -> -(int_of_pos p) - ++ ++ -") (* '"' *) - -(* collect all section-path in a CIC constant *) - -let spset_of_cci env c = - let spl = Fw_env.collect (extraction env c) in - let sps = List.fold_left (fun e x -> SpSet.add x e) SpSet.empty spl in - has_array := !has_array or (SpSet.mem sp_access sps) ++ - SpSet.remove sp_access sps - - -(* collect all Coq constants and all pgms appearing in a given program *) - -let add_id env ((sp,ids) as s) id = - if is_local env id then - s - else if is_global id then - (sp,IdSet.add id ids) - else - try (SpSet.add (Nametab.sp_of_id FW id) sp,ids) with Not_found -> s - -let collect env = - let rec collect_desc env s = function - | Var x -> add_id env s x - | Acc x -> add_id env s x - | Aff (x,e1) -> add_id env (collect_rec env s e1) x - | TabAcc (_,x,e1) -> - has_array := true ++ - add_id env (collect_rec env s e1) x - | TabAff (_,x,e1,e2) -> - has_array := true ++ - add_id env (collect_rec env (collect_rec env s e1) e2) x - | Seq bl -> - List.fold_left (fun s st -> match st with - Statement p -> collect_rec env s p - | _ -> s) s bl - | If (e1,e2,e3) -> - collect_rec env (collect_rec env (collect_rec env s e1) e2) e3 - | While (b,_,_,bl) -> - let s = List.fold_left (fun s st -> match st with - Statement p -> collect_rec env s p - | _ -> s) s bl in - collect_rec env s b - | Lam (bl,e) -> - collect_rec (traverse_binders env bl) s e - | App (e1,l) -> - let s = List.fold_left (fun s a -> match a with - Term t -> collect_rec env s t - | Type _ | Refarg _ -> s) s l in - collect_rec env s e1 - | SApp (_,l) -> - List.fold_left (fun s a -> collect_rec env s a) s l - | LetRef (x,e1,e2) -> - let (_,v),_,_,_ = e1.info.kappa in - collect_rec (add (x,Ref v) env) (collect_rec env s e1) e2 - | LetIn (x,e1,e2) -> - let (_,v),_,_,_ = e1.info.kappa in - collect_rec (add (x,v) env) (collect_rec env s e1) e2 - | LetRec (f,bl,_,_,e) -> - let env' = traverse_binders env bl in - let env'' = add (f,make_arrow bl e.info.kappa) env' in - collect_rec env'' s e - | Debug (_,e1) -> collect_rec env s e1 - | PPoint (_,d) -> collect_desc env s d - | Expression c -> - let (sp,ids) = s in - let sp' = spset_of_cci env c in - SpSet.fold - (fun s (es,ei) -> - let id = basename s in - if is_global id then (*SpSet.add s*)es,IdSet.add id ei - else SpSet.add s es,ei) - sp' (sp,ids) - - and collect_rec env s p = collect_desc env s p.desc - - in - collect_rec env (SpSet.empty,IdSet.empty) - - -(* On a besoin de faire du renommage, tout comme pour l'extraction des - * termes Coq. En ce qui concerne les globaux, on utilise la table de - * Fwtoml. Pour les objects locaux, on introduit la structure de - * renommage rename_struct - *) - -module Ocaml_ren = Ocaml.OCaml_renaming - -let rename_global id = - let id' = Ocaml_ren.rename_global_term !Fwtoml.globals (Name id) in - Fwtoml.add_global_renaming (id,id') ++ - id' - -type rename_struct = { rn_map : identifier IdMap.t; - rn_avoid : identifier list } - -let rn_empty = { rn_map = IdMap.empty; rn_avoid = [] } - -let rename_local rn id = - let id' = Ocaml_ren.rename_term (!Fwtoml.globals@rn.rn_avoid) (Name id) in - { rn_map = IdMap.add id id' rn.rn_map; rn_avoid = id' :: rn.rn_avoid }, - id' - -let get_local_name rn id = IdMap.find id rn.rn_map - -let get_name env rn id = - if is_local env id then - get_local_name rn id - else - Fwtoml.get_global_name id - -let rec rename_binders rn = function - | [] -> rn - | (id,_) :: bl -> let rn',_ = rename_local rn id in rename_binders rn' bl - -(* on a bespoin d'un pretty-printer de constr particulier, qui reconnaisse - * les acces a des references et dans des tableaux, et qui de plus n'imprime - * pas de GENTERM lorsque des identificateurs ne sont pas visibles. - * Il est simplifie dans la mesure ou l'on a ici que des constantes et - * des applications. - *) - -let putpar par s = - if par then (str"(" ++ s ++ str")") else s - -let is_ref env id = - try - (match type_in_env env id with Ref _ -> true | _ -> false) - with - Not_found -> false - -let rec pp_constr env rn = function - | VAR id -> - if is_ref env id then - (str"!" ++ pID (get_name env rn id)) - else - pID (get_name env rn id) - | DOPN((Const _|MutInd _|MutConstruct _) as oper, _) -> - pID (Fwtoml.name_of_oper oper) - | DOPN(AppL,v) -> - if Array.length v = 0 then - (mt ()) - else begin - match v.(0) with - DOPN(Const sp,_) when sp = sp_access -> - (pp_constr env rn v.(3) ++ - str".(int_of_z " ++ pp_constr env rn v.(4) ++ str")") - | _ -> - hov 2 (putpar true (prvect_with_sep (fun () -> (spc ())) - (pp_constr env rn) v)) - end - | DOP2(Cast,c,_) -> pp_constr env rn c - | _ -> failwith "Prog_extract.pp_constr: unexpected constr" - - -(* pretty-print of imperative programs *) - -let collect_lambda = - let rec collect acc p = match p.desc with - | Lam(bl,t) -> collect (bl@acc) t - | x -> acc,p - in - collect [] - -let pr_binding rn = - prlist_with_sep (fun () -> (mt ())) - (function - | (id,(Untyped | BindType _)) -> - (str" " ++ pID (get_local_name rn id)) - | (id,BindSet) -> (mt ())) - -let pp_prog id = - let rec pp_d env rn par = function - | Var x -> pID (get_name env rn x) - | Acc x -> (str"!" ++ pID (get_name env rn x)) - | Aff (x,e1) -> (pID (get_name env rn x) ++ - str" := " ++ hov 0 (pp env rn false e1)) - | TabAcc (_,x,e1) -> - (pID (get_name env rn x) ++ - str".(int_of_z " ++ hov 0 (pp env rn true e1) ++ str")") - | TabAff (_,x,e1,e2) -> - (pID (get_name env rn x) ++ - str".(int_of_z " ++ hov 0 (pp env rn true e1) ++ str")" ++ - str" <-" ++ spc () ++ hov 2 (pp env rn false e2)) - | Seq bl -> - (str"begin" ++ fnl () ++ - str" " ++ hov 0 (pp_block env rn bl) ++ fnl () ++ - str"end") - | If (e1,e2,e3) -> - putpar par (str"if " ++ (pp env rn false e1) ++ - str" then" ++ fnl () ++ - str" " ++ hov 0 (pp env rn false e2) ++ fnl () ++ - str"else" ++ fnl () ++ - str" " ++ hov 0 (pp env rn false e3)) - (* optimisations : then begin .... end else begin ... end *) - | While (b,inv,_,bl) -> - (str"while " ++ (pp env rn false b) ++ str" do" ++ fnl () ++ - str" " ++ - hov 0 ((match inv with - None -> (mt ()) - | Some c -> (str"(* invariant: " ++ pTERM c.a_value ++ - str" *)" ++ fnl ())) ++ - pp_block env rn bl) ++ fnl () ++ - str"done") - | Lam (bl,e) -> - let env' = traverse_binders env bl in - let rn' = rename_binders rn bl in - putpar par - (hov 2 (str"fun" ++ pr_binding rn' bl ++ str" ->" ++ - spc () ++ pp env' rn' false e)) - | SApp ((Var id)::_, [e1; e2]) - when id = connective_and or id = connective_or -> - let conn = if id = connective_and then "&" else "or" in - putpar par - (hov 0 (pp env rn true e1 ++ spc () ++ str conn ++ spc () ++ - pp env rn true e2)) - | SApp ((Var id)::_, [e]) when id = connective_not -> - putpar par - (hov 0 (str"not" ++ spc () ++ pp env rn true e)) - | SApp _ -> - invalid_arg "Prog_extract.pp_prog (SApp)" - | App(e1,[]) -> - hov 0 (pp env rn false e1) - | App (e1,l) -> - putpar true - (hov 2 (pp env rn true e1 ++ - prlist (function - Term p -> (spc () ++ pp env rn true p) - | Refarg x -> (spc () ++ pID (get_name env rn x)) - | Type _ -> (mt ())) - l)) - | LetRef (x,e1,e2) -> - let (_,v),_,_,_ = e1.info.kappa in - let env' = add (x,Ref v) env in - let rn',x' = rename_local rn x in - putpar par - (hov 0 (str"let " ++ pID x' ++ str" = ref " ++ pp env rn false e1 ++ - str" in" ++ fnl () ++ pp env' rn' false e2)) - | LetIn (x,e1,e2) -> - let (_,v),_,_,_ = e1.info.kappa in - let env' = add (x,v) env in - let rn',x' = rename_local rn x in - putpar par - (hov 0 (str"let " ++ pID x' ++ str" = " ++ pp env rn false e1 ++ - str" in" ++ fnl () ++ pp env' rn' false e2)) - | LetRec (f,bl,_,_,e) -> - let env' = traverse_binders env bl in - let rn' = rename_binders rn bl in - let env'' = add (f,make_arrow bl e.info.kappa) env' in - let rn'',f' = rename_local rn' f in - putpar par - (hov 0 (str"let rec " ++ pID f' ++ pr_binding rn' bl ++ str" =" ++ fnl () ++ - str" " ++ hov 0 (pp env'' rn'' false e) ++ fnl () ++ - str"in " ++ pID f')) - | Debug (_,e1) -> pp env rn par e1 - | PPoint (_,d) -> pp_d env rn par d - | Expression c -> - pp_constr env rn (extraction env c) - - and pp_block env rn bl = - let bl = - map_succeed (function Statement p -> p | _ -> failwith "caught") bl - in - prlist_with_sep (fun () -> (str";" ++ fnl ())) - (fun p -> hov 0 (pp env rn false p)) bl - - and pp env rn par p = - (pp_d env rn par p.desc) - - and pp_mut v c = match v with - | Ref _ -> - (str"ref " ++ pp_constr empty rn_empty (extraction empty c)) - | Array (n,_) -> - (str"Array.create " ++ cut () ++ - putpar true - (str"int_of_z " ++ - pp_constr empty rn_empty (extraction empty n)) ++ - str" " ++ pp_constr empty rn_empty (extraction empty c)) - | _ -> invalid_arg "pp_mut" - in - let v = lookup_global id in - let id' = rename_global id in - if is_mutable v then - try - let c = find_init id in - hov 0 (str"let " ++ pID id' ++ str" = " ++ pp_mut v c) - with Not_found -> - errorlabstrm "Prog_extract.pp_prog" - (str"The variable " ++ pID id ++ - str" must be initialized first !") - else - match find_pgm id with - | None -> - errorlabstrm "Prog_extract.pp_prog" - (str"The program " ++ pID id ++ - str" must be realized first !") - | Some p -> - let bl,p = collect_lambda p in - let rn = rename_binders rn_empty bl in - let env = traverse_binders empty bl in - hov 0 (str"let " ++ pID id' ++ pr_binding rn bl ++ str" =" ++ fnl () ++ - str" " ++ hov 2 (pp env rn false p)) - -(* extraction des programmes impératifs/fonctionnels vers ocaml *) - -(* Il faut parfois importer des modules non ouverts, sinon - * Ocaml.OCaml_pp_file.pp echoue en disant "machin is not a defined - * informative object". Cela dit, ce n'est pas tres satisfaisant, vu que - * la constante existe quand meme: il vaudrait mieux contourner l'echec - * de ml_import.fwsp_of_id - *) - -let import sp = match repr_path sp with - | [m],_,_ -> - begin - try Library.import_export_module m true - with _ -> () - end - | _ -> () - -let pp_ocaml file prm = - has_array := false ++ - (* on separe objects Coq et programmes *) - let cic,pgms = - List.fold_left - (fun (sp,ids) id -> - if is_global id then (sp,IdSet.add id ids) else (IdSet.add id sp,ids)) - (IdSet.empty,IdSet.empty) prm.needed - in - (* on met les programmes dans l'ordre et pour chacun on recherche les - * objects Coq necessaires, que l'on rajoute a l'ensemble cic *) - let cic,_,pgms = - let o_pgms = fold_all (fun (id,_) l -> id::l) empty [] in - List.fold_left - (fun (cic,pgms,pl) id -> - if IdSet.mem id pgms then - let spl,pgms' = - try - (match find_pgm id with - | Some p -> collect empty p - | None -> - (try - let c = find_init id in - spset_of_cci empty c,IdSet.empty - with Not_found -> - SpSet.empty,IdSet.empty)) - with Not_found -> SpSet.empty,IdSet.empty - in - let cic' = - SpSet.fold - (fun sp cic -> import sp ++ IdSet.add (basename sp) cic) - spl cic - in - (cic',IdSet.union pgms pgms',id::pl) - else - (cic,pgms,pl)) - (cic,pgms,[]) o_pgms - in - let cic = IdSet.elements cic in - (* on pretty-print *) - let prm' = { needed = cic ++ expand = prm.expand ++ - expansion = prm.expansion ++ exact = prm.exact } - in - let strm = (Ocaml.OCaml_pp_file.pp_recursive prm' ++ - fnl () ++ fnl () ++ - if !has_array then pp_conversions() else (mt ()) ++ - prlist (fun p -> (pp_prog p ++ fnl () ++ str";;" ++ fnl () ++ fnl ())) - pgms -) - in - (* puis on ecrit dans le fichier *) - let chan = open_trapping_failure open_out file ".ml" in - let ft = with_output_to chan in - begin - try pP_with ft strm ++ pp_flush_with ft () - with e -> pp_flush_with ft () ++ close_out chan ++ raise e - end ++ - close_out chan - - -(* Initializations of mutable objects *) - -let initialize id com = - let loc = Ast.loc com in - let c = constr_of_com (Evd.mt_evd()) (initial_sign()) com in - let ty = - Reductionops.nf_betaiota (type_of (Evd.mt_evd()) (initial_sign()) c) in - try - let v = lookup_global id in - let ety = match v with - | Ref (TypePure c) -> c | Array (_,TypePure c) -> c - | _ -> raise Not_found - in - if conv (Evd.mt_evd()) ty ety then - initialize id c - else - errorlabstrm "Prog_extract.initialize" - (str"Not the expected type for the mutable " ++ pID id) - with Not_found -> - errorlabstrm "Prog_extract.initialize" - (pr_id id ++ str" is not a mutable") - -(* grammaire *) - -open Vernacinterp - -let _ = vinterp_add "IMPERATIVEEXTRACTION" - (function - | VARG_STRING file :: rem -> - let prm = parse_param rem in (fun () -> pp_ocaml file prm) - | _ -> assert false) - -let _ = vinterp_add "INITIALIZE" - (function - | [VARG_IDENTIFIER id; VARG_COMMAND com] -> - (fun () -> initialize id com) - | _ -> assert false) diff --git a/contrib/correctness/pextract.mli b/contrib/correctness/pextract.mli deleted file mode 100644 index 3492729c..00000000 --- a/contrib/correctness/pextract.mli +++ /dev/null @@ -1,17 +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 *) -(************************************************************************) - -(* Certification of Imperative Programs / Jean-Christophe Filliâtre *) - -(* $Id: pextract.mli 5920 2004-07-16 20:01:26Z herbelin $ *) - -open Names - -val pp_ocaml : string -> unit - - diff --git a/contrib/correctness/pmisc.ml b/contrib/correctness/pmisc.ml deleted file mode 100644 index 076b11cd..00000000 --- a/contrib/correctness/pmisc.ml +++ /dev/null @@ -1,222 +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 *) -(************************************************************************) - -(* Certification of Imperative Programs / Jean-Christophe Filliâtre *) - -(* $Id: pmisc.ml 8752 2006-04-27 19:37:33Z herbelin $ *) - -open Pp -open Util -open Names -open Nameops -open Term -open Libnames -open Topconstr - -(* debug *) - -let deb_mess s = - if !Options.debug then begin - msgnl s; pp_flush() - end - -let deb_print f x = - if !Options.debug then begin - msgnl (f x); pp_flush() - end - -let list_of_some = function - None -> [] - | Some x -> [x] - -let difference l1 l2 = - let rec diff = function - [] -> [] - | a::rem -> if List.mem a l2 then diff rem else a::(diff rem) - in - diff l1 - -(* TODO: these functions should be moved in the code of Coq *) - -let reraise_with_loc loc f x = - try f x with Util.UserError (_,_) as e -> Stdpp.raise_with_loc loc e - - -(* functions on names *) - -let at = if !Options.v7 then "@" else "'at'" - -let at_id id d = id_of_string ((string_of_id id) ^ at ^ d) - -let is_at id = - try - let _ = string_index_from (string_of_id id) 0 at in true - with Not_found -> - false - -let un_at id = - let s = string_of_id id in - try - let n = string_index_from s 0 at in - id_of_string (String.sub s 0 n), - String.sub s (n + String.length at) - (String.length s - n - String.length at) - with Not_found -> - invalid_arg "un_at" - -let renaming_of_ids avoid ids = - let rec rename avoid = function - [] -> [], avoid - | x::rem -> - let al,avoid = rename avoid rem in - let x' = next_ident_away x avoid in - (x,x')::al, x'::avoid - in - rename avoid ids - -let result_id = id_of_string "result" - -let adr_id id = id_of_string ("adr_" ^ (string_of_id id)) - -(* hypotheses names *) - -let next s r = function - Anonymous -> incr r; id_of_string (s ^ string_of_int !r) - | Name id -> id - -let reset_names,pre_name,post_name,inv_name, - test_name,bool_name,var_name,phi_name,for_name,label_name = - let pre = ref 0 in - let post = ref 0 in - let inv = ref 0 in - let test = ref 0 in - let bool = ref 0 in - let var = ref 0 in - let phi = ref 0 in - let forr = ref 0 in - let label = ref 0 in - (fun () -> - pre := 0; post := 0; inv := 0; test := 0; - bool := 0; var := 0; phi := 0; label := 0), - (next "Pre" pre), - (next "Post" post), - (next "Inv" inv), - (next "Test" test), - (fun () -> next "Bool" bool Anonymous), - (next "Variant" var), - (fun () -> next "rphi" phi Anonymous), - (fun () -> next "for" forr Anonymous), - (fun () -> string_of_id (next "Label" label Anonymous)) - -let default = id_of_string "x_" -let id_of_name = function Name id -> id | Anonymous -> default - - -(* functions on CIC terms *) - -let isevar = Evarutil.new_evar_in_sign (Global.env ()) - -(* Substitutions of variables by others. *) -let subst_in_constr alist = - let alist' = List.map (fun (id,id') -> (id, mkVar id')) alist in - replace_vars alist' - -(* -let subst_in_ast alist ast = - let rec subst = function - Nvar(l,s) -> Nvar(l,try List.assoc s alist with Not_found -> s) - | Node(l,s,args) -> Node(l,s,List.map subst args) - | Slam(l,so,a) -> Slam(l,so,subst a) (* TODO:enlever so de alist ? *) - | x -> x - in - subst ast -*) -(* -let subst_ast_in_ast alist ast = - let rec subst = function - Nvar(l,s) as x -> (try List.assoc s alist with Not_found -> x) - | Node(l,s,args) -> Node(l,s,List.map subst args) - | Slam(l,so,a) -> Slam(l,so,subst a) (* TODO:enlever so de alist ? *) - | x -> x - in - subst ast -*) - -let rec subst_in_ast alist = function - | CRef (Ident (loc,id)) -> - CRef (Ident (loc,(try List.assoc id alist with Not_found -> id))) - | x -> map_constr_expr_with_binders subst_in_ast List.remove_assoc alist x - -let rec subst_ast_in_ast alist = function - | CRef (Ident (_,id)) as x -> (try List.assoc id alist with Not_found -> x) - | x -> - map_constr_expr_with_binders subst_ast_in_ast List.remove_assoc alist x - -(* subst. of variables by constr *) -let real_subst_in_constr = replace_vars - -(* Coq constants *) - -let coq_constant d s = - Libnames.encode_kn - (make_dirpath (List.rev (List.map id_of_string ("Coq"::d)))) - (id_of_string s) - -let bool_sp = coq_constant ["Init"; "Datatypes"] "bool" -let coq_true = mkConstruct ((bool_sp,0),1) -let coq_false = mkConstruct ((bool_sp,0),2) - -let constant s = - let id = Constrextern.id_of_v7_string s in - Constrintern.global_reference id - -let connective_and = id_of_string "prog_bool_and" -let connective_or = id_of_string "prog_bool_or" -let connective_not = id_of_string "prog_bool_not" - -let is_connective id = - id = connective_and or id = connective_or or id = connective_not - -(* [conj i s] constructs the conjunction of two constr *) - -let conj i s = Term.applist (constant "and", [i; s]) - -(* [n_mkNamedProd v [xn,tn;...;x1,t1]] constructs the type - [(x1:t1)...(xn:tn)v] *) - -let rec n_mkNamedProd v = function - | [] -> v - | (id,ty) :: rem -> n_mkNamedProd (Term.mkNamedProd id ty v) rem - -(* [n_lambda v [xn,tn;...;x1,t1]] constructs the type [x1:t1]...[xn:tn]v *) - -let rec n_lambda v = function - | [] -> v - | (id,ty) :: rem -> n_lambda (Term.mkNamedLambda id ty v) rem - -(* [abstract env idl c] constructs [x1]...[xn]c where idl = [x1;...;xn] *) - -let abstract ids c = n_lambda c (List.rev ids) - -(* substitutivity (of kernel names, for modules management) *) - -open Ptype - -let rec type_v_knsubst s = function - | Ref v -> Ref (type_v_knsubst s v) - | Array (c, v) -> Array (subst_mps s c, type_v_knsubst s v) - | Arrow (bl, c) -> Arrow (List.map (binder_knsubst s) bl, type_c_knsubst s c) - | TypePure c -> TypePure (subst_mps s c) - -and type_c_knsubst s ((id,v),e,pl,q) = - ((id, type_v_knsubst s v), e, - List.map (fun p -> { p with p_value = subst_mps s p.p_value }) pl, - option_map (fun q -> { q with a_value = subst_mps s q.a_value }) q) - -and binder_knsubst s (id,b) = - (id, match b with BindType v -> BindType (type_v_knsubst s v) | _ -> b) diff --git a/contrib/correctness/pmisc.mli b/contrib/correctness/pmisc.mli deleted file mode 100644 index 9d96467f..00000000 --- a/contrib/correctness/pmisc.mli +++ /dev/null @@ -1,81 +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 *) -(************************************************************************) - -(* Certification of Imperative Programs / Jean-Christophe Filliâtre *) - -(* $Id: pmisc.mli 5920 2004-07-16 20:01:26Z herbelin $ *) - -open Names -open Term -open Ptype -open Topconstr - -(* Some misc. functions *) - -val reraise_with_loc : Util.loc -> ('a -> 'b) -> 'a -> 'b - -val list_of_some : 'a option -> 'a list -val difference : 'a list -> 'a list -> 'a list - -val at_id : identifier -> string -> identifier -val un_at : identifier -> identifier * string -val is_at : identifier -> bool - -val result_id : identifier -val adr_id : identifier -> identifier - -val renaming_of_ids : identifier list -> identifier list - -> (identifier * identifier) list * identifier list - -val reset_names : unit -> unit -val pre_name : name -> identifier -val post_name : name -> identifier -val inv_name : name -> identifier -val test_name : name -> identifier -val bool_name : unit -> identifier -val var_name : name -> identifier -val phi_name : unit -> identifier -val for_name : unit -> identifier -val label_name : unit -> string - -val id_of_name : name -> identifier - -(* CIC terms *) - -val isevar : constr - -val subst_in_constr : (identifier * identifier) list -> constr -> constr -val subst_in_ast : (identifier * identifier) list -> constr_expr -> constr_expr -val subst_ast_in_ast : - (identifier * constr_expr) list -> constr_expr -> constr_expr -val real_subst_in_constr : (identifier * constr) list -> constr -> constr - -val constant : string -> constr -val coq_constant : string list -> string -> kernel_name -val conj : constr -> constr -> constr - -val coq_true : constr -val coq_false : constr - -val connective_and : identifier -val connective_or : identifier -val connective_not : identifier -val is_connective : identifier -> bool - -val n_mkNamedProd : constr -> (identifier * constr) list -> constr -val n_lambda : constr -> (identifier * constr) list -> constr -val abstract : (identifier * constr) list -> constr -> constr - -val type_v_knsubst : substitution -> type_v -> type_v -val type_c_knsubst : substitution -> type_c -> type_c - -(* for debugging purposes *) - -val deb_mess : Pp.std_ppcmds -> unit -val deb_print : ('a -> Pp.std_ppcmds) -> 'a -> unit - diff --git a/contrib/correctness/pmlize.ml b/contrib/correctness/pmlize.ml deleted file mode 100644 index e812fa57..00000000 --- a/contrib/correctness/pmlize.ml +++ /dev/null @@ -1,320 +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 *) -(************************************************************************) - -(* Certification of Imperative Programs / Jean-Christophe Filliâtre *) - -(* $Id: pmlize.ml 5920 2004-07-16 20:01:26Z herbelin $ *) - -open Names -open Term -open Termast -open Pattern -open Matching - -open Pmisc -open Ptype -open Past -open Putil -open Prename -open Penv -open Peffect -open Ptyping -open Pmonad - - -let has_proof_part ren env c = - let sign = Pcicenv.trad_sign_of ren env in - let ty = Typing.type_of (Global.env_of_context sign) Evd.empty c in - Hipattern.is_matching_sigma (Reductionops.nf_betaiota ty) - -(* main part: translation of imperative programs into functional ones. - * - * [env] is the environment - * [ren] is the current renamings of variables - * [t] is the imperative program to translate, annotated with type+effects - * - * we return the translated program in type cc_term - *) - -let rec trad ren t = - let env = t.info.env in - trad_desc ren env t.info.kappa t.desc - -and trad_desc ren env ct d = - let (_,tt),eft,pt,qt = ct in - match d with - - | Expression c -> - let ids = get_reads eft in - let al = current_vars ren ids in - let c' = subst_in_constr al c in - if has_proof_part ren env c' then - CC_expr c' - else - let ty = trad_ml_type_v ren env tt in - make_tuple [ CC_expr c',ty ] qt ren env (current_date ren) - - | Variable id -> - if is_mutable_in_env env id then - invalid_arg "Mlise.trad_desc" - else if is_local env id then - CC_var id - else - CC_expr (constant (string_of_id id)) - - | Acc _ -> - failwith "Mlise.trad: pure terms are supposed to be expressions" - - | TabAcc (check, x, e1) -> - let _,ty_elem,_ = array_info ren env x in - let te1 = trad ren e1 in - let (_,ef1,p1,q1) = e1.info.kappa in - let w = get_writes ef1 in - let ren' = next ren w in - let id = id_of_string "index" in - let access = - make_raw_access ren' env (x,current_var ren' x) (mkVar id) - in - let t,ty = result_tuple ren' (current_date ren) env - (CC_expr access, ty_elem) (eft,qt) in - let t = - if check then - let h = make_pre_access ren env x (mkVar id) in - let_in_pre ty (anonymous_pre true h) t - else - t - in - make_let_in ren env te1 p1 - (current_vars ren' w,q1) (id,constant "Z") (t,ty) - - | Aff (x, e1) -> - let tx = trad_type_in_env ren env x in - let te1 = trad ren e1 in - let (_,ef1,p1,q1) = e1.info.kappa in - let w1 = get_writes ef1 in - let ren' = next ren (x::w1) in - let t_ty = result_tuple ren' (current_date ren) env - (CC_expr (constant "tt"), constant "unit") (eft,qt) - in - make_let_in ren env te1 p1 - (current_vars ren' w1,q1) (current_var ren' x,tx) t_ty - - | TabAff (check, x, e1, e2) -> - let _,ty_elem,ty_array = array_info ren env x in - let te1 = trad ren e1 in - let (_,ef1,p1,q1) = e1.info.kappa in - let w1 = get_writes ef1 in - let ren' = next ren w1 in - let te2 = trad ren' e2 in - let (_,ef2,p2,q2) = e2.info.kappa in - let w2 = get_writes ef2 in - let ren'' = next ren' w2 in - let id1 = id_of_string "index" in - let id2 = id_of_string "v" in - let ren''' = next ren'' [x] in - let t,ty = result_tuple ren''' (current_date ren) env - (CC_expr (constant "tt"), constant "unit") (eft,qt) in - let store = make_raw_store ren'' env (x,current_var ren'' x) (mkVar id1) - (mkVar id2) in - let t = make_let_in ren'' env (CC_expr store) [] ([],None) - (current_var ren''' x,ty_array) (t,ty) in - let t = make_let_in ren' env te2 p2 - (current_vars ren'' w2,q2) (id2,ty_elem) (t,ty) in - let t = - if check then - let h = make_pre_access ren' env x (mkVar id1) in - let_in_pre ty (anonymous_pre true h) t - else - t - in - make_let_in ren env te1 p1 - (current_vars ren' w1,q1) (id1,constant "Z") (t,ty) - - | Seq bl -> - let before = current_date ren in - let finish ren = function - Some (id,ty) -> - result_tuple ren before env (CC_var id, ty) (eft,qt) - | None -> - failwith "a block should contain at least one statement" - in - let bl = trad_block ren env bl in - make_block ren env finish bl - - | If (b, e1, e2) -> - let tb = trad ren b in - let _,efb,_,_ = b.info.kappa in - let ren' = next ren (get_writes efb) in - let te1 = trad ren' e1 in - let te2 = trad ren' e2 in - make_if ren env (tb,b.info.kappa) ren' (te1,e1.info.kappa) - (te2,e2.info.kappa) ct - - (* Translation of the while. *) - - | While (b, inv, var, bl) -> - let ren' = next ren (get_writes eft) in - let tb = trad ren' b in - let tbl = trad_block ren' env bl in - let var' = typed_var ren env var in - make_while ren env var' (tb,b.info.kappa) tbl (inv,ct) - - | Lam (bl, e) -> - let bl' = trad_binders ren env bl in - let env' = traverse_binders env bl in - let ren' = initial_renaming env' in - let te = trans ren' e in - CC_lam (bl', te) - - | SApp ([Variable id; Expression q1; Expression q2], [e1; e2]) - when id = connective_and or id = connective_or -> - let c = constant (string_of_id id) in - let te1 = trad ren e1 - and te2 = trad ren e2 in - let q1' = apply_post ren env (current_date ren) (anonymous q1) - and q2' = apply_post ren env (current_date ren) (anonymous q2) in - CC_app (CC_expr c, [CC_expr q1'.a_value; CC_expr q2'.a_value; te1; te2]) - - | SApp ([Variable id; Expression q], [e]) when id = connective_not -> - let c = constant (string_of_id id) in - let te = trad ren e in - let q' = apply_post ren env (current_date ren) (anonymous q) in - CC_app (CC_expr c, [CC_expr q'.a_value; te]) - - | SApp _ -> - invalid_arg "mlise.trad (SApp)" - - | Apply (f, args) -> - let trad_arg (ren,args) = function - | Term a -> - let ((_,tya),efa,_,_) as ca = a.info.kappa in - let ta = trad ren a in - let w = get_writes efa in - let ren' = next ren w in - ren', ta::args - | Refarg _ -> - ren, args - | Type v -> - let c = trad_ml_type_v ren env v in - ren, (CC_expr c)::args - in - let ren',targs = List.fold_left trad_arg (ren,[]) args in - let tf = trad ren' f in - let cf = f.info.kappa in - let c,(s,_,_),capp = effect_app ren env f args in - let tc_args = - List.combine - (List.rev targs) - (Util.map_succeed - (function - | Term x -> x.info.kappa - | Refarg _ -> failwith "caught" - | Type _ -> - (result_id,TypePure mkSet),Peffect.bottom,[],None) - args) - in - make_app env ren tc_args ren' (tf,cf) (c,s,capp) ct - - | LetRef (x, e1, e2) -> - let (_,v1),ef1,p1,q1 = e1.info.kappa in - let te1 = trad ren e1 in - let tv1 = trad_ml_type_v ren env v1 in - let env' = add (x,Ref v1) env in - let ren' = next ren [x] in - let (_,v2),ef2,p2,q2 = e2.info.kappa in - let tv2 = trad_ml_type_v ren' env' v2 in - let te2 = trad ren' e2 in - let ren'' = next ren' (get_writes ef2) in - let t,ty = result_tuple ren'' (current_date ren) env - (CC_var result_id, tv2) (eft,qt) in - let t = make_let_in ren' env' te2 p2 - (current_vars ren'' (get_writes ef2),q2) - (result_id,tv2) (t,ty) in - let t = make_let_in ren env te1 p1 - (current_vars ren' (get_writes ef1),q1) (x,tv1) (t,ty) - in - t - - | Let (x, e1, e2) -> - let (_,v1),ef1,p1,q1 = e1.info.kappa in - let te1 = trad ren e1 in - let tv1 = trad_ml_type_v ren env v1 in - let env' = add (x,v1) env in - let ren' = next ren (get_writes ef1) in - let (_,v2),ef2,p2,q2 = e2.info.kappa in - let tv2 = trad_ml_type_v ren' env' v2 in - let te2 = trad ren' e2 in - let ren'' = next ren' (get_writes ef2) in - let t,ty = result_tuple ren'' (current_date ren) env - (CC_var result_id, tv2) (eft,qt) in - let t = make_let_in ren' env' te2 p2 - (current_vars ren'' (get_writes ef2),q2) - (result_id,tv2) (t,ty) in - let t = make_let_in ren env te1 p1 - (current_vars ren' (get_writes ef1),q1) (x,tv1) (t,ty) - in - t - - | LetRec (f,bl,v,var,e) -> - let (_,ef,_,_) as c = - match tt with Arrow(_,c) -> c | _ -> assert false in - let bl' = trad_binders ren env bl in - let env' = traverse_binders env bl in - let ren' = initial_renaming env' in - let (phi0,var') = find_recursion f e.info.env in - let te = trad ren' e in - let t = make_letrec ren' env' (phi0,var') f bl' (te,e.info.kappa) c in - CC_lam (bl', t) - - | PPoint (s,d) -> - let ren' = push_date ren s in - trad_desc ren' env ct d - - | Debug _ -> failwith "Mlise.trad: Debug: not implemented" - - -and trad_binders ren env = function - | [] -> - [] - | (_,BindType (Ref _ | Array _))::bl -> - trad_binders ren env bl - | (id,BindType v)::bl -> - let tt = trad_ml_type_v ren env v in - (id, CC_typed_binder tt) :: (trad_binders ren env bl) - | (id,BindSet)::bl -> - (id, CC_typed_binder mkSet) :: (trad_binders ren env bl) - | (_,Untyped)::_ -> invalid_arg "trad_binders" - - -and trad_block ren env = function - | [] -> - [] - | (Assert c)::block -> - (Assert c)::(trad_block ren env block) - | (Label s)::block -> - let ren' = push_date ren s in - (Label s)::(trad_block ren' env block) - | (Statement e)::block -> - let te = trad ren e in - let _,efe,_,_ = e.info.kappa in - let w = get_writes efe in - let ren' = next ren w in - (Statement (te,e.info.kappa))::(trad_block ren' env block) - - -and trans ren e = - let env = e.info.env in - let _,ef,p,_ = e.info.kappa in - let ty = trad_ml_type_c ren env e.info.kappa in - let ids = get_reads ef in - let al = current_vars ren ids in - let c = trad ren e in - let c = abs_pre ren env (c,ty) p in - let bl = binding_of_alist ren env al in - make_abs (List.rev bl) c - diff --git a/contrib/correctness/pmlize.mli b/contrib/correctness/pmlize.mli deleted file mode 100644 index 1f8936f0..00000000 --- a/contrib/correctness/pmlize.mli +++ /dev/null @@ -1,20 +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 *) -(************************************************************************) - -(* Certification of Imperative Programs / Jean-Christophe Filliâtre *) - -(* $Id: pmlize.mli 5920 2004-07-16 20:01:26Z herbelin $ *) - -open Past -open Penv -open Names - -(* translation of imperative programs into intermediate functional programs *) - -val trans : Prename.t -> typed_program -> cc_term - diff --git a/contrib/correctness/pmonad.ml b/contrib/correctness/pmonad.ml deleted file mode 100644 index 8f1b5946..00000000 --- a/contrib/correctness/pmonad.ml +++ /dev/null @@ -1,665 +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 *) -(************************************************************************) - -(* Certification of Imperative Programs / Jean-Christophe Filliâtre *) - -(* $Id: pmonad.ml 8752 2006-04-27 19:37:33Z herbelin $ *) - -open Util -open Names -open Term -open Termast - -open Pmisc -open Putil -open Ptype -open Past -open Prename -open Penv -open Pcic -open Peffect - - -(* [product ren [y1,z1;...;yk,zk] q] constructs - * the (possibly dependent) tuple type - * - * z1 x ... x zk if no post-condition - * or \exists. y1:z1. ... yk:zk. (Q x1 ... xn) otherwise - * - * where the xi are given by the renaming [ren]. - *) - -let product_name = function - | 2 -> "prod" - | n -> check_product_n n; Printf.sprintf "tuple_%d" n - -let dep_product_name = function - | 1 -> "sig" - | n -> check_dep_product_n n; Printf.sprintf "sig_%d" n - -let product ren env before lo = function - | None -> (* non dependent case *) - begin match lo with - | [_,v] -> v - | _ -> - let s = product_name (List.length lo) in - Term.applist (constant s, List.map snd lo) - end - | Some q -> (* dependent case *) - let s = dep_product_name (List.length lo) in - let a' = apply_post ren env before q in - Term.applist (constant s, (List.map snd lo) @ [a'.a_value]) - -(* [arrow ren v pl] abstracts the term v over the pre-condition if any - * i.e. computes - * - * (P1 x1 ... xn) -> ... -> (Pk x1 ... xn) -> v - * - * where the xi are given by the renaming [ren]. - *) - -let arrow ren env v pl = - List.fold_left - (fun t p -> - if p.p_assert then t else Term.mkArrow (apply_pre ren env p).p_value t) - v pl - -(* [abstract_post ren env (e,q) (res,v)] abstract a post-condition q - * over the write-variables of e *) - -let rec abstract_post ren env (e,q) = - let after_id id = id_of_string ((string_of_id id) ^ "'") in - let (_,go) = Peffect.get_repr e in - let al = List.map (fun id -> (id,after_id id)) go in - let q = option_map (named_app (subst_in_constr al)) q in - let tgo = List.map (fun (id,aid) -> (aid, trad_type_in_env ren env id)) al in - option_map (named_app (abstract tgo)) q - -(* Translation of effects types in cic types. - * - * [trad_ml_type_v] and [trad_ml_type_c] translate types with effects - * into cic types. - *) - -and prod ren env g = - List.map - (fun id -> (current_var ren id, trad_type_in_env ren env id)) - g - -and input ren env e = - let i,_ = Peffect.get_repr e in - prod ren env i - -and output ren env ((id,v),e) = - let tv = trad_ml_type_v ren env v in - let _,o = Peffect.get_repr e in - (prod ren env o) @ [id,tv] - -and input_output ren env c = - let ((res,v),e,_,_) = c in - input ren env e, output ren env ((res,v),e) - -(* The function t -> \barre{t} on V and C. *) - -and trad_ml_type_c ren env c = - let ((res,v),e,p,q) = c in - let q = abstract_post ren env (e,q) in - let lo = output ren env ((res,v),e) in - let ty = product ren env (current_date ren) lo q in - let ty = arrow ren env ty p in - let li = input ren env e in - n_mkNamedProd ty li - -and trad_ml_type_v ren env = function - - | Ref _ | Array _ -> invalid_arg "Monad.trad_ml_type_v" - - | Arrow (bl, c) -> - let bl',ren',env' = - List.fold_left - (fun (bl,ren,env) b -> match b with - | (id,BindType ((Ref _ | Array _) as v)) -> - let env' = add (id,v) env in - let ren' = initial_renaming env' in - (bl,ren',env') - | (id,BindType v) -> - let tt = trad_ml_type_v ren env v in - let env' = add (id,v) env in - let ren' = initial_renaming env' in - (id,tt)::bl,ren',env' - | (id, BindSet) -> - (id,mkSet) :: bl,ren,env - | _ -> failwith "Monad: trad_ml_type_v: not yet implemented" - ) - ([],ren,env) bl - in - n_mkNamedProd (trad_ml_type_c ren' env' c) bl' - - | TypePure c -> - (apply_pre ren env (anonymous_pre false c)).p_value - -and trad_imp_type ren env = function - | Ref v -> trad_ml_type_v ren env v - | Array (c,v) -> Term.applist (constant "array", - [c; trad_ml_type_v ren env v]) - | _ -> invalid_arg "Monad.trad_imp_type" - -and trad_type_in_env ren env id = - let v = type_in_env env id in trad_imp_type ren env v - - - -(* bindings *) - -let binding_of_alist ren env al = - List.map - (fun (id,id') -> (id', CC_typed_binder (trad_type_in_env ren env id))) - al - - -(* [make_abs bl t p] abstracts t w.r.t binding list bl., that is - * [x1:t1]...[xn:tn]t. Returns t if the binding is empty. *) - -let make_abs bl t = match bl with - | [] -> t - | _ -> CC_lam (bl, t) - - -(* [result_tuple ren before env (res,v) (ef,q)] constructs the tuple - * - * (y1,...,yn,res,?::(q/ren y1 ... yn res)) - * - * where the yi are the values of the output of ef. - * if there is no yi and no post-condition, it is simplified in res itself. - *) - -let simple_constr_of_prog = function - | CC_expr c -> c - | CC_var id -> mkVar id - | _ -> assert false - -let make_tuple l q ren env before = match l with - | [e,_] when q = None -> - e - | _ -> - let tl = List.map snd l in - let dep,h,th = match q with - | None -> false,[],[] - | Some c -> - let args = List.map (fun (e,_) -> simple_constr_of_prog e) l in - let c = apply_post ren env before c in - true, - [ CC_hole (Term.applist (c.a_value, args)) ], (* hole *) - [ c.a_value ] (* type of the hole *) - in - CC_tuple (dep, tl @ th, (List.map fst l) @ h) - -let result_tuple ren before env (res,v) (ef,q) = - let ids = get_writes ef in - let lo = - (List.map (fun id -> - let id' = current_var ren id in - CC_var id', trad_type_in_env ren env id) ids) - @ [res,v] - in - let q = abstract_post ren env (ef,q) in - make_tuple lo q ren env before, - product ren env before lo q - - -(* [make_let_in ren env fe p (vo,q) (res,v) t] constructs the term - - [ let h1 = ?:P1 in ... let hn = ?:Pm in ] - let y1,y2,...,yn, res [,q] = fe in - t - - vo=[_,y1;...;_,ym] are list of renamings. - v is the type of res - *) - -let let_in_pre ty p t = - let h = p.p_value in - CC_letin (false, ty, [pre_name p.p_name,CC_typed_binder h], CC_hole h, t) - -let multiple_let_in_pre ty hl t = - List.fold_left (fun t h -> let_in_pre ty h t) t hl - -let make_let_in ren env fe p (vo,q) (res,tyres) (t,ty) = - let b = [res, CC_typed_binder tyres] in - let b',dep = match q with - | None -> [],false - | Some q -> [post_name q.a_name, CC_untyped_binder],true - in - let bl = (binding_of_alist ren env vo) @ b @ b' in - let tyapp = - let n = succ (List.length vo) in - let name = match q with None -> product_name n | _ -> dep_product_name n in - constant name - in - let t = CC_letin (dep, ty, bl, fe, t) in - multiple_let_in_pre ty (List.map (apply_pre ren env) p) t - - -(* [abs_pre ren env (t,ty) pl] abstracts a term t with respect to the - * list of pre-conditions [pl]. Some of them are real pre-conditions - * and others are assertions, according to the boolean field p_assert, - * so we construct the term - * [h1:P1]...[hn:Pn]let h'1 = ?:P'1 in ... let H'm = ?:P'm in t - *) - -let abs_pre ren env (t,ty) pl = - List.fold_left - (fun t p -> - if p.p_assert then - let_in_pre ty (apply_pre ren env p) t - else - let h = pre_name p.p_name in - CC_lam ([h,CC_typed_binder (apply_pre ren env p).p_value],t)) - t pl - - -(* [make_block ren env finish bl] builds the translation of a block - * finish is the function that is applied to the result at the end of the - * block. *) - -let make_block ren env finish bl = - let rec rec_block ren result = function - | [] -> - finish ren result - | (Assert c) :: block -> - let t,ty = rec_block ren result block in - let c = apply_assert ren env c in - let p = { p_assert = true; p_name = c.a_name; p_value = c.a_value } in - let_in_pre ty p t, ty - | (Label s) :: block -> - let ren' = push_date ren s in - rec_block ren' result block - | (Statement (te,info)) :: block -> - let (_,tye),efe,pe,qe = info in - let w = get_writes efe in - let ren' = next ren w in - let id = result_id in - let tye = trad_ml_type_v ren env tye in - let t = rec_block ren' (Some (id,tye)) block in - make_let_in ren env te pe (current_vars ren' w,qe) (id,tye) t, - snd t - in - let t,_ = rec_block ren None bl in - t - - -(* [make_app env ren args ren' (tf,cf) (cb,s,capp) c] - * constructs the application of [tf] to [args]. - * capp is the effect of application, after substitution (s) and cb before - *) - -let eq ty e1 e2 = - Term.applist (constant "eq", [ty; e1; e2]) - -let lt r e1 e2 = - Term.applist (r, [e1; e2]) - -let is_recursive env = function - | CC_var x -> - (try let _ = find_recursion x env in true with Not_found -> false) - | _ -> false - -let if_recursion env f = function - | CC_var x -> - (try let v = find_recursion x env in (f v x) with Not_found -> []) - | _ -> [] - -let dec_phi ren env s svi = - if_recursion env - (fun (phi0,(cphi,r,_)) f -> - let phi = subst_in_constr svi (subst_in_constr s cphi) in - let phi = (apply_pre ren env (anonymous_pre true phi)).p_value in - [CC_expr phi; CC_hole (lt r phi (mkVar phi0))]) - -let eq_phi ren env s svi = - if_recursion env - (fun (phi0,(cphi,_,a)) f -> - let phi = subst_in_constr svi (subst_in_constr s cphi) in - let phi = (apply_pre ren env (anonymous_pre true phi)).p_value in - [CC_hole (eq a phi phi)]) - -let is_ref_binder = function - | (_,BindType (Ref _ | Array _)) -> true - | _ -> false - -let make_app env ren args ren' (tf,cf) ((bl,cb),s,capp) c = - let ((_,tvf),ef,pf,qf) = cf in - let (_,eapp,papp,qapp) = capp in - let ((_,v),e,p,q) = c in - let bl = List.filter (fun b -> not (is_ref_binder b)) bl in - let recur = is_recursive env tf in - let before = current_date ren in - let ren'' = next ren' (get_writes ef) in - let ren''' = next ren'' (get_writes eapp) in - let res = result_id in - let vi,svi = - let ids = List.map fst bl in - let s = fresh (avoid ren ids) ids in - List.map snd s, s - in - let tyres = subst_in_constr svi (trad_ml_type_v ren env v) in - let t,ty = result_tuple ren''' before env (CC_var res, tyres) (e,q) in - let res_f = id_of_string "vf" in - let inf,outf = - let i,o = let _,e,_,_ = cb in get_reads e, get_writes e in - let apply_s = List.map (fun id -> try List.assoc id s with _ -> id) in - apply_s i, apply_s o - in - let fe = - let xi = List.rev (List.map snd (current_vars ren'' inf)) in - let holes = List.map (fun x -> (apply_pre ren'' env x).p_value) - (List.map (pre_app (subst_in_constr svi)) papp) in - CC_app ((if recur then tf else CC_var res_f), - (dec_phi ren'' env s svi tf) - @(List.map (fun id -> CC_var id) (vi @ xi)) - @(eq_phi ren'' env s svi tf) - @(List.map (fun c -> CC_hole c) holes)) - in - let qapp' = option_map (named_app (subst_in_constr svi)) qapp in - let t = - make_let_in ren'' env fe [] (current_vars ren''' outf,qapp') - (res,tyres) (t,ty) - in - let t = - if recur then - t - else - make_let_in ren' env tf pf - (current_vars ren'' (get_writes ef),qf) - (res_f,trad_ml_type_v ren env tvf) (t,ty) - in - let rec eval_args ren = function - | [] -> t - | (vx,(ta,((_,tva),ea,pa,qa)))::args -> - let w = get_writes ea in - let ren' = next ren w in - let t' = eval_args ren' args in - make_let_in ren env ta pa (current_vars ren' (get_writes ea),qa) - (vx,trad_ml_type_v ren env tva) (t',ty) - in - eval_args ren (List.combine vi args) - - -(* [make_if ren env (tb,cb) ren' (t1,c1) (t2,c2)] - * constructs the term corresponding to a if expression, i.e - * - * [p] let o1, b [,q1] = m1 [?::p1] in - * Cases b of - * R => let o2, v2 [,q2] = t1 [?::p2] in - * (proj (o1,o2)), v2 [,?::q] - * | S => let o2, v2 [,q2] = t2 [?::p2] in - * (proj (o1,o2)), v2 [,?::q] - *) - -let make_if_case ren env ty (b,qb) (br1,br2) = - let id_b,ty',ty1,ty2 = match qb with - | Some q -> - let q = apply_post ren env (current_date ren) q in - let (name,t1,t2) = Term.destLambda q.a_value in - q.a_name, - Term.mkLambda (name, t1, mkArrow t2 ty), - Term.mkApp (q.a_value, [| coq_true |]), - Term.mkApp (q.a_value, [| coq_false |]) - | None -> assert false - in - let n = test_name Anonymous in - CC_app (CC_case (ty', b, [CC_lam ([n,CC_typed_binder ty1], br1); - CC_lam ([n,CC_typed_binder ty2], br2)]), - [CC_var (post_name id_b)]) - -let make_if ren env (tb,cb) ren' (t1,c1) (t2,c2) c = - let ((_,tvb),eb,pb,qb) = cb in - let ((_,tv1),e1,p1,q1) = c1 in - let ((_,tv2),e2,p2,q2) = c2 in - let ((_,t),e,p,q) = c in - - let wb = get_writes eb in - let resb = id_of_string "resultb" in - let res = result_id in - let tyb = trad_ml_type_v ren' env tvb in - let tt = trad_ml_type_v ren env t in - - (* une branche de if *) - let branch (tv_br,e_br,p_br,q_br) f_br = - let w_br = get_writes e_br in - let ren'' = next ren' w_br in - let t,ty = result_tuple ren'' (current_date ren') env - (CC_var res,tt) (e,q) in - make_let_in ren' env f_br p_br (current_vars ren'' w_br,q_br) - (res,tt) (t,ty), - ty - in - let t1,ty1 = branch c1 t1 in - let t2,ty2 = branch c2 t2 in - let ty = ty1 in - let qb = force_bool_name qb in - let t = make_if_case ren env ty (CC_var resb,qb) (t1,t2) in - make_let_in ren env tb pb (current_vars ren' wb,qb) (resb,tyb) (t,ty) - - -(* [make_while ren env (cphi,r,a) (tb,cb) (te,ce) c] - * constructs the term corresponding to the while, i.e. - * - * [h:(I x)](well_founded_induction - * A R ?::(well_founded A R) - * [Phi:A] (x) Phi=phi(x)->(I x)-> \exists x'.res.(I x')/\(S x') - * [Phi_0:A][w:(Phi:A)(Phi<Phi_0)-> ...] - * [x][eq:Phi_0=phi(x)][h:(I x)] - * Cases (b x) of - * (left HH) => (x,?::(IS x)) - * | (right HH) => let x1,_,_ = (e x ?) in - * (w phi(x1) ? x1 ? ?) - * phi(x) x ? ?) - *) - -let id_phi = id_of_string "phi" -let id_phi0 = id_of_string "phi0" - -let make_body_while ren env phi_of a r id_phi0 id_w (tb,cb) tbl (i,c) = - let ((_,tvb),eb,pb,qb) = cb in - let (_,ef,_,is) = c in - - let ren' = next ren (get_writes ef) in - let before = current_date ren in - - let ty = - let is = abstract_post ren' env (ef,is) in - let _,lo = input_output ren env c in - product ren env before lo is - in - let resb = id_of_string "resultb" in - let tyb = trad_ml_type_v ren' env tvb in - let wb = get_writes eb in - - (* première branche: le test est vrai => e;w *) - let t1 = - make_block ren' env - (fun ren'' result -> match result with - | Some (id,_) -> - let v = List.rev (current_vars ren'' (get_writes ef)) in - CC_app (CC_var id_w, - [CC_expr (phi_of ren''); - CC_hole (lt r (phi_of ren'') (mkVar id_phi0))] - @(List.map (fun (_,id) -> CC_var id) v) - @(CC_hole (eq a (phi_of ren'') (phi_of ren''))) - ::(match i with - | None -> [] - | Some c -> - [CC_hole (apply_assert ren'' env c).a_value])), - ty - | None -> failwith "a block should contain at least one statement") - tbl - in - - (* deuxième branche: le test est faux => on sort de la boucle *) - let t2,_ = - result_tuple ren' before env - (CC_expr (constant "tt"),constant "unit") (ef,is) - in - - let b_al = current_vars ren' (get_reads eb) in - let qb = force_bool_name qb in - let t = make_if_case ren' env ty (CC_var resb,qb) (t1,t2) in - let t = - make_let_in ren' env tb pb (current_vars ren' wb,qb) (resb,tyb) (t,ty) - in - let t = - let pl = List.map (pre_of_assert false) (list_of_some i) in - abs_pre ren' env (t,ty) pl - in - let t = - CC_lam ([var_name Anonymous, - CC_typed_binder (eq a (mkVar id_phi0) (phi_of ren'))],t) - in - let bl = binding_of_alist ren env (current_vars ren' (get_writes ef)) in - make_abs (List.rev bl) t - - -let make_while ren env (cphi,r,a) (tb,cb) tbl (i,c) = - let (_,ef,_,is) = c in - let phi_of ren = (apply_pre ren env (anonymous_pre true cphi)).p_value in - let wf_a_r = Term.applist (constant "well_founded", [a; r]) in - - let before = current_date ren in - let ren' = next ren (get_writes ef) in - let al = current_vars ren' (get_writes ef) in - let v = - let _,lo = input_output ren env c in - let is = abstract_post ren' env (ef,is) in - match i with - | None -> product ren' env before lo is - | Some ci -> - Term.mkArrow (apply_assert ren' env ci).a_value - (product ren' env before lo is) - in - let v = Term.mkArrow (eq a (mkVar id_phi) (phi_of ren')) v in - let v = - n_mkNamedProd v - (List.map (fun (id,id') -> (id',trad_type_in_env ren env id)) al) - in - let tw = - Term.mkNamedProd id_phi a - (Term.mkArrow (lt r (mkVar id_phi) (mkVar id_phi0)) v) - in - let id_w = id_of_string "loop" in - let vars = List.rev (current_vars ren (get_writes ef)) in - let body = - make_body_while ren env phi_of a r id_phi0 id_w (tb,cb) tbl (i,c) - in - CC_app (CC_expr (constant "well_founded_induction"), - [CC_expr a; CC_expr r; - CC_hole wf_a_r; - CC_expr (Term.mkNamedLambda id_phi a v); - CC_lam ([id_phi0, CC_typed_binder a; - id_w, CC_typed_binder tw], - body); - CC_expr (phi_of ren)] - @(List.map (fun (_,id) -> CC_var id) vars) - @(CC_hole (eq a (phi_of ren) (phi_of ren))) - ::(match i with - | None -> [] - | Some c -> [CC_hole (apply_assert ren env c).a_value])) - - -(* [make_letrec ren env (phi0,(cphi,r,a)) bl (te,ce) c] - * constructs the term corresponding to the let rec i.e. - * - * [x][h:P(x)](well_founded_induction - * A R ?::(well_founded A R) - * [Phi:A] (bl) (x) Phi=phi(x)->(P x)-> \exists x'.res.(Q x x') - * [Phi_0:A][w:(Phi:A)(Phi<Phi_0)-> ...] - * [bl][x][eq:Phi_0=phi(x)][h:(P x)]te - * phi(x) bl x ? ?) - *) - -let make_letrec ren env (id_phi0,(cphi,r,a)) idf bl (te,ce) c = - let (_,ef,p,q) = c in - let phi_of ren = (apply_pre ren env (anonymous_pre true cphi)).p_value in - let wf_a_r = Term.applist (constant "well_founded", [a; r]) in - - let before = current_date ren in - let al = current_vars ren (get_reads ef) in - let v = - let _,lo = input_output ren env c in - let q = abstract_post ren env (ef,q) in - arrow ren env (product ren env (current_date ren) lo q) p - in - let v = Term.mkArrow (eq a (mkVar id_phi) (phi_of ren)) v in - let v = - n_mkNamedProd v - (List.map (fun (id,id') -> (id',trad_type_in_env ren env id)) al) - in - let v = - n_mkNamedProd v - (List.map (function (id,CC_typed_binder c) -> (id,c) - | _ -> assert false) (List.rev bl)) - in - let tw = - Term.mkNamedProd id_phi a - (Term.mkArrow (lt r (mkVar id_phi) (mkVar id_phi0)) v) - in - let vars = List.rev (current_vars ren (get_reads ef)) in - let body = - let al = current_vars ren (get_reads ef) in - let bod = abs_pre ren env (te,v) p in - let bod = CC_lam ([var_name Anonymous, - CC_typed_binder (eq a (mkVar id_phi0) (phi_of ren))], - bod) - in - let bl' = binding_of_alist ren env al in - make_abs (bl@(List.rev bl')) bod - in - let t = - CC_app (CC_expr (constant "well_founded_induction"), - [CC_expr a; CC_expr r; - CC_hole wf_a_r; - CC_expr (Term.mkNamedLambda id_phi a v); - CC_lam ([id_phi0, CC_typed_binder a; - idf, CC_typed_binder tw], - body); - CC_expr (phi_of ren)] - @(List.map (fun (id,_) -> CC_var id) bl) - @(List.map (fun (_,id) -> CC_var id) vars) - @[CC_hole (eq a (phi_of ren) (phi_of ren))] - ) - in - (* on abstrait juste par rapport aux variables de ef *) - let al = current_vars ren (get_reads ef) in - let bl = binding_of_alist ren env al in - make_abs (List.rev bl) t - - -(* [make_access env id c] Access in array id. - * - * Constructs [t:(array s T)](access_g s T t c ?::(lt c s)). - *) - -let array_info ren env id = - let ty = type_in_env env id in - let size,v = dearray_type ty in - let ty_elem = trad_ml_type_v ren env v in - let ty_array = trad_imp_type ren env ty in - size,ty_elem,ty_array - -let make_raw_access ren env (id,id') c = - let size,ty_elem,_ = array_info ren env id in - Term.applist (constant "access", [size; ty_elem; mkVar id'; c]) - -let make_pre_access ren env id c = - let size,_,_ = array_info ren env id in - conj (lt (constant "Zle") (constant "ZERO") c) - (lt (constant "Zlt") c size) - -let make_raw_store ren env (id,id') c1 c2 = - let size,ty_elem,_ = array_info ren env id in - Term.applist (constant "store", [size; ty_elem; mkVar id'; c1; c2]) diff --git a/contrib/correctness/pmonad.mli b/contrib/correctness/pmonad.mli deleted file mode 100644 index a46a040e..00000000 --- a/contrib/correctness/pmonad.mli +++ /dev/null @@ -1,106 +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 *) -(************************************************************************) - -(* Certification of Imperative Programs / Jean-Christophe Filliâtre *) - -(* $Id: pmonad.mli 5920 2004-07-16 20:01:26Z herbelin $ *) - -open Names -open Term - -open Ptype -open Past -open Penv - -(* Main part of the translation of imperative programs into functional ones - * (with mlise.ml) *) - -(* Here we translate the specification into a CIC specification *) - -val trad_ml_type_v : Prename.t -> local_env -> type_v -> constr -val trad_ml_type_c : Prename.t -> local_env -> type_c -> constr -val trad_imp_type : Prename.t -> local_env -> type_v -> constr -val trad_type_in_env : Prename.t -> local_env -> identifier -> constr - -val binding_of_alist : Prename.t -> local_env - -> (identifier * identifier) list - -> cc_binder list -val make_abs : cc_binder list -> cc_term -> cc_term -val abs_pre : Prename.t -> local_env -> cc_term * constr -> - constr precondition list -> cc_term - -(* The following functions translate the main constructions *) - -val make_tuple : (cc_term * cc_type) list -> predicate option - -> Prename.t -> local_env -> string - -> cc_term - -val result_tuple : Prename.t -> string -> local_env - -> (cc_term * constr) -> (Peffect.t * predicate option) - -> cc_term * constr - -val let_in_pre : constr -> constr precondition -> cc_term -> cc_term - -val make_let_in : Prename.t -> local_env -> cc_term - -> constr precondition list - -> ((identifier * identifier) list * predicate option) - -> identifier * constr - -> cc_term * constr -> cc_term - -val make_block : Prename.t -> local_env - -> (Prename.t -> (identifier * constr) option -> cc_term * constr) - -> (cc_term * type_c, constr) block - -> cc_term - -val make_app : local_env - -> Prename.t -> (cc_term * type_c) list - -> Prename.t -> cc_term * type_c - -> ((type_v binder list) * type_c) - * ((identifier*identifier) list) - * type_c - -> type_c - -> cc_term - -val make_if : Prename.t -> local_env - -> cc_term * type_c - -> Prename.t - -> cc_term * type_c - -> cc_term * type_c - -> type_c - -> cc_term - -val make_while : Prename.t -> local_env - -> (constr * constr * constr) (* typed variant *) - -> cc_term * type_c - -> (cc_term * type_c, constr) block - -> constr assertion option * type_c - -> cc_term - -val make_letrec : Prename.t -> local_env - -> (identifier * (constr * constr * constr)) (* typed variant *) - -> identifier (* the name of the function *) - -> (cc_binder list) - -> (cc_term * type_c) - -> type_c - -> cc_term - -(* Functions to translate array operations *) - -val array_info : - Prename.t -> local_env -> identifier -> constr * constr * constr - -val make_raw_access : - Prename.t -> local_env -> identifier * identifier -> constr -> constr - -val make_raw_store : - Prename.t -> local_env -> identifier * identifier - -> constr -> constr -> constr - -val make_pre_access : - Prename.t -> local_env -> identifier -> constr -> constr - diff --git a/contrib/correctness/pred.ml b/contrib/correctness/pred.ml deleted file mode 100644 index 669727fc..00000000 --- a/contrib/correctness/pred.ml +++ /dev/null @@ -1,115 +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 *) -(************************************************************************) - -(* Certification of Imperative Programs / Jean-Christophe Filliâtre *) - -(* $Id: pred.ml 5920 2004-07-16 20:01:26Z herbelin $ *) - -open Pp -open Past -open Pmisc - -let rec cc_subst subst = function - | CC_var id as c -> - (try CC_expr (List.assoc id subst) with Not_found -> c) - | CC_letin (b,ty,bl,c1,c2) -> - CC_letin (b, real_subst_in_constr subst ty, cc_subst_binders subst bl, - cc_subst subst c1, cc_subst (cc_cross_binders subst bl) c2) - | CC_lam (bl, c) -> - CC_lam (cc_subst_binders subst bl, - cc_subst (cc_cross_binders subst bl) c) - | CC_app (c, cl) -> - CC_app (cc_subst subst c, List.map (cc_subst subst) cl) - | CC_tuple (b, tl, cl) -> - CC_tuple (b, List.map (real_subst_in_constr subst) tl, - List.map (cc_subst subst) cl) - | CC_case (ty, c, cl) -> - CC_case (real_subst_in_constr subst ty, cc_subst subst c, - List.map (cc_subst subst) cl) - | CC_expr c -> - CC_expr (real_subst_in_constr subst c) - | CC_hole ty -> - CC_hole (real_subst_in_constr subst ty) - -and cc_subst_binders subst = List.map (cc_subst_binder subst) - -and cc_subst_binder subst = function - | id,CC_typed_binder c -> id,CC_typed_binder (real_subst_in_constr subst c) - | b -> b - -and cc_cross_binders subst = function - | [] -> subst - | (id,_) :: bl -> cc_cross_binders (List.remove_assoc id subst) bl - -(* here we only perform eta-reductions on programs to eliminate - * redexes of the kind - * - * let (x1,...,xn) = e in (x1,...,xn) --> e - * - *) - -let is_eta_redex bl al = - try - List.for_all2 - (fun (id,_) t -> match t with CC_var id' -> id=id' | _ -> false) - bl al - with - Invalid_argument("List.for_all2") -> false - -let rec red = function - | CC_letin (_, _, [id,_], CC_expr c1, e2) -> - red (cc_subst [id,c1] e2) - | CC_letin (dep, ty, bl, e1, e2) -> - begin match red e2 with - | CC_tuple (false,tl,al) -> - if is_eta_redex bl al then - red e1 - else - CC_letin (dep, ty, bl, red e1, - CC_tuple (false,tl,List.map red al)) - | e -> CC_letin (dep, ty, bl, red e1, e) - end - | CC_lam (bl, e) -> - CC_lam (bl, red e) - | CC_app (e, al) -> - CC_app (red e, List.map red al) - | CC_case (ty, e1, el) -> - CC_case (ty, red e1, List.map red el) - | CC_tuple (dep, tl, al) -> - CC_tuple (dep, tl, List.map red al) - | e -> e - - -(* How to reduce uncomplete proof terms when they have become constr *) - -open Term -open Reductionops - -(* Il ne faut pas reduire de redexe (beta/iota) qui impliquerait - * la substitution d'une métavariable. - * - * On commence par rendre toutes les applications binaire (strong bin_app) - * puis on applique la reduction spéciale programmes définie dans - * typing/reduction *) - -(*i -let bin_app = function - | DOPN(AppL,v) as c -> - (match Array.length v with - | 1 -> v.(0) - | 2 -> c - | n -> - let f = DOPN(AppL,Array.sub v 0 (pred n)) in - DOPN(AppL,[|f;v.(pred n)|])) - | c -> c -i*) - -let red_cci c = - (*i let c = strong bin_app c in i*) - strong whd_programs (Global.env ()) Evd.empty c - diff --git a/contrib/correctness/pred.mli b/contrib/correctness/pred.mli deleted file mode 100644 index a5a9549b..00000000 --- a/contrib/correctness/pred.mli +++ /dev/null @@ -1,26 +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 *) -(************************************************************************) - -(* Certification of Imperative Programs / Jean-Christophe Filliâtre *) - -(* $Id: pred.mli 5920 2004-07-16 20:01:26Z herbelin $ *) - -open Term -open Past - -(* reduction on intermediate programs - * get rid of redexes of the kind let (x1,...,xn) = e in (x1,...,xn) *) - -val red : cc_term -> cc_term - - -(* Ad-hoc reduction on partial proof terms *) - -val red_cci : constr -> constr - - diff --git a/contrib/correctness/prename.ml b/contrib/correctness/prename.ml deleted file mode 100644 index 4ef1982d..00000000 --- a/contrib/correctness/prename.ml +++ /dev/null @@ -1,139 +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 *) -(************************************************************************) - -(* Certification of Imperative Programs / Jean-Christophe Filliâtre *) - -(* $Id: prename.ml 5920 2004-07-16 20:01:26Z herbelin $ *) - -open Names -open Nameops -open Util -open Pp -open Himsg -open Pmisc - -(* Variables names management *) - -type date = string - -(* The following data structure keeps the successive names of the variables - * as we traverse the program. A each step a ``date'' and a - * collection of new names is (possibly) given, and updates the - * previous renaming. - * - * Then, we can ask for the name of a variable, at current date or - * at a given date. - * - * It is easily represented by a list of date x assoc list, most recent coming - * first i.e. as follows: - * - * [ date (= current), [ (x,xi); ... ]; - * date , [ (z,zk); ... ]; - * ... - * date (= initial), [ (x,xj); (y,yi); ... ] - * - * We also keep a list of all names already introduced, in order to - * quickly get fresh names. - *) - -type t = - { levels : (date * (identifier * identifier) list) list; - avoid : identifier list; - cpt : int } - - -let empty_ren = { levels = []; avoid = []; cpt = 0 } - -let update r d ids = - let al,av = renaming_of_ids r.avoid ids in - { levels = (d,al) :: r.levels; avoid = av; cpt = r.cpt } - -let push_date r d = update r d [] - -let next r ids = - let al,av = renaming_of_ids r.avoid ids in - let n = succ r.cpt in - let d = string_of_int n in - { levels = (d,al) :: r.levels; avoid = av; cpt = n } - - -let find r x = - let rec find_in_one = function - [] -> raise Not_found - | (y,v)::rem -> if y = x then v else find_in_one rem - in - let rec find_in_all = function - [] -> raise Not_found - | (_,l)::rem -> try find_in_one l with Not_found -> find_in_all rem - in - find_in_all r.levels - - -let current_var = find - -let current_vars r ids = List.map (fun id -> id,current_var r id) ids - - -let avoid r ids = { levels = r.levels; avoid = r.avoid @ ids; cpt = r.cpt } - -let fresh r ids = fst (renaming_of_ids r.avoid ids) - - -let current_date r = - match r.levels with - [] -> invalid_arg "Renamings.current_date" - | (d,_)::_ -> d - -let all_dates r = List.map fst r.levels - -let rec valid_date da r = - let rec valid = function - [] -> false - | (d,_)::rem -> (d=da) or (valid rem) - in - valid r.levels - -(* [until d r] selects the part of the renaming [r] starting from date [d] *) -let rec until da r = - let rec cut = function - [] -> invalid_arg "Renamings.until" - | (d,_)::rem as r -> if d=da then r else cut rem - in - { avoid = r.avoid; levels = cut r.levels; cpt = r.cpt } - -let var_at_date r d id = - try - find (until d r) id - with Not_found -> - raise (UserError ("Renamings.var_at_date", - hov 0 (str"Variable " ++ pr_id id ++ str" is unknown" ++ spc () ++ - str"at date " ++ str d))) - -let vars_at_date r d ids = - let r' = until d r in List.map (fun id -> id,find r' id) ids - - -(* pretty-printers *) - -open Pp -open Util -open Himsg - -let pp r = - hov 2 (prlist_with_sep (fun () -> (fnl ())) - (fun (d,l) -> - (str d ++ str": " ++ - prlist_with_sep (fun () -> (spc ())) - (fun (id,id') -> - (str"(" ++ pr_id id ++ str"," ++ pr_id id' ++ str")")) - l)) - r.levels) - -let ppr e = - Pp.pp (pp e) - diff --git a/contrib/correctness/prename.mli b/contrib/correctness/prename.mli deleted file mode 100644 index 1d3ab669..00000000 --- a/contrib/correctness/prename.mli +++ /dev/null @@ -1,57 +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 *) -(************************************************************************) - -(* Certification of Imperative Programs / Jean-Christophe Filliâtre *) - -(* $Id: prename.mli 5920 2004-07-16 20:01:26Z herbelin $ *) - -open Names - -(* Abstract type for renamings - * - * Records the names of the mutables objets (ref, arrays) at the different - * moments of the evaluation, called dates - *) - -type t - -type date = string - - -val empty_ren : t -val update : t -> date -> identifier list -> t - (* assign new names for the given variables, associated to a new date *) -val next : t -> identifier list -> t - (* assign new names for the given variables, associated to a new - * date which is generated from an internal counter *) -val push_date : t -> date -> t - (* put a new date on top of the stack *) - -val valid_date : date -> t -> bool -val current_date : t -> date -val all_dates : t -> date list - -val current_var : t -> identifier -> identifier -val current_vars : t -> identifier list -> (identifier * identifier) list - (* gives the current names of some variables *) - -val avoid : t -> identifier list -> t -val fresh : t -> identifier list -> (identifier * identifier) list - (* introduces new names to avoid and renames some given variables *) - -val var_at_date : t -> date -> identifier -> identifier - (* gives the name of a variable at a given date *) -val vars_at_date : t -> date -> identifier list - -> (identifier * identifier) list - (* idem for a list of variables *) - -(* pretty-printers *) - -val pp : t -> Pp.std_ppcmds -val ppr : t -> unit - diff --git a/contrib/correctness/psyntax.ml4 b/contrib/correctness/psyntax.ml4 deleted file mode 100644 index 98d43112..00000000 --- a/contrib/correctness/psyntax.ml4 +++ /dev/null @@ -1,1058 +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 *) -(************************************************************************) - -(* Certification of Imperative Programs / Jean-Christophe Filliâtre *) - -(* $Id: psyntax.ml4 8752 2006-04-27 19:37:33Z herbelin $ *) - -(*i camlp4deps: "parsing/grammar.cma" i*) - -open Options -open Util -open Names -open Nameops -open Vernacentries -open Reduction -open Term -open Libnames -open Topconstr - -open Prename -open Pmisc -open Putil -open Ptype -open Past -open Penv -open Pmonad -open Vernacexpr - - -(* We define new entries for programs, with the use of this module - * Programs. These entries are named Programs.<foo> - *) - -module Gram = Pcoq.Gram -module Constr = Pcoq.Constr -module Tactic = Pcoq.Tactic - -module Programs = - struct - let gec s = Gram.Entry.create ("Programs."^s) - (* types *) - let type_v = gec "type_v" - let type_v0 = gec "type_v0" - let type_v1 = gec "type_v1" - let type_v2 = gec "type_v2" - let type_v3 = gec "type_v3" - let type_v_app = gec "type_v_app" - let type_c = gec "type_c" - let effects = gec "effects" - let reads = gec "reads" - let writes = gec "writes" - let pre_condition = gec "pre_condition" - let post_condition = gec "post_condition" - (* binders *) - let binder = gec "binder" - let binder_type = gec "binder_type" - let binders = gec "binders" - (* programs *) - let program = gec "program" - let prog1 = gec "prog1" - let prog2 = gec "prog2" - let prog3 = gec "prog3" - let prog4 = gec "prog4" - let prog5 = gec "prog5" - let prog6 = gec "prog6" - let prog7 = gec "prog7" - let ast1 = gec "ast1" - let ast2 = gec "ast2" - let ast3 = gec "ast3" - let ast4 = gec "ast4" - let ast5 = gec "ast5" - let ast6 = gec "ast6" - let ast7 = gec "ast7" - let arg = gec "arg" - let block = gec "block" - let block_statement = gec "block_statement" - let relation = gec "relation" - let variable = gec "variable" - let invariant = gec "invariant" - let variant = gec "variant" - let assertion = gec "assertion" - let precondition = gec "precondition" - let postcondition = gec "postcondition" - let predicate = gec "predicate" - let name = gec "name" - end - -open Programs - -let ast_of_int n = - CDelimiters - (dummy_loc, "Z", CNumeral (dummy_loc, Bignat.POS (Bignat.of_string n))) - -let constr_of_int n = - Constrintern.interp_constr Evd.empty (Global.env ()) (ast_of_int n) - -open Util -open Coqast - -let mk_id loc id = mkRefC (Ident (loc, id)) -let mk_ref loc s = mk_id loc (Constrextern.id_of_v7_string s) -let mk_appl loc1 loc2 f args = - CApp (join_loc loc1 loc2, (None,mk_ref loc1 f), List.map (fun a -> a,None) args) - -let conj_assert {a_name=n;a_value=a} {a_value=b} = - let loc1 = constr_loc a in - let loc2 = constr_loc a in - { a_value = mk_appl loc1 loc2 "and" [a;b]; a_name = n } - -let conj = function - None,None -> None - | None,b -> b - | a,None -> a - | Some a,Some b -> Some (conj_assert a b) - -let without_effect loc d = - { desc = d; pre = []; post = None; loc = loc; info = () } - -let isevar = Expression isevar - -let bin_op op loc e1 e2 = - without_effect loc - (Apply (without_effect loc (Expression (constant op)), - [ Term e1; Term e2 ])) - -let un_op op loc e = - without_effect loc - (Apply (without_effect loc (Expression (constant op)), [Term e])) - -let bool_bin op loc a1 a2 = - let w = without_effect loc in - let d = SApp ( [Variable op], [a1; a2]) in - w d - -let bool_or loc = bool_bin connective_or loc -let bool_and loc = bool_bin connective_and loc - -let bool_not loc a = - let w = without_effect loc in - let d = SApp ( [Variable connective_not ], [a]) in - w d - -let ast_zwf_zero loc = mk_appl loc loc "Zwf" [mk_ref loc "Z0"] - -(* program -> Coq AST *) - -let bdize c = - let env = - Global.env_of_context (Pcicenv.cci_sign_of Prename.empty_ren Penv.empty) - in - Constrextern.extern_constr true env c - -let rec coqast_of_program loc = function - | Variable id -> mk_id loc id - | Acc id -> mk_id loc id - | Apply (f,l) -> - let f = coqast_of_program f.loc f.desc in - let args = List.map - (function Term t -> (coqast_of_program t.loc t.desc,None) - | _ -> invalid_arg "coqast_of_program") l - in - CApp (dummy_loc, (None,f), args) - | Expression c -> bdize c - | _ -> invalid_arg "coqast_of_program" - -(* The construction `for' is syntactic sugar. - * - * for i = v1 to v2 do { invariant Inv } block done - * - * ==> (let rec f i { variant v2+1-i } = - * { i <= v2+1 /\ Inv(i) } - * (if i > v2 then tt else begin block; (f (i+1)) end) - * { Inv(v2+1) } - * in (f v1)) { Inv(v2+1) } - *) - -let ast_plus_un loc ast = - let un = ast_of_int "1" in - mk_appl loc loc "Zplus" [ast;un] - -let make_ast_for loc i v1 v2 inv block = - let f = for_name() in - let id_i = id_of_string i in - let var_i = without_effect loc (Variable id_i) in - let var_f = without_effect loc (Variable f) in - let succ_v2 = - let a_v2 = coqast_of_program v2.loc v2.desc in - ast_plus_un loc a_v2 in - let post = named_app (subst_ast_in_ast [ id_i, succ_v2 ]) inv in - let e1 = - let test = bin_op "Z_gt_le_bool" loc var_i v2 in - let br_t = without_effect loc (Expression (constant "tt")) in - let br_f = - let un = without_effect loc (Expression (constr_of_int "1")) in - let succ_i = bin_op "Zplus" loc var_i un in - let f_succ_i = without_effect loc (Apply (var_f, [Term succ_i])) in - without_effect loc (Seq (block @ [Statement f_succ_i])) - in - let inv' = - let i_le_sv2 = mk_appl loc loc "Zle" [mk_ref loc i; succ_v2] in - conj_assert {a_value=i_le_sv2;a_name=inv.a_name} inv - in - { desc = If(test,br_t,br_f); loc = loc; - pre = [pre_of_assert false inv']; post = Some post; info = () } - in - let bl = - let typez = mk_ref loc "Z" in - [(id_of_string i, BindType (TypePure typez))] - in - let fv1 = without_effect loc (Apply (var_f, [Term v1])) in - let v = TypePure (mk_ref loc "unit") in - let var = - let a = mk_appl loc loc "Zminus" [succ_v2;mk_ref loc i] in - (a, ast_zwf_zero loc) - in - Let (f, without_effect loc (LetRec (f,bl,v,var,e1)), fv1) - -let mk_prog loc p pre post = - { desc = p.desc; - pre = p.pre @ pre; - post = conj (p.post,post); - loc = loc; - info = () } - -if !Options.v7 then -GEXTEND Gram - - (* Types ******************************************************************) - type_v: - [ [ t = type_v0 -> t ] ] - ; - type_v0: - [ [ t = type_v1 -> t ] ] - ; - type_v1: - [ [ t = type_v2 -> t ] ] - ; - type_v2: - [ LEFTA - [ v = type_v2; IDENT "ref" -> Ref v - | t = type_v3 -> t ] ] - ; - type_v3: - [ [ IDENT "array"; size = Constr.constr; "of"; v = type_v0 -> - Array (size,v) - | IDENT "fun"; bl = binders; c = type_c -> make_arrow bl c - | c = Constr.constr -> TypePure c - ] ] - ; - type_c: - [ [ IDENT "returns"; id = IDENT; ":"; v = type_v; - e = effects; p = OPT pre_condition; q = OPT post_condition; "end" -> - ((id_of_string id, v), e, list_of_some p, q) - ] ] - ; - effects: - [ [ r = OPT reads; w = OPT writes -> - let r' = match r with Some l -> l | _ -> [] in - let w' = match w with Some l -> l | _ -> [] in - List.fold_left (fun e x -> Peffect.add_write x e) - (List.fold_left (fun e x -> Peffect.add_read x e) Peffect.bottom r') - w' - ] ] - ; - reads: - [ [ IDENT "reads"; l = LIST0 IDENT SEP "," -> List.map id_of_string l ] ] - ; - writes: - [ [ IDENT "writes"; l=LIST0 IDENT SEP "," -> List.map id_of_string l ] ] - ; - pre_condition: - [ [ IDENT "pre"; c = predicate -> pre_of_assert false c ] ] - ; - post_condition: - [ [ IDENT "post"; c = predicate -> c ] ] - ; - - (* Binders (for both types and programs) **********************************) - binder: - [ [ "("; sl = LIST1 IDENT SEP ","; ":"; t = binder_type ; ")" -> - List.map (fun s -> (id_of_string s, t)) sl - ] ] - ; - binder_type: - [ [ "Set" -> BindSet - | v = type_v -> BindType v - ] ] - ; - binders: - [ [ bl = LIST0 binder -> List.flatten bl ] ] - ; - - (* annotations *) - predicate: - [ [ c = Constr.constr; n = name -> { a_name = n; a_value = c } ] ] - ; - name: - [ [ "as"; s = IDENT -> Name (id_of_string s) - | -> Anonymous - ] ] - ; - - (* Programs ***************************************************************) - variable: - [ [ s = IDENT -> id_of_string s ] ] - ; - assertion: - [ [ "{"; c = predicate; "}" -> c ] ] - ; - precondition: - [ [ "{"; c = predicate; "}" -> pre_of_assert false c ] ] - ; - postcondition: - [ [ "{"; c = predicate; "}" -> c ] ] - ; - program: - [ [ p = prog1 -> p ] ] - ; - prog1: - [ [ pre = LIST0 precondition; ast = ast1; post = OPT postcondition -> - mk_prog loc ast pre post ] ] - ; - prog2: - [ [ pre = LIST0 precondition; ast = ast2; post = OPT postcondition -> - mk_prog loc ast pre post ] ] - ; - prog3: - [ [ pre = LIST0 precondition; ast = ast3; post = OPT postcondition -> - mk_prog loc ast pre post ] ] - ; - prog4: - [ [ pre = LIST0 precondition; ast = ast4; post = OPT postcondition -> - mk_prog loc ast pre post ] ] - ; - prog5: - [ [ pre = LIST0 precondition; ast = ast5; post = OPT postcondition -> - mk_prog loc ast pre post ] ] - ; - prog6: - [ [ pre = LIST0 precondition; ast = ast6; post = OPT postcondition -> - mk_prog loc ast pre post ] ] - ; - - ast1: - [ [ x = prog2; IDENT "or"; y = prog1 -> bool_or loc x y - | x = prog2; IDENT "and"; y = prog1 -> bool_and loc x y - | x = prog2 -> x - ] ] - ; - ast2: - [ [ IDENT "not"; x = prog3 -> bool_not loc x - | x = prog3 -> x - ] ] - ; - ast3: - [ [ x = prog4; rel = relation; y = prog4 -> bin_op rel loc x y - | x = prog4 -> x - ] ] - ; - ast4: - [ [ x = prog5; "+"; y = prog4 -> bin_op "Zplus" loc x y - | x = prog5; "-"; y = prog4 -> bin_op "Zminus" loc x y - | x = prog5 -> x - ] ] - ; - ast5: - [ [ x = prog6; "*"; y = prog5 -> bin_op "Zmult" loc x y - | x = prog6 -> x - ] ] - ; - ast6: - [ [ "-"; x = prog6 -> un_op "Zopp" loc x - | x = ast7 -> without_effect loc x - ] ] - ; - ast7: - [ [ v = variable -> - Variable v - | n = INT -> - Expression (constr_of_int n) - | "!"; v = variable -> - Acc v - | "?" -> - isevar - | v = variable; ":="; p = program -> - Aff (v,p) - | v = variable; "["; e = program; "]" -> TabAcc (true,v,e) - | v = variable; "#"; "["; e = program; "]" -> TabAcc (true,v,e) - | v = variable; "["; e = program; "]"; ":="; p = program -> - TabAff (true,v,e,p) - | v = variable; "#"; "["; e = program; "]"; ":="; p = program -> - TabAff (true,v,e,p) - | IDENT "if"; e1 = program; IDENT "then"; e2 = program; - IDENT "else"; e3 = program -> - If (e1,e2,e3) - | IDENT "if"; e1 = program; IDENT "then"; e2 = program -> - If (e1,e2,without_effect loc (Expression (constant "tt"))) - | IDENT "while"; b = program; IDENT "do"; - "{"; inv = OPT invariant; IDENT "variant"; wf = variant; "}"; - bl = block; IDENT "done" -> - While (b, inv, wf, bl) - | IDENT "for"; i = IDENT; "="; v1 = program; IDENT "to"; v2 = program; - IDENT "do"; "{"; inv = invariant; "}"; - bl = block; IDENT "done" -> - make_ast_for loc i v1 v2 inv bl - | IDENT "let"; v = variable; "="; IDENT "ref"; p1 = program; - "in"; p2 = program -> - LetRef (v, p1, p2) - | IDENT "let"; v = variable; "="; p1 = program; "in"; p2 = program -> - Let (v, p1, p2) - | IDENT "begin"; b = block; "end" -> - Seq b - | IDENT "fun"; bl = binders; "->"; p = program -> - Lam (bl,p) - | IDENT "let"; IDENT "rec"; f = variable; - bl = binders; ":"; v = type_v; - "{"; IDENT "variant"; var = variant; "}"; "="; p = program -> - LetRec (f,bl,v,var,p) - | IDENT "let"; IDENT "rec"; f = variable; - bl = binders; ":"; v = type_v; - "{"; IDENT "variant"; var = variant; "}"; "="; p = program; - "in"; p2 = program -> - Let (f, without_effect loc (LetRec (f,bl,v,var,p)), p2) - - | "@"; s = STRING; p = program -> - Debug (s,p) - - | "("; p = program; args = LIST0 arg; ")" -> - match args with - [] -> - if p.pre<>[] or p.post<>None then - Pp.warning "Some annotations are lost"; - p.desc - | _ -> - Apply(p,args) - ] ] - ; - arg: - [ [ "'"; t = type_v -> Type t - | p = program -> Term p - ] ] - ; - block: - [ [ s = block_statement; ";"; b = block -> s::b - | s = block_statement -> [s] ] ] - ; - block_statement: - [ [ IDENT "label"; s = IDENT -> Label s - | IDENT "assert"; c = assertion -> Assert c - | p = program -> Statement p ] ] - ; - relation: - [ [ "<" -> "Z_lt_ge_bool" - | "<=" -> "Z_le_gt_bool" - | ">" -> "Z_gt_le_bool" - | ">=" -> "Z_ge_lt_bool" - | "=" -> "Z_eq_bool" - | "<>" -> "Z_noteq_bool" ] ] - ; - - (* Other entries (invariants, etc.) ***************************************) - invariant: - [ [ IDENT "invariant"; c = predicate -> c ] ] - ; - variant: - [ [ c = Constr.constr; IDENT "for"; r = Constr.constr -> (c, r) - | c = Constr.constr -> (c, ast_zwf_zero loc) ] ] - ; - END -else -GEXTEND Gram - GLOBAL: type_v program; - - (* Types ******************************************************************) - type_v: - [ [ t = type_v0 -> t ] ] - ; - type_v0: - [ [ t = type_v1 -> t ] ] - ; - type_v1: - [ [ t = type_v2 -> t ] ] - ; - type_v2: - [ LEFTA - [ v = type_v2; IDENT "ref" -> Ref v - | t = type_v3 -> t ] ] - ; - type_v3: - [ [ IDENT "array"; size = Constr.constr; IDENT "of"; v = type_v0 -> - Array (size,v) - | "fun"; bl = binders; c = type_c -> make_arrow bl c - | c = Constr.constr -> TypePure c - ] ] - ; - type_c: - [ [ IDENT "returns"; id = IDENT; ":"; v = type_v; - e = effects; p = OPT pre_condition; q = OPT post_condition; "end" -> - ((id_of_string id, v), e, list_of_some p, q) - ] ] - ; - effects: - [ [ r = OPT reads; w = OPT writes -> - let r' = match r with Some l -> l | _ -> [] in - let w' = match w with Some l -> l | _ -> [] in - List.fold_left (fun e x -> Peffect.add_write x e) - (List.fold_left (fun e x -> Peffect.add_read x e) Peffect.bottom r') - w' - ] ] - ; - reads: - [ [ IDENT "reads"; l = LIST0 IDENT SEP "," -> List.map id_of_string l ] ] - ; - writes: - [ [ IDENT "writes"; l=LIST0 IDENT SEP "," -> List.map id_of_string l ] ] - ; - pre_condition: - [ [ IDENT "pre"; c = predicate -> pre_of_assert false c ] ] - ; - post_condition: - [ [ IDENT "post"; c = predicate -> c ] ] - ; - - (* Binders (for both types and programs) **********************************) - binder: - [ [ "("; sl = LIST1 IDENT SEP ","; ":"; t = binder_type ; ")" -> - List.map (fun s -> (id_of_string s, t)) sl - ] ] - ; - binder_type: - [ [ "Set" -> BindSet - | v = type_v -> BindType v - ] ] - ; - binders: - [ [ bl = LIST0 binder -> List.flatten bl ] ] - ; - - (* annotations *) - predicate: - [ [ c = Constr.constr; n = name -> { a_name = n; a_value = c } ] ] - ; - dpredicate: - [ [ c = Constr.lconstr; n = name -> { a_name = n; a_value = c } ] ] - ; - name: - [ [ "as"; s = IDENT -> Name (id_of_string s) - | -> Anonymous - ] ] - ; - - (* Programs ***************************************************************) - variable: - [ [ s = IDENT -> id_of_string s ] ] - ; - assertion: - [ [ "{"; c = dpredicate; "}" -> c ] ] - ; - precondition: - [ [ "{"; c = dpredicate; "}" -> pre_of_assert false c ] ] - ; - postcondition: - [ [ "{"; c = dpredicate; "}" -> c ] ] - ; - program: - [ [ p = prog1 -> p ] ] - ; - prog1: - [ [ pre = LIST0 precondition; ast = ast1; post = OPT postcondition -> - mk_prog loc ast pre post ] ] - ; - prog2: - [ [ pre = LIST0 precondition; ast = ast2; post = OPT postcondition -> - mk_prog loc ast pre post ] ] - ; - prog3: - [ [ pre = LIST0 precondition; ast = ast3; post = OPT postcondition -> - mk_prog loc ast pre post ] ] - ; - prog4: - [ [ pre = LIST0 precondition; ast = ast4; post = OPT postcondition -> - mk_prog loc ast pre post ] ] - ; - prog5: - [ [ pre = LIST0 precondition; ast = ast5; post = OPT postcondition -> - mk_prog loc ast pre post ] ] - ; - prog6: - [ [ pre = LIST0 precondition; ast = ast6; post = OPT postcondition -> - mk_prog loc ast pre post ] ] - ; - - ast1: - [ [ x = prog2; IDENT "or"; y = prog1 -> bool_or loc x y - | x = prog2; IDENT "and"; y = prog1 -> bool_and loc x y - | x = prog2 -> x - ] ] - ; - ast2: - [ [ IDENT "not"; x = prog3 -> bool_not loc x - | x = prog3 -> x - ] ] - ; - ast3: - [ [ x = prog4; rel = relation; y = prog4 -> bin_op rel loc x y - | x = prog4 -> x - ] ] - ; - ast4: - [ [ x = prog5; "+"; y = prog4 -> bin_op "Zplus" loc x y - | x = prog5; "-"; y = prog4 -> bin_op "Zminus" loc x y - | x = prog5 -> x - ] ] - ; - ast5: - [ [ x = prog6; "*"; y = prog5 -> bin_op "Zmult" loc x y - | x = prog6 -> x - ] ] - ; - ast6: - [ [ "-"; x = prog6 -> un_op "Zopp" loc x - | x = ast7 -> without_effect loc x - ] ] - ; - ast7: - [ [ v = variable -> - Variable v - | n = INT -> - Expression (constr_of_int n) - | "!"; v = variable -> - Acc v - | "?" -> - isevar - | v = variable; ":="; p = program -> - Aff (v,p) - | v = variable; "["; e = program; "]" -> TabAcc (true,v,e) - | v = variable; "#"; "["; e = program; "]" -> TabAcc (true,v,e) - | v = variable; "["; e = program; "]"; ":="; p = program -> - TabAff (true,v,e,p) - | v = variable; "#"; "["; e = program; "]"; ":="; p = program -> - TabAff (true,v,e,p) - | "if"; e1 = program; "then"; e2 = program; "else"; e3 = program -> - If (e1,e2,e3) - | "if"; e1 = program; "then"; e2 = program -> - If (e1,e2,without_effect loc (Expression (constant "tt"))) - | IDENT "while"; b = program; IDENT "do"; - "{"; inv = OPT invariant; IDENT "variant"; wf = variant; "}"; - bl = block; IDENT "done" -> - While (b, inv, wf, bl) - | "for"; i = IDENT; "="; v1 = program; IDENT "to"; v2 = program; - IDENT "do"; "{"; inv = invariant; "}"; - bl = block; IDENT "done" -> - make_ast_for loc i v1 v2 inv bl - | "let"; v = variable; "="; IDENT "ref"; p1 = program; - "in"; p2 = program -> - LetRef (v, p1, p2) - | "let"; v = variable; "="; p1 = program; "in"; p2 = program -> - Let (v, p1, p2) - | IDENT "begin"; b = block; "end" -> - Seq b - | "fun"; bl = binders; "=>"; p = program -> - Lam (bl,p) - | "let"; IDENT "rec"; f = variable; - bl = binders; ":"; v = type_v; - "{"; IDENT "variant"; var = variant; "}"; "="; p = program -> - LetRec (f,bl,v,var,p) - | "let"; IDENT "rec"; f = variable; - bl = binders; ":"; v = type_v; - "{"; IDENT "variant"; var = variant; "}"; "="; p = program; - "in"; p2 = program -> - Let (f, without_effect loc (LetRec (f,bl,v,var,p)), p2) - - | "@"; s = STRING; p = program -> - Debug (s,p) - - | "("; p = program; args = LIST0 arg; ")" -> - match args with - [] -> - if p.pre<>[] or p.post<>None then - Pp.warning "Some annotations are lost"; - p.desc - | _ -> - Apply(p,args) - ] ] - ; - arg: - [ [ "'"; t = type_v -> Type t - | p = program -> Term p - ] ] - ; - block: - [ [ s = block_statement; ";"; b = block -> s::b - | s = block_statement -> [s] ] ] - ; - block_statement: - [ [ IDENT "label"; s = IDENT -> Label s - | IDENT "assert"; c = assertion -> Assert c - | p = program -> Statement p ] ] - ; - relation: - [ [ "<" -> "Z_lt_ge_bool" - | "<=" -> "Z_le_gt_bool" - | ">" -> "Z_gt_le_bool" - | ">=" -> "Z_ge_lt_bool" - | "=" -> "Z_eq_bool" - | "<>" -> "Z_noteq_bool" ] ] - ; - - (* Other entries (invariants, etc.) ***************************************) - invariant: - [ [ IDENT "invariant"; c = predicate -> c ] ] - ; - variant: - [ [ c = Constr.constr; "for"; r = Constr.constr -> (c, r) - | c = Constr.constr -> (c, ast_zwf_zero loc) ] ] - ; - END -;; - -let wit_program, globwit_program, rawwit_program = - Genarg.create_arg "program" -let wit_type_v, globwit_type_v, rawwit_type_v = - Genarg.create_arg "type_v" - -open Pp -open Util -open Himsg -open Vernacinterp -open Vernacexpr -open Declare - -let is_assumed global ids = - if List.length ids = 1 then - msgnl (str (if global then "A global variable " else "") ++ - pr_id (List.hd ids) ++ str " is assumed") - else - msgnl (str (if global then "Some global variables " else "") ++ - prlist_with_sep (fun () -> (str ", ")) pr_id ids ++ - str " are assumed") - -open Pcoq - -(* Variables *) - -let wit_variables, globwit_variables, rawwit_variables = - Genarg.create_arg "variables" - -let variables = Gram.Entry.create "Variables" - -GEXTEND Gram - variables: [ [ l = LIST1 Prim.ident SEP "," -> l ] ]; -END - -let pr_variables _prc _prtac l = spc() ++ prlist_with_sep pr_coma pr_id l - -let _ = - Pptactic.declare_extra_genarg_pprule true - (rawwit_variables, pr_variables) - (globwit_variables, pr_variables) - (wit_variables, pr_variables) - -(* then_tac *) - -open Genarg -open Tacinterp - -let pr_then_tac _ prt = function - | None -> mt () - | Some t -> pr_semicolon () ++ prt t - -ARGUMENT EXTEND then_tac - TYPED AS tactic_opt - PRINTED BY pr_then_tac - INTERPRETED BY interp_genarg - GLOBALIZED BY intern_genarg -| [ ";" tactic(t) ] -> [ Some t ] -| [ ] -> [ None ] -END - -(* Correctness *) - -VERNAC COMMAND EXTEND Correctness - [ "Correctness" preident(str) program(pgm) then_tac(tac) ] - -> [ Ptactic.correctness str pgm (option_map Tacinterp.interp tac) ] -END - -(* Show Programs *) - -let show_programs () = - fold_all - (fun (id,v) _ -> - msgnl (pr_id id ++ str " : " ++ - hov 2 (match v with TypeV v -> pp_type_v v - | Set -> (str "Set")) ++ - fnl ())) - Penv.empty () - -VERNAC COMMAND EXTEND ShowPrograms - [ "Show" "Programs" ] -> [ show_programs () ] -END - -(* Global Variable *) - -let global_variable ids v = - List.iter - (fun id -> if Penv.is_global id then - Util.errorlabstrm "PROGVARIABLE" - (str"Clash with previous constant " ++ pr_id id)) - ids; - Pdb.check_type_v (all_refs ()) v; - let env = empty in - let ren = update empty_ren "" [] in - let v = Ptyping.cic_type_v env ren v in - if not (is_mutable v) then begin - let c = - Entries.ParameterEntry (trad_ml_type_v ren env v), - Decl_kinds.IsAssumption Decl_kinds.Definitional in - List.iter - (fun id -> ignore (Declare.declare_constant id c)) ids; - if_verbose (is_assumed false) ids - end; - if not (is_pure v) then begin - List.iter (fun id -> ignore (Penv.add_global id v None)) ids; - if_verbose (is_assumed true) ids - end - -VERNAC COMMAND EXTEND ProgVariable - [ "Global" "Variable" variables(ids) ":" type_v(t) ] - -> [ global_variable ids t] -END - -let pr_id id = pr_id (Constrextern.v7_to_v8_id id) - -(* Type printer *) - -let pr_reads = function - | [] -> mt () - | l -> spc () ++ - hov 0 (str "reads" ++ spc () ++ prlist_with_sep pr_coma pr_id l) - -let pr_writes = function - | [] -> mt () - | l -> spc () ++ - hov 0 (str "writes" ++ spc () ++ prlist_with_sep pr_coma pr_id l) - -let pr_effects x = - let (ro,rw) = Peffect.get_repr x in pr_reads ro ++ pr_writes rw - -let pr_predicate delimited { a_name = n; a_value = c } = - (if delimited then Ppconstr.pr_lconstr else Ppconstr.pr_constr) c ++ - (match n with Name id -> spc () ++ str "as " ++ pr_id id | Anonymous -> mt()) - -let pr_assert b { p_name = x; p_value = v } = - pr_predicate b { a_name = x; a_value = v } - -let pr_pre_condition_list = function - | [] -> mt () - | [pre] -> spc() ++ hov 0 (str "pre" ++ spc () ++ pr_assert false pre) - | _ -> assert false - -let pr_post_condition_opt = function - | None -> mt () - | Some post -> - spc() ++ hov 0 (str "post" ++ spc () ++ pr_predicate false post) - -let rec pr_type_v_v8 = function - | Array (a,v) -> - str "array" ++ spc() ++ Ppconstr.pr_constr a ++ spc() ++ str "of " ++ - pr_type_v_v8 v - | v -> pr_type_v3 v - -and pr_type_v3 = function - | Ref v -> pr_type_v3 v ++ spc () ++ str "ref" - | Arrow (bl,((id,v),e,prel,postl)) -> - str "fun" ++ spc() ++ hov 0 (prlist_with_sep cut pr_binder bl) ++ - spc () ++ str "returns" ++ spc () ++ pr_id id ++ str ":" ++ - pr_type_v_v8 v ++ pr_effects e ++ - pr_pre_condition_list prel ++ pr_post_condition_opt postl ++ - spc () ++ str "end" - | TypePure a -> Ppconstr.pr_constr a - | v -> str "(" ++ pr_type_v_v8 v ++ str ")" - -and pr_binder = function - | (id,BindType c) -> - str "(" ++ pr_id id ++ str ":" ++ pr_type_v_v8 c ++ str ")" - | (id,BindSet) -> - str "(" ++ pr_id id ++ str ":" ++ str "Set" ++ str ")" - | (id,Untyped) -> - str "<<<<< TODO: Untyped binder >>>>" - -let _ = - Pptactic.declare_extra_genarg_pprule true - (rawwit_type_v, fun _ _ -> pr_type_v_v8) - (globwit_type_v, fun _ -> raise Not_found) - (wit_type_v, fun _ -> raise Not_found) - -(* Program printer *) - -let pr_precondition pred = str "{" ++ pr_assert true pred ++ str "}" ++ spc () - -let pr_postcondition pred = str "{" ++ pr_predicate true pred ++ str "}" - -let pr_invariant = function - | None -> mt () - | Some c -> hov 2 (str "invariant" ++ spc () ++ pr_predicate false c) - -let pr_variant (c1,c2) = - Ppconstr.pr_constr c1 ++ - (try Constrextern.check_same_type c2 (ast_zwf_zero dummy_loc); mt () - with _ -> spc() ++ hov 0 (str "for" ++ spc () ++ Ppconstr.pr_constr c2)) - -let rec pr_desc = function - | Variable id -> - (* Unsafe: should distinguish global names and bound vars *) - let vars = (* TODO *) Idset.empty in - let id = try - snd (repr_qualid - (snd (qualid_of_reference - (Constrextern.extern_reference - dummy_loc vars (Nametab.locate (make_short_qualid id)))))) - with _ -> id in - pr_id id - | Acc id -> str "!" ++ pr_id id - | Aff (id,p) -> pr_id id ++ spc() ++ str ":=" ++ spc() ++ pr_prog p - | TabAcc (b,id,p) -> pr_id id ++ str "[" ++ pr_prog p ++ str "]" - | TabAff (b,id,p1,p2) -> - pr_id id ++ str "[" ++ pr_prog p1 ++ str "]" ++ - str ":=" ++ pr_prog p2 - | Seq bll -> - hv 0 (str "begin" ++ spc () ++ pr_block bll ++ spc () ++ str "end") - | While (p1,inv,var,bll) -> - hv 0 ( - hov 0 (str "while" ++ spc () ++ pr_prog p1 ++ spc () ++ str "do") ++ - brk (1,2) ++ - hv 2 ( - str "{ " ++ - pr_invariant inv ++ spc() ++ - hov 0 (str "variant" ++ spc () ++ pr_variant var) - ++ str " }") ++ cut () ++ - hov 0 (pr_block bll) ++ cut () ++ - str "done") - | If (p1,p2,p3) -> - hov 1 (str "if " ++ pr_prog p1) ++ spc () ++ - hov 0 (str "then" ++ spc () ++ pr_prog p2) ++ spc () ++ - hov 0 (str "else" ++ spc () ++ pr_prog p3) - | Lam (bl,p) -> - hov 0 - (str "fun" ++ spc () ++ hov 0 (prlist_with_sep cut pr_binder bl) ++ - spc () ++ str "=>") ++ - pr_prog p - | Apply ({desc=Expression e; pre=[]; post=None} as p,args) when isConst e -> - begin match - string_of_id (snd (repr_path (Nametab.sp_of_global (ConstRef (destConst e))))), - args - with - | "Zmult", [a1;a2] -> - str "(" ++ pr_arg a1 ++ str"*" ++ pr_arg a2 ++ str ")" - | "Zplus", [a1;a2] -> - str "(" ++ pr_arg a1 ++ str"+" ++ pr_arg a2 ++ str ")" - | "Zminus", [a1;a2] -> - str "(" ++ pr_arg a1 ++ str"-" ++ pr_arg a2 ++ str ")" - | "Zopp", [a] -> - str "( -" ++ pr_arg a ++ str ")" - | "Z_lt_ge_bool", [a1;a2] -> - str "(" ++ pr_arg a1 ++ str"<" ++ pr_arg a2 ++ str ")" - | "Z_le_gt_bool", [a1;a2] -> - str "(" ++ pr_arg a1 ++ str"<=" ++ pr_arg a2 ++ str ")" - | "Z_gt_le_bool", [a1;a2] -> - str "(" ++ pr_arg a1 ++ str">" ++ pr_arg a2 ++ str ")" - | "Z_ge_lt_bool", [a1;a2] -> - str "(" ++ pr_arg a1 ++ str">=" ++ pr_arg a2 ++ str ")" - | "Z_eq_bool", [a1;a2] -> - str "(" ++ pr_arg a1 ++ str"=" ++ pr_arg a2 ++ str ")" - | "Z_noteq_bool", [a1;a2] -> - str "(" ++ pr_arg a1 ++ str"<> " ++ pr_arg a2 ++ str ")" - | _ -> - str "(" ++ pr_prog p ++ spc () ++ prlist_with_sep spc pr_arg args ++ - str ")" - end - | Apply (p,args) -> - str "(" ++ pr_prog p ++ spc () ++ prlist_with_sep spc pr_arg args ++ - str ")" - | SApp ([Variable v], args) -> - begin match string_of_id v, args with - | "prog_bool_and", [a1;a2] -> - str"(" ++ pr_prog a1 ++ spc() ++ str"and " ++ pr_prog a2 ++str")" - | "prog_bool_or", [a1;a2] -> - str"(" ++ pr_prog a1 ++ spc() ++ str"or " ++ pr_prog a2 ++ str")" - | "prog_bool_not", [a] -> - str "(not " ++ pr_prog a ++ str ")" - | _ -> failwith "Correctness printer: TODO" - end - | SApp _ -> failwith "Correctness printer: TODO" - | LetRef (v,p1,p2) -> - hov 2 ( - str "let " ++ pr_id v ++ str " =" ++ spc () ++ str "ref" ++ spc () ++ - pr_prog p1 ++ str " in") ++ - spc () ++ pr_prog p2 - | Let (id, {desc=LetRec (f,bl,v,var,p); pre=[]; post=None },p2) when f=id -> - hov 2 ( - str "let rec " ++ pr_id f ++ spc () ++ - hov 0 (prlist_with_sep cut pr_binder bl) ++ spc () ++ - str ":" ++ pr_type_v_v8 v ++ spc () ++ - hov 2 (str "{ variant" ++ spc () ++ pr_variant var ++ str " }") ++ - spc() ++ str "=" ++ spc () ++ pr_prog p ++ - str " in") ++ - spc () ++ pr_prog p2 - | Let (v,p1,p2) -> - hov 2 ( - str "let " ++ pr_id v ++ str " =" ++ spc () ++ pr_prog p1 ++ str" in") - ++ spc () ++ pr_prog p2 - | LetRec (f,bl,v,var,p) -> - str "let rec " ++ pr_id f ++ spc () ++ - hov 0 (prlist_with_sep cut pr_binder bl) ++ spc () ++ - str ":" ++ pr_type_v_v8 v ++ spc () ++ - hov 2 (str "{ variant" ++ spc () ++ pr_variant var ++ str " }") ++ - spc () ++ str "=" ++ spc () ++ pr_prog p - | PPoint _ -> str "TODO: Ppoint" (* Internal use only *) - | Expression c -> - (* Numeral or "tt": use a printer which doesn't globalize *) - Ppconstr.pr_constr - (Constrextern.extern_constr_in_scope false "Z_scope" (Global.env()) c) - | Debug (s,p) -> str "@" ++ Pptactic.qsnew s ++ pr_prog p - -and pr_block_st = function - | Label s -> hov 0 (str "label" ++ spc() ++ str s) - | Assert pred -> - hov 0 (str "assert" ++ spc() ++ hov 0 (pr_postcondition pred)) - | Statement p -> pr_prog p - -and pr_block bl = prlist_with_sep pr_semicolon pr_block_st bl - -and pr_arg = function - | Past.Term p -> pr_prog p - | Past.Type t -> str "'" ++ pr_type_v_v8 t - | Refarg _ -> str "TODO: Refarg" (* Internal use only *) - -and pr_prog0 b { desc = desc; pre = pre; post = post } = - hv 0 ( - prlist pr_precondition pre ++ - hov 0 - (if b & post<>None then str"(" ++ pr_desc desc ++ str")" - else pr_desc desc) - ++ Ppconstr.pr_opt pr_postcondition post) - -and pr_prog x = pr_prog0 true x - -let _ = - Pptactic.declare_extra_genarg_pprule true - (rawwit_program, fun _ _ a -> spc () ++ pr_prog0 false a) - (globwit_program, fun _ -> raise Not_found) - (wit_program, fun _ -> raise Not_found) - diff --git a/contrib/correctness/psyntax.mli b/contrib/correctness/psyntax.mli deleted file mode 100644 index c0f0990b..00000000 --- a/contrib/correctness/psyntax.mli +++ /dev/null @@ -1,25 +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 *) -(************************************************************************) - -(* Certification of Imperative Programs / Jean-Christophe Filliâtre *) - -(* $Id: psyntax.mli 5920 2004-07-16 20:01:26Z herbelin $ *) - -open Pcoq -open Ptype -open Past -open Topconstr - -(* Grammar for the programs and the tactic Correctness *) - -module Programs : - sig - val program : program Gram.Entry.e - val type_v : constr_expr ml_type_v Gram.Entry.e - val type_c : constr_expr ml_type_c Gram.Entry.e - end diff --git a/contrib/correctness/ptactic.ml b/contrib/correctness/ptactic.ml deleted file mode 100644 index babc607d..00000000 --- a/contrib/correctness/ptactic.ml +++ /dev/null @@ -1,258 +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 *) -(************************************************************************) - -(* Certification of Imperative Programs / Jean-Christophe Filliâtre *) - -(* $Id: ptactic.ml 8759 2006-04-28 12:24:14Z herbelin $ *) - -open Pp -open Options -open Names -open Libnames -open Term -open Pretyping -open Pfedit -open Decl_kinds -open Vernacentries - -open Pmisc -open Putil -open Past -open Penv -open Prename -open Peffect -open Pmonad - -(* [coqast_of_prog: program -> constr * constr] - * Traduction d'un programme impératif en un but (second constr) - * et un terme de preuve partiel pour ce but (premier constr) - *) - -let coqast_of_prog p = - (* 1. db : séparation dB/var/const *) - let p = Pdb.db_prog p in - - (* 2. typage avec effets *) - deb_mess (str"Ptyping.states: Typing with effects..." ++ fnl ()); - let env = Penv.empty in - let ren = initial_renaming env in - let p = Ptyping.states ren env p in - let ((_,v),_,_,_) as c = p.info.kappa in - Perror.check_for_not_mutable p.loc v; - deb_print pp_type_c c; - - (* 3. propagation annotations *) - let p = Pwp.propagate ren p in - - (* 4a. traduction type *) - let ty = Pmonad.trad_ml_type_c ren env c in - deb_print (Printer.pr_lconstr_env (Global.env())) ty; - - (* 4b. traduction terme (terme intermédiaire de type cc_term) *) - deb_mess - (fnl () ++ str"Mlize.trad: Translation program -> cc_term..." ++ fnl ()); - let cc = Pmlize.trans ren p in - let cc = Pred.red cc in - deb_print Putil.pp_cc_term cc; - - (* 5. traduction en constr *) - deb_mess - (fnl () ++ str"Pcic.constr_of_prog: Translation cc_term -> rawconstr..." ++ - fnl ()); - let r = Pcic.rawconstr_of_prog cc in - deb_print Printer.pr_lrawconstr r; - - (* 6. résolution implicites *) - deb_mess (fnl () ++ str"Resolution implicits (? => Meta(n))..." ++ fnl ()); - let oc = understand_gen_tcc Evd.empty (Global.env()) [] None r in - deb_print (Printer.pr_lconstr_env (Global.env())) (snd oc); - - p,oc,ty,v - -(* [automatic : tactic] - * - * Certains buts engendrés par "correctness" (ci-dessous) - * sont réellement triviaux. On peut les résoudre aisément, sans pour autant - * tomber dans la solution trop lourde qui consiste à faire "; Auto." - * - * Cette tactique fait les choses suivantes : - * o elle élimine les hypothèses de nom loop<i> - * o sur G |- (well_founded nat lt) ==> Exact lt_wf. - * o sur G |- (well_founded Z (Zwf c)) ==> Exact (Zwf_well_founded c) - * o sur G |- e = e' ==> Reflexivity. (arg. de decr. des boucles) - * sinon Try Assumption. - * o sur G |- P /\ Q ==> Try (Split; Assumption). (sortie de boucle) - * o sinon, Try AssumptionBis (= Assumption + décomposition /\ dans hyp.) - * (pour entrée dans corps de boucle par ex.) - *) - -open Pattern -open Tacmach -open Tactics -open Tacticals -open Equality -open Nametab - -let nat = IndRef (coq_constant ["Init";"Datatypes"] "nat", 0) -let lt = ConstRef (coq_constant ["Init";"Peano"] "lt") -let well_founded = ConstRef (coq_constant ["Init";"Wf"] "well_founded") -let z = IndRef (coq_constant ["ZArith";"BinInt"] "Z", 0) -let and_ = IndRef (coq_constant ["Init";"Logic"] "and", 0) -let eq = IndRef (coq_constant ["Init";"Logic"] "eq", 0) - -let mkmeta n = Nameops.make_ident "X" (Some n) -let mkPMeta n = PMeta (Some (mkmeta n)) - -(* ["(well_founded nat lt)"] *) -let wf_nat_pattern = - PApp (PRef well_founded, [| PRef nat; PRef lt |]) -(* ["((well_founded Z (Zwf ?1))"] *) -let wf_z_pattern = - let zwf = ConstRef (coq_constant ["ZArith";"Zwf"] "Zwf") in - PApp (PRef well_founded, [| PRef z; PApp (PRef zwf, [| mkPMeta 1 |]) |]) -(* ["(and ?1 ?2)"] *) -let and_pattern = - PApp (PRef and_, [| mkPMeta 1; mkPMeta 2 |]) -(* ["(eq ?1 ?2 ?3)"] *) -let eq_pattern = - PApp (PRef eq, [| mkPMeta 1; mkPMeta 2; mkPMeta 3 |]) - -(* loop_ids: remove loop<i> hypotheses from the context, and rewrite - * using Variant<i> hypotheses when needed. *) - -let (loop_ids : tactic) = fun gl -> - let rec arec hyps gl = - let env = pf_env gl in - let concl = pf_concl gl in - match hyps with - | [] -> tclIDTAC gl - | (id,a) :: al -> - let s = string_of_id id in - let n = String.length s in - if n >= 4 & (let su = String.sub s 0 4 in su="loop" or su="Bool") - then - tclTHEN (clear [id]) (arec al) gl - else if n >= 7 & String.sub s 0 7 = "Variant" then begin - match pf_matches gl eq_pattern (body_of_type a) with - | [_; _,varphi; _] when isVar varphi -> - let phi = destVar varphi in - if Termops.occur_var env phi concl then - tclTHEN (rewriteLR (mkVar id)) (arec al) gl - else - arec al gl - | _ -> assert false end - else - arec al gl - in - arec (pf_hyps_types gl) gl - -(* assumption_bis: like assumption, but also solves ... h:A/\B ... |- A - * (resp. B) *) - -let (assumption_bis : tactic) = fun gl -> - let concl = pf_concl gl in - let rec arec = function - | [] -> Util.error "No such assumption" - | (s,a) :: al -> - let a = body_of_type a in - if pf_conv_x_leq gl a concl then - refine (mkVar s) gl - else if pf_is_matching gl and_pattern a then - match pf_matches gl and_pattern a with - | [_,c1; _,c2] -> - if pf_conv_x_leq gl c1 concl then - exact_check (applistc (constant "proj1") [c1;c2;mkVar s]) gl - else if pf_conv_x_leq gl c2 concl then - exact_check (applistc (constant "proj2") [c1;c2;mkVar s]) gl - else - arec al - | _ -> assert false - else - arec al - in - arec (pf_hyps_types gl) - -(* automatic: see above *) - -let (automatic : tactic) = - tclTHEN - loop_ids - (fun gl -> - let c = pf_concl gl in - if pf_is_matching gl wf_nat_pattern c then - exact_check (constant "lt_wf") gl - else if pf_is_matching gl wf_z_pattern c then - let (_,z) = List.hd (pf_matches gl wf_z_pattern c) in - exact_check (Term.applist (constant "Zwf_well_founded",[z])) gl - else if pf_is_matching gl and_pattern c then - (tclORELSE assumption_bis - (tclTRY (tclTHEN simplest_split assumption))) gl - else if pf_is_matching gl eq_pattern c then - (tclORELSE reflexivity (tclTRY assumption_bis)) gl - else - tclTRY assumption_bis gl) - -(* [correctness s p] : string -> program -> tactic option -> unit - * - * Vernac: Correctness <string> <program> [; <tactic>]. - *) - -let reduce_open_constr (em0,c) = - let existential_map_of_constr = - let rec collect em c = match kind_of_term c with - | Cast (c',t) -> - (match kind_of_term c' with - | Evar (ev,_) -> - if not (Evd.mem em ev) then - Evd.add em ev (Evd.find em0 ev) - else - em - | _ -> fold_constr collect em c) - | Evar _ -> - assert false (* all existentials should be casted *) - | _ -> - fold_constr collect em c - in - collect Evd.empty - in - let c = Pred.red_cci c in - let em = existential_map_of_constr c in - (em,c) - -let register id n = - let id' = match n with None -> id | Some id' -> id' in - Penv.register id id' - - (* On dit à la commande "Save" d'enregistrer les nouveaux programmes *) -let correctness_hook _ ref = - let pf_id = Nametab.id_of_global ref in - register pf_id None - -let correctness s p opttac = - Coqlib.check_required_library ["Coq";"correctness";"Correctness"]; - Pmisc.reset_names(); - let p,oc,cty,v = coqast_of_prog p in - let env = Global.env () in - let sign = Global.named_context () in - let sigma = Evd.empty in - let cty = Reduction.nf_betaiota cty in - let id = id_of_string s in - start_proof id (IsGlobal (Proof Lemma)) sign cty correctness_hook; - Penv.new_edited id (v,p); - if !debug then msg (Pfedit.pr_open_subgoals()); - deb_mess (str"Pred.red_cci: Reduction..." ++ fnl ()); - let oc = reduce_open_constr oc in - deb_mess (str"AFTER REDUCTION:" ++ fnl ()); - deb_print (Printer.pr_lconstr_env (Global.env())) (snd oc); - let tac = (tclTHEN (Extratactics.refine_tac oc) automatic) in - let tac = match opttac with - | None -> tac - | Some t -> tclTHEN tac t - in - solve_nth 1 tac; - if_verbose msg (pr_open_subgoals ()) diff --git a/contrib/correctness/ptactic.mli b/contrib/correctness/ptactic.mli deleted file mode 100644 index 87378cff..00000000 --- a/contrib/correctness/ptactic.mli +++ /dev/null @@ -1,22 +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 *) -(************************************************************************) - -(* Certification of Imperative Programs / Jean-Christophe Filliâtre *) - -(* $Id: ptactic.mli 5920 2004-07-16 20:01:26Z herbelin $ *) - -(* The main tactic: takes a name N, a program P, creates a goal - * of name N with the functional specification of P, then apply the Refine - * tactic with the partial proof term obtained by the translation of - * P into a functional program. - * - * Then an ad-hoc automatic tactic is applied on each subgoal to solve the - * trivial proof obligations *) - -val correctness : string -> Past.program -> Tacmach.tactic option -> unit - diff --git a/contrib/correctness/ptype.mli b/contrib/correctness/ptype.mli deleted file mode 100644 index be181bcc..00000000 --- a/contrib/correctness/ptype.mli +++ /dev/null @@ -1,73 +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 *) -(************************************************************************) - -(* Certification of Imperative Programs / Jean-Christophe Filliâtre *) - -(* $Id: ptype.mli 5920 2004-07-16 20:01:26Z herbelin $ *) - -open Term - -(* Types des valeurs (V) et des calculs (C). - * - * On a C = r:V,E,P,Q - * - * et V = (x1:V1)...(xn:Vn)C | V ref | V array | <type pur> - * - * INVARIANT: l'effet E contient toutes les variables apparaissant dans - * le programme ET les annotations P et Q - * Si E = { x1,...,xn | y1,...,ym }, les variables x sont les - * variables en lecture seule et y1 les variables modifiées - * les xi sont libres dans P et Q, et les yi,result liées dans Q - * i.e. P = p(x) - * et Q = [y1]...[yn][res]q(x,y,res) - *) - -(* pre and post conditions *) - -type 'a precondition = { p_assert : bool; p_name : Names.name; p_value : 'a } - -type 'a assertion = { a_name : Names.name; a_value : 'a } - -type 'a postcondition = 'a assertion - -type predicate = constr assertion - -(* binders *) - -type 'a binder_type = - BindType of 'a - | BindSet - | Untyped - -type 'a binder = Names.identifier * 'a binder_type - -(* variant *) - -type variant = constr * constr * constr (* phi, R, A *) - -(* types des valeurs *) - -type 'a ml_type_v = - Ref of 'a ml_type_v - | Array of 'a * 'a ml_type_v (* size x type *) - | Arrow of 'a ml_type_v binder list * 'a ml_type_c - - | TypePure of 'a - -(* et type des calculs *) - -and 'a ml_type_c = - (Names.identifier * 'a ml_type_v) - * Peffect.t - * ('a precondition list) * ('a postcondition option) - -(* at beginning they contain Coq AST but they become constr after typing *) -type type_v = constr ml_type_v -type type_c = constr ml_type_c - - diff --git a/contrib/correctness/ptyping.ml b/contrib/correctness/ptyping.ml deleted file mode 100644 index 91c1f293..00000000 --- a/contrib/correctness/ptyping.ml +++ /dev/null @@ -1,600 +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 *) -(************************************************************************) - -(* Certification of Imperative Programs / Jean-Christophe Filliâtre *) - -(* $Id: ptyping.ml 5920 2004-07-16 20:01:26Z herbelin $ *) - -open Pp -open Util -open Names -open Term -open Termops -open Environ -open Constrintern -open Himsg -open Proof_trees -open Topconstr - -open Pmisc -open Putil -open Prename -open Ptype -open Past -open Penv -open Peffect -open Pcicenv - -(* Ce module implante le jugement Gamma |-a e : kappa de la thèse. - * Les annotations passent du type CoqAst.t au type Term.constr ici. - * Les post-conditions sont abstraites par rapport au résultat. *) - -let simplify_type_of env sigma t = - Reductionops.nf_betaiota (Typing.type_of env sigma t) - -let just_reads e = - difference (get_reads e) (get_writes e) - -let type_v_sup loc t1 t2 = - if t1 = t2 then - t1 - else - Perror.if_branches loc - -let typed_var ren env (phi,r) = - let sign = Pcicenv.before_after_sign_of ren env in - let a = simplify_type_of (Global.env_of_context sign) Evd.empty phi in - (phi,r,a) - -(* Application de fonction *) - -let rec convert = function - | (TypePure c1, TypePure c2) -> - Reductionops.is_conv (Global.env ()) Evd.empty c1 c2 - | (Ref v1, Ref v2) -> - convert (v1,v2) - | (Array (s1,v1), Array (s2,v2)) -> - (Reductionops.is_conv (Global.env ()) Evd.empty s1 s2) && (convert (v1,v2)) - | (v1,v2) -> v1 = v2 - -let effect_app ren env f args = - let n = List.length args in - let tf = - let ((_,v),_,_,_) = f.info.kappa in - match v with TypePure c -> v_of_constr c | _ -> v - in - let bl,c = - match tf with - Arrow (bl, c) -> - if List.length bl <> n then Perror.partial_app f.loc; - bl,c - | _ -> Perror.app_of_non_function f.loc - in - let check_type loc v t so = - let v' = type_v_rsubst so v in - if not (convert (v',t)) then Perror.expected_type loc (pp_type_v v') - in - let s,so,ok = - (* s est la substitution des références, so celle des autres arg. - * ok nous dit si les arguments sont sans effet i.e. des expressions *) - List.fold_left - (fun (s,so,ok) (b,a) -> - match b,a with - (id,BindType (Ref _ | Array _ as v)), Refarg id' -> - let ta = type_in_env env id' in - check_type f.loc v ta so; - (id,id')::s, so, ok - | _, Refarg _ -> Perror.should_be_a_variable f.loc - | (id,BindType v), Term t -> - let ((_,ta),_,_,_) = t.info.kappa in - check_type t.loc v ta so; - (match t.desc with - Expression c -> s, (id,c)::so, ok - | _ -> s,so,false) - | (id,BindSet), Type v -> - let c = Pmonad.trad_ml_type_v ren env v in - s, (id,c)::so, ok - | (id,BindSet), Term t -> Perror.expects_a_type id t.loc - | (id,BindType _), Type _ -> Perror.expects_a_term id - | (_,Untyped), _ -> invalid_arg "effects_app") - ([],[],true) - (List.combine bl args) - in - let (id,v),ef,pre,post = type_c_subst s c in - (bl,c), (s,so,ok), ((id,type_v_rsubst so v),ef,pre,post) - -(* Execution of a Coq AST. Returns value and type. - * Also returns its variables *) - -let state_coq_ast sign a = - let env = Global.env_of_context sign in - let j = - reraise_with_loc (constr_loc a) (judgment_of_rawconstr Evd.empty env) a in - let ids = global_vars env j.uj_val in - j.uj_val, j.uj_type, ids - -(* [is_pure p] tests wether the program p is an expression or not. *) - -let type_of_expression ren env c = - let sign = now_sign_of ren env in - simplify_type_of (Global.env_of_context sign) Evd.empty c - -let rec is_pure_type_v = function - TypePure _ -> true - | Arrow (bl,c) -> List.for_all is_pure_arg bl & is_pure_type_c c - | Ref _ | Array _ -> false -and is_pure_arg = function - (_,BindType v) -> is_pure_type_v v - | (_,BindSet) -> true - | (_,Untyped) -> false -and is_pure_type_c = function - (_,v),_,[],None -> is_pure_type_v v - | _ -> false - -let rec is_pure_desc ren env = function - Variable id -> - not (is_in_env env id) or (is_pure_type_v (type_in_env env id)) - | Expression c -> - (c = isevar) or (is_pure_cci (type_of_expression ren env c)) - | Acc _ -> true - | TabAcc (_,_,p) -> is_pure ren env p - | Apply (p,args) -> - is_pure ren env p & List.for_all (is_pure_arg ren env) args - | SApp _ | Aff _ | TabAff _ | Seq _ | While _ | If _ - | Lam _ | LetRef _ | Let _ | LetRec _ -> false - | Debug (_,p) -> is_pure ren env p - | PPoint (_,d) -> is_pure_desc ren env d -and is_pure ren env p = - p.pre = [] & p.post = None & is_pure_desc ren env p.desc -and is_pure_arg ren env = function - Term p -> is_pure ren env p - | Type _ -> true - | Refarg _ -> false - -(* [state_var ren env (phi,r)] returns a tuple (e,(phi',r')) - * where e is the effect of the variant phi and phi',r' the corresponding - * constr of phi and r. - *) - -let state_var ren env (phi,r) = - let sign = Pcicenv.before_after_sign_of ren env in - let phi',_,ids = state_coq_ast sign phi in - let ef = List.fold_left - (fun e id -> - if is_mutable_in_env env id then Peffect.add_read id e else e) - Peffect.bottom ids in - let r',_,_ = state_coq_ast (Global.named_context ()) r in - ef,(phi',r') - -(* [state_pre ren env pl] returns a pair (e,c) where e is the effect of the - * pre-conditions list pl and cl the corresponding constrs not yet abstracted - * over the variables xi (i.e. c NOT [x1]...[xn]c !) - *) - -let state_pre ren env pl = - let state e p = - let sign = Pcicenv.before_sign_of ren env in - let cc,_,ids = state_coq_ast sign p.p_value in - let ef = List.fold_left - (fun e id -> - if is_mutable_in_env env id then - Peffect.add_read id e - else if is_at id then - let uid,_ = un_at id in - if is_mutable_in_env env uid then - Peffect.add_read uid e - else - e - else - e) - e ids - in - ef,{ p_assert = p.p_assert; p_name = p.p_name; p_value = cc } - in - List.fold_left - (fun (e,cl) p -> let ef,c = state e p in (ef,c::cl)) - (Peffect.bottom,[]) pl - -let state_assert ren env a = - let p = pre_of_assert true a in - let e,l = state_pre ren env [p] in - e,assert_of_pre (List.hd l) - -let state_inv ren env = function - None -> Peffect.bottom, None - | Some i -> let e,p = state_assert ren env i in e,Some p - -(* [state_post ren env (id,v,ef) q] returns a pair (e,c) - * where e is the effect of the - * post-condition q and c the corresponding constr not yet abstracted - * over the variables xi, yi and result. - * Moreover the RW variables not appearing in ef have been replaced by - * RO variables, and (id,v) is the result - *) - -let state_post ren env (id,v,ef) = function - None -> Peffect.bottom, None - | Some q -> - let v' = Pmonad.trad_ml_type_v ren env v in - let sign = Pcicenv.before_after_result_sign_of (Some (id,v')) ren env in - let cc,_,ids = state_coq_ast sign q.a_value in - let ef,c = - List.fold_left - (fun (e,c) id -> - if is_mutable_in_env env id then - if is_write ef id then - Peffect.add_write id e, c - else - Peffect.add_read id e, - subst_in_constr [id,at_id id ""] c - else if is_at id then - let uid,_ = un_at id in - if is_mutable_in_env env uid then - Peffect.add_read uid e, c - else - e,c - else - e,c) - (Peffect.bottom,cc) ids - in - let c = abstract [id,v'] c in - ef, Some { a_name = q.a_name; a_value = c } - -(* transformation of AST into constr in types V and C *) - -let rec cic_type_v env ren = function - | Ref v -> Ref (cic_type_v env ren v) - | Array (com,v) -> - let sign = Pcicenv.now_sign_of ren env in - let c = interp_constr Evd.empty (Global.env_of_context sign) com in - Array (c, cic_type_v env ren v) - | Arrow (bl,c) -> - let bl',ren',env' = - List.fold_left - (fun (bl,ren,env) b -> - let b' = cic_binder env ren b in - let env' = traverse_binders env [b'] in - let ren' = initial_renaming env' in - b'::bl,ren',env') - ([],ren,env) bl - in - let c' = cic_type_c env' ren' c in - Arrow (List.rev bl',c') - | TypePure com -> - let sign = Pcicenv.cci_sign_of ren env in - let c = interp_constr Evd.empty (Global.env_of_context sign) com in - TypePure c - -and cic_type_c env ren ((id,v),e,p,q) = - let v' = cic_type_v env ren v in - let cv = Pmonad.trad_ml_type_v ren env v' in - let efp,p' = state_pre ren env p in - let efq,q' = state_post ren env (id,v',e) q in - let ef = Peffect.union e (Peffect.union efp efq) in - ((id,v'),ef,p',q') - -and cic_binder env ren = function - | (id,BindType v) -> - let v' = cic_type_v env ren v in - let env' = add (id,v') env in - let ren' = initial_renaming env' in - (id, BindType v') - | (id,BindSet) -> (id,BindSet) - | (id,Untyped) -> (id,Untyped) - -and cic_binders env ren = function - [] -> [] - | b::bl -> - let b' = cic_binder env ren b in - let env' = traverse_binders env [b'] in - let ren' = initial_renaming env' in - b' :: (cic_binders env' ren' bl) - - -(* The case of expressions. - * - * Expressions are programs without neither effects nor pre/post conditions. - * But access to variables are allowed. - * - * Here we transform an expression into the corresponding constr, - * the variables still appearing as VAR (they will be abstracted in - * Mlise.trad) - * We collect the pre-conditions (e<N for t[e]) as we traverse the term. - * We also return the effect, which does contain only *read* variables. - *) - -let states_expression ren env expr = - let rec effect pl = function - | Variable id -> - (if is_global id then constant (string_of_id id) else mkVar id), - pl, Peffect.bottom - | Expression c -> c, pl, Peffect.bottom - | Acc id -> mkVar id, pl, Peffect.add_read id Peffect.bottom - | TabAcc (_,id,p) -> - let c,pl,ef = effect pl p.desc in - let pre = Pmonad.make_pre_access ren env id c in - Pmonad.make_raw_access ren env (id,id) c, - (anonymous_pre true pre)::pl, Peffect.add_read id ef - | Apply (p,args) -> - let a,pl,e = effect pl p.desc in - let args,pl,e = - List.fold_right - (fun arg (l,pl,e) -> - match arg with - Term p -> - let carg,pl,earg = effect pl p.desc in - carg::l,pl,Peffect.union e earg - | Type v -> - let v' = cic_type_v env ren v in - (Pmonad.trad_ml_type_v ren env v')::l,pl,e - | Refarg _ -> assert false) - args ([],pl,e) - in - Term.applist (a,args),pl,e - | _ -> invalid_arg "Ptyping.states_expression" - in - let e0,pl0 = state_pre ren env expr.pre in - let c,pl,e = effect [] expr.desc in - let sign = Pcicenv.before_sign_of ren env in - (*i WAS - let c = (Trad.ise_resolve true empty_evd [] (gLOB sign) c)._VAL in - i*) - let ty = simplify_type_of (Global.env_of_context sign) Evd.empty c in - let v = TypePure ty in - let ef = Peffect.union e0 e in - Expression c, (v,ef), pl0@pl - - -(* We infer here the type with effects. - * The type of types with effects (ml_type_c) is defined in the module ProgAst. - * - * A program of the shape {P} e {Q} has a type - * - * V, E, {None|Some P}, {None|Some Q} - * - * where - V is the type of e - * - E = (I,O) is the effect; the input I contains - * all the input variables appearing in P,e and Q; - * the output O contains variables possibly modified in e - * - P is NOT abstracted - * - Q = [y'1]...[y'k][result]Q where O = {y'j} - * i.e. Q is only abstracted over the output and the result - * the other variables now refer to value BEFORE - *) - -let verbose_fix = ref false - -let rec states_desc ren env loc = function - - Expression c -> - let ty = type_of_expression ren env c in - let v = v_of_constr ty in - Expression c, (v,Peffect.bottom) - - | Acc _ -> - failwith "Ptyping.states: term is supposed not to be pure" - - | Variable id -> - let v = type_in_env env id in - let ef = Peffect.bottom in - Variable id, (v,ef) - - | Aff (x, e1) -> - Perror.check_for_reference loc x (type_in_env env x); - let s_e1 = states ren env e1 in - let _,e,_,_ = s_e1.info.kappa in - let ef = add_write x e in - let v = constant_unit () in - Aff (x, s_e1), (v, ef) - - | TabAcc (check, x, e) -> - let s_e = states ren env e in - let _,efe,_,_ = s_e.info.kappa in - let ef = Peffect.add_read x efe in - let _,ty = dearray_type (type_in_env env x) in - TabAcc (check, x, s_e), (ty, ef) - - | TabAff (check, x, e1, e2) -> - let s_e1 = states ren env e1 in - let s_e2 = states ren env e2 in - let _,ef1,_,_ = s_e1.info.kappa in - let _,ef2,_,_ = s_e2.info.kappa in - let ef = Peffect.add_write x (Peffect.union ef1 ef2) in - let v = constant_unit () in - TabAff (check, x, s_e1, s_e2), (v,ef) - - | Seq bl -> - let bl,v,ef,_ = states_block ren env bl in - Seq bl, (v,ef) - - | While(b, invopt, var, bl) -> - let efphi,(cvar,r') = state_var ren env var in - let ren' = next ren [] in - let s_b = states ren' env b in - let s_bl,_,ef_bl,_ = states_block ren' env bl in - let cb = s_b.info.kappa in - let efinv,inv = state_inv ren env invopt in - let _,efb,_,_ = s_b.info.kappa in - let ef = - Peffect.union (Peffect.union ef_bl efb) (Peffect.union efinv efphi) - in - let v = constant_unit () in - let cvar = - let al = List.map (fun id -> (id,at_id id "")) (just_reads ef) in - subst_in_constr al cvar - in - While (s_b,inv,(cvar,r'),s_bl), (v,ef) - - | Lam ([],_) -> - failwith "Ptyping.states: abs. should have almost one binder" - - | Lam (bl, e) -> - let bl' = cic_binders env ren bl in - let env' = traverse_binders env bl' in - let ren' = initial_renaming env' in - let s_e = states ren' env' e in - let v = make_arrow bl' s_e.info.kappa in - let ef = Peffect.bottom in - Lam(bl',s_e), (v,ef) - - (* Connectives AND and OR *) - | SApp ([Variable id], [e1;e2]) -> - let s_e1 = states ren env e1 - and s_e2 = states ren env e2 in - let (_,ef1,_,_) = s_e1.info.kappa - and (_,ef2,_,_) = s_e2.info.kappa in - let ef = Peffect.union ef1 ef2 in - SApp ([Variable id], [s_e1; s_e2]), - (TypePure (constant "bool"), ef) - - (* Connective NOT *) - | SApp ([Variable id], [e]) -> - let s_e = states ren env e in - let (_,ef,_,_) = s_e.info.kappa in - SApp ([Variable id], [s_e]), - (TypePure (constant "bool"), ef) - - | SApp _ -> invalid_arg "Ptyping.states (SApp)" - - (* ATTENTION: - Si un argument réel de type ref. correspond à une ref. globale - modifiée par la fonction alors la traduction ne sera pas correcte. - Exemple: - f=[x:ref Int]( r := !r+1 ; x := !x+1) modifie r et son argument x - donc si on l'applique à r justement, elle ne modifiera que r - mais le séquencement ne sera pas correct. *) - - | Apply (f, args) -> - let s_f = states ren env f in - let _,eff,_,_ = s_f.info.kappa in - let s_args = List.map (states_arg ren env) args in - let ef_args = - List.map - (function Term t -> let (_,e,_,_) = t.info.kappa in e - | _ -> Peffect.bottom) - s_args - in - let _,_,((_,tapp),efapp,_,_) = effect_app ren env s_f s_args in - let ef = - Peffect.compose (List.fold_left Peffect.compose eff ef_args) efapp - in - Apply (s_f, s_args), (tapp, ef) - - | LetRef (x, e1, e2) -> - let s_e1 = states ren env e1 in - let (_,v1),ef1,_,_ = s_e1.info.kappa in - let env' = add (x,Ref v1) env in - let ren' = next ren [x] in - let s_e2 = states ren' env' e2 in - let (_,v2),ef2,_,_ = s_e2.info.kappa in - Perror.check_for_let_ref loc v2; - let ef = Peffect.compose ef1 (Peffect.remove ef2 x) in - LetRef (x, s_e1, s_e2), (v2,ef) - - | Let (x, e1, e2) -> - let s_e1 = states ren env e1 in - let (_,v1),ef1,_,_ = s_e1.info.kappa in - Perror.check_for_not_mutable e1.loc v1; - let env' = add (x,v1) env in - let s_e2 = states ren env' e2 in - let (_,v2),ef2,_,_ = s_e2.info.kappa in - let ef = Peffect.compose ef1 ef2 in - Let (x, s_e1, s_e2), (v2,ef) - - | If (b, e1, e2) -> - let s_b = states ren env b in - let s_e1 = states ren env e1 - and s_e2 = states ren env e2 in - let (_,tb),efb,_,_ = s_b.info.kappa in - let (_,t1),ef1,_,_ = s_e1.info.kappa in - let (_,t2),ef2,_,_ = s_e2.info.kappa in - let ef = Peffect.compose efb (disj ef1 ef2) in - let v = type_v_sup loc t1 t2 in - If (s_b, s_e1, s_e2), (v,ef) - - | LetRec (f,bl,v,var,e) -> - let bl' = cic_binders env ren bl in - let env' = traverse_binders env bl' in - let ren' = initial_renaming env' in - let v' = cic_type_v env' ren' v in - let efvar,var' = state_var ren' env' var in - let phi0 = phi_name () in - let tvar = typed_var ren env' var' in - (* effect for a let/rec construct is computed as a fixpoint *) - let rec state_rec c = - let tf = make_arrow bl' c in - let env'' = add_recursion (f,(phi0,tvar)) (add (f,tf) env') in - let s_e = states ren' env'' e in - if s_e.info.kappa = c then - s_e - else begin - if !verbose_fix then begin msgnl (pp_type_c s_e.info.kappa) end ; - state_rec s_e.info.kappa - end - in - let s_e = state_rec ((result_id,v'),efvar,[],None) in - let tf = make_arrow bl' s_e.info.kappa in - LetRec (f,bl',v',var',s_e), (tf,Peffect.bottom) - - | PPoint (s,d) -> - let ren' = push_date ren s in - states_desc ren' env loc d - - | Debug _ -> failwith "Ptyping.states: Debug: TODO" - - -and states_arg ren env = function - Term a -> let s_a = states ren env a in Term s_a - | Refarg id -> Refarg id - | Type v -> let v' = cic_type_v env ren v in Type v' - - -and states ren env expr = - (* Here we deal with the pre- and post- conditions: - * we add their effects to the effects of the program *) - let (d,(v,e),p1) = - if is_pure_desc ren env expr.desc then - states_expression ren env expr - else - let (d,ve) = states_desc ren env expr.loc expr.desc in (d,ve,[]) - in - let (ep,p) = state_pre ren env expr.pre in - let (eq,q) = state_post ren env (result_id,v,e) expr.post in - let e' = Peffect.union e (Peffect.union ep eq) in - let p' = p1 @ p in - let tinfo = { env = env; kappa = ((result_id,v),e',p',q) } in - { desc = d; - loc = expr.loc; - pre = p'; post = q; (* on les conserve aussi ici pour prog_wp *) - info = tinfo } - - -and states_block ren env bl = - let rec ef_block ren tyres = function - [] -> - begin match tyres with - Some ty -> [],ty,Peffect.bottom,ren - | None -> failwith "a block should contain at least one statement" - end - | (Assert p)::block -> - let ep,c = state_assert ren env p in - let bl,t,ef,ren' = ef_block ren tyres block in - (Assert c)::bl,t,Peffect.union ep ef,ren' - | (Label s)::block -> - let ren' = push_date ren s in - let bl,t,ef,ren'' = ef_block ren' tyres block in - (Label s)::bl,t,ef,ren'' - | (Statement e)::block -> - let s_e = states ren env e in - let (_,t),efe,_,_ = s_e.info.kappa in - let ren' = next ren (get_writes efe) in - let bl,t,ef,ren'' = ef_block ren' (Some t) block in - (Statement s_e)::bl,t,Peffect.compose efe ef,ren'' - in - ef_block ren None bl - diff --git a/contrib/correctness/ptyping.mli b/contrib/correctness/ptyping.mli deleted file mode 100644 index eaf548b1..00000000 --- a/contrib/correctness/ptyping.mli +++ /dev/null @@ -1,36 +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 *) -(************************************************************************) - -(* Certification of Imperative Programs / Jean-Christophe Filliâtre *) - -(* $Id: ptyping.mli 5920 2004-07-16 20:01:26Z herbelin $ *) - -open Names -open Term -open Topconstr - -open Ptype -open Past -open Penv - -(* This module realizes type and effect inference *) - -val cic_type_v : local_env -> Prename.t -> constr_expr ml_type_v -> type_v - -val effect_app : Prename.t -> local_env - -> (typing_info,'b) Past.t - -> (typing_info,constr) arg list - -> (type_v binder list * type_c) - * ((identifier*identifier) list * (identifier*constr) list * bool) - * type_c - -val typed_var : Prename.t -> local_env -> constr * constr -> variant - -val type_of_expression : Prename.t -> local_env -> constr -> constr - -val states : Prename.t -> local_env -> program -> typed_program diff --git a/contrib/correctness/putil.ml b/contrib/correctness/putil.ml deleted file mode 100644 index 18c3ba35..00000000 --- a/contrib/correctness/putil.ml +++ /dev/null @@ -1,303 +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 *) -(************************************************************************) - -(* Certification of Imperative Programs / Jean-Christophe Filliâtre *) - -(* $Id: putil.ml 8752 2006-04-27 19:37:33Z herbelin $ *) - -open Util -open Names -open Nameops -open Term -open Termops -open Pattern -open Matching -open Hipattern -open Environ - -open Pmisc -open Ptype -open Past -open Penv -open Prename - -let is_mutable = function Ref _ | Array _ -> true | _ -> false -let is_pure = function TypePure _ -> true | _ -> false - -let named_app f x = { a_name = x.a_name; a_value = (f x.a_value) } - -let pre_app f x = - { p_assert = x.p_assert; p_name = x.p_name; p_value = f x.p_value } - -let post_app = named_app - -let anonymous x = { a_name = Anonymous; a_value = x } - -let anonymous_pre b x = { p_assert = b; p_name = Anonymous; p_value = x } - -let force_name f x = - option_map (fun q -> { a_name = Name (f q.a_name); a_value = q.a_value }) x - -let force_post_name x = force_name post_name x - -let force_bool_name x = - force_name (function Name id -> id | Anonymous -> bool_name()) x - -let out_post = function - Some { a_value = x } -> x - | None -> invalid_arg "out_post" - -let pre_of_assert b x = - { p_assert = b; p_name = x.a_name; p_value = x.a_value } - -let assert_of_pre x = - { a_name = x.p_name; a_value = x.p_value } - -(* Some generic functions on programs *) - -let is_mutable_in_env env id = - (is_in_env env id) & (is_mutable (type_in_env env id)) - -let now_vars env c = - Util.map_succeed - (function id -> if is_mutable_in_env env id then id else failwith "caught") - (global_vars (Global.env()) c) - -let make_before_after c = - let ids = global_vars (Global.env()) c in - let al = - Util.map_succeed - (function id -> - if is_at id then - match un_at id with (uid,"") -> (id,uid) | _ -> failwith "caught" - else failwith "caught") - ids - in - subst_in_constr al c - -(* [apply_pre] and [apply_post] instantiate pre- and post- conditions - * according to a given renaming of variables (and a date that means - * `before' in the case of the post-condition). - *) - -let make_assoc_list ren env on_prime ids = - List.fold_left - (fun al id -> - if is_mutable_in_env env id then - (id,current_var ren id)::al - else if is_at id then - let uid,d = un_at id in - if is_mutable_in_env env uid then - (match d with - "" -> (id,on_prime ren uid) - | _ -> (id,var_at_date ren d uid))::al - else - al - else - al) - [] ids - -let apply_pre ren env c = - let ids = global_vars (Global.env()) c.p_value in - let al = make_assoc_list ren env current_var ids in - { p_assert = c.p_assert; p_name = c.p_name; - p_value = subst_in_constr al c.p_value } - -let apply_assert ren env c = - let ids = global_vars (Global.env()) c.a_value in - let al = make_assoc_list ren env current_var ids in - { a_name = c.a_name; a_value = subst_in_constr al c.a_value } - -let apply_post ren env before c = - let ids = global_vars (Global.env()) c.a_value in - let al = - make_assoc_list ren env (fun r uid -> var_at_date r before uid) ids in - { a_name = c.a_name; a_value = subst_in_constr al c.a_value } - -(* [traverse_binder ren env bl] updates renaming [ren] and environment [env] - * as we cross the binders [bl] - *) - -let rec traverse_binders env = function - [] -> env - | (id,BindType v)::rem -> - traverse_binders (add (id,v) env) rem - | (id,BindSet)::rem -> - traverse_binders (add_set id env) rem - | (_,Untyped)::_ -> - invalid_arg "traverse_binders" - -let initial_renaming env = - let ids = Penv.fold_all (fun (id,_) l -> id::l) env [] in - update empty_ren "0" ids - - -(* Substitutions *) - -let rec type_c_subst s ((id,t),e,p,q) = - let s' = s @ List.map (fun (x,x') -> (at_id x "", at_id x' "")) s in - (id, type_v_subst s t), Peffect.subst s e, - List.map (pre_app (subst_in_constr s)) p, - option_map (post_app (subst_in_constr s')) q - -and type_v_subst s = function - Ref v -> Ref (type_v_subst s v) - | Array (n,v) -> Array (n,type_v_subst s v) - | Arrow (bl,c) -> Arrow(List.map (binder_subst s) bl, type_c_subst s c) - | (TypePure _) as v -> v - -and binder_subst s = function - (n, BindType v) -> (n, BindType (type_v_subst s v)) - | b -> b - -(* substitution of constr by others *) - -let rec type_c_rsubst s ((id,t),e,p,q) = - (id, type_v_rsubst s t), e, - List.map (pre_app (real_subst_in_constr s)) p, - option_map (post_app (real_subst_in_constr s)) q - -and type_v_rsubst s = function - Ref v -> Ref (type_v_rsubst s v) - | Array (n,v) -> Array (real_subst_in_constr s n,type_v_rsubst s v) - | Arrow (bl,c) -> Arrow(List.map (binder_rsubst s) bl, type_c_rsubst s c) - | TypePure c -> TypePure (real_subst_in_constr s c) - -and binder_rsubst s = function - | (n, BindType v) -> (n, BindType (type_v_rsubst s v)) - | b -> b - -(* make_arrow bl c = (x1:V1)...(xn:Vn)c *) - -let make_arrow bl c = match bl with - | [] -> invalid_arg "make_arrow: no binder" - | _ -> Arrow (bl,c) - -(* misc. functions *) - -let deref_type = function - | Ref v -> v - | _ -> invalid_arg "deref_type" - -let dearray_type = function - | Array (size,v) -> size,v - | _ -> invalid_arg "dearray_type" - -let constant_unit () = TypePure (constant "unit") - -let id_from_name = function Name id -> id | Anonymous -> (id_of_string "X") - -(* v_of_constr : traduit un type CCI en un type ML *) - -(* TODO: faire un test plus serieux sur le type des objets Coq *) -let rec is_pure_cci c = match kind_of_term c with - | Cast (c,_) -> is_pure_cci c - | Prod(_,_,c') -> is_pure_cci c' - | Rel _ | Ind _ | Const _ -> true (* heu... *) - | App _ -> not (is_matching_sigma c) - | _ -> Util.error "CCI term not acceptable in programs" - -let rec v_of_constr c = match kind_of_term c with - | Cast (c,_) -> v_of_constr c - | Prod _ -> - let revbl,t2 = Term.decompose_prod c in - let bl = - List.map - (fun (name,t1) -> (id_from_name name, BindType (v_of_constr t1))) - (List.rev revbl) - in - let vars = List.rev (List.map (fun (id,_) -> mkVar id) bl) in - Arrow (bl, c_of_constr (substl vars t2)) - | Ind _ | Const _ | App _ -> - TypePure c - | _ -> - failwith "v_of_constr: TODO" - -and c_of_constr c = - if is_matching_sigma c then - let (a,q) = match_sigma c in - (result_id, v_of_constr a), Peffect.bottom, [], Some (anonymous q) - else - (result_id, v_of_constr c), Peffect.bottom, [], None - - -(* pretty printers (for debugging purposes) *) - -open Pp -open Util - -let pr_lconstr x = Printer.pr_lconstr_env (Global.env()) x - -let pp_pre = function - [] -> (mt ()) - | l -> - hov 0 (str"pre " ++ - prlist_with_sep (fun () -> (spc ())) - (fun x -> pr_lconstr x.p_value) l) - -let pp_post = function - None -> (mt ()) - | Some c -> hov 0 (str"post " ++ pr_lconstr c.a_value) - -let rec pp_type_v = function - Ref v -> hov 0 (pp_type_v v ++ spc () ++ str"ref") - | Array (cc,v) -> hov 0 (str"array " ++ pr_lconstr cc ++ str" of " ++ pp_type_v v) - | Arrow (b,c) -> - hov 0 (prlist_with_sep (fun () -> (mt ())) pp_binder b ++ - pp_type_c c) - | TypePure c -> pr_lconstr c - -and pp_type_c ((id,v),e,p,q) = - hov 0 (str"returns " ++ pr_id id ++ str":" ++ pp_type_v v ++ spc () ++ - Peffect.pp e ++ spc () ++ pp_pre p ++ spc () ++ pp_post q ++ - spc () ++ str"end") - -and pp_binder = function - id,BindType v -> (str"(" ++ pr_id id ++ str":" ++ pp_type_v v ++ str")") - | id,BindSet -> (str"(" ++ pr_id id ++ str":Set)") - | id,Untyped -> (str"(" ++ pr_id id ++ str")") - -(* pretty-print of cc-terms (intermediate terms) *) - -let rec pp_cc_term = function - CC_var id -> pr_id id - | CC_letin (_,_,bl,c,c1) -> - hov 0 (hov 2 (str"let " ++ - prlist_with_sep (fun () -> (str",")) - (fun (id,_) -> pr_id id) bl ++ - str" =" ++ spc () ++ - pp_cc_term c ++ - str " in") ++ - fnl () ++ - pp_cc_term c1) - | CC_lam (bl,c) -> - hov 2 (prlist (fun (id,_) -> (str"[" ++ pr_id id ++ str"]")) bl ++ - cut () ++ - pp_cc_term c) - | CC_app (f,args) -> - hov 2 (str"(" ++ - pp_cc_term f ++ spc () ++ - prlist_with_sep (fun () -> (spc ())) pp_cc_term args ++ - str")") - | CC_tuple (_,_,cl) -> - hov 2 (str"(" ++ - prlist_with_sep (fun () -> (str"," ++ cut ())) - pp_cc_term cl ++ - str")") - | CC_case (_,b,[e1;e2]) -> - hov 0 (str"if " ++ pp_cc_term b ++ str" then" ++ fnl () ++ - str" " ++ hov 0 (pp_cc_term e1) ++ fnl () ++ - str"else" ++ fnl () ++ - str" " ++ hov 0 (pp_cc_term e2)) - | CC_case _ -> - hov 0 (str"<Case: not yet implemented>") - | CC_expr c -> - hov 0 (pr_lconstr c) - | CC_hole c -> - (str"(?::" ++ pr_lconstr c ++ str")") - diff --git a/contrib/correctness/putil.mli b/contrib/correctness/putil.mli deleted file mode 100644 index 6c487f3f..00000000 --- a/contrib/correctness/putil.mli +++ /dev/null @@ -1,72 +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 *) -(************************************************************************) - -(* Certification of Imperative Programs / Jean-Christophe Filliâtre *) - -(* $Id: putil.mli 5920 2004-07-16 20:01:26Z herbelin $ *) - -open Pp -open Names -open Term -open Pmisc -open Ptype -open Past -open Penv - -val is_mutable : 'a ml_type_v -> bool -val is_pure : 'a ml_type_v -> bool - -val named_app : ('a -> 'b) -> 'a assertion -> 'b assertion -val pre_app : ('a -> 'b) -> 'a precondition -> 'b precondition -val post_app : ('a -> 'b) -> 'a postcondition -> 'b postcondition - -val anonymous : 'a -> 'a assertion -val anonymous_pre : bool -> 'a -> 'a precondition -val out_post : 'a postcondition option -> 'a -val pre_of_assert : bool -> 'a assertion -> 'a precondition -val assert_of_pre : 'a precondition -> 'a assertion - -val force_post_name : 'a postcondition option -> 'a postcondition option -val force_bool_name : 'a postcondition option -> 'a postcondition option - -val make_before_after : constr -> constr - -val traverse_binders : local_env -> (type_v binder) list -> local_env -val initial_renaming : local_env -> Prename.t - -val apply_pre : Prename.t -> local_env -> constr precondition -> - constr precondition -val apply_post : Prename.t -> local_env -> string -> constr postcondition -> - constr postcondition -val apply_assert : Prename.t -> local_env -> constr assertion -> - constr assertion - -val type_v_subst : (identifier * identifier) list -> type_v -> type_v -val type_c_subst : (identifier * identifier) list -> type_c -> type_c - -val type_v_rsubst : (identifier * constr) list -> type_v -> type_v -val type_c_rsubst : (identifier * constr) list -> type_c -> type_c - -val make_arrow : ('a ml_type_v binder) list -> 'a ml_type_c -> 'a ml_type_v - -val is_mutable_in_env : local_env -> identifier -> bool -val now_vars : local_env -> constr -> identifier list - -val deref_type : 'a ml_type_v -> 'a ml_type_v -val dearray_type : 'a ml_type_v -> 'a * 'a ml_type_v -val constant_unit : unit -> constr ml_type_v -val v_of_constr : constr -> constr ml_type_v -val c_of_constr : constr -> constr ml_type_c -val is_pure_cci : constr -> bool - -(* pretty printers *) - -val pp_type_v : type_v -> std_ppcmds -val pp_type_c : type_c -> std_ppcmds -val pp_cc_term : cc_term -> std_ppcmds - diff --git a/contrib/correctness/pwp.ml b/contrib/correctness/pwp.ml deleted file mode 100644 index f422c5cd..00000000 --- a/contrib/correctness/pwp.ml +++ /dev/null @@ -1,347 +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 *) -(************************************************************************) - -(* Certification of Imperative Programs / Jean-Christophe Filliâtre *) - -(* $Id: pwp.ml 8752 2006-04-27 19:37:33Z herbelin $ *) - -open Util -open Names -open Libnames -open Term -open Termops -open Environ -open Nametab - -open Pmisc -open Ptype -open Past -open Putil -open Penv -open Peffect -open Ptyping -open Prename - -(* In this module: - * - we try to insert more annotations to achieve a greater completeness; - * - we recursively propagate annotations inside programs; - * - we normalize boolean expressions. - * - * The propagation schemas are the following: - * - * 1. (f a1 ... an) -> (f a1 ... an) {Qf} if the ai are functional - * - * 2. (if e1 then e2 else e3) {Q} -> (if e1 then e2 {Q} else e3 {Q}) {Q} - * - * 3. (let x = e1 in e2) {Q} -> (let x = e1 in e2 {Q}) {Q} - *) - -(* force a post-condition *) -let update_post env top ef c = - let i,o = Peffect.get_repr ef in - let al = - List.fold_left - (fun l id -> - if is_mutable_in_env env id then - if is_write ef id then l else (id,at_id id "")::l - else if is_at id then - let (uid,d) = un_at id in - if is_mutable_in_env env uid & d="" then - (id,at_id uid top)::l - else - l - else - l) - [] (global_vars (Global.env()) c) - in - subst_in_constr al c - -let force_post up env top q e = - let (res,ef,p,_) = e.info.kappa in - let q' = - if up then option_map (named_app (update_post env top ef)) q else q - in - let i = { env = e.info.env; kappa = (res,ef,p,q') } in - { desc = e.desc; pre = e.pre; post = q'; loc = e.loc; info = i } - -(* put a post-condition if none is present *) -let post_if_none_up env top q = function - | { post = None } as p -> force_post true env top q p - | p -> p - -let post_if_none env q = function - | { post = None } as p -> force_post false env "" q p - | p -> p - -(* [annotation_candidate p] determines if p is a candidate for a - * post-condition *) - -let annotation_candidate = function - | { desc = If _ | Let _ | LetRef _ ; post = None } -> true - | _ -> false - -(* [extract_pre p] erase the pre-condition of p and returns it *) -let extract_pre pr = - let (v,e,p,q) = pr.info.kappa in - { desc = pr.desc; pre = []; post = pr.post; loc = pr.loc; - info = { env = pr.info.env; kappa = (v,e,[],q) } }, - p - -(* adds some pre-conditions *) -let add_pre p1 pr = - let (v,e,p,q) = pr.info.kappa in - let p' = p1 @ p in - { desc = pr.desc; pre = p'; post = pr.post; loc = pr.loc; - info = { env = pr.info.env; kappa = (v,e,p',q) } } - -(* change the statement *) -let change_desc p d = - { desc = d; pre = p.pre; post = p.post; loc = p.loc; info = p.info } - -let create_bool_post c = - Some { a_value = c; a_name = Name (bool_name()) } - -(* [normalize_boolean b] checks if the boolean expression b (of type bool) is - * annotated, and if it is not the case tries to add the annotation - * (if result then c=true else c=false) if b is an expression c. - *) - -let is_bool = function - | TypePure c -> - (match kind_of_term (strip_outer_cast c) with - | Ind op -> - string_of_id (id_of_global (IndRef op)) = "bool" - | _ -> false) - | _ -> false - -let normalize_boolean ren env b = - let ((res,v),ef,p,q) = b.info.kappa in - Perror.check_no_effect b.loc ef; - if is_bool v then - match q with - | Some _ -> - (* il y a une annotation : on se contente de lui forcer un nom *) - let q = force_bool_name q in - { desc = b.desc; pre = b.pre; post = q; loc = b.loc; - info = { env = b.info.env; kappa = ((res,v),ef,p,q) } } - | None -> begin - (* il n'y a pas d'annotation : on cherche à en mettre une *) - match b.desc with - Expression c -> - let c' = Term.applist (constant "annot_bool",[c]) in - let ty = type_of_expression ren env c' in - let (_,q') = Hipattern.match_sigma ty in - let q' = Some { a_value = q'; a_name = Name (bool_name()) } in - { desc = Expression c'; - pre = b.pre; post = q'; loc = b.loc; - info = { env = b.info.env; kappa = ((res, v),ef,p,q') } } - | _ -> b - end - else - Perror.should_be_boolean b.loc - -(* [decomp_boolean c] returns the specs R and S of a boolean expression *) - -let decomp_boolean = function - | Some { a_value = q } -> - Reductionops.whd_betaiota (Term.applist (q, [constant "true"])), - Reductionops.whd_betaiota (Term.applist (q, [constant "false"])) - | _ -> invalid_arg "Ptyping.decomp_boolean" - -(* top point of a program *) - -let top_point = function - | PPoint (s,_) as p -> s,p - | p -> let s = label_name() in s,PPoint(s,p) - -let top_point_block = function - | (Label s :: _) as b -> s,b - | b -> let s = label_name() in s,(Label s)::b - -let abstract_unit q = abstract [result_id,constant "unit"] q - -(* [add_decreasing env ren ren' phi r bl] adds the decreasing condition - * phi(ren') r phi(ren) - * to the last assertion of the block [bl], which is created if needed - *) - -let add_decreasing env inv (var,r) lab bl = - let ids = now_vars env var in - let al = List.map (fun id -> (id,at_id id lab)) ids in - let var_lab = subst_in_constr al var in - let dec = Term.applist (r, [var;var_lab]) in - let post = match inv with - None -> anonymous dec - | Some i -> { a_value = conj dec i.a_value; a_name = i.a_name } - in - bl @ [ Assert post ] - -(* [post_last_statement env top q bl] annotates the last statement of the - * sequence bl with q if necessary *) - -let post_last_statement env top q bl = - match List.rev bl with - | Statement e :: rem when annotation_candidate e -> - List.rev ((Statement (post_if_none_up env top q e)) :: rem) - | _ -> bl - -(* [propagate_desc] moves the annotations inside the program - * info is the typing information coming from the outside annotations *) -let rec propagate_desc ren info d = - let env = info.env in - let (_,_,p,q) = info.kappa in - match d with - | If (e1,e2,e3) -> - (* propagation number 2 *) - let e1' = normalize_boolean ren env (propagate ren e1) in - if e2.post = None or e3.post = None then - let top = label_name() in - let ren' = push_date ren top in - PPoint (top, If (e1', - propagate ren' (post_if_none_up env top q e2), - propagate ren' (post_if_none_up env top q e3))) - else - If (e1', propagate ren e2, propagate ren e3) - | Aff (x,e) -> - Aff (x, propagate ren e) - | TabAcc (ch,x,e) -> - TabAcc (ch, x, propagate ren e) - | TabAff (ch,x,({desc=Expression c} as e1),e2) -> - let p = Pmonad.make_pre_access ren env x c in - let e1' = add_pre [(anonymous_pre true p)] e1 in - TabAff (false, x, propagate ren e1', propagate ren e2) - | TabAff (ch,x,e1,e2) -> - TabAff (ch, x, propagate ren e1, propagate ren e2) - | Apply (f,l) -> - Apply (propagate ren f, List.map (propagate_arg ren) l) - | SApp (f,l) -> - let l = - List.map (fun e -> normalize_boolean ren env (propagate ren e)) l - in - SApp (f, l) - | Lam (bl,e) -> - Lam (bl, propagate ren e) - | Seq bl -> - let top,bl = top_point_block bl in - let bl = post_last_statement env top q bl in - Seq (propagate_block ren env bl) - | While (b,inv,var,bl) -> - let b = normalize_boolean ren env (propagate ren b) in - let lab,bl = top_point_block bl in - let bl = add_decreasing env inv var lab bl in - While (b,inv,var,propagate_block ren env bl) - | LetRef (x,e1,e2) -> - let top = label_name() in - let ren' = push_date ren top in - PPoint (top, LetRef (x, propagate ren' e1, - propagate ren' (post_if_none_up env top q e2))) - | Let (x,e1,e2) -> - let top = label_name() in - let ren' = push_date ren top in - PPoint (top, Let (x, propagate ren' e1, - propagate ren' (post_if_none_up env top q e2))) - | LetRec (f,bl,v,var,e) -> - LetRec (f, bl, v, var, propagate ren e) - | PPoint (s,d) -> - PPoint (s, propagate_desc ren info d) - | Debug _ | Variable _ - | Acc _ | Expression _ as d -> d - - -(* [propagate] adds new annotations if possible *) -and propagate ren p = - let env = p.info.env in - let p = match p.desc with - | Apply (f,l) -> - let _,(_,so,ok),(_,_,_,qapp) = effect_app ren env f l in - if ok then - let q = option_map (named_app (real_subst_in_constr so)) qapp in - post_if_none env q p - else - p - | _ -> p - in - let d = propagate_desc ren p.info p.desc in - let p = change_desc p d in - match d with - | Aff (x,e) -> - let e1,p1 = extract_pre e in - change_desc (add_pre p1 p) (Aff (x,e1)) - - | TabAff (check, x, ({ desc = Expression _ } as e1), e2) -> - let e1',p1 = extract_pre e1 in - let e2',p2 = extract_pre e2 in - change_desc (add_pre (p1@p2) p) (TabAff (check,x,e1',e2')) - - | While (b,inv,_,_) -> - let _,s = decomp_boolean b.post in - let s = make_before_after s in - let q = match inv with - None -> Some (anonymous s) - | Some i -> Some { a_value = conj i.a_value s; a_name = i.a_name } - in - let q = option_map (named_app abstract_unit) q in - post_if_none env q p - - | SApp ([Variable id], [e1;e2]) - when id = connective_and or id = connective_or -> - let (_,_,_,q1) = e1.info.kappa - and (_,_,_,q2) = e2.info.kappa in - let (r1,s1) = decomp_boolean q1 - and (r2,s2) = decomp_boolean q2 in - let q = - let conn = if id = connective_and then "spec_and" else "spec_or" in - let c = Term.applist (constant conn, [r1; s1; r2; s2]) in - let c = Reduction.whd_betadeltaiota (Global.env()) c in - create_bool_post c - in - let d = - SApp ([Variable id; - Expression (out_post q1); - Expression (out_post q2)], - [e1; e2] ) - in - post_if_none env q (change_desc p d) - - | SApp ([Variable id], [e1]) when id = connective_not -> - let (_,_,_,q1) = e1.info.kappa in - let (r1,s1) = decomp_boolean q1 in - let q = - let c = Term.applist (constant "spec_not", [r1; s1]) in - let c = Reduction.whd_betadeltaiota (Global.env ()) c in - create_bool_post c - in - let d = SApp ([Variable id; Expression (out_post q1)], [ e1 ]) in - post_if_none env q (change_desc p d) - - | _ -> p - -and propagate_arg ren = function - | Type _ | Refarg _ as a -> a - | Term e -> Term (propagate ren e) - - -and propagate_block ren env = function - | [] -> - [] - | (Statement p) :: (Assert q) :: rem when annotation_candidate p -> - (* TODO: plutot p.post = None ? *) - let q' = - let ((id,v),_,_,_) = p.info.kappa in - let tv = Pmonad.trad_ml_type_v ren env v in - named_app (abstract [id,tv]) q - in - let p' = post_if_none env (Some q') p in - (Statement (propagate ren p')) :: (Assert q) - :: (propagate_block ren env rem) - | (Statement p) :: rem -> - (Statement (propagate ren p)) :: (propagate_block ren env rem) - | (Label s as x) :: rem -> - x :: propagate_block (push_date ren s) env rem - | x :: rem -> - x :: propagate_block ren env rem diff --git a/contrib/correctness/pwp.mli b/contrib/correctness/pwp.mli deleted file mode 100644 index 4027a623..00000000 --- a/contrib/correctness/pwp.mli +++ /dev/null @@ -1,18 +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 *) -(************************************************************************) - -(* Certification of Imperative Programs / Jean-Christophe Filliâtre *) - -(* $Id: pwp.mli 5920 2004-07-16 20:01:26Z herbelin $ *) - -open Term -open Penv - -val update_post : local_env -> string -> Peffect.t -> constr -> constr - -val propagate : Prename.t -> typed_program -> typed_program diff --git a/contrib/dp/Dp.v b/contrib/dp/Dp.v new file mode 100644 index 00000000..857c182c --- /dev/null +++ b/contrib/dp/Dp.v @@ -0,0 +1,120 @@ +(* Calls to external decision procedures *) + +Require Export ZArith. +Require Export Classical. + +(* Zenon *) + +(* Copyright 2004 INRIA *) +(* $Id: Dp.v 10739 2008-04-01 14:45:20Z herbelin $ *) + +Lemma zenon_nottrue : + (~True -> False). +Proof. tauto. Qed. + +Lemma zenon_noteq : forall (T : Type) (t : T), + ((t <> t) -> False). +Proof. tauto. Qed. + +Lemma zenon_and : forall P Q : Prop, + (P -> Q -> False) -> (P /\ Q -> False). +Proof. tauto. Qed. + +Lemma zenon_or : forall P Q : Prop, + (P -> False) -> (Q -> False) -> (P \/ Q -> False). +Proof. tauto. Qed. + +Lemma zenon_imply : forall P Q : Prop, + (~P -> False) -> (Q -> False) -> ((P -> Q) -> False). +Proof. tauto. Qed. + +Lemma zenon_equiv : forall P Q : Prop, + (~P -> ~Q -> False) -> (P -> Q -> False) -> ((P <-> Q) -> False). +Proof. tauto. Qed. + +Lemma zenon_notand : forall P Q : Prop, + (~P -> False) -> (~Q -> False) -> (~(P /\ Q) -> False). +Proof. tauto. Qed. + +Lemma zenon_notor : forall P Q : Prop, + (~P -> ~Q -> False) -> (~(P \/ Q) -> False). +Proof. tauto. Qed. + +Lemma zenon_notimply : forall P Q : Prop, + (P -> ~Q -> False) -> (~(P -> Q) -> False). +Proof. tauto. Qed. + +Lemma zenon_notequiv : forall P Q : Prop, + (~P -> Q -> False) -> (P -> ~Q -> False) -> (~(P <-> Q) -> False). +Proof. tauto. Qed. + +Lemma zenon_ex : forall (T : Type) (P : T -> Prop), + (forall z : T, ((P z) -> False)) -> ((exists x : T, (P x)) -> False). +Proof. firstorder. Qed. + +Lemma zenon_all : forall (T : Type) (P : T -> Prop) (t : T), + ((P t) -> False) -> ((forall x : T, (P x)) -> False). +Proof. firstorder. Qed. + +Lemma zenon_notex : forall (T : Type) (P : T -> Prop) (t : T), + (~(P t) -> False) -> (~(exists x : T, (P x)) -> False). +Proof. firstorder. Qed. + +Lemma zenon_notall : forall (T : Type) (P : T -> Prop), + (forall z : T, (~(P z) -> False)) -> (~(forall x : T, (P x)) -> False). +Proof. intros T P Ha Hb. apply Hb. intro. apply NNPP. exact (Ha x). Qed. + +Lemma zenon_equal_base : forall (T : Type) (f : T), f = f. +Proof. auto. Qed. + +Lemma zenon_equal_step : + forall (S T : Type) (fa fb : S -> T) (a b : S), + (fa = fb) -> (a <> b -> False) -> ((fa a) = (fb b)). +Proof. intros. rewrite (NNPP (a = b)). congruence. auto. Qed. + +Lemma zenon_pnotp : forall P Q : Prop, + (P = Q) -> (P -> ~Q -> False). +Proof. intros P Q Ha. rewrite Ha. auto. Qed. + +Lemma zenon_notequal : forall (T : Type) (a b : T), + (a = b) -> (a <> b -> False). +Proof. auto. Qed. + +Ltac zenon_intro id := + intro id || let nid := fresh in (intro nid; clear nid) +. + +Definition zenon_and_s := fun P Q a b => zenon_and P Q b a. +Definition zenon_or_s := fun P Q a b c => zenon_or P Q b c a. +Definition zenon_imply_s := fun P Q a b c => zenon_imply P Q b c a. +Definition zenon_equiv_s := fun P Q a b c => zenon_equiv P Q b c a. +Definition zenon_notand_s := fun P Q a b c => zenon_notand P Q b c a. +Definition zenon_notor_s := fun P Q a b => zenon_notor P Q b a. +Definition zenon_notimply_s := fun P Q a b => zenon_notimply P Q b a. +Definition zenon_notequiv_s := fun P Q a b c => zenon_notequiv P Q b c a. +Definition zenon_ex_s := fun T P a b => zenon_ex T P b a. +Definition zenon_notall_s := fun T P a b => zenon_notall T P b a. + +Definition zenon_pnotp_s := fun P Q a b c => zenon_pnotp P Q c a b. +Definition zenon_notequal_s := fun T a b x y => zenon_notequal T a b y x. + +(* Ergo *) + +Set Implicit Arguments. +Section congr. + Variable t:Type. +Lemma ergo_eq_concat_1 : + forall (P:t -> Prop) (x y:t), + P x -> x = y -> P y. +Proof. + intros; subst; auto. +Qed. + +Lemma ergo_eq_concat_2 : + forall (P:t -> t -> Prop) (x1 x2 y1 y2:t), + P x1 x2 -> x1 = y1 -> x2 = y2 -> P y1 y2. +Proof. + intros; subst; auto. +Qed. + +End congr. diff --git a/contrib/dp/TODO b/contrib/dp/TODO index 387cacdf..44349e21 100644 --- a/contrib/dp/TODO +++ b/contrib/dp/TODO @@ -21,8 +21,4 @@ TODO BUGS ---- -- value = Some : forall A:Set, A -> option A - - -> eta_expanse échoue sur assert false (ligne 147) - diff --git a/contrib/dp/dp.ml b/contrib/dp/dp.ml index 131dd029..79ffaf3f 100644 --- a/contrib/dp/dp.ml +++ b/contrib/dp/dp.ml @@ -13,6 +13,8 @@ open Util open Pp +open Libobject +open Summary open Term open Tacmach open Tactics @@ -25,12 +27,46 @@ open Coqlib open Hipattern open Libnames open Declarations +open Dp_why let debug = ref false +let set_debug b = debug := b +let trace = ref false +let set_trace b = trace := b +let timeout = ref 10 +let set_timeout n = timeout := n + +let (dp_timeout_obj,_) = + declare_object + {(default_object "Dp_timeout") with + cache_function = (fun (_,x) -> set_timeout x); + load_function = (fun _ (_,x) -> set_timeout x); + export_function = (fun x -> Some x)} + +let dp_timeout x = Lib.add_anonymous_leaf (dp_timeout_obj x) + +let (dp_debug_obj,_) = + declare_object + {(default_object "Dp_debug") with + cache_function = (fun (_,x) -> set_debug x); + load_function = (fun _ (_,x) -> set_debug x); + export_function = (fun x -> Some x)} + +let dp_debug x = Lib.add_anonymous_leaf (dp_debug_obj x) + +let (dp_trace_obj,_) = + declare_object + {(default_object "Dp_trace") with + cache_function = (fun (_,x) -> set_trace x); + load_function = (fun _ (_,x) -> set_trace x); + export_function = (fun x -> Some x)} + +let dp_trace x = Lib.add_anonymous_leaf (dp_trace_obj x) let logic_dir = ["Coq";"Logic";"Decidable"] let coq_modules = init_modules @ [logic_dir] @ arith_modules @ zarith_base_modules + @ [["Coq"; "ZArith"; "BinInt"]] @ [["Coq"; "omega"; "OmegaLemmas"]] let constant = gen_constant_in_modules "dp" coq_modules @@ -52,6 +88,7 @@ let coq_Zneg = lazy (constant "Zneg") let coq_xH = lazy (constant "xH") let coq_xI = lazy (constant "xI") let coq_xO = lazy (constant "xO") +let coq_iff = lazy (constant "iff") (* not Prop typed expressions *) exception NotProp @@ -104,7 +141,7 @@ let coq_rename_vars env vars = type_quantifiers env (A1:Set)...(Ak:Set)t = A1...An, (env+Ai), t *) let decomp_type_quantifiers env t = let rec loop vars t = match kind_of_term t with - | Prod (n, a, t) when is_Set a -> + | Prod (n, a, t) when is_Set a || is_Type a -> loop ((n,a) :: vars) t | _ -> let vars, env = coq_rename_vars env vars in @@ -116,7 +153,7 @@ let decomp_type_quantifiers env t = (* same thing with lambda binders (for axiomatize body) *) let decomp_type_lambdas env t = let rec loop vars t = match kind_of_term t with - | Lambda (n, a, t) when is_Set a -> + | Lambda (n, a, t) when is_Set a || is_Type a -> loop ((n,a) :: vars) t | _ -> let vars, env = coq_rename_vars env vars in @@ -314,7 +351,7 @@ and make_term_abstraction tv env c = *) and tr_decl env id ty = let tv, env, t = decomp_type_quantifiers env ty in - if is_Set t then + if is_Set t || is_Type t then DeclType (id, List.length tv) else if is_Prop t then DeclPred (id, List.length tv, []) @@ -329,8 +366,8 @@ and tr_decl env id ty = DeclPred(id, List.length tv, l) else let s = Typing.type_of env Evd.empty t in - if is_Set s then - DeclFun(id, List.length tv, l, tr_type tv env t) + if is_Set s || is_Type s then + DeclFun (id, List.length tv, l, tr_type tv env t) else raise NotFO @@ -364,17 +401,18 @@ and axiomatize_body env r id d = match r with begin match (Global.lookup_constant c).const_body with | Some b -> let b = force b in - let tv, env, b = decomp_type_lambdas env b in let axioms = (match d with | DeclPred (id, _, []) -> + let tv, env, b = decomp_type_lambdas env b in let value = tr_formula tv [] env b in [id, Iff (Fatom (Pred (id, [])), value)] | DeclFun (id, _, [], _) -> + let tv, env, b = decomp_type_lambdas env b in let value = tr_term tv [] env b in [id, Fatom (Eq (Fol.App (id, []), value))] | DeclFun (id, _, l, _) | DeclPred (id, _, l) -> - Format.eprintf "axiomatize_body %S@." id; + (*Format.eprintf "axiomatize_body %S@." id;*) let b = match kind_of_term b with (* a single recursive function *) | Fix (_, (_,_,[|b|])) -> @@ -391,6 +429,7 @@ and axiomatize_body env r id d = match r with | _ -> b in + let tv, env, b = decomp_type_lambdas env b in let vars, t = decompose_lam b in let n = List.length l in let k = List.length vars in @@ -401,21 +440,21 @@ and axiomatize_body env r id d = match r with let vars = List.rev vars in let bv = vars in let vars = List.map (fun x -> string_of_id x) vars in - let fol_var x = - Fol.App (x, []) in + let fol_var x = Fol.App (x, []) in let fol_vars = List.map fol_var vars in let vars = List.combine vars l in begin match d with - | DeclFun _ -> + | DeclFun (_, _, _, ty) -> begin match kind_of_term t with | Case (ci, _, e, br) -> equations_for_case env id vars tv bv ci e br | _ -> - let p = - Fatom (Eq (App (id, fol_vars), - tr_term tv bv env t)) + let t = tr_term tv bv env t in + let ax = + add_proof (Fun_def (id, vars, ty, t)) in - [id, foralls vars p] + let p = Fatom (Eq (App (id, fol_vars), t)) in + [ax, foralls vars p] end | DeclPred _ -> let value = tr_formula tv bv env t in @@ -436,7 +475,7 @@ and axiomatize_body env r id d = match r with | IndRef i -> iter_all_constructors i (fun _ c -> - let rc = reference_of_constr c in + let rc = global_of_constr c in try begin match tr_global env rc with | DeclFun (_, _, [], _) -> () @@ -453,18 +492,20 @@ and equations_for_case env id vars tv bv ci e br = match kind_of_term e with iter_all_constructors ci.ci_ind (fun j cj -> try - let cjr = reference_of_constr cj in + let cjr = global_of_constr cj in begin match tr_global env cjr with | DeclFun (idc, _, l, _) -> let b = br.(j) in let rec_vars, b = decompose_lam b in let rec_vars, env = coq_rename_vars env rec_vars in - let b = substl (List.map mkVar rec_vars) b in + let coq_rec_vars = List.map mkVar rec_vars in + let b = substl coq_rec_vars b in let rec_vars = List.rev rec_vars in + let coq_rec_term = applist (cj, List.rev coq_rec_vars) in + let b = replace_vars [x, coq_rec_term] b in let bv = bv @ rec_vars in let rec_vars = List.map string_of_id rec_vars in - let fol_var x = - Fol.App (x, []) in + let fol_var x = Fol.App (x, []) in let fol_rec_vars = List.map fol_var rec_vars in let fol_rec_term = App (idc, fol_rec_vars) in let rec_vars = List.combine rec_vars l in @@ -558,7 +599,7 @@ and tr_formula tv bv env f = Fatom (Pred (rename_global (VarRef id), [])) | _, [t;a;b] when c = build_coq_eq () -> let ty = Typing.type_of env Evd.empty t in - if is_Set ty then + if is_Set ty || is_Type ty then let _ = tr_type tv env t in Fatom (Eq (tr_term tv bv env a, tr_term tv bv env b)) else @@ -581,6 +622,8 @@ and tr_formula tv bv env f = And (tr_formula tv bv env a, tr_formula tv bv env b) | _, [a;b] when c = build_coq_or () -> Or (tr_formula tv bv env a, tr_formula tv bv env b) + | _, [a;b] when c = Lazy.force coq_iff -> + Iff (tr_formula tv bv env a, tr_formula tv bv env b) | Prod (n, a, b), _ -> if is_imp_term f then Imp (tr_formula tv bv env a, tr_formula tv bv env b) @@ -632,55 +675,164 @@ let tr_goal gl = hyps, c -type prover = Simplify | CVCLite | Harvey | Zenon +type prover = Simplify | Ergo | Yices | CVCLite | Harvey | Zenon | Gwhy let remove_files = List.iter (fun f -> try Sys.remove f with _ -> ()) let sprintf = Format.sprintf +let file_contents f = + let buf = Buffer.create 1024 in + try + let c = open_in f in + begin try + while true do + let s = input_line c in Buffer.add_string buf s; + Buffer.add_char buf '\n' + done; + assert false + with End_of_file -> + close_in c; + Buffer.contents buf + end + with _ -> + sprintf "(cannot open %s)" f + +let timeout_sys_command cmd = + if !debug then Format.eprintf "command line: %s@." cmd; + let out = Filename.temp_file "out" "" in + let cmd = sprintf "cpulimit %d %s > %s 2>&1" !timeout cmd out in + let ret = Sys.command cmd in + if !debug then + Format.eprintf "Output file %s:@.%s@." out (file_contents out); + ret, out + +let timeout_or_failure c cmd out = + if c = 152 then + Timeout + else + Failure + (sprintf "command %s failed with output:\n%s " cmd (file_contents out)) + +let prelude_files = ref ([] : string list) + +let set_prelude l = prelude_files := l + +let (dp_prelude_obj,_) = + declare_object + {(default_object "Dp_prelude") with + cache_function = (fun (_,x) -> set_prelude x); + load_function = (fun _ (_,x) -> set_prelude x); + export_function = (fun x -> Some x)} + +let dp_prelude x = Lib.add_anonymous_leaf (dp_prelude_obj x) + +let why_files f = String.concat " " (!prelude_files @ [f]) + let call_simplify fwhy = - let cmd = sprintf "why --simplify %s" fwhy in - if Sys.command cmd <> 0 then error ("Call to " ^ cmd ^ " failed"); + let cmd = + sprintf "why --no-arrays --simplify --encoding sstrat %s" (why_files 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 + sprintf "timeout %d Simplify %s > out 2>&1 && grep -q -w Valid out" + !timeout fsx in let out = Sys.command cmd in - let r = if out = 0 then Valid else if out = 1 then Invalid else Timeout in + let r = + if out = 0 then Valid None else if out = 1 then Invalid else Timeout + in if not !debug then remove_files [fwhy; fsx]; r +let call_ergo fwhy = + let cmd = sprintf "why --no-arrays --why %s" (why_files fwhy) in + if Sys.command cmd <> 0 then error ("call to " ^ cmd ^ " failed"); + let fwhy = Filename.chop_suffix fwhy ".why" ^ "_why.why" in + let ftrace = Filename.temp_file "ergo_trace" "" in + let cmd = + if !trace then + sprintf "ergo -cctrace %s %s" ftrace fwhy + else + sprintf "ergo %s" fwhy + in + let ret,out = timeout_sys_command cmd in + let r = + if ret <> 0 then + timeout_or_failure ret cmd out + else if Sys.command (sprintf "grep -q -w Valid %s" out) = 0 then + Valid (if !trace then Some ftrace else None) + else if Sys.command (sprintf "grep -q -w \"I don't know\" %s" out) = 0 then + DontKnow + else if Sys.command (sprintf "grep -q -w \"Invalid\" %s" out) = 0 then + Invalid + else + Failure ("command failed: " ^ cmd) + in + if not !debug then remove_files [fwhy; out]; + r + let call_zenon fwhy = - let cmd = sprintf "why --no-prelude --no-zenon-prelude --zenon %s" fwhy in + let cmd = + sprintf "why --no-prelude --no-zenon-prelude --zenon %s" (why_files fwhy) + in if Sys.command cmd <> 0 then error ("call to " ^ cmd ^ " failed"); let fznn = Filename.chop_suffix fwhy ".why" ^ "_why.znn" in + let out = Filename.temp_file "dp_out" "" in let cmd = - sprintf "timeout 10 zenon %s > out 2>&1 && grep -q PROOF-FOUND out" fznn + sprintf "timeout %d zenon -ocoqterm %s > %s 2>&1" !timeout fznn out + in + let c = Sys.command cmd in + if not !debug then remove_files [fwhy; fznn]; + if c = 137 then + Timeout + else begin + if c <> 0 then anomaly ("command failed: " ^ cmd); + if Sys.command (sprintf "grep -q -w Error %s" out) = 0 then + error "Zenon failed"; + let c = Sys.command (sprintf "grep -q PROOF-FOUND %s" out) in + if c = 0 then Valid (Some out) else Invalid + end + +let call_yices fwhy = + let cmd = + sprintf "why --no-arrays -smtlib --encoding sstrat %s" (why_files fwhy) + in + if Sys.command cmd <> 0 then error ("call to " ^ cmd ^ " failed"); + let fsmt = Filename.chop_suffix fwhy ".why" ^ "_why.smt" in + let cmd = + sprintf "timeout %d yices -pc 0 -smt < %s > out 2>&1 && grep -q -w unsat out" + !timeout fsmt in let out = Sys.command cmd in let r = - if out = 0 then Valid - else if out = 1 then Invalid - else if out = 137 then Timeout - else anomaly ("malformed Zenon input file " ^ fznn) + if out = 0 then Valid None else if out = 1 then Invalid else Timeout in - if not !debug then remove_files [fwhy; fznn]; + if not !debug then remove_files [fwhy; fsmt]; r let call_cvcl fwhy = - let cmd = sprintf "why --cvcl %s" fwhy in + let cmd = + sprintf "why --no-arrays --cvcl --encoding sstrat %s" (why_files 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 + sprintf "timeout %d cvcl < %s > out 2>&1 && grep -q -w Valid out" + !timeout fcvc in let out = Sys.command cmd in - let r = if out = 0 then Valid else if out = 1 then Invalid else Timeout in + let r = + if out = 0 then Valid None else if out = 1 then Invalid else Timeout + in if not !debug then remove_files [fwhy; fcvc]; r let call_harvey fwhy = - let cmd = sprintf "why --harvey %s" fwhy in + let cmd = + sprintf "why --no-arrays --harvey --encoding strat %s" (why_files 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 @@ -688,7 +840,8 @@ let call_harvey fwhy = let f = Filename.chop_suffix frv ".rv" ^ "-0.baf" in let outf = Filename.temp_file "rv" ".out" in let out = - Sys.command (sprintf "timeout 10 rv -e\"-T 2000\" %s > %s 2>&1" f outf) + Sys.command (sprintf "timeout %d rv -e\"-T 2000\" %s > %s 2>&1" + !timeout f outf) in let r = if out <> 0 then @@ -697,40 +850,69 @@ let call_harvey fwhy = let cmd = sprintf "grep \"Proof obligation in\" %s | grep -q \"is valid\"" outf in - if Sys.command cmd = 0 then Valid else Invalid + if Sys.command cmd = 0 then Valid None else Invalid in if not !debug then remove_files [fwhy; frv; outf]; r +let call_gwhy fwhy = + let cmd = sprintf "gwhy --no-arrays %s" (why_files fwhy) in + if Sys.command cmd <> 0 then ignore (Sys.command (sprintf "emacs %s" fwhy)); + NoAnswer + +let ergo_proof_from_file f gl = + let s = + let buf = Buffer.create 1024 in + let c = open_in f in + try + while true do Buffer.add_string buf (input_line c) done; assert false + with End_of_file -> + close_in c; + Buffer.contents buf + in + let parsed_constr = Pcoq.parse_string Pcoq.Constr.constr s in + let t = Constrintern.interp_constr (project gl) (pf_env gl) parsed_constr in + exact_check t gl + let call_prover prover q = let fwhy = Filename.temp_file "coq_dp" ".why" in Dp_why.output_file fwhy q; - if !debug then ignore (Sys.command (sprintf "cat %s" fwhy)); match prover with | Simplify -> call_simplify fwhy + | Ergo -> call_ergo fwhy + | Yices -> call_yices fwhy | Zenon -> call_zenon fwhy | CVCLite -> call_cvcl fwhy | Harvey -> call_harvey fwhy + | Gwhy -> call_gwhy fwhy let dp prover gl = + Coqlib.check_required_library ["Coq";"ZArith";"ZArith"]; let concl_type = pf_type_of gl (pf_concl gl) in if not (is_Prop concl_type) then error "Conclusion is not a Prop"; try let q = tr_goal gl in begin match call_prover prover q with - | Valid -> Tactics.admit_as_an_axiom gl + | Valid (Some f) when prover = Zenon -> Dp_zenon.proof_from_file f gl + | Valid (Some f) when prover = Ergo -> ergo_proof_from_file f gl + | Valid _ -> Tactics.admit_as_an_axiom gl | Invalid -> error "Invalid" | DontKnow -> error "Don't know" | Timeout -> error "Timeout" + | Failure s -> error s + | NoAnswer -> Tacticals.tclIDTAC gl end with NotFO -> error "Not a first order goal" - + let simplify = tclTHEN intros (dp Simplify) +let ergo = tclTHEN intros (dp Ergo) +let yices = tclTHEN intros (dp Yices) let cvc_lite = tclTHEN intros (dp CVCLite) let harvey = dp Harvey let zenon = tclTHEN intros (dp Zenon) +let gwhy = tclTHEN intros (dp Gwhy) let dp_hint l = let env = Global.env () in @@ -741,7 +923,8 @@ let dp_hint l = if is_Prop s then try let id = rename_global r in - let d = Axiom (id, tr_formula [] [] env ty) in + let tv, env, ty = decomp_type_quantifiers env ty in + let d = Axiom (id, tr_formula tv [] env ty) in add_global r (Gfo d); globals_stack := d :: !globals_stack with NotFO -> @@ -757,3 +940,52 @@ let dp_hint l = end in List.iter one_hint (List.map (fun qid -> qid, Nametab.global qid) l) + +let (dp_hint_obj,_) = + declare_object + {(default_object "Dp_hint") with + cache_function = (fun (_,l) -> dp_hint l); + load_function = (fun _ (_,l) -> dp_hint l); + export_function = (fun x -> Some x)} + +let dp_hint l = Lib.add_anonymous_leaf (dp_hint_obj l) + +let dp_predefined qid s = + let r = Nametab.global qid in + let ty = Global.type_of_global r in + let env = Global.env () in + let id = rename_global r in + try + let d = match tr_decl env id ty with + | DeclType (_, n) -> DeclType (s, n) + | DeclFun (_, n, tyl, ty) -> DeclFun (s, n, tyl, ty) + | DeclPred (_, n, tyl) -> DeclPred (s, n, tyl) + | Axiom _ as d -> d + in + match d with + | Axiom _ -> msg_warning (str " ignored (axiom)") + | d -> add_global r (Gfo d) + with NotFO -> + msg_warning (str " ignored (not a first order declaration)") + +let (dp_predefined_obj,_) = + declare_object + {(default_object "Dp_predefined") with + cache_function = (fun (_,(id,s)) -> dp_predefined id s); + load_function = (fun _ (_,(id,s)) -> dp_predefined id s); + export_function = (fun x -> Some x)} + +let dp_predefined id s = Lib.add_anonymous_leaf (dp_predefined_obj (id,s)) + +let _ = declare_summary "Dp options" + { freeze_function = + (fun () -> !debug, !trace, !timeout, !prelude_files); + unfreeze_function = + (fun (d,tr,tm,pr) -> + debug := d; trace := tr; timeout := tm; prelude_files := pr); + init_function = + (fun () -> + debug := false; trace := false; timeout := 10; + prelude_files := []); + survive_module = true; + survive_section = true } diff --git a/contrib/dp/dp.mli b/contrib/dp/dp.mli index 3dad469c..6dbc05e1 100644 --- a/contrib/dp/dp.mli +++ b/contrib/dp/dp.mli @@ -3,10 +3,18 @@ open Libnames open Proof_type val simplify : tactic +val ergo : tactic +val yices : tactic val cvc_lite : tactic val harvey : tactic val zenon : tactic +val gwhy : tactic val dp_hint : reference list -> unit +val dp_timeout : int -> unit +val dp_debug : bool -> unit +val dp_trace : bool -> unit +val dp_prelude : string list -> unit +val dp_predefined : reference -> string -> unit diff --git a/contrib/dp/dp_cvcl.ml b/contrib/dp/dp_cvcl.ml deleted file mode 100644 index 05d43081..00000000 --- a/contrib/dp/dp_cvcl.ml +++ /dev/null @@ -1,112 +0,0 @@ - -open Format -open Fol - -let rec print_list sep print fmt = function - | [] -> () - | [x] -> print fmt x - | x :: r -> print fmt x; sep fmt (); print_list sep print fmt r - -let space fmt () = fprintf fmt "@ " -let comma fmt () = fprintf fmt ",@ " - -let rec print_term fmt = function - | Cst n -> - fprintf fmt "%d" n - | Plus (a, b) -> - fprintf fmt "@[(%a@ +@ %a)@]" print_term a print_term b - | Moins (a, b) -> - fprintf fmt "@[(%a@ -@ %a)@]" print_term a print_term b - | Mult (a, b) -> - fprintf fmt "@[(%a@ *@ %a)@]" print_term a print_term b - | Div (a, b) -> - fprintf fmt "@[(%a@ /@ %a)@]" print_term a print_term b - | App (id, []) -> - fprintf fmt "@[%s@]" id - | App (id, tl) -> - fprintf fmt "@[%s(%a)@]" id print_terms tl - -and print_terms fmt tl = - print_list comma print_term fmt tl - -let rec print_predicate fmt p = - let pp = print_predicate in - match p with - | True -> - fprintf fmt "TRUE" - | False -> - fprintf fmt "FALSE" - | Fatom (Eq (a, b)) -> - fprintf fmt "@[(%a = %a)@]" print_term a print_term b - | Fatom (Le (a, b)) -> - fprintf fmt "@[(%a@ <= %a)@]" print_term a print_term b - | Fatom (Lt (a, b))-> - fprintf fmt "@[(%a@ < %a)@]" print_term a print_term b - | Fatom (Ge (a, b)) -> - fprintf fmt "@[(%a@ >= %a)@]" print_term a print_term b - | Fatom (Gt (a, b)) -> - fprintf fmt "@[(%a@ > %a)@]" print_term a print_term b - | Fatom (Pred (id, [])) -> - fprintf fmt "@[%s@]" id - | Fatom (Pred (id, tl)) -> - fprintf fmt "@[%s(%a)@]" id print_terms tl - | Imp (a, b) -> - fprintf fmt "@[(%a@ => %a)@]" pp a pp b - | And (a, b) -> - fprintf fmt "@[(%a@ AND@ %a)@]" pp a pp b - | Or (a, b) -> - fprintf fmt "@[(%a@ OR@ %a)@]" pp a pp b - | Not a -> - fprintf fmt "@[(NOT@ %a)@]" pp a - | Forall (id, t, p) -> - fprintf fmt "@[(FORALL (%s:%s): %a)@]" id t pp p - | Exists (id, t, p) -> - fprintf fmt "@[(EXISTS (%s:%s): %a)@]" id t pp p - -let rec string_of_type_list = function - | [] -> assert false - | [e] -> e - | e :: l' -> e ^ ", " ^ (string_of_type_list l') - -let print_query fmt (decls,concl) = - let print_decl = function - | DeclVar (id, [], t) -> - fprintf fmt "@[%s: %s;@]@\n" id t - | DeclVar (id, [e], t) -> - fprintf fmt "@[%s: [%s -> %s];@]@\n" - id e t - | DeclVar (id, l, t) -> - fprintf fmt "@[%s: [[%s] -> %s];@]@\n" - id (string_of_type_list l) t - | DeclPred (id, []) -> - fprintf fmt "@[%s: BOOLEAN;@]@\n" id - | DeclPred (id, [e]) -> - fprintf fmt "@[%s: [%s -> BOOLEAN];@]@\n" - id e - | DeclPred (id, l) -> - fprintf fmt "@[%s: [[%s] -> BOOLEAN];@]@\n" - id (string_of_type_list l) - | DeclType id -> - fprintf fmt "@[%s: TYPE;@]@\n" id - | Assert (id, f) -> - fprintf fmt "@[ASSERT %% %s@\n %a;@]@\n" id print_predicate f - in - List.iter print_decl decls; - fprintf fmt "QUERY %a;" print_predicate concl - -let call q = - let f = Filename.temp_file "coq_dp" ".cvc" in - let c = open_out f in - let fmt = formatter_of_out_channel c in - fprintf fmt "@[%a@]@." print_query q; - close_out c; - ignore (Sys.command (sprintf "cat %s" f)); - let cmd = - sprintf "timeout 10 cvcl < %s > out 2>&1 && grep -q -w Valid out" f - in - prerr_endline cmd; flush stderr; - let out = Sys.command cmd in - if out = 0 then Valid else if out = 1 then Invalid else Timeout - (* TODO: effacer le fichier f et le fichier out *) - - diff --git a/contrib/dp/dp_cvcl.mli b/contrib/dp/dp_cvcl.mli deleted file mode 100644 index 03b6d347..00000000 --- a/contrib/dp/dp_cvcl.mli +++ /dev/null @@ -1,4 +0,0 @@ - -open Fol - -val call : query -> prover_answer diff --git a/contrib/dp/dp_gappa.ml b/contrib/dp/dp_gappa.ml new file mode 100644 index 00000000..70439a97 --- /dev/null +++ b/contrib/dp/dp_gappa.ml @@ -0,0 +1,445 @@ + +open Format +open Util +open Pp +open Term +open Tacmach +open Tactics +open Tacticals +open Names +open Nameops +open Termops +open Coqlib +open Hipattern +open Libnames +open Declarations +open Evarutil + +let debug = ref false + +(* 1. gappa syntax trees and output *) + +module Constant = struct + + open Bigint + + type t = { mantissa : bigint; base : int; exp : bigint } + + let create (b, m, e) = + { mantissa = m; base = b; exp = e } + + let of_int x = + { mantissa = x; base = 1; exp = zero } + + let print fmt x = match x.base with + | 1 -> fprintf fmt "%s" (to_string x.mantissa) + | 2 -> fprintf fmt "%sb%s" (to_string x.mantissa) (to_string x.exp) + | 10 -> fprintf fmt "%se%s" (to_string x.mantissa) (to_string x.exp) + | _ -> assert false + +end + +type binop = Bminus | Bplus | Bmult | Bdiv + +type unop = Usqrt | Uabs | Uopp + +type rounding_mode = string + +type term = + | Tconst of Constant.t + | Tvar of string + | Tbinop of binop * term * term + | Tunop of unop * term + | Tround of rounding_mode * term + +type pred = + | Pin of term * Constant.t * Constant.t + +let rec print_term fmt = function + | Tconst c -> Constant.print fmt c + | Tvar s -> pp_print_string fmt s + | Tbinop (op, t1, t2) -> + let op = match op with + | Bplus -> "+" | Bminus -> "-" | Bmult -> "*" | Bdiv -> "/" + in + fprintf fmt "(%a %s %a)" print_term t1 op print_term t2 + | Tunop (Uabs, t) -> + fprintf fmt "|%a|" print_term t + | Tunop (Uopp | Usqrt as op, t) -> + let s = match op with + | Uopp -> "-" | Usqrt -> "sqrt" | _ -> assert false + in + fprintf fmt "(%s(%a))" s print_term t + | Tround (m, t) -> + fprintf fmt "(%s(%a))" m print_term t + +let print_pred fmt = function + | Pin (t, c1, c2) -> + fprintf fmt "%a in [%a, %a]" + print_term t Constant.print c1 Constant.print c2 + +let temp_file f = if !debug then f else Filename.temp_file f ".v" +let remove_file f = if not !debug then try Sys.remove f with _ -> () + +let read_gappa_proof f = + let buf = Buffer.create 1024 in + Buffer.add_char buf '('; + let cin = open_in f in + let rec skip_space () = + let c = input_char cin in if c = ' ' then skip_space () else c + in + while input_char cin <> '=' do () done; + try + while true do + let c = skip_space () in + if c = ':' then raise Exit; + Buffer.add_char buf c; + let s = input_line cin in + Buffer.add_string buf s; + Buffer.add_char buf '\n'; + done; + assert false + with Exit -> + close_in cin; + remove_file f; + Buffer.add_char buf ')'; + Buffer.contents buf + +exception GappaFailed +exception GappaProofFailed + +let patch_gappa_proof fin fout = + let cin = open_in fin in + let cout = open_out fout in + let fmt = formatter_of_out_channel cout in + let last = ref "" in + let defs = ref "" in + try + while true do + let s = input_line cin in + if s = "Qed." then + fprintf fmt "Defined.@\n" + else begin + begin + try Scanf.sscanf s "Lemma %s " + (fun n -> defs := n ^ " " ^ !defs; last := n) + with Scanf.Scan_failure _ -> + try Scanf.sscanf s "Definition %s " + (fun n -> defs := n ^ " " ^ !defs) + with Scanf.Scan_failure _ -> + () + end; + fprintf fmt "%s@\n" s + end + done + with End_of_file -> + close_in cin; + fprintf fmt "Definition proof := Eval cbv delta [%s] in %s.@." !defs !last; + close_out cout + +let call_gappa hl p = + let gappa_in = temp_file "gappa_input" in + let c = open_out gappa_in in + let fmt = formatter_of_out_channel c in + fprintf fmt "@[{ "; + List.iter (fun h -> fprintf fmt "%a ->@ " print_pred h) hl; + fprintf fmt "%a }@]@." print_pred p; + close_out c; + let gappa_out = temp_file "gappa_output" in + let cmd = sprintf "gappa -Bcoq < %s > %s 2> /dev/null" gappa_in gappa_out in + let out = Sys.command cmd in + if out <> 0 then raise GappaFailed; + remove_file gappa_in; + let gappa_out2 = temp_file "gappa2" in + patch_gappa_proof gappa_out gappa_out2; + remove_file gappa_out; + let cmd = sprintf "%s/coqc %s" Coq_config.bindir gappa_out2 in + let out = Sys.command cmd in + if out <> 0 then raise GappaProofFailed; + let gappa_out3 = temp_file "gappa3" in + let c = open_out gappa_out3 in + let gappa2 = Filename.chop_suffix (Filename.basename gappa_out2) ".v" in + Printf.fprintf c + "Require \"%s\". Set Printing Depth 9999999. Print %s.proof." + (Filename.chop_suffix gappa_out2 ".v") gappa2; + close_out c; + let lambda = temp_file "gappa_lambda" in + let cmd = sprintf "%s/coqc %s > %s" Coq_config.bindir gappa_out3 lambda in + let out = Sys.command cmd in + if out <> 0 then raise GappaProofFailed; + remove_file gappa_out2; remove_file gappa_out3; + remove_file (gappa_out2 ^ "o"); remove_file (gappa_out3 ^ "o"); + read_gappa_proof lambda + +(* 2. coq -> gappa translation *) + +exception NotGappa + +let logic_dir = ["Coq";"Logic";"Decidable"] +let coq_modules = + init_modules @ [logic_dir] @ arith_modules @ zarith_base_modules + @ [["Coq"; "ZArith"; "BinInt"]; + ["Coq"; "Reals"; "Rdefinitions"]; + ["Coq"; "Reals"; "Raxioms";]; + ["Coq"; "Reals"; "Rbasic_fun";]; + ["Coq"; "Reals"; "R_sqrt";]; + ["Coq"; "Reals"; "Rfunctions";]; + ["Gappa"; "Gappa_tactic";]; + ["Gappa"; "Gappa_fixed";]; + ["Gappa"; "Gappa_float";]; + ["Gappa"; "Gappa_round_def";]; + ["Gappa"; "Gappa_pred_bnd";]; + ["Gappa"; "Gappa_definitions";]; + ] + +let constant = gen_constant_in_modules "gappa" coq_modules + +let coq_refl_equal = lazy (constant "refl_equal") +let coq_Rle = lazy (constant "Rle") +let coq_R = lazy (constant "R") +(* +let coq_Rplus = lazy (constant "Rplus") +let coq_Rminus = lazy (constant "Rminus") +let coq_Rmult = lazy (constant "Rmult") +let coq_Rdiv = lazy (constant "Rdiv") +let coq_powerRZ = lazy (constant "powerRZ") +let coq_R1 = lazy (constant "R1") +let coq_Ropp = lazy (constant "Ropp") +let coq_Rabs = lazy (constant "Rabs") +let coq_sqrt = lazy (constant "sqrt") +*) + +let coq_convert = lazy (constant "convert") +let coq_reUnknown = lazy (constant "reUnknown") +let coq_reFloat2 = lazy (constant "reFloat2") +let coq_reFloat10 = lazy (constant "reFloat10") +let coq_reInteger = lazy (constant "reInteger") +let coq_reBinary = lazy (constant "reBinary") +let coq_reUnary = lazy (constant "reUnary") +let coq_reRound = lazy (constant "reRound") +let coq_roundDN = lazy (constant "roundDN") +let coq_roundUP = lazy (constant "roundUP") +let coq_roundNE = lazy (constant "roundNE") +let coq_roundZR = lazy (constant "roundZR") +let coq_rounding_fixed = lazy (constant "rounding_fixed") +let coq_rounding_float = lazy (constant "rounding_float") +let coq_boAdd = lazy (constant "boAdd") +let coq_boSub = lazy (constant "boSub") +let coq_boMul = lazy (constant "boMul") +let coq_boDiv = lazy (constant "boDiv") +let coq_uoAbs = lazy (constant "uoAbs") +let coq_uoNeg = lazy (constant "uoNeg") +let coq_uoSqrt = lazy (constant "uoSqrt") +let coq_subset = lazy (constant "subset") +let coq_makepairF = lazy (constant "makepairF") + +let coq_true = lazy (constant "true") +let coq_false = lazy (constant "false") + +let coq_Z0 = lazy (constant "Z0") +let coq_Zpos = lazy (constant "Zpos") +let coq_Zneg = lazy (constant "Zneg") +let coq_xH = lazy (constant "xH") +let coq_xI = lazy (constant "xI") +let coq_xO = lazy (constant "xO") +let coq_IZR = lazy (constant "IZR") + +(* translates a closed Coq term p:positive into a FOL term of type int *) +let rec tr_positive p = match kind_of_term p with + | Term.Construct _ when p = Lazy.force coq_xH -> + 1 + | Term.App (f, [|a|]) when f = Lazy.force coq_xI -> + 2 * (tr_positive a) + 1 + | Term.App (f, [|a|]) when f = Lazy.force coq_xO -> + 2 * (tr_positive a) + | Term.Cast (p, _, _) -> + tr_positive p + | _ -> + raise NotGappa + +(* translates a closed Coq term t:Z into a term of type int *) +let rec tr_arith_constant t = match kind_of_term t with + | Term.Construct _ when t = Lazy.force coq_Z0 -> 0 + | Term.App (f, [|a|]) when f = Lazy.force coq_Zpos -> tr_positive a + | Term.App (f, [|a|]) when f = Lazy.force coq_Zneg -> - (tr_positive a) + | Term.Cast (t, _, _) -> tr_arith_constant t + | _ -> raise NotGappa + +(* translates a closed Coq term p:positive into a FOL term of type bigint *) +let rec tr_bigpositive p = match kind_of_term p with + | Term.Construct _ when p = Lazy.force coq_xH -> + Bigint.one + | Term.App (f, [|a|]) when f = Lazy.force coq_xI -> + Bigint.add_1 (Bigint.mult_2 (tr_bigpositive a)) + | Term.App (f, [|a|]) when f = Lazy.force coq_xO -> + (Bigint.mult_2 (tr_bigpositive a)) + | Term.Cast (p, _, _) -> + tr_bigpositive p + | _ -> + raise NotGappa + +(* translates a closed Coq term t:Z into a term of type bigint *) +let rec tr_arith_bigconstant t = match kind_of_term t with + | Term.Construct _ when t = Lazy.force coq_Z0 -> Bigint.zero + | Term.App (f, [|a|]) when f = Lazy.force coq_Zpos -> tr_bigpositive a + | Term.App (f, [|a|]) when f = Lazy.force coq_Zneg -> + Bigint.neg (tr_bigpositive a) + | Term.Cast (t, _, _) -> tr_arith_bigconstant t + | _ -> raise NotGappa + +let decomp c = + let c, args = decompose_app c in + kind_of_term c, args + +let tr_bool c = match decompose_app c with + | c, [] when c = Lazy.force coq_true -> true + | c, [] when c = Lazy.force coq_false -> false + | _ -> raise NotGappa + +let tr_float b m e = + (b, tr_arith_bigconstant m, tr_arith_bigconstant e) + +let tr_binop c = match decompose_app c with + | c, [] when c = Lazy.force coq_boAdd -> Bplus + | c, [] when c = Lazy.force coq_boSub -> Bminus + | c, [] when c = Lazy.force coq_boMul -> Bmult + | c, [] when c = Lazy.force coq_boDiv -> Bdiv + | _ -> assert false + +let tr_unop c = match decompose_app c with + | c, [] when c = Lazy.force coq_uoNeg -> Uopp + | c, [] when c = Lazy.force coq_uoSqrt -> Usqrt + | c, [] when c = Lazy.force coq_uoAbs -> Uabs + | _ -> raise NotGappa + +let tr_var c = match decomp c with + | Var x, [] -> string_of_id x + | _ -> assert false + +let tr_mode c = match decompose_app c with + | c, [] when c = Lazy.force coq_roundDN -> "dn" + | c, [] when c = Lazy.force coq_roundNE -> "ne" + | c, [] when c = Lazy.force coq_roundUP -> "up" + | c, [] when c = Lazy.force coq_roundZR -> "zr" + | _ -> raise NotGappa + +let tr_rounding_mode c = match decompose_app c with + | c, [a;b] when c = Lazy.force coq_rounding_fixed -> + let a = tr_mode a in + let b = tr_arith_constant b in + sprintf "fixed<%d,%s>" b a + | c, [a;p;e] when c = Lazy.force coq_rounding_float -> + let a = tr_mode a in + let p = tr_positive p in + let e = tr_arith_constant e in + sprintf "float<%d,%d,%s>" p (-e) a + | _ -> + raise NotGappa + +(* REexpr -> term *) +let rec tr_term c0 = + let c, args = decompose_app c0 in + match kind_of_term c, args with + | _, [a] when c = Lazy.force coq_reUnknown -> + Tvar (tr_var a) + | _, [a; b] when c = Lazy.force coq_reFloat2 -> + Tconst (Constant.create (tr_float 2 a b)) + | _, [a; b] when c = Lazy.force coq_reFloat10 -> + Tconst (Constant.create (tr_float 10 a b)) + | _, [a] when c = Lazy.force coq_reInteger -> + Tconst (Constant.create (1, tr_arith_bigconstant a, Bigint.zero)) + | _, [op;a;b] when c = Lazy.force coq_reBinary -> + Tbinop (tr_binop op, tr_term a, tr_term b) + | _, [op;a] when c = Lazy.force coq_reUnary -> + Tunop (tr_unop op, tr_term a) + | _, [op;a] when c = Lazy.force coq_reRound -> + Tround (tr_rounding_mode op, tr_term a) + | _ -> + msgnl (str "tr_term: " ++ Printer.pr_constr c0); + assert false + +let tr_rle c = + let c, args = decompose_app c in + match kind_of_term c, args with + | _, [a;b] when c = Lazy.force coq_Rle -> + begin match decompose_app a, decompose_app b with + | (ac, [at]), (bc, [bt]) + when ac = Lazy.force coq_convert && bc = Lazy.force coq_convert -> + at, bt + | _ -> + raise NotGappa + end + | _ -> + raise NotGappa + +let tr_pred c = + let c, args = decompose_app c in + match kind_of_term c, args with + | _, [a;b] when c = build_coq_and () -> + begin match tr_rle a, tr_rle b with + | (c1, t1), (t2, c2) when t1 = t2 -> + begin match tr_term c1, tr_term c2 with + | Tconst c1, Tconst c2 -> + Pin (tr_term t1, c1, c2) + | _ -> + raise NotGappa + end + | _ -> + raise NotGappa + end + | _ -> + raise NotGappa + +let is_R c = match decompose_app c with + | c, [] when c = Lazy.force coq_R -> true + | _ -> false + +let tr_hyps = + List.fold_left + (fun acc (_,h) -> try tr_pred h :: acc with NotGappa -> acc) [] + +let constr_of_string gl s = + let parse_constr = Pcoq.parse_string Pcoq.Constr.constr in + Constrintern.interp_constr (project gl) (pf_env gl) (parse_constr s) + +let var_name = function + | Name id -> + let s = string_of_id id in + let s = String.sub s 1 (String.length s - 1) in + mkVar (id_of_string s) + | Anonymous -> + assert false + +let build_proof_term c0 = + let bl,c = decompose_lam c0 in + List.fold_right + (fun (x,t) pf -> + mkApp (pf, [| if is_R t then var_name x else mk_new_meta () |])) + bl c0 + +let gappa_internal gl = + try + let c = tr_pred (pf_concl gl) in + let s = call_gappa (tr_hyps (pf_hyps_types gl)) c in + let pf = constr_of_string gl s in + let pf = build_proof_term pf in + Tacticals.tclTHEN (Tacmach.refine_no_check pf) Tactics.assumption gl + with + | NotGappa -> error "not a gappa goal" + | GappaFailed -> error "gappa failed" + | GappaProofFailed -> error "incorrect gappa proof term" + +let gappa_prepare = + let id = Ident (dummy_loc, id_of_string "gappa_prepare") in + lazy (Tacinterp.interp (Tacexpr.TacArg (Tacexpr.Reference id))) + +let gappa gl = + Coqlib.check_required_library ["Gappa"; "Gappa_tactic"]; + Tacticals.tclTHEN (Lazy.force gappa_prepare) gappa_internal gl + +(* +Local Variables: +compile-command: "make -C ../.. bin/coqc.opt bin/coqide.opt" +End: +*) + diff --git a/contrib/dp/dp_simplify.ml b/contrib/dp/dp_simplify.ml deleted file mode 100644 index d5376b8d..00000000 --- a/contrib/dp/dp_simplify.ml +++ /dev/null @@ -1,117 +0,0 @@ - -open Format -open Fol - -let is_simplify_ident s = - let is_simplify_char = function - | 'a'..'z' | 'A'..'Z' | '0'..'9' -> true - | _ -> false - in - try - String.iter (fun c -> if not (is_simplify_char c) then raise Exit) s; true - with Exit -> - false - -let ident fmt s = - if is_simplify_ident s then fprintf fmt "%s" s else fprintf fmt "|%s|" s - -let rec print_list sep print fmt = function - | [] -> () - | [x] -> print fmt x - | x :: r -> print fmt x; sep fmt (); print_list sep print fmt r - -let space fmt () = fprintf fmt "@ " -let comma fmt () = fprintf fmt ",@ " - -let rec print_term fmt = function - | Cst n -> - fprintf fmt "%d" n - | Plus (a, b) -> - fprintf fmt "@[(+@ %a@ %a)@]" print_term a print_term b - | Moins (a, b) -> - fprintf fmt "@[(-@ %a@ %a)@]" print_term a print_term b - | Mult (a, b) -> - fprintf fmt "@[(*@ %a@ %a)@]" print_term a print_term b - | Div (a, b) -> - fprintf fmt "@[(/@ %a@ %a)@]" print_term a print_term b - | App (id, []) -> - fprintf fmt "%a" ident id - | App (id, tl) -> - fprintf fmt "@[(%a@ %a)@]" ident id print_terms tl - -and print_terms fmt tl = - print_list space print_term fmt tl - -let rec print_predicate fmt p = - let pp = print_predicate in - match p with - | True -> - fprintf fmt "TRUE" - | False -> - fprintf fmt "FALSE" - | Fatom (Eq (a, b)) -> - fprintf fmt "@[(EQ %a@ %a)@]" print_term a print_term b - | Fatom (Le (a, b)) -> - fprintf fmt "@[(<= %a@ %a)@]" print_term a print_term b - | Fatom (Lt (a, b))-> - fprintf fmt "@[(< %a@ %a)@]" print_term a print_term b - | Fatom (Ge (a, b)) -> - fprintf fmt "@[(>= %a@ %a)@]" print_term a print_term b - | Fatom (Gt (a, b)) -> - fprintf fmt "@[(> %a@ %a)@]" print_term a print_term b - | Fatom (Pred (id, tl)) -> - fprintf fmt "@[(EQ (%a@ %a) |@@true|)@]" ident id print_terms tl - | Imp (a, b) -> - fprintf fmt "@[(IMPLIES@ %a@ %a)@]" pp a pp b - | And (a, b) -> - fprintf fmt "@[(AND@ %a@ %a)@]" pp a pp b - | Or (a, b) -> - fprintf fmt "@[(OR@ %a@ %a)@]" pp a pp b - | Not a -> - fprintf fmt "@[(NOT@ %a)@]" pp a - | Forall (id, _, p) -> - fprintf fmt "@[(FORALL (%a)@ %a)@]" ident id pp p - | Exists (id, _, p) -> - fprintf fmt "@[(EXISTS (%a)@ %a)@]" ident id pp p - -(** -let rec string_list l = match l with - [] -> "" - | [e] -> e - | e::l' -> e ^ " " ^ (string_list l') -**) - -let print_query fmt (decls,concl) = - let print_decl = function - | DeclVar (id, [], t) -> - fprintf fmt "@[;; %s : %s@]@\n" id t - | DeclVar (id, l, t) -> - fprintf fmt "@[;; %s : %a -> %s@]@\n" - id (print_list comma pp_print_string) l t - | DeclPred (id, []) -> - fprintf fmt "@[;; %s : BOOLEAN @]@\n" id - | DeclPred (id, l) -> - fprintf fmt "@[;; %s : %a -> BOOLEAN@]@\n" - id (print_list comma pp_print_string) l - | DeclType id -> - fprintf fmt "@[;; %s : TYPE@]@\n" id - | Assert (id, f) -> - fprintf fmt "@[(BG_PUSH ;; %s@\n %a)@]@\n" id print_predicate f - in - List.iter print_decl decls; - fprintf fmt "%a@." print_predicate concl - -let call q = - let f = Filename.temp_file "coq_dp" ".sx" in - let c = open_out f in - let fmt = formatter_of_out_channel c in - fprintf fmt "@[%a@]@." print_query q; - close_out c; - ignore (Sys.command (sprintf "cat %s" f)); - let cmd = - sprintf "timeout 10 Simplify %s > out 2>&1 && grep -q -w Valid out" f - in - prerr_endline cmd; flush stderr; - let out = Sys.command cmd in - if out = 0 then Valid else if out = 1 then Invalid else Timeout - (* TODO: effacer le fichier f et le fichier out *) diff --git a/contrib/dp/dp_simplify.mli b/contrib/dp/dp_simplify.mli deleted file mode 100644 index 03b6d347..00000000 --- a/contrib/dp/dp_simplify.mli +++ /dev/null @@ -1,4 +0,0 @@ - -open Fol - -val call : query -> prover_answer diff --git a/contrib/dp/dp_sorts.ml b/contrib/dp/dp_sorts.ml deleted file mode 100644 index 7dbdfa56..00000000 --- a/contrib/dp/dp_sorts.ml +++ /dev/null @@ -1,51 +0,0 @@ - -open Fol - -let term_has_sort x s = Fatom (Pred ("%sort_" ^ s, [x])) - -let has_sort x s = term_has_sort (App (x, [])) s - -let rec form = function - | True | False | Fatom _ as f -> f - | Imp (f1, f2) -> Imp (form f1, form f2) - | And (f1, f2) -> And (form f1, form f2) - | Or (f1, f2) -> Or (form f1, form f2) - | Not f -> Not (form f) - | Forall (x, ("INT" as t), f) -> Forall (x, t, form f) - | Forall (x, t, f) -> Forall (x, t, Imp (has_sort x t, form f)) - | Exists (x, ("INT" as t), f) -> Exists (x, t, form f) - | Exists (x, t, f) -> Exists (x, t, Imp (has_sort x t, form f)) - -let sort_ax = let r = ref 0 in fun () -> incr r; "sort_ax_" ^ string_of_int !r - -let hyp acc = function - | Assert (id, f) -> - (Assert (id, form f)) :: acc - | DeclVar (id, _, "INT") as d -> - d :: acc - | DeclVar (id, [], t) as d -> - (Assert (sort_ax (), has_sort id t)) :: d :: acc - | DeclVar (id, l, t) as d -> - let n = ref 0 in - let xi = - List.fold_left - (fun l t -> incr n; ("x" ^ string_of_int !n, t) :: l) [] l - in - let f = - List.fold_left - (fun f (x,t) -> if t = "INT" then f else Imp (has_sort x t, f)) - (term_has_sort - (App (id, List.rev_map (fun (x,_) -> App (x,[])) xi)) t) - xi - in - let f = List.fold_left (fun f (x,t) -> Forall (x, t, f)) f xi in - (Assert (sort_ax (), f)) :: d :: acc - | DeclPred _ as d -> - d :: acc - | DeclType t as d -> - (DeclPred ("%sort_" ^ t, [t])) :: d :: acc - -let query (hyps, f) = - let hyps' = List.fold_left hyp [] hyps in - List.rev hyps', form f - diff --git a/contrib/dp/dp_sorts.mli b/contrib/dp/dp_sorts.mli deleted file mode 100644 index 9e74f997..00000000 --- a/contrib/dp/dp_sorts.mli +++ /dev/null @@ -1,4 +0,0 @@ - -open Fol - -val query : query -> query diff --git a/contrib/dp/dp_why.ml b/contrib/dp/dp_why.ml index e1ddb039..e24049ad 100644 --- a/contrib/dp/dp_why.ml +++ b/contrib/dp/dp_why.ml @@ -4,6 +4,18 @@ open Format open Fol +type proof = + | Immediate of Term.constr + | Fun_def of string * (string * typ) list * typ * term + +let proofs = Hashtbl.create 97 +let proof_name = + let r = ref 0 in fun () -> incr r; "dp_axiom__" ^ string_of_int !r + +let add_proof pr = let n = proof_name () in Hashtbl.add proofs n pr; n + +let find_proof = Hashtbl.find proofs + let rec print_list sep print fmt = function | [] -> () | [x] -> print fmt x diff --git a/contrib/dp/dp_why.mli b/contrib/dp/dp_why.mli new file mode 100644 index 00000000..b38a3d37 --- /dev/null +++ b/contrib/dp/dp_why.mli @@ -0,0 +1,17 @@ + +open Fol + +(* generation of the Why file *) + +val output_file : string -> query -> unit + +(* table to translate the proofs back to Coq (used in dp_zenon) *) + +type proof = + | Immediate of Term.constr + | Fun_def of string * (string * typ) list * typ * term + +val add_proof : proof -> string +val find_proof : string -> proof + + diff --git a/contrib/dp/dp_zenon.ml b/contrib/dp/dp_zenon.ml deleted file mode 100644 index 57b0a44f..00000000 --- a/contrib/dp/dp_zenon.ml +++ /dev/null @@ -1,103 +0,0 @@ - -open Format -open Fol - -let rec print_list sep print fmt = function - | [] -> () - | [x] -> print fmt x - | x :: r -> print fmt x; sep fmt (); print_list sep print fmt r - -let space fmt () = fprintf fmt "@ " - -let rec print_term fmt = function - | Cst n -> - fprintf fmt "%d" n - | Plus (a, b) -> - fprintf fmt "@[(+@ %a@ %a)@]" print_term a print_term b - | Moins (a, b) -> - fprintf fmt "@[(-@ %a@ %a)@]" print_term a print_term b - | Mult (a, b) -> - fprintf fmt "@[(*@ %a@ %a)@]" print_term a print_term b - | Div (a, b) -> - fprintf fmt "@[(/@ %a@ %a)@]" print_term a print_term b - | App (id, []) -> - fprintf fmt "%s" id - | App (id, tl) -> - fprintf fmt "@[(%s@ %a)@]" id print_terms tl - -and print_terms fmt tl = - print_list space print_term fmt tl - -let rec print_predicate fmt p = - let pp = print_predicate in - match p with - | True -> - fprintf fmt "True" - | False -> - fprintf fmt "False" - | Fatom (Eq (a, b)) -> - fprintf fmt "@[(= %a@ %a)@]" print_term a print_term b - | Fatom (Le (a, b)) -> - fprintf fmt "@[(<= %a@ %a)@]" print_term a print_term b - | Fatom (Lt (a, b))-> - fprintf fmt "@[(< %a@ %a)@]" print_term a print_term b - | Fatom (Ge (a, b)) -> - fprintf fmt "@[(>= %a@ %a)@]" print_term a print_term b - | Fatom (Gt (a, b)) -> - fprintf fmt "@[(> %a@ %a)@]" print_term a print_term b - | Fatom (Pred (id, tl)) -> - fprintf fmt "@[(%s@ %a)@]" id print_terms tl - | Imp (a, b) -> - fprintf fmt "@[(=>@ %a@ %a)@]" pp a pp b - | And (a, b) -> - fprintf fmt "@[(/\\@ %a@ %a)@]" pp a pp b - | Or (a, b) -> - fprintf fmt "@[(\\/@ %a@ %a)@]" pp a pp b - | Not a -> - fprintf fmt "@[(-.@ %a)@]" pp a - | Forall (id, t, p) -> - fprintf fmt "@[(A. ((%s \"%s\")@ %a))@]" id t pp p - | Exists (id, t, p) -> - fprintf fmt "@[(E. ((%s \"%s\")@ %a))@]" id t pp p - -let rec string_of_type_list = function - | [] -> "" - | e :: l' -> e ^ " -> " ^ (string_of_type_list l') - -let print_query fmt (decls,concl) = - let print_decl = function - | DeclVar (id, [], t) -> - fprintf fmt "@[;; %s: %s@]@\n" id t - | DeclVar (id, l, t) -> - fprintf fmt "@[;; %s: %s%s@]@\n" - id (string_of_type_list l) t - | DeclPred (id, l) -> - fprintf fmt "@[;; %s: %sBOOLEAN@]@\n" - id (string_of_type_list l) - | DeclType id -> - fprintf fmt "@[;; %s: TYPE@]@\n" id - | Assert (id, f) -> - fprintf fmt "@[\"%s\" %a@]@\n" id print_predicate f - in - List.iter print_decl decls; - fprintf fmt "$goal %a@." print_predicate concl - -let call q = - let f = Filename.temp_file "coq_dp" ".znn" in - let c = open_out f in - let fmt = formatter_of_out_channel c in - fprintf fmt "@[%a@]@." print_query q; - close_out c; - ignore (Sys.command (sprintf "cat %s" f)); - let cmd = - sprintf "timeout 10 zenon %s > out 2>&1 && grep -q PROOF-FOUND out" f - in - prerr_endline cmd; flush stderr; - let out = Sys.command cmd in - if out = 0 then Valid - else if out = 1 then Invalid - else if out = 137 then Timeout - else Util.anomaly "malformed Zenon input file" - (* TODO: effacer le fichier f et le fichier out *) - - diff --git a/contrib/dp/dp_zenon.mli b/contrib/dp/dp_zenon.mli index 03b6d347..0a727d1f 100644 --- a/contrib/dp/dp_zenon.mli +++ b/contrib/dp/dp_zenon.mli @@ -1,4 +1,7 @@ open Fol -val call : query -> prover_answer +val set_debug : bool -> unit + +val proof_from_file : string -> Proof_type.tactic + diff --git a/contrib/dp/dp_zenon.mll b/contrib/dp/dp_zenon.mll new file mode 100644 index 00000000..2fc2a5f4 --- /dev/null +++ b/contrib/dp/dp_zenon.mll @@ -0,0 +1,181 @@ + +{ + + open Lexing + open Pp + open Util + open Names + open Tacmach + open Dp_why + open Tactics + open Tacticals + + let debug = ref false + let set_debug b = debug := b + + let buf = Buffer.create 1024 + + let string_of_global env ref = + Libnames.string_of_qualid (Nametab.shortest_qualid_of_global env ref) + + let axioms = ref [] + + (* we cannot interpret the terms as we read them (since some lemmas + may need other lemmas to be already interpreted) *) + type lemma = { l_id : string; l_type : string; l_proof : string } + type zenon_proof = lemma list * string + +} + +let ident = ['a'-'z' 'A'-'Z' '_' '0'-'9' '\'']+ +let space = [' ' '\t' '\r'] + +rule start = parse +| "(* BEGIN-PROOF *)" "\n" { scan lexbuf } +| _ { start lexbuf } +| eof { anomaly "malformed Zenon proof term" } + +(* here we read the lemmas and the main proof term; + meanwhile we maintain the set of axioms that were used *) + +and scan = parse +| "Let" space (ident as id) space* ":" + { let t = read_coq_term lexbuf in + let p = read_lemma_proof lexbuf in + let l,pr = scan lexbuf in + { l_id = id; l_type = t; l_proof = p } :: l, pr } +| "Definition theorem:" + { let t = read_main_proof lexbuf in [], t } +| _ | eof + { anomaly "malformed Zenon proof term" } + +and read_coq_term = parse +| "." "\n" + { let s = Buffer.contents buf in Buffer.clear buf; s } +| "coq__" (ident as id) (* a Why keyword renamed *) + { Buffer.add_string buf id; read_coq_term lexbuf } +| ("dp_axiom__" ['0'-'9']+) as id + { axioms := id :: !axioms; Buffer.add_string buf id; read_coq_term lexbuf } +| _ as c + { Buffer.add_char buf c; read_coq_term lexbuf } +| eof + { anomaly "malformed Zenon proof term" } + +and read_lemma_proof = parse +| "Proof" space + { read_coq_term lexbuf } +| _ | eof + { anomaly "malformed Zenon proof term" } + +(* skip the main proof statement and then read its term *) +and read_main_proof = parse +| ":=" "\n" + { read_coq_term lexbuf } +| _ + { read_main_proof lexbuf } +| eof + { anomaly "malformed Zenon proof term" } + + +{ + + let read_zenon_proof f = + Buffer.clear buf; + let c = open_in f in + let lb = from_channel c in + let p = start lb in + close_in c; + if not !debug then begin try Sys.remove f with _ -> () end; + p + + let constr_of_string gl s = + let parse_constr = Pcoq.parse_string Pcoq.Constr.constr in + Constrintern.interp_constr (project gl) (pf_env gl) (parse_constr s) + + (* we are lazy here: we build strings containing Coq terms using a *) + (* pretty-printer Fol -> Coq *) + module Coq = struct + open Format + open Fol + + let rec print_list sep print fmt = function + | [] -> () + | [x] -> print fmt x + | x :: r -> print fmt x; sep fmt (); print_list sep print fmt r + + let space fmt () = fprintf fmt "@ " + let comma fmt () = fprintf fmt ",@ " + + let rec print_typ fmt = function + | Tvar x -> fprintf fmt "%s" x + | Tid ("int", []) -> fprintf fmt "Z" + | Tid (x, []) -> fprintf fmt "%s" x + | Tid (x, [t]) -> fprintf fmt "(%s %a)" x print_typ t + | Tid (x,tl) -> + fprintf fmt "(%s %a)" x (print_list comma print_typ) tl + + let rec print_term fmt = function + | Cst n -> + fprintf fmt "%d" n + | Plus (a, b) -> + fprintf fmt "@[(Zplus %a %a)@]" print_term a print_term b + | Moins (a, b) -> + fprintf fmt "@[(Zminus %a %a)@]" print_term a print_term b + | Mult (a, b) -> + fprintf fmt "@[(Zmult %a %a)@]" print_term a print_term b + | Div (a, b) -> + fprintf fmt "@[(Zdiv %a %a)@]" print_term a print_term b + | App (id, []) -> + fprintf fmt "%s" id + | App (id, tl) -> + fprintf fmt "@[(%s %a)@]" id print_terms tl + + and print_terms fmt tl = + print_list space print_term fmt tl + + (* builds the text for "forall vars, f vars = t" *) + let fun_def_axiom f vars t = + let binder fmt (x,t) = fprintf fmt "(%s: %a)" x print_typ t in + fprintf str_formatter + "@[(forall %a, %s %a = %a)@]@." + (print_list space binder) vars f + (print_list space (fun fmt (x,_) -> pp_print_string fmt x)) vars + print_term t; + flush_str_formatter () + + end + + let prove_axiom id = match Dp_why.find_proof id with + | Immediate t -> + exact_check t + | Fun_def (f, vars, ty, t) -> + tclTHENS + (fun gl -> + let s = Coq.fun_def_axiom f vars t in + if !debug then Format.eprintf "axiom fun def = %s@." s; + let c = constr_of_string gl s in + assert_tac true (Name (id_of_string id)) c gl) + [tclTHEN intros reflexivity; tclIDTAC] + + let exact_string s gl = + let c = constr_of_string gl s in + exact_check c gl + + let interp_zenon_proof (ll,p) = + let interp_lemma l gl = + let ty = constr_of_string gl l.l_type in + tclTHENS + (assert_tac true (Name (id_of_string l.l_id)) ty) + [exact_string l.l_proof; tclIDTAC] + gl + in + tclTHEN (tclMAP interp_lemma ll) (exact_string p) + + let proof_from_file f = + axioms := []; + msgnl (str "proof_from_file " ++ str f); + let zp = read_zenon_proof f in + msgnl (str "proof term is " ++ str (snd zp)); + tclTHEN (tclMAP prove_axiom !axioms) (interp_zenon_proof zp) + +} diff --git a/contrib/dp/fol.mli b/contrib/dp/fol.mli index a85469cc..b94bd3e3 100644 --- a/contrib/dp/fol.mli +++ b/contrib/dp/fol.mli @@ -45,4 +45,11 @@ type query = decl list * form (* prover result *) -type prover_answer = Valid | Invalid | DontKnow | Timeout +type prover_answer = + | Valid of string option + | Invalid + | DontKnow + | Timeout + | NoAnswer + | Failure of string + diff --git a/contrib/dp/g_dp.ml4 b/contrib/dp/g_dp.ml4 index eb7fb73b..99bcf477 100644 --- a/contrib/dp/g_dp.ml4 +++ b/contrib/dp/g_dp.ml4 @@ -8,7 +8,7 @@ (*i camlp4deps: "parsing/grammar.cma" i*) -(* $Id: g_dp.ml4 7165 2005-06-24 12:56:46Z coq $ *) +(* $Id: g_dp.ml4 10924 2008-05-13 14:01:11Z filliatr $ *) open Dp @@ -16,6 +16,14 @@ TACTIC EXTEND Simplify [ "simplify" ] -> [ simplify ] END +TACTIC EXTEND Ergo + [ "ergo" ] -> [ ergo ] +END + +TACTIC EXTEND Yices + [ "yices" ] -> [ yices ] +END + TACTIC EXTEND CVCLite [ "cvcl" ] -> [ cvc_lite ] END @@ -28,6 +36,18 @@ TACTIC EXTEND Zenon [ "zenon" ] -> [ zenon ] END +TACTIC EXTEND Gwhy + [ "gwhy" ] -> [ gwhy ] +END + +TACTIC EXTEND Gappa_internal + [ "gappa_internal" ] -> [ Dp_gappa.gappa_internal ] +END + +TACTIC EXTEND Gappa + [ "gappa" ] -> [ Dp_gappa.gappa ] +END + (* should be part of basic tactics syntax *) TACTIC EXTEND admit [ "admit" ] -> [ Tactics.admit_as_an_axiom ] @@ -36,3 +56,24 @@ END VERNAC COMMAND EXTEND Dp_hint [ "Dp_hint" ne_global_list(l) ] -> [ dp_hint l ] END + +VERNAC COMMAND EXTEND Dp_timeout +| [ "Dp_timeout" natural(n) ] -> [ dp_timeout n ] +END + +VERNAC COMMAND EXTEND Dp_prelude +| [ "Dp_prelude" string_list(l) ] -> [ dp_prelude l ] +END + +VERNAC COMMAND EXTEND Dp_predefined +| [ "Dp_predefined" global(g) "=>" string(s) ] -> [ dp_predefined g s ] +END + +VERNAC COMMAND EXTEND Dp_debug +| [ "Dp_debug" ] -> [ dp_debug true; Dp_zenon.set_debug true ] +END + +VERNAC COMMAND EXTEND Dp_trace +| [ "Dp_trace" ] -> [ dp_trace true ] +END + diff --git a/contrib/dp/test2.v b/contrib/dp/test2.v index 4e933a3c..3e4c0f6d 100644 --- a/contrib/dp/test2.v +++ b/contrib/dp/test2.v @@ -5,6 +5,10 @@ Require Import List. Open Scope list_scope. Open Scope Z_scope. +Dp_debug. +Dp_timeout 3. +Require Export zenon. + Definition neg (z:Z) : Z := match z with | Z0 => Z0 | Zpos p => Zneg p @@ -18,9 +22,7 @@ Open Scope nat_scope. Print plus. Goal forall x, x+0=x. - induction x. - zenon. - zenon. + induction x; ergo. (* simplify resoud le premier, pas le second *) Admitted. diff --git a/contrib/dp/test_gappa.v b/contrib/dp/test_gappa.v new file mode 100644 index 00000000..eb65a59d --- /dev/null +++ b/contrib/dp/test_gappa.v @@ -0,0 +1,91 @@ +Require Export Gappa_tactic. +Require Export Reals. + +Open Scope Z_scope. +Open Scope R_scope. + +Lemma test_base10 : + forall x y:R, + 0 <= x <= 4 -> + 0 <= x * (24 * powerRZ 10 (-1)) <= 10. +Proof. + gappa. +Qed. + +(* +@rnd = float< ieee_32, zr >; +a = rnd(a_); b = rnd(b_); +{ a in [3.2,3.3] /\ b in [1.4,1.9] -> + rnd(a - b) - (a - b) in [0,0] } +*) + +Definition rnd := gappa_rounding (rounding_float roundZR 43 (120)). + +Lemma test_float3 : + forall a_ b_ a b : R, + a = rnd a_ -> + b = rnd b_ -> + 52 / 16 <= a <= 53 / 16 -> + 22 / 16 <= b <= 30 / 16 -> + 0 <= rnd (a - b) - (a - b) <= 0. +Proof. + unfold rnd. + gappa. +Qed. + +Lemma test_float2 : + forall x y:R, + 0 <= x <= 1 -> + 0 <= y <= 1 -> + 0 <= gappa_rounding (rounding_float roundNE 53 (1074)) (x+y) <= 2. +Proof. + gappa. +Qed. + +Lemma test_float1 : + forall x y:R, + 0 <= gappa_rounding (rounding_fixed roundDN (0)) x - + gappa_rounding (rounding_fixed roundDN (0)) y <= 0 -> + Rabs (x - y) <= 1. +Proof. + gappa. +Qed. + +Lemma test1 : + forall x y:R, + 0 <= x <= 1 -> + 0 <= -y <= 1 -> + 0 <= x * (-y) <= 1. +Proof. + gappa. +Qed. + +Lemma test2 : + forall x y:R, + 3/4 <= x <= 3 -> + 0 <= sqrt x <= 1775 * (powerRZ 2 (-10)). +Proof. + gappa. +Qed. + +Lemma test3 : + forall x y z:R, + 0 <= x - y <= 3 -> + -2 <= y - z <= 4 -> + -2 <= x - z <= 7. +Proof. + gappa. +Qed. + +Lemma test4 : + forall x1 x2 y1 y2 : R, + 1 <= Rabs y1 <= 1000 -> + 1 <= Rabs y2 <= 1000 -> + - powerRZ 2 (-53) <= (x1 - y1) / y1 <= powerRZ 2 (-53) -> + - powerRZ 2 (-53) <= (x2 - y2) / y2 <= powerRZ 2 (-53) -> + - powerRZ 2 (-51) <= (x1 * x2 - y1 * y2) / (y1 * y2) <= powerRZ 2 (-51). +Proof. + gappa. +Qed. + + diff --git a/contrib/dp/tests.v b/contrib/dp/tests.v index 52a57a0c..a6d4f2e1 100644 --- a/contrib/dp/tests.v +++ b/contrib/dp/tests.v @@ -2,48 +2,115 @@ Require Import ZArith. Require Import Classical. +Dp_debug. +Dp_timeout 3. + +(* module renamings *) + +Module M. + Parameter t : Set. +End M. + +Lemma test_module_0 : forall x:M.t, x=x. +ergo. +Qed. + +Module N := M. + +Lemma test_module_renaming_0 : forall x:N.t, x=x. +ergo. +Qed. + +Dp_predefined M.t => "int". + +Lemma test_module_renaming_1 : forall x:N.t, x=x. +ergo. +Qed. + +(* Coq lists *) + +Require Export List. + +Lemma test_pol_0 : forall l:list nat, l=l. +ergo. +Qed. + +Parameter nlist: list nat -> Prop. + +Lemma poly_1 : forall l, nlist l -> True. +intros. +simplify. +Qed. + +(* user lists *) + +Inductive list (A:Set) : Set := +| nil : list A +| cons: forall a:A, list A -> list A. + +Fixpoint app (A:Set) (l m:list A) {struct l} : list A := +match l with +| nil => m +| cons a l1 => cons A a (app A l1 m) +end. + +Lemma entail: (nil Z) = app Z (nil Z) (nil Z) -> True. +intros; ergo. +Qed. + +(* polymorphism *) +Require Import List. + +Inductive mylist (A:Set) : Set := + mynil : mylist A +| mycons : forall a:A, mylist A -> mylist A. + +Parameter my_nlist: mylist nat -> Prop. + + Goal forall l, my_nlist l -> True. + intros. + simplify. +Qed. + (* First example with the 0 and the equality translated *) Goal 0 = 0. -zenon. +simplify. Qed. - (* Examples in the Propositional Calculus and theory of equality *) Parameter A C : Prop. Goal A -> A. -zenon. +simplify. Qed. Goal A -> (A \/ C). -zenon. +simplify. Qed. Parameter x y z : Z. Goal x = y -> y = z -> x = z. - -zenon. +ergo. Qed. Goal ((((A -> C) -> A) -> A) -> C) -> C. -zenon. +ergo. Qed. - (* Arithmetic *) Open Scope Z_scope. Goal 1 + 1 = 2. -simplify. +yices. Qed. @@ -57,14 +124,12 @@ Qed. Goal (forall (x y : Z), x = y) -> 0=1. try zenon. -simplify. +ergo. Qed. Goal forall (x: nat), (x + 0 = x)%nat. -induction x0. -zenon. -zenon. +induction x0; ergo. Qed. @@ -106,7 +171,7 @@ Inductive even : Z -> Prop := unlike CVC Lite *) Goal even 4. -cvcl. +ergo. Qed. @@ -115,8 +180,7 @@ Definition skip_z (z : Z) (n : nat) := n. Definition skip_z1 := skip_z. Goal forall (z : Z) (n : nat), skip_z z n = skip_z1 z n. - -zenon. +yices. Qed. @@ -133,8 +197,7 @@ Dp_hint add_S. unlike zenon *) Goal forall n : nat, add n 0 = n. - -induction n ; zenon. +induction n ; yices. Qed. @@ -144,8 +207,8 @@ Definition pred (n : nat) : nat := match n with end. Goal forall n : nat, n <> 0%nat -> pred (S n) <> 0%nat. - -zenon. +yices. +(*zenon.*) Qed. @@ -157,7 +220,7 @@ end. Goal forall n : nat, plus n 0%nat = n. -induction n; zenon. +induction n; ergo. Qed. @@ -173,8 +236,11 @@ with odd_b (n : nat) : bool := match n with end. Goal even_b (S (S O)) = true. - +ergo. +(* +simplify. zenon. +*) Qed. @@ -184,7 +250,8 @@ Parameter foo : Set. Parameter ff : nat -> foo -> foo -> nat. Parameter g : foo -> foo. Goal (forall x:foo, ff 0 x x = O) -> forall y, ff 0 (g y) (g y) = O. -zenon. +yices. +(*zenon.*) Qed. @@ -194,7 +261,8 @@ Qed. Parameter poly_f : forall A:Set, A->A. Goal forall x:nat, poly_f nat x = poly_f nat x. -zenon. +ergo. +(*zenon.*) Qed. diff --git a/contrib/dp/zenon.v b/contrib/dp/zenon.v new file mode 100644 index 00000000..4ad00a11 --- /dev/null +++ b/contrib/dp/zenon.v @@ -0,0 +1,94 @@ +(* Copyright 2004 INRIA *) +(* $Id: zenon.v 10739 2008-04-01 14:45:20Z herbelin $ *) + +Require Export Classical. + +Lemma zenon_nottrue : + (~True -> False). +Proof. tauto. Qed. + +Lemma zenon_noteq : forall (T : Type) (t : T), + ((t <> t) -> False). +Proof. tauto. Qed. + +Lemma zenon_and : forall P Q : Prop, + (P -> Q -> False) -> (P /\ Q -> False). +Proof. tauto. Qed. + +Lemma zenon_or : forall P Q : Prop, + (P -> False) -> (Q -> False) -> (P \/ Q -> False). +Proof. tauto. Qed. + +Lemma zenon_imply : forall P Q : Prop, + (~P -> False) -> (Q -> False) -> ((P -> Q) -> False). +Proof. tauto. Qed. + +Lemma zenon_equiv : forall P Q : Prop, + (~P -> ~Q -> False) -> (P -> Q -> False) -> ((P <-> Q) -> False). +Proof. tauto. Qed. + +Lemma zenon_notand : forall P Q : Prop, + (~P -> False) -> (~Q -> False) -> (~(P /\ Q) -> False). +Proof. tauto. Qed. + +Lemma zenon_notor : forall P Q : Prop, + (~P -> ~Q -> False) -> (~(P \/ Q) -> False). +Proof. tauto. Qed. + +Lemma zenon_notimply : forall P Q : Prop, + (P -> ~Q -> False) -> (~(P -> Q) -> False). +Proof. tauto. Qed. + +Lemma zenon_notequiv : forall P Q : Prop, + (~P -> Q -> False) -> (P -> ~Q -> False) -> (~(P <-> Q) -> False). +Proof. tauto. Qed. + +Lemma zenon_ex : forall (T : Type) (P : T -> Prop), + (forall z : T, ((P z) -> False)) -> ((exists x : T, (P x)) -> False). +Proof. firstorder. Qed. + +Lemma zenon_all : forall (T : Type) (P : T -> Prop) (t : T), + ((P t) -> False) -> ((forall x : T, (P x)) -> False). +Proof. firstorder. Qed. + +Lemma zenon_notex : forall (T : Type) (P : T -> Prop) (t : T), + (~(P t) -> False) -> (~(exists x : T, (P x)) -> False). +Proof. firstorder. Qed. + +Lemma zenon_notall : forall (T : Type) (P : T -> Prop), + (forall z : T, (~(P z) -> False)) -> (~(forall x : T, (P x)) -> False). +Proof. intros T P Ha Hb. apply Hb. intro. apply NNPP. exact (Ha x). Qed. + +Lemma zenon_equal_base : forall (T : Type) (f : T), f = f. +Proof. auto. Qed. + +Lemma zenon_equal_step : + forall (S T : Type) (fa fb : S -> T) (a b : S), + (fa = fb) -> (a <> b -> False) -> ((fa a) = (fb b)). +Proof. intros. rewrite (NNPP (a = b)). congruence. auto. Qed. + +Lemma zenon_pnotp : forall P Q : Prop, + (P = Q) -> (P -> ~Q -> False). +Proof. intros P Q Ha. rewrite Ha. auto. Qed. + +Lemma zenon_notequal : forall (T : Type) (a b : T), + (a = b) -> (a <> b -> False). +Proof. auto. Qed. + +Ltac zenon_intro id := + intro id || let nid := fresh in (intro nid; clear nid) +. + +Definition zenon_and_s := fun P Q a b => zenon_and P Q b a. +Definition zenon_or_s := fun P Q a b c => zenon_or P Q b c a. +Definition zenon_imply_s := fun P Q a b c => zenon_imply P Q b c a. +Definition zenon_equiv_s := fun P Q a b c => zenon_equiv P Q b c a. +Definition zenon_notand_s := fun P Q a b c => zenon_notand P Q b c a. +Definition zenon_notor_s := fun P Q a b => zenon_notor P Q b a. +Definition zenon_notimply_s := fun P Q a b => zenon_notimply P Q b a. +Definition zenon_notequiv_s := fun P Q a b c => zenon_notequiv P Q b c a. +Definition zenon_ex_s := fun T P a b => zenon_ex T P b a. +Definition zenon_notall_s := fun T P a b => zenon_notall T P b a. + +Definition zenon_pnotp_s := fun P Q a b c => zenon_pnotp P Q c a b. +Definition zenon_notequal_s := fun T a b x y => zenon_notequal T a b y x. diff --git a/contrib/extraction/CHANGES b/contrib/extraction/CHANGES index 83ea4910..acd1dbda 100644 --- a/contrib/extraction/CHANGES +++ b/contrib/extraction/CHANGES @@ -346,8 +346,8 @@ Dyade/BDDS boolean tautology checker. Lyon/CIRCUITS multiplication via a modelization of a circuit. Lyon/FIRING-SQUAD print the states of the firing squad. Marseille/CIRCUITS compares integers via a modelization of a circuit. -Nancy/FOUnify unification of two first-orderde deux termes. -Rocq/ARITH/Chinese computation of the chinese remaindering. +Nancy/FOUnify unification of two first-order terms. +Rocq/ARITH/Chinese computation of the chinese remainder. Rocq/COC small coc typechecker. (test by B. Barras, not by me) Rocq/HIGMAN run the proof on one example. Rocq/GRAPHS linear constraints checker in Z. diff --git a/contrib/extraction/common.ml b/contrib/extraction/common.ml index 346201ec..5ad4a288 100644 --- a/contrib/extraction/common.ml +++ b/contrib/extraction/common.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: common.ml 8930 2006-06-09 02:14:34Z letouzey $ i*) +(*i $Id: common.ml 10596 2008-02-27 15:30:11Z letouzey $ i*) open Pp open Util @@ -17,42 +17,218 @@ open Nameops open Libnames open Table open Miniml +open Mlutil open Modutil -open Ocaml +open Mod_subst -(*S Renamings. *) +(*s Some pretty-print utility functions. *) + +let pp_par par st = if par then str "(" ++ st ++ str ")" else st + +let pp_apply st par args = match args with + | [] -> st + | _ -> hov 2 (pp_par par (st ++ spc () ++ prlist_with_sep spc identity args)) + +let pr_binding = function + | [] -> mt () + | l -> str " " ++ prlist_with_sep (fun () -> str " ") pr_id l + +let fnl2 () = fnl () ++ fnl () + +let space_if = function true -> str " " | false -> mt () + +let sec_space_if = function true -> spc () | false -> mt () + +let is_digit = function + | '0'..'9' -> true + | _ -> false + +let begins_with_CoqXX s = + let n = String.length s in + n >= 4 && s.[0] = 'C' && s.[1] = 'o' && s.[2] = 'q' && + let i = ref 3 in + try while !i < n do + if s.[!i] = '_' then i:=n (*Stop*) + else if is_digit s.[!i] then incr i + else raise Not_found + done; true + with Not_found -> false + +let unquote s = + if lang () <> Scheme then s + else + let s = String.copy s in + for i=0 to String.length s - 1 do if s.[i] = '\'' then s.[i] <- '~' done; + s + +let rec dottify = function + | [] -> assert false + | [s] -> unquote s + | s::[""] -> unquote s + | s::l -> (dottify l)^"."^(unquote s) + +(*s Uppercase/lowercase renamings. *) + +let is_upper s = match s.[0] with 'A' .. 'Z' -> true | _ -> false +let is_lower s = match s.[0] with 'a' .. 'z' | '_' -> true | _ -> false + +let lowercase_id id = id_of_string (String.uncapitalize (string_of_id id)) +let uppercase_id id = id_of_string (String.capitalize (string_of_id id)) + +(* [pr_upper_id id] makes 2 String.copy lesser than [pr_id (uppercase_id id)] *) +let pr_upper_id id = str (String.capitalize (string_of_id id)) + + +(*s de Bruijn environments for programs *) + +type env = identifier list * Idset.t + +(*s Generic renaming issues for local variable names. *) + +let rec rename_id id avoid = + if Idset.mem id avoid then rename_id (lift_ident id) avoid else id + +let rec rename_vars avoid = function + | [] -> + [], avoid + | id :: idl when id == dummy_name -> + (* we don't rename dummy binders *) + let (idl', avoid') = rename_vars avoid idl in + (id :: idl', avoid') + | id :: idl -> + let (idl, avoid) = rename_vars avoid idl in + let id = rename_id (lowercase_id id) avoid in + (id :: idl, Idset.add id avoid) + +let rename_tvars avoid l = + let rec rename avoid = function + | [] -> [],avoid + | id :: idl -> + let id = rename_id (lowercase_id id) avoid in + let idl, avoid = rename (Idset.add id avoid) idl in + (id :: idl, avoid) in + fst (rename avoid l) + +let push_vars ids (db,avoid) = + let ids',avoid' = rename_vars avoid ids in + ids', (ids' @ db, avoid') + +let get_db_name n (db,_) = + let id = List.nth db (pred n) in + if id = dummy_name then id_of_string "__" else id + + +(*S Renamings of global objects. *) (*s Tables of global renamings *) let keywords = ref Idset.empty +let set_keywords kws = keywords := kws + let global_ids = ref Idset.empty -let modular = ref false +let add_global_ids s = global_ids := Idset.add s !global_ids +let global_ids_list () = Idset.elements !global_ids + +let empty_env () = [], !global_ids + +let mktable () = + let h = Hashtbl.create 97 in + (Hashtbl.add h, Hashtbl.find h, fun () -> Hashtbl.clear h) + +let mkset () = + let h = Hashtbl.create 97 in + (fun x -> Hashtbl.add h x ()), (Hashtbl.mem h), (fun () -> Hashtbl.clear h) + +let mktriset () = + let h = Hashtbl.create 97 in + (fun x y z -> Hashtbl.add h (x,y,z) ()), + (fun x y z -> Hashtbl.mem h (x,y,z)), + (fun () -> Hashtbl.clear h) (* For each [global_reference], this table will contain the different parts - of its renamings, in [string list] form. *) -let renamings = Hashtbl.create 97 -let rename r l = Hashtbl.add renamings r l -let get_renamings r = Hashtbl.find renamings r + of its renaming, in [string list] form. *) +let add_renaming, get_renaming, clear_renaming = mktable () (* Idem for [module_path]. *) -let mp_renamings = Hashtbl.create 97 -let mp_rename mp l = Hashtbl.add mp_renamings mp l -let mp_get_renamings mp = Hashtbl.find mp_renamings mp +let add_mp_renaming, get_mp_renaming, clear_mp_renaming = mktable () -let modvisited = ref MPset.empty -let modcontents = ref Gset.empty -let add_module_contents mp s = modcontents := Gset.add (mp,s) !modcontents -let module_contents mp s = Gset.mem (mp,s) !modcontents +(* A table for function modfstlev_rename *) +let add_modfstlev, get_modfstlev, clear_modfstlev = mktable () -let to_qualify = ref Refset.empty +(* A set of all external objects that will have to be fully qualified *) +let add_static_clash, static_clash, clear_static_clash = mkset () -let mod_1st_level = ref Idmap.empty +(* Two tables of triplets [kind * module_path * string]. The first one + will record the first level of all MPfile, not only the current one. + The second table will contains local renamings. *) -(*s Uppercase/lowercase renamings. *) +type kind = Term | Type | Cons | Mod -let is_upper s = match s.[0] with 'A' .. 'Z' -> true | _ -> false +let add_ext_mpmem, ext_mpmem, clear_ext_mpmem = mktriset () +let add_loc_mpmem, loc_mpmem, clear_loc_mpmem = mktriset () + +(* The list of external modules that will be opened initially *) +let add_mpfiles, mem_mpfiles, list_mpfiles, clear_mpfiles = + let m = ref MPset.empty in + (fun mp -> m:= MPset.add mp !m), + (fun mp -> MPset.mem mp !m), + (fun () -> MPset.elements !m), + (fun () -> m:= MPset.empty) + +(*s table containing the visible horizon at a precise moment *) + +let visible = ref ([] : module_path list) +let pop_visible () = visible := List.tl !visible +let push_visible mp = visible := mp :: !visible +let top_visible_mp () = List.hd !visible + +(*s substitutions for printing signatures *) + +let substs = ref empty_subst +let add_subst msid mp = substs := add_msid msid mp !substs +let subst_mp mp = subst_mp !substs mp +let subst_kn kn = subst_kn !substs kn +let subst_con c = fst (subst_con !substs c) +let subst_ref = function + | ConstRef con -> ConstRef (subst_con con) + | IndRef (kn,i) -> IndRef (subst_kn kn,i) + | ConstructRef ((kn,i),j) -> ConstructRef ((subst_kn kn,i),j) + | _ -> assert false -let is_lower s = match s.[0] with 'a' .. 'z' | '_' -> true | _ -> false + +let duplicate_index = ref 0 +let to_duplicate = ref Gmap.empty +let add_duplicate mp l = + incr duplicate_index; + let ren = "Coq__" ^ string_of_int (!duplicate_index) in + to_duplicate := Gmap.add (mp,l) ren !to_duplicate +let check_duplicate mp l = + let mp' = subst_mp mp in + Gmap.find (mp',l) !to_duplicate + +type reset_kind = OnlyLocal | AllButExternal | Everything + +let reset_allbutext () = + clear_loc_mpmem (); + global_ids := !keywords; + clear_renaming (); + clear_mp_renaming (); + clear_modfstlev (); + clear_static_clash (); + clear_mpfiles (); + duplicate_index := 0; + to_duplicate := Gmap.empty; + visible := []; + substs := empty_subst + +let reset_everything () = reset_allbutext (); clear_ext_mpmem () + +let reset_renaming_tables = function + | OnlyLocal -> clear_loc_mpmem () + | AllButExternal -> reset_allbutext () + | Everything -> reset_everything () + +(*S Renaming functions *) (* This function creates from [id] a correct uppercase/lowercase identifier. This is done by adding a [Coq_] or [coq_] prefix. To avoid potential clashes @@ -69,389 +245,238 @@ let modular_rename up id = then prefix ^ s else s -let rename_module = modular_rename true - -(* [clash mp0 l s mpl] checks if [mp0-l-s] can be printed as [l-s] when - [mpl] is the context of visible modules. More precisely, we check if - there exists a mp1, module (sub-)path of an element of [mpl], such as - module [mp1-l] contains [s]. - The verification stops if we encounter [mp1=mp0]. *) - -exception Stop - -let clash mp0 l s mpl = - let rec clash_one mp = match mp with - | _ when mp = mp0 -> raise Stop - | MPdot (mp',_) -> - (module_contents (add_labels_mp mp l) s) || (clash_one mp') - | mp when is_toplevel mp -> false - | _ -> module_contents (add_labels_mp mp l) s +(*s [record_contents_fstlev] finds the names of the first-level objects + exported by the ground-level modules in [struc]. *) + +let rec record_contents_fstlev struc = + let upper_type = (lang () = Haskell) in + let addtyp mp id = add_ext_mpmem Type mp (modular_rename upper_type id) in + let addcons mp id = add_ext_mpmem Cons mp (modular_rename true id) in + let addterm mp id = add_ext_mpmem Term mp (modular_rename false id) in + let addmod mp id = add_ext_mpmem Mod mp (modular_rename true id) in + let addfix mp r = + add_ext_mpmem Term mp (modular_rename false (id_of_global r)) + in + let f mp = function + | (l,SEdecl (Dind (_,ind))) -> + Array.iter + (fun ip -> + addtyp mp ip.ip_typename; Array.iter (addcons mp) ip.ip_consnames) + ind.ind_packets + | (l,SEdecl (Dtype _)) -> addtyp mp (id_of_label l) + | (l,SEdecl (Dterm _)) -> addterm mp (id_of_label l) + | (l,SEdecl (Dfix (rv,_,_))) -> Array.iter (addfix mp) rv + | (l,SEmodule _) -> addmod mp (id_of_label l) + | (l,SEmodtype _) -> addmod mp (id_of_label l) in - let rec clash_list = function - | [] -> false - | mp :: mpl -> (clash_one mp) || (clash_list mpl) - in try clash_list mpl with Stop -> false - -(*s [contents_first_level mp] finds the names of the first-level objects - exported by module [mp]. Nota: it might fail if [mp] isn't a directly - visible module. Ex: [MPself] under functor, [MPbound], etc ... *) - -let contents_first_level mp = - if not (MPset.mem mp !modvisited) then begin - modvisited := MPset.add mp !modvisited; - match (Global.lookup_module mp).mod_type with - | MTBsig (msid,msb) -> - let add b id = add_module_contents mp (modular_rename b id) in - let upper_type = (lang () = Haskell) in - List.iter - (function - | (l, SPBconst cb) -> - (match Extraction.constant_kind (Global.env ()) cb with - | Extraction.Logical -> () - | Extraction.Type -> add upper_type (id_of_label l) - | Extraction.Term -> add false (id_of_label l)) - | (_, SPBmind mib) -> - Array.iter - (fun mip -> if snd (Inductive.mind_arity mip) <> InProp - then begin - add upper_type mip.mind_typename; - Array.iter (add true) mip.mind_consnames - end) - mib.mind_packets - | _ -> ()) - (Modops.subst_signature_msid msid mp msb) - | _ -> () - end + List.iter (fun (mp,sel) -> List.iter (f mp) sel) struc -(*s Initial renamings creation, for modular extraction. *) +(*s For monolithic extraction, first-level modules might have to be renamed + with unique numbers *) -let rec mp_create_modular_renamings mp = - try mp_get_renamings mp +let modfstlev_rename l = + let coqid = id_of_string "Coq" in + let id = id_of_label l in + try + let coqset = get_modfstlev id in + let nextcoq = next_ident_away coqid coqset in + add_modfstlev id (nextcoq::coqset); + (string_of_id nextcoq)^"_"^(string_of_id id) + with Not_found -> + let s = string_of_id id in + if is_lower s || begins_with_CoqXX s then + (add_modfstlev id [coqid]; "Coq_"^s) + else + (add_modfstlev id []; s) + + +(*s Creating renaming for a [module_path] *) + +let rec mp_create_renaming mp = + try get_mp_renaming mp with Not_found -> let ren = match mp with + | _ when not (modular ()) && at_toplevel mp -> [""] | MPdot (mp,l) -> - (rename_module (id_of_label l)) :: (mp_create_modular_renamings mp) - | MPself msid -> [rename_module (id_of_msid msid)] - | MPbound mbid -> [rename_module (id_of_mbid mbid)] - | MPfile f -> [String.capitalize (string_of_id (List.hd (repr_dirpath f)))] - in mp_rename mp ren; ren + let lmp = mp_create_renaming mp in + if lmp = [""] then (modfstlev_rename l)::lmp + else (modular_rename true (id_of_label l))::lmp + | MPself msid -> [modular_rename true (id_of_msid msid)] + | MPbound mbid -> [modular_rename true (id_of_mbid mbid)] + | MPfile _ when not (modular ()) -> assert false + | MPfile _ -> [string_of_modfile mp] + in add_mp_renaming mp ren; ren + +(* [clash mp0 s mpl] checks if [mp0-s] can be printed as [s] when + [mpl] is the context of visible modules. More precisely, we check if + there exists a [mp] in [mpl] that contains [s]. + The verification stops if we encounter [mp=mp0]. *) +let rec clash mem mp0 s = function + | [] -> false + | mp :: _ when mp = mp0 -> false + | mp :: mpl -> mem mp s || clash mem mp0 s mpl + +(*s Initial renamings creation, for modular extraction. *) let create_modular_renamings struc = let current_module = fst (List.hd struc) in - let modfiles = ref MPset.empty in - let { up = u ; down = d } = struct_get_references_set struc + let { typ = ty ; trm = tr ; cons = co } = struct_get_references_set struc in (* 1) creates renamings of objects *) let add upper r = let mp = modpath_of_r r in - let l = mp_create_modular_renamings mp in + let l = mp_create_renaming mp in let s = modular_rename upper (id_of_global r) in - global_ids := Idset.add (id_of_string s) !global_ids; - rename r (s::l); + add_global_ids (id_of_string s); + add_renaming r (s::l); begin try - let mp = modfile_of_mp mp in - if mp <> current_module then modfiles := MPset.add mp !modfiles + let mp = modfile_of_mp mp in if mp <> current_module then add_mpfiles mp with Not_found -> () end; in - Refset.iter (add true) u; - Refset.iter (add false) d; + Refset.iter (add (lang () = Haskell)) ty; + Refset.iter (add true) co; + Refset.iter (add false) tr; (* 2) determines the opened libraries. *) - let used_modules = MPset.elements !modfiles in - - (* [s] will contain all first-level sub-modules of [cur_mp] *) - let s = ref Stringset.empty in - begin - let add l = s := Stringset.add (rename_module (id_of_label l)) !s in - match (Global.lookup_module current_module).mod_type with - | MTBsig (_,msb) -> - List.iter (function (l,SPBmodule _) -> add l | _ -> ()) msb - | _ -> () - end; - (* We now compare [s] with the modules coming from [used_modules]. *) - List.iter - (function - | MPfile d -> - let s_mp = - String.capitalize (string_of_id (List.hd (repr_dirpath d))) in - if Stringset.mem s_mp !s then error_module_clash s_mp - else s:= Stringset.add s_mp !s - | _ -> assert false) - used_modules; + let used_modules = list_mpfiles () in + let used_modules' = List.rev used_modules in + let str_list = List.map string_of_modfile used_modules' + in + let rec check_elsewhere mpl sl = match mpl, sl with + | [], [] -> [] + | mp::mpl, _::sl -> + if List.exists (ext_mpmem Mod mp) sl then + check_elsewhere mpl sl + else mp :: (check_elsewhere mpl sl) + | _ -> assert false + in + let opened_modules = check_elsewhere used_modules' str_list in + clear_mpfiles (); + List.iter add_mpfiles opened_modules; (* 3) determines the potential clashes *) - List.iter contents_first_level used_modules; - let used_modules' = List.rev used_modules in - let needs_qualify r = + let needs_qualify k r = let mp = modpath_of_r r in - if (is_modfile mp) && mp <> current_module && - (clash mp [] (List.hd (get_renamings r)) used_modules') - then to_qualify := Refset.add r !to_qualify + if (is_modfile mp) && mp <> current_module && + (clash (ext_mpmem k) mp (List.hd (get_renaming r)) opened_modules) + then add_static_clash r in - Refset.iter needs_qualify u; - Refset.iter needs_qualify d; - used_modules + Refset.iter (needs_qualify Type) ty; + Refset.iter (needs_qualify Term) tr; + Refset.iter (needs_qualify Cons) co; + List.rev opened_modules (*s Initial renamings creation, for monolithic extraction. *) -let begins_with_CoqXX s = - (String.length s >= 4) && - (String.sub s 0 3 = "Coq") && - (try - for i = 4 to (String.index s '_')-1 do - match s.[i] with - | '0'..'9' -> () - | _ -> raise Not_found - done; - true - with Not_found -> false) - -let mod_1st_level_rename l = - let coqid = id_of_string "Coq" in - let id = id_of_label l in - try - let coqset = Idmap.find id !mod_1st_level in - let nextcoq = next_ident_away coqid coqset in - mod_1st_level := Idmap.add id (nextcoq::coqset) !mod_1st_level; - (string_of_id nextcoq)^"_"^(string_of_id id) - with Not_found -> - let s = string_of_id id in - if is_lower s || begins_with_CoqXX s then - (mod_1st_level := Idmap.add id [coqid] !mod_1st_level; "Coq_"^s) - else - (mod_1st_level := Idmap.add id [] !mod_1st_level; s) - -let rec mp_create_mono_renamings mp = - try mp_get_renamings mp - with Not_found -> - let ren = match mp with - | _ when (at_toplevel mp) -> [""] - | MPdot (mp,l) -> - let lmp = mp_create_mono_renamings mp in - if lmp = [""] then (mod_1st_level_rename l)::lmp - else (rename_module (id_of_label l))::lmp - | MPself msid -> [rename_module (id_of_msid msid)] - | MPbound mbid -> [rename_module (id_of_mbid mbid)] - | _ -> assert false - in mp_rename mp ren; ren - let create_mono_renamings struc = - let { up = u ; down = d } = struct_get_references_list struc in + let { typ = ty ; trm = tr ; cons = co } = struct_get_references_list struc in let add upper r = let mp = modpath_of_r r in - let l = mp_create_mono_renamings mp in + let l = mp_create_renaming mp in let mycase = if upper then uppercase_id else lowercase_id in let id = if l = [""] then - next_ident_away (mycase (id_of_global r)) (Idset.elements !global_ids) + next_ident_away (mycase (id_of_global r)) (global_ids_list ()) else id_of_string (modular_rename upper (id_of_global r)) in - global_ids := Idset.add id !global_ids; - rename r ((string_of_id id)::l) + add_global_ids id; + add_renaming r ((string_of_id id)::l) in - List.iter (add true) (List.rev u); - List.iter (add false) (List.rev d) - -(*s Renaming issues at toplevel *) - -module TopParams = struct - let globals () = Idset.empty - let pp_global _ r = pr_id (id_of_global r) - let pp_module _ mp = str (string_of_mp mp) -end - -(*s Renaming issues for a monolithic or modular extraction. *) - -module StdParams = struct - - let globals () = !global_ids - - let unquote s = - if lang () <> Scheme then s - else - let s = String.copy s in - for i=0 to String.length s - 1 do if s.[i] = '\'' then s.[i] <- '~' done; - s - - let rec dottify = function - | [] -> assert false - | [s] -> unquote s - | s::[""] -> unquote s - | s::l -> (dottify l)^"."^(unquote s) - - let pp_global mpl r = - let ls = get_renamings r in - let s = List.hd ls in - let mp = modpath_of_r r in - let ls = - if mp = List.hd mpl then [s] (* simpliest situation *) - else match lang () with - | Scheme -> [s] (* no modular Scheme extraction... *) - | Toplevel -> [s] (* idem *) - | Haskell -> - if !modular then - ls (* for the moment we always qualify in modular Haskell *) - else [s] - | Ocaml -> - try (* has [mp] something in common with one of those in [mpl] ? *) - let pref = common_prefix_from_list mp mpl in - (*i TODO: possibilité de clash i*) - list_firstn ((mp_length mp)-(mp_length pref)+1) ls - with Not_found -> (* [mp] is othogonal with every element of [mp]. *) - let base = base_mp mp in - if !modular && - (at_toplevel mp) && - not (Refset.mem r !to_qualify) && - not (clash base [] s mpl) - then snd (list_sep_last ls) - else ls - in - add_module_contents mp s; (* update the visible environment *) - str (dottify ls) - - (* The next function is used only in Ocaml extraction...*) - let pp_module mpl mp = - let ls = - if !modular - then mp_create_modular_renamings mp - else mp_create_mono_renamings mp - in - let ls = - try (* has [mp] something in common with one of those in [mpl] ? *) - let pref = common_prefix_from_list mp mpl in - (*i TODO: clash possible i*) - list_firstn ((mp_length mp)-(mp_length pref)) ls - with Not_found -> (* [mp] is othogonal with every element of [mp]. *) - if !modular && (at_toplevel mp) - then snd (list_sep_last ls) - else ls - in str (dottify ls) - -end - -module ToplevelPp = Ocaml.Make(TopParams) -module OcamlPp = Ocaml.Make(StdParams) -module HaskellPp = Haskell.Make(StdParams) -module SchemePp = Scheme.Make(StdParams) - -let pp_decl mp d = match lang () with - | Ocaml -> OcamlPp.pp_decl mp d - | Haskell -> HaskellPp.pp_decl mp d - | Scheme -> SchemePp.pp_decl mp d - | Toplevel -> ToplevelPp.pp_decl mp d - -let pp_struct s = match lang () with - | Ocaml -> OcamlPp.pp_struct s - | Haskell -> HaskellPp.pp_struct s - | Scheme -> SchemePp.pp_struct s - | Toplevel -> ToplevelPp.pp_struct s - -let pp_signature s = match lang () with - | Ocaml -> OcamlPp.pp_signature s - | Haskell -> HaskellPp.pp_signature s - | _ -> assert false - -let set_keywords () = - (match lang () with - | Ocaml -> keywords := Ocaml.keywords - | Haskell -> keywords := Haskell.keywords - | Scheme -> keywords := Scheme.keywords - | Toplevel -> keywords := Idset.empty); - global_ids := !keywords; - to_qualify := Refset.empty + List.iter (add (lang () = Haskell)) (List.rev ty); + List.iter (add false) (List.rev tr); + List.iter (add true) (List.rev co); + [] + +let create_renamings struc = + if modular () then create_modular_renamings struc + else create_mono_renamings struc -let preamble prm = match lang () with - | Ocaml -> Ocaml.preamble prm - | Haskell -> Haskell.preamble prm - | Scheme -> Scheme.preamble prm - | Toplevel -> (fun _ _ _ -> mt ()) - -let preamble_sig prm = match lang () with - | Ocaml -> Ocaml.preamble_sig prm - | _ -> assert false - -(*S Extraction of one decl to stdout. *) - -let print_one_decl struc mp decl = - set_keywords (); - modular := false; - create_mono_renamings struc; - msgnl (pp_decl [mp] decl) - -(*S Extraction to a file. *) - -let info f = - Options.if_verbose msgnl - (str ("The file "^f^" has been created by extraction.")) - -let print_structure_to_file f prm struc = - Hashtbl.clear renamings; - mod_1st_level := Idmap.empty; - modcontents := Gset.empty; - modvisited := MPset.empty; - set_keywords (); - modular := prm.modular; - let used_modules = - if lang () = Toplevel then [] - else if prm.modular then create_modular_renamings struc - else (create_mono_renamings struc; []) - in - let print_dummys = - (struct_ast_search ((=) MLdummy) struc, - struct_type_search Mlutil.isDummy struc, - struct_type_search ((=) Tunknown) struc) - in - let print_magic = - if lang () <> Haskell then false - else struct_ast_search (function MLmagic _ -> true | _ -> false) struc - in - (* print the implementation *) - let cout = option_map (fun (f,_) -> open_out f) f in - let ft = match cout with - | None -> !Pp_control.std_ft - | Some cout -> Pp_control.with_output_to cout in - begin try - msg_with ft (preamble prm used_modules print_dummys print_magic); - msg_with ft (pp_struct struc); - option_iter close_out cout; - with e -> - option_iter close_out cout; raise e - end; - option_iter (fun (f,_) -> info f) f; - (* print the signature *) - match f with - | Some (_,f) when lang () = Ocaml -> - let cout = open_out f in - let ft = Pp_control.with_output_to cout in - begin try - msg_with ft (preamble_sig prm used_modules print_dummys); - msg_with ft (pp_signature (signature_of_structure struc)); - close_out cout; - with e -> - close_out cout; raise e - end; - info f - | _ -> () - - -(*i - (* DO NOT REMOVE: used when making names resolution *) - let cout = open_out (f^".ren") in - let ft = Pp_control.with_output_to cout in - Hashtbl.iter - (fun r id -> - if short_module r = !current_module then - msgnl_with ft (pr_id id ++ str " " ++ pr_sp (sp_of_r r))) - renamings; - pp_flush_with ft (); - close_out cout; -i*) - - - - - - + +(*s On-the-fly qualification issues for both monolithic or modular extraction. *) + +let pp_global k r = + let ls = get_renaming r in + assert (List.length ls > 1); + let s = List.hd ls in + let mp = modpath_of_r r in + if mp = top_visible_mp () then + (* simpliest situation: definition of r (or use in the same context) *) + (* we update the visible environment *) + (add_loc_mpmem k mp s; unquote s) + else match lang () with + | Scheme -> unquote s (* no modular Scheme extraction... *) + | Haskell -> + (* for the moment we always qualify in modular Haskell *) + if modular () then dottify ls else s + | Ocaml -> + try (* has [mp] something in common with one of [!visible] ? *) + let prefix = common_prefix_from_list mp !visible in + let delta = mp_length mp - mp_length prefix in + let ls = list_firstn (delta+1) ls in + (* Difficulty: in ocaml we cannot qualify more than [ls], + but this (not-so-long) name can in fact be hidden. Solution: + duplication of the _definition_ of r in a Coq__XXX module *) + let s,ls' = list_sep_last ls in + let k' = if ls' = [] then k else Mod in + if clash (loc_mpmem k') prefix s !visible then + let front = if ls' = [] then [s] else ls' in + let l = get_nth_label delta r in + try dottify (front @ [check_duplicate prefix l]) + with Not_found -> add_duplicate prefix l; dottify ls + else dottify ls + with Not_found -> + (* [mp] belongs to a closed module, not one of [!visible]. *) + let base = base_mp mp in + let base_s,ls1 = list_sep_last ls in + let s,ls2 = list_sep_last ls1 in + let k' = if ls2 = [] then k else Mod in + if modular () && (mem_mpfiles base) && + not (static_clash r) && + (* k' = Mod can't clash in an opened module, see earlier check *) + not (clash (loc_mpmem k') base s !visible) + then (* Standard situation of an object in another file: *) + (* Thanks to the "open" of this file we remove its name *) + dottify ls1 + else if clash (loc_mpmem Mod) base base_s !visible then + error_module_clash base_s + else dottify ls + +(* The next function is used only in Ocaml extraction...*) +let pp_module mp = + let ls = mp_create_renaming mp in + if List.length ls = 1 then dottify ls + else match mp with + | MPdot (mp0,_) when mp0 = top_visible_mp () -> + (* simpliest situation: definition of mp (or use in the same context) *) + (* we update the visible environment *) + let s = List.hd ls in + add_loc_mpmem Mod mp0 s; s + | _ -> + try (* has [mp] something in common with one of those in [!visible] ? *) + let prefix = common_prefix_from_list mp !visible in + assert (mp <> prefix); (* no use of mp as whole module from itself *) + let delta = mp_length mp - mp_length prefix in + let ls = list_firstn delta ls in + (* Difficulty: in ocaml we cannot qualify more than [ls], + but this (not-so-long) name can in fact be hidden. Solution: + duplication of the _definition_ of mp via a Coq__XXX module *) + let s,ls' = list_sep_last ls in + if clash (loc_mpmem Mod) prefix s !visible then + let l = get_nth_label_mp delta mp in + try dottify (ls' @ [check_duplicate prefix l]) + with Not_found -> add_duplicate prefix l; dottify ls + else dottify ls + with Not_found -> + (* [mp] belongs to a closed module, not one of [!visible]. *) + let base = base_mp mp in + let base_s,ls' = list_sep_last ls in + let s = fst (list_sep_last ls) in + if modular () && (mem_mpfiles base) && + not (clash (loc_mpmem Mod) base s !visible) + then dottify ls' + else if clash (loc_mpmem Mod) base base_s !visible then + error_module_clash base_s + else dottify ls diff --git a/contrib/extraction/common.mli b/contrib/extraction/common.mli index 2ba51e1c..5cd26584 100644 --- a/contrib/extraction/common.mli +++ b/contrib/extraction/common.mli @@ -6,16 +6,56 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: common.mli 5920 2004-07-16 20:01:26Z herbelin $ i*) +(*i $Id: common.mli 10232 2007-10-17 12:32:10Z letouzey $ i*) open Names +open Libnames open Miniml open Mlutil +open Pp -val print_one_decl : - ml_structure -> module_path -> ml_decl -> unit +val fnl2 : unit -> std_ppcmds +val space_if : bool -> std_ppcmds +val sec_space_if : bool -> std_ppcmds -val print_structure_to_file : - (string * string) option -> extraction_params -> ml_structure -> unit +val pp_par : bool -> std_ppcmds -> std_ppcmds +val pp_apply : std_ppcmds -> bool -> std_ppcmds list -> std_ppcmds +val pr_binding : identifier list -> std_ppcmds +val rename_id : identifier -> Idset.t -> identifier +val lowercase_id : identifier -> identifier +val uppercase_id : identifier -> identifier + +val pr_upper_id : identifier -> std_ppcmds + +type env = identifier list * Idset.t +val empty_env : unit -> env + +val rename_vars: Idset.t -> identifier list -> env +val rename_tvars: Idset.t -> identifier list -> identifier list +val push_vars : identifier list -> env -> identifier list * env +val get_db_name : int -> env -> identifier + +val record_contents_fstlev : ml_structure -> unit + +val create_renamings : ml_structure -> module_path list + +type kind = Term | Type | Cons | Mod + +val pp_global : kind -> global_reference -> string +val pp_module : module_path -> string + +val top_visible_mp : unit -> module_path +val push_visible : module_path -> unit +val pop_visible : unit -> unit + +val add_subst : mod_self_id -> module_path -> unit + +val check_duplicate : module_path -> label -> string + +type reset_kind = OnlyLocal | AllButExternal | Everything + +val reset_renaming_tables : reset_kind -> unit + +val set_keywords : Idset.t -> unit diff --git a/contrib/extraction/extract_env.ml b/contrib/extraction/extract_env.ml index 825b3554..311b42c0 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 10209 2007-10-09 21:49:37Z letouzey $ i*) +(*i $Id: extract_env.ml 10794 2008-04-15 00:12:06Z letouzey $ i*) open Term open Declarations @@ -21,7 +21,9 @@ open Modutil open Common open Mod_subst -(*s Obtaining Coq environment. *) +(***************************************) +(*S Part I: computing Coq environment. *) +(***************************************) let toplevel_env () = let seg = Lib.contents_after None in @@ -29,16 +31,17 @@ let toplevel_env () = | (_,kn), Lib.Leaf o -> let mp,_,l = repr_kn kn in let seb = match Libobject.object_tag o with - | "CONSTANT" -> SEBconst (Global.lookup_constant (constant_of_kn kn)) - | "INDUCTIVE" -> SEBmind (Global.lookup_mind kn) - | "MODULE" -> SEBmodule (Global.lookup_module (MPdot (mp,l))) - | "MODULE TYPE" -> SEBmodtype (Global.lookup_modtype kn) + | "CONSTANT" -> SFBconst (Global.lookup_constant (constant_of_kn kn)) + | "INDUCTIVE" -> SFBmind (Global.lookup_mind kn) + | "MODULE" -> SFBmodule (Global.lookup_module (MPdot (mp,l))) + | "MODULE TYPE" -> + SFBmodtype (Global.lookup_modtype (MPdot (mp,l))) | _ -> failwith "caught" in l,seb | _ -> failwith "caught" in match current_toplevel () with - | MPself msid -> MEBstruct (msid, List.rev (map_succeed get_reference seg)) + | MPself msid -> SEBstruct (msid, List.rev (map_succeed get_reference seg)) | _ -> assert false let environment_until dir_opt = @@ -130,58 +133,87 @@ let factor_fix env l cb msb = list_iter_i (fun j -> function - | (l,SEBconst cb') -> + | (l,SFBconst cb') -> if check <> check_fix env cb' (j+1) then raise Impossible; labels.(j+1) <- l; | _ -> raise Impossible) msb'; labels, recd, msb'' end -let rec extract_msig env mp = function +(* From a [structure_body] (i.e. a list of [structure_field_body]) + to specifications. *) + +let rec extract_sfb_spec env mp = function | [] -> [] - | (l,SPBconst cb) :: msig -> + | (l,SFBconst 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 mp msig - else begin - Visit.add_spec_deps s; - (l,Spec s) :: (extract_msig env mp msig) - end - | (l,SPBmind cb) :: msig -> + let specs = extract_sfb_spec env mp msig in + if logical_spec s then specs + else begin Visit.add_spec_deps s; (l,Spec s) :: specs end + | (l,SFBmind 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 mp msig - else begin - Visit.add_spec_deps s; - (l,Spec s) :: (extract_msig env mp msig) - end - | (l,SPBmodule {msb_modtype=mtb}) :: msig -> - (l,Smodule (extract_mtb env None mtb)) :: (extract_msig env mp msig) - | (l,SPBmodtype mtb) :: msig -> - (l,Smodtype (extract_mtb env None mtb)) :: (extract_msig env mp msig) - -and extract_mtb env mpo = function - | MTBident kn -> Visit.add_kn kn; MTident kn - | MTBfunsig (mbid, mtb, mtb') -> + let specs = extract_sfb_spec env mp msig in + if logical_spec s then specs + else begin Visit.add_spec_deps s; (l,Spec s) :: specs end + | (l,SFBmodule mb) :: msig -> + let specs = extract_sfb_spec env mp msig in + let mtb = Modops.type_of_mb env mb in + let spec = extract_seb_spec env (mb.mod_type<>None) mtb in + (l,Smodule spec) :: specs + | (l,SFBmodtype mtb) :: msig -> + let specs = extract_sfb_spec env mp msig in + (l,Smodtype (extract_seb_spec env true(*?*) mtb.typ_expr)) :: specs + | (l,SFBalias(mp1,_))::msig -> + extract_sfb_spec env mp + ((l,SFBmodule {mod_expr = Some (SEBident mp1); + mod_type = None; + mod_constraints = Univ.Constraint.empty; + mod_alias = Mod_subst.empty_subst; + mod_retroknowledge = []})::msig) + +(* From [struct_expr_body] to specifications *) + + +and extract_seb_spec env truetype = function + | SEBident kn when truetype -> Visit.add_mp kn; MTident kn + | SEBwith(mtb',With_definition_body(idl,cb))-> + let mtb''= extract_seb_spec env truetype mtb' in + (match extract_with_type env cb with (* cb peut contenir des kn *) + | None -> mtb'' + | Some (vl,typ) -> MTwith(mtb'',ML_With_type(idl,vl,typ))) + | SEBwith(mtb',With_module_body(idl,mp,_))-> + Visit.add_mp mp; + MTwith(extract_seb_spec env truetype mtb', + ML_With_module(idl,mp)) + | SEBfunctor (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 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_module mp (Modops.module_body_of_type mtb) env in + MTfunsig (mbid, extract_seb_spec env true mtb.typ_expr, + extract_seb_spec env' truetype mtb') + | SEBstruct (msid, msig) -> + let mp = MPself msid in let env' = Modops.add_signature mp msig env in - MTsig (msid, extract_msig env' mp msig) + MTsig (msid, extract_sfb_spec env' mp msig) + | (SEBapply _|SEBident _ (*when not truetype*)) as mtb -> + extract_seb_spec env truetype (Modops.eval_struct env mtb) + + +(* From a [structure_body] (i.e. a list of [structure_field_body]) + to implementations. -let rec extract_msb env mp all = function + NB: when [all=false], the evaluation order of the list is + important: last to first ensures correct dependencies. +*) + +let rec extract_sfb env mp all = function | [] -> [] - | (l,SEBconst cb) :: msb -> + | (l,SFBconst cb) :: msb -> (try let vl,recd,msb = factor_fix env l cb msb in let vc = Array.map (make_con mp empty_dirpath) vl in - let ms = extract_msb env mp all msb in + let ms = extract_sfb env mp all msb in let b = array_exists Visit.needed_con vc in if all || b then let d = extract_fixpoint env vc recd in @@ -189,7 +221,7 @@ let rec extract_msb env mp all = function else begin Visit.add_decl_deps d; (l,SEdecl d) :: ms end else ms with Impossible -> - let ms = extract_msb env mp all msb in + let ms = extract_sfb 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 @@ -197,8 +229,8 @@ let rec extract_msb env mp all = function if (not b) && (logical_decl d) then ms else begin Visit.add_decl_deps d; (l,SEdecl d) :: ms end else ms) - | (l,SEBmind mib) :: msb -> - let ms = extract_msb env mp all msb in + | (l,SFBmind mib) :: msb -> + let ms = extract_sfb env mp all msb in let kn = make_kn mp empty_dirpath l in let b = Visit.needed_kn kn in if all || b then @@ -206,48 +238,68 @@ let rec extract_msb env mp all = function if (not b) && (logical_decl d) then ms else begin Visit.add_decl_deps d; (l,SEdecl d) :: ms end else ms - | (l,SEBmodule mb) :: msb -> - let ms = extract_msb env mp all msb in + | (l,SFBmodule mb) :: msb -> + let ms = extract_sfb env mp all msb in let mp = MPdot (mp,l) in 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 mp all msb in - let kn = make_kn mp empty_dirpath l in - if all || Visit.needed_kn kn then - (l,SEmodtype (extract_mtb env None mtb)) :: ms + | (l,SFBmodtype mtb) :: msb -> + let ms = extract_sfb env mp all msb in + let mp = MPdot (mp,l) in + if all || Visit.needed_mp mp then + (l,SEmodtype (extract_seb_spec env true(*?*) mtb.typ_expr)) :: ms + else ms + | (l,SFBalias (mp1,cst)) :: msb -> + let ms = extract_sfb env mp all msb in + let mp = MPdot (mp,l) in + if all || Visit.needed_mp mp then + (l,SEmodule (extract_module env mp true + {mod_expr = Some (SEBident mp1); + mod_type = None; + mod_constraints= Univ.Constraint.empty; + mod_alias = empty_subst; + mod_retroknowledge = []})) :: ms else ms -and extract_meb env mpo all = function - | MEBident (MPfile d) -> error_MPfile_as_mod d (* temporary (I hope) *) - | MEBident mp -> Visit.add_mp mp; MEident mp - | MEBapply (meb, meb',_) -> - MEapply (extract_meb env None true meb, - extract_meb env None true meb') - | MEBfunctor (mbid, mtb, meb) -> +(* From [struct_expr_body] to implementations *) + +and extract_seb env mpo all = function + | SEBident mp -> + if is_modfile mp && not (modular ()) then error_MPfile_as_mod mp false; + Visit.add_mp mp; MEident mp + | SEBapply (meb, meb',_) -> + MEapply (extract_seb env None true meb, + extract_seb env None true meb') + | SEBfunctor (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 None mtb, - extract_meb env' None true meb) - | MEBstruct (msid, msb) -> + MEfunctor (mbid, extract_seb_spec env true mtb.typ_expr, + extract_seb env' None true meb) + | SEBstruct (msid, msb) -> let mp,msb = match mpo with | None -> MPself msid, msb - | Some mp -> mp, subst_msb (map_msid msid mp) msb + | Some mp -> mp, Modops.subst_structure (map_msid msid mp) msb in - let env' = add_structure mp msb env in - MEstruct (msid, extract_msb env' mp all msb) + let env' = Modops.add_signature mp msb env in + MEstruct (msid, extract_sfb env' mp all msb) + | SEBwith (_,_) -> anomaly "Not available yet" 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 - let mtb = match mb.mod_user_type with None -> mb.mod_type | Some mt -> mt in + let meb = Option.get mb.mod_expr in + let mtb = match mb.mod_type with + | None -> Modops.eval_struct env meb + | Some mt -> mt + in (* 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 (Some mp) all meb; - ml_mod_type = extract_mtb env None mtb } + (* PL 26/02/2008: is this still relevant ? + let mtb = replicate_msid meb mtb in *) + { ml_mod_expr = extract_seb env (Some mp) all meb; + ml_mod_type = extract_seb_spec env (mb.mod_type<>None) mtb } + let unpack = function MEstruct (_,sel) -> sel | _ -> assert false @@ -258,161 +310,198 @@ let mono_environment refs mpl = let env = Global.env () in let l = List.rev (environment_until None) in List.rev_map - (fun (mp,m) -> mp, unpack (extract_meb env (Some mp) false m)) l + (fun (mp,m) -> mp, unpack (extract_seb env (Some mp) false m)) l + +(**************************************) +(*S Part II : Input/Output primitives *) +(**************************************) + +let descr () = match lang () with + | Ocaml -> Ocaml.ocaml_descr + | Haskell -> Haskell.haskell_descr + | Scheme -> Scheme.scheme_descr + +(* From a filename string "foo.ml" or "foo", builds "foo.ml" and "foo.mli" + Works similarly for the other languages. *) + +let default_id = id_of_string "Main" + +let mono_filename f = + let d = descr () in + match f with + | None -> None, None, default_id + | Some f -> + let f = + if Filename.check_suffix f d.file_suffix then + Filename.chop_suffix f d.file_suffix + else f + in + let id = + if lang () <> Haskell then default_id + else try id_of_string (Filename.basename f) + with _ -> error "Extraction: provided filename is not a valid identifier" + in + Some (f^d.file_suffix), Option.map ((^) f) d.sig_suffix, id + +(* Builds a suitable filename from a module id *) + +let module_filename m = + let d = descr () in + let f = if d.capital_file then String.capitalize else String.uncapitalize in + let fn = f (string_of_id m) in + Some (fn^d.file_suffix), Option.map ((^) fn) d.sig_suffix, m + +(*s Extraction of one decl to stdout. *) + +let print_one_decl struc mp decl = + let d = descr () in + reset_renaming_tables AllButExternal; + ignore (create_renamings struc); + push_visible mp; + msgnl (d.pp_decl decl); + pop_visible () + +(*s Extraction of a ml struct to a file. *) + +let print_structure_to_file (fn,si,mo) struc = + let d = descr () in + reset_renaming_tables AllButExternal; + let used_modules = create_renamings struc in + let unsafe_needs = { + mldummy = struct_ast_search ((=) MLdummy) struc; + tdummy = struct_type_search Mlutil.isDummy struc; + tunknown = struct_type_search ((=) Tunknown) struc; + magic = + if lang () <> Haskell then false + else struct_ast_search (function MLmagic _ -> true | _ -> false) struc } + in + (* print the implementation *) + let cout = Option.map open_out fn in + let ft = match cout with + | None -> !Pp_control.std_ft + | Some cout -> Pp_control.with_output_to cout in + begin try + msg_with ft (d.preamble mo used_modules unsafe_needs); + if lang () = Ocaml then begin + (* for computing objects to duplicate *) + let devnull = Format.make_formatter (fun _ _ _ -> ()) (fun _ -> ()) in + msg_with devnull (d.pp_struct struc); + reset_renaming_tables OnlyLocal; + end; + msg_with ft (d.pp_struct struc); + Option.iter close_out cout; + with e -> + Option.iter close_out cout; raise e + end; + Option.iter info_file fn; + (* print the signature *) + Option.iter + (fun si -> + let cout = open_out si in + let ft = Pp_control.with_output_to cout in + begin try + msg_with ft (d.sig_preamble mo used_modules unsafe_needs); + reset_renaming_tables OnlyLocal; + msg_with ft (d.pp_sig (signature_of_structure struc)); + close_out cout; + with e -> + close_out cout; raise e + end; + info_file si) + si + + +(*********************************************) +(*s Part III: the actual extraction commands *) +(*********************************************) + + +let reset () = + Visit.reset (); reset_tables (); reset_renaming_tables Everything + +let init modular = + check_inside_section (); check_inside_module (); + set_keywords (descr ()).keywords; + set_modular modular; + reset (); + if modular && lang () = Scheme then error_scheme () + - (*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. *) + \verb!Recursive Extraction! [qualid1] ... [qualidn]. Also used when + extracting to a file with the command: + \verb!Extraction "file"! [qualid1] ... [qualidn]. *) -let mono_extraction (f,m) qualids = - check_inside_section (); - check_inside_module (); +let full_extraction f qualids = + init false; let rec find = function | [] -> [],[] | q::l -> let refs,mps = find l in try - let mp = Nametab.locate_module (snd (qualid_of_reference q)) - in refs,(mp::mps) + let mp = Nametab.locate_module (snd (qualid_of_reference q)) in + if is_modfile mp then error_MPfile_as_mod mp true; + refs,(mp::mps) with Not_found -> (Nametab.global q)::refs, mps - in + in let refs,mps = find qualids in - 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 struc = optimize_struct refs (mono_environment refs mps) in + warning_axioms (); + print_structure_to_file (mono_filename f) struc; + reset () -let extraction_rec = mono_extraction (None,id_of_string "Main") -(*s Extraction in the Coq toplevel. We display the extracted term in - Ocaml syntax and we use the Coq printers for globals. The - vernacular command is \verb!Extraction! [qualid]. *) +(*s Simple extraction in the Coq toplevel. The vernacular command + is \verb!Extraction! [qualid]. *) -let extraction qid = - check_inside_section (); - check_inside_module (); +let simple_extraction qid = + init false; try - let _ = Nametab.locate_module (snd (qualid_of_reference qid)) in - extraction_rec [qid] + let mp = Nametab.locate_module (snd (qualid_of_reference qid)) in + if is_modfile mp then error_MPfile_as_mod mp true; + full_extraction None [qid] with Not_found -> let r = Nametab.global qid in if is_custom r then msgnl (str "User defined extraction:" ++ spc () ++ str (find_custom r) ++ fnl ()) else - let prm = - { modular = false; mod_name = id_of_string "Main"; to_appear = [r]} in - let struc = optimize_struct prm None (mono_environment [r] []) in + let struc = optimize_struct [r] (mono_environment [r] []) in let d = get_decl_in_structure r struc in + warning_axioms (); print_one_decl struc (modpath_of_r r) d; - Visit.reset (); - reset_tables () - -(*s Extraction to a file (necessarily recursive). - The vernacular command is - \verb!Extraction "file"! [qualid1] ... [qualidn].*) - -let lang_suffix () = match lang () with - | Ocaml -> ".ml",".mli" - | Haskell -> ".hs",".hi" - | Scheme -> ".scm",".scm" - | Toplevel -> assert false - -let filename f = - let s,s' = lang_suffix () in - if Filename.check_suffix f s then - let f' = Filename.chop_suffix f s in - Some (f,f'^s'),id_of_string f' - else Some (f^s,f^s'),id_of_string f - -let extraction_file f vl = - if lang () = Toplevel then error_toplevel () - else mono_extraction (filename f) vl - -(*s Extraction of a module at the toplevel. *) - -let extraction_module m = - check_inside_section (); - check_inside_module (); - begin match lang () with - | Toplevel -> error_toplevel () - | Scheme -> error_scheme () - | _ -> () - 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 () + reset () (*s (Recursive) Extraction of a library. The vernacular command is \verb!(Recursive) Extraction Library! [M]. *) -let module_file_name m = match lang () with - | Ocaml -> let f = String.uncapitalize (string_of_id m) in f^".ml", f^".mli" - | Haskell -> let f = String.capitalize (string_of_id m) in f^".hs", f^".hi" - | _ -> assert false - -let dir_module_of_id m = - let q = make_short_qualid m in - try Nametab.full_name_module q with Not_found -> error_unknown_module q - let extraction_library is_rec m = - check_inside_section (); - check_inside_module (); - begin match lang () with - | Toplevel -> error_toplevel () - | Scheme -> error_scheme () - | _ -> () - end; - let dir_m = dir_module_of_id m in - Visit.reset (); + init true; + let dir_m = + let q = make_short_qualid m in + try Nametab.full_name_module q with Not_found -> error_unknown_module q + in 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 + then (mp, unpack (extract_seb 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 struc = optimize_struct [] struc in + warning_axioms (); + record_contents_fstlev struc; 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_structure_to_file (module_filename short_m) [e]; print l | _ -> assert false in print struc; - Visit.reset (); - reset_tables () - - - - - + reset () diff --git a/contrib/extraction/extract_env.mli b/contrib/extraction/extract_env.mli index a09464a1..8d906985 100644 --- a/contrib/extraction/extract_env.mli +++ b/contrib/extraction/extract_env.mli @@ -6,15 +6,18 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: extract_env.mli 5920 2004-07-16 20:01:26Z herbelin $ i*) +(*i $Id: extract_env.mli 10895 2008-05-07 16:06:26Z letouzey $ i*) (*s This module declares the extraction commands. *) open Names open Libnames -val extraction : reference -> unit -val extraction_rec : reference list -> unit -val extraction_file : string -> reference list -> unit -val extraction_module : reference -> unit +val simple_extraction : reference -> unit +val full_extraction : string option -> reference list -> unit val extraction_library : bool -> identifier -> unit + +(* For debug / external output via coqtop.byte + Drop : *) + +val mono_environment : + global_reference list -> module_path list -> Miniml.ml_structure diff --git a/contrib/extraction/extraction.ml b/contrib/extraction/extraction.ml index 6982ffc6..fdc84a64 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 10195 2007-10-08 01:47:55Z letouzey $ i*) +(*i $Id: extraction.ml 10497 2008-02-01 12:18:37Z soubiran $ i*) (*i*) open Util @@ -310,7 +310,7 @@ and extract_ind env kn = (* kn is supposed to be in long form *) with Not_found -> (* 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; + 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 @@ -337,7 +337,10 @@ and extract_ind env kn = (* kn is supposed to be in long form *) {ind_info = Standard; ind_nparams = npar; ind_packets = packets; - ind_equiv = mib.mind_equiv }; + ind_equiv = match mib.mind_equiv with + | None -> NoEquiv + | Some kn -> Equiv kn + }; (* Second pass: we extract constructors *) for i = 0 to mib.mind_ntypes - 1 do let p = packets.(i) in @@ -410,7 +413,7 @@ and extract_ind env kn = (* kn is supposed to be in long form *) (Inductive.type_of_inductive env (mib,mip0)) in List.iter - (option_iter + (Option.iter (fun kn -> if Cset.mem kn !projs then add_projection n kn)) (lookup_projections ip) with Not_found -> () @@ -421,7 +424,9 @@ and extract_ind env kn = (* kn is supposed to be in long form *) let i = {ind_info = ind_info; ind_nparams = npar; ind_packets = packets; - ind_equiv = mib.mind_equiv} + ind_equiv = match mib.mind_equiv with + | None -> NoEquiv + | Some kn -> Equiv kn } in add_ind kn mib i; i @@ -750,7 +755,7 @@ and extract_case env mle ((kn,i) as ip,c,br) mlt = end else (* Standard case: we apply [extract_branch]. *) - MLcase (mi.ind_info, a, Array.init br_size extract_branch) + MLcase ((mi.ind_info,[]), a, Array.init br_size extract_branch) (*s Extraction of a (co)-fixpoint. *) @@ -828,18 +833,18 @@ let extract_constant env kn cb = | None -> (* A logical axiom is risky, an informative one is fatal. *) (match flag_of_type env typ with | (Info,TypeScheme) -> - if not (is_custom r) then warning_info_ax r; + if not (is_custom r) then add_info_axiom r; let n = type_scheme_nb_args env typ in let ids = iterate (fun l -> anonymous::l) n [] in Dtype (r, ids, Taxiom) | (Info,Default) -> - if not (is_custom r) then warning_info_ax r; + if not (is_custom r) then add_info_axiom r; let t = snd (record_constant_type env kn (Some typ)) in Dterm (r, MLaxiom, type_expunge env t) | (Logic,TypeScheme) -> - warning_log_ax r; Dtype (r, [], Tdummy Ktype) + add_log_axiom r; Dtype (r, [], Tdummy Ktype) | (Logic,Default) -> - warning_log_ax r; Dterm (r, MLdummy, Tdummy Kother)) + add_log_axiom r; Dterm (r, MLdummy, Tdummy Kother)) | Some body -> (match flag_of_type env typ with | (Logic, Default) -> Dterm (r, MLdummy, Tdummy Kother) @@ -871,6 +876,20 @@ let extract_constant_spec env kn cb = let t = snd (record_constant_type env kn (Some typ)) in Sval (r, type_expunge env t) +let extract_with_type env cb = + let typ = Typeops.type_of_constant_type env cb.const_type in + match flag_of_type env typ with + | (_ , Default) -> None + | (Logic, TypeScheme) ->Some ([],Tdummy Ktype) + | (Info, TypeScheme) -> + let s,vl = type_sign_vl env typ in + (match cb.const_body with + | None -> assert false + | Some body -> + let db = db_from_sign s in + let t = extract_type_scheme env db (force body) (List.length s) + in Some ( vl, t) ) + let extract_inductive env kn = let ind = extract_ind env kn in add_recursors env kn; @@ -880,24 +899,6 @@ let extract_inductive env kn = ind.ind_packets in { ind with ind_packets = packets } -(*s From a global reference to a ML declaration. *) - -let extract_declaration env r = match r with - | ConstRef kn -> extract_constant env kn (Environ.lookup_constant kn env) - | IndRef (kn,_) -> Dind (kn, extract_inductive env kn) - | ConstructRef ((kn,_),_) -> Dind (kn, extract_inductive env kn) - | VarRef kn -> assert false - -(*s Without doing complete extraction, just guess what a constant would be. *) - -type kind = Logical | Term | Type - -let constant_kind env cb = - match flag_of_type env (Typeops.type_of_constant_type env cb.const_type) with - | (Logic,_) -> Logical - | (Info,TypeScheme) -> Type - | (Info,Default) -> Term - (*s Is a [ml_decl] logical ? *) let logical_decl = function @@ -916,9 +917,3 @@ let logical_spec = function | Sval (_,Tdummy _) -> true | Sind (_,i) -> array_for_all (fun ip -> ip.ip_logical) i.ind_packets | _ -> false - - - - - - diff --git a/contrib/extraction/extraction.mli b/contrib/extraction/extraction.mli index 1dfd7e1a..6d41b630 100644 --- a/contrib/extraction/extraction.mli +++ b/contrib/extraction/extraction.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: extraction.mli 6303 2004-11-16 12:37:40Z sacerdot $ i*) +(*i $Id: extraction.mli 10497 2008-02-01 12:18:37Z soubiran $ i*) (*s Extraction from Coq terms to Miniml. *) @@ -21,21 +21,13 @@ val extract_constant : env -> constant -> constant_body -> ml_decl val extract_constant_spec : env -> constant -> constant_body -> ml_spec +val extract_with_type : env -> constant_body -> ( identifier list * ml_type ) option + val extract_fixpoint : env -> constant array -> (constr, types) prec_declaration -> ml_decl val extract_inductive : env -> kernel_name -> ml_ind -(*s ML declaration corresponding to a Coq reference. *) - -val extract_declaration : env -> global_reference -> ml_decl - -(*s Without doing complete extraction, just guess what a constant would be. *) - -type kind = Logical | Term | Type - -val constant_kind : env -> constant_body -> kind - (*s Is a [ml_decl] or a [ml_spec] logical ? *) val logical_decl : ml_decl -> bool diff --git a/contrib/extraction/g_extraction.ml4 b/contrib/extraction/g_extraction.ml4 index 13b29c7b..cb95808d 100644 --- a/contrib/extraction/g_extraction.ml4 +++ b/contrib/extraction/g_extraction.ml4 @@ -31,19 +31,18 @@ VERNAC ARGUMENT EXTEND language | [ "Ocaml" ] -> [ Ocaml ] | [ "Haskell" ] -> [ Haskell ] | [ "Scheme" ] -> [ Scheme ] -| [ "Toplevel" ] -> [ Toplevel ] END (* Extraction commands *) VERNAC COMMAND EXTEND Extraction (* Extraction in the Coq toplevel *) -| [ "Extraction" global(x) ] -> [ extraction x ] -| [ "Recursive" "Extraction" ne_global_list(l) ] -> [ extraction_rec l ] +| [ "Extraction" global(x) ] -> [ simple_extraction x ] +| [ "Recursive" "Extraction" ne_global_list(l) ] -> [ full_extraction None l ] (* Monolithic extraction to a file *) | [ "Extraction" string(f) ne_global_list(l) ] - -> [ extraction_file f l ] + -> [ full_extraction (Some f) l ] END (* Modular extraction (one Coq library = one ML module) *) diff --git a/contrib/extraction/haskell.ml b/contrib/extraction/haskell.ml index f924396c..0ef225c0 100644 --- a/contrib/extraction/haskell.ml +++ b/contrib/extraction/haskell.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: haskell.ml 8930 2006-06-09 02:14:34Z letouzey $ i*) +(*i $Id: haskell.ml 10233 2007-10-17 23:29:08Z letouzey $ i*) (*s Production of Haskell syntax. *) @@ -18,7 +18,7 @@ open Libnames open Table open Miniml open Mlutil -open Ocaml +open Common (*s Haskell renaming issues. *) @@ -30,22 +30,19 @@ let keywords = "as"; "qualified"; "hiding" ; "unit" ; "unsafeCoerce" ] Idset.empty -let preamble prm used_modules (mldummy,tdummy,tunknown) magic = - let pp_mp = function - | MPfile d -> pr_upper_id (List.hd (repr_dirpath d)) - | _ -> assert false - in - (if not magic then mt () +let preamble mod_name used_modules usf = + let pp_import mp = str ("import qualified "^ string_of_modfile mp ^"\n") + in + (if not usf.magic then mt () else str "{-# OPTIONS_GHC -cpp -fglasgow-exts #-}\n" ++ str "{- For Hugs, use the option -F\"cpp -P -traditional\" -}\n\n") ++ - str "module " ++ pr_upper_id prm.mod_name ++ str " where" ++ fnl () - ++ fnl() ++ - str "import qualified Prelude" ++ fnl() ++ - prlist (fun mp -> str "import qualified " ++ pp_mp mp ++ fnl ()) used_modules - ++ fnl () ++ - (if not magic then mt () + str "module " ++ pr_upper_id mod_name ++ str " where" ++ fnl2 () ++ + str "import qualified Prelude" ++ fnl () ++ + prlist pp_import used_modules ++ fnl () ++ + (if used_modules = [] then mt () else fnl ()) ++ + (if not usf.magic then mt () else str "\ #ifdef __GLASGOW_HASKELL__ import qualified GHC.Base @@ -54,16 +51,10 @@ unsafeCoerce = GHC.Base.unsafeCoerce# -- HUGS import qualified IOExts unsafeCoerce = IOExts.unsafeCoerce -#endif") - ++ - fnl() ++ fnl() +#endif" ++ fnl2 ()) ++ - (if not mldummy then mt () - else - str "__ = Prelude.error \"Logical or arity value used\"" - ++ fnl () ++ fnl()) - -let preamble_sig prm used_modules (mldummy,tdummy,tunknown) = failwith "TODO" + (if not usf.mldummy then mt () + else str "__ = Prelude.error \"Logical or arity value used\"" ++ fnl2 ()) let pp_abst = function | [] -> (mt ()) @@ -73,17 +64,11 @@ let pp_abst = function let pr_lower_id id = pr_id (lowercase_id id) -(*s The pretty-printing functor. *) +(*s The pretty-printer for haskell syntax *) -module Make = functor(P : Mlpp_param) -> struct - -let local_mpl = ref ([] : module_path list) - -let pp_global r = +let pp_global k r = if is_inline_custom r then str (find_custom r) - else P.pp_global !local_mpl r - -let empty_env () = [], P.globals() + else str (Common.pp_global k r) (*s Pretty-printing of types. [par] is a boolean indicating whether parentheses are needed or not. *) @@ -96,13 +81,14 @@ let rec pp_type par vl t = let rec pp_rec par = function | Tmeta _ | Tvar' _ -> assert false | Tvar i -> (try pr_id (List.nth vl (pred i)) with _ -> (str "a" ++ int i)) - | Tglob (r,[]) -> pp_global r + | Tglob (r,[]) -> pp_global Type r | Tglob (r,l) -> if r = IndRef (kn_sig,0) then pp_type true vl (List.hd l) else pp_par par - (pp_global r ++ spc () ++ prlist_with_sep spc (pp_type true vl) l) + (pp_global Type r ++ spc () ++ + prlist_with_sep spc (pp_type true vl) l) | Tarr (t1,t2) -> pp_par par (pp_rec true t1 ++ spc () ++ str "->" ++ spc () ++ pp_rec false t2) @@ -151,20 +137,20 @@ let rec pp_expr par env args = spc () ++ str "in") ++ spc () ++ hov 0 pp_a2))) | MLglob r -> - apply (pp_global r) + apply (pp_global Term r) | MLcons (_,r,[]) -> - assert (args=[]); pp_global r + assert (args=[]); pp_global Cons r | MLcons (_,r,[a]) -> assert (args=[]); - pp_par par (pp_global r ++ spc () ++ pp_expr true env [] a) + pp_par par (pp_global Cons r ++ spc () ++ pp_expr true env [] a) | MLcons (_,r,args') -> assert (args=[]); - pp_par par (pp_global r ++ spc () ++ + pp_par par (pp_global Cons r ++ spc () ++ prlist_with_sep spc (pp_expr true env []) args') - | MLcase (_,t, pv) -> + | MLcase ((_,factors),t, pv) -> apply (pp_par par' (v 0 (str "case " ++ pp_expr false env [] t ++ str " of" ++ - fnl () ++ str " " ++ pp_pat env pv))) + fnl () ++ str " " ++ pp_pat env factors pv))) | MLfix (i,ids,defs) -> let ids',env' = push_vars (List.rev (Array.to_list ids)) env in pp_fix par env' i (Array.of_list (List.rev ids'),defs) args @@ -177,11 +163,11 @@ let rec pp_expr par env args = pp_apply (str "unsafeCoerce") par (pp_expr true env [] a :: args) | MLaxiom -> pp_par par (str "Prelude.error \"AXIOM TO BE REALIZED\"") -and pp_pat env pv = +and pp_pat env factors pv = let pp_one_pat (name,ids,t) = let ids,env' = push_vars (List.rev ids) env in let par = expr_needs_par t in - hov 2 (pp_global name ++ + hov 2 (pp_global Cons name ++ (match ids with | [] -> mt () | _ -> (str " " ++ @@ -189,7 +175,18 @@ and pp_pat env pv = (fun () -> (spc ())) pr_id (List.rev ids))) ++ str " ->" ++ spc () ++ pp_expr par env' [] t) in - (prvect_with_sep (fun () -> (fnl () ++ str " ")) pp_one_pat pv) + prvecti + (fun i x -> if List.mem i factors then mt () else + (pp_one_pat pv.(i) ++ + if factors = [] && i = Array.length pv - 1 then mt () + else fnl () ++ str " ")) pv + ++ + match factors with + | [] -> mt () + | i::_ -> + let (_,ids,t) = pv.(i) in + let t = ast_lift (-List.length ids) t in + hov 2 (str "_ ->" ++ spc () ++ pp_expr (expr_needs_par t) env [] t) (*s names of the functions ([ids]) are already pushed in [env], and passed here just for convenience. *) @@ -223,7 +220,7 @@ let pp_logical_ind packet = let pp_singleton kn packet = let l = rename_tvars keywords packet.ip_vars in let l' = List.rev l in - hov 2 (str "type " ++ pp_global (IndRef (kn,0)) ++ spc () ++ + hov 2 (str "type " ++ pp_global Type (IndRef (kn,0)) ++ spc () ++ prlist_with_sep spc pr_id l ++ (if l <> [] then str " " else mt ()) ++ str "=" ++ spc () ++ pp_type false l' (List.hd packet.ip_types.(0)) ++ fnl () ++ @@ -233,7 +230,7 @@ let pp_singleton kn packet = let pp_one_ind ip pl cv = let pl = rename_tvars keywords pl in let pp_constructor (r,l) = - (pp_global r ++ + (pp_global Cons r ++ match l with | [] -> (mt ()) | _ -> (str " " ++ @@ -241,7 +238,7 @@ let pp_one_ind ip pl cv = (fun () -> (str " ")) (pp_type true pl) l)) in str (if Array.length cv = 0 then "type " else "data ") ++ - pp_global (IndRef ip) ++ str " " ++ + pp_global Type (IndRef ip) ++ str " " ++ prlist_with_sep (fun () -> str " ") pr_lower_id pl ++ (if pl = [] then mt () else str " ") ++ if Array.length cv = 0 then str "= () -- empty inductive" @@ -269,9 +266,7 @@ let rec pp_ind first kn i ind = let pp_string_parameters ids = prlist (fun id -> str id ++ str " ") -let pp_decl mpl = - local_mpl := mpl; - function +let pp_decl = function | Dind (kn,i) when i.ind_info = Singleton -> pp_singleton kn i.ind_packets.(0) ++ fnl () | Dind (kn,i) -> hov 0 (pp_ind true kn 0 i) @@ -288,38 +283,51 @@ let pp_decl mpl = if t = Taxiom then str "= () -- AXIOM TO BE REALIZED\n" else str "=" ++ spc () ++ pp_type false l t in - hov 2 (str "type " ++ pp_global r ++ spc () ++ st) ++ fnl () ++ fnl () + hov 2 (str "type " ++ pp_global Type r ++ spc () ++ st) ++ fnl2 () | Dfix (rv, defs, typs) -> let max = Array.length rv in let rec iter i = if i = max then mt () else - let e = pp_global rv.(i) in + let e = pp_global Term rv.(i) in e ++ str " :: " ++ pp_type false [] typs.(i) ++ fnl () - ++ pp_function (empty_env ()) e defs.(i) ++ fnl () ++ fnl () + ++ pp_function (empty_env ()) e defs.(i) ++ fnl2 () ++ iter (i+1) in iter 0 | Dterm (r, a, t) -> if is_inline_custom r then mt () else - let e = pp_global r in + let e = pp_global Term r in e ++ str " :: " ++ pp_type false [] t ++ fnl () ++ if is_custom r then - hov 0 (e ++ str " = " ++ str (find_custom r) ++ fnl() ++ fnl ()) + hov 0 (e ++ str " = " ++ str (find_custom r) ++ fnl2 ()) else - hov 0 (pp_function (empty_env ()) e a ++ fnl () ++ fnl ()) + hov 0 (pp_function (empty_env ()) e a ++ fnl2 ()) -let pp_structure_elem mpl = function - | (l,SEdecl d) -> pp_decl mpl d +let pp_structure_elem = function + | (l,SEdecl d) -> pp_decl d | (l,SEmodule m) -> failwith "TODO: Haskell extraction of modules not implemented yet" | (l,SEmodtype m) -> failwith "TODO: Haskell extraction of modules not implemented yet" let pp_struct = - prlist (fun (mp,sel) -> prlist (pp_structure_elem [mp]) sel) - -let pp_signature s = failwith "TODO" - -end - + let pp_sel (mp,sel) = + push_visible mp; + let p = prlist_strict pp_structure_elem sel in + pop_visible (); p + in + prlist_strict pp_sel + + +let haskell_descr = { + keywords = keywords; + file_suffix = ".hs"; + capital_file = true; + preamble = preamble; + pp_struct = pp_struct; + sig_suffix = None; + sig_preamble = (fun _ _ _ -> mt ()); + pp_sig = (fun _ -> mt ()); + pp_decl = pp_decl; +} diff --git a/contrib/extraction/haskell.mli b/contrib/extraction/haskell.mli index 106f7868..1af9c231 100644 --- a/contrib/extraction/haskell.mli +++ b/contrib/extraction/haskell.mli @@ -6,15 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: haskell.mli 7632 2005-12-01 14:35:21Z letouzey $ i*) +(*i $Id: haskell.mli 10232 2007-10-17 12:32:10Z letouzey $ i*) -open Pp -open Names -open Miniml +val haskell_descr : Miniml.language_descr -val keywords : Idset.t - -val preamble : - extraction_params -> module_path list -> bool*bool*bool -> bool -> std_ppcmds - -module Make : functor(P : Mlpp_param) -> Mlpp diff --git a/contrib/extraction/miniml.mli b/contrib/extraction/miniml.mli index 3b4146f8..dfe4eb48 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 9456 2006-12-17 20:08:38Z letouzey $ i*) +(*i $Id: miniml.mli 10497 2008-02-01 12:18:37Z soubiran $ i*) (*s Target language for extraction: a core ML called MiniML. *) @@ -58,6 +58,8 @@ type inductive_info = | Standard | Record of global_reference list +type case_info = int list (* list of branches to merge in a _ pattern *) + (* A [ml_ind_packet] is the miniml counterpart of a [one_inductive_body]. If the inductive is logical ([ip_logical = false]), then all other fields are unused. Otherwise, @@ -76,11 +78,16 @@ type ml_ind_packet = { (* [ip_nparams] contains the number of parameters. *) +type equiv = + | NoEquiv + | Equiv of kernel_name + | RenEquiv of string + type ml_ind = { ind_info : inductive_info; ind_nparams : int; ind_packets : ml_ind_packet array; - ind_equiv : kernel_name option + ind_equiv : equiv } (*s ML terms. *) @@ -92,7 +99,7 @@ type ml_ast = | MLletin of identifier * ml_ast * ml_ast | MLglob of global_reference | MLcons of inductive_info * global_reference * ml_ast list - | MLcase of inductive_info * ml_ast * + | MLcase of (inductive_info*case_info) * ml_ast * (global_reference * identifier list * ml_ast) array | MLfix of int * identifier array * ml_ast array | MLexn of string @@ -119,9 +126,14 @@ type ml_specif = | Smodtype of ml_module_type and ml_module_type = - | MTident of kernel_name + | MTident of module_path | MTfunsig of mod_bound_id * ml_module_type * ml_module_type | MTsig of mod_self_id * ml_module_sig + | MTwith of ml_module_type * ml_with_declaration + +and ml_with_declaration = + | ML_With_type of identifier list * identifier list * ml_type + | ML_With_module of identifier list * module_path and ml_module_sig = (label * ml_specif) list @@ -149,24 +161,28 @@ type ml_structure = (module_path * ml_module_structure) list type ml_signature = (module_path * ml_module_sig) list -(*s Pretty-printing of MiniML in a given concrete syntax is parameterized - by a function [pp_global] that pretty-prints global references. - The resulting pretty-printer is a module of type [Mlpp] providing - functions to print types, terms and declarations. *) - -module type Mlpp_param = sig - val globals : unit -> Idset.t - val pp_global : module_path list -> global_reference -> std_ppcmds - val pp_module : module_path list -> module_path -> std_ppcmds -end - -module type Mlpp = sig - val pp_decl : module_path list -> ml_decl -> std_ppcmds - val pp_struct : ml_structure -> std_ppcmds - val pp_signature : ml_signature -> std_ppcmds -end - -type extraction_params = - { modular : bool; - mod_name : identifier; - to_appear : global_reference list } +type unsafe_needs = { + mldummy : bool; + tdummy : bool; + tunknown : bool; + magic : bool +} + +type language_descr = { + keywords : Idset.t; + + (* Concerning the source file *) + file_suffix : string; + capital_file : bool; (* should we capitalize filenames ? *) + preamble : identifier -> module_path list -> unsafe_needs -> std_ppcmds; + pp_struct : ml_structure -> std_ppcmds; + + (* Concerning a possible interface file *) + sig_suffix : string option; + sig_preamble : identifier -> module_path list -> unsafe_needs -> std_ppcmds; + pp_sig : ml_signature -> std_ppcmds; + + (* for an isolated declaration print *) + pp_decl : ml_decl -> std_ppcmds; + +} diff --git a/contrib/extraction/mlutil.ml b/contrib/extraction/mlutil.ml index 6bfedce5..79aeea33 100644 --- a/contrib/extraction/mlutil.ml +++ b/contrib/extraction/mlutil.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: mlutil.ml 8886 2006-06-01 13:53:45Z letouzey $ i*) +(*i $Id: mlutil.ml 10329 2007-11-21 21:21:36Z letouzey $ i*) (*i*) open Pp @@ -573,14 +573,20 @@ let eta_red e = if n = 0 then e else match t with | MLapp (f,a) -> - let m = (List.length a) - n in - if m < 0 then e - else - let a1,a2 = list_chop m a in - let f = if m = 0 then f else MLapp (f,a1) in - if test_eta_args_lift 0 n a2 && not (ast_occurs_itvl 1 n f) - then ast_lift (-n) f - else e + let m = List.length a in + let ids,body,args = + if m = n then + [], f, a + else if m < n then + snd (list_chop (n-m) ids), f, a + else (* m > n *) + let a1,a2 = list_chop (m-n) a in + [], MLapp (f,a1), a2 + in + let p = List.length args in + if test_eta_args_lift 0 p args && not (ast_occurs_itvl 1 p body) + then named_lams ids (ast_lift (-p) body) + else e | _ -> e (*s Computes all head linear beta-reductions possible in [(t a)]. @@ -658,20 +664,27 @@ let check_generalizable_case unsafe br = if check_and_generalize br.(i) <> f then raise Impossible done; f -(*s Do all branches correspond to the same thing? *) +(*s Detecting similar branches of a match *) -let check_constant_case br = - if Array.length br = 0 then raise Impossible; - let (r,l,t) = br.(0) in - let n = List.length l in - if ast_occurs_itvl 1 n t then raise Impossible; - let cst = ast_lift (-n) t in - for i = 1 to Array.length br - 1 do - let (r,l,t) = br.(i) in - let n = List.length l in - if (ast_occurs_itvl 1 n t) || (cst <> (ast_lift (-n) t)) - then raise Impossible - done; cst +(* If several branches of a match are equal (and independent from their + patterns) we will print them using a _ pattern. If _all_ branches + are equal, we remove the match. +*) + +let common_branches br = + let tab = Hashtbl.create 13 in + for i = 0 to Array.length br - 1 do + let (r,ids,t) = br.(i) in + let n = List.length ids in + if not (ast_occurs_itvl 1 n t) then + let t = ast_lift (-n) t in + let l = try Hashtbl.find tab t with Not_found -> [] in + Hashtbl.replace tab t (i::l) + done; + let best = ref [] in + Hashtbl.iter + (fun _ l -> if List.length l > List.length !best then best := l) tab; + if List.length !best < 2 then [] else !best (*s If all branches are functions, try to permut the case and the functions. *) @@ -805,18 +818,20 @@ and simpl_case o i br e = let f = check_generalizable_case o.opt_case_idg br in simpl o (MLapp (MLlam (anonymous,f),[e])) with Impossible -> - try (* Is each branch independant of [e] ? *) - if not o.opt_case_cst then raise Impossible; - check_constant_case br - with Impossible -> + (* Detect common branches *) + let common_br = if not o.opt_case_cst then [] else common_branches br in + if List.length common_br = Array.length br && br <> [||] then + let (_,ids,t) = br.(0) in ast_lift (-List.length ids) t + else + let new_i = (fst i, common_br) in (* Swap the case and the lam if possible *) if o.opt_case_fun then let ids,br = permut_case_fun br [] in let n = List.length ids in - if n <> 0 then named_lams ids (MLcase (i,ast_lift n e, br)) - else MLcase (i,e,br) - else MLcase (i,e,br) + if n <> 0 then named_lams ids (MLcase (new_i,ast_lift n e, br)) + else MLcase (new_i,e,br) + else MLcase (new_i,e,br) let rec post_simpl = function | MLletin(_,c,e) when (is_atomic (eta_red c)) -> @@ -1122,13 +1137,15 @@ let is_not_strict t = Futhermore we don't expand fixpoints. *) let inline_test t = - not (is_fix (eta_red t)) && (ml_size t < 12 && is_not_strict t) + let t1 = eta_red t in + let t2 = snd (collect_lams t1) in + not (is_fix t2) && ml_size t < 12 && is_not_strict t let manual_inline_list = let mp = MPfile (dirpath_of_string "Coq.Init.Wf") in List.map (fun s -> (make_con mp empty_dirpath (mk_label s))) [ "well_founded_induction_type"; "well_founded_induction"; - "Acc_rect"; "Acc_rec" ; "Acc_iter" ] + "Acc_rect"; "Acc_rec" ; "Acc_iter" ; "Fix" ] let manual_inline = function | ConstRef c -> List.mem c manual_inline_list diff --git a/contrib/extraction/modutil.ml b/contrib/extraction/modutil.ml index c9d4e237..48444509 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 9456 2006-12-17 20:08:38Z letouzey $ i*) +(*i $Id: modutil.ml 10665 2008-03-14 12:10:09Z soubiran $ i*) open Names open Declarations @@ -20,121 +20,34 @@ open Mod_subst (*S Functions upon modules missing in [Modops]. *) -(*s Add _all_ direct subobjects of a module, not only those exported. - Build on the [Modops.add_signature] model. *) - -let add_structure mp msb env = - let add_one env (l,elem) = - let kn = make_kn mp empty_dirpath l in - let con = make_con mp empty_dirpath l in - match elem with - | SEBconst cb -> Environ.add_constant con cb env - | SEBmind mib -> Environ.add_mind kn mib env - | SEBmodule mb -> Modops.add_module (MPdot (mp,l)) mb env - | SEBmodtype mtb -> Environ.add_modtype kn mtb env - in List.fold_left add_one env msb - -(*s Apply a module path substitution on a module. - Build on the [Modops.subst_modtype] model. *) - -let rec subst_module sub mb = - let mtb' = Modops.subst_modtype sub mb.mod_type - and meb' = option_smartmap (subst_meb sub) mb.mod_expr - and mtb'' = option_smartmap (Modops.subst_modtype sub) mb.mod_user_type - and mpo' = option_smartmap (subst_mp sub) mb.mod_equiv in - if (mtb'==mb.mod_type) && (meb'==mb.mod_expr) && - (mtb''==mb.mod_user_type) && (mpo'==mb.mod_equiv) - then mb - else { mod_expr= meb'; - mod_type=mtb'; - mod_user_type=mtb''; - mod_equiv=mpo'; - mod_constraints=mb.mod_constraints } - -and subst_meb sub = function - | MEBident mp -> MEBident (subst_mp sub mp) - | MEBfunctor (mbid, mtb, meb) -> - assert (not (occur_mbid mbid sub)); - MEBfunctor (mbid, Modops.subst_modtype sub mtb, subst_meb sub meb) - | MEBstruct (msid, msb) -> - assert (not (occur_msid msid sub)); - MEBstruct (msid, subst_msb sub msb) - | MEBapply (meb, meb', c) -> - MEBapply (subst_meb sub meb, subst_meb sub meb', c) - -and subst_msb sub msb = - let subst_body = function - | SEBconst cb -> SEBconst (subst_const_body sub cb) - | SEBmind mib -> SEBmind (subst_mind sub mib) - | SEBmodule mb -> SEBmodule (subst_module sub mb) - | SEBmodtype mtb -> SEBmodtype (Modops.subst_modtype sub mtb) - in List.map (fun (l,b) -> (l,subst_body b)) msb - (*s Change a msid in a module type, to follow a module expr. Because of the "with" construct, the module type of a module can be a [MTBsig] with a msid different from the one of the module. *) let rec replicate_msid meb mtb = match meb,mtb with - | MEBfunctor (_, _, meb), MTBfunsig (mbid, mtb1, mtb2) -> + | SEBfunctor (_, _, meb), SEBfunctor (mbid, mtb1, mtb2) -> let mtb' = replicate_msid meb mtb2 in - if mtb' == mtb2 then mtb else MTBfunsig (mbid, mtb1, mtb') - | MEBstruct (msid, _), MTBsig (msid1, msig) when msid <> msid1 -> + if mtb' == mtb2 then mtb else SEBfunctor (mbid, mtb1, mtb') + | SEBstruct (msid, _), SEBstruct (msid1, msig) when msid <> msid1 -> let msig' = Modops.subst_signature_msid msid1 (MPself msid) msig in - if msig' == msig then MTBsig (msid, msig) else MTBsig (msid, msig') + if msig' == msig then SEBstruct (msid, msig) else SEBstruct (msid, msig') | _ -> mtb - -(*S More functions concerning [module_path]. *) - -let rec mp_length = function - | MPdot (mp, _) -> 1 + (mp_length mp) - | _ -> 1 - -let rec prefixes_mp mp = match mp with - | MPdot (mp',_) -> MPset.add mp (prefixes_mp mp') - | _ -> MPset.singleton mp - -let rec common_prefix prefixes_mp1 mp2 = - if MPset.mem mp2 prefixes_mp1 then mp2 - else match mp2 with - | MPdot (mp,_) -> common_prefix prefixes_mp1 mp - | _ -> raise Not_found - -let common_prefix_from_list mp0 mpl = - let prefixes_mp0 = prefixes_mp mp0 in - let rec f = function - | [] -> raise Not_found - | mp1 :: l -> try common_prefix prefixes_mp0 mp1 with Not_found -> f l - in f mpl - -let rec modfile_of_mp mp = match mp with - | MPfile _ -> mp - | MPdot (mp,_) -> modfile_of_mp mp - | _ -> raise Not_found - -let rec parse_labels ll = function - | MPdot (mp,l) -> parse_labels (l::ll) mp - | mp -> mp,ll - -let labels_of_mp mp = parse_labels [] mp - -let labels_of_ref r = - let mp,_,l = - match r with - ConstRef con -> repr_con con - | IndRef (kn,_) - | ConstructRef ((kn,_),_) -> repr_kn kn - | VarRef _ -> assert false - in - parse_labels [l] mp - -let rec add_labels_mp mp = function - | [] -> mp - | l :: ll -> add_labels_mp (MPdot (mp,l)) ll - - (*S Functions upon ML modules. *) - +let rec msid_of_mt = function + | MTident mp -> begin + match Modops.eval_struct (Global.env()) (SEBident mp) with + | SEBstruct(msid,_) -> MPself msid + | _ -> anomaly "Extraction:the With can't be applied to a funsig" + end + | MTwith(mt,_)-> msid_of_mt mt + | _ -> anomaly "Extraction:the With operator isn't applied to a name" + +let make_mp_with mp idl = + let idl_rev = List.rev idl in + let idl' = List.rev (List.tl idl_rev) in + (List.fold_left (fun mp id -> MPdot(mp,label_of_id id)) + mp idl') (*s Apply some functions upon all [ml_decl] and [ml_spec] found in a [ml_structure]. *) @@ -142,6 +55,16 @@ let struct_iter do_decl do_spec s = let rec mt_iter = function | MTident _ -> () | MTfunsig (_,mt,mt') -> mt_iter mt; mt_iter mt' + | MTwith (mt,ML_With_type(idl,l,t))-> + let mp_mt = msid_of_mt mt in + let mp = make_mp_with mp_mt idl in + let gr = ConstRef ( + (make_con mp empty_dirpath + (label_of_id ( + List.hd (List.rev idl))))) in + mt_iter mt;do_decl + (Dtype(gr,l,t)) + | MTwith (mt,_)->mt_iter mt | MTsig (_, sign) -> List.iter spec_iter sign and spec_iter = function | (_,Spec s) -> do_spec s @@ -186,7 +109,7 @@ let ast_iter_references do_term do_cons do_type a = if lang () = Ocaml then record_iter_references do_term i; do_cons r | MLcase (i,_,v) -> - if lang () = Ocaml then record_iter_references do_term i; + if lang () = Ocaml then record_iter_references do_term (fst i); Array.iter (fun (r,_,_) -> do_cons r) v | _ -> () in iter a @@ -197,7 +120,9 @@ let ind_iter_references do_term do_cons do_type kn ind = let packet_iter ip p = do_type (IndRef ip); if lang () = Ocaml then - option_iter (fun kne -> do_type (IndRef (kne,snd ip))) ind.ind_equiv; + (match ind.ind_equiv with + | Equiv kne -> do_type (IndRef (kne, snd ip)); + | _ -> ()); 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; @@ -215,7 +140,7 @@ let decl_iter_references do_term do_cons do_type = let spec_iter_references do_term do_cons do_type = function | Sind (kn,ind) -> ind_iter_references do_term do_cons do_type kn ind - | Stype (r,_,ot) -> do_type r; option_iter (type_iter_references do_type) ot + | Stype (r,_,ot) -> do_type r; Option.iter (type_iter_references do_type) ot | Sval (r,t) -> do_term r; type_iter_references do_type t let struct_iter_references do_term do_cons do_type = @@ -225,13 +150,13 @@ let struct_iter_references do_term do_cons do_type = (*s Get all references used in one [ml_structure], either in [list] or [set]. *) -type 'a updown = { mutable up : 'a ; mutable down : 'a } +type 'a kinds = { mutable typ : 'a ; mutable trm : 'a; mutable cons : 'a } let struct_get_references empty add struc = - let o = { up = empty ; down = empty } in - let do_term r = o.down <- add r o.down in - let do_cons r = o.up <- add r o.up in - let do_type = if lang () = Haskell then do_cons else do_term in + let o = { typ = empty ; trm = empty ; cons = empty } in + let do_type r = o.typ <- add r o.typ in + let do_term r = o.trm <- add r o.trm in + let do_cons r = o.cons <- add r o.cons in struct_iter_references do_term do_cons do_type struc; o let struct_get_references_set = struct_get_references Refset.empty Refset.add @@ -248,7 +173,9 @@ end let struct_get_references_list struc = let o = struct_get_references Orefset.empty Orefset.add struc in - { up = Orefset.list o.up; down = Orefset.list o.down } + { typ = Orefset.list o.typ; + trm = Orefset.list o.trm; + cons = Orefset.list o.cons } (*s Searching occurrences of a particular term (no lifting done). *) @@ -284,7 +211,7 @@ let spec_type_search f = function | Sind (_,{ind_packets=p}) -> Array.iter (fun {ip_types=v} -> Array.iter (List.iter (type_search f)) v) p - | Stype (_,_,ot) -> option_iter (type_search f) ot + | Stype (_,_,ot) -> Option.iter (type_search f) ot | Sval (_,u) -> type_search f u let struct_type_search f s = @@ -360,38 +287,40 @@ let dfix_to_mlfix rv av i = let c = Array.map (subst 0) av in MLfix(i, ids, c) -let rec optim prm s = function +let rec optim to_appear s = function | [] -> [] | (Dtype (r,_,Tdummy _) | Dterm(r,MLdummy,_)) as d :: l -> - if List.mem r prm.to_appear then d :: (optim prm s l) else optim prm s l + if List.mem r to_appear + then d :: (optim to_appear s l) + else optim to_appear s l | Dterm (r,t,typ) :: l -> let t = normalize (ast_glob_subst !s t) in let i = inline r t in if i then s := Refmap.add r t !s; - if not i || prm.modular || List.mem r prm.to_appear + if not i || modular () || List.mem r to_appear then let d = match optimize_fix t with | MLfix (0, _, [|c|]) -> Dfix ([|r|], [|ast_subst (MLglob r) c|], [|typ|]) | t -> Dterm (r, t, typ) - in d :: (optim prm s l) - else optim prm s l - | d :: l -> d :: (optim prm s l) + in d :: (optim to_appear s l) + else optim to_appear s l + | d :: l -> d :: (optim to_appear s l) -let rec optim_se top prm s = function +let rec optim_se top to_appear s = function | [] -> [] | (l,SEdecl (Dterm (r,a,t))) :: lse -> let a = normalize (ast_glob_subst !s a) in let i = inline r a in if i then s := Refmap.add r a !s; - if top && i && not prm.modular && not (List.mem r prm.to_appear) - then optim_se top prm s lse + if top && i && not (modular ()) && not (List.mem r to_appear) + then optim_se top to_appear s lse else let d = match optimize_fix a with | MLfix (0, _, [|c|]) -> Dfix ([|r|], [|ast_subst (MLglob r) c|], [|t|]) | a -> Dterm (r, a, t) - in (l,SEdecl d) :: (optim_se top prm s lse) + in (l,SEdecl d) :: (optim_se top to_appear s lse) | (l,SEdecl (Dfix (rv,av,tv))) :: lse -> let av = Array.map (fun a -> normalize (ast_glob_subst !s a)) av in let all = ref true in @@ -402,22 +331,22 @@ let rec optim_se top prm s = function then s := Refmap.add rv.(i) (dfix_to_mlfix rv av i) !s else all := false done; - if !all && top && not prm.modular - && (array_for_all (fun r -> not (List.mem r prm.to_appear)) rv) - then optim_se top prm s lse - else (l,SEdecl (Dfix (rv, av, tv))) :: (optim_se top prm s lse) + if !all && top && not (modular ()) + && (array_for_all (fun r -> not (List.mem r to_appear)) rv) + then optim_se top to_appear s lse + else (l,SEdecl (Dfix (rv, av, tv))) :: (optim_se top to_appear s lse) | (l,SEmodule m) :: lse -> - let m = { m with ml_mod_expr = optim_me prm s m.ml_mod_expr} - in (l,SEmodule m) :: (optim_se top prm s lse) - | se :: lse -> se :: (optim_se top prm s lse) + let m = { m with ml_mod_expr = optim_me to_appear s m.ml_mod_expr} + in (l,SEmodule m) :: (optim_se top to_appear s lse) + | se :: lse -> se :: (optim_se top to_appear s lse) -and optim_me prm s = function - | MEstruct (msid, lse) -> MEstruct (msid, optim_se false prm s lse) +and optim_me to_appear s = function + | MEstruct (msid, lse) -> MEstruct (msid, optim_se false to_appear s lse) | MEident mp as me -> me - | MEapply (me, me') -> MEapply (optim_me prm s me, optim_me prm s me') - | MEfunctor (mbid,mt,me) -> MEfunctor (mbid,mt, optim_me prm s me) + | MEapply (me, me') -> + MEapply (optim_me to_appear s me, optim_me to_appear s me') + | MEfunctor (mbid,mt,me) -> MEfunctor (mbid,mt, optim_me to_appear s me) -let optimize_struct prm before struc = +let optimize_struct to_appear struc = let subst = ref (Refmap.empty : ml_ast Refmap.t) in - option_iter (fun l -> ignore (optim prm subst l)) before; - List.map (fun (mp,lse) -> (mp, optim_se true prm subst lse)) struc + List.map (fun (mp,lse) -> (mp, optim_se true to_appear subst lse)) struc diff --git a/contrib/extraction/modutil.mli b/contrib/extraction/modutil.mli index 115a42ca..85d58a4b 100644 --- a/contrib/extraction/modutil.mli +++ b/contrib/extraction/modutil.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: modutil.mli 8724 2006-04-20 09:57:01Z letouzey $ i*) +(*i $Id: modutil.mli 10620 2008-03-05 10:54:41Z letouzey $ i*) open Names open Declarations @@ -17,29 +17,9 @@ open Mod_subst (*s Functions upon modules missing in [Modops]. *) -(* Add _all_ direct subobjects of a module, not only those exported. - Build on the [Modops.add_signature] model. *) - -val add_structure : module_path -> module_structure_body -> env -> env - -(* Apply a module path substitution on a module. - Build on the [Modops.subst_modtype] model. *) - -val subst_module : substitution -> module_body -> module_body -val subst_meb : substitution -> module_expr_body -> module_expr_body -val subst_msb : substitution -> module_structure_body -> module_structure_body - (* Change a msid in a module type, to follow a module expr. *) -val replicate_msid : module_expr_body -> module_type_body -> module_type_body - -(*s More utilities concerning [module_path]. *) - -val mp_length : module_path -> int -val prefixes_mp : module_path -> MPset.t -val modfile_of_mp : module_path -> module_path -val common_prefix_from_list : module_path -> module_path list -> module_path -val add_labels_mp : module_path -> label list -> module_path +val replicate_msid : struct_expr_body -> struct_expr_body -> struct_expr_body (*s Functions upon ML modules. *) @@ -52,10 +32,10 @@ val decl_iter_references : do_ref -> do_ref -> do_ref -> ml_decl -> unit val spec_iter_references : do_ref -> do_ref -> do_ref -> ml_spec -> unit val struct_iter_references : do_ref -> do_ref -> do_ref -> ml_structure -> unit -type 'a updown = { mutable up : 'a ; mutable down : 'a } +type 'a kinds = { mutable typ : 'a ; mutable trm : 'a; mutable cons : 'a } -val struct_get_references_set : ml_structure -> Refset.t updown -val struct_get_references_list : ml_structure -> global_reference list updown +val struct_get_references_set : ml_structure -> Refset.t kinds +val struct_get_references_list : ml_structure -> global_reference list kinds val signature_of_structure : ml_structure -> ml_signature @@ -65,7 +45,7 @@ val get_decl_in_structure : global_reference -> ml_structure -> ml_decl all beta redexes (when the argument does not occur, it is just thrown away; when it occurs exactly once it is substituted; otherwise a let-in redex is created for clarity) and iota redexes, plus some other - optimizations. *) + optimizations. The first argument is the list of objects we want to appear. +*) -val optimize_struct : - extraction_params -> ml_decl list option -> ml_structure -> ml_structure +val optimize_struct : global_reference list -> ml_structure -> ml_structure diff --git a/contrib/extraction/ocaml.ml b/contrib/extraction/ocaml.ml index 35f9a83c..64c80a2a 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 9472 2007-01-05 15:49:32Z letouzey $ i*) +(*i $Id: ocaml.ml 10592 2008-02-27 14:16:07Z letouzey $ i*) (*s Production of Ocaml syntax. *) @@ -19,10 +19,27 @@ open Table open Miniml open Mlutil open Modutil +open Common +open Declarations + (*s Some utility functions. *) -let pp_par par st = if par then str "(" ++ st ++ str ")" else st +let rec msid_of_mt = function + | MTident mp -> begin + match Modops.eval_struct (Global.env()) (SEBident mp) with + | SEBstruct(msid,_) -> MPself msid + | _ -> anomaly "Extraction:the With can't be applied to a funsig" + end + | MTwith(mt,_)-> msid_of_mt mt + | _ -> anomaly "Extraction:the With operator isn't applied to a name" + +let make_mp_with mp idl = + let idl_rev = List.rev idl in + let idl' = List.rev (List.tl idl_rev) in + (List.fold_left (fun mp id -> MPdot(mp,label_of_id id)) + mp idl') + let pp_tvar id = let s = string_of_id id in @@ -52,70 +69,12 @@ let pp_abst = function str "fun " ++ prlist_with_sep (fun () -> str " ") pr_id l ++ str " ->" ++ spc () -let pp_apply st par args = match args with - | [] -> st - | _ -> hov 2 (pp_par par (st ++ spc () ++ prlist_with_sep spc identity args)) - -let pr_binding = function - | [] -> mt () - | l -> str " " ++ prlist_with_sep (fun () -> str " ") pr_id l - -let space_if = function true -> str " " | false -> mt () - -let sec_space_if = function true -> spc () | false -> mt () - -let fnl2 () = fnl () ++ fnl () - let pp_parameters l = (pp_boxed_tuple pp_tvar l ++ space_if (l<>[])) let pp_string_parameters l = (pp_boxed_tuple str l ++ space_if (l<>[])) -(*s Generic renaming issues. *) - -let rec rename_id id avoid = - if Idset.mem id avoid then rename_id (lift_ident id) avoid else id - -let lowercase_id id = id_of_string (String.uncapitalize (string_of_id id)) -let uppercase_id id = id_of_string (String.capitalize (string_of_id id)) - -(* [pr_upper_id id] makes 2 String.copy lesser than [pr_id (uppercase_id id)] *) -let pr_upper_id id = str (String.capitalize (string_of_id id)) - -(*s de Bruijn environments for programs *) - -type env = identifier list * Idset.t - -let rec rename_vars avoid = function - | [] -> - [], avoid - | id :: idl when id == dummy_name -> - (* we don't rename dummy binders *) - let (idl', avoid') = rename_vars avoid idl in - (id :: idl', avoid') - | id :: idl -> - let (idl, avoid) = rename_vars avoid idl in - let id = rename_id (lowercase_id id) avoid in - (id :: idl, Idset.add id avoid) - -let rename_tvars avoid l = - let rec rename avoid = function - | [] -> [],avoid - | id :: idl -> - let id = rename_id (lowercase_id id) avoid in - let idl, avoid = rename (Idset.add id avoid) idl in - (id :: idl, avoid) in - fst (rename avoid l) - -let push_vars ids (db,avoid) = - let ids',avoid' = rename_vars avoid ids in - ids', (ids' @ db, avoid') - -let get_db_name n (db,_) = - let id = List.nth db (pred n) in - if id = dummy_name then id_of_string "__" else id - (*s Ocaml renaming issues. *) let keywords = @@ -130,46 +89,39 @@ let keywords = "land"; "lor"; "lxor"; "lsl"; "lsr"; "asr" ; "unit" ; "_" ; "__" ] Idset.empty -let preamble _ used_modules (mldummy,tdummy,tunknown) _ = - let pp_mp = function - | MPfile d -> pr_upper_id (List.hd (repr_dirpath d)) - | _ -> assert false - in - prlist (fun mp -> str "open " ++ pp_mp mp ++ fnl ()) used_modules - ++ - (if used_modules = [] then mt () else fnl ()) - ++ - (if tdummy || tunknown then str "type __ = Obj.t" ++ fnl() else mt()) - ++ - (if mldummy then - str "let __ = let rec f _ = Obj.repr f in Obj.repr f" ++ fnl () - else mt ()) - ++ - (if tdummy || tunknown || mldummy then fnl () else mt ()) - -let preamble_sig _ used_modules (_,tdummy,tunknown) = - let pp_mp = function - | MPfile d -> pr_upper_id (List.hd (repr_dirpath d)) - | _ -> assert false - in - prlist (fun mp -> str "open " ++ pp_mp mp ++ fnl ()) used_modules - ++ - (if used_modules = [] then mt () else fnl ()) - ++ - (if tdummy || tunknown then str "type __ = Obj.t" ++ fnl() ++ fnl () - else mt()) +let pp_open mp = str ("open "^ string_of_modfile mp ^"\n") -(*s The pretty-printing functor. *) +let preamble _ used_modules usf = + prlist pp_open used_modules ++ + (if used_modules = [] then mt () else fnl ()) ++ + (if usf.tdummy || usf.tunknown then str "type __ = Obj.t\n" else mt()) ++ + (if usf.mldummy then + str "let __ = let rec f _ = Obj.repr f in Obj.repr f\n" + else mt ()) ++ + (if usf.tdummy || usf.tunknown || usf.mldummy then fnl () else mt ()) -module Make = functor(P : Mlpp_param) -> struct +let sig_preamble _ used_modules usf = + prlist pp_open used_modules ++ + (if used_modules = [] then mt () else fnl ()) ++ + (if usf.tdummy || usf.tunknown then str "type __ = Obj.t\n\n" else mt()) -let local_mpl = ref ([] : module_path list) +(*s The pretty-printer for Ocaml syntax*) -let pp_global r = +let pp_global k r = if is_inline_custom r then str (find_custom r) - else P.pp_global !local_mpl r + else str (Common.pp_global k r) + +let pp_modname mp = str (Common.pp_module mp) -let empty_env () = [], P.globals () +let is_infix r = + is_inline_custom r && + (let s = find_custom r in + let l = String.length s in + l >= 2 && s.[0] = '(' && s.[l-1] = ')') + +let get_infix r = + let s = find_custom r in + String.sub s 1 (String.length s - 2) exception NoRecord @@ -187,12 +139,16 @@ let rec pp_type par vl t = | Tmeta _ | Tvar' _ | Taxiom -> assert false | Tvar i -> (try pp_tvar (List.nth vl (pred i)) with _ -> (str "'a" ++ int i)) - | Tglob (r,[]) -> pp_global r + | Tglob (r,[a1;a2]) when is_infix r -> + pp_par par + (pp_rec true a1 ++ spc () ++ str (get_infix r) ++ spc () ++ + pp_rec true a2) + | Tglob (r,[]) -> pp_global Type r | Tglob (r,l) -> if r = IndRef (kn_sig,0) then pp_tuple_light pp_rec l else - pp_tuple_light pp_rec l ++ spc () ++ pp_global r + pp_tuple_light pp_rec l ++ spc () ++ pp_global Type r | Tarr (t1,t2) -> pp_par par (pp_rec true t1 ++ spc () ++ str "->" ++ spc () ++ pp_rec false t2) @@ -206,10 +162,16 @@ let rec pp_type par vl t = de Bruijn variables. [args] is the list of collected arguments (already pretty-printed). *) +let is_ifthenelse = function + | [|(r1,[],_);(r2,[],_)|] -> + (try (find_custom r1 = "true") && (find_custom r2 = "false") + with Not_found -> false) + | _ -> false + let expr_needs_par = function | MLlam _ -> true | MLcase (_,_,[|_|]) -> false - | MLcase _ -> true + | MLcase (_,_,pv) -> not (is_ifthenelse pv) | _ -> false @@ -244,26 +206,31 @@ let rec pp_expr par env args = (try let args = list_skipn (projection_arity r) args in let record = List.hd args in - pp_apply (record ++ str "." ++ pp_global r) par (List.tl args) - with _ -> apply (pp_global r)) + pp_apply (record ++ str "." ++ pp_global Term r) par (List.tl args) + with _ -> apply (pp_global Term r)) | MLcons (Coinductive,r,[]) -> assert (args=[]); - pp_par par (str "lazy " ++ pp_global r) + pp_par par (str "lazy " ++ pp_global Cons r) | MLcons (Coinductive,r,args') -> assert (args=[]); let tuple = pp_tuple (pp_expr true env []) args' in - pp_par par (str "lazy (" ++ pp_global r ++ spc() ++ tuple ++str ")") + pp_par par (str "lazy (" ++ pp_global Cons r ++ spc() ++ tuple ++str ")") | MLcons (_,r,[]) -> assert (args=[]); - pp_global r + pp_global Cons r | MLcons (Record projs, r, args') -> assert (args=[]); pp_record_pat (projs, List.map (pp_expr true env []) args') + | MLcons (_,r,[arg1;arg2]) when is_infix r -> + assert (args=[]); + pp_par par + ((pp_expr true env [] arg1) ++ spc () ++ str (get_infix r) ++ + spc () ++ (pp_expr true env [] arg2)) | MLcons (_,r,args') -> assert (args=[]); let tuple = pp_tuple (pp_expr true env []) args' in - pp_par par (pp_global r ++ spc () ++ tuple) - | MLcase (i, t, pv) -> + pp_par par (pp_global Cons r ++ spc () ++ tuple) + | MLcase ((i,factors), t, pv) -> let expr = if i = Coinductive then (str "Lazy.force" ++ spc () ++ pp_expr true env [] t) else @@ -276,7 +243,7 @@ let rec pp_expr par env args = match c with | MLrel i when i <= n -> apply (pp_par par' (pp_expr true env [] t ++ str "." ++ - pp_global (List.nth projs (n-i)))) + pp_global Term (List.nth projs (n-i)))) | MLapp (MLrel i, a) when i <= n -> if List.exists (ast_occurs_itvl 1 n) a then raise NoRecord @@ -284,7 +251,7 @@ let rec pp_expr par env args = let ids,env' = push_vars (List.rev ids) env in (pp_apply (pp_expr true env [] t ++ str "." ++ - pp_global (List.nth projs (n-i))) + pp_global Term (List.nth projs (n-i))) par ((List.map (pp_expr true env' []) a) @ args)) | _ -> raise NoRecord with NoRecord -> @@ -297,11 +264,13 @@ let rec pp_expr par env args = (hov 2 (str "let " ++ s1 ++ str " =" ++ spc () ++ expr) ++ spc () ++ str "in") ++ spc () ++ hov 0 s2))) - else - apply + else + apply (pp_par par' - (v 0 (str "match " ++ expr ++ str " with" ++ - fnl () ++ str " | " ++ pp_pat env i pv)))) + (try pp_ifthenelse par' env expr pv + with Not_found -> + v 0 (str "match " ++ expr ++ str " with" ++ fnl () ++ + str " | " ++ pp_pat env (i,factors) pv)))) | MLfix (i,ids,defs) -> let ids',env' = push_vars (List.rev (Array.to_list ids)) env in pp_fix par env' i (Array.of_list (List.rev ids'),defs) args @@ -319,10 +288,21 @@ let rec pp_expr par env args = and pp_record_pat (projs, args) = str "{ " ++ prlist_with_sep (fun () -> str ";" ++ spc ()) - (fun (r,a) -> pp_global r ++ str " =" ++ spc () ++ a) + (fun (r,a) -> pp_global Term r ++ str " =" ++ spc () ++ a) (List.combine projs args) ++ str " }" +and pp_ifthenelse par env expr pv = match pv with + | [|(tru,[],the);(fal,[],els)|] when + (find_custom tru = "true") && (find_custom fal = "false") + -> + hv 0 (hov 2 (str "if " ++ expr) ++ spc () ++ + hov 2 (str "then " ++ + hov 2 (pp_expr (expr_needs_par the) env [] the)) ++ spc () ++ + hov 2 (str "else " ++ + hov 2 (pp_expr (expr_needs_par els) env [] els))) + | _ -> raise Not_found + and pp_one_pat env i (r,ids,t) = let ids,env' = push_vars (List.rev ids) env in let expr = pp_expr (expr_needs_par t) env' [] t in @@ -330,33 +310,45 @@ and pp_one_pat env i (r,ids,t) = let projs = find_projections i in pp_record_pat (projs, List.rev_map pr_id ids), expr with NoRecord -> - let args = - if ids = [] then (mt ()) - else str " " ++ pp_boxed_tuple pr_id (List.rev ids) in - pp_global r ++ args, expr + (match List.rev ids with + | [i1;i2] when is_infix r -> + pr_id i1 ++ str " " ++ str (get_infix r) ++ str " " ++ pr_id i2 + | [] -> pp_global Cons r + | ids -> pp_global Cons r ++ str " " ++ pp_boxed_tuple pr_id ids), + expr -and pp_pat env i pv = - prvect_with_sep (fun () -> (fnl () ++ str " | ")) - (fun x -> let s1,s2 = pp_one_pat env i x in - hov 2 (s1 ++ str " ->" ++ spc () ++ s2)) pv - -and pp_function env f t = +and pp_pat env (info,factors) pv = + prvecti + (fun i x -> if List.mem i factors then mt () else + let s1,s2 = pp_one_pat env info x in + hov 2 (s1 ++ str " ->" ++ spc () ++ s2) ++ + (if factors = [] && i = Array.length pv-1 then mt () + else fnl () ++ str " | ")) pv + ++ + match factors with + | [] -> mt () + | i::_ -> + let (_,ids,t) = pv.(i) in + let t = ast_lift (-List.length ids) t in + hov 2 (str "_ ->" ++ spc () ++ pp_expr (expr_needs_par t) env [] t) + +and pp_function env t = let bl,t' = collect_lams t in let bl,env' = push_vars bl env in match t' with - | MLcase(i,MLrel 1,pv) when i=Standard -> + | MLcase(i,MLrel 1,pv) when fst i=Standard -> if not (ast_occurs 1 (MLcase(i,MLdummy,pv))) then - (f ++ pr_binding (List.rev (List.tl bl)) ++ - str " = function" ++ fnl () ++ - v 0 (str " | " ++ pp_pat env' i pv)) + pr_binding (List.rev (List.tl bl)) ++ + str " = function" ++ fnl () ++ + v 0 (str " | " ++ pp_pat env' i pv) else - (f ++ pr_binding (List.rev bl) ++ - str " = match " ++ - pr_id (List.hd bl) ++ str " with" ++ fnl () ++ - v 0 (str " | " ++ pp_pat env' i pv)) - | _ -> (f ++ pr_binding (List.rev bl) ++ - str " =" ++ fnl () ++ str " " ++ - hov 2 (pp_expr false env' [] t')) + pr_binding (List.rev bl) ++ + str " = match " ++ pr_id (List.hd bl) ++ str " with" ++ fnl () ++ + v 0 (str " | " ++ pp_pat env' i pv) + | _ -> + pr_binding (List.rev bl) ++ + str " =" ++ fnl () ++ str " " ++ + hov 2 (pp_expr false env' [] t') (*s names of the functions ([ids]) are already pushed in [env], and passed here just for convenience. *) @@ -366,93 +358,111 @@ and pp_fix par env i (ids,bl) args = (v 0 (str "let rec " ++ prvect_with_sep (fun () -> fnl () ++ str "and ") - (fun (fi,ti) -> pp_function env (pr_id fi) ti) + (fun (fi,ti) -> pr_id fi ++ pp_function env ti) (array_map2 (fun id b -> (id,b)) ids bl) ++ fnl () ++ hov 2 (str "in " ++ pp_apply (pr_id ids.(i)) false args))) let pp_val e typ = - str "(** val " ++ e ++ str " : " ++ pp_type false [] typ ++ - str " **)" ++ fnl2 () + hov 4 (str "(** val " ++ e ++ str " :" ++ spc () ++ pp_type false [] typ ++ + str " **)") ++ fnl2 () (*s Pretty-printing of [Dfix] *) -let rec pp_Dfix init i ((rv,c,t) as fix) = - if i >= Array.length rv then mt () - else - if is_inline_custom rv.(i) then pp_Dfix init (i+1) fix +let pp_Dfix (rv,c,t) = + let names = Array.map + (fun r -> if is_inline_custom r then mt () else pp_global Term r) rv + in + let rec pp sep letand i = + if i >= Array.length rv then mt () + else if is_inline_custom rv.(i) then pp sep letand (i+1) else - let e = pp_global rv.(i) in - (if init then mt () else fnl2 ()) ++ - pp_val e t.(i) ++ - str (if init then "let rec " else "and ") ++ - (if is_custom rv.(i) then e ++ str " = " ++ str (find_custom rv.(i)) - else pp_function (empty_env ()) e c.(i)) ++ - pp_Dfix false (i+1) fix - + let def = + if is_custom rv.(i) then str " = " ++ str (find_custom rv.(i)) + else pp_function (empty_env ()) c.(i) + in + sep () ++ pp_val names.(i) t.(i) ++ + str letand ++ names.(i) ++ def ++ pp fnl2 "and " (i+1) + in pp mt "let rec " 0 + (*s Pretty-printing of inductive types declaration. *) -let pp_equiv param_list = function - | None -> mt () - | Some ip_equiv -> - str " = " ++ pp_parameters param_list ++ pp_global (IndRef ip_equiv) +let pp_equiv param_list name = function + | NoEquiv, _ -> mt () + | Equiv kn, i -> + str " = " ++ pp_parameters param_list ++ pp_global Type (IndRef (kn,i)) + | RenEquiv ren, _ -> + str " = " ++ pp_parameters param_list ++ str (ren^".") ++ name let pp_comment s = str "(* " ++ s ++ str " *)" -let pp_one_ind prefix ip ip_equiv pl cv = +let pp_one_ind prefix ip_equiv pl name cnames ctyps = let pl = rename_tvars keywords pl in - let pp_constructor (r,l) = - hov 2 (str " | " ++ pp_global r ++ - match l with - | [] -> mt () - | _ -> (str " of " ++ - prlist_with_sep - (fun () -> spc () ++ str "* ") (pp_type true pl) l)) + let pp_constructor i typs = + (if i=0 then mt () else fnl ()) ++ + hov 5 (str " | " ++ cnames.(i) ++ + (if typs = [] then mt () else str " of ") ++ + prlist_with_sep + (fun () -> spc () ++ str "* ") (pp_type true pl) typs) in - 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)) + pp_parameters pl ++ str prefix ++ name ++ + pp_equiv pl name ip_equiv ++ str " =" ++ + if Array.length ctyps = 0 then str " unit (* empty inductive *)" + else fnl () ++ v 0 (prvecti pp_constructor ctyps) let pp_logical_ind packet = pp_comment (pr_id packet.ip_typename ++ str " : logical inductive") ++ - fnl () ++ pp_comment (str "with constructors : " ++ - prvect_with_sep spc pr_id packet.ip_consnames) + fnl () ++ + pp_comment (str "with constructors : " ++ + prvect_with_sep spc pr_id packet.ip_consnames) ++ + fnl () let pp_singleton kn packet = + let name = pp_global Type (IndRef (kn,0)) in let l = rename_tvars keywords packet.ip_vars in - hov 2 (str "type " ++ pp_parameters l ++ - pp_global (IndRef (kn,0)) ++ str " =" ++ spc () ++ + hov 2 (str "type " ++ pp_parameters l ++ name ++ str " =" ++ spc () ++ pp_type false l (List.hd packet.ip_types.(0)) ++ fnl () ++ pp_comment (str "singleton inductive, whose constructor was " ++ pr_id packet.ip_consnames.(0))) let pp_record kn projs ip_equiv packet = - let l = List.combine projs packet.ip_types.(0) in + let name = pp_global Type (IndRef (kn,0)) in + let projnames = List.map (pp_global Term) projs in + let l = List.combine projnames packet.ip_types.(0) in let pl = rename_tvars keywords packet.ip_vars in - str "type " ++ pp_parameters pl ++ pp_global (IndRef (kn,0)) ++ - pp_equiv pl ip_equiv ++ str " = { "++ + str "type " ++ pp_parameters pl ++ name ++ + pp_equiv pl name ip_equiv ++ str " = { "++ hov 0 (prlist_with_sep (fun () -> str ";" ++ spc ()) - (fun (r,t) -> pp_global r ++ str " : " ++ pp_type true pl t) l) + (fun (p,t) -> p ++ str " : " ++ pp_type true pl t) l) ++ str " }" -let pp_coind ip pl = - let r = IndRef ip in +let pp_coind pl name = 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 ++ name ++ str " = " ++ + pp_parameters pl ++ str "__" ++ name ++ 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 names = + Array.mapi (fun i p -> if p.ip_logical then mt () else + pp_global Type (IndRef (kn,i))) + ind.ind_packets + in + let cnames = + Array.mapi + (fun i p -> if p.ip_logical then [||] else + Array.mapi (fun j _ -> pp_global Cons (ConstructRef ((kn,i),j+1))) + p.ip_types) + ind.ind_packets + 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 ip_equiv = ind.ind_equiv, 0 in let p = ind.ind_packets.(i) in if is_custom (IndRef ip) then pp (i+1) else begin @@ -463,8 +473,9 @@ let pp_ind co kn ind = begin init := (fnl () ++ str "and "); s ++ - (if co then pp_coind ip p.ip_vars else mt ()) - ++ pp_one_ind prefix ip ip_equiv p.ip_vars p.ip_types ++ + (if co then pp_coind p.ip_vars names.(i) else mt ()) ++ + pp_one_ind + prefix ip_equiv p.ip_vars names.(i) cnames.(i) p.ip_types ++ pp (i+1) end end @@ -479,159 +490,248 @@ let pp_mind kn i = | Singleton -> pp_singleton kn i.ind_packets.(0) | Coinductive -> pp_ind true kn i | 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) + pp_record kn projs (i.ind_equiv,0) i.ind_packets.(0) | Standard -> pp_ind false kn i -let pp_decl mpl = - local_mpl := mpl; - function +let pp_decl = function + | Dtype (r,_,_) when is_inline_custom r -> failwith "empty phrase" + | Dterm (r,_,_) when is_inline_custom r -> failwith "empty phrase" | Dind (kn,i) -> pp_mind kn i - | Dtype (r, l, t) -> - if is_inline_custom r then failwith "empty phrase" - else - let pp_r = pp_global r in - let l = rename_tvars keywords l in - let ids, def = try + | Dtype (r, l, t) -> + let name = pp_global Type r in + let l = rename_tvars keywords l in + let ids, def = + try let ids,s = find_type_custom r in pp_string_parameters ids, str "=" ++ spc () ++ str s - with not_found -> + with Not_found -> pp_parameters l, if t = Taxiom then str "(* AXIOM TO BE REALIZED *)" else str "=" ++ spc () ++ pp_type false l t - in - hov 2 (str "type" ++ spc () ++ ids ++ pp_r ++ - spc () ++ def) + in + hov 2 (str "type " ++ ids ++ name ++ spc () ++ def) | Dterm (r, a, t) -> - if is_inline_custom r then failwith "empty phrase" - else - let e = pp_global r in - pp_val e t ++ - hov 0 - (str "let " ++ - if is_custom r then - e ++ str " = " ++ str (find_custom r) - else if is_projection r then - let s = prvecti (fun _ -> str) - (Array.make (projection_arity r) " _") in - e ++ s ++ str " x = x." ++ e - else pp_function (empty_env ()) e a) + let def = + if is_custom r then str (" = " ^ find_custom r) + else if is_projection r then + (prvect str (Array.make (projection_arity r) " _")) ++ + str " x = x." + else pp_function (empty_env ()) a + in + let name = pp_global Term r in + let postdef = if is_projection r then name else mt () in + pp_val name t ++ hov 0 (str "let " ++ name ++ def ++ postdef) | Dfix (rv,defs,typs) -> - pp_Dfix true 0 (rv,defs,typs) - -let pp_spec mpl = - local_mpl := mpl; - function - | Sind (kn,i) -> pp_mind kn i - | Sval (r,t) -> - if is_inline_custom r then failwith "empty phrase" - else - hov 2 (str "val" ++ spc () ++ pp_global r ++ str " :" ++ spc () ++ - pp_type false [] t) - | Stype (r,vl,ot) -> - if is_inline_custom r then failwith "empty phrase" - else - let l = rename_tvars keywords vl in - let ids, def = - try - let ids, s = find_type_custom r in - pp_string_parameters ids, str "= " ++ str s - with not_found -> - let ids = pp_parameters l in - match ot with - | None -> ids, mt () - | Some Taxiom -> ids, str "(* AXIOM TO BE REALIZED *)" - | Some t -> ids, str "=" ++ spc () ++ pp_type false l t - in - hov 2 (str "type" ++ spc () ++ ids ++ pp_global r ++ spc () ++ def) - -let rec pp_specif mpl = function - | (_,Spec s) -> pp_spec mpl s + pp_Dfix (rv,defs,typs) + +let pp_alias_decl ren = function + | Dind (kn,i) -> pp_mind kn { i with ind_equiv = RenEquiv ren } + | Dtype (r, l, _) -> + let name = pp_global Type r in + let l = rename_tvars keywords l in + let ids = pp_parameters l in + hov 2 (str "type " ++ ids ++ name ++ str " =" ++ spc () ++ ids ++ + str (ren^".") ++ name) + | Dterm (r, a, t) -> + let name = pp_global Term r in + hov 2 (str "let " ++ name ++ str (" = "^ren^".") ++ name) + | Dfix (rv, _, _) -> + prvecti (fun i r -> if is_inline_custom r then mt () else + let name = pp_global Term r in + hov 2 (str "let " ++ name ++ str (" = "^ren^".") ++ name) ++ + fnl ()) + rv + +let pp_spec = function + | Sval (r,_) when is_inline_custom r -> failwith "empty phrase" + | Stype (r,_,_) when is_inline_custom r -> failwith "empty phrase" + | Sind (kn,i) -> pp_mind kn i + | Sval (r,t) -> + let def = pp_type false [] t in + let name = pp_global Term r in + hov 2 (str "val " ++ name ++ str " :" ++ spc () ++ def) + | Stype (r,vl,ot) -> + let name = pp_global Type r in + let l = rename_tvars keywords vl in + let ids, def = + try + let ids, s = find_type_custom r in + pp_string_parameters ids, str "= " ++ str s + with Not_found -> + let ids = pp_parameters l in + match ot with + | None -> ids, mt () + | Some Taxiom -> ids, str "(* AXIOM TO BE REALIZED *)" + | Some t -> ids, str "=" ++ spc () ++ pp_type false l t + in + hov 2 (str "type " ++ ids ++ name ++ spc () ++ def) + +let pp_alias_spec ren = function + | Sind (kn,i) -> pp_mind kn { i with ind_equiv = RenEquiv ren } + | Stype (r,l,_) -> + let name = pp_global Type r in + let l = rename_tvars keywords l in + let ids = pp_parameters l in + hov 2 (str "type " ++ ids ++ name ++ str " =" ++ spc () ++ ids ++ + str (ren^".") ++ name) + | Sval _ -> assert false + +let rec pp_specif = function + | (_,Spec (Sval _ as s)) -> pp_spec s + | (l,Spec s) -> + (try + let ren = Common.check_duplicate (top_visible_mp ()) l in + hov 1 (str ("module "^ren^" : sig ") ++ fnl () ++ pp_spec s) ++ + fnl () ++ str "end" ++ fnl () ++ + pp_alias_spec ren s + with Not_found -> pp_spec s) | (l,Smodule mt) -> - hov 1 - (str "module " ++ - P.pp_module mpl (MPdot (List.hd mpl, l)) ++ - str " : " ++ fnl () ++ pp_module_type mpl None (* (Some l) *) mt) + let def = pp_module_type (Some l) mt in + let def' = pp_module_type (Some l) mt in + let name = pp_modname (MPdot (top_visible_mp (), l)) in + hov 1 (str "module " ++ name ++ str " : " ++ fnl () ++ def) ++ + (try + let ren = Common.check_duplicate (top_visible_mp ()) l in + fnl () ++ hov 1 (str ("module "^ren^" : ") ++ fnl () ++ def') + with Not_found -> Pp.mt ()) | (l,Smodtype mt) -> - hov 1 - (str "module type " ++ - P.pp_module mpl (MPdot (List.hd mpl, l)) ++ - str " = " ++ fnl () ++ pp_module_type mpl None mt) - -and pp_module_type mpl ol = function + let def = pp_module_type None mt in + let name = pp_modname (MPdot (top_visible_mp (), l)) in + hov 1 (str "module type " ++ name ++ str " = " ++ fnl () ++ def) ++ + (try + let ren = Common.check_duplicate (top_visible_mp ()) l in + fnl () ++ str ("module type "^ren^" = ") ++ name + with Not_found -> Pp.mt ()) + +and pp_module_type ol = function | MTident kn -> - let mp,_,l = repr_kn kn in P.pp_module mpl (MPdot (mp,l)) + pp_modname kn | MTfunsig (mbid, mt, mt') -> - str "functor (" ++ - P.pp_module mpl (MPbound mbid) ++ - str ":" ++ - pp_module_type mpl None mt ++ - str ") ->" ++ fnl () ++ - pp_module_type mpl None mt' + let name = pp_modname (MPbound mbid) in + let typ = pp_module_type None mt in + let def = pp_module_type None mt' in + str "functor (" ++ name ++ str ":" ++ typ ++ str ") ->" ++ fnl () ++ def | MTsig (msid, sign) -> - let mpl = match ol, mpl with - | None, _ -> (MPself msid) :: mpl - | Some l, mp :: mpl -> (MPdot (mp,l)) :: mpl - | _ -> assert false - in - let l = map_succeed (pp_specif mpl) sign in + let tvm = top_visible_mp () in + Option.iter (fun l -> add_subst msid (MPdot (tvm, l))) ol; + let mp = MPself msid in + push_visible mp; + let l = map_succeed pp_specif sign in + pop_visible (); str "sig " ++ fnl () ++ v 1 (str " " ++ prlist_with_sep fnl2 identity l) ++ - fnl () ++ str "end" - + fnl () ++ str "end" + | MTwith(mt,ML_With_type(idl,vl,typ)) -> + let l = rename_tvars keywords vl in + let ids = pp_parameters l in + let mp_mt = msid_of_mt mt in + let mp = make_mp_with mp_mt idl in + let gr = ConstRef ( + (make_con mp empty_dirpath + (label_of_id ( + List.hd (List.rev idl))))) in + push_visible mp_mt; + let s = pp_module_type None mt ++ + str " with type " ++ + pp_global Type gr ++ + ids in + pop_visible(); + s ++ str "=" ++ spc () ++ + pp_type false vl typ + | MTwith(mt,ML_With_module(idl,mp)) -> + let mp_mt=msid_of_mt mt in + push_visible mp_mt; + let s = + pp_module_type None mt ++ + str " with module " ++ + (pp_modname + (List.fold_left (fun mp id -> MPdot(mp,label_of_id id)) + mp_mt idl)) + ++ str " = " + in + pop_visible (); + s ++ (pp_modname mp) + + let is_short = function MEident _ | MEapply _ -> true | _ -> false - -let rec pp_structure_elem mpl = function - | (_,SEdecl d) -> pp_decl mpl d + +let rec pp_structure_elem = function + | (l,SEdecl d) -> + (try + let ren = Common.check_duplicate (top_visible_mp ()) l in + hov 1 (str ("module "^ren^" = struct ") ++ fnl () ++ pp_decl d) ++ + fnl () ++ str "end" ++ fnl () ++ + pp_alias_decl ren d + with Not_found -> pp_decl d) | (l,SEmodule m) -> + let def = pp_module_expr (Some l) m.ml_mod_expr in + let name = pp_modname (MPdot (top_visible_mp (), l)) in hov 1 - (str "module " ++ P.pp_module mpl (MPdot (List.hd mpl, l)) ++ - (*i if you want signatures everywhere: i*) - (*i str " :" ++ fnl () ++ i*) - (*i pp_module_type mpl None m.ml_mod_type ++ fnl () ++ i*) - str " = " ++ - (if (is_short m.ml_mod_expr) then mt () else fnl ()) ++ - pp_module_expr mpl (Some l) m.ml_mod_expr) + (str "module " ++ name ++ str " = " ++ + (if (is_short m.ml_mod_expr) then mt () else fnl ()) ++ def) ++ + (try + let ren = Common.check_duplicate (top_visible_mp ()) l in + fnl () ++ str ("module "^ren^" = ") ++ name + with Not_found -> mt ()) | (l,SEmodtype m) -> - hov 1 - (str "module type " ++ P.pp_module mpl (MPdot (List.hd mpl, l)) ++ - str " = " ++ fnl () ++ pp_module_type mpl None m) - -and pp_module_expr mpl ol = function - | MEident mp' -> P.pp_module mpl mp' + let def = pp_module_type None m in + let name = pp_modname (MPdot (top_visible_mp (), l)) in + hov 1 (str "module type " ++ name ++ str " = " ++ fnl () ++ def) ++ + (try + let ren = Common.check_duplicate (top_visible_mp ()) l in + fnl () ++ str ("module type "^ren^" = ") ++ name + with Not_found -> mt ()) + +and pp_module_expr ol = function + | MEident mp' -> pp_modname mp' | MEfunctor (mbid, mt, me) -> - str "functor (" ++ - P.pp_module mpl (MPbound mbid) ++ - str ":" ++ - pp_module_type mpl None mt ++ - str ") ->" ++ fnl () ++ - pp_module_expr mpl None me + let name = pp_modname (MPbound mbid) in + let typ = pp_module_type None mt in + let def = pp_module_expr None me in + str "functor (" ++ name ++ str ":" ++ typ ++ str ") ->" ++ fnl () ++ def | MEapply (me, me') -> - pp_module_expr mpl None me ++ str "(" ++ - pp_module_expr mpl None me' ++ str ")" + pp_module_expr None me ++ str "(" ++ pp_module_expr None me' ++ str ")" | MEstruct (msid, sel) -> - let mpl = match ol, mpl with - | None, _ -> (MPself msid) :: mpl - | Some l, mp :: mpl -> (MPdot (mp,l)) :: mpl - | _ -> assert false - in - let l = map_succeed (pp_structure_elem mpl) sel in + let tvm = top_visible_mp () in + let mp = match ol with None -> MPself msid | Some l -> MPdot (tvm,l) in + push_visible mp; + let l = map_succeed pp_structure_elem sel in + pop_visible (); str "struct " ++ fnl () ++ v 1 (str " " ++ prlist_with_sep fnl2 identity l) ++ fnl () ++ str "end" let pp_struct s = - let pp mp s = pp_structure_elem [mp] s ++ fnl2 () in - prlist (fun (mp,sel) -> prlist identity (map_succeed (pp mp) sel)) s + let pp mp s = + push_visible mp; + let p = pp_structure_elem s ++ fnl2 () in + pop_visible (); p + in + prlist_strict + (fun (mp,sel) -> prlist_strict identity (map_succeed (pp mp) sel)) s let pp_signature s = - let pp mp s = pp_specif [mp] s ++ fnl2 () in - prlist (fun (mp,sign) -> prlist identity (map_succeed (pp mp) sign)) s - -let pp_decl mpl d = - try pp_decl mpl d with Failure "empty phrase" -> mt () - -end - + let pp mp s = + push_visible mp; + let p = pp_specif s ++ fnl2 () in + pop_visible (); p + in + prlist_strict + (fun (mp,sign) -> prlist_strict identity (map_succeed (pp mp) sign)) s + +let pp_decl d = + try pp_decl d with Failure "empty phrase" -> mt () + +let ocaml_descr = { + keywords = keywords; + file_suffix = ".ml"; + capital_file = false; + preamble = preamble; + pp_struct = pp_struct; + sig_suffix = Some ".mli"; + sig_preamble = sig_preamble; + pp_sig = pp_signature; + pp_decl = pp_decl; +} diff --git a/contrib/extraction/ocaml.mli b/contrib/extraction/ocaml.mli index 8c521ccd..3d90e74c 100644 --- a/contrib/extraction/ocaml.mli +++ b/contrib/extraction/ocaml.mli @@ -6,49 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: ocaml.mli 7632 2005-12-01 14:35:21Z letouzey $ i*) - -(*s Some utility functions to be reused in module [Haskell]. *) - -open Pp -open Names -open Libnames -open Miniml - -val pp_par : bool -> std_ppcmds -> std_ppcmds -val pp_abst : identifier list -> std_ppcmds -val pp_apply : std_ppcmds -> bool -> std_ppcmds list -> std_ppcmds -val pr_binding : identifier list -> std_ppcmds - -val rename_id : identifier -> Idset.t -> identifier - -val lowercase_id : identifier -> identifier -val uppercase_id : identifier -> identifier - -val pr_upper_id : identifier -> std_ppcmds - -type env = identifier list * Idset.t - -val rename_vars: Idset.t -> identifier list -> env -val rename_tvars: Idset.t -> identifier list -> identifier list -val push_vars : identifier list -> env -> identifier list * env -val get_db_name : int -> env -> identifier - -val keywords : Idset.t - -val preamble : - extraction_params -> module_path list -> bool*bool*bool -> bool -> std_ppcmds - -val preamble_sig : - extraction_params -> module_path list -> bool*bool*bool -> std_ppcmds - -(*s Production of Ocaml syntax. We export both a functor to be used for - extraction in the Coq toplevel and a function to extract some - declarations to a file. *) - -module Make : functor(P : Mlpp_param) -> Mlpp - - - +(*i $Id: ocaml.mli 10232 2007-10-17 12:32:10Z letouzey $ i*) +val ocaml_descr : Miniml.language_descr diff --git a/contrib/extraction/scheme.ml b/contrib/extraction/scheme.ml index 7004a202..600f64db 100644 --- a/contrib/extraction/scheme.ml +++ b/contrib/extraction/scheme.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: scheme.ml 7651 2005-12-16 03:19:20Z letouzey $ i*) +(*i $Id: scheme.ml 10233 2007-10-17 23:29:08Z letouzey $ i*) (*s Production of Scheme syntax. *) @@ -18,7 +18,7 @@ open Libnames open Miniml open Mlutil open Table -open Ocaml +open Common (*s Scheme renaming issues. *) @@ -29,17 +29,11 @@ let keywords = "error"; "delay"; "force"; "_"; "__"] Idset.empty -let preamble _ _ (mldummy,_,_) _ = - str ";; This extracted scheme code relies on some additional macros" ++ - fnl () ++ - str ";; available at http://www.pps.jussieu.fr/~letouzey/scheme" ++ - fnl () ++ - str "(load \"macros_extr.scm\")" ++ - fnl () ++ fnl () ++ - (if mldummy then - str "(define __ (lambda (_) __))" - ++ fnl () ++ fnl() - else mt ()) +let preamble _ _ usf = + str ";; This extracted scheme code relies on some additional macros\n" ++ + str ";; available at http://www.pps.jussieu.fr/~letouzey/scheme\n" ++ + str "(load \"macros_extr.scm\")\n\n" ++ + (if usf.mldummy then str "(define __ (lambda (_) __))\n\n" else mt ()) let pr_id id = let s = string_of_id id in @@ -60,14 +54,11 @@ let pp_apply st _ = function | [] -> st | [a] -> hov 2 (paren (st ++ spc () ++ a)) | args -> hov 2 (paren (str "@ " ++ st ++ - (prlist (fun x -> spc () ++ x) args))) + (prlist_strict (fun x -> spc () ++ x) args))) -(*s The pretty-printing functor. *) +(*s The pretty-printer for Scheme syntax *) -module Make = functor(P : Mlpp_param) -> struct - -let pp_global r = P.pp_global [initial_path] r -let empty_env () = [], P.globals() +let pp_global k r = str (Common.pp_global k r) (*s Pretty-printing of expressions. *) @@ -95,17 +86,17 @@ let rec pp_expr env args = (pr_id (List.hd i) ++ spc () ++ pp_expr env [] a1)) ++ spc () ++ hov 0 (pp_expr env' [] a2))))) | MLglob r -> - apply (pp_global r) + apply (pp_global Term r) | MLcons (i,r,args') -> assert (args=[]); let st = str "`" ++ - paren (pp_global r ++ + paren (pp_global Cons r ++ (if args' = [] then mt () else spc ()) ++ prlist_with_sep spc (pp_cons_args env) args') in if i = Coinductive then paren (str "delay " ++ st) else st - | MLcase (i,t, pv) -> + | MLcase ((i,_),t, pv) -> let e = if i <> Coinductive then pp_expr env [] t else paren (str "force" ++ spc () ++ pp_expr env [] t) @@ -125,7 +116,7 @@ let rec pp_expr env args = and pp_cons_args env = function | MLcons (i,r,args) when i<>Coinductive -> - paren (pp_global r ++ + paren (pp_global Cons r ++ (if args = [] then mt () else spc ()) ++ prlist_with_sep spc (pp_cons_args env) args) | e -> str "," ++ pp_expr env [] e @@ -137,7 +128,7 @@ and pp_one_pat env (r,ids,t) = if ids = [] then mt () else (str " " ++ prlist_with_sep spc pr_id (List.rev ids)) in - (pp_global r ++ args), (pp_expr env' [] t) + (pp_global Cons r ++ args), (pp_expr env' [] t) and pp_pat env pv = prvect_with_sep fnl @@ -160,11 +151,11 @@ and pp_fix env j (ids,bl) args = (*s Pretty-printing of a declaration. *) -let pp_decl _ = function +let pp_decl = function | Dind _ -> mt () | Dtype _ -> mt () | Dfix (rv, defs,_) -> - let ppv = Array.map pp_global rv in + let ppv = Array.map (pp_global Term) rv in prvect_with_sep fnl (fun (pi,ti) -> hov 2 @@ -177,23 +168,35 @@ let pp_decl _ = function if is_inline_custom r then mt () else if is_custom r then - hov 2 (paren (str "define " ++ pp_global r ++ spc () ++ + hov 2 (paren (str "define " ++ pp_global Term r ++ spc () ++ str (find_custom r))) ++ fnl () ++ fnl () else - hov 2 (paren (str "define " ++ pp_global r ++ spc () ++ + hov 2 (paren (str "define " ++ pp_global Term r ++ spc () ++ pp_expr (empty_env ()) [] a)) ++ fnl () ++ fnl () -let pp_structure_elem mp = function - | (l,SEdecl d) -> pp_decl mp d +let pp_structure_elem = function + | (l,SEdecl d) -> pp_decl d | (l,SEmodule m) -> failwith "TODO: Scheme extraction of modules not implemented yet" | (l,SEmodtype m) -> failwith "TODO: Scheme extraction of modules not implemented yet" let pp_struct = - prlist (fun (mp,sel) -> prlist (pp_structure_elem mp) sel) - -let pp_signature s = assert false - -end - + let pp_sel (mp,sel) = + push_visible mp; + let p = prlist_strict pp_structure_elem sel in + pop_visible (); p + in + prlist_strict pp_sel + +let scheme_descr = { + keywords = keywords; + file_suffix = ".scm"; + capital_file = false; + preamble = preamble; + pp_struct = pp_struct; + sig_suffix = None; + sig_preamble = (fun _ _ _ -> mt ()); + pp_sig = (fun _ -> mt ()); + pp_decl = pp_decl; +} diff --git a/contrib/extraction/scheme.mli b/contrib/extraction/scheme.mli index ef4a3a63..a88bb6db 100644 --- a/contrib/extraction/scheme.mli +++ b/contrib/extraction/scheme.mli @@ -6,22 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: scheme.mli 7632 2005-12-01 14:35:21Z letouzey $ i*) - -(*s Some utility functions to be reused in module [Haskell]. *) - -open Pp -open Miniml -open Names - -val keywords : Idset.t - -val preamble : - extraction_params -> module_path list -> bool*bool*bool -> bool -> std_ppcmds - -module Make : functor(P : Mlpp_param) -> Mlpp - - - - +(*i $Id: scheme.mli 10232 2007-10-17 12:32:10Z letouzey $ i*) +val scheme_descr : Miniml.language_descr diff --git a/contrib/extraction/table.ml b/contrib/extraction/table.ml index 6d39faee..abf461c1 100644 --- a/contrib/extraction/table.ml +++ b/contrib/extraction/table.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: table.ml 10209 2007-10-09 21:49:37Z letouzey $ i*) +(*i $Id: table.ml 10348 2007-12-06 17:36:14Z aspiwack $ i*) open Names open Term @@ -20,37 +20,49 @@ open Util open Pp open Miniml -(*S Utilities concerning [module_path] and [kernel_names] *) +(*S Utilities about [module_path] and [kernel_names] and [global_reference] *) -let occur_kn_in_ref kn = - function +let occur_kn_in_ref kn = function | IndRef (kn',_) | ConstructRef ((kn',_),_) -> kn = kn' | ConstRef _ -> false | VarRef _ -> assert false - -let modpath_of_r r = match r with - | ConstRef kn -> con_modpath kn - | IndRef (kn,_) - | ConstructRef ((kn,_),_) -> modpath kn - | VarRef _ -> assert false - -let label_of_r r = match r with - | ConstRef kn -> con_label kn - | IndRef (kn,_) - | ConstructRef ((kn,_),_) -> label kn - | VarRef _ -> assert false - -let current_toplevel () = fst (Lib.current_prefix ()) + +let modpath_of_r = function + | ConstRef kn -> con_modpath kn + | IndRef (kn,_) + | ConstructRef ((kn,_),_) -> modpath kn + | VarRef _ -> assert false + +let label_of_r = function + | ConstRef kn -> con_label kn + | IndRef (kn,_) + | ConstructRef ((kn,_),_) -> label kn + | VarRef _ -> assert false let rec base_mp = function | MPdot (mp,l) -> base_mp mp | mp -> mp +let rec mp_length = function + | MPdot (mp, _) -> 1 + (mp_length mp) + | _ -> 1 + let is_modfile = function | MPfile _ -> true | _ -> false +let string_of_modfile = function + | MPfile f -> String.capitalize (string_of_id (List.hd (repr_dirpath f))) + | _ -> assert false + +let rec modfile_of_mp = function + | (MPfile _) as mp -> mp + | MPdot (mp,_) -> modfile_of_mp mp + | _ -> raise Not_found + +let current_toplevel () = fst (Lib.current_prefix ()) + let is_toplevel mp = mp = initial_path || mp = current_toplevel () @@ -60,8 +72,56 @@ let at_toplevel mp = let visible_kn kn = at_toplevel (base_mp (modpath kn)) let visible_con kn = at_toplevel (base_mp (con_modpath kn)) +let rec prefixes_mp mp = match mp with + | MPdot (mp',_) -> MPset.add mp (prefixes_mp mp') + | _ -> MPset.singleton mp + +let rec get_nth_label_mp n mp = match mp with + | MPdot (mp,l) -> if n=1 then l else get_nth_label_mp (n-1) mp + | _ -> failwith "get_nth_label: not enough MPdot" + +let get_nth_label n r = + if n=0 then label_of_r r else get_nth_label_mp n (modpath_of_r r) + +let rec common_prefix prefixes_mp1 mp2 = + if MPset.mem mp2 prefixes_mp1 then mp2 + else match mp2 with + | MPdot (mp,_) -> common_prefix prefixes_mp1 mp + | _ -> raise Not_found + +let common_prefix_from_list mp0 mpl = + let prefixes_mp0 = prefixes_mp mp0 in + let rec f = function + | [] -> raise Not_found + | mp1 :: l -> try common_prefix prefixes_mp0 mp1 with Not_found -> f l + in f mpl + +let rec parse_labels ll = function + | MPdot (mp,l) -> parse_labels (l::ll) mp + | mp -> mp,ll + +let labels_of_mp mp = parse_labels [] mp + +let labels_of_ref r = + let mp,_,l = + match r with + ConstRef con -> repr_con con + | IndRef (kn,_) + | ConstructRef ((kn,_),_) -> repr_kn kn + | VarRef _ -> assert false + in + parse_labels [l] mp + +let rec add_labels_mp mp = function + | [] -> mp + | l :: ll -> add_labels_mp (MPdot (mp,l)) ll + + (*S The main tables: constants, inductives, records, ... *) +(* Theses tables are not registered within coq save/undo mechanism + since we reset their contents at each run of Extraction *) + (*s Constants tables. *) let terms = ref (Cmap.empty : ml_decl Cmap.t) @@ -109,11 +169,26 @@ let add_projection n kn = projs := Refmap.add (ConstRef kn) n !projs let is_projection r = Refmap.mem r !projs let projection_arity r = Refmap.find r !projs +(*s Table of used axioms *) + +let info_axioms = ref Refset.empty +let log_axioms = ref Refset.empty +let init_axioms () = info_axioms := Refset.empty; log_axioms := Refset.empty +let add_info_axiom r = info_axioms := Refset.add r !info_axioms +let add_log_axiom r = log_axioms := Refset.add r !log_axioms + +(*s Extraction mode: modular or monolithic *) + +let modular_ref = ref false + +let set_modular b = modular_ref := b +let modular () = !modular_ref + (*s Tables synchronization. *) let reset_tables () = init_terms (); init_types (); init_inductives (); init_recursors (); - init_projs () + init_projs (); init_axioms () (*s Printing. *) @@ -146,21 +221,34 @@ let pr_long_global r = let err s = errorlabstrm "Extraction" s +let warning_axioms () = + let info_axioms = Refset.elements !info_axioms in + if info_axioms = [] then () + else begin + let s = if List.length info_axioms = 1 then "axiom" else "axioms" in + msg_warning + (str ("The following "^s^" must be realized in the extracted code:") + ++ hov 1 (spc () ++ prlist_with_sep spc pr_global info_axioms) + ++ str "." ++ fnl ()) + end; + let log_axioms = Refset.elements !log_axioms in + if log_axioms = [] then () + else begin + let s = if List.length log_axioms = 1 then "axiom was" else "axioms were" + in + msg_warning + (str ("The following logical "^s^" encountered:") ++ + hov 1 (spc () ++ prlist_with_sep spc pr_global log_axioms ++ str ".\n") ++ + str "Having invalid logical axiom in the environment when extracting" ++ + spc () ++ str "may lead to incorrect or non-terminating ML terms." ++ + fnl ()) + end + let error_axiom_scheme r i = err (str "The type scheme axiom " ++ spc () ++ pr_global r ++ spc () ++ str "needs " ++ pr_int i ++ str " type variable(s).") -let warning_info_ax r = - msg_warning (str "You must realize axiom " ++ - pr_global r ++ str " in the extracted code.") - -let warning_log_ax r = - msg_warning (str "This extraction depends on logical axiom" ++ spc () ++ - pr_global r ++ str "." ++ spc() ++ - str "Having false logical axiom in the environment when extracting" ++ - spc () ++ str "may lead to incorrect or non-terminating ML terms.") - let check_inside_module () = if Lib.is_modtype () then err (str "You can't do that within a Module Type." ++ fnl () ++ @@ -186,15 +274,11 @@ let error_nb_cons () = let error_module_clash s = err (str ("There are two Coq modules with ML name " ^ s ^".\n") ++ - str "This is not allowed in ML. Please do some renaming first.") + str "This is not supported yet. Please do some renaming first.") let error_unknown_module m = err (str "Module" ++ spc () ++ pr_qualid m ++ spc () ++ str "not found.") -let error_toplevel () = - err (str "Toplevel pseudo-ML language can be used only at Coq toplevel.\n" ++ - str "You should use Extraction Language Ocaml or Haskell before.") - let error_scheme () = err (str "No Scheme modular extraction available yet.") @@ -203,9 +287,13 @@ let error_not_visible r = str "For example, it may be inside an applied functor." ++ str "Use Recursive Extraction to get the whole environment.") -let error_MPfile_as_mod d = - err (str ("The whole file "^(string_of_dirpath d)^".v is used somewhere as a module.\n"^ - "Extraction cannot currently deal with this situation.\n")) +let error_MPfile_as_mod mp b = + let s1 = if b then "asked" else "required" in + let s2 = if b then "extract some objects of this module or\n" else "" in + err (str ("Extraction of file "^(string_of_modfile mp)^ + ".v as a module is "^s1^".\n"^ + "Monolithic Extraction cannot deal with this situation.\n"^ + "Please "^s2^"use (Recursive) Extraction Library instead.\n")) let error_record r = err (str "Record " ++ pr_global r ++ str " has an anonymous field." ++ fnl () ++ @@ -216,8 +304,16 @@ let check_loaded_modfile mp = match base_mp mp with err (str ("Please load library "^(string_of_dirpath dp^" first."))) | _ -> () +let info_file f = + Flags.if_verbose message + ("The file "^f^" has been created by extraction.") + + (*S The Extraction auxiliary commands *) +(* The objects defined below should survive an arbitrary time, + so we register them to coq save/undo mechanism. *) + (*s Extraction AutoInline *) let auto_inline_ref = ref true @@ -305,7 +401,7 @@ let _ = declare_int_option (*s Extraction Lang *) -type lang = Ocaml | Haskell | Scheme | Toplevel +type lang = Ocaml | Haskell | Scheme let lang_ref = ref Ocaml @@ -327,7 +423,6 @@ let _ = declare_summary "Extraction Lang" let extraction_language x = Lib.add_anonymous_leaf (extr_lang x) - (*s Extraction Inline/NoInline *) let empty_inline_table = (Refset.empty,Refset.empty) diff --git a/contrib/extraction/table.mli b/contrib/extraction/table.mli index c9a4e8da..ca02cb4d 100644 --- a/contrib/extraction/table.mli +++ b/contrib/extraction/table.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: table.mli 10209 2007-10-09 21:49:37Z letouzey $ i*) +(*i $Id: table.mli 10245 2007-10-21 13:41:53Z letouzey $ i*) open Names open Libnames @@ -14,39 +14,49 @@ open Miniml open Declarations val id_of_global : global_reference -> identifier +val pr_long_global : global_reference -> Pp.std_ppcmds + (*s Warning and Error messages. *) +val warning_axioms : unit -> unit val error_axiom_scheme : global_reference -> int -> 'a -val warning_info_ax : global_reference -> unit -val warning_log_ax : global_reference -> unit val error_constant : global_reference -> 'a val error_inductive : global_reference -> 'a val error_nb_cons : unit -> 'a val error_module_clash : string -> 'a val error_unknown_module : qualid -> 'a -val error_toplevel : unit -> 'a val error_scheme : unit -> 'a val error_not_visible : global_reference -> 'a -val error_MPfile_as_mod : dir_path -> 'a +val error_MPfile_as_mod : module_path -> bool -> 'a val error_record : global_reference -> 'a val check_inside_module : unit -> unit val check_inside_section : unit -> unit val check_loaded_modfile : module_path -> unit -(*s utilities concerning [module_path]. *) +val info_file : string -> unit + +(*s utilities about [module_path] and [kernel_names] and [global_reference] *) val occur_kn_in_ref : kernel_name -> global_reference -> bool val modpath_of_r : global_reference -> module_path val label_of_r : global_reference -> label - val current_toplevel : unit -> module_path val base_mp : module_path -> module_path -val is_modfile : module_path -> bool +val is_modfile : module_path -> bool +val string_of_modfile : module_path -> string val is_toplevel : module_path -> bool val at_toplevel : module_path -> bool val visible_kn : kernel_name -> bool val visible_con : constant -> bool +val mp_length : module_path -> int +val prefixes_mp : module_path -> MPset.t +val modfile_of_mp : module_path -> module_path +val common_prefix_from_list : module_path -> module_path list -> module_path +val add_labels_mp : module_path -> label list -> module_path +val get_nth_label_mp : int -> module_path -> label +val get_nth_label : int -> global_reference -> label +val labels_of_ref : global_reference -> module_path * label list (*s Some table-related operations *) @@ -66,6 +76,9 @@ val add_projection : int -> constant -> unit val is_projection : global_reference -> bool val projection_arity : global_reference -> int +val add_info_axiom : global_reference -> unit +val add_log_axiom : global_reference -> unit + val reset_tables : unit -> unit (*s AutoInline parameter *) @@ -95,9 +108,14 @@ val optims : unit -> opt_flag (*s Target language. *) -type lang = Ocaml | Haskell | Scheme | Toplevel +type lang = Ocaml | Haskell | Scheme val lang : unit -> lang +(*s Extraction mode: modular or monolithic *) + +val set_modular : bool -> unit +val modular : unit -> bool + (*s Table for custom inlining *) val to_inline : global_reference -> bool diff --git a/contrib/extraction/test/.depend b/contrib/extraction/test/.depend deleted file mode 100644 index 31d46eeb..00000000 --- a/contrib/extraction/test/.depend +++ /dev/null @@ -1,1136 +0,0 @@ -theories/Arith/arith.cmo: theories/Arith/arith.cmi -theories/Arith/arith.cmx: theories/Arith/arith.cmi -theories/Arith/between.cmo: theories/Arith/between.cmi -theories/Arith/between.cmx: theories/Arith/between.cmi -theories/Arith/bool_nat.cmo: theories/Bool/sumbool.cmi \ - theories/Init/specif.cmi theories/Arith/peano_dec.cmi \ - theories/Init/datatypes.cmi theories/Arith/compare_dec.cmi \ - theories/Arith/bool_nat.cmi -theories/Arith/bool_nat.cmx: theories/Bool/sumbool.cmx \ - theories/Init/specif.cmx theories/Arith/peano_dec.cmx \ - theories/Init/datatypes.cmx theories/Arith/compare_dec.cmx \ - theories/Arith/bool_nat.cmi -theories/Arith/compare_dec.cmo: theories/Init/specif.cmi \ - theories/Init/datatypes.cmi theories/Arith/compare_dec.cmi -theories/Arith/compare_dec.cmx: theories/Init/specif.cmx \ - theories/Init/datatypes.cmx theories/Arith/compare_dec.cmi -theories/Arith/compare.cmo: theories/Init/specif.cmi \ - theories/Init/datatypes.cmi theories/Arith/compare_dec.cmi \ - theories/Arith/compare.cmi -theories/Arith/compare.cmx: theories/Init/specif.cmx \ - theories/Init/datatypes.cmx theories/Arith/compare_dec.cmx \ - theories/Arith/compare.cmi -theories/Arith/div2.cmo: theories/Init/specif.cmi theories/Init/peano.cmi \ - theories/Init/datatypes.cmi theories/Arith/div2.cmi -theories/Arith/div2.cmx: theories/Init/specif.cmx theories/Init/peano.cmx \ - theories/Init/datatypes.cmx theories/Arith/div2.cmi -theories/Arith/eqNat.cmo: theories/Init/specif.cmi \ - theories/Init/datatypes.cmi theories/Arith/eqNat.cmi -theories/Arith/eqNat.cmx: theories/Init/specif.cmx \ - theories/Init/datatypes.cmx theories/Arith/eqNat.cmi -theories/Arith/euclid.cmo: theories/Init/specif.cmi theories/Init/peano.cmi \ - theories/Init/datatypes.cmi theories/Arith/compare_dec.cmi \ - theories/Arith/euclid.cmi -theories/Arith/euclid.cmx: theories/Init/specif.cmx theories/Init/peano.cmx \ - theories/Init/datatypes.cmx theories/Arith/compare_dec.cmx \ - theories/Arith/euclid.cmi -theories/Arith/even.cmo: theories/Init/specif.cmi theories/Init/datatypes.cmi \ - theories/Arith/even.cmi -theories/Arith/even.cmx: theories/Init/specif.cmx theories/Init/datatypes.cmx \ - theories/Arith/even.cmi -theories/Arith/factorial.cmo: theories/Init/peano.cmi \ - theories/Init/datatypes.cmi theories/Arith/factorial.cmi -theories/Arith/factorial.cmx: theories/Init/peano.cmx \ - theories/Init/datatypes.cmx theories/Arith/factorial.cmi -theories/Arith/gt.cmo: theories/Arith/gt.cmi -theories/Arith/gt.cmx: theories/Arith/gt.cmi -theories/Arith/le.cmo: theories/Arith/le.cmi -theories/Arith/le.cmx: theories/Arith/le.cmi -theories/Arith/lt.cmo: theories/Arith/lt.cmi -theories/Arith/lt.cmx: theories/Arith/lt.cmi -theories/Arith/max.cmo: theories/Init/specif.cmi theories/Init/datatypes.cmi \ - theories/Arith/max.cmi -theories/Arith/max.cmx: theories/Init/specif.cmx theories/Init/datatypes.cmx \ - theories/Arith/max.cmi -theories/Arith/min.cmo: theories/Init/specif.cmi theories/Init/datatypes.cmi \ - theories/Arith/min.cmi -theories/Arith/min.cmx: theories/Init/specif.cmx theories/Init/datatypes.cmx \ - theories/Arith/min.cmi -theories/Arith/minus.cmo: theories/Arith/minus.cmi -theories/Arith/minus.cmx: theories/Arith/minus.cmi -theories/Arith/mult.cmo: theories/Arith/plus.cmi theories/Init/datatypes.cmi \ - theories/Arith/mult.cmi -theories/Arith/mult.cmx: theories/Arith/plus.cmx theories/Init/datatypes.cmx \ - theories/Arith/mult.cmi -theories/Arith/peano_dec.cmo: theories/Init/specif.cmi \ - theories/Init/datatypes.cmi theories/Arith/peano_dec.cmi -theories/Arith/peano_dec.cmx: theories/Init/specif.cmx \ - theories/Init/datatypes.cmx theories/Arith/peano_dec.cmi -theories/Arith/plus.cmo: theories/Init/specif.cmi theories/Init/datatypes.cmi \ - theories/Arith/plus.cmi -theories/Arith/plus.cmx: theories/Init/specif.cmx theories/Init/datatypes.cmx \ - theories/Arith/plus.cmi -theories/Arith/wf_nat.cmo: theories/Init/datatypes.cmi \ - theories/Arith/wf_nat.cmi -theories/Arith/wf_nat.cmx: theories/Init/datatypes.cmx \ - theories/Arith/wf_nat.cmi -theories/Bool/boolEq.cmo: theories/Init/specif.cmi \ - theories/Init/datatypes.cmi theories/Bool/boolEq.cmi -theories/Bool/boolEq.cmx: theories/Init/specif.cmx \ - theories/Init/datatypes.cmx theories/Bool/boolEq.cmi -theories/Bool/bool.cmo: theories/Init/specif.cmi theories/Init/datatypes.cmi \ - theories/Bool/bool.cmi -theories/Bool/bool.cmx: theories/Init/specif.cmx theories/Init/datatypes.cmx \ - theories/Bool/bool.cmi -theories/Bool/bvector.cmo: theories/Init/peano.cmi \ - theories/Init/datatypes.cmi theories/Bool/bool.cmi \ - theories/Bool/bvector.cmi -theories/Bool/bvector.cmx: theories/Init/peano.cmx \ - theories/Init/datatypes.cmx theories/Bool/bool.cmx \ - theories/Bool/bvector.cmi -theories/Bool/decBool.cmo: theories/Init/specif.cmi theories/Bool/decBool.cmi -theories/Bool/decBool.cmx: theories/Init/specif.cmx theories/Bool/decBool.cmi -theories/Bool/ifProp.cmo: theories/Init/specif.cmi \ - theories/Init/datatypes.cmi theories/Bool/ifProp.cmi -theories/Bool/ifProp.cmx: theories/Init/specif.cmx \ - theories/Init/datatypes.cmx theories/Bool/ifProp.cmi -theories/Bool/sumbool.cmo: theories/Init/specif.cmi \ - theories/Init/datatypes.cmi theories/Bool/sumbool.cmi -theories/Bool/sumbool.cmx: theories/Init/specif.cmx \ - theories/Init/datatypes.cmx theories/Bool/sumbool.cmi -theories/Bool/zerob.cmo: theories/Init/datatypes.cmi theories/Bool/zerob.cmi -theories/Bool/zerob.cmx: theories/Init/datatypes.cmx theories/Bool/zerob.cmi -theories/FSets/decidableTypeEx.cmo: theories/Init/specif.cmi \ - theories/FSets/orderedTypeEx.cmi theories/FSets/orderedType.cmi \ - theories/Init/datatypes.cmi theories/FSets/decidableTypeEx.cmi -theories/FSets/decidableTypeEx.cmx: theories/Init/specif.cmx \ - theories/FSets/orderedTypeEx.cmx theories/FSets/orderedType.cmx \ - theories/Init/datatypes.cmx theories/FSets/decidableTypeEx.cmi -theories/FSets/decidableType.cmo: theories/Init/specif.cmi \ - theories/FSets/decidableType.cmi -theories/FSets/decidableType.cmx: theories/Init/specif.cmx \ - theories/FSets/decidableType.cmi -theories/FSets/fMapAVL.cmo: theories/Init/wf.cmi theories/Init/specif.cmi \ - theories/FSets/orderedType.cmi theories/Lists/list.cmi \ - theories/FSets/int.cmi theories/FSets/fMapList.cmi \ - theories/Init/datatypes.cmi theories/NArith/binPos.cmi \ - theories/ZArith/binInt.cmi theories/FSets/fMapAVL.cmi -theories/FSets/fMapAVL.cmx: theories/Init/wf.cmx theories/Init/specif.cmx \ - theories/FSets/orderedType.cmx theories/Lists/list.cmx \ - theories/FSets/int.cmx theories/FSets/fMapList.cmx \ - theories/Init/datatypes.cmx theories/NArith/binPos.cmx \ - theories/ZArith/binInt.cmx theories/FSets/fMapAVL.cmi -theories/FSets/fMapFacts.cmo: theories/Init/specif.cmi \ - theories/FSets/orderedType.cmi theories/FSets/fMapInterface.cmi \ - theories/Init/datatypes.cmi theories/FSets/fMapFacts.cmi -theories/FSets/fMapFacts.cmx: theories/Init/specif.cmx \ - theories/FSets/orderedType.cmx theories/FSets/fMapInterface.cmx \ - theories/Init/datatypes.cmx theories/FSets/fMapFacts.cmi -theories/FSets/fMapInterface.cmo: theories/FSets/orderedType.cmi \ - theories/Lists/list.cmi theories/Init/datatypes.cmi \ - theories/FSets/fMapInterface.cmi -theories/FSets/fMapInterface.cmx: theories/FSets/orderedType.cmx \ - theories/Lists/list.cmx theories/Init/datatypes.cmx \ - theories/FSets/fMapInterface.cmi -theories/FSets/fMapIntMap.cmo: theories/Init/specif.cmi \ - theories/FSets/orderedType.cmi theories/NArith/ndigits.cmi \ - theories/IntMap/mapiter.cmi theories/IntMap/mapcanon.cmi \ - theories/IntMap/map.cmi theories/Lists/list.cmi \ - theories/FSets/fMapList.cmi theories/Init/datatypes.cmi \ - theories/NArith/binNat.cmi theories/FSets/fMapIntMap.cmi -theories/FSets/fMapIntMap.cmx: theories/Init/specif.cmx \ - theories/FSets/orderedType.cmx theories/NArith/ndigits.cmx \ - theories/IntMap/mapiter.cmx theories/IntMap/mapcanon.cmx \ - theories/IntMap/map.cmx theories/Lists/list.cmx \ - theories/FSets/fMapList.cmx theories/Init/datatypes.cmx \ - theories/NArith/binNat.cmx theories/FSets/fMapIntMap.cmi -theories/FSets/fMapList.cmo: theories/Init/specif.cmi \ - theories/FSets/orderedType.cmi theories/Lists/list.cmi \ - theories/Init/datatypes.cmi theories/FSets/fMapList.cmi -theories/FSets/fMapList.cmx: theories/Init/specif.cmx \ - theories/FSets/orderedType.cmx theories/Lists/list.cmx \ - theories/Init/datatypes.cmx theories/FSets/fMapList.cmi -theories/FSets/fMapPositive.cmo: theories/Init/specif.cmi \ - theories/FSets/orderedType.cmi theories/Lists/list.cmi \ - theories/Init/datatypes.cmi theories/NArith/binPos.cmi \ - theories/FSets/fMapPositive.cmi -theories/FSets/fMapPositive.cmx: theories/Init/specif.cmx \ - theories/FSets/orderedType.cmx theories/Lists/list.cmx \ - theories/Init/datatypes.cmx theories/NArith/binPos.cmx \ - theories/FSets/fMapPositive.cmi -theories/FSets/fMaps.cmo: theories/FSets/fMaps.cmi -theories/FSets/fMaps.cmx: theories/FSets/fMaps.cmi -theories/FSets/fMapWeakFacts.cmo: theories/Init/specif.cmi \ - theories/Lists/list.cmi theories/FSets/fMapWeakInterface.cmi \ - theories/Init/datatypes.cmi theories/FSets/fMapWeakFacts.cmi -theories/FSets/fMapWeakFacts.cmx: theories/Init/specif.cmx \ - theories/Lists/list.cmx theories/FSets/fMapWeakInterface.cmx \ - theories/Init/datatypes.cmx theories/FSets/fMapWeakFacts.cmi -theories/FSets/fMapWeakInterface.cmo: theories/Lists/list.cmi \ - theories/FSets/decidableType.cmi theories/Init/datatypes.cmi \ - theories/FSets/fMapWeakInterface.cmi -theories/FSets/fMapWeakInterface.cmx: theories/Lists/list.cmx \ - theories/FSets/decidableType.cmx theories/Init/datatypes.cmx \ - theories/FSets/fMapWeakInterface.cmi -theories/FSets/fMapWeakList.cmo: theories/Init/specif.cmi \ - theories/Lists/list.cmi theories/FSets/decidableType.cmi \ - theories/Init/datatypes.cmi theories/FSets/fMapWeakList.cmi -theories/FSets/fMapWeakList.cmx: theories/Init/specif.cmx \ - theories/Lists/list.cmx theories/FSets/decidableType.cmx \ - theories/Init/datatypes.cmx theories/FSets/fMapWeakList.cmi -theories/FSets/fMapWeak.cmo: theories/FSets/fMapWeak.cmi -theories/FSets/fMapWeak.cmx: theories/FSets/fMapWeak.cmi -theories/FSets/fSetAVL.cmo: theories/Init/wf.cmi theories/Init/specif.cmi \ - theories/Init/peano.cmi theories/FSets/orderedType.cmi \ - theories/Lists/list.cmi theories/FSets/int.cmi \ - theories/FSets/fSetList.cmi theories/Init/datatypes.cmi \ - theories/NArith/binPos.cmi theories/ZArith/binInt.cmi \ - theories/FSets/fSetAVL.cmi -theories/FSets/fSetAVL.cmx: theories/Init/wf.cmx theories/Init/specif.cmx \ - theories/Init/peano.cmx theories/FSets/orderedType.cmx \ - theories/Lists/list.cmx theories/FSets/int.cmx \ - theories/FSets/fSetList.cmx theories/Init/datatypes.cmx \ - theories/NArith/binPos.cmx theories/ZArith/binInt.cmx \ - theories/FSets/fSetAVL.cmi -theories/FSets/fSetBridge.cmo: theories/Init/specif.cmi \ - theories/FSets/orderedType.cmi theories/Lists/list.cmi \ - theories/FSets/fSetInterface.cmi theories/Init/datatypes.cmi \ - theories/FSets/fSetBridge.cmi -theories/FSets/fSetBridge.cmx: theories/Init/specif.cmx \ - theories/FSets/orderedType.cmx theories/Lists/list.cmx \ - theories/FSets/fSetInterface.cmx theories/Init/datatypes.cmx \ - theories/FSets/fSetBridge.cmi -theories/FSets/fSetEqProperties.cmo: theories/Init/specif.cmi \ - theories/Setoids/setoid.cmi theories/Init/peano.cmi \ - theories/FSets/orderedType.cmi theories/FSets/fSetProperties.cmi \ - theories/FSets/fSetInterface.cmi theories/Init/datatypes.cmi \ - theories/Bool/bool.cmi theories/FSets/fSetEqProperties.cmi -theories/FSets/fSetEqProperties.cmx: theories/Init/specif.cmx \ - theories/Setoids/setoid.cmx theories/Init/peano.cmx \ - theories/FSets/orderedType.cmx theories/FSets/fSetProperties.cmx \ - theories/FSets/fSetInterface.cmx theories/Init/datatypes.cmx \ - theories/Bool/bool.cmx theories/FSets/fSetEqProperties.cmi -theories/FSets/fSetFacts.cmo: theories/Init/specif.cmi \ - theories/Setoids/setoid.cmi theories/FSets/orderedType.cmi \ - theories/FSets/fSetInterface.cmi theories/Init/datatypes.cmi \ - theories/FSets/fSetFacts.cmi -theories/FSets/fSetFacts.cmx: theories/Init/specif.cmx \ - theories/Setoids/setoid.cmx theories/FSets/orderedType.cmx \ - theories/FSets/fSetInterface.cmx theories/Init/datatypes.cmx \ - theories/FSets/fSetFacts.cmi -theories/FSets/fSetInterface.cmo: theories/Init/specif.cmi \ - theories/FSets/orderedType.cmi theories/Lists/list.cmi \ - theories/Init/datatypes.cmi theories/FSets/fSetInterface.cmi -theories/FSets/fSetInterface.cmx: theories/Init/specif.cmx \ - theories/FSets/orderedType.cmx theories/Lists/list.cmx \ - theories/Init/datatypes.cmx theories/FSets/fSetInterface.cmi -theories/FSets/fSetList.cmo: theories/Init/specif.cmi \ - theories/FSets/orderedType.cmi theories/Lists/list.cmi \ - theories/Init/datatypes.cmi theories/FSets/fSetList.cmi -theories/FSets/fSetList.cmx: theories/Init/specif.cmx \ - theories/FSets/orderedType.cmx theories/Lists/list.cmx \ - theories/Init/datatypes.cmx theories/FSets/fSetList.cmi -theories/FSets/fSetProperties.cmo: theories/Init/specif.cmi \ - theories/Setoids/setoid.cmi theories/FSets/orderedType.cmi \ - theories/Lists/list.cmi theories/FSets/fSetInterface.cmi \ - theories/FSets/fSetFacts.cmi theories/Init/datatypes.cmi \ - theories/FSets/fSetProperties.cmi -theories/FSets/fSetProperties.cmx: theories/Init/specif.cmx \ - theories/Setoids/setoid.cmx theories/FSets/orderedType.cmx \ - theories/Lists/list.cmx theories/FSets/fSetInterface.cmx \ - theories/FSets/fSetFacts.cmx theories/Init/datatypes.cmx \ - theories/FSets/fSetProperties.cmi -theories/FSets/fSets.cmo: theories/FSets/fSets.cmi -theories/FSets/fSets.cmx: theories/FSets/fSets.cmi -theories/FSets/fSetToFiniteSet.cmo: theories/Init/specif.cmi \ - theories/Setoids/setoid.cmi theories/FSets/orderedTypeEx.cmi \ - theories/FSets/orderedType.cmi theories/Lists/list.cmi \ - theories/FSets/fSetProperties.cmi theories/Init/datatypes.cmi \ - theories/FSets/fSetToFiniteSet.cmi -theories/FSets/fSetToFiniteSet.cmx: theories/Init/specif.cmx \ - theories/Setoids/setoid.cmx theories/FSets/orderedTypeEx.cmx \ - theories/FSets/orderedType.cmx theories/Lists/list.cmx \ - theories/FSets/fSetProperties.cmx theories/Init/datatypes.cmx \ - theories/FSets/fSetToFiniteSet.cmi -theories/FSets/fSetWeakFacts.cmo: theories/Init/specif.cmi \ - theories/Setoids/setoid.cmi theories/FSets/fSetWeakInterface.cmi \ - theories/Init/datatypes.cmi theories/FSets/fSetWeakFacts.cmi -theories/FSets/fSetWeakFacts.cmx: theories/Init/specif.cmx \ - theories/Setoids/setoid.cmx theories/FSets/fSetWeakInterface.cmx \ - theories/Init/datatypes.cmx theories/FSets/fSetWeakFacts.cmi -theories/FSets/fSetWeakInterface.cmo: theories/Lists/list.cmi \ - theories/FSets/decidableType.cmi theories/Init/datatypes.cmi \ - theories/FSets/fSetWeakInterface.cmi -theories/FSets/fSetWeakInterface.cmx: theories/Lists/list.cmx \ - theories/FSets/decidableType.cmx theories/Init/datatypes.cmx \ - theories/FSets/fSetWeakInterface.cmi -theories/FSets/fSetWeakList.cmo: theories/Init/specif.cmi \ - theories/Lists/list.cmi theories/FSets/decidableType.cmi \ - theories/Init/datatypes.cmi theories/FSets/fSetWeakList.cmi -theories/FSets/fSetWeakList.cmx: theories/Init/specif.cmx \ - theories/Lists/list.cmx theories/FSets/decidableType.cmx \ - theories/Init/datatypes.cmx theories/FSets/fSetWeakList.cmi -theories/FSets/fSetWeak.cmo: theories/FSets/fSetWeak.cmi -theories/FSets/fSetWeak.cmx: theories/FSets/fSetWeak.cmi -theories/FSets/fSetWeakProperties.cmo: theories/Init/specif.cmi \ - theories/Setoids/setoid.cmi theories/Lists/list.cmi \ - theories/FSets/fSetWeakInterface.cmi theories/FSets/fSetWeakFacts.cmi \ - theories/Init/datatypes.cmi theories/FSets/fSetWeakProperties.cmi -theories/FSets/fSetWeakProperties.cmx: theories/Init/specif.cmx \ - theories/Setoids/setoid.cmx theories/Lists/list.cmx \ - theories/FSets/fSetWeakInterface.cmx theories/FSets/fSetWeakFacts.cmx \ - theories/Init/datatypes.cmx theories/FSets/fSetWeakProperties.cmi -theories/FSets/int.cmo: theories/ZArith/zmax.cmi \ - theories/ZArith/zArith_dec.cmi theories/Init/specif.cmi \ - theories/NArith/binPos.cmi theories/ZArith/binInt.cmi \ - theories/FSets/int.cmi -theories/FSets/int.cmx: theories/ZArith/zmax.cmx \ - theories/ZArith/zArith_dec.cmx theories/Init/specif.cmx \ - theories/NArith/binPos.cmx theories/ZArith/binInt.cmx \ - theories/FSets/int.cmi -theories/FSets/orderedTypeAlt.cmo: theories/Init/specif.cmi \ - theories/FSets/orderedType.cmi theories/Init/datatypes.cmi \ - theories/FSets/orderedTypeAlt.cmi -theories/FSets/orderedTypeAlt.cmx: theories/Init/specif.cmx \ - theories/FSets/orderedType.cmx theories/Init/datatypes.cmx \ - theories/FSets/orderedTypeAlt.cmi -theories/FSets/orderedTypeEx.cmo: theories/Init/specif.cmi \ - theories/FSets/orderedType.cmi theories/Init/datatypes.cmi \ - theories/Arith/compare_dec.cmi theories/NArith/binPos.cmi \ - theories/NArith/binNat.cmi theories/ZArith/binInt.cmi \ - theories/FSets/orderedTypeEx.cmi -theories/FSets/orderedTypeEx.cmx: theories/Init/specif.cmx \ - theories/FSets/orderedType.cmx theories/Init/datatypes.cmx \ - theories/Arith/compare_dec.cmx theories/NArith/binPos.cmx \ - theories/NArith/binNat.cmx theories/ZArith/binInt.cmx \ - theories/FSets/orderedTypeEx.cmi -theories/FSets/orderedType.cmo: theories/Init/specif.cmi \ - theories/Init/datatypes.cmi theories/FSets/orderedType.cmi -theories/FSets/orderedType.cmx: theories/Init/specif.cmx \ - theories/Init/datatypes.cmx theories/FSets/orderedType.cmi -theories/Init/datatypes.cmo: theories/Init/datatypes.cmi -theories/Init/datatypes.cmx: theories/Init/datatypes.cmi -theories/Init/logic.cmo: theories/Init/logic.cmi -theories/Init/logic.cmx: theories/Init/logic.cmi -theories/Init/logic_Type.cmo: theories/Init/logic_Type.cmi -theories/Init/logic_Type.cmx: theories/Init/logic_Type.cmi -theories/Init/notations.cmo: theories/Init/notations.cmi -theories/Init/notations.cmx: theories/Init/notations.cmi -theories/Init/peano.cmo: theories/Init/datatypes.cmi theories/Init/peano.cmi -theories/Init/peano.cmx: theories/Init/datatypes.cmx theories/Init/peano.cmi -theories/Init/prelude.cmo: theories/Init/prelude.cmi -theories/Init/prelude.cmx: theories/Init/prelude.cmi -theories/Init/specif.cmo: theories/Init/datatypes.cmi \ - theories/Init/specif.cmi -theories/Init/specif.cmx: theories/Init/datatypes.cmx \ - theories/Init/specif.cmi -theories/Init/tactics.cmo: theories/Init/tactics.cmi -theories/Init/tactics.cmx: theories/Init/tactics.cmi -theories/Init/wf.cmo: theories/Init/wf.cmi -theories/Init/wf.cmx: theories/Init/wf.cmi -theories/IntMap/adalloc.cmo: theories/Bool/sumbool.cmi \ - theories/Init/specif.cmi theories/NArith/ndec.cmi theories/IntMap/map.cmi \ - theories/Init/datatypes.cmi theories/NArith/binPos.cmi \ - theories/NArith/binNat.cmi theories/IntMap/adalloc.cmi -theories/IntMap/adalloc.cmx: theories/Bool/sumbool.cmx \ - theories/Init/specif.cmx theories/NArith/ndec.cmx theories/IntMap/map.cmx \ - theories/Init/datatypes.cmx theories/NArith/binPos.cmx \ - theories/NArith/binNat.cmx theories/IntMap/adalloc.cmi -theories/IntMap/allmaps.cmo: theories/IntMap/allmaps.cmi -theories/IntMap/allmaps.cmx: theories/IntMap/allmaps.cmi -theories/IntMap/fset.cmo: theories/Init/specif.cmi \ - theories/NArith/ndigits.cmi theories/NArith/ndec.cmi \ - theories/IntMap/map.cmi theories/Init/datatypes.cmi \ - theories/NArith/binNat.cmi theories/IntMap/fset.cmi -theories/IntMap/fset.cmx: theories/Init/specif.cmx \ - theories/NArith/ndigits.cmx theories/NArith/ndec.cmx \ - theories/IntMap/map.cmx theories/Init/datatypes.cmx \ - theories/NArith/binNat.cmx theories/IntMap/fset.cmi -theories/IntMap/lsort.cmo: theories/Bool/sumbool.cmi theories/Init/specif.cmi \ - theories/NArith/ndigits.cmi theories/NArith/ndec.cmi \ - theories/IntMap/mapiter.cmi theories/IntMap/map.cmi \ - theories/Lists/list.cmi theories/Init/datatypes.cmi \ - theories/NArith/binNat.cmi theories/IntMap/lsort.cmi -theories/IntMap/lsort.cmx: theories/Bool/sumbool.cmx theories/Init/specif.cmx \ - theories/NArith/ndigits.cmx theories/NArith/ndec.cmx \ - theories/IntMap/mapiter.cmx theories/IntMap/map.cmx \ - theories/Lists/list.cmx theories/Init/datatypes.cmx \ - theories/NArith/binNat.cmx theories/IntMap/lsort.cmi -theories/IntMap/mapaxioms.cmo: theories/IntMap/mapaxioms.cmi -theories/IntMap/mapaxioms.cmx: theories/IntMap/mapaxioms.cmi -theories/IntMap/mapcanon.cmo: theories/Init/specif.cmi \ - theories/IntMap/map.cmi theories/IntMap/mapcanon.cmi -theories/IntMap/mapcanon.cmx: theories/Init/specif.cmx \ - theories/IntMap/map.cmx theories/IntMap/mapcanon.cmi -theories/IntMap/mapcard.cmo: theories/Bool/sumbool.cmi \ - theories/Init/specif.cmi theories/Arith/plus.cmi \ - theories/Arith/peano_dec.cmi theories/Init/peano.cmi \ - theories/NArith/ndigits.cmi theories/NArith/ndec.cmi \ - theories/IntMap/map.cmi theories/Init/datatypes.cmi \ - theories/NArith/binNat.cmi theories/IntMap/mapcard.cmi -theories/IntMap/mapcard.cmx: theories/Bool/sumbool.cmx \ - theories/Init/specif.cmx theories/Arith/plus.cmx \ - theories/Arith/peano_dec.cmx theories/Init/peano.cmx \ - theories/NArith/ndigits.cmx theories/NArith/ndec.cmx \ - theories/IntMap/map.cmx theories/Init/datatypes.cmx \ - theories/NArith/binNat.cmx theories/IntMap/mapcard.cmi -theories/IntMap/mapc.cmo: theories/IntMap/mapc.cmi -theories/IntMap/mapc.cmx: theories/IntMap/mapc.cmi -theories/IntMap/mapfold.cmo: theories/Init/specif.cmi \ - theories/IntMap/mapiter.cmi theories/IntMap/map.cmi \ - theories/IntMap/fset.cmi theories/Init/datatypes.cmi \ - theories/IntMap/mapfold.cmi -theories/IntMap/mapfold.cmx: theories/Init/specif.cmx \ - theories/IntMap/mapiter.cmx theories/IntMap/map.cmx \ - theories/IntMap/fset.cmx theories/Init/datatypes.cmx \ - theories/IntMap/mapfold.cmi -theories/IntMap/mapiter.cmo: theories/Bool/sumbool.cmi \ - theories/Init/specif.cmi theories/NArith/ndigits.cmi \ - theories/NArith/ndec.cmi theories/IntMap/map.cmi theories/Lists/list.cmi \ - theories/Init/datatypes.cmi theories/NArith/binNat.cmi \ - theories/IntMap/mapiter.cmi -theories/IntMap/mapiter.cmx: theories/Bool/sumbool.cmx \ - theories/Init/specif.cmx theories/NArith/ndigits.cmx \ - theories/NArith/ndec.cmx theories/IntMap/map.cmx theories/Lists/list.cmx \ - theories/Init/datatypes.cmx theories/NArith/binNat.cmx \ - theories/IntMap/mapiter.cmi -theories/IntMap/maplists.cmo: theories/Bool/sumbool.cmi \ - theories/Init/specif.cmi theories/NArith/ndec.cmi \ - theories/IntMap/mapiter.cmi theories/IntMap/map.cmi \ - theories/Lists/list.cmi theories/IntMap/fset.cmi \ - theories/Init/datatypes.cmi theories/IntMap/maplists.cmi -theories/IntMap/maplists.cmx: theories/Bool/sumbool.cmx \ - theories/Init/specif.cmx theories/NArith/ndec.cmx \ - theories/IntMap/mapiter.cmx theories/IntMap/map.cmx \ - theories/Lists/list.cmx theories/IntMap/fset.cmx \ - theories/Init/datatypes.cmx theories/IntMap/maplists.cmi -theories/IntMap/map.cmo: theories/Init/specif.cmi theories/Init/peano.cmi \ - theories/NArith/ndigits.cmi theories/NArith/ndec.cmi \ - theories/Init/datatypes.cmi theories/NArith/binPos.cmi \ - theories/NArith/binNat.cmi theories/IntMap/map.cmi -theories/IntMap/map.cmx: theories/Init/specif.cmx theories/Init/peano.cmx \ - theories/NArith/ndigits.cmx theories/NArith/ndec.cmx \ - theories/Init/datatypes.cmx theories/NArith/binPos.cmx \ - theories/NArith/binNat.cmx theories/IntMap/map.cmi -theories/IntMap/mapsubset.cmo: theories/IntMap/mapiter.cmi \ - theories/IntMap/map.cmi theories/IntMap/fset.cmi \ - theories/Init/datatypes.cmi theories/Bool/bool.cmi \ - theories/IntMap/mapsubset.cmi -theories/IntMap/mapsubset.cmx: theories/IntMap/mapiter.cmx \ - theories/IntMap/map.cmx theories/IntMap/fset.cmx \ - theories/Init/datatypes.cmx theories/Bool/bool.cmx \ - theories/IntMap/mapsubset.cmi -theories/Lists/list.cmo: theories/Init/specif.cmi theories/Init/datatypes.cmi \ - theories/Lists/list.cmi -theories/Lists/list.cmx: theories/Init/specif.cmx theories/Init/datatypes.cmx \ - theories/Lists/list.cmi -theories/Lists/listSet.cmo: theories/Init/specif.cmi theories/Lists/list.cmi \ - theories/Init/datatypes.cmi theories/Lists/listSet.cmi -theories/Lists/listSet.cmx: theories/Init/specif.cmx theories/Lists/list.cmx \ - theories/Init/datatypes.cmx theories/Lists/listSet.cmi -theories/Lists/monoList.cmo: theories/Init/datatypes.cmi \ - theories/Lists/monoList.cmi -theories/Lists/monoList.cmx: theories/Init/datatypes.cmx \ - theories/Lists/monoList.cmi -theories/Lists/setoidList.cmo: theories/Init/specif.cmi \ - theories/Lists/list.cmi theories/Init/datatypes.cmi \ - theories/Lists/setoidList.cmi -theories/Lists/setoidList.cmx: theories/Init/specif.cmx \ - theories/Lists/list.cmx theories/Init/datatypes.cmx \ - theories/Lists/setoidList.cmi -theories/Lists/streams.cmo: theories/Init/datatypes.cmi \ - theories/Lists/streams.cmi -theories/Lists/streams.cmx: theories/Init/datatypes.cmx \ - theories/Lists/streams.cmi -theories/Lists/theoryList.cmo: theories/Init/specif.cmi \ - theories/Lists/list.cmi theories/Init/datatypes.cmi \ - theories/Lists/theoryList.cmi -theories/Lists/theoryList.cmx: theories/Init/specif.cmx \ - theories/Lists/list.cmx theories/Init/datatypes.cmx \ - theories/Lists/theoryList.cmi -theories/Logic/berardi.cmo: theories/Logic/berardi.cmi -theories/Logic/berardi.cmx: theories/Logic/berardi.cmi -theories/Logic/choiceFacts.cmo: theories/Init/specif.cmi \ - theories/Init/datatypes.cmi theories/Logic/choiceFacts.cmi -theories/Logic/choiceFacts.cmx: theories/Init/specif.cmx \ - theories/Init/datatypes.cmx theories/Logic/choiceFacts.cmi -theories/Logic/classicalChoice.cmo: theories/Logic/classicalChoice.cmi -theories/Logic/classicalChoice.cmx: theories/Logic/classicalChoice.cmi -theories/Logic/classicalDescription.cmo: theories/Init/specif.cmi \ - theories/Logic/choiceFacts.cmi theories/Logic/classicalDescription.cmi -theories/Logic/classicalDescription.cmx: theories/Init/specif.cmx \ - theories/Logic/choiceFacts.cmx theories/Logic/classicalDescription.cmi -theories/Logic/classicalEpsilon.cmo: theories/Init/specif.cmi \ - theories/Logic/choiceFacts.cmi theories/Logic/classicalEpsilon.cmi -theories/Logic/classicalEpsilon.cmx: theories/Init/specif.cmx \ - theories/Logic/choiceFacts.cmx theories/Logic/classicalEpsilon.cmi -theories/Logic/classicalFacts.cmo: theories/Logic/classicalFacts.cmi -theories/Logic/classicalFacts.cmx: theories/Logic/classicalFacts.cmi -theories/Logic/classical.cmo: theories/Logic/classical.cmi -theories/Logic/classical.cmx: theories/Logic/classical.cmi -theories/Logic/classical_Pred_Set.cmo: theories/Logic/classical_Pred_Set.cmi -theories/Logic/classical_Pred_Set.cmx: theories/Logic/classical_Pred_Set.cmi -theories/Logic/classical_Pred_Type.cmo: \ - theories/Logic/classical_Pred_Type.cmi -theories/Logic/classical_Pred_Type.cmx: \ - theories/Logic/classical_Pred_Type.cmi -theories/Logic/classical_Prop.cmo: theories/Logic/eqdepFacts.cmi \ - theories/Logic/classical_Prop.cmi -theories/Logic/classical_Prop.cmx: theories/Logic/eqdepFacts.cmx \ - theories/Logic/classical_Prop.cmi -theories/Logic/classical_Type.cmo: theories/Logic/classical_Type.cmi -theories/Logic/classical_Type.cmx: theories/Logic/classical_Type.cmi -theories/Logic/classicalUniqueChoice.cmo: \ - theories/Logic/classicalUniqueChoice.cmi -theories/Logic/classicalUniqueChoice.cmx: \ - theories/Logic/classicalUniqueChoice.cmi -theories/Logic/decidable.cmo: theories/Logic/decidable.cmi -theories/Logic/decidable.cmx: theories/Logic/decidable.cmi -theories/Logic/diaconescu.cmo: theories/Init/specif.cmi \ - theories/Logic/diaconescu.cmi -theories/Logic/diaconescu.cmx: theories/Init/specif.cmx \ - theories/Logic/diaconescu.cmi -theories/Logic/eqdep_dec.cmo: theories/Init/specif.cmi \ - theories/Logic/eqdep_dec.cmi -theories/Logic/eqdep_dec.cmx: theories/Init/specif.cmx \ - theories/Logic/eqdep_dec.cmi -theories/Logic/eqdepFacts.cmo: theories/Logic/eqdepFacts.cmi -theories/Logic/eqdepFacts.cmx: theories/Logic/eqdepFacts.cmi -theories/Logic/eqdep.cmo: theories/Logic/eqdepFacts.cmi \ - theories/Logic/eqdep.cmi -theories/Logic/eqdep.cmx: theories/Logic/eqdepFacts.cmx \ - theories/Logic/eqdep.cmi -theories/Logic/hurkens.cmo: theories/Logic/hurkens.cmi -theories/Logic/hurkens.cmx: theories/Logic/hurkens.cmi -theories/Logic/jMeq.cmo: theories/Logic/jMeq.cmi -theories/Logic/jMeq.cmx: theories/Logic/jMeq.cmi -theories/Logic/proofIrrelevanceFacts.cmo: theories/Logic/eqdepFacts.cmi \ - theories/Logic/proofIrrelevanceFacts.cmi -theories/Logic/proofIrrelevanceFacts.cmx: theories/Logic/eqdepFacts.cmx \ - theories/Logic/proofIrrelevanceFacts.cmi -theories/Logic/proofIrrelevance.cmo: theories/Logic/proofIrrelevanceFacts.cmi \ - theories/Logic/proofIrrelevance.cmi -theories/Logic/proofIrrelevance.cmx: theories/Logic/proofIrrelevanceFacts.cmx \ - theories/Logic/proofIrrelevance.cmi -theories/Logic/relationalChoice.cmo: theories/Logic/relationalChoice.cmi -theories/Logic/relationalChoice.cmx: theories/Logic/relationalChoice.cmi -theories/NArith/binNat.cmo: theories/Init/specif.cmi \ - theories/Init/datatypes.cmi theories/NArith/binPos.cmi \ - theories/NArith/binNat.cmi -theories/NArith/binNat.cmx: theories/Init/specif.cmx \ - theories/Init/datatypes.cmx theories/NArith/binPos.cmx \ - theories/NArith/binNat.cmi -theories/NArith/binPos.cmo: theories/Init/peano.cmi \ - theories/Init/datatypes.cmi theories/NArith/binPos.cmi -theories/NArith/binPos.cmx: theories/Init/peano.cmx \ - theories/Init/datatypes.cmx theories/NArith/binPos.cmi -theories/NArith/nArith.cmo: theories/NArith/nArith.cmi -theories/NArith/nArith.cmx: theories/NArith/nArith.cmi -theories/NArith/ndec.cmo: theories/Bool/sumbool.cmi theories/Init/specif.cmi \ - theories/NArith/nnat.cmi theories/NArith/ndigits.cmi \ - theories/Init/datatypes.cmi theories/Arith/compare_dec.cmi \ - theories/NArith/binPos.cmi theories/NArith/binNat.cmi \ - theories/NArith/ndec.cmi -theories/NArith/ndec.cmx: theories/Bool/sumbool.cmx theories/Init/specif.cmx \ - theories/NArith/nnat.cmx theories/NArith/ndigits.cmx \ - theories/Init/datatypes.cmx theories/Arith/compare_dec.cmx \ - theories/NArith/binPos.cmx theories/NArith/binNat.cmx \ - theories/NArith/ndec.cmi -theories/NArith/ndigits.cmo: theories/Init/specif.cmi \ - theories/Init/datatypes.cmi theories/Bool/bvector.cmi \ - theories/Bool/bool.cmi theories/NArith/binPos.cmi \ - theories/NArith/binNat.cmi theories/NArith/ndigits.cmi -theories/NArith/ndigits.cmx: theories/Init/specif.cmx \ - theories/Init/datatypes.cmx theories/Bool/bvector.cmx \ - theories/Bool/bool.cmx theories/NArith/binPos.cmx \ - theories/NArith/binNat.cmx theories/NArith/ndigits.cmi -theories/NArith/ndist.cmo: theories/NArith/ndigits.cmi theories/Arith/min.cmi \ - theories/Init/datatypes.cmi theories/NArith/binPos.cmi \ - theories/NArith/binNat.cmi theories/NArith/ndist.cmi -theories/NArith/ndist.cmx: theories/NArith/ndigits.cmx theories/Arith/min.cmx \ - theories/Init/datatypes.cmx theories/NArith/binPos.cmx \ - theories/NArith/binNat.cmx theories/NArith/ndist.cmi -theories/NArith/nnat.cmo: theories/Init/datatypes.cmi \ - theories/NArith/binPos.cmi theories/NArith/binNat.cmi \ - theories/NArith/nnat.cmi -theories/NArith/nnat.cmx: theories/Init/datatypes.cmx \ - theories/NArith/binPos.cmx theories/NArith/binNat.cmx \ - theories/NArith/nnat.cmi -theories/NArith/pnat.cmo: theories/NArith/pnat.cmi -theories/NArith/pnat.cmx: theories/NArith/pnat.cmi -theories/QArith/qArith_base.cmo: theories/ZArith/zArith_dec.cmi \ - theories/Init/specif.cmi theories/Setoids/setoid.cmi \ - theories/Init/datatypes.cmi theories/NArith/binPos.cmi \ - theories/ZArith/binInt.cmi theories/QArith/qArith_base.cmi -theories/QArith/qArith_base.cmx: theories/ZArith/zArith_dec.cmx \ - theories/Init/specif.cmx theories/Setoids/setoid.cmx \ - theories/Init/datatypes.cmx theories/NArith/binPos.cmx \ - theories/ZArith/binInt.cmx theories/QArith/qArith_base.cmi -theories/QArith/qArith.cmo: theories/QArith/qArith.cmi -theories/QArith/qArith.cmx: theories/QArith/qArith.cmi -theories/QArith/qreals.cmo: theories/QArith/qArith_base.cmi \ - theories/ZArith/binInt.cmi theories/QArith/qreals.cmi -theories/QArith/qreals.cmx: theories/QArith/qArith_base.cmx \ - theories/ZArith/binInt.cmx theories/QArith/qreals.cmi -theories/QArith/qreduction.cmo: theories/ZArith/znumtheory.cmi \ - theories/Setoids/setoid.cmi theories/QArith/qArith_base.cmi \ - theories/Init/datatypes.cmi theories/NArith/binPos.cmi \ - theories/ZArith/binInt.cmi theories/QArith/qreduction.cmi -theories/QArith/qreduction.cmx: theories/ZArith/znumtheory.cmx \ - theories/Setoids/setoid.cmx theories/QArith/qArith_base.cmx \ - theories/Init/datatypes.cmx theories/NArith/binPos.cmx \ - theories/ZArith/binInt.cmx theories/QArith/qreduction.cmi -theories/QArith/qring.cmo: theories/Init/specif.cmi \ - theories/QArith/qArith_base.cmi theories/Init/datatypes.cmi \ - theories/QArith/qring.cmi -theories/QArith/qring.cmx: theories/Init/specif.cmx \ - theories/QArith/qArith_base.cmx theories/Init/datatypes.cmx \ - theories/QArith/qring.cmi -theories/Relations/newman.cmo: theories/Relations/newman.cmi -theories/Relations/newman.cmx: theories/Relations/newman.cmi -theories/Relations/operators_Properties.cmo: \ - theories/Relations/operators_Properties.cmi -theories/Relations/operators_Properties.cmx: \ - theories/Relations/operators_Properties.cmi -theories/Relations/relation_Definitions.cmo: \ - theories/Relations/relation_Definitions.cmi -theories/Relations/relation_Definitions.cmx: \ - theories/Relations/relation_Definitions.cmi -theories/Relations/relation_Operators.cmo: theories/Init/specif.cmi \ - theories/Lists/list.cmi theories/Relations/relation_Operators.cmi -theories/Relations/relation_Operators.cmx: theories/Init/specif.cmx \ - theories/Lists/list.cmx theories/Relations/relation_Operators.cmi -theories/Relations/relations.cmo: theories/Relations/relations.cmi -theories/Relations/relations.cmx: theories/Relations/relations.cmi -theories/Relations/rstar.cmo: theories/Relations/rstar.cmi -theories/Relations/rstar.cmx: theories/Relations/rstar.cmi -theories/Setoids/setoid.cmo: theories/Init/datatypes.cmi \ - theories/Setoids/setoid.cmi -theories/Setoids/setoid.cmx: theories/Init/datatypes.cmx \ - theories/Setoids/setoid.cmi -theories/Sets/classical_sets.cmo: theories/Sets/classical_sets.cmi -theories/Sets/classical_sets.cmx: theories/Sets/classical_sets.cmi -theories/Sets/constructive_sets.cmo: theories/Sets/constructive_sets.cmi -theories/Sets/constructive_sets.cmx: theories/Sets/constructive_sets.cmi -theories/Sets/cpo.cmo: theories/Sets/partial_Order.cmi theories/Sets/cpo.cmi -theories/Sets/cpo.cmx: theories/Sets/partial_Order.cmx theories/Sets/cpo.cmi -theories/Sets/ensembles.cmo: theories/Sets/ensembles.cmi -theories/Sets/ensembles.cmx: theories/Sets/ensembles.cmi -theories/Sets/finite_sets_facts.cmo: theories/Sets/finite_sets_facts.cmi -theories/Sets/finite_sets_facts.cmx: theories/Sets/finite_sets_facts.cmi -theories/Sets/finite_sets.cmo: theories/Sets/finite_sets.cmi -theories/Sets/finite_sets.cmx: theories/Sets/finite_sets.cmi -theories/Sets/image.cmo: theories/Sets/image.cmi -theories/Sets/image.cmx: theories/Sets/image.cmi -theories/Sets/infinite_sets.cmo: theories/Sets/infinite_sets.cmi -theories/Sets/infinite_sets.cmx: theories/Sets/infinite_sets.cmi -theories/Sets/integers.cmo: theories/Sets/partial_Order.cmi \ - theories/Init/datatypes.cmi theories/Sets/integers.cmi -theories/Sets/integers.cmx: theories/Sets/partial_Order.cmx \ - theories/Init/datatypes.cmx theories/Sets/integers.cmi -theories/Sets/multiset.cmo: theories/Init/specif.cmi theories/Init/peano.cmi \ - theories/Init/datatypes.cmi theories/Sets/multiset.cmi -theories/Sets/multiset.cmx: theories/Init/specif.cmx theories/Init/peano.cmx \ - theories/Init/datatypes.cmx theories/Sets/multiset.cmi -theories/Sets/partial_Order.cmo: theories/Sets/relations_1.cmi \ - theories/Sets/ensembles.cmi theories/Sets/partial_Order.cmi -theories/Sets/partial_Order.cmx: theories/Sets/relations_1.cmx \ - theories/Sets/ensembles.cmx theories/Sets/partial_Order.cmi -theories/Sets/permut.cmo: theories/Sets/permut.cmi -theories/Sets/permut.cmx: theories/Sets/permut.cmi -theories/Sets/powerset_Classical_facts.cmo: \ - theories/Sets/powerset_Classical_facts.cmi -theories/Sets/powerset_Classical_facts.cmx: \ - theories/Sets/powerset_Classical_facts.cmi -theories/Sets/powerset_facts.cmo: theories/Sets/powerset_facts.cmi -theories/Sets/powerset_facts.cmx: theories/Sets/powerset_facts.cmi -theories/Sets/powerset.cmo: theories/Sets/partial_Order.cmi \ - theories/Sets/ensembles.cmi theories/Sets/powerset.cmi -theories/Sets/powerset.cmx: theories/Sets/partial_Order.cmx \ - theories/Sets/ensembles.cmx theories/Sets/powerset.cmi -theories/Sets/relations_1_facts.cmo: theories/Sets/relations_1_facts.cmi -theories/Sets/relations_1_facts.cmx: theories/Sets/relations_1_facts.cmi -theories/Sets/relations_1.cmo: theories/Sets/relations_1.cmi -theories/Sets/relations_1.cmx: theories/Sets/relations_1.cmi -theories/Sets/relations_2_facts.cmo: theories/Sets/relations_2_facts.cmi -theories/Sets/relations_2_facts.cmx: theories/Sets/relations_2_facts.cmi -theories/Sets/relations_2.cmo: theories/Sets/relations_2.cmi -theories/Sets/relations_2.cmx: theories/Sets/relations_2.cmi -theories/Sets/relations_3_facts.cmo: theories/Sets/relations_3_facts.cmi -theories/Sets/relations_3_facts.cmx: theories/Sets/relations_3_facts.cmi -theories/Sets/relations_3.cmo: theories/Sets/relations_3.cmi -theories/Sets/relations_3.cmx: theories/Sets/relations_3.cmi -theories/Sets/uniset.cmo: theories/Init/specif.cmi \ - theories/Init/datatypes.cmi theories/Sets/uniset.cmi -theories/Sets/uniset.cmx: theories/Init/specif.cmx \ - theories/Init/datatypes.cmx theories/Sets/uniset.cmi -theories/Sorting/heap.cmo: theories/Init/specif.cmi \ - theories/Sorting/sorting.cmi theories/Init/peano.cmi \ - theories/Sets/multiset.cmi theories/Lists/list.cmi \ - theories/Init/datatypes.cmi theories/Sorting/heap.cmi -theories/Sorting/heap.cmx: theories/Init/specif.cmx \ - theories/Sorting/sorting.cmx theories/Init/peano.cmx \ - theories/Sets/multiset.cmx theories/Lists/list.cmx \ - theories/Init/datatypes.cmx theories/Sorting/heap.cmi -theories/Sorting/permutation.cmo: theories/Init/specif.cmi \ - theories/Init/peano.cmi theories/Sets/multiset.cmi \ - theories/Lists/list.cmi theories/Init/datatypes.cmi \ - theories/Sorting/permutation.cmi -theories/Sorting/permutation.cmx: theories/Init/specif.cmx \ - theories/Init/peano.cmx theories/Sets/multiset.cmx \ - theories/Lists/list.cmx theories/Init/datatypes.cmx \ - theories/Sorting/permutation.cmi -theories/Sorting/permutEq.cmo: theories/Sorting/permutEq.cmi -theories/Sorting/permutEq.cmx: theories/Sorting/permutEq.cmi -theories/Sorting/permutSetoid.cmo: theories/Sorting/permutSetoid.cmi -theories/Sorting/permutSetoid.cmx: theories/Sorting/permutSetoid.cmi -theories/Sorting/sorting.cmo: theories/Init/specif.cmi \ - theories/Lists/list.cmi theories/Sorting/sorting.cmi -theories/Sorting/sorting.cmx: theories/Init/specif.cmx \ - theories/Lists/list.cmx theories/Sorting/sorting.cmi -theories/Strings/ascii.cmo: theories/Init/specif.cmi theories/Init/peano.cmi \ - theories/Init/datatypes.cmi theories/Bool/bool.cmi \ - theories/NArith/binPos.cmi theories/Strings/ascii.cmi -theories/Strings/ascii.cmx: theories/Init/specif.cmx theories/Init/peano.cmx \ - theories/Init/datatypes.cmx theories/Bool/bool.cmx \ - theories/NArith/binPos.cmx theories/Strings/ascii.cmi -theories/Strings/string.cmo: theories/Init/specif.cmi \ - theories/Init/datatypes.cmi theories/Strings/ascii.cmi \ - theories/Strings/string.cmi -theories/Strings/string.cmx: theories/Init/specif.cmx \ - theories/Init/datatypes.cmx theories/Strings/ascii.cmx \ - theories/Strings/string.cmi -theories/Wellfounded/disjoint_Union.cmo: \ - theories/Wellfounded/disjoint_Union.cmi -theories/Wellfounded/disjoint_Union.cmx: \ - theories/Wellfounded/disjoint_Union.cmi -theories/Wellfounded/inclusion.cmo: theories/Wellfounded/inclusion.cmi -theories/Wellfounded/inclusion.cmx: theories/Wellfounded/inclusion.cmi -theories/Wellfounded/inverse_Image.cmo: \ - theories/Wellfounded/inverse_Image.cmi -theories/Wellfounded/inverse_Image.cmx: \ - theories/Wellfounded/inverse_Image.cmi -theories/Wellfounded/lexicographic_Exponentiation.cmo: \ - theories/Wellfounded/lexicographic_Exponentiation.cmi -theories/Wellfounded/lexicographic_Exponentiation.cmx: \ - theories/Wellfounded/lexicographic_Exponentiation.cmi -theories/Wellfounded/lexicographic_Product.cmo: \ - theories/Wellfounded/lexicographic_Product.cmi -theories/Wellfounded/lexicographic_Product.cmx: \ - theories/Wellfounded/lexicographic_Product.cmi -theories/Wellfounded/transitive_Closure.cmo: \ - theories/Wellfounded/transitive_Closure.cmi -theories/Wellfounded/transitive_Closure.cmx: \ - theories/Wellfounded/transitive_Closure.cmi -theories/Wellfounded/union.cmo: theories/Wellfounded/union.cmi -theories/Wellfounded/union.cmx: theories/Wellfounded/union.cmi -theories/Wellfounded/wellfounded.cmo: theories/Wellfounded/wellfounded.cmi -theories/Wellfounded/wellfounded.cmx: theories/Wellfounded/wellfounded.cmi -theories/Wellfounded/well_Ordering.cmo: theories/Init/specif.cmi \ - theories/Wellfounded/well_Ordering.cmi -theories/Wellfounded/well_Ordering.cmx: theories/Init/specif.cmx \ - theories/Wellfounded/well_Ordering.cmi -theories/ZArith/auxiliary.cmo: theories/ZArith/auxiliary.cmi -theories/ZArith/auxiliary.cmx: theories/ZArith/auxiliary.cmi -theories/ZArith/binInt.cmo: theories/Init/datatypes.cmi \ - theories/NArith/binPos.cmi theories/NArith/binNat.cmi \ - theories/ZArith/binInt.cmi -theories/ZArith/binInt.cmx: theories/Init/datatypes.cmx \ - theories/NArith/binPos.cmx theories/NArith/binNat.cmx \ - theories/ZArith/binInt.cmi -theories/ZArith/wf_Z.cmo: theories/Init/specif.cmi theories/Init/peano.cmi \ - theories/Init/datatypes.cmi theories/NArith/binPos.cmi \ - theories/ZArith/binInt.cmi theories/ZArith/wf_Z.cmi -theories/ZArith/wf_Z.cmx: theories/Init/specif.cmx theories/Init/peano.cmx \ - theories/Init/datatypes.cmx theories/NArith/binPos.cmx \ - theories/ZArith/binInt.cmx theories/ZArith/wf_Z.cmi -theories/ZArith/zabs.cmo: theories/Init/specif.cmi theories/ZArith/binInt.cmi \ - theories/ZArith/zabs.cmi -theories/ZArith/zabs.cmx: theories/Init/specif.cmx theories/ZArith/binInt.cmx \ - theories/ZArith/zabs.cmi -theories/ZArith/zArith_base.cmo: theories/ZArith/zArith_base.cmi -theories/ZArith/zArith_base.cmx: theories/ZArith/zArith_base.cmi -theories/ZArith/zArith_dec.cmo: theories/Bool/sumbool.cmi \ - theories/Init/specif.cmi theories/Init/datatypes.cmi \ - theories/ZArith/binInt.cmi theories/ZArith/zArith_dec.cmi -theories/ZArith/zArith_dec.cmx: theories/Bool/sumbool.cmx \ - theories/Init/specif.cmx theories/Init/datatypes.cmx \ - theories/ZArith/binInt.cmx theories/ZArith/zArith_dec.cmi -theories/ZArith/zArith.cmo: theories/ZArith/zArith.cmi -theories/ZArith/zArith.cmx: theories/ZArith/zArith.cmi -theories/ZArith/zbinary.cmo: theories/ZArith/zeven.cmi \ - theories/Init/datatypes.cmi theories/Bool/bvector.cmi \ - theories/NArith/binPos.cmi theories/ZArith/binInt.cmi \ - theories/ZArith/zbinary.cmi -theories/ZArith/zbinary.cmx: theories/ZArith/zeven.cmx \ - theories/Init/datatypes.cmx theories/Bool/bvector.cmx \ - theories/NArith/binPos.cmx theories/ZArith/binInt.cmx \ - theories/ZArith/zbinary.cmi -theories/ZArith/zbool.cmo: theories/ZArith/zeven.cmi \ - theories/ZArith/zArith_dec.cmi theories/Bool/sumbool.cmi \ - theories/Init/specif.cmi theories/Init/datatypes.cmi \ - theories/ZArith/binInt.cmi theories/ZArith/zbool.cmi -theories/ZArith/zbool.cmx: theories/ZArith/zeven.cmx \ - theories/ZArith/zArith_dec.cmx theories/Bool/sumbool.cmx \ - theories/Init/specif.cmx theories/Init/datatypes.cmx \ - theories/ZArith/binInt.cmx theories/ZArith/zbool.cmi -theories/ZArith/zcompare.cmo: theories/ZArith/zcompare.cmi -theories/ZArith/zcompare.cmx: theories/ZArith/zcompare.cmi -theories/ZArith/zcomplements.cmo: theories/ZArith/zabs.cmi \ - theories/ZArith/wf_Z.cmi theories/Init/specif.cmi theories/Lists/list.cmi \ - theories/Init/datatypes.cmi theories/NArith/binPos.cmi \ - theories/ZArith/binInt.cmi theories/ZArith/zcomplements.cmi -theories/ZArith/zcomplements.cmx: theories/ZArith/zabs.cmx \ - theories/ZArith/wf_Z.cmx theories/Init/specif.cmx theories/Lists/list.cmx \ - theories/Init/datatypes.cmx theories/NArith/binPos.cmx \ - theories/ZArith/binInt.cmx theories/ZArith/zcomplements.cmi -theories/ZArith/zdiv.cmo: theories/ZArith/zbool.cmi \ - theories/ZArith/zArith_dec.cmi theories/Init/specif.cmi \ - theories/Init/datatypes.cmi theories/NArith/binPos.cmi \ - theories/ZArith/binInt.cmi theories/ZArith/zdiv.cmi -theories/ZArith/zdiv.cmx: theories/ZArith/zbool.cmx \ - theories/ZArith/zArith_dec.cmx theories/Init/specif.cmx \ - theories/Init/datatypes.cmx theories/NArith/binPos.cmx \ - theories/ZArith/binInt.cmx theories/ZArith/zdiv.cmi -theories/ZArith/zeven.cmo: theories/Init/specif.cmi \ - theories/Init/datatypes.cmi theories/NArith/binPos.cmi \ - theories/ZArith/binInt.cmi theories/ZArith/zeven.cmi -theories/ZArith/zeven.cmx: theories/Init/specif.cmx \ - theories/Init/datatypes.cmx theories/NArith/binPos.cmx \ - theories/ZArith/binInt.cmx theories/ZArith/zeven.cmi -theories/ZArith/zhints.cmo: theories/ZArith/zhints.cmi -theories/ZArith/zhints.cmx: theories/ZArith/zhints.cmi -theories/ZArith/zlogarithm.cmo: theories/NArith/binPos.cmi \ - theories/ZArith/binInt.cmi theories/ZArith/zlogarithm.cmi -theories/ZArith/zlogarithm.cmx: theories/NArith/binPos.cmx \ - theories/ZArith/binInt.cmx theories/ZArith/zlogarithm.cmi -theories/ZArith/zmax.cmo: theories/Init/datatypes.cmi \ - theories/ZArith/binInt.cmi theories/ZArith/zmax.cmi -theories/ZArith/zmax.cmx: theories/Init/datatypes.cmx \ - theories/ZArith/binInt.cmx theories/ZArith/zmax.cmi -theories/ZArith/zminmax.cmo: theories/ZArith/zminmax.cmi -theories/ZArith/zminmax.cmx: theories/ZArith/zminmax.cmi -theories/ZArith/zmin.cmo: theories/Init/specif.cmi \ - theories/Init/datatypes.cmi theories/ZArith/binInt.cmi \ - theories/ZArith/zmin.cmi -theories/ZArith/zmin.cmx: theories/Init/specif.cmx \ - theories/Init/datatypes.cmx theories/ZArith/binInt.cmx \ - theories/ZArith/zmin.cmi -theories/ZArith/zmisc.cmo: theories/Init/datatypes.cmi \ - theories/NArith/binPos.cmi theories/ZArith/binInt.cmi \ - theories/ZArith/zmisc.cmi -theories/ZArith/zmisc.cmx: theories/Init/datatypes.cmx \ - theories/NArith/binPos.cmx theories/ZArith/binInt.cmx \ - theories/ZArith/zmisc.cmi -theories/ZArith/znat.cmo: theories/ZArith/znat.cmi -theories/ZArith/znat.cmx: theories/ZArith/znat.cmi -theories/ZArith/znumtheory.cmo: theories/ZArith/zorder.cmi \ - theories/ZArith/zdiv.cmi theories/ZArith/zArith_dec.cmi \ - theories/ZArith/wf_Z.cmi theories/Init/specif.cmi theories/Init/peano.cmi \ - theories/Init/datatypes.cmi theories/NArith/binPos.cmi \ - theories/ZArith/binInt.cmi theories/ZArith/znumtheory.cmi -theories/ZArith/znumtheory.cmx: theories/ZArith/zorder.cmx \ - theories/ZArith/zdiv.cmx theories/ZArith/zArith_dec.cmx \ - theories/ZArith/wf_Z.cmx theories/Init/specif.cmx theories/Init/peano.cmx \ - theories/Init/datatypes.cmx theories/NArith/binPos.cmx \ - theories/ZArith/binInt.cmx theories/ZArith/znumtheory.cmi -theories/ZArith/zorder.cmo: theories/Init/specif.cmi \ - theories/Init/datatypes.cmi theories/ZArith/binInt.cmi \ - theories/ZArith/zorder.cmi -theories/ZArith/zorder.cmx: theories/Init/specif.cmx \ - theories/Init/datatypes.cmx theories/ZArith/binInt.cmx \ - theories/ZArith/zorder.cmi -theories/ZArith/zpower.cmo: theories/ZArith/zmisc.cmi \ - theories/Init/datatypes.cmi theories/NArith/binPos.cmi \ - theories/ZArith/binInt.cmi theories/ZArith/zpower.cmi -theories/ZArith/zpower.cmx: theories/ZArith/zmisc.cmx \ - theories/Init/datatypes.cmx theories/NArith/binPos.cmx \ - theories/ZArith/binInt.cmx theories/ZArith/zpower.cmi -theories/ZArith/zsqrt.cmo: theories/ZArith/zArith_dec.cmi \ - theories/Init/specif.cmi theories/NArith/binPos.cmi \ - theories/ZArith/binInt.cmi theories/ZArith/zsqrt.cmi -theories/ZArith/zsqrt.cmx: theories/ZArith/zArith_dec.cmx \ - theories/Init/specif.cmx theories/NArith/binPos.cmx \ - theories/ZArith/binInt.cmx theories/ZArith/zsqrt.cmi -theories/ZArith/zwf.cmo: theories/ZArith/zwf.cmi -theories/ZArith/zwf.cmx: theories/ZArith/zwf.cmi -theories/Arith/bool_nat.cmi: theories/Bool/sumbool.cmi \ - theories/Init/specif.cmi theories/Arith/peano_dec.cmi \ - theories/Init/datatypes.cmi theories/Arith/compare_dec.cmi -theories/Arith/compare_dec.cmi: theories/Init/specif.cmi \ - theories/Init/datatypes.cmi -theories/Arith/compare.cmi: theories/Init/specif.cmi \ - theories/Init/datatypes.cmi theories/Arith/compare_dec.cmi -theories/Arith/div2.cmi: theories/Init/specif.cmi theories/Init/peano.cmi \ - theories/Init/datatypes.cmi -theories/Arith/eqNat.cmi: theories/Init/specif.cmi \ - theories/Init/datatypes.cmi -theories/Arith/euclid.cmi: theories/Init/specif.cmi theories/Init/peano.cmi \ - theories/Init/datatypes.cmi theories/Arith/compare_dec.cmi -theories/Arith/even.cmi: theories/Init/specif.cmi theories/Init/datatypes.cmi -theories/Arith/factorial.cmi: theories/Init/peano.cmi \ - theories/Init/datatypes.cmi -theories/Arith/max.cmi: theories/Init/specif.cmi theories/Init/datatypes.cmi -theories/Arith/min.cmi: theories/Init/specif.cmi theories/Init/datatypes.cmi -theories/Arith/mult.cmi: theories/Arith/plus.cmi theories/Init/datatypes.cmi -theories/Arith/peano_dec.cmi: theories/Init/specif.cmi \ - theories/Init/datatypes.cmi -theories/Arith/plus.cmi: theories/Init/specif.cmi theories/Init/datatypes.cmi -theories/Arith/wf_nat.cmi: theories/Init/datatypes.cmi -theories/Bool/boolEq.cmi: theories/Init/specif.cmi \ - theories/Init/datatypes.cmi -theories/Bool/bool.cmi: theories/Init/specif.cmi theories/Init/datatypes.cmi -theories/Bool/bvector.cmi: theories/Init/peano.cmi \ - theories/Init/datatypes.cmi theories/Bool/bool.cmi -theories/Bool/decBool.cmi: theories/Init/specif.cmi -theories/Bool/ifProp.cmi: theories/Init/specif.cmi \ - theories/Init/datatypes.cmi -theories/Bool/sumbool.cmi: theories/Init/specif.cmi \ - theories/Init/datatypes.cmi -theories/Bool/zerob.cmi: theories/Init/datatypes.cmi -theories/FSets/decidableTypeEx.cmi: theories/Init/specif.cmi \ - theories/FSets/orderedTypeEx.cmi theories/FSets/orderedType.cmi \ - theories/Init/datatypes.cmi -theories/FSets/decidableType.cmi: theories/Init/specif.cmi -theories/FSets/fMapAVL.cmi: theories/Init/wf.cmi theories/Init/specif.cmi \ - theories/FSets/orderedType.cmi theories/Lists/list.cmi \ - theories/FSets/int.cmi theories/Init/datatypes.cmi \ - theories/NArith/binPos.cmi theories/ZArith/binInt.cmi -theories/FSets/fMapFacts.cmi: theories/Init/specif.cmi \ - theories/FSets/fMapInterface.cmi theories/Init/datatypes.cmi -theories/FSets/fMapInterface.cmi: theories/FSets/orderedType.cmi \ - theories/Lists/list.cmi theories/Init/datatypes.cmi -theories/FSets/fMapIntMap.cmi: theories/Init/specif.cmi \ - theories/FSets/orderedType.cmi theories/NArith/ndigits.cmi \ - theories/IntMap/mapiter.cmi theories/IntMap/mapcanon.cmi \ - theories/IntMap/map.cmi theories/Lists/list.cmi \ - theories/Init/datatypes.cmi theories/NArith/binNat.cmi -theories/FSets/fMapList.cmi: theories/Init/specif.cmi \ - theories/FSets/orderedType.cmi theories/Lists/list.cmi \ - theories/Init/datatypes.cmi -theories/FSets/fMapPositive.cmi: theories/Init/specif.cmi \ - theories/FSets/orderedType.cmi theories/Lists/list.cmi \ - theories/Init/datatypes.cmi theories/NArith/binPos.cmi -theories/FSets/fMapWeakFacts.cmi: theories/Init/specif.cmi \ - theories/Lists/list.cmi theories/FSets/fMapWeakInterface.cmi \ - theories/Init/datatypes.cmi -theories/FSets/fMapWeakInterface.cmi: theories/Lists/list.cmi \ - theories/FSets/decidableType.cmi theories/Init/datatypes.cmi -theories/FSets/fMapWeakList.cmi: theories/Init/specif.cmi \ - theories/Lists/list.cmi theories/FSets/decidableType.cmi \ - theories/Init/datatypes.cmi -theories/FSets/fSetAVL.cmi: theories/Init/wf.cmi theories/Init/specif.cmi \ - theories/Init/peano.cmi theories/FSets/orderedType.cmi \ - theories/Lists/list.cmi theories/FSets/int.cmi \ - theories/Init/datatypes.cmi theories/NArith/binPos.cmi \ - theories/ZArith/binInt.cmi -theories/FSets/fSetBridge.cmi: theories/Init/specif.cmi \ - theories/FSets/orderedType.cmi theories/Lists/list.cmi \ - theories/FSets/fSetInterface.cmi theories/Init/datatypes.cmi -theories/FSets/fSetEqProperties.cmi: theories/Init/specif.cmi \ - theories/Setoids/setoid.cmi theories/Init/peano.cmi \ - theories/FSets/fSetInterface.cmi theories/Init/datatypes.cmi \ - theories/Bool/bool.cmi -theories/FSets/fSetFacts.cmi: theories/Init/specif.cmi \ - theories/Setoids/setoid.cmi theories/FSets/fSetInterface.cmi \ - theories/Init/datatypes.cmi -theories/FSets/fSetInterface.cmi: theories/Init/specif.cmi \ - theories/FSets/orderedType.cmi theories/Lists/list.cmi \ - theories/Init/datatypes.cmi -theories/FSets/fSetList.cmi: theories/Init/specif.cmi \ - theories/FSets/orderedType.cmi theories/Lists/list.cmi \ - theories/Init/datatypes.cmi -theories/FSets/fSetProperties.cmi: theories/Init/specif.cmi \ - theories/Setoids/setoid.cmi theories/Lists/list.cmi \ - theories/FSets/fSetInterface.cmi theories/Init/datatypes.cmi -theories/FSets/fSetToFiniteSet.cmi: theories/Init/specif.cmi \ - theories/Setoids/setoid.cmi theories/FSets/orderedTypeEx.cmi \ - theories/FSets/orderedType.cmi theories/Lists/list.cmi \ - theories/Init/datatypes.cmi -theories/FSets/fSetWeakFacts.cmi: theories/Init/specif.cmi \ - theories/Setoids/setoid.cmi theories/FSets/fSetWeakInterface.cmi \ - theories/Init/datatypes.cmi -theories/FSets/fSetWeakInterface.cmi: theories/Lists/list.cmi \ - theories/FSets/decidableType.cmi theories/Init/datatypes.cmi -theories/FSets/fSetWeakList.cmi: theories/Init/specif.cmi \ - theories/Lists/list.cmi theories/FSets/decidableType.cmi \ - theories/Init/datatypes.cmi -theories/FSets/fSetWeakProperties.cmi: theories/Init/specif.cmi \ - theories/Setoids/setoid.cmi theories/Lists/list.cmi \ - theories/FSets/fSetWeakInterface.cmi theories/Init/datatypes.cmi -theories/FSets/int.cmi: theories/ZArith/zmax.cmi \ - theories/ZArith/zArith_dec.cmi theories/Init/specif.cmi \ - theories/NArith/binPos.cmi theories/ZArith/binInt.cmi -theories/FSets/orderedTypeAlt.cmi: theories/Init/specif.cmi \ - theories/FSets/orderedType.cmi theories/Init/datatypes.cmi -theories/FSets/orderedTypeEx.cmi: theories/Init/specif.cmi \ - theories/FSets/orderedType.cmi theories/Init/datatypes.cmi \ - theories/Arith/compare_dec.cmi theories/NArith/binPos.cmi \ - theories/NArith/binNat.cmi theories/ZArith/binInt.cmi -theories/FSets/orderedType.cmi: theories/Init/specif.cmi \ - theories/Init/datatypes.cmi -theories/Init/peano.cmi: theories/Init/datatypes.cmi -theories/Init/specif.cmi: theories/Init/datatypes.cmi -theories/IntMap/adalloc.cmi: theories/Bool/sumbool.cmi \ - theories/Init/specif.cmi theories/NArith/ndec.cmi theories/IntMap/map.cmi \ - theories/Init/datatypes.cmi theories/NArith/binPos.cmi \ - theories/NArith/binNat.cmi -theories/IntMap/fset.cmi: theories/Init/specif.cmi \ - theories/NArith/ndigits.cmi theories/NArith/ndec.cmi \ - theories/IntMap/map.cmi theories/Init/datatypes.cmi \ - theories/NArith/binNat.cmi -theories/IntMap/lsort.cmi: theories/Bool/sumbool.cmi theories/Init/specif.cmi \ - theories/NArith/ndigits.cmi theories/NArith/ndec.cmi \ - theories/IntMap/mapiter.cmi theories/IntMap/map.cmi \ - theories/Lists/list.cmi theories/Init/datatypes.cmi \ - theories/NArith/binNat.cmi -theories/IntMap/mapcanon.cmi: theories/Init/specif.cmi \ - theories/IntMap/map.cmi -theories/IntMap/mapcard.cmi: theories/Bool/sumbool.cmi \ - theories/Init/specif.cmi theories/Arith/plus.cmi \ - theories/Arith/peano_dec.cmi theories/Init/peano.cmi \ - theories/NArith/ndigits.cmi theories/NArith/ndec.cmi \ - theories/IntMap/map.cmi theories/Init/datatypes.cmi \ - theories/NArith/binNat.cmi -theories/IntMap/mapfold.cmi: theories/Init/specif.cmi \ - theories/IntMap/mapiter.cmi theories/IntMap/map.cmi \ - theories/IntMap/fset.cmi theories/Init/datatypes.cmi -theories/IntMap/mapiter.cmi: theories/Bool/sumbool.cmi \ - theories/Init/specif.cmi theories/NArith/ndigits.cmi \ - theories/NArith/ndec.cmi theories/IntMap/map.cmi theories/Lists/list.cmi \ - theories/Init/datatypes.cmi theories/NArith/binNat.cmi -theories/IntMap/maplists.cmi: theories/Bool/sumbool.cmi \ - theories/Init/specif.cmi theories/NArith/ndec.cmi \ - theories/IntMap/mapiter.cmi theories/IntMap/map.cmi \ - theories/Lists/list.cmi theories/IntMap/fset.cmi \ - theories/Init/datatypes.cmi -theories/IntMap/map.cmi: theories/Init/specif.cmi theories/Init/peano.cmi \ - theories/NArith/ndigits.cmi theories/NArith/ndec.cmi \ - theories/Init/datatypes.cmi theories/NArith/binPos.cmi \ - theories/NArith/binNat.cmi -theories/IntMap/mapsubset.cmi: theories/IntMap/mapiter.cmi \ - theories/IntMap/map.cmi theories/IntMap/fset.cmi \ - theories/Init/datatypes.cmi theories/Bool/bool.cmi -theories/Lists/list.cmi: theories/Init/specif.cmi theories/Init/datatypes.cmi -theories/Lists/listSet.cmi: theories/Init/specif.cmi theories/Lists/list.cmi \ - theories/Init/datatypes.cmi -theories/Lists/monoList.cmi: theories/Init/datatypes.cmi -theories/Lists/setoidList.cmi: theories/Init/specif.cmi \ - theories/Lists/list.cmi theories/Init/datatypes.cmi -theories/Lists/streams.cmi: theories/Init/datatypes.cmi -theories/Lists/theoryList.cmi: theories/Init/specif.cmi \ - theories/Lists/list.cmi theories/Init/datatypes.cmi -theories/Logic/choiceFacts.cmi: theories/Init/specif.cmi \ - theories/Init/datatypes.cmi -theories/Logic/classicalDescription.cmi: theories/Init/specif.cmi \ - theories/Logic/choiceFacts.cmi -theories/Logic/classicalEpsilon.cmi: theories/Init/specif.cmi \ - theories/Logic/choiceFacts.cmi -theories/Logic/diaconescu.cmi: theories/Init/specif.cmi -theories/Logic/eqdep_dec.cmi: theories/Init/specif.cmi -theories/NArith/binNat.cmi: theories/Init/specif.cmi \ - theories/Init/datatypes.cmi theories/NArith/binPos.cmi -theories/NArith/binPos.cmi: theories/Init/peano.cmi \ - theories/Init/datatypes.cmi -theories/NArith/ndec.cmi: theories/Bool/sumbool.cmi theories/Init/specif.cmi \ - theories/NArith/nnat.cmi theories/NArith/ndigits.cmi \ - theories/Init/datatypes.cmi theories/Arith/compare_dec.cmi \ - theories/NArith/binPos.cmi theories/NArith/binNat.cmi -theories/NArith/ndigits.cmi: theories/Init/specif.cmi \ - theories/Init/datatypes.cmi theories/Bool/bvector.cmi \ - theories/Bool/bool.cmi theories/NArith/binPos.cmi \ - theories/NArith/binNat.cmi -theories/NArith/ndist.cmi: theories/NArith/ndigits.cmi theories/Arith/min.cmi \ - theories/Init/datatypes.cmi theories/NArith/binPos.cmi \ - theories/NArith/binNat.cmi -theories/NArith/nnat.cmi: theories/Init/datatypes.cmi \ - theories/NArith/binPos.cmi theories/NArith/binNat.cmi -theories/QArith/qArith_base.cmi: theories/ZArith/zArith_dec.cmi \ - theories/Init/specif.cmi theories/Setoids/setoid.cmi \ - theories/Init/datatypes.cmi theories/NArith/binPos.cmi \ - theories/ZArith/binInt.cmi -theories/QArith/qreals.cmi: theories/QArith/qArith_base.cmi \ - theories/ZArith/binInt.cmi -theories/QArith/qreduction.cmi: theories/ZArith/znumtheory.cmi \ - theories/Setoids/setoid.cmi theories/QArith/qArith_base.cmi \ - theories/Init/datatypes.cmi theories/NArith/binPos.cmi \ - theories/ZArith/binInt.cmi -theories/QArith/qring.cmi: theories/Init/specif.cmi \ - theories/QArith/qArith_base.cmi theories/Init/datatypes.cmi -theories/Relations/relation_Operators.cmi: theories/Init/specif.cmi \ - theories/Lists/list.cmi -theories/Setoids/setoid.cmi: theories/Init/datatypes.cmi -theories/Sets/cpo.cmi: theories/Sets/partial_Order.cmi -theories/Sets/integers.cmi: theories/Sets/partial_Order.cmi \ - theories/Init/datatypes.cmi -theories/Sets/multiset.cmi: theories/Init/specif.cmi theories/Init/peano.cmi \ - theories/Init/datatypes.cmi -theories/Sets/partial_Order.cmi: theories/Sets/relations_1.cmi \ - theories/Sets/ensembles.cmi -theories/Sets/powerset.cmi: theories/Sets/partial_Order.cmi \ - theories/Sets/ensembles.cmi -theories/Sets/uniset.cmi: theories/Init/specif.cmi \ - theories/Init/datatypes.cmi -theories/Sorting/heap.cmi: theories/Init/specif.cmi \ - theories/Sorting/sorting.cmi theories/Init/peano.cmi \ - theories/Sets/multiset.cmi theories/Lists/list.cmi \ - theories/Init/datatypes.cmi -theories/Sorting/permutation.cmi: theories/Init/specif.cmi \ - theories/Init/peano.cmi theories/Sets/multiset.cmi \ - theories/Lists/list.cmi theories/Init/datatypes.cmi -theories/Sorting/sorting.cmi: theories/Init/specif.cmi \ - theories/Lists/list.cmi -theories/Strings/ascii.cmi: theories/Init/specif.cmi theories/Init/peano.cmi \ - theories/Init/datatypes.cmi theories/Bool/bool.cmi \ - theories/NArith/binPos.cmi -theories/Strings/string.cmi: theories/Init/specif.cmi \ - theories/Init/datatypes.cmi theories/Strings/ascii.cmi -theories/Wellfounded/well_Ordering.cmi: theories/Init/specif.cmi -theories/ZArith/binInt.cmi: theories/Init/datatypes.cmi \ - theories/NArith/binPos.cmi theories/NArith/binNat.cmi -theories/ZArith/wf_Z.cmi: theories/Init/specif.cmi theories/Init/peano.cmi \ - theories/Init/datatypes.cmi theories/NArith/binPos.cmi \ - theories/ZArith/binInt.cmi -theories/ZArith/zabs.cmi: theories/Init/specif.cmi theories/ZArith/binInt.cmi -theories/ZArith/zArith_dec.cmi: theories/Bool/sumbool.cmi \ - theories/Init/specif.cmi theories/Init/datatypes.cmi \ - theories/ZArith/binInt.cmi -theories/ZArith/zbinary.cmi: theories/ZArith/zeven.cmi \ - theories/Init/datatypes.cmi theories/Bool/bvector.cmi \ - theories/NArith/binPos.cmi theories/ZArith/binInt.cmi -theories/ZArith/zbool.cmi: theories/ZArith/zeven.cmi \ - theories/ZArith/zArith_dec.cmi theories/Bool/sumbool.cmi \ - theories/Init/specif.cmi theories/Init/datatypes.cmi \ - theories/ZArith/binInt.cmi -theories/ZArith/zcomplements.cmi: theories/ZArith/zabs.cmi \ - theories/ZArith/wf_Z.cmi theories/Init/specif.cmi theories/Lists/list.cmi \ - theories/Init/datatypes.cmi theories/NArith/binPos.cmi \ - theories/ZArith/binInt.cmi -theories/ZArith/zdiv.cmi: theories/ZArith/zbool.cmi \ - theories/ZArith/zArith_dec.cmi theories/Init/specif.cmi \ - theories/Init/datatypes.cmi theories/NArith/binPos.cmi \ - theories/ZArith/binInt.cmi -theories/ZArith/zeven.cmi: theories/Init/specif.cmi \ - theories/Init/datatypes.cmi theories/NArith/binPos.cmi \ - theories/ZArith/binInt.cmi -theories/ZArith/zlogarithm.cmi: theories/NArith/binPos.cmi \ - theories/ZArith/binInt.cmi -theories/ZArith/zmax.cmi: theories/Init/datatypes.cmi \ - theories/ZArith/binInt.cmi -theories/ZArith/zmin.cmi: theories/Init/specif.cmi \ - theories/Init/datatypes.cmi theories/ZArith/binInt.cmi -theories/ZArith/zmisc.cmi: theories/Init/datatypes.cmi \ - theories/NArith/binPos.cmi theories/ZArith/binInt.cmi -theories/ZArith/znumtheory.cmi: theories/ZArith/zorder.cmi \ - theories/ZArith/zdiv.cmi theories/ZArith/zArith_dec.cmi \ - theories/ZArith/wf_Z.cmi theories/Init/specif.cmi theories/Init/peano.cmi \ - theories/Init/datatypes.cmi theories/NArith/binPos.cmi \ - theories/ZArith/binInt.cmi -theories/ZArith/zorder.cmi: theories/Init/specif.cmi \ - theories/Init/datatypes.cmi theories/ZArith/binInt.cmi -theories/ZArith/zpower.cmi: theories/ZArith/zmisc.cmi \ - theories/Init/datatypes.cmi theories/NArith/binPos.cmi \ - theories/ZArith/binInt.cmi -theories/ZArith/zsqrt.cmi: theories/ZArith/zArith_dec.cmi \ - theories/Init/specif.cmi theories/NArith/binPos.cmi \ - theories/ZArith/binInt.cmi diff --git a/contrib/extraction/test/Makefile b/contrib/extraction/test/Makefile deleted file mode 100644 index 65a54090..00000000 --- a/contrib/extraction/test/Makefile +++ /dev/null @@ -1,109 +0,0 @@ -# -# General variables -# - -TOPDIR=../../.. - -# Files with axioms to be realized: can't be extracted directly - -AXIOMSVO:= \ -theories/Reals/% \ -theories/Num/% - -DIRS:= $(shell (cd $(TOPDIR);find theories -type d ! -path \*.svn\*)) - -INCL:= $(patsubst %,-I %,$(DIRS)) - -VO:= $(shell (cd $(TOPDIR);find theories -name \*.vo)) - -VO:= $(filter-out $(AXIOMSVO),$(VO)) - -ML:= $(shell test -x v2ml && ./v2ml $(VO)) - -MLI:= $(patsubst %.ml,%.mli,$(ML)) - -CMO:= $(patsubst %.ml,%.cmo,$(ML)) - -OSTDLIB:=$(shell (ocamlc -where)) - -# -# General rules -# - -all: v2ml ml $(MLI) $(CMO) - -ml: $(ML) - -depend: #$(ML) - rm -f .depend; ocamldep $(INCL) theories/*/*.ml theories/*/*.mli > .depend - -tree: - mkdir -p $(DIRS) - cp $(OSTDLIB)/pervasives.cmi $(OSTDLIB)/obj.cmi $(OSTDLIB)/lazy.cmi theories - -#%.mli:%.ml -# ./make_mli $< > $@ - -%.cmi:%.mli - ocamlc -c $(INCL) -nostdlib $< - -%.cmo:%.ml - ocamlc -c $(INCL) -nostdlib $< - -$(ML): ml2v - ./extract $@ - -clean: - rm -f theories/*/*.ml* theories/*/*.cm* - - -# -# Utilities -# - -open: - find theories -name "*".ml -exec ./qualify2open \{\} \; - -undo_open: - find theories -name "*".ml -exec mv \{\}.orig \{\} \; - -ml2v: ml2v.ml - ocamlopt -o $@ $< - -v2ml: v2ml.ml - ocamlopt -o $@ $< - $(MAKE) - -# -# Extraction of Reals -# - - -REALSAXIOMSVO:=theories/Reals/Rsyntax.vo - -REALSALLVO:=$(shell cd $(TOPDIR); ls -tr theories/Reals/*.vo) -REALSVO:=$(filter-out $(REALSAXIOMSVO),$(REALSALLVO)) -REALSML:=$(shell test -x v2ml && ./v2ml $(REALSVO)) -REALSCMO:= $(patsubst %.ml,%.cmo,$(REALSML)) - -reals: all realsml theories/Reals/addReals.cmo $(REALSCMO) - -realsml: $(REALSML) - -theories/Reals/addReals.ml: - cp -f addReals theories/Reals/addReals.ml - -$(REALSML): - ./extract $@ - - -# -# The End -# - -.PHONY: all tree clean reals realsml depend - -include .depend - - - diff --git a/contrib/extraction/test/Makefile.haskell b/contrib/extraction/test/Makefile.haskell deleted file mode 100644 index 6e1e15d1..00000000 --- a/contrib/extraction/test/Makefile.haskell +++ /dev/null @@ -1,416 +0,0 @@ -# -# General variables -# - -TOPDIR=../../.. - -# Files with axioms to be realized: can't be extracted directly - -AXIOMSVO:= \ -theories/Init/Prelude.vo \ -theories/Reals/% \ -theories/Num/% - -DIRS:= $(shell (cd $(TOPDIR);find theories -type d ! -name CVS)) - -INCL:= $(patsubst %,-i%,$(DIRS)) - -VO:= $(shell (cd $(TOPDIR);find theories -name \*.vo)) - -VO:= $(filter-out $(AXIOMSVO),$(VO)) - -HS:= $(shell test -x v2hs && ./v2hs $(VO)) - -O:= $(patsubst %.hs,%.o,$(HS)) - -# -# General rules -# - -all: v2hs hs $(O) - -hs: $(HS) - -tree: - mkdir -p $(DIRS) - -%.o:%.hs - ghc $(INCL) -c $< - -$(HS): hs2v - ./extract.haskell $@ - -clean: - rm -f theories/*/*.h* theories/*/*.o - - -# -# Utilities -# - -hs2v: hs2v.ml - ocamlc -o $@ $< - -v2hs: v2hs.ml - ocamlc -o $@ $< - $(MAKE) -f Makefile.haskell - - -# -# The End -# - -.PHONY: all tree clean depend - -# DO NOT DELETE: Beginning of Haskell dependencies -theories/Arith/Between.o : theories/Arith/Between.hs -theories/Arith/Bool_nat.o : theories/Arith/Bool_nat.hs -theories/Arith/Bool_nat.o : theories/Bool/Sumbool.o -theories/Arith/Bool_nat.o : theories/Init/Specif.o -theories/Arith/Bool_nat.o : theories/Arith/Peano_dec.o -theories/Arith/Bool_nat.o : theories/Init/Datatypes.o -theories/Arith/Bool_nat.o : theories/Arith/Compare_dec.o -theories/Arith/Compare_dec.o : theories/Arith/Compare_dec.hs -theories/Arith/Compare_dec.o : theories/Init/Specif.o -theories/Arith/Compare_dec.o : theories/Init/Logic.o -theories/Arith/Compare_dec.o : theories/Init/Datatypes.o -theories/Arith/Compare.o : theories/Arith/Compare.hs -theories/Arith/Compare.o : theories/Init/Specif.o -theories/Arith/Compare.o : theories/Init/Datatypes.o -theories/Arith/Compare.o : theories/Arith/Compare_dec.o -theories/Arith/Div2.o : theories/Arith/Div2.hs -theories/Arith/Div2.o : theories/Init/Specif.o -theories/Arith/Div2.o : theories/Init/Peano.o -theories/Arith/Div2.o : theories/Init/Datatypes.o -theories/Arith/EqNat.o : theories/Arith/EqNat.hs -theories/Arith/EqNat.o : theories/Init/Specif.o -theories/Arith/EqNat.o : theories/Init/Datatypes.o -theories/Arith/Euclid.o : theories/Arith/Euclid.hs -theories/Arith/Euclid.o : theories/Arith/Wf_nat.o -theories/Arith/Euclid.o : theories/Init/Specif.o -theories/Arith/Euclid.o : theories/Arith/Minus.o -theories/Arith/Euclid.o : theories/Init/Datatypes.o -theories/Arith/Euclid.o : theories/Arith/Compare_dec.o -theories/Arith/Even.o : theories/Arith/Even.hs -theories/Arith/Even.o : theories/Init/Specif.o -theories/Arith/Even.o : theories/Init/Datatypes.o -theories/Arith/Gt.o : theories/Arith/Gt.hs -theories/Arith/Le.o : theories/Arith/Le.hs -theories/Arith/Lt.o : theories/Arith/Lt.hs -theories/Arith/Max.o : theories/Arith/Max.hs -theories/Arith/Max.o : theories/Init/Specif.o -theories/Arith/Max.o : theories/Init/Logic.o -theories/Arith/Max.o : theories/Init/Datatypes.o -theories/Arith/Min.o : theories/Arith/Min.hs -theories/Arith/Min.o : theories/Init/Specif.o -theories/Arith/Min.o : theories/Init/Logic.o -theories/Arith/Min.o : theories/Init/Datatypes.o -theories/Arith/Minus.o : theories/Arith/Minus.hs -theories/Arith/Minus.o : theories/Init/Datatypes.o -theories/Arith/Mult.o : theories/Arith/Mult.hs -theories/Arith/Mult.o : theories/Arith/Plus.o -theories/Arith/Mult.o : theories/Init/Datatypes.o -theories/Arith/Peano_dec.o : theories/Arith/Peano_dec.hs -theories/Arith/Peano_dec.o : theories/Init/Specif.o -theories/Arith/Peano_dec.o : theories/Init/Datatypes.o -theories/Arith/Plus.o : theories/Arith/Plus.hs -theories/Arith/Plus.o : theories/Init/Specif.o -theories/Arith/Plus.o : theories/Init/Logic.o -theories/Arith/Plus.o : theories/Init/Datatypes.o -theories/Arith/Wf_nat.o : theories/Arith/Wf_nat.hs -theories/Arith/Wf_nat.o : theories/Init/Wf.o -theories/Arith/Wf_nat.o : theories/Init/Logic.o -theories/Arith/Wf_nat.o : theories/Init/Datatypes.o -theories/Bool/BoolEq.o : theories/Bool/BoolEq.hs -theories/Bool/BoolEq.o : theories/Init/Specif.o -theories/Bool/BoolEq.o : theories/Init/Datatypes.o -theories/Bool/Bool.o : theories/Bool/Bool.hs -theories/Bool/Bool.o : theories/Init/Specif.o -theories/Bool/Bool.o : theories/Init/Datatypes.o -theories/Bool/DecBool.o : theories/Bool/DecBool.hs -theories/Bool/DecBool.o : theories/Init/Specif.o -theories/Bool/IfProp.o : theories/Bool/IfProp.hs -theories/Bool/IfProp.o : theories/Init/Specif.o -theories/Bool/IfProp.o : theories/Init/Datatypes.o -theories/Bool/Sumbool.o : theories/Bool/Sumbool.hs -theories/Bool/Sumbool.o : theories/Init/Specif.o -theories/Bool/Sumbool.o : theories/Init/Datatypes.o -theories/Bool/Zerob.o : theories/Bool/Zerob.hs -theories/Bool/Zerob.o : theories/Init/Datatypes.o -theories/Init/Datatypes.o : theories/Init/Datatypes.hs -theories/Init/DatatypesSyntax.o : theories/Init/DatatypesSyntax.hs -theories/Init/Logic.o : theories/Init/Logic.hs -theories/Init/LogicSyntax.o : theories/Init/LogicSyntax.hs -theories/Init/Logic_Type.o : theories/Init/Logic_Type.hs -theories/Init/Logic_TypeSyntax.o : theories/Init/Logic_TypeSyntax.hs -theories/Init/Peano.o : theories/Init/Peano.hs -theories/Init/Peano.o : theories/Init/Datatypes.o -theories/Init/Specif.o : theories/Init/Specif.hs -theories/Init/Specif.o : theories/Init/Logic.o -theories/Init/Specif.o : theories/Init/Datatypes.o -theories/Init/SpecifSyntax.o : theories/Init/SpecifSyntax.hs -theories/Init/Wf.o : theories/Init/Wf.hs -theories/IntMap/Adalloc.o : theories/IntMap/Adalloc.hs -theories/IntMap/Adalloc.o : theories/ZArith/Fast_integer.o -theories/IntMap/Adalloc.o : theories/Bool/Sumbool.o -theories/IntMap/Adalloc.o : theories/Init/Specif.o -theories/IntMap/Adalloc.o : theories/IntMap/Map.o -theories/IntMap/Adalloc.o : theories/Init/Logic.o -theories/IntMap/Adalloc.o : theories/Init/Datatypes.o -theories/IntMap/Adalloc.o : theories/IntMap/Addr.o -theories/IntMap/Adalloc.o : theories/IntMap/Addec.o -theories/IntMap/Addec.o : theories/IntMap/Addec.hs -theories/IntMap/Addec.o : theories/ZArith/Fast_integer.o -theories/IntMap/Addec.o : theories/Bool/Sumbool.o -theories/IntMap/Addec.o : theories/Init/Specif.o -theories/IntMap/Addec.o : theories/Init/Datatypes.o -theories/IntMap/Addec.o : theories/IntMap/Addr.o -theories/IntMap/Addr.o : theories/IntMap/Addr.hs -theories/IntMap/Addr.o : theories/ZArith/Fast_integer.o -theories/IntMap/Addr.o : theories/Init/Specif.o -theories/IntMap/Addr.o : theories/Init/Datatypes.o -theories/IntMap/Addr.o : theories/Bool/Bool.o -theories/IntMap/Adist.o : theories/IntMap/Adist.hs -theories/IntMap/Adist.o : theories/ZArith/Fast_integer.o -theories/IntMap/Adist.o : theories/Arith/Min.o -theories/IntMap/Adist.o : theories/Init/Datatypes.o -theories/IntMap/Adist.o : theories/IntMap/Addr.o -theories/IntMap/Allmaps.o : theories/IntMap/Allmaps.hs -theories/IntMap/Fset.o : theories/IntMap/Fset.hs -theories/IntMap/Fset.o : theories/Init/Specif.o -theories/IntMap/Fset.o : theories/IntMap/Map.o -theories/IntMap/Fset.o : theories/Init/Logic.o -theories/IntMap/Fset.o : theories/Init/Datatypes.o -theories/IntMap/Fset.o : theories/IntMap/Addr.o -theories/IntMap/Fset.o : theories/IntMap/Addec.o -theories/IntMap/Lsort.o : theories/IntMap/Lsort.hs -theories/IntMap/Lsort.o : theories/ZArith/Fast_integer.o -theories/IntMap/Lsort.o : theories/Bool/Sumbool.o -theories/IntMap/Lsort.o : theories/Init/Specif.o -theories/IntMap/Lsort.o : theories/Lists/PolyList.o -theories/IntMap/Lsort.o : theories/IntMap/Mapiter.o -theories/IntMap/Lsort.o : theories/IntMap/Map.o -theories/IntMap/Lsort.o : theories/Init/Logic.o -theories/IntMap/Lsort.o : theories/Init/Datatypes.o -theories/IntMap/Lsort.o : theories/Bool/Bool.o -theories/IntMap/Lsort.o : theories/IntMap/Addr.o -theories/IntMap/Lsort.o : theories/IntMap/Addec.o -theories/IntMap/Mapaxioms.o : theories/IntMap/Mapaxioms.hs -theories/IntMap/Mapcanon.o : theories/IntMap/Mapcanon.hs -theories/IntMap/Mapcanon.o : theories/Init/Specif.o -theories/IntMap/Mapcanon.o : theories/IntMap/Map.o -theories/IntMap/Mapcard.o : theories/IntMap/Mapcard.hs -theories/IntMap/Mapcard.o : theories/Bool/Sumbool.o -theories/IntMap/Mapcard.o : theories/Init/Specif.o -theories/IntMap/Mapcard.o : theories/Arith/Plus.o -theories/IntMap/Mapcard.o : theories/Arith/Peano_dec.o -theories/IntMap/Mapcard.o : theories/Init/Peano.o -theories/IntMap/Mapcard.o : theories/IntMap/Map.o -theories/IntMap/Mapcard.o : theories/Init/Logic.o -theories/IntMap/Mapcard.o : theories/Init/Datatypes.o -theories/IntMap/Mapcard.o : theories/IntMap/Addr.o -theories/IntMap/Mapcard.o : theories/IntMap/Addec.o -theories/IntMap/Mapc.o : theories/IntMap/Mapc.hs -theories/IntMap/Mapfold.o : theories/IntMap/Mapfold.hs -theories/IntMap/Mapfold.o : theories/Init/Specif.o -theories/IntMap/Mapfold.o : theories/IntMap/Mapiter.o -theories/IntMap/Mapfold.o : theories/IntMap/Map.o -theories/IntMap/Mapfold.o : theories/Init/Logic.o -theories/IntMap/Mapfold.o : theories/IntMap/Fset.o -theories/IntMap/Mapfold.o : theories/Init/Datatypes.o -theories/IntMap/Mapfold.o : theories/IntMap/Addr.o -theories/IntMap/Map.o : theories/IntMap/Map.hs -theories/IntMap/Map.o : theories/ZArith/Fast_integer.o -theories/IntMap/Map.o : theories/Init/Specif.o -theories/IntMap/Map.o : theories/Init/Peano.o -theories/IntMap/Map.o : theories/Init/Datatypes.o -theories/IntMap/Map.o : theories/IntMap/Addr.o -theories/IntMap/Map.o : theories/IntMap/Addec.o -theories/IntMap/Mapiter.o : theories/IntMap/Mapiter.hs -theories/IntMap/Mapiter.o : theories/Bool/Sumbool.o -theories/IntMap/Mapiter.o : theories/Init/Specif.o -theories/IntMap/Mapiter.o : theories/Lists/PolyList.o -theories/IntMap/Mapiter.o : theories/IntMap/Map.o -theories/IntMap/Mapiter.o : theories/Init/Logic.o -theories/IntMap/Mapiter.o : theories/Init/Datatypes.o -theories/IntMap/Mapiter.o : theories/IntMap/Addr.o -theories/IntMap/Mapiter.o : theories/IntMap/Addec.o -theories/IntMap/Maplists.o : theories/IntMap/Maplists.hs -theories/IntMap/Maplists.o : theories/Bool/Sumbool.o -theories/IntMap/Maplists.o : theories/Init/Specif.o -theories/IntMap/Maplists.o : theories/Lists/PolyList.o -theories/IntMap/Maplists.o : theories/IntMap/Mapiter.o -theories/IntMap/Maplists.o : theories/IntMap/Map.o -theories/IntMap/Maplists.o : theories/Init/Logic.o -theories/IntMap/Maplists.o : theories/IntMap/Fset.o -theories/IntMap/Maplists.o : theories/Init/Datatypes.o -theories/IntMap/Maplists.o : theories/Bool/Bool.o -theories/IntMap/Maplists.o : theories/IntMap/Addr.o -theories/IntMap/Maplists.o : theories/IntMap/Addec.o -theories/IntMap/Mapsubset.o : theories/IntMap/Mapsubset.hs -theories/IntMap/Mapsubset.o : theories/IntMap/Mapiter.o -theories/IntMap/Mapsubset.o : theories/IntMap/Map.o -theories/IntMap/Mapsubset.o : theories/IntMap/Fset.o -theories/IntMap/Mapsubset.o : theories/Init/Datatypes.o -theories/IntMap/Mapsubset.o : theories/Bool/Bool.o -theories/Lists/ListSet.o : theories/Lists/ListSet.hs -theories/Lists/ListSet.o : theories/Init/Specif.o -theories/Lists/ListSet.o : theories/Lists/PolyList.o -theories/Lists/ListSet.o : theories/Init/Logic.o -theories/Lists/ListSet.o : theories/Init/Datatypes.o -theories/Lists/PolyList.o : theories/Lists/PolyList.hs -theories/Lists/PolyList.o : theories/Init/Specif.o -theories/Lists/PolyList.o : theories/Init/Datatypes.o -theories/Lists/PolyListSyntax.o : theories/Lists/PolyListSyntax.hs -theories/Lists/Streams.o : theories/Lists/Streams.hs -theories/Lists/Streams.o : theories/Init/Datatypes.o -theories/Lists/TheoryList.o : theories/Lists/TheoryList.hs -theories/Lists/TheoryList.o : theories/Init/Specif.o -theories/Lists/TheoryList.o : theories/Lists/PolyList.o -theories/Lists/TheoryList.o : theories/Bool/DecBool.o -theories/Lists/TheoryList.o : theories/Init/Datatypes.o -theories/Logic/Berardi.o : theories/Logic/Berardi.hs -theories/Logic/ClassicalFacts.o : theories/Logic/ClassicalFacts.hs -theories/Logic/Classical.o : theories/Logic/Classical.hs -theories/Logic/Classical_Pred_Set.o : theories/Logic/Classical_Pred_Set.hs -theories/Logic/Classical_Pred_Type.o : theories/Logic/Classical_Pred_Type.hs -theories/Logic/Classical_Prop.o : theories/Logic/Classical_Prop.hs -theories/Logic/Classical_Type.o : theories/Logic/Classical_Type.hs -theories/Logic/Decidable.o : theories/Logic/Decidable.hs -theories/Logic/Eqdep_dec.o : theories/Logic/Eqdep_dec.hs -theories/Logic/Eqdep.o : theories/Logic/Eqdep.hs -theories/Logic/Hurkens.o : theories/Logic/Hurkens.hs -theories/Logic/JMeq.o : theories/Logic/JMeq.hs -theories/Logic/ProofIrrelevance.o : theories/Logic/ProofIrrelevance.hs -theories/Relations/Newman.o : theories/Relations/Newman.hs -theories/Relations/Operators_Properties.o : theories/Relations/Operators_Properties.hs -theories/Relations/Relation_Definitions.o : theories/Relations/Relation_Definitions.hs -theories/Relations/Relation_Operators.o : theories/Relations/Relation_Operators.hs -theories/Relations/Relation_Operators.o : theories/Init/Specif.o -theories/Relations/Relation_Operators.o : theories/Lists/PolyList.o -theories/Relations/Relations.o : theories/Relations/Relations.hs -theories/Relations/Rstar.o : theories/Relations/Rstar.hs -theories/Setoids/Setoid.o : theories/Setoids/Setoid.hs -theories/Sets/Classical_sets.o : theories/Sets/Classical_sets.hs -theories/Sets/Constructive_sets.o : theories/Sets/Constructive_sets.hs -theories/Sets/Cpo.o : theories/Sets/Cpo.hs -theories/Sets/Cpo.o : theories/Sets/Partial_Order.o -theories/Sets/Ensembles.o : theories/Sets/Ensembles.hs -theories/Sets/Finite_sets_facts.o : theories/Sets/Finite_sets_facts.hs -theories/Sets/Finite_sets.o : theories/Sets/Finite_sets.hs -theories/Sets/Image.o : theories/Sets/Image.hs -theories/Sets/Infinite_sets.o : theories/Sets/Infinite_sets.hs -theories/Sets/Integers.o : theories/Sets/Integers.hs -theories/Sets/Integers.o : theories/Sets/Partial_Order.o -theories/Sets/Integers.o : theories/Init/Datatypes.o -theories/Sets/Multiset.o : theories/Sets/Multiset.hs -theories/Sets/Multiset.o : theories/Init/Specif.o -theories/Sets/Multiset.o : theories/Init/Peano.o -theories/Sets/Multiset.o : theories/Init/Datatypes.o -theories/Sets/Partial_Order.o : theories/Sets/Partial_Order.hs -theories/Sets/Permut.o : theories/Sets/Permut.hs -theories/Sets/Powerset_Classical_facts.o : theories/Sets/Powerset_Classical_facts.hs -theories/Sets/Powerset_facts.o : theories/Sets/Powerset_facts.hs -theories/Sets/Powerset.o : theories/Sets/Powerset.hs -theories/Sets/Powerset.o : theories/Sets/Partial_Order.o -theories/Sets/Relations_1_facts.o : theories/Sets/Relations_1_facts.hs -theories/Sets/Relations_1.o : theories/Sets/Relations_1.hs -theories/Sets/Relations_2_facts.o : theories/Sets/Relations_2_facts.hs -theories/Sets/Relations_2.o : theories/Sets/Relations_2.hs -theories/Sets/Relations_3_facts.o : theories/Sets/Relations_3_facts.hs -theories/Sets/Relations_3.o : theories/Sets/Relations_3.hs -theories/Sets/Uniset.o : theories/Sets/Uniset.hs -theories/Sets/Uniset.o : theories/Init/Specif.o -theories/Sets/Uniset.o : theories/Init/Datatypes.o -theories/Sets/Uniset.o : theories/Bool/Bool.o -theories/Sorting/Heap.o : theories/Sorting/Heap.hs -theories/Sorting/Heap.o : theories/Init/Specif.o -theories/Sorting/Heap.o : theories/Sorting/Sorting.o -theories/Sorting/Heap.o : theories/Lists/PolyList.o -theories/Sorting/Heap.o : theories/Sets/Multiset.o -theories/Sorting/Heap.o : theories/Init/Logic.o -theories/Sorting/Permutation.o : theories/Sorting/Permutation.hs -theories/Sorting/Permutation.o : theories/Init/Specif.o -theories/Sorting/Permutation.o : theories/Lists/PolyList.o -theories/Sorting/Permutation.o : theories/Sets/Multiset.o -theories/Sorting/Sorting.o : theories/Sorting/Sorting.hs -theories/Sorting/Sorting.o : theories/Init/Specif.o -theories/Sorting/Sorting.o : theories/Lists/PolyList.o -theories/Sorting/Sorting.o : theories/Init/Logic.o -theories/Wellfounded/Disjoint_Union.o : theories/Wellfounded/Disjoint_Union.hs -theories/Wellfounded/Inclusion.o : theories/Wellfounded/Inclusion.hs -theories/Wellfounded/Inverse_Image.o : theories/Wellfounded/Inverse_Image.hs -theories/Wellfounded/Lexicographic_Exponentiation.o : theories/Wellfounded/Lexicographic_Exponentiation.hs -theories/Wellfounded/Lexicographic_Product.o : theories/Wellfounded/Lexicographic_Product.hs -theories/Wellfounded/Transitive_Closure.o : theories/Wellfounded/Transitive_Closure.hs -theories/Wellfounded/Union.o : theories/Wellfounded/Union.hs -theories/Wellfounded/Wellfounded.o : theories/Wellfounded/Wellfounded.hs -theories/Wellfounded/Well_Ordering.o : theories/Wellfounded/Well_Ordering.hs -theories/Wellfounded/Well_Ordering.o : theories/Init/Wf.o -theories/Wellfounded/Well_Ordering.o : theories/Init/Specif.o -theories/ZArith/Auxiliary.o : theories/ZArith/Auxiliary.hs -theories/ZArith/Fast_integer.o : theories/ZArith/Fast_integer.hs -theories/ZArith/Fast_integer.o : theories/Init/Peano.o -theories/ZArith/Fast_integer.o : theories/Init/Datatypes.o -theories/ZArith/Wf_Z.o : theories/ZArith/Wf_Z.hs -theories/ZArith/Wf_Z.o : theories/ZArith/Zarith_aux.o -theories/ZArith/Wf_Z.o : theories/ZArith/Fast_integer.o -theories/ZArith/Wf_Z.o : theories/Init/Specif.o -theories/ZArith/Wf_Z.o : theories/Init/Peano.o -theories/ZArith/Wf_Z.o : theories/Init/Logic.o -theories/ZArith/Wf_Z.o : theories/Init/Datatypes.o -theories/ZArith/Zarith_aux.o : theories/ZArith/Zarith_aux.hs -theories/ZArith/Zarith_aux.o : theories/ZArith/Fast_integer.o -theories/ZArith/Zarith_aux.o : theories/Init/Specif.o -theories/ZArith/Zarith_aux.o : theories/Init/Datatypes.o -theories/ZArith/ZArith_base.o : theories/ZArith/ZArith_base.hs -theories/ZArith/ZArith_dec.o : theories/ZArith/ZArith_dec.hs -theories/ZArith/ZArith_dec.o : theories/ZArith/Fast_integer.o -theories/ZArith/ZArith_dec.o : theories/Bool/Sumbool.o -theories/ZArith/ZArith_dec.o : theories/Init/Specif.o -theories/ZArith/ZArith_dec.o : theories/Init/Logic.o -theories/ZArith/ZArith.o : theories/ZArith/ZArith.hs -theories/ZArith/Zbool.o : theories/ZArith/Zbool.hs -theories/ZArith/Zbool.o : theories/ZArith/Fast_integer.o -theories/ZArith/Zbool.o : theories/ZArith/Zmisc.o -theories/ZArith/Zbool.o : theories/ZArith/ZArith_dec.o -theories/ZArith/Zbool.o : theories/Bool/Sumbool.o -theories/ZArith/Zbool.o : theories/Init/Specif.o -theories/ZArith/Zbool.o : theories/Init/Datatypes.o -theories/ZArith/Zcomplements.o : theories/ZArith/Zcomplements.hs -theories/ZArith/Zcomplements.o : theories/ZArith/Zarith_aux.o -theories/ZArith/Zcomplements.o : theories/ZArith/Fast_integer.o -theories/ZArith/Zcomplements.o : theories/ZArith/Wf_Z.o -theories/ZArith/Zcomplements.o : theories/Init/Specif.o -theories/ZArith/Zcomplements.o : theories/Init/Logic.o -theories/ZArith/Zcomplements.o : theories/Init/Datatypes.o -theories/ZArith/Zdiv.o : theories/ZArith/Zdiv.hs -theories/ZArith/Zdiv.o : theories/ZArith/Zarith_aux.o -theories/ZArith/Zdiv.o : theories/ZArith/Fast_integer.o -theories/ZArith/Zdiv.o : theories/ZArith/Zmisc.o -theories/ZArith/Zdiv.o : theories/ZArith/ZArith_dec.o -theories/ZArith/Zdiv.o : theories/Init/Specif.o -theories/ZArith/Zdiv.o : theories/Init/Logic.o -theories/ZArith/Zdiv.o : theories/Init/Datatypes.o -theories/ZArith/Zhints.o : theories/ZArith/Zhints.hs -theories/ZArith/Zlogarithm.o : theories/ZArith/Zlogarithm.hs -theories/ZArith/Zlogarithm.o : theories/ZArith/Zarith_aux.o -theories/ZArith/Zlogarithm.o : theories/ZArith/Fast_integer.o -theories/ZArith/Zmisc.o : theories/ZArith/Zmisc.hs -theories/ZArith/Zmisc.o : theories/ZArith/Fast_integer.o -theories/ZArith/Zmisc.o : theories/Init/Specif.o -theories/ZArith/Zmisc.o : theories/Init/Datatypes.o -theories/ZArith/Zpower.o : theories/ZArith/Zpower.hs -theories/ZArith/Zpower.o : theories/ZArith/Zarith_aux.o -theories/ZArith/Zpower.o : theories/ZArith/Fast_integer.o -theories/ZArith/Zpower.o : theories/ZArith/Zmisc.o -theories/ZArith/Zpower.o : theories/Init/Logic.o -theories/ZArith/Zpower.o : theories/Init/Datatypes.o -theories/ZArith/Zsqrt.o : theories/ZArith/Zsqrt.hs -theories/ZArith/Zsqrt.o : theories/ZArith/Zarith_aux.o -theories/ZArith/Zsqrt.o : theories/ZArith/Fast_integer.o -theories/ZArith/Zsqrt.o : theories/ZArith/ZArith_dec.o -theories/ZArith/Zsqrt.o : theories/Init/Specif.o -theories/ZArith/Zsqrt.o : theories/Init/Logic.o -theories/ZArith/Zwf.o : theories/ZArith/Zwf.hs -# DO NOT DELETE: End of Haskell dependencies diff --git a/contrib/extraction/test/addReals b/contrib/extraction/test/addReals deleted file mode 100644 index fb73d47b..00000000 --- a/contrib/extraction/test/addReals +++ /dev/null @@ -1,21 +0,0 @@ -open TypeSyntax -open Fast_integer - - -let total_order_T x y = -if x = y then InleftT RightT -else if x < y then InleftT LeftT -else InrightT - -let rec int_to_positive i = - if i = 1 then XH - else - if (i mod 2) = 0 then XO (int_to_positive (i/2)) - else XI (int_to_positive (i/2)) - -let rec int_to_Z i = - if i = 0 then ZERO - else if i > 0 then POS (int_to_positive i) - else NEG (int_to_positive (-i)) - -let my_ceil x = int_to_Z (succ (int_of_float (floor x))) diff --git a/contrib/extraction/test/custom/Adalloc b/contrib/extraction/test/custom/Adalloc deleted file mode 100644 index e7204838..00000000 --- a/contrib/extraction/test/custom/Adalloc +++ /dev/null @@ -1,2 +0,0 @@ -Require Import BinNat. -Extraction NoInline Ndouble Ndouble_plus_one. diff --git a/contrib/extraction/test/custom/Euclid b/contrib/extraction/test/custom/Euclid deleted file mode 100644 index a58e3940..00000000 --- a/contrib/extraction/test/custom/Euclid +++ /dev/null @@ -1 +0,0 @@ -Extraction Inline Wf_nat.gt_wf_rec Wf_nat.lt_wf_rec. diff --git a/contrib/extraction/test/custom/List b/contrib/extraction/test/custom/List deleted file mode 100644 index ffee7dc9..00000000 --- a/contrib/extraction/test/custom/List +++ /dev/null @@ -1 +0,0 @@ -Extraction NoInline map. diff --git a/contrib/extraction/test/custom/ListSet b/contrib/extraction/test/custom/ListSet deleted file mode 100644 index c9bea52a..00000000 --- a/contrib/extraction/test/custom/ListSet +++ /dev/null @@ -1 +0,0 @@ -Extraction NoInline set_add set_mem. diff --git a/contrib/extraction/test/custom/Lsort b/contrib/extraction/test/custom/Lsort deleted file mode 100644 index 22ab18e3..00000000 --- a/contrib/extraction/test/custom/Lsort +++ /dev/null @@ -1,2 +0,0 @@ -Require Import BinNat. -Extraction NoInline Ndouble Ndouble_plus_one. diff --git a/contrib/extraction/test/custom/Map b/contrib/extraction/test/custom/Map deleted file mode 100644 index f024dbd7..00000000 --- a/contrib/extraction/test/custom/Map +++ /dev/null @@ -1,3 +0,0 @@ -Require Import BinNat. -Extraction NoInline Ndouble Ndouble_plus_one. - diff --git a/contrib/extraction/test/custom/Mapcard b/contrib/extraction/test/custom/Mapcard deleted file mode 100644 index 5932cf7b..00000000 --- a/contrib/extraction/test/custom/Mapcard +++ /dev/null @@ -1,4 +0,0 @@ -Require Import Plus. -Extraction NoInline plus_is_one. -Require Import BinNat. -Extraction NoInline Ndouble Ndouble_plus_one. diff --git a/contrib/extraction/test/custom/Mapiter b/contrib/extraction/test/custom/Mapiter deleted file mode 100644 index 22ab18e3..00000000 --- a/contrib/extraction/test/custom/Mapiter +++ /dev/null @@ -1,2 +0,0 @@ -Require Import BinNat. -Extraction NoInline Ndouble Ndouble_plus_one. diff --git a/contrib/extraction/test/custom/R_Ifp b/contrib/extraction/test/custom/R_Ifp deleted file mode 100644 index d8f1b3e7..00000000 --- a/contrib/extraction/test/custom/R_Ifp +++ /dev/null @@ -1,2 +0,0 @@ -Load "custom/Reals". - diff --git a/contrib/extraction/test/custom/R_sqr b/contrib/extraction/test/custom/R_sqr deleted file mode 100644 index d8f1b3e7..00000000 --- a/contrib/extraction/test/custom/R_sqr +++ /dev/null @@ -1,2 +0,0 @@ -Load "custom/Reals". - diff --git a/contrib/extraction/test/custom/Ranalysis b/contrib/extraction/test/custom/Ranalysis deleted file mode 100644 index d8f1b3e7..00000000 --- a/contrib/extraction/test/custom/Ranalysis +++ /dev/null @@ -1,2 +0,0 @@ -Load "custom/Reals". - diff --git a/contrib/extraction/test/custom/Raxioms b/contrib/extraction/test/custom/Raxioms deleted file mode 100644 index d8f1b3e7..00000000 --- a/contrib/extraction/test/custom/Raxioms +++ /dev/null @@ -1,2 +0,0 @@ -Load "custom/Reals". - diff --git a/contrib/extraction/test/custom/Rbase b/contrib/extraction/test/custom/Rbase deleted file mode 100644 index d8f1b3e7..00000000 --- a/contrib/extraction/test/custom/Rbase +++ /dev/null @@ -1,2 +0,0 @@ -Load "custom/Reals". - diff --git a/contrib/extraction/test/custom/Rbasic_fun b/contrib/extraction/test/custom/Rbasic_fun deleted file mode 100644 index d8f1b3e7..00000000 --- a/contrib/extraction/test/custom/Rbasic_fun +++ /dev/null @@ -1,2 +0,0 @@ -Load "custom/Reals". - diff --git a/contrib/extraction/test/custom/Rdefinitions b/contrib/extraction/test/custom/Rdefinitions deleted file mode 100644 index d8f1b3e7..00000000 --- a/contrib/extraction/test/custom/Rdefinitions +++ /dev/null @@ -1,2 +0,0 @@ -Load "custom/Reals". - diff --git a/contrib/extraction/test/custom/Reals.v b/contrib/extraction/test/custom/Reals.v deleted file mode 100644 index 45d0a224..00000000 --- a/contrib/extraction/test/custom/Reals.v +++ /dev/null @@ -1,17 +0,0 @@ -Require Import Reals. -Extract Inlined Constant R => float. -Extract Inlined Constant R0 => "0.0". -Extract Inlined Constant R1 => "1.0". -Extract Inlined Constant Rplus => "(+.)". -Extract Inlined Constant Rmult => "( *.)". -Extract Inlined Constant Ropp => "(~-.)". -Extract Inlined Constant Rinv => "(fun x -> 1.0 /. x)". -Extract Inlined Constant Rlt => "(<)". -Extract Inlined Constant up => "AddReals.my_ceil". -Extract Inlined Constant total_order_T => "AddReals.total_order_T". -Extract Inlined Constant sqrt => "sqrt". -Extract Inlined Constant sigma => "(fun l h -> sigma_aux l h (Minus.minus h l))". -Extract Inlined Constant PI => "3.141593". -Extract Inlined Constant cos => cos. -Extract Inlined Constant sin => sin. -Extract Inlined Constant derive_pt => "(fun f x -> ((f (x+.1E-5))-.(f x))*.1E5)". diff --git a/contrib/extraction/test/custom/Rfunctions b/contrib/extraction/test/custom/Rfunctions deleted file mode 100644 index d8f1b3e7..00000000 --- a/contrib/extraction/test/custom/Rfunctions +++ /dev/null @@ -1,2 +0,0 @@ -Load "custom/Reals". - diff --git a/contrib/extraction/test/custom/Rgeom b/contrib/extraction/test/custom/Rgeom deleted file mode 100644 index d8f1b3e7..00000000 --- a/contrib/extraction/test/custom/Rgeom +++ /dev/null @@ -1,2 +0,0 @@ -Load "custom/Reals". - diff --git a/contrib/extraction/test/custom/Rlimit b/contrib/extraction/test/custom/Rlimit deleted file mode 100644 index d8f1b3e7..00000000 --- a/contrib/extraction/test/custom/Rlimit +++ /dev/null @@ -1,2 +0,0 @@ -Load "custom/Reals". - diff --git a/contrib/extraction/test/custom/Rseries b/contrib/extraction/test/custom/Rseries deleted file mode 100644 index d8f1b3e7..00000000 --- a/contrib/extraction/test/custom/Rseries +++ /dev/null @@ -1,2 +0,0 @@ -Load "custom/Reals". - diff --git a/contrib/extraction/test/custom/Rsigma b/contrib/extraction/test/custom/Rsigma deleted file mode 100644 index d8f1b3e7..00000000 --- a/contrib/extraction/test/custom/Rsigma +++ /dev/null @@ -1,2 +0,0 @@ -Load "custom/Reals". - diff --git a/contrib/extraction/test/custom/Rtrigo b/contrib/extraction/test/custom/Rtrigo deleted file mode 100644 index d8f1b3e7..00000000 --- a/contrib/extraction/test/custom/Rtrigo +++ /dev/null @@ -1,2 +0,0 @@ -Load "custom/Reals". - diff --git a/contrib/extraction/test/custom/ZArith_dec b/contrib/extraction/test/custom/ZArith_dec deleted file mode 100644 index 2201419e..00000000 --- a/contrib/extraction/test/custom/ZArith_dec +++ /dev/null @@ -1 +0,0 @@ -Extraction Inline Dcompare_inf Zcompare_rec. diff --git a/contrib/extraction/test/custom/fast_integer b/contrib/extraction/test/custom/fast_integer deleted file mode 100644 index e2b24953..00000000 --- a/contrib/extraction/test/custom/fast_integer +++ /dev/null @@ -1 +0,0 @@ -Extraction NoInline Zero_suivi_de Un_suivi_de. diff --git a/contrib/extraction/test/e b/contrib/extraction/test/e deleted file mode 100644 index 88b6c90b..00000000 --- a/contrib/extraction/test/e +++ /dev/null @@ -1,17 +0,0 @@ - -(* To trace Extraction, you can use this file via: *) -(* Drop. #use "e";; *) -(* *) - -#use "include";; -open Extraction;; -open Miniml;; -#trace extract_declaration;; -go();; - - - - - - - diff --git a/contrib/extraction/test/extract b/contrib/extraction/test/extract deleted file mode 100755 index 83444be3..00000000 --- a/contrib/extraction/test/extract +++ /dev/null @@ -1,12 +0,0 @@ -#!/bin/sh -rm -f /tmp/extr$$.v -vfile=`./ml2v $1` -d=`dirname $vfile` -n=`basename $vfile .v` -if [ -e custom/$n ]; then cat custom/$n > /tmp/extr$$.v; fi -echo "Cd \"$d\". Extraction Library $n. " >> /tmp/extr$$.v -../../../bin/coqtop.opt -silent -batch -require $n -load-vernac-source /tmp/extr$$.v -out=$? -rm -f /tmp/extr$$.v -exit $out - diff --git a/contrib/extraction/test/extract.haskell b/contrib/extraction/test/extract.haskell deleted file mode 100755 index d11bc706..00000000 --- a/contrib/extraction/test/extract.haskell +++ /dev/null @@ -1,12 +0,0 @@ -#!/bin/sh -rm -f /tmp/extr$$.v -vfile=`./hs2v $1` -d=`dirname $vfile` -n=`basename $vfile .v` -if [ -e custom/$n ]; then cat custom/$n > /tmp/extr$$.v; fi -echo "Cd \"$d\". Extraction Language Haskell. Extraction Library $n. " >> /tmp/extr$$.v -../../../bin/coqtop.opt -silent -batch -require $n -load-vernac-source /tmp/extr$$.v -out=$? -rm -f /tmp/extr$$.v -exit $out - diff --git a/contrib/extraction/test/hs2v.ml b/contrib/extraction/test/hs2v.ml deleted file mode 100644 index fd8b9b26..00000000 --- a/contrib/extraction/test/hs2v.ml +++ /dev/null @@ -1,14 +0,0 @@ -let _ = - for j = 1 to ((Array.length Sys.argv)-1) do - let fml = Sys.argv.(j) in - let f = Filename.chop_extension fml in - let fv = f ^ ".v" in - if Sys.file_exists ("../../../" ^ fv) then - print_string (fv^" ") - else - let d = Filename.dirname f in - let b = String.uncapitalize (Filename.basename f) in - let fv = Filename.concat d (b ^ ".v ") in - print_string fv - done; - print_newline() diff --git a/contrib/extraction/test/make_mli b/contrib/extraction/test/make_mli deleted file mode 100755 index 40ee496e..00000000 --- a/contrib/extraction/test/make_mli +++ /dev/null @@ -1,17 +0,0 @@ -#!/usr/bin/awk -We $0 - -{ match($0,"^open") - if (RLENGTH>0) state=1 - match($0,"^type") - if (RLENGTH>0) state=1 - match($0,"^\(\*\* ") - if (RLENGTH>0) state=2 - match($0,"^let") - if (RLENGTH>0) state=0 - match($0,"^and") - if ((RLENGTH>0) && (state==2)) state=0 - if ((RLENGTH>0) && (state==1)) state=1 - gsub("\(\*\* ","") - gsub("\*\*\)","") - if (state>0) print -} diff --git a/contrib/extraction/test/ml2v.ml b/contrib/extraction/test/ml2v.ml deleted file mode 100644 index 363ea642..00000000 --- a/contrib/extraction/test/ml2v.ml +++ /dev/null @@ -1,14 +0,0 @@ -let _ = - for j = 1 to ((Array.length Sys.argv)-1) do - let fml = Sys.argv.(j) in - let f = Filename.chop_extension fml in - let fv = f ^ ".v" in - if Sys.file_exists ("../../../" ^ fv) then - print_string (fv^" ") - else - let d = Filename.dirname f in - let b = String.capitalize (Filename.basename f) in - let fv = Filename.concat d (b ^ ".v ") in - print_string fv - done; - print_newline() diff --git a/contrib/extraction/test/v2hs.ml b/contrib/extraction/test/v2hs.ml deleted file mode 100644 index 88632875..00000000 --- a/contrib/extraction/test/v2hs.ml +++ /dev/null @@ -1,9 +0,0 @@ -let _ = - for j = 1 to ((Array.length Sys.argv) -1) do - let s = Sys.argv.(j) in - let b = Filename.chop_extension (Filename.basename s) in - let b = String.capitalize b in - let d = Filename.dirname s in - print_string (Filename.concat d (b ^ ".hs ")) - done; - print_newline() diff --git a/contrib/extraction/test/v2ml.ml b/contrib/extraction/test/v2ml.ml deleted file mode 100644 index 245a1b1e..00000000 --- a/contrib/extraction/test/v2ml.ml +++ /dev/null @@ -1,9 +0,0 @@ -let _ = - for j = 1 to ((Array.length Sys.argv) -1) do - let s = Sys.argv.(j) in - let b = Filename.chop_extension (Filename.basename s) in - let b = String.uncapitalize b in - let d = Filename.dirname s in - print_string (Filename.concat d (b ^ ".ml ")) - done; - print_newline() diff --git a/contrib/field/field.ml4 b/contrib/field/field.ml4 index dab5a45c..dea79773 100644 --- a/contrib/field/field.ml4 +++ b/contrib/field/field.ml4 @@ -8,7 +8,7 @@ (*i camlp4deps: "parsing/grammar.cma" i*) -(* $Id: field.ml4 9273 2006-10-25 11:30:36Z barras $ *) +(* $Id: field.ml4 10076 2007-08-16 11:16:43Z notin $ *) open Names open Pp @@ -159,7 +159,7 @@ let field g = | Some (eq,t::args) when eq = (Coqlib.build_coq_eq_data()).Coqlib.eq -> t | _ -> error "The statement is not built from Leibniz' equality" in let th = VConstr (lookup (pf_env g) typ) in - (interp_tac_gen [(id_of_string "FT",th)] (get_debug ()) + (interp_tac_gen [(id_of_string "FT",th)] [] (get_debug ()) <:tactic< match goal with |- (@eq _ _ _) => field_gen FT end >>) g (* Verifies that all the terms have the same type and gives the right theory *) diff --git a/contrib/first-order/formula.ml b/contrib/firstorder/formula.ml index 0be468aa..3e49cd9c 100644 --- a/contrib/first-order/formula.ml +++ b/contrib/firstorder/formula.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: formula.ml 9154 2006-09-20 17:18:18Z corbinea $ *) +(* $Id: formula.ml 10785 2008-04-13 21:41:54Z herbelin $ *) open Hipattern open Names @@ -120,7 +120,7 @@ type side = Hyp | Concl | Hint let no_atoms = (false,{positive=[];negative=[]}) -let dummy_id=VarRef (id_of_string "") +let dummy_id=VarRef (id_of_string "_") (* "_" cannot be parsed *) let build_atoms gl metagen side cciterm = let trivial =ref false diff --git a/contrib/first-order/formula.mli b/contrib/firstorder/formula.mli index 8703045c..8703045c 100644 --- a/contrib/first-order/formula.mli +++ b/contrib/firstorder/formula.mli diff --git a/contrib/first-order/g_ground.ml4 b/contrib/firstorder/g_ground.ml4 index 366f563b..f7b0a546 100644 --- a/contrib/first-order/g_ground.ml4 +++ b/contrib/firstorder/g_ground.ml4 @@ -8,7 +8,7 @@ (*i camlp4deps: "parsing/grammar.cma" i*) -(* $Id: g_ground.ml4 9154 2006-09-20 17:18:18Z corbinea $ *) +(* $Id: g_ground.ml4 10346 2007-12-05 21:11:19Z aspiwack $ *) open Formula open Sequent @@ -97,23 +97,24 @@ let normalize_evaluables= (Tacexpr.InHypType id)) *) TACTIC EXTEND firstorder - [ "firstorder" tactic_opt(t) "with" ne_reference_list(l) ] -> - [ gen_ground_tac true (option_map eval_tactic t) (Ids l) ] -| [ "firstorder" tactic_opt(t) "using" ne_preident_list(l) ] -> - [ gen_ground_tac true (option_map eval_tactic t) (Bases l) ] + [ "firstorder" tactic_opt(t) "using" ne_reference_list(l) ] -> + [ gen_ground_tac true (Option.map eval_tactic t) (Ids l) ] +| [ "firstorder" tactic_opt(t) "with" ne_preident_list(l) ] -> + [ gen_ground_tac true (Option.map eval_tactic t) (Bases l) ] | [ "firstorder" tactic_opt(t) ] -> - [ gen_ground_tac true (option_map eval_tactic t) Void ] + [ gen_ground_tac true (Option.map eval_tactic t) Void ] END TACTIC EXTEND gintuition [ "gintuition" tactic_opt(t) ] -> - [ gen_ground_tac false (option_map eval_tactic t) Void ] + [ gen_ground_tac false (Option.map eval_tactic t) Void ] END let default_declarative_automation gls = - tclORELSE - (Cctac.congruence_tac !congruence_depth []) + tclORELSE + (tclORELSE (Auto.h_trivial [] None) + (Cctac.congruence_tac !congruence_depth [])) (gen_ground_tac true (Some (tclTHEN default_solver diff --git a/contrib/first-order/ground.ml b/contrib/firstorder/ground.ml index bccac6df..f4661869 100644 --- a/contrib/first-order/ground.ml +++ b/contrib/firstorder/ground.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: ground.ml 9537 2007-01-26 10:05:04Z corbinea $ *) +(* $Id: ground.ml 9549 2007-01-28 23:30:12Z corbinea $ *) open Formula open Sequent diff --git a/contrib/first-order/ground.mli b/contrib/firstorder/ground.mli index 621f99db..621f99db 100644 --- a/contrib/first-order/ground.mli +++ b/contrib/firstorder/ground.mli diff --git a/contrib/first-order/instances.ml b/contrib/firstorder/instances.ml index 254d7b84..1432207d 100644 --- a/contrib/first-order/instances.ml +++ b/contrib/firstorder/instances.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: instances.ml 8654 2006-03-22 15:36:58Z msozeau $ i*) +(*i $Id: instances.ml 10410 2007-12-31 13:11:55Z msozeau $ i*) open Formula open Sequent @@ -125,9 +125,9 @@ let mk_open_instance id gl m t= let rec raux n t= if n=0 then t else match t with - RLambda(loc,name,_,t0)-> + RLambda(loc,name,k,_,t0)-> let t1=raux (n-1) t0 in - RLambda(loc,name,RHole (dummy_loc,Evd.BinderType name),t1) + RLambda(loc,name,k,RHole (dummy_loc,Evd.BinderType name),t1) | _-> anomaly "can't happen" in let ntt=try Pretyping.Default.understand evmap env (raux m rawt) diff --git a/contrib/first-order/instances.mli b/contrib/firstorder/instances.mli index 7667c89f..7667c89f 100644 --- a/contrib/first-order/instances.mli +++ b/contrib/firstorder/instances.mli diff --git a/contrib/first-order/rules.ml b/contrib/firstorder/rules.ml index 6c51eda3..b8b56548 100644 --- a/contrib/first-order/rules.ml +++ b/contrib/firstorder/rules.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: rules.ml 8878 2006-05-30 16:44:25Z herbelin $ *) +(* $Id: rules.ml 11094 2008-06-10 19:35:23Z herbelin $ *) open Util open Names @@ -78,7 +78,7 @@ let and_tac backtrack continue seq= let or_tac backtrack continue seq= tclORELSE - (any_constructor (Some (tclCOMPLETE (wrap 0 true continue seq)))) + (any_constructor false (Some (tclCOMPLETE (wrap 0 true continue seq)))) backtrack let arrow_tac backtrack continue seq= @@ -204,8 +204,8 @@ let ll_forall_tac prod backtrack id continue seq= let constant str = Coqlib.gen_constant "User" ["Init";"Logic"] str let defined_connectives=lazy - [[],EvalConstRef (destConst (constant "not")); - [],EvalConstRef (destConst (constant "iff"))] + [all_occurrences,EvalConstRef (destConst (constant "not")); + all_occurrences,EvalConstRef (destConst (constant "iff"))] let normalize_evaluables= onAllClauses @@ -213,4 +213,4 @@ let normalize_evaluables= None->unfold_in_concl (Lazy.force defined_connectives) | Some ((_,id),_)-> unfold_in_hyp (Lazy.force defined_connectives) - (([],id),Tacexpr.InHypTypeOnly)) + ((Rawterm.all_occurrences_expr,id),Tacexpr.InHypTypeOnly)) diff --git a/contrib/first-order/rules.mli b/contrib/firstorder/rules.mli index 3798d8d4..3798d8d4 100644 --- a/contrib/first-order/rules.mli +++ b/contrib/firstorder/rules.mli diff --git a/contrib/first-order/sequent.ml b/contrib/firstorder/sequent.ml index 805700b0..c832d30f 100644 --- a/contrib/first-order/sequent.ml +++ b/contrib/firstorder/sequent.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: sequent.ml 7925 2006-01-24 23:20:39Z herbelin $ *) +(* $Id: sequent.ml 10824 2008-04-21 13:57:03Z msozeau $ *) open Term open Util @@ -281,7 +281,7 @@ let create_with_auto_hints l depth gl= searchtable_map dbname with Not_found-> error ("Firstorder: "^dbname^" : No such Hint database") in - Hint_db.iter g hdb in + Hint_db.iter g (snd hdb) in List.iter h l; !seqref diff --git a/contrib/first-order/sequent.mli b/contrib/firstorder/sequent.mli index 47fb74c7..47fb74c7 100644 --- a/contrib/first-order/sequent.mli +++ b/contrib/firstorder/sequent.mli diff --git a/contrib/first-order/unify.ml b/contrib/firstorder/unify.ml index 1dd13cbe..1dd13cbe 100644 --- a/contrib/first-order/unify.ml +++ b/contrib/firstorder/unify.ml diff --git a/contrib/first-order/unify.mli b/contrib/firstorder/unify.mli index 9fbe3dda..9fbe3dda 100644 --- a/contrib/first-order/unify.mli +++ b/contrib/firstorder/unify.mli diff --git a/contrib/fourier/Fourier_util.v b/contrib/fourier/Fourier_util.v index c3257b7d..6a9ab051 100644 --- a/contrib/fourier/Fourier_util.v +++ b/contrib/fourier/Fourier_util.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: Fourier_util.v 5920 2004-07-16 20:01:26Z herbelin $ *) +(* $Id: Fourier_util.v 10710 2008-03-23 09:24:09Z herbelin $ *) Require Export Rbase. Comments "Lemmas used by the tactic Fourier". @@ -152,7 +152,7 @@ apply Rlt_irrefl. ring. Qed. -Lemma Rlt_not_le : forall n d:R, 0 < n * / d -> ~ 0 <= - n * / d. +Lemma Rlt_not_le_frac_opp : forall n d:R, 0 < n * / d -> ~ 0 <= - n * / d. intros n d H; try assumption. apply Rgt_not_le. replace 0 with (-0). diff --git a/contrib/fourier/fourierR.ml b/contrib/fourier/fourierR.ml index f9518bcb..114d5f9c 100644 --- a/contrib/fourier/fourierR.ml +++ b/contrib/fourier/fourierR.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: fourierR.ml 7760 2005-12-30 10:49:13Z herbelin $ *) +(* $Id: fourierR.ml 10790 2008-04-14 22:34:19Z herbelin $ *) @@ -258,11 +258,11 @@ let fourier_lineq lineq1 = let nvar=ref (-1) in let hvar=Hashtbl.create 50 in (* la table des variables des inéquations *) List.iter (fun f -> - Hashtbl.iter (fun x c -> - try (Hashtbl.find hvar x;()) - with _-> nvar:=(!nvar)+1; - Hashtbl.add hvar x (!nvar)) - f.hflin.fhom) + Hashtbl.iter (fun x _ -> if not (Hashtbl.mem hvar x) then begin + nvar:=(!nvar)+1; + Hashtbl.add hvar x (!nvar) + end) + f.hflin.fhom) lineq1; let sys= List.map (fun h-> let v=Array.create ((!nvar)+1) r0 in @@ -334,7 +334,7 @@ let coq_Rfourier_le_lt = lazy (constant_fourier "Rfourier_le_lt") let coq_Rfourier_le_le = lazy (constant_fourier "Rfourier_le_le") let coq_Rnot_lt_lt = lazy (constant_fourier "Rnot_lt_lt") let coq_Rnot_le_le = lazy (constant_fourier "Rnot_le_le") -let coq_Rlt_not_le = lazy (constant_fourier "Rlt_not_le") +let coq_Rlt_not_le_frac_opp = lazy (constant_fourier "Rlt_not_le_frac_opp") (****************************************************************************** Construction de la preuve en cas de succès de la méthode de Fourier, @@ -404,7 +404,7 @@ let tac_zero_inf_false gl (n,d) = (* preuve que 0<=(-n)*(1/d) => False *) let tac_zero_infeq_false gl (n,d) = - (tclTHEN (apply (get coq_Rlt_not_le)) + (tclTHEN (apply (get coq_Rlt_not_le_frac_opp)) (tac_zero_inf_pos gl (-n,d))) ;; @@ -492,7 +492,7 @@ let rec fourier gl= in tac gl) with _ -> (* les hypothèses *) - let hyps = List.map (fun (h,t)-> (mkVar h,(body_of_type t))) + let hyps = List.map (fun (h,t)-> (mkVar h,t)) (list_of_sign (pf_hyps gl)) in let lineq =ref [] in List.iter (fun h -> try (lineq:=(ineq1_of_constr h)@(!lineq)) @@ -503,8 +503,7 @@ let rec fourier gl= let res=fourier_lineq (!lineq) in let tac=ref tclIDTAC in if res=[] - then (print_string "Tactic Fourier fails.\n"; - flush stdout) + then Util.error "fourier failed" (* l'algorithme de Fourier a réussi: on va en tirer une preuve Coq *) else (match res with [(cres,sres,lc)]-> diff --git a/contrib/recdef/Recdef.v b/contrib/funind/Recdef.v index 2d206220..2d206220 100644 --- a/contrib/recdef/Recdef.v +++ b/contrib/funind/Recdef.v diff --git a/contrib/funind/functional_principles_proofs.ml b/contrib/funind/functional_principles_proofs.ml index 975cf60b..3d80bd00 100644 --- a/contrib/funind/functional_principles_proofs.ml +++ b/contrib/funind/functional_principles_proofs.ml @@ -47,7 +47,7 @@ let observe_tac_stream s tac g = let observe_tac s tac g = observe_tac_stream (str s) tac g (* let tclTRYD tac = *) -(* if !Options.debug || do_observe () *) +(* if !Flags.debug || do_observe () *) (* then (fun g -> try (\* do_observe_tac "" *\)tac g with _ -> tclIDTAC g) *) (* else tac *) @@ -140,7 +140,7 @@ let change_hyp_with_using msg hyp_id t tac : tactic = [tclTHENLIST [ (* observe_tac "change_hyp_with_using thin" *) (thin [hyp_id]); - (* observe_tac "change_hyp_with_using rename " *) (h_rename prov_id hyp_id) + (* observe_tac "change_hyp_with_using rename " *) (h_rename [prov_id,hyp_id]) ]] g exception TOREMOVE @@ -573,7 +573,7 @@ let instanciate_hyps_with_args (do_prove:identifier list -> tactic) hyps args_id tclTHENLIST[ forward None (Genarg.IntroIdentifier prov_hid) (mkApp(mkVar hid,args)); thin [hid]; - (h_rename prov_hid hid) + h_rename [prov_hid,hid] ] g ) ( (* @@ -637,7 +637,7 @@ let build_proof [ h_generalize (term_eq::(List.map mkVar dyn_infos.rec_hyps)); thin dyn_infos.rec_hyps; - pattern_option [[-1],t] None; + pattern_option [(false,[1]),t] None; h_simplest_case t; (fun g' -> let g'_nb_prod = nb_prod (pf_concl g') in @@ -882,7 +882,7 @@ let generate_equation_lemma fnames f fun_num nb_params nb_args rec_args_num = let f_def = Global.lookup_constant (destConst f) in let eq_lhs = mkApp(f,Array.init (nb_params + nb_args) (fun i -> mkRel(nb_params + nb_args - i))) in let f_body = - force (out_some f_def.const_body) + force (Option.get f_def.const_body) in let params,f_body_with_params = decompose_lam_n nb_params f_body in let (_,num),(_,_,bodies) = destFix f_body_with_params in @@ -910,7 +910,7 @@ let generate_equation_lemma fnames f fun_num nb_params nb_args rec_args_num = let rec_id = pf_nth_hyp_id g 1 in tclTHENSEQ [(* observe_tac "generalize_non_dep in generate_equation_lemma" *) (generalize_non_dep rec_id); - (* observe_tac "h_case" *) (h_case (mkVar rec_id,Rawterm.NoBindings)); + (* observe_tac "h_case" *) (h_case false (mkVar rec_id,Rawterm.NoBindings)); intros_reflexivity] g ) ] @@ -933,8 +933,8 @@ let do_replace params rec_arg_num rev_args_id f fun_num all_funs g = let equation_lemma = try let finfos = find_Function_infos (destConst f) in - mkConst (out_some finfos.equation_lemma) - with (Not_found | Failure "out_some" as e) -> + mkConst (Option.get finfos.equation_lemma) + with (Not_found | Option.IsNone as e) -> let f_id = id_of_label (con_label (destConst f)) in (*i The next call to mk_equation_id is valid since we will construct the lemma Ensures by: obvious @@ -943,7 +943,7 @@ let do_replace params rec_arg_num rev_args_id f fun_num all_funs g = generate_equation_lemma all_funs f fun_num (List.length params) (List.length rev_args_id) rec_arg_num; let _ = match e with - | Failure "out_some" -> + | Option.IsNone -> let finfos = find_Function_infos (destConst f) in update_Function {finfos with @@ -1141,7 +1141,7 @@ let prove_princ_for_struct interactive_proof fun_num fnames all_funs _nparams : then (* observe_tac ("h_fix") *) (h_fix (Some this_fix_info.name) (this_fix_info.idx +1)) else - h_mutual_fix this_fix_info.name (this_fix_info.idx + 1) + h_mutual_fix false this_fix_info.name (this_fix_info.idx + 1) other_fix_infos | _ -> anomaly "Not a valid information" in @@ -1246,7 +1246,7 @@ let prove_princ_for_struct interactive_proof fun_num fnames all_funs _nparams : in let fname = destConst (fst (decompose_app (List.hd (List.rev pte_args)))) in tclTHENSEQ - [unfold_in_concl [([],Names.EvalConstRef fname)]; + [unfold_in_concl [(all_occurrences,Names.EvalConstRef fname)]; let do_prove = build_proof interactive_proof @@ -1347,19 +1347,27 @@ let build_clause eqs = { Tacexpr.onhyps = Some (List.map - (fun id -> ([],id),Tacexpr.InHyp) + (fun id -> (Rawterm.all_occurrences_expr,id),Tacexpr.InHyp) eqs ); - Tacexpr.onconcl = false; - Tacexpr.concl_occs = [] + Tacexpr.concl_occs = Rawterm.no_occurrences_expr } let rec rewrite_eqs_in_eqs eqs = match eqs with | [] -> tclIDTAC | eq::eqs -> + tclTHEN - (tclMAP (fun id -> tclTRY (Equality.general_rewrite_in true id (mkVar eq))) eqs) + (tclMAP + (fun id gl -> + observe_tac + (Format.sprintf "rewrite %s in %s " (string_of_id eq) (string_of_id id)) + (tclTRY (Equality.general_rewrite_in true all_occurrences id (mkVar eq) false)) + gl + ) + eqs + ) (rewrite_eqs_in_eqs eqs) let new_prove_with_tcc is_mes acc_inv hrec tcc_hyps eqs : tactic = @@ -1373,21 +1381,26 @@ let new_prove_with_tcc is_mes acc_inv hrec tcc_hyps eqs : tactic = [ tclTHENSEQ [ keep (tcc_hyps@eqs); - apply (Lazy.force acc_inv); (fun g -> if is_mes then - unfold_in_concl [([], evaluable_of_global_reference (delayed_force ltof_ref))] g + unfold_in_concl [(all_occurrences, evaluable_of_global_reference (delayed_force ltof_ref))] g else tclIDTAC g ); observe_tac "rew_and_finish" (tclTHENLIST [tclTRY(Recdef.list_rewrite false (List.map mkVar eqs)); - rewrite_eqs_in_eqs eqs; - (observe_tac "finishing" - (tclCOMPLETE ( - Eauto.gen_eauto false (false,5) [] (Some [])) + observe_tac "rewrite_eqs_in_eqs" (rewrite_eqs_in_eqs eqs); + (observe_tac "finishing using" + ( + tclCOMPLETE( + Eauto.eauto_with_bases + false + (true,5) + [Lazy.force refl_equal] + [empty_transparent_state, Auto.Hint_db.empty] + ) ) ) ] @@ -1445,7 +1458,7 @@ let prove_principle_for_gen let wf_tac = if is_mes then - (fun b -> Recdef.tclUSER_if_not_mes b None) + (fun b -> Recdef.tclUSER_if_not_mes tclIDTAC b None) else fun _ -> prove_with_tcc tcc_lemma_ref [] in let real_rec_arg_num = rec_arg_num - princ_info.nparams in @@ -1502,16 +1515,16 @@ let prove_principle_for_gen | None -> anomaly ( "No tcc proof !!") | Some lemma -> lemma in - let rec list_diff del_list check_list = - match del_list with - [] -> - [] - | f::r -> - if List.mem f check_list then - list_diff r check_list - else - f::(list_diff r check_list) - in +(* let rec list_diff del_list check_list = *) +(* match del_list with *) +(* [] -> *) +(* [] *) +(* | f::r -> *) +(* if List.mem f check_list then *) +(* list_diff r check_list *) +(* else *) +(* f::(list_diff r check_list) *) +(* in *) let tcc_list = ref [] in let start_tac gls = let hyps = pf_ids_of_hyps gls in @@ -1527,7 +1540,7 @@ let prove_principle_for_gen Elim.h_decompose_and (mkVar hid); (fun g -> let new_hyps = pf_ids_of_hyps g in - tcc_list := list_diff new_hyps (hid::hyps); + tcc_list := List.rev (list_subtract new_hyps (hid::hyps)); if !tcc_list = [] then begin @@ -1593,14 +1606,15 @@ let prove_principle_for_gen (* msgnl (str "eqs := "++ prlist_with_sep spc Ppconstr.pr_id eqs); *) (* observe_tac "new_prove_with_tcc" *) - (new_prove_with_tcc + (new_prove_with_tcc is_mes acc_inv fix_id - !tcc_list - ((List.map + + (!tcc_list@(List.map (fun (na,_,_) -> (Nameops.out_name na)) (princ_info.args@princ_info.params) - )@ (acc_rec_arg_id::eqs)) + )@ ([acc_rec_arg_id])) eqs ) + ); is_valid = is_valid_hypothesis predicates_names } diff --git a/contrib/funind/functional_principles_types.ml b/contrib/funind/functional_principles_types.ml index 8ad2e72b..16076479 100644 --- a/contrib/funind/functional_principles_types.ml +++ b/contrib/funind/functional_principles_types.ml @@ -115,7 +115,7 @@ let compute_new_princ_type_from_rel rel_to_fun sorts princ_type = it_mkProd_or_LetIn ~init: (it_mkProd_or_LetIn - ~init:(option_fold_right + ~init:(Option.fold_right mkProd_or_LetIn princ_type_info.indarg princ_type_info.concl @@ -384,7 +384,7 @@ let generate_functional_principle { const_entry_body = value; const_entry_type = None; const_entry_opaque = false; - const_entry_boxed = Options.boxed_definitions() + const_entry_boxed = Flags.boxed_definitions() } in ignore( @@ -394,7 +394,7 @@ let generate_functional_principle Decl_kinds.IsDefinition (Decl_kinds.Scheme) ) ); - Options.if_verbose + Flags.if_verbose (fun id -> Pp.msgnl (Ppconstr.pr_id id ++ str " is defined")) name; names := name :: !names @@ -561,6 +561,15 @@ let make_scheme (fas : (constant*Rawterm.rawsort) list) : Entries.definition_ent (fun _ _ _ -> ()) in incr i; + let opacity = + let finfos = find_Function_infos this_block_funs.(0) in + try + let equation = Option.get finfos.equation_lemma in + (Global.lookup_constant equation).Declarations.const_opaque + with Option.IsNone -> (* non recursive definition *) + false + in + let const = {const with const_entry_opaque = opacity } in (* The others are just deduced *) if other_princ_types = [] then @@ -642,10 +651,12 @@ let build_scheme fas = in List.iter2 (fun (princ_id,_,_) def_entry -> - ignore (Declare.declare_constant - princ_id - (Entries.DefinitionEntry def_entry,Decl_kinds.IsProof Decl_kinds.Theorem)); - Options.if_verbose (fun id -> Pp.msgnl (Ppconstr.pr_id id ++ str " is defined")) princ_id + ignore + (Declare.declare_constant + princ_id + (Entries.DefinitionEntry def_entry,Decl_kinds.IsProof Decl_kinds.Theorem)); + Flags.if_verbose + (fun id -> Pp.msgnl (Ppconstr.pr_id id ++ str " is defined")) princ_id ) fas bodies_types diff --git a/contrib/funind/indfun_main.ml4 b/contrib/funind/g_indfun.ml4 index 9cee9edc..dae76f2d 100644 --- a/contrib/funind/indfun_main.ml4 +++ b/contrib/funind/g_indfun.ml4 @@ -29,20 +29,37 @@ let pr_bindings prc prlc = function Util.prlist_with_sep spc (fun b -> str"(" ++ pr_binding prlc b ++ str")") l | Rawterm.NoBindings -> mt () - let pr_with_bindings prc prlc (c,bl) = prc c ++ hv 0 (pr_bindings prc prlc bl) - let pr_fun_ind_using prc prlc _ opt_c = match opt_c with | None -> mt () | Some (p,b) -> spc () ++ hov 2 (str "using" ++ spc () ++ pr_with_bindings prc prlc (p,b)) +(* Duplication of printing functions because "'a with_bindings" is + (internally) not uniform in 'a: indeed constr_with_bindings at the + "typed" level has type "open_constr with_bindings" instead of + "constr with_bindings"; hence, its printer cannot be polymorphic in + (prc,prlc)... *) + +let pr_with_bindings_typed prc prlc (c,bl) = + prc c ++ + hv 0 (pr_bindings (fun c -> prc (snd c)) (fun c -> prlc (snd c)) bl) + +let pr_fun_ind_using_typed prc prlc _ opt_c = + match opt_c with + | None -> mt () + | Some (p,b) -> spc () ++ hov 2 (str "using" ++ spc () ++ pr_with_bindings_typed prc prlc (p,b)) + ARGUMENT EXTEND fun_ind_using TYPED AS constr_with_bindings_opt - PRINTED BY pr_fun_ind_using + PRINTED BY pr_fun_ind_using_typed + RAW_TYPED AS constr_with_bindings_opt + RAW_PRINTED BY pr_fun_ind_using + GLOB_TYPED AS constr_with_bindings_opt + GLOB_PRINTED BY pr_fun_ind_using | [ "using" constr_with_bindings(c) ] -> [ Some c ] | [ ] -> [ None ] END @@ -131,7 +148,7 @@ END VERNAC ARGUMENT EXTEND binder2 [ "(" ne_ident_list(idl) ":" lconstr(c) ")"] -> [ - LocalRawAssum (List.map (fun id -> (Util.dummy_loc,Name id)) idl,c) ] + LocalRawAssum (List.map (fun id -> (Util.dummy_loc,Name id)) idl,Topconstr.default_binder_kind,c) ] END @@ -152,7 +169,7 @@ VERNAC ARGUMENT EXTEND rec_definition2 | Struct id -> id | Wf(_,Some id,_) -> id | Mes(_,Some id,_) -> id | Wf(_,None,_) | Mes(_,None,_) -> failwith "check_exists_args" in - (try ignore(Util.list_index (Name id) names - 1); annot + (try ignore(Util.list_index0 (Name id) names); annot with Not_found -> Util.user_err_loc (Util.dummy_loc,"Function", Pp.str "No argument named " ++ Nameops.pr_id id) @@ -166,7 +183,7 @@ VERNAC ARGUMENT EXTEND rec_definition2 | Some an -> check_exists_args an in - (id, ni, bl, type_, def) ] + ((Util.dummy_loc,id), ni, bl, type_, def) ] END @@ -300,7 +317,7 @@ let mkEq typ c1 c2 = let poseq_unsafe idunsafe cstr gl = let typ = Tacmach.pf_type_of gl cstr in tclTHEN - (Tactics.letin_tac true (Name idunsafe) cstr allClauses) + (Tactics.letin_tac None (Name idunsafe) cstr allClauses) (tclTHENFIRST (Tactics.assert_as true IntroAnonymous (mkEq typ (mkVar idunsafe) cstr)) Tactics.reflexivity) @@ -446,25 +463,23 @@ VERNAC COMMAND EXTEND Showindinfo END VERNAC COMMAND EXTEND MergeFunind - [ "Mergeschemes" lconstr(c) "with" lconstr(c') "using" ident(id) ] -> + [ "Mergeschemes" "(" ident(id1) ne_ident_list(cl1) ")" + "with" "(" ident(id2) ne_ident_list(cl2) ")" "using" ident(id) ] -> [ - let c1 = Constrintern.interp_constr Evd.empty (Global.env()) c in - let c2 = Constrintern.interp_constr Evd.empty (Global.env()) c' in - let id1,args1 = - try - let hd,args = destApp c1 in - if Term.isInd hd then hd , args - else raise (Util.error "Ill-formed (fst) argument") - with Invalid_argument _ - -> Util.error ("Bad argument form for merging schemes") in - let id2,args2 = - try - let hd,args = destApp c2 in - if isInd hd then hd , args - else raise (Util.error "Ill-formed (snd) argument") - with Invalid_argument _ - -> Util.error ("Bad argument form for merging schemes") in - (* TOFO: enlever le ignore et declarer l'inductif *) - ignore(Merge.merge c1 c2 args1 args2 id) + let f1 = Constrintern.interp_constr Evd.empty (Global.env()) + (CRef (Libnames.Ident (Util.dummy_loc,id1))) in + let f2 = Constrintern.interp_constr Evd.empty (Global.env()) + (CRef (Libnames.Ident (Util.dummy_loc,id2))) in + let f1type = Typing.type_of (Global.env()) Evd.empty f1 in + let f2type = Typing.type_of (Global.env()) Evd.empty f2 in + let ar1 = List.length (fst (decompose_prod f1type)) in + let ar2 = List.length (fst (decompose_prod f2type)) in + let _ = + if ar1 <> List.length cl1 then + Util.error ("not the right number of arguments for " ^ string_of_id id1) in + let _ = + if ar2 <> List.length cl2 then + Util.error ("not the right number of arguments for " ^ string_of_id id2) in + Merge.merge id1 id2 (Array.of_list cl1) (Array.of_list cl2) id ] END diff --git a/contrib/funind/indfun.ml b/contrib/funind/indfun.ml index 82bee01f..a6cbb321 100644 --- a/contrib/funind/indfun.ml +++ b/contrib/funind/indfun.ml @@ -22,8 +22,8 @@ let is_rec_info scheme_info = let choose_dest_or_ind scheme_info = if is_rec_info scheme_info - then Tactics.new_induct - else Tactics.new_destruct + then Tactics.new_induct false + else Tactics.new_destruct false let functional_induction with_clean c princl pat = @@ -48,8 +48,8 @@ let functional_induction with_clean c princl pat = | InType -> finfo.rect_lemma in let princ = (* then we get the principle *) - try mkConst (out_some princ_option ) - with Failure "out_some" -> + try mkConst (Option.get princ_option ) + with Option.IsNone -> (*i If there is not default lemma defined then, we cross our finger and try to find a lemma named f_ind (or f_rec, f_rect) i*) @@ -77,7 +77,7 @@ let functional_induction with_clean c princl pat = if princ_infos.Tactics.farg_in_concl then [c] else [] in - List.map (fun c -> Tacexpr.ElimOnConstr c) (args@c_list) + List.map (fun c -> Tacexpr.ElimOnConstr (c,NoBindings)) (args@c_list) in let princ' = Some (princ,bindings) in let princ_vars = @@ -120,7 +120,8 @@ let functional_induction with_clean c princl pat = princ_infos args_as_induction_constr princ' - pat) + pat + None) subst_and_reduce g @@ -139,14 +140,14 @@ type newfixpoint_expr = let rec abstract_rawconstr c = function | [] -> c | Topconstr.LocalRawDef (x,b)::bl -> Topconstr.mkLetInC(x,b,abstract_rawconstr c bl) - | Topconstr.LocalRawAssum (idl,t)::bl -> - List.fold_right (fun x b -> Topconstr.mkLambdaC([x],t,b)) idl + | Topconstr.LocalRawAssum (idl,k,t)::bl -> + List.fold_right (fun x b -> Topconstr.mkLambdaC([x],k,t,b)) idl (abstract_rawconstr c bl) let interp_casted_constr_with_implicits sigma env impls c = (* Constrintern.interp_rawconstr_with_implicits sigma env [] impls c *) Constrintern.intern_gen false sigma env ~impls:([],impls) - ~allow_soapp:false ~ltacvars:([],[]) c + ~allow_patvar:false ~ltacvars:([],[]) c (* @@ -160,7 +161,7 @@ let build_newrecursive in let (rec_sign,rec_impls) = List.fold_left - (fun (env,impls) (recname,_,bl,arityc,_) -> + (fun (env,impls) ((_,recname),_,bl,arityc,_) -> let arityc = Command.generalize_constr_expr arityc bl in let arity = Constrintern.interp_type sigma env0 arityc in let impl = @@ -213,7 +214,7 @@ let rec is_rec names = | RRec _ -> error "RRec not handled" | RIf(_,b,_,lhs,rhs) -> (lookup names b) || (lookup names lhs) || (lookup names rhs) - | RLetIn(_,na,t,b) | RLambda(_,na,t,b) | RProd(_,na,t,b) -> + | RLetIn(_,na,t,b) | RLambda(_,na,_,t,b) | RProd(_,na,_,t,b) -> lookup names t || lookup (Nameops.name_fold Idset.remove na names) b | RLetTuple(_,nal,_,t,b) -> lookup names t || lookup @@ -224,7 +225,7 @@ let rec is_rec names = ) b | RApp(_,f,args) -> List.exists (lookup names) (f::args) - | RCases(_,_,el,brl) -> + | RCases(_,_,_,el,brl) -> List.exists (fun (e,_) -> lookup names e) el || List.exists (lookup_br names) brl and lookup_br names (_,idl,_,rt) = @@ -266,7 +267,7 @@ let derive_inversion fix_names = ) with e -> msg_warning - (str "Cannot build functional inversion principle" ++ + (str "Cannot built inversion information" ++ if do_observe () then Cerrors.explain_exn e else mt ()) with _ -> () @@ -297,7 +298,7 @@ let generate_principle on_error is_general do_built fix_rec_l recdefs interactive_proof (continue_proof : int -> Names.constant array -> Term.constr array -> int -> Tacmach.tactic) : unit = - let names = List.map (function (name,_,_,_,_) -> name) fix_rec_l in + let names = List.map (function ((_, name),_,_,_,_) -> name) fix_rec_l in let fun_bodies = List.map2 prepare_body fix_rec_l recdefs in let funs_args = List.map fst fun_bodies in let funs_types = List.map (function (_,_,_,types,_) -> types) fix_rec_l in @@ -318,7 +319,7 @@ let generate_principle on_error f_R_mut) in let fname_kn (fname,_,_,_,_) = - let f_ref = Ident (dummy_loc,fname) in + let f_ref = Ident fname in locate_with_msg (pr_reference f_ref++str ": Not an inductive type!") locate_constant @@ -351,17 +352,17 @@ let generate_principle on_error let register_struct is_rec fixpoint_exprl = match fixpoint_exprl with - | [(fname,_,bl,ret_type,body),_] when not is_rec -> + | [((_,fname),_,bl,ret_type,body),_] when not is_rec -> Command.declare_definition fname - (Decl_kinds.Global,Options.boxed_definitions (),Decl_kinds.Definition) + (Decl_kinds.Global,Flags.boxed_definitions (),Decl_kinds.Definition) bl None body (Some ret_type) (fun _ _ -> ()) | _ -> - Command.build_recursive fixpoint_exprl (Options.boxed_definitions()) + Command.build_recursive fixpoint_exprl (Flags.boxed_definitions()) let generate_correction_proof_wf f_ref tcc_lemma_ref is_mes functional_ref eq_ref rec_arg_num rec_arg_type nb_args relation @@ -402,7 +403,7 @@ let register_wf ?(is_mes=false) fname rec_impls wf_rel_expr wf_arg using_lemmas ) ) in - Topconstr.CApp (dummy_loc,(None,Topconstr.mkIdentC (id_of_string "eq")), + Topconstr.CApp (dummy_loc,(None,Topconstr.mkRefC (Qualid (dummy_loc,(qualid_of_string "Logic.eq")))), [(f_app_args,None);(body,None)]) in let eq = Command.generalize_constr_expr unbounded_eq args in @@ -434,7 +435,7 @@ let register_mes fname rec_impls wf_mes_expr wf_arg using_lemmas args ret_type b | None -> begin match args with - | [Topconstr.LocalRawAssum ([(_,Name x)],t)] -> t,x + | [Topconstr.LocalRawAssum ([(_,Name x)],k,t)] -> t,x | _ -> error "Recursive argument must be specified" end | Some wf_args -> @@ -442,7 +443,7 @@ let register_mes fname rec_impls wf_mes_expr wf_arg using_lemmas args ret_type b match List.find (function - | Topconstr.LocalRawAssum(l,t) -> + | Topconstr.LocalRawAssum(l,k,t) -> List.exists (function (_,Name id) -> id = wf_args | _ -> false) l @@ -450,7 +451,7 @@ let register_mes fname rec_impls wf_mes_expr wf_arg using_lemmas args ret_type b ) args with - | Topconstr.LocalRawAssum(_,t) -> t,wf_args + | Topconstr.LocalRawAssum(_,k,t) -> t,wf_args | _ -> assert false with Not_found -> assert false in @@ -462,7 +463,7 @@ let register_mes fname rec_impls wf_mes_expr wf_arg using_lemmas args ret_type b let fun_from_mes = let applied_mes = Topconstr.mkAppC(wf_mes_expr,[Topconstr.mkIdentC wf_arg]) in - Topconstr.mkLambdaC ([(dummy_loc,Name wf_arg)],wf_arg_type,applied_mes) + Topconstr.mkLambdaC ([(dummy_loc,Name wf_arg)],Topconstr.default_binder_kind,wf_arg_type,applied_mes) in let wf_rel_from_mes = Topconstr.mkAppC(Topconstr.mkRefC ltof,[wf_arg_type;fun_from_mes]) @@ -475,7 +476,7 @@ let do_generate_principle on_error register_built interactive_proof fixpoint_exp let recdefs,rec_impls = build_newrecursive fixpoint_exprl in let _is_struct = match fixpoint_exprl with - | [((name,Some (Wf (wf_rel,wf_x,using_lemmas)),args,types,body))] -> + | [(((_,name),Some (Wf (wf_rel,wf_x,using_lemmas)),args,types,body))] -> let pre_hook = generate_principle on_error @@ -488,7 +489,7 @@ let do_generate_principle on_error register_built interactive_proof fixpoint_exp if register_built then register_wf name rec_impls wf_rel wf_x using_lemmas args types body pre_hook; false - | [((name,Some (Mes (wf_mes,wf_x,using_lemmas)),args,types,body))] -> + | [(((_,name),Some (Mes (wf_mes,wf_x,using_lemmas)),args,types,body))] -> let pre_hook = generate_principle on_error @@ -503,20 +504,15 @@ let do_generate_principle on_error register_built interactive_proof fixpoint_exp true | _ -> let fix_names = - List.map (function (name,_,_,_,_) -> name) fixpoint_exprl + List.map (function ((_,name),_,_,_,_) -> name) fixpoint_exprl in let is_one_rec = is_rec fix_names in let old_fixpoint_exprl = List.map (function | (name,Some (Struct id),args,types,body),_ -> - let names = - List.map - snd - (Topconstr.names_of_local_assums args) - in let annot = - try Some (list_index (Name id) names - 1), Topconstr.CStructRec + try Some (dummy_loc, id), Topconstr.CStructRec with Not_found -> raise (UserError("",str "Cannot find argument " ++ Ppconstr.pr_id id)) @@ -529,7 +525,8 @@ let do_generate_principle on_error register_built interactive_proof fixpoint_exp (dummy_loc,"Function", Pp.str "the recursive argument needs to be specified in Function") else - (name,(Some 0, Topconstr.CStructRec),args,types,body), + let loc, na = List.hd names in + (name,(Some (loc, Nameops.out_name na), Topconstr.CStructRec),args,types,body), (None:Vernacexpr.decl_notation) | (_,Some (Wf _),_,_,_),_ | (_,Some (Mes _),_,_,_),_-> error @@ -539,7 +536,7 @@ let do_generate_principle on_error register_built interactive_proof fixpoint_exp in (* ok all the expressions are structural *) let fix_names = - List.map (function (name,_,_,_,_) -> name) fixpoint_exprl + List.map (function ((_,name),_,_,_,_) -> name) fixpoint_exprl in let is_rec = List.exists (is_rec fix_names) recdefs in if register_built then register_struct is_rec old_fixpoint_exprl; @@ -570,11 +567,11 @@ let rec add_args id new_args b = CArrow(loc,add_args id new_args b1, add_args id new_args b2) | CProdN(loc,nal,b1) -> CProdN(loc, - List.map (fun (nal,b2) -> (nal,add_args id new_args b2)) nal, + List.map (fun (nal,k,b2) -> (nal,k,add_args id new_args b2)) nal, add_args id new_args b1) | CLambdaN(loc,nal,b1) -> CLambdaN(loc, - List.map (fun (nal,b2) -> (nal,add_args id new_args b2)) nal, + List.map (fun (nal,k,b2) -> (nal,k,add_args id new_args b2)) nal, add_args id new_args b1) | CLetIn(loc,na,b1,b2) -> CLetIn(loc,na,add_args id new_args b1,add_args id new_args b2) @@ -588,22 +585,22 @@ let rec add_args id new_args b = | CApp(loc,(pf,b),bl) -> CApp(loc,(pf,add_args id new_args b), List.map (fun (e,o) -> add_args id new_args e,o) bl) - | CCases(loc,b_option,cel,cal) -> - CCases(loc,option_map (add_args id new_args) b_option, + | CCases(loc,sty,b_option,cel,cal) -> + CCases(loc,sty,Option.map (add_args id new_args) b_option, List.map (fun (b,(na,b_option)) -> add_args id new_args b, - (na,option_map (add_args id new_args) b_option)) cel, + (na,Option.map (add_args id new_args) b_option)) cel, List.map (fun (loc,cpl,e) -> (loc,cpl,add_args id new_args e)) cal ) | CLetTuple(loc,nal,(na,b_option),b1,b2) -> - CLetTuple(loc,nal,(na,option_map (add_args id new_args) b_option), + CLetTuple(loc,nal,(na,Option.map (add_args id new_args) b_option), add_args id new_args b1, add_args id new_args b2 ) | CIf(loc,b1,(na,b_option),b2,b3) -> CIf(loc,add_args id new_args b1, - (na,option_map (add_args id new_args) b_option), + (na,Option.map (add_args id new_args) b_option), add_args id new_args b2, add_args id new_args b3 ) @@ -644,13 +641,15 @@ let rec chop_n_arrow n t = let new_n = let rec aux (n:int) = function [] -> n - | (nal,t'')::nal_ta' -> + | (nal,k,t'')::nal_ta' -> let nal_l = List.length nal in if n >= nal_l then aux (n - nal_l) nal_ta' else - let new_t' = Topconstr.CProdN(dummy_loc,((snd (list_chop n nal)),t'')::nal_ta',t') + let new_t' = + Topconstr.CProdN(dummy_loc, + ((snd (list_chop n nal)),k,t'')::nal_ta',t') in raise (Stop new_t') in @@ -668,12 +667,12 @@ let rec get_args b t : Topconstr.local_binder list * | Topconstr.CLambdaN (loc, (nal_ta), b') -> begin let n = - (List.fold_left (fun n (nal,_) -> + (List.fold_left (fun n (nal,_,_) -> n+List.length nal) 0 nal_ta ) in let nal_tas,b'',t'' = get_args b' (chop_n_arrow n t) in - (List.map (fun (nal,ta) -> - (Topconstr.LocalRawAssum (nal,ta))) nal_ta)@nal_tas, b'',t'' + (List.map (fun (nal,k,ta) -> + (Topconstr.LocalRawAssum (nal,k,ta))) nal_ta)@nal_tas, b'',t'' end | _ -> [],b,t @@ -711,26 +710,13 @@ let make_graph (f_ref:global_reference) = let l = List.map (fun (id,(n,recexp),bl,t,b) -> - let bl' = - List.flatten - (List.map - (function - | Topconstr.LocalRawDef (na,_)-> [] - | Topconstr.LocalRawAssum (nal,_) -> nal - ) - bl - ) - in - let rec_id = - match List.nth bl' (out_some n) with - |(_,Name id) -> id | _ -> anomaly "" - in + let loc, rec_id = Option.get n in let new_args = List.flatten (List.map (function | Topconstr.LocalRawDef (na,_)-> [] - | Topconstr.LocalRawAssum (nal,_) -> + | Topconstr.LocalRawAssum (nal,_,_) -> List.map (fun (loc,n) -> CRef(Libnames.Ident(loc, Nameops.out_name n))) @@ -739,7 +725,7 @@ let make_graph (f_ref:global_reference) = nal_tas ) in - let b' = add_args id new_args b in + let b' = add_args (snd id) new_args b in (id, Some (Struct rec_id),nal_tas@bl,t,b') ) fixexprl @@ -747,13 +733,13 @@ let make_graph (f_ref:global_reference) = l | _ -> let id = id_of_label (con_label c) in - [(id,None,nal_tas,t,b)] + [((dummy_loc,id),None,nal_tas,t,b)] in do_generate_principle error_error false false expr_list; (* We register the infos *) let mp,dp,_ = repr_con c in List.iter - (fun (id,_,_,_,_) -> add_Function false (make_con mp dp (label_of_id id))) + (fun ((_,id),_,_,_,_) -> add_Function false (make_con mp dp (label_of_id id))) expr_list diff --git a/contrib/funind/indfun_common.ml b/contrib/funind/indfun_common.ml index 13b242d5..4010b49d 100644 --- a/contrib/funind/indfun_common.ml +++ b/contrib/funind/indfun_common.ml @@ -76,7 +76,7 @@ let chop_rlambda_n = then List.rev acc,rt else match rt with - | Rawterm.RLambda(_,name,t,b) -> chop_lambda_n ((name,t,false)::acc) (n-1) b + | Rawterm.RLambda(_,name,k,t,b) -> chop_lambda_n ((name,t,false)::acc) (n-1) b | Rawterm.RLetIn(_,name,v,b) -> chop_lambda_n ((name,v,true)::acc) (n-1) b | _ -> raise (Util.UserError("chop_rlambda_n", @@ -90,7 +90,7 @@ let chop_rprod_n = then List.rev acc,rt else match rt with - | Rawterm.RProd(_,name,t,b) -> chop_prod_n ((name,t)::acc) (n-1) b + | Rawterm.RProd(_,name,k,t,b) -> chop_prod_n ((name,t)::acc) (n-1) b | _ -> raise (Util.UserError("chop_rprod_n",str "chop_rprod_n: Not enough products")) in chop_prod_n [] @@ -131,7 +131,7 @@ let coq_constant s = (Coqlib.init_modules @ Coqlib.arith_modules) s;; let constant sl s = - constr_of_reference + constr_of_global (Nametab.locate (make_qualid(Names.make_dirpath (List.map id_of_string (List.rev sl))) (id_of_string s)));; @@ -153,7 +153,7 @@ open Entries open Decl_kinds open Declare let definition_message id = - Options.if_verbose message ((string_of_id id) ^ " is defined") + Flags.if_verbose message ((string_of_id id) ^ " is defined") let save with_clean id const (locality,kind) hook = @@ -237,24 +237,29 @@ let with_full_print f a = let old_implicit_args = Impargs.is_implicit_args () and old_strict_implicit_args = Impargs.is_strict_implicit_args () and old_contextual_implicit_args = Impargs.is_contextual_implicit_args () in - let old_rawprint = !Options.raw_print in - Options.raw_print := true; + let old_rawprint = !Flags.raw_print in + let old_dump = !Flags.dump in + Flags.raw_print := true; Impargs.make_implicit_args false; Impargs.make_strict_implicit_args false; Impargs.make_contextual_implicit_args false; + Impargs.make_contextual_implicit_args false; + Flags.dump := false; try let res = f a in Impargs.make_implicit_args old_implicit_args; Impargs.make_strict_implicit_args old_strict_implicit_args; Impargs.make_contextual_implicit_args old_contextual_implicit_args; - Options.raw_print := old_rawprint; + Flags.raw_print := old_rawprint; + Flags.dump := old_dump; res with | e -> Impargs.make_implicit_args old_implicit_args; Impargs.make_strict_implicit_args old_strict_implicit_args; Impargs.make_contextual_implicit_args old_contextual_implicit_args; - Options.raw_print := old_rawprint; + Flags.raw_print := old_rawprint; + Flags.dump := old_dump; raise e @@ -319,12 +324,12 @@ let subst_Function (_,subst,finfos) = in let function_constant' = do_subst_con finfos.function_constant in let graph_ind' = do_subst_ind finfos.graph_ind in - let equation_lemma' = Util.option_smartmap do_subst_con finfos.equation_lemma in - let correctness_lemma' = Util.option_smartmap do_subst_con finfos.correctness_lemma in - let completeness_lemma' = Util.option_smartmap do_subst_con finfos.completeness_lemma in - let rect_lemma' = Util.option_smartmap do_subst_con finfos.rect_lemma in - let rec_lemma' = Util.option_smartmap do_subst_con finfos.rec_lemma in - let prop_lemma' = Util.option_smartmap do_subst_con finfos.prop_lemma in + let equation_lemma' = Option.smartmap do_subst_con finfos.equation_lemma in + let correctness_lemma' = Option.smartmap do_subst_con finfos.correctness_lemma in + let completeness_lemma' = Option.smartmap do_subst_con finfos.completeness_lemma in + let rect_lemma' = Option.smartmap do_subst_con finfos.rect_lemma in + let rec_lemma' = Option.smartmap do_subst_con finfos.rec_lemma in + let prop_lemma' = Option.smartmap do_subst_con finfos.prop_lemma in if function_constant' == finfos.function_constant && graph_ind' == finfos.graph_ind && equation_lemma' == finfos.equation_lemma && @@ -354,12 +359,12 @@ let export_Function infos = Some infos let discharge_Function (_,finfos) = let function_constant' = Lib.discharge_con finfos.function_constant and graph_ind' = Lib.discharge_inductive finfos.graph_ind - and equation_lemma' = Util.option_smartmap Lib.discharge_con finfos.equation_lemma - and correctness_lemma' = Util.option_smartmap Lib.discharge_con finfos.correctness_lemma - and completeness_lemma' = Util.option_smartmap Lib.discharge_con finfos.completeness_lemma - and rect_lemma' = Util.option_smartmap Lib.discharge_con finfos.rect_lemma - and rec_lemma' = Util.option_smartmap Lib.discharge_con finfos.rec_lemma - and prop_lemma' = Util.option_smartmap Lib.discharge_con finfos.prop_lemma + and equation_lemma' = Option.smartmap Lib.discharge_con finfos.equation_lemma + and correctness_lemma' = Option.smartmap Lib.discharge_con finfos.correctness_lemma + and completeness_lemma' = Option.smartmap Lib.discharge_con finfos.completeness_lemma + and rect_lemma' = Option.smartmap Lib.discharge_con finfos.rect_lemma + and rec_lemma' = Option.smartmap Lib.discharge_con finfos.rec_lemma + and prop_lemma' = Option.smartmap Lib.discharge_con finfos.prop_lemma in if function_constant' == finfos.function_constant && graph_ind' == finfos.graph_ind && @@ -387,12 +392,12 @@ let pr_info f_info = str "function_constant := " ++ Printer.pr_lconstr (mkConst f_info.function_constant)++ fnl () ++ str "function_constant_type := " ++ (try Printer.pr_lconstr (Global.type_of_global (ConstRef f_info.function_constant)) with _ -> mt ()) ++ fnl () ++ - str "equation_lemma := " ++ (Util.option_fold_right (fun v acc -> Printer.pr_lconstr (mkConst v)) f_info.equation_lemma (mt ()) ) ++ fnl () ++ - str "completeness_lemma :=" ++ (Util.option_fold_right (fun v acc -> Printer.pr_lconstr (mkConst v)) f_info.completeness_lemma (mt ()) ) ++ fnl () ++ - str "correctness_lemma := " ++ (Util.option_fold_right (fun v acc -> Printer.pr_lconstr (mkConst v)) f_info.correctness_lemma (mt ()) ) ++ fnl () ++ - str "rect_lemma := " ++ (Util.option_fold_right (fun v acc -> Printer.pr_lconstr (mkConst v)) f_info.rect_lemma (mt ()) ) ++ fnl () ++ - str "rec_lemma := " ++ (Util.option_fold_right (fun v acc -> Printer.pr_lconstr (mkConst v)) f_info.rec_lemma (mt ()) ) ++ fnl () ++ - str "prop_lemma := " ++ (Util.option_fold_right (fun v acc -> Printer.pr_lconstr (mkConst v)) f_info.prop_lemma (mt ()) ) ++ fnl () ++ + str "equation_lemma := " ++ (Option.fold_right (fun v acc -> Printer.pr_lconstr (mkConst v)) f_info.equation_lemma (mt ()) ) ++ fnl () ++ + str "completeness_lemma :=" ++ (Option.fold_right (fun v acc -> Printer.pr_lconstr (mkConst v)) f_info.completeness_lemma (mt ()) ) ++ fnl () ++ + str "correctness_lemma := " ++ (Option.fold_right (fun v acc -> Printer.pr_lconstr (mkConst v)) f_info.correctness_lemma (mt ()) ) ++ fnl () ++ + str "rect_lemma := " ++ (Option.fold_right (fun v acc -> Printer.pr_lconstr (mkConst v)) f_info.rect_lemma (mt ()) ) ++ fnl () ++ + str "rec_lemma := " ++ (Option.fold_right (fun v acc -> Printer.pr_lconstr (mkConst v)) f_info.rec_lemma (mt ()) ) ++ fnl () ++ + str "prop_lemma := " ++ (Option.fold_right (fun v acc -> Printer.pr_lconstr (mkConst v)) f_info.prop_lemma (mt ()) ) ++ fnl () ++ str "graph_ind := " ++ Printer.pr_lconstr (mkInd f_info.graph_ind) ++ fnl () let pr_table tb = diff --git a/contrib/funind/invfun.ml b/contrib/funind/invfun.ml index c7a3d164..63d44916 100644 --- a/contrib/funind/invfun.ml +++ b/contrib/funind/invfun.ml @@ -16,6 +16,7 @@ open Tacticals open Tactics open Indfun_common open Tacmach +open Termops open Sign open Hiddentac @@ -23,13 +24,13 @@ open Hiddentac let pr_binding prc = function - | loc, Rawterm.NamedHyp id, c -> hov 1 (Ppconstr.pr_id id ++ str " := " ++ Pp.cut () ++ prc c) - | loc, Rawterm.AnonHyp n, c -> hov 1 (int n ++ str " := " ++ Pp.cut () ++ prc c) + | loc, Rawterm.NamedHyp id, (_,c) -> hov 1 (Ppconstr.pr_id id ++ str " := " ++ Pp.cut () ++ prc c) + | loc, Rawterm.AnonHyp n, (_,c) -> hov 1 (int n ++ str " := " ++ Pp.cut () ++ prc c) let pr_bindings prc prlc = function | Rawterm.ImplicitBindings l -> brk (1,1) ++ str "with" ++ brk (1,1) ++ - Util.prlist_with_sep spc prc l + Util.prlist_with_sep spc (fun (_,c) -> prc c) l | Rawterm.ExplicitBindings l -> brk (1,1) ++ str "with" ++ brk (1,1) ++ Util.prlist_with_sep spc (fun b -> str"(" ++ pr_binding prlc b ++ str")") l @@ -59,13 +60,13 @@ let observennl strm = let do_observe_tac s tac g = - try let goal = begin try (Printer.pr_goal (sig_it g)) with _ -> assert false end in - let v = tac g in msgnl (goal ++ fnl () ++ s ++(str " ")++(str "finished")); v - with e -> - let goal = begin try (Printer.pr_goal (sig_it g)) with _ -> assert false end in - msgnl (str "observation "++ s++str " raised exception " ++ - Cerrors.explain_exn e ++ str " on goal " ++ goal ); - raise e;; + let goal = begin try (Printer.pr_goal (sig_it g)) with _ -> assert false end in + try + let v = tac g in msgnl (goal ++ fnl () ++ s ++(str " ")++(str "finished")); v + with e -> + msgnl (str "observation "++ s++str " raised exception " ++ + Cerrors.explain_exn e ++ str " on goal " ++ goal ); + raise e;; let observe_tac s tac g = @@ -314,7 +315,7 @@ let prove_fun_correct functional_induction funs_constr graphs_constr schemes lem | None -> (id::pre_args,pre_tac) | Some b -> (pre_args, - tclTHEN (h_reduce (Rawterm.Unfold([[],EvalVarRef id])) allHyps) pre_tac + tclTHEN (h_reduce (Rawterm.Unfold([Rawterm.all_occurrences_expr,EvalVarRef id])) allHyps) pre_tac ) else (pre_args,pre_tac) @@ -425,7 +426,7 @@ let prove_fun_correct functional_induction funs_constr graphs_constr schemes lem List.fold_left2 (fun (bindings,avoid) (x,_,_) p -> let id = Nameops.next_ident_away (Nameops.out_name x) avoid in - (dummy_loc,Rawterm.NamedHyp id,p)::bindings,id::avoid + (dummy_loc,Rawterm.NamedHyp id,inj_open p)::bindings,id::avoid ) ([],pf_ids_of_hyps g) princ_infos.params @@ -435,7 +436,7 @@ let prove_fun_correct functional_induction funs_constr graphs_constr schemes lem List.rev (fst (List.fold_left2 (fun (bindings,avoid) (x,_,_) p -> let id = Nameops.next_ident_away (Nameops.out_name x) avoid in - (dummy_loc,Rawterm.NamedHyp id,nf_zeta p)::bindings,id::avoid) + (dummy_loc,Rawterm.NamedHyp id,inj_open (nf_zeta p))::bindings,id::avoid) ([],avoid) princ_infos.predicates (lemmas))) @@ -461,14 +462,14 @@ let prove_fun_correct functional_induction funs_constr graphs_constr schemes lem ] g -(* [generalize_depedent_of x hyp g] +(* [generalize_dependent_of x hyp g] generalize every hypothesis which depends of [x] but [hyp] *) -let generalize_depedent_of x hyp g = +let generalize_dependent_of x hyp g = tclMAP (function | (id,None,t) when not (id = hyp) && - (Termops.occur_var (pf_env g) x t) -> h_generalize [mkVar id] + (Termops.occur_var (pf_env g) x t) -> tclTHEN (h_generalize [mkVar id]) (thin [id]) | _ -> tclIDTAC ) (pf_hyps g) @@ -490,12 +491,17 @@ and intros_with_rewrite_aux : tactic = | Prod(_,t,t') -> begin match kind_of_term t with - | App(eq,args) when (eq_constr eq eq_ind) -> - if isVar args.(1) + | App(eq,args) when (eq_constr eq eq_ind) -> + if Reductionops.is_conv (pf_env g) (project g) args.(1) args.(2) + then + let id = pf_get_new_id (id_of_string "y") g in + tclTHENSEQ [ h_intro id; thin [id]; intros_with_rewrite ] g + + else if isVar args.(1) then let id = pf_get_new_id (id_of_string "y") g in tclTHENSEQ [ h_intro id; - generalize_depedent_of (destVar args.(1)) id; + generalize_dependent_of (destVar args.(1)) id; tclTRY (Equality.rewriteLR (mkVar id)); intros_with_rewrite ] @@ -513,7 +519,7 @@ and intros_with_rewrite_aux : tactic = Tauto.tauto g | Case(_,_,v,_) -> tclTHENSEQ[ - h_case (v,Rawterm.NoBindings); + h_case false (v,Rawterm.NoBindings); intros_with_rewrite ] g | LetIn _ -> @@ -550,7 +556,7 @@ let rec reflexivity_with_destruct_cases g = match kind_of_term (snd (destApp (pf_concl g))).(2) with | Case(_,_,v,_) -> tclTHENSEQ[ - h_case (v,Rawterm.NoBindings); + h_case false (v,Rawterm.NoBindings); intros; observe_tac "reflexivity_with_destruct_cases" reflexivity_with_destruct_cases ] @@ -567,9 +573,9 @@ let rec reflexivity_with_destruct_cases g = match kind_of_term (pf_type_of g (mkVar id)) with | App(eq,[|_;t1;t2|]) when eq_constr eq eq_ind -> if Equality.discriminable (pf_env g) (project g) t1 t2 - then Equality.discr id g + then Equality.discrHyp id g else if Equality.injectable (pf_env g) (project g) t1 t2 - then tclTHENSEQ [Equality.inj [] id;thin [id];intros_with_rewrite] g + then tclTHENSEQ [Equality.injHyp id;thin [id];intros_with_rewrite] g else tclIDTAC g | _ -> tclIDTAC g ) @@ -665,8 +671,8 @@ let prove_fun_complete funcs graphs schemes lemmas_types_infos i : tactic = if infos.is_general || Rtree.is_infinite graph_def.mind_recargs then let eq_lemma = - try out_some (infos).equation_lemma - with Failure "out_some" -> anomaly "Cannot find equation lemma" + try Option.get (infos).equation_lemma + with Option.IsNone -> anomaly "Cannot find equation lemma" in tclTHENSEQ[ tclMAP h_intro ids; @@ -682,7 +688,7 @@ let prove_fun_complete funcs graphs schemes lemmas_types_infos i : tactic = h_generalize (List.map mkVar ids); thin ids ] - else unfold_in_concl [([],Names.EvalConstRef (destConst f))] + else unfold_in_concl [(all_occurrences,Names.EvalConstRef (destConst f))] in (* The proof of each branche itself *) let ind_number = ref 0 in @@ -706,7 +712,7 @@ let prove_fun_complete funcs graphs schemes lemmas_types_infos i : tactic = (* we expand the definition of the function *) observe_tac "rewrite_tac" (rewrite_tac this_ind_number this_branche_ids); (* introduce hypothesis with some rewrite *) - (intros_with_rewrite); + observe_tac "intros_with_rewrite" intros_with_rewrite; (* The proof is (almost) complete *) observe_tac "reflexivity" (reflexivity_with_destruct_cases) ] @@ -720,7 +726,7 @@ let prove_fun_complete funcs graphs schemes lemmas_types_infos i : tactic = (h_generalize [mkApp(applist(graph_principle,params),Array.map (fun c -> applist(c,params)) lemmas)]); h_intro graph_principle_id; observe_tac "" (tclTHEN_i - (observe_tac "elim" ((elim (mkVar hres,Rawterm.NoBindings) (Some (mkVar graph_principle_id,Rawterm.NoBindings))))) + (observe_tac "elim" ((elim false (mkVar hres,Rawterm.NoBindings) (Some (mkVar graph_principle_id,Rawterm.NoBindings))))) (fun i g -> observe_tac "prove_branche" (prove_branche i) g )) ] g @@ -769,7 +775,7 @@ let derive_correctness make_scheme functional_induction (funs: constant list) (g Array.of_list (List.map (fun entry -> - (entry.Entries.const_entry_body, out_some entry.Entries.const_entry_type ) + (entry.Entries.const_entry_body, Option.get entry.Entries.const_entry_type ) ) (make_scheme (array_map_to_list (fun const -> const,Rawterm.RType None) funs)) ) @@ -960,13 +966,13 @@ let invfun qhyp f = in try let finfos = find_Function_infos f in - let f_correct = mkConst(out_some finfos.correctness_lemma) + let f_correct = mkConst(Option.get finfos.correctness_lemma) and kn = fst finfos.graph_ind in Tactics.try_intros_until (fun hid -> functional_inversion kn hid (mkConst f) f_correct) qhyp with | Not_found -> error "No graph found" - | Failure "out_some" -> error "Cannot use equivalence with graph!" + | Option.IsNone -> error "Cannot use equivalence with graph!" let invfun qhyp f g = @@ -983,23 +989,23 @@ let invfun qhyp f g = try if not (isConst f1) then failwith ""; let finfos = find_Function_infos (destConst f1) in - let f_correct = mkConst(out_some finfos.correctness_lemma) + let f_correct = mkConst(Option.get finfos.correctness_lemma) and kn = fst finfos.graph_ind in functional_inversion kn hid f1 f_correct g - with | Failure "" | Failure "out_some" | Not_found -> + with | Failure "" | Option.IsNone | Not_found -> try let f2,_ = decompose_app args.(2) in if not (isConst f2) then failwith ""; let finfos = find_Function_infos (destConst f2) in - let f_correct = mkConst(out_some finfos.correctness_lemma) + let f_correct = mkConst(Option.get finfos.correctness_lemma) and kn = fst finfos.graph_ind in functional_inversion kn hid f2 f_correct g with | Failure "" -> errorlabstrm "" (str "Hypothesis" ++ Ppconstr.pr_id hid ++ str " must contain at leat one Function") - | Failure "out_some" -> + | Option.IsNone -> if do_observe () then error "Cannot use equivalence with graph for any side of the equality" diff --git a/contrib/funind/merge.ml b/contrib/funind/merge.ml index 1b796a81..ec456aae 100644 --- a/contrib/funind/merge.ml +++ b/contrib/funind/merge.ml @@ -9,13 +9,16 @@ (* Merging of induction principles. *) (*i $Id: i*) - +open Libnames +open Tactics +open Indfun_common open Util open Topconstr open Vernacexpr open Pp open Names open Term +open Termops open Declarations open Environ open Rawterm @@ -25,6 +28,8 @@ open Rawtermops (** {2 Useful operations on constr and rawconstr} *) +let rec popn i c = if i<=0 then c else pop (popn (i-1) c) + (** Substitutions in constr *) let compare_constr_nosub t1 t2 = if compare_constr (fun _ _ -> false) t1 t2 @@ -110,6 +115,19 @@ let prNamedLDecl s lc = List.iter (fun (nm,_,tp) -> prNamedConstr (string_of_name nm) tp) lc; prstr "\n"; end +let prNamedRLDecl s lc = + begin + prstr s; prstr "\n"; prstr "{§§ "; + List.iter + (fun x -> + match x with + | (nm,None,Some tp) -> prNamedRConstr (string_of_name nm) tp + | (nm,Some bdy,None) -> prNamedRConstr ("(letin) "^string_of_name nm) bdy + | _ -> assert false + ) lc; + prstr " §§}\n"; + prstr "\n"; + end let showind (id:identifier) = let cstrid = Tacinterp.constr_of_id (Global.env()) id in @@ -193,7 +211,7 @@ type linked_var = | Funres (** When merging two graphs, parameters may become regular arguments, - and thus be shifted. This type describe the result of computing + and thus be shifted. This type describes the result of computing the changes. *) type 'a shifted_params = { @@ -237,39 +255,47 @@ type 'a merged_arg = | Arg_linked of 'a | Arg_funres +(** Information about graph merging of two inductives. + All rel_decl list are IN REVERSE ORDER (ie well suited for compose) *) + type merge_infos = { - ident:identifier; (* new inductive name *) + ident:identifier; (** new inductive name *) mib1: mutual_inductive_body; oib1: one_inductive_body; mib2: mutual_inductive_body; oib2: one_inductive_body; - (* Array of links of the first inductive (should be all stable) *) + + (** Array of links of the first inductive (should be all stable) *) lnk1: int merged_arg array; - (* Array of links of the second inductive (point to the first ind param/args) *) + + (** Array of links of the second inductive (point to the first ind param/args) *) lnk2: int merged_arg array; - (* number of rec params of ind1 which remai rec param in merge *) - nrecprms1: int; - (* number of other rec params of ind1 (which become non parm) *) - notherprms1:int; - (* number of functional result params of ind2 (which become non parm) *) - nfunresprms1:int; - (* list of decl of rec parms from ind1 which remain parms *) + + (** rec params which remain rec param (ie not linked) *) recprms1: rel_declaration list; - (* List of other rec parms from ind1 *) - otherprms1: rel_declaration list; (* parms that became args *) - funresprms1: rel_declaration list; (* parms that are functional result args *) - (* number of rec params of ind2 which remain rec param in merge (and not linked) *) + recprms2: rel_declaration list; + nrecprms1: int; nrecprms2: int; - (* number of other params of ind2 (which become non rec parm) *) + + (** rec parms which became non parm (either linked to something + or because after a rec parm that became non parm) *) + otherprms1: rel_declaration list; + otherprms2: rel_declaration list; + notherprms1:int; notherprms2:int; - (* number of functional result params of ind2 (which become non parm) *) + + (** args which remain args in merge *) + args1:rel_declaration list; + args2:rel_declaration list; + nargs1:int; + nargs2:int; + + (** functional result args *) + funresprms1: rel_declaration list; + funresprms2: rel_declaration list; + nfunresprms1:int; nfunresprms2:int; - (* list of decl of rec parms from ind2 which remain parms (and not linked) *) - recprms2: rel_declaration list; - (* List of other rec parms from ind2 (which are linked or become non parm) *) - otherprms2: rel_declaration list; - funresprms2: rel_declaration list; (* parms that are functional result args *) } @@ -288,7 +314,11 @@ let pr_merginfo x = let isPrm_stable x = match x with Prm_stable _ -> true | _ -> false -let isArg_stable x = match x with Arg_stable _ -> true | _ -> false +(* ?? prm_linked?? *) +let isArg_stable x = match x with Arg_stable _ | Prm_arg _ -> true | _ -> false + +let is_stable x = + match x with Arg_stable _ | Prm_stable _ | Prm_arg _ -> true | _ -> false let isArg_funres x = match x with Arg_funres -> true | _ -> false @@ -346,6 +376,24 @@ let verify_inds mib1 mib2 = if mib2.mind_ntypes <> 1 then error "Second argument is mutual"; () +(* +(** [build_raw_params prms_decl avoid] returns a list of variables + attributed to the list of decl [prms_decl], avoiding names in + [avoid]. *) +let build_raw_params prms_decl avoid = + let dummy_constr = compose_prod (List.map (fun (x,_,z) -> x,z) prms_decl) (mkRel 1) in + let _ = prNamedConstr "DUMMY" dummy_constr in + let dummy_rawconstr = Detyping.detype false avoid [] dummy_constr in + let _ = prNamedRConstr "RAWDUMMY" dummy_rawconstr in + let res,_ = raw_decompose_prod dummy_rawconstr in + let comblist = List.combine prms_decl res in + comblist, res , (avoid @ (Idset.elements (ids_of_rawterm dummy_rawconstr))) +*) + +let ids_of_rawlist avoid rawl = + List.fold_left Idset.union avoid (List.map ids_of_rawterm rawl) + + (** {1 Merging function graphs} *) @@ -366,6 +414,7 @@ let verify_inds mib1 mib2 = ones, they become non rec (and the following too). And functinal argument have to be shifted at the end *) let shift_linked_params mib1 mib2 (lnk1:linked_var array) (lnk2:linked_var array) id = + let _ = prstr "\nYOUHOU shift\n" in let linked_targets = revlinked lnk2 in let is_param_of_mib1 x = x < mib1.mind_nparams_rec in let is_param_of_mib2 x = x < mib2.mind_nparams_rec in @@ -409,15 +458,29 @@ let shift_linked_params mib1 mib2 (lnk1:linked_var array) (lnk2:linked_var array let n_params2 = array_prfx mlnk2 (fun i x -> not (isPrm_stable x)) in let bldprms arity_ctxt mlnk = list_fold_lefti - (fun i (acc1,acc2,acc3) x -> + (fun i (acc1,acc2,acc3,acc4) x -> + prstr (pr_merginfo mlnk.(i));prstr "\n"; match mlnk.(i) with - | Prm_stable _ -> x::acc1 , acc2 , acc3 - | Prm_arg _ | Arg_stable _ -> acc1 , x::acc2 , acc3 - | Arg_funres -> acc1 , acc2 , x::acc3 - | _ -> acc1 , acc2 , acc3) (* Prm_linked and Arg_xxx = forget it *) - ([],[],[]) arity_ctxt in - let recprms1,otherprms1,funresprms1 = bldprms (List.rev oib1.mind_arity_ctxt) mlnk1 in - let recprms2,otherprms2,funresprms2 = bldprms (List.rev oib2.mind_arity_ctxt) mlnk2 in + | Prm_stable _ -> x::acc1 , acc2 , acc3, acc4 + | Prm_arg _ -> acc1 , x::acc2 , acc3, acc4 + | Arg_stable _ -> acc1 , acc2 , x::acc3, acc4 + | Arg_funres -> acc1 , acc2 , acc3, x::acc4 + | _ -> acc1 , acc2 , acc3, acc4) + ([],[],[],[]) arity_ctxt in +(* let arity_ctxt2 = + build_raw_params oib2.mind_arity_ctxt + (Idset.elements (ids_of_rawterm oib1.mind_arity_ctxt)) in*) + let recprms1,otherprms1,args1,funresprms1 = bldprms (List.rev oib1.mind_arity_ctxt) mlnk1 in + let _ = prstr "\n\n\n" in + let recprms2,otherprms2,args2,funresprms2 = bldprms (List.rev oib2.mind_arity_ctxt) mlnk2 in + let _ = prstr "\notherprms1:\n" in + let _ = + List.iter (fun (x,_,y) -> prstr (string_of_name x^" : ");prconstr y;prstr "\n") + otherprms1 in + let _ = prstr "\notherprms2:\n" in + let _ = + List.iter (fun (x,_,y) -> prstr (string_of_name x^" : ");prconstr y;prstr "\n") + otherprms2 in { ident=id; mib1=mib1; @@ -429,14 +492,18 @@ let shift_linked_params mib1 mib2 (lnk1:linked_var array) (lnk2:linked_var array nrecprms1 = n_params1; recprms1 = recprms1; otherprms1 = otherprms1; + args1 = args1; funresprms1 = funresprms1; notherprms1 = Array.length mlnk1 - n_params1; nfunresprms1 = List.length funresprms1; + nargs1 = List.length args1; nrecprms2 = n_params2; recprms2 = recprms2; otherprms2 = otherprms2; + args2 = args2; funresprms2 = funresprms2; notherprms2 = Array.length mlnk2 - n_params2; + nargs2 = List.length args2; nfunresprms2 = List.length funresprms2; } @@ -447,45 +514,61 @@ let shift_linked_params mib1 mib2 (lnk1:linked_var array) (lnk2:linked_var array exception NoMerge -(* lnk is an link array of *all* args (from 1 and 2) *) -let merge_app c1 c2 id1 id2 shift filter_shift_stable = +let rec merge_app c1 c2 id1 id2 shift filter_shift_stable = let lnk = Array.append shift.lnk1 shift.lnk2 in match c1 , c2 with | RApp(_,f1, arr1), RApp(_,f2,arr2) when isVarf id1 f1 && isVarf id2 f2 -> + let _ = prstr "\nICI1!\n";Pp.flush_all() in let args = filter_shift_stable lnk (arr1 @ arr2) in RApp (dummy_loc,RVar (dummy_loc,shift.ident) , args) | RApp(_,f1, arr1), RApp(_,f2,arr2) -> raise NoMerge - | _ -> raise NoMerge - -let merge_app_unsafe c1 c2 shift filter_shift_stable = + | RLetIn(_,nme,bdy,trm) , _ -> + let _ = prstr "\nICI2!\n";Pp.flush_all() in + let newtrm = merge_app trm c2 id1 id2 shift filter_shift_stable in + RLetIn(dummy_loc,nme,bdy,newtrm) + | _, RLetIn(_,nme,bdy,trm) -> + let _ = prstr "\nICI3!\n";Pp.flush_all() in + let newtrm = merge_app c1 trm id1 id2 shift filter_shift_stable in + RLetIn(dummy_loc,nme,bdy,newtrm) + | _ -> let _ = prstr "\nICI4!\n";Pp.flush_all() in + raise NoMerge + +let rec merge_app_unsafe c1 c2 shift filter_shift_stable = let lnk = Array.append shift.lnk1 shift.lnk2 in match c1 , c2 with | RApp(_,f1, arr1), RApp(_,f2,arr2) -> let args = filter_shift_stable lnk (arr1 @ arr2) in RApp (dummy_loc,RVar(dummy_loc,shift.ident) , args) - | _ -> raise NoMerge + (* FIXME: what if the function appears in the body of the let? *) + | RLetIn(_,nme,bdy,trm) , _ -> + let _ = prstr "\nICI2 '!\n";Pp.flush_all() in + let newtrm = merge_app_unsafe trm c2 shift filter_shift_stable in + RLetIn(dummy_loc,nme,bdy,newtrm) + | _, RLetIn(_,nme,bdy,trm) -> + let _ = prstr "\nICI3 '!\n";Pp.flush_all() in + let newtrm = merge_app_unsafe c1 trm shift filter_shift_stable in + RLetIn(dummy_loc,nme,bdy,newtrm) + | _ -> let _ = prstr "\nICI4 '!\n";Pp.flush_all() in raise NoMerge (* Heuristic when merging two lists of hypothesis: merge every rec - calls of nrach 1 with all rec calls of branch 2. *) + calls of branch 1 with all rec calls of branch 2. *) (* TODO: reecrire cette heuristique (jusqu'a merge_types) *) -let onefoud = ref false (* Ugly *) - -let rec merge_rec_hyps shift accrec (ltyp:(Names.name * Rawterm.rawconstr) list) - filter_shift_stable = +let rec merge_rec_hyps shift accrec + (ltyp:(Names.name * rawconstr option * rawconstr option) list) + filter_shift_stable : (Names.name * rawconstr option * rawconstr option) list = + let mergeonehyp t reldecl = + match reldecl with + | (nme,x,Some (RApp(_,i,args) as ind)) + -> nme,x, Some (merge_app_unsafe ind t shift filter_shift_stable) + | (nme,Some _,None) -> error "letins with recursive calls not treated yet" + | (nme,None,Some _) -> assert false + | (nme,None,None) | (nme,Some _,Some _) -> assert false in match ltyp with | [] -> [] - | (nme,(RApp(_,f, largs) as t)) :: lt when isVarf ind2name f -> - let _ = onefoud := true in - let rechyps = - List.map - (fun (nme,ind) -> - match ind with - | RApp(_,i,args) -> - nme, merge_app_unsafe ind t shift filter_shift_stable - | _ -> assert false) - accrec in + | (nme,None,Some (RApp(_,f, largs) as t)) :: lt when isVarf ind2name f -> + let rechyps = List.map (mergeonehyp t) accrec in rechyps @ merge_rec_hyps shift accrec lt filter_shift_stable | e::lt -> e :: merge_rec_hyps shift accrec lt filter_shift_stable @@ -494,50 +577,58 @@ let rec build_suppl_reccall (accrec:(name * rawconstr) list) concl2 shift = List.map (fun (nm,tp) -> (nm,merge_app_unsafe tp concl2 shift)) accrec -let find_app (nme:identifier) (ltyp: (name * rawconstr) list) = +let find_app (nme:identifier) ltyp = try ignore (List.map (fun x -> match x with - | _,(RApp(_,f,_)) when isVarf nme f -> raise (Found 0) + | _,None,Some (RApp(_,f,_)) when isVarf nme f -> raise (Found 0) | _ -> ()) ltyp); false with Found _ -> true + +let prnt_prod_or_letin nm letbdy typ = + match letbdy , typ with + | Some lbdy , None -> prNamedRConstr ("(letin) " ^ string_of_name nm) lbdy + | None , Some tp -> prNamedRConstr (string_of_name nm) tp + | _ , _ -> assert false + -let rec merge_types shift accrec1 (ltyp1:(name * rawconstr) list) - concl1 (ltyp2:(name * rawconstr) list) concl2 - : (name * rawconstr) list * rawconstr = +let rec merge_types shift accrec1 + (ltyp1:(name * rawconstr option * rawconstr option) list) + (concl1:rawconstr) (ltyp2:(name * rawconstr option * rawconstr option) list) concl2 + : (name * rawconstr option * rawconstr option) list * rawconstr = let _ = prstr "MERGE_TYPES\n" in let _ = prstr "ltyp 1 : " in - let _ = List.iter (fun (nm,tp) -> prNamedRConstr (string_of_name nm) tp) ltyp1 in + let _ = List.iter (fun (nm,lbdy,tp) -> prnt_prod_or_letin nm lbdy tp) ltyp1 in let _ = prstr "\nltyp 2 : " in - let _ = List.iter (fun (nm,tp) -> prNamedRConstr (string_of_name nm) tp) ltyp2 in + let _ = List.iter (fun (nm,lbdy,tp) -> prnt_prod_or_letin nm lbdy tp) ltyp2 in let _ = prstr "\n" in - - let res = match ltyp1 with | [] -> let isrec1 = (accrec1<>[]) in let isrec2 = find_app ind2name ltyp2 in - let _ = if isrec2 then prstr " ISREC2 TRUE" else prstr " ISREC2 FALSE" in - let _ = if isrec1 then prstr " ISREC1 TRUE\n" else prstr " ISREC1 FALSE\n" in let rechyps = if isrec1 && isrec2 - then merge_rec_hyps shift accrec1 ltyp2 filter_shift_stable + then (* merge_rec_hyps shift accrec1 ltyp2 filter_shift_stable *) + merge_rec_hyps shift [name_of_string "concl1",None,Some concl1] ltyp2 + filter_shift_stable_right + @ merge_rec_hyps shift accrec1 [name_of_string "concl2",None, Some concl2] + filter_shift_stable else if isrec1 (* if rec calls in accrec1 and not in ltyp2, add one to ltyp2 *) - then merge_rec_hyps shift accrec1 (ltyp2@[name_of_string "concl2",concl2]) - filter_shift_stable + then + merge_rec_hyps shift accrec1 + (ltyp2@[name_of_string "concl2",None,Some concl2]) filter_shift_stable else if isrec2 - then merge_rec_hyps shift [name_of_string "concl1",concl1] ltyp2 + then merge_rec_hyps shift [name_of_string "concl1",None,Some concl1] ltyp2 filter_shift_stable_right - else [] in + else ltyp2 in let _ = prstr"\nrechyps : " in - let _ = List.iter - (fun (nm,tp) -> prNamedRConstr (string_of_name nm) tp) rechyps in + let _ = List.iter(fun (nm,lbdy,tp)-> prnt_prod_or_letin nm lbdy tp) rechyps in let _ = prstr "MERGE CONCL : " in let _ = prNamedRConstr "concl1" concl1 in let _ = prstr " with " in @@ -548,15 +639,22 @@ let rec merge_types shift accrec1 (ltyp1:(name * rawconstr) list) let _ = prstr "FIN " in let _ = prNamedRConstr "concl" concl in let _ = prstr "\n" in + rechyps , concl - | (nme,t1)as e ::lt1 -> - match t1 with + | (nme,None, Some t1)as e ::lt1 -> + (match t1 with | RApp(_,f,carr) when isVarf ind1name f -> merge_types shift (e::accrec1) lt1 concl1 ltyp2 concl2 | _ -> let recres, recconcl2 = merge_types shift accrec1 lt1 concl1 ltyp2 concl2 in - ((nme,t1) :: recres) , recconcl2 + ((nme,None,Some t1) :: recres) , recconcl2) + | (nme,Some bd, None) ::lt1 -> + (* FIXME: what if ind1name appears in bd? *) + let recres, recconcl2 = + merge_types shift accrec1 lt1 concl1 ltyp2 concl2 in + ((nme,Some bd,None) :: recres) , recconcl2 + | (_,None,None)::_ | (_,Some _,Some _)::_ -> assert false in res @@ -578,9 +676,9 @@ let build_link_map_aux (allargs1:identifier array) (allargs2:identifier array) let build_link_map allargs1 allargs2 lnk = let allargs1 = - Array.of_list (List.rev (List.map (fun (x,y) -> id_of_name x) allargs1)) in + Array.of_list (List.rev (List.map (fun (x,_,_) -> id_of_name x) allargs1)) in let allargs2 = - Array.of_list (List.rev (List.map (fun (x,y) -> id_of_name x) allargs2)) in + Array.of_list (List.rev (List.map (fun (x,_,_) -> id_of_name x) allargs2)) in build_link_map_aux allargs1 allargs2 lnk @@ -598,7 +696,7 @@ let build_link_map allargs1 allargs2 lnk = forall recparams1 (recparams2 without linked params), forall ordparams1 (ordparams2 without linked params), - H1a' -> H2a' -> ... -> H2a' -> H2b' -> ... + H1a' -> H2a' -> ... -> H2a' -> H2b'(shifted) -> ... -> (newI x1 ... z1 x2 y2 ...z2 without linked params) where Hix' have been adapted, ie: @@ -621,21 +719,27 @@ let merge_one_constructor (shift:merge_infos) (typcstr1:rawconstr) shift.mib1.mind_nparams + shift.oib1.mind_nrealargs - shift.nfunresprms1 in let nargs2 = shift.mib2.mind_nparams + shift.oib2.mind_nrealargs - shift.nfunresprms2 in - let allargs1,rest1 = raw_decompose_prod_n nargs1 typcstr1 in - let allargs2,rest2 = raw_decompose_prod_n nargs2 typcstr2 in + let allargs1,rest1 = raw_decompose_prod_or_letin_n nargs1 typcstr1 in + let allargs2,rest2 = raw_decompose_prod_or_letin_n nargs2 typcstr2 in (* Build map of linked args of [typcstr2], and apply it to [typcstr2]. *) let linked_map = build_link_map allargs1 allargs2 shift.lnk2 in let rest2 = change_vars linked_map rest2 in - let hyps1,concl1 = raw_decompose_prod rest1 in - let hyps2,concl2' = raw_decompose_prod rest2 in + let hyps1,concl1 = raw_decompose_prod_or_letin rest1 in + let hyps2,concl2' = raw_decompose_prod_or_letin rest2 in let ltyp,concl2 = merge_types shift [] (List.rev hyps1) concl1 (List.rev hyps2) concl2' in - let typ = raw_compose_prod concl2 (List.rev ltyp) in + let _ = prNamedRLDecl "ltyp result:" ltyp in + let typ = raw_compose_prod_or_letin concl2 (List.rev ltyp) in let revargs1 = list_filteri (fun i _ -> isArg_stable shift.lnk1.(i)) (List.rev allargs1) in + let _ = prNamedRLDecl "ltyp allargs1" allargs1 in + let _ = prNamedRLDecl "ltyp revargs1" revargs1 in let revargs2 = list_filteri (fun i _ -> isArg_stable shift.lnk2.(i)) (List.rev allargs2) in - let typwithprms = raw_compose_prod typ (List.rev revargs2 @ List.rev revargs1) in + let _ = prNamedRLDecl "ltyp allargs2" allargs2 in + let _ = prNamedRLDecl "ltyp revargs2" revargs2 in + let typwithprms = + raw_compose_prod_or_letin typ (List.rev revargs2 @ List.rev revargs1) in typwithprms @@ -661,22 +765,16 @@ let merge_constructor_id id1 id2 shift:identifier = constructor [(name*type)]. These are translated to rawterms first, each of them having distinct var names. *) let rec merge_constructors (shift:merge_infos) (avoid:Idset.t) - (typcstr1:(identifier * types) list) - (typcstr2:(identifier * types) list) : (identifier * rawconstr) list = + (typcstr1:(identifier * rawconstr) list) + (typcstr2:(identifier * rawconstr) list) : (identifier * rawconstr) list = List.flatten (List.map - (fun (id1,typ1) -> - let typ1 = substitterm 0 (mkRel 1) (mkVar ind1name) typ1 in - let rawtyp1 = Detyping.detype false (Idset.elements avoid) [] typ1 in - let idsoftyp1:Idset.t = ids_of_rawterm rawtyp1 in + (fun (id1,rawtyp1) -> List.map - (fun (id2,typ2) -> - let typ2 = substitterm 0 (mkRel 1) (mkVar ind2name) typ2 in - (* Avoid also rawtyp1 names *) - let avoid2 = Idset.union avoid idsoftyp1 in - let rawtyp2 = Detyping.detype false (Idset.elements avoid2) [] typ2 in + (fun (id2,rawtyp2) -> let typ = merge_one_constructor shift rawtyp1 rawtyp2 in let newcstror_id = merge_constructor_id id1 id2 shift in + let _ = prstr "\n**************\n" in newcstror_id , typ) typcstr2) typcstr1) @@ -685,22 +783,33 @@ let rec merge_constructors (shift:merge_infos) (avoid:Idset.t) inductive bodies [oib1] and [oib2], linking with [lnk], params info in [shift], avoiding identifiers in [avoid]. *) let rec merge_inductive_body (shift:merge_infos) avoid (oib1:one_inductive_body) - (oib2:one_inductive_body) : (identifier * rawconstr) list = - let lcstr1 = Array.to_list oib1.mind_user_lc in - let lcstr2 = Array.to_list oib2.mind_user_lc in + (oib2:one_inductive_body) = + (* building rawconstr type of constructors *) + let mkrawcor nme avoid typ = + (* first replace rel 1 by a varname *) + let substindtyp = substitterm 0 (mkRel 1) (mkVar nme) typ in + Detyping.detype false (Idset.elements avoid) [] substindtyp in + let lcstr1: rawconstr list = + Array.to_list (Array.map (mkrawcor ind1name avoid) oib1.mind_user_lc) in + (* add to avoid all indentifiers of lcstr1 *) + let avoid2 = Idset.union avoid (ids_of_rawlist avoid lcstr1) in + let lcstr2 = + Array.to_list (Array.map (mkrawcor ind2name avoid2) oib2.mind_user_lc) in + let avoid3 = Idset.union avoid (ids_of_rawlist avoid lcstr2) in + + let params1 = + try fst (raw_decompose_prod_n shift.nrecprms1 (List.hd lcstr1)) + with _ -> [] in + let params2 = + try fst (raw_decompose_prod_n shift.nrecprms2 (List.hd lcstr2)) + with _ -> [] in + let lcstr1 = List.combine (Array.to_list oib1.mind_consnames) lcstr1 in let lcstr2 = List.combine (Array.to_list oib2.mind_consnames) lcstr2 in + cstror_suffix_init(); - merge_constructors shift avoid lcstr1 lcstr2 + params1,params2,merge_constructors shift avoid3 lcstr1 lcstr2 -(** [build_raw_params prms_decl avoid] returns a list of variables - attributed to the list of decl [prms_decl], avoiding names in - [avoid]. *) -let build_raw_params prms_decl avoid = - let dummy_constr = compose_prod prms_decl mkProp in - let dummy_rawconstr = Detyping.detype false avoid [] dummy_constr in - let res,_ = raw_decompose_prod dummy_rawconstr in - res , (avoid @ (Idset.elements (ids_of_rawterm dummy_rawconstr))) (** [merge_mutual_inductive_body lnk mib1 mib2 shift] merge mutual inductive bodies [mib1] and [mib2] linking vars with @@ -708,42 +817,35 @@ let build_raw_params prms_decl avoid = For the moment, inductives are supposed to be non mutual. *) let rec merge_mutual_inductive_body - (mib1:mutual_inductive_body) (mib2:mutual_inductive_body) - (shift:merge_infos) = + (mib1:mutual_inductive_body) (mib2:mutual_inductive_body) (shift:merge_infos) = (* Mutual not treated, we take first ind body of each. *) - let nprms1 = mib1.mind_nparams_rec in (* n# of rec uniform parms of mib1 *) - let prms1 = (* rec uniform parms of mib1 *) - List.map (fun (x,_,y) -> x,y) (fst (list_chop nprms1 mib1.mind_params_ctxt)) in - - (* useless: *) - let prms1_named,avoid' = build_raw_params prms1 [] in - let prms2_named,avoid = build_raw_params prms1 avoid' in - let avoid:Idset.t = List.fold_right Idset.add avoid Idset.empty in - (* *** *) - - merge_inductive_body shift avoid mib1.mind_packets.(0) mib2.mind_packets.(0) + merge_inductive_body shift Idset.empty mib1.mind_packets.(0) mib2.mind_packets.(0) +let rawterm_to_constr_expr x = (* build a constr_expr from a rawconstr *) + Flags.with_option Flags.raw_print (Constrextern.extern_rawtype Idset.empty) x -let merge_rec_params_and_arity params1 params2 shift (concl:constr) = - let params = shift.recprms1 @ shift.recprms2 in - let resparams, _ = +let merge_rec_params_and_arity prms1 prms2 shift (concl:constr) = + let params = prms2 @ prms1 in + let resparams = List.fold_left - (fun (acc,env) (nme,_,tp) -> - let typ = Constrextern.extern_constr false env tp in - let newenv = Environ.push_rel (nme,None,tp) env in - LocalRawAssum ([(dummy_loc,nme)] , typ) :: acc , newenv) - ([],Global.env()) - params in + (fun acc (nme,tp) -> + let _ = prstr "param :" in + let _ = prNamedRConstr (string_of_name nme) tp in + let _ = prstr " ; " in + let typ = rawterm_to_constr_expr tp in + LocalRawAssum ([(dummy_loc,nme)], Topconstr.default_binder_kind, typ) :: acc) + [] params in let concl = Constrextern.extern_constr false (Global.env()) concl in let arity,_ = List.fold_left (fun (acc,env) (nm,_,c) -> let typ = Constrextern.extern_constr false env c in let newenv = Environ.push_rel (nm,None,c) env in - CProdN (dummy_loc, [[(dummy_loc,nm)],typ] , acc) , newenv) + CProdN (dummy_loc, [[(dummy_loc,nm)],Topconstr.default_binder_kind,typ] , acc) , newenv) (concl,Global.env()) - (shift.otherprms1@shift.otherprms2@shift.funresprms1@shift.funresprms2) in + (shift.funresprms2 @ shift.funresprms1 + @ shift.args2 @ shift.args1 @ shift.otherprms2 @ shift.otherprms1) in resparams,arity @@ -752,20 +854,37 @@ let merge_rec_params_and_arity params1 params2 shift (concl:constr) = induct_expr corresponding to the the list of constructor types [rawlist], named ident. FIXME: params et cstr_expr (arity) *) -let rawterm_list_to_inductive_expr mib1 mib2 shift +let rawterm_list_to_inductive_expr prms1 prms2 mib1 mib2 shift (rawlist:(identifier * rawconstr) list):inductive_expr = - let rawterm_to_constr_expr x = (* build a constr_expr from a rawconstr *) - Options.with_option Options.raw_print (Constrextern.extern_rawtype Idset.empty) x in let lident = dummy_loc, shift.ident in let bindlist , cstr_expr = (* params , arities *) - merge_rec_params_and_arity - mib1.mind_params_ctxt mib2.mind_params_ctxt shift mkSet in + merge_rec_params_and_arity prms1 prms2 shift mkSet in let lcstor_expr : (bool * (lident * constr_expr)) list = List.map (* zeta_normalize t ? *) (fun (id,t) -> false, ((dummy_loc,id),rawterm_to_constr_expr t)) rawlist in lident , bindlist , cstr_expr , lcstor_expr + + +let mkProd_reldecl (rdecl:rel_declaration) (t2:rawconstr) = + match rdecl with + | (nme,None,t) -> + let traw = Detyping.detype false [] [] t in + RProd (dummy_loc,nme,Explicit,traw,t2) + | (_,Some _,_) -> assert false + + + + +let mkProd_reldecl (rdecl:rel_declaration) (t2:rawconstr) = + match rdecl with + | (nme,None,t) -> + let traw = Detyping.detype false [] [] t in + RProd (dummy_loc,nme,Explicit,traw,t2) + | (_,Some _,_) -> assert false + + (** [merge_inductive ind1 ind2 lnk] merges two graphs, linking variables specified in [lnk]. Graphs are not supposed to be mutual inductives for the moment. *) @@ -777,35 +896,124 @@ let merge_inductive (ind1: inductive) (ind2: inductive) let _ = verify_inds mib1 mib2 in (* raises an exception if something wrong *) (* compute params that become ordinary args (because linked to ord. args) *) let shift_prm = shift_linked_params mib1 mib2 lnk1 lnk2 id in - let rawlist = merge_mutual_inductive_body mib1 mib2 shift_prm in - let indexpr = rawterm_list_to_inductive_expr mib1 mib2 shift_prm rawlist in + let prms1,prms2, rawlist = merge_mutual_inductive_body mib1 mib2 shift_prm in + let _ = prstr "\nrawlist : " in + let _ = + List.iter (fun (nm,tp) -> prNamedRConstr (string_of_id nm) tp;prstr "\n") rawlist in + let _ = prstr "\nend rawlist\n" in +(* FIX: retransformer en constr ici + let shift_prm = + { shift_prm with + recprms1=prms1; + recprms1=prms1; + } in *) + let indexpr = rawterm_list_to_inductive_expr prms1 prms2 mib1 mib2 shift_prm rawlist in (* Declare inductive *) Command.build_mutual [(indexpr,None)] true (* means: not coinductive *) - -let merge (cstr1:constr) (cstr2:constr) (args1:constr array) (args2:constr array) id = - let env = Global.env() in - let ind1,_cstrlist1 = Inductiveops.find_inductive env Evd.empty cstr1 in - let ind2,_cstrlist2 = Inductiveops.find_inductive env Evd.empty cstr2 in - let lnk1 = (* args1 are unlinked. FIXME? mergescheme (G x x) ?? *) - Array.mapi (fun i c -> Unlinked) args1 in - let _ = lnk1.(Array.length lnk1 - 1) <- Funres in (* last arg is functional result *) - let lnk2 = (* args2 may be linked to args1 members. FIXME: same - as above: vars may be linked inside args2?? *) +(* Find infos on identifier id. *) +let find_Function_infos_safe (id:identifier): Indfun_common.function_info = + let kn_of_id x = + let f_ref = Libnames.Ident (dummy_loc,x) in + locate_with_msg (str "Don't know what to do with " ++ Libnames.pr_reference f_ref) + locate_constant f_ref in + try find_Function_infos (kn_of_id id) + with Not_found -> + errorlabstrm "indfun" (Nameops.pr_id id ++ str " has no functional scheme") + +(** [merge id1 id2 args1 args2 id] builds and declares a new inductive + type called [id], representing the merged graphs of both graphs + [ind1] and [ind2]. identifiers occuring in both arrays [args1] and + [args2] are considered linked (i.e. are the same variable) in the + new graph. + + Warning: For the moment, repetitions of an id in [args1] or + [args2] are not supported. *) +let merge (id1:identifier) (id2:identifier) (args1:identifier array) + (args2:identifier array) id : unit = + let finfo1 = find_Function_infos_safe id1 in + let finfo2 = find_Function_infos_safe id2 in + (* FIXME? args1 are supposed unlinked. mergescheme (G x x) ?? *) + (* We add one arg (functional arg of the graph) *) + let lnk1 = Array.make (Array.length args1 + 1) Unlinked in + let lnk2' = (* args2 may be linked to args1 members. FIXME: same + as above: vars may be linked inside args2?? *) Array.mapi (fun i c -> match array_find args1 (fun i x -> x=c) with | Some j -> Linked j | None -> Unlinked) args2 in - let _ = lnk2.(Array.length lnk2 - 1) <- Funres in (* last arg is functional result *) - let resa = merge_inductive ind1 ind2 lnk1 lnk2 id in - resa - - - + (* We add one arg (functional arg of the graph) *) + let lnk2 = Array.append lnk2' (Array.make 1 Unlinked) in + (* setting functional results *) + let _ = lnk1.(Array.length lnk1 - 1) <- Funres in + let _ = lnk2.(Array.length lnk2 - 1) <- Funres in + merge_inductive finfo1.graph_ind finfo2.graph_ind lnk1 lnk2 id + + +let remove_last_arg c = + let (x,y) = decompose_prod c in + let xnolast = List.rev (List.tl (List.rev x)) in + compose_prod xnolast y + +let rec remove_n_fst_list n l = if n=0 then l else remove_n_fst_list (n-1) (List.tl l) +let remove_n_last_list n l = List.rev (remove_n_fst_list n (List.rev l)) + +let remove_last_n_arg n c = + let (x,y) = decompose_prod c in + let xnolast = remove_n_last_list n x in + compose_prod xnolast y + +(* [funify_branches relinfo nfuns branch] returns the branch [branch] + of the relinfo [relinfo] modified to fit in a functional principle. + Things to do: + - remove indargs from rel applications + - replace *variables only* corresponding to function (recursive) + results by the actual function application. *) +let funify_branches relinfo nfuns branch = + let mut_induct, induct = + match relinfo.indref with + | None -> assert false + | Some (IndRef ((mutual_ind,i) as ind)) -> mutual_ind,ind + | _ -> assert false in + let is_dom c = + match kind_of_term c with + | Ind((u,_)) | Construct((u,_),_) -> u = mut_induct + | _ -> false in + let _dom_i c = + assert (is_dom c); + match kind_of_term c with + | Ind((u,i)) | Construct((u,_),i) -> i + | _ -> assert false in + let _is_pred c shift = + match kind_of_term c with + | Rel i -> let reali = i-shift in (reali>=0 && reali<relinfo.nbranches) + | _ -> false in + (* FIXME: *) + (Anonymous,Some mkProp,mkProp) + +let relprinctype_to_funprinctype relprinctype nfuns = + let relinfo = compute_elim_sig relprinctype in + assert (not relinfo.farg_in_concl); + assert (relinfo.indarg_in_concl); + (* first remove indarg and indarg_in_concl *) + let relinfo_noindarg = { relinfo with + indarg_in_concl = false; indarg = None; + concl = remove_last_arg (pop relinfo.concl); } in + (* the nfuns last induction arguments are functional ones: remove them *) + let relinfo_argsok = { relinfo_noindarg with + nargs = relinfo_noindarg.nargs - nfuns; + (* args is in reverse order, so remove fst *) + args = remove_n_fst_list nfuns relinfo_noindarg.args; + concl = popn nfuns relinfo_noindarg.concl + } in + let new_branches = + List.map (funify_branches relinfo_argsok nfuns) relinfo_argsok.branches in + let relinfo_branches = { relinfo_argsok with branches = new_branches } in + relinfo_branches (* @article{ bundy93rippling, author = "Alan Bundy and Andrew Stevens and Frank van Harmelen and Andrew Ireland and Alan Smaill", diff --git a/contrib/funind/rawterm_to_relation.ml b/contrib/funind/rawterm_to_relation.ml index b34a1097..08a97fd2 100644 --- a/contrib/funind/rawterm_to_relation.ml +++ b/contrib/funind/rawterm_to_relation.ml @@ -368,7 +368,7 @@ let raw_push_named (na,raw_value,raw_typ) env = match na with | Anonymous -> env | Name id -> - let value = Util.option_map (Pretyping.Default.understand Evd.empty env) raw_value in + let value = Option.map (Pretyping.Default.understand Evd.empty env) raw_value in let typ = Pretyping.Default.understand_type Evd.empty env raw_typ in Environ.push_named (id,value,typ) env @@ -398,12 +398,12 @@ let add_pat_variables pat typ env : Environ.env = | Anonymous -> assert false | Name id -> let new_t = substl ctxt t in - let new_v = option_map (substl ctxt) v in + let new_v = Option.map (substl ctxt) v in observe (str "for variable " ++ Ppconstr.pr_id id ++ fnl () ++ str "old type := " ++ Printer.pr_lconstr t ++ fnl () ++ str "new type := " ++ Printer.pr_lconstr new_t ++ fnl () ++ - option_fold_right (fun v _ -> str "old value := " ++ Printer.pr_lconstr v ++ fnl ()) v (mt ()) ++ - option_fold_right (fun v _ -> str "new value := " ++ Printer.pr_lconstr v ++ fnl ()) new_v (mt ()) + Option.fold_right (fun v _ -> str "old value := " ++ Printer.pr_lconstr v ++ fnl ()) v (mt ()) ++ + Option.fold_right (fun v _ -> str "new value := " ++ Printer.pr_lconstr v ++ fnl ()) new_v (mt ()) ); (Environ.push_named (id,new_v,new_t) env,mkVar id::ctxt) ) @@ -446,7 +446,7 @@ let rec pattern_to_term_and_type env typ = function let patl_as_term = List.map2 (pattern_to_term_and_type env) (List.rev cs_args_types) patternl in - mkRApp(mkRRef(Libnames.ConstructRef constr), + mkRApp(mkRRef(ConstructRef constr), implicit_args@patl_as_term ) @@ -586,7 +586,7 @@ let rec build_entry_lc env funnames avoid rt : rawconstr build_entry_return = | RProd _ -> error "Cannot apply a type" end (* end of the application treatement *) - | RLambda(_,n,t,b) -> + | RLambda(_,n,_,t,b) -> (* we first compute the list of constructor corresponding to the body of the function, then the one corresponding to the type @@ -601,7 +601,7 @@ let rec build_entry_lc env funnames avoid rt : rawconstr build_entry_return = let new_env = raw_push_named (new_n,None,t) env in let b_res = build_entry_lc new_env funnames avoid b in combine_results (combine_lam new_n) t_res b_res - | RProd(_,n,t,b) -> + | RProd(_,n,_,t,b) -> (* we first compute the list of constructor corresponding to the body of the function, then the one corresponding to the type @@ -627,7 +627,7 @@ let rec build_entry_lc env funnames avoid rt : rawconstr build_entry_return = in let b_res = build_entry_lc new_env funnames avoid b in combine_results (combine_letin n) v_res b_res - | RCases(_,_,el,brl) -> + | RCases(_,_,_,el,brl) -> (* we create the discrimination function and treat the case itself *) @@ -689,7 +689,7 @@ let rec build_entry_lc env funnames avoid rt : rawconstr build_entry_return = build_entry_lc env funnames avoid b | RDynamic _ -> error "Not handled RDynamic" and build_entry_lc_from_case env funname make_discr - (el:tomatch_tuple) + (el:tomatch_tuples) (brl:Rawterm.cases_clauses) avoid : rawconstr build_entry_return = match el with @@ -865,7 +865,7 @@ let is_res id = *) let rec rebuild_cons nb_args relname args crossed_types depth rt = match rt with - | RProd(_,n,t,b) -> + | RProd(_,n,k,t,b) -> let not_free_in_t id = not (is_free_in id t) in let new_crossed_types = t::crossed_types in begin @@ -928,7 +928,7 @@ let rec rebuild_cons nb_args relname args crossed_types depth rt = (Idset.filter not_free_in_t id_to_exclude) | _ -> mkRProd(n,t,new_b),Idset.filter not_free_in_t id_to_exclude end - | RLambda(_,n,t,b) -> + | RLambda(_,n,k,t,b) -> begin let not_free_in_t id = not (is_free_in id t) in let new_crossed_types = t :: crossed_types in @@ -944,7 +944,7 @@ let rec rebuild_cons nb_args relname args crossed_types depth rt = then new_b, Idset.remove id (Idset.filter not_free_in_t id_to_exclude) else - RProd(dummy_loc,n,t,new_b),Idset.filter not_free_in_t id_to_exclude + RProd(dummy_loc,n,k,t,new_b),Idset.filter not_free_in_t id_to_exclude | _ -> anomaly "Should not have an anonymous function here" (* We have renamed all the anonymous functions during alpha_renaming phase *) @@ -1016,11 +1016,12 @@ let rec compute_cst_params relnames params = function compute_cst_params_from_app [] (params,rtl) | RApp(_,f,args) -> List.fold_left (compute_cst_params relnames) params (f::args) - | RLambda(_,_,t,b) | RProd(_,_,t,b) | RLetIn(_,_,t,b) | RLetTuple(_,_,_,t,b) -> + | RLambda(_,_,_,t,b) | RProd(_,_,_,t,b) | RLetIn(_,_,t,b) | RLetTuple(_,_,_,t,b) -> let t_params = compute_cst_params relnames params t in compute_cst_params relnames t_params b - | RCases _ -> params (* If there is still cases at this point they can only be - discriminitation ones *) + | RCases _ -> + params (* If there is still cases at this point they can only be + discriminitation ones *) | RSort _ -> params | RHole _ -> params | RIf _ | RRec _ | RCast _ | RDynamic _ -> @@ -1153,7 +1154,7 @@ let do_build_inductive else Topconstr.CProdN (dummy_loc, - [[(dummy_loc,n)],Constrextern.extern_rawconstr Idset.empty t], + [[(dummy_loc,n)],Topconstr.default_binder_kind,Constrextern.extern_rawconstr Idset.empty t], acc ) ) @@ -1173,7 +1174,7 @@ let do_build_inductive Topconstr.LocalRawDef((dummy_loc,n), Constrextern.extern_rawconstr Idset.empty t) else Topconstr.LocalRawAssum - ([(dummy_loc,n)], Constrextern.extern_rawconstr Idset.empty t) + ([(dummy_loc,n)], Topconstr.default_binder_kind, Constrextern.extern_rawconstr Idset.empty t) ) rels_params in @@ -1181,8 +1182,8 @@ let do_build_inductive Array.map (List.map (fun (id,t) -> false,((dummy_loc,id), - Options.with_option - Options.raw_print + Flags.with_option + Flags.raw_print (Constrextern.extern_rawtype Idset.empty) ((* zeta_normalize *) t) ) )) @@ -1218,7 +1219,7 @@ let do_build_inductive (* in *) let _time2 = System.get_time () in try - with_full_print (Options.silently (Command.build_mutual rel_inds)) true + with_full_print (Flags.silently (Command.build_mutual rel_inds)) true with | UserError(s,msg) as e -> let _time3 = System.get_time () in diff --git a/contrib/funind/rawtermops.ml b/contrib/funind/rawtermops.ml index 113ddd8b..92396af5 100644 --- a/contrib/funind/rawtermops.ml +++ b/contrib/funind/rawtermops.ml @@ -12,10 +12,10 @@ let idmap_is_empty m = m = Idmap.empty let mkRRef ref = RRef(dummy_loc,ref) let mkRVar id = RVar(dummy_loc,id) let mkRApp(rt,rtl) = RApp(dummy_loc,rt,rtl) -let mkRLambda(n,t,b) = RLambda(dummy_loc,n,t,b) -let mkRProd(n,t,b) = RProd(dummy_loc,n,t,b) +let mkRLambda(n,t,b) = RLambda(dummy_loc,n,Explicit,t,b) +let mkRProd(n,t,b) = RProd(dummy_loc,n,Explicit,t,b) let mkRLetIn(n,t,b) = RLetIn(dummy_loc,n,t,b) -let mkRCases(rto,l,brl) = RCases(dummy_loc,rto,l,brl) +let mkRCases(rto,l,brl) = RCases(dummy_loc,Term.RegularStyle,rto,l,brl) let mkRSort s = RSort(dummy_loc,s) let mkRHole () = RHole(dummy_loc,Evd.BinderType Anonymous) let mkRCast(b,t) = RCast(dummy_loc,b,CastConv (Term.DEFAULTcast,t)) @@ -26,27 +26,59 @@ let mkRCast(b,t) = RCast(dummy_loc,b,CastConv (Term.DEFAULTcast,t)) *) let raw_decompose_prod = let rec raw_decompose_prod args = function - | RProd(_,n,t,b) -> + | RProd(_,n,k,t,b) -> raw_decompose_prod ((n,t)::args) b | rt -> args,rt in raw_decompose_prod [] +let raw_decompose_prod_or_letin = + let rec raw_decompose_prod args = function + | RProd(_,n,k,t,b) -> + raw_decompose_prod ((n,None,Some t)::args) b + | RLetIn(_,n,t,b) -> + raw_decompose_prod ((n,Some t,None)::args) b + | rt -> args,rt + in + raw_decompose_prod [] + let raw_compose_prod = List.fold_left (fun b (n,t) -> mkRProd(n,t,b)) +let raw_compose_prod_or_letin = + List.fold_left ( + fun concl decl -> + match decl with + | (n,None,Some t) -> mkRProd(n,t,concl) + | (n,Some bdy,None) -> mkRLetIn(n,bdy,concl) + | _ -> assert false) + let raw_decompose_prod_n n = let rec raw_decompose_prod i args c = if i<=0 then args,c else match c with - | RProd(_,n,t,b) -> + | RProd(_,n,_,t,b) -> raw_decompose_prod (i-1) ((n,t)::args) b | rt -> args,rt in raw_decompose_prod n [] +let raw_decompose_prod_or_letin_n n = + let rec raw_decompose_prod i args c = + if i<=0 then args,c + else + match c with + | RProd(_,n,_,t,b) -> + raw_decompose_prod (i-1) ((n,None,Some t)::args) b + | RLetIn(_,n,t,b) -> + raw_decompose_prod (i-1) ((n,Some t,None)::args) b + | rt -> args,rt + in + raw_decompose_prod n [] + + let raw_decompose_app = let rec decompose_rapp acc rt = (* msgnl (str "raw_decompose_app on : "++ Printer.pr_rawconstr rt); *) @@ -103,15 +135,17 @@ let change_vars = change_vars mapping rt', List.map (change_vars mapping) rtl ) - | RLambda(loc,name,t,b) -> + | RLambda(loc,name,k,t,b) -> RLambda(loc, name, + k, change_vars mapping t, change_vars (remove_name_from_mapping mapping name) b ) - | RProd(loc,name,t,b) -> + | RProd(loc,name,k,t,b) -> RProd(loc, name, + k, change_vars mapping t, change_vars (remove_name_from_mapping mapping name) b ) @@ -125,12 +159,12 @@ let change_vars = let new_mapping = List.fold_left remove_name_from_mapping mapping nal in RLetTuple(loc, nal, - (na, option_map (change_vars mapping) rto), + (na, Option.map (change_vars mapping) rto), change_vars mapping b, change_vars new_mapping e ) - | RCases(loc,infos,el,brl) -> - RCases(loc, + | RCases(loc,sty,infos,el,brl) -> + RCases(loc,sty, infos, List.map (fun (e,x) -> (change_vars mapping e,x)) el, List.map (change_vars_br mapping) brl @@ -138,7 +172,7 @@ let change_vars = | RIf(loc,b,(na,e_option),lhs,rhs) -> RIf(loc, change_vars mapping b, - (na,option_map (change_vars mapping) e_option), + (na,Option.map (change_vars mapping) e_option), change_vars mapping lhs, change_vars mapping rhs ) @@ -229,21 +263,21 @@ let rec alpha_rt excluded rt = let new_rt = match rt with | RRef _ | RVar _ | REvar _ | RPatVar _ -> rt - | RLambda(loc,Anonymous,t,b) -> + | RLambda(loc,Anonymous,k,t,b) -> let new_id = Nameops.next_ident_away (id_of_string "_x") excluded in let new_excluded = new_id :: excluded in let new_t = alpha_rt new_excluded t in let new_b = alpha_rt new_excluded b in - RLambda(loc,Name new_id,new_t,new_b) - | RProd(loc,Anonymous,t,b) -> + RLambda(loc,Name new_id,k,new_t,new_b) + | RProd(loc,Anonymous,k,t,b) -> let new_t = alpha_rt excluded t in let new_b = alpha_rt excluded b in - RProd(loc,Anonymous,new_t,new_b) + RProd(loc,Anonymous,k,new_t,new_b) | RLetIn(loc,Anonymous,t,b) -> let new_t = alpha_rt excluded t in let new_b = alpha_rt excluded b in RLetIn(loc,Anonymous,new_t,new_b) - | RLambda(loc,Name id,t,b) -> + | RLambda(loc,Name id,k,t,b) -> let new_id = Nameops.next_ident_away id excluded in let t,b = if new_id = id @@ -255,8 +289,8 @@ let rec alpha_rt excluded rt = let new_excluded = new_id::excluded in let new_t = alpha_rt new_excluded t in let new_b = alpha_rt new_excluded b in - RLambda(loc,Name new_id,new_t,new_b) - | RProd(loc,Name id,t,b) -> + RLambda(loc,Name new_id,k,new_t,new_b) + | RProd(loc,Name id,k,t,b) -> let new_id = Nameops.next_ident_away id excluded in let new_excluded = new_id::excluded in let t,b = @@ -268,7 +302,7 @@ let rec alpha_rt excluded rt = in let new_t = alpha_rt new_excluded t in let new_b = alpha_rt new_excluded b in - RProd(loc,Name new_id,new_t,new_b) + RProd(loc,Name new_id,k,new_t,new_b) | RLetIn(loc,Name id,t,b) -> let new_id = Nameops.next_ident_away id excluded in let t,b = @@ -306,20 +340,20 @@ let rec alpha_rt excluded rt = if idmap_is_empty mapping then rto,t,b else let replace = change_vars mapping in - (option_map replace rto, t,replace b) + (Option.map replace rto, t,replace b) in let new_t = alpha_rt new_excluded new_t in let new_b = alpha_rt new_excluded new_b in - let new_rto = option_map (alpha_rt new_excluded) new_rto in + let new_rto = Option.map (alpha_rt new_excluded) new_rto in RLetTuple(loc,new_nal,(na,new_rto),new_t,new_b) - | RCases(loc,infos,el,brl) -> + | RCases(loc,sty,infos,el,brl) -> let new_el = List.map (function (rt,i) -> alpha_rt excluded rt, i) el in - RCases(loc,infos,new_el,List.map (alpha_br excluded) brl) + RCases(loc,sty,infos,new_el,List.map (alpha_br excluded) brl) | RIf(loc,b,(na,e_o),lhs,rhs) -> RIf(loc,alpha_rt excluded b, - (na,option_map (alpha_rt excluded) e_o), + (na,Option.map (alpha_rt excluded) e_o), alpha_rt excluded lhs, alpha_rt excluded rhs ) @@ -357,17 +391,16 @@ let is_free_in id = | REvar _ -> false | RPatVar _ -> false | RApp(_,rt,rtl) -> List.exists is_free_in (rt::rtl) - | RLambda(_,n,t,b) | RProd(_,n,t,b) | RLetIn(_,n,t,b) -> + | RLambda(_,n,_,t,b) | RProd(_,n,_,t,b) | RLetIn(_,n,t,b) -> let check_in_b = match n with | Name id' -> id_ord id' id <> 0 | _ -> true in is_free_in t || (check_in_b && is_free_in b) - | RCases(_,_,el,brl) -> + | RCases(_,_,_,el,brl) -> (List.exists (fun (e,_) -> is_free_in e) el) || List.exists is_free_in_br brl - | RLetTuple(_,nal,_,b,t) -> let check_in_nal = not (List.exists (function Name id' -> id'= id | _ -> false) nal) @@ -428,17 +461,19 @@ let replace_var_by_term x_id term = replace_var_by_pattern rt', List.map replace_var_by_pattern rtl ) - | RLambda(_,Name id,_,_) when id_ord id x_id == 0 -> rt - | RLambda(loc,name,t,b) -> + | RLambda(_,Name id,_,_,_) when id_ord id x_id == 0 -> rt + | RLambda(loc,name,k,t,b) -> RLambda(loc, name, + k, replace_var_by_pattern t, replace_var_by_pattern b ) - | RProd(_,Name id,_,_) when id_ord id x_id == 0 -> rt - | RProd(loc,name,t,b) -> + | RProd(_,Name id,_,_,_) when id_ord id x_id == 0 -> rt + | RProd(loc,name,k,t,b) -> RProd(loc, name, + k, replace_var_by_pattern t, replace_var_by_pattern b ) @@ -455,19 +490,19 @@ let replace_var_by_term x_id term = | RLetTuple(loc,nal,(na,rto),def,b) -> RLetTuple(loc, nal, - (na,option_map replace_var_by_pattern rto), + (na,Option.map replace_var_by_pattern rto), replace_var_by_pattern def, replace_var_by_pattern b ) - | RCases(loc,infos,el,brl) -> - RCases(loc, + | RCases(loc,sty,infos,el,brl) -> + RCases(loc,sty, infos, List.map (fun (e,x) -> (replace_var_by_pattern e,x)) el, List.map replace_var_by_pattern_br brl ) | RIf(loc,b,(na,e_option),lhs,rhs) -> RIf(loc, replace_var_by_pattern b, - (na,option_map replace_var_by_pattern e_option), + (na,Option.map replace_var_by_pattern e_option), replace_var_by_pattern lhs, replace_var_by_pattern rhs ) @@ -558,15 +593,15 @@ let ids_of_rawterm c = | RVar (_,id) -> id::acc | RApp (loc,g,args) -> ids_of_rawterm [] g @ List.flatten (List.map (ids_of_rawterm []) args) @ acc - | RLambda (loc,na,ty,c) -> idof na :: ids_of_rawterm [] ty @ ids_of_rawterm [] c @ acc - | RProd (loc,na,ty,c) -> idof na :: ids_of_rawterm [] ty @ ids_of_rawterm [] c @ acc + | RLambda (loc,na,k,ty,c) -> idof na :: ids_of_rawterm [] ty @ ids_of_rawterm [] c @ acc + | RProd (loc,na,k,ty,c) -> idof na :: ids_of_rawterm [] ty @ ids_of_rawterm [] c @ acc | RLetIn (loc,na,b,c) -> idof na :: ids_of_rawterm [] b @ ids_of_rawterm [] c @ acc | RCast (loc,c,CastConv(k,t)) -> ids_of_rawterm [] c @ ids_of_rawterm [] t @ acc | RCast (loc,c,CastCoerce) -> ids_of_rawterm [] c @ acc | RIf (loc,c,(na,po),b1,b2) -> ids_of_rawterm [] c @ ids_of_rawterm [] b1 @ ids_of_rawterm [] b2 @ acc | RLetTuple (_,nal,(na,po),b,c) -> List.map idof nal @ ids_of_rawterm [] b @ ids_of_rawterm [] c @ acc - | RCases (loc,rtntypopt,tml,brchl) -> + | RCases (loc,sty,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 _) -> [] @@ -590,15 +625,17 @@ let zeta_normalize = zeta_normalize_term rt', List.map zeta_normalize_term rtl ) - | RLambda(loc,name,t,b) -> + | RLambda(loc,name,k,t,b) -> RLambda(loc, name, + k, zeta_normalize_term t, zeta_normalize_term b ) - | RProd(loc,name,t,b) -> + | RProd(loc,name,k,t,b) -> RProd(loc, - name, + name, + k, zeta_normalize_term t, zeta_normalize_term b ) @@ -608,19 +645,19 @@ let zeta_normalize = | RLetTuple(loc,nal,(na,rto),def,b) -> RLetTuple(loc, nal, - (na,option_map zeta_normalize_term rto), + (na,Option.map zeta_normalize_term rto), zeta_normalize_term def, zeta_normalize_term b ) - | RCases(loc,infos,el,brl) -> - RCases(loc, + | RCases(loc,sty,infos,el,brl) -> + RCases(loc,sty, infos, List.map (fun (e,x) -> (zeta_normalize_term e,x)) el, List.map zeta_normalize_br brl ) | RIf(loc,b,(na,e_option),lhs,rhs) -> RIf(loc, zeta_normalize_term b, - (na,option_map zeta_normalize_term e_option), + (na,Option.map zeta_normalize_term e_option), zeta_normalize_term lhs, zeta_normalize_term rhs ) @@ -659,24 +696,23 @@ let expand_as = with Not_found -> rt end | RApp(loc,f,args) -> RApp(loc,expand_as map f,List.map (expand_as map) args) - | RLambda(loc,na,t,b) -> RLambda(loc,na,expand_as map t, expand_as map b) - | RProd(loc,na,t,b) -> RProd(loc,na,expand_as map t, expand_as map b) + | RLambda(loc,na,k,t,b) -> RLambda(loc,na,k,expand_as map t, expand_as map b) + | RProd(loc,na,k,t,b) -> RProd(loc,na,k,expand_as map t, expand_as map b) | RLetIn(loc,na,v,b) -> RLetIn(loc,na, expand_as map v,expand_as map b) | RLetTuple(loc,nal,(na,po),v,b) -> - RLetTuple(loc,nal,(na,option_map (expand_as map) po), + RLetTuple(loc,nal,(na,Option.map (expand_as map) po), expand_as map v, expand_as map b) | RIf(loc,e,(na,po),br1,br2) -> - RIf(loc,expand_as map e,(na,option_map (expand_as map) po), + RIf(loc,expand_as map e,(na,Option.map (expand_as map) po), expand_as map br1, expand_as map br2) | RRec _ -> error "Not handled RRec" | RDynamic _ -> error "Not handled RDynamic" | RCast(loc,b,CastConv(kind,t)) -> RCast(loc,expand_as map b,CastConv(kind,expand_as map t)) | RCast(loc,b,CastCoerce) -> RCast(loc,expand_as map b,CastCoerce) - | RCases(loc,po,el,brl) -> - RCases(loc, option_map (expand_as map) po, List.map (fun (rt,t) -> expand_as map rt,t) el, + | RCases(loc,sty,po,el,brl) -> + RCases(loc, sty, Option.map (expand_as map) po, List.map (fun (rt,t) -> expand_as map rt,t) el, List.map (expand_as_br map) brl) - and expand_as_br map (loc,idl,cpl,rt) = - (loc,idl,cpl, expand_as (List.fold_left add_as map cpl) rt) + (loc,idl,cpl, expand_as (List.fold_left add_as map cpl) rt) in expand_as Idmap.empty diff --git a/contrib/funind/rawtermops.mli b/contrib/funind/rawtermops.mli index 9647640c..358c6ba6 100644 --- a/contrib/funind/rawtermops.mli +++ b/contrib/funind/rawtermops.mli @@ -22,7 +22,7 @@ val mkRApp : rawconstr*(rawconstr list) -> rawconstr val mkRLambda : Names.name*rawconstr*rawconstr -> rawconstr val mkRProd : Names.name*rawconstr*rawconstr -> rawconstr val mkRLetIn : Names.name*rawconstr*rawconstr -> rawconstr -val mkRCases : rawconstr option * tomatch_tuple * cases_clauses -> rawconstr +val mkRCases : rawconstr option * tomatch_tuples * cases_clauses -> rawconstr val mkRSort : rawsort -> rawconstr val mkRHole : unit -> rawconstr (* we only build Evd.BinderType Anonymous holes *) val mkRCast : rawconstr* rawconstr -> rawconstr @@ -31,8 +31,14 @@ val mkRCast : rawconstr* rawconstr -> rawconstr These are analogous to the ones constrs *) val raw_decompose_prod : rawconstr -> (Names.name*rawconstr) list * rawconstr +val raw_decompose_prod_or_letin : + rawconstr -> (Names.name*rawconstr option*rawconstr option) list * rawconstr val raw_decompose_prod_n : int -> rawconstr -> (Names.name*rawconstr) list * rawconstr +val raw_decompose_prod_or_letin_n : int -> rawconstr -> + (Names.name*rawconstr option*rawconstr option) list * rawconstr val raw_compose_prod : rawconstr -> (Names.name*rawconstr) list -> rawconstr +val raw_compose_prod_or_letin: rawconstr -> + (Names.name*rawconstr option*rawconstr option) list -> rawconstr val raw_decompose_app : rawconstr -> rawconstr*(rawconstr list) diff --git a/contrib/recdef/recdef.ml4 b/contrib/funind/recdef.ml index 40832677..c9bf2f1f 100644 --- a/contrib/recdef/recdef.ml4 +++ b/contrib/funind/recdef.ml @@ -8,6 +8,8 @@ (*i camlp4deps: "parsing/grammar.cma" i*) +(* $Id: recdef.ml 11094 2008-06-10 19:35:23Z herbelin $ *) + open Term open Termops open Environ @@ -25,6 +27,7 @@ open Typing open Tacmach open Tactics open Nametab +open Decls open Declare open Decl_kinds open Tacred @@ -67,7 +70,8 @@ let h_intros l = let do_observe_tac s tac g = let goal = begin (Printer.pr_goal (sig_it g)) end in - try let v = tac g in msgnl (goal ++ fnl () ++ (str s)++(str " ")++(str "finished")); v + try let v = tac g in msgnl (goal ++ fnl () ++ (str "recdef ") ++ + (str s)++(str " ")++(str "finished")); v with e -> msgnl (str "observation "++str s++str " raised exception " ++ Cerrors.explain_exn e ++ str " on goal " ++ goal ); @@ -106,7 +110,7 @@ let (teq_id:identifier) = hyp_id 15 hyp_ids;; let (pmax_id:identifier) = hyp_id 16 hyp_ids;; let (hle_id:identifier) = hyp_id 17 hyp_ids;; -let message s = if Options.is_verbose () then msgnl(str s);; +let message s = if Flags.is_verbose () then msgnl(str s);; let def_of_const t = match (kind_of_term t) with @@ -146,9 +150,9 @@ let rank_for_arg_list h = | x::tl -> if predicate h x then Some i else rank_aux (i+1) tl in rank_aux 0;; -let rec (find_call_occs: - constr -> constr -> (constr list ->constr)*(constr list list)) = - fun f expr -> +let rec (find_call_occs : int -> constr -> constr -> + (constr list -> constr) * constr list list) = + fun nb_lam f expr -> match (kind_of_term expr) with App (g, args) when g = f -> (fun l -> List.hd l), [Array.to_list args] @@ -159,7 +163,7 @@ let rec (find_call_occs: | a::upper_tl -> (match find_aux upper_tl with (cf, ((arg1::args) as args_for_upper_tl)) -> - (match find_call_occs f a with + (match find_call_occs nb_lam f a with cf2, (_ :: _ as other_args) -> let rec avoid_duplicates args = match args with @@ -183,7 +187,7 @@ let rec (find_call_occs: other_args'@args_for_upper_tl | _, [] -> (fun x -> a::cf x), args_for_upper_tl) | _, [] -> - (match find_call_occs f a with + (match find_call_occs nb_lam f a with cf, (arg1::args) -> (fun l -> cf l::upper_tl), (arg1::args) | _, [] -> (fun x -> a::upper_tl), [])) in begin @@ -192,33 +196,48 @@ let rec (find_call_occs: | cf, args -> (fun l -> mkApp (g, Array.of_list (cf l))), args end - | Rel(_) -> error "find_call_occs : Rel" + | Rel(v) -> if v > nb_lam then error "find_call_occs : Rel" else ((fun l -> expr),[]) | Var(id) -> (fun l -> expr), [] | Meta(_) -> error "find_call_occs : Meta" | Evar(_) -> error "find_call_occs : Evar" - | Sort(_) -> error "find_call_occs : Sort" - | Cast(b,_,_) -> find_call_occs f b + | Sort(_) -> (fun l -> expr), [] + | Cast(b,_,_) -> find_call_occs nb_lam f b | Prod(_,_,_) -> error "find_call_occs : Prod" - | Lambda(_,_,_) -> error "find_call_occs : Lambda" - | LetIn(_,_,_,_) -> error "find_call_occs : let in" + | Lambda(na,t,b) -> + begin + match find_call_occs (succ nb_lam) f b with + | _, [] -> (* Lambda are authorized as long as they do not contain + recursives calls *) + (fun l -> expr),[] + | _ -> error "find_call_occs : Lambda" + end + | LetIn(na,v,t,b) -> + begin + match find_call_occs nb_lam f v, find_call_occs (succ nb_lam) f b with + | (_,[]),(_,[]) -> + ((fun l -> expr), []) + | (_,[]),(cf,(_::_ as l)) -> + ((fun l -> mkLetIn(na,v,t,cf l)),l) + | (cf,(_::_ as l)),(_,[]) -> + ((fun l -> mkLetIn(na,cf l,t,b)), l) + | _ -> error "find_call_occs : LetIn" + end | Const(_) -> (fun l -> expr), [] | Ind(_) -> (fun l -> expr), [] | Construct (_, _) -> (fun l -> expr), [] | Case(i,t,a,r) -> - (match find_call_occs f a with + (match find_call_occs nb_lam f a with cf, (arg1::args) -> (fun l -> mkCase(i, t, (cf l), r)),(arg1::args) - | _ -> (fun l -> mkCase(i, t, a, r)),[]) + | _ -> (fun l -> expr),[]) | Fix(_) -> error "find_call_occs : Fix" | CoFix(_) -> error "find_call_occs : CoFix";; - - let coq_constant s = Coqlib.gen_constant_in_modules "RecursiveDefinition" (Coqlib.init_modules @ Coqlib.arith_modules) s;; let constant sl s = - constr_of_reference + constr_of_global (locate (make_qualid(Names.make_dirpath (List.map id_of_string (List.rev sl))) (id_of_string s)));; @@ -257,8 +276,8 @@ let acc_inv_id = function () -> (coq_constant "Acc_inv") let well_founded_ltof = function () -> (Coqlib.coq_constant "" ["Arith";"Wf_nat"] "well_founded_ltof") let iter_ref = function () -> (try find_reference ["Recdef"] "iter" with Not_found -> error "module Recdef not loaded") let max_ref = function () -> (find_reference ["Recdef"] "max") -let iter = function () -> (constr_of_reference (delayed_force iter_ref)) -let max_constr = function () -> (constr_of_reference (delayed_force max_ref)) +let iter = function () -> (constr_of_global (delayed_force iter_ref)) +let max_constr = function () -> (constr_of_global (delayed_force max_ref)) let ltof_ref = function () -> (find_reference ["Coq";"Arith";"Wf_nat"] "ltof") let coq_conj = function () -> find_reference ["Coq";"Init";"Logic"] "conj" @@ -268,44 +287,61 @@ let coq_conj = function () -> find_reference ["Coq";"Init";"Logic"] "conj" let nat = function () -> (coq_constant "nat") let lt = function () -> (coq_constant "lt") +(* This is simply an implementation of the case_eq tactic. this code + should be replaced with the tactic defined in Ltac in Init/Tactics.v *) let mkCaseEq a : tactic = (fun g -> - (* commentaire de Yves: on pourra avoir des problemes si - a n'est pas bien type dans l'environnement du but *) let type_of_a = pf_type_of g a in - (tclTHEN (generalize [mkApp(delayed_force refl_equal, [| type_of_a; a|])]) - (tclTHEN - (fun g2 -> - change_in_concl None - (pattern_occs [([2], a)] (pf_env g2) Evd.empty (pf_concl g2)) - g2) - (simplest_case a))) g);; - -let rec mk_intros_and_continue (extra_eqn:bool) - cont_function (eqs:constr list) (expr:constr) g = - match kind_of_term expr with - | Lambda (n, _, b) -> - let n1 = - match n with - Name x -> x - | Anonymous -> ano_id - in - let new_n = pf_get_new_id n1 g in - tclTHEN (h_intro new_n) - (mk_intros_and_continue extra_eqn cont_function eqs - (subst1 (mkVar new_n) b)) g - | _ -> - if extra_eqn then + tclTHENLIST + [h_generalize [mkApp(delayed_force refl_equal, [| type_of_a; a|])]; + (fun g2 -> + change_in_concl None + (pattern_occs [((false,[1]), a)] (pf_env g2) Evd.empty (pf_concl g2)) + g2); + simplest_case a] g);; + +(* This is like the previous one except that it also rewrite on all + hypotheses except the ones given in the first argument. All the + modified hypotheses are generalized in the process and should be + introduced back later; the result is the pair of the tactic and the + list of hypotheses that have been generalized and cleared. *) +let mkDestructEq : + identifier list -> constr -> goal sigma -> tactic * identifier list = + fun not_on_hyp expr g -> + let hyps = pf_hyps g in + let to_revert = + Util.map_succeed + (fun (id,_,t) -> + if List.mem id not_on_hyp || not (Termops.occur_term expr t) + then failwith "is_expr_context"; + id) hyps in + let to_revert_constr = List.rev_map mkVar to_revert in + let type_of_expr = pf_type_of g expr in + let new_hyps = mkApp(delayed_force refl_equal, [|type_of_expr; expr|]):: + to_revert_constr in + tclTHENLIST + [h_generalize new_hyps; + (fun g2 -> + change_in_concl None + (pattern_occs [((false,[1]), expr)] (pf_env g2) Evd.empty (pf_concl g2)) g2); + simplest_case expr], to_revert + +let rec mk_intros_and_continue thin_intros (extra_eqn:bool) + cont_function (eqs:constr list) nb_lam (expr:constr) g = + let finalize () = if extra_eqn then let teq = pf_get_new_id teq_id g in tclTHENLIST [ h_intro teq; + thin thin_intros; + h_intros thin_intros; + tclMAP - (fun eq -> tclTRY (Equality.general_rewrite_in true teq eq)) + (fun eq -> tclTRY (Equality.general_rewrite_in true all_occurrences teq eq false)) (List.rev eqs); (fun g1 -> let ty_teq = pf_type_of g1 (mkVar teq) in let teq_lhs,teq_rhs = - let _,args = destApp ty_teq in + let _,args = try destApp ty_teq with _ -> Pp.msgnl (Printer.pr_goal (sig_it g1) ++ fnl () ++ pr_id teq ++ str ":" ++ Printer.pr_lconstr ty_teq); assert false in args.(1),args.(2) in cont_function (mkVar teq::eqs) (replace_term teq_lhs teq_rhs expr) g1 @@ -313,22 +349,44 @@ let rec mk_intros_and_continue (extra_eqn:bool) ] g else - cont_function eqs expr g - + tclTHENSEQ[ + thin thin_intros; + h_intros thin_intros; + cont_function eqs expr + ] g + in + if nb_lam = 0 + then finalize () + else + match kind_of_term expr with + | Lambda (n, _, b) -> + let n1 = + match n with + Name x -> x + | Anonymous -> ano_id + in + let new_n = pf_get_new_id n1 g in + tclTHEN (h_intro new_n) + (mk_intros_and_continue thin_intros extra_eqn cont_function eqs + (pred nb_lam) (subst1 (mkVar new_n) b)) g + | _ -> + assert false +(* finalize () *) let const_of_ref = function ConstRef kn -> kn | _ -> anomaly "ConstRef expected" -let simpl_iter () = +let simpl_iter clause = reduce - (Lazy + (Lazy {rBeta=true;rIota=true;rZeta= true; rDelta=false; rConst = [ EvalConstRef (const_of_ref (delayed_force iter_ref))]}) - onConcl +(* (Simpl (Some ([],mkConst (const_of_ref (delayed_force iter_ref))))) *) + clause (* The boolean value is_mes expresses that the termination is expressed using a measure function instead of a well-founded relation. *) -let tclUSER is_mes l g = +let tclUSER tac is_mes l g = let clear_tac = match l with | None -> h_clear true [] @@ -338,8 +396,11 @@ let tclUSER is_mes l g = [ clear_tac; if is_mes - then unfold_in_concl [([], evaluable_of_global_reference (delayed_force ltof_ref))] - else tclIDTAC + then tclTHEN + (unfold_in_concl [(all_occurrences, evaluable_of_global_reference + (delayed_force ltof_ref))]) + tac + else tac ] g @@ -358,22 +419,22 @@ let base_leaf_terminate (func:global_reference) eqs expr = [k';h] -> k',h | _ -> assert false in - tclTHENLIST [observe_tac "first split" (split (ImplicitBindings [expr])); - observe_tac "second split" (split (ImplicitBindings [delayed_force coq_O])); - observe_tac "intro k" (h_intro k'); - observe_tac "case on k" - (tclTHENS - (simplest_case (mkVar k')) - [(tclTHEN (h_intro h) - (tclTHEN (simplest_elim - (mkApp (delayed_force gt_antirefl, - [| delayed_force coq_O |]))) - default_auto)); tclIDTAC ]); - intros; - simpl_iter(); - unfold_constr func; - list_rewrite true eqs; - default_auto ] g);; + tclTHENLIST + [observe_tac "first split" (split (ImplicitBindings [expr])); + observe_tac "second split" + (split (ImplicitBindings [delayed_force coq_O])); + observe_tac "intro k" (h_intro k'); + observe_tac "case on k" + (tclTHENS (simplest_case (mkVar k')) + [(tclTHEN (h_intro h) + (tclTHEN (simplest_elim (mkApp (delayed_force gt_antirefl, + [| delayed_force coq_O |]))) + default_auto)); tclIDTAC ]); + intros; + simpl_iter onConcl; + unfold_constr func; + list_rewrite true eqs; + default_auto] g);; (* La fonction est donnee en premier argument a la fonctionnelle suivie d'autres Lambdas et de Case ... @@ -402,8 +463,7 @@ let rec compute_le_proofs = function apply_with_bindings (le_trans, ExplicitBindings[dummy_loc,NamedHyp m_id,a]) - g - ) + g) [compute_le_proofs tl; tclORELSE (apply (delayed_force le_n)) assumption]) @@ -436,10 +496,10 @@ let rec list_cond_rewrite k def pmax cond_eqs le_proofs = Nameops.out_name k_na,Nameops.out_name def_na in tclTHENS - (general_rewrite_bindings false + (general_rewrite_bindings false all_occurrences (mkVar eq, ExplicitBindings[dummy_loc, NamedHyp k_id, mkVar k; - dummy_loc, NamedHyp def_id, mkVar def])) + dummy_loc, NamedHyp def_id, mkVar def]) false) [list_cond_rewrite k def pmax eqs le_proofs; observe_tac "make_lt_proof" (make_lt_proof pmax le_proofs)] g ) @@ -469,12 +529,12 @@ let rec introduce_all_equalities func eqs values specs bound le_proofs ]; observe_tac "clearing k " (clear [k]); observe_tac "intros k h' def" (h_intros [k;h';def]); - observe_tac "simple_iter" (simpl_iter()); + observe_tac "simple_iter" (simpl_iter onConcl); observe_tac "unfold functional" - (unfold_in_concl[([1],evaluable_of_global_reference func)]); + (unfold_in_concl[((true,[1]),evaluable_of_global_reference func)]); observe_tac "rewriting equations" (list_rewrite true eqs); - observe_tac "cond rewrite" (list_cond_rewrite k def bound cond_eqs le_proofs); + observe_tac ("cond rewrite "^(string_of_id k)) (list_cond_rewrite k def bound cond_eqs le_proofs); observe_tac "refl equal" (apply (delayed_force refl_equal))] g | spec1::specs -> fun g -> @@ -498,7 +558,7 @@ let rec introduce_all_equalities func eqs values specs bound le_proofs (mkVar pmax) ((mkVar pmax)::le_proofs) (heq::cond_eqs)] g;; -let string_match s = +let string_match s = if String.length s < 3 then failwith "string_match"; try for i = 0 to 3 do @@ -513,7 +573,7 @@ let retrieve_acc_var g = (fun id -> string_match (string_of_id id);id) hyps -let rec introduce_all_values is_mes acc_inv func context_fn +let rec introduce_all_values concl_tac is_mes acc_inv func context_fn eqs hrec args values specs = (match args with [] -> @@ -530,16 +590,19 @@ let rec introduce_all_values is_mes acc_inv func context_fn let hspec = next_global_ident_away true hspec_id ids in let tac = observe_tac "introduce_all_values" ( - introduce_all_values is_mes acc_inv func context_fn eqs + introduce_all_values concl_tac is_mes acc_inv func context_fn eqs hrec args (rec_res::values)(hspec::specs)) in (tclTHENS - (observe_tac "elim h_rec" (simplest_elim (mkApp(mkVar hrec, Array.of_list arg)))) + (observe_tac "elim h_rec" + (simplest_elim (mkApp(mkVar hrec, Array.of_list arg))) + ) [tclTHENLIST [h_intros [rec_res; hspec]; tac]; (tclTHENS (observe_tac "acc_inv" (apply (Lazy.force acc_inv))) - [ observe_tac "h_assumption" h_assumption + [(* tclTHEN (tclTRY(list_rewrite true eqs)) *) + (observe_tac "h_assumption" h_assumption) ; tclTHENLIST [ @@ -547,6 +610,7 @@ let rec introduce_all_values is_mes acc_inv func context_fn observe_tac "user proof" (fun g -> tclUSER + concl_tac is_mes (Some (hrec::hspec::(retrieve_acc_var g)@specs)) g @@ -559,70 +623,61 @@ let rec introduce_all_values is_mes acc_inv func context_fn ) -let rec_leaf_terminate is_mes acc_inv hrec (func:global_reference) eqs expr = - match find_call_occs (mkVar (get_f (constr_of_reference func))) expr with +let rec_leaf_terminate f_constr concl_tac is_mes acc_inv hrec (func:global_reference) eqs expr = + match find_call_occs 0 f_constr expr with | context_fn, args -> observe_tac "introduce_all_values" - (introduce_all_values is_mes acc_inv func context_fn eqs hrec args [] []) + (introduce_all_values concl_tac is_mes acc_inv func context_fn eqs hrec args [] []) -let proveterminate is_mes acc_inv (hrec:identifier) +let proveterminate rec_arg_id is_mes acc_inv (hrec:identifier) (f_constr:constr) (func:global_reference) base_leaf rec_leaf = let rec proveterminate (eqs:constr list) (expr:constr) = try (* let _ = msgnl (str "entering proveterminate") in *) let v = - match (kind_of_term expr) with - Case (_, t, a, l) -> - (match find_call_occs f_constr a with - _,[] -> - tclTHENS - (fun g -> - (* let _ = msgnl(str "entering mkCaseEq") in *) - let v = (mkCaseEq a) g in - (* let _ = msgnl (str "exiting mkCaseEq") in *) - v - ) - (List.map - (mk_intros_and_continue true proveterminate eqs) - (Array.to_list l) - ) - | _, _::_ -> - ( - match find_call_occs f_constr expr with - _,[] -> observe_tac "base_leaf" (base_leaf func eqs expr) - | _, _:: _ -> - observe_tac "rec_leaf" - (rec_leaf is_mes acc_inv hrec func eqs expr) - ) - ) - | _ -> (match find_call_occs f_constr expr with - _,[] -> - (try - observe_tac "base_leaf" (base_leaf func eqs expr) - with e -> - (msgerrnl (str "failure in base case");raise e )) - | _, _::_ -> - observe_tac "rec_leaf" - (rec_leaf is_mes acc_inv hrec func eqs expr) - ) in - (* let _ = msgnl(str "exiting proveterminate") in *) + match (kind_of_term expr) with + Case (ci, t, a, l) -> + (match find_call_occs 0 f_constr a with + _,[] -> + (fun g -> + let destruct_tac, rev_to_thin_intro = + mkDestructEq rec_arg_id a g in + tclTHENS destruct_tac + (list_map_i + (fun i -> mk_intros_and_continue + (List.rev rev_to_thin_intro) + true + proveterminate + eqs + ci.ci_cstr_nargs.(i)) + 0 (Array.to_list l)) g) + | _, _::_ -> + (match find_call_occs 0 f_constr expr with + _,[] -> observe_tac "base_leaf" (base_leaf func eqs expr) + | _, _:: _ -> + observe_tac "rec_leaf" + (rec_leaf is_mes acc_inv hrec func eqs expr))) + | _ -> + (match find_call_occs 0 f_constr expr with + _,[] -> + (try observe_tac "base_leaf" (base_leaf func eqs expr) + with e -> (msgerrnl (str "failure in base case");raise e )) + | _, _::_ -> + observe_tac "rec_leaf" + (rec_leaf is_mes acc_inv hrec func eqs expr)) in v - with e -> - begin - msgerrnl(str "failure in proveterminate"); - raise e - end + with e -> begin msgerrnl(str "failure in proveterminate"); raise e end in proveterminate -let hyp_terminates func = - let a_arrow_b = arg_type (constr_of_reference func) in - let rev_args,b = decompose_prod a_arrow_b in +let hyp_terminates nb_args func = + let a_arrow_b = arg_type (constr_of_global func) in + let rev_args,b = decompose_prod_n nb_args a_arrow_b in let left = mkApp(delayed_force iter, Array.of_list (lift 5 a_arrow_b:: mkRel 3:: - constr_of_reference func::mkRel 1:: + constr_of_global func::mkRel 1:: List.rev (list_map_i (fun i _ -> mkRel (6+i)) 0 rev_args) ) ) @@ -647,11 +702,10 @@ let hyp_terminates func = -let tclUSER_if_not_mes is_mes names_to_suppress = +let tclUSER_if_not_mes concl_tac is_mes names_to_suppress = if is_mes - then - tclCOMPLETE (h_apply (delayed_force well_founded_ltof,Rawterm.NoBindings)) - else tclUSER is_mes names_to_suppress + then tclCOMPLETE (h_simplest_apply (delayed_force well_founded_ltof)) + else tclUSER concl_tac is_mes names_to_suppress let termination_proof_header is_mes input_type ids args_id relation rec_arg_num rec_arg_id tac wf_tac : tactic = @@ -710,8 +764,7 @@ let termination_proof_header is_mes input_type ids args_id relation (* this gives the accessibility argument *) observe_tac "apply wf_thm" - (h_apply ((mkApp(mkVar wf_thm, - [|mkVar rec_arg_id |])),Rawterm.NoBindings) + (h_simplest_apply (mkApp(mkVar wf_thm,[|mkVar rec_arg_id|])) ) ] ; @@ -720,13 +773,13 @@ let termination_proof_header is_mes input_type ids args_id relation [observe_tac "generalize" (onNLastHyps (nargs+1) (fun (id,_,_) -> - tclTHEN (generalize [mkVar id]) (h_clear false [id]) + tclTHEN (h_generalize [mkVar id]) (h_clear false [id]) )) ; observe_tac "h_fix" (h_fix (Some hrec) (nargs+1)); h_intros args_id; h_intro wf_rec_arg; - observe_tac "tac" (tac hrec acc_inv) + observe_tac "tac" (tac wf_rec_arg hrec acc_inv) ] ] ) g @@ -743,18 +796,18 @@ let rec instantiate_lambda t l = ;; -let whole_start is_mes func input_type relation rec_arg_num : tactic = +let whole_start (concl_tac:tactic) nb_args is_mes func input_type relation rec_arg_num : tactic = begin fun g -> let ids = ids_of_named_context (pf_hyps g) in - let func_body = (def_of_const (constr_of_reference func)) in + let func_body = (def_of_const (constr_of_global func)) 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_names_types,_ = decompose_lam_n nb_args body1 in let n_ids,ids = List.fold_left (fun (n_ids,ids) (n_name,_) -> @@ -777,30 +830,29 @@ let whole_start is_mes func input_type relation rec_arg_num : tactic = relation rec_arg_num rec_arg_id - (fun hrec acc_inv g -> + (fun rec_arg_id hrec acc_inv g -> (proveterminate + [rec_arg_id] is_mes acc_inv hrec (mkVar f_id) func base_leaf_terminate - rec_leaf_terminate + (rec_leaf_terminate (mkVar f_id) concl_tac) [] expr ) g ) - tclUSER_if_not_mes + (tclUSER_if_not_mes concl_tac) g end - let get_current_subgoals_types () = let pts = get_pftreestate () in let _,subs = extract_open_pftreestate pts in - List.map snd (List.sort (fun (x,_) (y,_) -> x -y )subs ) - + List.map snd ((* List.sort (fun (x,_) (y,_) -> x -y ) *)subs ) let build_and_l l = let and_constr = Coqlib.build_coq_and () in @@ -814,7 +866,7 @@ let build_and_l l = let c,tac,nb = f pl in mk_and p1 c, tclTHENS - (apply (constr_of_reference conj_constr)) + (apply (constr_of_global conj_constr)) [tclIDTAC; tac ],nb+1 @@ -849,23 +901,24 @@ let build_new_goal_type () = res - + (* let prove_with_tcc lemma _ : tactic = fun gls -> let hid = next_global_ident_away true h_id (pf_ids_of_hyps gls) in tclTHENSEQ [ - generalize [lemma]; + h_generalize [lemma]; h_intro hid; Elim.h_decompose_and (mkVar hid); gen_eauto(* default_eauto *) false (false,5) [] (Some []) (* default_auto *) ] gls + *) -let open_new_goal using_lemmas ref goal_name (gls_type,decompose_and_tac,nb_goal) = +let open_new_goal (build_proof:tactic -> tactic -> unit) using_lemmas ref_ goal_name (gls_type,decompose_and_tac,nb_goal) = let current_proof_name = get_current_proof_name () in let name = match goal_name with | Some s -> s @@ -879,14 +932,58 @@ let open_new_goal using_lemmas ref goal_name (gls_type,decompose_and_tac,nb_goal if occur_existential gls_type then Util.error "\"abstract\" cannot handle existentials"; let hook _ _ = + let opacity = + let na_ref = Libnames.Ident (dummy_loc,na) in + let na_global = Nametab.global na_ref in + match na_global with + ConstRef c -> + let cb = Global.lookup_constant c in + if cb.Declarations.const_opaque then true + else begin match cb.const_body with None -> true | _ -> false end + | _ -> anomaly "equation_lemma: not a constant" + in let lemma = mkConst (Lib.make_con na) in - Array.iteri - (fun i _ -> - by (observe_tac ("reusing lemma "^(string_of_id na)) (prove_with_tcc lemma i))) - (Array.make nb_goal ()) - ; - ref := Some lemma ; - defined (); + ref_ := Some lemma ; + let lid = ref [] in + let h_num = ref (-1) in + Flags.silently Vernacentries.interp (Vernacexpr.VernacAbort None); + build_proof + ( fun gls -> + let hid = next_global_ident_away true h_id (pf_ids_of_hyps gls) in + tclTHENSEQ + [ + h_generalize [lemma]; + h_intro hid; + (fun g -> + let ids = pf_ids_of_hyps g in + tclTHEN + (Elim.h_decompose_and (mkVar hid)) + (fun g -> + let ids' = pf_ids_of_hyps g in + lid := List.rev (list_subtract ids' ids); + if !lid = [] then lid := [hid]; +(* list_iter_i *) +(* (fun i v -> *) +(* msgnl (str "hyp" ++ int i ++ str " " ++ *) +(* Nameops.pr_id v ++ fnl () ++ fnl())) *) +(* !lid; *) + tclIDTAC g + ) + g + ); + ] gls) + (fun g -> + match kind_of_term (pf_concl g) with + | App(f,_) when eq_constr f (well_founded ()) -> + Auto.h_auto None [] (Some []) g + | _ -> + incr h_num; + tclTHEN + (eapply_with_bindings (mkVar (List.nth !lid !h_num), NoBindings)) + e_assumption + g) +; + Command.save_named opacity; in start_proof na @@ -904,7 +1001,7 @@ let open_new_goal using_lemmas ref goal_name (gls_type,decompose_and_tac,nb_goal (fun c -> tclTHENSEQ [intros; - h_apply (interp_constr Evd.empty (Global.env()) c,Rawterm.NoBindings); + h_simplest_apply (interp_constr Evd.empty (Global.env()) c); tclCOMPLETE Auto.default_auto ] ) @@ -913,11 +1010,13 @@ let open_new_goal using_lemmas ref goal_name (gls_type,decompose_and_tac,nb_goal g); try by tclIDTAC; (* raises UserError _ if the proof is complete *) - if Options.is_verbose () then (pp (Printer.pr_open_subgoals())) + if Flags.is_verbose () then (pp (Printer.pr_open_subgoals())) with UserError _ -> defined () - +;; + + let com_terminate tcc_lemma_name tcc_lemma_ref @@ -926,21 +1025,29 @@ let com_terminate input_type relation rec_arg_num - thm_name using_lemmas hook = - let (evmap, env) = Command.get_current_context() in - start_proof thm_name - (Global, Proof Lemma) (Environ.named_context_val env) - (hyp_terminates fonctional_ref) hook; - by (observe_tac "whole_start" (whole_start is_mes fonctional_ref - input_type relation rec_arg_num )); + thm_name using_lemmas + nb_args + hook = + let start_proof (tac_start:tactic) (tac_end:tactic) = + let (evmap, env) = Command.get_current_context() in + start_proof thm_name + (Global, Proof Lemma) (Environ.named_context_val env) + (hyp_terminates nb_args fonctional_ref) hook; + by (observe_tac "starting_tac" tac_start); + by (observe_tac "whole_start" (whole_start tac_end nb_args is_mes fonctional_ref + input_type relation rec_arg_num )) + + in + start_proof tclIDTAC tclIDTAC; try let new_goal_type = build_new_goal_type () in - open_new_goal using_lemmas tcc_lemma_ref + open_new_goal start_proof using_lemmas tcc_lemma_ref (Some tcc_lemma_name) (new_goal_type) with Failure "empty list of subgoals!" -> (* a non recursive function declared with measure ! *) defined () + @@ -964,7 +1071,7 @@ let (value_f:constr list -> global_reference -> constr) = in let fun_body = RCases - (d0,None, + (d0,RegularStyle,None, [RApp(d0, RRef(d0,fterm), List.rev_map (fun x_id -> RVar(d0, x_id)) rev_x_id_l), (Anonymous,None)], [d0, [v_id], [PatCstr(d0,(ind_of_ref @@ -978,7 +1085,7 @@ let (value_f:constr list -> global_reference -> constr) = List.fold_left2 (fun acc x_id a -> RLambda - (d0, Name x_id, RDynamic(d0, constr_in a), + (d0, Name x_id, Explicit, RDynamic(d0, constr_in a), acc ) ) @@ -1000,27 +1107,24 @@ let (declare_f : identifier -> logical_kind -> constr list -> global_reference - fun f_id kind input_type fterm_ref -> declare_fun f_id kind (value_f input_type fterm_ref);; +let rec n_x_id ids n = + if n = 0 then [] + else let x = next_global_ident_away true x_id ids in + x::n_x_id (x::ids) (n-1);; + let start_equation (f:global_reference) (term_f:global_reference) (cont_tactic:identifier list -> tactic) g = let ids = pf_ids_of_hyps g in - let terminate_constr = constr_of_reference term_f in + let terminate_constr = constr_of_global term_f in let nargs = nb_prod (type_of_const terminate_constr) in - let x = - let rec f ids n = - if n = 0 - then [] - else - let x = next_global_ident_away true x_id ids in - x::f (x::ids) (n-1) - in - f ids nargs - in + let x = n_x_id ids nargs in tclTHENLIST [ h_intros x; - observe_tac "unfold_constr f" (unfold_constr f); - observe_tac "simplest_case" (simplest_case (mkApp (terminate_constr, Array.of_list (List.map mkVar x)))); - observe_tac "prove_eq" (cont_tactic x)] g -;; + unfold_in_concl [(all_occurrences, evaluable_of_global_reference f)]; + observe_tac "simplest_case" + (simplest_case (mkApp (terminate_constr, + Array.of_list (List.map mkVar x)))); + observe_tac "prove_eq" (cont_tactic x)] g;; let base_leaf_eq func eqs f_id g = let ids = pf_ids_of_hyps g in @@ -1039,37 +1143,40 @@ let base_leaf_eq func eqs f_id g = (mkApp(mkVar heq1, [|mkApp (delayed_force coq_S, [|mkVar p|]); mkApp(delayed_force lt_n_Sn, [|mkVar p|]); f_id|]))); - simpl_iter(); - unfold_in_concl [([1], evaluable_of_global_reference func)]; + simpl_iter onConcl; + tclTRY (unfold_in_concl [((true,[1]), evaluable_of_global_reference func)]); list_rewrite true eqs; apply (delayed_force refl_equal)] g;; let f_S t = mkApp(delayed_force coq_S, [|t|]);; -let rec introduce_all_values_eq cont_tac functional termine + +let rec introduce_all_values_eq cont_tac functional termine f p heq1 pmax bounds le_proofs eqs ids = function [] -> + let heq2 = next_global_ident_away true heq_id ids in tclTHENLIST - [tclTHENS + [forward None (IntroIdentifier heq2) + (mkApp(mkVar heq1, [|f_S(f_S(mkVar pmax))|])); + simpl_iter (onHyp heq2); + unfold_in_hyp [((true,[1]), evaluable_of_global_reference + (global_of_constr functional))] + ((all_occurrences_expr, heq2), Tacexpr.InHyp); + tclTHENS (fun gls -> - let t_eq = compute_renamed_type gls (mkVar heq1) in - let k_id,def_id = - let k_na,_,t = destProd t_eq in - let _,_,t = destProd t in - let def_na,_,_ = destProd t in - Nameops.out_name k_na,Nameops.out_name def_na + let t_eq = compute_renamed_type gls (mkVar heq2) in + let def_id = + let _,_,t = destProd t_eq in let def_na,_,_ = destProd t in + Nameops.out_name def_na in - general_rewrite_bindings false - (mkVar heq1, - ExplicitBindings[dummy_loc,NamedHyp k_id, - f_S(f_S(mkVar pmax)); - dummy_loc,NamedHyp def_id, - f]) gls ) + observe_tac "rewrite heq" (general_rewrite_bindings false all_occurrences + (mkVar heq2, + ExplicitBindings[dummy_loc,NamedHyp def_id, + f]) false) gls) [tclTHENLIST - [simpl_iter(); - unfold_constr (reference_of_constr functional); - list_rewrite true eqs; cont_tac pmax le_proofs]; + [observe_tac "list_rewrite" (list_rewrite true eqs); + cont_tac pmax le_proofs]; tclTHENLIST[apply (delayed_force le_lt_SS); compute_le_proofs le_proofs]]] | arg::args -> @@ -1102,8 +1209,9 @@ let rec introduce_all_values_eq cont_tac functional termine tclTHENLIST [cont_tac pmax' le_proofs'; h_intros [heq;heq2]; - rewriteLR (mkVar heq2); - tclTHENS + observe_tac ("rewriteRL " ^ (string_of_id heq2)) + (tclTRY (rewriteLR (mkVar heq2))); + tclTRY (tclTHENS ( fun g -> let t_eq = compute_renamed_type g (mkVar heq) in let k_id,def_id = @@ -1112,18 +1220,20 @@ let rec introduce_all_values_eq cont_tac functional termine let def_na,_,_ = destProd t in Nameops.out_name k_na,Nameops.out_name def_na in - general_rewrite_bindings false - (mkVar heq, + let c_b = (mkVar heq, ExplicitBindings [dummy_loc, NamedHyp k_id, f_S(mkVar pmax'); - dummy_loc, NamedHyp def_id, f]) - g + dummy_loc, NamedHyp def_id, f]) + in + observe_tac "general_rewrite_bindings" ( (general_rewrite_bindings false all_occurrences + c_b false)) + g ) [tclIDTAC; tclTHENLIST [apply (delayed_force le_lt_n_Sm); - compute_le_proofs le_proofs']]]) + compute_le_proofs le_proofs']])]) functional termine f p heq1 new_pmax (p'::bounds)((mkVar pmax)::le_proofs) eqs (heq2::heq::hle2::hle1::new_pmax::p'::hex'::v'::ids) args] @@ -1141,84 +1251,95 @@ let rec_leaf_eq termine f ids functional eqs expr fn args = let hle1 = next_global_ident_away true hle_id ids in let ids = hle1::ids in tclTHENLIST - [h_intros [v;hex]; + [observe_tac "intros v hex" (h_intros [v;hex]); simplest_elim (mkVar hex); h_intros [p;heq1]; - generalize [mkApp(delayed_force le_n,[|mkVar p|])]; + h_generalize [mkApp(delayed_force le_n,[|mkVar p|])]; h_intros [hle1]; - introduce_all_values_eq + observe_tac "introduce_all_values_eq" (introduce_all_values_eq (fun _ _ -> tclIDTAC) - functional termine f p heq1 p [] [] eqs ids args; - apply (delayed_force refl_equal)] + functional termine f p heq1 p [] [] eqs ids args); + observe_tac "failing here" (apply (delayed_force refl_equal))] let rec prove_eq (termine:constr) (f:constr)(functional:global_reference) - (eqs:constr list) - (expr:constr) = - tclTRY - (match kind_of_term expr with - Case(_,t,a,l) -> - (match find_call_occs f a with - _,[] -> - tclTHENS(mkCaseEq a)(* (simplest_case a) *) - (List.map - (fun expr -> observe_tac "mk_intros_and_continue" (mk_intros_and_continue true - (prove_eq termine f functional) eqs expr)) - (Array.to_list l)) + (eqs:constr list) (expr:constr) = +(* tclTRY *) + (match kind_of_term expr with + Case(ci,t,a,l) -> + (match find_call_occs 0 f a with + _,[] -> + (fun g -> + let destruct_tac,rev_to_thin_intro = mkDestructEq [] a g in + tclTHENS + destruct_tac + (list_map_i + (fun i -> mk_intros_and_continue + (List.rev rev_to_thin_intro) true + (prove_eq termine f functional) + eqs ci.ci_cstr_nargs.(i)) + 0 (Array.to_list l)) g) | _,_::_ -> - (match find_call_occs f expr with - _,[] -> base_leaf_eq functional eqs f - | fn,args -> - fun g -> - let ids = ids_of_named_context (pf_hyps g) in - rec_leaf_eq termine f ids - (constr_of_reference functional) - eqs expr fn args g)) + (match find_call_occs 0 f expr with + _,[] -> base_leaf_eq functional eqs f + | fn,args -> + fun g -> + let ids = ids_of_named_context (pf_hyps g) in + rec_leaf_eq termine f ids + (constr_of_global functional) + eqs expr fn args g)) | _ -> - (match find_call_occs f expr with + (match find_call_occs 0 f expr with _,[] -> base_leaf_eq functional eqs f | fn,args -> fun g -> let ids = ids_of_named_context (pf_hyps g) in observe_tac "rec_leaf_eq" (rec_leaf_eq - termine f ids (constr_of_reference functional) + termine f ids (constr_of_global functional) eqs expr fn args) g));; let (com_eqn : identifier -> global_reference -> global_reference -> global_reference -> constr -> unit) = fun eq_name functional_ref f_ref terminate_ref equation_lemma_type -> + let opacity = + match terminate_ref with + | ConstRef c -> + let cb = Global.lookup_constant c in + if cb.Declarations.const_opaque then true + else begin match cb.const_body with None -> true | _ -> false end + | _ -> anomaly "terminate_lemma: not a constant" + in let (evmap, env) = Command.get_current_context() in - let f_constr = (constr_of_reference f_ref) in + let f_constr = (constr_of_global f_ref) in let equation_lemma_type = subst1 f_constr equation_lemma_type in (start_proof eq_name (Global, Proof Lemma) (Environ.named_context_val env) equation_lemma_type (fun _ _ -> ()); by (start_equation f_ref terminate_ref - (fun x -> + (fun x -> prove_eq - (constr_of_reference terminate_ref) + (constr_of_global terminate_ref) f_constr functional_ref [] (instantiate_lambda - (def_of_const (constr_of_reference functional_ref)) + (def_of_const (constr_of_global functional_ref)) (f_constr::List.map mkVar x) ) ) ); -(* (try Vernacentries.interp (Vernacexpr.VernacShow Vernacexpr.ShowProof) with _ -> ()); - Vernacentries.interp (Vernacexpr.VernacShow Vernacexpr.ShowScript); -*) - Options.silently defined (); +(* (try Vernacentries.interp (Vernacexpr.VernacShow Vernacexpr.ShowProof) with _ -> ()); *) +(* Vernacentries.interp (Vernacexpr.VernacShow Vernacexpr.ShowScript); *) + Flags.silently (fun () ->Command.save_named opacity) () ; +(* Pp.msgnl (str "eqn finished"); *) + );; - let nf_zeta env = Reductionops.clos_norm_flags (Closure.RedFlags.mkflags [Closure.RedFlags.fZETA]) env Evd.empty - let recursive_definition is_mes function_name rec_impls type_of_f r rec_arg_num eq generate_induction_principle using_lemmas : unit = let function_type = interp_constr Evd.empty (Global.env()) type_of_f in @@ -1232,7 +1353,7 @@ let recursive_definition is_mes function_name rec_impls type_of_f r rec_arg_num let res = (* Pp.msgnl (str "res_var :=" ++ Printer.pr_lconstr_env (push_rel_context (List.map (function (x,t) -> (x,None,t)) res_vars) env) eq'); *) (* Pp.msgnl (str "rec_arg_num := " ++ str (string_of_int rec_arg_num)); *) -(* Pp.msgnl (str "eq' := " ++ Printer.pr_lconstr_env env eq' ++ fnl () ++str (string_of_int rec_arg_num)); *) +(* Pp.msgnl (str "eq' := " ++ str (string_of_int rec_arg_num)); *) match kind_of_term eq' with | App(e,[|_;_;eq_fix|]) -> mkLambda (Name function_name,function_type,subst_var function_name (compose_lam res_vars eq_fix)) @@ -1259,31 +1380,33 @@ let recursive_definition is_mes function_name rec_impls type_of_f r rec_arg_num let term_ref = Nametab.locate (make_short_qualid term_id) in let f_ref = declare_f function_name (IsProof Lemma) arg_types term_ref in (* message "start second proof"; *) - let continue = ref true in + let stop = ref false in begin try com_eqn equation_id functional_ref f_ref term_ref (subst_var function_name equation_lemma_type) with e -> begin if Tacinterp.get_debug () <> Tactic_debug.DebugOff - then (Pp.msgnl (str "Cannot create equation Lemma " ++ Cerrors.explain_exn e); continue := false) - else (ignore(try Vernacentries.vernac_reset_name (Util.dummy_loc,functional_id) with _ -> ()); - anomaly "Cannot create equation Lemma") + then pperrnl (str "Cannot create equation Lemma " ++ Cerrors.explain_exn e) + else anomaly "Cannot create equation Lemma" + ; +(* ignore(try Vernacentries.vernac_reset_name (Util.dummy_loc,functional_id) with _ -> ()); *) + stop := true; end end; - if !continue + if not !stop then - let eq_ref = Nametab.locate (make_short_qualid equation_id ) in - let f_ref = destConst (constr_of_reference f_ref) - and functional_ref = destConst (constr_of_reference functional_ref) - and eq_ref = destConst (constr_of_reference eq_ref) in - generate_induction_principle f_ref tcc_lemma_constr - functional_ref eq_ref rec_arg_num rec_arg_type (nb_prod res) relation; - if Options.is_verbose () - then msgnl (h 1 (Ppconstr.pr_id function_name ++ - spc () ++ str"is defined" )++ fnl () ++ - h 1 (Ppconstr.pr_id equation_id ++ - spc () ++ str"is defined" ) - ) + let eq_ref = Nametab.locate (make_short_qualid equation_id ) in + let f_ref = destConst (constr_of_global f_ref) + and functional_ref = destConst (constr_of_global functional_ref) + and eq_ref = destConst (constr_of_global eq_ref) in + generate_induction_principle f_ref tcc_lemma_constr + functional_ref eq_ref rec_arg_num rec_arg_type (nb_prod res) relation; + if Flags.is_verbose () + then msgnl (h 1 (Ppconstr.pr_id function_name ++ + spc () ++ str"is defined" )++ fnl () ++ + h 1 (Ppconstr.pr_id equation_id ++ + spc () ++ str"is defined" ) + ) in try com_terminate @@ -1294,7 +1417,8 @@ let recursive_definition is_mes function_name rec_impls type_of_f r rec_arg_num relation rec_arg_num term_id using_lemmas - hook + (List.length res_vars) + hook with e -> begin ignore(try Vernacentries.vernac_reset_name (Util.dummy_loc,functional_id) with _ -> ()); @@ -1303,22 +1427,4 @@ let recursive_definition is_mes function_name rec_impls type_of_f r rec_arg_num end -VERNAC COMMAND EXTEND RecursiveDefinition - [ "Recursive" "Definition" ident(f) constr(type_of_f) constr(r) constr(wf) - constr(proof) integer_opt(rec_arg_num) constr(eq) ] -> - [ - warning "Recursive Definition is obsolete. Use Function instead"; - ignore(proof);ignore(wf); - let rec_arg_num = - match rec_arg_num with - | None -> 1 - | Some n -> n - in - recursive_definition false f [] type_of_f r rec_arg_num eq (fun _ _ _ _ _ _ _ _ -> ()) []] -| [ "Recursive" "Definition" ident(f) constr(type_of_f) constr(r) constr(wf) - "[" ne_constr_list(proof) "]" constr(eq) ] -> - [ ignore(proof);ignore(wf);recursive_definition false f [] type_of_f r 1 eq (fun _ _ _ _ _ _ _ _ -> ()) []] -END - - diff --git a/contrib/funind/tacinv.ml4 b/contrib/funind/tacinv.ml4 deleted file mode 100644 index 5d19079b..00000000 --- a/contrib/funind/tacinv.ml4 +++ /dev/null @@ -1,872 +0,0 @@ -(*i camlp4deps: "parsing/grammar.cma" i*) - -(*s FunInv Tactic: inversion following the shape of a function. *) - -(* Deprecated: see indfun_main.ml4 instead *) - -(* Don't delete this file yet, it may be used for other purposes *) - -(*i*) -open Termops -open Equality -open Names -open Pp -open Tacmach -open Proof_type -open Tacinterp -open Tactics -open Tacticals -open Term -open Util -open Printer -open Reductionops -open Inductiveops -open Coqlib -open Refine -open Typing -open Declare -open Decl_kinds -open Safe_typing -open Vernacinterp -open Evd -open Environ -open Entries -open Setoid_replace -open Tacinvutils -(*i*) - -module Smap = Map.Make(struct type t = constr let compare = compare end) -let smap_to_list m = Smap.fold (fun c cb l -> (c,cb)::l) m [] -let merge_smap m1 m2 = Smap.fold (fun c cb m -> Smap.add c cb m) m1 m2 -let rec listsuf i l = if i<=0 then l else listsuf (i-1) (List.tl l) -let rec listpref i l = if i<=0 then [] else List.hd l :: listpref (i-1) (List.tl l) -let rec split3 l = - List.fold_right (fun (e1,e2,e3) (a,b,c) -> (e1::a),(e2::b),(e3::c)) l ([],[],[]) - -let mkthesort = mkProp (* would like to put Type here, but with which index? *) - -(* this is the prefix used to name equality hypothesis generated by - case analysis*) -let equality_hyp_string = "_eg_" - -(* bug de refine: on doit ssavoir sur quelle hypothese on se trouve. valeur - initiale au debut de l'appel a la fonction proofPrinc: 1. *) -let nthhyp = ref 1 - -let debug i = prstr ("DEBUG "^ string_of_int i ^"\n") -let pr2constr = (fun c1 c2 -> prconstr c1; prstr " <---> "; prconstr c2) -(* Operations on names *) -let id_of_name = function - Anonymous -> id_of_string "H" - | Name id -> id;; -let string_of_name nme = string_of_id (id_of_name nme) - (*end debugging *) - -(* Interpretation of constr's *) -let constr_of c = Constrintern.interp_constr Evd.empty (Global.env()) c - -(*s specific manipulations on constr *) -let lift1_leqs leq= - List.map - (function (r,(typofg,g,d)) - -> lift 1 r, (lift 1 typofg, lift 1 g , lift 1 d)) leq - -let lift1_relleqs leq= List.map (function (r,x) -> lift 1 r,x) leq - -(* WARNING: In the types, we don't lift the rels in the type. This is - intentional. Use with care. *) -let lift1_lvars lvars= List.map - (function x,(nme,c) -> lift 1 x, (nme, (*lift 1*) c)) lvars - -let pop1_levar levars = List.map (function ev,tev -> ev, popn 1 tev) levars - - -let rec add_n_dummy_prod t n = - if n<=0 then t - else add_n_dummy_prod (mkNamedProd (id_of_string "DUMMY") mkthesort t) (n-1) - -(* [add_lambdas t gl [csr1;csr2...]] returns [[x1:type of csr1] - [x2:type of csr2] t [csr <- x1 ...]], names of abstracted variables - are not specified *) -let rec add_lambdas t gl lcsr = - match lcsr with - | [] -> t - | csr::lcsr' -> - let hyp_csr,hyptyp = csr,(pf_type_of gl csr) in - lambda_id hyp_csr hyptyp (add_lambdas t gl lcsr') - -(* [add_pis t gl [csr1;csr2...]] returns ([x1] :type of [csr1] - [x2]:type of csr2) [t]*) -let rec add_pis t gl lcsr = - match lcsr with - | [] -> t - | csr::lcsr' -> - let hyp_csr,hyptyp = csr,(pf_type_of gl csr) in - prod_id hyp_csr hyptyp (add_pis t gl lcsr') - -let mkProdEg teq eql eqr concl = - mkProd (name_of_string "eg", mkEq teq eql eqr, lift 1 concl) - -let eqs_of_beqs x = - List.map (function (_,(a,b,c)) -> (Anonymous, mkEq a b c)) x - - -let rec eqs_of_beqs_named_aux s i l = - match l with - | [] -> [] - | (r,(a,b,c))::l' -> - (Name(id_of_string (s^ string_of_int i)), mkEq a b c) - ::eqs_of_beqs_named_aux s (i-1) l' - - -let eqs_of_beqs_named s l = eqs_of_beqs_named_aux s (List.length l) l - -let rec patternify ltypes c nme = - match ltypes with - | [] -> c - | (mv,t)::ltypes' -> - let c'= substitterm 0 mv (mkRel 1) c in - let tlift = lift (List.length ltypes') t in - let res = - patternify ltypes' (mkLambda (newname_append nme "rec", tlift, c')) nme in - res - -let rec npatternify ltypes c = - match ltypes with - | [] -> c - | (mv,nme,t)::ltypes' -> - let c'= substitterm 0 mv (mkRel 1) c in - let tlift = lift (List.length ltypes') t in - let res = - npatternify ltypes' (mkLambda (newname_append nme "", tlift, c')) in - res - -(* fait une application (c m1 m2...mn, où mi est une evar, on rend également - la liste des evar munies de leur type) *) -let rec apply_levars c lmetav = - match lmetav with - | [] -> [],c - | (i,typ) :: lmetav' -> - let levars,trm = apply_levars c lmetav' in - let exkey = mknewexist() in - ((exkey,typ)::levars), applistc trm [mkEvar exkey] - (* EXPERIMENT le refine est plus long si on met un cast: - ((exkey,typ)::levars), mkCast ((applistc trm [mkEvar exkey]),typ) *) - - -let prod_change_concl c newconcl = - let lv,_ = decompose_prod c in prod_it newconcl lv - -let lam_change_concl c newconcl = - let lv,_ = decompose_prod c in lam_it newconcl lv - - -let rec mkAppRel c largs n = - match largs with - | [] -> c - | arg::largs' -> - let newc = mkApp (c,[|(mkRel n)|]) in mkAppRel newc largs' (n-1) - -let applFull c typofc = - let lv,t = decompose_prod typofc in - let ltyp = List.map fst lv in - let res = mkAppRel c ltyp (List.length ltyp) in - res - -(* Take two terms with same structure and return a map of deBruijn from the - first to the second. Only DeBruijn should be different between the two - terms. *) -let rec build_rel_map typ type_of_b = - match (kind_of_term typ), (kind_of_term type_of_b) with - Evar _ , Evar _ -> Smap.empty - | Const c1, Const c2 when c1=c2 -> Smap.empty - | Ind c1, Ind c2 when c1=c2 -> Smap.empty - | Rel i, Rel j when i=j -> Smap.empty - | Rel i, Rel j -> Smap.add typ type_of_b Smap.empty - | Prod (name,c1,c2), Prod (nameb,c1b,c2b) -> - let map1 = build_rel_map c1 c1b in - let map2 = build_rel_map (pop c2) (pop c2b) in - merge_smap map1 map2 - | App (f,args), App (fb,argsb) when Array.length args = Array.length argsb -> - build_rel_map_list (Array.to_list args) (Array.to_list argsb) - | _,_ -> failwith ("Could not generate case annotation. "^ - "Incompatibility between annotation and actual type") - -and build_rel_map_list ltyp ltype_of_b = - List.fold_left2 (fun a b c -> merge_smap a (build_rel_map b c)) - Smap.empty ltyp ltype_of_b - - -(*s Use (and proof) of the principle *) - -(* This is the type of the argument of [proofPrinc] *) - -type mimickinfo = - { - concl: constr; (* conclusion voulue, cad (xi:ti)gl, ou gl est le but a - prouver, et xi:ti correspondent aux arguments donnés à - la tactique. On enlèvera un produit à chaque fois - qu'on rencontrera un binder, sans lift ou pop. - Initialement: une seule conclusion, puis specifique à - chaque branche. *) - absconcl: constr array; (* conclusions patternisées pour pouvoir être - appliquées = un predicat pour chaque fixpt - mutuel. *) - mimick: constr; (* le terme qu'on imite. On plongera dedans au fur et - à mesure, sans lift ni pop. *) - env: env; (* The global typing environment, we will add thing in it when - going inside the term (push_rel, push_rec_types) *) - sigma: Evd.evar_map; - nmefonc: constr array; (* la constante correspondant à la fonction - appelée, permet de remplacer les appels - recursifs par des appels à la constante - correspondante (non pertinent (et inutile) si - on permet l'appel de la tactique sur une terme - donné directement (au lieu d'une constante - comme pour l'instant)). *) - fonc: int * int; (* bornes des indices des variable correspondant aux - appels récursifs (plusieurs car fixp. mutuels), - utile pour reconnaître les appels récursifs - (ATTENTION: initialement vide, reste vide tant qu'on - n'est pas dans un fix). *) - doeqs: bool; (* this reference is to toggle building of equalities during - the building of the principle (default is true) *) - fix: bool; (* did I already went through a fix or case constr? lambdas - found before a case or a fix are treated as parameters of - the induction principle *) - lst_vars: (constr*(name*constr)) list ; (* Variables rencontrées jusque là *) - lst_eqs: (Term.constr * (Term.constr * Term.constr * Term.constr)) list ; - (* liste d'équations engendrées au cours du - parcours, cette liste grandit à chaque - case, et il faut lifter le tout à chaque - binder *) - lst_recs: constr list ; (* appels récursifs rencontrés jusque là *) - } - -(* This is the return type of [proofPrinc] *) -type 'a funind = (* 'A = CONTR OU CONSTR ARRAY *) - { - - princ:'a; (* le (ou les) principe(s) demandé(s), il contient des meta - variables représentant soit des trous à prouver plus tard, - soit les conclusions à compléter avant de rendre le terme - (suivant qu'on utilise le principe pour faire refine ou - functional scheme). Il y plusieurs conclusions si plusieurs - fonction mutuellement récursives) voir la suite. *) - evarlist: (constr*Term.types) list; (* [(ev1,tev1);(ev2,tev2)...]] - l'ensemble des meta variables - correspondant à des trous. [evi] - est la meta variable, [tevi] est - son type. *) - hypnum: (int*int*int) list; (* [[(in,jn,kn)...]] sont les nombres - respectivement de variables, d'équations, - et d'hypothèses de récurrence pour le but - n. Permet de faire le bon nombre d'intros - et des rewrite au bons endroits dans la - suite. *) - mutfixmetas: constr array ; (* un tableau de meta variables correspondant - à chacun des prédicats mutuellement - récursifs construits. *) - conclarray: types array; (* un tableau contenant les conclusions - respectives de chacun des prédicats - mutuellement récursifs. Permet de finir la - construction du principe. *) - params:(constr*name*constr) list; (* [[(metavar,param,tparam)..]] la - liste des paramètres (les lambdas - au-dessus du fix) du fixpoint si - fixpoint il y a, le paramètre est - une meta var, dont on stocke le nom - et le type. TODO: utiliser la - structure adequat? *) - } - - - -let empty_funind_constr = - { - princ = mkProp; - evarlist = []; - hypnum = []; - mutfixmetas = [||]; - conclarray = [||]; - params = [] - } - -let empty_funind_array = - { empty_funind_constr with - princ = [||]; - } - -(* Replace the calls to the function (recursive calls) by calls to the - corresponding constant *) -let replace_reccalls mi b = - let d,f = mi.fonc in - let res = ref b in - let _ = for i = d to f do - res := substitterm 0 (mkRel i) mi.nmefonc.(f-i) !res done in - !res - - - -(* collects all information of match branches stored in [l] *) -let rec collect_cases l = - match l with - | [||] -> empty_funind_array - | arr -> - let x = arr.(0) in - let resrec = collect_cases (Array.sub arr 1 (Array.length arr - 1)) in - { x with - princ= Array.append [|x.princ|] resrec.princ; - evarlist = x.evarlist@resrec.evarlist; - hypnum = x.hypnum@resrec.hypnum; - } - -let collect_pred l = - let l1,l2,l3 = split3 l in - Array.of_list l1 , Array.of_list l2 , Array.of_list l3 - - -(* [build_pred n tarr] builds the right predicates for each element of [tarr] - (of type: [type array] of size [n]). Return the list of triples: - (?i , - fun (x1:t1) ... (xn:tn) => (?i x1...xn) , - forall (x1:t1) ... (xn:tn), (?i x1...xn)), - where ti's are deduced from elements of tarr, which are of the form: - t1 -> t2 -> ... -> tn -> <nevermind>. *) -let rec build_pred n tarr = - if n >= Array.length tarr (* iarr *) then [] - else - let ftyp = Array.get tarr n in - let gl = mknewmeta() in - let gl_app = applFull gl ftyp in - let pis = prod_change_concl ftyp gl_app in - let gl_abstr = lam_change_concl ftyp gl_app in - (gl,gl_abstr,pis):: build_pred (n+1) tarr - - -let heq_prefix = "H_eq_" - -type kind_of_hyp = Var | Eq (*| Rec*) - -(* the main function, build the principle by exploring the term and reproduce - the same structure. *) -let rec proofPrinc mi: constr funind = - match kind_of_term mi.mimick with - (* Fixpoint: we reproduce the Fix, fonc becomes (1,nbofmutf) to point on - the name of recursive calls *) - | Fix((iarr,i),(narr,tarr,carr)) -> - (* We construct the right predicates for each mutual fixpt *) - let evararr,newabsconcl,pisarr = collect_pred (build_pred 0 tarr) in - let newenv = push_rec_types (narr,tarr,carr) mi.env in - let anme',aappel_rec,llevar,llposeq = - collect_fix mi 0 iarr narr carr pisarr newabsconcl newenv in - let anme = Array.map (fun nme -> newname_append nme "_ind") anme' in - { - princ = mkFix((iarr,i),(anme, pisarr,aappel_rec)); - evarlist= pop1_levar llevar; (* llevar are put outside the fix, so we pop 1 *) - hypnum = llposeq; - mutfixmetas = evararr; - conclarray = pisarr; - params = [] - } - (* <pcase> Cases b of arrPt end.*) - | Case (cinfo, pcase, b, arrPt) -> - let prod_pcase,_ = decompose_lam pcase in - let _nmeb,_ = List.hd prod_pcase in - let newb'= apply_leqtrpl_t b mi.lst_eqs in - let type_of_b = Typing.type_of mi.env mi.sigma b in - (* Replace the recursive calls to the function by calls to the constant *) - let newb = replace_reccalls mi newb' in - let cases = collect_cases (Array.mapi (fold_proof mi b type_of_b newb) arrPt) in - (* the match (case) annotation must be transformed, see [build_pcase] below *) - let newpcase = build_pcase mi pcase b type_of_b newb in - let trm' = mkCase (cinfo,newpcase,newb, cases.princ) in - { cases with - princ = if mi.doeqs then mkApp (trm',[|(mkRefl type_of_b newb)|]) else trm'; - params = [] (* FIX: fix parms here (fixpt inside a match)*) - } - - - | Lambda(nme, typ, cstr) -> - let _, _, cconcl = destProd mi.concl in - let d,f=mi.fonc in - let newenv = push_rel (nme,None,typ) mi.env in - let newlst_var = (* if this lambda is a param, then don't add it here *) - if mi.fix then (mkRel 1,(nme,typ)) :: lift1_lvars mi.lst_vars - else (*(mkRel 1,(nme,typ)) :: *) lift1_lvars mi.lst_vars in - let newmi = {mi with concl=cconcl; mimick=cstr; env=newenv; - fonc = (if d > 0 then d+1 else 0) , (if f > 0 then f+1 else 0); - lst_vars = newlst_var ; lst_eqs = lift1_leqs mi.lst_eqs; - lst_recs = lift1L mi.lst_recs} in - let resrec = proofPrinc newmi in - (* are we inside a fixpoint or a case? then this is a normal lambda *) - if mi.fix - then { resrec with princ = mkLambda (nme,typ,resrec.princ) ; params = [] } - else (* otherwise this is a parameter *) - let metav = mknewmeta() in - let substmeta t = popn 1 (substitterm 0 (mkRel 1) metav t) in - { resrec with - princ = substmeta resrec.princ; - evarlist = List.map (fun (ev,tev) -> ev, substmeta tev) resrec.evarlist; - conclarray = Array.map substmeta resrec.conclarray; - params = (metav,nme,typ) :: resrec.params - } - - - | LetIn(nme,cstr1, typ, cstr) -> - failwith ("I don't deal with let ins yet. "^ - "Please expand them before applying this function.") - - | u -> - let varrels = List.rev (List.map fst mi.lst_vars) in - let varnames = List.map snd mi.lst_vars in - let nb_vars = List.length varnames in - let nb_eqs = List.length mi.lst_eqs in - let _eqrels = List.map fst mi.lst_eqs in - (* [terms_recs]: appel rec du fixpoint, On concatène les appels recs - trouvés dans les let in et les Cases avec ceux trouves dans u (ie - mi.mimick). *) - (* TODO: il faudra gérer plusieurs pt fixes imbriqués ? *) - let terms_recs = mi.lst_recs @ hdMatchSub_cpl mi.mimick mi.fonc in - (*c construction du terme: application successive des variables, des - egalites et des appels rec, a la variable existentielle correspondant a - l'hypothese de recurrence en cours. *) - (* d'abord, on fabrique les types des appels recursifs en replacant le nom - de des fonctions par les predicats dans [terms_recs]: [(f_i t u v)] - devient [(P_i t u v)] *) - (* TODO optimiser ici: *) - let appsrecpred = exchange_reli_arrayi_L mi.absconcl mi.fonc terms_recs in - let typeofhole'' = prod_it_anonym_lift mi.concl appsrecpred in - let typeofhole = prodn nb_vars varnames typeofhole'' in - (* Un bug de refine m'oblige à mettre ici un H (meta variable à ce point, - mais remplacé par H avant le refine) au lieu d'un '?', je mettrai les - '?' à la fin comme ça [(([H1,H2,H3...] ...) ? ? ?)] *) - let newmeta = mknewmeta() in - let concl_with_var = applistc newmeta varrels in - let conclrecs = applistc concl_with_var terms_recs in - { empty_funind_constr with - princ = conclrecs; - evarlist = [ newmeta , typeofhole ]; - hypnum = [ nb_vars , List.length terms_recs , nb_eqs ]; - conclarray = mi.absconcl; - } - - -(* C'est un peu compliqué ici: en cas de type inductif vraiment dépendant - l'annotation de type du case [pcase] contient des lambdas supplémentaires - en tête. Je les récupère dans la variable [suppllam_pcase]. Le problème est - que la conclusion de l'annotation du nouveauacse doit faire référence à ces - variables plutôt qu'à celle de l'exterieur. Ce qui suit permet de changer - les reference de newpcase' pour pointer vers les lambda du piquant. On - procède comme suit: on repère les rels qui pointent à l'interieur de - l'annotation dans la fonction initiale et on les relie à celle du type - voulu pour le case, pour ça ([build_rel_map]) on parcourt en même temps le - dernier lambda du piquant ([typ]) (qui contient le type de l'argument du - case) et le type attendu pour le case ([type_of_b]) et on construit un - map. Ensuite on remplace les rels correspondant dans la preuve construite - en suivant le map. *) - -and build_pcase mi pcase b type_of_b newb = - let prod_pcase,_ = decompose_lam pcase in - let nme,typ = List.hd prod_pcase in - (* je remplace b par rel1 (apres avoir lifte un coup) dans la future - annotation du futur case: ensuite je mettrai un lambda devant *) - let typeof_case'' = substitterm 0 (lift 1 b) (mkRel 1) (lift 1 mi.concl) in - let suppllam_pcase = List.tl prod_pcase in - let suppllam_pcasel = List.length suppllam_pcase in - let rel_smap = - if suppllam_pcasel=0 then Smap.empty else (* FIX: is this test necessary ? *) - build_rel_map (lift suppllam_pcasel type_of_b) typ in - let newpcase''' = - Smap.fold (fun e e' acc -> substitterm 0 e (lift 1 e') acc) - rel_smap typeof_case'' in - let neweq = mkEq (lift (suppllam_pcasel + 1) type_of_b) - (lift (suppllam_pcasel + 1) newb) (mkRel 1) in - let newpcase'' = - if mi.doeqs - then mkProd (name_of_string "eg", neweq, lift 1 newpcase''') - else newpcase''' in - (* construction du dernier lambda du piquant. *) - let newpcase' = mkLambda (newname_append nme "_ind" ,typ, newpcase'') in - (* ajout des lambdas supplémentaires (type dépendant) du piquant. *) - lamn suppllam_pcasel suppllam_pcase newpcase' - - -(* [fold_proof mi b typeofb newb l n] rend le resultat de l'appel recursif sur - cstr (correpsondant au ième elt de [arrPt] ci-dessus et donc au ième - constructeur de [typeofb]), appele avec les bons arguments: [mi.concl] - devient [(DUMMY1:t1;...;DUMMY:tn)concl'], ou [n] est le nombre d'arguments - du constructeur considéré, et [concl'] est [mi.concl] ou l'on a réécrit [b] - en ($c_n$ [rel1]...). *) -and fold_proof mi b type_of_b newb i cstr = - let new_lst_recs = mi.lst_recs @ hdMatchSub_cpl b mi.fonc in - (* mise a jour de concl pour l'interieur du case, concl'= concl[b <- C x3 - x2 x1... ], sans quoi les annotations ne sont plus coherentes *) - let cstr_appl,nargs = nth_dep_constructor type_of_b i in - let concl'' = - substitterm 0 (lift nargs b) cstr_appl (lift nargs mi.concl) in - let neweq = mkEq type_of_b newb (popn nargs cstr_appl) in - let concl_dummy = add_n_dummy_prod concl'' nargs in - let lsteqs_rew = apply_eq_leqtrpl mi.lst_eqs neweq in - let new_lsteqs = (mkRel (-nargs),(type_of_b,newb, popn nargs cstr_appl))::lsteqs_rew in - let a',a'' = decompose_lam_n nargs cstr in - let newa'' = - if mi.doeqs - then mkLambda (name_of_string heq_prefix,lift nargs neweq,lift 1 a'') - else a'' in - let newmimick = lamn nargs a' newa'' in - let b',b'' = decompose_prod_n nargs concl_dummy in - let newb'' = - if mi.doeqs - then mkProd (name_of_string heq_prefix,lift nargs neweq,lift 1 b'') - else b'' in - let newconcl = prodn nargs b' newb'' in - let newmi = {mi with mimick=newmimick; concl=newconcl; fix=true; - lst_eqs= new_lsteqs; lst_recs = new_lst_recs} in - proofPrinc newmi - - -and collect_fix mi n iarr narr carr pisarr newabsconcl newenv = - if n >= Array.length iarr then [||],[||],[],[] - else - let nme = Array.get narr n in - let c = Array.get carr n in - (* rappelle sur le sous-terme, on ajoute un niveau de - profondeur (lift) parce que Fix est un binder. *) - let newmi = {mi with concl=(pisarr.(n)); absconcl=newabsconcl; - mimick=c; fonc=(1,((Array.length iarr)));env=newenv;fix=true; - lst_vars=lift1_lvars mi.lst_vars; lst_eqs=lift1_leqs mi.lst_eqs; - lst_recs= lift1L mi.lst_recs;} in - let resrec = proofPrinc newmi in - let lnme,lappel_rec,llevar,llposeq = - collect_fix mi (n+1) iarr narr carr pisarr newabsconcl newenv in - Array.append [|nme|] lnme , Array.append [|resrec.princ|] lappel_rec - , (resrec.evarlist@llevar) , (resrec.hypnum@llposeq) - -let mkevarmap_aux ex = let x,y = ex in (mkevarmap_from_listex x),y - - -(* TODO: deal with any term, not only a constant. *) -let interp_fonc_tacarg fonctac gl = - (* [fonc] is the constr corresponding to fontact not unfolded, - if [fonctac] is a (qualified) name then this is a [const] ?. *) -(* let fonc = constr_of_Constr fonctac in *) - (* TODO: replace the [with _ -> ] by something more precise in - the following. *) - (* [def_fonc] is the definition of fonc. TODO: We should do this only - if [fonc] is a const, and take [fonc] otherwise.*) - try fonctac, pf_const_value gl (destConst fonctac) - with _ -> failwith ("don't know how to deal with this function " - ^"(DEBUG:is it a constante?)") - - - - -(* [invfun_proof fonc def_fonc gl_abstr pis] builds the principle, - following the shape of [def_fonc], [fonc] is the constant - corresponding to [def_func] (or a reduced form of it ?), gl_abstr and - pis are the goal to be proved, of the form [x,y...]g and (x.y...)g. - - This function calls the big function proofPrinc. *) - -let invfun_proof fonc def_fonc gl_abstr pis env sigma = - let mi = {concl=pis; absconcl=gl_abstr; mimick=def_fonc; env=env; - sigma=sigma; nmefonc=fonc; fonc=(0,0); doeqs=true; fix=false ; - lst_vars = []; lst_eqs = []; lst_recs = []} in - proofPrinc mi - -(* Do intros [i] times, then do rewrite on all introduced hyps which are called - like [heq_prefix], FIX: have another filter than the name. *) -let rec iterintro i = - if i<=0 then tclIDTAC else - tclTHEN - (tclTHEN - intro - (iterintro (i-1))) - (fun gl -> - (tclREPEAT - (tclNTH_HYP i - (fun hyp -> - let hypname = (string_of_id (destVar hyp)) in - let sub = - try String.sub hypname 0 (String.length heq_prefix) - with _ -> "" (* different than [heq_prefix] *) in - if sub=heq_prefix then rewriteLR hyp else tclFAIL 0 (str "Cannot rewrite")) - )) gl) - - -(* - (fun hyp gl -> - let _ = prstr ("nthhyp= "^ string_of_int i) in - if isConst hyp && ((name_of_const hyp)==heq_prefix) then - let _ = prstr "YES\n" in - rewriteLR hyp gl - else - let _ = prstr "NO\n" in - tclIDTAC gl) - *) - -(* [invfun_basic C listargs_ids gl dorew lposeq] builds the tactic - which: - \begin{itemize} - \item Do refine on C (the induction principle), - \item try to Clear listargs_ids - \item if boolean dorew is true, then intro all new hypothesis, and - try rewrite on those hypothesis that are equalities. - \end{itemize} -*) - -let invfun_basic open_princ_proof_applied listargs_ids gl dorew lposeq = - (tclTHEN_i - (tclTHEN - (tclTHEN - (* Refine on the right term (following the sheme of the - given function) *) - (fun gl -> refine open_princ_proof_applied gl) - (* Clear the hypothesis given as arguments of the tactic - (because they are generalized) *) - (tclTHEN simpl_in_concl (tclTRY (clear listargs_ids)))) - (* Now we introduce the created hypothesis, and try rewrite on - equalities due to case analysis *) - (fun gl -> (tclIDTAC gl))) - (fun i gl -> - if not dorew then tclIDTAC gl - else - (* d,m,f correspond respectively to vars, induction hyps and - equalities*) - let d,m,f = List.nth lposeq (i-1) in - tclTHEN (iterintro (d)) (tclDO m (tclTRY intro)) gl) - ) - gl - - - - -(* This function trys to reduce instanciated arguments, provided they - are of the form [(C t u v...)] where [C] is a constructor, and - provided that the argument is not the argument of a fixpoint (i.e. the - argument corresponds to a simple lambda) . *) -let rec applistc_iota cstr lcstr env sigma = - match lcstr with - | [] -> cstr,[] - | arg::lcstr' -> - let arghd = - if isApp arg then let x,_ = destApp arg in x else arg in - if isConstruct arghd (* of the form [(C ...)]*) - then - applistc_iota (Tacred.nf env sigma (nf_beta (applistc cstr [arg]))) - lcstr' env sigma - else - try - let nme,typ,suite = destLambda cstr in - let c, l = applistc_iota suite lcstr' env sigma in - mkLambda (nme,typ,c), arg::l - with _ -> cstr,arg::lcstr' (* the arg does not correspond to a lambda*) - - - -(* TODO: ne plus mettre les sous-but à l'exterieur, mais à l'intérieur (le bug - de refine est normalement resolu). Ca permettra 2 choses: d'une part que - les preuves soient plus simple, et d'autre part de fabriquer un terme de - refine qui pourra s'aapliquer SANS FAIRE LES INTROS AVANT, ce qui est bcp - mieux car fonctionne comme induction et plus comme inversion (pas de perte - de connexion entre les hypothèse et les variables). *) - -(*s Tactic that makes induction and case analysis following the shape - of a function (idf) given with arguments (listargs) *) -let invfun c l dorew gl = -(* \begin{itemize} - \item [fonc] = the constant corresponding to the function - (necessary for equalities of the form [(f x1 x2 ...)=...] where - [f] is the recursive function). - \item [def_fonc] = body of the function, where let ins have - been expanded. *) - let fonc, def_fonc' = interp_fonc_tacarg c gl in - let def_fonc'',listargs' = - applistc_iota def_fonc' l (pf_env gl) (project gl) in - let def_fonc = expand_letins def_fonc'' in - (* quantifies on previously generalized arguments. - [(x1:T1)...g[arg1 <- x1 ...]] *) - let pis = add_pis (pf_concl gl) gl listargs' in - (* princ_proof builds the principle *) - let _ = resetmeta() in - let pr = invfun_proof [|fonc|] def_fonc [||] pis (pf_env gl) (project gl) in - (* Generalize the goal. [[x1:T1][x2:T2]... g[arg1 <- x1 ...]]. *) - let gl_abstr' = add_lambdas (pf_concl gl) gl listargs' in - (* apply parameters immediately *) - let gl_abstr = - applistc gl_abstr' (List.map (fun (x,y,z) -> x) (List.rev pr.params)) in - (* we apply args of the fix now, the parameters will be applied later *) - let princ_proof_applied_args = - applistc pr.princ (listsuf (List.length pr.params) listargs') in - (* parameters are still there so patternify must not take them -> lift *) - let princ_proof_applied_lift = - lift (List.length pr.evarlist) princ_proof_applied_args in - let princ_applied_hyps'' = patternify (List.rev pr.evarlist) - princ_proof_applied_lift (Name (id_of_string "Hyp")) in - (* if there was a fix, we will not add "Q" as in funscheme, so we make a pop, - TODO: find were we made the lift in proofPrinc instead and supress it here, - and add lift in funscheme. *) - let princ_applied_hyps' = - if Array.length pr.mutfixmetas > 0 then popn 1 princ_applied_hyps'' - else princ_applied_hyps'' in - (* if there is was fix, we have to replace the meta representing the - predicate of the goal by the abstracted goal itself. *) - let princ_applied_hyps = - if Array.length pr.mutfixmetas > 0 then(* mutual Fixpoint not treated in the tactic*) - (substit_red 0 (pr.mutfixmetas.(0)) gl_abstr princ_applied_hyps') - else princ_applied_hyps' (* No Fixpoint *) in - let _ = prNamedConstr "princ_applied_hyps" princ_applied_hyps in - (* Same thing inside levar *) - let newlevar' = - if Array.length pr.mutfixmetas > 0 then(* mutual Fixpoint not treated in the tactic*) - List.map (fun (x,y) -> x,substit_red 0 (pr.mutfixmetas.(0)) gl_abstr y) pr.evarlist - else pr.evarlist - in - (* replace params metavar by real args *) - let rec replace_parms lparms largs t = - match lparms, largs with - [], _ -> t - | ((p,_,_)::lp), (a::la) -> let t'= substitterm 0 p a t in replace_parms lp la t' - | _, _ -> error "problem with number of args." in - let princ_proof_applied = replace_parms pr.params listargs' princ_applied_hyps in - let _ = prNamedLConstr "levar:" (List.map fst newlevar') in - let _ = prNamedLConstr "levar types:" (List.map snd newlevar') in - let _ = prNamedConstr "princ_proof_applied" princ_proof_applied in - (* replace also in levar *) - let newlevar = - List.rev (List.map (fun (x,y) -> x, replace_parms pr.params listargs' y) newlevar') in -(* - (* replace params metavar by abstracted variables *) - let princ_proof_params = npatternify (List.rev pr.params) princ_applied_hyps in - (* we apply now the real parameters *) - let princ_proof_applied = - applistc princ_proof_params (listpref (List.length pr.params) listargs') in -*) - let princ_applied_evars = apply_levars princ_proof_applied newlevar in - let open_princ_proof_applied = princ_applied_evars in - let _ = prNamedConstr "princ_applied_evars" (snd princ_applied_evars) in - let _ = prNamedLConstr "evars" (List.map snd (fst princ_applied_evars)) in - let listargs_ids = List.map destVar (List.filter isVar listargs') in - (* debug: impression du but*) - let lgl = Evd.to_list (sig_sig gl) in - let _ = prNamedLConstr "\ngl= " (List.map (fun x -> (snd x).evar_concl) lgl) in - let _ = prstr "fin gl \n\n" in - invfun_basic (mkevarmap_aux open_princ_proof_applied) listargs_ids - gl dorew pr.hypnum - -(* function must be a constant, all arguments must be given. *) -let invfun_verif c l dorew gl = - if not (isConst c) then error "given function is not a constant" - else - let x,_ = decompose_prod (pf_type_of gl c) in - if List.length x = List.length l then - try invfun c l dorew gl - with UserError (x,y) -> raise (UserError (x,y)) - else error "wrong number of arguments for the function" - - - - -(* Construction of the functional scheme. *) -let buildFunscheme fonc mutflist = - let def_fonc = expand_letins (def_of_const fonc) in - let ftyp = type_of (Global.env ()) Evd.empty fonc in - let _ = resetmeta() in - let gl = mknewmeta() in - let gl_app = applFull gl ftyp in - let pis = prod_change_concl ftyp gl_app in - (* Here we call the function invfun_proof, that effectively - builds the scheme *) -(* let princ_proof,levar,_,evararr,absc,parms = *) - let _ = prstr "Recherche du principe... lancement de invfun_proof\n" in - let pr = invfun_proof mutflist def_fonc [||] pis (Global.env()) Evd.empty in - (* parameters are still there (unboud rel), and patternify must not take them - -> lift*) - let princ_proof_lift = lift (List.length pr.evarlist) pr.princ in - let princ_proof_hyps = - patternify (List.rev pr.evarlist) princ_proof_lift (Name (id_of_string "Hyp")) in - let rec princ_replace_metas ev abs i t = - if i>= Array.length ev then t - else (* fix? *) - princ_replace_metas ev abs (i+1) - (mkLambda ( - (Name (id_of_string ("Q"^(string_of_int i)))), - prod_change_concl (lift 0 abs.(i)) mkthesort, - (substitterm 0 ev.(i) (mkRel 1) (lift 0 t)))) - in - let rec princ_replace_params params t = - List.fold_left ( - fun acc (ev,nam,typ) -> - mkLambda (Name (id_of_name nam) , typ, - substitterm 0 ev (mkRel 1) (lift 0 acc))) - t (List.rev params) in - if Array.length pr.mutfixmetas = 0 (* Is there a Fixpoint? *) - then (* No Fixpoint *) - princ_replace_params pr.params (mkLambda ((Name (id_of_string "Q")), - prod_change_concl ftyp mkthesort, - (substitterm 0 gl (mkRel 1) princ_proof_hyps))) - else (* there is a fix -> add parameters + replace metas *) - let princ_rpl = - princ_replace_metas pr.mutfixmetas pr.conclarray 0 princ_proof_hyps in - princ_replace_params pr.params princ_rpl - - - -(* Declaration of the functional scheme. *) -let declareFunScheme f fname mutflist = - let _ = prstr "Recherche du perincipe...\n" in - let id_to_cstr id = - try constr_of_id (Global.env()) id - with - Not_found -> error (string_of_id id ^ " not found in the environment") in - let flist = if mutflist=[] then [f] else mutflist in - let fcstrlist = Array.of_list (List.map id_to_cstr flist) in - let idf = id_to_cstr f in - let scheme = buildFunscheme idf fcstrlist in - let _ = prstr "Principe:" in - let _ = prconstr scheme in - let ce = { - const_entry_body = scheme; - const_entry_type = None; - const_entry_opaque = false; - const_entry_boxed = true } in - let _= ignore (declare_constant fname (DefinitionEntry ce,IsDefinition Scheme)) in - () - - - -TACTIC EXTEND functional_induction - [ "old" "functional" "induction" constr(c) ne_constr_list(l) ] - -> [ invfun_verif c l true ] -END - -VERNAC COMMAND EXTEND FunctionalScheme - [ "Old" "Functional" "Scheme" ident(na) ":=" "Induction" "for" - ident(c) "with" ne_ident_list(l) ] - -> [ declareFunScheme c na l ] -| [ "Old" "Functional" "Scheme" ident(na) ":=" "Induction" "for" ident (c) ] - -> [ declareFunScheme c na [] ] -END - - - - - -(* -*** Local Variables: *** -*** compile-command: "make -C ../.. contrib/funind/tacinv.cmo" *** -*** tuareg-default-indent:1 *** -*** tuareg-begin-indent:1 *** -*** tuareg-let-indent:1 *** -*** tuareg-match-indent:-1 *** -*** tuareg-try-indent:1 *** -*** tuareg-with-indent:1 *** -*** tuareg-if-then-else-inden:1 *** -*** fill-column: 78 *** -*** indent-tabs-mode: nil *** -*** test-tactic: "../../bin/coqtop -translate -q -batch -load-vernac-source ../../test-suite/success/Funind.v" *** -*** End: *** -*) - - diff --git a/contrib/funind/tacinvutils.ml b/contrib/funind/tacinvutils.ml deleted file mode 100644 index ce775e0b..00000000 --- a/contrib/funind/tacinvutils.ml +++ /dev/null @@ -1,284 +0,0 @@ -(* tacinvutils.ml *) -(*s utilities *) - -(*i*) -open Names -open Util -open Term -open Termops -open Coqlib -open Pp -open Printer -open Inductiveops -open Environ -open Declarations -open Nameops -open Evd -open Sign -open Reductionops -(*i*) - -(*s printing of constr -- debugging *) - -(* comment this line to see debug msgs *) -let msg x = () ;; let pr_lconstr c = str "" - (* uncomment this to see debugging *) -let prconstr c = msg (str" " ++ pr_lconstr c ++ str"\n") -let prlistconstr lc = List.iter prconstr lc -let prstr s = msg(str s) - -let prchr () = msg (str" (ret) \n") -let prNamedConstr s c = - begin - msg(str ""); - msg(str(s^"==>\n ") ++ pr_lconstr c ++ str "\n<==\n"); - msg(str ""); - end - -let prNamedLConstr_aux lc = - List.iter (prNamedConstr "#>") lc - -let prNamedLConstr s lc = - begin - prstr s; - prNamedLConstr_aux lc - end - - -(* FIXME: ref 1, pas bon, si? *) -let evarcpt = ref 0 -let metacpt = ref 0 -let mknewexist ()= - begin - evarcpt := !evarcpt+1; - !evarcpt,[||] - end - -let resetexist ()= evarcpt := 0 - -let mknewmeta ()= - begin - metacpt := !metacpt+1; - mkMeta (!metacpt) - end - -let resetmeta () = metacpt := 0 - -let rec mkevarmap_from_listex lex = - match lex with - | [] -> Evd.empty - | ((ex,_),typ)::lex' -> -(* let _ = prstr "mkevarmap" in - let _ = prstr ("evar n. " ^ string_of_int ex ^ " ") in - let _ = prstr "OF TYPE: " in - let _ = prconstr typ in*) - let info = { - evar_concl = typ; - evar_hyps = empty_named_context_val; - evar_body = Evar_empty; - evar_extra = None} in - Evd.add (mkevarmap_from_listex lex') ex info - -let mkEq typ c1 c2 = - mkApp (build_coq_eq(),[| typ; c1; c2|]) - -let mkRefl typ c1 = - mkApp ((build_coq_eq_data()).refl, [| typ; c1|]) - -let rec popn i c = if i<=0 then c else pop (popn (i-1) c) - - -(* Operations on names *) -let id_of_name = function - Anonymous -> id_of_string "H" - | Name id -> id;; -let string_of_name nme = string_of_id (id_of_name nme) -let name_of_string str = Name (id_of_string str) -let newname_append nme str = - Name(id_of_string ((string_of_id (id_of_name nme))^str)) - -(* Substitutions in constr *) - -let compare_constr_nosub t1 t2 = - if compare_constr (fun _ _ -> false) t1 t2 - then true - else false - -let rec compare_constr' t1 t2 = - if compare_constr_nosub t1 t2 - then true - else (compare_constr (compare_constr') t1 t2) - -let rec substitterm prof t by_t in_u = - if (compare_constr' (lift prof t) in_u) - then (lift prof by_t) - else map_constr_with_binders succ - (fun i -> substitterm i t by_t) prof in_u - - -let apply_eqtrpl eq t = - let r,(tb,b,by_t) = eq in - substitterm 0 b by_t t - -let apply_eqtrpl_lt lt eq = List.map (apply_eqtrpl eq) lt - -let apply_leqtrpl_t t leq = - List.fold_left (fun x y -> apply_eqtrpl y x) t leq - - -let apply_refl_term eq t = - let _,arr = destApp eq in - let reli= (Array.get arr 1) in - let by_t= (Array.get arr 2) in - substitterm 0 reli by_t t - -let apply_eq_leqtrpl leq eq = - List.map - (function (r,(tb,b,t)) -> - r,(tb, - (if isRel b then b else (apply_refl_term eq b)), apply_refl_term eq t)) - leq - - - -(* [(a b c) a] -> true *) -let constr_head_match u t= - if isApp u - then - let uhd,args= destApp u in - uhd=t - else false - -(* My operations on constr *) -let lift1L l = (List.map (lift 1) l) -let mkArrow_lift t1 t2 = mkArrow t1 (lift 1 t2) -let mkProd_liftc nme c1 c2 = mkProd (nme,c1,(lift 1 c2)) -(* prod_it_lift x [a1 a2 ...] *) -let prod_it_lift ini lcpl = - List.fold_right (function a,b -> (fun c -> mkProd_liftc a b c)) ini lcpl;; - -let prod_it_anonym_lift trm lst = List.fold_right mkArrow_lift lst trm - -let lam_it_anonymous trm lst = - List.fold_right - (fun elt res -> mkLambda(Name(id_of_string "Hrec"),elt,res)) lst trm - -let lambda_id id typeofid cstr = - let cstr' = mkNamedLambda (id_of_string "FUNX") typeofid cstr in - substitterm 0 id (mkRel 0) cstr' - -let prod_id id typeofid cstr = - let cstr' = mkNamedProd (id_of_string "FUNX") typeofid cstr in - substitterm 0 id (mkRel 0) cstr' - - - - - -let nth_dep_constructor indtype n = - let sigma = Evd.empty and env = Global.env() in - let indtypedef = find_rectype env sigma indtype in - let indfam,_ = dest_ind_type indtypedef in - let arr_cstr_summary = get_constructors env indfam in - let cstr_sum = Array.get arr_cstr_summary n in - build_dependent_constructor cstr_sum, cstr_sum.cs_nargs - - -let rec buildrefl_from_eqs eqs = - match eqs with - | [] -> [] - | cstr::eqs' -> - let eq,args = destApp cstr in - (mkRefl (Array.get args 0) (Array.get args 2)) - :: (buildrefl_from_eqs eqs') - - - - -(* list of occurrences of a term inside another *) -(* Cofix will be wrong, not sure Fix is correct too *) -let rec hdMatchSub u t= - let subres = - match kind_of_term u with - | Lambda (nm,tp,cstr) | Prod (nm,tp,cstr) -> hdMatchSub (lift 1 cstr) t - | Fix (_,(lna,tl,bl)) -> - Array.fold_left - (fun acc cstr -> acc @ hdMatchSub (lift (Array.length tl) cstr) t) - [] bl - | LetIn _ -> assert false - (* Correct? *) - | _ -> fold_constr (fun l cstr -> l @ hdMatchSub cstr t) [] u - in - if constr_head_match u t then u :: subres else subres - - -(* let hdMatchSub_list u lt = List.flatten (List.map (hdMatchSub u) lt) *) -let hdMatchSub_cpl u (d,f) = - let res = ref [] in - begin - for i = d to f do res := hdMatchSub u (mkRel i) @ !res done; - !res - end - - -(* destApplication raises an exception if [t] is not an application *) -let exchange_hd_prod subst_hd t = - let hd,args= destApplication t in mkApp (subst_hd,args) - -(* substitute t by by_t in head of products inside in_u, reduces each - product found *) -let rec substit_red prof t by_t in_u = - if constr_head_match in_u (lift prof t) - then - let x = whd_beta (exchange_hd_prod (lift prof by_t) in_u) in - x - else - map_constr_with_binders succ (fun i u -> substit_red i t by_t u) prof in_u - -(* [exchange_reli_arrayi t=(reli x y ...) tarr (d,f)] exchange each - reli by tarr.(f-i). *) -let exchange_reli_arrayi tarr (d,f) t = - let hd,args= destApp t in - let i = destRel hd in - let res = whd_beta (mkApp (tarr.(f-i) ,args)) in - res - -let exchange_reli_arrayi_L tarr (d,f) = - List.map (exchange_reli_arrayi tarr (d,f)) - - -(* expand all letins in a term, before building the principle. *) -let rec expand_letins mimick = - match kind_of_term mimick with - | LetIn(nme,cstr1, typ, cstr) -> - let cstr' = substitterm 0 (mkRel 1) (lift 1 cstr1) cstr in - expand_letins (pop cstr') - | x -> map_constr expand_letins mimick - - -(* Valeur d'une constante, or identity *) -let def_of_const t = - match kind_of_term t with - | Const sp -> - (try - match Global.lookup_constant sp with - {const_body=Some c} -> force c - |_ -> assert false - with _ -> assert false) - | _ -> t - -(* nom d'une constante. Must be a constante. x*) -let name_of_const t = - match (kind_of_term t) with - Const cst -> Names.string_of_label (Names.con_label cst) - |_ -> assert false - ;; - - -(*i -*** Local Variables: -*** compile-command: "make -k tacinvutils.cmo" -*** test-tactic: "../../bin/coqtop -translate -q -batch -load-vernac-source ../../test-suite/success/Funind.v" -*** End: -i*) - diff --git a/contrib/funind/tacinvutils.mli b/contrib/funind/tacinvutils.mli deleted file mode 100644 index 64b21213..00000000 --- a/contrib/funind/tacinvutils.mli +++ /dev/null @@ -1,80 +0,0 @@ -(* tacinvutils.ml *) -(*s utilities *) - -(*i*) -open Termops -open Equality -open Names -open Pp -open Tacmach -open Proof_type -open Tacinterp -open Tactics -open Tacticals -open Term -open Util -open Printer -open Reductionops -open Inductiveops -open Coqlib -open Refine -open Evd -(*i*) - -(* printing debugging *) -val prconstr: constr -> unit -val prlistconstr: constr list -> unit -val prNamedConstr:string -> constr -> unit -val prNamedLConstr:string -> constr list -> unit -val prstr: string -> unit - - -val mknewmeta: unit -> constr -val mknewexist: unit -> existential -val resetmeta: unit -> unit (* safe *) -val resetexist: unit -> unit (* be careful with this one *) -val mkevarmap_from_listex: (Term.existential * Term.types) list -> evar_map -val mkEq: types -> constr -> constr -> constr -(* let mkEq typ c1 c2 = mkApp (build_coq_eq_data.eq(),[| typ; c1; c2|]) *) -val mkRefl: types -> constr -> constr -val buildrefl_from_eqs: constr list -> constr list -(* typ c1 = mkApp ((constant ["Coq"; "Init"; "Logic"] "refl_equal"), [| typ; c1|]) *) - -val nth_dep_constructor: constr -> int -> (constr*int) - -val prod_it_lift: (name*constr) list -> constr -> constr -val prod_it_anonym_lift: constr -> constr list -> constr -val lam_it_anonymous: constr -> constr list -> constr -val lift1L: (constr list) -> constr list -val popn: int -> constr -> constr -val lambda_id: constr -> constr -> constr -> constr -val prod_id: constr -> constr -> constr -> constr - - -val name_of_string : string -> name -val newname_append: name -> string -> name - -val apply_eqtrpl: constr*(constr*constr*constr) -> constr -> constr -val substitterm: int -> constr -> constr -> constr -> constr -val apply_leqtrpl_t: - constr -> (constr*(constr*constr*constr)) list -> constr -val apply_eq_leqtrpl: - (constr*(constr*constr*constr)) list -> constr -> (constr*(constr*constr*constr)) list -(* val apply_leq_lt: constr list -> constr list -> constr list *) - -val hdMatchSub: constr -> constr -> constr list -val hdMatchSub_cpl: constr -> int*int -> constr list -val exchange_hd_prod: constr -> constr -> constr -val exchange_reli_arrayi_L: constr array -> int*int -> constr list -> constr list -val substit_red: int -> constr -> constr -> constr -> constr -val expand_letins: constr -> constr - -val def_of_const: constr -> constr -val name_of_const: constr -> string - -(*i - *** Local Variables: *** - *** compile-command: "make -C ../.. contrib/funind/tacinvutils.cmi" *** - *** End: *** -i*) - diff --git a/contrib/interface/COPYRIGHT b/contrib/interface/COPYRIGHT index 2fb11c6b..23aeb6bb 100644 --- a/contrib/interface/COPYRIGHT +++ b/contrib/interface/COPYRIGHT @@ -1,8 +1,9 @@ (*****************************************************************************) (* *) -(* Coq support for the Pcoq Graphical Interface of Coq *) +(* Coq support for the Pcoq and tmEgg Graphical Interfaces of Coq *) (* *) (* Copyright (C) 1999-2004 INRIA Sophia-Antipolis (Lemme team) *) +(* Copyright (C) 2006,2007 Lionel Elie Mamane *) (* *) (*****************************************************************************) @@ -10,6 +11,9 @@ The current directory contrib/interface implements Coq support for the Pcoq Graphical Interface of Coq. It has been developed by Yves Bertot with contributions from Loïc Pottier and Laurence Rideau. +Modifications by Lionel Elie Mamane <lionel@mamane.lu> for +generalising the protocol to suit other Coq interfaces. + The Pcoq Graphical Interface (see http://www-sop.inria.fr/lemme/pcoq) is developed by the Lemme team at INRIA Sophia-Antipolis (see http://www-sop.inria.fr/lemme) diff --git a/contrib/interface/ascent.mli b/contrib/interface/ascent.mli index ef1d095e..32338523 100644 --- a/contrib/interface/ascent.mli +++ b/contrib/interface/ascent.mli @@ -113,7 +113,6 @@ and ct_COMMAND = | CT_module_type_decl of ct_ID * ct_MODULE_BINDER_LIST * ct_MODULE_TYPE_OPT | CT_no_inline of ct_ID_NE_LIST | CT_omega_flag of ct_OMEGA_MODE * ct_OMEGA_FEATURE - | CT_opaque of ct_ID_NE_LIST | CT_open_scope of ct_ID | CT_print | CT_print_about of ct_ID @@ -189,13 +188,13 @@ and ct_COMMAND = | CT_show_script | CT_show_tree | CT_solve of ct_INT * ct_TACTIC_COM * ct_DOTDOT_OPT + | CT_strategy of ct_LEVEL_LIST | CT_suspend | CT_syntax_macro of ct_ID * ct_FORMULA * ct_INT_OPT | CT_tactic_definition of ct_TAC_DEF_NE_LIST | CT_test_natural_feature of ct_NATURAL_FEATURE * ct_ID | CT_theorem_struct of ct_THEOREM_GOAL * ct_PROOF_SCRIPT | CT_time of ct_COMMAND - | CT_transparent of ct_ID_NE_LIST | CT_undo of ct_INT_OPT | CT_unfocus | CT_unset_option of ct_TABLE @@ -204,6 +203,12 @@ and ct_COMMAND = | CT_user_vernac of ct_ID * ct_VARG_LIST | CT_variable of ct_VAR * ct_BINDER_NE_LIST | CT_write_module of ct_ID * ct_STRING_OPT +and ct_LEVEL_LIST = + CT_level_list of (ct_LEVEL * ct_ID_LIST) list +and ct_LEVEL = + CT_Opaque + | CT_Level of ct_INT + | CT_Expand and ct_COMMAND_LIST = CT_command_list of ct_COMMAND * ct_COMMAND list and ct_COMMENT = diff --git a/contrib/interface/blast.ml b/contrib/interface/blast.ml index dc27cf98..6ec0fac4 100644 --- a/contrib/interface/blast.ml +++ b/contrib/interface/blast.ml @@ -151,7 +151,7 @@ let pp_string x = let unify_e_resolve (c,clenv) gls = let clenv' = connect_clenv gls clenv in let _ = clenv_unique_resolver false clenv' gls in - vernac_e_resolve_constr c gls + Hiddentac.h_simplest_eapply c gls let rec e_trivial_fail_db db_list local_db goal = let tacl = @@ -161,33 +161,36 @@ let rec e_trivial_fail_db db_list local_db goal = let d = pf_last_hyp g' in let hintl = make_resolve_hyp (pf_env g') (project g') d in (e_trivial_fail_db db_list - (Hint_db.add_list hintl local_db) g'))) :: + (add_hint_list hintl local_db) g'))) :: (List.map fst (e_trivial_resolve db_list local_db (pf_concl goal)) ) in tclFIRST (List.map tclCOMPLETE tacl) goal and e_my_find_search db_list local_db hdc concl = let hdc = head_of_constr_reference hdc in + let flags = Auto.auto_unif_flags in let hintl = if occur_existential concl then - list_map_append (Hint_db.map_all hdc) (local_db::db_list) + list_map_append (fun (st, db) -> List.map (fun x -> ({flags with Unification.modulo_delta = st}, x)) + (Hint_db.map_all hdc db)) (local_db::db_list) else - list_map_append (Hint_db.map_auto (hdc,concl)) (local_db::db_list) + list_map_append (fun (st, db) -> List.map (fun x -> ({flags with Unification.modulo_delta = st}, x)) + (Hint_db.map_auto (hdc,concl) db)) (local_db::db_list) in let tac_of_hint = - fun ({pri=b; pat = p; code=t} as _patac) -> + fun (st, ({pri=b; pat = p; code=t} as _patac)) -> (b, let tac = match t with - | Res_pf (term,cl) -> unify_resolve (term,cl) + | Res_pf (term,cl) -> unify_resolve st (term,cl) | ERes_pf (term,cl) -> unify_e_resolve (term,cl) | Give_exact (c) -> e_give_exact_constr c | Res_pf_THEN_trivial_fail (term,cl) -> tclTHEN (unify_e_resolve (term,cl)) (e_trivial_fail_db db_list local_db) - | Unfold_nth c -> unfold_in_concl [[],c] + | Unfold_nth c -> unfold_in_concl [all_occurrences,c] | Extern tacast -> Auto.conclPattern concl - (out_some p) tacast + (Option.get p) tacast in (free_try tac,fmt_autotactic t)) (*i @@ -227,8 +230,8 @@ module MySearchProblem = struct depth : int; (*r depth of search before failing *) tacres : goal list sigma * validation; last_tactic : std_ppcmds; - dblist : Auto.Hint_db.t list; - localdb : Auto.Hint_db.t list } + dblist : Auto.hint_db list; + localdb : Auto.hint_db list } let success s = (sig_it (fst s.tacres)) = [] @@ -242,9 +245,6 @@ module MySearchProblem = struct with e when Logic.catchable_exception e -> filter_tactics (glls,v) tacl - let rec list_addn n x l = - if n = 0 then l else x :: (list_addn (pred n) x l) - (* Ordering of states is lexicographic on depth (greatest first) then number of remaining goals. *) let compare s s' = @@ -279,7 +279,7 @@ module MySearchProblem = struct let hintl = make_resolve_hyp (pf_env g') (project g') (pf_last_hyp g') in - let ldb = Hint_db.add_list hintl (List.hd s.localdb) in + let ldb = add_hint_list hintl (List.hd s.localdb) in { depth = s.depth; tacres = res; last_tactic = pp; dblist = s.dblist; localdb = ldb :: List.tl s.localdb }) @@ -337,7 +337,7 @@ let e_breadth_search debug n db_list local_db gl = with Not_found -> error "EAuto: breadth first search failed" let e_search_auto debug (n,p) db_list gl = - let local_db = make_local_hint_db [] gl in + let local_db = make_local_hint_db true [] gl in if n = 0 then e_depth_search debug p db_list local_db gl else @@ -357,7 +357,7 @@ let full_eauto debug n gl = let dbnames = current_db_names () in let dbnames = list_subtract dbnames ["v62"] in let db_list = List.map searchtable_map dbnames in - let _local_db = make_local_hint_db [] gl in + let _local_db = make_local_hint_db true [] gl in tclTRY (e_search_auto debug n db_list) gl let my_full_eauto n gl = full_eauto false (n,0) gl @@ -375,7 +375,7 @@ let rec trivial_fail_db db_list local_db gl = tclTHEN intro (fun g'-> let hintl = make_resolve_hyp (pf_env g') (project g') (pf_last_hyp g') - in trivial_fail_db db_list (Hint_db.add_list hintl local_db) g') + in trivial_fail_db db_list (add_hint_list hintl local_db) g') in tclFIRST (assumption::intro_tac:: @@ -383,27 +383,29 @@ let rec trivial_fail_db db_list local_db gl = (trivial_resolve db_list local_db (pf_concl gl)))) gl and my_find_search db_list local_db hdc concl = + let flags = Auto.auto_unif_flags in let tacl = if occur_existential concl then - list_map_append (fun db -> Hint_db.map_all hdc db) (local_db::db_list) + list_map_append (fun (st, db) -> List.map (fun x -> {flags with Unification.modulo_delta = st}, x) + (Hint_db.map_all hdc db)) (local_db::db_list) else - list_map_append (fun db -> Hint_db.map_auto (hdc,concl) db) - (local_db::db_list) + list_map_append (fun (st, db) -> List.map (fun x -> {flags with Unification.modulo_delta = st}, x) + (Hint_db.map_auto (hdc,concl) db)) (local_db::db_list) in List.map - (fun ({pri=b; pat=p; code=t} as _patac) -> + (fun (st, {pri=b; pat=p; code=t} as _patac) -> (b, match t with - | Res_pf (term,cl) -> unify_resolve (term,cl) + | Res_pf (term,cl) -> unify_resolve st (term,cl) | ERes_pf (_,c) -> (fun gl -> error "eres_pf") | Give_exact c -> exact_check c | Res_pf_THEN_trivial_fail (term,cl) -> tclTHEN - (unify_resolve (term,cl)) + (unify_resolve st (term,cl)) (trivial_fail_db db_list local_db) - | Unfold_nth c -> unfold_in_concl [[],c] + | Unfold_nth c -> unfold_in_concl [all_occurrences,c] | Extern tacast -> - conclPattern concl (out_some p) tacast)) + conclPattern concl (Option.get p) tacast)) tacl and trivial_resolve db_list local_db cl = @@ -470,11 +472,12 @@ let rec search_gen decomp n db_list local_db extra_sign goal = try [make_apply_entry (pf_env g') (project g') (true,false) - (mkVar hid,body_of_type htyp)] + None + (mkVar hid,htyp)] with Failure _ -> [] in (free_try - (search_gen decomp n db_list (Hint_db.add_list hintl local_db) [d]) + (search_gen decomp n db_list (add_hint_list hintl local_db) [d]) g')) in let rec_tacs = @@ -497,7 +500,7 @@ let full_auto n gl = let dbnames = list_subtract dbnames ["v62"] in let db_list = List.map searchtable_map dbnames in let hyps = pf_hyps gl in - tclTRY (search n db_list (make_local_hint_db [] gl) hyps) gl + tclTRY (search n db_list (make_local_hint_db false [] gl) hyps) gl let default_full_auto gl = full_auto !default_search_depth gl (************************************************************************) diff --git a/contrib/interface/centaur.ml4 b/contrib/interface/centaur.ml4 index 730e055b..a4dc0eac 100644 --- a/contrib/interface/centaur.ml4 +++ b/contrib/interface/centaur.ml4 @@ -1,11 +1,28 @@ (*i camlp4deps: "parsing/grammar.cma" i*) +(* + * This file has been modified by Lionel Elie Mamane <lionel@mamane.lu> + * to implement the following features + * - Terms (optionally) as pretty-printed string and not trees + * - (Optionally) give most commands their usual Coq semantics + * - Add the backtracking information to the status message. + * in the following time period + * - May-November 2006 + * and + * - Make use of new Command.save_hook to generate dependencies at + * save-time. + * in + * - June 2007 + *) + (*Toplevel loop for the communication between Coq and Centaur *) open Names;; open Nameops;; open Util;; open Term;; open Pp;; +open Ppconstr;; +open Prettyp;; open Libnames;; open Libobject;; open Library;; @@ -43,6 +60,7 @@ open Showproof;; open Showproof_ct;; open Tacexpr;; open Vernacexpr;; +open Printer;; let pcoq_started = ref None;; @@ -51,6 +69,11 @@ let if_pcoq f a = let text_proof_flag = ref "en";; +let pcoq_history = ref true;; + +let assert_pcoq_history f a = + if !pcoq_history then f a else error "Pcoq-style history tracking deactivated";; + let current_proof_name () = try string_of_id (get_current_proof_name ()) @@ -85,10 +108,33 @@ let kill_proof_node index = History.border_length (current_proof_name());; +type vtp_tree = + | P_rl of ct_RULE_LIST + | P_r of ct_RULE + | P_s_int of ct_SIGNED_INT_LIST + | P_pl of ct_PREMISES_LIST + | P_cl of ct_COMMAND_LIST + | P_t of ct_TACTIC_COM + | P_text of ct_TEXT + | P_ids of ct_ID_LIST;; + +let print_tree t = + (match t with + | P_rl x -> fRULE_LIST x + | P_r x -> fRULE x + | P_s_int x -> fSIGNED_INT_LIST x + | P_pl x -> fPREMISES_LIST x + | P_cl x -> fCOMMAND_LIST x + | P_t x -> fTACTIC_COM x + | P_text x -> fTEXT x + | P_ids x -> fID_LIST x) + ++ (str "e\nblabla\n");; + + (*Message functions, the text of these messages is recognized by the protocols *) (*of CtCoq *) let ctf_header message_name request_id = - fnl () ++ str "message" ++ fnl() ++ str message_name ++ fnl() ++ + str "message" ++ fnl() ++ str message_name ++ fnl() ++ int request_id ++ fnl();; let ctf_acknowledge_command request_id command_count opt_exn = @@ -97,14 +143,20 @@ let ctf_acknowledge_command request_id command_count opt_exn = let g_count = List.length (fst (frontier (proof_of_pftreestate (get_pftreestate ())))) in - g_count, (min g_count !current_goal_index) + g_count, !current_goal_index else - (0, 0) in + (0, 0) + and statnum = Lib.current_command_label () + and dpth = let d = Pfedit.current_proof_depth() in if d >= 0 then d else 0 + and pending = CT_id_list (List.map xlate_ident (Pfedit.get_all_proof_names())) in (ctf_header "acknowledge" request_id ++ int command_count ++ fnl() ++ int goal_count ++ fnl () ++ int goal_index ++ fnl () ++ str (current_proof_name()) ++ fnl() ++ + int statnum ++ fnl() ++ + print_tree (P_ids pending) ++ + int dpth ++ fnl() ++ (match opt_exn with Some e -> Cerrors.explain_exn e | None -> mt ()) ++ fnl() ++ str "E-n-d---M-e-s-s-a-g-e" ++ fnl ());; @@ -126,6 +178,8 @@ let ctf_PathGoalMessage () = let ctf_GoalReqIdMessage = ctf_header "single_goal_state";; +let ctf_GoalsReqIdMessage = ctf_header "goals_state";; + let ctf_NewStateMessage = ctf_header "fresh_state";; let ctf_SavedMessage () = fnl () ++ str "message" ++ fnl () ++ @@ -153,39 +207,16 @@ let ctf_ResetIdentMessage request_id s = ctf_header "reset_ident" request_id ++ str s ++ fnl () ++ str "E-n-d---M-e-s-s-a-g-e" ++ fnl();; -type vtp_tree = - | P_rl of ct_RULE_LIST - | P_r of ct_RULE - | P_s_int of ct_SIGNED_INT_LIST - | P_pl of ct_PREMISES_LIST - | P_cl of ct_COMMAND_LIST - | P_t of ct_TACTIC_COM - | P_text of ct_TEXT - | P_ids of ct_ID_LIST;; - -let print_tree t = - (match t with - | P_rl x -> fRULE_LIST x - | P_r x -> fRULE x - | P_s_int x -> fSIGNED_INT_LIST x - | P_pl x -> fPREMISES_LIST x - | P_cl x -> fCOMMAND_LIST x - | P_t x -> fTACTIC_COM x - | P_text x -> fTEXT x - | P_ids x -> fID_LIST x); - print_string "e\nblabla\n";; - - let break_happened = ref false;; let output_results stream vtp_tree = let _ = Sys.signal Sys.sigint (Sys.Signal_handle(fun i -> (break_happened := true;()))) in - msg stream; - match vtp_tree with - Some t -> print_tree t - | None -> ();; + msg (stream ++ + (match vtp_tree with + Some t -> print_tree t + | None -> mt()));; let output_results_nl stream = let _ = Sys.signal Sys.sigint @@ -221,20 +252,18 @@ let print_past_goal index = let show_nth n = try - let pf = proof_of_pftreestate (get_pftreestate()) in - if (!text_proof_flag<>"off") then - (if n=0 - then output_results (ctf_TextMessage !global_request_id) - (Some (P_text (show_proof !text_proof_flag []))) - else - let path = History.get_nth_open_path (current_proof_name()) n in - output_results (ctf_TextMessage !global_request_id) - (Some (P_text (show_proof !text_proof_flag path)))) - else - output_results (ctf_GoalReqIdMessage !global_request_id) - (let goal = List.nth (fst (frontier pf)) - (n - 1) in - (Some (P_r (translate_goal goal)))) + output_results (ctf_GoalReqIdMessage !global_request_id + ++ pr_nth_open_subgoal n) + None + with + | Invalid_argument s -> + error "No focused proof (No proof-editing in progress)";; + +let show_subgoals () = + try + output_results (ctf_GoalReqIdMessage !global_request_id + ++ pr_open_subgoals ()) + None with | Invalid_argument s -> error "No focused proof (No proof-editing in progress)";; @@ -275,39 +304,24 @@ let ctf_EmptyGoalMessage id = fnl () ++ str "Empty Goal is a no-op. Fun oh fun." ++ fnl ();; -let print_check judg = - let {uj_val=value; uj_type=typ} = judg in - let value_ct_ast = - (try translate_constr false (Global.env()) value - with UserError(f,str) -> - raise(UserError(f,Printer.pr_lconstr value ++ - fnl () ++ str ))) in - let type_ct_ast = - (try translate_constr false (Global.env()) typ - with UserError(f,str) -> - raise(UserError(f, Printer.pr_lconstr value ++ fnl() ++ str))) in - ((ctf_SearchResults !global_request_id), - (Some (P_pl - (CT_premises_list - [CT_coerce_TYPED_FORMULA_to_PREMISE - (CT_typed_formula(value_ct_ast,type_ct_ast) - )]))));; - -let ct_print_eval ast red_fun env judg = -((if refining() then traverse_to []); -let {uj_val=value; uj_type=typ} = judg in -let nvalue = red_fun value -(* // Attention , ici il faut peut être utiliser des environnemenst locaux *) -and ntyp = nf_betaiota typ in -(ctf_SearchResults !global_request_id, - Some (P_pl - (CT_premises_list - [CT_eval_result - (xlate_formula ast, - translate_constr false env nvalue, - translate_constr false env ntyp)]))));; - - +let print_check env judg = + ((ctf_SearchResults !global_request_id) ++ + print_judgment env judg, + None);; + +let ct_print_eval red_fun env evmap ast judg = + (if refining() then traverse_to []); + let {uj_val=value; uj_type=typ} = judg in + let nvalue = (red_fun env evmap) value + (* // Attention , ici il faut peut être utiliser des environnemenst locaux *) + and ntyp = nf_betaiota typ in + print_tree + (P_pl + (CT_premises_list + [CT_eval_result + (xlate_formula ast, + translate_constr false env nvalue, + translate_constr false env ntyp)]));; let pbp_tac_pcoq = pbp_tac (function (x:raw_tactic_expr) -> @@ -330,6 +344,7 @@ let dad_tac_pcoq = </cpa> *) let search_output_results () = + (* LEM: See comments for pcoq_search *) output_results (ctf_SearchResults !global_request_id) (Some (P_pl (CT_premises_list @@ -393,7 +408,7 @@ let inspect n = oname, Lib.Leaf lobj -> (match oname, object_tag lobj with (sp,_), "VARIABLE" -> - let (_, _, v) = get_variable (basename sp) in + let (_, _, v) = Global.lookup_named (basename sp) in add_search2 (Nametab.locate (qualid_of_sp sp)) v | (sp,kn), "CONSTANT" -> let typ = Typeops.type_of_constant (Global.env()) (constant_of_kn kn) in @@ -491,19 +506,19 @@ VERNAC COMMAND EXTEND OutputGoal END VERNAC COMMAND EXTEND OutputGoal - [ "Goal" "Cmd" natural(n) "with" tactic(tac) ] -> [ simulate_solve n tac ] + [ "Goal" "Cmd" natural(n) "with" tactic(tac) ] -> [ assert_pcoq_history (simulate_solve n) tac ] END VERNAC COMMAND EXTEND KillProofAfter -| [ "Kill" "Proof" "after" natural(n) ] -> [ kill_node_verbose n ] +| [ "Kill" "Proof" "after" natural(n) ] -> [ assert_pcoq_history kill_node_verbose n ] END VERNAC COMMAND EXTEND KillProofAt -| [ "Kill" "Proof" "at" natural(n) ] -> [ kill_node_verbose n ] +| [ "Kill" "Proof" "at" natural(n) ] -> [ assert_pcoq_history kill_node_verbose n ] END VERNAC COMMAND EXTEND KillSubProof - [ "Kill" "SubProof" natural(n) ] -> [ logical_kill n ] + [ "Kill" "SubProof" natural(n) ] -> [ assert_pcoq_history logical_kill n ] END VERNAC COMMAND EXTEND PcoqReset @@ -515,18 +530,17 @@ VERNAC COMMAND EXTEND PcoqResetInitial END let start_proof_hook () = - History.start_proof (current_proof_name()); + if !pcoq_history then History.start_proof (current_proof_name()); current_goal_index := 1 let solve_hook n = - let name = current_proof_name () in - let old_n_count = History.border_length name in - let pf = proof_of_pftreestate (get_pftreestate ()) in - let n_goals = (List.length (fst (frontier pf))) + 1 - old_n_count in - begin - current_goal_index := n; - History.push_command name n n_goals - end + current_goal_index := n; + if !pcoq_history then + let name = current_proof_name () in + let old_n_count = History.border_length name in + let pf = proof_of_pftreestate (get_pftreestate ()) in + let n_goals = (List.length (fst (frontier pf))) + 1 - old_n_count in + History.push_command name n n_goals let abort_hook s = output_results_nl (ctf_AbortedMessage !global_request_id s) @@ -535,6 +549,12 @@ let interp_search_about_item = function | SearchString s -> GlobSearchString s let pcoq_search s l = + (* LEM: I don't understand why this is done in this way (redoing the + * match on s here) instead of making the code in + * parsing/search.ml call the right function instead of + * "plain_display". Investigates this later. + * TODO + *) ctv_SEARCH_LIST:=[]; begin match s with | SearchAbout sl -> @@ -581,27 +601,25 @@ let hyp_search_pattern c l = (Some (P_pl (CT_premises_list (List.rev !ctv_SEARCH_LIST))));; let pcoq_print_name ref = - let results = xlate_vernac_list (name_to_ast ref) in output_results - (fnl () ++ str "message" ++ fnl () ++ str "PRINT_VALUE" ++ fnl ()) - (Some (P_cl results)) + (fnl () ++ str "message" ++ fnl () ++ str "PRINT_VALUE" ++ fnl () ++ print_name ref ) + None -let pcoq_print_check j = - let a,b = print_check j in output_results a b +let pcoq_print_check env j = + let a,b = print_check env j in output_results a b -let pcoq_print_eval redfun env c j = - let strm, vtp = ct_print_eval c redfun env j in - output_results strm vtp;; +let pcoq_print_eval redfun env evmap c j = + output_results + (ctf_SearchResults !global_request_id + ++ Prettyp.print_eval redfun env evmap c j) + None;; open Vernacentries let pcoq_show_goal = function | Some n -> show_nth n - | None -> - if !pcoq_started = Some true (* = debug *) then - msg (Printer.pr_open_subgoals ()) - else errorlabstrm "show_goal" - (str "Show must be followed by an integer in Centaur mode");; + | None -> show_subgoals () +;; let pcoq_hook = { start_proof = start_proof_hook; @@ -614,6 +632,165 @@ let pcoq_hook = { show_goal = pcoq_show_goal } +let pcoq_term_pr = { + pr_constr_expr = (fun c -> str "pcoq_constr_expr\n" ++ (default_term_pr.pr_constr_expr c)); + (* In future translate_constr false (Global.env()) + * Except with right bool/env which I'll get :) + *) + pr_lconstr_expr = (fun c -> fFORMULA (xlate_formula c) ++ str "(pcoq_lconstr_expr of " ++ (default_term_pr.pr_lconstr_expr c) ++ str ")"); + pr_pattern_expr = (fun c -> str "pcoq_pattern_expr\n" ++ (default_term_pr.pr_pattern_expr c)); + pr_lpattern_expr = (fun c -> str "pcoq_constr_expr\n" ++ (default_term_pr.pr_lpattern_expr c)) +} + +let start_pcoq_trees () = + set_term_pr pcoq_term_pr + +(* BEGIN functions for object_pr *) + +(* These functions in general mirror what name_to_ast does in a subcase, + and then print the corresponding object as a PCoq tree. *) + +let object_to_ast_template object_to_ast_list sp = + let l = object_to_ast_list sp in + VernacList (List.map (fun x -> (dummy_loc, x)) l) + +let pcoq_print_object_template object_to_ast_list sp = + let results = xlate_vernac_list (object_to_ast_template object_to_ast_list sp) in + print_tree (P_cl results) + +(* This function mirror what print_check does *) + +let pcoq_print_typed_value_in_env env (value, typ) = + let value_ct_ast = + (try translate_constr false (Global.env()) value + with UserError(f,str) -> + raise(UserError(f,Printer.pr_lconstr value ++ + fnl () ++ str ))) in + let type_ct_ast = + (try translate_constr false (Global.env()) typ + with UserError(f,str) -> + raise(UserError(f, Printer.pr_lconstr value ++ fnl() ++ str))) in + print_tree + (P_pl + (CT_premises_list + [CT_coerce_TYPED_FORMULA_to_PREMISE + (CT_typed_formula(value_ct_ast,type_ct_ast) + )])) +;; + +(* This function mirrors what show_nth does *) + +let pcoq_pr_subgoal n gl = + try + print_tree + (if (!text_proof_flag<>"off") then + (* This is a horrendeous hack; it ignores the "gl" argument + and just takes the currently focused proof. This will bite + us back one day. + TODO: Fix this. + *) + ( + if not !pcoq_history then error "Text mode requires Pcoq history tracking."; + if n=0 + then (P_text (show_proof !text_proof_flag [])) + else + let path = History.get_nth_open_path (current_proof_name()) n in + (P_text (show_proof !text_proof_flag path))) + else + (let goal = List.nth gl (n - 1) in + (P_r (translate_goal goal)))) + with + | Invalid_argument _ + | Failure "nth" + | Not_found -> error "No such goal";; + +let pcoq_pr_subgoals close_cmd evar gl = + (*LEM: TODO: we should check for evar emptiness or not, and do something *) + try + print_tree + (if (!text_proof_flag<>"off") then + raise (Anomaly ("centaur.ml4:pcoq_pr_subgoals", str "Text mode show all subgoals not implemented")) + else + (P_rl (translate_goals gl))) + with + | Invalid_argument _ + | Failure "nth" + | Not_found -> error "No such goal";; + + +(* END functions for object_pr *) + +let pcoq_object_pr = { + print_inductive = pcoq_print_object_template inductive_to_ast_list; + (* TODO: Check what that with_infos means, and adapt accordingly *) + print_constant_with_infos = pcoq_print_object_template constant_to_ast_list; + print_section_variable = pcoq_print_object_template variable_to_ast_list; + print_syntactic_def = pcoq_print_object_template (fun x -> errorlabstrm "print" + (str "printing of syntax definitions not implemented in PCoq syntax")); + (* TODO: These are placeholders only; write them *) + print_module = (fun x y -> str "pcoq_print_module not implemented"); + print_modtype = (fun x -> str "pcoq_print_modtype not implemented"); + print_named_decl = (fun x -> str "pcoq_print_named_decl not implemented"); + (* TODO: Find out what the first argument x (a bool) is about and react accordingly *) + print_leaf_entry = (fun x -> pcoq_print_object_template leaf_entry_to_ast_list); + print_library_entry = (fun x y -> Some (str "pcoq_print_library_entry not implemented")); + print_context = (fun x y z -> str "pcoq_print_context not implemented"); + print_typed_value_in_env = pcoq_print_typed_value_in_env; + Prettyp.print_eval = ct_print_eval; +};; + +let pcoq_printer_pr = { + pr_subgoals = pcoq_pr_subgoals; + pr_subgoal = pcoq_pr_subgoal; + pr_goal = (fun x -> str "pcoq_pr_goal not implemented"); +};; + + +let start_pcoq_objects () = + set_object_pr pcoq_object_pr; + set_printer_pr pcoq_printer_pr + +let start_default_objects () = + set_object_pr default_object_pr; + set_printer_pr default_printer_pr + +let full_name_of_ref r = + (match r with + | VarRef _ -> str "VAR" + | ConstRef _ -> str "CST" + | IndRef _ -> str "IND" + | ConstructRef _ -> str "CSR") + ++ str " " ++ (pr_sp (Nametab.sp_of_global r)) + (* LEM TODO: Cleanly separate path from id (see Libnames.string_of_path) *) + +let string_of_ref = + (*LEM TODO: Will I need the Var/Const/Ind/Construct info?*) + Depends.o Libnames.string_of_path Nametab.sp_of_global + +let print_depends compute_depends ptree = + output_results (List.fold_left (fun x y -> x ++ (full_name_of_ref y) ++ fnl()) + (str "This object depends on:" ++ fnl()) + (compute_depends ptree)) + None + +let output_depends compute_depends ptree = + (* Using an ident list for that is arguably stretching it, but less effort than touching the vtp types *) + output_results (ctf_header "depends" !global_request_id ++ + print_tree (P_ids (CT_id_list (List.map + (fun x -> CT_ident (string_of_ref x)) + (compute_depends ptree))))) + None + +let gen_start_depends_dumps print_depends print_depends' print_depends'' print_depends''' = + Command.set_declare_definition_hook (print_depends' (Depends.depends_of_definition_entry ~acc:[])); + Command.set_declare_assumption_hook (print_depends (fun (c:types) -> Depends.depends_of_constr c [])); + Command.set_start_hook (print_depends (fun c -> Depends.depends_of_constr c [])); + Command.set_save_hook (print_depends'' (Depends.depends_of_pftreestate Depends.depends_of_pftree)); + Refiner.set_solve_hook (print_depends''' (fun pt -> Depends.depends_of_pftree_head pt [])) + +let start_depends_dumps () = gen_start_depends_dumps output_depends output_depends output_depends output_depends + +let start_depends_dumps_debug () = gen_start_depends_dumps print_depends print_depends print_depends print_depends TACTIC EXTEND pbp | [ "pbp" ident_opt(idopt) natural_list(nl) ] -> @@ -635,7 +812,6 @@ let start_pcoq_mode debug = (* <\cpa> start_dad(); </cpa> *) - declare_in_coq(); (* The following ones are added to enable rich comments in pcoq *) (* TODO ... add_tactic "Image" (fun _ -> tclIDTAC); @@ -649,6 +825,8 @@ let start_pcoq_mode debug = List.iter (fun (a,b) -> overwriting_vinterp_add a b) non_debug_changes; *) set_pcoq_hook pcoq_hook; + start_pcoq_objects(); + Flags.print_emacs := false; Pp.make_pp_nonemacs(); end;; @@ -681,3 +859,23 @@ END VERNAC COMMAND EXTEND StartPcoqDebug | [ "Start" "Pcoq" "Debug" "Mode" ] -> [ start_pcoq_debug () ] END + +VERNAC COMMAND EXTEND StartPcoqTerms +| [ "Start" "Pcoq" "Trees" ] -> [ start_pcoq_trees () ] +END + +VERNAC COMMAND EXTEND StartPcoqObjects +| [ "Start" "Pcoq" "Objects" ] -> [ start_pcoq_objects () ] +END + +VERNAC COMMAND EXTEND StartDefaultObjects +| [ "Start" "Default" "Objects" ] -> [ start_default_objects () ] +END + +VERNAC COMMAND EXTEND StartDependencyDumps +| [ "Start" "Dependency" "Dumps" ] -> [ start_depends_dumps () ] +END + +VERNAC COMMAND EXTEND StopPcoqHistory +| [ "Stop" "Pcoq" "History" ] -> [ pcoq_history := false ] +END diff --git a/contrib/interface/debug_tac.ml4 b/contrib/interface/debug_tac.ml4 index 890bb3ce..aad3a765 100644 --- a/contrib/interface/debug_tac.ml4 +++ b/contrib/interface/debug_tac.ml4 @@ -113,7 +113,7 @@ let count_subgoals2 let rec local_interp : glob_tactic_expr -> report_holder -> tactic = function TacThens (a,l) -> (fun report_holder -> checked_thens report_holder a l) - | TacThen (a,b) -> + | TacThen (a,[||],b,[||]) -> (fun report_holder -> checked_then report_holder a b) | t -> (fun report_holder g -> @@ -279,7 +279,7 @@ let rec reconstruct_success_tac (tac:glob_tactic_expr) = | Failed n -> TacId [] | Tree_fail r -> reconstruct_success_tac a r | Mismatch (n,p) -> a) - | TacThen (a,b) -> + | TacThen (a,[||],b,[||]) -> (function Report_node(true, n, l) -> tac | Report_node(false, n, rl) -> @@ -340,7 +340,7 @@ Tacinterp.add_tactic "OnThen" on_then;; let rec clean_path tac l = match tac, l with - | TacThen (a,b), fst::tl -> + | TacThen (a,[||],b,[||]), fst::tl -> fst::(clean_path (if fst = 1 then a else b) tl) | TacThens (a,l), 1::tl -> 1::(clean_path a tl) @@ -390,7 +390,7 @@ let rec report_error | t::tl -> (report_error t the_goal the_ast returned_path (n::2::path)):: (fold_num (n + 1) tl) in fold_num 1 l) - | TacThen (a,b) -> + | TacThen (a,[||],b,[||]) -> let the_count = ref 1 in tclTHEN (fun g -> @@ -398,7 +398,7 @@ let rec report_error report_error a the_goal the_ast returned_path (1::path) g with e -> - (the_ast := TacThen (!the_ast, b); + (the_ast := TacThen (!the_ast,[||], b,[||]); raise e)) (fun g -> try diff --git a/contrib/interface/depends.ml b/contrib/interface/depends.ml new file mode 100644 index 00000000..dd40c5cc --- /dev/null +++ b/contrib/interface/depends.ml @@ -0,0 +1,454 @@ +(************************************************************************) +(* v * The Coq Proof Assistant *) +(* <O___,, * *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1, *) +(* * or (at your option) any later version. *) +(************************************************************************) + +(* Copyright © 2007, Lionel Elie Mamane <lionel@mamane.lu> *) + +(* This is distributed in the hope that it will be useful, *) +(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) +(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU *) +(* Lesser General Public License for more details. *) + +(* You should have received a copy of the GNU Lesser General Public *) +(* License along with this library; if not, write to the Free Software *) +(* Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, *) +(* MA 02110-1301, USA *) + + +(* LEM TODO: a .mli file *) + +open Refiner +open Proof_type +open Rawterm +open Term +open Libnames +open Util +open Tacexpr +open Entries + +(* DBG utilities, to be removed *) +let print_bool b = print_string (string_of_bool b) +let string_of_ppcmds p = Pp.pp_with Format.str_formatter p; Format.flush_str_formatter() +let acc_str f = List.fold_left (fun a b -> a ^ (f b) ^ "+") "O" +(* End utilities, to be removed *) + +let explore_tree pfs = + print_string "explore_tree called\n"; + print_string "pfs is a top: "; + (* We expect yes. *) + print_string (if (is_top_pftreestate pfs) then "yes" else "no"); + print_newline(); + let rec explain_tree (pt:proof_tree) = + match pt.ref with + | None -> "none" + | Some (Prim p, l) -> "<Prim (" ^ (explain_prim p) ^ ") | " ^ (acc_str explain_tree l) ^ ">" + | Some (Nested (t,p), l) -> "<Nested (" ^ explain_compound t ^ ", " ^ (explain_tree p) ^ ") | " ^ (acc_str explain_tree l) ^ ">" + | Some (Decl_proof _, _) -> "Decl_proof" + | Some (Daimon, _) -> "Daimon" + and explain_compound cr = + match cr with + | Tactic (texp, b) -> "Tactic (" ^ (string_of_ppcmds (Tactic_printer.pr_tactic texp)) ^ ", " ^ (string_of_bool b) ^ ")" + | Proof_instr (b, instr) -> "Proof_instr (" ^ (string_of_bool b) ^ (string_of_ppcmds (Tactic_printer.pr_proof_instr instr)) ^ ")" + and explain_prim = function + | Refine c -> "Refine " ^ (string_of_ppcmds (Printer.prterm c)) + | Intro identifier -> "Intro" + | Intro_replacing identifier -> "Intro_replacing" + | Cut (bool, identifier, types) -> "Cut" + | FixRule (identifier, int, l) -> "FixRule" + | Cofix (identifier, l) -> "Cofix" + | Convert_concl (types, cast_kind) -> "Convert_concl" + | Convert_hyp named_declaration -> "Convert_hyp" + | Thin identifier_list -> "Thin" + | ThinBody identifier_list -> "ThinBody" + | Move (bool, identifier, identifier') -> "Move" + | Rename (identifier, identifier') -> "Rename" + | Change_evars -> "Change_evars" + in + let pt = proof_of_pftreestate pfs in + (* We expect 0 *) + print_string "Number of open subgoals: "; + print_int pt.open_subgoals; + print_newline(); + print_string "First rule is a "; + print_string (explain_tree pt); + print_newline() + + +let o f g x = f (g x) +let fst_of_3 (x, _, _) = x +let snd_of_3 (_, x, _) = x +let trd_of_3 (_, _, x) = x + +(* TODO: These for now return a Libnames.global_reference, but a + prooftree will also depend on things like tactic declarations, etc + so we may need a new type for that. *) +let rec depends_of_hole_kind hk acc = match hk with + | Evd.ImplicitArg (gr,_) -> gr::acc + | Evd.TomatchTypeParameter (ind, _) -> (IndRef ind)::acc + | Evd.BinderType _ + | Evd.QuestionMark _ + | Evd.CasesType + | Evd.InternalHole + | Evd.GoalEvar + | Evd.ImpossibleCase -> acc + +let depends_of_'a_cast_type depends_of_'a act acc = match act with + | CastConv (ck, a) -> depends_of_'a a acc + | CastCoerce -> acc + +let depends_of_'a_bindings depends_of_'a ab acc = match ab with + | ImplicitBindings al -> list_union_map depends_of_'a al acc + | ExplicitBindings apl -> list_union_map (fun x y -> depends_of_'a (trd_of_3 x) y) apl acc + | NoBindings -> acc + +let depends_of_'a_with_bindings depends_of_'a (a, ab) acc = + depends_of_'a a (depends_of_'a_bindings depends_of_'a ab acc) + +(* let depends_of_constr_with_bindings = depends_of_'a_with_bindings depends_of_constr *) +(* and depends_of_open_constr_with_bindings = depends_of_'a_with_bindings depends_of_open_let *) + +let depends_of_'a_induction_arg depends_of_'a aia acc = match aia with + | ElimOnConstr a -> depends_of_'a a acc + | ElimOnIdent _ -> + (* TODO: Check that this really refers only to an hypothesis (not a section variable, etc.) + * It *seems* thaat section variables are seen as hypotheses, so we have a problem :-( + + * Plan: Load all section variables before anything in that + * section and call the user's proof script "brittle" and refuse + * to handle if it breaks because of that + *) + acc + | ElimOnAnonHyp _ -> acc + +let depends_of_'a_or_var depends_of_'a aov acc = match aov with + | ArgArg a -> depends_of_'a a acc + | ArgVar _ -> acc + +let depends_of_'a_with_occurences depends_of_'a (_,a) acc = + depends_of_'a a acc + +let depends_of_'a_'b_red_expr_gen depends_of_'a reg acc = match reg with + (* TODO: dirty assumption that the 'b doesn't make any dependency *) + | Red _ + | Hnf + | Cbv _ + | Lazy _ + | Unfold _ + | ExtraRedExpr _ + | CbvVm -> acc + | Simpl awoo -> + Option.fold_right + (depends_of_'a_with_occurences depends_of_'a) + awoo + acc + | Fold al -> list_union_map depends_of_'a al acc + | Pattern awol -> + list_union_map + (depends_of_'a_with_occurences depends_of_'a) + awol + acc + +let depends_of_'a_'b_inversion_strength depends_of_'a is acc = match is with + (* TODO: dirty assumption that the 'b doesn't make any dependency *) + | NonDepInversion _ -> acc + | DepInversion (_, ao, _) -> Option.fold_right depends_of_'a ao acc + | InversionUsing (a, _) -> depends_of_'a a acc + +let depends_of_'a_pexistential depends_of_'a (_, aa) acc = array_union_map depends_of_'a aa acc + +let depends_of_named_vals nvs acc = + (* TODO: I'm stopping here because I have noooo idea what to do with values... *) + acc + +let depends_of_inductive ind acc = (IndRef ind)::acc + +let rec depends_of_constr c acc = match kind_of_term c with + | Rel _ -> acc + | Var id -> (VarRef id)::acc + | Meta _ -> acc + | Evar ev -> depends_of_'a_pexistential depends_of_constr ev acc + | Sort _ -> acc + | Cast (c, _, t) -> depends_of_constr c (depends_of_constr t acc) + | Prod (_, t, t') -> depends_of_constr t (depends_of_constr t' acc) + | Lambda (_, t, c) -> depends_of_constr t (depends_of_constr c acc) + | LetIn (_, c, t, c') -> depends_of_constr c (depends_of_constr t (depends_of_constr c' acc)) + | App (c, ca) -> depends_of_constr c (array_union_map depends_of_constr ca acc) + | Const cnst -> (ConstRef cnst)::acc + | Ind ind -> (IndRef ind)::acc + | Construct cons -> (ConstructRef cons)::acc + | Case (_, c, c', ca) -> depends_of_constr c (depends_of_constr c' (array_union_map depends_of_constr ca acc)) + | Fix (_, (_, ta, ca)) + | CoFix (_, (_, ta, ca)) -> array_union_map depends_of_constr ca (array_union_map depends_of_constr ta acc) +and depends_of_evar_map evm acc = + Evd.fold (fun ev evi -> depends_of_evar_info evi) evm acc +and depends_of_evar_info evi acc = + (* TODO: evi.evar_extra contains a dynamic... Figure out what to do with it. *) + depends_of_constr evi.Evd.evar_concl (depends_of_evar_body evi.Evd.evar_body (depends_of_named_context_val evi.Evd.evar_hyps acc)) +and depends_of_evar_body evb acc = match evb with + | Evd.Evar_empty -> acc + | Evd.Evar_defined c -> depends_of_constr c acc +and depends_of_named_context nc acc = list_union_map depends_of_named_declaration nc acc +and depends_of_named_context_val ncv acc = + depends_of_named_context (Environ.named_context_of_val ncv) (depends_of_named_vals (Environ.named_vals_of_val ncv) acc) +and depends_of_named_declaration (_,co,t) acc = depends_of_constr t (Option.fold_right depends_of_constr co acc) + + + +let depends_of_open_constr (evm,c) acc = + depends_of_constr c (depends_of_evar_map evm acc) + +let rec depends_of_rawconstr rc acc = match rc with + | RRef (_,r) -> r::acc + | RVar (_, id) -> (VarRef id)::acc + | REvar (_, _, rclo) -> Option.fold_right depends_of_rawconstr_list rclo acc + | RPatVar _ -> acc + | RApp (_, rc, rcl) -> depends_of_rawconstr rc (depends_of_rawconstr_list rcl acc) + | RLambda (_, _, _, rct, rcb) + | RProd (_, _, _, rct, rcb) + | RLetIn (_, _, rct, rcb) -> depends_of_rawconstr rcb (depends_of_rawconstr rct acc) + | RCases (_, _, rco, tmt, cc) -> + (* LEM TODO: handle the cc *) + (Option.fold_right depends_of_rawconstr rco + (list_union_map + (fun (rc, pp) acc -> + Option.fold_right (fun (_,ind,_,_) acc -> (IndRef ind)::acc) (snd pp) + (depends_of_rawconstr rc acc)) + tmt + acc)) + | RLetTuple (_,_,(_,rco),rc0,rc1) -> + depends_of_rawconstr rc1 (depends_of_rawconstr rc0 (Option.fold_right depends_of_rawconstr rco acc)) + | RIf (_, rcC, (_, rco), rcT, rcF) -> let dorc = depends_of_rawconstr in + dorc rcF (dorc rcT (dorc rcF (dorc rcC (Option.fold_right dorc rco acc)))) + | RRec (_, _, _, rdla, rca0, rca1) -> let dorca = array_union_map depends_of_rawconstr in + dorca rca0 (dorca rca1 (array_union_map + (list_union_map (fun (_,_,rco,rc) acc -> depends_of_rawconstr rc (Option.fold_right depends_of_rawconstr rco acc))) + rdla + acc)) + | RSort _ -> acc + | RHole (_, hk) -> depends_of_hole_kind hk acc + | RCast (_, rc, rcct) -> depends_of_rawconstr rc (depends_of_'a_cast_type depends_of_rawconstr rcct acc) + | RDynamic (_, dyn) -> failwith "Depends of a dyn not implemented yet" (* TODO: figure out how these dyns are used*) +and depends_of_rawconstr_list l = list_union_map depends_of_rawconstr l + +let depends_of_rawconstr_and_expr (rc, _) acc = + (* TODO Le constr_expr représente le même terme que le rawconstr. Vérifier ça. *) + depends_of_rawconstr rc acc + +let rec depends_of_gen_tactic_expr depends_of_'constr depends_of_'ind depends_of_'tac = + (* TODO: + * Dirty assumptions that the 'id, 'cst, 'ref don't generate dependencies + *) + let rec depends_of_tacexpr texp acc = match texp with + | TacAtom (_, atexpr) -> depends_of_atomic_tacexpr atexpr acc + | TacThen (tac0, taca0, tac1, taca1) -> + depends_of_tacexpr tac0 (array_union_map depends_of_tacexpr taca0 (depends_of_tacexpr tac1 (array_union_map depends_of_tacexpr taca1 acc))) + | TacThens (tac, tacl) -> + depends_of_tacexpr tac (list_union_map depends_of_tacexpr tacl acc) + | TacFirst tacl -> list_union_map depends_of_tacexpr tacl acc + | TacComplete tac -> depends_of_tacexpr tac acc + | TacSolve tacl -> list_union_map depends_of_tacexpr tacl acc + | TacTry tac -> depends_of_tacexpr tac acc + | TacOrelse (tac0, tac1) -> depends_of_tacexpr tac0 (depends_of_tacexpr tac1 acc) + | TacDo (_, tac) -> depends_of_tacexpr tac acc + | TacRepeat tac -> depends_of_tacexpr tac acc + | TacProgress tac -> depends_of_tacexpr tac acc + | TacAbstract (tac, _) -> depends_of_tacexpr tac acc + | TacId _ + | TacFail _ -> acc + | TacInfo tac -> depends_of_tacexpr tac acc + | TacLetIn (_, igtal, tac) -> + depends_of_tacexpr + tac + (list_union_map + (fun x y -> depends_of_tac_arg (snd x) y) + igtal + acc) + | TacMatch (_, tac, tacexpr_mrl) -> failwith "depends_of_tacexpr of a Match not implemented yet" + | TacMatchContext (_, _, tacexpr_mrl) -> failwith "depends_of_tacexpr of a Match Context not implemented yet" + | TacFun tacfa -> depends_of_tac_fun_ast tacfa acc + | TacArg tacarg -> depends_of_tac_arg tacarg acc + and depends_of_atomic_tacexpr atexpr acc = let depends_of_'constr_with_bindings = depends_of_'a_with_bindings depends_of_'constr in match atexpr with + (* Basic tactics *) + | TacIntroPattern _ + | TacIntrosUntil _ + | TacIntroMove _ + | TacAssumption -> acc + | TacExact c + | TacExactNoCheck c + | TacVmCastNoCheck c -> depends_of_'constr c acc + | TacApply (_, _, cb) -> depends_of_'constr_with_bindings cb acc + | TacElim (_, cwb, cwbo) -> + depends_of_'constr_with_bindings cwb + (Option.fold_right depends_of_'constr_with_bindings cwbo acc) + | TacElimType c -> depends_of_'constr c acc + | TacCase (_, cb) -> depends_of_'constr_with_bindings cb acc + | TacCaseType c -> depends_of_'constr c acc + | TacFix _ + | TacMutualFix _ + | TacCofix _ + | TacMutualCofix _ -> failwith "depends_of_atomic_tacexpr of a Tac(Mutual)(Co)Fix not implemented yet" + | TacCut c -> depends_of_'constr c acc + | TacAssert (taco, _, c) -> + Option.fold_right depends_of_'tac taco (depends_of_'constr c acc) + | TacGeneralize cl -> + list_union_map depends_of_'constr (List.map (fun ((_,c),_) -> c) cl) + acc + | TacGeneralizeDep c -> depends_of_'constr c acc + | TacLetTac (_,c,_,_) -> depends_of_'constr c acc + + (* Derived basic tactics *) + | TacSimpleInduction _ + | TacSimpleDestruct _ + | TacDoubleInduction _ -> acc + | TacNewInduction (_, cwbial, cwbo, _, _) + | TacNewDestruct (_, cwbial, cwbo, _, _) -> + list_union_map (depends_of_'a_induction_arg depends_of_'constr_with_bindings) + cwbial + (Option.fold_right depends_of_'constr_with_bindings cwbo acc) + | TacDecomposeAnd c + | TacDecomposeOr c -> depends_of_'constr c acc + | TacDecompose (il, c) -> depends_of_'constr c (list_union_map depends_of_'ind il acc) + | TacSpecialize (_,cwb) -> depends_of_'constr_with_bindings cwb acc + | TacLApply c -> depends_of_'constr c acc + + (* Automation tactics *) + | TacTrivial (cl, bs) -> + (* TODO: Maybe make use of bs: list of hint bases to be used. *) + list_union_map depends_of_'constr cl acc + | TacAuto (_, cs, bs) -> + (* TODO: Maybe make use of bs: list of hint bases to be used. + None -> all ("with *") + Some list -> a list, "core" added implicitly *) + list_union_map depends_of_'constr cs acc + | TacAutoTDB _ -> acc + | TacDestructHyp _ -> acc + | TacDestructConcl -> acc + | TacSuperAuto _ -> (* TODO: this reference thing is scary*) + acc + | TacDAuto _ -> acc + + (* Context management *) + | TacClear _ + | TacClearBody _ + | TacMove _ + | TacRename _ + | TacRevert _ -> acc + + (* Constructors *) + | TacLeft (_,cb) + | TacRight (_,cb) + | TacSplit (_, _, cb) + | TacConstructor (_, _, cb) -> depends_of_'a_bindings depends_of_'constr cb acc + | TacAnyConstructor (_,taco) -> Option.fold_right depends_of_'tac taco acc + + (* Conversion *) + | TacReduce (reg,_) -> + depends_of_'a_'b_red_expr_gen depends_of_'constr reg acc + | TacChange (cwoo, c, _) -> + depends_of_'constr + c + (Option.fold_right (depends_of_'a_with_occurences depends_of_'constr) cwoo acc) + + (* Equivalence relations *) + | TacReflexivity + | TacSymmetry _ -> acc + | TacTransitivity c -> depends_of_'constr c acc + + (* Equality and inversion *) + | TacRewrite (_,cbl,_,_) -> list_union_map (o depends_of_'constr_with_bindings (fun (_,_,x)->x)) cbl acc + | TacInversion (is, _) -> depends_of_'a_'b_inversion_strength depends_of_'constr is acc + + (* For ML extensions *) + | TacExtend (_, _, cgal) -> failwith "depends of TacExtend not implemented because depends of a generic_argument not implemented" + + (* For syntax extensions *) + | TacAlias (_,_,gal,(_,gte)) -> failwith "depends of a TacAlias not implemented because depends of a generic_argument not implemented" + and depends_of_tac_fun_ast tfa acc = failwith "depend_of_tac_fun_ast not implemented yet" + and depends_of_tac_arg ta acc = match ta with + | TacDynamic (_,d) -> failwith "Don't know what to do with a Dyn in tac_arg" + | TacVoid -> acc + | MetaIdArg _ -> failwith "Don't know what to do with a MetaIdArg in tac_arg" + | ConstrMayEval me -> failwith "TODO: depends_of_tac_arg of a ConstrMayEval" + | IntroPattern _ -> acc + | Reference ltc -> acc (* TODO: This assumes the "ltac constant" cannot somehow refer to a named object... *) + | Integer _ -> acc + | TacCall (_,ltc,l) -> (* TODO: This assumes the "ltac constant" cannot somehow refer to a named object... *) + list_union_map depends_of_tac_arg l acc + | TacExternal (_,_,_,l) -> list_union_map depends_of_tac_arg l acc + | TacFreshId _ -> acc + | Tacexp tac -> + depends_of_'tac tac acc + in + depends_of_tacexpr + +let rec depends_of_glob_tactic_expr (gte:glob_tactic_expr) acc = + depends_of_gen_tactic_expr + depends_of_rawconstr_and_expr + (depends_of_'a_or_var depends_of_inductive) + depends_of_glob_tactic_expr + gte + acc + +let rec depends_of_tacexpr te acc = + depends_of_gen_tactic_expr + depends_of_open_constr + depends_of_inductive + depends_of_glob_tactic_expr + te + acc + +let depends_of_compound_rule cr acc = match cr with + | Tactic (texp, _) -> depends_of_tacexpr texp acc + | Proof_instr (b, instr) -> + (* TODO: What is the boolean b? Should check. *) + failwith "Dependency calculation of Proof_instr not implemented yet" +and depends_of_prim_rule pr acc = match pr with + | Refine c -> depends_of_constr c acc + | Intro id -> acc + | Intro_replacing id -> acc + | Cut (_, _, t) -> depends_of_constr t acc (* TODO: check what 2nd argument contains *) + | FixRule (_, _, l) -> list_union_map (o depends_of_constr trd_of_3) l acc (* TODO: check what the arguments contain *) + | Cofix (_, l) -> list_union_map (o depends_of_constr snd) l acc (* TODO: check what the arguments contain *) + | Convert_concl (t, _) -> depends_of_constr t acc + | Convert_hyp (_, None, t) -> depends_of_constr t acc + | Convert_hyp (_, (Some c), t) -> depends_of_constr c (depends_of_constr t acc) + | Thin _ -> acc + | ThinBody _ -> acc + | Move _ -> acc + | Rename _ -> acc + | Change_evars -> acc + +let rec depends_of_pftree pt acc = + match pt.ref with + | None -> acc + | Some (Prim pr , l) -> depends_of_prim_rule pr (list_union_map depends_of_pftree l acc) + | Some (Nested (t, p), l) -> depends_of_compound_rule t (depends_of_pftree p (list_union_map depends_of_pftree l acc)) + | Some (Decl_proof _ , l) -> list_union_map depends_of_pftree l acc + | Some (Daimon, l) -> list_union_map depends_of_pftree l acc + +let rec depends_of_pftree_head pt acc = + match pt.ref with + | None -> acc + | Some (Prim pr , l) -> depends_of_prim_rule pr acc + | Some (Nested (t, p), l) -> depends_of_compound_rule t (depends_of_pftree p acc) + | Some (Decl_proof _ , l) -> acc + | Some (Daimon, l) -> acc + +let depends_of_pftreestate depends_of_pftree pfs = +(* print_string "depends_of_pftreestate called\n"; *) +(* explore_tree pfs; *) + let pt = proof_of_pftreestate pfs in + assert (is_top_pftreestate pfs); + assert (pt.open_subgoals = 0); + depends_of_pftree pt [] + +let depends_of_definition_entry de ~acc = + Option.fold_right + depends_of_constr + de.const_entry_type + (depends_of_constr de.const_entry_body acc) diff --git a/contrib/interface/name_to_ast.ml b/contrib/interface/name_to_ast.ml index 9a503cfb..6b17e739 100644 --- a/contrib/interface/name_to_ast.ml +++ b/contrib/interface/name_to_ast.ml @@ -28,7 +28,7 @@ let convert_env = let convert_binder env (na, b, c) = match b with | Some b -> LocalRawDef ((dummy_loc,na), extern_constr true env b) - | None -> LocalRawAssum ([dummy_loc,na], extern_constr true env c) in + | None -> LocalRawAssum ([dummy_loc,na], default_binder_kind, extern_constr true env c) in let rec cvrec env = function [] -> [] | b::rest -> (convert_binder env b)::(cvrec (push_rel b env) rest) in @@ -134,14 +134,14 @@ let implicits_to_ast_list implicits = let make_variable_ast name typ implicits = (VernacAssumption - ((Local,Definitional), - [false,([dummy_loc,name], constr_to_ast (body_of_type typ))])) + ((Local,Definitional),false,(*inline flag*) + [false,([dummy_loc,name], constr_to_ast typ)])) ::(implicits_to_ast_list implicits);; let make_definition_ast name c typ implicits = - VernacDefinition ((Global,false,Definition), (dummy_loc,name), DefineBody ([], None, - (constr_to_ast c), Some (constr_to_ast (body_of_type typ))), + VernacDefinition ((Global,false,Definition), (dummy_loc,name), + DefineBody ([], None, constr_to_ast c, Some (constr_to_ast typ)), (fun _ _ -> ())) ::(implicits_to_ast_list implicits);; @@ -158,7 +158,7 @@ let constant_to_ast_list kn = make_definition_ast (id_of_label (con_label kn)) (Declarations.force c1) typ l) let variable_to_ast_list sp = - let (id, c, v) = get_variable sp in + let (id, c, v) = Global.lookup_named sp in let l = implicits_of_global (VarRef sp) in (match c with None -> diff --git a/contrib/interface/name_to_ast.mli b/contrib/interface/name_to_ast.mli index b8c2d7dc..f9e83b5e 100644 --- a/contrib/interface/name_to_ast.mli +++ b/contrib/interface/name_to_ast.mli @@ -1 +1,5 @@ val name_to_ast : Libnames.reference -> Vernacexpr.vernac_expr;; +val inductive_to_ast_list : Names.mutual_inductive -> Vernacexpr.vernac_expr list;; +val constant_to_ast_list : Names.constant -> Vernacexpr.vernac_expr list;; +val variable_to_ast_list : Names.variable -> Vernacexpr.vernac_expr list;; +val leaf_entry_to_ast_list : (Libnames.section_path * Names.mutual_inductive) * Libobject.obj -> Vernacexpr.vernac_expr list;; diff --git a/contrib/interface/parse.ml b/contrib/interface/parse.ml index 8cca7614..bf8614b4 100644 --- a/contrib/interface/parse.ml +++ b/contrib/interface/parse.ml @@ -21,18 +21,19 @@ type parsed_tree = | P_i of ct_INT;; let print_parse_results n msg = - print_string "message\nparsed\n"; - print_int n; - print_string "\n"; - (match msg with - | P_cl x -> fCOMMAND_LIST x - | P_c x -> fCOMMAND x - | P_t x -> fTACTIC_COM x - | P_f x -> fFORMULA x - | P_id x -> fID x - | P_s x -> fSTRING x - | P_i x -> fINT x); - print_string "e\nblabla\n"; + Pp.msg + ( str "message\nparsed\n" ++ + int n ++ + str "\n" ++ + (match msg with + | P_cl x -> fCOMMAND_LIST x + | P_c x -> fCOMMAND x + | P_t x -> fTACTIC_COM x + | P_f x -> fFORMULA x + | P_id x -> fID x + | P_s x -> fSTRING x + | P_i x -> fINT x) ++ + str "e\nblabla\n"); flush stdout;; let ctf_SyntaxErrorMessage reqid pps = @@ -329,7 +330,7 @@ let add_path_action reqid string_arg = let print_version_action () = msgnl (mt ()); - msgnl (str "$Id: parse.ml 9397 2006-11-21 21:50:54Z herbelin $");; + msgnl (str "$Id: parse.ml 9476 2007-01-10 15:44:44Z lmamane $");; let load_syntax_action reqid module_name = msg (str "loading " ++ str module_name ++ str "... "); diff --git a/contrib/interface/pbp.ml b/contrib/interface/pbp.ml index d2f71bfc..06b957d9 100644 --- a/contrib/interface/pbp.ml +++ b/contrib/interface/pbp.ml @@ -156,29 +156,29 @@ let make_pbp_pattern x = let rec make_then = function | [] -> TacId [] | [t] -> t - | t1::t2::l -> make_then (TacThen (t1,t2)::l) + | t1::t2::l -> make_then (TacThen (t1,[||],t2,[||])::l) let make_pbp_atomic_tactic = function | PbpTryAssumption None -> TacTry (TacAtom (zz, TacAssumption)) | PbpTryAssumption (Some a) -> TacTry (TacAtom (zz, TacExact (make_var a))) | PbpExists x -> - TacAtom (zz, TacSplit (true,ImplicitBindings [make_pbp_pattern x])) + TacAtom (zz, TacSplit (false,true,ImplicitBindings [make_pbp_pattern x])) | PbpGeneralize (h,args) -> let l = List.map make_pbp_pattern args in - TacAtom (zz, TacGeneralize [make_app (make_var h) l]) - | PbpLeft -> TacAtom (zz, TacLeft NoBindings) - | PbpRight -> TacAtom (zz, TacRight NoBindings) + TacAtom (zz, TacGeneralize [((true,[]),make_app (make_var h) l),Anonymous]) + | PbpLeft -> TacAtom (zz, TacLeft (false,NoBindings)) + | PbpRight -> TacAtom (zz, TacRight (false,NoBindings)) | PbpIntros l -> TacAtom (zz, TacIntroPattern l) | PbpLApply h -> TacAtom (zz, TacLApply (make_var h)) - | PbpApply h -> TacAtom (zz, TacApply (make_var h,NoBindings)) + | PbpApply h -> TacAtom (zz, TacApply (true,false,(make_var h,NoBindings))) | PbpElim (hyp_name, names) -> let bind = List.map (fun s ->(zz,NamedHyp s,make_pbp_pattern s)) names in TacAtom - (zz, TacElim ((make_var hyp_name,ExplicitBindings bind),None)) + (zz, TacElim (false,(make_var hyp_name,ExplicitBindings bind),None)) | PbpTryClear l -> TacTry (TacAtom (zz, TacClear (false,List.map (fun s -> AI (zz,s)) l))) - | PbpSplit -> TacAtom (zz, TacSplit (false,NoBindings));; + | PbpSplit -> TacAtom (zz, TacSplit (false,false,NoBindings));; let rec make_pbp_tactic = function | PbpThen tl -> make_then (List.map make_pbp_atomic_tactic tl) diff --git a/contrib/interface/showproof.ml b/contrib/interface/showproof.ml index 4bec7350..953fb5e7 100644 --- a/contrib/interface/showproof.ml +++ b/contrib/interface/showproof.ml @@ -166,7 +166,7 @@ let rule_to_ntactic r = let rt = (match r with Nested(Tactic (t,_),_) -> t - | Prim (Refine h) -> TacAtom (dummy_loc,TacExact h) + | Prim (Refine h) -> TacAtom (dummy_loc,TacExact (Tactics.inj_open h)) | _ -> TacAtom (dummy_loc, TacIntroPattern [])) in if rule_is_complex r then (match rt with @@ -1183,8 +1183,8 @@ let rec natural_ntree ig ntree = TacIntroPattern _ -> natural_intros ig lh g gs ltree | TacIntroMove _ -> natural_intros ig lh g gs ltree | TacFix (_,n) -> natural_fix ig lh g gs n ltree - | TacSplit (_,NoBindings) -> natural_split ig lh g gs ge [] ltree - | TacSplit(_,ImplicitBindings l) -> natural_split ig lh g gs ge l ltree + | TacSplit (_,_,NoBindings) -> natural_split ig lh g gs ge [] ltree + | TacSplit(_,_,ImplicitBindings l) -> natural_split ig lh g gs ge (List.map snd l) ltree | TacGeneralize l -> natural_generalize ig lh g gs ge l ltree | TacRight _ -> natural_right ig lh g gs ltree | TacLeft _ -> natural_left ig lh g gs ltree @@ -1202,17 +1202,18 @@ let rec natural_ntree ig ntree = | TacExtend (_,"InductionIntro",[a]) -> let id=(out_gen wit_ident a) in natural_induction ig lh g gs ge id ltree true - | TacApply (c,_) -> natural_apply ig lh g gs c ltree - | TacExact c -> natural_exact ig lh g gs c ltree - | TacCut c -> natural_cut ig lh g gs c ltree + | TacApply (_,false,(c,_)) -> natural_apply ig lh g gs (snd c) ltree + | TacExact c -> natural_exact ig lh g gs (snd c) ltree + | TacCut c -> natural_cut ig lh g gs (snd c) ltree | TacExtend (_,"CutIntro",[a]) -> let _c = out_gen wit_constr a in natural_cutintro ig lh g gs a ltree - | TacCase (c,_) -> natural_case ig lh g gs ge c ltree false + | TacCase (_,(c,_)) -> natural_case ig lh g gs ge (snd c) ltree false | TacExtend (_,"CaseIntro",[a]) -> let c = out_gen wit_constr a in natural_case ig lh g gs ge c ltree true - | TacElim ((c,_),_) -> natural_elim ig lh g gs ge c ltree false + | TacElim (_,(c,_),_) -> + natural_elim ig lh g gs ge (snd c) ltree false | TacExtend (_,"ElimIntro",[a]) -> let c = out_gen wit_constr a in natural_elim ig lh g gs ge c ltree true @@ -1611,7 +1612,7 @@ and natural_fix ig lh g gs narg ltree = | _ -> assert false and natural_reduce ig lh g gs ge mode la ltree = match la with - {onhyps=Some[];onconcl=true} -> + {onhyps=Some[]} when la.concl_occs <> no_occurrences_expr -> spv [ (natural_lhyp lh ig.ihsg); (show_goal2 lh ig g gs ""); @@ -1619,7 +1620,7 @@ and natural_reduce ig lh g gs ge mode la ltree = {ihsg=All_subgoals_hyp;isgintro="simpl"}) ltree) ] - | {onhyps=Some[hyp]; onconcl=false} -> + | {onhyps=Some[hyp]} when la.concl_occs = no_occurrences_expr -> spv [ (natural_lhyp lh ig.ihsg); (show_goal2 lh ig g gs ""); @@ -1651,7 +1652,7 @@ and natural_split ig lh g gs ge la ltree = | _ -> assert false and natural_generalize ig lh g gs ge la ltree = match la with - [arg] -> + [(_,(_,arg)),_] -> let _env= (gLOB ge) in let arg1= (*dbize env*) arg in let _type_arg=type_of (Global.env()) Evd.empty arg in diff --git a/contrib/interface/translate.ml b/contrib/interface/translate.ml index 6e4782be..559860b2 100644 --- a/contrib/interface/translate.ml +++ b/contrib/interface/translate.ml @@ -75,3 +75,6 @@ let translate_path l = (*translates a path and a goal into a centaur-tree --> RULE *) let translate_goal (g:goal) = CT_rule(translate_sign (evar_env g), translate_constr true (evar_env g) g.evar_concl);; + +let translate_goals (gl: goal list) = + CT_rule_list (List.map translate_goal gl);; diff --git a/contrib/interface/translate.mli b/contrib/interface/translate.mli index 65d8331b..34841fc4 100644 --- a/contrib/interface/translate.mli +++ b/contrib/interface/translate.mli @@ -5,6 +5,7 @@ open Environ;; open Term;; val translate_goal : goal -> ct_RULE;; +val translate_goals : goal list -> ct_RULE_LIST;; (* The boolean argument indicates whether names from the environment should *) (* be avoided (same interpretation as for prterm_env and ast_of_constr) *) val translate_constr : bool -> env -> constr -> ct_FORMULA;; diff --git a/contrib/interface/vtp.ml b/contrib/interface/vtp.ml index 166a0cbf..551ad3a3 100644 --- a/contrib/interface/vtp.ml +++ b/contrib/interface/vtp.ml @@ -1,103 +1,108 @@ open Ascent;; +open Pp;; + +(* LEM: This is actually generated automatically *) let fNODE s n = - print_string "n\n"; - print_string ("vernac$" ^ s); - print_string "\n"; - print_int n; - print_string "\n";; + (str "n\n") ++ + (str ("vernac$" ^ s)) ++ + (str "\n") ++ + (int n) ++ + (str "\n");; let fATOM s1 = - print_string "a\n"; - print_string ("vernac$" ^ s1); - print_string "\n";; + (str "a\n") ++ + (str ("vernac$" ^ s1)) ++ + (str "\n");; -let f_atom_string = print_string;; -let f_atom_int = print_int;; +let f_atom_string = str;; +let f_atom_int = int;; let rec fAST = function | CT_coerce_ID_OR_INT_to_AST x -> fID_OR_INT x | CT_coerce_ID_OR_STRING_to_AST x -> fID_OR_STRING x | CT_coerce_SINGLE_OPTION_VALUE_to_AST x -> fSINGLE_OPTION_VALUE x | CT_astnode(x1, x2) -> - fID x1; - fAST_LIST x2; + fID x1 ++ + fAST_LIST x2 ++ fNODE "astnode" 2 | CT_astpath(x1) -> - fID_LIST x1; + fID_LIST x1 ++ fNODE "astpath" 1 | CT_astslam(x1, x2) -> - fID_OPT x1; - fAST x2; + fID_OPT x1 ++ + fAST x2 ++ fNODE "astslam" 2 and fAST_LIST = function | CT_ast_list l -> - (List.iter fAST l); + (List.fold_left (++) (mt()) (List.map fAST l)) ++ fNODE "ast_list" (List.length l) and fBINARY = function -| CT_binary x -> fATOM "binary"; - (f_atom_int x); - print_string "\n"and fBINDER = function +| CT_binary x -> fATOM "binary" ++ + (f_atom_int x) ++ + str "\n" +and fBINDER = function | CT_coerce_DEF_to_BINDER x -> fDEF x | CT_binder(x1, x2) -> - fID_OPT_NE_LIST x1; - fFORMULA x2; + fID_OPT_NE_LIST x1 ++ + fFORMULA x2 ++ fNODE "binder" 2 | CT_binder_coercion(x1, x2) -> - fID_OPT_NE_LIST x1; - fFORMULA x2; + fID_OPT_NE_LIST x1 ++ + fFORMULA x2 ++ fNODE "binder_coercion" 2 and fBINDER_LIST = function | CT_binder_list l -> - (List.iter fBINDER l); + (List.fold_left (++) (mt()) (List.map fBINDER l)) ++ fNODE "binder_list" (List.length l) and fBINDER_NE_LIST = function | CT_binder_ne_list(x,l) -> - fBINDER x; - (List.iter fBINDER l); + fBINDER x ++ + (List.fold_left (++) (mt()) (List.map fBINDER l)) ++ fNODE "binder_ne_list" (1 + (List.length l)) and fBINDING = function | CT_binding(x1, x2) -> - fID_OR_INT x1; - fFORMULA x2; + fID_OR_INT x1 ++ + fFORMULA x2 ++ fNODE "binding" 2 and fBINDING_LIST = function | CT_binding_list l -> - (List.iter fBINDING l); + (List.fold_left (++) (mt()) (List.map fBINDING l)) ++ fNODE "binding_list" (List.length l) and fBOOL = function | CT_false -> fNODE "false" 0 | CT_true -> fNODE "true" 0 and fCASE = function -| CT_case x -> fATOM "case"; - (f_atom_string x); - print_string "\n"and fCLAUSE = function +| CT_case x -> fATOM "case" ++ + (f_atom_string x) ++ + str "\n" +and fCLAUSE = function | CT_clause(x1, x2) -> - fHYP_LOCATION_LIST_OR_STAR x1; - fSTAR_OPT x2; + fHYP_LOCATION_LIST_OR_STAR x1 ++ + fSTAR_OPT x2 ++ fNODE "clause" 2 and fCOERCION_OPT = function | CT_coerce_NONE_to_COERCION_OPT x -> fNONE x | CT_coercion_atm -> fNODE "coercion_atm" 0 and fCOFIXTAC = function | CT_cofixtac(x1, x2) -> - fID x1; - fFORMULA x2; + fID x1 ++ + fFORMULA x2 ++ fNODE "cofixtac" 2 and fCOFIX_REC = function | CT_cofix_rec(x1, x2, x3, x4) -> - fID x1; - fBINDER_LIST x2; - fFORMULA x3; - fFORMULA x4; + fID x1 ++ + fBINDER_LIST x2 ++ + fFORMULA x3 ++ + fFORMULA x4 ++ fNODE "cofix_rec" 4 and fCOFIX_REC_LIST = function | CT_cofix_rec_list(x,l) -> - fCOFIX_REC x; - (List.iter fCOFIX_REC l); + fCOFIX_REC x ++ + (List.fold_left (++) (mt()) (List.map fCOFIX_REC l)) ++ fNODE "cofix_rec_list" (1 + (List.length l)) and fCOFIX_TAC_LIST = function | CT_cofix_tac_list l -> - (List.iter fCOFIXTAC l); + (List.fold_left (++) (mt()) (List.map fCOFIXTAC l)) ++ fNODE "cofix_tac_list" (List.length l) and fCOMMAND = function | CT_coerce_COMMAND_LIST_to_COMMAND x -> fCOMMAND_LIST x @@ -105,479 +110,476 @@ and fCOMMAND = function | CT_coerce_SECTION_BEGIN_to_COMMAND x -> fSECTION_BEGIN x | CT_coerce_THEOREM_GOAL_to_COMMAND x -> fTHEOREM_GOAL x | CT_abort(x1) -> - fID_OPT_OR_ALL x1; + fID_OPT_OR_ALL x1 ++ fNODE "abort" 1 | CT_abstraction(x1, x2, x3) -> - fID x1; - fFORMULA x2; - fINT_LIST x3; + fID x1 ++ + fFORMULA x2 ++ + fINT_LIST x3 ++ fNODE "abstraction" 3 | CT_add_field(x1, x2, x3, x4) -> - fFORMULA x1; - fFORMULA x2; - fFORMULA x3; - fFORMULA_OPT x4; + fFORMULA x1 ++ + fFORMULA x2 ++ + fFORMULA x3 ++ + fFORMULA_OPT x4 ++ fNODE "add_field" 4 | CT_add_natural_feature(x1, x2) -> - fNATURAL_FEATURE x1; - fID x2; + fNATURAL_FEATURE x1 ++ + fID x2 ++ fNODE "add_natural_feature" 2 | CT_addpath(x1, x2) -> - fSTRING x1; - fID_OPT x2; + fSTRING x1 ++ + fID_OPT x2 ++ fNODE "addpath" 2 | CT_arguments_scope(x1, x2) -> - fID x1; - fID_OPT_LIST x2; + fID x1 ++ + fID_OPT_LIST x2 ++ fNODE "arguments_scope" 2 | CT_bind_scope(x1, x2) -> - fID x1; - fID_NE_LIST x2; + fID x1 ++ + fID_NE_LIST x2 ++ fNODE "bind_scope" 2 | CT_cd(x1) -> - fSTRING_OPT x1; + fSTRING_OPT x1 ++ fNODE "cd" 1 | CT_check(x1) -> - fFORMULA x1; + fFORMULA x1 ++ fNODE "check" 1 | CT_class(x1) -> - fID x1; + fID x1 ++ fNODE "class" 1 | CT_close_scope(x1) -> - fID x1; + fID x1 ++ fNODE "close_scope" 1 | CT_coercion(x1, x2, x3, x4, x5) -> - fLOCAL_OPT x1; - fIDENTITY_OPT x2; - fID x3; - fID x4; - fID x5; + fLOCAL_OPT x1 ++ + fIDENTITY_OPT x2 ++ + fID x3 ++ + fID x4 ++ + fID x5 ++ fNODE "coercion" 5 | CT_cofix_decl(x1) -> - fCOFIX_REC_LIST x1; + fCOFIX_REC_LIST x1 ++ fNODE "cofix_decl" 1 | CT_compile_module(x1, x2, x3) -> - fVERBOSE_OPT x1; - fID x2; - fSTRING_OPT x3; + fVERBOSE_OPT x1 ++ + fID x2 ++ + fSTRING_OPT x3 ++ fNODE "compile_module" 3 | CT_declare_module(x1, x2, x3, x4) -> - fID x1; - fMODULE_BINDER_LIST x2; - fMODULE_TYPE_CHECK x3; - fMODULE_EXPR x4; + fID x1 ++ + fMODULE_BINDER_LIST x2 ++ + fMODULE_TYPE_CHECK x3 ++ + fMODULE_EXPR x4 ++ fNODE "declare_module" 4 | CT_define_notation(x1, x2, x3, x4) -> - fSTRING x1; - fFORMULA x2; - fMODIFIER_LIST x3; - fID_OPT x4; + fSTRING x1 ++ + fFORMULA x2 ++ + fMODIFIER_LIST x3 ++ + fID_OPT x4 ++ fNODE "define_notation" 4 | CT_definition(x1, x2, x3, x4, x5) -> - fDEFN x1; - fID x2; - fBINDER_LIST x3; - fDEF_BODY x4; - fFORMULA_OPT x5; + fDEFN x1 ++ + fID x2 ++ + fBINDER_LIST x3 ++ + fDEF_BODY x4 ++ + fFORMULA_OPT x5 ++ fNODE "definition" 5 | CT_delim_scope(x1, x2) -> - fID x1; - fID x2; + fID x1 ++ + fID x2 ++ fNODE "delim_scope" 2 | CT_delpath(x1) -> - fSTRING x1; + fSTRING x1 ++ fNODE "delpath" 1 | CT_derive_depinversion(x1, x2, x3, x4) -> - fINV_TYPE x1; - fID x2; - fFORMULA x3; - fSORT_TYPE x4; + fINV_TYPE x1 ++ + fID x2 ++ + fFORMULA x3 ++ + fSORT_TYPE x4 ++ fNODE "derive_depinversion" 4 | CT_derive_inversion(x1, x2, x3, x4) -> - fINV_TYPE x1; - fINT_OPT x2; - fID x3; - fID x4; + fINV_TYPE x1 ++ + fINT_OPT x2 ++ + fID x3 ++ + fID x4 ++ fNODE "derive_inversion" 4 | CT_derive_inversion_with(x1, x2, x3, x4) -> - fINV_TYPE x1; - fID x2; - fFORMULA x3; - fSORT_TYPE x4; + fINV_TYPE x1 ++ + fID x2 ++ + fFORMULA x3 ++ + fSORT_TYPE x4 ++ fNODE "derive_inversion_with" 4 | CT_explain_proof(x1) -> - fINT_LIST x1; + fINT_LIST x1 ++ fNODE "explain_proof" 1 | CT_explain_prooftree(x1) -> - fINT_LIST x1; + fINT_LIST x1 ++ fNODE "explain_prooftree" 1 | CT_export_id(x1) -> - fID_NE_LIST x1; + fID_NE_LIST x1 ++ fNODE "export_id" 1 | CT_extract_to_file(x1, x2) -> - fSTRING x1; - fID_NE_LIST x2; + fSTRING x1 ++ + fID_NE_LIST x2 ++ fNODE "extract_to_file" 2 | CT_extraction(x1) -> - fID_OPT x1; + fID_OPT x1 ++ fNODE "extraction" 1 | CT_fix_decl(x1) -> - fFIX_REC_LIST x1; + fFIX_REC_LIST x1 ++ fNODE "fix_decl" 1 | CT_focus(x1) -> - fINT_OPT x1; + fINT_OPT x1 ++ fNODE "focus" 1 | CT_go(x1) -> - fINT_OR_LOCN x1; + fINT_OR_LOCN x1 ++ fNODE "go" 1 | CT_guarded -> fNODE "guarded" 0 | CT_hint_destruct(x1, x2, x3, x4, x5, x6) -> - fID x1; - fINT x2; - fDESTRUCT_LOCATION x3; - fFORMULA x4; - fTACTIC_COM x5; - fID_LIST x6; + fID x1 ++ + fINT x2 ++ + fDESTRUCT_LOCATION x3 ++ + fFORMULA x4 ++ + fTACTIC_COM x5 ++ + fID_LIST x6 ++ fNODE "hint_destruct" 6 | CT_hint_extern(x1, x2, x3, x4) -> - fINT x1; - fFORMULA x2; - fTACTIC_COM x3; - fID_LIST x4; + fINT x1 ++ + fFORMULA x2 ++ + fTACTIC_COM x3 ++ + fID_LIST x4 ++ fNODE "hint_extern" 4 | CT_hintrewrite(x1, x2, x3, x4) -> - fORIENTATION x1; - fFORMULA_NE_LIST x2; - fID x3; - fTACTIC_COM x4; + fORIENTATION x1 ++ + fFORMULA_NE_LIST x2 ++ + fID x3 ++ + fTACTIC_COM x4 ++ fNODE "hintrewrite" 4 | CT_hints(x1, x2, x3) -> - fID x1; - fID_NE_LIST x2; - fID_LIST x3; + fID x1 ++ + fID_NE_LIST x2 ++ + fID_LIST x3 ++ fNODE "hints" 3 | CT_hints_immediate(x1, x2) -> - fFORMULA_NE_LIST x1; - fID_LIST x2; + fFORMULA_NE_LIST x1 ++ + fID_LIST x2 ++ fNODE "hints_immediate" 2 | CT_hints_resolve(x1, x2) -> - fFORMULA_NE_LIST x1; - fID_LIST x2; + fFORMULA_NE_LIST x1 ++ + fID_LIST x2 ++ fNODE "hints_resolve" 2 | CT_hyp_search_pattern(x1, x2) -> - fFORMULA x1; - fIN_OR_OUT_MODULES x2; + fFORMULA x1 ++ + fIN_OR_OUT_MODULES x2 ++ fNODE "hyp_search_pattern" 2 | CT_implicits(x1, x2) -> - fID x1; - fID_LIST_OPT x2; + fID x1 ++ + fID_LIST_OPT x2 ++ fNODE "implicits" 2 | CT_import_id(x1) -> - fID_NE_LIST x1; + fID_NE_LIST x1 ++ fNODE "import_id" 1 | CT_ind_scheme(x1) -> - fSCHEME_SPEC_LIST x1; + fSCHEME_SPEC_LIST x1 ++ fNODE "ind_scheme" 1 | CT_infix(x1, x2, x3, x4) -> - fSTRING x1; - fID x2; - fMODIFIER_LIST x3; - fID_OPT x4; + fSTRING x1 ++ + fID x2 ++ + fMODIFIER_LIST x3 ++ + fID_OPT x4 ++ fNODE "infix" 4 | CT_inline(x1) -> - fID_NE_LIST x1; + fID_NE_LIST x1 ++ fNODE "inline" 1 | CT_inspect(x1) -> - fINT x1; + fINT x1 ++ fNODE "inspect" 1 | CT_kill_node(x1) -> - fINT x1; + fINT x1 ++ fNODE "kill_node" 1 | CT_load(x1, x2) -> - fVERBOSE_OPT x1; - fID_OR_STRING x2; + fVERBOSE_OPT x1 ++ + fID_OR_STRING x2 ++ fNODE "load" 2 | CT_local_close_scope(x1) -> - fID x1; + fID x1 ++ fNODE "local_close_scope" 1 | CT_local_define_notation(x1, x2, x3, x4) -> - fSTRING x1; - fFORMULA x2; - fMODIFIER_LIST x3; - fID_OPT x4; + fSTRING x1 ++ + fFORMULA x2 ++ + fMODIFIER_LIST x3 ++ + fID_OPT x4 ++ fNODE "local_define_notation" 4 | CT_local_hint_destruct(x1, x2, x3, x4, x5, x6) -> - fID x1; - fINT x2; - fDESTRUCT_LOCATION x3; - fFORMULA x4; - fTACTIC_COM x5; - fID_LIST x6; + fID x1 ++ + fINT x2 ++ + fDESTRUCT_LOCATION x3 ++ + fFORMULA x4 ++ + fTACTIC_COM x5 ++ + fID_LIST x6 ++ fNODE "local_hint_destruct" 6 | CT_local_hint_extern(x1, x2, x3, x4) -> - fINT x1; - fFORMULA x2; - fTACTIC_COM x3; - fID_LIST x4; + fINT x1 ++ + fFORMULA x2 ++ + fTACTIC_COM x3 ++ + fID_LIST x4 ++ fNODE "local_hint_extern" 4 | CT_local_hints(x1, x2, x3) -> - fID x1; - fID_NE_LIST x2; - fID_LIST x3; + fID x1 ++ + fID_NE_LIST x2 ++ + fID_LIST x3 ++ fNODE "local_hints" 3 | CT_local_hints_immediate(x1, x2) -> - fFORMULA_NE_LIST x1; - fID_LIST x2; + fFORMULA_NE_LIST x1 ++ + fID_LIST x2 ++ fNODE "local_hints_immediate" 2 | CT_local_hints_resolve(x1, x2) -> - fFORMULA_NE_LIST x1; - fID_LIST x2; + fFORMULA_NE_LIST x1 ++ + fID_LIST x2 ++ fNODE "local_hints_resolve" 2 | CT_local_infix(x1, x2, x3, x4) -> - fSTRING x1; - fID x2; - fMODIFIER_LIST x3; - fID_OPT x4; + fSTRING x1 ++ + fID x2 ++ + fMODIFIER_LIST x3 ++ + fID_OPT x4 ++ fNODE "local_infix" 4 | CT_local_open_scope(x1) -> - fID x1; + fID x1 ++ fNODE "local_open_scope" 1 | CT_local_reserve_notation(x1, x2) -> - fSTRING x1; - fMODIFIER_LIST x2; + fSTRING x1 ++ + fMODIFIER_LIST x2 ++ fNODE "local_reserve_notation" 2 | CT_locate(x1) -> - fID x1; + fID x1 ++ fNODE "locate" 1 | CT_locate_file(x1) -> - fSTRING x1; + fSTRING x1 ++ fNODE "locate_file" 1 | CT_locate_lib(x1) -> - fID x1; + fID x1 ++ fNODE "locate_lib" 1 | CT_locate_notation(x1) -> - fSTRING x1; + fSTRING x1 ++ fNODE "locate_notation" 1 | CT_mind_decl(x1, x2) -> - fCO_IND x1; - fIND_SPEC_LIST x2; + fCO_IND x1 ++ + fIND_SPEC_LIST x2 ++ fNODE "mind_decl" 2 | CT_ml_add_path(x1) -> - fSTRING x1; + fSTRING x1 ++ fNODE "ml_add_path" 1 | CT_ml_declare_modules(x1) -> - fSTRING_NE_LIST x1; + fSTRING_NE_LIST x1 ++ fNODE "ml_declare_modules" 1 | CT_ml_print_modules -> fNODE "ml_print_modules" 0 | CT_ml_print_path -> fNODE "ml_print_path" 0 | CT_module(x1, x2, x3, x4) -> - fID x1; - fMODULE_BINDER_LIST x2; - fMODULE_TYPE_CHECK x3; - fMODULE_EXPR x4; + fID x1 ++ + fMODULE_BINDER_LIST x2 ++ + fMODULE_TYPE_CHECK x3 ++ + fMODULE_EXPR x4 ++ fNODE "module" 4 | CT_module_type_decl(x1, x2, x3) -> - fID x1; - fMODULE_BINDER_LIST x2; - fMODULE_TYPE_OPT x3; + fID x1 ++ + fMODULE_BINDER_LIST x2 ++ + fMODULE_TYPE_OPT x3 ++ fNODE "module_type_decl" 3 | CT_no_inline(x1) -> - fID_NE_LIST x1; + fID_NE_LIST x1 ++ fNODE "no_inline" 1 | CT_omega_flag(x1, x2) -> - fOMEGA_MODE x1; - fOMEGA_FEATURE x2; + fOMEGA_MODE x1 ++ + fOMEGA_FEATURE x2 ++ fNODE "omega_flag" 2 -| CT_opaque(x1) -> - fID_NE_LIST x1; - fNODE "opaque" 1 | CT_open_scope(x1) -> - fID x1; + fID x1 ++ fNODE "open_scope" 1 | CT_print -> fNODE "print" 0 | CT_print_about(x1) -> - fID x1; + fID x1 ++ fNODE "print_about" 1 | CT_print_all -> fNODE "print_all" 0 | CT_print_classes -> fNODE "print_classes" 0 | CT_print_ltac id -> - fID id; + fID id ++ fNODE "print_ltac" 1 | CT_print_coercions -> fNODE "print_coercions" 0 | CT_print_grammar(x1) -> - fGRAMMAR x1; + fGRAMMAR x1 ++ fNODE "print_grammar" 1 | CT_print_graph -> fNODE "print_graph" 0 | CT_print_hint(x1) -> - fID_OPT x1; + fID_OPT x1 ++ fNODE "print_hint" 1 | CT_print_hintdb(x1) -> - fID_OR_STAR x1; + fID_OR_STAR x1 ++ fNODE "print_hintdb" 1 | CT_print_rewrite_hintdb(x1) -> - fID x1; + fID x1 ++ fNODE "print_rewrite_hintdb" 1 | CT_print_id(x1) -> - fID x1; + fID x1 ++ fNODE "print_id" 1 | CT_print_implicit(x1) -> - fID x1; + fID x1 ++ fNODE "print_implicit" 1 | CT_print_loadpath -> fNODE "print_loadpath" 0 | CT_print_module(x1) -> - fID x1; + fID x1 ++ fNODE "print_module" 1 | CT_print_module_type(x1) -> - fID x1; + fID x1 ++ fNODE "print_module_type" 1 | CT_print_modules -> fNODE "print_modules" 0 | CT_print_natural(x1) -> - fID x1; + fID x1 ++ fNODE "print_natural" 1 | CT_print_natural_feature(x1) -> - fNATURAL_FEATURE x1; + fNATURAL_FEATURE x1 ++ fNODE "print_natural_feature" 1 | CT_print_opaqueid(x1) -> - fID x1; + fID x1 ++ fNODE "print_opaqueid" 1 | CT_print_path(x1, x2) -> - fID x1; - fID x2; + fID x1 ++ + fID x2 ++ fNODE "print_path" 2 | CT_print_proof(x1) -> - fID x1; + fID x1 ++ fNODE "print_proof" 1 | CT_print_scope(x1) -> - fID x1; + fID x1 ++ fNODE "print_scope" 1 | CT_print_setoids -> fNODE "print_setoids" 0 | CT_print_scopes -> fNODE "print_scopes" 0 | CT_print_section(x1) -> - fID x1; + fID x1 ++ fNODE "print_section" 1 | CT_print_states -> fNODE "print_states" 0 | CT_print_tables -> fNODE "print_tables" 0 | CT_print_universes(x1) -> - fSTRING_OPT x1; + fSTRING_OPT x1 ++ fNODE "print_universes" 1 | CT_print_visibility(x1) -> - fID_OPT x1; + fID_OPT x1 ++ fNODE "print_visibility" 1 | CT_proof(x1) -> - fFORMULA x1; + fFORMULA x1 ++ fNODE "proof" 1 | CT_proof_no_op -> fNODE "proof_no_op" 0 | CT_proof_with(x1) -> - fTACTIC_COM x1; + fTACTIC_COM x1 ++ fNODE "proof_with" 1 | CT_pwd -> fNODE "pwd" 0 | CT_quit -> fNODE "quit" 0 | CT_read_module(x1) -> - fID x1; + fID x1 ++ fNODE "read_module" 1 | CT_rec_ml_add_path(x1) -> - fSTRING x1; + fSTRING x1 ++ fNODE "rec_ml_add_path" 1 | CT_recaddpath(x1, x2) -> - fSTRING x1; - fID_OPT x2; + fSTRING x1 ++ + fID_OPT x2 ++ fNODE "recaddpath" 2 | CT_record(x1, x2, x3, x4, x5, x6) -> - fCOERCION_OPT x1; - fID x2; - fBINDER_LIST x3; - fFORMULA x4; - fID_OPT x5; - fRECCONSTR_LIST x6; + fCOERCION_OPT x1 ++ + fID x2 ++ + fBINDER_LIST x3 ++ + fFORMULA x4 ++ + fID_OPT x5 ++ + fRECCONSTR_LIST x6 ++ fNODE "record" 6 | CT_remove_natural_feature(x1, x2) -> - fNATURAL_FEATURE x1; - fID x2; + fNATURAL_FEATURE x1 ++ + fID x2 ++ fNODE "remove_natural_feature" 2 | CT_require(x1, x2, x3) -> - fIMPEXP x1; - fSPEC_OPT x2; - fID_NE_LIST_OR_STRING x3; + fIMPEXP x1 ++ + fSPEC_OPT x2 ++ + fID_NE_LIST_OR_STRING x3 ++ fNODE "require" 3 | CT_reserve(x1, x2) -> - fID_NE_LIST x1; - fFORMULA x2; + fID_NE_LIST x1 ++ + fFORMULA x2 ++ fNODE "reserve" 2 | CT_reserve_notation(x1, x2) -> - fSTRING x1; - fMODIFIER_LIST x2; + fSTRING x1 ++ + fMODIFIER_LIST x2 ++ fNODE "reserve_notation" 2 | CT_reset(x1) -> - fID x1; + fID x1 ++ fNODE "reset" 1 | CT_reset_section(x1) -> - fID x1; + fID x1 ++ fNODE "reset_section" 1 | CT_restart -> fNODE "restart" 0 | CT_restore_state(x1) -> - fID x1; + fID x1 ++ fNODE "restore_state" 1 | CT_resume(x1) -> - fID_OPT x1; + fID_OPT x1 ++ fNODE "resume" 1 | CT_save(x1, x2) -> - fTHM_OPT x1; - fID_OPT x2; + fTHM_OPT x1 ++ + fID_OPT x2 ++ fNODE "save" 2 | CT_scomments(x1) -> - fSCOMMENT_CONTENT_LIST x1; + fSCOMMENT_CONTENT_LIST x1 ++ fNODE "scomments" 1 | CT_search(x1, x2) -> - fID x1; - fIN_OR_OUT_MODULES x2; + fID x1 ++ + fIN_OR_OUT_MODULES x2 ++ fNODE "search" 2 | CT_search_about(x1, x2) -> - fID_OR_STRING_NE_LIST x1; - fIN_OR_OUT_MODULES x2; + fID_OR_STRING_NE_LIST x1 ++ + fIN_OR_OUT_MODULES x2 ++ fNODE "search_about" 2 | CT_search_pattern(x1, x2) -> - fFORMULA x1; - fIN_OR_OUT_MODULES x2; + fFORMULA x1 ++ + fIN_OR_OUT_MODULES x2 ++ fNODE "search_pattern" 2 | CT_search_rewrite(x1, x2) -> - fFORMULA x1; - fIN_OR_OUT_MODULES x2; + fFORMULA x1 ++ + fIN_OR_OUT_MODULES x2 ++ fNODE "search_rewrite" 2 | CT_section_end(x1) -> - fID x1; + fID x1 ++ fNODE "section_end" 1 | CT_section_struct(x1, x2, x3) -> - fSECTION_BEGIN x1; - fSECTION_BODY x2; - fCOMMAND x3; + fSECTION_BEGIN x1 ++ + fSECTION_BODY x2 ++ + fCOMMAND x3 ++ fNODE "section_struct" 3 | CT_set_natural(x1) -> - fID x1; + fID x1 ++ fNODE "set_natural" 1 | CT_set_natural_default -> fNODE "set_natural_default" 0 | CT_set_option(x1) -> - fTABLE x1; + fTABLE x1 ++ fNODE "set_option" 1 | CT_set_option_value(x1, x2) -> - fTABLE x1; - fSINGLE_OPTION_VALUE x2; + fTABLE x1 ++ + fSINGLE_OPTION_VALUE x2 ++ fNODE "set_option_value" 2 | CT_set_option_value2(x1, x2) -> - fTABLE x1; - fID_OR_STRING_NE_LIST x2; + fTABLE x1 ++ + fID_OR_STRING_NE_LIST x2 ++ fNODE "set_option_value2" 2 | CT_sethyp(x1) -> - fINT x1; + fINT x1 ++ fNODE "sethyp" 1 | CT_setundo(x1) -> - fINT x1; + fINT x1 ++ fNODE "setundo" 1 | CT_show_existentials -> fNODE "show_existentials" 0 | CT_show_goal(x1) -> - fINT_OPT x1; + fINT_OPT x1 ++ fNODE "show_goal" 1 | CT_show_implicit(x1) -> - fINT x1; + fINT x1 ++ fNODE "show_implicit" 1 | CT_show_intro -> fNODE "show_intro" 0 | CT_show_intros -> fNODE "show_intros" 0 @@ -587,97 +589,103 @@ and fCOMMAND = function | CT_show_script -> fNODE "show_script" 0 | CT_show_tree -> fNODE "show_tree" 0 | CT_solve(x1, x2, x3) -> - fINT x1; - fTACTIC_COM x2; - fDOTDOT_OPT x3; + fINT x1 ++ + fTACTIC_COM x2 ++ + fDOTDOT_OPT x3 ++ fNODE "solve" 3 +| CT_strategy(CT_level_list x1) -> + List.fold_left (++) (mt()) + (List.map (fun(l,q) -> fLEVEL l ++ fID_LIST q ++ fNODE "pair"2) x1) ++ + fNODE "strategy" (List.length x1) | CT_suspend -> fNODE "suspend" 0 | CT_syntax_macro(x1, x2, x3) -> - fID x1; - fFORMULA x2; - fINT_OPT x3; + fID x1 ++ + fFORMULA x2 ++ + fINT_OPT x3 ++ fNODE "syntax_macro" 3 | CT_tactic_definition(x1) -> - fTAC_DEF_NE_LIST x1; + fTAC_DEF_NE_LIST x1 ++ fNODE "tactic_definition" 1 | CT_test_natural_feature(x1, x2) -> - fNATURAL_FEATURE x1; - fID x2; + fNATURAL_FEATURE x1 ++ + fID x2 ++ fNODE "test_natural_feature" 2 | CT_theorem_struct(x1, x2) -> - fTHEOREM_GOAL x1; - fPROOF_SCRIPT x2; + fTHEOREM_GOAL x1 ++ + fPROOF_SCRIPT x2 ++ fNODE "theorem_struct" 2 | CT_time(x1) -> - fCOMMAND x1; + fCOMMAND x1 ++ fNODE "time" 1 -| CT_transparent(x1) -> - fID_NE_LIST x1; - fNODE "transparent" 1 | CT_undo(x1) -> - fINT_OPT x1; + fINT_OPT x1 ++ fNODE "undo" 1 | CT_unfocus -> fNODE "unfocus" 0 | CT_unset_option(x1) -> - fTABLE x1; + fTABLE x1 ++ fNODE "unset_option" 1 | CT_unsethyp -> fNODE "unsethyp" 0 | CT_unsetundo -> fNODE "unsetundo" 0 | CT_user_vernac(x1, x2) -> - fID x1; - fVARG_LIST x2; + fID x1 ++ + fVARG_LIST x2 ++ fNODE "user_vernac" 2 | CT_variable(x1, x2) -> - fVAR x1; - fBINDER_NE_LIST x2; + fVAR x1 ++ + fBINDER_NE_LIST x2 ++ fNODE "variable" 2 | CT_write_module(x1, x2) -> - fID x1; - fSTRING_OPT x2; + fID x1 ++ + fSTRING_OPT x2 ++ fNODE "write_module" 2 +and fLEVEL = function +| CT_Opaque -> fNODE "opaque" 0 +| CT_Level n -> fINT n ++ fNODE "level" 1 +| CT_Expand -> fNODE "expand" 0 and fCOMMAND_LIST = function | CT_command_list(x,l) -> - fCOMMAND x; - (List.iter fCOMMAND l); + fCOMMAND x ++ + (List.fold_left (++) (mt()) (List.map fCOMMAND l)) ++ fNODE "command_list" (1 + (List.length l)) and fCOMMENT = function -| CT_comment x -> fATOM "comment"; - (f_atom_string x); - print_string "\n"and fCOMMENT_S = function +| CT_comment x -> fATOM "comment" ++ + (f_atom_string x) ++ + str "\n" +and fCOMMENT_S = function | CT_comment_s l -> - (List.iter fCOMMENT l); + (List.fold_left (++) (mt()) (List.map fCOMMENT l)) ++ fNODE "comment_s" (List.length l) and fCONSTR = function | CT_constr(x1, x2) -> - fID x1; - fFORMULA x2; + fID x1 ++ + fFORMULA x2 ++ fNODE "constr" 2 | CT_constr_coercion(x1, x2) -> - fID x1; - fFORMULA x2; + fID x1 ++ + fFORMULA x2 ++ fNODE "constr_coercion" 2 and fCONSTR_LIST = function | CT_constr_list l -> - (List.iter fCONSTR l); + (List.fold_left (++) (mt()) (List.map fCONSTR l)) ++ fNODE "constr_list" (List.length l) and fCONTEXT_HYP_LIST = function | CT_context_hyp_list l -> - (List.iter fPREMISE_PATTERN l); + (List.fold_left (++) (mt()) (List.map fPREMISE_PATTERN l)) ++ fNODE "context_hyp_list" (List.length l) and fCONTEXT_PATTERN = function | CT_coerce_FORMULA_to_CONTEXT_PATTERN x -> fFORMULA x | CT_context(x1, x2) -> - fID_OPT x1; - fFORMULA x2; + fID_OPT x1 ++ + fFORMULA x2 ++ fNODE "context" 2 and fCONTEXT_RULE = function | CT_context_rule(x1, x2, x3) -> - fCONTEXT_HYP_LIST x1; - fCONTEXT_PATTERN x2; - fTACTIC_COM x3; + fCONTEXT_HYP_LIST x1 ++ + fCONTEXT_PATTERN x2 ++ + fTACTIC_COM x3 ++ fNODE "context_rule" 3 | CT_def_context_rule(x1) -> - fTACTIC_COM x1; + fTACTIC_COM x1 ++ fNODE "def_context_rule" 1 and fCONVERSION_FLAG = function | CT_beta -> fNODE "beta" 0 @@ -687,49 +695,52 @@ and fCONVERSION_FLAG = function | CT_zeta -> fNODE "zeta" 0 and fCONVERSION_FLAG_LIST = function | CT_conversion_flag_list l -> - (List.iter fCONVERSION_FLAG l); + (List.fold_left (++) (mt()) (List.map fCONVERSION_FLAG l)) ++ fNODE "conversion_flag_list" (List.length l) and fCONV_SET = function | CT_unf l -> - (List.iter fID l); + (List.fold_left (++) (mt()) (List.map fID l)) ++ fNODE "unf" (List.length l) | CT_unfbut l -> - (List.iter fID l); + (List.fold_left (++) (mt()) (List.map fID l)) ++ fNODE "unfbut" (List.length l) and fCO_IND = function -| CT_co_ind x -> fATOM "co_ind"; - (f_atom_string x); - print_string "\n"and fDECL_NOTATION_OPT = function +| CT_co_ind x -> fATOM "co_ind" ++ + (f_atom_string x) ++ + str "\n" +and fDECL_NOTATION_OPT = function | CT_coerce_NONE_to_DECL_NOTATION_OPT x -> fNONE x | CT_decl_notation(x1, x2, x3) -> - fSTRING x1; - fFORMULA x2; - fID_OPT x3; + fSTRING x1 ++ + fFORMULA x2 ++ + fID_OPT x3 ++ fNODE "decl_notation" 3 and fDEF = function | CT_def(x1, x2) -> - fID_OPT x1; - fFORMULA x2; + fID_OPT x1 ++ + fFORMULA x2 ++ fNODE "def" 2 and fDEFN = function -| CT_defn x -> fATOM "defn"; - (f_atom_string x); - print_string "\n"and fDEFN_OR_THM = function +| CT_defn x -> fATOM "defn" ++ + (f_atom_string x) ++ + str "\n" +and fDEFN_OR_THM = function | CT_coerce_DEFN_to_DEFN_OR_THM x -> fDEFN x | CT_coerce_THM_to_DEFN_OR_THM x -> fTHM x and fDEF_BODY = function | CT_coerce_CONTEXT_PATTERN_to_DEF_BODY x -> fCONTEXT_PATTERN x | CT_coerce_EVAL_CMD_to_DEF_BODY x -> fEVAL_CMD x | CT_type_of(x1) -> - fFORMULA x1; + fFORMULA x1 ++ fNODE "type_of" 1 and fDEF_BODY_OPT = function | CT_coerce_DEF_BODY_to_DEF_BODY_OPT x -> fDEF_BODY x | CT_coerce_FORMULA_OPT_to_DEF_BODY_OPT x -> fFORMULA_OPT x and fDEP = function -| CT_dep x -> fATOM "dep"; - (f_atom_string x); - print_string "\n"and fDESTRUCTING = function +| CT_dep x -> fATOM "dep" ++ + (f_atom_string x) ++ + str "\n" +and fDESTRUCTING = function | CT_coerce_NONE_to_DESTRUCTING x -> fNONE x | CT_destructing -> fNODE "destructing" 0 and fDESTRUCT_LOCATION = function @@ -741,54 +752,54 @@ and fDOTDOT_OPT = function | CT_dotdot -> fNODE "dotdot" 0 and fEQN = function | CT_eqn(x1, x2) -> - fMATCH_PATTERN_NE_LIST x1; - fFORMULA x2; + fMATCH_PATTERN_NE_LIST x1 ++ + fFORMULA x2 ++ fNODE "eqn" 2 and fEQN_LIST = function | CT_eqn_list l -> - (List.iter fEQN l); + (List.fold_left (++) (mt()) (List.map fEQN l)) ++ fNODE "eqn_list" (List.length l) and fEVAL_CMD = function | CT_eval(x1, x2, x3) -> - fINT_OPT x1; - fRED_COM x2; - fFORMULA x3; + fINT_OPT x1 ++ + fRED_COM x2 ++ + fFORMULA x3 ++ fNODE "eval" 3 and fFIXTAC = function | CT_fixtac(x1, x2, x3) -> - fID x1; - fINT x2; - fFORMULA x3; + fID x1 ++ + fINT x2 ++ + fFORMULA x3 ++ fNODE "fixtac" 3 and fFIX_BINDER = function | CT_coerce_FIX_REC_to_FIX_BINDER x -> fFIX_REC x | CT_fix_binder(x1, x2, x3, x4) -> - fID x1; - fINT x2; - fFORMULA x3; - fFORMULA x4; + fID x1 ++ + fINT x2 ++ + fFORMULA x3 ++ + fFORMULA x4 ++ fNODE "fix_binder" 4 and fFIX_BINDER_LIST = function | CT_fix_binder_list(x,l) -> - fFIX_BINDER x; - (List.iter fFIX_BINDER l); + fFIX_BINDER x ++ + (List.fold_left (++) (mt()) (List.map fFIX_BINDER l)) ++ fNODE "fix_binder_list" (1 + (List.length l)) and fFIX_REC = function | CT_fix_rec(x1, x2, x3, x4, x5) -> - fID x1; - fBINDER_NE_LIST x2; - fID_OPT x3; - fFORMULA x4; - fFORMULA x5; + fID x1 ++ + fBINDER_NE_LIST x2 ++ + fID_OPT x3 ++ + fFORMULA x4 ++ + fFORMULA x5 ++ fNODE "fix_rec" 5 and fFIX_REC_LIST = function | CT_fix_rec_list(x,l) -> - fFIX_REC x; - (List.iter fFIX_REC l); + fFIX_REC x ++ + (List.fold_left (++) (mt()) (List.map fFIX_REC l)) ++ fNODE "fix_rec_list" (1 + (List.length l)) and fFIX_TAC_LIST = function | CT_fix_tac_list l -> - (List.iter fFIXTAC l); + (List.fold_left (++) (mt()) (List.map fFIXTAC l)) ++ fNODE "fix_tac_list" (List.length l) and fFORMULA = function | CT_coerce_BINARY_to_FORMULA x -> fBINARY x @@ -797,90 +808,90 @@ and fFORMULA = function | CT_coerce_SORT_TYPE_to_FORMULA x -> fSORT_TYPE x | CT_coerce_TYPED_FORMULA_to_FORMULA x -> fTYPED_FORMULA x | CT_appc(x1, x2) -> - fFORMULA x1; - fFORMULA_NE_LIST x2; + fFORMULA x1 ++ + fFORMULA_NE_LIST x2 ++ fNODE "appc" 2 | CT_arrowc(x1, x2) -> - fFORMULA x1; - fFORMULA x2; + fFORMULA x1 ++ + fFORMULA x2 ++ fNODE "arrowc" 2 | CT_bang(x1) -> - fFORMULA x1; + fFORMULA x1 ++ fNODE "bang" 1 | CT_cases(x1, x2, x3) -> - fMATCHED_FORMULA_NE_LIST x1; - fFORMULA_OPT x2; - fEQN_LIST x3; + fMATCHED_FORMULA_NE_LIST x1 ++ + fFORMULA_OPT x2 ++ + fEQN_LIST x3 ++ fNODE "cases" 3 | CT_cofixc(x1, x2) -> - fID x1; - fCOFIX_REC_LIST x2; + fID x1 ++ + fCOFIX_REC_LIST x2 ++ fNODE "cofixc" 2 | CT_elimc(x1, x2, x3, x4) -> - fCASE x1; - fFORMULA_OPT x2; - fFORMULA x3; - fFORMULA_LIST x4; + fCASE x1 ++ + fFORMULA_OPT x2 ++ + fFORMULA x3 ++ + fFORMULA_LIST x4 ++ fNODE "elimc" 4 | CT_existvarc -> fNODE "existvarc" 0 | CT_fixc(x1, x2) -> - fID x1; - fFIX_BINDER_LIST x2; + fID x1 ++ + fFIX_BINDER_LIST x2 ++ fNODE "fixc" 2 | CT_if(x1, x2, x3, x4) -> - fFORMULA x1; - fRETURN_INFO x2; - fFORMULA x3; - fFORMULA x4; + fFORMULA x1 ++ + fRETURN_INFO x2 ++ + fFORMULA x3 ++ + fFORMULA x4 ++ fNODE "if" 4 | CT_inductive_let(x1, x2, x3, x4) -> - fFORMULA_OPT x1; - fID_OPT_NE_LIST x2; - fFORMULA x3; - fFORMULA x4; + fFORMULA_OPT x1 ++ + fID_OPT_NE_LIST x2 ++ + fFORMULA x3 ++ + fFORMULA x4 ++ fNODE "inductive_let" 4 | CT_labelled_arg(x1, x2) -> - fID x1; - fFORMULA x2; + fID x1 ++ + fFORMULA x2 ++ fNODE "labelled_arg" 2 | CT_lambdac(x1, x2) -> - fBINDER_NE_LIST x1; - fFORMULA x2; + fBINDER_NE_LIST x1 ++ + fFORMULA x2 ++ fNODE "lambdac" 2 | CT_let_tuple(x1, x2, x3, x4) -> - fID_OPT_NE_LIST x1; - fRETURN_INFO x2; - fFORMULA x3; - fFORMULA x4; + fID_OPT_NE_LIST x1 ++ + fRETURN_INFO x2 ++ + fFORMULA x3 ++ + fFORMULA x4 ++ fNODE "let_tuple" 4 | CT_letin(x1, x2) -> - fDEF x1; - fFORMULA x2; + fDEF x1 ++ + fFORMULA x2 ++ fNODE "letin" 2 | CT_notation(x1, x2) -> - fSTRING x1; - fFORMULA_LIST x2; + fSTRING x1 ++ + fFORMULA_LIST x2 ++ fNODE "notation" 2 | CT_num_encapsulator(x1, x2) -> - fNUM_TYPE x1; - fFORMULA x2; + fNUM_TYPE x1 ++ + fFORMULA x2 ++ fNODE "num_encapsulator" 2 | CT_prodc(x1, x2) -> - fBINDER_NE_LIST x1; - fFORMULA x2; + fBINDER_NE_LIST x1 ++ + fFORMULA x2 ++ fNODE "prodc" 2 | CT_proj(x1, x2) -> - fFORMULA x1; - fFORMULA_NE_LIST x2; + fFORMULA x1 ++ + fFORMULA_NE_LIST x2 ++ fNODE "proj" 2 and fFORMULA_LIST = function | CT_formula_list l -> - (List.iter fFORMULA l); + (List.fold_left (++) (mt()) (List.map fFORMULA l)) ++ fNODE "formula_list" (List.length l) and fFORMULA_NE_LIST = function | CT_formula_ne_list(x,l) -> - fFORMULA x; - (List.iter fFORMULA l); + fFORMULA x ++ + (List.fold_left (++) (mt()) (List.map fFORMULA l)) ++ fNODE "formula_ne_list" (1 + (List.length l)) and fFORMULA_OPT = function | CT_coerce_FORMULA_to_FORMULA_OPT x -> fFORMULA x @@ -893,44 +904,46 @@ and fGRAMMAR = function and fHYP_LOCATION = function | CT_coerce_UNFOLD_to_HYP_LOCATION x -> fUNFOLD x | CT_intype(x1, x2) -> - fID x1; - fINT_LIST x2; + fID x1 ++ + fINT_LIST x2 ++ fNODE "intype" 2 | CT_invalue(x1, x2) -> - fID x1; - fINT_LIST x2; + fID x1 ++ + fINT_LIST x2 ++ fNODE "invalue" 2 and fHYP_LOCATION_LIST_OR_STAR = function | CT_coerce_STAR_to_HYP_LOCATION_LIST_OR_STAR x -> fSTAR x | CT_hyp_location_list l -> - (List.iter fHYP_LOCATION l); + (List.fold_left (++) (mt()) (List.map fHYP_LOCATION l)) ++ fNODE "hyp_location_list" (List.length l) and fID = function -| CT_ident x -> fATOM "ident"; - (f_atom_string x); - print_string "\n"| CT_metac(x1) -> - fINT x1; +| CT_ident x -> fATOM "ident" ++ + (f_atom_string x) ++ + str "\n" +| CT_metac(x1) -> + fINT x1 ++ fNODE "metac" 1 -| CT_metaid x -> fATOM "metaid"; - (f_atom_string x); - print_string "\n"and fIDENTITY_OPT = function +| CT_metaid x -> fATOM "metaid" ++ + (f_atom_string x) ++ + str "\n" +and fIDENTITY_OPT = function | CT_coerce_NONE_to_IDENTITY_OPT x -> fNONE x | CT_identity -> fNODE "identity" 0 and fID_LIST = function | CT_id_list l -> - (List.iter fID l); + (List.fold_left (++) (mt()) (List.map fID l)) ++ fNODE "id_list" (List.length l) and fID_LIST_LIST = function | CT_id_list_list l -> - (List.iter fID_LIST l); + (List.fold_left (++) (mt()) (List.map fID_LIST l)) ++ fNODE "id_list_list" (List.length l) and fID_LIST_OPT = function | CT_coerce_ID_LIST_to_ID_LIST_OPT x -> fID_LIST x | CT_coerce_NONE_to_ID_LIST_OPT x -> fNONE x and fID_NE_LIST = function | CT_id_ne_list(x,l) -> - fID x; - (List.iter fID l); + fID x ++ + (List.fold_left (++) (mt()) (List.map fID l)) ++ fNODE "id_ne_list" (1 + (List.length l)) and fID_NE_LIST_OR_STAR = function | CT_coerce_ID_NE_LIST_to_ID_NE_LIST_OR_STAR x -> fID_NE_LIST x @@ -943,12 +956,12 @@ and fID_OPT = function | CT_coerce_NONE_to_ID_OPT x -> fNONE x and fID_OPT_LIST = function | CT_id_opt_list l -> - (List.iter fID_OPT l); + (List.fold_left (++) (mt()) (List.map fID_OPT l)) ++ fNODE "id_opt_list" (List.length l) and fID_OPT_NE_LIST = function | CT_id_opt_ne_list(x,l) -> - fID_OPT x; - (List.iter fID_OPT l); + fID_OPT x ++ + (List.fold_left (++) (mt()) (List.map fID_OPT l)) ++ fNODE "id_opt_ne_list" (1 + (List.length l)) and fID_OPT_OR_ALL = function | CT_coerce_ID_OPT_to_ID_OPT_OR_ALL x -> fID_OPT x @@ -968,8 +981,8 @@ and fID_OR_STRING = function | CT_coerce_STRING_to_ID_OR_STRING x -> fSTRING x and fID_OR_STRING_NE_LIST = function | CT_id_or_string_ne_list(x,l) -> - fID_OR_STRING x; - (List.iter fID_OR_STRING l); + fID_OR_STRING x ++ + (List.fold_left (++) (mt()) (List.map fID_OR_STRING l)) ++ fNODE "id_or_string_ne_list" (1 + (List.length l)) and fIMPEXP = function | CT_coerce_NONE_to_IMPEXP x -> fNONE x @@ -977,40 +990,41 @@ and fIMPEXP = function | CT_import -> fNODE "import" 0 and fIND_SPEC = function | CT_ind_spec(x1, x2, x3, x4, x5) -> - fID x1; - fBINDER_LIST x2; - fFORMULA x3; - fCONSTR_LIST x4; - fDECL_NOTATION_OPT x5; + fID x1 ++ + fBINDER_LIST x2 ++ + fFORMULA x3 ++ + fCONSTR_LIST x4 ++ + fDECL_NOTATION_OPT x5 ++ fNODE "ind_spec" 5 and fIND_SPEC_LIST = function | CT_ind_spec_list l -> - (List.iter fIND_SPEC l); + (List.fold_left (++) (mt()) (List.map fIND_SPEC l)) ++ fNODE "ind_spec_list" (List.length l) and fINT = function -| CT_int x -> fATOM "int"; - (f_atom_int x); - print_string "\n"and fINTRO_PATT = function +| CT_int x -> fATOM "int" ++ + (f_atom_int x) ++ + str "\n" +and fINTRO_PATT = function | CT_coerce_ID_to_INTRO_PATT x -> fID x | CT_disj_pattern(x,l) -> - fINTRO_PATT_LIST x; - (List.iter fINTRO_PATT_LIST l); + fINTRO_PATT_LIST x ++ + (List.fold_left (++) (mt()) (List.map fINTRO_PATT_LIST l)) ++ fNODE "disj_pattern" (1 + (List.length l)) and fINTRO_PATT_LIST = function | CT_intro_patt_list l -> - (List.iter fINTRO_PATT l); + (List.fold_left (++) (mt()) (List.map fINTRO_PATT l)) ++ fNODE "intro_patt_list" (List.length l) and fINTRO_PATT_OPT = function | CT_coerce_ID_OPT_to_INTRO_PATT_OPT x -> fID_OPT x | CT_coerce_INTRO_PATT_to_INTRO_PATT_OPT x -> fINTRO_PATT x and fINT_LIST = function | CT_int_list l -> - (List.iter fINT l); + (List.fold_left (++) (mt()) (List.map fINT l)) ++ fNODE "int_list" (List.length l) and fINT_NE_LIST = function | CT_int_ne_list(x,l) -> - fINT x; - (List.iter fINT l); + fINT x ++ + (List.fold_left (++) (mt()) (List.map fINT l)) ++ fNODE "int_ne_list" (1 + (List.length l)) and fINT_OPT = function | CT_coerce_INT_to_INT_OPT x -> fINT x @@ -1028,21 +1042,21 @@ and fINV_TYPE = function and fIN_OR_OUT_MODULES = function | CT_coerce_NONE_to_IN_OR_OUT_MODULES x -> fNONE x | CT_in_modules(x1) -> - fID_NE_LIST x1; + fID_NE_LIST x1 ++ fNODE "in_modules" 1 | CT_out_modules(x1) -> - fID_NE_LIST x1; + fID_NE_LIST x1 ++ fNODE "out_modules" 1 and fLET_CLAUSE = function | CT_let_clause(x1, x2, x3) -> - fID x1; - fTACTIC_OPT x2; - fLET_VALUE x3; + fID x1 ++ + fTACTIC_OPT x2 ++ + fLET_VALUE x3 ++ fNODE "let_clause" 3 and fLET_CLAUSES = function | CT_let_clauses(x,l) -> - fLET_CLAUSE x; - (List.iter fLET_CLAUSE l); + fLET_CLAUSE x ++ + (List.fold_left (++) (mt()) (List.map fLET_CLAUSE l)) ++ fNODE "let_clauses" (1 + (List.length l)) and fLET_VALUE = function | CT_coerce_DEF_BODY_to_LET_VALUE x -> fDEF_BODY x @@ -1051,120 +1065,121 @@ and fLOCAL_OPT = function | CT_coerce_NONE_to_LOCAL_OPT x -> fNONE x | CT_local -> fNODE "local" 0 and fLOCN = function -| CT_locn x -> fATOM "locn"; - (f_atom_string x); - print_string "\n"and fMATCHED_FORMULA = function +| CT_locn x -> fATOM "locn" ++ + (f_atom_string x) ++ + str "\n" +and fMATCHED_FORMULA = function | CT_coerce_FORMULA_to_MATCHED_FORMULA x -> fFORMULA x | CT_formula_as(x1, x2) -> - fFORMULA x1; - fID_OPT x2; + fFORMULA x1 ++ + fID_OPT x2 ++ fNODE "formula_as" 2 | CT_formula_as_in(x1, x2, x3) -> - fFORMULA x1; - fID_OPT x2; - fFORMULA x3; + fFORMULA x1 ++ + fID_OPT x2 ++ + fFORMULA x3 ++ fNODE "formula_as_in" 3 | CT_formula_in(x1, x2) -> - fFORMULA x1; - fFORMULA x2; + fFORMULA x1 ++ + fFORMULA x2 ++ fNODE "formula_in" 2 and fMATCHED_FORMULA_NE_LIST = function | CT_matched_formula_ne_list(x,l) -> - fMATCHED_FORMULA x; - (List.iter fMATCHED_FORMULA l); + fMATCHED_FORMULA x ++ + (List.fold_left (++) (mt()) (List.map fMATCHED_FORMULA l)) ++ fNODE "matched_formula_ne_list" (1 + (List.length l)) and fMATCH_PATTERN = function | CT_coerce_ID_OPT_to_MATCH_PATTERN x -> fID_OPT x | CT_coerce_NUM_to_MATCH_PATTERN x -> fNUM x | CT_pattern_app(x1, x2) -> - fMATCH_PATTERN x1; - fMATCH_PATTERN_NE_LIST x2; + fMATCH_PATTERN x1 ++ + fMATCH_PATTERN_NE_LIST x2 ++ fNODE "pattern_app" 2 | CT_pattern_as(x1, x2) -> - fMATCH_PATTERN x1; - fID_OPT x2; + fMATCH_PATTERN x1 ++ + fID_OPT x2 ++ fNODE "pattern_as" 2 | CT_pattern_delimitors(x1, x2) -> - fNUM_TYPE x1; - fMATCH_PATTERN x2; + fNUM_TYPE x1 ++ + fMATCH_PATTERN x2 ++ fNODE "pattern_delimitors" 2 | CT_pattern_notation(x1, x2) -> - fSTRING x1; - fMATCH_PATTERN_LIST x2; + fSTRING x1 ++ + fMATCH_PATTERN_LIST x2 ++ fNODE "pattern_notation" 2 and fMATCH_PATTERN_LIST = function | CT_match_pattern_list l -> - (List.iter fMATCH_PATTERN l); + (List.fold_left (++) (mt()) (List.map fMATCH_PATTERN l)) ++ fNODE "match_pattern_list" (List.length l) and fMATCH_PATTERN_NE_LIST = function | CT_match_pattern_ne_list(x,l) -> - fMATCH_PATTERN x; - (List.iter fMATCH_PATTERN l); + fMATCH_PATTERN x ++ + (List.fold_left (++) (mt()) (List.map fMATCH_PATTERN l)) ++ fNODE "match_pattern_ne_list" (1 + (List.length l)) and fMATCH_TAC_RULE = function | CT_match_tac_rule(x1, x2) -> - fCONTEXT_PATTERN x1; - fLET_VALUE x2; + fCONTEXT_PATTERN x1 ++ + fLET_VALUE x2 ++ fNODE "match_tac_rule" 2 and fMATCH_TAC_RULES = function | CT_match_tac_rules(x,l) -> - fMATCH_TAC_RULE x; - (List.iter fMATCH_TAC_RULE l); + fMATCH_TAC_RULE x ++ + (List.fold_left (++) (mt()) (List.map fMATCH_TAC_RULE l)) ++ fNODE "match_tac_rules" (1 + (List.length l)) and fMODIFIER = function | CT_entry_type(x1, x2) -> - fID x1; - fID x2; + fID x1 ++ + fID x2 ++ fNODE "entry_type" 2 | CT_format(x1) -> - fSTRING x1; + fSTRING x1 ++ fNODE "format" 1 | CT_lefta -> fNODE "lefta" 0 | CT_nona -> fNODE "nona" 0 | CT_only_parsing -> fNODE "only_parsing" 0 | CT_righta -> fNODE "righta" 0 | CT_set_item_level(x1, x2) -> - fID_NE_LIST x1; - fINT_OR_NEXT x2; + fID_NE_LIST x1 ++ + fINT_OR_NEXT x2 ++ fNODE "set_item_level" 2 | CT_set_level(x1) -> - fINT x1; + fINT x1 ++ fNODE "set_level" 1 and fMODIFIER_LIST = function | CT_modifier_list l -> - (List.iter fMODIFIER l); + (List.fold_left (++) (mt()) (List.map fMODIFIER l)) ++ fNODE "modifier_list" (List.length l) and fMODULE_BINDER = function | CT_module_binder(x1, x2) -> - fID_NE_LIST x1; - fMODULE_TYPE x2; + fID_NE_LIST x1 ++ + fMODULE_TYPE x2 ++ fNODE "module_binder" 2 and fMODULE_BINDER_LIST = function | CT_module_binder_list l -> - (List.iter fMODULE_BINDER l); + (List.fold_left (++) (mt()) (List.map fMODULE_BINDER l)) ++ fNODE "module_binder_list" (List.length l) and fMODULE_EXPR = function | CT_coerce_ID_OPT_to_MODULE_EXPR x -> fID_OPT x | CT_module_app(x1, x2) -> - fMODULE_EXPR x1; - fMODULE_EXPR x2; + fMODULE_EXPR x1 ++ + fMODULE_EXPR x2 ++ fNODE "module_app" 2 and fMODULE_TYPE = function | CT_coerce_ID_to_MODULE_TYPE x -> fID x | CT_module_type_with_def(x1, x2, x3) -> - fMODULE_TYPE x1; - fID_LIST x2; - fFORMULA x3; + fMODULE_TYPE x1 ++ + fID_LIST x2 ++ + fFORMULA x3 ++ fNODE "module_type_with_def" 3 | CT_module_type_with_mod(x1, x2, x3) -> - fMODULE_TYPE x1; - fID_LIST x2; - fID x3; + fMODULE_TYPE x1 ++ + fID_LIST x2 ++ + fID x3 ++ fNODE "module_type_with_mod" 3 and fMODULE_TYPE_CHECK = function | CT_coerce_MODULE_TYPE_OPT_to_MODULE_TYPE_CHECK x -> fMODULE_TYPE_OPT x | CT_only_check(x1) -> - fMODULE_TYPE x1; + fMODULE_TYPE x1 ++ fNODE "only_check" 1 and fMODULE_TYPE_OPT = function | CT_coerce_ID_OPT_to_MODULE_TYPE_OPT x -> fID_OPT x @@ -1176,12 +1191,14 @@ and fNATURAL_FEATURE = function and fNONE = function | CT_none -> fNODE "none" 0 and fNUM = function -| CT_int_encapsulator x -> fATOM "int_encapsulator"; - (f_atom_string x); - print_string "\n"and fNUM_TYPE = function -| CT_num_type x -> fATOM "num_type"; - (f_atom_string x); - print_string "\n"and fOMEGA_FEATURE = function +| CT_int_encapsulator x -> fATOM "int_encapsulator" ++ + (f_atom_string x) ++ + str "\n" +and fNUM_TYPE = function +| CT_num_type x -> fATOM "num_type" ++ + (f_atom_string x) ++ + str "\n" +and fOMEGA_FEATURE = function | CT_coerce_STRING_to_OMEGA_FEATURE x -> fSTRING x | CT_flag_action -> fNODE "flag_action" 0 | CT_flag_system -> fNODE "flag_system" 0 @@ -1195,13 +1212,13 @@ and fORIENTATION = function | CT_rl -> fNODE "rl" 0 and fPATTERN = function | CT_pattern_occ(x1, x2) -> - fINT_LIST x1; - fFORMULA x2; + fINT_LIST x1 ++ + fFORMULA x2 ++ fNODE "pattern_occ" 2 and fPATTERN_NE_LIST = function | CT_pattern_ne_list(x,l) -> - fPATTERN x; - (List.iter fPATTERN l); + fPATTERN x ++ + (List.fold_left (++) (mt()) (List.map fPATTERN l)) ++ fNODE "pattern_ne_list" (1 + (List.length l)) and fPATTERN_OPT = function | CT_coerce_NONE_to_PATTERN_OPT x -> fNONE x @@ -1209,146 +1226,147 @@ and fPATTERN_OPT = function and fPREMISE = function | CT_coerce_TYPED_FORMULA_to_PREMISE x -> fTYPED_FORMULA x | CT_eval_result(x1, x2, x3) -> - fFORMULA x1; - fFORMULA x2; - fFORMULA x3; + fFORMULA x1 ++ + fFORMULA x2 ++ + fFORMULA x3 ++ fNODE "eval_result" 3 | CT_premise(x1, x2) -> - fID x1; - fFORMULA x2; + fID x1 ++ + fFORMULA x2 ++ fNODE "premise" 2 and fPREMISES_LIST = function | CT_premises_list l -> - (List.iter fPREMISE l); + (List.fold_left (++) (mt()) (List.map fPREMISE l)) ++ fNODE "premises_list" (List.length l) and fPREMISE_PATTERN = function | CT_premise_pattern(x1, x2) -> - fID_OPT x1; - fCONTEXT_PATTERN x2; + fID_OPT x1 ++ + fCONTEXT_PATTERN x2 ++ fNODE "premise_pattern" 2 and fPROOF_SCRIPT = function | CT_proof_script l -> - (List.iter fCOMMAND l); + (List.fold_left (++) (mt()) (List.map fCOMMAND l)) ++ fNODE "proof_script" (List.length l) and fRECCONSTR = function | CT_defrecconstr(x1, x2, x3) -> - fID_OPT x1; - fFORMULA x2; - fFORMULA_OPT x3; + fID_OPT x1 ++ + fFORMULA x2 ++ + fFORMULA_OPT x3 ++ fNODE "defrecconstr" 3 | CT_defrecconstr_coercion(x1, x2, x3) -> - fID_OPT x1; - fFORMULA x2; - fFORMULA_OPT x3; + fID_OPT x1 ++ + fFORMULA x2 ++ + fFORMULA_OPT x3 ++ fNODE "defrecconstr_coercion" 3 | CT_recconstr(x1, x2) -> - fID_OPT x1; - fFORMULA x2; + fID_OPT x1 ++ + fFORMULA x2 ++ fNODE "recconstr" 2 | CT_recconstr_coercion(x1, x2) -> - fID_OPT x1; - fFORMULA x2; + fID_OPT x1 ++ + fFORMULA x2 ++ fNODE "recconstr_coercion" 2 and fRECCONSTR_LIST = function | CT_recconstr_list l -> - (List.iter fRECCONSTR l); + (List.fold_left (++) (mt()) (List.map fRECCONSTR l)) ++ fNODE "recconstr_list" (List.length l) and fREC_TACTIC_FUN = function | CT_rec_tactic_fun(x1, x2, x3) -> - fID x1; - fID_OPT_NE_LIST x2; - fTACTIC_COM x3; + fID x1 ++ + fID_OPT_NE_LIST x2 ++ + fTACTIC_COM x3 ++ fNODE "rec_tactic_fun" 3 and fREC_TACTIC_FUN_LIST = function | CT_rec_tactic_fun_list(x,l) -> - fREC_TACTIC_FUN x; - (List.iter fREC_TACTIC_FUN l); + fREC_TACTIC_FUN x ++ + (List.fold_left (++) (mt()) (List.map fREC_TACTIC_FUN l)) ++ fNODE "rec_tactic_fun_list" (1 + (List.length l)) and fRED_COM = function | CT_cbv(x1, x2) -> - fCONVERSION_FLAG_LIST x1; - fCONV_SET x2; + fCONVERSION_FLAG_LIST x1 ++ + fCONV_SET x2 ++ fNODE "cbv" 2 | CT_fold(x1) -> - fFORMULA_LIST x1; + fFORMULA_LIST x1 ++ fNODE "fold" 1 | CT_hnf -> fNODE "hnf" 0 | CT_lazy(x1, x2) -> - fCONVERSION_FLAG_LIST x1; - fCONV_SET x2; + fCONVERSION_FLAG_LIST x1 ++ + fCONV_SET x2 ++ fNODE "lazy" 2 | CT_pattern(x1) -> - fPATTERN_NE_LIST x1; + fPATTERN_NE_LIST x1 ++ fNODE "pattern" 1 | CT_red -> fNODE "red" 0 | CT_cbvvm -> fNODE "vm_compute" 0 | CT_simpl(x1) -> - fPATTERN_OPT x1; + fPATTERN_OPT x1 ++ fNODE "simpl" 1 | CT_unfold(x1) -> - fUNFOLD_NE_LIST x1; + fUNFOLD_NE_LIST x1 ++ fNODE "unfold" 1 and fRETURN_INFO = function | CT_coerce_NONE_to_RETURN_INFO x -> fNONE x | CT_as_and_return(x1, x2) -> - fID_OPT x1; - fFORMULA x2; + fID_OPT x1 ++ + fFORMULA x2 ++ fNODE "as_and_return" 2 | CT_return(x1) -> - fFORMULA x1; + fFORMULA x1 ++ fNODE "return" 1 and fRULE = function | CT_rule(x1, x2) -> - fPREMISES_LIST x1; - fFORMULA x2; + fPREMISES_LIST x1 ++ + fFORMULA x2 ++ fNODE "rule" 2 and fRULE_LIST = function | CT_rule_list l -> - (List.iter fRULE l); + (List.fold_left (++) (mt()) (List.map fRULE l)) ++ fNODE "rule_list" (List.length l) and fSCHEME_SPEC = function | CT_scheme_spec(x1, x2, x3, x4) -> - fID x1; - fDEP x2; - fFORMULA x3; - fSORT_TYPE x4; + fID x1 ++ + fDEP x2 ++ + fFORMULA x3 ++ + fSORT_TYPE x4 ++ fNODE "scheme_spec" 4 and fSCHEME_SPEC_LIST = function | CT_scheme_spec_list(x,l) -> - fSCHEME_SPEC x; - (List.iter fSCHEME_SPEC l); + fSCHEME_SPEC x ++ + (List.fold_left (++) (mt()) (List.map fSCHEME_SPEC l)) ++ fNODE "scheme_spec_list" (1 + (List.length l)) and fSCOMMENT_CONTENT = function | CT_coerce_FORMULA_to_SCOMMENT_CONTENT x -> fFORMULA x | CT_coerce_ID_OR_STRING_to_SCOMMENT_CONTENT x -> fID_OR_STRING x and fSCOMMENT_CONTENT_LIST = function | CT_scomment_content_list l -> - (List.iter fSCOMMENT_CONTENT l); + (List.fold_left (++) (mt()) (List.map fSCOMMENT_CONTENT l)) ++ fNODE "scomment_content_list" (List.length l) and fSECTION_BEGIN = function | CT_section(x1) -> - fID x1; + fID x1 ++ fNODE "section" 1 and fSECTION_BODY = function | CT_section_body l -> - (List.iter fCOMMAND l); + (List.fold_left (++) (mt()) (List.map fCOMMAND l)) ++ fNODE "section_body" (List.length l) and fSIGNED_INT = function | CT_coerce_INT_to_SIGNED_INT x -> fINT x | CT_minus(x1) -> - fINT x1; + fINT x1 ++ fNODE "minus" 1 and fSIGNED_INT_LIST = function | CT_signed_int_list l -> - (List.iter fSIGNED_INT l); + (List.fold_left (++) (mt()) (List.map fSIGNED_INT l)) ++ fNODE "signed_int_list" (List.length l) and fSINGLE_OPTION_VALUE = function | CT_coerce_INT_to_SINGLE_OPTION_VALUE x -> fINT x | CT_coerce_STRING_to_SINGLE_OPTION_VALUE x -> fSTRING x and fSORT_TYPE = function -| CT_sortc x -> fATOM "sortc"; - (f_atom_string x); - print_string "\n"and fSPEC_LIST = function +| CT_sortc x -> fATOM "sortc" ++ + (f_atom_string x) ++ + str "\n" +and fSPEC_LIST = function | CT_coerce_BINDING_LIST_to_SPEC_LIST x -> fBINDING_LIST x | CT_coerce_FORMULA_LIST_to_SPEC_LIST x -> fFORMULA_LIST x and fSPEC_OPT = function @@ -1360,12 +1378,13 @@ and fSTAR_OPT = function | CT_coerce_NONE_to_STAR_OPT x -> fNONE x | CT_coerce_STAR_to_STAR_OPT x -> fSTAR x and fSTRING = function -| CT_string x -> fATOM "string"; - (f_atom_string x); - print_string "\n"and fSTRING_NE_LIST = function +| CT_string x -> fATOM "string" ++ + (f_atom_string x) ++ + str "\n" +and fSTRING_NE_LIST = function | CT_string_ne_list(x,l) -> - fSTRING x; - (List.iter fSTRING l); + fSTRING x ++ + (List.fold_left (++) (mt()) (List.map fSTRING l)) ++ fNODE "string_ne_list" (1 + (List.length l)) and fSTRING_OPT = function | CT_coerce_NONE_to_STRING_OPT x -> fNONE x @@ -1373,8 +1392,8 @@ and fSTRING_OPT = function and fTABLE = function | CT_coerce_ID_to_TABLE x -> fID x | CT_table(x1, x2) -> - fID x1; - fID x2; + fID x1 ++ + fID x2 ++ fNODE "table" 2 and fTACTIC_ARG = function | CT_coerce_EVAL_CMD_to_TACTIC_ARG x -> fEVAL_CMD x @@ -1384,429 +1403,429 @@ and fTACTIC_ARG = function | CT_void -> fNODE "void" 0 and fTACTIC_ARG_LIST = function | CT_tactic_arg_list(x,l) -> - fTACTIC_ARG x; - (List.iter fTACTIC_ARG l); + fTACTIC_ARG x ++ + (List.fold_left (++) (mt()) (List.map fTACTIC_ARG l)) ++ fNODE "tactic_arg_list" (1 + (List.length l)) and fTACTIC_COM = function | CT_abstract(x1, x2) -> - fID_OPT x1; - fTACTIC_COM x2; + fID_OPT x1 ++ + fTACTIC_COM x2 ++ fNODE "abstract" 2 | CT_absurd(x1) -> - fFORMULA x1; + fFORMULA x1 ++ fNODE "absurd" 1 | CT_any_constructor(x1) -> - fTACTIC_OPT x1; + fTACTIC_OPT x1 ++ fNODE "any_constructor" 1 | CT_apply(x1, x2) -> - fFORMULA x1; - fSPEC_LIST x2; + fFORMULA x1 ++ + fSPEC_LIST x2 ++ fNODE "apply" 2 | CT_assert(x1, x2) -> - fID_OPT x1; - fFORMULA x2; + fID_OPT x1 ++ + fFORMULA x2 ++ fNODE "assert" 2 | CT_assumption -> fNODE "assumption" 0 | CT_auto(x1) -> - fINT_OPT x1; + fINT_OPT x1 ++ fNODE "auto" 1 | CT_auto_with(x1, x2) -> - fINT_OPT x1; - fID_NE_LIST_OR_STAR x2; + fINT_OPT x1 ++ + fID_NE_LIST_OR_STAR x2 ++ fNODE "auto_with" 2 | CT_autorewrite(x1, x2) -> - fID_NE_LIST x1; - fTACTIC_OPT x2; + fID_NE_LIST x1 ++ + fTACTIC_OPT x2 ++ fNODE "autorewrite" 2 | CT_autotdb(x1) -> - fINT_OPT x1; + fINT_OPT x1 ++ fNODE "autotdb" 1 | CT_case_type(x1) -> - fFORMULA x1; + fFORMULA x1 ++ fNODE "case_type" 1 | CT_casetac(x1, x2) -> - fFORMULA x1; - fSPEC_LIST x2; + fFORMULA x1 ++ + fSPEC_LIST x2 ++ fNODE "casetac" 2 | CT_cdhyp(x1) -> - fID x1; + fID x1 ++ fNODE "cdhyp" 1 | CT_change(x1, x2) -> - fFORMULA x1; - fCLAUSE x2; + fFORMULA x1 ++ + fCLAUSE x2 ++ fNODE "change" 2 | CT_change_local(x1, x2, x3) -> - fPATTERN x1; - fFORMULA x2; - fCLAUSE x3; + fPATTERN x1 ++ + fFORMULA x2 ++ + fCLAUSE x3 ++ fNODE "change_local" 3 | CT_clear(x1) -> - fID_NE_LIST x1; + fID_NE_LIST x1 ++ fNODE "clear" 1 | CT_clear_body(x1) -> - fID_NE_LIST x1; + fID_NE_LIST x1 ++ fNODE "clear_body" 1 | CT_cofixtactic(x1, x2) -> - fID_OPT x1; - fCOFIX_TAC_LIST x2; + fID_OPT x1 ++ + fCOFIX_TAC_LIST x2 ++ fNODE "cofixtactic" 2 | CT_condrewrite_lr(x1, x2, x3, x4) -> - fTACTIC_COM x1; - fFORMULA x2; - fSPEC_LIST x3; - fID_OPT x4; + fTACTIC_COM x1 ++ + fFORMULA x2 ++ + fSPEC_LIST x3 ++ + fID_OPT x4 ++ fNODE "condrewrite_lr" 4 | CT_condrewrite_rl(x1, x2, x3, x4) -> - fTACTIC_COM x1; - fFORMULA x2; - fSPEC_LIST x3; - fID_OPT x4; + fTACTIC_COM x1 ++ + fFORMULA x2 ++ + fSPEC_LIST x3 ++ + fID_OPT x4 ++ fNODE "condrewrite_rl" 4 | CT_constructor(x1, x2) -> - fINT x1; - fSPEC_LIST x2; + fINT x1 ++ + fSPEC_LIST x2 ++ fNODE "constructor" 2 | CT_contradiction -> fNODE "contradiction" 0 | CT_contradiction_thm(x1, x2) -> - fFORMULA x1; - fSPEC_LIST x2; + fFORMULA x1 ++ + fSPEC_LIST x2 ++ fNODE "contradiction_thm" 2 | CT_cut(x1) -> - fFORMULA x1; + fFORMULA x1 ++ fNODE "cut" 1 | CT_cutrewrite_lr(x1, x2) -> - fFORMULA x1; - fID_OPT x2; + fFORMULA x1 ++ + fID_OPT x2 ++ fNODE "cutrewrite_lr" 2 | CT_cutrewrite_rl(x1, x2) -> - fFORMULA x1; - fID_OPT x2; + fFORMULA x1 ++ + fID_OPT x2 ++ fNODE "cutrewrite_rl" 2 | CT_dauto(x1, x2) -> - fINT_OPT x1; - fINT_OPT x2; + fINT_OPT x1 ++ + fINT_OPT x2 ++ fNODE "dauto" 2 | CT_dconcl -> fNODE "dconcl" 0 | CT_decompose_list(x1, x2) -> - fID_NE_LIST x1; - fFORMULA x2; + fID_NE_LIST x1 ++ + fFORMULA x2 ++ fNODE "decompose_list" 2 | CT_decompose_record(x1) -> - fFORMULA x1; + fFORMULA x1 ++ fNODE "decompose_record" 1 | CT_decompose_sum(x1) -> - fFORMULA x1; + fFORMULA x1 ++ fNODE "decompose_sum" 1 | CT_depinversion(x1, x2, x3, x4) -> - fINV_TYPE x1; - fID_OR_INT x2; - fINTRO_PATT_OPT x3; - fFORMULA_OPT x4; + fINV_TYPE x1 ++ + fID_OR_INT x2 ++ + fINTRO_PATT_OPT x3 ++ + fFORMULA_OPT x4 ++ fNODE "depinversion" 4 | CT_deprewrite_lr(x1) -> - fID x1; + fID x1 ++ fNODE "deprewrite_lr" 1 | CT_deprewrite_rl(x1) -> - fID x1; + fID x1 ++ fNODE "deprewrite_rl" 1 | CT_destruct(x1) -> - fID_OR_INT x1; + fID_OR_INT x1 ++ fNODE "destruct" 1 | CT_dhyp(x1) -> - fID x1; + fID x1 ++ fNODE "dhyp" 1 | CT_discriminate_eq(x1) -> - fID_OR_INT_OPT x1; + fID_OR_INT_OPT x1 ++ fNODE "discriminate_eq" 1 | CT_do(x1, x2) -> - fID_OR_INT x1; - fTACTIC_COM x2; + fID_OR_INT x1 ++ + fTACTIC_COM x2 ++ fNODE "do" 2 | CT_eapply(x1, x2) -> - fFORMULA x1; - fSPEC_LIST x2; + fFORMULA x1 ++ + fSPEC_LIST x2 ++ fNODE "eapply" 2 | CT_eauto(x1, x2) -> - fID_OR_INT_OPT x1; - fID_OR_INT_OPT x2; + fID_OR_INT_OPT x1 ++ + fID_OR_INT_OPT x2 ++ fNODE "eauto" 2 | CT_eauto_with(x1, x2, x3) -> - fID_OR_INT_OPT x1; - fID_OR_INT_OPT x2; - fID_NE_LIST_OR_STAR x3; + fID_OR_INT_OPT x1 ++ + fID_OR_INT_OPT x2 ++ + fID_NE_LIST_OR_STAR x3 ++ fNODE "eauto_with" 3 | CT_elim(x1, x2, x3) -> - fFORMULA x1; - fSPEC_LIST x2; - fUSING x3; + fFORMULA x1 ++ + fSPEC_LIST x2 ++ + fUSING x3 ++ fNODE "elim" 3 | CT_elim_type(x1) -> - fFORMULA x1; + fFORMULA x1 ++ fNODE "elim_type" 1 | CT_exact(x1) -> - fFORMULA x1; + fFORMULA x1 ++ fNODE "exact" 1 | CT_exact_no_check(x1) -> - fFORMULA x1; + fFORMULA x1 ++ fNODE "exact_no_check" 1 | CT_vm_cast_no_check(x1) -> - fFORMULA x1; + fFORMULA x1 ++ fNODE "vm_cast_no_check" 1 | CT_exists(x1) -> - fSPEC_LIST x1; + fSPEC_LIST x1 ++ fNODE "exists" 1 | CT_fail(x1, x2) -> - fID_OR_INT x1; - fSTRING_OPT x2; + fID_OR_INT x1 ++ + fSTRING_OPT x2 ++ fNODE "fail" 2 | CT_first(x,l) -> - fTACTIC_COM x; - (List.iter fTACTIC_COM l); + fTACTIC_COM x ++ + (List.fold_left (++) (mt()) (List.map fTACTIC_COM l)) ++ fNODE "first" (1 + (List.length l)) | CT_firstorder(x1) -> - fTACTIC_OPT x1; + fTACTIC_OPT x1 ++ fNODE "firstorder" 1 | CT_firstorder_using(x1, x2) -> - fTACTIC_OPT x1; - fID_NE_LIST x2; + fTACTIC_OPT x1 ++ + fID_NE_LIST x2 ++ fNODE "firstorder_using" 2 | CT_firstorder_with(x1, x2) -> - fTACTIC_OPT x1; - fID_NE_LIST x2; + fTACTIC_OPT x1 ++ + fID_NE_LIST x2 ++ fNODE "firstorder_with" 2 | CT_fixtactic(x1, x2, x3) -> - fID_OPT x1; - fINT x2; - fFIX_TAC_LIST x3; + fID_OPT x1 ++ + fINT x2 ++ + fFIX_TAC_LIST x3 ++ fNODE "fixtactic" 3 | CT_formula_marker(x1) -> - fFORMULA x1; + fFORMULA x1 ++ fNODE "formula_marker" 1 | CT_fresh(x1) -> - fSTRING_OPT x1; + fSTRING_OPT x1 ++ fNODE "fresh" 1 | CT_generalize(x1) -> - fFORMULA_NE_LIST x1; + fFORMULA_NE_LIST x1 ++ fNODE "generalize" 1 | CT_generalize_dependent(x1) -> - fFORMULA x1; + fFORMULA x1 ++ fNODE "generalize_dependent" 1 | CT_idtac(x1) -> - fSTRING_OPT x1; + fSTRING_OPT x1 ++ fNODE "idtac" 1 | CT_induction(x1) -> - fID_OR_INT x1; + fID_OR_INT x1 ++ fNODE "induction" 1 | CT_info(x1) -> - fTACTIC_COM x1; + fTACTIC_COM x1 ++ fNODE "info" 1 | CT_injection_eq(x1) -> - fID_OR_INT_OPT x1; + fID_OR_INT_OPT x1 ++ fNODE "injection_eq" 1 | CT_instantiate(x1, x2, x3) -> - fINT x1; - fFORMULA x2; - fCLAUSE x3; + fINT x1 ++ + fFORMULA x2 ++ + fCLAUSE x3 ++ fNODE "instantiate" 3 | CT_intro(x1) -> - fID_OPT x1; + fID_OPT x1 ++ fNODE "intro" 1 | CT_intro_after(x1, x2) -> - fID_OPT x1; - fID x2; + fID_OPT x1 ++ + fID x2 ++ fNODE "intro_after" 2 | CT_intros(x1) -> - fINTRO_PATT_LIST x1; + fINTRO_PATT_LIST x1 ++ fNODE "intros" 1 | CT_intros_until(x1) -> - fID_OR_INT x1; + fID_OR_INT x1 ++ fNODE "intros_until" 1 | CT_inversion(x1, x2, x3, x4) -> - fINV_TYPE x1; - fID_OR_INT x2; - fINTRO_PATT_OPT x3; - fID_LIST x4; + fINV_TYPE x1 ++ + fID_OR_INT x2 ++ + fINTRO_PATT_OPT x3 ++ + fID_LIST x4 ++ fNODE "inversion" 4 | CT_left(x1) -> - fSPEC_LIST x1; + fSPEC_LIST x1 ++ fNODE "left" 1 | CT_let_ltac(x1, x2) -> - fLET_CLAUSES x1; - fLET_VALUE x2; + fLET_CLAUSES x1 ++ + fLET_VALUE x2 ++ fNODE "let_ltac" 2 | CT_lettac(x1, x2, x3) -> - fID_OPT x1; - fFORMULA x2; - fCLAUSE x3; + fID_OPT x1 ++ + fFORMULA x2 ++ + fCLAUSE x3 ++ fNODE "lettac" 3 | CT_match_context(x,l) -> - fCONTEXT_RULE x; - (List.iter fCONTEXT_RULE l); + fCONTEXT_RULE x ++ + (List.fold_left (++) (mt()) (List.map fCONTEXT_RULE l)) ++ fNODE "match_context" (1 + (List.length l)) | CT_match_context_reverse(x,l) -> - fCONTEXT_RULE x; - (List.iter fCONTEXT_RULE l); + fCONTEXT_RULE x ++ + (List.fold_left (++) (mt()) (List.map fCONTEXT_RULE l)) ++ fNODE "match_context_reverse" (1 + (List.length l)) | CT_match_tac(x1, x2) -> - fTACTIC_COM x1; - fMATCH_TAC_RULES x2; + fTACTIC_COM x1 ++ + fMATCH_TAC_RULES x2 ++ fNODE "match_tac" 2 | CT_move_after(x1, x2) -> - fID x1; - fID x2; + fID x1 ++ + fID x2 ++ fNODE "move_after" 2 | CT_new_destruct(x1, x2, x3) -> - (List.iter fFORMULA_OR_INT x1); (* Julien F. Est-ce correct? *) - fUSING x2; - fINTRO_PATT_OPT x3; + (List.fold_left (++) (mt()) (List.map fFORMULA_OR_INT x1)) ++ (* Julien F. Est-ce correct? *) + fUSING x2 ++ + fINTRO_PATT_OPT x3 ++ fNODE "new_destruct" 3 | CT_new_induction(x1, x2, x3) -> - (List.iter fFORMULA_OR_INT x1); (* Pierre C. Est-ce correct? *) - fUSING x2; - fINTRO_PATT_OPT x3; + (List.fold_left (++) (mt()) (List.map fFORMULA_OR_INT x1)) ++ (* Pierre C. Est-ce correct? *) + fUSING x2 ++ + fINTRO_PATT_OPT x3 ++ fNODE "new_induction" 3 | CT_omega -> fNODE "omega" 0 | CT_orelse(x1, x2) -> - fTACTIC_COM x1; - fTACTIC_COM x2; + fTACTIC_COM x1 ++ + fTACTIC_COM x2 ++ fNODE "orelse" 2 | CT_parallel(x,l) -> - fTACTIC_COM x; - (List.iter fTACTIC_COM l); + fTACTIC_COM x ++ + (List.fold_left (++) (mt()) (List.map fTACTIC_COM l)) ++ fNODE "parallel" (1 + (List.length l)) | CT_pose(x1, x2) -> - fID_OPT x1; - fFORMULA x2; + fID_OPT x1 ++ + fFORMULA x2 ++ fNODE "pose" 2 | CT_progress(x1) -> - fTACTIC_COM x1; + fTACTIC_COM x1 ++ fNODE "progress" 1 | CT_prolog(x1, x2) -> - fFORMULA_LIST x1; - fINT x2; + fFORMULA_LIST x1 ++ + fINT x2 ++ fNODE "prolog" 2 | CT_rec_tactic_in(x1, x2) -> - fREC_TACTIC_FUN_LIST x1; - fTACTIC_COM x2; + fREC_TACTIC_FUN_LIST x1 ++ + fTACTIC_COM x2 ++ fNODE "rec_tactic_in" 2 | CT_reduce(x1, x2) -> - fRED_COM x1; - fCLAUSE x2; + fRED_COM x1 ++ + fCLAUSE x2 ++ fNODE "reduce" 2 | CT_refine(x1) -> - fFORMULA x1; + fFORMULA x1 ++ fNODE "refine" 1 | CT_reflexivity -> fNODE "reflexivity" 0 | CT_rename(x1, x2) -> - fID x1; - fID x2; + fID x1 ++ + fID x2 ++ fNODE "rename" 2 | CT_repeat(x1) -> - fTACTIC_COM x1; + fTACTIC_COM x1 ++ fNODE "repeat" 1 | CT_replace_with(x1, x2,x3,x4) -> - fFORMULA x1; - fFORMULA x2; - fCLAUSE x3; - fTACTIC_OPT x4; + fFORMULA x1 ++ + fFORMULA x2 ++ + fCLAUSE x3 ++ + fTACTIC_OPT x4 ++ fNODE "replace_with" 4 | CT_rewrite_lr(x1, x2, x3) -> - fFORMULA x1; - fSPEC_LIST x2; - fCLAUSE x3; + fFORMULA x1 ++ + fSPEC_LIST x2 ++ + fCLAUSE x3 ++ fNODE "rewrite_lr" 3 | CT_rewrite_rl(x1, x2, x3) -> - fFORMULA x1; - fSPEC_LIST x2; - fCLAUSE x3; + fFORMULA x1 ++ + fSPEC_LIST x2 ++ + fCLAUSE x3 ++ fNODE "rewrite_rl" 3 | CT_right(x1) -> - fSPEC_LIST x1; + fSPEC_LIST x1 ++ fNODE "right" 1 | CT_ring(x1) -> - fFORMULA_LIST x1; + fFORMULA_LIST x1 ++ fNODE "ring" 1 | CT_simple_user_tac(x1, x2) -> - fID x1; - fTACTIC_ARG_LIST x2; + fID x1 ++ + fTACTIC_ARG_LIST x2 ++ fNODE "simple_user_tac" 2 | CT_simplify_eq(x1) -> - fID_OR_INT_OPT x1; + fID_OR_INT_OPT x1 ++ fNODE "simplify_eq" 1 | CT_specialize(x1, x2, x3) -> - fINT_OPT x1; - fFORMULA x2; - fSPEC_LIST x3; + fINT_OPT x1 ++ + fFORMULA x2 ++ + fSPEC_LIST x3 ++ fNODE "specialize" 3 | CT_split(x1) -> - fSPEC_LIST x1; + fSPEC_LIST x1 ++ fNODE "split" 1 | CT_subst(x1) -> - fID_LIST x1; + fID_LIST x1 ++ fNODE "subst" 1 | CT_superauto(x1, x2, x3, x4) -> - fINT_OPT x1; - fID_LIST x2; - fDESTRUCTING x3; - fUSINGTDB x4; + fINT_OPT x1 ++ + fID_LIST x2 ++ + fDESTRUCTING x3 ++ + fUSINGTDB x4 ++ fNODE "superauto" 4 | CT_symmetry(x1) -> - fCLAUSE x1; + fCLAUSE x1 ++ fNODE "symmetry" 1 | CT_tac_double(x1, x2) -> - fID_OR_INT x1; - fID_OR_INT x2; + fID_OR_INT x1 ++ + fID_OR_INT x2 ++ fNODE "tac_double" 2 | CT_tacsolve(x,l) -> - fTACTIC_COM x; - (List.iter fTACTIC_COM l); + fTACTIC_COM x ++ + (List.fold_left (++) (mt()) (List.map fTACTIC_COM l)) ++ fNODE "tacsolve" (1 + (List.length l)) | CT_tactic_fun(x1, x2) -> - fID_OPT_NE_LIST x1; - fTACTIC_COM x2; + fID_OPT_NE_LIST x1 ++ + fTACTIC_COM x2 ++ fNODE "tactic_fun" 2 | CT_then(x,l) -> - fTACTIC_COM x; - (List.iter fTACTIC_COM l); + fTACTIC_COM x ++ + (List.fold_left (++) (mt()) (List.map fTACTIC_COM l)) ++ fNODE "then" (1 + (List.length l)) | CT_transitivity(x1) -> - fFORMULA x1; + fFORMULA x1 ++ fNODE "transitivity" 1 | CT_trivial -> fNODE "trivial" 0 | CT_trivial_with(x1) -> - fID_NE_LIST_OR_STAR x1; + fID_NE_LIST_OR_STAR x1 ++ fNODE "trivial_with" 1 | CT_truecut(x1, x2) -> - fID_OPT x1; - fFORMULA x2; + fID_OPT x1 ++ + fFORMULA x2 ++ fNODE "truecut" 2 | CT_try(x1) -> - fTACTIC_COM x1; + fTACTIC_COM x1 ++ fNODE "try" 1 | CT_use(x1) -> - fFORMULA x1; + fFORMULA x1 ++ fNODE "use" 1 | CT_use_inversion(x1, x2, x3) -> - fID_OR_INT x1; - fFORMULA x2; - fID_LIST x3; + fID_OR_INT x1 ++ + fFORMULA x2 ++ + fID_LIST x3 ++ fNODE "use_inversion" 3 | CT_user_tac(x1, x2) -> - fID x1; - fTARG_LIST x2; + fID x1 ++ + fTARG_LIST x2 ++ fNODE "user_tac" 2 and fTACTIC_OPT = function | CT_coerce_NONE_to_TACTIC_OPT x -> fNONE x | CT_coerce_TACTIC_COM_to_TACTIC_OPT x -> fTACTIC_COM x and fTAC_DEF = function | CT_tac_def(x1, x2) -> - fID x1; - fTACTIC_COM x2; + fID x1 ++ + fTACTIC_COM x2 ++ fNODE "tac_def" 2 and fTAC_DEF_NE_LIST = function | CT_tac_def_ne_list(x,l) -> - fTAC_DEF x; - (List.iter fTAC_DEF l); + fTAC_DEF x ++ + (List.fold_left (++) (mt()) (List.map fTAC_DEF l)) ++ fNODE "tac_def_ne_list" (1 + (List.length l)) and fTARG = function | CT_coerce_BINDING_to_TARG x -> fBINDING x @@ -1824,81 +1843,83 @@ and fTARG = function | CT_coerce_UNFOLD_NE_LIST_to_TARG x -> fUNFOLD_NE_LIST x and fTARG_LIST = function | CT_targ_list l -> - (List.iter fTARG l); + (List.fold_left (++) (mt()) (List.map fTARG l)) ++ fNODE "targ_list" (List.length l) and fTERM_CHANGE = function | CT_check_term(x1) -> - fFORMULA x1; + fFORMULA x1 ++ fNODE "check_term" 1 | CT_inst_term(x1, x2) -> - fID x1; - fFORMULA x2; + fID x1 ++ + fFORMULA x2 ++ fNODE "inst_term" 2 and fTEXT = function | CT_coerce_ID_to_TEXT x -> fID x | CT_text_formula(x1) -> - fFORMULA x1; + fFORMULA x1 ++ fNODE "text_formula" 1 | CT_text_h l -> - (List.iter fTEXT l); + (List.fold_left (++) (mt()) (List.map fTEXT l)) ++ fNODE "text_h" (List.length l) | CT_text_hv l -> - (List.iter fTEXT l); + (List.fold_left (++) (mt()) (List.map fTEXT l)) ++ fNODE "text_hv" (List.length l) | CT_text_op l -> - (List.iter fTEXT l); + (List.fold_left (++) (mt()) (List.map fTEXT l)) ++ fNODE "text_op" (List.length l) | CT_text_path(x1) -> - fSIGNED_INT_LIST x1; + fSIGNED_INT_LIST x1 ++ fNODE "text_path" 1 | CT_text_v l -> - (List.iter fTEXT l); + (List.fold_left (++) (mt()) (List.map fTEXT l)) ++ fNODE "text_v" (List.length l) and fTHEOREM_GOAL = function | CT_goal(x1) -> - fFORMULA x1; + fFORMULA x1 ++ fNODE "goal" 1 | CT_theorem_goal(x1, x2, x3, x4) -> - fDEFN_OR_THM x1; - fID x2; - fBINDER_LIST x3; - fFORMULA x4; + fDEFN_OR_THM x1 ++ + fID x2 ++ + fBINDER_LIST x3 ++ + fFORMULA x4 ++ fNODE "theorem_goal" 4 and fTHM = function -| CT_thm x -> fATOM "thm"; - (f_atom_string x); - print_string "\n"and fTHM_OPT = function +| CT_thm x -> fATOM "thm" ++ + (f_atom_string x) ++ + str "\n" +and fTHM_OPT = function | CT_coerce_NONE_to_THM_OPT x -> fNONE x | CT_coerce_THM_to_THM_OPT x -> fTHM x and fTYPED_FORMULA = function | CT_typed_formula(x1, x2) -> - fFORMULA x1; - fFORMULA x2; + fFORMULA x1 ++ + fFORMULA x2 ++ fNODE "typed_formula" 2 and fUNFOLD = function | CT_coerce_ID_to_UNFOLD x -> fID x | CT_unfold_occ(x1, x2) -> - fID x1; - fINT_NE_LIST x2; + fID x1 ++ + fINT_NE_LIST x2 ++ fNODE "unfold_occ" 2 and fUNFOLD_NE_LIST = function | CT_unfold_ne_list(x,l) -> - fUNFOLD x; - (List.iter fUNFOLD l); + fUNFOLD x ++ + (List.fold_left (++) (mt()) (List.map fUNFOLD l)) ++ fNODE "unfold_ne_list" (1 + (List.length l)) and fUSING = function | CT_coerce_NONE_to_USING x -> fNONE x | CT_using(x1, x2) -> - fFORMULA x1; - fSPEC_LIST x2; + fFORMULA x1 ++ + fSPEC_LIST x2 ++ fNODE "using" 2 and fUSINGTDB = function | CT_coerce_NONE_to_USINGTDB x -> fNONE x | CT_usingtdb -> fNODE "usingtdb" 0 and fVAR = function -| CT_var x -> fATOM "var"; - (f_atom_string x); - print_string "\n"and fVARG = function +| CT_var x -> fATOM "var" ++ + (f_atom_string x) ++ + str "\n" +and fVARG = function | CT_coerce_AST_to_VARG x -> fAST x | CT_coerce_AST_LIST_to_VARG x -> fAST_LIST x | CT_coerce_BINDER_to_VARG x -> fBINDER x @@ -1916,7 +1937,7 @@ and fVAR = function | CT_coerce_VARG_LIST_to_VARG x -> fVARG_LIST x and fVARG_LIST = function | CT_varg_list l -> - (List.iter fVARG l); + (List.fold_left (++) (mt()) (List.map fVARG l)) ++ fNODE "varg_list" (List.length l) and fVERBOSE_OPT = function | CT_coerce_NONE_to_VERBOSE_OPT x -> fNONE x diff --git a/contrib/interface/vtp.mli b/contrib/interface/vtp.mli index fe30b317..d7bd8db5 100644 --- a/contrib/interface/vtp.mli +++ b/contrib/interface/vtp.mli @@ -1,15 +1,16 @@ open Ascent;; +open Pp;; -val fCOMMAND_LIST : ct_COMMAND_LIST -> unit;; -val fCOMMAND : ct_COMMAND -> unit;; -val fTACTIC_COM : ct_TACTIC_COM -> unit;; -val fFORMULA : ct_FORMULA -> unit;; -val fID : ct_ID -> unit;; -val fSTRING : ct_STRING -> unit;; -val fINT : ct_INT -> unit;; -val fRULE_LIST : ct_RULE_LIST -> unit;; -val fRULE : ct_RULE -> unit;; -val fSIGNED_INT_LIST : ct_SIGNED_INT_LIST -> unit;; -val fPREMISES_LIST : ct_PREMISES_LIST -> unit;; -val fID_LIST : ct_ID_LIST -> unit;; -val fTEXT : ct_TEXT -> unit;;
\ No newline at end of file +val fCOMMAND_LIST : ct_COMMAND_LIST -> std_ppcmds;; +val fCOMMAND : ct_COMMAND -> std_ppcmds;; +val fTACTIC_COM : ct_TACTIC_COM -> std_ppcmds;; +val fFORMULA : ct_FORMULA -> std_ppcmds;; +val fID : ct_ID -> std_ppcmds;; +val fSTRING : ct_STRING -> std_ppcmds;; +val fINT : ct_INT -> std_ppcmds;; +val fRULE_LIST : ct_RULE_LIST -> std_ppcmds;; +val fRULE : ct_RULE -> std_ppcmds;; +val fSIGNED_INT_LIST : ct_SIGNED_INT_LIST -> std_ppcmds;; +val fPREMISES_LIST : ct_PREMISES_LIST -> std_ppcmds;; +val fID_LIST : ct_ID_LIST -> std_ppcmds;; +val fTEXT : ct_TEXT -> std_ppcmds;; diff --git a/contrib/interface/xlate.ml b/contrib/interface/xlate.ml index df03a579..7d1f57fe 100644 --- a/contrib/interface/xlate.ml +++ b/contrib/interface/xlate.ml @@ -15,12 +15,6 @@ open Libnames;; open Goptions;; -let in_coq_ref = ref false;; - -let declare_in_coq () = in_coq_ref:=true;; - -let in_coq () = !in_coq_ref;; - (* // Verify whether this is dead code, as of coq version 7 *) (* The following three sentences have been added to cope with a change of strategy from the Coq team in the way rules construct ast's. The @@ -203,6 +197,10 @@ let xlate_int_or_var_opt_to_int_opt = function | Some (ArgVar _) -> xlate_error "int_or_var: TODO" | None -> CT_coerce_NONE_to_INT_OPT CT_none +let apply_or_by_notation f = function + | AN x -> f x + | ByNotation _ -> xlate_error "TODO: ByNotation" + let tac_qualid_to_ct_ID ref = CT_ident (Libnames.string_of_qualid (snd (qualid_of_reference ref))) @@ -307,14 +305,10 @@ let make_fix_struct (n,bl) = let names = names_of_local_assums bl in let nn = List.length names in if nn = 1 || n = None then ctv_ID_OPT_NONE - else - let n = out_some n in - if n < nn then xlate_id_opt(List.nth names n) - else xlate_error "unexpected result of parsing for Fixpoint";; - + else ctf_ID_OPT_SOME(CT_ident (string_of_id (snd (Option.get n))));; let rec xlate_binder = function - (l,t) -> CT_binder(xlate_id_opt_ne_list l, xlate_formula t) + (l,k,t) -> CT_binder(xlate_id_opt_ne_list l, xlate_formula t) and xlate_return_info = function | (Some Anonymous, None) | (None, None) -> CT_coerce_NONE_to_RETURN_INFO CT_none @@ -327,7 +321,7 @@ and xlate_formula_opt = | Some e -> CT_coerce_FORMULA_to_FORMULA_OPT (xlate_formula e) and xlate_binder_l = function - LocalRawAssum(l,t) -> CT_binder(xlate_id_opt_ne_list l, xlate_formula t) + LocalRawAssum(l,_,t) -> CT_binder(xlate_id_opt_ne_list l, xlate_formula t) | LocalRawDef(n,v) -> CT_coerce_DEF_to_BINDER(CT_def(xlate_id_opt n, xlate_formula v)) and @@ -336,7 +330,7 @@ and | a::l -> CT_match_pattern_ne_list(xlate_match_pattern a, List.map xlate_match_pattern l) and translate_one_equation = function - (_,[lp], a) -> CT_eqn (xlate_match_pattern_ne_list lp, xlate_formula a) + (_,[_,lp], a) -> CT_eqn (xlate_match_pattern_ne_list lp, xlate_formula a) | _ -> xlate_error "TODO: disjunctive multiple patterns" and xlate_binder_ne_list = function @@ -379,8 +373,8 @@ and (xlate_formula:Topconstr.constr_expr -> Ascent.ct_FORMULA) = function (xlate_formula f, List.map xlate_formula_expl l')) | CApp(_, (_,f), l) -> CT_appc(xlate_formula f, xlate_formula_expl_ne_list l) - | CCases (_, _, [], _) -> assert false - | CCases (_, ret_type, tm::tml, eqns)-> + | CCases (_, _, _, [], _) -> assert false + | CCases (_, _, ret_type, tm::tml, eqns)-> CT_cases(CT_matched_formula_ne_list(xlate_matched_formula tm, List.map xlate_matched_formula tml), xlate_formula_opt ret_type, @@ -418,23 +412,16 @@ and (xlate_formula:Topconstr.constr_expr -> Ascent.ct_FORMULA) = function CT_coerce_ID_to_FORMULA(CT_metaid (string_of_id s)) | CPatVar (_, (true, s)) -> xlate_error "Second order variable not supported" - | CEvar (_, _) -> xlate_error "CEvar not supported" + | CEvar _ -> xlate_error "CEvar not supported" | CCoFix (_, (_, id), lm::lmi) -> - let strip_mutcorec (fid, bl,arf, ardef) = + let strip_mutcorec ((_, fid), bl,arf, ardef) = CT_cofix_rec (xlate_ident fid, xlate_binder_list bl, xlate_formula arf, xlate_formula ardef) in CT_cofixc(xlate_ident id, (CT_cofix_rec_list (strip_mutcorec lm, List.map strip_mutcorec lmi))) | CFix (_, (_, id), lm::lmi) -> - let strip_mutrec (fid, (n, ro), bl, arf, ardef) = - let (struct_arg,bl,arf,ardef) = - (* Pierre L: could the case [n=None && bl=[]] happen ? Normally not *) - (* By the way, how could [bl = []] happen in V8 syntax ? *) - if bl = [] then - let n = out_some n in - let (bl,arf,ardef) = Ppconstr.split_fix (n+1) arf ardef in - (xlate_id_opt(List.nth (names_of_local_assums bl) n),bl,arf,ardef) - else (make_fix_struct (n, bl),bl,arf,ardef) in + let strip_mutrec ((_, fid), (n, ro), bl, arf, ardef) = + let struct_arg = make_fix_struct (n, bl) in let arf = xlate_formula arf in let ardef = xlate_formula ardef in match xlate_binder_list bl with @@ -461,7 +448,7 @@ and xlate_matched_formula = function CT_coerce_FORMULA_to_MATCHED_FORMULA(xlate_formula f) and xlate_formula_expl = function (a, None) -> xlate_formula a - | (a, Some (_,ExplByPos i)) -> + | (a, Some (_,ExplByPos (i, _))) -> xlate_error "explicitation of implicit by rank not supported" | (a, Some (_,ExplByName i)) -> CT_labelled_arg(CT_ident (string_of_id i), xlate_formula a) @@ -477,24 +464,31 @@ let (xlate_ident_or_metaid: AI (_, x) -> xlate_ident x | MetaId(_, x) -> CT_metaid x;; +let nums_of_occs (b,nums) = + if b then nums + else List.map (function ArgArg x -> ArgArg (-x) | y -> y) nums + let xlate_hyp = function | AI (_,id) -> xlate_ident id | MetaId _ -> xlate_error "MetaId should occur only in quotations" let xlate_hyp_location = function - | (nums, AI (_,id)), InHypTypeOnly -> - CT_intype(xlate_ident id, nums_or_var_to_int_list nums) - | (nums, AI (_,id)), InHypValueOnly -> - CT_invalue(xlate_ident id, nums_or_var_to_int_list nums) - | ([], AI (_,id)), InHyp -> + | (occs, AI (_,id)), InHypTypeOnly -> + CT_intype(xlate_ident id, nums_or_var_to_int_list (nums_of_occs occs)) + | (occs, AI (_,id)), InHypValueOnly -> + CT_invalue(xlate_ident id, nums_or_var_to_int_list (nums_of_occs occs)) + | (occs, AI (_,id)), InHyp when occs = all_occurrences_expr -> CT_coerce_UNFOLD_to_HYP_LOCATION (CT_coerce_ID_to_UNFOLD (xlate_ident id)) - | (a::l, AI (_,id)), InHyp -> + | ((_,a::l as occs), AI (_,id)), InHyp -> + let nums = nums_of_occs occs in + let a = List.hd nums and l = List.tl nums in CT_coerce_UNFOLD_to_HYP_LOCATION (CT_unfold_occ (xlate_ident id, CT_int_ne_list(num_or_var_to_int a, nums_or_var_to_int_list_aux l))) + | (_, AI (_,id)), InHyp -> xlate_error "Unused" (* (true,]) *) | (_, MetaId _),_ -> xlate_error "MetaId not supported in xlate_hyp_location (should occur only in quotations)" @@ -507,7 +501,7 @@ let xlate_clause cls = | Some l -> CT_hyp_location_list(List.map xlate_hyp_location l) in CT_clause (hyps_info, - if cls.onconcl then + if cls.concl_occs <> no_occurrences_expr then CT_coerce_STAR_to_STAR_OPT CT_star else CT_coerce_NONE_to_STAR_OPT CT_none) @@ -606,14 +600,15 @@ let strip_targ_intropatt = | _ -> xlate_error "strip_targ_intropatt";; let get_flag r = - let conv_flags, red_ids = + let conv_flags, red_ids = + let csts = List.map (apply_or_by_notation tac_qualid_to_ct_ID) r.rConst in if r.rDelta then - [CT_delta], CT_unfbut (List.map tac_qualid_to_ct_ID r.rConst) + [CT_delta], CT_unfbut csts else (if r.rConst = [] then (* probably useless: just for compatibility *) [] else [CT_delta]), - CT_unf (List.map tac_qualid_to_ct_ID r.rConst) in + CT_unf csts in let conv_flags = if r.rBeta then CT_beta::conv_flags else conv_flags in let conv_flags = if r.rIota then CT_iota::conv_flags else conv_flags in let conv_flags = if r.rZeta then CT_zeta::conv_flags else conv_flags in @@ -633,6 +628,8 @@ let rec xlate_intro_pattern = | IntroWildcard -> CT_coerce_ID_to_INTRO_PATT(CT_ident "_" ) | IntroIdentifier c -> CT_coerce_ID_to_INTRO_PATT(xlate_ident c) | IntroAnonymous -> xlate_error "TODO: IntroAnonymous" + | IntroFresh _ -> xlate_error "TODO: IntroFresh" + | IntroRewrite _ -> xlate_error "TODO: IntroRewrite" let compute_INV_TYPE = function FullInversionClear -> CT_inv_clear @@ -663,7 +660,8 @@ let xlate_largs_to_id_opt largs = | _ -> assert false;; let xlate_int_or_constr = function - ElimOnConstr a -> CT_coerce_FORMULA_to_FORMULA_OR_INT(xlate_formula a) + ElimOnConstr (a,NoBindings) -> CT_coerce_FORMULA_to_FORMULA_OR_INT(xlate_formula a) + | ElimOnConstr _ -> xlate_error "TODO: ElimOnConstr with bindings" | ElimOnIdent(_,i) -> CT_coerce_ID_OR_INT_to_FORMULA_OR_INT (CT_coerce_ID_to_ID_OR_INT(xlate_ident i)) @@ -676,9 +674,13 @@ let xlate_using = function | Some (c2,sl2) -> CT_using (xlate_formula c2, xlate_bindings sl2);; let xlate_one_unfold_block = function - ([],qid) -> CT_coerce_ID_to_UNFOLD(tac_qualid_to_ct_ID qid) - | (n::nums, qid) -> - CT_unfold_occ(tac_qualid_to_ct_ID qid, nums_or_var_to_int_ne_list n nums) + ((true,[]),qid) -> + CT_coerce_ID_to_UNFOLD(apply_or_by_notation tac_qualid_to_ct_ID qid) + | (((_,_::_) as occs), qid) -> + let l = nums_of_occs occs in + CT_unfold_occ(apply_or_by_notation tac_qualid_to_ct_ID qid, + nums_or_var_to_int_ne_list (List.hd l) (List.tl l)) + | ((false,[]), qid) -> xlate_error "Unused" ;; let xlate_with_names = function @@ -739,7 +741,8 @@ and xlate_red_tactic = | CbvVm -> CT_cbvvm | Hnf -> CT_hnf | Simpl None -> CT_simpl ctv_PATTERN_OPT_NONE - | Simpl (Some (l,c)) -> + | Simpl (Some (occs,c)) -> + let l = nums_of_occs occs in CT_simpl (CT_coerce_PATTERN_to_PATTERN_OPT (CT_pattern_occ @@ -758,9 +761,9 @@ and xlate_red_tactic = | Fold formula_list -> CT_fold(CT_formula_list(List.map xlate_formula formula_list)) | Pattern l -> - let pat_list = List.map (fun (nums,c) -> + let pat_list = List.map (fun (occs,c) -> CT_pattern_occ - (CT_int_list (nums_or_var_to_int_list_aux nums), + (CT_int_list (nums_or_var_to_int_list_aux (nums_of_occs occs)), xlate_formula c)) l in (match pat_list with | first :: others -> CT_pattern (CT_pattern_ne_list (first, others)) @@ -770,21 +773,23 @@ and xlate_red_tactic = and xlate_local_rec_tac = function (* TODO LATER: local recursive tactics and global ones should be handled in the same manner *) - | ((_,x),(argl,tac)) -> + | ((_,x),Tacexp (TacFun (argl,tac))) -> let fst, rest = xlate_largs_to_id_opt argl in CT_rec_tactic_fun(xlate_ident x, CT_id_opt_ne_list(fst, rest), xlate_tactic tac) + | _ -> xlate_error "TODO: more general argument of 'let rec in'" and xlate_tactic = function | TacFun (largs, t) -> let fst, rest = xlate_largs_to_id_opt largs in CT_tactic_fun (CT_id_opt_ne_list(fst, rest), xlate_tactic t) - | TacThen (t1,t2) -> + | TacThen (t1,[||],t2,[||]) -> (match xlate_tactic t1 with CT_then(a,l) -> CT_then(a,l@[xlate_tactic t2]) | t -> CT_then (t,[xlate_tactic t2])) + | TacThen _ -> xlate_error "TacThen generalization TODO" | TacThens(t1,[]) -> assert false | TacThens(t1,t::l) -> let ct = xlate_tactic t in @@ -831,36 +836,31 @@ and xlate_tactic = | TacMatchContext (false,true,rule1::rules) -> CT_match_context_reverse(xlate_context_rule rule1, List.map xlate_context_rule rules) - | TacLetIn (l, t) -> + | TacLetIn (false, l, t) -> let cvt_clause = function - ((_,s),None,ConstrMayEval v) -> + ((_,s),ConstrMayEval v) -> CT_let_clause(xlate_ident s, CT_coerce_NONE_to_TACTIC_OPT CT_none, CT_coerce_DEF_BODY_to_LET_VALUE (formula_to_def_body v)) - | ((_,s),None,Tacexp t) -> + | ((_,s),Tacexp t) -> CT_let_clause(xlate_ident s, CT_coerce_NONE_to_TACTIC_OPT CT_none, CT_coerce_TACTIC_COM_to_LET_VALUE (xlate_tactic t)) - | ((_,s),None,t) -> + | ((_,s),t) -> CT_let_clause(xlate_ident s, CT_coerce_NONE_to_TACTIC_OPT CT_none, CT_coerce_TACTIC_COM_to_LET_VALUE - (xlate_call_or_tacarg t)) - | ((_,s),Some c,t) -> - CT_let_clause(xlate_ident s, - CT_coerce_TACTIC_COM_to_TACTIC_OPT(xlate_tactic c), - CT_coerce_TACTIC_COM_to_LET_VALUE - (xlate_call_or_tacarg t)) in + (xlate_call_or_tacarg t)) in let cl_l = List.map cvt_clause l in (match cl_l with | [] -> assert false | fst::others -> CT_let_ltac (CT_let_clauses(fst, others), mk_let_value t)) - | TacLetRecIn([], _) -> xlate_error "recursive definition with no definition" - | TacLetRecIn(f1::l, t) -> + | TacLetIn(true, [], _) -> xlate_error "recursive definition with no definition" + | TacLetIn(true, f1::l, t) -> let tl = CT_rec_tactic_fun_list (xlate_local_rec_tac f1, List.map xlate_local_rec_tac l) in CT_rec_tactic_in(tl, xlate_tactic t) @@ -917,6 +917,7 @@ and xlate_tac = | TacChange (None, f, b) -> CT_change (xlate_formula f, xlate_clause b) | TacChange (Some(l,c), f, b) -> (* TODO LATER: combine with other constructions of pattern_occ *) + let l = nums_of_occs l in CT_change_local( CT_pattern_occ(CT_int_list(nums_or_var_to_int_list_aux l), xlate_formula c), @@ -946,18 +947,22 @@ and xlate_tac = xlate_error "TODO: injection as" | TacFix (idopt, n) -> CT_fixtactic (xlate_ident_opt idopt, CT_int n, CT_fix_tac_list []) - | TacMutualFix (id, n, fixtac_list) -> + | TacMutualFix (false, id, n, fixtac_list) -> let f (id,n,c) = CT_fixtac (xlate_ident id, CT_int n, xlate_formula c) in CT_fixtactic (ctf_ID_OPT_SOME (xlate_ident id), CT_int n, CT_fix_tac_list (List.map f fixtac_list)) + | TacMutualFix (true, id, n, fixtac_list) -> + xlate_error "TODO: non user-visible fix" | TacCofix idopt -> CT_cofixtactic (xlate_ident_opt idopt, CT_cofix_tac_list []) - | TacMutualCofix (id, cofixtac_list) -> + | TacMutualCofix (false, id, cofixtac_list) -> let f (id,c) = CT_cofixtac (xlate_ident id, xlate_formula c) in CT_cofixtactic (CT_coerce_ID_to_ID_OPT (xlate_ident id), CT_cofix_tac_list (List.map f cofixtac_list)) + | TacMutualCofix (true, id, cofixtac_list) -> + xlate_error "TODO: non user-visible cofix" | TacIntrosUntil (NamedHyp id) -> CT_intros_until (CT_coerce_ID_to_ID_OR_INT (xlate_ident id)) | TacIntrosUntil (AnonHyp n) -> @@ -975,10 +980,12 @@ and xlate_tac = | TacIntroMove (Some id, None) -> CT_intros (CT_intro_patt_list[CT_coerce_ID_to_INTRO_PATT(xlate_ident id)]) | TacIntroMove (None, None) -> CT_intro (CT_coerce_NONE_to_ID_OPT CT_none) - | TacLeft bindl -> CT_left (xlate_bindings bindl) - | TacRight bindl -> CT_right (xlate_bindings bindl) - | TacSplit (false,bindl) -> CT_split (xlate_bindings bindl) - | TacSplit (true,bindl) -> CT_exists (xlate_bindings bindl) + | TacLeft (false,bindl) -> CT_left (xlate_bindings bindl) + | TacRight (false,bindl) -> CT_right (xlate_bindings bindl) + | TacSplit (false,false,bindl) -> CT_split (xlate_bindings bindl) + | TacSplit (false,true,bindl) -> CT_exists (xlate_bindings bindl) + | TacSplit _ | TacRight _ | TacLeft _ -> + xlate_error "TODO: esplit, eright, etc" | TacExtend (_,"replace", [c1; c2;cl;tac_opt]) -> let c1 = xlate_formula (out_gen rawwit_constr c1) in let c2 = xlate_formula (out_gen rawwit_constr c2) in @@ -991,7 +998,7 @@ and xlate_tac = let cl_as_xlate_arg = {cl_as_clause with Tacexpr.onhyps = - option_map + Option.map (fun l -> List.map (fun ((l,id),hyp_flag) -> ((l, Tacexpr.AI ((),id)) ,hyp_flag)) l ) @@ -1009,12 +1016,15 @@ and xlate_tac = CT_coerce_TACTIC_COM_to_TACTIC_OPT tac in CT_replace_with (c1, c2,cl,tac_opt) - | TacRewrite(b,cbindl,cl) -> + | TacRewrite(false,[b,Precisely 1,cbindl],cl,None) -> let cl = xlate_clause cl and c = xlate_formula (fst cbindl) and bindl = xlate_bindings (snd cbindl) in if b then CT_rewrite_lr (c, bindl, cl) else CT_rewrite_rl (c, bindl, cl) + | TacRewrite(_,_,_,Some _) -> xlate_error "TODO: rewrite by" + | TacRewrite(false,_,cl,_) -> xlate_error "TODO: rewrite of several hyps at once" + | TacRewrite(true,_,cl,_) -> xlate_error "TODO: erewrite" | TacExtend (_,"conditional_rewrite", [t; b; cbindl]) -> let t = out_gen rawwit_main_tactic t in let b = out_gen Extraargs.rawwit_orient b in @@ -1127,10 +1137,9 @@ and xlate_tac = (match out_gen rawwit_int_or_var n with | ArgVar _ -> xlate_error "" | ArgArg n -> CT_prolog (CT_formula_list cl, CT_int n)) - | TacExtend (_,"eapply", [cbindl]) -> - let (c,bindl) = out_gen rawwit_constr_with_bindings cbindl in - let c = xlate_formula c and bindl = xlate_bindings bindl in - CT_eapply (c, bindl) + (* eapply now represented by TacApply (true,cbindl) + | TacExtend (_,"eapply", [cbindl]) -> +*) | TacTrivial ([],Some []) -> CT_trivial | TacTrivial ([],None) -> CT_trivial_with(CT_coerce_STAR_to_ID_NE_LIST_OR_STAR CT_star) @@ -1141,25 +1150,36 @@ and xlate_tac = xlate_error "TODO: trivial using" | TacReduce (red, l) -> CT_reduce (xlate_red_tactic red, xlate_clause l) - | TacApply (c,bindl) -> + | TacApply (true,false,(c,bindl)) -> CT_apply (xlate_formula c, xlate_bindings bindl) - | TacConstructor (n_or_meta, bindl) -> + | TacApply (true,true,(c,bindl)) -> + CT_eapply (xlate_formula c, xlate_bindings bindl) + | TacApply (false,_,_) -> xlate_error "TODO: simple (e)apply" + | TacConstructor (false,n_or_meta, bindl) -> let n = match n_or_meta with AI n -> n | MetaId _ -> xlate_error "" in CT_constructor (CT_int n, xlate_bindings bindl) + | TacConstructor _ -> xlate_error "TODO: econstructor" | TacSpecialize (nopt, (c,sl)) -> CT_specialize (xlate_int_opt nopt, xlate_formula c, xlate_bindings sl) | TacGeneralize [] -> xlate_error "" - | TacGeneralize (first :: cl) -> + | TacGeneralize ((((true,[]),first),Anonymous) :: cl) + when List.for_all (fun ((o,_),na) -> o = all_occurrences_expr + & na = Anonymous) cl -> CT_generalize - (CT_formula_ne_list (xlate_formula first, List.map xlate_formula cl)) + (CT_formula_ne_list (xlate_formula first, + List.map (fun ((_,c),_) -> xlate_formula c) cl)) + | TacGeneralize _ -> xlate_error "TODO: Generalize at and as" | TacGeneralizeDep c -> CT_generalize_dependent (xlate_formula c) | TacElimType c -> CT_elim_type (xlate_formula c) | TacCaseType c -> CT_case_type (xlate_formula c) - | TacElim ((c1,sl), u) -> + | TacElim (false,(c1,sl), u) -> CT_elim (xlate_formula c1, xlate_bindings sl, xlate_using u) - | TacCase (c1,sl) -> + | TacCase (false,(c1,sl)) -> CT_casetac (xlate_formula c1, xlate_bindings sl) + | TacElim (true,_,_) | TacCase (true,_) + | TacNewDestruct (true,_,_,_,_) | TacNewInduction (true,_,_,_,_) -> + xlate_error "TODO: eelim, ecase, edestruct, einduction" | TacSimpleInduction h -> CT_induction (xlate_quantified_hypothesis h) | TacSimpleDestruct h -> CT_destruct (xlate_quantified_hypothesis h) | TacCut c -> CT_cut (xlate_formula c) @@ -1167,8 +1187,8 @@ and xlate_tac = | TacDecompose ([],c) -> xlate_error "Decompose : empty list of identifiers?" | TacDecompose (id::l,c) -> - let id' = tac_qualid_to_ct_ID id in - let l' = List.map tac_qualid_to_ct_ID l in + let id' = apply_or_by_notation tac_qualid_to_ct_ID id in + let l' = List.map (apply_or_by_notation tac_qualid_to_ct_ID) l in CT_decompose_list(CT_id_ne_list(id',l'),xlate_formula c) | TacDecomposeAnd c -> CT_decompose_record (xlate_formula c) | TacDecomposeOr c -> CT_decompose_sum(xlate_formula c) @@ -1178,6 +1198,7 @@ and xlate_tac = let idl' = List.map xlate_hyp idl in CT_clear (CT_id_ne_list (xlate_hyp id, idl')) | TacClear (true,_) -> xlate_error "TODO: 'clear - idl' and 'clear'" + | TacRevert _ -> xlate_error "TODO: revert" | (*For translating tactics/Inv.v *) TacInversion (NonDepInversion (k,idl,l),quant_hyp) -> CT_inversion(compute_INV_TYPE k, xlate_quantified_hypothesis quant_hyp, @@ -1192,30 +1213,36 @@ and xlate_tac = CT_use_inversion (id, xlate_formula c, CT_id_list (List.map xlate_hyp idlist)) | TacExtend (_,"omega", []) -> CT_omega - | TacRename (id1, id2) -> CT_rename(xlate_hyp id1, xlate_hyp id2) + | TacRename [id1, id2] -> CT_rename(xlate_hyp id1, xlate_hyp id2) + | TacRename _ -> xlate_error "TODO: add support for n-ary rename" | TacClearBody([]) -> assert false | TacClearBody(a::l) -> CT_clear_body (CT_id_ne_list (xlate_hyp a, List.map xlate_hyp l)) - | TacDAuto (a, b) -> + | TacDAuto (a, b, []) -> CT_dauto(xlate_int_or_var_opt_to_int_opt a, xlate_int_opt b) - | TacNewDestruct(a,b,c) -> - CT_new_destruct (* Julien F. : est-ce correct *) + | TacDAuto (a, b, _) -> + xlate_error "TODO: dauto using" + | TacNewDestruct(false,a,b,c,None) -> + CT_new_destruct (List.map xlate_int_or_constr a, xlate_using b, xlate_with_names c) - | TacNewInduction(a,b,c) -> - CT_new_induction (* Pierre C. : est-ce correct *) + | TacNewInduction(false,a,b,c,None) -> + CT_new_induction (List.map xlate_int_or_constr a, xlate_using b, xlate_with_names c) + | TacNewDestruct(false,a,b,c,_) -> xlate_error "TODO: destruct in" + | TacNewInduction(false,a,b,c,_) ->xlate_error "TODO: induction in" (*| TacInstantiate (a, b, cl) -> CT_instantiate(CT_int a, xlate_formula b, assert false) *) - | TacLetTac (na, c, cl) when cl = nowhere -> + | TacLetTac (na, c, cl, true) when cl = nowhere -> CT_pose(xlate_id_opt_aux na, xlate_formula c) - | TacLetTac (na, c, cl) -> + | TacLetTac (na, c, cl, true) -> CT_lettac(xlate_id_opt ((0,0),na), xlate_formula c, (* TODO LATER: This should be shared with Unfold, but the structures are different *) xlate_clause cl) + | TacLetTac (na, c, cl, false) -> xlate_error "TODO: remember" | TacAssert (None, IntroIdentifier id, c) -> CT_assert(xlate_id_opt ((0,0),Name id), xlate_formula c) | TacAssert (None, IntroAnonymous, c) -> @@ -1226,16 +1253,18 @@ and xlate_tac = CT_truecut(xlate_id_opt ((0,0),Anonymous), xlate_formula c) | TacAssert _ -> xlate_error "TODO: assert with 'as' and 'by' and pose proof with 'as'" - | TacAnyConstructor(Some tac) -> + | TacAnyConstructor(false,Some tac) -> CT_any_constructor (CT_coerce_TACTIC_COM_to_TACTIC_OPT(xlate_tactic tac)) - | TacAnyConstructor(None) -> + | TacAnyConstructor(false,None) -> CT_any_constructor(CT_coerce_NONE_to_TACTIC_OPT CT_none) + | TacAnyConstructor _ -> xlate_error "TODO: econstructor" | TacExtend(_, "ring", [args]) -> CT_ring (CT_formula_list (List.map xlate_formula (out_gen (wit_list0 rawwit_constr) args))) + | TacExtend (_, "f_equal", _) -> xlate_error "TODO: f_equal" | TacExtend (_,id, l) -> print_endline ("Extratactics : "^ id); CT_user_tac (CT_ident id, CT_targ_list (List.map coerce_genarg_to_TARG l)) @@ -1299,7 +1328,7 @@ and coerce_genarg_to_TARG x = (snd (out_gen (rawwit_open_constr_gen b) x)))) | ExtraArgType s as y when Pcoq.is_tactic_genarg y -> - let n = out_some (Pcoq.tactic_genarg_level s) in + let n = Option.get (Pcoq.tactic_genarg_level s) in let t = xlate_tactic (out_gen (Pcoq.rawwit_tactic n) x) in CT_coerce_TACTIC_COM_to_TARG t | ConstrWithBindingsArgType -> xlate_error "TODO: generic constr with bindings" @@ -1392,7 +1421,7 @@ let coerce_genarg_to_VARG x = | ConstrMayEvalArgType -> xlate_error"TODO: generic constr-may-eval argument" | QuantHypArgType ->xlate_error"TODO: generic quantified hypothesis argument" | ExtraArgType s as y when Pcoq.is_tactic_genarg y -> - let n = out_some (Pcoq.tactic_genarg_level s) in + let n = Option.get (Pcoq.tactic_genarg_level s) in let t = xlate_tactic (out_gen (Pcoq.rawwit_tactic n) x) in CT_coerce_TACTIC_OPT_to_VARG (CT_coerce_TACTIC_COM_to_TACTIC_OPT t) | OpenConstrArgType _ -> xlate_error "TODO: generic open constr" @@ -1563,7 +1592,9 @@ let rec xlate_module_type = function | CWith_Module((_, idl), (_, qid)) -> CT_module_type_with_mod(mty1, CT_id_list (List.map xlate_ident idl), - CT_ident (xlate_qualid qid)));; + CT_ident (xlate_qualid qid))) + | CMTEapply (_,_) -> xlate_error "TODO: Funsig application";; + let xlate_module_binder_list (l:module_binder list) = CT_module_binder_list @@ -1596,8 +1627,8 @@ let rec xlate_vernac = | VernacDeclareTacticDefinition (true, tacs) -> (match List.map (function - ((_, id), body) -> - CT_tac_def(CT_ident (string_of_id id), xlate_tactic body)) + (id, _, body) -> + CT_tac_def(reference_to_ct_ID id, xlate_tactic body)) tacs with [] -> assert false | fst::tacs1 -> @@ -1714,7 +1745,7 @@ let rec xlate_vernac = CT_id_ne_list(n1, names), dblist) | HintsExtern (n, c, t) -> CT_hint_extern(CT_int n, xlate_formula c, xlate_tactic t, dblist) - | HintsResolve l | HintsImmediate l -> + | HintsImmediate l -> let f1, formulas = match List.map xlate_formula l with a :: tl -> a, tl | _ -> failwith "" in @@ -1731,6 +1762,23 @@ let rec xlate_vernac = HintsResolve _ -> CT_hints_resolve(l', dblist) | HintsImmediate _ -> CT_hints_immediate(l', dblist) | _ -> assert false) + | HintsResolve l -> + let f1, formulas = match List.map xlate_formula (List.map snd l) with + a :: tl -> a, tl + | _ -> failwith "" in + let l' = CT_formula_ne_list(f1, formulas) in + if local then + (match h with + HintsResolve _ -> + CT_local_hints_resolve(l', dblist) + | HintsImmediate _ -> + CT_local_hints_immediate(l', dblist) + | _ -> assert false) + else + (match h with + HintsResolve _ -> CT_hints_resolve(l', dblist) + | HintsImmediate _ -> CT_hints_immediate(l', dblist) + | _ -> assert false) | HintsUnfold l -> let n1, names = match List.map loc_qualid_to_ct_ID l with n1 :: names -> n1, names @@ -1766,13 +1814,11 @@ let rec xlate_vernac = ctf_ID_OPT_SOME (xlate_ident s)) | VernacEndProof Admitted -> CT_save (CT_coerce_THM_to_THM_OPT (CT_thm "Admitted"), ctv_ID_OPT_NONE) - | VernacSetOpacity (false, id :: idl) -> - CT_transparent(CT_id_ne_list(loc_qualid_to_ct_ID id, - List.map loc_qualid_to_ct_ID idl)) - | VernacSetOpacity (true, id :: idl) - -> CT_opaque (CT_id_ne_list(loc_qualid_to_ct_ID id, - List.map loc_qualid_to_ct_ID idl)) - | VernacSetOpacity (_, []) -> xlate_error "Shouldn't occur" + | VernacSetOpacity (_,l) -> + CT_strategy(CT_level_list + (List.map (fun (l,q) -> + (level_to_ct_LEVEL l, + CT_id_list(List.map loc_qualid_to_ct_ID q))) l)) | VernacUndo n -> CT_undo (CT_coerce_INT_to_INT_OPT (CT_int n)) | VernacShow (ShowGoal nopt) -> CT_show_goal (xlate_int_opt nopt) | VernacShow ShowNode -> CT_show_node @@ -1799,7 +1845,7 @@ let rec xlate_vernac = | PrintOpaqueName id -> CT_print_opaqueid (loc_qualid_to_ct_ID id) | PrintSectionContext id -> CT_print_section (loc_qualid_to_ct_ID id) | PrintModules -> CT_print_modules - | PrintGrammar (phylum, name) -> CT_print_grammar CT_grammar_none + | PrintGrammar name -> CT_print_grammar CT_grammar_none | PrintHintDb -> CT_print_hintdb (CT_coerce_STAR_to_ID_OR_STAR CT_star) | PrintHintDbName id -> CT_print_hintdb (CT_coerce_ID_to_ID_OR_STAR (CT_ident id)) @@ -1819,6 +1865,12 @@ let rec xlate_vernac = CT_print_path (xlate_class id1, xlate_class id2) | PrintCanonicalConversions -> xlate_error "TODO: Print Canonical Structures" + | PrintAssumptions _ -> + xlate_error "TODO: Print Needed Assumptions" + | PrintInstances _ -> + xlate_error "TODO: Print Instances" + | PrintTypeClasses -> + xlate_error "TODO: Print TypeClasses" | PrintInspect n -> CT_inspect (CT_int n) | PrintUniverses opt_s -> CT_print_universes(ctf_STRING_OPT opt_s) | PrintSetoids -> CT_print_setoids @@ -1837,12 +1889,14 @@ let rec xlate_vernac = | VernacBeginSection (_,id) -> CT_coerce_SECTION_BEGIN_to_COMMAND (CT_section (xlate_ident id)) | VernacEndSegment (_,id) -> CT_section_end (xlate_ident id) - | VernacStartTheoremProof (k, (_,s), (bl,c), _, _) -> + | VernacStartTheoremProof (k, [Some (_,s), (bl,c)], _, _) -> CT_coerce_THEOREM_GOAL_to_COMMAND( CT_theorem_goal (CT_coerce_THM_to_DEFN_OR_THM (xlate_thm k), xlate_ident s, xlate_binder_list bl, xlate_formula c)) + | VernacStartTheoremProof _ -> + xlate_error "TODO: Mutually dependent theorems" | VernacSuspend -> CT_suspend - | VernacResume idopt -> CT_resume (xlate_ident_opt (option_map snd idopt)) + | VernacResume idopt -> CT_resume (xlate_ident_opt (Option.map snd idopt)) | VernacDefinition (k,(_,s),ProveBody (bl,typ),_) -> CT_coerce_THEOREM_GOAL_to_COMMAND (CT_theorem_goal @@ -1853,8 +1907,9 @@ let rec xlate_vernac = (xlate_defn kind, xlate_ident s, xlate_binder_list bl, cvt_optional_eval_for_definition c red_option, xlate_formula_opt typ_opt) - | VernacAssumption (kind, b) -> - CT_variable (xlate_var kind, cvt_vernac_binders b) + | VernacAssumption (kind,inline ,b) ->xlate_error "TODO: Parameter Inline" + (*inline : bool -> automatic delta reduction at fonctor application*) + (* CT_variable (xlate_var kind, cvt_vernac_binders b)*) | VernacCheckMayEval (None, numopt, c) -> CT_check (xlate_formula c) | VernacSearch (s,x) -> @@ -1884,7 +1939,7 @@ let rec xlate_vernac = (_, (add_coercion, (_,s)), binders, c1, rec_constructor_or_none, field_list) -> let record_constructor = - xlate_ident_opt (option_map snd rec_constructor_or_none) in + xlate_ident_opt (Option.map snd rec_constructor_or_none) in CT_record ((if add_coercion then CT_coercion_atm else CT_coerce_NONE_to_COERCION_OPT(CT_none)), @@ -1902,15 +1957,8 @@ let rec xlate_vernac = (CT_co_ind co_or_ind, CT_ind_spec_list (List.map strip_mutind lmi)) | VernacFixpoint ([],_) -> xlate_error "mutual recursive" | VernacFixpoint ((lm :: lmi),boxed) -> - let strip_mutrec ((fid, (n, ro), bl, arf, ardef), _ntn) = - let (struct_arg,bl,arf,ardef) = - (* Pierre L: could the case [n=None && bl=[]] happen ? Normally not *) - (* By the way, how could [bl = []] happen in V8 syntax ? *) - if bl = [] then - let n = out_some n in - let (bl,arf,ardef) = Ppconstr.split_fix (n+1) arf ardef in - (xlate_id_opt(List.nth (names_of_local_assums bl) n),bl,arf,ardef) - else (make_fix_struct (n, bl),bl,arf,ardef) in + let strip_mutrec (((_,fid), (n, ro), bl, arf, ardef), _ntn) = + let struct_arg = make_fix_struct (n, bl) in let arf = xlate_formula arf in let ardef = xlate_formula ardef in match xlate_binder_list bl with @@ -1922,26 +1970,35 @@ let rec xlate_vernac = (CT_fix_rec_list (strip_mutrec lm, List.map strip_mutrec lmi)) | VernacCoFixpoint ([],boxed) -> xlate_error "mutual corecursive" | VernacCoFixpoint ((lm :: lmi),boxed) -> - let strip_mutcorec ((fid, bl, arf, ardef), _ntn) = + let strip_mutcorec (((_,fid), bl, arf, ardef), _ntn) = CT_cofix_rec (xlate_ident fid, xlate_binder_list bl, xlate_formula arf, xlate_formula ardef) in CT_cofix_decl (CT_cofix_rec_list (strip_mutcorec lm, List.map strip_mutcorec lmi)) | VernacScheme [] -> xlate_error "induction scheme" | VernacScheme (lm :: lmi) -> - let strip_ind ((_,id), depstr, inde, sort) = + let strip_ind = function + | (Some (_,id), InductionScheme (depstr, inde, sort)) -> CT_scheme_spec (xlate_ident id, xlate_dep depstr, CT_coerce_ID_to_FORMULA (loc_qualid_to_ct_ID inde), - xlate_sort sort) in + xlate_sort sort) + | (None, InductionScheme (depstr, inde, sort)) -> + CT_scheme_spec + (xlate_ident (id_of_string ""), xlate_dep depstr, + CT_coerce_ID_to_FORMULA (loc_qualid_to_ct_ID inde), + xlate_sort sort) + | (_, EqualityScheme _) -> xlate_error "TODO: Scheme Equality" in CT_ind_scheme (CT_scheme_spec_list (strip_ind lm, List.map strip_ind lmi)) - | VernacSyntacticDefinition (id, c, false, _) -> + | VernacCombinedScheme _ -> xlate_error "TODO: Combined Scheme" + | VernacSyntacticDefinition ((_,id), ([],c), false, _) -> CT_syntax_macro (xlate_ident id, xlate_formula c, xlate_int_opt None) - | VernacSyntacticDefinition (id, c, true, _) -> - xlate_error "TODO: Local abbreviations" + | VernacSyntacticDefinition ((_,id), _, _, _) -> + xlate_error"TODO: Local abbreviations and abbreviations with parameters" (* Modules and Module Types *) - | VernacDeclareModuleType((_, id), bl, mty_o) -> + | VernacInclude (_) -> xlate_error "TODO : Include " + | VernacDeclareModuleType((_, id), bl, mty_o) -> CT_module_type_decl(xlate_ident id, xlate_module_binder_list bl, match mty_o with @@ -2051,6 +2108,12 @@ let rec xlate_vernac = | Local -> CT_local in CT_coercion (local_opt, id_opt, xlate_ident id1, xlate_class id2, xlate_class id3) + + (* Type Classes *) + | VernacDeclareInstance _|VernacContext _| + VernacInstance (_, _, _, _, _)|VernacClass (_, _, _, _, _) -> + xlate_error "TODO: Type Classes commands" + | VernacResetName id -> CT_reset (xlate_ident (snd id)) | VernacResetInitial -> CT_restore_state (CT_ident "Initial") | VernacExtend (s, l) -> @@ -2073,10 +2136,10 @@ let rec xlate_vernac = CT_coerce_ID_LIST_to_ID_LIST_OPT (CT_id_list (List.map - (function ExplByPos x + (function ExplByPos (x,_), _, _ -> xlate_error "explication argument by rank is obsolete" - | ExplByName id -> CT_ident (string_of_id id)) l))) + | ExplByName id, _, _ -> CT_ident (string_of_id id)) l))) | VernacDeclareImplicits(false, id, opt_positions) -> xlate_error "TODO: Implicit Arguments Global" | VernacReserve((_,a)::l, f) -> @@ -2096,13 +2159,15 @@ let rec xlate_vernac = let table1 = match table with PrimaryTable(s) -> CT_coerce_ID_to_TABLE(CT_ident s) - | SecondaryTable(s1,s2) -> CT_table(CT_ident s1, CT_ident s2) in + | SecondaryTable(s1,s2) -> CT_table(CT_ident s1, CT_ident s2) + | TertiaryTable(s1,s2,s3) -> xlate_error "TODO: TertiaryTable" in CT_set_option(table1) | VernacSetOption (table, v) -> let table1 = match table with PrimaryTable(s) -> CT_coerce_ID_to_TABLE(CT_ident s) - | SecondaryTable(s1,s2) -> CT_table(CT_ident s1, CT_ident s2) in + | SecondaryTable(s1,s2) -> CT_table(CT_ident s1, CT_ident s2) + | TertiaryTable(s1,s2,s3) -> xlate_error "TODO: TertiaryTable" in let value = match v with | BoolValue _ -> assert false @@ -2115,7 +2180,8 @@ let rec xlate_vernac = let table1 = match table with PrimaryTable(s) -> CT_coerce_ID_to_TABLE(CT_ident s) - | SecondaryTable(s1,s2) -> CT_table(CT_ident s1, CT_ident s2) in + | SecondaryTable(s1,s2) -> CT_table(CT_ident s1, CT_ident s2) + | TertiaryTable(s1,s2,s3) -> xlate_error "TODO: TertiaryTable" in CT_unset_option(table1) | VernacAddOption (table, l) -> let values = @@ -2130,7 +2196,8 @@ let rec xlate_vernac = let table1 = match table with PrimaryTable(s) -> CT_coerce_ID_to_TABLE(CT_ident s) - | SecondaryTable(s1,s2) -> CT_table(CT_ident s1, CT_ident s2) in + | SecondaryTable(s1,s2) -> CT_table(CT_ident s1, CT_ident s2) + | TertiaryTable(s1,s2,s3) -> xlate_error "TODO: TertiaryTable" in CT_set_option_value2(table1, CT_id_or_string_ne_list(fst, values1)) | VernacImport(true, a::l) -> CT_export_id(CT_id_ne_list(reference_to_ct_ID a, @@ -2140,13 +2207,17 @@ let rec xlate_vernac = List.map reference_to_ct_ID l)) | VernacImport(_, []) -> assert false | VernacProof t -> CT_proof_with(xlate_tactic t) - | VernacVar _ -> xlate_error "Grammar vernac obsolete" | (VernacGlobalCheck _|VernacPrintOption _| VernacMemOption (_, _)|VernacRemoveOption (_, _) | VernacBack _ | VernacBacktrack _ |VernacBackTo _|VernacRestoreState _| VernacWriteState _| VernacSolveExistential (_, _)|VernacCanonical _ | - VernacTacticNotation _) - -> xlate_error "TODO: vernac";; + VernacTacticNotation _ | VernacUndoTo _ | VernacRemoveName _) + -> xlate_error "TODO: vernac" +and level_to_ct_LEVEL = function + Conv_oracle.Opaque -> CT_Opaque + | Conv_oracle.Level n -> CT_Level (CT_int n) + | Conv_oracle.Expand -> CT_Expand;; + let rec xlate_vernac_list = function diff --git a/contrib/interface/xlate.mli b/contrib/interface/xlate.mli index bedb4ac8..2e2b95fe 100644 --- a/contrib/interface/xlate.mli +++ b/contrib/interface/xlate.mli @@ -6,4 +6,3 @@ val xlate_formula : Topconstr.constr_expr -> ct_FORMULA;; val xlate_ident : Names.identifier -> ct_ID;; val xlate_vernac_list : Vernacexpr.vernac_expr -> ct_COMMAND_LIST;; -val declare_in_coq : (unit -> unit);; diff --git a/contrib/jprover/jall.ml b/contrib/jprover/jall.ml index a2a72676..a9ebe5b6 100644 --- a/contrib/jprover/jall.ml +++ b/contrib/jprover/jall.ml @@ -31,23 +31,6 @@ * Modified by: Aleksey Nogin <nogin@cs.cornell.edu> *) -(*: All of Huang's modifications of this file are quoted or denoted - by comments followed by a colon. -:*) - -(*: -open Mp_debug - -open Refiner.Refiner -open Term -open TermType -open TermOp -open TermSubst -open TermMan -open RefineError -open Opname -:*) - open Jterm open Opname open Jlogic @@ -55,10 +38,6 @@ open Jtunify let ruletable = Jlogic.ruletable -(*: -let free_var_op = make_opname ["free_variable";"Jprover"] -let jprover_op = make_opname ["string";"Jprover"] -:*) let free_var_op = make_opname ["free_variable"; "Jprover"] let jprover_op = make_opname ["jprover"; "string"] @@ -1308,23 +1287,6 @@ struct (* append renamed paramater "r" to non-quantifier subformulae of renamed quantifier formulae *) -(*: BUG :*) -(*: - let make_new_eigenvariable term = - let op = (dest_term term).term_op in - let opn = (dest_op op).op_name in - let opnam = dest_opname opn in - match opnam with - [] -> - raise jprover_bug - | ofirst::orest -> - let ofname = List.hd orest in - let new_eigen_var = (ofname^"_r"^(string_of_int (!eigen_counter))) in - eigen_counter := !eigen_counter + 1; -(* print_endline ("New Counter :"^(string_of_int (!eigen_counter))); *) - mk_string_term jprover_op new_eigen_var -:*) - let make_new_eigenvariable term = let op = (dest_term term).term_op in let opa = (dest_op op).op_params in @@ -2485,30 +2447,6 @@ struct let dbt = dest_bterm bt in (dbt.bterm)::(collect_subterms r) - (*: Bug! :*) -(*: let rec collect_delta_terms = function - [] -> [] - | t::r -> - let dt = dest_term t in - let top = dt.term_op - and tterms = dt.term_terms in - let dop = dest_op top in - let don = dest_opname dop.op_name in - match don with - [] -> - let sub_terms = collect_subterms tterms in - collect_delta_terms (sub_terms @ r) - | op1::opr -> - if op1 = "jprover" then - match opr with - [] -> raise (Invalid_argument "Jprover: delta position missing") - | delta::_ -> - delta::(collect_delta_terms r) - else - let sub_terms = collect_subterms tterms in - collect_delta_terms (sub_terms @ r) -:*) - let rec collect_delta_terms = function [] -> [] | t::r -> @@ -3219,23 +3157,7 @@ struct | (v,termlist)::r -> let dterms = collect_delta_terms termlist in begin -(*: print_stringlist dterms; - mbreak "add_sigmaQ:1\n"; - Format.open_box 0; - print_endline " "; - print_endline "sigmaQ: "; - print_string (v^" = "); - print_term_list termlist; - Format.force_newline (); - print_stringlist dterms; - Format.force_newline (); - Format.print_flush (); - mbreak "add_sigmaQ:2\n"; -:*) let new_ordering = add_arrowsQ v dterms ordering in -(*: print_ordering new_ordering; - mbreak "add_sigmaQ:3\n"; -:*) let (rest_pairs,rest_ordering) = add_sigmaQ r new_ordering in ((v,dterms)::rest_pairs),rest_ordering end @@ -3303,7 +3225,6 @@ struct let jqunify term1 term2 sigmaQ = let app_term1,app_term2 = apply_2_sigmaQ term1 term2 sigmaQ in try -(*: let tauQ = unify_mm app_term1 app_term2 String_set.StringSet.empty in :*) let tauQ = unify_mm app_term1 app_term2 StringSet.empty in let (mult,oel) = multiply sigmaQ tauQ in (mult,oel) @@ -3740,19 +3661,7 @@ let rec subst_replace subst_list t = [] -> t | (old_t,new_t)::r -> let inter_term = var_subst t old_t "dummy" in -(*: print_string "("; - print_term stdout old_t; - print_string " --> "; - print_term stdout new_t; - print_string ")\n"; - print_term stdout t; - print_newline (); - print_term stdout inter_term; - print_newline (); :*) let new_term = subst1 inter_term "dummy" new_t in -(*: print_term stdout new_term; - print_newline (); - mbreak "\n+++========----- ---------..........\n"; :*) subst_replace r new_term let rename_pos x m = @@ -3950,10 +3859,6 @@ exception Failed_connections let path_checker atom_rel atom_sets qprefixes init_ordering logic = let con = connections atom_rel [] in -(*: print_endline ""; - print_endline ("number of connections: "^(string_of_int (List.length con))); - mbreak "#connec\n"; -:*) let rec provable path closed (orderingQ,reduction_ordering) eqlist (sigmaQ,sigmaJ) = let rec check_connections (reduction_partners,extension_partners) ext_atom = @@ -4470,7 +4375,6 @@ let rec create_output rule_list input_map = and new_term2 = apply_var_subst next_term2 var_mapping and (a,b) = pos in -(*: print_string (a^"+++"^b^"\n"); :*) (* kick away the first argument, the position *) (JLogic.append_inf (create_output r input_map) (b,new_term1) (a,new_term2) rule) @@ -4514,8 +4418,6 @@ let rec make_test_interface rule_list input_map = (**************************************************************) -(*: modified for Coq :*) - let decomp_pos pos = let {name=n; address=a; label=l} = pos in (n,(a,l)) @@ -4590,8 +4492,6 @@ let gen_prover mult_limit logic calculus hyps concls = (* from the LJmc to the LJ proof *) create_coq_input (create_output sequent_proof input_map) idl -(*: end of coq modification :*) - let prover mult_limit hyps concl = gen_prover mult_limit "J" "LJ" hyps [concl] (************* test with propositional proof reconstruction ************) @@ -4658,7 +4558,6 @@ let do_prove mult_limit termlist logic calculus = print_endline ""; print_endline ""; Format.print_flush (); -(*: let _ = input_char stdin in :*) let reconstr_proof = reconstruct ftree red_ordering sigmaQ ext_proof logic calculus in let sequent_proof = make_test_interface reconstr_proof input_map in Format.open_box 0; @@ -4676,7 +4575,7 @@ let do_prove mult_limit termlist logic calculus = Format.force_newline (); Format.force_newline (); Format.print_flush (); - tt ptree; (*: print proof tree :*) + tt ptree; Format.print_flush (); print_endline ""; print_endline "" diff --git a/contrib/jprover/jprover.ml4 b/contrib/jprover/jprover.ml4 index 294943f7..5fd763c3 100644 --- a/contrib/jprover/jprover.ml4 +++ b/contrib/jprover/jprover.ml4 @@ -410,7 +410,7 @@ i*) | Negl -> dyn_negl s1 | Allr -> dyn_allr (JT.dest_var t2) | Alll -> dyn_alll s1 s2 (constr_of_jterm t2) - | Exr -> dyn_exr (constr_of_jterm t2) + | Exr -> dyn_exr (Tactics.inj_open (constr_of_jterm t2)) | Exl -> dyn_exl s1 s2 (JT.dest_var t2) | Ax -> T.assumption (*i TCL.tclIDTAC i*) | Truer -> dyn_truer diff --git a/contrib/micromega/CheckerMaker.v b/contrib/micromega/CheckerMaker.v new file mode 100644 index 00000000..93b4d213 --- /dev/null +++ b/contrib/micromega/CheckerMaker.v @@ -0,0 +1,129 @@ +(************************************************************************) +(* 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 *) +(************************************************************************) +(* *) +(* Micromega: A reflexive tactic using the Positivstellensatz *) +(* *) +(* Frédéric Besson (Irisa/Inria) 2006-2008 *) +(* *) +(************************************************************************) + +Require Import Setoid. +Require Import Decidable. +Require Import List. +Require Import Refl. + +Set Implicit Arguments. + +Section CheckerMaker. + +(* 'Formula' is a syntactic representation of a certain kind of propositions. *) +Variable Formula : Type. + +Variable Env : Type. + +Variable eval : Env -> Formula -> Prop. + +Variable Formula' : Type. + +Variable eval' : Env -> Formula' -> Prop. + +Variable normalise : Formula -> Formula'. + +Variable negate : Formula -> Formula'. + +Hypothesis normalise_sound : + forall (env : Env) (t : Formula), eval env t -> eval' env (normalise t). + +Hypothesis negate_correct : + forall (env : Env) (t : Formula), eval env t <-> ~ (eval' env (negate t)). + +Variable Witness : Type. + +Variable check_formulas' : list Formula' -> Witness -> bool. + +Hypothesis check_formulas'_sound : + forall (l : list Formula') (w : Witness), + check_formulas' l w = true -> + forall env : Env, make_impl (eval' env) l False. + +Definition normalise_list : list Formula -> list Formula' := map normalise. +Definition negate_list : list Formula -> list Formula' := map negate. + +Definition check_formulas (l : list Formula) (w : Witness) : bool := + check_formulas' (map normalise l) w. + +(* Contraposition of normalise_sound for lists *) +Lemma normalise_sound_contr : forall (env : Env) (l : list Formula), + make_impl (eval' env) (map normalise l) False -> make_impl (eval env) l False. +Proof. +intros env l; induction l as [| t l IH]; simpl in *. +trivial. +intros H1 H2. apply IH. apply H1. now apply normalise_sound. +Qed. + +Theorem check_formulas_sound : + forall (l : list Formula) (w : Witness), + check_formulas l w = true -> forall env : Env, make_impl (eval env) l False. +Proof. +unfold check_formulas; intros l w H env. destruct l as [| t l]; simpl in *. +pose proof (check_formulas'_sound H env) as H1; now simpl in H1. +intro H1. apply normalise_sound in H1. +pose proof (check_formulas'_sound H env) as H2; simpl in H2. +apply H2 in H1. now apply normalise_sound_contr. +Qed. + +(* In check_conj_formulas', t2 is supposed to be a list of negations of +formulas. If, for example, t1 = [A1, A2] and t2 = [~ B1, ~ B2], then +check_conj_formulas' checks that each of [~ B1, A1, A2] and [~ B2, A1, A2] is +inconsistent. This means that A1 /\ A2 -> B1 and A1 /\ A2 -> B1, i.e., that +A1 /\ A2 -> B1 /\ B2. *) + +Fixpoint check_conj_formulas' + (t1 : list Formula') (wits : list Witness) (t2 : list Formula') {struct wits} : bool := +match t2 with +| nil => true +| t':: rt2 => + match wits with + | nil => false + | w :: rwits => + match check_formulas' (t':: t1) w with + | true => check_conj_formulas' t1 rwits rt2 + | false => false + end + end +end. + +(* checks whether the conjunction of t1 implies the conjunction of t2 *) + +Definition check_conj_formulas + (t1 : list Formula) (wits : list Witness) (t2 : list Formula) : bool := + check_conj_formulas' (normalise_list t1) wits (negate_list t2). + +Theorem check_conj_formulas_sound : + forall (t1 : list Formula) (t2 : list Formula) (wits : list Witness), + check_conj_formulas t1 wits t2 = true -> + forall env : Env, make_impl (eval env) t1 (make_conj (eval env) t2). +Proof. +intro t1; induction t2 as [| a2 t2' IH]. +intros; apply make_impl_true. +intros wits H env. +unfold check_conj_formulas in H; simpl in H. +destruct wits as [| w ws]; simpl in H. discriminate. +case_eq (check_formulas' (negate a2 :: normalise_list t1) w); +intro H1; rewrite H1 in H; [| discriminate]. +assert (H2 : make_impl (eval' env) (negate a2 :: normalise_list t1) False) by +now apply check_formulas'_sound with (w := w). clear H1. +pose proof (IH ws H env) as H1. simpl in H2. +assert (H3 : eval' env (negate a2) -> make_impl (eval env) t1 False) +by auto using normalise_sound_contr. clear H2. +rewrite <- make_conj_impl in *. +rewrite make_conj_cons. intro H2. split. +apply <- negate_correct. intro; now elim H3. exact (H1 H2). +Qed. + +End CheckerMaker. diff --git a/contrib/micromega/Env.v b/contrib/micromega/Env.v new file mode 100644 index 00000000..40db9e46 --- /dev/null +++ b/contrib/micromega/Env.v @@ -0,0 +1,182 @@ +(************************************************************************) +(* 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 *) +(************************************************************************) +(* *) +(* Micromega: A reflexive tactic using the Positivstellensatz *) +(* *) +(* Frédéric Besson (Irisa/Inria) 2006-2008 *) +(* *) +(************************************************************************) + +Require Import ZArith. +Require Import Coq.Arith.Max. +Require Import List. +Set Implicit Arguments. + +(* I have addded a Leaf constructor to the varmap data structure (/contrib/ring/Quote.v) + -- this is harmless and spares a lot of Empty. + This means smaller proof-terms. + BTW, by dropping the polymorphism, I get small (yet noticeable) speed-up. +*) + +Section S. + + Variable D :Type. + + Definition Env := positive -> D. + + Definition jump (j:positive) (e:Env) := fun x => e (Pplus x j). + + Definition nth (n:positive) (e : Env ) := e n. + + Definition hd (x:D) (e: Env) := nth xH e. + + Definition tail (e: Env) := jump xH e. + + Lemma psucc : forall p, (match p with + | xI y' => xO (Psucc y') + | xO y' => xI y' + | 1%positive => 2%positive + end) = (p+1)%positive. + Proof. + destruct p. + auto with zarith. + rewrite xI_succ_xO. + auto with zarith. + reflexivity. + Qed. + + Lemma jump_Pplus : forall i j l, + forall x, jump (i + j) l x = jump i (jump j l) x. + Proof. + unfold jump. + intros. + rewrite Pplus_assoc. + reflexivity. + Qed. + + Lemma jump_simpl : forall p l, + forall x, jump p l x = + match p with + | xH => tail l x + | xO p => jump p (jump p l) x + | xI p => jump p (jump p (tail l)) x + end. + Proof. + destruct p ; unfold tail ; intros ; repeat rewrite <- jump_Pplus. + (* xI p = p + p + 1 *) + rewrite xI_succ_xO. + rewrite Pplus_diag. + rewrite <- Pplus_one_succ_r. + reflexivity. + (* xO p = p + p *) + rewrite Pplus_diag. + reflexivity. + reflexivity. + Qed. + + Ltac jump_s := + repeat + match goal with + | |- context [jump xH ?e] => rewrite (jump_simpl xH) + | |- context [jump (xO ?p) ?e] => rewrite (jump_simpl (xO p)) + | |- context [jump (xI ?p) ?e] => rewrite (jump_simpl (xI p)) + end. + + Lemma jump_tl : forall j l, forall x, tail (jump j l) x = jump j (tail l) x. + Proof. + unfold tail. + intros. + repeat rewrite <- jump_Pplus. + rewrite Pplus_comm. + reflexivity. + Qed. + + Lemma jump_Psucc : forall j l, + forall x, (jump (Psucc j) l x) = (jump 1 (jump j l) x). + Proof. + intros. + rewrite <- jump_Pplus. + rewrite Pplus_one_succ_r. + rewrite Pplus_comm. + reflexivity. + Qed. + + Lemma jump_Pdouble_minus_one : forall i l, + forall x, (jump (Pdouble_minus_one i) (tail l)) x = (jump i (jump i l)) x. + Proof. + unfold tail. + intros. + repeat rewrite <- jump_Pplus. + rewrite <- Pplus_one_succ_r. + rewrite Psucc_o_double_minus_one_eq_xO. + rewrite Pplus_diag. + reflexivity. + Qed. + + Lemma jump_x0_tail : forall p l, forall x, jump (xO p) (tail l) x = jump (xI p) l x. + Proof. + intros. + unfold jump. + unfold tail. + unfold jump. + rewrite <- Pplus_assoc. + simpl. + reflexivity. + Qed. + + Lemma nth_spec : forall p l x, + nth p l = + match p with + | xH => hd x l + | xO p => nth p (jump p l) + | xI p => nth p (jump p (tail l)) + end. + Proof. + unfold nth. + destruct p. + intros. + unfold jump, tail. + unfold jump. + rewrite Pplus_diag. + rewrite xI_succ_xO. + simpl. + reflexivity. + unfold jump. + rewrite Pplus_diag. + reflexivity. + unfold hd. + unfold nth. + reflexivity. + Qed. + + + Lemma nth_jump : forall p l x, nth p (tail l) = hd x (jump p l). + Proof. + unfold tail. + unfold hd. + unfold jump. + unfold nth. + intros. + rewrite Pplus_comm. + reflexivity. + Qed. + + Lemma nth_Pdouble_minus_one : + forall p l, nth (Pdouble_minus_one p) (tail l) = nth p (jump p l). + Proof. + intros. + unfold tail. + unfold nth, jump. + rewrite Pplus_diag. + rewrite <- Psucc_o_double_minus_one_eq_xO. + rewrite Pplus_one_succ_r. + reflexivity. + Qed. + +End S. + diff --git a/contrib/micromega/EnvRing.v b/contrib/micromega/EnvRing.v new file mode 100644 index 00000000..04e68272 --- /dev/null +++ b/contrib/micromega/EnvRing.v @@ -0,0 +1,1403 @@ +(************************************************************************) +(* 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 *) +(************************************************************************) +(* F. Besson: to evaluate polynomials, the original code is using a list. + For big polynomials, this is inefficient -- linear access. + I have modified the code to use binary trees -- logarithmic access. *) + + +Set Implicit Arguments. +Require Import Setoid. +Require Import BinList. +Require Import Env. +Require Import BinPos. +Require Import BinNat. +Require Import BinInt. +Require Export Ring_theory. + +Open Local Scope positive_scope. +Import RingSyntax. + +Section MakeRingPol. + + (* Ring elements *) + Variable R:Type. + Variable (rO rI : R) (radd rmul rsub: R->R->R) (ropp : R->R). + Variable req : R -> R -> Prop. + + (* Ring properties *) + Variable Rsth : Setoid_Theory R req. + Variable Reqe : ring_eq_ext radd rmul ropp req. + Variable ARth : almost_ring_theory rO rI radd rmul rsub ropp req. + + (* Coefficients *) + Variable C: Type. + Variable (cO cI: C) (cadd cmul csub : C->C->C) (copp : C->C). + Variable ceqb : C->C->bool. + Variable phi : C -> R. + 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. + Notation "x + y" := (radd x y). Notation "x * y " := (rmul x y). + Notation "x - y " := (rsub x y). Notation "- x" := (ropp x). + Notation "x == y" := (req x y). + + (* C notations *) + Notation "x +! y" := (cadd x y). Notation "x *! y " := (cmul x y). + Notation "x -! y " := (csub x y). Notation "-! x" := (copp x). + Notation " x ?=! y" := (ceqb x y). Notation "[ x ]" := (phi x). + + (* Usefull tactics *) + Add Setoid R req Rsth as R_set1. + Ltac rrefl := gen_reflexivity Rsth. + Add Morphism radd : radd_ext. exact (Radd_ext Reqe). Qed. + Add Morphism rmul : rmul_ext. exact (Rmul_ext Reqe). Qed. + Add Morphism ropp : ropp_ext. exact (Ropp_ext Reqe). Qed. + Add Morphism rsub : rsub_ext. exact (ARsub_ext Rsth Reqe ARth). Qed. + Ltac rsimpl := gen_srewrite Rsth Reqe ARth. + Ltac add_push := gen_add_push radd Rsth Reqe ARth. + Ltac mul_push := gen_mul_push rmul Rsth Reqe ARth. + + (* Definition of multivariable polynomials with coefficients in C : + Type [Pol] represents [X1 ... Xn]. + The representation is Horner's where a [n] variable polynomial + (C[X1..Xn]) is seen as a polynomial on [X1] which coefficients + are polynomials with [n-1] variables (C[X2..Xn]). + There are several optimisations to make the repr compacter: + - [Pc c] is the constant polynomial of value c + == c*X1^0*..*Xn^0 + - [Pinj j Q] is a polynomial constant w.r.t the [j] first variables. + variable indices are shifted of j in Q. + == X1^0 *..* Xj^0 * Q{X1 <- Xj+1;..; Xn-j <- Xn} + - [PX P i Q] is an optimised Horner form of P*X^i + Q + with P not the null polynomial + == P * X1^i + Q{X1 <- X2; ..; Xn-1 <- Xn} + + In addition: + - polynomials of the form (PX (PX P i (Pc 0)) j Q) are forbidden + since they can be represented by the simpler form (PX P (i+j) Q) + - (Pinj i (Pinj j P)) is (Pinj (i+j) P) + - (Pinj i (Pc c)) is (Pc c) + *) + + Inductive Pol : Type := + | Pc : C -> Pol + | Pinj : positive -> Pol -> Pol + | PX : Pol -> positive -> Pol -> Pol. + + Definition P0 := Pc cO. + Definition P1 := Pc cI. + + Fixpoint Peq (P P' : Pol) {struct P'} : bool := + match P, P' with + | Pc c, Pc c' => c ?=! c' + | Pinj j Q, Pinj j' Q' => + match Pcompare j j' Eq with + | Eq => Peq Q Q' + | _ => false + end + | PX P i Q, PX P' i' Q' => + match Pcompare i i' Eq with + | Eq => if Peq P P' then Peq Q Q' else false + | _ => false + end + | _, _ => false + end. + + Notation " P ?== P' " := (Peq P P'). + + Definition mkPinj j P := + match P with + | Pc _ => P + | Pinj j' Q => Pinj ((j + j'):positive) Q + | _ => 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 *) + + Fixpoint Popp (P:Pol) : Pol := + match P with + | Pc c => Pc (-! c) + | Pinj j Q => Pinj j (Popp Q) + | PX P i Q => PX (Popp P) i (Popp Q) + end. + + Notation "-- P" := (Popp P). + + (** Addition et subtraction *) + + Fixpoint PaddC (P:Pol) (c:C) {struct P} : Pol := + match P with + | Pc c1 => Pc (c1 +! c) + | Pinj j Q => Pinj j (PaddC Q c) + | PX P i Q => PX P i (PaddC Q c) + end. + + Fixpoint PsubC (P:Pol) (c:C) {struct P} : Pol := + match P with + | Pc c1 => Pc (c1 -! c) + | Pinj j Q => Pinj j (PsubC Q c) + | PX P i Q => PX P i (PsubC Q c) + end. + + Section PopI. + + Variable Pop : Pol -> Pol -> Pol. + Variable Q : Pol. + + Fixpoint PaddI (j:positive) (P:Pol){struct P} : Pol := + match P with + | Pc c => mkPinj j (PaddC Q c) + | Pinj j' Q' => + match ZPminus j' j with + | Zpos k => mkPinj j (Pop (Pinj k Q') Q) + | Z0 => mkPinj j (Pop Q' Q) + | Zneg k => mkPinj j' (PaddI k Q') + end + | PX P i Q' => + match j with + | xH => PX P i (Pop Q' Q) + | xO j => PX P i (PaddI (Pdouble_minus_one j) Q') + | xI j => PX P i (PaddI (xO j) Q') + end + end. + + Fixpoint PsubI (j:positive) (P:Pol){struct P} : Pol := + match P with + | Pc c => mkPinj j (PaddC (--Q) c) + | Pinj j' Q' => + match ZPminus j' j with + | Zpos k => mkPinj j (Pop (Pinj k Q') Q) + | Z0 => mkPinj j (Pop Q' Q) + | Zneg k => mkPinj j' (PsubI k Q') + end + | PX P i Q' => + match j with + | xH => PX P i (Pop Q' Q) + | xO j => PX P i (PsubI (Pdouble_minus_one j) Q') + | xI j => PX P i (PsubI (xO j) Q') + end + end. + + Variable P' : Pol. + + Fixpoint PaddX (i':positive) (P:Pol) {struct P} : Pol := + match P with + | Pc c => PX P' i' P + | Pinj j Q' => + match j with + | xH => PX P' i' Q' + | xO j => PX P' i' (Pinj (Pdouble_minus_one j) Q') + | xI j => PX P' i' (Pinj (xO j) Q') + end + | PX P i Q' => + match ZPminus i i' with + | Zpos k => mkPX (Pop (PX P k P0) P') i' Q' + | Z0 => mkPX (Pop P P') i Q' + | Zneg k => mkPX (PaddX k P) i Q' + end + end. + + Fixpoint PsubX (i':positive) (P:Pol) {struct P} : Pol := + match P with + | Pc c => PX (--P') i' P + | Pinj j Q' => + match j with + | xH => PX (--P') i' Q' + | xO j => PX (--P') i' (Pinj (Pdouble_minus_one j) Q') + | xI j => PX (--P') i' (Pinj (xO j) Q') + end + | PX P i Q' => + match ZPminus i i' with + | Zpos k => mkPX (Pop (PX P k P0) P') i' Q' + | Z0 => mkPX (Pop P P') i Q' + | Zneg k => mkPX (PsubX k P) i Q' + end + end. + + + End PopI. + + Fixpoint Padd (P P': Pol) {struct P'} : Pol := + match P' with + | Pc c' => PaddC P c' + | Pinj j' Q' => PaddI Padd Q' j' P + | PX P' i' Q' => + match P with + | Pc c => PX P' i' (PaddC Q' c) + | Pinj j Q => + match j with + | xH => PX P' i' (Padd Q Q') + | xO j => PX P' i' (Padd (Pinj (Pdouble_minus_one j) Q) Q') + | xI j => PX P' i' (Padd (Pinj (xO j) Q) Q') + end + | PX P i Q => + match ZPminus i i' with + | Zpos k => mkPX (Padd (PX P k P0) P') i' (Padd Q Q') + | Z0 => mkPX (Padd P P') i (Padd Q Q') + | Zneg k => mkPX (PaddX Padd P' k P) i (Padd Q Q') + end + end + end. + Notation "P ++ P'" := (Padd P P'). + + Fixpoint Psub (P P': Pol) {struct P'} : Pol := + match P' with + | Pc c' => PsubC P c' + | Pinj j' Q' => PsubI Psub Q' j' P + | PX P' i' Q' => + match P with + | Pc c => PX (--P') i' (*(--(PsubC Q' c))*) (PaddC (--Q') c) + | Pinj j Q => + match j with + | xH => PX (--P') i' (Psub Q Q') + | xO j => PX (--P') i' (Psub (Pinj (Pdouble_minus_one j) Q) Q') + | xI j => PX (--P') i' (Psub (Pinj (xO j) Q) Q') + end + | PX P i Q => + match ZPminus i i' with + | Zpos k => mkPX (Psub (PX P k P0) P') i' (Psub Q Q') + | Z0 => mkPX (Psub P P') i (Psub Q Q') + | Zneg k => mkPX (PsubX Psub P' k P) i (Psub Q Q') + end + end + end. + Notation "P -- P'" := (Psub P P'). + + (** Multiplication *) + + Fixpoint PmulC_aux (P:Pol) (c:C) {struct P} : Pol := + match P with + | Pc c' => Pc (c' *! c) + | Pinj j Q => mkPinj j (PmulC_aux Q c) + | PX P i Q => mkPX (PmulC_aux P c) i (PmulC_aux Q c) + end. + + Definition PmulC P c := + if c ?=! cO then P0 else + if c ?=! cI then P else PmulC_aux P c. + + Section PmulI. + Variable Pmul : Pol -> Pol -> Pol. + Variable Q : Pol. + Fixpoint PmulI (j:positive) (P:Pol) {struct P} : Pol := + match P with + | Pc c => mkPinj j (PmulC Q c) + | Pinj j' Q' => + match ZPminus j' j with + | Zpos k => mkPinj j (Pmul (Pinj k Q') Q) + | Z0 => mkPinj j (Pmul Q' Q) + | Zneg k => mkPinj j' (PmulI k Q') + end + | PX P' i' Q' => + match j with + | xH => mkPX (PmulI xH P') i' (Pmul Q' Q) + | xO j' => mkPX (PmulI j P') i' (PmulI (Pdouble_minus_one j') Q') + | xI j' => mkPX (PmulI j P') i' (PmulI (xO j') Q') + end + 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' + | Pinj j' Q' => PmulI Pmul_aux Q' j' P + | PX P' i' Q' => + (mkPX (Pmul_aux P P') i' P0) ++ (PmulI Pmul_aux Q' xH P) + end. + + Definition Pmul P P' := + match P with + | Pc c => PmulC P' c + | Pinj j Q => PmulI Pmul_aux Q j P' + | PX P i Q => + (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 **) + + Inductive Mon: Set := + mon0: Mon + | zmon: positive -> Mon -> Mon + | vmon: positive -> Mon -> Mon. + + Fixpoint Mphi(l:Env 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_pos rmul x i in + (Mphi (tail l) M1) * xi + 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) + | Pc _, _ => (P, Pc cO) + | Pinj j1 P1, zmon j2 M1 => + match (j1 ?= j2) Eq with + Eq => let (R,S) := MFactor P1 M1 in + (mkPinj j1 R, mkPinj j1 S) + | Lt => let (R,S) := MFactor P1 (zmon (j2 - j1) M1) in + (mkPinj j1 R, mkPinj j1 S) + | Gt => (P, Pc cO) + end + | Pinj _ _, vmon _ _ => (P, Pc cO) + | PX P1 i Q1, zmon j M1 => + let M2 := zmon_pred j M1 in + let (R1, S1) := MFactor P1 M in + let (R2, S2) := MFactor Q1 M2 in + (mkPX R1 i R2, mkPX S1 i S2) + | PX P1 i Q1, vmon j M1 => + match (i ?= j) Eq with + Eq => let (R1,S1) := MFactor P1 (mkZmon xH M1) in + (mkPX R1 i Q1, S1) + | Lt => let (R1,S1) := MFactor P1 (vmon (j - i) M1) in + (mkPX R1 i Q1, S1) + | Gt => let (R1,S1) := MFactor P1 (mkZmon xH M1) in + (mkPX R1 i Q1, mkPX S1 (i-j) (Pc cO)) + end + end. + + Definition POneSubst (P1: Pol) (M1: Mon) (P2: Pol): option Pol := + let (Q1,R1) := MFactor P1 M1 in + match R1 with + (Pc c) => if c ?=! cO then None + else Some (Padd Q1 (Pmul P2 R1)) + | _ => Some (Padd Q1 (Pmul P2 R1)) + end. + + Fixpoint PNSubst1 (P1: Pol) (M1: Mon) (P2: Pol) (n: nat) {struct n}: Pol := + match POneSubst P1 M1 P2 with + Some P3 => match n with S n1 => PNSubst1 P3 M1 P2 n1 | _ => P3 end + | _ => P1 + end. + + Definition PNSubst (P1: Pol) (M1: Mon) (P2: Pol) (n: nat): option Pol := + match POneSubst P1 M1 P2 with + Some P3 => match n with S n1 => Some (PNSubst1 P3 M1 P2 n1) | _ => None end + | _ => None + end. + + Fixpoint PSubstL1 (P1: Pol) (LM1: list (Mon * Pol)) (n: nat) {struct LM1}: + Pol := + match LM1 with + cons (M1,P2) LM2 => PSubstL1 (PNSubst1 P1 M1 P2 n) LM2 n + | _ => P1 + end. + + Fixpoint PSubstL (P1: Pol) (LM1: list (Mon * Pol)) (n: nat) {struct LM1}: option Pol := + match LM1 with + cons (M1,P2) LM2 => + match PNSubst P1 M1 P2 n with + Some P3 => Some (PSubstL1 P3 LM2 n) + | None => PSubstL P1 LM2 n + end + | _ => None + end. + + Fixpoint PNSubstL (P1: Pol) (LM1: list (Mon * Pol)) (m n: nat) {struct m}: Pol := + match PSubstL P1 LM1 n with + Some P3 => match m with S m1 => PNSubstL P3 LM1 m1 n | _ => P3 end + | _ => P1 + end. + + (** Evaluation of a polynomial towards R *) + + Fixpoint Pphi(l:Env R) (P:Pol) {struct P} : R := + match P with + | Pc c => [c] + | Pinj j Q => Pphi (jump j l) Q + | PX P i Q => + let x := hd 0 l in + let xi := pow_pos rmul x i in + (Pphi l P) * xi + (Pphi (tail l) Q) + end. + + Reserved Notation "P @ l " (at level 10, no associativity). + Notation "P @ l " := (Pphi l P). + (** Proofs *) + Lemma ZPminus_spec : forall x y, + match ZPminus x y with + | Z0 => x = y + | Zpos k => x = (y + k)%positive + | Zneg k => y = (x + k)%positive + end. + Proof. + induction x;destruct y. + replace (ZPminus (xI x) (xI y)) with (Zdouble (ZPminus x y));trivial. + assert (H := IHx y);destruct (ZPminus x y);unfold Zdouble;rewrite H;trivial. + replace (ZPminus (xI x) (xO y)) with (Zdouble_plus_one (ZPminus x y));trivial. + assert (H := IHx y);destruct (ZPminus x y);unfold Zdouble_plus_one;rewrite H;trivial. + apply Pplus_xI_double_minus_one. + simpl;trivial. + replace (ZPminus (xO x) (xI y)) with (Zdouble_minus_one (ZPminus x y));trivial. + assert (H := IHx y);destruct (ZPminus x y);unfold Zdouble_minus_one;rewrite H;trivial. + apply Pplus_xI_double_minus_one. + replace (ZPminus (xO x) (xO y)) with (Zdouble (ZPminus x y));trivial. + assert (H := IHx y);destruct (ZPminus x y);unfold Zdouble;rewrite H;trivial. + replace (ZPminus (xO x) xH) with (Zpos (Pdouble_minus_one x));trivial. + rewrite <- Pplus_one_succ_l. + rewrite Psucc_o_double_minus_one_eq_xO;trivial. + replace (ZPminus xH (xI y)) with (Zneg (xO y));trivial. + replace (ZPminus xH (xO y)) with (Zneg (Pdouble_minus_one y));trivial. + rewrite <- Pplus_one_succ_l. + rewrite Psucc_o_double_minus_one_eq_xO;trivial. + simpl;trivial. + Qed. + + Lemma Peq_ok : forall P P', + (P ?== P') = true -> forall l, P@l == P'@ l. + Proof. + induction P;destruct P';simpl;intros;try discriminate;trivial. + apply (morph_eq CRmorph);trivial. + assert (H1 := Pcompare_Eq_eq p p0); destruct ((p ?= p0)%positive Eq); + try discriminate H. + rewrite (IHP P' H); rewrite H1;trivial;rrefl. + assert (H1 := Pcompare_Eq_eq p p0); destruct ((p ?= p0)%positive Eq); + try discriminate H. + rewrite H1;trivial. clear H1. + assert (H1 := IHP1 P'1);assert (H2 := IHP2 P'2); + destruct (P2 ?== P'1);[destruct (P3 ?== P'2); [idtac|discriminate H] + |discriminate H]. + rewrite (H1 H);rewrite (H2 H);rrefl. + Qed. + + Lemma Pphi0 : forall l, P0@l == 0. + Proof. + intros;simpl;apply (morph0 CRmorph). + Qed. + +Lemma env_morph : forall p e1 e2, (forall x, e1 x = e2 x) -> + p @ e1 = p @ e2. +Proof. + induction p ; simpl. + reflexivity. + intros. + apply IHp. + intros. + unfold jump. + apply H. + intros. + rewrite (IHp1 e1 e2) ; auto. + rewrite (IHp2 (tail e1) (tail e2)) ; auto. + unfold hd. unfold nth. rewrite H. reflexivity. + unfold tail. unfold jump. intros ; apply H. +Qed. + +Lemma Pjump_Pplus : forall P i j l, P @ (jump (i + j) l ) = P @ (jump j (jump i l)). +Proof. + intros. apply env_morph. intros. rewrite <- jump_Pplus. + rewrite Pplus_comm. + reflexivity. +Qed. + +Lemma Pjump_xO_tail : forall P p l, + P @ (jump (xO p) (tail l)) = P @ (jump (xI p) l). +Proof. + intros. + apply env_morph. + intros. + rewrite (@jump_simpl R (xI p)). + rewrite (@jump_simpl R (xO p)). + reflexivity. +Qed. + +Lemma Pjump_Pdouble_minus_one : forall P p l, + P @ (jump (Pdouble_minus_one p) (tail l)) = P @ (jump (xO p) l). +Proof. + intros. + apply env_morph. + intros. + rewrite jump_Pdouble_minus_one. + rewrite (@jump_simpl R (xO p)). + reflexivity. +Qed. + + + + Lemma Pphi1 : forall l, P1@l == 1. + Proof. + intros;simpl;apply (morph1 CRmorph). + Qed. + + Lemma mkPinj_ok : forall j l P, (mkPinj j P)@l == P@(jump j l). + Proof. + intros j l p;destruct p;simpl;rsimpl. + rewrite Pjump_Pplus. + reflexivity. + 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_pos rmul (hd 0 l) i) + Q@(tail l). + Proof. + intros l P i Q;unfold mkPX. + destruct P;try (simpl;rrefl). + assert (H := morph_eq CRmorph c cO);destruct (c ?=! cO);simpl;try rrefl. + rewrite (H (refl_equal true));rewrite (morph0 CRmorph). + 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_pos_Pplus;rsimpl. + Qed. + + + Ltac Esimpl := + repeat (progress ( + match goal with + | |- context [P0@?l] => rewrite (Pphi0 l) + | |- context [P1@?l] => rewrite (Pphi1 l) + | |- context [(mkPinj ?j ?P)@?l] => rewrite (mkPinj_ok j l P) + | |- context [(mkPX ?P ?i ?Q)@?l] => rewrite (mkPX_ok l P i Q) + | |- context [[cO]] => rewrite (morph0 CRmorph) + | |- context [[cI]] => rewrite (morph1 CRmorph) + | |- context [[?x +! ?y]] => rewrite ((morph_add CRmorph) x y) + | |- context [[?x *! ?y]] => rewrite ((morph_mul CRmorph) x y) + | |- context [[?x -! ?y]] => rewrite ((morph_sub CRmorph) x y) + | |- context [[-! ?x]] => rewrite ((morph_opp CRmorph) x) + end)); + rsimpl; simpl. + + Lemma PaddC_ok : forall c P l, (PaddC P c)@l == P@l + [c]. + Proof. + induction P;simpl;intros;Esimpl;trivial. + rewrite IHP2;rsimpl. + Qed. + + Lemma PsubC_ok : forall c P l, (PsubC P c)@l == P@l - [c]. + Proof. + induction P;simpl;intros. + Esimpl. + rewrite IHP;rsimpl. + rewrite IHP2;rsimpl. + Qed. + + Lemma PmulC_aux_ok : forall c P l, (PmulC_aux P c)@l == P@l * [c]. + Proof. + induction P;simpl;intros;Esimpl;trivial. + rewrite IHP1;rewrite IHP2;rsimpl. + mul_push ([c]);rrefl. + Qed. + + Lemma PmulC_ok : forall c P l, (PmulC P c)@l == P@l * [c]. + Proof. + intros c P l; unfold PmulC. + assert (H:= morph_eq CRmorph c cO);destruct (c ?=! cO). + rewrite (H (refl_equal true));Esimpl. + assert (H1:= morph_eq CRmorph c cI);destruct (c ?=! cI). + rewrite (H1 (refl_equal true));Esimpl. + apply PmulC_aux_ok. + Qed. + + Lemma Popp_ok : forall P l, (--P)@l == - P@l. + Proof. + induction P;simpl;intros. + Esimpl. + apply IHP. + rewrite IHP1;rewrite IHP2;rsimpl. + Qed. + + Ltac Esimpl2 := + Esimpl; + repeat (progress ( + match goal with + | |- context [(PaddC ?P ?c)@?l] => rewrite (PaddC_ok c P l) + | |- context [(PsubC ?P ?c)@?l] => rewrite (PsubC_ok c P l) + | |- context [(PmulC ?P ?c)@?l] => rewrite (PmulC_ok c P l) + | |- context [(--?P)@?l] => rewrite (Popp_ok P l) + end)); Esimpl. + + + + + Lemma Padd_ok : forall P' P l, (P ++ P')@l == P@l + P'@l. + Proof. + induction P';simpl;intros;Esimpl2. + generalize P p l;clear P p l. + induction P;simpl;intros. + Esimpl2;apply (ARadd_comm ARth). + assert (H := ZPminus_spec p p0);destruct (ZPminus p p0). + rewrite H;Esimpl. rewrite IHP';rrefl. + rewrite H;Esimpl. rewrite IHP';Esimpl. + rewrite Pjump_Pplus. rrefl. + rewrite H;Esimpl. rewrite IHP. + rewrite Pjump_Pplus. rrefl. + destruct p0;simpl. + rewrite IHP2;simpl. rsimpl. + rewrite Pjump_xO_tail. Esimpl. + rewrite IHP2;simpl. + rewrite Pjump_Pdouble_minus_one. + rsimpl. + rewrite IHP'. + rsimpl. + destruct P;simpl. + Esimpl2;add_push [c];rrefl. + destruct p0;simpl;Esimpl2. + rewrite IHP'2;simpl. + rewrite Pjump_xO_tail. + rsimpl;add_push (P'1@l * (pow_pos rmul (hd 0 l) p));rrefl. + rewrite IHP'2;simpl. + rewrite Pjump_Pdouble_minus_one. rsimpl. + add_push (P'1@l * (pow_pos rmul (hd 0 l) p));rrefl. + rewrite IHP'2;rsimpl. + unfold tail. + add_push (P @ (jump 1 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_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_pos rmul (hd 0 l) k). + induction P;simpl;intros;try apply (ARadd_comm ARth). + destruct p2; simpl; try apply (ARadd_comm ARth). + rewrite Pjump_xO_tail. + apply (ARadd_comm ARth). + rewrite Pjump_Pdouble_minus_one. + apply (ARadd_comm ARth). + assert (H1 := ZPminus_spec p2 k);destruct (ZPminus p2 k);Esimpl2. + rewrite IHP'1;rsimpl; rewrite H1;add_push (P5 @ (tail l0));rrefl. + rewrite IHP'1;simpl;Esimpl. + rewrite H1;rewrite Pplus_comm. + rewrite pow_pos_Pplus;simpl;Esimpl. + add_push (P5 @ (tail l0));rrefl. + rewrite IHP1;rewrite H1;rewrite Pplus_comm. + 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_pos_Pplus;rsimpl. + add_push (P3 @ (tail l));rrefl. + Qed. + + Lemma Psub_ok : forall P' P l, (P -- P')@l == P@l - P'@l. + Proof. + induction P';simpl;intros;Esimpl2;trivial. + generalize P p l;clear P p l. + induction P;simpl;intros. + Esimpl2;apply (ARadd_comm ARth). + assert (H := ZPminus_spec p p0);destruct (ZPminus p p0). + rewrite H;Esimpl. rewrite IHP';rsimpl. + rewrite H;Esimpl. rewrite IHP';Esimpl. + rewrite <- Pjump_Pplus;rewrite Pplus_comm;rrefl. + rewrite H;Esimpl. rewrite IHP. + rewrite <- Pjump_Pplus;rewrite Pplus_comm;rrefl. + destruct p0;simpl. + rewrite IHP2;simpl; try rewrite Pjump_xO_tail ; rsimpl. + rewrite IHP2;simpl. + rewrite Pjump_Pdouble_minus_one;rsimpl. + unfold tail ; rsimpl. + rewrite IHP';rsimpl. + 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_pos rmul (hd 0 l) p));trivial. + rewrite Pjump_xO_tail. + add_push (P @ ((jump (xI p0) l)));rrefl. + rewrite IHP'2;simpl;rewrite Pjump_Pdouble_minus_one;rsimpl. + add_push (- (P'1 @ l * pow_pos rmul (hd 0 l) p));rrefl. + unfold tail. + rewrite IHP'2;rsimpl;add_push (P @ (jump 1 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_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_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. + rewrite Pjump_xO_tail. + apply (ARadd_comm ARth);trivial. + rewrite Pjump_Pdouble_minus_one. + apply (ARadd_comm ARth);trivial. + apply (ARadd_comm ARth);trivial. + 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_pos_Pplus;simpl;Esimpl. + add_push (P5 @ (tail l0));rrefl. + rewrite IHP1;rewrite H1;rewrite Pplus_comm. + 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_pos_Pplus;rsimpl. + Qed. +(* Proof for the symmetric version *) + + Lemma PmulI_ok : + forall P', + (forall (P : Pol) (l : Env R), (Pmul P P') @ l == P @ l * P' @ l) -> + forall (P : Pol) (p : positive) (l : Env 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 Pjump_Pplus;simpl;rrefl. + rewrite H1. + rewrite Pjump_Pplus;rewrite IHP;rrefl. + destruct p0;Esimpl2. + rewrite IHP1;rewrite IHP2;rsimpl. + rewrite Pjump_xO_tail. + 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 Pjump_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) -> + forall (P : Pol) (p : positive) (l : list R), + (PmulI Pmul_aux 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 Pmul_aux_ok : forall P' P l,(Pmul_aux P P')@l == P@l * P'@l. + Proof. + induction P';simpl;intros. + Esimpl2;trivial. + apply PmulI_ok;trivial. + 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;rewrite IHP'2;Esimpl. + rewrite Pjump_xO_tail. reflexivity. + rewrite Pjump_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. + unfold tail. + mul_push (P'1@l). simpl. mul_push (P'2 @ (jump 1 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)). + apply (ARmul_comm ARth). + rewrite Padd_ok; Esimpl2. + rewrite (PmulI_ok P3 (Pmul_aux_ok P3));trivial. + 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 Mphi_morph : forall P env env', (forall x, env x = env' x ) -> + Mphi env P = Mphi env' P. + Proof. + induction P ; simpl. + reflexivity. + intros. + apply IHP. + intros. + unfold jump. + apply H. + (**) + intros. + replace (Mphi (tail env) P) with (Mphi (tail env') P). + unfold hd. unfold nth. + rewrite H. + reflexivity. + apply IHP. + unfold tail,jump. + intros. symmetry. apply H. + Qed. + +Lemma Mjump_xO_tail : forall M p l, + Mphi (jump (xO p) (tail l)) M = Mphi (jump (xI p) l) M. +Proof. + intros. + apply Mphi_morph. + intros. + rewrite (@jump_simpl R (xI p)). + rewrite (@jump_simpl R (xO p)). + reflexivity. +Qed. + +Lemma Mjump_Pdouble_minus_one : forall M p l, + Mphi (jump (Pdouble_minus_one p) (tail l)) M = Mphi (jump (xO p) l) M. +Proof. + intros. + apply Mphi_morph. + intros. + rewrite jump_Pdouble_minus_one. + rewrite (@jump_simpl R (xO p)). + reflexivity. +Qed. + +Lemma Mjump_Pplus : forall M i j l, Mphi (jump (i + j) l ) M = Mphi (jump j (jump i l)) M. +Proof. + intros. apply Mphi_morph. intros. rewrite <- jump_Pplus. + rewrite Pplus_comm. + reflexivity. +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 l; rsimpl. + rewrite mkZmon_ok;rsimpl. + simpl. + rewrite Mjump_xO_tail. + reflexivity. + rewrite mkZmon_ok;simpl. + rewrite Mjump_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 + P@l == Q@l + (Mphi l M) * (R@l). + Proof. + intros P; elim P; simpl; auto; clear P. + intros c M l; case M; simpl; auto; try intro p; try intro m; + try rewrite (morph0 CRmorph); rsimpl. + + intros i P Hrec M l; case M; simpl; clear M. + rewrite (morph0 CRmorph); rsimpl. + intros j M. + case_eq ((i ?= j) Eq); intros He; simpl. + rewrite (Pcompare_Eq_eq _ _ He). + generalize (Hrec M (jump j l)); case (MFactor P M); + simpl; intros P2 Q2 H; repeat rewrite mkPinj_ok; auto. + generalize (Hrec (zmon (j -i) M) (jump i l)); + case (MFactor P (zmon (j -i) M)); simpl. + intros P2 Q2 H; repeat rewrite mkPinj_ok; auto. + rewrite <- (Pplus_minus _ _ (ZC2 _ _ He)). + rewrite Mjump_Pplus; auto. + rewrite (morph0 CRmorph); rsimpl. + intros P2 m; rewrite (morph0 CRmorph); rsimpl. + + intros P2 Hrec1 i Q2 Hrec2 M l; case M; simpl; auto. + rewrite (morph0 CRmorph); rsimpl. + intros j M1. + generalize (Hrec1 (zmon j M1) l); + case (MFactor P2 (zmon j M1)). + intros R1 S1 H1. + generalize (Hrec2 (zmon_pred j M1) (tail l)); + case (MFactor Q2 (zmon_pred j M1)); simpl. + intros R2 S2 H2; rewrite H1; rewrite H2. + repeat rewrite mkPX_ok; simpl. + rsimpl. + apply radd_ext; rsimpl. + rewrite (ARadd_comm ARth); rsimpl. + apply radd_ext; rsimpl. + rewrite (ARadd_comm ARth); rsimpl. + rewrite zmon_pred_ok;rsimpl. + intros j M1. + case_eq ((i ?= j) Eq); intros He; simpl. + rewrite (Pcompare_Eq_eq _ _ He). + generalize (Hrec1 (mkZmon xH M1) l); case (MFactor P2 (mkZmon xH M1)); + simpl; intros P3 Q3 H; repeat rewrite mkPinj_ok; auto. + rewrite H; rewrite mkPX_ok; rsimpl. + repeat (rewrite <-(ARadd_assoc ARth)). + apply radd_ext; rsimpl. + rewrite (ARadd_comm ARth); rsimpl. + apply radd_ext; rsimpl. + repeat (rewrite <-(ARmul_assoc ARth)). + rewrite mkZmon_ok. + apply rmul_ext; rsimpl. + rewrite (ARmul_comm ARth); rsimpl. + generalize (Hrec1 (vmon (j - i) M1) l); + case (MFactor P2 (vmon (j - i) M1)); + simpl; intros P3 Q3 H; repeat rewrite mkPinj_ok; auto. + rewrite H; rsimpl; repeat rewrite mkPinj_ok; auto. + rewrite mkPX_ok; rsimpl. + repeat (rewrite <-(ARadd_assoc ARth)). + apply radd_ext; rsimpl. + rewrite (ARadd_comm ARth); rsimpl. + apply radd_ext; rsimpl. + repeat (rewrite <-(ARmul_assoc ARth)). + apply rmul_ext; rsimpl. + rewrite (ARmul_comm ARth); rsimpl. + apply rmul_ext; rsimpl. + rewrite <- pow_pos_Pplus. + rewrite (Pplus_minus _ _ (ZC2 _ _ He)); rsimpl. + generalize (Hrec1 (mkZmon 1 M1) l); + case (MFactor P2 (mkZmon 1 M1)); + simpl; intros P3 Q3 H; repeat rewrite mkPinj_ok; auto. + rewrite H; rsimpl. + rewrite mkPX_ok; rsimpl. + repeat (rewrite <-(ARadd_assoc ARth)). + apply radd_ext; rsimpl. + rewrite (ARadd_comm ARth); rsimpl. + apply radd_ext; rsimpl. + rewrite mkZmon_ok. + repeat (rewrite <-(ARmul_assoc ARth)). + apply rmul_ext; rsimpl. + rewrite (ARmul_comm ARth); rsimpl. + rewrite mkPX_ok; simpl; rsimpl. + rewrite (morph0 CRmorph); rsimpl. + repeat (rewrite <-(ARmul_assoc ARth)). + rewrite (ARmul_comm ARth (Q3@l)); rsimpl. + apply rmul_ext; rsimpl. + 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. + 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. + (* 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 PmulI_ok by (intros;apply Pmul_ok). rewrite H1; rsimpl. + intros i P5 P6 H1 H2 H3; rewrite H1; rewrite H3. + 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. + intros n; elim n; simpl; auto. + intros P2 M1 P3 l H. + generalize (fun P4 => @POneSubst_ok P2 M1 P3 P4 l); + case (POneSubst P2 M1 P3); [idtac | intros; rsimpl]. + intros P4 Hrec; rewrite (Hrec P4); auto; rsimpl. + intros n1 Hrec P2 M1 P3 l H. + generalize (fun P4 => @POneSubst_ok P2 M1 P3 P4 l); + case (POneSubst P2 M1 P3); [idtac | intros; rsimpl]. + intros P4 Hrec1; rewrite (Hrec1 P4); auto; rsimpl. + Qed. + + Lemma PNSubst_ok: forall n P1 M1 P2 l P3, + PNSubst P1 M1 P2 n = Some P3 -> Mphi l M1 == P2@l -> P1@l == P3@l. + Proof. + intros n P2 M1 P3 l P4; unfold PNSubst. + generalize (fun P4 => @POneSubst_ok P2 M1 P3 P4 l); + case (POneSubst P2 M1 P3); [idtac | intros; discriminate]. + intros P5 H1; case n; try (intros; discriminate). + intros n1 H2; injection H2; intros; subst. + rewrite <- PNSubst1_ok; auto. + Qed. + + Fixpoint MPcond (LM1: list (Mon * Pol)) (l: Env R) {struct LM1} : Prop := + match LM1 with + cons (M1,P2) LM2 => (Mphi l M1 == P2@l) /\ (MPcond LM2 l) + | _ => True + end. + + Lemma PSubstL1_ok: forall n LM1 P1 l, + MPcond LM1 l -> P1@l == (PSubstL1 P1 LM1 n)@l. + Proof. + intros n LM1; elim LM1; simpl; auto. + intros; rsimpl. + intros (M2,P2) LM2 Hrec P3 l [H H1]. + rewrite <- Hrec; auto. + apply PNSubst1_ok; auto. + Qed. + + Lemma PSubstL_ok: forall n LM1 P1 P2 l, + PSubstL P1 LM1 n = Some P2 -> MPcond LM1 l -> P1@l == P2@l. + Proof. + intros n LM1; elim LM1; simpl; auto. + intros; discriminate. + intros (M2,P2) LM2 Hrec P3 P4 l. + generalize (PNSubst_ok n P3 M2 P2); case (PNSubst P3 M2 P2 n). + intros P5 H0 H1 [H2 H3]; injection H1; intros; subst. + rewrite <- PSubstL1_ok; auto. + intros l1 H [H1 H2]; auto. + Qed. + + Lemma PNSubstL_ok: forall m n LM1 P1 l, + MPcond LM1 l -> P1@l == (PNSubstL P1 LM1 m n)@l. + Proof. + intros m; elim m; simpl; auto. + intros n LM1 P2 l H; generalize (fun P3 => @PSubstL_ok n LM1 P2 P3 l); + case (PSubstL P2 LM1 n); intros; rsimpl; auto. + intros m1 Hrec n LM1 P2 l H. + generalize (fun P3 => @PSubstL_ok n LM1 P2 P3 l); + case (PSubstL P2 LM1 n); intros; rsimpl; auto. + rewrite <- Hrec; auto. + Qed. + + (** Definition of polynomial expressions *) + + Inductive PExpr : Type := + | PEc : C -> PExpr + | PEX : positive -> PExpr + | PEadd : PExpr -> PExpr -> PExpr + | PEsub : PExpr -> PExpr -> PExpr + | PEmul : PExpr -> PExpr -> PExpr + | PEopp : PExpr -> PExpr + | PEpow : PExpr -> N -> PExpr. + + (** evaluation of polynomial expressions towards R *) + Definition mk_X j := mkPinj_pred j mkX. + + (** evaluation of polynomial expressions towards R *) + + Fixpoint PEeval (l:Env R) (pe:PExpr) {struct pe} : R := + match pe with + | PEc c => phi c + | PEX j => nth 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 p l == (mk_X p) @ l. + Proof. + destruct p;simpl;intros;Esimpl;trivial. + rewrite nth_spec ; auto. + unfold hd. + rewrite <- nth_Pdouble_minus_one. + rewrite (nth_jump (Pdouble_minus_one p) l 1). + reflexivity. + 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) + 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. auto. 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. + + 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 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 by reflexivity. + 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. + + + End NORM_SUBST_REC. + + +End MakeRingPol. + diff --git a/contrib/micromega/LICENSE.sos b/contrib/micromega/LICENSE.sos new file mode 100644 index 00000000..5aadfa2a --- /dev/null +++ b/contrib/micromega/LICENSE.sos @@ -0,0 +1,29 @@ + HOL Light copyright notice, licence and disclaimer + + (c) University of Cambridge 1998 + (c) Copyright, John Harrison 1998-2006 + +HOL Light version 2.20, hereinafter referred to as "the software", is a +computer theorem proving system written by John Harrison. Much of the +software was developed at the University of Cambridge Computer Laboratory, +New Museums Site, Pembroke Street, Cambridge, CB2 3QG, England. The +software is copyright, University of Cambridge 1998 and John Harrison +1998-2006. + +Permission to use, copy, modify, and distribute the software and its +documentation for any purpose and without fee is hereby granted. In the +case of further distribution of the software the present text, including +copyright notice, licence and disclaimer of warranty, must be included in +full and unmodified form in any release. Distribution of derivative +software obtained by modifying the software, or incorporating it into +other software, is permitted, provided the inclusion of the software is +acknowledged and that any changes made to the software are clearly +documented. + +John Harrison and the University of Cambridge disclaim all warranties +with regard to the software, including all implied warranties of +merchantability and fitness. In no event shall John Harrison or the +University of Cambridge be liable for any special, indirect, +incidental or consequential damages or any damages whatsoever, +including, but not limited to, those arising from computer failure or +malfunction, work stoppage, loss of profit or loss of contracts. diff --git a/contrib/micromega/MExtraction.v b/contrib/micromega/MExtraction.v new file mode 100644 index 00000000..a5ac92db --- /dev/null +++ b/contrib/micromega/MExtraction.v @@ -0,0 +1,23 @@ +(************************************************************************) +(* 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 *) +(************************************************************************) +(* *) +(* Micromega: A reflexive tactic using the Positivstellensatz *) +(* *) +(* Frédéric Besson (Irisa/Inria) 2006-2008 *) +(* *) +(************************************************************************) + +(* Used to generate micromega.ml *) + +Require Import ZMicromega. +Require Import QMicromega. +Require Import VarMap. +Require Import RingMicromega. +Require Import NArith. + +Extraction "micromega.ml" List.map simpl_cone map_cone indexes n_of_Z Nnat.N_of_nat ZTautoChecker QTautoChecker find. diff --git a/contrib/micromega/Micromegatac.v b/contrib/micromega/Micromegatac.v new file mode 100644 index 00000000..13c7eace --- /dev/null +++ b/contrib/micromega/Micromegatac.v @@ -0,0 +1,79 @@ +(************************************************************************) +(* 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 *) +(************************************************************************) +(* *) +(* Micromega: A reflexive tactic using the Positivstellensatz *) +(* *) +(* Frédéric Besson (Irisa/Inria) 2006-2008 *) +(* *) +(************************************************************************) + +Require Import ZMicromega. +Require Import QMicromega. +Require Import RMicromega. +Require Import QArith. +Require Export Ring_normalize. +Require Import ZArith. +Require Import Raxioms. +Require Export RingMicromega. +Require Import VarMap. +Require Tauto. + +Ltac micromegac dom d := + let tac := lazymatch dom with + | Z => + micromegap d ; + intros __wit __varmap __ff ; + change (Tauto.eval_f (Zeval_formula (@find Z Z0 __varmap)) __ff) ; + apply (ZTautoChecker_sound __ff __wit); vm_compute ; reflexivity + | R => + rmicromegap d ; + intros __wit __varmap __ff ; + change (Tauto.eval_f (Reval_formula (@find R 0%R __varmap)) __ff) ; + apply (RTautoChecker_sound __ff __wit); vm_compute ; reflexivity + | _ => fail "Unsupported domain" + end in tac. + +Tactic Notation "micromega" constr(dom) int_or_var(n) := micromegac dom n. +Tactic Notation "micromega" constr(dom) := micromegac dom ltac:-1. + +Ltac zfarkas := omicronp ; + intros __wit __varmap __ff ; + change (Tauto.eval_f (Zeval_formula (@find Z Z0 __varmap)) __ff) ; + apply (ZTautoChecker_sound __ff __wit); vm_compute ; reflexivity. + +Ltac omicron dom := + let tac := lazymatch dom with + | Z => + zomicronp ; + intros __wit __varmap __ff ; + change (Tauto.eval_f (Zeval_formula (@find Z Z0 __varmap)) __ff) ; + apply (ZTautoChecker_sound __ff __wit); vm_compute ; reflexivity + | Q => + qomicronp ; + intros __wit __varmap __ff ; + change (Tauto.eval_f (Qeval_formula (@find Q 0%Q __varmap)) __ff) ; + apply (QTautoChecker_sound __ff __wit); vm_compute ; reflexivity + | R => + romicronp ; + intros __wit __varmap __ff ; + change (Tauto.eval_f (Reval_formula (@find R 0%R __varmap)) __ff) ; + apply (RTautoChecker_sound __ff __wit); vm_compute ; reflexivity + | _ => fail "Unsupported domain" + end in tac. + +Ltac sos dom := + let tac := lazymatch dom with + | Z => + sosp ; + intros __wit __varmap __ff ; + change (Tauto.eval_f (Zeval_formula (@find Z Z0 __varmap)) __ff) ; + apply (ZTautoChecker_sound __ff __wit); vm_compute ; reflexivity + | _ => fail "Unsupported domain" + end in tac. + + diff --git a/contrib/micromega/OrderedRing.v b/contrib/micromega/OrderedRing.v new file mode 100644 index 00000000..149b7731 --- /dev/null +++ b/contrib/micromega/OrderedRing.v @@ -0,0 +1,458 @@ +(************************************************************************) +(* 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 *) +(************************************************************************) +(* Evgeny Makarov, INRIA, 2007 *) +(************************************************************************) + +Require Import Setoid. +Require Import Ring. + +(** Generic properties of ordered rings on a setoid equality *) + +Set Implicit Arguments. + +Module Import OrderedRingSyntax. +Export RingSyntax. + +Reserved Notation "x ~= y" (at level 70, no associativity). +Reserved Notation "x [=] y" (at level 70, no associativity). +Reserved Notation "x [~=] y" (at level 70, no associativity). +Reserved Notation "x [<] y" (at level 70, no associativity). +Reserved Notation "x [<=] y" (at level 70, no associativity). +End OrderedRingSyntax. + +Section DEFINITIONS. + +Variable R : Type. +Variable (rO rI : R) (rplus rtimes rminus: R -> R -> R) (ropp : R -> R). +Variable req rle rlt : R -> R -> Prop. +Notation "0" := rO. +Notation "1" := rI. +Notation "x + y" := (rplus x y). +Notation "x * y " := (rtimes x y). +Notation "x - y " := (rminus x y). +Notation "- x" := (ropp x). +Notation "x == y" := (req x y). +Notation "x ~= y" := (~ req x y). +Notation "x <= y" := (rle x y). +Notation "x < y" := (rlt x y). + +Record SOR : Type := mk_SOR_theory { + SORsetoid : Setoid_Theory R req; + SORplus_wd : forall x1 x2, x1 == x2 -> forall y1 y2, y1 == y2 -> x1 + y1 == x2 + y2; + SORtimes_wd : forall x1 x2, x1 == x2 -> forall y1 y2, y1 == y2 -> x1 * y1 == x2 * y2; + SORopp_wd : forall x1 x2, x1 == x2 -> -x1 == -x2; + SORle_wd : forall x1 x2, x1 == x2 -> forall y1 y2, y1 == y2 -> (x1 <= y1 <-> x2 <= y2); + SORlt_wd : forall x1 x2, x1 == x2 -> forall y1 y2, y1 == y2 -> (x1 < y1 <-> x2 < y2); + SORrt : ring_theory rO rI rplus rtimes rminus ropp req; + SORle_refl : forall n : R, n <= n; + SORle_antisymm : forall n m : R, n <= m -> m <= n -> n == m; + SORle_trans : forall n m p : R, n <= m -> m <= p -> n <= p; + SORlt_le_neq : forall n m : R, n < m <-> n <= m /\ n ~= m; + SORlt_trichotomy : forall n m : R, n < m \/ n == m \/ m < n; + SORplus_le_mono_l : forall n m p : R, n <= m -> p + n <= p + m; + SORtimes_pos_pos : forall n m : R, 0 < n -> 0 < m -> 0 < n * m; + SORneq_0_1 : 0 ~= 1 +}. + +(* We cannot use Relation_Definitions.order.ord_antisym and +Relations_1.Antisymmetric because they refer to Leibniz equality *) + +End DEFINITIONS. + +Section STRICT_ORDERED_RING. + +Variable R : Type. +Variable (rO rI : R) (rplus rtimes rminus: R -> R -> R) (ropp : R -> R). +Variable req rle rlt : R -> R -> Prop. + +Variable sor : SOR rO rI rplus rtimes rminus ropp req rle rlt. + +Notation "0" := rO. +Notation "1" := rI. +Notation "x + y" := (rplus x y). +Notation "x * y " := (rtimes x y). +Notation "x - y " := (rminus x y). +Notation "- x" := (ropp x). +Notation "x == y" := (req x y). +Notation "x ~= y" := (~ req x y). +Notation "x <= y" := (rle x y). +Notation "x < y" := (rlt x y). + + +Add Relation R req + reflexivity proved by sor.(SORsetoid).(@Equivalence_Reflexive _ _ ) + symmetry proved by sor.(SORsetoid).(@Equivalence_Symmetric _ _ ) + transitivity proved by sor.(SORsetoid).(@Equivalence_Transitive _ _ ) +as sor_setoid. + + +Add Morphism rplus with signature req ==> req ==> req as rplus_morph. +Proof. +exact sor.(SORplus_wd). +Qed. +Add Morphism rtimes with signature req ==> req ==> req as rtimes_morph. +Proof. +exact sor.(SORtimes_wd). +Qed. +Add Morphism ropp with signature req ==> req as ropp_morph. +Proof. +exact sor.(SORopp_wd). +Qed. +Add Morphism rle with signature req ==> req ==> iff as rle_morph. +Proof. +exact sor.(SORle_wd). +Qed. +Add Morphism rlt with signature req ==> req ==> iff as rlt_morph. +Proof. +exact sor.(SORlt_wd). +Qed. + +Add Ring SOR : sor.(SORrt). + +Add Morphism rminus with signature req ==> req ==> req as rminus_morph. +Proof. +intros x1 x2 H1 y1 y2 H2. +rewrite (sor.(SORrt).(Rsub_def) x1 y1). +rewrite (sor.(SORrt).(Rsub_def) x2 y2). +rewrite H1; now rewrite H2. +Qed. + +Theorem Rneq_symm : forall n m : R, n ~= m -> m ~= n. +Proof. +intros n m H1 H2; rewrite H2 in H1; now apply H1. +Qed. + +(* Propeties of plus, minus and opp *) + +Theorem Rplus_0_l : forall n : R, 0 + n == n. +Proof. +intro; ring. +Qed. + +Theorem Rplus_0_r : forall n : R, n + 0 == n. +Proof. +intro; ring. +Qed. + +Theorem Rtimes_0_r : forall n : R, n * 0 == 0. +Proof. +intro; ring. +Qed. + +Theorem Rplus_comm : forall n m : R, n + m == m + n. +Proof. +intros; ring. +Qed. + +Theorem Rtimes_0_l : forall n : R, 0 * n == 0. +Proof. +intro; ring. +Qed. + +Theorem Rtimes_comm : forall n m : R, n * m == m * n. +Proof. +intros; ring. +Qed. + +Theorem Rminus_eq_0 : forall n m : R, n - m == 0 <-> n == m. +Proof. +intros n m. +split; intro H. setoid_replace n with ((n - m) + m) by ring. rewrite H. +now rewrite Rplus_0_l. +rewrite H; ring. +Qed. + +Theorem Rplus_cancel_l : forall n m p : R, p + n == p + m <-> n == m. +Proof. +intros n m p; split; intro H. +setoid_replace n with (- p + (p + n)) by ring. +setoid_replace m with (- p + (p + m)) by ring. now rewrite H. +now rewrite H. +Qed. + +(* Relations *) + +Theorem Rle_refl : forall n : R, n <= n. +Proof sor.(SORle_refl). + +Theorem Rle_antisymm : forall n m : R, n <= m -> m <= n -> n == m. +Proof sor.(SORle_antisymm). + +Theorem Rle_trans : forall n m p : R, n <= m -> m <= p -> n <= p. +Proof sor.(SORle_trans). + +Theorem Rlt_trichotomy : forall n m : R, n < m \/ n == m \/ m < n. +Proof sor.(SORlt_trichotomy). + +Theorem Rlt_le_neq : forall n m : R, n < m <-> n <= m /\ n ~= m. +Proof sor.(SORlt_le_neq). + +Theorem Rneq_0_1 : 0 ~= 1. +Proof sor.(SORneq_0_1). + +Theorem Req_em : forall n m : R, n == m \/ n ~= m. +Proof. +intros n m. destruct (Rlt_trichotomy n m) as [H | [H | H]]; try rewrite Rlt_le_neq in H. +right; now destruct H. +now left. +right; apply Rneq_symm; now destruct H. +Qed. + +Theorem Req_dne : forall n m : R, ~ ~ n == m <-> n == m. +Proof. +intros n m; destruct (Req_em n m) as [H | H]. +split; auto. +split. intro H1; false_hyp H H1. auto. +Qed. + +Theorem Rle_lt_eq : forall n m : R, n <= m <-> n < m \/ n == m. +Proof. +intros n m; rewrite Rlt_le_neq. +split; [intro H | intros [[H1 H2] | H]]. +destruct (Req_em n m) as [H1 | H1]. now right. left; now split. +assumption. +rewrite H; apply Rle_refl. +Qed. + +Ltac le_less := rewrite Rle_lt_eq; left; try assumption. +Ltac le_equal := rewrite Rle_lt_eq; right; try reflexivity; try assumption. +Ltac le_elim H := rewrite Rle_lt_eq in H; destruct H as [H | H]. + +Theorem Rlt_trans : forall n m p : R, n < m -> m < p -> n < p. +Proof. +intros n m p; repeat rewrite Rlt_le_neq; intros [H1 H2] [H3 H4]; split. +now apply Rle_trans with m. +intro H. rewrite H in H1. pose proof (Rle_antisymm H3 H1). now apply H4. +Qed. + +Theorem Rle_lt_trans : forall n m p : R, n <= m -> m < p -> n < p. +Proof. +intros n m p H1 H2; le_elim H1. +now apply Rlt_trans with (m := m). now rewrite H1. +Qed. + +Theorem Rlt_le_trans : forall n m p : R, n < m -> m <= p -> n < p. +Proof. +intros n m p H1 H2; le_elim H2. +now apply Rlt_trans with (m := m). now rewrite <- H2. +Qed. + +Theorem Rle_gt_cases : forall n m : R, n <= m \/ m < n. +Proof. +intros n m; destruct (Rlt_trichotomy n m) as [H | [H | H]]. +left; now le_less. left; now le_equal. now right. +Qed. + +Theorem Rlt_neq : forall n m : R, n < m -> n ~= m. +Proof. +intros n m; rewrite Rlt_le_neq; now intros [_ H]. +Qed. + +Theorem Rle_ngt : forall n m : R, n <= m <-> ~ m < n. +Proof. +intros n m; split. +intros H H1; assert (H2 : n < n) by now apply Rle_lt_trans with m. now apply (Rlt_neq H2). +intro H. destruct (Rle_gt_cases n m) as [H1 | H1]. assumption. false_hyp H1 H. +Qed. + +Theorem Rlt_nge : forall n m : R, n < m <-> ~ m <= n. +Proof. +intros n m; split. +intros H H1; assert (H2 : n < n) by now apply Rlt_le_trans with m. now apply (Rlt_neq H2). +intro H. destruct (Rle_gt_cases m n) as [H1 | H1]. false_hyp H1 H. assumption. +Qed. + +(* Plus, minus and order *) + +Theorem Rplus_le_mono_l : forall n m p : R, n <= m <-> p + n <= p + m. +Proof. +intros n m p; split. +apply sor.(SORplus_le_mono_l). +intro H. apply (sor.(SORplus_le_mono_l) (p + n) (p + m) (- p)) in H. +setoid_replace (- p + (p + n)) with n in H by ring. +setoid_replace (- p + (p + m)) with m in H by ring. assumption. +Qed. + +Theorem Rplus_le_mono_r : forall n m p : R, n <= m <-> n + p <= m + p. +Proof. +intros n m p; rewrite (Rplus_comm n p); rewrite (Rplus_comm m p). +apply Rplus_le_mono_l. +Qed. + +Theorem Rplus_lt_mono_l : forall n m p : R, n < m <-> p + n < p + m. +Proof. +intros n m p; do 2 rewrite Rlt_le_neq. rewrite Rplus_cancel_l. +now rewrite <- Rplus_le_mono_l. +Qed. + +Theorem Rplus_lt_mono_r : forall n m p : R, n < m <-> n + p < m + p. +Proof. +intros n m p. +rewrite (Rplus_comm n p); rewrite (Rplus_comm m p); apply Rplus_lt_mono_l. +Qed. + +Theorem Rplus_lt_mono : forall n m p q : R, n < m -> p < q -> n + p < m + q. +Proof. +intros n m p q H1 H2. +apply Rlt_trans with (m + p); [now apply -> Rplus_lt_mono_r | now apply -> Rplus_lt_mono_l]. +Qed. + +Theorem Rplus_le_mono : forall n m p q : R, n <= m -> p <= q -> n + p <= m + q. +Proof. +intros n m p q H1 H2. +apply Rle_trans with (m + p); [now apply -> Rplus_le_mono_r | now apply -> Rplus_le_mono_l]. +Qed. + +Theorem Rplus_lt_le_mono : forall n m p q : R, n < m -> p <= q -> n + p < m + q. +Proof. +intros n m p q H1 H2. +apply Rlt_le_trans with (m + p); [now apply -> Rplus_lt_mono_r | now apply -> Rplus_le_mono_l]. +Qed. + +Theorem Rplus_le_lt_mono : forall n m p q : R, n <= m -> p < q -> n + p < m + q. +Proof. +intros n m p q H1 H2. +apply Rle_lt_trans with (m + p); [now apply -> Rplus_le_mono_r | now apply -> Rplus_lt_mono_l]. +Qed. + +Theorem Rplus_pos_pos : forall n m : R, 0 < n -> 0 < m -> 0 < n + m. +Proof. +intros n m H1 H2. rewrite <- (Rplus_0_l 0). now apply Rplus_lt_mono. +Qed. + +Theorem Rplus_pos_nonneg : forall n m : R, 0 < n -> 0 <= m -> 0 < n + m. +Proof. +intros n m H1 H2. rewrite <- (Rplus_0_l 0). now apply Rplus_lt_le_mono. +Qed. + +Theorem Rplus_nonneg_pos : forall n m : R, 0 <= n -> 0 < m -> 0 < n + m. +Proof. +intros n m H1 H2. rewrite <- (Rplus_0_l 0). now apply Rplus_le_lt_mono. +Qed. + +Theorem Rplus_nonneg_nonneg : forall n m : R, 0 <= n -> 0 <= m -> 0 <= n + m. +Proof. +intros n m H1 H2. rewrite <- (Rplus_0_l 0). now apply Rplus_le_mono. +Qed. + +Theorem Rle_le_minus : forall n m : R, n <= m <-> 0 <= m - n. +Proof. +intros n m. rewrite (@Rplus_le_mono_r n m (- n)). +setoid_replace (n + - n) with 0 by ring. +now setoid_replace (m + - n) with (m - n) by ring. +Qed. + +Theorem Rlt_lt_minus : forall n m : R, n < m <-> 0 < m - n. +Proof. +intros n m. rewrite (@Rplus_lt_mono_r n m (- n)). +setoid_replace (n + - n) with 0 by ring. +now setoid_replace (m + - n) with (m - n) by ring. +Qed. + +Theorem Ropp_lt_mono : forall n m : R, n < m <-> - m < - n. +Proof. +intros n m. split; intro H. +apply -> (@Rplus_lt_mono_l n m (- n - m)) in H. +setoid_replace (- n - m + n) with (- m) in H by ring. +now setoid_replace (- n - m + m) with (- n) in H by ring. +apply -> (@Rplus_lt_mono_l (- m) (- n) (n + m)) in H. +setoid_replace (n + m + - m) with n in H by ring. +now setoid_replace (n + m + - n) with m in H by ring. +Qed. + +Theorem Ropp_pos_neg : forall n : R, 0 < - n <-> n < 0. +Proof. +intro n; rewrite (Ropp_lt_mono n 0). now setoid_replace (- 0) with 0 by ring. +Qed. + +(* Times and order *) + +Theorem Rtimes_pos_pos : forall n m : R, 0 < n -> 0 < m -> 0 < n * m. +Proof sor.(SORtimes_pos_pos). + +Theorem Rtimes_nonneg_nonneg : forall n m : R, 0 <= n -> 0 <= m -> 0 <= n * m. +Proof. +intros n m H1 H2. +le_elim H1. le_elim H2. +le_less; now apply Rtimes_pos_pos. +rewrite <- H2; rewrite Rtimes_0_r; le_equal. +rewrite <- H1; rewrite Rtimes_0_l; le_equal. +Qed. + +Theorem Rtimes_pos_neg : forall n m : R, 0 < n -> m < 0 -> n * m < 0. +Proof. +intros n m H1 H2. apply -> Ropp_pos_neg. +setoid_replace (- (n * m)) with (n * (- m)) by ring. +apply Rtimes_pos_pos. assumption. now apply <- Ropp_pos_neg. +Qed. + +Theorem Rtimes_neg_neg : forall n m : R, n < 0 -> m < 0 -> 0 < n * m. +Proof. +intros n m H1 H2. +setoid_replace (n * m) with ((- n) * (- m)) by ring. +apply Rtimes_pos_pos; now apply <- Ropp_pos_neg. +Qed. + +Theorem Rtimes_square_nonneg : forall n : R, 0 <= n * n. +Proof. +intro n; destruct (Rlt_trichotomy 0 n) as [H | [H | H]]. +le_less; now apply Rtimes_pos_pos. +rewrite <- H, Rtimes_0_l; le_equal. +le_less; now apply Rtimes_neg_neg. +Qed. + +Theorem Rtimes_neq_0 : forall n m : R, n ~= 0 /\ m ~= 0 -> n * m ~= 0. +Proof. +intros n m [H1 H2]. +destruct (Rlt_trichotomy n 0) as [H3 | [H3 | H3]]; +destruct (Rlt_trichotomy m 0) as [H4 | [H4 | H4]]; +try (false_hyp H3 H1); try (false_hyp H4 H2). +apply Rneq_symm. apply Rlt_neq. now apply Rtimes_neg_neg. +apply Rlt_neq. rewrite Rtimes_comm. now apply Rtimes_pos_neg. +apply Rlt_neq. now apply Rtimes_pos_neg. +apply Rneq_symm. apply Rlt_neq. now apply Rtimes_pos_pos. +Qed. + +(* The following theorems are used to build a morphism from Z to R and +prove its properties in ZCoeff.v. They are not used in RingMicromega.v. *) + +(* Surprisingly, multilication is needed to prove the following theorem *) + +Theorem Ropp_neg_pos : forall n : R, - n < 0 <-> 0 < n. +Proof. +intro n; setoid_replace n with (- - n) by ring. rewrite Ropp_pos_neg. +now setoid_replace (- - n) with n by ring. +Qed. + +Theorem Rlt_0_1 : 0 < 1. +Proof. +apply <- Rlt_le_neq. split. +setoid_replace 1 with (1 * 1) by ring. apply Rtimes_square_nonneg. +apply Rneq_0_1. +Qed. + +Theorem Rlt_succ_r : forall n : R, n < 1 + n. +Proof. +intro n. rewrite <- (Rplus_0_l n); setoid_replace (1 + (0 + n)) with (1 + n) by ring. +apply -> Rplus_lt_mono_r. apply Rlt_0_1. +Qed. + +Theorem Rlt_lt_succ : forall n m : R, n < m -> n < 1 + m. +Proof. +intros n m H; apply Rlt_trans with m. assumption. apply Rlt_succ_r. +Qed. + +(*Theorem Rtimes_lt_mono_pos_l : forall n m p : R, 0 < p -> n < m -> p * n < p * m. +Proof. +intros n m p H1 H2. apply <- Rlt_lt_minus. +setoid_replace (p * m - p * n) with (p * (m - n)) by ring. +apply Rtimes_pos_pos. assumption. now apply -> Rlt_lt_minus. +Qed.*) + +End STRICT_ORDERED_RING. + diff --git a/contrib/micromega/QMicromega.v b/contrib/micromega/QMicromega.v new file mode 100644 index 00000000..9e95f6c4 --- /dev/null +++ b/contrib/micromega/QMicromega.v @@ -0,0 +1,259 @@ +(************************************************************************) +(* 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 *) +(************************************************************************) +(* *) +(* Micromega: A reflexive tactic using the Positivstellensatz *) +(* *) +(* Frédéric Besson (Irisa/Inria) 2006-2008 *) +(* *) +(************************************************************************) + +Require Import OrderedRing. +Require Import RingMicromega. +Require Import Refl. +Require Import QArith. +Require Import Qring. + +(* Qsrt has been removed from the library ? *) +Definition Qsrt : ring_theory 0 1 Qplus Qmult Qminus Qopp Qeq. +Proof. + constructor. + exact Qplus_0_l. + exact Qplus_comm. + exact Qplus_assoc. + exact Qmult_1_l. + exact Qmult_comm. + exact Qmult_assoc. + exact Qmult_plus_distr_l. + reflexivity. + exact Qplus_opp_r. +Qed. + + +Add Ring Qring : Qsrt. + +Lemma Qmult_neutral : forall x , 0 * x == 0. +Proof. + intros. + compute. + reflexivity. +Qed. + +(* Is there any qarith database ? *) + +Lemma Qsor : SOR 0 1 Qplus Qmult Qminus Qopp Qeq Qle Qlt. +Proof. + constructor; intros ; subst ; try (intuition (subst; auto with qarith)). + apply Q_Setoid. + rewrite H ; rewrite H0 ; reflexivity. + rewrite H ; rewrite H0 ; reflexivity. + rewrite H ; auto ; reflexivity. + rewrite <- H ; rewrite <- H0 ; auto. + rewrite H ; rewrite H0 ; auto. + rewrite <- H ; rewrite <- H0 ; auto. + rewrite H ; rewrite H0 ; auto. + apply Qsrt. + apply Qle_refl. + apply Qle_antisym ; auto. + eapply Qle_trans ; eauto. + apply Qlt_le_weak ; auto. + apply (Qlt_not_eq n m H H0) ; auto. + destruct (Qle_lt_or_eq _ _ H0) ; auto. + tauto. + destruct(Q_dec n m) as [[H1 |H1] | H1 ] ; tauto. + apply (Qplus_le_compat p p n m (Qle_refl p) H). + generalize (Qmult_lt_compat_r 0 n m H0 H). + rewrite Qmult_neutral. + auto. + compute in H. + discriminate. +Qed. + +Definition Qeq_bool (p q : Q) : bool := Zeq_bool (Qnum p * ' Qden q)%Z (Qnum q * ' Qden p)%Z. + +Definition Qle_bool (x y : Q) : bool := Zle_bool (Qnum x * ' Qden y)%Z (Qnum y * ' Qden x)%Z. + +Require ZMicromega. + +Lemma Qeq_bool_ok : forall x y, Qeq_bool x y = true -> x == y. +Proof. + intros. + unfold Qeq_bool in H. + unfold Qeq. + apply (Zeqb_ok _ _ H). +Qed. + + +Lemma Qeq_bool_neq : forall x y, Qeq_bool x y = false -> ~ x == y. +Proof. + unfold Qeq_bool,Qeq. + red ; intros ; subst. + rewrite H0 in H. + apply (ZMicromega.Zeq_bool_neq _ _ H). + reflexivity. +Qed. + +Lemma Qle_bool_imp_le : forall x y : Q, Qle_bool x y = true -> x <= y. +Proof. + unfold Qle_bool, Qle. + intros. + apply Zle_bool_imp_le ; auto. +Qed. + + + + +Lemma QSORaddon : + SORaddon 0 1 Qplus Qmult Qminus Qopp Qeq Qle (* ring elements *) + 0 1 Qplus Qmult Qminus Qopp (* coefficients *) + Qeq_bool Qle_bool + (fun x => x) (fun x => x) (pow_N 1 Qmult). +Proof. + constructor. + constructor ; intros ; try reflexivity. + apply Qeq_bool_ok ; auto. + constructor. + reflexivity. + intros x y. + apply Qeq_bool_neq ; auto. + apply Qle_bool_imp_le. +Qed. + + +(*Definition Zeval_expr := eval_pexpr 0 Zplus Zmult Zminus Zopp (fun x => x) (fun x => Z_of_N x) (Zpower).*) +Require Import EnvRing. + +Fixpoint Qeval_expr (env: PolEnv Q) (e: PExpr Q) : Q := + match e with + | PEc c => c + | PEX j => env j + | PEadd pe1 pe2 => (Qeval_expr env pe1) + (Qeval_expr env pe2) + | PEsub pe1 pe2 => (Qeval_expr env pe1) - (Qeval_expr env pe2) + | PEmul pe1 pe2 => (Qeval_expr env pe1) * (Qeval_expr env pe2) + | PEopp pe1 => - (Qeval_expr env pe1) + | PEpow pe1 n => Qpower (Qeval_expr env pe1) (Z_of_N n) + end. + +Lemma Qeval_expr_simpl : forall env e, + Qeval_expr env e = + match e with + | PEc c => c + | PEX j => env j + | PEadd pe1 pe2 => (Qeval_expr env pe1) + (Qeval_expr env pe2) + | PEsub pe1 pe2 => (Qeval_expr env pe1) - (Qeval_expr env pe2) + | PEmul pe1 pe2 => (Qeval_expr env pe1) * (Qeval_expr env pe2) + | PEopp pe1 => - (Qeval_expr env pe1) + | PEpow pe1 n => Qpower (Qeval_expr env pe1) (Z_of_N n) + end. +Proof. + destruct e ; reflexivity. +Qed. + +Definition Qeval_expr' := eval_pexpr Qplus Qmult Qminus Qopp (fun x => x) (fun x => x) (pow_N 1 Qmult). + +Lemma QNpower : forall r n, r ^ Z_of_N n = pow_N 1 Qmult r n. +Proof. + destruct n ; reflexivity. +Qed. + + +Lemma Qeval_expr_compat : forall env e, Qeval_expr env e = Qeval_expr' env e. +Proof. + induction e ; simpl ; subst ; try congruence. + rewrite IHe. + apply QNpower. +Qed. + +Definition Qeval_op2 (o : Op2) : Q -> Q -> Prop := +match o with +| OpEq => Qeq +| OpNEq => fun x y => ~ x == y +| OpLe => Qle +| OpGe => Qge +| OpLt => Qlt +| OpGt => Qgt +end. + +Definition Qeval_formula (e:PolEnv Q) (ff : Formula Q) := + let (lhs,o,rhs) := ff in Qeval_op2 o (Qeval_expr e lhs) (Qeval_expr e rhs). + +Definition Qeval_formula' := + eval_formula Qplus Qmult Qminus Qopp Qeq Qle Qlt (fun x => x) (fun x => x) (pow_N 1 Qmult). + +Lemma Qeval_formula_compat : forall env f, Qeval_formula env f <-> Qeval_formula' env f. +Proof. + intros. + unfold Qeval_formula. + destruct f. + repeat rewrite Qeval_expr_compat. + unfold Qeval_formula'. + unfold Qeval_expr'. + split ; destruct Fop ; simpl; auto. +Qed. + + + +Definition Qeval_nformula := + eval_nformula 0 Qplus Qmult Qminus Qopp Qeq Qle Qlt (fun x => x) (fun x => x) (pow_N 1 Qmult). + +Definition Qeval_op1 (o : Op1) : Q -> Prop := +match o with +| Equal => fun x : Q => x == 0 +| NonEqual => fun x : Q => ~ x == 0 +| Strict => fun x : Q => 0 < x +| NonStrict => fun x : Q => 0 <= x +end. + +Lemma Qeval_nformula_simpl : forall env f, Qeval_nformula env f = (let (p, op) := f in Qeval_op1 op (Qeval_expr env p)). +Proof. + intros. + destruct f. + rewrite Qeval_expr_compat. + reflexivity. +Qed. + +Lemma Qeval_nformula_dec : forall env d, (Qeval_nformula env d) \/ ~ (Qeval_nformula env d). +Proof. + exact (fun env d =>eval_nformula_dec Qsor (fun x => x) (fun x => x) (pow_N 1 Qmult) env d). +Qed. + +Definition QWitness := ConeMember Q. + +Definition QWeakChecker := check_normalised_formulas 0 1 Qplus Qmult Qminus Qopp Qeq_bool Qle_bool. + +Require Import List. + +Lemma QWeakChecker_sound : forall (l : list (NFormula Q)) (cm : QWitness), + QWeakChecker l cm = true -> + forall env, make_impl (Qeval_nformula env) l False. +Proof. + intros l cm H. + intro. + unfold Qeval_nformula. + apply (checker_nf_sound Qsor QSORaddon l cm). + unfold QWeakChecker in H. + exact H. +Qed. + +Require Import Tauto. + +Definition QTautoChecker (f : BFormula (Formula Q)) (w: list QWitness) : bool := + @tauto_checker (Formula Q) (NFormula Q) (@cnf_normalise Q) (@cnf_negate Q) QWitness QWeakChecker f w. + +Lemma QTautoChecker_sound : forall f w, QTautoChecker f w = true -> forall env, eval_f (Qeval_formula env) f. +Proof. + intros f w. + unfold QTautoChecker. + apply (tauto_checker_sound Qeval_formula Qeval_nformula). + apply Qeval_nformula_dec. + intros. rewrite Qeval_formula_compat. unfold Qeval_formula'. now apply (cnf_normalise_correct Qsor). + intros. rewrite Qeval_formula_compat. unfold Qeval_formula'. now apply (cnf_negate_correct Qsor). + intros t w0. + apply QWeakChecker_sound. +Qed. + + diff --git a/contrib/micromega/RMicromega.v b/contrib/micromega/RMicromega.v new file mode 100644 index 00000000..ef28db32 --- /dev/null +++ b/contrib/micromega/RMicromega.v @@ -0,0 +1,148 @@ +(************************************************************************) +(* 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 *) +(************************************************************************) +(* *) +(* Micromega: A reflexive tactic using the Positivstellensatz *) +(* *) +(* Frédéric Besson (Irisa/Inria) 2006-2008 *) +(* *) +(************************************************************************) + +Require Import OrderedRing. +Require Import RingMicromega. +Require Import Refl. +Require Import Raxioms RIneq Rpow_def DiscrR. +Require Setoid. + +Definition Rsrt : ring_theory R0 R1 Rplus Rmult Rminus Ropp (@eq R). +Proof. + constructor. + exact Rplus_0_l. + exact Rplus_comm. + intros. rewrite Rplus_assoc. auto. + exact Rmult_1_l. + exact Rmult_comm. + intros ; rewrite Rmult_assoc ; auto. + intros. rewrite Rmult_comm. rewrite Rmult_plus_distr_l. + rewrite (Rmult_comm z). rewrite (Rmult_comm z). auto. + reflexivity. + exact Rplus_opp_r. +Qed. + +Add Ring Rring : Rsrt. +Open Scope R_scope. + +Lemma Rmult_neutral : forall x:R , 0 * x = 0. +Proof. + intro ; ring. +Qed. + + +Lemma Rsor : SOR R0 R1 Rplus Rmult Rminus Ropp (@eq R) Rle Rlt. +Proof. + constructor; intros ; subst ; try (intuition (subst; try ring ; auto with real)). + constructor. + constructor. + unfold RelationClasses.Symmetric. auto. + unfold RelationClasses.Transitive. intros. subst. reflexivity. + apply Rsrt. + eapply Rle_trans ; eauto. + apply (Rlt_irrefl m) ; auto. + apply Rnot_le_lt. auto with real. + destruct (total_order_T n m) as [ [H1 | H1] | H1] ; auto. + intros. + rewrite <- (Rmult_neutral m). + apply (Rmult_lt_compat_r) ; auto. +Qed. + +Require ZMicromega. + +(* R with coeffs in Z *) + +Lemma RZSORaddon : + SORaddon R0 R1 Rplus Rmult Rminus Ropp (@eq R) Rle (* ring elements *) + 0%Z 1%Z Zplus Zmult Zminus Zopp (* coefficients *) + Zeq_bool Zle_bool + IZR Nnat.nat_of_N pow. +Proof. + constructor. + constructor ; intros ; try reflexivity. + apply plus_IZR. + symmetry. apply Z_R_minus. + apply mult_IZR. + apply Ropp_Ropp_IZR. + apply IZR_eq. + apply Zeqb_ok ; auto. + apply R_power_theory. + intros x y. + intro. + apply IZR_neq. + apply ZMicromega.Zeq_bool_neq ; auto. + intros. apply IZR_le. apply Zle_bool_imp_le. auto. +Qed. + + +Require Import EnvRing. + +Definition INZ (n:N) : R := + match n with + | N0 => IZR 0%Z + | Npos p => IZR (Zpos p) + end. + +Definition Reval_expr := eval_pexpr Rplus Rmult Rminus Ropp IZR Nnat.nat_of_N pow. + + +Definition Reval_formula := + eval_formula Rplus Rmult Rminus Ropp (@eq R) Rle Rlt IZR Nnat.nat_of_N pow. + + +Definition Reval_nformula := + eval_nformula 0 Rplus Rmult Rminus Ropp (@eq R) Rle Rlt IZR Nnat.nat_of_N pow. + + +Lemma Reval_nformula_dec : forall env d, (Reval_nformula env d) \/ ~ (Reval_nformula env d). +Proof. + exact (fun env d =>eval_nformula_dec Rsor IZR Nnat.nat_of_N pow env d). +Qed. + +Definition RWitness := ConeMember Z. + +Definition RWeakChecker := check_normalised_formulas 0%Z 1%Z Zplus Zmult Zminus Zopp Zeq_bool Zle_bool. + +Require Import List. + +Lemma RWeakChecker_sound : forall (l : list (NFormula Z)) (cm : RWitness), + RWeakChecker l cm = true -> + forall env, make_impl (Reval_nformula env) l False. +Proof. + intros l cm H. + intro. + unfold Reval_nformula. + apply (checker_nf_sound Rsor RZSORaddon l cm). + unfold RWeakChecker in H. + exact H. +Qed. + +Require Import Tauto. + +Definition RTautoChecker (f : BFormula (Formula Z)) (w: list RWitness) : bool := + @tauto_checker (Formula Z) (NFormula Z) (@cnf_normalise Z) (@cnf_negate Z) RWitness RWeakChecker f w. + +Lemma RTautoChecker_sound : forall f w, RTautoChecker f w = true -> forall env, eval_f (Reval_formula env) f. +Proof. + intros f w. + unfold RTautoChecker. + apply (tauto_checker_sound Reval_formula Reval_nformula). + apply Reval_nformula_dec. + intros. unfold Reval_formula. now apply (cnf_normalise_correct Rsor). + intros. unfold Reval_formula. now apply (cnf_negate_correct Rsor). + intros t w0. + apply RWeakChecker_sound. +Qed. + + diff --git a/contrib/micromega/Refl.v b/contrib/micromega/Refl.v new file mode 100644 index 00000000..801d8b21 --- /dev/null +++ b/contrib/micromega/Refl.v @@ -0,0 +1,129 @@ +(************************************************************************) +(* 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 *) +(************************************************************************) +(* *) +(* Micromega: A reflexive tactic using the Positivstellensatz *) +(* *) +(* Frédéric Besson (Irisa/Inria) 2006-2008 *) +(* *) +(************************************************************************) + +Require Import List. +Require Setoid. + +Set Implicit Arguments. + +(* Refl of '->' '/\': basic properties *) + +Fixpoint make_impl (A : Type) (eval : A -> Prop) (l : list A) (goal : Prop) {struct l} : Prop := + match l with + | nil => goal + | cons e l => (eval e) -> (make_impl eval l goal) + end. + +Theorem make_impl_true : + forall (A : Type) (eval : A -> Prop) (l : list A), make_impl eval l True. +Proof. +induction l as [| a l IH]; simpl. +trivial. +intro; apply IH. +Qed. + +Fixpoint make_conj (A : Type) (eval : A -> Prop) (l : list A) {struct l} : Prop := + match l with + | nil => True + | cons e nil => (eval e) + | cons e l2 => ((eval e) /\ (make_conj eval l2)) + end. + +Theorem make_conj_cons : forall (A : Type) (eval : A -> Prop) (a : A) (l : list A), + make_conj eval (a :: l) <-> eval a /\ make_conj eval l. +Proof. +intros; destruct l; simpl; tauto. +Qed. + + +Lemma make_conj_impl : forall (A : Type) (eval : A -> Prop) (l : list A) (g : Prop), + (make_conj eval l -> g) <-> make_impl eval l g. +Proof. + induction l. + simpl. + tauto. + simpl. + intros. + destruct l. + simpl. + tauto. + generalize (IHl g). + tauto. +Qed. + +Lemma make_conj_in : forall (A : Type) (eval : A -> Prop) (l : list A), + make_conj eval l -> (forall p, In p l -> eval p). +Proof. + induction l. + simpl. + tauto. + simpl. + intros. + destruct l. + simpl in H0. + destruct H0. + subst; auto. + tauto. + destruct H. + destruct H0. + subst;auto. + apply IHl; auto. +Qed. + + + +Lemma make_conj_app : forall A eval l1 l2, @make_conj A eval (l1 ++ l2) <-> @make_conj A eval l1 /\ @make_conj A eval l2. +Proof. + induction l1. + simpl. + tauto. + intros. + change ((a::l1) ++ l2) with (a :: (l1 ++ l2)). + rewrite make_conj_cons. + rewrite IHl1. + rewrite make_conj_cons. + tauto. +Qed. + +Lemma not_make_conj_cons : forall (A:Type) (t:A) a eval (no_middle_eval : (eval t) \/ ~ (eval t)), + ~ make_conj eval (t ::a) -> ~ (eval t) \/ (~ make_conj eval a). +Proof. + intros. + simpl in H. + destruct a. + tauto. + tauto. +Qed. + +Lemma not_make_conj_app : forall (A:Type) (t:list A) a eval + (no_middle_eval : forall d, eval d \/ ~ eval d) , + ~ make_conj eval (t ++ a) -> (~ make_conj eval t) \/ (~ make_conj eval a). +Proof. + induction t. + simpl. + tauto. + intros. + simpl ((a::t)++a0)in H. + destruct (@not_make_conj_cons _ _ _ _ (no_middle_eval a) H). + left ; red ; intros. + apply H0. + rewrite make_conj_cons in H1. + tauto. + destruct (IHt _ _ no_middle_eval H0). + left ; red ; intros. + apply H1. + rewrite make_conj_cons in H2. + tauto. + right ; auto. +Qed. diff --git a/contrib/micromega/RingMicromega.v b/contrib/micromega/RingMicromega.v new file mode 100644 index 00000000..6885b82c --- /dev/null +++ b/contrib/micromega/RingMicromega.v @@ -0,0 +1,779 @@ +(************************************************************************) +(* 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 *) +(************************************************************************) +(* Evgeny Makarov, INRIA, 2007 *) +(************************************************************************) + +Require Import NArith. +Require Import Relation_Definitions. +Require Import Setoid. +(*****) +Require Import Env. +Require Import EnvRing. +(*****) +Require Import List. +Require Import Bool. +Require Import OrderedRing. +Require Import Refl. + + +Set Implicit Arguments. + +Import OrderedRingSyntax. + +Section Micromega. + +(* Assume we have a strict(ly?) ordered ring *) + +Variable R : Type. +Variables rO rI : R. +Variables rplus rtimes rminus: R -> R -> R. +Variable ropp : R -> R. +Variables req rle rlt : R -> R -> Prop. + +Variable sor : SOR rO rI rplus rtimes rminus ropp req rle rlt. + +Notation "0" := rO. +Notation "1" := rI. +Notation "x + y" := (rplus x y). +Notation "x * y " := (rtimes x y). +Notation "x - y " := (rminus x y). +Notation "- x" := (ropp x). +Notation "x == y" := (req x y). +Notation "x ~= y" := (~ req x y). +Notation "x <= y" := (rle x y). +Notation "x < y" := (rlt x y). + +(* Assume we have a type of coefficients C and a morphism from C to R *) + +Variable C : Type. +Variables cO cI : C. +Variables cplus ctimes cminus: C -> C -> C. +Variable copp : C -> C. +Variables ceqb cleb : C -> C -> bool. +Variable phi : C -> R. + +(* Power coefficients *) +Variable E : Set. (* the type of exponents *) +Variable pow_phi : N -> E. +Variable rpow : R -> E -> R. + +Notation "[ x ]" := (phi x). +Notation "x [=] y" := (ceqb x y). +Notation "x [<=] y" := (cleb x y). + +(* Let's collect all hypotheses in addition to the ordered ring axioms into +one structure *) + +Record SORaddon := mk_SOR_addon { + SORrm : ring_morph 0 1 rplus rtimes rminus ropp req cO cI cplus ctimes cminus copp ceqb phi; + SORpower : power_theory rI rtimes req pow_phi rpow; + SORcneqb_morph : forall x y : C, x [=] y = false -> [x] ~= [y]; + SORcleb_morph : forall x y : C, x [<=] y = true -> [x] <= [y] +}. + +Variable addon : SORaddon. + +Add Relation R req + reflexivity proved by sor.(SORsetoid).(@Equivalence_Reflexive _ _ ) + symmetry proved by sor.(SORsetoid).(@Equivalence_Symmetric _ _ ) + transitivity proved by sor.(SORsetoid).(@Equivalence_Transitive _ _ ) +as micomega_sor_setoid. + +Add Morphism rplus with signature req ==> req ==> req as rplus_morph. +Proof. +exact sor.(SORplus_wd). +Qed. +Add Morphism rtimes with signature req ==> req ==> req as rtimes_morph. +Proof. +exact sor.(SORtimes_wd). +Qed. +Add Morphism ropp with signature req ==> req as ropp_morph. +Proof. +exact sor.(SORopp_wd). +Qed. +Add Morphism rle with signature req ==> req ==> iff as rle_morph. +Proof. + exact sor.(SORle_wd). +Qed. +Add Morphism rlt with signature req ==> req ==> iff as rlt_morph. +Proof. + exact sor.(SORlt_wd). +Qed. + +Add Morphism rminus with signature req ==> req ==> req as rminus_morph. +Proof. + exact (rminus_morph sor). (* We already proved that minus is a morphism in OrderedRing.v *) +Qed. + +Definition cneqb (x y : C) := negb (ceqb x y). +Definition cltb (x y : C) := (cleb x y) && (cneqb x y). + +Notation "x [~=] y" := (cneqb x y). +Notation "x [<] y" := (cltb x y). + +Ltac le_less := rewrite (Rle_lt_eq sor); left; try assumption. +Ltac le_equal := rewrite (Rle_lt_eq sor); right; try reflexivity; try assumption. +Ltac le_elim H := rewrite (Rle_lt_eq sor) in H; destruct H as [H | H]. + +Lemma cleb_sound : forall x y : C, x [<=] y = true -> [x] <= [y]. +Proof. + exact addon.(SORcleb_morph). +Qed. + +Lemma cneqb_sound : forall x y : C, x [~=] y = true -> [x] ~= [y]. +Proof. +intros x y H1. apply addon.(SORcneqb_morph). unfold cneqb, negb in H1. +destruct (ceqb x y); now try discriminate. +Qed. + +Lemma cltb_sound : forall x y : C, x [<] y = true -> [x] < [y]. +Proof. +intros x y H. unfold cltb in H. apply andb_prop in H. destruct H as [H1 H2]. +apply cleb_sound in H1. apply cneqb_sound in H2. apply <- (Rlt_le_neq sor). now split. +Qed. + +(* Begin Micromega *) + +Definition PExprC := PExpr C. (* arbitrary expressions built from +, *, - *) +Definition PolC := Pol C. (* polynomials in generalized Horner form, defined in Ring_polynom or EnvRing *) +(*****) +(*Definition Env := Env R. (* For interpreting PExprC *)*) +Definition PolEnv := Env R. (* For interpreting PolC *) +(*****) +(*Definition Env := list R. +Definition PolEnv := list R.*) +(*****) + +(* What benefit do we get, in the case of EnvRing, from defining eval_pexpr +explicitely below and not through PEeval, as the following lemma says? The +function eval_pexpr seems to be a straightforward special case of PEeval +when the environment (i.e., the second last argument of PEeval) of type +off_map (which is (option positive * t)) is (None, env). *) + +(*****) +Fixpoint eval_pexpr (l : PolEnv) (pe : PExprC) {struct pe} : R := +match pe with +| PEc c => phi c +| PEX j => l j +| PEadd pe1 pe2 => (eval_pexpr l pe1) + (eval_pexpr l pe2) +| PEsub pe1 pe2 => (eval_pexpr l pe1) - (eval_pexpr l pe2) +| PEmul pe1 pe2 => (eval_pexpr l pe1) * (eval_pexpr l pe2) +| PEopp pe1 => - (eval_pexpr l pe1) +| PEpow pe1 n => rpow (eval_pexpr l pe1) (pow_phi n) +end. + + +Lemma eval_pexpr_simpl : forall (l : PolEnv) (pe : PExprC), + eval_pexpr l pe = + match pe with + | PEc c => phi c + | PEX j => l j + | PEadd pe1 pe2 => (eval_pexpr l pe1) + (eval_pexpr l pe2) + | PEsub pe1 pe2 => (eval_pexpr l pe1) - (eval_pexpr l pe2) + | PEmul pe1 pe2 => (eval_pexpr l pe1) * (eval_pexpr l pe2) + | PEopp pe1 => - (eval_pexpr l pe1) + | PEpow pe1 n => rpow (eval_pexpr l pe1) (pow_phi n) + end. +Proof. + intros ; destruct pe ; reflexivity. +Qed. + + + +Lemma eval_pexpr_PEeval : forall (env : PolEnv) (pe : PExprC), + eval_pexpr env pe = + PEeval rplus rtimes rminus ropp phi pow_phi rpow env pe. +Proof. +induction pe; simpl; intros. +reflexivity. +reflexivity. +rewrite <- IHpe1; rewrite <- IHpe2; reflexivity. +rewrite <- IHpe1; rewrite <- IHpe2; reflexivity. +rewrite <- IHpe1; rewrite <- IHpe2; reflexivity. +rewrite <- IHpe; reflexivity. +rewrite <- IHpe; reflexivity. +Qed. +(*****) +(*Definition eval_pexpr : Env -> PExprC -> R := + PEeval 0 rplus rtimes rminus ropp phi pow_phi rpow.*) +(*****) + +Inductive Op1 : Set := (* relations with 0 *) +| Equal (* == 0 *) +| NonEqual (* ~= 0 *) +| Strict (* > 0 *) +| NonStrict (* >= 0 *). + +Definition NFormula := (PExprC * Op1)%type. (* normalized formula *) + +Definition eval_op1 (o : Op1) : R -> Prop := +match o with +| Equal => fun x => x == 0 +| NonEqual => fun x : R => x ~= 0 +| Strict => fun x : R => 0 < x +| NonStrict => fun x : R => 0 <= x +end. + +Definition eval_nformula (env : PolEnv) (f : NFormula) : Prop := +let (p, op) := f in eval_op1 op (eval_pexpr env p). + + +Definition OpMult (o o' : Op1) : Op1 := +match o with +| Equal => Equal +| NonStrict => NonStrict (* (OpMult NonStrict Equal) could be defined as Equal *) +| Strict => o' +| NonEqual => NonEqual (* does not matter what we return here; see the following lemmas *) +end. + +Definition OpAdd (o o': Op1) : Op1 := +match o with +| Equal => o' +| NonStrict => + match o' with + | Strict => Strict + | _ => NonStrict + end +| Strict => Strict +| NonEqual => NonEqual (* does not matter what we return here *) +end. + +Lemma OpMultNonEqual : + forall o o' : Op1, o <> NonEqual -> o' <> NonEqual -> OpMult o o' <> NonEqual. +Proof. +intros o o' H1 H2; destruct o; destruct o'; simpl; try discriminate; +try (intro H; apply H1; reflexivity); +try (intro H; apply H2; reflexivity). +Qed. + +Lemma OpAdd_NonEqual : + forall o o' : Op1, o <> NonEqual -> o' <> NonEqual -> OpAdd o o' <> NonEqual. +Proof. +intros o o' H1 H2; destruct o; destruct o'; simpl; try discriminate; +try (intro H; apply H1; reflexivity); +try (intro H; apply H2; reflexivity). +Qed. + +Lemma OpMult_sound : + forall (o o' : Op1) (x y : R), o <> NonEqual -> o' <> NonEqual -> + eval_op1 o x -> eval_op1 o' y -> eval_op1 (OpMult o o') (x * y). +Proof. +unfold eval_op1; destruct o; simpl; intros o' x y H1 H2 H3 H4. +rewrite H3; now rewrite (Rtimes_0_l sor). +elimtype False; now apply H1. +destruct o'. +rewrite H4; now rewrite (Rtimes_0_r sor). +elimtype False; now apply H2. +now apply (Rtimes_pos_pos sor). +apply (Rtimes_nonneg_nonneg sor); [le_less | assumption]. +destruct o'. +rewrite H4, (Rtimes_0_r sor); le_equal. +elimtype False; now apply H2. +apply (Rtimes_nonneg_nonneg sor); [assumption | le_less]. +now apply (Rtimes_nonneg_nonneg sor). +Qed. + +Lemma OpAdd_sound : + forall (o o' : Op1) (e e' : R), o <> NonEqual -> o' <> NonEqual -> + eval_op1 o e -> eval_op1 o' e' -> eval_op1 (OpAdd o o') (e + e'). +Proof. +unfold eval_op1; destruct o; simpl; intros o' e e' H1 H2 H3 H4. +destruct o'. +now rewrite H3, H4, (Rplus_0_l sor). +elimtype False; now apply H2. +now rewrite H3, (Rplus_0_l sor). +now rewrite H3, (Rplus_0_l sor). +elimtype False; now apply H1. +destruct o'. +now rewrite H4, (Rplus_0_r sor). +elimtype False; now apply H2. +now apply (Rplus_pos_pos sor). +now apply (Rplus_pos_nonneg sor). +destruct o'. +now rewrite H4, (Rplus_0_r sor). +elimtype False; now apply H2. +now apply (Rplus_nonneg_pos sor). +now apply (Rplus_nonneg_nonneg sor). +Qed. + +(* We consider a monoid whose generators are polynomials from the +hypotheses of the form (p ~= 0). Thus it follows from the hypotheses that +every element of the monoid (i.e., arbitrary product of generators) is ~= +0. Therefore, the square of every element is > 0. *) + +Inductive Monoid (l : list NFormula) : PExprC -> Prop := +| M_One : Monoid l (PEc cI) +| M_In : forall p : PExprC, In (p, NonEqual) l -> Monoid l p +| M_Mult : forall (e1 e2 : PExprC), Monoid l e1 -> Monoid l e2 -> Monoid l (PEmul e1 e2). + +(* Do we really need to rely on the intermediate definition of monoid ? + InC why the restriction NonEqual ? + Could not we consider the IsIdeal as a IsMult ? + The same for IsSquare ? +*) + +Inductive Cone (l : list (NFormula)) : PExprC -> Op1 -> Prop := +| InC : forall p op, In (p, op) l -> op <> NonEqual -> Cone l p op +| IsIdeal : forall p, Cone l p Equal -> forall p', Cone l (PEmul p p') Equal +| IsSquare : forall p, Cone l (PEmul p p) NonStrict +| IsMonoid : forall p, Monoid l p -> Cone l (PEmul p p) Strict +| IsMult : forall p op q oq, Cone l p op -> Cone l q oq -> Cone l (PEmul p q) (OpMult op oq) +| IsAdd : forall p op q oq, Cone l p op -> Cone l q oq -> Cone l (PEadd p q) (OpAdd op oq) +| IsPos : forall c : C, cltb cO c = true -> Cone l (PEc c) Strict +| IsZ : Cone l (PEc cO) Equal. + +(* As promised, if all hypotheses are true in some environment, then every +member of the monoid is nonzero in this environment *) + +Lemma monoid_nonzero : forall (l : list NFormula) (env : PolEnv), + (forall f : NFormula, In f l -> eval_nformula env f) -> + forall p : PExprC, Monoid l p -> eval_pexpr env p ~= 0. +Proof. +intros l env H1 p H2. induction H2 as [| f H | e1 e2 H3 IH1 H4 IH2]; simpl. +rewrite addon.(SORrm).(morph1). apply (Rneq_symm sor). apply (Rneq_0_1 sor). +apply H1 in H. now simpl in H. +simpl in IH1, IH2. apply (Rtimes_neq_0 sor). now split. +Qed. + +(* If all members of a cone base are true in some environment, then every +member of the cone is true as well *) + +Lemma cone_true : + forall (l : list NFormula) (env : PolEnv), + (forall (f : NFormula), In f l -> eval_nformula env f) -> + forall (p : PExprC) (op : Op1), Cone l p op -> + op <> NonEqual /\ eval_nformula env (p, op). +Proof. +intros l env H1 p op H2. induction H2; simpl in *. +split. assumption. apply H1 in H. now unfold eval_nformula in H. +split. discriminate. destruct IHCone as [_ H3]. rewrite H3. now rewrite (Rtimes_0_l sor). +split. discriminate. apply (Rtimes_square_nonneg sor). +split. discriminate. apply <- (Rlt_le_neq sor). split. apply (Rtimes_square_nonneg sor). +apply (Rneq_symm sor). apply (Rtimes_neq_0 sor). split; now apply monoid_nonzero with l. +destruct IHCone1 as [IH1 IH2]; destruct IHCone2 as [IH3 IH4]. +split. now apply OpMultNonEqual. now apply OpMult_sound. +destruct IHCone1 as [IH1 IH2]; destruct IHCone2 as [IH3 IH4]. +split. now apply OpAdd_NonEqual. now apply OpAdd_sound. +split. discriminate. rewrite <- addon.(SORrm).(morph0). now apply cltb_sound. +split. discriminate. apply addon.(SORrm).(morph0). +Qed. + +(* Every element of a monoid is a product of some generators; therefore, +to determine an element we can give a list of generators' indices *) + +Definition MonoidMember : Set := list nat. + +Inductive ConeMember : Type := +| S_In : nat -> ConeMember +| S_Ideal : PExprC -> ConeMember -> ConeMember +| S_Square : PExprC -> ConeMember +| S_Monoid : MonoidMember -> ConeMember +| S_Mult : ConeMember -> ConeMember -> ConeMember +| S_Add : ConeMember -> ConeMember -> ConeMember +| S_Pos : C -> ConeMember +| S_Z : ConeMember. + +Definition nformula_times (f f' : NFormula) : NFormula := +let (p, op) := f in + let (p', op') := f' in + (PEmul p p', OpMult op op'). + +Definition nformula_plus (f f' : NFormula) : NFormula := +let (p, op) := f in + let (p', op') := f' in + (PEadd p p', OpAdd op op'). + +Definition nformula_times_0 (p : PExprC) (f : NFormula) : NFormula := +let (q, op) := f in + match op with + | Equal => (PEmul q p, Equal) + | _ => f + end. + +Fixpoint eval_monoid (l : list NFormula) (ns : MonoidMember) {struct ns} : PExprC := +match ns with +| nil => PEc cI +| n :: ns => + let p := match nth n l (PEc cI, NonEqual) with + | (q, NonEqual) => q + | _ => PEc cI + end in + PEmul p (eval_monoid l ns) +end. + +Theorem eval_monoid_in_monoid : + forall (l : list NFormula) (ns : MonoidMember), Monoid l (eval_monoid l ns). +Proof. +intro l; induction ns; simpl in *. +constructor. +apply M_Mult; [| assumption]. +destruct (nth_in_or_default a l (PEc cI, NonEqual)). +destruct (nth a l (PEc cI, NonEqual)). destruct o; try constructor. assumption. +rewrite e; simpl. constructor. +Qed. + +(* Provides the cone member from the witness, i.e., ConeMember *) +Fixpoint eval_cone (l : list NFormula) (cm : ConeMember) {struct cm} : NFormula := +match cm with +| S_In n => match nth n l (PEc cO, Equal) with + | (_, NonEqual) => (PEc cO, Equal) + | f => f + end +| S_Ideal p cm' => nformula_times_0 p (eval_cone l cm') +| S_Square p => (PEmul p p, NonStrict) +| S_Monoid m => let p := eval_monoid l m in (PEmul p p, Strict) +| S_Mult p q => nformula_times (eval_cone l p) (eval_cone l q) +| S_Add p q => nformula_plus (eval_cone l p) (eval_cone l q) +| S_Pos c => if cltb cO c then (PEc c, Strict) else (PEc cO, Equal) +| S_Z => (PEc cO, Equal) +end. + +Theorem eval_cone_in_cone : + forall (l : list NFormula) (cm : ConeMember), + let (p, op) := eval_cone l cm in Cone l p op. +Proof. +intros l cm; induction cm; simpl. +destruct (nth_in_or_default n l (PEc cO, Equal)). +destruct (nth n l (PEc cO, Equal)). destruct o; try (now apply InC). apply IsZ. +rewrite e. apply IsZ. +destruct (eval_cone l cm). destruct o; simpl; try assumption. now apply IsIdeal. +apply IsSquare. +apply IsMonoid. apply eval_monoid_in_monoid. +destruct (eval_cone l cm1). destruct (eval_cone l cm2). unfold nformula_times. now apply IsMult. +destruct (eval_cone l cm1). destruct (eval_cone l cm2). unfold nformula_plus. now apply IsAdd. +case_eq (cO [<] c) ; intros ; [apply IsPos ; auto| apply IsZ]. +apply IsZ. +Qed. + +(* (inconsistent_cone_member l p) means (p, op) is in the cone for some op +(> 0, >= 0, == 0, or ~= 0) and this formula is inconsistent. This fact +implies that l is inconsistent, as shown by the next lemma. Inconsistency +of a formula (p, op) can be established by normalizing p and showing that +it is a constant c for which (c, op) is false. (This is only a sufficient, +not necessary, condition, of course.) Membership in the cone can be +verified if we have a certificate. *) + +Definition inconsistent_cone_member (l : list NFormula) (p : PExprC) := + exists op : Op1, Cone l p op /\ + forall env : PolEnv, ~ eval_op1 op (eval_pexpr env p). + +(* If some element of a cone is inconsistent, then the base of the cone +is also inconsistent *) + +Lemma prove_inconsistent : + forall (l : list NFormula) (p : PExprC), + inconsistent_cone_member l p -> forall env, make_impl (eval_nformula env) l False. +Proof. +intros l p H env. +destruct H as [o [wit H]]. +apply -> make_conj_impl. +intro H1. apply H with env. +pose proof (@cone_true l env) as H2. +cut (forall f : NFormula, In f l -> eval_nformula env f). intro H3. +apply (proj2 (H2 H3 p o wit)). intro. now apply make_conj_in. +Qed. + +Definition normalise_pexpr : PExprC -> PolC := + norm_aux cO cI cplus ctimes cminus copp ceqb. + +(* The following definition we don't really need, hence it is commented *) +(*Definition eval_pol : PolEnv -> PolC -> R := Pphi 0 rplus rtimes phi.*) + +(* roughly speaking, normalise_pexpr_correct is a proof of + forall env p, eval_pexpr env p == eval_pol env (normalise_pexpr p) *) + +(*****) +Definition normalise_pexpr_correct := +let Rops_wd := mk_reqe rplus rtimes ropp req + sor.(SORplus_wd) + sor.(SORtimes_wd) + sor.(SORopp_wd) in + norm_aux_spec sor.(SORsetoid) Rops_wd (Rth_ARth (SORsetoid sor) Rops_wd sor.(SORrt)) + addon.(SORrm) addon.(SORpower). +(*****) +(*Definition normalise_pexpr_correct := +let Rops_wd := mk_reqe rplus rtimes ropp req + sor.(SORplus_wd) + sor.(SORtimes_wd) + sor.(SORopp_wd) in + norm_aux_spec sor.(SORsetoid) Rops_wd (Rth_ARth sor.(SORsetoid) Rops_wd sor.(SORrt)) + addon.(SORrm) addon.(SORpower) nil.*) +(*****) + +(* Check that a formula f is inconsistent by normalizing and comparing the +resulting constant with 0 *) + +Definition check_inconsistent (f : NFormula) : bool := +let (e, op) := f in + match normalise_pexpr e with + | Pc c => + match op with + | Equal => cneqb c cO + | NonStrict => c [<] cO + | Strict => c [<=] cO + | NonEqual => false (* eval_cone never returns (p, NonEqual) *) + end + | _ => false (* not a constant *) + end. + +Lemma check_inconsistent_sound : + forall (p : PExprC) (op : Op1), + check_inconsistent (p, op) = true -> forall env, ~ eval_op1 op (eval_pexpr env p). +Proof. +intros p op H1 env. unfold check_inconsistent, normalise_pexpr in H1. +destruct op; simpl; +(*****) +rewrite eval_pexpr_PEeval; +(*****) +(*unfold eval_pexpr;*) +(*****) +rewrite normalise_pexpr_correct; +destruct (norm_aux cO cI cplus ctimes cminus copp ceqb p); simpl; try discriminate H1; +try rewrite <- addon.(SORrm).(morph0); trivial. +now apply cneqb_sound. +apply cleb_sound in H1. now apply -> (Rle_ngt sor). +apply cltb_sound in H1. now apply -> (Rlt_nge sor). +Qed. + +Definition check_normalised_formulas : list NFormula -> ConeMember -> bool := + fun l cm => check_inconsistent (eval_cone l cm). + +Lemma checker_nf_sound : + forall (l : list NFormula) (cm : ConeMember), + check_normalised_formulas l cm = true -> + forall env : PolEnv, make_impl (eval_nformula env) l False. +Proof. +intros l cm H env. +unfold check_normalised_formulas in H. +case_eq (eval_cone l cm). intros p op H1. +apply prove_inconsistent with p. unfold inconsistent_cone_member. exists op. split. +pose proof (eval_cone_in_cone l cm) as H2. now rewrite H1 in H2. +apply check_inconsistent_sound. now rewrite <- H1. +Qed. + +(** Normalisation of formulae **) + +Inductive Op2 : Set := (* binary relations *) +| OpEq +| OpNEq +| OpLe +| OpGe +| OpLt +| OpGt. + +Definition eval_op2 (o : Op2) : R -> R -> Prop := +match o with +| OpEq => req +| OpNEq => fun x y : R => x ~= y +| OpLe => rle +| OpGe => fun x y : R => y <= x +| OpLt => fun x y : R => x < y +| OpGt => fun x y : R => y < x +end. + +Record Formula : Type := { + Flhs : PExprC; + Fop : Op2; + Frhs : PExprC +}. + +Definition eval_formula (env : PolEnv) (f : Formula) : Prop := + let (lhs, op, rhs) := f in + (eval_op2 op) (eval_pexpr env lhs) (eval_pexpr env rhs). + +(* We normalize Formulas by moving terms to one side *) + +Definition normalise (f : Formula) : NFormula := +let (lhs, op, rhs) := f in + match op with + | OpEq => (PEsub lhs rhs, Equal) + | OpNEq => (PEsub lhs rhs, NonEqual) + | OpLe => (PEsub rhs lhs, NonStrict) + | OpGe => (PEsub lhs rhs, NonStrict) + | OpGt => (PEsub lhs rhs, Strict) + | OpLt => (PEsub rhs lhs, Strict) + end. + +Definition negate (f : Formula) : NFormula := +let (lhs, op, rhs) := f in + match op with + | OpEq => (PEsub rhs lhs, NonEqual) + | OpNEq => (PEsub rhs lhs, Equal) + | OpLe => (PEsub lhs rhs, Strict) (* e <= e' == ~ e > e' *) + | OpGe => (PEsub rhs lhs, Strict) + | OpGt => (PEsub rhs lhs, NonStrict) + | OpLt => (PEsub lhs rhs, NonStrict) +end. + +Theorem normalise_sound : + forall (env : PolEnv) (f : Formula), + eval_formula env f -> eval_nformula env (normalise f). +Proof. +intros env f H; destruct f as [lhs op rhs]; simpl in *. +destruct op; simpl in *. +now apply <- (Rminus_eq_0 sor). +intros H1. apply -> (Rminus_eq_0 sor) in H1. now apply H. +now apply -> (Rle_le_minus sor). +now apply -> (Rle_le_minus sor). +now apply -> (Rlt_lt_minus sor). +now apply -> (Rlt_lt_minus sor). +Qed. + +Theorem negate_correct : + forall (env : PolEnv) (f : Formula), + eval_formula env f <-> ~ (eval_nformula env (negate f)). +Proof. +intros env f; destruct f as [lhs op rhs]; simpl. +destruct op; simpl. +symmetry. rewrite (Rminus_eq_0 sor). +split; intro H; [symmetry; now apply -> (Req_dne sor) | symmetry in H; now apply <- (Req_dne sor)]. +rewrite (Rminus_eq_0 sor). split; intro; now apply (Rneq_symm sor). +rewrite <- (Rlt_lt_minus sor). now rewrite <- (Rle_ngt sor). +rewrite <- (Rlt_lt_minus sor). now rewrite <- (Rle_ngt sor). +rewrite <- (Rle_le_minus sor). now rewrite <- (Rlt_nge sor). +rewrite <- (Rle_le_minus sor). now rewrite <- (Rlt_nge sor). +Qed. + +(** Another normalistion - this is used for cnf conversion **) + +Definition xnormalise (t:Formula) : list (NFormula) := + let (lhs,o,rhs) := t in + match o with + | OpEq => + (PEsub lhs rhs, Strict)::(PEsub rhs lhs , Strict)::nil + | OpNEq => (PEsub lhs rhs,Equal) :: nil + | OpGt => (PEsub rhs lhs,NonStrict) :: nil + | OpLt => (PEsub lhs rhs,NonStrict) :: nil + | OpGe => (PEsub rhs lhs , Strict) :: nil + | OpLe => (PEsub lhs rhs ,Strict) :: nil + end. + +Require Import Tauto. + +Definition cnf_normalise (t:Formula) : cnf (NFormula) := + List.map (fun x => x::nil) (xnormalise t). + + +Add Ring SORRing : sor.(SORrt). + +Lemma cnf_normalise_correct : forall env t, eval_cnf (eval_nformula env) (cnf_normalise t) -> eval_formula env t. +Proof. + unfold cnf_normalise, xnormalise ; simpl ; intros env t. + unfold eval_cnf. + destruct t as [lhs o rhs]; case_eq o ; simpl; + generalize (eval_pexpr env lhs); + generalize (eval_pexpr env rhs) ; intros z1 z2 ; intros. + (**) + apply sor.(SORle_antisymm). + rewrite (Rle_ngt sor). rewrite (Rlt_lt_minus sor). tauto. + rewrite (Rle_ngt sor). rewrite (Rlt_lt_minus sor). tauto. + now rewrite <- (Rminus_eq_0 sor). + rewrite (Rle_ngt sor). rewrite (Rlt_lt_minus sor). auto. + rewrite (Rle_ngt sor). rewrite (Rlt_lt_minus sor). auto. + rewrite (Rlt_nge sor). rewrite (Rle_le_minus sor). auto. + rewrite (Rlt_nge sor). rewrite (Rle_le_minus sor). auto. +Qed. + +Definition xnegate (t:Formula) : list (NFormula) := + let (lhs,o,rhs) := t in + match o with + | OpEq => (PEsub lhs rhs,Equal) :: nil + | OpNEq => (PEsub lhs rhs ,Strict)::(PEsub rhs lhs,Strict)::nil + | OpGt => (PEsub lhs rhs,Strict) :: nil + | OpLt => (PEsub rhs lhs,Strict) :: nil + | OpGe => (PEsub lhs rhs,NonStrict) :: nil + | OpLe => (PEsub rhs lhs,NonStrict) :: nil + end. + +Definition cnf_negate (t:Formula) : cnf (NFormula) := + List.map (fun x => x::nil) (xnegate t). + +Lemma cnf_negate_correct : forall env t, eval_cnf (eval_nformula env) (cnf_negate t) -> ~ eval_formula env t. +Proof. + unfold cnf_negate, xnegate ; simpl ; intros env t. + unfold eval_cnf. + destruct t as [lhs o rhs]; case_eq o ; simpl ; + generalize (eval_pexpr env lhs); + generalize (eval_pexpr env rhs) ; intros z1 z2 ; intros ; + intuition. + (**) + apply H0. + rewrite H1 ; ring. + (**) + apply H1. + apply sor.(SORle_antisymm). + rewrite (Rle_ngt sor). rewrite (Rlt_lt_minus sor). tauto. + rewrite (Rle_ngt sor). rewrite (Rlt_lt_minus sor). tauto. + (**) + apply H0. now rewrite (Rle_le_minus sor) in H1. + apply H0. now rewrite (Rle_le_minus sor) in H1. + apply H0. now rewrite (Rlt_lt_minus sor) in H1. + apply H0. now rewrite (Rlt_lt_minus sor) in H1. +Qed. + + +Lemma eval_nformula_dec : forall env d, (eval_nformula env d) \/ ~ (eval_nformula env d). +Proof. + intros. + destruct d ; simpl. + generalize (eval_pexpr env p); intros. + destruct o ; simpl. + apply (Req_em sor r 0). + destruct (Req_em sor r 0) ; tauto. + rewrite <- (Rle_ngt sor r 0). generalize (Rle_gt_cases sor r 0). tauto. + rewrite <- (Rlt_nge sor r 0). generalize (Rle_gt_cases sor 0 r). tauto. +Qed. + +(** Some syntactic simplifications of expressions and cone elements *) + + +Fixpoint simpl_expr (e:PExprC) : PExprC := + match e with + | PEmul y z => let y' := simpl_expr y in let z' := simpl_expr z in + match y' , z' with + | PEc c , z' => if ceqb c cI then z' else PEmul y' z' + | _ , _ => PEmul y' z' + end + | PEadd x y => PEadd (simpl_expr x) (simpl_expr y) + | _ => e + end. + + +Definition simpl_cone (e:ConeMember) : ConeMember := + match e with + | S_Square t => match simpl_expr t with + | PEc c => if ceqb cO c then S_Z else S_Pos (ctimes c c) + | x => S_Square x + end + | S_Mult t1 t2 => + match t1 , t2 with + | S_Z , x => S_Z + | x , S_Z => S_Z + | S_Pos c , S_Pos c' => S_Pos (ctimes c c') + | S_Pos p1 , S_Mult (S_Pos p2) x => S_Mult (S_Pos (ctimes p1 p2)) x + | S_Pos p1 , S_Mult x (S_Pos p2) => S_Mult (S_Pos (ctimes p1 p2)) x + | S_Mult (S_Pos p2) x , S_Pos p1 => S_Mult (S_Pos (ctimes p1 p2)) x + | S_Mult x (S_Pos p2) , S_Pos p1 => S_Mult (S_Pos (ctimes p1 p2)) x + | S_Pos x , S_Add y z => S_Add (S_Mult (S_Pos x) y) (S_Mult (S_Pos x) z) + | S_Pos c , _ => if ceqb cI c then t2 else S_Mult t1 t2 + | _ , S_Pos c => if ceqb cI c then t1 else S_Mult t1 t2 + | _ , _ => e + end + | S_Add t1 t2 => + match t1 , t2 with + | S_Z , x => x + | x , S_Z => x + | x , y => S_Add x y + end + | _ => e + end. + + + +End Micromega. + diff --git a/contrib/micromega/Tauto.v b/contrib/micromega/Tauto.v new file mode 100644 index 00000000..ef48efa6 --- /dev/null +++ b/contrib/micromega/Tauto.v @@ -0,0 +1,324 @@ +(************************************************************************) +(* 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 *) +(************************************************************************) +(* *) +(* Micromega: A reflexive tactic using the Positivstellensatz *) +(* *) +(* Frédéric Besson (Irisa/Inria) 2006-2008 *) +(* *) +(************************************************************************) + +Require Import List. +Require Import Refl. +Require Import Bool. + +Set Implicit Arguments. + + + Inductive BFormula (A:Type) : Type := + | TT : BFormula A + | FF : BFormula A + | X : Prop -> BFormula A + | A : A -> BFormula A + | Cj : BFormula A -> BFormula A -> BFormula A + | D : BFormula A-> BFormula A -> BFormula A + | N : BFormula A -> BFormula A + | I : BFormula A-> BFormula A-> BFormula A. + + Fixpoint eval_f (A:Type) (ev:A -> Prop ) (f:BFormula A) {struct f}: Prop := + match f with + | TT => True + | FF => False + | A a => ev a + | X p => p + | Cj e1 e2 => (eval_f ev e1) /\ (eval_f ev e2) + | D e1 e2 => (eval_f ev e1) \/ (eval_f ev e2) + | N e => ~ (eval_f ev e) + | I f1 f2 => (eval_f ev f1) -> (eval_f ev f2) + end. + + + Lemma map_simpl : forall A B f l, @map A B f l = match l with + | nil => nil + | a :: l=> (f a) :: (@map A B f l) + end. + Proof. + destruct l ; reflexivity. + Qed. + + + + Section S. + + Variable Env : Type. + Variable Term : Type. + Variable eval : Env -> Term -> Prop. + Variable Term' : Type. + Variable eval' : Env -> Term' -> Prop. + + + + Variable no_middle_eval' : forall env d, (eval' env d) \/ ~ (eval' env d). + + + Definition clause := list Term'. + Definition cnf := list clause. + + Variable normalise : Term -> cnf. + Variable negate : Term -> cnf. + + + Definition tt : cnf := @nil clause. + Definition ff : cnf := cons (@nil Term') nil. + + + Definition or_clause_cnf (t:clause) (f:cnf) : cnf := + List.map (fun x => (t++x)) f. + + Fixpoint or_cnf (f : cnf) (f' : cnf) {struct f}: cnf := + match f with + | nil => tt + | e :: rst => (or_cnf rst f') ++ (or_clause_cnf e f') + end. + + + Definition and_cnf (f1 : cnf) (f2 : cnf) : cnf := + f1 ++ f2. + + Fixpoint xcnf (pol : bool) (f : BFormula Term) {struct f}: cnf := + match f with + | TT => if pol then tt else ff + | FF => if pol then ff else tt + | X p => if pol then ff else ff (* This is not complete - cannot negate any proposition *) + | A x => if pol then normalise x else negate x + | N e => xcnf (negb pol) e + | Cj e1 e2 => + (if pol then and_cnf else or_cnf) (xcnf pol e1) (xcnf pol e2) + | D e1 e2 => (if pol then or_cnf else and_cnf) (xcnf pol e1) (xcnf pol e2) + | I e1 e2 => (if pol then or_cnf else and_cnf) (xcnf (negb pol) e1) (xcnf pol e2) + end. + + Definition eval_cnf (env : Term' -> Prop) (f:cnf) := make_conj (fun cl => ~ make_conj env cl) f. + + + Lemma eval_cnf_app : forall env x y, eval_cnf (eval' env) (x++y) -> eval_cnf (eval' env) x /\ eval_cnf (eval' env) y. + Proof. + unfold eval_cnf. + intros. + rewrite make_conj_app in H ; auto. + Qed. + + + Lemma or_clause_correct : forall env t f, eval_cnf (eval' env) (or_clause_cnf t f) -> (~ make_conj (eval' env) t) \/ (eval_cnf (eval' env) f). + Proof. + unfold eval_cnf. + unfold or_clause_cnf. + induction f. + simpl. + intros ; right;auto. + (**) + rewrite map_simpl. + intros. + rewrite make_conj_cons in H. + destruct H as [HH1 HH2]. + generalize (IHf HH2) ; clear IHf ; intro. + destruct H. + left ; auto. + rewrite make_conj_cons. + destruct (not_make_conj_app _ _ _ (no_middle_eval' env) HH1). + tauto. + tauto. + Qed. + + Lemma eval_cnf_cons : forall env a f, (~ make_conj (eval' env) a) -> eval_cnf (eval' env) f -> eval_cnf (eval' env) (a::f). + Proof. + intros. + unfold eval_cnf in *. + rewrite make_conj_cons ; eauto. + Qed. + + Lemma or_cnf_correct : forall env f f', eval_cnf (eval' env) (or_cnf f f') -> (eval_cnf (eval' env) f) \/ (eval_cnf (eval' env) f'). + Proof. + induction f. + unfold eval_cnf. + simpl. + tauto. + (**) + intros. + simpl in H. + destruct (eval_cnf_app _ _ _ H). + clear H. + destruct (IHf _ H0). + destruct (or_clause_correct _ _ _ H1). + left. + apply eval_cnf_cons ; auto. + right ; auto. + right ; auto. + Qed. + + Variable normalise_correct : forall env t, eval_cnf (eval' env) (normalise t) -> eval env t. + + Variable negate_correct : forall env t, eval_cnf (eval' env) (negate t) -> ~ eval env t. + + + Lemma xcnf_correct : forall f pol env, eval_cnf (eval' env) (xcnf pol f) -> eval_f (eval env) (if pol then f else N f). + Proof. + induction f. + (* TT *) + unfold eval_cnf. + simpl. + destruct pol ; simpl ; auto. + (* FF *) + unfold eval_cnf. + destruct pol; simpl ; auto. + (* P *) + simpl. + destruct pol ; intros ;simpl. + unfold eval_cnf in H. + (* Here I have to drop the proposition *) + simpl in H. + tauto. + (* Here, I could store P in the clause *) + unfold eval_cnf in H;simpl in H. + tauto. + (* A *) + simpl. + destruct pol ; simpl. + intros. + apply normalise_correct ; auto. + (* A 2 *) + intros. + apply negate_correct ; auto. + auto. + (* Cj *) + destruct pol ; simpl. + (* pol = true *) + intros. + unfold and_cnf in H. + destruct (eval_cnf_app _ _ _ H). + clear H. + split. + apply (IHf1 _ _ H0). + apply (IHf2 _ _ H1). + (* pol = false *) + intros. + destruct (or_cnf_correct _ _ _ H). + generalize (IHf1 false env H0). + simpl. + tauto. + generalize (IHf2 false env H0). + simpl. + tauto. + (* D *) + simpl. + destruct pol. + (* pol = true *) + intros. + destruct (or_cnf_correct _ _ _ H). + generalize (IHf1 _ env H0). + simpl. + tauto. + generalize (IHf2 _ env H0). + simpl. + tauto. + (* pol = true *) + unfold and_cnf. + intros. + destruct (eval_cnf_app _ _ _ H). + clear H. + simpl. + generalize (IHf1 _ _ H0). + generalize (IHf2 _ _ H1). + simpl. + tauto. + (**) + simpl. + destruct pol ; simpl. + intros. + apply (IHf false) ; auto. + intros. + generalize (IHf _ _ H). + tauto. + (* I *) + simpl; intros. + destruct pol. + simpl. + intro. + destruct (or_cnf_correct _ _ _ H). + generalize (IHf1 _ _ H1). + simpl in *. + tauto. + generalize (IHf2 _ _ H1). + auto. + (* pol = false *) + unfold and_cnf in H. + simpl in H. + destruct (eval_cnf_app _ _ _ H). + generalize (IHf1 _ _ H0). + generalize (IHf2 _ _ H1). + simpl. + tauto. + Qed. + + + Variable Witness : Type. + Variable checker : list Term' -> Witness -> bool. + + Variable checker_sound : forall t w, checker t w = true -> forall env, make_impl (eval' env) t False. + + Fixpoint cnf_checker (f : cnf) (l : list Witness) {struct f}: bool := + match f with + | nil => true + | e::f => match l with + | nil => false + | c::l => match checker e c with + | true => cnf_checker f l + | _ => false + end + end + end. + + Lemma cnf_checker_sound : forall t w, cnf_checker t w = true -> forall env, eval_cnf (eval' env) t. + Proof. + unfold eval_cnf. + induction t. + (* bc *) + simpl. + auto. + (* ic *) + simpl. + destruct w. + intros ; discriminate. + case_eq (checker a w) ; intros ; try discriminate. + generalize (@checker_sound _ _ H env). + generalize (IHt _ H0 env) ; intros. + destruct t. + red ; intro. + rewrite <- make_conj_impl in H2. + tauto. + rewrite <- make_conj_impl in H2. + tauto. + Qed. + + + Definition tauto_checker (f:BFormula Term) (w:list Witness) : bool := + cnf_checker (xcnf true f) w. + + Lemma tauto_checker_sound : forall t w, tauto_checker t w = true -> forall env, eval_f (eval env) t. + Proof. + unfold tauto_checker. + intros. + change (eval_f (eval env) t) with (eval_f (eval env) (if true then t else TT Term)). + apply (xcnf_correct t true). + eapply cnf_checker_sound ; eauto. + Qed. + + + + +End S. + diff --git a/contrib/micromega/VarMap.v b/contrib/micromega/VarMap.v new file mode 100644 index 00000000..240c0fb7 --- /dev/null +++ b/contrib/micromega/VarMap.v @@ -0,0 +1,258 @@ +(************************************************************************) +(* 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 *) +(************************************************************************) +(* *) +(* Micromega: A reflexive tactic using the Positivstellensatz *) +(* *) +(* Frédéric Besson (Irisa/Inria) 2006-2008 *) +(* *) +(************************************************************************) + +Require Import ZArith. +Require Import Coq.Arith.Max. +Require Import List. +Set Implicit Arguments. + +(* I have addded a Leaf constructor to the varmap data structure (/contrib/ring/Quote.v) + -- this is harmless and spares a lot of Empty. + This means smaller proof-terms. + BTW, by dropping the polymorphism, I get small (yet noticeable) speed-up. +*) + +Section MakeVarMap. + Variable A : Type. + Variable default : A. + + Inductive t : Type := + | Empty : t + | Leaf : A -> t + | Node : t -> A -> t -> t . + + Fixpoint find (vm : t ) (p:positive) {struct vm} : A := + match vm with + | Empty => default + | Leaf i => i + | Node l e r => match p with + | xH => e + | xO p => find l p + | xI p => find r p + end + end. + + (* an off_map (a map with offset) offers the same functionalites as /contrib/setoid_ring/BinList.v - it is used in EnvRing.v *) +(* + Definition off_map := (option positive *t )%type. + + + + Definition jump (j:positive) (l:off_map ) := + let (o,m) := l in + match o with + | None => (Some j,m) + | Some j0 => (Some (j+j0)%positive,m) + end. + + Definition nth (n:positive) (l: off_map ) := + let (o,m) := l in + let idx := match o with + | None => n + | Some i => i + n + end%positive in + find idx m. + + + Definition hd (l:off_map) := nth xH l. + + + Definition tail (l:off_map ) := jump xH l. + + + Lemma psucc : forall p, (match p with + | xI y' => xO (Psucc y') + | xO y' => xI y' + | 1%positive => 2%positive + end) = (p+1)%positive. + Proof. + destruct p. + auto with zarith. + rewrite xI_succ_xO. + auto with zarith. + reflexivity. + Qed. + + Lemma jump_Pplus : forall i j l, + (jump (i + j) l) = (jump i (jump j l)). + Proof. + unfold jump. + destruct l. + destruct o. + rewrite Pplus_assoc. + reflexivity. + reflexivity. + Qed. + + Lemma jump_simpl : forall p l, + jump p l = + match p with + | xH => tail l + | xO p => jump p (jump p l) + | xI p => jump p (jump p (tail l)) + end. + Proof. + destruct p ; unfold tail ; intros ; repeat rewrite <- jump_Pplus. + (* xI p = p + p + 1 *) + rewrite xI_succ_xO. + rewrite Pplus_diag. + rewrite <- Pplus_one_succ_r. + reflexivity. + (* xO p = p + p *) + rewrite Pplus_diag. + reflexivity. + reflexivity. + Qed. + + Ltac jump_s := + repeat + match goal with + | |- context [jump xH ?e] => rewrite (jump_simpl xH) + | |- context [jump (xO ?p) ?e] => rewrite (jump_simpl (xO p)) + | |- context [jump (xI ?p) ?e] => rewrite (jump_simpl (xI p)) + end. + + Lemma jump_tl : forall j l, tail (jump j l) = jump j (tail l). + Proof. + unfold tail. + intros. + repeat rewrite <- jump_Pplus. + rewrite Pplus_comm. + reflexivity. + Qed. + + Lemma jump_Psucc : forall j l, + (jump (Psucc j) l) = (jump 1 (jump j l)). + Proof. + intros. + rewrite <- jump_Pplus. + rewrite Pplus_one_succ_r. + rewrite Pplus_comm. + reflexivity. + Qed. + + Lemma jump_Pdouble_minus_one : forall i l, + (jump (Pdouble_minus_one i) (tail l)) = (jump i (jump i l)). + Proof. + unfold tail. + intros. + repeat rewrite <- jump_Pplus. + rewrite <- Pplus_one_succ_r. + rewrite Psucc_o_double_minus_one_eq_xO. + rewrite Pplus_diag. + reflexivity. + Qed. + + Lemma jump_x0_tail : forall p l, jump (xO p) (tail l) = jump (xI p) l. + Proof. + intros. + jump_s. + repeat rewrite <- jump_Pplus. + reflexivity. + Qed. + + + Lemma nth_spec : forall p l, + nth p l = + match p with + | xH => hd l + | xO p => nth p (jump p l) + | xI p => nth p (jump p (tail l)) + end. + Proof. + unfold nth. + destruct l. + destruct o. + simpl. + rewrite psucc. + destruct p. + replace (p0 + xI p)%positive with ((p + (p0 + 1) + p))%positive. + reflexivity. + rewrite xI_succ_xO. + rewrite Pplus_one_succ_r. + rewrite <- Pplus_diag. + rewrite Pplus_comm. + symmetry. + rewrite (Pplus_comm p0). + rewrite <- Pplus_assoc. + rewrite (Pplus_comm 1)%positive. + rewrite <- Pplus_assoc. + reflexivity. + (**) + replace ((p0 + xO p))%positive with (p + p0 + p)%positive. + reflexivity. + rewrite <- Pplus_diag. + rewrite <- Pplus_assoc. + rewrite Pplus_comm. + rewrite Pplus_assoc. + reflexivity. + reflexivity. + simpl. + destruct p. + rewrite xI_succ_xO. + rewrite Pplus_one_succ_r. + rewrite <- Pplus_diag. + symmetry. + rewrite Pplus_comm. + rewrite Pplus_assoc. + reflexivity. + rewrite Pplus_diag. + reflexivity. + reflexivity. + Qed. + + + Lemma nth_jump : forall p l, nth p (tail l) = hd (jump p l). + Proof. + destruct l. + unfold tail. + unfold hd. + unfold jump. + unfold nth. + destruct o. + symmetry. + rewrite Pplus_comm. + rewrite <- Pplus_assoc. + rewrite (Pplus_comm p0). + reflexivity. + rewrite Pplus_comm. + reflexivity. + Qed. + + Lemma nth_Pdouble_minus_one : + forall p l, nth (Pdouble_minus_one p) (tail l) = nth p (jump p l). + Proof. + destruct l. + unfold tail. + unfold nth, jump. + destruct o. + rewrite ((Pplus_comm p)). + rewrite <- (Pplus_assoc p0). + rewrite Pplus_diag. + rewrite <- Psucc_o_double_minus_one_eq_xO. + rewrite Pplus_one_succ_r. + rewrite (Pplus_comm (Pdouble_minus_one p)). + rewrite Pplus_assoc. + rewrite (Pplus_comm p0). + reflexivity. + rewrite <- Pplus_one_succ_l. + rewrite Psucc_o_double_minus_one_eq_xO. + rewrite Pplus_diag. + reflexivity. + Qed. + +*) + +End MakeVarMap. + diff --git a/contrib/micromega/ZCoeff.v b/contrib/micromega/ZCoeff.v new file mode 100644 index 00000000..ced67e39 --- /dev/null +++ b/contrib/micromega/ZCoeff.v @@ -0,0 +1,173 @@ +(************************************************************************) +(* 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 *) +(************************************************************************) +(* Evgeny Makarov, INRIA, 2007 *) +(************************************************************************) + +Require Import OrderedRing. +Require Import RingMicromega. +Require Import ZArith. +Require Import InitialRing. +Require Import Setoid. + +Import OrderedRingSyntax. + +Set Implicit Arguments. + +Section InitialMorphism. + +Variable R : Type. +Variables rO rI : R. +Variables rplus rtimes rminus: R -> R -> R. +Variable ropp : R -> R. +Variables req rle rlt : R -> R -> Prop. + +Variable sor : SOR rO rI rplus rtimes rminus ropp req rle rlt. + +Notation "0" := rO. +Notation "1" := rI. +Notation "x + y" := (rplus x y). +Notation "x * y " := (rtimes x y). +Notation "x - y " := (rminus x y). +Notation "- x" := (ropp x). +Notation "x == y" := (req x y). +Notation "x ~= y" := (~ req x y). +Notation "x <= y" := (rle x y). +Notation "x < y" := (rlt x y). + +Lemma req_refl : forall x, req x x. +Proof. + destruct sor.(SORsetoid). + apply Equivalence_Reflexive. +Qed. + +Lemma req_sym : forall x y, req x y -> req y x. +Proof. + destruct sor.(SORsetoid). + apply Equivalence_Symmetric. +Qed. + +Lemma req_trans : forall x y z, req x y -> req y z -> req x z. +Proof. + destruct sor.(SORsetoid). + apply Equivalence_Transitive. +Qed. + + +Add Relation R req + reflexivity proved by sor.(SORsetoid).(@Equivalence_Reflexive _ _) + symmetry proved by sor.(SORsetoid).(@Equivalence_Symmetric _ _) + transitivity proved by sor.(SORsetoid).(@Equivalence_Transitive _ _) +as sor_setoid. + +Add Morphism rplus with signature req ==> req ==> req as rplus_morph. +Proof. +exact sor.(SORplus_wd). +Qed. +Add Morphism rtimes with signature req ==> req ==> req as rtimes_morph. +Proof. +exact sor.(SORtimes_wd). +Qed. +Add Morphism ropp with signature req ==> req as ropp_morph. +Proof. +exact sor.(SORopp_wd). +Qed. +Add Morphism rle with signature req ==> req ==> iff as rle_morph. +Proof. +exact sor.(SORle_wd). +Qed. +Add Morphism rlt with signature req ==> req ==> iff as rlt_morph. +Proof. +exact sor.(SORlt_wd). +Qed. +Add Morphism rminus with signature req ==> req ==> req as rminus_morph. +Proof. + exact (rminus_morph sor). +Qed. + +Ltac le_less := rewrite (Rle_lt_eq sor); left; try assumption. +Ltac le_equal := rewrite (Rle_lt_eq sor); right; try reflexivity; try assumption. + +Definition gen_order_phi_Z : Z -> R := gen_phiZ 0 1 rplus rtimes ropp. + +Notation phi_pos := (gen_phiPOS 1 rplus rtimes). +Notation phi_pos1 := (gen_phiPOS1 1 rplus rtimes). + +Notation "[ x ]" := (gen_order_phi_Z x). + +Lemma ring_ops_wd : ring_eq_ext rplus rtimes ropp req. +Proof. +constructor. +exact rplus_morph. +exact rtimes_morph. +exact ropp_morph. +Qed. + +Lemma Zring_morph : + ring_morph 0 1 rplus rtimes rminus ropp req + 0%Z 1%Z Zplus Zmult Zminus Zopp + Zeq_bool gen_order_phi_Z. +Proof. +exact (gen_phiZ_morph sor.(SORsetoid) ring_ops_wd sor.(SORrt)). +Qed. + +Lemma phi_pos1_pos : forall x : positive, 0 < phi_pos1 x. +Proof. +induction x as [x IH | x IH |]; simpl; +try apply (Rplus_pos_pos sor); try apply (Rtimes_pos_pos sor); try apply (Rplus_pos_pos sor); +try apply (Rlt_0_1 sor); assumption. +Qed. + +Lemma phi_pos1_succ : forall x : positive, phi_pos1 (Psucc x) == 1 + phi_pos1 x. +Proof. +exact (ARgen_phiPOS_Psucc sor.(SORsetoid) ring_ops_wd + (Rth_ARth sor.(SORsetoid) ring_ops_wd sor.(SORrt))). +Qed. + +Lemma clt_pos_morph : forall x y : positive, (x < y)%positive -> phi_pos1 x < phi_pos1 y. +Proof. +intros x y H. pattern y; apply Plt_ind with x. +rewrite phi_pos1_succ; apply (Rlt_succ_r sor). +clear y H; intros y _ H. rewrite phi_pos1_succ. now apply (Rlt_lt_succ sor). +assumption. +Qed. + +Lemma clt_morph : forall x y : Z, (x < y)%Z -> [x] < [y]. +Proof. +unfold Zlt; intros x y H; +do 2 rewrite (same_genZ sor.(SORsetoid) ring_ops_wd sor.(SORrt)); +destruct x; destruct y; simpl in *; try discriminate. +apply phi_pos1_pos. +now apply clt_pos_morph. +apply <- (Ropp_neg_pos sor); apply phi_pos1_pos. +apply (Rlt_trans sor) with 0. apply <- (Ropp_neg_pos sor); apply phi_pos1_pos. +apply phi_pos1_pos. +rewrite Pcompare_antisym in H; simpl in H. apply -> (Ropp_lt_mono sor). +now apply clt_pos_morph. +Qed. + +Lemma Zcleb_morph : forall x y : Z, Zle_bool x y = true -> [x] <= [y]. +Proof. +unfold Zle_bool; intros x y H. +case_eq (x ?= y)%Z; intro H1; rewrite H1 in H. +le_equal. apply Zring_morph.(morph_eq). unfold Zeq_bool; now rewrite H1. +le_less. now apply clt_morph. +discriminate. +Qed. + +Lemma Zcneqb_morph : forall x y : Z, Zeq_bool x y = false -> [x] ~= [y]. +Proof. +intros x y H. unfold Zeq_bool in H. +case_eq (Zcompare x y); intro H1; rewrite H1 in *; (discriminate || clear H). +apply (Rlt_neq sor). now apply clt_morph. +fold (x > y)%Z in H1. rewrite Zgt_iff_lt in H1. +apply (Rneq_symm sor). apply (Rlt_neq sor). now apply clt_morph. +Qed. + +End InitialMorphism. + + diff --git a/contrib/micromega/ZMicromega.v b/contrib/micromega/ZMicromega.v new file mode 100644 index 00000000..94c83f73 --- /dev/null +++ b/contrib/micromega/ZMicromega.v @@ -0,0 +1,714 @@ +(************************************************************************) +(* 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 *) +(************************************************************************) +(* *) +(* Micromega: A reflexive tactic using the Positivstellensatz *) +(* *) +(* Frédéric Besson (Irisa/Inria) 2006-2008 *) +(* *) +(************************************************************************) + +Require Import OrderedRing. +Require Import RingMicromega. +Require Import ZCoeff. +Require Import Refl. +Require Import ZArith. +Require Import List. +Require Import Bool. + +Ltac flatten_bool := + repeat match goal with + [ id : (_ && _)%bool = true |- _ ] => destruct (andb_prop _ _ id); clear id + | [ id : (_ || _)%bool = true |- _ ] => destruct (orb_prop _ _ id); clear id + end. + +Require Import EnvRing. + +Open Scope Z_scope. + +Lemma Zsor : SOR 0 1 Zplus Zmult Zminus Zopp (@eq Z) Zle Zlt. +Proof. + constructor ; intros ; subst ; try (intuition (auto with zarith)). + apply Zsth. + apply Zth. + destruct (Ztrichotomy n m) ; intuition (auto with zarith). + apply Zmult_lt_0_compat ; auto. +Qed. + +Lemma Zeq_bool_neq : forall x y, Zeq_bool x y = false -> x <> y. +Proof. + red ; intros. + subst. + unfold Zeq_bool in H. + rewrite Zcompare_refl in H. + discriminate. +Qed. + +Lemma ZSORaddon : + SORaddon 0 1 Zplus Zmult Zminus Zopp (@eq Z) Zle (* ring elements *) + 0%Z 1%Z Zplus Zmult Zminus Zopp (* coefficients *) + Zeq_bool Zle_bool + (fun x => x) (fun x => x) (pow_N 1 Zmult). +Proof. + constructor. + constructor ; intros ; try reflexivity. + apply Zeqb_ok ; auto. + constructor. + reflexivity. + intros x y. + apply Zeq_bool_neq ; auto. + apply Zle_bool_imp_le. +Qed. + + +(*Definition Zeval_expr := eval_pexpr 0 Zplus Zmult Zminus Zopp (fun x => x) (fun x => Z_of_N x) (Zpower).*) + +Fixpoint Zeval_expr (env: PolEnv Z) (e: PExpr Z) : Z := + match e with + | PEc c => c + | PEX j => env j + | PEadd pe1 pe2 => (Zeval_expr env pe1) + (Zeval_expr env pe2) + | PEsub pe1 pe2 => (Zeval_expr env pe1) - (Zeval_expr env pe2) + | PEmul pe1 pe2 => (Zeval_expr env pe1) * (Zeval_expr env pe2) + | PEopp pe1 => - (Zeval_expr env pe1) + | PEpow pe1 n => Zpower (Zeval_expr env pe1) (Z_of_N n) + end. + +Lemma Zeval_expr_simpl : forall env e, + Zeval_expr env e = + match e with + | PEc c => c + | PEX j => env j + | PEadd pe1 pe2 => (Zeval_expr env pe1) + (Zeval_expr env pe2) + | PEsub pe1 pe2 => (Zeval_expr env pe1) - (Zeval_expr env pe2) + | PEmul pe1 pe2 => (Zeval_expr env pe1) * (Zeval_expr env pe2) + | PEopp pe1 => - (Zeval_expr env pe1) + | PEpow pe1 n => Zpower (Zeval_expr env pe1) (Z_of_N n) + end. +Proof. + destruct e ; reflexivity. +Qed. + + +Definition Zeval_expr' := eval_pexpr Zplus Zmult Zminus Zopp (fun x => x) (fun x => x) (pow_N 1 Zmult). + +Lemma ZNpower : forall r n, r ^ Z_of_N n = pow_N 1 Zmult r n. +Proof. + destruct n. + reflexivity. + simpl. + unfold Zpower_pos. + replace (pow_pos Zmult r p) with (1 * (pow_pos Zmult r p)) by ring. + generalize 1. + induction p; simpl ; intros ; repeat rewrite IHp ; ring. +Qed. + + + +Lemma Zeval_expr_compat : forall env e, Zeval_expr env e = Zeval_expr' env e. +Proof. + induction e ; simpl ; subst ; try congruence. + rewrite IHe. + apply ZNpower. +Qed. + +Definition Zeval_op2 (o : Op2) : Z -> Z -> Prop := +match o with +| OpEq => @eq Z +| OpNEq => fun x y => ~ x = y +| OpLe => Zle +| OpGe => Zge +| OpLt => Zlt +| OpGt => Zgt +end. + +Definition Zeval_formula (e: PolEnv Z) (ff : Formula Z) := + let (lhs,o,rhs) := ff in Zeval_op2 o (Zeval_expr e lhs) (Zeval_expr e rhs). + +Definition Zeval_formula' := + eval_formula Zplus Zmult Zminus Zopp (@eq Z) Zle Zlt (fun x => x) (fun x => x) (pow_N 1 Zmult). + +Lemma Zeval_formula_compat : forall env f, Zeval_formula env f <-> Zeval_formula' env f. +Proof. + intros. + unfold Zeval_formula. + destruct f. + repeat rewrite Zeval_expr_compat. + unfold Zeval_formula'. + unfold Zeval_expr'. + split ; destruct Fop ; simpl; auto with zarith. +Qed. + + + +Definition Zeval_nformula := + eval_nformula 0 Zplus Zmult Zminus Zopp (@eq Z) Zle Zlt (fun x => x) (fun x => x) (pow_N 1 Zmult). + +Definition Zeval_op1 (o : Op1) : Z -> Prop := +match o with +| Equal => fun x : Z => x = 0 +| NonEqual => fun x : Z => x <> 0 +| Strict => fun x : Z => 0 < x +| NonStrict => fun x : Z => 0 <= x +end. + +Lemma Zeval_nformula_simpl : forall env f, Zeval_nformula env f = (let (p, op) := f in Zeval_op1 op (Zeval_expr env p)). +Proof. + intros. + destruct f. + rewrite Zeval_expr_compat. + reflexivity. +Qed. + +Lemma Zeval_nformula_dec : forall env d, (Zeval_nformula env d) \/ ~ (Zeval_nformula env d). +Proof. + exact (fun env d =>eval_nformula_dec Zsor (fun x => x) (fun x => x) (pow_N 1%Z Zmult) env d). +Qed. + +Definition ZWitness := ConeMember Z. + +Definition ZWeakChecker := check_normalised_formulas 0 1 Zplus Zmult Zminus Zopp Zeq_bool Zle_bool. + +Lemma ZWeakChecker_sound : forall (l : list (NFormula Z)) (cm : ZWitness), + ZWeakChecker l cm = true -> + forall env, make_impl (Zeval_nformula env) l False. +Proof. + intros l cm H. + intro. + unfold Zeval_nformula. + apply (checker_nf_sound Zsor ZSORaddon l cm). + unfold ZWeakChecker in H. + exact H. +Qed. + +Definition xnormalise (t:Formula Z) : list (NFormula Z) := + let (lhs,o,rhs) := t in + match o with + | OpEq => + ((PEsub lhs (PEadd rhs (PEc 1))),NonStrict)::((PEsub rhs (PEadd lhs (PEc 1))),NonStrict)::nil + | OpNEq => (PEsub lhs rhs,Equal) :: nil + | OpGt => (PEsub rhs lhs,NonStrict) :: nil + | OpLt => (PEsub lhs rhs,NonStrict) :: nil + | OpGe => (PEsub rhs (PEadd lhs (PEc 1)),NonStrict) :: nil + | OpLe => (PEsub lhs (PEadd rhs (PEc 1)),NonStrict) :: nil + end. + +Require Import Tauto. + +Definition normalise (t:Formula Z) : cnf (NFormula Z) := + List.map (fun x => x::nil) (xnormalise t). + + +Lemma normalise_correct : forall env t, eval_cnf (Zeval_nformula env) (normalise t) <-> Zeval_formula env t. +Proof. + unfold normalise, xnormalise ; simpl ; intros env t. + rewrite Zeval_formula_compat. + unfold eval_cnf. + destruct t as [lhs o rhs]; case_eq o ; simpl; + generalize ( eval_pexpr Zplus Zmult Zminus Zopp (fun x : Z => x) + (fun x : BinNat.N => x) (pow_N 1 Zmult) env lhs); + generalize (eval_pexpr Zplus Zmult Zminus Zopp (fun x : Z => x) + (fun x : BinNat.N => x) (pow_N 1 Zmult) env rhs) ; intros z1 z2 ; intros ; subst; + intuition (auto with zarith). +Qed. + +Definition xnegate (t:RingMicromega.Formula Z) : list (NFormula Z) := + let (lhs,o,rhs) := t in + match o with + | OpEq => (PEsub lhs rhs,Equal) :: nil + | OpNEq => ((PEsub lhs (PEadd rhs (PEc 1))),NonStrict)::((PEsub rhs (PEadd lhs (PEc 1))),NonStrict)::nil + | OpGt => (PEsub lhs (PEadd rhs (PEc 1)),NonStrict) :: nil + | OpLt => (PEsub rhs (PEadd lhs (PEc 1)),NonStrict) :: nil + | OpGe => (PEsub lhs rhs,NonStrict) :: nil + | OpLe => (PEsub rhs lhs,NonStrict) :: nil + end. + +Definition negate (t:RingMicromega.Formula Z) : cnf (NFormula Z) := + List.map (fun x => x::nil) (xnegate t). + +Lemma negate_correct : forall env t, eval_cnf (Zeval_nformula env) (negate t) <-> ~ Zeval_formula env t. +Proof. + unfold negate, xnegate ; simpl ; intros env t. + rewrite Zeval_formula_compat. + unfold eval_cnf. + destruct t as [lhs o rhs]; case_eq o ; simpl ; + generalize ( eval_pexpr Zplus Zmult Zminus Zopp (fun x : Z => x) + (fun x : BinNat.N => x) (pow_N 1 Zmult) env lhs); + generalize (eval_pexpr Zplus Zmult Zminus Zopp (fun x : Z => x) + (fun x : BinNat.N => x) (pow_N 1 Zmult) env rhs) ; intros z1 z2 ; intros ; + intuition (auto with zarith). +Qed. + + +Definition ZweakTautoChecker (w: list ZWitness) (f : BFormula (Formula Z)) : bool := + @tauto_checker (Formula Z) (NFormula Z) normalise negate ZWitness ZWeakChecker f w. + +(* To get a complete checker, the proof format has to be enriched *) + +Require Import Zdiv. +Open Scope Z_scope. + +Definition ceiling (a b:Z) : Z := + let (q,r) := Zdiv_eucl a b in + match r with + | Z0 => q + | _ => q + 1 + end. + +Lemma narrow_interval_lower_bound : forall a b x, a > 0 -> a * x >= b -> x >= ceiling b a. +Proof. + unfold ceiling. + intros. + generalize (Z_div_mod b a H). + destruct (Zdiv_eucl b a). + intros. + destruct H1. + destruct H2. + subst. + destruct (Ztrichotomy z0 0) as [ HH1 | [HH2 | HH3]]; destruct z0 ; try auto with zarith ; try discriminate. + assert (HH :x >= z \/ x < z) by (destruct (Ztrichotomy x z) ; auto with zarith). + destruct HH ;auto. + generalize (Zmult_lt_compat_l _ _ _ H3 H1). + auto with zarith. + clear H2. + assert (HH :x >= z +1 \/ x <= z) by (destruct (Ztrichotomy x z) ; intuition (auto with zarith)). + destruct HH ;auto. + assert (0 < a) by auto with zarith. + generalize (Zmult_lt_0_le_compat_r _ _ _ H2 H1). + intros. + rewrite Zmult_comm in H4. + rewrite (Zmult_comm z) in H4. + auto with zarith. +Qed. + +Lemma narrow_interval_upper_bound : forall a b x, a > 0 -> a * x <= b -> x <= Zdiv b a. +Proof. + unfold Zdiv. + intros. + generalize (Z_div_mod b a H). + destruct (Zdiv_eucl b a). + intros. + destruct H1. + destruct H2. + subst. + assert (HH :x <= z \/ z <= x -1) by (destruct (Ztrichotomy x z) ; intuition (auto with zarith)). + destruct HH ;auto. + assert (0 < a) by auto with zarith. + generalize (Zmult_lt_0_le_compat_r _ _ _ H4 H1). + intros. + ring_simplify in H5. + rewrite Zmult_comm in H5. + auto with zarith. +Qed. + + +(* In this case, a certificate is made of a pair of inequations, in 1 variable, + that do not have an integer solution. + => modify the fourier elimination + *) +Require Import QArith. + + +Inductive ProofTerm : Type := +| RatProof : ZWitness -> ProofTerm +| CutProof : PExprC Z -> Q -> ZWitness -> ProofTerm -> ProofTerm +| EnumProof : Q -> PExprC Z -> Q -> ZWitness -> ZWitness -> list ProofTerm -> ProofTerm. + +(* n/d <= x -> d*x - n >= 0 *) + +Definition makeLb (v:PExpr Z) (q:Q) : NFormula Z := + let (n,d) := q in (PEsub (PEmul (PEc (Zpos d)) v) (PEc n),NonStrict). + +(* x <= n/d -> d * x <= d *) +Definition makeUb (v:PExpr Z) (q:Q) : NFormula Z := + let (n,d) := q in + (PEsub (PEc n) (PEmul (PEc (Zpos d)) v), NonStrict). + +Definition qceiling (q:Q) : Z := + let (n,d) := q in ceiling n (Zpos d). + +Definition qfloor (q:Q) : Z := + let (n,d) := q in Zdiv n (Zpos d). + +Definition makeLbCut (v:PExprC Z) (q:Q) : NFormula Z := + (PEsub v (PEc (qceiling q)), NonStrict). + +Definition neg_nformula (f : NFormula Z) := + let (e,o) := f in + (PEopp (PEadd e (PEc 1%Z)), o). + +Lemma neg_nformula_sound : forall env f, snd f = NonStrict ->( ~ (Zeval_nformula env (neg_nformula f)) <-> Zeval_nformula env f). +Proof. + unfold neg_nformula. + destruct f. + simpl. + intros ; subst ; simpl in *. + split; auto with zarith. +Qed. + + +Definition cutChecker (l:list (NFormula Z)) (e: PExpr Z) (lb:Q) (pf : ZWitness) : option (NFormula Z) := + let (lb,lc) := (makeLb e lb,makeLbCut e lb) in + if ZWeakChecker (neg_nformula lb::l) pf then Some lc else None. + + +Fixpoint ZChecker (l:list (NFormula Z)) (pf : ProofTerm) {struct pf} : bool := + match pf with + | RatProof pf => ZWeakChecker l pf + | CutProof e q pf rst => + match cutChecker l e q pf with + | None => false + | Some c => ZChecker (c::l) rst + end + | EnumProof lb e ub pf1 pf2 rst => + match cutChecker l e lb pf1 , cutChecker l (PEopp e) (Qopp ub) pf2 with + | None , _ | _ , None => false + | Some _ , Some _ => let (lb',ub') := (qceiling lb, Zopp (qceiling (- ub))) in + (fix label (pfs:list ProofTerm) := + fun lb ub => + match pfs with + | nil => if Z_gt_dec lb ub then true else false + | pf::rsr => andb (ZChecker ((PEsub e (PEc lb), Equal) :: l) pf) (label rsr (Zplus lb 1%Z) ub) + end) + rst lb' ub' + end + end. + + +Lemma ZChecker_simpl : forall (pf : ProofTerm) (l:list (NFormula Z)), + ZChecker l pf = + match pf with + | RatProof pf => ZWeakChecker l pf + | CutProof e q pf rst => + match cutChecker l e q pf with + | None => false + | Some c => ZChecker (c::l) rst + end + | EnumProof lb e ub pf1 pf2 rst => + match cutChecker l e lb pf1 , cutChecker l (PEopp e) (Qopp ub) pf2 with + | None , _ | _ , None => false + | Some _ , Some _ => let (lb',ub') := (qceiling lb, Zopp (qceiling (- ub))) in + (fix label (pfs:list ProofTerm) := + fun lb ub => + match pfs with + | nil => if Z_gt_dec lb ub then true else false + | pf::rsr => andb (ZChecker ((PEsub e (PEc lb), Equal) :: l) pf) (label rsr (Zplus lb 1%Z) ub) + end) + rst lb' ub' + end + end. +Proof. + destruct pf ; reflexivity. +Qed. + +(* +Fixpoint depth (n:nat) : ProofTerm -> option nat := + match n with + | O => fun pf => None + | S n => + fun pf => + match pf with + | RatProof _ => Some O + | CutProof _ _ _ p => option_map S (depth n p) + | EnumProof _ _ _ _ _ l => + let f := fun pf x => + match x , depth n pf with + | None , _ | _ , None => None + | Some n1 , Some n2 => Some (Max.max n1 n2) + end in + List.fold_right f (Some O) l + end + end. +*) +Fixpoint bdepth (pf : ProofTerm) : nat := + match pf with + | RatProof _ => O + | CutProof _ _ _ p => S (bdepth p) + | EnumProof _ _ _ _ _ l => S (List.fold_right (fun pf x => Max.max (bdepth pf) x) O l) + end. + +Require Import Wf_nat. + +Lemma in_bdepth : forall l a b p c c0 y, In y l -> ltof ProofTerm bdepth y (EnumProof a b p c c0 l). +Proof. + induction l. + simpl. + tauto. + simpl. + intros. + destruct H. + subst. + unfold ltof. + simpl. + generalize ( (fold_right + (fun (pf : ProofTerm) (x : nat) => Max.max (bdepth pf) x) 0%nat l)). + intros. + generalize (bdepth y) ; intros. + generalize (Max.max_l n0 n) (Max.max_r n0 n). + omega. + generalize (IHl a0 b p c c0 y H). + unfold ltof. + simpl. + generalize ( (fold_right (fun (pf : ProofTerm) (x : nat) => Max.max (bdepth pf) x) 0%nat + l)). + intros. + generalize (Max.max_l (bdepth a) n) (Max.max_r (bdepth a) n). + omega. +Qed. + +Lemma lb_lbcut : forall env e q, Zeval_nformula env (makeLb e q) -> Zeval_nformula env (makeLbCut e q). +Proof. + unfold makeLb, makeLbCut. + destruct q. + rewrite Zeval_nformula_simpl. + rewrite Zeval_nformula_simpl. + unfold Zeval_op1. + rewrite Zeval_expr_simpl. + rewrite Zeval_expr_simpl. + rewrite Zeval_expr_simpl. + intro. + rewrite Zeval_expr_simpl. + revert H. + generalize (Zeval_expr env e). + rewrite Zeval_expr_simpl. + rewrite Zeval_expr_simpl. + unfold qceiling. + intros. + assert ( z >= ceiling Qnum (' Qden))%Z. + apply narrow_interval_lower_bound. + compute. + reflexivity. + destruct z ; auto with zarith. + auto with zarith. +Qed. + +Lemma cutChecker_sound : forall e lb pf l res, cutChecker l e lb pf = Some res -> + forall env, make_impl (Zeval_nformula env) l (Zeval_nformula env res). +Proof. + unfold cutChecker. + intros. + revert H. + case_eq (ZWeakChecker (neg_nformula (makeLb e lb) :: l) pf); intros ; [idtac | discriminate]. + generalize (ZWeakChecker_sound _ _ H env). + intros. + inversion H0 ; subst ; clear H0. + apply -> make_conj_impl. + simpl in H1. + rewrite <- make_conj_impl in H1. + intros. + apply -> neg_nformula_sound ; auto. + red ; intros. + apply H1 ; auto. + clear H H1 H0. + generalize (lb_lbcut env e lb). + intros. + destruct (Zeval_nformula_dec env ((neg_nformula (makeLb e lb)))). + auto. + rewrite -> neg_nformula_sound in H0. + assert (HH := H H0). + rewrite <- neg_nformula_sound in HH. + tauto. + reflexivity. + unfold makeLb. + destruct lb. + reflexivity. +Qed. + + +Lemma cutChecker_sound_bound : forall e lb pf l res, cutChecker l e lb pf = Some res -> + forall env, make_conj (Zeval_nformula env) l -> (Zeval_expr env e >= qceiling lb)%Z. +Proof. + intros. + generalize (cutChecker_sound _ _ _ _ _ H env). + intros. + rewrite <- (make_conj_impl) in H1. + generalize (H1 H0). + unfold cutChecker in H. + destruct (ZWeakChecker (neg_nformula (makeLb e lb) :: l) pf). + unfold makeLbCut in H. + inversion H ; subst. + clear H. + simpl. + rewrite Zeval_expr_compat. + unfold Zeval_expr'. + auto with zarith. + discriminate. +Qed. + + +Lemma ZChecker_sound : forall w l, ZChecker l w = true -> forall env, make_impl (Zeval_nformula env) l False. +Proof. + induction w using (well_founded_ind (well_founded_ltof _ bdepth)). + destruct w. + (* RatProof *) + simpl. + intros. + eapply ZWeakChecker_sound. + apply H0. + (* CutProof *) + simpl. + intro. + case_eq (cutChecker l p q z) ; intros. + generalize (cutChecker_sound _ _ _ _ _ H0 env). + intro. + assert (make_impl (Zeval_nformula env) (n::l) False). + eapply (H w) ; auto. + unfold ltof. + simpl. + auto with arith. + simpl in H3. + rewrite <- make_conj_impl in H2. + rewrite <- make_conj_impl in H3. + rewrite <- make_conj_impl. + tauto. + discriminate. + (* EnumProof *) + intro. + rewrite ZChecker_simpl. + case_eq (cutChecker l0 p q z). + rename q into llb. + case_eq (cutChecker l0 (PEopp p) (- q0) z0). + intros. + rename q0 into uub. + (* get the bounds of the enum *) + rewrite <- make_conj_impl. + intro. + assert (qceiling llb <= Zeval_expr env p <= - qceiling ( - uub))%Z. + generalize (cutChecker_sound_bound _ _ _ _ _ H0 env H3). + generalize (cutChecker_sound_bound _ _ _ _ _ H1 env H3). + intros. + rewrite Zeval_expr_simpl in H5. + auto with zarith. + clear H0 H1. + revert H2 H3 H4. + generalize (qceiling llb) (- qceiling (- uub))%Z. + set (FF := (fix label (pfs : list ProofTerm) (lb ub : Z) {struct pfs} : bool := + match pfs with + | nil => if Z_gt_dec lb ub then true else false + | pf :: rsr => + (ZChecker ((PEsub p (PEc lb), Equal) :: l0) pf && + label rsr (lb + 1)%Z ub)%bool + end)). + intros z1 z2. + intros. + assert (forall x, z1 <= x <= z2 -> exists pr, + (In pr l /\ + ZChecker ((PEsub p (PEc x),Equal) :: l0) pr = true))%Z. + clear H. + revert H2. + clear H4. + revert z1 z2. + induction l;simpl ;intros. + destruct (Z_gt_dec z1 z2). + intros. + apply False_ind ; omega. + discriminate. + intros. + simpl in H2. + flatten_bool. + assert (HH:(x = z1 \/ z1 +1 <=x)%Z) by omega. + destruct HH. + subst. + exists a ; auto. + assert (z1 + 1 <= x <= z2)%Z by omega. + destruct (IHl _ _ H1 _ H4). + destruct H5. + exists x0 ; split;auto. + (*/asser *) + destruct (H0 _ H4) as [pr [Hin Hcheker]]. + assert (make_impl (Zeval_nformula env) ((PEsub p (PEc (Zeval_expr env p)),Equal) :: l0) False). + apply (H pr);auto. + apply in_bdepth ; auto. + rewrite <- make_conj_impl in H1. + apply H1. + rewrite make_conj_cons. + split ;auto. + rewrite Zeval_nformula_simpl; + unfold Zeval_op1; + rewrite Zeval_expr_simpl. + generalize (Zeval_expr env p). + intros. + rewrite Zeval_expr_simpl. + auto with zarith. + intros ; discriminate. + intros ; discriminate. +Qed. + +Definition ZTautoChecker (f : BFormula (Formula Z)) (w: list ProofTerm): bool := + @tauto_checker (Formula Z) (NFormula Z) normalise negate ProofTerm ZChecker f w. + +Lemma ZTautoChecker_sound : forall f w, ZTautoChecker f w = true -> forall env, eval_f (Zeval_formula env) f. +Proof. + intros f w. + unfold ZTautoChecker. + apply (tauto_checker_sound Zeval_formula Zeval_nformula). + apply Zeval_nformula_dec. + intros env t. + rewrite normalise_correct ; auto. + intros env t. + rewrite negate_correct ; auto. + intros t w0. + apply ZChecker_sound. +Qed. + + +Open Scope Z_scope. + + +Fixpoint map_cone (f: nat -> nat) (e:ZWitness) : ZWitness := + match e with + | S_In n => S_In _ (f n) + | S_Ideal e cm => S_Ideal e (map_cone f cm) + | S_Square _ => e + | S_Monoid l => S_Monoid _ (List.map f l) + | S_Mult cm1 cm2 => S_Mult (map_cone f cm1) (map_cone f cm2) + | S_Add cm1 cm2 => S_Add (map_cone f cm1) (map_cone f cm2) + | _ => e + end. + +Fixpoint indexes (e:ZWitness) : list nat := + match e with + | S_In n => n::nil + | S_Ideal e cm => indexes cm + | S_Square e => nil + | S_Monoid l => l + | S_Mult cm1 cm2 => (indexes cm1)++ (indexes cm2) + | S_Add cm1 cm2 => (indexes cm1)++ (indexes cm2) + | _ => nil + end. + +(** To ease bindings from ml code **) +(*Definition varmap := Quote.varmap.*) +Definition make_impl := Refl.make_impl. +Definition make_conj := Refl.make_conj. + +Require VarMap. + +(*Definition varmap_type := VarMap.t Z. *) +Definition env := PolEnv Z. +Definition node := @VarMap.Node Z. +Definition empty := @VarMap.Empty Z. +Definition leaf := @VarMap.Leaf Z. + +Definition coneMember := ZWitness. + +Definition eval := Zeval_formula. + +Definition prod_pos_nat := prod positive nat. + +Require Import Int. + + +Definition n_of_Z (z:Z) : BinNat.N := + match z with + | Z0 => N0 + | Zpos p => Npos p + | Zneg p => N0 + end. + + + diff --git a/contrib/micromega/certificate.ml b/contrib/micromega/certificate.ml new file mode 100644 index 00000000..88e882e6 --- /dev/null +++ b/contrib/micromega/certificate.ml @@ -0,0 +1,618 @@ +(************************************************************************) +(* 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 *) +(************************************************************************) +(* *) +(* Micromega: A reflexive tactic using the Positivstellensatz *) +(* *) +(* Frédéric Besson (Irisa/Inria) 2006-2008 *) +(* *) +(************************************************************************) + +(* We take as input a list of polynomials [p1...pn] and return an unfeasibility + certificate polynomial. *) + +(*open Micromega.Polynomial*) +open Big_int +open Num + +module Mc = Micromega +module Ml2C = Mutils.CamlToCoq +module C2Ml = Mutils.CoqToCaml + +let (<+>) = add_num +let (<->) = minus_num +let (<*>) = mult_num + +type var = Mc.positive + +module Monomial : +sig + type t + val const : t + val var : var -> t + val find : var -> t -> int + val mult : var -> t -> t + val prod : t -> t -> t + val compare : t -> t -> int + val pp : out_channel -> t -> unit + val fold : (var -> int -> 'a -> 'a) -> t -> 'a -> 'a +end + = +struct + (* A monomial is represented by a multiset of variables *) + module Map = Map.Make(struct type t = var let compare = Pervasives.compare end) + open Map + + type t = int Map.t + + (* The monomial that corresponds to a constant *) + let const = Map.empty + + (* The monomial 'x' *) + let var x = Map.add x 1 Map.empty + + (* Get the degre of a variable in a monomial *) + let find x m = try find x m with Not_found -> 0 + + (* Multiply a monomial by a variable *) + let mult x m = add x ( (find x m) + 1) m + + (* Product of monomials *) + let prod m1 m2 = Map.fold (fun k d m -> add k ((find k m) + d) m) m1 m2 + + (* Total ordering of monomials *) + let compare m1 m2 = Map.compare Pervasives.compare m1 m2 + + let pp o m = Map.iter (fun k v -> + if v = 1 then Printf.fprintf o "x%i." (C2Ml.index k) + else Printf.fprintf o "x%i^%i." (C2Ml.index k) v) m + + let fold = fold + +end + + +module Poly : + (* A polynomial is a map of monomials *) + (* + This is probably a naive implementation + (expected to be fast enough - Coq is probably the bottleneck) + *The new ring contribution is using a sparse Horner representation. + *) +sig + type t + val get : Monomial.t -> t -> num + val variable : var -> t + val add : Monomial.t -> num -> t -> t + val constant : num -> t + val mult : Monomial.t -> num -> t -> t + val product : t -> t -> t + val addition : t -> t -> t + val uminus : t -> t + val fold : (Monomial.t -> num -> 'a -> 'a) -> t -> 'a -> 'a + val pp : out_channel -> t -> unit + val compare : t -> t -> int +end = +struct + (*normalisation bug : 0*x ... *) + module P = Map.Make(Monomial) + open P + + type t = num P.t + + let pp o p = P.iter (fun k v -> + if compare_num v (Int 0) <> 0 + then + if Monomial.compare Monomial.const k = 0 + then Printf.fprintf o "%s " (string_of_num v) + else Printf.fprintf o "%s*%a " (string_of_num v) Monomial.pp k) p + + (* Get the coefficient of monomial mn *) + let get : Monomial.t -> t -> num = + fun mn p -> try find mn p with Not_found -> (Int 0) + + + (* The polynomial 1.x *) + let variable : var -> t = + fun x -> add (Monomial.var x) (Int 1) empty + + (*The constant polynomial *) + let constant : num -> t = + fun c -> add (Monomial.const) c empty + + (* The addition of a monomial *) + + let add : Monomial.t -> num -> t -> t = + fun mn v p -> + let vl = (get mn p) <+> v in + add mn vl p + + + (** Design choice: empty is not a polynomial + I do not remember why .... + **) + + (* The product by a monomial *) + let mult : Monomial.t -> num -> t -> t = + fun mn v p -> + fold (fun mn' v' res -> P.add (Monomial.prod mn mn') (v<*>v') res) p empty + + + let addition : t -> t -> t = + fun p1 p2 -> fold (fun mn v p -> add mn v p) p1 p2 + + + let product : t -> t -> t = + fun p1 p2 -> + fold (fun mn v res -> addition (mult mn v p2) res ) p1 empty + + + let uminus : t -> t = + fun p -> map (fun v -> minus_num v) p + + let fold = P.fold + + let compare = compare compare_num +end + +open Mutils +type 'a number_spec = { + bigint_to_number : big_int -> 'a; + number_to_num : 'a -> num; + zero : 'a; + unit : 'a; + mult : 'a -> 'a -> 'a; + eqb : 'a -> 'a -> Mc.bool +} + +let z_spec = { + bigint_to_number = Ml2C.bigint ; + number_to_num = (fun x -> Big_int (C2Ml.z_big_int x)); + zero = Mc.Z0; + unit = Mc.Zpos Mc.XH; + mult = Mc.zmult; + eqb = Mc.zeq_bool +} + + +let q_spec = { + bigint_to_number = (fun x -> {Mc.qnum = Ml2C.bigint x; Mc.qden = Mc.XH}); + number_to_num = C2Ml.q_to_num; + zero = {Mc.qnum = Mc.Z0;Mc.qden = Mc.XH}; + unit = {Mc.qnum = (Mc.Zpos Mc.XH) ; Mc.qden = Mc.XH}; + mult = Mc.qmult; + eqb = Mc.qeq_bool +} + +let r_spec = z_spec + + + + +let dev_form n_spec p = + let rec dev_form p = + match p with + | Mc.PEc z -> Poly.constant (n_spec.number_to_num z) + | Mc.PEX v -> Poly.variable v + | Mc.PEmul(p1,p2) -> + let p1 = dev_form p1 in + let p2 = dev_form p2 in + Poly.product p1 p2 + | Mc.PEadd(p1,p2) -> Poly.addition (dev_form p1) (dev_form p2) + | Mc.PEopp p -> Poly.uminus (dev_form p) + | Mc.PEsub(p1,p2) -> Poly.addition (dev_form p1) (Poly.uminus (dev_form p2)) + | Mc.PEpow(p,n) -> + let p = dev_form p in + let n = C2Ml.n n in + let rec pow n = + if n = 0 + then Poly.constant (n_spec.number_to_num n_spec.unit) + else Poly.product p (pow (n-1)) in + pow n in + dev_form p + + +let monomial_to_polynomial mn = + Monomial.fold + (fun v i acc -> + let mn = if i = 1 then Mc.PEX v else Mc.PEpow (Mc.PEX v ,Ml2C.n i) in + if acc = Mc.PEc (Mc.Zpos Mc.XH) + then mn + else Mc.PEmul(mn,acc)) + mn + (Mc.PEc (Mc.Zpos Mc.XH)) + +let list_to_polynomial vars l = + assert (List.for_all (fun x -> ceiling_num x =/ x) l); + let var x = monomial_to_polynomial (List.nth vars x) in + let rec xtopoly p i = function + | [] -> p + | c::l -> if c =/ (Int 0) then xtopoly p (i+1) l + else let c = Mc.PEc (Ml2C.bigint (numerator c)) in + let mn = + if c = Mc.PEc (Mc.Zpos Mc.XH) + then var i + else Mc.PEmul (c,var i) in + let p' = if p = Mc.PEc Mc.Z0 then mn else + Mc.PEadd (mn, p) in + xtopoly p' (i+1) l in + + xtopoly (Mc.PEc Mc.Z0) 0 l + +let rec fixpoint f x = + let y' = f x in + if y' = x then y' + else fixpoint f y' + + + + + + + + +let rec_simpl_cone n_spec e = + let simpl_cone = + Mc.simpl_cone n_spec.zero n_spec.unit n_spec.mult n_spec.eqb in + + let rec rec_simpl_cone = function + | Mc.S_Mult(t1, t2) -> + simpl_cone (Mc.S_Mult (rec_simpl_cone t1, rec_simpl_cone t2)) + | Mc.S_Add(t1,t2) -> + simpl_cone (Mc.S_Add (rec_simpl_cone t1, rec_simpl_cone t2)) + | x -> simpl_cone x in + rec_simpl_cone e + + +let simplify_cone n_spec c = fixpoint (rec_simpl_cone n_spec) c + +type cone_prod = + Const of cone + | Ideal of cone *cone + | Mult of cone * cone + | Other of cone +and cone = Mc.zWitness + + + +let factorise_linear_cone c = + + let rec cone_list c l = + match c with + | Mc.S_Add (x,r) -> cone_list r (x::l) + | _ -> c :: l in + + let factorise c1 c2 = + match c1 , c2 with + | Mc.S_Ideal(x,y) , Mc.S_Ideal(x',y') -> + if x = x' then Some (Mc.S_Ideal(x, Mc.S_Add(y,y'))) else None + | Mc.S_Mult(x,y) , Mc.S_Mult(x',y') -> + if x = x' then Some (Mc.S_Mult(x, Mc.S_Add(y,y'))) else None + | _ -> None in + + let rec rebuild_cone l pending = + match l with + | [] -> (match pending with + | None -> Mc.S_Z + | Some p -> p + ) + | e::l -> + (match pending with + | None -> rebuild_cone l (Some e) + | Some p -> (match factorise p e with + | None -> Mc.S_Add(p, rebuild_cone l (Some e)) + | Some f -> rebuild_cone l (Some f) ) + ) in + + (rebuild_cone (List.sort Pervasives.compare (cone_list c [])) None) + + + +(* The binding with Fourier might be a bit obsolete + -- how does it handle equalities ? *) + +(* Certificates are elements of the cone such that P = 0 *) + +(* To begin with, we search for certificates of the form: + a1.p1 + ... an.pn + b1.q1 +... + bn.qn + c = 0 + where pi >= 0 qi > 0 + ai >= 0 + bi >= 0 + Sum bi + c >= 1 + This is a linear problem: each monomial is considered as a variable. + Hence, we can use fourier. + + The variable c is at index 0 +*) + +open Mfourier + (*module Fourier = Fourier(Vector.VList)(SysSet(Vector.VList))*) + (*module Fourier = Fourier(Vector.VSparse)(SysSetAlt(Vector.VSparse))*) +module Fourier = Mfourier.Fourier(Vector.VSparse)(*(SysSetAlt(Vector.VMap))*) + +module Vect = Fourier.Vect +open Fourier.Cstr + +(* fold_left followed by a rev ! *) + +let constrain_monomial mn l = + let coeffs = List.fold_left (fun acc p -> (Poly.get mn p)::acc) [] l in + if mn = Monomial.const + then + { coeffs = Vect.from_list ((Big_int unit_big_int):: (List.rev coeffs)) ; + op = Eq ; + cst = Big_int zero_big_int } + else + { coeffs = Vect.from_list ((Big_int zero_big_int):: (List.rev coeffs)) ; + op = Eq ; + cst = Big_int zero_big_int } + + +let positivity l = + let rec xpositivity i l = + match l with + | [] -> [] + | (_,Mc.Equal)::l -> xpositivity (i+1) l + | (_,_)::l -> + {coeffs = Vect.update (i+1) (fun _ -> Int 1) Vect.null ; + op = Ge ; + cst = Int 0 } :: (xpositivity (i+1) l) + in + xpositivity 0 l + + +let string_of_op = function + | Mc.Strict -> "> 0" + | Mc.NonStrict -> ">= 0" + | Mc.Equal -> "= 0" + | Mc.NonEqual -> "<> 0" + + + +(* If the certificate includes at least one strict inequality, + the obtained polynomial can also be 0 *) +let build_linear_system l = + + (* Gather the monomials: HINT add up of the polynomials *) + let l' = List.map fst l in + let monomials = + List.fold_left (fun acc p -> Poly.addition p acc) (Poly.constant (Int 0)) l' + in (* For each monomial, compute a constraint *) + let s0 = + Poly.fold (fun mn _ res -> (constrain_monomial mn l')::res) monomials [] in + (* I need at least something strictly positive *) + let strict = { + coeffs = Vect.from_list ((Big_int unit_big_int):: + (List.map (fun (x,y) -> + match y with Mc.Strict -> + Big_int unit_big_int + | _ -> Big_int zero_big_int) l)); + op = Ge ; cst = Big_int unit_big_int } in + (* Add the positivity constraint *) + {coeffs = Vect.from_list ([Big_int unit_big_int]) ; + op = Ge ; + cst = Big_int zero_big_int}::(strict::(positivity l)@s0) + + +let big_int_to_z = Ml2C.bigint + +(* For Q, this is a pity that the certificate has been scaled + -- at a lower layer, certificates are using nums... *) +let make_certificate n_spec cert li = + let bint_to_cst = n_spec.bigint_to_number in + match cert with + | [] -> None + | e::cert' -> + let cst = match compare_big_int e zero_big_int with + | 0 -> Mc.S_Z + | 1 -> Mc.S_Pos (bint_to_cst e) + | _ -> failwith "positivity error" + in + let rec scalar_product cert l = + match cert with + | [] -> Mc.S_Z + | c::cert -> match l with + | [] -> failwith "make_certificate(1)" + | i::l -> + let r = scalar_product cert l in + match compare_big_int c zero_big_int with + | -1 -> Mc.S_Add ( + Mc.S_Ideal (Mc.PEc ( bint_to_cst c), Mc.S_In (Ml2C.nat i)), + r) + | 0 -> r + | _ -> Mc.S_Add ( + Mc.S_Mult (Mc.S_Pos (bint_to_cst c), Mc.S_In (Ml2C.nat i)), + r) in + + Some ((factorise_linear_cone + (simplify_cone n_spec (Mc.S_Add (cst, scalar_product cert' li))))) + + +exception Found of Monomial.t + +let raw_certificate l = + let sys = build_linear_system l in + try + match Fourier.find_point sys with + | None -> None + | Some cert -> Some (rats_to_ints (Vect.to_list cert)) + (* should not use rats_to_ints *) + with x -> + if debug + then (Printf.printf "raw certificate %s" (Printexc.to_string x); + flush stdout) ; + None + + +let simple_linear_prover to_constant l = + let (lc,li) = List.split l in + match raw_certificate lc with + | None -> None (* No certificate *) + | Some cert -> make_certificate to_constant cert li + + + +let linear_prover n_spec l = + let li = List.combine l (interval 0 (List.length l -1)) in + let (l1,l') = List.partition + (fun (x,_) -> if snd' x = Mc.NonEqual then true else false) li in + let l' = List.map + (fun (c,i) -> let (Mc.Pair(x,y)) = c in + match y with + Mc.NonEqual -> failwith "cannot happen" + | y -> ((dev_form n_spec x, y),i)) l' in + + simple_linear_prover n_spec l' + + +let linear_prover n_spec l = + try linear_prover n_spec l with + x -> (print_string (Printexc.to_string x); None) + +(* zprover.... *) + +(* I need to gather the set of variables ---> + Then go for fold + Once I have an interval, I need a certificate : 2 other fourier elims. + (I could probably get the certificate directly + as it is done in the fourier contrib.) +*) + +let make_linear_system l = + let l' = List.map fst l in + let monomials = List.fold_left (fun acc p -> Poly.addition p acc) + (Poly.constant (Int 0)) l' in + let monomials = Poly.fold + (fun mn _ l -> if mn = Monomial.const then l else mn::l) monomials [] in + (List.map (fun (c,op) -> + {coeffs = Vect.from_list (List.map (fun mn -> (Poly.get mn c)) monomials) ; + op = op ; + cst = minus_num ( (Poly.get Monomial.const c))}) l + ,monomials) + + +open Interval +let pplus x y = Mc.PEadd(x,y) +let pmult x y = Mc.PEmul(x,y) +let pconst x = Mc.PEc x +let popp x = Mc.PEopp x + +let debug = false + +(* keep track of enumerated vectors *) +let rec mem p x l = + match l with [] -> false | e::l -> if p x e then true else mem p x l + +let rec remove_assoc p x l = + match l with [] -> [] | e::l -> if p x (fst e) then + remove_assoc p x l else e::(remove_assoc p x l) + +let eq x y = Vect.compare x y = 0 + +(* Beurk... this code is a shame *) + +let rec zlinear_prover sys = xzlinear_prover [] sys + +and xzlinear_prover enum l : (Mc.proofTerm option) = + match linear_prover z_spec l with + | Some prf -> Some (Mc.RatProof prf) + | None -> + let ll = List.fold_right (fun (Mc.Pair(e,k)) r -> match k with + Mc.NonEqual -> r + | k -> (dev_form z_spec e , + match k with + | Mc.Strict | Mc.NonStrict -> Ge + (* Loss of precision -- weakness of fourier*) + | Mc.Equal -> Eq + | Mc.NonEqual -> failwith "Cannot happen") :: r) l [] in + + let (sys,var) = make_linear_system ll in + let res = + match Fourier.find_Q_interval sys with + | Some(i,x,j) -> if i =/ j + then Some(i,Vect.set x (Int 1) Vect.null,i) else None + | None -> None in + let res = match res with + | None -> + begin + let candidates = List.fold_right + (fun cstr acc -> + let gcd = Big_int (Vect.gcd cstr.coeffs) in + let vect = Vect.mul (Int 1 // gcd) cstr.coeffs in + if mem eq vect enum then acc + else ((vect,Fourier.optimise vect sys)::acc)) sys [] in + let candidates = List.fold_left (fun l (x,i) -> + match i with + None -> (x,Empty)::l + | Some i -> (x,i)::l) [] (candidates) in + match List.fold_left (fun (x1,i1) (x2,i2) -> + if smaller_itv i1 i2 + then (x1,i1) else (x2,i2)) (Vect.null,Itv(None,None)) candidates + with + | (i,Empty) -> None + | (x,Itv(Some i, Some j)) -> Some(i,x,j) + | (x,Point n) -> Some(n,x,n) + | x -> match Fourier.find_Q_interval sys with + | None -> None + | Some(i,x,j) -> + if i =/ j + then Some(i,Vect.set x (Int 1) Vect.null,i) + else None + end + | _ -> res in + + match res with + | Some (lb,e,ub) -> + let (lbn,lbd) = + (Ml2C.bigint (sub_big_int (numerator lb) unit_big_int), + Ml2C.bigint (denominator lb)) in + let (ubn,ubd) = + (Ml2C.bigint (add_big_int unit_big_int (numerator ub)) , + Ml2C.bigint (denominator ub)) in + let expr = list_to_polynomial var (Vect.to_list e) in + (match + (*x <= ub -> x > ub *) + linear_prover z_spec + (Mc.Pair(pplus (pmult (pconst ubd) expr) (popp (pconst ubn)), + Mc.NonStrict) :: l), + (* lb <= x -> lb > x *) + linear_prover z_spec + (Mc.Pair( pplus (popp (pmult (pconst lbd) expr)) (pconst lbn) , + Mc.NonStrict)::l) + with + | Some cub , Some clb -> + (match zlinear_enum (e::enum) expr + (ceiling_num lb) (floor_num ub) l + with + | None -> None + | Some prf -> + Some (Mc.EnumProof(Ml2C.q lb,expr,Ml2C.q ub,clb,cub,prf))) + | _ -> None + ) + | _ -> None +and xzlinear_enum enum expr clb cub l = + if clb >/ cub + then Some Mc.Nil + else + let pexpr = pplus (popp (pconst (Ml2C.bigint (numerator clb)))) expr in + let sys' = (Mc.Pair(pexpr, Mc.Equal))::l in + match xzlinear_prover enum sys' with + | None -> if debug then print_string "zlp?"; None + | Some prf -> if debug then print_string "zlp!"; + match zlinear_enum enum expr (clb +/ (Int 1)) cub l with + | None -> None + | Some prfl -> Some (Mc.Cons(prf,prfl)) + +and zlinear_enum enum expr clb cub l = + let res = xzlinear_enum enum expr clb cub l in + if debug then Printf.printf "zlinear_enum %s %s -> %s\n" + (string_of_num clb) + (string_of_num cub) + (match res with + | None -> "None" + | Some r -> "Some") ; res + diff --git a/contrib/micromega/coq_micromega.ml b/contrib/micromega/coq_micromega.ml new file mode 100644 index 00000000..29e2a183 --- /dev/null +++ b/contrib/micromega/coq_micromega.ml @@ -0,0 +1,1290 @@ +(************************************************************************) +(* 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 *) +(************************************************************************) +(* *) +(* Micromega: A reflexive tactic using the Positivstellensatz *) +(* *) +(* Frédéric Besson (Irisa/Inria) 2006-2008 *) +(* *) +(************************************************************************) + +open Mutils +let debug = false + +let time str f x = + let t0 = (Unix.times()).Unix.tms_utime in + let res = f x in + let t1 = (Unix.times()).Unix.tms_utime in + (*if debug then*) (Printf.printf "time %s %f\n" str (t1 -. t0) ; + flush stdout); + res + +type ('a,'b) formula = + | TT + | FF + | X of 'b + | A of 'a * Names.name + | C of ('a,'b) formula * ('a,'b) formula * Names.name + | D of ('a,'b) formula * ('a,'b) formula * Names.name + | N of ('a,'b) formula * Names.name + | I of ('a,'b) formula * ('a,'b) formula * Names.name + +let none = Names.Anonymous + +let tag_formula t f = + match f with + | A(x,_) -> A(x,t) + | C(x,y,_) -> C(x,y,t) + | D(x,y,_) -> D(x,y,t) + | N(x,_) -> N(x,t) + | I(x,y,_) -> I(x,y,t) + | _ -> f + +let tt = [] +let ff = [ [] ] + + +type ('constant,'contr) sentence = + ('constant Micromega.formula, 'contr) formula + +let cnf negate normalise f = + let negate a = + CoqToCaml.list (fun cl -> CoqToCaml.list (fun x -> x) cl) (negate a) in + + let normalise a = + CoqToCaml.list (fun cl -> CoqToCaml.list (fun x -> x) cl) (normalise a) in + + let and_cnf x y = x @ y in + let or_clause_cnf t f = List.map (fun x -> t@x ) f in + + let rec or_cnf f f' = + match f with + | [] -> tt + | e :: rst -> (or_cnf rst f') @ (or_clause_cnf e f') in + + let rec xcnf (pol : bool) f = + match f with + | TT -> if pol then tt else ff (* ?? *) + | FF -> if pol then ff else tt (* ?? *) + | X p -> if pol then ff else ff (* ?? *) + | A(x,t) -> if pol then normalise x else negate x + | N(e,t) -> xcnf (not pol) e + | C(e1,e2,t) -> + (if pol then and_cnf else or_cnf) (xcnf pol e1) (xcnf pol e2) + | D(e1,e2,t) -> + (if pol then or_cnf else and_cnf) (xcnf pol e1) (xcnf pol e2) + | I(e1,e2,t) -> + (if pol then or_cnf else and_cnf) (xcnf (not pol) e1) (xcnf pol e2) in + + xcnf true f + + + +module M = +struct + open Coqlib + open Term + (* let constant = gen_constant_in_modules "Omicron" coq_modules*) + + + let logic_dir = ["Coq";"Logic";"Decidable"] + let coq_modules = + init_modules @ + [logic_dir] @ arith_modules @ zarith_base_modules @ + [ ["Coq";"Lists";"List"]; + ["ZMicromega"]; + ["Tauto"]; + ["RingMicromega"]; + ["EnvRing"]; + ["Coq"; "micromega"; "ZMicromega"]; + ["Coq" ; "micromega" ; "Tauto"]; + ["Coq" ; "micromega" ; "RingMicromega"]; + ["Coq" ; "micromega" ; "EnvRing"]; + ["Coq";"QArith"; "QArith_base"]; + ["Coq";"Reals" ; "Rdefinitions"]; + ["LRing_normalise"]] + + let constant = gen_constant_in_modules "ZMicromega" coq_modules + + let coq_and = lazy (constant "and") + let coq_or = lazy (constant "or") + let coq_not = lazy (constant "not") + let coq_iff = lazy (constant "iff") + let coq_True = lazy (constant "True") + let coq_False = lazy (constant "False") + + let coq_cons = lazy (constant "cons") + let coq_nil = lazy (constant "nil") + let coq_list = lazy (constant "list") + + let coq_O = lazy (constant "O") + let coq_S = lazy (constant "S") + let coq_nat = lazy (constant "nat") + + let coq_NO = lazy + (gen_constant_in_modules "N" [ ["Coq";"NArith";"BinNat" ]] "N0") + let coq_Npos = lazy + (gen_constant_in_modules "N" [ ["Coq";"NArith"; "BinNat"]] "Npos") + (* let coq_n = lazy (constant "N")*) + + let coq_pair = lazy (constant "pair") + let coq_None = lazy (constant "None") + let coq_option = lazy (constant "option") + let coq_positive = lazy (constant "positive") + let coq_xH = lazy (constant "xH") + let coq_xO = lazy (constant "xO") + let coq_xI = lazy (constant "xI") + + let coq_N0 = lazy (constant "N0") + let coq_N0 = lazy (constant "Npos") + + + let coq_Z = lazy (constant "Z") + let coq_Q = lazy (constant "Q") + let coq_R = lazy (constant "R") + + let coq_ZERO = lazy (constant "Z0") + let coq_POS = lazy (constant "Zpos") + let coq_NEG = lazy (constant "Zneg") + + let coq_QWitness = lazy + (gen_constant_in_modules "QMicromega" + [["Coq"; "micromega"; "QMicromega"]] "QWitness") + let coq_ZWitness = lazy + (gen_constant_in_modules "QMicromega" + [["Coq"; "micromega"; "ZMicromega"]] "ZWitness") + + + let coq_Build_Witness = lazy (constant "Build_Witness") + + + let coq_Qmake = lazy (constant "Qmake") + + let coq_proofTerm = lazy (constant "ProofTerm") + let coq_ratProof = lazy (constant "RatProof") + let coq_cutProof = lazy (constant "CutProof") + let coq_enumProof = lazy (constant "EnumProof") + + let coq_Zgt = lazy (constant "Zgt") + let coq_Zge = lazy (constant "Zge") + let coq_Zle = lazy (constant "Zle") + let coq_Zlt = lazy (constant "Zlt") + let coq_Eq = lazy (constant "eq") + + let coq_Zplus = lazy (constant "Zplus") + let coq_Zminus = lazy (constant "Zminus") + let coq_Zopp = lazy (constant "Zopp") + let coq_Zmult = lazy (constant "Zmult") + let coq_N_of_Z = lazy + (gen_constant_in_modules "ZArithRing" + [["Coq";"setoid_ring";"ZArithRing"]] "N_of_Z") + + + let coq_PEX = lazy (constant "PEX" ) + let coq_PEc = lazy (constant"PEc") + let coq_PEadd = lazy (constant "PEadd") + let coq_PEopp = lazy (constant "PEopp") + let coq_PEmul = lazy (constant "PEmul") + let coq_PEsub = lazy (constant "PEsub") + let coq_PEpow = lazy (constant "PEpow") + + + let coq_OpEq = lazy (constant "OpEq") + let coq_OpNEq = lazy (constant "OpNEq") + let coq_OpLe = lazy (constant "OpLe") + let coq_OpLt = lazy (constant "OpLt") + let coq_OpGe = lazy (constant "OpGe") + let coq_OpGt = lazy (constant "OpGt") + + + let coq_S_In = lazy (constant "S_In") + let coq_S_Square = lazy (constant "S_Square") + let coq_S_Monoid = lazy (constant "S_Monoid") + let coq_S_Ideal = lazy (constant "S_Ideal") + let coq_S_Mult = lazy (constant "S_Mult") + let coq_S_Add = lazy (constant "S_Add") + let coq_S_Pos = lazy (constant "S_Pos") + let coq_S_Z = lazy (constant "S_Z") + let coq_coneMember = lazy (constant "coneMember") + + + let coq_make_impl = lazy + (gen_constant_in_modules "Zmicromega" [["Refl"]] "make_impl") + let coq_make_conj = lazy + (gen_constant_in_modules "Zmicromega" [["Refl"]] "make_conj") + + let coq_Build = lazy + (gen_constant_in_modules "RingMicromega" + [["Coq" ; "micromega" ; "RingMicromega"] ; ["RingMicromega"] ] + "Build_Formula") + let coq_Cstr = lazy + (gen_constant_in_modules "RingMicromega" + [["Coq" ; "micromega" ; "RingMicromega"] ; ["RingMicromega"] ] "Formula") + + type parse_error = + | Ukn + | BadStr of string + | BadNum of int + | BadTerm of Term.constr + | Msg of string + | Goal of (Term.constr list ) * Term.constr * parse_error + + let string_of_error = function + | Ukn -> "ukn" + | BadStr s -> s + | BadNum i -> string_of_int i + | BadTerm _ -> "BadTerm" + | Msg s -> s + | Goal _ -> "Goal" + + + exception ParseError + + + + + let get_left_construct term = + match Term.kind_of_term term with + | Term.Construct(_,i) -> (i,[| |]) + | Term.App(l,rst) -> + (match Term.kind_of_term l with + | Term.Construct(_,i) -> (i,rst) + | _ -> raise ParseError + ) + | _ -> raise ParseError + + module Mc = Micromega + + let rec parse_nat term = + let (i,c) = get_left_construct term in + match i with + | 1 -> Mc.O + | 2 -> Mc.S (parse_nat (c.(0))) + | i -> raise ParseError + + + let pp_nat o n = Printf.fprintf o "%i" (CoqToCaml.nat n) + + + let rec dump_nat x = + match x with + | Mc.O -> Lazy.force coq_O + | Mc.S p -> Term.mkApp(Lazy.force coq_S,[| dump_nat p |]) + + + let rec parse_positive term = + let (i,c) = get_left_construct term in + match i with + | 1 -> Mc.XI (parse_positive c.(0)) + | 2 -> Mc.XO (parse_positive c.(0)) + | 3 -> Mc.XH + | i -> raise ParseError + + + let rec dump_positive x = + match x with + | Mc.XH -> Lazy.force coq_xH + | Mc.XO p -> Term.mkApp(Lazy.force coq_xO,[| dump_positive p |]) + | Mc.XI p -> Term.mkApp(Lazy.force coq_xI,[| dump_positive p |]) + + let pp_positive o x = Printf.fprintf o "%i" (CoqToCaml.positive x) + + + let rec dump_n x = + match x with + | Mc.N0 -> Lazy.force coq_N0 + | Mc.Npos p -> Term.mkApp(Lazy.force coq_Npos,[| dump_positive p|]) + + let rec dump_index x = + match x with + | Mc.XH -> Lazy.force coq_xH + | Mc.XO p -> Term.mkApp(Lazy.force coq_xO,[| dump_index p |]) + | Mc.XI p -> Term.mkApp(Lazy.force coq_xI,[| dump_index p |]) + + + let pp_index o x = Printf.fprintf o "%i" (CoqToCaml.index x) + + let rec dump_n x = + match x with + | Mc.N0 -> Lazy.force coq_NO + | Mc.Npos p -> Term.mkApp(Lazy.force coq_Npos,[| dump_positive p |]) + + let rec pp_n o x = output_string o (string_of_int (CoqToCaml.n x)) + + let dump_pair t1 t2 dump_t1 dump_t2 (Mc.Pair (x,y)) = + Term.mkApp(Lazy.force coq_pair,[| t1 ; t2 ; dump_t1 x ; dump_t2 y|]) + + + let rec parse_z term = + let (i,c) = get_left_construct term in + match i with + | 1 -> Mc.Z0 + | 2 -> Mc.Zpos (parse_positive c.(0)) + | 3 -> Mc.Zneg (parse_positive c.(0)) + | i -> raise ParseError + + let dump_z x = + match x with + | Mc.Z0 ->Lazy.force coq_ZERO + | Mc.Zpos p -> Term.mkApp(Lazy.force coq_POS,[| dump_positive p|]) + | Mc.Zneg p -> Term.mkApp(Lazy.force coq_NEG,[| dump_positive p|]) + + let pp_z o x = Printf.fprintf o "%i" (CoqToCaml.z x) + +let dump_num bd1 = + Term.mkApp(Lazy.force coq_Qmake, + [|dump_z (CamlToCoq.bigint (numerator bd1)) ; + dump_positive (CamlToCoq.positive_big_int (denominator bd1)) |]) + + +let dump_q q = + Term.mkApp(Lazy.force coq_Qmake, + [| dump_z q.Micromega.qnum ; dump_positive q.Micromega.qden|]) + +let parse_q term = + match Term.kind_of_term term with + | Term.App(c, args) -> + ( + match Term.kind_of_term c with + Term.Construct((n,j),i) -> + if Names.string_of_kn n = "Coq.QArith.QArith_base#<>#Q" + then {Mc.qnum = parse_z args.(0) ; Mc.qden = parse_positive args.(1) } + else raise ParseError + | _ -> raise ParseError + ) + | _ -> raise ParseError + + let rec parse_list parse_elt term = + let (i,c) = get_left_construct term in + match i with + | 1 -> Mc.Nil + | 2 -> Mc.Cons(parse_elt c.(1), parse_list parse_elt c.(2)) + | i -> raise ParseError + + + let rec dump_list typ dump_elt l = + match l with + | Mc.Nil -> Term.mkApp(Lazy.force coq_nil,[| typ |]) + | Mc.Cons(e,l) -> Term.mkApp(Lazy.force coq_cons, + [| typ; dump_elt e;dump_list typ dump_elt l|]) + + let rec dump_ml_list typ dump_elt l = + match l with + | [] -> Term.mkApp(Lazy.force coq_nil,[| typ |]) + | e::l -> Term.mkApp(Lazy.force coq_cons, + [| typ; dump_elt e;dump_ml_list typ dump_elt l|]) + + + + let pp_list op cl elt o l = + let rec _pp o l = + match l with + | Mc.Nil -> () + | Mc.Cons(e,Mc.Nil) -> Printf.fprintf o "%a" elt e + | Mc.Cons(e,l) -> Printf.fprintf o "%a ,%a" elt e _pp l in + Printf.fprintf o "%s%a%s" op _pp l cl + + + + let pp_var = pp_positive + let dump_var = dump_positive + + let rec pp_expr o e = + match e with + | Mc.PEX n -> Printf.fprintf o "V %a" pp_var n + | Mc.PEc z -> pp_z o z + | Mc.PEadd(e1,e2) -> Printf.fprintf o "(%a)+(%a)" pp_expr e1 pp_expr e2 + | Mc.PEmul(e1,e2) -> Printf.fprintf o "%a*(%a)" pp_expr e1 pp_expr e2 + | Mc.PEopp e -> Printf.fprintf o "-(%a)" pp_expr e + | Mc.PEsub(e1,e2) -> Printf.fprintf o "(%a)-(%a)" pp_expr e1 pp_expr e2 + | Mc.PEpow(e,n) -> Printf.fprintf o "(%a)^(%a)" pp_expr e pp_n n + + + let dump_expr typ dump_z e = + let rec dump_expr e = + match e with + | Mc.PEX n -> mkApp(Lazy.force coq_PEX,[| typ; dump_var n |]) + | Mc.PEc z -> mkApp(Lazy.force coq_PEc,[| typ ; dump_z z |]) + | Mc.PEadd(e1,e2) -> mkApp(Lazy.force coq_PEadd, + [| typ; dump_expr e1;dump_expr e2|]) + | Mc.PEsub(e1,e2) -> mkApp(Lazy.force coq_PEsub, + [| typ; dump_expr e1;dump_expr e2|]) + | Mc.PEopp e -> mkApp(Lazy.force coq_PEopp, + [| typ; dump_expr e|]) + | Mc.PEmul(e1,e2) -> mkApp(Lazy.force coq_PEmul, + [| typ; dump_expr e1;dump_expr e2|]) + | Mc.PEpow(e,n) -> mkApp(Lazy.force coq_PEpow, + [| typ; dump_expr e; dump_n n|]) + in + dump_expr e + + let rec dump_monoid l = dump_list (Lazy.force coq_nat) dump_nat l + + let rec dump_cone typ dump_z e = + let z = Lazy.force typ in + let rec dump_cone e = + match e with + | Mc.S_In n -> mkApp(Lazy.force coq_S_In,[| z; dump_nat n |]) + | Mc.S_Ideal(e,c) -> mkApp(Lazy.force coq_S_Ideal, + [| z; dump_expr z dump_z e ; dump_cone c |]) + | Mc.S_Square e -> mkApp(Lazy.force coq_S_Square, + [| z;dump_expr z dump_z e|]) + | Mc.S_Monoid l -> mkApp (Lazy.force coq_S_Monoid, + [|z; dump_monoid l|]) + | Mc.S_Add(e1,e2) -> mkApp(Lazy.force coq_S_Add, + [| z; dump_cone e1; dump_cone e2|]) + | Mc.S_Mult(e1,e2) -> mkApp(Lazy.force coq_S_Mult, + [| z; dump_cone e1; dump_cone e2|]) + | Mc.S_Pos p -> mkApp(Lazy.force coq_S_Pos,[| z; dump_z p|]) + | Mc.S_Z -> mkApp( Lazy.force coq_S_Z,[| z|]) in + dump_cone e + + + let pp_cone pp_z o e = + let rec pp_cone o e = + match e with + | Mc.S_In n -> + Printf.fprintf o "(S_In %a)%%nat" pp_nat n + | Mc.S_Ideal(e,c) -> + Printf.fprintf o "(S_Ideal %a %a)" pp_expr e pp_cone c + | Mc.S_Square e -> + Printf.fprintf o "(S_Square %a)" pp_expr e + | Mc.S_Monoid l -> + Printf.fprintf o "(S_Monoid %a)" (pp_list "[" "]" pp_nat) l + | Mc.S_Add(e1,e2) -> + Printf.fprintf o "(S_Add %a %a)" pp_cone e1 pp_cone e2 + | Mc.S_Mult(e1,e2) -> + Printf.fprintf o "(S_Mult %a %a)" pp_cone e1 pp_cone e2 + | Mc.S_Pos p -> + Printf.fprintf o "(S_Pos %a)%%positive" pp_z p + | Mc.S_Z -> + Printf.fprintf o "S_Z" in + pp_cone o e + + + + + let rec parse_op term = + let (i,c) = get_left_construct term in + match i with + | 1 -> Mc.OpEq + | 2 -> Mc.OpLe + | 3 -> Mc.OpGe + | 4 -> Mc.OpGt + | 5 -> Mc.OpLt + | i -> raise ParseError + + + let rec dump_op = function + | Mc.OpEq-> Lazy.force coq_OpEq + | Mc.OpNEq-> Lazy.force coq_OpNEq + | Mc.OpLe -> Lazy.force coq_OpLe + | Mc.OpGe -> Lazy.force coq_OpGe + | Mc.OpGt-> Lazy.force coq_OpGt + | Mc.OpLt-> Lazy.force coq_OpLt + + + + let pp_op o e= + match e with + | Mc.OpEq-> Printf.fprintf o "=" + | Mc.OpNEq-> Printf.fprintf o "<>" + | Mc.OpLe -> Printf.fprintf o "=<" + | Mc.OpGe -> Printf.fprintf o ">=" + | Mc.OpGt-> Printf.fprintf o ">" + | Mc.OpLt-> Printf.fprintf o "<" + + + + + let pp_cstr o {Mc.flhs = l ; Mc.fop = op ; Mc.frhs = r } = + Printf.fprintf o"(%a %a %a)" pp_expr l pp_op op pp_expr r + + let dump_cstr typ dump_constant {Mc.flhs = e1 ; Mc.fop = o ; Mc.frhs = e2} = + Term.mkApp(Lazy.force coq_Build, + [| typ; dump_expr typ dump_constant e1 ; + dump_op o ; + dump_expr typ dump_constant e2|]) + + + + let parse_zop (op,args) = + match kind_of_term op with + | Const x -> + (match Names.string_of_con x with + | "Coq.ZArith.BinInt#<>#Zgt" -> (Mc.OpGt, args.(0), args.(1)) + | "Coq.ZArith.BinInt#<>#Zge" -> (Mc.OpGe, args.(0), args.(1)) + | "Coq.ZArith.BinInt#<>#Zlt" -> (Mc.OpLt, args.(0), args.(1)) + | "Coq.ZArith.BinInt#<>#Zle" -> (Mc.OpLe, args.(0), args.(1)) + (*| "Coq.Init.Logic#<>#not" -> Mc.OpNEq (* for backward compat *)*) + | s -> raise ParseError + ) + | Ind(n,0) -> + (match Names.string_of_kn n with + | "Coq.Init.Logic#<>#eq" -> + if args.(0) <> Lazy.force coq_Z + then raise ParseError + else (Mc.OpEq, args.(1), args.(2)) + | _ -> raise ParseError) + | _ -> failwith "parse_zop" + + + let parse_rop (op,args) = + try + match kind_of_term op with + | Const x -> + (match Names.string_of_con x with + | "Coq.Reals.Rdefinitions#<>#Rgt" -> (Mc.OpGt, args.(0), args.(1)) + | "Coq.Reals.Rdefinitions#<>#Rge" -> (Mc.OpGe, args.(0), args.(1)) + | "Coq.Reals.Rdefinitions#<>#Rlt" -> (Mc.OpLt, args.(0), args.(1)) + | "Coq.Reals.Rdefinitions#<>#Rle" -> (Mc.OpLe, args.(0), args.(1)) + (*| "Coq.Init.Logic#<>#not"-> Mc.OpNEq (* for backward compat *)*) + | s -> raise ParseError + ) + | Ind(n,0) -> + (match Names.string_of_kn n with + | "Coq.Init.Logic#<>#eq" -> + (* if args.(0) <> Lazy.force coq_R + then raise ParseError + else*) (Mc.OpEq, args.(1), args.(2)) + | _ -> raise ParseError) + | _ -> failwith "parse_rop" + with x -> + (Pp.pp (Pp.str "parse_rop failure ") ; + Pp.pp (Printer.prterm op) ; Pp.pp_flush ()) + ; raise x + + + let parse_qop (op,args) = + ( + (match kind_of_term op with + | Const x -> + (match Names.string_of_con x with + | "Coq.QArith.QArith_base#<>#Qgt" -> Mc.OpGt + | "Coq.QArith.QArith_base#<>#Qge" -> Mc.OpGe + | "Coq.QArith.QArith_base#<>#Qlt" -> Mc.OpLt + | "Coq.QArith.QArith_base#<>#Qle" -> Mc.OpLe + | "Coq.QArith.QArith_base#<>#Qeq" -> Mc.OpEq + | s -> raise ParseError + ) + | _ -> failwith "parse_zop") , args.(0) , args.(1)) + + + module Env = + struct + type t = constr list + + let compute_rank_add env v = + let rec _add env n v = + match env with + | [] -> ([v],n) + | e::l -> + if eq_constr e v + then (env,n) + else + let (env,n) = _add l ( n+1) v in + (e::env,n) in + let (env, n) = _add env 1 v in + (env, CamlToCoq.idx n) + + + let empty = [] + + let elements env = env + + end + + + let is_constant t = (* This is an approx *) + match kind_of_term t with + | Construct(i,_) -> true + | _ -> false + + + type 'a op = + | Binop of ('a Mc.pExpr -> 'a Mc.pExpr -> 'a Mc.pExpr) + | Opp + | Power + | Ukn of string + + + let parse_expr parse_constant parse_exp ops_spec env term = + if debug + then (Pp.pp (Pp.str "parse_expr: "); + Pp.pp_flush ();Pp.pp (Printer.prterm term); Pp.pp_flush ()); + + let constant_or_variable env term = + try + ( Mc.PEc (parse_constant term) , env) + with ParseError -> + let (env,n) = Env.compute_rank_add env term in + (Mc.PEX n , env) in + + let rec parse_expr env term = + let combine env op (t1,t2) = + let (expr1,env) = parse_expr env t1 in + let (expr2,env) = parse_expr env t2 in + (op expr1 expr2,env) in + match kind_of_term term with + | App(t,args) -> + ( + match kind_of_term t with + | Const c -> + ( match ops_spec (Names.string_of_con c) with + | Binop f -> combine env f (args.(0),args.(1)) + | Opp -> let (expr,env) = parse_expr env args.(0) in + (Mc.PEopp expr, env) + | Power -> + let (expr,env) = parse_expr env args.(0) in + let exp = (parse_exp args.(1)) in + (Mc.PEpow(expr, exp) , env) + | Ukn s -> + if debug + then (Printf.printf "unknown op: %s\n" s; flush stdout;); + let (env,n) = Env.compute_rank_add env term in (Mc.PEX n, env) + ) + | _ -> constant_or_variable env term + ) + | _ -> constant_or_variable env term in + parse_expr env term + + +let zop_spec = function + | "Coq.ZArith.BinInt#<>#Zplus" -> Binop (fun x y -> Mc.PEadd(x,y)) + | "Coq.ZArith.BinInt#<>#Zminus" -> Binop (fun x y -> Mc.PEsub(x,y)) + | "Coq.ZArith.BinInt#<>#Zmult" -> Binop (fun x y -> Mc.PEmul (x,y)) + | "Coq.ZArith.BinInt#<>#Zopp" -> Opp + | "Coq.ZArith.Zpow_def#<>#Zpower" -> Power + | s -> Ukn s + +let qop_spec = function + | "Coq.QArith.QArith_base#<>#Qplus" -> Binop (fun x y -> Mc.PEadd(x,y)) + | "Coq.QArith.QArith_base#<>#Qminus" -> Binop (fun x y -> Mc.PEsub(x,y)) + | "Coq.QArith.QArith_base#<>#Qmult" -> Binop (fun x y -> Mc.PEmul (x,y)) + | "Coq.QArith.QArith_base#<>#Qopp" -> Opp + | "Coq.QArith.QArith_base#<>#Qpower" -> Power + | s -> Ukn s + +let rop_spec = function + | "Coq.Reals.Rdefinitions#<>#Rplus" -> Binop (fun x y -> Mc.PEadd(x,y)) + | "Coq.Reals.Rdefinitions#<>#Rminus" -> Binop (fun x y -> Mc.PEsub(x,y)) + | "Coq.Reals.Rdefinitions#<>#Rmult" -> Binop (fun x y -> Mc.PEmul (x,y)) + | "Coq.Reals.Rdefinitions#<>#Ropp" -> Opp + | "Coq.Reals.Rpow_def#<>#pow" -> Power + | s -> Ukn s + + + + + +let zconstant = parse_z +let qconstant = parse_q + + +let rconstant term = + if debug + then (Pp.pp_flush (); + Pp.pp (Pp.str "rconstant: "); + Pp.pp (Printer.prterm term); Pp.pp_flush ()); + match Term.kind_of_term term with + | Const x -> + (match Names.string_of_con x with + | "Coq.Reals.Rdefinitions#<>#R0" -> Mc.Z0 + | "Coq.Reals.Rdefinitions#<>#R1" -> Mc.Zpos Mc.XH + | _ -> raise ParseError + ) + | _ -> raise ParseError + + +let parse_zexpr = + parse_expr zconstant (fun x -> Mc.n_of_Z (parse_z x)) zop_spec +let parse_qexpr = + parse_expr qconstant (fun x -> Mc.n_of_Z (parse_z x)) qop_spec +let parse_rexpr = + parse_expr rconstant (fun x -> Mc.n_of_nat (parse_nat x)) rop_spec + + + let parse_arith parse_op parse_expr env cstr = + if debug + then (Pp.pp_flush (); + Pp.pp (Pp.str "parse_arith: "); + Pp.pp (Printer.prterm cstr); + Pp.pp_flush ()); + match kind_of_term cstr with + | App(op,args) -> + let (op,lhs,rhs) = parse_op (op,args) in + let (e1,env) = parse_expr env lhs in + let (e2,env) = parse_expr env rhs in + ({Mc.flhs = e1; Mc.fop = op;Mc.frhs = e2},env) + | _ -> failwith "error : parse_arith(2)" + + let parse_zarith = parse_arith parse_zop parse_zexpr + + let parse_qarith = parse_arith parse_qop parse_qexpr + + let parse_rarith = parse_arith parse_rop parse_rexpr + + + (* generic parsing of arithmetic expressions *) + + let rec parse_conj parse_arith env term = + match kind_of_term term with + | App(l,rst) -> + (match kind_of_term l with + | Ind (n,_) -> + ( match Names.string_of_kn n with + | "Coq.Init.Logic#<>#and" -> + let (e1,env) = parse_arith env rst.(0) in + let (e2,env) = parse_conj parse_arith env rst.(1) in + (Mc.Cons(e1,e2),env) + | _ -> (* This might be an equality *) + let (e,env) = parse_arith env term in + (Mc.Cons(e,Mc.Nil),env)) + | _ -> (* This is an arithmetic expression *) + let (e,env) = parse_arith env term in + (Mc.Cons(e,Mc.Nil),env)) + | _ -> failwith "parse_conj(2)" + + + + let rec f2f = function + | TT -> Mc.TT + | FF -> Mc.FF + | X _ -> Mc.X + | A (x,_) -> Mc.A x + | C (a,b,_) -> Mc.Cj(f2f a,f2f b) + | D (a,b,_) -> Mc.D(f2f a,f2f b) + | N (a,_) -> Mc.N(f2f a) + | I(a,b,_) -> Mc.I(f2f a,f2f b) + + let is_prop t = + match t with + | Names.Anonymous -> true (* Not quite right *) + | Names.Name x -> false + + let mkC f1 f2 = C(f1,f2,none) + let mkD f1 f2 = D(f1,f2,none) + let mkIff f1 f2 = C(I(f1,f2,none),I(f2,f2,none),none) + let mkI f1 f2 = I(f1,f2,none) + + let mkformula_binary g term f1 f2 = + match f1 , f2 with + | X _ , X _ -> X(term) + | _ -> g f1 f2 + + let parse_formula parse_atom env term = + let parse_atom env t = try let (at,env) = parse_atom env t in (A(at,none), env) with _ -> (X(t),env) in + + let rec xparse_formula env term = + match kind_of_term term with + | App(l,rst) -> + (match rst with + | [|a;b|] when l = Lazy.force coq_and -> + let f,env = xparse_formula env a in + let g,env = xparse_formula env b in + mkformula_binary mkC term f g,env + | [|a;b|] when l = Lazy.force coq_or -> + let f,env = xparse_formula env a in + let g,env = xparse_formula env b in + mkformula_binary mkD term f g,env + | [|a|] when l = Lazy.force coq_not -> + let (f,env) = xparse_formula env a in (N(f,none), env) + | [|a;b|] when l = Lazy.force coq_iff -> + let f,env = xparse_formula env a in + let g,env = xparse_formula env b in + mkformula_binary mkIff term f g,env + | _ -> parse_atom env term) + | Prod(typ,a,b) when not (Termops.dependent (mkRel 1) b) -> + let f,env = xparse_formula env a in + let g,env = xparse_formula env b in + mkformula_binary mkI term f g,env + | _ when term = Lazy.force coq_True -> (TT,env) + | _ when term = Lazy.force coq_False -> (FF,env) + | _ -> X(term),env in + xparse_formula env term + + let coq_TT = lazy + (gen_constant_in_modules "ZMicromega" + [["Coq" ; "micromega" ; "Tauto"];["Tauto"]] "TT") + let coq_FF = lazy + (gen_constant_in_modules "ZMicromega" + [["Coq" ; "micromega" ; "Tauto"];["Tauto"]] "FF") + let coq_And = lazy + (gen_constant_in_modules "ZMicromega" + [["Coq" ; "micromega" ; "Tauto"];["Tauto"]] "Cj") + let coq_Or = lazy + (gen_constant_in_modules "ZMicromega" + [["Coq" ; "micromega" ; "Tauto"];["Tauto"]] "D") + let coq_Neg = lazy + (gen_constant_in_modules "ZMicromega" + [["Coq" ; "micromega" ; "Tauto"];["Tauto"]] "N") + let coq_Atom = lazy + (gen_constant_in_modules "ZMicromega" + [["Coq" ; "micromega" ; "Tauto"];["Tauto"]] "A") + let coq_X = lazy + (gen_constant_in_modules "ZMicromega" + [["Coq" ; "micromega" ; "Tauto"];["Tauto"]] "X") + let coq_Impl = lazy + (gen_constant_in_modules "ZMicromega" + [["Coq" ; "micromega" ; "Tauto"];["Tauto"]] "I") + let coq_Formula = lazy + (gen_constant_in_modules "ZMicromega" + [["Coq" ; "micromega" ; "Tauto"];["Tauto"]] "BFormula") + + let dump_formula typ dump_atom f = + let rec xdump f = + match f with + | TT -> mkApp(Lazy.force coq_TT,[| typ|]) + | FF -> mkApp(Lazy.force coq_FF,[| typ|]) + | C(x,y,_) -> mkApp(Lazy.force coq_And,[| typ ; xdump x ; xdump y|]) + | D(x,y,_) -> mkApp(Lazy.force coq_Or,[| typ ; xdump x ; xdump y|]) + | I(x,y,_) -> mkApp(Lazy.force coq_Impl,[| typ ; xdump x ; xdump y|]) + | N(x,_) -> mkApp(Lazy.force coq_Neg,[| typ ; xdump x|]) + | A(x,_) -> mkApp(Lazy.force coq_Atom,[| typ ; dump_atom x|]) + | X(t) -> mkApp(Lazy.force coq_X,[| typ ; t|]) in + + xdump f + + + (* Backward compat *) + + let rec parse_concl parse_arith env term = + match kind_of_term term with + | Prod(_,expr,rst) -> (* a -> b *) + let (lhs,rhs,env) = parse_concl parse_arith env rst in + let (e,env) = parse_arith env expr in + (Mc.Cons(e,lhs),rhs,env) + | App(_,_) -> + let (conj, env) = parse_conj parse_arith env term in + (Mc.Nil,conj,env) + | Ind(n,_) -> + (match (Names.string_of_kn n) with + | "Coq.Init.Logic#<>#False" -> (Mc.Nil,Mc.Nil,env) + | s -> + print_string s ; flush stdout; + failwith "parse_concl") + | _ -> failwith "parse_concl" + + + let rec parse_hyps parse_arith env goal_hyps hyps = + match hyps with + | [] -> ([],goal_hyps,env) + | (i,t)::l -> + let (li,lt,env) = parse_hyps parse_arith env goal_hyps l in + try + let (c,env) = parse_arith env t in + (i::li, Mc.Cons(c,lt), env) + with x -> + (*(if debug then Printf.printf "parse_arith : %s\n" x);*) + (li,lt,env) + + + let parse_goal parse_arith env hyps term = + try + let (lhs,rhs,env) = parse_concl parse_arith env term in + let (li,lt,env) = parse_hyps parse_arith env lhs hyps in + (li,lt,rhs,env) + with Failure x -> raise ParseError + (* backward compat *) + + + (* ! reverse the list of bindings *) + let set l concl = + let rec _set acc = function + | [] -> acc + | (e::l) -> + let (name,expr,typ) = e in + _set (Term.mkNamedLetIn + (Names.id_of_string name) + expr typ acc) l in + _set concl l + + +end + +open M + + +let rec sig_of_cone = function + | Mc.S_In n -> [CoqToCaml.nat n] + | Mc.S_Ideal(e,w) -> sig_of_cone w + | Mc.S_Mult(w1,w2) -> + (sig_of_cone w1)@(sig_of_cone w2) + | Mc.S_Add(w1,w2) -> (sig_of_cone w1)@(sig_of_cone w2) + | _ -> [] + +let same_proof sg cl1 cl2 = + let cl1 = CoqToCaml.list (fun x -> x) cl1 in + let cl2 = CoqToCaml.list (fun x -> x) cl2 in + let rec xsame_proof sg = + match sg with + | [] -> true + | n::sg -> (try List.nth cl1 n = List.nth cl2 n with _ -> false) + && (xsame_proof sg ) in + xsame_proof sg + + + + +let tags_of_clause tgs wit clause = + let rec xtags tgs = function + | Mc.S_In n -> Names.Idset.union tgs + (snd (List.nth clause (CoqToCaml.nat n) )) + | Mc.S_Ideal(e,w) -> xtags tgs w + | Mc.S_Mult (w1,w2) | Mc.S_Add(w1,w2) -> xtags (xtags tgs w1) w2 + | _ -> tgs in + xtags tgs wit + +let tags_of_cnf wits cnf = + List.fold_left2 (fun acc w cl -> tags_of_clause acc w cl) + Names.Idset.empty wits cnf + + +let find_witness prover polys1 = + let l = CoqToCaml.list (fun x -> x) polys1 in + try_any prover l + +let rec witness prover l1 l2 = + match l2 with + | Micromega.Nil -> Some (Micromega.Nil) + | Micromega.Cons(e,l2) -> + match find_witness prover (Micromega.Cons( e,l1)) with + | None -> None + | Some w -> + (match witness prover l1 l2 with + | None -> None + | Some l -> Some (Micromega.Cons (w,l)) + ) + + +let rec apply_ids t ids = + match ids with + | [] -> t + | i::ids -> apply_ids (Term.mkApp(t,[| Term.mkVar i |])) ids + + +let coq_Node = lazy + (Coqlib.gen_constant_in_modules "VarMap" + [["Coq" ; "micromega" ; "VarMap"];["VarMap"]] "Node") +let coq_Leaf = lazy + (Coqlib.gen_constant_in_modules "VarMap" + [["Coq" ; "micromega" ; "VarMap"];["VarMap"]] "Leaf") +let coq_Empty = lazy + (Coqlib.gen_constant_in_modules "VarMap" + [["Coq" ; "micromega" ;"VarMap"];["VarMap"]] "Empty") + + +let btree_of_array typ a = + let size_of_a = Array.length a in + let semi_size_of_a = size_of_a lsr 1 in + let node = Lazy.force coq_Node + and leaf = Lazy.force coq_Leaf + and empty = Term.mkApp (Lazy.force coq_Empty, [| typ |]) in + let rec aux n = + if n > size_of_a + then empty + else if n > semi_size_of_a + then Term.mkApp (leaf, [| typ; a.(n-1) |]) + else Term.mkApp (node, [| typ; aux (2*n); a.(n-1); aux (2*n+1) |]) + in + aux 1 + +let btree_of_array typ a = + try + btree_of_array typ a + with x -> + failwith (Printf.sprintf "btree of array : %s" (Printexc.to_string x)) + +let dump_varmap typ env = + btree_of_array typ (Array.of_list env) + + +let rec pp_varmap o vm = + match vm with + | Mc.Empty -> output_string o "[]" + | Mc.Leaf z -> Printf.fprintf o "[%a]" pp_z z + | Mc.Node(l,z,r) -> Printf.fprintf o "[%a, %a, %a]" pp_varmap l pp_z z pp_varmap r + + + +let rec dump_proof_term = function + | Micromega.RatProof cone -> + Term.mkApp(Lazy.force coq_ratProof, [|dump_cone coq_Z dump_z cone|]) + | Micromega.CutProof(e,q,cone,prf) -> + Term.mkApp(Lazy.force coq_cutProof, + [| dump_expr (Lazy.force coq_Z) dump_z e ; + dump_q q ; + dump_cone coq_Z dump_z cone ; + dump_proof_term prf|]) + | Micromega.EnumProof( q1,e1,q2,c1,c2,prfs) -> + Term.mkApp (Lazy.force coq_enumProof, + [| dump_q q1 ; dump_expr (Lazy.force coq_Z) dump_z e1 ; dump_q q2; + dump_cone coq_Z dump_z c1 ; dump_cone coq_Z dump_z c2 ; + dump_list (Lazy.force coq_proofTerm) dump_proof_term prfs |]) + +let pp_q o q = Printf.fprintf o "%a/%a" pp_z q.Micromega.qnum pp_positive q.Micromega.qden + + +let rec pp_proof_term o = function + | Micromega.RatProof cone -> Printf.fprintf o "R[%a]" (pp_cone pp_z) cone + | Micromega.CutProof(e,q,_,p) -> failwith "not implemented" + | Micromega.EnumProof(q1,e1,q2,c1,c2,rst) -> + Printf.fprintf o "EP[%a,%a,%a,%a,%a,%a]" + pp_q q1 pp_expr e1 pp_q q2 (pp_cone pp_z) c1 (pp_cone pp_z) c2 + (pp_list "[" "]" pp_proof_term) rst + +let rec parse_hyps parse_arith env hyps = + match hyps with + | [] -> ([],env) + | (i,t)::l -> + let (lhyps,env) = parse_hyps parse_arith env l in + try + let (c,env) = parse_formula parse_arith env t in + ((i,c)::lhyps, env) + with _ -> (lhyps,env) + (*(if debug then Printf.printf "parse_arith : %s\n" x);*) + + +exception ParseError + +let parse_goal parse_arith env hyps term = + (* try*) + let (f,env) = parse_formula parse_arith env term in + let (lhyps,env) = parse_hyps parse_arith env hyps in + (lhyps,f,env) + (* with Failure x -> raise ParseError*) + + +type ('a, 'b) domain_spec = { + typ : Term.constr; (* Z, Q , R *) + coeff : Term.constr ; (* Z, Q *) + dump_coeff : 'a -> Term.constr ; + proof_typ : Term.constr ; + dump_proof : 'b -> Term.constr +} + +let zz_domain_spec = lazy { + typ = Lazy.force coq_Z; + coeff = Lazy.force coq_Z; + dump_coeff = dump_z ; + proof_typ = Lazy.force coq_proofTerm ; + dump_proof = dump_proof_term +} + +let qq_domain_spec = lazy { + typ = Lazy.force coq_Q; + coeff = Lazy.force coq_Q; + dump_coeff = dump_q ; + proof_typ = Lazy.force coq_QWitness ; + dump_proof = dump_cone coq_Q dump_q +} + +let rz_domain_spec = lazy { + typ = Lazy.force coq_R; + coeff = Lazy.force coq_Z; + dump_coeff = dump_z; + proof_typ = Lazy.force coq_ZWitness ; + dump_proof = dump_cone coq_Z dump_z +} + + + + +let micromega_order_change spec cert cert_typ env ff gl = + let formula_typ = (Term.mkApp( Lazy.force coq_Cstr,[| spec.coeff|])) in + + let ff = dump_formula formula_typ (dump_cstr spec.coeff spec.dump_coeff) ff in + let vm = dump_varmap ( spec.typ) env in + Tactics.change_in_concl None + (set + [ + ("__ff", ff, Term.mkApp(Lazy.force coq_Formula ,[| formula_typ |])); + ("__varmap", vm , Term.mkApp + (Coqlib.gen_constant_in_modules "VarMap" + [["Coq" ; "micromega" ; "VarMap"];["VarMap"]] "t", [| spec.typ|])); + ("__wit", cert,cert_typ) + ] + (Tacmach.pf_concl gl ) + + ) + gl + + +let detect_duplicates cnf wit = + let cnf = CoqToCaml.list (fun x -> x) cnf in + let wit = CoqToCaml.list (fun x -> x) wit in + + let rec xdup cnf wit = + match wit with + | [] -> [] + | w :: wit -> + let sg = sig_of_cone w in + match cnf with + | [] -> [] + | e::cnf -> + let (dups,cnf) = (List.partition (fun x -> same_proof sg e x) cnf) in + dups@(xdup cnf wit) in + xdup cnf wit + +let find_witness prover polys1 = + try_any prover polys1 + + +let witness_list_with_tags prover l = + + let rec xwitness_list l = + match l with + | [] -> Some([]) + | e::l -> + match find_witness prover (List.map fst e) with + | None -> None + | Some w -> + (match xwitness_list l with + | None -> None + | Some l -> Some (w::l) + ) in + xwitness_list l + +let witness_list_without_tags prover l = + + let rec xwitness_list l = + match l with + | [] -> Some([]) + | e::l -> + match find_witness prover e with + | None -> None + | Some w -> + (match xwitness_list l with + | None -> None + | Some l -> Some (w::l) + ) in + xwitness_list l + +let witness_list prover l = + let rec xwitness_list l = + match l with + | Micromega.Nil -> Some(Micromega.Nil) + | Micromega.Cons(e,l) -> + match find_witness prover e with + | None -> None + | Some w -> + (match xwitness_list l with + | None -> None + | Some l -> Some (Micromega.Cons(w,l)) + ) in + xwitness_list l + + + + +let is_singleton = function [] -> true | [e] -> true | _ -> false + + +let micromega_tauto negate normalise spec prover env polys1 polys2 gl = + let spec = Lazy.force spec in + let (ff,ids) = + List.fold_right + (fun (id,f) (cc,ids) -> + match f with + X _ -> (cc,ids) + | _ -> (I(tag_formula (Names.Name id) f,cc,none), id::ids)) + polys1 (polys2,[]) in + + let cnf_ff = cnf negate normalise ff in + + if debug then + (Pp.pp (Pp.str "Formula....\n") ; + let formula_typ = (Term.mkApp( Lazy.force coq_Cstr,[| spec.coeff|])) in + let ff = dump_formula formula_typ + (dump_cstr spec.typ spec.dump_coeff) ff in + Pp.pp (Printer.prterm ff) ; Pp.pp_flush ()) ; + + match witness_list_without_tags prover cnf_ff with + | None -> Tacticals.tclFAIL 0 (Pp.str "Cannot find witness") gl + | Some res -> (*Printf.printf "\nList %i" (List.length res); *) + let (ff,res,ids) = (ff,res,List.map Term.mkVar ids) in + let res' = dump_ml_list (spec.proof_typ) spec.dump_proof res in + (Tacticals.tclTHENSEQ + [ + Tactics.generalize ids; + micromega_order_change spec res' + (Term.mkApp(Lazy.force coq_list,[| spec.proof_typ|])) env ff ; + ]) gl + + +let micromega_gen parse_arith negate normalise spec prover gl = + let concl = Tacmach.pf_concl gl in + let hyps = Tacmach.pf_hyps_types gl in + try + let (hyps,concl,env) = parse_goal parse_arith Env.empty hyps concl in + let env = Env.elements env in + micromega_tauto negate normalise spec prover env hyps concl gl + with + | Failure x -> flush stdout ; Pp.pp_flush () ; + Tacticals.tclFAIL 0 (Pp.str x) gl + | ParseError -> Tacticals.tclFAIL 0 (Pp.str "Bad logical fragment") gl + + +let lift_ratproof prover l = + match prover l with + | None -> None + | Some c -> Some (Mc.RatProof c) + + +type csdpcert = Certificate.Mc.z Certificate.Mc.coneMember option +type micromega_polys = (Micromega.z Mc.pExpr, Mc.op1) Micromega.prod list +type provername = string * int option + +let call_csdpcert provername poly = + let tmp_to,ch_to = Filename.open_temp_file "csdpcert" ".in" in + let tmp_from = Filename.temp_file "csdpcert" ".out" in + output_value ch_to (provername,poly : provername * micromega_polys); + close_out ch_to; + let cmdname = + Filename.concat Coq_config.bindir + ("csdpcert" ^ Coq_config.exec_extension) in + let c = Sys.command (cmdname ^" "^ tmp_to ^" "^ tmp_from) in + (try Sys.remove tmp_to with _ -> ()); + if c <> 0 then Util.error ("Failed to call csdp certificate generator"); + let ch_from = open_in tmp_from in + let cert = (input_value ch_from : csdpcert) in + close_in ch_from; Sys.remove tmp_from; + cert + +let omicron gl = + micromega_gen parse_zarith Mc.negate Mc.normalise zz_domain_spec + [lift_ratproof + (Certificate.linear_prover Certificate.z_spec), "fourier refutation" ] gl + + +let qomicron gl = + micromega_gen parse_qarith Mc.cnf_negate Mc.cnf_normalise qq_domain_spec + [ Certificate.linear_prover Certificate.q_spec, "fourier refutation" ] gl + +let romicron gl = + micromega_gen parse_rarith Mc.cnf_negate Mc.cnf_normalise rz_domain_spec + [ Certificate.linear_prover Certificate.z_spec, "fourier refutation" ] gl + + +let rmicromega i gl = + micromega_gen parse_rarith Mc.negate Mc.normalise rz_domain_spec + [ call_csdpcert ("real_nonlinear_prover", Some i), "fourier refutation" ] gl + + +let micromega i gl = + micromega_gen parse_zarith Mc.negate Mc.normalise zz_domain_spec + [lift_ratproof (call_csdpcert ("real_nonlinear_prover",Some i)), + "fourier refutation" ] gl + + +let sos gl = + micromega_gen parse_zarith Mc.negate Mc.normalise zz_domain_spec + [lift_ratproof (call_csdpcert ("pure_sos", None)), "pure sos refutation"] gl + +let zomicron gl = + micromega_gen parse_zarith Mc.negate Mc.normalise zz_domain_spec + [Certificate.zlinear_prover, "zprover"] gl diff --git a/contrib/micromega/csdpcert.ml b/contrib/micromega/csdpcert.ml new file mode 100644 index 00000000..cfaf6ae1 --- /dev/null +++ b/contrib/micromega/csdpcert.ml @@ -0,0 +1,333 @@ +(************************************************************************) +(* 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 *) +(************************************************************************) +(* *) +(* Micromega: A reflexive tactic using the Positivstellensatz *) +(* *) +(* Frédéric Besson (Irisa/Inria) 2006-2008 *) +(* *) +(************************************************************************) + +open Big_int +open Num +open Sos + +module Mc = Micromega +module Ml2C = Mutils.CamlToCoq +module C2Ml = Mutils.CoqToCaml + +let debug = false + +module M = +struct + open Mc + + let rec expr_to_term = function + | PEc z -> Const (Big_int (C2Ml.z_big_int z)) + | PEX v -> Var ("x"^(string_of_int (C2Ml.index v))) + | PEmul(p1,p2) -> + let p1 = expr_to_term p1 in + let p2 = expr_to_term p2 in + let res = Mul(p1,p2) in res + + | PEadd(p1,p2) -> Add(expr_to_term p1, expr_to_term p2) + | PEsub(p1,p2) -> Sub(expr_to_term p1, expr_to_term p2) + | PEpow(p,n) -> Pow(expr_to_term p , C2Ml.n n) + | PEopp p -> Opp (expr_to_term p) + + + let rec term_to_expr = function + | Const n -> PEc (Ml2C.bigint (big_int_of_num n)) + | Zero -> PEc ( Z0) + | Var s -> PEX (Ml2C.index + (int_of_string (String.sub s 1 (String.length s - 1)))) + | Mul(p1,p2) -> PEmul(term_to_expr p1, term_to_expr p2) + | Add(p1,p2) -> PEadd(term_to_expr p1, term_to_expr p2) + | Opp p -> PEopp (term_to_expr p) + | Pow(t,n) -> PEpow (term_to_expr t,Ml2C.n n) + | Sub(t1,t2) -> PEsub (term_to_expr t1, term_to_expr t2) + | _ -> failwith "term_to_expr: not implemented" + + let term_to_expr e = + let e' = term_to_expr e in + if debug + then Printf.printf "term_to_expr : %s - %s\n" + (string_of_poly (poly_of_term e)) + (string_of_poly (poly_of_term (expr_to_term e'))); + e' + +end +open M + +open List +open Mutils + +let rec scale_term t = + match t with + | Zero -> unit_big_int , Zero + | Const n -> (denominator n) , Const (Big_int (numerator n)) + | Var n -> unit_big_int , Var n + | Inv _ -> failwith "scale_term : not implemented" + | Opp t -> let s, t = scale_term t in s, Opp t + | Add(t1,t2) -> let s1,y1 = scale_term t1 and s2,y2 = scale_term t2 in + let g = gcd_big_int s1 s2 in + let s1' = div_big_int s1 g in + let s2' = div_big_int s2 g in + let e = mult_big_int g (mult_big_int s1' s2') in + if (compare_big_int e unit_big_int) = 0 + then (unit_big_int, Add (y1,y2)) + else e, Add (Mul(Const (Big_int s2'), y1), + Mul (Const (Big_int s1'), y2)) + | Sub _ -> failwith "scale term: not implemented" + | Mul(y,z) -> let s1,y1 = scale_term y and s2,y2 = scale_term z in + mult_big_int s1 s2 , Mul (y1, y2) + | Pow(t,n) -> let s,t = scale_term t in + power_big_int_positive_int s n , Pow(t,n) + | _ -> failwith "scale_term : not implemented" + +let scale_term t = + let (s,t') = scale_term t in + s,t' + + + + +let rec scale_certificate pos = match pos with + | Axiom_eq i -> unit_big_int , Axiom_eq i + | Axiom_le i -> unit_big_int , Axiom_le i + | Axiom_lt i -> unit_big_int , Axiom_lt i + | Monoid l -> unit_big_int , Monoid l + | Rational_eq n -> (denominator n) , Rational_eq (Big_int (numerator n)) + | Rational_le n -> (denominator n) , Rational_le (Big_int (numerator n)) + | Rational_lt n -> (denominator n) , Rational_lt (Big_int (numerator n)) + | Square t -> let s,t' = scale_term t in + mult_big_int s s , Square t' + | Eqmul (t, y) -> let s1,y1 = scale_term t and s2,y2 = scale_certificate y in + mult_big_int s1 s2 , Eqmul (y1,y2) + | Sum (y, z) -> let s1,y1 = scale_certificate y + and s2,y2 = scale_certificate z in + let g = gcd_big_int s1 s2 in + let s1' = div_big_int s1 g in + let s2' = div_big_int s2 g in + mult_big_int g (mult_big_int s1' s2'), + Sum (Product(Rational_le (Big_int s2'), y1), + Product (Rational_le (Big_int s1'), y2)) + | Product (y, z) -> + let s1,y1 = scale_certificate y and s2,y2 = scale_certificate z in + mult_big_int s1 s2 , Product (y1,y2) + + +let is_eq = function Mc.Equal -> true | _ -> false +let is_le = function Mc.NonStrict -> true | _ -> false +let is_lt = function Mc.Strict -> true | _ -> false + +let get_index_of_ith_match f i l = + let rec get j res l = + match l with + | [] -> failwith "bad index" + | e::l -> if f e + then + (if j = i then res else get (j+1) (res+1) l ) + else get j (res+1) l in + get 0 0 l + + +let cert_of_pos eq le lt ll l pos = + let s,pos = (scale_certificate pos) in + let rec _cert_of_pos = function + Axiom_eq i -> let idx = get_index_of_ith_match is_eq i l in + Mc.S_In (Ml2C.nat idx) + | Axiom_le i -> let idx = get_index_of_ith_match is_le i l in + Mc.S_In (Ml2C.nat idx) + | Axiom_lt i -> let idx = get_index_of_ith_match is_lt i l in + Mc.S_In (Ml2C.nat idx) + | Monoid l -> Mc.S_Monoid (Ml2C.list Ml2C.nat l) + | Rational_eq n | Rational_le n | Rational_lt n -> + if compare_num n (Int 0) = 0 then Mc.S_Z else + Mc.S_Pos (Ml2C.bigint (big_int_of_num n)) + | Square t -> Mc.S_Square (term_to_expr t) + | Eqmul (t, y) -> Mc.S_Ideal(term_to_expr t, _cert_of_pos y) + | Sum (y, z) -> Mc.S_Add (_cert_of_pos y, _cert_of_pos z) + | Product (y, z) -> Mc.S_Mult (_cert_of_pos y, _cert_of_pos z) in + s, Certificate.simplify_cone Certificate.z_spec (_cert_of_pos pos) + + +let term_of_cert l pos = + let l = List.map fst' l in + let rec _cert_of_pos = function + | Mc.S_In i -> expr_to_term (List.nth l (C2Ml.nat i)) + | Mc.S_Pos p -> Const (C2Ml.num p) + | Mc.S_Z -> Const (Int 0) + | Mc.S_Square t -> Mul(expr_to_term t, expr_to_term t) + | Mc.S_Monoid m -> List.fold_right + (fun x m -> Mul (expr_to_term (List.nth l (C2Ml.nat x)),m)) + (C2Ml.list (fun x -> x) m) (Const (Int 1)) + | Mc.S_Ideal (t, y) -> Mul(expr_to_term t, _cert_of_pos y) + | Mc.S_Add (y, z) -> Add (_cert_of_pos y, _cert_of_pos z) + | Mc.S_Mult (y, z) -> Mul (_cert_of_pos y, _cert_of_pos z) in + (_cert_of_pos pos) + +let rec canonical_sum_to_string = function s -> failwith "not implemented" + +let print_canonical_sum m = Format.print_string (canonical_sum_to_string m) + +let print_list_term l = + print_string "print_list_term\n"; + List.iter (fun (Mc.Pair(e,k)) -> Printf.printf "q: %s %s ;" + (string_of_poly (poly_of_term (expr_to_term e))) + (match k with + Mc.Equal -> "= " + | Mc.Strict -> "> " + | Mc.NonStrict -> ">= " + | _ -> failwith "not_implemented")) l ; + print_string "\n" + + +let partition_expr l = + let rec f i = function + | [] -> ([],[],[]) + | Mc.Pair(e,k)::l -> + let (eq,ge,neq) = f (i+1) l in + match k with + | Mc.Equal -> ((e,i)::eq,ge,neq) + | Mc.NonStrict -> (eq,(e,Axiom_le i)::ge,neq) + | Mc.Strict -> (* e > 0 == e >= 0 /\ e <> 0 *) + (eq, (e,Axiom_lt i)::ge,(e,Axiom_lt i)::neq) + | Mc.NonEqual -> (eq,ge,(e,Axiom_eq i)::neq) + (* Not quite sure -- Coq interface has changed *) + in f 0 l + + +let rec sets_of_list l = + match l with + | [] -> [[]] + | e::l -> let s = sets_of_list l in + s@(List.map (fun s0 -> e::s0) s) + +let cert_of_pos pos = + let s,pos = (scale_certificate pos) in + let rec _cert_of_pos = function + Axiom_eq i -> Mc.S_In (Ml2C.nat i) + | Axiom_le i -> Mc.S_In (Ml2C.nat i) + | Axiom_lt i -> Mc.S_In (Ml2C.nat i) + | Monoid l -> Mc.S_Monoid (Ml2C.list Ml2C.nat l) + | Rational_eq n | Rational_le n | Rational_lt n -> + if compare_num n (Int 0) = 0 then Mc.S_Z else + Mc.S_Pos (Ml2C.bigint (big_int_of_num n)) + | Square t -> Mc.S_Square (term_to_expr t) + | Eqmul (t, y) -> Mc.S_Ideal(term_to_expr t, _cert_of_pos y) + | Sum (y, z) -> Mc.S_Add (_cert_of_pos y, _cert_of_pos z) + | Product (y, z) -> Mc.S_Mult (_cert_of_pos y, _cert_of_pos z) in + s, Certificate.simplify_cone Certificate.z_spec (_cert_of_pos pos) + +(* The exploration is probably not complete - for simple cases, it works... *) +let real_nonlinear_prover d l = + try + let (eq,ge,neq) = partition_expr l in + + let rec elim_const = function + [] -> [] + | (x,y)::l -> let p = poly_of_term (expr_to_term x) in + if poly_isconst p + then elim_const l + else (p,y)::(elim_const l) in + + let eq = elim_const eq in + let peq = List.map fst eq in + + let pge = List.map + (fun (e,psatz) -> poly_of_term (expr_to_term e),psatz) ge in + + let monoids = List.map (fun m -> (List.fold_right (fun (p,kd) y -> + let p = poly_of_term (expr_to_term p) in + match kd with + | Axiom_lt i -> poly_mul p y + | Axiom_eq i -> poly_mul (poly_pow p 2) y + | _ -> failwith "monoids") m (poly_const (Int 1)) , map snd m)) + (sets_of_list neq) in + + let (cert_ideal, cert_cone,monoid) = deepen_until d (fun d -> + list_try_find (fun m -> let (ci,cc) = + real_positivnullstellensatz_general false d peq pge (poly_neg (fst m) ) in + (ci,cc,snd m)) monoids) 0 in + + let proofs_ideal = map2 (fun q i -> Eqmul(term_of_poly q,Axiom_eq i)) + cert_ideal (List.map snd eq) in + + let proofs_cone = map term_of_sos cert_cone in + + let proof_ne = + let (neq , lt) = List.partition + (function Axiom_eq _ -> true | _ -> false ) monoid in + let sq = match + (List.map (function Axiom_eq i -> i | _ -> failwith "error") neq) + with + | [] -> Rational_lt (Int 1) + | l -> Monoid l in + List.fold_right (fun x y -> Product(x,y)) lt sq in + + let proof = list_fold_right_elements + (fun s t -> Sum(s,t)) (proof_ne :: proofs_ideal @ proofs_cone) in + + let s,proof' = scale_certificate proof in + let cert = snd (cert_of_pos proof') in + if debug + then Printf.printf "cert poly : %s\n" + (string_of_poly (poly_of_term (term_of_cert l cert))); + match Mc.zWeakChecker (Ml2C.list (fun x -> x) l) cert with + | Mc.True -> Some cert + | Mc.False -> (print_string "buggy certificate" ; flush stdout) ;None + with + | Sos.TooDeep -> None + + +(* This is somewhat buggy, over Z, strict inequality vanish... *) +let pure_sos l = + (* If there is no strict inequality, + I should nonetheless be able to try something - over Z > is equivalent to -1 >= *) + try + let l = List.combine l (interval 0 (length l -1)) in + let (lt,i) = try (List.find (fun (x,_) -> snd' x = Mc.Strict) l) + with Not_found -> List.hd l in + let plt = poly_neg (poly_of_term (expr_to_term (fst' lt))) in + let (n,polys) = sumofsquares plt in (* n * (ci * pi^2) *) + let pos = Product (Rational_lt n, + List.fold_right (fun (c,p) rst -> Sum (Product (Rational_lt c, Square + (term_of_poly p)), rst)) + polys (Rational_lt (Int 0))) in + let proof = Sum(Axiom_lt i, pos) in + let s,proof' = scale_certificate proof in + let cert = snd (cert_of_pos proof') in + Some cert + with + | Not_found -> (* This is no strict inequality *) None + | x -> None + + +type micromega_polys = (Micromega.z Mc.pExpr, Mc.op1) Micromega.prod list +type csdp_certificate = Certificate.Mc.z Certificate.Mc.coneMember option +type provername = string * int option + +let main () = + if Array.length Sys.argv <> 3 then + (Printf.printf "Usage: csdpcert inputfile outputfile\n"; exit 1); + let input_file = Sys.argv.(1) in + let output_file = Sys.argv.(2) in + let inch = open_in input_file in + let (prover,poly) = (input_value inch : provername * micromega_polys) in + close_in inch; + let cert = + match prover with + | "real_nonlinear_prover", Some d -> real_nonlinear_prover d poly + | "pure_sos", None -> pure_sos poly + | prover, _ -> (Printf.printf "unknown prover: %s\n" prover; exit 1) in + let outch = open_out output_file in + output_value outch (cert:csdp_certificate); + close_out outch; + exit 0;; + +let _ = main () in () diff --git a/contrib/micromega/g_micromega.ml4 b/contrib/micromega/g_micromega.ml4 new file mode 100644 index 00000000..259b5d4b --- /dev/null +++ b/contrib/micromega/g_micromega.ml4 @@ -0,0 +1,59 @@ +(************************************************************************) +(* 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 *) +(************************************************************************) +(* *) +(* Micromega: A reflexive tactic using the Positivstellensatz *) +(* *) +(* Frédéric Besson (Irisa/Inria) 2006-2008 *) +(* *) +(************************************************************************) + +(*i camlp4deps: "parsing/grammar.cma" i*) + +(* $Id: g_micromega.ml4 10947 2008-05-19 19:10:40Z herbelin $ *) + +open Quote +open Ring +open Mutils +open Rawterm +open Util + +let out_arg = function + | ArgVar _ -> anomaly "Unevaluated or_var variable" + | ArgArg x -> x + +TACTIC EXTEND Micromega +| [ "micromegap" int_or_var(i) ] -> [ Coq_micromega.micromega (out_arg i) ] +| [ "micromegap" ] -> [ Coq_micromega.micromega (-1) ] +END + +TACTIC EXTEND Sos +[ "sosp" ] -> [ Coq_micromega.sos] +END + + +TACTIC EXTEND Omicron +[ "omicronp" ] -> [ Coq_micromega.omicron] +END + +TACTIC EXTEND QOmicron +[ "qomicronp" ] -> [ Coq_micromega.qomicron] +END + + +TACTIC EXTEND ZOmicron +[ "zomicronp" ] -> [ Coq_micromega.zomicron] +END + +TACTIC EXTEND ROmicron +[ "romicronp" ] -> [ Coq_micromega.romicron] +END + +TACTIC EXTEND RMicromega +| [ "rmicromegap" int_or_var(i) ] -> [ Coq_micromega.rmicromega (out_arg i) ] +| [ "rmicromegap" ] -> [ Coq_micromega.rmicromega (-1) ] +END diff --git a/contrib/micromega/mfourier.ml b/contrib/micromega/mfourier.ml new file mode 100644 index 00000000..415d3a3e --- /dev/null +++ b/contrib/micromega/mfourier.ml @@ -0,0 +1,667 @@ +(************************************************************************) +(* 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 *) +(************************************************************************) +(* *) +(* Micromega: A reflexive tactic using the Positivstellensatz *) +(* *) +(* Frédéric Besson (Irisa/Inria) 2006-2008 *) +(* *) +(************************************************************************) + +(* Yet another implementation of Fourier *) +open Num + +module Cmp = + (* How to compare pairs, lists ... *) +struct + let rec compare_lexical l = + match l with + | [] -> 0 (* Equal *) + | f::l -> + let cmp = f () in + if cmp = 0 then compare_lexical l else cmp + + let rec compare_list cmp l1 l2 = + match l1 , l2 with + | [] , [] -> 0 + | [] , _ -> -1 + | _ , [] -> 1 + | e1::l1 , e2::l2 -> + let c = cmp e1 e2 in + if c = 0 then compare_list cmp l1 l2 else c + + let hash_list hash l = + let rec xhash res l = + match l with + | [] -> res + | e::l -> xhash ((hash e) lxor res) l in + xhash (Hashtbl.hash []) l + +end + +module Interval = +struct + (** The type of intervals. **) + type intrvl = Empty | Point of num | Itv of num option * num option + + (** + Different intervals can denote the same set of variables e.g., + Point n && Itv (Some n, Some n) + Itv (Some x) (Some y) && Empty if x > y + see the 'belongs_to' function. + **) + + (* The set of numerics that belong to an interval *) + let belongs_to n = function + | Empty -> false + | Point x -> n =/ x + | Itv(Some x, Some y) -> x <=/ n && n <=/ y + | Itv(None,Some y) -> n <=/ y + | Itv(Some x,None) -> x <=/ n + | Itv(None,None) -> true + + let string_of_bound = function + | None -> "oo" + | Some n -> Printf.sprintf "Bd(%s)" (string_of_num n) + + let string_of_intrvl = function + | Empty -> "[]" + | Point n -> Printf.sprintf "[%s]" (string_of_num n) + | Itv(bd1,bd2) -> + Printf.sprintf "[%s,%s]" (string_of_bound bd1) (string_of_bound bd2) + + let pick_closed_to_zero = function + | Empty -> None + | Point n -> Some n + | Itv(None,None) -> Some (Int 0) + | Itv(None,Some i) -> + Some (if (Int 0) <=/ (floor_num i) then Int 0 else floor_num i) + | Itv(Some i,None) -> + Some (if i <=/ (Int 0) then Int 0 else ceiling_num i) + | Itv(Some i,Some j) -> + Some ( + if i <=/ Int 0 && Int 0 <=/ j + then Int 0 + else if ceiling_num i <=/ floor_num j + then ceiling_num i (* why not *) else i) + + type status = + | O | Qonly | Z | Q + + let interval_kind = function + | Empty -> O + | Point n -> if ceiling_num n =/ n then Z else Qonly + | Itv(None,None) -> Z + | Itv(None,Some i) -> if ceiling_num i <>/ i then Q else Z + | Itv(Some i,None) -> if ceiling_num i <>/ i then Q else Z + | Itv(Some i,Some j) -> + if ceiling_num i <>/ i or floor_num j <>/ j then Q else Z + + let empty_z = function + | Empty -> true + | Point n -> ceiling_num n <>/ n + | Itv(None,None) | Itv(None,Some _) | Itv(Some _,None) -> false + | Itv(Some i,Some j) -> ceiling_num i >/ floor_num j + + + let normalise b1 b2 = + match b1 , b2 with + | Some i , Some j -> + (match compare_num i j with + | 1 -> Empty + | 0 -> Point i + | _ -> Itv(b1,b2) + ) + | _ -> Itv(b1,b2) + + + + let min x y = + match x , y with + | None , x | x , None -> x + | Some i , Some j -> Some (min_num i j) + + let max x y = + match x , y with + | None , x | x , None -> x + | Some i , Some j -> Some (max_num i j) + + let inter i1 i2 = + match i1,i2 with + | Empty , _ -> Empty + | _ , Empty -> Empty + | Point n , Point m -> if n =/ m then i1 else Empty + | Point n , Itv (mn,mx) | Itv (mn,mx) , Point n-> + if (match mn with + | None -> true + | Some mn -> mn <=/ n) && + (match mx with + | None -> true + | Some mx -> n <=/ mx) then Point n else Empty + | Itv (min1,max1) , Itv (min2,max2) -> + let bmin = max min1 min2 + and bmax = min max1 max2 in + normalise bmin bmax + + (* a.x >= b*) + let bound_of_constraint (a,b) = + match compare_num a (Int 0) with + | 0 -> + if compare_num b (Int 0) = 1 + then Empty + (*actually this is a contradiction failwith "bound_of_constraint" *) + else Itv (None,None) + | 1 -> Itv (Some (div_num b a),None) + | -1 -> Itv (None, Some (div_num b a)) + | x -> failwith "bound_of_constraint(2)" + + + let bounded x = + match x with + | Itv(None,_) | Itv(_,None) -> false + | _ -> true + + + let range = function + | Empty -> Some (Int 0) + | Point n -> Some (Int (if ceiling_num n =/ n then 1 else 0)) + | Itv(None,_) | Itv(_,None)-> None + | Itv(Some i,Some j) -> Some (floor_num j -/ceiling_num i +/ (Int 1)) + + (* Returns the interval of smallest range *) + let smaller_itv i1 i2 = + match range i1 , range i2 with + | None , _ -> false + | _ , None -> true + | Some i , Some j -> i <=/ j + +end +open Interval + +(* A set of constraints *) +module Sys(V:Vector.S) (* : Vector.SystemS with module Vect = V*) = +struct + + module Vect = V + + module Cstr = Vector.Cstr(V) + open Cstr + + + module CMap = Map.Make( + struct + type t = Vect.t + let compare = Vect.compare + end) + + module CstrBag = + struct + + type mut_itv = { mutable itv : intrvl} + + type t = mut_itv CMap.t + + exception Contradiction + + let cstr_to_itv cstr = + let (n,l) = V.normalise cstr.coeffs in + if n =/ (Int 0) + then (Vect.null, bound_of_constraint (Int 0,cstr.cst)) (* Might be empty *) + else + match cstr.op with + | Eq -> let n = cstr.cst // n in (l, Point n) + | Ge -> + match compare_num n (Int 0) with + | 0 -> failwith "intrvl_of_constraint" + | 1 -> (l,Itv (Some (cstr.cst // n), None)) + | -1 -> (l, Itv(None,Some (cstr.cst // n))) + | _ -> failwith "cstr_to_itv" + + + let empty = CMap.empty + + + + + let is_empty = CMap.is_empty + + let find_vect v bag = + try + (bag,CMap.find v bag) + with Not_found -> let x = { itv = Itv(None,None)} in (CMap.add v x bag ,x) + + + let add (v,b) bag = + match b with + | Empty -> raise Contradiction + | Itv(None,None) -> bag + | _ -> + let (bag,intrl) = find_vect v bag in + match inter b intrl.itv with + | Empty -> raise Contradiction + | itv -> intrl.itv <- itv ; bag + + exception Found of cstr + + let find_equation bag = + try + CMap.fold (fun v i () -> + match i.itv with + | Point n -> let e = {coeffs = v ; op = Eq ; cst = n} + in raise (Found e) + | _ -> () ) bag () ; None + with Found c -> Some c + + + let fold f bag acc = + CMap.fold (fun v itv acc -> + match itv.itv with + | Empty | Itv(None,None) -> failwith "fold Empty" + | Itv(None ,Some i) -> + f {coeffs = V.mul (Int (-1)) v ; op = Ge ; cst = minus_num i} acc + | Point n -> f {coeffs = v ; op = Eq ; cst = n} acc + | Itv(x,y) -> + (match x with + | None -> (fun x -> x) + | Some i -> f {coeffs = v ; op = Ge ; cst = i}) + (match y with + | None -> acc + | Some i -> + f {coeffs = V.mul (Int (-1)) v ; op = Ge ; cst = minus_num i} acc + ) ) bag acc + + + let remove l _ = failwith "remove:Not implemented" + + module Map = + Map.Make( + struct + type t = int + let compare : int -> int -> int = Pervasives.compare + end) + + let split f (t:t) = + let res = + fold (fun e m -> let i = f e in + Map.add i (add (cstr_to_itv e) + (try Map.find i m with + Not_found -> empty)) m) t Map.empty in + (fun i -> try Map.find i res with Not_found -> empty) + + type map = (int list * int list) Map.t + + + let status (b:t) = + let _ , map = fold (fun c ( (idx:int),(res: map)) -> + ( idx + 1, + List.fold_left (fun (res:map) (pos,s) -> + let (lp,ln) = try Map.find pos res with Not_found -> ([],[]) in + match s with + | Vect.Pos -> Map.add pos (idx::lp,ln) res + | Vect.Neg -> + Map.add pos (lp, idx::ln) res) res + (Vect.status c.coeffs))) b (0,Map.empty) in + Map.fold (fun k e res -> (k,e)::res) map [] + + + type it = num CMap.t + + let iterator x = x + + let element it = failwith "element:Not implemented" + + end +end + +module Fourier(Vect : Vector.S) = +struct + module Vect = Vect + module Sys = Sys( Vect) + module Cstr = Sys.Cstr + module Bag = Sys.CstrBag + + open Cstr + open Sys + + let debug = false + + let print_bag msg b = + print_endline msg; + CstrBag.fold (fun e () -> print_endline (Cstr.string_of_cstr e)) b () + + let print_bag_file file msg b = + let f = open_out file in + output_string f msg; + CstrBag.fold (fun e () -> + Printf.fprintf f "%s\n" (Cstr.string_of_cstr e)) b () + + + (* A system with only inequations -- + *) + let partition i m = + let splitter cstr = compare_num (Vect.get i cstr.coeffs ) (Int 0) in + let split = CstrBag.split splitter m in + (split (-1) , split 0, split 1) + + + (* op of the result is arbitrary Ge *) + let lin_comb n1 c1 n2 c2 = + { coeffs = Vect.lin_comb n1 c1.coeffs n2 c2.coeffs ; + op = Ge ; + cst = (n1 */ c1.cst) +/ (n2 */ c2.cst)} + + (* BUG? : operator of the result ? *) + + let combine_project i c1 c2 = + let p = Vect.get i c1.coeffs + and n = Vect.get i c2.coeffs in + assert (n </ Int 0 && p >/ Int 0) ; + let nopp = minus_num n in + let c =lin_comb nopp c1 p c2 in + let op = if c1.op = Ge || c2.op = Ge then Ge else Eq in + CstrBag.cstr_to_itv {coeffs = c.coeffs ; op = op ; cst= c.cst } + + + let project i m = + let (neg,zero,pos) = partition i m in + let project1 cpos acc = + CstrBag.fold (fun cneg res -> + CstrBag.add (combine_project i cpos cneg) res) neg acc in + (CstrBag.fold project1 pos zero) + + (* Given a vector [x1 -> v1; ... ; xn -> vn] + and a constraint {x1 ; .... xn >= c } + *) + let evaluate_constraint i map cstr = + let {coeffs = _coeffs ; op = _op ; cst = _cst} = cstr in + let vi = Vect.get i _coeffs in + let v = Vect.set i (Int 0) _coeffs in + (vi, _cst -/ Vect.dotp map v) + + + let rec bounds m itv = + match m with + | [] -> itv + | e::m -> bounds m (inter itv (bound_of_constraint e)) + + + + let compare_status (i,(lp,ln)) (i',(lp',ln')) = + let cmp = Pervasives.compare + ((List.length lp) * (List.length ln)) + ((List.length lp') * (List.length ln')) in + if cmp = 0 + then Pervasives.compare i i' + else cmp + + let cardinal m = CstrBag.fold (fun _ x -> x + 1) m 0 + + let lightest_projection l c m = + let bound = c in + if debug then (Printf.printf "l%i" bound; flush stdout) ; + let rec xlight best l = + match l with + | [] -> best + | i::l -> + let proj = (project i m) in + let cproj = cardinal proj in + (*Printf.printf " p %i " cproj; flush stdout;*) + match best with + | None -> + if cproj < bound + then Some(cproj,proj,i) + else xlight (Some(cproj,proj,i)) l + | Some (cbest,_,_) -> + if cproj < cbest + then + if cproj < bound then Some(cproj,proj,i) + else xlight (Some(cproj,proj,i)) l + else xlight best l in + match xlight None l with + | None -> None + | Some(_,p,i) -> Some (p,i) + + + + exception Equality of cstr + + let find_equality m = Bag.find_equation m + + + + let pivot (n,v) eq ge = + assert (eq.op = Eq) ; + let res = + match + compare_num v (Int 0), + compare_num (Vect.get n ge.coeffs) (Int 0) + with + | 0 , _ -> failwith "Buggy" + | _ ,0 -> (CstrBag.cstr_to_itv ge) + | 1 , -1 -> combine_project n eq ge + | -1 , 1 -> combine_project n ge eq + | 1 , 1 -> + combine_project n ge + {coeffs = Vect.mul (Int (-1)) eq.coeffs; + op = eq.op ; + cst = minus_num eq.cst} + | -1 , -1 -> + combine_project n + {coeffs = Vect.mul (Int (-1)) eq.coeffs; + op = eq.op ; cst = minus_num eq.cst} ge + | _ -> failwith "pivot" in + res + + let check_cstr v c = + let {coeffs = _coeffs ; op = _op ; cst = _cst} = c in + let vl = Vect.dotp v _coeffs in + match _op with + | Eq -> vl =/ _cst + | Ge -> vl >= _cst + + + let forall p sys = + try + CstrBag.fold (fun c () -> if p c then () else raise Not_found) sys (); true + with Not_found -> false + + + let check_sys v sys = forall (check_cstr v) sys + + let check_null_cstr c = + let {coeffs = _coeffs ; op = _op ; cst = _cst} = c in + match _op with + | Eq -> (Int 0) =/ _cst + | Ge -> (Int 0) >= _cst + + let check_null sys = forall check_null_cstr sys + + + let optimise_ge + quick_check choose choose_idx return_empty return_ge return_eq m = + let c = cardinal m in + let bound = 2 * c in + if debug then (Printf.printf "optimise_ge: %i\n" c; flush stdout); + + let rec xoptimise m = + if debug then (Printf.printf "x%i" (cardinal m) ; flush stdout); + if debug then (print_bag "xoptimise" m ; flush stdout); + if quick_check m + then return_empty m + else + match find_equality m with + | None -> xoptimise_ge m + | Some eq -> xoptimise_eq eq m + + and xoptimise_ge m = + begin + let c = cardinal m in + let l = List.map fst (List.sort compare_status (CstrBag.status m)) in + let idx = choose bound l c m in + match idx with + | None -> return_empty m + | Some (proj,i) -> + match xoptimise proj with + | None -> None + | Some mapping -> return_ge m i mapping + end + and xoptimise_eq eq m = + let l = List.map fst (Vect.status eq.coeffs) in + match choose_idx l with + | None -> (*if l = [] then None else*) return_empty m + | Some i -> + let p = (i,Vect.get i eq.coeffs) in + let m' = CstrBag.fold + (fun ge res -> CstrBag.add (pivot p eq ge) res) m CstrBag.empty in + match xoptimise ( m') with + | None -> None + | Some mapp -> return_eq m eq i mapp in + try + let res = xoptimise m in res + with CstrBag.Contradiction -> (*print_string "contradiction" ;*) None + + + + let minimise m = + let opt_zero_choose bound l c m = + if c > bound + then lightest_projection l c m + else match l with + | [] -> None + | i::_ -> Some (project i m, i) in + + let choose_idx = function [] -> None | x::l -> Some x in + + let opt_zero_return_empty m = Some Vect.null in + + + let opt_zero_return_ge m i mapping = + let (it:intrvl) = CstrBag.fold (fun cstr itv -> Interval.inter + (bound_of_constraint (evaluate_constraint i mapping cstr)) itv) m + (Itv (None, None)) in + match pick_closed_to_zero it with + | None -> print_endline "Cannot pick" ; None + | Some v -> + let res = (Vect.set i v mapping) in + if debug + then Printf.printf "xoptimise res %i [%s]" i (Vect.string res) ; + Some res in + + let opt_zero_return_eq m eq i mapp = + let (a,b) = evaluate_constraint i mapp eq in + Some (Vect.set i (div_num b a) mapp) in + + optimise_ge check_null opt_zero_choose + choose_idx opt_zero_return_empty opt_zero_return_ge opt_zero_return_eq m + + let normalise cstr = [CstrBag.cstr_to_itv cstr] + + let find_point l = + (* List.iter (fun e -> print_endline (Cstr.string_of_cstr e)) l;*) + try + let m = List.fold_left (fun sys e -> CstrBag.add (CstrBag.cstr_to_itv e) sys) + CstrBag.empty l in + match minimise m with + | None -> None + | Some res -> + if debug then Printf.printf "[%s]" (Vect.string res); + Some res + with CstrBag.Contradiction -> None + + + let find_q_interval_for x m = + if debug then Printf.printf "find_q_interval_for %i\n" x ; + + let choose bound l c m = + let rec xchoose l = + match l with + | [] -> None + | i::l -> if i = x then xchoose l else Some (project i m,i) in + xchoose l in + + let rec choose_idx = function + [] -> None + | e::l -> if e = x then choose_idx l else Some e in + + let return_empty m = (* Beurk *) + (* returns the interval of x *) + Some (CstrBag.fold (fun cstr itv -> + let i = if cstr.op = Eq + then Point (cstr.cst // Vect.get x cstr.coeffs) + else if Vect.is_null (Vect.set x (Int 0) cstr.coeffs) + then bound_of_constraint (Vect.get x cstr.coeffs , cstr.cst) + else itv + in + Interval.inter i itv) m (Itv (None, None))) in + + let return_ge m i res = Some res in + + let return_eq m eq i res = Some res in + + try + optimise_ge + (fun x -> false) choose choose_idx return_empty return_ge return_eq m + with CstrBag.Contradiction -> None + + + let find_q_intervals sys = + let variables = + List.map fst (List.sort compare_status (CstrBag.status sys)) in + List.map (fun x -> (x,find_q_interval_for x sys)) variables + + let pp_option f o = function + None -> Printf.fprintf o "None" + | Some x -> Printf.fprintf o "Some %a" f x + + let optimise vect sys = + (* we have to modify the system with a dummy variable *) + let fresh = + List.fold_left (fun fr c -> Pervasives.max fr (Vect.fresh c.coeffs)) 0 sys in + assert (List.for_all (fun x -> Vect.get fresh x.coeffs =/ Int 0) sys); + let cstr = { + coeffs = Vect.set fresh (Int (-1)) vect ; + op = Eq ; + cst = (Int 0)} in + try + find_q_interval_for fresh + (List.fold_left + (fun bg c -> CstrBag.add (CstrBag.cstr_to_itv c) bg) + CstrBag.empty (cstr::sys)) + with CstrBag.Contradiction -> None + + + let optimise vect sys = + let res = optimise vect sys in + if debug + then Printf.printf "optimise %s -> %a\n" + (Vect.string vect) (pp_option (fun o x -> Printf.printf "%s" (string_of_intrvl x))) res + ; res + + let find_Q_interval sys = + try + let sys = + (List.fold_left + (fun bg c -> CstrBag.add (CstrBag.cstr_to_itv c) bg) CstrBag.empty sys) in + let candidates = + List.fold_left + (fun l (x,i) -> match i with + None -> (x,Empty)::l + | Some i -> (x,i)::l) [] (find_q_intervals sys) in + match List.fold_left + (fun (x1,i1) (x2,i2) -> + if smaller_itv i1 i2 + then (x1,i1) else (x2,i2)) (-1,Itv(None,None)) candidates + with + | (i,Empty) -> None + | (x,Itv(Some i, Some j)) -> Some(i,x,j) + | (x,Point n) -> Some(n,x,n) + | _ -> None + with CstrBag.Contradiction -> None + + +end + diff --git a/contrib/micromega/micromega.ml b/contrib/micromega/micromega.ml new file mode 100644 index 00000000..e151e4e1 --- /dev/null +++ b/contrib/micromega/micromega.ml @@ -0,0 +1,1512 @@ +type __ = Obj.t +let __ = let rec f _ = Obj.repr f in Obj.repr f + +type bool = + | True + | False + +(** val negb : bool -> bool **) + +let negb = function + | True -> False + | False -> True + +type nat = + | O + | S of nat + +type 'a option = + | Some of 'a + | None + +type ('a, 'b) prod = + | Pair of 'a * 'b + +type comparison = + | Eq + | Lt + | Gt + +(** val compOpp : comparison -> comparison **) + +let compOpp = function + | Eq -> Eq + | Lt -> Gt + | Gt -> Lt + +type sumbool = + | Left + | Right + +type 'a sumor = + | Inleft of 'a + | Inright + +type 'a list = + | Nil + | Cons of 'a * 'a list + +(** val app : 'a1 list -> 'a1 list -> 'a1 list **) + +let rec app l m = + match l with + | Nil -> m + | Cons (a, l1) -> Cons (a, (app l1 m)) + +(** val nth : nat -> 'a1 list -> 'a1 -> 'a1 **) + +let rec nth n0 l default = + match n0 with + | O -> (match l with + | Nil -> default + | Cons (x, l') -> x) + | S m -> + (match l with + | Nil -> default + | Cons (x, t0) -> nth m t0 default) + +(** val map : ('a1 -> 'a2) -> 'a1 list -> 'a2 list **) + +let rec map f = function + | Nil -> Nil + | Cons (a, t0) -> Cons ((f a), (map f t0)) + +type positive = + | XI of positive + | XO of positive + | XH + +(** val psucc : positive -> positive **) + +let rec psucc = function + | XI p -> XO (psucc p) + | XO p -> XI p + | XH -> XO XH + +(** val pplus : positive -> positive -> positive **) + +let rec pplus x y = + match x with + | XI p -> + (match y with + | XI q0 -> XO (pplus_carry p q0) + | XO q0 -> XI (pplus p q0) + | XH -> XO (psucc p)) + | XO p -> + (match y with + | XI q0 -> XI (pplus p q0) + | XO q0 -> XO (pplus p q0) + | XH -> XI p) + | XH -> + (match y with + | XI q0 -> XO (psucc q0) + | XO q0 -> XI q0 + | XH -> XO XH) + +(** val pplus_carry : positive -> positive -> positive **) + +and pplus_carry x y = + match x with + | XI p -> + (match y with + | XI q0 -> XI (pplus_carry p q0) + | XO q0 -> XO (pplus_carry p q0) + | XH -> XI (psucc p)) + | XO p -> + (match y with + | XI q0 -> XO (pplus_carry p q0) + | XO q0 -> XI (pplus p q0) + | XH -> XO (psucc p)) + | XH -> + (match y with + | XI q0 -> XI (psucc q0) + | XO q0 -> XO (psucc q0) + | XH -> XI XH) + +(** val p_of_succ_nat : nat -> positive **) + +let rec p_of_succ_nat = function + | O -> XH + | S x -> psucc (p_of_succ_nat x) + +(** val pdouble_minus_one : positive -> positive **) + +let rec pdouble_minus_one = function + | XI p -> XI (XO p) + | XO p -> XI (pdouble_minus_one p) + | XH -> XH + +type positive_mask = + | IsNul + | IsPos of positive + | IsNeg + +(** val pdouble_plus_one_mask : positive_mask -> positive_mask **) + +let pdouble_plus_one_mask = function + | IsNul -> IsPos XH + | IsPos p -> IsPos (XI p) + | IsNeg -> IsNeg + +(** val pdouble_mask : positive_mask -> positive_mask **) + +let pdouble_mask = function + | IsNul -> IsNul + | IsPos p -> IsPos (XO p) + | IsNeg -> IsNeg + +(** val pdouble_minus_two : positive -> positive_mask **) + +let pdouble_minus_two = function + | XI p -> IsPos (XO (XO p)) + | XO p -> IsPos (XO (pdouble_minus_one p)) + | XH -> IsNul + +(** val pminus_mask : positive -> positive -> positive_mask **) + +let rec pminus_mask x y = + match x with + | XI p -> + (match y with + | XI q0 -> pdouble_mask (pminus_mask p q0) + | XO q0 -> pdouble_plus_one_mask (pminus_mask p q0) + | XH -> IsPos (XO p)) + | XO p -> + (match y with + | XI q0 -> pdouble_plus_one_mask (pminus_mask_carry p q0) + | XO q0 -> pdouble_mask (pminus_mask p q0) + | XH -> IsPos (pdouble_minus_one p)) + | XH -> (match y with + | XH -> IsNul + | _ -> IsNeg) + +(** val pminus_mask_carry : positive -> positive -> positive_mask **) + +and pminus_mask_carry x y = + match x with + | XI p -> + (match y with + | XI q0 -> pdouble_plus_one_mask (pminus_mask_carry p q0) + | XO q0 -> pdouble_mask (pminus_mask p q0) + | XH -> IsPos (pdouble_minus_one p)) + | XO p -> + (match y with + | XI q0 -> pdouble_mask (pminus_mask_carry p q0) + | XO q0 -> pdouble_plus_one_mask (pminus_mask_carry p q0) + | XH -> pdouble_minus_two p) + | XH -> IsNeg + +(** val pminus : positive -> positive -> positive **) + +let pminus x y = + match pminus_mask x y with + | IsPos z0 -> z0 + | _ -> XH + +(** val pmult : positive -> positive -> positive **) + +let rec pmult x y = + match x with + | XI p -> pplus y (XO (pmult p y)) + | XO p -> XO (pmult p y) + | XH -> y + +(** val pcompare : positive -> positive -> comparison -> comparison **) + +let rec pcompare x y r = + match x with + | XI p -> + (match y with + | XI q0 -> pcompare p q0 r + | XO q0 -> pcompare p q0 Gt + | XH -> Gt) + | XO p -> + (match y with + | XI q0 -> pcompare p q0 Lt + | XO q0 -> pcompare p q0 r + | XH -> Gt) + | XH -> (match y with + | XH -> r + | _ -> Lt) + +type n = + | N0 + | Npos of positive + +type z = + | Z0 + | Zpos of positive + | Zneg of positive + +(** val zdouble_plus_one : z -> z **) + +let zdouble_plus_one = function + | Z0 -> Zpos XH + | Zpos p -> Zpos (XI p) + | Zneg p -> Zneg (pdouble_minus_one p) + +(** val zdouble_minus_one : z -> z **) + +let zdouble_minus_one = function + | Z0 -> Zneg XH + | Zpos p -> Zpos (pdouble_minus_one p) + | Zneg p -> Zneg (XI p) + +(** val zdouble : z -> z **) + +let zdouble = function + | Z0 -> Z0 + | Zpos p -> Zpos (XO p) + | Zneg p -> Zneg (XO p) + +(** val zPminus : positive -> positive -> z **) + +let rec zPminus x y = + match x with + | XI p -> + (match y with + | XI q0 -> zdouble (zPminus p q0) + | XO q0 -> zdouble_plus_one (zPminus p q0) + | XH -> Zpos (XO p)) + | XO p -> + (match y with + | XI q0 -> zdouble_minus_one (zPminus p q0) + | XO q0 -> zdouble (zPminus p q0) + | XH -> Zpos (pdouble_minus_one p)) + | XH -> + (match y with + | XI q0 -> Zneg (XO q0) + | XO q0 -> Zneg (pdouble_minus_one q0) + | XH -> Z0) + +(** val zplus : z -> z -> z **) + +let zplus x y = + match x with + | Z0 -> y + | Zpos x' -> + (match y with + | Z0 -> Zpos x' + | Zpos y' -> Zpos (pplus x' y') + | Zneg y' -> + (match pcompare x' y' Eq with + | Eq -> Z0 + | Lt -> Zneg (pminus y' x') + | Gt -> Zpos (pminus x' y'))) + | Zneg x' -> + (match y with + | Z0 -> Zneg x' + | Zpos y' -> + (match pcompare x' y' Eq with + | Eq -> Z0 + | Lt -> Zpos (pminus y' x') + | Gt -> Zneg (pminus x' y')) + | Zneg y' -> Zneg (pplus x' y')) + +(** val zopp : z -> z **) + +let zopp = function + | Z0 -> Z0 + | Zpos x0 -> Zneg x0 + | Zneg x0 -> Zpos x0 + +(** val zminus : z -> z -> z **) + +let zminus m n0 = + zplus m (zopp n0) + +(** val zmult : z -> z -> z **) + +let zmult x y = + match x with + | Z0 -> Z0 + | Zpos x' -> + (match y with + | Z0 -> Z0 + | Zpos y' -> Zpos (pmult x' y') + | Zneg y' -> Zneg (pmult x' y')) + | Zneg x' -> + (match y with + | Z0 -> Z0 + | Zpos y' -> Zneg (pmult x' y') + | Zneg y' -> Zpos (pmult x' y')) + +(** val zcompare : z -> z -> comparison **) + +let zcompare x y = + match x with + | Z0 -> (match y with + | Z0 -> Eq + | Zpos y' -> Lt + | Zneg y' -> Gt) + | Zpos x' -> (match y with + | Zpos y' -> pcompare x' y' Eq + | _ -> Gt) + | Zneg x' -> + (match y with + | Zneg y' -> compOpp (pcompare x' y' Eq) + | _ -> Lt) + +(** val dcompare_inf : comparison -> sumbool sumor **) + +let dcompare_inf = function + | Eq -> Inleft Left + | Lt -> Inleft Right + | Gt -> Inright + +(** val zcompare_rec : + z -> z -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 **) + +let zcompare_rec x y h1 h2 h3 = + match dcompare_inf (zcompare x y) with + | Inleft x0 -> (match x0 with + | Left -> h1 __ + | Right -> h2 __) + | Inright -> h3 __ + +(** val z_gt_dec : z -> z -> sumbool **) + +let z_gt_dec x y = + zcompare_rec x y (fun _ -> Right) (fun _ -> Right) (fun _ -> Left) + +(** val zle_bool : z -> z -> bool **) + +let zle_bool x y = + match zcompare x y with + | Gt -> False + | _ -> True + +(** val zge_bool : z -> z -> bool **) + +let zge_bool x y = + match zcompare x y with + | Lt -> False + | _ -> True + +(** val zgt_bool : z -> z -> bool **) + +let zgt_bool x y = + match zcompare x y with + | Gt -> True + | _ -> False + +(** val zeq_bool : z -> z -> bool **) + +let zeq_bool x y = + match zcompare x y with + | Eq -> True + | _ -> False + +(** val n_of_nat : nat -> n **) + +let n_of_nat = function + | O -> N0 + | S n' -> Npos (p_of_succ_nat n') + +(** val zdiv_eucl_POS : positive -> z -> (z, z) prod **) + +let rec zdiv_eucl_POS a b = + match a with + | XI a' -> + let Pair (q0, r) = zdiv_eucl_POS a' b in + let r' = zplus (zmult (Zpos (XO XH)) r) (Zpos XH) in + (match zgt_bool b r' with + | True -> Pair ((zmult (Zpos (XO XH)) q0), r') + | False -> Pair ((zplus (zmult (Zpos (XO XH)) q0) (Zpos XH)), + (zminus r' b))) + | XO a' -> + let Pair (q0, r) = zdiv_eucl_POS a' b in + let r' = zmult (Zpos (XO XH)) r in + (match zgt_bool b r' with + | True -> Pair ((zmult (Zpos (XO XH)) q0), r') + | False -> Pair ((zplus (zmult (Zpos (XO XH)) q0) (Zpos XH)), + (zminus r' b))) + | XH -> + (match zge_bool b (Zpos (XO XH)) with + | True -> Pair (Z0, (Zpos XH)) + | False -> Pair ((Zpos XH), Z0)) + +(** val zdiv_eucl : z -> z -> (z, z) prod **) + +let zdiv_eucl a b = + match a with + | Z0 -> Pair (Z0, Z0) + | Zpos a' -> + (match b with + | Z0 -> Pair (Z0, Z0) + | Zpos p -> zdiv_eucl_POS a' b + | Zneg b' -> + let Pair (q0, r) = zdiv_eucl_POS a' (Zpos b') in + (match r with + | Z0 -> Pair ((zopp q0), Z0) + | _ -> Pair ((zopp (zplus q0 (Zpos XH))), (zplus b r)))) + | Zneg a' -> + (match b with + | Z0 -> Pair (Z0, Z0) + | Zpos p -> + let Pair (q0, r) = zdiv_eucl_POS a' b in + (match r with + | Z0 -> Pair ((zopp q0), Z0) + | _ -> Pair ((zopp (zplus q0 (Zpos XH))), (zminus b r))) + | Zneg b' -> + let Pair (q0, r) = zdiv_eucl_POS a' (Zpos b') in + Pair (q0, (zopp r))) + +type 'c pol = + | Pc of 'c + | Pinj of positive * 'c pol + | PX of 'c pol * positive * 'c pol + +(** val p0 : 'a1 -> 'a1 pol **) + +let p0 cO = + Pc cO + +(** val p1 : 'a1 -> 'a1 pol **) + +let p1 cI = + Pc cI + +(** val peq : ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol -> bool **) + +let rec peq ceqb p p' = + match p with + | Pc c -> (match p' with + | Pc c' -> ceqb c c' + | _ -> False) + | Pinj (j, q0) -> + (match p' with + | Pinj (j', q') -> + (match pcompare j j' Eq with + | Eq -> peq ceqb q0 q' + | _ -> False) + | _ -> False) + | PX (p2, i, q0) -> + (match p' with + | PX (p'0, i', q') -> + (match pcompare i i' Eq with + | Eq -> + (match peq ceqb p2 p'0 with + | True -> peq ceqb q0 q' + | False -> False) + | _ -> False) + | _ -> False) + +(** val mkPinj_pred : positive -> 'a1 pol -> 'a1 pol **) + +let mkPinj_pred j p = + match j with + | XI j0 -> Pinj ((XO j0), p) + | XO j0 -> Pinj ((pdouble_minus_one j0), p) + | XH -> p + +(** val mkPX : + 'a1 -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> positive -> 'a1 pol -> 'a1 pol **) + +let mkPX cO ceqb p i q0 = + match p with + | Pc c -> + (match ceqb c cO with + | True -> + (match q0 with + | Pc c0 -> q0 + | Pinj (j', q1) -> Pinj ((pplus XH j'), q1) + | PX (p2, p3, p4) -> Pinj (XH, q0)) + | False -> PX (p, i, q0)) + | Pinj (p2, p3) -> PX (p, i, q0) + | PX (p', i', q') -> + (match peq ceqb q' (p0 cO) with + | True -> PX (p', (pplus i' i), q0) + | False -> PX (p, i, q0)) + +(** val mkXi : 'a1 -> 'a1 -> positive -> 'a1 pol **) + +let mkXi cO cI i = + PX ((p1 cI), i, (p0 cO)) + +(** val mkX : 'a1 -> 'a1 -> 'a1 pol **) + +let mkX cO cI = + mkXi cO cI XH + +(** val popp : ('a1 -> 'a1) -> 'a1 pol -> 'a1 pol **) + +let rec popp copp = function + | Pc c -> Pc (copp c) + | Pinj (j, q0) -> Pinj (j, (popp copp q0)) + | PX (p2, i, q0) -> PX ((popp copp p2), i, (popp copp q0)) + +(** val paddC : ('a1 -> 'a1 -> 'a1) -> 'a1 pol -> 'a1 -> 'a1 pol **) + +let rec paddC cadd p c = + match p with + | Pc c1 -> Pc (cadd c1 c) + | Pinj (j, q0) -> Pinj (j, (paddC cadd q0 c)) + | PX (p2, i, q0) -> PX (p2, i, (paddC cadd q0 c)) + +(** val psubC : ('a1 -> 'a1 -> 'a1) -> 'a1 pol -> 'a1 -> 'a1 pol **) + +let rec psubC csub p c = + match p with + | Pc c1 -> Pc (csub c1 c) + | Pinj (j, q0) -> Pinj (j, (psubC csub q0 c)) + | PX (p2, i, q0) -> PX (p2, i, (psubC csub q0 c)) + +(** val paddI : + ('a1 -> 'a1 -> 'a1) -> ('a1 pol -> 'a1 pol -> 'a1 pol) -> 'a1 pol -> + positive -> 'a1 pol -> 'a1 pol **) + +let rec paddI cadd pop q0 j = function + | Pc c -> + let p2 = paddC cadd q0 c in + (match p2 with + | Pc c0 -> p2 + | Pinj (j', q1) -> Pinj ((pplus j j'), q1) + | PX (p3, p4, p5) -> Pinj (j, p2)) + | Pinj (j', q') -> + (match zPminus j' j with + | Z0 -> + let p2 = pop q' q0 in + (match p2 with + | Pc c -> p2 + | Pinj (j'0, q1) -> Pinj ((pplus j j'0), q1) + | PX (p3, p4, p5) -> Pinj (j, p2)) + | Zpos k -> + let p2 = pop (Pinj (k, q')) q0 in + (match p2 with + | Pc c -> p2 + | Pinj (j'0, q1) -> Pinj ((pplus j j'0), q1) + | PX (p3, p4, p5) -> Pinj (j, p2)) + | Zneg k -> + let p2 = paddI cadd pop q0 k q' in + (match p2 with + | Pc c -> p2 + | Pinj (j'0, q1) -> Pinj ((pplus j' j'0), q1) + | PX (p3, p4, p5) -> Pinj (j', p2))) + | PX (p2, i, q') -> + (match j with + | XI j0 -> PX (p2, i, (paddI cadd pop q0 (XO j0) q')) + | XO j0 -> PX (p2, i, (paddI cadd pop q0 (pdouble_minus_one j0) q')) + | XH -> PX (p2, i, (pop q' q0))) + +(** val psubI : + ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1 pol -> 'a1 pol -> 'a1 pol) -> + 'a1 pol -> positive -> 'a1 pol -> 'a1 pol **) + +let rec psubI cadd copp pop q0 j = function + | Pc c -> + let p2 = paddC cadd (popp copp q0) c in + (match p2 with + | Pc c0 -> p2 + | Pinj (j', q1) -> Pinj ((pplus j j'), q1) + | PX (p3, p4, p5) -> Pinj (j, p2)) + | Pinj (j', q') -> + (match zPminus j' j with + | Z0 -> + let p2 = pop q' q0 in + (match p2 with + | Pc c -> p2 + | Pinj (j'0, q1) -> Pinj ((pplus j j'0), q1) + | PX (p3, p4, p5) -> Pinj (j, p2)) + | Zpos k -> + let p2 = pop (Pinj (k, q')) q0 in + (match p2 with + | Pc c -> p2 + | Pinj (j'0, q1) -> Pinj ((pplus j j'0), q1) + | PX (p3, p4, p5) -> Pinj (j, p2)) + | Zneg k -> + let p2 = psubI cadd copp pop q0 k q' in + (match p2 with + | Pc c -> p2 + | Pinj (j'0, q1) -> Pinj ((pplus j' j'0), q1) + | PX (p3, p4, p5) -> Pinj (j', p2))) + | PX (p2, i, q') -> + (match j with + | XI j0 -> PX (p2, i, (psubI cadd copp pop q0 (XO j0) q')) + | XO j0 -> PX (p2, i, + (psubI cadd copp pop q0 (pdouble_minus_one j0) q')) + | XH -> PX (p2, i, (pop q' q0))) + +(** val paddX : + 'a1 -> ('a1 -> 'a1 -> bool) -> ('a1 pol -> 'a1 pol -> 'a1 pol) -> 'a1 pol + -> positive -> 'a1 pol -> 'a1 pol **) + +let rec paddX cO ceqb pop p' i' p = match p with + | Pc c -> PX (p', i', p) + | Pinj (j, q') -> + (match j with + | XI j0 -> PX (p', i', (Pinj ((XO j0), q'))) + | XO j0 -> PX (p', i', (Pinj ((pdouble_minus_one j0), q'))) + | XH -> PX (p', i', q')) + | PX (p2, i, q') -> + (match zPminus i i' with + | Z0 -> mkPX cO ceqb (pop p2 p') i q' + | Zpos k -> mkPX cO ceqb (pop (PX (p2, k, (p0 cO))) p') i' q' + | Zneg k -> mkPX cO ceqb (paddX cO ceqb pop p' k p2) i q') + +(** val psubX : + 'a1 -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 pol -> 'a1 pol -> 'a1 + pol) -> 'a1 pol -> positive -> 'a1 pol -> 'a1 pol **) + +let rec psubX cO copp ceqb pop p' i' p = match p with + | Pc c -> PX ((popp copp p'), i', p) + | Pinj (j, q') -> + (match j with + | XI j0 -> PX ((popp copp p'), i', (Pinj ((XO j0), q'))) + | XO j0 -> PX ((popp copp p'), i', (Pinj ( + (pdouble_minus_one j0), q'))) + | XH -> PX ((popp copp p'), i', q')) + | PX (p2, i, q') -> + (match zPminus i i' with + | Z0 -> mkPX cO ceqb (pop p2 p') i q' + | Zpos k -> mkPX cO ceqb (pop (PX (p2, k, (p0 cO))) p') i' q' + | Zneg k -> mkPX cO ceqb (psubX cO copp ceqb pop p' k p2) i q') + +(** val padd : + 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol + -> 'a1 pol **) + +let rec padd cO cadd ceqb p = function + | Pc c' -> paddC cadd p c' + | Pinj (j', q') -> paddI cadd (fun x x0 -> padd cO cadd ceqb x x0) q' j' p + | PX (p'0, i', q') -> + (match p with + | Pc c -> PX (p'0, i', (paddC cadd q' c)) + | Pinj (j, q0) -> + (match j with + | XI j0 -> PX (p'0, i', + (padd cO cadd ceqb (Pinj ((XO j0), q0)) q')) + | XO j0 -> PX (p'0, i', + (padd cO cadd ceqb (Pinj ((pdouble_minus_one j0), q0)) + q')) + | XH -> PX (p'0, i', (padd cO cadd ceqb q0 q'))) + | PX (p2, i, q0) -> + (match zPminus i i' with + | Z0 -> + mkPX cO ceqb (padd cO cadd ceqb p2 p'0) i + (padd cO cadd ceqb q0 q') + | Zpos k -> + mkPX cO ceqb + (padd cO cadd ceqb (PX (p2, k, (p0 cO))) p'0) i' + (padd cO cadd ceqb q0 q') + | Zneg k -> + mkPX cO ceqb + (paddX cO ceqb (fun x x0 -> padd cO cadd ceqb x x0) p'0 + k p2) i (padd cO cadd ceqb q0 q'))) + +(** val psub : + 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1 + -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol -> 'a1 pol **) + +let rec psub cO cadd csub copp ceqb p = function + | Pc c' -> psubC csub p c' + | Pinj (j', q') -> + psubI cadd copp (fun x x0 -> psub cO cadd csub copp ceqb x x0) q' j' p + | PX (p'0, i', q') -> + (match p with + | Pc c -> PX ((popp copp p'0), i', (paddC cadd (popp copp q') c)) + | Pinj (j, q0) -> + (match j with + | XI j0 -> PX ((popp copp p'0), i', + (psub cO cadd csub copp ceqb (Pinj ((XO j0), q0)) q')) + | XO j0 -> PX ((popp copp p'0), i', + (psub cO cadd csub copp ceqb (Pinj + ((pdouble_minus_one j0), q0)) q')) + | XH -> PX ((popp copp p'0), i', + (psub cO cadd csub copp ceqb q0 q'))) + | PX (p2, i, q0) -> + (match zPminus i i' with + | Z0 -> + mkPX cO ceqb (psub cO cadd csub copp ceqb p2 p'0) i + (psub cO cadd csub copp ceqb q0 q') + | Zpos k -> + mkPX cO ceqb + (psub cO cadd csub copp ceqb (PX (p2, k, (p0 cO))) p'0) + i' (psub cO cadd csub copp ceqb q0 q') + | Zneg k -> + mkPX cO ceqb + (psubX cO copp ceqb (fun x x0 -> + psub cO cadd csub copp ceqb x x0) p'0 k p2) i + (psub cO cadd csub copp ceqb q0 q'))) + +(** val pmulC_aux : + 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 -> + 'a1 pol **) + +let rec pmulC_aux cO cmul ceqb p c = + match p with + | Pc c' -> Pc (cmul c' c) + | Pinj (j, q0) -> + let p2 = pmulC_aux cO cmul ceqb q0 c in + (match p2 with + | Pc c0 -> p2 + | Pinj (j', q1) -> Pinj ((pplus j j'), q1) + | PX (p3, p4, p5) -> Pinj (j, p2)) + | PX (p2, i, q0) -> + mkPX cO ceqb (pmulC_aux cO cmul ceqb p2 c) i + (pmulC_aux cO cmul ceqb q0 c) + +(** val pmulC : + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> + 'a1 -> 'a1 pol **) + +let pmulC cO cI cmul ceqb p c = + match ceqb c cO with + | True -> p0 cO + | False -> + (match ceqb c cI with + | True -> p + | False -> pmulC_aux cO cmul ceqb p c) + +(** val pmulI : + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 pol -> + 'a1 pol -> 'a1 pol) -> 'a1 pol -> positive -> 'a1 pol -> 'a1 pol **) + +let rec pmulI cO cI cmul ceqb pmul0 q0 j = function + | Pc c -> + let p2 = pmulC cO cI cmul ceqb q0 c in + (match p2 with + | Pc c0 -> p2 + | Pinj (j', q1) -> Pinj ((pplus j j'), q1) + | PX (p3, p4, p5) -> Pinj (j, p2)) + | Pinj (j', q') -> + (match zPminus j' j with + | Z0 -> + let p2 = pmul0 q' q0 in + (match p2 with + | Pc c -> p2 + | Pinj (j'0, q1) -> Pinj ((pplus j j'0), q1) + | PX (p3, p4, p5) -> Pinj (j, p2)) + | Zpos k -> + let p2 = pmul0 (Pinj (k, q')) q0 in + (match p2 with + | Pc c -> p2 + | Pinj (j'0, q1) -> Pinj ((pplus j j'0), q1) + | PX (p3, p4, p5) -> Pinj (j, p2)) + | Zneg k -> + let p2 = pmulI cO cI cmul ceqb pmul0 q0 k q' in + (match p2 with + | Pc c -> p2 + | Pinj (j'0, q1) -> Pinj ((pplus j' j'0), q1) + | PX (p3, p4, p5) -> Pinj (j', p2))) + | PX (p', i', q') -> + (match j with + | XI j' -> + mkPX cO ceqb (pmulI cO cI cmul ceqb pmul0 q0 j p') i' + (pmulI cO cI cmul ceqb pmul0 q0 (XO j') q') + | XO j' -> + mkPX cO ceqb (pmulI cO cI cmul ceqb pmul0 q0 j p') i' + (pmulI cO cI cmul ceqb pmul0 q0 (pdouble_minus_one j') q') + | XH -> + mkPX cO ceqb (pmulI cO cI cmul ceqb pmul0 q0 XH p') i' + (pmul0 q' q0)) + +(** val pmul : + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 + -> bool) -> 'a1 pol -> 'a1 pol -> 'a1 pol **) + +let rec pmul cO cI cadd cmul ceqb p p'' = match p'' with + | Pc c -> pmulC cO cI cmul ceqb p c + | Pinj (j', q') -> + pmulI cO cI cmul ceqb (fun x x0 -> pmul cO cI cadd cmul ceqb x x0) q' + j' p + | PX (p', i', q') -> + (match p with + | Pc c -> pmulC cO cI cmul ceqb p'' c + | Pinj (j, q0) -> + mkPX cO ceqb (pmul cO cI cadd cmul ceqb p p') i' + (match j with + | XI j0 -> + pmul cO cI cadd cmul ceqb (Pinj ((XO j0), q0)) q' + | XO j0 -> + pmul cO cI cadd cmul ceqb (Pinj + ((pdouble_minus_one j0), q0)) q' + | XH -> pmul cO cI cadd cmul ceqb q0 q') + | PX (p2, i, q0) -> + padd cO cadd ceqb + (mkPX cO ceqb + (padd cO cadd ceqb + (mkPX cO ceqb (pmul cO cI cadd cmul ceqb p2 p') i (p0 cO)) + (pmul cO cI cadd cmul ceqb + (match q0 with + | Pc c -> q0 + | Pinj (j', q1) -> Pinj ((pplus XH j'), q1) + | PX (p3, p4, p5) -> Pinj (XH, q0)) p')) i' + (p0 cO)) + (mkPX cO ceqb + (pmulI cO cI cmul ceqb (fun x x0 -> + pmul cO cI cadd cmul ceqb x x0) q' XH p2) i + (pmul cO cI cadd cmul ceqb q0 q'))) + +type 'c pExpr = + | PEc of 'c + | PEX of positive + | PEadd of 'c pExpr * 'c pExpr + | PEsub of 'c pExpr * 'c pExpr + | PEmul of 'c pExpr * 'c pExpr + | PEopp of 'c pExpr + | PEpow of 'c pExpr * n + +(** val mk_X : 'a1 -> 'a1 -> positive -> 'a1 pol **) + +let mk_X cO cI j = + mkPinj_pred j (mkX cO cI) + +(** val ppow_pos : + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 + -> bool) -> ('a1 pol -> 'a1 pol) -> 'a1 pol -> 'a1 pol -> positive -> 'a1 + pol **) + +let rec ppow_pos cO cI cadd cmul ceqb subst_l res p = function + | XI p3 -> + subst_l + (pmul cO cI cadd cmul ceqb + (ppow_pos cO cI cadd cmul ceqb subst_l + (ppow_pos cO cI cadd cmul ceqb subst_l res p p3) p p3) p) + | XO p3 -> + ppow_pos cO cI cadd cmul ceqb subst_l + (ppow_pos cO cI cadd cmul ceqb subst_l res p p3) p p3 + | XH -> subst_l (pmul cO cI cadd cmul ceqb res p) + +(** val ppow_N : + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 + -> bool) -> ('a1 pol -> 'a1 pol) -> 'a1 pol -> n -> 'a1 pol **) + +let ppow_N cO cI cadd cmul ceqb subst_l p = function + | N0 -> p1 cI + | Npos p2 -> ppow_pos cO cI cadd cmul ceqb subst_l (p1 cI) p p2 + +(** val norm_aux : + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 + -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pExpr -> 'a1 pol **) + +let rec norm_aux cO cI cadd cmul csub copp ceqb = function + | PEc c -> Pc c + | PEX j -> mk_X cO cI j + | PEadd (pe1, pe2) -> + (match pe1 with + | PEopp pe3 -> + psub cO cadd csub copp ceqb + (norm_aux cO cI cadd cmul csub copp ceqb pe2) + (norm_aux cO cI cadd cmul csub copp ceqb pe3) + | _ -> + (match pe2 with + | PEopp pe3 -> + psub cO cadd csub copp ceqb + (norm_aux cO cI cadd cmul csub copp ceqb pe1) + (norm_aux cO cI cadd cmul csub copp ceqb pe3) + | _ -> + padd cO cadd ceqb + (norm_aux cO cI cadd cmul csub copp ceqb pe1) + (norm_aux cO cI cadd cmul csub copp ceqb pe2))) + | PEsub (pe1, pe2) -> + psub cO cadd csub copp ceqb + (norm_aux cO cI cadd cmul csub copp ceqb pe1) + (norm_aux cO cI cadd cmul csub copp ceqb pe2) + | PEmul (pe1, pe2) -> + pmul cO cI cadd cmul ceqb (norm_aux cO cI cadd cmul csub copp ceqb pe1) + (norm_aux cO cI cadd cmul csub copp ceqb pe2) + | PEopp pe1 -> popp copp (norm_aux cO cI cadd cmul csub copp ceqb pe1) + | PEpow (pe1, n0) -> + ppow_N cO cI cadd cmul ceqb (fun p -> p) + (norm_aux cO cI cadd cmul csub copp ceqb pe1) n0 + +type 'a bFormula = + | TT + | FF + | X + | A of 'a + | Cj of 'a bFormula * 'a bFormula + | D of 'a bFormula * 'a bFormula + | N of 'a bFormula + | I of 'a bFormula * 'a bFormula + +type 'term' clause = 'term' list + +type 'term' cnf = 'term' clause list + +(** val tt : 'a1 cnf **) + +let tt = + Nil + +(** val ff : 'a1 cnf **) + +let ff = + Cons (Nil, Nil) + +(** val or_clause_cnf : 'a1 clause -> 'a1 cnf -> 'a1 cnf **) + +let or_clause_cnf t0 f = + map (fun x -> app t0 x) f + +(** val or_cnf : 'a1 cnf -> 'a1 cnf -> 'a1 cnf **) + +let rec or_cnf f f' = + match f with + | Nil -> tt + | Cons (e, rst) -> app (or_cnf rst f') (or_clause_cnf e f') + +(** val and_cnf : 'a1 cnf -> 'a1 cnf -> 'a1 cnf **) + +let and_cnf f1 f2 = + app f1 f2 + +(** val xcnf : + ('a1 -> 'a2 cnf) -> ('a1 -> 'a2 cnf) -> bool -> 'a1 bFormula -> 'a2 cnf **) + +let rec xcnf normalise0 negate0 pol0 = function + | TT -> (match pol0 with + | True -> tt + | False -> ff) + | FF -> (match pol0 with + | True -> ff + | False -> tt) + | X -> ff + | A x -> (match pol0 with + | True -> normalise0 x + | False -> negate0 x) + | Cj (e1, e2) -> + (match pol0 with + | True -> + and_cnf (xcnf normalise0 negate0 pol0 e1) + (xcnf normalise0 negate0 pol0 e2) + | False -> + or_cnf (xcnf normalise0 negate0 pol0 e1) + (xcnf normalise0 negate0 pol0 e2)) + | D (e1, e2) -> + (match pol0 with + | True -> + or_cnf (xcnf normalise0 negate0 pol0 e1) + (xcnf normalise0 negate0 pol0 e2) + | False -> + and_cnf (xcnf normalise0 negate0 pol0 e1) + (xcnf normalise0 negate0 pol0 e2)) + | N e -> xcnf normalise0 negate0 (negb pol0) e + | I (e1, e2) -> + (match pol0 with + | True -> + or_cnf (xcnf normalise0 negate0 (negb pol0) e1) + (xcnf normalise0 negate0 pol0 e2) + | False -> + and_cnf (xcnf normalise0 negate0 (negb pol0) e1) + (xcnf normalise0 negate0 pol0 e2)) + +(** val cnf_checker : + ('a1 list -> 'a2 -> bool) -> 'a1 cnf -> 'a2 list -> bool **) + +let rec cnf_checker checker f l = + match f with + | Nil -> True + | Cons (e, f0) -> + (match l with + | Nil -> False + | Cons (c, l0) -> + (match checker e c with + | True -> cnf_checker checker f0 l0 + | False -> False)) + +(** val tauto_checker : + ('a1 -> 'a2 cnf) -> ('a1 -> 'a2 cnf) -> ('a2 list -> 'a3 -> bool) -> 'a1 + bFormula -> 'a3 list -> bool **) + +let tauto_checker normalise0 negate0 checker f w = + cnf_checker checker (xcnf normalise0 negate0 True f) w + +type 'c pExprC = 'c pExpr + +type 'c polC = 'c pol + +type op1 = + | Equal + | NonEqual + | Strict + | NonStrict + +type 'c nFormula = ('c pExprC, op1) prod + +type monoidMember = nat list + +type 'c coneMember = + | S_In of nat + | S_Ideal of 'c pExprC * 'c coneMember + | S_Square of 'c pExprC + | S_Monoid of monoidMember + | S_Mult of 'c coneMember * 'c coneMember + | S_Add of 'c coneMember * 'c coneMember + | S_Pos of 'c + | S_Z + +(** val nformula_times : 'a1 nFormula -> 'a1 nFormula -> 'a1 nFormula **) + +let nformula_times f f' = + let Pair (p, op) = f in + let Pair (p', op') = f' in + Pair ((PEmul (p, p')), + (match op with + | Equal -> Equal + | NonEqual -> NonEqual + | Strict -> op' + | NonStrict -> NonStrict)) + +(** val nformula_plus : 'a1 nFormula -> 'a1 nFormula -> 'a1 nFormula **) + +let nformula_plus f f' = + let Pair (p, op) = f in + let Pair (p', op') = f' in + Pair ((PEadd (p, p')), + (match op with + | Equal -> op' + | NonEqual -> NonEqual + | Strict -> Strict + | NonStrict -> (match op' with + | Strict -> Strict + | _ -> NonStrict))) + +(** val eval_monoid : + 'a1 -> 'a1 nFormula list -> monoidMember -> 'a1 pExprC **) + +let rec eval_monoid cI l = function + | Nil -> PEc cI + | Cons (n0, ns0) -> PEmul + ((let Pair (q0, o) = nth n0 l (Pair ((PEc cI), NonEqual)) in + (match o with + | NonEqual -> q0 + | _ -> PEc cI)), (eval_monoid cI l ns0)) + +(** val eval_cone : + 'a1 -> 'a1 -> ('a1 -> 'a1 -> bool) -> ('a1 -> 'a1 -> bool) -> 'a1 + nFormula list -> 'a1 coneMember -> 'a1 nFormula **) + +let rec eval_cone cO cI ceqb cleb l = function + | S_In n0 -> + let Pair (p, o) = nth n0 l (Pair ((PEc cO), Equal)) in + (match o with + | NonEqual -> Pair ((PEc cO), Equal) + | _ -> nth n0 l (Pair ((PEc cO), Equal))) + | S_Ideal (p, cm') -> + let f = eval_cone cO cI ceqb cleb l cm' in + let Pair (q0, op) = f in + (match op with + | Equal -> Pair ((PEmul (q0, p)), Equal) + | _ -> f) + | S_Square p -> Pair ((PEmul (p, p)), NonStrict) + | S_Monoid m -> let p = eval_monoid cI l m in Pair ((PEmul (p, p)), Strict) + | S_Mult (p, q0) -> + nformula_times (eval_cone cO cI ceqb cleb l p) + (eval_cone cO cI ceqb cleb l q0) + | S_Add (p, q0) -> + nformula_plus (eval_cone cO cI ceqb cleb l p) + (eval_cone cO cI ceqb cleb l q0) + | S_Pos c -> + (match match cleb cO c with + | True -> negb (ceqb cO c) + | False -> False with + | True -> Pair ((PEc c), Strict) + | False -> Pair ((PEc cO), Equal)) + | S_Z -> Pair ((PEc cO), Equal) + +(** val normalise_pexpr : + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 + -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pExprC -> 'a1 polC **) + +let normalise_pexpr cO cI cplus ctimes cminus copp ceqb x = + norm_aux cO cI cplus ctimes cminus copp ceqb x + +(** val check_inconsistent : + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 + -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 -> 'a1 -> bool) + -> 'a1 nFormula -> bool **) + +let check_inconsistent cO cI cplus ctimes cminus copp ceqb cleb = function + | Pair (e, op) -> + (match normalise_pexpr cO cI cplus ctimes cminus copp ceqb e with + | Pc c -> + (match op with + | Equal -> negb (ceqb c cO) + | NonEqual -> False + | Strict -> cleb c cO + | NonStrict -> + (match cleb c cO with + | True -> negb (ceqb c cO) + | False -> False)) + | _ -> False) + +(** val check_normalised_formulas : + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 + -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 -> 'a1 -> bool) + -> 'a1 nFormula list -> 'a1 coneMember -> bool **) + +let check_normalised_formulas cO cI cplus ctimes cminus copp ceqb cleb l cm = + check_inconsistent cO cI cplus ctimes cminus copp ceqb cleb + (eval_cone cO cI ceqb cleb l cm) + +type op2 = + | OpEq + | OpNEq + | OpLe + | OpGe + | OpLt + | OpGt + +type 'c formula = { flhs : 'c pExprC; fop : op2; frhs : 'c pExprC } + +(** val flhs : 'a1 formula -> 'a1 pExprC **) + +let flhs x = x.flhs + +(** val fop : 'a1 formula -> op2 **) + +let fop x = x.fop + +(** val frhs : 'a1 formula -> 'a1 pExprC **) + +let frhs x = x.frhs + +(** val xnormalise : 'a1 formula -> 'a1 nFormula list **) + +let xnormalise t0 = + let { flhs = lhs; fop = o; frhs = rhs } = t0 in + (match o with + | OpEq -> Cons ((Pair ((PEsub (lhs, rhs)), Strict)), (Cons ((Pair + ((PEsub (rhs, lhs)), Strict)), Nil))) + | OpNEq -> Cons ((Pair ((PEsub (lhs, rhs)), Equal)), Nil) + | OpLe -> Cons ((Pair ((PEsub (lhs, rhs)), Strict)), Nil) + | OpGe -> Cons ((Pair ((PEsub (rhs, lhs)), Strict)), Nil) + | OpLt -> Cons ((Pair ((PEsub (lhs, rhs)), NonStrict)), Nil) + | OpGt -> Cons ((Pair ((PEsub (rhs, lhs)), NonStrict)), Nil)) + +(** val cnf_normalise : 'a1 formula -> 'a1 nFormula cnf **) + +let cnf_normalise t0 = + map (fun x -> Cons (x, Nil)) (xnormalise t0) + +(** val xnegate : 'a1 formula -> 'a1 nFormula list **) + +let xnegate t0 = + let { flhs = lhs; fop = o; frhs = rhs } = t0 in + (match o with + | OpEq -> Cons ((Pair ((PEsub (lhs, rhs)), Equal)), Nil) + | OpNEq -> Cons ((Pair ((PEsub (lhs, rhs)), Strict)), (Cons ((Pair + ((PEsub (rhs, lhs)), Strict)), Nil))) + | OpLe -> Cons ((Pair ((PEsub (rhs, lhs)), NonStrict)), Nil) + | OpGe -> Cons ((Pair ((PEsub (lhs, rhs)), NonStrict)), Nil) + | OpLt -> Cons ((Pair ((PEsub (rhs, lhs)), Strict)), Nil) + | OpGt -> Cons ((Pair ((PEsub (lhs, rhs)), Strict)), Nil)) + +(** val cnf_negate : 'a1 formula -> 'a1 nFormula cnf **) + +let cnf_negate t0 = + map (fun x -> Cons (x, Nil)) (xnegate t0) + +(** val simpl_expr : + 'a1 -> ('a1 -> 'a1 -> bool) -> 'a1 pExprC -> 'a1 pExprC **) + +let rec simpl_expr cI ceqb e = match e with + | PEadd (x, y) -> PEadd ((simpl_expr cI ceqb x), (simpl_expr cI ceqb y)) + | PEmul (y, z0) -> + let y' = simpl_expr cI ceqb y in + (match y' with + | PEc c -> + (match ceqb c cI with + | True -> simpl_expr cI ceqb z0 + | False -> PEmul (y', (simpl_expr cI ceqb z0))) + | _ -> PEmul (y', (simpl_expr cI ceqb z0))) + | _ -> e + +(** val simpl_cone : + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 + coneMember -> 'a1 coneMember **) + +let simpl_cone cO cI ctimes ceqb e = match e with + | S_Square t0 -> + (match simpl_expr cI ceqb t0 with + | PEc c -> + (match ceqb cO c with + | True -> S_Z + | False -> S_Pos (ctimes c c)) + | _ -> S_Square (simpl_expr cI ceqb t0)) + | S_Mult (t1, t2) -> + (match t1 with + | S_Mult (x, x0) -> + (match x with + | S_Pos p2 -> + (match t2 with + | S_Pos c -> S_Mult ((S_Pos (ctimes c p2)), x0) + | S_Z -> S_Z + | _ -> e) + | _ -> + (match x0 with + | S_Pos p2 -> + (match t2 with + | S_Pos c -> S_Mult ((S_Pos (ctimes c p2)), x) + | S_Z -> S_Z + | _ -> e) + | _ -> + (match t2 with + | S_Pos c -> + (match ceqb cI c with + | True -> t1 + | False -> S_Mult (t1, t2)) + | S_Z -> S_Z + | _ -> e))) + | S_Pos c -> + (match t2 with + | S_Mult (x, x0) -> + (match x with + | S_Pos p2 -> S_Mult ((S_Pos (ctimes c p2)), x0) + | _ -> + (match x0 with + | S_Pos p2 -> S_Mult ((S_Pos (ctimes c p2)), x) + | _ -> + (match ceqb cI c with + | True -> t2 + | False -> S_Mult (t1, t2)))) + | S_Add (y, z0) -> S_Add ((S_Mult ((S_Pos c), y)), (S_Mult + ((S_Pos c), z0))) + | S_Pos c0 -> S_Pos (ctimes c c0) + | S_Z -> S_Z + | _ -> + (match ceqb cI c with + | True -> t2 + | False -> S_Mult (t1, t2))) + | S_Z -> S_Z + | _ -> + (match t2 with + | S_Pos c -> + (match ceqb cI c with + | True -> t1 + | False -> S_Mult (t1, t2)) + | S_Z -> S_Z + | _ -> e)) + | S_Add (t1, t2) -> + (match t1 with + | S_Z -> t2 + | _ -> (match t2 with + | S_Z -> t1 + | _ -> S_Add (t1, t2))) + | _ -> e + +type q = { qnum : z; qden : positive } + +(** val qnum : q -> z **) + +let qnum x = x.qnum + +(** val qden : q -> positive **) + +let qden x = x.qden + +(** val qplus : q -> q -> q **) + +let qplus x y = + { qnum = (zplus (zmult x.qnum (Zpos y.qden)) (zmult y.qnum (Zpos x.qden))); + qden = (pmult x.qden y.qden) } + +(** val qmult : q -> q -> q **) + +let qmult x y = + { qnum = (zmult x.qnum y.qnum); qden = (pmult x.qden y.qden) } + +(** val qopp : q -> q **) + +let qopp x = + { qnum = (zopp x.qnum); qden = x.qden } + +(** val qminus : q -> q -> q **) + +let qminus x y = + qplus x (qopp y) + +type 'a t = + | Empty + | Leaf of 'a + | Node of 'a t * 'a * 'a t + +(** val find : 'a1 -> 'a1 t -> positive -> 'a1 **) + +let rec find default vm p = + match vm with + | Empty -> default + | Leaf i -> i + | Node (l, e, r) -> + (match p with + | XI p2 -> find default r p2 + | XO p2 -> find default l p2 + | XH -> e) + +type zWitness = z coneMember + +(** val zWeakChecker : z nFormula list -> z coneMember -> bool **) + +let zWeakChecker x x0 = + check_normalised_formulas Z0 (Zpos XH) zplus zmult zminus zopp zeq_bool + zle_bool x x0 + +(** val xnormalise0 : z formula -> z nFormula list **) + +let xnormalise0 t0 = + let { flhs = lhs; fop = o; frhs = rhs } = t0 in + (match o with + | OpEq -> Cons ((Pair ((PEsub (lhs, (PEadd (rhs, (PEc (Zpos XH)))))), + NonStrict)), (Cons ((Pair ((PEsub (rhs, (PEadd (lhs, (PEc (Zpos + XH)))))), NonStrict)), Nil))) + | OpNEq -> Cons ((Pair ((PEsub (lhs, rhs)), Equal)), Nil) + | OpLe -> Cons ((Pair ((PEsub (lhs, (PEadd (rhs, (PEc (Zpos XH)))))), + NonStrict)), Nil) + | OpGe -> Cons ((Pair ((PEsub (rhs, (PEadd (lhs, (PEc (Zpos XH)))))), + NonStrict)), Nil) + | OpLt -> Cons ((Pair ((PEsub (lhs, rhs)), NonStrict)), Nil) + | OpGt -> Cons ((Pair ((PEsub (rhs, lhs)), NonStrict)), Nil)) + +(** val normalise : z formula -> z nFormula cnf **) + +let normalise t0 = + map (fun x -> Cons (x, Nil)) (xnormalise0 t0) + +(** val xnegate0 : z formula -> z nFormula list **) + +let xnegate0 t0 = + let { flhs = lhs; fop = o; frhs = rhs } = t0 in + (match o with + | OpEq -> Cons ((Pair ((PEsub (lhs, rhs)), Equal)), Nil) + | OpNEq -> Cons ((Pair ((PEsub (lhs, (PEadd (rhs, (PEc (Zpos XH)))))), + NonStrict)), (Cons ((Pair ((PEsub (rhs, (PEadd (lhs, (PEc (Zpos + XH)))))), NonStrict)), Nil))) + | OpLe -> Cons ((Pair ((PEsub (rhs, lhs)), NonStrict)), Nil) + | OpGe -> Cons ((Pair ((PEsub (lhs, rhs)), NonStrict)), Nil) + | OpLt -> Cons ((Pair ((PEsub (rhs, (PEadd (lhs, (PEc (Zpos XH)))))), + NonStrict)), Nil) + | OpGt -> Cons ((Pair ((PEsub (lhs, (PEadd (rhs, (PEc (Zpos XH)))))), + NonStrict)), Nil)) + +(** val negate : z formula -> z nFormula cnf **) + +let negate t0 = + map (fun x -> Cons (x, Nil)) (xnegate0 t0) + +(** val ceiling : z -> z -> z **) + +let ceiling a b = + let Pair (q0, r) = zdiv_eucl a b in + (match r with + | Z0 -> q0 + | _ -> zplus q0 (Zpos XH)) + +type proofTerm = + | RatProof of zWitness + | CutProof of z pExprC * q * zWitness * proofTerm + | EnumProof of q * z pExprC * q * zWitness * zWitness * proofTerm list + +(** val makeLb : z pExpr -> q -> z nFormula **) + +let makeLb v q0 = + let { qnum = n0; qden = d } = q0 in + Pair ((PEsub ((PEmul ((PEc (Zpos d)), v)), (PEc n0))), NonStrict) + +(** val qceiling : q -> z **) + +let qceiling q0 = + let { qnum = n0; qden = d } = q0 in ceiling n0 (Zpos d) + +(** val makeLbCut : z pExprC -> q -> z nFormula **) + +let makeLbCut v q0 = + Pair ((PEsub (v, (PEc (qceiling q0)))), NonStrict) + +(** val neg_nformula : z nFormula -> (z pExpr, op1) prod **) + +let neg_nformula = function + | Pair (e, o) -> Pair ((PEopp (PEadd (e, (PEc (Zpos XH))))), o) + +(** val cutChecker : + z nFormula list -> z pExpr -> q -> zWitness -> z nFormula option **) + +let cutChecker l e lb pf = + match zWeakChecker (Cons ((neg_nformula (makeLb e lb)), l)) pf with + | True -> Some (makeLbCut e lb) + | False -> None + +(** val zChecker : z nFormula list -> proofTerm -> bool **) + +let rec zChecker l = function + | RatProof pf0 -> zWeakChecker l pf0 + | CutProof (e, q0, pf0, rst) -> + (match cutChecker l e q0 pf0 with + | Some c -> zChecker (Cons (c, l)) rst + | None -> False) + | EnumProof (lb, e, ub, pf1, pf2, rst) -> + (match cutChecker l e lb pf1 with + | Some n0 -> + (match cutChecker l (PEopp e) (qopp ub) pf2 with + | Some n1 -> + let rec label pfs lb0 ub0 = + match pfs with + | Nil -> + (match z_gt_dec lb0 ub0 with + | Left -> True + | Right -> False) + | Cons (pf0, rsr) -> + (match zChecker (Cons ((Pair ((PEsub (e, (PEc + lb0))), Equal)), l)) pf0 with + | True -> label rsr (zplus lb0 (Zpos XH)) ub0 + | False -> False) + in label rst (qceiling lb) (zopp (qceiling (qopp ub))) + | None -> False) + | None -> False) + +(** val zTautoChecker : z formula bFormula -> proofTerm list -> bool **) + +let zTautoChecker f w = + tauto_checker normalise negate zChecker f w + +(** val map_cone : (nat -> nat) -> zWitness -> zWitness **) + +let rec map_cone f e = match e with + | S_In n0 -> S_In (f n0) + | S_Ideal (e0, cm) -> S_Ideal (e0, (map_cone f cm)) + | S_Monoid l -> S_Monoid (map f l) + | S_Mult (cm1, cm2) -> S_Mult ((map_cone f cm1), (map_cone f cm2)) + | S_Add (cm1, cm2) -> S_Add ((map_cone f cm1), (map_cone f cm2)) + | _ -> e + +(** val indexes : zWitness -> nat list **) + +let rec indexes = function + | S_In n0 -> Cons (n0, Nil) + | S_Ideal (e0, cm) -> indexes cm + | S_Monoid l -> l + | S_Mult (cm1, cm2) -> app (indexes cm1) (indexes cm2) + | S_Add (cm1, cm2) -> app (indexes cm1) (indexes cm2) + | _ -> Nil + +(** val n_of_Z : z -> n **) + +let n_of_Z = function + | Zpos p -> Npos p + | _ -> N0 + +(** val qeq_bool : q -> q -> bool **) + +let qeq_bool p q0 = + zeq_bool (zmult p.qnum (Zpos q0.qden)) (zmult q0.qnum (Zpos p.qden)) + +(** val qle_bool : q -> q -> bool **) + +let qle_bool x y = + zle_bool (zmult x.qnum (Zpos y.qden)) (zmult y.qnum (Zpos x.qden)) + +type qWitness = q coneMember + +(** val qWeakChecker : q nFormula list -> q coneMember -> bool **) + +let qWeakChecker x x0 = + check_normalised_formulas { qnum = Z0; qden = XH } { qnum = (Zpos XH); + qden = XH } qplus qmult qminus qopp qeq_bool qle_bool x x0 + +(** val qTautoChecker : q formula bFormula -> qWitness list -> bool **) + +let qTautoChecker f w = + tauto_checker (fun x -> cnf_normalise x) (fun x -> + cnf_negate x) qWeakChecker f w + diff --git a/contrib/micromega/micromega.mli b/contrib/micromega/micromega.mli new file mode 100644 index 00000000..f94f091e --- /dev/null +++ b/contrib/micromega/micromega.mli @@ -0,0 +1,398 @@ +type __ = Obj.t + +type bool = + | True + | False + +val negb : bool -> bool + +type nat = + | O + | S of nat + +type 'a option = + | Some of 'a + | None + +type ('a, 'b) prod = + | Pair of 'a * 'b + +type comparison = + | Eq + | Lt + | Gt + +val compOpp : comparison -> comparison + +type sumbool = + | Left + | Right + +type 'a sumor = + | Inleft of 'a + | Inright + +type 'a list = + | Nil + | Cons of 'a * 'a list + +val app : 'a1 list -> 'a1 list -> 'a1 list + +val nth : nat -> 'a1 list -> 'a1 -> 'a1 + +val map : ('a1 -> 'a2) -> 'a1 list -> 'a2 list + +type positive = + | XI of positive + | XO of positive + | XH + +val psucc : positive -> positive + +val pplus : positive -> positive -> positive + +val pplus_carry : positive -> positive -> positive + +val p_of_succ_nat : nat -> positive + +val pdouble_minus_one : positive -> positive + +type positive_mask = + | IsNul + | IsPos of positive + | IsNeg + +val pdouble_plus_one_mask : positive_mask -> positive_mask + +val pdouble_mask : positive_mask -> positive_mask + +val pdouble_minus_two : positive -> positive_mask + +val pminus_mask : positive -> positive -> positive_mask + +val pminus_mask_carry : positive -> positive -> positive_mask + +val pminus : positive -> positive -> positive + +val pmult : positive -> positive -> positive + +val pcompare : positive -> positive -> comparison -> comparison + +type n = + | N0 + | Npos of positive + +type z = + | Z0 + | Zpos of positive + | Zneg of positive + +val zdouble_plus_one : z -> z + +val zdouble_minus_one : z -> z + +val zdouble : z -> z + +val zPminus : positive -> positive -> z + +val zplus : z -> z -> z + +val zopp : z -> z + +val zminus : z -> z -> z + +val zmult : z -> z -> z + +val zcompare : z -> z -> comparison + +val dcompare_inf : comparison -> sumbool sumor + +val zcompare_rec : z -> z -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 + +val z_gt_dec : z -> z -> sumbool + +val zle_bool : z -> z -> bool + +val zge_bool : z -> z -> bool + +val zgt_bool : z -> z -> bool + +val zeq_bool : z -> z -> bool + +val n_of_nat : nat -> n + +val zdiv_eucl_POS : positive -> z -> (z, z) prod + +val zdiv_eucl : z -> z -> (z, z) prod + +type 'c pol = + | Pc of 'c + | Pinj of positive * 'c pol + | PX of 'c pol * positive * 'c pol + +val p0 : 'a1 -> 'a1 pol + +val p1 : 'a1 -> 'a1 pol + +val peq : ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol -> bool + +val mkPinj_pred : positive -> 'a1 pol -> 'a1 pol + +val mkPX : + 'a1 -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> positive -> 'a1 pol -> 'a1 pol + +val mkXi : 'a1 -> 'a1 -> positive -> 'a1 pol + +val mkX : 'a1 -> 'a1 -> 'a1 pol + +val popp : ('a1 -> 'a1) -> 'a1 pol -> 'a1 pol + +val paddC : ('a1 -> 'a1 -> 'a1) -> 'a1 pol -> 'a1 -> 'a1 pol + +val psubC : ('a1 -> 'a1 -> 'a1) -> 'a1 pol -> 'a1 -> 'a1 pol + +val paddI : + ('a1 -> 'a1 -> 'a1) -> ('a1 pol -> 'a1 pol -> 'a1 pol) -> 'a1 pol -> + positive -> 'a1 pol -> 'a1 pol + +val psubI : + ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1 pol -> 'a1 pol -> 'a1 pol) -> + 'a1 pol -> positive -> 'a1 pol -> 'a1 pol + +val paddX : + 'a1 -> ('a1 -> 'a1 -> bool) -> ('a1 pol -> 'a1 pol -> 'a1 pol) -> 'a1 pol + -> positive -> 'a1 pol -> 'a1 pol + +val psubX : + 'a1 -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 pol -> 'a1 pol -> 'a1 + pol) -> 'a1 pol -> positive -> 'a1 pol -> 'a1 pol + +val padd : + 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol -> + 'a1 pol + +val psub : + 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1 + -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol -> 'a1 pol + +val pmulC_aux : + 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 -> 'a1 + pol + +val pmulC : + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 + -> 'a1 pol + +val pmulI : + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 pol -> + 'a1 pol -> 'a1 pol) -> 'a1 pol -> positive -> 'a1 pol -> 'a1 pol + +val pmul : + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> + bool) -> 'a1 pol -> 'a1 pol -> 'a1 pol + +type 'c pExpr = + | PEc of 'c + | PEX of positive + | PEadd of 'c pExpr * 'c pExpr + | PEsub of 'c pExpr * 'c pExpr + | PEmul of 'c pExpr * 'c pExpr + | PEopp of 'c pExpr + | PEpow of 'c pExpr * n + +val mk_X : 'a1 -> 'a1 -> positive -> 'a1 pol + +val ppow_pos : + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> + bool) -> ('a1 pol -> 'a1 pol) -> 'a1 pol -> 'a1 pol -> positive -> 'a1 pol + +val ppow_N : + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> + bool) -> ('a1 pol -> 'a1 pol) -> 'a1 pol -> n -> 'a1 pol + +val norm_aux : + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> + 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pExpr -> 'a1 pol + +type 'a bFormula = + | TT + | FF + | X + | A of 'a + | Cj of 'a bFormula * 'a bFormula + | D of 'a bFormula * 'a bFormula + | N of 'a bFormula + | I of 'a bFormula * 'a bFormula + +type 'term' clause = 'term' list + +type 'term' cnf = 'term' clause list + +val tt : 'a1 cnf + +val ff : 'a1 cnf + +val or_clause_cnf : 'a1 clause -> 'a1 cnf -> 'a1 cnf + +val or_cnf : 'a1 cnf -> 'a1 cnf -> 'a1 cnf + +val and_cnf : 'a1 cnf -> 'a1 cnf -> 'a1 cnf + +val xcnf : + ('a1 -> 'a2 cnf) -> ('a1 -> 'a2 cnf) -> bool -> 'a1 bFormula -> 'a2 cnf + +val cnf_checker : ('a1 list -> 'a2 -> bool) -> 'a1 cnf -> 'a2 list -> bool + +val tauto_checker : + ('a1 -> 'a2 cnf) -> ('a1 -> 'a2 cnf) -> ('a2 list -> 'a3 -> bool) -> 'a1 + bFormula -> 'a3 list -> bool + +type 'c pExprC = 'c pExpr + +type 'c polC = 'c pol + +type op1 = + | Equal + | NonEqual + | Strict + | NonStrict + +type 'c nFormula = ('c pExprC, op1) prod + +type monoidMember = nat list + +type 'c coneMember = + | S_In of nat + | S_Ideal of 'c pExprC * 'c coneMember + | S_Square of 'c pExprC + | S_Monoid of monoidMember + | S_Mult of 'c coneMember * 'c coneMember + | S_Add of 'c coneMember * 'c coneMember + | S_Pos of 'c + | S_Z + +val nformula_times : 'a1 nFormula -> 'a1 nFormula -> 'a1 nFormula + +val nformula_plus : 'a1 nFormula -> 'a1 nFormula -> 'a1 nFormula + +val eval_monoid : 'a1 -> 'a1 nFormula list -> monoidMember -> 'a1 pExprC + +val eval_cone : + 'a1 -> 'a1 -> ('a1 -> 'a1 -> bool) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula + list -> 'a1 coneMember -> 'a1 nFormula + +val normalise_pexpr : + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> + 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pExprC -> 'a1 polC + +val check_inconsistent : + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> + 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 -> 'a1 -> bool) -> 'a1 + nFormula -> bool + +val check_normalised_formulas : + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> + 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 -> 'a1 -> bool) -> 'a1 + nFormula list -> 'a1 coneMember -> bool + +type op2 = + | OpEq + | OpNEq + | OpLe + | OpGe + | OpLt + | OpGt + +type 'c formula = { flhs : 'c pExprC; fop : op2; frhs : 'c pExprC } + +val flhs : 'a1 formula -> 'a1 pExprC + +val fop : 'a1 formula -> op2 + +val frhs : 'a1 formula -> 'a1 pExprC + +val xnormalise : 'a1 formula -> 'a1 nFormula list + +val cnf_normalise : 'a1 formula -> 'a1 nFormula cnf + +val xnegate : 'a1 formula -> 'a1 nFormula list + +val cnf_negate : 'a1 formula -> 'a1 nFormula cnf + +val simpl_expr : 'a1 -> ('a1 -> 'a1 -> bool) -> 'a1 pExprC -> 'a1 pExprC + +val simpl_cone : + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 coneMember + -> 'a1 coneMember + +type q = { qnum : z; qden : positive } + +val qnum : q -> z + +val qden : q -> positive + +val qplus : q -> q -> q + +val qmult : q -> q -> q + +val qopp : q -> q + +val qminus : q -> q -> q + +type 'a t = + | Empty + | Leaf of 'a + | Node of 'a t * 'a * 'a t + +val find : 'a1 -> 'a1 t -> positive -> 'a1 + +type zWitness = z coneMember + +val zWeakChecker : z nFormula list -> z coneMember -> bool + +val xnormalise0 : z formula -> z nFormula list + +val normalise : z formula -> z nFormula cnf + +val xnegate0 : z formula -> z nFormula list + +val negate : z formula -> z nFormula cnf + +val ceiling : z -> z -> z + +type proofTerm = + | RatProof of zWitness + | CutProof of z pExprC * q * zWitness * proofTerm + | EnumProof of q * z pExprC * q * zWitness * zWitness * proofTerm list + +val makeLb : z pExpr -> q -> z nFormula + +val qceiling : q -> z + +val makeLbCut : z pExprC -> q -> z nFormula + +val neg_nformula : z nFormula -> (z pExpr, op1) prod + +val cutChecker : + z nFormula list -> z pExpr -> q -> zWitness -> z nFormula option + +val zChecker : z nFormula list -> proofTerm -> bool + +val zTautoChecker : z formula bFormula -> proofTerm list -> bool + +val map_cone : (nat -> nat) -> zWitness -> zWitness + +val indexes : zWitness -> nat list + +val n_of_Z : z -> n + +val qeq_bool : q -> q -> bool + +val qle_bool : q -> q -> bool + +type qWitness = q coneMember + +val qWeakChecker : q nFormula list -> q coneMember -> bool + +val qTautoChecker : q formula bFormula -> qWitness list -> bool + diff --git a/contrib/micromega/mutils.ml b/contrib/micromega/mutils.ml new file mode 100644 index 00000000..2473608f --- /dev/null +++ b/contrib/micromega/mutils.ml @@ -0,0 +1,305 @@ +(************************************************************************) +(* 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 *) +(************************************************************************) +(* *) +(* Micromega: A reflexive tactic using the Positivstellensatz *) +(* *) +(* Frédéric Besson (Irisa/Inria) 2006-2008 *) +(* *) +(************************************************************************) + +let debug = false + +let fst' (Micromega.Pair(x,y)) = x +let snd' (Micromega.Pair(x,y)) = y + +let rec try_any l x = + match l with + | [] -> None + | (f,s)::l -> match f x with + | None -> try_any l x + | x -> x + +let list_try_find f = + let rec try_find_f = function + | [] -> failwith "try_find" + | h::t -> try f h with Failure _ -> try_find_f t + in + try_find_f + +let rec list_fold_right_elements f l = + let rec aux = function + | [] -> invalid_arg "list_fold_right_elements" + | [x] -> x + | x::l -> f x (aux l) in + aux l + +let interval n m = + let rec interval_n (l,m) = + if n > m then l else interval_n (m::l,pred m) + in + interval_n ([],m) + +open Num +open Big_int + +let ppcm x y = + let g = gcd_big_int x y in + let x' = div_big_int x g in + let y' = div_big_int y g in + mult_big_int g (mult_big_int x' y') + + +let denominator = function + | Int _ | Big_int _ -> unit_big_int + | Ratio r -> Ratio.denominator_ratio r + +let numerator = function + | Ratio r -> Ratio.numerator_ratio r + | Int i -> Big_int.big_int_of_int i + | Big_int i -> i + +let rec ppcm_list c l = + match l with + | [] -> c + | e::l -> ppcm_list (ppcm c (denominator e)) l + +let rec rec_gcd_list c l = + match l with + | [] -> c + | e::l -> rec_gcd_list (gcd_big_int c (numerator e)) l + +let rec gcd_list l = + let res = rec_gcd_list zero_big_int l in + if compare_big_int res zero_big_int = 0 + then unit_big_int else res + + + +let rats_to_ints l = + let c = ppcm_list unit_big_int l in + List.map (fun x -> (div_big_int (mult_big_int (numerator x) c) + (denominator x))) l + +(* Nasty reordering of lists - useful to trim certificate down *) +let mapi f l = + let rec xmapi i l = + match l with + | [] -> [] + | e::l -> (f e i)::(xmapi (i+1) l) in + xmapi 0 l + + +let concatMapi f l = List.rev (mapi (fun e i -> (i,f e)) l) + +(* assoc_pos j [a0...an] = [j,a0....an,j+n],j+n+1 *) +let assoc_pos j l = (mapi (fun e i -> e,i+j) l, j + (List.length l)) + +let assoc_pos_assoc l = + let rec xpos i l = + match l with + | [] -> [] + | (x,l) ::rst -> let (l',j) = assoc_pos i l in + (x,l')::(xpos j rst) in + xpos 0 l + +let filter_pos f l = + (* Could sort ... take care of duplicates... *) + let rec xfilter l = + match l with + | [] -> [] + | (x,e)::l -> + if List.exists (fun ee -> List.mem ee f) (List.map snd e) + then (x,e)::(xfilter l) + else xfilter l in + xfilter l + +let select_pos lpos l = + let rec xselect i lpos l = + match lpos with + | [] -> [] + | j::rpos -> + match l with + | [] -> failwith "select_pos" + | e::l -> + if i = j + then e:: (xselect (i+1) rpos l) + else xselect (i+1) lpos l in + xselect 0 lpos l + + +module CoqToCaml = +struct + open Micromega + + let rec nat = function + | O -> 0 + | S n -> (nat n) + 1 + + + let rec positive p = + match p with + | XH -> 1 + | XI p -> 1+ 2*(positive p) + | XO p -> 2*(positive p) + + + let n nt = + match nt with + | N0 -> 0 + | Npos p -> positive p + + + let rec index i = (* Swap left-right ? *) + match i with + | XH -> 1 + | XI i -> 1+(2*(index i)) + | XO i -> 2*(index i) + + + let z x = + match x with + | Z0 -> 0 + | Zpos p -> (positive p) + | Zneg p -> - (positive p) + + open Big_int + + let rec positive_big_int p = + match p with + | XH -> unit_big_int + | XI p -> add_int_big_int 1 (mult_int_big_int 2 (positive_big_int p)) + | XO p -> (mult_int_big_int 2 (positive_big_int p)) + + + let z_big_int x = + match x with + | Z0 -> zero_big_int + | Zpos p -> (positive_big_int p) + | Zneg p -> minus_big_int (positive_big_int p) + + + let num x = Num.Big_int (z_big_int x) + + let rec list elt l = + match l with + | Nil -> [] + | Cons(e,l) -> (elt e)::(list elt l) + + let q_to_num {qnum = x ; qden = y} = + Big_int (z_big_int x) // (Big_int (z_big_int (Zpos y))) + +end + + +module CamlToCoq = +struct + open Micromega + + let rec nat = function + | 0 -> O + | n -> S (nat (n-1)) + + + let rec positive n = + if n=1 then XH + else if n land 1 = 1 then XI (positive (n lsr 1)) + else XO (positive (n lsr 1)) + + let n nt = + if nt < 0 + then assert false + else if nt = 0 then N0 + else Npos (positive nt) + + + + + + let rec index n = + if n=1 then XH + else if n land 1 = 1 then XI (index (n lsr 1)) + else XO (index (n lsr 1)) + + + let idx n = + (*a.k.a path_of_int *) + (* returns the list of digits of n in reverse order with + initial 1 removed *) + let rec digits_of_int n = + if n=1 then [] + else (n mod 2 = 1)::(digits_of_int (n lsr 1)) + in + List.fold_right + (fun b c -> (if b then XI c else XO c)) + (List.rev (digits_of_int n)) + (XH) + + + + let z x = + match compare x 0 with + | 0 -> Z0 + | 1 -> Zpos (positive x) + | _ -> (* this should be -1 *) + Zneg (positive (-x)) + + open Big_int + + let positive_big_int n = + let two = big_int_of_int 2 in + let rec _pos n = + if eq_big_int n unit_big_int then XH + else + let (q,m) = quomod_big_int n two in + if eq_big_int unit_big_int m + then XI (_pos q) + else XO (_pos q) in + _pos n + + let bigint x = + match sign_big_int x with + | 0 -> Z0 + | 1 -> Zpos (positive_big_int x) + | _ -> Zneg (positive_big_int (minus_big_int x)) + + let q n = + {Micromega.qnum = bigint (numerator n) ; + Micromega.qden = positive_big_int (denominator n)} + + + let list elt l = List.fold_right (fun x l -> Cons(elt x, l)) l Nil + +end + +module Cmp = +struct + + let rec compare_lexical l = + match l with + | [] -> 0 (* Equal *) + | f::l -> + let cmp = f () in + if cmp = 0 then compare_lexical l else cmp + + let rec compare_list cmp l1 l2 = + match l1 , l2 with + | [] , [] -> 0 + | [] , _ -> -1 + | _ , [] -> 1 + | e1::l1 , e2::l2 -> + let c = cmp e1 e2 in + if c = 0 then compare_list cmp l1 l2 else c + + let hash_list hash l = + let rec _hash_list l h = + match l with + | [] -> h lxor (Hashtbl.hash []) + | e::l -> _hash_list l ((hash e) lxor h) in + + _hash_list l 0 +end diff --git a/contrib/micromega/sos.ml b/contrib/micromega/sos.ml new file mode 100644 index 00000000..e3d72ed9 --- /dev/null +++ b/contrib/micromega/sos.ml @@ -0,0 +1,1919 @@ +(* ========================================================================= *) +(* - This code originates from John Harrison's HOL LIGHT 2.20 *) +(* (see file LICENSE.sos for license, copyright and disclaimer) *) +(* - Laurent Théry (thery@sophia.inria.fr) has isolated the HOL *) +(* independent bits *) +(* - Frédéric Besson (fbesson@irisa.fr) is using it to feed micromega *) +(* - Addition of a csdp cache by the Coq development team *) +(* ========================================================================= *) + +(* ========================================================================= *) +(* Nonlinear universal reals procedure using SOS decomposition. *) +(* ========================================================================= *) + +open Num;; +open List;; + +let debugging = ref false;; + +exception Sanity;; + +exception Unsolvable;; + +(* ------------------------------------------------------------------------- *) +(* Comparisons that are reflexive on NaN and also short-circuiting. *) +(* ------------------------------------------------------------------------- *) + +let (=?) = fun x y -> Pervasives.compare x y = 0;; +let (<?) = fun x y -> Pervasives.compare x y < 0;; +let (<=?) = fun x y -> Pervasives.compare x y <= 0;; +let (>?) = fun x y -> Pervasives.compare x y > 0;; +let (>=?) = fun x y -> Pervasives.compare x y >= 0;; + +(* ------------------------------------------------------------------------- *) +(* Combinators. *) +(* ------------------------------------------------------------------------- *) + +let (o) = fun f g x -> f(g x);; + +(* ------------------------------------------------------------------------- *) +(* Some useful functions on "num" type. *) +(* ------------------------------------------------------------------------- *) + + +let num_0 = Int 0 +and num_1 = Int 1 +and num_2 = Int 2 +and num_10 = Int 10;; + +let pow2 n = power_num num_2 (Int n);; +let pow10 n = power_num num_10 (Int n);; + +let numdom r = + let r' = Ratio.normalize_ratio (ratio_of_num r) in + num_of_big_int(Ratio.numerator_ratio r'), + num_of_big_int(Ratio.denominator_ratio r');; + +let numerator = (o) fst numdom +and denominator = (o) snd numdom;; + +let gcd_num n1 n2 = + num_of_big_int(Big_int.gcd_big_int (big_int_of_num n1) (big_int_of_num n2));; + +let lcm_num x y = + if x =/ num_0 & y =/ num_0 then num_0 + else abs_num((x */ y) // gcd_num x y);; + + +(* ------------------------------------------------------------------------- *) +(* List basics. *) +(* ------------------------------------------------------------------------- *) + +let rec el n l = + if n = 0 then hd l else el (n - 1) (tl l);; + + +(* ------------------------------------------------------------------------- *) +(* Various versions of list iteration. *) +(* ------------------------------------------------------------------------- *) + +let rec itlist f l b = + match l with + [] -> b + | (h::t) -> f h (itlist f t b);; + +let rec end_itlist f l = + match l with + [] -> failwith "end_itlist" + | [x] -> x + | (h::t) -> f h (end_itlist f t);; + +let rec itlist2 f l1 l2 b = + match (l1,l2) with + ([],[]) -> b + | (h1::t1,h2::t2) -> f h1 h2 (itlist2 f t1 t2 b) + | _ -> failwith "itlist2";; + +(* ------------------------------------------------------------------------- *) +(* All pairs arising from applying a function over two lists. *) +(* ------------------------------------------------------------------------- *) + +let rec allpairs f l1 l2 = + match l1 with + h1::t1 -> itlist (fun x a -> f h1 x :: a) l2 (allpairs f t1 l2) + | [] -> [];; + +(* ------------------------------------------------------------------------- *) +(* String operations (surely there is a better way...) *) +(* ------------------------------------------------------------------------- *) + +let implode l = itlist (^) l "";; + +let explode s = + let rec exap n l = + if n < 0 then l else + exap (n - 1) ((String.sub s n 1)::l) in + exap (String.length s - 1) [];; + + +(* ------------------------------------------------------------------------- *) +(* Attempting function or predicate applications. *) +(* ------------------------------------------------------------------------- *) + +let can f x = try (f x; true) with Failure _ -> false;; + + +(* ------------------------------------------------------------------------- *) +(* Repetition of a function. *) +(* ------------------------------------------------------------------------- *) + +let rec funpow n f x = + if n < 1 then x else funpow (n-1) f (f x);; + + +(* ------------------------------------------------------------------------- *) +(* term?? *) +(* ------------------------------------------------------------------------- *) + +type vname = string;; + +type term = +| Zero +| Const of Num.num +| Var of vname +| Inv of term +| Opp of term +| Add of (term * term) +| Sub of (term * term) +| Mul of (term * term) +| Div of (term * term) +| Pow of (term * int);; + + +(* ------------------------------------------------------------------------- *) +(* Data structure for Positivstellensatz refutations. *) +(* ------------------------------------------------------------------------- *) + +type positivstellensatz = + Axiom_eq of int + | Axiom_le of int + | Axiom_lt of int + | Rational_eq of num + | Rational_le of num + | Rational_lt of num + | Square of term + | Monoid of int list + | Eqmul of term * positivstellensatz + | Sum of positivstellensatz * positivstellensatz + | Product of positivstellensatz * positivstellensatz;; + + + +(* ------------------------------------------------------------------------- *) +(* Replication and sequences. *) +(* ------------------------------------------------------------------------- *) + +let rec replicate x n = + if n < 1 then [] + else x::(replicate x (n - 1));; + +let rec (--) = fun m n -> if m > n then [] else m::((m + 1) -- n);; + +(* ------------------------------------------------------------------------- *) +(* Various useful list operations. *) +(* ------------------------------------------------------------------------- *) + +let rec forall p l = + match l with + [] -> true + | h::t -> p(h) & forall p t;; + +let rec tryfind f l = + match l with + [] -> failwith "tryfind" + | (h::t) -> try f h with Failure _ -> tryfind f t;; + +let index x = + let rec ind n l = + match l with + [] -> failwith "index" + | (h::t) -> if x =? h then n else ind (n + 1) t in + ind 0;; + +(* ------------------------------------------------------------------------- *) +(* "Set" operations on lists. *) +(* ------------------------------------------------------------------------- *) + +let rec mem x lis = + match lis with + [] -> false + | (h::t) -> x =? h or mem x t;; + +let insert x l = + if mem x l then l else x::l;; + +let union l1 l2 = itlist insert l1 l2;; + +let subtract l1 l2 = filter (fun x -> not (mem x l2)) l1;; + +(* ------------------------------------------------------------------------- *) +(* Merging and bottom-up mergesort. *) +(* ------------------------------------------------------------------------- *) + +let rec merge ord l1 l2 = + match l1 with + [] -> l2 + | h1::t1 -> match l2 with + [] -> l1 + | h2::t2 -> if ord h1 h2 then h1::(merge ord t1 l2) + else h2::(merge ord l1 t2);; + + +(* ------------------------------------------------------------------------- *) +(* Common measure predicates to use with "sort". *) +(* ------------------------------------------------------------------------- *) + +let increasing f x y = f x <? f y;; + +let decreasing f x y = f x >? f y;; + +(* ------------------------------------------------------------------------- *) +(* Zipping, unzipping etc. *) +(* ------------------------------------------------------------------------- *) + +let rec zip l1 l2 = + match (l1,l2) with + ([],[]) -> [] + | (h1::t1,h2::t2) -> (h1,h2)::(zip t1 t2) + | _ -> failwith "zip";; + +let rec unzip = + function [] -> [],[] + | ((a,b)::rest) -> let alist,blist = unzip rest in + (a::alist,b::blist);; + +(* ------------------------------------------------------------------------- *) +(* Iterating functions over lists. *) +(* ------------------------------------------------------------------------- *) + +let rec do_list f l = + match l with + [] -> () + | (h::t) -> (f h; do_list f t);; + +(* ------------------------------------------------------------------------- *) +(* Sorting. *) +(* ------------------------------------------------------------------------- *) + +let rec sort cmp lis = + match lis with + [] -> [] + | piv::rest -> + let r,l = partition (cmp piv) rest in + (sort cmp l) @ (piv::(sort cmp r));; + +(* ------------------------------------------------------------------------- *) +(* Removing adjacent (NB!) equal elements from list. *) +(* ------------------------------------------------------------------------- *) + +let rec uniq l = + match l with + x::(y::_ as t) -> let t' = uniq t in + if x =? y then t' else + if t'==t then l else x::t' + | _ -> l;; + +(* ------------------------------------------------------------------------- *) +(* Convert list into set by eliminating duplicates. *) +(* ------------------------------------------------------------------------- *) + +let setify s = uniq (sort (<=?) s);; + +(* ------------------------------------------------------------------------- *) +(* Polymorphic finite partial functions via Patricia trees. *) +(* *) +(* The point of this strange representation is that it is canonical (equal *) +(* functions have the same encoding) yet reasonably efficient on average. *) +(* *) +(* Idea due to Diego Olivier Fernandez Pons (OCaml list, 2003/11/10). *) +(* ------------------------------------------------------------------------- *) + +type ('a,'b)func = + Empty + | Leaf of int * ('a*'b)list + | Branch of int * int * ('a,'b)func * ('a,'b)func;; + +(* ------------------------------------------------------------------------- *) +(* Undefined function. *) +(* ------------------------------------------------------------------------- *) + +let undefined = Empty;; + +(* ------------------------------------------------------------------------- *) +(* In case of equality comparison worries, better use this. *) +(* ------------------------------------------------------------------------- *) + +let is_undefined f = + match f with + Empty -> true + | _ -> false;; + +(* ------------------------------------------------------------------------- *) +(* Operation analagous to "map" for lists. *) +(* ------------------------------------------------------------------------- *) + +let mapf = + let rec map_list f l = + match l with + [] -> [] + | (x,y)::t -> (x,f(y))::(map_list f t) in + let rec mapf f t = + match t with + Empty -> Empty + | Leaf(h,l) -> Leaf(h,map_list f l) + | Branch(p,b,l,r) -> Branch(p,b,mapf f l,mapf f r) in + mapf;; + +(* ------------------------------------------------------------------------- *) +(* Operations analogous to "fold" for lists. *) +(* ------------------------------------------------------------------------- *) + +let foldl = + let rec foldl_list f a l = + match l with + [] -> a + | (x,y)::t -> foldl_list f (f a x y) t in + let rec foldl f a t = + match t with + Empty -> a + | Leaf(h,l) -> foldl_list f a l + | Branch(p,b,l,r) -> foldl f (foldl f a l) r in + foldl;; + +let foldr = + let rec foldr_list f l a = + match l with + [] -> a + | (x,y)::t -> f x y (foldr_list f t a) in + let rec foldr f t a = + match t with + Empty -> a + | Leaf(h,l) -> foldr_list f l a + | Branch(p,b,l,r) -> foldr f l (foldr f r a) in + foldr;; + +(* ------------------------------------------------------------------------- *) +(* Redefinition and combination. *) +(* ------------------------------------------------------------------------- *) + +let (|->),combine = + let ldb x y = let z = x lxor y in z land (-z) in + let newbranch p1 t1 p2 t2 = + let b = ldb p1 p2 in + let p = p1 land (b - 1) in + if p1 land b = 0 then Branch(p,b,t1,t2) + else Branch(p,b,t2,t1) in + let rec define_list (x,y as xy) l = + match l with + (a,b as ab)::t -> + if x =? a then xy::t + else if x <? a then xy::l + else ab::(define_list xy t) + | [] -> [xy] + and combine_list op z l1 l2 = + match (l1,l2) with + [],_ -> l2 + | _,[] -> l1 + | ((x1,y1 as xy1)::t1,(x2,y2 as xy2)::t2) -> + if x1 <? x2 then xy1::(combine_list op z t1 l2) + else if x2 <? x1 then xy2::(combine_list op z l1 t2) else + let y = op y1 y2 and l = combine_list op z t1 t2 in + if z(y) then l else (x1,y)::l in + let (|->) x y = + let k = Hashtbl.hash x in + let rec upd t = + match t with + Empty -> Leaf (k,[x,y]) + | Leaf(h,l) -> + if h = k then Leaf(h,define_list (x,y) l) + else newbranch h t k (Leaf(k,[x,y])) + | Branch(p,b,l,r) -> + if k land (b - 1) <> p then newbranch p t k (Leaf(k,[x,y])) + else if k land b = 0 then Branch(p,b,upd l,r) + else Branch(p,b,l,upd r) in + upd in + let rec combine op z t1 t2 = + match (t1,t2) with + Empty,_ -> t2 + | _,Empty -> t1 + | Leaf(h1,l1),Leaf(h2,l2) -> + if h1 = h2 then + let l = combine_list op z l1 l2 in + if l = [] then Empty else Leaf(h1,l) + else newbranch h1 t1 h2 t2 + | (Leaf(k,lis) as lf),(Branch(p,b,l,r) as br) | + (Branch(p,b,l,r) as br),(Leaf(k,lis) as lf) -> + if k land (b - 1) = p then + if k land b = 0 then + let l' = combine op z lf l in + if is_undefined l' then r else Branch(p,b,l',r) + else + let r' = combine op z lf r in + if is_undefined r' then l else Branch(p,b,l,r') + else + newbranch k lf p br + | Branch(p1,b1,l1,r1),Branch(p2,b2,l2,r2) -> + if b1 < b2 then + if p2 land (b1 - 1) <> p1 then newbranch p1 t1 p2 t2 + else if p2 land b1 = 0 then + let l = combine op z l1 t2 in + if is_undefined l then r1 else Branch(p1,b1,l,r1) + else + let r = combine op z r1 t2 in + if is_undefined r then l1 else Branch(p1,b1,l1,r) + else if b2 < b1 then + if p1 land (b2 - 1) <> p2 then newbranch p1 t1 p2 t2 + else if p1 land b2 = 0 then + let l = combine op z t1 l2 in + if is_undefined l then r2 else Branch(p2,b2,l,r2) + else + let r = combine op z t1 r2 in + if is_undefined r then l2 else Branch(p2,b2,l2,r) + else if p1 = p2 then + let l = combine op z l1 l2 and r = combine op z r1 r2 in + if is_undefined l then r + else if is_undefined r then l else Branch(p1,b1,l,r) + else + newbranch p1 t1 p2 t2 in + (|->),combine;; + +(* ------------------------------------------------------------------------- *) +(* Special case of point function. *) +(* ------------------------------------------------------------------------- *) + +let (|=>) = fun x y -> (x |-> y) undefined;; + + +(* ------------------------------------------------------------------------- *) +(* Grab an arbitrary element. *) +(* ------------------------------------------------------------------------- *) + +let rec choose t = + match t with + Empty -> failwith "choose: completely undefined function" + | Leaf(h,l) -> hd l + | Branch(b,p,t1,t2) -> choose t1;; + +(* ------------------------------------------------------------------------- *) +(* Application. *) +(* ------------------------------------------------------------------------- *) + +let applyd = + let rec apply_listd l d x = + match l with + (a,b)::t -> if x =? a then b + else if x >? a then apply_listd t d x else d x + | [] -> d x in + fun f d x -> + let k = Hashtbl.hash x in + let rec look t = + match t with + Leaf(h,l) when h = k -> apply_listd l d x + | Branch(p,b,l,r) -> look (if k land b = 0 then l else r) + | _ -> d x in + look f;; + +let apply f = applyd f (fun x -> failwith "apply");; + +let tryapplyd f a d = applyd f (fun x -> d) a;; + +let defined f x = try apply f x; true with Failure _ -> false;; + +(* ------------------------------------------------------------------------- *) +(* Undefinition. *) +(* ------------------------------------------------------------------------- *) + +let undefine = + let rec undefine_list x l = + match l with + (a,b as ab)::t -> + if x =? a then t + else if x <? a then l else + let t' = undefine_list x t in + if t' == t then l else ab::t' + | [] -> [] in + fun x -> + let k = Hashtbl.hash x in + let rec und t = + match t with + Leaf(h,l) when h = k -> + let l' = undefine_list x l in + if l' == l then t + else if l' = [] then Empty + else Leaf(h,l') + | Branch(p,b,l,r) when k land (b - 1) = p -> + if k land b = 0 then + let l' = und l in + if l' == l then t + else if is_undefined l' then r + else Branch(p,b,l',r) + else + let r' = und r in + if r' == r then t + else if is_undefined r' then l + else Branch(p,b,l,r') + | _ -> t in + und;; + + +(* ------------------------------------------------------------------------- *) +(* Mapping to sorted-list representation of the graph, domain and range. *) +(* ------------------------------------------------------------------------- *) + +let graph f = setify (foldl (fun a x y -> (x,y)::a) [] f);; + +let dom f = setify(foldl (fun a x y -> x::a) [] f);; + +let ran f = setify(foldl (fun a x y -> y::a) [] f);; + +(* ------------------------------------------------------------------------- *) +(* Turn a rational into a decimal string with d sig digits. *) +(* ------------------------------------------------------------------------- *) + +let decimalize = + let rec normalize y = + if abs_num y </ Int 1 // Int 10 then normalize (Int 10 */ y) - 1 + else if abs_num y >=/ Int 1 then normalize (y // Int 10) + 1 + else 0 in + fun d x -> + if x =/ Int 0 then "0.0" else + let y = abs_num x in + let e = normalize y in + let z = pow10(-e) */ y +/ Int 1 in + let k = round_num(pow10 d */ z) in + (if x </ Int 0 then "-0." else "0.") ^ + implode(tl(explode(string_of_num k))) ^ + (if e = 0 then "" else "e"^string_of_int e);; + + +(* ------------------------------------------------------------------------- *) +(* Iterations over numbers, and lists indexed by numbers. *) +(* ------------------------------------------------------------------------- *) + +let rec itern k l f a = + match l with + [] -> a + | h::t -> itern (k + 1) t f (f h k a);; + +let rec iter (m,n) f a = + if n < m then a + else iter (m+1,n) f (f m a);; + +(* ------------------------------------------------------------------------- *) +(* The main types. *) +(* ------------------------------------------------------------------------- *) + +type vector = int*(int,num)func;; + +type matrix = (int*int)*(int*int,num)func;; + +type monomial = (vname,int)func;; + +type poly = (monomial,num)func;; + +(* ------------------------------------------------------------------------- *) +(* Assignment avoiding zeros. *) +(* ------------------------------------------------------------------------- *) + +let (|-->) x y a = if y =/ Int 0 then a else (x |-> y) a;; + +(* ------------------------------------------------------------------------- *) +(* This can be generic. *) +(* ------------------------------------------------------------------------- *) + +let element (d,v) i = tryapplyd v i (Int 0);; + +let mapa f (d,v) = + d,foldl (fun a i c -> (i |--> f(c)) a) undefined v;; + +let is_zero (d,v) = + match v with + Empty -> true + | _ -> false;; + +(* ------------------------------------------------------------------------- *) +(* Vectors. Conventionally indexed 1..n. *) +(* ------------------------------------------------------------------------- *) + +let vector_0 n = (n,undefined:vector);; + +let dim (v:vector) = fst v;; + +let vector_const c n = + if c =/ Int 0 then vector_0 n + else (n,itlist (fun k -> k |-> c) (1--n) undefined :vector);; + +let vector_1 = vector_const (Int 1);; + +let vector_cmul c (v:vector) = + let n = dim v in + if c =/ Int 0 then vector_0 n + else n,mapf (fun x -> c */ x) (snd v);; + +let vector_neg (v:vector) = (fst v,mapf minus_num (snd v) :vector);; + +let vector_add (v1:vector) (v2:vector) = + let m = dim v1 and n = dim v2 in + if m <> n then failwith "vector_add: incompatible dimensions" else + (n,combine (+/) (fun x -> x =/ Int 0) (snd v1) (snd v2) :vector);; + +let vector_sub v1 v2 = vector_add v1 (vector_neg v2);; + +let vector_of_list l = + let n = length l in + (n,itlist2 (|->) (1--n) l undefined :vector);; + +(* ------------------------------------------------------------------------- *) +(* Matrices; again rows and columns indexed from 1. *) +(* ------------------------------------------------------------------------- *) + +let matrix_0 (m,n) = ((m,n),undefined:matrix);; + +let dimensions (m:matrix) = fst m;; + +let matrix_const c (m,n as mn) = + if m <> n then failwith "matrix_const: needs to be square" + else if c =/ Int 0 then matrix_0 mn + else (mn,itlist (fun k -> (k,k) |-> c) (1--n) undefined :matrix);; + +let matrix_1 = matrix_const (Int 1);; + +let matrix_cmul c (m:matrix) = + let (i,j) = dimensions m in + if c =/ Int 0 then matrix_0 (i,j) + else (i,j),mapf (fun x -> c */ x) (snd m);; + +let matrix_neg (m:matrix) = (dimensions m,mapf minus_num (snd m) :matrix);; + +let matrix_add (m1:matrix) (m2:matrix) = + let d1 = dimensions m1 and d2 = dimensions m2 in + if d1 <> d2 then failwith "matrix_add: incompatible dimensions" + else (d1,combine (+/) (fun x -> x =/ Int 0) (snd m1) (snd m2) :matrix);; + +let matrix_sub m1 m2 = matrix_add m1 (matrix_neg m2);; + +let row k (m:matrix) = + let i,j = dimensions m in + (j, + foldl (fun a (i,j) c -> if i = k then (j |-> c) a else a) undefined (snd m) + : vector);; + +let column k (m:matrix) = + let i,j = dimensions m in + (i, + foldl (fun a (i,j) c -> if j = k then (i |-> c) a else a) undefined (snd m) + : vector);; + +let transp (m:matrix) = + let i,j = dimensions m in + ((j,i),foldl (fun a (i,j) c -> ((j,i) |-> c) a) undefined (snd m) :matrix);; + +let diagonal (v:vector) = + let n = dim v in + ((n,n),foldl (fun a i c -> ((i,i) |-> c) a) undefined (snd v) : matrix);; + +let matrix_of_list l = + let m = length l in + if m = 0 then matrix_0 (0,0) else + let n = length (hd l) in + (m,n),itern 1 l (fun v i -> itern 1 v (fun c j -> (i,j) |-> c)) undefined;; + +(* ------------------------------------------------------------------------- *) +(* Monomials. *) +(* ------------------------------------------------------------------------- *) + +let monomial_eval assig (m:monomial) = + foldl (fun a x k -> a */ power_num (apply assig x) (Int k)) + (Int 1) m;; + +let monomial_1 = (undefined:monomial);; + +let monomial_var x = (x |=> 1 :monomial);; + +let (monomial_mul:monomial->monomial->monomial) = + combine (+) (fun x -> false);; + +let monomial_pow (m:monomial) k = + if k = 0 then monomial_1 + else mapf (fun x -> k * x) m;; + +let monomial_divides (m1:monomial) (m2:monomial) = + foldl (fun a x k -> tryapplyd m2 x 0 >= k & a) true m1;; + +let monomial_div (m1:monomial) (m2:monomial) = + let m = combine (+) (fun x -> x = 0) m1 (mapf (fun x -> -x) m2) in + if foldl (fun a x k -> k >= 0 & a) true m then m + else failwith "monomial_div: non-divisible";; + +let monomial_degree x (m:monomial) = tryapplyd m x 0;; + +let monomial_lcm (m1:monomial) (m2:monomial) = + (itlist (fun x -> x |-> max (monomial_degree x m1) (monomial_degree x m2)) + (union (dom m1) (dom m2)) undefined :monomial);; + +let monomial_multidegree (m:monomial) = foldl (fun a x k -> k + a) 0 m;; + +let monomial_variables m = dom m;; + +(* ------------------------------------------------------------------------- *) +(* Polynomials. *) +(* ------------------------------------------------------------------------- *) + +let eval assig (p:poly) = + foldl (fun a m c -> a +/ c */ monomial_eval assig m) (Int 0) p;; + +let poly_0 = (undefined:poly);; + +let poly_isconst (p:poly) = foldl (fun a m c -> m = monomial_1 & a) true p;; + +let poly_var x = ((monomial_var x) |=> Int 1 :poly);; + +let poly_const c = + if c =/ Int 0 then poly_0 else (monomial_1 |=> c);; + +let poly_cmul c (p:poly) = + if c =/ Int 0 then poly_0 + else mapf (fun x -> c */ x) p;; + +let poly_neg (p:poly) = (mapf minus_num p :poly);; + +let poly_add (p1:poly) (p2:poly) = + (combine (+/) (fun x -> x =/ Int 0) p1 p2 :poly);; + +let poly_sub p1 p2 = poly_add p1 (poly_neg p2);; + +let poly_cmmul (c,m) (p:poly) = + if c =/ Int 0 then poly_0 + else if m = monomial_1 then mapf (fun d -> c */ d) p + else foldl (fun a m' d -> (monomial_mul m m' |-> c */ d) a) poly_0 p;; + +let poly_mul (p1:poly) (p2:poly) = + foldl (fun a m c -> poly_add (poly_cmmul (c,m) p2) a) poly_0 p1;; + +let poly_div (p1:poly) (p2:poly) = + if not(poly_isconst p2) then failwith "poly_div: non-constant" else + let c = eval undefined p2 in + if c =/ Int 0 then failwith "poly_div: division by zero" + else poly_cmul (Int 1 // c) p1;; + +let poly_square p = poly_mul p p;; + +let rec poly_pow p k = + if k = 0 then poly_const (Int 1) + else if k = 1 then p + else let q = poly_square(poly_pow p (k / 2)) in + if k mod 2 = 1 then poly_mul p q else q;; + +let poly_exp p1 p2 = + if not(poly_isconst p2) then failwith "poly_exp: not a constant" else + poly_pow p1 (Num.int_of_num (eval undefined p2));; + +let degree x (p:poly) = foldl (fun a m c -> max (monomial_degree x m) a) 0 p;; + +let multidegree (p:poly) = + foldl (fun a m c -> max (monomial_multidegree m) a) 0 p;; + +let poly_variables (p:poly) = + foldr (fun m c -> union (monomial_variables m)) p [];; + +(* ------------------------------------------------------------------------- *) +(* Order monomials for human presentation. *) +(* ------------------------------------------------------------------------- *) + +let humanorder_varpow (x1,k1) (x2,k2) = x1 < x2 or (x1 = x2 & k1 > k2);; + +let humanorder_monomial = + let rec ord l1 l2 = match (l1,l2) with + _,[] -> true + | [],_ -> false + | h1::t1,h2::t2 -> humanorder_varpow h1 h2 or (h1 = h2 & ord t1 t2) in + fun m1 m2 -> m1 = m2 or + ord (sort humanorder_varpow (graph m1)) + (sort humanorder_varpow (graph m2));; + +(* ------------------------------------------------------------------------- *) +(* Conversions to strings. *) +(* ------------------------------------------------------------------------- *) + +let string_of_vector min_size max_size (v:vector) = + let n_raw = dim v in + if n_raw = 0 then "[]" else + let n = max min_size (min n_raw max_size) in + let xs = map ((o) string_of_num (element v)) (1--n) in + "[" ^ end_itlist (fun s t -> s ^ ", " ^ t) xs ^ + (if n_raw > max_size then ", ...]" else "]");; + +let string_of_matrix max_size (m:matrix) = + let i_raw,j_raw = dimensions m in + let i = min max_size i_raw and j = min max_size j_raw in + let rstr = map (fun k -> string_of_vector j j (row k m)) (1--i) in + "["^end_itlist(fun s t -> s^";\n "^t) rstr ^ + (if j > max_size then "\n ...]" else "]");; + +let string_of_vname (v:vname): string = (v: string);; + +let rec string_of_term t = + match t with + Opp t1 -> "(- " ^ string_of_term t1 ^ ")" +| Add (t1, t2) -> + "(" ^ (string_of_term t1) ^ " + " ^ (string_of_term t2) ^ ")" +| Sub (t1, t2) -> + "(" ^ (string_of_term t1) ^ " - " ^ (string_of_term t2) ^ ")" +| Mul (t1, t2) -> + "(" ^ (string_of_term t1) ^ " * " ^ (string_of_term t2) ^ ")" +| Inv t1 -> "(/ " ^ string_of_term t1 ^ ")" +| Div (t1, t2) -> + "(" ^ (string_of_term t1) ^ " / " ^ (string_of_term t2) ^ ")" +| Pow (t1, n1) -> + "(" ^ (string_of_term t1) ^ " ^ " ^ (string_of_int n1) ^ ")" +| Zero -> "0" +| Var v -> "x" ^ (string_of_vname v) +| Const x -> string_of_num x;; + + +let string_of_varpow x k = + if k = 1 then string_of_vname x else string_of_vname x^"^"^string_of_int k;; + +let string_of_monomial m = + if m = monomial_1 then "1" else + let vps = List.fold_right (fun (x,k) a -> string_of_varpow x k :: a) + (sort humanorder_varpow (graph m)) [] in + end_itlist (fun s t -> s^"*"^t) vps;; + +let string_of_cmonomial (c,m) = + if m = monomial_1 then string_of_num c + else if c =/ Int 1 then string_of_monomial m + else string_of_num c ^ "*" ^ string_of_monomial m;; + +let string_of_poly (p:poly) = + if p = poly_0 then "<<0>>" else + let cms = sort (fun (m1,_) (m2,_) -> humanorder_monomial m1 m2) (graph p) in + let s = + List.fold_left (fun a (m,c) -> + if c </ Int 0 then a ^ " - " ^ string_of_cmonomial(minus_num c,m) + else a ^ " + " ^ string_of_cmonomial(c,m)) + "" cms in + let s1 = String.sub s 0 3 + and s2 = String.sub s 3 (String.length s - 3) in + "<<" ^(if s1 = " + " then s2 else "-"^s2)^">>";; + +(* ------------------------------------------------------------------------- *) +(* Printers. *) +(* ------------------------------------------------------------------------- *) + +let print_vector v = Format.print_string(string_of_vector 0 20 v);; + +let print_matrix m = Format.print_string(string_of_matrix 20 m);; + +let print_monomial m = Format.print_string(string_of_monomial m);; + +let print_poly m = Format.print_string(string_of_poly m);; + +(* +#install_printer print_vector;; +#install_printer print_matrix;; +#install_printer print_monomial;; +#install_printer print_poly;; +*) + +(* ------------------------------------------------------------------------- *) +(* Conversion from term. *) +(* ------------------------------------------------------------------------- *) + +let rec poly_of_term t = match t with + Zero -> poly_0 +| Const n -> poly_const n +| Var x -> poly_var x +| Opp t1 -> poly_neg (poly_of_term t1) +| Inv t1 -> + let p = poly_of_term t1 in + if poly_isconst p then poly_const(Int 1 // eval undefined p) + else failwith "poly_of_term: inverse of non-constant polyomial" +| Add (l, r) -> poly_add (poly_of_term l) (poly_of_term r) +| Sub (l, r) -> poly_sub (poly_of_term l) (poly_of_term r) +| Mul (l, r) -> poly_mul (poly_of_term l) (poly_of_term r) +| Div (l, r) -> + let p = poly_of_term l and q = poly_of_term r in + if poly_isconst q then poly_cmul (Int 1 // eval undefined q) p + else failwith "poly_of_term: division by non-constant polynomial" +| Pow (t, n) -> + poly_pow (poly_of_term t) n;; + +(* ------------------------------------------------------------------------- *) +(* String of vector (just a list of space-separated numbers). *) +(* ------------------------------------------------------------------------- *) + +let sdpa_of_vector (v:vector) = + let n = dim v in + let strs = map (o (decimalize 20) (element v)) (1--n) in + end_itlist (fun x y -> x ^ " " ^ y) strs ^ "\n";; + +(* ------------------------------------------------------------------------- *) +(* String for block diagonal matrix numbered k. *) +(* ------------------------------------------------------------------------- *) + +let sdpa_of_blockdiagonal k m = + let pfx = string_of_int k ^" " in + let ents = + foldl (fun a (b,i,j) c -> if i > j then a else ((b,i,j),c)::a) [] m in + let entss = sort (increasing fst) ents in + itlist (fun ((b,i,j),c) a -> + pfx ^ string_of_int b ^ " " ^ string_of_int i ^ " " ^ string_of_int j ^ + " " ^ decimalize 20 c ^ "\n" ^ a) entss "";; + +(* ------------------------------------------------------------------------- *) +(* String for a matrix numbered k, in SDPA sparse format. *) +(* ------------------------------------------------------------------------- *) + +let sdpa_of_matrix k (m:matrix) = + let pfx = string_of_int k ^ " 1 " in + let ms = foldr (fun (i,j) c a -> if i > j then a else ((i,j),c)::a) + (snd m) [] in + let mss = sort (increasing fst) ms in + itlist (fun ((i,j),c) a -> + pfx ^ string_of_int i ^ " " ^ string_of_int j ^ + " " ^ decimalize 20 c ^ "\n" ^ a) mss "";; + +(* ------------------------------------------------------------------------- *) +(* String in SDPA sparse format for standard SDP problem: *) +(* *) +(* X = v_1 * [M_1] + ... + v_m * [M_m] - [M_0] must be PSD *) +(* Minimize obj_1 * v_1 + ... obj_m * v_m *) +(* ------------------------------------------------------------------------- *) + +let sdpa_of_problem comment obj mats = + let m = length mats - 1 + and n,_ = dimensions (hd mats) in + "\"" ^ comment ^ "\"\n" ^ + string_of_int m ^ "\n" ^ + "1\n" ^ + string_of_int n ^ "\n" ^ + sdpa_of_vector obj ^ + itlist2 (fun k m a -> sdpa_of_matrix (k - 1) m ^ a) + (1--length mats) mats "";; + +(* ------------------------------------------------------------------------- *) +(* More parser basics. *) +(* ------------------------------------------------------------------------- *) + +exception Noparse;; + + +let isspace,issep,isbra,issymb,isalpha,isnum,isalnum = + let charcode s = Char.code(String.get s 0) in + let spaces = " \t\n\r" + and separators = ",;" + and brackets = "()[]{}" + and symbs = "\\!@#$%^&*-+|\\<=>/?~.:" + and alphas = "'abcdefghijklmnopqrstuvwxyz_ABCDEFGHIJKLMNOPQRSTUVWXYZ" + and nums = "0123456789" in + let allchars = spaces^separators^brackets^symbs^alphas^nums in + let csetsize = itlist ((o) max charcode) (explode allchars) 256 in + let ctable = Array.make csetsize 0 in + do_list (fun c -> Array.set ctable (charcode c) 1) (explode spaces); + do_list (fun c -> Array.set ctable (charcode c) 2) (explode separators); + do_list (fun c -> Array.set ctable (charcode c) 4) (explode brackets); + do_list (fun c -> Array.set ctable (charcode c) 8) (explode symbs); + do_list (fun c -> Array.set ctable (charcode c) 16) (explode alphas); + do_list (fun c -> Array.set ctable (charcode c) 32) (explode nums); + let isspace c = Array.get ctable (charcode c) = 1 + and issep c = Array.get ctable (charcode c) = 2 + and isbra c = Array.get ctable (charcode c) = 4 + and issymb c = Array.get ctable (charcode c) = 8 + and isalpha c = Array.get ctable (charcode c) = 16 + and isnum c = Array.get ctable (charcode c) = 32 + and isalnum c = Array.get ctable (charcode c) >= 16 in + isspace,issep,isbra,issymb,isalpha,isnum,isalnum;; + +let (||) parser1 parser2 input = + try parser1 input + with Noparse -> parser2 input;; + +let (++) parser1 parser2 input = + let result1,rest1 = parser1 input in + let result2,rest2 = parser2 rest1 in + (result1,result2),rest2;; + +let rec many prs input = + try let result,next = prs input in + let results,rest = many prs next in + (result::results),rest + with Noparse -> [],input;; + +let (>>) prs treatment input = + let result,rest = prs input in + treatment(result),rest;; + +let fix err prs input = + try prs input + with Noparse -> failwith (err ^ " expected");; + +let rec listof prs sep err = + prs ++ many (sep ++ fix err prs >> snd) >> (fun (h,t) -> h::t);; + +let possibly prs input = + try let x,rest = prs input in [x],rest + with Noparse -> [],input;; + +let some p = + function + [] -> raise Noparse + | (h::t) -> if p h then (h,t) else raise Noparse;; + +let a tok = some (fun item -> item = tok);; + +let rec atleast n prs i = + (if n <= 0 then many prs + else prs ++ atleast (n - 1) prs >> (fun (h,t) -> h::t)) i;; + +let finished input = + if input = [] then 0,input else failwith "Unparsed input";; + +let word s = + end_itlist (fun p1 p2 -> (p1 ++ p2) >> (fun (s,t) -> s^t)) + (map a (explode s));; + +let token s = + many (some isspace) ++ word s ++ many (some isspace) + >> (fun ((_,t),_) -> t);; + +let decimal = + let numeral = some isnum in + let decimalint = atleast 1 numeral >> ((o) Num.num_of_string implode) in + let decimalfrac = atleast 1 numeral + >> (fun s -> Num.num_of_string(implode s) // pow10 (length s)) in + let decimalsig = + decimalint ++ possibly (a "." ++ decimalfrac >> snd) + >> (function (h,[]) -> h | (h,[x]) -> h +/ x | _ -> failwith "decimalsig") in + let signed prs = + a "-" ++ prs >> ((o) minus_num snd) + || a "+" ++ prs >> snd + || prs in + let exponent = (a "e" || a "E") ++ signed decimalint >> snd in + signed decimalsig ++ possibly exponent + >> (function (h,[]) -> h | (h,[x]) -> h */ power_num (Int 10) x | _ -> + failwith "exponent");; + +let mkparser p s = + let x,rst = p(explode s) in + if rst = [] then x else failwith "mkparser: unparsed input";; + +let parse_decimal = mkparser decimal;; + +(* ------------------------------------------------------------------------- *) +(* Parse back a vector. *) +(* ------------------------------------------------------------------------- *) + +let parse_csdpoutput = + let rec skipupto dscr prs inp = + (dscr ++ prs >> snd + || some (fun c -> true) ++ skipupto dscr prs >> snd) inp in + let ignore inp = (),[] in + let csdpoutput = + (decimal ++ many(a " " ++ decimal >> snd) >> (fun (h,t) -> h::t)) ++ + (a " " ++ a "\n" ++ ignore) >> ((o) vector_of_list fst) in + mkparser csdpoutput;; + +(* ------------------------------------------------------------------------- *) +(* CSDP parameters; so far I'm sticking with the defaults. *) +(* ------------------------------------------------------------------------- *) + +let csdp_default_parameters = +"axtol=1.0e-8 +atytol=1.0e-8 +objtol=1.0e-8 +pinftol=1.0e8 +dinftol=1.0e8 +maxiter=100 +minstepfrac=0.9 +maxstepfrac=0.97 +minstepp=1.0e-8 +minstepd=1.0e-8 +usexzgap=1 +tweakgap=0 +affine=0 +printlevel=1 +";; + +let csdp_params = csdp_default_parameters;; + +(* ------------------------------------------------------------------------- *) +(* The same thing with CSDP. *) +(* Modified by the Coq development team to use a cache *) +(* ------------------------------------------------------------------------- *) + +let buffer_add_line buff line = + Buffer.add_string buff line; Buffer.add_char buff '\n' + +let string_of_file filename = + let fd = open_in filename in + let buff = Buffer.create 16 in + try while true do buffer_add_line buff (input_line fd) done; failwith "" + with End_of_file -> (close_in fd; Buffer.contents buff) + +let file_of_string filename s = + let fd = Pervasives.open_out filename in + output_string fd s; close_out fd + +let request_mark = "*** REQUEST ***" +let answer_mark = "*** ANSWER ***" +let end_mark = "*** END ***" +let infeasible_mark = "Infeasible\n" +let failure_mark = "Failure\n" + +let cache_name = "csdp.cache" + +let look_in_cache string_problem = + let n = String.length string_problem in + try + let inch = open_in cache_name in + let rec search () = + while input_line inch <> request_mark do () done; + let i = ref 0 in + while !i < n & string_problem.[!i] = input_char inch do incr i done; + if !i < n or input_line inch <> answer_mark then + search () + else begin + let buff = Buffer.create 16 in + let line = ref (input_line inch) in + while (!line <> end_mark) do + buffer_add_line buff !line; line := input_line inch + done; + close_in inch; + Buffer.contents buff + end in + try search () with End_of_file -> close_in inch; raise Not_found + with Sys_error _ -> raise Not_found + +let flush_to_cache string_problem string_result = + try + let flags = [Open_append;Open_text;Open_creat] in + let outch = open_out_gen flags 0o666 cache_name in + begin + try + Printf.fprintf outch "%s\n" request_mark; + Printf.fprintf outch "%s" string_problem; + Printf.fprintf outch "%s\n" answer_mark; + Printf.fprintf outch "%s" string_result; + Printf.fprintf outch "%s\n" end_mark; + with Sys_error _ as e -> close_out outch; raise e + end; + close_out outch + with Sys_error _ -> + print_endline "Warning: Could not open or write to csdp cache" + +exception CsdpInfeasible + +let run_csdp dbg string_problem = + try + let res = look_in_cache string_problem in + if res = infeasible_mark then raise CsdpInfeasible; + if res = failure_mark then failwith "csdp error"; + res + with Not_found -> + let input_file = Filename.temp_file "sos" ".dat-s" in + let output_file = Filename.temp_file "sos" ".dat-s" in + let temp_path = Filename.dirname input_file in + let params_file = Filename.concat temp_path "param.csdp" in + file_of_string input_file string_problem; + file_of_string params_file csdp_params; + let rv = Sys.command("cd "^temp_path^"; csdp "^input_file^" "^output_file^ + (if dbg then "" else "> /dev/null")) in + if rv = 1 or rv = 2 then + (flush_to_cache string_problem infeasible_mark; raise CsdpInfeasible); + if rv = 127 then + (print_string "csdp not found, exiting..."; exit 1); + if rv <> 0 & rv <> 3 (* reduced accuracy *) then + (flush_to_cache string_problem failure_mark; + failwith("csdp: error "^string_of_int rv)); + let string_result = string_of_file output_file in + flush_to_cache string_problem string_result; + if not dbg then + (Sys.remove input_file; Sys.remove output_file; Sys.remove params_file); + string_result + +let csdp obj mats = + try parse_csdpoutput (run_csdp !debugging (sdpa_of_problem "" obj mats)) + with CsdpInfeasible -> failwith "csdp: Problem is infeasible" + +(* ------------------------------------------------------------------------- *) +(* Try some apparently sensible scaling first. Note that this is purely to *) +(* get a cleaner translation to floating-point, and doesn't affect any of *) +(* the results, in principle. In practice it seems a lot better when there *) +(* are extreme numbers in the original problem. *) +(* ------------------------------------------------------------------------- *) + +let scale_then = + let common_denominator amat acc = + foldl (fun a m c -> lcm_num (denominator c) a) acc amat + and maximal_element amat acc = + foldl (fun maxa m c -> max_num maxa (abs_num c)) acc amat in + fun solver obj mats -> + let cd1 = itlist common_denominator mats (Int 1) + and cd2 = common_denominator (snd obj) (Int 1) in + let mats' = map (mapf (fun x -> cd1 */ x)) mats + and obj' = vector_cmul cd2 obj in + let max1 = itlist maximal_element mats' (Int 0) + and max2 = maximal_element (snd obj') (Int 0) in + let scal1 = pow2 (20-int_of_float(log(float_of_num max1) /. log 2.0)) + and scal2 = pow2 (20-int_of_float(log(float_of_num max2) /. log 2.0)) in + let mats'' = map (mapf (fun x -> x */ scal1)) mats' + and obj'' = vector_cmul scal2 obj' in + solver obj'' mats'';; + +(* ------------------------------------------------------------------------- *) +(* Round a vector to "nice" rationals. *) +(* ------------------------------------------------------------------------- *) + +let nice_rational n x = round_num (n */ x) // n;; + +let nice_vector n = mapa (nice_rational n);; + +(* ------------------------------------------------------------------------- *) +(* Reduce linear program to SDP (diagonal matrices) and test with CSDP. This *) +(* one tests A [-1;x1;..;xn] >= 0 (i.e. left column is negated constants). *) +(* ------------------------------------------------------------------------- *) + +let linear_program_basic a = + let m,n = dimensions a in + let mats = map (fun j -> diagonal (column j a)) (1--n) + and obj = vector_const (Int 1) m in + try ignore (run_csdp false (sdpa_of_problem "" obj mats)); true + with CsdpInfeasible -> false + +(* ------------------------------------------------------------------------- *) +(* Test whether a point is in the convex hull of others. Rather than use *) +(* computational geometry, express as linear inequalities and call CSDP. *) +(* This is a bit lazy of me, but it's easy and not such a bottleneck so far. *) +(* ------------------------------------------------------------------------- *) + +let in_convex_hull pts pt = + let pts1 = (1::pt) :: map (fun x -> 1::x) pts in + let pts2 = map (fun p -> map (fun x -> -x) p @ p) pts1 in + let n = length pts + 1 + and v = 2 * (length pt + 1) in + let m = v + n - 1 in + let mat = + (m,n), + itern 1 pts2 (fun pts j -> itern 1 pts (fun x i -> (i,j) |-> Int x)) + (iter (1,n) (fun i -> (v + i,i+1) |-> Int 1) undefined) in + linear_program_basic mat;; + +(* ------------------------------------------------------------------------- *) +(* Filter down a set of points to a minimal set with the same convex hull. *) +(* ------------------------------------------------------------------------- *) + +let minimal_convex_hull = + let augment1 = function (m::ms) -> if in_convex_hull ms m then ms else ms@[m] + | _ -> failwith "augment1" + in + let augment m ms = funpow 3 augment1 (m::ms) in + fun mons -> + let mons' = itlist augment (tl mons) [hd mons] in + funpow (length mons') augment1 mons';; + +(* ------------------------------------------------------------------------- *) +(* Stuff for "equations" (generic A->num functions). *) +(* ------------------------------------------------------------------------- *) + +let equation_cmul c eq = + if c =/ Int 0 then Empty else mapf (fun d -> c */ d) eq;; + +let equation_add eq1 eq2 = combine (+/) (fun x -> x =/ Int 0) eq1 eq2;; + +let equation_eval assig eq = + let value v = apply assig v in + foldl (fun a v c -> a +/ value(v) */ c) (Int 0) eq;; + +(* ------------------------------------------------------------------------- *) +(* Eliminate among linear equations: return unconstrained variables and *) +(* assignments for the others in terms of them. We give one pseudo-variable *) +(* "one" that's used for a constant term. *) +(* ------------------------------------------------------------------------- *) + + +let eliminate_equations = + let rec extract_first p l = + match l with + [] -> failwith "extract_first" + | h::t -> if p(h) then h,t else + let k,s = extract_first p t in + k,h::s in + let rec eliminate vars dun eqs = + match vars with + [] -> if forall is_undefined eqs then dun + else (raise Unsolvable) + | v::vs -> + try let eq,oeqs = extract_first (fun e -> defined e v) eqs in + let a = apply eq v in + let eq' = equation_cmul (Int(-1) // a) (undefine v eq) in + let elim e = + let b = tryapplyd e v (Int 0) in + if b =/ Int 0 then e else + equation_add e (equation_cmul (minus_num b // a) eq) in + eliminate vs ((v |-> eq') (mapf elim dun)) (map elim oeqs) + with Failure _ -> eliminate vs dun eqs in + fun one vars eqs -> + let assig = eliminate vars undefined eqs in + let vs = foldl (fun a x f -> subtract (dom f) [one] @ a) [] assig in + setify vs,assig;; + +(* ------------------------------------------------------------------------- *) +(* Eliminate all variables, in an essentially arbitrary order. *) +(* ------------------------------------------------------------------------- *) + +let eliminate_all_equations one = + let choose_variable eq = + let (v,_) = choose eq in + if v = one then + let eq' = undefine v eq in + if is_undefined eq' then failwith "choose_variable" else + let (w,_) = choose eq' in w + else v in + let rec eliminate dun eqs = + match eqs with + [] -> dun + | eq::oeqs -> + if is_undefined eq then eliminate dun oeqs else + let v = choose_variable eq in + let a = apply eq v in + let eq' = equation_cmul (Int(-1) // a) (undefine v eq) in + let elim e = + let b = tryapplyd e v (Int 0) in + if b =/ Int 0 then e else + equation_add e (equation_cmul (minus_num b // a) eq) in + eliminate ((v |-> eq') (mapf elim dun)) (map elim oeqs) in + fun eqs -> + let assig = eliminate undefined eqs in + let vs = foldl (fun a x f -> subtract (dom f) [one] @ a) [] assig in + setify vs,assig;; + +(* ------------------------------------------------------------------------- *) +(* Solve equations by assigning arbitrary numbers. *) +(* ------------------------------------------------------------------------- *) + +let solve_equations one eqs = + let vars,assigs = eliminate_all_equations one eqs in + let vfn = itlist (fun v -> (v |-> Int 0)) vars (one |=> Int(-1)) in + let ass = + combine (+/) (fun c -> false) (mapf (equation_eval vfn) assigs) vfn in + if forall (fun e -> equation_eval ass e =/ Int 0) eqs + then undefine one ass else raise Sanity;; + +(* ------------------------------------------------------------------------- *) +(* Hence produce the "relevant" monomials: those whose squares lie in the *) +(* Newton polytope of the monomials in the input. (This is enough according *) +(* to Reznik: "Extremal PSD forms with few terms", Duke Math. Journal, *) +(* vol 45, pp. 363--374, 1978. *) +(* *) +(* These are ordered in sort of decreasing degree. In particular the *) +(* constant monomial is last; this gives an order in diagonalization of the *) +(* quadratic form that will tend to display constants. *) +(* ------------------------------------------------------------------------- *) + +let newton_polytope pol = + let vars = poly_variables pol in + let mons = map (fun m -> map (fun x -> monomial_degree x m) vars) (dom pol) + and ds = map (fun x -> (degree x pol + 1) / 2) vars in + let all = itlist (fun n -> allpairs (fun h t -> h::t) (0--n)) ds [[]] + and mons' = minimal_convex_hull mons in + let all' = + filter (fun m -> in_convex_hull mons' (map (fun x -> 2 * x) m)) all in + map (fun m -> itlist2 (fun v i a -> if i = 0 then a else (v |-> i) a) + vars m monomial_1) (rev all');; + +(* ------------------------------------------------------------------------- *) +(* Diagonalize (Cholesky/LDU) the matrix corresponding to a quadratic form. *) +(* ------------------------------------------------------------------------- *) + +let diag m = + let nn = dimensions m in + let n = fst nn in + if snd nn <> n then failwith "diagonalize: non-square matrix" else + let rec diagonalize i m = + if is_zero m then [] else + let a11 = element m (i,i) in + if a11 </ Int 0 then failwith "diagonalize: not PSD" + else if a11 =/ Int 0 then + if is_zero(row i m) then diagonalize (i + 1) m + else failwith "diagonalize: not PSD" + else + let v = row i m in + let v' = mapa (fun a1k -> a1k // a11) v in + let m' = + (n,n), + iter (i+1,n) (fun j -> + iter (i+1,n) (fun k -> + ((j,k) |--> (element m (j,k) -/ element v j */ element v' k)))) + undefined in + (a11,v')::diagonalize (i + 1) m' in + diagonalize 1 m;; + +(* ------------------------------------------------------------------------- *) +(* Adjust a diagonalization to collect rationals at the start. *) +(* ------------------------------------------------------------------------- *) + +let deration d = + if d = [] then Int 0,d else + let adj(c,l) = + let a = foldl (fun a i c -> lcm_num a (denominator c)) (Int 1) (snd l) // + foldl (fun a i c -> gcd_num a (numerator c)) (Int 0) (snd l) in + (c // (a */ a)),mapa (fun x -> a */ x) l in + let d' = map adj d in + let a = itlist ((o) lcm_num ((o) denominator fst)) d' (Int 1) // + itlist ((o) gcd_num ((o) numerator fst)) d' (Int 0) in + (Int 1 // a),map (fun (c,l) -> (a */ c,l)) d';; + +(* ------------------------------------------------------------------------- *) +(* Enumeration of monomials with given multidegree bound. *) +(* ------------------------------------------------------------------------- *) + +let rec enumerate_monomials d vars = + if d < 0 then [] + else if d = 0 then [undefined] + else if vars = [] then [monomial_1] else + let alts = + map (fun k -> let oths = enumerate_monomials (d - k) (tl vars) in + map (fun ks -> if k = 0 then ks else (hd vars |-> k) ks) oths) + (0--d) in + end_itlist (@) alts;; + +(* ------------------------------------------------------------------------- *) +(* Enumerate products of distinct input polys with degree <= d. *) +(* We ignore any constant input polynomials. *) +(* Give the output polynomial and a record of how it was derived. *) +(* ------------------------------------------------------------------------- *) + +let rec enumerate_products d pols = + if d = 0 then [poly_const num_1,Rational_lt num_1] else if d < 0 then [] else + match pols with + [] -> [poly_const num_1,Rational_lt num_1] + | (p,b)::ps -> let e = multidegree p in + if e = 0 then enumerate_products d ps else + enumerate_products d ps @ + map (fun (q,c) -> poly_mul p q,Product(b,c)) + (enumerate_products (d - e) ps);; + +(* ------------------------------------------------------------------------- *) +(* Multiply equation-parametrized poly by regular poly and add accumulator. *) +(* ------------------------------------------------------------------------- *) + +let epoly_pmul p q acc = + foldl (fun a m1 c -> + foldl (fun b m2 e -> + let m = monomial_mul m1 m2 in + let es = tryapplyd b m undefined in + (m |-> equation_add (equation_cmul c e) es) b) + a q) acc p;; + +(* ------------------------------------------------------------------------- *) +(* Usual operations on equation-parametrized poly. *) +(* ------------------------------------------------------------------------- *) + +let epoly_cmul c l = + if c =/ Int 0 then undefined else mapf (equation_cmul c) l;; + +let epoly_neg x = epoly_cmul (Int(-1)) x;; + +let epoly_add x = combine equation_add is_undefined x;; + +let epoly_sub p q = epoly_add p (epoly_neg q);; + +(* ------------------------------------------------------------------------- *) +(* Convert regular polynomial. Note that we treat (0,0,0) as -1. *) +(* ------------------------------------------------------------------------- *) + +let epoly_of_poly p = + foldl (fun a m c -> (m |-> ((0,0,0) |=> minus_num c)) a) undefined p;; + +(* ------------------------------------------------------------------------- *) +(* String for block diagonal matrix numbered k. *) +(* ------------------------------------------------------------------------- *) + +let sdpa_of_blockdiagonal k m = + let pfx = string_of_int k ^" " in + let ents = + foldl (fun a (b,i,j) c -> if i > j then a else ((b,i,j),c)::a) [] m in + let entss = sort (increasing fst) ents in + itlist (fun ((b,i,j),c) a -> + pfx ^ string_of_int b ^ " " ^ string_of_int i ^ " " ^ string_of_int j ^ + " " ^ decimalize 20 c ^ "\n" ^ a) entss "";; + +(* ------------------------------------------------------------------------- *) +(* SDPA for problem using block diagonal (i.e. multiple SDPs) *) +(* ------------------------------------------------------------------------- *) + +let sdpa_of_blockproblem comment nblocks blocksizes obj mats = + let m = length mats - 1 in + "\"" ^ comment ^ "\"\n" ^ + string_of_int m ^ "\n" ^ + string_of_int nblocks ^ "\n" ^ + (end_itlist (fun s t -> s^" "^t) (map string_of_int blocksizes)) ^ + "\n" ^ + sdpa_of_vector obj ^ + itlist2 (fun k m a -> sdpa_of_blockdiagonal (k - 1) m ^ a) + (1--length mats) mats "";; + +(* ------------------------------------------------------------------------- *) +(* Hence run CSDP on a problem in block diagonal form. *) +(* ------------------------------------------------------------------------- *) + +let csdp_blocks nblocks blocksizes obj mats = + let string_problem = sdpa_of_blockproblem "" nblocks blocksizes obj mats in + try parse_csdpoutput (run_csdp !debugging string_problem) + with CsdpInfeasible -> failwith "csdp: Problem is infeasible" + +(* ------------------------------------------------------------------------- *) +(* 3D versions of matrix operations to consider blocks separately. *) +(* ------------------------------------------------------------------------- *) + +let bmatrix_add = combine (+/) (fun x -> x =/ Int 0);; + +let bmatrix_cmul c bm = + if c =/ Int 0 then undefined + else mapf (fun x -> c */ x) bm;; + +let bmatrix_neg = bmatrix_cmul (Int(-1));; + +let bmatrix_sub m1 m2 = bmatrix_add m1 (bmatrix_neg m2);; + +(* ------------------------------------------------------------------------- *) +(* Smash a block matrix into components. *) +(* ------------------------------------------------------------------------- *) + +let blocks blocksizes bm = + map (fun (bs,b0) -> + let m = foldl + (fun a (b,i,j) c -> if b = b0 then ((i,j) |-> c) a else a) + undefined bm in + (*let d = foldl (fun a (i,j) c -> max a (max i j)) 0 m in*) + (((bs,bs),m):matrix)) + (zip blocksizes (1--length blocksizes));; + +(* ------------------------------------------------------------------------- *) +(* Positiv- and Nullstellensatz. Flag "linf" forces a linear representation. *) +(* ------------------------------------------------------------------------- *) + +let real_positivnullstellensatz_general linf d eqs leqs pol + : poly list * (positivstellensatz * (num * poly) list) list = + + let vars = itlist ((o) union poly_variables) (pol::eqs @ map fst leqs) [] in + let monoid = + if linf then + (poly_const num_1,Rational_lt num_1):: + (filter (fun (p,c) -> multidegree p <= d) leqs) + else enumerate_products d leqs in + let nblocks = length monoid in + let mk_idmultiplier k p = + let e = d - multidegree p in + let mons = enumerate_monomials e vars in + let nons = zip mons (1--length mons) in + mons, + itlist (fun (m,n) -> (m |-> ((-k,-n,n) |=> Int 1))) nons undefined in + let mk_sqmultiplier k (p,c) = + let e = (d - multidegree p) / 2 in + let mons = enumerate_monomials e vars in + let nons = zip mons (1--length mons) in + mons, + itlist (fun (m1,n1) -> + itlist (fun (m2,n2) a -> + let m = monomial_mul m1 m2 in + if n1 > n2 then a else + let c = if n1 = n2 then Int 1 else Int 2 in + let e = tryapplyd a m undefined in + (m |-> equation_add ((k,n1,n2) |=> c) e) a) + nons) + nons undefined in + let sqmonlist,sqs = unzip(map2 mk_sqmultiplier (1--length monoid) monoid) + and idmonlist,ids = unzip(map2 mk_idmultiplier (1--length eqs) eqs) in + let blocksizes = map length sqmonlist in + let bigsum = + itlist2 (fun p q a -> epoly_pmul p q a) eqs ids + (itlist2 (fun (p,c) s a -> epoly_pmul p s a) monoid sqs + (epoly_of_poly(poly_neg pol))) in + let eqns = foldl (fun a m e -> e::a) [] bigsum in + let pvs,assig = eliminate_all_equations (0,0,0) eqns in + let qvars = (0,0,0)::pvs in + let allassig = itlist (fun v -> (v |-> (v |=> Int 1))) pvs assig in + let mk_matrix v = + foldl (fun m (b,i,j) ass -> if b < 0 then m else + let c = tryapplyd ass v (Int 0) in + if c =/ Int 0 then m else + ((b,j,i) |-> c) (((b,i,j) |-> c) m)) + undefined allassig in + let diagents = foldl + (fun a (b,i,j) e -> if b > 0 & i = j then equation_add e a else a) + undefined allassig in + let mats = map mk_matrix qvars + and obj = length pvs, + itern 1 pvs (fun v i -> (i |--> tryapplyd diagents v (Int 0))) + undefined in + let raw_vec = if pvs = [] then vector_0 0 + else scale_then (csdp_blocks nblocks blocksizes) obj mats in + let find_rounding d = + (if !debugging then + (Format.print_string("Trying rounding with limit "^string_of_num d); + Format.print_newline()) + else ()); + let vec = nice_vector d raw_vec in + let blockmat = iter (1,dim vec) + (fun i a -> bmatrix_add (bmatrix_cmul (element vec i) (el i mats)) a) + (bmatrix_neg (el 0 mats)) in + let allmats = blocks blocksizes blockmat in + vec,map diag allmats in + let vec,ratdias = + if pvs = [] then find_rounding num_1 + else tryfind find_rounding (map Num.num_of_int (1--31) @ + map pow2 (5--66)) in + let newassigs = + itlist (fun k -> el (k - 1) pvs |-> element vec k) + (1--dim vec) ((0,0,0) |=> Int(-1)) in + let finalassigs = + foldl (fun a v e -> (v |-> equation_eval newassigs e) a) newassigs + allassig in + let poly_of_epoly p = + foldl (fun a v e -> (v |--> equation_eval finalassigs e) a) + undefined p in + let mk_sos mons = + let mk_sq (c,m) = + c,itlist (fun k a -> (el (k - 1) mons |--> element m k) a) + (1--length mons) undefined in + map mk_sq in + let sqs = map2 mk_sos sqmonlist ratdias + and cfs = map poly_of_epoly ids in + let msq = filter (fun (a,b) -> b <> []) (map2 (fun a b -> a,b) monoid sqs) in + let eval_sq sqs = itlist + (fun (c,q) -> poly_add (poly_cmul c (poly_mul q q))) sqs poly_0 in + let sanity = + itlist (fun ((p,c),s) -> poly_add (poly_mul p (eval_sq s))) msq + (itlist2 (fun p q -> poly_add (poly_mul p q)) cfs eqs + (poly_neg pol)) in + if not(is_undefined sanity) then raise Sanity else + cfs,map (fun (a,b) -> snd a,b) msq;; + + +let term_of_monoid l1 m = itlist (fun i m -> Mul (nth l1 i,m)) m (Const num_1) + +let rec term_of_pos l1 x = match x with + Axiom_eq i -> failwith "term_of_pos" + | Axiom_le i -> nth l1 i + | Axiom_lt i -> nth l1 i + | Monoid m -> term_of_monoid l1 m + | Rational_eq n -> Const n + | Rational_le n -> Const n + | Rational_lt n -> Const n + | Square t -> Pow (t, 2) + | Eqmul (t, y) -> Mul (t, term_of_pos l1 y) + | Sum (y, z) -> Add (term_of_pos l1 y, term_of_pos l1 z) + | Product (y, z) -> Mul (term_of_pos l1 y, term_of_pos l1 z);; + + +let dest_monomial mon = sort (increasing fst) (graph mon);; + +let monomial_order = + let rec lexorder l1 l2 = + match (l1,l2) with + [],[] -> true + | vps,[] -> false + | [],vps -> true + | ((x1,n1)::vs1),((x2,n2)::vs2) -> + if x1 < x2 then true + else if x2 < x1 then false + else if n1 < n2 then false + else if n2 < n1 then true + else lexorder vs1 vs2 in + fun m1 m2 -> + if m2 = monomial_1 then true else if m1 = monomial_1 then false else + let mon1 = dest_monomial m1 and mon2 = dest_monomial m2 in + let deg1 = itlist ((o) (+) snd) mon1 0 + and deg2 = itlist ((o) (+) snd) mon2 0 in + if deg1 < deg2 then false else if deg1 > deg2 then true + else lexorder mon1 mon2;; + +let dest_poly p = + map (fun (m,c) -> c,dest_monomial m) + (sort (fun (m1,_) (m2,_) -> monomial_order m1 m2) (graph p));; + +(* ------------------------------------------------------------------------- *) +(* Map back polynomials and their composites to term. *) +(* ------------------------------------------------------------------------- *) + +let term_of_varpow = + fun x k -> + if k = 1 then Var x else Pow (Var x, k);; + +let term_of_monomial = + fun m -> if m = monomial_1 then Const num_1 else + let m' = dest_monomial m in + let vps = itlist (fun (x,k) a -> term_of_varpow x k :: a) m' [] in + end_itlist (fun s t -> Mul (s,t)) vps;; + +let term_of_cmonomial = + fun (m,c) -> + if m = monomial_1 then Const c + else if c =/ num_1 then term_of_monomial m + else Mul (Const c,term_of_monomial m);; + +let term_of_poly = + fun p -> + if p = poly_0 then Zero else + let cms = map term_of_cmonomial + (sort (fun (m1,_) (m2,_) -> monomial_order m1 m2) (graph p)) in + end_itlist (fun t1 t2 -> Add (t1,t2)) cms;; + +let term_of_sqterm (c,p) = + Product(Rational_lt c,Square(term_of_poly p));; + +let term_of_sos (pr,sqs) = + if sqs = [] then pr + else Product(pr,end_itlist (fun a b -> Sum(a,b)) (map term_of_sqterm sqs));; + +let rec deepen f n = + try (*print_string "Searching with depth limit "; + print_int n; print_newline();*) f n + with Failure _ -> deepen f (n + 1);; + + + + + +exception TooDeep + +let deepen_until limit f n = + match compare limit 0 with + | 0 -> raise TooDeep + | -1 -> deepen f n + | _ -> + let rec d_until f n = + try if !debugging + then (print_string "Searching with depth limit "; + print_int n; print_newline()) ; f n + with Failure x -> + if !debugging then (Printf.printf "solver error : %s\n" x) ; + if n = limit then raise TooDeep else d_until f (n + 1) in + d_until f n + + +(* patch to remove zero polynomials from equalities. + In this case, hol light loops *) + +let real_nonlinear_prover depthmax eqs les lts = + let eq = map poly_of_term eqs + and le = map poly_of_term les + and lt = map poly_of_term lts in + let pol = itlist poly_mul lt (poly_const num_1) + and lep = map (fun (t,i) -> t,Axiom_le i) (zip le (0--(length le - 1))) + and ltp = map (fun (t,i) -> t,Axiom_lt i) (zip lt (0--(length lt - 1))) + and eqp = itlist2 (fun t i res -> + if t = undefined then res else (t,Axiom_eq i)::res) eq (0--(length eq - 1)) [] + in + + let proof = + let leq = lep @ ltp in + let eq = List.map fst eqp in + let tryall d = + let e = multidegree pol (*and pol' = poly_neg pol*) in + let k = if e = 0 then 1 else d / e in + tryfind (fun i -> d,i, + real_positivnullstellensatz_general false d eq leq + (poly_neg(poly_pow pol i))) + (0--k) in + let d,i,(cert_ideal,cert_cone) = deepen_until depthmax tryall 0 in + let proofs_ideal = + map2 (fun q i -> Eqmul(term_of_poly q,i)) + cert_ideal (List.map snd eqp) + and proofs_cone = map term_of_sos cert_cone + and proof_ne = + if lt = [] then Rational_lt num_1 else + let p = end_itlist (fun s t -> Product(s,t)) (map snd ltp) in + funpow i (fun q -> Product(p,q)) (Rational_lt num_1) in + end_itlist (fun s t -> Sum(s,t)) (proof_ne :: proofs_ideal @ proofs_cone) in + if !debugging then (print_string("Translating proof certificate to Coq"); print_newline()); + proof;; + + +(* ------------------------------------------------------------------------- *) +(* Now pure SOS stuff. *) +(* ------------------------------------------------------------------------- *) + +(* ------------------------------------------------------------------------- *) +(* Some combinatorial helper functions. *) +(* ------------------------------------------------------------------------- *) + +let rec allpermutations l = + if l = [] then [[]] else + itlist (fun h acc -> map (fun t -> h::t) + (allpermutations (subtract l [h])) @ acc) l [];; + +let allvarorders l = + map (fun vlis x -> index x vlis) (allpermutations l);; + +let changevariables_monomial zoln (m:monomial) = + foldl (fun a x k -> (assoc x zoln |-> k) a) monomial_1 m;; + +let changevariables zoln pol = + foldl (fun a m c -> (changevariables_monomial zoln m |-> c) a) + poly_0 pol;; + +(* ------------------------------------------------------------------------- *) +(* Sum-of-squares function with some lowbrow symmetry reductions. *) +(* ------------------------------------------------------------------------- *) + +let sumofsquares_general_symmetry tool pol = + let vars = poly_variables pol + and lpps = newton_polytope pol in + let n = length lpps in + let sym_eqs = + let invariants = filter + (fun vars' -> + is_undefined(poly_sub pol (changevariables (zip vars vars') pol))) + (allpermutations vars) in +(* let lpps2 = allpairs monomial_mul lpps lpps in*) +(* let lpp2_classes = + setify(map (fun m -> + setify(map (fun vars' -> changevariables_monomial (zip vars vars') m) + invariants)) lpps2) in *) + let lpns = zip lpps (1--length lpps) in + let lppcs = + filter (fun (m,(n1,n2)) -> n1 <= n2) + (allpairs + (fun (m1,n1) (m2,n2) -> (m1,m2),(n1,n2)) lpns lpns) in + let clppcs = end_itlist (@) + (map (fun ((m1,m2),(n1,n2)) -> + map (fun vars' -> + (changevariables_monomial (zip vars vars') m1, + changevariables_monomial (zip vars vars') m2),(n1,n2)) + invariants) + lppcs) in + let clppcs_dom = setify(map fst clppcs) in + let clppcs_cls = map (fun d -> filter (fun (e,_) -> e = d) clppcs) + clppcs_dom in + let eqvcls = map (o setify (map snd)) clppcs_cls in + let mk_eq cls acc = + match cls with + [] -> raise Sanity + | [h] -> acc + | h::t -> map (fun k -> (k |-> Int(-1)) (h |=> Int 1)) t @ acc in + itlist mk_eq eqvcls [] in + let eqs = foldl (fun a x y -> y::a) [] + (itern 1 lpps (fun m1 n1 -> + itern 1 lpps (fun m2 n2 f -> + let m = monomial_mul m1 m2 in + if n1 > n2 then f else + let c = if n1 = n2 then Int 1 else Int 2 in + (m |-> ((n1,n2) |-> c) (tryapplyd f m undefined)) f)) + (foldl (fun a m c -> (m |-> ((0,0)|=>c)) a) + undefined pol)) @ + sym_eqs in + let pvs,assig = eliminate_all_equations (0,0) eqs in + let allassig = itlist (fun v -> (v |-> (v |=> Int 1))) pvs assig in + let qvars = (0,0)::pvs in + let diagents = + end_itlist equation_add (map (fun i -> apply allassig (i,i)) (1--n)) in + let mk_matrix v = + ((n,n), + foldl (fun m (i,j) ass -> let c = tryapplyd ass v (Int 0) in + if c =/ Int 0 then m else + ((j,i) |-> c) (((i,j) |-> c) m)) + undefined allassig :matrix) in + let mats = map mk_matrix qvars + and obj = length pvs, + itern 1 pvs (fun v i -> (i |--> tryapplyd diagents v (Int 0))) + undefined in + let raw_vec = if pvs = [] then vector_0 0 else tool obj mats in + let find_rounding d = + (if !debugging then + (Format.print_string("Trying rounding with limit "^string_of_num d); + Format.print_newline()) + else ()); + let vec = nice_vector d raw_vec in + let mat = iter (1,dim vec) + (fun i a -> matrix_add (matrix_cmul (element vec i) (el i mats)) a) + (matrix_neg (el 0 mats)) in + deration(diag mat) in + let rat,dia = + if pvs = [] then + let mat = matrix_neg (el 0 mats) in + deration(diag mat) + else + tryfind find_rounding (map Num.num_of_int (1--31) @ + map pow2 (5--66)) in + let poly_of_lin(d,v) = + d,foldl(fun a i c -> (el (i - 1) lpps |-> c) a) undefined (snd v) in + let lins = map poly_of_lin dia in + let sqs = map (fun (d,l) -> poly_mul (poly_const d) (poly_pow l 2)) lins in + let sos = poly_cmul rat (end_itlist poly_add sqs) in + if is_undefined(poly_sub sos pol) then rat,lins else raise Sanity;; + +let (sumofsquares: poly -> Num.num * (( Num.num * poly) list)) = +sumofsquares_general_symmetry csdp;; diff --git a/contrib/micromega/sos.mli b/contrib/micromega/sos.mli new file mode 100644 index 00000000..31c9518c --- /dev/null +++ b/contrib/micromega/sos.mli @@ -0,0 +1,66 @@ +(************************************************************************) +(* 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 *) +(************************************************************************) + + +type vname = string;; + +type term = +| Zero +| Const of Num.num +| Var of vname +| Inv of term +| Opp of term +| Add of (term * term) +| Sub of (term * term) +| Mul of (term * term) +| Div of (term * term) +| Pow of (term * int) + +type positivstellensatz = + Axiom_eq of int + | Axiom_le of int + | Axiom_lt of int + | Rational_eq of Num.num + | Rational_le of Num.num + | Rational_lt of Num.num + | Square of term + | Monoid of int list + | Eqmul of term * positivstellensatz + | Sum of positivstellensatz * positivstellensatz + | Product of positivstellensatz * positivstellensatz + +type poly + +val poly_isconst : poly -> bool + +val poly_neg : poly -> poly + +val poly_mul : poly -> poly -> poly + +val poly_pow : poly -> int -> poly + +val poly_const : Num.num -> poly + +val poly_of_term : term -> poly + +val term_of_poly : poly -> term + +val term_of_sos : positivstellensatz * (Num.num * poly) list -> + positivstellensatz + +val string_of_poly : poly -> string + +exception TooDeep + +val deepen_until : int -> (int -> 'a) -> int -> 'a + +val real_positivnullstellensatz_general : bool -> int -> poly list -> + (poly * positivstellensatz) list -> + poly -> poly list * (positivstellensatz * (Num.num * poly) list) list + +val sumofsquares : poly -> Num.num * ( Num.num * poly) list diff --git a/contrib/micromega/vector.ml b/contrib/micromega/vector.ml new file mode 100644 index 00000000..fee4ebfc --- /dev/null +++ b/contrib/micromega/vector.ml @@ -0,0 +1,674 @@ +(************************************************************************) +(* 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 *) +(************************************************************************) +(* *) +(* Micromega: A reflexive tactic using the Positivstellensatz *) +(* *) +(* Frédéric Besson (Irisa/Inria) 2006-2008 *) +(* *) +(************************************************************************) + +open Num + +module type S = +sig + type t + + val fresh : t -> int + + val null : t + + val is_null : t -> bool + + val get : int -> t -> num + + val update : int -> (num -> num) -> t -> t + (* behaviour is undef if index < 0 -- might loop*) + + val set : int -> num -> t -> t + + (* + For efficiency... + + val get_update : int -> (num -> num) -> t -> num * t + *) + + val mul : num -> t -> t + + val uminus : t -> t + + val add : t -> t -> t + + val dotp : t -> t -> num + + val lin_comb : num -> t -> num -> t -> t + (* lin_comb n1 t1 n2 t2 = (n1 * t1) + (n2 * t2) *) + + val gcd : t -> Big_int.big_int + + val normalise : t -> num * t + + val hash : t -> int + + val compare : t -> t -> int + + type it + + val iterator : t -> it + val element : it -> (num*it) option + + val string : t -> string + + type status = Pos | Neg + + (* the result list is ordered by fst *) + val status : t -> (int * status) list + + val from_list : num list -> t + val to_list : t -> num list + +end + + +module type SystemS = +sig + + module Vect : S + + module Cstr : + sig + type kind = Eq | Ge + val string_of_kind : kind -> string + type cstr = {coeffs : Vect.t ; op : kind ; cst : num} + val string_of_cstr : cstr -> string + val compare : cstr -> cstr -> int + end + open Cstr + + + module CstrBag : + sig + type t + exception Contradiction + + val empty : t + + val is_empty : t -> bool + + val add : cstr -> t -> t + (* c can be deduced from add c t *) + + val find : (cstr -> bool) -> t -> cstr option + + val fold : (cstr -> 'a -> 'a) -> t -> 'a -> 'a + + val status : t -> (int * (int list * int list)) list + (* aggregate of vector statuses *) + + val remove : cstr -> t -> t + + (* remove_list the ith element -- it is the ith element visited by 'fold' *) + + val split : (cstr -> int) -> t -> (int -> t) + + type it + val iterator : t -> it + val element : it -> (cstr*it) option + + end + +end + +let zero_num = Int 0 +let unit_num = Int 1 + + + + +module Cstr(V:S) = +struct + type kind = Eq | Ge + let string_of_kind = function Eq -> "Eq" | Ge -> "Ge" + + type cstr = {coeffs : V.t ; op : kind ; cst : num} + + let string_of_cstr {coeffs =a ; op = b ; cst =c} = + Printf.sprintf "{coeffs = %s;op=%s;cst=%s}" (V.string a) (string_of_kind b) (string_of_num c) + + type t = cstr + let compare + {coeffs = v1 ; op = op1 ; cst = c1} + {coeffs = v2 ; op = op2 ; cst = c2} = + Mutils.Cmp.compare_lexical [ + (fun () -> V.compare v1 v2); + (fun () -> Pervasives.compare op1 op2); + (fun () -> compare_num c1 c2) + ] + + +end + + + +module VList : S with type t = num list = +struct + type t = num list + + let fresh l = failwith "not implemented" + + let null = [] + + let is_null = List.for_all ((=/) zero_num) + + let normalise l = failwith "Not implemented" + (*match l with (* Buggy : What if the first num is zero! *) + | [] -> (Int 0,[]) + | [n] -> (n,[Int 1]) + | n::l -> (n, (Int 1) :: List.map (fun x -> x // n) l) + *) + + + let get i l = try List.nth l i with _ -> zero_num + + (* This is not tail-recursive *) + let rec update i f t = + match t with + | [] -> if i = 0 then [f zero_num] else (zero_num)::(update (i-1) f []) + | e::t -> if i = 0 then (f e)::t else e::(update (i-1) f t) + + let rec set i n t = + match t with + | [] -> if i = 0 then [n] else (zero_num)::(set (i-1) n []) + | e::t -> if i = 0 then (n)::t else e::(set (i-1) n t) + + + + + let rec mul z t = + match z with + | Int 0 -> null + | Int 1 -> t + | _ -> List.map (mult_num z) t + + let uminus t = mul (Int (-1)) t + + let rec add t1 t2 = + match t1,t2 with + | [], _ -> t2 + | _ , [] -> t1 + | e1::t1,e2::t2 -> (e1 +/ e2 )::(add t1 t2) + + let dotp t1 t2 = + let rec _dotp t1 t2 acc = + match t1, t2 with + | [] , _ -> acc + | _ , [] -> acc + | e1::t1,e2::t2 -> _dotp t1 t2 (acc +/ (e1 */ e2)) in + _dotp t1 t2 zero_num + + let add_mul n t1 t2 = + match n with + | Int 0 -> t2 + | Int 1 -> add t1 t2 + | _ -> + let rec _add_mul t1 t2 = + match t1,t2 with + | [], _ -> t2 + | _ , [] -> mul n t1 + | e1::t1,e2::t2 -> ( (n */e1) +/ e2 )::(_add_mul t1 t2) in + _add_mul t1 t2 + + let lin_comb n1 t1 n2 t2 = + match n1,n2 with + | Int 0 , _ -> mul n2 t2 + | Int 1 , _ -> add_mul n2 t2 t1 + | _ , Int 0 -> mul n1 t1 + | _ , Int 1 -> add_mul n1 t1 t2 + | _ -> + let rec _lin_comb t1 t2 = + match t1,t2 with + | [], _ -> mul n2 t2 + | _ , [] -> mul n1 t1 + | e1::t1,e2::t2 -> ( (n1 */e1) +/ (n2 */ e2 ))::(_lin_comb t1 t2) in + _lin_comb t1 t2 + + (* could be computed on the fly *) + let gcd t =Mutils.gcd_list t + + + + + let hash = Mutils.Cmp.hash_list int_of_num + + let compare = Mutils.Cmp.compare_list compare_num + + type it = t + let iterator (x:t) : it = x + let element it = + match it with + | [] -> None + | e::l -> Some (e,l) + + (* TODO: Buffer! *) + let string l = List.fold_right (fun n s -> (string_of_num n)^";"^s) l "" + + type status = Pos | Neg + + let status l = + let rec xstatus i l = + match l with + | [] -> [] + | e::l -> + begin + match compare_num e (Int 0) with + | 1 -> (i,Pos):: (xstatus (i+1) l) + | 0 -> xstatus (i+1) l + | -1 -> (i,Neg) :: (xstatus (i+1) l) + | _ -> assert false + end in + xstatus 0 l + + let from_list l = l + let to_list l = l + +end + +module VMap : S = +struct + module Map = Map.Make(struct type t = int let compare (x:int) (y:int) = Pervasives.compare x y end) + + type t = num Map.t + + let null = Map.empty + + let fresh m = failwith "not implemented" + + let is_null = Map.is_empty + + let normalise m = failwith "Not implemented" + + + + let get i l = try Map.find i l with _ -> zero_num + + let update i f t = + try + let res = f (Map.find i t) in + if res =/ zero_num + then Map.remove i t + else Map.add i res t + with + Not_found -> + let res = f zero_num in + if res =/ zero_num then t else Map.add i res t + + let set i n t = + if n =/ zero_num then Map.remove i t + else Map.add i n t + + + let rec mul z t = + match z with + | Int 0 -> null + | Int 1 -> t + | _ -> Map.map (mult_num z) t + + let uminus t = mul (Int (-1)) t + + + let map2 f m1 m2 = + let res,m2' = + Map.fold (fun k e (res,m2) -> + let v = f e (get k m2) in + if v =/ zero_num + then (res,Map.remove k m2) + else (Map.add k v res,Map.remove k m2)) m1 (Map.empty,m2) in + Map.fold (fun k e res -> + let v = f zero_num e in + if v =/ zero_num + then res else Map.add k v res) m2' res + + let add t1 t2 = map2 (+/) t1 t2 + + + let dotp t1 t2 = + Map.fold (fun k e res -> + res +/ (e */ get k t2)) t1 zero_num + + + + let add_mul n t1 t2 = + match n with + | Int 0 -> t2 + | Int 1 -> add t1 t2 + | _ -> map2 (fun x y -> (n */ x) +/ y) t1 t2 + + let lin_comb n1 t1 n2 t2 = + match n1,n2 with + | Int 0 , _ -> mul n2 t2 + | Int 1 , _ -> add_mul n2 t2 t1 + | _ , Int 0 -> mul n1 t1 + | _ , Int 1 -> add_mul n1 t1 t2 + | _ -> map2 (fun x y -> (n1 */ x) +/ (n2 */ y)) t1 t2 + + + let hash map = Map.fold (fun k e res -> k lxor (int_of_num e) lxor res) map 0 + + let compare = Map.compare compare_num + + type it = t * int + + let iterator (x:t) : it = (x,0) + + let element (mp,id) = + try + Some (Map.find id mp, (mp, id+1)) + with + Not_found -> None + + (* TODO: Buffer! *) + type status = Pos | Neg + + let status l = Map.fold (fun k e l -> + match compare_num e (Int 0) with + | 1 -> (k,Pos)::l + | 0 -> l + | -1 -> (k,Neg) :: l + | _ -> assert false) l [] + let from_list l = + let rec from_list i l map = + match l with + | [] -> map + | e::l -> from_list (i+1) l (if e <>/ Int 0 then Map.add i e map else map) in + from_list 0 l Map.empty + + let gcd m = + let res = Map.fold (fun _ e x -> Big_int.gcd_big_int x (Mutils.numerator e)) m Big_int.zero_big_int in + if Big_int.compare_big_int res Big_int.zero_big_int = 0 + then Big_int.unit_big_int else res + + + let to_list m = + let l = List.rev (Map.fold (fun k e l -> (k,e)::l) m []) in + let rec xto_list i l = + match l with + | [] -> [] + | (x,v)::l' -> if i = x then v::(xto_list (i+1) l') else zero_num ::(xto_list (i+1) l) in + xto_list 0 l + + let string l = VList.string (to_list l) + + +end + + +module VSparse : S = +struct + + type t = (int*num) list + + let null = [] + + let fresh l = List.fold_left (fun acc (i,_) -> max (i+1) acc) 0 l + + let is_null l = l = [] + + let rec is_sorted l = + match l with + | [] -> true + | [e] -> true + | (i,_)::(j,x)::l -> i < j && is_sorted ((j,x)::l) + + + let check l = (List.for_all (fun (_,n) -> compare_num n (Int 0) <> 0) l) && (is_sorted l) + + (* let get i t = + assert (check t); + try List.assoc i t with Not_found -> zero_num *) + + let rec get (i:int) t = + match t with + | [] -> zero_num + | (j,n)::t -> + match compare i j with + | 0 -> n + | 1 -> get i t + | _ -> zero_num + + let cons i v rst = if v =/ Int 0 then rst else (i,v)::rst + + let rec update i f t = + match t with + | [] -> cons i (f zero_num) [] + | (k,v)::l -> + match Pervasives.compare i k with + | 0 -> cons k (f v) l + | -1 -> cons i (f zero_num) t + | 1 -> (k,v) ::(update i f l) + | _ -> failwith "compare_num" + + let update i f t = + assert (check t); + let res = update i f t in + assert (check t) ; res + + + let rec set i n t = + match t with + | [] -> cons i n [] + | (k,v)::l -> + match Pervasives.compare i k with + | 0 -> cons k n l + | -1 -> cons i n t + | 1 -> (k,v) :: (set i n l) + | _ -> failwith "compare_num" + + + let rec map f l = + match l with + | [] -> [] + | (i,e)::l -> cons i (f e) (map f l) + + let rec mul z t = + match z with + | Int 0 -> null + | Int 1 -> t + | _ -> List.map (fun (i,n) -> (i, mult_num z n)) t + + let mul z t = + assert (check t) ; + let res = mul z t in + assert (check res) ; + res + + let uminus t = mul (Int (-1)) t + + + let normalise l = + match l with + | [] -> (Int 0,[]) + | (i,n)::_ -> (n, mul ((Int 1) // n) l) + + + let rec map2 f m1 m2 = + match m1, m2 with + | [] , [] -> [] + | l , [] -> map (fun x -> f x zero_num) l + | [] ,l -> map (f zero_num) l + | (i,e)::l1,(i',e')::l2 -> + match Pervasives.compare i i' with + | 0 -> cons i (f e e') (map2 f l1 l2) + | -1 -> cons i (f e zero_num) (map2 f l1 m2) + | 1 -> cons i' (f zero_num e') (map2 f m1 l2) + | _ -> assert false + + (* let add t1 t2 = map2 (+/) t1 t2*) + + let rec add (m1:t) (m2:t) = + match m1, m2 with + | [] , [] -> [] + | l , [] -> l + | [] ,l -> l + | (i,e)::l1,(i',e')::l2 -> + match Pervasives.compare i i' with + | 0 -> cons i ( e +/ e') (add l1 l2) + | -1 -> (i,e) :: (add l1 m2) + | 1 -> (i', e') :: (add m1 l2) + | _ -> assert false + + + + + let add t1 t2 = + assert (check t1 && check t2); + let res = add t1 t2 in + assert (check res); + res + + + let rec dotp (t1:t) (t2:t) = + match t1, t2 with + | [] , _ -> zero_num + | _ , [] -> zero_num + | (i,e)::l1 , (i',e')::l2 -> + match Pervasives.compare i i' with + | 0 -> (e */ e') +/ (dotp l1 l2) + | -1 -> dotp l1 t2 + | 1 -> dotp t1 l2 + | _ -> assert false + + let dotp t1 t2 = + assert (check t1 && check t2) ; dotp t1 t2 + + let add_mul n t1 t2 = + match n with + | Int 0 -> t2 + | Int 1 -> add t1 t2 + | _ -> map2 (fun x y -> (n */ x) +/ y) t1 t2 + + let add_mul n (t1:t) (t2:t) = + match n with + | Int 0 -> t2 + | Int 1 -> add t1 t2 + | _ -> + let rec xadd_mul m1 m2 = + match m1, m2 with + | [] , [] -> [] + | _ , [] -> mul n m1 + | [] , _ -> m2 + | (i,e)::l1,(i',e')::l2 -> + match Pervasives.compare i i' with + | 0 -> cons i ( n */ e +/ e') (xadd_mul l1 l2) + | -1 -> (i,n */ e) :: (xadd_mul l1 m2) + | 1 -> (i', e') :: (xadd_mul m1 l2) + | _ -> assert false in + xadd_mul t1 t2 + + + + + let lin_comb n1 t1 n2 t2 = + match n1,n2 with + | Int 0 , _ -> mul n2 t2 + | Int 1 , _ -> add_mul n2 t2 t1 + | _ , Int 0 -> mul n1 t1 + | _ , Int 1 -> add_mul n1 t1 t2 + | _ -> (*map2 (fun x y -> (n1 */ x) +/ (n2 */ y)) t1 t2*) + let rec xlin_comb m1 m2 = + match m1, m2 with + | [] , [] -> [] + | _ , [] -> mul n1 m1 + | [] , _ -> mul n2 m2 + | (i,e)::l1,(i',e')::l2 -> + match Pervasives.compare i i' with + | 0 -> cons i ( n1 */ e +/ n2 */ e') (xlin_comb l1 l2) + | -1 -> (i,n1 */ e) :: (xlin_comb l1 m2) + | 1 -> (i', n2 */ e') :: (xlin_comb m1 l2) + | _ -> assert false in + xlin_comb t1 t2 + + + + + + let lin_comb n1 t1 n2 t2 = + assert (check t1 && check t2); + let res = lin_comb n1 t1 n2 t2 in + assert (check res); res + + let hash = Mutils.Cmp.hash_list (fun (x,y) -> (Hashtbl.hash x) lxor (int_of_num y)) + + + let compare = Mutils.Cmp.compare_list (fun x y -> Mutils.Cmp.compare_lexical + [ + (fun () -> Pervasives.compare (fst x) (fst y)); + (fun () -> compare_num (snd x) (snd y))]) + + (* + let compare (x:t) (y:t) = + let rec xcompare acc1 acc2 x y = + match x , y with + | [] , [] -> xcomp acc1 acc2 + | [] , _ -> -1 + | _ , [] -> 1 + | (i,n1)::l1 , (j,n2)::l2 -> + match Pervasives.compare i j with + | 0 -> xcompare (n1::acc1) (n2::acc2) l1 l2 + | c -> c + and xcomp acc1 acc2 = Mutils.Cmp.compare_list compare_num acc1 acc2 in + xcompare [] [] x y + *) + + type it = t + + let iterator (x:t) : it = x + + let element l = failwith "Not_implemented" + + (* TODO: Buffer! *) + type status = Pos | Neg + + let status l = List.map (fun (i,e) -> + match compare_num e (Int 0) with + | 1 -> i,Pos + | -1 -> i,Neg + | _ -> assert false) l + + let from_list (l: num list) = + let rec xfrom_list i l = + match l with + | [] -> [] + | e::l -> + if e <>/ Int 0 + then (i,e)::(xfrom_list (i+1) l) + else xfrom_list (i+1) l in + + let res = xfrom_list 0 l in + assert (check res) ; res + + + let gcd m = + let res = List.fold_left (fun x (i,e) -> Big_int.gcd_big_int x (Mutils.numerator e)) Big_int.zero_big_int m in + if Big_int.compare_big_int res Big_int.zero_big_int = 0 + then Big_int.unit_big_int else res + + let to_list m = + let rec xto_list i l = + match l with + | [] -> [] + | (x,v)::l' -> + if i = x then v::(xto_list (i+1) l') else zero_num ::(xto_list (i+1) l) in + xto_list 0 m + + let to_list l = + assert (check l); + to_list l + + + let string l = VList.string (to_list l) + +end diff --git a/contrib/omega/Omega.v b/contrib/omega/Omega.v index 66f86a49..ee823502 100644 --- a/contrib/omega/Omega.v +++ b/contrib/omega/Omega.v @@ -9,15 +9,16 @@ (* *) (* Omega: a solver of quantifier-free problems in Presburger Arithmetic *) (* *) -(* Pierre Crégut (CNET, Lannion, France) *) +(* Pierre Crégut (CNET, Lannion, France) *) (* *) (**************************************************************************) -(* $Id: Omega.v 8642 2006-03-17 10:09:02Z notin $ *) +(* $Id: Omega.v 10028 2007-07-18 22:38:06Z letouzey $ *) (* We do not require [ZArith] anymore, but only what's necessary for Omega *) Require Export ZArith_base. Require Export OmegaLemmas. +Require Export PreOmega. Hint Resolve Zle_refl Zplus_comm Zplus_assoc Zmult_comm Zmult_assoc Zplus_0_l Zplus_0_r Zmult_1_l Zplus_opp_l Zplus_opp_r Zmult_plus_distr_l diff --git a/contrib/omega/PreOmega.v b/contrib/omega/PreOmega.v new file mode 100644 index 00000000..47e22a97 --- /dev/null +++ b/contrib/omega/PreOmega.v @@ -0,0 +1,445 @@ +Require Import Arith Max Min ZArith_base NArith Nnat. + +Open Local Scope Z_scope. + + +(** * zify: the Z-ification tactic *) + +(* This tactic searches for nat and N and positive elements in the goal and + translates everything into Z. It is meant as a pre-processor for + (r)omega; for instance a positivity hypothesis is added whenever + - a multiplication is encountered + - an atom is encountered (that is a variable or an unknown construct) + + Recognized relations (can be handled as deeply as allowed by setoid rewrite): + - { eq, le, lt, ge, gt } on { Z, positive, N, nat } + + Recognized operations: + - on Z: Zmin, Zmax, Zabs, Zsgn are translated in term of <= < = + - on nat: + * - S O pred min max nat_of_P nat_of_N Zabs_nat + - on positive: Zneg Zpos xI xO xH + * - Psucc Ppred Pmin Pmax P_of_succ_nat + - on N: N0 Npos + * - Nsucc Nmin Nmax N_of_nat Zabs_N +*) + + + + +(** I) translation of Zmax, Zmin, Zabs, Zsgn into recognized equations *) + +Ltac zify_unop_core t thm a := + (* Let's introduce the specification theorem for t *) + let H:= fresh "H" in assert (H:=thm a); + (* Then we replace (t a) everywhere with a fresh variable *) + let z := fresh "z" in set (z:=t a) in *; clearbody z. + +Ltac zify_unop_var_or_term t thm a := + (* If a is a variable, no need for aliasing *) + let za := fresh "z" in + (rename a into za; rename za into a; zify_unop_core t thm a) || + (* Otherwise, a is a complex term: we alias it. *) + (remember a as za; zify_unop_core t thm za). + +Ltac zify_unop t thm a := + (* if a is a scalar, we can simply reduce the unop *) + let isz := isZcst a in + match isz with + | true => simpl (t a) in * + | _ => zify_unop_var_or_term t thm a + end. + +Ltac zify_unop_nored t thm a := + (* in this version, we don't try to reduce the unop (that can be (Zplus x)) *) + let isz := isZcst a in + match isz with + | true => zify_unop_core t thm a + | _ => zify_unop_var_or_term t thm a + end. + +Ltac zify_binop t thm a b:= + (* works as zify_unop, except that we should be careful when + dealing with b, since it can be equal to a *) + let isza := isZcst a in + match isza with + | true => zify_unop (t a) (thm a) b + | _ => + let za := fresh "z" in + (rename a into za; rename za into a; zify_unop_nored (t a) (thm a) b) || + (remember a as za; match goal with + | H : za = b |- _ => zify_unop_nored (t za) (thm za) za + | _ => zify_unop_nored (t za) (thm za) b + end) + end. + +Ltac zify_op_1 := + match goal with + | |- context [ Zmax ?a ?b ] => zify_binop Zmax Zmax_spec a b + | H : context [ Zmax ?a ?b ] |- _ => zify_binop Zmax Zmax_spec a b + | |- context [ Zmin ?a ?b ] => zify_binop Zmin Zmin_spec a b + | H : context [ Zmin ?a ?b ] |- _ => zify_binop Zmin Zmin_spec a b + | |- context [ Zsgn ?a ] => zify_unop Zsgn Zsgn_spec a + | H : context [ Zsgn ?a ] |- _ => zify_unop Zsgn Zsgn_spec a + | |- context [ Zabs ?a ] => zify_unop Zabs Zabs_spec a + | H : context [ Zabs ?a ] |- _ => zify_unop Zabs Zabs_spec a + end. + +Ltac zify_op := repeat zify_op_1. + + + + + +(** II) Conversion from nat to Z *) + + +Definition Z_of_nat' := Z_of_nat. + +Ltac hide_Z_of_nat t := + let z := fresh "z" in set (z:=Z_of_nat t) in *; + change Z_of_nat with Z_of_nat' in z; + unfold z in *; clear z. + +Ltac zify_nat_rel := + match goal with + (* I: equalities *) + | H : (@eq nat ?a ?b) |- _ => generalize (inj_eq _ _ H); clear H; intro H + | |- (@eq nat ?a ?b) => apply (inj_eq_rev a b) + | H : context [ @eq nat ?a ?b ] |- _ => rewrite (inj_eq_iff a b) in H + | |- context [ @eq nat ?a ?b ] => rewrite (inj_eq_iff a b) + (* II: less than *) + | H : (lt ?a ?b) |- _ => generalize (inj_lt _ _ H); clear H; intro H + | |- (lt ?a ?b) => apply (inj_lt_rev a b) + | H : context [ lt ?a ?b ] |- _ => rewrite (inj_lt_iff a b) in H + | |- context [ lt ?a ?b ] => rewrite (inj_lt_iff a b) + (* III: less or equal *) + | H : (le ?a ?b) |- _ => generalize (inj_le _ _ H); clear H; intro H + | |- (le ?a ?b) => apply (inj_le_rev a b) + | H : context [ le ?a ?b ] |- _ => rewrite (inj_le_iff a b) in H + | |- context [ le ?a ?b ] => rewrite (inj_le_iff a b) + (* IV: greater than *) + | H : (gt ?a ?b) |- _ => generalize (inj_gt _ _ H); clear H; intro H + | |- (gt ?a ?b) => apply (inj_gt_rev a b) + | H : context [ gt ?a ?b ] |- _ => rewrite (inj_gt_iff a b) in H + | |- context [ gt ?a ?b ] => rewrite (inj_gt_iff a b) + (* V: greater or equal *) + | H : (ge ?a ?b) |- _ => generalize (inj_ge _ _ H); clear H; intro H + | |- (ge ?a ?b) => apply (inj_ge_rev a b) + | H : context [ ge ?a ?b ] |- _ => rewrite (inj_ge_iff a b) in H + | |- context [ ge ?a ?b ] => rewrite (inj_ge_iff a b) + end. + +Ltac zify_nat_op := + match goal with + (* misc type conversions: positive/N/Z to nat *) + | H : context [ Z_of_nat (nat_of_P ?a) ] |- _ => rewrite <- (Zpos_eq_Z_of_nat_o_nat_of_P a) in H + | |- context [ Z_of_nat (nat_of_P ?a) ] => rewrite <- (Zpos_eq_Z_of_nat_o_nat_of_P a) + | H : context [ Z_of_nat (nat_of_N ?a) ] |- _ => rewrite (Z_of_nat_of_N a) in H + | |- context [ Z_of_nat (nat_of_N ?a) ] => rewrite (Z_of_nat_of_N a) + | H : context [ Z_of_nat (Zabs_nat ?a) ] |- _ => rewrite (inj_Zabs_nat a) in H + | |- context [ Z_of_nat (Zabs_nat ?a) ] => rewrite (inj_Zabs_nat a) + + (* plus -> Zplus *) + | H : context [ Z_of_nat (plus ?a ?b) ] |- _ => rewrite (inj_plus a b) in H + | |- context [ Z_of_nat (plus ?a ?b) ] => rewrite (inj_plus a b) + + (* min -> Zmin *) + | H : context [ Z_of_nat (min ?a ?b) ] |- _ => rewrite (inj_min a b) in H + | |- context [ Z_of_nat (min ?a ?b) ] => rewrite (inj_min a b) + + (* max -> Zmax *) + | H : context [ Z_of_nat (max ?a ?b) ] |- _ => rewrite (inj_max a b) in H + | |- context [ Z_of_nat (max ?a ?b) ] => rewrite (inj_max a b) + + (* minus -> Zmax (Zminus ... ...) 0 *) + | H : context [ Z_of_nat (minus ?a ?b) ] |- _ => rewrite (inj_minus a b) in H + | |- context [ Z_of_nat (minus ?a ?b) ] => rewrite (inj_minus a b) + + (* pred -> minus ... -1 -> Zmax (Zminus ... -1) 0 *) + | H : context [ Z_of_nat (pred ?a) ] |- _ => rewrite (pred_of_minus a) in H + | |- context [ Z_of_nat (pred ?a) ] => rewrite (pred_of_minus a) + + (* mult -> Zmult and a positivity hypothesis *) + | H : context [ Z_of_nat (mult ?a ?b) ] |- _ => + let H:= fresh "H" in + assert (H:=Zle_0_nat (mult a b)); rewrite (inj_mult a b) in * + | |- context [ Z_of_nat (mult ?a ?b) ] => + let H:= fresh "H" in + assert (H:=Zle_0_nat (mult a b)); rewrite (inj_mult a b) in * + + (* O -> Z0 *) + | H : context [ Z_of_nat O ] |- _ => simpl (Z_of_nat O) in H + | |- context [ Z_of_nat O ] => simpl (Z_of_nat O) + + (* S -> number or Zsucc *) + | H : context [ Z_of_nat (S ?a) ] |- _ => + let isnat := isnatcst a in + match isnat with + | true => simpl (Z_of_nat (S a)) in H + | _ => rewrite (inj_S a) in H + end + | |- context [ Z_of_nat (S ?a) ] => + let isnat := isnatcst a in + match isnat with + | true => simpl (Z_of_nat (S a)) + | _ => rewrite (inj_S a) + end + + (* atoms of type nat : we add a positivity condition (if not already there) *) + | H : context [ Z_of_nat ?a ] |- _ => + match goal with + | H' : 0 <= Z_of_nat a |- _ => hide_Z_of_nat a + | H' : 0 <= Z_of_nat' a |- _ => fail + | _ => let H:= fresh "H" in + assert (H:=Zle_0_nat a); hide_Z_of_nat a + end + | |- context [ Z_of_nat ?a ] => + match goal with + | H' : 0 <= Z_of_nat a |- _ => hide_Z_of_nat a + | H' : 0 <= Z_of_nat' a |- _ => fail + | _ => let H:= fresh "H" in + assert (H:=Zle_0_nat a); hide_Z_of_nat a + end + end. + +Ltac zify_nat := repeat zify_nat_rel; repeat zify_nat_op; unfold Z_of_nat' in *. + + + + +(* III) conversion from positive to Z *) + +Definition Zpos' := Zpos. +Definition Zneg' := Zneg. + +Ltac hide_Zpos t := + let z := fresh "z" in set (z:=Zpos t) in *; + change Zpos with Zpos' in z; + unfold z in *; clear z. + +Ltac zify_positive_rel := + match goal with + (* I: equalities *) + | H : (@eq positive ?a ?b) |- _ => generalize (Zpos_eq _ _ H); clear H; intro H + | |- (@eq positive ?a ?b) => apply (Zpos_eq_rev a b) + | H : context [ @eq positive ?a ?b ] |- _ => rewrite (Zpos_eq_iff a b) in H + | |- context [ @eq positive ?a ?b ] => rewrite (Zpos_eq_iff a b) + (* II: less than *) + | H : context [ (?a<?b)%positive ] |- _ => change (a<b)%positive with (Zpos a<Zpos b) in H + | |- context [ (?a<?b)%positive ] => change (a<b)%positive with (Zpos a<Zpos b) + (* III: less or equal *) + | H : context [ (?a<=?b)%positive ] |- _ => change (a<=b)%positive with (Zpos a<=Zpos b) in H + | |- context [ (?a<=?b)%positive ] => change (a<=b)%positive with (Zpos a<=Zpos b) + (* IV: greater than *) + | H : context [ (?a>?b)%positive ] |- _ => change (a>b)%positive with (Zpos a>Zpos b) in H + | |- context [ (?a>?b)%positive ] => change (a>b)%positive with (Zpos a>Zpos b) + (* V: greater or equal *) + | H : context [ (?a>=?b)%positive ] |- _ => change (a>=b)%positive with (Zpos a>=Zpos b) in H + | |- context [ (?a>=?b)%positive ] => change (a>=b)%positive with (Zpos a>=Zpos b) + end. + +Ltac zify_positive_op := + match goal with + (* Zneg -> -Zpos (except for numbers) *) + | H : context [ Zneg ?a ] |- _ => + let isp := isPcst a in + match isp with + | true => change (Zneg a) with (Zneg' a) in H + | _ => change (Zneg a) with (- Zpos a) in H + end + | |- context [ Zneg ?a ] => + let isp := isPcst a in + match isp with + | true => change (Zneg a) with (Zneg' a) + | _ => change (Zneg a) with (- Zpos a) + end + + (* misc type conversions: nat to positive *) + | H : context [ Zpos (P_of_succ_nat ?a) ] |- _ => rewrite (Zpos_P_of_succ_nat a) in H + | |- context [ Zpos (P_of_succ_nat ?a) ] => rewrite (Zpos_P_of_succ_nat a) + + (* Pplus -> Zplus *) + | H : context [ Zpos (Pplus ?a ?b) ] |- _ => change (Zpos (Pplus a b)) with (Zplus (Zpos a) (Zpos b)) in H + | |- context [ Zpos (Pplus ?a ?b) ] => change (Zpos (Pplus a b)) with (Zplus (Zpos a) (Zpos b)) + + (* Pmin -> Zmin *) + | H : context [ Zpos (Pmin ?a ?b) ] |- _ => rewrite (Zpos_min a b) in H + | |- context [ Zpos (Pmin ?a ?b) ] => rewrite (Zpos_min a b) + + (* Pmax -> Zmax *) + | H : context [ Zpos (Pmax ?a ?b) ] |- _ => rewrite (Zpos_max a b) in H + | |- context [ Zpos (Pmax ?a ?b) ] => rewrite (Zpos_max a b) + + (* Pminus -> Zmax 1 (Zminus ... ...) *) + | H : context [ Zpos (Pminus ?a ?b) ] |- _ => rewrite (Zpos_minus a b) in H + | |- context [ Zpos (Pminus ?a ?b) ] => rewrite (Zpos_minus a b) + + (* Psucc -> Zsucc *) + | H : context [ Zpos (Psucc ?a) ] |- _ => rewrite (Zpos_succ_morphism a) in H + | |- context [ Zpos (Psucc ?a) ] => rewrite (Zpos_succ_morphism a) + + (* Ppred -> Pminus ... -1 -> Zmax 1 (Zminus ... - 1) *) + | H : context [ Zpos (Ppred ?a) ] |- _ => rewrite (Ppred_minus a) in H + | |- context [ Zpos (Ppred ?a) ] => rewrite (Ppred_minus a) + + (* Pmult -> Zmult and a positivity hypothesis *) + | H : context [ Zpos (Pmult ?a ?b) ] |- _ => + let H:= fresh "H" in + assert (H:=Zgt_pos_0 (Pmult a b)); rewrite (Zpos_mult_morphism a b) in * + | |- context [ Zpos (Pmult ?a ?b) ] => + let H:= fresh "H" in + assert (H:=Zgt_pos_0 (Pmult a b)); rewrite (Zpos_mult_morphism a b) in * + + (* xO *) + | H : context [ Zpos (xO ?a) ] |- _ => + let isp := isPcst a in + match isp with + | true => change (Zpos (xO a)) with (Zpos' (xO a)) in H + | _ => rewrite (Zpos_xO a) in H + end + | |- context [ Zpos (xO ?a) ] => + let isp := isPcst a in + match isp with + | true => change (Zpos (xO a)) with (Zpos' (xO a)) + | _ => rewrite (Zpos_xO a) + end + (* xI *) + | H : context [ Zpos (xI ?a) ] |- _ => + let isp := isPcst a in + match isp with + | true => change (Zpos (xI a)) with (Zpos' (xI a)) in H + | _ => rewrite (Zpos_xI a) in H + end + | |- context [ Zpos (xI ?a) ] => + let isp := isPcst a in + match isp with + | true => change (Zpos (xI a)) with (Zpos' (xI a)) + | _ => rewrite (Zpos_xI a) + end + + (* xI : nothing to do, just prevent adding a useless positivity condition *) + | H : context [ Zpos xH ] |- _ => hide_Zpos xH + | |- context [ Zpos xH ] => hide_Zpos xH + + (* atoms of type positive : we add a positivity condition (if not already there) *) + | H : context [ Zpos ?a ] |- _ => + match goal with + | H' : Zpos a > 0 |- _ => hide_Zpos a + | H' : Zpos' a > 0 |- _ => fail + | _ => let H:= fresh "H" in assert (H:=Zgt_pos_0 a); hide_Zpos a + end + | |- context [ Zpos ?a ] => + match goal with + | H' : Zpos a > 0 |- _ => hide_Zpos a + | H' : Zpos' a > 0 |- _ => fail + | _ => let H:= fresh "H" in assert (H:=Zgt_pos_0 a); hide_Zpos a + end + end. + +Ltac zify_positive := + repeat zify_positive_rel; repeat zify_positive_op; unfold Zpos',Zneg' in *. + + + + + +(* IV) conversion from N to Z *) + +Definition Z_of_N' := Z_of_N. + +Ltac hide_Z_of_N t := + let z := fresh "z" in set (z:=Z_of_N t) in *; + change Z_of_N with Z_of_N' in z; + unfold z in *; clear z. + +Ltac zify_N_rel := + match goal with + (* I: equalities *) + | H : (@eq N ?a ?b) |- _ => generalize (Z_of_N_eq _ _ H); clear H; intro H + | |- (@eq N ?a ?b) => apply (Z_of_N_eq_rev a b) + | H : context [ @eq N ?a ?b ] |- _ => rewrite (Z_of_N_eq_iff a b) in H + | |- context [ @eq N ?a ?b ] => rewrite (Z_of_N_eq_iff a b) + (* II: less than *) + | H : (?a<?b)%N |- _ => generalize (Z_of_N_lt _ _ H); clear H; intro H + | |- (?a<?b)%N => apply (Z_of_N_lt_rev a b) + | H : context [ (?a<?b)%N ] |- _ => rewrite (Z_of_N_lt_iff a b) in H + | |- context [ (?a<?b)%N ] => rewrite (Z_of_N_lt_iff a b) + (* III: less or equal *) + | H : (?a<=?b)%N |- _ => generalize (Z_of_N_le _ _ H); clear H; intro H + | |- (?a<=?b)%N => apply (Z_of_N_le_rev a b) + | H : context [ (?a<=?b)%N ] |- _ => rewrite (Z_of_N_le_iff a b) in H + | |- context [ (?a<=?b)%N ] => rewrite (Z_of_N_le_iff a b) + (* IV: greater than *) + | H : (?a>?b)%N |- _ => generalize (Z_of_N_gt _ _ H); clear H; intro H + | |- (?a>?b)%N => apply (Z_of_N_gt_rev a b) + | H : context [ (?a>?b)%N ] |- _ => rewrite (Z_of_N_gt_iff a b) in H + | |- context [ (?a>?b)%N ] => rewrite (Z_of_N_gt_iff a b) + (* V: greater or equal *) + | H : (?a>=?b)%N |- _ => generalize (Z_of_N_ge _ _ H); clear H; intro H + | |- (?a>=?b)%N => apply (Z_of_N_ge_rev a b) + | H : context [ (?a>=?b)%N ] |- _ => rewrite (Z_of_N_ge_iff a b) in H + | |- context [ (?a>=?b)%N ] => rewrite (Z_of_N_ge_iff a b) + end. + +Ltac zify_N_op := + match goal with + (* misc type conversions: nat to positive *) + | H : context [ Z_of_N (N_of_nat ?a) ] |- _ => rewrite (Z_of_N_of_nat a) in H + | |- context [ Z_of_N (N_of_nat ?a) ] => rewrite (Z_of_N_of_nat a) + | H : context [ Z_of_N (Zabs_N ?a) ] |- _ => rewrite (Z_of_N_abs a) in H + | |- context [ Z_of_N (Zabs_N ?a) ] => rewrite (Z_of_N_abs a) + | H : context [ Z_of_N (Npos ?a) ] |- _ => rewrite (Z_of_N_pos a) in H + | |- context [ Z_of_N (Npos ?a) ] => rewrite (Z_of_N_pos a) + | H : context [ Z_of_N N0 ] |- _ => change (Z_of_N N0) with Z0 in H + | |- context [ Z_of_N N0 ] => change (Z_of_N N0) with Z0 + + (* Nplus -> Zplus *) + | H : context [ Z_of_N (Nplus ?a ?b) ] |- _ => rewrite (Z_of_N_plus a b) in H + | |- context [ Z_of_N (Nplus ?a ?b) ] => rewrite (Z_of_N_plus a b) + + (* Nmin -> Zmin *) + | H : context [ Z_of_N (Nmin ?a ?b) ] |- _ => rewrite (Z_of_N_min a b) in H + | |- context [ Z_of_N (Nmin ?a ?b) ] => rewrite (Z_of_N_min a b) + + (* Nmax -> Zmax *) + | H : context [ Z_of_N (Nmax ?a ?b) ] |- _ => rewrite (Z_of_N_max a b) in H + | |- context [ Z_of_N (Nmax ?a ?b) ] => rewrite (Z_of_N_max a b) + + (* Nminus -> Zmax 0 (Zminus ... ...) *) + | H : context [ Z_of_N (Nminus ?a ?b) ] |- _ => rewrite (Z_of_N_minus a b) in H + | |- context [ Z_of_N (Nminus ?a ?b) ] => rewrite (Z_of_N_minus a b) + + (* Nsucc -> Zsucc *) + | H : context [ Z_of_N (Nsucc ?a) ] |- _ => rewrite (Z_of_N_succ a) in H + | |- context [ Z_of_N (Nsucc ?a) ] => rewrite (Z_of_N_succ a) + + (* Nmult -> Zmult and a positivity hypothesis *) + | H : context [ Z_of_N (Nmult ?a ?b) ] |- _ => + let H:= fresh "H" in + assert (H:=Z_of_N_le_0 (Nmult a b)); rewrite (Z_of_N_mult a b) in * + | |- context [ Z_of_N (Nmult ?a ?b) ] => + let H:= fresh "H" in + assert (H:=Z_of_N_le_0 (Nmult a b)); rewrite (Z_of_N_mult a b) in * + + (* atoms of type N : we add a positivity condition (if not already there) *) + | H : context [ Z_of_N ?a ] |- _ => + match goal with + | H' : 0 <= Z_of_N a |- _ => hide_Z_of_N a + | H' : 0 <= Z_of_N' a |- _ => fail + | _ => let H:= fresh "H" in assert (H:=Z_of_N_le_0 a); hide_Z_of_N a + end + | |- context [ Z_of_N ?a ] => + match goal with + | H' : 0 <= Z_of_N a |- _ => hide_Z_of_N a + | H' : 0 <= Z_of_N' a |- _ => fail + | _ => let H:= fresh "H" in assert (H:=Z_of_N_le_0 a); hide_Z_of_N a + end + end. + +Ltac zify_N := repeat zify_N_rel; repeat zify_N_op; unfold Z_of_N' in *. + + + +(** The complete Z-ification tactic *) + +Ltac zify := + repeat progress (zify_nat; zify_positive; zify_N); zify_op. + diff --git a/contrib/omega/coq_omega.ml b/contrib/omega/coq_omega.ml index be9ea5ae..84092812 100644 --- a/contrib/omega/coq_omega.ml +++ b/contrib/omega/coq_omega.ml @@ -13,7 +13,7 @@ (* *) (**************************************************************************) -(* $Id: coq_omega.ml 9963 2007-07-09 14:02:20Z letouzey $ *) +(* $Id: coq_omega.ml 11094 2008-06-10 19:35:23Z herbelin $ *) open Util open Pp @@ -128,12 +128,12 @@ let intern_id,unintern_id = let mk_then = tclTHENLIST -let exists_tac c = constructor_tac (Some 1) 1 (Rawterm.ImplicitBindings [c]) +let exists_tac c = constructor_tac false (Some 1) 1 (Rawterm.ImplicitBindings [c]) let generalize_tac t = generalize_time (generalize t) let elim t = elim_time (simplest_elim t) let exact t = exact_time (Tactics.refine t) -let unfold s = Tactics.unfold_in_concl [[], Lazy.force s] +let unfold s = Tactics.unfold_in_concl [all_occurrences, Lazy.force s] let rev_assoc k = let rec loop = function @@ -180,8 +180,6 @@ let coq_Zneg = lazy (constant "Zneg") let coq_Z = lazy (constant "Z") let coq_comparison = lazy (constant "comparison") let coq_Gt = lazy (constant "Gt") -let coq_INFEEIEUR = lazy (constant "Lt") -let coq_Eq = lazy (constant "Eq") let coq_Zplus = lazy (constant "Zplus") let coq_Zmult = lazy (constant "Zmult") let coq_Zopp = lazy (constant "Zopp") @@ -1227,7 +1225,7 @@ let replay_history tactic_normalisation = (clear [aux]); (intros_using [id]); (loop l) ]; - tclTHEN (exists_tac eq1) reflexivity ] + tclTHEN (exists_tac (inj_open eq1)) reflexivity ] | SPLIT_INEQ(e,(e1,act1),(e2,act2)) :: l -> let id1 = new_identifier () and id2 = new_identifier () in diff --git a/contrib/omega/g_omega.ml4 b/contrib/omega/g_omega.ml4 index 01592ebe..02545b30 100644 --- a/contrib/omega/g_omega.ml4 +++ b/contrib/omega/g_omega.ml4 @@ -15,10 +15,33 @@ (*i camlp4deps: "parsing/grammar.cma" i*) -(* $Id: g_omega.ml4 7734 2005-12-26 14:06:51Z herbelin $ *) +(* $Id: g_omega.ml4 10028 2007-07-18 22:38:06Z letouzey $ *) open Coq_omega +open Refiner + +let omega_tactic l = + let tacs = List.map + (function + | "nat" -> Tacinterp.interp <:tactic<zify_nat>> + | "positive" -> Tacinterp.interp <:tactic<zify_positive>> + | "N" -> Tacinterp.interp <:tactic<zify_N>> + | "Z" -> Tacinterp.interp <:tactic<zify_op>> + | s -> Util.error ("No Omega knowledge base for type "^s)) + (Util.list_uniquize (List.sort compare l)) + in + tclTHEN + (tclREPEAT (tclPROGRESS (tclTHENLIST tacs))) + omega_solver + TACTIC EXTEND omega - [ "omega" ] -> [ omega_solver ] +| [ "omega" ] -> [ omega_tactic [] ] END + +TACTIC EXTEND omega' +| [ "omega" "with" ne_ident_list(l) ] -> + [ omega_tactic (List.map Names.string_of_id l) ] +| [ "omega" "with" "*" ] -> [ omega_tactic ["nat";"positive";"N";"Z"] ] +END + diff --git a/contrib/ring/LegacyRing.v b/contrib/ring/LegacyRing.v index dc8635bd..40323b3d 100644 --- a/contrib/ring/LegacyRing.v +++ b/contrib/ring/LegacyRing.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: Ring.v 5920 2004-07-16 20:01:26Z herbelin $ *) +(* $Id: LegacyRing.v 10739 2008-04-01 14:45:20Z herbelin $ *) Require Export Bool. Require Export LegacyRing_theory. diff --git a/contrib/ring/LegacyRing_theory.v b/contrib/ring/LegacyRing_theory.v index 5df927a6..d15d18a6 100644 --- a/contrib/ring/LegacyRing_theory.v +++ b/contrib/ring/LegacyRing_theory.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: LegacyRing_theory.v 9179 2006-09-26 12:13:06Z barras $ *) +(* $Id: LegacyRing_theory.v 9370 2006-11-13 09:21:31Z herbelin $ *) Require Export Bool. @@ -153,7 +153,7 @@ Notation "- x" := (Aopp x). Record Ring_Theory : Prop := {Th_plus_comm : forall n m:A, n + m = m + n; Th_plus_assoc : forall n m p:A, n + (m + p) = n + m + p; - Th_mult_sym : forall n m:A, n * m = m * n; + Th_mult_comm : forall n m:A, n * m = m * n; Th_mult_assoc : forall n m p:A, n * (m * p) = n * m * p; Th_plus_zero_left : forall n:A, 0 + n = n; Th_mult_one_left : forall n:A, 1 * n = n; @@ -165,7 +165,7 @@ Variable T : Ring_Theory. Let plus_comm := Th_plus_comm T. Let plus_assoc := Th_plus_assoc T. -Let mult_comm := Th_mult_sym T. +Let mult_comm := Th_mult_comm T. Let mult_assoc := Th_mult_assoc T. Let plus_zero_left := Th_plus_zero_left T. Let mult_one_left := Th_mult_one_left T. diff --git a/contrib/ring/Ring_abstract.v b/contrib/ring/Ring_abstract.v index 115ed5ca..c2467ebf 100644 --- a/contrib/ring/Ring_abstract.v +++ b/contrib/ring/Ring_abstract.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: Ring_abstract.v 9179 2006-09-26 12:13:06Z barras $ *) +(* $Id: Ring_abstract.v 9370 2006-11-13 09:21:31Z herbelin $ *) Require Import LegacyRing_theory. Require Import Quote. @@ -428,7 +428,7 @@ Fixpoint interp_ap (p:apolynomial) : A := Hint Resolve (Th_plus_comm T). Hint Resolve (Th_plus_assoc T). Hint Resolve (Th_plus_assoc2 T). -Hint Resolve (Th_mult_sym T). +Hint Resolve (Th_mult_comm T). Hint Resolve (Th_mult_assoc T). Hint Resolve (Th_mult_assoc2 T). Hint Resolve (Th_plus_zero_left T). diff --git a/contrib/ring/Ring_normalize.v b/contrib/ring/Ring_normalize.v index 4a082396..e8d9f1ee 100644 --- a/contrib/ring/Ring_normalize.v +++ b/contrib/ring/Ring_normalize.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: Ring_normalize.v 9179 2006-09-26 12:13:06Z barras $ *) +(* $Id: Ring_normalize.v 10913 2008-05-09 14:40:04Z herbelin $ *) Require Import LegacyRing_theory. Require Import Quote. @@ -774,7 +774,7 @@ Variable T : Ring_Theory Aplus Amult Aone Azero Aopp Aeq. Hint Resolve (Th_plus_comm T). Hint Resolve (Th_plus_assoc T). Hint Resolve (Th_plus_assoc2 T). -Hint Resolve (Th_mult_sym T). +Hint Resolve (Th_mult_comm T). Hint Resolve (Th_mult_assoc T). Hint Resolve (Th_mult_assoc2 T). Hint Resolve (Th_plus_zero_left T). @@ -897,6 +897,6 @@ End rings. Infix "+" := Pplus : ring_scope. Infix "*" := Pmult : ring_scope. Notation "- x" := (Popp x) : ring_scope. -Notation "[ x ]" := (Pvar x) (at level 1) : ring_scope. +Notation "[ x ]" := (Pvar x) (at level 0) : ring_scope. Delimit Scope ring_scope with ring. diff --git a/contrib/ring/Setoid_ring_normalize.v b/contrib/ring/Setoid_ring_normalize.v index 56329ade..8eb49a37 100644 --- a/contrib/ring/Setoid_ring_normalize.v +++ b/contrib/ring/Setoid_ring_normalize.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: Setoid_ring_normalize.v 6662 2005-02-02 21:33:14Z sacerdot $ *) +(* $Id: Setoid_ring_normalize.v 9370 2006-11-13 09:21:31Z herbelin $ *) Require Import Setoid_ring_theory. Require Import Quote. @@ -1032,7 +1032,7 @@ Variable T : Setoid_Ring_Theory Aequiv Aplus Amult Aone Azero Aopp Aeq. Hint Resolve (STh_plus_comm T). Hint Resolve (STh_plus_assoc T). Hint Resolve (STh_plus_assoc2 S T). -Hint Resolve (STh_mult_sym T). +Hint Resolve (STh_mult_comm T). Hint Resolve (STh_mult_assoc T). Hint Resolve (STh_mult_assoc2 S T). Hint Resolve (STh_plus_zero_left T). diff --git a/contrib/ring/Setoid_ring_theory.v b/contrib/ring/Setoid_ring_theory.v index ae6610d3..88abd7de 100644 --- a/contrib/ring/Setoid_ring_theory.v +++ b/contrib/ring/Setoid_ring_theory.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: Setoid_ring_theory.v 6662 2005-02-02 21:33:14Z sacerdot $ *) +(* $Id: Setoid_ring_theory.v 10631 2008-03-06 18:17:24Z msozeau $ *) Require Export Bool. Require Export Setoid. @@ -177,7 +177,7 @@ Section Theory_of_setoid_rings. Record Setoid_Ring_Theory : Prop := {STh_plus_comm : forall n m:A, n + m == m + n; STh_plus_assoc : forall n m p:A, n + (m + p) == n + m + p; - STh_mult_sym : forall n m:A, n * m == m * n; + STh_mult_comm : forall n m:A, n * m == m * n; STh_mult_assoc : forall n m p:A, n * (m * p) == n * m * p; STh_plus_zero_left : forall n:A, 0 + n == n; STh_mult_one_left : forall n:A, 1 * n == n; @@ -189,7 +189,7 @@ Variable T : Setoid_Ring_Theory. Let plus_comm := STh_plus_comm T. Let plus_assoc := STh_plus_assoc T. -Let mult_comm := STh_mult_sym T. +Let mult_comm := STh_mult_comm T. Let mult_assoc := STh_mult_assoc T. Let plus_zero_left := STh_plus_zero_left T. Let mult_one_left := STh_mult_one_left T. @@ -245,7 +245,7 @@ Lemma Saux1 : forall a:A, a + a == a -> a == 0. intros. rewrite <- (plus_zero_left a). rewrite (plus_comm 0 a). -setoid_replace (a + 0) with (a + (a + - a)); auto. +setoid_replace (a + 0) with (a + (a + - a)) by auto. rewrite (plus_assoc a a (- a)). rewrite H. apply opp_def. diff --git a/contrib/ring/quote.ml b/contrib/ring/quote.ml index e0a6cba3..7cd22a36 100644 --- a/contrib/ring/quote.ml +++ b/contrib/ring/quote.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: quote.ml 9178 2006-09-26 11:18:22Z barras $ *) +(* $Id: quote.ml 10790 2008-04-14 22:34:19Z herbelin $ *) (* The `Quote' tactic *) @@ -191,8 +191,11 @@ let decomp_term c = kind_of_term (strip_outer_cast c) ?2 ?1)}, where \texttt{C} is the [i]-th constructor of inductive type [typ] *) -let coerce_meta_out id = int_of_string (string_of_id id) -let coerce_meta_in n = id_of_string (string_of_int n) +let coerce_meta_out id = + let s = string_of_id id in + int_of_string (String.sub s 1 (String.length s - 1)) +let coerce_meta_in n = + id_of_string ("M" ^ string_of_int n) let compute_lhs typ i nargsi = match kind_of_term typ with diff --git a/contrib/ring/ring.ml b/contrib/ring/ring.ml index 6b82b75b..3d13a254 100644 --- a/contrib/ring/ring.ml +++ b/contrib/ring/ring.ml @@ -6,13 +6,13 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: ring.ml 9179 2006-09-26 12:13:06Z barras $ *) +(* $Id: ring.ml 11094 2008-06-10 19:35:23Z herbelin $ *) (* ML part of the Ring tactic *) open Pp open Util -open Options +open Flags open Term open Names open Libnames @@ -193,7 +193,7 @@ let _ = let subst_morph subst morph = let plusm' = subst_mps subst morph.plusm in let multm' = subst_mps subst morph.multm in - let oppm' = option_smartmap (subst_mps subst) morph.oppm in + let oppm' = Option.smartmap (subst_mps subst) morph.oppm in if plusm' == morph.plusm && multm' == morph.multm && oppm' == morph.oppm then @@ -215,15 +215,15 @@ let subst_set subst cset = if !same then cset else cset' let subst_theory subst th = - let th_equiv' = option_smartmap (subst_mps subst) th.th_equiv in - let th_setoid_th' = option_smartmap (subst_mps subst) th.th_setoid_th in - let th_morph' = option_smartmap (subst_morph subst) th.th_morph in + let th_equiv' = Option.smartmap (subst_mps subst) th.th_equiv in + let th_setoid_th' = Option.smartmap (subst_mps subst) th.th_setoid_th in + let th_morph' = Option.smartmap (subst_morph subst) th.th_morph in let th_a' = subst_mps subst th.th_a in let th_plus' = subst_mps subst th.th_plus in let th_mult' = subst_mps subst th.th_mult in let th_one' = subst_mps subst th.th_one in let th_zero' = subst_mps subst th.th_zero in - let th_opp' = option_smartmap (subst_mps subst) th.th_opp in + let th_opp' = Option.smartmap (subst_mps subst) th.th_opp in let th_eq' = subst_mps subst th.th_eq in let th_t' = subst_mps subst th.th_t in let th_closed' = subst_set subst th.th_closed in @@ -826,9 +826,11 @@ let raw_polynom th op lc gl = c'''i; ci; c'i_eq_c''i |])))) (tclTHENS (tclORELSE - (Setoid_replace.general_s_rewrite true c'i_eq_c''i + (Setoid_replace.general_s_rewrite true + Termops.all_occurrences c'i_eq_c''i ~new_goals:[]) - (Setoid_replace.general_s_rewrite false c'i_eq_c''i + (Setoid_replace.general_s_rewrite false + Termops.all_occurrences c'i_eq_c''i ~new_goals:[])) [tac])) else diff --git a/contrib/romega/ROmega.v b/contrib/romega/ROmega.v index 19933873..68bc43bb 100644 --- a/contrib/romega/ROmega.v +++ b/contrib/romega/ROmega.v @@ -1,10 +1,11 @@ (************************************************************************* PROJET RNRT Calife - 2001 - Author: Pierre Crégut - France Télécom R&D + Author: Pierre Crégut - France Télécom R&D Licence : LGPL version 2.1 *************************************************************************) Require Import ReflOmegaCore. - +Require Export Setoid. +Require Export PreOmega. diff --git a/contrib/romega/ReflOmegaCore.v b/contrib/romega/ReflOmegaCore.v index d20cafc1..9d379548 100644 --- a/contrib/romega/ReflOmegaCore.v +++ b/contrib/romega/ReflOmegaCore.v @@ -7,32 +7,852 @@ *************************************************************************) -Require Import Arith. -Require Import List. -Require Import Bool. -Require Import ZArith_base. -Require Import OmegaLemmas. - -Open Scope Z_scope. - -(* \subsection{Definition of basic types} *) - -(* \subsubsection{Environment of propositions (lists) *) -Inductive PropList : Type := - | Pnil : PropList - | Pcons : Prop -> PropList -> PropList. - -(* Access function for the environment with a default *) -Fixpoint nthProp (n : nat) (l : PropList) (default : Prop) {struct l} : - Prop := - match n, l with - | O, Pcons x l' => x - | O, other => default - | S m, Pnil => default - | S m, Pcons x t => nthProp m t default - end. +Require Import List Bool Sumbool EqNat Setoid Ring_theory Decidable. +Delimit Scope Int_scope with I. + +(* Abstract Integers. *) + +Module Type Int. + + Parameter int : Set. + + Parameter zero : int. + Parameter one : int. + Parameter plus : int -> int -> int. + Parameter opp : int -> int. + Parameter minus : int -> int -> int. + Parameter mult : int -> int -> int. + + Notation "0" := zero : Int_scope. + Notation "1" := one : Int_scope. + Infix "+" := plus : Int_scope. + Infix "-" := minus : Int_scope. + Infix "*" := mult : Int_scope. + Notation "- x" := (opp x) : Int_scope. + + Open Scope Int_scope. + + (* First, int is a ring: *) + Axiom ring : @ring_theory int 0 1 plus mult minus opp (@eq int). + + (* int should also be ordered: *) + + Parameter le : int -> int -> Prop. + Parameter lt : int -> int -> Prop. + Parameter ge : int -> int -> Prop. + Parameter gt : int -> int -> Prop. + Notation "x <= y" := (le x y): Int_scope. + Notation "x < y" := (lt x y) : Int_scope. + Notation "x >= y" := (ge x y) : Int_scope. + Notation "x > y" := (gt x y): Int_scope. + Axiom le_lt_iff : forall i j, (i<=j) <-> ~(j<i). + Axiom ge_le_iff : forall i j, (i>=j) <-> (j<=i). + Axiom gt_lt_iff : forall i j, (i>j) <-> (j<i). + + (* Basic properties of this order *) + Axiom lt_trans : forall i j k, i<j -> j<k -> i<k. + Axiom lt_not_eq : forall i j, i<j -> i<>j. + + (* Compatibilities *) + Axiom lt_0_1 : 0<1. + Axiom plus_le_compat : forall i j k l, i<=j -> k<=l -> i+k<=j+l. + Axiom opp_le_compat : forall i j, i<=j -> (-j)<=(-i). + Axiom mult_lt_compat_l : + forall i j k, 0 < k -> i < j -> k*i<k*j. + + (* We should have a way to decide the equality and the order*) + Parameter compare : int -> int -> comparison. + Infix "?=" := compare (at level 70, no associativity) : Int_scope. + Axiom compare_Eq : forall i j, compare i j = Eq <-> i=j. + Axiom compare_Lt : forall i j, compare i j = Lt <-> i<j. + Axiom compare_Gt : forall i j, compare i j = Gt <-> i>j. + + (* Up to here, these requirements could be fulfilled + by any totally ordered ring. Let's now be int-specific: *) + Axiom le_lt_int : forall x y, x<y <-> x<=y+-(1). + + (* Btw, lt_0_1 could be deduced from this last axiom *) + +End Int. + + + +(* Of course, Z is a model for our abstract int *) + +Module Z_as_Int <: Int. + + Require Import ZArith_base. + Open Scope Z_scope. + + Definition int := Z. + Definition zero := 0. + Definition one := 1. + Definition plus := Zplus. + Definition opp := Zopp. + Definition minus := Zminus. + Definition mult := Zmult. + + Lemma ring : @ring_theory int zero one plus mult minus opp (@eq int). + Proof. + constructor. + exact Zplus_0_l. + exact Zplus_comm. + exact Zplus_assoc. + exact Zmult_1_l. + exact Zmult_comm. + exact Zmult_assoc. + exact Zmult_plus_distr_l. + unfold minus, Zminus; auto. + exact Zplus_opp_r. + Qed. + + Definition le := Zle. + Definition lt := Zlt. + Definition ge := Zge. + Definition gt := Zgt. + Lemma le_lt_iff : forall i j, (i<=j) <-> ~(j<i). + Proof. + split; intros. + apply Zle_not_lt; auto. + rewrite <- Zge_iff_le. + apply Znot_lt_ge; auto. + Qed. + Definition ge_le_iff := Zge_iff_le. + Definition gt_lt_iff := Zgt_iff_lt. + + Definition lt_trans := Zlt_trans. + Definition lt_not_eq := Zlt_not_eq. + + Definition lt_0_1 := Zlt_0_1. + Definition plus_le_compat := Zplus_le_compat. + Definition mult_lt_compat_l := Zmult_lt_compat_l. + Lemma opp_le_compat : forall i j, i<=j -> (-j)<=(-i). + Proof. + unfold Zle; intros; rewrite <- Zcompare_opp; auto. + Qed. + + Definition compare := Zcompare. + Definition compare_Eq := Zcompare_Eq_iff_eq. + Lemma compare_Lt : forall i j, compare i j = Lt <-> i<j. + Proof. intros; unfold compare, Zlt; intuition. Qed. + Lemma compare_Gt : forall i j, compare i j = Gt <-> i>j. + Proof. intros; unfold compare, Zgt; intuition. Qed. + + Lemma le_lt_int : forall x y, x<y <-> x<=y+-(1). + Proof. + intros; split; intros. + generalize (Zlt_left _ _ H); simpl; intros. + apply Zle_left_rev; auto. + apply Zlt_0_minus_lt. + generalize (Zplus_le_lt_compat x (y+-1) (-x) (-x+1) H). + rewrite Zplus_opp_r. + rewrite <-Zplus_assoc. + rewrite (Zplus_permute (-1)). + simpl in *. + rewrite Zplus_0_r. + intro H'; apply H'. + replace (-x+1) with (Zsucc (-x)); auto. + apply Zlt_succ. + Qed. + +End Z_as_Int. + + + + +Module IntProperties (I:Int). + Import I. + + (* Primo, some consequences of being a ring theory... *) + + Definition two := 1+1. + Notation "2" := two : Int_scope. + + (* Aliases for properties packed in the ring record. *) + + Definition plus_assoc := ring.(Radd_assoc). + Definition plus_comm := ring.(Radd_comm). + Definition plus_0_l := ring.(Radd_0_l). + Definition mult_assoc := ring.(Rmul_assoc). + Definition mult_comm := ring.(Rmul_comm). + Definition mult_1_l := ring.(Rmul_1_l). + Definition mult_plus_distr_r := ring.(Rdistr_l). + Definition opp_def := ring.(Ropp_def). + Definition minus_def := ring.(Rsub_def). + + Opaque plus_assoc plus_comm plus_0_l mult_assoc mult_comm mult_1_l + mult_plus_distr_r opp_def minus_def. + + (* More facts about plus *) + + Lemma plus_0_r : forall x, x+0 = x. + Proof. intros; rewrite plus_comm; apply plus_0_l. Qed. + + Lemma plus_0_r_reverse : forall x, x = x+0. + Proof. intros; symmetry; apply plus_0_r. Qed. + + Lemma plus_assoc_reverse : forall x y z, x+y+z = x+(y+z). + Proof. intros; symmetry; apply plus_assoc. Qed. + + Lemma plus_permute : forall x y z, x+(y+z) = y+(x+z). + Proof. intros; do 2 rewrite plus_assoc; f_equal; apply plus_comm. Qed. + + Lemma plus_reg_l : forall x y z, x+y = x+z -> y = z. + Proof. + intros. + rewrite (plus_0_r_reverse y), (plus_0_r_reverse z), <-(opp_def x). + now rewrite plus_permute, plus_assoc, H, <- plus_assoc, plus_permute. + Qed. + + (* More facts about mult *) + + Lemma mult_assoc_reverse : forall x y z, x*y*z = x*(y*z). + Proof. intros; symmetry; apply mult_assoc. Qed. + + Lemma mult_plus_distr_l : forall x y z, x*(y+z)=x*y+x*z. + Proof. + intros. + rewrite (mult_comm x (y+z)), (mult_comm x y), (mult_comm x z). + apply mult_plus_distr_r. + Qed. + + Lemma mult_0_l : forall x, 0*x = 0. + Proof. + intros. + generalize (mult_plus_distr_r 0 1 x). + rewrite plus_0_l, mult_1_l, plus_comm; intros. + apply plus_reg_l with x. + rewrite <- H. + apply plus_0_r_reverse. + Qed. + + + (* More facts about opp *) + + Definition plus_opp_r := opp_def. + + Lemma plus_opp_l : forall x, -x + x = 0. + Proof. intros; now rewrite plus_comm, opp_def. Qed. + + Lemma mult_opp_comm : forall x y, - x * y = x * - y. + Proof. + intros. + apply plus_reg_l with (x*y). + rewrite <- mult_plus_distr_l, <- mult_plus_distr_r. + now rewrite opp_def, opp_def, mult_0_l, mult_comm, mult_0_l. + Qed. + + Lemma opp_eq_mult_neg_1 : forall x, -x = x * -(1). + Proof. + intros; now rewrite mult_comm, mult_opp_comm, mult_1_l. + Qed. + + Lemma opp_involutive : forall x, -(-x) = x. + Proof. + intros. + apply plus_reg_l with (-x). + now rewrite opp_def, plus_comm, opp_def. + Qed. + + Lemma opp_plus_distr : forall x y, -(x+y) = -x + -y. + Proof. + intros. + apply plus_reg_l with (x+y). + rewrite opp_def. + rewrite plus_permute. + do 2 rewrite plus_assoc. + now rewrite (plus_comm (-x)), opp_def, plus_0_l, opp_def. + Qed. + + Lemma opp_mult_distr_r : forall x y, -(x*y) = x * -y. + Proof. + intros. + rewrite <- mult_opp_comm. + apply plus_reg_l with (x*y). + now rewrite opp_def, <-mult_plus_distr_r, opp_def, mult_0_l. + Qed. + + Lemma egal_left : forall n m, n=m -> n+-m = 0. + Proof. intros; subst; apply opp_def. Qed. + + Lemma ne_left_2 : forall x y : int, x<>y -> 0<>(x + - y). + Proof. + intros; contradict H. + apply (plus_reg_l (-y)). + now rewrite plus_opp_l, plus_comm, H. + Qed. + + (* Special lemmas for factorisation. *) + + Lemma red_factor0 : forall n, n = n*1. + Proof. symmetry; rewrite mult_comm; apply mult_1_l. Qed. + + Lemma red_factor1 : forall n, n+n = n*2. + Proof. + intros; unfold two. + now rewrite mult_comm, mult_plus_distr_r, mult_1_l. + Qed. + + Lemma red_factor2 : forall n m, n + n*m = n * (1+m). + Proof. + intros; rewrite mult_plus_distr_l. + f_equal; now rewrite mult_comm, mult_1_l. + Qed. + + Lemma red_factor3 : forall n m, n*m + n = n*(1+m). + Proof. intros; now rewrite plus_comm, red_factor2. Qed. + + Lemma red_factor4 : forall n m p, n*m + n*p = n*(m+p). + Proof. + intros; now rewrite mult_plus_distr_l. + Qed. + + Lemma red_factor5 : forall n m , n * 0 + m = m. + Proof. intros; now rewrite mult_comm, mult_0_l, plus_0_l. Qed. + + Definition red_factor6 := plus_0_r_reverse. + + + (* Specialized distributivities *) + + Hint Rewrite mult_plus_distr_l mult_plus_distr_r mult_assoc : int. + Hint Rewrite <- plus_assoc : int. + + Lemma OMEGA10 : + forall v c1 c2 l1 l2 k1 k2 : int, + (v * c1 + l1) * k1 + (v * c2 + l2) * k2 = + v * (c1 * k1 + c2 * k2) + (l1 * k1 + l2 * k2). + Proof. + intros; autorewrite with int; f_equal; now rewrite plus_permute. + Qed. + + Lemma OMEGA11 : + forall v1 c1 l1 l2 k1 : int, + (v1 * c1 + l1) * k1 + l2 = v1 * (c1 * k1) + (l1 * k1 + l2). + Proof. + intros; now autorewrite with int. + Qed. + + Lemma OMEGA12 : + forall v2 c2 l1 l2 k2 : int, + l1 + (v2 * c2 + l2) * k2 = v2 * (c2 * k2) + (l1 + l2 * k2). + Proof. + intros; autorewrite with int; now rewrite plus_permute. + Qed. + + Lemma OMEGA13 : + forall v l1 l2 x : int, + v * -x + l1 + (v * x + l2) = l1 + l2. + Proof. + intros; autorewrite with int. + rewrite plus_permute; f_equal. + rewrite plus_assoc. + now rewrite <- mult_plus_distr_l, plus_opp_l, mult_comm, mult_0_l, plus_0_l. + Qed. + + Lemma OMEGA15 : + forall v c1 c2 l1 l2 k2 : int, + v * c1 + l1 + (v * c2 + l2) * k2 = v * (c1 + c2 * k2) + (l1 + l2 * k2). + Proof. + intros; autorewrite with int; f_equal; now rewrite plus_permute. + Qed. + + Lemma OMEGA16 : forall v c l k : int, (v * c + l) * k = v * (c * k) + l * k. + Proof. + intros; now autorewrite with int. + Qed. + + Lemma sum1 : forall a b c d : int, 0 = a -> 0 = b -> 0 = a * c + b * d. + Proof. + intros; elim H; elim H0; simpl in |- *; auto. + now rewrite mult_0_l, mult_0_l, plus_0_l. + Qed. + + + (* Secondo, some results about order (and equality) *) + + Lemma lt_irrefl : forall n, ~ n<n. + Proof. + intros n H. + elim (lt_not_eq _ _ H); auto. + Qed. + + Lemma lt_antisym : forall n m, n<m -> m<n -> False. + Proof. + intros; elim (lt_irrefl _ (lt_trans _ _ _ H H0)); auto. + Qed. + + Lemma lt_le_weak : forall n m, n<m -> n<=m. + Proof. + intros; rewrite le_lt_iff; intro H'; eapply lt_antisym; eauto. + Qed. + + Lemma le_refl : forall n, n<=n. + Proof. + intros; rewrite le_lt_iff; apply lt_irrefl; auto. + Qed. + + Lemma le_antisym : forall n m, n<=m -> m<=n -> n=m. + Proof. + intros n m; do 2 rewrite le_lt_iff; intros. + rewrite <- compare_Lt in H0. + rewrite <- gt_lt_iff, <- compare_Gt in H. + rewrite <- compare_Eq. + destruct compare; intuition. + Qed. + + Lemma lt_eq_lt_dec : forall n m, { n<m }+{ n=m }+{ m<n }. + Proof. + intros. + generalize (compare_Lt n m)(compare_Eq n m)(compare_Gt n m). + destruct compare; [ left; right | left; left | right ]; intuition. + rewrite gt_lt_iff in H1; intuition. + Qed. + + Lemma lt_dec : forall n m: int, { n<m } + { ~n<m }. + Proof. + intros. + generalize (compare_Lt n m)(compare_Eq n m)(compare_Gt n m). + destruct compare; [ right | left | right ]; intuition discriminate. + Qed. + + Lemma lt_le_iff : forall n m, (n<m) <-> ~(m<=n). + Proof. + intros. + rewrite le_lt_iff. + destruct (lt_dec n m); intuition. + Qed. + + Lemma le_dec : forall n m: int, { n<=m } + { ~n<=m }. + Proof. + intros; destruct (lt_dec m n); [right|left]; rewrite le_lt_iff; intuition. + Qed. + + Lemma le_lt_dec : forall n m, { n<=m } + { m<n }. + Proof. + intros; destruct (le_dec n m); [left|right]; auto; now rewrite lt_le_iff. + Qed. + + + Definition beq i j := match compare i j with Eq => true | _ => false end. + + Lemma beq_iff : forall i j, beq i j = true <-> i=j. + Proof. + intros; unfold beq; generalize (compare_Eq i j). + destruct compare; intuition discriminate. + Qed. + + Lemma beq_true : forall i j, beq i j = true -> i=j. + Proof. + intros. + rewrite <- beq_iff; auto. + Qed. + + Lemma beq_false : forall i j, beq i j = false -> i<>j. + Proof. + intros. + intro H'. + rewrite <- beq_iff in H'; rewrite H' in H; discriminate. + Qed. + + Lemma eq_dec : forall n m:int, { n=m } + { n<>m }. + Proof. + intros; generalize (beq_iff n m); destruct beq; [left|right]; intuition. + Qed. + + Definition bgt i j := match compare i j with Gt => true | _ => false end. + + Lemma bgt_iff : forall i j, bgt i j = true <-> i>j. + Proof. + intros; unfold bgt; generalize (compare_Gt i j). + destruct compare; intuition discriminate. + Qed. + + Lemma bgt_true : forall i j, bgt i j = true -> i>j. + Proof. intros; now rewrite <- bgt_iff. Qed. + + Lemma bgt_false : forall i j, bgt i j = false -> i<=j. + Proof. + intros. + rewrite le_lt_iff, <-gt_lt_iff, <-bgt_iff; intro H'; now rewrite H' in H. + Qed. + + Lemma le_is_lt_or_eq : forall n m, n<=m -> { n<m } + { n=m }. + Proof. + intros. + destruct (eq_dec n m) as [H'|H']. + right; intuition. + left; rewrite lt_le_iff. + contradict H'. + apply le_antisym; auto. + Qed. + + Lemma le_neq_lt : forall n m, n<=m -> n<>m -> n<m. + Proof. + intros. + destruct (le_is_lt_or_eq _ _ H); intuition. + Qed. + + Lemma le_trans : forall n m p, n<=m -> m<=p -> n<=p. + Proof. + intros n m p; do 3 rewrite le_lt_iff; intros A B C. + destruct (lt_eq_lt_dec p m) as [[H|H]|H]; subst; auto. + generalize (lt_trans _ _ _ H C); intuition. + Qed. + + (* order and operations *) + + Lemma le_0_neg : forall n, 0 <= n <-> -n <= 0. + Proof. + intros. + pattern 0 at 2; rewrite <- (mult_0_l (-(1))). + rewrite <- opp_eq_mult_neg_1. + split; intros. + apply opp_le_compat; auto. + rewrite <-(opp_involutive 0), <-(opp_involutive n). + apply opp_le_compat; auto. + Qed. + + Lemma le_0_neg' : forall n, n <= 0 <-> 0 <= -n. + Proof. + intros; rewrite le_0_neg, opp_involutive; intuition. + Qed. + + Lemma plus_le_reg_r : forall n m p, n + p <= m + p -> n <= m. + Proof. + intros. + replace n with ((n+p)+-p). + replace m with ((m+p)+-p). + apply plus_le_compat; auto. + apply le_refl. + now rewrite <- plus_assoc, opp_def, plus_0_r. + now rewrite <- plus_assoc, opp_def, plus_0_r. + Qed. + + Lemma plus_le_lt_compat : forall n m p q, n<=m -> p<q -> n+p<m+q. + Proof. + intros. + apply le_neq_lt. + apply plus_le_compat; auto. + apply lt_le_weak; auto. + rewrite lt_le_iff in H0. + contradict H0. + apply plus_le_reg_r with m. + rewrite (plus_comm q m), <-H0, (plus_comm p m). + apply plus_le_compat; auto. + apply le_refl; auto. + Qed. + + Lemma plus_lt_compat : forall n m p q, n<m -> p<q -> n+p<m+q. + Proof. + intros. + apply plus_le_lt_compat; auto. + apply lt_le_weak; auto. + Qed. + + Lemma opp_lt_compat : forall n m, n<m -> -m < -n. + Proof. + intros n m; do 2 rewrite lt_le_iff; intros H; contradict H. + rewrite <-(opp_involutive m), <-(opp_involutive n). + apply opp_le_compat; auto. + Qed. + + Lemma lt_0_neg : forall n, 0 < n <-> -n < 0. + Proof. + intros. + pattern 0 at 2; rewrite <- (mult_0_l (-(1))). + rewrite <- opp_eq_mult_neg_1. + split; intros. + apply opp_lt_compat; auto. + rewrite <-(opp_involutive 0), <-(opp_involutive n). + apply opp_lt_compat; auto. + Qed. + + Lemma lt_0_neg' : forall n, n < 0 <-> 0 < -n. + Proof. + intros; rewrite lt_0_neg, opp_involutive; intuition. + Qed. + + Lemma mult_lt_0_compat : forall n m, 0 < n -> 0 < m -> 0 < n*m. + Proof. + intros. + rewrite <- (mult_0_l n), mult_comm. + apply mult_lt_compat_l; auto. + Qed. + + Lemma mult_integral : forall n m, n * m = 0 -> n = 0 \/ m = 0. + Proof. + intros. + destruct (lt_eq_lt_dec n 0) as [[Hn|Hn]|Hn]; auto; + destruct (lt_eq_lt_dec m 0) as [[Hm|Hm]|Hm]; auto; elimtype False. + + rewrite lt_0_neg' in Hn. + rewrite lt_0_neg' in Hm. + generalize (mult_lt_0_compat _ _ Hn Hm). + rewrite <- opp_mult_distr_r, mult_comm, <- opp_mult_distr_r, opp_involutive. + rewrite mult_comm, H. + exact (lt_irrefl 0). + + rewrite lt_0_neg' in Hn. + generalize (mult_lt_0_compat _ _ Hn Hm). + rewrite mult_comm, <- opp_mult_distr_r, mult_comm. + rewrite H. + rewrite opp_eq_mult_neg_1, mult_0_l. + exact (lt_irrefl 0). + + rewrite lt_0_neg' in Hm. + generalize (mult_lt_0_compat _ _ Hn Hm). + rewrite <- opp_mult_distr_r. + rewrite H. + rewrite opp_eq_mult_neg_1, mult_0_l. + exact (lt_irrefl 0). + + generalize (mult_lt_0_compat _ _ Hn Hm). + rewrite H. + exact (lt_irrefl 0). + Qed. + + Lemma mult_le_compat : + forall i j k l, i<=j -> k<=l -> 0<=i -> 0<=k -> i*k<=j*l. + Proof. + intros. + destruct (le_is_lt_or_eq _ _ H1). + + apply le_trans with (i*l). + destruct (le_is_lt_or_eq _ _ H0); [ | subst; apply le_refl]. + apply lt_le_weak. + apply mult_lt_compat_l; auto. + + generalize (le_trans _ _ _ H2 H0); clear H0 H1 H2; intros. + rewrite (mult_comm i), (mult_comm j). + destruct (le_is_lt_or_eq _ _ H0); + [ | subst; do 2 rewrite mult_0_l; apply le_refl]. + destruct (le_is_lt_or_eq _ _ H); + [ | subst; apply le_refl]. + apply lt_le_weak. + apply mult_lt_compat_l; auto. + + subst i. + rewrite mult_0_l. + generalize (le_trans _ _ _ H2 H0); clear H0 H1 H2; intros. + destruct (le_is_lt_or_eq _ _ H); + [ | subst; rewrite mult_0_l; apply le_refl]. + destruct (le_is_lt_or_eq _ _ H0); + [ | subst; rewrite mult_comm, mult_0_l; apply le_refl]. + apply lt_le_weak. + apply mult_lt_0_compat; auto. + Qed. + + Lemma sum5 : + forall a b c d : int, c <> 0 -> 0 <> a -> 0 = b -> 0 <> a * c + b * d. + Proof. + intros. + subst b; rewrite mult_0_l, plus_0_r. + contradict H. + symmetry in H; destruct (mult_integral _ _ H); congruence. + Qed. + + Lemma one_neq_zero : 1 <> 0. + Proof. + red; intro. + symmetry in H. + apply (lt_not_eq 0 1); auto. + apply lt_0_1. + Qed. + + Lemma minus_one_neq_zero : -(1) <> 0. + Proof. + apply lt_not_eq. + rewrite <- lt_0_neg. + apply lt_0_1. + Qed. + + Lemma le_left : forall n m, n <= m -> 0 <= m + - n. + Proof. + intros. + rewrite <- (opp_def m). + apply plus_le_compat. + apply le_refl. + apply opp_le_compat; auto. + Qed. + + Lemma OMEGA2 : forall x y, 0 <= x -> 0 <= y -> 0 <= x + y. + Proof. + intros. + replace 0 with (0+0). + apply plus_le_compat; auto. + rewrite plus_0_l; auto. + Qed. + + Lemma OMEGA8 : forall x y, 0 <= x -> 0 <= y -> x = - y -> x = 0. + Proof. + intros. + assert (y=-x). + subst x; symmetry; apply opp_involutive. + clear H1; subst y. + destruct (eq_dec 0 x) as [H'|H']; auto. + assert (H'':=le_neq_lt _ _ H H'). + generalize (plus_le_lt_compat _ _ _ _ H0 H''). + rewrite plus_opp_l, plus_0_l. + intros. + elim (lt_not_eq _ _ H1); auto. + Qed. + + Lemma sum2 : + forall a b c d : int, 0 <= d -> 0 = a -> 0 <= b -> 0 <= a * c + b * d. + Proof. + intros. + subst a; rewrite mult_0_l, plus_0_l. + rewrite <- (mult_0_l 0). + apply mult_le_compat; auto; apply le_refl. + Qed. + + Lemma sum3 : + forall a b c d : int, + 0 <= c -> 0 <= d -> 0 <= a -> 0 <= b -> 0 <= a * c + b * d. + Proof. + intros. + rewrite <- (plus_0_l 0). + apply plus_le_compat; auto. + rewrite <- (mult_0_l 0). + apply mult_le_compat; auto; apply le_refl. + rewrite <- (mult_0_l 0). + apply mult_le_compat; auto; apply le_refl. + Qed. + + Lemma sum4 : forall k : int, k>0 -> 0 <= k. + Proof. + intros k; rewrite gt_lt_iff; apply lt_le_weak. + Qed. + + (* Lemmas specific to integers (they use lt_le_int) *) + + Lemma lt_left : forall n m, n < m -> 0 <= m + -(1) + - n. + Proof. + intros; apply le_left. + now rewrite <- le_lt_int. + Qed. + + Lemma lt_left_inv : forall x y, 0 <= y + -(1) + - x -> x < y. + Proof. + intros. + generalize (plus_le_compat _ _ _ _ H (le_refl x)); clear H. + now rewrite plus_0_l, <-plus_assoc, plus_opp_l, plus_0_r, le_lt_int. + Qed. + + Lemma OMEGA4 : forall x y z, x > 0 -> y > x -> z * y + x <> 0. + Proof. + intros. + intro H'. + rewrite gt_lt_iff in H,H0. + destruct (lt_eq_lt_dec z 0) as [[G|G]|G]. + + rewrite lt_0_neg' in G. + generalize (plus_le_lt_compat _ _ _ _ (le_refl (z*y)) H0). + rewrite H'. + pattern y at 2; rewrite <-(mult_1_l y), <-mult_plus_distr_r. + intros. + rewrite le_lt_int in G. + rewrite <- opp_plus_distr in G. + assert (0 < y) by (apply lt_trans with x; auto). + generalize (mult_le_compat _ _ _ _ G (lt_le_weak _ _ H2) (le_refl 0) (le_refl 0)). + rewrite mult_0_l, mult_comm, <- opp_mult_distr_r, mult_comm, <-le_0_neg', le_lt_iff. + intuition. + + subst; rewrite mult_0_l, plus_0_l in H'; subst. + apply (lt_not_eq _ _ H); auto. + + apply (lt_not_eq 0 (z*y+x)); auto. + rewrite <- (plus_0_l 0). + apply plus_lt_compat; auto. + apply mult_lt_0_compat; auto. + apply lt_trans with x; auto. + Qed. + + Lemma OMEGA19 : forall x, x<>0 -> 0 <= x + -(1) \/ 0 <= x * -(1) + -(1). + Proof. + intros. + do 2 rewrite <- le_lt_int. + rewrite <- opp_eq_mult_neg_1. + destruct (lt_eq_lt_dec 0 x) as [[H'|H']|H']. + auto. + congruence. + right. + rewrite <-(mult_0_l (-(1))), <-(opp_eq_mult_neg_1 0). + apply opp_lt_compat; auto. + Qed. + + Lemma mult_le_approx : + forall n m p, n > 0 -> n > p -> 0 <= m * n + p -> 0 <= m. + Proof. + intros n m p. + do 2 rewrite gt_lt_iff. + do 2 rewrite le_lt_iff; intros. + contradict H1. + rewrite lt_0_neg' in H1. + rewrite lt_0_neg'. + rewrite opp_plus_distr. + rewrite mult_comm, opp_mult_distr_r. + rewrite le_lt_int. + rewrite <- plus_assoc, (plus_comm (-p)), plus_assoc. + apply lt_left. + rewrite le_lt_int. + rewrite le_lt_int in H0. + apply le_trans with (n+-(1)); auto. + apply plus_le_compat; [ | apply le_refl ]. + rewrite le_lt_int in H1. + generalize (mult_le_compat _ _ _ _ (lt_le_weak _ _ H) H1 (le_refl 0) (le_refl 0)). + rewrite mult_0_l. + rewrite mult_plus_distr_l. + rewrite <- opp_eq_mult_neg_1. + intros. + generalize (plus_le_compat _ _ _ _ (le_refl n) H2). + now rewrite plus_permute, opp_def, plus_0_r, plus_0_r. + Qed. + + (* Some decidabilities *) + + Lemma dec_eq : forall i j:int, decidable (i=j). + Proof. + red; intros; destruct (eq_dec i j); auto. + Qed. + + Lemma dec_ne : forall i j:int, decidable (i<>j). + Proof. + red; intros; destruct (eq_dec i j); auto. + Qed. + + Lemma dec_le : forall i j:int, decidable (i<=j). + Proof. + red; intros; destruct (le_dec i j); auto. + Qed. + + Lemma dec_lt : forall i j:int, decidable (i<j). + Proof. + red; intros; destruct (lt_dec i j); auto. + Qed. + + Lemma dec_ge : forall i j:int, decidable (i>=j). + Proof. + red; intros; rewrite ge_le_iff; destruct (le_dec j i); auto. + Qed. + + Lemma dec_gt : forall i j:int, decidable (i>j). + Proof. + red; intros; rewrite gt_lt_iff; destruct (lt_dec j i); auto. + Qed. + +End IntProperties. + + + + +Module IntOmega (I:Int). +Import I. +Module IP:=IntProperties(I). +Import IP. -(* \subsubsection{Définition of reified integer expressions} +(* \subsubsection{Definition of reified integer expressions} Terms are either: \begin{itemize} \item integers [Tint] @@ -41,7 +861,7 @@ Fixpoint nthProp (n : nat) (l : PropList) (default : Prop) {struct l} : The last two are translated in additions and products. *) Inductive term : Set := - | Tint : Z -> term + | Tint : int -> term | Tplus : term -> term -> term | Tmult : term -> term -> term | Tminus : term -> term -> term @@ -49,6 +869,7 @@ Inductive term : Set := | Tvar : nat -> term. Delimit Scope romega_scope with term. +Arguments Scope Tint [Int_scope]. Arguments Scope Tplus [romega_scope romega_scope]. Arguments Scope Tmult [romega_scope romega_scope]. Arguments Scope Tminus [romega_scope romega_scope]. @@ -58,20 +879,21 @@ Infix "+" := Tplus : romega_scope. Infix "*" := Tmult : romega_scope. Infix "-" := Tminus : romega_scope. Notation "- x" := (Topp x) : romega_scope. -Notation "[ x ]" := (Tvar x) (at level 1) : romega_scope. +Notation "[ x ]" := (Tvar x) (at level 0) : romega_scope. (* \subsubsection{Definition of reified goals} *) + (* Very restricted definition of handled predicates that should be extended to cover a wider set of operations. Taking care of negations and disequations require solving more than a goal in parallel. This is a major improvement over previous versions. *) Inductive proposition : Set := - | EqTerm : term -> term -> proposition (* egalité entre termes *) - | LeqTerm : term -> term -> proposition (* plus petit ou egal *) - | TrueTerm : proposition (* vrai *) - | FalseTerm : proposition (* faux *) - | Tnot : proposition -> proposition (* négation *) + | EqTerm : term -> term -> proposition (* equality between terms *) + | LeqTerm : term -> term -> proposition (* less or equal on terms *) + | TrueTerm : proposition (* true *) + | FalseTerm : proposition (* false *) + | Tnot : proposition -> proposition (* negation *) | GeqTerm : term -> term -> proposition | GtTerm : term -> term -> proposition | LtTerm : term -> term -> proposition @@ -87,7 +909,7 @@ Notation hyps := (list proposition). (* Definition of lists of subgoals (set of open goals) *) Notation lhyps := (list hyps). -(* a syngle goal packed in a subgoal list *) +(* a single goal packed in a subgoal list *) Notation singleton := (fun a : hyps => a :: nil). (* an absurd goal *) @@ -110,24 +932,22 @@ Inductive t_fusion : Set := (* \subsubsection{Rewriting steps to normalize terms} *) Inductive step : Set := - (* apply the rewriting steps to both subterms of an operation *) - | C_DO_BOTH : - step -> step -> step - (* apply the rewriting step to the first branch *) + (* apply the rewriting steps to both subterms of an operation *) + | C_DO_BOTH : step -> step -> step + (* apply the rewriting step to the first branch *) | C_LEFT : step -> step - (* apply the rewriting step to the second branch *) + (* apply the rewriting step to the second branch *) | C_RIGHT : step -> step - (* apply two steps consecutively to a term *) - | C_SEQ : step -> step -> step - (* empty step *) - | C_NOP : step - (* the following operations correspond to actual rewriting *) + (* apply two steps consecutively to a term *) + | C_SEQ : step -> step -> step + (* empty step *) + | C_NOP : step + (* the following operations correspond to actual rewriting *) | C_OPP_PLUS : step | C_OPP_OPP : step | C_OPP_MULT_R : step - | C_OPP_ONE : - step - (* This is a special step that reduces the term (computation) *) + | C_OPP_ONE : step + (* This is a special step that reduces the term (computation) *) | C_REDUCE : step | C_MULT_PLUS_DISTR : step | C_MULT_OPP_LEFT : step @@ -152,261 +972,98 @@ Inductive step : Set := the trace coming from the decision procedure Omega. *) Inductive t_omega : Set := - (* n = 0 n!= 0 *) + (* n = 0 and n!= 0 *) | O_CONSTANT_NOT_NUL : nat -> t_omega - | O_CONSTANT_NEG : - nat -> t_omega - (* division et approximation of an equation *) - | O_DIV_APPROX : - Z -> - Z -> - term -> - nat -> - t_omega -> nat -> t_omega - (* no solution because no exact division *) - | O_NOT_EXACT_DIVIDE : - Z -> Z -> term -> nat -> nat -> t_omega - (* exact division *) - | O_EXACT_DIVIDE : Z -> term -> nat -> t_omega -> nat -> t_omega - | O_SUM : Z -> nat -> Z -> nat -> list t_fusion -> t_omega -> t_omega + | O_CONSTANT_NEG : nat -> t_omega + (* division and approximation of an equation *) + | O_DIV_APPROX : int -> int -> term -> nat -> t_omega -> nat -> t_omega + (* no solution because no exact division *) + | O_NOT_EXACT_DIVIDE : int -> int -> term -> nat -> nat -> t_omega + (* exact division *) + | O_EXACT_DIVIDE : int -> term -> nat -> t_omega -> nat -> t_omega + | O_SUM : int -> nat -> int -> nat -> list t_fusion -> t_omega -> t_omega | O_CONTRADICTION : nat -> nat -> nat -> t_omega | O_MERGE_EQ : nat -> nat -> nat -> t_omega -> t_omega | O_SPLIT_INEQ : nat -> nat -> t_omega -> t_omega -> t_omega | O_CONSTANT_NUL : nat -> t_omega | O_NEGATE_CONTRADICT : nat -> nat -> t_omega | O_NEGATE_CONTRADICT_INV : nat -> nat -> nat -> t_omega - | O_STATE : Z -> step -> nat -> nat -> t_omega -> t_omega. + | O_STATE : int -> step -> nat -> nat -> t_omega -> t_omega. + +(* \subsubsection{Rules for normalizing the hypothesis} *) +(* These rules indicate how to normalize useful propositions + of each useful hypothesis before the decomposition of hypothesis. + The rules include the inversion phase for negation removal. *) -(* \subsubsection{Règles pour normaliser les hypothèses} *) -(* Ces règles indiquent comment normaliser les propositions utiles - de chaque hypothèse utile avant la décomposition des hypothèses et - incluent l'étape d'inversion pour la suppression des négations *) Inductive p_step : Set := | P_LEFT : p_step -> p_step | P_RIGHT : p_step -> p_step | P_INVERT : step -> p_step | P_STEP : step -> p_step | P_NOP : p_step. -(* Liste des normalisations a effectuer : avec un constructeur dans le - type [p_step] permettant - de parcourir à la fois les branches gauches et droit, on pourrait n'avoir - qu'une normalisation par hypothèse. Et comme toutes les hypothèses sont - utiles (sinon on ne les inclurait pas), on pourrait remplacer [h_step] - par une simple liste *) + +(* List of normalizations to perform : with a constructor of type + [p_step] allowing to visit both left and right branches, we would be + able to restrict to only one normalization by hypothesis. + And since all hypothesis are useful (otherwise they wouldn't be included), + we would be able to replace [h_step] by a simple list. *) Inductive h_step : Set := pair_step : nat -> p_step -> h_step. -(* \subsubsection{Règles pour décomposer les hypothèses} *) -(* Ce type permet de se diriger dans les constructeurs logiques formant les - prédicats des hypothèses pour aller les décomposer. Ils permettent - en particulier d'extraire une hypothèse d'une conjonction avec - éventuellement le bon niveau de négations. *) +(* \subsubsection{Rules for decomposing the hypothesis} *) +(* This type allows to navigate in the logical constructors that + form the predicats of the hypothesis in order to decompose them. + This allows in particular to extract one hypothesis from a + conjonction with possibly the right level of negations. *) Inductive direction : Set := | D_left : direction | D_right : direction | D_mono : direction. -(* Ce type permet d'extraire les composants utiles des hypothèses : que ce - soit des hypothèses générées par éclatement d'une disjonction, ou - des équations. Le constructeur terminal indique comment résoudre le système - obtenu en recourrant au type de trace d'Omega [t_omega] *) +(* This type allows to extract useful components from hypothesis, either + hypothesis generated by splitting a disjonction, or equations. + The last constructor indicates how to solve the obtained system + via the use of the trace type of Omega [t_omega] *) Inductive e_step : Set := | E_SPLIT : nat -> list direction -> e_step -> e_step -> e_step | E_EXTRACT : nat -> list direction -> e_step -> e_step | E_SOLVE : t_omega -> e_step. -(* \subsection{Egalité décidable efficace} *) -(* Pour chaque type de donnée réifié, on calcule un test d'égalité efficace. - Ce n'est pas le cas de celui rendu par [Decide Equality]. +(* \subsection{Efficient decidable equality} *) +(* For each reified data-type, we define an efficient equality test. + It is not the one produced by [Decide Equality]. - Puis on prouve deux théorèmes permettant d'éliminer de telles égalités : + Then we prove two theorem allowing to eliminate such equalities : \begin{verbatim} (t1,t2: typ) (eq_typ t1 t2) = true -> t1 = t2. (t1,t2: typ) (eq_typ t1 t2) = false -> ~ t1 = t2. \end{verbatim} *) -(* Ces deux tactiques permettent de résoudre pas mal de cas. L'une pour - les théorèmes positifs, l'autre pour les théorèmes négatifs *) - -Ltac absurd_case := simpl in |- *; intros; discriminate. -Ltac trivial_case := unfold not in |- *; intros; discriminate. - -(* \subsubsection{Entiers naturels} *) - -Fixpoint eq_nat (t1 t2 : nat) {struct t2} : bool := - match t1 with - | O => match t2 with - | O => true - | _ => false - end - | S n1 => match t2 with - | O => false - | S n2 => eq_nat n1 n2 - end - end. - -Theorem eq_nat_true : forall t1 t2 : nat, eq_nat t1 t2 = true -> t1 = t2. - -simple induction t1; - [ intro t2; case t2; [ trivial | absurd_case ] - | intros n H t2; case t2; - [ absurd_case - | simpl in |- *; intros; rewrite (H n0); [ trivial | assumption ] ] ]. - -Qed. - -Theorem eq_nat_false : forall t1 t2 : nat, eq_nat t1 t2 = false -> t1 <> t2. - -simple induction t1; - [ intro t2; case t2; [ simpl in |- *; intros; discriminate | trivial_case ] - | intros n H t2; case t2; simpl in |- *; unfold not in |- *; intros; - [ discriminate | elim (H n0 H0); simplify_eq H1; trivial ] ]. - -Qed. - - -(* \subsubsection{Entiers positifs} *) +(* \subsubsection{Reified terms} *) -Fixpoint eq_pos (p1 p2 : positive) {struct p2} : bool := - match p1 with - | xI n1 => match p2 with - | xI n2 => eq_pos n1 n2 - | _ => false - end - | xO n1 => match p2 with - | xO n2 => eq_pos n1 n2 - | _ => false - end - | xH => match p2 with - | xH => true - | _ => false - end - end. +Open Scope romega_scope. -Theorem eq_pos_true : forall t1 t2 : positive, eq_pos t1 t2 = true -> t1 = t2. - -simple induction t1; - [ intros p H t2; case t2; - [ simpl in |- *; intros; rewrite (H p0 H0); trivial - | absurd_case - | absurd_case ] - | intros p H t2; case t2; - [ absurd_case - | simpl in |- *; intros; rewrite (H p0 H0); trivial - | absurd_case ] - | intro t2; case t2; [ absurd_case | absurd_case | auto ] ]. - -Qed. - -Theorem eq_pos_false : - forall t1 t2 : positive, eq_pos t1 t2 = false -> t1 <> t2. - -simple induction t1; - [ intros p H t2; case t2; - [ simpl in |- *; unfold not in |- *; intros; elim (H p0 H0); - simplify_eq H1; auto - | trivial_case - | trivial_case ] - | intros p H t2; case t2; - [ trivial_case - | simpl in |- *; unfold not in |- *; intros; elim (H p0 H0); - simplify_eq H1; auto - | trivial_case ] - | intros t2; case t2; [ trivial_case | trivial_case | absurd_case ] ]. -Qed. - -(* \subsubsection{Entiers relatifs} *) - -Definition eq_Z (z1 z2 : Z) : bool := - match z1 with - | Z0 => match z2 with - | Z0 => true - | _ => false - end - | Zpos p1 => match z2 with - | Zpos p2 => eq_pos p1 p2 - | _ => false - end - | Zneg p1 => match z2 with - | Zneg p2 => eq_pos p1 p2 - | _ => false - end +Fixpoint eq_term (t1 t2 : term) {struct t2} : bool := + match t1, t2 with + | Tint st1, Tint st2 => beq st1 st2 + | (st11 + st12), (st21 + st22) => eq_term st11 st21 && eq_term st12 st22 + | (st11 * st12), (st21 * st22) => eq_term st11 st21 && eq_term st12 st22 + | (st11 - st12), (st21 - st22) => eq_term st11 st21 && eq_term st12 st22 + | (- st1), (- st2) => eq_term st1 st2 + | [st1], [st2] => beq_nat st1 st2 + | _, _ => false end. -Theorem eq_Z_true : forall t1 t2 : Z, eq_Z t1 t2 = true -> t1 = t2. - -simple induction t1; - [ intros t2; case t2; [ auto | absurd_case | absurd_case ] - | intros p t2; case t2; - [ absurd_case - | simpl in |- *; intros; rewrite (eq_pos_true p p0 H); trivial - | absurd_case ] - | intros p t2; case t2; - [ absurd_case - | absurd_case - | simpl in |- *; intros; rewrite (eq_pos_true p p0 H); trivial ] ]. - -Qed. - -Theorem eq_Z_false : forall t1 t2 : Z, eq_Z t1 t2 = false -> t1 <> t2. - -simple induction t1; - [ intros t2; case t2; [ absurd_case | trivial_case | trivial_case ] - | intros p t2; case t2; - [ absurd_case - | simpl in |- *; unfold not in |- *; intros; elim (eq_pos_false p p0 H); - simplify_eq H0; auto - | trivial_case ] - | intros p t2; case t2; - [ absurd_case - | trivial_case - | simpl in |- *; unfold not in |- *; intros; elim (eq_pos_false p p0 H); - simplify_eq H0; auto ] ]. -Qed. - -(* \subsubsection{Termes réifiés} *) - -Fixpoint eq_term (t1 t2 : term) {struct t2} : bool := - match t1 with - | Tint st1 => match t2 with - | Tint st2 => eq_Z st1 st2 - | _ => false - end - | (st11 + st12)%term => - match t2 with - | (st21 + st22)%term => eq_term st11 st21 && eq_term st12 st22 - | _ => false - end - | (st11 * st12)%term => - match t2 with - | (st21 * st22)%term => eq_term st11 st21 && eq_term st12 st22 - | _ => false - end - | (st11 - st12)%term => - match t2 with - | (st21 - st22)%term => eq_term st11 st21 && eq_term st12 st22 - | _ => false - end - | (- st1)%term => - match t2 with - | (- st2)%term => eq_term st1 st2 - | _ => false - end - | [st1]%term => - match t2 with - | [st2]%term => eq_nat st1 st2 - | _ => false - end - end. +Close Scope romega_scope. Theorem eq_term_true : forall t1 t2 : term, eq_term t1 t2 = true -> t1 = t2. - - -simple induction t1; intros until t2; case t2; try absurd_case; simpl in |- *; - [ intros; elim eq_Z_true with (1 := H); trivial +Proof. + simple induction t1; intros until t2; case t2; simpl in *; + try (intros; discriminate; fail); + [ intros; elim beq_true with (1 := H); trivial | intros t21 t22 H3; elim andb_prop with (1 := H3); intros H4 H5; elim H with (1 := H4); elim H0 with (1 := H5); trivial @@ -417,16 +1074,17 @@ simple induction t1; intros until t2; case t2; try absurd_case; simpl in |- *; elim H with (1 := H4); elim H0 with (1 := H5); trivial | intros t21 H3; elim H with (1 := H3); trivial - | intros; elim eq_nat_true with (1 := H); trivial ]. - + | intros; elim beq_nat_true with (1 := H); trivial ]. Qed. +Ltac trivial_case := unfold not in |- *; intros; discriminate. + Theorem eq_term_false : forall t1 t2 : term, eq_term t1 t2 = false -> t1 <> t2. - -simple induction t1; +Proof. + simple induction t1; [ intros z t2; case t2; try trivial_case; simpl in |- *; unfold not in |- *; - intros; elim eq_Z_false with (1 := H); simplify_eq H0; + intros; elim beq_false with (1 := H); simplify_eq H0; auto | intros t11 H1 t12 H2 t2; case t2; try trivial_case; simpl in |- *; intros t21 t22 H3; unfold not in |- *; intro H4; @@ -447,9 +1105,8 @@ simple induction t1; unfold not in |- *; intro H4; elim H1 with (1 := H3); simplify_eq H4; auto | intros n t2; case t2; try trivial_case; simpl in |- *; unfold not in |- *; - intros; elim eq_nat_false with (1 := H); simplify_eq H0; + intros; elim beq_nat_false with (1 := H); simplify_eq H0; auto ]. - Qed. (* \subsubsection{Tactiques pour éliminer ces tests} @@ -463,54 +1120,29 @@ Qed. tel test préserve bien l'information voulue mais calculatoirement de telles fonctions sont trop lentes. *) -(* Le théorème suivant permet de garder dans les hypothèses la valeur - du booléen lors de l'élimination. *) - -Theorem bool_ind2 : - forall (P : bool -> Prop) (b : bool), - (b = true -> P true) -> (b = false -> P false) -> P b. - -simple induction b; auto. -Qed. - (* Les tactiques définies si après se comportent exactement comme si on avait utilisé le test précédent et fait une elimination dessus. *) Ltac elim_eq_term t1 t2 := - pattern (eq_term t1 t2) in |- *; apply bool_ind2; intro Aux; + pattern (eq_term t1 t2) in |- *; apply bool_eq_ind; intro Aux; [ generalize (eq_term_true t1 t2 Aux); clear Aux | generalize (eq_term_false t1 t2 Aux); clear Aux ]. -Ltac elim_eq_Z t1 t2 := - pattern (eq_Z t1 t2) in |- *; apply bool_ind2; intro Aux; - [ generalize (eq_Z_true t1 t2 Aux); clear Aux - | generalize (eq_Z_false t1 t2 Aux); clear Aux ]. - -Ltac elim_eq_pos t1 t2 := - pattern (eq_pos t1 t2) in |- *; apply bool_ind2; intro Aux; - [ generalize (eq_pos_true t1 t2 Aux); clear Aux - | generalize (eq_pos_false t1 t2 Aux); clear Aux ]. +Ltac elim_beq t1 t2 := + pattern (beq t1 t2) in |- *; apply bool_eq_ind; intro Aux; + [ generalize (beq_true t1 t2 Aux); clear Aux + | generalize (beq_false t1 t2 Aux); clear Aux ]. -(* \subsubsection{Comparaison sur Z} *) - -(* Sujet très lié au précédent : on introduit la tactique d'élimination - avec son théorème *) - -Theorem relation_ind2 : - forall (P : comparison -> Prop) (b : comparison), - (b = Eq -> P Eq) -> - (b = Lt -> P Lt) -> - (b = Gt -> P Gt) -> P b. - -simple induction b; auto. -Qed. +Ltac elim_bgt t1 t2 := + pattern (bgt t1 t2) in |- *; apply bool_eq_ind; intro Aux; + [ generalize (bgt_true t1 t2 Aux); clear Aux + | generalize (bgt_false t1 t2 Aux); clear Aux ]. -Ltac elim_Zcompare t1 t2 := pattern (t1 ?= t2) in |- *; apply relation_ind2. (* \subsection{Interprétations} \subsubsection{Interprétation des termes dans Z} *) -Fixpoint interp_term (env : list Z) (t : term) {struct t} : Z := +Fixpoint interp_term (env : list int) (t : term) {struct t} : int := match t with | Tint x => x | (t1 + t2)%term => interp_term env t1 + interp_term env t2 @@ -521,7 +1153,8 @@ Fixpoint interp_term (env : list Z) (t : term) {struct t} : Z := end. (* \subsubsection{Interprétation des prédicats} *) -Fixpoint interp_proposition (envp : PropList) (env : list Z) + +Fixpoint interp_proposition (envp : list Prop) (env : list int) (p : proposition) {struct p} : Prop := match p with | EqTerm t1 t2 => interp_term env t1 = interp_term env t2 @@ -532,14 +1165,14 @@ Fixpoint interp_proposition (envp : PropList) (env : list Z) | GeqTerm t1 t2 => interp_term env t1 >= interp_term env t2 | GtTerm t1 t2 => interp_term env t1 > interp_term env t2 | LtTerm t1 t2 => interp_term env t1 < interp_term env t2 - | NeqTerm t1 t2 => Zne (interp_term env t1) (interp_term env t2) + | NeqTerm t1 t2 => (interp_term env t1)<>(interp_term env t2) | Tor p1 p2 => interp_proposition envp env p1 \/ interp_proposition envp env p2 | Tand p1 p2 => interp_proposition envp env p1 /\ interp_proposition envp env p2 | Timp p1 p2 => interp_proposition envp env p1 -> interp_proposition envp env p2 - | Tprop n => nthProp n envp True + | Tprop n => nth n envp True end. (* \subsubsection{Inteprétation des listes d'hypothèses} @@ -547,7 +1180,7 @@ Fixpoint interp_proposition (envp : PropList) (env : list Z) Interprétation sous forme d'une conjonction d'hypothèses plus faciles à manipuler individuellement *) -Fixpoint interp_hyps (envp : PropList) (env : list Z) +Fixpoint interp_hyps (envp : list Prop) (env : list int) (l : hyps) {struct l} : Prop := match l with | nil => True @@ -559,8 +1192,8 @@ Fixpoint interp_hyps (envp : PropList) (env : list Z) [Generalize] et qu'une conjonction est forcément lourde (répétition des types dans les conjonctions intermédiaires) *) -Fixpoint interp_goal_concl (c : proposition) (envp : PropList) - (env : list Z) (l : hyps) {struct l} : Prop := +Fixpoint interp_goal_concl (c : proposition) (envp : list Prop) + (env : list int) (l : hyps) {struct l} : Prop := match l with | nil => interp_proposition envp env c | p' :: l' => @@ -573,19 +1206,19 @@ Notation interp_goal := (interp_goal_concl FalseTerm). interprétations. *) Theorem goal_to_hyps : - forall (envp : PropList) (env : list Z) (l : hyps), + forall (envp : list Prop) (env : list int) (l : hyps), (interp_hyps envp env l -> False) -> interp_goal envp env l. - -simple induction l; +Proof. + simple induction l; [ simpl in |- *; auto | simpl in |- *; intros a l1 H1 H2 H3; apply H1; intro H4; apply H2; auto ]. Qed. Theorem hyps_to_goal : - forall (envp : PropList) (env : list Z) (l : hyps), + forall (envp : list Prop) (env : list int) (l : hyps), interp_goal envp env l -> interp_hyps envp env l -> False. - -simple induction l; simpl in |- *; [ auto | intros; apply H; elim H1; auto ]. +Proof. + simple induction l; simpl in |- *; [ auto | intros; apply H; elim H1; auto ]. Qed. (* \subsection{Manipulations sur les hypothèses} *) @@ -593,7 +1226,7 @@ Qed. (* \subsubsection{Définitions de base de stabilité pour la réflexion} *) (* Une opération laisse un terme stable si l'égalité est préservée *) Definition term_stable (f : term -> term) := - forall (e : list Z) (t : term), interp_term e t = interp_term e (f t). + forall (e : list int) (t : term), interp_term e t = interp_term e (f t). (* Une opération est valide sur une hypothèse, si l'hypothèse implique le résultat de l'opération. \emph{Attention : cela ne concerne que des @@ -602,11 +1235,11 @@ Definition term_stable (f : term -> term) := en argument (cela suffit pour omega). *) Definition valid1 (f : proposition -> proposition) := - forall (ep : PropList) (e : list Z) (p1 : proposition), + forall (ep : list Prop) (e : list int) (p1 : proposition), interp_proposition ep e p1 -> interp_proposition ep e (f p1). Definition valid2 (f : proposition -> proposition -> proposition) := - forall (ep : PropList) (e : list Z) (p1 p2 : proposition), + forall (ep : list Prop) (e : list int) (p1 p2 : proposition), interp_proposition ep e p1 -> interp_proposition ep e p2 -> interp_proposition ep e (f p1 p2). @@ -615,31 +1248,31 @@ Definition valid2 (f : proposition -> proposition -> proposition) := On reste contravariant *) Definition valid_hyps (f : hyps -> hyps) := - forall (ep : PropList) (e : list Z) (lp : hyps), + forall (ep : list Prop) (e : list int) (lp : hyps), interp_hyps ep e lp -> interp_hyps ep e (f lp). (* Enfin ce théorème élimine la contravariance et nous ramène à une opération sur les buts *) - Theorem valid_goal : - forall (ep : PropList) (env : list Z) (l : hyps) (a : hyps -> hyps), +Theorem valid_goal : + forall (ep : list Prop) (env : list int) (l : hyps) (a : hyps -> hyps), valid_hyps a -> interp_goal ep env (a l) -> interp_goal ep env l. - -intros; simpl in |- *; apply goal_to_hyps; intro H1; +Proof. + intros; simpl in |- *; apply goal_to_hyps; intro H1; apply (hyps_to_goal ep env (a l) H0); apply H; assumption. Qed. (* \subsubsection{Généralisation a des listes de buts (disjonctions)} *) -Fixpoint interp_list_hyps (envp : PropList) (env : list Z) +Fixpoint interp_list_hyps (envp : list Prop) (env : list int) (l : lhyps) {struct l} : Prop := match l with | nil => False | h :: l' => interp_hyps envp env h \/ interp_list_hyps envp env l' end. -Fixpoint interp_list_goal (envp : PropList) (env : list Z) +Fixpoint interp_list_goal (envp : list Prop) (env : list int) (l : lhyps) {struct l} : Prop := match l with | nil => True @@ -647,10 +1280,10 @@ Fixpoint interp_list_goal (envp : PropList) (env : list Z) end. Theorem list_goal_to_hyps : - forall (envp : PropList) (env : list Z) (l : lhyps), + forall (envp : list Prop) (env : list int) (l : lhyps), (interp_list_hyps envp env l -> False) -> interp_list_goal envp env l. - -simple induction l; simpl in |- *; +Proof. + simple induction l; simpl in |- *; [ auto | intros h1 l1 H H1; split; [ apply goal_to_hyps; intro H2; apply H1; auto @@ -658,37 +1291,37 @@ simple induction l; simpl in |- *; Qed. Theorem list_hyps_to_goal : - forall (envp : PropList) (env : list Z) (l : lhyps), + forall (envp : list Prop) (env : list int) (l : lhyps), interp_list_goal envp env l -> interp_list_hyps envp env l -> False. - -simple induction l; simpl in |- *; +Proof. + simple induction l; simpl in |- *; [ auto | intros h1 l1 H (H1, H2) H3; elim H3; intro H4; [ apply hyps_to_goal with (1 := H1); assumption | auto ] ]. Qed. Definition valid_list_hyps (f : hyps -> lhyps) := - forall (ep : PropList) (e : list Z) (lp : hyps), + forall (ep : list Prop) (e : list int) (lp : hyps), interp_hyps ep e lp -> interp_list_hyps ep e (f lp). Definition valid_list_goal (f : hyps -> lhyps) := - forall (ep : PropList) (e : list Z) (lp : hyps), + forall (ep : list Prop) (e : list int) (lp : hyps), interp_list_goal ep e (f lp) -> interp_goal ep e lp. Theorem goal_valid : forall f : hyps -> lhyps, valid_list_hyps f -> valid_list_goal f. - -unfold valid_list_goal in |- *; intros f H ep e lp H1; apply goal_to_hyps; +Proof. + unfold valid_list_goal in |- *; intros f H ep e lp H1; apply goal_to_hyps; intro H2; apply list_hyps_to_goal with (1 := H1); apply (H ep e lp); assumption. Qed. Theorem append_valid : - forall (ep : PropList) (e : list Z) (l1 l2 : lhyps), + forall (ep : list Prop) (e : list int) (l1 l2 : lhyps), interp_list_hyps ep e l1 \/ interp_list_hyps ep e l2 -> interp_list_hyps ep e (l1 ++ l2). - -intros ep e; simple induction l1; +Proof. + intros ep e; simple induction l1; [ simpl in |- *; intros l2 [H| H]; [ contradiction | trivial ] | simpl in |- *; intros h1 t1 HR l2 [[H| H]| H]; [ auto @@ -703,10 +1336,10 @@ Qed. Definition nth_hyps (n : nat) (l : hyps) := nth n l TrueTerm. Theorem nth_valid : - forall (ep : PropList) (e : list Z) (i : nat) (l : hyps), + forall (ep : list Prop) (e : list int) (i : nat) (l : hyps), interp_hyps ep e l -> interp_proposition ep e (nth_hyps i l). - -unfold nth_hyps in |- *; simple induction i; +Proof. + unfold nth_hyps in |- *; simple induction i; [ simple induction l; simpl in |- *; [ auto | intros; elim H0; auto ] | intros n H; simple induction l; [ simpl in |- *; trivial @@ -722,8 +1355,8 @@ Definition apply_oper_2 (i j : nat) Theorem apply_oper_2_valid : forall (i j : nat) (f : proposition -> proposition -> proposition), valid2 f -> valid_hyps (apply_oper_2 i j f). - -intros i j f Hf; unfold apply_oper_2, valid_hyps in |- *; simpl in |- *; +Proof. + intros i j f Hf; unfold apply_oper_2, valid_hyps in |- *; simpl in |- *; intros lp Hlp; split; [ apply Hf; apply nth_valid; assumption | assumption ]. Qed. @@ -743,8 +1376,8 @@ Fixpoint apply_oper_1 (i : nat) (f : proposition -> proposition) Theorem apply_oper_1_valid : forall (i : nat) (f : proposition -> proposition), valid1 f -> valid_hyps (apply_oper_1 i f). - -unfold valid_hyps in |- *; intros i f Hf ep e; elim i; +Proof. + unfold valid_hyps in |- *; intros i f Hf ep e; elim i; [ intro lp; case lp; [ simpl in |- *; trivial | simpl in |- *; intros p l' (H1, H2); split; @@ -753,7 +1386,6 @@ unfold valid_hyps in |- *; intros i f Hf ep e; elim i; [ simpl in |- *; auto | simpl in |- *; intros p l' (H1, H2); split; [ assumption | apply Hrec; assumption ] ] ]. - Qed. (* \subsubsection{Manipulations de termes} *) @@ -789,31 +1421,31 @@ Definition apply_both (f g : term -> term) (t : term) := Theorem apply_left_stable : forall f : term -> term, term_stable f -> term_stable (apply_left f). - -unfold term_stable in |- *; intros f H e t; case t; auto; simpl in |- *; +Proof. + unfold term_stable in |- *; intros f H e t; case t; auto; simpl in |- *; intros; elim H; trivial. Qed. Theorem apply_right_stable : forall f : term -> term, term_stable f -> term_stable (apply_right f). - -unfold term_stable in |- *; intros f H e t; case t; auto; simpl in |- *; +Proof. + unfold term_stable in |- *; intros f H e t; case t; auto; simpl in |- *; intros t0 t1; elim H; trivial. Qed. Theorem apply_both_stable : forall f g : term -> term, term_stable f -> term_stable g -> term_stable (apply_both f g). - -unfold term_stable in |- *; intros f g H1 H2 e t; case t; auto; simpl in |- *; +Proof. + unfold term_stable in |- *; intros f g H1 H2 e t; case t; auto; simpl in |- *; intros t0 t1; elim H1; elim H2; trivial. Qed. Theorem compose_term_stable : forall f g : term -> term, term_stable f -> term_stable g -> term_stable (fun t : term => f (g t)). - -unfold term_stable in |- *; intros f g Hf Hg e t; elim Hf; apply Hg. +Proof. + unfold term_stable in |- *; intros f g Hf Hg e t; elim Hf; apply Hg. Qed. (* \subsection{Les règles de réécriture} *) @@ -879,21 +1511,7 @@ Ltac loop t := | Tand x x0 => _ | Timp x x0 => _ | Tprop x => _ - end => - case X1; - [ intro; intro - | intro; intro - | idtac - | idtac - | intro - | intro; intro - | intro; intro - | intro; intro - | intro; intro - | intro; intro - | intro; intro - | intro; intro - | intro ]; auto; Simplify + end => destruct X1; auto; Simplify | match ?X1 with | Tint x => _ | (x + x0)%term => _ @@ -901,38 +1519,27 @@ Ltac loop t := | (x - x0)%term => _ | (- x)%term => _ | [x]%term => _ - end => - case X1; - [ intro | intro; intro | intro; intro | intro; intro | intro | intro ]; - auto; Simplify - | match ?X1 ?= ?X2 with - | Eq => _ - | Lt => _ - | Gt => _ - end => - elim_Zcompare X1 X2; intro; auto; Simplify - | match ?X1 with - | Z0 => _ - | Zpos x => _ - | Zneg x => _ - end => - case X1; [ idtac | intro | intro ]; auto; Simplify - | (if eq_Z ?X1 ?X2 then _ else _) => - elim_eq_Z X1 X2; intro H; [ rewrite H; clear H | clear H ]; + end => destruct X1; auto; Simplify + | (if beq ?X1 ?X2 then _ else _) => + let H := fresh "H" in + elim_beq X1 X2; intro H; try (rewrite H in *; clear H); simpl in |- *; auto; Simplify + | (if bgt ?X1 ?X2 then _ else _) => + let H := fresh "H" in + elim_bgt X1 X2; intro H; simpl in |- *; auto; Simplify | (if eq_term ?X1 ?X2 then _ else _) => - elim_eq_term X1 X2; intro H; [ rewrite H; clear H | clear H ]; - simpl in |- *; auto; Simplify - | (if eq_pos ?X1 ?X2 then _ else _) => - elim_eq_pos X1 X2; intro H; [ rewrite H; clear H | clear H ]; + let H := fresh "H" in + elim_eq_term X1 X2; intro H; try (rewrite H in *; clear H); simpl in |- *; auto; Simplify + | (if _ && _ then _ else _) => rewrite andb_if; Simplify + | (if negb _ then _ else _) => rewrite negb_if; Simplify | _ => fail end - with Simplify := match goal with - | |- ?X1 => try loop X1 - | _ => idtac - end. +with Simplify := match goal with + | |- ?X1 => try loop X1 + | _ => idtac + end. Ltac prove_stable x th := match constr:x with @@ -949,8 +1556,8 @@ Definition Tplus_assoc_l (t : term) := end. Theorem Tplus_assoc_l_stable : term_stable Tplus_assoc_l. - -prove_stable Tplus_assoc_l Zplus_assoc. +Proof. + prove_stable Tplus_assoc_l (ring.(Radd_assoc)). Qed. Definition Tplus_assoc_r (t : term) := @@ -960,8 +1567,8 @@ Definition Tplus_assoc_r (t : term) := end. Theorem Tplus_assoc_r_stable : term_stable Tplus_assoc_r. - -prove_stable Tplus_assoc_r Zplus_assoc_reverse. +Proof. + prove_stable Tplus_assoc_r plus_assoc_reverse. Qed. Definition Tmult_assoc_r (t : term) := @@ -971,8 +1578,8 @@ Definition Tmult_assoc_r (t : term) := end. Theorem Tmult_assoc_r_stable : term_stable Tmult_assoc_r. - -prove_stable Tmult_assoc_r Zmult_assoc_reverse. +Proof. + prove_stable Tmult_assoc_r mult_assoc_reverse. Qed. Definition Tplus_permute (t : term) := @@ -982,46 +1589,44 @@ Definition Tplus_permute (t : term) := end. Theorem Tplus_permute_stable : term_stable Tplus_permute. - -prove_stable Tplus_permute Zplus_permute. +Proof. + prove_stable Tplus_permute plus_permute. Qed. -Definition Tplus_sym (t : term) := +Definition Tplus_comm (t : term) := match t with | (x + y)%term => (y + x)%term | _ => t end. -Theorem Tplus_sym_stable : term_stable Tplus_sym. - -prove_stable Tplus_sym Zplus_comm. +Theorem Tplus_comm_stable : term_stable Tplus_comm. +Proof. + prove_stable Tplus_comm plus_comm. Qed. -Definition Tmult_sym (t : term) := +Definition Tmult_comm (t : term) := match t with | (x * y)%term => (y * x)%term | _ => t end. -Theorem Tmult_sym_stable : term_stable Tmult_sym. - -prove_stable Tmult_sym Zmult_comm. +Theorem Tmult_comm_stable : term_stable Tmult_comm. +Proof. + prove_stable Tmult_comm mult_comm. Qed. Definition T_OMEGA10 (t : term) := match t with | ((v * Tint c1 + l1) * Tint k1 + (v' * Tint c2 + l2) * Tint k2)%term => - match eq_term v v' with - | true => - (v * Tint (c1 * k1 + c2 * k2) + (l1 * Tint k1 + l2 * Tint k2))%term - | false => t - end + if eq_term v v' + then (v * Tint (c1 * k1 + c2 * k2)%I + (l1 * Tint k1 + l2 * Tint k2))%term + else t | _ => t end. Theorem T_OMEGA10_stable : term_stable T_OMEGA10. - -prove_stable T_OMEGA10 OMEGA10. +Proof. + prove_stable T_OMEGA10 OMEGA10. Qed. Definition T_OMEGA11 (t : term) := @@ -1032,8 +1637,8 @@ Definition T_OMEGA11 (t : term) := end. Theorem T_OMEGA11_stable : term_stable T_OMEGA11. - -prove_stable T_OMEGA11 OMEGA11. +Proof. + prove_stable T_OMEGA11 OMEGA11. Qed. Definition T_OMEGA12 (t : term) := @@ -1044,52 +1649,37 @@ Definition T_OMEGA12 (t : term) := end. Theorem T_OMEGA12_stable : term_stable T_OMEGA12. - -prove_stable T_OMEGA12 OMEGA12. +Proof. + prove_stable T_OMEGA12 OMEGA12. Qed. Definition T_OMEGA13 (t : term) := match t with - | (v * Tint (Zpos x) + l1 + (v' * Tint (Zneg x') + l2))%term => - match eq_term v v' with - | true => - match eq_pos x x' with - | true => (l1 + l2)%term - | false => t - end - | false => t - end - | (v * Tint (Zneg x) + l1 + (v' * Tint (Zpos x') + l2))%term => - match eq_term v v' with - | true => - match eq_pos x x' with - | true => (l1 + l2)%term - | false => t - end - | false => t - end + | (v * Tint x + l1 + (v' * Tint x' + l2))%term => + if eq_term v v' && beq x (-x') + then (l1+l2)%term + else t | _ => t end. Theorem T_OMEGA13_stable : term_stable T_OMEGA13. - -unfold term_stable, T_OMEGA13 in |- *; intros; Simplify; simpl in |- *; - [ apply OMEGA13 | apply OMEGA14 ]. +Proof. + unfold term_stable, T_OMEGA13 in |- *; intros; Simplify; simpl in |- *; + apply OMEGA13. Qed. Definition T_OMEGA15 (t : term) := match t with | (v * Tint c1 + l1 + (v' * Tint c2 + l2) * Tint k2)%term => - match eq_term v v' with - | true => (v * Tint (c1 + c2 * k2) + (l1 + l2 * Tint k2))%term - | false => t - end + if eq_term v v' + then (v * Tint (c1 + c2 * k2)%I + (l1 + l2 * Tint k2))%term + else t | _ => t end. Theorem T_OMEGA15_stable : term_stable T_OMEGA15. - -prove_stable T_OMEGA15 OMEGA15. +Proof. + prove_stable T_OMEGA15 OMEGA15. Qed. Definition T_OMEGA16 (t : term) := @@ -1100,20 +1690,19 @@ Definition T_OMEGA16 (t : term) := Theorem T_OMEGA16_stable : term_stable T_OMEGA16. - -prove_stable T_OMEGA16 OMEGA16. +Proof. + prove_stable T_OMEGA16 OMEGA16. Qed. Definition Tred_factor5 (t : term) := match t with - | (x * Tint Z0 + y)%term => y + | (x * Tint c + y)%term => if beq c 0 then y else t | _ => t end. Theorem Tred_factor5_stable : term_stable Tred_factor5. - - -prove_stable Tred_factor5 Zred_factor5. +Proof. + prove_stable Tred_factor5 red_factor5. Qed. Definition Topp_plus (t : term) := @@ -1123,8 +1712,8 @@ Definition Topp_plus (t : term) := end. Theorem Topp_plus_stable : term_stable Topp_plus. - -prove_stable Topp_plus Zopp_plus_distr. +Proof. + prove_stable Topp_plus opp_plus_distr. Qed. @@ -1135,8 +1724,8 @@ Definition Topp_opp (t : term) := end. Theorem Topp_opp_stable : term_stable Topp_opp. - -prove_stable Topp_opp Zopp_involutive. +Proof. + prove_stable Topp_opp opp_involutive. Qed. Definition Topp_mult_r (t : term) := @@ -1146,19 +1735,19 @@ Definition Topp_mult_r (t : term) := end. Theorem Topp_mult_r_stable : term_stable Topp_mult_r. - -prove_stable Topp_mult_r Zopp_mult_distr_r. +Proof. + prove_stable Topp_mult_r opp_mult_distr_r. Qed. Definition Topp_one (t : term) := match t with - | (- x)%term => (x * Tint (-1))%term + | (- x)%term => (x * Tint (-(1)))%term | _ => t end. Theorem Topp_one_stable : term_stable Topp_one. - -prove_stable Topp_one Zopp_eq_mult_neg_1. +Proof. + prove_stable Topp_one opp_eq_mult_neg_1. Qed. Definition Tmult_plus_distr (t : term) := @@ -1168,8 +1757,8 @@ Definition Tmult_plus_distr (t : term) := end. Theorem Tmult_plus_distr_stable : term_stable Tmult_plus_distr. - -prove_stable Tmult_plus_distr Zmult_plus_distr_l. +Proof. + prove_stable Tmult_plus_distr mult_plus_distr_r. Qed. Definition Tmult_opp_left (t : term) := @@ -1179,8 +1768,8 @@ Definition Tmult_opp_left (t : term) := end. Theorem Tmult_opp_left_stable : term_stable Tmult_opp_left. - -prove_stable Tmult_opp_left Zmult_opp_comm. +Proof. + prove_stable Tmult_opp_left mult_opp_comm. Qed. Definition Tmult_assoc_reduced (t : term) := @@ -1190,91 +1779,81 @@ Definition Tmult_assoc_reduced (t : term) := end. Theorem Tmult_assoc_reduced_stable : term_stable Tmult_assoc_reduced. - -prove_stable Tmult_assoc_reduced Zmult_assoc_reverse. +Proof. + prove_stable Tmult_assoc_reduced mult_assoc_reverse. Qed. Definition Tred_factor0 (t : term) := (t * Tint 1)%term. Theorem Tred_factor0_stable : term_stable Tred_factor0. - -prove_stable Tred_factor0 Zred_factor0. +Proof. + prove_stable Tred_factor0 red_factor0. Qed. Definition Tred_factor1 (t : term) := match t with | (x + y)%term => - match eq_term x y with - | true => (x * Tint 2)%term - | false => t - end + if eq_term x y + then (x * Tint 2)%term + else t | _ => t end. Theorem Tred_factor1_stable : term_stable Tred_factor1. - -prove_stable Tred_factor1 Zred_factor1. +Proof. + prove_stable Tred_factor1 red_factor1. Qed. Definition Tred_factor2 (t : term) := match t with | (x + y * Tint k)%term => - match eq_term x y with - | true => (x * Tint (1 + k))%term - | false => t - end + if eq_term x y + then (x * Tint (1 + k))%term + else t | _ => t end. -(* Attention : il faut rendre opaque [Zplus] pour éviter que la tactique - de simplification n'aille trop loin et défasse [Zplus 1 k] *) - -Opaque Zplus. - Theorem Tred_factor2_stable : term_stable Tred_factor2. -prove_stable Tred_factor2 Zred_factor2. +Proof. + prove_stable Tred_factor2 red_factor2. Qed. Definition Tred_factor3 (t : term) := match t with | (x * Tint k + y)%term => - match eq_term x y with - | true => (x * Tint (1 + k))%term - | false => t - end + if eq_term x y + then (x * Tint (1 + k))%term + else t | _ => t end. Theorem Tred_factor3_stable : term_stable Tred_factor3. - -prove_stable Tred_factor3 Zred_factor3. +Proof. + prove_stable Tred_factor3 red_factor3. Qed. Definition Tred_factor4 (t : term) := match t with | (x * Tint k1 + y * Tint k2)%term => - match eq_term x y with - | true => (x * Tint (k1 + k2))%term - | false => t - end + if eq_term x y + then (x * Tint (k1 + k2))%term + else t | _ => t end. Theorem Tred_factor4_stable : term_stable Tred_factor4. - -prove_stable Tred_factor4 Zred_factor4. +Proof. + prove_stable Tred_factor4 red_factor4. Qed. Definition Tred_factor6 (t : term) := (t + Tint 0)%term. Theorem Tred_factor6_stable : term_stable Tred_factor6. - -prove_stable Tred_factor6 Zred_factor6. +Proof. + prove_stable Tred_factor6 red_factor6. Qed. -Transparent Zplus. - Definition Tminus_def (t : term) := match t with | (x - y)%term => (x + - y)%term @@ -1282,9 +1861,8 @@ Definition Tminus_def (t : term) := end. Theorem Tminus_def_stable : term_stable Tminus_def. - -(* Le théorème ne sert à rien. Le but est prouvé avant. *) -prove_stable Tminus_def False. +Proof. + prove_stable Tminus_def minus_def. Qed. (* \subsection{Fonctions de réécriture complexes} *) @@ -1332,8 +1910,8 @@ Fixpoint reduce (t : term) : term := end. Theorem reduce_stable : term_stable reduce. - -unfold term_stable in |- *; intros e t; elim t; auto; +Proof. + unfold term_stable in |- *; intros e t; elim t; auto; try (intros t0 H0 t1 H1; simpl in |- *; rewrite H0; rewrite H1; (case (reduce t0); @@ -1366,8 +1944,8 @@ Fixpoint fusion (trace : list t_fusion) (t : term) {struct trace} : term := end. Theorem fusion_stable : forall t : list t_fusion, term_stable (fusion t). - -simple induction t; simpl in |- *; +Proof. + simple induction t; simpl in |- *; [ exact reduce_stable | intros stp l H; case stp; [ apply compose_term_stable; @@ -1378,7 +1956,6 @@ simple induction t; simpl in |- *; [ apply apply_right_stable; assumption | exact T_OMEGA11_stable ] | apply compose_term_stable; [ apply apply_right_stable; assumption | exact T_OMEGA12_stable ] ] ]. - Qed. (* \paragraph{Fusion de deux équations dont une sans coefficient} *) @@ -1405,8 +1982,8 @@ Fixpoint fusion_cancel (trace : nat) (t : term) {struct trace} : term := end. Theorem fusion_cancel_stable : forall t : nat, term_stable (fusion_cancel t). - -unfold term_stable, fusion_cancel in |- *; intros trace e; elim trace; +Proof. + unfold term_stable, fusion_cancel in |- *; intros trace e; elim trace; [ exact (reduce_stable e) | intros n H t; elim H; exact (T_OMEGA13_stable e t) ]. Qed. @@ -1422,8 +1999,8 @@ Fixpoint scalar_norm_add (trace : nat) (t : term) {struct trace} : term := Theorem scalar_norm_add_stable : forall t : nat, term_stable (scalar_norm_add t). - -unfold term_stable, scalar_norm_add in |- *; intros trace; elim trace; +Proof. + unfold term_stable, scalar_norm_add in |- *; intros trace; elim trace; [ exact reduce_stable | intros n H e t; elim apply_right_stable; [ exact (T_OMEGA11_stable e t) | exact H ] ]. @@ -1437,8 +2014,8 @@ Fixpoint scalar_norm (trace : nat) (t : term) {struct trace} : term := end. Theorem scalar_norm_stable : forall t : nat, term_stable (scalar_norm t). - -unfold term_stable, scalar_norm in |- *; intros trace; elim trace; +Proof. + unfold term_stable, scalar_norm in |- *; intros trace; elim trace; [ exact reduce_stable | intros n H e t; elim apply_right_stable; [ exact (T_OMEGA16_stable e t) | exact H ] ]. @@ -1452,8 +2029,8 @@ Fixpoint add_norm (trace : nat) (t : term) {struct trace} : term := end. Theorem add_norm_stable : forall t : nat, term_stable (add_norm t). - -unfold term_stable, add_norm in |- *; intros trace; elim trace; +Proof. + unfold term_stable, add_norm in |- *; intros trace; elim trace; [ exact reduce_stable | intros n H e t; elim apply_right_stable; [ exact (Tplus_assoc_r_stable e t) | exact H ] ]. @@ -1480,7 +2057,7 @@ Fixpoint rewrite (s : step) : term -> term := | C_PLUS_ASSOC_R => Tplus_assoc_r | C_PLUS_ASSOC_L => Tplus_assoc_l | C_PLUS_PERMUTE => Tplus_permute - | C_PLUS_COMM => Tplus_sym + | C_PLUS_COMM => Tplus_comm | C_RED0 => Tred_factor0 | C_RED1 => Tred_factor1 | C_RED2 => Tred_factor2 @@ -1490,12 +2067,12 @@ Fixpoint rewrite (s : step) : term -> term := | C_RED6 => Tred_factor6 | C_MULT_ASSOC_REDUCED => Tmult_assoc_reduced | C_MINUS => Tminus_def - | C_MULT_COMM => Tmult_sym + | C_MULT_COMM => Tmult_comm end. Theorem rewrite_stable : forall s : step, term_stable (rewrite s). - -simple induction s; simpl in |- *; +Proof. + simple induction s; simpl in |- *; [ intros; apply apply_both_stable; auto | intros; apply apply_left_stable; auto | intros; apply apply_right_stable; auto @@ -1512,7 +2089,7 @@ simple induction s; simpl in |- *; | exact Tplus_assoc_r_stable | exact Tplus_assoc_l_stable | exact Tplus_permute_stable - | exact Tplus_sym_stable + | exact Tplus_comm_stable | exact Tred_factor0_stable | exact Tred_factor1_stable | exact Tred_factor2_stable @@ -1522,7 +2099,7 @@ simple induction s; simpl in |- *; | exact Tred_factor6_stable | exact Tmult_assoc_reduced_stable | exact Tminus_def_stable - | exact Tmult_sym_stable ]. + | exact Tmult_comm_stable ]. Qed. (* \subsection{tactiques de résolution d'un but omega normalisé} @@ -1532,20 +2109,18 @@ Qed. Definition constant_not_nul (i : nat) (h : hyps) := match nth_hyps i h with - | EqTerm (Tint Z0) (Tint n) => - match eq_Z n 0 with - | true => h - | false => absurd - end + | EqTerm (Tint Nul) (Tint n) => + if beq n Nul then h else absurd | _ => h end. Theorem constant_not_nul_valid : forall i : nat, valid_hyps (constant_not_nul i). - -unfold valid_hyps, constant_not_nul in |- *; intros; - generalize (nth_valid ep e i lp); Simplify; simpl in |- *; - elim_eq_Z ipattern:z0 0; auto; simpl in |- *; intros H1 H2; +Proof. + unfold valid_hyps, constant_not_nul in |- *; intros; + generalize (nth_valid ep e i lp); Simplify; simpl in |- *. + + elim_beq i1 i0; auto; simpl in |- *; intros H1 H2; elim H1; symmetry in |- *; auto. Qed. @@ -1553,66 +2128,55 @@ Qed. Definition constant_neg (i : nat) (h : hyps) := match nth_hyps i h with - | LeqTerm (Tint Z0) (Tint (Zneg n)) => absurd + | LeqTerm (Tint Nul) (Tint Neg) => + if bgt Nul Neg then absurd else h | _ => h end. Theorem constant_neg_valid : forall i : nat, valid_hyps (constant_neg i). - -unfold valid_hyps, constant_neg in |- *; intros; - generalize (nth_valid ep e i lp); Simplify; simpl in |- *; - unfold Zle in |- *; simpl in |- *; intros H1; elim H1; - [ assumption | trivial ]. -Qed. +Proof. + unfold valid_hyps, constant_neg in |- *; intros; + generalize (nth_valid ep e i lp); Simplify; simpl in |- *. + rewrite gt_lt_iff in H0; rewrite le_lt_iff; intuition. +Qed. (* \paragraph{[NOT_EXACT_DIVIDE]} *) -Definition not_exact_divide (k1 k2 : Z) (body : term) +Definition not_exact_divide (k1 k2 : int) (body : term) (t i : nat) (l : hyps) := match nth_hyps i l with - | EqTerm (Tint Z0) b => - match - eq_term (scalar_norm_add t (body * Tint k1 + Tint k2)%term) b - with - | true => - match k2 ?= 0 with - | Gt => - match k1 ?= k2 with - | Gt => absurd - | _ => l - end - | _ => l - end - | false => l - end + | EqTerm (Tint Nul) b => + if beq Nul 0 && + eq_term (scalar_norm_add t (body * Tint k1 + Tint k2)%term) b && + bgt k2 0 && + bgt k1 k2 + then absurd + else l | _ => l end. Theorem not_exact_divide_valid : - forall (k1 k2 : Z) (body : term) (t i : nat), + forall (k1 k2 : int) (body : term) (t i : nat), valid_hyps (not_exact_divide k1 k2 body t i). - -unfold valid_hyps, not_exact_divide in |- *; intros; - generalize (nth_valid ep e i lp); Simplify; - elim_eq_term (scalar_norm_add t (body * Tint k1 + Tint k2)%term) t1; - auto; Simplify; intro H2; elim H2; simpl in |- *; - elim (scalar_norm_add_stable t e); simpl in |- *; - intro H4; absurd (interp_term e body * k1 + k2 = 0); - [ apply OMEGA4; assumption | symmetry in |- *; auto ]. - +Proof. + unfold valid_hyps, not_exact_divide in |- *; intros; + generalize (nth_valid ep e i lp); Simplify. + rewrite (scalar_norm_add_stable t e), <-H1. + do 2 rewrite <- scalar_norm_add_stable; simpl in *; intros. + absurd (interp_term e body * k1 + k2 = 0); + [ now apply OMEGA4 | symmetry; auto ]. Qed. (* \paragraph{[O_CONTRADICTION]} *) Definition contradiction (t i j : nat) (l : hyps) := match nth_hyps i l with - | LeqTerm (Tint Z0) b1 => + | LeqTerm (Tint Nul) b1 => match nth_hyps j l with - | LeqTerm (Tint Z0) b2 => + | LeqTerm (Tint Nul') b2 => match fusion_cancel t (b1 + b2)%term with - | Tint k => match 0 ?= k with - | Gt => absurd - | _ => l - end + | Tint k => if beq Nul 0 && beq Nul' 0 && bgt 0 k + then absurd + else l | _ => l end | _ => l @@ -1622,43 +2186,40 @@ Definition contradiction (t i j : nat) (l : hyps) := Theorem contradiction_valid : forall t i j : nat, valid_hyps (contradiction t i j). - -unfold valid_hyps, contradiction in |- *; intros t i j ep e l H; +Proof. + unfold valid_hyps, contradiction in |- *; intros t i j ep e l H; generalize (nth_valid _ _ i _ H); generalize (nth_valid _ _ j _ H); case (nth_hyps i l); auto; intros t1 t2; case t1; - auto; intros z; case z; auto; case (nth_hyps j l); - auto; intros t3 t4; case t3; auto; intros z'; case z'; - auto; simpl in |- *; intros H1 H2; + auto; case (nth_hyps j l); + auto; intros t3 t4; case t3; auto; + simpl in |- *; intros z z' H1 H2; generalize (refl_equal (interp_term e (fusion_cancel t (t2 + t4)%term))); pattern (fusion_cancel t (t2 + t4)%term) at 2 3 in |- *; case (fusion_cancel t (t2 + t4)%term); simpl in |- *; - auto; intro k; elim (fusion_cancel_stable t); simpl in |- *; - intro E; generalize (OMEGA2 _ _ H2 H1); rewrite E; - case k; auto; unfold Zle in |- *; simpl in |- *; intros p H3; - elim H3; auto. - + auto; intro k; elim (fusion_cancel_stable t); simpl in |- *. + Simplify; intro H3. + generalize (OMEGA2 _ _ H2 H1); rewrite H3. + rewrite gt_lt_iff in H0; rewrite le_lt_iff; intuition. Qed. (* \paragraph{[O_NEGATE_CONTRADICT]} *) Definition negate_contradict (i1 i2 : nat) (h : hyps) := match nth_hyps i1 h with - | EqTerm (Tint Z0) b1 => + | EqTerm (Tint Nul) b1 => match nth_hyps i2 h with - | NeqTerm (Tint Z0) b2 => - match eq_term b1 b2 with - | true => absurd - | false => h - end + | NeqTerm (Tint Nul') b2 => + if beq Nul 0 && beq Nul' 0 && eq_term b1 b2 + then absurd + else h | _ => h end - | NeqTerm (Tint Z0) b1 => + | NeqTerm (Tint Nul) b1 => match nth_hyps i2 h with - | EqTerm (Tint Z0) b2 => - match eq_term b1 b2 with - | true => absurd - | false => h - end + | EqTerm (Tint Nul') b2 => + if beq Nul 0 && beq Nul' 0 && eq_term b1 b2 + then absurd + else h | _ => h end | _ => h @@ -1666,22 +2227,22 @@ Definition negate_contradict (i1 i2 : nat) (h : hyps) := Definition negate_contradict_inv (t i1 i2 : nat) (h : hyps) := match nth_hyps i1 h with - | EqTerm (Tint Z0) b1 => + | EqTerm (Tint Nul) b1 => match nth_hyps i2 h with - | NeqTerm (Tint Z0) b2 => - match eq_term b1 (scalar_norm t (b2 * Tint (-1))%term) with - | true => absurd - | false => h - end + | NeqTerm (Tint Nul') b2 => + if beq Nul 0 && beq Nul' 0 && + eq_term b1 (scalar_norm t (b2 * Tint (-(1)))%term) + then absurd + else h | _ => h end - | NeqTerm (Tint Z0) b1 => + | NeqTerm (Tint Nul) b1 => match nth_hyps i2 h with - | EqTerm (Tint Z0) b2 => - match eq_term b1 (scalar_norm t (b2 * Tint (-1))%term) with - | true => absurd - | false => h - end + | EqTerm (Tint Nul') b2 => + if beq Nul 0 && beq Nul' 0 && + eq_term b1 (scalar_norm t (b2 * Tint (-(1)))%term) + then absurd + else h | _ => h end | _ => h @@ -1689,45 +2250,33 @@ Definition negate_contradict_inv (t i1 i2 : nat) (h : hyps) := Theorem negate_contradict_valid : forall i j : nat, valid_hyps (negate_contradict i j). - -unfold valid_hyps, negate_contradict in |- *; intros i j ep e l H; +Proof. + unfold valid_hyps, negate_contradict in |- *; intros i j ep e l H; generalize (nth_valid _ _ i _ H); generalize (nth_valid _ _ j _ H); case (nth_hyps i l); auto; intros t1 t2; case t1; - auto; intros z; case z; auto; case (nth_hyps j l); - auto; intros t3 t4; case t3; auto; intros z'; case z'; - auto; simpl in |- *; intros H1 H2; - [ elim_eq_term t2 t4; intro H3; - [ elim H1; elim H3; assumption | assumption ] - | elim_eq_term t2 t4; intro H3; - [ elim H2; rewrite H3; assumption | assumption ] ]. - + auto; intros z; auto; case (nth_hyps j l); + auto; intros t3 t4; case t3; auto; intros z'; + auto; simpl in |- *; intros H1 H2; Simplify. Qed. Theorem negate_contradict_inv_valid : forall t i j : nat, valid_hyps (negate_contradict_inv t i j). - - -unfold valid_hyps, negate_contradict_inv in |- *; intros t i j ep e l H; +Proof. + unfold valid_hyps, negate_contradict_inv in |- *; intros t i j ep e l H; generalize (nth_valid _ _ i _ H); generalize (nth_valid _ _ j _ H); case (nth_hyps i l); auto; intros t1 t2; case t1; - auto; intros z; case z; auto; case (nth_hyps j l); - auto; intros t3 t4; case t3; auto; intros z'; case z'; - auto; simpl in |- *; intros H1 H2; - (pattern (eq_term t2 (scalar_norm t (t4 * Tint (-1))%term)) in |- *; - apply bool_ind2; intro Aux; - [ generalize (eq_term_true t2 (scalar_norm t (t4 * Tint (-1))%term) Aux); - clear Aux - | generalize (eq_term_false t2 (scalar_norm t (t4 * Tint (-1))%term) Aux); - clear Aux ]); - [ intro H3; elim H1; generalize H2; rewrite H3; - rewrite <- (scalar_norm_stable t e); simpl in |- *; - elim (interp_term e t4); simpl in |- *; auto; intros p H4; - discriminate H4 - | auto - | intro H3; elim H2; rewrite H3; elim (scalar_norm_stable t e); - simpl in |- *; elim H1; simpl in |- *; trivial - | auto ]. - + auto; intros z; auto; case (nth_hyps j l); + auto; intros t3 t4; case t3; auto; intros z'; + auto; simpl in |- *; intros H1 H2; Simplify; + [ + rewrite <- scalar_norm_stable in H2; simpl in *; + elim (mult_integral (interp_term e t4) (-(1))); intuition; + elim minus_one_neq_zero; auto + | + elim H2; clear H2; + rewrite <- scalar_norm_stable; simpl in *; + now rewrite <- H1, mult_0_l + ]. Qed. (* \subsubsection{Tactiques générant une nouvelle équation} *) @@ -1737,150 +2286,93 @@ Qed. preuve un peu compliquée. On utilise quelques lemmes qui sont des généralisations des théorèmes utilisés par OMEGA. *) -Definition sum (k1 k2 : Z) (trace : list t_fusion) +Definition sum (k1 k2 : int) (trace : list t_fusion) (prop1 prop2 : proposition) := match prop1 with - | EqTerm (Tint Z0) b1 => + | EqTerm (Tint Null) b1 => match prop2 with - | EqTerm (Tint Z0) b2 => - EqTerm (Tint 0) (fusion trace (b1 * Tint k1 + b2 * Tint k2)%term) - | LeqTerm (Tint Z0) b2 => - match k2 ?= 0 with - | Gt => - LeqTerm (Tint 0) + | EqTerm (Tint Null') b2 => + if beq Null 0 && beq Null' 0 + then EqTerm (Tint 0) (fusion trace (b1 * Tint k1 + b2 * Tint k2)%term) + else TrueTerm + | LeqTerm (Tint Null') b2 => + if beq Null 0 && beq Null' 0 && bgt k2 0 + then LeqTerm (Tint 0) (fusion trace (b1 * Tint k1 + b2 * Tint k2)%term) - | _ => TrueTerm - end + else TrueTerm | _ => TrueTerm end - | LeqTerm (Tint Z0) b1 => - match k1 ?= 0 with - | Gt => - match prop2 with - | EqTerm (Tint Z0) b2 => + | LeqTerm (Tint Null) b1 => + if beq Null 0 && bgt k1 0 + then match prop2 with + | EqTerm (Tint Null') b2 => + if beq Null' 0 then LeqTerm (Tint 0) (fusion trace (b1 * Tint k1 + b2 * Tint k2)%term) - | LeqTerm (Tint Z0) b2 => - match k2 ?= 0 with - | Gt => - LeqTerm (Tint 0) + else TrueTerm + | LeqTerm (Tint Null') b2 => + if beq Null' 0 && bgt k2 0 + then LeqTerm (Tint 0) (fusion trace (b1 * Tint k1 + b2 * Tint k2)%term) - | _ => TrueTerm - end + else TrueTerm | _ => TrueTerm end - | _ => TrueTerm - end - | NeqTerm (Tint Z0) b1 => + else TrueTerm + | NeqTerm (Tint Null) b1 => match prop2 with - | EqTerm (Tint Z0) b2 => - match eq_Z k1 0 with - | true => TrueTerm - | false => - NeqTerm (Tint 0) - (fusion trace (b1 * Tint k1 + b2 * Tint k2)%term) - end + | EqTerm (Tint Null') b2 => + if beq Null 0 && beq Null' 0 && (negb (beq k1 0)) + then NeqTerm (Tint 0) + (fusion trace (b1 * Tint k1 + b2 * Tint k2)%term) + else TrueTerm | _ => TrueTerm end | _ => TrueTerm end. -Theorem sum1 : forall a b c d : Z, 0 = a -> 0 = b -> 0 = a * c + b * d. - -intros; elim H; elim H0; simpl in |- *; auto. -Qed. - -Theorem sum2 : - forall a b c d : Z, 0 <= d -> 0 = a -> 0 <= b -> 0 <= a * c + b * d. - -intros; elim H0; simpl in |- *; generalize H H1; case b; case d; - unfold Zle in |- *; simpl in |- *; auto. -Qed. - -Theorem sum3 : - forall a b c d : Z, - 0 <= c -> 0 <= d -> 0 <= a -> 0 <= b -> 0 <= a * c + b * d. - -intros a b c d; case a; case b; case c; case d; unfold Zle in |- *; - simpl in |- *; auto. -Qed. - -Theorem sum4 : forall k : Z, (k ?= 0) = Gt -> 0 <= k. - -intro; case k; unfold Zle in |- *; simpl in |- *; auto; intros; discriminate. -Qed. - -Theorem sum5 : - forall a b c d : Z, c <> 0 -> 0 <> a -> 0 = b -> 0 <> a * c + b * d. - -intros a b c d H1 H2 H3; elim H3; simpl in |- *; rewrite Zplus_comm; - simpl in |- *; generalize H1 H2; case a; case c; simpl in |- *; - intros; try discriminate; assumption. -Qed. - Theorem sum_valid : - forall (k1 k2 : Z) (t : list t_fusion), valid2 (sum k1 k2 t). - -unfold valid2 in |- *; intros k1 k2 t ep e p1 p2; unfold sum in |- *; + forall (k1 k2 : int) (t : list t_fusion), valid2 (sum k1 k2 t). +Proof. + unfold valid2 in |- *; intros k1 k2 t ep e p1 p2; unfold sum in |- *; Simplify; simpl in |- *; auto; try elim (fusion_stable t); simpl in |- *; intros; [ apply sum1; assumption | apply sum2; try assumption; apply sum4; assumption - | rewrite Zplus_comm; apply sum2; try assumption; apply sum4; assumption + | rewrite plus_comm; apply sum2; try assumption; apply sum4; assumption | apply sum3; try assumption; apply sum4; assumption - | elim_eq_Z k1 0; simpl in |- *; auto; elim (fusion_stable t); simpl in |- *; - intros; unfold Zne in |- *; apply sum5; assumption ]. + | apply sum5; auto ]. Qed. (* \paragraph{[O_EXACT_DIVIDE]} c'est une oper1 valide mais on préfère une substitution a ce point la *) -Definition exact_divide (k : Z) (body : term) (t : nat) +Definition exact_divide (k : int) (body : term) (t : nat) (prop : proposition) := match prop with - | EqTerm (Tint Z0) b => - match eq_term (scalar_norm t (body * Tint k)%term) b with - | true => - match eq_Z k 0 with - | true => TrueTerm - | false => EqTerm (Tint 0) body - end - | false => TrueTerm - end - | NeqTerm (Tint Z0) b => - match eq_term (scalar_norm t (body * Tint k)%term) b with - | true => - match eq_Z k 0 with - | true => FalseTerm - | false => NeqTerm (Tint 0) body - end - | false => TrueTerm - end + | EqTerm (Tint Null) b => + if beq Null 0 && + eq_term (scalar_norm t (body * Tint k)%term) b && + negb (beq k 0) + then EqTerm (Tint 0) body + else TrueTerm + | NeqTerm (Tint Null) b => + if beq Null 0 && + eq_term (scalar_norm t (body * Tint k)%term) b && + negb (beq k 0) + then NeqTerm (Tint 0) body + else TrueTerm | _ => TrueTerm end. Theorem exact_divide_valid : - forall (k : Z) (t : term) (n : nat), valid1 (exact_divide k t n). - - -unfold valid1, exact_divide in |- *; intros k1 k2 t ep e p1; Simplify; - simpl in |- *; auto; elim_eq_term (scalar_norm t (k2 * Tint k1)%term) t1; - simpl in |- *; auto; elim_eq_Z k1 0; simpl in |- *; - auto; intros H1 H2; elim H2; elim scalar_norm_stable; - simpl in |- *; - [ - generalize H1; case (interp_term e k2); - try trivial; - (case k1; simpl in |- *; - [ intros; absurd (0 = 0); assumption - | intros p2 p3 H3 H4; discriminate H4 - | intros p2 p3 H3 H4; discriminate H4 ]) - | - subst k1; rewrite Zmult_comm; simpl in *; intros; absurd (0=0); trivial - | - generalize H1; case (interp_term e k2); - try trivial; intros p2 p3 H3 H4; discriminate H4 + forall (k : int) (t : term) (n : nat), valid1 (exact_divide k t n). +Proof. + unfold valid1, exact_divide in |- *; intros k1 k2 t ep e p1; + Simplify; simpl; auto; subst; + rewrite <- scalar_norm_stable; simpl; intros; + [ destruct (mult_integral _ _ (sym_eq H0)); intuition + | contradict H0; rewrite <- H0, mult_0_l; auto ]. Qed. @@ -1889,61 +2381,51 @@ Qed. La preuve reprend le schéma de la précédente mais on est sur une opération de type valid1 et non sur une opération terminale. *) -Definition divide_and_approx (k1 k2 : Z) (body : term) +Definition divide_and_approx (k1 k2 : int) (body : term) (t : nat) (prop : proposition) := match prop with - | LeqTerm (Tint Z0) b => - match - eq_term (scalar_norm_add t (body * Tint k1 + Tint k2)%term) b - with - | true => - match k1 ?= 0 with - | Gt => - match k1 ?= k2 with - | Gt => LeqTerm (Tint 0) body - | _ => prop - end - | _ => prop - end - | false => prop - end + | LeqTerm (Tint Null) b => + if beq Null 0 && + eq_term (scalar_norm_add t (body * Tint k1 + Tint k2)%term) b && + bgt k1 0 && + bgt k1 k2 + then LeqTerm (Tint 0) body + else prop | _ => prop end. Theorem divide_and_approx_valid : - forall (k1 k2 : Z) (body : term) (t : nat), + forall (k1 k2 : int) (body : term) (t : nat), valid1 (divide_and_approx k1 k2 body t). - -unfold valid1, divide_and_approx in |- *; intros k1 k2 body t ep e p1; - Simplify; - elim_eq_term (scalar_norm_add t (body * Tint k1 + Tint k2)%term) t1; - Simplify; auto; intro E; elim E; simpl in |- *; - elim (scalar_norm_add_stable t e); simpl in |- *; - intro H1; apply Zmult_le_approx with (3 := H1); assumption. +Proof. + unfold valid1, divide_and_approx in |- *; intros k1 k2 body t ep e p1; + Simplify; simpl; auto; subst; + elim (scalar_norm_add_stable t e); simpl in |- *. + intro H2; apply mult_le_approx with (3 := H2); assumption. Qed. (* \paragraph{[MERGE_EQ]} *) Definition merge_eq (t : nat) (prop1 prop2 : proposition) := match prop1 with - | LeqTerm (Tint Z0) b1 => + | LeqTerm (Tint Null) b1 => match prop2 with - | LeqTerm (Tint Z0) b2 => - match eq_term b1 (scalar_norm t (b2 * Tint (-1))%term) with - | true => EqTerm (Tint 0) b1 - | false => TrueTerm - end + | LeqTerm (Tint Null') b2 => + if beq Null 0 && beq Null' 0 && + eq_term b1 (scalar_norm t (b2 * Tint (-(1)))%term) + then EqTerm (Tint 0) b1 + else TrueTerm | _ => TrueTerm end | _ => TrueTerm end. Theorem merge_eq_valid : forall n : nat, valid2 (merge_eq n). - -unfold valid2, merge_eq in |- *; intros n ep e p1 p2; Simplify; simpl in |- *; +Proof. + unfold valid2, merge_eq in |- *; intros n ep e p1 p2; Simplify; simpl in |- *; auto; elim (scalar_norm_stable n e); simpl in |- *; intros; symmetry in |- *; apply OMEGA8 with (2 := H0); - [ assumption | elim Zopp_eq_mult_neg_1; trivial ]. + [ assumption | elim opp_eq_mult_neg_1; trivial ]. Qed. @@ -1952,36 +2434,39 @@ Qed. Definition constant_nul (i : nat) (h : hyps) := match nth_hyps i h with - | NeqTerm (Tint Z0) (Tint Z0) => absurd + | NeqTerm (Tint Null) (Tint Null') => + if beq Null Null' then absurd else h | _ => h end. Theorem constant_nul_valid : forall i : nat, valid_hyps (constant_nul i). - -unfold valid_hyps, constant_nul in |- *; intros; +Proof. + unfold valid_hyps, constant_nul in |- *; intros; generalize (nth_valid ep e i lp); Simplify; simpl in |- *; - unfold Zne in |- *; intro H1; absurd (0 = 0); auto. + intro H1; absurd (0 = 0); intuition. Qed. (* \paragraph{[O_STATE]} *) -Definition state (m : Z) (s : step) (prop1 prop2 : proposition) := +Definition state (m : int) (s : step) (prop1 prop2 : proposition) := match prop1 with - | EqTerm (Tint Z0) b1 => + | EqTerm (Tint Null) b1 => match prop2 with | EqTerm b2 b3 => - EqTerm (Tint 0) (rewrite s (b1 + (- b3 + b2) * Tint m)%term) + if beq Null 0 + then EqTerm (Tint 0) (rewrite s (b1 + (- b3 + b2) * Tint m)%term) + else TrueTerm | _ => TrueTerm end | _ => TrueTerm end. -Theorem state_valid : forall (m : Z) (s : step), valid2 (state m s). - -unfold valid2 in |- *; intros m s ep e p1 p2; unfold state in |- *; Simplify; +Theorem state_valid : forall (m : int) (s : step), valid2 (state m s). +Proof. + unfold valid2 in |- *; intros m s ep e p1 p2; unfold state in |- *; Simplify; simpl in |- *; auto; elim (rewrite_stable s e); simpl in |- *; intros H1 H2; elim H1. - rewrite H2; rewrite Zplus_opp_l; simpl; reflexivity. + now rewrite H2, plus_opp_l, plus_0_l, mult_0_l. Qed. (* \subsubsection{Tactiques générant plusieurs but} @@ -1991,11 +2476,13 @@ Qed. Definition split_ineq (i t : nat) (f1 f2 : hyps -> lhyps) (l : hyps) := match nth_hyps i l with - | NeqTerm (Tint Z0) b1 => - f1 (LeqTerm (Tint 0) (add_norm t (b1 + Tint (-1))%term) :: l) ++ + | NeqTerm (Tint Null) b1 => + if beq Null 0 then + f1 (LeqTerm (Tint 0) (add_norm t (b1 + Tint (-(1)))%term) :: l) ++ f2 (LeqTerm (Tint 0) - (scalar_norm_add t (b1 * Tint (-1) + Tint (-1))%term) :: l) + (scalar_norm_add t (b1 * Tint (-(1)) + Tint (-(1)))%term) :: l) + else l :: nil | _ => l :: nil end. @@ -2003,17 +2490,18 @@ Theorem split_ineq_valid : forall (i t : nat) (f1 f2 : hyps -> lhyps), valid_list_hyps f1 -> valid_list_hyps f2 -> valid_list_hyps (split_ineq i t f1 f2). - -unfold valid_list_hyps, split_ineq in |- *; intros i t f1 f2 H1 H2 ep e lp H; +Proof. + unfold valid_list_hyps, split_ineq in |- *; intros i t f1 f2 H1 H2 ep e lp H; generalize (nth_valid _ _ i _ H); case (nth_hyps i lp); simpl in |- *; auto; intros t1 t2; case t1; simpl in |- *; - auto; intros z; case z; simpl in |- *; auto; intro H3; + auto; intros z; simpl in |- *; auto; intro H3. + Simplify. apply append_valid; elim (OMEGA19 (interp_term e t2)); [ intro H4; left; apply H1; simpl in |- *; elim (add_norm_stable t); simpl in |- *; auto | intro H4; right; apply H2; simpl in |- *; elim (scalar_norm_add_stable t); simpl in |- *; auto - | generalize H3; unfold Zne, not in |- *; intros E1 E2; apply E1; + | generalize H3; unfold not in |- *; intros E1 E2; apply E1; symmetry in |- *; trivial ]. Qed. @@ -2046,8 +2534,8 @@ Fixpoint execute_omega (t : t_omega) (l : hyps) {struct t} : lhyps := end. Theorem omega_valid : forall t : t_omega, valid_list_hyps (execute_omega t). - -simple induction t; simpl in |- *; +Proof. + simple induction t; simpl in |- *; [ unfold valid_list_hyps in |- *; simpl in |- *; intros; left; apply (constant_not_nul_valid n ep e lp H) | unfold valid_list_hyps in |- *; simpl in |- *; intros; left; @@ -2058,7 +2546,7 @@ simple induction t; simpl in |- *; (apply_oper_1_valid m (divide_and_approx k1 k2 body n) (divide_and_approx_valid k1 k2 body n) ep e lp H) | unfold valid_list_hyps in |- *; simpl in |- *; intros; left; - apply (not_exact_divide_valid z z0 t0 n n0 ep e lp H) + apply (not_exact_divide_valid i i0 t0 n n0 ep e lp H) | unfold valid_list_hyps, valid_hyps in |- *; intros k body n t' Ht' m ep e lp H; apply Ht'; apply @@ -2101,36 +2589,30 @@ Definition move_right (s : step) (p : proposition) := | EqTerm t1 t2 => EqTerm (Tint 0) (rewrite s (t1 + - t2)%term) | LeqTerm t1 t2 => LeqTerm (Tint 0) (rewrite s (t2 + - t1)%term) | GeqTerm t1 t2 => LeqTerm (Tint 0) (rewrite s (t1 + - t2)%term) - | LtTerm t1 t2 => LeqTerm (Tint 0) (rewrite s (t2 + Tint (-1) + - t1)%term) - | GtTerm t1 t2 => LeqTerm (Tint 0) (rewrite s (t1 + Tint (-1) + - t2)%term) + | LtTerm t1 t2 => LeqTerm (Tint 0) (rewrite s (t2 + Tint (-(1)) + - t1)%term) + | GtTerm t1 t2 => LeqTerm (Tint 0) (rewrite s (t1 + Tint (-(1)) + - t2)%term) | NeqTerm t1 t2 => NeqTerm (Tint 0) (rewrite s (t1 + - t2)%term) | p => p end. -Theorem Zne_left_2 : forall x y : Z, Zne x y -> Zne 0 (x + - y). -unfold Zne, not in |- *; intros x y H1 H2; apply H1; - apply (Zplus_reg_l (- y)); rewrite Zplus_comm; elim H2; - rewrite Zplus_opp_l; trivial. -Qed. - Theorem move_right_valid : forall s : step, valid1 (move_right s). - -unfold valid1, move_right in |- *; intros s ep e p; Simplify; simpl in |- *; +Proof. + unfold valid1, move_right in |- *; intros s ep e p; Simplify; simpl in |- *; elim (rewrite_stable s e); simpl in |- *; - [ symmetry in |- *; apply Zegal_left; assumption - | intro; apply Zle_left; assumption - | intro; apply Zge_left; assumption - | intro; apply Zgt_left; assumption - | intro; apply Zlt_left; assumption - | intro; apply Zne_left_2; assumption ]. + [ symmetry in |- *; apply egal_left; assumption + | intro; apply le_left; assumption + | intro; apply le_left; rewrite <- ge_le_iff; assumption + | intro; apply lt_left; rewrite <- gt_lt_iff; assumption + | intro; apply lt_left; assumption + | intro; apply ne_left_2; assumption ]. Qed. Definition do_normalize (i : nat) (s : step) := apply_oper_1 i (move_right s). Theorem do_normalize_valid : forall (i : nat) (s : step), valid_hyps (do_normalize i s). - -intros; unfold do_normalize in |- *; apply apply_oper_1_valid; +Proof. + intros; unfold do_normalize in |- *; apply apply_oper_1_valid; apply move_right_valid. Qed. @@ -2143,43 +2625,40 @@ Fixpoint do_normalize_list (l : list step) (i : nat) Theorem do_normalize_list_valid : forall (l : list step) (i : nat), valid_hyps (do_normalize_list l i). - -simple induction l; simpl in |- *; unfold valid_hyps in |- *; +Proof. + simple induction l; simpl in |- *; unfold valid_hyps in |- *; [ auto | intros a l' Hl' i ep e lp H; unfold valid_hyps in Hl'; apply Hl'; apply (do_normalize_valid i a ep e lp); assumption ]. Qed. Theorem normalize_goal : - forall (s : list step) (ep : PropList) (env : list Z) (l : hyps), + forall (s : list step) (ep : list Prop) (env : list int) (l : hyps), interp_goal ep env (do_normalize_list s 0 l) -> interp_goal ep env l. - -intros; apply valid_goal with (2 := H); apply do_normalize_list_valid. +Proof. + intros; apply valid_goal with (2 := H); apply do_normalize_list_valid. Qed. (* \subsubsection{Exécution de la trace} *) Theorem execute_goal : - forall (t : t_omega) (ep : PropList) (env : list Z) (l : hyps), + forall (t : t_omega) (ep : list Prop) (env : list int) (l : hyps), interp_list_goal ep env (execute_omega t l) -> interp_goal ep env l. - -intros; apply (goal_valid (execute_omega t) (omega_valid t) ep env l H). +Proof. + intros; apply (goal_valid (execute_omega t) (omega_valid t) ep env l H). Qed. Theorem append_goal : - forall (ep : PropList) (e : list Z) (l1 l2 : lhyps), + forall (ep : list Prop) (e : list int) (l1 l2 : lhyps), interp_list_goal ep e l1 /\ interp_list_goal ep e l2 -> interp_list_goal ep e (l1 ++ l2). - -intros ep e; simple induction l1; +Proof. + intros ep e; simple induction l1; [ simpl in |- *; intros l2 (H1, H2); assumption | simpl in |- *; intros h1 t1 HR l2 ((H1, H2), H3); split; auto ]. - Qed. -Require Import Decidable. - (* A simple decidability checker : if the proposition belongs to the simple grammar describe below then it is decidable. Proof is by induction and uses well known theorem about arithmetic and propositional @@ -2203,30 +2682,29 @@ Fixpoint decidability (p : proposition) : bool := end. Theorem decidable_correct : - forall (ep : PropList) (e : list Z) (p : proposition), + forall (ep : list Prop) (e : list int) (p : proposition), decidability p = true -> decidable (interp_proposition ep e p). - -simple induction p; simpl in |- *; intros; +Proof. + simple induction p; simpl in |- *; intros; [ apply dec_eq - | apply dec_Zle + | apply dec_le | left; auto | right; unfold not in |- *; auto | apply dec_not; auto - | apply dec_Zge - | apply dec_Zgt - | apply dec_Zlt - | apply dec_Zne + | apply dec_ge + | apply dec_gt + | apply dec_lt + | apply dec_ne | apply dec_or; elim andb_prop with (1 := H1); auto | apply dec_and; elim andb_prop with (1 := H1); auto | apply dec_imp; elim andb_prop with (1 := H1); auto | discriminate H ]. - Qed. (* An interpretation function for a complete goal with an explicit conclusion. We use an intermediate fixpoint. *) -Fixpoint interp_full_goal (envp : PropList) (env : list Z) +Fixpoint interp_full_goal (envp : list Prop) (env : list int) (c : proposition) (l : hyps) {struct l} : Prop := match l with | nil => interp_proposition envp env c @@ -2234,7 +2712,7 @@ Fixpoint interp_full_goal (envp : PropList) (env : list Z) interp_proposition envp env p' -> interp_full_goal envp env c l' end. -Definition interp_full (ep : PropList) (e : list Z) +Definition interp_full (ep : list Prop) (e : list int) (lc : hyps * proposition) : Prop := match lc with | (l, c) => interp_full_goal ep e c l @@ -2244,12 +2722,11 @@ Definition interp_full (ep : PropList) (e : list Z) of its hypothesis and conclusion *) Theorem interp_full_false : - forall (ep : PropList) (e : list Z) (l : hyps) (c : proposition), + forall (ep : list Prop) (e : list int) (l : hyps) (c : proposition), (interp_hyps ep e l -> interp_proposition ep e c) -> interp_full ep e (l, c). - -simple induction l; unfold interp_full in |- *; simpl in |- *; +Proof. + simple induction l; unfold interp_full in |- *; simpl in |- *; [ auto | intros a l1 H1 c H2 H3; apply H1; auto ]. - Qed. (* Push the conclusion in the list of hypothesis using a double negation @@ -2265,11 +2742,11 @@ Definition to_contradict (lc : hyps * proposition) := hypothesis implies the original goal *) Theorem to_contradict_valid : - forall (ep : PropList) (e : list Z) (lc : hyps * proposition), + forall (ep : list Prop) (e : list int) (lc : hyps * proposition), interp_goal ep e (to_contradict lc) -> interp_full ep e lc. - -intros ep e lc; case lc; intros l c; simpl in |- *; - pattern (decidability c) in |- *; apply bool_ind2; +Proof. + intros ep e lc; case lc; intros l c; simpl in |- *; + pattern (decidability c) in |- *; apply bool_eq_ind; [ simpl in |- *; intros H H1; apply interp_full_false; intros H2; apply not_not; [ apply decidable_correct; assumption @@ -2333,19 +2810,19 @@ Fixpoint destructure_hyps (nn : nat) (ll : hyps) {struct nn} : lhyps := end. Theorem map_cons_val : - forall (ep : PropList) (e : list Z) (p : proposition) (l : lhyps), + forall (ep : list Prop) (e : list int) (p : proposition) (l : lhyps), interp_proposition ep e p -> interp_list_hyps ep e l -> interp_list_hyps ep e (map_cons _ p l). - -simple induction l; simpl in |- *; [ auto | intros; elim H1; intro H2; auto ]. +Proof. + simple induction l; simpl in |- *; [ auto | intros; elim H1; intro H2; auto ]. Qed. Hint Resolve map_cons_val append_valid decidable_correct. Theorem destructure_hyps_valid : forall n : nat, valid_list_hyps (destructure_hyps n). - -simple induction n; +Proof. + simple induction n; [ unfold valid_list_hyps in |- *; simpl in |- *; auto | unfold valid_list_hyps at 2 in |- *; intros n1 H ep e lp; case lp; [ simpl in |- *; auto @@ -2358,7 +2835,7 @@ simple induction n; (simpl in |- *; intros; apply map_cons_val; simpl in |- *; elim H0; auto); [ simpl in |- *; intros p1 (H1, H2); - pattern (decidability p1) in |- *; apply bool_ind2; + pattern (decidability p1) in |- *; apply bool_eq_ind; intro H3; [ apply H; simpl in |- *; split; [ apply not_not; auto | assumption ] @@ -2366,7 +2843,7 @@ simple induction n; | simpl in |- *; intros p1 p2 (H1, H2); apply H; simpl in |- *; elim not_or with (1 := H1); auto | simpl in |- *; intros p1 p2 (H1, H2); - pattern (decidability p1) in |- *; apply bool_ind2; + pattern (decidability p1) in |- *; apply bool_eq_ind; intro H3; [ apply append_valid; elim not_and with (2 := H1); [ intro; left; apply H; simpl in |- *; auto @@ -2378,18 +2855,17 @@ simple induction n; apply H; simpl in |- *; auto | simpl in |- *; intros; apply H; simpl in |- *; tauto | simpl in |- *; intros p1 p2 (H1, H2); - pattern (decidability p1) in |- *; apply bool_ind2; + pattern (decidability p1) in |- *; apply bool_eq_ind; intro H3; [ apply append_valid; elim imp_simp with (2 := H1); [ intro H4; left; simpl in |- *; apply H; simpl in |- *; auto | intro H4; right; simpl in |- *; apply H; simpl in |- *; auto | auto ] | auto ] ] ] ]. - Qed. Definition prop_stable (f : proposition -> proposition) := - forall (ep : PropList) (e : list Z) (p : proposition), + forall (ep : list Prop) (e : list int) (p : proposition), interp_proposition ep e p <-> interp_proposition ep e (f p). Definition p_apply_left (f : proposition -> proposition) @@ -2405,8 +2881,8 @@ Definition p_apply_left (f : proposition -> proposition) Theorem p_apply_left_stable : forall f : proposition -> proposition, prop_stable f -> prop_stable (p_apply_left f). - -unfold prop_stable in |- *; intros f H ep e p; split; +Proof. + unfold prop_stable in |- *; intros f H ep e p; split; (case p; simpl in |- *; auto; intros p1; elim (H ep e p1); tauto). Qed. @@ -2423,8 +2899,8 @@ Definition p_apply_right (f : proposition -> proposition) Theorem p_apply_right_stable : forall f : proposition -> proposition, prop_stable f -> prop_stable (p_apply_right f). - -unfold prop_stable in |- *; intros f H ep e p; split; +Proof. + unfold prop_stable in |- *; intros f H ep e p; split; (case p; simpl in |- *; auto; [ intros p1; elim (H ep e p1); tauto | intros p1 p2; elim (H ep e p2); tauto @@ -2447,67 +2923,55 @@ Definition p_invert (f : proposition -> proposition) Theorem p_invert_stable : forall f : proposition -> proposition, prop_stable f -> prop_stable (p_invert f). - -unfold prop_stable in |- *; intros f H ep e p; split; +Proof. + unfold prop_stable in |- *; intros f H ep e p; split; (case p; simpl in |- *; auto; [ intros t1 t2; elim (H ep e (NeqTerm t1 t2)); simpl in |- *; - unfold Zne in |- *; generalize (dec_eq (interp_term e t1) (interp_term e t2)); unfold decidable in |- *; tauto | intros t1 t2; elim (H ep e (GtTerm t1 t2)); simpl in |- *; - unfold Zgt in |- *; - generalize (dec_Zgt (interp_term e t1) (interp_term e t2)); - unfold decidable, Zgt, Zle in |- *; tauto + generalize (dec_gt (interp_term e t1) (interp_term e t2)); + unfold decidable in |- *; rewrite le_lt_iff, <- gt_lt_iff; tauto | intros t1 t2; elim (H ep e (LtTerm t1 t2)); simpl in |- *; - unfold Zlt in |- *; - generalize (dec_Zlt (interp_term e t1) (interp_term e t2)); - unfold decidable, Zge in |- *; tauto + generalize (dec_lt (interp_term e t1) (interp_term e t2)); + unfold decidable in |- *; rewrite ge_le_iff, le_lt_iff; tauto | intros t1 t2; elim (H ep e (LeqTerm t1 t2)); simpl in |- *; - generalize (dec_Zgt (interp_term e t1) (interp_term e t2)); - unfold Zle, Zgt in |- *; unfold decidable in |- *; - tauto + generalize (dec_gt (interp_term e t1) (interp_term e t2)); + unfold decidable in |- *; repeat rewrite le_lt_iff; + repeat rewrite gt_lt_iff; tauto | intros t1 t2; elim (H ep e (GeqTerm t1 t2)); simpl in |- *; - generalize (dec_Zlt (interp_term e t1) (interp_term e t2)); - unfold Zge, Zlt in |- *; unfold decidable in |- *; - tauto + generalize (dec_lt (interp_term e t1) (interp_term e t2)); + unfold decidable in |- *; repeat rewrite ge_le_iff; + repeat rewrite le_lt_iff; tauto | intros t1 t2; elim (H ep e (EqTerm t1 t2)); simpl in |- *; generalize (dec_eq (interp_term e t1) (interp_term e t2)); - unfold decidable, Zne in |- *; tauto ]). -Qed. - -Theorem Zlt_left_inv : forall x y : Z, 0 <= y + -1 + - x -> x < y. - -intros; apply Zsucc_lt_reg; apply Zle_lt_succ; - apply (fun a b : Z => Zplus_le_reg_r a b (-1 + - x)); - rewrite Zplus_assoc; unfold Zsucc in |- *; rewrite (Zplus_assoc_reverse x); - rewrite (Zplus_assoc y); simpl in |- *; rewrite Zplus_0_r; - rewrite Zplus_opp_r; assumption. + unfold decidable; tauto ]). Qed. Theorem move_right_stable : forall s : step, prop_stable (move_right s). - -unfold move_right, prop_stable in |- *; intros s ep e p; split; +Proof. + unfold move_right, prop_stable in |- *; intros s ep e p; split; [ Simplify; simpl in |- *; elim (rewrite_stable s e); simpl in |- *; - [ symmetry in |- *; apply Zegal_left; assumption - | intro; apply Zle_left; assumption - | intro; apply Zge_left; assumption - | intro; apply Zgt_left; assumption - | intro; apply Zlt_left; assumption - | intro; apply Zne_left_2; assumption ] + [ symmetry in |- *; apply egal_left; assumption + | intro; apply le_left; assumption + | intro; apply le_left; rewrite <- ge_le_iff; assumption + | intro; apply lt_left; rewrite <- gt_lt_iff; assumption + | intro; apply lt_left; assumption + | intro; apply ne_left_2; assumption ] | case p; simpl in |- *; intros; auto; generalize H; elim (rewrite_stable s); simpl in |- *; intro H1; - [ rewrite (Zplus_0_r_reverse (interp_term e t0)); rewrite H1; - rewrite Zplus_permute; rewrite Zplus_opp_r; - rewrite Zplus_0_r; trivial - | apply (fun a b : Z => Zplus_le_reg_r a b (- interp_term e t)); - rewrite Zplus_opp_r; assumption - | apply Zle_ge; - apply (fun a b : Z => Zplus_le_reg_r a b (- interp_term e t0)); - rewrite Zplus_opp_r; assumption - | apply Zlt_gt; apply Zlt_left_inv; assumption - | apply Zlt_left_inv; assumption - | unfold Zne, not in |- *; unfold Zne in H1; intro H2; apply H1; - rewrite H2; rewrite Zplus_opp_r; trivial ] ]. + [ rewrite (plus_0_r_reverse (interp_term e t0)); rewrite H1; + rewrite plus_permute; rewrite plus_opp_r; + rewrite plus_0_r; trivial + | apply (fun a b => plus_le_reg_r a b (- interp_term e t)); + rewrite plus_opp_r; assumption + | rewrite ge_le_iff; + apply (fun a b => plus_le_reg_r a b (- interp_term e t0)); + rewrite plus_opp_r; assumption + | rewrite gt_lt_iff; apply lt_left_inv; assumption + | apply lt_left_inv; assumption + | unfold not in |- *; intro H2; apply H1; + rewrite H2; rewrite plus_opp_r; trivial ] ]. Qed. @@ -2521,9 +2985,8 @@ Fixpoint p_rewrite (s : p_step) : proposition -> proposition := end. Theorem p_rewrite_stable : forall s : p_step, prop_stable (p_rewrite s). - - -simple induction s; simpl in |- *; +Proof. + simple induction s; simpl in |- *; [ intros; apply p_apply_left_stable; trivial | intros; apply p_apply_right_stable; trivial | intros; apply p_invert_stable; apply move_right_stable @@ -2539,8 +3002,8 @@ Fixpoint normalize_hyps (l : list h_step) (lh : hyps) {struct l} : hyps := Theorem normalize_hyps_valid : forall l : list h_step, valid_hyps (normalize_hyps l). - -simple induction l; unfold valid_hyps in |- *; simpl in |- *; +Proof. + simple induction l; unfold valid_hyps in |- *; simpl in |- *; [ auto | intros n_s r; case n_s; intros n s H ep e lp H1; apply H; apply apply_oper_1_valid; @@ -2550,10 +3013,10 @@ simple induction l; unfold valid_hyps in |- *; simpl in |- *; Qed. Theorem normalize_hyps_goal : - forall (s : list h_step) (ep : PropList) (env : list Z) (l : hyps), + forall (s : list h_step) (ep : list Prop) (env : list int) (l : hyps), interp_goal ep env (normalize_hyps s l) -> interp_goal ep env l. - -intros; apply valid_goal with (2 := H); apply normalize_hyps_valid. +Proof. + intros; apply valid_goal with (2 := H); apply normalize_hyps_valid. Qed. Fixpoint extract_hyp_pos (s : list direction) (p : proposition) {struct s} : @@ -2604,18 +3067,18 @@ Fixpoint extract_hyp_pos (s : list direction) (p : proposition) {struct s} : end. Definition co_valid1 (f : proposition -> proposition) := - forall (ep : PropList) (e : list Z) (p1 : proposition), + forall (ep : list Prop) (e : list int) (p1 : proposition), interp_proposition ep e (Tnot p1) -> interp_proposition ep e (f p1). Theorem extract_valid : forall s : list direction, valid1 (extract_hyp_pos s) /\ co_valid1 (extract_hyp_neg s). - -unfold valid1, co_valid1 in |- *; simple induction s; +Proof. + unfold valid1, co_valid1 in |- *; simple induction s; [ split; [ simpl in |- *; auto | intros ep e p1; case p1; simpl in |- *; auto; intro p; - pattern (decidability p) in |- *; apply bool_ind2; + pattern (decidability p) in |- *; apply bool_eq_ind; [ intro H; generalize (decidable_correct ep e p H); unfold decidable in |- *; tauto | simpl in |- *; auto ] ] @@ -2623,12 +3086,11 @@ unfold valid1, co_valid1 in |- *; simple induction s; case p; auto; simpl in |- *; intros; (apply H1; tauto) || (apply H2; tauto) || - (pattern (decidability p0) in |- *; apply bool_ind2; + (pattern (decidability p0) in |- *; apply bool_eq_ind; [ intro H3; generalize (decidable_correct ep e p0 H3); unfold decidable in |- *; intro H4; apply H1; tauto | intro; tauto ]) ]. - Qed. Fixpoint decompose_solve (s : e_step) (h : hyps) {struct s} : lhyps := @@ -2655,13 +3117,13 @@ Fixpoint decompose_solve (s : e_step) (h : hyps) {struct s} : lhyps := Theorem decompose_solve_valid : forall s : e_step, valid_list_goal (decompose_solve s). - -intro s; apply goal_valid; unfold valid_list_hyps in |- *; elim s; +Proof. + intro s; apply goal_valid; unfold valid_list_hyps in |- *; elim s; simpl in |- *; intros; [ cut (interp_proposition ep e1 (extract_hyp_pos l (nth_hyps n lp))); [ case (extract_hyp_pos l (nth_hyps n lp)); simpl in |- *; auto; [ intro p; case p; simpl in |- *; auto; intros p1 p2 H2; - pattern (decidability p1) in |- *; apply bool_ind2; + pattern (decidability p1) in |- *; apply bool_eq_ind; [ intro H3; generalize (decidable_correct ep e1 p1 H3); intro H4; apply append_valid; elim H4; intro H5; [ right; apply H0; simpl in |- *; tauto @@ -2671,7 +3133,7 @@ intro s; apply goal_valid; unfold valid_list_hyps in |- *; elim s; [ intros H3; left; apply H; simpl in |- *; auto | intros H3; right; apply H0; simpl in |- *; auto ] | intros p1 p2 H2; - pattern (decidability p1) in |- *; apply bool_ind2; + pattern (decidability p1) in |- *; apply bool_eq_ind; [ intro H3; generalize (decidable_correct ep e1 p1 H3); intro H4; apply append_valid; elim H4; intro H5; [ right; apply H0; simpl in |- *; tauto @@ -2687,7 +3149,7 @@ Qed. (* \subsection{La dernière étape qui élimine tous les séquents inutiles} *) Definition valid_lhyps (f : lhyps -> lhyps) := - forall (ep : PropList) (e : list Z) (lp : lhyps), + forall (ep : list Prop) (e : list int) (lp : lhyps), interp_list_hyps ep e lp -> interp_list_hyps ep e (f lp). Fixpoint reduce_lhyps (lp : lhyps) : lhyps := @@ -2698,8 +3160,8 @@ Fixpoint reduce_lhyps (lp : lhyps) : lhyps := end. Theorem reduce_lhyps_valid : valid_lhyps reduce_lhyps. - -unfold valid_lhyps in |- *; intros ep e lp; elim lp; +Proof. + unfold valid_lhyps in |- *; intros ep e lp; elim lp; [ simpl in |- *; auto | intros a l HR; elim a; [ simpl in |- *; tauto @@ -2707,10 +3169,10 @@ unfold valid_lhyps in |- *; intros ep e lp; elim lp; Qed. Theorem do_reduce_lhyps : - forall (envp : PropList) (env : list Z) (l : lhyps), + forall (envp : list Prop) (env : list int) (l : lhyps), interp_list_goal envp env (reduce_lhyps l) -> interp_list_goal envp env l. - -intros envp env l H; apply list_goal_to_hyps; intro H1; +Proof. + intros envp env l H; apply list_goal_to_hyps; intro H1; apply list_hyps_to_goal with (1 := H); apply reduce_lhyps_valid; assumption. Qed. @@ -2719,13 +3181,13 @@ Definition concl_to_hyp (p : proposition) := if decidability p then Tnot p else TrueTerm. Definition do_concl_to_hyp : - forall (envp : PropList) (env : list Z) (c : proposition) (l : hyps), + forall (envp : list Prop) (env : list int) (c : proposition) (l : hyps), interp_goal envp env (concl_to_hyp c :: l) -> interp_goal_concl c envp env l. - -simpl in |- *; intros envp env c l; induction l as [| a l Hrecl]; +Proof. + simpl in |- *; intros envp env c l; induction l as [| a l Hrecl]; [ simpl in |- *; unfold concl_to_hyp in |- *; - pattern (decidability c) in |- *; apply bool_ind2; + pattern (decidability c) in |- *; apply bool_eq_ind; [ intro H; generalize (decidable_correct envp env c H); unfold decidable in |- *; simpl in |- *; tauto | simpl in |- *; intros H1 H2; elim H2; trivial ] @@ -2737,12 +3199,19 @@ Definition omega_tactic (t1 : e_step) (t2 : list h_step) reduce_lhyps (decompose_solve t1 (normalize_hyps t2 (concl_to_hyp c :: l))). Theorem do_omega : - forall (t1 : e_step) (t2 : list h_step) (envp : PropList) - (env : list Z) (c : proposition) (l : hyps), + forall (t1 : e_step) (t2 : list h_step) (envp : list Prop) + (env : list int) (c : proposition) (l : hyps), interp_list_goal envp env (omega_tactic t1 t2 c l) -> interp_goal_concl c envp env l. - -unfold omega_tactic in |- *; intros; apply do_concl_to_hyp; +Proof. + unfold omega_tactic in |- *; intros; apply do_concl_to_hyp; apply (normalize_hyps_goal t2); apply (decompose_solve_valid t1); apply do_reduce_lhyps; assumption. Qed. + +End IntOmega. + +(* For now, the above modular construction is instanciated on Z, + in order to retrieve the initial ROmega. *) + +Module ZOmega := IntOmega(Z_as_Int). diff --git a/contrib/romega/const_omega.ml b/contrib/romega/const_omega.ml index 69b4b2de..bdec6bf4 100644 --- a/contrib/romega/const_omega.ml +++ b/contrib/romega/const_omega.ml @@ -48,64 +48,16 @@ let dest_const_apply t = | _ -> raise Destruct in Nametab.id_of_global ref, args -let recognize_number t = - let rec loop t = - let f,l = dest_const_apply t in - match Names.string_of_id f,l with - "xI",[t] -> Bigint.add Bigint.one (Bigint.mult Bigint.two (loop t)) - | "xO",[t] -> Bigint.mult Bigint.two (loop t) - | "xH",[] -> Bigint.one - | _ -> failwith "not a number" in - let f,l = dest_const_apply t in - match Names.string_of_id f,l with - "Zpos",[t] -> loop t - | "Zneg",[t] -> Bigint.neg (loop t) - | "Z0",[] -> Bigint.zero - | _ -> failwith "not a number";; - - let logic_dir = ["Coq";"Logic";"Decidable"] let coq_modules = Coqlib.init_modules @ [logic_dir] @ Coqlib.arith_modules @ Coqlib.zarith_base_modules - @ [["Coq"; "omega"; "OmegaLemmas"]] @ [["Coq"; "Lists"; "List"]] @ [module_refl_path] - + @ [module_refl_path@["ZOmega"]] let constant = Coqlib.gen_constant_in_modules "Omega" coq_modules -let coq_xH = lazy (constant "xH") -let coq_xO = lazy (constant "xO") -let coq_xI = lazy (constant "xI") -let coq_Z0 = lazy (constant "Z0") -let coq_Zpos = lazy (constant "Zpos") -let coq_Zneg = lazy (constant "Zneg") -let coq_Z = lazy (constant "Z") -let coq_comparison = lazy (constant "comparison") -let coq_Gt = lazy (constant "Gt") -let coq_Lt = lazy (constant "Lt") -let coq_Eq = lazy (constant "Eq") -let coq_Zplus = lazy (constant "Zplus") -let coq_Zmult = lazy (constant "Zmult") -let coq_Zopp = lazy (constant "Zopp") - -let coq_Zminus = lazy (constant "Zminus") -let coq_Zsucc = lazy (constant "Zsucc") -let coq_Zgt = lazy (constant "Zgt") -let coq_Zle = lazy (constant "Zle") -let coq_Z_of_nat = lazy (constant "Z_of_nat") - -(* Peano *) -let coq_le = lazy(constant "le") -let coq_gt = lazy(constant "gt") - -(* Integers *) -let coq_nat = lazy(constant "nat") -let coq_S = lazy(constant "S") -let coq_O = lazy(constant "O") -let coq_minus = lazy(constant "minus") - (* Logic *) let coq_eq = lazy(constant "eq") let coq_refl_equal = lazy(constant "refl_equal") @@ -114,15 +66,9 @@ let coq_not = lazy(constant "not") let coq_or = lazy(constant "or") let coq_True = lazy(constant "True") let coq_False = lazy(constant "False") -let coq_ex = lazy(constant "ex") let coq_I = lazy(constant "I") -(* Lists *) -let coq_cons = lazy (constant "cons") -let coq_nil = lazy (constant "nil") - -let coq_pcons = lazy (constant "Pcons") -let coq_pnil = lazy (constant "Pnil") +(* ReflOmegaCore/ZOmega *) let coq_h_step = lazy (constant "h_step") let coq_pair_step = lazy (constant "pair_step") @@ -130,8 +76,6 @@ let coq_p_left = lazy (constant "P_LEFT") let coq_p_right = lazy (constant "P_RIGHT") let coq_p_invert = lazy (constant "P_INVERT") let coq_p_step = lazy (constant "P_STEP") -let coq_p_nop = lazy (constant "P_NOP") - let coq_t_int = lazy (constant "Tint") let coq_t_plus = lazy (constant "Tplus") @@ -140,6 +84,7 @@ let coq_t_opp = lazy (constant "Topp") let coq_t_minus = lazy (constant "Tminus") let coq_t_var = lazy (constant "Tvar") +let coq_proposition = lazy (constant "proposition") let coq_p_eq = lazy (constant "EqTerm") let coq_p_leq = lazy (constant "LeqTerm") let coq_p_geq = lazy (constant "GeqTerm") @@ -154,14 +99,6 @@ let coq_p_and = lazy (constant "Tand") let coq_p_imp = lazy (constant "Timp") let coq_p_prop = lazy (constant "Tprop") -let coq_proposition = lazy (constant "proposition") -let coq_interp_sequent = lazy (constant "interp_goal_concl") -let coq_normalize_sequent = lazy (constant "normalize_goal") -let coq_execute_sequent = lazy (constant "execute_goal") -let coq_do_concl_to_hyp = lazy (constant "do_concl_to_hyp") -let coq_sequent_to_hyps = lazy (constant "goal_to_hyps") -let coq_normalize_hyps_goal = lazy (constant "normalize_hyps_goal") - (* Constructors for shuffle tactic *) let coq_t_fusion = lazy (constant "t_fusion") let coq_f_equal = lazy (constant "F_equal") @@ -170,7 +107,6 @@ let coq_f_left = lazy (constant "F_left") let coq_f_right = lazy (constant "F_right") (* Constructors for reordering tactics *) -let coq_step = lazy (constant "step") let coq_c_do_both = lazy (constant "C_DO_BOTH") let coq_c_do_left = lazy (constant "C_LEFT") let coq_c_do_right = lazy (constant "C_RIGHT") @@ -196,8 +132,7 @@ let coq_c_red4 = lazy (constant "C_RED4") let coq_c_red5 = lazy (constant "C_RED5") let coq_c_red6 = lazy (constant "C_RED6") let coq_c_mult_opp_left = lazy (constant "C_MULT_OPP_LEFT") -let coq_c_mult_assoc_reduced = - lazy (constant "C_MULT_ASSOC_REDUCED") +let coq_c_mult_assoc_reduced = lazy (constant "C_MULT_ASSOC_REDUCED") let coq_c_minus = lazy (constant "C_MINUS") let coq_c_mult_comm = lazy (constant "C_MULT_COMM") @@ -225,30 +160,11 @@ let coq_e_split = lazy (constant "E_SPLIT") let coq_e_extract = lazy (constant "E_EXTRACT") let coq_e_solve = lazy (constant "E_SOLVE") -let coq_decompose_solve_valid = - lazy (constant "decompose_solve_valid") -let coq_do_reduce_lhyps = lazy (constant "do_reduce_lhyps") +let coq_interp_sequent = lazy (constant "interp_goal_concl") let coq_do_omega = lazy (constant "do_omega") (* \subsection{Construction d'expressions} *) - -let mk_var v = Term.mkVar (Names.id_of_string v) -let mk_plus t1 t2 = Term.mkApp (Lazy.force coq_Zplus,[| t1; t2 |]) -let mk_times t1 t2 = Term.mkApp (Lazy.force coq_Zmult, [| t1; t2 |]) -let mk_minus t1 t2 = Term.mkApp (Lazy.force coq_Zminus, [| t1;t2 |]) -let mk_eq t1 t2 = Term.mkApp (Lazy.force coq_eq, [| Lazy.force coq_Z; t1; t2 |]) -let mk_le t1 t2 = Term.mkApp (Lazy.force coq_Zle, [|t1; t2 |]) -let mk_gt t1 t2 = Term.mkApp (Lazy.force coq_Zgt, [|t1; t2 |]) -let mk_inv t = Term.mkApp (Lazy.force coq_Zopp, [|t |]) -let mk_and t1 t2 = Term.mkApp (Lazy.force coq_and, [|t1; t2 |]) -let mk_or t1 t2 = Term.mkApp (Lazy.force coq_or, [|t1; t2 |]) -let mk_not t = Term.mkApp (Lazy.force coq_not, [|t |]) -let mk_eq_rel t1 t2 = Term.mkApp (Lazy.force coq_eq, [| - Lazy.force coq_comparison; t1; t2 |]) -let mk_inj t = Term.mkApp (Lazy.force coq_Z_of_nat, [|t |]) - - let do_left t = if t = Lazy.force coq_c_nop then Lazy.force coq_c_nop else Term.mkApp (Lazy.force coq_c_do_left, [|t |] ) @@ -272,27 +188,20 @@ let rec do_list = function | [x] -> x | (x::l) -> do_seq x (do_list l) -let mk_integer n = - let rec loop n = - if n=Bigint.one then Lazy.force coq_xH else - let (q,r) = Bigint.euclid n Bigint.two in - Term.mkApp - ((if r = Bigint.zero then Lazy.force coq_xO else Lazy.force coq_xI), - [| loop q |]) in - - if n = Bigint.zero then Lazy.force coq_Z0 - else - if Bigint.is_strictly_pos n then - Term.mkApp (Lazy.force coq_Zpos, [| loop n |]) - else - Term.mkApp (Lazy.force coq_Zneg, [| loop (Bigint.neg n) |]) +(* Nat *) -let mk_Z = mk_integer +let coq_S = lazy(constant "S") +let coq_O = lazy(constant "O") let rec mk_nat = function | 0 -> Lazy.force coq_O | n -> Term.mkApp (Lazy.force coq_S, [| mk_nat (n-1) |]) +(* Lists *) + +let coq_cons = lazy (constant "cons") +let coq_nil = lazy (constant "nil") + let mk_list typ l = let rec loop = function | [] -> @@ -301,14 +210,141 @@ let mk_list typ l = Term.mkApp (Lazy.force coq_cons, [|typ; step; loop l |]) in loop l -let mk_plist l = - let rec loop = function - | [] -> - (Lazy.force coq_pnil) - | (step :: l) -> - Term.mkApp (Lazy.force coq_pcons, [| step; loop l |]) in - loop l - +let mk_plist l = mk_list Term.mkProp l let mk_shuffle_list l = mk_list (Lazy.force coq_t_fusion) l + +type parse_term = + | Tplus of Term.constr * Term.constr + | Tmult of Term.constr * Term.constr + | Tminus of Term.constr * Term.constr + | Topp of Term.constr + | Tsucc of Term.constr + | Tnum of Bigint.bigint + | Tother + +type parse_rel = + | Req of Term.constr * Term.constr + | Rne of Term.constr * Term.constr + | Rlt of Term.constr * Term.constr + | Rle of Term.constr * Term.constr + | Rgt of Term.constr * Term.constr + | Rge of Term.constr * Term.constr + | Rtrue + | Rfalse + | Rnot of Term.constr + | Ror of Term.constr * Term.constr + | Rand of Term.constr * Term.constr + | Rimp of Term.constr * Term.constr + | Riff of Term.constr * Term.constr + | Rother + +let parse_logic_rel c = + try match destructurate c with + | Kapp("True",[]) -> Rtrue + | Kapp("False",[]) -> Rfalse + | Kapp("not",[t]) -> Rnot t + | Kapp("or",[t1;t2]) -> Ror (t1,t2) + | Kapp("and",[t1;t2]) -> Rand (t1,t2) + | Kimp(t1,t2) -> Rimp (t1,t2) + | Kapp("iff",[t1;t2]) -> Riff (t1,t2) + | _ -> Rother + with e when Logic.catchable_exception e -> Rother + + +module type Int = sig + val typ : Term.constr Lazy.t + val plus : Term.constr Lazy.t + val mult : Term.constr Lazy.t + val opp : Term.constr Lazy.t + val minus : Term.constr Lazy.t + + val mk : Bigint.bigint -> Term.constr + val parse_term : Term.constr -> parse_term + val parse_rel : Proof_type.goal Tacmach.sigma -> Term.constr -> parse_rel + (* check whether t is built only with numbers and + * - *) + val is_scalar : Term.constr -> bool +end + +module Z : Int = struct + +let typ = lazy (constant "Z") +let plus = lazy (constant "Zplus") +let mult = lazy (constant "Zmult") +let opp = lazy (constant "Zopp") +let minus = lazy (constant "Zminus") + +let coq_xH = lazy (constant "xH") +let coq_xO = lazy (constant "xO") +let coq_xI = lazy (constant "xI") +let coq_Z0 = lazy (constant "Z0") +let coq_Zpos = lazy (constant "Zpos") +let coq_Zneg = lazy (constant "Zneg") + +let recognize t = + let rec loop t = + let f,l = dest_const_apply t in + match Names.string_of_id f,l with + "xI",[t] -> Bigint.add Bigint.one (Bigint.mult Bigint.two (loop t)) + | "xO",[t] -> Bigint.mult Bigint.two (loop t) + | "xH",[] -> Bigint.one + | _ -> failwith "not a number" in + let f,l = dest_const_apply t in + match Names.string_of_id f,l with + "Zpos",[t] -> loop t + | "Zneg",[t] -> Bigint.neg (loop t) + | "Z0",[] -> Bigint.zero + | _ -> failwith "not a number";; + +let rec mk_positive n = + if n=Bigint.one then Lazy.force coq_xH + else + let (q,r) = Bigint.euclid n Bigint.two in + Term.mkApp + ((if r = Bigint.zero then Lazy.force coq_xO else Lazy.force coq_xI), + [| mk_positive q |]) + +let mk_Z n = + if n = Bigint.zero then Lazy.force coq_Z0 + else if Bigint.is_strictly_pos n then + Term.mkApp (Lazy.force coq_Zpos, [| mk_positive n |]) + else + Term.mkApp (Lazy.force coq_Zneg, [| mk_positive (Bigint.neg n) |]) + +let mk = mk_Z + +let parse_term t = + try match destructurate t with + | Kapp("Zplus",[t1;t2]) -> Tplus (t1,t2) + | Kapp("Zminus",[t1;t2]) -> Tminus (t1,t2) + | Kapp("Zmult",[t1;t2]) -> Tmult (t1,t2) + | Kapp("Zopp",[t]) -> Topp t + | Kapp("Zsucc",[t]) -> Tsucc t + | Kapp("Zpred",[t]) -> Tplus(t, mk_Z (Bigint.neg Bigint.one)) + | Kapp(("Zpos"|"Zneg"|"Z0"),_) -> + (try Tnum (recognize t) with _ -> Tother) + | _ -> Tother + with e when Logic.catchable_exception e -> Tother + +let parse_rel gl t = + try match destructurate t with + | Kapp("eq",[typ;t1;t2]) + when destructurate (Tacmach.pf_nf gl typ) = Kapp("Z",[]) -> Req (t1,t2) + | Kapp("Zne",[t1;t2]) -> Rne (t1,t2) + | Kapp("Zle",[t1;t2]) -> Rle (t1,t2) + | Kapp("Zlt",[t1;t2]) -> Rlt (t1,t2) + | Kapp("Zge",[t1;t2]) -> Rge (t1,t2) + | Kapp("Zgt",[t1;t2]) -> Rgt (t1,t2) + | _ -> parse_logic_rel t + with e when Logic.catchable_exception e -> Rother + +let is_scalar t = + let rec aux t = match destructurate t with + | Kapp(("Zplus"|"Zminus"|"Zmult"),[t1;t2]) -> aux t1 & aux t2 + | Kapp(("Zopp"|"Zsucc"|"Zpred"),[t]) -> aux t + | Kapp(("Zpos"|"Zneg"|"Z0"),_) -> let _ = recognize t in true + | _ -> false in + try aux t with _ -> false + +end diff --git a/contrib/romega/const_omega.mli b/contrib/romega/const_omega.mli new file mode 100644 index 00000000..0f00e918 --- /dev/null +++ b/contrib/romega/const_omega.mli @@ -0,0 +1,176 @@ +(************************************************************************* + + PROJET RNRT Calife - 2001 + Author: Pierre Crégut - France Télécom R&D + Licence : LGPL version 2.1 + + *************************************************************************) + + +(** Coq objects used in romega *) + +(* from Logic *) +val coq_refl_equal : Term.constr lazy_t +val coq_and : Term.constr lazy_t +val coq_not : Term.constr lazy_t +val coq_or : Term.constr lazy_t +val coq_True : Term.constr lazy_t +val coq_False : Term.constr lazy_t +val coq_I : Term.constr lazy_t + +(* from ReflOmegaCore/ZOmega *) +val coq_h_step : Term.constr lazy_t +val coq_pair_step : Term.constr lazy_t +val coq_p_left : Term.constr lazy_t +val coq_p_right : Term.constr lazy_t +val coq_p_invert : Term.constr lazy_t +val coq_p_step : Term.constr lazy_t + +val coq_t_int : Term.constr lazy_t +val coq_t_plus : Term.constr lazy_t +val coq_t_mult : Term.constr lazy_t +val coq_t_opp : Term.constr lazy_t +val coq_t_minus : Term.constr lazy_t +val coq_t_var : Term.constr lazy_t + +val coq_proposition : Term.constr lazy_t +val coq_p_eq : Term.constr lazy_t +val coq_p_leq : Term.constr lazy_t +val coq_p_geq : Term.constr lazy_t +val coq_p_lt : Term.constr lazy_t +val coq_p_gt : Term.constr lazy_t +val coq_p_neq : Term.constr lazy_t +val coq_p_true : Term.constr lazy_t +val coq_p_false : Term.constr lazy_t +val coq_p_not : Term.constr lazy_t +val coq_p_or : Term.constr lazy_t +val coq_p_and : Term.constr lazy_t +val coq_p_imp : Term.constr lazy_t +val coq_p_prop : Term.constr lazy_t + +val coq_f_equal : Term.constr lazy_t +val coq_f_cancel : Term.constr lazy_t +val coq_f_left : Term.constr lazy_t +val coq_f_right : Term.constr lazy_t + +val coq_c_do_both : Term.constr lazy_t +val coq_c_do_left : Term.constr lazy_t +val coq_c_do_right : Term.constr lazy_t +val coq_c_do_seq : Term.constr lazy_t +val coq_c_nop : Term.constr lazy_t +val coq_c_opp_plus : Term.constr lazy_t +val coq_c_opp_opp : Term.constr lazy_t +val coq_c_opp_mult_r : Term.constr lazy_t +val coq_c_opp_one : Term.constr lazy_t +val coq_c_reduce : Term.constr lazy_t +val coq_c_mult_plus_distr : Term.constr lazy_t +val coq_c_opp_left : Term.constr lazy_t +val coq_c_mult_assoc_r : Term.constr lazy_t +val coq_c_plus_assoc_r : Term.constr lazy_t +val coq_c_plus_assoc_l : Term.constr lazy_t +val coq_c_plus_permute : Term.constr lazy_t +val coq_c_plus_comm : Term.constr lazy_t +val coq_c_red0 : Term.constr lazy_t +val coq_c_red1 : Term.constr lazy_t +val coq_c_red2 : Term.constr lazy_t +val coq_c_red3 : Term.constr lazy_t +val coq_c_red4 : Term.constr lazy_t +val coq_c_red5 : Term.constr lazy_t +val coq_c_red6 : Term.constr lazy_t +val coq_c_mult_opp_left : Term.constr lazy_t +val coq_c_mult_assoc_reduced : Term.constr lazy_t +val coq_c_minus : Term.constr lazy_t +val coq_c_mult_comm : Term.constr lazy_t + +val coq_s_constant_not_nul : Term.constr lazy_t +val coq_s_constant_neg : Term.constr lazy_t +val coq_s_div_approx : Term.constr lazy_t +val coq_s_not_exact_divide : Term.constr lazy_t +val coq_s_exact_divide : Term.constr lazy_t +val coq_s_sum : Term.constr lazy_t +val coq_s_state : Term.constr lazy_t +val coq_s_contradiction : Term.constr lazy_t +val coq_s_merge_eq : Term.constr lazy_t +val coq_s_split_ineq : Term.constr lazy_t +val coq_s_constant_nul : Term.constr lazy_t +val coq_s_negate_contradict : Term.constr lazy_t +val coq_s_negate_contradict_inv : Term.constr lazy_t + +val coq_direction : Term.constr lazy_t +val coq_d_left : Term.constr lazy_t +val coq_d_right : Term.constr lazy_t +val coq_d_mono : Term.constr lazy_t + +val coq_e_split : Term.constr lazy_t +val coq_e_extract : Term.constr lazy_t +val coq_e_solve : Term.constr lazy_t + +val coq_interp_sequent : Term.constr lazy_t +val coq_do_omega : Term.constr lazy_t + +(** Building expressions *) + +val do_left : Term.constr -> Term.constr +val do_right : Term.constr -> Term.constr +val do_both : Term.constr -> Term.constr -> Term.constr +val do_seq : Term.constr -> Term.constr -> Term.constr +val do_list : Term.constr list -> Term.constr + +val mk_nat : int -> Term.constr +val mk_list : Term.constr -> Term.constr list -> Term.constr +val mk_plist : Term.types list -> Term.types +val mk_shuffle_list : Term.constr list -> Term.constr + +(** Analyzing a coq term *) + +(* The generic result shape of the analysis of a term. + One-level depth, except when a number is found *) +type parse_term = + Tplus of Term.constr * Term.constr + | Tmult of Term.constr * Term.constr + | Tminus of Term.constr * Term.constr + | Topp of Term.constr + | Tsucc of Term.constr + | Tnum of Bigint.bigint + | Tother + +(* The generic result shape of the analysis of a relation. + One-level depth. *) +type parse_rel = + Req of Term.constr * Term.constr + | Rne of Term.constr * Term.constr + | Rlt of Term.constr * Term.constr + | Rle of Term.constr * Term.constr + | Rgt of Term.constr * Term.constr + | Rge of Term.constr * Term.constr + | Rtrue + | Rfalse + | Rnot of Term.constr + | Ror of Term.constr * Term.constr + | Rand of Term.constr * Term.constr + | Rimp of Term.constr * Term.constr + | Riff of Term.constr * Term.constr + | Rother + +(* A module factorizing what we should now about the number representation *) +module type Int = + sig + (* the coq type of the numbers *) + val typ : Term.constr Lazy.t + (* the operations on the numbers *) + val plus : Term.constr Lazy.t + val mult : Term.constr Lazy.t + val opp : Term.constr Lazy.t + val minus : Term.constr Lazy.t + (* building a coq number *) + val mk : Bigint.bigint -> Term.constr + (* parsing a term (one level, except if a number is found) *) + val parse_term : Term.constr -> parse_term + (* parsing a relation expression, including = < <= >= > *) + val parse_rel : Proof_type.goal Tacmach.sigma -> Term.constr -> parse_rel + (* Is a particular term only made of numbers and + * - ? *) + val is_scalar : Term.constr -> bool + end + +(* Currently, we only use Z numbers *) +module Z : Int diff --git a/contrib/romega/g_romega.ml4 b/contrib/romega/g_romega.ml4 index 7cfc50f8..39b6c210 100644 --- a/contrib/romega/g_romega.ml4 +++ b/contrib/romega/g_romega.ml4 @@ -9,7 +9,34 @@ (*i camlp4deps: "parsing/grammar.cma" i*) open Refl_omega +open Refiner -TACTIC EXTEND romelga - [ "romega" ] -> [ total_reflexive_omega_tactic ] +let romega_tactic l = + let tacs = List.map + (function + | "nat" -> Tacinterp.interp <:tactic<zify_nat>> + | "positive" -> Tacinterp.interp <:tactic<zify_positive>> + | "N" -> Tacinterp.interp <:tactic<zify_N>> + | "Z" -> Tacinterp.interp <:tactic<zify_op>> + | s -> Util.error ("No ROmega knowledge base for type "^s)) + (Util.list_uniquize (List.sort compare l)) + in + tclTHEN + (tclREPEAT (tclPROGRESS (tclTHENLIST tacs))) + (tclTHEN + (* because of the contradiction process in (r)omega, + we'd better leave as little as possible in the conclusion, + for an easier decidability argument. *) + Tactics.intros + total_reflexive_omega_tactic) + + +TACTIC EXTEND romega +| [ "romega" ] -> [ romega_tactic [] ] +END + +TACTIC EXTEND romega' +| [ "romega" "with" ne_ident_list(l) ] -> + [ romega_tactic (List.map Names.string_of_id l) ] +| [ "romega" "with" "*" ] -> [ romega_tactic ["nat";"positive";"N";"Z"] ] END diff --git a/contrib/romega/refl_omega.ml b/contrib/romega/refl_omega.ml index e7e7b3c5..fc4f7a8f 100644 --- a/contrib/romega/refl_omega.ml +++ b/contrib/romega/refl_omega.ml @@ -6,10 +6,7 @@ *************************************************************************) -(* The addition on int, since it while be hidden soon by the one on BigInt *) - -let (+.) = (+) - +open Util open Const_omega module OmegaSolver = Omega.MakeOmegaSolver (Bigint) open OmegaSolver @@ -26,65 +23,6 @@ let pp i = print_int i; print_newline (); flush stdout (* More readable than the prefix notation *) let (>>) = Tacticals.tclTHEN -(* [list_index t l = i] \eqv $nth l i = t \wedge \forall j < i nth l j != t$ *) - -let list_index t = - let rec loop i = function - | (u::l) -> if u = t then i else loop (succ i) l - | [] -> raise Not_found in - loop 0 - -(* [list_uniq l = filter_i (x i -> nth l (i-1) != x) l] *) -let list_uniq l = - let rec uniq = function - x :: ((y :: _) as l) when x = y -> uniq l - | x :: l -> x :: uniq l - | [] -> [] in - uniq (List.sort compare l) - -(* $\forall x. mem x (list\_union l1 l2) \eqv x \in \{l1\} \cup \{l2\}$ *) -let list_union l1 l2 = - let rec loop buf = function - x :: r -> if List.mem x l2 then loop buf r else loop (x :: buf) r - | [] -> buf in - loop l2 l1 - -(* $\forall x. - mem \;\; x \;\; (list\_intersect\;\; l1\;\;l2) \eqv x \in \{l1\} - \cap \{l2\}$ *) -let list_intersect l1 l2 = - let rec loop buf = function - x :: r -> if List.mem x l2 then loop (x::buf) r else loop buf r - | [] -> buf in - loop [] l1 - -(* cartesian product. Elements are lists and are concatenated. - $cartesian [x_1 ... x_n] [y_1 ... y_p] = [x_1 @ y_1, x_2 @ y_1 ... x_n @ y_1 , x_1 @ y_2 ... x_n @ y_p]$ *) - -let rec cartesien l1 l2 = - let rec loop = function - (x2 :: r2) -> List.map (fun x1 -> x1 @ x2) l1 @ loop r2 - | [] -> [] in - loop l2 - -(* remove element e from list l *) -let list_remove e l = - let rec loop = function - x :: l -> if x = e then loop l else x :: loop l - | [] -> [] in - loop l - -(* equivalent of the map function but no element is added when the function - raises an exception (and the computation silently continues) *) -let map_exc f = - let rec loop = function - (x::l) -> - begin match try Some (f x) with exc -> None with - Some v -> v :: loop l | None -> loop l - end - | [] -> [] in - loop - let mkApp = Term.mkApp (* \section{Types} @@ -174,6 +112,7 @@ type environment = { (* \subsection{Solution tree} Définition d'une solution trouvée par Omega sous la forme d'un identifiant, d'un ensemble d'équation dont dépend la solution et d'une trace *) +(* La liste des dépendances est triée et sans redondance *) type solution = { s_index : int; s_equa_deps : int list; @@ -280,7 +219,7 @@ let unintern_omega env id = calcul des variables utiles. *) let add_reified_atom t env = - try list_index t env.terms + try list_index0 t env.terms with Not_found -> let i = List.length env.terms in env.terms <- env.terms @ [t]; i @@ -291,7 +230,7 @@ let get_reified_atom env = (* \subsection{Gestion de l'environnement de proposition pour Omega} *) (* ajout d'une proposition *) let add_prop env t = - try list_index t env.props + try list_index0 t env.props with Not_found -> let i = List.length env.props in env.props <- env.props @ [t]; i @@ -362,13 +301,6 @@ let omega_of_oformula env kind = (* \subsection{Omega vers Oformula} *) -let reified_of_atom env i = - try Hashtbl.find env.real_indices i - with Not_found -> - Printf.printf "Atome %d non trouvé\n" i; - Hashtbl.iter (fun k v -> Printf.printf "%d -> %d\n" k v) env.real_indices; - raise Not_found - let rec oformula_of_omega env af = let rec loop = function | ({v=v; c=n}::r) -> @@ -382,20 +314,27 @@ let app f v = mkApp(Lazy.force f,v) let rec coq_of_formula env t = let rec loop = function - | Oplus (t1,t2) -> app coq_Zplus [| loop t1; loop t2 |] - | Oopp t -> app coq_Zopp [| loop t |] - | Omult(t1,t2) -> app coq_Zmult [| loop t1; loop t2 |] - | Oint v -> mk_Z v + | Oplus (t1,t2) -> app Z.plus [| loop t1; loop t2 |] + | Oopp t -> app Z.opp [| loop t |] + | Omult(t1,t2) -> app Z.mult [| loop t1; loop t2 |] + | Oint v -> Z.mk v | Oufo t -> loop t | Oatom var -> (* attention ne traite pas les nouvelles variables si on ne les * met pas dans env.term *) get_reified_atom env var - | Ominus(t1,t2) -> app coq_Zminus [| loop t1; loop t2 |] in + | Ominus(t1,t2) -> app Z.minus [| loop t1; loop t2 |] in loop t (* \subsection{Oformula vers COQ reifié} *) +let reified_of_atom env i = + try Hashtbl.find env.real_indices i + with Not_found -> + Printf.printf "Atome %d non trouvé\n" i; + Hashtbl.iter (fun k v -> Printf.printf "%d -> %d\n" k v) env.real_indices; + raise Not_found + let rec reified_of_formula env = function | Oplus (t1,t2) -> app coq_t_plus [| reified_of_formula env t1; reified_of_formula env t2 |] @@ -403,7 +342,7 @@ let rec reified_of_formula env = function app coq_t_opp [| reified_of_formula env t |] | Omult(t1,t2) -> app coq_t_mult [| reified_of_formula env t1; reified_of_formula env t2 |] - | Oint v -> app coq_t_int [| mk_Z v |] + | Oint v -> app coq_t_int [| Z.mk v |] | Oufo t -> reified_of_formula env t | Oatom i -> app coq_t_var [| mk_nat (reified_of_atom env i) |] | Ominus(t1,t2) -> @@ -448,12 +387,12 @@ let reified_of_proposition env f = let reified_of_omega env body constant = let coeff_constant = - app coq_t_int [| mk_Z constant |] in + app coq_t_int [| Z.mk constant |] in let mk_coeff {c=c; v=v} t = let coef = app coq_t_mult [| reified_of_formula env (unintern_omega env v); - app coq_t_int [| mk_Z c |] |] in + app coq_t_int [| Z.mk c |] |] in app coq_t_plus [|coef; t |] in List.fold_right mk_coeff body coeff_constant @@ -469,22 +408,34 @@ Ces fonctions préparent les traces utilisées par la tactique réfléchie pour faire des opérations de normalisation sur les équations. *) (* \subsection{Extractions des variables d'une équation} *) -(* Extraction des variables d'une équation *) +(* Extraction des variables d'une équation. *) +(* Chaque fonction retourne une liste triée sans redondance *) + +let (@@) = list_merge_uniq compare let rec vars_of_formula = function | Oint _ -> [] - | Oplus (e1,e2) -> (vars_of_formula e1) @ (vars_of_formula e2) - | Omult (e1,e2) -> (vars_of_formula e1) @ (vars_of_formula e2) - | Ominus (e1,e2) -> (vars_of_formula e1) @ (vars_of_formula e2) - | Oopp e -> (vars_of_formula e) + | Oplus (e1,e2) -> (vars_of_formula e1) @@ (vars_of_formula e2) + | Omult (e1,e2) -> (vars_of_formula e1) @@ (vars_of_formula e2) + | Ominus (e1,e2) -> (vars_of_formula e1) @@ (vars_of_formula e2) + | Oopp e -> vars_of_formula e | Oatom i -> [i] | Oufo _ -> [] -let vars_of_equations l = - let rec loop = function - e :: l -> vars_of_formula e.e_left @ vars_of_formula e.e_right @ loop l - | [] -> [] in - list_uniq (List.sort compare (loop l)) +let rec vars_of_equations = function + | [] -> [] + | e::l -> + (vars_of_formula e.e_left) @@ + (vars_of_formula e.e_right) @@ + (vars_of_equations l) + +let rec vars_of_prop = function + | Pequa(_,e) -> vars_of_equations [e] + | Pnot p -> vars_of_prop p + | Por(_,p1,p2) -> (vars_of_prop p1) @@ (vars_of_prop p2) + | Pand(_,p1,p2) -> (vars_of_prop p1) @@ (vars_of_prop p2) + | Pimp(_,p1,p2) -> (vars_of_prop p1) @@ (vars_of_prop p2) + | Pprop _ | Ptrue | Pfalse -> [] (* \subsection{Multiplication par un scalaire} *) @@ -715,36 +666,23 @@ let normalize_equation env (negated,depends,origin,path) (oper,t1,t2) = (* \section{Compilation des hypothèses} *) -let is_scalar t = - let rec aux t = match destructurate t with - | Kapp(("Zplus"|"Zminus"|"Zmult"),[t1;t2]) -> aux t1 & aux t2 - | Kapp(("Zopp"|"Zsucc"),[t]) -> aux t - | Kapp(("Zpos"|"Zneg"|"Z0"),_) -> let _ = recognize_number t in true - | _ -> false in - try aux t with _ -> false - let rec oformula_of_constr env t = - try match destructurate t with - | Kapp("Zplus",[t1;t2]) -> binop env (fun x y -> Oplus(x,y)) t1 t2 - | Kapp("Zminus",[t1;t2]) -> binop env (fun x y -> Ominus(x,y)) t1 t2 - | Kapp("Zmult",[t1;t2]) when is_scalar t1 or is_scalar t2 -> - binop env (fun x y -> Omult(x,y)) t1 t2 - | Kapp("Zopp",[t]) -> Oopp(oformula_of_constr env t) - | Kapp("Zsucc",[t]) -> Oplus(oformula_of_constr env t, Oint one) - | Kapp(("Zpos"|"Zneg"|"Z0"),_) -> - begin try Oint(recognize_number t) - with _ -> Oatom (add_reified_atom t env) end - | _ -> - Oatom (add_reified_atom t env) - with e when Logic.catchable_exception e -> - Oatom (add_reified_atom t env) - -and binop env c t1 t2 = - let t1' = oformula_of_constr env t1 in - let t2' = oformula_of_constr env t2 in - c t1' t2' - -and binprop env (neg2,depends,origin,path) + match Z.parse_term t with + | Tplus (t1,t2) -> binop env (fun x y -> Oplus(x,y)) t1 t2 + | Tminus (t1,t2) -> binop env (fun x y -> Ominus(x,y)) t1 t2 + | Tmult (t1,t2) when Z.is_scalar t1 || Z.is_scalar t2 -> + binop env (fun x y -> Omult(x,y)) t1 t2 + | Topp t -> Oopp(oformula_of_constr env t) + | Tsucc t -> Oplus(oformula_of_constr env t, Oint one) + | Tnum n -> Oint n + | _ -> Oatom (add_reified_atom t env) + +and binop env c t1 t2 = + let t1' = oformula_of_constr env t1 in + let t2' = oformula_of_constr env t2 in + c t1' t2' + +and binprop env (neg2,depends,origin,path) add_to_depends neg1 gl c t1 t2 = let i = new_connector_id env in let depends1 = if add_to_depends then Left i::depends else depends in @@ -767,40 +705,32 @@ and mk_equation env ctxt c connector t1 t2 = Pequa (c,omega) and oproposition_of_constr env ((negated,depends,origin,path) as ctxt) gl c = - try match destructurate c with - | Kapp("eq",[typ;t1;t2]) - when destructurate (Tacmach.pf_nf gl typ) = Kapp("Z",[]) -> - mk_equation env ctxt c Eq t1 t2 - | Kapp("Zne",[t1;t2]) -> - mk_equation env ctxt c Neq t1 t2 - | Kapp("Zle",[t1;t2]) -> - mk_equation env ctxt c Leq t1 t2 - | Kapp("Zlt",[t1;t2]) -> - mk_equation env ctxt c Lt t1 t2 - | Kapp("Zge",[t1;t2]) -> - mk_equation env ctxt c Geq t1 t2 - | Kapp("Zgt",[t1;t2]) -> - mk_equation env ctxt c Gt t1 t2 - | Kapp("True",[]) -> Ptrue - | Kapp("False",[]) -> Pfalse - | Kapp("not",[t]) -> - let t' = - oproposition_of_constr - env (not negated, depends, origin,(O_mono::path)) gl t in - Pnot t' - | Kapp("or",[t1;t2]) -> + match Z.parse_rel gl c with + | Req (t1,t2) -> mk_equation env ctxt c Eq t1 t2 + | Rne (t1,t2) -> mk_equation env ctxt c Neq t1 t2 + | Rle (t1,t2) -> mk_equation env ctxt c Leq t1 t2 + | Rlt (t1,t2) -> mk_equation env ctxt c Lt t1 t2 + | Rge (t1,t2) -> mk_equation env ctxt c Geq t1 t2 + | Rgt (t1,t2) -> mk_equation env ctxt c Gt t1 t2 + | Rtrue -> Ptrue + | Rfalse -> Pfalse + | Rnot t -> + let t' = + oproposition_of_constr + env (not negated, depends, origin,(O_mono::path)) gl t in + Pnot t' + | Ror (t1,t2) -> binprop env ctxt (not negated) negated gl (fun i x y -> Por(i,x,y)) t1 t2 - | Kapp("and",[t1;t2]) -> + | Rand (t1,t2) -> binprop env ctxt negated negated gl (fun i x y -> Pand(i,x,y)) t1 t2 - | Kimp(t1,t2) -> + | Rimp (t1,t2) -> binprop env ctxt (not negated) (not negated) gl (fun i x y -> Pimp(i,x,y)) t1 t2 - | Kapp("iff",[t1;t2]) -> + | Riff (t1,t2) -> binprop env ctxt negated negated gl (fun i x y -> Pand(i,x,y)) (Term.mkArrow t1 t2) (Term.mkArrow t2 t1) | _ -> Pprop c - with e when Logic.catchable_exception e -> Pprop c (* Destructuration des hypothèses et de la conclusion *) @@ -881,7 +811,7 @@ let destructurate_hyps syst = (i,t) :: l -> let l_syst1 = destructurate_pos_hyp i [] [] t in let l_syst2 = loop l in - cartesien l_syst1 l_syst2 + list_cartesian (@) l_syst1 l_syst2 | [] -> [[]] in loop syst @@ -924,9 +854,9 @@ let display_systems syst_list = let rec hyps_used_in_trace = function | act :: l -> begin match act with - | HYP e -> e.id :: hyps_used_in_trace l + | HYP e -> [e.id] @@ (hyps_used_in_trace l) | SPLIT_INEQ (_,(_,act1),(_,act2)) -> - hyps_used_in_trace act1 @ hyps_used_in_trace act2 + hyps_used_in_trace act1 @@ hyps_used_in_trace act2 | _ -> hyps_used_in_trace l end | [] -> [] @@ -950,14 +880,15 @@ let rec variable_stated_in_trace = function ;; let add_stated_equations env tree = - let rec loop = function - Tree(_,t1,t2) -> - list_union (loop t1) (loop t2) - | Leaf s -> variable_stated_in_trace s.s_trace in (* Il faut trier les variables par ordre d'introduction pour ne pas risquer de définir dans le mauvais ordre *) let stated_equations = - List.sort (fun x y -> Pervasives.(-) x.st_var y.st_var) (loop tree) in + let cmpvar x y = Pervasives.(-) x.st_var y.st_var in + let rec loop = function + | Tree(_,t1,t2) -> List.merge cmpvar (loop t1) (loop t2) + | Leaf s -> List.sort cmpvar (variable_stated_in_trace s.s_trace) + in loop tree + in let add_env st = (* On retransforme la définition de v en formule reifiée *) let v_def = oformula_of_omega env st.st_def in @@ -966,7 +897,7 @@ let add_stated_equations env tree = let coq_v = coq_of_formula env v_def in let v = add_reified_atom coq_v env in (* Le terme qu'il va falloir introduire *) - let term_to_generalize = app coq_refl_equal [|Lazy.force coq_Z; coq_v|] in + let term_to_generalize = app coq_refl_equal [|Lazy.force Z.typ; coq_v|] in (* sa représentation sous forme d'équation mais non réifié car on n'a pas * l'environnement pour le faire correctement *) let term_to_reify = (v_def,Oatom v) in @@ -978,10 +909,15 @@ let add_stated_equations env tree = (* Calcule la liste des éclatements à réaliser sur les hypothèses nécessaires pour extraire une liste d'équations donnée *) +(* PL: experimentally, the result order of the following function seems + _very_ crucial for efficiency. No idea why. Do not remove the List.rev + or modify the current semantics of Util.list_union (some elements of first + arg, then second arg), unless you know what you're doing. *) + let rec get_eclatement env = function i :: r -> let l = try (get_equation env i).e_depends with Not_found -> [] in - list_union l (get_eclatement env r) + list_union (List.rev l) (get_eclatement env r) | [] -> [] let select_smaller l = @@ -992,14 +928,13 @@ let filter_compatible_systems required systems = let rec select = function (x::l) -> if List.mem x required then select l - else if List.mem (barre x) required then raise Exit + else if List.mem (barre x) required then failwith "Exit" else x :: select l | [] -> [] in - map_exc (function (sol,splits) -> (sol,select splits)) systems + map_succeed (function (sol,splits) -> (sol,select splits)) systems let rec equas_of_solution_tree = function - Tree(_,t1,t2) -> - list_union (equas_of_solution_tree t1) (equas_of_solution_tree t2) + Tree(_,t1,t2) -> (equas_of_solution_tree t1)@@(equas_of_solution_tree t2) | Leaf s -> s.s_equa_deps (* [really_useful_prop] pushes useless props in a new Pprop variable *) @@ -1041,14 +976,6 @@ let really_useful_prop l_equa c = None -> Pprop (real_of c) | Some t -> t -let rec vars_of_prop = function - | Pequa(_,e) -> vars_of_equations [e] - | Pnot p -> vars_of_prop p - | Por(_,p1,p2) -> list_union (vars_of_prop p1) (vars_of_prop p2) - | Pand(_,p1,p2) -> list_union (vars_of_prop p1) (vars_of_prop p2) - | Pimp(_,p1,p2) -> list_union (vars_of_prop p1) (vars_of_prop p2) - | _ -> [] - let rec display_solution_tree ch = function Leaf t -> output_string ch @@ -1103,7 +1030,7 @@ let mk_direction_list l = (* \section{Rejouer l'historique} *) let get_hyp env_hyp i = - try list_index (CCEqua i) env_hyp + try list_index0 (CCEqua i) env_hyp with Not_found -> failwith (Printf.sprintf "get_hyp %d" i) let replay_history env env_hyp = @@ -1116,7 +1043,7 @@ let replay_history env env_hyp = mk_nat (get_hyp env_hyp e2.id) |]) | DIVIDE_AND_APPROX (e1,e2,k,d) :: l -> mkApp (Lazy.force coq_s_div_approx, - [| mk_Z k; mk_Z d; + [| Z.mk k; Z.mk d; reified_of_omega env e2.body e2.constant; mk_nat (List.length e2.body); loop env_hyp l; mk_nat (get_hyp env_hyp e1.id) |]) @@ -1125,7 +1052,7 @@ let replay_history env env_hyp = let d = e1.constant - e2_constant * k in let e2_body = map_eq_linear (fun c -> c / k) e1.body in mkApp (Lazy.force coq_s_not_exact_divide, - [|mk_Z k; mk_Z d; + [|Z.mk k; Z.mk d; reified_of_omega env e2_body e2_constant; mk_nat (List.length e2_body); mk_nat (get_hyp env_hyp e1.id)|]) @@ -1134,7 +1061,7 @@ let replay_history env env_hyp = map_eq_linear (fun c -> c / k) e1.body in let e2_constant = floor_div e1.constant k in mkApp (Lazy.force coq_s_exact_divide, - [|mk_Z k; + [|Z.mk k; reified_of_omega env e2_body e2_constant; mk_nat (List.length e2_body); loop env_hyp l; mk_nat (get_hyp env_hyp e1.id)|]) @@ -1149,7 +1076,7 @@ let replay_history env env_hyp = and n2 = get_hyp env_hyp e2.id in let trace = shuffle_path k1 e1.body k2 e2.body in mkApp (Lazy.force coq_s_sum, - [| mk_Z k1; mk_nat n1; mk_Z k2; + [| Z.mk k1; mk_nat n1; Z.mk k2; mk_nat n2; trace; (loop (CCEqua e3 :: env_hyp) l) |]) | CONSTANT_NOT_NUL(e,k) :: l -> mkApp (Lazy.force coq_s_constant_not_nul, @@ -1169,7 +1096,7 @@ let replay_history env env_hyp = Oplus (o_orig,Omult (Oplus (Oopp v,o_def), Oint m)) in let trace,_ = normalize_linear_term env body in mkApp (Lazy.force coq_s_state, - [| mk_Z m; trace; mk_nat n1; mk_nat n2; + [| Z.mk m; trace; mk_nat n1; mk_nat n2; loop (CCEqua new_eq.id :: env_hyp) l |]) | HYP _ :: l -> loop env_hyp l | CONSTANT_NUL e :: l -> @@ -1267,17 +1194,17 @@ let resolution env full_reified_goal systems_list = print_newline() end; (* calcule la liste de toutes les hypothèses utilisées dans l'arbre de solution *) - let useful_equa_id = list_uniq (equas_of_solution_tree solution_tree) in + let useful_equa_id = equas_of_solution_tree solution_tree in (* recupere explicitement ces equations *) let equations = List.map (get_equation env) useful_equa_id in - let l_hyps' = list_uniq (List.map (fun e -> e.e_origin.o_hyp) equations) in + let l_hyps' = list_uniquize (List.map (fun e -> e.e_origin.o_hyp) equations) in let l_hyps = id_concl :: list_remove id_concl l_hyps' in let useful_hyps = List.map (fun id -> List.assoc id full_reified_goal) l_hyps in let useful_vars = let really_useful_vars = vars_of_equations equations in let concl_vars = vars_of_prop (List.assoc id_concl full_reified_goal) in - list_uniq (List.sort compare (really_useful_vars @ concl_vars)) + really_useful_vars @@ concl_vars in (* variables a introduire *) let to_introduce = add_stated_equations env solution_tree in @@ -1295,7 +1222,7 @@ let resolution env full_reified_goal systems_list = Hashtbl.add env.real_indices var i; t :: loop (succ i) l | [] -> [] in loop 0 all_vars_env in - let env_terms_reified = mk_list (Lazy.force coq_Z) basic_env in + let env_terms_reified = mk_list (Lazy.force Z.typ) basic_env in (* On peut maintenant généraliser le but : env est a jour *) let l_reified_stated = List.map (fun (_,_,(l,r),_) -> @@ -1325,10 +1252,10 @@ let resolution env full_reified_goal systems_list = | ((O_left | O_mono) :: l) -> app coq_p_left [| loop l |] | (O_right :: l) -> app coq_p_right [| loop l |] in let correct_index = - let i = list_index e.e_origin.o_hyp l_hyps in + let i = list_index0 e.e_origin.o_hyp l_hyps in (* PL: it seems that additionnally introduced hyps are in the way during normalization, hence this index shifting... *) - if i=0 then 0 else i +. List.length to_introduce + if i=0 then 0 else Pervasives.(+) i (List.length to_introduce) in app coq_pair_step [| mk_nat correct_index; loop e.e_origin.o_path |] in let normalization_trace = diff --git a/contrib/rtauto/Bintree.v b/contrib/rtauto/Bintree.v index f4b24d4b..e90fea84 100644 --- a/contrib/rtauto/Bintree.v +++ b/contrib/rtauto/Bintree.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: Bintree.v 8881 2006-05-31 18:16:34Z jforest $ *) +(* $Id: Bintree.v 10681 2008-03-16 13:40:45Z msozeau $ *) Require Export List. Require Export BinPos. @@ -20,15 +20,6 @@ Ltac caseq t := generalize (refl_equal t); pattern t at -1; case t. Functional Scheme Pcompare_ind := Induction for Pcompare Sort Prop. -Lemma Prect : forall P : positive -> Type, - P 1 -> - (forall n : positive, P n -> P (Psucc n)) -> forall p : positive, P p. -intros P H1 Hsucc n; induction n. -rewrite <- plus_iter_xI; apply Hsucc; apply iterate_add; assumption. -rewrite <- plus_iter_xO; apply iterate_add; assumption. -assumption. -Qed. - Lemma Gt_Eq_Gt : forall p q cmp, (p ?= q) Eq = Gt -> (p ?= q) cmp = Gt. apply (Pcompare_ind (fun p q cmp _ => (p ?= q) Eq = Gt -> (p ?= q) cmp = Gt)); @@ -116,7 +107,7 @@ intro ne;right;congruence. left;reflexivity. Defined. -Theorem pos_eq_dec_refl : forall m, pos_eq_dec m m = left (m<>m) (refl_equal m) . +Theorem pos_eq_dec_refl : forall m, pos_eq_dec m m = left _ (refl_equal m). fix 1;intros [mm|mm|]. simpl; rewrite pos_eq_dec_refl; reflexivity. simpl; rewrite pos_eq_dec_refl; reflexivity. @@ -125,7 +116,7 @@ Qed. Theorem pos_eq_dec_ex : forall m n, pos_eq m n =true -> exists h:m=n, - pos_eq_dec m n = left (m<>n) h. + pos_eq_dec m n = left _ h. fix 1;intros [mm|mm|] [nn|nn|];try (simpl;congruence). simpl;intro e. elim (pos_eq_dec_ex _ _ e). diff --git a/contrib/rtauto/refl_tauto.ml b/contrib/rtauto/refl_tauto.ml index a1f5e5aa..81256f4a 100644 --- a/contrib/rtauto/refl_tauto.ml +++ b/contrib/rtauto/refl_tauto.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: refl_tauto.ml 9154 2006-09-20 17:18:18Z corbinea $ *) +(* $Id: refl_tauto.ml 10478 2008-01-29 10:31:39Z notin $ *) module Search = Explore.Make(Proof_search) @@ -292,7 +292,7 @@ let rtauto_tac gls= let prf = try project (search_fun (init_state [] formula)) with Not_found -> - errorlabstrm "rtauto" (Pp.str "rtauto could'nt find any proof") in + errorlabstrm "rtauto" (Pp.str "rtauto couldn't find any proof") in let search_end_time = System.get_time () in let _ = if !verbose then begin diff --git a/contrib/setoid_ring/ArithRing.v b/contrib/setoid_ring/ArithRing.v index 074f6ef7..601cabe0 100644 --- a/contrib/setoid_ring/ArithRing.v +++ b/contrib/setoid_ring/ArithRing.v @@ -32,7 +32,7 @@ Qed. Ltac natcst t := match isnatcst t with true => constr:(N_of_nat t) - | _ => InitialRing.NotConstant + | _ => constr:InitialRing.NotConstant end. Ltac Ss_to_add f acc := diff --git a/contrib/setoid_ring/Field_tac.v b/contrib/setoid_ring/Field_tac.v index aad3a580..cccee604 100644 --- a/contrib/setoid_ring/Field_tac.v +++ b/contrib/setoid_ring/Field_tac.v @@ -67,12 +67,12 @@ Ltac FFV Cst CstPow add mul sub opp div inv pow t fv := end in TFV t fv. -Ltac ParseFieldComponents lemma := +Ltac ParseFieldComponents lemma req := match type of lemma with | context [ (* PCond _ _ _ _ _ _ _ _ _ _ _ -> *) - (@FEeval ?R ?rO ?radd ?rmul ?rsub ?ropp ?rdiv ?rinv - ?C ?phi ?Cpow ?Cp_phi ?rpow _ _) ] => + req (@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. @@ -119,18 +119,18 @@ Ltac Field_norm_gen f Cst_tac Pow_tac lemma Cond_lemma req n lH rl := 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 _] => + | context [mk_monpol_list ?cO ?cI ?cadd ?cmul ?csub ?copp ?cdiv ?ceqb _] => compute_assertion vlmp_eq vlmp - (mk_monpol_list cO cI cadd cmul csub copp ceqb vlpe); + (mk_monpol_list cO cI cadd cmul csub copp cdiv ceqb vlpe); (assert (rr_lemma := lemma n vlpe fv prh vlmp vlmp_eq) - || fail "type error when build the rewriting lemma"); + || fail 1 "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. + ParseFieldComponents lemma req Main. Ltac Field_simplify_gen f := fun req cst_tac pow_tac _ _ field_simplify_ok _ cond_ok pre post lH rl => @@ -141,33 +141,35 @@ Ltac Field_simplify_gen f := 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(rl) := + let G := Get_goal in + field_lookup Field_simplify [] rl G. 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. + let G := Get_goal in + field_lookup Field_simplify [lH] rl G. 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. + let G := Get_goal 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 := Get_goal 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:= @@ -176,12 +178,12 @@ Ltac Field_simplify_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]. + 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]. + field_lookup (Field_simplify_in h) [lH] rl t. *) (** Generic tactic for solving equations *) @@ -224,7 +226,7 @@ Ltac Field_Scheme Simpl_tac Cst_tac Pow_tac lemma Cond_lemma req n lH := [ Simpl_tac | apply Cond_lemma; simpl_PCond req]); clear vlpe nlemma in OnEquation req Main_eq in - ParseFieldComponents lemma Main. + ParseFieldComponents lemma req Main. (* solve completely a field equation, leaving non-zero conditions to be proved (field) *) @@ -239,14 +241,15 @@ Ltac FIELD := post(). Tactic Notation (at level 0) "field" := - let G := getGoal in field_lookup FIELD [] [G]. + let G := Get_goal in + field_lookup FIELD [] G. Tactic Notation (at level 0) "field" "[" constr_list(lH) "]" := - let G := getGoal in field_lookup FIELD [lH] [G]. + let G := Get_goal 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_SIMPL := let Simpl := (protect_fv "field") in fun req cst_tac pow_tac _ field_simplify_eq_ok _ _ cond_ok pre post lH rl => @@ -256,17 +259,19 @@ Ltac FIELD_SIMPL := post(). Tactic Notation (at level 0) "field_simplify_eq" := - let G := getGoal in field_lookup FIELD_SIMPL [] [G]. + let G := Get_goal 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]. + let G := Get_goal 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; + intro hyp; match type of hyp with | req ?t1 ?t2 => let mkFV := FV Cst_tac Pow_tac radd rmul rsub ropp rpow in @@ -306,7 +311,7 @@ Ltac Field_simplify_eq Cst_tac Pow_tac lemma Cond_lemma req n lH := clear hyp end) end in - ParseFieldComponents lemma Main. + ParseFieldComponents lemma req Main. Ltac FIELD_SIMPL_EQ := fun req cst_tac pow_tac _ _ _ lemma cond_ok pre post lH rl => @@ -318,7 +323,7 @@ Ltac FIELD_SIMPL_EQ := 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]; + field_lookup FIELD_SIMPL_EQ [] t; [ try exact I | clear H;intro H]. @@ -327,7 +332,7 @@ 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]; + field_lookup FIELD_SIMPL_EQ [lH] t; [ try exact I |clear H;intro H]. @@ -347,59 +352,55 @@ Ltac coerce_to_almost_field set ext f := | semi_field_theory _ _ _ _ _ _ _ => constr:(SF2AF set f) end. -Ltac field_elements set ext fspec pspec sspec rk := +Ltac field_elements set ext fspec pspec sspec dspec rk := let afth := coerce_to_almost_field set ext fspec in let rspec := ring_of_field fspec in - 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 _ _ _ _ _ _ _ _ _ _ + ring_elements set ext rspec pspec sspec dspec rk + ltac:(fun arth ext_r morph p_spec s_spec d_spec f => f afth ext_r morph p_spec s_spec d_spec). + +Ltac field_lemmas set ext inv_m fspec pspec sspec dspec rk := + let get_lemma := + match pspec with None => fun x y => x | _ => fun x y => y end in + let simpl_eq_lemma := get_lemma + Field_simplify_eq_correct Field_simplify_eq_pow_correct in + let simpl_eq_in_lemma := get_lemma + Field_simplify_eq_in_correct Field_simplify_eq_pow_in_correct in + let rw_lemma := get_lemma + Field_rw_correct Field_rw_pow_correct in + field_elements set ext fspec pspec sspec dspec rk + ltac:(fun afth ext_r morph p_spec s_spec d_spec => + match morph with + | _ => + let field_ok1 := constr:(Field_correct set ext_r inv_m afth morph) in + match p_spec with + | mkhypo ?pp_spec => + let field_ok2 := constr:(field_ok1 _ _ _ pp_spec) in + match s_spec with + | mkhypo ?ss_spec => + let field_ok3 := constr:(field_ok2 _ ss_spec) in + match d_spec with + | mkhypo ?dd_spec => + let field_ok := constr:(field_ok3 _ dd_spec) in + let mk_lemma lemma := + constr:(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" + _ _ _ pp_spec _ ss_spec _ dd_spec) in + let field_simpl_eq_ok := mk_lemma simpl_eq_lemma in + let field_simpl_ok := mk_lemma rw_lemma in + let field_simpl_eq_in := mk_lemma simpl_eq_in_lemma in + let cond1_ok := + constr:(Pcond_simpl_gen set ext_r afth morph pp_spec dd_spec) in + let cond2_ok := + constr:(Pcond_simpl_complete set ext_r afth morph pp_spec dd_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 4 "field: bad coefficiant division specification" + end + | _ => fail 3 "field: bad sign specification" + end + | _ => fail 2 "field: bad power specification" + end + | _ => fail 1 "field internal error : field_lemmas, please report" end). - diff --git a/contrib/setoid_ring/Field_theory.v b/contrib/setoid_ring/Field_theory.v index ea8421cf..65a397ac 100644 --- a/contrib/setoid_ring/Field_theory.v +++ b/contrib/setoid_ring/Field_theory.v @@ -74,7 +74,7 @@ Qed. Notation "[ x ]" := (phi x) (at level 0). - (* Usefull tactics *) + (* Useful tactics *) Add Setoid R req Rsth as R_set1. Add Morphism radd : radd_ext. exact (Radd_ext Reqe). Qed. Add Morphism rmul : rmul_ext. exact (Rmul_ext Reqe). Qed. @@ -102,10 +102,13 @@ Hint Resolve (ARadd_0_l ARth) (ARadd_comm ARth) (ARadd_assoc ARth) 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. + Variable get_sign_spec : sign_theory copp ceqb get_sign. + + Variable cdiv:C -> C -> C*C. + Variable cdiv_th : div_theory req cadd cmul phi cdiv. Notation NPEeval := (PEeval rO radd rmul rsub ropp phi Cp_phi rpow). -Notation Nnorm := (norm_subst cO cI cadd cmul csub copp ceqb). +Notation Nnorm:= (norm_subst cO cI cadd cmul csub copp ceqb cdiv). 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). @@ -300,7 +303,30 @@ transitivity (r2 * (r1 / r2) * (r4 * (r3 / r4))); [ ring | idtac ]. repeat rewrite rdiv_simpl in |- *; trivial. Qed. - Theorem rdiv7: + Theorem rdiv4b: + forall r1 r2 r3 r4 r5 r6, + ~ r2 * r5 == 0 -> + ~ r4 * r6 == 0 -> + ((r1 * r6) / (r2 * r5)) * ((r3 * r5) / (r4 * r6)) == (r1 * r3) / (r2 * r4). +Proof. +intros r1 r2 r3 r4 r5 r6 H H0. +rewrite rdiv4; auto. +transitivity ((r5 * r6) * (r1 * r3) / ((r5 * r6) * (r2 * r4))). +apply SRdiv_ext; ring. +assert (HH: ~ r5*r6 == 0). + apply field_is_integral_domain. + intros H1; case H; rewrite H1; ring. + intros H1; case H0; rewrite H1; ring. +rewrite <- rdiv4 ; auto. + rewrite rdiv_r_r; auto. + + apply field_is_integral_domain. + intros H1; case H; rewrite H1; ring. + intros H1; case H0; rewrite H1; ring. +Qed. + + +Theorem rdiv7: forall r1 r2 r3 r4, ~ r2 == 0 -> ~ r3 == 0 -> @@ -313,6 +339,29 @@ rewrite rdiv6 in |- *; trivial. apply rdiv4; trivial. Qed. +Theorem rdiv7b: + forall r1 r2 r3 r4 r5 r6, + ~ r2 * r6 == 0 -> + ~ r3 * r5 == 0 -> + ~ r4 * r6 == 0 -> + ((r1 * r5) / (r2 * r6)) / ((r3 * r5) / (r4 * r6)) == (r1 * r4) / (r2 * r3). +Proof. +intros. +rewrite rdiv7; auto. +transitivity ((r5 * r6) * (r1 * r4) / ((r5 * r6) * (r2 * r3))). +apply SRdiv_ext; ring. +assert (HH: ~ r5*r6 == 0). + apply field_is_integral_domain. + intros H2; case H0; rewrite H2; ring. + intros H2; case H1; rewrite H2; ring. +rewrite <- rdiv4 ; auto. +rewrite rdiv_r_r; auto. + apply field_is_integral_domain. + intros H2; case H; rewrite H2; ring. + intros H2; case H0; rewrite H2; ring. +Qed. + + Theorem rdiv8: forall r1 r2, ~ r2 == 0 -> r1 == 0 -> r1 / r2 == 0. intros r1 r2 H H0. transitivity (r1 * / r2); auto. @@ -331,8 +380,7 @@ transitivity (r1 / r2 * (r4 / r4)). rewrite H1 in |- *. rewrite (ARmul_comm ARth r2 r4) in |- *. rewrite <- rdiv4 in |- *; trivial. - rewrite rdiv_r_r in |- *. - trivial. + rewrite rdiv_r_r in |- * by trivial. apply (ARmul_1_r Rsth ARth). Qed. @@ -395,7 +443,7 @@ 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. +Add Morphism (pow_N rI rmul) with signature req ==> (@eq N) ==> req as pow_N_morph. intros x y H [|p];simpl;auto. apply pow_morph;trivial. Qed. (* @@ -451,7 +499,7 @@ 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 apply eq_refl; - try ring [(morph0 CRmorph)]. + try (ring [(morph0 CRmorph)]). apply (morph_add CRmorph). Qed. @@ -613,6 +661,8 @@ Fixpoint FEeval (l : list R) (pe : FExpr) {struct pe} : R := | FEpow x n => rpow (FEeval l x) (Cp_phi n) end. +Strategy expand [FEeval]. + (* The result of the normalisation *) Record linear : Type := mk_linear { @@ -732,7 +782,7 @@ Proof. 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)]]. + rewrite H by trivial. ring [ (morph1 CRmorph)]. fold (NPEpow e2 (Npos (p2 - p1))). rewrite NPEpow_correct;simpl. repeat rewrite pow_th.(rpow_pow_N);simpl. @@ -813,7 +863,7 @@ destruct n. (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. + simpl. rewrite Pcompare_refl. simpl. 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). @@ -961,8 +1011,10 @@ Fixpoint Fnorm (e : FExpr) : linear := | FEmul e1 e2 => let x := Fnorm e1 in let y := Fnorm e2 in - mk_linear (NPEmul (num x) (num y)) - (NPEmul (denum x) (denum y)) + let s1 := split (num x) (denum y) in + let s2 := split (num y) (denum x) in + mk_linear (NPEmul (left s1) (left s2)) + (NPEmul (right s2) (right s1)) (condition x ++ condition y) | FEopp e1 => let x := Fnorm e1 in @@ -973,8 +1025,10 @@ Fixpoint Fnorm (e : FExpr) : linear := | FEdiv e1 e2 => let x := Fnorm e1 in let y := Fnorm e2 in - mk_linear (NPEmul (num x) (denum y)) - (NPEmul (denum x) (num y)) + let s1 := split (num x) (num y) in + let s2 := split (denum x) (denum y) in + mk_linear (NPEmul (left s1) (right s2)) + (NPEmul (left s2) (right s1)) (num y :: condition x ++ condition y) | FEpow e1 n => let x := Fnorm e1 in @@ -996,10 +1050,11 @@ 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. + rewrite (@rmul_reg_l _ (pow_pos rmul x p) 0 IHp). + reflexivity. + rewrite H1. ring. rewrite Hp;ring. intro Hp;apply IHp. rewrite (@rmul_reg_l _ (pow_pos rmul x p) 0 IHp). - rewrite Hp;ring. reflexivity. trivial. + reflexivity. rewrite Hp;ring. trivial. Qed. Theorem Pcond_Fnorm: @@ -1040,10 +1095,14 @@ intros l e; elim e. rewrite NPEmul_correct in |- *. simpl in |- *. apply field_is_integral_domain. - apply Hrec1. + intros HH; apply Hrec1. apply PCond_app_inv_l with (1 := Hcond). - apply Hrec2. + rewrite (split_correct_r l (num (Fnorm e2)) (denum (Fnorm e1))). + rewrite NPEmul_correct; simpl; rewrite HH; ring. + intros HH; apply Hrec2. apply PCond_app_inv_r with (1 := Hcond). + rewrite (split_correct_r l (num (Fnorm e1)) (denum (Fnorm e2))). + rewrite NPEmul_correct; simpl; rewrite HH; ring. intros e1 Hrec1 Hcond. simpl condition in Hcond. simpl denum in |- *. @@ -1058,10 +1117,14 @@ intros l e; elim e. rewrite NPEmul_correct in |- *. simpl in |- *. apply field_is_integral_domain. - apply Hrec1. + intros HH; apply Hrec1. 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). + rewrite (split_correct_l l (denum (Fnorm e1)) (denum (Fnorm e2))). + rewrite NPEmul_correct; simpl; rewrite HH; ring. + intros HH; apply PCond_cons_inv_l with (1:=Hcond). + rewrite (split_correct_r l (num (Fnorm e1)) (num (Fnorm e2))). + rewrite NPEmul_correct; simpl; rewrite HH; ring. simpl;intros e1 Hrec1 n Hcond. rewrite NPEpow_correct. simpl;rewrite pow_th.(rpow_pow_N). @@ -1124,7 +1187,16 @@ assert (HH2: PCond l (condition (Fnorm e2))). apply PCond_app_inv_r with ( 1 := HH ). rewrite (He1 HH1); rewrite (He2 HH2). repeat rewrite NPEmul_correct; simpl. -apply rdiv4; auto. +generalize (split_correct_l l (num (Fnorm e1)) (denum (Fnorm e2))) + (split_correct_r l (num (Fnorm e1)) (denum (Fnorm e2))) + (split_correct_l l (num (Fnorm e2)) (denum (Fnorm e1))) + (split_correct_r l (num (Fnorm e2)) (denum (Fnorm e1))). +repeat rewrite NPEmul_correct; simpl. +intros U1 U2 U3 U4; rewrite U1; rewrite U2; rewrite U3; + rewrite U4; simpl. +apply rdiv4b; auto. + rewrite <- U4; auto. + rewrite <- U2; auto. intros e1 He1 HH. rewrite NPEopp_correct; simpl; rewrite (He1 HH); apply rdiv5; auto. @@ -1144,8 +1216,18 @@ apply PCond_app_inv_r with (condition (Fnorm e1)). apply PCond_cons_inv_r with ( 1 := HH ). rewrite (He1 HH1); rewrite (He2 HH2). repeat rewrite NPEmul_correct;simpl. -apply rdiv7; auto. +generalize (split_correct_l l (num (Fnorm e1)) (num (Fnorm e2))) + (split_correct_r l (num (Fnorm e1)) (num (Fnorm e2))) + (split_correct_l l (denum (Fnorm e1)) (denum (Fnorm e2))) + (split_correct_r l (denum (Fnorm e1)) (denum (Fnorm e2))). +repeat rewrite NPEmul_correct; simpl. +intros U1 U2 U3 U4; rewrite U1; rewrite U2; rewrite U3; + rewrite U4; simpl. +apply rdiv7b; auto. + rewrite <- U3; auto. + rewrite <- U2; auto. apply PCond_cons_inv_l with ( 1 := HH ). + rewrite <- U4; auto. intros e1 He1 n Hcond;assert (He1' := He1 Hcond);clear He1. repeat rewrite NPEpow_correct;simpl;repeat rewrite pow_th.(rpow_pow_N). @@ -1155,13 +1237,15 @@ 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 IHp. reflexivity. +apply pow_pos_not_0;trivial. +apply pow_pos_not_0;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. + reflexivity. apply pow_pos_not_0;trivial. ring [Hp]. +rewrite <- rdiv4;trivial. rewrite IHp;reflexivity. +apply pow_pos_not_0;trivial. apply pow_pos_not_0;trivial. reflexivity. Qed. @@ -1174,9 +1258,9 @@ Theorem Fnorm_crossproduct: PCond l (condition nfe1 ++ condition nfe2) -> FEeval l fe1 == FEeval l fe2. intros l fe1 fe2 nfe1 nfe2 Hcrossprod Hcond; subst nfe1 nfe2. -rewrite Fnorm_FEeval_PEeval in |- *. +rewrite Fnorm_FEeval_PEeval in |- * by apply PCond_app_inv_l with (1 := Hcond). - rewrite Fnorm_FEeval_PEeval in |- *. + rewrite Fnorm_FEeval_PEeval in |- * by apply PCond_app_inv_r with (1 := Hcond). apply cross_product_eq; trivial. apply Pcond_Fnorm. @@ -1187,7 +1271,7 @@ 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). +Notation Nmk_monpol_list := (mk_monpol_list cO cI cadd cmul csub copp ceqb cdiv). Theorem Fnorm_correct: forall n l lpe fe, @@ -1198,7 +1282,7 @@ 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. -rewrite (norm_subst_ok Rsth Reqe ARth CRmorph pow_th n l lpe);auto. +rewrite (norm_subst_ok Rsth Reqe ARth CRmorph pow_th cdiv_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. @@ -1270,9 +1354,9 @@ intros l fe1 fe2 nfe1 nfe2 eq1 eq2 Hcrossprod Hcond; subst nfe1 nfe2. apply Fnorm_crossproduct; trivial. match goal with [ |- NPEeval l ?x == NPEeval l ?y] => - rewrite (ring_rw_correct Rsth Reqe ARth CRmorph pow_th get_sign_spec + rewrite (ring_rw_correct Rsth Reqe ARth CRmorph pow_th cdiv_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 + rewrite (ring_rw_correct Rsth Reqe ARth CRmorph pow_th cdiv_th get_sign_spec O nil l I (refl_equal nil) y (refl_equal (Nnorm O nil y))) end. trivial. @@ -1303,14 +1387,14 @@ 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_correct Rsth Reqe ARth CRmorph pow_th get_sign_spec n lpe l +ring_rw_correct Rsth Reqe ARth CRmorph pow_th cdiv_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 + ring_rw_correct Rsth Reqe ARth CRmorph pow_th cdiv_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. @@ -1343,14 +1427,14 @@ 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 +ring_rw_pow_correct Rsth Reqe ARth CRmorph pow_th cdiv_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 + ring_rw_pow_correct Rsth Reqe ARth CRmorph pow_th cdiv_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. @@ -1394,18 +1478,18 @@ Proof. 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. + rewrite <- (AFth.(AFdiv_def)). rewrite rdiv_r_r by 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. + repeat rewrite <- (AFth.(AFdiv_def)). rewrite rdiv_r_r by 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). + repeat rewrite <- Fnorm_FEeval_PEeval ; trivial. + apply (PCond_app_inv_r _ _ _ H7). apply (PCond_app_inv_l _ _ _ H7). Qed. Theorem Field_simplify_eq_in_correct : @@ -1444,18 +1528,18 @@ Proof. 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. + rewrite <- (AFth.(AFdiv_def)). rewrite rdiv_r_r by 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. + repeat rewrite <- (AFth.(AFdiv_def)). rewrite rdiv_r_r by 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). + apply (PCond_app_inv_r _ _ _ H7). apply (PCond_app_inv_l _ _ _ H7). Qed. @@ -1524,7 +1608,7 @@ 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 pow_th O l nil a a0). simpl. +generalize (ring_correct Rsth Reqe ARth CRmorph pow_th cdiv_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. diff --git a/contrib/setoid_ring/InitialRing.v b/contrib/setoid_ring/InitialRing.v index f5f845c2..c1fa963f 100644 --- a/contrib/setoid_ring/InitialRing.v +++ b/contrib/setoid_ring/InitialRing.v @@ -13,13 +13,13 @@ Require Import BinNat. Require Import Setoid. Require Import Ring_theory. Require Import Ring_polynom. +Require Import ZOdiv_def. Import List. Set Implicit Arguments. Import RingSyntax. - (* An object to return when an expression is not recognized as a constant *) Definition NotConstant := false. @@ -101,19 +101,19 @@ Section ZMORPHISM. | _ => None end. - Lemma get_signZ_th : sign_theory ropp req gen_phiZ get_signZ. + Lemma get_signZ_th : sign_theory Zopp Zeq_bool get_signZ. Proof. constructor. destruct c;intros;try discriminate. injection H;clear H;intros H1;subst c'. - simpl;rrefl. + simpl. unfold Zeq_bool. rewrite Zcompare_refl. trivial. Qed. Section ALMOST_RING. Variable ARth : almost_ring_theory 0 1 radd rmul rsub ropp req. Add Morphism rsub : rsub_ext3. exact (ARsub_ext Rsth Reqe ARth). Qed. - Ltac norm := gen_srewrite 0 1 radd rmul rsub ropp req Rsth Reqe ARth. + Ltac norm := gen_srewrite Rsth Reqe ARth. Ltac add_push := gen_add_push radd Rsth Reqe ARth. Lemma same_gen : forall x, gen_phiPOS1 x == gen_phiPOS x. @@ -161,7 +161,7 @@ Section ZMORPHISM. Variable Rth : ring_theory 0 1 radd rmul rsub ropp req. Let ARth := Rth_ARth Rsth Reqe Rth. Add Morphism rsub : rsub_ext4. exact (ARsub_ext Rsth Reqe ARth). Qed. - Ltac norm := gen_srewrite 0 1 radd rmul rsub ropp req Rsth Reqe ARth. + Ltac norm := gen_srewrite Rsth Reqe ARth. Ltac add_push := gen_add_push radd Rsth Reqe ARth. (*morphisms are extensionaly equal*) @@ -243,7 +243,7 @@ Section ZMORPHISM. Zplus Zmult Zeq_bool gen_phiZ). apply mkRmorph;simpl;try rrefl. apply gen_phiZ_add. apply gen_phiZ_mul. apply gen_Zeqb_ok. - apply (Smorph_morph Rsth Reqe Rth Zsth Zth SRmorph gen_phiZ_ext). + apply (Smorph_morph Rsth Reqe Rth Zth SRmorph gen_phiZ_ext). Qed. End ZMORPHISM. @@ -317,8 +317,8 @@ Section NMORPHISM. Add Morphism rmul : rmul_ext4. exact (Rmul_ext Reqe). Qed. Add Morphism ropp : ropp_ext4. exact (Ropp_ext Reqe). Qed. Add Morphism rsub : rsub_ext5. exact (ARsub_ext Rsth Reqe ARth). Qed. - Ltac norm := gen_srewrite 0 1 radd rmul rsub ropp req Rsth Reqe ARth. - + Ltac norm := gen_srewrite Rsth Reqe ARth. + Definition gen_phiN1 x := match x with | N0 => 0 @@ -433,7 +433,7 @@ Section NWORDMORPHISM. Variable ARth : almost_ring_theory 0 1 radd rmul rsub ropp req. Add Morphism rsub : rsub_ext7. exact (ARsub_ext Rsth Reqe ARth). Qed. - Ltac norm := gen_srewrite 0 1 radd rmul rsub ropp req Rsth Reqe ARth. + Ltac norm := gen_srewrite Rsth Reqe ARth. Ltac add_push := gen_add_push radd Rsth Reqe ARth. Fixpoint gen_phiNword (w : Nword) : R := @@ -515,12 +515,12 @@ induction x; intros. simpl Nwadd in |- *. repeat rewrite gen_phiNword_cons in |- *. - rewrite (fun sreq => gen_phiN_add Rsth sreq (ARth_SRth ARth)) in |- *. - destruct Reqe; constructor; trivial. + rewrite (fun sreq => gen_phiN_add Rsth sreq (ARth_SRth ARth)) in |- * by + (destruct Reqe; constructor; trivial). - rewrite IHx in |- *. - norm. - add_push (- gen_phiNword x); reflexivity. + rewrite IHx in |- *. + norm. + add_push (- gen_phiNword x); reflexivity. Qed. Lemma Nwopp_ok : forall x, gen_phiNword (Nwopp x) == - gen_phiNword x. @@ -537,8 +537,8 @@ induction x; intros. simpl Nwscal in |- *. repeat rewrite gen_phiNword_cons in |- *. - rewrite (fun sreq => gen_phiN_mult Rsth sreq (ARth_SRth ARth)) in |- *. - destruct Reqe; constructor; trivial. + rewrite (fun sreq => gen_phiN_mult Rsth sreq (ARth_SRth ARth)) in |- * + by (destruct Reqe; constructor; trivial). rewrite IHx in |- *. norm. @@ -592,7 +592,70 @@ Qed. End NWORDMORPHISM. +Section GEN_DIV. + + Variables (R : Type) (rO : R) (rI : R) (radd : R -> R -> R) + (rmul : R -> R -> R) (rsub : R -> R -> R) (ropp : R -> R) + (req : R -> R -> Prop) (C : Type) (cO : C) (cI : C) + (cadd : C -> C -> C) (cmul : C -> C -> C) (csub : C -> C -> C) + (copp : C -> C) (ceqb : C -> C -> bool) (phi : C -> R). + Variable Rsth : Setoid_Theory R req. + Variable Reqe : ring_eq_ext radd rmul ropp req. + Variable ARth : almost_ring_theory rO rI radd rmul rsub ropp req. + Variable morph : ring_morph rO rI radd rmul rsub ropp req cO cI cadd cmul csub copp ceqb phi. + + (* Useful tactics *) + Add Setoid R req Rsth as R_set1. + Ltac rrefl := gen_reflexivity Rsth. + Add Morphism radd : radd_ext. exact (Radd_ext Reqe). Qed. + Add Morphism rmul : rmul_ext. exact (Rmul_ext Reqe). Qed. + Add Morphism ropp : ropp_ext. exact (Ropp_ext Reqe). Qed. + Add Morphism rsub : rsub_ext. exact (ARsub_ext Rsth Reqe ARth). Qed. + Ltac rsimpl := gen_srewrite Rsth Reqe ARth. + + Definition triv_div x y := + if ceqb x y then (cI, cO) + else (cO, x). + + Ltac Esimpl :=repeat (progress ( + match goal with + | |- context [phi cO] => rewrite (morph0 morph) + | |- context [phi cI] => rewrite (morph1 morph) + | |- context [phi (cadd ?x ?y)] => rewrite ((morph_add morph) x y) + | |- context [phi (cmul ?x ?y)] => rewrite ((morph_mul morph) x y) + | |- context [phi (csub ?x ?y)] => rewrite ((morph_sub morph) x y) + | |- context [phi (copp ?x)] => rewrite ((morph_opp morph) x) + end)). + + Lemma triv_div_th : Ring_theory.div_theory req cadd cmul phi triv_div. + Proof. + constructor. + intros a b;unfold triv_div. + assert (X:= morph.(morph_eq) a b);destruct (ceqb a b). + Esimpl. + rewrite X; trivial. + rsimpl. + Esimpl; rsimpl. +Qed. + + Variable zphi : Z -> R. + + Lemma Ztriv_div_th : div_theory req Zplus Zmult zphi ZOdiv_eucl. + Proof. + constructor. + intros; generalize (ZOdiv_eucl_correct a b); case ZOdiv_eucl; intros; subst. + rewrite Zmult_comm; rsimpl. + Qed. + Variable nphi : N -> R. + + Lemma Ntriv_div_th : div_theory req Nplus Nmult nphi Ndiv_eucl. + constructor. + intros; generalize (Ndiv_eucl_correct a b); case Ndiv_eucl; intros; subst. + rewrite Nmult_comm; rsimpl. + Qed. + +End GEN_DIV. (* syntaxification of constants in an abstract ring: the inverse of gen_phiPOS *) @@ -604,17 +667,17 @@ End NWORDMORPHISM. | (add rI (add rI rI)) => constr:3%positive | (mul (add rI rI) ?p) => (* 2p *) match inv_cst p with - NotConstant => NotConstant - | 1%positive => NotConstant (* 2*1 is not convertible to 2 *) + NotConstant => constr:NotConstant + | 1%positive => constr:NotConstant (* 2*1 is not convertible to 2 *) | ?p => constr:(xO p) end | (add rI (mul (add rI rI) ?p)) => (* 1+2p *) match inv_cst p with - NotConstant => NotConstant - | 1%positive => NotConstant + NotConstant => constr:NotConstant + | 1%positive => constr:NotConstant | ?p => constr:(xI p) end - | _ => NotConstant + | _ => constr:NotConstant end in inv_cst t. @@ -624,7 +687,7 @@ End NWORDMORPHISM. rO => constr:NwO | _ => match inv_gen_phi_pos rI add mul t with - NotConstant => NotConstant + NotConstant => constr:NotConstant | ?p => constr:(Npos p::nil) end end. @@ -636,7 +699,7 @@ End NWORDMORPHISM. rO => constr:0%N | _ => match inv_gen_phi_pos rI add mul t with - NotConstant => NotConstant + NotConstant => constr:NotConstant | ?p => constr:(Npos p) end end. @@ -647,12 +710,12 @@ End NWORDMORPHISM. rO => constr:0%Z | (opp ?p) => match inv_gen_phi_pos rI add mul p with - NotConstant => NotConstant + NotConstant => constr:NotConstant | ?p => constr:(Zneg p) end | _ => match inv_gen_phi_pos rI add mul t with - NotConstant => NotConstant + NotConstant => constr:NotConstant | ?p => constr:(Zpos p) end end. @@ -668,7 +731,7 @@ Ltac inv_gen_phi rO rI cO cI t := end. (* A simple tactic recognizing no constant *) - Ltac inv_morph_nothing t := constr:(NotConstant). + Ltac inv_morph_nothing t := constr:NotConstant. Ltac coerce_to_almost_ring set ext rspec := match type of rspec with @@ -710,31 +773,42 @@ Ltac gen_ring_pow set arth pspec := | Some ?t => constr:(t) end. -Ltac default_sign_spec morph := +Ltac gen_ring_sign morph sspec := + match sspec with + | None => + match type of morph with + | @ring_morph ?R ?r0 ?rI ?radd ?rmul ?rsub ?ropp ?req + Z ?c0 ?c1 ?cadd ?cmul ?csub ?copp ?ceqb ?phi => + constr:(@mkhypo (sign_theory copp ceqb get_signZ) get_signZ_th) + | @ring_morph ?R ?r0 ?rI ?radd ?rmul ?rsub ?ropp ?req + ?C ?c0 ?c1 ?cadd ?cmul ?csub ?copp ?ceqb ?phi => + constr:(mkhypo (@get_sign_None_th C copp ceqb)) + | _ => fail 2 "ring anomaly : default_sign_spec" + end + | Some ?t => constr:(t) + end. + +Ltac default_div_spec set reqe arth morph := match type of morph with | @ring_morph ?R ?r0 ?rI ?radd ?rmul ?rsub ?ropp ?req + Z ?c0 ?c1 Zplus Zmult ?csub ?copp ?ceq_b ?phi => + constr:(mkhypo (Ztriv_div_th set phi)) + | @ring_morph ?R ?r0 ?rI ?radd ?rmul ?rsub ?ropp ?req + N ?c0 ?c1 Nplus Nmult ?csub ?copp ?ceq_b ?phi => + constr:(mkhypo (Ntriv_div_th set phi)) + | @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)) + constr:(mkhypo (triv_div_th set reqe arth morph)) | _ => 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 +Ltac gen_ring_div set reqe arth morph dspec := + match dspec with + | None => default_div_spec set reqe arth morph | Some ?t => constr:(t) end. - - -Ltac ring_elements set ext rspec pspec sspec rk := + +Ltac ring_elements set ext rspec pspec sspec dspec rk := let arth := coerce_to_almost_ring set ext rspec in let ext_r := coerce_to_ring_ext ext in let morph := @@ -756,42 +830,54 @@ Ltac ring_elements set ext rspec pspec sspec rk := | _ => fail 1 "ill-formed ring kind" end in 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. + let s_spec := gen_ring_sign morph sspec in + let d_spec := gen_ring_div set ext_r arth morph dspec in + fun f => f arth ext_r morph p_spec s_spec d_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 := + + Ltac ring_lemmas set ext rspec pspec sspec dspec 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" + ring_elements set ext rspec pspec sspec dspec rk + ltac:(fun arth ext_r morph p_spec s_spec d_spec => + 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 => + let gen_lemma2_0 := + constr:(gen_lemma2 R r0 rI radd rmul rsub ropp req set ext_r arth + C c0 c1 cadd cmul csub copp ceq_b phi morph) in + match p_spec with + | @mkhypo (power_theory _ _ _ ?Cp_phi ?rpow) ?pp_spec => + let gen_lemma2_1 := constr:(gen_lemma2_0 _ Cp_phi rpow pp_spec) in + match d_spec with + | @mkhypo (div_theory _ _ _ _ ?cdiv) ?dd_spec => + let gen_lemma2_2 := constr:(gen_lemma2_1 cdiv dd_spec) in + match s_spec with + | @mkhypo (sign_theory _ _ ?get_sign) ?ss_spec => + let lemma2 := constr:(gen_lemma2_2 get_sign ss_spec) in + let lemma1 := + constr:(ring_correct set ext_r arth morph pp_spec dd_spec) in + fun f => f arth ext_r morph lemma1 lemma2 + | _ => fail 4 "ring: bad sign specification" + end + | _ => fail 3 "ring: bad coefficiant division specification" + end + | _ => fail 2 "ring: bad power specification" + end + | _ => fail 1 "ring internal error: ring_lemmas, please report" end). - + (* Tactic for constant *) Ltac isnatcst t := match t with - O => true + O => constr:true | S ?p => isnatcst p - | _ => false + | _ => constr:false end. Ltac isPcst t := @@ -801,7 +887,7 @@ Ltac isPcst t := | xH => constr:true (* nat -> positive *) | P_of_succ_nat ?n => isnatcst n - | _ => false + | _ => constr:false end. Ltac isNcst t := @@ -813,7 +899,7 @@ Ltac isNcst t := Ltac isZcst t := match t with - Z0 => true + Z0 => constr:true | Zpos ?p => isPcst p | Zneg ?p => isPcst p (* injection nat -> Z *) @@ -821,7 +907,7 @@ Ltac isZcst t := (* injection N -> Z *) | Z_of_N ?n => isNcst n (* *) - | _ => false + | _ => constr:false end. diff --git a/contrib/setoid_ring/NArithRing.v b/contrib/setoid_ring/NArithRing.v index ae067a8a..0ba519fd 100644 --- a/contrib/setoid_ring/NArithRing.v +++ b/contrib/setoid_ring/NArithRing.v @@ -15,7 +15,7 @@ Set Implicit Arguments. Ltac Ncst t := match isNcst t with true => t - | _ => NotConstant + | _ => constr:NotConstant end. Add Ring Nr : Nth (decidable Neq_bool_ok, constants [Ncst]). diff --git a/contrib/setoid_ring/RealField.v b/contrib/setoid_ring/RealField.v index d0512dff..60641bcf 100644 --- a/contrib/setoid_ring/RealField.v +++ b/contrib/setoid_ring/RealField.v @@ -130,4 +130,5 @@ 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 1a4e1cc7..d01b1625 100644 --- a/contrib/setoid_ring/Ring.v +++ b/contrib/setoid_ring/Ring.v @@ -38,7 +38,7 @@ Ltac bool_cst t := match t with true => constr:true | false => constr:false - | _ => NotConstant + | _ => constr:NotConstant end. Add Ring bool_ring : BoolTheory (decidable bool_eq_ok, constants [bool_cst]). diff --git a/contrib/setoid_ring/Ring_polynom.v b/contrib/setoid_ring/Ring_polynom.v index b79f2fe2..d8847036 100644 --- a/contrib/setoid_ring/Ring_polynom.v +++ b/contrib/setoid_ring/Ring_polynom.v @@ -43,6 +43,10 @@ Section MakeRingPol. Variable rpow : R -> Cpow -> R. Variable pow_th : power_theory rI rmul req Cp_phi rpow. + (* division is ok *) + Variable cdiv: C -> C -> C * C. + Variable div_th: div_theory req cadd cmul phi cdiv. + (* R notations *) Notation "0" := rO. Notation "1" := rI. @@ -55,14 +59,14 @@ Section MakeRingPol. Notation "x -! y " := (csub x y). Notation "-! x" := (copp x). Notation " x ?=! y" := (ceqb x y). Notation "[ x ]" := (phi x). - (* Usefull tactics *) + (* Useful tactics *) Add Setoid R req Rsth as R_set1. Ltac rrefl := gen_reflexivity Rsth. Add Morphism radd : radd_ext. exact (Radd_ext Reqe). Qed. Add Morphism rmul : rmul_ext. exact (Rmul_ext Reqe). Qed. Add Morphism ropp : ropp_ext. exact (Ropp_ext Reqe). Qed. Add Morphism rsub : rsub_ext. exact (ARsub_ext Rsth Reqe ARth). Qed. - Ltac rsimpl := gen_srewrite 0 1 radd rmul rsub ropp req Rsth Reqe ARth. + Ltac rsimpl := gen_srewrite Rsth Reqe ARth. Ltac add_push := gen_add_push radd Rsth Reqe ARth. Ltac mul_push := gen_mul_push rmul Rsth Reqe ARth. @@ -411,63 +415,79 @@ Section MakeRingPol. | vmon i' m => vmon (i+i') m end. - Fixpoint MFactor (P: Pol) (M: Mon) {struct P}: Pol * Pol := + Fixpoint CFactor (P: Pol) (c: C) {struct P}: Pol * Pol := + match P with + | Pc c1 => let (q,r) := cdiv c1 c in (Pc r, Pc q) + | Pinj j1 P1 => + let (R,S) := CFactor P1 c in + (mkPinj j1 R, mkPinj j1 S) + | PX P1 i Q1 => + let (R1, S1) := CFactor P1 c in + let (R2, S2) := CFactor Q1 c in + (mkPX R1 i R2, mkPX S1 i S2) + end. + + Fixpoint MFactor (P: Pol) (c: C) (M: Mon) {struct P}: Pol * Pol := match P, M with - _, mon0 => (Pc cO, P) + _, mon0 => + if (ceqb c cI) then (Pc cO, P) else +(* if (ceqb c (copp cI)) then (Pc cO, Popp P) else Not in almost ring *) + CFactor P c | Pc _, _ => (P, Pc cO) | Pinj j1 P1, zmon j2 M1 => match (j1 ?= j2) Eq with - Eq => let (R,S) := MFactor P1 M1 in + Eq => let (R,S) := MFactor P1 c M1 in (mkPinj j1 R, mkPinj j1 S) - | Lt => let (R,S) := MFactor P1 (zmon (j2 - j1) M1) in + | Lt => let (R,S) := MFactor P1 c (zmon (j2 - j1) M1) in (mkPinj j1 R, mkPinj j1 S) | Gt => (P, Pc cO) end | Pinj _ _, vmon _ _ => (P, Pc cO) | PX P1 i Q1, zmon j M1 => let M2 := zmon_pred j M1 in - let (R1, S1) := MFactor P1 M in - let (R2, S2) := MFactor Q1 M2 in + let (R1, S1) := MFactor P1 c M in + let (R2, S2) := MFactor Q1 c M2 in (mkPX R1 i R2, mkPX S1 i S2) | PX P1 i Q1, vmon j M1 => match (i ?= j) Eq with - Eq => let (R1,S1) := MFactor P1 (mkZmon xH M1) in + Eq => let (R1,S1) := MFactor P1 c (mkZmon xH M1) in (mkPX R1 i Q1, S1) - | Lt => let (R1,S1) := MFactor P1 (vmon (j - i) M1) in + | Lt => let (R1,S1) := MFactor P1 c (vmon (j - i) M1) in (mkPX R1 i Q1, S1) - | Gt => let (R1,S1) := MFactor P1 (mkZmon xH M1) in + | Gt => let (R1,S1) := MFactor P1 c (mkZmon xH M1) in (mkPX R1 i Q1, mkPX S1 (i-j) (Pc cO)) end end. - Definition POneSubst (P1: Pol) (M1: Mon) (P2: Pol): option Pol := - let (Q1,R1) := MFactor P1 M1 in + Definition POneSubst (P1: Pol) (cM1: C * Mon) (P2: Pol): option Pol := + let (c,M1) := cM1 in + let (Q1,R1) := MFactor P1 c M1 in match R1 with (Pc c) => if c ?=! cO then None else Some (Padd Q1 (Pmul P2 R1)) | _ => Some (Padd Q1 (Pmul P2 R1)) end. - Fixpoint PNSubst1 (P1: Pol) (M1: Mon) (P2: Pol) (n: nat) {struct n}: Pol := - match POneSubst P1 M1 P2 with - Some P3 => match n with S n1 => PNSubst1 P3 M1 P2 n1 | _ => P3 end + Fixpoint PNSubst1 (P1: Pol) (cM1: C * Mon) (P2: Pol) (n: nat) {struct n}: Pol := + match POneSubst P1 cM1 P2 with + Some P3 => match n with S n1 => PNSubst1 P3 cM1 P2 n1 | _ => P3 end | _ => P1 end. - Definition PNSubst (P1: Pol) (M1: Mon) (P2: Pol) (n: nat): option Pol := - match POneSubst P1 M1 P2 with - Some P3 => match n with S n1 => Some (PNSubst1 P3 M1 P2 n1) | _ => None end + Definition PNSubst (P1: Pol) (cM1: C * Mon) (P2: Pol) (n: nat): option Pol := + match POneSubst P1 cM1 P2 with + Some P3 => match n with S n1 => Some (PNSubst1 P3 cM1 P2 n1) | _ => None end | _ => None end. - Fixpoint PSubstL1 (P1: Pol) (LM1: list (Mon * Pol)) (n: nat) {struct LM1}: + Fixpoint PSubstL1 (P1: Pol) (LM1: list ((C * Mon) * Pol)) (n: nat) {struct LM1}: Pol := match LM1 with cons (M1,P2) LM2 => PSubstL1 (PNSubst1 P1 M1 P2 n) LM2 n | _ => P1 end. - Fixpoint PSubstL (P1: Pol) (LM1: list (Mon * Pol)) (n: nat) {struct LM1}: option Pol := + Fixpoint PSubstL (P1: Pol) (LM1: list ((C * Mon) * Pol)) (n: nat) {struct LM1}: option Pol := match LM1 with cons (M1,P2) LM2 => match PNSubst P1 M1 P2 n with @@ -477,7 +497,7 @@ Section MakeRingPol. | _ => None end. - Fixpoint PNSubstL (P1: Pol) (LM1: list (Mon * Pol)) (m n: nat) {struct m}: Pol := + Fixpoint PNSubstL (P1: Pol) (LM1: list ((C * Mon) * Pol)) (m n: nat) {struct m}: Pol := match PSubstL P1 LM1 n with Some P3 => match m with S m1 => PNSubstL P3 LM1 m1 n | _ => P3 end | _ => P1 @@ -579,16 +599,22 @@ Section MakeRingPol. Ltac Esimpl := repeat (progress ( match goal with - | |- context [P0@?l] => rewrite (Pphi0 l) - | |- context [P1@?l] => rewrite (Pphi1 l) - | |- context [(mkPinj ?j ?P)@?l] => rewrite (mkPinj_ok j l P) - | |- context [(mkPX ?P ?i ?Q)@?l] => rewrite (mkPX_ok l P i Q) - | |- context [[cO]] => rewrite (morph0 CRmorph) - | |- context [[cI]] => rewrite (morph1 CRmorph) - | |- context [[?x +! ?y]] => rewrite ((morph_add CRmorph) x y) - | |- context [[?x *! ?y]] => rewrite ((morph_mul CRmorph) x y) - | |- context [[?x -! ?y]] => rewrite ((morph_sub CRmorph) x y) - | |- context [[-! ?x]] => rewrite ((morph_opp CRmorph) x) + | |- context [?P@?l] => + match P with + | P0 => rewrite (Pphi0 l) + | P1 => rewrite (Pphi1 l) + | (mkPinj ?j ?P) => rewrite (mkPinj_ok j l P) + | (mkPX ?P ?i ?Q) => rewrite (mkPX_ok l P i Q) + end + | |- context [[?c]] => + match c with + | cO => rewrite (morph0 CRmorph) + | cI => rewrite (morph1 CRmorph) + | ?x +! ?y => rewrite ((morph_add CRmorph) x y) + | ?x *! ?y => rewrite ((morph_mul CRmorph) x y) + | ?x -! ?y => rewrite ((morph_sub CRmorph) x y) + | -! ?x => rewrite ((morph_opp CRmorph) x) + end end)); rsimpl; simpl. @@ -876,38 +902,82 @@ Lemma Pmul_ok : forall P P' l, (P**P')@l == P@l * P'@l. rewrite Pplus_comm;rewrite pow_pos_Pplus;rsimpl. Qed. - - Lemma Mphi_ok: forall P M l, - let (Q,R) := MFactor P M in - P@l == Q@l + (Mphi l M) * (R@l). + Lemma Mcphi_ok: forall P c l, + let (Q,R) := CFactor P c in + P@l == Q@l + (phi c) * (R@l). Proof. intros P; elim P; simpl; auto; clear P. - intros c M l; case M; simpl; auto; try intro p; try intro m; - try rewrite (morph0 CRmorph); rsimpl. + intros c c1 l; generalize (div_th.(div_eucl_th) c c1); case cdiv. + intros q r H; rewrite H. + Esimpl. + rewrite (ARadd_comm ARth); rsimpl. + intros i P Hrec c l. + generalize (Hrec c (jump i l)); case CFactor. + intros R1 S1; Esimpl; auto. + intros Q1 Qrec i R1 Rrec c l. + generalize (Qrec c l); case CFactor; intros S1 S2 HS. + generalize (Rrec c (tail l)); case CFactor; intros S3 S4 HS1. + rewrite HS; rewrite HS1; Esimpl. + apply (Radd_ext Reqe); rsimpl. + repeat rewrite <- (ARadd_assoc ARth). + apply (Radd_ext Reqe); rsimpl. + rewrite (ARadd_comm ARth); rsimpl. + Qed. - intros i P Hrec M l; case M; simpl; clear M. - rewrite (morph0 CRmorph); rsimpl. + Lemma Mphi_ok: forall P (cM: C * Mon) l, + let (c,M) := cM in + let (Q,R) := MFactor P c M in + P@l == Q@l + (phi c) * (Mphi l M) * (R@l). + Proof. + intros P; elim P; simpl; auto; clear P. + intros c (c1, M) l; case M; simpl; auto. + assert (H1:= morph_eq CRmorph c1 cI);destruct (c1 ?=! cI). + rewrite (H1 (refl_equal true));Esimpl. + try rewrite (morph0 CRmorph); rsimpl. + generalize (div_th.(div_eucl_th) c c1); case (cdiv c c1). + intros q r H; rewrite H; clear H H1. + Esimpl. + rewrite (ARadd_comm ARth); rsimpl. + intros p m; Esimpl. + intros p m; Esimpl. + intros i P Hrec (c,M) l; case M; simpl; clear M. + assert (H1:= morph_eq CRmorph c cI);destruct (c ?=! cI). + rewrite (H1 (refl_equal true));Esimpl. + Esimpl. + generalize (Mcphi_ok P c (jump i l)); case CFactor. + intros R1 Q1 HH; rewrite HH; Esimpl. intros j M. case_eq ((i ?= j) Eq); intros He; simpl. rewrite (Pcompare_Eq_eq _ _ He). - generalize (Hrec M (jump j l)); case (MFactor P M); + generalize (Hrec (c, M) (jump j l)); case (MFactor P c M); simpl; intros P2 Q2 H; repeat rewrite mkPinj_ok; auto. - generalize (Hrec (zmon (j -i) M) (jump i l)); - case (MFactor P (zmon (j -i) M)); simpl. + generalize (Hrec (c, (zmon (j -i) M)) (jump i l)); + case (MFactor P c (zmon (j -i) M)); simpl. intros P2 Q2 H; repeat rewrite mkPinj_ok; auto. rewrite <- (Pplus_minus _ _ (ZC2 _ _ He)). rewrite Pplus_comm; rewrite jump_Pplus; auto. rewrite (morph0 CRmorph); rsimpl. intros P2 m; rewrite (morph0 CRmorph); rsimpl. - intros P2 Hrec1 i Q2 Hrec2 M l; case M; simpl; auto. - rewrite (morph0 CRmorph); rsimpl. + intros P2 Hrec1 i Q2 Hrec2 (c, M) l; case M; simpl; auto. + assert (H1:= morph_eq CRmorph c cI);destruct (c ?=! cI). + rewrite (H1 (refl_equal true));Esimpl. + Esimpl. + generalize (Mcphi_ok P2 c l); case CFactor. + intros S1 S2 HS. + generalize (Mcphi_ok Q2 c (tail l)); case CFactor. + intros S3 S4 HS1; Esimpl; rewrite HS; rewrite HS1. + rsimpl. + apply (Radd_ext Reqe); rsimpl. + repeat rewrite <- (ARadd_assoc ARth). + apply (Radd_ext Reqe); rsimpl. + rewrite (ARadd_comm ARth); rsimpl. intros j M1. - generalize (Hrec1 (zmon j M1) l); - case (MFactor P2 (zmon j M1)). + generalize (Hrec1 (c,zmon j M1) l); + case (MFactor P2 c (zmon j M1)). intros R1 S1 H1. - generalize (Hrec2 (zmon_pred j M1) (List.tail l)); - case (MFactor Q2 (zmon_pred j M1)); simpl. + generalize (Hrec2 (c, zmon_pred j M1) (List.tail l)); + case (MFactor Q2 c (zmon_pred j M1)); simpl. intros R2 S2 H2; rewrite H1; rewrite H2. repeat rewrite mkPX_ok; simpl. rsimpl. @@ -919,7 +989,7 @@ Lemma Pmul_ok : forall P P' l, (P**P')@l == P@l * P'@l. intros j M1. case_eq ((i ?= j) Eq); intros He; simpl. rewrite (Pcompare_Eq_eq _ _ He). - generalize (Hrec1 (mkZmon xH M1) l); case (MFactor P2 (mkZmon xH M1)); + generalize (Hrec1 (c, mkZmon xH M1) l); case (MFactor P2 c (mkZmon xH M1)); simpl; intros P3 Q3 H; repeat rewrite mkPinj_ok; auto. rewrite H; rewrite mkPX_ok; rsimpl. repeat (rewrite <-(ARadd_assoc ARth)). @@ -929,9 +999,11 @@ Lemma Pmul_ok : forall P P' l, (P**P')@l == P@l * P'@l. repeat (rewrite <-(ARmul_assoc ARth)). rewrite mkZmon_ok. apply rmul_ext; rsimpl. + repeat (rewrite <-(ARmul_assoc ARth)). + apply rmul_ext; rsimpl. rewrite (ARmul_comm ARth); rsimpl. - generalize (Hrec1 (vmon (j - i) M1) l); - case (MFactor P2 (vmon (j - i) M1)); + generalize (Hrec1 (c, vmon (j - i) M1) l); + case (MFactor P2 c (vmon (j - i) M1)); simpl; intros P3 Q3 H; repeat rewrite mkPinj_ok; auto. rewrite H; rsimpl; repeat rewrite mkPinj_ok; auto. rewrite mkPX_ok; rsimpl. @@ -943,10 +1015,13 @@ Lemma Pmul_ok : forall P P' l, (P**P')@l == P@l * P'@l. apply rmul_ext; rsimpl. rewrite (ARmul_comm ARth); rsimpl. apply rmul_ext; rsimpl. + rewrite <- (ARmul_comm ARth (Mphi (tail l) M1)); rsimpl. + repeat (rewrite <-(ARmul_assoc ARth)). + apply rmul_ext; rsimpl. rewrite <- pow_pos_Pplus. rewrite (Pplus_minus _ _ (ZC2 _ _ He)); rsimpl. - generalize (Hrec1 (mkZmon 1 M1) l); - case (MFactor P2 (mkZmon 1 M1)); + generalize (Hrec1 (c, mkZmon 1 M1) l); + case (MFactor P2 c (mkZmon 1 M1)); simpl; intros P3 Q3 H; repeat rewrite mkPinj_ok; auto. rewrite H; rsimpl. rewrite mkPX_ok; rsimpl. @@ -963,6 +1038,9 @@ Lemma Pmul_ok : forall P P' l, (P**P')@l == P@l * P'@l. repeat (rewrite <-(ARmul_assoc ARth)). rewrite (ARmul_comm ARth (Q3@l)); rsimpl. apply rmul_ext; rsimpl. + rewrite (ARmul_comm ARth); rsimpl. + repeat (rewrite <- (ARmul_assoc ARth)). + apply rmul_ext; rsimpl. rewrite <- pow_pos_Pplus. rewrite (Pplus_minus _ _ He); rsimpl. Qed. @@ -970,10 +1048,10 @@ Lemma Pmul_ok : forall P P' l, (P**P')@l == P@l * P'@l. (* 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. + POneSubst P1 M1 P2 = Some P3 -> phi (fst M1) * Mphi l (snd 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 P2 (cc,M1) P3 P4 l; unfold POneSubst. + generalize (Mphi_ok P2 (cc, M1) l); case (MFactor P2 cc M1); simpl; auto. intros Q1 R1; case R1. intros c H; rewrite H. generalize (morph_eq CRmorph c cO); @@ -986,7 +1064,7 @@ Lemma Pmul_ok : forall P P' l, (P**P')@l == P@l * P'@l. 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 PmulI_ok. intros;apply Pmul_ok. rewrite H1; rsimpl. + rewrite Padd_ok; rewrite PmulI_ok by (intros;apply Pmul_ok). rewrite H1; rsimpl. intros i P5 P6 H1 H2 H3; rewrite H1; rewrite H3. assert (P4 = Q1 ++ P3 ** PX i P5 P6). injection H2; intros; subst;trivial. @@ -1017,7 +1095,7 @@ Proof. Qed. *) Lemma PNSubst1_ok: forall n P1 M1 P2 l, - Mphi l M1 == P2@l -> P1@l == (PNSubst1 P1 M1 P2 n)@l. + [fst M1] * Mphi l (snd M1) == P2@l -> P1@l == (PNSubst1 P1 M1 P2 n)@l. Proof. intros n; elim n; simpl; auto. intros P2 M1 P3 l H. @@ -1031,19 +1109,19 @@ Proof. Qed. Lemma PNSubst_ok: forall n P1 M1 P2 l P3, - PNSubst P1 M1 P2 n = Some P3 -> Mphi l M1 == P2@l -> P1@l == P3@l. + PNSubst P1 M1 P2 n = Some P3 -> [fst M1] * Mphi l (snd M1) == P2@l -> P1@l == P3@l. Proof. - intros n P2 M1 P3 l P4; unfold PNSubst. - generalize (fun P4 => @POneSubst_ok P2 M1 P3 P4 l); - case (POneSubst P2 M1 P3); [idtac | intros; discriminate]. + intros n P2 (cc, M1) P3 l P4; unfold PNSubst. + generalize (fun P4 => @POneSubst_ok P2 (cc,M1) P3 P4 l); + case (POneSubst P2 (cc,M1) P3); [idtac | intros; discriminate]. intros P5 H1; case n; try (intros; discriminate). intros n1 H2; injection H2; intros; subst. rewrite <- PNSubst1_ok; auto. Qed. - Fixpoint MPcond (LM1: list (Mon * Pol)) (l: list R) {struct LM1} : Prop := + Fixpoint MPcond (LM1: list (C * Mon * Pol)) (l: list R) {struct LM1} : Prop := match LM1 with - cons (M1,P2) LM2 => (Mphi l M1 == P2@l) /\ (MPcond LM2 l) + cons (M1,P2) LM2 => ([fst M1] * Mphi l (snd M1) == P2@l) /\ (MPcond LM2 l) | _ => True end. @@ -1108,6 +1186,8 @@ Proof. | PEpow pe1 n => rpow (PEeval l pe1) (Cp_phi n) end. +Strategy expand [PEeval]. + (** Correctness proofs *) Lemma mkX_ok : forall p l, nth 0 p l == (mk_X p) @ l. @@ -1180,7 +1260,7 @@ Section POWER. 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. + Proof. destruct n;simpl. rrefl. rewrite Ppow_pos_ok by trivial. Esimpl. Qed. End POWER. @@ -1188,7 +1268,7 @@ Section POWER. Section NORM_SUBST_REC. Variable n : nat. - Variable lmp:list (Mon*Pol). + Variable lmp:list (C*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. @@ -1256,7 +1336,7 @@ Section POWER. rewrite IHpe1;rewrite IHpe2;rrefl. rewrite IHpe1;rewrite IHpe2. rewrite Pmul_ok. rrefl. rewrite IHpe;rrefl. - rewrite Ppow_N_ok. intros;rrefl. + rewrite Ppow_N_ok by (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. @@ -1282,24 +1362,24 @@ Section POWER. end end. - Fixpoint mon_of_pol (P:Pol) : option Mon := + Fixpoint mon_of_pol (P:Pol) : option (C * Mon) := match P with - | Pc c => if (c ?=! cI) then Some mon0 else None + | Pc c => if (c ?=! cO) then None else Some (c, mon0) | Pinj j P => match mon_of_pol P with | None => None - | Some m => Some (mkZmon j m) + | Some (c,m) => Some (c, 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) + | Some (c,m) => Some (c, mkVmon i m) end else None end. - Fixpoint mk_monpol_list (lpe:list (PExpr * PExpr)) : list (Mon*Pol) := + Fixpoint mk_monpol_list (lpe:list (PExpr * PExpr)) : list (C*Mon*Pol) := match lpe with | nil => nil | (me,pe)::lpe => @@ -1310,16 +1390,18 @@ Section POWER. end. Lemma mon_of_pol_ok : forall P m, mon_of_pol P = Some m -> - forall l, Mphi l m == P@l. + forall l, [fst m] * Mphi l (snd 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. + assert (H1 := (morph_eq CRmorph) c cO). + destruct (c ?=! cO). discriminate. - generalize H;clear H;case_eq (mon_of_pol P);intros;try discriminate. - inversion H0. - rewrite mkZmon_ok;simpl;auto. + inversion H;trivial;Esimpl. + generalize H;clear H;case_eq (mon_of_pol P). + intros (c1,P2) H0 H1; inversion H1; Esimpl. + generalize (IHP (c1, P2) H0 (jump p l)). + rewrite mkZmon_ok;simpl;auto. + intros; discriminate. generalize H;clear H;change match P3 with | Pc c => c ?=! cO | Pinj _ _ => false @@ -1327,10 +1409,13 @@ Section POWER. end with (P3 ?== P0). assert (H := Peq_ok P3 P0). destruct (P3 ?== P0). - case_eq (mon_of_pol P2);intros. + case_eq (mon_of_pol P2);try intros (cc, pp); intros. inversion H1. + simpl. rewrite mkVmon_ok;simpl. - rewrite H;trivial;Esimpl. rewrite IHP1;trivial;Esimpl. discriminate. + rewrite H;trivial;Esimpl. + generalize (IHP1 _ H0); simpl; intros HH; rewrite HH; rsimpl. + discriminate. intros;discriminate. Qed. @@ -1342,7 +1427,7 @@ Section POWER. 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. + rewrite <- norm_subst_spec by 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. @@ -1371,7 +1456,7 @@ Section POWER. (** 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. + Variable get_sign_spec : sign_theory copp ceqb get_sign. Section EVALUATION. @@ -1509,7 +1594,7 @@ Section POWER. 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 (CRmorph.(morph_eq) _ _ (get_sign_spec.(sign_spec) _ H)). Esimpl. rewrite H1;trivial. rewrite <- r_list_pow_rev;trivial;Esimpl. apply mkmultm1_ok. rewrite <- r_list_pow_rev; apply mkmult_rec_ok. @@ -1520,7 +1605,7 @@ Qed. Proof. intros;unfold mkadd_mult. case_eq (get_sign c);intros. - rewrite (get_sign_spec.(sign_spec) _ H). + rewrite (CRmorph.(morph_eq) _ _ (get_sign_spec.(sign_spec) _ H));Esimpl. rewrite mkmult_c_pos_ok;Esimpl. rewrite mkmult_c_pos_ok;Esimpl. Qed. diff --git a/contrib/setoid_ring/Ring_tac.v b/contrib/setoid_ring/Ring_tac.v index d8bb9eae..46d106d3 100644 --- a/contrib/setoid_ring/Ring_tac.v +++ b/contrib/setoid_ring/Ring_tac.v @@ -16,11 +16,6 @@ Ltac compute_assertion id id' t := [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 *) @@ -47,10 +42,10 @@ Ltac ApplyLemmaThen lemma expr tac := 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)). + 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 @@ -143,13 +138,11 @@ Ltac mkPolexpr C Cst CstPow radd rmul rsub ropp rpow t fv := Ltac ParseRingComponents lemma := match type of lemma with - | context - [@PEeval ?R ?rO ?add ?mul ?sub ?opp ?C ?phi ?Cpow ?powphi ?pow _ _] => + | 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 relation_carrier req := @@ -175,7 +168,7 @@ Ltac mkHyp_tac C req mkPE lH := let pe1 := mkPE r1 in let pe2 := mkPE r2 in constr:(cons (pe1,pe2) res) - | _ => fail "hypothesis is not a ring equality" + | _ => fail 1 "hypothesis is not a ring equality" end in list_fold_right mkHyp (@nil (PExpr C * PExpr C)) lH. @@ -226,12 +219,6 @@ Ltac Ring_norm_gen f Cst_tac CstPow_tac lemma2 req n lH rl := 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 @@ -240,25 +227,34 @@ Ltac Ring_norm_gen f Cst_tac CstPow_tac lemma2 req n lH rl := 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 => + match type of lemma2 with + | context [mk_monpol_list ?cO ?cI ?cadd ?cmul ?csub ?copp ?cdiv ?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 + (mk_monpol_list cO cI cadd cmul csub copp cdiv ceqb vlpe); + (assert (rr_lemma := lemma2 n vlpe fv prh vlmp vlmp_eq) + || fail 1 "type error when build the rewriting lemma"); + RW_tac rr_lemma; + try clear rr_lemma vlmp_eq vlmp vlpe + | _ => fail 1 "ring_simplify anomaly: bad correctness lemma" + end 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. +Ltac Get_goal := match goal with [|- ?G] => G end. + Tactic Notation (at level 0) "ring" := - let G := getGoal in ring_lookup Ring_gen [] [G]. + let G := Get_goal 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]. + let G := Get_goal in + ring_lookup Ring_gen [lH] G. (* Simplification *) @@ -269,67 +265,89 @@ Ltac Ring_simplify_gen f := generalize (refl_equal l); unfold l at 2; pre(); - match goal with - | [|- l = ?RL -> _ ] => + let Tac 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. + post() in + let Main := + match goal with + | [|- l = ?RL -> _ ] => (fun f => f RL) + | _ => fail 1 "ring_simplify anomaly: bad goal after pre" + end in + Main Tac. 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(rl) := + let G := Get_goal in + ring_lookup Ring_simplify [] rl G. 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]. + let G := Get_goal in + ring_lookup Ring_simplify [lH] rl G. +(* MON DIEU QUE C'EST MOCHE !!!!!!!!!!!!! *) 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. + let G := Get_goal 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 := Get_goal 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. + + + +(* LE RESTE MARCHE PAS DOMMAGE ..... *) + + + + + + + + + + + + + (* + + + + + + + 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. + 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. + 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):= @@ -339,7 +357,7 @@ Tactic Notation (at level 0) 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]. + [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). @@ -352,7 +370,7 @@ Tactic Notation (at level 0) pre(); Ring_simpl_in h cst_tac pow_tac lemma2 req ring_subst_niter lH rl; post()) - [] rl [t]. + [] rl t. Ltac rw_in H Heq := rewrite Heq in H. @@ -363,7 +381,7 @@ Ltac simpl_in H := pre(); Ring_norm_gen ltac:(fun Heq => rewrite Heq in H) cst_tac pow_tac lemma2 req ring_subst_niter lH rl; post()) - [] [t]. + [] t. *) diff --git a/contrib/setoid_ring/Ring_theory.v b/contrib/setoid_ring/Ring_theory.v index 5498911d..29feab5c 100644 --- a/contrib/setoid_ring/Ring_theory.v +++ b/contrib/setoid_ring/Ring_theory.v @@ -19,7 +19,7 @@ Reserved Notation "x -! y" (at level 50, left associativity). Reserved Notation "x *! y" (at level 40, left associativity). Reserved Notation "-! x" (at level 35, right associativity). -Reserved Notation "[ x ]" (at level 1, no associativity). +Reserved Notation "[ x ]" (at level 0). Reserved Notation "x ?== y" (at level 70, no associativity). Reserved Notation "x -- y" (at level 50, left associativity). @@ -59,8 +59,7 @@ Section Power. 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. + setoid_rewrite (mul_comm x (pow_pos x j)) at 2. repeat rewrite mul_assoc. apply (Seq_refl _ _ Rsth). repeat rewrite mul_assoc. apply (Seq_refl _ _ Rsth). apply (Seq_refl _ _ Rsth). @@ -198,7 +197,7 @@ Section DEFINITIONS. 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'] + sign_spec : forall c c', get_sign c = Some c' -> c ?=! -! c' = true }. End SIGN. @@ -207,6 +206,13 @@ Section DEFINITIONS. Lemma get_sign_None_th : sign_theory get_sign_None. Proof. constructor;intros;discriminate. Qed. + Section DIV. + Variable cdiv: C -> C -> C*C. + Record div_theory : Prop := mkdiv_th { + div_eucl_th : forall a b, let (q,r) := cdiv a b in [a] == [b *! q +! r] + }. + End DIV. + End MORPHISM. (** Identity is a morphism *) @@ -235,6 +241,7 @@ Section DEFINITIONS. Definition pow_N_th := mkpow_th id_phi_N (pow_N rI rmul) (pow_N_pow_N rI rmul Rsth). + End DEFINITIONS. @@ -250,7 +257,7 @@ Section ALMOST_RING. (** Leibniz equality leads to a setoid theory and is extensional*) Lemma Eqsth : Setoid_Theory R (@eq R). - Proof. constructor;intros;subst;trivial. Qed. + Proof. constructor;red;intros;subst;trivial. Qed. Lemma Eq_s_ext : sring_eq_ext radd rmul (@eq R). Proof. constructor;intros;subst;trivial. Qed. @@ -442,7 +449,7 @@ Section ALMOST_RING. End RING. - (** Usefull lemmas on almost ring *) + (** Useful lemmas on almost ring *) Variable ARth : almost_ring_theory 0 1 radd rmul rsub ropp req. Lemma ARth_SRth : semi_ring_theory 0 1 radd rmul req. @@ -564,7 +571,7 @@ End AddRing. (** Some simplification tactics*) Ltac gen_reflexivity Rsth := apply (Seq_refl _ _ Rsth). -Ltac gen_srewrite O I add mul sub opp eq Rsth Reqe ARth := +Ltac gen_srewrite Rsth Reqe ARth := repeat first [ gen_reflexivity Rsth | progress rewrite (ARopp_zero Rsth Reqe ARth) diff --git a/contrib/setoid_ring/ZArithRing.v b/contrib/setoid_ring/ZArithRing.v index 8de7021e..4a5b623b 100644 --- a/contrib/setoid_ring/ZArithRing.v +++ b/contrib/setoid_ring/ZArithRing.v @@ -17,14 +17,14 @@ Set Implicit Arguments. Ltac Zcst t := match isZcst t with true => t - | _ => NotConstant + | _ => constr:NotConstant end. Ltac isZpow_coef t := match t with | Zpos ?p => isPcst p - | Z0 => true - | _ => false + | Z0 => constr:true + | _ => constr:false end. Definition N_of_Z x := @@ -36,7 +36,7 @@ Definition N_of_Z x := Ltac Zpow_tac t := match isZpow_coef t with | true => constr:(N_of_Z t) - | _ => constr:(NotConstant) + | _ => constr:NotConstant end. Ltac Zpower_neg := @@ -49,8 +49,12 @@ Ltac Zpower_neg := end end. - Add Ring Zr : Zth (decidable Zeqb_ok, constants [Zcst], preprocess [Zpower_neg;unfold Zsucc], - power_tac Zpower_theory [Zpow_tac]). + power_tac Zpower_theory [Zpow_tac], + (* The two following option are not needed, it is the default chose when the set of + coefficiant is usual ring Z *) + div (InitialRing.Ztriv_div_th (@Eqsth Z) (@IDphi Z)), + sign get_signZ_th). + diff --git a/contrib/setoid_ring/newring.ml4 b/contrib/setoid_ring/newring.ml4 index 134ba1a8..dd79801d 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 10047 2007-07-24 17:55:18Z barras $ i*) +(*i $Id: newring.ml4 11094 2008-06-10 19:35:23Z herbelin $ i*) open Pp open Util @@ -104,7 +104,8 @@ let protect_tac map = Tactics.reduct_option (protect_red map,DEFAULTcast) None ;; let protect_tac_in map id = - Tactics.reduct_option (protect_red map,DEFAULTcast) (Some(([],id),InHyp));; + Tactics.reduct_option (protect_red map,DEFAULTcast) + (Some((all_occurrences_expr,id),InHyp));; TACTIC EXTEND protect_fv @@ -176,13 +177,9 @@ let ltac_lcall tac args = let carg c = TacDynamic(dummy_loc,Pretyping.constr_in c) -let dummy_goal env = - {Evd.it= - {Evd.evar_concl=mkProp; - Evd.evar_hyps=named_context_val env; - Evd.evar_body=Evd.Evar_empty; - Evd.evar_extra=None}; - Evd.sigma=Evd.empty} +let dummy_goal env = + {Evd.it = Evd.make_evar (named_context_val env) mkProp; + Evd.sigma = Evd.empty} let exec_tactic env n f args = let lid = list_tabulate(fun i -> id_of_string("x"^string_of_int i)) n in @@ -205,7 +202,8 @@ let constr_of = function let stdlib_modules = [["Coq";"Setoids";"Setoid"]; ["Coq";"Lists";"List"]; - ["Coq";"Init";"Datatypes"] + ["Coq";"Init";"Datatypes"]; + ["Coq";"Init";"Logic"]; ] let coq_constant c = @@ -216,6 +214,7 @@ 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 coq_eq = coq_constant "eq" let lapp f args = mkApp(Lazy.force f,args) @@ -452,10 +451,12 @@ let (theory_to_obj, obj_to_theory) = export_function = export_th } -let setoid_of_relation r = +let setoid_of_relation env a r = lapp coq_mk_Setoid - [|r.rel_a; r.rel_aeq; - out_some r.rel_refl; out_some r.rel_sym; out_some r.rel_trans |] + [|a ; r ; + Class_tactics.reflexive_proof env a r ; + Class_tactics.symmetric_proof env a r ; + Class_tactics.transitive_proof env a r |] let op_morph r add mul opp req m1 m2 m3 = lapp coq_mk_reqe [| r; add; mul; opp; req; m1; m2; m3 |] @@ -463,63 +464,110 @@ let op_morph r add mul opp req m1 m2 m3 = let op_smorph r add mul req m1 m2 = lapp coq_mk_seqe [| r; add; mul; req; m1; m2 |] -let default_ring_equality (r,add,mul,opp,req) = - let is_setoid = function - {rel_refl=Some _; rel_sym=Some _;rel_trans=Some _;rel_aeq=rel} -> - eq_constr req rel (* Qu: use conversion ? *) - | _ -> false in - match default_relation_for_carrier ~filter:is_setoid r with - Leibniz _ -> - let setoid = lapp coq_eq_setoid [|r|] in - let op_morph = - match opp with +(* let default_ring_equality (r,add,mul,opp,req) = *) +(* let is_setoid = function *) +(* {rel_refl=Some _; rel_sym=Some _;rel_trans=Some _;rel_aeq=rel} -> *) +(* eq_constr req rel (\* Qu: use conversion ? *\) *) +(* | _ -> false in *) +(* match default_relation_for_carrier ~filter:is_setoid r with *) +(* Leibniz _ -> *) +(* let setoid = lapp coq_eq_setoid [|r|] in *) +(* let op_morph = *) +(* match opp with *) +(* Some opp -> lapp coq_eq_morph [|r;add;mul;opp|] *) +(* | None -> lapp coq_eq_smorph [|r;add;mul|] in *) +(* (setoid,op_morph) *) +(* | Relation rel -> *) +(* let setoid = setoid_of_relation rel in *) +(* let is_endomorphism = function *) +(* { args=args } -> List.for_all *) +(* (function (var,Relation rel) -> *) +(* var=None && eq_constr req rel *) +(* | _ -> false) args in *) +(* let add_m = *) +(* try default_morphism ~filter:is_endomorphism add *) +(* with Not_found -> *) +(* error "ring addition should be declared as a morphism" in *) +(* let mul_m = *) +(* try default_morphism ~filter:is_endomorphism mul *) +(* with Not_found -> *) +(* error "ring multiplication should be declared as a morphism" in *) +(* let op_morph = *) +(* match opp with *) +(* | Some opp -> *) +(* (let opp_m = *) +(* try default_morphism ~filter:is_endomorphism opp *) +(* with Not_found -> *) +(* error "ring opposite should be declared as a morphism" in *) +(* let op_morph = *) +(* op_morph r add mul opp req add_m.lem mul_m.lem opp_m.lem in *) +(* msgnl *) +(* (str"Using setoid \""++pr_constr rel.rel_aeq++str"\""++spc()++ *) +(* str"and morphisms \""++pr_constr add_m.morphism_theory++ *) +(* str"\","++spc()++ str"\""++pr_constr mul_m.morphism_theory++ *) +(* str"\""++spc()++str"and \""++pr_constr opp_m.morphism_theory++ *) +(* str"\""); *) +(* op_morph) *) +(* | None -> *) +(* (msgnl *) +(* (str"Using setoid \""++pr_constr rel.rel_aeq++str"\"" ++ spc() ++ *) +(* str"and morphisms \""++pr_constr add_m.morphism_theory++ *) +(* str"\""++spc()++str"and \""++ *) +(* pr_constr mul_m.morphism_theory++str"\""); *) +(* op_smorph r add mul req add_m.lem mul_m.lem) in *) +(* (setoid,op_morph) *) + +let ring_equality (r,add,mul,opp,req) = + match kind_of_term req with + | App (f, [| _ |]) when eq_constr f (Lazy.force coq_eq) -> + let setoid = lapp coq_eq_setoid [|r|] in + let op_morph = + match opp with Some opp -> lapp coq_eq_morph [|r;add;mul;opp|] | None -> lapp coq_eq_smorph [|r;add;mul|] in - (setoid,op_morph) - | Relation rel -> - let setoid = setoid_of_relation rel in - let is_endomorphism = function - { args=args } -> List.for_all - (function (var,Relation rel) -> - var=None && eq_constr req rel - | _ -> false) args in - let add_m = - try default_morphism ~filter:is_endomorphism add + (setoid,op_morph) + | _ -> + let setoid = setoid_of_relation (Global.env ()) r req in + let signature = [Some (r,req);Some (r,req)],Some(Lazy.lazy_from_val (r,req)) in + let add_m, add_m_lem = + try Class_tactics.default_morphism signature add with Not_found -> error "ring addition should be declared as a morphism" in - let mul_m = - try default_morphism ~filter:is_endomorphism mul + let mul_m, mul_m_lem = + try Class_tactics.default_morphism signature mul with Not_found -> error "ring multiplication should be declared as a morphism" in let op_morph = match opp with | Some opp -> - (let opp_m = - try default_morphism ~filter:is_endomorphism opp - with Not_found -> - error "ring opposite should be declared as a morphism" in - let op_morph = - op_morph r add mul opp req add_m.lem mul_m.lem opp_m.lem in - msgnl - (str"Using setoid \""++pr_constr rel.rel_aeq++str"\""++spc()++ - str"and morphisms \""++pr_constr add_m.morphism_theory++ - str"\","++spc()++ str"\""++pr_constr mul_m.morphism_theory++ - str"\""++spc()++str"and \""++pr_constr opp_m.morphism_theory++ - str"\""); - op_morph) + (let opp_m,opp_m_lem = + try Class_tactics.default_morphism ([Some(r,req)],Some(Lazy.lazy_from_val (r,req))) opp + with Not_found -> + error "ring opposite should be declared as a morphism" in + let op_morph = + op_morph r add mul opp req add_m_lem mul_m_lem opp_m_lem in + Flags.if_verbose + msgnl + (str"Using setoid \""++pr_constr req++str"\""++spc()++ + str"and morphisms \""++pr_constr add_m_lem ++ + str"\","++spc()++ str"\""++pr_constr mul_m_lem++ + str"\""++spc()++str"and \""++pr_constr opp_m_lem++ + str"\""); + op_morph) | None -> - (msgnl - (str"Using setoid \""++pr_constr rel.rel_aeq++str"\"" ++ spc() ++ - str"and morphisms \""++pr_constr add_m.morphism_theory++ - str"\""++spc()++str"and \""++ - pr_constr mul_m.morphism_theory++str"\""); - op_smorph r add mul req add_m.lem mul_m.lem) in - (setoid,op_morph) - + (Flags.if_verbose + msgnl + (str"Using setoid \""++pr_constr req ++str"\"" ++ spc() ++ + str"and morphisms \""++pr_constr add_m_lem ++ + str"\""++spc()++str"and \""++ + pr_constr mul_m_lem++str"\""); + op_smorph r add mul req add_m_lem mul_m_lem) in + (setoid,op_morph) + let build_setoid_params r add mul opp req eqth = match eqth with Some th -> th - | None -> default_ring_equality (r,add,mul,opp,req) + | None -> ring_equality (r,add,mul,opp,req) let dest_ring env sigma th_spec = let th_typ = Retyping.get_type_of env sigma th_spec in @@ -569,7 +617,8 @@ type cst_tac_spec = let interp_cst_tac env sigma rk kind (zero,one,add,mul,opp) cst_tac = match cst_tac with Some (CstTac t) -> Tacinterp.glob_tactic t - | Some (Closed lc) -> closed_term_ast (List.map Nametab.global lc) + | Some (Closed lc) -> + closed_term_ast (List.map Syntax_def.global_with_alias lc) | None -> (match rk, opp, kind with Abstract, None, _ -> @@ -612,7 +661,8 @@ let interp_power env pow = let tac = match tac with | CstTac t -> Tacinterp.glob_tactic t - | Closed lc -> closed_term_ast (List.map Nametab.global lc) in + | Closed lc -> + closed_term_ast (List.map Syntax_def.global_with_alias lc) in let spec = make_hyp env (ic spec) in (tac, lapp coq_Some [|carrier; spec|]) @@ -625,7 +675,16 @@ let interp_sign env sign = 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 interp_div env div = + let carrier = Lazy.force coq_hypo in + match div 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 div = check_required_library (cdir@["Ring_base"]); let env = Global.env() in let sigma = Evd.empty in @@ -633,10 +692,11 @@ let add_theory name rth eqth morphth cst_tac (pre,post) power sign = 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 dspec = interp_div env div in let rk = reflect_coeff morphth in let params = exec_tactic env 5 (zltac "ring_lemmas") - (List.map carg[sth;ext;rth;pspec;sspec;rk]) in + (List.map carg[sth;ext;rth;pspec;sspec;dspec;rk]) in let lemma1 = constr_of params.(3) in let lemma2 = constr_of params.(4) in @@ -678,6 +738,7 @@ type ring_mod = | Pow_spec of cst_tac_spec * Topconstr.constr_expr (* Syntaxification tactic , correctness lemma *) | Sign_spec of Topconstr.constr_expr + | Div_spec of Topconstr.constr_expr VERNAC ARGUMENT EXTEND ring_mod @@ -694,6 +755,7 @@ VERNAC ARGUMENT EXTEND ring_mod [ Pow_spec (Closed l, pow_spec) ] | [ "power_tac" constr(pow_spec) "[" tactic(cst_tac) "]" ] -> [ Pow_spec (CstTac cst_tac, pow_spec) ] + | [ "div" constr(div_spec) ] -> [ Div_spec div_spec ] END let set_once s r v = @@ -707,6 +769,7 @@ let process_ring_mods l = let post = ref None in let sign = ref None in let power = ref None in + let div = 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 @@ -714,14 +777,15 @@ let process_ring_mods l = | Post_tac t -> set_once "postprocess tactic" post t | 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; + | Sign_spec t -> set_once "sign" sign t + | Div_spec t -> set_once "div" div t) l; let k = match !kind with Some k -> k | None -> Abstract in - (k, !set, !cst_tac, !pre, !post, !power, !sign) + (k, !set, !cst_tac, !pre, !post, !power, !sign, !div) VERNAC COMMAND EXTEND AddSetoidRing | [ "Add" "Ring" ident(id) ":" constr(t) ring_mods(l) ] -> - [ 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 ] + [ let (k,set,cst,pre,post,power,sign, div) = process_ring_mods l in + add_theory id (ic t) set k cst (pre,post) power sign div] END (*****************************************************************************) @@ -759,15 +823,14 @@ let ring_lookup (f:glob_tactic_expr) lH rl t gl = let posttac = Tacexp(TacFun([None],e.ring_post_tac)) in Tacinterp.eval_tactic (TacLetIn - ([(dummy_loc,id_of_string"f"),None,Tacexp f], + (false,[(dummy_loc,id_of_string"f"),Tacexp f], ltac_lcall "f" [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(lH) "]" constr_list(lr) - "[" constr(t) "]" ] -> - [ring_lookup (fst f) lH lr t] +| [ "ring_lookup" tactic0(f) "[" constr_list(lH) "]" ne_constr_list(lrt) ] -> + [ let (t,lr) = list_sep_last lrt in ring_lookup (fst f) lH lr t] END @@ -968,26 +1031,20 @@ let (ftheory_to_obj, obj_to_ftheory) = classify_function = (fun (_,x) -> Substitute x); export_function = export_th } -let default_field_equality r inv req = - let is_setoid = function - {rel_refl=Some _; rel_sym=Some _;rel_trans=Some _} -> true - | _ -> false in - match default_relation_for_carrier ~filter:is_setoid r with - Leibniz _ -> +let field_equality r inv req = + match kind_of_term req with + | App (f, [| _ |]) when eq_constr f (Lazy.force coq_eq) -> mkApp((Coqlib.build_coq_eq_data()).congr,[|r;r;inv|]) - | Relation rel -> - let is_endomorphism = function - { args=args } -> List.for_all - (function (var,Relation rel) -> - var=None && eq_constr req rel - | _ -> false) args in - let inv_m = - try default_morphism ~filter:is_endomorphism inv + | _ -> + let _setoid = setoid_of_relation (Global.env ()) r req in + let signature = [Some (r,req)],Some(Lazy.lazy_from_val (r,req)) in + let inv_m, inv_m_lem = + try Class_tactics.default_morphism signature inv with Not_found -> 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) power sign = + inv_m_lem + +let add_field_theory name fth eqth morphth cst_tac inj (pre,post) power sign odiv = check_required_library (cdir@["Field_tac"]); let env = Global.env() in let sigma = Evd.empty in @@ -995,14 +1052,15 @@ let add_field_theory name fth eqth morphth cst_tac inj (pre,post) power sign = 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) power sign in + let _ = add_theory name rth eqth morphth cst_tac (None,None) power sign odiv 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 dspec = interp_div env odiv in + let inv_m = field_equality r inv req in let rk = reflect_coeff morphth in let params = exec_tactic env 9 (field_ltac"field_lemmas") - (List.map carg[sth;ext;inv_m;fth;pspec;sspec;rk]) in + (List.map carg[sth;ext;inv_m;fth;pspec;sspec;dspec;rk]) in let lemma1 = constr_of params.(3) in let lemma2 = constr_of params.(4) in let lemma3 = constr_of params.(5) in @@ -1059,6 +1117,7 @@ let process_field_mods l = let inj = ref None in let sign = ref None in let power = ref None in + let div = ref None in List.iter(function Ring_mod(Ring_kind k) -> set_once "field kind" kind k | Ring_mod(Const_tac t) -> @@ -1068,14 +1127,15 @@ let process_field_mods l = | 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 + | Ring_mod(Div_spec t) -> set_once "div" div 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, !power, !sign) + (k, !set, !inj, !cst_tac, !pre, !post, !power, !sign, !div) VERNAC COMMAND EXTEND AddSetoidField | [ "Add" "Field" ident(id) ":" constr(t) field_mods(l) ] -> - [ 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] + [ let (k,set,inj,cst_tac,pre,post,power,sign,div) = process_field_mods l in + add_field_theory id (ic t) set k cst_tac inj (pre,post) power sign div] END let field_lookup (f:glob_tactic_expr) lH rl t gl = @@ -1097,13 +1157,12 @@ let field_lookup (f:glob_tactic_expr) lH rl t gl = let posttac = Tacexp(TacFun([None],e.field_post_tac)) in Tacinterp.eval_tactic (TacLetIn - ([(dummy_loc,id_of_string"f"),None,Tacexp f], + (false,[(dummy_loc,id_of_string"f"),Tacexp f], ltac_lcall "f" [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(lH) "]" constr_list(l) - "[" constr(t) "]" ] -> - [ field_lookup (fst f) lH l t ] +| [ "field_lookup" tactic0(f) "[" constr_list(lH) "]" ne_constr_list(lt) ] -> + [ let (t,l) = list_sep_last lt in field_lookup (fst f) lH l t ] END diff --git a/contrib/subtac/FixSub.v b/contrib/subtac/FixSub.v deleted file mode 100644 index f047b729..00000000 --- a/contrib/subtac/FixSub.v +++ /dev/null @@ -1,147 +0,0 @@ -Require Import Wf. -Require Import Coq.subtac.Utils. - -(** Reformulation of the Wellfounded module using subsets where possible. *) - -Section Well_founded. - 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. - - 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. - - 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. - - 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 Well_founded. - -Extraction Inline Fix_F_sub Fix_sub. - -Require Import Wf_nat. -Require Import Lt. - -Section Well_founded_measure. - Variable A : Type. - Variable m : A -> nat. - - Section Acc. - - Variable P : A -> Type. - - Variable F_sub : forall x:A, (forall y: { y : A | m y < m x }, P (proj1_sig y)) -> P x. - - Fixpoint Fix_measure_F_sub (x : A) (r : Acc lt (m x)) {struct r} : P x := - F_sub x (fun y: { y : A | m y < m x} => Fix_measure_F_sub (proj1_sig y) - (Acc_inv r (m (proj1_sig y)) (proj2_sig y))). - - Definition Fix_measure_sub (x : A) := Fix_measure_F_sub x (lt_wf (m x)). - - End Acc. - - Section FixPoint. - Variable P : A -> Type. - - Variable F_sub : forall x:A, (forall y: { y : A | m y < m x }, P (proj1_sig y)) -> P x. - - Notation Fix_F := (Fix_measure_F_sub P F_sub) (only parsing). (* alias *) - - Definition Fix_measure (x:A) := Fix_measure_F_sub P F_sub x (lt_wf (m x)). - - Hypothesis - F_ext : - forall (x:A) (f g:forall y:{y:A | m y < m x}, P (`y)), - (forall y:{ y:A | m y < m x}, f y = g y) -> F_sub x f = F_sub x g. - - Lemma Fix_measure_F_eq : - forall (x:A) (r:Acc lt (m x)), - F_sub x (fun (y:{y:A|m y < m x}) => Fix_F (`y) (Acc_inv r (m (proj1_sig y)) (proj2_sig y))) = Fix_F x r. - Proof. - intros x. - set (y := m x). - unfold Fix_measure_F_sub. - intros r ; case r ; auto. - Qed. - - Lemma Fix_measure_F_inv : forall (x:A) (r s:Acc lt (m x)), Fix_F x r = Fix_F x s. - Proof. - intros x r s. - rewrite (proof_irrelevance (Acc lt (m x)) r s) ; auto. - Qed. - - Lemma Fix_measure_eq : forall x:A, Fix_measure x = F_sub x (fun (y:{y:A| m y < m x}) => Fix_measure (proj1_sig y)). - Proof. - intro x; unfold Fix_measure in |- *. - rewrite <- (Fix_measure_F_eq ). - apply F_ext; intros. - apply Fix_measure_F_inv. - Qed. - - Lemma fix_measure_sub_eq : - forall x : A, - Fix_measure_sub P F_sub x = - let f_sub := F_sub in - f_sub x (fun {y : A | m y < m x}=> Fix_measure (`y)). - exact Fix_measure_eq. - Qed. - - 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 deleted file mode 100644 index 4610f346..00000000 --- a/contrib/subtac/FunctionalExtensionality.v +++ /dev/null @@ -1,47 +0,0 @@ -Lemma equal_f : forall A B : Type, forall (f g : A -> B), - f = g -> forall x, f x = g x. -Proof. - intros. - rewrite H. - auto. -Qed. - -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. - -Lemma fix_sub_measure_eq_ext : - forall (A : Type) (f : A -> nat) (P : A -> Type) - (F_sub : forall x : A, (forall {y : A | f y < f x}, P (`y)) -> P x), - forall x : A, - Fix_measure_sub A f P F_sub x = - F_sub x (fun {y : A | f y < f x}=> Fix_measure_sub A f P F_sub (`y)). -Proof. - intros ; apply Fix_measure_eq ; auto. - intros. - assert(f0 = g). - apply (fun_extensionality_dep _ _ _ _ H). - rewrite H0 ; auto. -Qed. diff --git a/contrib/subtac/Heq.v b/contrib/subtac/Heq.v deleted file mode 100644 index f2b216d9..00000000 --- a/contrib/subtac/Heq.v +++ /dev/null @@ -1,34 +0,0 @@ -Require Export JMeq. - -(** Notation for heterogenous equality. *) - -Notation " [ x : X ] = [ y : Y ] " := (@JMeq X x Y y) (at level 0, X at next level, Y at next level). - -(** Do something on an heterogeneous equality appearing in the context. *) - -Ltac on_JMeq tac := - match goal with - | [ H : @JMeq ?x ?X ?y ?Y |- _ ] => tac H - end. - -(** Try to apply [JMeq_eq] to get back a regular equality when the two types are equal. *) - -Ltac simpl_one_JMeq := - on_JMeq - ltac:(fun H => let H' := fresh "H" in - assert (H' := JMeq_eq H) ; clear H ; rename H' into H). - -(** Repeat it for every possible hypothesis. *) - -Ltac simpl_JMeq := repeat simpl_one_JMeq. - -(** Just simplify an h.eq. without clearing it. *) - -Ltac simpl_one_dep_JMeq := - on_JMeq - ltac:(fun H => let H' := fresh "H" in - assert (H' := JMeq_eq H)). - - - - diff --git a/contrib/subtac/Subtac.v b/contrib/subtac/Subtac.v deleted file mode 100644 index 9912cd24..00000000 --- a/contrib/subtac/Subtac.v +++ /dev/null @@ -1,2 +0,0 @@ -Require Export Coq.subtac.Utils. -Require Export Coq.subtac.FixSub.
\ No newline at end of file diff --git a/contrib/subtac/SubtacTactics.v b/contrib/subtac/SubtacTactics.v deleted file mode 100644 index a00234dd..00000000 --- a/contrib/subtac/SubtacTactics.v +++ /dev/null @@ -1,158 +0,0 @@ -Ltac induction_with_subterm c H := - let x := fresh "x" in - let y := fresh "y" in - (remember c as x ; rewrite <- y in H ; induction H ; subst). - -Ltac induction_on_subterm c := - let x := fresh "x" in - let y := fresh "y" in - (set(x := c) ; assert(y:x = c) by reflexivity ; clearbody x ; induction x ; inversion y ; try subst ; - clear y). - -Ltac induction_with_subterms c c' H := - let x := fresh "x" in - let y := fresh "y" in - let z := fresh "z" in - let w := fresh "w" in - (set(x := c) ; assert(y:x = c) by reflexivity ; - set(z := c') ; assert(w:z = c') by reflexivity ; - rewrite <- y in H ; rewrite <- w in H ; - induction H ; subst). - - -Ltac destruct_one_pair := - match goal with - | [H : (_ /\ _) |- _] => destruct H - | [H : prod _ _ |- _] => destruct H - end. - -Ltac destruct_pairs := repeat (destruct_one_pair). - -Ltac destruct_one_ex := - let tac H := let ph := fresh "H" in destruct H as [H ph] in - match goal with - | [H : (ex _) |- _] => tac H - | [H : (sig ?P) |- _ ] => tac H - | [H : (ex2 _) |- _] => tac H - end. - -Ltac destruct_exists := repeat (destruct_one_ex). - -Tactic Notation "destruct" "exist" ident(t) ident(Ht) := destruct t as [t Ht]. - -Tactic Notation "destruct" "or" ident(H) := destruct H as [H|H]. - -Tactic Notation "contradiction" "by" constr(t) := - let H := fresh in assert t as H by auto with * ; contradiction. - -Ltac discriminates := - match goal with - | [ H : ?x <> ?x |- _ ] => elim H ; reflexivity - | _ => discriminate - end. - -Ltac destruct_conjs := repeat (destruct_one_pair || destruct_one_ex). - -Ltac on_last_hyp tac := - match goal with - [ H : _ |- _ ] => tac H - end. - -Tactic Notation "on_last_hyp" tactic(t) := on_last_hyp t. - -Ltac revert_last := - match goal with - [ H : _ |- _ ] => revert H - end. - -Ltac reverse := repeat revert_last. - -Ltac on_call f tac := - match goal with - | H : ?T |- _ => - match T with - | context [f ?x ?y ?z ?w ?v ?u] => tac (f x y z w v u) - | context [f ?x ?y ?z ?w ?v] => tac (f x y z w v) - | context [f ?x ?y ?z ?w] => tac (f x y z w) - | context [f ?x ?y ?z] => tac (f x y z) - | context [f ?x ?y] => tac (f x y) - | context [f ?x] => tac (f x) - end - | |- ?T => - match T with - | context [f ?x ?y ?z ?w ?v ?u] => tac (f x y z w v u) - | context [f ?x ?y ?z ?w ?v] => tac (f x y z w v) - | context [f ?x ?y ?z ?w] => tac (f x y z w) - | context [f ?x ?y ?z] => tac (f x y z) - | context [f ?x ?y] => tac (f x y) - | context [f ?x] => tac (f x) - end - end. - -(* Destructs calls to f in hypothesis or conclusion, useful if f creates a subset object *) -Ltac destruct_call f := - let tac t := destruct t in on_call f tac. - -Ltac destruct_call_as f l := - let tac t := destruct t as l in on_call f tac. - -Tactic Notation "destruct_call" constr(f) := destruct_call f. -Tactic Notation "destruct_call" constr(f) "as" simple_intropattern(l) := destruct_call_as f l. - -Ltac myinjection := - let tac H := inversion H ; subst ; clear H in - match goal with - | [ H : ?f ?a = ?f' ?a' |- _ ] => tac H - | [ H : ?f ?a ?b = ?f' ?a' ?b' |- _ ] => tac H - | [ H : ?f ?a ?b ?c = ?f' ?a' ?b' ?c' |- _ ] => tac H - | [ H : ?f ?a ?b ?c ?d= ?f' ?a' ?b' ?c' ?d' |- _ ] => tac H - | [ H : ?f ?a ?b ?c ?d ?e= ?f' ?a' ?b' ?c' ?d' ?e' |- _ ] => tac H - | [ H : ?f ?a ?b ?c ?d ?e ?g= ?f' ?a' ?b' ?c' ?d' ?e' ?g' |- _ ] => tac H - | [ H : ?f ?a ?b ?c ?d ?e ?g ?h= ?f' ?a' ?b' ?c' ?d' ?e'?g' ?h' |- _ ] => tac H - | [ H : ?f ?a ?b ?c ?d ?e ?g ?h ?i = ?f' ?a' ?b' ?c' ?d' ?e'?g' ?h' ?i' |- _ ] => tac H - | [ H : ?f ?a ?b ?c ?d ?e ?g ?h ?i ?j = ?f' ?a' ?b' ?c' ?d' ?e'?g' ?h' ?i' ?j' |- _ ] => tac H - | _ => idtac - end. - -Ltac destruct_nondep H := let H0 := fresh "H" in assert(H0 := H); destruct H0. - -Ltac bang := - match goal with - | |- ?x => - match x with - | context [False_rect _ ?p] => elim p - end - end. - -Require Import Eqdep. - -Ltac elim_eq_rect := - match goal with - | [ |- ?t ] => - match t with - | context [ @eq_rect _ _ _ _ _ ?p ] => - let P := fresh "P" in - set (P := p); simpl in P ; - try ((case P ; clear P) || (clearbody P; rewrite (UIP_refl _ _ P); clear P)) - | context [ @eq_rect _ _ _ _ _ ?p _ ] => - let P := fresh "P" in - set (P := p); simpl in P ; - try ((case P ; clear P) || (clearbody P; rewrite (UIP_refl _ _ P); clear P)) - end - end. - -Ltac real_elim_eq_rect := - match goal with - | [ |- ?t ] => - match t with - | context [ @eq_rect _ _ _ _ _ ?p ] => - let P := fresh "P" in - set (P := p); simpl in P ; - ((case P ; clear P) || (clearbody P; rewrite (UIP_refl _ _ P); clear P)) - | context [ @eq_rect _ _ _ _ _ ?p _ ] => - let P := fresh "P" in - set (P := p); simpl in P ; - ((case P ; clear P) || (clearbody P; rewrite (UIP_refl _ _ P); clear P)) - end - end. -
\ No newline at end of file diff --git a/contrib/subtac/Utils.v b/contrib/subtac/Utils.v deleted file mode 100644 index 76f49dd3..00000000 --- a/contrib/subtac/Utils.v +++ /dev/null @@ -1,65 +0,0 @@ -Require Export Coq.subtac.SubtacTactics. - -Set Implicit Arguments. - -(** Wrap a proposition inside a subset. *) - -Notation " {{ x }} " := (tt : { y : unit | x }). - -(** A simpler notation for subsets defined on a cartesian product. *) - -Notation "{ ( x , y ) : A | P }" := - (sig (fun anonymous : A => let (x,y) := anonymous in P)) - (x ident, y ident) : type_scope. - -(** Generates an obligation to prove False. *) - -Notation " ! " := (False_rect _ _). - -(** Abbreviation for first projection and hiding of proofs of subset objects. *) - -Notation " ` t " := (proj1_sig t) (at level 10) : core_scope. -Notation "( x & ? )" := (@exist _ _ x _) : core_scope. - -(** Coerces objects to their support before comparing them. *) - -Notation " x '`=' y " := ((x :>) = (y :>)) (at level 70). - -(** Quantifying over subsets. *) - -Notation "'fun' { x : A | P } => Q" := - (fun x:{x:A|P} => Q) - (at level 200, x ident, right associativity). - -Notation "'forall' { x : A | P } , Q" := - (forall x:{x:A|P}, Q) - (at level 200, x ident, right associativity). - -Require Import Coq.Bool.Sumbool. - -(** Construct a dependent disjunction from a boolean. *) - -Notation "'dec'" := (sumbool_of_bool) (at level 0). - -(** The notations [in_right] and [in_left] construct objects of a dependent disjunction. *) - -Notation in_right := (@right _ _ _). -Notation in_left := (@left _ _ _). - -(** Default simplification tactic. *) - -Ltac subtac_simpl := simpl ; intros ; destruct_conjs ; simpl in * ; try subst ; - try (solve [ red ; intros ; discriminate ]) ; auto with *. - -(** Extraction directives *) -Extraction Inline proj1_sig. -Extract Inductive unit => "unit" [ "()" ]. -Extract Inductive bool => "bool" [ "true" "false" ]. -Extract Inductive sumbool => "bool" [ "true" "false" ]. -(* Extract Inductive prod "'a" "'b" => " 'a * 'b " [ "(,)" ]. *) -(* Extract Inductive sigT => "prod" [ "" ]. *) - -Require Export ProofIrrelevance. -Require Export Coq.subtac.Heq. - -Delimit Scope program_scope with program. diff --git a/contrib/subtac/eterm.ml b/contrib/subtac/eterm.ml index 2a84fdd0..9bfb33ea 100644 --- a/contrib/subtac/eterm.ml +++ b/contrib/subtac/eterm.ml @@ -14,17 +14,21 @@ open Util open Subtac_utils let trace s = - if !Options.debug then (msgnl s; msgerr s) + if !Flags.debug then (msgnl s; msgerr s) else () +let succfix (depth, fixrels) = + (succ depth, List.map succ fixrels) + (** Substitute evar references in t using De Bruijn indices, where n binders were passed through. *) let subst_evar_constr evs n t = let seen = ref Intset.empty in + let transparent = ref Idset.empty in let evar_info id = List.assoc id evs in - let rec substrec depth c = match kind_of_term c with + let rec substrec (depth, fixrels) c = match kind_of_term c with | Evar (k, args) -> - let (id, idstr), hyps, chop, _, _ = + let (id, idstr), hyps, chop, _, _, _ = try evar_info k with Not_found -> anomaly ("eterm: existential variable " ^ string_of_int k ^ " not found") @@ -42,7 +46,7 @@ let subst_evar_constr evs n t = let rec aux hyps args acc = match hyps, args with ((_, None, _) :: tlh), (c :: tla) -> - aux tlh tla ((map_constr_with_binders succ substrec depth c) :: acc) + aux tlh tla ((map_constr_with_binders succfix substrec (depth, fixrels) c) :: acc) | ((_, Some _, _) :: tlh), (_ :: tla) -> aux tlh tla acc | [], [] -> acc @@ -53,11 +57,15 @@ let subst_evar_constr evs n t = int (List.length hyps) ++ str " hypotheses" ++ spc () ++ pp_list (fun x -> my_print_constr (Global.env ()) x) args); with _ -> ()); + if List.exists (fun x -> match kind_of_term x with Rel n -> List.mem n fixrels | _ -> false) args then + transparent := Idset.add idstr !transparent; mkApp (mkVar idstr, Array.of_list args) - | _ -> map_constr_with_binders succ substrec depth c + | Fix _ -> + map_constr_with_binders succfix substrec (depth, 1 :: fixrels) c + | _ -> map_constr_with_binders succfix substrec (depth, fixrels) c in - let t' = substrec 0 t in - t', !seen + let t' = substrec (0, []) t in + t', !seen, !transparent (** Substitute variable references in t using De Bruijn indices, @@ -74,26 +82,29 @@ let subst_vars acc n t = to a product : forall H1 : t1, ..., forall Hn : tn, concl. Changes evars and hypothesis references to variable references. A little optimization: don't include unnecessary let-ins and their dependencies. -*) +*) let etype_of_evar evs hyps concl = let rec aux acc n = function (id, copt, t) :: tl -> - let t', s = subst_evar_constr evs n t in + let t', s, trans = subst_evar_constr evs n t in let t'' = subst_vars acc 0 t' in - let rest, s' = aux (id :: acc) (succ n) tl in + let rest, s', trans' = aux (id :: acc) (succ n) tl in let s' = Intset.union s s' in + let trans' = Idset.union trans trans' in (match copt with Some c -> - if noccurn 1 rest then lift (-1) rest, s' + if noccurn 1 rest then lift (-1) rest, s', trans' else - let c', s'' = subst_evar_constr evs n c in + let c', s'', trans'' = subst_evar_constr evs n c in let c' = subst_vars acc 0 c' in - mkNamedProd_or_LetIn (id, Some c', t'') rest, Intset.union s'' s' + mkNamedProd_or_LetIn (id, Some c', t'') rest, + Intset.union s'' s', + Idset.union trans'' trans' | None -> - mkNamedProd_or_LetIn (id, None, t'') rest, s') + mkNamedProd_or_LetIn (id, None, t'') rest, s', trans') | [] -> - let t', s = subst_evar_constr evs n concl in - subst_vars acc 0 t', s + let t', s, trans = subst_evar_constr evs n concl in + subst_vars acc 0 t', s, trans in aux [] 0 (rev hyps) @@ -110,12 +121,14 @@ let rec chop_product n t = | Prod (_, _, b) -> if noccurn 1 b then chop_product (pred n) (Termops.pop b) else None | _ -> None -let eterm_obligations name nclen isevars evm fs t tycon = +let eterm_obligations env name isevars evm fs t ty = (* 'Serialize' the evars, we assume that the types of the existentials refer to previous existentials in the list only *) trace (str " In eterm: isevars: " ++ my_print_evardefs isevars); trace (str "Term given to eterm" ++ spc () ++ Termops.print_constr_env (Global.env ()) t); + let nc = Environ.named_context env in + let nc_len = Sign.named_context_length nc in let evl = List.rev (to_list evm) in let evn = let i = ref (-1) in @@ -128,9 +141,9 @@ let eterm_obligations name nclen isevars evm fs t tycon = (* Remove existential variables in types and build the corresponding products *) fold_right (fun (id, (n, nstr), ev) l -> - let hyps = Environ.named_context_of_val ev.evar_hyps in - let hyps = trunc_named_context nclen hyps in - let evtyp, deps = etype_of_evar l hyps ev.evar_concl in + let hyps = Evd.evar_filtered_context ev in + let hyps = trunc_named_context nc_len hyps in + let evtyp, deps, transp = etype_of_evar l hyps ev.evar_concl in let evtyp, hyps, chop = match chop_product fs evtyp with Some t -> @@ -145,26 +158,28 @@ let eterm_obligations name nclen isevars evm fs t tycon = let loc, k = evar_source id isevars in let opacity = match k with QuestionMark o -> o | _ -> true in let opaque = if not opacity || chop <> fs then None else Some chop in - let y' = (id, ((n, nstr), hyps, opaque, evtyp, deps)) in + let y' = (id, ((n, nstr), hyps, opaque, loc, evtyp, deps)) in y' :: l) evn [] in - let t', _ = (* Substitute evar refs in the term by variables *) + let t', _, transparent = (* Substitute evar refs in the term by variables *) subst_evar_constr evts 0 t in + let ty, _, _ = subst_evar_constr evts 0 ty in let evars = - List.map (fun (_, ((_, name), _, opaque, typ, deps)) -> name, typ, not (opaque = None), deps) evts + List.map (fun (_, ((_, name), _, opaque, loc, typ, deps)) -> + name, typ, loc, not (opaque = None) && not (Idset.mem name transparent), deps) evts in (try trace (str "Term constructed in eterm" ++ spc () ++ Termops.print_constr_env (Global.env ()) t'); ignore(iter - (fun (name, typ, _, deps) -> + (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' + Array.of_list (List.rev evars), t', ty let mkMetas n = list_tabulate (fun _ -> Evarutil.mk_new_meta ()) n diff --git a/contrib/subtac/eterm.mli b/contrib/subtac/eterm.mli index 76994c06..007e327c 100644 --- a/contrib/subtac/eterm.mli +++ b/contrib/subtac/eterm.mli @@ -6,8 +6,8 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: eterm.mli 9976 2007-07-12 11:58:30Z msozeau $ i*) - +(*i $Id: eterm.mli 10889 2008-05-06 14:05:20Z msozeau $ i*) +open Environ open Tacmach open Term open Evd @@ -18,10 +18,11 @@ val mkMetas : int -> constr list (* val eterm_term : evar_map -> constr -> types option -> constr * types option * (identifier * types) list *) -(* id, named context length, evars, number of - function prototypes to try to clear from evars contexts, object and optional type *) -val eterm_obligations : identifier -> int -> evar_defs -> evar_map -> int -> constr -> types option -> - (identifier * types * bool * Intset.t) array * constr - (* Obl. name, type as product, opacity (true = opaque) and dependencies as indexes into the array *) +(* env, id, evars, number of + function prototypes to try to clear from evars contexts, object and type *) +val eterm_obligations : env -> identifier -> evar_defs -> evar_map -> int -> constr -> types -> + (identifier * types * loc * bool * Intset.t) array * constr * types + (* Obl. name, type as product, location of the original evar, + opacity (true = opaque) and dependencies as indexes into the array *) val etermtac : open_constr -> tactic diff --git a/contrib/subtac/g_subtac.ml4 b/contrib/subtac/g_subtac.ml4 index 43a3bec4..88243b60 100644 --- a/contrib/subtac/g_subtac.ml4 +++ b/contrib/subtac/g_subtac.ml4 @@ -6,15 +6,18 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) +(*i camlp4deps: "parsing/grammar.cma" i*) +(*i camlp4use: "pa_extend.cmo" i*) + + (* Syntax for the subtac terms and types. Elaborated from correctness/psyntax.ml4 by Jean-Christophe Filliâtre *) -(* $Id: g_subtac.ml4 9976 2007-07-12 11:58:30Z msozeau $ *) +(* $Id: g_subtac.ml4 10919 2008-05-11 22:04:26Z msozeau $ *) -(*i camlp4deps: "parsing/grammar.cma" i*) -open Options +open Flags open Util open Names open Nameops @@ -41,17 +44,20 @@ struct let subtac_nameopt : identifier option Gram.Entry.e = gec "subtac_nameopt" end +open Rawterm open SubtacGram open Util open Pcoq - +open Prim +open Constr 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 subtac_nameopt; + GLOBAL: subtac_gallina_loc typeclass_constraint Constr.binder subtac_nameopt; subtac_gallina_loc: - [ [ g = Vernac.gallina -> loc, g ] ] + [ [ g = Vernac.gallina -> loc, g + | g = Vernac.gallina_ext -> loc, g ] ] ; subtac_nameopt: @@ -60,31 +66,31 @@ GEXTEND Gram ; Constr.binder_let: - [ [ "("; id=Prim.name; ":"; t=Constr.lconstr; "|"; c=Constr.lconstr; ")" -> - let typ = mkAppC (sigref, [mkLambdaC ([id], t, c)]) in - LocalRawAssum ([id], typ) + [[ "("; id=Prim.name; ":"; t=Constr.lconstr; "|"; c=Constr.lconstr; ")" -> + let typ = mkAppC (sigref, [mkLambdaC ([id], default_binder_kind, t, c)]) in + [LocalRawAssum ([id], default_binder_kind, typ)] ] ]; Constr.binder: [ [ "("; id=Prim.name; ":"; c=Constr.lconstr; "|"; p=Constr.lconstr; ")" -> - ([id],mkAppC (sigref, [mkLambdaC ([id], c, p)])) + ([id],default_binder_kind, mkAppC (sigref, [mkLambdaC ([id], default_binder_kind, c, p)])) | "("; id=Prim.name; ":"; c=Constr.lconstr; ")" -> - ([id],c) + ([id],default_binder_kind, c) | "("; id=Prim.name; lid=LIST1 Prim.name; ":"; c=Constr.lconstr; ")" -> - (id::lid,c) + (id::lid,default_binder_kind, c) ] ]; END -type ('a,'b) gallina_loc_argtype = (Vernacexpr.vernac_expr located, 'a, 'b) Genarg.abstract_argument_type +type 'a gallina_loc_argtype = (Vernacexpr.vernac_expr located, 'a) 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), - (rawwit_subtac_gallina_loc : (Genarg.rlevel, Tacexpr.raw_tactic_expr) gallina_loc_argtype) = +let (wit_subtac_gallina_loc : Genarg.tlevel gallina_loc_argtype), + (globwit_subtac_gallina_loc : Genarg.glevel gallina_loc_argtype), + (rawwit_subtac_gallina_loc : Genarg.rlevel gallina_loc_argtype) = Genarg.create_arg "subtac_gallina_loc" -type 'a nameopt_argtype = (identifier option, 'a, 'a) Genarg.abstract_argument_type +type 'a nameopt_argtype = (identifier option, 'a) Genarg.abstract_argument_type let (wit_subtac_nameopt : Genarg.tlevel nameopt_argtype), (globwit_subtac_nameopt : Genarg.glevel nameopt_argtype), @@ -133,10 +139,18 @@ VERNAC COMMAND EXTEND Subtac_Admit_Obligations END VERNAC COMMAND EXTEND Subtac_Set_Solver -| [ "Obligations" "Tactic" ":=" tactic(t) ] -> [ Subtac_obligations.set_default_tactic (Tacinterp.glob_tactic t) ] +| [ "Obligations" "Tactic" ":=" tactic(t) ] -> [ + Coqlib.check_required_library ["Coq";"Program";"Tactics"]; + Tacinterp.add_tacdef false + [(Qualid (dummy_loc, qualid_of_string "Coq.Program.Tactics.obligations_tactic"), true, 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 + +VERNAC COMMAND EXTEND Subtac_Show_Preterm +| [ "Preterm" "of" ident(name) ] -> [ Subtac_obligations.show_term (Some name) ] +| [ "Preterm" ] -> [ Subtac_obligations.show_term None ] +END diff --git a/contrib/subtac/subtac.ml b/contrib/subtac/subtac.ml index 8bc310d5..a59ad6f5 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 9976 2007-07-12 11:58:30Z msozeau $ *) +(* $Id: subtac.ml 11150 2008-06-19 11:38:27Z msozeau $ *) open Global open Pp @@ -49,24 +49,41 @@ open Decl_kinds open Tacinterp open Tacexpr +let solve_tccs_in_type env id isevars evm c typ = + if not (evm = Evd.empty) then + let stmt_id = Nameops.add_suffix id "_stmt" in + let obls, c', t' = eterm_obligations env stmt_id !isevars evm 0 c typ in + (** Make all obligations transparent so that real dependencies can be sorted out by the user *) + let obls = Array.map (fun (id, t, l, op, d) -> (id, t, l, false, d)) obls in + match Subtac_obligations.add_definition stmt_id c' typ obls with + Subtac_obligations.Defined cst -> constant_value (Global.env()) + (match cst with ConstRef kn -> kn | _ -> assert false) + | _ -> + errorlabstrm "start_proof" + (str "The statement obligations could not be resolved automatically, " ++ spc () ++ + str "write a statement definition first.") + else + let _ = Typeops.infer_type env c in c + + let start_proof_com env isevars sopt kind (bl,t) hook = let id = match sopt with - | Some id -> + | Some (loc,id) -> (* We check existence here: it's a bit late at Qed time *) if Nametab.exists_cci (Lib.make_path id) or is_section_variable id then - errorlabstrm "start_proof" (pr_id id ++ str " already exists"); + user_err_loc (loc,"start_proof",pr_id id ++ str " already exists"); id | None -> next_global_ident_away false (id_of_string "Unnamed_thm") (Pfedit.get_all_proof_names ()) in - let evm, c, typ = + let evm, c, typ, _imps = Subtac_pretyping.subtac_process env isevars id [] (Command.generalize_constr_expr t bl) None in - let _ = Typeops.infer_type env c in - Command.start_proof id kind c hook + let c = solve_tccs_in_type env id isevars evm c typ in + Command.start_proof id kind c hook -let print_subgoals () = Options.if_verbose (fun () -> msg (Printer.pr_open_subgoals ())) () +let print_subgoals () = Flags.if_verbose (fun () -> msg (Printer.pr_open_subgoals ())) () let start_proof_and_print env isevars idopt k t hook = start_proof_com env isevars idopt k t hook; @@ -75,122 +92,157 @@ let start_proof_and_print env isevars idopt k t hook = let _ = Detyping.set_detype_anonymous (fun loc n -> RVar (loc, id_of_string ("Anonymous_REL_" ^ string_of_int n))) let assumption_message id = - Options.if_verbose message ((string_of_id id) ^ " is assumed") + Flags.if_verbose message ((string_of_id id) ^ " is assumed") -let declare_assumption env isevars idl is_coe k bl c = - if not (Pfedit.refining ()) then - let evm, c, typ = - Subtac_pretyping.subtac_process env isevars (snd (List.hd idl)) [] (Command.generalize_constr_expr c bl) None +let declare_assumption env isevars idl is_coe k bl c nl = + if not (Pfedit.refining ()) then + let id = snd (List.hd idl) in + let evm, c, typ, imps = + Subtac_pretyping.subtac_process env isevars id [] (Command.generalize_constr_expr c bl) None in - List.iter (Command.declare_one_assumption is_coe k c) idl + let c = solve_tccs_in_type env id isevars evm c typ in + List.iter (Command.declare_one_assumption is_coe k c imps false false nl) idl else errorlabstrm "Command.Assumption" (str "Cannot declare an assumption while in proof editing mode.") -let vernac_assumption env isevars kind l = - List.iter (fun (is_coe,(idl,c)) -> declare_assumption env isevars idl is_coe kind [] c) l +let dump_definition (loc, id) s = + Flags.dump_string (Printf.sprintf "%s %d %s\n" s (fst (unloc loc)) (string_of_id id)) + +let dump_constraint ty ((loc, n), _, _) = + match n with + | Name id -> dump_definition (loc, id) ty + | Anonymous -> () +let dump_variable lid = () +let vernac_assumption env isevars kind l nl = + let global = fst kind = Global in + List.iter (fun (is_coe,(idl,c)) -> + if !Flags.dump then + List.iter (fun lid -> + if global then dump_definition lid "ax" + else dump_variable lid) idl; + declare_assumption env isevars idl is_coe kind [] c nl) l + +let check_fresh (loc,id) = + if Nametab.exists_cci (Lib.make_path id) or is_section_variable id then + user_err_loc (loc,"",pr_id id ++ str " already exists") + 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"; - require_library "Coq.Logic.JMeq"; + check_required_library ["Coq";"Program";"Tactics"]; let env = Global.env () in let isevars = ref (create_evar_defs Evd.empty) in try match command with - VernacDefinition (defkind, (locid, id), expr, hook) -> - (match expr with - ProveBody (bl, c) -> Subtac_pretyping.subtac_proof env isevars id bl c None - | DefineBody (bl, _, c, tycon) -> - Subtac_pretyping.subtac_proof env isevars id bl c tycon) - | VernacFixpoint (l, b) -> - let _ = trace (str "Building fixpoint") in - ignore(Subtac_command.build_recursive l b) - - | VernacStartTheoremProof (thkind, (locid, id), (bl, t), lettop, hook) -> - if not(Pfedit.refining ()) then - if lettop then - errorlabstrm "Subtac_command.StartProof" - (str "Let declarations can only be used in proof editing mode"); + | VernacDefinition (defkind, (_, id as lid), expr, hook) -> + check_fresh lid; + dump_definition lid "def"; + (match expr with + | ProveBody (bl, t) -> if Lib.is_modtype () then errorlabstrm "Subtac_command.StartProof" (str "Proof editing mode not supported in module types"); - start_proof_and_print env isevars (Some id) (Global, Proof thkind) (bl,t) hook - - - | VernacAssumption (stre,l) -> - vernac_assumption env isevars stre l - - (*| VernacEndProof e -> - subtac_end_proof e*) - - | _ -> user_err_loc (loc,"", str ("Invalid Program command")) - with - | Typing_error e -> - msg_warning (str "Type error in Program tactic:"); - let cmds = - (match e with - | NonFunctionalApp (loc, x, mux, e) -> - str "non functional application of term " ++ - e ++ str " to function " ++ x ++ str " of (mu) type " ++ mux - | NonSigma (loc, t) -> - str "Term is not of Sigma type: " ++ t - | NonConvertible (loc, x, y) -> - str "Unconvertible terms:" ++ spc () ++ - x ++ spc () ++ str "and" ++ spc () ++ y - | IllSorted (loc, t) -> - str "Term is ill-sorted:" ++ spc () ++ t - ) - in msg_warning cmds - - | Subtyping_error e -> - msg_warning (str "(Program tactic) Subtyping error:"); - let cmds = - match e with - | UncoercibleInferType (loc, x, y) -> - str "Uncoercible terms:" ++ spc () - ++ x ++ spc () ++ str "and" ++ spc () ++ y - | UncoercibleInferTerm (loc, x, y, tx, ty) -> - str "Uncoercible terms:" ++ spc () - ++ tx ++ spc () ++ str "of" ++ spc () ++ str "type" ++ spc () ++ x - ++ str "and" ++ spc() ++ ty ++ spc () ++ str "of" ++ spc () ++ str "type" ++ spc () ++ y - | UncoercibleRewrite (x, y) -> - str "Uncoercible terms:" ++ spc () - ++ x ++ spc () ++ str "and" ++ spc () ++ y - in msg_warning cmds - - | Cases.PatternMatchingError (env, exn) as e -> - debug 2 (Himsg.explain_pattern_matching_error env exn); - raise e - - | Type_errors.TypeError (env, exn) as e -> - debug 2 (Himsg.explain_type_error env exn); - raise e - - | Pretype_errors.PretypeError (env, exn) as e -> - debug 2 (Himsg.explain_pretype_error env exn); - raise e + start_proof_and_print env isevars (Some lid) (Global, DefinitionBody Definition) (bl,t) + (fun _ _ -> ()) + | DefineBody (bl, _, c, tycon) -> + ignore(Subtac_pretyping.subtac_proof defkind env isevars id bl c tycon)) + | VernacFixpoint (l, b) -> + List.iter (fun ((lid, _, _, _, _), _) -> + check_fresh lid; + dump_definition lid "fix") l; + let _ = trace (str "Building fixpoint") in + ignore(Subtac_command.build_recursive l b) - | (Stdpp.Exc_located (loc, e')) as e -> - debug 2 (str "Parsing exception: "); - (match e' with - | Type_errors.TypeError (env, exn) -> - debug 2 (Himsg.explain_type_error env exn); - raise e - - | Pretype_errors.PretypeError (env, exn) -> - debug 2 (Himsg.explain_pretype_error env exn); - raise e - - | e'' -> msg_warning (str "Unexpected exception: " ++ Cerrors.explain_exn e''); - raise e) - - | e -> - msg_warning (str "Uncatched exception: " ++ Cerrors.explain_exn e); - raise e - - + | VernacStartTheoremProof (thkind, [Some id, (bl, t)], lettop, hook) -> + if !Flags.dump then dump_definition id "prf"; + if not(Pfedit.refining ()) then + if lettop then + errorlabstrm "Subtac_command.StartProof" + (str "Let declarations can only be used in proof editing mode"); + if Lib.is_modtype () then + errorlabstrm "Subtac_command.StartProof" + (str "Proof editing mode not supported in module types"); + check_fresh id; + start_proof_and_print env isevars (Some id) (Global, Proof thkind) (bl,t) hook + + | VernacAssumption (stre,nl,l) -> + vernac_assumption env isevars stre l nl + + | VernacInstance (glob, sup, is, props, pri) -> + if !Flags.dump then dump_constraint "inst" is; + ignore(Subtac_classes.new_instance ~global:glob sup is props pri) + + | VernacCoFixpoint (l, b) -> + List.iter (fun ((lid, _, _, _), _) -> dump_definition lid "cofix") l; + ignore(Subtac_command.build_corecursive l b) + + (*| VernacEndProof e -> + subtac_end_proof e*) + + | _ -> user_err_loc (loc,"", str ("Invalid Program command")) + with + | Typing_error e -> + msg_warning (str "Type error in Program tactic:"); + let cmds = + (match e with + | NonFunctionalApp (loc, x, mux, e) -> + str "non functional application of term " ++ + e ++ str " to function " ++ x ++ str " of (mu) type " ++ mux + | NonSigma (loc, t) -> + str "Term is not of Sigma type: " ++ t + | NonConvertible (loc, x, y) -> + str "Unconvertible terms:" ++ spc () ++ + x ++ spc () ++ str "and" ++ spc () ++ y + | IllSorted (loc, t) -> + str "Term is ill-sorted:" ++ spc () ++ t + ) + in msg_warning cmds + + | Subtyping_error e -> + msg_warning (str "(Program tactic) Subtyping error:"); + let cmds = + match e with + | UncoercibleInferType (loc, x, y) -> + str "Uncoercible terms:" ++ spc () + ++ x ++ spc () ++ str "and" ++ spc () ++ y + | UncoercibleInferTerm (loc, x, y, tx, ty) -> + str "Uncoercible terms:" ++ spc () + ++ tx ++ spc () ++ str "of" ++ spc () ++ str "type" ++ spc () ++ x + ++ str "and" ++ spc() ++ ty ++ spc () ++ str "of" ++ spc () ++ str "type" ++ spc () ++ y + | UncoercibleRewrite (x, y) -> + str "Uncoercible terms:" ++ spc () + ++ x ++ spc () ++ str "and" ++ spc () ++ y + in msg_warning cmds + + | Cases.PatternMatchingError (env, exn) as e -> + debug 2 (Himsg.explain_pattern_matching_error env exn); + raise e + + | Type_errors.TypeError (env, exn) as e -> + debug 2 (Himsg.explain_type_error env exn); + raise e + + | Pretype_errors.PretypeError (env, exn) as e -> + debug 2 (Himsg.explain_pretype_error env exn); + raise e + + | (Stdpp.Exc_located (loc, e')) as e -> + debug 2 (str "Parsing exception: "); + (match e' with + | Type_errors.TypeError (env, exn) -> + debug 2 (Himsg.explain_type_error env exn); + raise e + + | Pretype_errors.PretypeError (env, exn) -> + debug 2 (Himsg.explain_pretype_error env exn); + raise e + + | e'' -> msg_warning (str "Unexpected exception: " ++ Cerrors.explain_exn e''); + raise e) + + | e -> + msg_warning (str "Uncatched exception: " ++ Cerrors.explain_exn e); + raise e diff --git a/contrib/subtac/subtac_cases.ml b/contrib/subtac/subtac_cases.ml index 04cad7c0..c7182bd2 100644 --- a/contrib/subtac/subtac_cases.ml +++ b/contrib/subtac/subtac_cases.ml @@ -1,3 +1,4 @@ +(* -*- compile-command: "make -C ../.. bin/coqtop.byte" -*- *) (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) @@ -6,7 +7,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: cases.ml 9399 2006-11-22 16:11:53Z herbelin $ *) +(* $Id: subtac_cases.ml 11154 2008-06-19 18:42:19Z msozeau $ *) open Cases open Util @@ -100,8 +101,7 @@ type equation = rhs : rhs; alias_stack : name list; eqn_loc : loc; - used : bool ref; - tag : pattern_source } + used : bool ref } type matrix = equation list @@ -242,6 +242,7 @@ type pattern_matching_problem = history : pattern_continuation; mat : matrix; caseloc : loc; + casestyle: case_style; typing_function: type_constraint -> env -> rawconstr -> unsafe_judgment } (*--------------------------------------------------------------------------* @@ -386,7 +387,7 @@ let mkDeclTomatch na = function 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) + | 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 @@ -423,25 +424,6 @@ let remove_current_pattern eqn = 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 *) @@ -499,7 +481,7 @@ let extract_rhs pb = | [] -> errorlabstrm "build_leaf" (mssg_may_need_inversion()) | eqn::_ -> set_used_pattern eqn; - eqn.tag, eqn.rhs + eqn.rhs (**********************************************************************) (* Functions to deal with matrix factorization *) @@ -676,26 +658,6 @@ let all_name sign = List.map (fun (n, b, t) -> let n = match n with Name _ -> n 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 = @@ -1126,7 +1088,6 @@ let group_equations pb ind current cstrs mat = 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,_) -> @@ -1148,22 +1109,22 @@ let rec generalize_problem pb = function let tomatch = regeneralize_index_tomatch (i+1) tomatch in { pb with tomatch = Abstract d :: tomatch; - pred = option_map (generalize_predicate i d) pb'.pred } + 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 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 + 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; + 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 } @@ -1228,7 +1189,7 @@ let build_branch current deps pb eqns const_info = 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 + let pred' = Option.map (specialize_predicate (List.rev typs') dep_sign const_info) pb.pred in sign, { pb with env = env'; @@ -1279,33 +1240,30 @@ and match_current pb tomatch = 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 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 ci = make_case_info pb.env mind pb.casestyle 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) + let j = compile pb in + (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; + pred = Option.map ungeneralize_predicate pb.pred; mat = List.map (push_rels_eqn [d]) pb.mat } in - let patstat,j = compile pb in - patstat, + let j = compile pb in { uj_val = mkLambda_or_LetIn d j.uj_val; uj_type = mkProd_or_LetIn d j.uj_type } @@ -1328,11 +1286,10 @@ and compile_alias pb (deppat,nondeppat,d,t) rest = {pb with env = newenv; tomatch = tomatch; - pred = option_map (lift_predicate n) pb.pred; + pred = Option.map (lift_predicate n) pb.pred; history = history; mat = mat } in - let patstat,j = compile pb in - patstat, + let j = compile pb in List.fold_left mkSpecialLetInJudge j sign (* pour les alias des initiaux, enrichir les env de ce qu'il faut et @@ -1352,7 +1309,6 @@ let matx_of_eqns env eqns = it = rhs; } in { patterns = lpat; - tag = RegularPat; alias_stack = []; eqn_loc = loc; used = ref false; @@ -1421,9 +1377,9 @@ let set_arity_signature dep n arsign tomatchl pred x = 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) -> + | RLambda (_,(Name id as na),k,_,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 + | RLambda (_,(Anonymous as na),k,_,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) @@ -1513,7 +1469,7 @@ let extract_arity_signature env0 tomatchl tmsign = match tm with | NotInd (bo,typ) -> (match t with - | None -> [na,option_map (lift n) bo,lift n typ] + | 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")) @@ -1612,7 +1568,8 @@ let eq_id avoid id = let mk_eq typ x y = mkApp (Lazy.force eq_ind, [| typ; x ; y |]) let mk_eq_refl typ x = mkApp (Lazy.force eq_refl, [| typ; x |]) -let mk_JMeq typ x typ' y = mkApp (Lazy.force Subtac_utils.jmeq_ind, [| typ; x ; typ'; y |]) +let mk_JMeq typ x typ' y = + mkApp (Lazy.force Subtac_utils.jmeq_ind, [| typ; x ; typ'; y |]) let mk_JMeq_refl typ x = mkApp (Lazy.force Subtac_utils.jmeq_refl, [| typ; x |]) let hole = RHole (dummy_loc, Evd.QuestionMark true) @@ -1626,18 +1583,14 @@ let context_of_arsign l = let constr_of_pat env isevars arsign pat avoid = let rec typ env (ty, realargs) pat avoid = - 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) -> - trace (str "Treating pattern variable " ++ str (string_of_id (id_of_name name))); let name, avoid = match name with Name n -> name, avoid | Anonymous -> let previd, id = prime avoid (Name (id_of_string "wildcard")) in Name id, id :: avoid in - trace (str "Treated pattern variable " ++ str (string_of_id (id_of_name name))); PatVar (l, name), [name, None, ty] @ realargs, mkRel 1, ty, (List.map (fun x -> mkRel 1) realargs), 1, avoid | PatCstr (l,((_, i) as cstr),args,alias) -> let cind = inductive_of_constructor cstr in @@ -1665,11 +1618,8 @@ let constr_of_pat env isevars arsign pat avoid = 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 "Getting type of app: " ++ my_print_constr env app); let apptype = Retyping.get_type_of env (Evd.evars_of !isevars) app in - trace (str "Family and args of apptype: " ++ my_print_constr env apptype); let IndType (indf, realargs) = find_rectype env (Evd.evars_of !isevars) apptype in - trace (str "Got Family and args of apptype: " ++ my_print_constr env apptype); match alias with Anonymous -> pat', sign, app, apptype, realargs, n, avoid @@ -1680,8 +1630,6 @@ let constr_of_pat env isevars arsign pat avoid = try let env = push_rels sign env in isevars := the_conv_x_leq (push_rels sign env) (lift (succ m) ty) (lift 1 apptype) !isevars; - trace (str "convertible types for alias : " ++ my_print_constr env (lift (succ m) ty) - ++ my_print_constr env (lift 1 apptype)); let eq_t = mk_eq (lift (succ m) ty) (mkRel 1) (* alias *) (lift 1 app) (* aliased term *) @@ -1693,15 +1641,8 @@ let constr_of_pat env isevars arsign pat avoid = (* Mark the equality as a hole *) pat', sign, lift i app, lift i apptype, realargs, n + i, avoid in -(* let tycon, arity = mk_tycon_from_sign env isevars arsign arity in *) let pat', sign, patc, patty, args, z, avoid = typ env (pi3 (List.hd arsign), List.tl arsign) pat avoid in - let c = it_mkProd_or_LetIn patc sign in - trace (str "arity signature is : " ++ my_print_rel_context env arsign); - trace (str "signature is : " ++ my_print_rel_context env sign); - trace (str "patty, args are : " ++ my_print_constr env (applistc patty args)); - trace (str "Constr_of_pat gives: " ++ my_print_constr env c); - trace (str "with args: " ++ pp_list (my_print_constr (push_rels sign env)) args); - pat', (sign, patc, (pi3 (List.hd arsign), args), pat'), avoid + pat', (sign, patc, (pi3 (List.hd arsign), args), pat'), avoid (* shadows functional version *) @@ -1729,7 +1670,7 @@ let vars_of_ctx ctx = match na with Anonymous -> raise (Invalid_argument "vars_of_ctx") | Name n -> n, RVar (dummy_loc, n) :: vars) - ctx (id_of_string "vars_of_ctx: error", []) + ctx (id_of_string "vars_of_ctx_error", []) in List.rev y let rec is_included x y = @@ -1740,14 +1681,17 @@ let rec is_included x y = if i = i' then List.for_all2 is_included args args' else false -(* liftsign is the current pattern's signature length *) +(* liftsign is the current pattern's complete signature length. Hence pats is already typed in its + full signature. However prevpatterns are in the original one signature per pattern form. + *) let build_ineqs prevpatterns pats liftsign = let _tomatchs = List.length pats in let diffs = List.fold_left (fun c eqnpats -> - let acc = List.fold_left2 - (fun acc (ppat_sign, ppat_c, (ppat_ty, ppat_tyargs), ppat) + let acc = List.fold_left2 + (* ppat is the pattern we are discriminating against, curpat is the current one. *) + (fun acc (ppat_sign, ppat_c, (ppat_ty, ppat_tyargs), ppat) (curpat_sign, curpat_c, (curpat_ty, curpat_tyargs), curpat) -> match acc with None -> None @@ -1757,21 +1701,16 @@ let build_ineqs prevpatterns pats liftsign = let lens = List.length ppat_sign in (* Accumulated length of previous pattern's signatures *) let len' = lens + len in - trace (str "Lifting " ++ my_print_constr Environ.empty_env curpat_c ++ str " by " - ++ int len'); let acc = ((* Jump over previous prevpat signs *) lift_rel_context len ppat_sign @ sign, len', succ n, (* nth pattern *) mkApp (Lazy.force eq_ind, - [| lift (lens + liftsign) ppat_ty ; - liftn liftsign (succ lens) ppat_c ; + [| lift (len' + liftsign) curpat_ty; + liftn (len + liftsign) (succ lens) ppat_c ; lift len' curpat_c |]) :: - List.map - (fun t -> - liftn (List.length curpat_sign) (succ len') (* Jump over the curpat signature *) - (lift lens t (* Jump over this prevpat signature *))) c) + List.map (lift lens (* Jump over this prevpat signature *)) c) in Some acc else None) (Some ([], 0, 0, [])) eqnpats pats @@ -1790,20 +1729,19 @@ let subst_rel_context k ctx subst = let (_, ctx') = List.fold_right (fun (n, b, t) (k, acc) -> - (succ k, (n, option_map (substnl subst k) b, substnl subst k t) :: acc)) + (succ k, (n, Option.map (substnl subst k) b, substnl subst k t) :: acc)) ctx (k, []) in ctx' let lift_rel_contextn n k sign = let rec liftrec k = function | (na,c,t)::sign -> - (na,option_map (liftn n k) c,type_app (liftn n k) t) - ::(liftrec (k-1) sign) + (na,Option.map (liftn n k) c,liftn n k t)::(liftrec (k-1) sign) | [] -> [] in liftrec (rel_context_length sign + k) sign -let constrs_of_pats typing_fun tycon env isevars eqns tomatchs sign neqs eqs arity = +let constrs_of_pats typing_fun env isevars eqns tomatchs sign neqs arity = let i = ref 0 in let (x, y, z) = List.fold_left @@ -1815,71 +1753,53 @@ let constrs_of_pats typing_fun tycon env isevars eqns tomatchs sign neqs eqs ari (idents, pat' :: newpatterns, cpat :: pats)) ([], [], []) eqn.patterns sign in - let newpatterns = List.rev newpatterns and pats = List.rev pats in + let newpatterns = List.rev newpatterns and opats = List.rev pats in let rhs_rels, pats, signlen = List.fold_left (fun (renv, pats, n) (sign,c, (s, args), p) -> (* Recombine signatures and terms of all of the row's patterns *) -(* trace (str "treating pattern:" ++ my_print_constr Environ.empty_env c); *) let sign' = lift_rel_context n sign in let len = List.length sign' in (sign' @ renv, (* lift to get outside of previous pattern's signatures. *) (sign', liftn n (succ len) c, (s, List.map (liftn n (succ len)) args), p) :: pats, len + n)) - ([], [], 0) pats in + ([], [], 0) opats in let pats, _ = List.fold_left (* lift to get outside of past patterns to get terms in the combined environment. *) (fun (pats, n) (sign, c, (s, args), p) -> let len = List.length sign in ((rels_of_patsign sign, lift n c, (s, List.map (lift n) args), p) :: pats, len + n)) - ([], 0) pats + ([], 0) pats in + let ineqs = build_ineqs prevpatterns pats signlen in let rhs_rels' = rels_of_patsign rhs_rels in let _signenv = push_rel_context rhs_rels' env in -(* trace (str "Env with signature is: " ++ my_print_env _signenv); *) - let ineqs = build_ineqs prevpatterns pats signlen in - let eqs_rels = - let eqs = (*List.concat (List.rev eqs)*) context_of_arsign eqs in + let arity = let args, nargs = List.fold_right (fun (sign, c, (_, args), _) (allargs,n) -> -(* trace (str "treating arg:" ++ my_print_constr Environ.empty_env c); *) (args @ c :: allargs, List.length args + succ n)) pats ([], 0) in let args = List.rev args in -(* trace (str " equalities " ++ my_print_rel_context Environ.empty_env eqs); *) -(* trace (str " args " ++ pp_list (my_print_constr _signenv) args); *) - (* Make room for substitution of prime arguments by constr patterns *) - let eqs' = lift_rel_contextn signlen nargs eqs in - let eqs'' = subst_rel_context 0 eqs' args in -(* trace (str " new equalities " ++ my_print_rel_context Environ.empty_env eqs'); *) -(* trace (str " subtituted equalities " ++ my_print_rel_context _signenv eqs''); *) - eqs'' + substl args (liftn signlen (succ nargs) arity) in - let rhs_rels', lift_ineqs = - match ineqs with - None -> eqs_rels @ rhs_rels', 0 - | Some ineqs -> - (* let _ = trace (str"Generated inequalities: " ++ my_print_constr env ineqs) in *) - lift_rel_context 1 eqs_rels @ ((Anonymous, None, ineqs) :: rhs_rels'), 1 + let rhs_rels', tycon = + let neqs_rels, arity = + match ineqs with + | None -> [], arity + | Some ineqs -> + [Anonymous, None, ineqs], lift 1 arity + in + let eqs_rels, arity = decompose_prod_n_assum neqs arity in + eqs_rels @ neqs_rels @ rhs_rels', arity 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_rels + lift_ineqs + 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 j = typing_fun (mk_tycon tycon) rhs_env eqn.rhs.it in 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 @@ -1890,22 +1810,13 @@ let constrs_of_pats typing_fun tycon env isevars eqns tomatchs sign neqs eqs ari Some _ -> RApp (dummy_loc, branch, [ hole ]) | None -> branch 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, - pats :: prevpatterns)) + incr i; + let rhs = { eqn.rhs with it = branch } in + (branch_decl :: branches, + { eqn with patterns = newpatterns; rhs = rhs } :: eqns, + opats :: prevpatterns)) ([], [], []) eqns in x, y - - -(* 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 @@ -1920,11 +1831,6 @@ let constrs_of_pats typing_fun tycon env isevars eqns tomatchs sign neqs eqs ari 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 -(* (try List.iter *) -(* (fun arsign -> *) -(* trace (str "arity signature: " ++ my_print_rel_context env arsign)) *) -(* arsign; *) -(* with _ -> trace (str "error in arity signature printing")); *) let env = List.fold_right push_rels arsign env in let allnames = List.rev (List.map (List.map pi1) arsign) in match rtntyp with @@ -1984,15 +1890,10 @@ let build_dependent_signature env evars avoid tomatchs arsign = (* Build the arity signature following the names in matched terms as much as possible *) let argsign = List.tl arsign in (* arguments in inverse application order *) let (appn, appb, appt) as _appsign = List.hd arsign in (* The matched argument *) -(* let _ = trace (str "Working on dependent arg: " ++ my_print_rel_context *) -(* (push_rel_context argsign env) [_appsign]) *) -(* in *) let argsign = List.rev argsign in (* arguments in application order *) let env', nargeqs, argeqs, refl_args, slift, argsign' = List.fold_left2 (fun (env, nargeqs, argeqs, refl_args, slift, argsign') arg (name, b, t) -> -(* trace (str "Matching indexes: " ++ my_print_constr env arg ++ *) -(* str " and " ++ my_print_rel_context env [(name,b,t)]); *) let argt = Retyping.get_type_of env evars arg in let eq, refl_arg = if Reductionops.is_conv env evars argt t then @@ -2001,7 +1902,7 @@ let build_dependent_signature env evars avoid tomatchs arsign = (lift (nargeqs + nar) arg), mk_eq_refl argt arg) else - (mk_JMeq (lift (nargeqs + slift) appt) + (mk_JMeq (lift (nargeqs + slift) t) (mkRel (nargeqs + slift)) (lift (nargeqs + nar) argt) (lift (nargeqs + nar) arg), @@ -2022,10 +1923,6 @@ let build_dependent_signature env evars avoid tomatchs arsign = (Name id, b, t) :: argsign')) (env, 0, [], [], slift, []) args argsign in -(* trace (str "neqs: " ++ int neqs ++ spc () ++ *) -(* str "nargeqs: " ++ int nargeqs ++spc () ++ *) -(* str "slift: " ++ int slift ++spc () ++ *) -(* str "nar: " ++ int nar); *) let eq = mk_JMeq (lift (nargeqs + slift) appt) (mkRel (nargeqs + slift)) @@ -2045,15 +1942,10 @@ let build_dependent_signature env evars avoid tomatchs arsign = let (name, b, typ) = match arsign with [x] -> x | _ -> assert(false) in let previd, id = make_prime avoid name in let arsign' = (Name id, b, typ) in -(* let _ = trace (str "Working on arg: " ++ my_print_rel_context *) -(* env [arsign']) *) -(* in *) let tomatch_ty = type_of_tomatch ty in let eq = mk_eq (lift nar tomatch_ty) (mkRel slift) (lift nar tm) -(* mk_eq (lift (neqs + nar) tomatch_ty) *) -(* (mkRel (neqs + slift)) (lift (neqs + nar) tm) *) in ([(Name (eq_id avoid previd), None, eq)] :: eqs, succ neqs, (mk_eq_refl tomatch_ty tm) :: refl_args, @@ -2062,28 +1954,7 @@ let build_dependent_signature env evars avoid tomatchs arsign = in let arsign'' = List.rev arsign' in assert(slift = 0); (* we must have folded over all elements of the arity signature *) -(* begin try *) -(* List.iter *) -(* (fun arsign -> *) -(* trace (str "old arity signature: " ++ my_print_rel_context env arsign)) *) -(* arsign; *) - List.iter - (fun c -> - trace (str "new arity signature: " ++ my_print_rel_context env c)) - (arsign''); -(* with _ -> trace (str "error in arity signature printing") *) -(* end; *) - let env' = push_rel_context (context_of_arsign arsign') env in - let _eqsenv = push_rel_context (context_of_arsign eqs) env' in - (try trace (str "Where env with eqs is: " ++ my_print_env _eqsenv); - trace (str "args: " ++ List.fold_left (fun acc x -> acc ++ my_print_constr env x) - (mt()) refls) - with _ -> trace (str "error in equalities signature printing")); - arsign'', allnames, nar, eqs, neqs, refls - -(* let len = List.length eqs in *) -(* it_mkProd_wo_LetIn (lift (nar + len) pred) eqs, pred, len *) - + arsign'', allnames, nar, eqs, neqs, refls (**************************************************************************) (* Main entry of the matching compilation *) @@ -2091,8 +1962,7 @@ let build_dependent_signature env evars avoid tomatchs arsign = let liftn_rel_context n k sign = let rec liftrec k = function | (na,c,t)::sign -> - (na,option_map (liftn n k) c,type_app (liftn n k) t) - ::(liftrec (k-1) sign) + (na,Option.map (liftn n k) c,liftn n k t)::(liftrec (k-1) sign) | [] -> [] in liftrec (k + rel_context_length sign) sign @@ -2101,73 +1971,109 @@ let nf_evars_env evar_defs (env : env) : env = let nf t = nf_isevar evar_defs t in let env0 : env = reset_context env in let f e (na, b, t) e' : env = - Environ.push_named (na, option_map nf b, nf t) e' + Environ.push_named (na, Option.map nf b, nf t) e' in let env' = Environ.fold_named_context f ~init:env0 env in - Environ.fold_rel_context (fun e (na, b, t) e' -> Environ.push_rel (na, option_map nf b, nf t) e') + Environ.fold_rel_context (fun e (na, b, t) e' -> Environ.push_rel (na, Option.map nf b, nf t) e') ~init:env' env -let compile_cases loc (typing_fun, isevars) (tycon : Evarutil.type_constraint) env (predopt, tomatchl, eqns) = +(* We put the tycon inside the arity signature, possibly discovering dependencies. *) + +let prepare_predicate_from_arsign_tycon loc env evm tomatchs arsign c = + let nar = List.fold_left (fun n sign -> List.length sign + n) 0 arsign in + let subst, len = + List.fold_left2 (fun (subst, len) (tm, tmtype) sign -> + let signlen = List.length sign in + match kind_of_term tm with + | Rel n when dependent tm c + && signlen = 1 (* The term to match is not of a dependent type itself *) -> + ((n, len) :: subst, len - signlen) + | Rel _ when not (dependent tm c) + && signlen > 1 (* The term is of a dependent type but does not appear in + the tycon, maybe some variable in its type does. *) -> + (match tmtype with + NotInd _ -> (* len - signlen, subst*) assert false (* signlen > 1 *) + | IsInd (_, IndType(indf,realargs)) -> + List.fold_left + (fun (subst, len) arg -> + match kind_of_term arg with + | Rel n when dependent arg c -> + ((n, len) :: subst, pred len) + | _ -> (subst, pred len)) + (subst, len) realargs) + | _ -> (subst, len - signlen)) + ([], nar) tomatchs arsign + in + let rec predicate lift c = + match kind_of_term c with + | Rel n when n > lift -> + (try + (* Make the predicate dependent on the matched variable *) + let idx = List.assoc (n - lift) subst in + mkRel (idx + lift) + with Not_found -> + (* A variable that is not matched, lift over the arsign. *) + mkRel (n + nar)) + | _ -> + map_constr_with_binders succ predicate lift c + in + try + (* The tycon may be ill-typed after abstraction. *) + let pred = predicate 0 c in + let env' = push_rel_context (context_of_arsign arsign) env in + ignore(Typing.sort_of env' evm pred); pred + with _ -> lift nar c + +let compile_cases loc style (typing_fun, isevars) (tycon : Evarutil.type_constraint) env (predopt, tomatchl, eqns) = + + let typing_fun tycon env = typing_fun tycon env isevars 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 -(* isevars := nf_evar_defs !isevars; *) -(* let env = nf_evars_env !isevars (env : env) in *) -(* trace (str "Evars : " ++ my_print_evardefs !isevars); *) -(* trace (str "Env : " ++ my_print_env env); *) - - 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 let _isdep = List.exists (fun (x, y) -> is_dependent_ind y) tomatchs in if predopt = None then + let tomatchs, tomatchs_lets = abstract_tomatch env tomatchs in + let tomatchs_len = List.length tomatchs_lets in + let env = push_rel_context tomatchs_lets env in let len = List.length eqns in let sign, allnames, signlen, eqs, neqs, args = (* The arity signature *) let arsign = extract_arity_signatures env tomatchs (List.map snd tomatchl) in (* Build the dependent arity signature, the equalities which makes the first part of the predicate and their instantiations. *) - trace (str "Arity signatures : " ++ my_print_rel_context env (context_of_arsign arsign)); let avoid = [] in build_dependent_signature env (Evd.evars_of !isevars) avoid tomatchs arsign in - let tycon_constr = + let tycon, arity = match valcon_of_tycon tycon with - | None -> mkExistential env isevars - | Some t -> t + | None -> let ev = mkExistential env isevars in ev, ev + | Some t -> + t, prepare_predicate_from_arsign_tycon loc env (Evd.evars_of !isevars) + tomatchs sign (lift tomatchs_len t) + in + let arity = + it_mkProd_or_LetIn (lift neqs arity) (context_of_arsign eqs) in let lets, matx = (* Type the rhs under the assumption of equations *) - constrs_of_pats typing_fun tycon env isevars matx tomatchs sign neqs - (eqs : rel_context list) (lift (signlen + neqs) tycon_constr) in - + constrs_of_pats typing_fun env isevars matx tomatchs sign neqs arity + in let matx = List.rev matx in let _ = assert(len = List.length lets) 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 tomatchs = List.map (fun (x, y) -> lift len x, lift_tomatch_type len y) tomatchs in let args = List.rev_map (lift len) args in - let sign = List.map (lift_rel_context len) sign in - let pred = it_mkProd_wo_LetIn (lift (signlen + neqs) tycon_constr) - (context_of_arsign eqs) in + let pred = liftn len (succ signlen) arity in + let pred = build_initial_predicate true allnames pred in - let pred = liftn len (succ signlen) pred in -(* it_mkProd_wo_LetIn (lift (len + signlen + neqs) tycon_constr) (liftn_rel_context len signlen eqs) in*) - (* We build the elimination predicate if any and check its consistency *) - (* with the type of arguments to match *) - let _signenv = List.fold_right push_rels sign env in -(* trace (str "Using predicate: " ++ my_print_constr signenv pred ++ str " in env: " ++ my_print_env signenv ++ str " len is " ++ int len); *) - - let pred = - (* prepare_predicate_from_tycon loc typing_fun isevars env tomatchs eqs allnames signlen sign tycon in *) - build_initial_predicate true allnames pred 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) *) + (* 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 = @@ -2178,17 +2084,17 @@ let compile_cases loc (typing_fun, isevars) (tycon : Evarutil.type_constraint) e history = start_history (List.length initial_pushed); mat = matx; caseloc = loc; + casestyle= style; typing_function = typing_fun } in - let _, j = compile pb in + let j = compile pb in (* We check for unused patterns *) List.iter (check_unused_pattern env) matx; 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 = lift (-tomatchs_len) (nf_isevar !isevars tycon_constr); } + uj_type = nf_isevar !isevars tycon; } in j -(* inh_conv_coerce_to_tycon loc env isevars j tycon0 *) else (* We build the elimination predicate if any and check its consistency *) (* with the type of arguments to match *) @@ -2207,12 +2113,12 @@ let compile_cases loc (typing_fun, isevars) (tycon : Evarutil.type_constraint) e history = start_history (List.length initial_pushed); mat = matx; caseloc = loc; + casestyle= style; typing_function = typing_fun } in - let _, j = compile pb 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 index 02fe016d..6b8a0981 100644 --- a/contrib/subtac/subtac_cases.mli +++ b/contrib/subtac/subtac_cases.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: cases.mli 8741 2006-04-26 22:30:32Z herbelin $ i*) +(*i $Id: subtac_cases.mli 10739 2008-04-01 14:45:20Z herbelin $ i*) (*i*) open Util diff --git a/contrib/subtac/subtac_classes.ml b/contrib/subtac/subtac_classes.ml new file mode 100644 index 00000000..15addb44 --- /dev/null +++ b/contrib/subtac/subtac_classes.ml @@ -0,0 +1,210 @@ +(************************************************************************) +(* 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: subtac_classes.ml 11047 2008-06-03 23:08:00Z msozeau $ i*) + +open Pretyping +open Evd +open Environ +open Term +open Rawterm +open Topconstr +open Names +open Libnames +open Pp +open Vernacexpr +open Constrintern +open Subtac_command +open Typeclasses +open Typeclasses_errors +open Termops +open Decl_kinds +open Entries +open Util + +module SPretyping = Subtac_pretyping.Pretyping + +let interp_binder_evars evdref env na t = + let t = Constrintern.intern_gen true (Evd.evars_of !evdref) env t in + SPretyping.understand_tcc_evars evdref env IsType t + +let interp_binders_evars isevars env avoid l = + List.fold_left + (fun (env, ids, params) ((loc, i), t) -> + let n = Name i in + let t' = interp_binder_evars isevars env n t in + let d = (i,None,t') in + (push_named d env, i :: ids, d::params)) + (env, avoid, []) l + +let interp_typeclass_context_evars isevars env avoid l = + List.fold_left + (fun (env, ids, params) (iid, bk, cl) -> + let t' = interp_binder_evars isevars env (snd iid) cl in + let i = match snd iid with + | Anonymous -> Nameops.next_name_away (Termops.named_hd env t' Anonymous) ids + | Name id -> id + in + let d = (i,None,t') in + (push_named d env, i :: ids, d::params)) + (env, avoid, []) l + +let interp_constrs_evars isevars env avoid l = + List.fold_left + (fun (env, ids, params) t -> + let t' = interp_binder_evars isevars env Anonymous t in + let id = Nameops.next_name_away (Termops.named_hd env t' Anonymous) ids in + let d = (id,None,t') in + (push_named d env, id :: ids, d::params)) + (env, avoid, []) l + +let interp_constr_evars_gen evdref env ?(impls=([],[])) kind c = + SPretyping.understand_tcc_evars evdref env kind + (intern_gen (kind=IsType) ~impls (Evd.evars_of !evdref) env c) + +let interp_casted_constr_evars evdref env ?(impls=([],[])) c typ = + interp_constr_evars_gen evdref env ~impls (OfType (Some typ)) c + +let type_ctx_instance isevars env ctx inst subst = + List.fold_left2 + (fun (subst, instctx) (na, _, t) ce -> + let t' = replace_vars subst t in + let c = interp_casted_constr_evars isevars env ce t' in + let d = na, Some c, t' in + (na, c) :: subst, d :: instctx) + (subst, []) (List.rev ctx) inst + +(*let superclass_ce = CRef (Ident (dummy_loc, id_of_string ".superclass"))*) + +let type_class_instance_params isevars env id n ctx inst subst = + List.fold_left2 + (fun (subst, instctx) (na, _, t) ce -> + let t' = replace_vars subst t in + let c = +(* if ce = superclass_ce then *) + (* (\* Control over the evars which are direct superclasses to avoid partial instanciations *) + (* in instance search. *\) *) + (* Evarutil.e_new_evar isevars env ~src:(dummy_loc, ImplicitArg (VarRef id, (n, Some na))) t' *) + (* else *) + interp_casted_constr_evars isevars env ce t' + in + let d = na, Some c, t' in + (na, c) :: subst, d :: instctx) + (subst, []) (List.rev ctx) inst + +let substitution_of_constrs ctx cstrs = + List.fold_right2 (fun c (na, _, _) acc -> (na, c) :: acc) cstrs ctx [] + +let new_instance ?(global=false) ctx (instid, bk, cl) props ?(on_free_vars=Classes.default_on_free_vars) pri = + let env = Global.env() in + let isevars = ref (Evd.create_evar_defs Evd.empty) in + let bound = Implicit_quantifiers.ids_of_list (Termops.ids_of_context env) in + let bound, fvs = Implicit_quantifiers.free_vars_of_binders ~bound [] ctx in + let tclass = + match bk with + | Implicit -> + let loc, id, par = Implicit_quantifiers.destClassAppExpl cl in + let k = class_info (Nametab.global id) in + let applen = List.fold_left (fun acc (x, y) -> if y = None then succ acc else acc) 0 par in + let needlen = List.fold_left (fun acc (x, y) -> if x = None then succ acc else acc) 0 k.cl_context in + if needlen <> applen then + Classes.mismatched_params env (List.map fst par) (List.map snd k.cl_context); + let pars, _ = Implicit_quantifiers.combine_params Idset.empty (* need no avoid *) + (fun avoid (clname, (id, _, t)) -> + match clname with + Some (cl, b) -> + let t = + if b then + let _k = class_info cl in + CHole (Util.dummy_loc, Some Evd.InternalHole) (* (Evd.ImplicitArg (IndRef k.cl_impl, (1, None)))) *) + else CHole (Util.dummy_loc, None) + in t, avoid + | None -> failwith ("new instance: under-applied typeclass")) + par (List.rev k.cl_context) + in Topconstr.CAppExpl (loc, (None, id), pars) + + | Explicit -> cl + in + let ctx_bound = Idset.union bound (Implicit_quantifiers.ids_of_list fvs) in + let gen_ids = Implicit_quantifiers.free_vars_of_constr_expr ~bound:ctx_bound tclass [] in + let bound = Idset.union (Implicit_quantifiers.ids_of_list gen_ids) ctx_bound in + on_free_vars (List.rev (gen_ids @ fvs)); + let gen_ctx = Implicit_quantifiers.binder_list_of_ids gen_ids in + let ctx, avoid = Classes.name_typeclass_binders bound ctx in + let ctx = List.append ctx (List.rev gen_ctx) in + let k, ctx', imps, subst = + let c = Command.generalize_constr_expr tclass ctx in + let c', imps = interp_type_evars_impls ~evdref:isevars env c in + let ctx, c = Classes.decompose_named_assum c' in + let cl, args = Typeclasses.dest_class_app c in + cl, ctx, imps, substitution_of_constrs (List.map snd cl.cl_context) (List.rev (Array.to_list args)) + in + let id = + match snd instid with + Name id -> + let sp = Lib.make_path id in + if Nametab.exists_cci sp then + errorlabstrm "new_instance" (Nameops.pr_id id ++ Pp.str " already exists"); + id + | Anonymous -> + let i = Nameops.add_suffix (Classes.id_of_class k) "_instance_0" in + Termops.next_global_ident_away false i (Termops.ids_of_context env) + in + let env' = Classes.push_named_context ctx' env in + isevars := Evarutil.nf_evar_defs !isevars; + isevars := resolve_typeclasses ~onlyargs:false ~fail:true env' !isevars; + let sigma = Evd.evars_of !isevars in + let substctx = Typeclasses.nf_substitution sigma subst in + let subst, _propsctx = + let props = + List.map (fun (x, l, d) -> + x, Topconstr.abstract_constr_expr d (Classes.binders_of_lidents l)) + props + in + if List.length props > List.length k.cl_props then + Classes.mismatched_props env' (List.map snd props) k.cl_props; + let props, rest = + List.fold_left + (fun (props, rest) (id,_,_) -> + try + let ((loc, mid), c) = List.find (fun ((_,id'), c) -> id' = id) rest in + let rest' = List.filter (fun ((_,id'), c) -> id' <> id) rest in + Constrintern.add_glob loc (ConstRef (List.assoc mid k.cl_projs)); + c :: props, rest' + with Not_found -> (CHole (Util.dummy_loc, None) :: props), rest) + ([], props) k.cl_props + in + if rest <> [] then + unbound_method env' k.cl_impl (fst (List.hd rest)) + else + type_ctx_instance isevars env' k.cl_props props substctx + in + let inst_constr, ty_constr = instance_constructor k (List.rev_map snd subst) in + isevars := Evarutil.nf_evar_defs !isevars; + let term = Evarutil.nf_isevar !isevars (it_mkNamedLambda_or_LetIn inst_constr ctx') + and termtype = Evarutil.nf_isevar !isevars (it_mkNamedProd_or_LetIn ty_constr ctx') + in + isevars := undefined_evars !isevars; + Evarutil.check_evars env Evd.empty !isevars termtype; +(* let imps = *) +(* Util.list_map_i *) +(* (fun i binder -> *) +(* match binder with *) +(* ExplByPos (i, Some na), (true, true)) *) +(* 1 ctx *) +(* in *) + let hook gr = + let cst = match gr with ConstRef kn -> kn | _ -> assert false in + let inst = Typeclasses.new_instance k pri global cst in + Impargs.declare_manual_implicits false gr false imps; + Typeclasses.add_instance inst + in + let evm = Subtac_utils.evars_of_term (Evd.evars_of !isevars) Evd.empty term in + let obls, constr, typ = Eterm.eterm_obligations env id !isevars evm 0 term termtype in + ignore(Subtac_obligations.add_definition id constr typ ~kind:(Global,false,Instance) ~hook obls); + id diff --git a/contrib/subtac/subtac_classes.mli b/contrib/subtac/subtac_classes.mli new file mode 100644 index 00000000..43f00107 --- /dev/null +++ b/contrib/subtac/subtac_classes.mli @@ -0,0 +1,42 @@ +(************************************************************************) +(* 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: subtac_classes.mli 10797 2008-04-15 13:19:33Z msozeau $ i*) + +(*i*) +open Names +open Decl_kinds +open Term +open Sign +open Evd +open Environ +open Nametab +open Mod_subst +open Topconstr +open Util +open Typeclasses +open Implicit_quantifiers +open Classes +(*i*) + +val type_ctx_instance : Evd.evar_defs ref -> + Environ.env -> + (Names.identifier * 'a * Term.constr) list -> + Topconstr.constr_expr list -> + (Names.identifier * Term.constr) list -> + (Names.identifier * Term.constr) list * + (Names.identifier * Term.constr option * Term.constr) list + +val new_instance : + ?global:bool -> + Topconstr.local_binder list -> + typeclass_constraint -> + binder_def_list -> + ?on_free_vars:(identifier list -> unit) -> + int option -> + identifier diff --git a/contrib/subtac/subtac_coercion.ml b/contrib/subtac/subtac_coercion.ml index c764443f..b45e23d0 100644 --- a/contrib/subtac/subtac_coercion.ml +++ b/contrib/subtac/subtac_coercion.ml @@ -1,3 +1,4 @@ +(* -*- compile-command: "make -C ../.. bin/coqtop.byte" -*- *) (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) @@ -5,7 +6,7 @@ (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: subtac_coercion.ml 9976 2007-07-12 11:58:30Z msozeau $ *) +(* $Id: subtac_coercion.ml 11143 2008-06-18 15:52:42Z msozeau $ *) open Util open Names @@ -129,34 +130,45 @@ module Coercion = struct with Reduction.NotConvertible -> coerce' env x y and coerce' env x y : (Term.constr -> Term.constr) option = let subco () = subset_coerce env isevars x y in - let rec coerce_application typ c c' l l' = + let rec coerce_application typ typ' c c' l l' = let len = Array.length l in - let rec aux tele typ i co = + let rec aux tele typ typ' i co = +(* (try trace (str "coerce_application.aux from " ++ (my_print_constr env x) ++ *) +(* str " to "++ my_print_constr env y *) +(* ++ str "in env:" ++ my_print_env env); *) +(* with _ -> ()); *) if i < len then let hdx = l.(i) and hdy = l'.(i) in try isevars := the_conv_x_leq env hdx hdy !isevars; let (n, eqT, restT) = destProd typ in - aux (hdx :: tele) (subst1 hdy restT) (succ i) co + let (n', eqT', restT') = destProd typ' in + aux (hdx :: tele) (subst1 hdx restT) (subst1 hdy restT') (succ i) co with Reduction.NotConvertible -> let (n, eqT, restT) = destProd typ in + let (n', eqT', restT') = destProd typ' in + let _ = + try isevars := the_conv_x_leq env eqT eqT' !isevars + with Reduction.NotConvertible -> raise NoSubtacCoercion + in + (* Disallow equalities on arities *) + if Reduction.is_arity env eqT then raise NoSubtacCoercion; let restargs = lift_args 1 (List.rev (Array.to_list (Array.sub l (succ i) (len - (succ i))))) in let args = List.rev (restargs @ mkRel 1 :: lift_args 1 tele) in let pred = mkLambda (n, eqT, applistc (lift 1 c) args) in let eq = mkApp (Lazy.force eq_ind, [| eqT; hdx; hdy |]) in -(* let jmeq = mkApp (Lazy.force jmeq_ind, [| eqT; hdx; eqT; hdy |]) in *) - let evar = make_existential dummy_loc env isevars eq in + let evar = make_existential loc env isevars eq in let eq_app x = mkApp (Lazy.force eq_rect, [| eqT; hdx; pred; x; hdy; evar|]) in - trace (str"Inserting coercion at application"); - aux (hdy :: tele) (subst1 hdy restT) (succ i) (fun x -> eq_app (co x)) - else co - in aux [] typ 0 (fun x -> x) + aux (hdy :: tele) (subst1 hdx restT) (subst1 hdy restT') (succ i) (fun x -> eq_app (co x)) + else Some co + in aux [] typ typ' 0 (fun x -> x) in -(* (try debug 1 (str "coerce' from " ++ (my_print_constr env x) ++ *) -(* str " to "++ my_print_constr env y); *) -(* with _ -> ()); *) +(* (try trace (str "coerce' from " ++ (my_print_constr env x) ++ *) +(* str " to "++ my_print_constr env y *) +(* ++ str "in env:" ++ my_print_env env); *) +(* with _ -> ()); *) match (kind_of_term x, kind_of_term y) with | Sort s, Sort s' -> (match s, s' with @@ -167,24 +179,35 @@ module Coercion = struct | Prod (name, a, b), Prod (name', a', b') -> let name' = Name (Nameops.next_ident_away (id_of_string "x") (Termops.ids_of_context env)) in let env' = push_rel (name', None, a') env in + +(* let c1 = coerce_unify env' (lift 1 a') (lift 1 a) in *) +(* let name'' = Name (Nameops.next_ident_away (id_of_string "x'") (Termops.ids_of_context env)) in *) +(* let env'' = push_rel (name'', Some (app_opt c1 (mkRel 1)), lift 1 a) env' in *) +(* let c2 = coerce_unify env'' (liftn 1 1 b) (lift 1 b') in *) +(* mkLetIn (name'', app_opt c1 (mkRel 1), (lift 1 a), *) + let c1 = coerce_unify env' (lift 1 a') (lift 1 a) in - let c2 = coerce_unify env' b b' in + (* env, x : a' |- c1 : lift 1 a' > lift 1 a *) + let coec1 = app_opt c1 (mkRel 1) in + (* env, x : a' |- c1[x] : lift 1 a *) + let c2 = coerce_unify env' (subst1 coec1 (liftn 1 2 b)) b' in + (* env, x : a' |- c2 : b[c1[x]/x]] > b' *) (match c1, c2 with None, None -> failwith "subtac.coerce': Should have detected equivalence earlier" | _, _ -> Some (fun f -> - mkLambda (name', a', - app_opt c2 - (mkApp (Term.lift 1 f, - [| app_opt c1 (mkRel 1) |]))))) + mkLambda (name', a', + app_opt c2 + (mkApp (Term.lift 1 f, [| coec1 |]))))) | App (c, l), App (c', l') -> (match kind_of_term c, kind_of_term c' with - Ind i, Ind i' -> (* Sigma types *) + Ind i, Ind i' -> (* Inductive types *) let len = Array.length l in let existS = Lazy.force existS in let prod = Lazy.force prod in + (* Sigma types *) if len = Array.length l' && len = 2 && i = i' && (i = Term.destInd existS.typ || i = Term.destInd prod.typ) then @@ -248,21 +271,22 @@ module Coercion = struct else if i = i' && len = Array.length l' then let evm = evars_of !isevars in - let typ = Typing.type_of env evm c in (try subco () - with NoSubtacCoercion -> - -(* if not (is_arity env evm typ) then *) - Some (coerce_application typ c c' l l')) -(* else subco () *) + with NoSubtacCoercion -> + let typ = Typing.type_of env evm c in + let typ' = Typing.type_of env evm c' in + (* if not (is_arity env evm typ) then *) + coerce_application typ typ' c c' l l') + (* else subco () *) else subco () | x, y when x = y -> if Array.length l = Array.length l' then let evm = evars_of !isevars in let lam_type = Typing.type_of env evm c in + let lam_type' = Typing.type_of env evm c' in (* if not (is_arity env evm lam_type) then ( *) - Some (coerce_application lam_type c c' l l') + coerce_application lam_type lam_type' c c' l l' (* ) else subco () *) else subco () | _ -> subco ()) @@ -284,7 +308,7 @@ module Coercion = struct Some (fun x -> let cx = app_opt c x in - let evar = make_existential dummy_loc env isevars (mkApp (p, [| cx |])) + let evar = make_existential loc env isevars (mkApp (p, [| cx |])) in (mkApp ((Lazy.force sig_).intro, @@ -298,7 +322,7 @@ module Coercion = struct let coerce_itf loc env isevars v t c1 = let evars = ref isevars in let coercion = coerce loc env evars t c1 in - !evars, option_map (app_opt coercion) v, t + !evars, Option.map (app_opt coercion) v (* Taken from pretyping/coercion.ml *) @@ -360,7 +384,7 @@ module Coercion = struct match kind_of_term t with | Prod (_,_,_) -> (isevars,j) | Evar ev when not (is_defined_evar isevars ev) -> - let (isevars',t) = define_evar_as_arrow isevars ev in + let (isevars',t) = define_evar_as_product isevars ev in (isevars',{ uj_val = j.uj_val; uj_type = t }) | _ -> (try @@ -400,11 +424,15 @@ module Coercion = struct uj_type = typ' } - let inh_coerce_to_fail env isevars c1 v t = + let inh_coerce_to_fail env evd rigidonly v t c1 = + if rigidonly & not (Heads.is_rigid env c1 && Heads.is_rigid env t) + then + raise NoCoercion + else let v', t' = try - let t1,i1 = class_of1 env (evars_of isevars) c1 in - let t2,i2 = class_of1 env (evars_of isevars) t in + let t1,i1 = class_of1 env (evars_of evd) c1 in + let t2,i2 = class_of1 env (evars_of evd) t in let p = lookup_path_between (i2,i1) in match v with Some v -> @@ -413,132 +441,88 @@ module Coercion = struct | None -> None, t with Not_found -> raise NoCoercion in - try (the_conv_x_leq env t' c1 isevars, v', t') + try (the_conv_x_leq env t' c1 evd, v') 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 () ++ *) -(* 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) + + let rec inh_conv_coerce_to_fail loc env evd rigidonly v t c1 = + try (the_conv_x_leq env t c1 evd, v) with Reduction.NotConvertible -> - (try - inh_coerce_to_fail env isevars c1 v t - with NoCoercion -> - (match kind_of_term (whd_betadeltaiota env (evars_of isevars) t), - kind_of_term (whd_betadeltaiota env (evars_of isevars) c1) with - | Prod (_,t1,t2), Prod (name,u1,u2) -> - let v' = option_map (whd_betadeltaiota env (evars_of isevars)) v in - let (evd',b) = - match v' with - Some v' -> - (match kind_of_term v' with - | Lambda (x,v1,v2) -> - (try the_conv_x env v1 u1 isevars, Some (x, v1, v2) (* leq v1 u1? *) - with Reduction.NotConvertible -> (isevars, None)) - | _ -> (isevars, None)) - | None -> (isevars, None) - in - (match b with - Some (x, v1, v2) -> - let env1 = push_rel (x,None,v1) env in - let (evd'', v2', t2') = inh_conv_coerce_to_fail loc env1 evd' - (Some v2) t2 u2 in - (evd'', option_map (fun v2' -> mkLambda (x, v1, v2')) v2', - mkProd (x, v1, t2')) - | None -> - (* Mismatch on t1 and u1 or not a lambda: we eta-expand *) - (* we look for a coercion c:u1->t1 s.t. [name:u1](v' (c x)) *) - (* has type (name:u1)u2 (with v' recursively obtained) *) - let name = (match name with - | Anonymous -> Name (id_of_string "x") - | _ -> name) in - let env1 = push_rel (name,None,u1) env in - let (evd', v1', t1') = - inh_conv_coerce_to_fail loc env1 isevars - (Some (mkRel 1)) (lift 1 u1) (lift 1 t1) - in - let (evd'', v2', t2') = - let v2 = - match v with - Some v -> option_map (fun v1' -> mkApp (lift 1 v, [|v1'|])) v1' - | None -> None - and evd', t2 = - match v1' with - Some v1' -> evd', subst1 v1' t2 - | None -> - let evd', ev = new_evar evd' env ~src:(loc, InternalHole) t1' in - evd', subst1 ev t2 - in - inh_conv_coerce_to_fail loc env1 evd' v2 t2 u2 - in - (evd'', option_map (fun v2' -> mkLambda (name, u1, v2')) v2', - mkProd (name, u1, t2'))) - | _ -> raise NoCoercion)) + try inh_coerce_to_fail env evd rigidonly v t c1 + with NoCoercion -> + match + kind_of_term (whd_betadeltaiota env (evars_of evd) t), + kind_of_term (whd_betadeltaiota env (evars_of evd) c1) + with + | Prod (name,t1,t2), Prod (_,u1,u2) -> + (* Conversion did not work, we may succeed with a coercion. *) + (* We eta-expand (hence possibly modifying the original term!) *) + (* and look for a coercion c:u1->t1 s.t. fun x:u1 => v' (c x)) *) + (* has type forall (x:u1), u2 (with v' recursively obtained) *) + let name = match name with + | Anonymous -> Name (id_of_string "x") + | _ -> name in + let env1 = push_rel (name,None,u1) env in + let (evd', v1) = + inh_conv_coerce_to_fail loc env1 evd rigidonly + (Some (mkRel 1)) (lift 1 u1) (lift 1 t1) in + let v1 = Option.get v1 in + let v2 = Option.map (fun v -> beta_applist (lift 1 v,[v1])) v in + let t2 = Termops.subst_term v1 t2 in + let (evd'',v2') = inh_conv_coerce_to_fail loc env1 evd' rigidonly v2 t2 u2 in + (evd'', Option.map (fun v2' -> mkLambda (name, u1, v2')) v2') + | _ -> raise NoCoercion - (* 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 *) -(* 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 _ -> ()); *) + let inh_conv_coerce_to_gen rigidonly loc env evd cj ((n, t) as _tycon) = + let evd = nf_evar_defs evd in match n with None -> - let (evd', val', type') = + let (evd', val') = try - inh_conv_coerce_to_fail loc env isevars (Some cj.uj_val) cj.uj_type t + inh_conv_coerce_to_fail loc env evd rigidonly + (Some (nf_isevar evd cj.uj_val)) + (nf_isevar evd cj.uj_type) (nf_isevar evd t) with NoCoercion -> - let sigma = evars_of isevars in + let sigma = evars_of evd in try - coerce_itf loc env isevars (Some cj.uj_val) cj.uj_type t + coerce_itf loc env evd (Some cj.uj_val) cj.uj_type t with NoSubtacCoercion -> error_actual_type_loc loc env sigma cj t in let val' = match val' with Some v -> v | None -> assert(false) in (evd',{ uj_val = val'; uj_type = t }) | Some (init, cur) -> - (isevars, cj) + (evd, cj) + + let inh_conv_coerce_to = inh_conv_coerce_to_gen false + let inh_conv_coerce_rigid_to = inh_conv_coerce_to_gen true 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 = + let nabsinit, nabs = match abs with None -> 0, 0 | Some (init, cur) -> init, cur in - (* a little more effort to get products is needed *) + (* a little more effort to get products is needed *) 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', 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' + try + fst (try inh_conv_coerce_to_fail loc env' isevars false None t t' with NoCoercion -> - coerce_itf loc env' isevars None t t') + 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 + else isevars with _ -> isevars - (* trace (str "decompose_prod_n failed"); *) - (* raise (Invalid_argument "Subtac_coercion.inh_conv_coerces_to") *) +(* 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 86139039..5bff6ad1 100644 --- a/contrib/subtac/subtac_command.ml +++ b/contrib/subtac/subtac_command.ml @@ -39,6 +39,8 @@ open Tacticals open Tacinterp open Vernacexpr open Notation +open Evd +open Evarutil module SPretyping = Subtac_pretyping.Pretyping open Subtac_utils @@ -53,22 +55,24 @@ let evar_nf isevars c = Evarutil.nf_isevar !isevars c let interp_gen kind isevars env - ?(impls=([],[])) ?(allow_soapp=false) ?(ltacvars=([],[])) + ?(impls=([],[])) ?(allow_patvar=false) ?(ltacvars=([],[])) c = - let c' = Constrintern.intern_gen (kind=IsType) ~impls ~allow_soapp ~ltacvars (Evd.evars_of !isevars) env c in -(* (try trace (str "Pretyping " ++ my_print_constr_expr c) with _ -> ()); *) + let c' = Constrintern.intern_gen (kind=IsType) ~impls ~allow_patvar ~ltacvars (Evd.evars_of !isevars) env c in let c' = SPretyping.pretype_gen isevars env ([],[]) kind c' in evar_nf isevars c' - + let interp_constr isevars env c = interp_gen (OfType None) isevars env c -let interp_type isevars env ?(impls=([],[])) c = +let interp_type_evars isevars env ?(impls=([],[])) c = interp_gen IsType isevars env ~impls c let interp_casted_constr isevars env ?(impls=([],[])) c typ = interp_gen (OfType (Some typ)) isevars env ~impls c +let interp_casted_constr_evars isevars env ?(impls=([],[])) c typ = + interp_gen (OfType (Some typ)) isevars env ~impls c + let interp_open_constr isevars env c = msgnl (str "Pretyping " ++ my_print_constr_expr c); let c = Constrintern.intern_constr (Evd.evars_of !isevars) env c in @@ -92,26 +96,31 @@ let locate_if_isevar loc na = function let interp_binder sigma env na t = let t = Constrintern.intern_gen true (Evd.evars_of !sigma) env t in - SPretyping.understand_type (Evd.evars_of !sigma) env (locate_if_isevar (loc_of_rawconstr t) na t) - - -let interp_context sigma env params = - List.fold_left - (fun (env,params) d -> match d with - | LocalRawAssum ([_,na],(CHole _ as t)) -> - let t = interp_binder sigma env na t in - let d = (na,None,t) in - (push_rel d env, d::params) - | LocalRawAssum (nal,t) -> - let t = interp_type sigma env t in - let ctx = list_map_i (fun i (_,na) -> (na,None,lift i t)) 0 nal in - let ctx = List.rev ctx in - (push_rel_context ctx env, ctx@params) - | LocalRawDef ((_,na),c) -> - let c = interp_constr_judgment sigma env c in - let d = (na, Some c.uj_val, c.uj_type) in - (push_rel d env,d::params)) - (env,[]) params + SPretyping.pretype_gen sigma env ([], []) IsType (locate_if_isevar (loc_of_rawconstr t) na t) + +let interp_context_evars evdref env params = + let bl = Constrintern.intern_context (Evd.evars_of !evdref) env params in + let (env, par, _, impls) = + List.fold_left + (fun (env,params,n,impls) (na, k, b, t) -> + match b with + None -> + let t' = locate_if_isevar (loc_of_rawconstr t) na t in + let t = SPretyping.understand_tcc_evars evdref env IsType t' in + let d = (na,None,t) in + let impls = + if k = Implicit then + let na = match na with Name n -> Some n | Anonymous -> None in + (ExplByPos (n, na), (true, true)) :: impls + else impls + in + (push_rel d env, d::params, succ n, impls) + | Some b -> + let c = SPretyping.understand_judgment_tcc evdref env b in + let d = (na, Some c.uj_val, c.uj_type) in + (push_rel d env,d::params, succ n, impls)) + (env,[],1,[]) (List.rev bl) + in (env, par), impls (* try to find non recursive definitions *) @@ -126,7 +135,7 @@ let collect_non_rec env = let i = list_try_find_i (fun i f -> - if List.for_all (fun (_, _, def) -> not (occur_var env f def)) ldefrec + if List.for_all (fun (_, def) -> not (occur_var env f def)) ldefrec then i else failwith "try_find_i") 0 lnamerec in @@ -152,14 +161,14 @@ let collect_non_rec env = let list_of_local_binders l = let rec aux acc = function Topconstr.LocalRawDef (n, c) :: tl -> aux ((n, Some c, None) :: acc) tl - | Topconstr.LocalRawAssum (nl, c) :: tl -> + | Topconstr.LocalRawAssum (nl, k, c) :: tl -> aux (List.fold_left (fun acc n -> (n, None, Some c) :: acc) acc nl) tl | [] -> List.rev acc in aux [] l let lift_binders k n l = let rec aux n = function - | (id, t, c) :: tl -> (id, option_map (liftn k n) t, liftn k n c) :: aux (pred n) tl + | (id, t, c) :: tl -> (id, Option.map (liftn k n) t, liftn k n c) :: aux (pred n) tl | [] -> [] in aux n l @@ -172,11 +181,10 @@ let split_args n rel = match list_chop ((List.length rel) - n) rel with | _ -> assert(false) let build_wellfounded (recname, n, bl,arityc,body) r measure notation boxed = + Coqlib.check_required_library ["Coq";"Program";"Wf"]; let sigma = Evd.empty in let isevars = ref (Evd.create_evar_defs sigma) in let env = Global.env() in - let nc = named_context env in - let nc_len = named_context_length nc 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 @@ -188,8 +196,10 @@ let build_wellfounded (recname, n, bl,arityc,body) r measure notation boxed = (* Ppconstr.pr_constr_expr body) *) (* with _ -> () *) (* in *) - let env', binders_rel = interp_context isevars env bl in - let after, ((argname, _, argtyp) as arg), before = split_args (succ n) binders_rel in + let (env', binders_rel), impls = interp_context_evars isevars env bl in + let after, ((argname, _, argtyp) as arg), before = + let idx = list_index (Name (snd n)) (List.rev_map (fun (na, _, _) -> na) binders_rel) in + split_args idx 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,11 +236,10 @@ let build_wellfounded (recname, n, bl,arityc,body) r measure notation boxed = (wf_rel_fun (succ len) (mkRel 1) (mkRel (len + 1)))) in let top_bl = after @ (arg :: before) in - let intern_bl = liftafter @ (wfarg 1 :: arg :: before) in - (try trace (str "Intern bl: " ++ prr intern_bl) with _ -> ()); let top_env = push_rel_context top_bl env in + let top_arity = interp_type_evars isevars top_env arityc in + let intern_bl = wfarg 1 :: arg :: before in let _intern_env = push_rel_context intern_bl env in - let top_arity = interp_type isevars top_env arityc in let proj = (Lazy.force sig_).Coqlib.proj1 in let projection = mkApp (proj, [| argtyp ; @@ -240,29 +249,21 @@ let build_wellfounded (recname, n, bl,arityc,body) r measure notation boxed = |]) in let intern_arity = it_mkProd_or_LetIn top_arity after in - (try trace (str "After length: " ++ int after_length ++ str "Top env: " ++ prr top_bl ++ spc () ++ str "Top arity: " ++ my_print_constr top_env top_arity); - trace (str "Before lifting arity: " ++ my_print_constr env top_arity) with _ -> ()); - (* Top arity is in top_env = after :: arg :: before *) -(* let intern_arity' = liftn 1 (succ after_length) top_arity in (\* arity in after :: wfarg :: arg :: before *\) *) -(* (try trace (str "projection: " "After lifting arity: " ++ my_print_constr env intern_arity' ++ spc ()); *) -(* trace (str "Intern env: " ++ prr intern_bl ++ str "intern_arity': " ++ my_print_constr _intern_env intern_arity') with _ -> ()); *) - let intern_arity = substl [projection] intern_arity in (* substitute the projection of wfarg for arg *) - (try trace (str "Top arity after subst: " ++ my_print_constr (Global.env ()) intern_arity) with _ -> ()); -(* let intern_arity = liftn 1 (succ after_length) intern_arity in (\* back in after :: wfarg :: arg :: before (ie, jump over arg) *\) *) -(* (try trace (str "Top arity after subst and lift: " ++ my_print_constr (Global.env ()) intern_arity) with _ -> ()); *) + (* Intern arity is in top_env = arg :: before *) + let intern_arity = liftn 2 2 intern_arity in +(* trace (str "After lifting arity: " ++ *) +(* my_print_constr (push_rel (Name argid', None, lift 2 argtyp) intern_env) *) +(* intern_arity); *) + (* arity is now in something :: wfarg :: arg :: before + where what refered to arg now refers to something *) + let intern_arity = substl [projection] intern_arity in + (* substitute the projection of wfarg for something *) let intern_before_env = push_rel_context before env in -(* let intern_fun_bl = liftafter @ [wfarg 1] in (\* FixMe dependencies *\) *) -(* (try debug 2 (str "Intern fun bl: " ++ prr intern_fun_bl) with _ -> ()); *) - (try trace (str "Intern arity: " ++ - my_print_constr _intern_env intern_arity) with _ -> ()); let intern_fun_arity_prod = it_mkProd_or_LetIn intern_arity [wfarg 1] in - (try trace (str "Intern fun arity product: " ++ - my_print_constr (push_rel_context [arg] intern_before_env) intern_fun_arity_prod) with _ -> ()); let intern_fun_binder = (Name recname, None, intern_fun_arity_prod) in let fun_bl = liftafter @ (intern_fun_binder :: [arg]) in -(* (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 fun_arity = interp_type_evars 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 _ = @@ -274,161 +275,177 @@ let build_wellfounded (recname, n, bl,arityc,body) r measure notation boxed = (* str "Intern body " ++ pr intern_body_lam) *) with _ -> () in - let _impl = - if Impargs.is_implicit_args() - then Impargs.compute_implicits top_env top_arity - else [] - in let prop = mkLambda (Name argid, argtyp, it_mkProd_or_LetIn top_arity after) in + (* Lift to get to constant arguments *) + let lift_cst = List.length after + 1 in let fix_def = match measure_fn with None -> - mkApp (constr_of_reference (Lazy.force fix_sub_ref), + mkApp (constr_of_global (Lazy.force fix_sub_ref), [| argtyp ; wf_rel ; - make_existential dummy_loc ~opaque:false intern_before_env isevars wf_proof ; - prop ; - intern_body_lam |]) + make_existential dummy_loc ~opaque:false env isevars wf_proof ; + lift lift_cst prop ; + lift lift_cst intern_body_lam |]) | Some f -> - lift (succ after_length) - (mkApp (constr_of_reference (Lazy.force fix_measure_sub_ref), - [| argtyp ; - f ; - prop ; - intern_body_lam |])) + mkApp (constr_of_global (Lazy.force fix_measure_sub_ref), + [| lift lift_cst argtyp ; + lift lift_cst f ; + lift lift_cst prop ; + lift lift_cst intern_body_lam |]) in 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 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 evm = evars_of_term (Evd.evars_of !isevars) Evd.empty fullctyp in let evm = evars_of_term (Evd.evars_of !isevars) evm fullcoqc in let evm = non_instanciated_map env isevars evm 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 !isevars evm 0 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 _ -> ()); *) - Subtac_obligations.add_definition recname evars_def fullctyp evars + let evars, evars_def, evars_typ = Eterm.eterm_obligations env recname !isevars evm 0 fullcoqc fullctyp in + Subtac_obligations.add_definition recname evars_def evars_typ ~implicits:impls evars let nf_evar_context isevars ctx = List.map (fun (n, b, t) -> - (n, option_map (Evarutil.nf_isevar isevars) b, Evarutil.nf_isevar isevars t)) ctx + (n, Option.map (Evarutil.nf_isevar isevars) b, Evarutil.nf_isevar isevars t)) ctx -let build_mutrec l boxed = - 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 env protos (f, d))*) - l - in - let lrecnames = List.map (fun ((f,_,_,_,_),_) -> f) lnameargsardef - and nv = List.map (fun ((_,n,_,_,_),_) -> n) lnameargsardef +let interp_fix_context evdref env fix = + interp_context_evars evdref env fix.Command.fix_binders + +let interp_fix_ccl evdref (env,_) fix = + interp_type_evars evdref env fix.Command.fix_type + +let interp_fix_body evdref env_rec impls (_,ctx) fix ccl = + let env = push_rel_context ctx env_rec in + let body = interp_casted_constr_evars evdref env ~impls fix.Command.fix_body ccl in + it_mkLambda_or_LetIn body ctx + +let build_fix_type (_,ctx) ccl = it_mkProd_or_LetIn ccl ctx + +let prepare_recursive_declaration fixnames fixtypes fixdefs = + let defs = List.map (subst_vars (List.rev fixnames)) fixdefs in + let names = List.map (fun id -> Name id) fixnames in + (Array.of_list names, Array.of_list fixtypes, Array.of_list defs) + +let rel_index n ctx = + list_index0 (Name n) (List.rev_map pi1 (List.filter (fun x -> pi2 x = None) ctx)) + +let rec unfold f b = + match f b with + | Some (x, b') -> x :: unfold f b' + | None -> [] + +let compute_possible_guardness_evidences (n,_) (_, fixctx) fixtype = + match n with + | Some (loc, n) -> [rel_index n fixctx] + | None -> + (* If recursive argument was not given by user, we try all args. + An earlier approach was to look only for inductive arguments, + but doing it properly involves delta-reduction, and it finally + doesn't seem to worth the effort (except for huge mutual + fixpoints ?) *) + let len = List.length fixctx in + unfold (function x when x = len -> None + | n -> Some (n, succ n)) 0 + +let push_named_context = List.fold_right push_named + +let interp_recursive fixkind l boxed = + let env = Global.env() in + let fixl, ntnl = List.split l in + let fixnames = List.map (fun fix -> fix.Command.fix_name) fixl in + + (* Interp arities allowing for unresolved types *) + let evdref = ref (Evd.create_evar_defs Evd.empty) in + let fixctxs, fiximps = List.split (List.map (interp_fix_context evdref env) fixl) in + let fixccls = List.map2 (interp_fix_ccl evdref) fixctxs fixl in + let fixtypes = List.map2 build_fix_type fixctxs fixccls in + let rec_sign = + List.fold_left2 (fun env id t -> (id,None,t) :: env) + [] fixnames fixtypes in - (* Build the recursive context and notations for the recursive types *) - let (rec_sign,rec_env,rec_impls,arityl) = - List.fold_left - (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 env arityc in - let impl = - if Impargs.is_implicit_args() - then Impargs.compute_implicits env arity - else [] in - let impls' =(recname,([],impl,compute_arguments_scope arity))::impls 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) - lnameargsardef [] in - - let recdef = - - (* Declare local notations *) - let fs = States.freeze() in + let env_rec = push_named_context rec_sign env in + + (* Get interpretation metadatas *) + let impls = Command.compute_interning_datas env [] fixnames fixtypes fiximps in + let notations = List.fold_right Option.List.cons ntnl [] in + + (* Interp bodies with rollback because temp use of notations/implicit *) + let fixdefs = + States.with_heavy_rollback (fun () -> + List.iter (Command.declare_interning_data impls) notations; + list_map3 (interp_fix_body evdref env_rec impls) fixctxs fixl fixccls) + () in + + (* Instantiate evars and check all are resolved *) + let evd,_ = Evarconv.consider_remaining_unif_problems env_rec !evdref in + let fixdefs = List.map (nf_evar (evars_of evd)) fixdefs in + let fixtypes = List.map (nf_evar (evars_of evd)) fixtypes in + let rec_sign = nf_named_context_evar (evars_of evd) rec_sign in + + let recdefs = List.length rec_sign in +(* List.iter (check_evars env_rec Evd.empty evd) fixdefs; *) +(* List.iter (check_evars env Evd.empty evd) fixtypes; *) +(* check_mutuality env kind (List.combine fixnames fixdefs); *) + + (* Russell-specific code *) + + (* Get the interesting evars, those that were not instanciated *) + let isevars = Evd.undefined_evars evd in + trace (str "got undefined evars" ++ Evd.pr_evar_defs isevars); + let evm = Evd.evars_of isevars in + trace (str "got the evm, recdefs is " ++ int recdefs); + (* Solve remaining evars *) + let rec collect_evars id def typ imps = + let _ = try trace (str "In collect evars, isevars is: " ++ Evd.pr_evar_defs isevars) with _ -> () in + (* Generalize by the recursive prototypes *) let def = - try - List.iter (fun (df,c,scope) -> (* No scope for tmp notation *) - Metasyntax.add_notation_interpretation df rec_impls c None) notations; - List.map2 - (fun ((_,_,bl,_,def),_) (isevars, info, arity) -> - match info with - None -> - let def = abstract_constr_expr def bl in - 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_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 - with e -> - States.unfreeze fs; raise e in - States.unfreeze fs; def - in - let (lnonrec,(namerec,defrec,arrec,nvrec)) = - collect_non_rec env lrecnames recdef arityl nv in - let recdefs = Array.length defrec in - (* 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 def = evar_nf isevars def in - let x, y, typ = arrec.(i) in - let typ = evar_nf isevars typ in - arrec.(i) <- (x, y, typ); - let rec_sign = nf_evar_context !isevars rec_sign 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 evm = Evd.evars_of isevars in - let id = namerec.(i) in - (* Generalize by the recursive prototypes *) - let def = - Termops.it_mkNamedLambda_or_LetIn def rec_sign - and typ = - Termops.it_mkNamedProd_or_LetIn typ rec_sign - in - let evars, def = Eterm.eterm_obligations id nc_len isevars evm recdefs def (Some typ) in - collect_evars (succ i) ((id, def, typ, evars) :: acc) - else acc + Termops.it_mkNamedLambda_or_LetIn def rec_sign + and typ = + Termops.it_mkNamedProd_or_LetIn typ rec_sign + in + let evm' = Subtac_utils.evars_of_term evm Evd.empty def in + let evm' = Subtac_utils.evars_of_term evm evm' typ in + let evars, def, typ = Eterm.eterm_obligations env id isevars evm' recdefs def typ in + (id, def, typ, imps, evars) in - let defs = collect_evars 0 [] in - Subtac_obligations.add_mutual_definitions (List.rev defs) nvrec - + let defs = list_map4 collect_evars fixnames fixdefs fixtypes fiximps in + (match fixkind with + | Command.IsFixpoint wfl -> + let possible_indexes = + list_map3 compute_possible_guardness_evidences wfl fixctxs fixtypes in + let fixdecls = Array.of_list (List.map (fun x -> Name x) fixnames), + Array.of_list fixtypes, + Array.of_list (List.map (subst_vars (List.rev fixnames)) fixdefs) + in + let indexes = Pretyping.search_guard dummy_loc (Global.env ()) possible_indexes fixdecls in + list_iter_i (fun i _ -> Inductive.check_fix env ((indexes,i),fixdecls)) l + | Command.IsCoFixpoint -> ()); + Subtac_obligations.add_mutual_definitions defs notations fixkind + let out_n = function Some n -> n - | None -> 0 - -let build_recursive (lnameargsardef:(fixpoint_expr * decl_notation) list) boxed = - match lnameargsardef with - | ((id, (n, CWfRec r), bl, typ, body), no) :: [] -> - build_wellfounded (id, out_n n, bl, typ, body) r false no boxed - | ((id, (n, CMeasureRec r), bl, typ, body), no) :: [] -> - build_wellfounded (id, out_n n, bl, typ, body) r true no boxed - | l -> - let lnameargsardef = - List.map (fun ((id, (n, ro), bl, typ, body), no) -> - match ro with - CStructRec -> (id, out_n n, bl, typ, body), no - | CWfRec _ | CMeasureRec _ -> - errorlabstrm "Subtac_command.build_recursive" - (str "Well-founded fixpoints not allowed in mutually recursive blocks")) - lnameargsardef - in build_mutrec lnameargsardef boxed - - - + | None -> raise Not_found + +let build_recursive l b = + let g = List.map (fun ((_,wf,_,_,_),_) -> wf) l in + match g, l with + [(n, CWfRec r)], [(((_,id),_,bl,typ,def),ntn)] -> + ignore(build_wellfounded (id, out_n n, bl, typ, def) r false ntn false) + + | [(n, CMeasureRec r)], [(((_,id),_,bl,typ,def),ntn)] -> + ignore(build_wellfounded (id, out_n n, bl, typ, def) r true ntn false) + + | _, _ when List.for_all (fun (n, ro) -> ro = CStructRec) g -> + let fixl = List.map (fun (((_,id),_,bl,typ,def),ntn) -> + ({Command.fix_name = id; Command.fix_binders = bl; Command.fix_body = def; Command.fix_type = typ},ntn)) l + in interp_recursive (Command.IsFixpoint g) fixl b + | _, _ -> + errorlabstrm "Subtac_command.build_recursive" + (str "Well-founded fixpoints not allowed in mutually recursive blocks") + +let build_corecursive l b = + let fixl = List.map (fun (((_,id),bl,typ,def),ntn) -> + ({Command.fix_name = id; Command.fix_binders = bl; Command.fix_body = def; Command.fix_type = typ},ntn)) + l in + interp_recursive Command.IsCoFixpoint fixl b diff --git a/contrib/subtac/subtac_command.mli b/contrib/subtac/subtac_command.mli index 846e06cf..27520867 100644 --- a/contrib/subtac/subtac_command.mli +++ b/contrib/subtac/subtac_command.mli @@ -14,18 +14,18 @@ val interp_gen : evar_defs ref -> env -> ?impls:full_implicits_env -> - ?allow_soapp:bool -> + ?allow_patvar:bool -> ?ltacvars:ltac_sign -> constr_expr -> constr val interp_constr : evar_defs ref -> env -> constr_expr -> constr -val interp_type : +val interp_type_evars : evar_defs ref -> env -> ?impls:full_implicits_env -> constr_expr -> constr -val interp_casted_constr : +val interp_casted_constr_evars : evar_defs ref -> env -> ?impls:full_implicits_env -> @@ -38,5 +38,12 @@ val interp_constr_judgment : constr_expr -> unsafe_judgment val list_chop_hd : int -> 'a list -> 'a list * 'a * 'a list +val interp_binder : Evd.evar_defs ref -> + Environ.env -> Names.name -> Topconstr.constr_expr -> Term.constr + + val build_recursive : (fixpoint_expr * decl_notation) list -> bool -> unit + +val build_corecursive : + (cofixpoint_expr * decl_notation) list -> bool -> unit diff --git a/contrib/subtac/subtac_obligations.ml b/contrib/subtac/subtac_obligations.ml index d182f7cd..55cdc7c4 100644 --- a/contrib/subtac/subtac_obligations.ml +++ b/contrib/subtac/subtac_obligations.ml @@ -1,7 +1,7 @@ -(* -*- default-directory: "~/research/coq/trunk/" -*- *) open Printf open Pp open Subtac_utils +open Command open Term open Names @@ -12,8 +12,11 @@ open Entries open Decl_kinds open Util open Evd +open Declare -let pperror cmd = Util.errorlabstrm "Subtac" cmd +type definition_hook = global_reference -> unit + +let pperror cmd = Util.errorlabstrm "Program" cmd let error s = pperror (str s) exception NoObligations of identifier option @@ -22,11 +25,12 @@ let explain_no_obligations = function Some ident -> str "No obligations for program " ++ str (string_of_id ident) | None -> str "No obligations remaining" -type obligation_info = (Names.identifier * Term.types * bool * Intset.t) array +type obligation_info = (Names.identifier * Term.types * loc * bool * Intset.t) array type obligation = { obl_name : identifier; obl_type : types; + obl_location : loc; obl_body : constr option; obl_opaque : bool; obl_deps : Intset.t; @@ -34,27 +38,46 @@ type obligation = type obligations = (obligation array * int) +type notations = (string * Topconstr.constr_expr * Topconstr.scope_name option) list + type program_info = { prg_name: identifier; prg_body: constr; prg_type: constr; prg_obligations: obligations; prg_deps : identifier list; - prg_nvrec : int array; + prg_fixkind : Command.fixpoint_kind option ; + prg_implicits : (Topconstr.explicitation * (bool * bool)) list; + prg_notations : notations ; + prg_kind : definition_kind; + prg_hook : definition_hook; } let assumption_message id = - Options.if_verbose message ((string_of_id id) ^ " is assumed") + Flags.if_verbose message ((string_of_id id) ^ " is assumed") let default_tactic : Proof_type.tactic ref = ref Refiner.tclIDTAC let default_tactic_expr : Tacexpr.glob_tactic_expr ref = ref (Obj.magic ()) let set_default_tactic t = default_tactic_expr := t; default_tactic := Tacinterp.eval_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 } +(* true = All transparent, false = Opaque if possible *) +let proofs_transparency = ref true + +let set_proofs_transparency = (:=) proofs_transparency +let get_proofs_transparency () = !proofs_transparency + +open Goptions + +let _ = + declare_bool_option + { optsync = true; + optname = "transparency of Program obligations"; + optkey = (SecondaryTable ("Transparent","Obligations")); + optread = get_proofs_transparency; + optwrite = set_proofs_transparency; } + +let evar_of_obligation o = make_evar (Global.named_context_val ()) o.obl_type let subst_deps obls deps t = Intset.fold @@ -62,7 +85,7 @@ let subst_deps obls deps t = let xobl = obls.(x) in debug 3 (str "Trying to get body of obligation " ++ int x); let oblb = - try out_some xobl.obl_body + try Option.get xobl.obl_body with _ -> debug 3 (str "Couldn't get body of obligation " ++ int x); assert(false) @@ -96,7 +119,7 @@ let from_prg : program_info ProgMap.t ref = ref ProgMap.empty let freeze () = !from_prg, !default_tactic_expr let unfreeze (v, t) = from_prg := v; set_default_tactic t let init () = - from_prg := ProgMap.empty; set_default_tactic (Subtac_utils.utils_call "subtac_simpl" []) + from_prg := ProgMap.empty; set_default_tactic (Subtac_utils.tactics_call "obligations_tactic" []) let _ = Summary.declare_summary "program-tcc-table" @@ -110,7 +133,7 @@ let progmap_union = ProgMap.fold ProgMap.add let cache (_, (infos, tac)) = from_prg := infos; - default_tactic_expr := tac + set_default_tactic tac let (input,output) = declare_object @@ -129,69 +152,112 @@ let rec intset_to = function let subst_body prg = let obls, _ = prg.prg_obligations in - subst_deps obls (intset_to (pred (Array.length obls))) prg.prg_body - + let ints = intset_to (pred (Array.length obls)) in + subst_deps obls ints prg.prg_body, + subst_deps obls ints (Termops.refresh_universes prg.prg_type) + let declare_definition prg = - let body = subst_body prg in + let body, typ = subst_body prg in (try trace (str "Declaring: " ++ Ppconstr.pr_id prg.prg_name ++ spc () ++ my_print_constr (Global.env()) body ++ str " : " ++ my_print_constr (Global.env()) prg.prg_type); with _ -> ()); + let (local, boxed, kind) = prg.prg_kind in let ce = { const_entry_body = body; - const_entry_type = Some prg.prg_type; + const_entry_type = Some typ; const_entry_opaque = false; - const_entry_boxed = false} + const_entry_boxed = boxed} in - let _constant = Declare.declare_constant - prg.prg_name (DefinitionEntry ce,IsDefinition Definition) - in - Subtac_utils.definition_message prg.prg_name + (Command.get_declare_definition_hook ()) ce; + match local with + | Local when Lib.sections_are_opened () -> + let c = + SectionLocalDef(ce.const_entry_body,ce.const_entry_type,false) in + let _ = declare_variable prg.prg_name (Lib.cwd(),c,IsDefinition kind) in + print_message (Subtac_utils.definition_message prg.prg_name); + if Pfedit.refining () then + Flags.if_verbose msg_warning + (str"Local definition " ++ Nameops.pr_id prg.prg_name ++ + str" is not visible from current goals"); + VarRef prg.prg_name + | (Global|Local) -> + let c = + Declare.declare_constant + prg.prg_name (DefinitionEntry ce,IsDefinition (pi3 prg.prg_kind)) + in + let gr = ConstRef c in + if Impargs.is_implicit_args () || prg.prg_implicits <> [] then + Impargs.declare_manual_implicits false gr (Impargs.is_implicit_args ()) prg.prg_implicits; + print_message (Subtac_utils.definition_message prg.prg_name); + prg.prg_hook gr; + gr open Pp open Ppconstr +let rec lam_index n t acc = + match kind_of_term t with + | Lambda (na, _, b) -> + if na = Name n then acc + else lam_index n b (succ acc) + | _ -> raise Not_found + +let compute_possible_guardness_evidences (n,_) fixbody fixtype = + match n with + | Some (loc, n) -> [lam_index n fixbody 0] + | None -> + (* If recursive argument was not given by user, we try all args. + An earlier approach was to look only for inductive arguments, + but doing it properly involves delta-reduction, and it finally + doesn't seem to worth the effort (except for huge mutual + fixpoints ?) *) + let m = Term.nb_prod fixtype in + let ctx = fst (Sign.decompose_prod_n_assum m fixtype) in + list_map_i (fun i _ -> i) 0 ctx + 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 + let fixdefs, fixtypes, fiximps = + list_split3 (List.map (fun x -> - let subs = (subst_body x) in - snd (decompose_lam_n len subs)) l) + let subs, typ = (subst_body x) in + snd (decompose_lam_n len subs), snd (decompose_prod_n len typ), x.prg_implicits) 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 fixkind = Option.get (List.hd l).prg_fixkind in + let arrrec, recvec = Array.of_list fixtypes, Array.of_list fixdefs in + let fixdecls = (Array.of_list (List.map (fun x -> Name x.prg_name) l), arrrec, recvec) in + let boxed = true (* TODO *) in + let fixnames = (List.hd l).prg_deps in + let kind = if fixkind <> IsCoFixpoint then Fixpoint else CoFixpoint in + let indexes, fixdecls = + match fixkind with + | IsFixpoint wfl -> + let possible_indexes = + list_map3 compute_possible_guardness_evidences wfl fixdefs fixtypes in + let indexes = Pretyping.search_guard dummy_loc (Global.env ()) possible_indexes fixdecls in + Some indexes, list_map_i (fun i _ -> mkFix ((indexes,i),fixdecls)) 0 l + | IsCoFixpoint -> + None, list_map_i (fun i _ -> mkCoFix (i,fixdecls)) 0 l + in + (* Declare the recursive definitions *) + let kns = list_map4 (declare_fix boxed kind) fixnames fixdecls fixtypes fiximps in + (* Declare notations *) + List.iter (Command.declare_interning_data ([],[])) (List.hd l).prg_notations; + Flags.if_verbose ppnl (Command.recursive_message kind indexes fixnames); + (match List.hd kns with ConstRef kn -> kn | _ -> assert false) + let declare_obligation obl body = let ce = { const_entry_body = body; const_entry_type = Some obl.obl_type; - const_entry_opaque = obl.obl_opaque; + const_entry_opaque = if get_proofs_transparency () then false else obl.obl_opaque; const_entry_boxed = false} in let constant = Declare.declare_constant obl.obl_name (DefinitionEntry ce,IsProof Property) in - Subtac_utils.definition_message obl.obl_name; + print_message (Subtac_utils.definition_message obl.obl_name); { obl with obl_body = Some (mkConst constant) } let try_tactics obls = @@ -209,18 +275,19 @@ let try_tactics obls = let red = Reductionops.nf_betaiota -let init_prog_info n b t deps nvrec obls = +let init_prog_info n b t deps fixkind notations obls impls kind hook = let obls' = Array.mapi - (fun i (n, t, o, d) -> + (fun i (n, t, l, o, 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_opaque = o; + obl_location = l; obl_type = red t; obl_opaque = o; obl_deps = d }) obls in { prg_name = n ; prg_body = b; prg_type = red t; prg_obligations = (obls', Array.length obls'); - prg_deps = deps; prg_nvrec = nvrec; } + prg_deps = deps; prg_fixkind = fixkind ; prg_notations = notations ; + prg_implicits = impls; prg_kind = kind; prg_hook = hook; } let get_prog name = let prg_infos = !from_prg in @@ -244,44 +311,63 @@ let update_state s = (* msgnl (str "Updating obligations info"); *) Lib.add_anonymous_leaf (input s) -let obligations_message rem = +type progress = + | Remain of int + | Dependent + | Defined of global_reference + +let obligations_message rem = if rem > 0 then if rem = 1 then - Options.if_verbose msgnl (int rem ++ str " obligation remaining") + Flags.if_verbose msgnl (int rem ++ str " obligation remaining") else - Options.if_verbose msgnl (int rem ++ str " obligations remaining") + Flags.if_verbose msgnl (int rem ++ str " obligations remaining") else - Options.if_verbose msgnl (str "No more obligations remaining") - + Flags.if_verbose msgnl (str "No more obligations remaining") + let update_obls prg obls rem = let prg' = { prg with prg_obligations = (obls, rem) } in from_prg := map_replace prg.prg_name prg' !from_prg; obligations_message rem; - if rem > 0 then () - else ( - 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)); - update_state (!from_prg, !default_tactic_expr); - rem + let res = + if rem > 0 then Remain rem + else ( + match prg'.prg_deps with + [] -> + let kn = declare_definition prg' in + from_prg := ProgMap.remove prg.prg_name !from_prg; + Defined kn + | 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 + (let kn = declare_mutual_definition progs in + from_prg := List.fold_left + (fun acc x -> + ProgMap.remove x.prg_name acc) !from_prg progs; + Defined (ConstRef kn)) + else Dependent); + in + update_state (!from_prg, !default_tactic_expr); + res let is_defined obls x = obls.(x).obl_body <> None let deps_remaining obls deps = - Intset.fold - (fun x acc -> - if is_defined obls x then acc - else x :: acc) - deps [] - + Intset.fold + (fun x acc -> + if is_defined obls x then acc + else x :: acc) + deps [] + +let has_dependencies obls n = + let res = ref false in + Array.iteri + (fun i obl -> + if i <> n && Intset.mem n obl.obl_deps then + res := true) + obls; + !res + let kind_of_opacity o = if o then Subtac_utils.goal_proof_kind else Subtac_utils.goal_kind @@ -293,6 +379,7 @@ let obligations_of_evars evars = (fun (n, t) -> { obl_name = n; obl_type = t; + obl_location = dummy_loc; obl_body = None; obl_opaque = false; obl_deps = Intset.empty; @@ -315,11 +402,15 @@ let rec solve_obligation prg num = let obl = { obl with obl_body = Some (Libnames.constr_of_global gr) } in let obls = Array.copy obls in let _ = obls.(num) <- obl in - if update_obls prg obls (pred rem) <> 0 then - auto_solve_obligations (Some prg.prg_name)); + match update_obls prg obls (pred rem) with + | Remain n when n > 0 -> + if has_dependencies obls num then + ignore(auto_solve_obligations (Some prg.prg_name)) + | _ -> ()); trace (str "Started obligation " ++ int user_num ++ str " proof: " ++ Subtac_utils.my_print_constr (Global.env ()) obl.obl_type); - Pfedit.by !default_tactic + Pfedit.by !default_tactic; + Flags.if_verbose (fun () -> msg (Printer.pr_open_subgoals ())) () | l -> pperror (str "Obligation " ++ int user_num ++ str " depends on obligation(s) " ++ str (string_of_list ", " (fun x -> string_of_int (succ x)) l)) @@ -341,7 +432,7 @@ and solve_obligation_by_tac prg obls i tac = Some _ -> false | None -> (try - if deps_remaining obls obl.obl_deps = [] then + 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 if obl.obl_opaque then @@ -349,8 +440,12 @@ and solve_obligation_by_tac prg obls i tac = else obls.(i) <- { obl with obl_body = Some t }; true - else false - with _ -> false) + else false + with + | Stdpp.Exc_located(_, Refiner.FailError (_, s)) + | Refiner.FailError (_, s) -> + user_err_loc (obl.obl_location, "solve_obligation", s) + | e -> false) and solve_prg_obligations prg tac = let obls, rem = prg.prg_obligations in @@ -381,35 +476,66 @@ and try_solve_obligation n prg tac = and try_solve_obligations n tac = try ignore (solve_obligations n tac) with NoObligations _ -> () -and auto_solve_obligations n : unit = - Options.if_verbose msgnl (str "Solving obligations automatically..."); - try_solve_obligations n !default_tactic +and auto_solve_obligations n : progress = + Flags.if_verbose msgnl (str "Solving obligations automatically..."); + try solve_obligations n !default_tactic with NoObligations _ -> Dependent -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 +open Pp +let show_obligations ?(msg=true) n = + let prg = get_prog_err n in + let n = prg.prg_name in + let obls, rem = prg.prg_obligations in + if msg then msgnl (int rem ++ str " obligation(s) remaining: "); + Array.iteri (fun i x -> + match x.obl_body with + 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 + +let show_term n = + let prg = get_prog_err n in + let n = prg.prg_name in + msgnl (str (string_of_id n) ++ spc () ++ str":" ++ spc () ++ my_print_constr (Global.env ()) prg.prg_type ++ spc () ++ str ":=" ++ fnl () + ++ my_print_constr (Global.env ()) prg.prg_body) + +let add_definition n b t ?(implicits=[]) ?(kind=Global,false,Definition) ?(hook=fun x -> ()) obls = + Flags.if_verbose pp (str (string_of_id n) ++ str " has type-checked"); + let prg = init_prog_info n b t [] None [] obls implicits kind hook 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) + Flags.if_verbose ppnl (str "."); + let cst = declare_definition prg in + from_prg := ProgMap.remove prg.prg_name !from_prg; + Defined cst) else ( let len = Array.length obls in - let _ = Options.if_verbose ppnl (str ", generating " ++ int len ++ str " obligation(s)") in + let _ = Flags.if_verbose ppnl (str ", generating " ++ int len ++ str " obligation(s)") in from_prg := ProgMap.add n prg !from_prg; - auto_solve_obligations (Some n)) + let res = auto_solve_obligations (Some n) in + match res with + | Remain rem when rem < 5 -> Flags.if_verbose (fun () -> show_obligations ~msg:false (Some n)) (); res + | _ -> res) -let add_mutual_definitions l nvrec = - let deps = List.map (fun (n, b, t, obls) -> n) l in +let add_mutual_definitions l ?(kind=Global,false,Definition) notations fixkind = + let deps = List.map (fun (n, b, t, imps, 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) + (fun acc (n, b, t, imps, obls) -> + let prg = init_prog_info n b t deps (Some fixkind) notations obls imps kind (fun x -> ()) in + ProgMap.add n prg acc) !from_prg l in from_prg := upd; - List.iter (fun x -> auto_solve_obligations (Some x)) deps - + let _defined = + List.fold_left (fun finished x -> + if finished then finished + else + match auto_solve_obligations (Some x) with + Defined _ -> (* If one definition is turned into a constant, the whole block is defined. *) true + | _ -> false) + false deps + in () + let admit_obligations n = let prg = get_prog_err n in let obls, rem = prg.prg_obligations in @@ -417,7 +543,7 @@ let admit_obligations n = match x.obl_body with None -> let x = subst_deps_obl obls x in - let kn = Declare.declare_constant x.obl_name (ParameterEntry x.obl_type, IsAssumption Conjectural) in + let kn = Declare.declare_constant x.obl_name (ParameterEntry (x.obl_type,false), IsAssumption Conjectural) in assumption_message x.obl_name; obls.(i) <- { x with obl_body = Some (mkConst kn) } | Some _ -> ()) @@ -438,18 +564,5 @@ let next_obligation n = array_find (fun x -> x.obl_body = None && deps_remaining obls x.obl_deps = []) obls in solve_obligation prg i - -open Pp -let show_obligations n = - let prg = get_prog_err 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 (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 - + let default_tactic () = !default_tactic diff --git a/contrib/subtac/subtac_obligations.mli b/contrib/subtac/subtac_obligations.mli index f015b80b..6d13e3bd 100644 --- a/contrib/subtac/subtac_obligations.mli +++ b/contrib/subtac/subtac_obligations.mli @@ -1,22 +1,42 @@ +open Names open Util +open Libnames -type obligation_info = (Names.identifier * Term.types * bool * Intset.t) array - (* ident, type, opaque or transparent, dependencies *) +type obligation_info = (Names.identifier * Term.types * loc * bool * Intset.t) array + (* ident, type, location, opaque or transparent, dependencies *) +type progress = (* Resolution status of a program *) + | Remain of int (* n obligations remaining *) + | Dependent (* Dependent on other definitions *) + | Defined of global_reference (* Defined as id *) + val set_default_tactic : Tacexpr.glob_tactic_expr -> unit val default_tactic : unit -> Proof_type.tactic +val set_proofs_transparency : bool -> unit (* true = All transparent, false = Opaque if possible *) +val get_proofs_transparency : unit -> bool + +type definition_hook = global_reference -> unit + val add_definition : Names.identifier -> Term.constr -> Term.types -> - obligation_info -> unit + ?implicits:(Topconstr.explicitation * (bool * bool)) list -> + ?kind:Decl_kinds.definition_kind -> + ?hook:definition_hook -> obligation_info -> progress + +type notations = (string * Topconstr.constr_expr * Topconstr.scope_name option) list val add_mutual_definitions : - (Names.identifier * Term.constr * Term.types * obligation_info) list -> int array -> unit + (Names.identifier * Term.constr * Term.types * + (Topconstr.explicitation * (bool * bool)) list * obligation_info) list -> + ?kind:Decl_kinds.definition_kind -> + notations -> + Command.fixpoint_kind -> 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 -> int +val solve_obligations : Names.identifier option -> Proof_type.tactic -> progress (* Number of remaining obligations to be solved for this program *) val solve_all_obligations : Proof_type.tactic -> unit @@ -25,7 +45,9 @@ val try_solve_obligation : int -> Names.identifier option -> Proof_type.tactic - val try_solve_obligations : Names.identifier option -> Proof_type.tactic -> unit -val show_obligations : Names.identifier option -> unit +val show_obligations : ?msg:bool -> Names.identifier option -> unit + +val show_term : 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 cce9a358..0e987cf2 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 9976 2007-07-12 11:58:30Z msozeau $ *) +(* $Id: subtac_pretyping.ml 11047 2008-06-03 23:08:00Z msozeau $ *) open Global open Pp @@ -70,7 +70,12 @@ let merge_evms x y = let interp env isevars c tycon = let j = pretype tycon env isevars ([],[]) c in - let evm = evars_of !isevars in + let _ = isevars := Evarutil.nf_evar_defs !isevars in + let evd,_ = consider_remaining_unif_problems env !isevars in +(* let unevd = undefined_evars evd in *) + let unevd' = Typeclasses.resolve_typeclasses ~onlyargs:true ~fail:false env evd in + let evm = evars_of unevd' in + isevars := unevd'; nf_evar evm j.uj_val, nf_evar evm j.uj_type let find_with_index x l = @@ -98,7 +103,7 @@ let env_with_binders env isevars l = let coqdef, deftyp = interp env isevars rawdef empty_tycon in let reldecl = (name, Some coqdef, deftyp) in aux (push_rel reldecl env, reldecl :: rels) tl - | Topconstr.LocalRawAssum (bl, typ) :: tl -> + | Topconstr.LocalRawAssum (bl, k, typ) :: tl -> let rawtyp = coqintern_type !isevars env typ in let coqtyp, typtyp = interp env isevars rawtyp empty_tycon in let acc = @@ -111,46 +116,28 @@ let env_with_binders env isevars l = | [] -> acc in aux (env, []) l -let subtac_process env isevars id l c tycon = - let c = Command.abstract_constr_expr c l in -(* let env_binders, binders_rel = env_with_binders env isevars l in *) +let subtac_process env isevars id bl c tycon = +(* let bl = Implicit_quantifiers.ctx_of_class_binders (vars_of_env env) cbl @ l in *) + let c = Command.abstract_constr_expr c bl in let tycon = match tycon with None -> empty_tycon | Some t -> - let t = Command.generalize_constr_expr t l in + let t = Command.generalize_constr_expr t bl in let t = coqintern_type !isevars env t in let coqt, ttyp = interp env isevars t empty_tycon in mk_tycon coqt in let c = coqintern_constr !isevars env c in + let imps = Implicit_quantifiers.implicits_of_rawterm c in let coqc, ctyp = interp env isevars c tycon in -(* let _ = try trace (str "Interpreted term: " ++ my_print_constr env coqc ++ spc () ++ *) -(* str "Coq type: " ++ my_print_constr env ctyp) *) -(* with _ -> () *) -(* in *) -(* let _ = try trace (str "Original evar map: " ++ Evd.pr_evar_map (evars_of !isevars)) with _ -> () in *) - -(* let fullcoqc = it_mkLambda_or_LetIn coqc binders_rel *) -(* and fullctyp = it_mkProd_or_LetIn ctyp binders_rel *) -(* in *) - let fullcoqc = Evarutil.nf_evar (evars_of !isevars) coqc in - let fullctyp = Evarutil.nf_evar (evars_of !isevars) ctyp in -(* let evm = evars_of_term (evars_of !isevars) Evd.empty fullctyp in *) -(* let evm = evars_of_term (evars_of !isevars) evm fullcoqc in *) -(* let _ = try trace (str "After evar normalization remain: " ++ spc () ++ *) -(* Evd.pr_evar_map evm) *) -(* with _ -> () *) -(* in *) let evm = non_instanciated_map env isevars (evars_of !isevars) in -(* let _ = try trace (str "Non instanciated evars map: " ++ Evd.pr_evar_map evm) with _ -> () in *) - evm, fullcoqc, fullctyp + evm, coqc, (match tycon with Some (None, c) -> c | _ -> ctyp), imps open Subtac_obligations -let subtac_proof env isevars id l c tycon = - let nc = named_context env in - 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 !isevars evm 0 coqc (Some coqt) in - add_definition id def coqt evars +let subtac_proof kind env isevars id bl c tycon = + let evm, coqc, coqt, imps = subtac_process env isevars id bl c tycon in + let evm = Subtac_utils.evars_of_term evm Evd.empty coqc in + let evars, def, ty = Eterm.eterm_obligations env id !isevars evm 0 coqc coqt in + add_definition id def ty ~implicits:imps ~kind:kind evars diff --git a/contrib/subtac/subtac_pretyping.mli b/contrib/subtac/subtac_pretyping.mli index b62a8766..1d8eb250 100644 --- a/contrib/subtac/subtac_pretyping.mli +++ b/contrib/subtac/subtac_pretyping.mli @@ -5,11 +5,19 @@ open Sign open Evd open Global open Topconstr +open Implicit_quantifiers +open Impargs module Pretyping : Pretyping.S +val interp : + Environ.env -> + Evd.evar_defs ref -> + Rawterm.rawconstr -> + Evarutil.type_constraint -> Term.constr * Term.constr + val subtac_process : env -> evar_defs ref -> identifier -> local_binder list -> - constr_expr -> constr_expr option -> evar_map * constr * types + constr_expr -> constr_expr option -> evar_map * constr * types * manual_explicitation list -val subtac_proof : env -> evar_defs ref -> identifier -> local_binder list -> - constr_expr -> constr_expr option -> unit +val subtac_proof : Decl_kinds.definition_kind -> env -> evar_defs ref -> identifier -> local_binder list -> + constr_expr -> constr_expr option -> Subtac_obligations.progress diff --git a/contrib/subtac/subtac_pretyping_F.ml b/contrib/subtac/subtac_pretyping_F.ml index 53eec0b6..afa5817f 100644 --- a/contrib/subtac/subtac_pretyping_F.ml +++ b/contrib/subtac/subtac_pretyping_F.ml @@ -1,3 +1,4 @@ +(* -*- compile-command: "make -C ../.. bin/coqtop.byte" -*- *) (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) @@ -6,7 +7,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: subtac_pretyping_F.ml 9976 2007-07-12 11:58:30Z msozeau $ *) +(* $Id: subtac_pretyping_F.ml 11143 2008-06-18 15:52:42Z msozeau $ *) open Pp open Util @@ -67,8 +68,6 @@ module SubtacPretyping_F (Coercion : Coercion.S) = struct let mt_evd = Evd.empty - let vect_lift_type = Array.mapi (fun i t -> type_app (lift i) t) - (* Utilisé pour inférer le prédicat des Cases *) (* Semble exagérement fort *) (* Faudra préférer une unification entre les types de toutes les clauses *) @@ -113,7 +112,7 @@ module SubtacPretyping_F (Coercion : Coercion.S) = struct let id = strip_meta id in (* May happen in tactics defined by Grammar *) try let (n,typ) = lookup_rel_id id (rel_context env) in - { uj_val = mkRel n; uj_type = type_app (lift n) typ } + { uj_val = mkRel n; uj_type = lift n typ } with Not_found -> try List.assoc id lvar @@ -202,11 +201,11 @@ module SubtacPretyping_F (Coercion : Coercion.S) = struct | RRec (loc,fixkind,names,bl,lar,vdef) -> let rec type_bl env ctxt = function [] -> ctxt - | (na,None,ty)::bl -> + | (na,k,None,ty)::bl -> let ty' = pretype_type empty_valcon env isevars lvar ty in let dcl = (na,None,ty'.utj_val) in type_bl (push_rel dcl env) (add_rel_decl dcl ctxt) bl - | (na,Some bd,ty)::bl -> + | (na,k,Some bd,ty)::bl -> let ty' = pretype_type empty_valcon env isevars lvar ty in let bd' = pretype (mk_tycon ty'.utj_val) env isevars lvar ty in let dcl = (na,Some bd'.uj_val,ty'.utj_val) in @@ -223,43 +222,47 @@ module SubtacPretyping_F (Coercion : Coercion.S) = struct let names = Array.map (fun id -> Name id) names in (* Note: bodies are not used by push_rec_types, so [||] is safe *) let newenv = push_rec_types (names,ftys,[||]) env in + let fixi = match fixkind with RFix (vn, i) -> i | RCoFix i -> i in let vdefj = array_map2_i (fun i ctxt def -> - (* we lift nbfix times the type in tycon, because of - * the nbfix variables pushed to newenv *) - let (ctxt,ty) = - decompose_prod_n_assum (rel_context_length ctxt) - (lift nbfix ftys.(i)) in - let nenv = push_rel_context ctxt newenv in - let j = pretype (mk_tycon ty) nenv isevars lvar def in - { uj_val = it_mkLambda_or_LetIn j.uj_val ctxt; - uj_type = it_mkProd_or_LetIn j.uj_type ctxt }) + let fty = + let ty = ftys.(i) in + if i = fixi then ( + Option.iter (fun tycon -> + isevars := Coercion.inh_conv_coerces_to loc env !isevars ftys.(i) tycon) + tycon; + nf_isevar !isevars ty) + else ty + in + (* we lift nbfix times the type in tycon, because of + * the nbfix variables pushed to newenv *) + let (ctxt,ty) = + decompose_prod_n_assum (rel_context_length ctxt) + (lift nbfix fty) in + let nenv = push_rel_context ctxt newenv in + let j = pretype (mk_tycon ty) nenv isevars lvar def in + { uj_val = it_mkLambda_or_LetIn j.uj_val ctxt; + uj_type = it_mkProd_or_LetIn j.uj_type ctxt }) ctxtv vdef in evar_type_fixpoint loc env isevars names ftys vdefj; let fixj = match fixkind with | RFix (vn,i) -> - let guard_indexes = Array.mapi + (* First, let's find the guard indexes. *) + (* If recursive argument was not given by user, we try all args. + An earlier approach was to look only for inductive arguments, + but doing it properly involves delta-reduction, and it finally + doesn't seem worth the effort (except for huge mutual + fixpoints ?) *) + let possible_indexes = Array.to_list (Array.mapi (fun i (n,_) -> match n with - | Some n -> n - | None -> - (* Recursive argument was not given by the user : We - check that there is only one inductive argument *) - let ctx = ctxtv.(i) in - let isIndApp t = - isInd (fst (decompose_app (strip_head_cast t))) in - (* This could be more precise (e.g. do some delta) *) - let lb = List.rev_map (fun (_,_,t) -> isIndApp t) ctx in - try (list_unique_index true lb) - 1 - with Not_found -> - Util.user_err_loc - (loc,"pretype", - Pp.str "cannot guess decreasing argument of fix")) - vn - in - let fix = ((guard_indexes, i),(names,ftys,Array.map j_val vdefj)) in - (try check_fix env fix with e -> Stdpp.raise_with_loc loc e); - make_judge (mkFix fix) ftys.(i) + | Some n -> [n] + | None -> list_map_i (fun i _ -> i) 0 ctxtv.(i)) + vn) + in + let fixdecls = (names,ftys,Array.map j_val vdefj) in + let indexes = search_guard loc env possible_indexes fixdecls in + make_judge (mkFix ((indexes,i),fixdecls)) ftys.(i) | RCoFix i -> let cofix = (i,(names,ftys,Array.map j_val vdefj)) in (try check_cofix env cofix with e -> Stdpp.raise_with_loc loc e); @@ -292,7 +295,7 @@ module SubtacPretyping_F (Coercion : Coercion.S) = struct let value, typ = applist (j_val resj, [j_val hj]), subst1 hj.uj_val c2 in let typ' = nf_isevar !isevars typ in let tycon = - option_map + Option.map (fun (abs, ty) -> match abs with None -> @@ -308,7 +311,7 @@ module SubtacPretyping_F (Coercion : Coercion.S) = struct apply_rec env (n+1) { uj_val = nf_isevar !isevars value; uj_type = nf_isevar !isevars typ' } - (option_map (fun (abs, c) -> abs, nf_isevar !isevars c) tycon) rest + (Option.map (fun (abs, c) -> abs, nf_isevar !isevars c) tycon) rest | _ -> let hj = pretype empty_tycon env isevars lvar c in @@ -316,7 +319,7 @@ module SubtacPretyping_F (Coercion : Coercion.S) = struct (join_loc floc argloc) env (evars_of !isevars) resj [hj] in - let ftycon = option_map (lift_abstr_tycon_type (-1)) ftycon in + let ftycon = Option.map (lift_abstr_tycon_type (-1)) ftycon in let resj = j_nf_evar (evars_of !isevars) (apply_rec env 1 fj ftycon args) in let resj = match kind_of_term resj.uj_val with @@ -328,7 +331,7 @@ module SubtacPretyping_F (Coercion : Coercion.S) = struct | _ -> resj in inh_conv_coerce_to_tycon loc env isevars resj tycon - | RLambda(loc,name,c1,c2) -> + | RLambda(loc,name,k,c1,c2) -> let (name',dom,rng) = evd_comb1 (split_tycon loc env) isevars tycon in let dom_valcon = valcon_of_tycon dom in let j = pretype_type dom_valcon env isevars lvar c1 in @@ -336,7 +339,7 @@ module SubtacPretyping_F (Coercion : Coercion.S) = struct let j' = pretype rng (push_rel var env) isevars lvar c2 in judge_of_abstraction env name j j' - | RProd(loc,name,c1,c2) -> + | RProd(loc,name,k,c1,c2) -> let j = pretype_type empty_valcon env isevars lvar c1 in let var = (name,j.utj_val) in let env' = push_rel_assum var env in @@ -397,7 +400,7 @@ module SubtacPretyping_F (Coercion : Coercion.S) = struct let f = it_mkLambda_or_LetIn fj.uj_val fsign in let v = let mis,_ = dest_ind_family indf in - let ci = make_default_case_info env LetStyle mis in + let ci = make_case_info env mis LetStyle in mkCase (ci, p, cj.uj_val,[|f|]) in { uj_val = v; uj_type = substl (realargs@[cj.uj_val]) ccl } @@ -415,7 +418,7 @@ module SubtacPretyping_F (Coercion : Coercion.S) = struct let p = it_mkLambda_or_LetIn (lift (nar+1) ccl) psign in let v = let mis,_ = dest_ind_family indf in - let ci = make_default_case_info env LetStyle mis in + let ci = make_case_info env mis LetStyle in mkCase (ci, p, cj.uj_val,[|f|] ) in { uj_val = v; uj_type = ccl }) @@ -485,14 +488,14 @@ module SubtacPretyping_F (Coercion : Coercion.S) = struct let b2 = f cstrs.(1) b2 in let v = let mis,_ = dest_ind_family indf in - let ci = make_default_case_info env IfStyle mis in + let ci = make_case_info env mis IfStyle in mkCase (ci, pred, cj.uj_val, [|b1;b2|]) in { uj_val = v; uj_type = p } - | RCases (loc,po,tml,eqns) -> - Cases.compile_cases loc - ((fun vtyc env -> pretype vtyc env isevars lvar),isevars) + | RCases (loc,sty,po,tml,eqns) -> + Cases.compile_cases loc sty + ((fun vtyc env isevars -> pretype vtyc env isevars lvar),isevars) tycon env (* loc *) (po,tml,eqns) | RCast(loc,c,k) -> @@ -552,15 +555,22 @@ module SubtacPretyping_F (Coercion : Coercion.S) = struct error_unexpected_type_loc (loc_of_rawconstr c) env (evars_of !isevars) tj.utj_val v - let pretype_gen isevars env lvar kind c = + let pretype_gen_aux isevars env lvar kind c = let c' = match kind with | OfType exptyp -> let tycon = match exptyp with None -> empty_tycon | Some t -> mk_tycon t in (pretype tycon env isevars lvar c).uj_val | IsType -> (pretype_type empty_valcon env isevars lvar c).utj_val in + let evd,_ = consider_remaining_unif_problems env !isevars in + isevars:=evd; nf_evar (evars_of !isevars) c' + let pretype_gen isevars env lvar kind c = + let c = pretype_gen_aux isevars env lvar kind c in + isevars := Typeclasses.resolve_typeclasses ~onlyargs:true ~fail:false env !isevars; + nf_evar (evars_of !isevars) c + (* TODO: comment faire remonter l'information si le typage a resolu des variables du sigma original. il faudrait que la fonction de typage retourne aussi le nouveau sigma... @@ -587,11 +597,10 @@ module SubtacPretyping_F (Coercion : Coercion.S) = struct let ise_pretype_gen fail_evar sigma env lvar kind c = let isevars = ref (Evd.create_evar_defs sigma) in let c = pretype_gen isevars env lvar kind c in - let isevars,_ = consider_remaining_unif_problems env !isevars in - let c = nf_evar (evars_of isevars) c in - if fail_evar then check_evars env sigma isevars c; - isevars, c - + let evd = !isevars in + if fail_evar then check_evars env Evd.empty evd c; + evd, c + (** Entry points of the high-level type synthesis algorithm *) let understand_gen kind sigma env c = @@ -601,16 +610,23 @@ module SubtacPretyping_F (Coercion : Coercion.S) = struct snd (ise_pretype_gen true sigma env ([],[]) (OfType exptyp) c) let understand_type sigma env c = - snd (ise_pretype_gen true sigma env ([],[]) IsType c) + snd (ise_pretype_gen false sigma env ([],[]) IsType c) let understand_ltac sigma env lvar kind c = ise_pretype_gen false sigma env lvar kind c - let understand_tcc_evars isevars env kind c = - pretype_gen isevars env ([],[]) kind c - - let understand_tcc sigma env ?expected_type:exptyp c = - let ev, t = ise_pretype_gen false sigma env ([],[]) (OfType exptyp) c in + let understand_tcc_evars evdref env kind c = + pretype_gen evdref env ([],[]) kind c + + let understand_tcc ?(resolve_classes=true) sigma env ?expected_type:exptyp c = + let ev, t = + if resolve_classes then + ise_pretype_gen false sigma env ([],[]) (OfType exptyp) c + else + let isevars = ref (Evd.create_evar_defs sigma) in + let c = pretype_gen_aux isevars env ([],[]) (OfType exptyp) c in + !isevars, c + in Evd.evars_of ev, t end diff --git a/contrib/subtac/subtac_utils.ml b/contrib/subtac/subtac_utils.ml index 28fe6352..bae2731a 100644 --- a/contrib/subtac/subtac_utils.ml +++ b/contrib/subtac/subtac_utils.ml @@ -10,10 +10,10 @@ let ($) f x = f x (****************************************************************************) (* Library linking *) -let contrib_name = "subtac" +let contrib_name = "Program" let subtac_dir = [contrib_name] -let fix_sub_module = "FixSub" +let fix_sub_module = "Wf" let utils_module = "Utils" let fixsub_module = subtac_dir @ [fix_sub_module] let utils_module = subtac_dir @ [utils_module] @@ -28,8 +28,8 @@ let make_ref l s = lazy (init_reference l s) let well_founded_ref = make_ref ["Init";"Wf"] "Well_founded" let acc_ref = make_ref ["Init";"Wf"] "Acc" let acc_inv_ref = make_ref ["Init";"Wf"] "Acc_inv" -let fix_sub_ref = make_ref ["subtac";"FixSub"] "Fix_sub" -let fix_measure_sub_ref = make_ref ["subtac";"FixSub"] "Fix_measure_sub" +let fix_sub_ref = make_ref fixsub_module "Fix_sub" +let fix_measure_sub_ref = make_ref fixsub_module "Fix_measure_sub" let lt_ref = make_ref ["Init";"Peano"] "lt" let lt_wf_ref = make_ref ["Wf_nat"] "lt_wf" let refl_ref = make_ref ["Init";"Logic"] "refl_equal" @@ -64,9 +64,15 @@ 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_refl = lazy (init_constant ["Logic";"JMeq"] "JMeq_refl") +let jmeq_ind = + lazy (check_required_library ["Coq";"Logic";"JMeq"]; + init_constant ["Logic";"JMeq"] "JMeq") +let jmeq_rec = + lazy (check_required_library ["Coq";"Logic";"JMeq"]; + init_constant ["Logic";"JMeq"] "JMeq_rec") +let jmeq_refl = + lazy (check_required_library ["Coq";"Logic";"JMeq"]; + init_constant ["Logic";"JMeq"] "JMeq_refl") let ex_ind = lazy (init_constant ["Init"; "Logic"] "ex") let ex_intro = lazy (init_reference ["Init"; "Logic"] "ex_intro") @@ -113,20 +119,20 @@ let debug_on = true let debug n s = if debug_on then - if !Options.debug && n >= debug_level then + if !Flags.debug && n >= debug_level then msgnl s else () else () let debug_msg n s = if debug_on then - if !Options.debug && n >= debug_level then s + if !Flags.debug && n >= debug_level then s else mt () else mt () let trace s = if debug_on then - if !Options.debug && debug_level > 0 then msgnl s + if !Flags.debug && debug_level > 0 then msgnl s else () else () @@ -163,7 +169,7 @@ let make_existential loc ?(opaque = true) env isevars c = let make_existential_expr loc env c = let key = Evarutil.new_untyped_evar () in - let evar = Topconstr.CEvar (loc, key) in + let evar = Topconstr.CEvar (loc, key, None) in debug 2 (str "Constructed evar " ++ int key); evar @@ -174,6 +180,8 @@ let string_of_hole_kind = function | CasesType -> "CasesType" | InternalHole -> "InternalHole" | TomatchTypeParameter _ -> "TomatchTypeParameter" + | GoalEvar -> "GoalEvar" + | ImpossibleCase -> "ImpossibleCase" let evars_of_term evc init c = let rec evrec acc c = @@ -194,7 +202,7 @@ let non_instanciated_map env evd evm = QuestionMark _ -> Evd.add evm key evi | _ -> debug 2 (str " and is an implicit"); - Pretype_errors.error_unsolvable_implicit loc env evm k) + Pretype_errors.error_unsolvable_implicit loc env evm (Evarutil.nf_evar_info evm evi) k None) Evd.empty (Evarutil.non_instantiated evm) let global_kind = Decl_kinds.IsDefinition Decl_kinds.Definition @@ -231,8 +239,8 @@ let build_dependent_sum l = (tclTHENS tac ([intros; (tclTHENSEQ - [constructor_tac (Some 1) 1 - (Rawterm.ImplicitBindings [mkVar n]); + [constructor_tac false (Some 1) 1 + (Rawterm.ImplicitBindings [inj_open (mkVar n)]); cont]); ]))) in @@ -342,29 +350,44 @@ let id_of_name = function | Anonymous -> raise (Invalid_argument "id_of_name") let definition_message id = - Options.if_verbose message ((string_of_id id) ^ " is defined") - + Nameops.pr_id id ++ str " is defined" + let recursive_message v = match Array.length v with | 0 -> error "no recursive definition" - | 1 -> (Printer.pr_global v.(0) ++ str " is recursively defined") - | _ -> hov 0 (prvect_with_sep pr_coma Printer.pr_global v ++ + | 1 -> (Printer.pr_constant (Global.env ()) v.(0) ++ str " is recursively defined") + | _ -> hov 0 (prvect_with_sep pr_coma (Printer.pr_constant (Global.env ())) v ++ spc () ++ str "are recursively defined") +let print_message m = + Flags.if_verbose ppnl m + (* Solve an obligation using tactics, return the corresponding proof term *) 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 + 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 + let _,(const,_,_) = Pfedit.cook_proof ignore in Pfedit.delete_current_proof (); const.Entries.const_entry_body - with e -> + with e -> Pfedit.delete_current_proof(); - raise Exit + raise e + +(* let apply_tac t goal = t goal *) + +(* let solve_by_tac evi t = *) +(* let ev = 1 in *) +(* let evm = Evd.add Evd.empty ev evi in *) +(* let goal = {it = evi; sigma = evm } in *) +(* let (res, valid) = apply_tac t goal in *) +(* if res.it = [] then *) +(* let prooftree = valid [] in *) +(* let proofterm, obls = Refiner.extract_open_proof res.sigma prooftree in *) +(* if obls = [] then proofterm *) +(* else raise Exit *) +(* else raise Exit *) let rec string_of_list sep f = function [] -> "" @@ -395,7 +418,7 @@ let pr_meta_map evd = | (mv,Clval(na,b,_)) -> hov 0 (pr_meta mv ++ pr_name na ++ str " := " ++ - print_constr b.rebus ++ fnl ()) + print_constr (fst b).rebus ++ fnl ()) in prlist pr_meta_binding ml @@ -440,11 +463,11 @@ let pr_evar_defs evd = str"METAS:"++brk(0,1)++pr_meta_map evd in v 0 (pp_evm ++ pp_met) -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 contrib_tactics_path = + make_dirpath (List.map id_of_string ["Tactics";contrib_name;"Coq"]) +let tactics_tac s = + lazy(make_kn (MPfile contrib_tactics_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 tactics_call tac args = + TacArg(TacCall(dummy_loc, ArgArg(dummy_loc, Lazy.force (tactics_tac tac)),args)) diff --git a/contrib/subtac/subtac_utils.mli b/contrib/subtac/subtac_utils.mli index 5a5dd427..49335211 100644 --- a/contrib/subtac/subtac_utils.mli +++ b/contrib/subtac/subtac_utils.mli @@ -89,11 +89,11 @@ val string_of_hole_kind : hole_kind -> string val evars_of_term : evar_map -> evar_map -> constr -> evar_map val non_instanciated_map : env -> evar_defs ref -> evar_map -> evar_map val global_kind : logical_kind -val goal_kind : locality_flag * goal_object_kind +val goal_kind : locality * goal_object_kind val global_proof_kind : logical_kind -val goal_proof_kind : locality_flag * goal_object_kind +val goal_proof_kind : locality * goal_object_kind val global_fix_kind : logical_kind -val goal_fix_kind : locality_flag * goal_object_kind +val goal_fix_kind : locality * goal_object_kind val mkSubset : name -> constr -> constr -> constr val mkProj1 : constr -> constr -> constr -> constr @@ -115,8 +115,10 @@ val destruct_ex : constr -> constr -> constr list val id_of_name : name -> identifier -val definition_message : identifier -> unit -val recursive_message : global_reference array -> std_ppcmds +val definition_message : identifier -> std_ppcmds +val recursive_message : constant array -> std_ppcmds + +val print_message : std_ppcmds -> unit val solve_by_tac : evar_info -> Tacmach.tactic -> constr @@ -125,6 +127,6 @@ val string_of_intset : Intset.t -> string val pr_evar_defs : evar_defs -> Pp.std_ppcmds -val utils_call : string -> Tacexpr.glob_tactic_arg list -> Tacexpr.glob_tactic_expr +val tactics_call : string -> Tacexpr.glob_tactic_arg list -> Tacexpr.glob_tactic_expr val pp_list : ('a -> Pp.std_ppcmds) -> 'a list -> Pp.std_ppcmds diff --git a/contrib/subtac/test/ListDep.v b/contrib/subtac/test/ListDep.v index 97cef9a5..da612c43 100644 --- a/contrib/subtac/test/ListDep.v +++ b/contrib/subtac/test/ListDep.v @@ -1,6 +1,6 @@ (* -*- coq-prog-args: ("-emacs-U" "-debug") -*- *) Require Import List. -Require Import Coq.subtac.Utils. +Require Import Coq.Program.Program. Set Implicit Arguments. @@ -23,13 +23,13 @@ Section Map_DependentRecursor. Variable f : { x : U | In x l } -> V. Obligations Tactic := unfold sub_list in * ; - subtac_simpl ; intuition. + program_simpl ; intuition. Program Fixpoint map_rec ( l' : list U | sub_list l' l ) { measure length l' } : { r : list V | length r = length l' } := match l' with - nil => nil - | cons x tl => let tl' := map_rec tl in + | nil => nil + | cons x tl => let tl' := map_rec tl in f x :: tl' end. diff --git a/contrib/subtac/test/Mutind.v b/contrib/subtac/test/Mutind.v index 0b40ef82..ac49ca96 100644 --- a/contrib/subtac/test/Mutind.v +++ b/contrib/subtac/test/Mutind.v @@ -1,13 +1,20 @@ -Program Fixpoint f (a : nat) : nat := +Require Import List. + +Program Fixpoint f a : { x : nat | x > 0 } := match a with - | 0 => 0 + | 0 => 1 | S a' => g a a' end -with g (a b : nat) { struct b } : nat := +with g a b : { x : nat | x > 0 } := match b with - | 0 => 0 + | 0 => 1 | S b' => f b' end. Check f. -Check g.
\ No newline at end of file +Check g. + + + + + diff --git a/contrib/subtac/test/euclid.v b/contrib/subtac/test/euclid.v index a5a8b85f..501aa798 100644 --- a/contrib/subtac/test/euclid.v +++ b/contrib/subtac/test/euclid.v @@ -1,20 +1,17 @@ -Require Import Coq.subtac.Utils. +Require Import Coq.Program.Program. Require Import Coq.Arith.Compare_dec. Notation "( x & y )" := (existS _ x y) : core_scope. +Require Import Omega. + 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). -Require Import Omega. - -Obligations. -Solve Obligations using subtac_simpl ; omega. - Next Obligation. - assert(x0 * S q' = x0 * q' + x0) by auto with arith ; omega. + assert(b * S q' = b * q' + b) by auto with arith ; omega. Defined. Program Definition test_euclid : (prod nat nat) := let (q, r) := euclid 4 2 in (q, q). diff --git a/contrib/subtac/test/measure.v b/contrib/subtac/test/measure.v index 4764037d..4f938f4f 100644 --- a/contrib/subtac/test/measure.v +++ b/contrib/subtac/test/measure.v @@ -2,7 +2,7 @@ Notation "( x & y )" := (@existS _ _ x y) : core_scope. Unset Printing All. Require Import Coq.Arith.Compare_dec. -Require Import Coq.subtac.Utils. +Require Import Coq.Program.Program. Fixpoint size (a : nat) : nat := match a with @@ -10,15 +10,11 @@ Fixpoint size (a : nat) : nat := | S n => S (size n) end. -Program Fixpoint test_measure (a : nat) {measure a size} : nat := +Program Fixpoint test_measure (a : nat) {measure size a} : nat := match a with | S (S n) => S (test_measure n) - | x => x + | 0 | S 0 => a end. -subst. -unfold n0. -auto with arith. -Qed. Check test_measure. Print test_measure.
\ No newline at end of file diff --git a/contrib/subtac/test/take.v b/contrib/subtac/test/take.v new file mode 100644 index 00000000..87ab47d6 --- /dev/null +++ b/contrib/subtac/test/take.v @@ -0,0 +1,38 @@ +(* -*- coq-prog-args: ("-emacs-U" "-debug") -*- *) +Require Import JMeq. +Require Import List. +Require Import Coq.subtac.Utils. + +Set Implicit Arguments. + +Program Fixpoint take (A : Set) (l : list A) (n : nat | n <= length l) { struct l } : { l' : list A | length l' = n } := + match n with + | 0 => nil + | S p => + match l with + | cons hd tl => let rest := take tl p in cons hd rest + | nil => ! + end + end. + +Require Import Omega. + +Next Obligation. + intros. + simpl in l0. + apply le_S_n ; exact l0. +Defined. + +Next Obligation. + intros. + destruct_call take ; subtac_simpl. +Defined. + +Next Obligation. + intros. + inversion l0. +Defined. + + + + diff --git a/contrib/xml/cic2acic.ml b/contrib/xml/cic2acic.ml index 8a5967a2..1a6cb9c8 100644 --- a/contrib/xml/cic2acic.ml +++ b/contrib/xml/cic2acic.ml @@ -55,18 +55,8 @@ let remove_module_dirpath_from_dirpath ~basedir dir = let get_uri_of_var v pvars = - let module D = Declare in + let module D = Decls in let module N = Names in - let rec search_in_pvars names = - function - [] -> None - | ((name,l)::tl) -> - let names' = name::names in - if List.mem v l then - Some names' - else - search_in_pvars names' tl - in let rec search_in_open_sections = function [] -> Util.error ("Variable "^v^" not found") @@ -78,9 +68,10 @@ let get_uri_of_var v pvars = search_in_open_sections tl in let path = - match search_in_pvars [] pvars with - None -> search_in_open_sections (N.repr_dirpath (Lib.cwd ())) - | Some path -> path + if List.mem v pvars then + [] + else + search_in_open_sections (N.repr_dirpath (Lib.cwd ())) in "cic:" ^ List.fold_left @@ -241,16 +232,15 @@ let typeur sigma metamap = | T.Var id -> (try let (_,_,ty) = Environ.lookup_named id env in - T.body_of_type ty + ty with Not_found -> Util.anomaly ("type_of: variable "^(Names.string_of_id id)^" unbound")) | T.Const c -> let cb = Environ.lookup_constant c env in Typeops.type_of_constant_type env (cb.Declarations.const_type) | T.Evar ev -> Evd.existential_type sigma ev - | T.Ind ind -> T.body_of_type (Inductiveops.type_of_inductive env ind) - | T.Construct cstr -> - T.body_of_type (Inductiveops.type_of_constructor env cstr) + | T.Ind ind -> Inductiveops.type_of_inductive env ind + | T.Construct cstr -> Inductiveops.type_of_constructor env cstr | T.Case (_,p,c,lf) -> let Inductiveops.IndType(_,realargs) = try Inductiveops.find_rectype env sigma (type_of env c) @@ -273,7 +263,7 @@ let typeur sigma metamap = match sort_of env cstr with Coq_sort T.InProp -> T.mkProp | Coq_sort T.InSet -> T.mkSet - | Coq_sort T.InType -> T.mkType Univ.prop_univ (* ERROR HERE *) + | Coq_sort T.InType -> T.mkType Univ.type1_univ (* ERROR HERE *) | CProp -> T.mkConst DoubleTypeInference.cprop and sort_of env t = diff --git a/contrib/xml/doubleTypeInference.ml b/contrib/xml/doubleTypeInference.ml index cce78891..de8c540c 100644 --- a/contrib/xml/doubleTypeInference.ml +++ b/contrib/xml/doubleTypeInference.ml @@ -51,7 +51,7 @@ let type_judgment env sigma j = ;; let type_judgment_cprop env sigma j = - match Term.kind_of_term(whd_betadeltaiotacprop env sigma (Term.body_of_type j.Environ.uj_type)) with + match Term.kind_of_term(whd_betadeltaiotacprop env sigma j.Environ.uj_type) with | Term.Sort s -> Some {Environ.utj_val = j.Environ.uj_val; Environ.utj_type = s } | _ -> None (* None means the CProp constant *) ;; diff --git a/contrib/xml/dumptree.ml4 b/contrib/xml/dumptree.ml4 new file mode 100644 index 00000000..407f86b3 --- /dev/null +++ b/contrib/xml/dumptree.ml4 @@ -0,0 +1,152 @@ +(************************************************************************) +(* 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 *) +(************************************************************************) + +(** This module provides the "Dump Tree" command that allows dumping the + current state of the proof stree in XML format *) + +(** Contributed by Cezary Kaliszyk, Radboud University Nijmegen *) + +(*i camlp4deps: "parsing/grammar.cma" i*) +open Tacexpr;; +open Decl_mode;; +open Printer;; +open Pp;; +open Environ;; +open Format;; +open Proof_type;; +open Evd;; +open Termops;; +open Ppconstr;; +open Names;; + +exception Different + +let xmlstream s = + (* In XML we want to print the whole stream so we can force the evaluation *) + Stream.of_list (List.map xmlescape (Stream.npeek max_int s)) +;; + +let thin_sign osign sign = + Sign.fold_named_context + (fun (id,c,ty as d) sign -> + try + if Sign.lookup_named id osign = (id,c,ty) then sign + else raise Different + with Not_found | Different -> Environ.push_named_context_val d sign) + sign ~init:Environ.empty_named_context_val +;; + +let pr_tactic_xml = function + | TacArg (Tacexp t) -> str "<tactic cmd=\"" ++ xmlstream (Pptactic.pr_glob_tactic (Global.env()) t) ++ str "\"/>" + | t -> str "<tactic cmd=\"" ++ xmlstream (Pptactic.pr_tactic (Global.env()) t) ++ str "\"/>" +;; + +let pr_proof_instr_xml instr = + Ppdecl_proof.pr_proof_instr (Global.env()) instr +;; + +let pr_rule_xml pr = function + | Prim r -> str "<rule text=\"" ++ xmlstream (pr_prim_rule r) ++ str "\"/>" + | Nested(cmpd, subtree) -> + hov 2 (str "<cmpdrule>" ++ fnl () ++ + begin match cmpd with + Tactic (texp, _) -> pr_tactic_xml texp + | Proof_instr (_,instr) -> pr_proof_instr_xml instr + end ++ fnl () + ++ pr subtree + ) ++ fnl () ++ str "</cmpdrule>" + | Daimon -> str "<daimon/>" + | Decl_proof _ -> str "<proof/>" +(* | Change_evars -> str "<chgevars/>"*) +;; + +let pr_var_decl_xml env (id,c,typ) = + let ptyp = print_constr_env env typ in + match c with + | None -> + (str "<hyp id=\"" ++ xmlstream (pr_id id) ++ str "\" type=\"" ++ xmlstream ptyp ++ str "\"/>") + | Some c -> + (* Force evaluation *) + let pb = print_constr_env env c in + (str "<hyp id=\"" ++ xmlstream (pr_id id) ++ str "\" type=\"" ++ xmlstream ptyp ++ str "\" body=\"" ++ + xmlstream pb ++ str "\"/>") +;; + +let pr_rel_decl_xml env (na,c,typ) = + let pbody = match c with + | None -> mt () + | Some c -> + (* Force evaluation *) + let pb = print_constr_env env c in + (str" body=\"" ++ xmlstream pb ++ str "\"") in + let ptyp = print_constr_env env typ in + let pid = + match na with + | Anonymous -> mt () + | Name id -> str " id=\"" ++ pr_id id ++ str "\"" + in + (str "<hyp" ++ pid ++ str " type=\"" ++ xmlstream ptyp ++ str "\"" ++ pbody ++ str "/>") +;; + +let pr_context_xml env = + let sign_env = + fold_named_context + (fun env d pp -> pp ++ pr_var_decl_xml env d) + env ~init:(mt ()) + in + let db_env = + fold_rel_context + (fun env d pp -> pp ++ pr_rel_decl_xml env d) + env ~init:(mt ()) + in + (sign_env ++ db_env) +;; + +let pr_subgoal_metas_xml metas env= + let pr_one (meta, typ) = + fnl () ++ str "<meta index=\"" ++ int meta ++ str " type=\"" ++ xmlstream (pr_ltype_env_at_top env typ) ++ + str "\"/>" + in + List.fold_left (++) (mt ()) (List.map pr_one metas) +;; + +let pr_goal_xml g = + let env = try evar_env g with _ -> empty_env in + if g.evar_extra = None then + (hov 2 (str "<goal>" ++ fnl () ++ str "<concl type=\"" ++ + xmlstream (pr_ltype_env_at_top env g.evar_concl) ++ + str "\"/>" ++ + (pr_context_xml env)) ++ + fnl () ++ str "</goal>") + else + (hov 2 (str "<goal type=\"declarative\">" ++ + (pr_context_xml env)) ++ + fnl () ++ str "</goal>") +;; + +let rec print_proof_xml sigma osign pf = + let hyps = Environ.named_context_of_val pf.goal.evar_hyps in + let hyps' = thin_sign osign hyps in + match pf.ref with + | None -> hov 2 (str "<tree>" ++ fnl () ++ (pr_goal_xml {pf.goal with evar_hyps=hyps'})) ++ fnl () ++ str "</tree>" + | Some(r,spfl) -> + hov 2 (str "<tree>" ++ fnl () ++ + (pr_goal_xml {pf.goal with evar_hyps=hyps'}) ++ fnl () ++ (pr_rule_xml (print_proof_xml sigma osign) r) ++ + (List.fold_left (fun x y -> x ++ fnl () ++ y) (mt ()) (List.map (print_proof_xml sigma hyps) spfl))) ++ fnl () ++ str "</tree>" +;; + +let print_proof_xml () = + let pp = print_proof_xml Evd.empty Sign.empty_named_context + (Tacmach.proof_of_pftreestate (Refiner.top_of_tree (Pfedit.get_pftreestate ()))) + in + msgnl pp +;; + +VERNAC COMMAND EXTEND DumpTree + [ "Dump" "Tree" ] -> [ print_proof_xml () ] +END diff --git a/contrib/xml/xmlcommand.ml b/contrib/xml/xmlcommand.ml index 01271323..3c4b01f5 100644 --- a/contrib/xml/xmlcommand.ml +++ b/contrib/xml/xmlcommand.ml @@ -73,11 +73,7 @@ let could_have_namesakes o sp = (* namesake = omonimo in italian *) let tag = Libobject.object_tag o in print_if_verbose ("Object tag: " ^ tag ^ "\n") ; match tag with - "CONSTANT" -> - (match D.constant_strength sp with - | DK.Local -> false (* a local definition *) - | DK.Global -> true (* a non-local one *) - ) + "CONSTANT" -> true (* constants/parameters are non global *) | "INDUCTIVE" -> true (* mutual inductive types are never local *) | "VARIABLE" -> false (* variables are local, so no namesakes *) | _ -> false (* uninteresting thing that won't be printed*) @@ -89,8 +85,7 @@ let could_have_namesakes o sp = (* namesake = omonimo in italian *) (* OF VARIABLES DECLARED IN THE i-th SUPER-SECTION OF THE CURRENT *) (* SECTION, WHOSE PATH IS namei *) -let pvars = - ref ([Names.id_of_string "",[]] : (Names.identifier * string list) list);; +let pvars = ref ([] : string list);; let cumenv = ref Environ.empty_env;; (* filter_params pvars hyps *) @@ -138,9 +133,7 @@ let add_to_pvars x = E.push_named (Names.id_of_string v, None, typ) !cumenv ; v in - match !pvars with - [] -> assert false - | ((name,l)::tl) -> pvars := (name,v::l)::tl + pvars := v::!pvars ;; (* The computation is very inefficient, but we can't do anything *) @@ -157,7 +150,7 @@ let search_variables () = | he::tl as modules -> let one_section_variables = let dirpath = N.make_dirpath (modules @ N.repr_dirpath modulepath) in - let t = List.map N.string_of_id (Declare.last_section_hyps dirpath) in + let t = List.map N.string_of_id (Decls.last_section_hyps dirpath) in [he,t] in one_section_variables @ aux tl @@ -329,14 +322,13 @@ let mk_variable_obj id body typ = let variables = search_variables () in let params = filter_params variables hyps'' in Acic.Variable - (Names.string_of_id id, unsharedbody, - (Unshare.unshare (Term.body_of_type typ)), params) + (Names.string_of_id id, unsharedbody, Unshare.unshare typ, params) ;; (* Unsharing is not performed on the body, that must be already unshared. *) (* The evar map and the type, instead, are unshared by this function. *) let mk_current_proof_obj is_a_variable id bo ty evar_map env = - let unshared_ty = Unshare.unshare (Term.body_of_type ty) in + let unshared_ty = Unshare.unshare ty in let metasenv = List.map (function @@ -384,7 +376,7 @@ let mk_current_proof_obj is_a_variable id bo ty evar_map env = let mk_constant_obj id bo ty variables hyps = let hyps = string_list_of_named_context_list hyps in - let ty = Unshare.unshare (Term.body_of_type ty) in + let ty = Unshare.unshare ty in let params = filter_params variables hyps in match bo with None -> @@ -413,7 +405,7 @@ let mk_inductive_obj sp mib packs variables nparams hyps finite = let cons = (Array.fold_right (fun (name,lc) i -> (name,lc)::i) (Array.mapi - (fun j x ->(x,Unshare.unshare (Term.body_of_type lc.(j)))) consnames) + (fun j x ->(x,Unshare.unshare lc.(j))) consnames) [] ) in @@ -447,7 +439,7 @@ let kind_of_inductive isrecord kn = let kind_of_variable id = let module DK = Decl_kinds in - match Declare.variable_kind id with + match Decls.variable_kind id with | DK.IsAssumption DK.Definitional -> "VARIABLE","Assumption" | DK.IsAssumption DK.Logical -> "VARIABLE","Hypothesis" | DK.IsAssumption DK.Conjectural -> "VARIABLE","Conjecture" @@ -458,7 +450,7 @@ let kind_of_variable id = let kind_of_constant kn = let module DK = Decl_kinds in - match Declare.constant_kind (Nametab.sp_of_global(Libnames.ConstRef kn)) with + match Decls.constant_kind kn with | DK.IsAssumption DK.Definitional -> "AXIOM","Declaration" | DK.IsAssumption DK.Logical -> "AXIOM","Axiom" | DK.IsAssumption DK.Conjectural -> @@ -492,6 +484,12 @@ let kind_of_constant kn = | DK.IsDefinition DK.IdentityCoercion -> Pp.warning "IdentityCoercion not supported in dtd (used Definition instead)"; "DEFINITION","Definition" + | DK.IsDefinition DK.Instance -> + Pp.warning "Instance not supported in dtd (used Definition instead)"; + "DEFINITION","Definition" + | DK.IsDefinition DK.Method -> + Pp.warning "Method not supported in dtd (used Definition instead)"; + "DEFINITION","Definition" | DK.IsProof (DK.Theorem|DK.Lemma|DK.Corollary|DK.Fact|DK.Remark as thm) -> "THEOREM",DK.string_of_theorem_kind thm | DK.IsProof _ -> @@ -541,11 +539,10 @@ let print internal glob_ref kind xml_library_root = let tag,obj = match glob_ref with Ln.VarRef id -> - let sp = Declare.find_section_variable id in (* this kn is fake since it is not provided by Coq *) let kn = let (mod_path,dir_path) = Lib.current_prefix () in - N.make_kn mod_path dir_path (N.label_of_id (Ln.basename sp)) + N.make_kn mod_path dir_path (N.label_of_id id) in let (_,body,typ) = G.lookup_named id in Cic2acic.Variable kn,mk_variable_obj id body typ @@ -692,11 +689,11 @@ let _ = Buffer.output_buffer ch theory_buffer ; close_out ch end ; - Util.option_iter + Option.iter (fun fn -> let coqdoc = Coq_config.bindir^"/coqdoc" in let options = " --html -s --body-only --no-index --latin1 --raw-comments" in - let dir = Util.out_some xml_library_root in + let dir = Option.get xml_library_root in let command cmd = if Sys.command cmd <> 0 then Util.anomaly ("Error executing \"" ^ cmd ^ "\"") |