diff options
| author | glondu | 2009-09-17 15:58:14 +0000 |
|---|---|---|
| committer | glondu | 2009-09-17 15:58:14 +0000 |
| commit | 61ccbc81a2f3b4662ed4a2bad9d07d2003dda3a2 (patch) | |
| tree | 961cc88c714aa91a0276ea9fbf8bc53b2b9d5c28 /plugins | |
| parent | 6d3fbdf36c6a47b49c2a4b16f498972c93c07574 (diff) | |
Delete trailing whitespaces in all *.{v,ml*} files
git-svn-id: svn+ssh://scm.gforge.inria.fr/svn/coq/trunk@12337 85f007b7-540e-0410-9357-904b9bb8a0f7
Diffstat (limited to 'plugins')
176 files changed, 9265 insertions, 9265 deletions
diff --git a/plugins/cc/ccalgo.ml b/plugins/cc/ccalgo.ml index 418980c54b..9cc6f9de93 100644 --- a/plugins/cc/ccalgo.ml +++ b/plugins/cc/ccalgo.ml @@ -22,45 +22,45 @@ open Proof_type let init_size=5 -let cc_verbose=ref false +let cc_verbose=ref false -let debug f x = +let debug f x = if !cc_verbose then f x let _= let gdopt= { optsync=true; optname="Congruence Verbose"; - optkey=["Congruence";"Verbose"]; - optread=(fun ()-> !cc_verbose); - optwrite=(fun b -> cc_verbose := b)} + optkey=["Congruence";"Verbose"]; + optread=(fun ()-> !cc_verbose); + optwrite=(fun b -> cc_verbose := b)} in declare_bool_option gdopt (* Signature table *) module ST=struct - + (* l: sign -> term r: term -> sign *) - + type t = {toterm:(int*int,int) Hashtbl.t; tosign:(int,int*int) Hashtbl.t} - + let empty ()= {toterm=Hashtbl.create init_size; tosign=Hashtbl.create init_size} - + let enter t sign st= - if Hashtbl.mem st.toterm sign then + if Hashtbl.mem st.toterm sign then anomaly "enter: signature already entered" - else + else Hashtbl.replace st.toterm sign t; Hashtbl.replace st.tosign t sign - + let query sign st=Hashtbl.find st.toterm sign let rev_query term st=Hashtbl.find st.tosign term - + let delete st t= try let sign=Hashtbl.find st.tosign t in Hashtbl.remove st.toterm sign; @@ -69,7 +69,7 @@ module ST=struct Not_found -> () let rec delete_set st s = Intset.iter (delete st) s - + end type pa_constructor= @@ -85,11 +85,11 @@ type pa_mark= Fmark of pa_fun | Cmark of pa_constructor -module PacMap=Map.Make(struct - type t=pa_constructor - let compare=Pervasives.compare end) +module PacMap=Map.Make(struct + type t=pa_constructor + let compare=Pervasives.compare end) -module PafMap=Map.Make(struct +module PafMap=Map.Make(struct type t=pa_fun let compare=Pervasives.compare end) @@ -107,11 +107,11 @@ type term= type ccpattern = PApp of term * ccpattern list (* arguments are reversed *) - | PVar of int + | PVar of int type rule= Congruence - | Axiom of constr * bool + | Axiom of constr * bool | Injection of int * pa_constructor * int * pa_constructor * int type from= @@ -127,7 +127,7 @@ type equality = rule eq type disequality = from eq type patt_kind = - Normal + Normal | Trivial of types | Creates_variables @@ -146,7 +146,7 @@ let swap eq : equality = | Injection (i,pi,j,pj,k) -> Injection (j,pj,i,pi,k) | Axiom (id,reversed) -> Axiom (id,not reversed) in {lhs=eq.rhs;rhs=eq.lhs;rule=swap_rule} - + type inductive_status = Unknown | Partial of pa_constructor @@ -163,15 +163,15 @@ type representative= mutable constructors: int PacMap.t} (*pac -> term = app(constr,t) *) type cl = Rep of representative| Eqto of int*equality - -type vertex = Leaf| Node of (int*int) -type node = +type vertex = Leaf| Node of (int*int) + +type node = {mutable clas:cl; - mutable cpath: int; + mutable cpath: int; vertex:vertex; term:term} - + type forest= {mutable max_size:int; mutable size:int; @@ -180,11 +180,11 @@ type forest= mutable epsilons: pa_constructor list; syms:(term,int) Hashtbl.t} -type state = +type state = {uf: forest; sigtable:ST.t; - mutable terms: Intset.t; - combine: equality Queue.t; + mutable terms: Intset.t; + combine: equality Queue.t; marks: (int * pa_mark) Queue.t; mutable diseq: disequality list; mutable quant: quant_eq list; @@ -222,17 +222,17 @@ let empty depth gls:state = changed=false; gls=gls} -let forest state = state.uf - +let forest state = state.uf + let compress_path uf i j = uf.map.(j).cpath<-i - -let rec find_aux uf visited i= - let j = uf.map.(i).cpath in + +let rec find_aux uf visited i= + let j = uf.map.(i).cpath in if j<0 then let _ = List.iter (compress_path uf i) visited in i else find_aux uf (i::visited) j - + let find uf i= find_aux uf [] i - + let get_representative uf i= match uf.map.(i).clas with Rep r -> r @@ -245,7 +245,7 @@ let get_constructor_info uf i= match uf.map.(i).term with Constructor cinfo->cinfo | _ -> anomaly "get_constructor: not a constructor" - + let size uf i= (get_representative uf i).weight @@ -264,36 +264,36 @@ let add_rfather uf i t= r.weight<-r.weight+1; r.fathers <-Intset.add t r.fathers -exception Discriminable of int * pa_constructor * int * pa_constructor +exception Discriminable of int * pa_constructor * int * pa_constructor let append_pac t p = - {p with arity=pred p.arity;args=t::p.args} + {p with arity=pred p.arity;args=t::p.args} let tail_pac p= {p with arity=succ p.arity;args=List.tl p.args} let fsucc paf = {paf with fnargs=succ paf.fnargs} - + let add_pac rep pac t = if not (PacMap.mem pac rep.constructors) then rep.constructors<-PacMap.add pac t rep.constructors let add_paf rep paf t = - let already = + let already = try PafMap.find paf rep.functions with Not_found -> Intset.empty in rep.functions<- PafMap.add paf (Intset.add t already) rep.functions let term uf i=uf.map.(i).term - + let subterms uf i= match uf.map.(i).vertex with Node(j,k) -> (j,k) | _ -> anomaly "subterms: not a node" - + let signature uf i= let j,k=subterms uf i in (find uf j,find uf k) - + let next uf= let size=uf.size in let nsize= succ size in @@ -304,11 +304,11 @@ let next uf= uf.max_size<-newmax; Array.blit uf.map 0 newmap 0 size; uf.map<-newmap - end + end else (); - uf.size<-nsize; + uf.size<-nsize; size - + let new_representative typ = {weight=0; lfathers=Intset.empty; @@ -317,14 +317,14 @@ let new_representative typ = 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 = +let cc_product s1 s2 = mkLambda(_A_,mkSort(Termops.new_sort_in_family s1), mkLambda(_B_,mkSort(Termops.new_sort_in_family s2),_body_)) @@ -332,27 +332,27 @@ let rec constr_of_term = function Symb s->s | Product(s1,s2) -> cc_product s1 s2 | Eps id -> mkVar id - | Constructor cinfo -> mkConstruct cinfo.ci_constr + | Constructor cinfo -> mkConstruct cinfo.ci_constr | Appli (s1,s2)-> make_app [(constr_of_term s2)] s1 and make_app l=function - Appli (s1,s2)->make_app ((constr_of_term s2)::l) s1 - | other -> applistc (constr_of_term other) l + Appli (s1,s2)->make_app ((constr_of_term s2)::l) s1 + | other -> applistc (constr_of_term other) l (* rebuild a term from a pattern and a substitution *) let build_subst uf subst = - Array.map (fun i -> - try term uf i + Array.map (fun i -> + try term uf i with _ -> anomaly "incomplete matching") subst let rec inst_pattern subst = function - PVar i -> - subst.(pred i) - | PApp (t, args) -> + PVar i -> + subst.(pred i) + | PApp (t, args) -> List.fold_right (fun spat f -> Appli (f,inst_pattern subst spat)) - args t + args t let pr_idx_term state i = str "[" ++ int i ++ str ":=" ++ Termops.print_constr (constr_of_term (term state.uf i)) ++ str "]" @@ -360,9 +360,9 @@ let pr_idx_term state i = str "[" ++ int i ++ str ":=" ++ let pr_term t = str "[" ++ Termops.print_constr (constr_of_term t) ++ str "]" -let rec add_term state t= +let rec add_term state t= let uf=state.uf in - try Hashtbl.find uf.syms t with + 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 @@ -377,12 +377,12 @@ let rec add_term state t= cpath= -1; vertex= Leaf; term= t} - | Eps id -> + | Eps id -> {clas= Rep (new_representative typ); cpath= -1; vertex= Leaf; term= t} - | Appli (t1,t2) -> + | Appli (t1,t2) -> let i1=add_term state t1 and i2=add_term state t2 in add_lfather uf (find uf i1) b; add_rfather uf (find uf i2) b; @@ -408,9 +408,9 @@ let rec add_term state 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 + Hashtbl.replace state.by_type typ + (Intset.add b + (try Hashtbl.find state.by_type typ with Not_found -> Intset.empty)); b @@ -436,22 +436,22 @@ let add_quant state id pol (nvars,valid1,patt1,valid2,patt2) = qe_rhs_valid=valid2}::state.quant let is_redundant state id args = - try + 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) + 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) = +let add_inst state (inst,int_subst) = 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 + else begin Hashtbl.add state.q_history inst.qe_hyp_id int_subst; let subst = build_subst (forest state) int_subst in @@ -459,149 +459,149 @@ let add_inst state (inst,int_subst) = 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 + 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 + debug (fun () -> + msgnl (str "Adding new equality, depth="++ int state.rew_depth); - msgnl (str " [" ++ Termops.print_constr prf ++ str " : " ++ + 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 + debug (fun () -> + msgnl (str "Adding new disequality, depth="++ int state.rew_depth); - msgnl (str " [" ++ Termops.print_constr prf ++ str " : " ++ + msgnl (str " [" ++ Termops.print_constr prf ++ str " : " ++ pr_term s ++ str " <> " ++ pr_term t ++ str "]")) (); - add_disequality state (Hyp prf) s t + add_disequality state (Hyp prf) s t end end let link uf i j eq = (* links i -> j *) - let node=uf.map.(i) in + let node=uf.map.(i) in node.clas<-Eqto (j,eq); node.cpath<-j - + let rec down_path uf i l= match uf.map.(i).clas with Eqto(j,t)->down_path uf j (((i,j),t)::l) | Rep _ ->l - + let rec min_path=function ([],l2)->([],l2) | (l1,[])->(l1,[]) - | (((c1,t1)::q1),((c2,t2)::q2)) when c1=c2 -> min_path (q1,q2) + | (((c1,t1)::q1),((c2,t2)::q2)) when c1=c2 -> min_path (q1,q2) | cpl -> cpl - + let join_path uf i j= assert (find uf i=find uf j); min_path (down_path uf i [],down_path uf j []) let union state i1 i2 eq= - debug (fun () -> msgnl (str "Linking " ++ pr_idx_term state i1 ++ + 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 + 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 + 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.weight<-Intset.cardinal f; r2.fathers<-f; r2.lfathers<-Intset.union r1.lfathers r2.lfathers; ST.delete_set state.sigtable r1.fathers; - state.terms<-Intset.union state.terms r1.fathers; - PacMap.iter - (fun pac b -> Queue.add (b,Cmark pac) state.marks) + state.terms<-Intset.union state.terms r1.fathers; + PacMap.iter + (fun pac b -> Queue.add (b,Cmark pac) state.marks) r1.constructors; - PafMap.iter - (fun paf -> Intset.iter - (fun b -> Queue.add (b,Fmark paf) state.marks)) + PafMap.iter + (fun paf -> Intset.iter + (fun b -> Queue.add (b,Fmark paf) state.marks)) r1.functions; - match r1.inductive_status,r2.inductive_status with + match r1.inductive_status,r2.inductive_status with Unknown,_ -> () - | Partial pac,Unknown -> + | Partial pac,Unknown -> r2.inductive_status<-Partial pac; state.pa_classes<-Intset.remove i1 state.pa_classes; state.pa_classes<-Intset.add i2 state.pa_classes - | Partial _ ,(Partial _ |Partial_applied) -> + | Partial _ ,(Partial _ |Partial_applied) -> state.pa_classes<-Intset.remove i1 state.pa_classes - | Partial_applied,Unknown -> - r2.inductive_status<-Partial_applied - | Partial_applied,Partial _ -> + | Partial_applied,Unknown -> + r2.inductive_status<-Partial_applied + | Partial_applied,Partial _ -> state.pa_classes<-Intset.remove i2 state.pa_classes; r2.inductive_status<-Partial_applied | Total cpl,Unknown -> r2.inductive_status<-Total cpl; - | Total (i,pac),Total _ -> Queue.add (i,Cmark pac) state.marks - | _,_ -> () - + | Total (i,pac),Total _ -> Queue.add (i,Cmark pac) state.marks + | _,_ -> () + let merge eq state = (* merge and no-merge *) - debug (fun () -> msgnl - (str "Merging " ++ pr_idx_term state eq.lhs ++ + 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 + let i=find uf eq.lhs and j=find uf eq.rhs in - if i<>j then + if i<>j then if (size uf i)<(size uf j) then union state i j eq else union state j i (swap eq) let update t state = (* update 1 and 2 *) - debug (fun () -> msgnl + 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 begin - match rep.inductive_status with + match rep.inductive_status with Partial _ -> rep.inductive_status <- Partial_applied; state.pa_classes <- Intset.remove i state.pa_classes | _ -> () end; - PacMap.iter - (fun pac _ -> Queue.add (t,Cmark (append_pac v pac)) state.marks) - rep.constructors; - PafMap.iter - (fun paf _ -> Queue.add (t,Fmark (fsucc paf)) state.marks) - rep.functions; - try - let s = ST.query sign state.sigtable in + PacMap.iter + (fun pac _ -> Queue.add (t,Cmark (append_pac v pac)) state.marks) + rep.constructors; + PafMap.iter + (fun paf _ -> Queue.add (t,Fmark (fsucc paf)) state.marks) + rep.functions; + try + let s = ST.query sign state.sigtable in Queue.add {lhs=t;rhs=s;rule=Congruence} state.combine - with + with Not_found -> ST.enter t sign state.sigtable let process_function_mark t rep paf state = add_paf rep paf t; state.terms<-Intset.union rep.lfathers state.terms - + let process_constructor_mark t i rep pac state = match rep.inductive_status with Total (s,opac) -> - if pac.cnode <> opac.cnode then (* Conflict *) - raise (Discriminable (s,opac,t,pac)) + if pac.cnode <> opac.cnode then (* Conflict *) + raise (Discriminable (s,opac,t,pac)) else (* Match *) let cinfo = get_constructor_info state.uf pac.cnode in let rec f n oargs args= - if n > 0 then + if n > 0 then match (oargs,args) with s1::q1,s2::q2-> - Queue.add + Queue.add {lhs=s1;rhs=s2;rule=Injection(s,opac,t,pac,n)} state.combine; - f (n-1) q1 q2 - | _-> anomaly - "add_pacs : weird error in injection subterms merge" + f (n-1) q1 q2 + | _-> anomaly + "add_pacs : weird error in injection subterms merge" in f cinfo.ci_nhyps opac.args pac.args | Partial_applied | Partial _ -> add_pac rep pac t; @@ -617,8 +617,8 @@ let process_constructor_mark t i rep pac state = state.pa_classes<- Intset.add i state.pa_classes end -let process_mark t m state = - debug (fun () -> msgnl +let process_mark t m state = + 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 @@ -634,15 +634,15 @@ type explanation = let check_disequalities state = let uf=state.uf in let rec check_aux = function - dis::q -> - 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 + dis::q -> + 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 begin debug msgnl (str "No");check_aux q end - | [] -> None + | [] -> None in check_aux state.diseq @@ -651,8 +651,8 @@ let one_step state = let eq = Queue.take state.combine in merge eq state; true - with Queue.Empty -> - try + with Queue.Empty -> + try let (t,m) = Queue.take state.marks in process_mark t m state; true @@ -664,40 +664,40 @@ let one_step state = true with Not_found -> false -let __eps__ = id_of_string "_eps_" +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 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 typ n = + let rec app t typ n = if n<=0 then t else 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)) + 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 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; + state.uf.epsilons <- pac :: state.uf.epsilons; ignore (add_term state ct) - | _ -> anomaly "wrong incomplete class" + | _ -> anomaly "wrong incomplete class" let complete state = Intset.iter (complete_one_class state) state.pa_classes -type matching_problem = +type matching_problem = {mp_subst : int array; mp_inst : quant_eq; mp_stack : (ccpattern*int) list } @@ -705,31 +705,31 @@ type matching_problem = let make_fun_table state = let uf= state.uf in let funtab=ref PafMap.empty in - Array.iteri + 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 + 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) + funtab:= PafMap.add paf (Intset.add i elem) !funtab) rep.functions | _ -> ()) state.uf.map; !funtab - + let rec do_match state res pb_stack = let mp=Stack.pop pb_stack in match mp.mp_stack with - [] -> + [] -> res:= (mp.mp_inst,mp.mp_subst) :: !res | (patt,cl)::remains -> let uf=state.uf in match patt with - PVar i -> - if mp.mp_subst.(pred i)<0 then + PVar i -> + if mp.mp_subst.(pred i)<0 then begin mp.mp_subst.(pred i)<- cl; (* no aliasing problem here *) Stack.push {mp with mp_stack=remains} pb_stack @@ -746,18 +746,18 @@ let rec do_match state res pb_stack = with Not_found -> () end | PApp(f, ((last_arg::rem_args) as args)) -> - try - let j=Hashtbl.find uf.syms f in + try + 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 aux i = let (s,t) = signature state.uf i in - Stack.push - {mp with + Stack.push + {mp with mp_subst=Array.copy mp.mp_subst; mp_stack= - (PApp(f,rem_args),s) :: + (PApp(f,rem_args),s) :: (last_arg,t) :: remains} pb_stack in Intset.iter aux good_terms with Not_found -> () @@ -768,7 +768,7 @@ let paf_of_patt syms = function {fsym=Hashtbl.find syms f; fnargs=List.length args} -let init_pb_stack state = +let init_pb_stack state = let syms= state.uf.syms in let pb_stack = Stack.create () in let funtab = make_fun_table state in @@ -778,51 +778,51 @@ let init_pb_stack state = match inst.qe_lhs_valid with Creates_variables -> Intset.empty | Normal -> - begin - try + 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 + | 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); + 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 + begin let good_classes = match inst.qe_rhs_valid with Creates_variables -> Intset.empty | Normal -> - begin - try + 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 + | 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); + 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 -let find_instances state = +let find_instances state = let pb_stack= init_pb_stack state in let res =ref [] in let _ = @@ -830,7 +830,7 @@ let find_instances state = try while true do check_for_interrupt (); - do_match state res pb_stack + do_match state res pb_stack done; anomaly "get out of here !" with Stack.Empty -> () in @@ -839,34 +839,34 @@ let find_instances state = let rec execute first_run state = debug msgnl (str "Executing ... "); try - while + while check_for_interrupt (); one_step state do () done; match check_disequalities state with - None -> + None -> if not(Intset.is_empty state.pa_classes) then - begin + begin debug msgnl (str "First run was incomplete, completing ... "); complete state; execute false state end - else + else if state.rew_depth>0 then let l=find_instances state in List.iter (add_inst state) l; - if state.changed then + if state.changed then begin state.changed <- false; execute true state end else - begin + begin debug msgnl (str "Out of instances ... "); None end - else - begin + else + begin debug msgnl (str "Out of depth ... "); None end diff --git a/plugins/cc/ccalgo.mli b/plugins/cc/ccalgo.mli index 3bd52b6e1d..5f56c7e69f 100644 --- a/plugins/cc/ccalgo.mli +++ b/plugins/cc/ccalgo.mli @@ -25,35 +25,35 @@ type term = | Constructor of cinfo (* constructor arity + nhyps *) type patt_kind = - Normal + Normal | Trivial of types | Creates_variables type ccpattern = PApp of term * ccpattern list - | PVar of int + | PVar of int type pa_constructor = { cnode : int; arity : int; args : int list} -module PacMap : Map.S with type key = pa_constructor +module PacMap : Map.S with type key = pa_constructor type forest -type state +type state type rule= Congruence - | Axiom of constr * bool + | Axiom of constr * bool | Injection of int * pa_constructor * int * pa_constructor * int type from= Goal | Hyp of constr | HeqG of constr - | HeqnH of constr*constr + | HeqnH of constr*constr type 'a eq = {lhs:int;rhs:int;rule:'a} @@ -84,7 +84,7 @@ val add_equality : state -> constr -> term -> term -> unit val add_disequality : state -> from -> term -> term -> unit -val add_quant : state -> identifier -> bool -> +val add_quant : state -> identifier -> bool -> int * patt_kind * ccpattern * patt_kind * ccpattern -> unit val tail_pac : pa_constructor -> pa_constructor @@ -99,7 +99,7 @@ val get_constructor_info : forest -> int -> cinfo val subterms : forest -> int -> int * int -val join_path : forest -> int -> int -> +val join_path : forest -> int -> int -> ((int * int) * equality) list * ((int * int) * equality) list type quant_eq= @@ -117,10 +117,10 @@ type pa_fun= fnargs:int} type matching_problem - + module PafMap: Map.S with type key = pa_fun -val make_fun_table : state -> Intset.t PafMap.t +val make_fun_table : state -> Intset.t PafMap.t val do_match : state -> (quant_eq * int array) list ref -> matching_problem Stack.t -> unit @@ -150,20 +150,20 @@ val execute : bool -> state -> explanation option module PacMap:Map.S with type key=pa_constructor -type term = - Symb of Term.constr +type term = + Symb of Term.constr | Eps - | Appli of term * term + | Appli of term * term | Constructor of Names.constructor*int*int -type rule = - Congruence +type rule = + Congruence | Axiom of Names.identifier | Injection of int*int*int*int type equality = - {lhs : int; - rhs : int; + {lhs : int; + rhs : int; rule : rule} module ST : @@ -175,47 +175,47 @@ sig val delete : int -> t -> unit val delete_list : int list -> t -> unit end - + module UF : sig - type t - exception Discriminable of int * int * int * int * t + type t + exception Discriminable of int * int * int * int * t val empty : unit -> t val find : t -> int -> int val size : t -> int -> int val get_constructor : t -> int -> Names.constructor val pac_arity : t -> int -> int * int -> int - val mem_node_pac : t -> int -> int * int -> int - val add_pacs : t -> int -> pa_constructor PacMap.t -> + val mem_node_pac : t -> int -> int * int -> int + val add_pacs : t -> int -> pa_constructor PacMap.t -> int list * equality list - val term : t -> int -> term + val term : t -> int -> term val subterms : t -> int -> int * int val add : t -> term -> int val union : t -> int -> int -> equality -> int list * equality list - val join_path : t -> int -> int -> + val join_path : t -> int -> int -> ((int*int)*equality) list* ((int*int)*equality) list end - + val combine_rec : UF.t -> int list -> equality list val process_rec : UF.t -> equality list -> int list val cc : UF.t -> unit - + val make_uf : (Names.identifier * (term * term)) list -> UF.t val add_one_diseq : UF.t -> (term * term) -> int * int -val add_disaxioms : - UF.t -> (Names.identifier * (term * term)) list -> +val add_disaxioms : + UF.t -> (Names.identifier * (term * term)) list -> (Names.identifier * (int * int)) list - + val check_equal : UF.t -> int * int -> bool -val find_contradiction : UF.t -> - (Names.identifier * (int * int)) list -> +val find_contradiction : UF.t -> + (Names.identifier * (int * int)) list -> (Names.identifier * (int * int)) *) diff --git a/plugins/cc/ccproof.ml b/plugins/cc/ccproof.ml index 1e57aa6cb1..2a019ebfff 100644 --- a/plugins/cc/ccproof.ml +++ b/plugins/cc/ccproof.ml @@ -8,30 +8,30 @@ (* $Id$ *) -(* This file uses the (non-compressed) union-find structure to generate *) +(* This file uses the (non-compressed) union-find structure to generate *) (* proof-trees that will be transformed into proof-terms in cctac.ml4 *) open Util open Names open Term open Ccalgo - + type rule= Ax of constr | SymAx of constr | Refl of term | Trans of proof*proof | Congr of proof*proof - | Inject of proof*constructor*int*int -and proof = + | Inject of proof*constructor*int*int +and proof = {p_lhs:term;p_rhs:term;p_rule:rule} let prefl t = {p_lhs=t;p_rhs=t;p_rule=Refl t} -let pcongr p1 p2 = - match p1.p_rule,p2.p_rule with +let pcongr p1 p2 = + match p1.p_rule,p2.p_rule with Refl t1, Refl t2 -> prefl (Appli (t1,t2)) - | _, _ -> + | _, _ -> {p_lhs=Appli (p1.p_lhs,p2.p_lhs); p_rhs=Appli (p1.p_rhs,p2.p_rhs); p_rule=Congr (p1,p2)} @@ -44,25 +44,25 @@ let rec ptrans p1 p3= | Congr(p1,p2), Congr(p3,p4) ->pcongr (ptrans p1 p3) (ptrans p2 p4) | Congr(p1,p2), Trans({p_rule=Congr(p3,p4)},p5) -> ptrans (pcongr (ptrans p1 p3) (ptrans p2 p4)) p5 - | _, _ -> - if p1.p_rhs = p3.p_lhs then + | _, _ -> + if p1.p_rhs = p3.p_lhs then {p_lhs=p1.p_lhs; p_rhs=p3.p_rhs; p_rule=Trans (p1,p3)} else anomaly "invalid cc transitivity" - -let rec psym p = - match p.p_rule with - Refl _ -> p + +let rec psym p = + match p.p_rule with + Refl _ -> p | SymAx s -> {p_lhs=p.p_rhs; p_rhs=p.p_lhs; p_rule=Ax s} - | Ax s-> + | Ax s-> {p_lhs=p.p_rhs; p_rhs=p.p_lhs; p_rule=SymAx s} - | Inject (p0,c,n,a)-> + | Inject (p0,c,n,a)-> {p_lhs=p.p_rhs; p_rhs=p.p_lhs; p_rule=Inject (psym p0,c,n,a)} @@ -82,9 +82,9 @@ let psymax axioms s = p_rule=SymAx s} let rec nth_arg t n= - match t with - Appli (t1,t2)-> - if n>0 then + match t with + Appli (t1,t2)-> + if n>0 then nth_arg t1 (n-1) else t2 | _ -> anomaly "nth_arg: not enough args" @@ -99,23 +99,23 @@ let build_proof uf= let axioms = axioms uf in let rec equal_proof i j= - if i=j then prefl (term uf i) else + if i=j then prefl (term uf i) else let (li,lj)=join_path uf i j in ptrans (path_proof i li) (psym (path_proof j lj)) - + and edge_proof ((i,j),eq)= let pi=equal_proof i eq.lhs in let pj=psym (equal_proof j eq.rhs) in let pij= - match eq.rule with + match eq.rule with Axiom (s,reversed)-> - if reversed then psymax axioms s + if reversed then psymax axioms s else pax axioms s | Congruence ->congr_proof eq.lhs eq.rhs | Injection (ti,ipac,tj,jpac,k) -> let p=ind_proof ti ipac tj jpac in let cinfo= get_constructor_info uf ipac.cnode in - pinject p cinfo.ci_constr cinfo.ci_nhyps k + pinject p cinfo.ci_constr cinfo.ci_nhyps k in ptrans (ptrans pi pij) pj and constr_proof i t ipac= @@ -133,15 +133,15 @@ let build_proof uf= and path_proof i=function [] -> prefl (term uf i) | x::q->ptrans (path_proof (snd (fst x)) q) (edge_proof x) - + and congr_proof i j= let (i1,i2) = subterms uf i - and (j1,j2) = subterms uf j in + and (j1,j2) = subterms uf j in pcongr (equal_proof i1 j1) (equal_proof i2 j2) - + and ind_proof i ipac j jpac= - let p=equal_proof i j - and p1=constr_proof i i ipac + let p=equal_proof i j + and p1=constr_proof i i ipac and p2=constr_proof j j jpac in ptrans (psym p1) (ptrans p p2) in diff --git a/plugins/cc/ccproof.mli b/plugins/cc/ccproof.mli index 7fd28390f6..2a0ca688c6 100644 --- a/plugins/cc/ccproof.mli +++ b/plugins/cc/ccproof.mli @@ -18,12 +18,12 @@ type rule= | Refl of term | Trans of proof*proof | Congr of proof*proof - | Inject of proof*constructor*int*int -and proof = + | Inject of proof*constructor*int*int +and proof = private {p_lhs:term;p_rhs:term;p_rule:rule} -val build_proof : - forest -> +val build_proof : + forest -> [ `Discr of int * pa_constructor * int * pa_constructor | `Prove of int * int ] -> proof diff --git a/plugins/cc/cctac.ml b/plugins/cc/cctac.ml index 515d4aa932..4e6ea8022e 100644 --- a/plugins/cc/cctac.ml +++ b/plugins/cc/cctac.ml @@ -80,18 +80,18 @@ let rec decompose_term env sigma t= ci_arity=nargs; ci_nhyps=nargs-oib.mind_nparams} | _ ->if closed0 t then (Symb t) else raise Not_found - + (* decompose equality in members and type *) - + let atom_of_constr env sigma term = let wh = (whd_delta env term) in - let kot = kind_of_term wh 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 + if eq_constr f (Lazy.force _eq) && (Array.length args)=3 then `Eq (args.(0), - decompose_term env sigma args.(1), - decompose_term env sigma args.(2)) + 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) @@ -99,7 +99,7 @@ let rec pattern_of_constr env sigma c = match kind_of_term (whd env c) with App (f,args)-> let pf = decompose_term env sigma f in - let pargs,lrels = List.split + let pargs,lrels = List.split (array_map_to_list (pattern_of_constr env sigma) args) in PApp (pf,List.rev pargs), List.fold_left Intset.union Intset.empty lrels @@ -112,7 +112,7 @@ let rec pattern_of_constr env sigma c = PApp(Product (sort_a,sort_b), [pa;pb]),(Intset.union sa sb) | Rel i -> PVar i,Intset.singleton i - | _ -> + | _ -> let pf = decompose_term env sigma c in PApp (pf,[]),Intset.empty @@ -121,58 +121,58 @@ let non_trivial = function | _ -> true let patterns_of_constr env sigma nrels term= - let f,args= + 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 + if eq_constr f (Lazy.force _eq) && (Array.length args)=3 + then let patt1,rels1 = pattern_of_constr env sigma args.(1) and patt2,rels2 = pattern_of_constr env sigma args.(2) in - let valid1 = + let valid1 = if Intset.cardinal rels1 <> nrels then Creates_variables else if non_trivial patt1 then Normal - else Trivial args.(0) + 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 + || valid2 <> Creates_variables then nrels,valid1,patt1,valid2,patt2 else raise Not_found else raise Not_found let rec quantified_atom_of_constr env sigma nrels term = match kind_of_term (whd_delta env term) with - Prod (_,atom,ff) -> + Prod (_,atom,ff) -> if eq_constr ff (Lazy.force _False) then let patts=patterns_of_constr env sigma nrels atom in `Nrule patts - else + else quantified_atom_of_constr env sigma (succ nrels) ff - | _ -> + | _ -> let patts=patterns_of_constr env sigma nrels term in - `Rule patts + `Rule patts let litteral_of_constr env sigma term= match kind_of_term (whd_delta env term) with - | Prod (_,atom,ff) -> + | Prod (_,atom,ff) -> if eq_constr ff (Lazy.force _False) then 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 sigma 1 ff + try + quantified_atom_of_constr env sigma 1 ff with Not_found -> `Other (decompose_term env sigma term) end - | _ -> + | _ -> 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 sigma=sig_sig gls in @@ -182,8 +182,8 @@ let rec make_prb gls depth additionnal_terms = List.iter (fun c -> let t = decompose_term env sigma c in - ignore (add_term state t)) additionnal_terms; - List.iter + ignore (add_term state t)) additionnal_terms; + List.iter (fun (id,_,e) -> begin let cid=mkVar id in @@ -191,15 +191,15 @@ let rec make_prb gls depth additionnal_terms = `Eq (t,a,b) -> add_equality state cid a b | `Neq (t,a,b) -> add_disequality state (Hyp cid) a b | `Other ph -> - List.iter - (fun (cidn,nh) -> - add_disequality state (HeqnH (cid,cidn)) ph nh) + List.iter + (fun (cidn,nh) -> + add_disequality state (HeqnH (cid,cidn)) ph nh) !neg_hyps; pos_hyps:=(cid,ph):: !pos_hyps | `Nother nh -> - List.iter - (fun (cidp,ph) -> - add_disequality state (HeqnH (cidp,cid)) ph nh) + List.iter + (fun (cidp,ph) -> + add_disequality state (HeqnH (cidp,cid)) ph nh) !pos_hyps; neg_hyps:=(cid,nh):: !neg_hyps | `Rule patts -> add_quant state id true patts @@ -208,9 +208,9 @@ let rec make_prb gls depth additionnal_terms = begin 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 - (fun (idp,ph) -> + | `Other g -> + List.iter + (fun (idp,ph) -> add_disequality state (HeqG idp) ph g) !pos_hyps end; state @@ -218,11 +218,11 @@ let rec make_prb gls depth additionnal_terms = (* indhyps builds the array of arrays of constructor hyps for (ind largs) *) let build_projection intype outtype (cstr:constructor) special default gls= - let env=pf_env gls in - let (h,argv) = - try destApp intype with + let env=pf_env gls in + let (h,argv) = + try destApp intype with Invalid_argument _ -> (intype,[||]) in - let ind=destInd h in + let ind=destInd h in let types=Inductiveops.arities_of_constructors env ind in let lp=Array.length types in let ci=pred (snd cstr) in @@ -230,16 +230,16 @@ let build_projection intype outtype (cstr:constructor) special default gls= let ti=Term.prod_appvect types.(i) argv in let rc=fst (decompose_prod_assum ti) in let head= - if i=ci then special else default in + if i=ci then special else default in it_mkLambda_or_LetIn head rc in let branches=Array.init lp branch in let casee=mkRel 1 in let pred=mkLambda(Anonymous,intype,outtype) 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 + let id=pf_get_new_id (id_of_string "t") gls in mkLambda(Name id,intype,body) - + (* generate an adhoc tactic following the proof tree *) let _M =mkMeta @@ -247,29 +247,29 @@ let _M =mkMeta let rec proof_tac p gls = match p.p_rule with Ax c -> exact_check c gls - | SymAx c -> - let l=constr_of_term p.p_lhs and + | SymAx c -> + let l=constr_of_term p.p_lhs and r=constr_of_term p.p_rhs in - let typ = refresh_universes (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 = refresh_universes (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 = refresh_universes (pf_type_of gls t2) in - let prf = + 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 | Congr (p1,p2)-> - let tf1=constr_of_term p1.p_lhs - and tx1=constr_of_term p2.p_lhs - and tf2=constr_of_term p1.p_rhs + let tf1=constr_of_term p1.p_lhs + 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 = refresh_universes (pf_type_of gls tf1) in let typx = refresh_universes (pf_type_of gls tx1) in @@ -282,7 +282,7 @@ let rec proof_tac p gls = let lemma2= mkApp(Lazy.force _f_equal, [|typx;typfx;tf2;tx1;tx2;_M 1|]) in - let prf = + let prf = mkApp(Lazy.force _trans_eq, [|typfx; mkApp(tf1,[|tx1|]); @@ -294,8 +294,8 @@ let rec proof_tac p gls = [tclTHEN (refine lemma2) (proof_tac p2); reflexivity; fun gls -> - errorlabstrm "Congruence" - (Pp.str + errorlabstrm "Congruence" + (Pp.str "I don't know how to handle dependent equality")]] gls | Inject (prf,cstr,nargs,argind) -> let ti=constr_of_term prf.p_lhs in @@ -306,10 +306,10 @@ let rec proof_tac p gls = let special=mkRel (1+nargs-argind) in let proj=build_projection intype outtype cstr special default gls in let injt= - mkApp (Lazy.force _f_equal,[|intype;outtype;proj;ti;tj;_M 1|]) in + mkApp (Lazy.force _f_equal,[|intype;outtype;proj;ti;tj;_M 1|]) in tclTHEN (refine injt) (proof_tac prf) gls -let refute_tac c t1 t2 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=refresh_universes (pf_type_of gls tt1) in let neweq= @@ -323,13 +323,13 @@ 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=refresh_universes (pf_type_of gls tt2) in - let neweq=mkApp(Lazy.force _eq,[|sort;tt1;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 - let identity=mkLambda (Name x,sort,mkRel 1) in + let identity=mkLambda (Name x,sort,mkRel 1) in let endt=mkApp (Lazy.force _eq_rect, [|sort;tt1;identity;c;tt2;mkVar e|]) in - tclTHENS (assert_tac (Name e) neweq) + tclTHENS (assert_tac (Name e) neweq) [proof_tac p;exact_check endt] gls let convert_to_hyp_tac c1 t1 c2 t2 p gls = @@ -339,7 +339,7 @@ let convert_to_hyp_tac c1 t1 c2 t2 p gls = tclTHENS (assert_tac (Name h) tt2) [convert_to_goal_tac c1 t1 t2 p; simplest_elim false_t] 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=refresh_universes (pf_type_of gls t1) in @@ -351,25 +351,25 @@ let discriminate_tac cstr p gls = let trivial=pf_type_of gls identity in let outtype=mkType (new_univ ()) in let pred=mkLambda(Name xid,outtype,mkRel 1) in - let hid=pf_get_new_id (id_of_string "Heq") gls in + let hid=pf_get_new_id (id_of_string "Heq") gls in let proj=build_projection intype outtype cstr trivial concl gls in let injt=mkApp (Lazy.force _f_equal, - [|intype;outtype;proj;t1;t2;mkVar hid|]) in + [|intype;outtype;proj;t1;t2;mkVar hid|]) in let endt=mkApp (Lazy.force _eq_rect, [|outtype;trivial;pred;identity;concl;injt|]) in let neweq=mkApp(Lazy.force _eq,[|intype;t1;t2|]) in - tclTHENS (assert_tac (Name hid) neweq) + tclTHENS (assert_tac (Name hid) neweq) [proof_tac p;exact_check endt] gls - + (* wrap everything *) - + let build_term_to_complete uf meta pac = let cinfo = get_constructor_info uf pac.cnode in let real_args = List.map (fun i -> constr_of_term (term uf i)) pac.args in let dummy_args = List.rev (list_tabulate meta pac.arity) in let all_args = List.rev_append real_args dummy_args in applistc (mkConstruct cinfo.ci_constr) all_args - + let cc_tactic depth additionnal_terms gls= Coqlib.check_required_library ["Coq";"Init";"Logic"]; let _ = debug Pp.msgnl (Pp.str "Reading subgoal ...") in @@ -379,7 +379,7 @@ let cc_tactic depth additionnal_terms gls= let _ = debug Pp.msgnl (Pp.str "Computation completed.") in let uf=forest state in match sol with - None -> tclFAIL 0 (str "congruence failed") gls + None -> tclFAIL 0 (str "congruence failed") gls | Some reason -> debug Pp.msgnl (Pp.str "Goal solved, generating proof ..."); match reason with @@ -390,22 +390,22 @@ let cc_tactic depth additionnal_terms gls= | Incomplete -> let metacnt = ref 0 in let newmeta _ = incr metacnt; _M !metacnt in - let terms_to_complete = - List.map - (build_term_to_complete uf newmeta) - (epsilons uf) in + let terms_to_complete = + List.map + (build_term_to_complete uf newmeta) + (epsilons uf) in Pp.msgnl (Pp.str "Goal is solvable by congruence but \ some arguments are missing."); Pp.msgnl (Pp.str " Try " ++ hov 8 - begin - str "\"congruence with (" ++ - prlist_with_sep + begin + str "\"congruence with (" ++ + prlist_with_sep (fun () -> str ")" ++ pr_spc () ++ str "(") (print_constr_env (pf_env gls)) - terms_to_complete ++ + terms_to_complete ++ str ")\"," end); Pp.msgnl @@ -417,18 +417,18 @@ let cc_tactic depth additionnal_terms gls= match dis.rule with Goal -> proof_tac p gls | Hyp id -> refute_tac id ta tb p gls - | HeqG id -> + | HeqG id -> convert_to_goal_tac id ta tb p gls - | HeqnH (ida,idb) -> + | HeqnH (ida,idb) -> convert_to_hyp_tac ida ta idb tb p gls - + let cc_fail gls = - errorlabstrm "Congruence" (Pp.str "congruence failed.") + errorlabstrm "Congruence" (Pp.str "congruence failed.") -let congruence_tac depth l = - tclORELSE - (tclTHEN (tclREPEAT introf) (cc_tactic depth l)) +let congruence_tac depth l = + tclORELSE + (tclTHEN (tclREPEAT introf) (cc_tactic depth l)) cc_fail (* Beware: reflexivity = constructor 1 = apply refl_equal @@ -441,22 +441,22 @@ let simple_reflexivity () = apply (Lazy.force _refl_equal) 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. + 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 +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|]))) (simple_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 + 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 []) + 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 diff --git a/plugins/cc/cctac.mli b/plugins/cc/cctac.mli index 7cdd46ab4a..7ed077bda1 100644 --- a/plugins/cc/cctac.mli +++ b/plugins/cc/cctac.mli @@ -8,7 +8,7 @@ (* $Id$ *) -open Term +open Term open Proof_type val proof_tac: Ccproof.proof -> Proof_type.tactic diff --git a/plugins/cc/g_congruence.ml4 b/plugins/cc/g_congruence.ml4 index f23ed49b6e..d9db927a37 100644 --- a/plugins/cc/g_congruence.ml4 +++ b/plugins/cc/g_congruence.ml4 @@ -15,12 +15,12 @@ open Tactics open Tacticals (* Tactic registration *) - + TACTIC EXTEND cc [ "congruence" ] -> [ congruence_tac 1000 [] ] |[ "congruence" integer(n) ] -> [ congruence_tac n [] ] |[ "congruence" "with" ne_constr_list(l) ] -> [ congruence_tac 1000 l ] - |[ "congruence" integer(n) "with" ne_constr_list(l) ] -> + |[ "congruence" integer(n) "with" ne_constr_list(l) ] -> [ congruence_tac n l ] END diff --git a/plugins/dp/Dp.v b/plugins/dp/Dp.v index 47d67725f2..bc7d73f62d 100644 --- a/plugins/dp/Dp.v +++ b/plugins/dp/Dp.v @@ -103,14 +103,14 @@ Definition zenon_notequal_s := fun T a b x y => zenon_notequal T a b y x. Set Implicit Arguments. Section congr. Variable t:Type. -Lemma ergo_eq_concat_1 : +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 : +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. diff --git a/plugins/dp/dp.ml b/plugins/dp/dp.ml index a7e1a82068..dc4698c5ea 100644 --- a/plugins/dp/dp.ml +++ b/plugins/dp/dp.ml @@ -1,7 +1,7 @@ (* Authors: Nicolas Ayache and Jean-Christophe Filliâtre *) (* Tactics to call decision procedures *) -(* Works in two steps: +(* Works in two steps: - first the Coq context and the current goal are translated in Polymorphic First-Order Logic (see fol.mli in this directory) @@ -36,27 +36,27 @@ 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 +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 +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 +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)} @@ -67,7 +67,7 @@ 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"; "Rdefinitions"]; ["Coq"; "Reals"; "Raxioms";]; ["Coq"; "Reals"; "Rbasic_fun";]; ["Coq"; "Reals"; "R_sqrt";]; @@ -123,36 +123,36 @@ let global_names = Hashtbl.create 97 let used_names = Hashtbl.create 97 let rename_global r = - try + try Hashtbl.find global_names r with Not_found -> - let rec loop id = - if Hashtbl.mem used_names id then + let rec loop id = + if Hashtbl.mem used_names id then loop (lift_ident id) - else begin + else begin Hashtbl.add used_names id (); let s = string_of_id id in - Hashtbl.add global_names r s; + Hashtbl.add global_names r s; s end in loop (Nametab.basename_of_global r) let foralls = - List.fold_right + List.fold_right (fun (x,t) p -> Forall (x, t, p)) let fresh_var = function | Anonymous -> rename_global (VarRef (id_of_string "x")) | Name x -> rename_global (VarRef x) -(* coq_rename_vars env [(x1,t1);...;(xn,tn)] renames the xi outside of - env names, and returns the new variables together with the new +(* coq_rename_vars env [(x1,t1);...;(xn,tn)] renames the xi outside of + env names, and returns the new variables together with the new environment *) let coq_rename_vars env vars = let avoid = ref (ids_of_named_context (Environ.named_context env)) in List.fold_right - (fun (na,t) (newvars, newenv) -> + (fun (na,t) (newvars, newenv) -> let id = next_name_away na !avoid in avoid := id :: !avoid; id :: newvars, Environ.push_named (id, None, t) newenv) @@ -162,9 +162,9 @@ 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 || is_Type 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 let t = substl (List.map mkVar vars) t in List.rev vars, env, t @@ -174,21 +174,21 @@ 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 || is_Type 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 let t = substl (List.map mkVar vars) t in List.rev vars, env, t in loop [] t -let decompose_arrows = +let decompose_arrows = let rec arrows_rec l c = match kind_of_term c with | Prod (_,t,c) when not (dependent (mkRel 1) c) -> arrows_rec (t :: l) c | Cast (c,_,_) -> arrows_rec l c | _ -> List.rev l, c - in + in arrows_rec [] let rec eta_expanse t vars env i = @@ -203,7 +203,7 @@ let rec eta_expanse t vars env i = let env' = Environ.push_named (id, None, a) env in let t' = mkApp (t, [| mkVar id |]) in eta_expanse t' (id :: vars) env' (pred i) - | _ -> + | _ -> assert false let rec skip_k_args k cl = match k, cl with @@ -222,7 +222,7 @@ let globals_stack = ref [] let () = Summary.declare_summary "Dp globals" { Summary.freeze_function = (fun () -> !globals, !globals_stack); - Summary.unfreeze_function = + Summary.unfreeze_function = (fun (g,s) -> globals := g; globals_stack := s); Summary.init_function = (fun () -> ()) } @@ -238,7 +238,7 @@ let lookup_local r = match Hashtbl.find locals r with | Gnot_fo -> raise NotFO | Gfo d -> d -let iter_all_constructors i f = +let iter_all_constructors i f = let _, oib = Global.lookup_inductive i in Array.iteri (fun j tj -> f j (mkConstruct (i, j+1))) @@ -246,7 +246,7 @@ let iter_all_constructors i f = (* injection c [t1,...,tn] adds the injection axiom - forall x1:t1,...,xn:tn,y1:t1,...,yn:tn. + forall x1:t1,...,xn:tn,y1:t1,...,yn:tn. c(x1,...,xn)=c(y1,...,yn) -> x1=y1 /\ ... /\ xn=yn *) let injection c l = @@ -255,8 +255,8 @@ let injection c l = let xl = List.map (fun t -> rename_global (VarRef (var "x")), t) l in i := 0; let yl = List.map (fun t -> rename_global (VarRef (var "y")), t) l in - let f = - List.fold_right2 + let f = + List.fold_right2 (fun (x,_) (y,_) p -> And (Fatom (Eq (App (x,[]),App (y,[]))), p)) xl yl True in @@ -267,14 +267,14 @@ let injection c l = let ax = Axiom ("injection_" ^ c, f) in globals_stack := ax :: !globals_stack -(* rec_names_for c [|n1;...;nk|] builds the list of constant names for +(* rec_names_for c [|n1;...;nk|] builds the list of constant names for identifiers n1...nk with the same path as c, if they exist; otherwise raises Not_found *) let rec_names_for c = let mp,dp,_ = Names.repr_con c in array_map_to_list - (function - | Name id -> + (function + | Name id -> let c' = Names.make_con mp dp (label_of_id id) in ignore (Global.lookup_constant c'); msgnl (Printer.pr_constr (mkConst c')); @@ -286,7 +286,7 @@ let rec_names_for c = let term_abstractions = Hashtbl.create 97 -let new_abstraction = +let new_abstraction = let r = ref 0 in fun () -> incr r; "abstraction_" ^ string_of_int !r (* Arithmetic constants *) @@ -345,14 +345,14 @@ let rec tr_arith_constant t = match kind_of_term t with tr_powerRZ a b | Term.Cast (t, _, _) -> tr_arith_constant t - | _ -> + | _ -> raise NotArithConstant (* translates a constant of the form (powerRZ 2 int_constant) *) and tr_powerRZ a b = (* checking first that a is (R1 + R1) *) match kind_of_term a with - | Term.App (f, [|c;d|]) when f = Lazy.force coq_Rplus -> + | Term.App (f, [|c;d|]) when f = Lazy.force coq_Rplus -> begin match kind_of_term c,kind_of_term d with | Term.Const _, Term.Const _ @@ -371,9 +371,9 @@ and tr_powerRZ a b = tv = list of type variables *) and tr_type tv env t = let t = Reductionops.nf_betadeltaiota env Evd.empty t in - if t = Lazy.force coq_Z then + if t = Lazy.force coq_Z then Tid ("int", []) - else if t = Lazy.force coq_R then + else if t = Lazy.force coq_R then Tid ("real", []) else match kind_of_term t with | Var x when List.mem x tv -> @@ -383,15 +383,15 @@ and tr_type tv env t = begin try let r = global_of_constr f in match tr_global env r with - | DeclType (id, k) -> + | DeclType (id, k) -> assert (k = List.length cl); (* since t:Set *) Tid (id, List.map (tr_type tv env) cl) - | _ -> + | _ -> raise NotFO - with + with | Not_found -> raise NotFO - | NotFO -> + | NotFO -> (* we need to abstract some part of (f cl) *) (*TODO*) raise NotFO @@ -403,8 +403,8 @@ and make_term_abstraction tv env c = match tr_decl env id ty with | DeclFun (id,_,_,_) as _d -> raise NotFO - (* [CM 07/09/2009] deactivated because it generates - unbound identifiers 'abstraction_<number>' + (* [CM 07/09/2009] deactivated because it generates + unbound identifiers 'abstraction_<number>' begin try Hashtbl.find term_abstractions c with Not_found -> @@ -428,7 +428,7 @@ and tr_decl env id ty = DeclType (id, List.length tv) else if is_Prop t then DeclPred (id, List.length tv, []) - else + else let s = Typing.type_of env Evd.empty t in if is_Prop s then Axiom (id, tr_formula tv [] env t) @@ -437,11 +437,11 @@ and tr_decl env id ty = let l = List.map (tr_type tv env) l in if is_Prop t then DeclPred(id, List.length tv, l) - else + else let s = Typing.type_of env Evd.empty t in - if is_Set s || is_Type s then + if is_Set s || is_Type s then DeclFun (id, List.length tv, l, tr_type tv env t) - else + else raise NotFO (* tr_global(r) = tr_decl(id(r),typeof(r)) + a cache mechanism *) @@ -457,7 +457,7 @@ and tr_global env r = match r with let id = rename_global r in let d = tr_decl env id ty in (* r can be already declared if it is a constructor *) - if not (mem_global r) then begin + if not (mem_global r) then begin add_global r (Gfo d); globals_stack := d :: !globals_stack end; @@ -468,7 +468,7 @@ and tr_global env r = match r with raise NotFO and axiomatize_body env r id d = match r with - | VarRef _ -> + | VarRef _ -> assert false | ConstRef c -> begin match (Global.lookup_constant c).const_body with @@ -488,7 +488,7 @@ and axiomatize_body env r id d = match r with (*Format.eprintf "axiomatize_body %S@." id;*) let b = match kind_of_term b with (* a single recursive function *) - | Fix (_, (_,_,[|b|])) -> + | Fix (_, (_,_,[|b|])) -> subst1 (mkConst c) b (* mutually recursive functions *) | Fix ((_,i), (names,_,bodies)) -> @@ -499,7 +499,7 @@ and axiomatize_body env r id d = match r with with Not_found -> b end - | _ -> + | _ -> b in let tv, env, b = decomp_type_lambdas env b in @@ -521,9 +521,9 @@ and axiomatize_body env r id d = match r with begin match kind_of_term t with | Case (ci, _, e, br) -> equations_for_case env id vars tv bv ci e br - | _ -> + | _ -> let t = tr_term tv bv env t in - let ax = + let ax = add_proof (Fun_def (id, vars, ty, t)) in let p = Fatom (Eq (App (id, fol_vars), t)) in @@ -542,7 +542,7 @@ and axiomatize_body env r id d = match r with in let axioms = List.map (fun (id,ax) -> Axiom (id, ax)) axioms in globals_stack := axioms @ !globals_stack - | None -> + | None -> () (* Coq axiom *) end | IndRef i -> @@ -597,12 +597,12 @@ and equations_for_case env id vars tv bv ci e br = match kind_of_term e with | (y, t)::l' -> if y = string_of_id e then l' else (y, t)::(remove l' e) in let vars = remove vars x in - let p = - Fatom (Eq (App (id, fol_vars), + let p = + Fatom (Eq (App (id, fol_vars), tr_term tv bv env b)) in eqs := (id ^ "_" ^ idc, foralls vars p) :: !eqs - | _ -> + | _ -> assert false end with NotFO -> ()); @@ -611,30 +611,30 @@ and equations_for_case env id vars tv bv ci e br = match kind_of_term e with raise NotFO (* assumption: t:T:Set *) -and tr_term tv bv env t = +and tr_term tv bv env t = try tr_arith_constant t with NotArithConstant -> match kind_of_term t with (* binary operations on integers *) - | Term.App (f, [|a;b|]) when f = Lazy.force coq_Zplus -> + | Term.App (f, [|a;b|]) when f = Lazy.force coq_Zplus -> Plus (tr_term tv bv env a, tr_term tv bv env b) - | Term.App (f, [|a;b|]) when f = Lazy.force coq_Zminus -> + | Term.App (f, [|a;b|]) when f = Lazy.force coq_Zminus -> Moins (tr_term tv bv env a, tr_term tv bv env b) - | Term.App (f, [|a;b|]) when f = Lazy.force coq_Zmult -> + | Term.App (f, [|a;b|]) when f = Lazy.force coq_Zmult -> Mult (tr_term tv bv env a, tr_term tv bv env b) - | Term.App (f, [|a;b|]) when f = Lazy.force coq_Zdiv -> + | Term.App (f, [|a;b|]) when f = Lazy.force coq_Zdiv -> Div (tr_term tv bv env a, tr_term tv bv env b) - | Term.App (f, [|a|]) when f = Lazy.force coq_Zopp -> + | Term.App (f, [|a|]) when f = Lazy.force coq_Zopp -> Opp (tr_term tv bv env a) (* binary operations on reals *) - | Term.App (f, [|a;b|]) when f = Lazy.force coq_Rplus -> + | Term.App (f, [|a;b|]) when f = Lazy.force coq_Rplus -> Plus (tr_term tv bv env a, tr_term tv bv env b) - | Term.App (f, [|a;b|]) when f = Lazy.force coq_Rminus -> + | Term.App (f, [|a;b|]) when f = Lazy.force coq_Rminus -> Moins (tr_term tv bv env a, tr_term tv bv env b) - | Term.App (f, [|a;b|]) when f = Lazy.force coq_Rmult -> + | Term.App (f, [|a;b|]) when f = Lazy.force coq_Rmult -> Mult (tr_term tv bv env a, tr_term tv bv env b) - | Term.App (f, [|a;b|]) when f = Lazy.force coq_Rdiv -> + | Term.App (f, [|a;b|]) when f = Lazy.force coq_Rdiv -> Div (tr_term tv bv env a, tr_term tv bv env b) | Term.Var id when List.mem id bv -> App (string_of_id id, []) @@ -643,12 +643,12 @@ and tr_term tv bv env t = begin try let r = global_of_constr f in match tr_global env r with - | DeclFun (s, k, _, _) -> + | DeclFun (s, k, _, _) -> let cl = skip_k_args k cl in Fol.App (s, List.map (tr_term tv bv env) cl) - | _ -> + | _ -> raise NotFO - with + with | Not_found -> raise NotFO | NotFO -> (* we need to abstract some part of (f cl) *) @@ -663,7 +663,7 @@ and tr_term tv bv env t = abstract (applist (app, [x])) l end in - let app,l = match cl with + let app,l = match cl with | x :: l -> applist (f, [x]), l | [] -> raise NotFO in abstract app l @@ -681,14 +681,14 @@ and quantifiers n a b tv bv env = and tr_formula tv bv env f = let c, args = decompose_app f in match kind_of_term c, args with - | Var id, [] -> + | Var id, [] -> 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 || 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 + else raise NotFO (* comparisons on integers *) | _, [a;b] when c = Lazy.force coq_Zle -> @@ -731,7 +731,7 @@ and tr_formula tv bv env f = | Lambda(n, a, b) -> let id, t, bv, env, b = quantifiers n a b tv bv env in Exists (string_of_id id, t, tr_formula tv bv env b) - | _ -> + | _ -> (* unusual case of the shape (ex p) *) raise NotFO (* TODO: we could eta-expanse *) end @@ -739,10 +739,10 @@ and tr_formula tv bv env f = begin try let r = global_of_constr c in match tr_global env r with - | DeclPred (s, k, _) -> + | DeclPred (s, k, _) -> let args = skip_k_args k args in Fatom (Pred (s, List.map (tr_term tv bv env) args)) - | _ -> + | _ -> raise NotFO with Not_found -> raise NotFO @@ -751,7 +751,7 @@ and tr_formula tv bv env f = let tr_goal gl = Hashtbl.clear locals; - let tr_one_hyp (id, ty) = + let tr_one_hyp (id, ty) = try let s = rename_global (VarRef id) in let d = tr_decl (pf_env gl) s ty in @@ -762,7 +762,7 @@ let tr_goal gl = raise NotFO in let hyps = - List.fold_right + List.fold_right (fun h acc -> try tr_one_hyp h :: acc with NotFO -> acc) (pf_hyps_types gl) [] in @@ -781,9 +781,9 @@ 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; + begin try + while true do + let s = input_line c in Buffer.add_string buf s; Buffer.add_char buf '\n' done; assert false @@ -791,7 +791,7 @@ let file_contents f = close_in c; Buffer.contents buf end - with _ -> + with _ -> sprintf "(cannot open %s)" f let timeout_sys_command cmd = @@ -799,24 +799,24 @@ let timeout_sys_command cmd = let out = Filename.temp_file "out" "" in let cmd = sprintf "why-cpulimit %d %s > %s 2>&1" !timeout cmd out in let ret = Sys.command cmd in - if !debug then + 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 + if c = 152 then + Timeout else - Failure + 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 +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)} @@ -826,18 +826,18 @@ 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" (why_files fwhy) + let cmd = + sprintf "why --simplify %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 "why-cpulimit %d Simplify %s > out 2>&1 && grep -q -w Valid out" + let cmd = + sprintf "why-cpulimit %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 None else if out = 1 then Invalid else Timeout + 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 @@ -847,15 +847,15 @@ let call_ergo fwhy = 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 = + let cmd = if !trace then sprintf "alt-ergo -cctrace %s %s" ftrace fwhy else sprintf "alt-ergo %s" fwhy in let ret,out = timeout_sys_command cmd in - let r = - if ret <> 0 then + 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) @@ -871,18 +871,18 @@ let call_ergo fwhy = let call_zenon fwhy = - let cmd = + 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 %d zenon -ocoqterm %s > %s 2>&1" !timeout fznn out + let cmd = + 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 + if c = 137 then Timeout else begin if c <> 0 then anomaly ("command failed: " ^ cmd); @@ -893,58 +893,58 @@ let call_zenon fwhy = end let call_yices fwhy = - let cmd = + let cmd = sprintf "why -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 "why-cpulimit %d yices -pc 0 -smt %s > out 2>&1 && grep -q -w unsat out" + let cmd = + sprintf "why-cpulimit %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 None else if out = 1 then Invalid else Timeout + let r = + if out = 0 then Valid None else if out = 1 then Invalid else Timeout in if not !debug then remove_files [fwhy; fsmt]; r let call_cvc3 fwhy = - let cmd = + let cmd = sprintf "why -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 "why-cpulimit %d cvc3 -lang smt %s > out 2>&1 && grep -q -w unsat out" + let cmd = + sprintf "why-cpulimit %d cvc3 -lang 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 None else if out = 1 then Invalid else Timeout + let r = + if out = 0 then Valid None else if out = 1 then Invalid else Timeout in if not !debug then remove_files [fwhy; fsmt]; r let call_cvcl fwhy = - let cmd = + let cmd = sprintf "why --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 %d cvcl < %s > out 2>&1 && grep -q -w Valid out" + let cmd = + 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 None else if out = 1 then Invalid else Timeout + 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 = + let cmd = sprintf "why --harvey --encoding strat %s" (why_files fwhy) in if Sys.command cmd <> 0 then error ("call to " ^ cmd ^ " failed"); @@ -953,15 +953,15 @@ let call_harvey fwhy = if out <> 0 then anomaly ("call to rvc -e -t " ^ frv ^ " failed"); let f = Filename.chop_suffix frv ".rv" ^ "-0.baf" in let outf = Filename.temp_file "rv" ".out" in - let out = - Sys.command (sprintf "timeout %d rv -e\"-T 2000\" %s > %s 2>&1" - !timeout f outf) + let out = + Sys.command (sprintf "timeout %d rv -e\"-T 2000\" %s > %s 2>&1" + !timeout f outf) in let r = - if out <> 0 then + if out <> 0 then Timeout else - let cmd = + let cmd = sprintf "grep \"Proof obligation in\" %s | grep -q \"is valid\"" outf in if Sys.command cmd = 0 then Valid None else Invalid @@ -1000,12 +1000,12 @@ let call_prover prover q = | 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 + try let q = tr_goal gl in begin match call_prover prover q with | Valid (Some f) when prover = Zenon -> Dp_zenon.proof_from_file f gl @@ -1019,7 +1019,7 @@ let dp prover gl = end with NotFO -> error "Not a first order goal" - + let simplify = tclTHEN intros (dp Simplify) let ergo = tclTHEN intros (dp Ergo) @@ -1032,7 +1032,7 @@ let gwhy = tclTHEN intros (dp Gwhy) let dp_hint l = let env = Global.env () in - let one_hint (qid,r) = + let one_hint (qid,r) = if not (mem_global r) then begin let ty = Global.type_of_global r in let s = Typing.type_of env Evd.empty ty in @@ -1046,7 +1046,7 @@ let dp_hint l = with NotFO -> add_global r Gnot_fo; msg_warning - (pr_reference qid ++ + (pr_reference qid ++ str " ignored (not a first order proposition)") else begin add_global r Gnot_fo; @@ -1057,9 +1057,9 @@ let dp_hint l = 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 +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)} @@ -1075,7 +1075,7 @@ let dp_predefined qid s = 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) + | DeclPred (_, n, tyl) -> DeclPred (s, n, tyl) | Axiom _ as d -> d in match d with @@ -1084,22 +1084,22 @@ let dp_predefined qid s = with NotFO -> msg_warning (str " ignored (not a first order declaration)") -let (dp_predefined_obj,_) = - declare_object - {(default_object "Dp_predefined") with +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 = +let _ = declare_summary "Dp options" + { freeze_function = (fun () -> !debug, !trace, !timeout, !prelude_files); - unfreeze_function = - (fun (d,tr,tm,pr) -> + 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 := []) } + init_function = + (fun () -> + debug := false; trace := false; timeout := 10; + prelude_files := []) } diff --git a/plugins/dp/dp_why.ml b/plugins/dp/dp_why.ml index 94dc0ef484..4a1d70d411 100644 --- a/plugins/dp/dp_why.ml +++ b/plugins/dp/dp_why.ml @@ -4,12 +4,12 @@ open Format open Fol -type proof = +type proof = | Immediate of Term.constr | Fun_def of string * (string * typ) list * typ * term let proofs = Hashtbl.create 97 -let proof_name = +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 @@ -24,9 +24,9 @@ let rec print_list sep print fmt = function let space fmt () = fprintf fmt "@ " let comma fmt () = fprintf fmt ",@ " -let is_why_keyword = +let is_why_keyword = let h = Hashtbl.create 17 in - List.iter + List.iter (fun s -> Hashtbl.add h s ()) ["absurd"; "and"; "array"; "as"; "assert"; "axiom"; "begin"; "bool"; "do"; "done"; "else"; "end"; "exception"; "exists"; @@ -34,7 +34,7 @@ let is_why_keyword = "if"; "in"; "int"; "invariant"; "label"; "let"; "logic"; "not"; "of"; "or"; "parameter"; "predicate"; "prop"; "raise"; "raises"; "reads"; "real"; "rec"; "ref"; "returns"; "then"; "true"; "try"; - "type"; "unit"; "variant"; "void"; "while"; "with"; "writes" ]; + "type"; "unit"; "variant"; "void"; "while"; "with"; "writes" ]; Hashtbl.mem h let ident fmt s = @@ -49,9 +49,9 @@ let rec print_typ fmt = function | Tid (x,tl) -> fprintf fmt "(%a) %a" (print_list comma print_typ) tl ident x let rec print_term fmt = function - | Cst n -> + | Cst n -> fprintf fmt "%s" (Big_int.string_of_big_int n) - | RCst s -> + | RCst s -> fprintf fmt "%s.0" (Big_int.string_of_big_int s) | Power2 n -> fprintf fmt "0x1p%s" (Big_int.string_of_big_int n) @@ -64,17 +64,17 @@ let rec print_term fmt = function | Div (a, b) -> fprintf fmt "@[(%a /@ %a)@]" print_term a print_term b | Opp (a) -> - fprintf fmt "@[(-@ %a)@]" print_term a + fprintf fmt "@[(-@ %a)@]" print_term a | App (id, []) -> fprintf fmt "%a" ident id | App (id, tl) -> fprintf fmt "@[%a(%a)@]" ident id print_terms tl -and print_terms fmt tl = +and print_terms fmt tl = print_list comma print_term fmt tl -let rec print_predicate fmt p = - let pp = print_predicate in +let rec print_predicate fmt p = + let pp = print_predicate in match p with | True -> fprintf fmt "true" @@ -90,9 +90,9 @@ let rec print_predicate fmt p = 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, [])) -> + | Fatom (Pred (id, [])) -> fprintf fmt "%a" ident id - | Fatom (Pred (id, tl)) -> + | Fatom (Pred (id, tl)) -> fprintf fmt "@[%a(%a)@]" ident id print_terms tl | Imp (a, b) -> fprintf fmt "@[(%a ->@ %a)@]" pp a pp b @@ -104,9 +104,9 @@ let rec print_predicate fmt p = fprintf fmt "@[(%a or@ %a)@]" pp a pp b | Not a -> fprintf fmt "@[(not@ %a)@]" pp a - | Forall (id, t, p) -> + | Forall (id, t, p) -> fprintf fmt "@[(forall %a:%a.@ %a)@]" ident id print_typ t pp p - | Exists (id, t, p) -> + | Exists (id, t, p) -> fprintf fmt "@[(exists %a:%a.@ %a)@]" ident id print_typ t pp p let print_query fmt (decls,concl) = @@ -117,7 +117,7 @@ let print_query fmt (decls,concl) = fprintf fmt "@[type 'a %a@]@\n@\n" ident id | DeclType (id, n) -> fprintf fmt "@[type ("; - for i = 1 to n do + for i = 1 to n do fprintf fmt "'a%d" i; if i < n then fprintf fmt ", " done; fprintf fmt ") %a@]@\n@\n" ident id @@ -128,18 +128,18 @@ let print_query fmt (decls,concl) = | DeclFun (id, _, [], t) -> fprintf fmt "@[logic %a : -> %a@]@\n@\n" ident id print_typ t | DeclFun (id, _, l, t) -> - fprintf fmt "@[logic %a : %a -> %a@]@\n@\n" + fprintf fmt "@[logic %a : %a -> %a@]@\n@\n" ident id (print_list comma print_typ) l print_typ t | DeclPred (id, _, []) -> fprintf fmt "@[logic %a : -> prop @]@\n@\n" ident id - | DeclPred (id, _, l) -> - fprintf fmt "@[logic %a : %a -> prop@]@\n@\n" + | DeclPred (id, _, l) -> + fprintf fmt "@[logic %a : %a -> prop@]@\n@\n" ident id (print_list comma print_typ) l | DeclType _ | Axiom _ -> () in let print_assert = function - | Axiom (id, f) -> + | Axiom (id, f) -> fprintf fmt "@[<hov 2>axiom %a:@ %a@]@\n@\n" ident id print_predicate f | DeclType _ | DeclFun _ | DeclPred _ -> () diff --git a/plugins/dp/dp_why.mli b/plugins/dp/dp_why.mli index b38a3d3762..0efa24a238 100644 --- a/plugins/dp/dp_why.mli +++ b/plugins/dp/dp_why.mli @@ -7,7 +7,7 @@ val output_file : string -> query -> unit (* table to translate the proofs back to Coq (used in dp_zenon) *) -type proof = +type proof = | Immediate of Term.constr | Fun_def of string * (string * typ) list * typ * term diff --git a/plugins/dp/dp_zenon.mll b/plugins/dp/dp_zenon.mll index 658534151a..949e91e344 100644 --- a/plugins/dp/dp_zenon.mll +++ b/plugins/dp/dp_zenon.mll @@ -1,7 +1,7 @@ { - open Lexing + open Lexing open Pp open Util open Names @@ -12,9 +12,9 @@ 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) @@ -50,15 +50,15 @@ and scan = parse { anomaly "malformed Zenon proof term" } and read_coq_term = parse -| "." "\n" +| "." "\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 +| ("dp_axiom__" ['0'-'9']+) as id { axioms := id :: !axioms; Buffer.add_string buf id; read_coq_term lexbuf } -| _ as c +| _ as c { Buffer.add_char buf c; read_coq_term lexbuf } -| eof +| eof { anomaly "malformed Zenon proof term" } and read_lemma_proof = parse @@ -71,7 +71,7 @@ and read_lemma_proof = parse and read_main_proof = parse | ":=" "\n" { read_coq_term lexbuf } -| _ +| _ { read_main_proof lexbuf } | eof { anomaly "malformed Zenon proof term" } @@ -88,7 +88,7 @@ and read_main_proof = parse if not !debug then begin try Sys.remove f with _ -> () end; p - let constr_of_string gl s = + 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) @@ -102,7 +102,7 @@ and read_main_proof = parse | [] -> () | [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 ",@ " @@ -110,14 +110,14 @@ and read_main_proof = parse | 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 - + | 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 -> + | Cst n -> fprintf fmt "%s" (Big_int.string_of_big_int n) - | RCst s -> + | RCst s -> fprintf fmt "%s" (Big_int.string_of_big_int s) | Power2 n -> fprintf fmt "@[(powerRZ 2 %s)@]" (Big_int.string_of_big_int n) @@ -132,13 +132,13 @@ and read_main_proof = parse | Div (a, b) -> fprintf fmt "@[(Zdiv %a %a)@]" print_term a print_term b | Opp (a) -> - fprintf fmt "@[(Zopp %a)@]" print_term a + fprintf fmt "@[(Zopp %a)@]" print_term a | App (id, []) -> fprintf fmt "%s" id | App (id, tl) -> fprintf fmt "@[(%s %a)@]" id print_terms tl - and print_terms fmt tl = + and print_terms fmt tl = print_list space print_term fmt tl (* builds the text for "forall vars, f vars = t" *) @@ -146,17 +146,17 @@ and read_main_proof = parse 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 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 -> + | Immediate t -> exact_check t - | Fun_def (f, vars, ty, t) -> + | Fun_def (f, vars, ty, t) -> tclTHENS (fun gl -> let s = Coq.fun_def_axiom f vars t in diff --git a/plugins/dp/fol.mli b/plugins/dp/fol.mli index 32637bb74d..4fb763a6d1 100644 --- a/plugins/dp/fol.mli +++ b/plugins/dp/fol.mli @@ -1,11 +1,11 @@ (* Polymorphic First-Order Logic (that is Why's input logic) *) -type typ = +type typ = | Tvar of string | Tid of string * typ list -type term = +type term = | Cst of Big_int.big_int | RCst of Big_int.big_int | Power2 of Big_int.big_int @@ -16,7 +16,7 @@ type term = | Opp of term | App of string * term list -and atom = +and atom = | Eq of term * term | Le of term * term | Lt of term * term @@ -24,7 +24,7 @@ and atom = | Gt of term * term | Pred of string * term list -and form = +and form = | Fatom of atom | Imp of form * form | Iff of form * form @@ -48,8 +48,8 @@ type query = decl list * form (* prover result *) -type prover_answer = - | Valid of string option +type prover_answer = + | Valid of string option | Invalid | DontKnow | Timeout diff --git a/plugins/dp/g_dp.ml4 b/plugins/dp/g_dp.ml4 index e027c882e6..505b07a143 100644 --- a/plugins/dp/g_dp.ml4 +++ b/plugins/dp/g_dp.ml4 @@ -49,7 +49,7 @@ TACTIC EXTEND admit [ "admit" ] -> [ Tactics.admit_as_an_axiom ] END -VERNAC COMMAND EXTEND Dp_hint +VERNAC COMMAND EXTEND Dp_hint [ "Dp_hint" ne_global_list(l) ] -> [ dp_hint l ] END diff --git a/plugins/dp/test2.v b/plugins/dp/test2.v index 3e4c0f6dd0..0940b13524 100644 --- a/plugins/dp/test2.v +++ b/plugins/dp/test2.v @@ -36,7 +36,7 @@ Goal fct O = O. Admitted. Fixpoint even (n:nat) : Prop := - match n with + match n with O => True | S O => False | S (S p) => even p @@ -64,9 +64,9 @@ BUG avec head prédéfini : manque eta-expansion sur A:Set Goal forall x, head _ (p _ _ 1 2) = Some x -> fst x = 1. -Print value. +Print value. Print Some. - + zenon. *) diff --git a/plugins/dp/tests.v b/plugins/dp/tests.v index 1a796094b8..dc85d2ee2b 100644 --- a/plugins/dp/tests.v +++ b/plugins/dp/tests.v @@ -50,8 +50,8 @@ Qed. Parameter nlist: list nat -> Prop. Lemma poly_1 : forall l, nlist l -> True. -intros. -simplify. +intros. +simplify. Qed. (* user lists *) @@ -66,8 +66,8 @@ match l with | cons a l1 => cons A a (app A l1 m) end. -Lemma entail: (nil Z) = app Z (nil Z) (nil Z) -> True. -intros; ergo. +Lemma entail: (nil Z) = app Z (nil Z) (nil Z) -> True. +intros; ergo. Qed. (* polymorphism *) @@ -81,13 +81,13 @@ Parameter my_nlist: mylist nat -> Prop. Goal forall l, my_nlist l -> True. intros. - simplify. + simplify. Qed. (* First example with the 0 and the equality translated *) Goal 0 = 0. -simplify. +simplify. Qed. (* Examples in the Propositional Calculus @@ -102,7 +102,7 @@ Qed. Goal A -> (A \/ C). -simplify. +simplify. Qed. @@ -145,12 +145,12 @@ induction x0; ergo. Qed. -(* No decision procedure can solve this problem +(* No decision procedure can solve this problem Goal forall (x a b : Z), a * x + b = 0 -> x = - b/a. *) -(* Functions definitions *) +(* Functions definitions *) Definition fst (x y : Z) : Z := x. @@ -205,7 +205,7 @@ Axiom add_S : forall (n1 n2 : nat), add (S n1) n2 = S (add n1 n2). Dp_hint add_0. Dp_hint add_S. -(* Simplify can't prove this goal before the timeout +(* Simplify can't prove this goal before the timeout unlike zenon *) Goal forall n : nat, add n 0 = n. @@ -258,7 +258,7 @@ Qed. (* sorts issues *) -Parameter foo : Set. +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. diff --git a/plugins/extraction/extraction.ml b/plugins/extraction/extraction.ml index ffaefd5e38..3468e8a360 100644 --- a/plugins/extraction/extraction.ml +++ b/plugins/extraction/extraction.ml @@ -620,7 +620,7 @@ and extract_cst_app env mle mlt kn args = else mla with _ -> mla else mla - in + in (* Different situations depending of the number of arguments: *) if ls = 0 then put_magic_if magic2 head else if List.mem Keep s then diff --git a/plugins/extraction/g_extraction.ml4 b/plugins/extraction/g_extraction.ml4 index 2b561616b4..60a2e91a2f 100644 --- a/plugins/extraction/g_extraction.ml4 +++ b/plugins/extraction/g_extraction.ml4 @@ -28,7 +28,7 @@ open Table open Extract_env let pr_language = function - | Ocaml -> str "Ocaml" + | Ocaml -> str "Ocaml" | Haskell -> str "Haskell" | Scheme -> str "Scheme" diff --git a/plugins/extraction/haskell.ml b/plugins/extraction/haskell.ml index 6403e7bbe9..9d45c08b7e 100644 --- a/plugins/extraction/haskell.ml +++ b/plugins/extraction/haskell.ml @@ -300,7 +300,7 @@ let pp_decl = function else let e = pp_global Term r in e ++ str " :: " ++ pp_type false [] t ++ fnl () ++ - if is_custom r then + if is_custom r then hov 0 (e ++ str " = " ++ str (find_custom r) ++ fnl2 ()) else hov 0 (pp_function (empty_env ()) e a ++ fnl2 ()) diff --git a/plugins/extraction/miniml.mli b/plugins/extraction/miniml.mli index 12ca9ad757..55231d766b 100644 --- a/plugins/extraction/miniml.mli +++ b/plugins/extraction/miniml.mli @@ -85,7 +85,7 @@ type equiv = type ml_ind = { ind_info : inductive_info; - ind_nparams : int; + ind_nparams : int; ind_packets : ml_ind_packet array; ind_equiv : equiv } diff --git a/plugins/extraction/modutil.ml b/plugins/extraction/modutil.ml index 0394ea4b74..1b1a39770d 100644 --- a/plugins/extraction/modutil.ml +++ b/plugins/extraction/modutil.ml @@ -115,7 +115,7 @@ let decl_iter_references do_term do_cons do_type = | Dind (kn,ind) -> ind_iter_references do_term do_cons do_type kn ind | Dtype (r,_,t) -> do_type r; type_iter t | Dterm (r,a,t) -> do_term r; ast_iter a; type_iter t - | Dfix(rv,c,t) -> + | Dfix(rv,c,t) -> Array.iter do_term rv; Array.iter ast_iter c; Array.iter type_iter t let spec_iter_references do_term do_cons do_type = function diff --git a/plugins/extraction/scheme.ml b/plugins/extraction/scheme.ml index eaa47f5f92..50339d473d 100644 --- a/plugins/extraction/scheme.ml +++ b/plugins/extraction/scheme.ml @@ -98,7 +98,7 @@ let rec pp_expr env args = if i = Coinductive then paren (str "delay " ++ st) else st | MLcase ((i,_),t, pv) -> let e = - if i <> Coinductive then pp_expr env [] t + if i <> Coinductive then pp_expr env [] t else paren (str "force" ++ spc () ++ pp_expr env [] t) in apply (v 3 (paren (str "match " ++ e ++ fnl () ++ pp_pat env pv))) diff --git a/plugins/field/LegacyField_Compl.v b/plugins/field/LegacyField_Compl.v index 746e7c9976..d4a39296a0 100644 --- a/plugins/field/LegacyField_Compl.v +++ b/plugins/field/LegacyField_Compl.v @@ -13,7 +13,7 @@ Require Import List. Definition assoc_2nd := (fix assoc_2nd_rec (A:Type) (B:Set) (eq_dec:forall e1 e2:B, {e1 = e2} + {e1 <> e2}) - (lst:list (prod A B)) {struct lst} : + (lst:list (prod A B)) {struct lst} : B -> A -> A := fun (key:B) (default:A) => match lst with @@ -26,7 +26,7 @@ Definition assoc_2nd := end). Definition mem := - (fix mem (A:Set) (eq_dec:forall e1 e2:A, {e1 = e2} + {e1 <> e2}) + (fix mem (A:Set) (eq_dec:forall e1 e2:A, {e1 = e2} + {e1 <> e2}) (a:A) (l:list A) {struct l} : bool := match l with | nil => false diff --git a/plugins/field/LegacyField_Tactic.v b/plugins/field/LegacyField_Tactic.v index 63d9bdda69..5c1f228ac6 100644 --- a/plugins/field/LegacyField_Tactic.v +++ b/plugins/field/LegacyField_Tactic.v @@ -29,17 +29,17 @@ Ltac mem_assoc var lvar := end end. -Ltac number lvar := +Ltac number lvar := let rec number_aux lvar cpt := match constr:lvar with | (@nil ?X1) => constr:(@nil (prod X1 nat)) | ?X2 :: ?X3 => let l2 := number_aux X3 (S cpt) in - constr:((X2,cpt) :: l2) + constr:((X2,cpt) :: l2) end in number_aux lvar 0. -Ltac build_varlist FT trm := +Ltac build_varlist FT trm := let rec seek_var lvar trm := let AT := get_component A FT with AzeroT := get_component Azero FT @@ -244,11 +244,11 @@ Ltac inverse_test FT := Ltac apply_simplif sfun := match goal with - | |- (interp_ExprA ?X1 ?X2 ?X3 = interp_ExprA _ _ _) => + | |- (interp_ExprA ?X1 ?X2 ?X3 = interp_ExprA _ _ _) => sfun X1 X2 X3 end; match goal with - | |- (interp_ExprA _ _ _ = interp_ExprA ?X1 ?X2 ?X3) => + | |- (interp_ExprA _ _ _ = interp_ExprA ?X1 ?X2 ?X3) => sfun X1 X2 X3 end. diff --git a/plugins/field/LegacyField_Theory.v b/plugins/field/LegacyField_Theory.v index 131ba84b83..378efa0353 100644 --- a/plugins/field/LegacyField_Theory.v +++ b/plugins/field/LegacyField_Theory.v @@ -13,7 +13,7 @@ Require Import Peano_dec. Require Import LegacyRing. Require Import LegacyField_Compl. -Record Field_Theory : Type := +Record Field_Theory : Type := {A : Type; Aplus : A -> A -> A; Amult : A -> A -> A; @@ -59,7 +59,7 @@ Proof. right; red in |- *; intro; inversion H1; auto. elim (eq_nat_dec n n0); intro y. left; rewrite y; auto. - right; red in |- *; intro; inversion H; auto. + right; red in |- *; intro; inversion H; auto. Defined. Definition eq_nat_dec := Eval compute in eq_nat_dec. @@ -149,7 +149,7 @@ Proof. repeat rewrite AplusT_assoc; rewrite <- H; reflexivity. legacy ring. Qed. - + Lemma r_AmultT_mult : forall r r1 r2:AT, AmultT r r1 = AmultT r r2 -> r <> AzeroT -> r1 = r2. Proof. @@ -164,22 +164,22 @@ Lemma AmultT_Or : forall r:AT, AmultT r AzeroT = AzeroT. Proof. intro; legacy ring. Qed. - + Lemma AmultT_Ol : forall r:AT, AmultT AzeroT r = AzeroT. Proof. intro; legacy ring. Qed. - + Lemma AmultT_1r : forall r:AT, AmultT r AoneT = r. Proof. intro; legacy ring. Qed. - + Lemma AinvT_r : forall r:AT, r <> AzeroT -> AmultT r (AinvT r) = AoneT. Proof. intros; rewrite AmultT_comm; apply Th_inv_defT; auto. Qed. - + Lemma Rmult_neq_0_reg : forall r1 r2:AT, AmultT r1 r2 <> AzeroT -> r1 <> AzeroT /\ r2 <> AzeroT. Proof. @@ -298,7 +298,7 @@ Lemma assoc_mult_correct1 : Proof. simple induction e1; auto; intros. rewrite <- (H e0 lvar); simpl in |- *; rewrite merge_mult_correct; - simpl in |- *; rewrite merge_mult_correct; simpl in |- *; + simpl in |- *; rewrite merge_mult_correct; simpl in |- *; auto. Qed. @@ -318,7 +318,7 @@ simpl in |- *; rewrite merge_mult_correct; simpl in |- *; rewrite <- assoc_mult_correct1 in H1; unfold interp_ExprA at 3 in H1; fold interp_ExprA in H1; rewrite (H0 lvar) in H1; rewrite (AmultT_comm (interp_ExprA lvar e3) (interp_ExprA lvar e1)); - rewrite <- AmultT_assoc; rewrite H1; rewrite AmultT_assoc; + rewrite <- AmultT_assoc; rewrite H1; rewrite AmultT_assoc; legacy ring. simpl in |- *; rewrite (H0 lvar); auto. simpl in |- *; rewrite (H0 lvar); auto. @@ -365,7 +365,7 @@ Lemma assoc_plus_correct : Proof. simple induction e1; auto; intros. rewrite <- (H e0 lvar); simpl in |- *; rewrite merge_plus_correct; - simpl in |- *; rewrite merge_plus_correct; simpl in |- *; + simpl in |- *; rewrite merge_plus_correct; simpl in |- *; auto. Qed. @@ -388,7 +388,7 @@ simpl in |- *; rewrite merge_plus_correct; simpl in |- *; (interp_ExprA lvar e1))); rewrite <- AplusT_assoc; rewrite (AplusT_comm (interp_ExprA lvar (assoc e1)) (interp_ExprA lvar (assoc e2))) - ; rewrite assoc_plus_correct; rewrite H1; simpl in |- *; + ; rewrite assoc_plus_correct; rewrite H1; simpl in |- *; rewrite (H0 lvar); rewrite <- (AplusT_assoc (AplusT (interp_ExprA lvar e2) (interp_ExprA lvar e1)) @@ -402,13 +402,13 @@ simpl in |- *; rewrite merge_plus_correct; simpl in |- *; (AplusT_assoc (interp_ExprA lvar e2) (interp_ExprA lvar e3) (interp_ExprA lvar e1)); apply AplusT_comm. unfold assoc in |- *; fold assoc in |- *; unfold interp_ExprA in |- *; - fold interp_ExprA in |- *; rewrite assoc_mult_correct; + fold interp_ExprA in |- *; rewrite assoc_mult_correct; rewrite (H0 lvar); simpl in |- *; auto. simpl in |- *; rewrite (H0 lvar); auto. simpl in |- *; rewrite (H0 lvar); auto. simpl in |- *; rewrite (H0 lvar); auto. unfold assoc in |- *; fold assoc in |- *; unfold interp_ExprA in |- *; - fold interp_ExprA in |- *; rewrite assoc_mult_correct; + fold interp_ExprA in |- *; rewrite assoc_mult_correct; simpl in |- *; auto. Qed. @@ -466,7 +466,7 @@ Proof. simple induction e1; try intros; simpl in |- *. rewrite AmultT_Ol; rewrite distrib_mult_right_correct; simpl in |- *; apply AmultT_Or. -rewrite distrib_mult_right_correct; simpl in |- *; apply AmultT_comm. +rewrite distrib_mult_right_correct; simpl in |- *; apply AmultT_comm. rewrite AmultT_comm; rewrite (AmultT_AplusT_distr (interp_ExprA lvar e2) (interp_ExprA lvar e) @@ -629,7 +629,7 @@ Lemma monom_simplif_correct : Proof. simple induction e; intros; auto. simpl in |- *; case (eqExprA a e0); intros. -rewrite <- e2; apply monom_simplif_rem_correct; auto. +rewrite <- e2; apply monom_simplif_rem_correct; auto. simpl in |- *; trivial. Qed. diff --git a/plugins/field/field.ml4 b/plugins/field/field.ml4 index 7401491e45..2b4651dfb9 100644 --- a/plugins/field/field.ml4 +++ b/plugins/field/field.ml4 @@ -44,12 +44,12 @@ let th_tab = ref (Gmap.empty : (constr,constr) Gmap.t) let lookup env typ = try Gmap.find typ !th_tab - with Not_found -> + with Not_found -> errorlabstrm "field" (str "No field is declared for type" ++ spc() ++ Printer.pr_lconstr_env env typ) -let _ = +let _ = let init () = th_tab := Gmap.empty in let freeze () = !th_tab in let unfreeze fs = th_tab := fs in @@ -116,7 +116,7 @@ END (* For the translator, otherwise the code above is OK *) open Ppconstr -let pp_minus_div_arg _prc _prlc _prt (omin,odiv) = +let pp_minus_div_arg _prc _prlc _prt (omin,odiv) = if omin=None && odiv=None then mt() else spc() ++ str "with" ++ pr_opt (fun c -> str "minus := " ++ _prc c) omin ++ @@ -128,7 +128,7 @@ let () = (globwit_minus_div_arg,pp_minus_div_arg) (wit_minus_div_arg,pp_minus_div_arg) *) -ARGUMENT EXTEND minus_div_arg +ARGUMENT EXTEND minus_div_arg TYPED AS constr_opt * constr_opt PRINTED BY pp_minus_div_arg | [ "with" minusarg(m) divarg_opt(d) ] -> [ Some m, d ] @@ -137,7 +137,7 @@ ARGUMENT EXTEND minus_div_arg END VERNAC COMMAND EXTEND Field - [ "Add" "Legacy" "Field" + [ "Add" "Legacy" "Field" constr(a) constr(aplus) constr(amult) constr(aone) constr(azero) constr(aopp) constr(aeq) constr(ainv) constr(rth) constr(ainv_l) minus_div_arg(md) ] diff --git a/plugins/firstorder/formula.ml b/plugins/firstorder/formula.ml index 0be3a4b399..45365cb2cd 100644 --- a/plugins/firstorder/formula.ml +++ b/plugins/firstorder/formula.ml @@ -41,20 +41,20 @@ let meta_succ m = m+1 let rec nb_prod_after n c= match kind_of_term c with - | Prod (_,_,b) ->if n>0 then nb_prod_after (n-1) b else + | Prod (_,_,b) ->if n>0 then nb_prod_after (n-1) b else 1+(nb_prod_after 0 b) | _ -> 0 let construct_nhyps ind gls = let nparams = (fst (Global.lookup_inductive ind)).mind_nparams in - let constr_types = Inductiveops.arities_of_constructors (pf_env gls) ind in - let hyp = nb_prod_after nparams in + let constr_types = Inductiveops.arities_of_constructors (pf_env gls) ind in + let hyp = nb_prod_after nparams in Array.map hyp constr_types (* indhyps builds the array of arrays of constructor hyps for (ind largs)*) -let ind_hyps nevar ind largs gls= - let types= Inductiveops.arities_of_constructors (pf_env gls) ind in - let lp=Array.length types in +let ind_hyps nevar ind largs gls= + let types= Inductiveops.arities_of_constructors (pf_env gls) ind in + let lp=Array.length types in let myhyps i= let t1=Term.prod_applist types.(i) largs in let t2=snd (decompose_prod_n_assum nevar t1) in @@ -77,7 +77,7 @@ type kind_of_formula= | Exists of inductive*constr list | Forall of constr*constr | Atom of constr - + let rec kind_of_formula gl term = let normalize=special_nf gl in let cciterm=special_whd gl term in @@ -86,34 +86,34 @@ let rec kind_of_formula gl term = |_-> match match_with_forall_term cciterm with Some (_,a,b)-> Forall(a,b) - |_-> + |_-> match match_with_nodep_ind cciterm with Some (i,l,n)-> let ind=destInd i in let (mib,mip) = Global.lookup_inductive ind in let nconstr=Array.length mip.mind_consnames in - if nconstr=0 then + if nconstr=0 then False(ind,l) else let has_realargs=(n>0) in let is_trivial= let is_constant c = - nb_prod c = mib.mind_nparams in - array_exists is_constant mip.mind_nf_lc in + nb_prod c = mib.mind_nparams in + array_exists is_constant mip.mind_nf_lc in if Inductiveops.mis_is_recursive (ind,mib,mip) || (has_realargs && not is_trivial) then - Atom cciterm + Atom cciterm else if nconstr=1 then And(ind,l,is_trivial) - else - Or(ind,l,is_trivial) - | _ -> + else + Or(ind,l,is_trivial) + | _ -> match match_with_sigma_type cciterm with Some (i,l)-> Exists((destInd i),l) |_-> Atom (normalize cciterm) - + type atoms = {positive:constr list;negative:constr list} type side = Hyp | Concl | Hint @@ -126,7 +126,7 @@ let build_atoms gl metagen side cciterm = let trivial =ref false and positive=ref [] and negative=ref [] in - let normalize=special_nf gl in + let normalize=special_nf gl in let rec build_rec env polarity cciterm= match kind_of_formula gl cciterm with False(_,_)->if not polarity then trivial:=true @@ -134,12 +134,12 @@ let build_atoms gl metagen side cciterm = build_rec env (not polarity) a; build_rec env polarity b | And(i,l,b) | Or(i,l,b)-> - if b then + if b then begin let unsigned=normalize (substnl env 0 cciterm) in - if polarity then - positive:= unsigned :: !positive - else + if polarity then + positive:= unsigned :: !positive + else negative:= unsigned :: !negative end; let v = ind_hyps 0 i l gl in @@ -148,9 +148,9 @@ let build_atoms gl metagen side cciterm = let f l = list_fold_left_i g (1-(List.length l)) () l in if polarity && (* we have a constant constructor *) - array_exists (function []->true|_->false) v + array_exists (function []->true|_->false) v then trivial:=true; - Array.iter f v + Array.iter f v | Exists(i,l)-> let var=mkMeta (metagen true) in let v =(ind_hyps 1 i l gl).(0) in @@ -163,15 +163,15 @@ let build_atoms gl metagen side cciterm = | Atom t-> let unsigned=substnl env 0 t in if not (isMeta unsigned) then (* discarding wildcard atoms *) - if polarity then - positive:= unsigned :: !positive - else + if polarity then + positive:= unsigned :: !positive + else negative:= unsigned :: !negative in begin match side with Concl -> build_rec [] true cciterm | Hyp -> build_rec [] false cciterm - | Hint -> + | Hint -> let rels,head=decompose_prod cciterm in let env=List.rev (List.map (fun _->mkMeta (metagen true)) rels) in build_rec env false head;trivial:=false (* special for hints *) @@ -179,15 +179,15 @@ let build_atoms gl metagen side cciterm = (!trivial, {positive= !positive; negative= !negative}) - + type right_pattern = Rarrow | Rand - | Ror + | Ror | Rfalse | Rforall | Rexists of metavariable*constr*bool - + type left_arrow_pattern= LLatom | LLfalse of inductive*constr list @@ -198,9 +198,9 @@ type left_arrow_pattern= | LLarrow of constr*constr*constr type left_pattern= - Lfalse + Lfalse | Land of inductive - | Lor of inductive + | Lor of inductive | Lforall of metavariable*constr*bool | Lexists of inductive | LA of constr*left_arrow_pattern @@ -209,14 +209,14 @@ type t={id:global_reference; constr:constr; pat:(left_pattern,right_pattern) sum; atoms:atoms} - + let build_formula side nam typ gl metagen= let normalize = special_nf gl in - try + try let m=meta_succ(metagen false) in let trivial,atoms= - if !qflag then - build_atoms gl metagen side typ + if !qflag then + build_atoms gl metagen side typ else no_atoms in let pattern= match side with @@ -227,10 +227,10 @@ let build_formula side nam typ gl metagen= | Atom a -> raise (Is_atom a) | And(_,_,_) -> Rand | Or(_,_,_) -> Ror - | Exists (i,l) -> + | Exists (i,l) -> let (_,_,d)=list_last (ind_hyps 0 i l gl).(0) in Rexists(m,d,trivial) - | Forall (_,a) -> Rforall + | Forall (_,a) -> Rforall | Arrow (a,b) -> Rarrow in Right pat | _ -> @@ -238,7 +238,7 @@ let build_formula side nam typ gl metagen= match kind_of_formula gl typ with False(i,_) -> Lfalse | Atom a -> raise (Is_atom a) - | And(i,_,b) -> + | And(i,_,b) -> if b then let nftyp=normalize typ in raise (Is_atom nftyp) else Land i @@ -246,12 +246,12 @@ let build_formula side nam typ gl metagen= if b then let nftyp=normalize typ in raise (Is_atom nftyp) else Lor i - | Exists (ind,_) -> Lexists ind - | Forall (d,_) -> + | Exists (ind,_) -> Lexists ind + | Forall (d,_) -> Lforall(m,d,trivial) | Arrow (a,b) -> let nfa=normalize a in - LA (nfa, + LA (nfa, match kind_of_formula gl a with False(i,l)-> LLfalse(i,l) | Atom t-> LLatom diff --git a/plugins/firstorder/formula.mli b/plugins/firstorder/formula.mli index 9e9d1e1220..2e89ddb061 100644 --- a/plugins/firstorder/formula.mli +++ b/plugins/firstorder/formula.mli @@ -16,10 +16,10 @@ val qflag : bool ref val red_flags: Closure.RedFlags.reds ref -val (=?) : ('a -> 'a -> int) -> ('b -> 'b -> int) -> +val (=?) : ('a -> 'a -> int) -> ('b -> 'b -> int) -> 'a -> 'a -> 'b -> 'b -> int - -val (==?) : ('a -> 'a -> 'b ->'b -> int) -> ('c -> 'c -> int) -> + +val (==?) : ('a -> 'a -> 'b ->'b -> int) -> ('c -> 'c -> int) -> 'a -> 'a -> 'b -> 'b -> 'c ->'c -> int type ('a,'b) sum = Left of 'a | Right of 'b @@ -28,7 +28,7 @@ type counter = bool -> metavariable val construct_nhyps : inductive -> Proof_type.goal Tacmach.sigma -> int array -val ind_hyps : int -> inductive -> constr list -> +val ind_hyps : int -> inductive -> constr list -> Proof_type.goal Tacmach.sigma -> rel_context array type atoms = {positive:constr list;negative:constr list} @@ -36,18 +36,18 @@ type atoms = {positive:constr list;negative:constr list} type side = Hyp | Concl | Hint val dummy_id: global_reference - -val build_atoms : Proof_type.goal Tacmach.sigma -> counter -> + +val build_atoms : Proof_type.goal Tacmach.sigma -> counter -> side -> constr -> bool * atoms type right_pattern = Rarrow | Rand - | Ror + | Ror | Rfalse | Rforall | Rexists of metavariable*constr*bool - + type left_arrow_pattern= LLatom | LLfalse of inductive*constr list @@ -58,20 +58,20 @@ type left_arrow_pattern= | LLarrow of constr*constr*constr type left_pattern= - Lfalse + Lfalse | Land of inductive - | Lor of inductive + | Lor of inductive | Lforall of metavariable*constr*bool | Lexists of inductive | LA of constr*left_arrow_pattern - + type t={id: global_reference; constr: constr; pat: (left_pattern,right_pattern) sum; atoms: atoms} - + (*exception Is_atom of constr*) -val build_formula : side -> global_reference -> types -> +val build_formula : side -> global_reference -> types -> Proof_type.goal Tacmach.sigma -> counter -> (t,types) sum diff --git a/plugins/firstorder/g_ground.ml4 b/plugins/firstorder/g_ground.ml4 index 8302da5c1d..c986a30260 100644 --- a/plugins/firstorder/g_ground.ml4 +++ b/plugins/firstorder/g_ground.ml4 @@ -30,10 +30,10 @@ let _= let gdopt= { optsync=true; optname="Firstorder Depth"; - optkey=["Firstorder";"Depth"]; - optread=(fun ()->Some !ground_depth); + optkey=["Firstorder";"Depth"]; + optread=(fun ()->Some !ground_depth); optwrite= - (function + (function None->ground_depth:=3 | Some i->ground_depth:=(max i 0))} in @@ -45,10 +45,10 @@ let _= let gdopt= { optsync=true; optname="Congruence Depth"; - optkey=["Congruence";"Depth"]; - optread=(fun ()->Some !congruence_depth); + optkey=["Congruence";"Depth"]; + optread=(fun ()->Some !congruence_depth); optwrite= - (function + (function None->congruence_depth:=0 | Some i->congruence_depth:=(max i 0))} in @@ -57,23 +57,23 @@ let _= let default_solver=(Tacinterp.interp <:tactic<auto with *>>) let fail_solver=tclFAIL 0 (Pp.str "GTauto failed") - + let gen_ground_tac flag taco ids bases gl= let backup= !qflag in try qflag:=flag; - let solver= - match taco with + let solver= + match taco with Some tac-> tac | None-> default_solver in let startseq gl= let seq=empty_seq !ground_depth in extend_with_auto_hints bases (extend_with_ref_list ids seq gl) gl in - let result=ground_tac solver startseq gl in + let result=ground_tac solver startseq gl in qflag:=backup;result with e ->qflag:=backup;raise e - -(* special for compatibility with Intuition + +(* special for compatibility with Intuition let constant str = Coqlib.gen_constant "User" ["Init";"Logic"] str @@ -83,10 +83,10 @@ let defined_connectives=lazy let normalize_evaluables= onAllHypsAndConcl - (function + (function None->unfold_in_concl (Lazy.force defined_connectives) - | Some id-> - unfold_in_hyp (Lazy.force defined_connectives) + | Some id-> + unfold_in_hyp (Lazy.force defined_connectives) (Tacexpr.InHypType id)) *) open Genarg @@ -116,12 +116,12 @@ END TACTIC EXTEND firstorder [ "firstorder" tactic_opt(t) firstorder_using(l) ] -> [ gen_ground_tac true (Option.map eval_tactic t) l [] ] -| [ "firstorder" tactic_opt(t) "with" ne_preident_list(l) ] -> +| [ "firstorder" tactic_opt(t) "with" ne_preident_list(l) ] -> [ gen_ground_tac true (Option.map eval_tactic t) [] l ] -| [ "firstorder" tactic_opt(t) firstorder_using(l) - "with" ne_preident_list(l') ] -> +| [ "firstorder" tactic_opt(t) firstorder_using(l) + "with" ne_preident_list(l') ] -> [ gen_ground_tac true (Option.map eval_tactic t) l l' ] -| [ "firstorder" tactic_opt(t) ] -> +| [ "firstorder" tactic_opt(t) ] -> [ gen_ground_tac true (Option.map eval_tactic t) [] [] ] END @@ -131,11 +131,11 @@ TACTIC EXTEND gintuition END -let default_declarative_automation gls = +let default_declarative_automation gls = tclORELSE - (tclORELSE (Auto.h_trivial [] None) + (tclORELSE (Auto.h_trivial [] None) (Cctac.congruence_tac !congruence_depth [])) - (gen_ground_tac true + (gen_ground_tac true (Some (tclTHEN default_solver (Cctac.congruence_tac !congruence_depth []))) @@ -143,6 +143,6 @@ let default_declarative_automation gls = -let () = +let () = Decl_proof_instr.register_automation_tac default_declarative_automation diff --git a/plugins/firstorder/ground.ml b/plugins/firstorder/ground.ml index a8d5fc2ef3..8a0f02d27e 100644 --- a/plugins/firstorder/ground.ml +++ b/plugins/firstorder/ground.ml @@ -19,10 +19,10 @@ open Tacticals open Libnames (* -let old_search=ref !Auto.searchtable +let old_search=ref !Auto.searchtable -(* I use this solution as a means to know whether hints have changed, -but this prevents the GC from collecting the previous table, +(* I use this solution as a means to know whether hints have changed, +but this prevents the GC from collecting the previous table, resulting in some limited space wasting*) let update_flags ()= @@ -30,7 +30,7 @@ let update_flags ()= begin old_search:=!Auto.searchtable; let predref=ref Names.KNpred.empty in - let f p_a_t = + let f p_a_t = match p_a_t.Auto.code with Auto.Unfold_nth (ConstRef kn)-> predref:=Names.KNpred.add kn !predref @@ -39,7 +39,7 @@ let update_flags ()= let h _ hdb=Auto.Hint_db.iter g hdb in Util.Stringmap.iter h !Auto.searchtable; red_flags:= - Closure.RedFlags.red_add_transparent + Closure.RedFlags.red_add_transparent Closure.betaiotazeta (Names.Idpred.full,!predref) end *) @@ -53,8 +53,8 @@ let update_flags ()= with Invalid_argument "destConst"-> () in List.iter f (Classops.coercions ()); red_flags:= - Closure.RedFlags.red_add_transparent - Closure.betaiotazeta + Closure.RedFlags.red_add_transparent + Closure.betaiotazeta (Names.Idpred.full,Names.Cpred.complement !predref) let ground_tac solver startseq gl= @@ -64,10 +64,10 @@ let ground_tac solver startseq gl= then Pp.msgnl (Printer.pr_goal (sig_it gl)); tclORELSE (axiom_tac seq.gl seq) begin - try - let (hd,seq1)=take_formula seq + try + let (hd,seq1)=take_formula seq and re_add s=re_add_formula_list skipped s in - let continue=toptac [] + let continue=toptac [] and backtrack gl=toptac (hd::skipped) seq1 gl in match hd.pat with Right rpat-> @@ -77,7 +77,7 @@ let ground_tac solver startseq gl= and_tac backtrack continue (re_add seq1) | Rforall-> let backtrack1= - if !qflag then + if !qflag then tclFAIL 0 (Pp.str "reversible in 1st order mode") else backtrack in @@ -86,12 +86,12 @@ let ground_tac solver startseq gl= arrow_tac backtrack continue (re_add seq1) | Ror-> or_tac backtrack continue (re_add seq1) - | Rfalse->backtrack + | Rfalse->backtrack | Rexists(i,dom,triv)-> let (lfp,seq2)=collect_quantified seq in let backtrack2=toptac (lfp@skipped) seq2 in - if !qflag && seq.depth>0 then - quantified_tac lfp backtrack2 + if !qflag && seq.depth>0 then + quantified_tac lfp backtrack2 continue (re_add seq) else backtrack2 (* need special backtracking *) @@ -102,21 +102,21 @@ let ground_tac solver startseq gl= Lfalse-> left_false_tac hd.id | Land ind-> - left_and_tac ind backtrack + left_and_tac ind backtrack hd.id continue (re_add seq1) | Lor ind-> - left_or_tac ind backtrack + left_or_tac ind backtrack hd.id continue (re_add seq1) | Lforall (_,_,_)-> let (lfp,seq2)=collect_quantified seq in let backtrack2=toptac (lfp@skipped) seq2 in - if !qflag && seq.depth>0 then - quantified_tac lfp backtrack2 + if !qflag && seq.depth>0 then + quantified_tac lfp backtrack2 continue (re_add seq) else backtrack2 (* need special backtracking *) | Lexists ind -> - if !qflag then + if !qflag then left_exists_tac ind backtrack hd.id continue (re_add seq1) else backtrack @@ -124,14 +124,14 @@ let ground_tac solver startseq gl= let la_tac= begin match lap with - LLatom -> backtrack - | LLand (ind,largs) | LLor(ind,largs) + LLatom -> backtrack + | LLand (ind,largs) | LLor(ind,largs) | LLfalse (ind,largs)-> - (ll_ind_tac ind largs backtrack - hd.id continue (re_add seq1)) - | LLforall p -> - if seq.depth>0 && !qflag then - (ll_forall_tac p backtrack + (ll_ind_tac ind largs backtrack + hd.id continue (re_add seq1)) + | LLforall p -> + if seq.depth>0 && !qflag then + (ll_forall_tac p backtrack hd.id continue (re_add seq1)) else backtrack | LLexists (ind,l) -> @@ -140,13 +140,13 @@ let ground_tac solver startseq gl= hd.id continue (re_add seq1) else backtrack - | LLarrow (a,b,c) -> + | LLarrow (a,b,c) -> (ll_arrow_tac a b c backtrack hd.id continue (re_add seq1)) - end in + end in ll_atom_tac typ la_tac hd.id continue (re_add seq1) end with Heap.EmptyHeap->solver end gl in wrap (List.length (pf_hyps gl)) true (toptac []) (startseq gl) gl - + diff --git a/plugins/firstorder/ground_plugin.mllib b/plugins/firstorder/ground_plugin.mllib index 1647e0f3d3..447a1fb513 100644 --- a/plugins/firstorder/ground_plugin.mllib +++ b/plugins/firstorder/ground_plugin.mllib @@ -3,6 +3,6 @@ Unify Sequent Rules Instances -Ground +Ground G_ground Ground_plugin_mod diff --git a/plugins/firstorder/instances.ml b/plugins/firstorder/instances.ml index 3e087cd8b6..810262a699 100644 --- a/plugins/firstorder/instances.ml +++ b/plugins/firstorder/instances.ml @@ -37,8 +37,8 @@ let compare_instance inst1 inst2= let compare_gr id1 id2= if id1==id2 then 0 else - if id1==dummy_id then 1 - else if id2==dummy_id then -1 + if id1==dummy_id then 1 + else if id2==dummy_id then -1 else Pervasives.compare id1 id2 module OrderedInstance= @@ -48,7 +48,7 @@ struct (compare_instance =? compare_gr) inst2 inst1 id2 id1 (* we want a __decreasing__ total order *) end - + module IS=Set.Make(OrderedInstance) let make_simple_atoms seq= @@ -62,7 +62,7 @@ let do_sequent setref triv id seq i dom atoms= let flag=ref true in let phref=ref triv in let do_atoms a1 a2 = - let do_pair t1 t2 = + let do_pair t1 t2 = match unif_atoms i dom t1 t2 with None->() | Some (Phantom _) ->phref:=true @@ -71,27 +71,27 @@ let do_sequent setref triv id seq i dom atoms= List.iter (fun t->List.iter (do_pair t) a2.positive) a1.negative in HP.iter (fun lf->do_atoms atoms lf.atoms) seq.redexes; do_atoms atoms (make_simple_atoms seq); - !flag && !phref - + !flag && !phref + let match_one_quantified_hyp setref seq lf= - match lf.pat with + match lf.pat with Left(Lforall(i,dom,triv))|Right(Rexists(i,dom,triv))-> if do_sequent setref triv lf.id seq i dom lf.atoms then - setref:=IS.add ((Phantom dom),lf.id) !setref - | _ ->anomaly "can't happen" + setref:=IS.add ((Phantom dom),lf.id) !setref + | _ ->anomaly "can't happen" let give_instances lf seq= let setref=ref IS.empty in List.iter (match_one_quantified_hyp setref seq) lf; IS.elements !setref - + (* collector for the engine *) let rec collect_quantified seq= try let hd,seq1=take_formula seq in - (match hd.pat with - Left(Lforall(_,_,_)) | Right(Rexists(_,_,_)) -> + (match hd.pat with + Left(Lforall(_,_,_)) | Right(Rexists(_,_,_)) -> let (q,seq2)=collect_quantified seq1 in ((hd::q),seq2) | _->[],seq) @@ -109,10 +109,10 @@ let mk_open_instance id gl m t= let var_id= if id==dummy_id then dummy_bvid else let typ=pf_type_of gl (constr_of_global id) in - (* since we know we will get a product, + (* since we know we will get a product, reduction is not too expensive *) let (nam,_,_)=destProd (whd_betadeltaiota env evmap typ) in - match nam with + match nam with Name id -> id | Anonymous -> dummy_bvid in let revt=substl (list_tabulate (fun i->mkRel (m-i)) m) t in @@ -123,15 +123,15 @@ let mk_open_instance id gl m t= let nt=it_mkLambda_or_LetIn revt (aux m []) in let rawt=Detyping.detype false [] [] nt in let rec raux n t= - if n=0 then t else + if n=0 then t else match t with RLambda(loc,name,k,_,t0)-> let t1=raux (n-1) t0 in RLambda(loc,name,k,RHole (dummy_loc,Evd.BinderType name),t1) | _-> anomaly "can't happen" in - let ntt=try + let ntt=try Pretyping.Default.understand evmap env (raux m rawt) - with _ -> + with _ -> error "Untypable instance, maybe higher-order non-prenex quantification" in decompose_lam_n_assum m ntt @@ -140,51 +140,51 @@ let mk_open_instance id gl m t= let left_instance_tac (inst,id) continue seq= match inst with Phantom dom-> - if lookup (id,None) seq then + if lookup (id,None) seq then tclFAIL 0 (Pp.str "already done") else - tclTHENS (cut dom) + tclTHENS (cut dom) [tclTHENLIST [introf; - (fun gls->generalize + (fun gls->generalize [mkApp(constr_of_global id, [|mkVar (Tacmach.pf_nth_hyp_id gls 1)|])] gls); introf; - tclSOLVE [wrap 1 false continue + tclSOLVE [wrap 1 false continue (deepen (record (id,None) seq))]]; tclTRY assumption] | Real((m,t) as c,_)-> - if lookup (id,Some c) seq then + if lookup (id,Some c) seq then tclFAIL 0 (Pp.str "already done") - else + else let special_generalize= - if m>0 then - fun gl-> + if m>0 then + fun gl-> let (rc,ot)= mk_open_instance id gl m t in - let gt= - it_mkLambda_or_LetIn + let gt= + it_mkLambda_or_LetIn (mkApp(constr_of_global id,[|ot|])) rc in generalize [gt] gl else generalize [mkApp(constr_of_global id,[|t|])] in - tclTHENLIST + tclTHENLIST [special_generalize; - introf; - tclSOLVE + introf; + tclSOLVE [wrap 1 false continue (deepen (record (id,Some c) seq))]] - + let right_instance_tac inst continue seq= match inst with Phantom dom -> - tclTHENS (cut dom) + tclTHENS (cut dom) [tclTHENLIST [introf; (fun gls-> - split (Rawterm.ImplicitBindings + split (Rawterm.ImplicitBindings [mkVar (Tacmach.pf_nth_hyp_id gls 1)]) gls); tclSOLVE [wrap 0 true continue (deepen seq)]]; - tclTRY assumption] + tclTRY assumption] | Real ((0,t),_) -> (tclTHEN (split (Rawterm.ImplicitBindings [t])) (tclSOLVE [wrap 0 true continue (deepen seq)])) @@ -192,7 +192,7 @@ let right_instance_tac inst continue seq= tclFAIL 0 (Pp.str "not implemented ... yet") let instance_tac inst= - if (snd inst)==dummy_id then + if (snd inst)==dummy_id then right_instance_tac (fst inst) else left_instance_tac inst @@ -203,4 +203,4 @@ let quantified_tac lf backtrack continue seq gl= (tclFIRST (List.map (fun inst->instance_tac inst continue seq) insts)) backtrack gl - + diff --git a/plugins/firstorder/instances.mli b/plugins/firstorder/instances.mli index aed2ec83d1..95dd22ea89 100644 --- a/plugins/firstorder/instances.mli +++ b/plugins/firstorder/instances.mli @@ -13,10 +13,10 @@ open Tacmach open Names open Libnames open Rules - + val collect_quantified : Sequent.t -> Formula.t list * Sequent.t -val give_instances : Formula.t list -> Sequent.t -> +val give_instances : Formula.t list -> Sequent.t -> (Unify.instance * global_reference) list val quantified_tac : Formula.t list -> seqtac with_backtracking diff --git a/plugins/firstorder/rules.ml b/plugins/firstorder/rules.ml index 75d69099ae..515efea701 100644 --- a/plugins/firstorder/rules.ml +++ b/plugins/firstorder/rules.ml @@ -31,17 +31,17 @@ let wrap n b continue seq gls= let nc=pf_hyps gls in let env=pf_env gls in let rec aux i nc ctx= - if i<=0 then seq else + if i<=0 then seq else match nc with []->anomaly "Not the expected number of hyps" - | ((id,_,typ) as nd)::q-> - if occur_var env id (pf_concl gls) || + | ((id,_,typ) as nd)::q-> + if occur_var env id (pf_concl gls) || List.exists (occur_var_in_decl env id) ctx then (aux (i-1) q (nd::ctx)) else add_formula Hyp (VarRef id) typ (aux (i-1) q (nd::ctx)) gls in let seq1=aux n nc [] in - let seq2=if b then + let seq2=if b then add_formula Concl dummy_id (pf_concl gls) seq1 gls else seq1 in continue seq2 gls @@ -52,24 +52,24 @@ let basename_of_global=function let clear_global=function VarRef id->clear [id] | _->tclIDTAC - + (* connection rules *) let axiom_tac t seq= - try exact_no_check (constr_of_global (find_left t seq)) + try exact_no_check (constr_of_global (find_left t seq)) with Not_found->tclFAIL 0 (Pp.str "No axiom link") -let ll_atom_tac a backtrack id continue seq= +let ll_atom_tac a backtrack id continue seq= tclIFTHENELSE - (try + (try tclTHENLIST [generalize [mkApp(constr_of_global id, [|constr_of_global (find_left a seq)|])]; clear_global id; intro] with Not_found->tclFAIL 0 (Pp.str "No link")) - (wrap 1 false continue seq) backtrack + (wrap 1 false continue seq) backtrack (* right connectives rules *) @@ -77,7 +77,7 @@ let and_tac backtrack continue seq= tclIFTHENELSE simplest_split (wrap 0 true continue seq) backtrack let or_tac backtrack continue seq= - tclORELSE + tclORELSE (any_constructor false (Some (tclCOMPLETE (wrap 0 true continue seq)))) backtrack @@ -89,17 +89,17 @@ let arrow_tac backtrack continue seq= (* left connectives rules *) let left_and_tac ind backtrack id continue seq gls= - let n=(construct_nhyps ind gls).(0) in + let n=(construct_nhyps ind gls).(0) in tclIFTHENELSE - (tclTHENLIST + (tclTHENLIST [simplest_elim (constr_of_global id); - clear_global id; + clear_global id; tclDO n intro]) (wrap n false continue seq) backtrack gls let left_or_tac ind backtrack id continue seq gls= - let v=construct_nhyps ind gls in + let v=construct_nhyps ind gls in let f n= tclTHENLIST [clear_global id; @@ -117,10 +117,10 @@ let left_false_tac id= (* We use this function for false, and, or, exists *) -let ll_ind_tac ind largs backtrack id continue seq gl= +let ll_ind_tac ind largs backtrack id continue seq gl= let rcs=ind_hyps 0 ind largs gl in let vargs=Array.of_list largs in - (* construire le terme H->B, le generaliser etc *) + (* construire le terme H->B, le generaliser etc *) let myterm i= let rc=rcs.(i) in let p=List.length rc in @@ -132,7 +132,7 @@ let ll_ind_tac ind largs backtrack id continue seq gl= let lp=Array.length rcs in let newhyps=list_tabulate myterm lp in tclIFTHENELSE - (tclTHENLIST + (tclTHENLIST [generalize newhyps; clear_global id; tclDO lp intro]) @@ -149,9 +149,9 @@ let ll_arrow_tac a b c backtrack id continue seq= [introf; clear_global id; wrap 1 false continue seq]; - tclTHENS (cut cc) - [exact_no_check (constr_of_global id); - tclTHENLIST + tclTHENS (cut cc) + [exact_no_check (constr_of_global id); + tclTHENLIST [generalize [d]; clear_global id; introf; @@ -167,21 +167,21 @@ let forall_tac backtrack continue seq= (tclORELSE (tclTHEN introf (tclCOMPLETE (wrap 0 true continue seq))) backtrack)) - (if !qflag then + (if !qflag then tclFAIL 0 (Pp.str "reversible in 1st order mode") else backtrack) let left_exists_tac ind backtrack id continue seq gls= - let n=(construct_nhyps ind gls).(0) in + let n=(construct_nhyps ind gls).(0) in tclIFTHENELSE (simplest_elim (constr_of_global id)) (tclTHENLIST [clear_global id; tclDO n intro; - (wrap (n-1) false continue seq)]) - backtrack + (wrap (n-1) false continue seq)]) + backtrack gls - + let ll_forall_tac prod backtrack id continue seq= tclORELSE (tclTHENS (cut prod) @@ -190,7 +190,7 @@ let ll_forall_tac prod backtrack id continue seq= (fun gls-> let id0=pf_nth_hyp_id gls 1 in let term=mkApp((constr_of_global id),[|mkVar(id0)|]) in - tclTHEN (generalize [term]) (clear [id0]) gls); + tclTHEN (generalize [term]) (clear [id0]) gls); clear_global id; intro; tclCOMPLETE (wrap 1 false continue (deepen seq))]; @@ -209,7 +209,7 @@ let defined_connectives=lazy let normalize_evaluables= onAllHypsAndConcl - (function + (function None->unfold_in_concl (Lazy.force defined_connectives) - | Some id -> + | Some id -> unfold_in_hyp (Lazy.force defined_connectives) (id,InHypTypeOnly)) diff --git a/plugins/firstorder/rules.mli b/plugins/firstorder/rules.mli index b804c93ae3..fc32621ca7 100644 --- a/plugins/firstorder/rules.mli +++ b/plugins/firstorder/rules.mli @@ -49,6 +49,6 @@ val forall_tac : seqtac with_backtracking val left_exists_tac : inductive -> lseqtac with_backtracking -val ll_forall_tac : types -> lseqtac with_backtracking +val ll_forall_tac : types -> lseqtac with_backtracking val normalize_evaluables : tactic diff --git a/plugins/firstorder/sequent.ml b/plugins/firstorder/sequent.ml index 98b178bdee..685d44a84d 100644 --- a/plugins/firstorder/sequent.ml +++ b/plugins/firstorder/sequent.ml @@ -27,7 +27,7 @@ let priority = (* pure heuristics, <=0 for non reversible *) begin match rf with Rarrow -> 100 - | Rand -> 40 + | Rand -> 40 | Ror -> -15 | Rfalse -> -50 | Rforall -> 100 @@ -38,7 +38,7 @@ let priority = (* pure heuristics, <=0 for non reversible *) Lfalse -> 999 | Land _ -> 90 | Lor _ -> 40 - | Lforall (_,_,_) -> -30 + | Lforall (_,_,_) -> -30 | Lexists _ -> 60 | LA(_,lap) -> match lap with @@ -48,7 +48,7 @@ let priority = (* pure heuristics, <=0 for non reversible *) | LLor (_,_) -> 70 | LLforall _ -> -20 | LLexists (_,_) -> 50 - | LLarrow (_,_,_) -> -10 + | LLarrow (_,_,_) -> -10 let left_reversible lpat=(priority lpat)>0 @@ -71,15 +71,15 @@ let rec compare_list f l1 l2= | _,[] -> 1 | (h1::q1),(h2::q2) -> (f =? (compare_list f)) h1 h2 q1 q2 -let compare_array f v1 v2= +let compare_array f v1 v2= let l=Array.length v1 in let c=l - Array.length v2 in if c=0 then let rec comp_aux i= - if i<0 then 0 + if i<0 then 0 else let ci=f v1.(i) v2.(i) in - if ci=0 then + if ci=0 then comp_aux (i-1) else ci in comp_aux (l-1) @@ -93,16 +93,16 @@ let compare_constr_int f t1 t2 = | Sort s1, Sort s2 -> Pervasives.compare s1 s2 | Cast (c1,_,_), _ -> f c1 t2 | _, Cast (c2,_,_) -> f t1 c2 - | Prod (_,t1,c1), Prod (_,t2,c2) + | Prod (_,t1,c1), Prod (_,t2,c2) | Lambda (_,t1,c1), Lambda (_,t2,c2) -> - (f =? f) t1 t2 c1 c2 - | LetIn (_,b1,t1,c1), LetIn (_,b2,t2,c2) -> + (f =? f) t1 t2 c1 c2 + | LetIn (_,b1,t1,c1), LetIn (_,b2,t2,c2) -> ((f =? f) ==? f) b1 b2 t1 t2 c1 c2 | App (_,_), App (_,_) -> - let c1,l1=decompose_app t1 + let c1,l1=decompose_app t1 and c2,l2=decompose_app t2 in (f =? (compare_list f)) c1 c2 l1 l2 - | Evar (e1,l1), Evar (e2,l2) -> + | Evar (e1,l1), Evar (e2,l2) -> ((-) =? (compare_array f)) e1 e2 l1 l2 | Const c1, Const c2 -> Pervasives.compare c1 c2 | Ind c1, Ind c2 -> Pervasives.compare c1 c2 @@ -119,7 +119,7 @@ let compare_constr_int f t1 t2 = let rec compare_constr m n= compare_constr_int compare_constr m n - + module OrderedConstr= struct type t=constr @@ -129,13 +129,13 @@ end type h_item = global_reference * (int*constr) option module Hitem= -struct +struct type t = h_item let compare (id1,co1) (id2,co2)= - (Pervasives.compare + (Pervasives.compare =? (fun oc1 oc2 -> - match oc1,oc2 with - Some (m1,c1),Some (m2,c2) -> + match oc1,oc2 with + Some (m1,c1),Some (m2,c2) -> ((-) =? OrderedConstr.compare) m1 m2 c1 c2 | _,_->Pervasives.compare oc1 oc2)) id1 id2 co1 co2 end @@ -145,16 +145,16 @@ module CM=Map.Make(OrderedConstr) module History=Set.Make(Hitem) let cm_add typ nam cm= - try + try let l=CM.find typ cm in CM.add typ (nam::l) cm with Not_found->CM.add typ [nam] cm - + let cm_remove typ nam cm= try - let l=CM.find typ cm in + let l=CM.find typ cm in let l0=List.filter (fun id->id<>nam) l in - match l0 with + match l0 with []->CM.remove typ cm | _ ->CM.add typ l0 cm with Not_found ->cm @@ -172,7 +172,7 @@ type t= depth:int} let deepen seq={seq with depth=seq.depth-1} - + let record item seq={seq with history=History.add item seq.history} let lookup item seq= @@ -192,12 +192,12 @@ let rec add_formula side nam t seq gl= begin match side with Concl -> - {seq with + {seq with redexes=HP.add f seq.redexes; gl=f.constr; glatom=None} | _ -> - {seq with + {seq with redexes=HP.add f seq.redexes; context=cm_add f.constr nam seq.context} end @@ -206,15 +206,15 @@ let rec add_formula side nam t seq gl= Concl -> {seq with gl=t;glatom=Some t} | _ -> - {seq with + {seq with context=cm_add t nam seq.context; latoms=t::seq.latoms} - + let re_add_formula_list lf seq= let do_one f cm= if f.id == dummy_id then cm else cm_add f.constr f.id cm in - {seq with + {seq with redexes=List.fold_right HP.add lf seq.redexes; context=List.fold_right do_one lf seq.context} @@ -234,17 +234,17 @@ let rec take_formula seq= and hp=HP.remove seq.redexes in if hd.id == dummy_id then let nseq={seq with redexes=hp} in - if seq.gl==hd.constr then + if seq.gl==hd.constr then hd,nseq else take_formula nseq (* discarding deprecated goal *) else - hd,{seq with + hd,{seq with redexes=hp; context=cm_remove hd.constr hd.id seq.context} - + let empty_seq depth= - {redexes=HP.empty; + {redexes=HP.empty; context=CM.empty; latoms=[]; gl=(mkMeta 1); @@ -264,7 +264,7 @@ let expand_constructor_hints = let extend_with_ref_list l seq gl= let l = expand_constructor_hints l in let f gr seq= - let c=constr_of_global gr in + let c=constr_of_global gr in let typ=(pf_type_of gl c) in add_formula Hyp gr typ seq gl in List.fold_right f l seq @@ -277,8 +277,8 @@ let extend_with_auto_hints l seq gl= match p_a_t.code with Res_pf (c,_) | Give_exact c | Res_pf_THEN_trivial_fail (c,_) -> - (try - let gr=global_of_constr c in + (try + let gr=global_of_constr c in let typ=(pf_type_of gl c) in seqref:=add_formula Hint gr typ !seqref gl with Not_found->()) @@ -288,7 +288,7 @@ let extend_with_auto_hints l seq gl= let hdb= try searchtable_map dbname - with Not_found-> + with Not_found-> error ("Firstorder: "^dbname^" : No such Hint database") in Hint_db.iter g hdb in List.iter h l; @@ -297,16 +297,16 @@ let extend_with_auto_hints l seq gl= let print_cmap map= let print_entry c l s= let xc=Constrextern.extern_constr false (Global.env ()) c in - str "| " ++ - Util.prlist Printer.pr_global l ++ + str "| " ++ + Util.prlist Printer.pr_global l ++ str " : " ++ - Ppconstr.pr_constr_expr xc ++ - cut () ++ + Ppconstr.pr_constr_expr xc ++ + cut () ++ s in - msgnl (v 0 - (str "-----" ++ + msgnl (v 0 + (str "-----" ++ cut () ++ CM.fold print_entry map (mt ()) ++ str "-----")) - + diff --git a/plugins/firstorder/sequent.mli b/plugins/firstorder/sequent.mli index 206de27ed7..ce0eddccc2 100644 --- a/plugins/firstorder/sequent.mli +++ b/plugins/firstorder/sequent.mli @@ -46,7 +46,7 @@ val record: h_item -> t -> t val lookup: h_item -> t -> bool -val add_formula : side -> global_reference -> constr -> t -> +val add_formula : side -> global_reference -> constr -> t -> Proof_type.goal sigma -> t val re_add_formula_list : Formula.t list -> t -> t @@ -60,7 +60,7 @@ val empty_seq : int -> t val extend_with_ref_list : global_reference list -> t -> Proof_type.goal sigma -> t -val extend_with_auto_hints : Auto.hint_db_name list -> +val extend_with_auto_hints : Auto.hint_db_name list -> t -> Proof_type.goal sigma -> t -val print_cmap: global_reference list CM.t -> unit +val print_cmap: global_reference list CM.t -> unit diff --git a/plugins/firstorder/unify.ml b/plugins/firstorder/unify.ml index 782129e5c9..e3a4c6a559 100644 --- a/plugins/firstorder/unify.ml +++ b/plugins/firstorder/unify.ml @@ -9,7 +9,7 @@ (*i $Id$ i*) open Util -open Formula +open Formula open Tacmach open Term open Names @@ -18,73 +18,73 @@ open Reductionops exception UFAIL of constr*constr -(* - RIGID-only Martelli-Montanari style unification for CLOSED terms - I repeat : t1 and t2 must NOT have ANY free deBruijn - sigma is kept normal with respect to itself but is lazily applied - to the equation set. Raises UFAIL with a pair of terms +(* + RIGID-only Martelli-Montanari style unification for CLOSED terms + I repeat : t1 and t2 must NOT have ANY free deBruijn + sigma is kept normal with respect to itself but is lazily applied + to the equation set. Raises UFAIL with a pair of terms *) -let unif t1 t2= - let bige=Queue.create () +let unif t1 t2= + let bige=Queue.create () and sigma=ref [] in let bind i t= sigma:=(i,t):: (List.map (function (n,tn)->(n,subst_meta [i,t] tn)) !sigma) in - let rec head_reduce t= + let rec head_reduce t= (* forbids non-sigma-normal meta in head position*) match kind_of_term t with Meta i-> - (try - head_reduce (List.assoc i !sigma) + (try + head_reduce (List.assoc i !sigma) with Not_found->t) - | _->t in + | _->t in Queue.add (t1,t2) bige; try while true do let t1,t2=Queue.take bige in - let nt1=head_reduce (whd_betaiotazeta Evd.empty t1) + let nt1=head_reduce (whd_betaiotazeta Evd.empty t1) and nt2=head_reduce (whd_betaiotazeta Evd.empty t2) in match (kind_of_term nt1),(kind_of_term nt2) with - Meta i,Meta j-> - if i<>j then + Meta i,Meta j-> + if i<>j then if i<j then bind j nt1 else bind i nt2 | Meta i,_ -> let t=subst_meta !sigma nt2 in - if Intset.is_empty (free_rels t) && + if Intset.is_empty (free_rels t) && not (occur_term (mkMeta i) t) then bind i t else raise (UFAIL(nt1,nt2)) - | _,Meta i -> + | _,Meta i -> let t=subst_meta !sigma nt1 in - if Intset.is_empty (free_rels t) && + if Intset.is_empty (free_rels t) && not (occur_term (mkMeta i) t) then bind i t else raise (UFAIL(nt1,nt2)) | Cast(_,_,_),_->Queue.add (strip_outer_cast nt1,nt2) bige - | _,Cast(_,_,_)->Queue.add (nt1,strip_outer_cast nt2) bige + | _,Cast(_,_,_)->Queue.add (nt1,strip_outer_cast nt2) bige | (Prod(_,a,b),Prod(_,c,d))|(Lambda(_,a,b),Lambda(_,c,d))-> Queue.add (a,c) bige;Queue.add (pop b,pop d) bige | Case (_,pa,ca,va),Case (_,pb,cb,vb)-> Queue.add (pa,pb) bige; Queue.add (ca,cb) bige; let l=Array.length va in - if l<>(Array.length vb) then + if l<>(Array.length vb) then raise (UFAIL (nt1,nt2)) - else + else for i=0 to l-1 do Queue.add (va.(i),vb.(i)) bige - done + done | App(ha,va),App(hb,vb)-> Queue.add (ha,hb) bige; let l=Array.length va in - if l<>(Array.length vb) then + if l<>(Array.length vb) then raise (UFAIL (nt1,nt2)) - else + else for i=0 to l-1 do Queue.add (va.(i),vb.(i)) bige done | _->if not (eq_constr nt1 nt2) then raise (UFAIL (nt1,nt2)) done; - assert false + assert false (* this place is unreachable but needed for the sake of typing *) with Queue.Empty-> !sigma @@ -93,23 +93,23 @@ let value i t= if x<0 then y else if y<0 then x else x+y in let tref=mkMeta i in let rec vaux term= - if term=tref then 0 else + if term=tref then 0 else let f v t=add v (vaux t) in let vr=fold_constr f (-1) term in if vr<0 then -1 else vr+1 in vaux t - + type instance= - Real of (int*constr)*int - | Phantom of constr + Real of (int*constr)*int + | Phantom of constr let mk_rel_inst t= let new_rel=ref 1 in let rel_env=ref [] in let rec renum_rec d t= - match kind_of_term t with + match kind_of_term t with Meta n-> - (try + (try mkRel (d+(List.assoc n !rel_env)) with Not_found-> let m= !new_rel in @@ -117,18 +117,18 @@ let mk_rel_inst t= rel_env:=(n,m) :: !rel_env; mkRel (m+d)) | _ -> map_constr_with_binders succ renum_rec d t - in + in let nt=renum_rec 0 t in (!new_rel - 1,nt) let unif_atoms i dom t1 t2= - try - let t=List.assoc i (unif t1 t2) in + try + let t=List.assoc i (unif t1 t2) in if isMeta t then Some (Phantom dom) else Some (Real(mk_rel_inst t,value i t1)) with UFAIL(_,_) ->None | Not_found ->Some (Phantom dom) - + let renum_metas_from k n t= (* requires n = max (free_rels t) *) let l=list_tabulate (fun i->mkMeta (k+i)) n in substl l t @@ -136,7 +136,7 @@ let renum_metas_from k n t= (* requires n = max (free_rels t) *) let more_general (m1,t1) (m2,t2)= let mt1=renum_metas_from 0 m1 t1 and mt2=renum_metas_from m1 m2 t2 in - try + try let sigma=unif mt1 mt2 in let p (n,t)= n<m1 || isMeta t in List.for_all p sigma diff --git a/plugins/fourier/Fourier_util.v b/plugins/fourier/Fourier_util.v index c592af09a3..0fd92d6064 100644 --- a/plugins/fourier/Fourier_util.v +++ b/plugins/fourier/Fourier_util.v @@ -12,17 +12,17 @@ Require Export Rbase. Comments "Lemmas used by the tactic Fourier". Open Scope R_scope. - + Lemma Rfourier_lt : forall x1 y1 a:R, x1 < y1 -> 0 < a -> a * x1 < a * y1. intros; apply Rmult_lt_compat_l; assumption. Qed. - + Lemma Rfourier_le : forall x1 y1 a:R, x1 <= y1 -> 0 < a -> a * x1 <= a * y1. red in |- *. intros. case H; auto with real. Qed. - + Lemma Rfourier_lt_lt : forall x1 y1 x2 y2 a:R, x1 < y1 -> x2 < y2 -> 0 < a -> x1 + a * x2 < y1 + a * y2. @@ -33,7 +33,7 @@ apply Rfourier_lt. try exact H0. try exact H1. Qed. - + Lemma Rfourier_lt_le : forall x1 y1 x2 y2 a:R, x1 < y1 -> x2 <= y2 -> 0 < a -> x1 + a * x2 < y1 + a * y2. @@ -48,7 +48,7 @@ rewrite (Rplus_comm x1 (a * y2)). apply Rplus_lt_compat_l. try exact H. Qed. - + Lemma Rfourier_le_lt : forall x1 y1 x2 y2 a:R, x1 <= y1 -> x2 < y2 -> 0 < a -> x1 + a * x2 < y1 + a * y2. @@ -59,7 +59,7 @@ rewrite H2. apply Rplus_lt_compat_l. apply Rfourier_lt; auto with real. Qed. - + Lemma Rfourier_le_le : forall x1 y1 x2 y2 a:R, x1 <= y1 -> x2 <= y2 -> 0 < a -> x1 + a * x2 <= y1 + a * y2. @@ -81,25 +81,25 @@ red in |- *. right; try assumption. auto with real. Qed. - + Lemma Rlt_zero_pos_plus1 : forall x:R, 0 < x -> 0 < 1 + x. intros x H; try assumption. rewrite Rplus_comm. apply Rle_lt_0_plus_1. red in |- *; auto with real. Qed. - + Lemma Rlt_mult_inv_pos : forall x y:R, 0 < x -> 0 < y -> 0 < x * / y. intros x y H H0; try assumption. replace 0 with (x * 0). apply Rmult_lt_compat_l; auto with real. ring. Qed. - + Lemma Rlt_zero_1 : 0 < 1. exact Rlt_0_1. Qed. - + Lemma Rle_zero_pos_plus1 : forall x:R, 0 <= x -> 0 <= 1 + x. intros x H; try assumption. case H; intros. @@ -112,7 +112,7 @@ red in |- *; left. exact Rlt_zero_1. ring. Qed. - + Lemma Rle_mult_inv_pos : forall x y:R, 0 <= x -> 0 < y -> 0 <= x * / y. intros x y H H0; try assumption. case H; intros. @@ -121,12 +121,12 @@ apply Rlt_mult_inv_pos; auto with real. rewrite <- H1. red in |- *; right; ring. Qed. - + Lemma Rle_zero_1 : 0 <= 1. red in |- *; left. exact Rlt_zero_1. Qed. - + Lemma Rle_not_lt : forall n d:R, 0 <= n * / d -> ~ 0 < - n * / d. intros n d H; red in |- *; intros H0; try exact H0. generalize (Rgt_not_le 0 (n * / d)). @@ -144,14 +144,14 @@ ring. ring. ring. Qed. - + Lemma Rnot_lt0 : forall x:R, ~ 0 < 0 * x. intros x; try assumption. replace (0 * x) with 0. apply Rlt_irrefl. ring. Qed. - + 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. @@ -162,7 +162,7 @@ try exact H. ring. ring. Qed. - + Lemma Rnot_lt_lt : forall x y:R, ~ 0 < y - x -> ~ x < y. unfold not in |- *; intros. apply H. @@ -173,7 +173,7 @@ try exact H0. ring. ring. Qed. - + Lemma Rnot_le_le : forall x y:R, ~ 0 <= y - x -> ~ x <= y. unfold not in |- *; intros. apply H. @@ -188,35 +188,35 @@ ring. right. rewrite H1; ring. Qed. - + Lemma Rfourier_gt_to_lt : forall x y:R, y > x -> x < y. unfold Rgt in |- *; intros; assumption. Qed. - + Lemma Rfourier_ge_to_le : forall x y:R, y >= x -> x <= y. intros x y; exact (Rge_le y x). Qed. - + Lemma Rfourier_eqLR_to_le : forall x y:R, x = y -> x <= y. exact Req_le. Qed. - + Lemma Rfourier_eqRL_to_le : forall x y:R, y = x -> x <= y. exact Req_le_sym. Qed. - + Lemma Rfourier_not_ge_lt : forall x y:R, (x >= y -> False) -> x < y. exact Rnot_ge_lt. Qed. - + Lemma Rfourier_not_gt_le : forall x y:R, (x > y -> False) -> x <= y. exact Rnot_gt_le. Qed. - + Lemma Rfourier_not_le_gt : forall x y:R, (x <= y -> False) -> x > y. exact Rnot_le_lt. Qed. - + Lemma Rfourier_not_lt_ge : forall x y:R, (x < y -> False) -> x >= y. exact Rnot_lt_ge. Qed. diff --git a/plugins/fourier/fourier.ml b/plugins/fourier/fourier.ml index dd54aea29a..73fb49295a 100644 --- a/plugins/fourier/fourier.ml +++ b/plugins/fourier/fourier.ml @@ -11,17 +11,17 @@ (* Méthode d'élimination de Fourier *) (* Référence: Auteur(s) : Fourier, Jean-Baptiste-Joseph - + Titre(s) : Oeuvres de Fourier [Document électronique]. Tome second. Mémoires publiés dans divers recueils / publ. par les soins de M. Gaston Darboux,... - + Publication : Numérisation BnF de l'édition de Paris : Gauthier-Villars, 1890 - + Pages: 326-327 http://gallica.bnf.fr/ *) -(* Un peu de calcul sur les rationnels... +(* Un peu de calcul sur les rationnels... Les opérations rendent des rationnels normalisés, i.e. le numérateur et le dénominateur sont premiers entre eux. *) @@ -45,7 +45,7 @@ let rnorm x = let x = (if x.den<0 then {num=(-x.num);den=(-x.den)} else x) in else (let d=pgcd x.num x.den in let d= (if d<0 then -d else d) in {num=(x.num)/d;den=(x.den)/d});; - + let rop x = rnorm {num=(-x.num);den=x.den};; let rplus x y = rnorm {num=x.num*y.den + y.num*x.den;den=x.den*y.den};; @@ -72,7 +72,7 @@ type ineq = {coef:rational list; let pop x l = l:=x::(!l);; -(* sépare la liste d'inéquations s selon que leur premier coefficient est +(* sépare la liste d'inéquations s selon que leur premier coefficient est négatif, nul ou positif. *) let partitionne s = let lpos=ref [] in @@ -98,7 +98,7 @@ let partitionne s = let add_hist le = let n = List.length le in let i=ref 0 in - List.map (fun (ie,s) -> + List.map (fun (ie,s) -> let h =ref [] in for k=1 to (n-(!i)-1) do pop r0 h; done; pop r1 h; @@ -107,7 +107,7 @@ let add_hist le = {coef=ie;hist=(!h);strict=s}) le ;; -(* additionne deux inéquations *) +(* additionne deux inéquations *) let ie_add ie1 ie2 = {coef=List.map2 rplus ie1.coef ie2.coef; hist=List.map2 rplus ie1.hist ie2.hist; strict=ie1.strict || ie2.strict} @@ -142,7 +142,7 @@ let deduce_add lneg lpos = opération qu'on itère dans l'algorithme de Fourier. *) let deduce1 s = - match (partitionne s) with + match (partitionne s) with [lneg;lnul;lpos] -> let lnew = deduce_add lneg lpos in (List.map ie_tl lnul)@lnew @@ -172,7 +172,7 @@ let unsolvable lie = (try (List.iter (fun e -> match e with {coef=[c];hist=lc;strict=s} -> - if (rinf c r0 && (not s)) || (rinfeq c r0 && s) + if (rinf c r0 && (not s)) || (rinfeq c r0 && s) then (res := [c,s,lc]; raise (Failure "contradiction found")) |_->assert false) diff --git a/plugins/fourier/fourierR.ml b/plugins/fourier/fourierR.ml index 9082677008..3f490babd7 100644 --- a/plugins/fourier/fourierR.ml +++ b/plugins/fourier/fourierR.ml @@ -10,7 +10,7 @@ -(* La tactique Fourier ne fonctionne de manière sûre que si les coefficients +(* La tactique Fourier ne fonctionne de manière sûre que si les coefficients des inéquations et équations sont entiers. En attendant la tactique Field. *) @@ -26,9 +26,9 @@ open Contradiction (****************************************************************************** Opérations sur les combinaisons linéaires affines. -La partie homogène d'une combinaison linéaire est en fait une table de hash -qui donne le coefficient d'un terme du calcul des constructions, -qui est zéro si le terme n'y est pas. +La partie homogène d'une combinaison linéaire est en fait une table de hash +qui donne le coefficient d'un terme du calcul des constructions, +qui est zéro si le terme n'y est pas. *) type flin = {fhom:(constr , rational)Hashtbl.t; @@ -38,27 +38,27 @@ let flin_zero () = {fhom=Hashtbl.create 50;fcste=r0};; let flin_coef f x = try (Hashtbl.find f.fhom x) with _-> r0;; -let flin_add f x c = +let flin_add f x c = let cx = flin_coef f x in Hashtbl.remove f.fhom x; Hashtbl.add f.fhom x (rplus cx c); f ;; -let flin_add_cste f c = +let flin_add_cste f c = {fhom=f.fhom; fcste=rplus f.fcste c} ;; let flin_one () = flin_add_cste (flin_zero()) r1;; -let flin_plus f1 f2 = +let flin_plus f1 f2 = let f3 = flin_zero() in Hashtbl.iter (fun x c -> let _=flin_add f3 x c in ()) f1.fhom; Hashtbl.iter (fun x c -> let _=flin_add f3 x c in ()) f2.fhom; flin_add_cste (flin_add_cste f3 f1.fcste) f2.fcste; ;; -let flin_minus f1 f2 = +let flin_minus f1 f2 = let f3 = flin_zero() in Hashtbl.iter (fun x c -> let _=flin_add f3 x c in ()) f1.fhom; Hashtbl.iter (fun x c -> let _=flin_add f3 x (rop c) in ()) f2.fhom; @@ -69,17 +69,17 @@ let flin_emult a f = Hashtbl.iter (fun x c -> let _=flin_add f2 x (rmult a c) in ()) f.fhom; flin_add_cste f2 (rmult a f.fcste); ;; - + (*****************************************************************************) open Vernacexpr type ineq = Rlt | Rle | Rgt | Rge -let string_of_R_constant kn = +let string_of_R_constant kn = match Names.repr_con kn with - | MPfile dir, sec_dir, id when - sec_dir = empty_dirpath && - string_of_dirpath dir = "Coq.Reals.Rdefinitions" + | MPfile dir, sec_dir, id when + sec_dir = empty_dirpath && + string_of_dirpath dir = "Coq.Reals.Rdefinitions" -> string_of_label id | _ -> "constant_not_of_R" @@ -94,20 +94,20 @@ let rec rational_of_constr c = | Cast (c,_,_) -> (rational_of_constr c) | App (c,args) -> (match (string_of_R_constr c) with - | "Ropp" -> + | "Ropp" -> rop (rational_of_constr args.(0)) - | "Rinv" -> + | "Rinv" -> rinv (rational_of_constr args.(0)) - | "Rmult" -> + | "Rmult" -> rmult (rational_of_constr args.(0)) (rational_of_constr args.(1)) - | "Rdiv" -> + | "Rdiv" -> rdiv (rational_of_constr args.(0)) (rational_of_constr args.(1)) - | "Rplus" -> + | "Rplus" -> rplus (rational_of_constr args.(0)) (rational_of_constr args.(1)) - | "Rminus" -> + | "Rminus" -> rminus (rational_of_constr args.(0)) (rational_of_constr args.(1)) | _ -> failwith "not a rational") @@ -125,9 +125,9 @@ let rec flin_of_constr c = | Cast (c,_,_) -> (flin_of_constr c) | App (c,args) -> (match (string_of_R_constr c) with - "Ropp" -> + "Ropp" -> flin_emult (rop r1) (flin_of_constr args.(0)) - | "Rplus"-> + | "Rplus"-> flin_plus (flin_of_constr args.(0)) (flin_of_constr args.(1)) | "Rminus"-> @@ -138,10 +138,10 @@ let rec flin_of_constr c = try (let b = (rational_of_constr args.(1)) in (flin_add_cste (flin_zero()) (rmult a b))) with _-> (flin_add (flin_zero()) - args.(1) + args.(1) a)) with _-> (flin_add (flin_zero()) - args.(0) + args.(0) (rational_of_constr args.(1)))) | "Rinv"-> let a=(rational_of_constr args.(0)) in @@ -151,7 +151,7 @@ let rec flin_of_constr c = try (let a = (rational_of_constr args.(0)) in (flin_add_cste (flin_zero()) (rdiv a b))) with _-> (flin_add (flin_zero()) - args.(0) + args.(0) (rinv b))) |_->assert false) | Const c -> @@ -254,19 +254,19 @@ let ineq1_of_constr (h,t) = (* Applique la méthode de Fourier à une liste d'hypothèses (type hineq) *) -let fourier_lineq lineq1 = +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 _ -> if not (Hashtbl.mem hvar x) then begin - nvar:=(!nvar)+1; + 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 - Hashtbl.iter (fun x c -> v.(Hashtbl.find hvar x)<-c) + Hashtbl.iter (fun x c -> v.(Hashtbl.find hvar x)<-c) h.hflin.fhom; ((Array.to_list v)@[rop h.hflin.fcste],h.hstrict)) lineq1 in @@ -346,7 +346,7 @@ let is_int x = (x.den)=1 (* fraction = couple (num,den) *) let rec rational_to_fraction x= (x.num,x.den) ;; - + (* traduction -3 -> (Ropp (Rplus R1 (Rplus R1 R1))) *) let int_to_real n = @@ -371,7 +371,7 @@ let rational_to_real x = let tac_zero_inf_pos gl (n,d) = let tacn=ref (apply (get coq_Rlt_zero_1)) in let tacd=ref (apply (get coq_Rlt_zero_1)) in - for i=1 to n-1 do + for i=1 to n-1 do tacn:=(tclTHEN (apply (get coq_Rlt_zero_pos_plus1)) !tacn); done; for i=1 to d-1 do tacd:=(tclTHEN (apply (get coq_Rlt_zero_pos_plus1)) !tacd); done; @@ -381,18 +381,18 @@ let tac_zero_inf_pos gl (n,d) = (* preuve que 0<=n*1/d *) let tac_zero_infeq_pos gl (n,d)= - let tacn=ref (if n=0 + let tacn=ref (if n=0 then (apply (get coq_Rle_zero_zero)) else (apply (get coq_Rle_zero_1))) in let tacd=ref (apply (get coq_Rlt_zero_1)) in - for i=1 to n-1 do + for i=1 to n-1 do tacn:=(tclTHEN (apply (get coq_Rle_zero_pos_plus1)) !tacn); done; for i=1 to d-1 do tacd:=(tclTHEN (apply (get coq_Rlt_zero_pos_plus1)) !tacd); done; (tclTHENS (apply (get coq_Rle_mult_inv_pos)) [!tacn;!tacd]) ;; - -(* preuve que 0<(-n)*(1/d) => False + +(* preuve que 0<(-n)*(1/d) => False *) let tac_zero_inf_false gl (n,d) = if n=0 then (apply (get coq_Rnot_lt0)) @@ -401,7 +401,7 @@ let tac_zero_inf_false gl (n,d) = (tac_zero_infeq_pos gl (-n,d))) ;; -(* preuve que 0<=(-n)*(1/d) => False +(* preuve que 0<=(-n)*(1/d) => False *) let tac_zero_infeq_false gl (n,d) = (tclTHEN (apply (get coq_Rlt_not_le_frac_opp)) @@ -409,7 +409,7 @@ let tac_zero_infeq_false gl (n,d) = ;; let create_meta () = mkMeta(Evarutil.new_meta());; - + let my_cut c gl= let concl = pf_concl gl in apply_type (mkProd(Anonymous,c,concl)) [create_meta()] gl @@ -467,22 +467,22 @@ let rec fourier gl= match (kind_of_term goal) with App (f,args) -> (match (string_of_R_constr f) with - "Rlt" -> + "Rlt" -> (tclTHEN (tclTHEN (apply (get coq_Rfourier_not_ge_lt)) (intro_using fhyp)) fourier) - |"Rle" -> + |"Rle" -> (tclTHEN (tclTHEN (apply (get coq_Rfourier_not_gt_le)) (intro_using fhyp)) fourier) - |"Rgt" -> + |"Rgt" -> (tclTHEN (tclTHEN (apply (get coq_Rfourier_not_le_gt)) (intro_using fhyp)) fourier) - |"Rge" -> + |"Rge" -> (tclTHEN (tclTHEN (apply (get coq_Rfourier_not_lt_ge)) (intro_using fhyp)) @@ -490,7 +490,7 @@ let rec fourier gl= |_->assert false) |_->assert false in tac gl) - with _ -> + with _ -> (* les hypothèses *) let hyps = List.map (fun (h,t)-> (mkVar h,t)) (list_of_sign (pf_hyps gl)) in @@ -511,12 +511,12 @@ let rec fourier gl= qui donnent 0<cres ou 0<=cres selon sres *) (*print_string "Fourier's method can prove the goal...";flush stdout;*) let lutil=ref [] in - List.iter + List.iter (fun (h,c) -> if c<>r0 then (lutil:=(h,c)::(!lutil)(*; print_rational(c);print_string " "*))) - (List.combine (!lineq) lc); + (List.combine (!lineq) lc); (* on construit la combinaison linéaire des inéquation *) (match (!lutil) with (h1,c1)::lutil -> @@ -545,7 +545,7 @@ let rec fourier gl= !t2 |] in let tc=rational_to_real cres in (* puis sa preuve *) - let tac1=ref (if h1.hstrict + let tac1=ref (if h1.hstrict then (tclTHENS (apply (get coq_Rfourier_lt)) [tac_use h1; tac_zero_inf_pos gl @@ -555,24 +555,24 @@ let rec fourier gl= tac_zero_inf_pos gl (rational_to_fraction c1)])) in s:=h1.hstrict; - List.iter (fun (h,c)-> + List.iter (fun (h,c)-> (if (!s) then (if h.hstrict then tac1:=(tclTHENS (apply (get coq_Rfourier_lt_lt)) - [!tac1;tac_use h; + [!tac1;tac_use h; tac_zero_inf_pos gl (rational_to_fraction c)]) else tac1:=(tclTHENS (apply (get coq_Rfourier_lt_le)) - [!tac1;tac_use h; + [!tac1;tac_use h; tac_zero_inf_pos gl (rational_to_fraction c)])) else (if h.hstrict then tac1:=(tclTHENS (apply (get coq_Rfourier_le_lt)) - [!tac1;tac_use h; + [!tac1;tac_use h; tac_zero_inf_pos gl (rational_to_fraction c)]) else tac1:=(tclTHENS (apply (get coq_Rfourier_le_le)) - [!tac1;tac_use h; + [!tac1;tac_use h; tac_zero_inf_pos gl (rational_to_fraction c)]))); s:=(!s)||(h.hstrict)) @@ -581,7 +581,7 @@ let rec fourier gl= then tac_zero_inf_false gl (rational_to_fraction cres) else tac_zero_infeq_false gl (rational_to_fraction cres) in - tac:=(tclTHENS (my_cut ineq) + tac:=(tclTHENS (my_cut ineq) [tclTHEN (change_in_concl None (mkAppL [| get coq_not; ineq|] )) @@ -594,17 +594,17 @@ let rec fourier gl= [tac2; (tclTHENS (Equality.replace - (mkApp (get coq_Rinv, + (mkApp (get coq_Rinv, [|get coq_R1|])) (get coq_R1)) -(* en attendant Field, ça peut aider Ring de remplacer 1/1 par 1 ... *) +(* en attendant Field, ça peut aider Ring de remplacer 1/1 par 1 ... *) [tclORELSE (Ring.polynom []) tclIDTAC; (tclTHEN (apply (get coq_sym_eqT)) (apply (get coq_Rinv_1)))] - + ) ])); !tac1]); @@ -614,7 +614,7 @@ let rec fourier gl= |_-> assert false) |_-> assert false ); (* ((tclTHEN !tac (tclFAIL 1 (* 1 au hasard... *))) gl) *) - (!tac gl) + (!tac gl) (* ((tclABSTRACT None !tac) gl) *) ;; diff --git a/plugins/funind/Recdef.v b/plugins/funind/Recdef.v index 2d206220e4..00302a741d 100644 --- a/plugins/funind/Recdef.v +++ b/plugins/funind/Recdef.v @@ -20,21 +20,21 @@ Fixpoint iter (n : nat) : (A -> A) -> A -> A := End Iter. Theorem SSplus_lt : forall p p' : nat, p < S (S (p + p')). - intro p; intro p'; change (S p <= S (S (p + p'))); - apply le_S; apply Gt.gt_le_S; change (p < S (p + p')); + intro p; intro p'; change (S p <= S (S (p + p'))); + apply le_S; apply Gt.gt_le_S; change (p < S (p + p')); apply Lt.le_lt_n_Sm; apply Plus.le_plus_l. Qed. - + Theorem Splus_lt : forall p p' : nat, p' < S (p + p'). - intro p; intro p'; change (S p' <= S (p + p')); + intro p; intro p'; change (S p' <= S (p + p')); apply Gt.gt_le_S; change (p' < S (p + p')); apply Lt.le_lt_n_Sm; apply Plus.le_plus_r. Qed. Theorem le_lt_SS : forall x y, x <= y -> x < S (S y). -intro x; intro y; intro H; change (S x <= S (S y)); - apply le_S; apply Gt.gt_le_S; change (x < S y); +intro x; intro y; intro H; change (S x <= S (S y)); + apply le_S; apply Gt.gt_le_S; change (x < S y); apply Lt.le_lt_n_Sm; exact H. Qed. diff --git a/plugins/funind/functional_principles_proofs.ml b/plugins/funind/functional_principles_proofs.ml index 9087f51798..90eb499422 100644 --- a/plugins/funind/functional_principles_proofs.ml +++ b/plugins/funind/functional_principles_proofs.ml @@ -1,8 +1,8 @@ open Printer open Util open Term -open Termops -open Names +open Termops +open Names open Declarations open Pp open Entries @@ -16,7 +16,7 @@ open Indfun_common open Libnames let msgnl = Pp.msgnl - + let observe strm = if do_observe () @@ -35,11 +35,11 @@ let do_observe_tac s tac g = try let v = tac g in (* msgnl (goal ++ fnl () ++ (str 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 ); + msgnl (str "observation "++ s++str " raised exception " ++ + Cerrors.explain_exn e ++ str " on goal " ++ goal ); raise e;; -let observe_tac_stream s tac g = +let observe_tac_stream s tac g = if do_observe () then do_observe_tac s tac g else tac g @@ -52,54 +52,54 @@ let observe_tac s tac g = observe_tac_stream (str s) tac g (* else tac *) -let list_chop ?(msg="") n l = - try - list_chop n l - with Failure (msg') -> +let list_chop ?(msg="") n l = + try + list_chop n l + with Failure (msg') -> failwith (msg ^ msg') - + let make_refl_eq constructor type_of_t t = (* let refl_equal_term = Lazy.force refl_equal in *) mkApp(constructor,[|type_of_t;t|]) -type pte_info = - { +type pte_info = + { proving_tac : (identifier list -> Tacmach.tactic); is_valid : constr -> bool } type ptes_info = pte_info Idmap.t -type 'a dynamic_info = - { +type 'a dynamic_info = + { nb_rec_hyps : int; - rec_hyps : identifier list ; + rec_hyps : identifier list ; eq_hyps : identifier list; info : 'a } -type body_info = constr dynamic_info - +type body_info = constr dynamic_info + -let finish_proof dynamic_infos g = - observe_tac "finish" +let finish_proof dynamic_infos g = + observe_tac "finish" ( h_assumption) g - -let refine c = + +let refine c = Tacmach.refine_no_check c -let thin l = +let thin l = Tacmach.thin_no_check l - -let cut_replacing id t tac :tactic= + +let cut_replacing id t tac :tactic= tclTHENS (cut t) [ tclTHEN (thin_no_check [id]) (introduction_no_check id); - tac + tac ] let intro_erasing id = tclTHEN (thin [id]) (introduction id) @@ -108,54 +108,54 @@ let intro_erasing id = tclTHEN (thin [id]) (introduction id) let rec_hyp_id = id_of_string "rec_hyp" -let is_trivial_eq t = - let res = try +let is_trivial_eq t = + let res = try begin - match kind_of_term t with - | App(f,[|_;t1;t2|]) when eq_constr f (Lazy.force eq) -> + match kind_of_term t with + | App(f,[|_;t1;t2|]) when eq_constr f (Lazy.force eq) -> eq_constr t1 t2 | App(f,[|t1;a1;t2;a2|]) when eq_constr f (jmeq ()) -> eq_constr t1 t2 && eq_constr a1 a2 - | _ -> false + | _ -> false end with _ -> false in (* observe (str "is_trivial_eq " ++ Printer.pr_lconstr t ++ (if res then str " true" else str " false")); *) res -let rec incompatible_constructor_terms t1 t2 = - let c1,arg1 = decompose_app t1 - and c2,arg2 = decompose_app t2 - in +let rec incompatible_constructor_terms t1 t2 = + let c1,arg1 = decompose_app t1 + and c2,arg2 = decompose_app t2 + in (not (eq_constr t1 t2)) && - isConstruct c1 && isConstruct c2 && + isConstruct c1 && isConstruct c2 && ( - not (eq_constr c1 c2) || + not (eq_constr c1 c2) || List.exists2 incompatible_constructor_terms arg1 arg2 ) -let is_incompatible_eq t = +let is_incompatible_eq t = let res = try - match kind_of_term t with - | App(f,[|_;t1;t2|]) when eq_constr f (Lazy.force eq) -> + match kind_of_term t with + | App(f,[|_;t1;t2|]) when eq_constr f (Lazy.force eq) -> incompatible_constructor_terms t1 t2 - | App(f,[|u1;t1;u2;t2|]) when eq_constr f (jmeq ()) -> + | App(f,[|u1;t1;u2;t2|]) when eq_constr f (jmeq ()) -> (eq_constr u1 u2 && incompatible_constructor_terms t1 t2) - | _ -> false + | _ -> false with _ -> false - in + in if res then observe (str "is_incompatible_eq " ++ Printer.pr_lconstr t); res -let change_hyp_with_using msg hyp_id t tac : tactic = - fun g -> - let prov_id = pf_get_new_id hyp_id g in +let change_hyp_with_using msg hyp_id t tac : tactic = + fun g -> + let prov_id = pf_get_new_id hyp_id g in tclTHENS ((* observe_tac msg *) (assert_by (Name prov_id) t (tclCOMPLETE tac))) - [tclTHENLIST - [ + [tclTHENLIST + [ (* observe_tac "change_hyp_with_using thin" *) (thin [hyp_id]); (* observe_tac "change_hyp_with_using rename " *) (h_rename [prov_id,hyp_id]) ]] g @@ -163,20 +163,20 @@ let change_hyp_with_using msg hyp_id t tac : tactic = exception TOREMOVE -let prove_trivial_eq h_id context (constructor,type_of_term,term) = - let nb_intros = List.length context in +let prove_trivial_eq h_id context (constructor,type_of_term,term) = + let nb_intros = List.length context in tclTHENLIST [ tclDO nb_intros intro; (* introducing context *) - (fun g -> - let context_hyps = - fst (list_chop ~msg:"prove_trivial_eq : " nb_intros (pf_ids_of_hyps g)) + (fun g -> + let context_hyps = + fst (list_chop ~msg:"prove_trivial_eq : " nb_intros (pf_ids_of_hyps g)) in - let context_hyps' = + let context_hyps' = (mkApp(constructor,[|type_of_term;term|])):: (List.map mkVar context_hyps) in - let to_refine = applist(mkVar h_id,List.rev context_hyps') in + let to_refine = applist(mkVar h_id,List.rev context_hyps') in refine to_refine g ) ] @@ -191,124 +191,124 @@ let find_rectype env c = | _ -> raise Not_found -let isAppConstruct ?(env=Global.env ()) t = - try - let t',l = find_rectype (Global.env ()) t in +let isAppConstruct ?(env=Global.env ()) t = + try + let t',l = find_rectype (Global.env ()) t in observe (str "isAppConstruct : " ++ Printer.pr_lconstr t ++ str " -> " ++ Printer.pr_lconstr (applist (t',l))); true - with Not_found -> false + with Not_found -> false let nf_betaiotazeta = (* Reductionops.local_strong Reductionops.whd_betaiotazeta *) let clos_norm_flags flgs env sigma t = Closure.norm_val (Closure.create_clos_infos flgs env) (Closure.inject (Reductionops.nf_evar sigma t)) in clos_norm_flags Closure.betaiotazeta Environ.empty_env Evd.empty - -let change_eq env sigma hyp_id (context:rel_context) x t end_of_type = - let nochange ?t' msg = - begin + +let change_eq env sigma hyp_id (context:rel_context) x t end_of_type = + let nochange ?t' msg = + begin observe (str ("Not treating ( "^msg^" )") ++ pr_lconstr t ++ str " " ++ match t' with None -> str "" | Some t -> Printer.pr_lconstr t ); - failwith "NoChange"; + failwith "NoChange"; end - in - let eq_constr = Reductionops.is_conv env sigma in + in + let eq_constr = Reductionops.is_conv env sigma in if not (noccurn 1 end_of_type) then nochange "dependent"; (* if end_of_type depends on this term we don't touch it *) if not (isApp t) then nochange "not an equality"; let f_eq,args = destApp t in - let constructor,t1,t2,t1_typ = - try - if (eq_constr f_eq (Lazy.force eq)) - then + let constructor,t1,t2,t1_typ = + try + if (eq_constr f_eq (Lazy.force eq)) + then let t1 = (args.(1),args.(0)) - and t2 = (args.(2),args.(0)) + and t2 = (args.(2),args.(0)) and t1_typ = args.(0) in (Lazy.force refl_equal,t1,t2,t1_typ) else - if (eq_constr f_eq (jmeq ())) - then + if (eq_constr f_eq (jmeq ())) + then (jmeq_refl (),(args.(1),args.(0)),(args.(3),args.(2)),args.(0)) else nochange "not an equality" with _ -> nochange "not an equality" - in - if not ((closed0 (fst t1)) && (closed0 (snd t1)))then nochange "not a closed lhs"; - let rec compute_substitution sub t1 t2 = + in + if not ((closed0 (fst t1)) && (closed0 (snd t1)))then nochange "not a closed lhs"; + let rec compute_substitution sub t1 t2 = (* observe (str "compute_substitution : " ++ pr_lconstr t1 ++ str " === " ++ pr_lconstr t2); *) - if isRel t2 - then - let t2 = destRel t2 in - begin - try - let t1' = Intmap.find t2 sub in + if isRel t2 + then + let t2 = destRel t2 in + begin + try + let t1' = Intmap.find t2 sub in if not (eq_constr t1 t1') then nochange "twice bound variable"; sub - with Not_found -> + with Not_found -> assert (closed0 t1); Intmap.add t2 t1 sub end - else if isAppConstruct t1 && isAppConstruct t2 - then + else if isAppConstruct t1 && isAppConstruct t2 + then begin let c1,args1 = find_rectype env t1 and c2,args2 = find_rectype env t2 - in + in if not (eq_constr c1 c2) then nochange "cannot solve (diff)"; List.fold_left2 compute_substitution sub args1 args2 end - else + else if (eq_constr t1 t2) then sub else nochange ~t':(make_refl_eq constructor (Reduction.whd_betadeltaiota env t1) t2) "cannot solve (diff)" in - let sub = compute_substitution Intmap.empty (snd t1) (snd t2) in + let sub = compute_substitution Intmap.empty (snd t1) (snd t2) in let sub = compute_substitution sub (fst t1) (fst t2) in - let end_of_type_with_pop = pop end_of_type in (*the equation will be removed *) - let new_end_of_type = - (* Ugly hack to prevent Map.fold order change between ocaml-3.08.3 and ocaml-3.08.4 + let end_of_type_with_pop = pop end_of_type in (*the equation will be removed *) + let new_end_of_type = + (* Ugly hack to prevent Map.fold order change between ocaml-3.08.3 and ocaml-3.08.4 Can be safely replaced by the next comment for Ocaml >= 3.08.4 *) - let sub' = Intmap.fold (fun i t acc -> (i,t)::acc) sub [] in - let sub'' = List.sort (fun (x,_) (y,_) -> Pervasives.compare x y) sub' in + let sub' = Intmap.fold (fun i t acc -> (i,t)::acc) sub [] in + let sub'' = List.sort (fun (x,_) (y,_) -> Pervasives.compare x y) sub' in List.fold_left (fun end_of_type (i,t) -> lift 1 (substnl [t] (i-1) end_of_type)) end_of_type_with_pop sub'' in let old_context_length = List.length context + 1 in - let witness_fun = + let witness_fun = mkLetIn(Anonymous,make_refl_eq constructor t1_typ (fst t1),t, mkApp(mkVar hyp_id,Array.init old_context_length (fun i -> mkRel (old_context_length - i))) ) in - let new_type_of_hyp,ctxt_size,witness_fun = - list_fold_left_i - (fun i (end_of_type,ctxt_size,witness_fun) ((x',b',t') as decl) -> - try - let witness = Intmap.find i sub in + let new_type_of_hyp,ctxt_size,witness_fun = + list_fold_left_i + (fun i (end_of_type,ctxt_size,witness_fun) ((x',b',t') as decl) -> + try + let witness = Intmap.find i sub in if b' <> None then anomaly "can not redefine a rel!"; (pop end_of_type,ctxt_size,mkLetIn(x',witness,t',witness_fun)) - with Not_found -> + with Not_found -> (mkProd_or_LetIn decl end_of_type, ctxt_size + 1, mkLambda_or_LetIn decl witness_fun) ) - 1 + 1 (new_end_of_type,0,witness_fun) context in let new_type_of_hyp = - Reductionops.nf_betaiota Evd.empty new_type_of_hyp in - let new_ctxt,new_end_of_type = - decompose_prod_n_assum ctxt_size new_type_of_hyp - in - let prove_new_hyp : tactic = + Reductionops.nf_betaiota Evd.empty new_type_of_hyp in + let new_ctxt,new_end_of_type = + decompose_prod_n_assum ctxt_size new_type_of_hyp + in + let prove_new_hyp : tactic = tclTHEN (tclDO ctxt_size intro) (fun g -> - let all_ids = pf_ids_of_hyps g in - let new_ids,_ = list_chop ctxt_size all_ids in - let to_refine = applist(witness_fun,List.rev_map mkVar new_ids) in + let all_ids = pf_ids_of_hyps g in + let new_ids,_ = list_chop ctxt_size all_ids in + let to_refine = applist(witness_fun,List.rev_map mkVar new_ids) in refine to_refine g ) in - let simpl_eq_tac = + let simpl_eq_tac = change_hyp_with_using "prove_pattern_simplification" hyp_id new_type_of_hyp prove_new_hyp in (* observe (str "In " ++ Ppconstr.pr_id hyp_id ++ *) @@ -328,51 +328,51 @@ let change_eq env sigma hyp_id (context:rel_context) x t end_of_type = new_ctxt,new_end_of_type,simpl_eq_tac -let is_property ptes_info t_x full_type_of_hyp = - if isApp t_x - then - let pte,args = destApp t_x in - if isVar pte && array_for_all closed0 args - then - try - let info = Idmap.find (destVar pte) ptes_info in - info.is_valid full_type_of_hyp - with Not_found -> false - else false - else false +let is_property ptes_info t_x full_type_of_hyp = + if isApp t_x + then + let pte,args = destApp t_x in + if isVar pte && array_for_all closed0 args + then + try + let info = Idmap.find (destVar pte) ptes_info in + info.is_valid full_type_of_hyp + with Not_found -> false + else false + else false -let isLetIn t = - match kind_of_term t with - | LetIn _ -> true - | _ -> false +let isLetIn t = + match kind_of_term t with + | LetIn _ -> true + | _ -> false -let h_reduce_with_zeta = - h_reduce +let h_reduce_with_zeta = + h_reduce (Rawterm.Cbv - {Rawterm.all_flags - with Rawterm.rDelta = false; + {Rawterm.all_flags + with Rawterm.rDelta = false; }) - + let rewrite_until_var arg_num eq_ids : tactic = - (* tests if the declares recursive argument is neither a Constructor nor - an applied Constructor since such a form for the recursive argument - will break the Guard when trying to save the Lemma. + (* tests if the declares recursive argument is neither a Constructor nor + an applied Constructor since such a form for the recursive argument + will break the Guard when trying to save the Lemma. *) - let test_var g = - let _,args = destApp (pf_concl g) in + let test_var g = + let _,args = destApp (pf_concl g) in not ((isConstruct args.(arg_num)) || isAppConstruct args.(arg_num)) in - let rec do_rewrite eq_ids g = - if test_var g + let rec do_rewrite eq_ids g = + if test_var g then tclIDTAC g else - match eq_ids with + match eq_ids with | [] -> anomaly "Cannot find a way to prove recursive property"; - | eq_id::eq_ids -> - tclTHEN + | eq_id::eq_ids -> + tclTHEN (tclTRY (Equality.rewriteRL (mkVar eq_id))) (do_rewrite eq_ids) g @@ -380,50 +380,50 @@ let rewrite_until_var arg_num eq_ids : tactic = do_rewrite eq_ids -let rec_pte_id = id_of_string "Hrec" -let clean_hyp_with_heq ptes_infos eq_hyps hyp_id env sigma = - let coq_False = Coqlib.build_coq_False () in - let coq_True = Coqlib.build_coq_True () in - let coq_I = Coqlib.build_coq_I () in - let rec scan_type context type_of_hyp : tactic = - if isLetIn type_of_hyp then +let rec_pte_id = id_of_string "Hrec" +let clean_hyp_with_heq ptes_infos eq_hyps hyp_id env sigma = + let coq_False = Coqlib.build_coq_False () in + let coq_True = Coqlib.build_coq_True () in + let coq_I = Coqlib.build_coq_I () in + let rec scan_type context type_of_hyp : tactic = + if isLetIn type_of_hyp then let real_type_of_hyp = it_mkProd_or_LetIn ~init:type_of_hyp context in - let reduced_type_of_hyp = nf_betaiotazeta real_type_of_hyp in + let reduced_type_of_hyp = nf_betaiotazeta real_type_of_hyp in (* length of context didn't change ? *) - let new_context,new_typ_of_hyp = + let new_context,new_typ_of_hyp = decompose_prod_n_assum (List.length context) reduced_type_of_hyp in - tclTHENLIST + tclTHENLIST [ h_reduce_with_zeta (Tacticals.onHyp hyp_id) ; - scan_type new_context new_typ_of_hyp - + scan_type new_context new_typ_of_hyp + ] - else if isProd type_of_hyp - then - begin - let (x,t_x,t') = destProd type_of_hyp in - let actual_real_type_of_hyp = it_mkProd_or_LetIn ~init:t' context in + else if isProd type_of_hyp + then + begin + let (x,t_x,t') = destProd type_of_hyp in + let actual_real_type_of_hyp = it_mkProd_or_LetIn ~init:t' context in if is_property ptes_infos t_x actual_real_type_of_hyp then begin - let pte,pte_args = (destApp t_x) in - let (* fix_info *) prove_rec_hyp = (Idmap.find (destVar pte) ptes_infos).proving_tac in - let popped_t' = pop t' in - let real_type_of_hyp = it_mkProd_or_LetIn ~init:popped_t' context in - let prove_new_type_of_hyp = - let context_length = List.length context in + let pte,pte_args = (destApp t_x) in + let (* fix_info *) prove_rec_hyp = (Idmap.find (destVar pte) ptes_infos).proving_tac in + let popped_t' = pop t' in + let real_type_of_hyp = it_mkProd_or_LetIn ~init:popped_t' context in + let prove_new_type_of_hyp = + let context_length = List.length context in tclTHENLIST - [ - tclDO context_length intro; - (fun g -> - let context_hyps_ids = + [ + tclDO context_length intro; + (fun g -> + let context_hyps_ids = fst (list_chop ~msg:"rec hyp : context_hyps" context_length (pf_ids_of_hyps g)) in - let rec_pte_id = pf_get_new_id rec_pte_id g in - let to_refine = + let rec_pte_id = pf_get_new_id rec_pte_id g in + let to_refine = applist(mkVar hyp_id, List.rev_map mkVar (rec_pte_id::context_hyps_ids) ) @@ -440,39 +440,39 @@ let clean_hyp_with_heq ptes_infos eq_hyps hyp_id env sigma = ) ] in - tclTHENLIST + tclTHENLIST [ (* observe_tac "hyp rec" *) (change_hyp_with_using "rec_hyp_tac" hyp_id real_type_of_hyp prove_new_type_of_hyp); scan_type context popped_t' ] end - else if eq_constr t_x coq_False then + else if eq_constr t_x coq_False then begin (* observe (str "Removing : "++ Ppconstr.pr_id hyp_id++ *) (* str " since it has False in its preconds " *) (* ); *) raise TOREMOVE; (* False -> .. useless *) end - else if is_incompatible_eq t_x then raise TOREMOVE (* t_x := C1 ... = C2 ... *) + else if is_incompatible_eq t_x then raise TOREMOVE (* t_x := C1 ... = C2 ... *) else if eq_constr t_x coq_True (* Trivial => we remove this precons *) - then + then (* observe (str "In "++Ppconstr.pr_id hyp_id++ *) (* str " removing useless precond True" *) (* ); *) let popped_t' = pop t' in - let real_type_of_hyp = - it_mkProd_or_LetIn ~init:popped_t' context - in - let prove_trivial = - let nb_intro = List.length context in + let real_type_of_hyp = + it_mkProd_or_LetIn ~init:popped_t' context + in + let prove_trivial = + let nb_intro = List.length context in tclTHENLIST [ tclDO nb_intro intro; - (fun g -> - let context_hyps = + (fun g -> + let context_hyps = fst (list_chop ~msg:"removing True : context_hyps "nb_intro (pf_ids_of_hyps g)) in - let to_refine = + let to_refine = applist (mkVar hyp_id, List.rev (coq_I::List.map mkVar context_hyps) ) @@ -482,19 +482,19 @@ let clean_hyp_with_heq ptes_infos eq_hyps hyp_id env sigma = ] in tclTHENLIST[ - change_hyp_with_using "prove_trivial" hyp_id real_type_of_hyp + change_hyp_with_using "prove_trivial" hyp_id real_type_of_hyp ((* observe_tac "prove_trivial" *) prove_trivial); scan_type context popped_t' ] - else if is_trivial_eq t_x - then (* t_x := t = t => we remove this precond *) + else if is_trivial_eq t_x + then (* t_x := t = t => we remove this precond *) let popped_t' = pop t' in let real_type_of_hyp = it_mkProd_or_LetIn ~init:popped_t' context in let hd,args = destApp t_x in - let get_args hd args = - if eq_constr hd (Lazy.force eq) + let get_args hd args = + if eq_constr hd (Lazy.force eq) then (Lazy.force refl_equal,args.(0),args.(1)) else (jmeq_refl (),args.(0),args.(1)) in @@ -504,77 +504,77 @@ let clean_hyp_with_heq ptes_infos eq_hyps hyp_id env sigma = "prove_trivial_eq" hyp_id real_type_of_hyp - ((* observe_tac "prove_trivial_eq" *) + ((* observe_tac "prove_trivial_eq" *) (prove_trivial_eq hyp_id context (get_args hd args))); scan_type context popped_t' - ] - else + ] + else begin - try - let new_context,new_t',tac = change_eq env sigma hyp_id context x t_x t' in + try + let new_context,new_t',tac = change_eq env sigma hyp_id context x t_x t' in tclTHEN - tac + tac (scan_type new_context new_t') - with Failure "NoChange" -> - (* Last thing todo : push the rel in the context and continue *) + with Failure "NoChange" -> + (* Last thing todo : push the rel in the context and continue *) scan_type ((x,None,t_x)::context) t' end end else tclIDTAC - in - try + in + try scan_type [] (Typing.type_of env sigma (mkVar hyp_id)), [hyp_id] - with TOREMOVE -> + with TOREMOVE -> thin [hyp_id],[] -let clean_goal_with_heq ptes_infos continue_tac dyn_infos = - fun g -> - let env = pf_env g - and sigma = project g +let clean_goal_with_heq ptes_infos continue_tac dyn_infos = + fun g -> + let env = pf_env g + and sigma = project g in - let tac,new_hyps = - List.fold_left ( + let tac,new_hyps = + List.fold_left ( fun (hyps_tac,new_hyps) hyp_id -> - let hyp_tac,new_hyp = - clean_hyp_with_heq ptes_infos dyn_infos.eq_hyps hyp_id env sigma + let hyp_tac,new_hyp = + clean_hyp_with_heq ptes_infos dyn_infos.eq_hyps hyp_id env sigma in (tclTHEN hyp_tac hyps_tac),new_hyp@new_hyps ) (tclIDTAC,[]) dyn_infos.rec_hyps in - let new_infos = - { dyn_infos with - rec_hyps = new_hyps; + let new_infos = + { dyn_infos with + rec_hyps = new_hyps; nb_rec_hyps = List.length new_hyps } in - tclTHENLIST + tclTHENLIST [ tac ; (* observe_tac "clean_hyp_with_heq continue" *) (continue_tac new_infos) ] - g + g let heq_id = id_of_string "Heq" -let treat_new_case ptes_infos nb_prod continue_tac term dyn_infos = - fun g -> - let heq_id = pf_get_new_id heq_id g in +let treat_new_case ptes_infos nb_prod continue_tac term dyn_infos = + fun g -> + let heq_id = pf_get_new_id heq_id g in let nb_first_intro = nb_prod - 1 - dyn_infos.nb_rec_hyps in tclTHENLIST - [ - (* We first introduce the variables *) + [ + (* We first introduce the variables *) tclDO nb_first_intro (intro_avoiding dyn_infos.rec_hyps); (* Then the equation itself *) introduction_no_check heq_id; - (* Then the new hypothesis *) + (* Then the new hypothesis *) tclMAP introduction_no_check dyn_infos.rec_hyps; - (* observe_tac "after_introduction" *)(fun g' -> + (* observe_tac "after_introduction" *)(fun g' -> (* We get infos on the equations introduced*) - let new_term_value_eq = pf_type_of g' (mkVar heq_id) in + let new_term_value_eq = pf_type_of g' (mkVar heq_id) in (* compute the new value of the body *) let new_term_value = match kind_of_term new_term_value_eq with @@ -592,31 +592,31 @@ let treat_new_case ptes_infos nb_prod continue_tac term dyn_infos = ) in let new_body = pf_nf_betaiota g' (mkApp(fun_body,[| new_term_value |])) in - let new_infos = - {dyn_infos with + let new_infos = + {dyn_infos with info = new_body; eq_hyps = heq_id::dyn_infos.eq_hyps } - in + in clean_goal_with_heq ptes_infos continue_tac new_infos g' ) ] g -let my_orelse tac1 tac2 g = - try - tac1 g - with e -> +let my_orelse tac1 tac2 g = + try + tac1 g + with e -> (* observe (str "using snd tac since : " ++ Cerrors.explain_exn e); *) - tac2 g + tac2 g -let instanciate_hyps_with_args (do_prove:identifier list -> tactic) hyps args_id = - let args = Array.of_list (List.map mkVar args_id) in - let instanciate_one_hyp hid = +let instanciate_hyps_with_args (do_prove:identifier list -> tactic) hyps args_id = + let args = Array.of_list (List.map mkVar args_id) in + let instanciate_one_hyp hid = my_orelse ( (* we instanciate the hyp if possible *) - fun g -> + fun g -> let prov_hid = pf_get_new_id hid g in tclTHENLIST[ pose_proof (Name prov_hid) (mkApp(mkVar hid,args)); @@ -625,21 +625,21 @@ let instanciate_hyps_with_args (do_prove:identifier list -> tactic) hyps args_id ] g ) ( (* - if not then we are in a mutual function block + if not then we are in a mutual function block and this hyp is a recursive hyp on an other function. - - We are not supposed to use it while proving this - principle so that we can trash it - + + We are not supposed to use it while proving this + principle so that we can trash it + *) - (fun g -> + (fun g -> (* observe (str "Instanciation: removing hyp " ++ Ppconstr.pr_id hid); *) thin [hid] g ) ) in - if args_id = [] - then + if args_id = [] + then tclTHENLIST [ tclMAP (fun hyp_id -> h_reduce_with_zeta (Tacticals.onHyp hyp_id)) hyps; do_prove hyps @@ -649,32 +649,32 @@ let instanciate_hyps_with_args (do_prove:identifier list -> tactic) hyps args_id [ tclMAP (fun hyp_id -> h_reduce_with_zeta (Tacticals.onHyp hyp_id)) hyps; tclMAP instanciate_one_hyp hyps; - (fun g -> - let all_g_hyps_id = + (fun g -> + let all_g_hyps_id = List.fold_right Idset.add (pf_ids_of_hyps g) Idset.empty - in - let remaining_hyps = + in + let remaining_hyps = List.filter (fun id -> Idset.mem id all_g_hyps_id) hyps in do_prove remaining_hyps g ) ] -let build_proof +let build_proof (interactive_proof:bool) (fnames:constant list) ptes_infos dyn_infos : tactic = - let rec build_proof_aux do_finalize dyn_infos : tactic = - fun g -> + let rec build_proof_aux do_finalize dyn_infos : tactic = + fun g -> (* observe (str "proving on " ++ Printer.pr_lconstr_env (pf_env g) term);*) - match kind_of_term dyn_infos.info with - | Case(ci,ct,t,cb) -> - let do_finalize_t dyn_info' = + match kind_of_term dyn_infos.info with + | Case(ci,ct,t,cb) -> + let do_finalize_t dyn_info' = fun g -> - let t = dyn_info'.info in - let dyn_infos = {dyn_info' with info = + let t = dyn_info'.info in + let dyn_infos = {dyn_info' with info = mkCase(ci,ct,t,cb)} in let g_nb_prod = nb_prod (pf_concl g) in let type_of_term = pf_type_of g t in @@ -686,21 +686,21 @@ let build_proof h_generalize (term_eq::(List.map mkVar dyn_infos.rec_hyps)); thin dyn_infos.rec_hyps; pattern_option [(false,[1]),t] None; - (fun g -> observe_tac "toto" ( + (fun g -> observe_tac "toto" ( tclTHENSEQ [h_simplest_case t; - (fun g' -> - let g'_nb_prod = nb_prod (pf_concl g') in - let nb_instanciate_partial = g'_nb_prod - g_nb_prod in + (fun g' -> + let g'_nb_prod = nb_prod (pf_concl g') in + let nb_instanciate_partial = g'_nb_prod - g_nb_prod in observe_tac "treat_new_case" - (treat_new_case + (treat_new_case ptes_infos - nb_instanciate_partial - (build_proof do_finalize) - t + nb_instanciate_partial + (build_proof do_finalize) + t dyn_infos) g' ) - + ]) g ) ] @@ -715,25 +715,25 @@ let build_proof intro (fun g' -> let (id,_,_) = pf_last_hyp g' in - let new_term = - pf_nf_betaiota g' - (mkApp(dyn_infos.info,[|mkVar id|])) + let new_term = + pf_nf_betaiota g' + (mkApp(dyn_infos.info,[|mkVar id|])) in let new_infos = {dyn_infos with info = new_term} in - let do_prove new_hyps = - build_proof do_finalize + let do_prove new_hyps = + build_proof do_finalize {new_infos with - rec_hyps = new_hyps; + rec_hyps = new_hyps; nb_rec_hyps = List.length new_hyps } - in + in (* observe_tac "Lambda" *) (instanciate_hyps_with_args do_prove new_infos.rec_hyps [id]) g' (* build_proof do_finalize new_infos g' *) ) g | _ -> - do_finalize dyn_infos g + do_finalize dyn_infos g end - | Cast(t,_,_) -> + | Cast(t,_,_) -> build_proof do_finalize {dyn_infos with info = t} g | Const _ | Var _ | Meta _ | Evar _ | Sort _ | Construct _ | Ind _ -> do_finalize dyn_infos g @@ -743,15 +743,15 @@ let build_proof match kind_of_term f with | App _ -> assert false (* we have collected all the app in decompose_app *) | Var _ | Construct _ | Rel _ | Evar _ | Meta _ | Ind _ | Sort _ | Prod _ -> - let new_infos = - { dyn_infos with + let new_infos = + { dyn_infos with info = (f,args) } in build_proof_args do_finalize new_infos g | Const c when not (List.mem c fnames) -> - let new_infos = - { dyn_infos with + let new_infos = + { dyn_infos with info = (f,args) } in @@ -759,93 +759,93 @@ let build_proof build_proof_args do_finalize new_infos g | Const _ -> do_finalize dyn_infos g - | Lambda _ -> + | Lambda _ -> let new_term = - Reductionops.nf_beta Evd.empty dyn_infos.info in - build_proof do_finalize {dyn_infos with info = new_term} + Reductionops.nf_beta Evd.empty dyn_infos.info in + build_proof do_finalize {dyn_infos with info = new_term} g - | LetIn _ -> - let new_infos = - { dyn_infos with info = nf_betaiotazeta dyn_infos.info } - in - - tclTHENLIST - [tclMAP - (fun hyp_id -> h_reduce_with_zeta (Tacticals.onHyp hyp_id)) + | LetIn _ -> + let new_infos = + { dyn_infos with info = nf_betaiotazeta dyn_infos.info } + in + + tclTHENLIST + [tclMAP + (fun hyp_id -> h_reduce_with_zeta (Tacticals.onHyp hyp_id)) dyn_infos.rec_hyps; h_reduce_with_zeta Tacticals.onConcl; build_proof do_finalize new_infos - ] + ] g - | Cast(b,_,_) -> + | Cast(b,_,_) -> build_proof do_finalize {dyn_infos with info = b } g | Case _ | Fix _ | CoFix _ -> - let new_finalize dyn_infos = - let new_infos = - { dyn_infos with + let new_finalize dyn_infos = + let new_infos = + { dyn_infos with info = dyn_infos.info,args } - in - build_proof_args do_finalize new_infos - in + in + build_proof_args do_finalize new_infos + in build_proof new_finalize {dyn_infos with info = f } g end | Fix _ | CoFix _ -> error ( "Anonymous local (co)fixpoints are not handled yet") - | Prod _ -> error "Prod" - | LetIn _ -> - let new_infos = - { dyn_infos with - info = nf_betaiotazeta dyn_infos.info + | Prod _ -> error "Prod" + | LetIn _ -> + let new_infos = + { dyn_infos with + info = nf_betaiotazeta dyn_infos.info } - in + in - tclTHENLIST - [tclMAP - (fun hyp_id -> h_reduce_with_zeta (Tacticals.onHyp hyp_id)) + tclTHENLIST + [tclMAP + (fun hyp_id -> h_reduce_with_zeta (Tacticals.onHyp hyp_id)) dyn_infos.rec_hyps; h_reduce_with_zeta Tacticals.onConcl; build_proof do_finalize new_infos ] g - | Rel _ -> anomaly "Free var in goal conclusion !" + | Rel _ -> anomaly "Free var in goal conclusion !" and build_proof do_finalize dyn_infos g = (* observe (str "proving with "++Printer.pr_lconstr dyn_infos.info++ str " on goal " ++ pr_gls g); *) observe_tac "build_proof" (build_proof_aux do_finalize dyn_infos) g and build_proof_args do_finalize dyn_infos (* f_args' args *) :tactic = fun g -> - let (f_args',args) = dyn_infos.info in + let (f_args',args) = dyn_infos.info in let tac : tactic = - fun g -> + fun g -> match args with | [] -> - do_finalize {dyn_infos with info = f_args'} g + do_finalize {dyn_infos with info = f_args'} g | arg::args -> (* observe (str "build_proof_args with arg := "++ pr_lconstr_env (pf_env g) arg++ *) (* fnl () ++ *) (* pr_goal (Tacmach.sig_it g) *) (* ); *) let do_finalize dyn_infos = - let new_arg = dyn_infos.info in + let new_arg = dyn_infos.info in (* tclTRYD *) (build_proof_args do_finalize {dyn_infos with info = (mkApp(f_args',[|new_arg|])), args} ) in - build_proof do_finalize + build_proof do_finalize {dyn_infos with info = arg } g in (* observe_tac "build_proof_args" *) (tac ) g in - let do_finish_proof dyn_infos = - (* tclTRYD *) (clean_goal_with_heq + let do_finish_proof dyn_infos = + (* tclTRYD *) (clean_goal_with_heq ptes_infos finish_proof dyn_infos) in (* observe_tac "build_proof" *) - (build_proof (clean_goal_with_heq ptes_infos do_finish_proof) dyn_infos) + (build_proof (clean_goal_with_heq ptes_infos do_finish_proof) dyn_infos) @@ -858,16 +858,16 @@ let build_proof -(* Proof of principles from structural functions *) +(* Proof of principles from structural functions *) let is_pte_type t = isSort ((strip_prod t)) - + let is_pte (_,_,t) = is_pte_type t -type static_fix_info = +type static_fix_info = { idx : int; name : identifier; @@ -875,18 +875,18 @@ type static_fix_info = offset : int; nb_realargs : int; body_with_param : constr; - num_in_block : int + num_in_block : int } -let prove_rec_hyp_for_struct fix_info = - (fun eq_hyps -> tclTHEN +let prove_rec_hyp_for_struct fix_info = + (fun eq_hyps -> tclTHEN (rewrite_until_var (fix_info.idx) eq_hyps) - (fun g -> - let _,pte_args = destApp (pf_concl g) in - let rec_hyp_proof = - mkApp(mkVar fix_info.name,array_get_start pte_args) + (fun g -> + let _,pte_args = destApp (pf_concl g) in + let rec_hyp_proof = + mkApp(mkVar fix_info.name,array_get_start pte_args) in refine rec_hyp_proof g )) @@ -894,38 +894,38 @@ let prove_rec_hyp_for_struct fix_info = let prove_rec_hyp fix_info = { proving_tac = prove_rec_hyp_for_struct fix_info ; - is_valid = fun _ -> true + is_valid = fun _ -> true } exception Not_Rec - -let generalize_non_dep hyp g = + +let generalize_non_dep hyp g = (* observe (str "rec id := " ++ Ppconstr.pr_id hyp); *) - let hyps = [hyp] in - let env = Global.env () in - let hyp_typ = pf_type_of g (mkVar hyp) in - let to_revert,_ = + let hyps = [hyp] in + let env = Global.env () in + let hyp_typ = pf_type_of g (mkVar hyp) in + let to_revert,_ = Environ.fold_named_context_reverse (fun (clear,keep) (hyp,_,_ as decl) -> if List.mem hyp hyps or List.exists (occur_var_in_decl env hyp) keep or occur_var env hyp hyp_typ - or Termops.is_section_variable hyp (* should be dangerous *) + or Termops.is_section_variable hyp (* should be dangerous *) then (clear,decl::keep) else (hyp::clear,keep)) ~init:([],[]) (pf_env g) in (* observe (str "to_revert := " ++ prlist_with_sep spc Ppconstr.pr_id to_revert); *) - tclTHEN + tclTHEN ((* observe_tac "h_generalize" *) (h_generalize (List.map mkVar to_revert) )) ((* observe_tac "thin" *) (thin to_revert)) g - + let id_of_decl (na,_,_) = (Nameops.out_name na) let var_of_decl decl = mkVar (id_of_decl decl) -let revert idl = - tclTHEN - (generalize (List.map mkVar idl)) +let revert idl = + tclTHEN + (generalize (List.map mkVar idl)) (thin idl) let generate_equation_lemma fnames f fun_num nb_params nb_args rec_args_num = @@ -950,7 +950,7 @@ let generate_equation_lemma fnames f fun_num nb_params nb_args rec_args_num = (* observe (str "f_body_with_params_and_other_fun " ++ pr_lconstr f_body_with_params_and_other_fun); *) let eq_rhs = nf_betaiotazeta (mkApp(compose_lam params f_body_with_params_and_other_fun,Array.init (nb_params + nb_args) (fun i -> mkRel(nb_params + nb_args - i)))) in (* observe (str "eq_rhs " ++ pr_lconstr eq_rhs); *) - let type_ctxt,type_of_f = decompose_prod_n_assum (nb_params + nb_args) + let type_ctxt,type_of_f = decompose_prod_n_assum (nb_params + nb_args) (Typeops.type_of_constant_type (Global.env()) f_def.const_type) in let eqn = mkApp(Lazy.force eq,[|type_of_f;eq_lhs;eq_rhs|]) in let lemma_type = it_mkProd_or_LetIn ~init:eqn type_ctxt in @@ -971,7 +971,7 @@ let generate_equation_lemma fnames f fun_num nb_params nb_args rec_args_num = Command.start_proof (*i The next call to mk_equation_id is valid since we are constructing the lemma Ensures by: obvious - i*) + i*) (mk_equation_id f_id) (Decl_kinds.Global,(Decl_kinds.Proof Decl_kinds.Theorem)) lemma_type @@ -981,72 +981,72 @@ let generate_equation_lemma fnames f fun_num nb_params nb_args rec_args_num = - + 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 + let equation_lemma = + try + let finfos = find_Function_infos (destConst f) in mkConst (Option.get finfos.equation_lemma) - with (Not_found | Option.IsNone as e) -> - let f_id = id_of_label (con_label (destConst f)) in + 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 - i*) - let equation_lemma_id = (mk_equation_id f_id) in + i*) + let equation_lemma_id = (mk_equation_id f_id) in generate_equation_lemma all_funs f fun_num (List.length params) (List.length rev_args_id) rec_arg_num; let _ = - match e with - | Option.IsNone -> - let finfos = find_Function_infos (destConst f) in - update_Function + match e with + | Option.IsNone -> + let finfos = find_Function_infos (destConst f) in + update_Function {finfos with equation_lemma = Some (match Nametab.locate (qualid_of_ident equation_lemma_id) with ConstRef c -> c - | _ -> Util.anomaly "Not a constant" + | _ -> Util.anomaly "Not a constant" ) } - | _ -> () + | _ -> () - in + in Tacinterp.constr_of_id (pf_env g) equation_lemma_id in let nb_intro_to_do = nb_prod (pf_concl g) in tclTHEN (tclDO nb_intro_to_do intro) ( - fun g' -> - let just_introduced = nLastDecls nb_intro_to_do g' in - let just_introduced_id = List.map (fun (id,_,_) -> id) just_introduced in + fun g' -> + let just_introduced = nLastDecls nb_intro_to_do g' in + let just_introduced_id = List.map (fun (id,_,_) -> id) just_introduced in tclTHEN (Equality.rewriteLR equation_lemma) (revert just_introduced_id) g' ) g let prove_princ_for_struct interactive_proof fun_num fnames all_funs _nparams : tactic = - fun g -> - let princ_type = pf_concl g in - let princ_info = compute_elim_sig princ_type in - let fresh_id = - let avoid = ref (pf_ids_of_hyps g) in - (fun na -> - let new_id = - match na with - Name id -> fresh_id !avoid (string_of_id id) + fun g -> + let princ_type = pf_concl g in + let princ_info = compute_elim_sig princ_type in + let fresh_id = + let avoid = ref (pf_ids_of_hyps g) in + (fun na -> + let new_id = + match na with + Name id -> fresh_id !avoid (string_of_id id) | Anonymous -> fresh_id !avoid "H" in - avoid := new_id :: !avoid; + avoid := new_id :: !avoid; (Name new_id) ) in - let fresh_decl = - (fun (na,b,t) -> + let fresh_decl = + (fun (na,b,t) -> (fresh_id na,b,t) ) in - let princ_info : elim_scheme = - { princ_info with + let princ_info : elim_scheme = + { princ_info with params = List.map fresh_decl princ_info.params; - predicates = List.map fresh_decl princ_info.predicates; - branches = List.map fresh_decl princ_info.branches; + predicates = List.map fresh_decl princ_info.predicates; + branches = List.map fresh_decl princ_info.branches; args = List.map fresh_decl princ_info.args } in @@ -1062,15 +1062,15 @@ let prove_princ_for_struct interactive_proof fun_num fnames all_funs _nparams : | None -> error ( "Cannot define a principle over an axiom ") in let fbody = get_body fnames.(fun_num) in - let f_ctxt,f_body = decompose_lam fbody in - let f_ctxt_length = List.length f_ctxt in - let diff_params = princ_info.nparams - f_ctxt_length in - let full_params,princ_params,fbody_with_full_params = + let f_ctxt,f_body = decompose_lam fbody in + let f_ctxt_length = List.length f_ctxt in + let diff_params = princ_info.nparams - f_ctxt_length in + let full_params,princ_params,fbody_with_full_params = if diff_params > 0 - then - let princ_params,full_params = - list_chop diff_params princ_info.params - in + then + let princ_params,full_params = + list_chop diff_params princ_info.params + in (full_params, (* real params *) princ_params, (* the params of the principle which are not params of the function *) substl (* function instanciated with real params *) @@ -1078,9 +1078,9 @@ let prove_princ_for_struct interactive_proof fun_num fnames all_funs _nparams : f_body ) else - let f_ctxt_other,f_ctxt_params = - list_chop (- diff_params) f_ctxt in - let f_body = compose_lam f_ctxt_other f_body in + let f_ctxt_other,f_ctxt_params = + list_chop (- diff_params) f_ctxt in + let f_body = compose_lam f_ctxt_other f_body in (princ_info.params, (* real params *) [],(* all params are full params *) substl (* function instanciated with real params *) @@ -1099,32 +1099,32 @@ let prove_princ_for_struct interactive_proof fun_num fnames all_funs _nparams : (* observe (str "fbody_with_full_params := " ++ *) (* pr_lconstr fbody_with_full_params *) (* ); *) - let all_funs_with_full_params = + let all_funs_with_full_params = Array.map (fun f -> applist(f, List.rev_map var_of_decl full_params)) all_funs in - let fix_offset = List.length princ_params in - let ptes_to_fix,infos = - match kind_of_term fbody_with_full_params with - | Fix((idxs,i),(names,typess,bodies)) -> - let bodies_with_all_params = - Array.map - (fun body -> + let fix_offset = List.length princ_params in + let ptes_to_fix,infos = + match kind_of_term fbody_with_full_params with + | Fix((idxs,i),(names,typess,bodies)) -> + let bodies_with_all_params = + Array.map + (fun body -> Reductionops.nf_betaiota Evd.empty (applist(substl (List.rev (Array.to_list all_funs_with_full_params)) body, List.rev_map var_of_decl princ_params)) ) bodies in - let info_array = - Array.mapi - (fun i types -> + let info_array = + Array.mapi + (fun i types -> let types = prod_applist types (List.rev_map var_of_decl princ_params) in { idx = idxs.(i) - fix_offset; name = Nameops.out_name (fresh_id names.(i)); - types = types; + types = types; offset = fix_offset; - nb_realargs = - List.length + nb_realargs = + List.length (fst (decompose_lam bodies.(i))) - fix_offset; body_with_param = bodies_with_all_params.(i); num_in_block = i @@ -1132,65 +1132,65 @@ let prove_princ_for_struct interactive_proof fun_num fnames all_funs _nparams : ) typess in - let pte_to_fix,rev_info = - list_fold_left_i - (fun i (acc_map,acc_info) (pte,_,_) -> - let infos = info_array.(i) in - let type_args,_ = decompose_prod infos.types in - let nargs = List.length type_args in + let pte_to_fix,rev_info = + list_fold_left_i + (fun i (acc_map,acc_info) (pte,_,_) -> + let infos = info_array.(i) in + let type_args,_ = decompose_prod infos.types in + let nargs = List.length type_args in let f = applist(mkConst fnames.(i), List.rev_map var_of_decl princ_info.params) in let first_args = Array.init nargs (fun i -> mkRel (nargs -i)) in let app_f = mkApp(f,first_args) in - let pte_args = (Array.to_list first_args)@[app_f] in - let app_pte = applist(mkVar (Nameops.out_name pte),pte_args) in - let body_with_param,num = - let body = get_body fnames.(i) in - let body_with_full_params = + let pte_args = (Array.to_list first_args)@[app_f] in + let app_pte = applist(mkVar (Nameops.out_name pte),pte_args) in + let body_with_param,num = + let body = get_body fnames.(i) in + let body_with_full_params = Reductionops.nf_betaiota Evd.empty ( applist(body,List.rev_map var_of_decl full_params)) in - match kind_of_term body_with_full_params with - | Fix((_,num),(_,_,bs)) -> + match kind_of_term body_with_full_params with + | Fix((_,num),(_,_,bs)) -> Reductionops.nf_betaiota Evd.empty ( (applist - (substl - (List.rev - (Array.to_list all_funs_with_full_params)) + (substl + (List.rev + (Array.to_list all_funs_with_full_params)) bs.(num), List.rev_map var_of_decl princ_params)) ),num | _ -> error "Not a mutual block" in - let info = - {infos with + let info = + {infos with types = compose_prod type_args app_pte; body_with_param = body_with_param; num_in_block = num } - in + in (* observe (str "binding " ++ Ppconstr.pr_id (Nameops.out_name pte) ++ *) (* str " to " ++ Ppconstr.pr_id info.name); *) (Idmap.add (Nameops.out_name pte) info acc_map,info::acc_info) ) - 0 - (Idmap.empty,[]) + 0 + (Idmap.empty,[]) (List.rev princ_info.predicates) in pte_to_fix,List.rev rev_info | _ -> Idmap.empty,[] in - let mk_fixes : tactic = - let pre_info,infos = list_chop fun_num infos in - match pre_info,infos with + let mk_fixes : tactic = + let pre_info,infos = list_chop fun_num infos in + match pre_info,infos with | [],[] -> tclIDTAC - | _, this_fix_info::others_infos -> + | _, this_fix_info::others_infos -> let other_fix_infos = List.map - (fun fi -> fi.name,fi.idx + 1 ,fi.types) + (fun fi -> fi.name,fi.idx + 1 ,fi.types) (pre_info@others_infos) - in - if other_fix_infos = [] + in + if other_fix_infos = [] then (* observe_tac ("h_fix") *) (h_fix (Some this_fix_info.name) (this_fix_info.idx +1)) else @@ -1199,34 +1199,34 @@ let prove_princ_for_struct interactive_proof fun_num fnames all_funs _nparams : | _ -> anomaly "Not a valid information" in let first_tac : tactic = (* every operations until fix creations *) - tclTHENSEQ - [ (* observe_tac "introducing params" *) (intros_using (List.rev_map id_of_decl princ_info.params)); - (* observe_tac "introducing predictes" *) (intros_using (List.rev_map id_of_decl princ_info.predicates)); - (* observe_tac "introducing branches" *) (intros_using (List.rev_map id_of_decl princ_info.branches)); + tclTHENSEQ + [ (* observe_tac "introducing params" *) (intros_using (List.rev_map id_of_decl princ_info.params)); + (* observe_tac "introducing predictes" *) (intros_using (List.rev_map id_of_decl princ_info.predicates)); + (* observe_tac "introducing branches" *) (intros_using (List.rev_map id_of_decl princ_info.branches)); (* observe_tac "building fixes" *) mk_fixes; ] in - let intros_after_fixes : tactic = - fun gl -> + let intros_after_fixes : tactic = + fun gl -> let ctxt,pte_app = (decompose_prod_assum (pf_concl gl)) in let pte,pte_args = (decompose_app pte_app) in try - let pte = try destVar pte with _ -> anomaly "Property is not a variable" in + let pte = try destVar pte with _ -> anomaly "Property is not a variable" in let fix_info = Idmap.find pte ptes_to_fix in - let nb_args = fix_info.nb_realargs in + let nb_args = fix_info.nb_realargs in tclTHENSEQ [ (* observe_tac ("introducing args") *) (tclDO nb_args intro); (fun g -> (* replacement of the function by its body *) - let args = nLastDecls nb_args g in + let args = nLastDecls nb_args g in let fix_body = fix_info.body_with_param in (* observe (str "fix_body := "++ pr_lconstr_env (pf_env gl) fix_body); *) let args_id = List.map (fun (id,_,_) -> id) args in - let dyn_infos = + let dyn_infos = { nb_rec_hyps = -100; rec_hyps = []; - info = + info = Reductionops.nf_betaiota Evd.empty (applist(fix_body,List.rev_map mkVar args_id)); eq_hyps = [] @@ -1235,42 +1235,42 @@ let prove_princ_for_struct interactive_proof fun_num fnames all_funs _nparams : tclTHENSEQ [ (* observe_tac "do_replace" *) - (do_replace - full_params - (fix_info.idx + List.length princ_params) + (do_replace + full_params + (fix_info.idx + List.length princ_params) (args_id@(List.map (fun (id,_,_) -> Nameops.out_name id ) princ_params)) - (all_funs.(fix_info.num_in_block)) - fix_info.num_in_block + (all_funs.(fix_info.num_in_block)) + fix_info.num_in_block all_funs ); (* observe_tac "do_replace" *) (* (do_replace princ_info.params fix_info.idx args_id *) (* (List.hd (List.rev pte_args)) fix_body); *) - let do_prove = - build_proof + let do_prove = + build_proof interactive_proof - (Array.to_list fnames) + (Array.to_list fnames) (Idmap.map prove_rec_hyp ptes_to_fix) in - let prove_tac branches = - let dyn_infos = - {dyn_infos with + let prove_tac branches = + let dyn_infos = + {dyn_infos with rec_hyps = branches; nb_rec_hyps = List.length branches } in observe_tac "cleaning" (clean_goal_with_heq - (Idmap.map prove_rec_hyp ptes_to_fix) - do_prove + (Idmap.map prove_rec_hyp ptes_to_fix) + do_prove dyn_infos) in (* observe (str "branches := " ++ *) (* prlist_with_sep spc (fun decl -> Ppconstr.pr_id (id_of_decl decl)) princ_info.branches ++ fnl () ++ *) (* str "args := " ++ prlist_with_sep spc Ppconstr.pr_id args_id *) - + (* ); *) - (* observe_tac "instancing" *) (instanciate_hyps_with_args prove_tac - (List.rev_map id_of_decl princ_info.branches) + (* observe_tac "instancing" *) (instanciate_hyps_with_args prove_tac + (List.rev_map id_of_decl princ_info.branches) (List.rev args_id)) ] g @@ -1282,14 +1282,14 @@ let prove_princ_for_struct interactive_proof fun_num fnames all_funs _nparams : [ tclDO nb_args intro; (fun g -> (* replacement of the function by its body *) - let args = nLastDecls nb_args g in + let args = nLastDecls nb_args g in let args_id = List.map (fun (id,_,_) -> id) args in - let dyn_infos = + let dyn_infos = { nb_rec_hyps = -100; rec_hyps = []; - info = - Reductionops.nf_betaiota Evd.empty + info = + Reductionops.nf_betaiota Evd.empty (applist(fbody_with_full_params, (List.rev_map var_of_decl princ_params)@ (List.rev_map mkVar args_id) @@ -1300,44 +1300,44 @@ let prove_princ_for_struct interactive_proof fun_num fnames all_funs _nparams : let fname = destConst (fst (decompose_app (List.hd (List.rev pte_args)))) in tclTHENSEQ [unfold_in_concl [(all_occurrences,Names.EvalConstRef fname)]; - let do_prove = - build_proof + let do_prove = + build_proof interactive_proof - (Array.to_list fnames) + (Array.to_list fnames) (Idmap.map prove_rec_hyp ptes_to_fix) in - let prove_tac branches = - let dyn_infos = - {dyn_infos with + let prove_tac branches = + let dyn_infos = + {dyn_infos with rec_hyps = branches; nb_rec_hyps = List.length branches } in clean_goal_with_heq - (Idmap.map prove_rec_hyp ptes_to_fix) - do_prove + (Idmap.map prove_rec_hyp ptes_to_fix) + do_prove dyn_infos in - instanciate_hyps_with_args prove_tac - (List.rev_map id_of_decl princ_info.branches) + instanciate_hyps_with_args prove_tac + (List.rev_map id_of_decl princ_info.branches) (List.rev args_id) ] g ) - ] + ] gl in - tclTHEN + tclTHEN first_tac intros_after_fixes g - -(* Proof of principles of general functions *) + +(* Proof of principles of general functions *) let h_id = Recdef.h_id and hrec_id = Recdef.hrec_id and acc_inv_id = Recdef.acc_inv_id @@ -1376,73 +1376,73 @@ let prove_with_tcc tcc_lemma_constr eqs : tactic = gls -let backtrack_eqs_until_hrec hrec eqs : tactic = - fun gls -> - let eqs = List.map mkVar eqs in - let rewrite = +let backtrack_eqs_until_hrec hrec eqs : tactic = + fun gls -> + let eqs = List.map mkVar eqs in + let rewrite = tclFIRST (List.map Equality.rewriteRL eqs ) - in - let _,hrec_concl = decompose_prod (pf_type_of gls (mkVar hrec)) in - let f_app = array_last (snd (destApp hrec_concl)) in - let f = (fst (destApp f_app)) in - let rec backtrack : tactic = - fun g -> - let f_app = array_last (snd (destApp (pf_concl g))) in - match kind_of_term f_app with + in + let _,hrec_concl = decompose_prod (pf_type_of gls (mkVar hrec)) in + let f_app = array_last (snd (destApp hrec_concl)) in + let f = (fst (destApp f_app)) in + let rec backtrack : tactic = + fun g -> + let f_app = array_last (snd (destApp (pf_concl g))) in + match kind_of_term f_app with | App(f',_) when eq_constr f' f -> tclIDTAC g | _ -> tclTHEN rewrite backtrack g in backtrack gls - - -let build_clause eqs = + + +let build_clause eqs = { - Tacexpr.onhyps = - Some (List.map + Tacexpr.onhyps = + Some (List.map (fun id -> (Rawterm.all_occurrences_expr,id),InHyp) eqs ); - Tacexpr.concl_occs = Rawterm.no_occurrences_expr + Tacexpr.concl_occs = Rawterm.no_occurrences_expr } -let rec rewrite_eqs_in_eqs eqs = - match eqs with +let rec rewrite_eqs_in_eqs eqs = + match eqs with | [] -> tclIDTAC - | eq::eqs -> - - tclTHEN - (tclMAP - (fun id gl -> - observe_tac - (Format.sprintf "rewrite %s in %s " (string_of_id eq) (string_of_id id)) + | eq::eqs -> + + tclTHEN + (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) + (rewrite_eqs_in_eqs eqs) -let new_prove_with_tcc is_mes acc_inv hrec tcc_hyps eqs : tactic = +let new_prove_with_tcc is_mes acc_inv hrec tcc_hyps eqs : tactic = fun gls -> - (tclTHENSEQ + (tclTHENSEQ [ backtrack_eqs_until_hrec hrec eqs; (* observe_tac ("new_prove_with_tcc ( applying "^(string_of_id hrec)^" )" ) *) (tclTHENS (* We must have exactly ONE subgoal !*) (apply (mkVar hrec)) - [ tclTHENSEQ + [ tclTHENSEQ [ keep (tcc_hyps@eqs); apply (Lazy.force acc_inv); - (fun g -> - if is_mes - then - unfold_in_concl [(all_occurrences, evaluable_of_global_reference (delayed_force ltof_ref))] g + (fun g -> + if is_mes + then + unfold_in_concl [(all_occurrences, evaluable_of_global_reference (delayed_force ltof_ref))] g else tclIDTAC g ); observe_tac "rew_and_finish" - (tclTHENLIST + (tclTHENLIST [tclTRY(Recdef.list_rewrite false (List.map mkVar eqs)); observe_tac "rewrite_eqs_in_eqs" (rewrite_eqs_in_eqs eqs); (observe_tac "finishing using" @@ -1462,7 +1462,7 @@ let new_prove_with_tcc is_mes acc_inv hrec tcc_hyps eqs : tactic = ]) ]) gls - + let is_valid_hypothesis predicates_name = let predicates_name = List.fold_right Idset.add predicates_name Idset.empty in @@ -1477,78 +1477,78 @@ let is_valid_hypothesis predicates_name = in let rec is_valid_hypothesis typ = is_pte typ || - match kind_of_term typ with + match kind_of_term typ with | Prod(_,pte,typ') -> is_pte pte && is_valid_hypothesis typ' - | _ -> false + | _ -> false in - is_valid_hypothesis + is_valid_hypothesis let prove_principle_for_gen (f_ref,functional_ref,eq_ref) tcc_lemma_ref is_mes - rec_arg_num rec_arg_type relation gl = - let princ_type = pf_concl gl in - let princ_info = compute_elim_sig princ_type in - let fresh_id = - let avoid = ref (pf_ids_of_hyps gl) in - fun na -> - let new_id = - match na with - | Name id -> fresh_id !avoid (string_of_id id) - | Anonymous -> fresh_id !avoid "H" + rec_arg_num rec_arg_type relation gl = + let princ_type = pf_concl gl in + let princ_info = compute_elim_sig princ_type in + let fresh_id = + let avoid = ref (pf_ids_of_hyps gl) in + fun na -> + let new_id = + match na with + | Name id -> fresh_id !avoid (string_of_id id) + | Anonymous -> fresh_id !avoid "H" in avoid := new_id :: !avoid; Name new_id in let fresh_decl (na,b,t) = (fresh_id na,b,t) in - let princ_info : elim_scheme = - { princ_info with + let princ_info : elim_scheme = + { princ_info with params = List.map fresh_decl princ_info.params; - predicates = List.map fresh_decl princ_info.predicates; - branches = List.map fresh_decl princ_info.branches; + predicates = List.map fresh_decl princ_info.predicates; + branches = List.map fresh_decl princ_info.branches; args = List.map fresh_decl princ_info.args } in - let wf_tac = - if is_mes - then + let wf_tac = + if is_mes + then (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 - let npost_rec_arg = princ_info.nargs - real_rec_arg_num + 1 in + let real_rec_arg_num = rec_arg_num - princ_info.nparams in + let npost_rec_arg = princ_info.nargs - real_rec_arg_num + 1 in (* observe ( *) (* str "princ_type := " ++ pr_lconstr princ_type ++ fnl () ++ *) (* str "princ_info.nparams := " ++ int princ_info.nparams ++ fnl () ++ *) - + (* str "princ_info.nargs := " ++ int princ_info.nargs ++ fnl () ++ *) (* str "rec_arg_num := " ++ int rec_arg_num ++ fnl() ++ *) (* str "real_rec_arg_num := " ++ int real_rec_arg_num ++ fnl () ++ *) (* str "npost_rec_arg := " ++ int npost_rec_arg ); *) - let (post_rec_arg,pre_rec_arg) = + let (post_rec_arg,pre_rec_arg) = Util.list_chop npost_rec_arg princ_info.args in - let rec_arg_id = - match List.rev post_rec_arg with - | (Name id,_,_)::_ -> id - | _ -> assert false + let rec_arg_id = + match List.rev post_rec_arg with + | (Name id,_,_)::_ -> id + | _ -> assert false in (* observe (str "rec_arg_id := " ++ pr_lconstr (mkVar rec_arg_id)); *) - let subst_constrs = List.map (fun (na,_,_) -> mkVar (Nameops.out_name na)) (pre_rec_arg@princ_info.params) in - let relation = substl subst_constrs relation in - let input_type = substl subst_constrs rec_arg_type in - let wf_thm_id = Nameops.out_name (fresh_id (Name (id_of_string "wf_R"))) in - let acc_rec_arg_id = + let subst_constrs = List.map (fun (na,_,_) -> mkVar (Nameops.out_name na)) (pre_rec_arg@princ_info.params) in + let relation = substl subst_constrs relation in + let input_type = substl subst_constrs rec_arg_type in + let wf_thm_id = Nameops.out_name (fresh_id (Name (id_of_string "wf_R"))) in + let acc_rec_arg_id = Nameops.out_name (fresh_id (Name (id_of_string ("Acc_"^(string_of_id rec_arg_id))))) - in - let revert l = - tclTHEN (h_generalize (List.map mkVar l)) (clear l) in - let fix_id = Nameops.out_name (fresh_id (Name hrec_id)) in - let prove_rec_arg_acc g = + let revert l = + tclTHEN (h_generalize (List.map mkVar l)) (clear l) + in + let fix_id = Nameops.out_name (fresh_id (Name hrec_id)) in + let prove_rec_arg_acc g = ((* observe_tac "prove_rec_arg_acc" *) (tclCOMPLETE (tclTHEN - (assert_by (Name wf_thm_id) + (assert_by (Name wf_thm_id) (mkApp (delayed_force well_founded,[|input_type;relation|])) (fun g -> (* observe_tac "prove wf" *) (tclCOMPLETE (wf_tac is_mes)) g)) ( @@ -1562,8 +1562,8 @@ let prove_principle_for_gen g in let args_ids = List.map (fun (na,_,_) -> Nameops.out_name na) princ_info.args in - let lemma = - match !tcc_lemma_ref with + let lemma = + match !tcc_lemma_ref with | None -> anomaly ( "No tcc proof !!") | Some lemma -> lemma in @@ -1578,11 +1578,11 @@ let prove_principle_for_gen (* f::(list_diff r check_list) *) (* in *) let tcc_list = ref [] in - let start_tac gls = - let hyps = pf_ids_of_hyps gls in - let hid = - next_global_ident_away true - (id_of_string "prov") + let start_tac gls = + let hyps = pf_ids_of_hyps gls in + let hid = + next_global_ident_away true + (id_of_string "prov") hyps in tclTHENSEQ @@ -1590,12 +1590,12 @@ let prove_principle_for_gen generalize [lemma]; h_intro hid; Elim.h_decompose_and (mkVar hid); - (fun g -> - let new_hyps = pf_ids_of_hyps g in + (fun g -> + let new_hyps = pf_ids_of_hyps g in tcc_list := List.rev (list_subtract new_hyps (hid::hyps)); if !tcc_list = [] - then - begin + then + begin tcc_list := [hid]; tclIDTAC g end @@ -1605,10 +1605,10 @@ let prove_principle_for_gen gls in tclTHENSEQ - [ + [ observe_tac "start_tac" start_tac; - h_intros - (List.rev_map (fun (na,_,_) -> Nameops.out_name na) + h_intros + (List.rev_map (fun (na,_,_) -> Nameops.out_name na) (princ_info.args@princ_info.branches@princ_info.predicates@princ_info.params) ); (* observe_tac "" *) (assert_by @@ -1619,24 +1619,24 @@ let prove_principle_for_gen (* observe_tac "reverting" *) (revert (List.rev (acc_rec_arg_id::args_ids))); (* (fun g -> observe (Printer.pr_goal (sig_it g) ++ fnl () ++ *) (* str "fix arg num" ++ int (List.length args_ids + 1) ); tclIDTAC g); *) - (* observe_tac "h_fix " *) (h_fix (Some fix_id) (List.length args_ids + 1)); + (* observe_tac "h_fix " *) (h_fix (Some fix_id) (List.length args_ids + 1)); (* (fun g -> observe (Printer.pr_goal (sig_it g) ++ fnl() ++ pr_lconstr_env (pf_env g ) (pf_type_of g (mkVar fix_id) )); tclIDTAC g); *) h_intros (List.rev (acc_rec_arg_id::args_ids)); Equality.rewriteLR (mkConst eq_ref); - (* observe_tac "finish" *) (fun gl' -> - let body = - let _,args = destApp (pf_concl gl') in + (* observe_tac "finish" *) (fun gl' -> + let body = + let _,args = destApp (pf_concl gl') in array_last args in - let body_info rec_hyps = + let body_info rec_hyps = { nb_rec_hyps = List.length rec_hyps; rec_hyps = rec_hyps; eq_hyps = []; info = body } - in - let acc_inv = + in + let acc_inv = lazy ( mkApp ( delayed_force acc_inv_id, @@ -1645,12 +1645,12 @@ let prove_principle_for_gen ) in let acc_inv = lazy (mkApp(Lazy.force acc_inv, [|mkVar acc_rec_arg_id|])) in - let predicates_names = + let predicates_names = List.map (fun (na,_,_) -> Nameops.out_name na) princ_info.predicates in - let pte_info = + let pte_info = { proving_tac = - (fun eqs -> + (fun eqs -> (* msgnl (str "tcc_list := "++ prlist_with_sep spc Ppconstr.pr_id !tcc_list); *) (* msgnl (str "princ_info.args := "++ prlist_with_sep spc Ppconstr.pr_id (List.map (fun (na,_,_) -> (Nameops.out_name na)) princ_info.args)); *) (* msgnl (str "princ_info.params := "++ prlist_with_sep spc Ppconstr.pr_id (List.map (fun (na,_,_) -> (Nameops.out_name na)) princ_info.params)); *) @@ -1658,47 +1658,47 @@ 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 - is_mes acc_inv fix_id - - (!tcc_list@(List.map - (fun (na,_,_) -> (Nameops.out_name na)) + (new_prove_with_tcc + is_mes acc_inv fix_id + + (!tcc_list@(List.map + (fun (na,_,_) -> (Nameops.out_name na)) (princ_info.args@princ_info.params) )@ ([acc_rec_arg_id])) eqs ) - + ); is_valid = is_valid_hypothesis predicates_names } in - let ptes_info : pte_info Idmap.t = + let ptes_info : pte_info Idmap.t = List.fold_left - (fun map pte_id -> - Idmap.add pte_id - pte_info + (fun map pte_id -> + Idmap.add pte_id + pte_info map ) Idmap.empty predicates_names in - let make_proof rec_hyps = - build_proof - false + let make_proof rec_hyps = + build_proof + false [f_ref] ptes_info (body_info rec_hyps) in (* observe_tac "instanciate_hyps_with_args" *) - (instanciate_hyps_with_args + (instanciate_hyps_with_args make_proof (List.map (fun (na,_,_) -> Nameops.out_name na) princ_info.branches) (List.rev args_ids) ) gl' ) - + ] - gl + gl diff --git a/plugins/funind/functional_principles_proofs.mli b/plugins/funind/functional_principles_proofs.mli index 62eb528e0d..ff98f2b97f 100644 --- a/plugins/funind/functional_principles_proofs.mli +++ b/plugins/funind/functional_principles_proofs.mli @@ -6,11 +6,11 @@ val prove_princ_for_struct : int -> constant array -> constr array -> int -> Tacmach.tactic -val prove_principle_for_gen : +val prove_principle_for_gen : constant*constant*constant -> (* name of the function, the fonctionnal and the fixpoint equation *) constr option ref -> (* a pointer to the obligation proofs lemma *) bool -> (* is that function uses measure *) - int -> (* the number of recursive argument *) + int -> (* the number of recursive argument *) types -> (* the type of the recursive argument *) constr -> (* the wf relation used to prove the function *) Tacmach.tactic diff --git a/plugins/funind/functional_principles_types.ml b/plugins/funind/functional_principles_types.ml index 49d1a179b4..f6959d77e1 100644 --- a/plugins/funind/functional_principles_types.ml +++ b/plugins/funind/functional_principles_types.ml @@ -1,8 +1,8 @@ open Printer open Util open Term -open Termops -open Names +open Termops +open Names open Declarations open Pp open Entries @@ -19,102 +19,102 @@ exception Toberemoved_with_rel of int*constr exception Toberemoved -let pr_elim_scheme el = - let env = Global.env () in - let msg = str "params := " ++ Printer.pr_rel_context env el.params in - let env = Environ.push_rel_context el.params env in - let msg = msg ++ fnl () ++ str "predicates := "++ Printer.pr_rel_context env el.predicates in - let env = Environ.push_rel_context el.predicates env in - let msg = msg ++ fnl () ++ str "branches := " ++ Printer.pr_rel_context env el.branches in - let env = Environ.push_rel_context el.branches env in - let msg = msg ++ fnl () ++ str "args := " ++ Printer.pr_rel_context env el.args in - let env = Environ.push_rel_context el.args env in +let pr_elim_scheme el = + let env = Global.env () in + let msg = str "params := " ++ Printer.pr_rel_context env el.params in + let env = Environ.push_rel_context el.params env in + let msg = msg ++ fnl () ++ str "predicates := "++ Printer.pr_rel_context env el.predicates in + let env = Environ.push_rel_context el.predicates env in + let msg = msg ++ fnl () ++ str "branches := " ++ Printer.pr_rel_context env el.branches in + let env = Environ.push_rel_context el.branches env in + let msg = msg ++ fnl () ++ str "args := " ++ Printer.pr_rel_context env el.args in + let env = Environ.push_rel_context el.args env in msg ++ fnl () ++ str "concl := " ++ pr_lconstr_env env el.concl -let observe s = - if do_observe () - then Pp.msgnl s +let observe s = + if do_observe () + then Pp.msgnl s -let pr_elim_scheme el = - let env = Global.env () in - let msg = str "params := " ++ Printer.pr_rel_context env el.params in - let env = Environ.push_rel_context el.params env in - let msg = msg ++ fnl () ++ str "predicates := "++ Printer.pr_rel_context env el.predicates in - let env = Environ.push_rel_context el.predicates env in - let msg = msg ++ fnl () ++ str "branches := " ++ Printer.pr_rel_context env el.branches in - let env = Environ.push_rel_context el.branches env in - let msg = msg ++ fnl () ++ str "args := " ++ Printer.pr_rel_context env el.args in - let env = Environ.push_rel_context el.args env in +let pr_elim_scheme el = + let env = Global.env () in + let msg = str "params := " ++ Printer.pr_rel_context env el.params in + let env = Environ.push_rel_context el.params env in + let msg = msg ++ fnl () ++ str "predicates := "++ Printer.pr_rel_context env el.predicates in + let env = Environ.push_rel_context el.predicates env in + let msg = msg ++ fnl () ++ str "branches := " ++ Printer.pr_rel_context env el.branches in + let env = Environ.push_rel_context el.branches env in + let msg = msg ++ fnl () ++ str "args := " ++ Printer.pr_rel_context env el.args in + let env = Environ.push_rel_context el.args env in msg ++ fnl () ++ str "concl := " ++ pr_lconstr_env env el.concl -let observe s = - if do_observe () - then Pp.msgnl s +let observe s = + if do_observe () + then Pp.msgnl s -(* - Transform an inductive induction principle into +(* + Transform an inductive induction principle into a functional one -*) +*) let compute_new_princ_type_from_rel rel_to_fun sorts princ_type = - let princ_type_info = compute_elim_sig princ_type in - let env = Global.env () in + let princ_type_info = compute_elim_sig princ_type in + let env = Global.env () in let env_with_params = Environ.push_rel_context princ_type_info.params env in let tbl = Hashtbl.create 792 in - let rec change_predicates_names (avoid:identifier list) (predicates:rel_context) : rel_context = - match predicates with + let rec change_predicates_names (avoid:identifier list) (predicates:rel_context) : rel_context = + match predicates with | [] -> [] - |(Name x,v,t)::predicates -> - let id = Nameops.next_ident_away x avoid in + |(Name x,v,t)::predicates -> + let id = Nameops.next_ident_away x avoid in Hashtbl.add tbl id x; (Name id,v,t)::(change_predicates_names (id::avoid) predicates) | (Anonymous,_,_)::_ -> anomaly "Anonymous property binder " in let avoid = (Termops.ids_of_context env_with_params ) in - let princ_type_info = + let princ_type_info = { princ_type_info with predicates = change_predicates_names avoid princ_type_info.predicates } - in + in (* observe (str "starting princ_type := " ++ pr_lconstr_env env princ_type); *) (* observe (str "princ_infos : " ++ pr_elim_scheme princ_type_info); *) - let change_predicate_sort i (x,_,t) = + let change_predicate_sort i (x,_,t) = let new_sort = sorts.(i) in - let args,_ = decompose_prod t in - let real_args = - if princ_type_info.indarg_in_concl - then List.tl args + let args,_ = decompose_prod t in + let real_args = + if princ_type_info.indarg_in_concl + then List.tl args else args in - Nameops.out_name x,None,compose_prod real_args (mkSort new_sort) + Nameops.out_name x,None,compose_prod real_args (mkSort new_sort) in - let new_predicates = + let new_predicates = list_map_i - change_predicate_sort + change_predicate_sort 0 princ_type_info.predicates in let env_with_params_and_predicates = List.fold_right Environ.push_named new_predicates env_with_params in - let rel_as_kn = + let rel_as_kn = fst (match princ_type_info.indref with - | Some (Libnames.IndRef ind) -> ind + | Some (Libnames.IndRef ind) -> ind | _ -> error "Not a valid predicate" ) in let ptes_vars = List.map (fun (id,_,_) -> id) new_predicates in - let is_pte = - let set = List.fold_right Idset.add ptes_vars Idset.empty in - fun t -> - match kind_of_term t with - | Var id -> Idset.mem id set - | _ -> false - in - let pre_princ = - it_mkProd_or_LetIn + let is_pte = + let set = List.fold_right Idset.add ptes_vars Idset.empty in + fun t -> + match kind_of_term t with + | Var id -> Idset.mem id set + | _ -> false + in + let pre_princ = + it_mkProd_or_LetIn ~init: - (it_mkProd_or_LetIn + (it_mkProd_or_LetIn ~init:(Option.fold_right mkProd_or_LetIn princ_type_info.indarg @@ -139,7 +139,7 @@ let compute_new_princ_type_from_rel rel_to_fun sorts princ_type = in let dummy_var = mkVar (id_of_string "________") in let mk_replacement c i args = - let res = mkApp(rel_to_fun.(i),Array.map pop (array_get_start args)) in + let res = mkApp(rel_to_fun.(i),Array.map pop (array_get_start args)) in (* observe (str "replacing " ++ pr_lconstr c ++ str " by " ++ pr_lconstr res); *) res in @@ -168,10 +168,10 @@ let compute_new_princ_type_from_rel rel_to_fun sorts princ_type = let num = get_fun_num f in raise (Toberemoved_with_rel (var_to_be_removed,mk_replacement pre_princ num args)) | App(f,args) -> - let args = - if is_pte f && remove - then array_get_start args - else args + let args = + if is_pte f && remove + then array_get_start args + else args in let new_args,binders_to_remove = Array.fold_right (compute_new_princ_type_with_acc remove env) @@ -193,7 +193,7 @@ let compute_new_princ_type_from_rel rel_to_fun sorts princ_type = (* pr_lconstr_env env new_princ_type ++ fnl ()) *) (* | _ -> () in *) res - + and compute_new_princ_type_for_binder remove bind_fun env x t b = begin try @@ -240,7 +240,7 @@ let compute_new_princ_type_from_rel rel_to_fun sorts princ_type = (list_union_eq eq_constr binders_to_remove_from_t binders_to_remove_from_v) (List.map pop binders_to_remove_from_b) ) - + with | Toberemoved -> (* observe (str "Decl of "++Ppconstr.pr_name x ++ str " is removed "); *) @@ -257,54 +257,54 @@ let compute_new_princ_type_from_rel rel_to_fun sorts princ_type = new_e::c_acc,list_union_eq eq_constr to_remove_from_e to_remove_acc in (* observe (str "Computing new principe from " ++ pr_lconstr_env env_with_params_and_predicates pre_princ); *) - let pre_res,_ = - compute_new_princ_type princ_type_info.indarg_in_concl env_with_params_and_predicates pre_princ - in - let pre_res = - replace_vars + let pre_res,_ = + compute_new_princ_type princ_type_info.indarg_in_concl env_with_params_and_predicates pre_princ + in + let pre_res = + replace_vars (list_map_i (fun i id -> (id, mkRel i)) 1 ptes_vars) (lift (List.length ptes_vars) pre_res) in - it_mkProd_or_LetIn - ~init:(it_mkProd_or_LetIn - ~init:pre_res (List.map (fun (id,t,b) -> Name(Hashtbl.find tbl id), t,b) + it_mkProd_or_LetIn + ~init:(it_mkProd_or_LetIn + ~init:pre_res (List.map (fun (id,t,b) -> Name(Hashtbl.find tbl id), t,b) new_predicates) ) princ_type_info.params - - -let change_property_sort toSort princ princName = - let princ_info = compute_elim_sig princ in - let change_sort_in_predicate (x,v,t) = + + +let change_property_sort toSort princ princName = + let princ_info = compute_elim_sig princ in + let change_sort_in_predicate (x,v,t) = (x,None, - let args,_ = decompose_prod t in + let args,_ = decompose_prod t in compose_prod args (mkSort toSort) ) - in - let princName_as_constr = Tacinterp.constr_of_id (Global.env ()) princName in - let init = - let nargs = (princ_info.nparams + (List.length princ_info.predicates)) in + in + let princName_as_constr = Tacinterp.constr_of_id (Global.env ()) princName in + let init = + let nargs = (princ_info.nparams + (List.length princ_info.predicates)) in mkApp(princName_as_constr, Array.init nargs (fun i -> mkRel (nargs - i ))) in it_mkLambda_or_LetIn - ~init: - (it_mkLambda_or_LetIn ~init + ~init: + (it_mkLambda_or_LetIn ~init (List.map change_sort_in_predicate princ_info.predicates) ) princ_info.params - -let pp_dur time time' = + +let pp_dur time time' = str (string_of_float (System.time_difference time time')) (* let qed () = save_named true *) -let defined () = - try - Command.save_named false - with +let defined () = + try + Command.save_named false + with | UserError("extract_proof",msg) -> Util.errorlabstrm "defined" @@ -318,7 +318,7 @@ let defined () = let build_functional_principle interactive_proof old_princ_type sorts funs i proof_tac hook = (* First we get the type of the old graph principle *) - let mutr_nparams = (compute_elim_sig old_princ_type).nparams in + let mutr_nparams = (compute_elim_sig old_princ_type).nparams in (* let time1 = System.get_time () in *) let new_principle_type = compute_new_princ_type_from_rel @@ -346,7 +346,7 @@ let build_functional_principle interactive_proof old_princ_type sorts funs i pro (* let dur1 = System.time_difference tim1 tim2 in *) (* Pp.msgnl (str ("Time to compute proof: ") ++ str (string_of_float dur1)); *) (* end; *) - get_proof_clean true + get_proof_clean true end @@ -355,8 +355,8 @@ let generate_functional_principle interactive_proof old_princ_type sorts new_princ_name funs i proof_tac = - try - + try + let f = funs.(i) in let type_sort = Termops.new_sort_in_family InType in let new_sorts = @@ -395,8 +395,8 @@ let generate_functional_principle Decl_kinds.IsDefinition (Decl_kinds.Scheme) ) ); - Flags.if_verbose - (fun id -> Pp.msgnl (Ppconstr.pr_id id ++ str " is defined")) + Flags.if_verbose + (fun id -> Pp.msgnl (Ppconstr.pr_id id ++ str " is defined")) name; names := name :: !names in @@ -404,21 +404,21 @@ let generate_functional_principle register_with_sort InSet in let (id,(entry,g_kind,hook)) = - build_functional_principle interactive_proof old_princ_type new_sorts funs i proof_tac hook + build_functional_principle interactive_proof old_princ_type new_sorts funs i proof_tac hook in (* Pr 1278 : Don't forget to close the goal if an error is raised !!!! - *) + *) save false new_princ_name entry g_kind hook - with e -> + with e -> begin - begin - try - let id = Pfedit.get_current_proof_name () in - let s = string_of_id id in + begin + try + let id = Pfedit.get_current_proof_name () in + let s = string_of_id id in let n = String.length "___________princ_________" in - if String.length s >= n - then if String.sub s 0 n = "___________princ_________" + if String.length s >= n + then if String.sub s 0 n = "___________princ_________" then Pfedit.delete_current_proof () else () else () @@ -431,24 +431,24 @@ let generate_functional_principle exception Not_Rec -let get_funs_constant mp dp = - let rec get_funs_constant const e : (Names.constant*int) array = - match kind_of_term ((strip_lam e)) with - | Fix((_,(na,_,_))) -> - Array.mapi - (fun i na -> - match na with - | Name id -> - let const = make_con mp dp (label_of_id id) in +let get_funs_constant mp dp = + let rec get_funs_constant const e : (Names.constant*int) array = + match kind_of_term ((strip_lam e)) with + | Fix((_,(na,_,_))) -> + Array.mapi + (fun i na -> + match na with + | Name id -> + let const = make_con mp dp (label_of_id id) in const,i - | Anonymous -> - anomaly "Anonymous fix" + | Anonymous -> + anomaly "Anonymous fix" ) na | _ -> [|const,0|] in - function const -> - let find_constant_body const = + function const -> + let find_constant_body const = match (Global.lookup_constant const ).const_body with | Some b -> let body = force b in @@ -462,97 +462,97 @@ let get_funs_constant mp dp = | None -> error ( "Cannot define a principle over an axiom ") in let f = find_constant_body const in - let l_const = get_funs_constant const f in - (* - We need to check that all the functions found are in the same block + let l_const = get_funs_constant const f in + (* + We need to check that all the functions found are in the same block to prevent Reset stange thing - *) - let l_bodies = List.map find_constant_body (Array.to_list (Array.map fst l_const)) in - let l_params,l_fixes = List.split (List.map decompose_lam l_bodies) in - (* all the paremeter must be equal*) - let _check_params = - let first_params = List.hd l_params in - List.iter - (fun params -> - if not ((=) first_params params) + *) + let l_bodies = List.map find_constant_body (Array.to_list (Array.map fst l_const)) in + let l_params,l_fixes = List.split (List.map decompose_lam l_bodies) in + (* all the paremeter must be equal*) + let _check_params = + let first_params = List.hd l_params in + List.iter + (fun params -> + if not ((=) first_params params) then error "Not a mutal recursive block" ) l_params in - (* The bodies has to be very similar *) - let _check_bodies = - try - let extract_info is_first body = - match kind_of_term body with + (* The bodies has to be very similar *) + let _check_bodies = + try + let extract_info is_first body = + match kind_of_term body with | Fix((idxs,_),(na,ta,ca)) -> (idxs,na,ta,ca) - | _ -> - if is_first && (List.length l_bodies = 1) + | _ -> + if is_first && (List.length l_bodies = 1) then raise Not_Rec else error "Not a mutal recursive block" in - let first_infos = extract_info true (List.hd l_bodies) in + let first_infos = extract_info true (List.hd l_bodies) in let check body = (* Hope this is correct *) - if not (first_infos = (extract_info false body)) + if not (first_infos = (extract_info false body)) then error "Not a mutal recursive block" - in + in List.iter check l_bodies with Not_Rec -> () in l_const -exception No_graph_found -exception Found_type of int +exception No_graph_found +exception Found_type of int -let make_scheme (fas : (constant*Rawterm.rawsort) list) : Entries.definition_entry list = - let env = Global.env () +let make_scheme (fas : (constant*Rawterm.rawsort) list) : Entries.definition_entry list = + let env = Global.env () and sigma = Evd.empty in - let funs = List.map fst fas in - let first_fun = List.hd funs in + let funs = List.map fst fas in + let first_fun = List.hd funs in let funs_mp,funs_dp,_ = Names.repr_con first_fun in - let first_fun_kn = - try - fst (find_Function_infos first_fun).graph_ind - with Not_found -> raise No_graph_found + let first_fun_kn = + try + fst (find_Function_infos first_fun).graph_ind + with Not_found -> raise No_graph_found in let this_block_funs_indexes = get_funs_constant funs_mp funs_dp first_fun in - let this_block_funs = Array.map fst this_block_funs_indexes in + let this_block_funs = Array.map fst this_block_funs_indexes in let prop_sort = InProp in - let funs_indexes = - let this_block_funs_indexes = Array.to_list this_block_funs_indexes in + let funs_indexes = + let this_block_funs_indexes = Array.to_list this_block_funs_indexes in List.map (function const -> List.assoc const this_block_funs_indexes) funs in - let ind_list = - List.map - (fun (idx) -> - let ind = first_fun_kn,idx in + let ind_list = + List.map + (fun (idx) -> + let ind = first_fun_kn,idx in let (mib,mip) = Global.lookup_inductive ind in ind,mib,mip,true,prop_sort ) funs_indexes in - let l_schemes = + let l_schemes = List.map - (Typing.type_of env sigma) + (Typing.type_of env sigma) (Indrec.build_mutual_indrec env sigma ind_list) - in + in let i = ref (-1) in - let sorts = - List.rev_map (fun (_,x) -> + let sorts = + List.rev_map (fun (_,x) -> Termops.new_sort_in_family (Pretyping.interp_elimination_sort x) - ) - fas + ) + fas in (* We create the first priciple by tactic *) - let first_type,other_princ_types = - match l_schemes with + let first_type,other_princ_types = + match l_schemes with s::l_schemes -> s,l_schemes | _ -> anomaly "" in - let (_,(const,_,_)) = + let (_,(const,_,_)) = try build_functional_principle false first_type @@ -561,15 +561,15 @@ let make_scheme (fas : (constant*Rawterm.rawsort) list) : Entries.definition_ent 0 (prove_princ_for_struct false 0 (Array.of_list funs)) (fun _ _ _ -> ()) - with e -> + with e -> begin - begin - try - let id = Pfedit.get_current_proof_name () in - let s = string_of_id id in + begin + try + let id = Pfedit.get_current_proof_name () in + let s = string_of_id id in let n = String.length "___________princ_________" in - if String.length s >= n - then if String.sub s 0 n = "___________princ_________" + if String.length s >= n + then if String.sub s 0 n = "___________princ_________" then Pfedit.delete_current_proof () else () else () @@ -578,71 +578,71 @@ let make_scheme (fas : (constant*Rawterm.rawsort) list) : Entries.definition_ent raise (Defining_principle e) end - in + 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 *) + 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 + let const = {const with const_entry_opaque = opacity } in (* The others are just deduced *) - if other_princ_types = [] + if other_princ_types = [] then [const] else - let other_fun_princ_types = - let funs = Array.map mkConst this_block_funs in - let sorts = Array.of_list sorts in + let other_fun_princ_types = + let funs = Array.map mkConst this_block_funs in + let sorts = Array.of_list sorts in List.map (compute_new_princ_type_from_rel funs sorts) other_princ_types in - let first_princ_body,first_princ_type = const.Entries.const_entry_body, const.Entries.const_entry_type in + let first_princ_body,first_princ_type = const.Entries.const_entry_body, const.Entries.const_entry_type in let ctxt,fix = decompose_lam_assum first_princ_body in (* the principle has for forall ...., fix .*) - let (idxs,_),(_,ta,_ as decl) = destFix fix in - let other_result = + let (idxs,_),(_,ta,_ as decl) = destFix fix in + let other_result = List.map (* we can now compute the other principles *) - (fun scheme_type -> + (fun scheme_type -> incr i; observe (Printer.pr_lconstr scheme_type); - let type_concl = (strip_prod_assum scheme_type) in - let applied_f = List.hd (List.rev (snd (decompose_app type_concl))) in + let type_concl = (strip_prod_assum scheme_type) in + let applied_f = List.hd (List.rev (snd (decompose_app type_concl))) in let f = fst (decompose_app applied_f) in try (* we search the number of the function in the fix block (name of the function) *) - Array.iteri - (fun j t -> - let t = (strip_prod_assum t) in - let applied_g = List.hd (List.rev (snd (decompose_app t))) in + Array.iteri + (fun j t -> + let t = (strip_prod_assum t) in + let applied_g = List.hd (List.rev (snd (decompose_app t))) in let g = fst (decompose_app applied_g) in if eq_constr f g - then raise (Found_type j); + then raise (Found_type j); observe (Printer.pr_lconstr f ++ str " <> " ++ Printer.pr_lconstr g) - + ) ta; - (* If we reach this point, the two principle are not mutually recursive - We fall back to the previous method + (* If we reach this point, the two principle are not mutually recursive + We fall back to the previous method *) - let (_,(const,_,_)) = + let (_,(const,_,_)) = build_functional_principle - false + false (List.nth other_princ_types (!i - 1)) (Array.of_list sorts) this_block_funs !i (prove_princ_for_struct false !i (Array.of_list funs)) (fun _ _ _ -> ()) - in + in const - with Found_type i -> - let princ_body = + with Found_type i -> + let princ_body = Termops.it_mkLambda_or_LetIn ~init:(mkFix((idxs,i),decl)) ctxt - in - {const with - Entries.const_entry_body = princ_body; + in + {const with + Entries.const_entry_body = princ_body; Entries.const_entry_type = Some scheme_type } ) @@ -650,51 +650,51 @@ let make_scheme (fas : (constant*Rawterm.rawsort) list) : Entries.definition_ent in const::other_result -let build_scheme fas = +let build_scheme fas = Dumpglob.pause (); - let bodies_types = - make_scheme - (List.map - (fun (_,f,sort) -> + let bodies_types = + make_scheme + (List.map + (fun (_,f,sort) -> let f_as_constant = try - match Nametab.global f with - | Libnames.ConstRef c -> c + match Nametab.global f with + | Libnames.ConstRef c -> c | _ -> Util.error "Functional Scheme can only be used with functions" with Not_found -> Util.error ("Cannot find "^ Libnames.string_of_reference f) in (f_as_constant,sort) - ) + ) fas - ) - in - List.iter2 - (fun (princ_id,_,_) def_entry -> - ignore - (Declare.declare_constant - princ_id + ) + in + List.iter2 + (fun (princ_id,_,_) def_entry -> + ignore + (Declare.declare_constant + princ_id (Entries.DefinitionEntry def_entry,Decl_kinds.IsProof Decl_kinds.Theorem)); - Flags.if_verbose + Flags.if_verbose (fun id -> Pp.msgnl (Ppconstr.pr_id id ++ str " is defined")) princ_id ) fas bodies_types; Dumpglob.continue () - -let build_case_scheme fa = - let env = Global.env () + +let build_case_scheme fa = + let env = Global.env () and sigma = Evd.empty in (* let id_to_constr id = *) (* Tacinterp.constr_of_id env id *) (* in *) - let funs = (fun (_,f,_) -> + let funs = (fun (_,f,_) -> try Libnames.constr_of_global (Nametab.global f) - with Not_found -> - Util.error ("Cannot find "^ Libnames.string_of_reference f)) fa in - let first_fun = destConst funs in + with Not_found -> + Util.error ("Cannot find "^ Libnames.string_of_reference f)) fa in + let first_fun = destConst funs in let funs_mp,funs_dp,_ = Names.repr_con first_fun in let first_fun_kn = try fst (find_Function_infos first_fun).graph_ind with Not_found -> raise No_graph_found in @@ -702,17 +702,17 @@ let build_case_scheme fa = let this_block_funs_indexes = get_funs_constant funs_mp funs_dp first_fun in - let this_block_funs = Array.map fst this_block_funs_indexes in + let this_block_funs = Array.map fst this_block_funs_indexes in let prop_sort = InProp in - let funs_indexes = - let this_block_funs_indexes = Array.to_list this_block_funs_indexes in + let funs_indexes = + let this_block_funs_indexes = Array.to_list this_block_funs_indexes in List.assoc (destConst funs) this_block_funs_indexes in - let ind_fun = - let ind = first_fun_kn,funs_indexes in + let ind_fun = + let ind = first_fun_kn,funs_indexes in ind,prop_sort in - let scheme_type = (Typing.type_of env sigma ) ((fun (ind,sf) -> Indrec.make_case_gen env sigma ind sf) ind_fun) in + let scheme_type = (Typing.type_of env sigma ) ((fun (ind,sf) -> Indrec.make_case_gen env sigma ind sf) ind_fun) in let sorts = (fun (_,_,x) -> Termops.new_sort_in_family (Pretyping.interp_elimination_sort x) @@ -720,7 +720,7 @@ let build_case_scheme fa = fa in let princ_name = (fun (x,_,_) -> x) fa in - let _ = + let _ = (* Pp.msgnl (str "Generating " ++ Ppconstr.pr_id princ_name ++str " with " ++ pr_lconstr scheme_type ++ str " and " ++ (fun a -> prlist_with_sep spc (fun c -> pr_lconstr (mkConst c)) (Array.to_list a)) this_block_funs ); diff --git a/plugins/funind/functional_principles_types.mli b/plugins/funind/functional_principles_types.mli index cf28c6e6c2..fb04c6ec28 100644 --- a/plugins/funind/functional_principles_types.mli +++ b/plugins/funind/functional_principles_types.mli @@ -2,26 +2,26 @@ open Names open Term -val generate_functional_principle : +val generate_functional_principle : (* do we accept interactive proving *) bool -> - (* induction principle on rel *) + (* induction principle on rel *) types -> (* *) - sorts array option -> - (* Name of the new principle *) - (identifier) option -> + sorts array option -> + (* Name of the new principle *) + (identifier) option -> (* the compute functions to use *) - constant array -> + constant array -> (* We prove the nth- principle *) int -> (* The tactic to use to make the proof w.r the number of params *) - (constr array -> int -> Tacmach.tactic) -> + (constr array -> int -> Tacmach.tactic) -> unit -val compute_new_princ_type_from_rel : constr array -> sorts array -> +val compute_new_princ_type_from_rel : constr array -> sorts array -> types -> types diff --git a/plugins/funind/g_indfun.ml4 b/plugins/funind/g_indfun.ml4 index 28fec2e981..0e51eb7e1b 100644 --- a/plugins/funind/g_indfun.ml4 +++ b/plugins/funind/g_indfun.ml4 @@ -11,7 +11,7 @@ open Term open Names open Pp open Topconstr -open Indfun_common +open Indfun_common open Indfun open Genarg open Pcoq @@ -26,14 +26,14 @@ let pr_bindings prc prlc = function brk (1,1) ++ str "with" ++ brk (1,1) ++ Util.prlist_with_sep spc prc l | Rawterm.ExplicitBindings l -> - brk (1,1) ++ str "with" ++ brk (1,1) ++ + brk (1,1) ++ str "with" ++ brk (1,1) ++ 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 = +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)) @@ -45,10 +45,10 @@ let pr_fun_ind_using prc prlc _ opt_c = (prc,prlc)... *) let pr_with_bindings_typed prc prlc (c,bl) = - prc c ++ + 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 = +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)) @@ -67,46 +67,46 @@ END TACTIC EXTEND newfuninv - [ "functional" "inversion" quantified_hypothesis(hyp) reference_opt(fname) ] -> + [ "functional" "inversion" quantified_hypothesis(hyp) reference_opt(fname) ] -> [ Invfun.invfun hyp fname ] END -let pr_intro_as_pat prc _ _ pat = - match pat with +let pr_intro_as_pat prc _ _ pat = + match pat with | Some pat -> spc () ++ str "as" ++ spc () ++ pr_intro_pattern pat | None -> mt () ARGUMENT EXTEND with_names TYPED AS intro_pattern_opt PRINTED BY pr_intro_as_pat -| [ "as" simple_intropattern(ipat) ] -> [ Some ipat ] -| [] ->[ None ] +| [ "as" simple_intropattern(ipat) ] -> [ Some ipat ] +| [] ->[ None ] END TACTIC EXTEND newfunind - ["functional" "induction" ne_constr_list(cl) fun_ind_using(princl) with_names(pat)] -> - [ - let c = match cl with + ["functional" "induction" ne_constr_list(cl) fun_ind_using(princl) with_names(pat)] -> + [ + let c = match cl with | [] -> assert false - | [c] -> c + | [c] -> c | c::cl -> applist(c,cl) - in + in functional_induction true c princl pat ] END (***** debug only ***) TACTIC EXTEND snewfunind - ["soft" "functional" "induction" ne_constr_list(cl) fun_ind_using(princl) with_names(pat)] -> - [ - let c = match cl with + ["soft" "functional" "induction" ne_constr_list(cl) fun_ind_using(princl) with_names(pat)] -> + [ + let c = match cl with | [] -> assert false - | [c] -> c + | [c] -> c | c::cl -> applist(c,cl) - in + in functional_induction false c princl pat ] END @@ -130,8 +130,8 @@ ARGUMENT EXTEND auto_using' END let pr_rec_annotation2_aux s r id l = - str ("{"^s^" ") ++ Ppconstr.pr_constr_expr r ++ - Util.pr_opt Nameops.pr_id id ++ + str ("{"^s^" ") ++ Ppconstr.pr_constr_expr r ++ + Util.pr_opt Nameops.pr_id id ++ Pptactic.pr_auto_using Ppconstr.pr_constr_expr l ++ str "}" let pr_rec_annotation2 = function @@ -143,11 +143,11 @@ VERNAC ARGUMENT EXTEND rec_annotation2 PRINTED BY pr_rec_annotation2 [ "{" "struct" ident(id) "}"] -> [ Struct id ] | [ "{" "wf" constr(r) ident_opt(id) auto_using'(l) "}" ] -> [ Wf(r,id,l) ] -| [ "{" "measure" constr(r) ident_opt(id) auto_using'(l) "}" ] -> [ Mes(r,id,l) ] +| [ "{" "measure" constr(r) ident_opt(id) auto_using'(l) "}" ] -> [ Mes(r,id,l) ] END let pr_binder2 (idl,c) = - str "(" ++ Util.prlist_with_sep spc Nameops.pr_id idl ++ spc () ++ + str "(" ++ Util.prlist_with_sep spc Nameops.pr_id idl ++ spc () ++ str ": " ++ Ppconstr.pr_lconstr_expr c ++ str ")" VERNAC ARGUMENT EXTEND binder2 @@ -159,9 +159,9 @@ let make_binder2 (idl,c) = LocalRawAssum (List.map (fun id -> (Util.dummy_loc,Name id)) idl,Topconstr.default_binder_kind,c) let pr_rec_definition2 (id,bl,annot,type_,def) = - Nameops.pr_id id ++ spc () ++ Util.prlist_with_sep spc pr_binder2 bl ++ + Nameops.pr_id id ++ spc () ++ Util.prlist_with_sep spc pr_binder2 bl ++ Util.pr_opt pr_rec_annotation2 annot ++ spc () ++ str ":" ++ spc () ++ - Ppconstr.pr_lconstr_expr type_ ++ str " :=" ++ spc () ++ + Ppconstr.pr_lconstr_expr type_ ++ str " :=" ++ spc () ++ Ppconstr.pr_lconstr_expr def VERNAC ARGUMENT EXTEND rec_definition2 @@ -182,11 +182,11 @@ let make_rec_definitions2 (id,bl,annot,type_,def) = Pp.str "the recursive argument needs to be specified"); in let check_exists_args an = - try - let id = match an with - | Struct id -> id | Wf(_,Some id,_) -> id | Mes(_,Some id,_) -> id - | Wf(_,None,_) | Mes(_,None,_) -> failwith "check_exists_args" - in + try + let id = match an with + | Struct id -> id | Wf(_,Some id,_) -> id | Mes(_,Some id,_) -> id + | Wf(_,None,_) | Mes(_,None,_) -> failwith "check_exists_args" + in (try ignore(Util.list_index0 (Name id) names); annot with Not_found -> Util.user_err_loc (Util.dummy_loc,"Function", @@ -206,33 +206,33 @@ let make_rec_definitions2 (id,bl,annot,type_,def) = VERNAC COMMAND EXTEND Function ["Function" ne_rec_definition2_list_sep(recsl,"with")] -> - [ - do_generate_principle false (List.map make_rec_definitions2 recsl); - + [ + do_generate_principle false (List.map make_rec_definitions2 recsl); + ] END -let pr_fun_scheme_arg (princ_name,fun_name,s) = - Nameops.pr_id princ_name ++ str " :=" ++ spc() ++ str "Induction for " ++ - Libnames.pr_reference fun_name ++ spc() ++ str "Sort " ++ +let pr_fun_scheme_arg (princ_name,fun_name,s) = + Nameops.pr_id princ_name ++ str " :=" ++ spc() ++ str "Induction for " ++ + Libnames.pr_reference fun_name ++ spc() ++ str "Sort " ++ Ppconstr.pr_rawsort s VERNAC ARGUMENT EXTEND fun_scheme_arg PRINTED BY pr_fun_scheme_arg -| [ ident(princ_name) ":=" "Induction" "for" reference(fun_name) "Sort" sort(s) ] -> [ (princ_name,fun_name,s) ] -END +| [ ident(princ_name) ":=" "Induction" "for" reference(fun_name) "Sort" sort(s) ] -> [ (princ_name,fun_name,s) ] +END -let warning_error names e = - match e with - | Building_graph e -> - Pp.msg_warning - (str "Cannot define graph(s) for " ++ +let warning_error names e = + match e with + | Building_graph e -> + Pp.msg_warning + (str "Cannot define graph(s) for " ++ h 1 (prlist_with_sep (fun _ -> str","++spc ()) Libnames.pr_reference names) ++ if do_observe () then (spc () ++ Cerrors.explain_exn e) else mt ()) - | Defining_principle e -> + | Defining_principle e -> Pp.msg_warning - (str "Cannot define principle(s) for "++ + (str "Cannot define principle(s) for "++ h 1 (prlist_with_sep (fun _ -> str","++spc ()) Libnames.pr_reference names) ++ if do_observe () then Cerrors.explain_exn e else mt ()) | _ -> anomaly "" @@ -242,29 +242,29 @@ VERNAC COMMAND EXTEND NewFunctionalScheme ["Functional" "Scheme" ne_fun_scheme_arg_list_sep(fas,"with") ] -> [ begin - try + try Functional_principles_types.build_scheme fas - with Functional_principles_types.No_graph_found -> + with Functional_principles_types.No_graph_found -> begin - match fas with - | (_,fun_name,_)::_ -> + match fas with + | (_,fun_name,_)::_ -> begin begin make_graph (Nametab.global fun_name) end ; try Functional_principles_types.build_scheme fas - with Functional_principles_types.No_graph_found -> + with Functional_principles_types.No_graph_found -> Util.error ("Cannot generate induction principle(s)") - | e -> - let names = List.map (fun (_,na,_) -> na) fas in + | e -> + let names = List.map (fun (_,na,_) -> na) fas in warning_error names e - + end | _ -> assert false (* we can only have non empty list *) end - | e -> - let names = List.map (fun (_,na,_) -> na) fas in + | e -> + let names = List.map (fun (_,na,_) -> na) fas in warning_error names e end @@ -280,7 +280,7 @@ VERNAC COMMAND EXTEND NewFunctionalCase END (***** debug only ***) -VERNAC COMMAND EXTEND GenerateGraph +VERNAC COMMAND EXTEND GenerateGraph ["Generate" "graph" "for" reference(c)] -> [ make_graph (Nametab.global c) ] END @@ -296,7 +296,7 @@ let msg x = () ;; let pr_lconstr c = str "" let prconstr c = msg (str" " ++ Printer.pr_lconstr c ++ str"\n") let prlistconstr lc = List.iter prconstr lc let prstr s = msg(str s) -let prNamedConstr s c = +let prNamedConstr s c = begin msg(str ""); msg(str(s^"==>\n ") ++ Printer.pr_lconstr c ++ str "\n<==\n"); @@ -318,8 +318,8 @@ type fapp_info = { (** [constr_head_match(a b c) a] returns true, false otherwise. *) let constr_head_match u t= - if isApp u - then + if isApp u + then let uhd,args= destApp u in uhd=t else false @@ -328,28 +328,28 @@ let constr_head_match u t= [inu]. DeBruijn are not pushed, so some of them may be unbound in the result. *) let rec hdMatchSub inu (test: constr -> bool) : fapp_info list = - let subres = + let subres = match kind_of_term inu with - | Lambda (nm,tp,cstr) | Prod (nm,tp,cstr) -> + | Lambda (nm,tp,cstr) | Prod (nm,tp,cstr) -> hdMatchSub tp test @ hdMatchSub (lift 1 cstr) test | Fix (_,(lna,tl,bl)) -> (* not sure Fix is correct *) - Array.fold_left - (fun acc cstr -> acc @ hdMatchSub (lift (Array.length tl) cstr) test) + Array.fold_left + (fun acc cstr -> acc @ hdMatchSub (lift (Array.length tl) cstr) test) [] bl | _ -> (* Cofix will be wrong *) - fold_constr - (fun l cstr -> - l @ hdMatchSub cstr test) [] inu in + fold_constr + (fun l cstr -> + l @ hdMatchSub cstr test) [] inu in if not (test inu) then subres else let f,args = decompose_app inu in let freeset = Termops.free_rels inu in let max_rel = try Util.Intset.max_elt freeset with Not_found -> -1 in {fname = f; largs = args; free = Util.Intset.is_empty freeset; - max_rel = max_rel; onlyvars = List.for_all isVar args } + max_rel = max_rel; onlyvars = List.for_all isVar args } ::subres -let mkEq typ c1 c2 = +let mkEq typ c1 c2 = mkApp (Coqlib.build_coq_eq(),[| typ; c1; c2|]) @@ -357,11 +357,11 @@ let poseq_unsafe idunsafe cstr gl = let typ = Tacmach.pf_type_of gl cstr in tclTHEN (Tactics.letin_tac None (Name idunsafe) cstr None allHypsAndConcl) - (tclTHENFIRST - (Tactics.assert_tac Anonymous (mkEq typ (mkVar idunsafe) cstr)) + (tclTHENFIRST + (Tactics.assert_tac Anonymous (mkEq typ (mkVar idunsafe) cstr)) Tactics.reflexivity) gl - + let poseq id cstr gl = let x = Tactics.fresh_id [] id gl in @@ -374,11 +374,11 @@ let list_constr_largs = ref [] let rec poseq_list_ids_rec lcstr gl = match lcstr with | [] -> tclIDTAC gl - | c::lcstr' -> + | c::lcstr' -> match kind_of_term c with - | Var _ -> + | Var _ -> (list_constr_largs:=c::!list_constr_largs ; poseq_list_ids_rec lcstr' gl) - | _ -> + | _ -> let _ = prstr "c = " in let _ = prconstr c in let _ = prstr "\n" in @@ -395,16 +395,16 @@ let rec poseq_list_ids_rec lcstr gl = (poseq_list_ids_rec lcstr') gl -let poseq_list_ids lcstr gl = +let poseq_list_ids lcstr gl = let _ = list_constr_largs := [] in poseq_list_ids_rec lcstr gl (** [find_fapp test g] returns the list of [app_info] of all calls to functions that satisfy [test] in the conclusion of goal g. Trivial repetition (not modulo conversion) are deleted. *) -let find_fapp (test:constr -> bool) g : fapp_info list = +let find_fapp (test:constr -> bool) g : fapp_info list = let pre_res = hdMatchSub (Tacmach.pf_concl g) test in - let res = + let res = List.fold_right (fun x acc -> if List.mem x acc then acc else x::acc) pre_res [] in (prlistconstr (List.map (fun x -> applist (x.fname,x.largs)) res); res) @@ -418,24 +418,24 @@ let find_fapp (test:constr -> bool) g : fapp_info list = let finduction (oid:identifier option) (heuristic: fapp_info list -> fapp_info list) (nexttac:Proof_type.tactic) g = let test = match oid with - | Some id -> + | Some id -> let idconstr = mkConst (const_of_id id) in (fun u -> constr_head_match u idconstr) (* select only id *) | None -> (fun u -> isApp u) in (* select calls to any function *) let info_list = find_fapp test g in let ordered_info_list = heuristic info_list in - prlistconstr (List.map (fun x -> applist (x.fname,x.largs)) ordered_info_list); + prlistconstr (List.map (fun x -> applist (x.fname,x.largs)) ordered_info_list); if List.length ordered_info_list = 0 then Util.error "function not found in goal\n"; - let taclist: Proof_type.tactic list = - List.map + let taclist: Proof_type.tactic list = + List.map (fun info -> (tclTHEN (tclTHEN (poseq_list_ids info.largs) ( - fun gl -> - (functional_induction - true (applist (info.fname, List.rev !list_constr_largs)) - None None) gl)) + fun gl -> + (functional_induction + true (applist (info.fname, List.rev !list_constr_largs)) + None None) gl)) nexttac)) ordered_info_list in (* we try each (f t u v) until one does not fail *) (* TODO: try also to mix functional schemes *) @@ -450,7 +450,7 @@ let finduction (oid:identifier option) (heuristic: fapp_info list -> fapp_info l let chose_heuristic (oi:int option) : fapp_info list -> fapp_info list = match oi with | Some i -> (fun l -> [ List.nth l (i-1) ]) (* occurrence was given by the user *) - | None -> + | None -> (* Default heuristic: put first occurrences where all arguments are *bound* (meaning already introduced) variables *) let ordering x y = @@ -464,11 +464,11 @@ let chose_heuristic (oi:int option) : fapp_info list -> fapp_info list = TACTIC EXTEND finduction - ["finduction" ident(id) natural_opt(oi)] -> - [ + ["finduction" ident(id) natural_opt(oi)] -> + [ match oi with | Some(n) when n<=0 -> Util.error "numerical argument must be > 0" - | _ -> + | _ -> let heuristic = chose_heuristic oi in finduction (Some id) heuristic tclIDTAC ] @@ -477,13 +477,13 @@ END TACTIC EXTEND fauto - [ "fauto" tactic(tac)] -> + [ "fauto" tactic(tac)] -> [ let heuristic = chose_heuristic None in finduction None heuristic (snd tac) ] | - [ "fauto" ] -> + [ "fauto" ] -> [ let heuristic = chose_heuristic None in finduction None heuristic tclIDTAC @@ -493,7 +493,7 @@ END TACTIC EXTEND poseq - [ "poseq" ident(x) constr(c) ] -> + [ "poseq" ident(x) constr(c) ] -> [ poseq x c ] END @@ -502,10 +502,10 @@ VERNAC COMMAND EXTEND Showindinfo END VERNAC COMMAND EXTEND MergeFunind - [ "Mergeschemes" "(" ident(id1) ne_ident_list(cl1) ")" - "with" "(" ident(id2) ne_ident_list(cl2) ")" "using" ident(id) ] -> - [ - let f1 = Constrintern.interp_constr Evd.empty (Global.env()) + [ "Mergeschemes" "(" ident(id1) ne_ident_list(cl1) ")" + "with" "(" ident(id2) ne_ident_list(cl2) ")" "using" ident(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 @@ -513,11 +513,11 @@ VERNAC COMMAND EXTEND MergeFunind 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 + 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 + 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 ] diff --git a/plugins/funind/indfun.ml b/plugins/funind/indfun.ml index 46da3a01d5..7cce53c7c3 100644 --- a/plugins/funind/indfun.ml +++ b/plugins/funind/indfun.ml @@ -7,13 +7,13 @@ open Libnames open Rawterm open Declarations -let is_rec_info scheme_info = - let test_branche min acc (_,_,br) = +let is_rec_info scheme_info = + let test_branche min acc (_,_,br) = acc || ( - let new_branche = - it_mkProd_or_LetIn mkProp (fst (decompose_prod_assum br)) in - let free_rels_in_br = Termops.free_rels new_branche in - let max = min + scheme_info.Tactics.npredicates in + let new_branche = + it_mkProd_or_LetIn mkProp (fst (decompose_prod_assum br)) in + let free_rels_in_br = Termops.free_rels new_branche in + let max = min + scheme_info.Tactics.npredicates in Util.Intset.exists (fun i -> i >= min && i< max) free_rels_in_br ) in @@ -28,38 +28,38 @@ let choose_dest_or_ind scheme_info = let functional_induction with_clean c princl pat = Dumpglob.pause (); - let res = let f,args = decompose_app c in - fun g -> - let princ,bindings, princ_type = - match princl with + let res = let f,args = decompose_app c in + fun g -> + let princ,bindings, princ_type = + match princl with | None -> (* No principle is given let's find the good one *) begin match kind_of_term f with | Const c' -> - let princ_option = + let princ_option = let finfo = (* we first try to find out a graph on f *) - try find_Function_infos c' - with Not_found -> + try find_Function_infos c' + with Not_found -> errorlabstrm "" (str "Cannot find induction information on "++ Printer.pr_lconstr (mkConst c') ) in - match Tacticals.elimination_sort_of_goal g with + match Tacticals.elimination_sort_of_goal g with | InProp -> finfo.prop_lemma | InSet -> finfo.rec_lemma | InType -> finfo.rect_lemma in let princ = (* then we get the principle *) 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 + 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*) - let princ_name = + let princ_name = Indrec.make_elimination_ident (id_of_label (con_label c')) (Tacticals.elimination_sort_of_goal g) in - try + try mkConst(const_of_id princ_name ) with Not_found -> (* This one is neither defined ! *) errorlabstrm "" (str "Cannot find induction principle for " @@ -67,57 +67,57 @@ let functional_induction with_clean c princl pat = in (princ,Rawterm.NoBindings, Tacmach.pf_type_of g princ) | _ -> raise (UserError("",str "functional induction must be used with a function" )) - + end - | Some ((princ,binding)) -> + | Some ((princ,binding)) -> princ,binding,Tacmach.pf_type_of g princ in - let princ_infos = Tactics.compute_elim_sig princ_type in + let princ_infos = Tactics.compute_elim_sig princ_type in let args_as_induction_constr = - let c_list = - if princ_infos.Tactics.farg_in_concl - then [c] else [] + let c_list = + if princ_infos.Tactics.farg_in_concl + then [c] else [] in - List.map (fun c -> Tacexpr.ElimOnConstr (c,NoBindings)) (args@c_list) - in - let princ' = Some (princ,bindings) in - let princ_vars = - List.fold_right - (fun a acc -> + List.map (fun c -> Tacexpr.ElimOnConstr (c,NoBindings)) (args@c_list) + in + let princ' = Some (princ,bindings) in + let princ_vars = + List.fold_right + (fun a acc -> try Idset.add (destVar a) acc with _ -> acc ) args Idset.empty in - let old_idl = List.fold_right Idset.add (Tacmach.pf_ids_of_hyps g) Idset.empty in - let old_idl = Idset.diff old_idl princ_vars in - let subst_and_reduce g = - if with_clean + let old_idl = List.fold_right Idset.add (Tacmach.pf_ids_of_hyps g) Idset.empty in + let old_idl = Idset.diff old_idl princ_vars in + let subst_and_reduce g = + if with_clean then - let idl = - map_succeed - (fun id -> + let idl = + map_succeed + (fun id -> if Idset.mem id old_idl then failwith "subst_and_reduce"; - id + id ) (Tacmach.pf_ids_of_hyps g) - in - let flag = + in + let flag = Rawterm.Cbv - {Rawterm.all_flags - with Rawterm.rDelta = false; + {Rawterm.all_flags + with Rawterm.rDelta = false; } in Tacticals.tclTHEN (Tacticals.tclMAP (fun id -> Tacticals.tclTRY (Equality.subst [id])) idl ) - (Hiddentac.h_reduce flag Tacticals.allHypsAndConcl) + (Hiddentac.h_reduce flag Tacticals.allHypsAndConcl) g - else Tacticals.tclIDTAC g - + else Tacticals.tclIDTAC g + in Tacticals.tclTHEN - (choose_dest_or_ind + (choose_dest_or_ind princ_infos args_as_induction_constr princ' @@ -128,12 +128,12 @@ let functional_induction with_clean c princl pat = in Dumpglob.continue (); res - - -type annot = - Struct of identifier + + +type annot = + Struct of identifier | Wf of Topconstr.constr_expr * identifier option * Topconstr.constr_expr list | Mes of Topconstr.constr_expr * identifier option * Topconstr.constr_expr list @@ -150,12 +150,12 @@ let rec abstract_rawconstr c = function 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) + Constrintern.intern_gen false sigma env ~impls:([],impls) ~allow_patvar:false ~ltacvars:([],[]) c -(* - Construct a fixpoint as a Rawterm +(* + Construct a fixpoint as a Rawterm and not as a constr *) let build_newrecursive @@ -192,7 +192,7 @@ let build_newrecursive States.unfreeze fs; def in recdef,rec_impls - + let compute_annot (name,annot,args,types,body) = let names = List.map snd (Topconstr.names_of_local_assums args) in @@ -207,124 +207,124 @@ let compute_annot (name,annot,args,types,body) = | Some r -> (name,r,args,types,body) -(* Checks whether or not the mutual bloc is recursive *) -let rec is_rec names = - let names = List.fold_right Idset.add names Idset.empty in - let check_id id names = Idset.mem id names in - let rec lookup names = function +(* Checks whether or not the mutual bloc is recursive *) +let rec is_rec names = + let names = List.fold_right Idset.add names Idset.empty in + let check_id id names = Idset.mem id names in + let rec lookup names = function | RVar(_,id) -> check_id id names | RRef _ | REvar _ | RPatVar _ | RSort _ | RHole _ | RDynamic _ -> false | RCast(_,b,_) -> lookup names b | RRec _ -> error "RRec not handled" - | RIf(_,b,_,lhs,rhs) -> + | 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 - (List.fold_left + | RLetTuple(_,nal,_,t,b) -> lookup names t || + lookup + (List.fold_left (fun acc na -> Nameops.name_fold Idset.remove na acc) names nal ) 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) = - let new_names = List.fold_right Idset.remove idl names in + and lookup_br names (_,idl,_,rt) = + let new_names = List.fold_right Idset.remove idl names in lookup new_names rt in lookup names -let prepare_body (name,annot,args,types,body) rt = - let n = (Topconstr.local_binders_length args) in +let prepare_body (name,annot,args,types,body) rt = + let n = (Topconstr.local_binders_length args) in (* Pp.msgnl (str "nb lambda to chop : " ++ str (string_of_int n) ++ fnl () ++Printer.pr_rawconstr rt); *) let fun_args,rt' = chop_rlambda_n n rt in (fun_args,rt') let derive_inversion fix_names = - try + try (* we first transform the fix_names identifier into their corresponding constant *) - let fix_names_as_constant = - List.map (fun id -> destConst (Tacinterp.constr_of_id (Global.env ()) id)) fix_names - in - (* - Then we check that the graphs have been defined - If one of the graphs haven't been defined + let fix_names_as_constant = + List.map (fun id -> destConst (Tacinterp.constr_of_id (Global.env ()) id)) fix_names + in + (* + Then we check that the graphs have been defined + If one of the graphs haven't been defined we do nothing *) List.iter (fun c -> ignore (find_Function_infos c)) fix_names_as_constant ; try - Invfun.derive_correctness + Invfun.derive_correctness Functional_principles_types.make_scheme - functional_induction + functional_induction fix_names_as_constant - (*i The next call to mk_rel_id is valid since we have just construct the graph + (*i The next call to mk_rel_id is valid since we have just construct the graph Ensures by : register_built - i*) + i*) (List.map (fun id -> destInd (Tacinterp.constr_of_id (Global.env ()) (mk_rel_id id))) fix_names ) - with e -> - msg_warning - (str "Cannot built inversion information" ++ + with e -> + msg_warning + (str "Cannot built inversion information" ++ if do_observe () then Cerrors.explain_exn e else mt ()) with _ -> () -let warning_error names e = - let e_explain e = - match e with +let warning_error names e = + let e_explain e = + match e with | ToShow e -> spc () ++ Cerrors.explain_exn e | _ -> if do_observe () then (spc () ++ Cerrors.explain_exn e) else mt () - in - match e with - | Building_graph e -> - Pp.msg_warning - (str "Cannot define graph(s) for " ++ + in + match e with + | Building_graph e -> + Pp.msg_warning + (str "Cannot define graph(s) for " ++ h 1 (prlist_with_sep (fun _ -> str","++spc ()) Ppconstr.pr_id names) ++ e_explain e) - | Defining_principle e -> + | Defining_principle e -> Pp.msg_warning - (str "Cannot define principle(s) for "++ + (str "Cannot define principle(s) for "++ h 1 (prlist_with_sep (fun _ -> str","++spc ()) Ppconstr.pr_id names) ++ e_explain e) | _ -> anomaly "" -let error_error names e = - let e_explain e = - match e with +let error_error names e = + let e_explain e = + match e with | ToShow e -> spc () ++ Cerrors.explain_exn e | _ -> if do_observe () then (spc () ++ Cerrors.explain_exn e) else mt () in - match e with - | Building_graph e -> - errorlabstrm "" - (str "Cannot define graph(s) for " ++ + match e with + | Building_graph e -> + errorlabstrm "" + (str "Cannot define graph(s) for " ++ h 1 (prlist_with_sep (fun _ -> str","++spc ()) Ppconstr.pr_id names) ++ e_explain e) | _ -> anomaly "" 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 -> + 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 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 - try + try (* We then register the Inductive graphs of the functions *) Rawterm_to_relation.build_inductive names funs_args funs_types recdefs; - if do_built + if do_built then begin - (*i The next call to mk_rel_id is valid since we have just construct the graph + (*i The next call to mk_rel_id is valid since we have just construct the graph Ensures by : do_built - i*) + i*) let f_R_mut = Ident (dummy_loc,mk_rel_id (List.nth names 0)) in let ind_kn = fst (locate_with_msg @@ -339,34 +339,34 @@ let generate_principle on_error locate_constant f_ref in - let funs_kn = Array.of_list (List.map fname_kn fix_rec_l) in - let _ = + let funs_kn = Array.of_list (List.map fname_kn fix_rec_l) in + let _ = list_map_i (fun i x -> - let princ = destConst (Indrec.lookup_eliminator (ind_kn,i) (InProp)) in + let princ = destConst (Indrec.lookup_eliminator (ind_kn,i) (InProp)) in let princ_type = Typeops.type_of_constant (Global.env()) princ in Functional_principles_types.generate_functional_principle - interactive_proof + interactive_proof princ_type None - None + None funs_kn i - (continue_proof 0 [|funs_kn.(i)|]) + (continue_proof 0 [|funs_kn.(i)|]) ) 0 fix_rec_l - in + in Array.iter (add_Function is_general) funs_kn; () end - with e -> - on_error names e + with e -> + on_error names e -let register_struct is_rec fixpoint_exprl = - match fixpoint_exprl with - | [((_,fname),_,bl,ret_type,body),_] when not is_rec -> +let register_struct is_rec fixpoint_exprl = + match fixpoint_exprl with + | [((_,fname),_,bl,ret_type,body),_] when not is_rec -> Command.declare_definition fname (Decl_kinds.Global,Flags.boxed_definitions (),Decl_kinds.Definition) @@ -375,65 +375,65 @@ let register_struct is_rec fixpoint_exprl = body (Some ret_type) (fun _ _ -> ()) - | _ -> + | _ -> Command.build_recursive fixpoint_exprl (Flags.boxed_definitions()) -let generate_correction_proof_wf f_ref tcc_lemma_ref +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 - (_: int) (_:Names.constant array) (_:Term.constr array) (_:int) : Tacmach.tactic = + (_: int) (_:Names.constant array) (_:Term.constr array) (_:int) : Tacmach.tactic = Functional_principles_proofs.prove_principle_for_gen (f_ref,functional_ref,eq_ref) tcc_lemma_ref is_mes rec_arg_num rec_arg_type relation let register_wf ?(is_mes=false) fname rec_impls wf_rel_expr wf_arg using_lemmas args ret_type body - pre_hook - = - let type_of_f = Command.generalize_constr_expr ret_type args in - let rec_arg_num = - let names = + pre_hook + = + let type_of_f = Command.generalize_constr_expr ret_type args in + let rec_arg_num = + let names = List.map snd - (Topconstr.names_of_local_assums args) - in - match wf_arg with - | None -> + (Topconstr.names_of_local_assums args) + in + match wf_arg with + | None -> if List.length names = 1 then 1 else error "Recursive argument must be specified" - | Some wf_arg -> - list_index (Name wf_arg) names + | Some wf_arg -> + list_index (Name wf_arg) names in - let unbounded_eq = - let f_app_args = - Topconstr.CAppExpl - (dummy_loc, + let unbounded_eq = + let f_app_args = + Topconstr.CAppExpl + (dummy_loc, (None,(Ident (dummy_loc,fname))) , - (List.map + (List.map (function - | _,Anonymous -> assert false + | _,Anonymous -> assert false | _,Name e -> (Topconstr.mkIdentC e) - ) + ) (Topconstr.names_of_local_assums args) ) - ) + ) in 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 + let eq = Command.generalize_constr_expr unbounded_eq args in let hook f_ref tcc_lemma_ref functional_ref eq_ref rec_arg_num rec_arg_type nb_args relation = - try - pre_hook + try + pre_hook (generate_correction_proof_wf f_ref tcc_lemma_ref is_mes functional_ref eq_ref rec_arg_num rec_arg_type nb_args relation ); derive_inversion [fname] - with e -> - (* No proof done *) + with e -> + (* No proof done *) () - in - Recdef.recursive_definition + in + Recdef.recursive_definition is_mes fname rec_impls type_of_f wf_rel_expr @@ -442,115 +442,115 @@ let register_wf ?(is_mes=false) fname rec_impls wf_rel_expr wf_arg using_lemmas hook using_lemmas - -let register_mes fname rec_impls wf_mes_expr wf_arg using_lemmas args ret_type body = - let wf_arg_type,wf_arg = - match wf_arg with - | None -> + +let register_mes fname rec_impls wf_mes_expr wf_arg using_lemmas args ret_type body = + let wf_arg_type,wf_arg = + match wf_arg with + | None -> begin - match args with - | [Topconstr.LocalRawAssum ([(_,Name x)],k,t)] -> t,x - | _ -> error "Recursive argument must be specified" + match args with + | [Topconstr.LocalRawAssum ([(_,Name x)],k,t)] -> t,x + | _ -> error "Recursive argument must be specified" end - | Some wf_args -> - try - match - List.find - (function - | Topconstr.LocalRawAssum(l,k,t) -> - List.exists - (function (_,Name id) -> id = wf_args | _ -> false) - l + | Some wf_args -> + try + match + List.find + (function + | Topconstr.LocalRawAssum(l,k,t) -> + List.exists + (function (_,Name id) -> id = wf_args | _ -> false) + l | _ -> false ) - args - with + args + with | Topconstr.LocalRawAssum(_,k,t) -> t,wf_args - | _ -> assert false - with Not_found -> assert false + | _ -> assert false + with Not_found -> assert false in - let ltof = - let make_dir l = make_dirpath (List.map id_of_string (List.rev l)) in - Libnames.Qualid (dummy_loc,Libnames.qualid_of_path + let ltof = + let make_dir l = make_dirpath (List.map id_of_string (List.rev l)) in + Libnames.Qualid (dummy_loc,Libnames.qualid_of_path (Libnames.make_path (make_dir ["Arith";"Wf_nat"]) (id_of_string "ltof"))) in - let fun_from_mes = - let applied_mes = + let fun_from_mes = + let applied_mes = Topconstr.mkAppC(wf_mes_expr,[Topconstr.mkIdentC wf_arg]) in - Topconstr.mkLambdaC ([(dummy_loc,Name wf_arg)],Topconstr.default_binder_kind,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 = + let wf_rel_from_mes = Topconstr.mkAppC(Topconstr.mkRefC ltof,[wf_arg_type;fun_from_mes]) in - register_wf ~is_mes:true fname rec_impls wf_rel_from_mes (Some wf_arg) + register_wf ~is_mes:true fname rec_impls wf_rel_from_mes (Some wf_arg) using_lemmas args ret_type body - - -let do_generate_principle on_error register_built interactive_proof fixpoint_exprl = - 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))] -> - let pre_hook = - generate_principle + + +let do_generate_principle on_error register_built interactive_proof fixpoint_exprl = + 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))] -> + let pre_hook = + generate_principle on_error true register_built - fixpoint_exprl + fixpoint_exprl recdefs true - in - if register_built + in + 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))] -> - let pre_hook = - generate_principle + | [(((_,name),Some (Mes (wf_mes,wf_x,using_lemmas)),args,types,body))] -> + let pre_hook = + generate_principle on_error true register_built - fixpoint_exprl + fixpoint_exprl recdefs true - in - if register_built + in + if register_built then register_mes name rec_impls wf_mes wf_x using_lemmas args types body pre_hook; true - | _ -> - let fix_names = - List.map (function ((_,name),_,_,_,_) -> name) fixpoint_exprl + | _ -> + let fix_names = + List.map (function ((_,name),_,_,_,_) -> name) fixpoint_exprl in let is_one_rec = is_rec fix_names in - let old_fixpoint_exprl = + let old_fixpoint_exprl = List.map (function - | (name,Some (Struct id),args,types,body),_ -> - let annot = - try Some (dummy_loc, id), Topconstr.CStructRec - with Not_found -> - raise (UserError("",str "Cannot find argument " ++ - Ppconstr.pr_id id)) - in - (name,annot,args,types,body),(None:Vernacexpr.decl_notation) - | (name,None,args,types,body),recdef -> + | (name,Some (Struct id),args,types,body),_ -> + let annot = + try Some (dummy_loc, id), Topconstr.CStructRec + with Not_found -> + raise (UserError("",str "Cannot find argument " ++ + Ppconstr.pr_id id)) + in + (name,annot,args,types,body),(None:Vernacexpr.decl_notation) + | (name,None,args,types,body),recdef -> let names = (Topconstr.names_of_local_assums args) in if is_one_rec recdef && List.length names > 1 then user_err_loc (dummy_loc,"Function", Pp.str "the recursive argument needs to be specified in Function") - else + else 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 + | (_,Some (Wf _),_,_,_),_ | (_,Some (Mes _),_,_,_),_-> + error ("Cannot use mutual definition with well-founded recursion or measure") - ) + ) (List.combine fixpoint_exprl recdefs) in - (* ok all the expressions are structural *) - let fix_names = - List.map (function ((_,name),_,_,_,_) -> name) fixpoint_exprl + (* ok all the expressions are structural *) + let fix_names = + 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; @@ -559,7 +559,7 @@ let do_generate_principle on_error register_built interactive_proof fixpoint_exp false register_built fixpoint_exprl - recdefs + recdefs interactive_proof (Functional_principles_proofs.prove_princ_for_struct interactive_proof); if register_built then derive_inversion fix_names; @@ -568,52 +568,52 @@ let do_generate_principle on_error register_built interactive_proof fixpoint_exp () open Topconstr -let rec add_args id new_args b = - match b with - | CRef r -> - begin match r with - | Libnames.Ident(loc,fname) when fname = id -> +let rec add_args id new_args b = + match b with + | CRef r -> + begin match r with + | Libnames.Ident(loc,fname) when fname = id -> CAppExpl(dummy_loc,(None,r),new_args) | _ -> b end | CFix _ | CCoFix _ -> anomaly "add_args : todo" - | CArrow(loc,b1,b2) -> + | CArrow(loc,b1,b2) -> CArrow(loc,add_args id new_args b1, add_args id new_args b2) - | CProdN(loc,nal,b1) -> + | CProdN(loc,nal,b1) -> CProdN(loc, - List.map (fun (nal,k,b2) -> (nal,k,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,nal,b1) -> CLambdaN(loc, - List.map (fun (nal,k,b2) -> (nal,k,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,b1,b2) -> CLetIn(loc,na,add_args id new_args b1,add_args id new_args b2) - | CAppExpl(loc,(pf,r),exprl) -> - begin - match r with - | Libnames.Ident(loc,fname) when fname = id -> + | CAppExpl(loc,(pf,r),exprl) -> + begin + match r with + | Libnames.Ident(loc,fname) when fname = id -> CAppExpl(loc,(pf,r),new_args@(List.map (add_args id new_args) exprl)) | _ -> CAppExpl(loc,(pf,r),List.map (add_args id new_args) exprl) end - | CApp(loc,(pf,b),bl) -> - CApp(loc,(pf,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,sty,b_option,cel,cal) -> + | 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)) -> + 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,b_option),b1,b2) -> 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, + + | 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), add_args id new_args b2, add_args id new_args b3 @@ -622,7 +622,7 @@ let rec add_args id new_args b = | CPatVar _ -> b | CEvar _ -> b | CSort _ -> b - | CCast(loc,b1,CastConv(ck,b2)) -> + | CCast(loc,b1,CastConv(ck,b2)) -> CCast(loc,add_args id new_args b1,CastConv(ck,add_args id new_args b2)) | CCast(loc,b1,CastCoerce) -> CCast(loc,add_args id new_args b1,CastCoerce) @@ -635,70 +635,70 @@ let rec add_args id new_args b = exception Stop of Topconstr.constr_expr -(* [chop_n_arrow n t] chops the [n] first arrows in [t] - Acts on Topconstr.constr_expr +(* [chop_n_arrow n t] chops the [n] first arrows in [t] + Acts on Topconstr.constr_expr *) -let rec chop_n_arrow n t = - if n <= 0 +let rec chop_n_arrow n t = + if n <= 0 then t (* If we have already removed all the arrows then return the type *) - else (* If not we check the form of [t] *) - match t with + else (* If not we check the form of [t] *) + match t with | Topconstr.CArrow(_,_,t) -> (* If we have an arrow, we discard it and recall [chop_n_arrow] *) chop_n_arrow (n-1) t - | Topconstr.CProdN(_,nal_ta',t') -> (* If we have a forall, to result are possible : + | Topconstr.CProdN(_,nal_ta',t') -> (* If we have a forall, to result are possible : either we need to discard more than the number of arrows contained in this product declaration then we just recall [chop_n_arrow] on - the remaining number of arrow to chop and [t'] we discard it and - recall [chop_n_arrow], either this product contains more arrows + the remaining number of arrow to chop and [t'] we discard it and + recall [chop_n_arrow], either this product contains more arrows than the number we need to chop and then we return the new type *) - begin - try + begin + try let new_n = - let rec aux (n:int) = function + let rec aux (n:int) = function [] -> n - | (nal,k,t'')::nal_ta' -> - let nal_l = List.length nal in + | (nal,k,t'')::nal_ta' -> + let nal_l = List.length nal in if n >= nal_l - then + then aux (n - nal_l) nal_ta' - else - let new_t' = + else + let new_t' = Topconstr.CProdN(dummy_loc, ((snd (list_chop n nal)),k,t'')::nal_ta',t') - in + in raise (Stop new_t') in aux n nal_ta' - in + in chop_n_arrow new_n t' with Stop t -> t end | _ -> anomaly "Not enough products" - -let rec get_args b t : Topconstr.local_binder list * - Topconstr.constr_expr * Topconstr.constr_expr = - match b with - | Topconstr.CLambdaN (loc, (nal_ta), b') -> + +let rec get_args b t : Topconstr.local_binder list * + Topconstr.constr_expr * Topconstr.constr_expr = + match b with + | Topconstr.CLambdaN (loc, (nal_ta), b') -> begin - let n = - (List.fold_left (fun n (nal,_,_) -> + let n = + (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,k,ta) -> - (Topconstr.LocalRawAssum (nal,k,ta))) nal_ta)@nal_tas, b'',t'' + let nal_tas,b'',t'' = get_args b' (chop_n_arrow n t) in + (List.map (fun (nal,k,ta) -> + (Topconstr.LocalRawAssum (nal,k,ta))) nal_ta)@nal_tas, b'',t'' end | _ -> [],b,t let make_graph (f_ref:global_reference) = - let c,c_body = - match f_ref with - | ConstRef c -> - begin try c,Global.lookup_constant c - with Not_found -> + let c,c_body = + match f_ref with + | ConstRef c -> + begin try c,Global.lookup_constant c + with Not_found -> raise (UserError ("",str "Cannot find " ++ Printer.pr_lconstr (mkConst c)) ) end | _ -> raise (UserError ("", str "Not a function reference") ) @@ -710,10 +710,10 @@ let make_graph (f_ref:global_reference) = | Some b -> let env = Global.env () in let body = (force b) in - let extern_body,extern_type = - with_full_print - (fun () -> - (Constrextern.extern_constr false env body, + let extern_body,extern_type = + with_full_print + (fun () -> + (Constrextern.extern_constr false env body, Constrextern.extern_type false env (Typeops.type_of_constant_type env c_body.const_type) ) @@ -721,48 +721,48 @@ let make_graph (f_ref:global_reference) = () in let (nal_tas,b,t) = get_args extern_body extern_type in - let expr_list = - match b with - | Topconstr.CFix(loc,l_id,fixexprl) -> - let l = + let expr_list = + match b with + | Topconstr.CFix(loc,l_id,fixexprl) -> + let l = List.map - (fun (id,(n,recexp),bl,t,b) -> + (fun (id,(n,recexp),bl,t,b) -> let loc, rec_id = Option.get n in - let new_args = - List.flatten - (List.map + let new_args = + List.flatten + (List.map (function | Topconstr.LocalRawDef (na,_)-> [] - | Topconstr.LocalRawAssum (nal,_,_) -> - List.map - (fun (loc,n) -> - CRef(Libnames.Ident(loc, Nameops.out_name n))) + | Topconstr.LocalRawAssum (nal,_,_) -> + List.map + (fun (loc,n) -> + CRef(Libnames.Ident(loc, Nameops.out_name n))) nal ) nal_tas ) in - let b' = add_args (snd 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 in l - | _ -> - let id = id_of_label (con_label c) in + | _ -> + let id = id_of_label (con_label c) in [((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))) + let mp,dp,_ = repr_con c in + List.iter + (fun ((_,id),_,_,_,_) -> add_Function false (make_con mp dp (label_of_id id))) expr_list); Dumpglob.continue () - + (* let make_graph _ = assert false *) - -let do_generate_principle = do_generate_principle warning_error true + +let do_generate_principle = do_generate_principle warning_error true diff --git a/plugins/funind/indfun_common.ml b/plugins/funind/indfun_common.ml index 3583c84484..06f3291fe6 100644 --- a/plugins/funind/indfun_common.ml +++ b/plugins/funind/indfun_common.ml @@ -24,13 +24,13 @@ let get_name avoid ?(default="H") = function | Name n -> Name n let array_get_start a = - try + try Array.init (Array.length a - 1) (fun i -> a.(i)) - with Invalid_argument "index out of bounds" -> + with Invalid_argument "index out of bounds" -> invalid_argument "array_get_start" - + let id_of_name = function Name id -> id | _ -> raise Not_found @@ -78,7 +78,7 @@ let chop_rlambda_n = match rt with | 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", str "chop_rlambda_n: Not enough Lambdas")) in @@ -107,11 +107,11 @@ let list_union_eq eq_fun l1 l2 = let list_add_set_eq eq_fun x l = if List.exists (eq_fun x) l then l else x::l - + let const_of_id id = - let _,princ_ref = + let _,princ_ref = qualid_of_reference (Libnames.Ident (Util.dummy_loc,id)) in try Nametab.locate_constant princ_ref @@ -119,7 +119,7 @@ let const_of_id id = let def_of_const t = match (Term.kind_of_term t) with - Term.Const sp -> + Term.Const sp -> (try (match (Global.lookup_constant sp) with {Declarations.const_body=Some c} -> Declarations.force c |_ -> assert false) @@ -127,17 +127,17 @@ let def_of_const t = |_ -> assert false let coq_constant s = - Coqlib.gen_constant_in_modules "RecursiveDefinition" + Coqlib.gen_constant_in_modules "RecursiveDefinition" (Coqlib.init_modules @ Coqlib.arith_modules) s;; let constant sl s = constr_of_global - (Nametab.locate (make_qualid(Names.make_dirpath + (Nametab.locate (make_qualid(Names.make_dirpath (List.map id_of_string (List.rev sl))) (id_of_string s)));; let find_reference sl s = - (Nametab.locate (make_qualid(Names.make_dirpath + (Nametab.locate (make_qualid(Names.make_dirpath (List.map id_of_string (List.rev sl))) (id_of_string s)));; @@ -146,7 +146,7 @@ let refl_equal = lazy(coq_constant "refl_equal") (*****************************************************************) (* Copy of the standart save mechanism but without the much too *) -(* slow reduction function *) +(* slow reduction function *) (*****************************************************************) open Declarations open Entries @@ -183,7 +183,7 @@ let save with_clean id const (locality,kind) hook = let extract_pftreestate pts = let pfterm,subgoals = Refiner.extract_open_pftreestate pts in - let tpfsigma = Refiner.evc_of_pftreestate pts in + let tpfsigma = Refiner.evc_of_pftreestate pts in let exl = Evarutil.non_instantiated tpfsigma in if subgoals <> [] or exl <> [] then Util.errorlabstrm "extract_proof" @@ -198,19 +198,19 @@ let extract_pftreestate pts = let nf_betaiotazeta = let clos_norm_flags flgs env sigma t = Closure.norm_val (Closure.create_clos_infos flgs env) (Closure.inject (Reductionops.nf_evar sigma t)) in - clos_norm_flags Closure.betaiotazeta + clos_norm_flags Closure.betaiotazeta let nf_betaiota = let clos_norm_flags flgs env sigma t = Closure.norm_val (Closure.create_clos_infos flgs env) (Closure.inject (Reductionops.nf_evar sigma t)) in - clos_norm_flags Closure.betaiota + clos_norm_flags Closure.betaiota let cook_proof do_reduce = - let pfs = Pfedit.get_pftreestate () + let pfs = Pfedit.get_pftreestate () (* and ident = Pfedit.get_current_proof_name () *) and (ident,strength,concl,hook) = Pfedit.current_proof_statement () in let env,sigma,pfterm = extract_pftreestate pfs in - let pfterm = + let pfterm = if do_reduce then nf_betaiota env sigma pfterm else pfterm @@ -228,32 +228,32 @@ let new_save_named opacity = let const = { const with const_entry_opaque = opacity } in save true id const persistence hook -let get_proof_clean do_reduce = - let result = cook_proof do_reduce in +let get_proof_clean do_reduce = + let result = cook_proof do_reduce in Pfedit.delete_current_proof (); result -let with_full_print f a = +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 = !Flags.raw_print in + let old_rawprint = !Flags.raw_print 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; Dumpglob.pause (); - try - let res = f a in + 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; Flags.raw_print := old_rawprint; Dumpglob.continue (); res - with - | e -> + 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; @@ -268,19 +268,19 @@ let with_full_print f a = (**********************) -type function_info = - { +type function_info = + { function_constant : constant; graph_ind : inductive; equation_lemma : constant option; correctness_lemma : constant option; - completeness_lemma : constant option; + completeness_lemma : constant option; rect_lemma : constant option; rec_lemma : constant option; prop_lemma : constant option; is_general : bool; (* Has this function been defined using general recursive definition *) } - + (* type function_db = function_info list *) @@ -290,54 +290,54 @@ type function_info = let from_function = ref Cmap.empty let from_graph = ref Indmap.empty (* -let rec do_cache_info finfo = function - | [] -> raise Not_found - | (finfo'::finfos as l) -> - if finfo' == finfo then l - else if finfo'.function_constant = finfo.function_constant +let rec do_cache_info finfo = function + | [] -> raise Not_found + | (finfo'::finfos as l) -> + if finfo' == finfo then l + else if finfo'.function_constant = finfo.function_constant then finfo::finfos else - let res = do_cache_info finfo finfos in + let res = do_cache_info finfo finfos in if res == finfos then l else finfo'::l - -let cache_Function (_,(finfos)) = - let new_tbl = + +let cache_Function (_,(finfos)) = + let new_tbl = try do_cache_info finfos !function_table with Not_found -> finfos::!function_table - in - if new_tbl != !function_table + in + if new_tbl != !function_table then function_table := new_tbl *) -let cache_Function (_,finfos) = +let cache_Function (_,finfos) = from_function := Cmap.add finfos.function_constant finfos !from_function; from_graph := Indmap.add finfos.graph_ind finfos !from_graph let load_Function _ = cache_Function let open_Function _ = cache_Function -let subst_Function (_,subst,finfos) = +let subst_Function (_,subst,finfos) = let do_subst_con c = fst (Mod_subst.subst_con subst c) and do_subst_ind (kn,i) = (Mod_subst.subst_kn subst kn,i) in - let function_constant' = do_subst_con finfos.function_constant in - let graph_ind' = do_subst_ind finfos.graph_ind 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 function_constant' = do_subst_con finfos.function_constant in + let graph_ind' = do_subst_ind finfos.graph_ind 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 && + 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 && - correctness_lemma' == finfos.correctness_lemma && - completeness_lemma' == finfos.completeness_lemma && - rect_lemma' == finfos.rect_lemma && - rec_lemma' == finfos.rec_lemma && - prop_lemma' == finfos.prop_lemma - then finfos + correctness_lemma' == finfos.correctness_lemma && + completeness_lemma' == finfos.completeness_lemma && + rect_lemma' == finfos.rect_lemma && + rec_lemma' == finfos.rec_lemma && + prop_lemma' == finfos.prop_lemma + then finfos else { function_constant = function_constant'; graph_ind = graph_ind'; @@ -355,25 +355,25 @@ let classify_Function infos = Libobject.Substitute infos let export_Function infos = Some infos -let discharge_Function (_,finfos) = +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' = 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 graph_ind' = Lib.discharge_inductive finfos.graph_ind + 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 && + if function_constant' == finfos.function_constant && + graph_ind' == finfos.graph_ind && equation_lemma' == finfos.equation_lemma && - correctness_lemma' == finfos.correctness_lemma && - completeness_lemma' == finfos.completeness_lemma && - rect_lemma' == finfos.rect_lemma && - rec_lemma' == finfos.rec_lemma && - prop_lemma' == finfos.prop_lemma - then Some finfos + correctness_lemma' == finfos.correctness_lemma && + completeness_lemma' == finfos.completeness_lemma && + rect_lemma' == finfos.rect_lemma && + rec_lemma' == finfos.rec_lemma && + prop_lemma' == finfos.prop_lemma + then Some finfos else Some { function_constant = function_constant' ; graph_ind = graph_ind' ; @@ -384,12 +384,12 @@ let discharge_Function (_,finfos) = rec_lemma = rec_lemma'; prop_lemma = prop_lemma' ; is_general = finfos.is_general - } + } open Term -let pr_info f_info = +let pr_info f_info = str "function_constant := " ++ Printer.pr_lconstr (mkConst f_info.function_constant)++ fnl () ++ - str "function_constant_type := " ++ + str "function_constant_type := " ++ (try Printer.pr_lconstr (Global.type_of_global (ConstRef f_info.function_constant)) with _ -> 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 () ++ @@ -397,15 +397,15 @@ let pr_info f_info = 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 () + str "graph_ind := " ++ Printer.pr_lconstr (mkInd f_info.graph_ind) ++ fnl () -let pr_table tb = - let l = Cmap.fold (fun k v acc -> v::acc) tb [] in +let pr_table tb = + let l = Cmap.fold (fun k v acc -> v::acc) tb [] in Util.prlist_with_sep fnl pr_info l -let in_Function,out_Function = +let in_Function,out_Function = Libobject.declare_object - {(Libobject.default_object "FUNCTIONS_DB") with + {(Libobject.default_object "FUNCTIONS_DB") with Libobject.cache_function = cache_Function; Libobject.load_function = load_Function; Libobject.classify_function = classify_Function; @@ -418,57 +418,57 @@ let in_Function,out_Function = (* Synchronisation with reset *) -let freeze () = +let freeze () = !from_function,!from_graph -let unfreeze (functions,graphs) = +let unfreeze (functions,graphs) = (* Pp.msgnl (str "unfreezing function_table : " ++ pr_table l); *) from_function := functions; from_graph := graphs -let init () = +let init () = (* Pp.msgnl (str "reseting function_table"); *) from_function := Cmap.empty; from_graph := Indmap.empty -let _ = +let _ = Summary.declare_summary "functions_db_sum" { Summary.freeze_function = freeze; Summary.unfreeze_function = unfreeze; Summary.init_function = init } -let find_or_none id = - try Some - (match Nametab.locate (qualid_of_ident id) with ConstRef c -> c | _ -> Util.anomaly "Not a constant" - ) +let find_or_none id = + try Some + (match Nametab.locate (qualid_of_ident id) with ConstRef c -> c | _ -> Util.anomaly "Not a constant" + ) with Not_found -> None -let find_Function_infos f = +let find_Function_infos f = Cmap.find f !from_function -let find_Function_of_graph ind = +let find_Function_of_graph ind = Indmap.find ind !from_graph - -let update_Function finfo = + +let update_Function finfo = (* Pp.msgnl (pr_info finfo); *) Lib.add_anonymous_leaf (in_Function finfo) - - -let add_Function is_general f = - let f_id = id_of_label (con_label f) in + + +let add_Function is_general f = + let f_id = id_of_label (con_label f) in let equation_lemma = find_or_none (mk_equation_id f_id) - and correctness_lemma = find_or_none (mk_correct_id f_id) - and completeness_lemma = find_or_none (mk_complete_id f_id) + and correctness_lemma = find_or_none (mk_correct_id f_id) + and completeness_lemma = find_or_none (mk_complete_id f_id) and rect_lemma = find_or_none (Nameops.add_suffix f_id "_rect") and rec_lemma = find_or_none (Nameops.add_suffix f_id "_rec") and prop_lemma = find_or_none (Nameops.add_suffix f_id "_ind") - and graph_ind = - match Nametab.locate (qualid_of_ident (mk_rel_id f_id)) + and graph_ind = + match Nametab.locate (qualid_of_ident (mk_rel_id f_id)) with | IndRef ind -> ind | _ -> Util.anomaly "Not an inductive" in - let finfos = + let finfos = { function_constant = f; equation_lemma = equation_lemma; completeness_lemma = completeness_lemma; @@ -478,7 +478,7 @@ let add_Function is_general f = prop_lemma = prop_lemma; graph_ind = graph_ind; is_general = is_general - + } in update_Function finfos @@ -486,7 +486,7 @@ let add_Function is_general f = let pr_table () = pr_table !from_function (*********************************) (* Debuging *) -let function_debug = ref false +let function_debug = ref false open Goptions let function_debug_sig = @@ -501,13 +501,13 @@ let function_debug_sig = let _ = declare_bool_option function_debug_sig -let do_observe () = +let do_observe () = !function_debug = true - - - + + + let strict_tcc = ref false -let is_strict_tcc () = !strict_tcc +let is_strict_tcc () = !strict_tcc let strict_tcc_sig = { optsync = false; @@ -520,29 +520,29 @@ let strict_tcc_sig = let _ = declare_bool_option strict_tcc_sig -exception Building_graph of exn +exception Building_graph of exn exception Defining_principle of exn exception ToShow of exn -let init_constant dir s = - try +let init_constant dir s = + try Coqlib.gen_constant "Function" dir s with e -> raise (ToShow e) -let jmeq () = - try - (Coqlib.check_required_library ["Coq";"Logic";"JMeq"]; +let jmeq () = + try + (Coqlib.check_required_library ["Coq";"Logic";"JMeq"]; init_constant ["Logic";"JMeq"] "JMeq") with e -> raise (ToShow e) -let jmeq_rec () = +let jmeq_rec () = try - Coqlib.check_required_library ["Coq";"Logic";"JMeq"]; + Coqlib.check_required_library ["Coq";"Logic";"JMeq"]; init_constant ["Logic";"JMeq"] "JMeq_rec" with e -> raise (ToShow e) -let jmeq_refl () = - try +let jmeq_refl () = + try Coqlib.check_required_library ["Coq";"Logic";"JMeq"]; init_constant ["Logic";"JMeq"] "JMeq_refl" with e -> raise (ToShow e) diff --git a/plugins/funind/indfun_common.mli b/plugins/funind/indfun_common.mli index e9aa692b61..87d646ab89 100644 --- a/plugins/funind/indfun_common.mli +++ b/plugins/funind/indfun_common.mli @@ -1,10 +1,10 @@ open Names open Pp -(* - The mk_?_id function build different name w.r.t. a function - Each of their use is justified in the code -*) +(* + The mk_?_id function build different name w.r.t. a function + Each of their use is justified in the code +*) val mk_rel_id : identifier -> identifier val mk_correct_id : identifier -> identifier val mk_complete_id : identifier -> identifier @@ -16,8 +16,8 @@ val msgnl : std_ppcmds -> unit val invalid_argument : string -> 'a val fresh_id : identifier list -> string -> identifier -val fresh_name : identifier list -> string -> name -val get_name : identifier list -> ?default:string -> name -> name +val fresh_name : identifier list -> string -> name +val get_name : identifier list -> ?default:string -> name -> name val array_get_start : 'a array -> 'a array @@ -46,11 +46,11 @@ val eq : Term.constr Lazy.t val refl_equal : Term.constr Lazy.t val const_of_id: identifier -> constant val jmeq : unit -> Term.constr -val jmeq_refl : unit -> Term.constr +val jmeq_refl : unit -> Term.constr + +(* [save_named] is a copy of [Command.save_named] but uses + [nf_betaiotazeta] instead of [nf_betaiotaevar_preserving_vm_cast] -(* [save_named] is a copy of [Command.save_named] but uses - [nf_betaiotazeta] instead of [nf_betaiotaevar_preserving_vm_cast] - DON'T USE IT if you cannot ensure that there is no VMcast in the proof @@ -59,32 +59,32 @@ val jmeq_refl : unit -> Term.constr (* val nf_betaiotazeta : Reductionops.reduction_function *) -val new_save_named : bool -> unit +val new_save_named : bool -> unit -val save : bool -> identifier -> Entries.definition_entry -> Decl_kinds.goal_kind -> - Tacexpr.declaration_hook -> unit +val save : bool -> identifier -> Entries.definition_entry -> Decl_kinds.goal_kind -> + Tacexpr.declaration_hook -> unit -(* [get_proof_clean do_reduce] : returns the proof name, definition, kind and hook and - abort the proof +(* [get_proof_clean do_reduce] : returns the proof name, definition, kind and hook and + abort the proof *) -val get_proof_clean : bool -> +val get_proof_clean : bool -> Names.identifier * (Entries.definition_entry * Decl_kinds.goal_kind * Tacexpr.declaration_hook) - -(* [with_full_print f a] applies [f] to [a] in full printing environment - - This function preserves the print settings + +(* [with_full_print f a] applies [f] to [a] in full printing environment + + This function preserves the print settings *) val with_full_print : ('a -> 'b) -> 'a -> 'b (*****************) -type function_info = - { +type function_info = + { function_constant : constant; graph_ind : inductive; equation_lemma : constant option; @@ -101,10 +101,10 @@ val find_Function_of_graph : inductive -> function_info (* WARNING: To be used just after the graph definition !!! *) val add_Function : bool -> constant -> unit -val update_Function : function_info -> unit +val update_Function : function_info -> unit -(** debugging *) +(** debugging *) val pr_info : function_info -> Pp.std_ppcmds val pr_table : unit -> Pp.std_ppcmds @@ -113,8 +113,8 @@ val pr_table : unit -> Pp.std_ppcmds val do_observe : unit -> bool (* To localize pb *) -exception Building_graph of exn +exception Building_graph of exn exception Defining_principle of exn -exception ToShow of exn +exception ToShow of exn val is_strict_tcc : unit -> bool diff --git a/plugins/funind/invfun.ml b/plugins/funind/invfun.ml index 5f8587408b..116a3c9913 100644 --- a/plugins/funind/invfun.ml +++ b/plugins/funind/invfun.ml @@ -22,7 +22,7 @@ open Hiddentac (* Some pretty printing function for debugging purpose *) -let pr_binding prc = +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) @@ -32,7 +32,7 @@ let pr_bindings prc prlc = function brk (1,1) ++ str "with" ++ brk (1,1) ++ Util.prlist_with_sep spc (fun (_,c) -> prc c) l | Rawterm.ExplicitBindings l -> - brk (1,1) ++ str "with" ++ brk (1,1) ++ + brk (1,1) ++ str "with" ++ brk (1,1) ++ Util.prlist_with_sep spc (fun b -> str"(" ++ pr_binding prlc b ++ str")") l | Rawterm.NoBindings -> mt () @@ -42,7 +42,7 @@ let pr_with_bindings prc prlc (c,bl) = -let pr_constr_with_binding prc (c,bl) : Pp.std_ppcmds = +let pr_constr_with_binding prc (c,bl) : Pp.std_ppcmds = pr_with_bindings prc prc (c,bl) (* The local debuging mechanism *) @@ -61,11 +61,11 @@ let observennl strm = let do_observe_tac s tac g = let goal = begin try (Printer.pr_goal (sig_it g)) with _ -> assert false end in - try + 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 ); + msgnl (str "observation "++ s++str " raised exception " ++ + Cerrors.explain_exn e ++ str " on goal " ++ goal ); raise e;; @@ -75,117 +75,117 @@ let observe_tac s tac g = else tac g (* [nf_zeta] $\zeta$-normalization of a term *) -let nf_zeta = +let nf_zeta = Reductionops.clos_norm_flags (Closure.RedFlags.mkflags [Closure.RedFlags.fZETA]) Environ.empty_env Evd.empty (* [id_to_constr id] finds the term associated to [id] in the global environment *) -let id_to_constr id = +let id_to_constr id = try Tacinterp.constr_of_id (Global.env ()) id - with Not_found -> + with Not_found -> raise (UserError ("",str "Cannot find " ++ Ppconstr.pr_id id)) -(* [generate_type g_to_f f graph i] build the completeness (resp. correctness) lemma type if [g_to_f = true] - (resp. g_to_f = false) where [graph] is the graph of [f] and is the [i]th function in the block. +(* [generate_type g_to_f f graph i] build the completeness (resp. correctness) lemma type if [g_to_f = true] + (resp. g_to_f = false) where [graph] is the graph of [f] and is the [i]th function in the block. - [generate_type true f i] returns - \[\forall (x_1:t_1)\ldots(x_n:t_n), let fv := f x_1\ldots x_n in, forall res, - graph\ x_1\ldots x_n\ res \rightarrow res = fv \] decomposed as the context and the conclusion + [generate_type true f i] returns + \[\forall (x_1:t_1)\ldots(x_n:t_n), let fv := f x_1\ldots x_n in, forall res, + graph\ x_1\ldots x_n\ res \rightarrow res = fv \] decomposed as the context and the conclusion - [generate_type false f i] returns - \[\forall (x_1:t_1)\ldots(x_n:t_n), let fv := f x_1\ldots x_n in, forall res, - res = fv \rightarrow graph\ x_1\ldots x_n\ res\] decomposed as the context and the conclusion + [generate_type false f i] returns + \[\forall (x_1:t_1)\ldots(x_n:t_n), let fv := f x_1\ldots x_n in, forall res, + res = fv \rightarrow graph\ x_1\ldots x_n\ res\] decomposed as the context and the conclusion *) -let generate_type g_to_f f graph i = +let generate_type g_to_f f graph i = (*i we deduce the number of arguments of the function and its returned type from the graph i*) - let graph_arity = Inductive.type_of_inductive (Global.env()) (Global.lookup_inductive (destInd graph)) in - let ctxt,_ = decompose_prod_assum graph_arity in - let fun_ctxt,res_type = - match ctxt with + let graph_arity = Inductive.type_of_inductive (Global.env()) (Global.lookup_inductive (destInd graph)) in + let ctxt,_ = decompose_prod_assum graph_arity in + let fun_ctxt,res_type = + match ctxt with | [] | [_] -> anomaly "Not a valid context" | (_,_,res_type)::fun_ctxt -> fun_ctxt,res_type in let nb_args = List.length fun_ctxt in - let args_from_decl i decl = - match decl with + let args_from_decl i decl = + match decl with | (_,Some _,_) -> incr i; failwith "args_from_decl" - | _ -> let j = !i in incr i;mkRel (nb_args - j + 1) + | _ -> let j = !i in incr i;mkRel (nb_args - j + 1) in (*i We need to name the vars [res] and [fv] i*) - let res_id = - Termops.next_global_ident_away + let res_id = + Termops.next_global_ident_away true (id_of_string "res") (map_succeed (function (Name id,_,_) -> id | (Anonymous,_,_) -> failwith "") fun_ctxt) in - let fv_id = - Termops.next_global_ident_away + let fv_id = + Termops.next_global_ident_away true (id_of_string "fv") (res_id::(map_succeed (function (Name id,_,_) -> id | (Anonymous,_,_) -> failwith "Anonymous!") fun_ctxt)) in (*i we can then type the argument to be applied to the function [f] i*) - let args_as_rels = + let args_as_rels = let i = ref 0 in - Array.of_list ((map_succeed (args_from_decl i) (List.rev fun_ctxt))) + Array.of_list ((map_succeed (args_from_decl i) (List.rev fun_ctxt))) in let args_as_rels = Array.map Termops.pop args_as_rels in (*i - the hypothesis [res = fv] can then be computed - We will need to lift it by one in order to use it as a conclusion + the hypothesis [res = fv] can then be computed + We will need to lift it by one in order to use it as a conclusion i*) let res_eq_f_of_args = mkApp(Coqlib.build_coq_eq (),[|lift 2 res_type;mkRel 1;mkRel 2|]) - in - (*i - The hypothesis [graph\ x_1\ldots x_n\ res] can then be computed - We will need to lift it by one in order to use it as a conclusion - i*) - let graph_applied = - let args_and_res_as_rels = + in + (*i + The hypothesis [graph\ x_1\ldots x_n\ res] can then be computed + We will need to lift it by one in order to use it as a conclusion + i*) + let graph_applied = + let args_and_res_as_rels = let i = ref 0 in Array.of_list ((map_succeed (args_from_decl i) (List.rev ((Name res_id,None,res_type)::fun_ctxt))) ) in - let args_and_res_as_rels = + let args_and_res_as_rels = Array.mapi (fun i c -> if i <> Array.length args_and_res_as_rels - 1 then lift 1 c else c) args_and_res_as_rels in - mkApp(graph,args_and_res_as_rels) - in - (*i The [pre_context] is the defined to be the context corresponding to + mkApp(graph,args_and_res_as_rels) + in + (*i The [pre_context] is the defined to be the context corresponding to \[\forall (x_1:t_1)\ldots(x_n:t_n), let fv := f x_1\ldots x_n in, forall res, \] i*) - let pre_ctxt = - (Name res_id,None,lift 1 res_type)::(Name fv_id,Some (mkApp(mkConst f,args_as_rels)),res_type)::fun_ctxt - in + let pre_ctxt = + (Name res_id,None,lift 1 res_type)::(Name fv_id,Some (mkApp(mkConst f,args_as_rels)),res_type)::fun_ctxt + in (*i and we can return the solution depending on which lemma type we are defining i*) - if g_to_f + if g_to_f then (Anonymous,None,graph_applied)::pre_ctxt,(lift 1 res_eq_f_of_args) else (Anonymous,None,res_eq_f_of_args)::pre_ctxt,(lift 1 graph_applied) -(* +(* [find_induction_principle f] searches and returns the [body] and the [type] of [f_rect] - + WARNING: while convertible, [type_of body] and [type] can be non equal *) -let find_induction_principle f = - let f_as_constant = match kind_of_term f with +let find_induction_principle f = + let f_as_constant = match kind_of_term f with | Const c' -> c' | _ -> error "Must be used with a function" in - let infos = find_Function_infos f_as_constant in - match infos.rect_lemma with - | None -> raise Not_found - | Some rect_lemma -> - let rect_lemma = mkConst rect_lemma in - let typ = Typing.type_of (Global.env ()) Evd.empty rect_lemma in + let infos = find_Function_infos f_as_constant in + match infos.rect_lemma with + | None -> raise Not_found + | Some rect_lemma -> + let rect_lemma = mkConst rect_lemma in + let typ = Typing.type_of (Global.env ()) Evd.empty rect_lemma in rect_lemma,typ - - + + (* let fname = *) (* match kind_of_term f with *) @@ -205,41 +205,41 @@ let find_induction_principle f = (* c,Typing.type_of (Global.env ()) Evd.empty c *) -let rec generate_fresh_id x avoid i = - if i == 0 - then [] +let rec generate_fresh_id x avoid i = + if i == 0 + then [] else - let id = Termops.next_global_ident_away true x avoid in + let id = Termops.next_global_ident_away true x avoid in id::(generate_fresh_id x (id::avoid) (pred i)) -(* [prove_fun_correct functional_induction funs_constr graphs_constr schemes lemmas_types_infos i ] - is the tactic used to prove correctness lemma. - +(* [prove_fun_correct functional_induction funs_constr graphs_constr schemes lemmas_types_infos i ] + is the tactic used to prove correctness lemma. + [functional_induction] is the tactic defined in [indfun] (dependency problem) [funs_constr], [graphs_constr] [schemes] [lemmas_types_infos] are the mutually recursive functions - (resp. graphs of the functions and principles and correctness lemma types) to prove correct. - + (resp. graphs of the functions and principles and correctness lemma types) to prove correct. + [i] is the indice of the function to prove correct - The lemma to prove if suppose to have been generated by [generate_type] (in $\zeta$ normal form that is + The lemma to prove if suppose to have been generated by [generate_type] (in $\zeta$ normal form that is it looks like~: - [\forall (x_1:t_1)\ldots(x_n:t_n), forall res, + [\forall (x_1:t_1)\ldots(x_n:t_n), forall res, res = f x_1\ldots x_n in, \rightarrow graph\ x_1\ldots x_n\ res] - The sketch of the proof is the following one~: + The sketch of the proof is the following one~: \begin{enumerate} \item intros until $x_n$ \item $functional\ induction\ (f.(i)\ x_1\ldots x_n)$ using schemes.(i) - \item for each generated branch intro [res] and [hres :res = f x_1\ldots x_n], rewrite [hres] and the + \item for each generated branch intro [res] and [hres :res = f x_1\ldots x_n], rewrite [hres] and the apply the corresponding constructor of the corresponding graph inductive. \end{enumerate} - + *) let prove_fun_correct functional_induction funs_constr graphs_constr schemes lemmas_types_infos i : tactic = fun g -> - (* first of all we recreate the lemmas types to be used as predicates of the induction principle + (* first of all we recreate the lemmas types to be used as predicates of the induction principle that is~: \[fun (x_1:t_1)\ldots(x_n:t_n)=> fun fv => fun res => res = fv \rightarrow graph\ x_1\ldots x_n\ res\] *) @@ -257,8 +257,8 @@ let prove_fun_correct functional_induction funs_constr graphs_constr schemes lem in (* we the get the definition of the graphs block *) let graph_ind = destInd graphs_constr.(i) in - let kn = fst graph_ind in - let mib,_ = Global.lookup_inductive graph_ind in + let kn = fst graph_ind in + let mib,_ = Global.lookup_inductive graph_ind in (* and the principle to use in this lemma in $\zeta$ normal form *) let f_principle,princ_type = schemes.(i) in let princ_type = nf_zeta princ_type in @@ -267,9 +267,9 @@ let prove_fun_correct functional_induction funs_constr graphs_constr schemes lem let nb_fun_args = nb_prod (pf_concl g) - 2 in let args_names = generate_fresh_id (id_of_string "x") [] nb_fun_args in let ids = args_names@(pf_ids_of_hyps g) in - (* Since we cannot ensure that the funcitonnal principle is defined in the + (* Since we cannot ensure that the funcitonnal principle is defined in the environement and due to the bug #1174, we will need to pose the principle - using a name + using a name *) let principle_id = Termops.next_global_ident_away true (id_of_string "princ") ids in let ids = principle_id :: ids in @@ -290,8 +290,8 @@ let prove_fun_correct functional_induction funs_constr graphs_constr schemes lem let eq_ind = Coqlib.build_coq_eq () in let eq_construct = mkConstruct((destInd eq_ind),1) in (* The next to referencies will be used to find out which constructor to apply in each branch *) - let ind_number = ref 0 - and min_constr_number = ref 0 in + let ind_number = ref 0 + and min_constr_number = ref 0 in (* The tactic to prove the ith branch of the principle *) let prove_branche i g = (* We get the identifiers of this branch *) @@ -317,18 +317,18 @@ let prove_fun_correct functional_induction funs_constr graphs_constr schemes lem (pre_args, tclTHEN (h_reduce (Rawterm.Unfold([Rawterm.all_occurrences_expr,EvalVarRef id])) allHyps) pre_tac ) - + else (pre_args,pre_tac) ) (pf_hyps g) ([],tclIDTAC) in - (* - We can then recompute the arguments of the constructor. - For each [hid] introduced by this branch, if [hid] has type + (* + We can then recompute the arguments of the constructor. + For each [hid] introduced by this branch, if [hid] has type $forall res, res=fv -> graph.(j)\ x_1\ x_n res$ the corresponding arguments of the constructor are - [ fv (hid fv (refl_equal fv)) ]. - + [ fv (hid fv (refl_equal fv)) ]. + If [hid] has another type the corresponding argument of the constructor is [hid] *) let constructor_args = @@ -360,21 +360,21 @@ let prove_fun_correct functional_induction funs_constr graphs_constr schemes lem let params_id = fst (list_chop princ_infos.nparams args_names) in (List.map mkVar params_id)@(List.rev constructor_args) in - (* We then get the constructor corresponding to this branch and - modifies the references has needed i.e. - if the constructor is the last one of the current inductive then - add one the number of the inductive to take and add the number of constructor of the previous - graph to the minimal constructor number + (* We then get the constructor corresponding to this branch and + modifies the references has needed i.e. + if the constructor is the last one of the current inductive then + add one the number of the inductive to take and add the number of constructor of the previous + graph to the minimal constructor number *) - let constructor = - let constructor_num = i - !min_constr_number in - let length = Array.length (mib.Declarations.mind_packets.(!ind_number).Declarations.mind_consnames) in + let constructor = + let constructor_num = i - !min_constr_number in + let length = Array.length (mib.Declarations.mind_packets.(!ind_number).Declarations.mind_consnames) in if constructor_num <= length - then - begin + then + begin (kn,!ind_number),constructor_num end - else + else begin incr ind_number; min_constr_number := !min_constr_number + length ; @@ -418,8 +418,8 @@ let prove_fun_correct functional_induction funs_constr graphs_constr schemes lem let param_names = fst (list_chop princ_infos.nparams args_names) in let params = List.map mkVar param_names in let lemmas = Array.to_list (Array.map (fun c -> applist(c,params)) lemmas) in - (* The bindings of the principle - that is the params of the principle and the different lemma types + (* The bindings of the principle + that is the params of the principle and the different lemma types *) let bindings = let params_bindings,avoid = @@ -435,7 +435,7 @@ let prove_fun_correct functional_induction funs_constr graphs_constr schemes lem let lemmas_bindings = List.rev (fst (List.fold_left2 (fun (bindings,avoid) (x,_,_) p -> - let id = Nameops.next_ident_away (Nameops.out_name x) avoid in + let id = Nameops.next_ident_away (Nameops.out_name x) avoid in (dummy_loc,Rawterm.NamedHyp id,inj_open (nf_zeta p))::bindings,id::avoid) ([],avoid) princ_infos.predicates @@ -451,7 +451,7 @@ let prove_fun_correct functional_induction funs_constr graphs_constr schemes lem (h_exact f_principle)); tclTHEN_i (observe_tac "functional_induction" ( - fun g -> + fun g -> observe (pr_constr_with_binding (Printer.pr_lconstr_env (pf_env g)) (mkVar principle_id,bindings)); functional_induction false (applist(funs_constr.(i),List.map mkVar args_names)) @@ -462,13 +462,13 @@ let prove_fun_correct functional_induction funs_constr graphs_constr schemes lem ] g -(* [generalize_dependent_of x hyp g] - generalize every hypothesis which depends of [x] but [hyp] +(* [generalize_dependent_of x hyp g] + generalize every hypothesis which depends of [x] but [hyp] *) -let generalize_dependent_of x hyp g = - tclMAP - (function - | (id,None,t) when not (id = hyp) && +let generalize_dependent_of x hyp g = + tclMAP + (function + | (id,None,t) when not (id = hyp) && (Termops.occur_var (pf_env g) x t) -> tclTHEN (h_generalize [mkVar id]) (thin [id]) | _ -> tclIDTAC ) @@ -479,86 +479,86 @@ let generalize_dependent_of x hyp g = - (* [intros_with_rewrite] do the intros in each branch and treat each new hypothesis + (* [intros_with_rewrite] do the intros in each branch and treat each new hypothesis (unfolding, substituting, destructing cases \ldots) *) -let rec intros_with_rewrite g = +let rec intros_with_rewrite g = observe_tac "intros_with_rewrite" intros_with_rewrite_aux g -and intros_with_rewrite_aux : tactic = - fun g -> - let eq_ind = Coqlib.build_coq_eq () in - match kind_of_term (pf_concl g) with - | Prod(_,t,t') -> - begin - match kind_of_term t with - | App(eq,args) when (eq_constr eq eq_ind) -> +and intros_with_rewrite_aux : tactic = + fun g -> + let eq_ind = Coqlib.build_coq_eq () in + match kind_of_term (pf_concl g) with + | Prod(_,t,t') -> + begin + match kind_of_term t with + | 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 + then + let id = pf_get_new_id (id_of_string "y") g in tclTHENSEQ [ h_intro id; - generalize_dependent_of (destVar args.(1)) id; + generalize_dependent_of (destVar args.(1)) id; tclTRY (Equality.rewriteLR (mkVar id)); intros_with_rewrite - ] + ] g else - begin - let id = pf_get_new_id (id_of_string "y") g in + begin + let id = pf_get_new_id (id_of_string "y") g in tclTHENSEQ[ h_intro id; tclTRY (Equality.rewriteLR (mkVar id)); intros_with_rewrite ] g end - | Ind _ when eq_constr t (Coqlib.build_coq_False ()) -> + | Ind _ when eq_constr t (Coqlib.build_coq_False ()) -> Tauto.tauto g - | Case(_,_,v,_) -> + | Case(_,_,v,_) -> tclTHENSEQ[ h_case false (v,Rawterm.NoBindings); intros_with_rewrite ] g - | LetIn _ -> + | LetIn _ -> tclTHENSEQ[ - h_reduce + h_reduce (Rawterm.Cbv - {Rawterm.all_flags - with Rawterm.rDelta = false; - }) + {Rawterm.all_flags + with Rawterm.rDelta = false; + }) onConcl ; intros_with_rewrite ] g - | _ -> - let id = pf_get_new_id (id_of_string "y") g in + | _ -> + let id = pf_get_new_id (id_of_string "y") g in tclTHENSEQ [ h_intro id;intros_with_rewrite] g end - | LetIn _ -> + | LetIn _ -> tclTHENSEQ[ - h_reduce + h_reduce (Rawterm.Cbv - {Rawterm.all_flags - with Rawterm.rDelta = false; - }) + {Rawterm.all_flags + with Rawterm.rDelta = false; + }) onConcl ; intros_with_rewrite ] g - | _ -> tclIDTAC g - -let rec reflexivity_with_destruct_cases g = - let destruct_case () = - try - match kind_of_term (snd (destApp (pf_concl g))).(2) with - | Case(_,_,v,_) -> + | _ -> tclIDTAC g + +let rec reflexivity_with_destruct_cases g = + let destruct_case () = + try + match kind_of_term (snd (destApp (pf_concl g))).(2) with + | Case(_,_,v,_) -> tclTHENSEQ[ h_case false (v,Rawterm.NoBindings); intros; - observe_tac "reflexivity_with_destruct_cases" reflexivity_with_destruct_cases + observe_tac "reflexivity_with_destruct_cases" reflexivity_with_destruct_cases ] | _ -> reflexivity with _ -> reflexivity @@ -566,13 +566,13 @@ let rec reflexivity_with_destruct_cases g = let eq_ind = Coqlib.build_coq_eq () in let discr_inject = Tacticals.onAllHypsAndConcl ( - fun sc g -> - match sc with + fun sc g -> + match sc with None -> tclIDTAC g - | Some id -> - 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 + | Some id -> + 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.discrHyp id g else if Equality.injectable (pf_env g) (project g) t1 t2 then tclTHENSEQ [Equality.injHyp id;thin [id];intros_with_rewrite] g @@ -583,10 +583,10 @@ let rec reflexivity_with_destruct_cases g = (tclFIRST [ reflexivity; tclTHEN (tclPROGRESS discr_inject) (destruct_case ()); - (* We reach this point ONLY if - the same value is matched (at least) two times + (* We reach this point ONLY if + the same value is matched (at least) two times along binding path. - In this case, either we have a discriminable hypothesis and we are done, + In this case, either we have a discriminable hypothesis and we are done, either at least an injectable one and we do the injection before continuing *) tclTHEN (tclPROGRESS discr_inject ) reflexivity_with_destruct_cases @@ -594,95 +594,95 @@ let rec reflexivity_with_destruct_cases g = g -(* [prove_fun_complete funs graphs schemes lemmas_types_infos i] - is the tactic used to prove completness lemma. - +(* [prove_fun_complete funs graphs schemes lemmas_types_infos i] + is the tactic used to prove completness lemma. + [funcs], [graphs] [schemes] [lemmas_types_infos] are the mutually recursive functions - (resp. definitions of the graphs of the functions, principles and correctness lemma types) to prove correct. - + (resp. definitions of the graphs of the functions, principles and correctness lemma types) to prove correct. + [i] is the indice of the function to prove complete - The lemma to prove if suppose to have been generated by [generate_type] (in $\zeta$ normal form that is + The lemma to prove if suppose to have been generated by [generate_type] (in $\zeta$ normal form that is it looks like~: - [\forall (x_1:t_1)\ldots(x_n:t_n), forall res, + [\forall (x_1:t_1)\ldots(x_n:t_n), forall res, graph\ x_1\ldots x_n\ res, \rightarrow res = f x_1\ldots x_n in] - The sketch of the proof is the following one~: + The sketch of the proof is the following one~: \begin{enumerate} \item intros until $H:graph\ x_1\ldots x_n\ res$ \item $elim\ H$ using schemes.(i) - \item for each generated branch, intro the news hyptohesis, for each such hyptohesis [h], if [h] has - type [x=?] with [x] a variable, then subst [x], - if [h] has type [t=?] with [t] not a variable then rewrite [t] in the subterms, else - if [h] is a match then destruct it, else do just introduce it, + \item for each generated branch, intro the news hyptohesis, for each such hyptohesis [h], if [h] has + type [x=?] with [x] a variable, then subst [x], + if [h] has type [t=?] with [t] not a variable then rewrite [t] in the subterms, else + if [h] is a match then destruct it, else do just introduce it, after all intros, the conclusion should be a reflexive equality. \end{enumerate} - + *) -let prove_fun_complete funcs graphs schemes lemmas_types_infos i : tactic = - fun g -> - (* We compute the types of the different mutually recursive lemmas +let prove_fun_complete funcs graphs schemes lemmas_types_infos i : tactic = + fun g -> + (* We compute the types of the different mutually recursive lemmas in $\zeta$ normal form *) - let lemmas = - Array.map - (fun (_,(ctxt,concl)) -> nf_zeta (Termops.it_mkLambda_or_LetIn ~init:concl ctxt)) + let lemmas = + Array.map + (fun (_,(ctxt,concl)) -> nf_zeta (Termops.it_mkLambda_or_LetIn ~init:concl ctxt)) lemmas_types_infos in (* We get the constant and the principle corresponding to this lemma *) let f = funcs.(i) in - let graph_principle = nf_zeta schemes.(i) in - let princ_type = pf_type_of g graph_principle in - let princ_infos = Tactics.compute_elim_sig princ_type in - (* Then we get the number of argument of the function + let graph_principle = nf_zeta schemes.(i) in + let princ_type = pf_type_of g graph_principle in + let princ_infos = Tactics.compute_elim_sig princ_type in + (* Then we get the number of argument of the function and compute a fresh name for each of them *) - let nb_fun_args = nb_prod (pf_concl g) - 2 in + let nb_fun_args = nb_prod (pf_concl g) - 2 in let args_names = generate_fresh_id (id_of_string "x") [] nb_fun_args in let ids = args_names@(pf_ids_of_hyps g) in (* and fresh names for res H and the principle (cf bug bug #1174) *) - let res,hres,graph_principle_id = - match generate_fresh_id (id_of_string "z") ids 3 with + let res,hres,graph_principle_id = + match generate_fresh_id (id_of_string "z") ids 3 with | [res;hres;graph_principle_id] -> res,hres,graph_principle_id - | _ -> assert false + | _ -> assert false in - let ids = res::hres::graph_principle_id::ids in + let ids = res::hres::graph_principle_id::ids in (* we also compute fresh names for each hyptohesis of each branche of the principle *) - let branches = List.rev princ_infos.branches in - let intro_pats = - List.map - (fun (_,_,br_type) -> - List.map - (fun id -> id) + let branches = List.rev princ_infos.branches in + let intro_pats = + List.map + (fun (_,_,br_type) -> + List.map + (fun id -> id) (generate_fresh_id (id_of_string "y") ids (nb_prod br_type)) ) branches in - (* We will need to change the function by its body - using [f_equation] if it is recursive (that is the graph is infinite - or unfold if the graph is finite + (* We will need to change the function by its body + using [f_equation] if it is recursive (that is the graph is infinite + or unfold if the graph is finite *) - let rewrite_tac j ids : tactic = - let graph_def = graphs.(j) in - let infos = try find_Function_infos (destConst funcs.(j)) with Not_found -> error "No graph found" in + let rewrite_tac j ids : tactic = + let graph_def = graphs.(j) in + let infos = try find_Function_infos (destConst funcs.(j)) with Not_found -> error "No graph found" in if infos.is_general || Rtree.is_infinite graph_def.mind_recargs - then - let eq_lemma = + then + let eq_lemma = try Option.get (infos).equation_lemma with Option.IsNone -> anomaly "Cannot find equation lemma" - in + in tclTHENSEQ[ tclMAP h_intro ids; Equality.rewriteLR (mkConst eq_lemma); (* Don't forget to $\zeta$ normlize the term since the principles have been $\zeta$-normalized *) - h_reduce + h_reduce (Rawterm.Cbv - {Rawterm.all_flags - with Rawterm.rDelta = false; - }) + {Rawterm.all_flags + with Rawterm.rDelta = false; + }) onConcl ; h_generalize (List.map mkVar ids); @@ -691,16 +691,16 @@ let prove_fun_complete funcs graphs schemes lemmas_types_infos i : tactic = else unfold_in_concl [(all_occurrences,Names.EvalConstRef (destConst f))] in (* The proof of each branche itself *) - let ind_number = ref 0 in + let ind_number = ref 0 in let min_constr_number = ref 0 in - let prove_branche i g = + let prove_branche i g = (* we fist compute the inductive corresponding to the branch *) - let this_ind_number = - let constructor_num = i - !min_constr_number in - let length = Array.length (graphs.(!ind_number).Declarations.mind_consnames) in + let this_ind_number = + let constructor_num = i - !min_constr_number in + let length = Array.length (graphs.(!ind_number).Declarations.mind_consnames) in if constructor_num <= length then !ind_number - else + else begin incr ind_number; min_constr_number := !min_constr_number + length; @@ -719,13 +719,13 @@ let prove_fun_complete funcs graphs schemes lemmas_types_infos i : tactic = g in let params_names = fst (list_chop princ_infos.nparams args_names) in - let params = List.map mkVar params_names in - tclTHENSEQ + let params = List.map mkVar params_names in + tclTHENSEQ [ tclMAP h_intro (args_names@[res;hres]); - observe_tac "h_generalize" + observe_tac "h_generalize" (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 "" (tclTHEN_i (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 )) ] @@ -737,94 +737,94 @@ let prove_fun_complete funcs graphs schemes lemmas_types_infos i : tactic = let do_save () = Command.save_named false -(* [derive_correctness make_scheme functional_induction funs graphs] create correctness and completeness +(* [derive_correctness make_scheme functional_induction funs graphs] create correctness and completeness lemmas for each function in [funs] w.r.t. [graphs] - - [make_scheme] is Functional_principle_types.make_scheme (dependency pb) and - [functional_induction] is Indfun.functional_induction (same pb) + + [make_scheme] is Functional_principle_types.make_scheme (dependency pb) and + [functional_induction] is Indfun.functional_induction (same pb) *) - -let derive_correctness make_scheme functional_induction (funs: constant list) (graphs:inductive list) = + +let derive_correctness make_scheme functional_induction (funs: constant list) (graphs:inductive list) = let funs = Array.of_list funs and graphs = Array.of_list graphs in let funs_constr = Array.map mkConst funs in - try - let graphs_constr = Array.map mkInd graphs in - let lemmas_types_infos = - Util.array_map2_i - (fun i f_constr graph -> - let const_of_f = destConst f_constr in - let (type_of_lemma_ctxt,type_of_lemma_concl) as type_info = + try + let graphs_constr = Array.map mkInd graphs in + let lemmas_types_infos = + Util.array_map2_i + (fun i f_constr graph -> + let const_of_f = destConst f_constr in + let (type_of_lemma_ctxt,type_of_lemma_concl) as type_info = generate_type false const_of_f graph i - in - let type_of_lemma = Termops.it_mkProd_or_LetIn ~init:type_of_lemma_concl type_of_lemma_ctxt in + in + let type_of_lemma = Termops.it_mkProd_or_LetIn ~init:type_of_lemma_concl type_of_lemma_ctxt in let type_of_lemma = nf_zeta type_of_lemma in observe (str "type_of_lemma := " ++ Printer.pr_lconstr type_of_lemma); type_of_lemma,type_info ) funs_constr - graphs_constr + graphs_constr in - let schemes = - (* The functional induction schemes are computed and not saved if there is more that one function + let schemes = + (* The functional induction schemes are computed and not saved if there is more that one function if the block contains only one function we can safely reuse [f_rect] *) try if Array.length funs_constr <> 1 then raise Not_found; [| find_induction_principle funs_constr.(0) |] - with Not_found -> - Array.of_list - (List.map - (fun entry -> + with Not_found -> + Array.of_list + (List.map + (fun entry -> (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)) ) in - let proving_tac = + let proving_tac = prove_fun_correct functional_induction funs_constr graphs_constr schemes lemmas_types_infos in - Array.iteri - (fun i f_as_constant -> + Array.iteri + (fun i f_as_constant -> let f_id = id_of_label (con_label f_as_constant) in - Command.start_proof + Command.start_proof (*i The next call to mk_correct_id is valid since we are constructing the lemma Ensures by: obvious - i*) + i*) (mk_correct_id f_id) (Decl_kinds.Global,(Decl_kinds.Proof Decl_kinds.Theorem)) (fst lemmas_types_infos.(i)) (fun _ _ -> ()); Pfedit.by (observe_tac ("prove correctness ("^(string_of_id f_id)^")") (proving_tac i)); do_save (); - let finfo = find_Function_infos f_as_constant in + let finfo = find_Function_infos f_as_constant in update_Function - {finfo with + {finfo with correctness_lemma = Some (destConst (Tacinterp.constr_of_id (Global.env ())(mk_correct_id f_id))) } ) funs; - let lemmas_types_infos = - Util.array_map2_i - (fun i f_constr graph -> - let const_of_f = destConst f_constr in - let (type_of_lemma_ctxt,type_of_lemma_concl) as type_info = + let lemmas_types_infos = + Util.array_map2_i + (fun i f_constr graph -> + let const_of_f = destConst f_constr in + let (type_of_lemma_ctxt,type_of_lemma_concl) as type_info = generate_type true const_of_f graph i - in - let type_of_lemma = Termops.it_mkProd_or_LetIn ~init:type_of_lemma_concl type_of_lemma_ctxt in + in + let type_of_lemma = Termops.it_mkProd_or_LetIn ~init:type_of_lemma_concl type_of_lemma_ctxt in let type_of_lemma = nf_zeta type_of_lemma in observe (str "type_of_lemma := " ++ Printer.pr_lconstr type_of_lemma); type_of_lemma,type_info ) funs_constr - graphs_constr + graphs_constr in - let kn,_ as graph_ind = destInd graphs_constr.(0) in + let kn,_ as graph_ind = destInd graphs_constr.(0) in let mib,mip = Global.lookup_inductive graph_ind in - let schemes = - Array.of_list + let schemes = + Array.of_list (Indrec.build_mutual_indrec (Global.env ()) Evd.empty - (Array.to_list + (Array.to_list (Array.mapi (fun i mip -> (kn,i),mib,mip,true,InType) mib.Declarations.mind_packets @@ -832,25 +832,25 @@ let derive_correctness make_scheme functional_induction (funs: constant list) (g ) ) in - let proving_tac = + let proving_tac = prove_fun_complete funs_constr mib.Declarations.mind_packets schemes lemmas_types_infos in - Array.iteri - (fun i f_as_constant -> + Array.iteri + (fun i f_as_constant -> let f_id = id_of_label (con_label f_as_constant) in - Command.start_proof + Command.start_proof (*i The next call to mk_complete_id is valid since we are constructing the lemma Ensures by: obvious - i*) + i*) (mk_complete_id f_id) (Decl_kinds.Global,(Decl_kinds.Proof Decl_kinds.Theorem)) (fst lemmas_types_infos.(i)) (fun _ _ -> ()); Pfedit.by (observe_tac ("prove completeness ("^(string_of_id f_id)^")") (proving_tac i)); do_save (); - let finfo = find_Function_infos f_as_constant in + let finfo = find_Function_infos f_as_constant in update_Function - {finfo with + {finfo with completeness_lemma = Some (destConst (Tacinterp.constr_of_id (Global.env ())(mk_complete_id f_id))) } ) @@ -859,16 +859,16 @@ let derive_correctness make_scheme functional_induction (funs: constant list) (g (* In case of problem, we reset all the lemmas *) (*i The next call to mk_correct_id is valid since we are erasing the lemmas Ensures by: obvious - i*) - let first_lemma_id = - let f_id = id_of_label (con_label funs.(0)) in - - mk_correct_id f_id + i*) + let first_lemma_id = + let f_id = id_of_label (con_label funs.(0)) in + + mk_correct_id f_id in ignore(try Vernacentries.vernac_reset_name (Util.dummy_loc,first_lemma_id) with _ -> ()); raise e - - + + @@ -876,73 +876,73 @@ let derive_correctness make_scheme functional_induction (funs: constant list) (g (* [revert_graph kn post_tac hid] transforme an hypothesis [hid] having type Ind(kn,num) t1 ... tn res when [kn] denotes a graph block into - f_num t1... tn = res (by applying [f_complete] to the first type) before apply post_tac on the result - + f_num t1... tn = res (by applying [f_complete] to the first type) before apply post_tac on the result + if the type of hypothesis has not this form or if we cannot find the completeness lemma then we do nothing *) let revert_graph kn post_tac hid g = - let typ = pf_type_of g (mkVar hid) in - match kind_of_term typ with - | App(i,args) when isInd i -> - let ((kn',num) as ind') = destInd i in - if kn = kn' + let typ = pf_type_of g (mkVar hid) in + match kind_of_term typ with + | App(i,args) when isInd i -> + let ((kn',num) as ind') = destInd i in + if kn = kn' then (* We have generated a graph hypothesis so that we must change it if we can *) - let info = + let info = try find_Function_of_graph ind' with Not_found -> (* The graphs are mutually recursive but we cannot find one of them !*) anomaly "Cannot retrieve infos about a mutual block" - in - (* if we can find a completeness lemma for this function - then we can come back to the functional form. If not, we do nothing + in + (* if we can find a completeness lemma for this function + then we can come back to the functional form. If not, we do nothing *) - match info.completeness_lemma with + match info.completeness_lemma with | None -> tclIDTAC g - | Some f_complete -> + | Some f_complete -> let f_args,res = array_chop (Array.length args - 1) args in tclTHENSEQ [ h_generalize [applist(mkConst f_complete,(Array.to_list f_args)@[res.(0);mkVar hid])]; thin [hid]; - h_intro hid; + h_intro hid; post_tac hid ] g - + else tclIDTAC g | _ -> tclIDTAC g -(* +(* [functional_inversion hid fconst f_correct ] is the functional version of [inversion] - + [hid] is the hypothesis to invert, [fconst] is the function to invert and [f_correct] is the correctness lemma for [fconst]. - The sketch is the follwing~: - \begin{enumerate} - \item Transforms the hypothesis [hid] such that its type is now $res\ =\ f\ t_1 \ldots t_n$ + The sketch is the follwing~: + \begin{enumerate} + \item Transforms the hypothesis [hid] such that its type is now $res\ =\ f\ t_1 \ldots t_n$ (fails if it is not possible) \item replace [hid] with $R\_f t_1 \ldots t_n res$ using [f_correct] \item apply [inversion] on [hid] - \item finally in each branch, replace each hypothesis [R\_f ..] by [f ...] using [f_complete] (whenever + \item finally in each branch, replace each hypothesis [R\_f ..] by [f ...] using [f_complete] (whenever such a lemma exists) \end{enumerate} *) - -let functional_inversion kn hid fconst f_correct : tactic = - fun g -> - let old_ids = List.fold_right Idset.add (pf_ids_of_hyps g) Idset.empty in - let type_of_h = pf_type_of g (mkVar hid) in - match kind_of_term type_of_h with - | App(eq,args) when eq_constr eq (Coqlib.build_coq_eq ()) -> - let pre_tac,f_args,res = - match kind_of_term args.(1),kind_of_term args.(2) with - | App(f,f_args),_ when eq_constr f fconst -> + +let functional_inversion kn hid fconst f_correct : tactic = + fun g -> + let old_ids = List.fold_right Idset.add (pf_ids_of_hyps g) Idset.empty in + let type_of_h = pf_type_of g (mkVar hid) in + match kind_of_term type_of_h with + | App(eq,args) when eq_constr eq (Coqlib.build_coq_eq ()) -> + let pre_tac,f_args,res = + match kind_of_term args.(1),kind_of_term args.(2) with + | App(f,f_args),_ when eq_constr f fconst -> ((fun hid -> h_symmetry (onHyp hid)),f_args,args.(2)) - |_,App(f,f_args) when eq_constr f fconst -> - ((fun hid -> tclIDTAC),f_args,args.(1)) + |_,App(f,f_args) when eq_constr f fconst -> + ((fun hid -> tclIDTAC),f_args,args.(1)) | _ -> (fun hid -> tclFAIL 1 (mt ())),[||],args.(2) - in + in tclTHENSEQ[ pre_tac hid; h_generalize [applist(f_correct,(Array.to_list f_args)@[res;mkVar hid])]; @@ -950,7 +950,7 @@ let functional_inversion kn hid fconst f_correct : tactic = h_intro hid; Inv.inv FullInversion None (Rawterm.NamedHyp hid); (fun g -> - let new_ids = List.filter (fun id -> not (Idset.mem id old_ids)) (pf_ids_of_hyps g) in + let new_ids = List.filter (fun id -> not (Idset.mem id old_ids)) (pf_ids_of_hyps g) in tclMAP (revert_graph kn pre_tac) (hid::new_ids) g ); ] g @@ -958,62 +958,62 @@ let functional_inversion kn hid fconst f_correct : tactic = -let invfun qhyp f = - let f = - match f with - | ConstRef f -> f +let invfun qhyp f = + let f = + match f with + | ConstRef f -> f | _ -> raise (Util.UserError("",str "Not a function")) in - try - let finfos = find_Function_infos f in - let f_correct = mkConst(Option.get finfos.correctness_lemma) + try + let finfos = find_Function_infos f in + 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" + Tactics.try_intros_until (fun hid -> functional_inversion kn hid (mkConst f) f_correct) qhyp + with + | Not_found -> error "No graph found" | Option.IsNone -> error "Cannot use equivalence with graph!" -let invfun qhyp f g = - match f with +let invfun qhyp f g = + match f with | Some f -> invfun qhyp f g - | None -> - Tactics.try_intros_until - (fun hid g -> - let hyp_typ = pf_type_of g (mkVar hid) in - match kind_of_term hyp_typ with - | App(eq,args) when eq_constr eq (Coqlib.build_coq_eq ()) -> + | None -> + Tactics.try_intros_until + (fun hid g -> + let hyp_typ = pf_type_of g (mkVar hid) in + match kind_of_term hyp_typ with + | App(eq,args) when eq_constr eq (Coqlib.build_coq_eq ()) -> begin - let f1,_ = decompose_app args.(1) in - try + let f1,_ = decompose_app args.(1) in + try if not (isConst f1) then failwith ""; - let finfos = find_Function_infos (destConst f1) in - let f_correct = mkConst(Option.get finfos.correctness_lemma) + let finfos = find_Function_infos (destConst f1) in + 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 "" | Option.IsNone | Not_found -> - try - let f2,_ = decompose_app args.(2) in + 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(Option.get finfos.correctness_lemma) + let finfos = find_Function_infos (destConst f2) in + 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 "" -> + | Failure "" -> errorlabstrm "" (str "Hypothesis" ++ Ppconstr.pr_id hid ++ str " must contain at leat one Function") - | Option.IsNone -> - if do_observe () + | Option.IsNone -> + if do_observe () then error "Cannot use equivalence with graph for any side of the equality" else errorlabstrm "" (str "Cannot find inversion information for hypothesis " ++ Ppconstr.pr_id hid) - | Not_found -> - if do_observe () + | Not_found -> + if do_observe () then - error "No graph found for any side of equality" + error "No graph found for any side of equality" else errorlabstrm "" (str "Cannot find inversion information for hypothesis " ++ Ppconstr.pr_id hid) end | _ -> errorlabstrm "" (Ppconstr.pr_id hid ++ str " must be an equality ") diff --git a/plugins/funind/merge.ml b/plugins/funind/merge.ml index 092830025b..3538f63426 100644 --- a/plugins/funind/merge.ml +++ b/plugins/funind/merge.ml @@ -18,7 +18,7 @@ open Vernacexpr open Pp open Names open Term -open Termops +open Termops open Declarations open Environ open Rawterm @@ -32,19 +32,19 @@ 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 + if compare_constr (fun _ _ -> false) t1 t2 then true else false let rec compare_constr' t1 t2 = - if compare_constr_nosub 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 + else map_constr_with_binders succ (fun i -> substitterm i t by_t) prof in_u let lift_ldecl n ldecl = List.map (fun (x,y) -> x,lift n y) ldecl @@ -59,23 +59,23 @@ let name_of_string str = Name (id_of_string str) let string_of_name nme = string_of_id (id_of_name nme) (** [isVarf f x] returns [true] if term [x] is of the form [(Var f)]. *) -let isVarf f x = +let isVarf f x = match x with - | RVar (_,x) -> Pervasives.compare x f = 0 + | RVar (_,x) -> Pervasives.compare x f = 0 | _ -> false (** [ident_global_exist id] returns true if identifier [id] is linked in global environment. *) -let ident_global_exist id = - try +let ident_global_exist id = + try let ans = CRef (Libnames.Ident (dummy_loc,id)) in let _ = ignore (Constrintern.intern_constr Evd.empty (Global.env()) ans) in true - with _ -> false + with _ -> false (** [next_ident_fresh id] returns a fresh identifier (ie not linked in global env) with base [id]. *) -let next_ident_fresh (id:identifier) = +let next_ident_fresh (id:identifier) = let res = ref id in while ident_global_exist !res do res := Nameops.lift_ident !res done; !res @@ -89,37 +89,37 @@ let prconstr c = msg (str" " ++ Printer.pr_lconstr c) let prconstrnl c = msg (str" " ++ Printer.pr_lconstr c ++ str"\n") let prlistconstr lc = List.iter prconstr lc let prstr s = msg(str s) -let prNamedConstr s c = +let prNamedConstr s c = begin msg(str ""); msg(str(s^" {§ ") ++ Printer.pr_lconstr c ++ str " §} "); msg(str ""); end -let prNamedRConstr s c = +let prNamedRConstr s c = begin msg(str ""); msg(str(s^" {§ ") ++ Printer.pr_rawconstr c ++ str " §} "); msg(str ""); end let prNamedLConstr_aux lc = List.iter (prNamedConstr "\n") lc -let prNamedLConstr s lc = +let prNamedLConstr s lc = begin prstr "[§§§ "; prstr s; prNamedLConstr_aux lc; prstr " §§§]\n"; end -let prNamedLDecl s lc = +let prNamedLDecl s lc = begin prstr s; prstr "\n"; List.iter (fun (nm,_,tp) -> prNamedConstr (string_of_name nm) tp) lc; prstr "\n"; end -let prNamedRLDecl s lc = +let prNamedRLDecl s lc = begin prstr s; prstr "\n"; prstr "{§§ "; - List.iter - (fun x -> + 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 @@ -133,16 +133,16 @@ let showind (id:identifier) = let cstrid = Tacinterp.constr_of_id (Global.env()) id in let ind1,cstrlist = Inductiveops.find_inductive (Global.env()) Evd.empty cstrid in let mib1,ib1 = Inductive.lookup_mind_specif (Global.env()) ind1 in - List.iter (fun (nm, optcstr, tp) -> + List.iter (fun (nm, optcstr, tp) -> print_string (string_of_name nm^":"); - prconstr tp; print_string "\n") + prconstr tp; print_string "\n") ib1.mind_arity_ctxt; (match ib1.mind_arity with | Monomorphic x -> Printf.printf "arity :"; prconstr x.mind_user_arity - | Polymorphic x -> + | Polymorphic x -> Printf.printf "arity : universe?"); - Array.iteri + Array.iteri (fun i x -> Printf.printf"type constr %d :" i ; prconstr x) ib1.mind_user_lc @@ -151,7 +151,7 @@ let showind (id:identifier) = exception Found of int (* Array scanning *) -let array_find (arr: 'a array) (pred: int -> 'a -> bool): int option = +let array_find (arr: 'a array) (pred: int -> 'a -> bool): int option = try for i=0 to Array.length arr - 1 do if pred i (arr.(i)) then raise (Found i) done; None @@ -163,10 +163,10 @@ let array_prfx (arr: 'a array) (pred: int -> 'a -> bool): int = Array.length arr (* all elt are positive *) with Found i -> i -let array_fold_lefti (f: int -> 'a -> 'b -> 'a) (acc:'a) (arr:'b array): 'a = - let i = ref 0 in - Array.fold_left - (fun acc x -> +let array_fold_lefti (f: int -> 'a -> 'b -> 'a) (acc:'a) (arr:'b array): 'a = + let i = ref 0 in + Array.fold_left + (fun acc x -> let res = f !i acc x in i := !i + 1; res) acc arr @@ -176,25 +176,25 @@ let list_chop_end i l = if size_prefix < 0 then failwith "list_chop_end" else list_chop size_prefix l -let list_fold_lefti (f: int -> 'a -> 'b -> 'a) (acc:'a) (arr:'b list): 'a = - let i = ref 0 in - List.fold_left - (fun acc x -> +let list_fold_lefti (f: int -> 'a -> 'b -> 'a) (acc:'a) (arr:'b list): 'a = + let i = ref 0 in + List.fold_left + (fun acc x -> let res = f !i acc x in i := !i + 1; res) acc arr -let list_filteri (f: int -> 'a -> bool) (l:'a list):'a list = - let i = ref 0 in +let list_filteri (f: int -> 'a -> bool) (l:'a list):'a list = + let i = ref 0 in List.filter (fun x -> let res = f !i x in i := !i + 1; res) l (** Iteration module *) -module For = +module For = struct let rec map i j (f: int -> 'a) = if i>j then [] else f i :: (map (i+1) j f) - let rec foldup i j (f: 'a -> int -> 'a) acc = + let rec foldup i j (f: 'a -> int -> 'a) acc = if i>j then acc else let newacc = f acc i in foldup (i+1) j f newacc - let rec folddown i j (f: 'a -> int -> 'a) acc = + let rec folddown i j (f: 'a -> int -> 'a) acc = if i>j then acc else let newacc = f acc j in folddown i (j-1) f newacc let fold i j = if i<j then foldup i j else folddown i j end @@ -231,7 +231,7 @@ let prlinked x = | Unlinked -> Printf.sprintf "Unlinked" | Funres -> Printf.sprintf "Funres" -let linkmonad f lnkvar = +let linkmonad f lnkvar = match lnkvar with | Linked i -> Linked (f i) | Unlinked -> Unlinked @@ -242,7 +242,7 @@ let linklift lnkvar i = linkmonad (fun x -> x+i) lnkvar (* This map is used to deal with debruijn linked indices. *) module Link = Map.Make (struct type t = int let compare = Pervasives.compare end) -let pr_links l = +let pr_links l = Printf.printf "links:\n"; Link.iter (fun k e -> Printf.printf "%d : %s\n" k (prlinked e)) l; Printf.printf "_____________\n" @@ -255,16 +255,16 @@ type 'a merged_arg = | Arg_linked of 'a | Arg_funres -(** Information about graph merging of two inductives. +(** 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 *) mib1: mutual_inductive_body; - oib1: one_inductive_body; + oib1: one_inductive_body; mib2: mutual_inductive_body; - oib2: one_inductive_body; + oib2: one_inductive_body; (** Array of links of the first inductive (should be all stable) *) lnk1: int merged_arg array; @@ -275,24 +275,24 @@ type merge_infos = (** rec params which remain rec param (ie not linked) *) recprms1: rel_declaration list; recprms2: rel_declaration list; - nrecprms1: int; + nrecprms1: int; nrecprms2: int; (** 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; + otherprms1: rel_declaration list; + otherprms2: rel_declaration list; + notherprms1:int; notherprms2:int; (** args which remain args in merge *) - args1:rel_declaration list; + args1:rel_declaration list; args2:rel_declaration list; nargs1:int; nargs2:int; (** functional result args *) - funresprms1: rel_declaration list; + funresprms1: rel_declaration list; funresprms2: rel_declaration list; nfunresprms1:int; nfunresprms2:int; @@ -301,7 +301,7 @@ type merge_infos = let pr_merginfo x = let i,s= - match x with + match x with | Prm_linked i -> Some i,"Prm_linked" | Arg_linked i -> Some i,"Arg_linked" | Prm_stable i -> Some i,"Prm_stable" @@ -317,7 +317,7 @@ let isPrm_stable x = match x with Prm_stable _ -> true | _ -> false (* ?? prm_linked?? *) let isArg_stable x = match x with Arg_stable _ | Prm_arg _ -> true | _ -> false -let is_stable x = +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 @@ -332,22 +332,22 @@ let filter_shift_stable (lnk:int merged_arg array) (l:'a list): 'a list = of int as several vars may be linked to the same var. *) let revlinked lnk = For.fold 0 (Array.length lnk - 1) - (fun acc k -> - match lnk.(k) with - | Unlinked | Funres -> acc - | Linked i -> + (fun acc k -> + match lnk.(k) with + | Unlinked | Funres -> acc + | Linked i -> let old = try Link.find i acc with Not_found -> [] in Link.add i (k::old) acc) Link.empty -let array_switch arr i j = +let array_switch arr i j = let aux = arr.(j) in arr.(j) <- arr.(i); arr.(i) <- aux let filter_shift_stable_right (lnk:int merged_arg array) (l:'a list): 'a list = let larr = Array.of_list l in let _ = Array.iteri - (fun j x -> + (fun j x -> match x with | Prm_linked i -> array_switch larr i j | Arg_linked i -> array_switch larr i j @@ -392,7 +392,7 @@ let build_raw_params prms_decl avoid = let ids_of_rawlist avoid rawl = List.fold_left Idset.union avoid (List.map ids_of_rawterm rawl) - + (** {1 Merging function graphs} *) @@ -402,7 +402,7 @@ let ids_of_rawlist avoid rawl = remain uniform when linked by [lnk]. All parameters are considered, ie we take parameters of the first inductive body of [mib1] and [mib2]. - + Explanation: The two inductives have parameters, some of the first are recursively uniform, some of the last are functional result of the functional graph. @@ -418,14 +418,14 @@ let shift_linked_params mib1 mib2 (lnk1:linked_var array) (lnk2:linked_var array 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 - let is_targetted_by_non_recparam_lnk1 i = - try - let targets = Link.find i linked_targets in + let is_targetted_by_non_recparam_lnk1 i = + try + let targets = Link.find i linked_targets in List.exists (fun x -> not (is_param_of_mib2 x)) targets with Not_found -> false in - let mlnk1 = + let mlnk1 = Array.mapi - (fun i lkv -> + (fun i lkv -> let isprm = is_param_of_mib1 i in let prmlost = is_targetted_by_non_recparam_lnk1 i in match isprm , prmlost, lnk1.(i) with @@ -435,13 +435,13 @@ let shift_linked_params mib1 mib2 (lnk1:linked_var array) (lnk2:linked_var array | _ , _ , Funres -> assert false (* fun res cannot be a rec param or lost *) | false , _ , _ -> Arg_stable i) (* Args of lnk1 are not linked *) lnk1 in - let mlnk2 = + let mlnk2 = Array.mapi - (fun i lkv -> + (fun i lkv -> (* Is this correct if some param of ind2 is lost? *) let isprm = is_param_of_mib2 i in match isprm , lnk2.(i) with - | true , Linked j when not (is_param_of_mib1 j) -> + | true , Linked j when not (is_param_of_mib1 j) -> Prm_arg j (* recparam becoming ordinary *) | true , Linked j -> Prm_linked j (*recparam linked to recparam*) | true , Unlinked -> Prm_stable i (* recparam remains recparam*) @@ -456,9 +456,9 @@ let shift_linked_params mib1 mib2 (lnk1:linked_var array) (lnk2:linked_var array (* count params remaining params *) let n_params1 = array_prfx mlnk1 (fun i x -> not (isPrm_stable x)) in let n_params2 = array_prfx mlnk2 (fun i x -> not (isPrm_stable x)) in - let bldprms arity_ctxt mlnk = + let bldprms arity_ctxt mlnk = list_fold_lefti - (fun i (acc1,acc2,acc3,acc4) 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, acc4 @@ -467,19 +467,19 @@ let shift_linked_params mib1 mib2 (lnk1:linked_var array) (lnk2:linked_var array | Arg_funres -> acc1 , acc2 , acc3, x::acc4 | _ -> acc1 , acc2 , acc3, acc4) ([],[],[],[]) arity_ctxt in -(* let arity_ctxt2 = - build_raw_params oib2.mind_arity_ctxt +(* 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") + 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") + let _ = + List.iter (fun (x,_,y) -> prstr (string_of_name x^" : ");prconstr y;prstr "\n") otherprms2 in { ident=id; @@ -514,38 +514,38 @@ let shift_linked_params mib1 mib2 (lnk1:linked_var array) (lnk2:linked_var array exception NoMerge -let rec 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 -> + | 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 - | RLetIn(_,nme,bdy,trm) , _ -> - let _ = prstr "\nICI2!\n";Pp.flush_all() in + | 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 + | _, 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 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) -> + | RApp(_,f1, arr1), RApp(_,f2,arr2) -> let args = filter_shift_stable lnk (arr1 @ arr2) in RApp (dummy_loc,RVar(dummy_loc,shift.ident) , args) (* FIXME: what if the function appears in the body of the let? *) - | RLetIn(_,nme,bdy,trm) , _ -> - let _ = prstr "\nICI2 '!\n";Pp.flush_all() in + | 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 + | _, 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 @@ -555,33 +555,33 @@ let rec merge_app_unsafe c1 c2 shift filter_shift_stable = (* Heuristic when merging two lists of hypothesis: merge every rec calls of branch 1 with all rec calls of branch 2. *) (* TODO: reecrire cette heuristique (jusqu'a merge_types) *) -let rec merge_rec_hyps shift accrec - (ltyp:(Names.name * rawconstr option * rawconstr option) list) +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 = + let mergeonehyp t reldecl = match reldecl with - | (nme,x,Some (RApp(_,i,args) as ind)) + | (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,Some _) -> assert false | (nme,None,None) | (nme,Some _,Some _) -> assert false in match ltyp with | [] -> [] - | (nme,None,Some (RApp(_,f, largs) as t)) :: lt when isVarf ind2name f -> + | (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 -let rec build_suppl_reccall (accrec:(name * rawconstr) list) concl2 shift = +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 = +let find_app (nme:identifier) ltyp = try ignore (List.map - (fun x -> + (fun x -> match x with | _,None,Some (RApp(_,f,_)) when isVarf nme f -> raise (Found 0) | _ -> ()) @@ -589,17 +589,17 @@ let find_app (nme:identifier) ltyp = false with Found _ -> true -let prnt_prod_or_letin nm letbdy typ = +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 + +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 = + : (name * rawconstr option * rawconstr option) list * rawconstr = let _ = prstr "MERGE_TYPES\n" in let _ = prstr "ltyp 1 : " in let _ = List.iter (fun (nm,lbdy,tp) -> prnt_prod_or_letin nm lbdy tp) ltyp1 in @@ -608,20 +608,20 @@ let rec merge_types shift accrec1 let _ = prstr "\n" in let res = match ltyp1 with - | [] -> + | [] -> let isrec1 = (accrec1<>[]) in let isrec2 = find_app ind2name ltyp2 in let rechyps = - if isrec1 && isrec2 + if isrec1 && isrec2 then (* merge_rec_hyps shift accrec1 ltyp2 filter_shift_stable *) - merge_rec_hyps shift [name_of_string "concl1",None,Some concl1] ltyp2 + 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 + else if isrec1 (* if rec calls in accrec1 and not in ltyp2, add one to ltyp2 *) - then - merge_rec_hyps shift accrec1 + 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",None,Some concl1] ltyp2 @@ -634,22 +634,22 @@ let rec merge_types shift accrec1 let _ = prstr " with " in let _ = prNamedRConstr "concl2" concl2 in let _ = prstr "\n" in - let concl = + let concl = merge_app concl1 concl2 ind1name ind2name shift filter_shift_stable in let _ = prstr "FIN " in let _ = prNamedRConstr "concl" concl in let _ = prstr "\n" in rechyps , concl - | (nme,None, Some t1)as e ::lt1 -> + | (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 - | _ -> + | 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,None,Some t1) :: recres) , recconcl2) - | (nme,Some bd, None) ::lt1 -> + ((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 @@ -666,10 +666,10 @@ let rec merge_types shift accrec1 let build_link_map_aux (allargs1:identifier array) (allargs2:identifier array) (lnk:int merged_arg array) = array_fold_lefti - (fun i acc e -> + (fun i acc e -> if i = Array.length lnk - 1 then acc (* functional arg, not in allargs *) - else - match e with + else + match e with | Prm_linked j | Arg_linked j -> Idmap.add allargs2.(i) allargs1.(j) acc | _ -> acc) Idmap.empty lnk @@ -696,10 +696,10 @@ let build_link_map allargs1 allargs2 lnk = forall recparams1 (recparams2 without linked params), forall ordparams1 (ordparams2 without linked params), - H1a' -> H2a' -> ... -> H2a' -> H2b'(shifted) -> ... + H1a' -> H2a' -> ... -> H2a' -> H2b'(shifted) -> ... -> (newI x1 ... z1 x2 y2 ...z2 without linked params) - where Hix' have been adapted, ie: + where Hix' have been adapted, ie: - linked vars have been changed, - rec calls to I1 and I2 have been replaced by rec calls to newI. More precisely calls to I1 and I2 have been merge by an @@ -715,26 +715,26 @@ let merge_one_constructor (shift:merge_infos) (typcstr1:rawconstr) (* FIXME: les noms des parametres corerspondent en principe au parametres du niveau mib, mais il faudrait s'en assurer *) (* shift.nfunresprmsx last args are functional result *) - let nargs1 = + let nargs1 = 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_or_letin_n nargs1 typcstr1 in - let allargs2,rest2 = raw_decompose_prod_or_letin_n nargs2 typcstr2 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_or_letin rest1 in let hyps2,concl2' = raw_decompose_prod_or_letin rest2 in - let ltyp,concl2 = + let ltyp,concl2 = merge_types shift [] (List.rev hyps1) concl1 (List.rev hyps2) concl2' in let _ = prNamedRLDecl "ltyp result:" ltyp in let typ = raw_compose_prod_or_letin concl2 (List.rev ltyp) in - let revargs1 = + 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 = + let revargs2 = list_filteri (fun i _ -> isArg_stable shift.lnk2.(i)) (List.rev allargs2) in let _ = prNamedRLDecl "ltyp allargs2" allargs2 in let _ = prNamedRLDecl "ltyp revargs2" revargs2 in @@ -746,7 +746,7 @@ let merge_one_constructor (shift:merge_infos) (typcstr1:rawconstr) (** constructor numbering *) let fresh_cstror_suffix , cstror_suffix_init = let cstror_num = ref 0 in - (fun () -> + (fun () -> let res = string_of_int !cstror_num in cstror_num := !cstror_num + 1; res) , @@ -755,7 +755,7 @@ let fresh_cstror_suffix , cstror_suffix_init = (** [merge_constructor_id id1 id2 shift] returns the identifier of the new constructor from the id of the two merged constructor and the merging info. *) -let merge_constructor_id id1 id2 shift:identifier = +let merge_constructor_id id1 id2 shift:identifier = let id = string_of_id shift.ident ^ "_" ^ fresh_cstror_suffix () in next_ident_fresh (id_of_string id) @@ -765,43 +765,43 @@ 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 * rawconstr) list) + (typcstr1:(identifier * rawconstr) list) (typcstr2:(identifier * rawconstr) list) : (identifier * rawconstr) list = - List.flatten + List.flatten (List.map - (fun (id1,rawtyp1) -> + (fun (id1,rawtyp1) -> List.map - (fun (id2,rawtyp2) -> + (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) - + (** [merge_inductive_body lnk shift avoid oib1 oib2] merges two 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) = (* building rawconstr type of constructors *) - let mkrawcor nme avoid typ = + 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 = + 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 = + 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)) + 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)) + 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 @@ -819,17 +819,17 @@ let rec merge_inductive_body (shift:merge_infos) avoid (oib1:one_inductive_body) let rec merge_mutual_inductive_body (mib1:mutual_inductive_body) (mib2:mutual_inductive_body) (shift:merge_infos) = (* Mutual not treated, we take first ind body of each. *) - merge_inductive_body shift Idset.empty 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 prms1 prms2 shift (concl:constr) = +let merge_rec_params_and_arity prms1 prms2 shift (concl:constr) = let params = prms2 @ prms1 in let resparams = List.fold_left - (fun acc (nme,tp) -> + (fun acc (nme,tp) -> let _ = prstr "param :" in let _ = prNamedRConstr (string_of_name nme) tp in let _ = prstr " ; " in @@ -837,18 +837,18 @@ let merge_rec_params_and_arity prms1 prms2 shift (concl:constr) = 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 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)],Topconstr.default_binder_kind,typ] , acc) , newenv) (concl,Global.env()) - (shift.funresprms2 @ shift.funresprms1 - @ shift.args2 @ shift.args1 @ shift.otherprms2 @ shift.otherprms1) in + (shift.funresprms2 @ shift.funresprms1 + @ shift.args2 @ shift.args1 @ shift.otherprms2 @ shift.otherprms1) in resparams,arity - + (** [rawterm_list_to_inductive_expr ident rawlist] returns the induct_expr corresponding to the the list of constructor types @@ -859,17 +859,17 @@ let rawterm_list_to_inductive_expr prms1 prms2 mib1 mib2 shift let lident = dummy_loc, shift.ident in let bindlist , cstr_expr = (* params , arities *) merge_rec_params_and_arity prms1 prms2 shift mkSet in - let lcstor_expr : (bool * (lident * constr_expr)) list = + 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 + rawlist in lident , bindlist , Some cstr_expr , lcstor_expr let mkProd_reldecl (rdecl:rel_declaration) (t2:rawconstr) = match rdecl with - | (nme,None,t) -> + | (nme,None,t) -> let traw = Detyping.detype false [] [] t in RProd (dummy_loc,nme,Explicit,traw,t2) | (_,Some _,_) -> assert false @@ -879,7 +879,7 @@ let mkProd_reldecl (rdecl:rel_declaration) (t2:rawconstr) = let mkProd_reldecl (rdecl:rel_declaration) (t2:rawconstr) = match rdecl with - | (nme,None,t) -> + | (nme,None,t) -> let traw = Detyping.detype false [] [] t in RProd (dummy_loc,nme,Explicit,traw,t2) | (_,Some _,_) -> assert false @@ -888,7 +888,7 @@ let mkProd_reldecl (rdecl:rel_declaration) (t2:rawconstr) = (** [merge_inductive ind1 ind2 lnk] merges two graphs, linking variables specified in [lnk]. Graphs are not supposed to be mutual inductives for the moment. *) -let merge_inductive (ind1: inductive) (ind2: inductive) +let merge_inductive (ind1: inductive) (ind2: inductive) (lnk1: linked_var array) (lnk2: linked_var array) id = let env = Global.env() in let mib1,_ = Inductive.lookup_mind_specif env ind1 in @@ -898,14 +898,14 @@ let merge_inductive (ind1: inductive) (ind2: inductive) let shift_prm = shift_linked_params mib1 mib2 lnk1 lnk2 id in let prms1,prms2, rawlist = merge_mutual_inductive_body mib1 mib2 shift_prm in let _ = prstr "\nrawlist : " in - let _ = + 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 = + let shift_prm = { shift_prm with recprms1=prms1; - recprms1=prms1; + recprms1=prms1; } in *) let indexpr = rawterm_list_to_inductive_expr prms1 prms2 mib1 mib2 shift_prm rawlist in (* Declare inductive *) @@ -927,28 +927,28 @@ let find_Function_infos_safe (id:identifier): Indfun_common.function_info = [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) +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 + let lnk2' = (* args2 may be linked to args1 members. FIXME: same as above: vars may be linked inside args2?? *) Array.mapi - (fun i c -> + (fun i c -> match array_find args1 (fun i x -> x=c) with | Some j -> Linked j - | None -> Unlinked) + | None -> Unlinked) args2 in (* 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 _ = 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 @@ -968,12 +968,12 @@ let remove_last_n_arg n c = (* [funify_branches relinfo nfuns branch] returns the branch [branch] of the relinfo [relinfo] modified to fit in a functional principle. - Things to do: + 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 = +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 @@ -987,13 +987,13 @@ let funify_branches relinfo nfuns branch = match kind_of_term c with | Ind((u,i)) | Construct((u,_),i) -> i | _ -> assert false in - let _is_pred c shift = + 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 @@ -1010,7 +1010,7 @@ let relprinctype_to_funprinctype relprinctype nfuns = args = remove_n_fst_list nfuns relinfo_noindarg.args; concl = popn nfuns relinfo_noindarg.concl } in - let new_branches = + 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 @@ -1026,7 +1026,7 @@ let relprinctype_to_funprinctype relprinctype nfuns = url = "citeseer.ist.psu.edu/bundy93rippling.html" } *) -(* +(* *** Local Variables: *** *** compile-command: "make -C ../.. plugins/funind/merge.cmo" *** *** indent-tabs-mode: nil *** diff --git a/plugins/funind/rawterm_to_relation.ml b/plugins/funind/rawterm_to_relation.ml index 7e9ba3f8ea..4bd0385caa 100644 --- a/plugins/funind/rawterm_to_relation.ml +++ b/plugins/funind/rawterm_to_relation.ml @@ -1,6 +1,6 @@ open Printer open Pp -open Names +open Names open Term open Rawterm open Libnames @@ -8,76 +8,76 @@ open Indfun_common open Util open Rawtermops -let observe strm = +let observe strm = if do_observe () - then Pp.msgnl strm + then Pp.msgnl strm else () -let observennl strm = +let observennl strm = if do_observe () - then Pp.msg strm + then Pp.msg strm else () type binder_type = - | Lambda of name - | Prod of name + | Lambda of name + | Prod of name | LetIn of name type raw_context = (binder_type*rawconstr) list -(* - compose_raw_context [(bt_1,n_1,t_1);......] rt returns - b_1(n_1,t_1,.....,bn(n_k,t_k,rt)) where the b_i's are the +(* + compose_raw_context [(bt_1,n_1,t_1);......] rt returns + b_1(n_1,t_1,.....,bn(n_k,t_k,rt)) where the b_i's are the binders corresponding to the bt_i's *) -let compose_raw_context = +let compose_raw_context = let compose_binder (bt,t) acc = - match bt with + match bt with | Lambda n -> mkRLambda(n,t,acc) | Prod n -> mkRProd(n,t,acc) | LetIn n -> mkRLetIn(n,t,acc) in List.fold_right compose_binder - -(* + +(* The main part deals with building a list of raw constructor expressions - from the rhs of a fixpoint equation. + from the rhs of a fixpoint equation. *) -type 'a build_entry_pre_return = +type 'a build_entry_pre_return = { context : raw_context; (* the binding context of the result *) value : 'a; (* The value *) } -type 'a build_entry_return = +type 'a build_entry_return = { - result : 'a build_entry_pre_return list; + result : 'a build_entry_pre_return list; to_avoid : identifier list } (* - [combine_results combine_fun res1 res2] combine two results [res1] and [res2] + [combine_results combine_fun res1 res2] combine two results [res1] and [res2] w.r.t. [combine_fun]. - Informally, both [res1] and [res2] are lists of "constructors" [res1_1;...] - and [res2_1,....] and we need to produce + Informally, both [res1] and [res2] are lists of "constructors" [res1_1;...] + and [res2_1,....] and we need to produce [combine_fun res1_1 res2_1;combine_fun res1_1 res2_2;........] *) -let combine_results - (combine_fun : 'a build_entry_pre_return -> 'b build_entry_pre_return -> +let combine_results + (combine_fun : 'a build_entry_pre_return -> 'b build_entry_pre_return -> 'c build_entry_pre_return - ) - (res1: 'a build_entry_return) - (res2 : 'b build_entry_return) - : 'c build_entry_return - = - let pre_result = List.map + ) + (res1: 'a build_entry_return) + (res2 : 'b build_entry_return) + : 'c build_entry_return + = + let pre_result = List.map ( fun res1 -> (* for each result in arg_res *) - List.map (* we add it in each args_res *) - (fun res2 -> + List.map (* we add it in each args_res *) + (fun res2 -> combine_fun res1 res2 ) res2.result @@ -85,107 +85,107 @@ let combine_results res1.result in (* and then we flatten the map *) { - result = List.concat pre_result; + result = List.concat pre_result; to_avoid = list_union res1.to_avoid res2.to_avoid } - -(* - The combination function for an argument with a list of argument + +(* + The combination function for an argument with a list of argument *) -let combine_args arg args = +let combine_args arg args = { - context = arg.context@args.context; - (* Note that the binding context of [arg] MUST be placed before the one of - [args] in order to preserve possible type dependencies + context = arg.context@args.context; + (* Note that the binding context of [arg] MUST be placed before the one of + [args] in order to preserve possible type dependencies *) value = arg.value::args.value; } -let ids_of_binder = function +let ids_of_binder = function | LetIn Anonymous | Prod Anonymous | Lambda Anonymous -> [] | LetIn (Name id) | Prod (Name id) | Lambda (Name id) -> [id] -let rec change_vars_in_binder mapping = function +let rec change_vars_in_binder mapping = function [] -> [] | (bt,t)::l -> - let new_mapping = List.fold_right Idmap.remove (ids_of_binder bt) mapping in + let new_mapping = List.fold_right Idmap.remove (ids_of_binder bt) mapping in (bt,change_vars mapping t):: (if idmap_is_empty new_mapping - then l + then l else change_vars_in_binder new_mapping l ) let rec replace_var_by_term_in_binder x_id term = function | [] -> [] - | (bt,t)::l -> + | (bt,t)::l -> (bt,replace_var_by_term x_id term t):: - if List.mem x_id (ids_of_binder bt) + if List.mem x_id (ids_of_binder bt) then l else replace_var_by_term_in_binder x_id term l let add_bt_names bt = List.append (ids_of_binder bt) -let apply_args ctxt body args = - let need_convert_id avoid id = - List.exists (is_free_in id) args || List.mem id avoid - in - let need_convert avoid bt = +let apply_args ctxt body args = + let need_convert_id avoid id = + List.exists (is_free_in id) args || List.mem id avoid + in + let need_convert avoid bt = List.exists (need_convert_id avoid) (ids_of_binder bt) in - let next_name_away (na:name) (mapping: identifier Idmap.t) (avoid: identifier list) = - match na with - | Name id when List.mem id avoid -> - let new_id = Nameops.next_ident_away id avoid in + let next_name_away (na:name) (mapping: identifier Idmap.t) (avoid: identifier list) = + match na with + | Name id when List.mem id avoid -> + let new_id = Nameops.next_ident_away id avoid in Name new_id,Idmap.add id new_id mapping,new_id::avoid | _ -> na,mapping,avoid in - let next_bt_away bt (avoid:identifier list) = - match bt with - | LetIn na -> - let new_na,mapping,new_avoid = next_name_away na Idmap.empty avoid in + let next_bt_away bt (avoid:identifier list) = + match bt with + | LetIn na -> + let new_na,mapping,new_avoid = next_name_away na Idmap.empty avoid in LetIn new_na,mapping,new_avoid - | Prod na -> - let new_na,mapping,new_avoid = next_name_away na Idmap.empty avoid in + | Prod na -> + let new_na,mapping,new_avoid = next_name_away na Idmap.empty avoid in Prod new_na,mapping,new_avoid - | Lambda na -> - let new_na,mapping,new_avoid = next_name_away na Idmap.empty avoid in + | Lambda na -> + let new_na,mapping,new_avoid = next_name_away na Idmap.empty avoid in Lambda new_na,mapping,new_avoid in - let rec do_apply avoid ctxt body args = - match ctxt,args with + let rec do_apply avoid ctxt body args = + match ctxt,args with | _,[] -> (* No more args *) (ctxt,body) | [],_ -> (* no more fun *) let f,args' = raw_decompose_app body in (ctxt,mkRApp(f,args'@args)) - | (Lambda Anonymous,t)::ctxt',arg::args' -> + | (Lambda Anonymous,t)::ctxt',arg::args' -> do_apply avoid ctxt' body args' - | (Lambda (Name id),t)::ctxt',arg::args' -> - let new_avoid,new_ctxt',new_body,new_id = - if need_convert_id avoid id - then - let new_avoid = id::avoid in - let new_id = Nameops.next_ident_away id new_avoid in - let new_avoid' = new_id :: new_avoid in - let mapping = Idmap.add id new_id Idmap.empty in - let new_ctxt' = change_vars_in_binder mapping ctxt' in - let new_body = change_vars mapping body in + | (Lambda (Name id),t)::ctxt',arg::args' -> + let new_avoid,new_ctxt',new_body,new_id = + if need_convert_id avoid id + then + let new_avoid = id::avoid in + let new_id = Nameops.next_ident_away id new_avoid in + let new_avoid' = new_id :: new_avoid in + let mapping = Idmap.add id new_id Idmap.empty in + let new_ctxt' = change_vars_in_binder mapping ctxt' in + let new_body = change_vars mapping body in new_avoid',new_ctxt',new_body,new_id - else - id::avoid,ctxt',body,id + else + id::avoid,ctxt',body,id in let new_body = replace_var_by_term new_id arg new_body in let new_ctxt' = replace_var_by_term_in_binder new_id arg new_ctxt' in do_apply avoid new_ctxt' new_body args' - | (bt,t)::ctxt',_ -> - let new_avoid,new_ctxt',new_body,new_bt = - let new_avoid = add_bt_names bt avoid in - if need_convert avoid bt - then - let new_bt,mapping,new_avoid = next_bt_away bt new_avoid in + | (bt,t)::ctxt',_ -> + let new_avoid,new_ctxt',new_body,new_bt = + let new_avoid = add_bt_names bt avoid in + if need_convert avoid bt + then + let new_bt,mapping,new_avoid = next_bt_away bt new_avoid in ( new_avoid, change_vars_in_binder mapping ctxt', @@ -194,93 +194,93 @@ let apply_args ctxt body args = ) else new_avoid,ctxt',body,bt in - let new_ctxt',new_body = - do_apply new_avoid new_ctxt' new_body args + let new_ctxt',new_body = + do_apply new_avoid new_ctxt' new_body args in (new_bt,t)::new_ctxt',new_body - in + in do_apply [] ctxt body args -let combine_app f args = - let new_ctxt,new_value = apply_args f.context f.value args.value in - { - (* Note that the binding context of [args] MUST be placed before the one of - the applied value in order to preserve possible type dependencies +let combine_app f args = + let new_ctxt,new_value = apply_args f.context f.value args.value in + { + (* Note that the binding context of [args] MUST be placed before the one of + the applied value in order to preserve possible type dependencies *) context = args.context@new_ctxt; value = new_value; } -let combine_lam n t b = +let combine_lam n t b = { - context = []; - value = mkRLambda(n, compose_raw_context t.context t.value, + context = []; + value = mkRLambda(n, compose_raw_context t.context t.value, compose_raw_context b.context b.value ) } -let combine_prod n t b = +let combine_prod n t b = { context = t.context@((Prod n,t.value)::b.context); value = b.value} -let combine_letin n t b = +let combine_letin n t b = { context = t.context@((LetIn n,t.value)::b.context); value = b.value} -let mk_result ctxt value avoid = - { - result = +let mk_result ctxt value avoid = + { + result = [{context = ctxt; value = value}] ; to_avoid = avoid } (************************************************* - Some functions to deal with overlapping patterns + Some functions to deal with overlapping patterns **************************************************) -let coq_True_ref = +let coq_True_ref = lazy (Coqlib.gen_reference "" ["Init";"Logic"] "True") -let coq_False_ref = +let coq_False_ref = lazy (Coqlib.gen_reference "" ["Init";"Logic"] "False") (* [make_discr_match_el \[e1,...en\]] builds match e1,...,en with (the list of expresions on which we will do the matching) - *) -let make_discr_match_el = + *) +let make_discr_match_el = List.map (fun e -> (e,(Anonymous,None))) (* - [make_discr_match_brl i \[pat_1,...,pat_n\]] constructs a discrimination pattern matching on the ith expression. - that is. + [make_discr_match_brl i \[pat_1,...,pat_n\]] constructs a discrimination pattern matching on the ith expression. + that is. match ?????? with \\ | pat_1 => False \\ | pat_{i-1} => False \\ | pat_i => True \\ | pat_{i+1} => False \\ - \vdots + \vdots | pat_n => False end *) -let make_discr_match_brl i = - list_map_i - (fun j (_,idl,patl,_) -> +let make_discr_match_brl i = + list_map_i + (fun j (_,idl,patl,_) -> if j=i then (dummy_loc,idl,patl, mkRRef (Lazy.force coq_True_ref)) else (dummy_loc,idl,patl, mkRRef (Lazy.force coq_False_ref)) ) - 0 -(* - [make_discr_match brl el i] generates an hypothesis such that it reduce to true iff - brl_{i} is the first branch matched by [el] + 0 +(* + [make_discr_match brl el i] generates an hypothesis such that it reduce to true iff + brl_{i} is the first branch matched by [el] Used when we want to simulate the coq pattern matching algorithm *) -let make_discr_match brl = - fun el i -> +let make_discr_match brl = + fun el i -> mkRCases(None, make_discr_match_el el, make_discr_match_brl i brl) @@ -291,32 +291,32 @@ let pr_name = function (**********************************************************************) (* functions used to build case expression from lettuple and if ones *) -(**********************************************************************) +(**********************************************************************) -(* [build_constructors_of_type] construct the array of pattern of its inductive argument*) -let build_constructors_of_type ind' argl = +(* [build_constructors_of_type] construct the array of pattern of its inductive argument*) +let build_constructors_of_type ind' argl = let (mib,ind) = Inductive.lookup_mind_specif (Global.env()) ind' in let npar = mib.Declarations.mind_nparams in Array.mapi (fun i _ -> - let construct = ind',i+1 in - let constructref = ConstructRef(construct) in + let construct = ind',i+1 in + let constructref = ConstructRef(construct) in let _implicit_positions_of_cst = Impargs.implicits_of_global constructref in - let cst_narg = + let cst_narg = Inductiveops.mis_constructor_nargs_env (Global.env ()) construct - in - let argl = - if argl = [] + in + let argl = + if argl = [] then - Array.to_list + Array.to_list (Array.init (cst_narg - npar) (fun _ -> mkRHole ()) ) else argl in - let pat_as_term = + let pat_as_term = mkRApp(mkRRef (ConstructRef(ind',i+1)),argl) in cases_pattern_of_rawconstr Anonymous pat_as_term @@ -324,36 +324,36 @@ let build_constructors_of_type ind' argl = ind.Declarations.mind_consnames (* [find_type_of] very naive attempts to discover the type of an if or a letin *) -let rec find_type_of nb b = - let f,_ = raw_decompose_app b in - match f with - | RRef(_,ref) -> - begin - let ind_type = - match ref with - | VarRef _ | ConstRef _ -> - let constr_of_ref = constr_of_global ref in - let type_of_ref = Typing.type_of (Global.env ()) Evd.empty constr_of_ref in - let (_,ret_type) = Reduction.dest_prod (Global.env ()) type_of_ref in - let ret_type,_ = decompose_app ret_type in - if not (isInd ret_type) then +let rec find_type_of nb b = + let f,_ = raw_decompose_app b in + match f with + | RRef(_,ref) -> + begin + let ind_type = + match ref with + | VarRef _ | ConstRef _ -> + let constr_of_ref = constr_of_global ref in + let type_of_ref = Typing.type_of (Global.env ()) Evd.empty constr_of_ref in + let (_,ret_type) = Reduction.dest_prod (Global.env ()) type_of_ref in + let ret_type,_ = decompose_app ret_type in + if not (isInd ret_type) then begin (* Pp.msgnl (str "not an inductive" ++ pr_lconstr ret_type); *) raise (Invalid_argument "not an inductive") end; destInd ret_type | IndRef ind -> ind - | ConstructRef c -> fst c + | ConstructRef c -> fst c in - let _,ind_type_info = Inductive.lookup_mind_specif (Global.env()) ind_type in + let _,ind_type_info = Inductive.lookup_mind_specif (Global.env()) ind_type in if not (Array.length ind_type_info.Declarations.mind_consnames = nb ) then raise (Invalid_argument "find_type_of : not a valid inductive"); - ind_type + ind_type end - | RCast(_,b,_) -> find_type_of nb b + | RCast(_,b,_) -> find_type_of nb b | RApp _ -> assert false (* we have decomposed any application via raw_decompose_app *) | _ -> raise (Invalid_argument "not a ref") - + @@ -363,32 +363,32 @@ let rec find_type_of nb b = -let raw_push_named (na,raw_value,raw_typ) env = - match na with - | Anonymous -> env - | Name id -> - 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 +let raw_push_named (na,raw_value,raw_typ) env = + match na with + | Anonymous -> env + | Name id -> + 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 -let add_pat_variables pat typ env : Environ.env = - let rec add_pat_variables env pat typ : Environ.env = +let add_pat_variables pat typ env : Environ.env = + let rec add_pat_variables env pat typ : Environ.env = observe (str "new rel env := " ++ Printer.pr_rel_context_of env); - match pat with - | PatVar(_,na) -> Environ.push_rel (na,None,typ) env - | PatCstr(_,c,patl,na) -> - let Inductiveops.IndType(indf,indargs) = + match pat with + | PatVar(_,na) -> Environ.push_rel (na,None,typ) env + | PatCstr(_,c,patl,na) -> + let Inductiveops.IndType(indf,indargs) = try Inductiveops.find_rectype env Evd.empty typ - with Not_found -> assert false + with Not_found -> assert false in - let constructors = Inductiveops.get_constructors env indf in - let constructor : Inductiveops.constructor_summary = List.find (fun cs -> cs.Inductiveops.cs_cstr = c) (Array.to_list constructors) in - let cs_args_types :types list = List.map (fun (_,_,t) -> t) constructor.Inductiveops.cs_args in - List.fold_left2 add_pat_variables env patl (List.rev cs_args_types) + let constructors = Inductiveops.get_constructors env indf in + let constructor : Inductiveops.constructor_summary = List.find (fun cs -> cs.Inductiveops.cs_cstr = c) (Array.to_list constructors) in + let cs_args_types :types list = List.map (fun (_,_,t) -> t) constructor.Inductiveops.cs_args in + List.fold_left2 add_pat_variables env patl (List.rev cs_args_types) in - let new_env = add_pat_variables env pat typ in + let new_env = add_pat_variables env pat typ in let res = fst ( Sign.fold_rel_context @@ -426,15 +426,15 @@ let rec pattern_to_term_and_type env typ = function (Global.env ()) constr in - let Inductiveops.IndType(indf,indargs) = + let Inductiveops.IndType(indf,indargs) = try Inductiveops.find_rectype env Evd.empty typ - with Not_found -> assert false + with Not_found -> assert false in - let constructors = Inductiveops.get_constructors env indf in - let constructor = List.find (fun cs -> cs.Inductiveops.cs_cstr = constr) (Array.to_list constructors) in - let cs_args_types :types list = List.map (fun (_,_,t) -> t) constructor.Inductiveops.cs_args in - let _,cstl = Inductiveops.dest_ind_family indf in - let csta = Array.of_list cstl in + let constructors = Inductiveops.get_constructors env indf in + let constructor = List.find (fun cs -> cs.Inductiveops.cs_cstr = constr) (Array.to_list constructors) in + let cs_args_types :types list = List.map (fun (_,_,t) -> t) constructor.Inductiveops.cs_args in + let _,cstl = Inductiveops.dest_ind_family indf in + let csta = Array.of_list cstl in let implicit_args = Array.to_list (Array.init @@ -449,44 +449,44 @@ let rec pattern_to_term_and_type env typ = function implicit_args@patl_as_term ) -(* [build_entry_lc funnames avoid rt] construct the list (in fact a build_entry_return) - of constructors corresponding to [rt] when replacing calls to [funnames] by calls to the - corresponding graphs. +(* [build_entry_lc funnames avoid rt] construct the list (in fact a build_entry_return) + of constructors corresponding to [rt] when replacing calls to [funnames] by calls to the + corresponding graphs. The idea to transform a term [t] into a list of constructors [lc] is the following: - \begin{itemize} - \item if the term is a binder (bind x, body) then first compute [lc'] the list corresponding + \begin{itemize} + \item if the term is a binder (bind x, body) then first compute [lc'] the list corresponding to [body] and add (bind x. _) to each elements of [lc] - \item if the term has the form (g t1 ... ... tn) where g does not appears in (fnames) - then compute [lc1] ... [lcn] the lists of constructors corresponding to [t1] ... [tn], - then combine those lists and [g] as follows~: for each element [c1,...,cn] of [lc1\times...\times lcn], + \item if the term has the form (g t1 ... ... tn) where g does not appears in (fnames) + then compute [lc1] ... [lcn] the lists of constructors corresponding to [t1] ... [tn], + then combine those lists and [g] as follows~: for each element [c1,...,cn] of [lc1\times...\times lcn], [g c1 ... cn] is an element of [lc] - \item if the term has the form (f t1 .... tn) where [f] appears in [fnames] then - compute [lc1] ... [lcn] the lists of constructors corresponding to [t1] ... [tn], + \item if the term has the form (f t1 .... tn) where [f] appears in [fnames] then + compute [lc1] ... [lcn] the lists of constructors corresponding to [t1] ... [tn], then compute those lists and [f] as follows~: for each element [c1,...,cn] of [lc1\times...\times lcn] create a new variable [res] and [forall res, R_f c1 ... cn res] is in [lc] \item if the term is a cast just treat its body part - \item - if the term is a match, an if or a lettuple then compute the lists corresponding to each branch of the case + \item + if the term is a match, an if or a lettuple then compute the lists corresponding to each branch of the case and concatenate them (informally, each branch of a match produces a new constructor) \end{itemize} - - WARNING: The terms constructed here are only USING the rawconstr syntax but are highly bad formed. - We must wait to have complete all the current calculi to set the recursive calls. - At this point, each term [f t1 ... tn] (where f appears in [funnames]) is replaced by - a pseudo term [forall res, res t1 ... tn, res]. A reconstruction phase is done later. - We in fact not create a constructor list since then end of each constructor has not the expected form - but only the value of the function + + WARNING: The terms constructed here are only USING the rawconstr syntax but are highly bad formed. + We must wait to have complete all the current calculi to set the recursive calls. + At this point, each term [f t1 ... tn] (where f appears in [funnames]) is replaced by + a pseudo term [forall res, res t1 ... tn, res]. A reconstruction phase is done later. + We in fact not create a constructor list since then end of each constructor has not the expected form + but only the value of the function *) -let rec build_entry_lc env funnames avoid rt : rawconstr build_entry_return = +let rec build_entry_lc env funnames avoid rt : rawconstr build_entry_return = observe (str " Entering : " ++ Printer.pr_rawconstr rt); - match rt with - | RRef _ | RVar _ | REvar _ | RPatVar _ | RSort _ | RHole _ -> + match rt with + | RRef _ | RVar _ | REvar _ | RPatVar _ | RSort _ | RHole _ -> (* do nothing (except changing type of course) *) - mk_result [] rt avoid + mk_result [] rt avoid | RApp(_,_,_) -> let f,args = raw_decompose_app rt in let args_res : (rawconstr list) build_entry_return = @@ -502,108 +502,108 @@ let rec build_entry_lc env funnames avoid rt : rawconstr build_entry_return = match f with | RVar(_,id) when Idset.mem id funnames -> (* if we have [f t1 ... tn] with [f]$\in$[fnames] - then we create a fresh variable [res], - add [res] and its "value" (i.e. [res v1 ... vn]) to each - pseudo constructor build for the arguments (i.e. a pseudo context [ctxt] and - a pseudo value "v1 ... vn". + then we create a fresh variable [res], + add [res] and its "value" (i.e. [res v1 ... vn]) to each + pseudo constructor build for the arguments (i.e. a pseudo context [ctxt] and + a pseudo value "v1 ... vn". The "value" of this branch is then simply [res] *) - let rt_as_constr = Pretyping.Default.understand Evd.empty env rt in - let rt_typ = Typing.type_of env Evd.empty rt_as_constr in + let rt_as_constr = Pretyping.Default.understand Evd.empty env rt in + let rt_typ = Typing.type_of env Evd.empty rt_as_constr in let res_raw_type = Detyping.detype false [] (Termops.names_of_rel_context env) rt_typ in let res = fresh_id args_res.to_avoid "res" in let new_avoid = res::args_res.to_avoid in - let res_rt = mkRVar res in - let new_result = - List.map - (fun arg_res -> - let new_hyps = + let res_rt = mkRVar res in + let new_result = + List.map + (fun arg_res -> + let new_hyps = [Prod (Name res),res_raw_type; Prod Anonymous,mkRApp(res_rt,(mkRVar id)::arg_res.value)] in - {context = arg_res.context@new_hyps; value = res_rt } + {context = arg_res.context@new_hyps; value = res_rt } ) args_res.result - in + in { result = new_result; to_avoid = new_avoid } - | RVar _ | REvar _ | RPatVar _ | RHole _ | RSort _ | RRef _ -> - (* if have [g t1 ... tn] with [g] not appearing in [funnames] - then - foreach [ctxt,v1 ... vn] in [args_res] we return + | RVar _ | REvar _ | RPatVar _ | RHole _ | RSort _ | RRef _ -> + (* if have [g t1 ... tn] with [g] not appearing in [funnames] + then + foreach [ctxt,v1 ... vn] in [args_res] we return [ctxt, g v1 .... vn] *) { - args_res with - result = - List.map - (fun args_res -> + args_res with + result = + List.map + (fun args_res -> {args_res with value = mkRApp(f,args_res.value)}) args_res.result } | RApp _ -> assert false (* we have collected all the app in [raw_decompose_app] *) - | RLetIn(_,n,t,b) -> - (* if we have [(let x := v in b) t1 ... tn] , - we discard our work and compute the list of constructor for - [let x = v in (b t1 ... tn)] up to alpha conversion + | RLetIn(_,n,t,b) -> + (* if we have [(let x := v in b) t1 ... tn] , + we discard our work and compute the list of constructor for + [let x = v in (b t1 ... tn)] up to alpha conversion *) - let new_n,new_b,new_avoid = - match n with - | Name id when List.exists (is_free_in id) args -> + let new_n,new_b,new_avoid = + match n with + | Name id when List.exists (is_free_in id) args -> (* need to alpha-convert the name *) - let new_id = Nameops.next_ident_away id avoid in + let new_id = Nameops.next_ident_away id avoid in let new_avoid = id:: avoid in - let new_b = + let new_b = replace_var_by_term id - (RVar(dummy_loc,id)) + (RVar(dummy_loc,id)) b - in + in (Name new_id,new_b,new_avoid) | _ -> n,b,avoid in - build_entry_lc + build_entry_lc env - funnames + funnames avoid (mkRLetIn(new_n,t,mkRApp(new_b,args))) - | RCases _ | RLambda _ | RIf _ | RLetTuple _ -> + | RCases _ | RLambda _ | RIf _ | RLetTuple _ -> (* we have [(match e1, ...., en with ..... end) t1 tn] - we first compute the result from the case and + we first compute the result from the case and then combine each of them with each of args one *) let f_res = build_entry_lc env funnames args_res.to_avoid f in combine_results combine_app f_res args_res - | RDynamic _ ->error "Not handled RDynamic" - | RCast(_,b,_) -> - (* for an applied cast we just trash the cast part - and restart the work. + | RDynamic _ ->error "Not handled RDynamic" + | RCast(_,b,_) -> + (* for an applied cast we just trash the cast part + and restart the work. WARNING: We need to restart since [b] itself should be an application term *) build_entry_lc env funnames avoid (mkRApp(b,args)) | RRec _ -> error "Not handled RRec" | RProd _ -> error "Cannot apply a type" - end (* end of the application treatement *) + end (* end of the application treatement *) | 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 + (* we first compute the list of constructor + corresponding to the body of the function, + then the one corresponding to the type and combine the two result *) let t_res = build_entry_lc env funnames avoid t in - let new_n = - match n with - | Name _ -> n + let new_n = + match n with + | Name _ -> n | Anonymous -> Name (Indfun_common.fresh_id [] "_x") in 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) -> - (* we first compute the list of constructor - corresponding to the body of the function, - then the one corresponding to the type + (* we first compute the list of constructor + corresponding to the body of the function, + then the one corresponding to the type and combine the two result *) let t_res = build_entry_lc env funnames avoid t in @@ -611,38 +611,38 @@ let rec build_entry_lc env funnames avoid rt : rawconstr build_entry_return = let b_res = build_entry_lc new_env funnames avoid b in combine_results (combine_prod n) t_res b_res | RLetIn(_,n,v,b) -> - (* we first compute the list of constructor - corresponding to the body of the function, - then the one corresponding to the value [t] + (* we first compute the list of constructor + corresponding to the body of the function, + then the one corresponding to the value [t] and combine the two result *) let v_res = build_entry_lc env funnames avoid v in - let v_as_constr = Pretyping.Default.understand Evd.empty env v in - let v_type = Typing.type_of env Evd.empty v_as_constr in - let new_env = + let v_as_constr = Pretyping.Default.understand Evd.empty env v in + let v_type = Typing.type_of env Evd.empty v_as_constr in + let new_env = match n with Anonymous -> env - | Name id -> Environ.push_named (id,Some v_as_constr,v_type) env + | Name id -> Environ.push_named (id,Some v_as_constr,v_type) env 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) -> - (* we create the discrimination function - and treat the case itself + | RCases(_,_,_,el,brl) -> + (* we create the discrimination function + and treat the case itself *) - let make_discr = make_discr_match brl in + let make_discr = make_discr_match brl in build_entry_lc_from_case env funnames make_discr el brl avoid - | RIf(_,b,(na,e_option),lhs,rhs) -> + | RIf(_,b,(na,e_option),lhs,rhs) -> let b_as_constr = Pretyping.Default.understand Evd.empty env b in - let b_typ = Typing.type_of env Evd.empty b_as_constr in - let (ind,_) = - try Inductiveops.find_inductive env Evd.empty b_typ - with Not_found -> - errorlabstrm "" (str "Cannot find the inductive associated to " ++ + let b_typ = Typing.type_of env Evd.empty b_as_constr in + let (ind,_) = + try Inductiveops.find_inductive env Evd.empty b_typ + with Not_found -> + errorlabstrm "" (str "Cannot find the inductive associated to " ++ Printer.pr_rawconstr b ++ str " in " ++ Printer.pr_rawconstr rt ++ str ". try again with a cast") in - let case_pats = build_constructors_of_type ind [] in + let case_pats = build_constructors_of_type ind [] in assert (Array.length case_pats = 2); let brl = list_map_i @@ -655,7 +655,7 @@ let rec build_entry_lc env funnames avoid rt : rawconstr build_entry_return = in (* Pp.msgnl (str "new case := " ++ Printer.pr_rawconstr match_expr); *) build_entry_lc env funnames avoid match_expr - | RLetTuple(_,nal,_,b,e) -> + | RLetTuple(_,nal,_,b,e) -> begin let nal_as_rawconstr = List.map @@ -666,15 +666,15 @@ let rec build_entry_lc env funnames avoid rt : rawconstr build_entry_return = nal in let b_as_constr = Pretyping.Default.understand Evd.empty env b in - let b_typ = Typing.type_of env Evd.empty b_as_constr in - let (ind,_) = - try Inductiveops.find_inductive env Evd.empty b_typ - with Not_found -> - errorlabstrm "" (str "Cannot find the inductive associated to " ++ + let b_typ = Typing.type_of env Evd.empty b_as_constr in + let (ind,_) = + try Inductiveops.find_inductive env Evd.empty b_typ + with Not_found -> + errorlabstrm "" (str "Cannot find the inductive associated to " ++ Printer.pr_rawconstr b ++ str " in " ++ Printer.pr_rawconstr rt ++ str ". try again with a cast") in - let case_pats = build_constructors_of_type ind nal_as_rawconstr in + let case_pats = build_constructors_of_type ind nal_as_rawconstr in assert (Array.length case_pats = 1); let br = (dummy_loc,[],[case_pats.(0)],e) @@ -684,25 +684,25 @@ let rec build_entry_lc env funnames avoid rt : rawconstr build_entry_return = end | RRec _ -> error "Not handled RRec" - | RCast(_,b,_) -> + | RCast(_,b,_) -> build_entry_lc env funnames avoid b | RDynamic _ -> error "Not handled RDynamic" and build_entry_lc_from_case env funname make_discr (el:tomatch_tuples) - (brl:Rawterm.cases_clauses) avoid : - rawconstr build_entry_return = - match el with - | [] -> assert false (* this case correspond to match <nothing> with .... !*) - | el -> - (* this case correspond to + (brl:Rawterm.cases_clauses) avoid : + rawconstr build_entry_return = + match el with + | [] -> assert false (* this case correspond to match <nothing> with .... !*) + | el -> + (* this case correspond to match el with brl end - we first compute the list of lists corresponding to [el] and - combine them . - Then for each elemeent of the combinations, - we compute the result we compute one list per branch in [brl] and - finally we just concatenate those list + we first compute the list of lists corresponding to [el] and + combine them . + Then for each elemeent of the combinations, + we compute the result we compute one list per branch in [brl] and + finally we just concatenate those list *) - let case_resl = + let case_resl = List.fold_right (fun (case_arg,_) ctxt_argsl -> let arg_res = build_entry_lc env funname avoid case_arg in @@ -711,32 +711,32 @@ and build_entry_lc_from_case env funname make_discr el (mk_result [] [] avoid) in - let types = - List.map (fun (case_arg,_) -> - let case_arg_as_constr = Pretyping.Default.understand Evd.empty env case_arg in + let types = + List.map (fun (case_arg,_) -> + let case_arg_as_constr = Pretyping.Default.understand Evd.empty env case_arg in Typing.type_of env Evd.empty case_arg_as_constr ) el in (****** The next works only if the match is not dependent ****) let results = - List.map - (fun ca -> + List.map + (fun ca -> let res = build_entry_lc_from_case_term env types funname (make_discr) - [] brl + [] brl case_resl.to_avoid ca - in + in res - ) - case_resl.result - in - { + ) + case_resl.result + in + { result = List.concat (List.map (fun r -> r.result) results); - to_avoid = + to_avoid = List.fold_left (fun acc r -> list_union acc r.to_avoid) [] results - } + } and build_entry_lc_from_case_term env types funname make_discr patterns_to_prevent brl avoid matched_expr = @@ -746,24 +746,24 @@ and build_entry_lc_from_case_term env types funname make_discr patterns_to_preve (* alpha convertion to prevent name clashes *) let _,idl,patl,return = alpha_br avoid br in let new_avoid = idl@avoid in (* for now we can no more use idl as an indentifier *) - (* building a list of precondition stating that we are not in this branch + (* building a list of precondition stating that we are not in this branch (will be used in the following recursive calls) *) - let new_env = List.fold_right2 add_pat_variables patl types env in - let not_those_patterns : (identifier list -> rawconstr -> rawconstr) list = + let new_env = List.fold_right2 add_pat_variables patl types env in + let not_those_patterns : (identifier list -> rawconstr -> rawconstr) list = List.map2 - (fun pat typ -> - fun avoid pat'_as_term -> + (fun pat typ -> + fun avoid pat'_as_term -> let renamed_pat,_,_ = alpha_pat avoid pat in - let pat_ids = get_pattern_id renamed_pat in - let env_with_pat_ids = add_pat_variables pat typ new_env in - List.fold_right - (fun id acc -> - let typ_of_id = - Typing.type_of env_with_pat_ids Evd.empty (mkVar id) - in - let raw_typ_of_id = - Detyping.detype false [] + let pat_ids = get_pattern_id renamed_pat in + let env_with_pat_ids = add_pat_variables pat typ new_env in + List.fold_right + (fun id acc -> + let typ_of_id = + Typing.type_of env_with_pat_ids Evd.empty (mkVar id) + in + let raw_typ_of_id = + Detyping.detype false [] (Termops.names_of_rel_context env_with_pat_ids) typ_of_id in mkRProd (Name id,raw_typ_of_id,acc)) @@ -773,21 +773,21 @@ and build_entry_lc_from_case_term env types funname make_discr patterns_to_preve patl types in - (* Checking if we can be in this branch + (* Checking if we can be in this branch (will be used in the following recursive calls) - *) + *) let unify_with_those_patterns : (cases_pattern -> bool*bool) list = - List.map - (fun pat pat' -> are_unifiable pat pat',eq_cases_pattern pat pat') + List.map + (fun pat pat' -> are_unifiable pat pat',eq_cases_pattern pat pat') patl in - (* - we first compute the other branch result (in ordrer to keep the order of the matching + (* + we first compute the other branch result (in ordrer to keep the order of the matching as much as possible) *) let brl'_res = build_entry_lc_from_case_term - env + env types funname make_discr @@ -797,9 +797,9 @@ and build_entry_lc_from_case_term env types funname make_discr patterns_to_preve matched_expr in (* We now create the precondition of this branch i.e. - 1- the list of variable appearing in the different patterns of this branch and + 1- the list of variable appearing in the different patterns of this branch and the list of equation stating than el = patl (List.flatten ...) - 2- If there exists a previous branch which pattern unify with the one of this branch + 2- If there exists a previous branch which pattern unify with the one of this branch then a discrimination precond stating that we are not in a previous branch (if List.exists ...) *) let those_pattern_preconds = @@ -807,15 +807,15 @@ and build_entry_lc_from_case_term env types funname make_discr patterns_to_preve ( list_map3 (fun pat e typ_as_constr -> - let this_pat_ids = ids_of_pat pat in + let this_pat_ids = ids_of_pat pat in let typ = Detyping.detype false [] (Termops.names_of_rel_context new_env) typ_as_constr in let pat_as_term = pattern_to_term pat in - List.fold_right - (fun id acc -> - if Idset.mem id this_pat_ids + List.fold_right + (fun id acc -> + if Idset.mem id this_pat_ids then (Prod (Name id), - let typ_of_id = Typing.type_of new_env Evd.empty (mkVar id) in - let raw_typ_of_id = + let typ_of_id = Typing.type_of new_env Evd.empty (mkVar id) in + let raw_typ_of_id = Detyping.detype false [] (Termops.names_of_rel_context new_env) typ_of_id in raw_typ_of_id @@ -832,15 +832,15 @@ and build_entry_lc_from_case_term env types funname make_discr patterns_to_preve ) @ (if List.exists (function (unifl,_) -> - let (unif,_) = + let (unif,_) = List.split (List.map2 (fun x y -> x y) unifl patl) in List.for_all (fun x -> x) unif) patterns_to_prevent - then - let i = List.length patterns_to_prevent in + then + let i = List.length patterns_to_prevent in let pats_as_constr = List.map2 (pattern_to_term_and_type new_env) types patl in [(Prod Anonymous,make_discr pats_as_constr i )] - else + else [] ) in @@ -856,183 +856,183 @@ and build_entry_lc_from_case_term env types funname make_discr patterns_to_preve return_res.result in { brl'_res with result = this_branch_res@brl'_res.result } - - -let is_res id = + + +let is_res id = try String.sub (string_of_id id) 0 3 = "res" - with Invalid_argument _ -> false + with Invalid_argument _ -> false exception Continue -(* - The second phase which reconstruct the real type of the constructor. - rebuild the raw constructors expression. +(* + The second phase which reconstruct the real type of the constructor. + rebuild the raw constructors expression. eliminates some meaningless equalities, applies some rewrites...... *) -let rec rebuild_cons env nb_args relname args crossed_types depth rt = +let rec rebuild_cons env nb_args relname args crossed_types depth rt = observe (str "rebuilding : " ++ pr_rawconstr rt); - match rt with - | 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 + match rt with + | 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 - match t with + match t with | RApp(_,(RVar(_,res_id) as res_rt),args') when is_res res_id -> begin - match args' with - | (RVar(_,this_relname))::args' -> - (*i The next call to mk_rel_id is + match args' with + | (RVar(_,this_relname))::args' -> + (*i The next call to mk_rel_id is valid since we are constructing the graph Ensures by: obvious - i*) - - let new_t = - mkRApp(mkRVar(mk_rel_id this_relname),args'@[res_rt]) - in - let t' = Pretyping.Default.understand Evd.empty env new_t in - let new_env = Environ.push_rel (n,None,t') env in - let new_b,id_to_exclude = + i*) + + let new_t = + mkRApp(mkRVar(mk_rel_id this_relname),args'@[res_rt]) + in + let t' = Pretyping.Default.understand Evd.empty env new_t in + let new_env = Environ.push_rel (n,None,t') env in + let new_b,id_to_exclude = rebuild_cons new_env nb_args relname args new_crossed_types (depth + 1) b - in + in mkRProd(n,new_t,new_b), Idset.filter not_free_in_t id_to_exclude | _ -> (* the first args is the name of the function! *) - assert false + assert false end - | RApp(loc1,RRef(loc2,eq_as_ref),[ty;RVar(loc3,id);rt]) + | RApp(loc1,RRef(loc2,eq_as_ref),[ty;RVar(loc3,id);rt]) when eq_as_ref = Lazy.force Coqlib.coq_eq_ref && n = Anonymous - -> + -> begin - try + try observe (str "computing new type for eq : " ++ pr_rawconstr rt); - let t' = + let t' = try Pretyping.Default.understand Evd.empty env t with _ -> raise Continue in let is_in_b = is_free_in id b in - let _keep_eq = - not (List.exists (is_free_in id) args) || is_in_b || - List.exists (is_free_in id) crossed_types - in - let new_args = List.map (replace_var_by_term id rt) args in - let subst_b = - if is_in_b then b else replace_var_by_term id rt b - in + let _keep_eq = + not (List.exists (is_free_in id) args) || is_in_b || + List.exists (is_free_in id) crossed_types + in + let new_args = List.map (replace_var_by_term id rt) args in + let subst_b = + if is_in_b then b else replace_var_by_term id rt b + in let new_env = Environ.push_rel (n,None,t') env in - let new_b,id_to_exclude = - rebuild_cons + let new_b,id_to_exclude = + rebuild_cons new_env nb_args relname new_args new_crossed_types (depth + 1) subst_b - in + in mkRProd(n,t,new_b),id_to_exclude - with Continue -> - let jmeq = Libnames.IndRef (destInd (jmeq ())) in - let ty' = Pretyping.Default.understand Evd.empty env ty in - let ind,args' = Inductive.find_inductive env ty' in - let mib,_ = Global.lookup_inductive ind in - let nparam = mib.Declarations.mind_nparams in - let params,arg' = + with Continue -> + let jmeq = Libnames.IndRef (destInd (jmeq ())) in + let ty' = Pretyping.Default.understand Evd.empty env ty in + let ind,args' = Inductive.find_inductive env ty' in + let mib,_ = Global.lookup_inductive ind in + let nparam = mib.Declarations.mind_nparams in + let params,arg' = ((Util.list_chop nparam args')) in - let rt_typ = + let rt_typ = RApp(Util.dummy_loc, - RRef (Util.dummy_loc,Libnames.IndRef ind), - (List.map - (fun p -> Detyping.detype false [] + RRef (Util.dummy_loc,Libnames.IndRef ind), + (List.map + (fun p -> Detyping.detype false [] (Termops.names_of_rel_context env) - p) params)@(Array.to_list - (Array.make - (List.length args' - nparam) + p) params)@(Array.to_list + (Array.make + (List.length args' - nparam) (mkRHole ())))) in - let eq' = + let eq' = RApp(loc1,RRef(loc2,jmeq),[ty;RVar(loc3,id);rt_typ;rt]) in observe (str "computing new type for jmeq : " ++ pr_rawconstr eq'); let eq'_as_constr = Pretyping.Default.understand Evd.empty env eq' in observe (str " computing new type for jmeq : done") ; - let new_args = - match kind_of_term eq'_as_constr with - | App(_,[|_;_;ty;_|]) -> - let ty = Array.to_list (snd (destApp ty)) in - let ty' = snd (Util.list_chop nparam ty) in - List.fold_left2 - (fun acc var_as_constr arg -> - if isRel var_as_constr - then - let (na,_,_) = + let new_args = + match kind_of_term eq'_as_constr with + | App(_,[|_;_;ty;_|]) -> + let ty = Array.to_list (snd (destApp ty)) in + let ty' = snd (Util.list_chop nparam ty) in + List.fold_left2 + (fun acc var_as_constr arg -> + if isRel var_as_constr + then + let (na,_,_) = Environ.lookup_rel (destRel var_as_constr) env - in - match na with - | Anonymous -> acc - | Name id' -> - (id',Detyping.detype false [] + in + match na with + | Anonymous -> acc + | Name id' -> + (id',Detyping.detype false [] (Termops.names_of_rel_context env) arg)::acc - else if isVar var_as_constr - then (destVar var_as_constr,Detyping.detype false [] + else if isVar var_as_constr + then (destVar var_as_constr,Detyping.detype false [] (Termops.names_of_rel_context env) arg)::acc else acc ) [] arg' - ty' + ty' | _ -> assert false in let is_in_b = is_free_in id b in - let _keep_eq = - not (List.exists (is_free_in id) args) || is_in_b || - List.exists (is_free_in id) crossed_types - in - let new_args = - List.fold_left + let _keep_eq = + not (List.exists (is_free_in id) args) || is_in_b || + List.exists (is_free_in id) crossed_types + in + let new_args = + List.fold_left (fun args (id,rt) -> List.map (replace_var_by_term id rt) args ) - args + args ((id,rt)::new_args) - in - let subst_b = + in + let subst_b = if is_in_b then b else replace_var_by_term id rt b - in - let new_env = - let t' = Pretyping.Default.understand Evd.empty env eq' in + in + let new_env = + let t' = Pretyping.Default.understand Evd.empty env eq' in Environ.push_rel (n,None,t') env in - let new_b,id_to_exclude = - rebuild_cons + let new_b,id_to_exclude = + rebuild_cons new_env nb_args relname new_args new_crossed_types (depth + 1) subst_b - in + in mkRProd(n,eq',new_b),id_to_exclude end - (* J.F:. keep this comment it explain how to remove some meaningless equalities + (* J.F:. keep this comment it explain how to remove some meaningless equalities if keep_eq then mkRProd(n,t,new_b),id_to_exclude else new_b, Idset.add id id_to_exclude *) - | _ -> + | _ -> observe (str "computing new type for prod : " ++ pr_rawconstr rt); - let t' = Pretyping.Default.understand Evd.empty env t in - let new_env = Environ.push_rel (n,None,t') env in - let new_b,id_to_exclude = + let t' = Pretyping.Default.understand Evd.empty env t in + let new_env = Environ.push_rel (n,None,t') env in + let new_b,id_to_exclude = rebuild_cons new_env nb_args relname args new_crossed_types (depth + 1) b - in + in match n with | Name id when Idset.mem id id_to_exclude && depth >= nb_args -> - new_b,Idset.remove id + new_b,Idset.remove id (Idset.filter not_free_in_t id_to_exclude) | _ -> mkRProd(n,t,new_b),Idset.filter not_free_in_t id_to_exclude end @@ -1041,60 +1041,60 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = let not_free_in_t id = not (is_free_in id t) in let new_crossed_types = t :: crossed_types in observe (str "computing new type for lambda : " ++ pr_rawconstr rt); - let t' = Pretyping.Default.understand Evd.empty env t in + let t' = Pretyping.Default.understand Evd.empty env t in match n with | Name id -> - let new_env = Environ.push_rel (n,None,t') env in - let new_b,id_to_exclude = + let new_env = Environ.push_rel (n,None,t') env in + let new_b,id_to_exclude = rebuild_cons new_env nb_args relname (args@[mkRVar id])new_crossed_types - (depth + 1 ) b + (depth + 1 ) b in if Idset.mem id id_to_exclude && depth >= nb_args - then + then new_b, Idset.remove id (Idset.filter not_free_in_t id_to_exclude) else 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" + | _ -> anomaly "Should not have an anonymous function here" (* We have renamed all the anonymous functions during alpha_renaming phase *) - + end - | RLetIn(_,n,t,b) -> + | RLetIn(_,n,t,b) -> begin - let not_free_in_t id = not (is_free_in id t) in - let t' = Pretyping.Default.understand Evd.empty env t in - let type_t' = Typing.type_of env Evd.empty t' in + let not_free_in_t id = not (is_free_in id t) in + let t' = Pretyping.Default.understand Evd.empty env t in + let type_t' = Typing.type_of env Evd.empty t' in let new_env = Environ.push_rel (n,Some t',type_t') env in - let new_b,id_to_exclude = - rebuild_cons new_env + let new_b,id_to_exclude = + rebuild_cons new_env nb_args relname args (t::crossed_types) (depth + 1 ) b in - match n with - | Name id when Idset.mem id id_to_exclude && depth >= nb_args -> + match n with + | Name id when Idset.mem id id_to_exclude && depth >= nb_args -> new_b,Idset.remove id (Idset.filter not_free_in_t id_to_exclude) | _ -> RLetIn(dummy_loc,n,t,new_b), Idset.filter not_free_in_t id_to_exclude end - | RLetTuple(_,nal,(na,rto),t,b) -> + | RLetTuple(_,nal,(na,rto),t,b) -> assert (rto=None); begin - let not_free_in_t id = not (is_free_in id t) in - let new_t,id_to_exclude' = + let not_free_in_t id = not (is_free_in id t) in + let new_t,id_to_exclude' = rebuild_cons env nb_args - relname - args (crossed_types) - depth t + relname + args (crossed_types) + depth t in - let t' = Pretyping.Default.understand Evd.empty env new_t in - let new_env = Environ.push_rel (na,None,t') env in - let new_b,id_to_exclude = + let t' = Pretyping.Default.understand Evd.empty env new_t in + let new_env = Environ.push_rel (na,None,t') env in + let new_b,id_to_exclude = rebuild_cons new_env nb_args relname - args (t::crossed_types) - (depth + 1) b + args (t::crossed_types) + (depth + 1) b in (* match n with *) (* | Name id when Idset.mem id id_to_exclude -> *) @@ -1109,125 +1109,125 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = (* debuging wrapper *) -let rebuild_cons env nb_args relname args crossed_types rt = +let rebuild_cons env nb_args relname args crossed_types rt = (* observennl (str "rebuild_cons : rt := "++ pr_rawconstr rt ++ *) (* str "nb_args := " ++ str (string_of_int nb_args)); *) - let res = - rebuild_cons env nb_args relname args crossed_types 0 rt + let res = + rebuild_cons env nb_args relname args crossed_types 0 rt in (* observe (str " leads to "++ pr_rawconstr (fst res)); *) res -(* naive implementation of parameter detection. +(* naive implementation of parameter detection. - A parameter is an argument which is only preceded by parameters and whose - calls are all syntaxically equal. + A parameter is an argument which is only preceded by parameters and whose + calls are all syntaxically equal. - TODO: Find a valid way to deal with implicit arguments here! + TODO: Find a valid way to deal with implicit arguments here! *) -let rec compute_cst_params relnames params = function +let rec compute_cst_params relnames params = function | RRef _ | RVar _ | REvar _ | RPatVar _ -> params | RApp(_,RVar(_,relname'),rtl) when Idset.mem relname' relnames -> compute_cst_params_from_app [] (params,rtl) - | RApp(_,f,args) -> + | 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) -> - let t_params = compute_cst_params relnames params t in + | 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 + params (* If there is still cases at this point they can only be discriminitation ones *) | RSort _ -> params | RHole _ -> params | RIf _ | RRec _ | RCast _ | RDynamic _ -> raise (UserError("compute_cst_params", str "Not handled case")) -and compute_cst_params_from_app acc (params,rtl) = - match params,rtl with +and compute_cst_params_from_app acc (params,rtl) = + match params,rtl with | _::_,[] -> assert false (* the rel has at least nargs + 1 arguments ! *) - | ((Name id,_,is_defined) as param)::params',(RVar(_,id'))::rtl' - when id_ord id id' == 0 && not is_defined -> + | ((Name id,_,is_defined) as param)::params',(RVar(_,id'))::rtl' + when id_ord id id' == 0 && not is_defined -> compute_cst_params_from_app (param::acc) (params',rtl') - | _ -> List.rev acc - -let compute_params_name relnames (args : (Names.name * Rawterm.rawconstr * bool) list array) csts = - let rels_params = - Array.mapi - (fun i args -> - List.fold_left - (fun params (_,cst) -> compute_cst_params relnames params cst) + | _ -> List.rev acc + +let compute_params_name relnames (args : (Names.name * Rawterm.rawconstr * bool) list array) csts = + let rels_params = + Array.mapi + (fun i args -> + List.fold_left + (fun params (_,cst) -> compute_cst_params relnames params cst) args csts.(i) ) args - in - let l = ref [] in - let _ = - try + in + let l = ref [] in + let _ = + try list_iter_i - (fun i ((n,nt,is_defined) as param) -> - if array_for_all - (fun l -> - let (n',nt',is_defined') = List.nth l i in + (fun i ((n,nt,is_defined) as param) -> + if array_for_all + (fun l -> + let (n',nt',is_defined') = List.nth l i in n = n' && Topconstr.eq_rawconstr nt nt' && is_defined = is_defined') rels_params - then + then l := param::!l - ) + ) rels_params.(0) - with _ -> + with _ -> () - in + in List.rev !l -let rec rebuild_return_type rt = - match rt with - | Topconstr.CProdN(loc,n,t') -> - Topconstr.CProdN(loc,n,rebuild_return_type t') - | Topconstr.CArrow(loc,t,t') -> +let rec rebuild_return_type rt = + match rt with + | Topconstr.CProdN(loc,n,t') -> + Topconstr.CProdN(loc,n,rebuild_return_type t') + | Topconstr.CArrow(loc,t,t') -> Topconstr.CArrow(loc,t,rebuild_return_type t') - | Topconstr.CLetIn(loc,na,t,t') -> - Topconstr.CLetIn(loc,na,t,rebuild_return_type t') + | Topconstr.CLetIn(loc,na,t,t') -> + Topconstr.CLetIn(loc,na,t,rebuild_return_type t') | _ -> Topconstr.CArrow(dummy_loc,rt,Topconstr.CSort(dummy_loc,RType None)) -let do_build_inductive - funnames (funsargs: (Names.name * rawconstr * bool) list list) - returned_types +let do_build_inductive + funnames (funsargs: (Names.name * rawconstr * bool) list list) + returned_types (rtl:rawconstr list) = let _time1 = System.get_time () in (* Pp.msgnl (prlist_with_sep fnl Printer.pr_rawconstr rtl); *) let funnames_as_set = List.fold_right Idset.add funnames Idset.empty in - let funnames = Array.of_list funnames in - let funsargs = Array.of_list funsargs in + let funnames = Array.of_list funnames in + let funsargs = Array.of_list funsargs in let returned_types = Array.of_list returned_types in (* alpha_renaming of the body to prevent variable capture during manipulation *) let rtl_alpha = List.map (function rt -> expand_as (alpha_rt [] rt)) rtl in let rta = Array.of_list rtl_alpha in (*i The next call to mk_rel_id is valid since we are constructing the graph Ensures by: obvious - i*) + i*) let relnames = Array.map mk_rel_id funnames in - let relnames_as_set = Array.fold_right Idset.add relnames Idset.empty in + let relnames_as_set = Array.fold_right Idset.add relnames Idset.empty in (* Construction of the pseudo constructors *) - let env = - Array.fold_right - (fun id env -> + let env = + Array.fold_right + (fun id env -> Environ.push_named (id,None,Typing.type_of env Evd.empty (Tacinterp.constr_of_id env id)) env ) - funnames + funnames (Global.env ()) - in - let resa = Array.map (build_entry_lc env funnames_as_set []) rta in - let env_with_graphs = + in + let resa = Array.map (build_entry_lc env funnames_as_set []) rta in + let env_with_graphs = let rel_arity i funargs = (* Reduilding arities (with parameters) *) - let rel_first_args :(Names.name * Rawterm.rawconstr * bool ) list = + let rel_first_args :(Names.name * Rawterm.rawconstr * bool ) list = funargs - in + in List.fold_right - (fun (n,t,is_defined) acc -> + (fun (n,t,is_defined) acc -> if is_defined - then + then Topconstr.CLetIn(dummy_loc,(dummy_loc, n),Constrextern.extern_rawconstr Idset.empty t, acc) else @@ -1240,40 +1240,40 @@ let do_build_inductive rel_first_args (rebuild_return_type returned_types.(i)) in - (* We need to lift back our work topconstr but only with all information - We mimick a Set Printing All. - Then save the graphs and reset Printing options to their primitive values + (* We need to lift back our work topconstr but only with all information + We mimick a Set Printing All. + Then save the graphs and reset Printing options to their primitive values *) let rel_arities = Array.mapi rel_arity funsargs in - Util.array_fold_left2 (fun env rel_name rel_ar -> + Util.array_fold_left2 (fun env rel_name rel_ar -> Environ.push_named (rel_name,None, Constrintern.interp_constr Evd.empty env rel_ar) env) env relnames rel_arities in (* and of the real constructors*) - let constr i res = - List.map - (function result (* (args',concl') *) -> - let rt = compose_raw_context result.context result.value in - let nb_args = List.length funsargs.(i) in + let constr i res = + List.map + (function result (* (args',concl') *) -> + let rt = compose_raw_context result.context result.value in + let nb_args = List.length funsargs.(i) in (* with_full_print (fun rt -> Pp.msgnl (str "raw constr " ++ pr_rawconstr rt)) rt; *) fst ( rebuild_cons env_with_graphs nb_args relnames.(i) [] [] - rt + rt ) - ) - res.result - in + ) + res.result + in (* adding names to constructors *) - let next_constructor_id = ref (-1) in - let mk_constructor_id i = + let next_constructor_id = ref (-1) in + let mk_constructor_id i = incr next_constructor_id; (*i The next call to mk_rel_id is valid since we are constructing the graph Ensures by: obvious - i*) + i*) id_of_string ((string_of_id (mk_rel_id funnames.(i)))^"_"^(string_of_int !next_constructor_id)) in - let rel_constructors i rt : (identifier*rawconstr) list = + let rel_constructors i rt : (identifier*rawconstr) list = next_constructor_id := (-1); List.map (fun constr -> (mk_constructor_id i),constr) (constr i rt) in @@ -1282,18 +1282,18 @@ let do_build_inductive let rels_params = compute_params_name relnames_as_set funsargs rel_constructors in let nrel_params = List.length rels_params in let rel_constructors = (* Taking into account the parameters in constructors *) - Array.map (List.map + Array.map (List.map (fun (id,rt) -> (id,snd (chop_rprod_n nrel_params rt)))) rel_constructors in let rel_arity i funargs = (* Reduilding arities (with parameters) *) - let rel_first_args :(Names.name * Rawterm.rawconstr * bool ) list = + let rel_first_args :(Names.name * Rawterm.rawconstr * bool ) list = (snd (list_chop nrel_params funargs)) - in + in List.fold_right - (fun (n,t,is_defined) acc -> + (fun (n,t,is_defined) acc -> if is_defined - then + then Topconstr.CLetIn(dummy_loc,(dummy_loc, n),Constrextern.extern_rawconstr Idset.empty t, acc) else @@ -1306,26 +1306,26 @@ let do_build_inductive rel_first_args (rebuild_return_type returned_types.(i)) in - (* We need to lift back our work topconstr but only with all information - We mimick a Set Printing All. - Then save the graphs and reset Printing options to their primitive values + (* We need to lift back our work topconstr but only with all information + We mimick a Set Printing All. + Then save the graphs and reset Printing options to their primitive values *) let rel_arities = Array.mapi rel_arity funsargs in - let rel_params = - List.map - (fun (n,t,is_defined) -> - if is_defined + let rel_params = + List.map + (fun (n,t,is_defined) -> + if is_defined then Topconstr.LocalRawDef((dummy_loc,n), Constrextern.extern_rawconstr Idset.empty t) else - Topconstr.LocalRawAssum + Topconstr.LocalRawAssum ([(dummy_loc,n)], Topconstr.default_binder_kind, Constrextern.extern_rawconstr Idset.empty t) ) rels_params - in - let ext_rels_constructors = - Array.map (List.map - (fun (id,t) -> + in + let ext_rels_constructors = + Array.map (List.map + (fun (id,t) -> false,((dummy_loc,id), Flags.with_option Flags.raw_print @@ -1334,14 +1334,14 @@ let do_build_inductive )) (rel_constructors) in - let rel_ind i ext_rel_constructors = + let rel_ind i ext_rel_constructors = ((dummy_loc,relnames.(i)), rel_params, Some rel_arities.(i), ext_rel_constructors),None in - let ext_rel_constructors = (Array.mapi rel_ind ext_rels_constructors) in - let rel_inds = Array.to_list ext_rel_constructors in + let ext_rel_constructors = (Array.mapi rel_ind ext_rels_constructors) in + let rel_inds = Array.to_list ext_rel_constructors in (* let _ = *) (* Pp.msgnl (\* observe *\) ( *) (* str "Inductive" ++ spc () ++ *) @@ -1362,18 +1362,18 @@ let do_build_inductive (* rel_inds *) (* ) *) (* in *) - let _time2 = System.get_time () in - try + let _time2 = System.get_time () in + try with_full_print (Flags.silently (Command.build_mutual rel_inds)) true - with + with | UserError(s,msg) as e -> let _time3 = System.get_time () in (* Pp.msgnl (str "error : "++ str (string_of_float (System.time_difference time2 time3))); *) - let repacked_rel_inds = + let repacked_rel_inds = List.map (fun ((a , b , c , l),ntn) -> ((false,a) , b, c , Vernacexpr.Inductive_kw, Vernacexpr.Constructors l),ntn ) rel_inds in - let msg = + let msg = str "while trying to define"++ spc () ++ Ppvernac.pr_vernac (Vernacexpr.VernacInductive(Decl_kinds.Finite,false,repacked_rel_inds)) ++ fnl () ++ @@ -1381,16 +1381,16 @@ let do_build_inductive in observe (msg); raise e - | e -> + | e -> let _time3 = System.get_time () in (* Pp.msgnl (str "error : "++ str (string_of_float (System.time_difference time2 time3))); *) - let repacked_rel_inds = + let repacked_rel_inds = List.map (fun ((a , b , c , l),ntn) -> ((false,a) , b, c , Vernacexpr.Inductive_kw, Vernacexpr.Constructors l),ntn ) rel_inds in - let msg = + let msg = str "while trying to define"++ spc () ++ - Ppvernac.pr_vernac (Vernacexpr.VernacInductive(Decl_kinds.Finite,false,repacked_rel_inds)) + Ppvernac.pr_vernac (Vernacexpr.VernacInductive(Decl_kinds.Finite,false,repacked_rel_inds)) ++ fnl () ++ Cerrors.explain_exn e in @@ -1399,9 +1399,9 @@ let do_build_inductive -let build_inductive funnames funsargs returned_types rtl = - try +let build_inductive funnames funsargs returned_types rtl = + try do_build_inductive funnames funsargs returned_types rtl with e -> raise (Building_graph e) - + diff --git a/plugins/funind/rawterm_to_relation.mli b/plugins/funind/rawterm_to_relation.mli index 0075fb0a07..a314050f73 100644 --- a/plugins/funind/rawterm_to_relation.mli +++ b/plugins/funind/rawterm_to_relation.mli @@ -2,8 +2,8 @@ (* - [build_inductive parametrize funnames funargs returned_types bodies] - constructs and saves the graphs of the functions [funnames] taking [funargs] as arguments + [build_inductive parametrize funnames funargs returned_types bodies] + constructs and saves the graphs of the functions [funnames] taking [funargs] as arguments and returning [returned_types] using bodies [bodies] *) diff --git a/plugins/funind/rawtermops.ml b/plugins/funind/rawtermops.ml index 92396af590..502960a144 100644 --- a/plugins/funind/rawtermops.ml +++ b/plugins/funind/rawtermops.ml @@ -1,11 +1,11 @@ -open Pp +open Pp open Rawterm open Util open Names (* Ocaml 3.06 Map.S does not handle is_empty *) let idmap_is_empty m = m = Idmap.empty -(* +(* Some basic functions to rebuild rawconstr In each of them the location is Util.dummy_loc *) @@ -24,152 +24,152 @@ let mkRCast(b,t) = RCast(dummy_loc,b,CastConv (Term.DEFAULTcast,t)) Some basic functions to decompose rawconstrs These are analogous to the ones constrs *) -let raw_decompose_prod = - let rec raw_decompose_prod args = function - | RProd(_,n,k,t,b) -> - raw_decompose_prod ((n,t)::args) b +let raw_decompose_prod = + let rec raw_decompose_prod args = function + | 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 +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 = +let raw_compose_prod = List.fold_left (fun b (n,t) -> mkRProd(n,t,b)) -let raw_compose_prod_or_letin = +let raw_compose_prod_or_letin = List.fold_left ( - fun concl decl -> - match decl with + 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 = +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) -> - raw_decompose_prod (i-1) ((n,t)::args) 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 = +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 + | 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 raw_decompose_app = let rec decompose_rapp acc rt = (* msgnl (str "raw_decompose_app on : "++ Printer.pr_rawconstr rt); *) - match rt with - | RApp(_,rt,rtl) -> + match rt with + | RApp(_,rt,rtl) -> decompose_rapp (List.fold_left (fun y x -> x::y) acc rtl) rt | rt -> rt,List.rev acc in - decompose_rapp [] + decompose_rapp [] -(* [raw_make_eq t1 t2] build the rawconstr corresponding to [t2 = t1] *) -let raw_make_eq ?(typ= mkRHole ()) t1 t2 = +(* [raw_make_eq t1 t2] build the rawconstr corresponding to [t2 = t1] *) +let raw_make_eq ?(typ= mkRHole ()) t1 t2 = mkRApp(mkRRef (Lazy.force Coqlib.coq_eq_ref),[typ;t2;t1]) -(* [raw_make_neq t1 t2] build the rawconstr corresponding to [t1 <> t2] *) -let raw_make_neq t1 t2 = +(* [raw_make_neq t1 t2] build the rawconstr corresponding to [t1 <> t2] *) +let raw_make_neq t1 t2 = mkRApp(mkRRef (Lazy.force Coqlib.coq_not_ref),[raw_make_eq t1 t2]) -(* [raw_make_or P1 P2] build the rawconstr corresponding to [P1 \/ P2] *) +(* [raw_make_or P1 P2] build the rawconstr corresponding to [P1 \/ P2] *) let raw_make_or t1 t2 = mkRApp (mkRRef(Lazy.force Coqlib.coq_or_ref),[t1;t2]) -(* [raw_make_or_list [P1;...;Pn]] build the rawconstr corresponding - to [P1 \/ ( .... \/ Pn)] -*) -let rec raw_make_or_list = function +(* [raw_make_or_list [P1;...;Pn]] build the rawconstr corresponding + to [P1 \/ ( .... \/ Pn)] +*) +let rec raw_make_or_list = function | [] -> raise (Invalid_argument "mk_or") | [e] -> e | e::l -> raw_make_or e (raw_make_or_list l) - -let remove_name_from_mapping mapping na = - match na with - | Anonymous -> mapping + +let remove_name_from_mapping mapping na = + match na with + | Anonymous -> mapping | Name id -> Idmap.remove id mapping -let change_vars = - let rec change_vars mapping rt = - match rt with - | RRef _ -> rt - | RVar(loc,id) -> - let new_id = - try - Idmap.find id mapping - with Not_found -> id +let change_vars = + let rec change_vars mapping rt = + match rt with + | RRef _ -> rt + | RVar(loc,id) -> + let new_id = + try + Idmap.find id mapping + with Not_found -> id in RVar(loc,new_id) - | REvar _ -> rt - | RPatVar _ -> rt - | RApp(loc,rt',rtl) -> + | REvar _ -> rt + | RPatVar _ -> rt + | RApp(loc,rt',rtl) -> RApp(loc, change_vars mapping rt', List.map (change_vars mapping) rtl ) - | RLambda(loc,name,k,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,k,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 ) - | RLetIn(loc,name,def,b) -> + | RLetIn(loc,name,def,b) -> RLetIn(loc, name, change_vars mapping def, change_vars (remove_name_from_mapping mapping name) b ) - | RLetTuple(loc,nal,(na,rto),b,e) -> - let new_mapping = List.fold_left remove_name_from_mapping mapping nal in + | RLetTuple(loc,nal,(na,rto),b,e) -> + let new_mapping = List.fold_left remove_name_from_mapping mapping nal in RLetTuple(loc, nal, - (na, Option.map (change_vars mapping) rto), - change_vars mapping b, + (na, Option.map (change_vars mapping) rto), + change_vars mapping b, change_vars new_mapping e ) - | RCases(loc,sty,infos,el,brl) -> + | RCases(loc,sty,infos,el,brl) -> RCases(loc,sty, infos, - List.map (fun (e,x) -> (change_vars mapping e,x)) el, + List.map (fun (e,x) -> (change_vars mapping e,x)) el, List.map (change_vars_br mapping) brl ) - | RIf(loc,b,(na,e_option),lhs,rhs) -> + | RIf(loc,b,(na,e_option),lhs,rhs) -> RIf(loc, change_vars mapping b, (na,Option.map (change_vars mapping) e_option), @@ -177,211 +177,211 @@ let change_vars = change_vars mapping rhs ) | RRec _ -> error "Local (co)fixes are not supported" - | RSort _ -> rt - | RHole _ -> rt - | RCast(loc,b,CastConv (k,t)) -> + | RSort _ -> rt + | RHole _ -> rt + | RCast(loc,b,CastConv (k,t)) -> RCast(loc,change_vars mapping b, CastConv (k,change_vars mapping t)) - | RCast(loc,b,CastCoerce) -> + | RCast(loc,b,CastCoerce) -> RCast(loc,change_vars mapping b,CastCoerce) | RDynamic _ -> error "Not handled RDynamic" - and change_vars_br mapping ((loc,idl,patl,res) as br) = - let new_mapping = List.fold_right Idmap.remove idl mapping in - if idmap_is_empty new_mapping - then br + and change_vars_br mapping ((loc,idl,patl,res) as br) = + let new_mapping = List.fold_right Idmap.remove idl mapping in + if idmap_is_empty new_mapping + then br else (loc,idl,patl,change_vars new_mapping res) in - change_vars + change_vars -let rec alpha_pat excluded pat = - match pat with - | PatVar(loc,Anonymous) -> - let new_id = Indfun_common.fresh_id excluded "_x" in +let rec alpha_pat excluded pat = + match pat with + | PatVar(loc,Anonymous) -> + let new_id = Indfun_common.fresh_id excluded "_x" in PatVar(loc,Name new_id),(new_id::excluded),Idmap.empty - | PatVar(loc,Name id) -> - if List.mem id excluded - then - let new_id = Nameops.next_ident_away id excluded in + | PatVar(loc,Name id) -> + if List.mem id excluded + then + let new_id = Nameops.next_ident_away id excluded in PatVar(loc,Name new_id),(new_id::excluded), (Idmap.add id new_id Idmap.empty) else pat,excluded,Idmap.empty - | PatCstr(loc,constr,patl,na) -> - let new_na,new_excluded,map = - match na with - | Name id when List.mem id excluded -> - let new_id = Nameops.next_ident_away id excluded in + | PatCstr(loc,constr,patl,na) -> + let new_na,new_excluded,map = + match na with + | Name id when List.mem id excluded -> + let new_id = Nameops.next_ident_away id excluded in Name new_id,new_id::excluded, Idmap.add id new_id Idmap.empty | _ -> na,excluded,Idmap.empty - in - let new_patl,new_excluded,new_map = - List.fold_left - (fun (patl,excluded,map) pat -> - let new_pat,new_excluded,new_map = alpha_pat excluded pat in + in + let new_patl,new_excluded,new_map = + List.fold_left + (fun (patl,excluded,map) pat -> + let new_pat,new_excluded,new_map = alpha_pat excluded pat in (new_pat::patl,new_excluded,Idmap.fold Idmap.add new_map map) ) ([],new_excluded,map) patl - in + in PatCstr(loc,constr,List.rev new_patl,new_na),new_excluded,new_map -let alpha_patl excluded patl = - let patl,new_excluded,map = - List.fold_left - (fun (patl,excluded,map) pat -> - let new_pat,new_excluded,new_map = alpha_pat excluded pat in +let alpha_patl excluded patl = + let patl,new_excluded,map = + List.fold_left + (fun (patl,excluded,map) pat -> + let new_pat,new_excluded,new_map = alpha_pat excluded pat in new_pat::patl,new_excluded,(Idmap.fold Idmap.add new_map map) ) ([],excluded,Idmap.empty) patl - in + in (List.rev patl,new_excluded,map) - -let raw_get_pattern_id pat acc = - let rec get_pattern_id pat = - match pat with + +let raw_get_pattern_id pat acc = + let rec get_pattern_id pat = + match pat with | PatVar(loc,Anonymous) -> assert false - | PatVar(loc,Name id) -> + | PatVar(loc,Name id) -> [id] - | PatCstr(loc,constr,patternl,_) -> - List.fold_right - (fun pat idl -> - let idl' = get_pattern_id pat in + | PatCstr(loc,constr,patternl,_) -> + List.fold_right + (fun pat idl -> + let idl' = get_pattern_id pat in idl'@idl ) - patternl + patternl [] in (get_pattern_id pat)@acc let get_pattern_id pat = raw_get_pattern_id pat [] - -let rec alpha_rt excluded rt = - let new_rt = - match rt with + +let rec alpha_rt excluded rt = + let new_rt = + match rt with | RRef _ | RVar _ | REvar _ | RPatVar _ -> rt - | 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,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,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,k,t,b) -> + let new_t = alpha_rt excluded t in + let new_b = alpha_rt excluded b in 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,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,k,t,b) -> - let new_id = Nameops.next_ident_away id excluded in - let t,b = - if new_id = id + | RLambda(loc,Name id,k,t,b) -> + let new_id = Nameops.next_ident_away id excluded in + let t,b = + if new_id = id then t,b - else - let replace = change_vars (Idmap.add id new_id Idmap.empty) in + else + let replace = change_vars (Idmap.add id new_id Idmap.empty) in (t,replace b) 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 + 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,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 = - if new_id = id + | 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 = + if new_id = id then t,b - else - let replace = change_vars (Idmap.add id new_id Idmap.empty) in + else + let replace = change_vars (Idmap.add id new_id Idmap.empty) in (t,replace b) in - let new_t = alpha_rt new_excluded t in - let new_b = alpha_rt new_excluded b in + let new_t = alpha_rt new_excluded t in + let new_b = alpha_rt new_excluded b in 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 = - if new_id = id + | RLetIn(loc,Name id,t,b) -> + let new_id = Nameops.next_ident_away id excluded in + let t,b = + if new_id = id then t,b - else - let replace = change_vars (Idmap.add id new_id Idmap.empty) in + else + let replace = change_vars (Idmap.add id new_id Idmap.empty) in (t,replace b) 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 + 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 RLetIn(loc,Name new_id,new_t,new_b) - | RLetTuple(loc,nal,(na,rto),t,b) -> - let rev_new_nal,new_excluded,mapping = - List.fold_left - (fun (nal,excluded,mapping) na -> - match na with + | RLetTuple(loc,nal,(na,rto),t,b) -> + let rev_new_nal,new_excluded,mapping = + List.fold_left + (fun (nal,excluded,mapping) na -> + match na with | Anonymous -> (na::nal,excluded,mapping) - | Name id -> - let new_id = Nameops.next_ident_away id excluded in - if new_id = id - then - na::nal,id::excluded,mapping - else + | Name id -> + let new_id = Nameops.next_ident_away id excluded in + if new_id = id + then + na::nal,id::excluded,mapping + else (Name new_id)::nal,id::excluded,(Idmap.add id new_id mapping) ) ([],excluded,Idmap.empty) nal in - let new_nal = List.rev rev_new_nal in - let new_rto,new_t,new_b = + let new_nal = List.rev rev_new_nal in + let new_rto,new_t,new_b = if idmap_is_empty mapping then rto,t,b - else let replace = change_vars mapping in + else let replace = change_vars mapping in (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_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 RLetTuple(loc,new_nal,(na,new_rto),new_t,new_b) - | RCases(loc,sty,infos,el,brl) -> - let new_el = - List.map (function (rt,i) -> alpha_rt excluded rt, i) el - in - RCases(loc,sty,infos,new_el,List.map (alpha_br excluded) brl) - | RIf(loc,b,(na,e_o),lhs,rhs) -> + | RCases(loc,sty,infos,el,brl) -> + let new_el = + List.map (function (rt,i) -> alpha_rt excluded rt, i) el + in + 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), alpha_rt excluded lhs, alpha_rt excluded rhs ) | RRec _ -> error "Not handled RRec" - | RSort _ -> rt - | RHole _ -> rt - | RCast (loc,b,CastConv (k,t)) -> + | RSort _ -> rt + | RHole _ -> rt + | RCast (loc,b,CastConv (k,t)) -> RCast(loc,alpha_rt excluded b,CastConv(k,alpha_rt excluded t)) - | RCast (loc,b,CastCoerce) -> + | RCast (loc,b,CastCoerce) -> RCast(loc,alpha_rt excluded b,CastCoerce) | RDynamic _ -> error "Not handled RDynamic" - | RApp(loc,f,args) -> + | RApp(loc,f,args) -> RApp(loc, alpha_rt excluded f, List.map (alpha_rt excluded) args ) - in + in new_rt -and alpha_br excluded (loc,ids,patl,res) = - let new_patl,new_excluded,mapping = alpha_patl excluded patl in - let new_ids = List.fold_right raw_get_pattern_id new_patl [] in - let new_excluded = new_ids@excluded in - let renamed_res = change_vars mapping res in - let new_res = alpha_rt new_excluded renamed_res in +and alpha_br excluded (loc,ids,patl,res) = + let new_patl,new_excluded,mapping = alpha_patl excluded patl in + let new_ids = List.fold_right raw_get_pattern_id new_patl [] in + let new_excluded = new_ids@excluded in + let renamed_res = change_vars mapping res in + let new_res = alpha_rt new_excluded renamed_res in (loc,new_ids,new_patl,new_res) - -(* + +(* [is_free_in id rt] checks if [id] is a free variable in [rt] *) let is_free_in id = @@ -401,12 +401,12 @@ let is_free_in id = | 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) - in + | RLetTuple(_,nal,_,b,t) -> + let check_in_nal = + not (List.exists (function Name id' -> id'= id | _ -> false) nal) + in is_free_in t || (check_in_nal && is_free_in b) - + | RIf(_,cond,_,br1,br2) -> is_free_in cond || is_free_in br1 || is_free_in br2 | RRec _ -> raise (UserError("",str "Not handled RRec")) @@ -419,7 +419,7 @@ let is_free_in id = (not (List.mem id ids)) && is_free_in rt in is_free_in - + let rec pattern_to_term = function @@ -446,23 +446,23 @@ let rec pattern_to_term = function implicit_args@patl_as_term ) - -let replace_var_by_term x_id term = - let rec replace_var_by_pattern rt = - match rt with - | RRef _ -> rt + +let replace_var_by_term x_id term = + let rec replace_var_by_pattern rt = + match rt with + | RRef _ -> rt | RVar(_,id) when id_ord id x_id == 0 -> term - | RVar _ -> rt - | REvar _ -> rt - | RPatVar _ -> rt - | RApp(loc,rt',rtl) -> + | RVar _ -> rt + | REvar _ -> rt + | RPatVar _ -> rt + | RApp(loc,rt',rtl) -> RApp(loc, 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,k,t,b) -> + | RLambda(loc,name,k,t,b) -> RLambda(loc, name, k, @@ -470,7 +470,7 @@ let replace_var_by_term x_id term = replace_var_by_pattern b ) | RProd(_,Name id,_,_,_) when id_ord id x_id == 0 -> rt - | RProd(loc,name,k,t,b) -> + | RProd(loc,name,k,t,b) -> RProd(loc, name, k, @@ -478,94 +478,94 @@ let replace_var_by_term x_id term = replace_var_by_pattern b ) | RLetIn(_,Name id,_,_) when id_ord id x_id == 0 -> rt - | RLetIn(loc,name,def,b) -> + | RLetIn(loc,name,def,b) -> RLetIn(loc, name, replace_var_by_pattern def, replace_var_by_pattern b ) - | RLetTuple(_,nal,_,_,_) - when List.exists (function Name id -> id = x_id | _ -> false) nal -> + | RLetTuple(_,nal,_,_,_) + when List.exists (function Name id -> id = x_id | _ -> false) nal -> rt - | RLetTuple(loc,nal,(na,rto),def,b) -> + | RLetTuple(loc,nal,(na,rto),def,b) -> RLetTuple(loc, nal, (na,Option.map replace_var_by_pattern rto), replace_var_by_pattern def, replace_var_by_pattern b ) - | RCases(loc,sty,infos,el,brl) -> + | RCases(loc,sty,infos,el,brl) -> RCases(loc,sty, infos, - List.map (fun (e,x) -> (replace_var_by_pattern e,x)) el, + 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,b,(na,e_option),lhs,rhs) -> RIf(loc, replace_var_by_pattern b, (na,Option.map replace_var_by_pattern e_option), replace_var_by_pattern lhs, replace_var_by_pattern rhs ) | RRec _ -> raise (UserError("",str "Not handled RRec")) - | RSort _ -> rt - | RHole _ -> rt - | RCast(loc,b,CastConv(k,t)) -> + | RSort _ -> rt + | RHole _ -> rt + | RCast(loc,b,CastConv(k,t)) -> RCast(loc,replace_var_by_pattern b,CastConv(k,replace_var_by_pattern t)) - | RCast(loc,b,CastCoerce) -> + | RCast(loc,b,CastCoerce) -> RCast(loc,replace_var_by_pattern b,CastCoerce) | RDynamic _ -> raise (UserError("",str "Not handled RDynamic")) - and replace_var_by_pattern_br ((loc,idl,patl,res) as br) = - if List.exists (fun id -> id_ord id x_id == 0) idl - then br + and replace_var_by_pattern_br ((loc,idl,patl,res) as br) = + if List.exists (fun id -> id_ord id x_id == 0) idl + then br else (loc,idl,patl,replace_var_by_pattern res) in - replace_var_by_pattern + replace_var_by_pattern -(* checking unifiability of patterns *) -exception NotUnifiable +(* checking unifiability of patterns *) +exception NotUnifiable -let rec are_unifiable_aux = function - | [] -> () - | eq::eqs -> - match eq with - | PatVar _,_ | _,PatVar _ -> are_unifiable_aux eqs - | PatCstr(_,constructor1,cpl1,_),PatCstr(_,constructor2,cpl2,_) -> - if constructor2 <> constructor1 +let rec are_unifiable_aux = function + | [] -> () + | eq::eqs -> + match eq with + | PatVar _,_ | _,PatVar _ -> are_unifiable_aux eqs + | PatCstr(_,constructor1,cpl1,_),PatCstr(_,constructor2,cpl2,_) -> + if constructor2 <> constructor1 then raise NotUnifiable - else - let eqs' = + else + let eqs' = try ((List.combine cpl1 cpl2)@eqs) - with _ -> anomaly "are_unifiable_aux" + with _ -> anomaly "are_unifiable_aux" in are_unifiable_aux eqs' - -let are_unifiable pat1 pat2 = - try + +let are_unifiable pat1 pat2 = + try are_unifiable_aux [pat1,pat2]; true with NotUnifiable -> false -let rec eq_cases_pattern_aux = function - | [] -> () - | eq::eqs -> - match eq with - | PatVar _,PatVar _ -> eq_cases_pattern_aux eqs - | PatCstr(_,constructor1,cpl1,_),PatCstr(_,constructor2,cpl2,_) -> - if constructor2 <> constructor1 +let rec eq_cases_pattern_aux = function + | [] -> () + | eq::eqs -> + match eq with + | PatVar _,PatVar _ -> eq_cases_pattern_aux eqs + | PatCstr(_,constructor1,cpl1,_),PatCstr(_,constructor2,cpl2,_) -> + if constructor2 <> constructor1 then raise NotUnifiable - else - let eqs' = + else + let eqs' = try ((List.combine cpl1 cpl2)@eqs) - with _ -> anomaly "eq_cases_pattern_aux" + with _ -> anomaly "eq_cases_pattern_aux" in eq_cases_pattern_aux eqs' | _ -> raise NotUnifiable -let eq_cases_pattern pat1 pat2 = +let eq_cases_pattern pat1 pat2 = try eq_cases_pattern_aux [pat1,pat2]; true @@ -573,25 +573,25 @@ let eq_cases_pattern pat1 pat2 = -let ids_of_pat = - let rec ids_of_pat ids = function - | PatVar(_,Anonymous) -> ids - | PatVar(_,Name id) -> Idset.add id ids +let ids_of_pat = + let rec ids_of_pat ids = function + | PatVar(_,Anonymous) -> ids + | PatVar(_,Name id) -> Idset.add id ids | PatCstr(_,_,patl,_) -> List.fold_left ids_of_pat ids patl in - ids_of_pat Idset.empty - -let id_of_name = function - | Names.Anonymous -> id_of_string "x" + ids_of_pat Idset.empty + +let id_of_name = function + | Names.Anonymous -> id_of_string "x" | Names.Name x -> x (* TODO: finish Rec caes *) -let ids_of_rawterm c = - let rec ids_of_rawterm acc c = +let ids_of_rawterm c = + let rec ids_of_rawterm acc c = let idof = id_of_name in match c with | RVar (_,id) -> id::acc - | RApp (loc,g,args) -> + | RApp (loc,g,args) -> ids_of_rawterm [] g @ List.flatten (List.map (ids_of_rawterm []) args) @ 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 @@ -599,101 +599,101 @@ let ids_of_rawterm c = | 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) -> + | RLetTuple (_,nal,(na,po),b,c) -> List.map idof nal @ ids_of_rawterm [] b @ ids_of_rawterm [] c @ acc - | RCases (loc,sty,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 _) -> [] in (* build the set *) List.fold_left (fun acc x -> Idset.add x acc) Idset.empty (ids_of_rawterm [] c) - -let zeta_normalize = - let rec zeta_normalize_term rt = - match rt with - | RRef _ -> rt - | RVar _ -> rt - | REvar _ -> rt - | RPatVar _ -> rt - | RApp(loc,rt',rtl) -> + +let zeta_normalize = + let rec zeta_normalize_term rt = + match rt with + | RRef _ -> rt + | RVar _ -> rt + | REvar _ -> rt + | RPatVar _ -> rt + | RApp(loc,rt',rtl) -> RApp(loc, zeta_normalize_term rt', List.map zeta_normalize_term rtl ) - | RLambda(loc,name,k,t,b) -> + | RLambda(loc,name,k,t,b) -> RLambda(loc, name, k, zeta_normalize_term t, zeta_normalize_term b ) - | RProd(loc,name,k,t,b) -> + | RProd(loc,name,k,t,b) -> RProd(loc, - name, + name, k, zeta_normalize_term t, zeta_normalize_term b ) - | RLetIn(_,Name id,def,b) -> + | RLetIn(_,Name id,def,b) -> zeta_normalize_term (replace_var_by_term id def b) | RLetIn(loc,Anonymous,def,b) -> zeta_normalize_term b - | RLetTuple(loc,nal,(na,rto),def,b) -> + | RLetTuple(loc,nal,(na,rto),def,b) -> RLetTuple(loc, nal, (na,Option.map zeta_normalize_term rto), zeta_normalize_term def, zeta_normalize_term b ) - | RCases(loc,sty,infos,el,brl) -> + | RCases(loc,sty,infos,el,brl) -> RCases(loc,sty, infos, - List.map (fun (e,x) -> (zeta_normalize_term e,x)) el, + 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,b,(na,e_option),lhs,rhs) -> RIf(loc, zeta_normalize_term b, (na,Option.map zeta_normalize_term e_option), zeta_normalize_term lhs, zeta_normalize_term rhs ) | RRec _ -> raise (UserError("",str "Not handled RRec")) - | RSort _ -> rt - | RHole _ -> rt - | RCast(loc,b,CastConv(k,t)) -> + | RSort _ -> rt + | RHole _ -> rt + | RCast(loc,b,CastConv(k,t)) -> RCast(loc,zeta_normalize_term b,CastConv(k,zeta_normalize_term t)) - | RCast(loc,b,CastCoerce) -> + | RCast(loc,b,CastCoerce) -> RCast(loc,zeta_normalize_term b,CastCoerce) | RDynamic _ -> raise (UserError("",str "Not handled RDynamic")) - and zeta_normalize_br (loc,idl,patl,res) = + and zeta_normalize_br (loc,idl,patl,res) = (loc,idl,patl,zeta_normalize_term res) in - zeta_normalize_term + zeta_normalize_term -let expand_as = - - let rec add_as map pat = - match pat with - | PatVar _ -> map - | PatCstr(_,_,patl,Name id) -> +let expand_as = + + let rec add_as map pat = + match pat with + | PatVar _ -> map + | PatCstr(_,_,patl,Name id) -> Idmap.add id (pattern_to_term pat) (List.fold_left add_as map patl) | PatCstr(_,_,patl,_) -> List.fold_left add_as map patl - in - let rec expand_as map rt = - match rt with - | RRef _ | REvar _ | RPatVar _ | RSort _ | RHole _ -> rt - | RVar(_,id) -> + in + let rec expand_as map rt = + match rt with + | RRef _ | REvar _ | RPatVar _ | RSort _ | RHole _ -> rt + | RVar(_,id) -> begin - try + try Idmap.find id map - with Not_found -> rt + with Not_found -> rt end | RApp(loc,f,args) -> RApp(loc,expand_as map f,List.map (expand_as map) args) | RLambda(loc,na,k,t,b) -> RLambda(loc,na,k,expand_as map t, expand_as map b) @@ -712,7 +712,7 @@ let expand_as = | 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) = + and expand_as_br map (loc,idl,cpl,rt) = (loc,idl,cpl, expand_as (List.fold_left add_as map cpl) rt) in - expand_as Idmap.empty + expand_as Idmap.empty diff --git a/plugins/funind/rawtermops.mli b/plugins/funind/rawtermops.mli index 358c6ba6c7..455e7c89b2 100644 --- a/plugins/funind/rawtermops.mli +++ b/plugins/funind/rawtermops.mli @@ -7,12 +7,12 @@ val idmap_is_empty : 'a Names.Idmap.t -> bool (* [get_pattern_id pat] returns a list of all the variable appearing in [pat] *) val get_pattern_id : cases_pattern -> Names.identifier list -(* [pattern_to_term pat] returns a rawconstr corresponding to [pat]. - [pat] must not contain occurences of anonymous pattern +(* [pattern_to_term pat] returns a rawconstr corresponding to [pat]. + [pat] must not contain occurences of anonymous pattern *) -val pattern_to_term : cases_pattern -> rawconstr +val pattern_to_term : cases_pattern -> rawconstr -(* +(* Some basic functions to rebuild rawconstr In each of them the location is Util.dummy_loc *) @@ -23,35 +23,35 @@ 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_tuples * cases_clauses -> rawconstr -val mkRSort : rawsort -> rawconstr +val mkRSort : rawsort -> rawconstr val mkRHole : unit -> rawconstr (* we only build Evd.BinderType Anonymous holes *) -val mkRCast : rawconstr* rawconstr -> rawconstr +val mkRCast : rawconstr* rawconstr -> rawconstr (* Some basic functions to decompose rawconstrs These are analogous to the ones constrs *) val raw_decompose_prod : rawconstr -> (Names.name*rawconstr) list * rawconstr -val raw_decompose_prod_or_letin : +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 -> +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 -> +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) -(* [raw_make_eq t1 t2] build the rawconstr corresponding to [t2 = t1] *) +(* [raw_make_eq t1 t2] build the rawconstr corresponding to [t2 = t1] *) val raw_make_eq : ?typ:rawconstr -> rawconstr -> rawconstr -> rawconstr -(* [raw_make_neq t1 t2] build the rawconstr corresponding to [t1 <> t2] *) +(* [raw_make_neq t1 t2] build the rawconstr corresponding to [t1 <> t2] *) val raw_make_neq : rawconstr -> rawconstr -> rawconstr -(* [raw_make_or P1 P2] build the rawconstr corresponding to [P1 \/ P2] *) +(* [raw_make_or P1 P2] build the rawconstr corresponding to [P1 \/ P2] *) val raw_make_or : rawconstr -> rawconstr -> rawconstr -(* [raw_make_or_list [P1;...;Pn]] build the rawconstr corresponding - to [P1 \/ ( .... \/ Pn)] -*) +(* [raw_make_or_list [P1;...;Pn]] build the rawconstr corresponding + to [P1 \/ ( .... \/ Pn)] +*) val raw_make_or_list : rawconstr list -> rawconstr @@ -64,8 +64,8 @@ val change_vars : Names.identifier Names.Idmap.t -> rawconstr -> rawconstr -(* [alpha_pat avoid pat] rename all the variables present in [pat] s.t. - the result does not share variables with [avoid]. This function create +(* [alpha_pat avoid pat] rename all the variables present in [pat] s.t. + the result does not share variables with [avoid]. This function create a fresh variable for each occurence of the anonymous pattern. Also returns a mapping from old variables to new ones and the concatenation of @@ -77,8 +77,8 @@ val change_vars : Names.identifier Names.Idmap.t -> rawconstr -> rawconstr Rawterm.cases_pattern * Names.Idmap.key list * Names.identifier Names.Idmap.t -(* [alpha_rt avoid rt] alpha convert [rt] s.t. the result repects barendregt - conventions and does not share bound variables with avoid +(* [alpha_rt avoid rt] alpha convert [rt] s.t. the result repects barendregt + conventions and does not share bound variables with avoid *) val alpha_rt : Names.identifier list -> rawconstr -> rawconstr @@ -90,35 +90,35 @@ val alpha_br : Names.identifier list -> Rawterm.rawconstr -(* Reduction function *) -val replace_var_by_term : +(* Reduction function *) +val replace_var_by_term : Names.identifier -> Rawterm.rawconstr -> Rawterm.rawconstr -> Rawterm.rawconstr -(* +(* [is_free_in id rt] checks if [id] is a free variable in [rt] *) val is_free_in : Names.identifier -> rawconstr -> bool -val are_unifiable : cases_pattern -> cases_pattern -> bool +val are_unifiable : cases_pattern -> cases_pattern -> bool val eq_cases_pattern : cases_pattern -> cases_pattern -> bool -(* - ids_of_pat : cases_pattern -> Idset.t - returns the set of variables appearing in a pattern +(* + ids_of_pat : cases_pattern -> Idset.t + returns the set of variables appearing in a pattern *) -val ids_of_pat : cases_pattern -> Names.Idset.t +val ids_of_pat : cases_pattern -> Names.Idset.t (* TODO: finish this function (Fix not treated) *) val ids_of_rawterm: rawconstr -> Names.Idset.t -(* - removing let_in construction in a rawterm +(* + removing let_in construction in a rawterm *) val zeta_normalize : Rawterm.rawconstr -> Rawterm.rawconstr diff --git a/plugins/funind/recdef.ml b/plugins/funind/recdef.ml index 876f3de4bf..92438db399 100644 --- a/plugins/funind/recdef.ml +++ b/plugins/funind/recdef.ml @@ -49,23 +49,23 @@ open Eauto open Genarg -let compute_renamed_type gls c = +let compute_renamed_type gls c = rename_bound_var (pf_env gls) [] (pf_type_of gls c) -let qed () = Command.save_named true +let qed () = Command.save_named true let defined () = Command.save_named false -let pf_get_new_ids idl g = - let ids = pf_ids_of_hyps g in +let pf_get_new_ids idl g = + let ids = pf_ids_of_hyps g in List.fold_right (fun id acc -> next_global_ident_away false id (acc@ids)::acc) - idl + idl [] -let pf_get_new_id id g = +let pf_get_new_id id g = List.hd (pf_get_new_ids [id] g) -let h_intros l = +let h_intros l = tclMAP h_intro l let do_observe_tac s tac g = @@ -73,12 +73,12 @@ let do_observe_tac s tac g = 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 ); + msgnl (str "observation "++str s++str " raised exception " ++ + Cerrors.explain_exn e ++ str " on goal " ++ goal ); raise e;; -let observe_tac s tac g = +let observe_tac s tac g = if Tacinterp.get_debug () <> Tactic_debug.DebugOff then do_observe_tac s tac g else tac g @@ -114,11 +114,11 @@ let message s = if Flags.is_verbose () then msgnl(str s);; let def_of_const t = match (kind_of_term t) with - Const sp -> + Const sp -> (try (match (Global.lookup_constant sp) with {const_body=Some c} -> Declarations.force c |_ -> assert false) - with _ -> + with _ -> anomaly ("Cannot find definition of constant "^ (string_of_id (id_of_label (con_label sp)))) ) @@ -135,14 +135,14 @@ let arg_type t = | _ -> assert false;; let evaluable_of_global_reference r = - match r with + match r with ConstRef sp -> EvalConstRef sp | VarRef id -> EvalVarRef id | _ -> assert false;; -let rank_for_arg_list h = - let predicate a b = +let rank_for_arg_list h = + let predicate a b = try List.for_all2 eq_constr a b with Invalid_argument _ -> false in let rec rank_aux i = function @@ -150,11 +150,11 @@ 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 : int -> constr -> constr -> +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 -> + App (g, args) when g = f -> (fun l -> List.hd l), [Array.to_list args] | App (g, args) -> let (largs: constr list) = Array.to_list args in @@ -162,17 +162,17 @@ let rec (find_call_occs : int -> constr -> constr -> [] -> (fun x -> []), [] | a::upper_tl -> (match find_aux upper_tl with - (cf, ((arg1::args) as args_for_upper_tl)) -> + (cf, ((arg1::args) as args_for_upper_tl)) -> (match find_call_occs nb_lam f a with cf2, (_ :: _ as other_args) -> let rec avoid_duplicates args = match args with | [] -> (fun _ -> []), [] - | h::tl -> + | h::tl -> let recomb_tl, args_for_tl = avoid_duplicates tl in match rank_for_arg_list h args_for_upper_tl with - | None -> + | None -> (fun l -> List.hd l::recomb_tl(List.tl l)), h::args_for_tl | Some i -> @@ -182,7 +182,7 @@ let rec (find_call_occs : int -> constr -> constr -> in let recombine, other_args' = avoid_duplicates other_args in - let len1 = List.length other_args' in + let len1 = List.length other_args' in (fun l -> cf2 (recombine l)::cf(nthtl(l,len1))), other_args'@args_for_upper_tl | _, [] -> (fun x -> a::cf x), args_for_upper_tl) @@ -203,22 +203,22 @@ let rec (find_call_occs : int -> constr -> constr -> | Sort(_) -> (fun l -> expr), [] | Cast(b,_,_) -> find_call_occs nb_lam f b | Prod(_,_,_) -> error "find_call_occs : Prod" - | Lambda(na,t,b) -> + | 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 + 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) -> + | LetIn(na,v,t,b) -> begin - match find_call_occs nb_lam f v, find_call_occs (succ nb_lam) f b with - | (_,[]),(_,[]) -> + match find_call_occs nb_lam f v, find_call_occs (succ nb_lam) f b with + | (_,[]),(_,[]) -> ((fun l -> expr), []) - | (_,[]),(cf,(_::_ as l)) -> + | (_,[]),(cf,(_::_ as l)) -> ((fun l -> mkLetIn(na,v,t,cf l)),l) - | (cf,(_::_ as l)),(_,[]) -> + | (cf,(_::_ as l)),(_,[]) -> ((fun l -> mkLetIn(na,cf l,t,b)), l) | _ -> error "find_call_occs : LetIn" end @@ -233,17 +233,17 @@ let rec (find_call_occs : int -> constr -> constr -> | CoFix(_) -> error "find_call_occs : CoFix";; let coq_constant s = - Coqlib.gen_constant_in_modules "RecursiveDefinition" + Coqlib.gen_constant_in_modules "RecursiveDefinition" (Coqlib.init_modules @ Coqlib.arith_modules) s;; let constant sl s = constr_of_global - (locate (make_qualid(Names.make_dirpath + (locate (make_qualid(Names.make_dirpath (List.map id_of_string (List.rev sl))) (id_of_string s)));; let find_reference sl s = - (locate (make_qualid(Names.make_dirpath + (locate (make_qualid(Names.make_dirpath (List.map id_of_string (List.rev sl))) (id_of_string s)));; @@ -295,7 +295,7 @@ let mkCaseEq a : tactic = tclTHENLIST [h_generalize [mkApp(delayed_force refl_equal, [| type_of_a; a|])]; (fun g2 -> - change_in_concl None + change_in_concl None (pattern_occs [((false,[1]), a)] (pf_env g2) Evd.empty (pf_concl g2)) g2); simplest_case a] g);; @@ -308,21 +308,21 @@ let mkCaseEq a : tactic = 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) -> + 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 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 + change_in_concl None (pattern_occs [((false,[1]), expr)] (pf_env g2) Evd.empty (pf_concl g2)) g2); simplest_case expr], to_revert @@ -334,15 +334,15 @@ let rec mk_intros_and_continue thin_intros (extra_eqn:bool) [ h_intro teq; thin thin_intros; h_intros thin_intros; - - tclMAP - (fun eq -> tclTRY (Equality.general_rewrite_in true all_occurrences teq eq false)) + + tclMAP + (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 = 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) + (fun g1 -> + let ty_teq = pf_type_of g1 (mkVar teq) in + let teq_lhs,teq_rhs = + 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 ) @@ -352,32 +352,32 @@ let rec mk_intros_and_continue thin_intros (extra_eqn:bool) tclTHENSEQ[ thin thin_intros; h_intros thin_intros; - cont_function eqs expr + cont_function eqs expr ] g in - if nb_lam = 0 - then finalize () + if nb_lam = 0 + then finalize () else match kind_of_term expr with - | Lambda (n, _, b) -> - let n1 = + | 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 + (mk_intros_and_continue thin_intros extra_eqn cont_function eqs (pred nb_lam) (subst1 (mkVar new_n) b)) g - | _ -> - assert false + | _ -> + assert false (* finalize () *) let const_of_ref = function ConstRef kn -> kn | _ -> anomaly "ConstRef expected" let simpl_iter clause = - reduce + reduce (Lazy {rBeta=true;rIota=true;rZeta= true; rDelta=false; rConst = [ EvalConstRef (const_of_ref (delayed_force iter_ref))]}) @@ -386,16 +386,16 @@ let simpl_iter clause = (* The boolean value is_mes expresses that the termination is expressed using a measure function instead of a well-founded relation. *) -let tclUSER tac is_mes l g = - let clear_tac = - match l with +let tclUSER tac is_mes l g = + let clear_tac = + match l with | None -> h_clear true [] | Some l -> tclMAP (fun id -> tclTRY (h_clear false [id])) (List.rev l) in - tclTHENSEQ + tclTHENSEQ [ clear_tac; - if is_mes + if is_mes then tclTHEN (unfold_in_concl [(all_occurrences, evaluable_of_global_reference (delayed_force ltof_ref))]) @@ -403,8 +403,8 @@ let tclUSER tac is_mes l g = else tac ] g - - + + let list_rewrite (rev:bool) (eqs: constr list) = tclREPEAT (List.fold_right @@ -414,8 +414,8 @@ let list_rewrite (rev:bool) (eqs: constr list) = let base_leaf_terminate (func:global_reference) eqs expr = (* let _ = msgnl (str "entering base_leaf") in *) (fun g -> - let k',h = - match pf_get_new_ids [k_id;h_id] g with + let k',h = + match pf_get_new_ids [k_id;h_id] g with [k';h] -> k',h | _ -> assert false in @@ -424,9 +424,9 @@ let base_leaf_terminate (func:global_reference) eqs expr = observe_tac "second split" (split (ImplicitBindings [delayed_force coq_O])); observe_tac "intro k" (h_intro k'); - observe_tac "case on k" + observe_tac "case on k" (tclTHENS (simplest_case (mkVar k')) - [(tclTHEN (h_intro h) + [(tclTHEN (h_intro h) (tclTHEN (simplest_elim (mkApp (delayed_force gt_antirefl, [| delayed_force coq_O |]))) default_auto)); tclIDTAC ]); @@ -436,63 +436,63 @@ let base_leaf_terminate (func:global_reference) eqs expr = list_rewrite true eqs; default_auto] g);; -(* La fonction est donnee en premier argument a la +(* La fonction est donnee en premier argument a la fonctionnelle suivie d'autres Lambdas et de Case ... - Pour recuperer la fonction f a partir de la + Pour recuperer la fonction f a partir de la fonctionnelle *) -let get_f foncl = +let get_f foncl = match (kind_of_term (def_of_const foncl)) with - Lambda (Name f, _, _) -> f + Lambda (Name f, _, _) -> f |_ -> error "la fonctionnelle est mal definie";; let rec compute_le_proofs = function [] -> assumption | a::tl -> - tclORELSE assumption + tclORELSE assumption (tclTHENS - (fun g -> - let le_trans = delayed_force le_trans in - let t_le_trans = compute_renamed_type g le_trans in - let m_id = - let _,_,t = destProd t_le_trans in - let na,_,_ = destProd t in + (fun g -> + let le_trans = delayed_force le_trans in + let t_le_trans = compute_renamed_type g le_trans in + let m_id = + let _,_,t = destProd t_le_trans in + let na,_,_ = destProd t in Nameops.out_name na in apply_with_bindings (le_trans, ExplicitBindings[dummy_loc,NamedHyp m_id,a]) g) - [compute_le_proofs tl; + [compute_le_proofs tl; tclORELSE (apply (delayed_force le_n)) assumption]) let make_lt_proof pmax le_proof = tclTHENS - (fun g -> - let le_lt_trans = delayed_force le_lt_trans in - let t_le_lt_trans = compute_renamed_type g le_lt_trans in - let m_id = - let _,_,t = destProd t_le_lt_trans in - let na,_,_ = destProd t in + (fun g -> + let le_lt_trans = delayed_force le_lt_trans in + let t_le_lt_trans = compute_renamed_type g le_lt_trans in + let m_id = + let _,_,t = destProd t_le_lt_trans in + let na,_,_ = destProd t in Nameops.out_name na in apply_with_bindings (le_lt_trans, ExplicitBindings[dummy_loc,NamedHyp m_id, pmax]) g) - [observe_tac "compute_le_proofs" (compute_le_proofs le_proof); + [observe_tac "compute_le_proofs" (compute_le_proofs le_proof); tclTHENLIST[observe_tac "lt_S_n" (apply (delayed_force lt_S_n)); default_full_auto]];; let rec list_cond_rewrite k def pmax cond_eqs le_proofs = match cond_eqs with [] -> tclIDTAC | eq::eqs -> - (fun g -> - let t_eq = compute_renamed_type g (mkVar eq) 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 + (fun g -> + let t_eq = compute_renamed_type g (mkVar eq) 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 in tclTHENS @@ -502,12 +502,12 @@ let rec list_cond_rewrite k def pmax cond_eqs le_proofs = 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 - ) + ) -let rec introduce_all_equalities func eqs values specs bound le_proofs +let rec introduce_all_equalities func eqs values specs bound le_proofs cond_eqs = match specs with - [] -> + [] -> fun g -> let ids = pf_ids_of_hyps g in let s_max = mkApp(delayed_force coq_S, [|bound|]) in @@ -530,9 +530,9 @@ 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 onConcl); - observe_tac "unfold functional" + observe_tac "unfold functional" (unfold_in_concl[((true,[1]),evaluable_of_global_reference func)]); - observe_tac "rewriting equations" + observe_tac "rewriting equations" (list_rewrite true eqs); 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 @@ -554,29 +554,29 @@ let rec introduce_all_equalities func eqs values specs bound le_proofs h_intros [p; heq]; simplest_elim (mkApp(delayed_force max_constr, [| bound; mkVar p|])); h_intros [pmax; hle1; hle2]; - introduce_all_equalities func eqs values specs + introduce_all_equalities func eqs values specs (mkVar pmax) ((mkVar pmax)::le_proofs) (heq::cond_eqs)] g;; - + let string_match s = if String.length s < 3 then failwith "string_match"; - try + try for i = 0 to 3 do if String.get s i <> String.get "Acc_" i then failwith "string_match" done; with Invalid_argument _ -> failwith "string_match" - -let retrieve_acc_var g = - (* Julien: I don't like this version .... *) - let hyps = pf_ids_of_hyps g in - map_succeed + +let retrieve_acc_var g = + (* Julien: I don't like this version .... *) + let hyps = pf_ids_of_hyps g in + map_succeed (fun id -> string_match (string_of_id id);id) - hyps + hyps let rec introduce_all_values concl_tac is_mes acc_inv func context_fn eqs hrec args values specs = (match args with - [] -> + [] -> tclTHENLIST [observe_tac "split" (split(ImplicitBindings [context_fn (List.map mkVar (List.rev values))])); @@ -588,17 +588,17 @@ let rec introduce_all_values concl_tac is_mes acc_inv func context_fn let rec_res = next_global_ident_away true rec_res_id ids in let ids = rec_res::ids in let hspec = next_global_ident_away true hspec_id ids in - let tac = + let tac = observe_tac "introduce_all_values" ( 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" + (observe_tac "elim h_rec" (simplest_elim (mkApp(mkVar hrec, Array.of_list arg))) ) [tclTHENLIST [h_intros [rec_res; hspec]; - tac]; + tac]; (tclTHENS (observe_tac "acc_inv" (apply (Lazy.force acc_inv))) [(* tclTHEN (tclTRY(list_rewrite true eqs)) *) @@ -607,126 +607,126 @@ let rec introduce_all_values concl_tac is_mes acc_inv func context_fn tclTHENLIST [ tclTRY(list_rewrite true eqs); - observe_tac "user proof" - (fun g -> + observe_tac "user proof" + (fun g -> tclUSER concl_tac is_mes (Some (hrec::hspec::(retrieve_acc_var g)@specs)) g - ) + ) ] ] ) ]) g) - + ) - - + + 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" + observe_tac "introduce_all_values" (introduce_all_values concl_tac is_mes acc_inv func context_fn eqs hrec args [] []) -let proveterminate rec_arg_id is_mes acc_inv (hrec:identifier) - (f_constr:constr) (func:global_reference) base_leaf rec_leaf = +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 (ci, t, a, l) -> + Case (ci, t, a, l) -> (match find_call_occs 0 f_constr a with _,[] -> - (fun g -> + (fun g -> let destruct_tac, rev_to_thin_intro = - mkDestructEq rec_arg_id a g in + 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 + (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" + | _, _:: _ -> + 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 - in - proveterminate - -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 + in + proveterminate + +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_global func::mkRel 1:: List.rev (list_map_i (fun i _ -> mkRel (6+i)) 0 rev_args) ) ) in - let right = mkRel 5 in + let right = mkRel 5 in let equality = mkApp(delayed_force eq, [|lift 5 b; left; right|]) in let result = (mkProd ((Name def_id) , lift 4 a_arrow_b, equality)) in let cond = mkApp(delayed_force lt, [|(mkRel 2); (mkRel 1)|]) in let nb_iter = mkApp(delayed_force ex, [|delayed_force nat; - (mkLambda + (mkLambda (Name p_id, - delayed_force nat, - (mkProd (Name k_id, delayed_force nat, + delayed_force nat, + (mkProd (Name k_id, delayed_force nat, mkArrow cond result))))|])in - let value = mkApp(delayed_force coq_sig, + let value = mkApp(delayed_force coq_sig, [|b; (mkLambda (Name v_id, b, nb_iter))|]) in compose_prod rev_args value - -let tclUSER_if_not_mes concl_tac is_mes names_to_suppress = - if is_mes + +let tclUSER_if_not_mes concl_tac is_mes names_to_suppress = + if is_mes 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 = - begin - fun g -> + rec_arg_num rec_arg_id tac wf_tac : tactic = + begin + fun g -> let nargs = List.length args_id in - let pre_rec_args = + let pre_rec_args = List.rev_map - mkVar (fst (list_chop (rec_arg_num - 1) args_id)) - in - let relation = substl pre_rec_args relation in - let input_type = substl pre_rec_args input_type in - let wf_thm = next_global_ident_away true (id_of_string ("wf_R")) ids in - let wf_rec_arg = - next_global_ident_away true + mkVar (fst (list_chop (rec_arg_num - 1) args_id)) + in + let relation = substl pre_rec_args relation in + let input_type = substl pre_rec_args input_type in + let wf_thm = next_global_ident_away true (id_of_string ("wf_R")) ids in + let wf_rec_arg = + next_global_ident_away true (id_of_string ("Acc_"^(string_of_id rec_arg_id))) - (wf_thm::ids) - in + (wf_thm::ids) + in let hrec = next_global_ident_away true hrec_id - (wf_rec_arg::wf_thm::ids) in - let acc_inv = + (wf_rec_arg::wf_thm::ids) in + let acc_inv = lazy ( mkApp ( delayed_force acc_inv_id, @@ -737,40 +737,40 @@ let termination_proof_header is_mes input_type ids args_id relation tclTHEN (h_intros args_id) (tclTHENS - (observe_tac - "first assert" - (assert_tac - (Name wf_rec_arg) + (observe_tac + "first assert" + (assert_tac + (Name wf_rec_arg) (mkApp (delayed_force acc_rel, [|input_type;relation;mkVar rec_arg_id|]) ) ) ) [ - (* accesibility proof *) - tclTHENS - (observe_tac - "second assert" - (assert_tac + (* accesibility proof *) + tclTHENS + (observe_tac + "second assert" + (assert_tac (Name wf_thm) (mkApp (delayed_force well_founded,[|input_type;relation|])) ) ) - [ + [ (* interactive proof that the relation is well_founded *) observe_tac "wf_tac" (wf_tac is_mes (Some args_id)); (* this gives the accessibility argument *) - observe_tac - "apply wf_thm" + observe_tac + "apply wf_thm" (h_simplest_apply (mkApp(mkVar wf_thm,[|mkVar rec_arg_id|])) ) ] ; (* rest of the proof *) - tclTHENSEQ - [observe_tac "generalize" + tclTHENSEQ + [observe_tac "generalize" (onNLastHypsId (nargs+1) - (tclMAP (fun id -> + (tclMAP (fun id -> tclTHEN (h_generalize [mkVar id]) (h_clear false [id])) )) ; @@ -780,23 +780,23 @@ let termination_proof_header is_mes input_type ids args_id relation observe_tac "tac" (tac wf_rec_arg hrec acc_inv) ] ] - ) g + ) g end -let rec instantiate_lambda t l = +let rec instantiate_lambda t l = match l with | [] -> t - | a::l -> + | a::l -> let (bound_name, _, body) = destLambda t in instantiate_lambda (subst1 a body) l ;; -let whole_start (concl_tac:tactic) nb_args is_mes func input_type relation rec_arg_num : tactic = - begin - fun g -> +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_global func)) in let (f_name, _, body1) = destLambda func_body in @@ -805,13 +805,13 @@ let whole_start (concl_tac:tactic) nb_args is_mes func input_type relation rec_a | Name f_id -> next_global_ident_away true f_id ids | Anonymous -> anomaly "Anonymous function" 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,_) -> - match n_name with - | Name id -> - let n_id = next_global_ident_away true id ids 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,_) -> + match n_name with + | Name id -> + let n_id = next_global_ident_away true id ids in n_id::n_ids,n_id::ids | _ -> anomaly "anonymous argument" ) @@ -819,151 +819,151 @@ let whole_start (concl_tac:tactic) nb_args is_mes func input_type relation rec_a n_names_types in let rec_arg_id = List.nth n_ids (rec_arg_num - 1) in - let expr = instantiate_lambda func_body (mkVar f_id::(List.map mkVar n_ids)) in - termination_proof_header + let expr = instantiate_lambda func_body (mkVar f_id::(List.map mkVar n_ids)) in + termination_proof_header is_mes input_type ids n_ids - relation + relation rec_arg_num rec_arg_id - (fun rec_arg_id hrec acc_inv g -> - (proveterminate + (fun rec_arg_id hrec acc_inv g -> + (proveterminate [rec_arg_id] is_mes - acc_inv + acc_inv hrec (mkVar f_id) func - base_leaf_terminate + base_leaf_terminate (rec_leaf_terminate (mkVar f_id) concl_tac) [] expr ) - g + g ) (tclUSER_if_not_mes concl_tac) - g + g end -let get_current_subgoals_types () = - let pts = get_pftreestate () in - let _,subs = extract_open_pftreestate pts in +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 ) -let build_and_l l = - let and_constr = Coqlib.build_coq_and () in - let conj_constr = coq_conj () in - let mk_and p1 p2 = - Term.mkApp(and_constr,[|p1;p2|]) in - let rec f = function - | [] -> failwith "empty list of subgoals!" - | [p] -> p,tclIDTAC,1 - | p1::pl -> - let c,tac,nb = f pl in - mk_and p1 c, +let build_and_l l = + let and_constr = Coqlib.build_coq_and () in + let conj_constr = coq_conj () in + let mk_and p1 p2 = + Term.mkApp(and_constr,[|p1;p2|]) in + let rec f = function + | [] -> failwith "empty list of subgoals!" + | [p] -> p,tclIDTAC,1 + | p1::pl -> + let c,tac,nb = f pl in + mk_and p1 c, tclTHENS - (apply (constr_of_global conj_constr)) + (apply (constr_of_global conj_constr)) [tclIDTAC; tac ],nb+1 in f l -let is_rec_res id = - let rec_res_name = string_of_id rec_res_id in - let id_name = string_of_id id in - try - String.sub id_name 0 (String.length rec_res_name) = rec_res_name +let is_rec_res id = + let rec_res_name = string_of_id rec_res_id in + let id_name = string_of_id id in + try + String.sub id_name 0 (String.length rec_res_name) = rec_res_name with _ -> false -let clear_goals = - let rec clear_goal t = - match kind_of_term t with - | Prod(Name id as na,t,b) -> - let b' = clear_goal b in - if noccurn 1 b' && (is_rec_res id) - then pop b' - else if b' == b then t +let clear_goals = + let rec clear_goal t = + match kind_of_term t with + | Prod(Name id as na,t,b) -> + let b' = clear_goal b in + if noccurn 1 b' && (is_rec_res id) + then pop b' + else if b' == b then t else mkProd(na,t,b') | _ -> map_constr clear_goal t - in - List.map clear_goal + in + List.map clear_goal -let build_new_goal_type () = - let sub_gls_types = get_current_subgoals_types () in - let sub_gls_types = clear_goals sub_gls_types in - let res = build_and_l sub_gls_types in +let build_new_goal_type () = + let sub_gls_types = get_current_subgoals_types () in + let sub_gls_types = clear_goals sub_gls_types in + let res = build_and_l sub_gls_types in res - + (* -let prove_with_tcc lemma _ : tactic = +let prove_with_tcc lemma _ : tactic = fun gls -> - let hid = next_global_ident_away true h_id (pf_ids_of_hyps gls) in - tclTHENSEQ + let hid = next_global_ident_away true h_id (pf_ids_of_hyps gls) in + tclTHENSEQ [ h_generalize [lemma]; h_intro hid; - Elim.h_decompose_and (mkVar hid); + Elim.h_decompose_and (mkVar hid); gen_eauto(* default_eauto *) false (false,5) [] (Some []) (* default_auto *) ] gls *) - - -let open_new_goal (build_proof:tactic -> tactic -> unit) 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 - | None -> - try (add_suffix current_proof_name "_subproof") + let name = match goal_name with + | Some s -> s + | None -> + try (add_suffix current_proof_name "_subproof") with _ -> anomaly "open_new_goal with an unamed theorem" - in + in let sign = Global.named_context () in let sign = clear_proofs sign in let na = next_global_ident_away false name [] in 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 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 + 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 + let lemma = mkConst (Lib.make_con na) in ref_ := Some lemma ; - let lid = ref [] in - let h_num = ref (-1) in + let lid = ref [] in + let h_num = ref (-1) in Flags.silently Vernacentries.interp (Vernacexpr.VernacAbort None); - build_proof + build_proof ( fun gls -> - let hid = next_global_ident_away true h_id (pf_ids_of_hyps gls) in - tclTHENSEQ + 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 + (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 + (fun g -> + let ids' = pf_ids_of_hyps g in lid := List.rev (list_subtract ids' ids); if !lid = [] then lid := [hid]; tclIDTAC g ) g - ); + ); ] gls) (fun g -> match kind_of_term (pf_concl g) with @@ -977,7 +977,7 @@ let open_new_goal (build_proof:tactic -> tactic -> unit) using_lemmas ref_ goal_ tclFIRST[ tclTHEN (eapply_with_bindings (mkVar (List.nth !lid !h_num), NoBindings)) - e_assumption; + e_assumption; Eauto.eauto_with_bases false (true,5) @@ -993,24 +993,24 @@ let open_new_goal (build_proof:tactic -> tactic -> unit) using_lemmas ref_ goal_ in start_proof na - (Decl_kinds.Global, Decl_kinds.Proof Decl_kinds.Lemma) + (Decl_kinds.Global, Decl_kinds.Proof Decl_kinds.Lemma) sign - gls_type + gls_type hook ; if Indfun_common.is_strict_tcc () then - by (tclIDTAC) + by (tclIDTAC) else by ( - fun g -> - tclTHEN + fun g -> + tclTHEN (decompose_and_tac) - (tclORELSE - (tclFIRST + (tclORELSE + (tclFIRST (List.map - (fun c -> + (fun c -> tclTHENSEQ - [intros; - h_simplest_apply (interp_constr Evd.empty (Global.env()) c); + [intros; + h_simplest_apply (interp_constr Evd.empty (Global.env()) c); tclCOMPLETE Auto.default_auto ] ) @@ -1020,24 +1020,24 @@ let open_new_goal (build_proof:tactic -> tactic -> unit) using_lemmas ref_ goal_ try by tclIDTAC; (* raises UserError _ if the proof is complete *) if Flags.is_verbose () then (pp (Printer.pr_open_subgoals())) - with UserError _ -> + with UserError _ -> defined () - -;; + +;; -let com_terminate - tcc_lemma_name - tcc_lemma_ref - is_mes +let com_terminate + tcc_lemma_name + tcc_lemma_ref + is_mes fonctional_ref input_type - relation + relation rec_arg_num - thm_name using_lemmas + thm_name using_lemmas nb_args hook = - let start_proof (tac_start:tactic) (tac_end:tactic) = + 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) @@ -1045,45 +1045,45 @@ let com_terminate 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 + try + let new_goal_type = build_new_goal_type () in open_new_goal start_proof using_lemmas tcc_lemma_ref (Some tcc_lemma_name) (new_goal_type) - with Failure "empty list of subgoals!" -> + with Failure "empty list of subgoals!" -> (* a non recursive function declared with measure ! *) defined () - - -let ind_of_ref = function + + +let ind_of_ref = function | IndRef (ind,i) -> (ind,i) | _ -> anomaly "IndRef expected" let (value_f:constr list -> global_reference -> constr) = fun al fterm -> - let d0 = dummy_loc in - let rev_x_id_l = + let d0 = dummy_loc in + let rev_x_id_l = ( - List.fold_left - (fun x_id_l _ -> - let x_id = next_global_ident_away true x_id x_id_l in + List.fold_left + (fun x_id_l _ -> + let x_id = next_global_ident_away true x_id x_id_l in x_id::x_id_l ) [] al ) in - let fun_body = + let fun_body = RCases (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 + [d0, [v_id], [PatCstr(d0,(ind_of_ref (delayed_force coq_sig_ref),1), [PatVar(d0, Name v_id); PatVar(d0, Anonymous)], @@ -1091,12 +1091,12 @@ let (value_f:constr list -> global_reference -> constr) = RVar(d0,v_id)]) in let value = - List.fold_left2 - (fun acc x_id a -> + List.fold_left2 + (fun acc x_id a -> RLambda (d0, Name x_id, Explicit, RDynamic(d0, constr_in a), acc - ) + ) ) fun_body rev_x_id_l @@ -1121,16 +1121,16 @@ let rec n_x_id ids n = 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) +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_global term_f in - let nargs = nb_prod (type_of_const terminate_constr) in + let terminate_constr = constr_of_global term_f in + let nargs = nb_prod (type_of_const terminate_constr) in let x = n_x_id ids nargs in tclTHENLIST [ h_intros x; unfold_in_concl [(all_occurrences, evaluable_of_global_reference f)]; - observe_tac "simplest_case" + observe_tac "simplest_case" (simplest_case (mkApp (terminate_constr, Array.of_list (List.map mkVar x)))); observe_tac "prove_eq" (cont_tactic x)] g;; @@ -1144,12 +1144,12 @@ let base_leaf_eq func eqs f_id g = let heq1 = next_global_ident_away true heq_id (heq::v::p::k::ids) in let hex = next_global_ident_away true hex_id (heq1::heq::v::p::k::ids) in tclTHENLIST [ - h_intros [v; hex]; + h_intros [v; hex]; simplest_elim (mkVar hex); h_intros [p;heq1]; tclTRY - (rewriteRL - (mkApp(mkVar heq1, + (rewriteRL + (mkApp(mkVar heq1, [|mkApp (delayed_force coq_S, [|mkVar p|]); mkApp(delayed_force lt_n_Sn, [|mkVar p|]); f_id|]))); simpl_iter onConcl; @@ -1160,7 +1160,7 @@ let base_leaf_eq func eqs f_id 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 [] -> @@ -1169,14 +1169,14 @@ let rec introduce_all_values_eq cont_tac functional termine [pose_proof (Name heq2) (mkApp(mkVar heq1, [|f_S(f_S(mkVar pmax))|])); simpl_iter (onHyp heq2); - unfold_in_hyp [((true,[1]), evaluable_of_global_reference + unfold_in_hyp [((true,[1]), evaluable_of_global_reference (global_of_constr functional))] (heq2, InHyp); tclTHENS - (fun gls -> - 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 + (fun gls -> + 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 observe_tac "rewrite heq" (general_rewrite_bindings false all_occurrences @@ -1213,7 +1213,7 @@ let rec introduce_all_values_eq cont_tac functional termine simplest_elim(mkApp(delayed_force max_constr, [|mkVar pmax; mkVar p'|])); h_intros [new_pmax;hle1;hle2]; - introduce_all_values_eq + introduce_all_values_eq (fun pmax' le_proofs'-> tclTHENLIST [cont_tac pmax' le_proofs'; @@ -1221,12 +1221,12 @@ let rec introduce_all_values_eq cont_tac functional termine 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 = - let k_na,_,t = destProd t_eq in - let _,_,t = destProd t in - let def_na,_,_ = destProd t in + ( fun g -> + let t_eq = compute_renamed_type g (mkVar heq) 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 in let c_b = (mkVar heq, @@ -1246,7 +1246,7 @@ let rec introduce_all_values_eq cont_tac functional termine 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] - + let rec_leaf_eq termine f ids functional eqs expr fn args = let p = next_global_ident_away true p_id ids in @@ -1276,15 +1276,15 @@ let rec prove_eq (termine:constr) (f:constr)(functional:global_reference) (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 + _,[] -> + (fun g -> + let destruct_tac,rev_to_thin_intro = mkDestructEq [] a g in tclTHENS destruct_tac - (list_map_i + (list_map_i (fun i -> mk_intros_and_continue - (List.rev rev_to_thin_intro) true - (prove_eq termine f functional) + (List.rev rev_to_thin_intro) true + (prove_eq termine f functional) eqs ci.ci_cstr_nargs.(i)) 0 (Array.to_list l)) g) | _,_::_ -> @@ -1296,13 +1296,13 @@ let rec prove_eq (termine:constr) (f:constr)(functional:global_reference) rec_leaf_eq termine f ids (constr_of_global 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 - observe_tac "rec_leaf_eq" (rec_leaf_eq + observe_tac "rec_leaf_eq" (rec_leaf_eq termine f ids (constr_of_global functional) eqs expr fn args) g));; @@ -1310,14 +1310,14 @@ 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 + 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 + in let (evmap, env) = Command.get_current_context() in let f_constr = (constr_of_global f_ref) in let equation_lemma_type = subst1 f_constr equation_lemma_type in @@ -1326,9 +1326,9 @@ let (com_eqn : identifier -> by (start_equation f_ref terminate_ref (fun x -> - prove_eq + prove_eq (constr_of_global terminate_ref) - f_constr + f_constr functional_ref [] (instantiate_lambda @@ -1339,61 +1339,61 @@ let (com_eqn : identifier -> ); (* (try Vernacentries.interp (Vernacexpr.VernacShow Vernacexpr.ShowProof) with _ -> ()); *) (* Vernacentries.interp (Vernacexpr.VernacShow Vernacexpr.ShowScript); *) - Flags.silently (fun () ->Command.save_named opacity) () ; + Flags.silently (fun () ->Command.save_named opacity) () ; (* Pp.msgnl (str "eqn finished"); *) - + );; -let nf_zeta env = +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 +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 let env = push_named (function_name,None,function_type) (Global.env()) in (* Pp.msgnl (str "function type := " ++ Printer.pr_lconstr function_type); *) - let equation_lemma_type = interp_gen (OfType None) Evd.empty env ~impls:([],rec_impls) eq in + let equation_lemma_type = interp_gen (OfType None) Evd.empty env ~impls:([],rec_impls) eq in (* Pp.msgnl (Printer.pr_lconstr equation_lemma_type); *) - let res_vars,eq' = decompose_prod equation_lemma_type in + let res_vars,eq' = decompose_prod equation_lemma_type in let env_eq' = Environ.push_rel_context (List.map (fun (x,y) -> (x,None,y)) res_vars) env in - let eq' = nf_zeta env_eq' eq' in - let res = + let eq' = nf_zeta env_eq' eq' in + 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' := " ++ str (string_of_int rec_arg_num)); *) - match kind_of_term eq' with - | App(e,[|_;_;eq_fix|]) -> + 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)) | _ -> failwith "Recursive Definition (res not eq)" in - let pre_rec_args,function_type_before_rec_arg = decompose_prod_n (rec_arg_num - 1) function_type in + let pre_rec_args,function_type_before_rec_arg = decompose_prod_n (rec_arg_num - 1) function_type in let (_, rec_arg_type, _) = destProd function_type_before_rec_arg in let arg_types = List.rev_map snd (fst (decompose_prod_n (List.length res_vars) function_type)) in let equation_id = add_suffix function_name "_equation" in let functional_id = add_suffix function_name "_F" in let term_id = add_suffix function_name "_terminate" in let functional_ref = declare_fun functional_id (IsDefinition Definition) res in - let env_with_pre_rec_args = push_rel_context(List.map (function (x,t) -> (x,None,t)) pre_rec_args) env in - let relation = + let env_with_pre_rec_args = push_rel_context(List.map (function (x,t) -> (x,None,t)) pre_rec_args) env in + let relation = interp_constr - Evd.empty + Evd.empty env_with_pre_rec_args r - in + in let tcc_lemma_name = add_suffix function_name "_tcc" in - let tcc_lemma_constr = ref None in + let tcc_lemma_constr = ref None in (* let _ = Pp.msgnl (str "relation := " ++ Printer.pr_lconstr_env env_with_pre_rec_args relation) in *) - let hook _ _ = + let hook _ _ = let term_ref = Nametab.locate (qualid_of_ident term_id) in let f_ref = declare_f function_name (IsProof Lemma) arg_types term_ref in (* message "start second proof"; *) - let stop = ref false in - begin + 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 + with e -> + begin if Tacinterp.get_debug () <> Tactic_debug.DebugOff then pperrnl (str "Cannot create equation Lemma " ++ Cerrors.explain_exn e) else anomaly "Cannot create equation Lemma" @@ -1405,20 +1405,20 @@ let recursive_definition is_mes function_name rec_impls type_of_f r rec_arg_num if not !stop then let eq_ref = Nametab.locate (qualid_of_ident equation_id ) in - let f_ref = destConst (constr_of_global f_ref) - and functional_ref = destConst (constr_of_global functional_ref) + 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 ++ + 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 + try + com_terminate tcc_lemma_name tcc_lemma_constr is_mes functional_ref @@ -1428,7 +1428,7 @@ let recursive_definition is_mes function_name rec_impls type_of_f r rec_arg_num using_lemmas (List.length res_vars) hook - with e -> + with e -> begin ignore(try Vernacentries.vernac_reset_name (Util.dummy_loc,functional_id) with _ -> ()); (* anomaly "Cannot create termination Lemma" *) diff --git a/plugins/groebner/GroebnerR.v b/plugins/groebner/GroebnerR.v index 9122540d72..fc01c58869 100644 --- a/plugins/groebner/GroebnerR.v +++ b/plugins/groebner/GroebnerR.v @@ -6,15 +6,15 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* +(* Tactic groebnerR: proofs of polynomials equalities with variables in R. Use Hilbert Nullstellensatz and Buchberger algorithm (adapted version of L.Thery Coq proven implementation). Thanks to B.Gregoire and L.Thery for help on ring tactic. Examples at the end of the file. - + 3 versions: - + - groebnerR. - groebnerRp (a::b::c::nil) : give the list of variables are considered as @@ -41,7 +41,7 @@ Declare ML Module "groebner_plugin". Local Open Scope R_scope. Lemma psos_r1b: forall x y, x - y = 0 -> x = y. -intros x y H; replace x with ((x - y) + y); +intros x y H; replace x with ((x - y) + y); [rewrite H | idtac]; ring. Qed. @@ -71,8 +71,8 @@ auto. Qed. -Ltac equalities_to_goal := - lazymatch goal with +Ltac equalities_to_goal := + lazymatch goal with | H: (@eq R ?x 0) |- _ => try revert H | H: (@eq R 0 ?x) |- _ => try generalize (sym_equal H); clear H @@ -93,17 +93,17 @@ Qed. (* Removes x<>0 from hypothesis *) Ltac groebnerR_not_hyp:= - match goal with + match goal with | H: ?x<>?y |- _ => match y with - |0 => + |0 => let H1:=fresh "Hgroebner" in let y:=fresh "x" in destruct (@groebnerR_not1_0 _ H) as (y,H1); clear H |_ => generalize (@groebnerR_diff _ _ H); clear H; intro end end. - + Ltac groebnerR_not_goal := match goal with | |- ?x<>?y :> R => red; intro; apply groebnerR_not2 @@ -124,10 +124,10 @@ Definition PEZ := PExpr Z. Definition P0Z : PolZ := @P0 Z 0%Z. -Definition PolZadd : PolZ -> PolZ -> PolZ := +Definition PolZadd : PolZ -> PolZ -> PolZ := @Padd Z 0%Z Zplus Zeq_bool. -Definition PolZmul : PolZ -> PolZ -> PolZ := +Definition PolZmul : PolZ -> PolZ -> PolZ := @Pmul Z 0%Z 1%Z Zplus Zmult Zeq_bool. Definition PolZeq := @Peq Z Zeq_bool. @@ -143,7 +143,7 @@ Fixpoint mult_l (la : list PEZ) (lp: list PolZ) : PolZ := Fixpoint compute_list (lla: list (list PEZ)) (lp:list PolZ) := match lla with - | List.nil => lp + | List.nil => lp | la::lla => compute_list lla ((mult_l la lp)::lp) end. @@ -154,10 +154,10 @@ Definition check (lpe:list PEZ) (qe:PEZ) (certif: list (list PEZ) * list PEZ) := (* Correction *) -Definition PhiR : list R -> PolZ -> R := +Definition PhiR : list R -> PolZ -> R := (Pphi 0 Rplus Rmult (gen_phiZ 0 1 Rplus Rmult Ropp)). -Definition PEevalR : list R -> PEZ -> R := +Definition PEevalR : list R -> PEZ -> R := PEeval 0 Rplus Rmult Rminus Ropp (gen_phiZ 0 1 Rplus Rmult Ropp) Nnat.nat_of_N pow. @@ -188,20 +188,20 @@ Proof. Qed. Lemma PolZeq_correct : forall P P' l, - PolZeq P P' = true -> + PolZeq P P' = true -> PhiR l P = PhiR l P'. Proof. - intros;apply + intros;apply (Peq_ok Rset Rext (gen_phiZ_morph Rset Rext (F_R Rfield)));trivial. Qed. Fixpoint Cond0 (A:Type) (Interp:A->R) (l:list A) : Prop := - match l with + match l with | List.nil => True | a::l => Interp a = 0 /\ Cond0 A Interp l end. -Lemma mult_l_correct : forall l la lp, +Lemma mult_l_correct : forall l la lp, Cond0 PolZ (PhiR l) lp -> PhiR l (mult_l la lp) = 0. Proof. @@ -220,7 +220,7 @@ Proof. apply mult_l_correct;trivial. Qed. -Lemma check_correct : +Lemma check_correct : forall l lpe qe certif, check lpe qe certif = true -> Cond0 PEZ (PEevalR l) lpe -> @@ -228,11 +228,11 @@ Lemma check_correct : Proof. unfold check;intros l lpe qe (lla, lq) H2 H1. apply PolZeq_correct with (l:=l) in H2. - rewrite norm_correct, H2. + rewrite norm_correct, H2. apply mult_l_correct. apply compute_list_correct. clear H2 lq lla qe;induction lpe;simpl;trivial. - simpl in H1;destruct H1. + simpl in H1;destruct H1. rewrite <- norm_correct;auto. Qed. @@ -244,7 +244,7 @@ elim (Rmult_integral _ _ H0);intros. absurd (c=0);auto. clear H0; induction r; simpl in *. - contradict H1; discrR. + contradict H1; discrR. elim (Rmult_integral _ _ H1); auto. Qed. @@ -255,10 +255,10 @@ Ltac generalise_eq_hyps:= (match goal with |h : (?p = ?q)|- _ => revert h end). - + Ltac lpol_goal t := match t with - | ?a = 0 -> ?b => + | ?a = 0 -> ?b => let r:= lpol_goal b in constr:(a::r) | ?a = 0 => constr:(a::nil) @@ -274,25 +274,25 @@ Fixpoint IPR p {struct p}: R := end. Definition IZR1 z := - match z with Z0 => 0 - | Zpos p => IPR p - | Zneg p => -(IPR p) + match z with Z0 => 0 + | Zpos p => IPR p + | Zneg p => -(IPR p) end. Fixpoint interpret3 t fv {struct t}: R := match t with - | (PEadd t1 t2) => + | (PEadd t1 t2) => let v1 := interpret3 t1 fv in let v2 := interpret3 t2 fv in (v1 + v2) - | (PEmul t1 t2) => + | (PEmul t1 t2) => let v1 := interpret3 t1 fv in let v2 := interpret3 t2 fv in (v1 * v2) - | (PEsub t1 t2) => + | (PEsub t1 t2) => let v1 := interpret3 t1 fv in let v2 := interpret3 t2 fv in (v1 - v2) - | (PEopp t1) => + | (PEopp t1) => let v1 := interpret3 t1 fv in (-v1) - | (PEpow t1 t2) => + | (PEpow t1 t2) => let v1 := interpret3 t1 fv in v1 ^(Nnat.nat_of_N t2) | (PEc t1) => (IZR1 t1) | (PEX n) => List.nth (pred (nat_of_P n)) fv 0 @@ -303,7 +303,7 @@ Fixpoint interpret3 t fv {struct t}: R := Ltac parametres_en_tete fv lp := match fv with | (@nil _) => lp - | (@cons _ ?x ?fv1) => + | (@cons _ ?x ?fv1) => let res := AddFvTail x lp in parametres_en_tete fv1 res end. @@ -340,7 +340,7 @@ Ltac groebner_call nparam p lp kont := groebner_call_n nparam p n lp kont || let n' := eval compute in (Nsucc n) in try_n n' end in - try_n 1%N. + try_n 1%N. Ltac groebnerR_gen lparam lvar n RNG lH _rl := @@ -351,7 +351,7 @@ Ltac groebnerR_gen lparam lvar n RNG lH _rl := let t := Get_goal in let lpol := lpol_goal t in intros; - let fv := + let fv := match lvar with | nil => let fv1 := FV_hypo_tac mkFV ltac:(get_Eq RNG) lH in @@ -381,7 +381,7 @@ Ltac groebnerR_gen lparam lvar n RNG lH _rl := set (lp21:=lp); groebner_call nparam p lp ltac:(fun c r lq lci => set (q := PEmul c (PEpow p21 r)); - let Hg := fresh "Hg" in + let Hg := fresh "Hg" in assert (Hg:check lp21 q (lci,lq) = true); [ (vm_compute;reflexivity) || idtac "invalid groebner certificate" | let Hg2 := fresh "Hg" in diff --git a/plugins/groebner/GroebnerZ.v b/plugins/groebner/GroebnerZ.v index 8fd14aee2b..7c40bbb70f 100644 --- a/plugins/groebner/GroebnerZ.v +++ b/plugins/groebner/GroebnerZ.v @@ -26,7 +26,7 @@ intros x y H. contradict H. f_equal. assumption. Qed. Ltac groebnerZversR1 := - repeat + repeat (match goal with | H:(@eq Z ?x ?y) |- _ => generalize (@groebnerZhypR _ _ H); clear H; intro H @@ -68,6 +68,6 @@ Ltac groebnerZ_begin := simpl in *. (*cbv beta iota zeta delta [nat_of_P Pmult_nat plus mult] in *.*) -Ltac groebnerZ := +Ltac groebnerZ := groebnerZ_begin; (*idtac "groebnerZ_begin;";*) groebnerR. diff --git a/plugins/groebner/groebner.ml4 b/plugins/groebner/groebner.ml4 index da41a89b66..cc1b08a638 100644 --- a/plugins/groebner/groebner.ml4 +++ b/plugins/groebner/groebner.ml4 @@ -75,17 +75,17 @@ module BigInt = struct let hash x = try (int_of_big_int x) with _-> 1 - let puis = power_big_int_positive_int + let puis = power_big_int_positive_int (* a et b positifs, résultat positif *) - let rec pgcd a b = - if equal b coef0 + let rec pgcd a b = + if equal b coef0 then a else if lt a b then pgcd b a else pgcd b (modulo a b) (* signe du pgcd = signe(a)*signe(b) si non nuls. *) - let pgcd2 a b = + let pgcd2 a b = if equal a coef0 then b else if equal b coef0 then a else let c = pgcd (abs a) (abs b) in @@ -113,7 +113,7 @@ module Ent = struct let coef0 = Entiers.ent0 let coef1 = Entiers.ent1 let to_string = Entiers.string_of_ent - let to_int x = Entiers.int_of_ent x + let to_int x = Entiers.int_of_ent x let hash x =Entiers.hash_ent x let signe = Entiers.signe_ent @@ -122,14 +122,14 @@ module Ent = struct |_ -> (mult p (puis p (n-1))) (* a et b positifs, résultat positif *) - let rec pgcd a b = - if equal b coef0 + let rec pgcd a b = + if equal b coef0 then a else if lt a b then pgcd b a else pgcd b (modulo a b) (* signe du pgcd = signe(a)*signe(b) si non nuls. *) - let pgcd2 a b = + let pgcd2 a b = if equal a coef0 then b else if equal b coef0 then a else let c = pgcd (abs a) (abs b) in @@ -175,7 +175,7 @@ let tpexpr = lazy (gen_constant "CC" ["setoid_ring";"Ring_polynom"] "PExpr") let ttconst = lazy (gen_constant "CC" ["setoid_ring";"Ring_polynom"] "PEc") let ttvar = lazy (gen_constant "CC" ["setoid_ring";"Ring_polynom"] "PEX") -let ttadd = lazy (gen_constant "CC" ["setoid_ring";"Ring_polynom"] "PEadd") +let ttadd = lazy (gen_constant "CC" ["setoid_ring";"Ring_polynom"] "PEadd") let ttsub = lazy (gen_constant "CC" ["setoid_ring";"Ring_polynom"] "PEsub") let ttmul = lazy (gen_constant "CC" ["setoid_ring";"Ring_polynom"] "PEmul") let ttopp = lazy (gen_constant "CC" ["setoid_ring";"Ring_polynom"] "PEopp") @@ -202,7 +202,7 @@ let mkt_app name l = mkApp (Lazy.force name, Array.of_list l) let tlp () = mkt_app tlist [mkt_app tpexpr [Lazy.force tz]] let tllp () = mkt_app tlist [tlp()] -let rec mkt_pos n = +let rec mkt_pos n = if n =/ num_1 then Lazy.force pxH else if mod_num n num_2 =/ num_0 then mkt_app pxO [mkt_pos (quo_num n num_2)] @@ -214,7 +214,7 @@ let mkt_n n = then Lazy.force nN0 else mkt_app nNpos [mkt_pos n] -let mkt_z z = +let mkt_z z = if z =/ num_0 then Lazy.force z0 else if z >/ num_0 then mkt_app zpos [mkt_pos z] @@ -224,14 +224,14 @@ let mkt_z z = let rec mkt_term t = match t with | Zero -> mkt_term (Const num_0) | Const r -> let (n,d) = numdom r in - mkt_app ttconst [Lazy.force tz; mkt_z n] -| Var v -> mkt_app ttvar [Lazy.force tz; mkt_pos (num_of_string v)] + mkt_app ttconst [Lazy.force tz; mkt_z n] +| Var v -> mkt_app ttvar [Lazy.force tz; mkt_pos (num_of_string v)] | Opp t1 -> mkt_app ttopp [Lazy.force tz; mkt_term t1] | Add (t1,t2) -> mkt_app ttadd [Lazy.force tz; mkt_term t1; mkt_term t2] | Sub (t1,t2) -> mkt_app ttsub [Lazy.force tz; mkt_term t1; mkt_term t2] | Mul (t1,t2) -> mkt_app ttmul [Lazy.force tz; mkt_term t1; mkt_term t2] -| Pow (t1,n) -> if (n = 0) then - mkt_app ttconst [Lazy.force tz; mkt_z num_1] +| Pow (t1,n) -> if (n = 0) then + mkt_app ttconst [Lazy.force tz; mkt_z num_1] else mkt_app ttpow [Lazy.force tz; mkt_term t1; mkt_n (num_of_int n)] @@ -270,10 +270,10 @@ let rec parse_term p = else Zero | _ -> Zero -let rec parse_request lp = +let rec parse_request lp = match kind_of_term lp with | App (_,[|_|]) -> [] - | App (_,[|_;p;lp1|]) -> + | App (_,[|_;p;lp1|]) -> (parse_term p)::(parse_request lp1) |_-> assert false @@ -433,7 +433,7 @@ let rec remove_list_tail l i = ... [cn+m n+m-1,...,cn+m 1]] - enleve les polynomes intermediaires inutiles pour calculer le dernier + enleve les polynomes intermediaires inutiles pour calculer le dernier *) let remove_zeros zero lci = @@ -491,7 +491,7 @@ let theoremedeszeros_termes lp = for i=m downto 1 do lvar:=["x"^string_of_int i^""]@(!lvar); done; name_var:=!lvar; - let lp = List.map (term_pol_sparse nparam) lp in + let lp = List.map (term_pol_sparse nparam) lp in match lp with | [] -> assert false | p::lp1 -> @@ -499,7 +499,7 @@ let theoremedeszeros_termes lp = let (cert,lp0,p,_lct) = theoremedeszeros lpol p in let lc = cert.last_comb::List.rev cert.gb_comb in match remove_zeros (fun x -> x=zeroP) lc with - | [] -> assert false + | [] -> assert false | (lq::lci) -> (* lci commence par les nouveaux polynomes *) let m= !nvars in @@ -524,7 +524,7 @@ let groebner lpol = init_constants (); let lp= parse_request lpol in let (_lp0,_p,c,r,_lci,_lq as rthz) = theoremedeszeros_termes lp in - let certif = certificat_vers_polynome_creux rthz in + let certif = certificat_vers_polynome_creux rthz in let certif = hash_certif certif in let certif = certif_term certif in let c = mkt_term c in diff --git a/plugins/groebner/ideal.ml4 b/plugins/groebner/ideal.ml4 index 73db36d467..eae8499219 100644 --- a/plugins/groebner/ideal.ml4 +++ b/plugins/groebner/ideal.ml4 @@ -9,15 +9,15 @@ (*i camlp4deps: "lib/refutpat.cmo" i*) (* NB: The above camlp4 extension adds a let* syntax for refutable patterns *) -(* +(* Nullstellensatz par calcul de base de Grobner On utilise une representation creuse des polynomes: - un monome est un tableau d'exposants (un par variable), + un monome est un tableau d'exposants (un par variable), avec son degre en tete. un polynome est une liste de (coefficient,monome). - L'algorithme de Buchberger a proprement parler est tire du code caml + L'algorithme de Buchberger a proprement parler est tire du code caml extrait du code Coq ecrit par L.Thery. *) @@ -250,10 +250,10 @@ let string_of_pol zeroP hdP tlP coefterm monterm string_of_coef | e -> s:= (!s) @ [((getvar !lvar (i-1)) ^ "^" ^ e)]); done; (match !s with - [] -> if coefone + [] -> if coefone then "1" else "" - | l -> if coefone + | l -> if coefone then (String.concat "*" l) else ( "*" ^ (String.concat "*" l))) @@ -267,22 +267,22 @@ let string_of_pol zeroP hdP tlP coefterm monterm string_of_coef | "-1" ->( "-" ^" "^(string_of_mon m true)) | c -> if (String.get c 0)='-' then ( "- "^ - (String.sub c 1 + (String.sub c 1 ((String.length c)-1))^ (string_of_mon m false)) else (match start with true -> ( c^(string_of_mon m false)) |false -> ( "+ "^ c^(string_of_mon m false))) - and stringP p start = + and stringP p start = if (zeroP p) - then (if start + then (if start then ("0") else "") else ((string_of_term (hdP p) start)^ " "^ (stringP (tlP p) false)) - in + in (stringP p true) @@ -299,12 +299,12 @@ let print_pol zeroP hdP tlP coefterm monterm string_of_coef | e -> s:= (!s) @ [((getvar !lvar (i-1)) ^ "^" ^ e)]); done; (match !s with - [] -> if coefone + [] -> if coefone then print_string "1" else () - | l -> if coefone + | l -> if coefone then print_string (String.concat "*" l) - else (print_string "*"; + else (print_string "*"; print_string (String.concat "*" l))) and print_term t start = let a = coefterm t and m = monterm t in match (string_of_coef a) with @@ -316,16 +316,16 @@ let print_pol zeroP hdP tlP coefterm monterm string_of_coef | "-1" ->(print_string "-";print_space();print_mon m true) | c -> if (String.get c 0)='-' then (print_string "- "; - print_string (String.sub c 1 + print_string (String.sub c 1 ((String.length c)-1)); print_mon m false) else (match start with true -> (print_string c;print_mon m false) |false -> (print_string "+ "; print_string c;print_mon m false)) - and printP p start = + and printP p start = if (zeroP p) - then (if start + then (if start then print_string("0") else ()) else (print_term (hdP p) start; @@ -340,7 +340,7 @@ let print_pol zeroP hdP tlP coefterm monterm string_of_coef let name_var= ref [] -let stringP = string_of_pol +let stringP = string_of_pol (fun p -> match p with [] -> true | _ -> false) (fun p -> match p with (t::p) -> t |_ -> failwith "print_pol dans dansideal") (fun p -> match p with (t::p) -> p |_ -> failwith "print_pol dans dansideal") @@ -362,7 +362,7 @@ let rec lstringP l = [] -> "" |p::l -> (stringP p)^("\n")^(lstringP l) -let printP = print_pol +let printP = print_pol (fun p -> match p with [] -> true | _ -> false) (fun p -> match p with (t::p) -> t |_ -> failwith "print_pol dans dansideal") (fun p -> match p with (t::p) -> p |_ -> failwith "print_pol dans dansideal") @@ -388,17 +388,17 @@ let zeroP = [] (* Retourne un polynome constant à d variables *) let polconst d c = let m = Array.create (d+1) 0 in - let m = set_deg d m in + let m = set_deg d m in [(c,m)] - + (* somme de polynomes= liste de couples (int,monomes) *) let plusP d p q = let rec plusP p q = match p with [] -> q - |t::p' -> + |t::p' -> match q with [] -> p |t'::q' -> @@ -434,7 +434,7 @@ let rec selectdiv d m l = let gen d i = let m = Array.create (d+1) 0 in m.(i) <- 1; - let m = set_deg d m in + let m = set_deg d m in [(coef1,m)] @@ -503,13 +503,13 @@ let add_hmon m q = if !use_hmon then Hashtbl.add hmon m q let selectdiv_cache d m l = - try find_hmon m - with Not_found -> + try find_hmon m + with Not_found -> match selectdiv d m l with [] -> [] | q -> add_hmon m q; q -let div_pol d p q a b m = +let div_pol d p q a b m = (* info ".";*) plusP d (emultP a p) (mult_t_pol d b m q) @@ -532,7 +532,7 @@ let reduce2 d p l = let (c,r)=(reduce p') in (c,((P.multP a c,m)::r)) else (coef1,p) - |(b,m')::q' -> + |(b,m')::q' -> let c=(pgcdpos a b) in let a'= (P.divP b c) in let b'=(P.oppP (P.divP a c)) in @@ -544,7 +544,7 @@ let reduce2 d p l = (* trace des divisions *) (* liste des polynomes de depart *) -let poldep = ref [] +let poldep = ref [] let poldepcontent = ref [] @@ -552,7 +552,7 @@ module HashPolPair = Hashtbl.Make (struct type t = poly * poly let equal (p,q) (p',q') = equal p p' && equal q q' - let hash (p,q) = + let hash (p,q) = let c = List.map fst p @ List.map fst q in let m = List.map snd p @ List.map snd q in List.fold_left (fun h p -> h * 17 + P.hash p) (Hashtbl.hash m) c @@ -576,7 +576,7 @@ let initcoefpoldep d lp = (fun p -> coefpoldep_set p p (polconst d coef1)) lp -(* garde la trace dans coefpoldep +(* garde la trace dans coefpoldep divise sans pseudodivisions *) let reduce2_trace d p l lcp = @@ -586,10 +586,10 @@ let reduce2_trace d p l lcp = [] -> ([],[]) |t::p' -> let (a,m)=t in let q = - (try Hashtbl.find hmon m - with Not_found -> + (try Hashtbl.find hmon m + with Not_found -> let q = selectdiv d m l in - match q with + match q with t'::q' -> (Hashtbl.add hmon m q;q) |[] -> q) in match q with @@ -599,7 +599,7 @@ let reduce2_trace d p l lcp = let (lq,r)=(reduce p') in (lq,((a,m)::r)) else ([],p) - |(b,m')::q' -> + |(b,m')::q' -> let b' = P.oppP (P.divP a b) in let m''= div_mon d m m' in let p1=plusP d p' (mult_t_pol d b' m'' q') in @@ -627,7 +627,7 @@ let reduce2_trace d p l lcp = c) lcp !poldep, - r) + r) (*********************************************************************** Algorithme de Janet (V.P.Gerdt Involutive algorithms...) @@ -640,7 +640,7 @@ let homogeneous = ref false let pol_courant = ref [] -type pol3 = +type pol3 = {pol : poly; anc : poly; nmp : mon} @@ -697,7 +697,7 @@ let monom_multiplicative d u s = then m.(i)<- 1; done; m - + (* mu monome des variables multiplicative de u *) let janet_div_mon d u mu v = let res = ref true in @@ -709,7 +709,7 @@ let janet_div_mon d u mu v = i:= !i + 1; done; !res - + let find_multiplicative p mg = try Hashpol.find mg p.pol with Not_found -> (info "\nPROBLEME DANS LA TABLE DES VAR MULT"; @@ -727,7 +727,7 @@ let find_reductor d v lt mt = let r = List.find (fun q -> - let u = fst_mon q in + let u = fst_mon q in let mu = find_multiplicative q mt in janet_div_mon d u mu v ) @@ -793,11 +793,11 @@ let criteria d p g lt = let head_normal_form d p lt mt = let h = ref (p.pol) in - let res = + let res = try ( let v = snd(List.hd !h) in let g = ref (find_reductor d v lt mt) in - if snd(List.hd !h) <> lm_anc p && criteria d p !g lt + if snd(List.hd !h) <> lm_anc p && criteria d p !g lt then ((* info "=";*) []) else ( while !h <> [] && (!g).pol <> [] do @@ -848,14 +848,14 @@ let head_reduce d lq lt mt = (*info ("temps de head_reduce: " ^(Format.sprintf "@[%10.3f@]s\n" ((Unix.gettimeofday ())-.t1)));*) !lq - + let choose_irreductible d lf = List.hd lf (* bien plus lent (List.sort (fun p q -> compare_mon d (fst_mon p.pol) (fst_mon q.pol)) lf) *) - - + + let hashtbl_multiplicative d lf = let mg = Hashpol.create 51 in hashtbl_reductor := Hashtbl.create 51; @@ -867,10 +867,10 @@ let hashtbl_multiplicative d lf = (*info ("temps de hashtbl_multiplicative: " ^(Format.sprintf "@[%10.3f@]s\n" ((Unix.gettimeofday ())-.t1)));*) mg - + let list_diff l x = List.filter (fun y -> y <> x) l - + let janet2 d lf p0 = hashtbl_reductor := Hashtbl.create 51; let t1 = Unix.gettimeofday() in @@ -889,14 +889,14 @@ let janet2 d lf p0 = while !lq <> [] && !r <> [] do let p = choose_irreductible d !lq in lq := list_diff !lq p; - if p.pol = p.anc + if p.pol = p.anc then ( (* on enleve de lt les pol divisibles par p et on les met dans lq *) let m = fst_mon p in let lt1 = !lt in List.iter - (fun q -> + (fun q -> let m'= fst_mon q in - if div_strict d m m' + if div_strict d m m' then ( lq := (!lq) @ [q]; lt := list_diff !lt q)) @@ -916,13 +916,13 @@ let janet2 d lf p0 = if !r <> [] then ( List.iter - (fun q -> + (fun q -> let mq = find_multiplicative q !mt in for i=1 to d do if mq.(i) = 1 then q.nmp.(i)<- 0 else - if q.nmp.(i) = 0 + if q.nmp.(i) = 0 then ( (* info "+";*) lq := (!lq) @ @@ -945,17 +945,17 @@ let janet2 d lf p0 = info ("--- fin Janet2\n"); info ("temps: "^(Format.sprintf "@[%10.3f@]s\n" ((Unix.gettimeofday ())-.t1))); List. map (fun q -> q.pol) !lt - + (********************************************************************** version 3 *) let head_normal_form3 d p lt mt = let h = ref (p.pol) in - let res = + let res = try ( let v = snd(List.hd !h) in let g = ref (find_reductor d v lt mt) in - if snd(List.hd !h) <> lm_anc p && criteria d p !g lt + if snd(List.hd !h) <> lm_anc p && criteria d p !g lt then ((* info "=";*) []) else ( while !h <> [] && (!g).pol <> [] do @@ -979,7 +979,7 @@ let head_normal_form3 d p lt mt = ^(Format.sprintf "@[%10.3f@]s\n" ((Unix.gettimeofday ())-.t1)));*) res - + let janet3 d lf p0 = hashtbl_reductor := Hashtbl.create 51; let t1 = Unix.gettimeofday() in @@ -997,14 +997,14 @@ let janet3 d lf p0 = let* p::lq1 = !lq in lq := lq1; (* - if p.pol = p.anc + if p.pol = p.anc then ( (* on enleve de lt les pol divisibles par p et on les met dans lq *) let m = fst_mon (p.pol) in let lt1 = !lt in List.iter - (fun q -> + (fun q -> let m'= fst_mon (q.pol) in - if div_strict d m m' + if div_strict d m m' then ( lq := (!lq) @ [q]; lt := list_diff !lt q)) @@ -1040,7 +1040,7 @@ let janet3 d lf p0 = if mq.(i) = 1 then q.nmp.(i)<- 0 else - if q.nmp.(i) = 0 + if q.nmp.(i) = 0 then ( (* info "+";*) lq := (!lq) @ @@ -1116,7 +1116,7 @@ let etrangers d p p'= !res -(* teste si le monome dominant de p'' +(* teste si le monome dominant de p'' divise le ppcm des monomes dominants de p et p' *) let div_ppcm d p p' p'' = @@ -1150,10 +1150,10 @@ let rec slice d i a = function else addRes b (slice d i a q1) let rec addS x l = l @[x] - + let addSugar x l = if !sugar_flag - then + then let sx = sugar x in let rec insere l = match l with @@ -1165,13 +1165,13 @@ let addSugar x l = in insere l else addS x l -(* ajoute les spolynomes de i avec la liste de polynomes aP, +(* ajoute les spolynomes de i avec la liste de polynomes aP, a la liste q *) let rec genPcPf d i aP q = match aP with [] -> q - | a::l1 -> + | a::l1 -> (match slice d i a l1 with Keep l2 -> addSugar (spol d i a) (genPcPf d i l2 q) | DontKeep l2 -> genPcPf d i l2 q) @@ -1183,7 +1183,7 @@ let rec genOCPf d = function let step = ref 0 let infobuch p q = - if !step = 0 + if !step = 0 then (info ("[" ^ (string_of_int (List.length p)) ^ "," ^ (string_of_int (List.length q)) ^ "]")) @@ -1266,8 +1266,8 @@ let pbuchf d pq p lp0= info "calcul de la base de Groebner\n"; step:=0; Hashtbl.clear hmon; - let rec pbuchf lp lpc = - infobuch lp lpc; + let rec pbuchf lp lpc = + infobuch lp lpc; (* step:=(!step+1)mod 10;*) match lpc with [] -> test_dans_ideal d p lp lp0 @@ -1297,7 +1297,7 @@ let pbuchf d pq p lp0= poldepcontent:=addS ct (!poldepcontent); try test_dans_ideal d p (addS a0 lp) lp0 with NotInIdeal -> pbuchf (addS a0 lp) (genPcPf d a0 lp lpc2) - in pbuchf (fst pq) (snd pq) + in pbuchf (fst pq) (snd pq) let is_homogeneous p = match p with @@ -1315,8 +1315,8 @@ let is_homogeneous p = [a(n+m,n+m-1);...;a(n+m,1)]] lc = [qn+m; ... q1] - tels que - c*p = sum qi*pi + tels que + c*p = sum qi*pi ou pn+k = a(n+k,n+k-1)*pn+k-1 + ... + a(n+k,1)* p1 *) diff --git a/plugins/groebner/polynom.ml b/plugins/groebner/polynom.ml index 6d2ed26e8d..0a9c3e270e 100644 --- a/plugins/groebner/polynom.ml +++ b/plugins/groebner/polynom.ml @@ -127,17 +127,17 @@ end module Make (C:Coef) = struct type coef = C.t -let coef_of_int i = C.of_num (Num.Int i) +let coef_of_int i = C.of_num (Num.Int i) let coef0 = coef_of_int 0 let coef1 = coef_of_int 1 type variable = int -type t = +type t = Pint of coef (* polynome constant *) | Prec of variable * (t array) (* coefficients par degre croissant *) -(* sauf mention du contraire, les opérations ne concernent que des +(* sauf mention du contraire, les opérations ne concernent que des polynomes normalisés: - les variables sont des entiers strictement positifs. - les coefficients d'un polynome en x ne font intervenir que des variables < x. @@ -149,12 +149,12 @@ type t = let of_num x = Pint (C.of_num x) let cf0 = of_num (Num.Int 0) let cf1 = of_num (Num.Int 1) - + (* la n-ième variable *) let x n = Prec (n,[|cf0;cf1|]) (* crée rapidement v^n *) -let monome v n = +let monome v n = match n with 0->Pint coef1; |_->let tmp = Array.create (n+1) (Pint coef0) in @@ -169,7 +169,7 @@ let is_constantP = function (* conversion d'un poly cst en entier*) -let int_of_Pint = function +let int_of_Pint = function Pint x -> x | _ -> failwith "non" @@ -179,15 +179,15 @@ let is_zero p = match p with Pint n -> if C.equal n coef0 then true else false |_-> false (* variable max *) -let max_var_pol p = - match p with +let max_var_pol p = + match p with Pint _ -> 0 |Prec(x,_) -> x (* p n'est pas forcément normalisé *) let rec max_var_pol2 p = - match p with + match p with Pint _ -> 0 |Prec(v,c)-> Array.fold_right (fun q m -> max (max_var_pol2 q) m) c v @@ -196,11 +196,11 @@ let rec max_var_pol2 p = let rec max_var l = Array.fold_right (fun p m -> max (max_var_pol2 p) m) l 0 -(* Egalité de deux polynômes +(* Egalité de deux polynômes On ne peut pas utiliser = car elle ne marche pas sur les Big_int. *) let rec equal p q = - match (p,q) with + match (p,q) with (Pint a,Pint b) -> C.equal a b |(Prec(x,p1),Prec(y,q1)) -> if x<>y then false @@ -216,17 +216,17 @@ let rec equal p q = sont supposés normalisés. si constant, rend le coef constant. *) - + let rec norm p = match p with Pint _ -> p |Prec (x,a)-> let d = (Array.length a -1) in - let n = ref d in + let n = ref d in while !n>0 && (equal a.(!n) (Pint coef0)) do n:=!n-1; done; if !n<0 then Pint coef0 - else if !n=0 then a.(0) + else if !n=0 then a.(0) else if !n=d then p else (let b=Array.create (!n+1) (Pint coef0) in for i=0 to !n do b.(i)<-a.(i);done; @@ -235,14 +235,14 @@ let rec norm p = match p with (* degré en la variable v du polynome p, v >= max var de p *) let rec deg v p = - match p with + match p with Prec(x,p1) when x=v -> Array.length p1 -1 |_ -> 0 (* degré total *) let rec deg_total p = - match p with + match p with Prec (x,p1) -> let d = ref 0 in Array.iteri (fun i q -> d:= (max !d (i+(deg_total q)))) p1; !d @@ -258,7 +258,7 @@ let rec copyP p = (* coefficient de degre i en v, v >= max var de p *) let coef v i p = - match p with + match p with Prec (x,p1) when x=v -> if i<(Array.length p1) then p1.(i) else Pint coef0 |_ -> if i=0 then p else Pint coef0 @@ -273,20 +273,20 @@ let rec plusP p q = |(Prec (x,p1),Pint b) -> let p2=Array.map copyP p1 in p2.(0)<- plusP p1.(0) q; Prec (x,p2) - |(Prec (x,p1),Prec (y,q1)) -> + |(Prec (x,p1),Prec (y,q1)) -> if x<y then (let q2=Array.map copyP q1 in q2.(0)<- plusP p q1.(0); Prec (y,q2)) else if x>y then (let p2=Array.map copyP p1 in p2.(0)<- plusP p1.(0) q; Prec (x,p2)) - else - (let n=max (deg x p) (deg x q) in + else + (let n=max (deg x p) (deg x q) in let r=Array.create (n+1) (Pint coef0) in for i=0 to n do r.(i)<- plusP (coef x i p) (coef x i q); done; - Prec(x,r))) + Prec(x,r))) in norm res @@ -324,8 +324,8 @@ let rec multx n v p = p2.(i+n)<-p1.(i); done; Prec (x,p2) - |_ -> if p = (Pint coef0) then (Pint coef0) - else (let p2=Array.create (n+1) (Pint coef0) in + |_ -> if p = (Pint coef0) then (Pint coef0) + else (let p2=Array.create (n+1) (Pint coef0) in p2.(n)<-p; Prec (v,p2)) @@ -338,13 +338,13 @@ let rec multP p q = if C.equal a coef0 then Pint coef0 else let q2 = Array.map (fun z-> multP p z) q1 in Prec (y,q2) - + |(Prec (x,p1), Pint b) -> if C.equal b coef0 then Pint coef0 else let p2 = Array.map (fun z-> multP z q) p1 in Prec (x,p2) |(Prec (x,p1), Prec(y,q1)) -> - if x<y + if x<y then (let q2 = Array.map (fun z-> multP p z) q1 in Prec (y,q2)) else if x>y @@ -357,7 +357,7 @@ let rec multP p q = (* derive p par rapport a la variable v, v >= max_var p *) let rec deriv v p = - match p with + match p with Pint a -> Pint coef0 | Prec(x,p1) when x=v -> let d = Array.length p1 -1 in @@ -373,7 +373,7 @@ let rec deriv v p = (* opposé de p *) let rec oppP p = - match p with + match p with Pint a -> Pint (C.opp a) |Prec(x,p1) -> Prec(x,Array.map oppP p1) @@ -428,7 +428,7 @@ let rec coef_constant p = match p with Pint a->a |Prec(_,q)->coef_constant q.(0) - + (*********************************************************************** 3. Affichage des polynômes. @@ -437,13 +437,13 @@ let rec coef_constant p = (* si univ=false, on utilise x,y,z,a,b,c,d... comme noms de variables, sinon, x1,x2,... *) -let univ=ref true +let univ=ref true (* joli jusqu'a trois variables -- sinon changer le 'w' *) let string_of_var x= if !univ then "u"^(string_of_int x) - else + else if x<=3 then String.make 1 (Char.chr(x+(Char.code 'w'))) else String.make 1 (Char.chr(x-4+(Char.code 'a'))) @@ -452,8 +452,8 @@ let nsP = ref 0 let rec string_of_Pcut p = if (!nsP)<=0 then "..." - else - match p with + else + match p with |Pint a-> nsP:=(!nsP)-1; if C.le coef0 a then C.to_string a @@ -467,7 +467,7 @@ let rec string_of_Pcut p = then s:=st0; let fin = ref false in for i=(Array.length t)-1 downto 1 do - if (!nsP)<0 + if (!nsP)<0 then (sp:="..."; if not (!fin) then s:=(!s)^"+"^(!sp); fin:=true) @@ -501,10 +501,10 @@ let rec string_of_Pcut p = if !s="" then (nsP:=(!nsP)-1; (s:="0")); !s - + let to_string p = nsP:=20; - string_of_Pcut p + string_of_Pcut p let printP p = Format.printf "@[%s@]" (to_string p) @@ -526,13 +526,13 @@ let print_lpoly lp = print_tpoly (Array.of_list lp) (* rend (s,r) tel que p = s*q+r *) let rec quo_rem_pol p q x = if x=0 - then (match (p,q) with + then (match (p,q) with |(Pint a, Pint b) -> - if C.equal (C.modulo a b) coef0 + if C.equal (C.modulo a b) coef0 then (Pint (C.div a b), cf0) else failwith "div_pol1" |_ -> assert false) - else + else let m = deg x q in let b = coefDom x q in let q1 = remP x q in (* q = b*x^m+q1 *) @@ -567,13 +567,13 @@ and div_pol p q x = ) -(* test de division exacte de p par q mais constantes rationnels +(* test de division exacte de p par q mais constantes rationnels à vérifier *) let divP p q= let x = max (max_var_pol p) (max_var_pol q) in div_pol p q x -(* test de division exacte de p par q mais constantes rationnels +(* test de division exacte de p par q mais constantes rationnels à vérifier *) let div_pol_rat p q= let x = max (max_var_pol p) (max_var_pol q) in @@ -600,7 +600,7 @@ let pseudo_div p q x = match q with Pint _ -> (cf0, q,1, p) | Prec (v,q1) when x<>v -> (cf0, q,1, p) - | Prec (v,q1) -> + | Prec (v,q1) -> ( (* pr "pseudo_division: c^d*p = s*q + r";*) let delta = ref 0 in @@ -636,7 +636,7 @@ let rec pgcdP p q = and pgcd_pol p q x = pgcd_pol_rec p q x -and content_pol p x = +and content_pol p x = match p with Prec(v,p1) when v=x -> Array.fold_left (fun a b -> pgcd_pol_rec a b (x-1)) cf0 p1 @@ -647,8 +647,8 @@ and pgcd_coef_pol c p x = Prec(v,p1) when x=v -> Array.fold_left (fun a b -> pgcd_pol_rec a b (x-1)) c p1 |_ -> pgcd_pol_rec c p (x-1) - - + + and pgcd_pol_rec p q x = match (p,q) with (Pint a,Pint b) -> Pint (C.pgcd (C.abs a) (C.abs b)) @@ -686,7 +686,7 @@ and pgcd_pol_rec p q x = ai = (- ci+1)^(di + 1) b1 = 1 bi = ci*si^di si i>1 - + s1 = 1 si+1 = ((ci+1)^di*si)/si^di @@ -694,7 +694,7 @@ and pgcd_pol_rec p q x = and gcd_sub_res p q x = if equal q cf0 then p - else + else let d = deg x p in let d' = deg x q in if d<d' @@ -704,9 +704,9 @@ and gcd_sub_res p q x = let c' = coefDom x q in let r = snd (quo_rem_pol (((oppP c')^^(delta+1))@@p) (oppP q) x) in gcd_sub_res_rec q r (c'^^delta) c' d' x - + and gcd_sub_res_rec p q s c d x = - if equal q cf0 + if equal q cf0 then p else ( let d' = deg x q in @@ -731,7 +731,7 @@ and lazard_power c s d x = *) (* - p = f1 f2^2 ... fn^r + p = f1 f2^2 ... fn^r p/\p'= f2 f3^2...fn^(r-1) sans_carré(p)= p/p/\p '= f1 f2 ... fn *) @@ -815,9 +815,9 @@ let prfactorise () = print_lpoly (List.flatten c)) hfactorise -let factorise = - memoP "f" hfactorise - (fun p -> +let factorise = + memoP "f" hfactorise + (fun p -> let rec fact p x = if x=0 then [] @@ -859,8 +859,8 @@ let set_of_array_facteurs tf = (* Factorise un tableau de polynômes f, et rend: - - un tableau p de facteurs (degré>0, contenu entier 1, - coefficient de tête >0) obtenu par décomposition sans carrés + - un tableau p de facteurs (degré>0, contenu entier 1, + coefficient de tête >0) obtenu par décomposition sans carrés puis par division mutuelle - un tableau l de couples (constante, listes d'indices l) tels que f.(i) = l.(i)_1*Produit(p.(j), j dans l.(i)_2) @@ -887,7 +887,7 @@ let factorise_tableauP2 f l1 = f l1 in pr ">"; res - + let factorise_tableauP f = factorise_tableauP2 f (Array.map facteurs2 f) @@ -901,9 +901,9 @@ let factorise_tableauP f = let rec is_positif p = let res = - match p with + match p with Pint a -> C.le coef0 a - |Prec(x,p1) -> + |Prec(x,p1) -> (array_for_all is_positif p1) && (try (Array.iteri (fun i c -> if (i mod 2)<>0 && not (equal c cf0) then failwith "pas pair") @@ -919,7 +919,7 @@ let is_negatif p = is_positif (oppP p) (* rend r tel que deg r < deg q et r a le signe de p en les racines de q. - le coefficient dominant de q est non nul + le coefficient dominant de q est non nul quand les polynômes de coef_non_nuls le sont. (rs,cs,ds,ss,crs,lpos,lpol)= pseudo_euclide coef_non_nuls vect.(s-1) res.(s-1) v *) @@ -943,7 +943,7 @@ let pseudo_euclide coef_non_nuls p q x = let r = if d mod 2 = 1 then c@@r else r in let s = if d mod 2 = 1 then c@@s else s in let d = if d mod 2 = 1 then d+1 else d in - + (* on encore c^d * p = s*q + r, mais d pair *) if equal r cf0 then ((*pr "reste nul"; *) (r,c,d,s,cf1,[],[])) @@ -960,7 +960,7 @@ let pseudo_euclide coef_non_nuls p q x = let k = ref 0 in (try (while true do let rd = div_pol !r f x in - (* verification de la division + (* verification de la division if not (equal cf0 ((!r)--(f@@rd))) then failwith "erreur dans la division"; *) @@ -972,7 +972,7 @@ let pseudo_euclide coef_non_nuls p q x = lf:=(f,!k)::(!lf))) coef_non_nuls; (* il faut éventuellement remultiplier pour garder le signe de r *) - let lpos = ref [] in + let lpos = ref [] in let lpol = ref [] in List.iter (fun (f,k) -> if k>0 @@ -1006,7 +1006,7 @@ let pseudo_euclide coef_non_nuls p q x = *) (* lpos = liste de (f,k) ou f est non nul positif, et f^k divise r0 lpol = liste de (f,k) ou f non nul, k est pair et f^k divise r0 - on c^d * p = s*q + r0 + on c^d * p = s*q + r0 avec d pair r0 = cr * r * PI_lpos f^k * PI_lpol g^k cr non nul positif @@ -1016,14 +1016,14 @@ let pseudo_euclide coef_non_nuls p q x = (* teste si la non-nullité des polynômes de lp entraîne celle de p: - chacun des facteurs de la décomposition sans carrés de p + chacun des facteurs de la décomposition sans carrés de p divise un des polynômes de lp (dans Q[x1...xn]) *) let implique_non_nul lp p = if equal p cf0 then false else( pr "["; - let lf = facteurs2 p in + let lf = facteurs2 p in let r =( try (List.iter (fun f -> if (try (List.iter (fun q -> diff --git a/plugins/groebner/utile.ml b/plugins/groebner/utile.ml index fc7de1e33d..40644489b2 100644 --- a/plugins/groebner/utile.ml +++ b/plugins/groebner/utile.ml @@ -21,7 +21,7 @@ let info s = (********************************************************************** Listes *) - + (* appartenance à une liste , on donne l'égalité *) let rec list_mem_eq eq x l = match l with @@ -32,13 +32,13 @@ let rec list_mem_eq eq x l = let set_of_list_eq eq l = let res = ref [] in List.iter (fun x -> if not (list_mem_eq eq x (!res)) then res:=x::(!res)) l; - List.rev !res + List.rev !res (*********************************************************************** Un outil pour faire une mémo-fonction: fonction est la fonction(!) - memoire est une référence au graphe déjà calculé + memoire est une référence au graphe déjà calculé (liste de couples, c'est une variable globale) egal est l'égalité sur les arguments valeur est une valeur possible de la fonction (sert uniquement pour le typage) @@ -56,9 +56,9 @@ let memo memoire egal valeur fonction x = with _ -> !res -(* un autre plus efficace, +(* un autre plus efficace, utilisant une fonction intermediaire (utile si on n'a pas - l'égalité = sur les arguments de fonction) + l'égalité = sur les arguments de fonction) s chaîne imprimée s'il n'y a pas calcul *) let memos s memoire print fonction x = @@ -71,8 +71,8 @@ let memos s memoire print fonction x = (********************************************************************** Eléments minimaux pour un ordre partiel de division. - E est un ensemble, avec une multiplication - et une division partielle div (la fonction div peut échouer), + E est un ensemble, avec une multiplication + et une division partielle div (la fonction div peut échouer), constant est un prédicat qui définit un sous-ensemble C de E. *) (* @@ -128,7 +128,7 @@ let factorise_tableau div zero c f l1 = let r = ref p in let li = ref [] in if not (zero p) - then + then Array.iteri (fun j q -> try (while true do let rr = div !r q in @@ -140,12 +140,12 @@ let factorise_tableau div zero c f l1 = res.(i)<-(!r,!li)) f; (l1,res) - + (* exemples: let l = [1;2;6;24;720] -and div1 = (fun a b -> if a mod b =0 then a/b else failwith "div") +and div1 = (fun a b -> if a mod b =0 then a/b else failwith "div") and constant = (fun x -> x<2) and zero = (fun x -> x=0) diff --git a/plugins/interface/blast.ml b/plugins/interface/blast.ml index 2f0095a56c..55db032f30 100644 --- a/plugins/interface/blast.ml +++ b/plugins/interface/blast.ml @@ -71,11 +71,11 @@ let free_try tac g = else (failwith "not free") ;; let adrel (x,t) e = - match x with + match x with Name(xid) -> Environ.push_rel (x,None,t) e | Anonymous -> Environ.push_rel (x,None,t) e (* les constantes ayant une définition apparaissant dans x *) -let rec def_const_in_term_rec vl x = +let rec def_const_in_term_rec vl x = match (kind_of_term x) with Prod(n,t,c)-> let vl = (adrel (n,t) vl) in def_const_in_term_rec vl c @@ -89,7 +89,7 @@ let rec def_const_in_term_rec vl x = new_sort_in_family (inductive_sort_family mip) | Construct(c) -> def_const_in_term_rec vl (mkInd (inductive_of_constructor c)) - | Case(_,x,t,a) + | Case(_,x,t,a) -> def_const_in_term_rec vl x | Cast(x,_,t)-> def_const_in_term_rec vl t | Const(c) -> def_const_in_term_rec vl (Typeops.type_of_constant vl c) @@ -99,7 +99,7 @@ let def_const_in_term_ x = def_const_in_term_rec (Global.env()) (strip_outer_cast x) ;; (************************************************************************* - recopiés de refiner.ml, car print_subscript pas exportée dans refiner.mli + recopiés de refiner.ml, car print_subscript pas exportée dans refiner.mli modif de print_info_script avec pr_bar *) @@ -115,9 +115,9 @@ let rec print_info_script sigma osign pf = | [] -> (str " " ++ fnl()) | [pf1] -> - if pf1.ref = None then + if pf1.ref = None then (str " " ++ fnl()) - else + else (str";" ++ brk(1,3) ++ print_info_script sigma sign pf1) | _ -> ( str";[" ++ fnl() ++ @@ -125,11 +125,11 @@ let rec print_info_script sigma osign pf = (print_info_script sigma sign) spfl ++ str"]") -let format_print_info_script sigma osign pf = +let format_print_info_script sigma osign pf = hov 0 (print_info_script sigma osign pf) - -let print_subscript sigma sign pf = - (* if is_tactic_proof pf then + +let print_subscript sigma sign pf = + (* if is_tactic_proof pf then format_print_info_script sigma sign (subproof_of_proof pf) else *) format_print_info_script sigma sign pf @@ -150,98 +150,98 @@ let pp_string x = let priority l = List.map snd (List.filter (fun (pr,_) -> pr = 0) l) -let unify_e_resolve (c,clenv) gls = +let unify_e_resolve (c,clenv) gls = let clenv' = connect_clenv gls clenv in let _ = clenv_unique_resolver false clenv' gls in Hiddentac.h_simplest_eapply c gls let rec e_trivial_fail_db db_list local_db goal = - let tacl = + let tacl = registered_e_assumption :: - (tclTHEN Tactics.intro + (tclTHEN Tactics.intro (function g'-> 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'))) :: (List.map fst (e_trivial_resolve db_list local_db (pf_concl goal)) ) - in - tclFIRST (List.map tclCOMPLETE tacl) goal + in + tclFIRST (List.map tclCOMPLETE tacl) goal -and e_my_find_search db_list local_db hdc concl = +and e_my_find_search db_list local_db hdc concl = let hdc = head_of_constr_reference hdc in let hintl = - if occur_existential concl then - list_map_append (fun db -> + if occur_existential concl then + list_map_append (fun db -> let flags = {Auto.auto_unif_flags with Unification.modulo_delta = Hint_db.transparent_state db} in List.map (fun x -> flags, x) (Hint_db.map_all hdc db)) (local_db::db_list) - else - list_map_append (fun db -> + else + list_map_append (fun db -> let flags = {Auto.auto_unif_flags with Unification.modulo_delta = Hint_db.transparent_state db} in List.map (fun x -> flags, x) (Hint_db.map_auto (hdc,concl) db)) (local_db::db_list) - in - let tac_of_hint = - fun (st, ({pri=b; pat = p; code=t} as _patac)) -> - (b, + in + let tac_of_hint = + fun (st, ({pri=b; pat = p; code=t} as _patac)) -> + (b, let tac = match t with | Res_pf (term,cl) -> unify_resolve st (term,cl) | ERes_pf (term,cl) -> unify_e_resolve (term,cl) | Give_exact (c) -> e_give_exact c | Res_pf_THEN_trivial_fail (term,cl) -> - tclTHEN (unify_e_resolve (term,cl)) + tclTHEN (unify_e_resolve (term,cl)) (e_trivial_fail_db db_list local_db) | Unfold_nth c -> unfold_in_concl [all_occurrences,c] | Extern tacast -> Auto.conclPattern concl p tacast - in + in (free_try tac,pr_autotactic t)) (*i - fun gls -> pPNL (pr_autotactic t); Format.print_flush (); + fun gls -> pPNL (pr_autotactic t); Format.print_flush (); try tac gls - with e when Logic.catchable_exception(e) -> - (Format.print_string "Fail\n"; - Format.print_flush (); + with e when Logic.catchable_exception(e) -> + (Format.print_string "Fail\n"; + Format.print_flush (); raise e) i*) - in + in List.map tac_of_hint hintl - -and e_trivial_resolve db_list local_db gl = - try - priority - (e_my_find_search db_list local_db + +and e_trivial_resolve db_list local_db gl = + try + priority + (e_my_find_search db_list local_db (fst (head_constr_bound gl)) gl) with Bound | Not_found -> [] let e_possible_resolve db_list local_db gl = - try List.map snd (e_my_find_search db_list local_db + try List.map snd (e_my_find_search db_list local_db (fst (head_constr_bound gl)) gl) with Bound | Not_found -> [] let assumption_tac_list id = apply_tac_list (e_give_exact (mkVar id)) -let find_first_goal gls = +let find_first_goal gls = try first_goal gls with UserError _ -> assert false (*s The following module [SearchProblem] is used to instantiate the generic exploration functor [Explore.Make]. *) - + module MySearchProblem = struct - type state = { + type state = { depth : int; (*r depth of search before failing *) tacres : goal list sigma * validation; last_tactic : std_ppcmds; dblist : Auto.hint_db list; localdb : Auto.hint_db list } - + let success s = (sig_it (fst s.tacres)) = [] let rec filter_tactics (glls,v) = function | [] -> [] - | (tac,pptac) :: tacl -> - try - let (lgls,ptl) = apply_tac_list tac glls in + | (tac,pptac) :: tacl -> + try + let (lgls,ptl) = apply_tac_list tac glls in let v' p = v (ptl p) in ((lgls,v'),pptac) :: filter_tactics (glls,v) tacl with e when Logic.catchable_exception e -> @@ -254,18 +254,18 @@ module MySearchProblem = struct let nbgoals s = List.length (sig_it (fst s.tacres)) in if d <> 0 then d else nbgoals s - nbgoals s' - let branching s = - if s.depth = 0 then + let branching s = + if s.depth = 0 then [] - else + else let lg = fst s.tacres in let nbgl = List.length (sig_it lg) in assert (nbgl > 0); let g = find_first_goal lg in - let assumption_tacs = - let l = + let assumption_tacs = + let l = filter_tactics s.tacres - (List.map + (List.map (fun id -> (e_give_exact (mkVar id), (str "Exact" ++ spc()++ pr_id id))) (pf_ids_of_hyps g)) @@ -274,40 +274,40 @@ module MySearchProblem = struct last_tactic = pp; dblist = s.dblist; localdb = List.tl s.localdb }) l in - let intro_tac = - List.map - (fun ((lgls,_) as res,pp) -> - let g' = first_goal lgls in - let hintl = + let intro_tac = + List.map + (fun ((lgls,_) as res,pp) -> + let g' = first_goal lgls in + 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 - { depth = s.depth; tacres = res; + { depth = s.depth; tacres = res; last_tactic = pp; dblist = s.dblist; localdb = ldb :: List.tl s.localdb }) (filter_tactics s.tacres [Tactics.intro,(str "Intro" )]) in - let rec_tacs = - let l = + let rec_tacs = + let l = filter_tactics s.tacres (e_possible_resolve s.dblist (List.hd s.localdb) (pf_concl g)) in - List.map - (fun ((lgls,_) as res, pp) -> + List.map + (fun ((lgls,_) as res, pp) -> let nbgl' = List.length (sig_it lgls) in if nbgl' < nbgl then { depth = s.depth; tacres = res; last_tactic = pp; dblist = s.dblist; localdb = List.tl s.localdb } - else - { depth = pred s.depth; tacres = res; + else + { depth = pred s.depth; tacres = res; dblist = s.dblist; last_tactic = pp; - localdb = + localdb = list_addn (nbgl'-nbgl) (List.hd s.localdb) s.localdb }) l in List.sort compare (assumption_tacs @ intro_tac @ rec_tacs) - let pp s = + let pp s = msg (hov 0 (str " depth="++ int s.depth ++ spc() ++ s.last_tactic ++ str "\n")) @@ -331,31 +331,31 @@ let e_depth_search debug p db_list local_db gl = let e_breadth_search debug n db_list local_db gl = try - let tac = - if debug then MySearch.debug_breadth_first else MySearch.breadth_first + let tac = + if debug then MySearch.debug_breadth_first else MySearch.breadth_first in let s = tac (make_initial_state n gl db_list local_db) in s.MySearchProblem.tacres 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 true [] gl in - if n = 0 then +let e_search_auto debug (n,p) db_list gl = + 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 + else e_breadth_search debug n db_list local_db gl -let eauto debug np dbnames = +let eauto debug np dbnames = let db_list = List.map - (fun x -> + (fun x -> try searchtable_map x with Not_found -> error ("EAuto: "^x^": No such Hint database")) - ("core"::dbnames) + ("core"::dbnames) in tclTRY (e_search_auto debug np db_list) -let full_eauto debug n gl = +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 @@ -373,49 +373,49 @@ let my_full_eauto n gl = full_eauto false (n,0) gl de Hint impérative a été remplacée par plusieurs bases fonctionnelles *) let rec trivial_fail_db db_list local_db gl = - let intro_tac = - tclTHEN intro + let intro_tac = + 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 - tclFIRST + tclFIRST (assumption::intro_tac:: - (List.map tclCOMPLETE + (List.map tclCOMPLETE (trivial_resolve db_list local_db (pf_concl gl)))) gl and my_find_search db_list local_db hdc concl = - let tacl = - if occur_existential concl then - list_map_append (fun db -> + let tacl = + if occur_existential concl then + list_map_append (fun db -> let flags = {Auto.auto_unif_flags with Unification.modulo_delta = Hint_db.transparent_state db} in List.map (fun x -> flags, x) (Hint_db.map_all hdc db)) (local_db::db_list) - else - list_map_append (fun db -> + else + list_map_append (fun db -> let flags = {Auto.auto_unif_flags with Unification.modulo_delta = Hint_db.transparent_state db} in List.map (fun x -> flags, x) (Hint_db.map_auto (hdc,concl) db)) (local_db::db_list) in - List.map - (fun (st, {pri=b; pat=p; code=t} as _patac) -> + List.map + (fun (st, {pri=b; pat=p; code=t} as _patac) -> (b, match t with | 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 st (term,cl)) + | Res_pf_THEN_trivial_fail (term,cl) -> + tclTHEN + (unify_resolve st (term,cl)) (trivial_fail_db db_list local_db) | Unfold_nth c -> unfold_in_concl [all_occurrences,c] | Extern tacast -> conclPattern concl p tacast)) tacl -and trivial_resolve db_list local_db cl = - try +and trivial_resolve db_list local_db cl = + try let hdconstr = fst (head_constr_bound cl) in - priority + priority (my_find_search db_list local_db (head_of_constr_reference hdconstr) cl) - with Bound | Not_found -> + with Bound | Not_found -> [] (**************************************************************************) @@ -423,88 +423,88 @@ and trivial_resolve db_list local_db cl = (**************************************************************************) let possible_resolve db_list local_db cl = - try + try let hdconstr = fst (head_constr_bound cl) in - List.map snd + List.map snd (my_find_search db_list local_db (head_of_constr_reference hdconstr) cl) - with Bound | Not_found -> + with Bound | Not_found -> [] -let decomp_unary_term c gls = - let typc = pf_type_of gls c in - let t = head_constr typc in - if Hipattern.is_conjunction (applist t) then - simplest_case c gls - else +let decomp_unary_term c gls = + let typc = pf_type_of gls c in + let t = head_constr typc in + if Hipattern.is_conjunction (applist t) then + simplest_case c gls + else errorlabstrm "Auto.decomp_unary_term" (str "not a unary type") -let decomp_empty_term c gls = - let typc = pf_type_of gls c in - let (hd,_) = decompose_app typc in - if Hipattern.is_empty_type hd then - simplest_case c gls - else +let decomp_empty_term c gls = + let typc = pf_type_of gls c in + let (hd,_) = decompose_app typc in + if Hipattern.is_empty_type hd then + simplest_case c gls + else errorlabstrm "Auto.decomp_empty_term" (str "not an empty type") -(* decomp is an natural number giving an indication on decomposition +(* decomp is an natural number giving an indication on decomposition of conjunction in hypotheses, 0 corresponds to no decomposition *) (* n is the max depth of search *) (* local_db contains the local Hypotheses *) let rec search_gen decomp n db_list local_db extra_sign goal = if n=0 then error "BOUND 2"; - let decomp_tacs = match decomp with - | 0 -> [] - | p -> + let decomp_tacs = match decomp with + | 0 -> [] + | p -> (tclFIRST_PROGRESS_ON decomp_empty_term extra_sign) :: - (List.map - (fun id -> tclTHEN (decomp_unary_term (mkVar id)) - (tclTHEN + (List.map + (fun id -> tclTHEN (decomp_unary_term (mkVar id)) + (tclTHEN (clear [id]) (free_try (search_gen decomp p db_list local_db [])))) - (pf_ids_of_hyps goal)) + (pf_ids_of_hyps goal)) in - let intro_tac = - tclTHEN intro - (fun g' -> + let intro_tac = + tclTHEN intro + (fun g' -> let (hid,_,htyp) = pf_last_hyp g' in - let hintl = - try + let hintl = + try [make_apply_entry (pf_env g') (project g') - (true,true,false) + (true,true,false) None (mkVar hid,htyp)] - with Failure _ -> [] + with Failure _ -> [] in (free_try (search_gen decomp n db_list (Hint_db.add_list hintl local_db) [mkVar hid]) g')) in - let rec_tacs = - List.map - (fun ntac -> + let rec_tacs = + List.map + (fun ntac -> tclTHEN ntac (free_try (search_gen decomp (n-1) db_list local_db []))) (possible_resolve db_list local_db (pf_concl goal)) - in + in tclFIRST (assumption::(decomp_tacs@(intro_tac::rec_tacs))) goal let search = search_gen 0 let default_search_depth = ref 5 - -let full_auto n gl = + +let full_auto 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 hyps = List.map mkVar (pf_ids_of_hyps gl) in tclTRY (search n db_list (make_local_hint_db false [] gl) hyps) gl - + let default_full_auto gl = full_auto !default_search_depth gl (************************************************************************) @@ -518,15 +518,15 @@ let blast_auto = (free_try default_full_auto) ;; let blast_simpl = (free_try (reduce (Simpl None) onConcl)) ;; -let blast_induction1 = +let blast_induction1 = (free_try (tclTHEN (tclTRY intro) (tclTRY (onLastHyp simplest_elim)))) ;; -let blast_induction2 = +let blast_induction2 = (free_try (tclTHEN (tclTRY (tclTHEN intro intro)) (tclTRY (onLastHyp simplest_elim)))) ;; -let blast_induction3 = +let blast_induction3 = (free_try (tclTHEN (tclTRY (tclTHEN intro (tclTHEN intro intro))) (tclTRY (onLastHyp simplest_elim)))) ;; @@ -554,7 +554,7 @@ let vire_extvar s = if get s i = '?' then (interro := true; interro_pos := i) - else if (!interro && + else if (!interro && (List.mem (get s i) ['0';'1';'2';'3';'4';'5';'6';'7';'8';'9'])) then set s i ' ' @@ -570,13 +570,13 @@ let blast gls = ref = None } in try (let (sgl,v) as _res = !blast_tactic gls in let {it=lg} = sgl in - if lg = [] + if lg = [] then (let pf = v (List.map leaf (sig_it sgl)) in let sign = (sig_it gls).evar_hyps in - let x = print_subscript + let x = print_subscript (sig_sig gls) sign pf in msgnl (hov 0 (str"Blast ==> " ++ x)); - let x = print_subscript + let x = print_subscript (sig_sig gls) sign pf in let tac_string = pp_string (hov 0 x ) in @@ -589,15 +589,15 @@ let blast gls = with _ -> failwith "echec de blast" ;; -let blast_tac display_function = function - | (n::_) as _l -> +let blast_tac display_function = function + | (n::_) as _l -> (function g -> let exp_ast = (blast g) in (display_function exp_ast; tclIDTAC g)) | _ -> failwith "expecting other arguments";; -let blast_tac_txt = +let blast_tac_txt = blast_tac (function x -> msgnl(Pptactic.pr_glob_tactic (Global.env()) (Tacinterp.glob_tactic x)));; @@ -621,8 +621,8 @@ CAMLLIB=/usr/local/lib/ocaml CAMLP4LIB=/usr/local/lib/camlp4 export CAMLLIB export COQTOP -export CAMLP4LIB -d:/Tools/coq-7.0-3mai/bin/coqtop.byte.exe +export CAMLP4LIB +d:/Tools/coq-7.0-3mai/bin/coqtop.byte.exe Drop. #use "/cygdrive/D/Tools/coq-7.0-3mai/dev/base_include";; *) diff --git a/plugins/interface/centaur.ml4 b/plugins/interface/centaur.ml4 index ee46cef8b2..e7084fbb00 100644 --- a/plugins/interface/centaur.ml4 +++ b/plugins/interface/centaur.ml4 @@ -74,17 +74,17 @@ 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 +let current_proof_name () = + try string_of_id (get_current_proof_name ()) with UserError("Pfedit.get_proof", _) -> "";; let current_goal_index = ref 0;; -let guarded_force_eval_stream (s : std_ppcmds) = +let guarded_force_eval_stream (s : std_ppcmds) = let l = ref [] in - let f elt = l:= elt :: !l in + let f elt = l:= elt :: !l in (try Stream.iter f s with | _ -> f (Stream.next (str "error guarded_force_eval_stream"))); Stream.of_list (List.rev !l);; @@ -118,7 +118,7 @@ type vtp_tree = | P_text of ct_TEXT | P_ids of ct_ID_LIST;; -let print_tree t = +let print_tree t = (match t with | P_rl x -> fRULE_LIST x | P_r x -> fRULE x @@ -138,10 +138,10 @@ let ctf_header message_name request_id = int request_id ++ fnl();; let ctf_acknowledge_command request_id command_count opt_exn = - let goal_count, goal_index = + let goal_count, goal_index = if refining() then let g_count = - List.length + List.length (fst (frontier (proof_of_pftreestate (get_pftreestate ())))) in g_count, !current_goal_index else @@ -192,7 +192,7 @@ let ctf_AbortedAllMessage () = fnl() ++ str "message" ++ fnl() ++ str "aborted_all" ++ fnl();; let ctf_AbortedMessage request_id na = - ctf_header "aborted_proof" request_id ++ str na ++ fnl () ++ + ctf_header "aborted_proof" request_id ++ str na ++ fnl () ++ str "E-n-d---M-e-s-s-a-g-e" ++ fnl ();; let ctf_UserErrorMessage request_id stream = @@ -256,7 +256,7 @@ let show_nth n = ++ pr_nth_open_subgoal n) None with - | Invalid_argument s -> + | Invalid_argument s -> error "No focused proof (No proof-editing in progress)";; let show_subgoals () = @@ -265,7 +265,7 @@ let show_subgoals () = ++ pr_open_subgoals ()) None with - | Invalid_argument s -> + | Invalid_argument s -> error "No focused proof (No proof-editing in progress)";; (* The rest of the file contains commands that are changed from the plain @@ -280,11 +280,11 @@ let filter_by_module_from_varg_list l = *) let add_search (global_reference:global_reference) assumptions cstr = - try + try let id_string = string_of_qualid (Nametab.shortest_qualid_of_global Idset.empty global_reference) in - let ast = + let ast = try CT_premise (CT_ident id_string, translate_constr false assumptions cstr) with Not_found -> @@ -324,20 +324,20 @@ let ct_print_eval red_fun env evmap ast judg = translate_constr false env ntyp)]));; let pbp_tac_pcoq = - pbp_tac (function (x:raw_tactic_expr) -> + pbp_tac (function (x:raw_tactic_expr) -> output_results (ctf_header "pbp_results" !global_request_id) (Some (P_t(xlate_tactic x))));; let blast_tac_pcoq = - blast_tac (function (x:raw_tactic_expr) -> + blast_tac (function (x:raw_tactic_expr) -> output_results (ctf_header "pbp_results" !global_request_id) (Some (P_t(xlate_tactic x))));; -(* <\cpa> +(* <\cpa> let dad_tac_pcoq = - dad_tac(function x -> + dad_tac(function x -> output_results (ctf_header "pbp_results" !global_request_id) (Some (P_t(xlate_tactic x))));; @@ -368,7 +368,7 @@ Caution, this is in the middle of what looks like dead code. ; e -> match !the_goal with None -> raise e - | Some g -> + | Some g -> (output_results (ctf_Location !global_request_id) (Some (P_s_int @@ -376,7 +376,7 @@ Caution, this is in the middle of what looks like dead code. ; (List.map (fun n -> CT_coerce_INT_to_SIGNED_INT (CT_int n)) - (clean_path tac + (clean_path tac (List.rev !the_path))))))); (output_results (ctf_OtherGoal !global_request_id) @@ -417,7 +417,7 @@ let inspect n = add_search2 (Nametab.locate (qualid_of_path sp)) (Pretyping.Default.understand Evd.empty (Global.env()) (RRef(dummy_loc, IndRef(kn,0)))) - | _ -> failwith ("unexpected value 1 for "^ + | _ -> failwith ("unexpected value 1 for "^ (string_of_id (basename (fst oname))))) | _ -> failwith "unexpected value") with e -> ()) @@ -427,7 +427,7 @@ let inspect n = (Some (P_pl (CT_premises_list (List.rev !ctv_SEARCH_LIST))));; -let ct_int_to_TARG n = +let ct_int_to_TARG n = CT_coerce_FORMULA_OR_INT_to_TARG (CT_coerce_ID_OR_INT_to_FORMULA_OR_INT (CT_coerce_INT_to_ID_OR_INT (CT_int n)));; @@ -561,7 +561,7 @@ let pcoq_search s l = *) ctv_SEARCH_LIST:=[]; begin match s with - | SearchAbout sl -> + | SearchAbout sl -> raw_search_about (filter_by_module_from_list l) add_search (List.map (on_snd interp_search_about_item) sl) | SearchPattern c -> @@ -580,7 +580,7 @@ let pcoq_search s l = let rec hyp_pattern_filter pat name a c = let _c1 = strip_outer_cast c in match kind_of_term c with - | Prod(_, hyp, c2) -> + | Prod(_, hyp, c2) -> (try (* let _ = msgnl ((str "WHOLE ") ++ (Printer.pr_lconstr c)) in let _ = msgnl ((str "PAT ") ++ (Printer.pr_constr_pattern pat)) in *) @@ -605,7 +605,7 @@ let hyp_search_pattern c l = (Some (P_pl (CT_premises_list (List.rev !ctv_SEARCH_LIST))));; let pcoq_print_name ref = - output_results + output_results (fnl () ++ str "message" ++ fnl () ++ str "PRINT_VALUE" ++ fnl () ++ print_name ref ) None @@ -665,8 +665,8 @@ let pcoq_print_object_template object_to_ast_list sp = (* 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 + 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 @@ -797,7 +797,7 @@ let start_depends_dumps () = gen_start_depends_dumps output_depends output_depen 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) ] -> +| [ "pbp" ident_opt(idopt) natural_list(nl) ] -> [ if_pcoq pbp_tac_pcoq idopt nl ] END @@ -810,10 +810,10 @@ TACTIC EXTEND ct_debugtac2 END -let start_pcoq_mode debug = +let start_pcoq_mode debug = begin pcoq_started := Some debug; -(* <\cpa> +(* <\cpa> start_dad(); </cpa> *) (* The following ones are added to enable rich comments in pcoq *) @@ -830,7 +830,7 @@ let start_pcoq_mode debug = *) set_pcoq_hook pcoq_hook; start_pcoq_objects(); - Flags.print_emacs := false; Pp.make_pp_nonemacs(); + Flags.print_emacs := false; Pp.make_pp_nonemacs(); end;; diff --git a/plugins/interface/coqparser.ml b/plugins/interface/coqparser.ml index df5e66b50f..730af3ca2f 100644 --- a/plugins/interface/coqparser.ml +++ b/plugins/interface/coqparser.ml @@ -53,13 +53,13 @@ let execute_when_necessary v = (match v with | VernacOpenCloseScope sc -> Vernacentries.interp v | VernacRequire (_,_,l) -> - (try + (try Vernacentries.interp v with _ -> let l=prlist_with_sep spc pr_reference l in msgnl (str "Reinterning of " ++ l ++ str " failed")) | VernacRequireFrom (_,_,f) -> - (try + (try Vernacentries.interp v with _ -> msgnl (str "Reinterning of " ++ Util.pr_str f ++ str " failed")) @@ -112,7 +112,7 @@ let rec get_sub_aux string_list snd_pos = let rec get_substring_list string_list fst_pos snd_pos = match string_list with [] -> [] - | s::l -> + | s::l -> let len = String.length s in if fst_pos > len then get_substring_list l (fst_pos - len - 1) (snd_pos - len - 1) @@ -146,10 +146,10 @@ let make_parse_error_item s l = let parse_command_list reqid stream string_list = let rec parse_whole_stream () = let this_pos = Stream.count stream in - let first_ast = + let first_ast = try ParseOK (Gram.Entry.parse Pcoq.main_entry (Gram.parsable stream)) with - | (Stdpp.Exc_located(l, Stream.Error txt)) as e -> + | (Stdpp.Exc_located(l, Stream.Error txt)) as e -> begin msgnl (ctf_SyntaxWarningMessage reqid (Cerrors.explain_exn e)); try @@ -161,7 +161,7 @@ let parse_command_list reqid stream string_list = (Stream.count stream)) with End_of_file -> ParseOK None end - | e-> + | e-> begin discard_to_dot stream; ParseError ("PARSING_ERROR2", @@ -172,11 +172,11 @@ let parse_command_list reqid stream string_list = let _ast0 = (execute_when_necessary ast) in (try xlate_vernac ast with e -> - make_parse_error_item "PARSING_ERROR2" + make_parse_error_item "PARSING_ERROR2" (get_substring_list string_list this_pos (Stream.count stream)))::parse_whole_stream() | ParseOK None -> [] - | ParseError (s,l) -> + | ParseError (s,l) -> (make_parse_error_item s l)::parse_whole_stream() in match parse_whole_stream () with @@ -200,21 +200,21 @@ let parse_string_action reqid phylum char_stream string_list = (Gram.Entry.parse Pcoq.Vernac_.vernac_eoi (Gram.parsable char_stream)))) | "TACTIC_COM" -> P_t - (xlate_tactic (Gram.Entry.parse Pcoq.Tactic.tactic_eoi + (xlate_tactic (Gram.Entry.parse Pcoq.Tactic.tactic_eoi (Gram.parsable char_stream))) | "FORMULA" -> P_f (xlate_formula - (Gram.Entry.parse + (Gram.Entry.parse (Pcoq.eoi_entry Pcoq.Constr.lconstr) (Gram.parsable char_stream))) | "ID" -> P_id (CT_ident - (Libnames.string_of_qualid - (snd + (Libnames.string_of_qualid + (snd (Gram.Entry.parse (Pcoq.eoi_entry Pcoq.Prim.qualid) (Gram.parsable char_stream))))) | "STRING" -> P_s - (CT_string (Gram.Entry.parse Pcoq.Prim.string + (CT_string (Gram.Entry.parse Pcoq.Prim.string (Gram.parsable char_stream))) | "INT" -> P_i (CT_int (Gram.Entry.parse Pcoq.Prim.natural @@ -225,7 +225,7 @@ let parse_string_action reqid phylum char_stream string_list = | Stdpp.Exc_located(l,Match_failure(_,_,_)) -> flush_until_end_of_stream char_stream; msgnl (ctf_SyntaxErrorMessage reqid - (Cerrors.explain_exn + (Cerrors.explain_exn (Stdpp.Exc_located(l,Stream.Error "match failure")))) | e -> flush_until_end_of_stream char_stream; @@ -233,7 +233,7 @@ let parse_string_action reqid phylum char_stream string_list = let quiet_parse_string_action char_stream = - try let _ = + try let _ = Gram.Entry.parse Pcoq.Vernac_.vernac_eoi (Gram.parsable char_stream) in () with @@ -242,9 +242,9 @@ let quiet_parse_string_action char_stream = let parse_file_action reqid file_name = try let file_chan = open_in file_name in - (* file_chan_err, stream_err are the channel and stream used to + (* file_chan_err, stream_err are the channel and stream used to get the text when a syntax error occurs *) - let file_chan_err = open_in file_name in + let file_chan_err = open_in file_name in let stream = Stream.of_channel file_chan in let _stream_err = Stream.of_channel file_chan_err in let rec discard_to_dot () = @@ -252,21 +252,21 @@ let parse_file_action reqid file_name = with Stdpp.Exc_located(_,Token.Error _) -> discard_to_dot() in match let rec parse_whole_file () = let this_pos = Stream.count stream in - match + match try ParseOK(Gram.Entry.parse Pcoq.main_entry (Gram.parsable stream)) with - | Stdpp.Exc_located(l,Stream.Error txt) -> + | Stdpp.Exc_located(l,Stream.Error txt) -> msgnl (ctf_SyntaxWarningMessage reqid (str "Error with file" ++ spc () ++ str file_name ++ fnl () ++ - Cerrors.explain_exn + Cerrors.explain_exn (Stdpp.Exc_located(l,Stream.Error txt)))); - (try + (try begin discard_to_dot (); ParseError ("PARSING_ERROR", - (make_string_list file_chan_err this_pos + (make_string_list file_chan_err this_pos (Stream.count stream))) end with End_of_file -> ParseOK None) @@ -277,10 +277,10 @@ let parse_file_action reqid file_name = (make_string_list file_chan this_pos (Stream.count stream))) end - + with | ParseOK (Some (_,ast)) -> - let _ast0=(execute_when_necessary ast) in + let _ast0=(execute_when_necessary ast) in let term = (try xlate_vernac ast with e -> @@ -291,10 +291,10 @@ let parse_file_action reqid file_name = "\n"); make_parse_error_item "PARSING_ERROR2" (make_string_list file_chan_err this_pos - (Stream.count stream))) in + (Stream.count stream))) in term::parse_whole_file () | ParseOK None -> [] - | ParseError (s,l) -> + | ParseError (s,l) -> (make_parse_error_item s l)::parse_whole_file () in parse_whole_file () with | first_one :: tail -> @@ -305,7 +305,7 @@ let parse_file_action reqid file_name = | Stdpp.Exc_located(l,Match_failure(_,_,_)) -> msgnl (ctf_SyntaxErrorMessage reqid - (str "Error with file" ++ spc () ++ str file_name ++ + (str "Error with file" ++ spc () ++ str file_name ++ fnl () ++ Cerrors.explain_exn (Stdpp.Exc_located(l,Stream.Error "match failure")))) @@ -320,7 +320,7 @@ let add_rec_path_action reqid string_arg ident_arg = begin add_rec_path directory_name (Libnames.dirpath_of_string ident_arg) end;; - + let add_path_action reqid string_arg = let directory_name = expand_path_macros string_arg in @@ -338,7 +338,7 @@ let load_syntax_action reqid module_name = (let qid = Libnames.qualid_of_ident (Names.id_of_string module_name) in require_library [dummy_loc,qid] None; msg (str "opening... "); - Declaremods.import_module false (Nametab.locate_module qid); + Declaremods.import_module false (Nametab.locate_module qid); msgnl (str "done" ++ fnl ()); ()) with @@ -365,11 +365,11 @@ let coqparser_loop inchan = add_path_action, add_rec_path_action, load_syntax_action) inchan;; if !Sys.interactive then () - else + else Libobject.relax true; -(let coqdir = +(let coqdir = try Sys.getenv "COQDIR" - with Not_found -> + with Not_found -> let coqdir = Envars.coqlib () in if Sys.file_exists coqdir then coqdir @@ -385,8 +385,8 @@ Libobject.relax true; try Sys.getenv "VERNACRC" with - Not_found -> - List.fold_left + Not_found -> + List.fold_left (fun s1 s2 -> (Filename.concat s1 s2)) coqdir [ "plugins"; "interface"; "vernacrc"] in try @@ -417,6 +417,6 @@ Libobject.relax true; msgnl (str "Starting Centaur Specialized Parser Loop"); try coqparser_loop stdin -with +with | End_of_file -> () | e -> msgnl(Cerrors.explain_exn e)) diff --git a/plugins/interface/dad.ml b/plugins/interface/dad.ml index c2ab2dc8d0..fb0562c571 100644 --- a/plugins/interface/dad.ml +++ b/plugins/interface/dad.ml @@ -58,9 +58,9 @@ let zz = Util.dummy_loc;; let rec get_subterm (depth:int) (path: int list) (constr:constr) = match depth, path, kind_of_term constr with 0, l, c -> (constr,l) - | n, 2::a::tl, App(func,arr) -> + | n, 2::a::tl, App(func,arr) -> get_subterm (n - 2) tl arr.(a-1) - | _,l,_ -> failwith (int_list_to_string + | _,l,_ -> failwith (int_list_to_string "wrong path or wrong form of term" l);; @@ -93,12 +93,12 @@ let rec find_cmd (l:(string * dad_rule) list) env constr p p1 p2 = if deg > length then failwith "internal" else - let term_to_match, p_r = - try + let term_to_match, p_r = + try get_subterm (length - deg) p constr with Failure s -> failwith "internal" in - let _, constr_pat = + let _, constr_pat = intern_constr_pattern Evd.empty (Global.env()) ((*ct_to_ast*) pat) in let subst = matches constr_pat term_to_match in @@ -136,26 +136,26 @@ let dad_tac display_function = function l -> let p1, p2 = part_tac_args [] l in (function g -> let (p_a, p1prime, p2prime) = decompose_path (List.rev p1,p2) in - (display_function + (display_function (find_cmd (!dad_rule_list) (pf_env g) (pf_concl g) p_a p1prime p2prime)); tclIDTAC g);; *) let dad_tac display_function p1 p2 g = let (p_a, p1prime, p2prime) = decompose_path (p1,p2) in - (display_function + (display_function (find_cmd (!dad_rule_list) (pf_env g) (pf_concl g) p_a p1prime p2prime)); tclIDTAC g;; (* Now we enter dad rule list management. *) let add_dad_rule name patt p1 p2 depth pr command = - dad_rule_list := (name, + dad_rule_list := (name, (patt, p1, p2, depth, pr, command))::!dad_rule_list;; let rec remove_if_exists name = function [] -> false, [] - | ((a,b) as rule1)::tl -> if a = name then + | ((a,b) as rule1)::tl -> if a = name then let result1, l = (remove_if_exists name tl) in true, l else @@ -177,11 +177,11 @@ let constrain ((n : patvar),(pat : constr_pattern)) sigma = if List.mem_assoc n sigma then if pat = (List.assoc n sigma) then sigma else failwith "internal" - else + else (n,pat)::sigma - + (* This function is inspired from matches_core in pattern.ml *) -let more_general_pat pat1 pat2 = +let more_general_pat pat1 pat2 = let rec match_rec sigma p1 p2 = match p1, p2 with | PMeta (Some n), m -> constrain (n,m) sigma @@ -203,7 +203,7 @@ let more_general_pat pat1 pat2 = | PApp (c1,arg1), PApp (c2,arg2) -> (try array_fold_left2 match_rec (match_rec sigma c1 c2) arg1 arg2 with Invalid_argument _ -> failwith "internal") - | _ -> failwith "unexpected case in more_general_pat" in + | _ -> failwith "unexpected case in more_general_pat" in try let _ = match_rec [] pat1 pat2 in true with Failure "internal" -> false;; @@ -214,7 +214,7 @@ let more_general r1 r2 = (more_general_pat patt1 patt2) & (is_prefix p11 p21) & (is_prefix p12 p22);; -let not_less_general r1 r2 = +let not_less_general r1 r2 = not (match r1,r2 with (_,(patt1,p11,p12,_,_,_)), (_,(patt2,p21,p22,_,_,_)) -> @@ -235,7 +235,7 @@ let rec add_in_list_sorting rule1 = function rule1::this_list and add_in_list_sorting_aux rule1 = function [] -> [] - | b::tl -> + | b::tl -> if more_general rule1 b then b::(add_in_list_sorting rule1 tl) else @@ -245,7 +245,7 @@ and add_in_list_sorting_aux rule1 = function | _ -> rule1::tl2);; let rec sort_list = function - [] -> [] + [] -> [] | a::l -> add_in_list_sorting a (sort_list l);; let mk_dad_meta n = CPatVar (zz,(true,Nameops.make_ident "DAD" (Some n)));; diff --git a/plugins/interface/debug_tac.ml4 b/plugins/interface/debug_tac.ml4 index 79c5fe8a8e..9fade8b587 100644 --- a/plugins/interface/debug_tac.ml4 +++ b/plugins/interface/debug_tac.ml4 @@ -57,7 +57,7 @@ let no_failure = function [Report_node(true,_,_)] -> true | _ -> false;; -let check_subgoals_count2 +let check_subgoals_count2 : card_holder -> int -> bool ref -> (report_holder -> tactic) -> tactic = fun card_holder count flag t g -> let new_report_holder = ref ([] : report_tree list) in @@ -96,7 +96,7 @@ let count_subgoals : card_holder -> bool ref -> tactic -> tactic = e -> card_holder := Fail; flag := false; tclIDTAC g;; - + let count_subgoals2 : card_holder -> bool ref -> (report_holder -> tactic) -> tactic = fun card_holder flag t g -> @@ -139,24 +139,24 @@ let rec local_interp : glob_tactic_expr -> report_holder -> tactic = function - In case of success of the first tactic, but count mismatch, then Mismatch n is added to the report holder. *) -and checked_thens: report_holder -> glob_tactic_expr -> glob_tactic_expr list -> tactic = +and checked_thens: report_holder -> glob_tactic_expr -> glob_tactic_expr list -> tactic = (fun report_holder t1 l g -> let flag = ref true in let traceable_t1 = traceable t1 in let card_holder = ref Fail in let new_holder = ref ([]:report_tree list) in - let tac_t1 = + let tac_t1 = if traceable_t1 then (check_subgoals_count2 card_holder (List.length l) flag (local_interp t1)) else (check_subgoals_count card_holder (List.length l) flag (Tacinterp.eval_tactic t1)) in - let (gls, _) as result = + let (gls, _) as result = tclTHEN_i tac_t1 (fun i -> if !flag then - (fun g -> + (fun g -> let tac_i = (List.nth l i) in if traceable tac_i then local_interp tac_i new_holder g @@ -174,7 +174,7 @@ and checked_thens: report_holder -> glob_tactic_expr -> glob_tactic_expr list -> tclIDTAC) g in let new_goal_list = sig_it gls in (if !flag then - report_holder := + report_holder := (Report_node(collect_status !new_holder, (List.length new_goal_list), List.rev !new_holder))::!report_holder @@ -206,7 +206,7 @@ and checked_then: report_holder -> glob_tactic_expr -> glob_tactic_expr -> tacti let new_tree_holder = ref ([] : report_tree list) in let (gls, _) as result = tclTHEN tac_t1 - (fun (g:goal sigma) -> + (fun (g:goal sigma) -> if !flag then if traceable t2 then local_interp t2 new_tree_holder g @@ -273,7 +273,7 @@ let rec select_success n = function let rec reconstruct_success_tac (tac:glob_tactic_expr) = match tac with TacThens (a,l) -> - (function + (function Report_node(true, n, l) -> tac | Report_node(false, n, rl) -> TacThens (a,List.map2 reconstruct_success_tac l rl) @@ -292,7 +292,7 @@ let rec reconstruct_success_tac (tac:glob_tactic_expr) = | Failed n -> TacId [] | Tree_fail r -> reconstruct_success_tac a r | _ -> error "this error case should not happen in a THEN tactic") - | _ -> + | _ -> (function Report_node(true, n, l) -> tac | Failed n -> TacId [] @@ -301,7 +301,7 @@ let rec reconstruct_success_tac (tac:glob_tactic_expr) = "this error case should not happen on an unknown tactic" (str "error in reconstruction with " ++ fnl () ++ (pr_glob_tactic tac)));; - + let rec path_to_first_error = function | Report_node(true, _, l) -> @@ -315,14 +315,14 @@ let rec path_to_first_error = function let debug_tac = function [(Tacexp ast)] -> - (fun g -> + (fun g -> let report = ref ([] : report_tree list) in let result = local_interp ast report g in let clean_ast = (* expand_tactic *) ast in let report_tree = try List.hd !report with Failure "hd" -> (msgnl (str "report is empty"); Failed 1) in - let success_tac = + let success_tac = reconstruct_success_tac clean_ast report_tree in let compact_success_tac = (* flatten_then *) success_tac in msgnl (fnl () ++ @@ -339,7 +339,7 @@ add_tactic "DebugTac" debug_tac;; Tacinterp.add_tactic "OnThen" on_then;; -let rec clean_path tac l = +let rec clean_path tac l = match tac, l with | TacThen (a,[||],b,[||]), fst::tl -> fst::(clean_path (if fst = 1 then a else b) tl) @@ -351,9 +351,9 @@ let rec clean_path tac l = | _, _ -> failwith "this case should not happen in clean_path";; let rec report_error - : glob_tactic_expr -> goal sigma option ref -> glob_tactic_expr ref -> int list ref -> + : glob_tactic_expr -> goal sigma option ref -> glob_tactic_expr ref -> int list ref -> int list -> tactic = - fun tac the_goal the_ast returned_path path -> + fun tac the_goal the_ast returned_path path -> match tac with TacThens (a,l) -> let the_card_holder = ref Fail in @@ -362,12 +362,12 @@ let rec report_error tclTHENS (fun g -> let result = - check_subgoals_count + check_subgoals_count the_card_holder - (List.length l) + (List.length l) the_flag - (fun g2 -> - try + (fun g2 -> + try (report_error a the_goal the_ast returned_path (1::path) g2) with e -> (the_exn := e; raise e)) @@ -376,10 +376,10 @@ let rec report_error result else (match !the_card_holder with - Fail -> + Fail -> the_ast := TacThens (!the_ast, l); raise !the_exn - | Goals_mismatch p -> + | Goals_mismatch p -> the_ast := tac; returned_path := path; error ("Wrong number of tactics: expected " ^ @@ -403,7 +403,7 @@ let rec report_error raise e)) (fun g -> try - let result = + let result = report_error b the_goal the_ast returned_path (2::path) g in the_count := !the_count + 1; result diff --git a/plugins/interface/depends.ml b/plugins/interface/depends.ml index 83c156f7bf..1a5bfaf33d 100644 --- a/plugins/interface/depends.ml +++ b/plugins/interface/depends.ml @@ -317,7 +317,7 @@ let rec depends_of_gen_tactic_expr depends_of_'constr depends_of_'ind depends_of | TacLApply c -> depends_of_'constr c acc (* Automation tactics *) - | TacTrivial (cl, bs) -> + | 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) -> @@ -336,7 +336,7 @@ let rec depends_of_gen_tactic_expr depends_of_'constr depends_of_'ind depends_of | TacClear _ | TacClearBody _ | TacMove _ - | TacRename _ + | TacRename _ | TacRevert _ -> acc (* Constructors *) diff --git a/plugins/interface/history.ml b/plugins/interface/history.ml index f73c20849a..cfd33c1861 100644 --- a/plugins/interface/history.ml +++ b/plugins/interface/history.ml @@ -12,7 +12,7 @@ type prf_info = { mutable border : tree list; prf_struct : tree};; -let theorem_proofs = ((Hashtbl.create 17): +let theorem_proofs = ((Hashtbl.create 17): (string, prf_info) Hashtbl.t);; @@ -54,12 +54,12 @@ let push_command s rank ngoals = this_tree.sub_proofs <- new_trees end;; -let get_tree_for_rank thm_name rank = - let {ranks_and_goals=l;prf_length=n} = +let get_tree_for_rank thm_name rank = + let {ranks_and_goals=l;prf_length=n} = Hashtbl.find theorem_proofs thm_name in let rec get_tree_aux = function [] -> - failwith + failwith "inconsistent values for thm_name and rank in get_tree_for_rank" | (_,_,({index=i} as tree))::tl -> if i = rank then @@ -88,9 +88,9 @@ let parent_from_rank thm_name rank = let first_child_command thm_name rank = let {sub_proofs = l} = get_tree_for_rank thm_name rank in - let rec first_child_rec = function + let rec first_child_rec = function [] -> None - | {index=i;is_open=b}::l -> + | {index=i;is_open=b}::l -> if b then (first_child_rec l) else @@ -104,7 +104,7 @@ let first_child_command_or_goal thm_name rank = let {sub_proofs=l}=get_tree_for_rank thm_name rank in match l with [] -> None - | ({index=i;is_open=b} as t)::_ -> + | ({index=i;is_open=b} as t)::_ -> if b then let rec get_rank n = function [] -> failwith "A goal is lost in first_child_command_or_goal" @@ -124,12 +124,12 @@ let next_sibling thm_name rank = | Some real_mommy -> let {sub_proofs=l}=real_mommy in let rec next_sibling_aux b = function - (opt_first, []) -> + (opt_first, []) -> if b then opt_first else failwith "inconsistency detected in next_sibling" - | (opt_first, {is_open=true}::l) -> + | (opt_first, {is_open=true}::l) -> next_sibling_aux b (opt_first, l) | (Some(first),({index=i; is_open=false} as t')::l) -> if b then @@ -149,7 +149,7 @@ let prefix l1 l2 = let rec remove_all_prefixes p = function [] -> [] - | a::l -> + | a::l -> if is_prefix p a then (remove_all_prefixes p l) else @@ -163,8 +163,8 @@ let recompute_border tree = else List.fold_right recompute_border_aux l acc in recompute_border_aux tree [];; - - + + let historical_undo thm_name rank = let ({ranks_and_goals=l} as proof_info)= Hashtbl.find theorem_proofs thm_name in @@ -180,7 +180,7 @@ let historical_undo thm_name rank = tree.is_open <- true; tree.sub_proofs <- []; proof_info.border <- recompute_border proof_info.prf_struct; - this_path_reversed::res + this_path_reversed::res end else begin @@ -208,7 +208,7 @@ let rec logical_undo_on_border the_tree rev_path = function (k,tree::res) else (0, the_tree::tree::tl);; - + let logical_undo thm_name rank = let ({ranks_and_goals=l; border=last_border} as proof_info)= @@ -223,7 +223,7 @@ let logical_undo thm_name rank = let new_rank, new_offset, new_width, kept = if is_prefix rev_ref_path this_path_rev then (r + lex_smaller_offset), lex_smaller_offset, - (family_width + 1 - n), false + (family_width + 1 - n), false else if lex_smaller this_path_rev rev_ref_path then r, (lex_smaller_offset - 1 + n), family_width, true else @@ -239,14 +239,14 @@ let logical_undo thm_name rank = begin tree.index <- current_rank; ranks_undone, ((i,new_rank)::ranks_kept), - ((new_rank, n, tree)::ranks_and_goals), + ((new_rank, n, tree)::ranks_and_goals), (current_rank + 1) end else ((i,new_rank)::ranks_undone), ranks_kept, ranks_and_goals, current_rank end in - let number_suffix, new_border = + let number_suffix, new_border = logical_undo_on_border ref_tree rev_ref_path last_border in let changed_ranks_undone, changed_ranks_kept, new_ranks_and_goals, new_length_plus_one = logical_aux 0 number_suffix l in @@ -265,19 +265,19 @@ let logical_undo thm_name rank = proof_info.border <- new_border; proof_info.ranks_and_goals <- new_ranks_and_goals; proof_info.prf_length <- new_length_plus_one - 1; - changed_ranks_undone, changed_ranks_kept, proof_info.prf_length, + changed_ranks_undone, changed_ranks_kept, proof_info.prf_length, the_goal_index end;; - + let start_proof thm_name = - let the_tree = + let the_tree = {index=0;parent=None;path_to_root=[];is_open=true;sub_proofs=[]} in Hashtbl.add theorem_proofs thm_name {prf_length=0; ranks_and_goals=[]; border=[the_tree]; prf_struct=the_tree};; - + let dump_sequence chan s = match (Hashtbl.find theorem_proofs s) with {ranks_and_goals=l}-> @@ -294,7 +294,7 @@ let dump_sequence chan s = output_string chan "end\n" end;; - + let proof_info_as_string s = let res = ref "" in match (Hashtbl.find theorem_proofs s) with @@ -307,7 +307,7 @@ let proof_info_as_string s = None -> if op then res := !res ^ "\"open goal\"\n" - | Some {index=j} -> + | Some {index=j} -> begin res := !res ^ (string_of_int j); res := !res ^ " -> "; @@ -330,7 +330,7 @@ let proof_info_as_string s = !res;; -let dump_proof_info chan s = +let dump_proof_info chan s = match (Hashtbl.find theorem_proofs s) with {prf_struct=tree} -> let open_goal_counter = ref 0 in @@ -341,7 +341,7 @@ let dump_proof_info chan s = None -> if op then output_string chan "\"open goal\"\n" - | Some {index=j} -> + | Some {index=j} -> begin output_string chan (string_of_int j); output_string chan " -> "; diff --git a/plugins/interface/line_parser.ml4 b/plugins/interface/line_parser.ml4 index 0b13a092a4..1c5afc1be7 100755 --- a/plugins/interface/line_parser.ml4 +++ b/plugins/interface/line_parser.ml4 @@ -6,7 +6,7 @@ by a precise keyword, which is also expected to appear alone on a line. *) (* The main parsing loop procedure is "parser_loop", given at the end of this file. It read lines one by one and checks whether they can be parsed using a very simple parser. This very simple parser uses a lexer, which is also given -in this file. +in this file. The lexical analyser: There are only 5 sorts of tokens *) @@ -19,7 +19,7 @@ type simple_tokens = Tspace | Tid of string | Tint of int | Tstring of string | code in src/meta/lexer.ml of Coq revision 6.1) *) let add_in_buff,get_buff = let buff = ref (String.create 80) in - (fun i x -> + (fun i x -> let len = String.length !buff in if i >= len then (buff := !buff ^ (String.create len);()); String.set !buff i x; @@ -47,16 +47,16 @@ let get_digit c = Char.code c - code0;; let rec parse_int intval = parser [< ''0'..'9' as c ; i=parse_int (10 * intval + get_digit c)>] -> i | [< >] -> Tint intval;; - -(* The string lexer is borrowed from the string parser of Coq V6.1 + +(* The string lexer is borrowed from the string parser of Coq V6.1 This may be a problem if convention have changed in Coq, However this parser is only used to recognize file names which should not contain too many special characters *) let rec spec_char = parser - [< ''n' >] -> '\n' + [< ''n' >] -> '\n' | [< ''t' >] -> '\t' -| [< ''b' >] -> '\008' +| [< ''b' >] -> '\008' | [< ''r' >] -> '\013' | [< ''0'..'9' as c; v= (spec1 (get_digit c)) >] -> Char.chr v @@ -93,7 +93,7 @@ let rec next_token = parser _count | [< '']' >] -> Trbracket | [< '_ ; x = next_token >] -> x;; -(* A very simple lexical analyser to recognize a integer value behind +(* A very simple lexical analyser to recognize a integer value behind blank characters *) let rec next_int = parser _count @@ -139,7 +139,7 @@ let line_list_to_stream string_list = count := !count + !current_length + 1; match !reserve with | [] -> None - | s1::rest -> + | s1::rest -> begin buff := s1; current_length := String.length !buff; @@ -149,7 +149,7 @@ let line_list_to_stream string_list = end else Some(String.get !buff (i - !count)));; - + (* In older revisions of this file you would find a function that does line oriented breakdown of the input channel without resorting to @@ -196,14 +196,14 @@ let parser_loop functions input_channel = load_syntax_action = functions in let rec parser_loop_rec input_channel = (let line = input_line input_channel in - let reqid, parser_request = - try + let reqid, parser_request = + try (match Stream.from (token_stream (Stream.of_string line)) with parser | [< 'Tid "print_version" >] -> 0, PRINT_VERSION | [< 'Tid "parse_string" ; 'Tint reqid ; 'Tlbracket ; - 'Tid phylum ; 'Trbracket >] + 'Tid phylum ; 'Trbracket >] -> reqid,PARSE_STRING phylum | [< 'Tid "quiet_parse_string" >] -> 0,QUIET_PARSE_STRING diff --git a/plugins/interface/name_to_ast.ml b/plugins/interface/name_to_ast.ml index f5e8be31e0..ef61a8202d 100644 --- a/plugins/interface/name_to_ast.ml +++ b/plugins/interface/name_to_ast.ml @@ -26,7 +26,7 @@ open Topconstr;; of this procedure is taken from the function print_env in pretty.ml *) let convert_env = let convert_binder env (na, b, c) = - match b with + match b with | Some b -> LocalRawDef ((dummy_loc,na), extern_constr true env b) | None -> LocalRawAssum ([dummy_loc,na], default_binder_kind, extern_constr true env c) in let rec cvrec env = function @@ -34,7 +34,7 @@ let convert_env = | b::rest -> (convert_binder env b)::(cvrec (push_rel b env) rest) in cvrec (Global.env());; -(* let mib string = +(* let mib string = let sp = Nametab.sp_of_id CCI (id_of_string string) in let lobj = Lib.map_leaf (objsp_of sp) in let (cmap, _) = outMutualInductive lobj in @@ -52,10 +52,10 @@ let impl_args_to_string_by_pos = function (* This function is directly inspired by implicit_args_id in pretty.ml *) -let impl_args_to_string l = +let impl_args_to_string l = impl_args_to_string_by_pos (positions_of_implicits l) -let implicit_args_id_to_ast_list id l ast_list = +let implicit_args_id_to_ast_list id l ast_list = (match impl_args_to_string l with None -> ast_list | Some(s) -> CommentString s:: @@ -67,7 +67,7 @@ let implicit_args_id_to_ast_list id l ast_list = implicit_args_msg in pretty.ml. *) let implicit_args_to_ast_list sp mipv = - let implicit_args_descriptions = + let implicit_args_descriptions = let ast_list = ref [] in (Array.iteri (fun i mip -> @@ -78,7 +78,7 @@ let implicit_args_to_ast_list sp mipv = (fun j idc -> let impls = implicits_of_global (ConstructRef ((sp,i),j+1)) in - ast_list := + ast_list := implicit_args_id_to_ast_list idc impls !ast_list) mip.mind_consnames)) mipv; @@ -86,19 +86,19 @@ let implicit_args_to_ast_list sp mipv = match implicit_args_descriptions with [] -> [] | _ -> [VernacComments (List.rev implicit_args_descriptions)];; - + (* This function converts constructors for an inductive definition to a Coqast.t. It is obtained directly from print_constructors in pretty.ml *) let convert_constructors envpar names types = - let array_idC = - array_map2 - (fun n t -> + let array_idC = + array_map2 + (fun n t -> let coercion_flag = false (* arbitrary *) in (coercion_flag, ((dummy_loc,n), extern_constr true envpar t))) names types in Array.to_list array_idC;; - + (* this function converts one inductive type in a possibly multiple inductive definition *) @@ -124,7 +124,7 @@ let mutual_to_ast_list sp mib = VernacInductive ((if mib.mind_finite then Decl_kinds.Finite else Decl_kinds.CoFinite), false, l) :: (implicit_args_to_ast_list sp mipv);; -let constr_to_ast v = +let constr_to_ast v = extern_constr true (Global.env()) v;; let implicits_to_ast_list implicits = @@ -137,10 +137,10 @@ let make_variable_ast name typ implicits = ((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), + VernacDefinition ((Global,false,Definition), (dummy_loc,name), DefineBody ([], None, constr_to_ast c, Some (constr_to_ast typ)), (fun _ _ -> ())) ::(implicits_to_ast_list implicits);; @@ -152,7 +152,7 @@ let constant_to_ast_list kn = let typ = Typeops.type_of_constant_type (Global.env()) cb.const_type in let l = implicits_of_global (ConstRef kn) in (match c with - None -> + None -> make_variable_ast (id_of_label (con_label kn)) typ l | Some c1 -> make_definition_ast (id_of_label (con_label kn)) (Declarations.force c1) typ l) @@ -161,7 +161,7 @@ let variable_to_ast_list sp = let (id, c, v) = Global.lookup_named sp in let l = implicits_of_global (VarRef sp) in (match c with - None -> + None -> make_variable_ast id v l | Some c1 -> make_definition_ast id c1 v l);; @@ -180,8 +180,8 @@ let leaf_entry_to_ast_list ((sp,kn),lobj) = | "VARIABLE" -> variable_to_ast_list (basename sp) | "CONSTANT" -> constant_to_ast_list (constant_of_kn kn) | "INDUCTIVE" -> inductive_to_ast_list kn - | s -> - errorlabstrm + | s -> + errorlabstrm "print" (str ("printing of unrecognized object " ^ s ^ " has been required"));; @@ -191,18 +191,18 @@ let leaf_entry_to_ast_list ((sp,kn),lobj) = (* this function is inspired by print_name *) let name_to_ast ref = let (loc,qid) = qualid_of_reference ref in - let l = - try + let l = + try match Nametab.locate qid with | ConstRef sp -> constant_to_ast_list sp | IndRef (sp,_) -> inductive_to_ast_list sp | ConstructRef ((sp,_),_) -> inductive_to_ast_list sp | VarRef sp -> variable_to_ast_list sp - with Not_found -> + with Not_found -> try (* Var locale de but, pas var de section... donc pas d'implicits *) - let dir,name = repr_qualid qid in + let dir,name = repr_qualid qid in if (repr_dirpath dir) <> [] then raise Not_found; - let (_,c,typ) = Global.lookup_named name in + let (_,c,typ) = Global.lookup_named name in (match c with None -> make_variable_ast name typ [] | Some c1 -> make_definition_ast name c1 typ []) diff --git a/plugins/interface/paths.ml b/plugins/interface/paths.ml index a157ca9254..dcccc39e83 100644 --- a/plugins/interface/paths.ml +++ b/plugins/interface/paths.ml @@ -1,5 +1,5 @@ let int_list_to_string s l = - List.fold_left + List.fold_left (fun s -> (fun v -> s ^ " " ^ (string_of_int v))) s l;; diff --git a/plugins/interface/pbp.ml b/plugins/interface/pbp.ml index 663e4ce925..b4dfe8a769 100644 --- a/plugins/interface/pbp.ml +++ b/plugins/interface/pbp.ml @@ -33,8 +33,8 @@ let next_global_ident = next_global_ident_away true let get_hyp_by_name g name = let evd = project g in let env = pf_env g in - try (let judgment = - Pretyping.Default.understand_judgment + try (let judgment = + Pretyping.Default.understand_judgment evd env (RVar(zz, name)) in ("hyp",judgment.uj_type)) (* je sais, c'est pas beau, mais je ne sais pas trop me servir de look_up... @@ -132,7 +132,7 @@ let (imply_intro2: pbp_rule) = function (f (h'::avoid) clear_names clear_flag None (kind_of_term body) path)) | _ -> None;; - + (* let (imply_intro1: pbp_rule) = function avoid, clear_names, @@ -140,7 +140,7 @@ let (imply_intro1: pbp_rule) = function let h' = next_global_ident hyp_radix avoid in let str_h' = h' in Some(chain_tactics [make_named_intro str_h'] - (f (h'::avoid) clear_names clear_flag (Some str_h') + (f (h'::avoid) clear_names clear_flag (Some str_h') (kind_of_term prem) path)) | _ -> None;; *) @@ -162,7 +162,7 @@ let make_pbp_atomic_tactic = function | PbpTryAssumption None -> TacTry (TacAtom (zz, TacAssumption)) | PbpTryAssumption (Some a) -> TacTry (TacAtom (zz, TacExact (make_var a))) - | PbpExists x -> + | PbpExists x -> TacAtom (zz, TacSplit (false,true,[ImplicitBindings [make_pbp_pattern x]])) | PbpGeneralize (h,args) -> let l = List.map make_pbp_pattern args in @@ -176,7 +176,7 @@ let make_pbp_atomic_tactic = function let bind = List.map (fun s ->(zz,NamedHyp s,make_pbp_pattern s)) names in TacAtom (zz, TacElim (false,(make_var hyp_name,ExplicitBindings bind),None)) - | PbpTryClear l -> + | PbpTryClear l -> TacTry (TacAtom (zz, TacClear (false,List.map (fun s -> AI (zz,s)) l))) | PbpSplit -> TacAtom (zz, TacSplit (false,false,[NoBindings]));; @@ -188,7 +188,7 @@ let rec make_pbp_tactic = function List.map make_pbp_tactic tl) let (forall_elim: pbp_rule) = function - avoid, clear_names, clear_flag, + avoid, clear_names, clear_flag, Some h, Prod(Name x, _, body), 2::path, f -> let h' = next_global_ident hyp_radix avoid in let clear_names' = if clear_flag then h::clear_names else clear_names in @@ -219,7 +219,7 @@ let (imply_elim2: pbp_rule) = function Some(PbpThens ([PbpLApply h], [chain_tactics [make_named_intro h'] - (f (h'::avoid) clear_names' false (Some h') + (f (h'::avoid) clear_names' false (Some h') (kind_of_term body) path); make_clears clear_names])) | _ -> None;; @@ -241,8 +241,8 @@ let notTconstr () = constant ["Logic_Type"] "notT";; let is_matching_local a b = is_matching (pattern_of_constr a) b;; -let rec (or_and_tree_to_intro_pattern: identifier list -> - constr -> int list -> +let rec (or_and_tree_to_intro_pattern: identifier list -> + constr -> int list -> intro_pattern_expr * identifier list * identifier *constr * int list * int * int) = fun avoid c path -> match kind_of_term c, path with @@ -251,19 +251,19 @@ fun avoid c path -> match kind_of_term c, path with (is_matching_local (prodconstr()) oper)) & (a = 1 or a = 2) -> let id2 = next_global_ident hyp_radix avoid in let cont_expr = if a = 1 then c1 else c2 in - let cont_patt, avoid_names, id, c, path, rank, total_branches = + let cont_patt, avoid_names, id, c, path, rank, total_branches = or_and_tree_to_intro_pattern (id2::avoid) cont_expr path in - let patt_list = + let patt_list = if a = 1 then [zz,cont_patt; zz,IntroIdentifier id2] else [zz,IntroIdentifier id2; zz,cont_patt] in - (IntroOrAndPattern[patt_list], avoid_names, id, c, path, rank, + (IntroOrAndPattern[patt_list], avoid_names, id, c, path, rank, total_branches) | (App(oper, [|c1; c2|]), 2::3::path) when ((is_matching_local (exconstr()) oper) or (is_matching_local (sigconstr()) oper)) -> - (match (kind_of_term c2) with + (match (kind_of_term c2) with Lambda (Name x, _, body) -> let id1 = next_global_ident x avoid in let cont_patt, avoid_names, id, c, path, rank, total_branches = @@ -285,13 +285,13 @@ fun avoid c path -> match kind_of_term c, path with [[zz,cont_patt];[zz,IntroIdentifier id2]] else [[zz,IntroIdentifier id2];[zz,cont_patt]] in - (IntroOrAndPattern patt_list, + (IntroOrAndPattern patt_list, avoid_names, id, c, path, new_rank, total_branches+1) | (_, path) -> let id = next_global_ident hyp_radix avoid in (IntroIdentifier id, (id::avoid), id, c, path, 1, 1);; let auxiliary_goals clear_names clear_flag this_name n_aux others = - let clear_cmd = + let clear_cmd = make_clears (if clear_flag then (this_name ::clear_names) else clear_names) in let rec clear_list = function 0 -> others @@ -316,25 +316,25 @@ let (imply_intro3: pbp_rule) = function (rank - 1) ((f avoid_names clear_names clear_flag (Some id) (kind_of_term c) path):: - auxiliary_goals clear_names clear_flag id + auxiliary_goals clear_names clear_flag id (total_branches - rank) []))) | _ -> None;; - + let (and_intro: pbp_rule) = function avoid, clear_names, clear_flag, - None, App(and_oper, [|c1; c2|]), 2::a::path, f + None, App(and_oper, [|c1; c2|]), 2::a::path, f -> if ((is_matching_local (andconstr()) and_oper) or (is_matching_local (prodconstr ()) and_oper)) & (a = 1 or a = 2) then let cont_term = if a = 1 then c1 else c2 in - let cont_cmd = f avoid clear_names false None + let cont_cmd = f avoid clear_names false None (kind_of_term cont_term) path in let clear_cmd = make_clears clear_names in let cmds = - (if a = 1 - then [cont_cmd;clear_cmd] + (if a = 1 + then [cont_cmd;clear_cmd] else [clear_cmd;cont_cmd]) in Some (PbpThens ([PbpSplit],cmds)) else None @@ -342,7 +342,7 @@ let (and_intro: pbp_rule) = function let exists_from_lambda avoid clear_names clear_flag c2 path f = match kind_of_term c2 with - Lambda(Name x, _, body) -> + Lambda(Name x, _, body) -> Some (PbpThens ([PbpExists x], [f avoid clear_names false None (kind_of_term body) path])) | _ -> None;; @@ -367,28 +367,28 @@ let (or_intro: pbp_rule) = function avoid, clear_names, clear_flag, None, App(or_oper, [|c1; c2 |]), 2::a::path, f -> if ((is_matching_local (orconstr ()) or_oper) or - (is_matching_local (sumboolconstr ()) or_oper) or + (is_matching_local (sumboolconstr ()) or_oper) or (is_matching_local (sumconstr ()) or_oper)) & (a = 1 or a = 2) then let cont_term = if a = 1 then c1 else c2 in let fst_cmd = if a = 1 then PbpLeft else PbpRight in - let cont_cmd = f avoid clear_names false None + let cont_cmd = f avoid clear_names false None (kind_of_term cont_term) path in Some(chain_tactics [fst_cmd] cont_cmd) else None | _ -> None;; - + let dummy_id = id_of_string "Dummy";; let (not_intro: pbp_rule) = function avoid, clear_names, clear_flag, None, App(not_oper, [|c1|]), 2::1::path, f -> - if(is_matching_local (notconstr ()) not_oper) or + if(is_matching_local (notconstr ()) not_oper) or (is_matching_local (notTconstr ()) not_oper) then let h' = next_global_ident hyp_radix avoid in Some(chain_tactics [make_named_intro h'] - (f (h'::avoid) clear_names false (Some h') + (f (h'::avoid) clear_names false (Some h') (kind_of_term c1) path)) else None @@ -407,7 +407,7 @@ let elim_with_bindings hyp_name names = crossed. Result is: - a list of string indicating the names of universally quantified variables. - - a list of integers indicating the positions of the successive + - a list of integers indicating the positions of the successive universally quantified variables. - an integer indicating the number of non-dependent products. - the last constr object encountered during the walk down, and @@ -421,16 +421,16 @@ let elim_with_bindings hyp_name names = *) -let rec down_prods: (types, constr) kind_of_term * (int list) * int -> +let rec down_prods: (types, constr) kind_of_term * (int list) * int -> identifier list * (int list) * int * (types, constr) kind_of_term * - (int list) = + (int list) = function Prod(Name x, _, body), 2::path, k -> - let res_sl, res_il, res_i, res_cstr, res_p + let res_sl, res_il, res_i, res_cstr, res_p = down_prods (kind_of_term body, path, k+1) in x::res_sl, (k::res_il), res_i, res_cstr, res_p | Prod(Anonymous, _, body), 2::path, k -> - let res_sl, res_il, res_i, res_cstr, res_p + let res_sl, res_il, res_i, res_cstr, res_p = down_prods (kind_of_term body, path, k+1) in res_sl, res_il, res_i+1, res_cstr, res_p | cstr, path, _ -> [], [], 0, cstr, path;; @@ -444,7 +444,7 @@ exception Pbp_internal of int list;; The knowledge I have on constr structures is incomplete. *) -let (check_apply: (types, constr) kind_of_term -> (int list) -> bool) = +let (check_apply: (types, constr) kind_of_term -> (int list) -> bool) = function c -> function l -> let rec delete n = function | [] -> [] @@ -464,7 +464,7 @@ let (check_apply: (types, constr) kind_of_term -> (int list) -> bool) = else result | _ -> raise (Pbp_internal l) in - try + try (check_rec l c) = [] with Pbp_internal l -> l = [];; @@ -475,12 +475,12 @@ let (mk_db_indices: int list -> int -> int list) = [] -> [] | a::l -> (total - a)::(mk_db_aux l) in mk_db_aux int_list;; - + (* This proof-by-pointing rule is quite complicated, as it attempts to foresee usages of head tactics. A first operation is to follow the path as far as possible while staying on the spine of products (function down_prods) - and then to check whether the next step will be an elim step. If the + and then to check whether the next step will be an elim step. If the answer is true, then the built command takes advantage of the power of head tactics. *) @@ -497,37 +497,37 @@ let (head_tactic_patt: pbp_rule) = function let x' = next_global_ident x avoid in let cont_body = Prod(Name x', c1, - mkProd(Anonymous, body, + mkProd(Anonymous, body, mkVar(dummy_id))) in - let cont_tac + let cont_tac = f avoid (h::clear_names) false None cont_body (2::1::path) in cont_tac::(auxiliary_goals clear_names clear_flag h nprems []))) | _ -> None) - | (str_list, _, nprems, - App(oper,[|c1|]), 2::1::path) + | (str_list, _, nprems, + App(oper,[|c1|]), 2::1::path) when (is_matching_local (notconstr ()) oper) or (is_matching_local (notTconstr ()) oper) -> Some(chain_tactics [elim_with_bindings h str_list] (f avoid clear_names false None (kind_of_term c1) path)) - | (str_list, _, nprems, - App(oper, [|c1; c2|]), 2::a::path) + | (str_list, _, nprems, + App(oper, [|c1; c2|]), 2::a::path) when ((is_matching_local (andconstr()) oper) or (is_matching_local (prodconstr()) oper)) & (a = 1 or a = 2) -> let h1 = next_global_ident hyp_radix avoid in let h2 = next_global_ident hyp_radix (h1::avoid) in Some(PbpThens ([elim_with_bindings h str_list], - let cont_body = + let cont_body = if a = 1 then c1 else c2 in - let cont_tac = - f (h2::h1::avoid) (h::clear_names) + let cont_tac = + f (h2::h1::avoid) (h::clear_names) false (Some (if 1 = a then h1 else h2)) (kind_of_term cont_body) path in - (chain_tactics + (chain_tactics [make_named_intro h1; make_named_intro h2] cont_tac):: (auxiliary_goals clear_names clear_flag h nprems []))) @@ -540,9 +540,9 @@ let (head_tactic_patt: pbp_rule) = function let x' = next_global_ident x avoid in let cont_body = Prod(Name x', c1, - mkProd(Anonymous, body, + mkProd(Anonymous, body, mkVar(dummy_id))) in - let cont_tac + let cont_tac = f avoid (h::clear_names) false None cont_body (2::1::path) in cont_tac::(auxiliary_goals @@ -561,26 +561,26 @@ let (head_tactic_patt: pbp_rule) = function (* h' is the name for the new intro *) let h' = next_global_ident hyp_radix avoid in let cont_tac = - chain_tactics + chain_tactics [make_named_intro h'] - (f + (f (* h' should not be used again *) (h'::avoid) (* the disjunct itself can be discarded *) (h::clear_names) false (Some h') (kind_of_term cont_body) path) in - let snd_tac = + let snd_tac = chain_tactics [make_named_intro h'] (make_clears (h::clear_names)) in - let tacs1 = + let tacs1 = if a = 1 then [cont_tac; snd_tac] else [snd_tac; cont_tac] in tacs1@(auxiliary_goals (h::clear_names) false dummy_id nprems []))) - | (str_list, int_list, nprems, c, []) + | (str_list, int_list, nprems, c, []) when (check_apply c (mk_db_indices int_list nprems)) & (match c with Prod(_,_,_) -> false | _ -> true) & @@ -588,7 +588,7 @@ let (head_tactic_patt: pbp_rule) = function Some(add_clear_names_if_necessary (PbpThen [PbpApply h]) clear_names) | _ -> None) | _ -> None;; - + let pbp_rules = ref [rem_cast;head_tactic_patt;forall_intro;imply_intro2; forall_elim; imply_intro3; imply_elim1; imply_elim2; @@ -622,7 +622,7 @@ let default_ast optname constr path = PbpThen [PbpTryAssumption optname] let rec pbpt final_cmd avoid clear_names clear_flag opt_name constr path = let rec try_all_rules rl = - match rl with + match rl with f::tl -> (match f (avoid, clear_names, clear_flag, opt_name, constr, path, pbpt final_cmd) with @@ -674,7 +674,7 @@ let rec optim3_aux str_list = function (match cleanup_clears str_list names with [] -> other | l -> (PbpTryClear l)::other) - | a::l -> a::(optim3_aux str_list l) + | a::l -> a::(optim3_aux str_list l) | [] -> [];; let rec optim3 str_list = function @@ -694,8 +694,8 @@ let rec tactic_args_to_ints = function | _ -> failwith "expecting only numbers";; (* -let pbp_tac display_function = function - (Identifier a)::l -> +let pbp_tac display_function = function + (Identifier a)::l -> (function g -> let str = (string_of_id a) in let (ou,tstr) = (get_hyp_by_name g str) in @@ -711,7 +711,7 @@ let pbp_tac display_function = function (tactic_args_to_ints l) in (display_function (optim exp_ast); tclIDTAC g)) - | ((Integer n)::_) as l -> + | ((Integer n)::_) as l -> (function g -> let exp_ast = (pbpt default_ast (pf_ids_of_hyps g) [] false diff --git a/plugins/interface/showproof.ml b/plugins/interface/showproof.ml index aa11609ae7..8eeeee34aa 100644 --- a/plugins/interface/showproof.ml +++ b/plugins/interface/showproof.ml @@ -32,7 +32,7 @@ open Genarg (*****************************************************************************) (* Arbre de preuve maison: - + *) (* hypotheses *) @@ -92,9 +92,9 @@ let tactic t = ;; -(* +(* un arbre est clos s'il ne contient pas de sous-but non prouves, -ou bien s'il a un cousin gauche qui n'est pas clos +ou bien s'il a un cousin gauche qui n'est pas clos ce qui fait qu'on a au plus un sous-but non clos, le premier sous-but. *) let update_closed nt = @@ -117,8 +117,8 @@ let update_closed nt = t_proof=Proof(tac,lt1)}) in update nt ;; - - + + (* type complet avec les hypotheses. *) @@ -138,7 +138,7 @@ let long_type_hyp lh t= let seq_to_lnhyp sign sign' cl = let lh= ref (List.map (fun (x,c,t) -> (Name x, t)) sign) in - let nh=List.map (fun (id,c,ty) -> + let nh=List.map (fun (id,c,ty) -> {hyp_name=id; hyp_type=ty; hyp_full_type= @@ -156,7 +156,7 @@ let seq_to_lnhyp sign sign' cl = let rule_is_complex r = match r with - Nested (Tactic + Nested (Tactic ((TacArg (Tacexp _) |TacAtom (_,(TacAuto _|TacSymmetry _))),_),_) -> true |_ -> false @@ -219,10 +219,10 @@ let to_nproof sigma osign pf = let rec to_nproof_rec sigma osign pf = let {evar_hyps=sign;evar_concl=cl} = pf.goal in let sign = Environ.named_context_of_val sign in - let nsign = new_sign osign sign in - let oldsign = old_sign osign sign in + let nsign = new_sign osign sign in + let oldsign = old_sign osign sign in match pf.ref with - + None -> {t_info="to_prove"; t_goal=(seq_to_lnhyp oldsign nsign cl); t_proof=Notproved} @@ -230,7 +230,7 @@ let to_nproof sigma osign pf = if rule_is_complex r then ( let p1= to_nproof_rec sigma sign (subproof_of_proof pf) in - let ntree= fill_unproved p1 + let ntree= fill_unproved p1 (List.map (fun x -> (to_nproof_rec sigma sign x).t_proof) spfl) in (match r with @@ -253,7 +253,7 @@ let to_nproof sigma osign pf = in update_closed (to_nproof_rec sigma osign pf) ;; -(* +(* recupere l'arbre de preuve courant. *) @@ -262,7 +262,7 @@ let get_nproof () = (Tacmach.proof_of_pftreestate (get_pftreestate())) ;; - + (*****************************************************************************) (* Pprinter @@ -273,14 +273,14 @@ let pr_void () = sphs "";; let list_rem l = match l with [] -> [] |x::l1->l1;; (* liste de chaines *) -let prls l = +let prls l = let res = ref (sps (List.hd l)) in - List.iter (fun s -> + List.iter (fun s -> res:= sphv [ !res; spb; sps s]) (list_rem l); !res ;; -let prphrases f l = +let prphrases f l = spv (List.map (fun s -> sphv [f s; sps ","]) l) ;; @@ -288,13 +288,13 @@ let prphrases f l = let spi = spnb 3;; (* en colonne *) -let prl f l = +let prl f l = if l=[] then spe else spv (List.map f l);; (*en colonne, avec indentation *) -let prli f l = +let prli f l = if l=[] then spe else sph [spi; spv (List.map f l)];; -(* +(* Langues. *) @@ -377,9 +377,9 @@ let enumerate f ln = match ln with [] -> [] | [x] -> [f x] - |ln -> - let rec enum_rec f ln = - (match ln with + |ln -> + let rec enum_rec f ln = + (match ln with [x;y] -> [f x; spb; sph [_et ();spb;f y]] |x::l -> [sph [(f x);sps ","];spb]@(enum_rec f l) | _ -> assert false) @@ -506,28 +506,28 @@ let reste_a_montrer g = match !natural_language with spb; spt g; sps ". "] | English -> sph[ (prls ["It remains";"to"; rand ["prove";"show"]]); - spb; spt g; sps ". "] + spb; spt g; sps ". "] ;; let discutons_avec_A type_arg = match !natural_language with French -> sphv [sps "Discutons"; spb; sps "avec"; spb; - spt type_arg; sps ":"] + spt type_arg; sps ":"] | English -> sphv [sps "Let us discuss"; spb; sps "with"; spb; - spt type_arg; sps ":"] + spt type_arg; sps ":"] ;; let utilisons_A arg1 = match !natural_language with French -> sphv [sps (rand ["Utilisons";"Avec";"A l'aide de"]); - spb; spt arg1; sps ":"] + spb; spt arg1; sps ":"] | English -> sphv [sps (rand ["Let us use";"With";"With the help of"]); - spb; spt arg1; sps ":"] + spb; spt arg1; sps ":"] ;; let selon_les_valeurs_de_A arg1 = match !natural_language with French -> sphv [ (prls ["Selon";"les";"valeurs";"de"]); - spb; spt arg1; sps ":"] + spb; spt arg1; sps ":"] | English -> sphv [ (prls ["According";"values";"of"]); - spb; spt arg1; sps ":"] + spb; spt arg1; sps ":"] ;; let de_A_on_a arg1 = match !natural_language with @@ -547,9 +547,9 @@ let procedons_par_recurrence_sur_A arg1 = match !natural_language with ;; -let calculons_la_fonction_F_de_type_T_par_recurrence_sur_son_argument_A +let calculons_la_fonction_F_de_type_T_par_recurrence_sur_son_argument_A nfun tfun narg = match !natural_language with - French -> sphv [ + French -> sphv [ sphv [ prls ["Calculons";"la";"fonction"]; spb; sps (string_of_id nfun);spb; prls ["de";"type"]; @@ -557,7 +557,7 @@ let calculons_la_fonction_F_de_type_T_par_recurrence_sur_son_argument_A prls ["par";"récurrence";"sur";"son";"argument"]; spb; sps (string_of_int narg); sps ":"] ] -| English -> sphv [ +| English -> sphv [ sphv [ prls ["Let us compute";"the";"function"]; spb; sps (string_of_id nfun);spb; prls ["of";"type"]; @@ -594,7 +594,7 @@ let coq_le_demontre_seul () = match !natural_language with sps "Fastoche."; sps "Trop cool"] | English -> rand [prls ["Coq";"shows";"it"; "alone."]; - sps "Fingers in the nose."] + sps "Fingers in the nose."] ;; let de_A_on_deduit_donc_B arg g = match !natural_language with @@ -608,31 +608,31 @@ let de_A_on_deduit_donc_B arg g = match !natural_language with let _A_est_immediat_par_B g arg = match !natural_language with French -> sph [ spt g; spb; (prls ["est";"immédiat";"par"]); - spb; spt arg ] + spb; spt arg ] | English -> sph [ spt g; spb; (prls ["is";"immediate";"from"]); - spb; spt arg ] + spb; spt arg ] ;; let le_resultat_est arg = match !natural_language with French -> sph [ (prls ["le";"résultat";"est"]); - spb; spt arg ] + spb; spt arg ] | English -> sph [ (prls ["the";"result";"is"]); spb; spt arg ];; let on_applique_la_tactique tactic tac = match !natural_language with - French -> sphv + French -> sphv [ sps "on applique";spb;sps "la tactique"; spb;tactic;spb;tac] -| English -> sphv +| English -> sphv [ sps "we apply";spb;sps "the tactic"; spb;tactic;spb;tac] ;; let de_A_il_vient_B arg g = match !natural_language with French -> sph - [ sps "De"; spb; spt arg; spb; - sps "il";spb; sps "vient";spb; spt g; sps ". " ] + [ sps "De"; spb; spt arg; spb; + sps "il";spb; sps "vient";spb; spt g; sps ". " ] | English -> sph - [ sps "From"; spb; spt arg; spb; - sps "it";spb; sps "comes";spb; spt g; sps ". " ] + [ sps "From"; spb; spt arg; spb; + sps "it";spb; sps "comes";spb; spt g; sps ". " ] ;; let ce_qui_est_trivial () = match !natural_language with @@ -690,12 +690,12 @@ type n_sort= | Nfunction ;; - + let sort_of_type t ts = let t=(strip_outer_cast t) in if is_Prop t then Nprop - else + else match ts with Prop(Null) -> Nformula |_ -> (match (kind_of_term t) with @@ -704,11 +704,11 @@ let sort_of_type t ts = ;; let adrel (x,t) e = - match x with + match x with Name(xid) -> Environ.push_rel (x,None,t) e | Anonymous -> Environ.push_rel (x,None,t) e -let rec nsortrec vl x = +let rec nsortrec vl x = match (kind_of_term x) with Prod(n,t,c)-> let vl = (adrel (n,t) vl) in nsortrec vl c @@ -722,7 +722,7 @@ let rec nsortrec vl x = new_sort_in_family (inductive_sort_family mip) | Construct(c) -> nsortrec vl (mkInd (inductive_of_constructor c)) - | Case(_,x,t,a) + | Case(_,x,t,a) -> nsortrec vl x | Cast(x,_, t)-> nsortrec vl t | Const c -> nsortrec vl (Typeops.type_of_constant vl c) @@ -732,7 +732,7 @@ let nsort x = nsortrec (Global.env()) (strip_outer_cast x) ;; -let sort_of_hyp h = +let sort_of_hyp h = (sort_of_type h.hyp_type (nsort h.hyp_full_type)) ;; @@ -744,14 +744,14 @@ let rec group_lhyp lh = |[h] -> [[h]] |h::lh -> match group_lhyp lh with - (h1::lh1)::lh2 -> + (h1::lh1)::lh2 -> if h.hyp_type=h1.hyp_type || ((sort_of_hyp h)=(sort_of_hyp h1) && (sort_of_hyp h1)=Nformula) then (h::(h1::lh1))::lh2 else [h]::((h1::lh1)::lh2) |_-> assert false ;; - + (* ln noms des hypotheses, lt leurs types *) let natural_ghyp (sort,ln,lt) intro = let t=List.hd lt in @@ -761,13 +761,13 @@ let natural_ghyp (sort,ln,lt) intro = Nprop -> soit_A_une_proposition nh ln t | Ntype -> soit_X_un_element_de_T nh ln t | Nfunction -> soit_F_une_fonction_de_type_T nh ln t - | Nformula -> + | Nformula -> sphv ((sps intro)::(enumerate (fun (n,t) -> tag_hypt n t) (List.combine ln lt))) ;; (* Cas d'une hypothese *) -let natural_hyp h = +let natural_hyp h = let ns= string_of_id h.hyp_name in let t=h.hyp_type in let ts= (nsort h.hyp_full_type) in @@ -782,18 +782,18 @@ let rec pr_ghyp lh intro= Nformula -> [natural_ghyp(sort,ln,t) intro; sps ". "] | _ -> [natural_ghyp(sort,ln,t) ""; sps ". "]) | (sort,ln,t)::lh -> - let hp= + let hp= ([natural_ghyp(sort,ln,t) intro] @(match lh with [] -> [sps ". "] |(sort1,ln1,t1)::lh1 -> match sort1 with - Nformula -> + Nformula -> (let nh=List.length ln in match sort with - Nprop -> telle_que nh - |Nfunction -> telle_que nh - |Ntype -> tel_que nh + Nprop -> telle_que nh + |Nfunction -> telle_que nh + |Ntype -> tel_que nh |Nformula -> [sps ". "]) | _ -> [sps ". "])) in (sphv hp)::(pr_ghyp lh "") @@ -860,7 +860,7 @@ let par_hypothese_de_recurrence () = match !natural_language with let natural_lhyp lh hi = match hi with - All_subgoals_hyp -> + All_subgoals_hyp -> ( match lh with [] -> spe |_-> prnatural_ghyp (group_lhyp lh) (supposons ())) @@ -896,21 +896,21 @@ let natural_lhyp lh hi = for i=1 to nlhci do let targ=(List.nth lhci (i-1))in let nh=(List.nth lh (i-1)) in - if targ="arg" || targ="argrec" + if targ="arg" || targ="argrec" then (s:=(!s)^" "^(string_of_id nh.hyp_name); lh0:=(!lh0)@[nh]) else lh1:=(!lh1)@[nh]; done; let introhyprec= - (if (!lh1)=[] then spe + (if (!lh1)=[] then spe else par_hypothese_de_recurrence () ) - in + in if a>0 then s:="("^(!s)^")"; spv [sphv [(if ncase>1 then sph[ sps ("-"^(cas ()));spb] else spe); - sps !s; sps ":"]; + sps !s; sps ":"]; prnatural_ghyp (group_lhyp !lh0) (supposons ()); introhyprec; prl (natural_hyp) !lh1] @@ -958,7 +958,7 @@ let rec show_goal lh ig g gs = "intros" -> if lh = [] then spe - else show_goal lh "standard" g gs + else show_goal lh "standard" g gs |"standard" -> (match (sort_of_type g gs) with Nprop -> donnons_une_proposition () @@ -967,7 +967,7 @@ let rec show_goal lh ig g gs = | Nfunction ->calculons_une_fonction_de_type g) | "apply" -> show_goal lh "" g gs | "simpl" ->en_simplifiant_on_obtient g - | "rewrite" -> on_obtient g + | "rewrite" -> on_obtient g | "equality" -> reste_a_montrer g | "trivial_equality" -> reste_a_montrer g | "" -> spe @@ -1002,14 +1002,14 @@ let first_name_hyp_of_ntree {t_goal={newhyp=lh}}= ;; let rec find_type x t= - match (kind_of_term (strip_outer_cast t)) with + match (kind_of_term (strip_outer_cast t)) with Prod(y,ty,t) -> (match y with - Name y -> + Name y -> if x=(string_of_id y) then ty else find_type x t | _ -> find_type x t) - |_-> assert false + |_-> assert false ;; (*********************************************************************** @@ -1061,7 +1061,7 @@ let is_equality_tac = function let equalities_ntree ig ntree = let rec equalities_ntree ig ntree = - if not (is_equality (concl ntree)) + if not (is_equality (concl ntree)) then [] else match (proof ntree) with @@ -1075,8 +1075,8 @@ let equalities_ntree ig ntree = then res else (ig,ntree)::res) else [(ig,ntree)] - in - equalities_ntree ig ntree + in + equalities_ntree ig ntree ;; let remove_seq_of_terms l = @@ -1091,7 +1091,7 @@ let remove_seq_of_terms l = let list_to_eq l o= let switch = fun h h' -> (if o then h else h') in match l with - [a] -> spt (fst a) + [a] -> spt (fst a) | (a,h)::(b,h')::l -> let rec list_to_eq h l = match l with @@ -1100,7 +1100,7 @@ let list_to_eq l o= (sph [sps "="; spb; spt b; spb;tag_uselemma (switch h h') spe]) :: (list_to_eq (switch h' h) l) in sph [spt a; spb; - spv ((sph [sps "="; spb; spt b; spb; + spv ((sph [sps "="; spb; spt b; spb; tag_uselemma (switch h h') spe]) ::(list_to_eq (switch h' h) l))] | _ -> assert false @@ -1131,7 +1131,7 @@ let rec natural_ntree ig ntree = [] ->spe | [_] -> spe | _::l -> sphv[sps ": "; - prli (natural_ntree + prli (natural_ntree {ihsg=All_subgoals_hyp; isgintro="standard"}) l])]) @@ -1157,7 +1157,7 @@ let rec natural_ntree ig ntree = spv [(natural_lhyp lh ig.ihsg); (show_goal2 lh ig g (nsort gf) ""); sph !ltext; - + natural_ntree {ihsg=All_subgoals_hyp; isgintro= let (t1,t2)= terms_of_equality (concl ntree) in @@ -1171,13 +1171,13 @@ let rec natural_ntree ig ntree = let gs=nsort gf in match p with Notproved -> spv [ (natural_lhyp lh ig.ihsg); - sph [spi; sps (intro_not_proved_goal gs); spb; + sph [spi; sps (intro_not_proved_goal gs); spb; tag_toprove g ] ] | Proof (TacId _,ltree) -> natural_ntree ig (List.hd ltree) - | Proof (TacAtom (_,tac),ltree) -> - (let ntext = + | Proof (TacAtom (_,tac),ltree) -> + (let ntext = match tac with (* Pas besoin de l'argument éventuel de la tactique *) TacIntroPattern _ -> natural_intros ig lh g gs ltree @@ -1197,9 +1197,9 @@ let rec natural_ntree ig ntree = | TacAssumption -> natural_trivial ig lh g gs ltree | TacClear _ -> natural_clear ig lh g gs ltree (* Besoin de l'argument de la tactique *) - | TacSimpleInductionDestruct (true,NamedHyp id) -> + | TacSimpleInductionDestruct (true,NamedHyp id) -> natural_induction ig lh g gs ge id ltree false - | TacExtend (_,"InductionIntro",[a]) -> + | TacExtend (_,"InductionIntro",[a]) -> let id=(out_gen wit_ident a) in natural_induction ig lh g gs ge id ltree true | TacApply (_,false,[c,_],None) -> @@ -1232,7 +1232,7 @@ let rec natural_ntree ig ntree = ntext (* spwithtac ntext tactic*) ) | Proof _ -> failwith "Don't know what to do with that" - in + in if info<>"not_proved" then spshrink info ntext else ntext @@ -1241,7 +1241,7 @@ and natural_generic ig lh g gs tactic tac ltree = [ (natural_lhyp lh ig.ihsg); (show_goal2 lh ig g gs ""); on_applique_la_tactique tactic tac ; - (prli(natural_ntree + (prli(natural_ntree {ihsg=All_subgoals_hyp; isgintro="standard"}) ltree) @@ -1258,7 +1258,7 @@ and natural_intros ig lh g gs ltree = spv [ (natural_lhyp lh ig.ihsg); (show_goal2 lh ig g gs ""); - (prl (natural_ntree + (prl (natural_ntree {ihsg=All_subgoals_hyp; isgintro="intros"}) ltree) @@ -1269,7 +1269,7 @@ and natural_apply ig lh g gs arg ltree = [] -> spv [ (natural_lhyp lh ig.ihsg); - de_A_il_vient_B arg g + de_A_il_vient_B arg g ] | [sg]-> spv @@ -1280,10 +1280,10 @@ and natural_apply ig lh g gs arg ltree = else ""} g gs ""); grace_a_A_il_suffit_de_montrer_LA arg [spt sg]; - sph [spi ; natural_ntree + sph [spi ; natural_ntree {ihsg=All_subgoals_hyp; isgintro="apply"} (List.hd ltree)] - ] + ] | _ -> let ln = List.map (fun _ -> new_name()) lg in spv @@ -1298,7 +1298,7 @@ and natural_apply ig lh g gs arg ltree = lg ln); sph [spi; spv (List.map2 (fun x n -> sph [sps ("("^n^"):"); spb; - natural_ntree + natural_ntree {ihsg=All_subgoals_hyp; isgintro="apply"} x]) ltree ln)] @@ -1310,26 +1310,26 @@ and natural_rem_goals ltree = | [sg]-> spv [ reste_a_montrer_LA [spt sg]; - sph [spi ; natural_ntree + sph [spi ; natural_ntree {ihsg=All_subgoals_hyp; isgintro="apply"} (List.hd ltree)] - ] + ] | _ -> let ln = List.map (fun _ -> new_name()) lg in spv - [ reste_a_montrer_LA + [ reste_a_montrer_LA (List.map2 (fun g n -> sph [sps ("("^n^")"); spb; spt g]) lg ln); sph [spi; spv (List.map2 (fun x n -> sph [sps ("("^n^"):"); spb; - natural_ntree + natural_ntree {ihsg=All_subgoals_hyp; isgintro="apply"} x]) ltree ln)] ] and natural_exact ig lh g gs arg ltree = spv - [ + [ (natural_lhyp lh ig.ihsg); (let {ihsg=pi;isgintro=ig}= ig in (show_goal2 lh {ihsg=pi;isgintro=""} @@ -1343,7 +1343,7 @@ and natural_cut ig lh g gs arg ltree = spv [ (natural_lhyp lh ig.ihsg); (show_goal2 lh ig g gs ""); - (prli(natural_ntree + (prli(natural_ntree {ihsg=All_subgoals_hyp;isgintro="standard"}) (List.rev ltree)); de_A_on_deduit_donc_B arg g @@ -1353,18 +1353,18 @@ and natural_cutintro ig lh g gs arg ltree = [ (natural_lhyp lh ig.ihsg); (show_goal2 lh ig g gs ""); sph [spi; - (natural_ntree + (natural_ntree {ihsg=All_subgoals_hyp;isgintro=""} (List.nth ltree 1))]; sph [spi; - (natural_ntree + (natural_ntree {ihsg=No_subgoals_hyp;isgintro=""} (List.nth ltree 0))] ] and whd_betadeltaiota x = whd_betaiota Evd.empty x and type_of_ast s c = type_of (Global.env()) Evd.empty (constr_of_ast c) and prod_head t = - match (kind_of_term (strip_outer_cast t)) with + match (kind_of_term (strip_outer_cast t)) with Prod(_,_,c) -> prod_head c (* |App(f,a) -> f *) | _ -> t @@ -1386,7 +1386,7 @@ and natural_case ig lh g gs ge arg1 ltree with_intros = let type_arg= targ1 (* List.nth targ (mis_index dmi)*) in if ncti<>1 (* Zéro ou Plusieurs constructeurs *) - then ( + then ( spv [ (natural_lhyp lh ig.ihsg); (show_goal2 lh ig g gs ""); @@ -1404,7 +1404,7 @@ and natural_case ig lh g gs ge arg1 ltree with_intros = then (arity_of_constr_of_mind env indf !ci) else 0 in let ici= (!ci) in - sph[ (natural_ntree + sph[ (natural_ntree {ihsg= (match (nsort targ1) with Prop(Null) -> @@ -1420,7 +1420,7 @@ and natural_case ig lh g gs ge arg1 ltree with_intros = (nhd ltree ((List.length ltree)- ncti)))]) ] ) (* Cas d'un seul constructeur *) - else ( + else ( spv [ (natural_lhyp lh ig.ihsg); @@ -1433,7 +1433,7 @@ and natural_case ig lh g gs ge arg1 ltree with_intros = then (arity_of_constr_of_mind env indf 1) else 0 in let _ici= 1 in - sph[ (natural_ntree + sph[ (natural_ntree {ihsg= (match (nsort targ1) with Prop(Null) -> @@ -1446,7 +1446,7 @@ and natural_case ig lh g gs ge arg1 ltree with_intros = ]); (sph [spi; (natural_rem_goals (nhd ltree ((List.length ltree)- 1)))]) - ] + ] ) (* with _ ->natural_generic ig lh g gs (sps "Case") (spt arg1) ltree *) @@ -1455,7 +1455,7 @@ and natural_case ig lh g gs ge arg1 ltree with_intros = Elim *) and prod_list_var t = - match (kind_of_term (strip_outer_cast t)) with + match (kind_of_term (strip_outer_cast t)) with Prod(_,t,c) -> t::(prod_list_var c) |_ -> [] and hd_is_mind t ti = @@ -1486,7 +1486,7 @@ and mind_ind_info_hyp_constr indf c = !lr (* mind_ind_info_hyp_constr "le" 2;; -donne ["arg"; "argrec"] +donne ["arg"; "argrec"] mind_ind_info_hyp_constr "le" 1;; donne [] mind_ind_info_hyp_constr "nat" 2;; @@ -1518,7 +1518,7 @@ and natural_elim ig lh g gs ge arg1 ltree with_intros= then mind_ind_info_hyp_constr indf !ci else [] in let ici= (!ci) in - sph[ (natural_ntree + sph[ (natural_ntree {ihsg= (match (nsort targ1) with Prop(Null) -> @@ -1538,7 +1538,7 @@ and natural_elim ig lh g gs ge arg1 ltree with_intros= (*****************************************************************************) (* InductionIntro n -*) +*) and natural_induction ig lh g gs ge arg2 ltree with_intros= let env = (gLOB (g_env (List.hd ltree))) in let arg1= mkVar arg2 in @@ -1572,12 +1572,12 @@ and natural_induction ig lh g gs ge arg2 ltree with_intros= (fun treearg -> ci:=!ci+1; let nci=(constr_of_mind mip !ci) in let aci=(arity_of_constr_of_mind env indf !ci) in - let hci= + let hci= if with_intros then mind_ind_info_hyp_constr indf !ci else [] in let ici= (!ci) in - sph[ (natural_ntree + sph[ (natural_ntree {ihsg= (match (nsort targ1) with Prop(Null) -> @@ -1606,47 +1606,47 @@ and natural_fix ig lh g gs narg ltree = spv [ (natural_lhyp lh ig.ihsg); calculons_la_fonction_F_de_type_T_par_recurrence_sur_son_argument_A nfun tfun narg; - (prli(natural_ntree + (prli(natural_ntree {ihsg=All_subgoals_hyp;isgintro=""}) ltree) ] | _ -> assert false and natural_reduce ig lh g gs ge mode la ltree = match la with - {onhyps=Some[]} when la.concl_occs <> no_occurrences_expr -> + {onhyps=Some[]} when la.concl_occs <> no_occurrences_expr -> spv [ (natural_lhyp lh ig.ihsg); - (show_goal2 lh ig g gs ""); - (prl (natural_ntree + (show_goal2 lh ig g gs ""); + (prl (natural_ntree {ihsg=All_subgoals_hyp;isgintro="simpl"}) ltree) ] | {onhyps=Some[hyp]} when la.concl_occs = no_occurrences_expr -> spv [ (natural_lhyp lh ig.ihsg); - (show_goal2 lh ig g gs ""); - (prl (natural_ntree + (show_goal2 lh ig g gs ""); + (prl (natural_ntree {ihsg=Reduce_hyp;isgintro=""}) ltree) ] | _ -> assert false and natural_split ig lh g gs ge la ltree = match la with - [arg] -> + [arg] -> let _env= (gLOB ge) in let arg1= (*dbize _env*) arg in spv [ (natural_lhyp lh ig.ihsg); - (show_goal2 lh ig g gs ""); + (show_goal2 lh ig g gs ""); pour_montrer_G_la_valeur_recherchee_est_A g arg1; - (prl (natural_ntree + (prl (natural_ntree {ihsg=All_subgoals_hyp;isgintro="standard"}) ltree) ] | [] -> spv [ (natural_lhyp lh ig.ihsg); - (prli(natural_ntree + (prli(natural_ntree {ihsg=All_subgoals_hyp;isgintro="standard"}) ltree) ] @@ -1660,9 +1660,9 @@ and natural_generalize ig lh g gs ge la ltree = (* let type_arg=type_of_ast ge arg in*) spv [ (natural_lhyp lh ig.ihsg); - (show_goal2 lh ig g gs ""); + (show_goal2 lh ig g gs ""); on_se_sert_de_A arg1; - (prl (natural_ntree + (prl (natural_ntree {ihsg=All_subgoals_hyp;isgintro=""}) ltree) ] @@ -1670,23 +1670,23 @@ and natural_generalize ig lh g gs ge la ltree = and natural_right ig lh g gs ltree = spv [ (natural_lhyp lh ig.ihsg); - (prli(natural_ntree + (prli(natural_ntree {ihsg=All_subgoals_hyp;isgintro="standard"}) - ltree); - d_ou_A g + ltree); + d_ou_A g ] and natural_left ig lh g gs ltree = spv [ (natural_lhyp lh ig.ihsg); - (prli(natural_ntree + (prli(natural_ntree {ihsg=All_subgoals_hyp;isgintro="standard"}) - ltree); - d_ou_A g + ltree); + d_ou_A g ] and natural_auto ig lh g gs ltree = match ig.isgintro with "trivial_equality" -> spe - | _ -> + | _ -> if ltree=[] then sphv [(natural_lhyp lh ig.ihsg); (show_goal2 lh ig g gs ""); @@ -1717,7 +1717,7 @@ and natural_trivial ig lh g gs ltree = ce_qui_est_trivial () ] else spv [(natural_lhyp lh ig.ihsg); (show_goal2 lh ig g gs ". "); - (prli(natural_ntree + (prli(natural_ntree {ihsg=All_subgoals_hyp;isgintro="standard"}) ltree)] and natural_rewrite ig lh g gs arg ltree = @@ -1725,7 +1725,7 @@ and natural_rewrite ig lh g gs arg ltree = [ (natural_lhyp lh ig.ihsg); (show_goal2 lh ig g gs ""); en_utilisant_l_egalite_A arg; - (prli(natural_ntree + (prli(natural_ntree {ihsg=All_subgoals_hyp;isgintro="rewrite"}) ltree) ] @@ -1768,18 +1768,18 @@ CAMLLIB=/usr/local/lib/ocaml CAMLP4LIB=/usr/local/lib/camlp4 export CAMLLIB export COQTOP -export CAMLP4LIB +export CAMLP4LIB cd d:/Tools/pcoq/src/text d:/Tools/coq-7avril/bin/coqtop.byte.exe -I /cygdrive/D/Tools/pcoq/src/abs_syntax -I /cygdrive/D/Tools/pcoq/src/text -I /cygdrive/D/Tools/pcoq/src/coq -I /cygdrive/D/Tools/pcoq/src/pbp -I /cygdrive/D/Tools/pcoq/src/dad -I /cygdrive/D/Tools/pcoq/src/history - - + + Lemma l1: (A, B : Prop) A \/ B -> B -> A. Intros. Elim H. Auto. Qed. - + Drop. @@ -1806,7 +1806,7 @@ Pp_control.set_depth_boxes 100;; #install_printer pproof;; ep();; -let bidon = ref (constr_of_string "O");; +let bidon = ref (constr_of_string "O");; #trace to_nproof;; ***********************************************************************) diff --git a/plugins/interface/showproof_ct.ml b/plugins/interface/showproof_ct.ml index dd7f455d79..7632ebdfb5 100644 --- a/plugins/interface/showproof_ct.ml +++ b/plugins/interface/showproof_ct.ml @@ -26,20 +26,20 @@ let spe = sphs "";; let spb = sps " ";; let spr = sps "Retour chariot pour Show proof";; -let spnb n = +let spnb n = let s = ref "" in for i=1 to n do s:=(!s)^" "; done; sps !s ;; let rec spclean l = - match l with + match l with [] -> [] |x::l -> if x=spe then (spclean l) else x::(spclean l) ;; -let spnb n = +let spnb n = let s = ref "" in for i=1 to n do s:=(!s)^" "; done; sps !s ;; @@ -62,13 +62,13 @@ let root_of_text_proof t= CT_text_op [ct_text "root_of_text_proof"; t] ;; - + let spshrink info t = CT_text_op [ct_text "shrink"; CT_text_op [ct_text info; t]] ;; - + let spuselemma intro x y = CT_text_op [ct_text "uselemma"; ct_text intro; @@ -105,7 +105,7 @@ let spv l = let l= spclean l in CT_text_v l ;; - + let sph l = let l= spclean l in CT_text_h l @@ -118,12 +118,12 @@ let sphv l = ;; let rec prlist_with_sep f g l = - match l with + match l with [] -> hov 0 (mt ()) |x::l1 -> hov 0 ((g x) ++ (f ()) ++ (prlist_with_sep f g l1)) ;; - -let rec sp_print x = + +let rec sp_print x = match x with | CT_coerce_ID_to_TEXT (CT_ident s) -> (match s with @@ -162,7 +162,7 @@ let rec sp_print x = (CT_coerce_INT_to_SIGNED_INT (CT_int x)) -> x | _ -> raise (Failure "sp_print")) p) in - h 0 (sp_print g ++ spc () ++ str "<i>(" ++ str hyp ++ str ")</i>") + h 0 (sp_print g ++ spc () ++ str "<i>(" ++ str hyp ++ str ")</i>") | CT_text_h l -> h 0 (prlist_with_sep (fun () -> mt ()) @@ -178,7 +178,7 @@ let rec sp_print x = h 0 (str ("("^info^": ") ++ sp_print t ++ str ")") | CT_text_op [CT_coerce_ID_to_TEXT (CT_ident "root_of_text_proof"); t]-> - sp_print t + sp_print t | _ -> str "..." ;; - + diff --git a/plugins/interface/translate.ml b/plugins/interface/translate.ml index 559860b2fc..48f35ebab2 100644 --- a/plugins/interface/translate.ml +++ b/plugins/interface/translate.ml @@ -25,9 +25,9 @@ let translate_constr at_top env c = (*translates a named_context into a centaur-tree --> PREMISES_LIST *) (* this code is inspired from printer.ml (function pr_named_context_of) *) let translate_sign env = - let l = + let l = Environ.fold_named_context - (fun env (id,v,c) l -> + (fun env (id,v,c) l -> (match v with None -> CT_premise(CT_ident(string_of_id id), translate_constr false env c) @@ -36,19 +36,19 @@ let translate_sign env = (CT_coerce_ID_to_FORMULA (CT_ident (string_of_id id)), translate_constr false env v1, translate_constr false env c))::l) - env ~init:[] + env ~init:[] in CT_premises_list l;; - + (* the function rev_and_compact performs two operations: 1- it reverses the list of integers given as argument 2- it replaces sequences of "1" by a negative number that is the length of the sequence. *) let rec rev_and_compact l = function [] -> l - | 1::tl -> + | 1::tl -> (match l with - n::tl' -> + n::tl' -> if n < 0 then rev_and_compact ((n - 1)::tl') tl else diff --git a/plugins/interface/xlate.ml b/plugins/interface/xlate.ml index be7472a486..a322c7a72b 100644 --- a/plugins/interface/xlate.ml +++ b/plugins/interface/xlate.ml @@ -17,7 +17,7 @@ open Goptions;; (* // Verify whether this is dead code, as of coq version 7 *) -(* The following three sentences have been added to cope with a change +(* 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 problem is that now grammar rules will refer to identifiers by giving their absolute name, using the mutconstruct when needed. Unfortunately, @@ -80,7 +80,7 @@ let ctv_FORMULA_OPT_NONE = let ctv_PATTERN_OPT_NONE = CT_coerce_NONE_to_PATTERN_OPT CT_none;; -let ctv_DEF_BODY_OPT_NONE = CT_coerce_FORMULA_OPT_to_DEF_BODY_OPT +let ctv_DEF_BODY_OPT_NONE = CT_coerce_FORMULA_OPT_to_DEF_BODY_OPT ctv_FORMULA_OPT_NONE;; let ctf_ID_OPT_OR_ALL_SOME s = @@ -202,7 +202,7 @@ let apply_or_by_notation f = function | AN x -> f x | ByNotation _ -> xlate_error "TODO: ByNotation" -let tac_qualid_to_ct_ID ref = +let tac_qualid_to_ct_ID ref = CT_ident (Libnames.string_of_qualid (snd (qualid_of_reference ref))) let loc_qualid_to_ct_ID ref = @@ -229,10 +229,10 @@ let xlate_class = function let id_to_pattern_var ctid = match ctid with | CT_metaid _ -> xlate_error "metaid not expected in pattern_var" - | CT_ident "_" -> + | CT_ident "_" -> CT_coerce_ID_OPT_to_MATCH_PATTERN (CT_coerce_NONE_to_ID_OPT CT_none) | CT_ident id_string -> - CT_coerce_ID_OPT_to_MATCH_PATTERN + CT_coerce_ID_OPT_to_MATCH_PATTERN (CT_coerce_ID_to_ID_OPT (CT_ident id_string)) | CT_metac _ -> assert false;; @@ -250,7 +250,7 @@ let xlate_qualid a = let d,i = Libnames.repr_qualid a in let l = Names.repr_dirpath d in List.fold_left (fun s i1 -> (string_of_id i1) ^ "." ^ s) (string_of_id i) l;; - + (* // The next two functions should be modified to make direct reference to a notation operator *) let notation_to_formula s l = CT_notation(CT_string s, CT_formula_list l);; @@ -267,19 +267,19 @@ let rec xlate_match_pattern = CT_pattern_app (id_to_pattern_var (xlate_reference f1), CT_match_pattern_ne_list - (xlate_match_pattern arg1, + (xlate_match_pattern arg1, List.map xlate_match_pattern args)) | CPatAlias (_, pattern, id) -> CT_pattern_as (xlate_match_pattern pattern, CT_coerce_ID_to_ID_OPT (xlate_ident id)) | CPatOr (_,l) -> xlate_error "CPatOr: TODO" - | CPatDelimiters(_, key, p) -> + | CPatDelimiters(_, key, p) -> CT_pattern_delimitors(CT_num_type key, xlate_match_pattern p) | CPatPrim (_,Numeral n) -> CT_coerce_NUM_to_MATCH_PATTERN (CT_int_encapsulator(Bigint.to_string n)) | CPatPrim (_,String _) -> xlate_error "CPatPrim (String): TODO" - | CPatNotation(_, s, (l,[])) -> + | CPatNotation(_, s, (l,[])) -> CT_pattern_notation(CT_string s, CT_match_pattern_list(List.map xlate_match_pattern l)) | CPatNotation(_, s, (l,_)) -> @@ -331,26 +331,26 @@ and xlate_binder_l = function 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 +and xlate_match_pattern_ne_list = function [] -> assert false - | a::l -> CT_match_pattern_ne_list(xlate_match_pattern a, + | 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) | _ -> xlate_error "TODO: disjunctive multiple patterns" -and +and xlate_binder_ne_list = function [] -> assert false | a::l -> CT_binder_ne_list(xlate_binder a, List.map xlate_binder l) -and +and xlate_binder_list = function l -> CT_binder_list( List.map xlate_binder_l l) and (xlate_formula:Topconstr.constr_expr -> Ascent.ct_FORMULA) = function CRef r -> varc (xlate_reference r) | CArrow(_,a,b)-> CT_arrowc (xlate_formula a, xlate_formula b) - | CProdN(_,ll,b) as whole_term -> + | CProdN(_,ll,b) as whole_term -> let rec gather_binders = function CProdN(_, ll, b) -> ll@(gather_binders b) @@ -358,27 +358,27 @@ and (xlate_formula:Topconstr.constr_expr -> Ascent.ct_FORMULA) = function let rec fetch_ultimate_body = function CProdN(_, _, b) -> fetch_ultimate_body b | a -> a in - CT_prodc(xlate_binder_ne_list (gather_binders whole_term), + CT_prodc(xlate_binder_ne_list (gather_binders whole_term), xlate_formula (fetch_ultimate_body b)) | CLambdaN(_,ll,b)-> CT_lambdac(xlate_binder_ne_list ll, xlate_formula b) - | CLetIn(_, v, a, b) -> + | CLetIn(_, v, a, b) -> CT_letin(CT_def(xlate_id_opt v, xlate_formula a), xlate_formula b) - | CAppExpl(_, (Some n, r), l) -> + | CAppExpl(_, (Some n, r), l) -> let l', last = decompose_last l in CT_proj(xlate_formula last, CT_formula_ne_list (CT_bang(varc (xlate_reference r)), List.map xlate_formula l')) | CAppExpl(_, (None, r), []) -> CT_bang(varc(xlate_reference r)) - | CAppExpl(_, (None, r), l) -> + | CAppExpl(_, (None, r), l) -> CT_appc(CT_bang(varc (xlate_reference r)), xlate_formula_ne_list l) - | CApp(_, (Some n,f), l) -> + | CApp(_, (Some n,f), l) -> let l', last = decompose_last l in - CT_proj(xlate_formula_expl last, + CT_proj(xlate_formula_expl last, CT_formula_ne_list (xlate_formula f, List.map xlate_formula_expl l')) - | CApp(_, (_,f), l) -> + | CApp(_, (_,f), l) -> CT_appc(xlate_formula f, xlate_formula_expl_ne_list l) | CRecord (_,_,_) -> xlate_error "CRecord: TODO" | CCases (_, _, _, [], _) -> assert false @@ -387,14 +387,14 @@ and (xlate_formula:Topconstr.constr_expr -> Ascent.ct_FORMULA) = function List.map xlate_matched_formula tml), xlate_formula_opt ret_type, CT_eqn_list (List.map (fun x -> translate_one_equation x) eqns)) - | CLetTuple (_,a::l, ret_info, c, b) -> + | CLetTuple (_,a::l, ret_info, c, b) -> CT_let_tuple(CT_id_opt_ne_list(xlate_id_opt_aux a, List.map xlate_id_opt_aux l), xlate_return_info ret_info, xlate_formula c, xlate_formula b) | CLetTuple (_, [], _, _, _) -> xlate_error "NOT parsed: Let with ()" - | CIf (_,c, ret_info, b1, b2) -> + | CIf (_,c, ret_info, b1, b2) -> CT_if (xlate_formula c, xlate_return_info ret_info, xlate_formula b1, xlate_formula b2) @@ -403,16 +403,16 @@ and (xlate_formula:Topconstr.constr_expr -> Ascent.ct_FORMULA) = function | CNotation(_, s,(l,[])) -> notation_to_formula s (List.map xlate_formula l) | CNotation(_, s,(l,_)) -> xlate_error "CNotation (recursive): TODO" | CGeneralization(_,_,_,_) -> xlate_error "CGeneralization: TODO" - | CPrim (_, Numeral i) -> + | CPrim (_, Numeral i) -> CT_coerce_NUM_to_FORMULA(CT_int_encapsulator(Bigint.to_string i)) | CPrim (_, String _) -> xlate_error "CPrim (String): TODO" - | CHole _ -> CT_existvarc + | CHole _ -> CT_existvarc (* I assume CDynamic has been inserted to make free form extension of the language possible, but this would go against the logic of pcoq anyway. *) | CDynamic (_, _) -> assert false - | CDelimiters (_, key, num) -> + | CDelimiters (_, key, num) -> CT_num_encapsulator(CT_num_type key , xlate_formula num) - | CCast (_, e, CastConv (_, t)) -> + | CCast (_, e, CastConv (_, t)) -> CT_coerce_TYPED_FORMULA_to_FORMULA (CT_typed_formula(xlate_formula e, xlate_formula t)) | CCast (_, e, CastCoerce) -> assert false @@ -423,13 +423,13 @@ and (xlate_formula:Topconstr.constr_expr -> Ascent.ct_FORMULA) = function | CPatVar (_, (true, s)) -> xlate_error "Second order variable not supported" | CEvar _ -> xlate_error "CEvar not supported" - | CCoFix (_, (_, id), lm::lmi) -> + | CCoFix (_, (_, id), lm::lmi) -> 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) -> + | CFix (_, (_, id), lm::lmi) -> let strip_mutrec ((_, fid), (n, ro), bl, arf, ardef) = let struct_arg = make_fix_struct (n, bl) in let arf = xlate_formula arf in @@ -439,12 +439,12 @@ and (xlate_formula:Topconstr.constr_expr -> Ascent.ct_FORMULA) = function CT_fix_rec (xlate_ident fid, CT_binder_ne_list (b, bl), struct_arg, arf, ardef) | _ -> xlate_error "mutual recursive" in - CT_fixc (xlate_ident id, + CT_fixc (xlate_ident id, CT_fix_binder_list - (CT_coerce_FIX_REC_to_FIX_BINDER - (strip_mutrec lm), List.map + (CT_coerce_FIX_REC_to_FIX_BINDER + (strip_mutrec lm), List.map (fun x-> CT_coerce_FIX_REC_to_FIX_BINDER (strip_mutrec x)) - lmi)) + lmi)) | CCoFix _ -> assert false | CFix _ -> assert false and xlate_matched_formula = function @@ -454,18 +454,18 @@ and xlate_matched_formula = function CT_formula_in(xlate_formula f, xlate_formula y) | (f, (Some x, None)) -> CT_formula_as(xlate_formula f, xlate_id_opt_aux x) - | (f, (None, None)) -> + | (f, (None, None)) -> 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) and xlate_formula_expl_ne_list = function [] -> assert false | a::l -> CT_formula_ne_list(xlate_formula_expl a, List.map xlate_formula_expl l) -and xlate_formula_ne_list = function +and xlate_formula_ne_list = function [] -> assert false | a::l -> CT_formula_ne_list(xlate_formula a, List.map xlate_formula l);; @@ -489,17 +489,17 @@ let xlate_hyp_location = | (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_UNFOLD_to_HYP_LOCATION (CT_coerce_ID_to_UNFOLD (xlate_ident id)) | ((_,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, + 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 _),_ -> + | (_, MetaId _),_ -> xlate_error "MetaId not supported in xlate_hyp_location (should occur only in quotations)" @@ -510,8 +510,8 @@ let xlate_clause cls = None -> CT_coerce_STAR_to_HYP_LOCATION_LIST_OR_STAR CT_star | Some l -> CT_hyp_location_list(List.map xlate_hyp_location l) in CT_clause - (hyps_info, - if cls.concl_occs <> no_occurrences_expr then + (hyps_info, + 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) @@ -577,7 +577,7 @@ let xlate_quantified_hypothesis = function | NamedHyp id -> CT_coerce_ID_to_ID_OR_INT (xlate_ident id) let xlate_quantified_hypothesis_opt = function - | None -> + | None -> CT_coerce_ID_OPT_to_ID_OR_INT_OPT ctv_ID_OPT_NONE | Some (AnonHyp n) -> xlate_int_to_id_or_int_opt n | Some (NamedHyp id) -> xlate_id_to_id_or_int_opt id;; @@ -586,7 +586,7 @@ let xlate_id_or_int = function ArgArg n -> CT_coerce_INT_to_ID_OR_INT(CT_int n) | ArgVar(_, s) -> CT_coerce_ID_to_ID_OR_INT(xlate_ident s);; -let xlate_explicit_binding (loc,h,c) = +let xlate_explicit_binding (loc,h,c) = CT_binding (xlate_quantified_hypothesis h, xlate_formula c) let xlate_bindings = function @@ -630,7 +630,7 @@ let rec xlate_intro_pattern (loc,pat) = match pat with | IntroOrAndPattern (fp::ll) -> CT_disj_pattern (CT_intro_patt_list(List.map xlate_intro_pattern fp), - List.map + List.map (fun l -> CT_intro_patt_list(List.map xlate_intro_pattern l)) ll) @@ -651,7 +651,7 @@ let is_tactic_special_case = function | _ -> false;; let xlate_context_pattern = function - | Term v -> + | Term v -> CT_coerce_FORMULA_to_CONTEXT_PATTERN (xlate_formula v) | Subterm (b, idopt, v) -> (* TODO: application pattern *) CT_context(xlate_ident_opt idopt, xlate_formula v) @@ -677,7 +677,7 @@ let xlate_int_or_constr = function | ElimOnIdent(_,i) -> CT_coerce_ID_OR_INT_to_FORMULA_OR_INT (CT_coerce_ID_to_ID_OR_INT(xlate_ident i)) - | ElimOnAnonHyp i -> + | ElimOnAnonHyp i -> CT_coerce_ID_OR_INT_to_FORMULA_OR_INT (CT_coerce_INT_to_ID_OR_INT(CT_int i));; @@ -686,11 +686,11 @@ let xlate_using = function | Some (c2,sl2) -> CT_using (xlate_formula c2, xlate_bindings sl2);; let xlate_one_unfold_block = function - ((true,[]),qid) -> + ((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, + 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" ;; @@ -705,7 +705,7 @@ let rec (xlate_tacarg:raw_tactic_arg -> ct_TACTIC_ARG) = function | TacVoid -> CT_void - | Tacexp t -> + | Tacexp t -> CT_coerce_TACTIC_COM_to_TACTIC_ARG(xlate_tactic t) | Integer n -> CT_coerce_FORMULA_OR_INT_to_TACTIC_ARG @@ -724,7 +724,7 @@ let rec (xlate_tacarg:raw_tactic_arg -> ct_TACTIC_ARG) = CT_coerce_EVAL_CMD_to_TACTIC_ARG (CT_eval(CT_coerce_NONE_to_INT_OPT CT_none, xlate_red_tactic r, xlate_formula c)) - | ConstrMayEval(ConstrTypeOf(c)) -> + | ConstrMayEval(ConstrTypeOf(c)) -> CT_coerce_TERM_CHANGE_to_TACTIC_ARG(CT_check_term(xlate_formula c)) | MetaIdArg _ -> xlate_error "MetaIdArg should only be used in quotations" @@ -753,9 +753,9 @@ and xlate_red_tactic = | CbvVm -> CT_cbvvm | Hnf -> CT_hnf | Simpl None -> CT_simpl ctv_PATTERN_OPT_NONE - | Simpl (Some (occs,c)) -> + | Simpl (Some (occs,c)) -> let l = nums_of_occs occs in - CT_simpl + CT_simpl (CT_coerce_PATTERN_to_PATTERN_OPT (CT_pattern_occ (CT_int_list(nums_or_var_to_int_list_aux l), xlate_formula c))) @@ -770,7 +770,7 @@ and xlate_red_tactic = (match ct_unf_list with | first :: others -> CT_unfold (CT_unfold_ne_list (first, others)) | [] -> error "there should be at least one thing to unfold") - | Fold formula_list -> + | Fold formula_list -> CT_fold(CT_formula_list(List.map xlate_formula formula_list)) | Pattern l -> let pat_list = List.map (fun (occs,c) -> @@ -782,7 +782,7 @@ and xlate_red_tactic = | [] -> error "Expecting at least one pattern in a Pattern command") | ExtraRedExpr _ -> xlate_error "TODO LATER: ExtraRedExpr (probably dead code)" -and xlate_local_rec_tac = function +and xlate_local_rec_tac = function (* TODO LATER: local recursive tactics and global ones should be handled in the same manner *) | ((_,x),Tacexp (TacFun (argl,tac))) -> @@ -797,7 +797,7 @@ and xlate_tactic = | 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])) @@ -817,7 +817,7 @@ and xlate_tactic = | TacDo(count, t) -> CT_do(xlate_id_or_int count, xlate_tactic t) | TacTry t -> CT_try (xlate_tactic t) | TacRepeat t -> CT_repeat(xlate_tactic t) - | TacAbstract(t,id_opt) -> + | TacAbstract(t,id_opt) -> CT_abstract((match id_opt with None -> ctv_ID_OPT_NONE | Some id -> ctf_ID_OPT_SOME (CT_ident (string_of_id id))), @@ -827,8 +827,8 @@ and xlate_tactic = | TacMatch (true,_,_) -> failwith "TODO: lazy match" | TacMatch (false, exp, rules) -> CT_match_tac(xlate_tactic exp, - match List.map - (function + match List.map + (function | Pat ([],p,tac) -> CT_match_tac_rule(xlate_context_pattern p, mk_let_value tac) @@ -836,7 +836,7 @@ and xlate_tactic = | All tac -> CT_match_tac_rule (CT_coerce_FORMULA_to_CONTEXT_PATTERN - CT_existvarc, + CT_existvarc, mk_let_value tac)) rules with | [] -> assert false | fst::others -> @@ -856,27 +856,27 @@ and xlate_tactic = CT_coerce_NONE_to_TACTIC_OPT CT_none, CT_coerce_DEF_BODY_to_LET_VALUE (formula_to_def_body v)) - | ((_,s),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),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)) in let cl_l = List.map cvt_clause l in (match cl_l with - | [] -> assert false + | [] -> assert false | fst::others -> CT_let_ltac (CT_let_clauses(fst, others), mk_let_value t)) | TacLetIn(true, [], _) -> xlate_error "recursive definition with no definition" - | TacLetIn(true, f1::l, t) -> + | 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) - | TacAtom (_, t) -> xlate_tac t + | TacAtom (_, t) -> xlate_tac t | TacFail (count, []) -> CT_fail(xlate_id_or_int count, ctf_STRING_OPT_NONE) | TacFail (count, [MsgString s]) -> CT_fail(xlate_id_or_int count, ctf_STRING_OPT_SOME (CT_string s)) @@ -898,17 +898,17 @@ and xlate_tac = | Some t2 -> CT_coerce_TACTIC_COM_to_TACTIC_OPT (xlate_tactic t2) in (match l with [] -> CT_firstorder t1 - | [l1] -> + | [l1] -> (match genarg_tag l1 with - List1ArgType PreIdentArgType -> - let l2 = List.map + List1ArgType PreIdentArgType -> + let l2 = List.map (fun x -> CT_ident x) (out_gen (wit_list1 rawwit_pre_ident) l1) in - let fst,l3 = + let fst,l3 = match l2 with fst::l3 -> fst,l3 | [] -> assert false in CT_firstorder_using(t1, CT_id_ne_list(fst, l3)) | List1ArgType RefArgType -> - let l2 = List.map reference_to_ct_ID + let l2 = List.map reference_to_ct_ID (out_gen (wit_list1 rawwit_ref) l1) in let fst,l3 = match l2 with fst::l3 -> fst, l3 | [] -> assert false in @@ -927,11 +927,11 @@ and xlate_tac = let bindings = xlate_bindings b in CT_contradiction_thm(c1, bindings)) | TacChange (None, f, b) -> CT_change (xlate_formula f, xlate_clause b) - | TacChange (Some(l,c), f, 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), + CT_pattern_occ(CT_int_list(nums_or_var_to_int_list_aux l), xlate_formula c), xlate_formula f, xlate_clause b) @@ -978,9 +978,9 @@ and xlate_tac = CT_cofix_tac_list (List.map f cofixtac_list)) | TacMutualCofix (true, id, cofixtac_list) -> xlate_error "TODO: non user-visible cofix" - | TacIntrosUntil (NamedHyp id) -> + | TacIntrosUntil (NamedHyp id) -> CT_intros_until (CT_coerce_ID_to_ID_OR_INT (xlate_ident id)) - | TacIntrosUntil (AnonHyp n) -> + | TacIntrosUntil (AnonHyp n) -> CT_intros_until (CT_coerce_INT_to_ID_OR_INT (CT_int n)) | TacIntroMove (Some id1, MoveAfter id2) -> CT_intro_after(CT_coerce_ID_to_ID_OPT (xlate_ident id1),xlate_hyp id2) @@ -1002,41 +1002,41 @@ and xlate_tac = | 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 _ -> + | 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 - let cl = - (* J.F. : 18/08/2006 - Hack to coerce the "clause" argument of replace to a real clause + let cl = + (* J.F. : 18/08/2006 + Hack to coerce the "clause" argument of replace to a real clause To be remove if we can reuse the clause grammar entrie defined in g_tactic *) - let cl_as_clause = Extraargs.raw_in_arg_hyp_to_clause (out_gen Extraargs.rawwit_in_arg_hyp cl) in - let cl_as_xlate_arg = - {cl_as_clause with - Tacexpr.onhyps = - Option.map - (fun l -> + let cl_as_clause = Extraargs.raw_in_arg_hyp_to_clause (out_gen Extraargs.rawwit_in_arg_hyp cl) in + let cl_as_xlate_arg = + {cl_as_clause with + Tacexpr.onhyps = + Option.map + (fun l -> List.map (fun ((l,id),hyp_flag) -> ((l, Tacexpr.AI ((),id)) ,hyp_flag)) l ) cl_as_clause.Tacexpr.onhyps } in cl_as_xlate_arg - in - let cl = xlate_clause cl in - let tac_opt = + in + let cl = xlate_clause cl in + let tac_opt = match out_gen (Extraargs.rawwit_by_arg_tac) tac_opt with | None -> CT_coerce_NONE_to_TACTIC_OPT CT_none | Some tac -> let tac = xlate_tactic tac in CT_coerce_TACTIC_COM_to_TACTIC_OPT tac - in + in CT_replace_with (c1, c2,cl,tac_opt) - | TacRewrite(false,[b,Precisely 1,cbindl],cl,None) -> - let cl = xlate_clause cl - and c = xlate_formula (fst cbindl) + | 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) @@ -1047,7 +1047,7 @@ and xlate_tac = let b = out_gen Extraargs.rawwit_orient b in let c = xlate_formula (out_gen rawwit_constr c) in (match c with - | CT_coerce_ID_to_FORMULA (CT_ident _ as id) -> + | CT_coerce_ID_to_FORMULA (CT_ident _ as id) -> if b then CT_deprewrite_lr id else CT_deprewrite_rl id | _ -> xlate_error "dependent rewrite on term: not supported") | TacExtend (_,"dependent_rewrite", [b; c; id]) -> @@ -1103,7 +1103,7 @@ and xlate_tac = match id_list with [] -> assert false | a::tl -> a,tl in let t1 = match t with - [t0] -> + [t0] -> CT_coerce_TACTIC_COM_to_TACTIC_OPT (xlate_tactic(out_gen rawwit_main_tactic t0)) | [] -> CT_coerce_NONE_to_TACTIC_OPT CT_none @@ -1130,7 +1130,7 @@ and xlate_tac = second_n, CT_coerce_STAR_to_ID_NE_LIST_OR_STAR CT_star) | Some [] -> CT_eauto(first_n, second_n) - | Some (a::l) -> + | Some (a::l) -> CT_eauto_with(first_n, second_n, CT_coerce_ID_NE_LIST_to_ID_NE_LIST_OR_STAR (CT_id_ne_list @@ -1141,11 +1141,11 @@ 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)) - (* eapply now represented by TacApply (true,cbindl) - | TacExtend (_,"eapply", [cbindl]) -> + (* eapply now represented by TacApply (true,cbindl) + | TacExtend (_,"eapply", [cbindl]) -> *) | TacTrivial ([],Some []) -> CT_trivial - | TacTrivial ([],None) -> + | TacTrivial ([],None) -> CT_trivial_with(CT_coerce_STAR_to_ID_NE_LIST_OR_STAR CT_star) | TacTrivial ([],Some (id1::idl)) -> CT_trivial_with(CT_coerce_ID_NE_LIST_to_ID_NE_LIST_OR_STAR( @@ -1171,7 +1171,7 @@ and xlate_tac = when List.for_all (fun ((o,_),na) -> o = all_occurrences_expr & na = Anonymous) cl -> CT_generalize - (CT_formula_ne_list (xlate_formula first, + (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 -> @@ -1213,7 +1213,7 @@ and xlate_tac = CT_id_list (List.map xlate_hyp idl)) | TacInversion (DepInversion (k,copt,l),quant_hyp) -> let id = xlate_quantified_hypothesis quant_hyp in - CT_depinversion (compute_INV_TYPE k, id, + CT_depinversion (compute_INV_TYPE k, id, xlate_with_names l, xlate_formula_opt copt) | TacInversion (InversionUsing (c,idlist), id) -> let id = xlate_quantified_hypothesis id in @@ -1223,7 +1223,7 @@ and xlate_tac = | 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) -> + | TacClearBody(a::l) -> CT_clear_body (CT_id_ne_list (xlate_hyp a, List.map xlate_hyp l)) | TacDAuto (a, b, []) -> CT_dauto(xlate_int_or_var_opt_to_int_opt a, xlate_int_opt b) @@ -1231,39 +1231,39 @@ and xlate_tac = xlate_error "TODO: dauto using" | TacInductionDestruct(true,false,[a,b,(None,c),None]) -> CT_new_destruct - (List.map xlate_int_or_constr a, xlate_using b, + (List.map xlate_int_or_constr a, xlate_using b, xlate_with_names c) | TacInductionDestruct(false,false,[a,b,(None,c),None]) -> CT_new_induction (List.map xlate_int_or_constr a, xlate_using b, xlate_with_names c) - | TacInductionDestruct(_,false,_) -> + | TacInductionDestruct(_,false,_) -> xlate_error "TODO: clause 'in' and full 'as' of destruct/induction" - | TacLetTac (na, c, cl, true) 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, true) -> - CT_lettac(xlate_id_opt ((0,0),na), xlate_formula c, + 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, Some (_,IntroIdentifier id), c) -> + | TacAssert (None, Some (_,IntroIdentifier id), c) -> CT_assert(xlate_id_opt ((0,0),Name id), xlate_formula c) - | TacAssert (None, None, c) -> + | TacAssert (None, None, c) -> CT_assert(xlate_id_opt ((0,0),Anonymous), xlate_formula c) - | TacAssert (Some (TacId []), Some (_,IntroIdentifier id), c) -> + | TacAssert (Some (TacId []), Some (_,IntroIdentifier id), c) -> CT_truecut(xlate_id_opt ((0,0),Name id), xlate_formula c) - | TacAssert (Some (TacId []), None, c) -> + | TacAssert (Some (TacId []), None, c) -> 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(false,Some tac) -> + | TacAnyConstructor(false,Some tac) -> CT_any_constructor (CT_coerce_TACTIC_COM_to_TACTIC_OPT(xlate_tactic tac)) - | TacAnyConstructor(false,None) -> + | TacAnyConstructor(false,None) -> CT_any_constructor(CT_coerce_NONE_to_TACTIC_OPT CT_none) | TacAnyConstructor _ -> xlate_error "TODO: econstructor" - | TacExtend(_, "ring", [args]) -> + | TacExtend(_, "ring", [args]) -> CT_ring (CT_formula_list (List.map xlate_formula @@ -1328,7 +1328,7 @@ and coerce_genarg_to_TARG x = (CT_coerce_FORMULA_to_SCOMMENT_CONTENT (xlate_formula (out_gen rawwit_constr x))) | ConstrMayEvalArgType -> xlate_error"TODO: generic constr-may-eval argument" | QuantHypArgType ->xlate_error"TODO: generic quantified hypothesis argument" - | OpenConstrArgType b -> + | OpenConstrArgType b -> CT_coerce_SCOMMENT_CONTENT_to_TARG (CT_coerce_FORMULA_to_SCOMMENT_CONTENT(xlate_formula (snd (out_gen @@ -1367,7 +1367,7 @@ and formula_to_def_body = | ConstrTypeOf f -> CT_type_of (xlate_formula f) | ConstrTerm c -> ct_coerce_FORMULA_to_DEF_BODY(xlate_formula c) -and mk_let_value = function +and mk_let_value = function TacArg (ConstrMayEval v) -> CT_coerce_DEF_BODY_to_LET_VALUE(formula_to_def_body v) | v -> CT_coerce_TACTIC_COM_to_LET_VALUE(xlate_tactic v);; @@ -1383,7 +1383,7 @@ let coerce_genarg_to_VARG x = (CT_coerce_INT_to_INT_OPT (CT_int n))) | IntOrVarArgType -> (match out_gen rawwit_int_or_var x with - | ArgArg n -> + | ArgArg n -> CT_coerce_ID_OR_INT_OPT_to_VARG (CT_coerce_INT_OPT_to_ID_OR_INT_OPT (CT_coerce_INT_to_INT_OPT (CT_int n))) @@ -1420,11 +1420,11 @@ let coerce_genarg_to_VARG x = (CT_coerce_ID_to_ID_OPT id)) (* Specific types *) | SortArgType -> - CT_coerce_FORMULA_OPT_to_VARG + CT_coerce_FORMULA_OPT_to_VARG (CT_coerce_FORMULA_to_FORMULA_OPT (CT_coerce_SORT_TYPE_to_FORMULA (xlate_sort (out_gen rawwit_sort x)))) | ConstrArgType -> - CT_coerce_FORMULA_OPT_to_VARG + CT_coerce_FORMULA_OPT_to_VARG (CT_coerce_FORMULA_to_FORMULA_OPT (xlate_formula (out_gen rawwit_constr x))) | ConstrMayEvalArgType -> xlate_error"TODO: generic constr-may-eval argument" | QuantHypArgType ->xlate_error"TODO: generic quantified hypothesis argument" @@ -1529,8 +1529,8 @@ let cvt_optional_eval_for_definition c1 optional_eval = let cvt_vernac_binder = function | b,(id::idl,c) -> - let l,t = - CT_id_opt_ne_list + let l,t = + CT_id_opt_ne_list (xlate_ident_opt (Some (snd id)), List.map (fun id -> xlate_ident_opt (Some (snd id))) idl), xlate_formula c in @@ -1556,8 +1556,8 @@ let xlate_comment = function let translate_opt_notation_decl = function None -> CT_coerce_NONE_to_DECL_NOTATION_OPT(CT_none) | Some(s, f, sc) -> - let tr_sc = - match sc with + let tr_sc = + match sc with None -> ctv_ID_OPT_NONE | Some id -> CT_coerce_ID_to_ID_OPT (CT_ident id) in CT_decl_notation(CT_string s, xlate_formula f, tr_sc);; @@ -1588,18 +1588,18 @@ let xlate_syntax_modifier = function let rec xlate_module_type = function - | CMTEident(_, qid) -> + | CMTEident(_, qid) -> CT_coerce_ID_to_MODULE_TYPE(CT_ident (xlate_qualid qid)) | CMTEwith(mty, decl) -> let mty1 = xlate_module_type mty in (match decl with CWith_Definition((_, idl), c) -> - CT_module_type_with_def(mty1, + CT_module_type_with_def(mty1, CT_id_list (List.map xlate_ident idl), xlate_formula c) | CWith_Module((_, idl), (_, qid)) -> CT_module_type_with_mod(mty1, - CT_id_list (List.map xlate_ident idl), + CT_id_list (List.map xlate_ident idl), CT_ident (xlate_qualid qid))) | CMTEapply (_,_) -> xlate_error "TODO: Funsig application";; @@ -1607,7 +1607,7 @@ let rec xlate_module_type = function let xlate_module_binder_list (l:module_binder list) = CT_module_binder_list (List.map (fun (_, idl, mty) -> - let idl1 = + let idl1 = List.map (fun (_, x) -> CT_ident (string_of_id x)) idl in let fst,idl2 = match idl1 with [] -> assert false @@ -1619,7 +1619,7 @@ let xlate_module_type_check_opt = function None -> CT_coerce_MODULE_TYPE_OPT_to_MODULE_TYPE_CHECK (CT_coerce_ID_OPT_to_MODULE_TYPE_OPT ctv_ID_OPT_NONE) | Some(mty, true) -> CT_only_check(xlate_module_type mty) - | Some(mty, false) -> + | Some(mty, false) -> CT_coerce_MODULE_TYPE_OPT_to_MODULE_TYPE_CHECK (CT_coerce_MODULE_TYPE_to_MODULE_TYPE_OPT (xlate_module_type mty));; @@ -1633,7 +1633,7 @@ let rec xlate_module_expr = function let rec xlate_vernac = function | VernacDeclareTacticDefinition (true, tacs) -> - (match List.map + (match List.map (function (id, _, body) -> CT_tac_def(reference_to_ct_ID id, xlate_tactic body)) @@ -1642,7 +1642,7 @@ let rec xlate_vernac = | fst::tacs1 -> CT_tactic_definition (CT_tac_def_ne_list(fst, tacs1))) - | VernacDeclareTacticDefinition(false, _) -> + | VernacDeclareTacticDefinition(false, _) -> xlate_error "obsolete tactic definition not handled" | VernacLoad (verbose,s) -> CT_load ( @@ -1682,14 +1682,14 @@ let rec xlate_vernac = | VernacAbort None -> CT_abort ctv_ID_OPT_OR_ALL_NONE | VernacAbortAll -> CT_abort ctv_ID_OPT_OR_ALL_ALL | VernacRestart -> CT_restart - | VernacSolve (n, tac, b) -> + | VernacSolve (n, tac, b) -> CT_solve (CT_int n, xlate_tactic tac, if b then CT_dotdot else CT_coerce_NONE_to_DOTDOT_OPT CT_none) (* MMode *) - | (VernacDeclProof | VernacReturn | VernacProofInstr _) -> + | (VernacDeclProof | VernacReturn | VernacProofInstr _) -> anomaly "No MMode in CTcoq" @@ -1701,7 +1701,7 @@ let rec xlate_vernac = let file = out_gen rawwit_string f in let l1 = out_gen (wit_list1 rawwit_ref) l in let fst,l2 = match l1 with [] -> assert false | fst::l2 -> fst, l2 in - CT_extract_to_file(CT_string file, + CT_extract_to_file(CT_string file, CT_id_ne_list(loc_qualid_to_ct_ID fst, List.map loc_qualid_to_ct_ID l2)) | VernacExtend("ExtractionInline", [l]) -> @@ -1714,7 +1714,7 @@ let rec xlate_vernac = let fst, l2 = match l1 with [] -> assert false | fst ::l2 -> fst, l2 in CT_no_inline(CT_id_ne_list(loc_qualid_to_ct_ID fst, List.map loc_qualid_to_ct_ID l2)) - | VernacExtend("Field", + | VernacExtend("Field", [fth;ainv;ainvl;div]) -> (match List.map (fun v -> xlate_formula(out_gen rawwit_constr v)) [fth;ainv;ainvl] @@ -1728,7 +1728,7 @@ let rec xlate_vernac = let orient = out_gen Extraargs.rawwit_orient o in let formula_list = out_gen (wit_list1 rawwit_constr) f in let base = out_gen rawwit_pre_ident b in - let t = + let t = match args with [t;_] -> out_gen rawwit_main_tactic t | _ -> TacId [] in let ct_orient = match orient with @@ -1754,17 +1754,17 @@ let rec xlate_vernac = CT_hints(CT_ident "Constructors", CT_id_ne_list(n1, names), dblist) | HintsExtern (n, c, t) -> - let pat = match c with + let pat = match c with | None -> CT_coerce_ID_OPT_to_FORMULA_OPT (CT_coerce_NONE_to_ID_OPT CT_none) - | Some c -> CT_coerce_FORMULA_to_FORMULA_OPT (xlate_formula c) + | Some c -> CT_coerce_FORMULA_to_FORMULA_OPT (xlate_formula c) in CT_hint_extern(CT_int n, pat, xlate_tactic t, dblist) - | HintsImmediate l -> + | HintsImmediate l -> let f1, formulas = match List.map xlate_formula l with a :: tl -> a, tl | _ -> failwith "" in let l' = CT_formula_ne_list(f1, formulas) in if local then - (match h with + (match h with HintsResolve _ -> CT_local_hints_resolve(l', dblist) | HintsImmediate _ -> @@ -1775,13 +1775,13 @@ let rec xlate_vernac = HintsResolve _ -> CT_hints_resolve(l', dblist) | HintsImmediate _ -> CT_hints_immediate(l', dblist) | _ -> assert false) - | HintsResolve l -> + | HintsResolve l -> let f1, formulas = match List.map xlate_formula (List.map pi3 l) with a :: tl -> a, tl | _ -> failwith "" in let l' = CT_formula_ne_list(f1, formulas) in if local then - (match h with + (match h with HintsResolve _ -> CT_local_hints_resolve(l', dblist) | HintsImmediate _ -> @@ -1792,16 +1792,16 @@ let rec xlate_vernac = HintsResolve _ -> CT_hints_resolve(l', dblist) | HintsImmediate _ -> CT_hints_immediate(l', dblist) | _ -> assert false) - | HintsUnfold l -> + | HintsUnfold l -> let n1, names = match List.map loc_qualid_to_ct_ID l with n1 :: names -> n1, names | _ -> failwith "" in if local then CT_local_hints(CT_ident "Unfold", CT_id_ne_list(n1, names), dblist) - else + else CT_hints(CT_ident "Unfold", CT_id_ne_list(n1, names), dblist) - | HintsTransparency (l,b) -> + | HintsTransparency (l,b) -> let n1, names = match List.map loc_qualid_to_ct_ID l with n1 :: names -> n1, names | _ -> failwith "" in @@ -1809,7 +1809,7 @@ let rec xlate_vernac = if local then CT_local_hints(CT_ident ty, CT_id_ne_list(n1, names), dblist) - else + else CT_hints(CT_ident ty, CT_id_ne_list(n1, names), dblist) | HintsDestruct(id, n, loc, f, t) -> let dl = match loc with @@ -1869,9 +1869,9 @@ let rec xlate_vernac = | PrintModules -> CT_print_modules | PrintGrammar name -> CT_print_grammar CT_grammar_none | PrintHintDb -> CT_print_hintdb (CT_coerce_STAR_to_ID_OR_STAR CT_star) - | PrintHintDbName id -> + | PrintHintDbName id -> CT_print_hintdb (CT_coerce_ID_to_ID_OR_STAR (CT_ident id)) - | PrintRewriteHintDbName id -> + | PrintRewriteHintDbName id -> CT_print_rewrite_hintdb (CT_ident id) | PrintHint id -> CT_print_hint (CT_coerce_ID_to_ID_OPT (loc_smart_global_to_ct_ID id)) @@ -1884,15 +1884,15 @@ let rec xlate_vernac = | PrintClasses -> CT_print_classes | PrintLtac qid -> CT_print_ltac (loc_qualid_to_ct_ID qid) | PrintCoercions -> CT_print_coercions - | PrintCoercionPaths (id1, id2) -> + | PrintCoercionPaths (id1, id2) -> CT_print_path (xlate_class id1, xlate_class id2) | PrintCanonicalConversions -> xlate_error "TODO: Print Canonical Structures" - | PrintAssumptions _ -> + | PrintAssumptions _ -> xlate_error "TODO: Print Needed Assumptions" - | PrintInstances _ -> + | PrintInstances _ -> xlate_error "TODO: Print Instances" - | PrintTypeClasses -> + | PrintTypeClasses -> xlate_error "TODO: Print TypeClasses" | PrintInspect n -> CT_inspect (CT_int n) | PrintUniverses opt_s -> CT_print_universes(ctf_STRING_OPT opt_s) @@ -1902,7 +1902,7 @@ let rec xlate_vernac = | PrintScopes -> CT_print_scopes | PrintScope id -> CT_print_scope (CT_ident id) | PrintVisibility id_opt -> - CT_print_visibility + CT_print_visibility (match id_opt with Some id -> CT_coerce_ID_to_ID_OPT(CT_ident id) | None -> ctv_ID_OPT_NONE) @@ -1947,9 +1947,9 @@ let rec xlate_vernac = let xlate_search_about_item (b,it) = if not b then xlate_error "TODO: negative searchabout constraint"; match it with - SearchSubPattern (CRef x) -> + SearchSubPattern (CRef x) -> CT_coerce_ID_to_ID_OR_STRING(loc_qualid_to_ct_ID x) - | SearchString (s,None) -> + | SearchString (s,None) -> CT_coerce_STRING_to_ID_OR_STRING(CT_string s) | SearchString _ | SearchSubPattern _ -> xlate_error @@ -1992,7 +1992,7 @@ let rec xlate_vernac = let ardef = xlate_formula ardef in match xlate_binder_list bl with | CT_binder_list (b :: bl) -> - CT_fix_rec (xlate_ident fid, CT_binder_ne_list (b, bl), + CT_fix_rec (xlate_ident fid, CT_binder_ne_list (b, bl), struct_arg, arf, ardef) | _ -> xlate_error "mutual recursive" in CT_fix_decl @@ -2009,7 +2009,7 @@ let rec xlate_vernac = let strip_ind = function | (Some (_,id), InductionScheme (depstr, inde, sort)) -> CT_scheme_spec - (xlate_ident id, xlate_dep depstr, + (xlate_ident id, xlate_dep depstr, CT_coerce_ID_to_FORMULA (loc_smart_global_to_ct_ID inde), xlate_sort sort) | (None, InductionScheme (depstr, inde, sort)) -> @@ -2027,7 +2027,7 @@ let rec xlate_vernac = xlate_error"TODO: Local abbreviations and abbreviations with parameters" (* Modules and Module Types *) | VernacInclude (_) -> xlate_error "TODO : Include " - | VernacDeclareModuleType((_, id), bl, mty_o) -> + | VernacDeclareModuleType((_, id), bl, mty_o) -> CT_module_type_decl(xlate_ident id, xlate_module_binder_list bl, match mty_o with @@ -2038,20 +2038,20 @@ let rec xlate_vernac = CT_coerce_MODULE_TYPE_to_MODULE_TYPE_OPT (xlate_module_type mty1)) | VernacDefineModule(_,(_, id), bl, mty_o, mexpr_o) -> - CT_module(xlate_ident id, + CT_module(xlate_ident id, xlate_module_binder_list bl, xlate_module_type_check_opt mty_o, match mexpr_o with None -> CT_coerce_ID_OPT_to_MODULE_EXPR ctv_ID_OPT_NONE | Some m -> xlate_module_expr m) - | VernacDeclareModule(_,(_, id), bl, mty_o) -> - CT_declare_module(xlate_ident id, + | VernacDeclareModule(_,(_, id), bl, mty_o) -> + CT_declare_module(xlate_ident id, xlate_module_binder_list bl, xlate_module_type_check_opt (Some mty_o), CT_coerce_ID_OPT_to_MODULE_EXPR ctv_ID_OPT_NONE) | VernacRequire (impexp, spec, id::idl) -> let ct_impexp, ct_spec = get_require_flags impexp spec in - CT_require (ct_impexp, ct_spec, + CT_require (ct_impexp, ct_spec, CT_coerce_ID_NE_LIST_to_ID_NE_LIST_OR_STRING( CT_id_ne_list(loc_qualid_to_ct_ID id, List.map loc_qualid_to_ct_ID idl))) @@ -2059,14 +2059,14 @@ let rec xlate_vernac = xlate_error "Require should have at least one id argument" | VernacRequireFrom (impexp, spec, filename) -> let ct_impexp, ct_spec = get_require_flags impexp spec in - CT_require(ct_impexp, ct_spec, + CT_require(ct_impexp, ct_spec, CT_coerce_STRING_to_ID_NE_LIST_OR_STRING(CT_string filename)) | VernacOpenCloseScope(true, true, s) -> CT_local_open_scope(CT_ident s) | VernacOpenCloseScope(false, true, s) -> CT_open_scope(CT_ident s) | VernacOpenCloseScope(true, false, s) -> CT_local_close_scope(CT_ident s) | VernacOpenCloseScope(false, false, s) -> CT_close_scope(CT_ident s) - | VernacArgumentsScope(true, qid, l) -> + | VernacArgumentsScope(true, qid, l) -> CT_arguments_scope(loc_smart_global_to_ct_ID qid, CT_id_opt_list (List.map @@ -2074,10 +2074,10 @@ let rec xlate_vernac = match x with None -> ctv_ID_OPT_NONE | Some x -> ctf_ID_OPT_SOME(CT_ident x)) l)) - | VernacArgumentsScope(false, qid, l) -> + | VernacArgumentsScope(false, qid, l) -> xlate_error "TODO: Arguments Scope Global" | VernacDelimiters(s1,s2) -> CT_delim_scope(CT_ident s1, CT_ident s2) - | VernacBindScope(id, a::l) -> + | VernacBindScope(id, a::l) -> let xlate_class_rawexpr = function FunClass -> CT_ident "Funclass" | SortClass -> CT_ident "Sortclass" | RefClass qid -> loc_smart_global_to_ct_ID qid in @@ -2085,10 +2085,10 @@ let rec xlate_vernac = CT_id_ne_list(xlate_class_rawexpr a, List.map xlate_class_rawexpr l)) | VernacBindScope(id, []) -> assert false - | VernacNotation(b, c, (s,modif_list), opt_scope) -> + | VernacNotation(b, c, (s,modif_list), opt_scope) -> let translated_s = CT_string s in let formula = xlate_formula c in - let translated_modif_list = + let translated_modif_list = CT_modifier_list(List.map xlate_syntax_modifier modif_list) in let translated_scope = match opt_scope with None -> ctv_ID_OPT_NONE @@ -2097,11 +2097,11 @@ let rec xlate_vernac = CT_local_define_notation (translated_s, formula, translated_modif_list, translated_scope) else - CT_define_notation(translated_s, formula, + CT_define_notation(translated_s, formula, translated_modif_list, translated_scope) - | VernacSyntaxExtension(b,(s,modif_list)) -> + | VernacSyntaxExtension(b,(s,modif_list)) -> let translated_s = CT_string s in - let translated_modif_list = + let translated_modif_list = CT_modifier_list(List.map xlate_syntax_modifier modif_list) in if b then CT_local_reserve_notation(translated_s, translated_modif_list) @@ -2118,7 +2118,7 @@ let rec xlate_vernac = CT_local_infix(s, id1,modl1, translated_scope) else CT_infix(s, id1,modl1, translated_scope) - | VernacInfix (b,(str,modl),_ , opt_scope) -> + | VernacInfix (b,(str,modl),_ , opt_scope) -> xlate_error "TODO: Infix not ref" | VernacCoercion (s, id1, id2, id3) -> let id_opt = CT_coerce_NONE_to_IDENTITY_OPT CT_none in @@ -2140,7 +2140,7 @@ let rec xlate_vernac = CT_coercion (local_opt, id_opt, xlate_ident id1, xlate_class id2, xlate_class id3) - (* Type Classes *) + (* Type Classes *) | VernacDeclareInstance _|VernacContext _| VernacInstance (_, _, _, _, _) -> xlate_error "TODO: Type Classes commands" @@ -2150,20 +2150,20 @@ let rec xlate_vernac = | VernacExtend (s, l) -> CT_user_vernac (CT_ident s, CT_varg_list (List.map coerce_genarg_to_VARG l)) - | VernacList((_, a)::l) -> + | VernacList((_, a)::l) -> CT_coerce_COMMAND_LIST_to_COMMAND - (CT_command_list(xlate_vernac a, + (CT_command_list(xlate_vernac a, List.map (fun (_, x) -> xlate_vernac x) l)) | VernacList([]) -> assert false | VernacNop -> CT_proof_no_op - | VernacComments l -> + | VernacComments l -> CT_scomments(CT_scomment_content_list (List.map xlate_comment l)) | VernacDeclareImplicits(true, id, opt_positions) -> CT_implicits (loc_smart_global_to_ct_ID id, match opt_positions with None -> CT_coerce_NONE_to_ID_LIST_OPT CT_none - | Some l -> + | Some l -> CT_coerce_ID_LIST_to_ID_LIST_OPT (CT_id_list (List.map @@ -2174,7 +2174,7 @@ let rec xlate_vernac = | VernacDeclareImplicits(false, id, opt_positions) -> xlate_error "TODO: Implicit Arguments Global" | VernacReserve((_,a)::l, f) -> - CT_reserve(CT_id_ne_list(xlate_ident a, + CT_reserve(CT_id_ne_list(xlate_ident a, List.map (fun (_,x) -> xlate_ident x) l), xlate_formula f) | VernacReserve([], _) -> assert false @@ -2186,15 +2186,15 @@ let rec xlate_vernac = | VernacTimeout(n,v) -> CT_timeout(CT_int n,xlate_vernac v) | VernacSetOption (_,["Implicit"; "Arguments"], BoolValue true)->CT_user_vernac (CT_ident "IMPLICIT_ARGS_ON", CT_varg_list[]) |VernacExactProof f -> CT_proof(xlate_formula f) - | VernacSetOption (_,table, BoolValue true) -> - let table1 = + | VernacSetOption (_,table, BoolValue true) -> + let table1 = match table with [s] -> CT_coerce_ID_to_TABLE(CT_ident s) | [s1;s2] -> CT_table(CT_ident s1, CT_ident s2) | _ -> xlate_error "TODO: arbitrary-length Table names" in CT_set_option(table1) - | VernacSetOption (_,table, v) -> - let table1 = + | VernacSetOption (_,table, v) -> + let table1 = match table with [s] -> CT_coerce_ID_to_TABLE(CT_ident s) | [s1;s2] -> CT_table(CT_ident s1, CT_ident s2) @@ -2208,7 +2208,7 @@ let rec xlate_vernac = CT_coerce_INT_to_SINGLE_OPTION_VALUE(CT_int n) in CT_set_option_value(table1, value) | VernacUnsetOption(_,table) -> - let table1 = + let table1 = match table with [s] -> CT_coerce_ID_to_TABLE(CT_ident s) | [s1;s2] -> CT_table(CT_ident s1, CT_ident s2) @@ -2218,13 +2218,13 @@ let rec xlate_vernac = let values = List.map (function - | QualidRefValue x -> + | QualidRefValue x -> CT_coerce_ID_to_ID_OR_STRING(loc_qualid_to_ct_ID x) - | StringRefValue x -> + | StringRefValue x -> CT_coerce_STRING_to_ID_OR_STRING(CT_string x)) l in - let fst, values1 = + let fst, values1 = match values with [] -> assert false | a::b -> (a,b) in - let table1 = + let table1 = match table with [s] -> CT_coerce_ID_to_TABLE(CT_ident s) | [s1;s2] -> CT_table(CT_ident s1, CT_ident s2) diff --git a/plugins/micromega/Env.v b/plugins/micromega/Env.v index 631417e0e9..231004bca2 100644 --- a/plugins/micromega/Env.v +++ b/plugins/micromega/Env.v @@ -17,9 +17,9 @@ Require Import Coq.Arith.Max. Require Import List. Set Implicit Arguments. -(* I have addded a Leaf constructor to the varmap data structure (/plugins/ring/Quote.v) +(* I have addded a Leaf constructor to the varmap data structure (/plugins/ring/Quote.v) -- this is harmless and spares a lot of Empty. - This means smaller proof-terms. + This means smaller proof-terms. BTW, by dropping the polymorphism, I get small (yet noticeable) speed-up. *) @@ -40,7 +40,7 @@ Section S. Lemma psucc : forall p, (match p with | xI y' => xO (Psucc y') | xO y' => xI y' - | 1%positive => 2%positive + | 1%positive => 2%positive end) = (p+1)%positive. Proof. destruct p. @@ -50,7 +50,7 @@ Section S. reflexivity. Qed. - Lemma jump_Pplus : forall i j l, + Lemma jump_Pplus : forall i j l, forall x, jump (i + j) l x = jump i (jump j l) x. Proof. unfold jump. @@ -60,7 +60,7 @@ Section S. Qed. Lemma jump_simpl : forall p l, - forall x, jump p l x = + forall x, jump p l x = match p with | xH => tail l x | xO p => jump p (jump p l) x @@ -80,15 +80,15 @@ Section S. Qed. Ltac jump_s := - repeat + 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. + Proof. unfold tail. intros. repeat rewrite <- jump_Pplus. @@ -96,7 +96,7 @@ Section S. reflexivity. Qed. - Lemma jump_Psucc : forall j l, + Lemma jump_Psucc : forall j l, forall x, (jump (Psucc j) l x) = (jump 1 (jump j l) x). Proof. intros. @@ -129,13 +129,13 @@ Section S. reflexivity. Qed. - Lemma nth_spec : forall p l x, - nth p l = + 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. + end. Proof. unfold nth. destruct p. diff --git a/plugins/micromega/EnvRing.v b/plugins/micromega/EnvRing.v index 04e68272ee..e58f8e6868 100644 --- a/plugins/micromega/EnvRing.v +++ b/plugins/micromega/EnvRing.v @@ -55,12 +55,12 @@ Section MakeRingPol. Notation "x - y " := (rsub x y). Notation "- x" := (ropp x). Notation "x == y" := (req x y). - (* C notations *) + (* 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 *) + (* 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. @@ -554,7 +554,7 @@ Section MakeRingPol. intros;simpl;apply (morph0 CRmorph). Qed. -Lemma env_morph : forall p e1 e2, (forall x, e1 x = e2 x) -> +Lemma env_morph : forall p e1 e2, (forall x, e1 x = e2 x) -> p @ e1 = p @ e2. Proof. induction p ; simpl. @@ -578,7 +578,7 @@ Proof. reflexivity. Qed. -Lemma Pjump_xO_tail : forall P p l, +Lemma Pjump_xO_tail : forall P p l, P @ (jump (xO p) (tail l)) = P @ (jump (xI p) l). Proof. intros. @@ -743,9 +743,9 @@ Qed. 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). + apply (ARadd_comm ARth). rewrite Pjump_Pdouble_minus_one. - apply (ARadd_comm ARth). + 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. @@ -785,7 +785,7 @@ Qed. 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. + 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. @@ -931,7 +931,7 @@ Lemma Pmul_ok : forall P P' l, (P**P')@l == P@l * P'@l. rrefl. Qed. - Lemma Mphi_morph : forall P env env', (forall x, env x = env' x ) -> + Lemma Mphi_morph : forall P env env', (forall x, env x = env' x ) -> Mphi env P = Mphi env' P. Proof. induction P ; simpl. @@ -952,7 +952,7 @@ Lemma Pmul_ok : forall P P' l, (P**P')@l == P@l * P'@l. intros. symmetry. apply H. Qed. -Lemma Mjump_xO_tail : forall M p l, +Lemma Mjump_xO_tail : forall M p l, Mphi (jump (xO p) (tail l)) M = Mphi (jump (xI p) l) M. Proof. intros. @@ -1117,7 +1117,7 @@ Qed. 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. + 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. @@ -1385,13 +1385,13 @@ Section POWER. intros. induction pe;simpl;Esimpl3. apply mkX_ok. - rewrite IHpe1;rewrite IHpe2;destruct pe1;destruct pe2;Esimpl3. + 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 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; + induction p;simpl;try rewrite IHp;try rewrite IHpe;repeat rewrite Pms_ok; repeat rewrite Pmul_ok;rrefl. Qed. diff --git a/plugins/micromega/OrderedRing.v b/plugins/micromega/OrderedRing.v index 149b773167..803dd903a9 100644 --- a/plugins/micromega/OrderedRing.v +++ b/plugins/micromega/OrderedRing.v @@ -162,7 +162,7 @@ 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. +split; intro H. setoid_replace n with ((n - m) + m) by ring. rewrite H. now rewrite Rplus_0_l. rewrite H; ring. Qed. diff --git a/plugins/micromega/Psatz.v b/plugins/micromega/Psatz.v index 9e675165fa..a2b10ebaa3 100644 --- a/plugins/micromega/Psatz.v +++ b/plugins/micromega/Psatz.v @@ -26,20 +26,20 @@ Declare ML Module "micromega_plugin". Ltac xpsatz dom d := let tac := lazymatch dom with - | Z => + | Z => (sos_Z || psatz_Z d) ; - intros __wit __varmap __ff ; - change (Tauto.eval_f (Zeval_formula (@find Z Z0 __varmap)) __ff) ; + intros __wit __varmap __ff ; + change (Tauto.eval_f (Zeval_formula (@find Z Z0 __varmap)) __ff) ; apply (ZTautoChecker_sound __ff __wit); vm_compute ; reflexivity | R => (sos_R || psatz_R d) ; - intros __wit __varmap __ff ; - change (Tauto.eval_f (Reval_formula (@find R 0%R __varmap)) __ff) ; + intros __wit __varmap __ff ; + change (Tauto.eval_f (Reval_formula (@find R 0%R __varmap)) __ff) ; apply (RTautoChecker_sound __ff __wit); vm_compute ; reflexivity | Q => (sos_Q || psatz_Q d) ; - intros __wit __varmap __ff ; - change (Tauto.eval_f (Qeval_formula (@find Q 0%Q __varmap)) __ff) ; + intros __wit __varmap __ff ; + change (Tauto.eval_f (Qeval_formula (@find Q 0%Q __varmap)) __ff) ; apply (QTautoChecker_sound __ff __wit); vm_compute ; reflexivity | _ => fail "Unsupported domain" end in tac. @@ -52,27 +52,27 @@ Ltac psatzl dom := | Z => psatzl_Z ; intros __wit __varmap __ff ; - change (Tauto.eval_f (Zeval_formula (@find Z Z0 __varmap)) __ff) ; + change (Tauto.eval_f (Zeval_formula (@find Z Z0 __varmap)) __ff) ; apply (ZTautoChecker_sound __ff __wit); vm_compute ; reflexivity | Q => - psatzl_Q ; - intros __wit __varmap __ff ; - change (Tauto.eval_f (Qeval_formula (@find Q 0%Q __varmap)) __ff) ; + psatzl_Q ; + 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 => + | R => psatzl_R ; intros __wit __varmap __ff ; - change (Tauto.eval_f (Reval_formula (@find R 0%R __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 lia := +Ltac lia := xlia ; intros __wit __varmap __ff ; - change (Tauto.eval_f (Zeval_formula (@find Z Z0 __varmap)) __ff) ; + change (Tauto.eval_f (Zeval_formula (@find Z Z0 __varmap)) __ff) ; apply (ZTautoChecker_sound __ff __wit); vm_compute ; reflexivity. diff --git a/plugins/micromega/QMicromega.v b/plugins/micromega/QMicromega.v index b266a1ab80..ae22b0c78c 100644 --- a/plugins/micromega/QMicromega.v +++ b/plugins/micromega/QMicromega.v @@ -80,7 +80,7 @@ Fixpoint Qeval_expr (env: PolEnv Q) (e: PExpr Q) : Q := end. Lemma Qeval_expr_simpl : forall env e, - Qeval_expr env e = + Qeval_expr env e = match e with | PEc c => c | PEX j => env j @@ -179,7 +179,7 @@ Definition Qnormalise := @cnf_normalise Q 0 1 Qplus Qmult Qminus Qopp Qeq_bool. Definition Qnegate := @cnf_negate Q 0 1 Qplus Qmult Qminus Qopp Qeq_bool. Definition QTautoChecker (f : BFormula (Formula Q)) (w: list QWitness) : bool := - @tauto_checker (Formula Q) (NFormula Q) + @tauto_checker (Formula Q) (NFormula Q) Qnormalise Qnegate QWitness QWeakChecker f w. diff --git a/plugins/micromega/RMicromega.v b/plugins/micromega/RMicromega.v index 2e8c3daec0..21f991ef87 100644 --- a/plugins/micromega/RMicromega.v +++ b/plugins/micromega/RMicromega.v @@ -159,7 +159,7 @@ Definition Rnormalise := @cnf_normalise Z 0%Z 1%Z Zplus Zmult Zminus Zopp Zeq_bo Definition Rnegate := @cnf_negate Z 0%Z 1%Z Zplus Zmult Zminus Zopp Zeq_bool. Definition RTautoChecker (f : BFormula (Formula Z)) (w: list RWitness) : bool := - @tauto_checker (Formula Z) (NFormula Z) + @tauto_checker (Formula Z) (NFormula Z) Rnormalise Rnegate RWitness RWeakChecker f w. diff --git a/plugins/micromega/Refl.v b/plugins/micromega/Refl.v index 801d8b2122..c86fe8fb64 100644 --- a/plugins/micromega/Refl.v +++ b/plugins/micromega/Refl.v @@ -107,7 +107,7 @@ Proof. Qed. Lemma not_make_conj_app : forall (A:Type) (t:list A) a eval - (no_middle_eval : forall d, eval d \/ ~ eval d) , + (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. diff --git a/plugins/micromega/RingMicromega.v b/plugins/micromega/RingMicromega.v index 88b53583d5..d556cd03e9 100644 --- a/plugins/micromega/RingMicromega.v +++ b/plugins/micromega/RingMicromega.v @@ -170,10 +170,10 @@ let (p, op) := f in eval_op1 op (eval_pol env p). Definition OpMult (o o' : Op1) : option Op1 := match o with | Equal => Some Equal -| NonStrict => +| NonStrict => match o' with | Equal => Some Equal - | NonEqual => None + | NonEqual => None | Strict => Some NonStrict | NonStrict => Some NonStrict end @@ -203,20 +203,20 @@ Definition OpAdd (o o': Op1) : option Op1 := end | NonEqual => match o' with | Equal => Some NonEqual - | _ => None + | _ => None end end. Lemma OpMult_sound : - forall (o o' om: Op1) (x y : R), + forall (o o' om: Op1) (x y : R), eval_op1 o x -> eval_op1 o' y -> OpMult o o' = Some om -> eval_op1 om (x * y). Proof. unfold eval_op1; destruct o; simpl; intros o' om x y H1 H2 H3. (* x == 0 *) inversion H3. rewrite H1. now rewrite (Rtimes_0_l sor). (* x ~= 0 *) -destruct o' ; inversion H3. +destruct o' ; inversion H3. (* y == 0 *) rewrite H2. now rewrite (Rtimes_0_r sor). (* y ~= 0 *) @@ -240,7 +240,7 @@ destruct o' ; inversion H3. Qed. Lemma OpAdd_sound : - forall (o o' oa : Op1) (e e' : R), + forall (o o' oa : Op1) (e e' : R), eval_op1 o e -> eval_op1 o' e' -> OpAdd o o' = Some oa -> eval_op1 oa (e + e'). Proof. unfold eval_op1; destruct o; simpl; intros o' oa e e' H1 H2 Hoa. @@ -298,7 +298,7 @@ Inductive Psatz : Type := (** Given a list [l] of NFormula and an extended polynomial expression [e], if [eval_Psatz l e] succeeds (= Some f) then [f] is a logic consequence of the conjunction of the formulae in l. - Moreover, the polynomial expression is obtained by replacing the (PsatzIn n) + Moreover, the polynomial expression is obtained by replacing the (PsatzIn n) by the nth polynomial expression in [l] and the sign is computed by the "rule of sign" *) (* Might be defined elsewhere *) @@ -310,12 +310,12 @@ Definition map_option (A B:Type) (f : A -> option B) (o : option A) : option B : Implicit Arguments map_option [A B]. -Definition map_option2 (A B C : Type) (f : A -> B -> option C) - (o: option A) (o': option B) : option C := - match o , o' with - | None , _ => None - | _ , None => None - | Some x , Some x' => f x x' +Definition map_option2 (A B C : Type) (f : A -> B -> option C) + (o: option A) (o': option B) : option C := + match o , o' with + | None , _ => None + | _ , None => None + | Some x , Some x' => f x x' end. Implicit Arguments map_option2 [A B C]. @@ -344,51 +344,51 @@ Definition nformula_times_nformula (f1 f2 : NFormula) : option NFormula := Fixpoint eval_Psatz (l : list NFormula) (e : Psatz) {struct e} : option NFormula := - match e with + match e with | PsatzIn n => Some (nth n l (Pc cO, Equal)) | PsatzSquare e => Some (Psquare cO cI cplus ctimes ceqb e , NonStrict) | PsatzMulC re e => map_option (pexpr_times_nformula re) (eval_Psatz l e) | PsatzMulE f1 f2 => map_option2 nformula_times_nformula (eval_Psatz l f1) (eval_Psatz l f2) | PsatzAdd f1 f2 => map_option2 nformula_plus_nformula (eval_Psatz l f1) (eval_Psatz l f2) - | PsatzC c => if cltb cO c then Some (Pc c, Strict) else None + | PsatzC c => if cltb cO c then Some (Pc c, Strict) else None (* This could be 0, or <> 0 -- but these cases are useless *) | PsatzZ => Some (Pc cO, Equal) (* Just to make life easier *) end. Lemma pexpr_times_nformula_correct : forall (env: PolEnv) (e: PolC) (f f' : NFormula), - eval_nformula env f -> pexpr_times_nformula e f = Some f' -> + eval_nformula env f -> pexpr_times_nformula e f = Some f' -> eval_nformula env f'. Proof. unfold pexpr_times_nformula. destruct f. intros. destruct o ; inversion H0 ; try discriminate. - simpl in *. unfold eval_pol in *. - rewrite (Pmul_ok sor.(SORsetoid) Rops_wd + simpl in *. unfold eval_pol in *. + rewrite (Pmul_ok sor.(SORsetoid) Rops_wd (Rth_ARth (SORsetoid sor) Rops_wd sor.(SORrt)) addon.(SORrm)). rewrite H. apply (Rtimes_0_r sor). Qed. - + Lemma nformula_times_nformula_correct : forall (env:PolEnv) - (f1 f2 f : NFormula), - eval_nformula env f1 -> eval_nformula env f2 -> - nformula_times_nformula f1 f2 = Some f -> + (f1 f2 f : NFormula), + eval_nformula env f1 -> eval_nformula env f2 -> + nformula_times_nformula f1 f2 = Some f -> eval_nformula env f. Proof. unfold nformula_times_nformula. destruct f1 ; destruct f2. case_eq (OpMult o o0) ; simpl ; try discriminate. intros. inversion H2 ; simpl. - unfold eval_pol. + unfold eval_pol. destruct o1; simpl; - rewrite (Pmul_ok sor.(SORsetoid) Rops_wd + rewrite (Pmul_ok sor.(SORsetoid) Rops_wd (Rth_ARth (SORsetoid sor) Rops_wd sor.(SORrt)) addon.(SORrm)); apply OpMult_sound with (3:= H);assumption. Qed. Lemma nformula_plus_nformula_correct : forall (env:PolEnv) - (f1 f2 f : NFormula), - eval_nformula env f1 -> eval_nformula env f2 -> - nformula_plus_nformula f1 f2 = Some f -> + (f1 f2 f : NFormula), + eval_nformula env f1 -> eval_nformula env f2 -> + nformula_plus_nformula f1 f2 = Some f -> eval_nformula env f. Proof. unfold nformula_plus_nformula. @@ -397,15 +397,15 @@ Proof. intros. inversion H2 ; simpl. unfold eval_pol. destruct o1; simpl; - rewrite (Padd_ok sor.(SORsetoid) Rops_wd + rewrite (Padd_ok sor.(SORsetoid) Rops_wd (Rth_ARth (SORsetoid sor) Rops_wd sor.(SORrt)) addon.(SORrm)); apply OpAdd_sound with (3:= H);assumption. Qed. -Lemma eval_Psatz_Sound : +Lemma eval_Psatz_Sound : forall (l : list NFormula) (env : PolEnv), (forall (f : NFormula), In f l -> eval_nformula env f) -> - forall (e : Psatz) (f : NFormula), eval_Psatz l e = Some f -> + forall (e : Psatz) (f : NFormula), eval_Psatz l e = Some f -> eval_nformula env f. Proof. induction e. @@ -416,17 +416,17 @@ Proof. apply H ; congruence. (* index is out-of-bounds *) inversion H0. - rewrite e. simpl. + rewrite e. simpl. now apply addon.(SORrm).(morph0). (* PsatzSquare *) simpl. intros. inversion H0. simpl. unfold eval_pol. - rewrite (Psquare_ok sor.(SORsetoid) Rops_wd + rewrite (Psquare_ok sor.(SORsetoid) Rops_wd (Rth_ARth (SORsetoid sor) Rops_wd sor.(SORrt)) addon.(SORrm)); now apply (Rtimes_square_nonneg sor). (* PsatzMulC *) simpl. - intro. + intro. case_eq (eval_Psatz l e) ; simpl ; intros. apply IHe in H0. apply pexpr_times_nformula_correct with (1:=H0) (2:= H1). @@ -441,7 +441,7 @@ Proof. (* PsatzAdd *) simpl ; intro. case_eq (eval_Psatz l e1) ; simpl ; try discriminate. - case_eq (eval_Psatz l e2) ; simpl ; try discriminate. + case_eq (eval_Psatz l e2) ; simpl ; try discriminate. intros. apply IHe1 in H1. apply IHe2 in H0. apply (nformula_plus_nformula_correct env n0 n) ; assumption. @@ -457,14 +457,14 @@ Proof. Qed. Fixpoint ge_bool (n m : nat) : bool := - match n with - | O => match m with + match n with + | O => match m with | O => true | S _ => false end - | S n => match m with + | S n => match m with | O => true - | S m => ge_bool n m + | S m => ge_bool n m end end. @@ -483,7 +483,7 @@ Qed. Fixpoint xhyps_of_psatz (base:nat) (acc : list nat) (prf : Psatz) : list nat := - match prf with + match prf with | PsatzC _ | PsatzZ | PsatzSquare _ => acc | PsatzMulC _ prf => xhyps_of_psatz base acc prf | PsatzAdd e1 e2 | PsatzMulE e1 e2 => xhyps_of_psatz base (xhyps_of_psatz base acc e2) e1 @@ -495,7 +495,7 @@ Fixpoint xhyps_of_psatz (base:nat) (acc : list nat) (prf : Psatz) : list nat := forall env p, eval_pexpr env p == eval_pol env (normalise_pexpr p) *) (*****) -Definition paddC := PaddC cplus. +Definition paddC := PaddC cplus. Definition psubC := PsubC cminus. Definition PsubC_ok : forall c P env, eval_pol env (psubC P c) == eval_pol env P - [c] := @@ -536,7 +536,7 @@ Lemma check_inconsistent_sound : check_inconsistent (p, op) = true -> forall env, ~ eval_op1 op (eval_pol env p). Proof. intros p op H1 env. unfold check_inconsistent in H1. -destruct op; simpl ; +destruct op; simpl ; (*****) destruct p ; simpl; try discriminate H1; try rewrite <- addon.(SORrm).(morph0); trivial. @@ -547,7 +547,7 @@ apply cltb_sound in H1. now apply -> (Rlt_nge sor). Qed. Definition check_normalised_formulas : list NFormula -> Psatz -> bool := - fun l cm => + fun l cm => match eval_Psatz l cm with | None => false | Some f => check_inconsistent f @@ -640,14 +640,14 @@ let (lhs, op, rhs) := f in Lemma eval_pol_sub : forall env lhs rhs, eval_pol env (psub lhs rhs) == eval_pol env lhs - eval_pol env rhs. Proof. intros. - apply (Psub_ok sor.(SORsetoid) Rops_wd + apply (Psub_ok sor.(SORsetoid) Rops_wd (Rth_ARth (SORsetoid sor) Rops_wd sor.(SORrt)) addon.(SORrm)). Qed. Lemma eval_pol_add : forall env lhs rhs, eval_pol env (padd lhs rhs) == eval_pol env lhs + eval_pol env rhs. Proof. intros. - apply (Padd_ok sor.(SORsetoid) Rops_wd + apply (Padd_ok sor.(SORsetoid) Rops_wd (Rth_ARth (SORsetoid sor) Rops_wd sor.(SORrt)) addon.(SORrm)). Qed. @@ -656,7 +656,7 @@ Proof. intros. apply (norm_aux_spec sor.(SORsetoid) Rops_wd (Rth_ARth (SORsetoid sor) Rops_wd sor.(SORrt)) addon.(SORrm) addon.(SORpower) ). Qed. - + Theorem normalise_sound : forall (env : PolEnv) (f : Formula), @@ -694,7 +694,7 @@ Definition xnormalise (t:Formula) : list (NFormula) := let lhs := norm lhs in let rhs := norm rhs in match o with - | OpEq => + | OpEq => (psub lhs rhs, Strict)::(psub rhs lhs , Strict)::nil | OpNEq => (psub lhs rhs,Equal) :: nil | OpGt => (psub rhs lhs,NonStrict) :: nil @@ -716,7 +716,7 @@ Proof. unfold cnf_normalise, xnormalise ; simpl ; intros env t. unfold eval_cnf. destruct t as [lhs o rhs]; case_eq o ; simpl; - repeat rewrite eval_pol_sub ; repeat rewrite <- eval_pol_norm in * ; + repeat rewrite eval_pol_sub ; repeat rewrite <- eval_pol_norm in * ; generalize (eval_pexpr env lhs); generalize (eval_pexpr env rhs) ; intros z1 z2 ; intros. (**) @@ -751,7 +751,7 @@ Proof. unfold cnf_negate, xnegate ; simpl ; intros env t. unfold eval_cnf. destruct t as [lhs o rhs]; case_eq o ; simpl; - repeat rewrite eval_pol_sub ; repeat rewrite <- eval_pol_norm in * ; + repeat rewrite eval_pol_sub ; repeat rewrite <- eval_pol_norm in * ; generalize (eval_pexpr env lhs); generalize (eval_pexpr env rhs) ; intros z1 z2 ; intros ; intuition. (**) @@ -774,7 +774,7 @@ Proof. intros. destruct d ; simpl. generalize (eval_pol env p); intros. - destruct o ; simpl. + 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. @@ -787,7 +787,7 @@ Fixpoint xdenorm (jmp : positive) (p: Pol C) : PExpr C := match p with | Pc c => PEc c | Pinj j p => xdenorm (Pplus j jmp ) p - | PX p j q => PEadd + | PX p j q => PEadd (PEmul (xdenorm jmp p) (PEpow (PEX _ jmp) (Npos j))) (xdenorm (Psucc jmp) q) end. @@ -802,7 +802,7 @@ Proof. intros. rewrite Pplus_succ_permute_r. rewrite <- IHp. - symmetry. + symmetry. rewrite Pplus_comm. rewrite Pjump_Pplus. reflexivity. (* PX *) @@ -821,7 +821,7 @@ Proof. Qed. Definition denorm (p : Pol C) := xdenorm xH p. - + Lemma denorm_correct : forall p env, eval_pol env p == eval_pexpr env (denorm p). Proof. unfold denorm. @@ -836,25 +836,25 @@ Proof. unfold Env.tail. rewrite xdenorm_correct. change (Psucc xH) with 2%positive. - rewrite addon.(SORpower).(rpow_pow_N). + rewrite addon.(SORpower).(rpow_pow_N). simpl. reflexivity. Qed. - + (** Some syntactic simplifications of expressions *) Definition simpl_cone (e:Psatz) : Psatz := match e with - | PsatzSquare t => + | PsatzSquare t => match t with | Pc c => if ceqb cO c then PsatzZ else PsatzC (ctimes c c) | _ => PsatzSquare t end - | PsatzMulE t1 t2 => + | PsatzMulE t1 t2 => match t1 , t2 with - | PsatzZ , x => PsatzZ - | x , PsatzZ => PsatzZ + | PsatzZ , x => PsatzZ + | x , PsatzZ => PsatzZ | PsatzC c , PsatzC c' => PsatzC (ctimes c c') | PsatzC p1 , PsatzMulE (PsatzC p2) x => PsatzMulE (PsatzC (ctimes p1 p2)) x | PsatzC p1 , PsatzMulE x (PsatzC p2) => PsatzMulE (PsatzC (ctimes p1 p2)) x @@ -865,7 +865,7 @@ Definition simpl_cone (e:Psatz) : Psatz := | _ , PsatzC c => if ceqb cI c then t1 else PsatzMulE t1 t2 | _ , _ => e end - | PsatzAdd t1 t2 => + | PsatzAdd t1 t2 => match t1 , t2 with | PsatzZ , x => x | x , PsatzZ => x diff --git a/plugins/micromega/Tauto.v b/plugins/micromega/Tauto.v index 42e0acb582..b1d0217685 100644 --- a/plugins/micromega/Tauto.v +++ b/plugins/micromega/Tauto.v @@ -20,14 +20,14 @@ Set Implicit Arguments. Inductive BFormula (A:Type) : Type := - | TT : BFormula A + | TT : BFormula A | FF : BFormula A | X : Prop -> BFormula A - | A : A -> 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. + | I : BFormula A-> BFormula A-> BFormula A. Fixpoint eval_f (A:Type) (ev:A -> Prop ) (f:BFormula A) {struct f}: Prop := match f with @@ -42,7 +42,7 @@ Set Implicit Arguments. end. - Lemma map_simpl : forall A B f l, @map A B f l = match l with + 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. @@ -57,7 +57,7 @@ Set Implicit Arguments. Variable Env : Type. Variable Term : Type. Variable eval : Env -> Term -> Prop. - Variable Term' : Type. + Variable Term' : Type. Variable eval' : Env -> Term' -> Prop. @@ -78,17 +78,17 @@ Set Implicit Arguments. 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 @@ -96,14 +96,14 @@ Set Implicit Arguments. | 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 => + | 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. @@ -111,7 +111,7 @@ Set Implicit Arguments. 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. @@ -258,8 +258,8 @@ Set Implicit Arguments. unfold and_cnf in H. simpl in H. destruct (eval_cnf_app _ _ _ H). - generalize (IHf1 _ _ H0). - generalize (IHf2 _ _ H1). + generalize (IHf1 _ _ H0). + generalize (IHf2 _ _ H1). simpl. tauto. Qed. @@ -267,13 +267,13 @@ Set Implicit Arguments. 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 + | e::f => match l with | nil => false | c::l => match checker e c with | true => cnf_checker f l diff --git a/plugins/micromega/VarMap.v b/plugins/micromega/VarMap.v index ed204d92b6..c0b86f5ed3 100644 --- a/plugins/micromega/VarMap.v +++ b/plugins/micromega/VarMap.v @@ -17,21 +17,21 @@ Require Import Coq.Arith.Max. Require Import List. Set Implicit Arguments. -(* I have addded a Leaf constructor to the varmap data structure (/plugins/ring/Quote.v) +(* I have addded a Leaf constructor to the varmap data structure (/plugins/ring/Quote.v) -- this is harmless and spares a lot of Empty. - This means smaller proof-terms. + 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 + | Empty : t + | Leaf : A -> t | Node : t -> A -> t -> t . - + Fixpoint find (vm : t ) (p:positive) {struct vm} : A := match vm with | Empty => default @@ -49,7 +49,7 @@ Section MakeVarMap. - Definition jump (j:positive) (l:off_map ) := + Definition jump (j:positive) (l:off_map ) := let (o,m) := l in match o with | None => (Some j,m) @@ -74,7 +74,7 @@ Section MakeVarMap. Lemma psucc : forall p, (match p with | xI y' => xO (Psucc y') | xO y' => xI y' - | 1%positive => 2%positive + | 1%positive => 2%positive end) = (p+1)%positive. Proof. destruct p. @@ -84,7 +84,7 @@ Section MakeVarMap. reflexivity. Qed. - Lemma jump_Pplus : forall i j l, + Lemma jump_Pplus : forall i j l, (jump (i + j) l) = (jump i (jump j l)). Proof. unfold jump. @@ -96,7 +96,7 @@ Section MakeVarMap. Qed. Lemma jump_simpl : forall p l, - jump p l = + jump p l = match p with | xH => tail l | xO p => jump p (jump p l) @@ -116,15 +116,15 @@ Section MakeVarMap. Qed. Ltac jump_s := - repeat + 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. + Proof. unfold tail. intros. repeat rewrite <- jump_Pplus. @@ -132,7 +132,7 @@ Section MakeVarMap. reflexivity. Qed. - Lemma jump_Psucc : forall j l, + Lemma jump_Psucc : forall j l, (jump (Psucc j) l) = (jump 1 (jump j l)). Proof. intros. @@ -162,14 +162,14 @@ Section MakeVarMap. reflexivity. Qed. - - Lemma nth_spec : forall p l, - nth p l = + + 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. + end. Proof. unfold nth. destruct l. diff --git a/plugins/micromega/ZCoeff.v b/plugins/micromega/ZCoeff.v index ced67e39d0..f27cd15e3b 100644 --- a/plugins/micromega/ZCoeff.v +++ b/plugins/micromega/ZCoeff.v @@ -56,7 +56,7 @@ Proof. destruct sor.(SORsetoid). apply Equivalence_Transitive. Qed. - + Add Relation R req reflexivity proved by sor.(SORsetoid).(@Equivalence_Reflexive _ _) diff --git a/plugins/micromega/ZMicromega.v b/plugins/micromega/ZMicromega.v index 70eb2331c7..b02a9850eb 100644 --- a/plugins/micromega/ZMicromega.v +++ b/plugins/micromega/ZMicromega.v @@ -33,7 +33,7 @@ Ltac inv H := inversion H ; try subst ; clear H. 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)). @@ -100,7 +100,7 @@ match o with | OpGt => Zgt end. -Definition Zeval_formula (env : PolEnv Z) (f : Formula Z):= +Definition Zeval_formula (env : PolEnv Z) (f : Formula Z):= let (lhs, op, rhs) := f in (Zeval_op2 op) (Zeval_expr env lhs) (Zeval_expr env rhs). @@ -109,16 +109,16 @@ Definition Zeval_formula' := Lemma Zeval_formula_compat : forall env f, Zeval_formula env f <-> Zeval_formula' env f. Proof. - destruct f ; simpl. + destruct f ; simpl. rewrite Zeval_expr_compat. rewrite Zeval_expr_compat. unfold eval_expr. - generalize (eval_pexpr Zplus Zmult Zminus Zopp (fun x : Z => x) + generalize (eval_pexpr Zplus Zmult Zminus Zopp (fun x : Z => x) (fun x : N => x) (pow_N 1 Zmult) env Flhs). - generalize ((eval_pexpr Zplus Zmult Zminus Zopp (fun x : Z => x) + generalize ((eval_pexpr Zplus Zmult Zminus Zopp (fun x : Z => x) (fun x : N => x) (pow_N 1 Zmult) env Frhs)). destruct Fop ; simpl; intros ; intuition (auto with zarith). Qed. - + Definition eval_nformula := eval_nformula 0 Zplus Zmult (@eq Z) Zle Zlt (fun x => x) . @@ -131,7 +131,7 @@ match o with | NonStrict => fun x : Z => 0 <= x end. - + Lemma Zeval_nformula_dec : forall env d, (eval_nformula env d) \/ ~ (eval_nformula env d). Proof. intros. @@ -179,13 +179,13 @@ Proof. intros. apply (eval_pol_norm Zsor ZSORaddon). Qed. - + Definition xnormalise (t:Formula Z) : list (NFormula Z) := let (lhs,o,rhs) := t in let lhs := norm lhs in let rhs := norm rhs in match o with - | OpEq => + | OpEq => ((psub lhs (padd rhs (Pc 1))),NonStrict)::((psub rhs (padd lhs (Pc 1))),NonStrict)::nil | OpNEq => (psub lhs rhs,Equal) :: nil | OpGt => (psub rhs lhs,NonStrict) :: nil @@ -218,7 +218,7 @@ Proof. intuition (auto with zarith). Transparent padd. Qed. - + Definition xnegate (t:RingMicromega.Formula Z) : list (NFormula Z) := let (lhs,o,rhs) := t in let lhs := norm lhs in @@ -331,11 +331,11 @@ Definition makeLbCut (v:PExprC Z) (q:Q) : NFormula Z := 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. + destruct f. simpl. intros ; subst ; simpl in *. split; auto with zarith. @@ -346,9 +346,9 @@ Qed. - b is the constant - a is the gcd of the other coefficient. *) -Require Import Znumtheory. +Require Import Znumtheory. -Definition isZ0 (x:Z) := +Definition isZ0 (x:Z) := match x with | Z0 => true | _ => false @@ -371,7 +371,7 @@ Fixpoint Zgcd_pol (p : PolC Z) : (Z * Z) := match p with | Pc c => (0,c) | Pinj _ p => Zgcd_pol p - | PX p _ q => + | PX p _ q => let (g1,c1) := Zgcd_pol p in let (g2,c2) := Zgcd_pol q in (ZgcdM (ZgcdM g1 c1) g2 , c2) @@ -393,7 +393,7 @@ Inductive Zdivide_pol (x:Z): PolC Z -> Prop := | Zdiv_PX : forall p q, Zdivide_pol x p -> Zdivide_pol x q -> forall j, Zdivide_pol x (PX p j q). -Lemma Zdiv_pol_correct : forall a p, 0 < a -> Zdivide_pol a p -> +Lemma Zdiv_pol_correct : forall a p, 0 < a -> Zdivide_pol a p -> forall env, eval_pol env p = a * eval_pol env (Zdiv_pol p a). Proof. intros until 2. @@ -441,7 +441,7 @@ Proof. constructor. auto. constructor ; auto. Qed. - + Lemma Zdivide_pol_one : forall p, Zdivide_pol 1 p. Proof. induction p ; constructor ; auto. @@ -458,15 +458,15 @@ Proof. rewrite <- Hq, Hb, Ha. ring. Qed. -Lemma Zdivide_pol_sub : forall p a b, - 0 < Zgcd a b -> - Zdivide_pol a (PsubC Zminus p b) -> +Lemma Zdivide_pol_sub : forall p a b, + 0 < Zgcd a b -> + Zdivide_pol a (PsubC Zminus p b) -> Zdivide_pol (Zgcd a b) p. Proof. induction p. simpl. intros. inversion H0. - constructor. + constructor. apply Zgcd_minus ; auto. intros. constructor. @@ -480,8 +480,8 @@ Proof. apply IHp2 ; assumption. Qed. -Lemma Zdivide_pol_sub_0 : forall p a, - Zdivide_pol a (PsubC Zminus p 0) -> +Lemma Zdivide_pol_sub_0 : forall p a, + Zdivide_pol a (PsubC Zminus p 0) -> Zdivide_pol a p. Proof. induction p. @@ -499,7 +499,7 @@ Proof. Qed. -Lemma Zgcd_pol_div : forall p g c, +Lemma Zgcd_pol_div : forall p g c, Zgcd_pol p = (g, c) -> Zdivide_pol g (PsubC Zminus p c). Proof. induction p ; simpl. @@ -541,7 +541,7 @@ Proof. Qed. - + Lemma Zgcd_pol_correct_lt : forall p env g c, Zgcd_pol p = (g,c) -> 0 < g -> eval_pol env p = g * (eval_pol env (Zdiv_pol (PsubC Zminus p c) g)) + c. Proof. @@ -555,9 +555,9 @@ Qed. -Definition makeCuttingPlane (p : PolC Z) : PolC Z * Z := +Definition makeCuttingPlane (p : PolC Z) : PolC Z * Z := let (g,c) := Zgcd_pol p in - if Zgt_bool g Z0 + if Zgt_bool g Z0 then (Zdiv_pol (PsubC Zminus p c) g , Zopp (ceiling (Zopp c) g)) else (p,Z0). @@ -594,7 +594,7 @@ Proof. destruct z ; try discriminate. reflexivity. Qed. - + @@ -609,37 +609,37 @@ Definition check_inconsistent := check_inconsistent 0 Zeq_bool Zle_bool. Fixpoint ZChecker (l:list (NFormula Z)) (pf : ZArithProof) {struct pf} : bool := match pf with - | DoneProof => false - | RatProof w pf => + | DoneProof => false + | RatProof w pf => match eval_Psatz l w with | None => false - | Some f => + | Some f => if check_inconsistent f then true else ZChecker (f::l) pf end - | CutProof w pf => + | CutProof w pf => match eval_Psatz l w with | None => false - | Some f => + | Some f => match genCuttingPlane f with | None => true | Some cp => ZChecker (nformula_of_cutting_plane cp::l) pf end end - | EnumProof w1 w2 pf => + | EnumProof w1 w2 pf => match eval_Psatz l w1 , eval_Psatz l w2 with - | Some f1 , Some f2 => + | Some f1 , Some f2 => match genCuttingPlane f1 , genCuttingPlane f2 with - |Some (e1,z1,op1) , Some (e2,z2,op2) => + |Some (e1,z1,op1) , Some (e2,z2,op2) => match op1 , op2 with - | NonStrict , NonStrict => + | NonStrict , NonStrict => if is_pol_Z0 (padd e1 e2) then (fix label (pfs:list ZArithProof) := - fun lb ub => + fun lb ub => match pfs with | nil => if Zgt_bool lb ub then true else false - | pf::rsr => andb (ZChecker ((psub e1 (Pc lb), Equal) :: l) pf) (label rsr (Zplus lb 1%Z) ub) + | pf::rsr => andb (ZChecker ((psub e1 (Pc lb), Equal) :: l) pf) (label rsr (Zplus lb 1%Z) ub) end) pf (Zopp z1) z2 else false @@ -693,18 +693,18 @@ Proof. Qed. -Lemma eval_Psatz_sound : forall env w l f', - make_conj (eval_nformula env) l -> +Lemma eval_Psatz_sound : forall env w l f', + make_conj (eval_nformula env) l -> eval_Psatz l w = Some f' -> eval_nformula env f'. Proof. intros. apply (eval_Psatz_Sound Zsor ZSORaddon) with (l:=l) (e:= w) ; auto. - apply make_conj_in ; auto. + apply make_conj_in ; auto. Qed. -Lemma makeCuttingPlane_sound : forall env e e' c, - eval_nformula env (e, NonStrict) -> - makeCuttingPlane e = (e',c) -> +Lemma makeCuttingPlane_sound : forall env e e' c, + eval_nformula env (e, NonStrict) -> + makeCuttingPlane e = (e',c) -> eval_nformula env (nformula_of_cutting_plane (e', c, NonStrict)). Proof. unfold nformula_of_cutting_plane. @@ -728,10 +728,10 @@ Proof. (* g <= 0 *) intros. inv H2. auto with zarith. Qed. - -Lemma cutting_plane_sound : forall env f p, - eval_nformula env f -> + +Lemma cutting_plane_sound : forall env f p, + eval_nformula env f -> genCuttingPlane f = Some p -> eval_nformula env (nformula_of_cutting_plane p). Proof. @@ -758,25 +758,25 @@ Proof. rewrite (RingMicromega.eval_pol_add Zsor ZSORaddon). simpl. auto with zarith. (* Strict *) - destruct p as [[e' z] op]. + destruct p as [[e' z] op]. case_eq (makeCuttingPlane (PsubC Zminus e 1)). intros. inv H1. apply makeCuttingPlane_sound with (env:=env) (2:= H). simpl in *. - rewrite (RingMicromega.PsubC_ok Zsor ZSORaddon). + rewrite (RingMicromega.PsubC_ok Zsor ZSORaddon). auto with zarith. (* NonStrict *) - destruct p as [[e' z] op]. + destruct p as [[e' z] op]. case_eq (makeCuttingPlane e). intros. inv H1. apply makeCuttingPlane_sound with (env:=env) (2:= H). assumption. -Qed. +Qed. -Lemma genCuttingPlaneNone : forall env f, - genCuttingPlane f = None -> +Lemma genCuttingPlaneNone : forall env f, + genCuttingPlane f = None -> eval_nformula env f -> False. Proof. unfold genCuttingPlane. @@ -784,7 +784,7 @@ Proof. destruct o. case_eq (Zgcd_pol p) ; intros g c. case_eq (Zgt_bool g 0 && (Zgt_bool c 0 && negb (Zeq_bool (Zgcd g c) g))). - intros. + intros. flatten_bool. rewrite negb_true_iff in H5. apply Zeq_bool_neq in H5. @@ -805,7 +805,7 @@ Proof. destruct (makeCuttingPlane p) ; discriminate. Qed. - + Lemma ZChecker_sound : forall w l, ZChecker l w = true -> forall env, make_impl (eval_nformula env) l False. Proof. induction w using (well_founded_ind (well_founded_ltof _ bdepth)). @@ -815,7 +815,7 @@ Proof. (* RatProof *) simpl. intro l. case_eq (eval_Psatz l w) ; [| discriminate]. - intros f Hf. + intros f Hf. case_eq (check_inconsistent f). intros. apply (checker_nf_sound Zsor ZSORaddon l w). @@ -831,7 +831,7 @@ Proof. rewrite <- make_conj_impl in H2. rewrite make_conj_cons in H2. rewrite <- make_conj_impl. - intro. + intro. apply H2. split ; auto. apply eval_Psatz_sound with (2:= Hf) ; assumption. @@ -840,7 +840,7 @@ Proof. intro l. case_eq (eval_Psatz l w) ; [ | discriminate]. intros f' Hlc. - case_eq (genCuttingPlane f'). + case_eq (genCuttingPlane f'). intros. assert (make_impl (eval_nformula env) (nformula_of_cutting_plane p::l) False). eapply (H pf) ; auto. @@ -850,7 +850,7 @@ Proof. rewrite <- make_conj_impl in H2. rewrite make_conj_cons in H2. rewrite <- make_conj_impl. - intro. + intro. apply H2. split ; auto. apply eval_Psatz_sound with (env:=env) in Hlc. @@ -887,7 +887,7 @@ Proof. unfold RingMicromega.eval_nformula in H4. change (RingMicromega.eval_pol 0 Zplus Zmult (fun x : Z => x)) with eval_pol in H4. unfold eval_op1 in H4. - rewrite eval_pol_add in H4. simpl in H4. + rewrite eval_pol_add in H4. simpl in H4. auto with zarith. (**) apply is_pol_Z0_eval_pol with (env := env) in H0. @@ -900,7 +900,7 @@ Proof. unfold RingMicromega.eval_nformula in H3. change (RingMicromega.eval_pol 0 Zplus Zmult (fun x : Z => x)) with eval_pol in H3. unfold eval_op1 in H3. - rewrite eval_pol_add in H3. simpl in H3. + rewrite eval_pol_add in H3. simpl in H3. omega. revert H5. set (FF := (fix label (pfs : list ZArithProof) (lb ub : Z) {struct pfs} : bool := @@ -911,7 +911,7 @@ Proof. label rsr (lb + 1)%Z ub)%bool end)). intros. - assert (HH :forall x, -z1 <= x <= z2 -> exists pr, + assert (HH :forall x, -z1 <= x <= z2 -> exists pr, (In pr pf /\ ZChecker ((PsubC Zminus p1 x,Equal) :: l) pr = true)%Z). clear H. @@ -972,7 +972,7 @@ Fixpoint xhyps_of_pt (base:nat) (acc : list nat) (pt:ZArithProof) : list nat := | DoneProof => acc | RatProof c pt => xhyps_of_pt (S base ) (xhyps_of_psatz base acc c) pt | CutProof c pt => xhyps_of_pt (S base ) (xhyps_of_psatz base acc c) pt - | EnumProof c1 c2 l => + | EnumProof c1 c2 l => let acc := xhyps_of_psatz base (xhyps_of_psatz base acc c2) c1 in List.fold_left (xhyps_of_pt (S base)) l acc end. @@ -989,7 +989,7 @@ Definition hyps_of_pt (pt : ZArithProof) : list nat := xhyps_of_pt 0 nil pt. Open Scope Z_scope. - + (** To ease bindings from ml code **) (*Definition varmap := Quote.varmap.*) Definition make_impl := Refl.make_impl. @@ -1019,5 +1019,5 @@ Definition n_of_Z (z:Z) : BinNat.N := (* Local Variables: *) (* coding: utf-8 *) (* End: *) - + diff --git a/plugins/micromega/certificate.ml b/plugins/micromega/certificate.ml index 2a1c2fe225..c5760229c5 100644 --- a/plugins/micromega/certificate.ml +++ b/plugins/micromega/certificate.ml @@ -47,28 +47,28 @@ 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 -> + 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 @@ -79,8 +79,8 @@ end module Poly : (* A polynomial is a map of monomials *) - (* - This is probably a naive implementation + (* + 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. *) @@ -106,22 +106,22 @@ struct type t = num P.t - let pp o p = P.iter (fun k v -> + let pp o p = P.iter (fun k v -> if compare_num v (Int 0) <> 0 - then + 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 + 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 = + 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 @@ -129,27 +129,27 @@ struct (* The addition of a monomial *) let add : Monomial.t -> num -> t -> t = - fun mn v p -> + 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 .... + (** 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 -> + 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 -> + fun p1 p2 -> fold (fun mn v res -> addition (mult mn v p2) res ) p1 empty @@ -181,7 +181,7 @@ let z_spec = { mult = Mc.zmult; eqb = Mc.zeq_bool } - + let q_spec = { bigint_to_number = (fun x -> {Mc.qnum = Ml2C.bigint x; Mc.qden = Mc.XH}); @@ -198,53 +198,53 @@ let r_spec = z_spec let dev_form n_spec p = - let rec dev_form 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) -> + | Mc.PEmul(p1,p2) -> let p1 = dev_form p1 in let p2 = dev_form p2 in - Poly.product p1 p2 + 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) -> + | Mc.PEpow(p,n) -> let p = dev_form p in let n = C2Ml.n n in - let rec pow n = - if n = 0 + 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 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 + then mn else Mc.PEmul(mn,acc)) - mn + mn (Mc.PEc (Mc.Zpos Mc.XH)) - -let list_to_polynomial vars l = + +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 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 + | c::l -> if c =/ (Int 0) then xtopoly p (i+1) l else let c = Mc.PEc (Ml2C.bigint (numerator c)) in - let mn = + 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 = @@ -259,54 +259,54 @@ let rec fixpoint f x = -let rec_simpl_cone n_spec e = - let simpl_cone = +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.PsatzMulE(t1, t2) -> + | Mc.PsatzMulE(t1, t2) -> simpl_cone (Mc.PsatzMulE (rec_simpl_cone t1, rec_simpl_cone t2)) - | Mc.PsatzAdd(t1,t2) -> + | Mc.PsatzAdd(t1,t2) -> simpl_cone (Mc.PsatzAdd (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 + +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 = + + let rec cone_list c l = match c with | Mc.PsatzAdd (x,r) -> cone_list r (x::l) | _ -> c :: l in - + let factorise c1 c2 = match c1 , c2 with - | Mc.PsatzMulC(x,y) , Mc.PsatzMulC(x',y') -> + | Mc.PsatzMulC(x,y) , Mc.PsatzMulC(x',y') -> if x = x' then Some (Mc.PsatzMulC(x, Mc.PsatzAdd(y,y'))) else None - | Mc.PsatzMulE(x,y) , Mc.PsatzMulE(x',y') -> + | Mc.PsatzMulE(x,y) , Mc.PsatzMulE(x',y') -> if x = x' then Some (Mc.PsatzMulE(x, Mc.PsatzAdd(y,y'))) else None | _ -> None in - + let rec rebuild_cone l pending = match l with | [] -> (match pending with | None -> Mc.PsatzZ | Some p -> p ) - | e::l -> + | e::l -> (match pending with - | None -> rebuild_cone l (Some e) + | None -> rebuild_cone l (Some e) | Some p -> (match factorise p e with | None -> Mc.PsatzAdd(p, rebuild_cone l (Some e)) | Some f -> rebuild_cone l (Some f) ) @@ -316,15 +316,15 @@ let factorise_linear_cone c = -(* The binding with Fourier might be a bit obsolete +(* 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 + a1.p1 + ... an.pn + b1.q1 +... + bn.qn + c = 0 where pi >= 0 qi > 0 - ai >= 0 + ai >= 0 bi >= 0 Sum bi + c >= 1 This is a linear problem: each monomial is considered as a variable. @@ -343,96 +343,96 @@ open Mfourier (* fold_left followed by a rev ! *) -let constrain_monomial mn l = +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 ; + 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 ; + { 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 = + +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 ; + | (_,_)::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.Strict -> "> 0" + | Mc.NonStrict -> ">= 0" | Mc.Equal -> "= 0" | Mc.NonEqual -> "<> 0" -(* If the certificate includes at least one strict inequality, +(* 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 = + 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 = + 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 + (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 ; + {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 + +(* 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 make_certificate n_spec (cert,li) = let bint_to_cst = n_spec.bigint_to_number in match cert with | [] -> failwith "empty_certificate" - | e::cert' -> + | e::cert' -> let cst = match compare_big_int e zero_big_int with | 0 -> Mc.PsatzZ - | 1 -> Mc.PsatzC (bint_to_cst e) - | _ -> failwith "positivity error" + | 1 -> Mc.PsatzC (bint_to_cst e) + | _ -> failwith "positivity error" in let rec scalar_product cert l = match cert with | [] -> Mc.PsatzZ | c::cert -> match l with | [] -> failwith "make_certificate(1)" - | i::l -> + | i::l -> let r = scalar_product cert l in match compare_big_int c zero_big_int with | -1 -> Mc.PsatzAdd ( - Mc.PsatzMulC (Mc.Pc ( bint_to_cst c), Mc.PsatzIn (Ml2C.nat i)), + Mc.PsatzMulC (Mc.Pc ( bint_to_cst c), Mc.PsatzIn (Ml2C.nat i)), r) | 0 -> r | _ -> Mc.PsatzAdd ( Mc.PsatzMulE (Mc.PsatzC (bint_to_cst c), Mc.PsatzIn (Ml2C.nat i)), r) in - - ((factorise_linear_cone + + ((factorise_linear_cone (simplify_cone n_spec (Mc.PsatzAdd (cst, scalar_product cert' li))))) @@ -440,59 +440,59 @@ exception Found of Monomial.t exception Strict -let primal l = +let primal l = let vr = ref 0 in let module Mmn = Map.Make(Monomial) in let vect_of_poly map p = - Poly.fold (fun mn vl (map,vect) -> - if mn = Monomial.const + Poly.fold (fun mn vl (map,vect) -> + if mn = Monomial.const then (map,vect) - else + else let (mn,m) = try (Mmn.find mn map,map) with Not_found -> let res = (!vr, Mmn.add mn !vr map) in incr vr ; res in (m,if sign_num vl = 0 then vect else (mn,vl)::vect)) p (map,[]) in - + let op_op = function Mc.NonStrict -> Ge |Mc.Equal -> Eq | _ -> raise Strict in let cmp x y = Pervasives.compare (fst x) (fst y) in snd (List.fold_right (fun (p,op) (map,l) -> - let (mp,vect) = vect_of_poly map p in + let (mp,vect) = vect_of_poly map p in let cstr = {coeffs = List.sort cmp vect; op = op_op op ; cst = minus_num (Poly.get Monomial.const p)} in (mp,cstr::l)) l (Mmn.empty,[])) -let dual_raw_certificate (l: (Poly.t * Mc.op1) list) = +let dual_raw_certificate (l: (Poly.t * Mc.op1) list) = (* List.iter (fun (p,op) -> Printf.fprintf stdout "%a %s 0\n" Poly.pp p (string_of_op op) ) l ; *) - - + + let sys = build_linear_system l in - try + try match Fourier.find_point sys with | Inr _ -> None - | Inl cert -> Some (rats_to_ints (Vect.to_list cert)) + | Inl 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); + with x -> + if debug + then (Printf.printf "raw certificate %s" (Printexc.to_string x); flush stdout) ; None -let raw_certificate l = - try +let raw_certificate l = + try let p = primal l in match Fourier.find_point p with - | Inr prf -> - if debug then Printf.printf "AProof : %a\n" pp_proof prf ; + | Inr prf -> + if debug then Printf.printf "AProof : %a\n" pp_proof prf ; let cert = List.map (fun (x,n) -> x+1,n) (fst (List.hd (Proof.mk_proof p prf))) in - if debug then Printf.printf "CProof : %a" Vect.pp_vect cert ; + if debug then Printf.printf "CProof : %a" Vect.pp_vect cert ; Some (rats_to_ints (Vect.to_list cert)) | Inl _ -> None - with Strict -> + with Strict -> (* Fourier elimination should handle > *) - dual_raw_certificate l + dual_raw_certificate l let simple_linear_prover (*to_constant*) l = @@ -500,26 +500,26 @@ let simple_linear_prover (*to_constant*) l = match raw_certificate lc with | None -> None (* No certificate *) | Some cert -> (* make_certificate to_constant*)Some (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 + let (l1,l') = List.partition (fun (x,_) -> if snd x = Mc.NonEqual then true else false) li in - let l' = List.map + let l' = List.map (fun ((x,y),i) -> match y with Mc.NonEqual -> failwith "cannot happen" | y -> ((dev_form n_spec x, y),i)) l' in - - simple_linear_prover (*n_spec*) l' + + 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) -let linear_prover_with_cert spec l = +let linear_prover_with_cert spec l = match linear_prover spec l with | None -> None | Some cert -> Some (make_certificate spec cert) @@ -529,21 +529,21 @@ let linear_prover_with_cert spec l = (* zprover.... *) (* I need to gather the set of variables ---> - Then go for fold + Then go for fold Once I have an interval, I need a certificate : 2 other fourier elims. - (I could probably get the certificate directly + (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) + let monomials = List.fold_left (fun acc p -> Poly.addition p acc) (Poly.constant (Int 0)) l' in - let monomials = Poly.fold + 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 ; + (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) @@ -552,106 +552,106 @@ 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 = +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 = +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) + remove_assoc p x l else e::(remove_assoc p x l) let eq x y = Vect.compare x y = 0 let remove e l = List.fold_left (fun l x -> if eq x e then l else x::l) [] l -(* The prover is (probably) incomplete -- +(* The prover is (probably) incomplete -- only searching for naive cutting planes *) -let candidates sys = +let candidates sys = let ll = List.fold_right ( fun (e,k) r -> - match k with + match k with | Mc.NonStrict -> (dev_form z_spec e , Ge)::r - | Mc.Equal -> (dev_form z_spec e , Eq)::r + | Mc.Equal -> (dev_form z_spec e , Eq)::r (* we already know the bound -- don't compute it again *) | _ -> failwith "Cannot happen candidates") sys [] in let (sys,var_mn) = make_linear_system ll in let vars = mapi (fun _ i -> Vect.set i (Int 1) Vect.null) var_mn in - (List.fold_left (fun l cstr -> + (List.fold_left (fun l cstr -> let gcd = Big_int (Vect.gcd cstr.coeffs) in - if gcd =/ (Int 1) && cstr.op = Eq - then l + if gcd =/ (Int 1) && cstr.op = Eq + then l else (Vect.mul (Int 1 // gcd) cstr.coeffs)::l) [] sys) @ vars -let rec xzlinear_prover planes sys = +let rec xzlinear_prover planes sys = match linear_prover z_spec sys with | Some prf -> Some (Mc.RatProof (make_certificate z_spec prf,Mc.DoneProof)) | None -> (* find the candidate with the smallest range *) (* Grrr - linear_prover is also calling 'make_linear_system' *) let ll = List.fold_right (fun (e,k) r -> match k with - Mc.NonEqual -> r - | k -> (dev_form z_spec e , + Mc.NonEqual -> r + | k -> (dev_form z_spec e , match k with - Mc.NonStrict -> Ge + Mc.NonStrict -> Ge | Mc.Equal -> Eq | Mc.Strict | Mc.NonEqual -> failwith "Cannot happen") :: r) sys [] in let (ll,var) = make_linear_system ll in - let candidates = List.fold_left (fun acc vect -> + let candidates = List.fold_left (fun acc vect -> match Fourier.optimise vect ll with | None -> acc - | Some i -> + | Some i -> (* Printf.printf "%s in %s\n" (Vect.string vect) (string_of_intrvl i) ; *) - flush stdout ; + flush stdout ; (vect,i) ::acc) [] planes in - let smallest_interval = - match List.fold_left (fun (x1,i1) (x2,i2) -> - if Itv.smaller_itv i1 i2 - then (x1,i1) else (x2,i2)) (Vect.null,(None,None)) candidates + let smallest_interval = + match List.fold_left (fun (x1,i1) (x2,i2) -> + if Itv.smaller_itv i1 i2 + then (x1,i1) else (x2,i2)) (Vect.null,(None,None)) candidates with | (x,(Some i, Some j)) -> Some(i,x,j) | x -> None (* This might be a cutting plane *) in match smallest_interval with - | Some (lb,e,ub) -> - let (lbn,lbd) = + | 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)) , + 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 + (match (*x <= ub -> x > ub *) - linear_prover z_spec + linear_prover z_spec ((pplus (pmult (pconst ubd) expr) (popp (pconst ubn)), Mc.NonStrict) :: sys), (* lb <= x -> lb > x *) - linear_prover z_spec + linear_prover z_spec ((pplus (popp (pmult (pconst lbd) expr)) (pconst lbn), - Mc.NonStrict)::sys) + Mc.NonStrict)::sys) with - | Some cub , Some clb -> - (match zlinear_enum (remove e planes) expr - (ceiling_num lb) (floor_num ub) sys + | Some cub , Some clb -> + (match zlinear_enum (remove e planes) expr + (ceiling_num lb) (floor_num ub) sys with | None -> None - | Some prf -> - let bound_proof (c,l) = make_certificate z_spec (List.tl c , List.tl (List.map (fun x -> x -1) l)) in - + | Some prf -> + let bound_proof (c,l) = make_certificate z_spec (List.tl c , List.tl (List.map (fun x -> x -1) l)) in + Some (Mc.EnumProof((*Ml2C.q lb,expr,Ml2C.q ub,*) bound_proof clb, bound_proof cub,prf))) | _ -> None ) | _ -> None -and zlinear_enum planes expr clb cub l = +and zlinear_enum planes expr clb cub l = if clb >/ cub then Some [] else @@ -665,9 +665,9 @@ and zlinear_enum planes expr clb cub l = | None -> None | Some prfl -> Some (prf :: prfl) -let zlinear_prover sys = +let zlinear_prover sys = let candidates = candidates sys in - (* Printf.printf "candidates %d" (List.length candidates) ; *) + (* Printf.printf "candidates %d" (List.length candidates) ; *) (*let t0 = Sys.time () in*) let res = xzlinear_prover candidates sys in (*Printf.printf "Time prover : %f" (Sys.time () -. t0) ;*) res @@ -675,7 +675,7 @@ let zlinear_prover sys = open Sos_types open Mutils -let rec scale_term t = +let rec scale_term t = match t with | Zero -> unit_big_int , Zero | Const n -> (denominator n) , Const (Big_int (numerator n)) @@ -708,7 +708,7 @@ let get_index_of_ith_match f i l = match l with | [] -> failwith "bad index" | e::l -> if f e - then + then (if j = i then res else get (j+1) (res+1) l ) else get j (res+1) l in get 0 0 l @@ -722,19 +722,19 @@ let rec scale_certificate pos = match pos with | 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 + | 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 + | 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'), + 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) -> + | Product (y, z) -> let s1,y1 = scale_certificate y and s2,y2 = scale_certificate z in mult_big_int s1 s2 , Product (y1,y2) @@ -743,7 +743,7 @@ open Micromega let rec term_to_q_expr = function | Const n -> PEc (Ml2C.q n) | Zero -> PEc ( Ml2C.q (Int 0)) - | Var s -> PEX (Ml2C.index + | Var s -> PEX (Ml2C.index (int_of_string (String.sub s 1 (String.length s - 1)))) | Mul(p1,p2) -> PEmul(term_to_q_expr p1, term_to_q_expr p2) | Add(p1,p2) -> PEadd(term_to_q_expr p1, term_to_q_expr p2) @@ -755,20 +755,20 @@ open Micromega let term_to_q_pol e = Mc.norm_aux (Ml2C.q (Int 0)) (Ml2C.q (Int 1)) Mc.qplus Mc.qmult Mc.qminus Mc.qopp Mc.qeq_bool (term_to_q_expr e) - let rec product l = + let rec product l = match l with | [] -> Mc.PsatzZ | [i] -> Mc.PsatzIn (Ml2C.nat i) | i ::l -> Mc.PsatzMulE(Mc.PsatzIn (Ml2C.nat i), product l) -let q_cert_of_pos pos = +let q_cert_of_pos pos = let rec _cert_of_pos = function Axiom_eq i -> Mc.PsatzIn (Ml2C.nat i) | Axiom_le i -> Mc.PsatzIn (Ml2C.nat i) | Axiom_lt i -> Mc.PsatzIn (Ml2C.nat i) | Monoid l -> product l - | Rational_eq n | Rational_le n | Rational_lt n -> + | Rational_eq n | Rational_le n | Rational_lt n -> if compare_num n (Int 0) = 0 then Mc.PsatzZ else Mc.PsatzC (Ml2C.q n) | Square t -> Mc.PsatzSquare (term_to_q_pol t) @@ -781,7 +781,7 @@ let q_cert_of_pos pos = let rec term_to_z_expr = function | Const n -> PEc (Ml2C.bigint (big_int_of_num n)) | Zero -> PEc ( Z0) - | Var s -> PEX (Ml2C.index + | Var s -> PEX (Ml2C.index (int_of_string (String.sub s 1 (String.length s - 1)))) | Mul(p1,p2) -> PEmul(term_to_z_expr p1, term_to_z_expr p2) | Add(p1,p2) -> PEadd(term_to_z_expr p1, term_to_z_expr p2) @@ -792,14 +792,14 @@ let q_cert_of_pos pos = let term_to_z_pol e = Mc.norm_aux (Ml2C.z 0) (Ml2C.z 1) Mc.zplus Mc.zmult Mc.zminus Mc.zopp Mc.zeq_bool (term_to_z_expr e) -let z_cert_of_pos pos = +let z_cert_of_pos pos = let s,pos = (scale_certificate pos) in let rec _cert_of_pos = function Axiom_eq i -> Mc.PsatzIn (Ml2C.nat i) | Axiom_le i -> Mc.PsatzIn (Ml2C.nat i) | Axiom_lt i -> Mc.PsatzIn (Ml2C.nat i) | Monoid l -> product l - | Rational_eq n | Rational_le n | Rational_lt n -> + | Rational_eq n | Rational_le n | Rational_lt n -> if compare_num n (Int 0) = 0 then Mc.PsatzZ else Mc.PsatzC (Ml2C.bigint (big_int_of_num n)) | Square t -> Mc.PsatzSquare (term_to_z_pol t) diff --git a/plugins/micromega/coq_micromega.ml b/plugins/micromega/coq_micromega.ml index 5e13db1b69..d10ae00c82 100644 --- a/plugins/micromega/coq_micromega.ml +++ b/plugins/micromega/coq_micromega.ml @@ -15,12 +15,12 @@ open Mutils let debug = false -let time str f x = +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); + 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 @@ -28,30 +28,30 @@ type tag = Tag.t type 'cst atom = 'cst Micromega.formula type 'cst formula = - | TT - | FF + | TT + | FF | X of Term.constr | A of 'cst atom * tag * Term.constr - | C of 'cst formula * 'cst formula - | D of 'cst formula * 'cst formula - | N of 'cst formula - | I of 'cst formula * Names.identifier option * 'cst formula + | C of 'cst formula * 'cst formula + | D of 'cst formula * 'cst formula + | N of 'cst formula + | I of 'cst formula * Names.identifier option * 'cst formula -let rec pp_formula o f = +let rec pp_formula o f = match f with | TT -> output_string o "tt" | FF -> output_string o "ff" - | X c -> output_string o "X " + | X c -> output_string o "X " | A(_,t,_) -> Printf.fprintf o "A(%a)" Tag.pp t | C(f1,f2) -> Printf.fprintf o "C(%a,%a)" pp_formula f1 pp_formula f2 | D(f1,f2) -> Printf.fprintf o "D(%a,%a)" pp_formula f1 pp_formula f2 - | I(f1,n,f2) -> Printf.fprintf o "I(%a%s,%a)" - pp_formula f1 - (match n with - | Some id -> Names.string_of_id id + | I(f1,n,f2) -> Printf.fprintf o "I(%a%s,%a)" + pp_formula f1 + (match n with + | Some id -> Names.string_of_id id | None -> "") pp_formula f2 - | N(f) -> Printf.fprintf o "N(%a)" pp_formula f + | N(f) -> Printf.fprintf o "N(%a)" pp_formula f let rec ids_of_formula f = match f with @@ -60,15 +60,15 @@ let rec ids_of_formula f = module ISet = Set.Make(struct type t = int let compare : int -> int -> int = Pervasives.compare end) -let selecti s m = - let rec xselect i m = +let selecti s m = + let rec xselect i m = match m with | [] -> [] | e::m -> if ISet.mem i s then e:: (xselect (i+1) m) else xselect (i+1) m in xselect 0 m -type 'cst clause = ('cst Micromega.nFormula * tag) list +type 'cst clause = ('cst Micromega.nFormula * tag) list type 'cst cnf = ('cst clause) list @@ -78,7 +78,7 @@ let ff : 'cst cnf = [ [] ] type 'cst mc_cnf = ('cst Micromega.nFormula) list list -let cnf (negate: 'cst atom -> 'cst mc_cnf) (normalise:'cst atom -> 'cst mc_cnf) (f:'cst formula) = +let cnf (negate: 'cst atom -> 'cst mc_cnf) (normalise:'cst atom -> 'cst mc_cnf) (f:'cst formula) = let negate a t = List.map (fun cl -> List.map (fun x -> (x,t)) cl) (negate a) in @@ -88,12 +88,12 @@ let cnf (negate: 'cst atom -> 'cst mc_cnf) (normalise:'cst atom -> 'cst mc_cnf) 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 (* ?? *) @@ -101,11 +101,11 @@ let cnf (negate: 'cst atom -> 'cst mc_cnf) (normalise:'cst atom -> 'cst mc_cnf) | X p -> if pol then ff else ff (* ?? *) | A(x,t,_) -> if pol then normalise x t else negate x t | N(e) -> xcnf (not pol) e - | C(e1,e2) -> + | C(e1,e2) -> (if pol then and_cnf else or_cnf) (xcnf pol e1) (xcnf pol e2) - | D(e1,e2) -> + | D(e1,e2) -> (if pol then or_cnf else and_cnf) (xcnf pol e1) (xcnf pol e2) - | I(e1,_,e2) -> + | I(e1,_,e2) -> (if pol then or_cnf else and_cnf) (xcnf (not pol) e1) (xcnf pol e2) in xcnf true f @@ -116,12 +116,12 @@ 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 @ + init_modules @ + [logic_dir] @ arith_modules @ zarith_base_modules @ [ ["Coq";"Lists";"List"]; ["ZMicromega"]; ["Tauto"]; @@ -135,7 +135,7 @@ struct ["Coq";"Reals" ; "Rdefinitions"]; ["Coq";"Reals" ; "Rpow_def"]; ["LRing_normalise"]] - + let constant = gen_constant_in_modules "ZMicromega" coq_modules let coq_and = lazy (constant "and") @@ -144,7 +144,7 @@ struct 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") @@ -153,9 +153,9 @@ struct let coq_S = lazy (constant "S") let coq_nat = lazy (constant "nat") - let coq_NO = lazy + let coq_NO = lazy (gen_constant_in_modules "N" [ ["Coq";"NArith";"BinNat" ]] "N0") - let coq_Npos = lazy + let coq_Npos = lazy (gen_constant_in_modules "N" [ ["Coq";"NArith"; "BinNat"]] "Npos") (* let coq_n = lazy (constant "N")*) @@ -166,7 +166,7 @@ struct 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") @@ -179,11 +179,11 @@ struct let coq_POS = lazy (constant "Zpos") let coq_NEG = lazy (constant "Zneg") - let coq_QWitness = lazy - (gen_constant_in_modules "QMicromega" + let coq_QWitness = lazy + (gen_constant_in_modules "QMicromega" [["Coq"; "micromega"; "QMicromega"]] "QWitness") - let coq_ZWitness = lazy - (gen_constant_in_modules "QMicromega" + let coq_ZWitness = lazy + (gen_constant_in_modules "QMicromega" [["Coq"; "micromega"; "ZMicromega"]] "ZWitness") @@ -212,8 +212,8 @@ struct let coq_Zopp = lazy (constant "Zopp") let coq_Zmult = lazy (constant "Zmult") let coq_Zpower = lazy (constant "Zpower") - let coq_N_of_Z = lazy - (gen_constant_in_modules "ZArithRing" + let coq_N_of_Z = lazy + (gen_constant_in_modules "ZArithRing" [["Coq";"setoid_ring";"ZArithRing"]] "N_of_Z") let coq_Qgt = lazy (constant "Qgt") @@ -271,27 +271,27 @@ struct let coq_PsatzC = lazy (constant "PsatzC") let coq_PsatzZ = lazy (constant "PsatzZ") let coq_coneMember = lazy (constant "coneMember") - - let coq_make_impl = lazy + + let coq_make_impl = lazy (gen_constant_in_modules "Zmicromega" [["Refl"]] "make_impl") - let coq_make_conj = lazy + 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"] ] + let coq_Build = lazy + (gen_constant_in_modules "RingMicromega" + [["Coq" ; "micromega" ; "RingMicromega"] ; ["RingMicromega"] ] "Build_Formula") - let coq_Cstr = lazy - (gen_constant_in_modules "RingMicromega" + 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 + 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 @@ -304,73 +304,73 @@ struct | Goal _ -> "Goal" - exception ParseError + exception ParseError - let get_left_construct term = + let get_left_construct term = match Term.kind_of_term term with | Term.Construct(_,i) -> (i,[| |]) - | Term.App(l,rst) -> + | 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 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 = + 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 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 = + + 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 pp_positive o x = Printf.fprintf o "%i" (CoqToCaml.positive x) - let rec dump_n x = - match x with + 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 = + 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 pp_index o x = Printf.fprintf o "%i" (CoqToCaml.index x) - let rec dump_n 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 |]) @@ -392,30 +392,30 @@ struct 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|]) + | 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 = +let dump_num bd1 = Term.mkApp(Lazy.force coq_Qmake, - [|dump_z (CamlToCoq.bigint (numerator bd1)) ; + [|dump_z (CamlToCoq.bigint (numerator bd1)) ; dump_positive (CamlToCoq.positive_big_int (denominator bd1)) |]) -let dump_q q = - Term.mkApp(Lazy.force coq_Qmake, +let dump_q q = + Term.mkApp(Lazy.force coq_Qmake, [| dump_z q.Micromega.qnum ; dump_positive q.Micromega.qden|]) -let parse_q term = +let parse_q term = match Term.kind_of_term term with | Term.App(c, args) -> if c = Lazy.force coq_Qmake then {Mc.qnum = parse_z args.(0) ; Mc.qden = parse_positive args.(1) } else raise ParseError | _ -> raise ParseError - - let rec parse_list parse_elt term = + + let rec parse_list parse_elt term = let (i,c) = get_left_construct term in match i with | 1 -> [] @@ -430,20 +430,20 @@ let parse_q term = [| typ; dump_elt e;dump_list typ dump_elt l|]) - let pp_list op cl elt o l = - let rec _pp o l = + let pp_list op cl elt o l = + let rec _pp o l = match l with | [] -> () | [e] -> Printf.fprintf o "%a" elt e | e::l -> Printf.fprintf o "%a ,%a" elt e _pp l in - Printf.fprintf o "%s%a%s" op _pp l cl + Printf.fprintf o "%s%a%s" op _pp l cl let pp_var = pp_positive let dump_var = dump_positive - let pp_expr pp_z o e = - let rec pp_expr o e = + let pp_expr pp_z o e = + 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 @@ -474,62 +474,62 @@ let parse_q term = dump_expr e - let dump_pol typ dump_c e = - let rec dump_pol e = - match e with + let dump_pol typ dump_c e = + let rec dump_pol e = + match e with | Mc.Pc n -> mkApp(Lazy.force coq_Pc, [|typ ; dump_c n|]) | Mc.Pinj(p,pol) -> mkApp(Lazy.force coq_Pinj , [| typ ; dump_positive p ; dump_pol pol|]) | Mc.PX(pol1,p,pol2) -> mkApp(Lazy.force coq_PX, [| typ ; dump_pol pol1 ; dump_positive p ; dump_pol pol2|]) in dump_pol e - let pp_pol pp_c o e = - let rec pp_pol o e = - match e with + let pp_pol pp_c o e = + let rec pp_pol o e = + match e with | Mc.Pc n -> Printf.fprintf o "Pc %a" pp_c n | Mc.Pinj(p,pol) -> Printf.fprintf o "Pinj(%a,%a)" pp_positive p pp_pol pol | Mc.PX(pol1,p,pol2) -> Printf.fprintf o "PX(%a,%a,%a)" pp_pol pol1 pp_positive p pp_pol pol2 in pp_pol o e - - - let pp_cnf pp_c o f = + + + let pp_cnf pp_c o f = let pp_clause o l = List.iter (fun ((p,_),t) -> Printf.fprintf o "(%a @%a)" (pp_pol pp_c) p Tag.pp t) l in List.iter (fun l -> Printf.fprintf o "[%a]" pp_clause l) f - - let dump_psatz typ dump_z e = - let z = Lazy.force typ in + + let dump_psatz typ dump_z e = + let z = Lazy.force typ in let rec dump_cone e = match e with | Mc.PsatzIn n -> mkApp(Lazy.force coq_PsatzIn,[| z; dump_nat n |]) - | Mc.PsatzMulC(e,c) -> mkApp(Lazy.force coq_PsatzMultC, + | Mc.PsatzMulC(e,c) -> mkApp(Lazy.force coq_PsatzMultC, [| z; dump_pol z dump_z e ; dump_cone c |]) - | Mc.PsatzSquare e -> mkApp(Lazy.force coq_PsatzSquare, + | Mc.PsatzSquare e -> mkApp(Lazy.force coq_PsatzSquare, [| z;dump_pol z dump_z e|]) | Mc.PsatzAdd(e1,e2) -> mkApp(Lazy.force coq_PsatzAdd, [| z; dump_cone e1; dump_cone e2|]) | Mc.PsatzMulE(e1,e2) -> mkApp(Lazy.force coq_PsatzMulE, [| z; dump_cone e1; dump_cone e2|]) | Mc.PsatzC p -> mkApp(Lazy.force coq_PsatzC,[| z; dump_z p|]) - | Mc.PsatzZ -> mkApp( Lazy.force coq_PsatzZ,[| z|]) in + | Mc.PsatzZ -> mkApp( Lazy.force coq_PsatzZ,[| z|]) in dump_cone e - let pp_psatz pp_z o e = - let rec pp_cone o e = - match e with - | Mc.PsatzIn n -> + let pp_psatz pp_z o e = + let rec pp_cone o e = + match e with + | Mc.PsatzIn n -> Printf.fprintf o "(In %a)%%nat" pp_nat n - | Mc.PsatzMulC(e,c) -> + | Mc.PsatzMulC(e,c) -> Printf.fprintf o "( %a [*] %a)" (pp_pol pp_z) e pp_cone c - | Mc.PsatzSquare e -> + | Mc.PsatzSquare e -> Printf.fprintf o "(%a^2)" (pp_pol pp_z) e - | Mc.PsatzAdd(e1,e2) -> + | Mc.PsatzAdd(e1,e2) -> Printf.fprintf o "(%a [+] %a)" pp_cone e1 pp_cone e2 - | Mc.PsatzMulE(e1,e2) -> + | Mc.PsatzMulE(e1,e2) -> Printf.fprintf o "(%a [*] %a)" pp_cone e1 pp_cone e2 - | Mc.PsatzC p -> + | Mc.PsatzC p -> Printf.fprintf o "(%a)%%positive" pp_z p - | Mc.PsatzZ -> + | Mc.PsatzZ -> Printf.fprintf o "0" in pp_cone o e @@ -544,8 +544,8 @@ let parse_q term = - let pp_op o e= - match e with + let pp_op o e= + match e with | Mc.OpEq-> Printf.fprintf o "=" | Mc.OpNEq-> Printf.fprintf o "<>" | Mc.OpLe -> Printf.fprintf o "=<" @@ -561,29 +561,29 @@ let parse_q term = 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 ; + [| typ; dump_expr typ dump_constant e1 ; + dump_op o ; dump_expr typ dump_constant e2|]) - let assoc_const x l = - try + let assoc_const x l = + try snd (List.find (fun (x',y) -> x = Lazy.force x') l) with Not_found -> raise ParseError - let zop_table = [ - coq_Zgt, Mc.OpGt ; + let zop_table = [ + coq_Zgt, Mc.OpGt ; coq_Zge, Mc.OpGe ; coq_Zlt, Mc.OpLt ; coq_Zle, Mc.OpLe ] - let rop_table = [ - coq_Rgt, Mc.OpGt ; + let rop_table = [ + coq_Rgt, Mc.OpGt ; coq_Rge, Mc.OpGe ; coq_Rlt, Mc.OpLt ; coq_Rle, Mc.OpLe ] - let qop_table = [ + let qop_table = [ coq_Qlt, Mc.OpLt ; coq_Qle, Mc.OpLe ; coq_Qeq, Mc.OpEq @@ -593,7 +593,7 @@ let parse_q term = let parse_zop (op,args) = match kind_of_term op with | Const x -> (assoc_const op zop_table, args.(0) , args.(1)) - | Ind(n,0) -> + | Ind(n,0) -> if op = Lazy.force coq_Eq && args.(0) = Lazy.force coq_Z then (Mc.OpEq, args.(1), args.(2)) else raise ParseError @@ -603,7 +603,7 @@ let parse_q term = let parse_rop (op,args) = match kind_of_term op with | Const x -> (assoc_const op rop_table, args.(0) , args.(1)) - | Ind(n,0) -> + | Ind(n,0) -> if op = Lazy.force coq_Eq && args.(0) = Lazy.force coq_R then (Mc.OpEq, args.(1), args.(2)) else raise ParseError @@ -614,25 +614,25 @@ let parse_q term = module Env = - struct + 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 + | e::l -> + if eq_constr e v then (env,n) - else + 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 @@ -640,63 +640,63 @@ let parse_q term = let is_constant t = (* This is an approx *) match kind_of_term t with - | Construct(i,_) -> true + | Construct(i,_) -> true | _ -> false - type 'a op = - | Binop of ('a Mc.pExpr -> 'a Mc.pExpr -> 'a Mc.pExpr) - | Opp - | Power + type 'a op = + | Binop of ('a Mc.pExpr -> 'a Mc.pExpr -> 'a Mc.pExpr) + | Opp + | Power | Ukn of string - let assoc_ops x l = - try + let assoc_ops x l = + try snd (List.find (fun (x',y) -> x = Lazy.force x') l) with Not_found -> Ukn "Oups" - let parse_expr parse_constant parse_exp ops_spec env term = - if debug - then (Pp.pp (Pp.str "parse_expr: "); + 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 + let constant_or_variable env term = + try ( Mc.PEc (parse_constant term) , env) - with ParseError -> + with ParseError -> let (env,n) = Env.compute_rank_add env term in (Mc.PEX n , env) in - let rec parse_expr env term = + 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) -> + | App(t,args) -> ( match kind_of_term t with - | Const c -> + | Const c -> ( match assoc_ops t ops_spec 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 -> + | Power -> begin - try + try let (expr,env) = parse_expr env args.(0) in - let exp = (parse_exp args.(1)) in - (Mc.PEpow(expr, exp) , env) + let exp = (parse_exp args.(1)) in + (Mc.PEpow(expr, exp) , env) with _ -> (* if the exponent is a variable *) let (env,n) = Env.compute_rank_add env term in (Mc.PEX n, env) end - | Ukn s -> - if debug + | 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) ) @@ -704,47 +704,47 @@ let parse_q term = ) | _ -> constant_or_variable env term in parse_expr env term - - let zop_spec = - [ + + let zop_spec = + [ coq_Zplus , Binop (fun x y -> Mc.PEadd(x,y)) ; coq_Zminus , Binop (fun x y -> Mc.PEsub(x,y)) ; - coq_Zmult , Binop (fun x y -> Mc.PEmul (x,y)) ; - coq_Zopp , Opp ; + coq_Zmult , Binop (fun x y -> Mc.PEmul (x,y)) ; + coq_Zopp , Opp ; coq_Zpower , Power] -let qop_spec = +let qop_spec = [ coq_Qplus , Binop (fun x y -> Mc.PEadd(x,y)) ; coq_Qminus , Binop (fun x y -> Mc.PEsub(x,y)) ; - coq_Qmult , Binop (fun x y -> Mc.PEmul (x,y)) ; - coq_Qopp , Opp ; + coq_Qmult , Binop (fun x y -> Mc.PEmul (x,y)) ; + coq_Qopp , Opp ; coq_Qpower , Power] -let rop_spec = +let rop_spec = [ coq_Rplus , Binop (fun x y -> Mc.PEadd(x,y)) ; coq_Rminus , Binop (fun x y -> Mc.PEsub(x,y)) ; - coq_Rmult , Binop (fun x y -> Mc.PEmul (x,y)) ; - coq_Ropp , Opp ; + coq_Rmult , Binop (fun x y -> Mc.PEmul (x,y)) ; + coq_Ropp , Opp ; coq_Rpower , Power] - + let zconstant = parse_z let qconstant = parse_q -let rconstant term = - if debug +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 -> + | Const x -> if term = Lazy.force coq_R0 then Mc.Z0 else if term = Lazy.force coq_R1 @@ -753,37 +753,37 @@ let rconstant term = | _ -> 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 = +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 + 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 (Printer.prterm cstr); Pp.pp_flush ()); match kind_of_term cstr with - | App(op,args) -> + | 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_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 *) - + @@ -797,7 +797,7 @@ let parse_rexpr = | N (a) -> Mc.N(f2f a) | I(a,_,b) -> Mc.I(f2f a,f2f b) - let is_prop t = + let is_prop t = match t with | Names.Anonymous -> true (* Not quite right *) | Names.Name x -> false @@ -814,7 +814,7 @@ let parse_rexpr = let parse_formula parse_atom env term = - let parse_atom env tg t = try let (at,env) = parse_atom env t in + let parse_atom env tg t = try let (at,env) = parse_atom env t in (A(at,tg,t), env,Tag.next tg) with _ -> (X(t),env,tg) in let rec xparse_formula env tg term = @@ -845,36 +845,36 @@ let parse_rexpr = | _ -> X(term),env,tg in xparse_formula env term - let coq_TT = lazy - (gen_constant_in_modules "ZMicromega" + let coq_TT = lazy + (gen_constant_in_modules "ZMicromega" [["Coq" ; "micromega" ; "Tauto"];["Tauto"]] "TT") - let coq_FF = lazy - (gen_constant_in_modules "ZMicromega" + let coq_FF = lazy + (gen_constant_in_modules "ZMicromega" [["Coq" ; "micromega" ; "Tauto"];["Tauto"]] "FF") - let coq_And = lazy - (gen_constant_in_modules "ZMicromega" + let coq_And = lazy + (gen_constant_in_modules "ZMicromega" [["Coq" ; "micromega" ; "Tauto"];["Tauto"]] "Cj") - let coq_Or = lazy - (gen_constant_in_modules "ZMicromega" + let coq_Or = lazy + (gen_constant_in_modules "ZMicromega" [["Coq" ; "micromega" ; "Tauto"];["Tauto"]] "D") - let coq_Neg = lazy - (gen_constant_in_modules "ZMicromega" + let coq_Neg = lazy + (gen_constant_in_modules "ZMicromega" [["Coq" ; "micromega" ; "Tauto"];["Tauto"]] "N") - let coq_Atom = lazy - (gen_constant_in_modules "ZMicromega" + let coq_Atom = lazy + (gen_constant_in_modules "ZMicromega" [["Coq" ; "micromega" ; "Tauto"];["Tauto"]] "A") - let coq_X = lazy - (gen_constant_in_modules "ZMicromega" + let coq_X = lazy + (gen_constant_in_modules "ZMicromega" [["Coq" ; "micromega" ; "Tauto"];["Tauto"]] "X") - let coq_Impl = lazy - (gen_constant_in_modules "ZMicromega" + let coq_Impl = lazy + (gen_constant_in_modules "ZMicromega" [["Coq" ; "micromega" ; "Tauto"];["Tauto"]] "I") - let coq_Formula = lazy - (gen_constant_in_modules "ZMicromega" + 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 = + 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|]) @@ -882,11 +882,11 @@ let parse_rexpr = | 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|]) + | A(x,_,_) -> mkApp(Lazy.force coq_Atom,[| typ ; dump_atom x|]) | X(t) -> mkApp(Lazy.force coq_X,[| typ ; t|]) in xdump f - + @@ -894,7 +894,7 @@ let parse_rexpr = let set l concl = let rec _set acc = function | [] -> acc - | (e::l) -> + | (e::l) -> let (name,expr,typ) = e in _set (Term.mkNamedLetIn (Names.id_of_string name) @@ -902,7 +902,7 @@ let parse_rexpr = _set concl l -end +end open M @@ -916,33 +916,33 @@ let rec sig_of_cone = function | _ -> [] let same_proof sg cl1 cl2 = - let rec xsame_proof sg = + let rec xsame_proof sg = match sg with | [] -> true - | n::sg -> (try List.nth cl1 n = List.nth cl2 n with _ -> false) + | 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 tags_of_clause tgs wit clause = let rec xtags tgs = function - | Mc.PsatzIn n -> Names.Idset.union tgs + | Mc.PsatzIn n -> Names.Idset.union tgs (snd (List.nth clause (CoqToCaml.nat n) )) | Mc.PsatzMulC(e,w) -> xtags tgs w | Mc.PsatzMulE (w1,w2) | Mc.PsatzAdd(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) +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 = try_any prover polys1 -let rec witness prover l1 l2 = +let rec witness prover l1 l2 = match l2 with | [] -> Some [] | e :: l2 -> @@ -955,23 +955,23 @@ let rec witness prover l1 l2 = ) -let rec apply_ids t ids = +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" + +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" +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" +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 @@ -979,25 +979,25 @@ let btree_of_array typ a = 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 + if n > size_of_a then empty - else if n > semi_size_of_a + 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 + in aux 1 -let btree_of_array typ a = - try +let btree_of_array typ a = + try btree_of_array typ a - with x -> + 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 = +let rec pp_varmap o vm = match vm with | Mc.Empty -> output_string o "[]" | Mc.Leaf z -> Printf.fprintf o "[%a]" pp_z z @@ -1005,37 +1005,37 @@ let rec pp_varmap o vm = -let rec dump_proof_term = function +let rec dump_proof_term = function | Micromega.DoneProof -> Lazy.force coq_doneProof - | Micromega.RatProof(cone,rst) -> + | Micromega.RatProof(cone,rst) -> Term.mkApp(Lazy.force coq_ratProof, [| dump_psatz coq_Z dump_z cone; dump_proof_term rst|]) | Micromega.CutProof(cone,prf) -> - Term.mkApp(Lazy.force coq_cutProof, - [| dump_psatz coq_Z dump_z cone ; + Term.mkApp(Lazy.force coq_cutProof, + [| dump_psatz coq_Z dump_z cone ; dump_proof_term prf|]) - | Micromega.EnumProof(c1,c2,prfs) -> + | Micromega.EnumProof(c1,c2,prfs) -> Term.mkApp (Lazy.force coq_enumProof, - [| dump_psatz coq_Z dump_z c1 ; dump_psatz coq_Z dump_z c2 ; + [| dump_psatz coq_Z dump_z c1 ; dump_psatz 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.DoneProof -> Printf.fprintf o "D" | Micromega.RatProof(cone,rst) -> Printf.fprintf o "R[%a,%a]" (pp_psatz pp_z) cone pp_proof_term rst | Micromega.CutProof(cone,rst) -> Printf.fprintf o "C[%a,%a]" (pp_psatz pp_z) cone pp_proof_term rst - | Micromega.EnumProof(c1,c2,rst) -> - Printf.fprintf o "EP[%a,%a,%a]" - (pp_psatz pp_z) c1 (pp_psatz pp_z) c2 + | Micromega.EnumProof(c1,c2,rst) -> + Printf.fprintf o "EP[%a,%a,%a]" + (pp_psatz pp_z) c1 (pp_psatz pp_z) c2 (pp_list "[" "]" pp_proof_term) rst let rec parse_hyps parse_arith env tg hyps = match hyps with | [] -> ([],env,tg) - | (i,t)::l -> + | (i,t)::l -> let (lhyps,env,tg) = parse_hyps parse_arith env tg l in - try + try let (c,env,tg) = parse_formula parse_arith env tg t in ((i,c)::lhyps, env,tg) with _ -> (lhyps,env,tg) @@ -1044,7 +1044,7 @@ let rec parse_hyps parse_arith env tg hyps = exception ParseError -let parse_goal parse_arith env hyps term = +let parse_goal parse_arith env hyps term = (* try*) let (f,env,tg) = parse_formula parse_arith env (Tag.from 0) term in let (lhyps,env,tg) = parse_hyps parse_arith env tg hyps in @@ -1052,11 +1052,11 @@ let parse_goal parse_arith env hyps term = (* with Failure x -> raise ParseError*) -type ('d, 'prf) domain_spec = { +type ('d, 'prf) domain_spec = { typ : Term.constr; (* Z, Q , R *) coeff : Term.constr ; (* Z, Q *) - dump_coeff : 'd -> Term.constr ; - proof_typ : Term.constr ; + dump_coeff : 'd -> Term.constr ; + proof_typ : Term.constr ; dump_proof : 'prf -> Term.constr } @@ -1085,25 +1085,25 @@ let rz_domain_spec = lazy { } -let abstract_formula hyps f = - - let rec xabs f = +let abstract_formula hyps f = + + let rec xabs f = match f with | X c -> X c | A(a,t,term) -> if TagSet.mem t hyps then A(a,t,term) else X(term) - | C(f1,f2) -> + | C(f1,f2) -> (match xabs f1 , xabs f2 with | X a1 , X a2 -> X (Term.mkApp(Lazy.force coq_and, [|a1;a2|])) | f1 , f2 -> C(f1,f2) ) - | D(f1,f2) -> + | D(f1,f2) -> (match xabs f1 , xabs f2 with | X a1 , X a2 -> X (Term.mkApp(Lazy.force coq_or, [|a1;a2|])) | f1 , f2 -> D(f1,f2) ) - | N(f) -> + | N(f) -> (match xabs f with | X a -> X (Term.mkApp(Lazy.force coq_not, [|a|])) | f -> N f) - | I(f1,hyp,f2) -> + | I(f1,hyp,f2) -> (match xabs f1 , hyp, xabs f2 with | X a1 , Some _ , af2 -> af2 | X a1 , None , X a2 -> X (Term.mkArrow a1 a2) @@ -1117,25 +1117,25 @@ let abstract_formula hyps f = -let micromega_order_change spec cert cert_typ env ff gl = +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 - [ + (set + [ ("__ff", ff, Term.mkApp(Lazy.force coq_Formula ,[| formula_typ |])); - ("__varmap", vm , Term.mkApp - (Coqlib.gen_constant_in_modules "VarMap" + ("__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 - + gl + type ('a,'prf) prover = { name : string ; (* name of the prover *) @@ -1147,18 +1147,18 @@ type ('a,'prf) prover = { } let find_witness provers polys1 = - - let provers = List.map (fun p -> - (fun l -> + + let provers = List.map (fun p -> + (fun l -> match p.prover l with | None -> None | Some prf -> Some(prf,p)) , p.name) provers in - + try_any provers (List.map fst polys1) -let witness_list prover l = - let rec xwitness_list l = +let witness_list prover l = + let rec xwitness_list l = match l with | [] -> Some [] | e :: l -> @@ -1173,79 +1173,79 @@ let witness_list prover l = let witness_list_tags = witness_list - + let is_singleton = function [] -> true | [e] -> true | _ -> false -let pp_ml_list pp_elt o l = +let pp_ml_list pp_elt o l = output_string o "[" ; - List.iter (fun x -> Printf.fprintf o "%a ;" pp_elt x) l ; - output_string o "]" + List.iter (fun x -> Printf.fprintf o "%a ;" pp_elt x) l ; + output_string o "]" -let compact_proofs (cnf_ff: 'cst cnf) res (cnf_ff': 'cst cnf) = +let compact_proofs (cnf_ff: 'cst cnf) res (cnf_ff': 'cst cnf) = - let compact_proof (old_cl:'cst clause) (prf,prover) (new_cl:'cst clause) = + let compact_proof (old_cl:'cst clause) (prf,prover) (new_cl:'cst clause) = let new_cl = Mutils.mapi (fun (f,_) i -> (f,i)) new_cl in - let remap i = + let remap i = let formula = try fst (List.nth old_cl i) with Failure _ -> failwith "bad old index" in List.assoc formula new_cl in - if debug then + if debug then begin - Printf.printf "\ncompact_proof : %a %a %a" - (pp_ml_list prover.pp_f) (List.map fst old_cl) - prover.pp_prf prf + Printf.printf "\ncompact_proof : %a %a %a" + (pp_ml_list prover.pp_f) (List.map fst old_cl) + prover.pp_prf prf (pp_ml_list prover.pp_f) (List.map fst new_cl) ; flush stdout end ; let res = try prover.compact prf remap with x -> - if debug then Printf.fprintf stdout "Proof compaction %s" (Printexc.to_string x) ; + if debug then Printf.fprintf stdout "Proof compaction %s" (Printexc.to_string x) ; (* This should not happen -- this is the recovery plan... *) - match prover.prover (List.map fst new_cl) with + match prover.prover (List.map fst new_cl) with | None -> failwith "proof compaction error" - | Some p -> p + | Some p -> p in - if debug then + if debug then begin - Printf.printf " -> %a\n" + Printf.printf " -> %a\n" prover.pp_prf res ; flush stdout end - ; + ; res in - let is_proof_compatible (old_cl:'cst clause) (prf,prover) (new_cl:'cst clause) = + let is_proof_compatible (old_cl:'cst clause) (prf,prover) (new_cl:'cst clause) = let hyps_idx = prover.hyps prf in let hyps = selecti hyps_idx old_cl in is_sublist hyps new_cl in let cnf_res = List.combine cnf_ff res in (* we get pairs clause * proof *) - - List.map (fun x -> - let (o,p) = List.find (fun (l,p) -> is_proof_compatible l p x) cnf_res - in compact_proof o p x) cnf_ff' - - - - -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(f,Some id,cc), id::ids)) + + List.map (fun x -> + let (o,p) = List.find (fun (l,p) -> is_proof_compatible l p x) cnf_res + in compact_proof o p x) cnf_ff' + + + + +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(f,Some id,cc), id::ids)) polys1 (polys2,[]) in let cnf_ff = cnf negate normalise ff in - if debug then + if debug then begin Pp.pp (Pp.str "Formula....\n") ; let formula_typ = (Term.mkApp( Lazy.force coq_Cstr,[| spec.coeff|])) in - let ff = dump_formula formula_typ + let ff = dump_formula formula_typ (dump_cstr spec.typ spec.dump_coeff) ff in Pp.pp (Printer.prterm ff) ; Pp.pp_flush (); Printf.fprintf stdout "cnf : %a\n" (pp_cnf (fun o _ -> ())) cnf_ff @@ -1255,30 +1255,30 @@ let micromega_tauto negate normalise spec prover env polys1 polys2 gl = | None -> Tacticals.tclFAIL 0 (Pp.str "Cannot find witness") gl | Some res -> (*Printf.printf "\nList %i" (List.length `res); *) - let hyps = List.fold_left (fun s (cl,(prf,p)) -> + let hyps = List.fold_left (fun s (cl,(prf,p)) -> let tags = ISet.fold (fun i s -> let t = snd (List.nth cl i) in if debug then (Printf.fprintf stdout "T : %i -> %a" i Tag.pp t) ; (*try*) TagSet.add t s (* with Invalid_argument _ -> s*)) (p.hyps prf) TagSet.empty in TagSet.union s tags) TagSet.empty (List.combine cnf_ff res) in if debug then (Printf.printf "TForm : %a\n" pp_formula ff ; flush stdout; - Printf.printf "Hyps : %a\n" (fun o s -> TagSet.fold (fun i _ -> Printf.fprintf o "%a " Tag.pp i) s ()) hyps) ; - + Printf.printf "Hyps : %a\n" (fun o s -> TagSet.fold (fun i _ -> Printf.fprintf o "%a " Tag.pp i) s ()) hyps) ; + let ff' = abstract_formula hyps ff in - + let cnf_ff' = cnf negate normalise ff' in if debug then begin - Pp.pp (Pp.str "\nAFormula\n") ; + Pp.pp (Pp.str "\nAFormula\n") ; let formula_typ = (Term.mkApp( Lazy.force coq_Cstr,[| spec.coeff|])) in - let ff' = dump_formula formula_typ + let ff' = dump_formula formula_typ (dump_cstr spec.typ spec.dump_coeff) ff' in Pp.pp (Printer.prterm ff') ; Pp.pp_flush (); Printf.fprintf stdout "cnf : %a\n" (pp_cnf (fun o _ -> ())) cnf_ff' end; - (* Even if it does not work, this does not mean it is not provable + (* Even if it does not work, this does not mean it is not provable -- the prover is REALLY incomplete *) (* if debug then begin @@ -1295,15 +1295,15 @@ let micromega_tauto negate normalise spec prover env polys1 polys2 gl = (Tacticals.tclTHENSEQ [ Tactics.generalize ids; - micromega_order_change spec res' + micromega_order_change spec res' (Term.mkApp(Lazy.force coq_list,[| spec.proof_typ|])) env ff' ; ]) gl -let micromega_gen - parse_arith - (negate:'cst atom -> 'cst mc_cnf) - (normalise:'cst atom -> 'cst mc_cnf) +let micromega_gen + parse_arith + (negate:'cst atom -> 'cst mc_cnf) + (normalise:'cst atom -> 'cst mc_cnf) spec prover gl = let concl = Tacmach.pf_concl gl in let hyps = Tacmach.pf_hyps_types gl in @@ -1311,8 +1311,8 @@ let micromega_gen 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 () ; + 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 @@ -1328,16 +1328,16 @@ type provername = string * int option open Persistent_cache -module Cache = PHashtable(struct - type t = (provername * micromega_polys) +module Cache = PHashtable(struct + type t = (provername * micromega_polys) let equal = (=) let hash = Hashtbl.hash end) -let csdp_cache = "csdp.cache" +let csdp_cache = "csdp.cache" let really_call_csdpcert : provername -> micromega_polys -> Sos_types.positivstellensatz option = - fun provername poly -> + fun provername poly -> let cmdname = List.fold_left Filename.concat (Envars.coqlib ()) @@ -1355,36 +1355,36 @@ let xcall_csdpcert = let call_csdpcert prover pb = xcall_csdpcert (prover,pb) -let rec z_to_q_pol e = +let rec z_to_q_pol e = match e with | Mc.Pc z -> Mc.Pc {Mc.qnum = z ; Mc.qden = Mc.XH} | Mc.Pinj(p,pol) -> Mc.Pinj(p,z_to_q_pol pol) | Mc.PX(pol1,p,pol2) -> Mc.PX(z_to_q_pol pol1, p, z_to_q_pol pol2) -let call_csdpcert_q provername poly = +let call_csdpcert_q provername poly = match call_csdpcert provername poly with | None -> None - | Some cert -> + | Some cert -> let cert = Certificate.q_cert_of_pos cert in if Mc.qWeakChecker poly cert then Some cert else ((print_string "buggy certificate" ; flush stdout) ;None) -let call_csdpcert_z provername poly = +let call_csdpcert_z provername poly = let l = List.map (fun (e,o) -> (z_to_q_pol e,o)) poly in match call_csdpcert provername l with | None -> None - | Some cert -> + | Some cert -> let cert = Certificate.z_cert_of_pos cert in if Mc.zWeakChecker poly cert then Some cert else ((print_string "buggy certificate" ; flush stdout) ;None) -let xhyps_of_cone base acc prf = - let rec xtract e acc = +let xhyps_of_cone base acc prf = + let rec xtract e acc = match e with | Mc.PsatzC _ | Mc.PsatzZ | Mc.PsatzSquare _ -> acc | Mc.PsatzIn n -> let n = (CoqToCaml.nat n) in @@ -1401,7 +1401,7 @@ let hyps_of_cone prf = xhyps_of_cone 0 ISet.empty prf let compact_cone prf f = let np n = CamlToCoq.nat (f (CoqToCaml.nat n)) in - let rec xinterp prf = + let rec xinterp prf = match prf with | Mc.PsatzC _ | Mc.PsatzZ | Mc.PsatzSquare _ -> prf | Mc.PsatzIn n -> Mc.PsatzIn (np n) @@ -1411,31 +1411,31 @@ let compact_cone prf f = xinterp prf -let hyps_of_pt pt = - let rec xhyps base pt acc = +let hyps_of_pt pt = + let rec xhyps base pt acc = match pt with | Mc.DoneProof -> acc | Mc.RatProof(c,pt) -> xhyps (base+1) pt (xhyps_of_cone base acc c) | Mc.CutProof(c,pt) -> xhyps (base+1) pt (xhyps_of_cone base acc c) - | Mc.EnumProof(c1,c2,l) -> + | Mc.EnumProof(c1,c2,l) -> let s = xhyps_of_cone base (xhyps_of_cone base acc c2) c1 in List.fold_left (fun s x -> xhyps (base + 1) x s) s l in - + xhyps 0 pt ISet.empty -let hyps_of_pt pt = +let hyps_of_pt pt = let res = hyps_of_pt pt in - if debug + if debug then (Printf.fprintf stdout "\nhyps_of_pt : %a -> " pp_proof_term pt ; ISet.iter (fun i -> Printf.printf "%i " i) res); res - - -let compact_pt pt f = + + +let compact_pt pt f = let translate ofset x = if x < ofset then x else (f (x-ofset) + ofset) in - let rec compact_pt ofset pt = + let rec compact_pt ofset pt = match pt with | Mc.DoneProof -> Mc.DoneProof | Mc.RatProof(c,pt) -> Mc.RatProof(compact_cone c (translate (ofset)), compact_pt (ofset+1) pt ) @@ -1451,8 +1451,8 @@ let compact_pt pt f = let lift_pexpr_prover p l = p (List.map (fun (e,o) -> Mc.denorm e , o) l) let linear_prover_Z = { - name = "linear prover" ; - prover = lift_ratproof (lift_pexpr_prover (Certificate.linear_prover_with_cert Certificate.z_spec)) ; + name = "linear prover" ; + prover = lift_ratproof (lift_pexpr_prover (Certificate.linear_prover_with_cert Certificate.z_spec)) ; hyps = hyps_of_pt ; compact = compact_pt ; pp_prf = pp_proof_term; @@ -1461,8 +1461,8 @@ let linear_prover_Z = { let linear_prover_Q = { name = "linear prover"; - prover = lift_pexpr_prover (Certificate.linear_prover_with_cert Certificate.q_spec) ; - hyps = hyps_of_cone ; + prover = lift_pexpr_prover (Certificate.linear_prover_with_cert Certificate.q_spec) ; + hyps = hyps_of_cone ; compact = compact_cone ; pp_prf = pp_psatz pp_q ; pp_f = fun o x -> pp_pol pp_q o (fst x) @@ -1470,8 +1470,8 @@ let linear_prover_Q = { let linear_prover_R = { name = "linear prover"; - prover = lift_pexpr_prover (Certificate.linear_prover_with_cert Certificate.z_spec) ; - hyps = hyps_of_cone ; + prover = lift_pexpr_prover (Certificate.linear_prover_with_cert Certificate.z_spec) ; + hyps = hyps_of_cone ; compact = compact_cone ; pp_prf = pp_psatz pp_z ; pp_f = fun o x -> pp_pol pp_z o (fst x) @@ -1504,7 +1504,7 @@ let non_linear_prover_Z str o = { pp_f = fun o x -> pp_pol pp_z o (fst x) } -module CacheZ = PHashtable(struct +module CacheZ = PHashtable(struct type t = (Mc.z Mc.pol * Mc.op1) list let equal = (=) let hash = Hashtbl.hash @@ -1515,7 +1515,7 @@ let memo_zlinear_prover = CacheZ.memo "lia.cache" (lift_pexpr_prover Certificate let linear_Z = { name = "lia"; - prover = memo_zlinear_prover ; + prover = memo_zlinear_prover ; hyps = hyps_of_pt; compact = compact_pt; pp_prf = pp_proof_term; @@ -1526,52 +1526,52 @@ let linear_Z = { (** Instantiation of the tactics *) -let psatzl_Z gl = +let psatzl_Z gl = micromega_gen parse_zarith Mc.negate Mc.normalise zz_domain_spec [linear_prover_Z ] gl -let psatzl_Q gl = - micromega_gen parse_qarith Mc.qnegate Mc.qnormalise qq_domain_spec +let psatzl_Q gl = + micromega_gen parse_qarith Mc.qnegate Mc.qnormalise qq_domain_spec [ linear_prover_Q ] gl -let psatz_Q i gl = +let psatz_Q i gl = micromega_gen parse_qarith Mc.qnegate Mc.qnormalise qq_domain_spec [ non_linear_prover_Q "real_nonlinear_prover" (Some i) ] gl -let psatzl_R gl = - micromega_gen parse_rarith Mc.rnegate Mc.rnormalise rz_domain_spec +let psatzl_R gl = + micromega_gen parse_rarith Mc.rnegate Mc.rnormalise rz_domain_spec [ linear_prover_R ] gl -let psatz_R i gl = +let psatz_R i gl = micromega_gen parse_rarith Mc.rnegate Mc.rnormalise rz_domain_spec [ non_linear_prover_R "real_nonlinear_prover" (Some i)] gl -let psatz_Z i gl = - micromega_gen parse_zarith Mc.negate Mc.normalise zz_domain_spec +let psatz_Z i gl = + micromega_gen parse_zarith Mc.negate Mc.normalise zz_domain_spec [non_linear_prover_Z "real_nonlinear_prover" (Some i) ] gl -let sos_Z gl = - micromega_gen parse_zarith Mc.negate Mc.normalise zz_domain_spec +let sos_Z gl = + micromega_gen parse_zarith Mc.negate Mc.normalise zz_domain_spec [non_linear_prover_Z "pure_sos" None] gl -let sos_Q gl = - micromega_gen parse_qarith Mc.qnegate Mc.qnormalise qq_domain_spec +let sos_Q gl = + micromega_gen parse_qarith Mc.qnegate Mc.qnormalise qq_domain_spec [non_linear_prover_Q "pure_sos" None] gl -let sos_R gl = - micromega_gen parse_rarith Mc.rnegate Mc.rnormalise rz_domain_spec +let sos_R gl = + micromega_gen parse_rarith Mc.rnegate Mc.rnormalise rz_domain_spec [non_linear_prover_R "pure_sos" None] gl -let xlia gl = - micromega_gen parse_zarith Mc.negate Mc.normalise zz_domain_spec +let xlia gl = + micromega_gen parse_zarith Mc.negate Mc.normalise zz_domain_spec [linear_Z] gl (* Local Variables: *) diff --git a/plugins/micromega/csdpcert.ml b/plugins/micromega/csdpcert.ml index 78087c0704..d4e6d920bd 100644 --- a/plugins/micromega/csdpcert.ml +++ b/plugins/micromega/csdpcert.ml @@ -29,7 +29,7 @@ type provername = string * int option let debug = true -let flags = [Open_append;Open_binary;Open_creat] +let flags = [Open_append;Open_binary;Open_creat] let chan = open_out_gen flags 0o666 "trace" @@ -41,7 +41,7 @@ struct let rec expr_to_term = function | PEc z -> Const (C2Ml.q_to_num z) | PEX v -> Var ("x"^(string_of_int (C2Ml.index v))) - | PEmul(p1,p2) -> + | PEmul(p1,p2) -> let p1 = expr_to_term p1 in let p2 = expr_to_term p2 in let res = Mul(p1,p2) in res @@ -51,12 +51,12 @@ struct | PEpow(p,n) -> Pow(expr_to_term p , C2Ml.n n) | PEopp p -> Opp (expr_to_term p) - -end -open M + +end +open M open List -open Mutils +open Mutils @@ -65,29 +65,29 @@ 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 o l = +let print_list_term o l = output_string o "print_list_term\n"; List.iter (fun (e,k) -> Printf.fprintf o "q: %s %s ;" - (string_of_poly (poly_of_term (expr_to_term e))) - (match k with - Mc.Equal -> "= " - | Mc.Strict -> "> " - | Mc.NonStrict -> ">= " + (string_of_poly (poly_of_term (expr_to_term e))) + (match k with + Mc.Equal -> "= " + | Mc.Strict -> "> " + | Mc.NonStrict -> ">= " | _ -> failwith "not_implemented")) (List.map (fun (e, o) -> Mc.denorm e , o) l) ; output_string o "\n" -let partition_expr l = +let partition_expr l = let rec f i = function | [] -> ([],[],[]) | (e,k)::l -> let (eq,ge,neq) = f (i+1) l in - match k with + 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 *) + | 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) + | Mc.NonEqual -> (eq,ge,(e,Axiom_eq i)::neq) (* Not quite sure -- Coq interface has changed *) in f 0 l @@ -96,28 +96,28 @@ 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) + s@(List.map (fun s0 -> e::s0) s) (* The exploration is probably not complete - for simple cases, it works... *) let real_nonlinear_prover d l = let l = List.map (fun (e,op) -> (Mc.denorm e,op)) l in - try + 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 + 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 + + 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 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 @@ -125,30 +125,30 @@ let real_nonlinear_prover d l = | _ -> 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) = + 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)) + + 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 + + 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) + 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 + let proof = list_fold_right_elements (fun s t -> Sum(s,t)) (proof_ne :: proofs_ideal @ proofs_cone) in S (Some proof) - with + with | Sos_lib.TooDeep -> S None | x -> F (Printexc.to_string x) @@ -156,17 +156,17 @@ let real_nonlinear_prover d l = let pure_sos l = let l = List.map (fun (e,o) -> Mc.denorm e, o) l in - (* If there is no strict inequality, + (* If there is no strict inequality, I should nonetheless be able to try something - over Z > is equivalent to -1 >= *) - try + 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, + let pos = Product (Rational_lt n, List.fold_right (fun (c,p) rst -> Sum (Product (Rational_lt c, Square - (term_of_poly p)), rst)) + (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 @@ -174,11 +174,11 @@ let pure_sos l = S (Some proof) with (* | Sos.CsdpNotFound -> F "Sos.CsdpNotFound" *) - | x -> (* May be that could be refined *) S None + | x -> (* May be that could be refined *) S None -let run_prover prover pb = +let run_prover prover pb = match prover with | "real_nonlinear_prover", Some d -> real_nonlinear_prover d pb | "pure_sos", None -> pure_sos pb @@ -192,17 +192,17 @@ let output_csdp_certificate o = function let main () = - try + try let (prover,poly) = (input_value stdin : provername * micromega_polys) in let cert = run_prover prover poly in (* Printf.fprintf chan "%a -> %a" print_list_term poly output_csdp_certificate cert ; close_out chan ; *) - + output_value stdout (cert:csdp_certificate); - flush stdout ; + flush stdout ; Marshal.to_channel chan (cert:csdp_certificate) [] ; - flush chan ; - exit 0 + flush chan ; + exit 0 with x -> (Printf.fprintf chan "error %s" (Printexc.to_string x) ; exit 1) ;; diff --git a/plugins/micromega/mfourier.ml b/plugins/micromega/mfourier.ml index c547b3d4ae..6250e324a5 100644 --- a/plugins/micromega/mfourier.ml +++ b/plugins/micromega/mfourier.ml @@ -8,100 +8,100 @@ let debug = false type ('a,'b) lr = Inl of 'a | Inr of 'b -module Vect = - struct +module Vect = + struct (** [t] is the type of vectors. A vector [(x1,v1) ; ... ; (xn,vn)] is such that: - variables indexes are ordered (x1 < ... < xn - values are all non-zero *) type var = int - type t = (var * num) list + type t = (var * num) list -(** [equal v1 v2 = true] if the vectors are syntactically equal. +(** [equal v1 v2 = true] if the vectors are syntactically equal. ([num] is not handled by [Pervasives.equal] *) - let rec equal v1 v2 = + let rec equal v1 v2 = match v1 , v2 with | [] , [] -> true | [] , _ -> false | _::_ , [] -> false - | (i1,n1)::v1 , (i2,n2)::v2 -> + | (i1,n1)::v1 , (i2,n2)::v2 -> (i1 = i2) && n1 =/ n2 && equal v1 v2 - let hash v = - let rec hash i = function + let hash v = + let rec hash i = function | [] -> i | (vr,vl)::l -> hash (i + (Hashtbl.hash (vr, float_of_num vl))) l in Hashtbl.hash (hash 0 v ) - + let null = [] - let pp_vect o vect = + let pp_vect o vect = List.iter (fun (v,n) -> Printf.printf "%sx%i + " (string_of_num n) v) vect - - let from_list (l: num list) = - let rec xfrom_list i l = + + let from_list (l: num list) = + let rec xfrom_list i l = match l with | [] -> [] - | e::l -> - if e <>/ Int 0 + | e::l -> + if e <>/ Int 0 then (i,e)::(xfrom_list (i+1) l) else xfrom_list (i+1) l in - + xfrom_list 0 l let zero_num = Int 0 let unit_num = Int 1 - - - let to_list m = + + + let to_list m = let rec xto_list i l = match l with | [] -> [] - | (x,v)::l' -> + | (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 cons i v rst = if v =/ Int 0 then rst else (i,v)::rst - - let rec update i f t = + + let rec update i f t = match t with | [] -> cons i (f zero_num) [] - | (k,v)::l -> + | (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 rec set i n t = match t with | [] -> cons i n [] - | (k,v)::l -> + | (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 gcd m = + + let gcd m = let res = List.fold_left (fun x (i,e) -> Big_int.gcd_big_int x (Utils.numerator e)) Big_int.zero_big_int m in - if Big_int.compare_big_int res Big_int.zero_big_int = 0 + if Big_int.compare_big_int res Big_int.zero_big_int = 0 then Big_int.unit_big_int else res - - let rec mul z t = + + let rec mul z t = match z with | Int 0 -> [] | Int 1 -> t | _ -> List.map (fun (i,n) -> (i, mult_num z n)) t - let compare : t -> t -> int = Utils.Cmp.compare_list (fun x y -> Utils.Cmp.compare_lexical + let compare : t -> t -> int = Utils.Cmp.compare_list (fun x y -> Utils.Cmp.compare_lexical [ (fun () -> Pervasives.compare (fst x) (fst y)); - (fun () -> compare_num (snd x) (snd y))]) + (fun () -> compare_num (snd x) (snd y))]) (** [tail v vect] returns - [None] if [v] is not a variable of the vector [vect] @@ -109,16 +109,16 @@ module Vect = and [rst] is the remaining of the vector We exploit that vectors are ordered lists *) - let rec tail (v:var) (vect:t) = + let rec tail (v:var) (vect:t) = match vect with | [] -> None - | (v',vl)::vect' -> + | (v',vl)::vect' -> match Pervasives.compare v' v with | 0 -> Some (vl,vect) (* Ok, found *) | -1 -> tail v vect' (* Might be in the tail *) | _ -> None (* Hopeless *) - - let get v vect = + + let get v vect = match tail v vect with | None -> None | Some(vl,_) -> Some vl @@ -134,13 +134,13 @@ module Vect = open Vect (** Implementation of intervals *) -module Itv = -struct - +module Itv = +struct + (** The type of intervals is *) type interval = num option * num option (** None models the absence of bound i.e. infinity *) - (** As a result, + (** As a result, - None , None -> ]-oo,+oo[ - None , Some v -> ]-oo,v] - Some v, None -> [v,+oo[ @@ -148,36 +148,36 @@ struct Intervals needs to be explicitely normalised. *) - type who = Left | Right + type who = Left | Right - (** if then interval [itv] is empty, [norm_itv itv] returns [None] + (** if then interval [itv] is empty, [norm_itv itv] returns [None] otherwise, it returns [Some itv] *) - - let norm_itv itv = + + let norm_itv itv = match itv with | Some a , Some b -> if a <=/ b then Some itv else None | _ -> Some itv - + (** [opp_itv itv] computes the opposite interval *) - let opp_itv itv = + let opp_itv itv = let (l,r) = itv in (map_option minus_num r, map_option minus_num l) - + (** [inter i1 i2 = None] if the intersection of intervals is empty [inter i1 i2 = Some i] if [i] is the intersection of the intervals [i1] and [i2] *) - let inter i1 i2 = + let inter i1 i2 = let (l1,r1) = i1 and (l2,r2) = i2 in - - let inter f o1 o2 = + + let inter f o1 o2 = match o1 , o2 with | None , None -> None | Some _ , None -> o1 - | None , Some _ -> o2 + | None , Some _ -> o2 | Some n1 , Some n2 -> Some (f n1 n2) in norm_itv (inter max_num l1 l2 , inter min_num r1 r2) @@ -185,9 +185,9 @@ struct let range = function | None,_ | _,None -> None | Some i,Some j -> Some (floor_num j -/ceiling_num i +/ (Int 1)) - - let smaller_itv i1 i2 = + + let smaller_itv i1 i2 = match range i1 , range i2 with | None , _ -> false | _ , None -> true @@ -204,7 +204,7 @@ let in_bound bnd v = | Some a , Some b -> a <=/ v && v <=/ b end -open Itv +open Itv type vector = Vect.t type cstr = { coeffs : vector ; bound : interval } @@ -220,22 +220,22 @@ module PSet = ISet module System = Hashtbl.Make(Vect) - type proof = - | Hyp of int + type proof = + | Hyp of int | Elim of var * proof * proof | And of proof * proof -type system = { - sys : cstr_info ref System.t ; +type system = { + sys : cstr_info ref System.t ; vars : ISet.t -} -and cstr_info = { +} +and cstr_info = { bound : interval ; prf : proof ; pos : int ; - neg : int ; + neg : int ; } @@ -247,85 +247,85 @@ and cstr_info = { When a new constraint c is computed by a function f(c1,...,cn), its proof_idx is ISet.fold union (List.map (fun x -> x.proof_idx) [c1;...;cn] - [pos] is the number of positive values of the vector - [neg] is the number of negative values of the vector - ( [neg] + [pos] is therefore the length of the vector) + ( [neg] + [pos] is therefore the length of the vector) [v] is an upper-bound of the set of variables which appear in [s]. *) (** To be thrown when a system has no solution *) exception SystemContradiction of proof -let hyps prf = - let rec hyps prf acc = +let hyps prf = + let rec hyps prf acc = match prf with | Hyp i -> ISet.add i acc - | Elim(_,prf1,prf2) + | Elim(_,prf1,prf2) | And(prf1,prf2) -> hyps prf1 (hyps prf2 acc) in hyps prf ISet.empty (** Pretty printing *) - let rec pp_proof o prf = + let rec pp_proof o prf = match prf with | Hyp i -> Printf.fprintf o "H%i" i | Elim(v, prf1,prf2) -> Printf.fprintf o "E(%i,%a,%a)" v pp_proof prf1 pp_proof prf2 | And(prf1,prf2) -> Printf.fprintf o "A(%a,%a)" pp_proof prf1 pp_proof prf2 - + let pp_bound o = function | None -> output_string o "oo" | Some a -> output_string o (string_of_num a) let pp_itv o (l,r) = Printf.fprintf o "(%a,%a)" pp_bound l pp_bound r -let rec pp_list f o l = +let rec pp_list f o l = match l with | [] -> () | e::l -> f o e ; output_string o ";" ; pp_list f o l -let pp_iset o s = +let pp_iset o s = output_string o "{" ; ISet.fold (fun i _ -> Printf.fprintf o "%i " i) s (); - output_string o "}" + output_string o "}" -let pp_pset o s = +let pp_pset o s = output_string o "{" ; PSet.fold (fun i _ -> Printf.fprintf o "%i " i) s (); - output_string o "}" + output_string o "}" let pp_info o i = pp_itv o i.bound -let pp_cstr o (vect,bnd) = +let pp_cstr o (vect,bnd) = let (l,r) = bnd in (match l with | None -> () | Some n -> Printf.fprintf o "%s <= " (string_of_num n)) ; - pp_vect o vect ; + pp_vect o vect ; (match r with | None -> output_string o"\n" | Some n -> Printf.fprintf o "<=%s\n" (string_of_num n)) -let pp_system o sys= - System.iter (fun vect ibnd -> +let pp_system o sys= + System.iter (fun vect ibnd -> pp_cstr o (vect,(!ibnd).bound)) sys -let pp_split_cstr o (vl,v,c,_) = +let pp_split_cstr o (vl,v,c,_) = Printf.fprintf o "(val x = %s ,%a,%s)" (string_of_num vl) pp_vect v (string_of_num c) (** [merge_cstr_info] takes: - - the intersection of bounds and + - the intersection of bounds and - the union of proofs - [pos] and [neg] fields should be identical *) -let merge_cstr_info i1 i2 = +let merge_cstr_info i1 i2 = let { pos = p1 ; neg = n1 ; bound = i1 ; prf = prf1 } = i1 and { pos = p2 ; neg = n2 ; bound = i2 ; prf = prf2 } = i2 in - assert (p1 = p2 && n1 = n2) ; + assert (p1 = p2 && n1 = n2) ; match inter i1 i2 with | None -> None (* Could directly raise a system contradiction exception *) - | Some bnd -> + | Some bnd -> Some { pos = p1 ; neg = n1 ; bound = bnd ; prf = And(prf1,prf2) } (** [xadd_cstr vect cstr_info] loads an constraint into the system. @@ -333,18 +333,18 @@ let merge_cstr_info i1 i2 = @raise SystemContradiction if [cstr_info] returns [None] *) -let xadd_cstr vect cstr_info sys = - if debug && System.length sys mod 1000 = 0 then (print_string "*" ; flush stdout) ; - try +let xadd_cstr vect cstr_info sys = + if debug && System.length sys mod 1000 = 0 then (print_string "*" ; flush stdout) ; + try let info = System.find sys vect in match merge_cstr_info cstr_info !info with | None -> raise (SystemContradiction (And(cstr_info.prf, (!info).prf))) | Some info' -> info := info' - with + with | Not_found -> System.replace sys vect (ref cstr_info) -type cstr_ext = +type cstr_ext = | Contradiction (** The constraint is contradictory. Typically, a [SystemContradiction] exception will be raised. *) | Redundant (** The constrain is redundant. @@ -353,16 +353,16 @@ type cstr_ext = Typically, it will be added to the constraint system. *) (** [normalise_cstr] : vector -> cstr_info -> cstr_ext *) -let normalise_cstr vect cinfo = +let normalise_cstr vect cinfo = match norm_itv cinfo.bound with | None -> Contradiction - | Some (l,r) -> + | Some (l,r) -> match vect with | [] -> if Itv.in_bound (l,r) (Int 0) then Redundant else Contradiction | (_,n)::_ -> Cstr( - (if n <>/ Int 1 then List.map (fun (x,nx) -> (x,nx // n)) vect else vect), + (if n <>/ Int 1 then List.map (fun (x,nx) -> (x,nx // n)) vect else vect), let divn x = x // n in - if sign_num n = 1 + if sign_num n = 1 then{cinfo with bound = (map_option divn l , map_option divn r) } else {cinfo with pos = cinfo.neg ; neg = cinfo.pos ; bound = (map_option divn r , map_option divn l)}) @@ -378,21 +378,21 @@ let eval_op = function | Eq -> (=/) | Ge -> (>=/) -let count v = +let count v = let rec count n p v = match v with | [] -> (n,p) - | (_,vl)::v -> let sg = sign_num vl in - assert (sg <> 0) ; + | (_,vl)::v -> let sg = sign_num vl in + assert (sg <> 0) ; if sg = 1 then count n (p+1) v else count (n+1) p v in count 0 0 v let norm_cstr {coeffs = v ; op = o ; cst = c} idx = - let (n,p) = count v in + let (n,p) = count v in - normalise_cstr v {pos = p ; neg = n ; bound = - (match o with + normalise_cstr v {pos = p ; neg = n ; bound = + (match o with | Eq -> Some c , Some c | Ge -> Some c , None) ; prf = Hyp idx } @@ -402,60 +402,60 @@ let norm_cstr {coeffs = v ; op = o ; cst = c} idx = @return a system of constraints @raise SystemContradiction if a contradiction is found *) -let load_system l = - +let load_system l = + let sys = System.create 1000 in - + let li = Mutils.mapi (fun e i -> (e,i)) l in - let vars = List.fold_left (fun vrs (cstr,i) -> + let vars = List.fold_left (fun vrs (cstr,i) -> match norm_cstr cstr i with | Contradiction -> raise (SystemContradiction (Hyp i)) | Redundant -> vrs - | Cstr(vect,info) -> + | Cstr(vect,info) -> xadd_cstr vect info sys ; List.fold_left (fun s (v,_) -> ISet.add v s) vrs cstr.coeffs) ISet.empty li in {sys = sys ;vars = vars} -let system_list sys = - let { sys = s ; vars = v } = sys in - System.fold (fun k bi l -> (k, !bi)::l) s [] +let system_list sys = + let { sys = s ; vars = v } = sys in + System.fold (fun k bi l -> (k, !bi)::l) s [] -(** [add (v1,c1) (v2,c2) ] +(** [add (v1,c1) (v2,c2) ] precondition: (c1 <>/ Int 0 && c2 <>/ Int 0) - @return a pair [(v,ln)] such that + @return a pair [(v,ln)] such that [v] is the sum of vector [v1] divided by [c1] and vector [v2] divided by [c2] Note that the resulting vector is not normalised. *) -let add (v1,c1) (v2,c2) = +let add (v1,c1) (v2,c2) = assert (c1 <>/ Int 0 && c2 <>/ Int 0) ; - let rec xadd v1 v2 = + let rec xadd v1 v2 = match v1 , v2 with - | (x1,n1)::v1' , (x2,n2)::v2' -> - if x1 = x2 - then + | (x1,n1)::v1' , (x2,n2)::v2' -> + if x1 = x2 + then let n' = (n1 // c1) +/ (n2 // c2) in - if n' =/ Int 0 then xadd v1' v2' - else + if n' =/ Int 0 then xadd v1' v2' + else let res = xadd v1' v2' in (x1,n') ::res else if x1 < x2 then let res = xadd v1' v2 in - (x1, n1 // c1)::res + (x1, n1 // c1)::res else let res = xadd v1 v2' in (x2, n2 // c2)::res | [] , [] -> [] | [] , _ -> List.map (fun (x,vl) -> (x,vl // c2)) v2 | _ , [] -> List.map (fun (x,vl) -> (x,vl // c1)) v1 in - + let res = xadd v1 v2 in (res, count res) -let add (v1,c1) (v2,c2) = +let add (v1,c1) (v2,c2) = let res = add (v1,c1) (v2,c2) in (* Printf.printf "add(%a,%s,%a,%s) -> %a\n" pp_vect v1 (string_of_num c1) pp_vect v2 (string_of_num c2) pp_vect (fst res) ;*) res @@ -464,27 +464,27 @@ type tlr = (num * vector * cstr_info) list type tm = (vector * cstr_info ) list (** To perform Fourier elimination, constraints are categorised depending on the sign of the variable to eliminate. *) - + (** [split x vect info (l,m,r)] @param v is the variable to eliminate - @param l contains constraints such that (e + a*x) // a >= c / a + @param l contains constraints such that (e + a*x) // a >= c / a @param r contains constraints such that (e + a*x) // - a >= c / -a @param m contains constraints which do not mention [x] *) let split x (vect: vector) info (l,m,r) = - match get x vect with + match get x vect with | None -> (* The constraint does not mention [x], store it in m *) - (l,(vect,info)::m,r) + (l,(vect,info)::m,r) | Some vl -> (* otherwise *) - let cons_bound lst bd = + let cons_bound lst bd = match bd with | None -> lst | Some bnd -> (vl,vect,{info with bound = Some bnd,None})::lst in - + let lb,rb = info.bound in - if sign_num vl = 1 + if sign_num vl = 1 then (cons_bound l lb,m,cons_bound r rb) else (* sign_num vl = -1 *) (cons_bound l rb,m,cons_bound r lb) @@ -493,36 +493,36 @@ let split x (vect: vector) info (l,m,r) = (** [project vr sys] projects system [sys] over the set of variables [ISet.remove vr sys.vars ]. This is a one step Fourier elimination. *) -let project vr sys = - +let project vr sys = + let (l,m,r) = System.fold (fun vect rf l_m_r -> split vr vect !rf l_m_r) sys.sys ([],[],[]) in let new_sys = System.create (System.length sys.sys) in - + (* Constraints in [m] belong to the projection - for those [vr] is already projected out *) List.iter (fun (vect,info) -> System.replace new_sys vect (ref info) ) m ; - let elim (v1,vect1,info1) (v2,vect2,info2) = + let elim (v1,vect1,info1) (v2,vect2,info2) = let {neg = n1 ; pos = p1 ; bound = bound1 ; prf = prf1} = info1 and {neg = n2 ; pos = p2 ; bound = bound2 ; prf = prf2} = info2 in - let bnd1 = from_option (fst bound1) + let bnd1 = from_option (fst bound1) and bnd2 = from_option (fst bound2) in let bound = (bnd1 // v1) +/ (bnd2 // minus_num v2) in let vres,(n,p) = add (vect1,v1) (vect2,minus_num v2) in (vres,{neg = n ; pos = p ; bound = (Some bound, None); prf = Elim(vr,info1.prf,info2.prf)}) in - List.iter(fun l_elem -> List.iter (fun r_elem -> + List.iter(fun l_elem -> List.iter (fun r_elem -> let (vect,info) = elim l_elem r_elem in match normalise_cstr vect info with | Redundant -> () | Contradiction -> raise (SystemContradiction info.prf) | Cstr(vect,info) -> xadd_cstr vect info new_sys) r ) l; {sys = new_sys ; vars = ISet.remove vr sys.vars} - + (** [project_using_eq] performs elimination by pivoting using an equation. - This is the counter_part of the [elim] sub-function of [!project]. + This is the counter_part of the [elim] sub-function of [!project]. @param vr is the variable to be used as pivot @param c is the coefficient of variable [vr] in vector [vect] @param len is the length of the equation @@ -530,42 +530,42 @@ let project vr sys = @param prf is the proof of the equation *) -let project_using_eq vr c vect bound prf (vect',info') = +let project_using_eq vr c vect bound prf (vect',info') = match get vr vect' with - | Some c2 -> + | Some c2 -> let c1 = if c2 >=/ Int 0 then minus_num c else c in - + let c2 = abs_num c2 in - + let (vres,(n,p)) = add (vect,c1) (vect', c2) in - + let cst = bound // c1 in - - let bndres = + + let bndres = let f x = cst +/ x // c2 in let (l,r) = info'.bound in (map_option f l , map_option f r) in - + (vres,{neg = n ; pos = p ; bound = bndres ; prf = Elim(vr,prf,info'.prf)}) | None -> (vect',info') let elim_var_using_eq vr vect cst prf sys = let c = from_option (get vr vect) in - + let elim_var = project_using_eq vr c vect cst prf in let new_sys = System.create (System.length sys.sys) in - System.iter(fun vect iref -> + System.iter(fun vect iref -> let (vect',info') = elim_var (vect,!iref) in match normalise_cstr vect' info' with | Redundant -> () | Contradiction -> raise (SystemContradiction info'.prf) - | Cstr(vect,info') -> xadd_cstr vect info' new_sys) sys.sys ; - + | Cstr(vect,info') -> xadd_cstr vect info' new_sys) sys.sys ; + {sys = new_sys ; vars = ISet.remove vr sys.vars} - + (** [size sys] computes the number of entries in the system of constraints *) let size sys = System.fold (fun v iref s -> s + (!iref).neg + (!iref).pos) sys 0 @@ -577,23 +577,23 @@ let pp_map o map = IMap.fold (fun k elt () -> Printf.fprintf o "%i -> %s\n" k (s If [map] binds all the variables of [vect], we get [eval_vect map [(x1,v1);...;(xn,vn)] = (IMap.find x1 map * v1) + ... + (IMap.find xn map) * vn , []] The function returns as second argument, a sub-vector consisting in the variables that are not in [map]. *) - -let eval_vect map vect = - let rec xeval_vect vect sum rst = + +let eval_vect map vect = + let rec xeval_vect vect sum rst = match vect with | [] -> (sum,rst) - | (v,vl)::vect -> - try + | (v,vl)::vect -> + try let val_v = IMap.find v map in xeval_vect vect (sum +/ (val_v */ vl)) rst with Not_found -> xeval_vect vect sum ((v,vl)::rst) in xeval_vect vect (Int 0) [] - + (** [restrict_bound n sum itv] returns the interval of [x] given that (fst itv) <= x * n + sum <= (snd itv) *) -let restrict_bound n sum (itv:interval) = +let restrict_bound n sum (itv:interval) = let f x = (x -/ sum) // n in let l,r = itv in match sign_num n with @@ -606,8 +606,8 @@ let restrict_bound n sum (itv:interval) = (** [bound_of_variable map v sys] computes the interval of [v] in [sys] given a mapping [map] binding all the other variables *) -let bound_of_variable map v sys = - System.fold (fun vect iref bnd -> +let bound_of_variable map v sys = + System.fold (fun vect iref bnd -> let sum,rst = eval_vect map vect in let vl = match get v rst with | None -> Int 0 @@ -618,53 +618,53 @@ let bound_of_variable map v sys = (** [pick_small_value bnd] picks a value being closed to zero within the interval *) -let pick_small_value bnd = +let pick_small_value bnd = match bnd with | None , None -> Int 0 | None , Some i -> if (Int 0) <=/ (floor_num i) then Int 0 else floor_num i | Some i,None -> if i <=/ (Int 0) then Int 0 else ceiling_num i - | Some i,Some j -> - if i <=/ Int 0 && Int 0 <=/ j + | Some i,Some j -> + if i <=/ Int 0 && Int 0 <=/ j then Int 0 - else if ceiling_num i <=/ floor_num j + else if ceiling_num i <=/ floor_num j then ceiling_num i (* why not *) else i -(** [solution s1 sys_l = Some(sn,[(vn-1,sn-1);...; (v1,s1)]@sys_l)] +(** [solution s1 sys_l = Some(sn,[(vn-1,sn-1);...; (v1,s1)]@sys_l)] then [sn] is a system which contains only [black_v] -- if it existed in [s1] - and [sn+1] is obtained by projecting [vn] out of [sn] - @raise SystemContradiction if system [s] has no solution + and [sn+1] is obtained by projecting [vn] out of [sn] + @raise SystemContradiction if system [s] has no solution *) -let solve_sys black_v choose_eq choose_variable sys sys_l = +let solve_sys black_v choose_eq choose_variable sys sys_l = - let rec solve_sys sys sys_l = + let rec solve_sys sys sys_l = if debug then Printf.printf "S #%i size %i\n" (System.length sys.sys) (size sys.sys); - + let eqs = choose_eq sys in - try + try let (v,vect,cst,ln) = fst (List.find (fun ((v,_,_,_),_) -> v <> black_v) eqs) in - if debug then + if debug then (Printf.printf "\nE %a = %s variable %i\n" pp_vect vect (string_of_num cst) v ; flush stdout); let sys' = elim_var_using_eq v vect cst ln sys in - solve_sys sys' ((v,sys)::sys_l) - with Not_found -> + solve_sys sys' ((v,sys)::sys_l) + with Not_found -> let vars = choose_variable sys in - try + try let (v,est) = (List.find (fun (v,_) -> v <> black_v) vars) in - if debug then (Printf.printf "\nV : %i esimate %f\n" v est ; flush stdout) ; + if debug then (Printf.printf "\nV : %i esimate %f\n" v est ; flush stdout) ; let sys' = project v sys in - solve_sys sys' ((v,sys)::sys_l) + solve_sys sys' ((v,sys)::sys_l) with Not_found -> (* we are done *) Inl (sys,sys_l) in solve_sys sys sys_l -let solve black_v choose_eq choose_variable cstrs = +let solve black_v choose_eq choose_variable cstrs = - try + try let sys = load_system cstrs in (* Printf.printf "solve :\n %a" pp_system sys.sys ; *) solve_sys black_v choose_eq choose_variable sys [] @@ -675,22 +675,22 @@ let solve black_v choose_eq choose_variable cstrs = The output is an ordered list of (variable,cost). *) -module EstimateElimVar = +module EstimateElimVar = struct type sys_list = (vector * cstr_info) list let abstract_partition (v:int) (l: sys_list) = - let rec xpart (l:sys_list) (ltl:sys_list) (n:int list) (z:int) (p:int list) = + let rec xpart (l:sys_list) (ltl:sys_list) (n:int list) (z:int) (p:int list) = match l with | [] -> (ltl, n,z,p) - | (l1,info) ::rl -> + | (l1,info) ::rl -> match l1 with | [] -> xpart rl (([],info)::ltl) n (info.neg+info.pos+z) p - | (vr,vl)::rl1 -> + | (vr,vl)::rl1 -> if v = vr then - let cons_bound lst bd = + let cons_bound lst bd = match bd with | None -> lst | Some bnd -> info.neg+info.pos::lst in @@ -701,7 +701,7 @@ struct else xpart rl ((rl1,info)::ltl) (cons_bound n rb) z (cons_bound p lb) else (* the variable is greater *) - xpart rl ((l1,info)::ltl) n (info.neg+info.pos+z) p + xpart rl ((l1,info)::ltl) n (info.neg+info.pos+z) p in let (sys',n,z,p) = xpart l [] [] 0 [] in @@ -711,72 +711,72 @@ struct let lp = float_of_int (List.length p) in let sp = float_of_int (List.fold_left (+) 0 p) in (sys', float_of_int z +. lp *. sn +. ln *. sp -. lp*.ln) - - + + let choose_variable sys = let {sys = s ; vars = v} = sys in - + let sl = system_list sys in let evals = fst (ISet.fold (fun v (eval,s) -> let ts,vl = abstract_partition v s in ((v,vl)::eval, ts)) v ([],sl)) in - + List.sort (fun x y -> Pervasives.compare (snd x) (snd y) ) evals -end +end open EstimateElimVar (** The module [EstimateElimEq] is similar to [EstimateElimVar] but it orders equations. *) module EstimateElimEq = -struct - - let itv_point bnd = +struct + + let itv_point bnd = match bnd with |(Some a, Some b) -> a =/ b | _ -> false - let eq_bound bnd c = + let eq_bound bnd c = match bnd with |(Some a, Some b) -> a =/ b && c =/ b | _ -> false - - let rec unroll_until v l = + + let rec unroll_until v l = match l with | [] -> (false,[]) - | (i,_)::rl -> if i = v - then (true,rl) + | (i,_)::rl -> if i = v + then (true,rl) else if i < v then unroll_until v rl else (false,l) - let choose_primal_equation eqs sys_l = + let choose_primal_equation eqs sys_l = - let is_primal_equation_var v = - List.fold_left (fun (nb_eq,nb_cst) (vect,info) -> - if fst (unroll_until v vect) + let is_primal_equation_var v = + List.fold_left (fun (nb_eq,nb_cst) (vect,info) -> + if fst (unroll_until v vect) then if itv_point info.bound then (nb_eq + 1,nb_cst) else (nb_eq,nb_cst) else (nb_eq,nb_cst)) (0,0) sys_l in - let rec find_var vect = + let rec find_var vect = match vect with | [] -> None - | (i,_)::vect -> + | (i,_)::vect -> let (nb_eq,nb_cst) = is_primal_equation_var i in if nb_eq = 2 && nb_cst = 0 then Some i else find_var vect in - let rec find_eq_var eqs = + let rec find_eq_var eqs = match eqs with | [] -> None - | (vect,a,prf,ln)::l -> - match find_var vect with + | (vect,a,prf,ln)::l -> + match find_var vect with | None -> find_eq_var l - | Some r -> Some (r,vect,a,prf,ln) + | Some r -> Some (r,vect,a,prf,ln) in - + find_eq_var eqs @@ -787,33 +787,33 @@ struct let sys_l = system_list sys in - let equalities = List.fold_left - (fun l (vect,info) -> + let equalities = List.fold_left + (fun l (vect,info) -> match info.bound with - | Some a , Some b -> + | Some a , Some b -> if a =/ b then (* This an equation *) (vect,a,info.prf,info.neg+info.pos)::l else l | _ -> l ) [] sys_l in - let rec estimate_cost v ct sysl acc tlsys = + let rec estimate_cost v ct sysl acc tlsys = match sysl with | [] -> (acc,tlsys) | (l,info)::rsys -> let ln = info.pos + info.neg in let (b,l) = unroll_until v l in match b with - | true -> - if itv_point info.bound + | true -> + if itv_point info.bound then estimate_cost v ct rsys (acc+ln) ((l,info)::tlsys) (* this is free *) else estimate_cost v ct rsys (acc+ln+ct) ((l,info)::tlsys) (* should be more ? *) | false -> estimate_cost v ct rsys (acc+ln) ((l,info)::tlsys) in match choose_primal_equation equalities sys_l with - | None -> - let cost_eq eq const prf ln acc_costs = - - let rec cost_eq eqr sysl costs = + | None -> + let cost_eq eq const prf ln acc_costs = + + let rec cost_eq eqr sysl costs = match eqr with | [] -> costs | (v,_) ::eqr -> let (cst,tlsys) = estimate_cost v (ln-1) sysl 0 [] in @@ -823,7 +823,7 @@ struct let all_costs = List.fold_left (fun all_costs (vect,const,prf,ln) -> cost_eq vect const prf ln all_costs) [] equalities in (* pp_list (fun o ((v,eq,_,_),cst) -> Printf.fprintf o "((%i,%a),%i)\n" v pp_vect eq cst) stdout all_costs ; *) - + List.sort (fun x y -> Pervasives.compare (snd x) (snd y) ) all_costs | Some (v,vect, const,prf,_) -> [(v,vect,const,prf),0] @@ -834,33 +834,33 @@ open EstimateElimEq module Fourier = struct - let optimise vect l = + let optimise vect l = (* We add a dummy (fresh) variable for vector *) - let fresh = + let fresh = List.fold_left (fun fr c -> Pervasives.max fr (Vect.fresh c.coeffs)) 0 l in let cstr = { - coeffs = Vect.set fresh (Int (-1)) vect ; - op = Eq ; + coeffs = Vect.set fresh (Int (-1)) vect ; + op = Eq ; cst = (Int 0)} in match solve fresh choose_equality_var choose_variable (cstr::l) with | Inr prf -> None (* This is an unsatisfiability proof *) - | Inl (s,_) -> - try + | Inl (s,_) -> + try Some (bound_of_variable IMap.empty fresh s.sys) with x -> Printf.printf "optimise Exception : %s" (Printexc.to_string x) ; None - let find_point cstrs = - + let find_point cstrs = + match solve max_int choose_equality_var choose_variable cstrs with | Inr prf -> Inr prf - | Inl (_,l) -> - - let rec rebuild_solution l map = + | Inl (_,l) -> + + let rec rebuild_solution l map = match l with | [] -> map - | (v,e)::l -> + | (v,e)::l -> let itv = bound_of_variable map v e.sys in let map = IMap.add v (pick_small_value itv) map in rebuild_solution l map @@ -877,9 +877,9 @@ end module Proof = -struct - - +struct + + (** A proof term in the sense of a ZMicromega.RatProof is a positive combination of the hypotheses which leads to a contradiction. @@ -893,49 +893,49 @@ struct let forall_pairs f l1 l2 = List.fold_left (fun acc e1 -> - List.fold_left (fun acc e2 -> + List.fold_left (fun acc e2 -> match f e1 e2 with | None -> acc | Some v -> v::acc) acc l2) [] l1 - let add_op x y = + let add_op x y = match x , y with | Eq , Eq -> Eq | _ -> Ge - let pivot v (p1,c1) (p2,c2) = + let pivot v (p1,c1) (p2,c2) = let {coeffs = v1 ; op = op1 ; cst = n1} = c1 and {coeffs = v2 ; op = op2 ; cst = n2} = c2 in - + match Vect.get v v1 , Vect.get v v2 with | None , _ | _ , None -> None - | Some a , Some b -> + | Some a , Some b -> if (sign_num a) * (sign_num b) = -1 - then Some (add (p1,abs_num a) (p2,abs_num b) , - {coeffs = add (v1,abs_num a) (v2,abs_num b) ; + then Some (add (p1,abs_num a) (p2,abs_num b) , + {coeffs = add (v1,abs_num a) (v2,abs_num b) ; op = add_op op1 op2 ; cst = n1 // (abs_num a) +/ n2 // (abs_num b) }) else if op1 = Eq - then Some (add (p1,minus_num (a // b)) (p2,Int 1), - {coeffs = add (v1,minus_num (a// b)) (v2 ,Int 1) ; + then Some (add (p1,minus_num (a // b)) (p2,Int 1), + {coeffs = add (v1,minus_num (a// b)) (v2 ,Int 1) ; op = add_op op1 op2; cst = n1 // (minus_num (a// b)) +/ n2 // (Int 1)}) else if op2 = Eq then - Some (add (p2,minus_num (b // a)) (p1,Int 1), - {coeffs = add (v2,minus_num (b// a)) (v1 ,Int 1) ; + Some (add (p2,minus_num (b // a)) (p1,Int 1), + {coeffs = add (v2,minus_num (b// a)) (v1 ,Int 1) ; op = add_op op1 op2; cst = n2 // (minus_num (b// a)) +/ n1 // (Int 1)}) - else None (* op2 could be Eq ... this might happen *) - + else None (* op2 could be Eq ... this might happen *) + - let normalise_proofs l = - List.fold_left (fun acc (prf,cstr) -> + let normalise_proofs l = + List.fold_left (fun acc (prf,cstr) -> match acc with | Inr _ -> acc (* I already found a contradiction *) - | Inl acc -> + | Inl acc -> match norm_cstr cstr 0 with | Redundant -> Inl acc | Contradiction -> Inr (prf,cstr) @@ -944,11 +944,11 @@ struct type oproof = (vector * cstr_compat * num) option - let merge_proof (oleft:oproof) (prf,cstr,v,info) (oright:oproof) = + let merge_proof (oleft:oproof) (prf,cstr,v,info) (oright:oproof) = let (l,r) = info.bound in - let keep p ob bd = - match ob , bd with + let keep p ob bd = + match ob , bd with | None , None -> None | None , Some b -> Some(prf,cstr,b) | Some _ , None -> ob @@ -959,24 +959,24 @@ struct (* Now, there might be a contradiction *) match oleft , oright with | None , _ | _ , None -> Inl (oleft,oright) - | Some(prfl,cstrl,l) , Some(prfr,cstrr,r) -> - if l <=/ r + | Some(prfl,cstrl,l) , Some(prfr,cstrr,r) -> + if l <=/ r then Inl (oleft,oright) else (* There is a contradiction - it should show up by scaling up the vectors - any pivot should do*) match cstrr.coeffs with | [] -> Inr (add (prfl,Int 1) (prfr,Int 1), cstrr) (* this is wrong *) - | (v,_)::_ -> + | (v,_)::_ -> match pivot v (prfl,cstrl) (prfr,cstrr) with | None -> failwith "merge_proof : pivot is not possible" | Some x -> Inr x -let mk_proof hyps prf = +let mk_proof hyps prf = (* I am keeping list - I might have a proof for the left bound and a proof for the right bound. If I perform aggressive elimination of redundancies, I expect the list to be of length at most 2. For each proof list, all the vectors should be of the form a.v for different constants a. *) - let rec mk_proof prf = + let rec mk_proof prf = match prf with | Hyp i -> [ ([i, Int 1] , List.nth hyps i) ] @@ -985,15 +985,15 @@ let mk_proof hyps prf = and prfsr = mk_proof prf2 in (* I take only the pairs for which the elimination is meaningfull *) forall_pairs (pivot v) prfsl prfsr - | And(prf1,prf2) -> - let prfsl1 = mk_proof prf1 + | And(prf1,prf2) -> + let prfsl1 = mk_proof prf1 and prfsl2 = mk_proof prf2 in (* detect trivial redundancies and contradictions *) match normalise_proofs (prfsl1@prfsl2) with | Inr x -> [x] (* This is a contradiction - this should be the end of the proof *) | Inl l -> (* All the vectors are the same *) - let prfs = - List.fold_left (fun acc e -> + let prfs = + List.fold_left (fun acc e -> match acc with | Inr _ -> acc (* I have a contradiction *) | Inl (oleft,oright) -> merge_proof oleft e oright) (Inl(None,None)) l in @@ -1008,5 +1008,5 @@ let mk_proof hyps prf = mk_proof prf -end +end diff --git a/plugins/micromega/micromega.ml b/plugins/micromega/micromega.ml index d884f26598..5c45c8f5fa 100644 --- a/plugins/micromega/micromega.ml +++ b/plugins/micromega/micromega.ml @@ -803,7 +803,7 @@ let rec pmul cO cI cadd cmul ceqb p p'' = match p'' with (match q0 with | Pc c -> q0 | Pinj (j', q1) -> Pinj ((pplus XH j'), q1) - | PX (p3, p4, p5) -> Pinj (XH, q0)) p')) i' + | PX (p3, p4, p5) -> Pinj (XH, q0)) p')) i' (p0 cO)) (mkPX cO ceqb (pmulI cO cI cmul ceqb (fun x x0 -> @@ -1599,16 +1599,16 @@ let rec zChecker l = function (match op4 with | NonStrict -> if is_pol_Z0 (padd1 e1 e2) - then + then let rec label pfs lb ub = - + match pfs with - | + | [] -> if z_gt_dec lb ub then true else false - | + | pf1 :: rsr -> (&&) (zChecker diff --git a/plugins/micromega/mutils.ml b/plugins/micromega/mutils.ml index a0158b1567..ec06fa58bb 100644 --- a/plugins/micromega/mutils.ml +++ b/plugins/micromega/mutils.ml @@ -14,25 +14,25 @@ let debug = false -let finally f rst = - try +let finally f rst = + try let res = f () in rst () ; res - with x -> - (try rst () + with x -> + (try rst () with _ -> raise x ); raise x -let map_option f x = +let map_option f x = match x with | None -> None | Some v -> Some (f v) let from_option = function | None -> failwith "from_option" - | Some v -> v + | Some v -> v -let rec try_any l x = +let rec try_any l x = match l with | [] -> None | (f,s)::l -> match f x with @@ -40,20 +40,20 @@ let rec try_any l x = | x -> x let iteri f l = - let rec xiter i l = + let rec xiter i l = match l with | [] -> () | e::l -> f i e ; xiter (i+1) l in xiter 0 l let mapi f l = - let rec xmap i l = + let rec xmap i l = match l with | [] -> [] | e::l -> (f i e)::xmap (i+1) l in xmap 0 l -let rec map3 f l1 l2 l3 = +let rec map3 f l1 l2 l3 = match l1 , l2 ,l3 with | [] , [] , [] -> [] | e1::l1 , e2::l2 , e3::l3 -> (f e1 e2 e3)::(map3 f l1 l2 l3) @@ -61,14 +61,14 @@ let rec map3 f l1 l2 l3 = -let rec is_sublist l1 l2 = +let rec is_sublist l1 l2 = match l1 ,l2 with | [] ,_ -> true | e::l1', [] -> false - | e::l1' , e'::l2' -> + | e::l1' , e'::l2' -> if e = e' then is_sublist l1' l2' else is_sublist l1 l2' - + let list_try_find f = @@ -85,16 +85,16 @@ let rec list_fold_right_elements f l = | x::l -> f x (aux l) in aux l -let interval n m = +let interval n m = let rec interval_n (l,m) = if n > m then l else interval_n (m::l,pred m) - in + in interval_n ([],m) open Num open Big_int -let ppcm x y = +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 @@ -115,26 +115,26 @@ let rec ppcm_list c l = | [] -> c | e::l -> ppcm_list (ppcm c (denominator e)) l -let rec rec_gcd_list c 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 rec gcd_list l = let res = rec_gcd_list zero_big_int l in - if compare_big_int res zero_big_int = 0 + if compare_big_int res zero_big_int = 0 then unit_big_int else res - - - -let rats_to_ints l = + + + +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) + 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 = + let rec xmapi i l = match l with | [] -> [] | e::l -> (f e i)::(xmapi (i+1) l) in @@ -146,11 +146,11 @@ 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 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) ::rst -> let (l',j) = assoc_pos i l in (x,l')::(xpos j rst) in xpos 0 l @@ -159,7 +159,7 @@ let filter_pos f l = let rec xfilter l = match l with | [] -> [] - | (x,e)::l -> + | (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 @@ -169,11 +169,11 @@ let select_pos lpos l = let rec xselect i lpos l = match lpos with | [] -> [] - | j::rpos -> + | j::rpos -> match l with | [] -> failwith "select_pos" - | e::l -> - if i = j + | e::l -> + if i = j then e:: (xselect (i+1) rpos l) else xselect (i+1) lpos l in xselect 0 lpos l @@ -188,7 +188,7 @@ struct | S n -> (nat n) + 1 - let rec positive p = + let rec positive p = match p with | XH -> 1 | XI p -> 1+ 2*(positive p) @@ -208,7 +208,7 @@ struct | XO i -> 2*(index i) - let z x = + let z x = match x with | Z0 -> 0 | Zpos p -> (positive p) @@ -223,7 +223,7 @@ struct | XO p -> (mult_int_big_int 2 (positive_big_int p)) - let z_big_int x = + let z_big_int x = match x with | Z0 -> zero_big_int | Zpos p -> (positive_big_int p) @@ -232,9 +232,9 @@ struct let num x = Num.Big_int (z_big_int x) - let q_to_num {qnum = x ; qden = y} = + let q_to_num {qnum = x ; qden = y} = Big_int (z_big_int x) // (Big_int (z_big_int (Zpos y))) - + end @@ -252,8 +252,8 @@ struct else if n land 1 = 1 then XI (positive (n lsr 1)) else XO (positive (n lsr 1)) - let n nt = - if nt < 0 + let n nt = + if nt < 0 then assert false else if nt = 0 then N0 else Npos (positive nt) @@ -264,47 +264,47 @@ struct else XO (index (n lsr 1)) - let idx n = + 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 [] + if n=1 then [] else (n mod 2 = 1)::(digits_of_int (n lsr 1)) in - List.fold_right + List.fold_right (fun b c -> (if b then XI c else XO c)) (List.rev (digits_of_int n)) (XH) - let z x = + let z x = match compare x 0 with | 0 -> Z0 | 1 -> Zpos (positive x) | _ -> (* this should be -1 *) - Zneg (positive (-x)) + Zneg (positive (-x)) open Big_int - let positive_big_int n = - let two = big_int_of_int 2 in - let rec _pos n = + 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 + if eq_big_int unit_big_int m then XI (_pos q) else XO (_pos q) in _pos n - let bigint x = + 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) ; + let q n = + {Micromega.qnum = bigint (numerator n) ; Micromega.qden = positive_big_int (denominator n)} end @@ -312,23 +312,23 @@ end module Cmp = struct - let rec compare_lexical l = + let rec compare_lexical l = match l with | [] -> 0 (* Equal *) - | f::l -> + | f::l -> let cmp = f () in if cmp = 0 then compare_lexical l else cmp - let rec compare_list cmp l1 l2 = + let rec compare_list cmp l1 l2 = match l1 , l2 with | [] , [] -> 0 | [] , _ -> -1 | _ , [] -> 1 - | e1::l1 , e2::l2 -> + | 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 hash_list hash l = let rec _hash_list l h = match l with | [] -> h lxor (Hashtbl.hash []) @@ -373,21 +373,21 @@ let command exe_path args vl = let outch = Unix.out_channel_of_descr stdin_write in output_value outch vl ; flush outch ; - + (* Wait for its completion *) let _pid,status = Unix.waitpid [] pid in - finally - (fun () -> + finally + (fun () -> (* Recover the result *) match status with - | Unix.WEXITED 0 -> - let inch = Unix.in_channel_of_descr stdout_read in + | Unix.WEXITED 0 -> + let inch = Unix.in_channel_of_descr stdout_read in begin try Marshal.from_channel inch with x -> failwith (Printf.sprintf "command \"%s\" exited %s" exe_path (Printexc.to_string x)) end | Unix.WEXITED i -> failwith (Printf.sprintf "command \"%s\" exited %i" exe_path i) | Unix.WSIGNALED i -> failwith (Printf.sprintf "command \"%s\" killed %i" exe_path i) | Unix.WSTOPPED i -> failwith (Printf.sprintf "command \"%s\" stopped %i" exe_path i)) - (fun () -> + (fun () -> (* Cleanup *) List.iter (fun x -> try Unix.close x with _ -> ()) [stdin_read; stdin_write; stdout_read ; stdout_write ; stderr_read; stderr_write] ) diff --git a/plugins/micromega/persistent_cache.ml b/plugins/micromega/persistent_cache.ml index 87c9d1bbeb..f17e1c35bd 100644 --- a/plugins/micromega/persistent_cache.ml +++ b/plugins/micromega/persistent_cache.ml @@ -13,13 +13,13 @@ (************************************************************************) -module type PHashtable = +module type PHashtable = sig type 'a t - type key + type key val create : int -> string -> 'a t - (** [create i f] creates an empty persistent table + (** [create i f] creates an empty persistent table with initial size i associated with file [f] *) @@ -31,7 +31,7 @@ module type PHashtable = val find : 'a t -> key -> 'a (** find has the specification of Hashtable.find *) - + val add : 'a t -> key -> 'a -> unit (** [add tbl key elem] adds the binding [key] [elem] to the table [tbl]. (and writes the binding to the file associated with [tbl].) @@ -50,7 +50,7 @@ module type PHashtable = open Hashtbl -module PHashtable(Key:HashedType) : PHashtable with type key = Key.t = +module PHashtable(Key:HashedType) : PHashtable with type key = Key.t = struct type key = Key.t @@ -66,27 +66,27 @@ struct type mode = Closed | Open - type 'a t = - { + type 'a t = + { outch : out_channel ; - mutable status : mode ; + mutable status : mode ; htbl : 'a Table.t } -let create i f = - { - outch = open_out_bin f ; - status = Open ; +let create i f = + { + outch = open_out_bin f ; + status = Open ; htbl = Table.create i } -let finally f rst = - try +let finally f rst = + try let res = f () in rst () ; res - with x -> - (try rst () + with x -> + (try rst () with _ -> raise x ); raise x @@ -94,80 +94,80 @@ let finally f rst = let read_key_elem inch = try Some (Marshal.from_channel inch) - with + with | End_of_file -> None | _ -> raise InvalidTableFormat - -let open_in f = + +let open_in f = let flags = [Open_rdonly;Open_binary;Open_creat] in let inch = open_in_gen flags 0o666 f in let htbl = Table.create 10 in - let rec xload () = + let rec xload () = match read_key_elem inch with | None -> () - | Some (key,elem) -> - Table.add htbl key elem ; + | Some (key,elem) -> + Table.add htbl key elem ; xload () in - try + try finally (fun () -> xload () ) (fun () -> close_in inch) ; { outch = begin let flags = [Open_append;Open_binary;Open_creat] in - open_out_gen flags 0o666 f + open_out_gen flags 0o666 f end ; status = Open ; htbl = htbl } - with InvalidTableFormat -> + with InvalidTableFormat -> (* Try to keep as many entries as possible *) begin let flags = [Open_wronly; Open_trunc;Open_binary;Open_creat] in let outch = open_out_gen flags 0o666 f in - Table.iter (fun k e -> Marshal.to_channel outch (k,e) [Marshal.No_sharing]) htbl; + Table.iter (fun k e -> Marshal.to_channel outch (k,e) [Marshal.No_sharing]) htbl; { outch = outch ; - status = Open ; + status = Open ; htbl = htbl } end -let close t = +let close t = let {outch = outch ; status = status ; htbl = tbl} = t in match t.status with | Closed -> () (* don't do it twice *) - | Open -> - close_out outch ; + | Open -> + close_out outch ; Table.clear tbl ; t.status <- Closed -let add t k e = +let add t k e = let {outch = outch ; status = status ; htbl = tbl} = t in if status = Closed then raise UnboundTable else begin - Table.add tbl k e ; + Table.add tbl k e ; Marshal.to_channel outch (k,e) [Marshal.No_sharing] end -let find t k = +let find t k = let {outch = outch ; status = status ; htbl = tbl} = t in if status = Closed then raise UnboundTable else let res = Table.find tbl k in - res + res -let memo cache f = +let memo cache f = let tbl = lazy (open_in cache) in - fun x -> + fun x -> let tbl = Lazy.force tbl in - try + try find tbl x with - Not_found -> + Not_found -> let res = f x in add tbl x res ; res diff --git a/plugins/micromega/sos.ml b/plugins/micromega/sos.ml index 87e55c9e17..2512dee92d 100644 --- a/plugins/micromega/sos.ml +++ b/plugins/micromega/sos.ml @@ -318,16 +318,16 @@ 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) -> +| Add (t1, t2) -> "(" ^ (string_of_term t1) ^ " + " ^ (string_of_term t2) ^ ")" -| Sub (t1, t2) -> +| Sub (t1, t2) -> "(" ^ (string_of_term t1) ^ " - " ^ (string_of_term t2) ^ ")" -| Mul (t1, t2) -> +| Mul (t1, t2) -> "(" ^ (string_of_term t1) ^ " * " ^ (string_of_term t2) ^ ")" | Inv t1 -> "(/ " ^ string_of_term t1 ^ ")" -| Div (t1, t2) -> +| Div (t1, t2) -> "(" ^ (string_of_term t1) ^ " / " ^ (string_of_term t2) ^ ")" -| Pow (t1, n1) -> +| Pow (t1, n1) -> "(" ^ (string_of_term t1) ^ " ^ " ^ (string_of_int n1) ^ ")" | Zero -> "0" | Var v -> "x" ^ (string_of_vname v) @@ -384,11 +384,11 @@ let print_poly m = Format.print_string(string_of_poly m);; (* ------------------------------------------------------------------------- *) let rec poly_of_term t = match t with - Zero -> poly_0 + Zero -> poly_0 | Const n -> poly_const n | Var x -> poly_var x | Opp t1 -> poly_neg (poly_of_term t1) -| Inv 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" diff --git a/plugins/micromega/sos.mli b/plugins/micromega/sos.mli index 42e22ffec2..e38caba06c 100644 --- a/plugins/micromega/sos.mli +++ b/plugins/micromega/sos.mli @@ -24,7 +24,7 @@ val poly_of_term : term -> poly val term_of_poly : poly -> term -val term_of_sos : positivstellensatz * (Num.num * poly) list -> +val term_of_sos : positivstellensatz * (Num.num * poly) list -> positivstellensatz val string_of_poly : poly -> string diff --git a/plugins/micromega/sos_lib.ml b/plugins/micromega/sos_lib.ml index a9228365ec..baf90d4daa 100644 --- a/plugins/micromega/sos_lib.ml +++ b/plugins/micromega/sos_lib.ml @@ -606,16 +606,16 @@ let rec deepen f n = exception TooDeep -let deepen_until limit f n = +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 "; + try(* if !debugging + then (print_string "Searching with depth limit "; print_int n; print_newline()) ;*) f n - with Failure x -> + 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 diff --git a/plugins/omega/OmegaLemmas.v b/plugins/omega/OmegaLemmas.v index fe8fcc9249..56a854d6f8 100644 --- a/plugins/omega/OmegaLemmas.v +++ b/plugins/omega/OmegaLemmas.v @@ -31,7 +31,7 @@ Qed. Theorem Zred_factor3 : forall n m:Z, n * m + n = n * (1 + m). Proof. intros x y; pattern x at 2 in |- *; rewrite <- (Zmult_1_r x); - rewrite <- Zmult_plus_distr_r; rewrite Zplus_comm; + rewrite <- Zmult_plus_distr_r; rewrite Zplus_comm; trivial with arith. Qed. @@ -53,7 +53,7 @@ Qed. (** Other specific variants of theorems dedicated for the Omega tactic *) Lemma new_var : forall x : Z, exists y : Z, x = y. -intros x; exists x; trivial with arith. +intros x; exists x; trivial with arith. Qed. Lemma OMEGA1 : forall x y : Z, x = y -> 0 <= x -> 0 <= y. @@ -62,7 +62,7 @@ Qed. Lemma OMEGA2 : forall x y : Z, 0 <= x -> 0 <= y -> 0 <= x + y. exact Zplus_le_0_compat. -Qed. +Qed. Lemma OMEGA3 : forall x y k : Z, k > 0 -> x = y * k -> x = 0 -> y = 0. @@ -82,11 +82,11 @@ unfold not in |- *; intros x y z H1 H2 H3; cut (y > 0); [ rewrite H3; unfold Zgt in |- *; simpl in |- *; discriminate | apply Zle_gt_trans with x; [ pattern x at 1 in |- *; rewrite <- (Zplus_0_l x); - apply Zplus_le_compat_r; rewrite Zmult_comm; + apply Zplus_le_compat_r; rewrite Zmult_comm; generalize H4; unfold Zgt in |- *; case y; [ simpl in |- *; intros H7; discriminate H7 | intros p H7; rewrite <- (Zmult_0_r (Zpos p)); - unfold Zle in |- *; rewrite Zcompare_mult_compat; + unfold Zle in |- *; rewrite Zcompare_mult_compat; exact H6 | simpl in |- *; intros p H7; discriminate H7 ] | assumption ] ] @@ -116,7 +116,7 @@ Lemma OMEGA8 : forall x y : Z, 0 <= x -> 0 <= y -> x = - y -> x = 0. intros x y H1 H2 H3; elim (Zle_lt_or_eq 0 x H1); [ intros H4; absurd (0 < x); [ change (0 >= x) in |- *; apply Zle_ge; apply Zplus_le_reg_l with y; - rewrite H3; rewrite Zplus_opp_r; rewrite Zplus_0_r; + rewrite H3; rewrite Zplus_opp_r; rewrite Zplus_0_r; assumption | assumption ] | intros H4; rewrite H4; trivial with arith ]. @@ -143,7 +143,7 @@ Lemma OMEGA11 : (v1 * c1 + l1) * k1 + l2 = v1 * (c1 * k1) + (l1 * k1 + l2). intros; repeat rewrite Zmult_plus_distr_l || rewrite Zmult_plus_distr_r; - repeat rewrite Zmult_assoc; repeat elim Zplus_assoc; + repeat rewrite Zmult_assoc; repeat elim Zplus_assoc; trivial with arith. Qed. @@ -152,7 +152,7 @@ Lemma OMEGA12 : l1 + (v2 * c2 + l2) * k2 = v2 * (c2 * k2) + (l1 + l2 * k2). intros; repeat rewrite Zmult_plus_distr_l || rewrite Zmult_plus_distr_r; - repeat rewrite Zmult_assoc; repeat elim Zplus_assoc; + repeat rewrite Zmult_assoc; repeat elim Zplus_assoc; rewrite Zplus_permute; trivial with arith. Qed. @@ -166,7 +166,7 @@ intros; rewrite Zplus_assoc; rewrite (Zplus_comm (v * Zpos x) l1); rewrite Zplus_opp_r; rewrite Zmult_0_r; rewrite Zplus_0_r; trivial with arith. Qed. - + Lemma OMEGA14 : forall (v l1 l2 : Z) (x : positive), v * Zneg x + l1 + (v * Zpos x + l2) = l1 + l2. @@ -188,14 +188,14 @@ Qed. Lemma OMEGA16 : forall v c l k : Z, (v * c + l) * k = v * (c * k) + l * k. intros; repeat rewrite Zmult_plus_distr_l || rewrite Zmult_plus_distr_r; - repeat rewrite Zmult_assoc; repeat elim Zplus_assoc; + repeat rewrite Zmult_assoc; repeat elim Zplus_assoc; trivial with arith. Qed. Lemma OMEGA17 : forall x y z : Z, Zne x 0 -> y = 0 -> Zne (x + y * z) 0. unfold Zne, not in |- *; intros x y z H1 H2 H3; apply H1; - apply Zplus_reg_l with (y * z); rewrite Zplus_comm; + apply Zplus_reg_l with (y * z); rewrite Zplus_comm; rewrite H3; rewrite H2; auto with arith. Qed. @@ -213,7 +213,7 @@ unfold Zne in |- *; intros x H; elim (Zle_or_lt 0 x); rewrite <- Zsucc_pred; apply Zlt_le_succ; assumption | intros H2; absurd (x = 0); auto with arith ] | intros H1; right; rewrite <- Zopp_eq_mult_neg_1; rewrite Zplus_comm; - apply Zle_left; apply Zsucc_le_reg; simpl in |- *; + apply Zle_left; apply Zsucc_le_reg; simpl in |- *; apply Zlt_le_succ; auto with arith ]. Qed. @@ -229,7 +229,7 @@ Definition fast_Zplus_comm (x y : Z) (P : Z -> Prop) Definition fast_Zplus_assoc_reverse (n m p : Z) (P : Z -> Prop) (H : P (n + (m + p))) := eq_ind_r P H (Zplus_assoc_reverse n m p). -Definition fast_Zplus_assoc (n m p : Z) (P : Z -> Prop) +Definition fast_Zplus_assoc (n m p : Z) (P : Z -> Prop) (H : P (n + m + p)) := eq_ind_r P H (Zplus_assoc n m p). Definition fast_Zplus_permute (n m p : Z) (P : Z -> Prop) @@ -257,7 +257,7 @@ Definition fast_OMEGA13 (v l1 l2 : Z) (x : positive) (P : Z -> Prop) Definition fast_OMEGA14 (v l1 l2 : Z) (x : positive) (P : Z -> Prop) (H : P (l1 + l2)) := eq_ind_r P H (OMEGA14 v l1 l2 x). -Definition fast_Zred_factor0 (x : Z) (P : Z -> Prop) +Definition fast_Zred_factor0 (x : Z) (P : Z -> Prop) (H : P (x * 1)) := eq_ind_r P H (Zred_factor0 x). Definition fast_Zopp_eq_mult_neg_1 (x : Z) (P : Z -> Prop) @@ -272,18 +272,18 @@ Definition fast_Zopp_plus_distr (x y : Z) (P : Z -> Prop) Definition fast_Zopp_involutive (x : Z) (P : Z -> Prop) (H : P x) := eq_ind_r P H (Zopp_involutive x). -Definition fast_Zopp_mult_distr_r (x y : Z) (P : Z -> Prop) +Definition fast_Zopp_mult_distr_r (x y : Z) (P : Z -> Prop) (H : P (x * - y)) := eq_ind_r P H (Zopp_mult_distr_r x y). Definition fast_Zmult_plus_distr_l (n m p : Z) (P : Z -> Prop) (H : P (n * p + m * p)) := eq_ind_r P H (Zmult_plus_distr_l n m p). -Definition fast_Zmult_opp_comm (x y : Z) (P : Z -> Prop) +Definition fast_Zmult_opp_comm (x y : Z) (P : Z -> Prop) (H : P (x * - y)) := eq_ind_r P H (Zmult_opp_comm x y). Definition fast_Zmult_assoc_reverse (n m p : Z) (P : Z -> Prop) (H : P (n * (m * p))) := eq_ind_r P H (Zmult_assoc_reverse n m p). -Definition fast_Zred_factor1 (x : Z) (P : Z -> Prop) +Definition fast_Zred_factor1 (x : Z) (P : Z -> Prop) (H : P (x * 2)) := eq_ind_r P H (Zred_factor1 x). Definition fast_Zred_factor2 (x y : Z) (P : Z -> Prop) @@ -295,8 +295,8 @@ Definition fast_Zred_factor3 (x y : Z) (P : Z -> Prop) Definition fast_Zred_factor4 (x y z : Z) (P : Z -> Prop) (H : P (x * (y + z))) := eq_ind_r P H (Zred_factor4 x y z). -Definition fast_Zred_factor5 (x y : Z) (P : Z -> Prop) +Definition fast_Zred_factor5 (x y : Z) (P : Z -> Prop) (H : P y) := eq_ind_r P H (Zred_factor5 x y). -Definition fast_Zred_factor6 (x : Z) (P : Z -> Prop) +Definition fast_Zred_factor6 (x : Z) (P : Z -> Prop) (H : P (x + 0)) := eq_ind_r P H (Zred_factor6 x). diff --git a/plugins/omega/PreOmega.v b/plugins/omega/PreOmega.v index 47e22a97f3..a5a085a99e 100644 --- a/plugins/omega/PreOmega.v +++ b/plugins/omega/PreOmega.v @@ -5,16 +5,16 @@ 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 +(* 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: + + 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 @@ -26,31 +26,31 @@ Open Local Scope Z_scope. (** I) translation of Zmax, Zmin, Zabs, Zsgn into recognized equations *) -Ltac zify_unop_core t thm a := +Ltac zify_unop_core t thm a := (* Let's introduce the specification theorem for t *) - let H:= fresh "H" in assert (H:=thm a); + 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 := +Ltac zify_unop_var_or_term t thm a := (* If a is a variable, no need for aliasing *) - let za := fresh "z" in + 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 := +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 + 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 := +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 + let isz := isZcst a in + match isz with | true => zify_unop_core t thm a | _ => zify_unop_var_or_term t thm a end. @@ -58,20 +58,20 @@ Ltac zify_unop_nored t thm a := 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 + let isza := isZcst a in + match isza with | true => zify_unop (t a) (thm a) b - | _ => - let za := fresh "z" in + | _ => + 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 + (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 +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 @@ -93,13 +93,13 @@ Ltac zify_op := repeat zify_op_1. 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; +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 +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) @@ -127,8 +127,8 @@ Ltac zify_nat_rel := | |- context [ ge ?a ?b ] => rewrite (inj_ge_iff a b) end. -Ltac zify_nat_op := - match goal with +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) @@ -158,11 +158,11 @@ Ltac zify_nat_op := | |- 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 + | 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 + | |- 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 *) @@ -170,29 +170,29 @@ Ltac zify_nat_op := | |- 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 + | 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 + | |- 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 + (* 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 + | |- 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 @@ -205,18 +205,18 @@ Ltac zify_nat := repeat zify_nat_rel; repeat zify_nat_op; unfold Z_of_nat' in *. -(* III) conversion from positive to Z *) +(* 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; +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 +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) @@ -236,18 +236,18 @@ Ltac zify_positive_rel := | |- context [ (?a>=?b)%positive ] => change (a>=b)%positive with (Zpos a>=Zpos b) end. -Ltac zify_positive_op := - match goal with +Ltac zify_positive_op := + match goal with (* Zneg -> -Zpos (except for numbers) *) - | H : context [ Zneg ?a ] |- _ => - let isp := isPcst a in - match isp with + | 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 + | |- 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 @@ -272,45 +272,45 @@ Ltac zify_positive_op := | 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 *) + (* 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 + | 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 + | |- 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 + | 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 + | |- 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 + (* 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 + | |- 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 @@ -320,38 +320,38 @@ Ltac zify_positive_op := | |- 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 : 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 + | |- 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 := +Ltac zify_positive := repeat zify_positive_rel; repeat zify_positive_op; unfold Zpos',Zneg' in *. -(* IV) conversion from N to Z *) +(* 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; +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 +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) @@ -378,9 +378,9 @@ Ltac zify_N_rel := | 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 + +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) @@ -407,27 +407,27 @@ Ltac zify_N_op := | 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 *) + (* 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 + | 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 + | |- 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 + (* 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 + | |- 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 @@ -440,6 +440,6 @@ Ltac zify_N := repeat zify_N_rel; repeat zify_N_op; unfold Z_of_N' in *. (** The complete Z-ification tactic *) -Ltac zify := +Ltac zify := repeat progress (zify_nat; zify_positive; zify_N); zify_op. diff --git a/plugins/omega/coq_omega.ml b/plugins/omega/coq_omega.ml index 075188f54d..e037ee8bff 100644 --- a/plugins/omega/coq_omega.ml +++ b/plugins/omega/coq_omega.ml @@ -58,7 +58,7 @@ let write f x = f:=x open Goptions let _ = - declare_bool_option + declare_bool_option { optsync = false; optname = "Omega system time displaying flag"; optkey = ["Omega";"System"]; @@ -66,7 +66,7 @@ let _ = optwrite = write display_system_flag } let _ = - declare_bool_option + declare_bool_option { optsync = false; optname = "Omega action display flag"; optkey = ["Omega";"Action"]; @@ -74,7 +74,7 @@ let _ = optwrite = write display_action_flag } let _ = - declare_bool_option + declare_bool_option { optsync = false; optname = "Omega old style flag"; optkey = ["Omega";"OldStyle"]; @@ -89,16 +89,16 @@ let elim_time = timing "Elim " let simpl_time = timing "Simpl " let generalize_time = timing "Generalize" -let new_identifier = - let cpt = ref 0 in +let new_identifier = + let cpt = ref 0 in (fun () -> let s = "Omega" ^ string_of_int !cpt in incr cpt; id_of_string s) -let new_identifier_state = - let cpt = ref 0 in +let new_identifier_state = + let cpt = ref 0 in (fun () -> let s = make_ident "State" (Some !cpt) in incr cpt; s) -let new_identifier_var = - let cpt = ref 0 in +let new_identifier_var = + let cpt = ref 0 in (fun () -> let s = "Zvar" ^ string_of_int !cpt in incr cpt; id_of_string s) let new_id = @@ -115,17 +115,17 @@ let display_var i = Printf.sprintf "X%d" i let intern_id,unintern_id = let cpt = ref 0 in let table = Hashtbl.create 7 and co_table = Hashtbl.create 7 in - (fun (name : identifier) -> - try Hashtbl.find table name with Not_found -> + (fun (name : identifier) -> + try Hashtbl.find table name with Not_found -> let idx = !cpt in - Hashtbl.add table name idx; + Hashtbl.add table name idx; Hashtbl.add co_table idx name; incr cpt; idx), - (fun idx -> - try Hashtbl.find co_table idx with Not_found -> + (fun idx -> + try Hashtbl.find co_table idx with Not_found -> let v = new_var () in Hashtbl.add table v idx; Hashtbl.add co_table idx v; v) - + let mk_then = tclTHENLIST let exists_tac c = constructor_tac false (Some 1) 1 (Rawterm.ImplicitBindings [c]) @@ -134,10 +134,10 @@ 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 [all_occurrences, Lazy.force s] - + let rev_assoc k = let rec loop = function - | [] -> raise Not_found | (v,k')::_ when k = k' -> v | _ :: l -> loop l + | [] -> raise Not_found | (v,k')::_ when k = k' -> v | _ :: l -> loop l in loop @@ -347,15 +347,15 @@ let mk_eq_rel t1 t2 = mkApp (build_coq_eq (), let mk_inj t = mkApp (Lazy.force coq_Z_of_nat, [| t |]) let mk_integer n = - let rec loop n = - if n =? one then Lazy.force coq_xH else + let rec loop n = + if n =? one then Lazy.force coq_xH else mkApp((if n mod two =? zero then Lazy.force coq_xO else Lazy.force coq_xI), [| loop (n/two) |]) in - if n =? zero then Lazy.force coq_Z0 + if n =? zero then Lazy.force coq_Z0 else mkApp ((if n >? zero then Lazy.force coq_Zpos else Lazy.force coq_Zneg), [| loop (abs n) |]) - + type omega_constant = | Zplus | Zmult | Zminus | Zsucc | Zopp | Plus | Mult | Minus | Pred | S | O @@ -371,7 +371,7 @@ type omega_proposition = | Keq of constr * constr * constr | Kn -type result = +type result = | Kvar of identifier | Kapp of omega_constant * constr list | Kimp of constr * constr @@ -442,18 +442,18 @@ let recognize_number t = | f, [t] when f = Lazy.force coq_xI -> one + two * loop t | f, [t] when f = Lazy.force coq_xO -> two * loop t | f, [] when f = Lazy.force coq_xH -> one - | _ -> failwith "not a number" + | _ -> failwith "not a number" in - match decompose_app t with + match decompose_app t with | f, [t] when f = Lazy.force coq_Zpos -> loop t | f, [t] when f = Lazy.force coq_Zneg -> neg (loop t) | f, [] when f = Lazy.force coq_Z0 -> zero | _ -> failwith "not a number" - + type constr_path = | P_APP of int (* Abstraction and product *) - | P_BODY + | P_BODY | P_TYPE (* Case *) | P_BRANCH of int @@ -461,8 +461,8 @@ type constr_path = | P_ARG let context operation path (t : constr) = - let rec loop i p0 t = - match (p0,kind_of_term t) with + let rec loop i p0 t = + match (p0,kind_of_term t) with | (p, Cast (c,k,t)) -> mkCast (loop i p c,k,t) | ([], _) -> operation i t | ((P_APP n :: p), App (f,v)) -> @@ -493,9 +493,9 @@ let context operation path (t : constr) = (mkLambda (n,loop i p t,c)) | ((P_TYPE :: p), LetIn (n,b,t,c)) -> (mkLetIn (n,b,loop i p t,c)) - | (p, _) -> + | (p, _) -> ppnl (Printer.pr_lconstr t); - failwith ("abstract_path " ^ string_of_int(List.length p)) + failwith ("abstract_path " ^ string_of_int(List.length p)) in loop 1 path t @@ -514,9 +514,9 @@ let occurence path (t : constr) = | ((P_TYPE :: p), Prod (n,term,c)) -> loop p term | ((P_TYPE :: p), Lambda (n,term,c)) -> loop p term | ((P_TYPE :: p), LetIn (n,b,term,c)) -> loop p term - | (p, _) -> + | (p, _) -> ppnl (Printer.pr_lconstr t); - failwith ("occurence " ^ string_of_int(List.length p)) + failwith ("occurence " ^ string_of_int(List.length p)) in loop path t @@ -539,13 +539,13 @@ type oformula = | Oz of bigint | Oufo of constr -let rec oprint = function - | Oplus(t1,t2) -> - print_string "("; oprint t1; print_string "+"; +let rec oprint = function + | Oplus(t1,t2) -> + print_string "("; oprint t1; print_string "+"; oprint t2; print_string ")" | Oinv t -> print_string "~"; oprint t - | Otimes (t1,t2) -> - print_string "("; oprint t1; print_string "*"; + | Otimes (t1,t2) -> + print_string "("; oprint t1; print_string "*"; oprint t2; print_string ")" | Oatom s -> print_string (string_of_id s) | Oz i -> print_string (string_of_bigint i) @@ -567,92 +567,92 @@ let rec val_of = function | Oplus(t1,t2) -> mkApp (Lazy.force coq_Zplus, [| val_of t1; val_of t2 |]) | Oufo c -> c -let compile name kind = +let compile name kind = let rec loop accu = function | Oplus(Otimes(Oatom v,Oz n),r) -> loop ({v=intern_id v; c=n} :: accu) r | Oz n -> let id = new_id () in tag_hypothesis name id; {kind = kind; body = List.rev accu; constant = n; id = id} - | _ -> anomaly "compile_equation" + | _ -> anomaly "compile_equation" in loop [] -let rec decompile af = +let rec decompile af = let rec loop = function - | ({v=v; c=n}::r) -> Oplus(Otimes(Oatom (unintern_id v),Oz n),loop r) - | [] -> Oz af.constant + | ({v=v; c=n}::r) -> Oplus(Otimes(Oatom (unintern_id v),Oz n),loop r) + | [] -> Oz af.constant in loop af.body let mkNewMeta () = mkMeta (Evarutil.new_meta()) -let clever_rewrite_base_poly typ p result theorem gl = +let clever_rewrite_base_poly typ p result theorem gl = let full = pf_concl gl in let (abstracted,occ) = abstract_path typ (List.rev p) full in - let t = + let t = applist (mkLambda - (Name (id_of_string "P"), + (Name (id_of_string "P"), mkArrow typ mkProp, mkLambda (Name (id_of_string "H"), applist (mkRel 1,[result]), - mkApp (Lazy.force coq_eq_ind_r, + mkApp (Lazy.force coq_eq_ind_r, [| typ; result; mkRel 2; mkRel 1; occ; theorem |]))), - [abstracted]) + [abstracted]) in exact (applist(t,[mkNewMeta()])) gl -let clever_rewrite_base p result theorem gl = +let clever_rewrite_base p result theorem gl = clever_rewrite_base_poly (Lazy.force coq_Z) p result theorem gl -let clever_rewrite_base_nat p result theorem gl = +let clever_rewrite_base_nat p result theorem gl = clever_rewrite_base_poly (Lazy.force coq_nat) p result theorem gl -let clever_rewrite_gen p result (t,args) = - let theorem = applist(t, args) in +let clever_rewrite_gen p result (t,args) = + let theorem = applist(t, args) in clever_rewrite_base p result theorem -let clever_rewrite_gen_nat p result (t,args) = - let theorem = applist(t, args) in +let clever_rewrite_gen_nat p result (t,args) = + let theorem = applist(t, args) in clever_rewrite_base_nat p result theorem -let clever_rewrite p vpath t gl = +let clever_rewrite p vpath t gl = let full = pf_concl gl in let (abstracted,occ) = abstract_path (Lazy.force coq_Z) (List.rev p) full in let vargs = List.map (fun p -> occurence p occ) vpath in let t' = applist(t, (vargs @ [abstracted])) in exact (applist(t',[mkNewMeta()])) gl -let rec shuffle p (t1,t2) = +let rec shuffle p (t1,t2) = match t1,t2 with | Oplus(l1,r1), Oplus(l2,r2) -> - if weight l1 > weight l2 then + if weight l1 > weight l2 then let (tac,t') = shuffle (P_APP 2 :: p) (r1,t2) in - (clever_rewrite p [[P_APP 1;P_APP 1]; + (clever_rewrite p [[P_APP 1;P_APP 1]; [P_APP 1; P_APP 2];[P_APP 2]] (Lazy.force coq_fast_Zplus_assoc_reverse) :: tac, Oplus(l1,t')) - else + else let (tac,t') = shuffle (P_APP 2 :: p) (t1,r2) in (clever_rewrite p [[P_APP 1];[P_APP 2;P_APP 1];[P_APP 2;P_APP 2]] (Lazy.force coq_fast_Zplus_permute) :: tac, Oplus(l2,t')) - | Oplus(l1,r1), t2 -> + | Oplus(l1,r1), t2 -> if weight l1 > weight t2 then let (tac,t') = shuffle (P_APP 2 :: p) (r1,t2) in clever_rewrite p [[P_APP 1;P_APP 1]; [P_APP 1; P_APP 2];[P_APP 2]] (Lazy.force coq_fast_Zplus_assoc_reverse) - :: tac, + :: tac, Oplus(l1, t') - else - [clever_rewrite p [[P_APP 1];[P_APP 2]] + else + [clever_rewrite p [[P_APP 1];[P_APP 2]] (Lazy.force coq_fast_Zplus_comm)], Oplus(t2,t1) - | t1,Oplus(l2,r2) -> + | t1,Oplus(l2,r2) -> if weight l2 > weight t1 then let (tac,t') = shuffle (P_APP 2 :: p) (t1,r2) in clever_rewrite p [[P_APP 1];[P_APP 2;P_APP 1];[P_APP 2;P_APP 2]] @@ -664,11 +664,11 @@ let rec shuffle p (t1,t2) = [focused_simpl p], Oz(Bigint.add t1 t2) | t1,t2 -> if weight t1 < weight t2 then - [clever_rewrite p [[P_APP 1];[P_APP 2]] + [clever_rewrite p [[P_APP 1];[P_APP 2]] (Lazy.force coq_fast_Zplus_comm)], Oplus(t2,t1) else [],Oplus(t1,t2) - + let rec shuffle_mult p_init k1 e1 k2 e2 = let rec loop p = function | (({c=c1;v=v1}::l1) as l1'),(({c=c2;v=v2}::l2) as l2') -> @@ -681,13 +681,13 @@ let rec shuffle_mult p_init k1 e1 k2 e2 = [P_APP 2; P_APP 1; P_APP 2]; [P_APP 1; P_APP 2]; [P_APP 2; P_APP 2]] - (Lazy.force coq_fast_OMEGA10) + (Lazy.force coq_fast_OMEGA10) in - if Bigint.add (Bigint.mult k1 c1) (Bigint.mult k2 c2) =? zero then - let tac' = + if Bigint.add (Bigint.mult k1 c1) (Bigint.mult k2 c2) =? zero then + let tac' = clever_rewrite p [[P_APP 1;P_APP 1];[P_APP 2]] (Lazy.force coq_fast_Zred_factor5) in - tac :: focused_simpl (P_APP 1::P_APP 2:: p) :: tac' :: + tac :: focused_simpl (P_APP 1::P_APP 2:: p) :: tac' :: loop p (l1,l2) else tac :: loop (P_APP 2 :: p) (l1,l2) else if v1 > v2 then @@ -706,7 +706,7 @@ let rec shuffle_mult p_init k1 e1 k2 e2 = [P_APP 2; P_APP 2]] (Lazy.force coq_fast_OMEGA12) :: loop (P_APP 2 :: p) (l1',l2) - | ({c=c1;v=v1}::l1), [] -> + | ({c=c1;v=v1}::l1), [] -> clever_rewrite p [[P_APP 1; P_APP 1; P_APP 1; P_APP 1]; [P_APP 1; P_APP 1; P_APP 1; P_APP 2]; [P_APP 1; P_APP 1; P_APP 2]; @@ -714,7 +714,7 @@ let rec shuffle_mult p_init k1 e1 k2 e2 = [P_APP 1; P_APP 2]] (Lazy.force coq_fast_OMEGA11) :: loop (P_APP 2 :: p) (l1,[]) - | [],({c=c2;v=v2}::l2) -> + | [],({c=c2;v=v2}::l2) -> clever_rewrite p [[P_APP 2; P_APP 1; P_APP 1; P_APP 1]; [P_APP 2; P_APP 1; P_APP 1; P_APP 2]; [P_APP 1]; @@ -722,10 +722,10 @@ let rec shuffle_mult p_init k1 e1 k2 e2 = [P_APP 2; P_APP 2]] (Lazy.force coq_fast_OMEGA12) :: loop (P_APP 2 :: p) ([],l2) - | [],[] -> [focused_simpl p_init] + | [],[] -> [focused_simpl p_init] in loop p_init (e1,e2) - + let rec shuffle_mult_right p_init e1 k2 e2 = let rec loop p = function | (({c=c1;v=v1}::l1) as l1'),(({c=c2;v=v2}::l2) as l2') -> @@ -738,14 +738,14 @@ let rec shuffle_mult_right p_init e1 k2 e2 = [P_APP 1; P_APP 2]; [P_APP 2; P_APP 1; P_APP 2]; [P_APP 2; P_APP 2]] - (Lazy.force coq_fast_OMEGA15) + (Lazy.force coq_fast_OMEGA15) in - if Bigint.add c1 (Bigint.mult k2 c2) =? zero then - let tac' = + if Bigint.add c1 (Bigint.mult k2 c2) =? zero then + let tac' = clever_rewrite p [[P_APP 1;P_APP 1];[P_APP 2]] - (Lazy.force coq_fast_Zred_factor5) + (Lazy.force coq_fast_Zred_factor5) in - tac :: focused_simpl (P_APP 1::P_APP 2:: p) :: tac' :: + tac :: focused_simpl (P_APP 1::P_APP 2:: p) :: tac' :: loop p (l1,l2) else tac :: loop (P_APP 2 :: p) (l1,l2) else if v1 > v2 then @@ -760,11 +760,11 @@ let rec shuffle_mult_right p_init e1 k2 e2 = [P_APP 2; P_APP 2]] (Lazy.force coq_fast_OMEGA12) :: loop (P_APP 2 :: p) (l1',l2) - | ({c=c1;v=v1}::l1), [] -> + | ({c=c1;v=v1}::l1), [] -> clever_rewrite p [[P_APP 1;P_APP 1]; [P_APP 1; P_APP 2];[P_APP 2]] (Lazy.force coq_fast_Zplus_assoc_reverse) :: loop (P_APP 2 :: p) (l1,[]) - | [],({c=c2;v=v2}::l2) -> + | [],({c=c2;v=v2}::l2) -> clever_rewrite p [[P_APP 2; P_APP 1; P_APP 1; P_APP 1]; [P_APP 2; P_APP 1; P_APP 1; P_APP 2]; [P_APP 1]; @@ -772,89 +772,89 @@ let rec shuffle_mult_right p_init e1 k2 e2 = [P_APP 2; P_APP 2]] (Lazy.force coq_fast_OMEGA12) :: loop (P_APP 2 :: p) ([],l2) - | [],[] -> [focused_simpl p_init] + | [],[] -> [focused_simpl p_init] in loop p_init (e1,e2) -let rec shuffle_cancel p = function +let rec shuffle_cancel p = function | [] -> [focused_simpl p] | ({c=c1}::l1) -> - let tac = + let tac = clever_rewrite p [[P_APP 1; P_APP 1; P_APP 1];[P_APP 1; P_APP 2]; - [P_APP 2; P_APP 2]; + [P_APP 2; P_APP 2]; [P_APP 1; P_APP 1; P_APP 2; P_APP 1]] - (if c1 >? zero then - (Lazy.force coq_fast_OMEGA13) - else - (Lazy.force coq_fast_OMEGA14)) + (if c1 >? zero then + (Lazy.force coq_fast_OMEGA13) + else + (Lazy.force coq_fast_OMEGA14)) in tac :: shuffle_cancel p l1 - + let rec scalar p n = function - | Oplus(t1,t2) -> - let tac1,t1' = scalar (P_APP 1 :: p) n t1 and + | Oplus(t1,t2) -> + let tac1,t1' = scalar (P_APP 1 :: p) n t1 and tac2,t2' = scalar (P_APP 2 :: p) n t2 in clever_rewrite p [[P_APP 1;P_APP 1];[P_APP 1;P_APP 2];[P_APP 2]] - (Lazy.force coq_fast_Zmult_plus_distr_l) :: + (Lazy.force coq_fast_Zmult_plus_distr_l) :: (tac1 @ tac2), Oplus(t1',t2') | Oinv t -> - [clever_rewrite p [[P_APP 1;P_APP 1];[P_APP 2]] + [clever_rewrite p [[P_APP 1;P_APP 1];[P_APP 2]] (Lazy.force coq_fast_Zmult_opp_comm); focused_simpl (P_APP 2 :: p)], Otimes(t,Oz(neg n)) - | Otimes(t1,Oz x) -> + | Otimes(t1,Oz x) -> [clever_rewrite p [[P_APP 1;P_APP 1];[P_APP 1;P_APP 2];[P_APP 2]] (Lazy.force coq_fast_Zmult_assoc_reverse); - focused_simpl (P_APP 2 :: p)], + focused_simpl (P_APP 2 :: p)], Otimes(t1,Oz (n*x)) | Otimes(t1,t2) -> error "Omega: Can't solve a goal with non-linear products" | (Oatom _ as t) -> [], Otimes(t,Oz n) | Oz i -> [focused_simpl p],Oz(n*i) | Oufo c -> [], Oufo (mkApp (Lazy.force coq_Zmult, [| mk_integer n; c |])) - -let rec scalar_norm p_init = + +let rec scalar_norm p_init = let rec loop p = function | [] -> [focused_simpl p_init] - | (_::l) -> + | (_::l) -> clever_rewrite p [[P_APP 1; P_APP 1; P_APP 1];[P_APP 1; P_APP 1; P_APP 2]; [P_APP 1; P_APP 2];[P_APP 2]] - (Lazy.force coq_fast_OMEGA16) :: loop (P_APP 2 :: p) l + (Lazy.force coq_fast_OMEGA16) :: loop (P_APP 2 :: p) l in loop p_init let rec norm_add p_init = let rec loop p = function | [] -> [focused_simpl p_init] - | _:: l -> + | _:: l -> clever_rewrite p [[P_APP 1;P_APP 1]; [P_APP 1; P_APP 2];[P_APP 2]] (Lazy.force coq_fast_Zplus_assoc_reverse) :: - loop (P_APP 2 :: p) l + loop (P_APP 2 :: p) l in loop p_init let rec scalar_norm_add p_init = let rec loop p = function | [] -> [focused_simpl p_init] - | _ :: l -> + | _ :: l -> clever_rewrite p [[P_APP 1; P_APP 1; P_APP 1; P_APP 1]; [P_APP 1; P_APP 1; P_APP 1; P_APP 2]; [P_APP 1; P_APP 1; P_APP 2]; [P_APP 2]; [P_APP 1; P_APP 2]] - (Lazy.force coq_fast_OMEGA11) :: loop (P_APP 2 :: p) l + (Lazy.force coq_fast_OMEGA11) :: loop (P_APP 2 :: p) l in loop p_init let rec negate p = function - | Oplus(t1,t2) -> - let tac1,t1' = negate (P_APP 1 :: p) t1 and + | Oplus(t1,t2) -> + let tac1,t1' = negate (P_APP 1 :: p) t1 and tac2,t2' = negate (P_APP 2 :: p) t2 in clever_rewrite p [[P_APP 1;P_APP 1];[P_APP 1;P_APP 2]] - (Lazy.force coq_fast_Zopp_plus_distr) :: + (Lazy.force coq_fast_Zopp_plus_distr) :: (tac1 @ tac2), Oplus(t1',t2') | Oinv t -> [clever_rewrite p [[P_APP 1;P_APP 1]] (Lazy.force coq_fast_Zopp_involutive)], t - | Otimes(t1,Oz x) -> + | Otimes(t1,Oz x) -> [clever_rewrite p [[P_APP 1;P_APP 1];[P_APP 1;P_APP 2]] (Lazy.force coq_fast_Zopp_mult_distr_r); focused_simpl (P_APP 2 :: p)], Otimes(t1,Oz (neg x)) @@ -864,13 +864,13 @@ let rec negate p = function [clever_rewrite p [[P_APP 1]] (Lazy.force coq_fast_Zopp_eq_mult_neg_1)], r | Oz i -> [focused_simpl p],Oz(neg i) | Oufo c -> [], Oufo (mkApp (Lazy.force coq_Zopp, [| c |])) - -let rec transform p t = + +let rec transform p t = let default isnat t' = - try + try let v,th,_ = find_constr t' in [clever_rewrite_base p (mkVar v) (mkVar th)], Oatom v - with _ -> + with _ -> let v = new_identifier_var () and th = new_identifier () in hide_constr t' v th isnat; @@ -878,12 +878,12 @@ let rec transform p t = in try match destructurate_term t with | Kapp(Zplus,[t1;t2]) -> - let tac1,t1' = transform (P_APP 1 :: p) t1 + let tac1,t1' = transform (P_APP 1 :: p) t1 and tac2,t2' = transform (P_APP 2 :: p) t2 in let tac,t' = shuffle p (t1',t2') in tac1 @ tac2 @ tac, t' | Kapp(Zminus,[t1;t2]) -> - let tac,t = + let tac,t = transform p (mkApp (Lazy.force coq_Zplus, [| t1; (mkApp (Lazy.force coq_Zopp, [| t2 |])) |])) in @@ -893,18 +893,18 @@ let rec transform p t = [| t1; mk_integer one |])) in unfold sp_Zsucc :: tac,t | Kapp(Zmult,[t1;t2]) -> - let tac1,t1' = transform (P_APP 1 :: p) t1 + let tac1,t1' = transform (P_APP 1 :: p) t1 and tac2,t2' = transform (P_APP 2 :: p) t2 in begin match t1',t2' with | (_,Oz n) -> let tac,t' = scalar p n t1' in tac1 @ tac2 @ tac,t' | (Oz n,_) -> - let sym = - clever_rewrite p [[P_APP 1];[P_APP 2]] + let sym = + clever_rewrite p [[P_APP 1];[P_APP 2]] (Lazy.force coq_fast_Zmult_comm) in let tac,t' = scalar p n t2' in tac1 @ tac2 @ (sym :: tac),t' | _ -> default false t end - | Kapp((Zpos|Zneg|Z0),_) -> + | Kapp((Zpos|Zneg|Z0),_) -> (try ([],Oz(recognize_number t)) with _ -> default false t) | Kvar s -> [],Oatom s | Kapp(Zopp,[t]) -> @@ -914,28 +914,28 @@ let rec transform p t = | Kapp(Z_of_nat,[t']) -> default true t' | _ -> default false t with e when catchable_exception e -> default false t - + let shrink_pair p f1 f2 = match f1,f2 with - | Oatom v,Oatom _ -> + | Oatom v,Oatom _ -> let r = Otimes(Oatom v,Oz two) in clever_rewrite p [[P_APP 1]] (Lazy.force coq_fast_Zred_factor1), r - | Oatom v, Otimes(_,c2) -> + | Oatom v, Otimes(_,c2) -> let r = Otimes(Oatom v,Oplus(c2,Oz one)) in - clever_rewrite p [[P_APP 1];[P_APP 2;P_APP 2]] + clever_rewrite p [[P_APP 1];[P_APP 2;P_APP 2]] (Lazy.force coq_fast_Zred_factor2), r - | Otimes (v1,c1),Oatom v -> + | Otimes (v1,c1),Oatom v -> let r = Otimes(Oatom v,Oplus(c1,Oz one)) in clever_rewrite p [[P_APP 2];[P_APP 1;P_APP 2]] (Lazy.force coq_fast_Zred_factor3), r | Otimes (Oatom v,c1),Otimes (v2,c2) -> let r = Otimes(Oatom v,Oplus(c1,c2)) in - clever_rewrite p + clever_rewrite p [[P_APP 1;P_APP 1];[P_APP 1;P_APP 2];[P_APP 2;P_APP 2]] (Lazy.force coq_fast_Zred_factor4),r - | t1,t2 -> - begin - oprint t1; print_newline (); oprint t2; print_newline (); + | t1,t2 -> + begin + oprint t1; print_newline (); oprint t2; print_newline (); flush Pervasives.stdout; error "shrink.1" end @@ -948,7 +948,7 @@ let reduce_factor p = function let rec compute = function | Oz n -> n | Oplus(t1,t2) -> Bigint.add (compute t1) (compute t2) - | _ -> error "condense.1" + | _ -> error "condense.1" in [focused_simpl (P_APP 2 :: p)], Otimes(Oatom v,Oz(compute c)) | t -> oprint t; error "reduce_factor.1" @@ -957,31 +957,31 @@ let rec condense p = function | Oplus(f1,(Oplus(f2,r) as t)) -> if weight f1 = weight f2 then begin let shrink_tac,t = shrink_pair (P_APP 1 :: p) f1 f2 in - let assoc_tac = - clever_rewrite p + let assoc_tac = + clever_rewrite p [[P_APP 1];[P_APP 2;P_APP 1];[P_APP 2;P_APP 2]] (Lazy.force coq_fast_Zplus_assoc) in let tac_list,t' = condense p (Oplus(t,r)) in (assoc_tac :: shrink_tac :: tac_list), t' end else begin let tac,f = reduce_factor (P_APP 1 :: p) f1 in - let tac',t' = condense (P_APP 2 :: p) t in - (tac @ tac'), Oplus(f,t') + let tac',t' = condense (P_APP 2 :: p) t in + (tac @ tac'), Oplus(f,t') end - | Oplus(f1,Oz n) -> + | Oplus(f1,Oz n) -> let tac,f1' = reduce_factor (P_APP 1 :: p) f1 in tac,Oplus(f1',Oz n) - | Oplus(f1,f2) -> + | Oplus(f1,f2) -> if weight f1 = weight f2 then begin let tac_shrink,t = shrink_pair p f1 f2 in let tac,t' = condense p t in tac_shrink :: tac,t' end else begin let tac,f = reduce_factor (P_APP 1 :: p) f1 in - let tac',t' = condense (P_APP 2 :: p) f2 in - (tac @ tac'),Oplus(f,t') + let tac',t' = condense (P_APP 2 :: p) f2 in + (tac @ tac'),Oplus(f,t') end | Oz _ as t -> [],t - | t -> + | t -> let tac,t' = reduce_factor p t in let final = Oplus(t',Oz zero) in let tac' = clever_rewrite p [[]] (Lazy.force coq_fast_Zred_factor6) in @@ -990,99 +990,99 @@ let rec condense p = function let rec clear_zero p = function | Oplus(Otimes(Oatom v,Oz n),r) when n =? zero -> let tac = - clever_rewrite p [[P_APP 1;P_APP 1];[P_APP 2]] + clever_rewrite p [[P_APP 1;P_APP 1];[P_APP 2]] (Lazy.force coq_fast_Zred_factor5) in let tac',t = clear_zero p r in tac :: tac',t - | Oplus(f,r) -> + | Oplus(f,r) -> let tac,t = clear_zero (P_APP 2 :: p) r in tac,Oplus(f,t) | t -> [],t -let replay_history tactic_normalisation = +let replay_history tactic_normalisation = let aux = id_of_string "auxiliary" in let aux1 = id_of_string "auxiliary_1" in let aux2 = id_of_string "auxiliary_2" in let izero = mk_integer zero in let rec loop t = match t with - | HYP e :: l -> - begin - try - tclTHEN - (List.assoc (hyp_of_tag e.id) tactic_normalisation) + | HYP e :: l -> + begin + try + tclTHEN + (List.assoc (hyp_of_tag e.id) tactic_normalisation) (loop l) with Not_found -> loop l end | NEGATE_CONTRADICT (e2,e1,b) :: l -> - let eq1 = decompile e1 - and eq2 = decompile e2 in - let id1 = hyp_of_tag e1.id + let eq1 = decompile e1 + and eq2 = decompile e2 in + let id1 = hyp_of_tag e1.id and id2 = hyp_of_tag e2.id in let k = if b then negone else one in let p_initial = [P_APP 1;P_TYPE] in let tac= shuffle_mult_right p_initial e1.body k e2.body in tclTHENLIST [ - (generalize_tac - [mkApp (Lazy.force coq_OMEGA17, [| + (generalize_tac + [mkApp (Lazy.force coq_OMEGA17, [| val_of eq1; val_of eq2; - mk_integer k; + mk_integer k; mkVar id1; mkVar id2 |])]); (mk_then tac); (intros_using [aux]); (resolve_id aux); reflexivity ] - | CONTRADICTION (e1,e2) :: l -> - let eq1 = decompile e1 - and eq2 = decompile e2 in + | CONTRADICTION (e1,e2) :: l -> + let eq1 = decompile e1 + and eq2 = decompile e2 in let p_initial = [P_APP 2;P_TYPE] in let tac = shuffle_cancel p_initial e1.body in let solve_le = - let not_sup_sup = mkApp (build_coq_eq (), [| - Lazy.force coq_comparison; + let not_sup_sup = mkApp (build_coq_eq (), [| + Lazy.force coq_comparison; Lazy.force coq_Gt; Lazy.force coq_Gt |]) in - tclTHENS + tclTHENS (tclTHENLIST [ (unfold sp_Zle); (simpl_in_concl); intro; (absurd not_sup_sup) ]) - [ assumption ; reflexivity ] + [ assumption ; reflexivity ] in let theorem = - mkApp (Lazy.force coq_OMEGA2, [| - val_of eq1; val_of eq2; + mkApp (Lazy.force coq_OMEGA2, [| + val_of eq1; val_of eq2; mkVar (hyp_of_tag e1.id); mkVar (hyp_of_tag e2.id) |]) in tclTHEN (tclTHEN (generalize_tac [theorem]) (mk_then tac)) (solve_le) | DIVIDE_AND_APPROX (e1,e2,k,d) :: l -> let id = hyp_of_tag e1.id in - let eq1 = val_of(decompile e1) + let eq1 = val_of(decompile e1) and eq2 = val_of(decompile e2) in - let kk = mk_integer k + let kk = mk_integer k and dd = mk_integer d in let rhs = mk_plus (mk_times eq2 kk) dd in let state_eg = mk_eq eq1 rhs in let tac = scalar_norm_add [P_APP 3] e2.body in - tclTHENS - (cut state_eg) + tclTHENS + (cut state_eg) [ tclTHENS (tclTHENLIST [ (intros_using [aux]); - (generalize_tac + (generalize_tac [mkApp (Lazy.force coq_OMEGA1, [| eq1; rhs; mkVar aux; mkVar id |])]); (clear [aux;id]); (intros_using [id]); (cut (mk_gt kk dd)) ]) - [ tclTHENS - (cut (mk_gt kk izero)) + [ tclTHENS + (cut (mk_gt kk izero)) [ tclTHENLIST [ (intros_using [aux1; aux2]); - (generalize_tac + (generalize_tac [mkApp (Lazy.force coq_Zmult_le_approx, [| kk;eq2;dd;mkVar aux1;mkVar aux2; mkVar id |])]); (clear [aux1;aux2;id]); @@ -1095,23 +1095,23 @@ let replay_history tactic_normalisation = tclTHENLIST [ (unfold sp_Zgt); simpl_in_concl; reflexivity ] ]; tclTHEN (mk_then tac) reflexivity ] - + | NOT_EXACT_DIVIDE (e1,k) :: l -> let c = floor_div e1.constant k in let d = Bigint.sub e1.constant (Bigint.mult c k) in - let e2 = {id=e1.id; kind=EQUA;constant = c; + let e2 = {id=e1.id; kind=EQUA;constant = c; body = map_eq_linear (fun c -> c / k) e1.body } in let eq2 = val_of(decompile e2) in - let kk = mk_integer k + let kk = mk_integer k and dd = mk_integer d in let tac = scalar_norm_add [P_APP 2] e2.body in - tclTHENS - (cut (mk_gt dd izero)) - [ tclTHENS (cut (mk_gt kk dd)) + tclTHENS + (cut (mk_gt dd izero)) + [ tclTHENS (cut (mk_gt kk dd)) [tclTHENLIST [ (intros_using [aux2;aux1]); - (generalize_tac - [mkApp (Lazy.force coq_OMEGA4, + (generalize_tac + [mkApp (Lazy.force coq_OMEGA4, [| dd;kk;eq2;mkVar aux1; mkVar aux2 |])]); (clear [aux1;aux2]); (unfold sp_not); @@ -1121,7 +1121,7 @@ let replay_history tactic_normalisation = assumption ] ; tclTHENLIST [ (unfold sp_Zgt); - simpl_in_concl; + simpl_in_concl; reflexivity ] ]; tclTHENLIST [ (unfold sp_Zgt); @@ -1130,18 +1130,18 @@ let replay_history tactic_normalisation = | EXACT_DIVIDE (e1,k) :: l -> let id = hyp_of_tag e1.id in let e2 = map_eq_afine (fun c -> c / k) e1 in - let eq1 = val_of(decompile e1) + let eq1 = val_of(decompile e1) and eq2 = val_of(decompile e2) in let kk = mk_integer k in let state_eq = mk_eq eq1 (mk_times eq2 kk) in if e1.kind = DISE then let tac = scalar_norm [P_APP 3] e2.body in - tclTHENS - (cut state_eq) + tclTHENS + (cut state_eq) [tclTHENLIST [ (intros_using [aux1]); - (generalize_tac - [mkApp (Lazy.force coq_OMEGA18, + (generalize_tac + [mkApp (Lazy.force coq_OMEGA18, [| eq1;eq2;kk;mkVar aux1; mkVar id |])]); (clear [aux1;id]); (intros_using [id]); @@ -1149,14 +1149,14 @@ let replay_history tactic_normalisation = tclTHEN (mk_then tac) reflexivity ] else let tac = scalar_norm [P_APP 3] e2.body in - tclTHENS (cut state_eq) + tclTHENS (cut state_eq) [ - tclTHENS - (cut (mk_gt kk izero)) + tclTHENS + (cut (mk_gt kk izero)) [tclTHENLIST [ (intros_using [aux2;aux1]); - (generalize_tac - [mkApp (Lazy.force coq_OMEGA3, + (generalize_tac + [mkApp (Lazy.force coq_OMEGA3, [| eq1; eq2; kk; mkVar aux2; mkVar aux1;mkVar id|])]); (clear [aux1;aux2;id]); (intros_using [id]); @@ -1169,35 +1169,35 @@ let replay_history tactic_normalisation = | (MERGE_EQ(e3,e1,e2)) :: l -> let id = new_identifier () in tag_hypothesis id e3; - let id1 = hyp_of_tag e1.id + let id1 = hyp_of_tag e1.id and id2 = hyp_of_tag e2 in - let eq1 = val_of(decompile e1) + let eq1 = val_of(decompile e1) and eq2 = val_of (decompile (negate_eq e1)) in - let tac = - clever_rewrite [P_APP 3] [[P_APP 1]] + let tac = + clever_rewrite [P_APP 3] [[P_APP 1]] (Lazy.force coq_fast_Zopp_eq_mult_neg_1) :: - scalar_norm [P_APP 3] e1.body + scalar_norm [P_APP 3] e1.body in - tclTHENS - (cut (mk_eq eq1 (mk_inv eq2))) + tclTHENS + (cut (mk_eq eq1 (mk_inv eq2))) [tclTHENLIST [ (intros_using [aux]); - (generalize_tac [mkApp (Lazy.force coq_OMEGA8, + (generalize_tac [mkApp (Lazy.force coq_OMEGA8, [| eq1;eq2;mkVar id1;mkVar id2; mkVar aux|])]); (clear [id1;id2;aux]); (intros_using [id]); (loop l) ]; tclTHEN (mk_then tac) reflexivity] - + | STATE {st_new_eq=e;st_def=def;st_orig=orig;st_coef=m;st_var=v} :: l -> - let id = new_identifier () + let id = new_identifier () and id2 = hyp_of_tag orig.id in tag_hypothesis id e.id; - let eq1 = val_of(decompile def) + let eq1 = val_of(decompile def) and eq2 = val_of(decompile orig) in let vid = unintern_id v in let theorem = - mkApp (build_coq_ex (), [| + mkApp (build_coq_ex (), [| Lazy.force coq_Z; mkLambda (Name vid, @@ -1206,20 +1206,20 @@ let replay_history tactic_normalisation = in let mm = mk_integer m in let p_initial = [P_APP 2;P_TYPE] in - let tac = - clever_rewrite (P_APP 1 :: P_APP 1 :: P_APP 2 :: p_initial) + let tac = + clever_rewrite (P_APP 1 :: P_APP 1 :: P_APP 2 :: p_initial) [[P_APP 1]] (Lazy.force coq_fast_Zopp_eq_mult_neg_1) :: shuffle_mult_right p_initial orig.body m ({c= negone;v= v}::def.body) in - tclTHENS - (cut theorem) + tclTHENS + (cut theorem) [tclTHENLIST [ (intros_using [aux]); (elim_id aux); (clear [aux]); (intros_using [vid; aux]); (generalize_tac - [mkApp (Lazy.force coq_OMEGA9, + [mkApp (Lazy.force coq_OMEGA9, [| mkVar vid;eq2;eq1;mm; mkVar id2;mkVar aux |])]); (mk_then tac); (clear [aux]); @@ -1227,36 +1227,36 @@ let replay_history tactic_normalisation = (loop l) ]; tclTHEN (exists_tac (inj_open eq1)) reflexivity ] | SPLIT_INEQ(e,(e1,act1),(e2,act2)) :: l -> - let id1 = new_identifier () + let id1 = new_identifier () and id2 = new_identifier () in tag_hypothesis id1 e1; tag_hypothesis id2 e2; let id = hyp_of_tag e.id in let tac1 = norm_add [P_APP 2;P_TYPE] e.body in let tac2 = scalar_norm_add [P_APP 2;P_TYPE] e.body in let eq = val_of(decompile e) in - tclTHENS + tclTHENS (simplest_elim (applist (Lazy.force coq_OMEGA19, [eq; mkVar id]))) [tclTHENLIST [ (mk_then tac1); (intros_using [id1]); (loop act1) ]; tclTHENLIST [ (mk_then tac2); (intros_using [id2]); (loop act2) ]] | SUM(e3,(k1,e1),(k2,e2)) :: l -> let id = new_identifier () in tag_hypothesis id e3; - let id1 = hyp_of_tag e1.id + let id1 = hyp_of_tag e1.id and id2 = hyp_of_tag e2.id in - let eq1 = val_of(decompile e1) + let eq1 = val_of(decompile e1) and eq2 = val_of(decompile e2) in if k1 =? one & e2.kind = EQUA then let tac_thm = match e1.kind with - | EQUA -> Lazy.force coq_OMEGA5 - | INEQ -> Lazy.force coq_OMEGA6 - | DISE -> Lazy.force coq_OMEGA20 + | EQUA -> Lazy.force coq_OMEGA5 + | INEQ -> Lazy.force coq_OMEGA6 + | DISE -> Lazy.force coq_OMEGA20 in let kk = mk_integer k2 in let p_initial = if e1.kind=DISE then [P_APP 1; P_TYPE] else [P_APP 2; P_TYPE] in let tac = shuffle_mult_right p_initial e1.body k2 e2.body in - tclTHENLIST [ + tclTHENLIST [ (generalize_tac [mkApp (tac_thm, [| eq1; eq2; kk; mkVar id1; mkVar id2 |])]); (mk_then tac); @@ -1264,18 +1264,18 @@ let replay_history tactic_normalisation = (loop l) ] else - let kk1 = mk_integer k1 + let kk1 = mk_integer k1 and kk2 = mk_integer k2 in let p_initial = [P_APP 2;P_TYPE] in let tac= shuffle_mult p_initial k1 e1.body k2 e2.body in - tclTHENS (cut (mk_gt kk1 izero)) - [tclTHENS - (cut (mk_gt kk2 izero)) + tclTHENS (cut (mk_gt kk1 izero)) + [tclTHENS + (cut (mk_gt kk2 izero)) [tclTHENLIST [ (intros_using [aux2;aux1]); (generalize_tac - [mkApp (Lazy.force coq_OMEGA7, [| - eq1;eq2;kk1;kk2; + [mkApp (Lazy.force coq_OMEGA7, [| + eq1;eq2;kk1;kk2; mkVar aux1;mkVar aux2; mkVar id1;mkVar id2 |])]); (clear [aux1;aux2]); @@ -1288,11 +1288,11 @@ let replay_history tactic_normalisation = reflexivity ] ]; tclTHENLIST [ (unfold sp_Zgt); - simpl_in_concl; + simpl_in_concl; reflexivity ] ] - | CONSTANT_NOT_NUL(e,k) :: l -> + | CONSTANT_NOT_NUL(e,k) :: l -> tclTHEN (generalize_tac [mkVar (hyp_of_tag e)]) Equality.discrConcl - | CONSTANT_NUL(e) :: l -> + | CONSTANT_NUL(e) :: l -> tclTHEN (resolve_id (hyp_of_tag e)) reflexivity | CONSTANT_NEG(e,k) :: l -> tclTHENLIST [ @@ -1302,43 +1302,43 @@ let replay_history tactic_normalisation = (unfold sp_not); (intros_using [aux]); (resolve_id aux); - reflexivity + reflexivity ] - | _ -> tclIDTAC + | _ -> tclIDTAC in loop let normalize p_initial t = let (tac,t') = transform p_initial t in let (tac',t'') = condense p_initial t' in - let (tac'',t''') = clear_zero p_initial t'' in + let (tac'',t''') = clear_zero p_initial t'' in tac @ tac' @ tac'' , t''' - + let normalize_equation id flag theorem pos t t1 t2 (tactic,defs) = let p_initial = [P_APP pos ;P_TYPE] in let (tac,t') = normalize p_initial t in - let shift_left = - tclTHEN + let shift_left = + tclTHEN (generalize_tac [mkApp (theorem, [| t1; t2; mkVar id |]) ]) (tclTRY (clear [id])) in if tac <> [] then - let id' = new_identifier () in + let id' = new_identifier () in ((id',(tclTHENLIST [ (shift_left); (mk_then tac); (intros_using [id']) ])) :: tactic, compile id' flag t' :: defs) - else + else (tactic,defs) - + let destructure_omega gl tac_def (id,c) = - if atompart_of_id id = "State" then + if atompart_of_id id = "State" then tac_def else try match destructurate_prop c with - | Kapp(Eq,[typ;t1;t2]) + | Kapp(Eq,[typ;t1;t2]) when destructurate_type (pf_nf gl typ) = Kapp(Z,[]) -> let t = mk_plus t1 (mk_inv t2) in - normalize_equation + normalize_equation id EQUA (Lazy.force coq_Zegal_left) 2 t t1 t2 tac_def | Kapp(Zne,[t1;t2]) -> let t = mk_plus t1 (mk_inv t2) in @@ -1369,10 +1369,10 @@ let reintroduce id = let coq_omega gl = clear_tables (); - let tactic_normalisation, system = + let tactic_normalisation, system = List.fold_left (destructure_omega gl) ([],[]) (pf_hyps_types gl) in - let prelude,sys = - List.fold_left + let prelude,sys = + List.fold_left (fun (tac,sys) (t,(v,th,b)) -> if b then let id = new_identifier () in @@ -1385,8 +1385,8 @@ let coq_omega gl = (clear [id]); (intros_using [th;id]); tac ]), - {kind = INEQ; - body = [{v=intern_id v; c=one}]; + {kind = INEQ; + body = [{v=intern_id v; c=one}]; constant = zero; id = i} :: sys else (tclTHENLIST [ @@ -1399,17 +1399,17 @@ let coq_omega gl = let system = system @ sys in if !display_system_flag then display_system display_var system; if !old_style_flag then begin - try + try let _ = simplify (new_id,new_var_num,display_var) false system in tclIDTAC gl - with UNSOLVABLE -> + with UNSOLVABLE -> let _,path = depend [] [] (history ()) in if !display_action_flag then display_action display_var path; - (tclTHEN prelude (replay_history tactic_normalisation path)) gl - end else begin + (tclTHEN prelude (replay_history tactic_normalisation path)) gl + end else begin try let path = simplify_strong (new_id,new_var_num,display_var) system in - if !display_action_flag then display_action display_var path; + if !display_action_flag then display_action display_var path; (tclTHEN prelude (replay_history tactic_normalisation path)) gl with NO_CONTRADICTION -> error "Omega can't solve this system" end @@ -1417,10 +1417,10 @@ let coq_omega gl = let coq_omega = solver_time coq_omega let nat_inject gl = - let rec explore p t = + let rec explore p t = try match destructurate_term t with | Kapp(Plus,[t1;t2]) -> - tclTHENLIST [ + tclTHENLIST [ (clever_rewrite_gen p (mk_plus (mk_inj t1) (mk_inj t2)) ((Lazy.force coq_inj_plus),[t1;t2])); (explore (P_APP 1 :: p) t1); @@ -1436,61 +1436,61 @@ let nat_inject gl = | Kapp(Minus,[t1;t2]) -> let id = new_identifier () in tclTHENS - (tclTHEN - (simplest_elim (applist (Lazy.force coq_le_gt_dec, [t2;t1]))) - (intros_using [id])) + (tclTHEN + (simplest_elim (applist (Lazy.force coq_le_gt_dec, [t2;t1]))) + (intros_using [id])) [ tclTHENLIST [ - (clever_rewrite_gen p + (clever_rewrite_gen p (mk_minus (mk_inj t1) (mk_inj t2)) ((Lazy.force coq_inj_minus1),[t1;t2;mkVar id])); (loop [id,mkApp (Lazy.force coq_le, [| t2;t1 |])]); (explore (P_APP 1 :: p) t1); (explore (P_APP 2 :: p) t2) ]; - (tclTHEN + (tclTHEN (clever_rewrite_gen p (mk_integer zero) ((Lazy.force coq_inj_minus2),[t1;t2;mkVar id])) (loop [id,mkApp (Lazy.force coq_gt, [| t2;t1 |])])) ] | Kapp(S,[t']) -> let rec is_number t = - try match destructurate_term t with + try match destructurate_term t with Kapp(S,[t]) -> is_number t | Kapp(O,[]) -> true | _ -> false - with e when catchable_exception e -> false + with e when catchable_exception e -> false in let rec loop p t = - try match destructurate_term t with + try match destructurate_term t with Kapp(S,[t]) -> - (tclTHEN - (clever_rewrite_gen p + (tclTHEN + (clever_rewrite_gen p (mkApp (Lazy.force coq_Zsucc, [| mk_inj t |])) - ((Lazy.force coq_inj_S),[t])) + ((Lazy.force coq_inj_S),[t])) (loop (P_APP 1 :: p) t)) - | _ -> explore p t - with e when catchable_exception e -> explore p t + | _ -> explore p t + with e when catchable_exception e -> explore p t in if is_number t' then focused_simpl p else loop p t | Kapp(Pred,[t]) -> - let t_minus_one = - mkApp (Lazy.force coq_minus, [| t; + let t_minus_one = + mkApp (Lazy.force coq_minus, [| t; mkApp (Lazy.force coq_S, [| Lazy.force coq_O |]) |]) in tclTHEN - (clever_rewrite_gen_nat (P_APP 1 :: p) t_minus_one + (clever_rewrite_gen_nat (P_APP 1 :: p) t_minus_one ((Lazy.force coq_pred_of_minus),[t])) - (explore p t_minus_one) + (explore p t_minus_one) | Kapp(O,[]) -> focused_simpl p - | _ -> tclIDTAC - with e when catchable_exception e -> tclIDTAC - + | _ -> tclIDTAC + with e when catchable_exception e -> tclIDTAC + and loop = function | [] -> tclIDTAC - | (i,t)::lit -> - begin try match destructurate_prop t with + | (i,t)::lit -> + begin try match destructurate_prop t with Kapp(Le,[t1;t2]) -> tclTHENLIST [ - (generalize_tac + (generalize_tac [mkApp (Lazy.force coq_inj_le, [| t1;t2;mkVar i |]) ]); (explore [P_APP 1; P_TYPE] t1); (explore [P_APP 2; P_TYPE] t2); @@ -1499,7 +1499,7 @@ let nat_inject gl = ] | Kapp(Lt,[t1;t2]) -> tclTHENLIST [ - (generalize_tac + (generalize_tac [mkApp (Lazy.force coq_inj_lt, [| t1;t2;mkVar i |]) ]); (explore [P_APP 1; P_TYPE] t1); (explore [P_APP 2; P_TYPE] t2); @@ -1508,7 +1508,7 @@ let nat_inject gl = ] | Kapp(Ge,[t1;t2]) -> tclTHENLIST [ - (generalize_tac + (generalize_tac [mkApp (Lazy.force coq_inj_ge, [| t1;t2;mkVar i |]) ]); (explore [P_APP 1; P_TYPE] t1); (explore [P_APP 2; P_TYPE] t2); @@ -1536,7 +1536,7 @@ let nat_inject gl = | Kapp(Eq,[typ;t1;t2]) -> if pf_conv_x gl typ (Lazy.force coq_nat) then tclTHENLIST [ - (generalize_tac + (generalize_tac [mkApp (Lazy.force coq_inj_eq, [| t1;t2;mkVar i |]) ]); (explore [P_APP 2; P_TYPE] t1); (explore [P_APP 3; P_TYPE] t2); @@ -1545,32 +1545,32 @@ let nat_inject gl = ] else loop lit | _ -> loop lit - with e when catchable_exception e -> loop lit end + with e when catchable_exception e -> loop lit end in loop (List.rev (pf_hyps_types gl)) gl - + let rec decidability gl t = match destructurate_prop t with - | Kapp(Or,[t1;t2]) -> + | Kapp(Or,[t1;t2]) -> mkApp (Lazy.force coq_dec_or, [| t1; t2; decidability gl t1; decidability gl t2 |]) - | Kapp(And,[t1;t2]) -> + | Kapp(And,[t1;t2]) -> mkApp (Lazy.force coq_dec_and, [| t1; t2; decidability gl t1; decidability gl t2 |]) - | Kapp(Iff,[t1;t2]) -> + | Kapp(Iff,[t1;t2]) -> mkApp (Lazy.force coq_dec_iff, [| t1; t2; decidability gl t1; decidability gl t2 |]) - | Kimp(t1,t2) -> + | Kimp(t1,t2) -> mkApp (Lazy.force coq_dec_imp, [| t1; t2; decidability gl t1; decidability gl t2 |]) - | Kapp(Not,[t1]) -> mkApp (Lazy.force coq_dec_not, [| t1; + | Kapp(Not,[t1]) -> mkApp (Lazy.force coq_dec_not, [| t1; decidability gl t1 |]) - | Kapp(Eq,[typ;t1;t2]) -> + | Kapp(Eq,[typ;t1;t2]) -> begin match destructurate_type (pf_nf gl typ) with | Kapp(Z,[]) -> mkApp (Lazy.force coq_dec_eq, [| t1;t2 |]) | Kapp(Nat,[]) -> mkApp (Lazy.force coq_dec_eq_nat, [| t1;t2 |]) - | _ -> errorlabstrm "decidability" - (str "Omega: Can't solve a goal with equality on " ++ + | _ -> errorlabstrm "decidability" + (str "Omega: Can't solve a goal with equality on " ++ Printer.pr_lconstr typ) end | Kapp(Zne,[t1;t2]) -> mkApp (Lazy.force coq_dec_Zne, [| t1;t2 |]) @@ -1584,7 +1584,7 @@ let rec decidability gl t = | Kapp(Gt, [t1;t2]) -> mkApp (Lazy.force coq_dec_gt, [| t1;t2 |]) | Kapp(False,[]) -> Lazy.force coq_dec_False | Kapp(True,[]) -> Lazy.force coq_dec_True - | Kapp(Other t,_::_) -> error + | Kapp(Other t,_::_) -> error ("Omega: Unrecognized predicate or connective: "^t) | Kapp(Other t,[]) -> error ("Omega: Unrecognized atomic proposition: "^t) | Kvar _ -> error "Omega: Can't solve a goal with proposition variables" @@ -1595,7 +1595,7 @@ let onClearedName id tac = (* so renaming may be necessary *) tclTHEN (tclTRY (clear [id])) - (fun gl -> + (fun gl -> let id = fresh_id [] id gl in tclTHEN (introduction id) (tac id) gl) @@ -1607,7 +1607,7 @@ let destructure_hyps gl = | Kapp(False,[]) -> elim_id i | Kapp((Zle|Zge|Zgt|Zlt|Zne),[t1;t2]) -> loop lit | Kapp(Or,[t1;t2]) -> - (tclTHENS + (tclTHENS (elim_id i) [ onClearedName i (fun i -> (loop ((i,None,t1)::lit))); onClearedName i (fun i -> (loop ((i,None,t2)::lit))) ]) @@ -1615,7 +1615,7 @@ let destructure_hyps gl = tclTHENLIST [ (elim_id i); (tclTRY (clear [i])); - (fun gl -> + (fun gl -> let i1 = fresh_id [] (add_suffix i "_left") gl in let i2 = fresh_id [] (add_suffix i "_right") gl in tclTHENLIST [ @@ -1627,7 +1627,7 @@ let destructure_hyps gl = tclTHENLIST [ (elim_id i); (tclTRY (clear [i])); - (fun gl -> + (fun gl -> let i1 = fresh_id [] (add_suffix i "_left") gl in let i2 = fresh_id [] (add_suffix i "_right") gl in tclTHENLIST [ @@ -1661,16 +1661,16 @@ let destructure_hyps gl = ] else loop lit - | Kapp(Not,[t]) -> - begin match destructurate_prop t with - Kapp(Or,[t1;t2]) -> + | Kapp(Not,[t]) -> + begin match destructurate_prop t with + Kapp(Or,[t1;t2]) -> tclTHENLIST [ (generalize_tac [mkApp (Lazy.force coq_not_or,[| t1; t2; mkVar i |])]); (onClearedName i (fun i -> (loop ((i,None,mk_and (mk_not t1) (mk_not t2)):: lit)))) ] - | Kapp(And,[t1;t2]) -> + | Kapp(And,[t1;t2]) -> tclTHENLIST [ (generalize_tac [mkApp (Lazy.force coq_not_and, [| t1; t2; @@ -1690,8 +1690,8 @@ let destructure_hyps gl = ] | Kimp(t1,t2) -> tclTHENLIST [ - (generalize_tac - [mkApp (Lazy.force coq_not_imp, [| t1; t2; + (generalize_tac + [mkApp (Lazy.force coq_not_imp, [| t1; t2; decidability gl t1;mkVar i |])]); (onClearedName i (fun i -> (loop ((i,None,mk_and t1 (mk_not t2)) :: lit)))) @@ -1717,7 +1717,7 @@ let destructure_hyps gl = ] | Kapp(Zlt, [t1;t2]) -> tclTHENLIST [ - (generalize_tac + (generalize_tac [mkApp (Lazy.force coq_Znot_lt_ge, [| t1;t2;mkVar i|])]); (onClearedName i (fun _ -> loop lit)) ] @@ -1752,33 +1752,33 @@ let destructure_hyps gl = (onClearedName i (fun _ -> loop lit)) ] | Kapp(Eq,[typ;t1;t2]) -> - if !old_style_flag then begin + if !old_style_flag then begin match destructurate_type (pf_nf gl typ) with - | Kapp(Nat,_) -> + | Kapp(Nat,_) -> tclTHENLIST [ - (simplest_elim + (simplest_elim (mkApp (Lazy.force coq_not_eq, [|t1;t2;mkVar i|]))); (onClearedName i (fun _ -> loop lit)) ] | Kapp(Z,_) -> tclTHENLIST [ - (simplest_elim + (simplest_elim (mkApp (Lazy.force coq_not_Zeq, [|t1;t2;mkVar i|]))); (onClearedName i (fun _ -> loop lit)) ] | _ -> loop lit - end else begin + end else begin match destructurate_type (pf_nf gl typ) with - | Kapp(Nat,_) -> - (tclTHEN + | Kapp(Nat,_) -> + (tclTHEN (convert_hyp_no_check (i,body, (mkApp (Lazy.force coq_neq, [| t1;t2|])))) (loop lit)) | Kapp(Z,_) -> - (tclTHEN + (tclTHEN (convert_hyp_no_check (i,body, (mkApp (Lazy.force coq_Zne, [| t1;t2|])))) @@ -1786,10 +1786,10 @@ let destructure_hyps gl = | _ -> loop lit end | _ -> loop lit - end - | _ -> loop lit + end + | _ -> loop lit with e when catchable_exception e -> loop lit - end + end in loop (pf_hyps gl) gl @@ -1798,19 +1798,19 @@ let destructure_goal gl = let rec loop t = match destructurate_prop t with | Kapp(Not,[t]) -> - (tclTHEN - (tclTHEN (unfold sp_not) intro) + (tclTHEN + (tclTHEN (unfold sp_not) intro) destructure_hyps) | Kimp(a,b) -> (tclTHEN intro (loop b)) | Kapp(False,[]) -> destructure_hyps | _ -> - (tclTHEN + (tclTHEN (tclTHEN - (Tactics.refine + (Tactics.refine (mkApp (Lazy.force coq_dec_not_not, [| t; decidability gl t; mkNewMeta () |]))) - intro) - (destructure_hyps)) + intro) + (destructure_hyps)) in (loop concl) gl @@ -1818,7 +1818,7 @@ let destructure_goal = all_time (destructure_goal) let omega_solver gl = Coqlib.check_required_library ["Coq";"omega";"Omega"]; - let result = destructure_goal gl in - (* if !display_time_flag then begin text_time (); + let result = destructure_goal gl in + (* if !display_time_flag then begin text_time (); flush Pervasives.stdout end; *) result diff --git a/plugins/omega/g_omega.ml4 b/plugins/omega/g_omega.ml4 index a69f8ef745..3bfdce7fdc 100644 --- a/plugins/omega/g_omega.ml4 +++ b/plugins/omega/g_omega.ml4 @@ -20,16 +20,16 @@ open Coq_omega open Refiner -let omega_tactic l = - let tacs = List.map - (function +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 + in tclTHEN (tclREPEAT (tclPROGRESS (tclTHENLIST tacs))) omega_solver @@ -40,7 +40,7 @@ TACTIC EXTEND omega END TACTIC EXTEND omega' -| [ "omega" "with" ne_ident_list(l) ] -> +| [ "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/plugins/omega/omega.ml b/plugins/omega/omega.ml index fd774c16d0..11ab9c0394 100644 --- a/plugins/omega/omega.ml +++ b/plugins/omega/omega.ml @@ -85,13 +85,13 @@ type linear = coeff list type eqn_kind = EQUA | INEQ | DISE -type afine = { +type afine = { (* a number uniquely identifying the equation *) - id: int ; + id: int ; (* a boolean true for an eq, false for an ineq (Sigma a_i x_i >= 0) *) - kind: eqn_kind; + kind: eqn_kind; (* the variables and their coefficient *) - body: coeff list; + body: coeff list; (* a constant *) constant: bigint } @@ -108,7 +108,7 @@ type action = | FORGET_C of int | EXACT_DIVIDE of afine * bigint | SUM of int * (bigint * afine) * (bigint * afine) - | STATE of state_action + | STATE of state_action | HYP of afine | FORGET of int * int | FORGET_I of int * int @@ -126,22 +126,22 @@ exception UNSOLVABLE exception NO_CONTRADICTION let display_eq print_var (l,e) = - let _ = - List.fold_left + let _ = + List.fold_left (fun not_first f -> - print_string + print_string (if f.c <? zero then "- " else if not_first then "+ " else ""); let c = abs f.c in - if c =? one then + if c =? one then Printf.printf "%s " (print_var f.v) - else - Printf.printf "%s %s " (string_of_bigint c) (print_var f.v); + else + Printf.printf "%s %s " (string_of_bigint c) (print_var f.v); true) false l in - if e >? zero then + if e >? zero then Printf.printf "+ %s " (string_of_bigint e) - else if e <? zero then + else if e <? zero then Printf.printf "- %s " (string_of_bigint (abs e)) let rec trace_length l = @@ -151,22 +151,22 @@ let rec trace_length l = | _ -> accu + one in List.fold_left action_length zero l -let operator_of_eq = function +let operator_of_eq = function | EQUA -> "=" | DISE -> "!=" | INEQ -> ">=" let kind_of = function | EQUA -> "equation" | DISE -> "disequation" | INEQ -> "inequation" -let display_system print_var l = - List.iter - (fun { kind=b; body=e; constant=c; id=id} -> +let display_system print_var l = + List.iter + (fun { kind=b; body=e; constant=c; id=id} -> Printf.printf "E%d: " id; display_eq print_var (e,c); Printf.printf "%s 0\n" (operator_of_eq b)) l; print_string "------------------------\n\n" -let display_inequations print_var l = +let display_inequations print_var l = List.iter (fun e -> display_eq print_var e;print_string ">= 0\n") l; print_string "------------------------\n\n" @@ -175,7 +175,7 @@ let sbi = string_of_bigint let rec display_action print_var = function | act :: l -> begin match act with | DIVIDE_AND_APPROX (e1,e2,k,d) -> - Printf.printf + Printf.printf "Inequation E%d is divided by %s and the constant coefficient is \ rounded by substracting %s.\n" e1.id (sbi k) (sbi d) | NOT_EXACT_DIVIDE (e,k) -> @@ -187,28 +187,28 @@ let rec display_action print_var = function "Equation E%d is divided by the pgcd \ %s of its coefficients.\n" e.id (sbi k) | WEAKEN (e,k) -> - Printf.printf + Printf.printf "To ensure a solution in the dark shadow \ the equation E%d is weakened by %s.\n" e (sbi k) - | SUM (e,(c1,e1),(c2,e2)) -> + | SUM (e,(c1,e1),(c2,e2)) -> Printf.printf - "We state %s E%d = %s %s E%d + %s %s E%d.\n" + "We state %s E%d = %s %s E%d + %s %s E%d.\n" (kind_of e1.kind) e (sbi c1) (kind_of e1.kind) e1.id (sbi c2) (kind_of e2.kind) e2.id | STATE { st_new_eq = e } -> - Printf.printf "We define a new equation E%d: " e.id; - display_eq print_var (e.body,e.constant); + Printf.printf "We define a new equation E%d: " e.id; + display_eq print_var (e.body,e.constant); print_string (operator_of_eq e.kind); print_string " 0" - | HYP e -> - Printf.printf "We define E%d: " e.id; - display_eq print_var (e.body,e.constant); + | HYP e -> + Printf.printf "We define E%d: " e.id; + display_eq print_var (e.body,e.constant); print_string (operator_of_eq e.kind); print_string " 0\n" | FORGET_C e -> Printf.printf "E%d is trivially satisfiable.\n" e | FORGET (e1,e2) -> Printf.printf "E%d subsumes E%d.\n" e1 e2 | FORGET_I (e1,e2) -> Printf.printf "E%d subsumes E%d.\n" e1 e2 | MERGE_EQ (e,e1,e2) -> Printf.printf "E%d and E%d can be merged into E%d.\n" e1.id e2 e - | CONTRADICTION (e1,e2) -> + | CONTRADICTION (e1,e2) -> Printf.printf "Equations E%d and E%d imply a contradiction on their \ constant factors.\n" e1.id e2.id @@ -216,20 +216,20 @@ let rec display_action print_var = function Printf.printf "Equations E%d and E%d state that their body is at the same time equal and different\n" e1.id e2.id - | CONSTANT_NOT_NUL (e,k) -> + | CONSTANT_NOT_NUL (e,k) -> Printf.printf "Equation E%d states %s = 0.\n" e (sbi k) - | CONSTANT_NEG(e,k) -> + | CONSTANT_NEG(e,k) -> Printf.printf "Equation E%d states %s >= 0.\n" e (sbi k) | CONSTANT_NUL e -> Printf.printf "Inequation E%d states 0 != 0.\n" e - | SPLIT_INEQ (e,(e1,l1),(e2,l2)) -> + | SPLIT_INEQ (e,(e1,l1),(e2,l2)) -> Printf.printf "Equation E%d is split in E%d and E%d\n\n" e.id e1 e2; display_action print_var l1; print_newline (); display_action print_var l2; print_newline () end; display_action print_var l - | [] -> + | [] -> flush stdout let default_print_var v = Printf.sprintf "X%d" v (* For debugging *) @@ -245,38 +245,38 @@ let nf_linear = Sort.list (fun x y -> x.v > y.v) let nf ((b : bool),(e,(x : int))) = (b,(nf_linear e,x)) -let map_eq_linear f = +let map_eq_linear f = let rec loop = function | x :: l -> let c = f x.c in if c=?zero then loop l else {v=x.v; c=c} :: loop l - | [] -> [] + | [] -> [] in loop -let map_eq_afine f e = - { id = e.id; kind = e.kind; body = map_eq_linear f e.body; +let map_eq_afine f e = + { id = e.id; kind = e.kind; body = map_eq_linear f e.body; constant = f e.constant } let negate_eq = map_eq_afine (fun x -> neg x) -let rec sum p0 p1 = match (p0,p1) with +let rec sum p0 p1 = match (p0,p1) with | ([], l) -> l | (l, []) -> l - | (((x1::l1) as l1'), ((x2::l2) as l2')) -> + | (((x1::l1) as l1'), ((x2::l2) as l2')) -> if x1.v = x2.v then let c = x1.c + x2.c in if c =? zero then sum l1 l2 else {v=x1.v;c=c} :: sum l1 l2 - else if x1.v > x2.v then + else if x1.v > x2.v then x1 :: sum l1 l2' - else + else x2 :: sum l1' l2 -let sum_afine new_eq_id eq1 eq2 = +let sum_afine new_eq_id eq1 eq2 = { kind = eq1.kind; id = new_eq_id (); body = sum eq1.body eq2.body; constant = eq1.constant + eq2.constant } exception FACTOR1 let rec chop_factor_1 = function - | x :: l -> + | x :: l -> if abs x.c =? one then x,l else let (c',l') = chop_factor_1 l in (c',x::l') | [] -> raise FACTOR1 @@ -287,7 +287,7 @@ let rec chop_var v = function | [] -> raise CHOPVAR let normalize ({id=id; kind=eq_flag; body=e; constant =x} as eq) = - if e = [] then begin + if e = [] then begin match eq_flag with | EQUA -> if x =? zero then [] else begin @@ -310,7 +310,7 @@ let normalize ({id=id; kind=eq_flag; body=e; constant =x} as eq) = end else if gcd <> one then begin let c = floor_div x gcd in let d = x - c * gcd in - let new_eq = {id=id; kind=eq_flag; constant=c; + let new_eq = {id=id; kind=eq_flag; constant=c; body=map_eq_linear (fun c -> c / gcd) e} in add_event (if eq_flag=EQUA or eq_flag = DISE then EXACT_DIVIDE(eq,gcd) else DIVIDE_AND_APPROX(eq,new_eq,gcd,d)); @@ -320,15 +320,15 @@ let normalize ({id=id; kind=eq_flag; body=e; constant =x} as eq) = let eliminate_with_in new_eq_id {v=v;c=c_unite} eq2 ({body=e1; constant=c1} as eq1) = try - let (f,_) = chop_var v e1 in - let coeff = if c_unite=?one then neg f.c else if c_unite=? negone then f.c + let (f,_) = chop_var v e1 in + let coeff = if c_unite=?one then neg f.c else if c_unite=? negone then f.c else failwith "eliminate_with_in" in let res = sum_afine new_eq_id eq1 (map_eq_afine (fun c -> c * coeff) eq2) in add_event (SUM (res.id,(one,eq1),(coeff,eq2))); res with CHOPVAR -> eq1 let omega_mod a b = a - b * floor_div (two * a + b) (two * b) -let banerjee_step (new_eq_id,new_var_id,print_var) original l1 l2 = +let banerjee_step (new_eq_id,new_var_id,print_var) original l1 l2 = let e = original.body in let sigma = new_var_id () in let smallest,var = @@ -339,7 +339,7 @@ let banerjee_step (new_eq_id,new_var_id,print_var) original l1 l2 = let m = smallest + one in let new_eq = { constant = omega_mod original.constant m; - body = {c= neg m;v=sigma} :: + body = {c= neg m;v=sigma} :: map_eq_linear (fun a -> omega_mod a m) original.body; id = new_eq_id (); kind = EQUA } in let definition = @@ -351,11 +351,11 @@ let banerjee_step (new_eq_id,new_var_id,print_var) original l1 l2 = st_orig = original; st_coef = m; st_var = sigma}); let new_eq = List.hd (normalize new_eq) in let eliminated_var, def = chop_var var new_eq.body in - let other_equations = + let other_equations = Util.list_map_append - (fun e -> + (fun e -> normalize (eliminate_with_in new_eq_id eliminated_var new_eq e)) l1 in - let inequations = + let inequations = Util.list_map_append (fun e -> normalize (eliminate_with_in new_eq_id eliminated_var new_eq e)) l2 in @@ -364,7 +364,7 @@ let banerjee_step (new_eq_id,new_var_id,print_var) original l1 l2 = add_event (EXACT_DIVIDE (original',m)); List.hd (normalize mod_original),other_equations,inequations -let rec eliminate_one_equation ((new_eq_id,new_var_id,print_var) as new_ids) (e,other,ineqs) = +let rec eliminate_one_equation ((new_eq_id,new_var_id,print_var) as new_ids) (e,other,ineqs) = if !debug then display_system print_var (e::other); try let v,def = chop_factor_1 e.body in @@ -377,22 +377,22 @@ let rec eliminate_one_equation ((new_eq_id,new_var_id,print_var) as new_ids) (e, let rec banerjee ((_,_,print_var) as new_ids) (sys_eq,sys_ineq) = let rec fst_eq_1 = function - (eq::l) -> + (eq::l) -> if List.exists (fun x -> abs x.c =? one) eq.body then eq,l else let (eq',l') = fst_eq_1 l in (eq',eq::l') | [] -> raise Not_found in match sys_eq with [] -> if !debug then display_system print_var sys_ineq; sys_ineq - | (e1::rest) -> + | (e1::rest) -> let eq,other = try fst_eq_1 sys_eq with Not_found -> (e1,rest) in - if eq.body = [] then + if eq.body = [] then if eq.constant =? zero then begin add_event (FORGET_C eq.id); banerjee new_ids (other,sys_ineq) end else begin add_event (CONSTANT_NOT_NUL(eq.id,eq.constant)); raise UNSOLVABLE end else - banerjee new_ids + banerjee new_ids (eliminate_one_equation new_ids (eq,other,sys_ineq)) type kind = INVERTED | NORMAL @@ -403,37 +403,37 @@ let redundancy_elimination new_eq_id system = | e -> e,NORMAL in let table = Hashtbl.create 7 in List.iter - (fun e -> + (fun e -> let ({body=ne} as nx) ,kind = normal e in if ne = [] then if nx.constant <? zero then begin add_event (CONSTANT_NEG(nx.id,nx.constant)); raise UNSOLVABLE end else add_event (FORGET_C nx.id) else - try + try let (optnormal,optinvert) = Hashtbl.find table ne in let final = if kind = NORMAL then begin - match optnormal with - Some v -> + match optnormal with + Some v -> let kept = - if v.constant <? nx.constant + if v.constant <? nx.constant then begin add_event (FORGET (v.id,nx.id));v end else begin add_event (FORGET (nx.id,v.id));nx end in (Some(kept),optinvert) | None -> Some nx,optinvert end else begin - match optinvert with + match optinvert with Some v -> let _kept = - if v.constant >? nx.constant + if v.constant >? nx.constant then begin add_event (FORGET_I (v.id,nx.id));v end else begin add_event (FORGET_I (nx.id,v.id));nx end in (optnormal,Some(if v.constant >? nx.constant then v else nx)) | None -> optnormal,Some nx end in begin match final with - (Some high, Some low) -> + (Some high, Some low) -> if high.constant <? low.constant then begin add_event(CONTRADICTION (high,negate_eq low)); raise UNSOLVABLE @@ -442,21 +442,21 @@ let redundancy_elimination new_eq_id system = Hashtbl.remove table ne; Hashtbl.add table ne final with Not_found -> - Hashtbl.add table ne + Hashtbl.add table ne (if kind = NORMAL then (Some nx,None) else (None,Some nx))) system; let accu_eq = ref [] in let accu_ineq = ref [] in Hashtbl.iter - (fun p0 p1 -> match (p0,p1) with + (fun p0 p1 -> match (p0,p1) with | (e, (Some x, Some y)) when x.constant =? y.constant -> let id=new_eq_id () in add_event (MERGE_EQ(id,x,y.id)); push {id=id; kind=EQUA; body=x.body; constant=x.constant} accu_eq | (e, (optnorm,optinvert)) -> - begin match optnorm with + begin match optnorm with Some x -> push x accu_ineq | _ -> () end; - begin match optinvert with + begin match optinvert with Some x -> push (negate_eq x) accu_ineq | _ -> () end) table; !accu_eq,!accu_ineq @@ -465,7 +465,7 @@ exception SOLVED_SYSTEM let select_variable system = let table = Hashtbl.create 7 in - let push v c= + let push v c= try let r = Hashtbl.find table v in r := max !r (abs c) with Not_found -> Hashtbl.add table v (ref (abs c)) in List.iter (fun {body=l} -> List.iter (fun f -> push f.v f.c) l) system; @@ -480,7 +480,7 @@ let select_variable system = !vmin let classify v system = - List.fold_left + List.fold_left (fun (not_occ,below,over) eq -> try let f,eq' = chop_var v eq.body in if f.c >=? zero then (not_occ,((f.c,eq) :: below),over) @@ -493,18 +493,18 @@ let product new_eq_id dark_shadow low high = (fun accu (a,eq1) -> List.fold_left (fun accu (b,eq2) -> - let eq = + let eq = sum_afine new_eq_id (map_eq_afine (fun c -> c * b) eq1) (map_eq_afine (fun c -> c * a) eq2) in add_event(SUM(eq.id,(b,eq1),(a,eq2))); match normalize eq with | [eq] -> let final_eq = - if dark_shadow then + if dark_shadow then let delta = (a - one) * (b - one) in add_event(WEAKEN(eq.id,delta)); - {id = eq.id; kind=INEQ; body = eq.body; - constant = eq.constant - delta} + {id = eq.id; kind=INEQ; body = eq.body; + constant = eq.constant - delta} else eq in final_eq :: accu | (e::_) -> failwith "Product dardk" @@ -519,7 +519,7 @@ let fourier_motzkin (new_eq_id,_,print_var) dark_shadow system = if !debug then display_system print_var expanded; expanded let simplify ((new_eq_id,new_var_id,print_var) as new_ids) dark_shadow system = - if List.exists (fun e -> e.kind = DISE) system then + if List.exists (fun e -> e.kind = DISE) system then failwith "disequation in simplify"; clear_history (); List.iter (fun e -> add_event (HYP e)) system; @@ -528,23 +528,23 @@ let simplify ((new_eq_id,new_var_id,print_var) as new_ids) dark_shadow system = let simp_eq,simp_ineq = redundancy_elimination new_eq_id ineqs in let system = (eqs @ simp_eq,simp_ineq) in let rec loop1a system = - let sys_ineq = banerjee new_ids system in - loop1b sys_ineq + let sys_ineq = banerjee new_ids system in + loop1b sys_ineq and loop1b sys_ineq = let simp_eq,simp_ineq = redundancy_elimination new_eq_id sys_ineq in - if simp_eq = [] then simp_ineq else loop1a (simp_eq,simp_ineq) + if simp_eq = [] then simp_ineq else loop1a (simp_eq,simp_ineq) in let rec loop2 system = try let expanded = fourier_motzkin new_ids dark_shadow system in loop2 (loop1b expanded) with SOLVED_SYSTEM -> - if !debug then display_system print_var system; system + if !debug then display_system print_var system; system in loop2 (loop1a system) let rec depend relie_on accu = function - | act :: l -> + | act :: l -> begin match act with | DIVIDE_AND_APPROX (e,_,_,_) -> if List.mem e.id relie_on then depend relie_on (act::accu) l @@ -555,40 +555,40 @@ let rec depend relie_on accu = function | WEAKEN (e,_) -> if List.mem e relie_on then depend relie_on (act::accu) l else depend relie_on accu l - | SUM (e,(_,e1),(_,e2)) -> - if List.mem e relie_on then + | SUM (e,(_,e1),(_,e2)) -> + if List.mem e relie_on then depend (e1.id::e2.id::relie_on) (act::accu) l - else + else depend relie_on accu l | STATE {st_new_eq=e;st_orig=o} -> if List.mem e.id relie_on then depend (o.id::relie_on) (act::accu) l else depend relie_on accu l - | HYP e -> + | HYP e -> if List.mem e.id relie_on then depend relie_on (act::accu) l else depend relie_on accu l | FORGET_C _ -> depend relie_on accu l | FORGET _ -> depend relie_on accu l | FORGET_I _ -> depend relie_on accu l | MERGE_EQ (e,e1,e2) -> - if List.mem e relie_on then + if List.mem e relie_on then depend (e1.id::e2::relie_on) (act::accu) l - else + else depend relie_on accu l | NOT_EXACT_DIVIDE (e,_) -> depend (e.id::relie_on) (act::accu) l - | CONTRADICTION (e1,e2) -> + | CONTRADICTION (e1,e2) -> depend (e1.id::e2.id::relie_on) (act::accu) l | CONSTANT_NOT_NUL (e,_) -> depend (e::relie_on) (act::accu) l | CONSTANT_NEG (e,_) -> depend (e::relie_on) (act::accu) l | CONSTANT_NUL e -> depend (e::relie_on) (act::accu) l - | NEGATE_CONTRADICT (e1,e2,_) -> + | NEGATE_CONTRADICT (e1,e2,_) -> depend (e1.id::e2.id::relie_on) (act::accu) l | SPLIT_INEQ _ -> failwith "depend" end | [] -> relie_on, accu (* -let depend relie_on accu trace = - Printf.printf "Longueur de la trace initiale : %d\n" +let depend relie_on accu trace = + Printf.printf "Longueur de la trace initiale : %d\n" (trace_length trace + trace_length accu); let rel',trace' = depend relie_on accu trace in Printf.printf "Longueur de la trace simplifiée : %d\n" (trace_length trace'); @@ -598,20 +598,20 @@ let depend relie_on accu trace = let solve (new_eq_id,new_eq_var,print_var) system = try let _ = simplify new_eq_id false system in failwith "no contradiction" with UNSOLVABLE -> display_action print_var (snd (depend [] [] (history ()))) - + let negation (eqs,ineqs) = let diseq,_ = List.partition (fun e -> e.kind = DISE) ineqs in let normal = function | ({body=f::_} as e) when f.c <? zero -> negate_eq e, INVERTED | e -> e,NORMAL in let table = Hashtbl.create 7 in - List.iter (fun e -> + List.iter (fun e -> let {body=ne;constant=c} ,kind = normal e in Hashtbl.add table (ne,c) (kind,e)) diseq; List.iter (fun e -> assert (e.kind = EQUA); let {body=ne;constant=c},kind = normal e in - try + try let (kind',e') = Hashtbl.find table (ne,c) in add_event (NEGATE_CONTRADICT (e,e',kind=kind')); raise UNSOLVABLE @@ -625,39 +625,39 @@ let simplify_strong ((new_eq_id,new_var_id,print_var) as new_ids) system = (* Initial simplification phase *) let rec loop1a system = negation system; - let sys_ineq = banerjee new_ids system in - loop1b sys_ineq + let sys_ineq = banerjee new_ids system in + loop1b sys_ineq and loop1b sys_ineq = let dise,ine = List.partition (fun e -> e.kind = DISE) sys_ineq in let simp_eq,simp_ineq = redundancy_elimination new_eq_id ine in if simp_eq = [] then dise @ simp_ineq - else loop1a (simp_eq,dise @ simp_ineq) + else loop1a (simp_eq,dise @ simp_ineq) in let rec loop2 system = try let expanded = fourier_motzkin new_ids false system in loop2 (loop1b expanded) - with SOLVED_SYSTEM -> if !debug then display_system print_var system; system + with SOLVED_SYSTEM -> if !debug then display_system print_var system; system in - let rec explode_diseq = function + let rec explode_diseq = function | (de::diseq,ineqs,expl_map) -> - let id1 = new_eq_id () + let id1 = new_eq_id () and id2 = new_eq_id () in - let e1 = + let e1 = {id = id1; kind=INEQ; body = de.body; constant = de.constant -one} in - let e2 = - {id = id2; kind=INEQ; body = map_eq_linear neg de.body; + let e2 = + {id = id2; kind=INEQ; body = map_eq_linear neg de.body; constant = neg de.constant - one} in let new_sys = - List.map (fun (what,sys) -> ((de.id,id1,true)::what, e1::sys)) - ineqs @ - List.map (fun (what,sys) -> ((de.id,id2,false)::what,e2::sys)) - ineqs + List.map (fun (what,sys) -> ((de.id,id1,true)::what, e1::sys)) + ineqs @ + List.map (fun (what,sys) -> ((de.id,id2,false)::what,e2::sys)) + ineqs in explode_diseq (diseq,new_sys,(de.id,(de,id1,id2))::expl_map) - | ([],ineqs,expl_map) -> ineqs,expl_map + | ([],ineqs,expl_map) -> ineqs,expl_map in - try + try let system = Util.list_map_append normalize system in let eqs,ineqs = List.partition (fun e -> e.kind=EQUA) system in let dise,ine = List.partition (fun e -> e.kind = DISE) ineqs in @@ -669,45 +669,45 @@ let simplify_strong ((new_eq_id,new_var_id,print_var) as new_ids) system = let sys_exploded,explode_map = explode_diseq (diseq,[[],ineq],[]) in let all_solutions = List.map - (fun (decomp,sys) -> + (fun (decomp,sys) -> clear_history (); try let _ = loop2 sys in raise NO_CONTRADICTION - with UNSOLVABLE -> + with UNSOLVABLE -> let relie_on,path = depend [] [] (history ()) in let dc,_ = List.partition (fun (_,id,_) -> List.mem id relie_on) decomp in let red = List.map (fun (x,_,_) -> x) dc in (red,relie_on,decomp,path)) - sys_exploded + sys_exploded in - let max_count sys = + let max_count sys = let tbl = Hashtbl.create 7 in - let augment x = - try incr (Hashtbl.find tbl x) + let augment x = + try incr (Hashtbl.find tbl x) with Not_found -> Hashtbl.add tbl x (ref 1) in let eq = ref (-1) and c = ref 0 in - List.iter (function + List.iter (function | ([],r_on,_,path) -> raise (FULL_SOLUTION (path,r_on)) | (l,_,_,_) -> List.iter augment l) sys; Hashtbl.iter (fun x v -> if !v > !c then begin eq := x; c := !v end) tbl; - !eq + !eq in - let rec solve systems = - try - let id = max_count systems in - let rec sign = function - | ((id',_,b)::l) -> if id=id' then b else sign l + let rec solve systems = + try + let id = max_count systems in + let rec sign = function + | ((id',_,b)::l) -> if id=id' then b else sign l | [] -> failwith "solve" in let s1,s2 = List.partition (fun (_,_,decomp,_) -> sign decomp) systems in - let s1' = + let s1' = List.map (fun (dep,ro,dc,pa) -> (Util.list_except id dep,ro,dc,pa)) s1 in - let s2' = + let s2' = List.map (fun (dep,ro,dc,pa) -> (Util.list_except id dep,ro,dc,pa)) s2 in - let (r1,relie1) = solve s1' + let (r1,relie1) = solve s1' and (r2,relie2) = solve s2' in let (eq,id1,id2) = List.assoc id explode_map in [SPLIT_INEQ(eq,(id1,r1),(id2, r2))], eq.id :: Util.list_union relie1 relie2 - with FULL_SOLUTION (x0,x1) -> (x0,x1) + with FULL_SOLUTION (x0,x1) -> (x0,x1) in let act,relie_on = solve all_solutions in snd(depend relie_on act first_segment) diff --git a/plugins/ring/LegacyArithRing.v b/plugins/ring/LegacyArithRing.v index 959d66c749..231b5fbb0f 100644 --- a/plugins/ring/LegacyArithRing.v +++ b/plugins/ring/LegacyArithRing.v @@ -73,14 +73,14 @@ Ltac rewrite_S_to_plus := match goal with | |- (?X1 = ?X2) => try - let t1 := + let t1 := (**) (**) rewrite_S_to_plus_term X1 with t2 := rewrite_S_to_plus_term X2 in change (t1 = t2) in |- * | |- (?X1 = ?X2) => try - let t1 := + let t1 := (**) (**) rewrite_S_to_plus_term X1 with t2 := rewrite_S_to_plus_term X2 in diff --git a/plugins/ring/LegacyRing_theory.v b/plugins/ring/LegacyRing_theory.v index 79f6976bd2..30d29515f0 100644 --- a/plugins/ring/LegacyRing_theory.v +++ b/plugins/ring/LegacyRing_theory.v @@ -19,8 +19,8 @@ Variable Aplus : A -> A -> A. Variable Amult : A -> A -> A. Variable Aone : A. Variable Azero : A. -(* There is also a "weakly decidable" equality on A. That means - that if (A_eq x y)=true then x=y but x=y can arise when +(* There is also a "weakly decidable" equality on A. That means + that if (A_eq x y)=true then x=y but x=y can arise when (A_eq x y)=false. On an abstract ring the function [x,y:A]false is a good choice. The proof of A_eq_prop is in this case easy. *) Variable Aeq : A -> A -> bool. @@ -30,7 +30,7 @@ Infix "*" := Amult (at level 40, left associativity). Notation "0" := Azero. Notation "1" := Aone. -Record Semi_Ring_Theory : Prop := +Record Semi_Ring_Theory : Prop := {SR_plus_comm : forall n m:A, n + m = m + n; SR_plus_assoc : forall n m p:A, n + (m + p) = n + m + p; SR_mult_comm : forall n m:A, n * m = m * n; @@ -49,7 +49,7 @@ Let plus_assoc := SR_plus_assoc T. Let mult_comm := SR_mult_comm T. Let mult_assoc := SR_mult_assoc T. Let plus_zero_left := SR_plus_zero_left T. -Let mult_one_left := SR_mult_one_left T. +Let mult_one_left := SR_mult_one_left T. Let mult_zero_left := SR_mult_zero_left T. Let distr_left := SR_distr_left T. (*Let plus_reg_left := SR_plus_reg_left T.*) @@ -58,7 +58,7 @@ Hint Resolve plus_comm plus_assoc mult_comm mult_assoc plus_zero_left mult_one_left mult_zero_left distr_left (*plus_reg_left*). (* Lemmas whose form is x=y are also provided in form y=x because Auto does - not symmetry *) + not symmetry *) Lemma SR_mult_assoc2 : forall n m p:A, n * m * p = n * (m * p). symmetry in |- *; eauto. Qed. @@ -150,7 +150,7 @@ Notation "0" := Azero. Notation "1" := Aone. Notation "- x" := (Aopp x). -Record Ring_Theory : Prop := +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_comm : forall n m:A, n * m = m * n; @@ -168,7 +168,7 @@ Let plus_assoc := Th_plus_assoc 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. +Let mult_one_left := Th_mult_one_left T. Let opp_def := Th_opp_def T. Let distr_left := Th_distr_left T. @@ -176,7 +176,7 @@ Hint Resolve plus_comm plus_assoc mult_comm mult_assoc plus_zero_left mult_one_left opp_def distr_left. (* Lemmas whose form is x=y are also provided in form y=x because Auto does - not symmetry *) + not symmetry *) Lemma Th_mult_assoc2 : forall n m p:A, n * m * p = n * (m * p). symmetry in |- *; eauto. Qed. @@ -331,7 +331,7 @@ Qed. Lemma Th_plus_reg_right : forall n m p:A, m + n = p + n -> m = p. intros. -eapply Th_plus_reg_left with n. +eapply Th_plus_reg_left with n. rewrite (plus_comm n m). rewrite (plus_comm n p). auto. @@ -354,7 +354,7 @@ Hint Resolve Th_mult_zero_left (*Th_plus_reg_left*): core. Unset Implicit Arguments. Definition Semi_Ring_Theory_of : - forall (A:Type) (Aplus Amult:A -> A -> A) (Aone Azero:A) + forall (A:Type) (Aplus Amult:A -> A -> A) (Aone Azero:A) (Aopp:A -> A) (Aeq:A -> A -> bool), Ring_Theory Aplus Amult Aone Azero Aopp Aeq -> Semi_Ring_Theory Aplus Amult Aone Azero Aeq. diff --git a/plugins/ring/Ring_abstract.v b/plugins/ring/Ring_abstract.v index 9b85fb85e0..2a9df21b33 100644 --- a/plugins/ring/Ring_abstract.v +++ b/plugins/ring/Ring_abstract.v @@ -164,7 +164,7 @@ Lemma abstract_varlist_insert_ok : trivial. simpl in |- *; intros. - elim (varlist_lt l v); simpl in |- *. + elim (varlist_lt l v); simpl in |- *. eauto. rewrite iacs_aux_ok. rewrite H; auto. @@ -175,7 +175,7 @@ Lemma abstract_sum_merge_ok : forall x y:abstract_sum, interp_acs (abstract_sum_merge x y) = Aplus (interp_acs x) (interp_acs y). -Proof. +Proof. simple induction x. trivial. simple induction y; intros. @@ -240,13 +240,13 @@ End abstract_semi_rings. Section abstract_rings. (* In abstract polynomials there is no constants other - than 0 and 1. An abstract ring is a ring whose operations plus, + than 0 and 1. An abstract ring is a ring whose operations plus, and mult are not functions but constructors. In other words, when c1 and c2 are closed, (plus c1 c2) doesn't reduce to a closed term. "closed" mean here "without plus and mult". *) (* this section is not parametrized by a (semi-)ring. - Nevertheless, they are two different types for semi-rings and rings + Nevertheless, they are two different types for semi-rings and rings and there will be 2 correction theorems *) Inductive apolynomial : Type := @@ -488,7 +488,7 @@ Lemma signed_sum_merge_ok : intro Heq; rewrite (Heq I). rewrite H. repeat rewrite isacs_aux_ok. - rewrite (Th_plus_permute T). + rewrite (Th_plus_permute T). repeat rewrite (Th_plus_assoc T). rewrite (Th_plus_comm T (Aopp (interp_vl Amult Aone Azero vm v0)) @@ -509,7 +509,7 @@ Lemma signed_sum_merge_ok : intro Heq; rewrite (Heq I). rewrite H. repeat rewrite isacs_aux_ok. - rewrite (Th_plus_permute T). + rewrite (Th_plus_permute T). repeat rewrite (Th_plus_assoc T). rewrite (Th_opp_def T). rewrite (Th_plus_zero_left T). @@ -701,6 +701,6 @@ Proof. intros. rewrite signed_sum_opp_ok. rewrite H; reflexivity. -Qed. +Qed. End abstract_rings. diff --git a/plugins/ring/Ring_normalize.v b/plugins/ring/Ring_normalize.v index ad1cc5cf10..7aeee21857 100644 --- a/plugins/ring/Ring_normalize.v +++ b/plugins/ring/Ring_normalize.v @@ -39,11 +39,11 @@ Variable Aeq : A -> A -> bool. (* Normal abtract Polynomials *) (******************************************) (* DEFINITIONS : -- A varlist is a sorted product of one or more variables : x, x*y*z +- A varlist is a sorted product of one or more variables : x, x*y*z - A monom is a constant, a varlist or the product of a constant by a varlist variables. 2*x*y, x*y*z, 3 are monoms : 2*3, x*3*y, 4*x*3 are NOT. -- A canonical sum is either a monom or an ordered sum of monoms - (the order on monoms is defined later) +- A canonical sum is either a monom or an ordered sum of monoms + (the order on monoms is defined later) - A normal polynomial it either a constant or a canonical sum or a constant plus a canonical sum *) @@ -61,14 +61,14 @@ Inductive canonical_sum : Type := (* Order on monoms *) -(* That's the lexicographic order on varlist, extended by : - - A constant is less than every monom +(* That's the lexicographic order on varlist, extended by : + - A constant is less than every monom - The relation between two varlist is preserved by multiplication by a constant. - Examples : + Examples : 3 < x < y - x*y < x*y*y*z + x*y < x*y*y*z 2*x*y < x*y*y*z x*y < 54*x*y*y*z 4*x*y < 59*x*y*y*z @@ -214,7 +214,7 @@ Fixpoint canonical_sum_scalar2 (l0:varlist) (s:canonical_sum) {struct s} : end. (* Computes c0*l0*s *) -Fixpoint canonical_sum_scalar3 (c0:A) (l0:varlist) +Fixpoint canonical_sum_scalar3 (c0:A) (l0:varlist) (s:canonical_sum) {struct s} : canonical_sum := match s with | Cons_monom c l t => @@ -225,7 +225,7 @@ Fixpoint canonical_sum_scalar3 (c0:A) (l0:varlist) | Nil_monom => Nil_monom end. -(* returns the product of two canonical sums *) +(* returns the product of two canonical sums *) Fixpoint canonical_sum_prod (s1 s2:canonical_sum) {struct s1} : canonical_sum := match s1 with @@ -282,7 +282,7 @@ Definition spolynomial_simplify (x:spolynomial) := Variable vm : varmap A. -(* Interpretation of list of variables +(* Interpretation of list of variables * [x1; ... ; xn ] is interpreted as (find v x1)* ... *(find v xn) * The unbound variables are mapped to 0. Normally this case sould * never occur. Since we want only to prove correctness theorems, which form @@ -608,7 +608,7 @@ repeat rewrite ics_aux_ok. repeat rewrite interp_m_ok. rewrite H. rewrite varlist_merge_ok. -repeat rewrite (SR_distr_right T). +repeat rewrite (SR_distr_right T). repeat rewrite <- (SR_mult_assoc T). repeat rewrite <- (SR_plus_assoc T). rewrite (SR_mult_permute T a (interp_vl l) (interp_vl v)). @@ -620,7 +620,7 @@ repeat rewrite ics_aux_ok. repeat rewrite interp_m_ok. rewrite H. rewrite varlist_merge_ok. -repeat rewrite (SR_distr_right T). +repeat rewrite (SR_distr_right T). repeat rewrite <- (SR_mult_assoc T). repeat rewrite <- (SR_plus_assoc T). reflexivity. @@ -639,7 +639,7 @@ repeat rewrite ics_aux_ok. repeat rewrite interp_m_ok. rewrite H. rewrite varlist_merge_ok. -repeat rewrite (SR_distr_right T). +repeat rewrite (SR_distr_right T). repeat rewrite <- (SR_mult_assoc T). repeat rewrite <- (SR_plus_assoc T). rewrite (SR_mult_permute T a (interp_vl l) (interp_vl v)). @@ -651,7 +651,7 @@ repeat rewrite ics_aux_ok. repeat rewrite interp_m_ok. rewrite H. rewrite varlist_merge_ok. -repeat rewrite (SR_distr_right T). +repeat rewrite (SR_distr_right T). repeat rewrite <- (SR_mult_assoc T). repeat rewrite <- (SR_plus_assoc T). rewrite (SR_mult_permute T c (interp_vl l) (interp_vl v)). diff --git a/plugins/ring/Setoid_ring_normalize.v b/plugins/ring/Setoid_ring_normalize.v index ce23d05af0..9b4c46fe92 100644 --- a/plugins/ring/Setoid_ring_normalize.v +++ b/plugins/ring/Setoid_ring_normalize.v @@ -13,7 +13,7 @@ Require Import Quote. Set Implicit Arguments. Unset Boxed Definitions. - + Lemma index_eq_prop : forall n m:index, Is_true (index_eq n m) -> n = m. Proof. simple induction n; simple induction m; simpl in |- *; @@ -75,11 +75,11 @@ Section semi_setoid_rings. (* Normal abtract Polynomials *) (******************************************) (* DEFINITIONS : -- A varlist is a sorted product of one or more variables : x, x*y*z +- A varlist is a sorted product of one or more variables : x, x*y*z - A monom is a constant, a varlist or the product of a constant by a varlist variables. 2*x*y, x*y*z, 3 are monoms : 2*3, x*3*y, 4*x*3 are NOT. -- A canonical sum is either a monom or an ordered sum of monoms - (the order on monoms is defined later) +- A canonical sum is either a monom or an ordered sum of monoms + (the order on monoms is defined later) - A normal polynomial it either a constant or a canonical sum or a constant plus a canonical sum *) @@ -97,14 +97,14 @@ Inductive canonical_sum : Type := (* Order on monoms *) -(* That's the lexicographic order on varlist, extended by : - - A constant is less than every monom +(* That's the lexicographic order on varlist, extended by : + - A constant is less than every monom - The relation between two varlist is preserved by multiplication by a constant. - Examples : + Examples : 3 < x < y - x*y < x*y*y*z + x*y < x*y*y*z 2*x*y < x*y*y*z x*y < 54*x*y*y*z 4*x*y < 59*x*y*y*z @@ -250,7 +250,7 @@ Fixpoint canonical_sum_scalar2 (l0:varlist) (s:canonical_sum) {struct s} : end. (* Computes c0*l0*s *) -Fixpoint canonical_sum_scalar3 (c0:A) (l0:varlist) +Fixpoint canonical_sum_scalar3 (c0:A) (l0:varlist) (s:canonical_sum) {struct s} : canonical_sum := match s with | Cons_monom c l t => @@ -261,7 +261,7 @@ Fixpoint canonical_sum_scalar3 (c0:A) (l0:varlist) | Nil_monom => Nil_monom end. -(* returns the product of two canonical sums *) +(* returns the product of two canonical sums *) Fixpoint canonical_sum_prod (s1 s2:canonical_sum) {struct s1} : canonical_sum := match s1 with @@ -540,7 +540,7 @@ rewrite end) c0)). rewrite H0. rewrite (ics_aux_ok (interp_m a v) c); - rewrite (ics_aux_ok (interp_m a0 v0) c0); simpl in |- *; + rewrite (ics_aux_ok (interp_m a0 v0) c0); simpl in |- *; auto. generalize (varlist_eq_prop v v0). diff --git a/plugins/ring/Setoid_ring_theory.v b/plugins/ring/Setoid_ring_theory.v index f50a2f30a4..2c2314affe 100644 --- a/plugins/ring/Setoid_ring_theory.v +++ b/plugins/ring/Setoid_ring_theory.v @@ -57,7 +57,7 @@ Qed. Section Theory_of_semi_setoid_rings. -Record Semi_Setoid_Ring_Theory : Prop := +Record Semi_Setoid_Ring_Theory : Prop := {SSR_plus_comm : forall n m:A, n + m == m + n; SSR_plus_assoc : forall n m p:A, n + (m + p) == n + m + p; SSR_mult_comm : forall n m:A, n * m == m * n; @@ -76,7 +76,7 @@ Let plus_assoc := SSR_plus_assoc T. Let mult_comm := SSR_mult_comm T. Let mult_assoc := SSR_mult_assoc T. Let plus_zero_left := SSR_plus_zero_left T. -Let mult_one_left := SSR_mult_one_left T. +Let mult_one_left := SSR_mult_one_left T. Let mult_zero_left := SSR_mult_zero_left T. Let distr_left := SSR_distr_left T. Let plus_reg_left := SSR_plus_reg_left T. @@ -90,7 +90,7 @@ Hint Resolve plus_comm plus_assoc mult_comm mult_assoc plus_zero_left Hint Immediate equiv_sym. (* Lemmas whose form is x=y are also provided in form y=x because - Auto does not symmetry *) + Auto does not symmetry *) Lemma SSR_mult_assoc2 : forall n m p:A, n * m * p == n * (m * p). auto. Qed. @@ -174,7 +174,7 @@ End Theory_of_semi_setoid_rings. Section Theory_of_setoid_rings. -Record Setoid_Ring_Theory : Prop := +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_comm : forall n m:A, n * m == m * n; @@ -192,7 +192,7 @@ Let plus_assoc := STh_plus_assoc 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. +Let mult_one_left := STh_mult_one_left T. Let opp_def := STh_opp_def T. Let distr_left := STh_distr_left T. Let equiv_refl := Seq_refl A Aequiv S. diff --git a/plugins/ring/g_ring.ml4 b/plugins/ring/g_ring.ml4 index 5ca1bfced5..d766e34454 100644 --- a/plugins/ring/g_ring.ml4 +++ b/plugins/ring/g_ring.ml4 @@ -20,13 +20,13 @@ END (* The vernac commands "Add Ring" and co *) -let cset_of_constrarg_list l = +let cset_of_constrarg_list l = List.fold_right ConstrSet.add (List.map constr_of l) ConstrSet.empty VERNAC COMMAND EXTEND AddRing - [ "Add" "Legacy" "Ring" + [ "Add" "Legacy" "Ring" constr(a) constr(aplus) constr(amult) constr(aone) constr(azero) - constr(aopp) constr(aeq) constr(t) "[" ne_constr_list(l) "]" ] + constr(aopp) constr(aeq) constr(t) "[" ne_constr_list(l) "]" ] -> [ add_theory true false false (constr_of a) None @@ -41,9 +41,9 @@ VERNAC COMMAND EXTEND AddRing (constr_of t) (cset_of_constrarg_list l) ] -| [ "Add" "Legacy" "Semi" "Ring" +| [ "Add" "Legacy" "Semi" "Ring" constr(a) constr(aplus) constr(amult) constr(aone) constr(azero) - constr(aeq) constr(t) "[" ne_constr_list(l) "]" ] + constr(aeq) constr(t) "[" ne_constr_list(l) "]" ] -> [ add_theory false false false (constr_of a) None @@ -58,9 +58,9 @@ VERNAC COMMAND EXTEND AddRing (constr_of t) (cset_of_constrarg_list l) ] -| [ "Add" "Legacy" "Abstract" "Ring" +| [ "Add" "Legacy" "Abstract" "Ring" constr(a) constr(aplus) constr(amult) constr(aone) - constr(azero) constr(aopp) constr(aeq) constr(t) ] + constr(azero) constr(aopp) constr(aeq) constr(t) ] -> [ add_theory true true false (constr_of a) None @@ -75,9 +75,9 @@ VERNAC COMMAND EXTEND AddRing (constr_of t) ConstrSet.empty ] -| [ "Add" "Legacy" "Abstract" "Semi" "Ring" +| [ "Add" "Legacy" "Abstract" "Semi" "Ring" constr(a) constr(aplus) constr(amult) constr(aone) - constr(azero) constr(aeq) constr(t) ] + constr(azero) constr(aeq) constr(t) ] -> [ add_theory false true false (constr_of a) None @@ -93,9 +93,9 @@ VERNAC COMMAND EXTEND AddRing ConstrSet.empty ] | [ "Add" "Legacy" "Setoid" "Ring" - constr(a) constr(aequiv) constr(asetth) constr(aplus) constr(amult) + constr(a) constr(aequiv) constr(asetth) constr(aplus) constr(amult) constr(aone) constr(azero) constr(aopp) constr(aeq) constr(pm) - constr(mm) constr(om) constr(t) "[" ne_constr_list(l) "]" ] + constr(mm) constr(om) constr(t) "[" ne_constr_list(l) "]" ] -> [ add_theory true false true (constr_of a) (Some (constr_of aequiv)) @@ -113,10 +113,10 @@ VERNAC COMMAND EXTEND AddRing (constr_of t) (cset_of_constrarg_list l) ] -| [ "Add" "Legacy" "Semi" "Setoid" "Ring" +| [ "Add" "Legacy" "Semi" "Setoid" "Ring" constr(a) constr(aequiv) constr(asetth) constr(aplus) - constr(amult) constr(aone) constr(azero) constr(aeq) - constr(pm) constr(mm) constr(t) "[" ne_constr_list(l) "]" ] + constr(amult) constr(aone) constr(azero) constr(aeq) + constr(pm) constr(mm) constr(t) "[" ne_constr_list(l) "]" ] -> [ add_theory false false true (constr_of a) (Some (constr_of aequiv)) diff --git a/plugins/ring/ring.ml b/plugins/ring/ring.ml index 2ed20b2bbe..bf3b8ef6f8 100644 --- a/plugins/ring/ring.ml +++ b/plugins/ring/ring.ml @@ -30,7 +30,7 @@ open Libobject open Closure open Tacred open Tactics -open Pattern +open Pattern open Hiddentac open Nametab open Quote @@ -96,13 +96,13 @@ let coq_SetPopp = lazy (ring_constant "SetPopp") let coq_interp_setsp = lazy (ring_constant "interp_setsp") let coq_interp_setp = lazy (ring_constant "interp_setp") let coq_interp_setcs = lazy (ring_constant "interp_setcs") -let coq_setspolynomial_simplify = +let coq_setspolynomial_simplify = lazy (ring_constant "setspolynomial_simplify") -let coq_setpolynomial_simplify = +let coq_setpolynomial_simplify = lazy (ring_constant "setpolynomial_simplify") -let coq_setspolynomial_simplify_ok = +let coq_setspolynomial_simplify_ok = lazy (ring_constant "setspolynomial_simplify_ok") -let coq_setpolynomial_simplify_ok = +let coq_setpolynomial_simplify_ok = lazy (ring_constant "setpolynomial_simplify_ok") (* Ring abstract *) @@ -123,9 +123,9 @@ let coq_interp_acs = lazy (ring_constant "interp_acs") let coq_interp_sacs = lazy (ring_constant "interp_sacs") let coq_aspolynomial_normalize = lazy (ring_constant "aspolynomial_normalize") let coq_apolynomial_normalize = lazy (ring_constant "apolynomial_normalize") -let coq_aspolynomial_normalize_ok = +let coq_aspolynomial_normalize_ok = lazy (ring_constant "aspolynomial_normalize_ok") -let coq_apolynomial_normalize_ok = +let coq_apolynomial_normalize_ok = lazy (ring_constant "apolynomial_normalize_ok") (* Logic --> to be found in Coqlib *) @@ -135,8 +135,8 @@ let mkLApp(fc,v) = mkApp(Lazy.force fc, v) (*********** Useful types and functions ************) -module OperSet = - Set.Make (struct +module OperSet = + Set.Make (struct type t = global_reference let compare = (Pervasives.compare : t->t->int) end) @@ -166,7 +166,7 @@ type theory = (* Must be empty for an abstract ring *) } -(* Theories are stored in a table which is synchronised with the Reset +(* Theories are stored in a table which is synchronised with the Reset mechanism. *) module Cmap = Map.Make(struct type t = constr let compare = compare end) @@ -177,7 +177,7 @@ let theories_map_add (c,t) = theories_map := Cmap.add c t !theories_map let theories_map_find c = Cmap.find c !theories_map let theories_map_mem c = Cmap.mem c !theories_map -let _ = +let _ = Summary.declare_summary "tactic-ring-table" { Summary.freeze_function = (fun () -> !theories_map); Summary.unfreeze_function = (fun t -> theories_map := t); @@ -188,23 +188,23 @@ let _ = between theories and environement objects. *) -let subst_morph subst morph = +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 - if plusm' == morph.plusm - && multm' == morph.multm - && oppm' == morph.oppm then + if plusm' == morph.plusm + && multm' == morph.multm + && oppm' == morph.oppm then morph else { plusm = plusm' ; multm = multm' ; oppm = oppm' ; } - -let subst_set subst cset = + +let subst_set subst cset = let same = ref true in - let copy_subst c newset = + let copy_subst c newset = let c' = subst_mps subst c in if not (c' == c) then same := false; ConstrSet.add c' newset @@ -212,21 +212,21 @@ let subst_set subst cset = let cset' = ConstrSet.fold copy_subst cset ConstrSet.empty in if !same then cset else cset' -let subst_theory subst th = +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_a' = subst_mps subst th.th_a 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_eq' = subst_mps subst th.th_eq in - let th_t' = subst_mps subst th.th_t in + let th_t' = subst_mps subst th.th_t in let th_closed' = subst_set subst th.th_closed in - if th_equiv' == th.th_equiv - && th_setoid_th' == th.th_setoid_th + if th_equiv' == th.th_equiv + && th_setoid_th' == th.th_setoid_th && th_morph' == th.th_morph && th_a' == th.th_a && th_plus' == th.th_plus @@ -236,29 +236,29 @@ let subst_theory subst th = && th_opp' == th.th_opp && th_eq' == th.th_eq && th_t' == th.th_t - && th_closed' == th.th_closed - then - th + && th_closed' == th.th_closed + then + th else - { th_ring = th.th_ring ; + { th_ring = th.th_ring ; th_abstract = th.th_abstract ; - th_setoid = th.th_setoid ; + th_setoid = th.th_setoid ; th_equiv = th_equiv' ; th_setoid_th = th_setoid_th' ; th_morph = th_morph' ; - th_a = th_a' ; + th_a = th_a' ; th_plus = th_plus' ; th_mult = th_mult' ; th_one = th_one' ; th_zero = th_zero' ; - th_opp = th_opp' ; + th_opp = th_opp' ; th_eq = th_eq' ; - th_t = th_t' ; - th_closed = th_closed' ; + th_t = th_t' ; + th_closed = th_closed' ; } -let subst_th (_,subst,(c,th as obj)) = +let subst_th (_,subst,(c,th as obj)) = let c' = subst_mps subst c in let th' = subst_theory subst th in if c' == c && th' == th then obj else @@ -280,21 +280,21 @@ let (theory_to_obj, obj_to_theory) = (* But only one theory can be declared for a given Set *) let guess_theory a = - try + try theories_map_find a - with Not_found -> - errorlabstrm "Ring" + with Not_found -> + errorlabstrm "Ring" (str "No Declared Ring Theory for " ++ pr_lconstr a ++ fnl () ++ str "Use Add [Semi] Ring to declare it") (* Looks up an option *) -let unbox = function +let unbox = function | Some w -> w | None -> anomaly "Ring : Not in case of a setoid ring." -(* Protects the convertibility test against undue exceptions when using it +(* Protects the convertibility test against undue exceptions when using it with untyped terms *) let safe_pf_conv_x gl c1 c2 = try pf_conv_x gl c1 c2 with _ -> false @@ -320,8 +320,8 @@ let states_compatibility_for env plus mult opp morphs = | Some opp, Some compat -> check opp compat | _,_ -> assert false) -let add_theory want_ring want_abstract want_setoid a aequiv asetth amorph aplus amult aone azero aopp aeq t cset = - if theories_map_mem a then errorlabstrm "Add Semi Ring" +let add_theory want_ring want_abstract want_setoid a aequiv asetth amorph aplus amult aone azero aopp aeq t cset = + if theories_map_mem a then errorlabstrm "Add Semi Ring" (str "A (Semi-)(Setoid-)Ring Structure is already declared for " ++ pr_lconstr a); let env = Global.env () in @@ -332,10 +332,10 @@ let add_theory want_ring want_abstract want_setoid a aequiv asetth amorph aplus not (implement_theory env (unbox asetth) coq_Setoid_Theory [| a; (unbox aequiv) |]) || not (states_compatibility_for env aplus amult aopp (unbox amorph)) - )) then + )) then errorlabstrm "addring" (str "Not a valid Setoid-Ring theory"); if (not want_ring & want_setoid & ( - not (implement_theory env t coq_Semi_Setoid_Ring_Theory + not (implement_theory env t coq_Semi_Setoid_Ring_Theory [| a; (unbox aequiv); aplus; amult; aone; azero; aeq|]) || not (implement_theory env (unbox asetth) coq_Setoid_Theory [| a; (unbox aequiv) |]) || @@ -348,10 +348,10 @@ let add_theory want_ring want_abstract want_setoid a aequiv asetth amorph aplus errorlabstrm "addring" (str "Not a valid Ring theory"); if (not want_ring & not want_setoid & not (implement_theory env t coq_Semi_Ring_Theory - [| a; aplus; amult; aone; azero; aeq |])) then + [| a; aplus; amult; aone; azero; aeq |])) then errorlabstrm "addring" (str "Not a valid Semi-Ring theory"); Lib.add_anonymous_leaf - (theory_to_obj + (theory_to_obj (a, { th_ring = want_ring; th_abstract = want_abstract; th_setoid = want_setoid; @@ -374,9 +374,9 @@ let add_theory want_ring want_abstract want_setoid a aequiv asetth amorph aplus gl : goal sigma th : semi-ring theory (concrete) cl : constr list [c1; c2; ...] - -Builds - - a list of tuples [(c1, c'1, c''1, c'1_eq_c''1); ... ] + +Builds + - a list of tuples [(c1, c'1, c''1, c'1_eq_c''1); ... ] where c'i is convertible with ci and c'i_eq_c''i is a proof of equality of c'i and c''i @@ -386,43 +386,43 @@ let build_spolynom gl th lc = let varhash = (Hashtbl.create 17 : (constr, constr) Hashtbl.t) in let varlist = ref ([] : constr list) in (* list of variables *) let counter = ref 1 in (* number of variables created + 1 *) - (* aux creates the spolynom p by a recursive destructuration of c + (* aux creates the spolynom p by a recursive destructuration of c and builds the varmap with side-effects *) - let rec aux c = - match (kind_of_term (strip_outer_cast c)) with + let rec aux c = + match (kind_of_term (strip_outer_cast c)) with | App (binop,[|c1; c2|]) when safe_pf_conv_x gl binop th.th_plus -> mkLApp(coq_SPplus, [|th.th_a; aux c1; aux c2 |]) | App (binop,[|c1; c2|]) when safe_pf_conv_x gl binop th.th_mult -> mkLApp(coq_SPmult, [|th.th_a; aux c1; aux c2 |]) | _ when closed_under th.th_closed c -> mkLApp(coq_SPconst, [|th.th_a; c |]) - | _ -> - try Hashtbl.find varhash c - with Not_found -> + | _ -> + try Hashtbl.find varhash c + with Not_found -> let newvar = mkLApp(coq_SPvar, [|th.th_a; (path_of_int !counter) |]) in - begin + begin incr counter; varlist := c :: !varlist; Hashtbl.add varhash c newvar; newvar end - in + in let lp = List.map aux lc in let v = btree_of_array (Array.of_list (List.rev !varlist)) th.th_a in - List.map - (fun p -> + List.map + (fun p -> (mkLApp (coq_interp_sp, [|th.th_a; th.th_plus; th.th_mult; th.th_zero; v; p |]), mkLApp (coq_interp_cs, [|th.th_a; th.th_plus; th.th_mult; th.th_one; th.th_zero; v; - pf_reduce cbv_betadeltaiota gl - (mkLApp (coq_spolynomial_simplify, - [| th.th_a; th.th_plus; th.th_mult; - th.th_one; th.th_zero; + pf_reduce cbv_betadeltaiota gl + (mkLApp (coq_spolynomial_simplify, + [| th.th_a; th.th_plus; th.th_mult; + th.th_one; th.th_zero; th.th_eq; p|])) |]), mkLApp (coq_spolynomial_simplify_ok, - [| th.th_a; th.th_plus; th.th_mult; th.th_one; th.th_zero; + [| th.th_a; th.th_plus; th.th_mult; th.th_one; th.th_zero; th.th_eq; v; th.th_t; p |]))) lp @@ -430,9 +430,9 @@ let build_spolynom gl th lc = gl : goal sigma th : ring theory (concrete) cl : constr list [c1; c2; ...] - -Builds - - a list of tuples [(c1, c'1, c''1, c'1_eq_c''1); ... ] + +Builds + - a list of tuples [(c1, c'1, c''1, c'1_eq_c''1); ... ] where c'i is convertible with ci and c'i_eq_c''i is a proof of equality of c'i and c''i @@ -442,8 +442,8 @@ let build_polynom gl th lc = let varhash = (Hashtbl.create 17 : (constr, constr) Hashtbl.t) in let varlist = ref ([] : constr list) in (* list of variables *) let counter = ref 1 in (* number of variables created + 1 *) - let rec aux c = - match (kind_of_term (strip_outer_cast c)) with + let rec aux c = + match (kind_of_term (strip_outer_cast c)) with | App (binop, [|c1; c2|]) when safe_pf_conv_x gl binop th.th_plus -> mkLApp(coq_Pplus, [|th.th_a; aux c1; aux c2 |]) | App (binop, [|c1; c2|]) when safe_pf_conv_x gl binop th.th_mult -> @@ -459,12 +459,12 @@ let build_polynom gl th lc = mkLApp(coq_Popp, [|th.th_a; aux c1|]) | _ when closed_under th.th_closed c -> mkLApp(coq_Pconst, [|th.th_a; c |]) - | _ -> - try Hashtbl.find varhash c - with Not_found -> + | _ -> + try Hashtbl.find varhash c + with Not_found -> let newvar = mkLApp(coq_Pvar, [|th.th_a; (path_of_int !counter) |]) in - begin + begin incr counter; varlist := c :: !varlist; Hashtbl.add varhash c newvar; @@ -473,20 +473,20 @@ let build_polynom gl th lc = in let lp = List.map aux lc in let v = (btree_of_array (Array.of_list (List.rev !varlist)) th.th_a) in - List.map - (fun p -> + List.map + (fun p -> (mkLApp(coq_interp_p, [| th.th_a; th.th_plus; th.th_mult; th.th_zero; (unbox th.th_opp); v; p |])), mkLApp(coq_interp_cs, [| th.th_a; th.th_plus; th.th_mult; th.th_one; th.th_zero; v; - pf_reduce cbv_betadeltaiota gl + pf_reduce cbv_betadeltaiota gl (mkLApp(coq_polynomial_simplify, - [| th.th_a; th.th_plus; th.th_mult; - th.th_one; th.th_zero; + [| th.th_a; th.th_plus; th.th_mult; + th.th_one; th.th_zero; (unbox th.th_opp); th.th_eq; p |])) |]), mkLApp(coq_polynomial_simplify_ok, - [| th.th_a; th.th_plus; th.th_mult; th.th_one; th.th_zero; + [| th.th_a; th.th_plus; th.th_mult; th.th_one; th.th_zero; (unbox th.th_opp); th.th_eq; v; th.th_t; p |])) lp @@ -494,9 +494,9 @@ let build_polynom gl th lc = gl : goal sigma th : semi-ring theory (abstract) cl : constr list [c1; c2; ...] - -Builds - - a list of tuples [(c1, c'1, c''1, c'1_eq_c''1); ... ] + +Builds + - a list of tuples [(c1, c'1, c''1, c'1_eq_c''1); ... ] where c'i is convertible with ci and c'i_eq_c''i is a proof of equality of c'i and c''i @@ -506,41 +506,41 @@ let build_aspolynom gl th lc = let varhash = (Hashtbl.create 17 : (constr, constr) Hashtbl.t) in let varlist = ref ([] : constr list) in (* list of variables *) let counter = ref 1 in (* number of variables created + 1 *) - (* aux creates the aspolynom p by a recursive destructuration of c + (* aux creates the aspolynom p by a recursive destructuration of c and builds the varmap with side-effects *) - let rec aux c = - match (kind_of_term (strip_outer_cast c)) with + let rec aux c = + match (kind_of_term (strip_outer_cast c)) with | App (binop, [|c1; c2|]) when safe_pf_conv_x gl binop th.th_plus -> mkLApp(coq_ASPplus, [| aux c1; aux c2 |]) | App (binop, [|c1; c2|]) when safe_pf_conv_x gl binop th.th_mult -> mkLApp(coq_ASPmult, [| aux c1; aux c2 |]) | _ when safe_pf_conv_x gl c th.th_zero -> Lazy.force coq_ASP0 | _ when safe_pf_conv_x gl c th.th_one -> Lazy.force coq_ASP1 - | _ -> - try Hashtbl.find varhash c - with Not_found -> + | _ -> + try Hashtbl.find varhash c + with Not_found -> let newvar = mkLApp(coq_ASPvar, [|(path_of_int !counter) |]) in - begin + begin incr counter; varlist := c :: !varlist; Hashtbl.add varhash c newvar; newvar end - in + in let lp = List.map aux lc in let v = btree_of_array (Array.of_list (List.rev !varlist)) th.th_a in - List.map - (fun p -> + List.map + (fun p -> (mkLApp(coq_interp_asp, - [| th.th_a; th.th_plus; th.th_mult; + [| th.th_a; th.th_plus; th.th_mult; th.th_one; th.th_zero; v; p |]), mkLApp(coq_interp_acs, - [| th.th_a; th.th_plus; th.th_mult; + [| th.th_a; th.th_plus; th.th_mult; th.th_one; th.th_zero; v; - pf_reduce cbv_betadeltaiota gl + pf_reduce cbv_betadeltaiota gl (mkLApp(coq_aspolynomial_normalize,[|p|])) |]), mkLApp(coq_spolynomial_simplify_ok, - [| th.th_a; th.th_plus; th.th_mult; th.th_one; th.th_zero; + [| th.th_a; th.th_plus; th.th_mult; th.th_one; th.th_zero; th.th_eq; v; th.th_t; p |]))) lp @@ -548,9 +548,9 @@ let build_aspolynom gl th lc = gl : goal sigma th : ring theory (abstract) cl : constr list [c1; c2; ...] - -Builds - - a list of tuples [(c1, c'1, c''1, c'1_eq_c''1); ... ] + +Builds + - a list of tuples [(c1, c'1, c''1, c'1_eq_c''1); ... ] where c'i is convertible with ci and c'i_eq_c''i is a proof of equality of c'i and c''i @@ -560,14 +560,14 @@ let build_apolynom gl th lc = let varhash = (Hashtbl.create 17 : (constr, constr) Hashtbl.t) in let varlist = ref ([] : constr list) in (* list of variables *) let counter = ref 1 in (* number of variables created + 1 *) - let rec aux c = - match (kind_of_term (strip_outer_cast c)) with + let rec aux c = + match (kind_of_term (strip_outer_cast c)) with | App (binop, [|c1; c2|]) when safe_pf_conv_x gl binop th.th_plus -> mkLApp(coq_APplus, [| aux c1; aux c2 |]) | App (binop, [|c1; c2|]) when safe_pf_conv_x gl binop th.th_mult -> mkLApp(coq_APmult, [| aux c1; aux c2 |]) (* The special case of Zminus *) - | App (binop, [|c1; c2|]) + | App (binop, [|c1; c2|]) when safe_pf_conv_x gl c (mkApp(th.th_plus, [|c1; mkApp(unbox th.th_opp,[|c2|]) |])) -> mkLApp(coq_APplus, @@ -576,12 +576,12 @@ let build_apolynom gl th lc = mkLApp(coq_APopp, [| aux c1 |]) | _ when safe_pf_conv_x gl c th.th_zero -> Lazy.force coq_AP0 | _ when safe_pf_conv_x gl c th.th_one -> Lazy.force coq_AP1 - | _ -> - try Hashtbl.find varhash c - with Not_found -> + | _ -> + try Hashtbl.find varhash c + with Not_found -> let newvar = mkLApp(coq_APvar, [| path_of_int !counter |]) in - begin + begin incr counter; varlist := c :: !varlist; Hashtbl.add varhash c newvar; @@ -590,28 +590,28 @@ let build_apolynom gl th lc = in let lp = List.map aux lc in let v = (btree_of_array (Array.of_list (List.rev !varlist)) th.th_a) in - List.map - (fun p -> + List.map + (fun p -> (mkLApp(coq_interp_ap, - [| th.th_a; th.th_plus; th.th_mult; th.th_one; + [| th.th_a; th.th_plus; th.th_mult; th.th_one; th.th_zero; (unbox th.th_opp); v; p |]), mkLApp(coq_interp_sacs, - [| th.th_a; th.th_plus; th.th_mult; - th.th_one; th.th_zero; (unbox th.th_opp); v; - pf_reduce cbv_betadeltaiota gl + [| th.th_a; th.th_plus; th.th_mult; + th.th_one; th.th_zero; (unbox th.th_opp); v; + pf_reduce cbv_betadeltaiota gl (mkLApp(coq_apolynomial_normalize, [|p|])) |]), mkLApp(coq_apolynomial_normalize_ok, - [| th.th_a; th.th_plus; th.th_mult; th.th_one; th.th_zero; + [| th.th_a; th.th_plus; th.th_mult; th.th_one; th.th_zero; (unbox th.th_opp); th.th_eq; v; th.th_t; p |]))) lp - + (* gl : goal sigma th : setoid ring theory (concrete) cl : constr list [c1; c2; ...] - -Builds - - a list of tuples [(c1, c'1, c''1, c'1_eq_c''1); ... ] + +Builds + - a list of tuples [(c1, c'1, c''1, c'1_eq_c''1); ... ] where c'i is convertible with ci and c'i_eq_c''i is a proof of equality of c'i and c''i @@ -621,8 +621,8 @@ let build_setpolynom gl th lc = let varhash = (Hashtbl.create 17 : (constr, constr) Hashtbl.t) in let varlist = ref ([] : constr list) in (* list of variables *) let counter = ref 1 in (* number of variables created + 1 *) - let rec aux c = - match (kind_of_term (strip_outer_cast c)) with + let rec aux c = + match (kind_of_term (strip_outer_cast c)) with | App (binop, [|c1; c2|]) when safe_pf_conv_x gl binop th.th_plus -> mkLApp(coq_SetPplus, [|th.th_a; aux c1; aux c2 |]) | App (binop, [|c1; c2|]) when safe_pf_conv_x gl binop th.th_mult -> @@ -638,12 +638,12 @@ let build_setpolynom gl th lc = mkLApp(coq_SetPopp, [| th.th_a; aux c1 |]) | _ when closed_under th.th_closed c -> mkLApp(coq_SetPconst, [| th.th_a; c |]) - | _ -> - try Hashtbl.find varhash c - with Not_found -> + | _ -> + try Hashtbl.find varhash c + with Not_found -> let newvar = mkLApp(coq_SetPvar, [| th.th_a; path_of_int !counter |]) in - begin + begin incr counter; varlist := c :: !varlist; Hashtbl.add varhash c newvar; @@ -652,17 +652,17 @@ let build_setpolynom gl th lc = in let lp = List.map aux lc in let v = (btree_of_array (Array.of_list (List.rev !varlist)) th.th_a) in - List.map - (fun p -> + List.map + (fun p -> (mkLApp(coq_interp_setp, [| th.th_a; th.th_plus; th.th_mult; th.th_zero; (unbox th.th_opp); v; p |]), mkLApp(coq_interp_setcs, [| th.th_a; th.th_plus; th.th_mult; th.th_one; th.th_zero; v; - pf_reduce cbv_betadeltaiota gl + pf_reduce cbv_betadeltaiota gl (mkLApp(coq_setpolynomial_simplify, - [| th.th_a; th.th_plus; th.th_mult; - th.th_one; th.th_zero; + [| th.th_a; th.th_plus; th.th_mult; + th.th_one; th.th_zero; (unbox th.th_opp); th.th_eq; p |])) |]), mkLApp(coq_setpolynomial_simplify_ok, [| th.th_a; (unbox th.th_equiv); th.th_plus; @@ -676,9 +676,9 @@ let build_setpolynom gl th lc = gl : goal sigma th : semi setoid ring theory (concrete) cl : constr list [c1; c2; ...] - -Builds - - a list of tuples [(c1, c'1, c''1, c'1_eq_c''1); ... ] + +Builds + - a list of tuples [(c1, c'1, c''1, c'1_eq_c''1); ... ] where c'i is convertible with ci and c'i_eq_c''i is a proof of equality of c'i and c''i @@ -688,20 +688,20 @@ let build_setspolynom gl th lc = let varhash = (Hashtbl.create 17 : (constr, constr) Hashtbl.t) in let varlist = ref ([] : constr list) in (* list of variables *) let counter = ref 1 in (* number of variables created + 1 *) - let rec aux c = - match (kind_of_term (strip_outer_cast c)) with + let rec aux c = + match (kind_of_term (strip_outer_cast c)) with | App (binop, [|c1; c2|]) when safe_pf_conv_x gl binop th.th_plus -> mkLApp(coq_SetSPplus, [|th.th_a; aux c1; aux c2 |]) | App (binop, [|c1; c2|]) when safe_pf_conv_x gl binop th.th_mult -> mkLApp(coq_SetSPmult, [| th.th_a; aux c1; aux c2 |]) | _ when closed_under th.th_closed c -> mkLApp(coq_SetSPconst, [| th.th_a; c |]) - | _ -> + | _ -> try Hashtbl.find varhash c with Not_found -> let newvar = mkLApp(coq_SetSPvar, [|th.th_a; path_of_int !counter |]) in - begin + begin incr counter; varlist := c :: !varlist; Hashtbl.add varhash c newvar; @@ -716,10 +716,10 @@ let build_setspolynom gl th lc = [| th.th_a; th.th_plus; th.th_mult; th.th_zero; v; p |]), mkLApp(coq_interp_setcs, [| th.th_a; th.th_plus; th.th_mult; th.th_one; th.th_zero; v; - pf_reduce cbv_betadeltaiota gl + pf_reduce cbv_betadeltaiota gl (mkLApp(coq_setspolynomial_simplify, - [| th.th_a; th.th_plus; th.th_mult; - th.th_one; th.th_zero; + [| th.th_a; th.th_plus; th.th_mult; + th.th_one; th.th_zero; th.th_eq; p |])) |]), mkLApp(coq_setspolynomial_simplify_ok, [| th.th_a; (unbox th.th_equiv); th.th_plus; @@ -737,12 +737,12 @@ module SectionPathSet = (* Avec l'uniformisation des red_kind, on perd ici sur la structure SectionPathSet; peut-être faudra-t-il la déplacer dans Closure *) -let constants_to_unfold = +let constants_to_unfold = (* List.fold_right SectionPathSet.add *) - let transform s = + let transform s = let sp = path_of_string s in let dir, id = repr_path sp in - Libnames.encode_con dir id + Libnames.encode_con dir id in List.map transform [ "Coq.ring.Ring_normalize.interp_cs"; @@ -772,9 +772,9 @@ let polynom_unfold_tac = let flags = (mkflags(fBETA::fIOTA::(List.map fCONST constants_to_unfold))) in reduct_in_concl (cbv_norm_flags flags,DEFAULTcast) - + let polynom_unfold_tac_in_term gl = - let flags = + let flags = (mkflags(fBETA::fIOTA::fZETA::(List.map fCONST constants_to_unfold))) in cbv_norm_flags flags (pf_env gl) (project gl) @@ -783,7 +783,7 @@ let polynom_unfold_tac_in_term gl = (* th : theory associated to t *) (* op : clause (None for conclusion or Some id for hypothesis id) *) (* gl : goal *) -(* Does the rewriting c_i -> (interp R RC v (polynomial_simplify p_i)) +(* Does the rewriting c_i -> (interp R RC v (polynomial_simplify p_i)) where the ring R, the Ring theory RC, the varmap v and the polynomials p_i are guessed and such that c_i = (interp R RC v p_i) *) let raw_polynom th op lc gl = @@ -791,7 +791,7 @@ let raw_polynom th op lc gl = after t in the list. This is to avoid that the normalization of t' modifies t in a non-desired way *) let lc = sort_subterm gl lc in - let ltriplets = + let ltriplets = if th.th_setoid then if th.th_ring then build_setpolynom gl th lc @@ -802,23 +802,23 @@ let raw_polynom th op lc gl = then build_apolynom gl th lc else build_polynom gl th lc else - if th.th_abstract + if th.th_abstract then build_aspolynom gl th lc - else build_spolynom gl th lc in - let polynom_tac = + else build_spolynom gl th lc in + let polynom_tac = List.fold_right2 (fun ci (c'i, c''i, c'i_eq_c''i) tac -> - let c'''i = - if !term_quality then polynom_unfold_tac_in_term gl c''i else c''i + let c'''i = + if !term_quality then polynom_unfold_tac_in_term gl c''i else c''i in - if !term_quality && safe_pf_conv_x gl c'''i ci then + if !term_quality && safe_pf_conv_x gl c'''i ci then tac (* convertible terms *) else if th.th_setoid then - (tclORELSE + (tclORELSE (tclORELSE (h_exact c'i_eq_c''i) - (h_exact (mkLApp(coq_seq_sym, + (h_exact (mkLApp(coq_seq_sym, [| th.th_a; (unbox th.th_equiv); (unbox th.th_setoid_th); c'''i; ci; c'i_eq_c''i |])))) @@ -826,7 +826,7 @@ let raw_polynom th op lc gl = (tclORELSE (Equality.general_rewrite true Termops.all_occurrences c'i_eq_c''i) - (Equality.general_rewrite false + (Equality.general_rewrite false Termops.all_occurrences c'i_eq_c''i)) [tac])) else @@ -835,13 +835,13 @@ let raw_polynom th op lc gl = (h_exact c'i_eq_c''i) (h_exact (mkApp(build_coq_eq_sym (), [|th.th_a; c'''i; ci; c'i_eq_c''i |])))) - (tclTHENS - (elim_type + (tclTHENS + (elim_type (mkApp(build_coq_eq (), [|th.th_a; c'''i; ci |]))) [ tac; h_exact c'i_eq_c''i ])) ) - lc ltriplets polynom_unfold_tac + lc ltriplets polynom_unfold_tac in polynom_tac gl @@ -864,19 +864,19 @@ let guess_eq_tac th = th.th_plus |]))) reflexivity))))) -let guess_equiv_tac th = +let guess_equiv_tac th = (tclORELSE (apply (mkLApp(coq_seq_refl, [| th.th_a; (unbox th.th_equiv); (unbox th.th_setoid_th)|]))) - (tclTHEN + (tclTHEN polynom_unfold_tac - (tclREPEAT - (tclORELSE + (tclREPEAT + (tclORELSE (apply (unbox th.th_morph).plusm) (apply (unbox th.th_morph).multm))))) let match_with_equiv c = match (kind_of_term c) with - | App (e,a) -> + | App (e,a) -> if (List.mem e []) (* (Setoid_replace.equiv_list ())) *) then Some (decompose_app c) else None @@ -884,18 +884,18 @@ let match_with_equiv c = match (kind_of_term c) with let polynom lc gl = Coqlib.check_required_library ["Coq";"ring";"LegacyRing"]; - match lc with + match lc with (* If no argument is given, try to recognize either an equality or - a declared relation with arguments c1 ... cn, + a declared relation with arguments c1 ... cn, do "Ring c1 c2 ... cn" and then try to apply the simplification theorems declared for the relation *) | [] -> - (try + (try match Hipattern.match_with_equation (pf_concl gl) with | _,_,Hipattern.PolymorphicLeibnizEq (t,c1,c2) -> let th = guess_theory t in (tclTHEN (raw_polynom th None [c1;c2]) (guess_eq_tac th)) gl - | _,_,Hipattern.HeterogenousEq (t1,c1,t2,c2) + | _,_,Hipattern.HeterogenousEq (t1,c1,t2,c2) when safe_pf_conv_x gl t1 t2 -> let th = guess_theory t1 in (tclTHEN (raw_polynom th None [c1;c2]) (guess_eq_tac th)) gl @@ -905,22 +905,22 @@ let polynom lc gl = | Some (equiv, c1::args) -> let t = (pf_type_of gl c1) in let th = (guess_theory t) in - if List.exists + if List.exists (fun c2 -> not (safe_pf_conv_x gl t (pf_type_of gl c2))) args - then + then errorlabstrm "Ring :" (str" All terms must have the same type"); - (tclTHEN (raw_polynom th None (c1::args)) (guess_equiv_tac th)) gl - | _ -> errorlabstrm "polynom :" + (tclTHEN (raw_polynom th None (c1::args)) (guess_equiv_tac th)) gl + | _ -> errorlabstrm "polynom :" (str" This goal is not an equality nor a setoid equivalence"))) (* Elsewhere, guess the theory, check that all terms have the same type and apply raw_polynom *) - | c :: lc' -> - let t = pf_type_of gl c in - let th = guess_theory t in - if List.exists + | c :: lc' -> + let t = pf_type_of gl c in + let th = guess_theory t in + if List.exists (fun c1 -> not (safe_pf_conv_x gl t (pf_type_of gl c1))) lc' - then + then errorlabstrm "Ring :" (str" All terms must have the same type"); (tclTHEN (raw_polynom th None lc) polynom_unfold_tac) gl diff --git a/plugins/romega/ReflOmegaCore.v b/plugins/romega/ReflOmegaCore.v index 12176d661d..a97f43d087 100644 --- a/plugins/romega/ReflOmegaCore.v +++ b/plugins/romega/ReflOmegaCore.v @@ -12,19 +12,19 @@ Delimit Scope Int_scope with I. (* Abstract Integers. *) -Module Type Int. +Module Type Int. - Parameter int : Set. + Parameter int : Set. - Parameter zero : int. - Parameter one : int. - Parameter plus : int -> int -> int. + Parameter zero : int. + Parameter one : int. + Parameter plus : int -> int -> int. Parameter opp : int -> int. - Parameter minus : int -> int -> int. + Parameter minus : int -> int -> int. Parameter mult : int -> int -> int. Notation "0" := zero : Int_scope. - Notation "1" := one : Int_scope. + Notation "1" := one : Int_scope. Infix "+" := plus : Int_scope. Infix "-" := minus : Int_scope. Infix "*" := mult : Int_scope. @@ -57,17 +57,17 @@ Module Type Int. 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 : + 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*) + (* 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 + (* 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). @@ -83,9 +83,9 @@ Module Z_as_Int <: Int. Open Scope Z_scope. - Definition int := Z. - Definition zero := 0. - Definition one := 1. + Definition int := Z. + Definition zero := 0. + Definition one := 1. Definition plus := Zplus. Definition opp := Zopp. Definition minus := Zminus. @@ -154,32 +154,32 @@ Module Z_as_Int <: Int. apply Zlt_succ. Qed. -End Z_as_Int. +End Z_as_Int. -Module IntProperties (I:Int). +Module IntProperties (I:Int). Import I. - + (* Primo, some consequences of being a ring theory... *) - + Definition two := 1+1. - Notation "2" := two : Int_scope. + 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_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 + 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 *) @@ -188,7 +188,7 @@ Module IntProperties (I:Int). 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. + 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. @@ -197,14 +197,14 @@ Module IntProperties (I:Int). 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. + 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. + now rewrite plus_permute, plus_assoc, H, <- plus_assoc, plus_permute. Qed. - (* More facts about mult *) - + (* 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. @@ -216,7 +216,7 @@ Module IntProperties (I:Int). Qed. Lemma mult_0_l : forall x, 0*x = 0. - Proof. + Proof. intros. generalize (mult_plus_distr_r 0 1 x). rewrite plus_0_l, mult_1_l, plus_comm; intros. @@ -224,7 +224,7 @@ Module IntProperties (I:Int). rewrite <- H. apply plus_0_r_reverse. Qed. - + (* More facts about opp *) @@ -269,7 +269,7 @@ Module IntProperties (I:Int). 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. + Qed. Lemma egal_left : forall n m, n=m -> n+-m = 0. Proof. intros; subst; apply opp_def. Qed. @@ -287,7 +287,7 @@ Module IntProperties (I:Int). Proof. symmetry; rewrite mult_comm; apply mult_1_l. Qed. Lemma red_factor1 : forall n, n+n = n*2. - Proof. + Proof. intros; unfold two. now rewrite mult_comm, mult_plus_distr_r, mult_1_l. Qed. @@ -302,10 +302,10 @@ Module IntProperties (I:Int). Proof. intros; now rewrite plus_comm, red_factor2. Qed. Lemma red_factor4 : forall n m p, n*m + n*p = n*(m+p). - Proof. + 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. @@ -368,7 +368,7 @@ Module IntProperties (I:Int). Qed. - (* Secondo, some results about order (and equality) *) + (* Secondo, some results about order (and equality) *) Lemma lt_irrefl : forall n, ~ n<n. Proof. @@ -440,7 +440,7 @@ Module IntProperties (I:Int). 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. @@ -471,7 +471,7 @@ Module IntProperties (I:Int). Proof. intros; now rewrite <- bgt_iff. Qed. Lemma bgt_false : forall i j, bgt i j = false -> i<=j. - Proof. + Proof. intros. rewrite le_lt_iff, <-gt_lt_iff, <-bgt_iff; intro H'; now rewrite H' in H. Qed. @@ -498,7 +498,7 @@ Module IntProperties (I:Int). 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. @@ -582,7 +582,7 @@ Module IntProperties (I:Int). 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 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. @@ -611,7 +611,7 @@ Module IntProperties (I:Int). exact (lt_irrefl 0). Qed. - Lemma mult_le_compat : + Lemma mult_le_compat : forall i j k l, i<=j -> k<=l -> 0<=i -> 0<=k -> i*k<=j*l. Proof. intros. @@ -624,9 +624,9 @@ Module IntProperties (I:Int). generalize (le_trans _ _ _ H2 H0); clear H0 H1 H2; intros. rewrite (mult_comm i), (mult_comm j). - destruct (le_is_lt_or_eq _ _ H0); + destruct (le_is_lt_or_eq _ _ H0); [ | subst; do 2 rewrite mult_0_l; apply le_refl]. - destruct (le_is_lt_or_eq _ _ H); + destruct (le_is_lt_or_eq _ _ H); [ | subst; apply le_refl]. apply lt_le_weak. apply mult_lt_compat_l; auto. @@ -634,9 +634,9 @@ Module IntProperties (I:Int). subst i. rewrite mult_0_l. generalize (le_trans _ _ _ H2 H0); clear H0 H1 H2; intros. - destruct (le_is_lt_or_eq _ _ H); + destruct (le_is_lt_or_eq _ _ H); [ | subst; rewrite mult_0_l; apply le_refl]. - destruct (le_is_lt_or_eq _ _ H0); + 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. @@ -766,7 +766,7 @@ Module IntProperties (I:Int). apply plus_lt_compat; auto. apply mult_lt_0_compat; auto. apply lt_trans with x; auto. - Qed. + Qed. Lemma OMEGA19 : forall x, x<>0 -> 0 <= x + -(1) \/ 0 <= x * -(1) + -(1). Proof. @@ -781,7 +781,7 @@ Module IntProperties (I:Int). apply opp_lt_compat; auto. Qed. - Lemma mult_le_approx : + Lemma mult_le_approx : forall n m p, n > 0 -> n > p -> 0 <= m * n + p -> 0 <= m. Proof. intros n m p. @@ -850,7 +850,7 @@ Module IntOmega (I:Int). Import I. Module IP:=IntProperties(I). Import IP. - + (* \subsubsection{Definition of reified integer expressions} Terms are either: \begin{itemize} @@ -903,7 +903,7 @@ Inductive proposition : Set := | Tprop : nat -> proposition. (* Definition of goals as a list of hypothesis *) -Notation hyps := (list proposition). +Notation hyps := (list proposition). (* Definition of lists of subgoals (set of open goals) *) Notation lhyps := (list hyps). @@ -930,7 +930,7 @@ Inductive t_fusion : Set := | F_right : t_fusion. (* \subsubsection{Rewriting steps to normalize terms} *) -Inductive step : Set := +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 *) @@ -938,9 +938,9 @@ Inductive step : Set := (* apply the rewriting step to the second branch *) | C_RIGHT : step -> step (* apply two steps consecutively to a term *) - | C_SEQ : step -> step -> step + | C_SEQ : step -> step -> step (* empty step *) - | C_NOP : step + | C_NOP : step (* the following operations correspond to actual rewriting *) | C_OPP_PLUS : step | C_OPP_OPP : step @@ -990,8 +990,8 @@ Inductive t_omega : Set := | 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. +(* 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. *) Inductive p_step : Set := @@ -1001,19 +1001,19 @@ Inductive p_step : Set := | P_STEP : step -> p_step | P_NOP : p_step. -(* 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), +(* 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{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 +(* 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 := @@ -1022,8 +1022,8 @@ Inductive direction : Set := | D_mono : direction. (* 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 + 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 := @@ -1032,10 +1032,10 @@ Inductive e_step : Set := | E_SOLVE : t_omega -> e_step. (* \subsection{Efficient decidable equality} *) -(* For each reified data-type, we define an efficient equality test. +(* For each reified data-type, we define an efficient equality test. It is not the one produced by [Decide Equality]. - - Then we prove two theorem allowing to eliminate such equalities : + + 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. @@ -1056,21 +1056,21 @@ Fixpoint eq_term (t1 t2 : term) {struct t2} : bool := | _, _ => false end. -Close Scope romega_scope. +Close Scope romega_scope. Theorem eq_term_true : forall t1 t2 : term, eq_term t1 t2 = true -> t1 = t2. Proof. simple induction t1; intros until t2; case t2; simpl in *; - try (intros; discriminate; fail); + 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); + elim H with (1 := H4); elim H0 with (1 := H5); trivial | intros t21 t22 H3; elim andb_prop with (1 := H3); intros H4 H5; - elim H with (1 := H4); elim H0 with (1 := H5); + elim H with (1 := H4); elim H0 with (1 := H5); trivial | intros t21 t22 H3; elim andb_prop with (1 := H3); intros H4 H5; - elim H with (1 := H4); elim H0 with (1 := H5); + elim H with (1 := H4); elim H0 with (1 := H5); trivial | intros t21 H3; elim H with (1 := H3); trivial | intros; elim beq_nat_true with (1 := H); trivial ]. @@ -1083,7 +1083,7 @@ Theorem eq_term_false : Proof. simple induction t1; [ intros z t2; case t2; try trivial_case; simpl in |- *; unfold not in |- *; - intros; elim beq_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; @@ -1101,21 +1101,21 @@ Proof. [ elim H1 with (1 := H5); simplify_eq H4; auto | elim H2 with (1 := H5); simplify_eq H4; auto ] | intros t11 H1 t2; case t2; try trivial_case; simpl in |- *; intros t21 H3; - unfold not in |- *; intro H4; elim H1 with (1 := H3); + 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 beq_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} +(* \subsubsection{Tactiques pour éliminer ces tests} - Si on se contente de faire un [Case (eq_typ t1 t2)] on perd + Si on se contente de faire un [Case (eq_typ t1 t2)] on perd totalement dans chaque branche le fait que [t1=t2] ou [~t1=t2]. Initialement, les développements avaient été réalisés avec les tests rendus par [Decide Equality], c'est à dire un test rendant - des termes du type [{t1=t2}+{~t1=t2}]. Faire une élimination sur un + des termes du type [{t1=t2}+{~t1=t2}]. Faire une élimination sur un tel test préserve bien l'information voulue mais calculatoirement de telles fonctions sont trop lentes. *) @@ -1132,8 +1132,8 @@ Ltac elim_beq t1 t2 := [ generalize (beq_true t1 t2 Aux); clear Aux | generalize (beq_false t1 t2 Aux); clear Aux ]. -Ltac elim_bgt t1 t2 := - pattern (bgt t1 t2) in |- *; apply bool_eq_ind; intro Aux; +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 ]. @@ -1151,7 +1151,7 @@ Fixpoint interp_term (env : list int) (t : term) {struct t} : int := | [n]%term => nth n env 0 end. -(* \subsubsection{Interprétation des prédicats} *) +(* \subsubsection{Interprétation des prédicats} *) Fixpoint interp_proposition (envp : list Prop) (env : list int) (p : proposition) {struct p} : Prop := @@ -1179,7 +1179,7 @@ Fixpoint interp_proposition (envp : list Prop) (env : list int) Interprétation sous forme d'une conjonction d'hypothèses plus faciles à manipuler individuellement *) -Fixpoint interp_hyps (envp : list Prop) (env : list int) +Fixpoint interp_hyps (envp : list Prop) (env : list int) (l : hyps) {struct l} : Prop := match l with | nil => True @@ -1191,7 +1191,7 @@ Fixpoint interp_hyps (envp : list Prop) (env : list int) [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 : list 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 @@ -1219,7 +1219,7 @@ Theorem hyps_to_goal : Proof. simple induction l; simpl in |- *; [ auto | intros; apply H; elim H1; auto ]. Qed. - + (* \subsection{Manipulations sur les hypothèses} *) (* \subsubsection{Définitions de base de stabilité pour la réflexion} *) @@ -1228,7 +1228,7 @@ Definition term_stable (f : term -> term) := 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 + résultat de l'opération. \emph{Attention : cela ne concerne que des opérations sur les hypothèses et non sur les buts (contravariance)}. On définit la validité pour une opération prenant une ou deux propositions en argument (cela suffit pour omega). *) @@ -1242,15 +1242,15 @@ Definition valid2 (f : proposition -> proposition -> proposition) := interp_proposition ep e p1 -> interp_proposition ep e p2 -> interp_proposition ep e (f p1 p2). -(* Dans cette notion de validité, la fonction prend directement une - liste de propositions et rend une nouvelle liste de proposition. +(* Dans cette notion de validité, la fonction prend directement une + liste de propositions et rend une nouvelle liste de proposition. On reste contravariant *) Definition valid_hyps (f : hyps -> 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 +(* Enfin ce théorème élimine la contravariance et nous ramène à une opération sur les buts *) Theorem valid_goal : @@ -1264,14 +1264,14 @@ Qed. (* \subsubsection{Généralisation a des listes de buts (disjonctions)} *) -Fixpoint interp_list_hyps (envp : list Prop) (env : list int) +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 : list Prop) (env : list int) +Fixpoint interp_list_goal (envp : list Prop) (env : list int) (l : lhyps) {struct l} : Prop := match l with | nil => True @@ -1311,10 +1311,10 @@ Theorem goal_valid : forall f : hyps -> lhyps, valid_list_hyps f -> valid_list_goal f. 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); + intro H2; apply list_hyps_to_goal with (1 := H1); apply (H ep e lp); assumption. Qed. - + Theorem append_valid : forall (ep : list Prop) (e : list int) (l1 l2 : lhyps), interp_list_hyps ep e l1 \/ interp_list_hyps ep e l2 -> @@ -1345,7 +1345,7 @@ Proof. | intros; simpl in |- *; apply H; elim H1; auto ] ]. Qed. -(* Appliquer une opération (valide) sur deux hypothèses extraites de +(* Appliquer une opération (valide) sur deux hypothèses extraites de la liste et ajouter le résultat à la liste. *) Definition apply_oper_2 (i j : nat) (f : proposition -> proposition -> proposition) (l : hyps) := @@ -1361,7 +1361,7 @@ Qed. (* Modifier une hypothèse par application d'une opération valide *) -Fixpoint apply_oper_1 (i : nat) (f : proposition -> proposition) +Fixpoint apply_oper_1 (i : nat) (f : proposition -> proposition) (l : hyps) {struct i} : hyps := match l with | nil => nil (A:=proposition) @@ -1390,7 +1390,7 @@ Qed. (* \subsubsection{Manipulations de termes} *) (* Les fonctions suivantes permettent d'appliquer une fonction de réécriture sur un sous terme du terme principal. Avec la composition, - cela permet de construire des réécritures complexes proches des + cela permet de construire des réécritures complexes proches des tactiques de conversion *) Definition apply_left (f : term -> term) (t : term) := @@ -1415,7 +1415,7 @@ Definition apply_both (f g : term -> term) (t : term) := | x => x end. -(* Les théorèmes suivants montrent la stabilité (conditionnée) des +(* Les théorèmes suivants montrent la stabilité (conditionnée) des fonctions. *) Theorem apply_left_stable : @@ -1448,21 +1448,21 @@ Proof. Qed. (* \subsection{Les règles de réécriture} *) -(* Chacune des règles de réécriture est accompagnée par sa preuve de - stabilité. Toutes ces preuves ont la même forme : il faut analyser +(* Chacune des règles de réécriture est accompagnée par sa preuve de + stabilité. Toutes ces preuves ont la même forme : il faut analyser suivant la forme du terme (élimination de chaque Case). On a besoin d'une - élimination uniquement dans les cas d'utilisation d'égalité décidable. + élimination uniquement dans les cas d'utilisation d'égalité décidable. Cette tactique itère la décomposition des Case. Elle est constituée de deux fonctions s'appelant mutuellement : - \begin{itemize} + \begin{itemize} \item une fonction d'enrobage qui lance la recherche sur le but, \item une fonction récursive qui décompose ce but. Quand elle a trouvé un - Case, elle l'élimine. - \end{itemize} + Case, elle l'élimine. + \end{itemize} Les motifs sur les cas sont très imparfaits et dans certains cas, il semble que cela ne marche pas. On aimerait plutot un motif de la - forme [ Case (?1 :: T) of _ end ] permettant de s'assurer que l'on + forme [ Case (?1 :: T) of _ end ] permettant de s'assurer que l'on utilise le bon type. Chaque élimination introduit correctement exactement le nombre d'hypothèses @@ -1520,15 +1520,15 @@ Ltac loop t := | [x]%term => _ end => destruct X1; auto; Simplify | (if beq ?X1 ?X2 then _ else _) => - let H := fresh "H" in + 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 + let H := fresh "H" in elim_bgt X1 X2; intro H; simpl in |- *; auto; Simplify | (if eq_term ?X1 ?X2 then _ else _) => - let H := fresh "H" in - elim_eq_term X1 X2; intro H; try (rewrite H in *; 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 @@ -1617,7 +1617,7 @@ Qed. Definition T_OMEGA10 (t : term) := match t with | ((v * Tint c1 + l1) * Tint k1 + (v' * Tint c2 + l2) * Tint k2)%term => - if eq_term v v' + if eq_term v v' then (v * Tint (c1 * k1 + c2 * k2)%I + (l1 * Tint k1 + l2 * Tint k2))%term else t | _ => t @@ -1650,12 +1650,12 @@ Definition T_OMEGA12 (t : term) := Theorem T_OMEGA12_stable : term_stable T_OMEGA12. Proof. prove_stable T_OMEGA12 OMEGA12. -Qed. +Qed. Definition T_OMEGA13 (t : term) := match t with | (v * Tint x + l1 + (v' * Tint x' + l2))%term => - if eq_term v v' && beq x (-x') + if eq_term v v' && beq x (-x') then (l1+l2)%term else t | _ => t @@ -1670,7 +1670,7 @@ Qed. Definition T_OMEGA15 (t : term) := match t with | (v * Tint c1 + l1 + (v' * Tint c2 + l2) * Tint k2)%term => - if eq_term v v' + if eq_term v v' then (v * Tint (c1 + c2 * k2)%I + (l1 + l2 * Tint k2))%term else t | _ => t @@ -1792,9 +1792,9 @@ Qed. Definition Tred_factor1 (t : term) := match t with | (x + y)%term => - if eq_term x y + if eq_term x y then (x * Tint 2)%term - else t + else t | _ => t end. @@ -1806,7 +1806,7 @@ Qed. Definition Tred_factor2 (t : term) := match t with | (x + y * Tint k)%term => - if eq_term x y + if eq_term x y then (x * Tint (1 + k))%term else t | _ => t @@ -1820,7 +1820,7 @@ Qed. Definition Tred_factor3 (t : term) := match t with | (x * Tint k + y)%term => - if eq_term x y + if eq_term x y then (x * Tint (1 + k))%term else t | _ => t @@ -1835,7 +1835,7 @@ Qed. Definition Tred_factor4 (t : term) := match t with | (x * Tint k1 + y * Tint k2)%term => - if eq_term x y + if eq_term x y then (x * Tint (k1 + k2))%term else t | _ => t @@ -1919,13 +1919,13 @@ Proof. | intros; auto | intros; auto | intros; auto - | intros; auto ])); intros t0 H0; simpl in |- *; + | intros; auto ])); intros t0 H0; simpl in |- *; rewrite H0; case (reduce t0); intros; auto. Qed. (* \subsubsection{Fusions} \paragraph{Fusion de deux équations} *) -(* On donne une somme de deux équations qui sont supposées normalisées. +(* On donne une somme de deux équations qui sont supposées normalisées. Cette fonction prend une trace de fusion en argument et transforme le terme en une équation normalisée. C'est une version très simplifiée du moteur de réécriture [rewrite]. *) @@ -1941,7 +1941,7 @@ Fixpoint fusion (trace : list t_fusion) (t : term) {struct trace} : term := | F_right => apply_right (fusion trace') (T_OMEGA12 t) end end. - + Theorem fusion_stable : forall t : list t_fusion, term_stable (fusion t). Proof. simple induction t; simpl in |- *; @@ -1985,7 +1985,7 @@ 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. +Qed. (* \subsubsection{Opérations affines sur une équation} *) (* \paragraph{Multiplication scalaire et somme d'une constante} *) @@ -2004,7 +2004,7 @@ Proof. | intros n H e t; elim apply_right_stable; [ exact (T_OMEGA11_stable e t) | exact H ] ]. Qed. - + (* \paragraph{Multiplication scalaire} *) Fixpoint scalar_norm (trace : nat) (t : term) {struct trace} : term := match trace with @@ -2101,8 +2101,8 @@ Proof. | exact Tmult_comm_stable ]. Qed. -(* \subsection{tactiques de résolution d'un but omega normalisé} - Trace de la procédure +(* \subsection{tactiques de résolution d'un but omega normalisé} + Trace de la procédure \subsubsection{Tactiques générant une contradiction} \paragraph{[O_CONSTANT_NOT_NUL]} *) @@ -2117,17 +2117,17 @@ Theorem constant_not_nul_valid : forall i : nat, valid_hyps (constant_not_nul i). 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; + 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. +Qed. (* \paragraph{[O_CONSTANT_NEG]} *) Definition constant_neg (i : nat) (h : hyps) := match nth_hyps i h with - | LeqTerm (Tint Nul) (Tint Neg) => + | LeqTerm (Tint Nul) (Tint Neg) => if bgt Nul Neg then absurd else h | _ => h end. @@ -2140,14 +2140,14 @@ Proof. Qed. (* \paragraph{[NOT_EXACT_DIVIDE]} *) -Definition not_exact_divide (k1 k2 : int) (body : term) +Definition not_exact_divide (k1 k2 : int) (body : term) (t i : nat) (l : hyps) := match nth_hyps i l with | 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 + 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 @@ -2161,7 +2161,7 @@ Proof. 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); + absurd (interp_term e body * k1 + k2 = 0); [ now apply OMEGA4 | symmetry; auto ]. Qed. @@ -2173,8 +2173,8 @@ Definition contradiction (t i j : nat) (l : hyps) := match nth_hyps j l with | LeqTerm (Tint Nul') b2 => match fusion_cancel t (b1 + b2)%term with - | Tint k => if beq Nul 0 && beq Nul' 0 && bgt 0 k - then absurd + | Tint k => if beq Nul 0 && beq Nul' 0 && bgt 0 k + then absurd else l | _ => l end @@ -2188,16 +2188,16 @@ Theorem contradiction_valid : 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; case (nth_hyps j l); - auto; intros t3 t4; case t3; auto; + case (nth_hyps i l); auto; intros t1 t2; case t1; + 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 |- *; + case (fusion_cancel t (t2 + t4)%term); simpl in |- *; auto; intro k; elim (fusion_cancel_stable t); simpl in |- *. Simplify; intro H3. - generalize (OMEGA2 _ _ H2 H1); rewrite H3. + generalize (OMEGA2 _ _ H2 H1); rewrite H3. rewrite gt_lt_iff in H0; rewrite le_lt_iff; intuition. Qed. @@ -2208,17 +2208,17 @@ Definition negate_contradict (i1 i2 : nat) (h : hyps) := | EqTerm (Tint Nul) b1 => match nth_hyps i2 h with | NeqTerm (Tint Nul') b2 => - if beq Nul 0 && beq Nul' 0 && eq_term b1 b2 - then absurd + if beq Nul 0 && beq Nul' 0 && eq_term b1 b2 + then absurd else h | _ => h end | NeqTerm (Tint Nul) b1 => match nth_hyps i2 h with | EqTerm (Tint Nul') b2 => - if beq Nul 0 && beq Nul' 0 && eq_term b1 b2 - then absurd - else h + if beq Nul 0 && beq Nul' 0 && eq_term b1 b2 + then absurd + else h | _ => h end | _ => h @@ -2229,7 +2229,7 @@ Definition negate_contradict_inv (t i1 i2 : nat) (h : hyps) := | EqTerm (Tint Nul) b1 => match nth_hyps i2 h with | NeqTerm (Tint Nul') b2 => - if beq Nul 0 && beq Nul' 0 && + if beq Nul 0 && beq Nul' 0 && eq_term b1 (scalar_norm t (b2 * Tint (-(1)))%term) then absurd else h @@ -2238,7 +2238,7 @@ Definition negate_contradict_inv (t i1 i2 : nat) (h : hyps) := | NeqTerm (Tint Nul) b1 => match nth_hyps i2 h with | EqTerm (Tint Nul') b2 => - if beq Nul 0 && beq Nul' 0 && + if beq Nul 0 && beq Nul' 0 && eq_term b1 (scalar_norm t (b2 * Tint (-(1)))%term) then absurd else h @@ -2252,9 +2252,9 @@ Theorem negate_contradict_valid : 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; auto; case (nth_hyps j l); - auto; intros t3 t4; case t3; auto; intros z'; + case (nth_hyps i l); auto; intros t1 t2; case t1; + 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. @@ -2263,15 +2263,15 @@ Theorem negate_contradict_inv_valid : 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; auto; case (nth_hyps j l); - auto; intros t3 t4; case t3; auto; intros z'; - auto; simpl in |- *; intros H1 H2; Simplify; + case (nth_hyps i l); auto; intros t1 t2; case t1; + 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 @@ -2282,7 +2282,7 @@ Qed. (* \paragraph{[O_SUM]} C'est une oper2 valide mais elle traite plusieurs cas à la fois (suivant les opérateurs de comparaison des deux arguments) d'où une - preuve un peu compliquée. On utilise quelques lemmes qui sont des + 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 : int) (trace : list t_fusion) @@ -2291,11 +2291,11 @@ Definition sum (k1 k2 : int) (trace : list t_fusion) | EqTerm (Tint Null) b1 => match prop2 with | EqTerm (Tint Null') b2 => - if beq Null 0 && beq Null' 0 + 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 + if beq Null 0 && beq Null' 0 && bgt k2 0 then LeqTerm (Tint 0) (fusion trace (b1 * Tint k1 + b2 * Tint k2)%term) else TrueTerm @@ -2305,18 +2305,18 @@ Definition sum (k1 k2 : int) (trace : list t_fusion) if beq Null 0 && bgt k1 0 then match prop2 with | EqTerm (Tint Null') b2 => - if beq Null' 0 then + if beq Null' 0 then LeqTerm (Tint 0) (fusion trace (b1 * Tint k1 + b2 * Tint k2)%term) - else TrueTerm + else TrueTerm | LeqTerm (Tint Null') b2 => - if beq Null' 0 && bgt k2 0 + if beq Null' 0 && bgt k2 0 then LeqTerm (Tint 0) (fusion trace (b1 * Tint k1 + b2 * Tint k2)%term) else TrueTerm | _ => TrueTerm end - else TrueTerm + else TrueTerm | NeqTerm (Tint Null) b1 => match prop2 with | EqTerm (Tint Null') b2 => @@ -2334,7 +2334,7 @@ Theorem sum_valid : 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); + Simplify; simpl in |- *; auto; try elim (fusion_stable t); simpl in |- *; intros; [ apply sum1; assumption | apply sum2; try assumption; apply sum4; assumption @@ -2350,13 +2350,13 @@ Definition exact_divide (k : int) (body : term) (t : nat) (prop : proposition) := match prop with | EqTerm (Tint Null) b => - if beq Null 0 && - eq_term (scalar_norm t (body * Tint k)%term) b && - negb (beq k 0) + 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 && + if beq Null 0 && eq_term (scalar_norm t (body * Tint k)%term) b && negb (beq k 0) then NeqTerm (Tint 0) body @@ -2367,8 +2367,8 @@ Definition exact_divide (k : int) (body : term) (t : nat) Theorem exact_divide_valid : 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; + 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 @@ -2380,15 +2380,15 @@ 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 : int) (body : term) +Definition divide_and_approx (k1 k2 : int) (body : term) (t : nat) (prop : proposition) := match prop with | LeqTerm (Tint Null) b => - if beq Null 0 && + 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 + bgt k1 0 && + bgt k1 k2 + then LeqTerm (Tint 0) body else prop | _ => prop end. @@ -2411,7 +2411,7 @@ Definition merge_eq (t : nat) (prop1 prop2 : proposition) := match prop2 with | LeqTerm (Tint Null') b2 => if beq Null 0 && beq Null' 0 && - eq_term b1 (scalar_norm t (b2 * Tint (-(1)))%term) + eq_term b1 (scalar_norm t (b2 * Tint (-(1)))%term) then EqTerm (Tint 0) b1 else TrueTerm | _ => TrueTerm @@ -2422,7 +2422,7 @@ Definition merge_eq (t : nat) (prop1 prop2 : proposition) := Theorem merge_eq_valid : forall n : nat, valid2 (merge_eq n). Proof. unfold valid2, merge_eq in |- *; intros n ep e p1 p2; Simplify; simpl in |- *; - auto; elim (scalar_norm_stable n e); simpl in |- *; + auto; elim (scalar_norm_stable n e); simpl in |- *; intros; symmetry in |- *; apply OMEGA8 with (2 := H0); [ assumption | elim opp_eq_mult_neg_1; trivial ]. Qed. @@ -2433,8 +2433,8 @@ Qed. Definition constant_nul (i : nat) (h : hyps) := match nth_hyps i h with - | NeqTerm (Tint Null) (Tint Null') => - if beq Null Null' then absurd else h + | NeqTerm (Tint Null) (Tint Null') => + if beq Null Null' then absurd else h | _ => h end. @@ -2452,7 +2452,7 @@ Definition state (m : int) (s : step) (prop1 prop2 : proposition) := | EqTerm (Tint Null) b1 => match prop2 with | EqTerm b2 b3 => - if beq Null 0 + if beq Null 0 then EqTerm (Tint 0) (rewrite s (b1 + (- b3 + b2) * Tint m)%term) else TrueTerm | _ => TrueTerm @@ -2463,20 +2463,20 @@ Definition state (m : int) (s : step) (prop1 prop2 : proposition) := 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 |- *; + simpl in |- *; auto; elim (rewrite_stable s e); simpl in |- *; intros H1 H2; elim H1. now rewrite H2, plus_opp_l, plus_0_l, mult_0_l. Qed. (* \subsubsection{Tactiques générant plusieurs but} - \paragraph{[O_SPLIT_INEQ]} + \paragraph{[O_SPLIT_INEQ]} La seule pour le moment (tant que la normalisation n'est pas réfléchie). *) -Definition split_ineq (i t : nat) (f1 f2 : hyps -> lhyps) +Definition split_ineq (i t : nat) (f1 f2 : hyps -> lhyps) (l : hyps) := match nth_hyps i l with | NeqTerm (Tint Null) b1 => - if beq Null 0 then + if beq Null 0 then f1 (LeqTerm (Tint 0) (add_norm t (b1 + Tint (-(1)))%term) :: l) ++ f2 (LeqTerm (Tint 0) @@ -2491,8 +2491,8 @@ Theorem split_ineq_valid : valid_list_hyps f2 -> valid_list_hyps (split_ineq i t f1 f2). 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 |- *; + generalize (nth_valid _ _ i _ H); case (nth_hyps i lp); + simpl in |- *; auto; intros t1 t2; case t1; simpl in |- *; auto; intros z; simpl in |- *; auto; intro H3. Simplify. apply append_valid; elim (OMEGA19 (interp_term e t2)); @@ -2580,7 +2580,7 @@ Proof. Qed. -(* \subsection{Les opérations globales sur le but} +(* \subsection{Les opérations globales sur le but} \subsubsection{Normalisation} *) Definition move_right (s : step) (p : proposition) := @@ -2615,7 +2615,7 @@ Proof. apply move_right_valid. Qed. -Fixpoint do_normalize_list (l : list step) (i : nat) +Fixpoint do_normalize_list (l : list step) (i : nat) (h : hyps) {struct l} : hyps := match l with | s :: l' => do_normalize_list l' (S i) (do_normalize i s h) @@ -2659,7 +2659,7 @@ Proof. Qed. (* A simple decidability checker : if the proposition belongs to the - simple grammar describe below then it is decidable. Proof is by + simple grammar describe below then it is decidable. Proof is by induction and uses well known theorem about arithmetic and propositional calculus *) @@ -2703,7 +2703,7 @@ Qed. (* An interpretation function for a complete goal with an explicit conclusion. We use an intermediate fixpoint. *) -Fixpoint interp_full_goal (envp : list Prop) (env : list int) +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 @@ -2711,7 +2711,7 @@ Fixpoint interp_full_goal (envp : list Prop) (env : list int) interp_proposition envp env p' -> interp_full_goal envp env c l' end. -Definition interp_full (ep : list Prop) (e : list int) +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 @@ -2729,7 +2729,7 @@ Proof. Qed. (* Push the conclusion in the list of hypothesis using a double negation - If the decidability cannot be "proven", then just forget about the + If the decidability cannot be "proven", then just forget about the conclusion (equivalent of replacing it with false) *) Definition to_contradict (lc : hyps * proposition) := @@ -2765,16 +2765,16 @@ Fixpoint map_cons (A : Set) (x : A) (l : list (list A)) {struct l} : | l :: ll => (x :: l) :: map_cons A x ll end. -(* This function breaks up a list of hypothesis in a list of simpler +(* This function breaks up a list of hypothesis in a list of simpler list of hypothesis that together implie the original one. The goal - of all this is to transform the goal in a list of solvable problems. + of all this is to transform the goal in a list of solvable problems. Note that : - we need a way to drive the analysis as some hypotheis may not - require a split. + require a split. - this procedure must be perfectly mimicked by the ML part otherwise hypothesis will get desynchronised and this will be a mess. *) - + Fixpoint destructure_hyps (nn : nat) (ll : hyps) {struct nn} : lhyps := match nn with | O => ll :: nil @@ -2834,7 +2834,7 @@ Proof. (simpl in |- *; intros; apply map_cons_val; simpl in |- *; elim H0; auto); [ simpl in |- *; intros p1 (H1, H2); - pattern (decidability p1) in |- *; apply bool_eq_ind; + pattern (decidability p1) in |- *; apply bool_eq_ind; intro H3; [ apply H; simpl in |- *; split; [ apply not_not; auto | assumption ] @@ -2842,7 +2842,7 @@ Proof. | 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_eq_ind; + 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 @@ -2850,11 +2850,11 @@ Proof. | auto ] | auto ] ] | simpl in |- *; intros p1 p2 (H1, H2); apply append_valid; - (elim H1; intro H3; simpl in |- *; [ left | right ]); + (elim H1; intro H3; simpl in |- *; [ left | right ]); 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_eq_ind; + 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 @@ -2867,7 +2867,7 @@ Definition prop_stable (f : proposition -> 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) +Definition p_apply_left (f : proposition -> proposition) (p : proposition) := match p with | Timp x y => Timp (f x) y @@ -2907,7 +2907,7 @@ Proof. | intros p1 p2; elim (H ep e p2); tauto ]). Qed. -Definition p_invert (f : proposition -> proposition) +Definition p_invert (f : proposition -> proposition) (p : proposition) := match p with | EqTerm x y => Tnot (f (NeqTerm x y)) @@ -2960,7 +2960,7 @@ Proof. | case p; simpl in |- *; intros; auto; generalize H; elim (rewrite_stable s); simpl in |- *; intro H1; [ rewrite (plus_0_r_reverse (interp_term e t0)); rewrite H1; - rewrite plus_permute; rewrite plus_opp_r; + 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 @@ -3037,7 +3037,7 @@ Fixpoint extract_hyp_pos (s : list direction) (p : proposition) {struct s} : end | _ => p end - + with extract_hyp_neg (s : list direction) (p : proposition) {struct s} : proposition := match s with @@ -3087,7 +3087,7 @@ Proof. (apply H2; tauto) || (pattern (decidability p0) in |- *; apply bool_eq_ind; [ intro H3; generalize (decidable_correct ep e p0 H3); - unfold decidable in |- *; intro H4; apply H1; + unfold decidable in |- *; intro H4; apply H1; tauto | intro; tauto ]) ]. Qed. @@ -3103,8 +3103,8 @@ Fixpoint decompose_solve (s : e_step) (h : hyps) {struct s} : lhyps := decompose_solve s1 (Tnot x :: h) ++ decompose_solve s2 (Tnot y :: h) else h :: nil - | Timp x y => - if decidability x then + | Timp x y => + if decidability x then decompose_solve s1 (Tnot x :: h) ++ decompose_solve s2 (y :: h) else h::nil | _ => h :: nil @@ -3130,11 +3130,11 @@ Proof. | simpl in |- *; auto ] | intros p1 p2 H2; apply append_valid; simpl in |- *; elim H2; [ intros H3; left; apply H; simpl in |- *; auto - | intros H3; right; apply H0; simpl in |- *; auto ] + | intros H3; right; apply H0; simpl in |- *; auto ] | intros p1 p2 H2; 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; + apply append_valid; elim H4; intro H5; [ right; apply H0; simpl in |- *; tauto | left; apply H; simpl in |- *; tauto ] | simpl in |- *; auto ] ] @@ -3172,7 +3172,7 @@ Theorem do_reduce_lhyps : interp_list_goal envp env (reduce_lhyps l) -> interp_list_goal envp env l. 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; + apply list_hyps_to_goal with (1 := H); apply reduce_lhyps_valid; assumption. Qed. @@ -3193,12 +3193,12 @@ Proof. | simpl in |- *; tauto ]. Qed. -Definition omega_tactic (t1 : e_step) (t2 : list h_step) +Definition omega_tactic (t1 : e_step) (t2 : list h_step) (c : proposition) (l : hyps) := 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 : list Prop) + 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. @@ -3210,7 +3210,7 @@ Qed. End IntOmega. -(* For now, the above modular construction is instanciated on Z, +(* 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/plugins/romega/const_omega.ml b/plugins/romega/const_omega.ml index 1caa5db1c5..2978d699e1 100644 --- a/plugins/romega/const_omega.ml +++ b/plugins/romega/const_omega.ml @@ -9,7 +9,7 @@ let module_refl_name = "ReflOmegaCore" let module_refl_path = ["Coq"; "romega"; module_refl_name] -type result = +type result = Kvar of string | Kapp of string * Term.constr list | Kimp of Term.constr * Term.constr @@ -38,10 +38,10 @@ let destructurate t = exception Destruct -let dest_const_apply t = - let f,args = Term.decompose_app t in - let ref = - match Term.kind_of_term f with +let dest_const_apply t = + let f,args = Term.decompose_app t in + let ref = + match Term.kind_of_term f with | Term.Const sp -> Libnames.ConstRef sp | Term.Construct csp -> Libnames.ConstructRef csp | Term.Ind isp -> Libnames.IndRef isp @@ -165,15 +165,15 @@ let coq_do_omega = lazy (constant "do_omega") (* \subsection{Construction d'expressions} *) -let do_left 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 |] ) -let do_right t = +let do_right t = if t = Lazy.force coq_c_nop then Lazy.force coq_c_nop else Term.mkApp (Lazy.force coq_c_do_right, [|t |]) -let do_both t1 t2 = +let do_both t1 t2 = if t1 = Lazy.force coq_c_nop then do_right t2 else if t2 = Lazy.force coq_c_nop then do_left t1 else Term.mkApp (Lazy.force coq_c_do_both , [|t1; t2 |]) @@ -182,7 +182,7 @@ let do_seq t1 t2 = if t1 = Lazy.force coq_c_nop then t2 else if t2 = Lazy.force coq_c_nop then t1 else Term.mkApp (Lazy.force coq_c_do_seq, [|t1; t2 |]) - + let rec do_list = function | [] -> Lazy.force coq_c_nop | [x] -> x @@ -206,7 +206,7 @@ let mk_list typ l = let rec loop = function | [] -> Term.mkApp (Lazy.force coq_nil, [|typ|]) - | (step :: l) -> + | (step :: l) -> Term.mkApp (Lazy.force coq_cons, [|typ; step; loop l |]) in loop l @@ -215,16 +215,16 @@ 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 +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 + | Tother -type parse_rel = +type parse_rel = | Req of Term.constr * Term.constr | Rne of Term.constr * Term.constr | Rlt of Term.constr * Term.constr @@ -240,12 +240,12 @@ type parse_rel = | Riff of Term.constr * Term.constr | Rother -let parse_logic_rel c = +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("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) @@ -255,7 +255,7 @@ let parse_logic_rel c = module type Int = sig val typ : Term.constr Lazy.t - val plus : 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 @@ -264,10 +264,10 @@ module type Int = sig 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 + val is_scalar : Term.constr -> bool end -module Z : Int = struct +module Z : Int = struct let typ = lazy (constant "Z") let plus = lazy (constant "Zplus") @@ -297,16 +297,16 @@ let recognize t = | "Z0",[] -> Bigint.zero | _ -> failwith "not a number";; -let rec mk_positive n = - if n=Bigint.one then Lazy.force coq_xH +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 |]) + [| mk_positive q |]) let mk_Z n = - if n = Bigint.zero then Lazy.force coq_Z0 + 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 @@ -314,7 +314,7 @@ let mk_Z n = let mk = mk_Z -let parse_term t = +let parse_term t = try match destructurate t with | Kapp("Zplus",[t1;t2]) -> Tplus (t1,t2) | Kapp("Zminus",[t1;t2]) -> Tminus (t1,t2) @@ -322,21 +322,21 @@ let parse_term t = | 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"),_) -> + | 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]) + +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 + | _ -> parse_logic_rel t with e when Logic.catchable_exception e -> Rother let is_scalar t = diff --git a/plugins/romega/const_omega.mli b/plugins/romega/const_omega.mli index 0f00e9184a..b8db71e40a 100644 --- a/plugins/romega/const_omega.mli +++ b/plugins/romega/const_omega.mli @@ -168,7 +168,7 @@ module type Int = 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 + * - ? *) + (* Is a particular term only made of numbers and + * - ? *) val is_scalar : Term.constr -> bool end diff --git a/plugins/romega/g_romega.ml4 b/plugins/romega/g_romega.ml4 index 39b6c2106b..2db86e005b 100644 --- a/plugins/romega/g_romega.ml4 +++ b/plugins/romega/g_romega.ml4 @@ -11,23 +11,23 @@ open Refl_omega open Refiner -let romega_tactic l = - let tacs = List.map - (function +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 + in tclTHEN (tclREPEAT (tclPROGRESS (tclTHENLIST tacs))) - (tclTHEN - (* because of the contradiction process in (r)omega, + (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 + Tactics.intros total_reflexive_omega_tactic) @@ -36,7 +36,7 @@ TACTIC EXTEND romega END TACTIC EXTEND romega' -| [ "romega" "with" ne_ident_list(l) ] -> +| [ "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/plugins/romega/refl_omega.ml b/plugins/romega/refl_omega.ml index fc4f7a8f09..570bb1877e 100644 --- a/plugins/romega/refl_omega.ml +++ b/plugins/romega/refl_omega.ml @@ -28,7 +28,7 @@ let mkApp = Term.mkApp (* \section{Types} \subsection{How to walk in a term} To represent how to get to a proposition. Only choice points are - kept (branch to choose in a disjunction and identifier of the disjunctive + kept (branch to choose in a disjunction and identifier of the disjunctive connector) *) type direction = Left of int | Right of int @@ -58,11 +58,11 @@ type oformula = (* Operators for comparison recognized by Omega *) type comparaison = Eq | Leq | Geq | Gt | Lt | Neq -(* Type des prédicats réifiés (fragment de calcul propositionnel. Les +(* Type des prédicats réifiés (fragment de calcul propositionnel. Les * quantifications sont externes au langage) *) -type oproposition = +type oproposition = Pequa of Term.constr * oequation - | Ptrue + | Ptrue | Pfalse | Pnot of oproposition | Por of int * oproposition * oproposition @@ -77,16 +77,16 @@ and oequation = { e_right: oformula; (* formule brute droite *) e_trace: Term.constr; (* tactique de normalisation *) e_origin: occurence; (* l'hypothèse dont vient le terme *) - e_negated: bool; (* vrai si apparait en position nié + e_negated: bool; (* vrai si apparait en position nié après normalisation *) - e_depends: direction list; (* liste des points de disjonction dont - dépend l'accès à l'équation avec la + e_depends: direction list; (* liste des points de disjonction dont + dépend l'accès à l'équation avec la direction (branche) pour y accéder *) e_omega: afine (* la fonction normalisée *) - } + } -(* \subsection{Proof context} - This environment codes +(* \subsection{Proof context} + This environment codes \begin{itemize} \item the terms and propositions that are given as parameters of the reified proof (and are represented as variables in the @@ -101,7 +101,7 @@ type environment = { mutable props : Term.constr list; (* Les variables introduites par omega *) mutable om_vars : (oformula * int) list; - (* Traduction des indices utilisés ici en les indices finaux utilisés par + (* Traduction des indices utilisés ici en les indices finaux utilisés par * la tactique Omega après dénombrement des variables utiles *) real_indices : (int,int) Hashtbl.t; mutable cnt_connectors : int; @@ -119,7 +119,7 @@ type solution = { s_trace : action list } (* Arbre de solution résolvant complètement un ensemble de systèmes *) -type solution_tree = +type solution_tree = Leaf of solution (* un noeud interne représente un point de branchement correspondant à l'élimination d'un connecteur générant plusieurs buts @@ -130,37 +130,37 @@ type solution_tree = (* Représentation de l'environnement extrait du but initial sous forme de chemins pour extraire des equations ou d'hypothèses *) -type context_content = +type context_content = CCHyp of occurence | CCEqua of int (* \section{Specific utility functions to handle base types} *) -(* Nom arbitraire de l'hypothèse codant la négation du but final *) +(* Nom arbitraire de l'hypothèse codant la négation du but final *) let id_concl = Names.id_of_string "__goal__" (* Initialisation de l'environnement de réification de la tactique *) let new_environment () = { - terms = []; props = []; om_vars = []; cnt_connectors = 0; + terms = []; props = []; om_vars = []; cnt_connectors = 0; real_indices = Hashtbl.create 7; equations = Hashtbl.create 7; constructors = Hashtbl.create 7; } (* Génération d'un nom d'équation *) -let new_connector_id env = +let new_connector_id env = env.cnt_connectors <- succ env.cnt_connectors; env.cnt_connectors (* Calcul de la branche complémentaire *) let barre = function Left x -> Right x | Right x -> Left x (* Identifiant associé à une branche *) -let indice = function Left x | Right x -> x +let indice = function Left x | Right x -> x (* Affichage de l'environnement de réification (termes et propositions) *) -let print_env_reification env = +let print_env_reification env = let rec loop c i = function [] -> Printf.printf " ===============================\n\n" - | t :: l -> + | t :: l -> Printf.printf " (%c%02d) := " c i; Pp.ppnl (Printer.pr_lconstr t); Pp.flush_all (); @@ -173,16 +173,16 @@ let print_env_reification env = (* \subsection{Gestion des environnements de variable pour Omega} *) (* generation d'identifiant d'equation pour Omega *) -let new_omega_eq, rst_omega_eq = - let cpt = ref 0 in - (function () -> incr cpt; !cpt), +let new_omega_eq, rst_omega_eq = + let cpt = ref 0 in + (function () -> incr cpt; !cpt), (function () -> cpt:=0) (* generation d'identifiant de variable pour Omega *) -let new_omega_var, rst_omega_var = - let cpt = ref 0 in - (function () -> incr cpt; !cpt), +let new_omega_var, rst_omega_var = + let cpt = ref 0 in + (function () -> incr cpt; !cpt), (function () -> cpt:=0) (* Affichage des variables d'un système *) @@ -195,8 +195,8 @@ let display_omega_var i = Printf.sprintf "OV%d" i let intern_omega env t = begin try List.assoc t env.om_vars - with Not_found -> - let v = new_omega_var () in + with Not_found -> + let v = new_omega_var () in env.om_vars <- (t,v) :: env.om_vars; v end @@ -207,14 +207,14 @@ let intern_omega_force env t v = env.om_vars <- (t,v) :: env.om_vars (* Récupère le terme associé à une variable *) let unintern_omega env id = - let rec loop = function - [] -> failwith "unintern" + let rec loop = function + [] -> failwith "unintern" | ((t,j)::l) -> if id = j then t else loop l in loop env.om_vars -(* \subsection{Gestion des environnements de variable pour la réflexion} +(* \subsection{Gestion des environnements de variable pour la réflexion} Gestion des environnements de traduction entre termes des constructions - non réifiés et variables des termes reifies. Attention il s'agit de + non réifiés et variables des termes reifies. Attention il s'agit de l'environnement initial contenant tout. Il faudra le réduire après calcul des variables utiles. *) @@ -224,7 +224,7 @@ let add_reified_atom t env = let i = List.length env.terms in env.terms <- env.terms @ [t]; i -let get_reified_atom env = +let get_reified_atom env = try List.nth env.terms with _ -> failwith "get_reified_atom" (* \subsection{Gestion de l'environnement de proposition pour Omega} *) @@ -245,33 +245,33 @@ let add_equation env e = with Not_found -> Hashtbl.add env.equations id e (* accès a une equation *) -let get_equation env id = +let get_equation env id = try Hashtbl.find env.equations id with e -> Printf.printf "Omega Equation %d non trouvée\n" id; raise e (* Affichage des termes réifiés *) -let rec oprint ch = function +let rec oprint ch = function | Oint n -> Printf.fprintf ch "%s" (Bigint.to_string n) - | Oplus (t1,t2) -> Printf.fprintf ch "(%a + %a)" oprint t1 oprint t2 - | Omult (t1,t2) -> Printf.fprintf ch "(%a * %a)" oprint t1 oprint t2 - | Ominus(t1,t2) -> Printf.fprintf ch "(%a - %a)" oprint t1 oprint t2 + | Oplus (t1,t2) -> Printf.fprintf ch "(%a + %a)" oprint t1 oprint t2 + | Omult (t1,t2) -> Printf.fprintf ch "(%a * %a)" oprint t1 oprint t2 + | Ominus(t1,t2) -> Printf.fprintf ch "(%a - %a)" oprint t1 oprint t2 | Oopp t1 ->Printf.fprintf ch "~ %a" oprint t1 | Oatom n -> Printf.fprintf ch "V%02d" n | Oufo x -> Printf.fprintf ch "?" let rec pprint ch = function Pequa (_,{ e_comp=comp; e_left=t1; e_right=t2 }) -> - let connector = - match comp with + let connector = + match comp with Eq -> "=" | Leq -> "<=" | Geq -> ">=" | Gt -> ">" | Lt -> "<" | Neq -> "!=" in - Printf.fprintf ch "%a %s %a" oprint t1 connector oprint t2 + Printf.fprintf ch "%a %s %a" oprint t1 connector oprint t2 | Ptrue -> Printf.fprintf ch "TT" | Pfalse -> Printf.fprintf ch "FF" | Pnot t -> Printf.fprintf ch "not(%a)" pprint t - | Por (_,t1,t2) -> Printf.fprintf ch "(%a or %a)" pprint t1 pprint t2 - | Pand(_,t1,t2) -> Printf.fprintf ch "(%a and %a)" pprint t1 pprint t2 - | Pimp(_,t1,t2) -> Printf.fprintf ch "(%a => %a)" pprint t1 pprint t2 + | Por (_,t1,t2) -> Printf.fprintf ch "(%a or %a)" pprint t1 pprint t2 + | Pand(_,t1,t2) -> Printf.fprintf ch "(%a and %a)" pprint t1 pprint t2 + | Pimp(_,t1,t2) -> Printf.fprintf ch "(%a => %a)" pprint t1 pprint t2 | Pprop c -> Printf.fprintf ch "Prop" let rec weight env = function @@ -287,21 +287,21 @@ let rec weight env = function (* \subsection{Oformula vers Omega} *) -let omega_of_oformula env kind = +let omega_of_oformula env kind = let rec loop accu = function - | Oplus(Omult(v,Oint n),r) -> + | Oplus(Omult(v,Oint n),r) -> loop ({v=intern_omega env v; c=n} :: accu) r | Oint n -> let id = new_omega_eq () in (*i tag_equation name id; i*) - {kind = kind; body = List.rev accu; + {kind = kind; body = List.rev accu; constant = n; id = id} | t -> print_string "CO"; oprint stdout t; failwith "compile_equation" in loop [] (* \subsection{Omega vers Oformula} *) -let rec oformula_of_omega env af = +let rec oformula_of_omega env af = let rec loop = function | ({v=v; c=n}::r) -> Oplus(Omult(unintern_omega env v,Oint n),loop r) @@ -330,8 +330,8 @@ let rec coq_of_formula env t = let reified_of_atom env i = try Hashtbl.find env.real_indices i - with Not_found -> - Printf.printf "Atome %d non trouvé\n" 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 @@ -352,55 +352,55 @@ let reified_of_formula env f = begin try reified_of_formula env f with e -> oprint stderr f; raise e end let rec reified_of_proposition env = function - Pequa (_,{ e_comp=Eq; e_left=t1; e_right=t2 }) -> + Pequa (_,{ e_comp=Eq; e_left=t1; e_right=t2 }) -> app coq_p_eq [| reified_of_formula env t1; reified_of_formula env t2 |] - | Pequa (_,{ e_comp=Leq; e_left=t1; e_right=t2 }) -> + | Pequa (_,{ e_comp=Leq; e_left=t1; e_right=t2 }) -> app coq_p_leq [| reified_of_formula env t1; reified_of_formula env t2 |] - | Pequa(_,{ e_comp=Geq; e_left=t1; e_right=t2 }) -> + | Pequa(_,{ e_comp=Geq; e_left=t1; e_right=t2 }) -> app coq_p_geq [| reified_of_formula env t1; reified_of_formula env t2 |] - | Pequa(_,{ e_comp=Gt; e_left=t1; e_right=t2 }) -> + | Pequa(_,{ e_comp=Gt; e_left=t1; e_right=t2 }) -> app coq_p_gt [| reified_of_formula env t1; reified_of_formula env t2 |] - | Pequa(_,{ e_comp=Lt; e_left=t1; e_right=t2 }) -> + | Pequa(_,{ e_comp=Lt; e_left=t1; e_right=t2 }) -> app coq_p_lt [| reified_of_formula env t1; reified_of_formula env t2 |] - | Pequa(_,{ e_comp=Neq; e_left=t1; e_right=t2 }) -> + | Pequa(_,{ e_comp=Neq; e_left=t1; e_right=t2 }) -> app coq_p_neq [| reified_of_formula env t1; reified_of_formula env t2 |] | Ptrue -> Lazy.force coq_p_true | Pfalse -> Lazy.force coq_p_false - | Pnot t -> + | Pnot t -> app coq_p_not [| reified_of_proposition env t |] - | Por (_,t1,t2) -> + | Por (_,t1,t2) -> app coq_p_or [| reified_of_proposition env t1; reified_of_proposition env t2 |] - | Pand(_,t1,t2) -> + | Pand(_,t1,t2) -> app coq_p_and [| reified_of_proposition env t1; reified_of_proposition env t2 |] - | Pimp(_,t1,t2) -> + | Pimp(_,t1,t2) -> app coq_p_imp [| reified_of_proposition env t1; reified_of_proposition env t2 |] | Pprop t -> app coq_p_prop [| mk_nat (add_prop env t) |] let reified_of_proposition env f = - begin try reified_of_proposition env f + begin try reified_of_proposition env f with e -> pprint stderr f; raise e end (* \subsection{Omega vers COQ réifié} *) -let reified_of_omega env body constant = - let coeff_constant = +let reified_of_omega env body constant = + let coeff_constant = 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); + let coef = + app coq_t_mult + [| reified_of_formula env (unintern_omega env v); app coq_t_int [| Z.mk c |] |] in app coq_t_plus [|coef; t |] in List.fold_right mk_coeff body coeff_constant -let reified_of_omega env body c = - begin try - reified_of_omega env body c - with e -> - display_eq display_omega_var (body,c); raise e +let reified_of_omega env body c = + begin try + reified_of_omega env body c + with e -> + display_eq display_omega_var (body,c); raise e end (* \section{Opérations sur les équations} @@ -423,13 +423,13 @@ let rec vars_of_formula = function | Oufo _ -> [] let rec vars_of_equations = function - | [] -> [] - | e::l -> + | [] -> [] + | e::l -> (vars_of_formula e.e_left) @@ (vars_of_formula e.e_right) @@ (vars_of_equations l) -let rec vars_of_prop = function +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) @@ -440,16 +440,16 @@ let rec vars_of_prop = function (* \subsection{Multiplication par un scalaire} *) let rec scalar n = function - Oplus(t1,t2) -> - let tac1,t1' = scalar n t1 and + Oplus(t1,t2) -> + let tac1,t1' = scalar n t1 and tac2,t2' = scalar n t2 in - do_list [Lazy.force coq_c_mult_plus_distr; do_both tac1 tac2], + do_list [Lazy.force coq_c_mult_plus_distr; do_both tac1 tac2], Oplus(t1',t2') | Oopp t -> do_list [Lazy.force coq_c_mult_opp_left], Omult(t,Oint(Bigint.neg n)) - | Omult(t1,Oint x) -> + | Omult(t1,Oint x) -> do_list [Lazy.force coq_c_mult_assoc_reduced], Omult(t1,Oint (n*x)) - | Omult(t1,t2) -> + | Omult(t1,t2) -> Util.error "Omega: Can't solve a goal with non-linear products" | (Oatom _ as t) -> do_list [], Omult(t,Oint n) | Oint i -> do_list [Lazy.force coq_c_reduce],Oint(n*i) @@ -459,16 +459,16 @@ let rec scalar n = function (* \subsection{Propagation de l'inversion} *) let rec negate = function - Oplus(t1,t2) -> - let tac1,t1' = negate t1 and + Oplus(t1,t2) -> + let tac1,t1' = negate t1 and tac2,t2' = negate t2 in do_list [Lazy.force coq_c_opp_plus ; (do_both tac1 tac2)], Oplus(t1',t2') | Oopp t -> do_list [Lazy.force coq_c_opp_opp], t - | Omult(t1,Oint x) -> + | Omult(t1,Oint x) -> do_list [Lazy.force coq_c_opp_mult_r], Omult(t1,Oint (Bigint.neg x)) - | Omult(t1,t2) -> + | Omult(t1,t2) -> Util.error "Omega: Can't solve a goal with non-linear products" | (Oatom _ as t) -> do_list [Lazy.force coq_c_opp_one], Omult(t,Oint(negone)) @@ -493,29 +493,29 @@ let rec shuffle_path k1 e1 k2 e2 = Lazy.force coq_f_left :: loop(l1,l2')) else ( Lazy.force coq_f_right :: loop(l1',l2)) - | ({c=c1;v=v1}::l1), [] -> + | ({c=c1;v=v1}::l1), [] -> Lazy.force coq_f_left :: loop(l1,[]) - | [],({c=c2;v=v2}::l2) -> + | [],({c=c2;v=v2}::l2) -> Lazy.force coq_f_right :: loop([],l2) | [],[] -> flush stdout; [] in mk_shuffle_list (loop (e1,e2)) (* \subsubsection{Version sans coefficients} *) -let rec shuffle env (t1,t2) = +let rec shuffle env (t1,t2) = match t1,t2 with Oplus(l1,r1), Oplus(l2,r2) -> - if weight env l1 > weight env l2 then + if weight env l1 > weight env l2 then let l_action,t' = shuffle env (r1,t2) in do_list [Lazy.force coq_c_plus_assoc_r;do_right l_action], Oplus(l1,t') - else + else let l_action,t' = shuffle env (t1,r2) in do_list [Lazy.force coq_c_plus_permute;do_right l_action], Oplus(l2,t') - | Oplus(l1,r1), t2 -> + | Oplus(l1,r1), t2 -> if weight env l1 > weight env t2 then let (l_action,t') = shuffle env (r1,t2) in do_list [Lazy.force coq_c_plus_assoc_r;do_right l_action],Oplus(l1, t') else do_list [Lazy.force coq_c_plus_comm], Oplus(t2,t1) - | t1,Oplus(l2,r2) -> + | t1,Oplus(l2,r2) -> if weight env l2 > weight env t1 then let (l_action,t') = shuffle env (t1,r2) in do_list [Lazy.force coq_c_plus_permute;do_right l_action], Oplus(l2,t') @@ -531,16 +531,16 @@ let rec shuffle env (t1,t2) = let shrink_pair f1 f2 = begin match f1,f2 with - Oatom v,Oatom _ -> + Oatom v,Oatom _ -> Lazy.force coq_c_red1, Omult(Oatom v,Oint two) - | Oatom v, Omult(_,c2) -> + | Oatom v, Omult(_,c2) -> Lazy.force coq_c_red2, Omult(Oatom v,Oplus(c2,Oint one)) - | Omult (v1,c1),Oatom v -> + | Omult (v1,c1),Oatom v -> Lazy.force coq_c_red3, Omult(Oatom v,Oplus(c1,Oint one)) | Omult (Oatom v,c1),Omult (v2,c2) -> Lazy.force coq_c_red4, Omult(Oatom v,Oplus(c1,c2)) - | t1,t2 -> - oprint stdout t1; print_newline (); oprint stdout t2; print_newline (); + | t1,t2 -> + oprint stdout t1; print_newline (); oprint stdout t2; print_newline (); flush Pervasives.stdout; Util.error "shrink.1" end @@ -554,7 +554,7 @@ let reduce_factor = function | Omult(Oatom v,c) -> let rec compute = function Oint n -> n - | Oplus(t1,t2) -> compute t1 + compute t2 + | Oplus(t1,t2) -> compute t1 + compute t2 | _ -> Util.error "condense.1" in [Lazy.force coq_c_reduce], Omult(Oatom v,Oint(compute c)) | t -> Util.error "reduce_factor.1" @@ -570,24 +570,24 @@ let rec condense env = function assoc_tac :: do_left (do_list [shrink_tac]) :: tac_list, t' end else begin let tac,f = reduce_factor f1 in - let tac',t' = condense env t in - [do_both (do_list tac) (do_list tac')], Oplus(f,t') + let tac',t' = condense env t in + [do_both (do_list tac) (do_list tac')], Oplus(f,t') end - | Oplus(f1,Oint n) -> - let tac,f1' = reduce_factor f1 in + | Oplus(f1,Oint n) -> + let tac,f1' = reduce_factor f1 in [do_left (do_list tac)],Oplus(f1',Oint n) - | Oplus(f1,f2) -> + | Oplus(f1,f2) -> if weight env f1 = weight env f2 then begin let tac_shrink,t = shrink_pair f1 f2 in let tac,t' = condense env t in tac_shrink :: tac,t' end else begin let tac,f = reduce_factor f1 in - let tac',t' = condense env f2 in - [do_both (do_list tac) (do_list tac')],Oplus(f,t') + let tac',t' = condense env f2 in + [do_both (do_list tac) (do_list tac')],Oplus(f,t') end | (Oint _ as t)-> [],t - | t -> + | t -> let tac,t' = reduce_factor t in let final = Oplus(t',Oint zero) in tac @ [Lazy.force coq_c_red6], final @@ -598,8 +598,8 @@ let rec clear_zero = function Oplus(Omult(Oatom v,Oint n),r) when n=zero -> let tac',t = clear_zero r in Lazy.force coq_c_red5 :: tac',t - | Oplus(f,r) -> - let tac,t = clear_zero r in + | Oplus(f,r) -> + let tac,t = clear_zero r in (if tac = [] then [] else [do_right (do_list tac)]),Oplus(f,t) | t -> [],t;; @@ -641,14 +641,14 @@ let normalize_linear_term env t = (* Cette fonction reproduit très exactement le comportement de [p_invert] *) let negate_oper = function Eq -> Neq | Neq -> Eq | Leq -> Gt | Geq -> Lt | Lt -> Geq | Gt -> Leq - -let normalize_equation env (negated,depends,origin,path) (oper,t1,t2) = + +let normalize_equation env (negated,depends,origin,path) (oper,t1,t2) = let mk_step t1 t2 f kind = let t = f t1 t2 in let trace, oterm = normalize_linear_term env t in - let equa = omega_of_oformula env kind oterm in - { e_comp = oper; e_left = t1; e_right = t2; - e_negated = negated; e_depends = depends; + let equa = omega_of_oformula env kind oterm in + { e_comp = oper; e_left = t1; e_right = t2; + e_negated = negated; e_depends = depends; e_origin = { o_hyp = origin; o_path = List.rev path }; e_trace = trace; e_omega = equa } in try match (if negated then (negate_oper oper) else oper) with @@ -660,36 +660,36 @@ let normalize_equation env (negated,depends,origin,path) (oper,t1,t2) = mk_step t1 t2 (fun o1 o2 -> Oplus (Oplus(o2,Oint negone),Oopp o1)) INEQ | Gt -> - mk_step t1 t2 (fun o1 o2 -> Oplus (Oplus(o1,Oint negone),Oopp o2)) + mk_step t1 t2 (fun o1 o2 -> Oplus (Oplus(o1,Oint negone),Oopp o2)) INEQ with e when Logic.catchable_exception e -> raise e (* \section{Compilation des hypothèses} *) let rec oformula_of_constr env t = - match Z.parse_term t with + 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 -> + | 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 = +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) +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 let depends2 = if add_to_depends then Right i::depends else depends in if add_to_depends then Hashtbl.add env.constructors i {o_hyp = origin; o_path = List.rev path}; - let t1' = + let t1' = oproposition_of_constr env (neg1,depends1,origin,O_left::path) gl t1 in let t2' = oproposition_of_constr env (neg2,depends2,origin,O_right::path) gl t2 in @@ -704,31 +704,31 @@ and mk_equation env ctxt c connector t1 t2 = add_equation env omega; Pequa (c,omega) -and oproposition_of_constr env ((negated,depends,origin,path) as ctxt) gl c = - match Z.parse_rel gl c with +and oproposition_of_constr env ((negated,depends,origin,path) as ctxt) gl c = + 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 + | Rtrue -> Ptrue | Rfalse -> Pfalse - | Rnot t -> - let t' = - oproposition_of_constr - env (not negated, depends, origin,(O_mono::path)) gl t in + | Rnot t -> + let t' = + oproposition_of_constr + env (not negated, depends, origin,(O_mono::path)) gl t in Pnot t' - | Ror (t1,t2) -> + | Ror (t1,t2) -> binprop env ctxt (not negated) negated gl (fun i x y -> Por(i,x,y)) t1 t2 - | Rand (t1,t2) -> + | Rand (t1,t2) -> binprop env ctxt negated negated gl (fun i x y -> Pand(i,x,y)) t1 t2 | Rimp (t1,t2) -> - binprop env ctxt (not negated) (not negated) gl + binprop env ctxt (not negated) (not negated) gl (fun i x y -> Pimp(i,x,y)) t1 t2 | Riff (t1,t2) -> - binprop env ctxt negated negated gl + binprop env ctxt negated negated gl (fun i x y -> Pand(i,x,y)) (Term.mkArrow t1 t2) (Term.mkArrow t2 t1) | _ -> Pprop c @@ -751,30 +751,30 @@ let reify_gl env gl = Printf.printf "\n" end; (i,t') :: loop lhyps - | [] -> - if !debug then print_env_reification env; + | [] -> + if !debug then print_env_reification env; [] in let t_lhyps = loop (Tacmach.pf_hyps_types gl) in - (id_concl,t_concl) :: t_lhyps + (id_concl,t_concl) :: t_lhyps let rec destructurate_pos_hyp orig list_equations list_depends = function | Pequa (_,e) -> [e :: list_equations] | Ptrue | Pfalse | Pprop _ -> [list_equations] | Pnot t -> destructurate_neg_hyp orig list_equations list_depends t - | Por (i,t1,t2) -> - let s1 = + | Por (i,t1,t2) -> + let s1 = destructurate_pos_hyp orig list_equations (i::list_depends) t1 in - let s2 = + let s2 = destructurate_pos_hyp orig list_equations (i::list_depends) t2 in s1 @ s2 - | Pand(i,t1,t2) -> + | Pand(i,t1,t2) -> let list_s1 = destructurate_pos_hyp orig list_equations (list_depends) t1 in - let rec loop = function + let rec loop = function le1 :: ll -> destructurate_pos_hyp orig le1 list_depends t2 @ loop ll | [] -> [] in loop list_s1 - | Pimp(i,t1,t2) -> + | Pimp(i,t1,t2) -> let s1 = destructurate_neg_hyp orig list_equations (i::list_depends) t1 in let s2 = @@ -785,30 +785,30 @@ and destructurate_neg_hyp orig list_equations list_depends = function | Pequa (_,e) -> [e :: list_equations] | Ptrue | Pfalse | Pprop _ -> [list_equations] | Pnot t -> destructurate_pos_hyp orig list_equations list_depends t - | Pand (i,t1,t2) -> + | Pand (i,t1,t2) -> let s1 = destructurate_neg_hyp orig list_equations (i::list_depends) t1 in let s2 = destructurate_neg_hyp orig list_equations (i::list_depends) t2 in s1 @ s2 - | Por(_,t1,t2) -> + | Por(_,t1,t2) -> let list_s1 = destructurate_neg_hyp orig list_equations list_depends t1 in - let rec loop = function + let rec loop = function le1 :: ll -> destructurate_neg_hyp orig le1 list_depends t2 @ loop ll | [] -> [] in loop list_s1 - | Pimp(_,t1,t2) -> + | Pimp(_,t1,t2) -> let list_s1 = destructurate_pos_hyp orig list_equations list_depends t1 in - let rec loop = function + let rec loop = function le1 :: ll -> destructurate_neg_hyp orig le1 list_depends t2 @ loop ll | [] -> [] in loop list_s1 let destructurate_hyps syst = let rec loop = function - (i,t) :: l -> + (i,t) :: l -> let l_syst1 = destructurate_pos_hyp i [] [] t in let l_syst2 = loop l in list_cartesian (@) l_syst1 l_syst2 @@ -819,23 +819,23 @@ let destructurate_hyps syst = (* Affichage des dépendances de système *) let display_depend = function - Left i -> Printf.printf " L%d" i + Left i -> Printf.printf " L%d" i | Right i -> Printf.printf " R%d" i -let display_systems syst_list = - let display_omega om_e = +let display_systems syst_list = + let display_omega om_e = Printf.printf " E%d : %a %s 0\n" om_e.id - (fun _ -> display_eq display_omega_var) + (fun _ -> display_eq display_omega_var) (om_e.body, om_e.constant) (operator_of_eq om_e.kind) in - let display_equation oformula_eq = + let display_equation oformula_eq = pprint stdout (Pequa (Lazy.force coq_c_nop,oformula_eq)); print_newline (); display_omega oformula_eq.e_omega; - Printf.printf " Depends on:"; + Printf.printf " Depends on:"; List.iter display_depend oformula_eq.e_depends; - Printf.printf "\n Path: %s" + Printf.printf "\n Path: %s" (String.concat "" (List.map (function O_left -> "L" | O_right -> "R" | O_mono -> "M") oformula_eq.e_origin.o_path)); @@ -852,10 +852,10 @@ let display_systems syst_list = calcul des hypothèses *) let rec hyps_used_in_trace = function - | act :: l -> + | act :: l -> begin match act with | HYP e -> [e.id] @@ (hyps_used_in_trace l) - | SPLIT_INEQ (_,(_,act1),(_,act2)) -> + | SPLIT_INEQ (_,(_,act1),(_,act2)) -> hyps_used_in_trace act1 @@ hyps_used_in_trace act2 | _ -> hyps_used_in_trace l end @@ -866,33 +866,33 @@ let rec hyps_used_in_trace = function éviter les créations de variable au vol *) let rec variable_stated_in_trace = function - | act :: l -> + | act :: l -> begin match act with | STATE action -> (*i nlle_equa: afine, def: afine, eq_orig: afine, i*) (*i coef: int, var:int i*) action :: variable_stated_in_trace l - | SPLIT_INEQ (_,(_,act1),(_,act2)) -> + | SPLIT_INEQ (_,(_,act1),(_,act2)) -> variable_stated_in_trace act1 @ variable_stated_in_trace act2 | _ -> variable_stated_in_trace l end | [] -> [] ;; -let add_stated_equations env tree = +let add_stated_equations env tree = (* Il faut trier les variables par ordre d'introduction pour ne pas risquer de définir dans le mauvais ordre *) - let stated_equations = - let cmpvar x y = Pervasives.(-) x.st_var y.st_var in + let stated_equations = + 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) + | Leaf s -> List.sort cmpvar (variable_stated_in_trace s.s_trace) in loop tree - in - let add_env st = + 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 - (* Notez que si l'ordre de création des variables n'est pas respecté, + (* Notez que si l'ordre de création des variables n'est pas respecté, * ca va planter *) let coq_v = coq_of_formula env v_def in let v = add_reified_atom coq_v env in @@ -902,33 +902,33 @@ let add_stated_equations env tree = * l'environnement pour le faire correctement *) let term_to_reify = (v_def,Oatom v) in (* enregistre le lien entre la variable omega et la variable Coq *) - intern_omega_force env (Oatom v) st.st_var; + intern_omega_force env (Oatom v) st.st_var; (v, term_to_generalize,term_to_reify,st.st_def.id) in List.map add_env stated_equations -(* Calcule la liste des éclatements à réaliser sur les hypothèses +(* 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 +(* 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 + 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 -> + i :: r -> let l = try (get_equation env i).e_depends with Not_found -> [] in list_union (List.rev l) (get_eclatement env r) | [] -> [] -let select_smaller l = +let select_smaller l = let comp (_,x) (_,y) = Pervasives.(-) (List.length x) (List.length y) in try List.hd (List.sort comp l) with Failure _ -> failwith "select_smaller" let filter_compatible_systems required systems = let rec select = function - (x::l) -> + (x::l) -> if List.mem x required then select l - else if List.mem (barre x) required then failwith "Exit" + else if List.mem (barre x) required then failwith "Exit" else x :: select l | [] -> [] in map_succeed (function (sol,splits) -> (sol,select splits)) systems @@ -938,8 +938,8 @@ let rec equas_of_solution_tree = function | Leaf s -> s.s_equa_deps (* [really_useful_prop] pushes useless props in a new Pprop variable *) -(* Things get shorter, but may also get wrong, since a Prop is considered - to be undecidable in ReflOmegaCore.concl_to_hyp, whereas for instance +(* Things get shorter, but may also get wrong, since a Prop is considered + to be undecidable in ReflOmegaCore.concl_to_hyp, whereas for instance Pfalse is decidable. So should not be used on conclusion (??) *) let really_useful_prop l_equa c = @@ -953,21 +953,21 @@ let really_useful_prop l_equa c = (* Attention : implications sur le lifting des variables à comprendre ! *) | Pimp(_,t1,t2) -> Term.mkArrow (real_of t1) (real_of t2) | Pprop t -> t in - let rec loop c = - match c with + let rec loop c = + match c with Pequa(_,e) -> if List.mem e.e_omega.id l_equa then Some c else None | Ptrue -> None | Pfalse -> None - | Pnot t1 -> + | Pnot t1 -> begin match loop t1 with None -> None | Some t1' -> Some (Pnot t1') end | Por(i,t1,t2) -> binop (fun (t1,t2) -> Por(i,t1,t2)) t1 t2 | Pand(i,t1,t2) -> binop (fun (t1,t2) -> Pand(i,t1,t2)) t1 t2 | Pimp(i,t1,t2) -> binop (fun (t1,t2) -> Pimp(i,t1,t2)) t1 t2 | Pprop t -> None - and binop f t1 t2 = + and binop f t1 t2 = begin match loop t1, loop t2 with - None, None -> None + None, None -> None | Some t1',Some t2' -> Some (f(t1',t2')) | Some t1',None -> Some (f(t1',Pprop (real_of t2))) | None,Some t2' -> Some (f(Pprop (real_of t1),t2')) @@ -977,36 +977,36 @@ let really_useful_prop l_equa c = | Some t -> t let rec display_solution_tree ch = function - Leaf t -> - output_string ch - (Printf.sprintf "%d[%s]" + Leaf t -> + output_string ch + (Printf.sprintf "%d[%s]" t.s_index (String.concat " " (List.map string_of_int t.s_equa_deps))) - | Tree(i,t1,t2) -> - Printf.fprintf ch "S%d(%a,%a)" i + | Tree(i,t1,t2) -> + Printf.fprintf ch "S%d(%a,%a)" i display_solution_tree t1 display_solution_tree t2 -let rec solve_with_constraints all_solutions path = +let rec solve_with_constraints all_solutions path = let rec build_tree sol buf = function [] -> Leaf sol - | (Left i :: remainder) -> + | (Left i :: remainder) -> Tree(i, - build_tree sol (Left i :: buf) remainder, + build_tree sol (Left i :: buf) remainder, solve_with_constraints all_solutions (List.rev(Right i :: buf))) - | (Right i :: remainder) -> + | (Right i :: remainder) -> Tree(i, solve_with_constraints all_solutions (List.rev (Left i :: buf)), build_tree sol (Right i :: buf) remainder) in let weighted = filter_compatible_systems path all_solutions in let (winner_sol,winner_deps) = - try select_smaller weighted - with e -> - Printf.printf "%d - %d\n" + try select_smaller weighted + with e -> + Printf.printf "%d - %d\n" (List.length weighted) (List.length all_solutions); List.iter display_depend path; raise e in - build_tree winner_sol (List.rev path) winner_deps + build_tree winner_sol (List.rev path) winner_deps -let find_path {o_hyp=id;o_path=p} env = +let find_path {o_hyp=id;o_path=p} env = let rec loop_path = function ([],l) -> Some l | (x1::l1,x2::l2) when x1 = x2 -> loop_path (l1,l2) @@ -1021,8 +1021,8 @@ let find_path {o_hyp=id;o_path=p} env = | [] -> failwith "find_path" in loop_id 0 env -let mk_direction_list l = - let trans = function +let mk_direction_list l = + let trans = function O_left -> coq_d_left | O_right -> coq_d_right | O_mono -> coq_d_mono in mk_list (Lazy.force coq_direction) (List.map (fun d-> Lazy.force(trans d)) l) @@ -1036,33 +1036,33 @@ let get_hyp env_hyp i = let replay_history env env_hyp = let rec loop env_hyp t = match t with - | CONTRADICTION (e1,e2) :: l -> + | CONTRADICTION (e1,e2) :: l -> let trace = mk_nat (List.length e1.body) in mkApp (Lazy.force coq_s_contradiction, - [| trace ; mk_nat (get_hyp env_hyp e1.id); + [| trace ; mk_nat (get_hyp env_hyp e1.id); mk_nat (get_hyp env_hyp e2.id) |]) | DIVIDE_AND_APPROX (e1,e2,k,d) :: l -> mkApp (Lazy.force coq_s_div_approx, - [| Z.mk k; Z.mk d; + [| Z.mk k; Z.mk d; reified_of_omega env e2.body e2.constant; - mk_nat (List.length e2.body); + mk_nat (List.length e2.body); loop env_hyp l; mk_nat (get_hyp env_hyp e1.id) |]) | NOT_EXACT_DIVIDE (e1,k) :: l -> let e2_constant = floor_div e1.constant k in 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, - [|Z.mk k; Z.mk d; - reified_of_omega env e2_body e2_constant; - mk_nat (List.length e2_body); + [|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)|]) | EXACT_DIVIDE (e1,k) :: l -> - let e2_body = + let e2_body = 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, - [|Z.mk k; - reified_of_omega env e2_body e2_constant; + [|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)|]) | (MERGE_EQ(e3,e1,e2)) :: l -> @@ -1072,22 +1072,22 @@ let replay_history env env_hyp = mk_nat n1; mk_nat n2; loop (CCEqua e3:: env_hyp) l |]) | SUM(e3,(k1,e1),(k2,e2)) :: l -> - let n1 = get_hyp env_hyp e1.id + let n1 = get_hyp env_hyp e1.id 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, [| 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 -> + | CONSTANT_NOT_NUL(e,k) :: l -> mkApp (Lazy.force coq_s_constant_not_nul, [| mk_nat (get_hyp env_hyp e) |]) | CONSTANT_NEG(e,k) :: l -> mkApp (Lazy.force coq_s_constant_neg, [| mk_nat (get_hyp env_hyp e) |]) - | STATE {st_new_eq=new_eq; st_def =def; + | STATE {st_new_eq=new_eq; st_def =def; st_orig=orig; st_coef=m; st_var=sigma } :: l -> - let n1 = get_hyp env_hyp orig.id + let n1 = get_hyp env_hyp orig.id and n2 = get_hyp env_hyp def.id in let v = unintern_omega env sigma in let o_def = oformula_of_omega env def in @@ -1096,26 +1096,26 @@ 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, - [| Z.mk 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 -> - mkApp (Lazy.force coq_s_constant_nul, + mkApp (Lazy.force coq_s_constant_nul, [| mk_nat (get_hyp env_hyp e) |]) | NEGATE_CONTRADICT(e1,e2,true) :: l -> - mkApp (Lazy.force coq_s_negate_contradict, + mkApp (Lazy.force coq_s_negate_contradict, [| mk_nat (get_hyp env_hyp e1.id); mk_nat (get_hyp env_hyp e2.id) |]) | NEGATE_CONTRADICT(e1,e2,false) :: l -> - mkApp (Lazy.force coq_s_negate_contradict_inv, - [| mk_nat (List.length e2.body); + mkApp (Lazy.force coq_s_negate_contradict_inv, + [| mk_nat (List.length e2.body); mk_nat (get_hyp env_hyp e1.id); mk_nat (get_hyp env_hyp e2.id) |]) | SPLIT_INEQ(e,(e1,l1),(e2,l2)) :: l -> let i = get_hyp env_hyp e.id in let r1 = loop (CCEqua e1 :: env_hyp) l1 in let r2 = loop (CCEqua e2 :: env_hyp) l2 in - mkApp (Lazy.force coq_s_split_ineq, + mkApp (Lazy.force coq_s_split_ineq, [| mk_nat (List.length e.body); mk_nat i; r1 ; r2 |]) | (FORGET_C _ | FORGET _ | FORGET_I _) :: l -> loop env_hyp l @@ -1125,14 +1125,14 @@ let replay_history env env_hyp = let rec decompose_tree env ctxt = function Tree(i,left,right) -> - let org = - try Hashtbl.find env.constructors i + let org = + try Hashtbl.find env.constructors i with Not_found -> failwith (Printf.sprintf "Cannot find constructor %d" i) in let (index,path) = find_path org ctxt in let left_hyp = CCHyp{o_hyp=org.o_hyp;o_path=org.o_path @ [O_left]} in let right_hyp = CCHyp{o_hyp=org.o_hyp;o_path=org.o_path @ [O_right]} in - app coq_e_split + app coq_e_split [| mk_nat index; mk_direction_list path; decompose_tree env (left_hyp::ctxt) left; @@ -1141,15 +1141,15 @@ let rec decompose_tree env ctxt = function decompose_tree_hyps s.s_trace env ctxt s.s_equa_deps and decompose_tree_hyps trace env ctxt = function [] -> app coq_e_solve [| replay_history env ctxt trace |] - | (i::l) -> + | (i::l) -> let equation = - try Hashtbl.find env.equations i + try Hashtbl.find env.equations i with Not_found -> failwith (Printf.sprintf "Cannot find equation %d" i) in let (index,path) = find_path equation.e_origin ctxt in let full_path = if equation.e_negated then path @ [O_mono] else path in - let cont = - decompose_tree_hyps trace env + let cont = + decompose_tree_hyps trace env (CCEqua equation.e_omega.id :: ctxt) l in app coq_e_extract [|mk_nat index; mk_direction_list full_path; @@ -1165,13 +1165,13 @@ de faire rejouer cette solution par la tactique réflexive. *) let resolution env full_reified_goal systems_list = let num = ref 0 in - let solve_system list_eq = + let solve_system list_eq = let index = !num in let system = List.map (fun eq -> eq.e_omega) list_eq in - let trace = - simplify_strong - (new_omega_eq,new_omega_var,display_omega_var) - system in + let trace = + simplify_strong + (new_omega_eq,new_omega_var,display_omega_var) + system in (* calcule les hypotheses utilisées pour la solution *) let vars = hyps_used_in_trace trace in let splits = get_eclatement env vars in @@ -1201,11 +1201,11 @@ let resolution env full_reified_goal systems_list = 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 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 + let concl_vars = vars_of_prop (List.assoc id_concl full_reified_goal) in really_useful_vars @@ concl_vars - in + in (* variables a introduire *) let to_introduce = add_stated_equations env solution_tree in let stated_vars = List.map (fun (v,_,_,_) -> v) to_introduce in @@ -1217,19 +1217,19 @@ let resolution env full_reified_goal systems_list = let all_vars_env = useful_vars @ stated_vars in let basic_env = let rec loop i = function - var :: l -> - let t = get_reified_atom env var in + var :: l -> + let t = get_reified_atom env var in 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 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),_) -> - app coq_p_eq [| reified_of_formula env l; + List.map (fun (_,_,(l,r),_) -> + app coq_p_eq [| reified_of_formula env l; reified_of_formula env r |]) to_introduce in - let reified_concl = + let reified_concl = match useful_hyps with (Pnot p) :: _ -> reified_of_proposition env p | _ -> reified_of_proposition env Pfalse in @@ -1239,51 +1239,51 @@ let resolution env full_reified_goal systems_list = reified_of_proposition env (really_useful_prop useful_equa_id p)) (List.tl useful_hyps)) in let env_props_reified = mk_plist env.props in - let reified_goal = + let reified_goal = mk_list (Lazy.force coq_proposition) (l_reified_stated @ l_reified_terms) in - let reified = - app coq_interp_sequent + let reified = + app coq_interp_sequent [| reified_concl;env_props_reified;env_terms_reified;reified_goal|] in - let normalize_equation e = + let normalize_equation e = let rec loop = function [] -> app (if e.e_negated then coq_p_invert else coq_p_step) [| e.e_trace |] | ((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_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... *) + let correct_index = + 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 Pervasives.(+) i (List.length to_introduce) - in + in app coq_pair_step [| mk_nat correct_index; loop e.e_origin.o_path |] in let normalization_trace = mk_list (Lazy.force coq_h_step) (List.map normalize_equation equations) in let initial_context = List.map (fun id -> CCHyp{o_hyp=id;o_path=[]}) (List.tl l_hyps) in - let context = + let context = CCHyp{o_hyp=id_concl;o_path=[]} :: hyp_stated_vars @ initial_context in let decompose_tactic = decompose_tree env context solution_tree in - Tactics.generalize + Tactics.generalize (l_generalize_arg @ List.map Term.mkVar (List.tl l_hyps)) >> - Tactics.change_in_concl None reified >> + Tactics.change_in_concl None reified >> Tactics.apply (app coq_do_omega [|decompose_tactic; normalization_trace|]) >> show_goal >> Tactics.normalise_vm_in_concl >> - (*i Alternatives to the previous line: - - Normalisation without VM: + (*i Alternatives to the previous line: + - Normalisation without VM: Tactics.normalise_in_concl - - Skip the conversion check and rely directly on the QED: - Tacmach.convert_concl_no_check (Lazy.force coq_True) Term.VMcast >> + - Skip the conversion check and rely directly on the QED: + Tacmach.convert_concl_no_check (Lazy.force coq_True) Term.VMcast >> i*) Tactics.apply (Lazy.force coq_I) -let total_reflexive_omega_tactic gl = +let total_reflexive_omega_tactic gl = Coqlib.check_required_library ["Coq";"romega";"ROmega"]; - rst_omega_eq (); + rst_omega_eq (); rst_omega_var (); try let env = new_environment () in diff --git a/plugins/rtauto/Bintree.v b/plugins/rtauto/Bintree.v index cd0f1afe97..36da9463ba 100644 --- a/plugins/rtauto/Bintree.v +++ b/plugins/rtauto/Bintree.v @@ -15,7 +15,7 @@ Unset Boxed Definitions. Open Scope positive_scope. -Ltac clean := try (simpl; congruence). +Ltac clean := try (simpl; congruence). Ltac caseq t := generalize (refl_equal t); pattern t at -1; case t. Functional Scheme Pcompare_ind := Induction for Pcompare Sort Prop. @@ -85,7 +85,7 @@ match m, n with | xO mm, xO nn => pos_eq mm nn | xH, xH => true | _, _ => false -end. +end. Theorem pos_eq_refl : forall m n, pos_eq m n = true -> m = n. induction m;simpl;intro n;destruct n;congruence || @@ -120,12 +120,12 @@ Theorem pos_eq_dec_ex : forall m n, fix 1;intros [mm|mm|] [nn|nn|];try (simpl;congruence). simpl;intro e. elim (pos_eq_dec_ex _ _ e). -intros x ex; rewrite ex. +intros x ex; rewrite ex. exists (f_equal xI x). reflexivity. simpl;intro e. elim (pos_eq_dec_ex _ _ e). -intros x ex; rewrite ex. +intros x ex; rewrite ex. exists (f_equal xO x). reflexivity. simpl. @@ -134,7 +134,7 @@ reflexivity. Qed. Fixpoint nat_eq (m n:nat) {struct m}: bool:= -match m, n with +match m, n with O,O => true | S mm,S nn => nat_eq mm nn | _,_ => false @@ -151,14 +151,14 @@ Defined. Fixpoint Lget (A:Set) (n:nat) (l:list A) {struct l}:option A := match l with nil => None -| x::q => +| x::q => match n with O => Some x | S m => Lget A m q end end . Implicit Arguments Lget [A]. -Lemma map_app : forall (A B:Set) (f:A -> B) l m, +Lemma map_app : forall (A B:Set) (f:A -> B) l m, List.map f (l ++ m) = List.map f l ++ List.map f m. induction l. reflexivity. @@ -166,16 +166,16 @@ simpl. intro m ; apply f_equal with (list B);apply IHl. Qed. -Lemma length_map : forall (A B:Set) (f:A -> B) l, +Lemma length_map : forall (A B:Set) (f:A -> B) l, length (List.map f l) = length l. induction l. reflexivity. simpl; apply f_equal with nat;apply IHl. Qed. -Lemma Lget_map : forall (A B:Set) (f:A -> B) i l, -Lget i (List.map f l) = -match Lget i l with Some a => +Lemma Lget_map : forall (A B:Set) (f:A -> B) i l, +Lget i (List.map f l) = +match Lget i l with Some a => Some (f a) | None => None end. induction i;intros [ | x l ] ;trivial. simpl;auto. @@ -190,7 +190,7 @@ reflexivity. auto. Qed. -Lemma Lget_app_Some : forall (A:Set) l delta i (a: A), +Lemma Lget_app_Some : forall (A:Set) l delta i (a: A), Lget i l = Some a -> Lget i (l ++ delta) = Some a. induction l;destruct i;simpl;try congruence;auto. @@ -208,8 +208,8 @@ Inductive Tree : Type := Tempty : Tree | Branch0 : Tree -> Tree -> Tree | Branch1 : A -> Tree -> Tree -> Tree. - -Fixpoint Tget (p:positive) (T:Tree) {struct p} : Poption := + +Fixpoint Tget (p:positive) (T:Tree) {struct p} : Poption := match T with Tempty => PNone | Branch0 T1 T2 => @@ -226,7 +226,7 @@ Fixpoint Tget (p:positive) (T:Tree) {struct p} : Poption := end end. -Fixpoint Tadd (p:positive) (a:A) (T:Tree) {struct p}: Tree := +Fixpoint Tadd (p:positive) (a:A) (T:Tree) {struct p}: Tree := match T with | Tempty => match p with @@ -253,13 +253,13 @@ Definition mkBranch0 (T1 T2:Tree) := Tempty ,Tempty => Tempty | _,_ => Branch0 T1 T2 end. - + Fixpoint Tremove (p:positive) (T:Tree) {struct p}: Tree := match T with | Tempty => Tempty - | Branch0 T1 T2 => + | Branch0 T1 T2 => match p with - | xI pp => mkBranch0 T1 (Tremove pp T2) + | xI pp => mkBranch0 T1 (Tremove pp T2) | xO pp => mkBranch0 (Tremove pp T1) T2 | xH => T end @@ -270,8 +270,8 @@ Fixpoint Tremove (p:positive) (T:Tree) {struct p}: Tree := | xH => mkBranch0 T1 T2 end end. - - + + Theorem Tget_Tempty: forall (p : positive), Tget p (Tempty) = PNone. destruct p;reflexivity. Qed. @@ -293,7 +293,7 @@ generalize i;clear i;induction j;destruct T;simpl in H|-*; destruct i;simpl;try rewrite (IHj _ H);try (destruct i;simpl;congruence);reflexivity|| congruence. Qed. -Record Store : Type := +Record Store : Type := mkStore {index:positive;contents:Tree}. Definition empty := mkStore xH Tempty. @@ -317,7 +317,7 @@ intros S W;induction W. unfold empty,index,get,contents;intros;apply Tget_Tempty. unfold index,get,push;simpl contents. intros i e;rewrite Tget_Tadd. -rewrite (Gt_Psucc _ _ e). +rewrite (Gt_Psucc _ _ e). unfold get in IHW. apply IHW;apply Gt_Psucc;assumption. Qed. @@ -336,8 +336,8 @@ apply get_Full_Gt; auto. apply Psucc_Gt. Qed. -Theorem get_push_Full : - forall i a S, Full S -> +Theorem get_push_Full : + forall i a S, Full S -> get i (push a S) = match (i ?= index S) Eq with Eq => PSome a @@ -359,9 +359,9 @@ apply get_Full_Gt;auto. Qed. Lemma Full_push_compat : forall i a S, Full S -> -forall x, get i S = PSome x -> +forall x, get i S = PSome x -> get i (push a S) = PSome x. -intros i a S F x H. +intros i a S F x H. caseq ((i ?= index S) Eq);intro test. rewrite (Pcompare_Eq_eq _ _ test) in H. rewrite (get_Full_Eq _ F) in H;congruence. @@ -372,7 +372,7 @@ assumption. rewrite (get_Full_Gt _ F) in H;congruence. Qed. -Lemma Full_index_one_empty : forall S, Full S -> index S = 1 -> S=empty. +Lemma Full_index_one_empty : forall S, Full S -> index S = 1 -> S=empty. intros [ind cont] F one; inversion F. reflexivity. simpl index in one;assert (h:=Psucc_not_one (index S)). @@ -382,7 +382,7 @@ Qed. Lemma push_not_empty: forall a S, (push a S) <> empty. intros a [ind cont];unfold push,empty. simpl;intro H;injection H; intros _ ; apply Psucc_not_one. -Qed. +Qed. Fixpoint In (x:A) (S:Store) (F:Full S) {struct F}: Prop := match F with @@ -390,7 +390,7 @@ F_empty => False | F_push a SS FF => x=a \/ In x SS FF end. -Lemma get_In : forall (x:A) (S:Store) (F:Full S) i , +Lemma get_In : forall (x:A) (S:Store) (F:Full S) i , get i S = PSome x -> In x S F. induction F. intro i;rewrite get_empty; congruence. @@ -432,7 +432,7 @@ Implicit Arguments F_empty [A]. Implicit Arguments F_push [A]. Implicit Arguments In [A]. -Section Map. +Section Map. Variables A B:Set. @@ -445,8 +445,8 @@ Tempty => Tempty | Branch1 a t1 t2 => Branch1 (f a) (Tmap t1) (Tmap t2) end. -Lemma Tget_Tmap: forall T i, -Tget i (Tmap T)= match Tget i T with PNone => PNone +Lemma Tget_Tmap: forall T i, +Tget i (Tmap T)= match Tget i T with PNone => PNone | PSome a => PSome (f a) end. induction T;intro i;case i;simpl;auto. Defined. @@ -459,13 +459,13 @@ Defined. Definition map (S:Store A) : Store B := mkStore (index S) (Tmap (contents S)). -Lemma get_map: forall i S, -get i (map S)= match get i S with PNone => PNone +Lemma get_map: forall i S, +get i (map S)= match get i S with PNone => PNone | PSome a => PSome (f a) end. destruct S;unfold get,map,contents,index;apply Tget_Tmap. Defined. -Lemma map_push: forall a S, +Lemma map_push: forall a S, map (push a S) = push (f a) (map S). intros a S. case S. @@ -474,7 +474,7 @@ intros;rewrite Tmap_Tadd;reflexivity. Defined. Theorem Full_map : forall S, Full S -> Full (map S). -intros S F. +intros S F. induction F. exact F_empty. rewrite map_push;constructor 2;assumption. diff --git a/plugins/rtauto/Rtauto.v b/plugins/rtauto/Rtauto.v index 4b95097e2f..0d1d09c736 100644 --- a/plugins/rtauto/Rtauto.v +++ b/plugins/rtauto/Rtauto.v @@ -23,7 +23,7 @@ Inductive form:Set:= Atom : positive -> form | Arrow : form -> form -> form | Bot -| Conjunct : form -> form -> form +| Conjunct : form -> form -> form | Disjunct : form -> form -> form. Notation "[ n ]":=(Atom n). @@ -39,7 +39,7 @@ match m with xI mm => match n with xI nn => pos_eq mm nn | _ => false end | xO mm => match n with xO nn => pos_eq mm nn | _ => false end | xH => match n with xH => true | _ => false end -end. +end. Theorem pos_eq_refl : forall m n, pos_eq m n = true -> m = n. induction m;simpl;destruct n;congruence || @@ -49,32 +49,32 @@ Qed. Fixpoint form_eq (p q:form) {struct p} :bool := match p with Atom m => match q with Atom n => pos_eq m n | _ => false end -| Arrow p1 p2 => -match q with - Arrow q1 q2 => form_eq p1 q1 && form_eq p2 q2 +| Arrow p1 p2 => +match q with + Arrow q1 q2 => form_eq p1 q1 && form_eq p2 q2 | _ => false end | Bot => match q with Bot => true | _ => false end -| Conjunct p1 p2 => -match q with - Conjunct q1 q2 => form_eq p1 q1 && form_eq p2 q2 -| _ => false +| Conjunct p1 p2 => +match q with + Conjunct q1 q2 => form_eq p1 q1 && form_eq p2 q2 +| _ => false end -| Disjunct p1 p2 => -match q with - Disjunct q1 q2 => form_eq p1 q1 && form_eq p2 q2 -| _ => false +| Disjunct p1 p2 => +match q with + Disjunct q1 q2 => form_eq p1 q1 && form_eq p2 q2 +| _ => false end -end. +end. Theorem form_eq_refl: forall p q, form_eq p q = true -> p = q. induction p;destruct q;simpl;clean. intro h;generalize (pos_eq_refl _ _ h);congruence. caseq (form_eq p1 q1);clean. -intros e1 e2;generalize (IHp1 _ e1) (IHp2 _ e2);congruence. +intros e1 e2;generalize (IHp1 _ e1) (IHp2 _ e2);congruence. caseq (form_eq p1 q1);clean. -intros e1 e2;generalize (IHp1 _ e1) (IHp2 _ e2);congruence. +intros e1 e2;generalize (IHp1 _ e1) (IHp2 _ e2);congruence. caseq (form_eq p1 q1);clean. -intros e1 e2;generalize (IHp1 _ e1) (IHp2 _ e2);congruence. +intros e1 e2;generalize (IHp1 _ e1) (IHp2 _ e2);congruence. Qed. Implicit Arguments form_eq_refl [p q]. @@ -102,16 +102,16 @@ end. Require Export BinPos. -Ltac wipe := intros;simpl;constructor. +Ltac wipe := intros;simpl;constructor. -Lemma compose0 : +Lemma compose0 : forall hyps F (A:Prop), - A -> + A -> (interp_ctx hyps F A). induction F;intros A H;simpl;auto. Qed. -Lemma compose1 : +Lemma compose1 : forall hyps F (A B:Prop), (A -> B) -> (interp_ctx hyps F A) -> @@ -120,9 +120,9 @@ induction F;intros A B H;simpl;auto. apply IHF;auto. Qed. -Theorem compose2 : +Theorem compose2 : forall hyps F (A B C:Prop), - (A -> B -> C) -> + (A -> B -> C) -> (interp_ctx hyps F A) -> (interp_ctx hyps F B) -> (interp_ctx hyps F C). @@ -130,10 +130,10 @@ induction F;intros A B C H;simpl;auto. apply IHF;auto. Qed. -Theorem compose3 : +Theorem compose3 : forall hyps F (A B C D:Prop), - (A -> B -> C -> D) -> - (interp_ctx hyps F A) -> + (A -> B -> C -> D) -> + (interp_ctx hyps F A) -> (interp_ctx hyps F B) -> (interp_ctx hyps F C) -> (interp_ctx hyps F D). @@ -148,7 +148,7 @@ induction F;simpl;intros;auto. apply compose1 with ([[a]]-> G);auto. Qed. -Theorem project_In : forall hyps F g, +Theorem project_In : forall hyps F g, In g hyps F -> interp_ctx hyps F [[g]]. induction F;simpl. @@ -158,7 +158,7 @@ subst;apply compose0;simpl;trivial. apply compose1 with [[g]];auto. Qed. -Theorem project : forall hyps F p g, +Theorem project : forall hyps F p g, get p hyps = PSome g-> interp_ctx hyps F [[g]]. intros hyps F p g e; apply project_In. @@ -186,23 +186,23 @@ Notation "hyps \ A" := (push A hyps) (at level 72,left associativity). Fixpoint check_proof (hyps:ctx) (gl:form) (P:proof) {struct P}: bool := match P with - Ax i => + Ax i => match get i hyps with PSome F => form_eq F gl | _ => false - end + end | I_Arrow p => match gl with A =>> B => check_proof (hyps \ A) B p - | _ => false - end + | _ => false + end | E_Arrow i j p => match get i hyps,get j hyps with PSome A,PSome (B =>>C) => form_eq A B && check_proof (hyps \ C) (gl) p | _,_ => false end -| D_Arrow i p1 p2 => +| D_Arrow i p1 p2 => match get i hyps with PSome ((A =>>B)=>>C) => (check_proof ( hyps \ B =>> C \ A) B p1) && (check_proof (hyps \ C) gl p2) @@ -219,12 +219,12 @@ Fixpoint check_proof (hyps:ctx) (gl:form) (P:proof) {struct P}: bool := check_proof hyps A p1 && check_proof hyps B p2 | _ => false end -| E_And i p => +| E_And i p => match get i hyps with PSome (A //\\ B) => check_proof (hyps \ A \ B) gl p | _=> false end -| D_And i p => +| D_And i p => match get i hyps with PSome (A //\\ B =>> C) => check_proof (hyps \ A=>>B=>>C) gl p | _=> false @@ -245,7 +245,7 @@ Fixpoint check_proof (hyps:ctx) (gl:form) (P:proof) {struct P}: bool := check_proof (hyps \ A) gl p1 && check_proof (hyps \ B) gl p2 | _=> false end -| D_Or i p => +| D_Or i p => match get i hyps with PSome (A \\// B =>> C) => (check_proof (hyps \ A=>>C \ B=>>C) gl p) @@ -253,10 +253,10 @@ Fixpoint check_proof (hyps:ctx) (gl:form) (P:proof) {struct P}: bool := end | Cut A p1 p2 => check_proof hyps A p1 && check_proof (hyps \ A) gl p2 -end. +end. -Theorem interp_proof: -forall p hyps F gl, +Theorem interp_proof: +forall p hyps F gl, check_proof hyps gl p = true -> interp_ctx hyps F [[gl]]. induction p;intros hyps F gl. @@ -281,7 +281,7 @@ intros f ef;caseq (get p0 hyps);clean. intros f0 ef0;destruct f0;clean. caseq (form_eq f f0_1);clean. simpl;intros e check_p1. -generalize (project F ef) (project F ef0) +generalize (project F ef) (project F ef0) (IHp (hyps \ f0_2) (F_push f0_2 hyps F) gl check_p1); clear check_p1 IHp p p0 p1 ef ef0. simpl. @@ -297,7 +297,7 @@ destruct f1;clean. caseq (check_proof (hyps \ f1_2 =>> f2 \ f1_1) f1_2 p2);clean. intros check_p1 check_p2. generalize (project F ef) -(IHp1 (hyps \ f1_2 =>> f2 \ f1_1) +(IHp1 (hyps \ f1_2 =>> f2 \ f1_1) (F_push f1_1 (hyps \ f1_2 =>> f2) (F_push (f1_2 =>> f2) hyps F)) f1_2 check_p1) (IHp2 (hyps \ f2) (F_push f2 hyps F) gl check_p2). @@ -331,7 +331,7 @@ simpl;caseq (get p hyps);clean. intros f ef;destruct f;clean. destruct f1;clean. intro H;generalize (project F ef) -(IHp (hyps \ f1_1 =>> f1_2 =>> f2) +(IHp (hyps \ f1_1 =>> f1_2 =>> f2) (F_push (f1_1 =>> f1_2 =>> f2) hyps F) gl H);clear H;simpl. apply compose2;auto. @@ -364,7 +364,7 @@ intros f ef;destruct f;clean. destruct f1;clean. intro check_p0;generalize (project F ef) (IHp (hyps \ f1_1 =>> f2 \ f1_2 =>> f2) -(F_push (f1_2 =>> f2) (hyps \ f1_1 =>> f2) +(F_push (f1_2 =>> f2) (hyps \ f1_1 =>> f2) (F_push (f1_1 =>> f2) hyps F)) gl check_p0);simpl. apply compose2;auto. @@ -372,7 +372,7 @@ apply compose2;auto. Focus 1. simpl;caseq (check_proof hyps f p1);clean. intros check_p1 check_p2; -generalize (IHp1 hyps F f check_p1) +generalize (IHp1 hyps F f check_p1) (IHp2 (hyps\f) (F_push f hyps F) gl check_p2); simpl; apply compose2;auto. Qed. @@ -392,8 +392,8 @@ Parameters A B C D:Prop. Theorem toto:A /\ (B \/ C) -> (A /\ B) \/ (A /\ C). exact (Reflect (empty \ A \ B \ C) ([1] //\\ ([2] \\// [3]) =>> [1] //\\ [2] \\// [1] //\\ [3]) -(I_Arrow (E_And 1 (E_Or 3 - (I_Or_l (I_And (Ax 2) (Ax 4))) +(I_Arrow (E_And 1 (E_Or 3 + (I_Or_l (I_And (Ax 2) (Ax 4))) (I_Or_r (I_And (Ax 2) (Ax 4))))))). Qed. Print toto. diff --git a/plugins/rtauto/proof_search.ml b/plugins/rtauto/proof_search.ml index 1fee72a601..562e2e3bdb 100644 --- a/plugins/rtauto/proof_search.ml +++ b/plugins/rtauto/proof_search.ml @@ -9,7 +9,7 @@ (* $Id$ *) open Term -open Util +open Util open Goptions type s_info= @@ -54,12 +54,12 @@ let opt_pruning= optread=(fun () -> !pruning); optwrite=(fun b -> pruning:=b)} -let _ = declare_bool_option opt_pruning +let _ = declare_bool_option opt_pruning type form= Atom of int | Arrow of form * form - | Bot + | Bot | Conjunct of form * form | Disjunct of form * form @@ -67,14 +67,14 @@ type tag=int let decomp_form=function Atom i -> Some (i,[]) - | Arrow (f1,f2) -> Some (-1,[f1;f2]) + | Arrow (f1,f2) -> Some (-1,[f1;f2]) | Bot -> Some (-2,[]) | Conjunct (f1,f2) -> Some (-3,[f1;f2]) | Disjunct (f1,f2) -> Some (-4,[f1;f2]) module Fmap=Map.Make(struct type t=form let compare=compare end) -type sequent = +type sequent = {rev_hyps: form Intmap.t; norev_hyps: form Intmap.t; size:int; @@ -103,14 +103,14 @@ type proof = | E_Or of int*proof*proof | D_Or of int*proof | Pop of int*proof - + type rule = SAx of int - | SI_Arrow + | SI_Arrow | SE_Arrow of int*int | SD_Arrow of int | SE_False of int - | SI_And + | SI_And | SE_And of int | SD_And of int | SI_Or_l @@ -132,9 +132,9 @@ let add_step s sub = | SI_Or_r,[p] -> I_Or_r p | SE_Or i,[p1;p2] -> E_Or(i,p1,p2) | SD_Or i,[p] -> D_Or(i,p) - | _,_ -> anomaly "add_step: wrong arity" - -type 'a with_deps = + | _,_ -> anomaly "add_step: wrong arity" + +type 'a with_deps = {dep_it:'a; dep_goal:bool; dep_hyps:Intset.t} @@ -148,7 +148,7 @@ type slice= changes_goal:bool; creates_hyps:Intset.t} -type state = +type state = Complete of proof | Incomplete of sequent * slice list @@ -164,15 +164,15 @@ let pop n prf = {prf with dep_it = nprf} let rec fill stack proof = - match stack with + match stack with [] -> Complete proof.dep_it | slice::super -> - if + if !pruning && slice.proofs_done=[] && not (slice.changes_goal && proof.dep_goal) && - not (Intset.exists - (fun i -> Intset.mem i proof.dep_hyps) + not (Intset.exists + (fun i -> Intset.mem i proof.dep_hyps) slice.creates_hyps) then begin @@ -181,23 +181,23 @@ let rec fill stack proof = List.length slice.proofs_todo; let created_here=Intset.cardinal slice.creates_hyps in s_info.pruned_hyps<-s_info.pruned_hyps+ - List.fold_left - (fun sum dseq -> sum + Intset.cardinal dseq.dep_hyps) + List.fold_left + (fun sum dseq -> sum + Intset.cardinal dseq.dep_hyps) created_here slice.proofs_todo; fill super (pop (Intset.cardinal slice.creates_hyps) proof) end else let dep_hyps= - Intset.union slice.needs_hyps + Intset.union slice.needs_hyps (Intset.diff proof.dep_hyps slice.creates_hyps) in let dep_goal= - slice.needs_goal || + slice.needs_goal || ((not slice.changes_goal) && proof.dep_goal) in let proofs_done= proof.dep_it::slice.proofs_done in match slice.proofs_todo with [] -> - fill super {dep_it = + fill super {dep_it = add_step slice.step (List.rev proofs_done); dep_goal = dep_goal; dep_hyps = dep_hyps} @@ -214,8 +214,8 @@ let rec fill stack proof = let append stack (step,subgoals) = s_info.created_steps<-s_info.created_steps+1; - match subgoals with - [] -> + match subgoals with + [] -> s_info.branch_successes<-s_info.branch_successes+1; fill stack {dep_it=add_step step.dep_it []; dep_goal=step.dep_goal; @@ -239,10 +239,10 @@ let embed seq= dep_hyps=Intset.empty} let change_goal seq gl= - {seq with + {seq with dep_it={seq.dep_it with gl=gl}; dep_goal=true} - + let add_hyp seqwd f= s_info.created_hyps<-s_info.created_hyps+1; let seq=seqwd.dep_it in @@ -256,71 +256,71 @@ let add_hyp seqwd f= with Not_found -> seq.cnx,seq.right in let nseq= match f with - Bot -> - {seq with + Bot -> + {seq with left=left; right=right; size=num; abs=Some num; cnx=cnx} | Atom _ -> - {seq with + {seq with size=num; left=left; right=right; cnx=cnx} | Conjunct (_,_) | Disjunct (_,_) -> {seq with - rev_hyps=Intmap.add num f seq.rev_hyps; + rev_hyps=Intmap.add num f seq.rev_hyps; size=num; left=left; right=right; cnx=cnx} | Arrow (f1,f2) -> let ncnx,nright= - try - let i = Fmap.find f1 seq.left in + try + let i = Fmap.find f1 seq.left in (i,num,f1,f2)::cnx,right with Not_found -> cnx,(add_one_arrow num f1 f2 right) in match f1 with Conjunct (_,_) | Disjunct (_,_) -> {seq with - rev_hyps=Intmap.add num f seq.rev_hyps; + rev_hyps=Intmap.add num f seq.rev_hyps; size=num; left=left; right=nright; cnx=ncnx} | Arrow(_,_) -> {seq with - norev_hyps=Intmap.add num f seq.norev_hyps; + norev_hyps=Intmap.add num f seq.norev_hyps; size=num; left=left; right=nright; cnx=ncnx} - | _ -> + | _ -> {seq with size=num; left=left; right=nright; cnx=ncnx} in - {seqwd with + {seqwd with dep_it=nseq; dep_hyps=Intset.add num seqwd.dep_hyps} exception Here_is of (int*form) -let choose m= - try +let choose m= + try Intmap.iter (fun i f -> raise (Here_is (i,f))) m; raise Not_found - with + with Here_is (i,f) -> (i,f) let search_or seq= match seq.gl with - Disjunct (f1,f2) -> + Disjunct (f1,f2) -> [{dep_it = SI_Or_l; dep_goal = true; dep_hyps = Intset.empty}, @@ -333,19 +333,19 @@ let search_or seq= let search_norev seq= let goals=ref (search_or seq) in - let add_one i f= + let add_one i f= match f with Arrow (Arrow (f1,f2),f3) -> - let nseq = + let nseq = {seq with norev_hyps=Intmap.remove i seq.norev_hyps} in goals:= ({dep_it=SD_Arrow(i); dep_goal=false; dep_hyps=Intset.singleton i}, - [add_hyp - (add_hyp - (change_goal (embed nseq) f2) - (Arrow(f2,f3))) + [add_hyp + (add_hyp + (change_goal (embed nseq) f2) + (Arrow(f2,f3))) f1; add_hyp (embed nseq) f3]):: !goals | _ -> anomaly "search_no_rev: can't happen" in @@ -353,7 +353,7 @@ let search_norev seq= List.rev !goals let search_in_rev_hyps seq= - try + try let i,f=choose seq.rev_hyps in let make_step step= {dep_it=step; @@ -361,25 +361,25 @@ let search_in_rev_hyps seq= dep_hyps=Intset.singleton i} in let nseq={seq with rev_hyps=Intmap.remove i seq.rev_hyps} in match f with - Conjunct (f1,f2) -> + Conjunct (f1,f2) -> [make_step (SE_And(i)), [add_hyp (add_hyp (embed nseq) f1) f2]] | Disjunct (f1,f2) -> [make_step (SE_Or(i)), [add_hyp (embed nseq) f1;add_hyp (embed nseq) f2]] - | Arrow (Conjunct (f1,f2),f0) -> + | Arrow (Conjunct (f1,f2),f0) -> [make_step (SD_And(i)), [add_hyp (embed nseq) (Arrow (f1,Arrow (f2,f0)))]] | Arrow (Disjunct (f1,f2),f0) -> [make_step (SD_Or(i)), [add_hyp (add_hyp (embed nseq) (Arrow(f1,f0))) (Arrow (f2,f0))]] - | _ -> anomaly "search_in_rev_hyps: can't happen" + | _ -> anomaly "search_in_rev_hyps: can't happen" with Not_found -> search_norev seq - + let search_rev seq= match seq.cnx with - (i,j,f1,f2)::next -> + (i,j,f1,f2)::next -> let nseq= match f1 with Conjunct (_,_) | Disjunct (_,_) -> @@ -394,7 +394,7 @@ let search_rev seq= dep_goal=false; dep_hyps=Intset.add i (Intset.singleton j)}, [add_hyp (embed nseq) f2]] - | [] -> + | [] -> match seq.gl with Arrow (f1,f2) -> [{dep_it=SI_Arrow; @@ -410,19 +410,19 @@ let search_rev seq= let search_all seq= match seq.abs with - Some i -> + Some i -> [{dep_it=SE_False (i); dep_goal=false; dep_hyps=Intset.singleton i},[]] | None -> - try + try let ax = Fmap.find seq.gl seq.left in [{dep_it=SAx (ax); dep_goal=true; dep_hyps=Intset.singleton ax},[]] with Not_found -> search_rev seq -let bare_sequent = embed +let bare_sequent = embed {rev_hyps=Intmap.empty; norev_hyps=Intmap.empty; size=0; @@ -431,7 +431,7 @@ let bare_sequent = embed cnx=[]; abs=None; gl=Bot} - + let init_state hyps gl= let init = change_goal bare_sequent gl in let goal=List.fold_right (fun (_,f,_) seq ->add_hyp seq f) hyps init in @@ -448,12 +448,12 @@ let branching = function let _ = match successors with [] -> s_info.branch_failures<-s_info.branch_failures+1 - | _::next -> + | _::next -> s_info.nd_branching<-s_info.nd_branching+List.length next in List.map (append stack) successors | Complete prf -> anomaly "already succeeded" -open Pp +open Pp let rec pp_form = function @@ -470,13 +470,13 @@ and pp_and = function and pp_atom= function Bot -> str "#" | Atom n -> int n - | f -> str "(" ++ hv 2 (pp_form f) ++ str ")" + | f -> str "(" ++ hv 2 (pp_form f) ++ str ")" let pr_form f = msg (pp_form f) -let pp_intmap map = - let pp=ref (str "") in - Intmap.iter (fun i obj -> pp:= (!pp ++ +let pp_intmap map = + let pp=ref (str "") in + Intmap.iter (fun i obj -> pp:= (!pp ++ pp_form obj ++ cut ())) map; str "{ " ++ v 0 (!pp) ++ str " }" @@ -486,17 +486,17 @@ let pp=ref (str "") in str "[ " ++ !pp ++ str "]" let pp_mapint map = - let pp=ref (str "") in - Fmap.iter (fun obj l -> pp:= (!pp ++ - pp_form obj ++ str " => " ++ - pp_list (fun (i,f) -> pp_form f) l ++ + let pp=ref (str "") in + Fmap.iter (fun obj l -> pp:= (!pp ++ + pp_form obj ++ str " => " ++ + pp_list (fun (i,f) -> pp_form f) l ++ cut ()) ) map; str "{ " ++ vb 0 ++ (!pp) ++ str " }" ++ close () let pp_connect (i,j,f1,f2) = pp_form f1 ++ str " => " ++ pp_form f2 let pp_gl gl= cut () ++ - str "{ " ++ vb 0 ++ + str "{ " ++ vb 0 ++ begin match gl.abs with None -> str "" @@ -504,38 +504,38 @@ let pp_gl gl= cut () ++ end ++ str "rev =" ++ pp_intmap gl.rev_hyps ++ cut () ++ str "norev =" ++ pp_intmap gl.norev_hyps ++ cut () ++ - str "arrows=" ++ pp_mapint gl.right ++ cut () ++ - str "cnx =" ++ pp_list pp_connect gl.cnx ++ cut () ++ + str "arrows=" ++ pp_mapint gl.right ++ cut () ++ + str "cnx =" ++ pp_list pp_connect gl.cnx ++ cut () ++ str "goal =" ++ pp_form gl.gl ++ str " }" ++ close () -let pp = +let pp = function Incomplete(gl,ctx) -> msgnl (pp_gl gl) | _ -> msg (str "<complete>") -let pp_info () = - let count_info = +let pp_info () = + let count_info = if !pruning then - str "Proof steps : " ++ - int s_info.created_steps ++ str " created / " ++ + str "Proof steps : " ++ + int s_info.created_steps ++ str " created / " ++ int s_info.pruned_steps ++ str " pruned" ++ fnl () ++ - str "Proof branches : " ++ - int s_info.created_branches ++ str " created / " ++ + str "Proof branches : " ++ + int s_info.created_branches ++ str " created / " ++ int s_info.pruned_branches ++ str " pruned" ++ fnl () ++ - str "Hypotheses : " ++ - int s_info.created_hyps ++ str " created / " ++ + str "Hypotheses : " ++ + int s_info.created_hyps ++ str " created / " ++ int s_info.pruned_hyps ++ str " pruned" ++ fnl () else str "Pruning is off" ++ fnl () ++ - str "Proof steps : " ++ + str "Proof steps : " ++ int s_info.created_steps ++ str " created" ++ fnl () ++ - str "Proof branches : " ++ + str "Proof branches : " ++ int s_info.created_branches ++ str " created" ++ fnl () ++ - str "Hypotheses : " ++ + str "Hypotheses : " ++ int s_info.created_hyps ++ str " created" ++ fnl () in msgnl ( str "Proof-search statistics :" ++ fnl () ++ - count_info ++ + count_info ++ str "Branch ends: " ++ int s_info.branch_successes ++ str " successes / " ++ int s_info.branch_failures ++ str " failures" ++ fnl () ++ @@ -543,4 +543,4 @@ let pp_info () = int s_info.nd_branching ++ str " branches") - + diff --git a/plugins/rtauto/proof_search.mli b/plugins/rtauto/proof_search.mli index a0e86b8d6b..e52f6bbdc5 100644 --- a/plugins/rtauto/proof_search.mli +++ b/plugins/rtauto/proof_search.mli @@ -11,10 +11,10 @@ type form= Atom of int | Arrow of form * form - | Bot + | Bot | Conjunct of form * form | Disjunct of form * form - + type proof = Ax of int | I_Arrow of proof diff --git a/plugins/rtauto/refl_tauto.ml b/plugins/rtauto/refl_tauto.ml index b47bbaa93f..23cb07050a 100644 --- a/plugins/rtauto/refl_tauto.ml +++ b/plugins/rtauto/refl_tauto.ml @@ -18,24 +18,24 @@ open Evd open Tacmach open Proof_search -let force count lazc = incr count;Lazy.force lazc +let force count lazc = incr count;Lazy.force lazc let step_count = ref 0 -let node_count = ref 0 +let node_count = ref 0 -let logic_constant = - Coqlib.gen_constant "refl_tauto" ["Init";"Logic"] +let logic_constant = + Coqlib.gen_constant "refl_tauto" ["Init";"Logic"] let li_False = lazy (destInd (logic_constant "False")) let li_and = lazy (destInd (logic_constant "and")) let li_or = lazy (destInd (logic_constant "or")) let data_constant = - Coqlib.gen_constant "refl_tauto" ["Init";"Datatypes"] + Coqlib.gen_constant "refl_tauto" ["Init";"Datatypes"] -let l_true_equals_true = - lazy (mkApp(logic_constant "refl_equal", +let l_true_equals_true = + lazy (mkApp(logic_constant "refl_equal", [|data_constant "bool";data_constant "true"|])) let pos_constant = @@ -45,7 +45,7 @@ let l_xI = lazy (pos_constant "xI") let l_xO = lazy (pos_constant "xO") let l_xH = lazy (pos_constant "xH") -let store_constant = +let store_constant = Coqlib.gen_constant "refl_tauto" ["rtauto";"Bintree"] let l_empty = lazy (store_constant "empty") @@ -103,17 +103,17 @@ let rec make_form atom_env gls term = let normalize=special_nf gls in let cciterm=special_whd gls term in match kind_of_term cciterm with - Prod(_,a,b) -> - if not (dependent (mkRel 1) b) && - Retyping.get_sort_family_of + Prod(_,a,b) -> + if not (dependent (mkRel 1) b) && + Retyping.get_sort_family_of (pf_env gls) (Tacmach.project gls) a = InProp - then + then let fa=make_form atom_env gls a in let fb=make_form atom_env gls b in Arrow (fa,fb) else make_atom atom_env (normalize term) - | Cast(a,_,_) -> + | Cast(a,_,_) -> make_form atom_env gls a | Ind ind -> if ind = Lazy.force li_False then @@ -122,7 +122,7 @@ let rec make_form atom_env gls term = make_atom atom_env (normalize term) | App(hd,argv) when Array.length argv = 2 -> begin - try + try let ind = destInd hd in if ind = Lazy.force li_and then let fa=make_form atom_env gls argv.(0) in @@ -139,103 +139,103 @@ let rec make_form atom_env gls term = let rec make_hyps atom_env gls lenv = function [] -> [] - | (_,Some body,typ)::rest -> - make_hyps atom_env gls (typ::body::lenv) rest + | (_,Some body,typ)::rest -> + make_hyps atom_env gls (typ::body::lenv) rest | (id,None,typ)::rest -> let hrec= make_hyps atom_env gls (typ::lenv) rest in - if List.exists (dependent (mkVar id)) lenv || - (Retyping.get_sort_family_of - (pf_env gls) (Tacmach.project gls) typ <> InProp) + if List.exists (dependent (mkVar id)) lenv || + (Retyping.get_sort_family_of + (pf_env gls) (Tacmach.project gls) typ <> InProp) then - hrec + hrec else (id,make_form atom_env gls typ)::hrec let rec build_pos n = - if n<=1 then force node_count l_xH - else if n land 1 = 0 then + if n<=1 then force node_count l_xH + else if n land 1 = 0 then mkApp (force node_count l_xO,[|build_pos (n asr 1)|]) - else + else mkApp (force node_count l_xI,[|build_pos (n asr 1)|]) let rec build_form = function Atom n -> mkApp (force node_count l_Atom,[|build_pos n|]) - | Arrow (f1,f2) -> + | Arrow (f1,f2) -> mkApp (force node_count l_Arrow,[|build_form f1;build_form f2|]) | Bot -> force node_count l_Bot - | Conjunct (f1,f2) -> + | Conjunct (f1,f2) -> mkApp (force node_count l_Conjunct,[|build_form f1;build_form f2|]) - | Disjunct (f1,f2) -> + | Disjunct (f1,f2) -> mkApp (force node_count l_Disjunct,[|build_form f1;build_form f2|]) -let rec decal k = function +let rec decal k = function [] -> k - | (start,delta)::rest -> + | (start,delta)::rest -> if k>start then k - delta - else + else decal k rest let add_pop size d pops= match pops with [] -> [size+d,d] - | (_,sum)::_ -> (size+sum,sum+d)::pops + | (_,sum)::_ -> (size+sum,sum+d)::pops -let rec build_proof pops size = +let rec build_proof pops size = function Ax i -> mkApp (force step_count l_Ax, [|build_pos (decal i pops)|]) - | I_Arrow p -> + | I_Arrow p -> mkApp (force step_count l_I_Arrow, [|build_proof pops (size + 1) p|]) - | E_Arrow(i,j,p) -> - mkApp (force step_count l_E_Arrow, + | E_Arrow(i,j,p) -> + mkApp (force step_count l_E_Arrow, [|build_pos (decal i pops); build_pos (decal j pops); build_proof pops (size + 1) p|]) - | D_Arrow(i,p1,p2) -> - mkApp (force step_count l_D_Arrow, + | D_Arrow(i,p1,p2) -> + mkApp (force step_count l_D_Arrow, [|build_pos (decal i pops); build_proof pops (size + 2) p1; build_proof pops (size + 1) p2|]) - | E_False i -> + | E_False i -> mkApp (force step_count l_E_False, [|build_pos (decal i pops)|]) - | I_And(p1,p2) -> - mkApp (force step_count l_I_And, + | I_And(p1,p2) -> + mkApp (force step_count l_I_And, [|build_proof pops size p1; build_proof pops size p2|]) - | E_And(i,p) -> + | E_And(i,p) -> mkApp (force step_count l_E_And, [|build_pos (decal i pops); build_proof pops (size + 2) p|]) - | D_And(i,p) -> + | D_And(i,p) -> mkApp (force step_count l_D_And, [|build_pos (decal i pops); build_proof pops (size + 1) p|]) - | I_Or_l(p) -> + | I_Or_l(p) -> mkApp (force step_count l_I_Or_l, [|build_proof pops size p|]) - | I_Or_r(p) -> + | I_Or_r(p) -> mkApp (force step_count l_I_Or_r, [|build_proof pops size p|]) | E_Or(i,p1,p2) -> - mkApp (force step_count l_E_Or, + mkApp (force step_count l_E_Or, [|build_pos (decal i pops); build_proof pops (size + 1) p1; build_proof pops (size + 1) p2|]) - | D_Or(i,p) -> + | D_Or(i,p) -> mkApp (force step_count l_D_Or, [|build_pos (decal i pops); build_proof pops (size + 2) p|]) | Pop(d,p) -> - build_proof (add_pop size d pops) size p - + build_proof (add_pop size d pops) size p + let build_env gamma= - List.fold_right (fun (p,_) e -> - mkApp(force node_count l_push,[|mkProp;p;e|])) + List.fold_right (fun (p,_) e -> + mkApp(force node_count l_push,[|mkProp;p;e|])) gamma.env (mkApp (force node_count l_empty,[|mkProp|])) open Goptions @@ -249,7 +249,7 @@ let opt_verbose= optread=(fun () -> !verbose); optwrite=(fun b -> verbose:=b)} -let _ = declare_bool_option opt_verbose +let _ = declare_bool_option opt_verbose let check = ref false @@ -260,7 +260,7 @@ let opt_check= optread=(fun () -> !check); optwrite=(fun b -> check:=b)} -let _ = declare_bool_option opt_check +let _ = declare_bool_option opt_check open Pp @@ -269,34 +269,34 @@ let rtauto_tac gls= let gamma={next=1;env=[]} in let gl=gls.it.evar_concl in let _= - if Retyping.get_sort_family_of - (pf_env gls) (Tacmach.project gls) gl <> InProp + if Retyping.get_sort_family_of + (pf_env gls) (Tacmach.project gls) gl <> InProp then errorlabstrm "rtauto" (Pp.str "goal should be in Prop") in let glf=make_form gamma gls gl in - let hyps=make_hyps gamma gls [gl] + let hyps=make_hyps gamma gls [gl] (Environ.named_context_of_val gls.it.evar_hyps) in let formula= - List.fold_left (fun gl (_,f)-> Arrow (f,gl)) glf hyps in - let search_fun = + List.fold_left (fun gl (_,f)-> Arrow (f,gl)) glf hyps in + let search_fun = if Tacinterp.get_debug()=Tactic_debug.DebugOn 0 then Search.debug_depth_first - else + else Search.depth_first in - let _ = + let _ = begin reset_info (); if !verbose then msgnl (str "Starting proof-search ..."); end in let search_start_time = System.get_time () in - let prf = - try project (search_fun (init_state [] formula)) + let prf = + try project (search_fun (init_state [] formula)) with Not_found -> errorlabstrm "rtauto" (Pp.str "rtauto couldn't find any proof") in let search_end_time = System.get_time () in let _ = if !verbose then begin - msgnl (str "Proof tree found in " ++ + msgnl (str "Proof tree found in " ++ System.fmt_time_difference search_start_time search_end_time); pp_info (); msgnl (str "Building proof term ... ") @@ -312,10 +312,10 @@ let rtauto_tac gls= let build_end_time=System.get_time () in let _ = if !verbose then begin - msgnl (str "Proof term built in " ++ + msgnl (str "Proof term built in " ++ System.fmt_time_difference build_start_time build_end_time ++ fnl () ++ - str "Proof size : " ++ int !step_count ++ + str "Proof size : " ++ int !step_count ++ str " steps" ++ fnl () ++ str "Proof term size : " ++ int (!step_count+ !node_count) ++ str " nodes (constants)" ++ fnl () ++ @@ -323,15 +323,15 @@ let rtauto_tac gls= end in let tac_start_time = System.get_time () in let result= - if !check then + if !check then Tactics.exact_check term gls else Tactics.exact_no_check term gls in let tac_end_time = System.get_time () in - let _ = + let _ = if !check then msgnl (str "Proof term type-checking is on"); if !verbose then - msgnl (str "Internal tactic executed in " ++ + msgnl (str "Internal tactic executed in " ++ System.fmt_time_difference tac_start_time tac_end_time) in result diff --git a/plugins/setoid_ring/ArithRing.v b/plugins/setoid_ring/ArithRing.v index 601cabe003..e5a4c8d179 100644 --- a/plugins/setoid_ring/ArithRing.v +++ b/plugins/setoid_ring/ArithRing.v @@ -16,11 +16,11 @@ Lemma natSRth : semi_ring_theory O (S O) plus mult (@eq nat). Proof. constructor. exact plus_0_l. exact plus_comm. exact plus_assoc. exact mult_1_l. exact mult_0_l. exact mult_comm. exact mult_assoc. - exact mult_plus_distr_r. + exact mult_plus_distr_r. Qed. -Lemma nat_morph_N : - semi_morph 0 1 plus mult (eq (A:=nat)) +Lemma nat_morph_N : + semi_morph 0 1 plus mult (eq (A:=nat)) 0%N 1%N Nplus Nmult Neq_bool nat_of_N. Proof. constructor;trivial. @@ -46,7 +46,7 @@ Ltac natprering := |- context C [S ?p] => match p with O => fail 1 (* avoid replacing 1 with 1+0 ! *) - | p => match isnatcst p with + | p => match isnatcst p with | true => fail 1 | false => let v := Ss_to_add p (S 0) in fold v; natprering diff --git a/plugins/setoid_ring/BinList.v b/plugins/setoid_ring/BinList.v index 5090200429..d403c9efe2 100644 --- a/plugins/setoid_ring/BinList.v +++ b/plugins/setoid_ring/BinList.v @@ -28,17 +28,17 @@ Section MakeBinList. | xH => hd default l | xO p => nth p (jump p l) | xI p => nth p (jump p (tail l)) - end. + end. Lemma jump_tl : forall j l, tail (jump j l) = jump j (tail l). - Proof. + Proof. induction j;simpl;intros. repeat rewrite IHj;trivial. repeat rewrite IHj;trivial. trivial. Qed. - Lemma jump_Psucc : forall j l, + Lemma jump_Psucc : forall j l, (jump (Psucc j) l) = (jump 1 (jump j l)). Proof. induction j;simpl;intros. @@ -47,7 +47,7 @@ Section MakeBinList. trivial. Qed. - Lemma jump_Pplus : forall i j l, + Lemma jump_Pplus : forall i j l, (jump (i + j) l) = (jump i (jump j l)). Proof. induction i;intros. @@ -69,7 +69,7 @@ Section MakeBinList. trivial. Qed. - + Lemma nth_jump : forall p l, nth p (tail l) = hd default (jump p l). Proof. induction p;simpl;intros. diff --git a/plugins/setoid_ring/Field_tac.v b/plugins/setoid_ring/Field_tac.v index 0082eb9afc..7aff8e0cbb 100644 --- a/plugins/setoid_ring/Field_tac.v +++ b/plugins/setoid_ring/Field_tac.v @@ -10,27 +10,27 @@ Require Import Ring_tac BinList Ring_polynom InitialRing. Require Export Field_theory. (* syntaxification *) - Ltac mkFieldexpr C Cst CstPow radd rmul rsub ropp rdiv rinv rpow t fv := + Ltac mkFieldexpr C Cst CstPow radd rmul rsub ropp rdiv rinv rpow t fv := let rec mkP t := let f := match Cst t with | InitialRing.NotConstant => - match t with - | (radd ?t1 ?t2) => + match t with + | (radd ?t1 ?t2) => fun _ => let e1 := mkP t1 in let e2 := mkP t2 in constr:(FEadd e1 e2) - | (rmul ?t1 ?t2) => + | (rmul ?t1 ?t2) => fun _ => let e1 := mkP t1 in let e2 := mkP t2 in constr:(FEmul e1 e2) - | (rsub ?t1 ?t2) => - fun _ => + | (rsub ?t1 ?t2) => + fun _ => let e1 := mkP t1 in let e2 := mkP t2 in constr:(FEsub e1 e2) | (ropp ?t1) => fun _ => let e1 := mkP t1 in constr:(FEopp e1) - | (rdiv ?t1 ?t2) => + | (rdiv ?t1 ?t2) => fun _ => let e1 := mkP t1 in let e2 := mkP t2 in constr:(FEdiv e1 e2) @@ -38,7 +38,7 @@ Require Export Field_theory. fun _ => let e1 := mkP t1 in constr:(FEinv e1) | (rpow ?t1 ?n) => match CstPow n with - | InitialRing.NotConstant => + | InitialRing.NotConstant => fun _ => let p := Find_at t fv in constr:(@FEX C p) @@ -74,7 +74,7 @@ Ltac FFV Cst CstPow add mul sub opp div inv pow t fv := | _ => AddFvTail t fv end | _ => fv - end + end in TFV t fv. (* packaging the field structure *) @@ -83,7 +83,7 @@ Ltac FFV Cst CstPow add mul sub opp div inv pow t fv := Ltac PackField F req Cst_tac Pow_tac L1 L2 L3 L4 cond_ok pre post := let FLD := match type of L1 with - | context [req (@FEeval ?R ?rO ?radd ?rmul ?rsub ?ropp ?rdiv ?rinv + | context [req (@FEeval ?R ?rO ?radd ?rmul ?rsub ?ropp ?rdiv ?rinv ?C ?phi ?Cpow ?Cp_phi ?rpow _ _) _ ] => (fun proj => proj Cst_tac Pow_tac pre post @@ -245,9 +245,9 @@ Ltac Field_norm_gen f n FLD lH rl := ReflexiveRewriteTactic mkFFV mkFE lemma_tac main_tac fv0 rl; try simpl_PCond FLD. -Ltac Field_simplify_gen f FLD lH rl := +Ltac Field_simplify_gen f FLD lH rl := get_FldPre FLD (); - Field_norm_gen f ring_subst_niter FLD lH rl; + Field_norm_gen f ring_subst_niter FLD lH rl; get_FldPost FLD (). Ltac Field_simplify := @@ -257,14 +257,14 @@ Tactic Notation (at level 0) "field_simplify" constr_list(rl) := let G := Get_goal in field_lookup (PackField Field_simplify) [] rl G. -Tactic Notation (at level 0) +Tactic Notation (at level 0) "field_simplify" "[" constr_list(lH) "]" constr_list(rl) := let G := Get_goal in field_lookup (PackField Field_simplify) [lH] rl G. -Tactic Notation "field_simplify" constr_list(rl) "in" hyp(H):= +Tactic Notation "field_simplify" constr_list(rl) "in" hyp(H):= let G := Get_goal in - let t := type of H in + let t := type of H in let g := fresh "goal" in set (g:= G); revert H; @@ -272,10 +272,10 @@ Tactic Notation "field_simplify" constr_list(rl) "in" hyp(H):= intro H; unfold g;clear g. -Tactic Notation "field_simplify" - "["constr_list(lH) "]" constr_list(rl) "in" hyp(H):= +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 t := type of H in let g := fresh "goal" in set (g:= G); revert H; @@ -284,15 +284,15 @@ Tactic Notation "field_simplify" unfold g;clear g. (* -Ltac Field_simplify_in hyp:= +Ltac Field_simplify_in hyp:= Field_simplify_gen ltac:(fun H => rewrite H in hyp). -Tactic Notation (at level 0) +Tactic Notation (at level 0) "field_simplify" constr_list(rl) "in" hyp(h) := let t := type of h in field_lookup (Field_simplify_in h) [] rl t. -Tactic Notation (at level 0) +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. @@ -317,10 +317,10 @@ Ltac Field_Scheme Simpl_tac n lemma FLD lH := pose (vlpe := lpe); let nlemma := fresh "field_lemma" in (assert (nlemma := lemma n fv vlpe fe1 fe2 prh) - || fail "field anomaly:failed to build lemma"); + || fail "field anomaly:failed to build lemma"); ProveLemmaHyps nlemma ltac:(fun ilemma => - apply ilemma + apply ilemma || fail "field anomaly: failed in applying lemma"; [ Simpl_tac | simpl_PCond FLD]); clear nlemma; @@ -333,11 +333,11 @@ Ltac Field_Scheme Simpl_tac n lemma FLD lH := Ltac FIELD FLD lH rl := let Simpl := vm_compute; reflexivity || fail "not a valid field equation" in let lemma := get_L1 FLD in - get_FldPre FLD (); + get_FldPre FLD (); Field_Scheme Simpl Ring_tac.ring_subst_niter lemma FLD lH; try exact I; get_FldPost FLD(). - + Tactic Notation (at level 0) "field" := let G := Get_goal in field_lookup (PackField FIELD) [] G. @@ -351,15 +351,15 @@ Tactic Notation (at level 0) "field" "[" constr_list(lH) "]" := Ltac FIELD_SIMPL FLD lH rl := let Simpl := (protect_fv "field") in let lemma := get_SimplifyEqLemma FLD in - get_FldPre FLD (); + get_FldPre FLD (); Field_Scheme Simpl Ring_tac.ring_subst_niter lemma FLD lH; get_FldPost FLD (). -Tactic Notation (at level 0) "field_simplify_eq" := +Tactic Notation (at level 0) "field_simplify_eq" := let G := Get_goal in field_lookup (PackField FIELD_SIMPL) [] G. -Tactic Notation (at level 0) "field_simplify_eq" "[" constr_list(lH) "]" := +Tactic Notation (at level 0) "field_simplify_eq" "[" constr_list(lH) "]" := let G := Get_goal in field_lookup FIELD_SIMPL [lH] G. @@ -372,7 +372,7 @@ Ltac Field_simplify_eq n FLD lH := let mkFE := get_Meta FLD in let lemma := get_L4 FLD in let hyp := fresh "hyp" in - intro hyp; + intro hyp; OnEquationHyp req hyp ltac:(fun t1 t2 => let fv := FV_hypo_tac mkFV req lH in let fv := mkFFV t1 fv in @@ -385,16 +385,16 @@ Ltac Field_simplify_eq n FLD lH := ProveLemmaHyps (lemma n fv lpe fe1 fe2 prh) ltac:(fun ilemma => match type of ilemma with - | req _ _ -> _ -> ?EQ => + | req _ _ -> _ -> ?EQ => let tmp := fresh "tmp" in assert (tmp : EQ); [ apply ilemma; [ exact hyp | simpl_PCond_BEURK FLD] | protect_fv "field" in tmp; revert tmp ]; - clear hyp + clear hyp end)). Ltac FIELD_SIMPL_EQ FLD lH rl := - get_FldPre FLD (); + get_FldPre FLD (); Field_simplify_eq Ring_tac.ring_subst_niter FLD lH; get_FldPost(). @@ -406,15 +406,15 @@ Tactic Notation (at level 0) "field_simplify_eq" "in" hyp(H) := | clear H;intro H]. -Tactic Notation (at level 0) - "field_simplify_eq" "[" constr_list(lH) "]" "in" hyp(H) := +Tactic Notation (at level 0) + "field_simplify_eq" "[" constr_list(lH) "]" "in" hyp(H) := let t := type of H in generalize H; field_lookup (PackField FIELD_SIMPL_EQ) [lH] t; [ try exact I |clear H;intro H]. - -(* More generic tactics to build variants of field *) + +(* More generic tactics to build variants of field *) (* This tactic reifies c and pass to F: - the FLD structure gathering all info in the field DB @@ -489,13 +489,13 @@ Ltac reduce_field_expr ope kont FLD fv expr := (* Hack to let a Ltac return a term in the context of a primitive tactic *) Ltac return_term x := generalize (refl_equal x). Ltac get_term := - match goal with + match goal with | |- ?x = _ -> _ => x end. (* Turn an operation on field expressions (FExpr) into a reduction on terms (in the field carrier). Because of field_lookup, - the tactic cannot return a term directly, so it is returned + the tactic cannot return a term directly, so it is returned via the conclusion of the goal (return_term). *) Ltac reduce_field_ope ope c := gen_with_field ltac:(reduce_field_expr ope return_term) c. @@ -526,7 +526,7 @@ Ltac field_elements set ext fspec pspec sspec dspec rk := 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 + 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 @@ -538,27 +538,27 @@ Ltac field_lemmas set ext inv_m fspec pspec sspec dspec rk := | _ => let field_ok1 := constr:(Field_correct set ext_r inv_m afth morph) in match p_spec with - | mkhypo ?pp_spec => + | mkhypo ?pp_spec => let field_ok2 := constr:(field_ok1 _ _ _ pp_spec) in match s_spec with - | mkhypo ?ss_spec => + | mkhypo ?ss_spec => let field_ok3 := constr:(field_ok2 _ ss_spec) in match d_spec with - | mkhypo ?dd_spec => + | 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 _ dd_spec) in + let mk_lemma lemma := + constr:(lemma _ _ _ _ _ _ _ _ _ _ + set ext_r inv_m afth + _ _ _ _ _ _ _ _ _ morph + _ _ _ 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 := + let cond1_ok := constr:(Pcond_simpl_gen set ext_r afth morph pp_spec dd_spec) in - let cond2_ok := + let cond2_ok := constr:(Pcond_simpl_complete set ext_r afth morph pp_spec dd_spec) in - (fun f => + (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" @@ -566,6 +566,6 @@ Ltac field_lemmas set ext inv_m fspec pspec sspec dspec rk := | _ => fail 3 "field: bad sign specification" end | _ => fail 2 "field: bad power specification" - end + end | _ => fail 1 "field internal error : field_lemmas, please report" end). diff --git a/plugins/setoid_ring/Field_theory.v b/plugins/setoid_ring/Field_theory.v index fd99f786f5..205bef6d57 100644 --- a/plugins/setoid_ring/Field_theory.v +++ b/plugins/setoid_ring/Field_theory.v @@ -14,7 +14,7 @@ Set Implicit Arguments. Section MakeFieldPol. -(* Field elements *) +(* Field elements *) Variable R:Type. Variable (rO rI : R) (radd rmul rsub: R->R->R) (ropp : R->R). Variable (rdiv : R -> R -> R) (rinv : R -> R). @@ -30,7 +30,7 @@ Section MakeFieldPol. Variable Rsth : Setoid_Theory R req. Variable Reqe : ring_eq_ext radd rmul ropp req. Variable SRinv_ext : forall p q, p == q -> / p == / q. - + (* Field properties *) Record almost_field_theory : Prop := mk_afield { AF_AR : almost_ring_theory rO rI radd rmul rsub ropp req; @@ -47,10 +47,10 @@ Section AlmostField. Let rdiv_def := AFth.(AFdiv_def). Let rinv_l := AFth.(AFinv_l). - (* Coefficients *) + (* Coefficients *) Variable C: Type. Variable (cO cI: C) (cadd cmul csub : C->C->C) (copp : C->C). - Variable ceqb : C->C->bool. + Variable ceqb : C->C->bool. Variable phi : C -> R. Variable CRmorph : ring_morph rO rI radd rmul rsub ropp req @@ -65,7 +65,7 @@ case (ceqb c1 c2); auto. Qed. - (* C notations *) + (* C notations *) Notation "x +! y" := (cadd x y) (at level 50). Notation "x *! y " := (cmul x y) (at level 40). Notation "x -! y " := (csub x y) (at level 50). @@ -74,14 +74,14 @@ Qed. Notation "[ x ]" := (phi x) (at level 0). - (* Useful 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. Add Morphism ropp : ropp_ext. exact (Ropp_ext Reqe). Qed. Add Morphism rsub : rsub_ext. exact (ARsub_ext Rsth Reqe ARth). Qed. Add Morphism rinv : rinv_ext. exact SRinv_ext. Qed. - + Let eq_trans := Setoid.Seq_trans _ _ Rsth. Let eq_sym := Setoid.Seq_sym _ _ Rsth. Let eq_refl := Setoid.Seq_refl _ _ Rsth. @@ -90,15 +90,15 @@ Hint Resolve eq_refl rdiv_def rinv_l rI_neq_rO CRmorph.(morph1) . Hint Resolve (Rmul_ext Reqe) (Rmul_ext Reqe) (Radd_ext Reqe) (ARsub_ext Rsth Reqe ARth) (Ropp_ext Reqe) SRinv_ext. Hint Resolve (ARadd_0_l ARth) (ARadd_comm ARth) (ARadd_assoc ARth) - (ARmul_1_l ARth) (ARmul_0_l ARth) + (ARmul_1_l ARth) (ARmul_0_l ARth) (ARmul_comm ARth) (ARmul_assoc ARth) (ARdistr_l ARth) - (ARopp_mul_l ARth) (ARopp_add ARth) + (ARopp_mul_l ARth) (ARopp_add ARth) (ARsub_def ARth) . (* Power coefficients *) Variable Cpow : Set. Variable Cp_phi : N -> Cpow. - Variable rpow : R -> Cpow -> R. + Variable rpow : R -> Cpow -> R. Variable pow_th : power_theory rI rmul req Cp_phi rpow. (* sign function *) Variable get_sign : C -> option C. @@ -129,11 +129,11 @@ rewrite (ARopp_zero Rsth Reqe ARth) in |- *; ring. Qed. (*************************************************************************** - - Properties of division - + + Properties of division + ***************************************************************************) - + Theorem rdiv_simpl: forall p q, ~ q == 0 -> q * (p / q) == p. intros p q H. rewrite rdiv_def in |- *. @@ -141,7 +141,7 @@ transitivity (/ q * q * p); [ ring | idtac ]. rewrite rinv_l in |- *; auto. Qed. Hint Resolve rdiv_simpl . - + Theorem SRdiv_ext: forall p1 p2, p1 == p2 -> forall q1 q2, q1 == q2 -> p1 / q1 == p2 / q2. intros p1 p2 H q1 q2 H0. @@ -195,7 +195,7 @@ Qed. Theorem rdiv1: forall r, r == r / 1. intros r; transitivity (1 * (r / 1)); auto. Qed. - + Theorem rdiv2: forall r1 r2 r3 r4, ~ r2 == 0 -> @@ -224,7 +224,7 @@ intros r1 r2 r3 r4 r5 H H0. assert (HH1: ~ r2 == 0) by (intros HH; case H; rewrite HH; ring). assert (HH2: ~ r5 == 0) by (intros HH; case H; rewrite HH; ring). assert (HH3: ~ r4 == 0) by (intros HH; case H0; rewrite HH; ring). -assert (HH4: ~ r2 * (r4 * r5) == 0) +assert (HH4: ~ r2 * (r4 * r5) == 0) by complete (repeat apply field_is_integral_domain; trivial). apply rmul_reg_l with (r2 * (r4 * r5)); trivial. rewrite rdiv_simpl in |- *; trivial. @@ -288,7 +288,7 @@ assert (~ r1 / r2 == 0) as Hk. repeat rewrite rinv_l in |- *; auto. Qed. Hint Resolve rdiv6 . - + Theorem rdiv4: forall r1 r2 r3 r4, ~ r2 == 0 -> @@ -385,9 +385,9 @@ transitivity (r1 / r2 * (r4 / r4)). Qed. (*************************************************************************** - - Some equality test - + + Some equality test + ***************************************************************************) Fixpoint positive_eq (p1 p2 : positive) {struct p1} : bool := @@ -397,7 +397,7 @@ Fixpoint positive_eq (p1 p2 : positive) {struct p1} : bool := | xI p3, xI p4 => positive_eq p3 p4 | _, _ => false end. - + Theorem positive_eq_correct: forall p1 p2, if positive_eq p1 p2 then p1 = p2 else p1 <> p2. intros p1; elim p1; @@ -411,8 +411,8 @@ generalize (rec p4); case (positive_eq p3 p4); auto. intros H1; apply f_equal with ( f := xO ); auto. intros H1 H2; case H1; injection H2; auto. Qed. - -Definition N_eq n1 n2 := + +Definition N_eq n1 n2 := match n1, n2 with | N0, N0 => true | Npos p1, Npos p2 => positive_eq p1 p2 @@ -438,7 +438,7 @@ Fixpoint PExpr_eq (e1 e2 : PExpr C) {struct e1} : bool := | PEpow e3 n3, PEpow e4 n4 => if N_eq n3 n4 then PExpr_eq e3 e4 else false | _, _ => false end. - + Add Morphism (pow_pos rmul) : pow_morph. intros x y H p;induction p as [p IH| p IH|];simpl;auto;ring[IH]. Qed. @@ -508,10 +508,10 @@ Definition NPEpow x n := | N0 => PEc cI | Npos p => if positive_eq p xH then x else - match x with - | PEc c => - if ceqb c cI then PEc cI else if ceqb c cO then PEc cO else PEc (pow_pos cmul c p) - | _ => PEpow x n + match x with + | PEc c => + if ceqb c cI then PEc cI else if ceqb c cO then PEc cO else PEc (pow_pos cmul c p) + | _ => PEpow x n end end. @@ -530,7 +530,7 @@ Proof. induction p;simpl;auto;repeat rewrite CRmorph.(morph_mul);ring [IHp]. Qed. -(* mul *) +(* mul *) Fixpoint NPEmul (x y : PExpr C) {struct x} : PExpr C := match x, y with PEc c1, PEc c2 => PEc (cmul c1 c2) @@ -546,7 +546,7 @@ Fixpoint NPEmul (x y : PExpr C) {struct x} : PExpr C := Lemma pow_pos_mul : forall x y p, pow_pos rmul (x * y) p == pow_pos rmul x p * pow_pos rmul y p. induction p;simpl;auto;try ring [IHp]. Qed. - + Theorem NPEmul_correct : forall l e1 e2, NPEeval l (NPEmul e1 e2) == NPEeval l (PEmul e1 e2). induction e1;destruct e2; simpl in |- *;try reflexivity; @@ -581,17 +581,17 @@ destruct e1; destruct e2; simpl in |- *; try reflexivity; try apply ceqb_rect; try (symmetry; apply rsub_0_l); try (symmetry; apply rsub_0_r). apply (morph_sub CRmorph). Qed. - + (* opp *) Definition NPEopp e1 := match e1 with PEc c1 => PEc (copp c1) | _ => PEopp e1 end. - + Theorem NPEopp_correct: forall l e1, NPEeval l (NPEopp e1) == NPEeval l (PEopp e1). intros l e1; case e1; simpl; auto. intros; apply (morph_opp CRmorph). Qed. - + (* simplification *) Fixpoint PExpr_simp (e : PExpr C) : PExpr C := match e with @@ -602,7 +602,7 @@ Fixpoint PExpr_simp (e : PExpr C) : PExpr C := | PEpow e1 n1 => NPEpow (PExpr_simp e1) n1 | _ => e end. - + Theorem PExpr_simp_correct: forall l e, NPEeval l (PExpr_simp e) == NPEeval l e. intros l e; elim e; simpl; auto. @@ -630,9 +630,9 @@ Qed. (**************************************************************************** - - Datastructure - + + Datastructure + ***************************************************************************) (* The input: syntax of a field expression *) @@ -647,7 +647,7 @@ Inductive FExpr : Type := | FEinv: FExpr -> FExpr | FEdiv: FExpr -> FExpr -> FExpr | FEpow: FExpr -> N -> FExpr . - + Fixpoint FEeval (l : list R) (pe : FExpr) {struct pe} : R := match pe with | FEc c => phi c @@ -664,7 +664,7 @@ Fixpoint FEeval (l : list R) (pe : FExpr) {struct pe} : R := Strategy expand [FEeval]. (* The result of the normalisation *) - + Record linear : Type := mk_linear { num : PExpr C; denum : PExpr C; @@ -675,7 +675,7 @@ Record linear : Type := mk_linear { Semantics and properties of side condition ***************************************************************************) - + Fixpoint PCond (l : list R) (le : list (PExpr C)) {struct le} : Prop := match le with | nil => True @@ -689,7 +689,7 @@ intros l a l1 H. destruct l1; simpl in H |- *; trivial. destruct H; trivial. Qed. - + Theorem PCond_cons_inv_r : forall l a l1, PCond l (a :: l1) -> PCond l l1. intros l a l1 H. destruct l1; simpl in H |- *; trivial. @@ -703,12 +703,12 @@ intros l l1 l2; elim l1; simpl app in |- *. destruct l2; firstorder. firstorder. Qed. - + Theorem PCond_app_inv_r: forall l l1 l2, PCond l (l1 ++ l2) -> PCond l l2. intros l l1 l2; elim l1; simpl app; auto. intros a l0 H H0; apply H; apply PCond_cons_inv_r with ( 1 := H0 ). Qed. - + (* An unsatisfiable condition: issued when a division by zero is detected *) Definition absurd_PCond := cons (PEc cO) nil. @@ -720,9 +720,9 @@ apply (morph0 CRmorph). Qed. (*************************************************************************** - - Normalisation - + + Normalisation + ***************************************************************************) Fixpoint isIn (e1:PExpr C) (p1:positive) @@ -731,18 +731,18 @@ Fixpoint isIn (e1:PExpr C) (p1:positive) | PEmul e3 e4 => match isIn e1 p1 e3 p2 with | Some (N0, e5) => Some (N0, NPEmul e5 (NPEpow e4 (Npos p2))) - | Some (Npos p, e5) => + | Some (Npos p, e5) => match isIn e1 p e4 p2 with | Some (n, e6) => Some (n, NPEmul e5 e6) | None => Some (Npos p, NPEmul e5 (NPEpow e4 (Npos p2))) end - | None => + | None => match isIn e1 p1 e4 p2 with | Some (n, e5) => Some (n,NPEmul (NPEpow e3 (Npos p2)) e5) | None => None end end - | PEpow e3 N0 => None + | PEpow e3 N0 => None | PEpow e3 (Npos p3) => isIn e1 p1 e3 (Pmult p3 p2) | _ => if PExpr_eq e1 e2 then @@ -751,27 +751,27 @@ Fixpoint isIn (e1:PExpr C) (p1:positive) | Z0 => Some (N0, PEc cI) | Zneg p => Some (N0, NPEpow e2 (Npos p)) end - else None + else None end. - + Definition ZtoN z := match z with Zpos p => Npos p | _ => N0 end. Definition NtoZ n := match n with Npos p => Zpos p | _ => Z0 end. - Notation pow_pos_plus := (Ring_theory.pow_pos_Pplus _ Rsth Reqe.(Rmul_ext) + Notation pow_pos_plus := (Ring_theory.pow_pos_Pplus _ Rsth Reqe.(Rmul_ext) ARth.(ARmul_comm) ARth.(ARmul_assoc)). - Lemma isIn_correct_aux : forall l e1 e2 p1 p2, - match + Lemma isIn_correct_aux : forall l e1 e2 p1 p2, + match (if PExpr_eq e1 e2 then match Zminus (Zpos p1) (Zpos p2) with | Zpos p => Some (Npos p, PEc cI) | Z0 => Some (N0, PEc cI) | Zneg p => Some (N0, NPEpow e2 (Npos p)) end - else None) + else None) with - | Some(n, e3) => - NPEeval l (PEpow e2 (Npos p2)) == + | Some(n, e3) => + NPEeval l (PEpow e2 (Npos p2)) == NPEeval l (PEmul (PEpow e1 (ZtoN (Zpos p1 - NtoZ n))) e3) /\ (Zpos p1 > NtoZ n)%Z | _ => True @@ -779,15 +779,15 @@ Fixpoint isIn (e1:PExpr C) (p1:positive) Proof. intros l e1 e2 p1 p2; generalize (PExpr_eq_semi_correct l e1 e2); case (PExpr_eq e1 e2); simpl; auto; intros H. - case_eq ((p1 ?= p2)%positive Eq);intros;simpl. + 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 (Pcompare_Eq_eq _ _ H0). 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. rewrite H;trivial. split. 2:refine (refl_equal _). - rewrite <- pow_pos_plus; rewrite Pplus_minus;auto. apply ZC2;trivial. + rewrite <- pow_pos_plus; rewrite Pplus_minus;auto. apply ZC2;trivial. repeat rewrite pow_th.(rpow_pow_N);simpl. rewrite H;trivial. change (ZtoN @@ -801,7 +801,7 @@ Proof. repeat rewrite Zth.(Rsub_def). rewrite (Ring_theory.Ropp_add Zsth Zeqe Zth). rewrite Zplus_assoc. simpl. rewrite Pcompare_refl. simpl. ring [ (morph1 CRmorph)]. - assert (Zpos p1 > 0 /\ Zpos p2 > 0)%Z. split;refine (refl_equal _). + assert (Zpos p1 > 0 /\ Zpos p2 > 0)%Z. split;refine (refl_equal _). apply Zplus_gt_reg_l with (Zpos p2). rewrite Zplus_minus. change (Zpos p2 + Zpos p1 > 0 + Zpos p1)%Z. apply Zplus_gt_compat_r. refine (refl_equal _). @@ -815,9 +815,9 @@ Qed. Theorem isIn_correct: forall l e1 p1 e2 p2, - match isIn e1 p1 e2 p2 with - | Some(n, e3) => - NPEeval l (PEpow e2 (Npos p2)) == + match isIn e1 p1 e2 p2 with + | Some(n, e3) => + NPEeval l (PEpow e2 (Npos p2)) == NPEeval l (PEmul (PEpow e1 (ZtoN (Zpos p1 - NtoZ n))) e3) /\ (Zpos p1 > NtoZ n)%Z | _ => True @@ -827,7 +827,7 @@ Opaque NPEpow. intros l e1 p1 e2; generalize p1;clear p1;elim e2; intros; try (refine (isIn_correct_aux l e1 _ p1 p2);fail);simpl isIn. generalize (H p1 p2);clear H;destruct (isIn e1 p1 p p2). destruct p3. -destruct n. +destruct n. simpl. rewrite NPEmul_correct. simpl; rewrite NPEpow_correct;simpl. repeat rewrite pow_th.(rpow_pow_N);simpl. rewrite pow_pos_mul;intros (H,H1);split;[ring[H]|trivial]. @@ -838,12 +838,12 @@ destruct n. unfold Zgt in H2, H4;simpl in H2,H4. rewrite H4 in H3;simpl in H3. rewrite pow_pos_mul. rewrite H1;rewrite H3. assert (pow_pos rmul (NPEeval l e1) (p1 - p4) * NPEeval l p3 * - (pow_pos rmul (NPEeval l e1) p4 * NPEeval l p5) == + (pow_pos rmul (NPEeval l e1) p4 * NPEeval l p5) == pow_pos rmul (NPEeval l e1) p4 * pow_pos rmul (NPEeval l e1) (p1 - p4) * NPEeval l p3 *NPEeval l p5) by ring. rewrite H;clear H. rewrite <- pow_pos_plus. rewrite Pplus_minus. split. symmetry;apply ARth.(ARmul_assoc). refine (refl_equal _). trivial. - repeat rewrite pow_th.(rpow_pow_N);simpl. + repeat rewrite pow_th.(rpow_pow_N);simpl. intros (H1,H2) (H3,H4). unfold Zgt in H2, H4;simpl in H2,H4. rewrite H4 in H3;simpl in H3. rewrite H2 in H1;simpl in H1. @@ -857,16 +857,16 @@ destruct n. pow_pos rmul (NPEeval l e1) (p1 - p4) * pow_pos rmul (NPEeval l e1) (p4 - p6) * NPEeval l p3 * NPEeval l p5) by ring. rewrite H0;clear H0. rewrite <- pow_pos_plus. - replace (p1 - p4 + (p4 - p6))%positive with (p1 - p6)%positive. + replace (p1 - p4 + (p4 - p6))%positive with (p1 - p6)%positive. rewrite NPEmul_correct. simpl;ring. - assert + assert (Zpos p1 - Zpos p6 = Zpos p1 - Zpos p4 + (Zpos p4 - Zpos p6))%Z. change ((Zpos p1 - Zpos p6)%Z = (Zpos p1 + (- Zpos p4) + (Zpos p4 +(- Zpos p6)))%Z). rewrite <- Zplus_assoc. rewrite (Zplus_assoc (- Zpos p4)). simpl. rewrite Pcompare_refl. 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). + simpl. repeat rewrite pow_th.(rpow_pow_N). intros H1 (H2,H3). unfold Zgt in H3;simpl in H3. rewrite H3 in H2;rewrite H3. rewrite NPEmul_correct;simpl;rewrite NPEpow_correct;simpl. simpl in H2. rewrite pow_th.(rpow_pow_N);simpl. @@ -879,8 +879,8 @@ destruct n. repeat rewrite pow_th.(rpow_pow_N);simpl. rewrite pow_pos_mul. intros (H1, H2);rewrite H1;split. unfold Zgt in H2;simpl in H2;rewrite H2;rewrite H2 in H1. - simpl in H1;ring [H1]. trivial. - trivial. + simpl in H1;ring [H1]. trivial. + trivial. destruct n. trivial. generalize (H p1 (p0*p2)%positive);clear H;destruct (isIn e1 p1 p (p0*p2)). destruct p3. destruct n;simpl. repeat rewrite pow_th.(rpow_pow_N). simpl. @@ -910,18 +910,18 @@ Fixpoint split_aux (e1: PExpr C) (p:positive) (e2:PExpr C) {struct e1}: rsplit : (NPEmul (common r1) (common r2)) (right r2) | PEpow e3 N0 => mk_rsplit (PEc cI) (PEc cI) e2 - | PEpow e3 (Npos p3) => split_aux e3 (Pmult p3 p) e2 - | _ => + | PEpow e3 (Npos p3) => split_aux e3 (Pmult p3 p) e2 + | _ => match isIn e1 p e2 xH with - | Some (N0,e3) => mk_rsplit (PEc cI) (NPEpow e1 (Npos p)) e3 + | Some (N0,e3) => mk_rsplit (PEc cI) (NPEpow e1 (Npos p)) e3 | Some (Npos q, e3) => mk_rsplit (NPEpow e1 (Npos q)) (NPEpow e1 (Npos (p - q))) e3 | None => mk_rsplit (NPEpow e1 (Npos p)) (PEc cI) e2 end - end. + end. Lemma split_aux_correct_1 : forall l e1 p e2, let res := match isIn e1 p e2 xH with - | Some (N0,e3) => mk_rsplit (PEc cI) (NPEpow e1 (Npos p)) e3 + | Some (N0,e3) => mk_rsplit (PEc cI) (NPEpow e1 (Npos p)) e3 | Some (Npos q, e3) => mk_rsplit (NPEpow e1 (Npos q)) (NPEpow e1 (Npos (p - q))) e3 | None => mk_rsplit (NPEpow e1 (Npos p)) (PEc cI) e2 end in @@ -932,7 +932,7 @@ Proof. intros. unfold res;clear res; generalize (isIn_correct l e1 p e2 xH). destruct (isIn e1 p e2 1). destruct p0. Opaque NPEpow NPEmul. - destruct n;simpl; + destruct n;simpl; (repeat rewrite NPEmul_correct;simpl; repeat rewrite NPEpow_correct;simpl; repeat rewrite pow_th.(rpow_pow_N);simpl). @@ -945,7 +945,7 @@ Proof. Qed. Theorem split_aux_correct: forall l e1 p e2, - NPEeval l (PEpow e1 (Npos p)) == + NPEeval l (PEpow e1 (Npos p)) == NPEeval l (NPEmul (left (split_aux e1 p e2)) (common (split_aux e1 p e2))) /\ NPEeval l e2 == NPEeval l (NPEmul (right (split_aux e1 p e2)) @@ -953,9 +953,9 @@ Theorem split_aux_correct: forall l e1 p e2, Proof. intros l; induction e1;intros k e2; try refine (split_aux_correct_1 l _ k e2);simpl. generalize (IHe1_1 k e2); clear IHe1_1. -generalize (IHe1_2 k (rsplit_right (split_aux e1_1 k e2))); clear IHe1_2. +generalize (IHe1_2 k (rsplit_right (split_aux e1_1 k e2))); clear IHe1_2. simpl. repeat (rewrite NPEmul_correct;simpl). -repeat rewrite pow_th.(rpow_pow_N);simpl. +repeat rewrite pow_th.(rpow_pow_N);simpl. intros (H1,H2) (H3,H4);split. rewrite pow_pos_mul. rewrite H1;rewrite H3. ring. rewrite H4;rewrite H2;ring. @@ -971,7 +971,7 @@ rewrite pow_pos_pow_pos. intros [H1 H2];split;ring [H1 H2]. Qed. Definition split e1 e2 := split_aux e1 xH e2. - + Theorem split_correct_l: forall l e1 e2, NPEeval l e1 == NPEeval l (NPEmul (left (split e1 e2)) (common (split e1 e2))). @@ -987,7 +987,7 @@ Proof. intros l e1 e2; case (split_aux_correct l e1 xH e2);simpl;auto. Qed. -Fixpoint Fnorm (e : FExpr) : linear := +Fixpoint Fnorm (e : FExpr) : linear := match e with | FEc c => mk_linear (PEc c) (PEc cI) nil | FEX x => mk_linear (PEX C x) (PEc cI) nil @@ -999,7 +999,7 @@ Fixpoint Fnorm (e : FExpr) : linear := (NPEadd (NPEmul (num x) (right s)) (NPEmul (num y) (left s))) (NPEmul (left s) (NPEmul (right s) (common s))) (condition x ++ condition y) - + | FEsub e1 e2 => let x := Fnorm e1 in let y := Fnorm e2 in @@ -1050,13 +1050,13 @@ 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 (@rmul_reg_l _ (pow_pos rmul x p) 0 IHp). reflexivity. - rewrite H1. ring. rewrite Hp;ring. + rewrite H1. ring. rewrite Hp;ring. intro Hp;apply IHp. rewrite (@rmul_reg_l _ (pow_pos rmul x p) 0 IHp). reflexivity. rewrite Hp;ring. trivial. Qed. - + Theorem Pcond_Fnorm: forall l e, PCond l (condition (Fnorm e)) -> ~ NPEeval l (denum (Fnorm e)) == 0. @@ -1135,9 +1135,9 @@ Hint Resolve Pcond_Fnorm. (*************************************************************************** - - Main theorem - + + Main theorem + ***************************************************************************) Theorem Fnorm_FEeval_PEeval: @@ -1242,8 +1242,8 @@ 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). - reflexivity. apply pow_pos_not_0;trivial. ring [Hp]. -rewrite <- rdiv4;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. @@ -1352,11 +1352,11 @@ Theorem Field_simplify_eq_old_correct : Proof. intros l fe1 fe2 nfe1 nfe2 eq1 eq2 Hcrossprod Hcond; subst nfe1 nfe2. apply Fnorm_crossproduct; trivial. -match goal with +match goal with [ |- NPEeval l ?x == NPEeval l ?y] => 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 cdiv_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. @@ -1368,7 +1368,7 @@ Theorem Field_simplify_eq_correct : forall lmp, Nmk_monpol_list lpe = lmp -> forall nfe1, Fnorm fe1 = nfe1 -> forall nfe2, Fnorm fe2 = nfe2 -> - forall den, split (denum nfe1) (denum nfe2) = den -> + forall den, split (denum nfe1) (denum nfe2) = den -> NPphi_dev l (Nnorm n lmp (PEmul (num nfe1) (right den))) == NPphi_dev l (Nnorm n lmp (PEmul (num nfe2) (left den))) -> PCond l (condition nfe1 ++ condition nfe2) -> @@ -1387,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 cdiv_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 cdiv_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. @@ -1408,7 +1408,7 @@ Theorem Field_simplify_eq_pow_correct : forall lmp, Nmk_monpol_list lpe = lmp -> forall nfe1, Fnorm fe1 = nfe1 -> forall nfe2, Fnorm fe2 = nfe2 -> - forall den, split (denum nfe1) (denum nfe2) = den -> + forall den, split (denum nfe1) (denum nfe2) = den -> NPphi_pow l (Nnorm n lmp (PEmul (num nfe1) (right den))) == NPphi_pow l (Nnorm n lmp (PEmul (num nfe2) (left den))) -> PCond l (condition nfe1 ++ condition nfe2) -> @@ -1427,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 cdiv_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 cdiv_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. @@ -1448,7 +1448,7 @@ Theorem Field_simplify_eq_pow_in_correct : forall lmp, Nmk_monpol_list lpe = lmp -> forall nfe1, Fnorm fe1 = nfe1 -> forall nfe2, Fnorm fe2 = nfe2 -> - forall den, split (denum nfe1) (denum nfe2) = den -> + forall den, split (denum nfe1) (denum nfe2) = den -> forall np1, Nnorm n lmp (PEmul (num nfe1) (right den)) = np1 -> forall np2, Nnorm n lmp (PEmul (num nfe2) (left den)) = np2 -> FEeval l fe1 == FEeval l fe2 -> @@ -1461,7 +1461,7 @@ Proof. repeat (rewrite <- (norm_subst_ok Rsth Reqe ARth CRmorph pow_th);trivial). simpl. assert (N1 := Pcond_Fnorm _ _ (PCond_app_inv_l _ _ _ H7)). assert (N2 := Pcond_Fnorm _ _ (PCond_app_inv_r _ _ _ H7)). - apply (@rmul_reg_l (NPEeval l (rsplit_common den))). + apply (@rmul_reg_l (NPEeval l (rsplit_common den))). intro Heq;apply N1. rewrite (split_correct_l l (denum (Fnorm fe1)) (denum (Fnorm fe2))). rewrite H3. rewrite NPEmul_correct. simpl. ring [Heq]. @@ -1498,7 +1498,7 @@ forall n l lpe fe1 fe2, forall lmp, Nmk_monpol_list lpe = lmp -> forall nfe1, Fnorm fe1 = nfe1 -> forall nfe2, Fnorm fe2 = nfe2 -> - forall den, split (denum nfe1) (denum nfe2) = den -> + forall den, split (denum nfe1) (denum nfe2) = den -> forall np1, Nnorm n lmp (PEmul (num nfe1) (right den)) = np1 -> forall np2, Nnorm n lmp (PEmul (num nfe2) (left den)) = np2 -> FEeval l fe1 == FEeval l fe2 -> @@ -1511,7 +1511,7 @@ Proof. repeat (rewrite <- (norm_subst_ok Rsth Reqe ARth CRmorph pow_th);trivial). simpl. assert (N1 := Pcond_Fnorm _ _ (PCond_app_inv_l _ _ _ H7)). assert (N2 := Pcond_Fnorm _ _ (PCond_app_inv_r _ _ _ H7)). - apply (@rmul_reg_l (NPEeval l (rsplit_common den))). + apply (@rmul_reg_l (NPEeval l (rsplit_common den))). intro Heq;apply N1. rewrite (split_correct_l l (denum (Fnorm fe1)) (denum (Fnorm fe2))). rewrite H3. rewrite NPEmul_correct. simpl. ring [Heq]. @@ -1539,7 +1539,7 @@ Proof. rewrite (ARth.(ARmul_comm) (/ NPEeval l (denum (Fnorm fe2)))). repeat rewrite <- (AFth.(AFdiv_def)). repeat rewrite <- Fnorm_FEeval_PEeval;trivial. - apply (PCond_app_inv_r _ _ _ H7). apply (PCond_app_inv_l _ _ _ H7). + apply (PCond_app_inv_r _ _ _ H7). apply (PCond_app_inv_l _ _ _ H7). Qed. @@ -1576,7 +1576,7 @@ Fixpoint Fcons (e:PExpr C) (l:list (PExpr C)) {struct l} : list (PExpr C) := nil => cons e nil | cons a l1 => if PExpr_eq e a then l else cons a (Fcons e l1) end. - + Theorem PFcons_fcons_inv: forall l a l1, PCond l (Fcons a l1) -> ~ NPEeval l a == 0 /\ PCond l l1. intros l a l1; elim l1; simpl Fcons; auto. @@ -1603,7 +1603,7 @@ Fixpoint Fcons0 (e:PExpr C) (l:list (PExpr C)) {struct l} : list (PExpr C) := if Peq ceqb (Nnorm O nil e) (Nnorm O nil a) then l else cons a (Fcons0 e l1) end. - + Theorem PFcons0_fcons_inv: forall l a l1, PCond l (Fcons0 a l1) -> ~ NPEeval l a == 0 /\ PCond l l1. intros l a l1; elim l1; simpl Fcons0; auto. @@ -1620,7 +1620,7 @@ split. generalize (PCond_cons_inv_l _ _ _ H1); simpl; auto. apply H0. generalize (PCond_cons_inv_r _ _ _ H1); simpl; auto. -clear get_sign get_sign_spec. +clear get_sign get_sign_spec. generalize Hp; case l0; simpl; intuition. Qed. @@ -1647,7 +1647,7 @@ intros l a; elim a; try (intros; apply PFcons0_fcons_inv; auto; fail). apply pow_pos_not_0;trivial. Qed. -Definition Pcond_simpl_gen := +Definition Pcond_simpl_gen := fcons_correct _ PFcons00_fcons_inv. @@ -1674,7 +1674,7 @@ Qed. Fixpoint Fcons1 (e:PExpr C) (l:list (PExpr C)) {struct e} : list (PExpr C) := match e with PEmul e1 e2 => Fcons1 e1 (Fcons1 e2 l) - | PEpow e _ => Fcons1 e l + | PEpow e _ => Fcons1 e l | PEopp e => if ceqb (copp cI) cO then absurd_PCond else Fcons1 e l | PEc c => if ceqb c cO then absurd_PCond else l | _ => Fcons0 e l @@ -1710,7 +1710,7 @@ intros l a; elim a; try (intros; apply PFcons0_fcons_inv; auto; fail). Qed. Definition Fcons2 e l := Fcons1 (PExpr_simp e) l. - + Theorem PFcons2_fcons_inv: forall l a l1, PCond l (Fcons2 a l1) -> ~ NPEeval l a == 0 /\ PCond l l1. unfold Fcons2 in |- *; intros l a l1 H; split; @@ -1720,7 +1720,7 @@ transitivity (NPEeval l a); trivial. apply PExpr_simp_correct. Qed. -Definition Pcond_simpl_complete := +Definition Pcond_simpl_complete := fcons_correct _ PFcons2_fcons_inv. End Fcons_simpl. @@ -1751,7 +1751,7 @@ End FieldAndSemiField. End MakeFieldPol. - Definition SF2AF R (rO rI:R) radd rmul rdiv rinv req Rsth + Definition SF2AF R (rO rI:R) radd rmul rdiv rinv req Rsth (sf:semi_field_theory rO rI radd rmul rdiv rinv req) := mk_afield _ _ (SRth_ARth Rsth sf.(SF_SR)) diff --git a/plugins/setoid_ring/InitialRing.v b/plugins/setoid_ring/InitialRing.v index e664b3b767..b5384f80b4 100644 --- a/plugins/setoid_ring/InitialRing.v +++ b/plugins/setoid_ring/InitialRing.v @@ -27,7 +27,7 @@ Definition NotConstant := false. Lemma Zsth : Setoid_Theory Z (@eq Z). Proof (Eqsth Z). - + Lemma Zeqe : ring_eq_ext Zplus Zmult Zopp (@eq Z). Proof (Eq_ext Zplus Zmult Zopp). @@ -65,7 +65,7 @@ Section ZMORPHISM. Fixpoint gen_phiPOS (p:positive) : R := match p with - | xH => 1 + | xH => 1 | xO xH => (1 + 1) | xO p => (1 + 1) * (gen_phiPOS p) | xI xH => 1 + (1 +1) @@ -78,18 +78,18 @@ Section ZMORPHISM. | Z0 => 0 | Zneg p => -(gen_phiPOS1 p) end. - - Definition gen_phiZ z := + + Definition gen_phiZ z := match z with | Zpos p => gen_phiPOS p | Z0 => 0 | Zneg p => -(gen_phiPOS p) end. - Notation "[ x ]" := (gen_phiZ x). + Notation "[ x ]" := (gen_phiZ x). Definition get_signZ z := match z with - | Zneg p => Some (Zpos p) + | Zneg p => Some (Zpos p) | _ => None end. @@ -101,16 +101,16 @@ Section ZMORPHISM. 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 Rsth Reqe ARth. Ltac add_push := gen_add_push radd Rsth Reqe ARth. - + Lemma same_gen : forall x, gen_phiPOS1 x == gen_phiPOS x. Proof. - induction x;simpl. + induction x;simpl. rewrite IHx;destruct x;simpl;norm. rewrite IHx;destruct x;simpl;norm. rrefl. @@ -155,28 +155,28 @@ Section ZMORPHISM. Add Morphism rsub : rsub_ext4. exact (ARsub_ext Rsth Reqe ARth). Qed. Ltac norm := gen_srewrite Rsth Reqe ARth. Ltac add_push := gen_add_push radd Rsth Reqe ARth. - + (*morphisms are extensionaly equal*) Lemma same_genZ : forall x, [x] == gen_phiZ1 x. Proof. destruct x;simpl; try rewrite (same_gen ARth);rrefl. Qed. - - Lemma gen_Zeqb_ok : forall x y, + + Lemma gen_Zeqb_ok : forall x y, Zeq_bool x y = true -> [x] == [y]. Proof. intros x y H. assert (H1 := Zeq_bool_eq x y H);unfold IDphi in H1. rewrite H1;rrefl. Qed. - + Lemma gen_phiZ1_add_pos_neg : forall x y, gen_phiZ1 match (x ?= y)%positive Eq with | Eq => Z0 | Lt => Zneg (y - x) | Gt => Zpos (x - y) - end + end == gen_phiPOS1 x + -gen_phiPOS1 y. Proof. intros x y. @@ -197,7 +197,7 @@ Section ZMORPHISM. Qed. Lemma match_compOpp : forall x (B:Type) (be bl bg:B), - match CompOpp x with Eq => be | Lt => bl | Gt => bg end + match CompOpp x with Eq => be | Lt => bl | Gt => bg end = match x with Eq => be | Lt => bg | Gt => bl end. Proof. destruct x;simpl;intros;trivial. Qed. @@ -209,7 +209,7 @@ Section ZMORPHISM. apply gen_phiZ1_add_pos_neg. replace Eq with (CompOpp Eq);trivial. rewrite <- Pcompare_antisym;simpl. - rewrite match_compOpp. + rewrite match_compOpp. rewrite (Radd_comm Rth). apply gen_phiZ1_add_pos_neg. rewrite (ARgen_phiPOS_add ARth); norm. @@ -227,11 +227,11 @@ Section ZMORPHISM. Proof. intros;subst;rrefl. Qed. (*proof that [.] satisfies morphism specifications*) - Lemma gen_phiZ_morph : - ring_morph 0 1 radd rmul rsub ropp req Z0 (Zpos xH) + Lemma gen_phiZ_morph : + ring_morph 0 1 radd rmul rsub ropp req Z0 (Zpos xH) Zplus Zmult Zminus Zopp Zeq_bool gen_phiZ. - Proof. - assert ( SRmorph : semi_morph 0 1 radd rmul req Z0 (Zpos xH) + Proof. + assert ( SRmorph : semi_morph 0 1 radd rmul req Z0 (Zpos xH) Zplus Zmult Zeq_bool gen_phiZ). apply mkRmorph;simpl;try rrefl. apply gen_phiZ_add. apply gen_phiZ_mul. apply gen_Zeqb_ok. @@ -251,7 +251,7 @@ Lemma Nth : semi_ring_theory N0 (Npos xH) Nplus Nmult (@eq N). Proof. constructor. exact Nplus_0_l. exact Nplus_comm. exact Nplus_assoc. exact Nmult_1_l. exact Nmult_0_l. exact Nmult_comm. exact Nmult_assoc. - exact Nmult_plus_distr_r. + exact Nmult_plus_distr_r. Qed. Definition Nsub := SRsub Nplus. @@ -260,11 +260,11 @@ Definition Nopp := (@SRopp N). Lemma Neqe : ring_eq_ext Nplus Nmult Nopp (@eq N). Proof (SReqe_Reqe Nseqe). -Lemma Nath : +Lemma Nath : almost_ring_theory N0 (Npos xH) Nplus Nmult Nsub Nopp (@eq N). Proof (SRth_ARth Nsth Nth). - -Definition Neq_bool (x y:N) := + +Definition Neq_bool (x y:N) := match Ncompare x y with | Eq => true | _ => false @@ -273,17 +273,17 @@ Definition Neq_bool (x y:N) := Lemma Neq_bool_ok : forall x y, Neq_bool x y = true -> x = y. Proof. intros x y;unfold Neq_bool. - assert (H:=Ncompare_Eq_eq x y); + assert (H:=Ncompare_Eq_eq x y); destruct (Ncompare x y);intros;try discriminate. - rewrite H;trivial. + rewrite H;trivial. Qed. Lemma Neq_bool_complete : forall x y, Neq_bool x y = true -> x = y. Proof. intros x y;unfold Neq_bool. - assert (H:=Ncompare_Eq_eq x y); + assert (H:=Ncompare_Eq_eq x y); destruct (Ncompare x y);intros;try discriminate. - rewrite H;trivial. + rewrite H;trivial. Qed. (**Same as above : definition of two,extensionaly equal, generic morphisms *) @@ -298,7 +298,7 @@ Section NMORPHISM. Add Setoid R req Rsth as R_setoid4. Ltac rrefl := gen_reflexivity Rsth. Variable SReqe : sring_eq_ext radd rmul req. - Variable SRth : semi_ring_theory 0 1 radd rmul req. + Variable SRth : semi_ring_theory 0 1 radd rmul req. Let ARth := SRth_ARth Rsth SRth. Let Reqe := SReqe_Reqe SReqe. Let ropp := (@SRopp R). @@ -315,15 +315,15 @@ Section NMORPHISM. match x with | N0 => 0 | Npos x => gen_phiPOS1 1 radd rmul x - end. + end. Definition gen_phiN x := match x with | N0 => 0 | Npos x => gen_phiPOS 1 radd rmul x - end. - Notation "[ x ]" := (gen_phiN x). - + end. + Notation "[ x ]" := (gen_phiN x). + Lemma same_genN : forall x, [x] == gen_phiN1 x. Proof. destruct x;simpl. rrefl. @@ -336,7 +336,7 @@ Section NMORPHISM. destruct x;destruct y;simpl;norm. apply (ARgen_phiPOS_add Rsth Reqe ARth). Qed. - + Lemma gen_phiN_mult : forall x y, [x * y] == [x] * [y]. Proof. intros x y;repeat rewrite same_genN. @@ -397,7 +397,7 @@ Fixpoint Nw_is0 (w : Nword) : bool := | nil => true | 0%N :: w' => Nw_is0 w' | _ => false - end. + end. Fixpoint Nweq_bool (w1 w2 : Nword) {struct w1} : bool := match w1, w2 with @@ -559,7 +559,7 @@ induction x; intros. Qed. (* Proof that [.] satisfies morphism specifications *) - Lemma gen_phiNword_morph : + Lemma gen_phiNword_morph : ring_morph 0 1 radd rmul rsub ropp req NwO NwI Nwadd Nwmul Nwsub Nwopp Nweq_bool gen_phiNword. constructor. @@ -585,7 +585,7 @@ 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) @@ -595,8 +595,8 @@ Section GEN_DIV. 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 *) + + (* 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. @@ -605,7 +605,7 @@ Section GEN_DIV. Add Morphism rsub : rsub_ext. exact (ARsub_ext Rsth Reqe ARth). Qed. Ltac rsimpl := gen_srewrite Rsth Reqe ARth. - Definition triv_div x y := + Definition triv_div x y := if ceqb x y then (cI, cO) else (cO, x). @@ -715,7 +715,7 @@ End GEN_DIV. (* A simple tactic recognizing only 0 and 1. The inv_gen_phiX above are only optimisations that directly returns the reifid constant instead of resorting to the constant propagation of the simplification - algorithm. *) + algorithm. *) Ltac inv_gen_phi rO rI cO cI t := match t with | rO => cO @@ -769,10 +769,10 @@ 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 + | @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 + | @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" @@ -782,24 +782,24 @@ Ltac gen_ring_sign morph sspec := Ltac default_div_spec set reqe arth morph := match type of morph with - | @ring_morph ?R ?r0 ?rI ?radd ?rmul ?rsub ?ropp ?req + | @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 + | @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 + 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 (triv_div_th set reqe arth morph)) - | _ => fail 1 "ring anomaly : default_sign_spec" + | _ => fail 1 "ring anomaly : default_sign_spec" end. Ltac gen_ring_div set reqe arth morph dspec := match dspec with - | None => default_div_spec set reqe arth morph + | None => default_div_spec set reqe arth morph | Some ?t => constr:(t) end. - + 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 @@ -813,10 +813,10 @@ Ltac ring_elements set ext rspec pspec sspec dspec rk := | _ => fail 2 "ring anomaly" end | @Morphism ?m => - match type of m with - | ring_morph _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ => m - | @semi_morph _ _ _ _ _ _ _ _ _ _ _ _ _ => - constr:(SRmorph_Rmorph set m) + match type of m with + | ring_morph _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ => m + | @semi_morph _ _ _ _ _ _ _ _ _ _ _ _ _ => + constr:(SRmorph_Rmorph set m) | _ => fail 2 "ring anomaly" end | _ => fail 1 "ill-formed ring kind" @@ -832,27 +832,27 @@ Ltac ring_elements set ext rspec pspec sspec dspec rk := Ltac ring_lemmas set ext rspec pspec sspec dspec rk := let gen_lemma2 := match pspec with - | None => constr:(ring_rw_correct) + | None => constr:(ring_rw_correct) | Some _ => constr:(ring_rw_pow_correct) end in 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 + | @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 + 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 => + | @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 := + | @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" @@ -878,7 +878,7 @@ Ltac isPcst t := | xO ?p => isPcst p | xH => constr:true (* nat -> positive *) - | P_of_succ_nat ?n => isnatcst n + | P_of_succ_nat ?n => isnatcst n | _ => constr:false end. diff --git a/plugins/setoid_ring/RealField.v b/plugins/setoid_ring/RealField.v index 60641bcf95..56473adb9c 100644 --- a/plugins/setoid_ring/RealField.v +++ b/plugins/setoid_ring/RealField.v @@ -1,5 +1,5 @@ Require Import Nnat. -Require Import ArithRing. +Require Import ArithRing. Require Export Ring Field. Require Import Rdefinitions. Require Import Rpow_def. @@ -99,7 +99,7 @@ rewrite H in |- *; intro. apply (Rlt_asym 0 0); trivial. Qed. -Lemma Zeq_bool_complete : forall x y, +Lemma Zeq_bool_complete : forall x y, InitialRing.gen_phiZ 0%R 1%R Rplus Rmult Ropp x = InitialRing.gen_phiZ 0%R 1%R Rplus Rmult Ropp y -> Zeq_bool x y = true. @@ -114,21 +114,21 @@ Qed. Lemma R_power_theory : power_theory 1%R Rmult (eq (A:=R)) nat_of_N pow. Proof. constructor. destruct n. reflexivity. - simpl. induction p;simpl. + simpl. induction p;simpl. rewrite ZL6. rewrite Rdef_pow_add;rewrite IHp. reflexivity. unfold nat_of_P;simpl;rewrite ZL6;rewrite Rdef_pow_add;rewrite IHp;trivial. rewrite Rmult_comm;apply Rmult_1_l. Qed. -Ltac Rpow_tac t := +Ltac Rpow_tac t := match isnatcst t with | false => constr:(InitialRing.NotConstant) | _ => constr:(N_of_nat t) - end. + end. -Add Field RField : Rfield +Add Field RField : Rfield (completeness Zeq_bool_complete, power_tac R_power_theory [Rpow_tac]). - + diff --git a/plugins/setoid_ring/Ring_polynom.v b/plugins/setoid_ring/Ring_polynom.v index d88470369d..faa83dedc2 100644 --- a/plugins/setoid_ring/Ring_polynom.v +++ b/plugins/setoid_ring/Ring_polynom.v @@ -18,21 +18,21 @@ Open Local Scope positive_scope. Import RingSyntax. Section MakeRingPol. - - (* Ring elements *) + + (* 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 *) + (* Coefficients *) Variable C: Type. Variable (cO cI: C) (cadd cmul csub : C->C->C) (copp : C->C). - Variable ceqb : C->C->bool. + 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. @@ -40,7 +40,7 @@ Section MakeRingPol. (* Power coefficients *) Variable Cpow : Set. Variable Cp_phi : N -> Cpow. - Variable rpow : R -> Cpow -> R. + Variable rpow : R -> Cpow -> R. Variable pow_th : power_theory rI rmul req Cp_phi rpow. (* division is ok *) @@ -54,12 +54,12 @@ Section MakeRingPol. Notation "x - y " := (rsub x y). Notation "- x" := (ropp x). Notation "x == y" := (req x y). - (* C notations *) + (* 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). - (* Useful 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. @@ -93,20 +93,20 @@ Section MakeRingPol. *) Inductive Pol : Type := - | Pc : C -> Pol - | Pinj : positive -> Pol -> Pol + | 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 := + + Fixpoint Peq (P P' : Pol) {struct P'} : bool := match P, P' with | Pc c, Pc c' => c ?=! c' - | Pinj j Q, Pinj j' Q' => + | Pinj j Q, Pinj j' Q' => match Pcompare j j' Eq with - | Eq => Peq Q Q' - | _ => false + | Eq => Peq Q Q' + | _ => false end | PX P i Q, PX P' i' Q' => match Pcompare i i' Eq with @@ -119,7 +119,7 @@ Section MakeRingPol. Notation " P ?== P' " := (Peq P P'). Definition mkPinj j P := - match P with + match P with | Pc _ => P | Pinj j' Q => Pinj ((j + j'):positive) Q | _ => Pinj j P @@ -132,7 +132,7 @@ Section MakeRingPol. | xI j => Pinj (xO j) P end. - Definition mkPX P i Q := + 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 @@ -142,20 +142,20 @@ Section MakeRingPol. Definition mkXi i := PX P1 i P0. Definition mkX := mkXi 1. - + (** Opposite of addition *) - - Fixpoint Popp (P:Pol) : Pol := + + 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) @@ -178,39 +178,39 @@ Section MakeRingPol. Fixpoint PaddI (j:positive) (P:Pol){struct P} : Pol := match P with | Pc c => mkPinj j (PaddC Q c) - | Pinj j' Q' => + | 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' => + | 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 end. Fixpoint PsubI (j:positive) (P:Pol){struct P} : Pol := match P with | Pc c => mkPinj j (PaddC (--Q) c) - | Pinj j' Q' => + | 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' => + | 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 end. - + Variable P' : Pol. - + Fixpoint PaddX (i':positive) (P:Pol) {struct P} : Pol := match P with | Pc c => PX P' i' P @@ -245,7 +245,7 @@ Section MakeRingPol. end end. - + End PopI. Fixpoint Padd (P P': Pol) {struct P'} : Pol := @@ -255,12 +255,12 @@ Section MakeRingPol. | PX P' i' Q' => match P with | Pc c => PX P' i' (PaddC Q' c) - | Pinj j Q => + | 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 + end | PX P i Q => match ZPminus i i' with | Zpos k => mkPX (Padd (PX P k P0) P') i' (Padd Q Q') @@ -278,12 +278,12 @@ Section MakeRingPol. | PX P' i' Q' => match P with | Pc c => PX (--P') i' (*(--(PsubC Q' c))*) (PaddC (--Q') c) - | Pinj j Q => + | 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 + end | PX P i Q => match ZPminus i i' with | Zpos k => mkPX (Psub (PX P k P0) P') i' (Psub Q Q') @@ -293,8 +293,8 @@ Section MakeRingPol. end end. Notation "P -- P'" := (Psub P P'). - - (** Multiplication *) + + (** Multiplication *) Fixpoint PmulC_aux (P:Pol) (c:C) {struct P} : Pol := match P with @@ -306,14 +306,14 @@ Section MakeRingPol. Definition PmulC P c := if c ?=! cO then P0 else if c ?=! cI then P else PmulC_aux P c. - - Section PmulI. + + 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' => + | Pinj j' Q' => match ZPminus j' j with | Zpos k => mkPinj j (Pmul (Pinj k Q') Q) | Z0 => mkPinj j (Pmul Q' Q) @@ -326,7 +326,7 @@ Section MakeRingPol. | xI j' => mkPX (PmulI j P') i' (PmulI (xO j') Q') end end. - + End PmulI. (* A symmetric version of the multiplication *) @@ -338,10 +338,10 @@ Section MakeRingPol. match P with | Pc c => PmulC P'' c | Pinj j Q => - let QQ' := + let QQ' := match j with | xH => Pmul Q Q' - | xO j => Pmul (Pinj (Pdouble_minus_one j) 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' @@ -352,15 +352,15 @@ Section MakeRingPol. let PP' := Pmul P P' in (mkPX (mkPX PP' i P0 ++ QP') i' P0) ++ mkPX PQ' i QQ' end - 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' => + | PX P' i' Q' => (mkPX (Pmul_aux P P') i' P0) ++ (PmulI Pmul_aux Q' xH P) end. @@ -368,7 +368,7 @@ Section MakeRingPol. match P with | Pc c => PmulC P' c | Pinj j Q => PmulI Pmul_aux Q j P' - | PX P i Q => + | PX P i Q => (mkPX (Pmul_aux P P') i P0) ++ (PmulI Pmul_aux Q xH P') end. *) @@ -378,7 +378,7 @@ Section MakeRingPol. match P with | Pc c => Pc (c *! c) | Pinj j Q => Pinj j (Psquare Q) - | PX P i 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 @@ -386,10 +386,10 @@ Section MakeRingPol. end. (** Monomial **) - + Inductive Mon: Set := - mon0: Mon - | zmon: positive -> Mon -> Mon + mon0: Mon + | zmon: positive -> Mon -> Mon | vmon: positive -> Mon -> Mon. Fixpoint Mphi(l:list R) (M: Mon) {struct M} : R := @@ -399,7 +399,7 @@ Section MakeRingPol. | vmon i M1 => let x := hd 0 l in let xi := pow_pos rmul x i in - (Mphi (tail l) M1) * xi + (Mphi (tail l) M1) * xi end. Definition mkZmon j M := @@ -409,8 +409,8 @@ Section MakeRingPol. match j with xH => M | _ => mkZmon (Ppred j) M end. Definition mkVmon i M := - match M with - | mon0 => vmon i mon0 + match M with + | mon0 => vmon i mon0 | zmon j m => vmon i (zmon_pred j m) | vmon i' m => vmon (i+i') m end. @@ -462,35 +462,35 @@ Section MakeRingPol. 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 + 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) (cM1: C * Mon) (P2: Pol) (n: nat) {struct n}: Pol := - match POneSubst P1 cM1 P2 with + 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) (cM1: C * Mon) (P2: Pol) (n: nat): option Pol := - match POneSubst P1 cM1 P2 with + 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 ((C * Mon) * Pol)) (n: nat) {struct LM1}: + + Fixpoint PSubstL1 (P1: Pol) (LM1: list ((C * Mon) * Pol)) (n: nat) {struct LM1}: Pol := - match LM1 with + match LM1 with cons (M1,P2) LM2 => PSubstL1 (PNSubst1 P1 M1 P2 n) LM2 n | _ => P1 end. Fixpoint PSubstL (P1: Pol) (LM1: list ((C * Mon) * Pol)) (n: nat) {struct LM1}: option Pol := - match LM1 with + match LM1 with cons (M1,P2) LM2 => - match PNSubst P1 M1 P2 n with + match PNSubst P1 M1 P2 n with Some P3 => Some (PSubstL1 P3 LM2 n) | None => PSubstL P1 LM2 n end @@ -498,7 +498,7 @@ Section MakeRingPol. end. Fixpoint PNSubstL (P1: Pol) (LM1: list ((C * Mon) * Pol)) (m n: nat) {struct m}: Pol := - match PSubstL P1 LM1 n with + match PSubstL P1 LM1 n with Some P3 => match m with S m1 => PNSubstL P3 LM1 m1 n | _ => P3 end | _ => P1 end. @@ -509,10 +509,10 @@ Section MakeRingPol. match P with | Pc c => [c] | Pinj j Q => Pphi (jump j l) Q - | PX P i 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) + (Pphi l P) * xi + (Pphi (tail l) Q) end. Reserved Notation "P @ l " (at level 10, no associativity). @@ -546,8 +546,8 @@ Section MakeRingPol. rewrite Psucc_o_double_minus_one_eq_xO;trivial. simpl;trivial. Qed. - - Lemma Peq_ok : forall P P', + + 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. @@ -580,10 +580,10 @@ Section MakeRingPol. rewrite <-jump_Pplus;rewrite Pplus_comm;rrefl. Qed. - Let pow_pos_Pplus := + 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, + 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. @@ -616,8 +616,8 @@ Section MakeRingPol. | -! ?x => rewrite ((morph_opp CRmorph) x) end end)); - rsimpl; simpl. - + rsimpl; simpl. + Lemma PaddC_ok : forall c P l, (PaddC P c)@l == P@l + [c]. Proof. induction P;simpl;intros;Esimpl;trivial. @@ -637,7 +637,7 @@ Section MakeRingPol. induction P;simpl;intros;Esimpl;trivial. rewrite IHP1;rewrite IHP2;rsimpl. mul_push ([c]);rrefl. - Qed. + Qed. Lemma PmulC_ok : forall c P l, (PmulC P c)@l == P@l * [c]. Proof. @@ -660,7 +660,7 @@ Section MakeRingPol. Ltac Esimpl2 := Esimpl; repeat (progress ( - match goal with + 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) @@ -684,7 +684,7 @@ Section MakeRingPol. rewrite IHP2;simpl. rewrite jump_Pdouble_minus_one;rsimpl. rewrite IHP';rsimpl. - destruct P;simpl. + destruct P;simpl. Esimpl2;add_push [c];rrefl. destruct p0;simpl;Esimpl2. rewrite IHP'2;simpl. @@ -699,7 +699,7 @@ Section MakeRingPol. rewrite H;rewrite Pplus_comm. rewrite pow_pos_Pplus;rsimpl. add_push (P3 @ (tail l));rrefl. - assert (forall P k l, + 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). @@ -727,7 +727,7 @@ Section MakeRingPol. 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';rsimpl. rewrite H;Esimpl. rewrite IHP';Esimpl. rewrite <- jump_Pplus;rewrite Pplus_comm;rrefl. rewrite H;Esimpl. rewrite IHP. @@ -736,8 +736,8 @@ Section MakeRingPol. rewrite IHP2;simpl;rsimpl. rewrite IHP2;simpl. rewrite jump_Pdouble_minus_one;rsimpl. - rewrite IHP';rsimpl. - destruct P;simpl. + 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. @@ -752,7 +752,7 @@ Section MakeRingPol. rewrite H;rewrite Pplus_comm. rewrite pow_pos_Pplus;rsimpl. add_push (P3 @ (tail l));rrefl. - assert (forall P k l, + 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. @@ -775,8 +775,8 @@ Section MakeRingPol. Qed. (* Proof for the symmetriv version *) - Lemma PmulI_ok : - forall P', + Lemma PmulI_ok : + forall P', (forall (P : Pol) (l : list R), (Pmul P P') @ l == P @ l * P' @ l) -> forall (P : Pol) (p : positive) (l : list R), (PmulI Pmul P' p P) @ l == P @ l * P' @ (jump p l). @@ -801,8 +801,8 @@ Section MakeRingPol. Qed. (* - Lemma PmulI_ok : - forall P', + 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). @@ -846,7 +846,7 @@ Section MakeRingPol. 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 + | xO j => Pinj (Pdouble_minus_one j) P ** P'2 | 1 => P ** P'2 end @ (tail l) == P @ (jump p0 l) * P'2 @ (tail l)). destruct p0;simpl;rewrite IHP'2;Esimpl. @@ -886,8 +886,8 @@ Lemma Pmul_ok : forall P P' l, (P**P')@l == P@l * P'@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, + + Lemma zmon_pred_ok : forall M j l, Mphi (tail l) (zmon_pred j M) == Mphi l (zmon j M). Proof. destruct j; simpl;intros auto; rsimpl. @@ -902,7 +902,7 @@ Lemma Pmul_ok : forall P P' l, (P**P')@l == P@l * P'@l. rewrite Pplus_comm;rewrite pow_pos_Pplus;rsimpl. Qed. - Lemma Mcphi_ok: forall P c l, + Lemma Mcphi_ok: forall P c l, let (Q,R) := CFactor P c in P@l == Q@l + (phi c) * (R@l). Proof. @@ -924,7 +924,7 @@ Lemma Pmul_ok : forall P P' l, (P**P')@l == P@l * P'@l. rewrite (ARadd_comm ARth); rsimpl. Qed. - Lemma Mphi_ok: forall P (cM: C * Mon) l, + 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). @@ -951,7 +951,7 @@ Lemma Pmul_ok : forall P P' l, (P**P')@l == P@l * P'@l. rewrite (Pcompare_Eq_eq _ _ He). generalize (Hrec (c, M) (jump j l)); case (MFactor P c M); simpl; intros P2 Q2 H; repeat rewrite mkPinj_ok; auto. - generalize (Hrec (c, (zmon (j -i) M)) (jump i l)); + 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)). @@ -973,14 +973,14 @@ Lemma Pmul_ok : forall P P' l, (P**P')@l == P@l * P'@l. apply (Radd_ext Reqe); rsimpl. rewrite (ARadd_comm ARth); rsimpl. intros j M1. - generalize (Hrec1 (c,zmon j M1) l); + generalize (Hrec1 (c,zmon j M1) l); case (MFactor P2 c (zmon j M1)). intros R1 S1 H1. - generalize (Hrec2 (c, zmon_pred j M1) (List.tail l)); + 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. + rsimpl. apply radd_ext; rsimpl. rewrite (ARadd_comm ARth); rsimpl. apply radd_ext; rsimpl. @@ -1002,7 +1002,7 @@ Lemma Pmul_ok : forall P P' l, (P**P')@l == P@l * P'@l. repeat (rewrite <-(ARmul_assoc ARth)). apply rmul_ext; rsimpl. rewrite (ARmul_comm ARth); rsimpl. - generalize (Hrec1 (c, vmon (j - i) M1) l); + 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. @@ -1020,7 +1020,7 @@ Lemma Pmul_ok : forall P P' l, (P**P')@l == P@l * P'@l. apply rmul_ext; rsimpl. rewrite <- pow_pos_Pplus. rewrite (Pplus_minus _ _ (ZC2 _ _ He)); rsimpl. - generalize (Hrec1 (c, mkZmon 1 M1) l); + 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. @@ -1064,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 by (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. @@ -1092,18 +1092,18 @@ Proof. injection H2; intros; subst; rsimpl. rewrite Padd_ok. rewrite Pmul_ok; rsimpl. - Qed. + Qed. *) Lemma PNSubst1_ok: forall n P1 M1 P2 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. - generalize (fun P4 => @POneSubst_ok P2 M1 P3 P4 l); + 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); + 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. @@ -1112,15 +1112,15 @@ Proof. PNSubst P1 M1 P2 n = Some P3 -> [fst M1] * Mphi l (snd M1) == P2@l -> P1@l == P3@l. Proof. intros n P2 (cc, M1) P3 l P4; unfold PNSubst. - generalize (fun P4 => @POneSubst_ok P2 (cc,M1) P3 P4 l); + 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 P5 H1; case n; try (intros; discriminate). intros n1 H2; injection H2; intros; subst. rewrite <- PNSubst1_ok; auto. Qed. - Fixpoint MPcond (LM1: list (C * Mon * Pol)) (l: list R) {struct LM1} : Prop := - match LM1 with + Fixpoint MPcond (LM1: list (C * Mon * Pol)) (l: list R) {struct LM1} : Prop := + match LM1 with cons (M1,P2) LM2 => ([fst M1] * Mphi l (snd M1) == P2@l) /\ (MPcond LM2 l) | _ => True end. @@ -1189,7 +1189,7 @@ Proof. Strategy expand [PEeval]. (** Correctness proofs *) - + Lemma mkX_ok : forall p l, nth 0 p l == (mk_X p) @ l. Proof. destruct p;simpl;intros;Esimpl;trivial. @@ -1198,11 +1198,11 @@ Strategy expand [PEeval]. rewrite nth_Pdouble_minus_one;rrefl. Qed. - Ltac Esimpl3 := + 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). + end;Esimpl2;try rrefl;try apply (ARadd_comm ARth). (* Power using the chinise algorithm *) (*Section POWER. @@ -1213,13 +1213,13 @@ Strategy expand [PEeval]. | 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. @@ -1228,28 +1228,28 @@ Strategy expand [PEeval]. 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) + | 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. @@ -1257,11 +1257,11 @@ Section POWER. 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 by trivial. Esimpl. Qed. - + End POWER. (** Normalization and rewriting *) @@ -1276,86 +1276,86 @@ Section POWER. Fixpoint norm_aux (pe:PExpr) : Pol := match pe with | PEc c => Pc c - | PEX j => mk_X j + | PEX j => mk_X j | PEadd (PEopp pe1) pe2 => Psub (norm_aux pe2) (norm_aux pe1) - | PEadd pe1 (PEopp pe2) => + | 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) + | 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) + | PEX j => subst_l (mk_X j) | PEadd (PEopp pe1) pe2 => Psub (norm_subst pe2) (norm_subst pe1) - | PEadd pe1 (PEopp pe2) => + | 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) + | 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 : + Lemma norm_subst_spec : forall l pe, MPcond lmp l -> - PEeval l pe == (norm_subst pe)@l. + PEeval l pe == (norm_subst pe)@l. Proof. - intros;assert (subst_l_ok:forall P, (subst_l P)@l == P@l). + 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;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; + induction p;simpl;try rewrite IHp;try rewrite IHpe;repeat rewrite Pms_ok; repeat rewrite Pmul_ok;rrefl. Qed. *) - Lemma norm_aux_spec : + Lemma norm_aux_spec : forall l pe, MPcond lmp l -> - PEeval l pe == (norm_aux pe)@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;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 (intros;rrefl). rewrite pow_th.(rpow_pow_N). destruct n0;Esimpl3. - induction p;simpl;try rewrite IHp;try rewrite IHpe;repeat rewrite Pms_ok; + induction p;simpl;try rewrite IHp;try rewrite IHpe;repeat rewrite Pms_ok; repeat rewrite Pmul_ok;rrefl. Qed. - Lemma norm_subst_spec : + Lemma norm_subst_spec : forall l pe, MPcond lmp l -> PEeval l pe == (norm_subst pe)@l. Proof. intros;unfold norm_subst. unfold subst_l;rewrite <- PNSubstL_ok;trivial. apply norm_aux_spec. trivial. - Qed. - + Qed. + End NORM_SUBST_REC. - + Fixpoint interp_PElist (l:list R) (lpe:list (PExpr*PExpr)) {struct lpe} : Prop := match lpe with | nil => True - | (me,pe)::lpe => + | (me,pe)::lpe => match lpe with | nil => PEeval l me == PEeval l pe | _ => PEeval l me == PEeval l pe /\ interp_PElist l lpe @@ -1366,9 +1366,9 @@ Section POWER. match P with | Pc c => if (c ?=! cO) then None else Some (c, mon0) | Pinj j P => - match mon_of_pol P with + match mon_of_pol P with | None => None - | Some (c,m) => Some (c, mkZmon j m) + | Some (c,m) => Some (c, mkZmon j m) end | PX P i Q => if Peq Q P0 then @@ -1384,15 +1384,15 @@ Section POWER. | nil => nil | (me,pe)::lpe => match mon_of_pol (norm_subst 0 nil me) with - | None => mk_monpol_list lpe - | Some m => (m,norm_subst 0 nil pe):: mk_monpol_list lpe + | None => mk_monpol_list lpe + | Some m => (m,norm_subst 0 nil pe):: mk_monpol_list lpe end end. Lemma mon_of_pol_ok : forall P m, mon_of_pol P = Some m -> forall l, [fst m] * Mphi l (snd m) == P@l. Proof. - induction P;simpl;intros;Esimpl. + induction P;simpl;intros;Esimpl. assert (H1 := (morph_eq CRmorph) c cO). destruct (c ?=! cO). discriminate. @@ -1418,14 +1418,14 @@ Section POWER. discriminate. intros;discriminate. Qed. - - Lemma interp_PElist_ok : forall l lpe, + + Lemma interp_PElist_ok : forall l lpe, interp_PElist l lpe -> MPcond (mk_monpol_list lpe) l. Proof. induction lpe;simpl. trivial. destruct a;simpl;intros. assert (HH:=mon_of_pol_ok (norm_subst 0 nil p)); - destruct (mon_of_pol (norm_subst 0 nil p)). + destruct (mon_of_pol (norm_subst 0 nil p)). split. rewrite <- norm_subst_spec by exact I. destruct lpe;try destruct H;rewrite <- H; @@ -1440,7 +1440,7 @@ Section POWER. Proof. intros;apply norm_subst_spec. apply interp_PElist_ok;trivial. Qed. - + Lemma ring_correct : forall n l lpe pe1 pe2, interp_PElist l lpe -> (let lmp := mk_monpol_list lpe in @@ -1448,9 +1448,9 @@ Section POWER. PEeval l pe1 == PEeval l pe2. Proof. simpl;intros. - do 2 (rewrite (norm_subst_ok n l lpe);trivial). + do 2 (rewrite (norm_subst_ok n l lpe);trivial). apply Peq_ok;trivial. - Qed. + Qed. @@ -1467,23 +1467,23 @@ Section POWER. Variable mkopp_pow : R -> positive -> R. (* [mkmult_pow r x p] = r * x^p *) Variable mkmult_pow : R -> R -> positive -> R. - + Fixpoint mkmult_rec (r:R) (lm:list (R*positive)) {struct lm}: R := match lm with | nil => r - | cons (x,p) t => mkmult_rec (mkmult_pow r x p) t + | cons (x,p) t => mkmult_rec (mkmult_pow r x p) t end. Definition mkmult1 lm := match lm with | nil => 1 - | cons (x,p) t => mkmult_rec (mkpow x p) t + | cons (x,p) t => mkmult_rec (mkpow x p) t end. Definition mkmultm1 lm := match lm with | nil => ropp rI - | cons (x,p) t => mkmult_rec (mkopp_pow x p) t + | cons (x,p) t => mkmult_rec (mkopp_pow x p) t end. Definition mkmult_c_pos c lm := @@ -1493,11 +1493,11 @@ Section POWER. Definition mkmult_c c lm := match get_sign c with | None => mkmult_c_pos c lm - | Some c' => + | Some c' => if c' ?=! cI then mkmultm1 (rev' lm) else mkmult_rec [c] (rev' lm) end. - + Definition mkadd_mult rP c lm := match get_sign c with | None => rP + mkmult_c_pos c lm @@ -1505,49 +1505,49 @@ Section POWER. end. Definition add_pow_list (r:R) n l := - match n with + match n with | N0 => l | Npos p => (r,p)::l end. - Fixpoint add_mult_dev + Fixpoint add_mult_dev (rP:R) (P:Pol) (fv:list R) (n:N) (lm:list (R*positive)) {struct P} : R := match P with - | Pc c => + | Pc c => let lm := add_pow_list (hd 0 fv) n lm in mkadd_mult rP c lm - | Pinj j Q => + | Pinj j Q => add_mult_dev rP Q (jump j fv) N0 (add_pow_list (hd 0 fv) n lm) - | PX P i Q => + | PX P i Q => let rP := add_mult_dev rP P fv (Nplus (Npos i) n) lm in - if Q ?== P0 then rP + if Q ?== P0 then rP else add_mult_dev rP Q (tail fv) N0 (add_pow_list (hd 0 fv) n lm) end. - Fixpoint mult_dev (P:Pol) (fv : list R) (n:N) + Fixpoint mult_dev (P:Pol) (fv : list R) (n:N) (lm:list (R*positive)) {struct P} : R := - (* P@l * (hd 0 l)^n * lm *) + (* P@l * (hd 0 l)^n * lm *) match P with | Pc c => mkmult_c c (add_pow_list (hd 0 fv) n lm) | Pinj j Q => mult_dev Q (jump j fv) N0 (add_pow_list (hd 0 fv) n lm) - | PX P i Q => + | PX P i Q => let rP := mult_dev P fv (Nplus (Npos i) n) lm in - if Q ?== P0 then rP - else + if Q ?== P0 then rP + else let lmq := add_pow_list (hd 0 fv) n lm in add_mult_dev rP Q (tail fv) N0 lmq - end. + end. Definition Pphi_avoid fv P := mult_dev P fv N0 nil. - + Fixpoint r_list_pow (l:list (R*positive)) : R := match l with | nil => rI - | cons (r,p) l => pow_pos rmul r p * r_list_pow l + | cons (r,p) l => pow_pos rmul r p * r_list_pow l end. Hypothesis mkpow_spec : forall r p, mkpow r p == pow_pos rmul r p. - Hypothesis mkopp_pow_spec : forall r p, mkopp_pow r p == - (pow_pos rmul r p). + Hypothesis mkopp_pow_spec : forall r p, mkopp_pow r p == - (pow_pos rmul r p). Hypothesis mkmult_pow_spec : forall r x p, mkmult_pow r x p == r * pow_pos rmul x p. Lemma mkmult_rec_ok : forall lm r, mkmult_rec r lm == r * r_list_pow lm. @@ -1571,7 +1571,7 @@ Section POWER. Lemma r_list_pow_rev : forall l, r_list_pow (rev' l) == r_list_pow l. Proof. - assert + assert (forall l lr : list (R * positive), r_list_pow (rev_append l lr) == r_list_pow lr * r_list_pow l). induction l;intros;simpl;Esimpl. destruct a;rewrite IHl;Esimpl. @@ -1583,7 +1583,7 @@ Section POWER. Proof. intros;unfold mkmult_c_pos;simpl. assert (H := (morph_eq CRmorph) c cI). - rewrite <- r_list_pow_rev; destruct (c ?=! cI). + rewrite <- r_list_pow_rev; destruct (c ?=! cI). rewrite H;trivial;Esimpl. apply mkmult1_ok. apply mkmult_rec_ok. Qed. @@ -1610,16 +1610,16 @@ Qed. rewrite mkmult_c_pos_ok;Esimpl. Qed. - Lemma add_pow_list_ok : + Lemma add_pow_list_ok : forall r n l, r_list_pow (add_pow_list r n l) == pow_N rI rmul r n * r_list_pow l. Proof. destruct n;simpl;intros;Esimpl. Qed. - Lemma add_mult_dev_ok : forall P rP fv n lm, + Lemma add_mult_dev_ok : forall P rP fv n lm, add_mult_dev rP P fv n lm == rP + P@fv*pow_N rI rmul (hd 0 fv) n * r_list_pow lm. Proof. - induction P;simpl;intros. + induction P;simpl;intros. rewrite mkadd_mult_ok. rewrite add_pow_list_ok; Esimpl. rewrite IHP. simpl. rewrite add_pow_list_ok; Esimpl. change (match P3 with @@ -1639,7 +1639,7 @@ Qed. rewrite IHP1. destruct n;simpl;Esimpl;rewrite pow_pos_Pplus;Esimpl. Qed. - Lemma mult_dev_ok : forall P fv n lm, + Lemma mult_dev_ok : forall P fv n lm, mult_dev P fv n lm == P@fv * pow_N rI rmul (hd 0 fv) n * r_list_pow lm. Proof. induction P;simpl;intros;Esimpl. @@ -1669,14 +1669,14 @@ Qed. End EVALUATION. - Definition Pphi_pow := - let mkpow x p := + Definition Pphi_pow := + let mkpow x p := match p with xH => x | _ => rpow x (Cp_phi (Npos p)) end in let mkopp_pow x p := ropp (mkpow x p) in let mkmult_pow r x p := rmul r (mkpow x p) in Pphi_avoid mkpow mkopp_pow mkmult_pow. - Lemma local_mkpow_ok : + Lemma local_mkpow_ok : forall (r : R) (p : positive), match p with | xI _ => rpow r (Cp_phi (Npos p)) @@ -1684,13 +1684,13 @@ Qed. | 1 => r end == pow_pos rmul r p. Proof. intros r p;destruct p;try rewrite pow_th.(rpow_pow_N);reflexivity. Qed. - + Lemma Pphi_pow_ok : forall P fv, Pphi_pow fv P == P@fv. Proof. unfold Pphi_pow;intros;apply Pphi_avoid_ok;intros;try rewrite local_mkpow_ok;rrefl. Qed. - Lemma ring_rw_pow_correct : forall n lH l, + Lemma ring_rw_pow_correct : forall n lH l, interp_PElist l lH -> forall lmp, mk_monpol_list lH = lmp -> forall pe npe, norm_subst n lmp pe = npe -> @@ -1701,22 +1701,22 @@ Qed. apply norm_subst_ok. trivial. Qed. - Fixpoint mkmult_pow (r x:R) (p: positive) {struct p} : R := + Fixpoint mkmult_pow (r x:R) (p: positive) {struct p} : R := match p with - | xH => r*x + | xH => r*x | xO p => mkmult_pow (mkmult_pow r x p) x p | xI p => mkmult_pow (mkmult_pow (r*x) x p) x p end. - + Definition mkpow x p := - match p with + match p with | xH => x | xO p => mkmult_pow x x (Pdouble_minus_one p) | xI p => mkmult_pow x x (xO p) end. - + Definition mkopp_pow x p := - match p with + match p with | xH => -x | xO p => mkmult_pow (-x) x (Pdouble_minus_one p) | xI p => mkmult_pow (-x) x (xO p) @@ -1726,31 +1726,31 @@ Qed. Lemma mkmult_pow_ok : forall p r x, mkmult_pow r x p == r*pow_pos rmul x p. Proof. - induction p;intros;simpl;Esimpl. + induction p;intros;simpl;Esimpl. repeat rewrite IHp;Esimpl. repeat rewrite IHp;Esimpl. Qed. - + Lemma mkpow_ok : forall p x, mkpow x p == pow_pos rmul x p. Proof. destruct p;simpl;intros;Esimpl. repeat rewrite mkmult_pow_ok;Esimpl. rewrite mkmult_pow_ok;Esimpl. - pattern x at 1;replace x with (pow_pos rmul x 1). - rewrite <- pow_pos_Pplus. + pattern x at 1;replace x with (pow_pos rmul x 1). + rewrite <- pow_pos_Pplus. rewrite <- Pplus_one_succ_l. rewrite Psucc_o_double_minus_one_eq_xO. simpl;Esimpl. trivial. Qed. - + Lemma mkopp_pow_ok : forall p x, mkopp_pow x p == - pow_pos rmul x p. Proof. destruct p;simpl;intros;Esimpl. repeat rewrite mkmult_pow_ok;Esimpl. rewrite mkmult_pow_ok;Esimpl. - pattern x at 1;replace x with (pow_pos rmul x 1). - rewrite <- pow_pos_Pplus. + pattern x at 1;replace x with (pow_pos rmul x 1). + rewrite <- pow_pos_Pplus. rewrite <- Pplus_one_succ_l. rewrite Psucc_o_double_minus_one_eq_xO. simpl;Esimpl. @@ -1765,7 +1765,7 @@ Qed. intros;apply mkmult_pow_ok. Qed. - Lemma ring_rw_correct : forall n lH l, + Lemma ring_rw_correct : forall n lH l, interp_PElist l lH -> forall lmp, mk_monpol_list lH = lmp -> forall pe npe, norm_subst n lmp pe = npe -> diff --git a/plugins/setoid_ring/Ring_tac.v b/plugins/setoid_ring/Ring_tac.v index 44e97bda77..e3eb418ad1 100644 --- a/plugins/setoid_ring/Ring_tac.v +++ b/plugins/setoid_ring/Ring_tac.v @@ -6,7 +6,7 @@ Require Import BinList. Require Import InitialRing. Require Import Quote. Declare ML Module "newring_plugin". - + (* adds a definition t' on the normal form of t and an hypothesis id stating that t = t' (tries to produces a proof as small as possible) *) @@ -58,8 +58,8 @@ Ltac OnMainSubgoal H ty := Ltac ProveLemmaHyp lemma := match type of lemma with forall x', ?x = x' -> _ => - (fun kont => - let x' := fresh "res" in + (fun kont => + let x' := fresh "res" in let H := fresh "res_eq" in compute_assertion H x' x; let lemma' := constr:(lemma x' H) in @@ -72,8 +72,8 @@ Ltac ProveLemmaHyp lemma := Ltac ProveLemmaHyps lemma := match type of lemma with forall x', ?x = x' -> _ => - (fun kont => - let x' := fresh "res" in + (fun kont => + let x' := fresh "res" in let H := fresh "res_eq" in compute_assertion H x' x; let lemma' := constr:(lemma x' H) in @@ -134,7 +134,7 @@ Ltac ReflexiveRewriteTactic FV_tac SYN_tac LEMMA_tac MAIN_tac fv terms := (* extend the atom list *) let fv := list_fold_left FV_tac fv terms in - let RW_tac lemma := + let RW_tac lemma := let fcons term CONT_tac := let expr := SYN_tac term fv in (ApplyLemmaThenAndCont lemma expr MAIN_tac CONT_tac) in @@ -154,8 +154,8 @@ Ltac FV_hypo_tac mkFV req lH := list_fold_right FV_hypo_r_tac fv lH. Ltac mkHyp_tac C req Reify lH := - let mkHyp h res := - match h with + let mkHyp h res := + match h with | @mkhypo (req ?r1 ?r2) _ => let pe1 := Reify r1 in let pe2 := Reify r2 in @@ -173,9 +173,9 @@ Ltac proofHyp_tac lH := match l with | nil => constr:(I) | cons ?h nil => get_proof h - | cons ?h ?tl => + | cons ?h ?tl => let l := get_proof h in - let r := bh tl in + let r := bh tl in constr:(conj l r) end in bh lH. @@ -213,22 +213,22 @@ Ltac FV Cst CstPow add mul sub opp pow t fv := in TFV t fv. (* syntaxification of ring expressions *) -Ltac mkPolexpr C Cst CstPow radd rmul rsub ropp rpow t fv := +Ltac mkPolexpr C Cst CstPow radd rmul rsub ropp rpow t fv := let rec mkP t := let f := match Cst t with | InitialRing.NotConstant => - match t with - | (radd ?t1 ?t2) => + match t with + | (radd ?t1 ?t2) => fun _ => let e1 := mkP t1 in let e2 := mkP t2 in constr:(PEadd e1 e2) - | (rmul ?t1 ?t2) => + | (rmul ?t1 ?t2) => fun _ => let e1 := mkP t1 in let e2 := mkP t2 in constr:(PEmul e1 e2) - | (rsub ?t1 ?t2) => - fun _ => + | (rsub ?t1 ?t2) => + fun _ => let e1 := mkP t1 in let e2 := mkP t2 in constr:(PEsub e1 e2) | (ropp ?t1) => @@ -236,7 +236,7 @@ Ltac mkPolexpr C Cst CstPow radd rmul rsub ropp rpow t fv := let e1 := mkP t1 in constr:(PEopp e1) | (rpow ?t1 ?n) => match CstPow n with - | InitialRing.NotConstant => + | InitialRing.NotConstant => fun _ => let p := Find_at t fv in constr:(PEX C p) | ?c => fun _ => let e1 := mkP t1 in constr:(PEpow e1 c) end @@ -311,7 +311,7 @@ Ltac get_RingHypTac RNG := (* ring tactics *) Definition ring_subst_niter := (10*10*10)%nat. - + Ltac Ring RNG lemma lH := let req := get_Eq RNG in OnEquation req ltac:(fun lhs rhs => @@ -343,7 +343,7 @@ Ltac Ring_norm_gen f RNG lemma lH rl := let mkHyp := get_RingHypTac RNG in let mk_monpol := get_MonPol lemma in let fv := FV_hypo_tac mkFV ltac:(get_Eq RNG) lH in - let lemma_tac fv kont := + let lemma_tac fv kont := let lpe := mkHyp fv lH in let vlpe := fresh "list_hyp" in let vlmp := fresh "list_hyp_norm" in @@ -390,25 +390,25 @@ Ltac Ring_simplify_gen f RNG lH rl := end in let Heq := fresh "Heq" in intros Heq;clear Heq l; - Ring_norm_gen f RNG (lemma ring_subst_niter) lH rl; + Ring_norm_gen f RNG (lemma ring_subst_niter) lH rl; get_Post RNG (). Ltac Ring_simplify := Ring_simplify_gen ltac:(fun H => rewrite H). -Tactic Notation (at level 0) "ring_simplify" constr_list(rl) := +Tactic Notation (at level 0) "ring_simplify" constr_list(rl) := let G := Get_goal in ring_lookup (PackRing Ring_simplify) [] rl G. -Tactic Notation (at level 0) +Tactic Notation (at level 0) "ring_simplify" "[" constr_list(lH) "]" constr_list(rl) := let G := Get_goal in ring_lookup (PackRing Ring_simplify) [lH] rl G. (* MON DIEU QUE C'EST MOCHE !!!!!!!!!!!!! *) -Tactic Notation "ring_simplify" constr_list(rl) "in" hyp(H):= +Tactic Notation "ring_simplify" constr_list(rl) "in" hyp(H):= let G := Get_goal in - let t := type of H in + let t := type of H in let g := fresh "goal" in set (g:= G); generalize H;clear H; @@ -416,10 +416,10 @@ Tactic Notation "ring_simplify" constr_list(rl) "in" hyp(H):= intro H; unfold g;clear g. -Tactic Notation - "ring_simplify" "["constr_list(lH)"]" constr_list(rl) "in" hyp(H):= +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 t := type of H in let g := fresh "goal" in set (g:= G); generalize H;clear H; diff --git a/plugins/setoid_ring/Ring_theory.v b/plugins/setoid_ring/Ring_theory.v index 531ab3ca5e..b3250a510f 100644 --- a/plugins/setoid_ring/Ring_theory.v +++ b/plugins/setoid_ring/Ring_theory.v @@ -39,7 +39,7 @@ Section Power. Notation "x * y " := (rmul x y). Notation "x == y" := (req x y). - Hypothesis mul_ext : + Hypothesis mul_ext : forall x1 x2, x1 == x2 -> forall y1 y2, y1 == y2 -> x1 * y1 == x2 * y2. Hypothesis mul_comm : forall x y, x * y == y * x. Hypothesis mul_assoc : forall x y z, x * (y * z) == (x * y) * z. @@ -79,11 +79,11 @@ Section Power. simpl. apply (Seq_refl _ _ Rsth). Qed. - Definition pow_N (x:R) (p:N) := + Definition pow_N (x:R) (p:N) := match p with | N0 => rI | Npos p => pow_pos x p - end. + end. Definition id_phi_N (x:N) : N := x. @@ -109,12 +109,12 @@ Section DEFINITIONS. SRadd_comm : forall n m, n + m == m + n ; SRadd_assoc : forall n m p, n + (m + p) == (n + m) + p; SRmul_1_l : forall n, 1*n == n; - SRmul_0_l : forall n, 0*n == 0; + SRmul_0_l : forall n, 0*n == 0; SRmul_comm : forall n m, n*m == m*n; SRmul_assoc : forall n m p, n*(m*p) == (n*m)*p; SRdistr_l : forall n m p, (n + m)*p == n*p + m*p }. - + (** Almost Ring *) (*Almost ring are no ring : Ropp_def is missing **) Record almost_ring_theory : Prop := mk_art { @@ -129,7 +129,7 @@ Section DEFINITIONS. ARopp_mul_l : forall x y, -(x * y) == -x * y; ARopp_add : forall x y, -(x + y) == -x + -y; ARsub_def : forall x y, x - y == x + -y - }. + }. (** Ring *) Record ring_theory : Prop := mk_rt { @@ -145,7 +145,7 @@ Section DEFINITIONS. }. (** Equality is extensional *) - + Record sring_eq_ext : Prop := mk_seqe { (* SRing operators are compatible with equality *) SRadd_ext : @@ -163,12 +163,12 @@ Section DEFINITIONS. Ropp_ext : forall x1 x2, x1 == x2 -> -x1 == -x2 }. - (** Interpretation morphisms definition*) + (** Interpretation morphisms definition*) Section MORPHISM. Variable C:Type. Variable (cO cI : C) (cadd cmul csub : C->C->C) (copp : C->C). Variable ceqb : C->C->bool. - (* [phi] est un morphisme de [C] dans [R] *) + (* [phi] est un morphisme de [C] dans [R] *) Variable phi : C -> R. Notation "x +! y" := (cadd x y). Notation "x -! y " := (csub x y). Notation "x *! y " := (cmul x y). Notation "-! x" := (copp x). @@ -180,7 +180,7 @@ Section DEFINITIONS. Smorph1 : [cI] == 1; Smorph_add : forall x y, [x +! y] == [x]+[y]; Smorph_mul : forall x y, [x *! y] == [x]*[y]; - Smorph_eq : forall x y, x?=!y = true -> [x] == [y] + Smorph_eq : forall x y, x?=!y = true -> [x] == [y] }. (* for rings*) @@ -191,7 +191,7 @@ Section DEFINITIONS. morph_sub : forall x y, [x -! y] == [x]-[y]; morph_mul : forall x y, [x *! y] == [x]*[y]; morph_opp : forall x, [-!x] == -[x]; - morph_eq : forall x y, x?=!y = true -> [x] == [y] + morph_eq : forall x y, x?=!y = true -> [x] == [y] }. Section SIGN. @@ -213,7 +213,7 @@ Section DEFINITIONS. }. End DIV. - End MORPHISM. + End MORPHISM. (** Identity is a morphism *) Variable Rsth : Setoid_Theory R req. @@ -231,8 +231,8 @@ Section DEFINITIONS. Section POWER. Variable Cpow : Set. Variable Cp_phi : N -> Cpow. - Variable rpow : R -> Cpow -> R. - + Variable rpow : R -> Cpow -> R. + Record power_theory : Prop := mkpow_th { rpow_pow_N : forall r n, req (rpow r (Cp_phi n)) (pow_N rI rmul r n) }. @@ -241,7 +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. @@ -268,7 +268,7 @@ Section ALMOST_RING. Variable Rsth : Setoid_Theory R req. Add Setoid R req Rsth as R_setoid2. Ltac sreflexivity := apply (Seq_refl _ _ Rsth). - + Section SEMI_RING. Variable SReqe : sring_eq_ext radd rmul req. Add Morphism radd : radd_ext1. exact (SRadd_ext SReqe). Qed. @@ -278,7 +278,7 @@ Section ALMOST_RING. (** Every semi ring can be seen as an almost ring, by taking : -x = x and x - y = x + y *) Definition SRopp (x:R) := x. Notation "- x" := (SRopp x). - + Definition SRsub x y := x + -y. Notation "x - y " := (SRsub x y). Lemma SRopp_ext : forall x y, x == y -> -x == -y. @@ -296,7 +296,7 @@ Section ALMOST_RING. Lemma SRopp_add : forall x y, -(x + y) == -x + -y. Proof. intros;sreflexivity. Qed. - + Lemma SRsub_def : forall x y, x - y == x + -y. Proof. intros;sreflexivity. Qed. @@ -306,7 +306,7 @@ Section ALMOST_RING. (SRmul_1_l SRth) (SRmul_0_l SRth) (SRmul_comm SRth) (SRmul_assoc SRth) (SRdistr_l SRth) SRopp_mul_l SRopp_add SRsub_def). - + (** Identity morphism for semi-ring equipped with their almost-ring structure*) Variable reqb : R->R->bool. @@ -337,12 +337,12 @@ Section ALMOST_RING. Qed. End SEMI_RING. - + Variable Reqe : ring_eq_ext radd rmul ropp req. Add Morphism radd : radd_ext2. exact (Radd_ext Reqe). Qed. Add Morphism rmul : rmul_ext2. exact (Rmul_ext Reqe). Qed. Add Morphism ropp : ropp_ext2. exact (Ropp_ext Reqe). Qed. - + Section RING. Variable Rth : ring_theory 0 1 radd rmul rsub ropp req. @@ -368,7 +368,7 @@ Section ALMOST_RING. rewrite (Rth.(Radd_comm) (-x));rewrite (Ropp_def Rth). rewrite Rmul_0_l;rewrite (Radd_0_l Rth);sreflexivity. Qed. - + Lemma Ropp_add : forall x y, -(x + y) == -x + -y. Proof. intros x y;rewrite <- ((Radd_0_l Rth) (-(x+y))). @@ -387,7 +387,7 @@ Section ALMOST_RING. rewrite ((Radd_comm Rth) (-x) 0);rewrite (Radd_0_l Rth). apply (Radd_comm Rth). Qed. - + Lemma Ropp_opp : forall x, - -x == x. Proof. intros x; rewrite <- (Radd_0_l Rth (- -x)). @@ -402,7 +402,7 @@ Section ALMOST_RING. (Rmul_1_l Rth) Rmul_0_l (Rmul_comm Rth) (Rmul_assoc Rth) (Rdistr_l Rth) Ropp_mul_l Ropp_add (Rsub_def Rth)). - (** Every semi morphism between two rings is a morphism*) + (** Every semi morphism between two rings is a morphism*) Variable C : Type. Variable (cO cI : C) (cadd cmul csub: C->C->C) (copp : C -> C). Variable (ceq : C -> C -> Prop) (ceqb : C -> C -> bool). @@ -431,7 +431,7 @@ Section ALMOST_RING. rewrite (Smorph0 Smorph). rewrite (Radd_comm Rth (-[x])). apply (Radd_0_l Rth);sreflexivity. - Qed. + Qed. Lemma Smorph_sub : forall x y, [x -! y] == [x] - [y]. Proof. @@ -439,11 +439,11 @@ Section ALMOST_RING. rewrite (Smorph_add Smorph);rewrite Smorph_opp;sreflexivity. Qed. - Lemma Smorph_morph : ring_morph 0 1 radd rmul rsub ropp req + Lemma Smorph_morph : ring_morph 0 1 radd rmul rsub ropp req cO cI cadd cmul csub copp ceqb phi. Proof (mkmorph 0 1 radd rmul rsub ropp req cO cI cadd cmul csub copp ceqb phi - (Smorph0 Smorph) (Smorph1 Smorph) + (Smorph0 Smorph) (Smorph1 Smorph) (Smorph_add Smorph) Smorph_sub (Smorph_mul Smorph) Smorph_opp (Smorph_eq Smorph)). @@ -462,7 +462,7 @@ Qed. forall x1 x2, x1 == x2 -> forall y1 y2, y1 == y2 -> x1 - y1 == x2 - y2. Proof. intros. - setoid_replace (x1 - y1) with (x1 + -y1). + setoid_replace (x1 - y1) with (x1 + -y1). setoid_replace (x2 - y2) with (x2 + -y2). rewrite H;rewrite H0;sreflexivity. apply (ARsub_def ARth). @@ -483,10 +483,10 @@ Qed. | match goal with | |- context [?z * (?x + ?y)] => rewrite ((ARmul_comm ARth) z (x+y)) end]. - + Lemma ARadd_0_r : forall x, (x + 0) == x. Proof. intros; mrewrite. Qed. - + Lemma ARmul_1_r : forall x, x * 1 == x. Proof. intros;mrewrite. Qed. @@ -495,7 +495,7 @@ Qed. Lemma ARdistr_r : forall x y z, z * (x + y) == z*x + z*y. Proof. - intros;mrewrite. + intros;mrewrite. repeat rewrite (ARth.(ARmul_comm) z);sreflexivity. Qed. @@ -516,7 +516,7 @@ Qed. intros;rewrite <-((ARmul_assoc ARth) x). rewrite ((ARmul_comm ARth) x);sreflexivity. Qed. - + Lemma ARmul_assoc2 : forall x y z, (y * x) * z == (y * z) * x. Proof. intros; repeat rewrite <- (ARmul_assoc ARth); @@ -592,17 +592,17 @@ Ltac gen_srewrite Rsth Reqe ARth := Ltac gen_add_push add Rsth Reqe ARth x := repeat (match goal with - | |- context [add (add ?y x) ?z] => + | |- context [add (add ?y x) ?z] => progress rewrite (ARadd_assoc2 Rsth Reqe ARth x y z) - | |- context [add (add x ?y) ?z] => + | |- context [add (add x ?y) ?z] => progress rewrite (ARadd_assoc1 Rsth ARth x y z) end). Ltac gen_mul_push mul Rsth Reqe ARth x := repeat (match goal with - | |- context [mul (mul ?y x) ?z] => + | |- context [mul (mul ?y x) ?z] => progress rewrite (ARmul_assoc2 Rsth Reqe ARth x y z) - | |- context [mul (mul x ?y) ?z] => + | |- context [mul (mul x ?y) ?z] => progress rewrite (ARmul_assoc1 Rsth ARth x y z) end). diff --git a/plugins/setoid_ring/ZArithRing.v b/plugins/setoid_ring/ZArithRing.v index 942915abf2..4cb5a05a38 100644 --- a/plugins/setoid_ring/ZArithRing.v +++ b/plugins/setoid_ring/ZArithRing.v @@ -21,7 +21,7 @@ Ltac Zcst t := end. Ltac isZpow_coef t := - match t with + match t with | Zpos ?p => isPcst p | Z0 => constr:true | _ => constr:false @@ -41,18 +41,18 @@ Ltac Zpow_tac t := Ltac Zpower_neg := repeat match goal with - | [|- ?G] => - match G with + | [|- ?G] => + match G with | context c [Zpower _ (Zneg _)] => let t := context c [Z0] in change t end - end. + end. Add Ring Zr : Zth (decidable Zeq_bool_eq, constants [Zcst], preprocess [Zpower_neg;unfold Zsucc], power_tac Zpower_theory [Zpow_tac], - (* The two following option are not needed, it is the default chose when the set of + (* 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/plugins/setoid_ring/newring.ml4 b/plugins/setoid_ring/newring.ml4 index 14d10e54f6..c6d9bf44a0 100644 --- a/plugins/setoid_ring/newring.ml4 +++ b/plugins/setoid_ring/newring.ml4 @@ -108,9 +108,9 @@ let protect_tac_in map id = TACTIC EXTEND protect_fv - [ "protect_fv" string(map) "in" ident(id) ] -> + [ "protect_fv" string(map) "in" ident(id) ] -> [ protect_tac_in map id ] -| [ "protect_fv" string(map) ] -> +| [ "protect_fv" string(map) ] -> [ protect_tac map ] END;; @@ -128,8 +128,8 @@ TACTIC EXTEND closed_term END ;; -TACTIC EXTEND echo -| [ "echo" constr(t) ] -> +TACTIC EXTEND echo +| [ "echo" constr(t) ] -> [ Pp.msg (Termops.print_constr t); Tacinterp.eval_tactic (TacId []) ] END;; @@ -159,11 +159,11 @@ let ic c = let ty c = Typing.type_of (Global.env()) Evd.empty c let decl_constant na c = - mkConst(declare_constant (id_of_string na) (DefinitionEntry + mkConst(declare_constant (id_of_string na) (DefinitionEntry { const_entry_body = c; const_entry_type = None; const_entry_opaque = true; - const_entry_boxed = true}, + const_entry_boxed = true}, IsProof Lemma)) (* Calling a global tactic *) @@ -187,7 +187,7 @@ let ltac_record flds = let carg c = TacDynamic(dummy_loc,Pretyping.constr_in c) -let dummy_goal env = +let dummy_goal env = {Evd.it = Evd.make_evar (named_context_val env) mkProp; Evd.sigma = Evd.empty} @@ -228,7 +228,7 @@ let coq_eq = coq_constant "eq" let lapp f args = mkApp(Lazy.force f,args) -let dest_rel0 t = +let dest_rel0 t = match kind_of_term t with | App(f,args) when Array.length args >= 2 -> let rel = mkApp(f,Array.sub args 0 (Array.length args - 2)) in @@ -321,9 +321,9 @@ let _ = add_map "ring" (* Pphi_dev: evaluate polynomial and coef operations, protect ring operations and make recursive call on the var map *) pol_cst "Pphi_dev", (function -1|8|9|10|11|12|14->Eval|13->Rec|_->Prot); - pol_cst "Pphi_pow", + pol_cst "Pphi_pow", (function -1|8|9|10|11|13|15|17->Eval|16->Rec|_->Prot); - (* PEeval: evaluate morphism and polynomial, protect ring + (* PEeval: evaluate morphism and polynomial, protect ring operations and make recursive call on the var map *) pol_cst "PEeval", (function -1|7|9|12->Eval|11->Rec|_->Prot)]) @@ -379,7 +379,7 @@ let find_ring_structure env sigma l = (str"cannot find a declared ring structure for equality"++ spc()++str"\""++pr_constr req++str"\"")) *) -let _ = +let _ = Summary.declare_summary "tactic-new-ring-table" { Summary.freeze_function = (fun () -> !from_carrier,!from_relation,!from_name); @@ -397,11 +397,11 @@ let add_entry (sp,_kn) e = *) from_carrier := Cmap.add e.ring_carrier e !from_carrier; from_relation := Cmap.add e.ring_req e !from_relation; - from_name := Spmap.add sp e !from_name + from_name := Spmap.add sp e !from_name -let subst_th (_,subst,th) = - let c' = subst_mps subst th.ring_carrier in +let subst_th (_,subst,th) = + let c' = subst_mps subst th.ring_carrier in let eq' = subst_mps subst th.ring_req in let set' = subst_mps subst th.ring_setoid in let ext' = subst_mps subst th.ring_ext in @@ -454,11 +454,11 @@ let (theory_to_obj, obj_to_theory) = let setoid_of_relation env a r = let evm = Evd.empty in - try + try lapp coq_mk_Setoid - [|a ; r ; - Rewrite.get_reflexive_proof env evm a r ; - Rewrite.get_symmetric_proof env evm a r ; + [|a ; r ; + Rewrite.get_reflexive_proof env evm a r ; + Rewrite.get_symmetric_proof env evm a r ; Rewrite.get_transitive_proof env evm a r |] with Not_found -> error "cannot find setoid relation" @@ -551,9 +551,9 @@ let ring_equality (r,add,mul,opp,req) = 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 + Flags.if_verbose msgnl - (str"Using setoid \""++pr_constr req++str"\""++spc()++ + (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++ @@ -562,13 +562,13 @@ let ring_equality (r,add,mul,opp,req) = | None -> (Flags.if_verbose msgnl - (str"Using setoid \""++pr_constr req ++str"\"" ++ spc() ++ + (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 @@ -652,18 +652,18 @@ let make_hyp env c = let make_hyp_list env lH = let carrier = Lazy.force coq_hypo in - List.fold_right + List.fold_right (fun c l -> lapp coq_cons [|carrier; (make_hyp env c); l|]) lH (lapp coq_nil [|carrier|]) -let interp_power env pow = +let interp_power env pow = let carrier = Lazy.force coq_hypo in match pow with - | None -> + | None -> let t = ArgArg(dummy_loc, Lazy.force ltac_inv_morph_nothing) in (TacArg(TacCall(dummy_loc,t,[])), lapp coq_None [|carrier|]) - | Some (tac, spec) -> - let tac = + | Some (tac, spec) -> + let tac = match tac with | CstTac t -> Tacinterp.glob_tactic t | Closed lc -> @@ -674,8 +674,8 @@ let interp_power env pow = let interp_sign env sign = let carrier = Lazy.force coq_hypo in match sign with - | None -> lapp coq_None [|carrier|] - | Some spec -> + | 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 ... *) @@ -683,8 +683,8 @@ let interp_sign env sign = let interp_div env div = let carrier = Lazy.force coq_hypo in match div with - | None -> lapp coq_None [|carrier|] - | Some spec -> + | 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 ... *) @@ -695,12 +695,12 @@ let add_theory name rth eqth morphth cst_tac (pre,post) power sign div = let sigma = Evd.empty in let (kind,r,zero,one,add,mul,sub,opp,req) = dest_ring env sigma rth in let (sth,ext) = build_setoid_params r add mul opp req eqth in - let (pow_tac, pspec) = interp_power env power in + let (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") + exec_tactic env 5 (zltac "ring_lemmas") (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 @@ -757,7 +757,7 @@ VERNAC ARGUMENT EXTEND ring_mod | [ "setoid" constr(sth) constr(ext) ] -> [ Setoid(sth,ext) ] | [ "sign" constr(sign_spec) ] -> [ Sign_spec sign_spec ] | [ "power" constr(pow_spec) "[" ne_global_list(l) "]" ] -> - [ Pow_spec (Closed l, pow_spec) ] + [ 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 ] @@ -780,7 +780,7 @@ let process_ring_mods l = | Const_tac t -> set_once "tactic recognizing constants" cst_tac t | Pre_tac t -> set_once "preprocess tactic" pre t | Post_tac t -> set_once "postprocess tactic" post t - | Setoid(sth,ext) -> set_once "setoid" set (ic sth,ic ext) + | 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 | Div_spec t -> set_once "div" div t) l; @@ -797,7 +797,7 @@ END (* The tactics consist then only in a lookup in the ring database and call the appropriate ltac. *) -let make_args_list rl t = +let make_args_list rl t = match rl with | [] -> let (_,t1,t2) = dest_rel0 t in [t1;t2] | _ -> rl @@ -838,7 +838,7 @@ TACTIC EXTEND ring_lookup END - + (***********************************************************************) let new_field_path = @@ -861,12 +861,12 @@ let _ = add_map "field" (* Pphi_dev: evaluate polynomial and coef operations, protect ring operations and make recursive call on the var map *) pol_cst "Pphi_dev", (function -1|8|9|10|11|12|14->Eval|13->Rec|_->Prot); - pol_cst "Pphi_pow", + pol_cst "Pphi_pow", (function -1|8|9|10|11|13|15|17->Eval|16->Rec|_->Prot); - (* PEeval: evaluate morphism and polynomial, protect ring + (* PEeval: evaluate morphism and polynomial, protect ring operations and make recursive call on the var map *) pol_cst "PEeval", (function -1|7|9|12->Eval|11->Rec|_->Prot); - (* FEeval: evaluate morphism, protect field + (* FEeval: evaluate morphism, protect field operations and make recursive call on the var map *) my_constant "FEeval", (function -1|8|9|10|11|14->Eval|13->Rec|_->Prot)]);; @@ -958,7 +958,7 @@ let find_field_structure env sigma l = (str"cannot find a declared field structure for equality"++ spc()++str"\""++pr_constr req++str"\"")) *) -let _ = +let _ = Summary.declare_summary "tactic-new-field-table" { Summary.freeze_function = (fun () -> !field_from_carrier,!field_from_relation,!field_from_name); @@ -980,10 +980,10 @@ let add_field_entry (sp,_kn) e = *) field_from_carrier := Cmap.add e.field_carrier e !field_from_carrier; field_from_relation := Cmap.add e.field_req e !field_from_relation; - field_from_name := Spmap.add sp e !field_from_name + field_from_name := Spmap.add sp e !field_from_name -let subst_th (_,subst,th) = - let c' = subst_mps subst th.field_carrier in +let subst_th (_,subst,th) = + let c' = subst_mps subst th.field_carrier in let eq' = subst_mps subst th.field_req in let thm1' = subst_mps subst th.field_ok in let thm2' = subst_mps subst th.field_simpl_eq_ok in @@ -1041,7 +1041,7 @@ let field_equality r inv req = 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 odiv = check_required_library (cdir@["Field_tac"]); let env = Global.env() in @@ -1051,7 +1051,7 @@ let add_field_theory name fth eqth morphth cst_tac inj (pre,post) power sign odi 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 odiv in - let (pow_tac, pspec) = interp_power env power in + let (pow_tac, pspec) = interp_power env power in let sspec = interp_sign env sign in let dspec = interp_div env odiv in let inv_m = field_equality r inv req in @@ -1112,7 +1112,7 @@ let process_field_mods l = let cst_tac = ref None in let pre = ref None in let post = ref None in - let inj = ref None in + let inj = ref None in let sign = ref None in let power = ref None in let div = ref None in @@ -1131,7 +1131,7 @@ let process_field_mods l = (k, !set, !inj, !cst_tac, !pre, !post, !power, !sign, !div) VERNAC COMMAND EXTEND AddSetoidField -| [ "Add" "Field" ident(id) ":" constr(t) field_mods(l) ] -> +| [ "Add" "Field" ident(id) ":" constr(t) field_mods(l) ] -> [ 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 @@ -1163,6 +1163,6 @@ let field_lookup (f:glob_tactic_expr) lH rl t gl = TACTIC EXTEND field_lookup -| [ "field_lookup" tactic(f) "[" constr_list(lH) "]" ne_constr_list(lt) ] -> +| [ "field_lookup" tactic(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/plugins/subtac/equations.ml4 b/plugins/subtac/equations.ml4 index 5ae15e00a1..ca4445cc2e 100644 --- a/plugins/subtac/equations.ml4 +++ b/plugins/subtac/equations.ml4 @@ -8,7 +8,7 @@ (************************************************************************) (*i camlp4deps: "parsing/grammar.cma" i*) -(*i camlp4use: "pa_extend.cmo" i*) +(*i camlp4use: "pa_extend.cmo" i*) (* $Id$ *) @@ -40,18 +40,18 @@ type pat = | PInac of constr let coq_inacc = lazy (Coqlib.gen_constant "equations" ["Program";"Equality"] "inaccessible_pattern") - + let mkInac env c = mkApp (Lazy.force coq_inacc, [| Typing.type_of env Evd.empty c ; c |]) - + let rec constr_of_pat ?(inacc=true) env = function | PRel i -> mkRel i - | PCstr (c, p) -> + | PCstr (c, p) -> let c' = mkConstruct c in mkApp (c', Array.of_list (constrs_of_pats ~inacc env p)) - | PInac r -> + | PInac r -> if inacc then try mkInac env r with _ -> r else r - + and constrs_of_pats ?(inacc=true) env l = map (constr_of_pat ~inacc env) l let rec pat_vars = function @@ -59,8 +59,8 @@ let rec pat_vars = function | PCstr (c, p) -> pats_vars p | PInac _ -> Intset.empty -and pats_vars l = - fold_left (fun vars p -> +and pats_vars l = + fold_left (fun vars p -> let pvars = pat_vars p in let inter = Intset.inter pvars vars in if inter = Intset.empty then @@ -70,7 +70,7 @@ and pats_vars l = Intset.empty l let rec pats_of_constrs l = map pat_of_constr l -and pat_of_constr c = +and pat_of_constr c = match kind_of_term c with | Rel i -> PRel i | App (f, [| a ; c |]) when eq_constr f (Lazy.force coq_inacc) -> @@ -95,10 +95,10 @@ let rec pmatch p c = and pmatches pl l = match pl, l with | [], [] -> [] - | hd :: tl, hd' :: tl' -> + | hd :: tl, hd' :: tl' -> pmatch hd hd' @ pmatches tl tl' | _ -> raise Conflict - + let pattern_matches pl l = try Some (pmatches pl l) with Conflict -> None let rec pinclude p c = @@ -108,59 +108,59 @@ let rec pinclude p c = | PInac _, _ -> true | _, PInac _ -> true | _, _ -> false - + and pincludes pl l = match pl, l with | [], [] -> true - | hd :: tl, hd' :: tl' -> + | hd :: tl, hd' :: tl' -> pinclude hd hd' && pincludes tl tl' | _ -> false - + let pattern_includes pl l = pincludes pl l (** Specialize by a substitution. *) let subst_tele s = replace_vars (List.map (fun (id, _, t) -> id, t) s) -let subst_rel_subst k s c = +let subst_rel_subst k s c = let rec aux depth c = match kind_of_term c with - | Rel n -> - let k = n - depth in - if k >= 0 then + | Rel n -> + let k = n - depth in + if k >= 0 then try lift depth (snd (assoc k s)) with Not_found -> c else c | _ -> map_constr_with_binders succ aux depth c in aux k c - + let subst_context s ctx = - let (_, ctx') = fold_right + let (_, ctx') = fold_right (fun (id, b, t) (k, ctx') -> (succ k, (id, Option.map (subst_rel_subst k s) b, subst_rel_subst k s t) :: ctx')) ctx (0, []) in ctx' -let subst_rel_context k cstr ctx = - let (_, ctx') = fold_right +let subst_rel_context k cstr ctx = + let (_, ctx') = fold_right (fun (id, b, t) (k, ctx') -> (succ k, (id, Option.map (substnl [cstr] k) b, substnl [cstr] k t) :: ctx')) ctx (k, []) in ctx' -let rec lift_pat n k p = +let rec lift_pat n k p = match p with | PRel i -> if i >= k then PRel (i + n) else p | PCstr(c, pl) -> PCstr (c, lift_pats n k pl) | PInac r -> PInac (liftn n k r) - + and lift_pats n k = map (lift_pat n k) -let rec subst_pat env k t p = +let rec subst_pat env k t p = match p with - | PRel i -> + | PRel i -> if i = k then t else if i > k then PRel (pred i) else p @@ -170,9 +170,9 @@ let rec subst_pat env k t p = and subst_pats env k t = map (subst_pat env k t) -let rec specialize s p = +let rec specialize s p = match p with - | PRel i -> + | PRel i -> if mem_assoc i s then let b, t = assoc i s in if b then PInac t @@ -190,10 +190,10 @@ let specialize_patterns = function | s -> specialize_pats s let specialize_rel_context s ctx = - snd (fold_right (fun (n, b, t) (k, ctx) -> + snd (fold_right (fun (n, b, t) (k, ctx) -> (succ k, (n, Option.map (subst_rel_subst k s) b, subst_rel_subst k s t) :: ctx)) ctx (0, [])) - + let lift_contextn n k sign = let rec liftrec k = function | (na,c,t)::sign -> @@ -202,7 +202,7 @@ let lift_contextn n k sign = in liftrec (rel_context_length sign + k) sign -type program = +type program = signature * clause list and signature = identifier * rel_context * constr @@ -211,16 +211,16 @@ and clause = lhs * (constr, int) rhs and lhs = rel_context * identifier * pat list -and ('a, 'b) rhs = +and ('a, 'b) rhs = | Program of 'a | Empty of 'b -type splitting = +type splitting = | Compute of clause | Split of lhs * int * inductive_family * unification_result array * splitting option array - -and unification_result = + +and unification_result = rel_context * int * constr * pat * substitution option and substitution = (int * (bool * constr)) list @@ -236,14 +236,14 @@ let split_solves split prob = | Compute (lhs, rhs) -> lhs = prob | Split (lhs, id, indf, us, ls) -> lhs = prob -let ids_of_constr c = - let rec aux vars c = +let ids_of_constr c = + let rec aux vars c = match kind_of_term c with | Var id -> Idset.add id vars | _ -> fold_constr aux vars c in aux Idset.empty c -let ids_of_constrs = +let ids_of_constrs = fold_left (fun acc x -> Idset.union (ids_of_constr x) acc) Idset.empty let idset_of_list = @@ -252,8 +252,8 @@ let idset_of_list = let intset_of_list = fold_left (fun s x -> Intset.add x s) Intset.empty -let solves split (delta, id, pats as prob) = - split_solves split prob && +let solves split (delta, id, pats as prob) = + split_solves split prob && Intset.equal (pats_vars pats) (intset_of_list (map destRel (rels_of_tele delta))) let check_judgment ctx c t = @@ -261,7 +261,7 @@ let check_judgment ctx c t = let check_context env ctx = fold_right - (fun (_, _, t as decl) env -> + (fun (_, _, t as decl) env -> ignore(Typing.sort_of env Evd.empty t); push_rel decl env) ctx env @@ -270,7 +270,7 @@ let split_context n c = match before with | hd :: tl -> after, hd, tl | [] -> raise (Invalid_argument "split_context") - + let split_tele n (ctx : rel_context) = let rec aux after n l = match n, l with @@ -284,12 +284,12 @@ let rec add_var_subst env subst n c = let t = assoc n subst in if eq_constr t c then subst else unify env subst t c - else + else let rel = mkRel n in if rel = c then subst else if dependent rel c then raise Conflict else (n, c) :: subst - + and unify env subst x y = match kind_of_term x, kind_of_term y with | Rel n, _ -> add_var_subst env subst n y @@ -298,7 +298,7 @@ and unify env subst x y = unify_constrs env subst (Array.to_list l) (Array.to_list l') | _, _ -> if eq_constr x y then subst else raise Conflict -and unify_constrs (env : env) subst l l' = +and unify_constrs (env : env) subst l l' = if List.length l = List.length l' then fold_left2 (unify env) subst l l' else raise Conflict @@ -306,10 +306,10 @@ and unify_constrs (env : env) subst l l' = let fold_rel_context_with_binders f ctx init = snd (List.fold_right (fun decl (depth, acc) -> (succ depth, f depth decl acc)) ctx (0, init)) - + let dependent_rel_context (ctx : rel_context) k = fold_rel_context_with_binders - (fun depth (n,b,t) acc -> + (fun depth (n,b,t) acc -> let r = mkRel (depth + k) in acc || dependent r t || (match b with @@ -319,14 +319,14 @@ let dependent_rel_context (ctx : rel_context) k = let liftn_between n k p c = let rec aux depth c = match kind_of_term c with - | Rel i -> + | Rel i -> if i <= depth then c else if i-depth > p then c else mkRel (i - n) | _ -> map_constr_with_binders succ aux depth c in aux k c - -let liftn_rel_context n k sign = + +let liftn_rel_context n k sign = let rec liftrec k = function | (na,c,t)::sign -> (na,Option.map (liftn n k) c,liftn n k t)::(liftrec (k-1) sign) @@ -348,7 +348,7 @@ let reduce_rel_context (ctx : rel_context) (subst : (int * (bool * constr)) list let s = rev s in let s' = map (fun (korig, (b, knew)) -> korig, (b, substl s knew)) subst in s', ctx' - + (* Compute the transitive closure of the dependency relation for a term in a context *) let rec dependencies_of_rel ctx k = @@ -356,12 +356,12 @@ let rec dependencies_of_rel ctx k = let b = Option.map (lift k) b and t = lift k t in let bdeps = match b with Some b -> dependencies_of_term ctx b | None -> Intset.empty in Intset.union (Intset.singleton k) (Intset.union bdeps (dependencies_of_term ctx t)) - + and dependencies_of_term ctx t = let rels = free_rels t in Intset.fold (fun i -> Intset.union (dependencies_of_rel ctx i)) rels Intset.empty -let subst_telescope k cstr ctx = +let subst_telescope k cstr ctx = let (_, ctx') = fold_left (fun (k, ctx') (id, b, t) -> (succ k, (id, Option.map (substnl [cstr] k) b, substnl [cstr] k t) :: ctx')) @@ -374,9 +374,9 @@ let lift_telescope n k sign = (na,Option.map (liftn n k) c,liftn n k t)::(liftrec (succ k) sign) | [] -> [] in liftrec k sign - + type ('a,'b) either = Inl of 'a | Inr of 'b - + let strengthen (ctx : rel_context) (t : constr) : rel_context * rel_context * (int * (int, int) either) list = let rels = dependencies_of_term ctx t in let len = length ctx in @@ -390,7 +390,7 @@ let strengthen (ctx : rel_context) (t : constr) : rel_context * rel_context * (i else aux (succ k) n (subst_telescope 0 mkProp acc) (succ m) (decl :: rest) ((k, Inr m) :: s) ctx' | [] -> rev acc, rev rest, s in aux 1 1 [] 1 [] [] ctx - + let merge_subst (ctx', rest, s) = let lenrest = length rest in map (function (k, Inl x) -> (k, (false, mkRel (x + lenrest))) | (k, Inr x) -> k, (false, mkRel x)) s @@ -412,7 +412,7 @@ let substitute_in_ctx n c ctx = if k = n then rev after @ (name, Some c, t) :: before else aux (succ k) (decl :: after) before in aux 1 [] ctx - + let rec reduce_subst (ctx : rel_context) (substacc : (int * (bool * constr)) list) (cursubst : (int * (bool * constr)) list) = match cursubst with | [] -> ctx, substacc @@ -423,7 +423,7 @@ let rec reduce_subst (ctx : rel_context) (substacc : (int * (bool * constr)) lis let t' = lift (-k) t in let ctx' = substitute_in_ctx k t' ctx in reduce_subst ctx' substacc rest - else (* The term refers to variables declared after [k], so we have + else (* The term refers to variables declared after [k], so we have to move these dependencies before [k]. *) let (minctx, ctxrest, subst as str) = strengthen ctx t in match assoc k subst with @@ -439,8 +439,8 @@ let rec reduce_subst (ctx : rel_context) (substacc : (int * (bool * constr)) lis in map substsubst ((k, (b, t)) :: rest) in reduce_subst ctx' (compose_subst s substacc) rest' (* (compose_subst s ((k, (b, t)) :: rest)) *) - - + + let substituted_context (subst : (int * constr) list) (ctx : rel_context) = let _, subst = fold_left (fun (k, s) _ -> @@ -452,7 +452,7 @@ let substituted_context (subst : (int * constr) list) (ctx : rel_context) = in let ctx', subst' = reduce_subst ctx subst subst in reduce_rel_context ctx' subst' - + let unify_type before ty = try let envb = push_rel_context before (Global.env()) in @@ -460,11 +460,11 @@ let unify_type before ty = let ind, params = dest_ind_family indf in let vs = map (Reduction.whd_betadeltaiota envb) args in let cstrs = Inductiveops.arities_of_constructors envb ind in - let cstrs = + let cstrs = Array.mapi (fun i ty -> let ty = prod_applist ty params in let ctx, ty = decompose_prod_assum ty in - let ctx, ids = + let ctx, ids = let ids = ids_of_rel_context ctx in fold_right (fun (n, b, t as decl) (acc, ids) -> match n with Name _ -> (decl :: acc), ids @@ -480,8 +480,8 @@ let unify_type before ty = env', ctx, constr, constrpat, (* params @ *)args) cstrs in - let res = - Array.map (fun (env', ctxc, c, cpat, us) -> + let res = + Array.map (fun (env', ctxc, c, cpat, us) -> let _beforelen = length before and ctxclen = length ctxc in let fullctx = ctxc @ before in try @@ -490,7 +490,7 @@ let unify_type before ty = let subst = unify_constrs fullenv [] vs' us in let subst', ctx' = substituted_context subst fullctx in (ctx', ctxclen, c, cpat, Some subst') - with Conflict -> + with Conflict -> (fullctx, ctxclen, c, cpat, None)) cstrs in Some (res, indf) with Not_found -> (* not an inductive type *) @@ -502,35 +502,35 @@ let rec id_of_rel n l = | n, _ :: tl -> id_of_rel (pred n) tl | _, _ -> raise (Invalid_argument "id_of_rel") -let constrs_of_lhs ?(inacc=true) env (ctx, _, pats) = +let constrs_of_lhs ?(inacc=true) env (ctx, _, pats) = constrs_of_pats ~inacc (push_rel_context ctx env) pats - -let rec valid_splitting (f, delta, t, pats) tree = - split_solves tree (delta, f, pats) && + +let rec valid_splitting (f, delta, t, pats) tree = + split_solves tree (delta, f, pats) && valid_splitting_tree (f, delta, t) tree - + and valid_splitting_tree (f, delta, t) = function - | Compute (lhs, Program rhs) -> - let subst = constrs_of_lhs ~inacc:false (Global.env ()) lhs in + | Compute (lhs, Program rhs) -> + let subst = constrs_of_lhs ~inacc:false (Global.env ()) lhs in ignore(check_judgment (pi1 lhs) rhs (substl subst t)); true - | Compute ((ctx, id, lhs), Empty split) -> + | Compute ((ctx, id, lhs), Empty split) -> let before, (x, _, ty), after = split_context split ctx in - let unify = + let unify = match unify_type before ty with - | Some (unify, _) -> unify + | Some (unify, _) -> unify | None -> assert false in array_for_all (fun (_, _, _, _, x) -> x = None) unify - - | Split ((ctx, id, lhs), rel, indf, unifs, ls) -> + + | Split ((ctx, id, lhs), rel, indf, unifs, ls) -> let before, (id, _, ty), after = split_tele (pred rel) ctx in let unify, indf' = Option.get (unify_type before ty) in assert(indf = indf'); if not (array_exists (fun (_, _, _, _, x) -> x <> None) unify) then false else - let ok, splits = - Array.fold_left (fun (ok, splits as acc) (ctx', ctxlen, cstr, cstrpat, subst) -> + let ok, splits = + Array.fold_left (fun (ok, splits as acc) (ctx', ctxlen, cstr, cstrpat, subst) -> match subst with | None -> acc | Some subst -> @@ -540,23 +540,23 @@ and valid_splitting_tree (f, delta, t) = function (* ignore(check_context env' (subst_context subst before)); *) (* true *) (* in *) - let newdelta = - subst_context subst (subst_rel_context 0 cstr + let newdelta = + subst_context subst (subst_rel_context 0 cstr (lift_contextn ctxlen 0 after)) @ before in let liftpats = lift_pats ctxlen rel lhs in let newpats = specialize_patterns subst (subst_pats (Global.env ()) rel cstrpat liftpats) in (ok, (f, newdelta, newpats) :: splits)) (true, []) unify in - let subst = List.map2 (fun (id, _, _) x -> out_name id, x) delta - (constrs_of_pats ~inacc:false (Global.env ()) lhs) + let subst = List.map2 (fun (id, _, _) x -> out_name id, x) delta + (constrs_of_pats ~inacc:false (Global.env ()) lhs) in let t' = replace_vars subst t in - ok && for_all - (fun (f, delta', pats') -> + ok && for_all + (fun (f, delta', pats') -> array_exists (function None -> false | Some tree -> valid_splitting (f, delta', t', pats') tree) ls) splits - -let valid_tree (f, delta, t) tree = + +let valid_tree (f, delta, t) tree = valid_splitting (f, delta, t, patvars_of_tele delta) tree let is_constructor c = @@ -579,12 +579,12 @@ let find_split (_, _, curpats : lhs) (_, _, patcs : lhs) = and find_split_pats curpats patcs = assert(List.length curpats = List.length patcs); - fold_left2 (fun acc -> + fold_left2 (fun acc -> match acc with | None -> find_split_pat | _ -> fun _ _ -> acc) None curpats patcs in find_split_pats curpats patcs - + open Pp open Termops @@ -595,13 +595,13 @@ let pr_constr_pat env c = | _ -> pr let pr_pat env c = - try + try let patc = constr_of_pat env c in try pr_constr_pat env patc with _ -> str"pr_constr_pat raised an exception" with _ -> str"constr_of_pat raised an exception" - + let pr_context env c = - let pr_decl (id,b,_) = + let pr_decl (id,b,_) = let bstr = match b with Some b -> str ":=" ++ spc () ++ print_constr_env env b | None -> mt() in let idstr = match id with Name id -> pr_id id | Anonymous -> str"_" in idstr ++ bstr @@ -618,18 +618,18 @@ let pr_lhs env (delta, f, patcs) = let pr_rhs env = function | Empty var -> spc () ++ str ":=!" ++ spc () ++ print_constr_env env (mkRel var) | Program rhs -> spc () ++ str ":=" ++ spc () ++ print_constr_env env rhs - + let pr_clause env (lhs, rhs) = - pr_lhs env lhs ++ + pr_lhs env lhs ++ (let env' = push_rel_context (pi1 lhs) env in pr_rhs env' rhs) - + (* let pr_splitting env = function *) (* | Compute cl -> str "Compute " ++ pr_clause env cl *) (* | Split (lhs, n, indf, results, splits) -> *) (* let pr_unification_result (ctx, n, c, pat, subst) = *) - + (* unification_result array * splitting option array *) let pr_clauses env = @@ -637,36 +637,36 @@ let pr_clauses env = let lhs_includes (delta, _, patcs : lhs) (delta', _, patcs' : lhs) = pattern_includes patcs patcs' - + let lhs_matches (delta, _, patcs : lhs) (delta', _, patcs' : lhs) = pattern_matches patcs patcs' let rec split_on env var (delta, f, curpats as lhs) clauses = let before, (id, _, ty), after = split_tele (pred var) delta in - let unify, indf = - match unify_type before ty with + let unify, indf = + match unify_type before ty with | Some r -> r | None -> assert false (* We decided... so it better be inductive *) in let clauses = ref clauses in - let splits = + let splits = Array.map (fun (ctx', ctxlen, cstr, cstrpat, s) -> match s with | None -> None - | Some s -> + | Some s -> (* ctx' |- s cstr, s cstrpat *) let newdelta = - subst_context s (subst_rel_context 0 cstr + subst_context s (subst_rel_context 0 cstr (lift_contextn ctxlen 1 after)) @ ctx' in - let liftpats = + let liftpats = (* delta |- curpats -> before; ctxc; id; after |- liftpats *) - lift_pats ctxlen (succ var) curpats + lift_pats ctxlen (succ var) curpats in let liftpat = (* before; ctxc |- cstrpat -> before; ctxc; after |- liftpat *) lift_pat (pred var) 1 cstrpat in let substpat = (* before; ctxc; after |- liftpats[id:=liftpat] *) - subst_pats env var liftpat liftpats + subst_pats env var liftpat liftpats in let lifts = (* before; ctxc |- s : newdelta -> before; ctxc; after |- lifts : newdelta ; after *) @@ -674,8 +674,8 @@ let rec split_on env var (delta, f, curpats as lhs) clauses = in let newpats = specialize_patterns lifts substpat in let newlhs = (newdelta, f, newpats) in - let matching, rest = - fold_right (fun (lhs, rhs as clause) (matching, rest) -> + let matching, rest = + fold_right (fun (lhs, rhs as clause) (matching, rest) -> if lhs_includes newlhs lhs then (clause :: matching, rest) else (matching, clause :: rest)) @@ -684,11 +684,11 @@ let rec split_on env var (delta, f, curpats as lhs) clauses = clauses := rest; if matching = [] then ( (* Try finding a splittable variable *) - let (id, _) = - fold_right (fun (id, _, ty as decl) (accid, ctx) -> - match accid with + let (id, _) = + fold_right (fun (id, _, ty as decl) (accid, ctx) -> + match accid with | Some _ -> (accid, ctx) - | None -> + | None -> match unify_type ctx ty with | Some (unify, indf) -> if array_for_all (fun (_, _, _, _, x) -> x = None) unify then @@ -696,13 +696,13 @@ let rec split_on env var (delta, f, curpats as lhs) clauses = else (None, decl :: ctx) | None -> (None, decl :: ctx)) newdelta (None, []) - in + in match id with | None -> errorlabstrm "deppat" (str "Non-exhaustive pattern-matching, no clause found for:" ++ fnl () ++ pr_lhs env newlhs) - | Some id -> + | Some id -> Some (Compute (newlhs, Empty (fst (lookup_rel_id (out_name id) newdelta)))) ) else ( let splitting = make_split_aux env newlhs matching in @@ -713,14 +713,14 @@ let rec split_on env var (delta, f, curpats as lhs) clauses = (* errorlabstrm "deppat" *) (* (str "Impossible clauses:" ++ fnl () ++ pr_clauses env !clauses); *) Split (lhs, var, indf, unify, splits) - + and make_split_aux env lhs clauses = - let split = - fold_left (fun acc (lhs', rhs) -> - match acc with + let split = + fold_left (fun acc (lhs', rhs) -> + match acc with | None -> find_split lhs lhs' | _ -> acc) None clauses - in + in match split with | Some var -> split_on env var lhs clauses | None -> @@ -742,7 +742,7 @@ and make_split_aux env lhs clauses = let make_split env (f, delta, t) clauses = make_split_aux env (delta, f, patvars_of_tele delta) clauses - + open Evd open Evarutil @@ -755,18 +755,18 @@ let term_of_tree status isevar env (i, delta, ty) ann tree = (* | Some (loc, i) -> *) (* let (n, t) = lookup_rel_id i delta in *) (* let t' = lift n t in *) - - + + (* in *) let rec aux = function - | Compute ((ctx, _, pats as lhs), Program rhs) -> + | Compute ((ctx, _, pats as lhs), Program rhs) -> let ty' = substl (rev (constrs_of_lhs ~inacc:false env lhs)) ty in let body = it_mkLambda_or_LetIn rhs ctx and typ = it_mkProd_or_LetIn ty' ctx in mkCast(body, DEFAULTcast, typ), typ | Compute ((ctx, _, pats as lhs), Empty split) -> let ty' = substl (rev (constrs_of_lhs ~inacc:false env lhs)) ty in - let split = (Name (id_of_string "split"), + let split = (Name (id_of_string "split"), Some (Class_tactics.coq_nat_of_int (1 + (length ctx - split))), Lazy.force Class_tactics.coq_nat) in @@ -774,25 +774,25 @@ let term_of_tree status isevar env (i, delta, ty) ann tree = let let_ty' = mkLambda_or_LetIn split (lift 1 ty') in let term = e_new_evar isevar env ~src:(dummy_loc, QuestionMark (Define true)) let_ty' in term, ty' - - | Split ((ctx, _, pats as lhs), rel, indf, unif, sp) -> + + | Split ((ctx, _, pats as lhs), rel, indf, unif, sp) -> let before, decl, after = split_tele (pred rel) ctx in let ty' = substl (rev (constrs_of_lhs ~inacc:false env lhs)) ty in - let branches = - array_map2 (fun (ctx', ctxlen, cstr, cstrpat, subst) split -> + let branches = + array_map2 (fun (ctx', ctxlen, cstr, cstrpat, subst) split -> match split with | Some s -> aux s - | None -> + | None -> (* dead code, inversion will find a proof of False by splitting on the rel'th hyp *) Class_tactics.coq_nat_of_int rel, Lazy.force Class_tactics.coq_nat) - unif sp + unif sp in let branches_ctx = Array.mapi (fun i (br, brt) -> (id_of_string ("m_" ^ string_of_int i), Some br, brt)) branches in - let n, branches_lets = - Array.fold_left (fun (n, lets) (id, b, t) -> + let n, branches_lets = + Array.fold_left (fun (n, lets) (id, b, t) -> (succ n, (Name id, Option.map (lift n) b, lift n t) :: lets)) (0, []) branches_ctx in @@ -800,18 +800,18 @@ let term_of_tree status isevar env (i, delta, ty) ann tree = let case = let ty = it_mkProd_or_LetIn ty' liftctx in let ty = it_mkLambda_or_LetIn ty branches_lets in - let nbbranches = (Name (id_of_string "branches"), + let nbbranches = (Name (id_of_string "branches"), Some (Class_tactics.coq_nat_of_int (length branches_lets)), Lazy.force Class_tactics.coq_nat) in - let nbdiscr = (Name (id_of_string "target"), + let nbdiscr = (Name (id_of_string "target"), Some (Class_tactics.coq_nat_of_int (length before)), Lazy.force Class_tactics.coq_nat) in let ty = it_mkLambda_or_LetIn (lift 2 ty) [nbbranches;nbdiscr] in let term = e_new_evar isevar env ~src:(dummy_loc, QuestionMark status) ty in term - in + in let casetyp = it_mkProd_or_LetIn ty' ctx in mkCast(case, DEFAULTcast, casetyp), casetyp @@ -829,9 +829,9 @@ let locate_reference qid = | SynDef kn -> true let is_global id = - try + try locate_reference (qualid_of_ident id) - with Not_found -> + with Not_found -> false let is_freevar ids env x = @@ -841,12 +841,12 @@ let is_freevar ids env x = try ignore(Environ.lookup_named x env) ; false with _ -> not (is_global x) with _ -> true - -let ids_of_patc c ?(bound=Idset.empty) l = + +let ids_of_patc c ?(bound=Idset.empty) l = let found id bdvars l = if not (is_freevar bdvars (Global.env ()) (snd id)) then l - else if List.exists (fun (_, id') -> id' = snd id) l then l - else id :: l + else if List.exists (fun (_, id') -> id' = snd id) l then l + else id :: l in let rec aux bdvars l c = match c with | CRef (Ident lid) -> found lid bdvars l @@ -858,11 +858,11 @@ let ids_of_patc c ?(bound=Idset.empty) l = let interp_pats i isevar env impls pat sign recu = let bound = Idset.singleton i in let vars = ids_of_patc pat ~bound [] in - let varsctx, env' = + let varsctx, env' = fold_right (fun (loc, id) (ctx, env) -> let decl = let ty = e_new_evar isevar env ~src:(loc, BinderType (Name id)) (new_Type ()) in - (Name id, None, ty) + (Name id, None, ty) in decl::ctx, push_rel decl env) vars ([], env) @@ -871,7 +871,7 @@ let interp_pats i isevar env impls pat sign recu = let patenv = match recu with None -> env' | Some ty -> push_named (i, None, ty) env' in let patt, _ = interp_constr_evars_impls ~evdref:isevar patenv ~impls:([],[]) pat in match kind_of_term patt with - | App (m, args) -> + | App (m, args) -> if not (eq_constr m (mkRel (succ (length varsctx)))) then user_err_loc (constr_loc pat, "interp_pats", str "Expecting a pattern for " ++ pr_id i) @@ -880,18 +880,18 @@ let interp_pats i isevar env impls pat sign recu = str "Error parsing pattern: unnexpected left-hand side") in isevar := nf_evar_defs !isevar; - (nf_rel_context_evar ( !isevar) varsctx, + (nf_rel_context_evar ( !isevar) varsctx, nf_env_evar ( !isevar) env', rev_map (nf_evar ( !isevar)) pats) - + let interp_eqn i isevar env impls sign arity recu (pats, rhs) = let ctx, env', patcs = interp_pats i isevar env impls pats sign recu in let rhs' = match rhs with - | Program p -> + | Program p -> let ty = nf_isevar !isevar (substl patcs arity) in Program (interp_casted_constr_evars isevar env' ~impls p ty) | Empty lid -> Empty (fst (lookup_rel_id (snd lid) ctx)) - in ((ctx, i, pats_of_constrs (rev patcs)), rhs') + in ((ctx, i, pats_of_constrs (rev patcs)), rhs') open Entries @@ -905,10 +905,10 @@ let contrib_tactics_path = let tactics_tac s = make_kn (MPfile contrib_tactics_path) (make_dirpath []) (mk_label s) - -let equations_tac = lazy - (Tacinterp.eval_tactic - (TacArg(TacCall(dummy_loc, + +let equations_tac = lazy + (Tacinterp.eval_tactic + (TacArg(TacCall(dummy_loc, ArgArg(dummy_loc, tactics_tac "equations"), [])))) let define_by_eqs with_comp i (l,ann) t nt eqs = @@ -918,14 +918,14 @@ let define_by_eqs with_comp i (l,ann) t nt eqs = let arity = interp_type_evars isevar env' t in let sign = nf_rel_context_evar ( !isevar) sign in let arity = nf_evar ( !isevar) arity in - let arity = + let arity = if with_comp then let compid = add_suffix i "_comp" in let ce = { const_entry_body = it_mkLambda_or_LetIn arity sign; const_entry_type = None; const_entry_opaque = false; - const_entry_boxed = false} + const_entry_boxed = false} in let c = Declare.declare_constant compid (DefinitionEntry ce, IsDefinition Definition) @@ -937,8 +937,8 @@ let define_by_eqs with_comp i (l,ann) t nt eqs = let data = Command.compute_interning_datas env Constrintern.Recursive [] [i] [ty] [impls] in let fixdecls = [(Name i, None, ty)] in let fixenv = push_rel_context fixdecls env in - let equations = - States.with_heavy_rollback (fun () -> + let equations = + States.with_heavy_rollback (fun () -> Option.iter (Command.declare_interning_data data) nt; map (interp_eqn i isevar fixenv data sign arity None) eqs) () in @@ -961,21 +961,21 @@ let define_by_eqs with_comp i (l,ann) t nt eqs = let status = (* if is_recursive then Expand else *) Define false in let t, ty = term_of_tree status isevar env' prob ann split in let undef = undefined_evars !isevar in - let t, ty = if is_recursive then + let t, ty = if is_recursive then (it_mkLambda_or_LetIn t fixdecls, it_mkProd_or_LetIn ty fixdecls) else t, ty in - let obls, t', ty' = + let obls, t', ty' = Eterm.eterm_obligations env i !isevar ( undef) 0 ~status t ty in if is_recursive then - ignore(Subtac_obligations.add_mutual_definitions [(i, t', ty', impls, obls)] [] + ignore(Subtac_obligations.add_mutual_definitions [(i, t', ty', impls, obls)] [] ~tactic:(Lazy.force equations_tac) (Command.IsFixpoint [None, CStructRec])) else ignore(Subtac_obligations.add_definition ~implicits:impls i t' ty' ~tactic:(Lazy.force equations_tac) obls) - + module Gram = Pcoq.Gram module Vernac = Pcoq.Vernac_ module Tactic = Pcoq.Tactic @@ -993,7 +993,7 @@ struct end open Rawterm -open DeppatGram +open DeppatGram open Util open Pcoq open Prim @@ -1002,7 +1002,7 @@ open G_vernac GEXTEND Gram GLOBAL: (* deppat_gallina_loc *) deppat_equations binders_let2; - + deppat_equations: [ [ l = LIST1 equation SEP ";" -> l ] ] ; @@ -1020,7 +1020,7 @@ GEXTEND Gram |":="; c = Constr.lconstr -> Program c ] ] ; - + END type 'a deppat_equations_argtype = (equation list, 'a) Genarg.abstract_argument_type @@ -1059,8 +1059,8 @@ VERNAC COMMAND EXTEND Define_equations2 decl_notation(nt) ] -> [ equations false i l t nt eqs ] END - -let rec int_of_coq_nat c = + +let rec int_of_coq_nat c = match kind_of_term c with | App (f, [| arg |]) -> succ (int_of_coq_nat arg) | _ -> 0 @@ -1076,24 +1076,24 @@ let solve_equations_goal destruct_tac tac gl = | _ -> error "Unnexpected goal") | _ -> error "Unnexpected goal" in - let branches, b = + let branches, b = let rec aux n c = if n = 0 then [], c else match kind_of_term c with - | LetIn (Name id, br, brt, b) -> + | LetIn (Name id, br, brt, b) -> let rest, b = aux (pred n) b in (id, br, brt) :: rest, b | _ -> error "Unnexpected goal" in aux brs b - in + in let ids = targetn :: branchesn :: map pi1 branches in let cleantac = tclTHEN (intros_using ids) (thin ids) in let dotac = tclDO (succ targ) intro in - let subtacs = + let subtacs = tclTHENS destruct_tac (map (fun (id, br, brt) -> tclTHEN (letin_tac None (Name id) br (Some brt) onConcl) tac) branches) in tclTHENLIST [cleantac ; dotac ; subtacs] gl - + TACTIC EXTEND solve_equations [ "solve_equations" tactic(destruct) tactic(tac) ] -> [ solve_equations_goal (snd destruct) (snd tac) ] END @@ -1110,7 +1110,7 @@ let specialize_hyp id gl = let evars = ref (create_evar_defs (project gl)) in let rec aux in_eqs acc ty = match kind_of_term ty with - | Prod (_, t, b) -> + | Prod (_, t, b) -> (match kind_of_term t with | App (eq, [| eqty; x; y |]) when eq_constr eq (Lazy.force coq_eq) -> let pt = mkApp (Lazy.force coq_eq, [| eqty; x; x |]) in @@ -1124,14 +1124,14 @@ let specialize_hyp id gl = if e_conv env evars pt t then aux true (mkApp (acc, [| p |])) (subst1 p b) else error "Unconvertible members of an heterogeneous equality" - | _ -> + | _ -> if in_eqs then acc, in_eqs, ty - else + else let e = e_new_evar evars env t in aux false (mkApp (acc, [| e |])) (subst1 e b)) | t -> acc, in_eqs, ty - in - try + in + try let acc, worked, ty = aux false (mkVar id) ty in let ty = Evarutil.nf_isevar !evars ty in if worked then @@ -1140,9 +1140,9 @@ let specialize_hyp id gl = (exact_no_check (Evarutil.nf_isevar !evars acc)) gl else tclFAIL 0 (str "Nothing to do in hypothesis " ++ pr_id id) gl with e -> tclFAIL 0 (Cerrors.explain_exn e) gl - + TACTIC EXTEND specialize_hyp -[ "specialize_hypothesis" constr(c) ] -> [ +[ "specialize_hypothesis" constr(c) ] -> [ match kind_of_term c with | Var id -> specialize_hyp id | _ -> tclFAIL 0 (str "Not an hypothesis") ] diff --git a/plugins/subtac/eterm.ml b/plugins/subtac/eterm.ml index d65b520b65..3c947e29cf 100644 --- a/plugins/subtac/eterm.ml +++ b/plugins/subtac/eterm.ml @@ -16,11 +16,11 @@ open Util open Subtac_utils open Proof_type -let trace s = +let trace s = if !Flags.debug then (msgnl s; msgerr s) else () -let succfix (depth, fixrels) = +let succfix (depth, fixrels) = (succ depth, List.map succ fixrels) type oblinfo = @@ -32,41 +32,41 @@ type oblinfo = ev_typ: types; ev_tac: Tacexpr.raw_tactic_expr option; ev_deps: Intset.t } - -(** Substitute evar references in t using De Bruijn indices, + +(** Substitute evar references in t using De Bruijn indices, where n binders were passed through. *) -let subst_evar_constr evs n t = +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, fixrels) c = match kind_of_term c with | Evar (k, args) -> - let { ev_name = (id, idstr) ; + let { ev_name = (id, idstr) ; ev_hyps = hyps ; ev_chop = chop } = try evar_info k - with Not_found -> + with Not_found -> anomaly ("eterm: existential variable " ^ string_of_int k ^ " not found") in seen := Intset.add id !seen; - (* Evar arguments are created in inverse order, + (* Evar arguments are created in inverse order, and we must not apply to defined ones (i.e. LetIn's) *) - let args = - let n = match chop with None -> 0 | Some c -> c in + let args = + let n = match chop with None -> 0 | Some c -> c in let (l, r) = list_chop n (List.rev (Array.to_list args)) in List.rev r in let args = let rec aux hyps args acc = match hyps, args with - ((_, None, _) :: tlh), (c :: tla) -> + ((_, None, _) :: tlh), (c :: tla) -> aux tlh tla ((substrec (depth, fixrels) c) :: acc) | ((_, Some _, _) :: tlh), (_ :: tla) -> aux tlh tla acc | [], [] -> acc | _, _ -> acc (*failwith "subst_evars: invalid argument"*) - in aux hyps args [] + in aux hyps args [] in 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; @@ -74,25 +74,25 @@ let subst_evar_constr evs n t = | Fix _ -> map_constr_with_binders succfix substrec (depth, 1 :: fixrels) c | _ -> map_constr_with_binders succfix substrec (depth, fixrels) c - in + in let t' = substrec (0, []) t in t', !seen, !transparent - -(** Substitute variable references in t using De Bruijn indices, + +(** Substitute variable references in t using De Bruijn indices, where n binders were passed through. *) -let subst_vars acc n t = +let subst_vars acc n t = let var_index id = Util.list_index id acc in let rec substrec depth c = match kind_of_term c with | Var v -> (try mkRel (depth + (var_index v)) with Not_found -> c) | _ -> map_constr_with_binders succ substrec depth c - in + in substrec 0 t (** Rewrite type of an evar ([ H1 : t1, ... Hn : tn |- concl ]) to a product : forall H1 : t1, ..., forall Hn : tn, concl. Changes evars and hypothesis references to variable references. -*) +*) let etype_of_evar evs hyps concl = let rec aux acc n = function (id, copt, t) :: tl -> @@ -102,13 +102,13 @@ let etype_of_evar evs hyps concl = let s' = Intset.union s s' in let trans' = Idset.union trans trans' in (match copt with - Some c -> + Some c -> 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 -> + | None -> mkNamedProd_or_LetIn (id, None, t'') rest, s', trans') | [] -> let t', s, trans = subst_evar_constr evs n concl in @@ -117,25 +117,25 @@ let etype_of_evar evs hyps concl = open Tacticals - -let trunc_named_context n ctx = + +let trunc_named_context n ctx = let len = List.length ctx in list_firstn (len - n) ctx - -let rec chop_product n t = + +let rec chop_product n t = if n = 0 then Some t - else + else match kind_of_term t with | Prod (_, _, b) -> if noccurn 1 b then chop_product (pred n) (Termops.pop b) else None | _ -> None let evar_dependencies evm ev = - let one_step deps = - Intset.fold (fun ev s -> + let one_step deps = + Intset.fold (fun ev s -> let evi = Evd.find evm ev in Intset.union (Evarutil.evars_of_evar_info evi) s) deps deps - in + in let rec aux deps = let deps' = one_step deps in if Intset.equal deps deps' then deps @@ -143,13 +143,13 @@ let evar_dependencies evm ev = in aux (Intset.singleton ev) let sort_dependencies evl = - List.sort (fun (_, _, deps) (_, _, deps') -> + List.sort (fun (_, _, deps) (_, _, deps') -> if Intset.subset deps deps' then (* deps' depends on deps *) -1 else if Intset.subset deps' deps then 1 else Intset.compare deps deps') evl - -let eterm_obligations env name isevars evm fs ?status t ty = + +let eterm_obligations env name isevars evm fs ?status t ty = (* 'Serialize' the evars *) let nc = Environ.named_context env in let nc_len = Sign.named_context_length nc in @@ -157,37 +157,37 @@ let eterm_obligations env name isevars evm fs ?status t ty = let evl = List.map (fun (id, ev) -> (id, ev, evar_dependencies evm id)) evl in let sevl = sort_dependencies evl in let evl = List.map (fun (id, ev, _) -> id, ev) sevl in - let evn = + let evn = let i = ref (-1) in - List.rev_map (fun (id, ev) -> incr i; + List.rev_map (fun (id, ev) -> incr i; (id, (!i, id_of_string (string_of_id name ^ "_obligation_" ^ string_of_int (succ !i))), ev)) evl in - let evts = + let evts = (* Remove existential variables in types and build the corresponding products *) - fold_right + fold_right (fun (id, (n, nstr), ev) l -> 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 = + let evtyp, hyps, chop = match chop_product fs evtyp with | Some t -> t, trunc_named_context fs hyps, fs | None -> evtyp, hyps, 0 in let loc, k = evar_source id isevars in let status = match k with QuestionMark o -> Some o | _ -> status in - let status, chop = match status with + let status, chop = match status with | Some (Define true as stat) -> - if chop <> fs then Define false, None + if chop <> fs then Define false, None else stat, Some chop | Some s -> s, None | None -> Define true, None in - let tac = match ev.evar_extra with - | Some t -> - if Dyn.tag t = "tactic" then + let tac = match ev.evar_extra with + | Some t -> + if Dyn.tag t = "tactic" then Some (Tacinterp.globTacticIn (Tacinterp.tactic_out t)) else None | None -> None @@ -195,14 +195,14 @@ let eterm_obligations env name isevars evm fs ?status t ty = let info = { ev_name = (n, nstr); ev_hyps = hyps; ev_status = status; ev_chop = chop; ev_loc = loc; ev_typ = evtyp ; ev_deps = deps; ev_tac = tac } - in (id, info) :: l) + in (id, info) :: l) evn [] - in + in let t', _, transparent = (* Substitute evar refs in the term by variables *) - subst_evar_constr evts 0 t + subst_evar_constr evts 0 t in let ty, _, _ = subst_evar_constr evts 0 ty in - let evars = + let evars = List.map (fun (_, info) -> let { ev_name = (_, name); ev_status = status; ev_loc = loc; ev_typ = typ; ev_deps = deps; ev_tac = tac } = info diff --git a/plugins/subtac/eterm.mli b/plugins/subtac/eterm.mli index 413823ffe9..1d1c512662 100644 --- a/plugins/subtac/eterm.mli +++ b/plugins/subtac/eterm.mli @@ -19,12 +19,12 @@ val mkMetas : int -> constr list val evar_dependencies : evar_map -> int -> Intset.t val sort_dependencies : (int * evar_info * Intset.t) list -> (int * evar_info * Intset.t) list - + (* 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 -> - ?status:obligation_definition_status -> constr -> types -> - (identifier * types * loc * obligation_definition_status * Intset.t * +val eterm_obligations : env -> identifier -> evar_defs -> evar_map -> int -> + ?status:obligation_definition_status -> constr -> types -> + (identifier * types * loc * obligation_definition_status * Intset.t * Tacexpr.raw_tactic_expr option) array * constr * types (* Obl. name, type as product, location of the original evar, associated tactic, status and dependencies as indexes into the array *) diff --git a/plugins/subtac/g_eterm.ml4 b/plugins/subtac/g_eterm.ml4 index 095e5fafc9..53ce5b8d64 100644 --- a/plugins/subtac/g_eterm.ml4 +++ b/plugins/subtac/g_eterm.ml4 @@ -20,7 +20,7 @@ open Eterm TACTIC EXTEND eterm - [ "eterm" ] -> [ + [ "eterm" ] -> [ (fun gl -> let evm = Tacmach.project gl and t = Tacmach.pf_concl gl in Eterm.etermtac (evm, t) gl) ] diff --git a/plugins/subtac/g_subtac.ml4 b/plugins/subtac/g_subtac.ml4 index a1cbeb710a..098418a7e3 100644 --- a/plugins/subtac/g_subtac.ml4 +++ b/plugins/subtac/g_subtac.ml4 @@ -7,7 +7,7 @@ (************************************************************************) (*i camlp4deps: "parsing/grammar.cma" i*) -(*i camlp4use: "pa_extend.cmo" i*) +(*i camlp4use: "pa_extend.cmo" i*) (* @@ -45,7 +45,7 @@ struct end open Rawterm -open SubtacGram +open SubtacGram open Util open Pcoq open Prim @@ -54,14 +54,14 @@ let sigref = mkRefC (Qualid (dummy_loc, Libnames.qualid_of_string "Coq.Init.Spec GEXTEND Gram GLOBAL: subtac_gallina_loc typeclass_constraint Constr.binder subtac_nameopt; - + subtac_gallina_loc: [ [ g = Vernac.gallina -> loc, g | g = Vernac.gallina_ext -> loc, g ] ] ; subtac_nameopt: - [ [ "ofb"; id=Prim.ident -> Some (id) + [ [ "ofb"; id=Prim.ident -> Some (id) | -> None ] ] ; @@ -115,42 +115,42 @@ let admit_obligations e = try_catch_exn Subtac_obligations.admit_obligations e VERNAC COMMAND EXTEND Subtac_Obligations | [ "Obligation" integer(num) "of" ident(name) ":" lconstr(t) ] -> [ subtac_obligation (num, Some name, Some t) ] | [ "Obligation" integer(num) "of" ident(name) ] -> [ subtac_obligation (num, Some name, None) ] -| [ "Obligation" integer(num) ":" lconstr(t) ] -> [ subtac_obligation (num, None, Some t) ] +| [ "Obligation" integer(num) ":" lconstr(t) ] -> [ subtac_obligation (num, None, Some t) ] | [ "Obligation" integer(num) ] -> [ subtac_obligation (num, None, None) ] | [ "Next" "Obligation" "of" ident(name) ] -> [ next_obligation (Some name) ] | [ "Next" "Obligation" ] -> [ next_obligation None ] END VERNAC COMMAND EXTEND Subtac_Solve_Obligation -| [ "Solve" "Obligation" integer(num) "of" ident(name) "using" tactic(t) ] -> +| [ "Solve" "Obligation" integer(num) "of" ident(name) "using" tactic(t) ] -> [ try_solve_obligation num (Some name) (Some (Tacinterp.interp t)) ] -| [ "Solve" "Obligation" integer(num) "using" tactic(t) ] -> +| [ "Solve" "Obligation" integer(num) "using" tactic(t) ] -> [ try_solve_obligation num None (Some (Tacinterp.interp t)) ] END VERNAC COMMAND EXTEND Subtac_Solve_Obligations -| [ "Solve" "Obligations" "of" ident(name) "using" tactic(t) ] -> +| [ "Solve" "Obligations" "of" ident(name) "using" tactic(t) ] -> [ try_solve_obligations (Some name) (Some (Tacinterp.interp t)) ] -| [ "Solve" "Obligations" "using" tactic(t) ] -> +| [ "Solve" "Obligations" "using" tactic(t) ] -> [ try_solve_obligations None (Some (Tacinterp.interp t)) ] -| [ "Solve" "Obligations" ] -> +| [ "Solve" "Obligations" ] -> [ try_solve_obligations None None ] END VERNAC COMMAND EXTEND Subtac_Solve_All_Obligations -| [ "Solve" "All" "Obligations" "using" tactic(t) ] -> +| [ "Solve" "All" "Obligations" "using" tactic(t) ] -> [ solve_all_obligations (Some (Tacinterp.interp t)) ] -| [ "Solve" "All" "Obligations" ] -> +| [ "Solve" "All" "Obligations" ] -> [ solve_all_obligations None ] END VERNAC COMMAND EXTEND Subtac_Admit_Obligations -| [ "Admit" "Obligations" "of" ident(name) ] -> [ admit_obligations (Some name) ] -| [ "Admit" "Obligations" ] -> [ admit_obligations None ] +| [ "Admit" "Obligations" "of" ident(name) ] -> [ admit_obligations (Some name) ] +| [ "Admit" "Obligations" ] -> [ admit_obligations None ] END VERNAC COMMAND EXTEND Subtac_Set_Solver -| [ "Obligation" "Tactic" ":=" tactic(t) ] -> [ +| [ "Obligation" "Tactic" ":=" tactic(t) ] -> [ Subtac_obligations.set_default_tactic (Tacinterp.glob_tactic t) ] END diff --git a/plugins/subtac/subtac.ml b/plugins/subtac/subtac.ml index b5e2880134..56134d7086 100644 --- a/plugins/subtac/subtac.ml +++ b/plugins/subtac/subtac.ml @@ -23,7 +23,7 @@ open Typeops open Libnames open Classops open List -open Recordops +open Recordops open Evarutil open Pretype_errors open Rawterm @@ -50,14 +50,14 @@ open Tacinterp open Tacexpr let solve_tccs_in_type env id isevars evm c typ = - if not (evm = Evd.empty) then + 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 ~status:Expand c typ in match Subtac_obligations.add_definition stmt_id c' typ obls with - | Subtac_obligations.Defined cst -> constant_value (Global.env()) + | Subtac_obligations.Defined cst -> constant_value (Global.env()) (match cst with ConstRef kn -> kn | _ -> assert false) - | _ -> - errorlabstrm "start_proof" + | _ -> + errorlabstrm "start_proof" (str "The statement obligations could not be resolved automatically, " ++ spc () ++ str "write a statement definition first.") else @@ -75,30 +75,30 @@ let start_proof_com env isevars sopt kind (bl,t) hook = next_global_ident_away false (id_of_string "Unnamed_thm") (Pfedit.get_all_proof_names ()) in - let evm, c, typ, imps = - Subtac_pretyping.subtac_process env isevars id [] (Command.generalize_constr_expr t bl) None + let evm, c, typ, imps = + Subtac_pretyping.subtac_process env isevars id [] (Command.generalize_constr_expr t bl) None in let c = solve_tccs_in_type env id isevars evm c typ in - Command.start_proof id kind c (fun loc gr -> + Command.start_proof id kind c (fun loc gr -> Impargs.declare_manual_implicits (loc = Local) gr ~enriching:true imps; hook loc gr) - + 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; print_subgoals () - + let _ = Detyping.set_detype_anonymous (fun loc n -> RVar (loc, id_of_string ("Anonymous_REL_" ^ string_of_int n))) - + let assumption_message id = Flags.if_verbose message ((string_of_id id) ^ " is assumed") 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 + let evm, c, typ, imps = + Subtac_pretyping.subtac_process env isevars id [] (Command.generalize_constr_expr c bl) None in 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 nl) idl @@ -115,9 +115,9 @@ 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)) -> + List.iter (fun (is_coe,(idl,c)) -> if Dumpglob.dump () then - List.iter (fun lid -> + List.iter (fun lid -> if global then Dumpglob.dump_definition lid (not global) "ax" else dump_variable lid) idl; declare_assumption env isevars idl is_coe kind [] c nl) l @@ -125,7 +125,7 @@ let vernac_assumption env isevars kind l nl = 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"]; @@ -133,25 +133,25 @@ let subtac (loc, command) = let isevars = ref (create_evar_defs Evd.empty) in try match command with - | VernacDefinition (defkind, (_, id as lid), expr, hook) -> + | VernacDefinition (defkind, (_, id as lid), expr, hook) -> check_fresh lid; Dumpglob.dump_definition lid false "def"; (match expr with - | ProveBody (bl, t) -> + | 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 lid) (Global, DefinitionBody Definition) (bl,t) + start_proof_and_print env isevars (Some lid) (Global, DefinitionBody Definition) (bl,t) (fun _ _ -> ()) - | DefineBody (bl, _, c, tycon) -> + | DefineBody (bl, _, c, tycon) -> ignore(Subtac_pretyping.subtac_proof defkind hook env isevars id bl c tycon)) - | VernacFixpoint (l, b) -> - List.iter (fun ((lid, _, _, _, _), _) -> + | VernacFixpoint (l, b) -> + List.iter (fun ((lid, _, _, _, _), _) -> check_fresh lid; Dumpglob.dump_definition lid false "fix") l; let _ = trace (str "Building fixpoint") in ignore(Subtac_command.build_recursive l b) - + | VernacStartTheoremProof (thkind, [Some id, (bl, t)], lettop, hook) -> Dumpglob.dump_definition id false "prf"; if not(Pfedit.refining ()) then @@ -163,30 +163,30 @@ let subtac (loc, command) = (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) -> + + | VernacAssumption (stre,nl,l) -> vernac_assumption env isevars stre l nl - + | VernacInstance (glob, sup, is, props, pri) -> dump_constraint "inst" is; ignore(Subtac_classes.new_instance ~global:glob sup is props pri) - + | VernacCoFixpoint (l, b) -> - if Dumpglob.dump () then + if Dumpglob.dump () then List.iter (fun ((lid, _, _, _), _) -> Dumpglob.dump_definition lid false "cofix") l; ignore(Subtac_command.build_corecursive l b) - - (*| VernacEndProof e -> + + (*| VernacEndProof e -> subtac_end_proof e*) | _ -> user_err_loc (loc,"", str ("Invalid Program command")) - with + with | Typing_error e -> msg_warning (str "Type error in Program tactic:"); - let cmds = + let cmds = (match e with | NonFunctionalApp (loc, x, mux, e) -> - str "non functional application of term " ++ + 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 @@ -197,10 +197,10 @@ let subtac (loc, command) = str "Term is ill-sorted:" ++ spc () ++ t ) in msg_warning cmds - + | Subtyping_error e -> msg_warning (str "(Program tactic) Subtyping error:"); - let cmds = + let cmds = match e with | UncoercibleInferType (loc, x, y) -> str "Uncoercible terms:" ++ spc () @@ -217,15 +217,15 @@ let subtac (loc, command) = | 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, Proof_type.LtacLocated (_,e')) | Stdpp.Exc_located (loc, e') as e) -> debug 2 (str "Parsing exception: "); @@ -233,14 +233,14 @@ let subtac (loc, command) = | 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 -> + + | e -> msg_warning (str "Uncatched exception: " ++ Cerrors.explain_exn e); raise e diff --git a/plugins/subtac/subtac_cases.ml b/plugins/subtac/subtac_cases.ml index 5f2cb601be..d54bbee4e3 100644 --- a/plugins/subtac/subtac_cases.ml +++ b/plugins/subtac/subtac_cases.ml @@ -45,7 +45,7 @@ let mssg_may_need_inversion () = (* Utils *) let make_anonymous_patvars = - list_tabulate (fun _ -> PatVar (dummy_loc,Anonymous)) + list_tabulate (fun _ -> PatVar (dummy_loc,Anonymous)) (* Environment management *) let push_rels vars env = List.fold_right push_rel vars env @@ -72,7 +72,7 @@ let mkSpecialLetInJudge j (na,(deppat,nondeppat,d,t)) = | NonDepAlias -> if (not (dependent (mkRel 1) j.uj_type)) or (* A leaf: *) isRel deppat - then + then (* The body of pat is not needed to type j - see *) (* insert_aliases - and both deppat and nondeppat have the *) (* same type, then one can freely substitute one by the other *) @@ -94,7 +94,7 @@ type rhs = } type equation = - { patterns : cases_pattern list; + { patterns : cases_pattern list; rhs : rhs; alias_stack : name list; eqn_loc : loc; @@ -154,7 +154,7 @@ let feed_history arg = function Continuation (n-1, arg :: l, h) | Continuation (n, _, _) -> anomaly ("Bad number of expected remaining patterns: "^(string_of_int n)) - | Result _ -> + | Result _ -> anomaly "Exhausted pattern history" (* This is for non exhaustive error message *) @@ -185,7 +185,7 @@ let rec simplify_history = function let pat = match f with | AliasConstructor pci -> PatCstr (dummy_loc,pci,pargs,Anonymous) - | AliasLeaf -> + | AliasLeaf -> assert (l = []); PatVar (dummy_loc, Anonymous) in feed_history pat rh @@ -203,7 +203,7 @@ let push_history_pattern n current cont = where tomatch is some sequence of "instructions" (t1 ... tn) - and mat is some matrix + and mat is some matrix (p11 ... p1n -> rhs1) ( ... ) (pm1 ... pmn -> rhsm) @@ -263,7 +263,7 @@ let rec find_row_ind = function let inductive_template isevars env tmloc ind = let arsign = get_full_arity_sign env ind in - let hole_source = match tmloc with + let hole_source = match tmloc with | Some loc -> fun i -> (loc, Evd.TomatchTypeParameter (ind,i)) | None -> fun _ -> (dummy_loc, Evd.InternalHole) in let (_,evarl,_) = @@ -273,7 +273,7 @@ let inductive_template isevars env tmloc ind = | None -> let ty' = substl subst ty in let e = e_new_evar isevars env ~src:(hole_source n) ty' in - (e::subst,e::evarl,n+1) + (e::subst,e::evarl,n+1) | Some b -> (b::subst,evarl,n+1)) arsign ([],[],1) in @@ -293,7 +293,7 @@ let evd_comb2 f isevars x y = let context_of_arsign l = let (x, _) = List.fold_right - (fun c (x, n) -> + (fun c (x, n) -> (lift_rel_context n c @ x, List.length c + n)) l ([], 0) in x @@ -302,11 +302,11 @@ let context_of_arsign l = 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 = + 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 + | 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 n when signlen > 1 (* The term is of a dependent type, @@ -314,12 +314,12 @@ let prepare_predicate_from_arsign_tycon loc env evm tomatchs arsign c = (match tmtype with | NotInd _ -> (* len - signlen, subst*) assert false (* signlen > 1 *) | IsInd (_, IndType(indf,realargs)) -> - let subst = - if dependent tm c && List.for_all isRel realargs - then (n, 1) :: subst else subst + let subst = + if dependent tm c && List.for_all isRel realargs + then (n, 1) :: subst else subst in List.fold_left - (fun (subst, len) arg -> + (fun (subst, len) arg -> match kind_of_term arg with | Rel n when dependent arg c -> ((n, len) :: subst, pred len) @@ -330,18 +330,18 @@ let prepare_predicate_from_arsign_tycon loc env evm tomatchs arsign c = in let rec predicate lift c = match kind_of_term c with - | Rel n when n > lift -> - (try + | 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 -> + with Not_found -> (* A variable that is not matched, lift over the arsign. *) mkRel (n + nar)) | _ -> - map_constr_with_binders succ predicate lift c + map_constr_with_binders succ predicate lift c in - try + 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 @@ -352,7 +352,7 @@ module Cases_F(Coercion : Coercion.S) : S = struct let inh_coerce_to_ind isevars env ty tyi = let expected_typ = inductive_template isevars env None tyi in - (* devrait être indifférent d'exiger leq ou pas puisque pour + (* devrait être indifférent d'exiger leq ou pas puisque pour un inductif cela doit être égal *) let _ = e_cumul env isevars expected_typ ty in () @@ -395,7 +395,7 @@ let adjust_tomatch_to_pattern pb ((current,typ),deps) = (* Ideally, we could find a common inductive type to which both the term to match and the patterns coerce *) (* In practice, we coerce the term to match if it is not already an - inductive type and it is not dependent; moreover, we use only + inductive type and it is not dependent; moreover, we use only the first pattern type and forget about the others *) let typ = match typ with IsInd (t,_) -> t | NotInd (_,t) -> t in let typ = @@ -479,7 +479,7 @@ let rec adjust_local_defs loc = function | [], [] -> [] | _ -> raise NotAdjustable -let check_and_adjust_constructor env ind cstrs = function +let check_and_adjust_constructor env ind cstrs = function | PatVar _ as pat -> pat | PatCstr (loc,((_,i) as cstr),args,alias) as pat -> (* Check it is constructor of the right type *) @@ -490,7 +490,7 @@ let check_and_adjust_constructor env ind cstrs = function let nb_args_constr = ci.cs_nargs in if List.length args = nb_args_constr then pat else - try + try let args' = adjust_local_defs loc (args, List.rev ci.cs_args) in PatCstr (loc, cstr, args', alias) with NotAdjustable -> @@ -500,7 +500,7 @@ let check_and_adjust_constructor env ind cstrs = function (* Try to insert a coercion *) try Coercion.inh_pattern_coerce_to loc pat ind' ind - with Not_found -> + with Not_found -> error_bad_constructor_loc loc cstr ind let check_all_variables typ mat = @@ -512,14 +512,14 @@ let check_all_variables typ mat = mat let check_unused_pattern env eqn = - if not !(eqn.used) then + if not !(eqn.used) then raise_pattern_matching_error (eqn.eqn_loc, env, UnusedClause eqn.patterns) let set_used_pattern eqn = eqn.used := true let extract_rhs pb = - match pb.mat with + match pb.mat with | [] -> errorlabstrm "build_leaf" (mssg_may_need_inversion()) | eqn::_ -> set_used_pattern eqn; @@ -558,7 +558,7 @@ let dependent_decl a = function let rec find_dependency_list k n = function | [] -> [] - | (used,tdeps,d)::rest -> + | (used,tdeps,d)::rest -> let deps = find_dependency_list k (n+1) rest in if used && dependent_decl (mkRel n) d then list_add_set (List.length rest + 1) (list_union deps tdeps) @@ -579,7 +579,7 @@ let find_dependencies_signature deps_in_rhs typs = (* A Pushed term to match has just been substituted by some constructor t = (ci x1...xn) and the terms x1 ... xn have been added to - match + match - all terms to match and to push (dependent on t by definition) must have (Rel depth) substituted by t and Rel's>depth lifted by n @@ -604,7 +604,7 @@ let regeneralize_index_tomatch n = ::(genrec (depth+1) rest) in genrec 0 -let rec replace_term n c k t = +let rec replace_term n c k t = if t = mkRel (n+k) then lift k c else map_constr_with_binders succ (replace_term n c) k t @@ -652,7 +652,7 @@ let lift_tomatch_stack n = liftn_tomatch_stack n 1 [match y with (S (S x)) => x | x => x end] should be compiled into [match y with O => y | (S n) => match n with O => y | (S x) => x end end] - and [match y with (S (S n)) => n | n => n end] into + and [match y with (S (S n)) => n | n => n end] into [match y with O => y | (S n0) => match n0 with O => y | (S n) => n end end] i.e. user names should be preserved and created names should not @@ -667,7 +667,7 @@ let merge_names get_name = List.map2 (merge_name get_name) let get_names env sign eqns = let names1 = list_tabulate (fun _ -> Anonymous) (List.length sign) in (* If any, we prefer names used in pats, from top to bottom *) - let names2 = + let names2 = List.fold_right (fun (pats,eqn) names -> merge_names alias_of_pat pats names) eqns names1 in @@ -681,7 +681,7 @@ let get_names env sign eqns = let na = merge_name (fun (na,_,t) -> Name (next_name_away (named_hd env t na) avoid)) - d na + d na in (na::l,(out_name na)::avoid)) ([],allvars) (List.rev sign) names2 in @@ -722,7 +722,7 @@ let build_aliases_context env sigma names allpats pats = let oldallpats = List.map List.tl oldallpats in let decl = (na,Some deppat,t) in let a = (deppat,nondeppat,d,t) in - insert (push_rel decl env) (decl::sign1) ((na,a)::sign2) (n+1) + insert (push_rel decl env) (decl::sign1) ((na,a)::sign2) (n+1) newallpats oldallpats (pats,names) | [], [] -> newallpats, sign1, sign2, env | _ -> anomaly "Inconsistent alias and name lists" in @@ -732,7 +732,7 @@ let build_aliases_context env sigma names allpats pats = let insert_aliases_eqn sign eqnnames alias_rest eqn = let thissign = List.map2 (fun na (_,c,t) -> (na,c,t)) eqnnames sign in push_rels_eqn thissign { eqn with alias_stack = alias_rest; } - + let insert_aliases env sigma alias eqns = (* Là, y a une faiblesse, si un alias est utilisé dans un cas par *) @@ -741,7 +741,7 @@ let insert_aliases env sigma alias eqns = let eqnsnames = List.map (fun eqn -> List.hd eqn.alias_stack) eqns in let alias_rests = List.map (fun eqn -> List.tl eqn.alias_stack) eqns in (* names2 takes the meet of all needed aliases *) - let names2 = + let names2 = List.fold_right (merge_name (fun x -> x)) eqnsnames Anonymous in (* Only needed aliases are kept by build_aliases_context *) let eqnsnames, sign1, sign2, env = @@ -753,12 +753,12 @@ let insert_aliases env sigma alias eqns = (* Functions to deal with elimination predicate *) exception Occur -let noccur_between_without_evar n m term = +let noccur_between_without_evar n m term = let rec occur_rec n c = match kind_of_term c with | Rel p -> if n<=p && p<n+m then raise Occur | Evar (_,cl) -> () | _ -> iter_constr_with_binders succ occur_rec n c - in + in try occur_rec n term; true with Occur -> false (* Inferring the predicate *) @@ -836,7 +836,7 @@ let rec transpose_args n = let shift_operator k = function OpLambda _ | OpProd _ -> k+1 | _ -> k -let reloc_operator (k,n) = function OpRel p when p > k -> +let reloc_operator (k,n) = function OpRel p when p > k -> let rec unify_clauses k pv = let pv'= Array.map (fun (n,sign,_,p) -> n,splay_constr (whd_betaiotaevar (push_rels (List.rev sign) env) ( isevars)) p) pv in let n1,op1 = let (n1,(op1,args1)) = pv'.(0) in n1,op1 in @@ -894,7 +894,7 @@ let infer_predicate loc env isevars typs cstrs indf = *) (* "TODO4-2" *) (* We skip parameters *) - let cis = + let cis = Array.map (fun cs -> applist (mkConstruct cs.cs_cstr, extended_rel_list 0 cs.cs_args)) @@ -1122,8 +1122,8 @@ let group_equations pb ind current cstrs mat = (fun eqn () -> let rest = remove_current_pattern eqn in let pat = current_pattern eqn in - match check_and_adjust_constructor pb.env ind cstrs pat with - | PatVar (_,name) -> + match check_and_adjust_constructor pb.env ind cstrs pat with + | PatVar (_,name) -> (* This is a default clause that we expand *) for i=1 to Array.length cstrs do let n = cstrs.(i-1).cs_nargs in @@ -1176,10 +1176,10 @@ let build_branch current deps pb eqns const_info = & not (known_dependent pb.pred) & deps = [] then NonDepAlias - else + else DepAlias in - let history = + let history = push_history_pattern const_info.cs_nargs (AliasConstructor const_info.cs_cstr) pb.history in @@ -1204,7 +1204,7 @@ let build_branch current deps pb eqns const_info = find_dependencies_signature (dependencies_in_rhs const_info.cs_nargs eqns) (List.rev typs) in - (* The dependent term to subst in the types of the remaining UnPushed + (* The dependent term to subst in the types of the remaining UnPushed terms is relative to the current context enriched by topushs *) let ci = build_dependent_constructor const_info in @@ -1283,7 +1283,7 @@ and match_current pb tomatch = 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 + 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 pb.casestyle in let case = mkCase (ci,nf_betaiota Evd.empty pred,current,brvals) in @@ -1382,10 +1382,10 @@ let oldprepare_predicate_from_tycon loc dep env isevars tomatchs sign c = e_new_evar isevars env ~src:(loc, Evd.CasesType) (Retyping.get_type_of env ( !isevars) c) else - map_constr_with_full_binders push_rel build_skeleton env c + map_constr_with_full_binders push_rel build_skeleton env c in names, build_skeleton env (lift n c) - + (* Here, [pred] is assumed to be in the context built from all *) (* realargs and terms to match *) let build_initial_predicate isdep allnames pred = @@ -1396,7 +1396,7 @@ let build_initial_predicate isdep allnames pred = let names' = if isdep then List.tl names else names in let n' = n + List.length names' in let pred, p, user_p = - if isdep then + if isdep then if dependent (mkRel (nar-n')) pred then pred, 1, 1 else liftn (-1) (nar-n') pred, 0, 1 else pred, 0, 0 in @@ -1414,10 +1414,10 @@ let build_initial_predicate isdep allnames pred = let extract_arity_signature env0 tomatchl tmsign = let get_one_sign n tm (na,t) = match tm with - | NotInd (bo,typ) -> + | NotInd (bo,typ) -> (match t with | None -> [na,Option.map (lift n) bo,lift n typ] - | Some (loc,_,_,_) -> + | Some (loc,_,_,_) -> user_err_loc (loc,"", str "Unexpected type annotation for a term of non inductive type")) | IsInd (_,IndType(indf,realargs)) -> @@ -1448,10 +1448,10 @@ let extract_arity_signature env0 tomatchl tmsign = let extract_arity_signatures env0 tomatchl tmsign = let get_one_sign tm (na,t) = match tm with - | NotInd (bo,typ) -> + | NotInd (bo,typ) -> (match t with | None -> [na,bo,typ] - | Some (loc,_,_,_) -> + | Some (loc,_,_,_) -> user_err_loc (loc,"", str "Unexpected type annotation for a term of non inductive type")) | IsInd (_,IndType(indf,realargs)) -> @@ -1487,19 +1487,19 @@ let inh_conv_coerce_to_tycon loc env isevars j tycon = | None -> j let out_ind = function IsInd (_, IndType(x, y)) -> (x, y) | _ -> assert(false) - -let string_of_name name = + +let string_of_name name = match name with | Anonymous -> "anonymous" | Name n -> string_of_id n - + let id_of_name n = id_of_string (string_of_name n) -let make_prime_id name = +let make_prime_id name = let str = string_of_name name in id_of_string str, id_of_string (str ^ "'") -let prime avoid name = +let prime avoid name = let previd, id = make_prime_id name in previd, next_ident_away_from id avoid @@ -1508,28 +1508,28 @@ let make_prime avoid prevname = avoid := id :: !avoid; previd, id -let eq_id avoid id = +let eq_id avoid id = let hid = id_of_string ("Heq_" ^ string_of_id id) in let hid' = next_ident_away_from hid avoid in hid' 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 = +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 (Evd.Define true)) -let constr_of_pat env isevars arsign pat avoid = - let rec typ env (ty, realargs) pat avoid = +let constr_of_pat env isevars arsign pat avoid = + let rec typ env (ty, realargs) pat avoid = match pat with - | PatVar (l,name) -> + | PatVar (l,name) -> let name, avoid = match name with Name n -> name, avoid - | Anonymous -> + | Anonymous -> let previd, id = prime avoid (Name (id_of_string "wildcard")) in - Name id, id :: avoid + Name id, id :: avoid in 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) -> @@ -1541,11 +1541,11 @@ let constr_of_pat env isevars arsign pat avoid = let ci = cstrs.(i-1) in let nb_args_constr = ci.cs_nargs in assert(nb_args_constr = List.length args); - let patargs, args, sign, env, n, m, avoid = + let patargs, args, sign, env, n, m, avoid = List.fold_right2 (fun (na, c, t) ua (patargs, args, sign, env, n, m, avoid) -> - let pat', sign', arg', typ', argtypargs, n', avoid = - typ env (lift (n - m) t, []) ua avoid + let pat', sign', arg', typ', argtypargs, n', avoid = + typ env (lift (n - m) t, []) ua avoid in let args' = arg' :: List.map (lift n') args in let env' = push_rels sign' env in @@ -1558,7 +1558,7 @@ 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 - let apptype = Retyping.get_type_of env ( !isevars) app in + let apptype = Retyping.get_type_of env ( !isevars) app in let IndType (indf, realargs) = find_rectype env ( !isevars) apptype in match alias with Anonymous -> @@ -1573,38 +1573,38 @@ let constr_of_pat env isevars arsign pat avoid = let eq_t = mk_eq (lift (succ m) ty) (mkRel 1) (* alias *) (lift 1 app) (* aliased term *) - in + in let neq = eq_id avoid id in (Name neq, Some (mkRel 0), eq_t) :: sign, 2, neq :: avoid with Reduction.NotConvertible -> sign, 1, avoid in (* Mark the equality as a hole *) pat', sign, lift i app, lift i apptype, realargs, n + i, avoid - in - let pat', sign, patc, patty, args, z, avoid = typ env (pi3 (List.hd arsign), List.tl arsign) pat avoid in + in + let pat', sign, patc, patty, args, z, avoid = typ env (pi3 (List.hd arsign), List.tl arsign) pat avoid in pat', (sign, patc, (pi3 (List.hd arsign), args), pat'), avoid (* shadows functional version *) -let eq_id avoid id = +let eq_id avoid id = let hid = id_of_string ("Heq_" ^ string_of_id id) in let hid' = next_ident_away_from hid !avoid in avoid := hid' :: !avoid; hid' -let rels_of_patsign = - List.map (fun ((na, b, t) as x) -> - match b with +let rels_of_patsign = + List.map (fun ((na, b, t) as x) -> + match b with | Some t' when kind_of_term t' = Rel 0 -> (na, None, t) | _ -> x) -let vars_of_ctx ctx = +let vars_of_ctx ctx = let _, y = - List.fold_right (fun (na, b, t) (prev, vars) -> - match b with - | Some t' when kind_of_term t' = Rel 0 -> - prev, - (RApp (dummy_loc, + List.fold_right (fun (na, b, t) (prev, vars) -> + match b with + | Some t' when kind_of_term t' = Rel 0 -> + prev, + (RApp (dummy_loc, (RRef (dummy_loc, Lazy.force refl_ref)), [hole; RVar (dummy_loc, prev)])) :: vars | _ -> match na with @@ -1613,7 +1613,7 @@ let vars_of_ctx ctx = ctx (id_of_string "vars_of_ctx_error", []) in List.rev y -let rec is_included x y = +let rec is_included x y = match x, y with | PatVar _, _ -> true | _, PatVar _ -> true @@ -1626,12 +1626,12 @@ let rec is_included x y = *) let build_ineqs prevpatterns pats liftsign = let _tomatchs = List.length pats in - let diffs = - List.fold_left - (fun c eqnpats -> + let diffs = + List.fold_left + (fun c eqnpats -> 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) + (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 @@ -1641,33 +1641,33 @@ 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 - let acc = + let acc = ((* Jump over previous prevpat signs *) - lift_rel_context len ppat_sign @ sign, + lift_rel_context len ppat_sign @ sign, len', succ n, (* nth pattern *) mkApp (Lazy.force eq_ind, [| lift (len' + liftsign) curpat_ty; liftn (len + liftsign) (succ lens) ppat_c ; - lift len' curpat_c |]) :: + lift len' curpat_c |]) :: List.map (lift lens (* Jump over this prevpat signature *)) c) in Some acc else None) (Some ([], 0, 0, [])) eqnpats pats - in match acc with + in match acc with None -> c | Some (sign, len, _, c') -> - let conj = it_mkProd_or_LetIn (mk_not (mk_conj c')) - (lift_rel_context liftsign sign) + let conj = it_mkProd_or_LetIn (mk_not (mk_conj c')) + (lift_rel_context liftsign sign) in conj :: c) [] prevpatterns in match diffs with [] -> None | _ -> Some (mk_conj diffs) - + let subst_rel_context k ctx subst = let (_, ctx') = - List.fold_right + List.fold_right (fun (n, b, t) (k, acc) -> (succ k, (n, Option.map (substnl subst k) b, substnl subst k t) :: acc)) ctx (k, []) @@ -1683,29 +1683,29 @@ let lift_rel_contextn n k sign = let constrs_of_pats typing_fun env isevars eqns tomatchs sign neqs arity = let i = ref 0 in - let (x, y, z) = + let (x, y, z) = List.fold_left (fun (branches, eqns, prevpatterns) eqn -> - let _, newpatterns, pats = + let _, newpatterns, pats = List.fold_left2 - (fun (idents, newpatterns, pats) pat arsign -> + (fun (idents, newpatterns, pats) pat arsign -> let pat', cpat, idents = constr_of_pat env isevars arsign pat idents in (idents, pat' :: newpatterns, cpat :: pats)) ([], [], []) eqn.patterns sign 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) -> + 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 *) let sign' = lift_rel_context n sign in let len = List.length sign' in - (sign' @ renv, + (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) opats in - let pats, _ = List.fold_left + 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 @@ -1716,7 +1716,7 @@ let constrs_of_pats typing_fun env isevars eqns tomatchs sign neqs arity = let rhs_rels' = rels_of_patsign rhs_rels in let _signenv = push_rel_context rhs_rels' env in let arity = - let args, nargs = + let args, nargs = List.fold_right (fun (sign, c, (_, args), _) (allargs,n) -> (args @ c :: allargs, List.length args + succ n)) pats ([], 0) @@ -1724,7 +1724,7 @@ let constrs_of_pats typing_fun env isevars eqns tomatchs sign neqs arity = let args = List.rev args in substl args (liftn signlen (succ nargs) arity) in - let rhs_rels', tycon = + let rhs_rels', tycon = let neqs_rels, arity = match ineqs with | None -> [], arity @@ -1740,7 +1740,7 @@ let constrs_of_pats typing_fun env isevars eqns tomatchs sign neqs arity = 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 - let branch = + let branch = let bref = RVar (dummy_loc, branch_name) in match vars_of_ctx rhs_rels with [] -> bref @@ -1767,30 +1767,30 @@ let constrs_of_pats typing_fun env isevars eqns tomatchs sign neqs arity = * A type constraint but no annotation case: it is assumed non dependent. *) - -let lift_ctx n ctx = + +let lift_ctx n ctx = let ctx', _ = List.fold_right (fun (c, t) (ctx, n') -> (liftn n n' c, liftn_tomatch_type n n' t) :: ctx, succ n') ctx ([], 0) in ctx' (* Turn matched terms into variables. *) let abstract_tomatch env tomatchs tycon = - let prev, ctx, names, tycon = + let prev, ctx, names, tycon = List.fold_left (fun (prev, ctx, names, tycon) (c, t) -> let lenctx = List.length ctx in match kind_of_term c with Rel n -> (lift lenctx c, lift_tomatch_type lenctx t) :: prev, ctx, names, tycon - | _ -> + | _ -> let tycon = Option.map (fun t -> subst_term_occ all_occurrences (lift 1 c) (lift 1 t)) tycon in let name = next_ident_away_from (id_of_string "filtered_var") names in - (mkRel 1, lift_tomatch_type (succ lenctx) t) :: lift_ctx 1 prev, - (Name name, Some (lift lenctx c), lift lenctx $ type_of_tomatch t) :: ctx, + (mkRel 1, lift_tomatch_type (succ lenctx) t) :: lift_ctx 1 prev, + (Name name, Some (lift lenctx c), lift lenctx $ type_of_tomatch t) :: ctx, name :: names, tycon) ([], [], [], tycon) tomatchs in List.rev prev, ctx, tycon - + let is_dependent_ind = function IsInd (_, IndType (indf, args)) when List.length args > 0 -> true | _ -> false @@ -1800,13 +1800,13 @@ let build_dependent_signature env evars avoid tomatchs arsign = let arsign = List.rev arsign in let allnames = List.rev (List.map (List.map pi1) arsign) in let nar = List.fold_left (fun n names -> List.length names + n) 0 allnames in - let eqs, neqs, refls, slift, arsign' = - List.fold_left2 - (fun (eqs, neqs, refl_args, slift, arsigns) (tm, ty) arsign -> + let eqs, neqs, refls, slift, arsign' = + List.fold_left2 + (fun (eqs, neqs, refl_args, slift, arsigns) (tm, ty) arsign -> (* The accumulator: - previous eqs, - number of previous eqs, - lift to get outside eqs and in the introduced variables ('as' and 'in'), + previous eqs, + number of previous eqs, + lift to get outside eqs and in the introduced variables ('as' and 'in'), new arity signatures *) match ty with @@ -1819,7 +1819,7 @@ let build_dependent_signature env evars avoid tomatchs arsign = List.fold_left2 (fun (env, nargeqs, argeqs, refl_args, slift, argsign') arg (name, b, t) -> let argt = Retyping.get_type_of env evars arg in - let eq, refl_arg = + let eq, refl_arg = if Reductionops.is_conv env evars argt t then (mk_eq (lift (nargeqs + slift) argt) (mkRel (nargeqs + slift)) @@ -1832,58 +1832,58 @@ let build_dependent_signature env evars avoid tomatchs arsign = (lift (nargeqs + nar) arg), mk_JMeq_refl argt arg) in - let previd, id = - let name = - match kind_of_term arg with + let previd, id = + let name = + match kind_of_term arg with Rel n -> pi1 (lookup_rel n env) | _ -> name in - make_prime avoid name + make_prime avoid name in - (env, succ nargeqs, - (Name (eq_id avoid previd), None, eq) :: argeqs, + (env, succ nargeqs, + (Name (eq_id avoid previd), None, eq) :: argeqs, refl_arg :: refl_args, pred slift, (Name id, b, t) :: argsign')) (env, 0, [], [], slift, []) args argsign in - let eq = mk_JMeq + let eq = mk_JMeq (lift (nargeqs + slift) appt) (mkRel (nargeqs + slift)) - (lift (nargeqs + nar) ty) - (lift (nargeqs + nar) tm) + (lift (nargeqs + nar) ty) + (lift (nargeqs + nar) tm) in let refl_eq = mk_JMeq_refl ty tm in let previd, id = make_prime avoid appn in - (((Name (eq_id avoid previd), None, eq) :: argeqs) :: eqs, - succ nargeqs, + (((Name (eq_id avoid previd), None, eq) :: argeqs) :: eqs, + succ nargeqs, refl_eq :: refl_args, - pred slift, + pred slift, (((Name id, appb, appt) :: argsign') :: arsigns)) - - | _ -> + + | _ -> (* Non dependent inductive or not inductive, just use a regular equality *) 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 tomatch_ty = type_of_tomatch ty in - let eq = + let eq = mk_eq (lift nar tomatch_ty) (mkRel slift) (lift nar tm) in - ([(Name (eq_id avoid previd), None, eq)] :: eqs, succ neqs, + ([(Name (eq_id avoid previd), None, eq)] :: eqs, succ neqs, (mk_eq_refl tomatch_ty tm) :: refl_args, pred slift, (arsign' :: []) :: arsigns)) ([], 0, [], nar, []) tomatchs arsign - in + in let arsign'' = List.rev arsign' in assert(slift = 0); (* we must have folded over all elements of the arity signature *) arsign'', allnames, nar, eqs, neqs, refls (**************************************************************************) (* Main entry of the matching compilation *) - -let liftn_rel_context n k sign = + +let liftn_rel_context n k sign = let rec liftrec k = function | (na,c,t)::sign -> (na,Option.map (liftn n k) c,liftn n k t)::(liftrec (k-1) sign) @@ -1891,16 +1891,16 @@ let liftn_rel_context n k sign = in liftrec (k + rel_context_length sign) sign -let nf_evars_env evar_defs (env : env) : env = +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 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' 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') ~init:env' env - + let prepare_predicate_from_rettyp loc typing_fun isevars env tomatchs sign tycon rtntyp = (* We extract the signature of the arity *) @@ -1910,12 +1910,12 @@ let prepare_predicate_from_rettyp loc typing_fun isevars env tomatchs sign tycon match rtntyp with | Some rtntyp -> let predcclj = typing_fun (mk_tycon (new_Type ())) newenv rtntyp in - let predccl = (j_nf_isevar !isevars predcclj).uj_val in + let predccl = (j_nf_isevar !isevars predcclj).uj_val in Some (build_initial_predicate true allnames predccl) - | None -> + | None -> match valcon_of_tycon tycon with - | Some ty -> - let pred = + | Some ty -> + let pred = prepare_predicate_from_arsign_tycon loc env !isevars tomatchs arsign ty in Some (build_initial_predicate true allnames pred) | None -> None @@ -1926,7 +1926,7 @@ let compile_cases loc style (typing_fun, isevars) (tycon : Evarutil.type_constra (* 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 @@ -1935,8 +1935,8 @@ let compile_cases loc style (typing_fun, isevars) (tycon : Evarutil.type_constra let tycon = valcon_of_tycon tycon in let tomatchs, tomatchs_lets, tycon' = abstract_tomatch env tomatchs tycon in let env = push_rel_context tomatchs_lets env in - let len = List.length eqns in - let sign, allnames, signlen, eqs, neqs, args = + 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 @@ -1945,21 +1945,21 @@ let compile_cases loc style (typing_fun, isevars) (tycon : Evarutil.type_constra build_dependent_signature env ( !isevars) avoid tomatchs arsign in - let tycon, arity = + let tycon, arity = match tycon' with | None -> let ev = mkExistential env isevars in ev, ev - | Some t -> + | Some t -> Option.get tycon, prepare_predicate_from_arsign_tycon loc env ( !isevars) tomatchs sign t in - let neqs, arity = + let neqs, arity = let ctx = context_of_arsign eqs in let neqs = List.length ctx in neqs, it_mkProd_or_LetIn (lift neqs arity) ctx in - let lets, matx = + let lets, matx = (* Type the rhs under the assumption of equations *) - constrs_of_pats typing_fun env isevars matx tomatchs sign neqs arity + 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 @@ -1973,7 +1973,7 @@ let compile_cases loc style (typing_fun, isevars) (tycon : Evarutil.type_constra (* We push the initial terms to match and push their alias to rhs' envs *) (* names of aliases will be recovered from patterns (hence Anonymous here) *) let initial_pushed = List.map (fun tm -> Pushed (tm,[])) tomatchs in - + let pb = { env = env; isevars = isevars; @@ -1984,12 +1984,12 @@ let compile_cases loc style (typing_fun, isevars) (tycon : Evarutil.type_constra caseloc = loc; casestyle= style; typing_function = typing_fun } 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 = + let j = { uj_val = it_mkLambda_or_LetIn body tomatchs_lets; uj_type = nf_isevar !isevars tycon; } in j @@ -2012,11 +2012,11 @@ let compile_cases loc style (typing_fun, isevars) (tycon : Evarutil.type_constra caseloc = loc; casestyle= style; typing_function = typing_fun } in - + let j = compile pb in (* We check for unused patterns *) List.iter (check_unused_pattern env) matx; - inh_conv_coerce_to_tycon loc env isevars j tycon - + inh_conv_coerce_to_tycon loc env isevars j tycon + end - + diff --git a/plugins/subtac/subtac_classes.ml b/plugins/subtac/subtac_classes.ml index 2b76266718..6fe14da34d 100644 --- a/plugins/subtac/subtac_classes.ml +++ b/plugins/subtac/subtac_classes.ml @@ -35,7 +35,7 @@ let interp_binder_evars evdref env na t = let interp_binders_evars isevars env avoid l = List.fold_left - (fun (env, ids, params) ((loc, i), t) -> + (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 @@ -44,7 +44,7 @@ let interp_binders_evars isevars env avoid l = let interp_typeclass_context_evars isevars env avoid l = List.fold_left - (fun (env, ids, params) (iid, bk, cl) -> + (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 @@ -56,13 +56,13 @@ let interp_typeclass_context_evars isevars env avoid l = let interp_constrs_evars isevars env avoid l = List.fold_left - (fun (env, ids, params) t -> + (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 ( !evdref) env c) @@ -99,11 +99,11 @@ let new_instance ?(global=false) ctx (instid, bk, cl) props ?(generalize=true) p match bk with | Implicit -> Implicit_quantifiers.implicit_application Idset.empty (* need no avoid *) - ~allow_partial:false (fun avoid (clname, (id, _, t)) -> - match clname with - | Some (cl, b) -> - let t = - if b then + ~allow_partial:false (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) else CHole (Util.dummy_loc, None) @@ -113,21 +113,21 @@ let new_instance ?(global=false) ctx (instid, bk, cl) props ?(generalize=true) p | Explicit -> cl in let tclass = if generalize then CGeneralization (dummy_loc, Implicit, Some AbsPi, tclass) else tclass in - let k, ctx', imps, subst = + 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 = decompose_prod_assum c' in let cl, args = Typeclasses.dest_class_app (push_rel_context ctx env) c in cl, ctx, imps, (List.rev args) in - let id = + let id = match snd instid with - | Name id -> + | 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 -> + | 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 @@ -136,29 +136,29 @@ let new_instance ?(global=false) ctx (instid, bk, cl) props ?(generalize=true) p isevars := resolve_typeclasses ~onlyargs:false ~fail:true env' !isevars; let sigma = !isevars in let subst = List.map (Evarutil.nf_evar sigma) subst in - let subst = - let props = + let subst = + let props = match props with - | CRecord (loc, _, fs) -> - if List.length fs > List.length k.cl_props then + | CRecord (loc, _, fs) -> + if List.length fs > List.length k.cl_props then Classes.mismatched_props env' (List.map snd fs) k.cl_props; fs - | _ -> - if List.length k.cl_props <> 1 then + | _ -> + if List.length k.cl_props <> 1 then errorlabstrm "new_instance" (Pp.str "Expected a definition for the instance body") else [(dummy_loc, Nameops.out_name (pi1 (List.hd k.cl_props))), props] in - match k.cl_props with - | [(na,b,ty)] -> + match k.cl_props with + | [(na,b,ty)] -> let term = match props with [] -> CHole (Util.dummy_loc, None) | [(_,f)] -> f | _ -> assert false in let ty' = substl subst ty in let c = interp_casted_constr_evars isevars env' term ty' in c :: subst | _ -> - let props, rest = + let props, rest = List.fold_left - (fun (props, rest) (id,_,_) -> - try + (fun (props, rest) (id,_,_) -> + try let ((loc, mid), c) = List.find (fun ((_,id'), c) -> Name id' = id) rest in let rest' = List.filter (fun ((_,id'), c) -> Name id' <> id) rest in Option.iter (fun x -> Dumpglob.add_glob loc (ConstRef x)) (List.assoc mid k.cl_projs); @@ -166,23 +166,23 @@ let new_instance ?(global=false) ctx (instid, bk, cl) props ?(generalize=true) p with Not_found -> (CHole (Util.dummy_loc, None) :: props), rest) ([], props) k.cl_props in - if rest <> [] then + if rest <> [] then unbound_method env' k.cl_impl (fst (List.hd rest)) else fst (type_ctx_instance isevars env' k.cl_props props subst) in - let subst = List.fold_left2 + let subst = List.fold_left2 (fun subst' s (_, b, _) -> if b = None then s :: subst' else subst') [] subst (k.cl_props @ snd k.cl_context) in let inst_constr, ty_constr = instance_constructor k subst in isevars := Evarutil.nf_evar_defs !isevars; let term = Evarutil.nf_isevar !isevars (it_mkLambda_or_LetIn inst_constr ctx') - and termtype = Evarutil.nf_isevar !isevars (it_mkProd_or_LetIn ty_constr ctx') + and termtype = Evarutil.nf_isevar !isevars (it_mkProd_or_LetIn ty_constr ctx') in isevars := undefined_evars !isevars; Evarutil.check_evars env Evd.empty !isevars termtype; - let hook vis gr = + let hook vis 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 ~enriching:false imps; @@ -191,4 +191,4 @@ let new_instance ?(global=false) ctx (instid, bk, cl) props ?(generalize=true) p let evm = Subtac_utils.evars_of_term ( !isevars) Evd.empty term in let obls, constr, typ = Eterm.eterm_obligations env id !isevars evm 0 term termtype in id, Subtac_obligations.add_definition id constr typ ~kind:(Global,false,Instance) ~hook obls - + diff --git a/plugins/subtac/subtac_classes.mli b/plugins/subtac/subtac_classes.mli index 917ed80594..eb9f3c8e38 100644 --- a/plugins/subtac/subtac_classes.mli +++ b/plugins/subtac/subtac_classes.mli @@ -32,7 +32,7 @@ val type_ctx_instance : Evd.evar_defs ref -> Term.constr list * ('a * Term.constr option * Term.constr) list -val new_instance : +val new_instance : ?global:bool -> local_binder list -> typeclass_constraint -> diff --git a/plugins/subtac/subtac_coercion.ml b/plugins/subtac/subtac_coercion.ml index ce7b5431b1..4dd3dd32be 100644 --- a/plugins/subtac/subtac_coercion.ml +++ b/plugins/subtac/subtac_coercion.ml @@ -33,7 +33,7 @@ open Pp let pair_of_array a = (a.(0), a.(1)) let make_name s = Name (id_of_string s) -let rec disc_subset x = +let rec disc_subset x = match kind_of_term x with | App (c, l) -> (match kind_of_term c with @@ -47,33 +47,33 @@ let rec disc_subset x = else None | _ -> None) | _ -> None - + and disc_exist env x = match kind_of_term x with | App (c, l) -> (match kind_of_term c with - Construct c -> + Construct c -> if c = Term.destConstruct (Lazy.force sig_).intro then Some (l.(0), l.(1), l.(2), l.(3)) else None | _ -> None) | _ -> None - + module Coercion = struct - + exception NoSubtacCoercion - + let disc_proj_exist env x = match kind_of_term x with | App (c, l) -> - (if Term.eq_constr c (Lazy.force sig_).proj1 - && Array.length l = 3 + (if Term.eq_constr c (Lazy.force sig_).proj1 + && Array.length l = 3 then disc_exist env l.(2) else None) | _ -> None - let sort_rel s1 s2 = + let sort_rel s1 s2 = match s1, s2 with Prop Pos, Prop Pos -> Prop Pos | Prop Pos, Prop Null -> Prop Null @@ -92,27 +92,27 @@ module Coercion = struct in liftrec (List.length sign) sign - let rec mu env isevars t = + let rec mu env isevars t = let isevars = ref isevars in - let rec aux v = + let rec aux v = let v = hnf env isevars v in match disc_subset v with - Some (u, p) -> + Some (u, p) -> let f, ct = aux u in - (Some (fun x -> - app_opt f (mkApp ((Lazy.force sig_).proj1, + (Some (fun x -> + app_opt f (mkApp ((Lazy.force sig_).proj1, [| u; p; x |]))), ct) | None -> (None, v) in aux t - and coerce loc env isevars (x : Term.constr) (y : Term.constr) - : (Term.constr -> Term.constr) option + and coerce loc env isevars (x : Term.constr) (y : Term.constr) + : (Term.constr -> Term.constr) option = let x = nf_evar ( !isevars) x and y = nf_evar ( !isevars) y in let rec coerce_unify env x y = let x = hnf env isevars x and y = hnf env isevars y in - try + try isevars := the_conv_x_leq env x y !isevars; None with Reduction.NotConvertible -> coerce' env x y @@ -125,7 +125,7 @@ module Coercion = struct in let rec coerce_application typ typ' c c' l l' = let len = Array.length l in - let rec aux tele typ typ' i co = + let rec aux tele typ typ' i co = if i < len then let hdx = l.(i) and hdy = l'.(i) in try isevars := the_conv_x_leq env hdx hdy !isevars; @@ -135,15 +135,15 @@ module Coercion = struct with Reduction.NotConvertible -> let (n, eqT), restT = dest_prod typ in let (n', eqT'), restT' = dest_prod typ' in - let _ = + 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 + let restargs = lift_args 1 (List.rev (Array.to_list (Array.sub l (succ i) (len - (succ i))))) - in + 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 @@ -152,14 +152,14 @@ module Coercion = struct [| eqT; hdx; pred; x; hdy; evar|]) in aux (hdy :: tele) (subst1 hdx restT) (subst1 hdy restT') (succ i) (fun x -> eq_app (co x)) else Some co - in + in if isEvar c || isEvar c' then (* Second-order unification needed. *) raise NoSubtacCoercion; aux [] typ typ' 0 (fun x -> x) in match (kind_of_term x, kind_of_term y) with - | Sort s, Sort s' -> + | Sort s, Sort s' -> (match s, s' with Prop x, Prop y when x = y -> None | Prop _, Type _ -> None @@ -178,11 +178,11 @@ module Coercion = struct None, None -> failwith "subtac.coerce': Should have detected equivalence earlier" | _, _ -> Some - (fun f -> + (fun f -> 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' -> (* Inductive types *) @@ -192,16 +192,16 @@ module Coercion = struct (* Sigma types *) if len = Array.length l' && len = 2 && i = i' && (i = Term.destInd existS.typ || i = Term.destInd prod.typ) - then - if i = Term.destInd existS.typ + then + if i = Term.destInd existS.typ then - begin - let (a, pb), (a', pb') = - pair_of_array l, pair_of_array l' + begin + let (a, pb), (a', pb') = + pair_of_array l, pair_of_array l' in let c1 = coerce_unify env a a' in - let rec remove_head a c = - match kind_of_term c with + let rec remove_head a c = + match kind_of_term c with | Lambda (n, t, t') -> c, t' (*| Prod (n, t, t') -> t'*) | Evar (k, args) -> @@ -217,35 +217,35 @@ module Coercion = struct let env' = push_rel (make_name "x", None, a) env in let c2 = coerce_unify env' b b' in match c1, c2 with - None, None -> + None, None -> None | _, _ -> - Some + Some (fun x -> - let x, y = + let x, y = app_opt c1 (mkApp (existS.proj1, [| a; pb; x |])), - app_opt c2 (mkApp (existS.proj2, + app_opt c2 (mkApp (existS.proj2, [| a; pb; x |])) in mkApp (existS.intro, [| a'; pb'; x ; y |])) end - else - begin - let (a, b), (a', b') = - pair_of_array l, pair_of_array l' + else + begin + let (a, b), (a', b') = + pair_of_array l, pair_of_array l' in let c1 = coerce_unify env a a' in let c2 = coerce_unify env b b' in match c1, c2 with None, None -> None | _, _ -> - Some + Some (fun x -> - let x, y = + let x, y = app_opt c1 (mkApp (prod.proj1, [| a; b; x |])), - app_opt c2 (mkApp (prod.proj2, + app_opt c2 (mkApp (prod.proj2, [| a; b; x |])) in mkApp (prod.intro, [| a'; b'; x ; y |])) @@ -253,7 +253,7 @@ module Coercion = struct else if i = i' && len = Array.length l' then let evm = !isevars in - (try subco () + (try subco () with NoSubtacCoercion -> let typ = Typing.type_of env evm c in let typ' = Typing.type_of env evm c' in @@ -276,25 +276,25 @@ module Coercion = struct and subset_coerce env isevars x y = match disc_subset x with - Some (u, p) -> + Some (u, p) -> let c = coerce_unify env u y in - let f x = - app_opt c (mkApp ((Lazy.force sig_).proj1, + let f x = + app_opt c (mkApp ((Lazy.force sig_).proj1, [| u; p; x |])) in Some f | None -> match disc_subset y with Some (u, p) -> let c = coerce_unify env x u in - Some + Some (fun x -> let cx = app_opt c x in let evar = make_existential loc env isevars (mkApp (p, [| cx |])) in - (mkApp - ((Lazy.force sig_).intro, + (mkApp + ((Lazy.force sig_).intro, [| u; p; cx; evar |]))) - | None -> + | None -> raise NoSubtacCoercion (*isevars := Evd.add_conv_pb (Reduction.CONV, x, y) !isevars; None*) @@ -304,7 +304,7 @@ module Coercion = struct let evars = ref isevars in let coercion = coerce loc env evars t c1 in !evars, Option.map (app_opt coercion) v - + (* Taken from pretyping/coercion.ml *) (* Typing operations dealing with coercions *) @@ -317,11 +317,11 @@ module Coercion = struct | h::restl -> (* On devrait pouvoir s'arranger pour qu'on n'ait pas à faire hnf_constr *) match kind_of_term (whd_betadeltaiota env Evd.empty typ) with - | Prod (_,c1,c2) -> + | Prod (_,c1,c2) -> (* Typage garanti par l'appel à app_coercion*) apply_rec (h::acc) (subst1 h c2) restl | _ -> anomaly "apply_coercion_args" - in + in apply_rec [] funj.uj_type argl (* appliquer le chemin de coercions de patterns p *) @@ -342,21 +342,21 @@ module Coercion = struct (* appliquer le chemin de coercions p à hj *) let apply_coercion env sigma p hj typ_cl = - try + try fst (List.fold_left - (fun (ja,typ_cl) i -> + (fun (ja,typ_cl) i -> let fv,isid = coercion_value i in let argl = (class_args_of env sigma typ_cl)@[ja.uj_val] in let jres = apply_coercion_args env argl fv in - (if isid then + (if isid then { uj_val = ja.uj_val; uj_type = jres.uj_type } - else + else jres), jres.uj_type) (hj,typ_cl) p) with _ -> anomaly "apply_coercion" - let inh_app_fun env isevars j = + let inh_app_fun env isevars j = let t = whd_betadeltaiota env ( isevars) j.uj_type in match kind_of_term t with | Prod (_,_,_) -> (isevars,j) @@ -369,7 +369,7 @@ module Coercion = struct lookup_path_to_fun_from env ( isevars) j.uj_type in (isevars,apply_coercion env ( isevars) p j t) with Not_found -> - try + try let coercef, t = mu env isevars t in (isevars, { uj_val = app_opt coercef j.uj_val; uj_type = t }) with NoSubtacCoercion | NoCoercion -> @@ -378,7 +378,7 @@ module Coercion = struct let inh_tosort_force loc env isevars j = try let t,p = lookup_path_to_sort_from env ( isevars) j.uj_type in - let j1 = apply_coercion env ( isevars) p j t in + let j1 = apply_coercion env ( isevars) p j t in (isevars,type_judgment env (j_nf_evar ( isevars) j1)) with Not_found -> error_not_a_type_loc loc env ( isevars) j @@ -396,29 +396,29 @@ module Coercion = struct let inh_coerce_to_base loc env isevars j = let typ = whd_betadeltaiota env ( isevars) j.uj_type in let ct, typ' = mu env isevars typ in - isevars, { uj_val = app_opt ct j.uj_val; + isevars, { uj_val = app_opt ct j.uj_val; uj_type = typ' } let inh_coerce_to_prod loc env isevars t = let typ = whd_betadeltaiota env ( isevars) (snd t) in let _, typ' = mu env isevars typ in isevars, (fst t, typ') - + 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 + try let t2,t1,p = lookup_path_between env ( evd) (t,c1) in match v with - Some v -> + Some v -> let j = apply_coercion env ( evd) p {uj_val = v; uj_type = t} t2 in Some j.uj_val, j.uj_type | None -> None, t - with Not_found -> raise NoCoercion + with Not_found -> raise NoCoercion in try (the_conv_x_leq env t' c1 evd, v') with Reduction.NotConvertible -> raise NoCoercion @@ -433,12 +433,12 @@ module Coercion = struct kind_of_term (whd_betadeltaiota env ( evd) t), kind_of_term (whd_betadeltaiota env ( evd) c1) with - | Prod (name,t1,t2), Prod (_,u1,u2) -> + | 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 + let name = match name with | Anonymous -> Name (id_of_string "x") | _ -> name in let env1 = push_rel (name,None,u1) env in @@ -456,8 +456,8 @@ module Coercion = struct let inh_conv_coerce_to_gen rigidonly loc env evd cj ((n, t) as _tycon) = match n with None -> - let (evd', val') = - try + let (evd', val') = + try 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) @@ -482,7 +482,7 @@ module Coercion = struct None -> 0, 0 | Some (init, cur) -> init, cur in - try + try let rels, rng = Reductionops.splay_prod_n env ( isevars) 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. *) diff --git a/plugins/subtac/subtac_command.ml b/plugins/subtac/subtac_command.ml index 1095b143cc..d1e890867c 100644 --- a/plugins/subtac/subtac_command.ml +++ b/plugins/subtac/subtac_command.ml @@ -55,11 +55,11 @@ let evar_nf isevars c = let get_undefined_evars evd = Evd.fold (fun ev evi evd' -> - if evi.evar_body = Evar_empty then + if evi.evar_body = Evar_empty then Evd.add evd' ev (nf_evar_info evd evi) else evd') evd Evd.empty -let interp_gen kind isevars env +let interp_gen kind isevars env ?(impls=([],[])) ?(allow_patvar=false) ?(ltacvars=([],[])) c = let c' = Constrintern.intern_gen (kind=IsType) ~impls ~allow_patvar ~ltacvars ( !isevars) env c in @@ -67,16 +67,16 @@ let interp_gen kind isevars env evar_nf isevars c' let interp_constr isevars env c = - interp_gen (OfType None) isevars env c + interp_gen (OfType None) isevars env 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 + 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 + interp_gen (OfType (Some typ)) isevars env ~impls c let interp_open_constr isevars env c = msgnl (str "Pretyping " ++ my_print_constr_expr c); @@ -85,17 +85,17 @@ let interp_open_constr isevars env c = evar_nf isevars c' let interp_constr_judgment isevars env c = - let j = + let j = SPretyping.understand_judgment_tcc isevars env - (Constrintern.intern_constr ( !isevars) env c) + (Constrintern.intern_constr ( !isevars) env c) in { uj_val = evar_nf isevars j.uj_val; uj_type = evar_nf isevars j.uj_type } let locate_if_isevar loc na = function - | RHole _ -> + | RHole _ -> (try match na with | Name id -> Reserve.find_reserved_type id - | Anonymous -> raise Not_found + | Anonymous -> raise Not_found with Not_found -> RHole (loc, Evd.BinderType na)) | x -> x @@ -103,7 +103,7 @@ let interp_binder sigma env na t = let t = Constrintern.intern_gen true ( !sigma) env t in SPretyping.understand_tcc_evars sigma env IsType (locate_if_isevar (loc_of_rawconstr t) na t) -let interp_context_evars evdref env params = +let interp_context_evars evdref env params = let bl = Constrintern.intern_context false ( !evdref) env params in let (env, par, _, impls) = List.fold_left @@ -113,7 +113,7 @@ let interp_context_evars evdref env params = 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 = + let impls = if k = Implicit then let na = match na with Name n -> Some n | Anonymous -> None in (ExplByPos (n, na), (true, true, true)) :: impls @@ -134,39 +134,39 @@ let list_chop_hd i l = match list_chop i l with | (x :: [], l2) -> ([], x, []) | _ -> assert(false) -let collect_non_rec env = - let rec searchrec lnonrec lnamerec ldefrec larrec nrec = +let collect_non_rec env = + let rec searchrec lnonrec lnamerec ldefrec larrec nrec = try - let i = + let i = list_try_find_i (fun i f -> if List.for_all (fun (_, def) -> not (occur_var env f def)) ldefrec then i else failwith "try_find_i") - 0 lnamerec + 0 lnamerec in let (lf1,f,lf2) = list_chop_hd i lnamerec in let (ldef1,def,ldef2) = list_chop_hd i ldefrec in let (lar1,ar,lar2) = list_chop_hd i larrec in - let newlnv = - try - match list_chop i nrec with + let newlnv = + try + match list_chop i nrec with | (lnv1,_::lnv2) -> (lnv1@lnv2) | _ -> [] (* nrec=[] for cofixpoints *) with Failure "list_chop" -> [] - in - searchrec ((f,def,ar)::lnonrec) + in + searchrec ((f,def,ar)::lnonrec) (lf1@lf2) (ldef1@ldef2) (lar1@lar2) newlnv - with Failure "try_find_i" -> + with Failure "try_find_i" -> (List.rev lnonrec, (Array.of_list lnamerec, Array.of_list ldefrec, Array.of_list larrec, Array.of_list nrec)) - in - searchrec [] + in + searchrec [] -let list_of_local_binders l = +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, k, 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 @@ -201,7 +201,7 @@ let telescope = function | (n, None, t) :: tl -> let ty, tys, (k, constr) = List.fold_left - (fun (ty, tys, (k, constr)) (n, b, t) -> + (fun (ty, tys, (k, constr)) (n, b, t) -> let pred = mkLambda (n, t, ty) in let sigty = mkApp ((Lazy.force sigT).typ, [|t; pred|]) in let intro = mkApp ((Lazy.force sigT).intro, [|lift k t; lift k pred; mkRel k; constr|]) in @@ -215,14 +215,14 @@ let telescope = function (lift 1 proj2, (n, Some proj1, t) :: subst)) (List.rev tys) tl (mkRel 1, []) in ty, ((n, Some last, t) :: subst), constr - + | _ -> raise (Invalid_argument "telescope") 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 env = Global.env() in let _pr c = my_print_constr env c in let _prr = Printer.pr_rel_context env in let _prn = Printer.pr_named_context env in @@ -235,8 +235,8 @@ let build_wellfounded (recname,n,bl,arityc,body) r measure notation boxed = let argtyp, letbinders, make = telescope binders_rel in let argname = id_of_string "recarg" in let arg = (Name argname, None, argtyp) in - let wrapper x = - if List.length binders_rel > 1 then + let wrapper x = + if List.length binders_rel > 1 then it_mkLambda_or_LetIn (mkApp (x, [|make|])) binders_rel else x in @@ -244,12 +244,12 @@ let build_wellfounded (recname,n,bl,arityc,body) r measure notation boxed = let binders_env = push_rel_context binders_rel env in let rel = interp_constr isevars env r in let relty = type_of env !isevars rel in - let relargty = + let relargty = let ctx, ar = Reductionops.splay_prod_n env !isevars 2 relty in match ctx, kind_of_term ar with - | [(_, None, t); (_, None, u)], Sort (Prop Null) + | [(_, None, t); (_, None, u)], Sort (Prop Null) when Reductionops.is_conv env !isevars t u -> t - | _, _ -> + | _, _ -> user_err_loc (constr_loc r, "Subtac_command.build_wellfounded", my_print_constr env rel ++ str " is not an homogeneous binary relation.") @@ -261,7 +261,7 @@ let build_wellfounded (recname,n,bl,arityc,body) r measure notation boxed = it_mkLambda_or_LetIn measure binders in let comb = constr_of_global (Lazy.force measure_on_R_ref) in - let wf_rel = mkApp (comb, [| argtyp; relargty; rel; measure |]) in + let wf_rel = mkApp (comb, [| argtyp; relargty; rel; measure |]) in let wf_rel_fun x y = mkApp (rel, [| subst1 x measure_body; subst1 y measure_body |]) @@ -280,13 +280,13 @@ let build_wellfounded (recname,n,bl,arityc,body) r measure notation boxed = let projection = (* in wfarg :: arg :: before *) mkApp (proj, [| argtyp ; wfargpred ; mkRel 1 |]) in - let top_arity_let = it_mkLambda_or_LetIn top_arity letbinders in + let top_arity_let = it_mkLambda_or_LetIn top_arity letbinders in let intern_arity = substl [projection] top_arity_let in (* substitute the projection of wfarg for something, now intern_arity is in wfarg :: arg *) let intern_fun_arity_prod = it_mkProd_or_LetIn intern_arity [wfarg 1] in let intern_fun_binder = (Name (add_suffix recname "'"), None, intern_fun_arity_prod) in - let curry_fun = + let curry_fun = let wfpred = mkLambda (Name argid', argtyp, wf_rel_fun (mkRel 1) (mkRel (2 * len + 4))) in let arg = mkApp ((Lazy.force sig_).intro, [| argtyp; wfpred; lift 1 make; mkRel 1 |]) in let app = mkApp (mkRel (2 * len + 2 (* recproof + orig binders + current binders *)), [| arg |]) in @@ -298,22 +298,22 @@ let build_wellfounded (recname,n,bl,arityc,body) r measure notation boxed = in let fun_bl = intern_fun_binder :: [arg] in let lift_lets = Termops.lift_rel_context 1 letbinders in - let intern_body = + let intern_body = let ctx = (Name recname, None, pi3 curry_fun) :: binders_rel in let impls = Command.compute_interning_datas env Constrintern.Recursive [] [recname] [full_arity] [impls] in - let newimpls = + let newimpls = match snd impls with [(p, (r, l, impls, scopes))] -> [(p, (r, l, impls @ [Some (id_of_string "recproof", Impargs.Manual, (true, false))], scopes @ [None]))] | x -> x - in interp_casted_constr isevars ~impls:(fst impls,newimpls) + in interp_casted_constr isevars ~impls:(fst impls,newimpls) (push_rel_context ctx env) body (lift 1 top_arity) in let intern_body_lam = it_mkLambda_or_LetIn intern_body (curry_fun :: lift_lets @ fun_bl) in let prop = mkLambda (Name argname, argtyp, top_arity_let) in let fix_def = mkApp (constr_of_global (Lazy.force fix_sub_ref), - [| argtyp ; wf_rel ; + [| argtyp ; wf_rel ; make_existential dummy_loc ~opaque:(Define false) env isevars wf_proof ; prop ; intern_body_lam |]) in @@ -328,10 +328,10 @@ let build_wellfounded (recname,n,bl,arityc,body) r measure notation boxed = 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) -> +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 - + let interp_fix_context evdref env fix = interp_context_evars evdref env fix.Command.fix_binders @@ -350,7 +350,7 @@ let prepare_recursive_declaration fixnames fixtypes fixdefs = 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 = +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 = @@ -359,16 +359,16 @@ let rec unfold f b = | None -> [] let compute_possible_guardness_evidences (n,_) (_, fixctx) fixtype = - match n with + match n with | Some (loc, n) -> [rel_index n fixctx] - | None -> + | 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 + 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 + unfold (function x when x = len -> None | n -> Some (n, succ n)) 0 let push_named_context = List.fold_right push_named @@ -402,11 +402,11 @@ let interp_recursive fixkind l boxed = 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 = + let rec_sign = List.fold_left2 (fun env' id t -> let sort = Retyping.get_type_of env !evdref t in - let fixprot = - try mkApp (Lazy.force Subtac_utils.fix_proto, [|sort; t|]) + let fixprot = + try mkApp (Lazy.force Subtac_utils.fix_proto, [|sort; t|]) with e -> t in (id,None,fixprot) :: env') @@ -419,8 +419,8 @@ let interp_recursive fixkind l boxed = let notations = List.fold_right Option.List.cons ntnl [] in (* Interp bodies with rollback because temp use of notations/implicit *) - let fixdefs = - States.with_state_protection (fun () -> + let fixdefs = + States.with_state_protection (fun () -> List.iter (Command.declare_interning_data impls) notations; list_map3 (interp_fix_body evdref env_rec impls) fixctxs fixl fixccls) () in @@ -434,7 +434,7 @@ let interp_recursive fixkind l boxed = let fixdefs = List.map (nf_evar evd) fixdefs in let fixtypes = List.map (nf_evar evd) fixtypes in let rec_sign = nf_named_context_evar 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; @@ -446,9 +446,9 @@ let interp_recursive fixkind l boxed = let isevars = Evd.undefined_evars evd in let evm = isevars in (* Solve remaining evars *) - let rec collect_evars id def typ imps = + let rec collect_evars id def typ imps = (* Generalize by the recursive prototypes *) - let def = + let def = Termops.it_mkNamedLambda_or_LetIn def rec_sign and typ = Termops.it_mkNamedProd_or_LetIn typ rec_sign @@ -457,14 +457,14 @@ let interp_recursive fixkind l boxed = 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 + in 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, + 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 @@ -480,8 +480,8 @@ 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, n, bl, typ, def) r - (match n with Some n -> mkIdentC (snd n) | None -> + ignore(build_wellfounded (id, n, bl, typ, def) r + (match n with Some n -> mkIdentC (snd n) | None -> errorlabstrm "Subtac_command.build_recursive" (str "Recursive argument required for well-founded fixpoints")) ntn false) @@ -491,15 +491,15 @@ let build_recursive l b = m 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 + 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) -> + 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/plugins/subtac/subtac_command.mli b/plugins/subtac/subtac_command.mli index 6f73bc9424..6c0c4340f9 100644 --- a/plugins/subtac/subtac_command.mli +++ b/plugins/subtac/subtac_command.mli @@ -47,7 +47,7 @@ val telescope : Term.types * (Names.name * Term.types option * Term.types) list * Term.constr -val build_wellfounded : +val build_wellfounded : Names.identifier * 'a * Topconstr.local_binder list * Topconstr.constr_expr * Topconstr.constr_expr -> Topconstr.constr_expr -> diff --git a/plugins/subtac/subtac_errors.ml b/plugins/subtac/subtac_errors.ml index 3bbfe22bc0..067da150ec 100644 --- a/plugins/subtac/subtac_errors.ml +++ b/plugins/subtac/subtac_errors.ml @@ -4,12 +4,12 @@ open Printer type term_pp = Pp.std_ppcmds -type subtyping_error = +type subtyping_error = | UncoercibleInferType of loc * term_pp * term_pp | UncoercibleInferTerm of loc * term_pp * term_pp * term_pp * term_pp | UncoercibleRewrite of term_pp * term_pp -type typing_error = +type typing_error = | NonFunctionalApp of loc * term_pp * term_pp * term_pp | NonConvertible of loc * term_pp * term_pp | NonSigma of loc * term_pp @@ -17,7 +17,7 @@ type typing_error = exception Subtyping_error of subtyping_error exception Typing_error of typing_error - + exception Debug_msg of string let typing_error e = raise (Typing_error e) diff --git a/plugins/subtac/subtac_obligations.ml b/plugins/subtac/subtac_obligations.ml index fb74867f1b..94bd059c2d 100644 --- a/plugins/subtac/subtac_obligations.ml +++ b/plugins/subtac/subtac_obligations.ml @@ -29,7 +29,7 @@ let explain_no_obligations = function type obligation_info = (Names.identifier * Term.types * loc * obligation_definition_status * Intset.t * Tacexpr.raw_tactic_expr option) array - + type obligation = { obl_name : identifier; obl_type : types; @@ -74,18 +74,18 @@ let get_proofs_transparency () = !proofs_transparency open Goptions let _ = - declare_bool_option + declare_bool_option { optsync = true; optname = "transparency of Program obligations"; optkey = ["Transparent";"Obligations"]; optread = get_proofs_transparency; - optwrite = set_proofs_transparency; } + optwrite = set_proofs_transparency; } let evar_of_obligation o = make_evar (Global.named_context_val ()) o.obl_type let get_obligation_body expand obl = let c = Option.get obl.obl_body in - if expand && obl.obl_status = Expand then + if expand && obl.obl_status = Expand then match kind_of_term c with | Const c -> constant_value (Global.env ()) c | _ -> c @@ -96,14 +96,14 @@ let subst_deps expand obls deps t = Intset.fold (fun x acc -> let xobl = obls.(x) in - let oblb = + let oblb = try get_obligation_body expand xobl with _ -> assert(false) in (xobl.obl_name, oblb) :: acc) deps [] in(* Termops.it_mkNamedProd_or_LetIn t subst *) Term.replace_vars subst t - + let subst_deps_obl obls obl = let t' = subst_deps false obls obl.obl_deps obl.obl_type in { obl with obl_type = t' } @@ -114,19 +114,19 @@ let map_replace k v m = ProgMap.add k v (ProgMap.remove k m) let map_keys m = ProgMap.fold (fun k _ l -> k :: l) m [] -let map_cardinal m = - let i = ref 0 in +let map_cardinal m = + let i = ref 0 in ProgMap.iter (fun _ _ -> incr i) m; !i exception Found of program_info -let map_first m = +let map_first m = try ProgMap.iter (fun _ v -> raise (Found v)) m; assert(false) with Found x -> x - + let from_prg : program_info ProgMap.t ref = ref ProgMap.empty let freeze () = !from_prg, !default_tactic_expr @@ -140,7 +140,7 @@ let init () = let _ = init () -let _ = +let _ = Summary.declare_summary "program-tcc-table" { Summary.freeze_function = freeze; Summary.unfreeze_function = unfreeze; @@ -155,10 +155,10 @@ let cache (_, (infos, tac)) = let load (_, (_, tac)) = set_default_tactic tac -let subst (_, s, (infos, tac)) = +let subst (_, s, (infos, tac)) = (infos, Tacinterp.subst_tactic s tac) -let (input,output) = +let (input,output) = declare_object { (default_object "Program state") with cache_function = cache; @@ -173,40 +173,40 @@ let (input,output) = subst_function = subst; export_function = (fun x -> Some x) } -let update_state () = +let update_state () = (* msgnl (str "Updating obligations info"); *) Lib.add_anonymous_leaf (input (!from_prg, !default_tactic_expr)) -let set_default_tactic t = +let set_default_tactic t = set_default_tactic t; update_state () - + open Evd -let progmap_remove prg = +let progmap_remove prg = from_prg := ProgMap.remove prg.prg_name !from_prg - + let rec intset_to = function -1 -> Intset.empty | n -> Intset.add n (intset_to (pred n)) - -let subst_body expand prg = + +let subst_body expand prg = let obls, _ = prg.prg_obligations in let ints = intset_to (pred (Array.length obls)) in subst_deps expand obls ints prg.prg_body, subst_deps expand obls ints (Termops.refresh_universes prg.prg_type) - + let declare_definition prg = let body, typ = subst_body false 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()) body ++ str " : " ++ my_print_constr (Global.env()) prg.prg_type); with _ -> ()); let (local, boxed, kind) = prg.prg_kind in - let ce = + let ce = { const_entry_body = body; const_entry_type = Some typ; const_entry_opaque = false; - const_entry_boxed = boxed} + const_entry_boxed = boxed} in (Command.get_declare_definition_hook ()) ce; match local with @@ -215,15 +215,15 @@ let declare_definition prg = 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 ++ + 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"); progmap_remove prg; update_state (); VarRef prg.prg_name | (Global|Local) -> let c = - Declare.declare_constant + Declare.declare_constant prg.prg_name (DefinitionEntry ce,IsDefinition (pi3 prg.prg_kind)) in let gr = ConstRef c in @@ -243,15 +243,15 @@ let rec lam_index n t acc = 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 + match n with | Some (loc, n) -> [lam_index n fixbody 0] - | None -> + | 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 + 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 (decompose_prod_n_assum m fixtype) in @@ -263,9 +263,9 @@ let reduce_fix = let declare_mutual_definition l = let len = List.length l in let first = List.hd l in - let fixdefs, fixtypes, fiximps = + let fixdefs, fixtypes, fiximps = list_split3 - (List.map (fun x -> + (List.map (fun x -> let subs, typ = (subst_body false x) in (strip_lam_n len subs), snd (decompose_prod_n len typ), x.prg_implicits) l) in @@ -285,7 +285,7 @@ let declare_mutual_definition l = 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 + in (* Declare the recursive definitions *) let kns = list_map4 (declare_fix boxed kind) fixnames fixdecls fixtypes fiximps in (* Declare notations *) @@ -293,36 +293,36 @@ let declare_mutual_definition l = Flags.if_verbose ppnl (Command.recursive_message kind indexes fixnames); let gr = List.hd kns in let kn = match gr with ConstRef kn -> kn | _ -> assert false in - first.prg_hook local gr; + first.prg_hook local gr; List.iter progmap_remove l; update_state (); kn - + let declare_obligation obl body = match obl.obl_status with | Expand -> { obl with obl_body = Some body } | Define opaque -> - let ce = + let ce = { const_entry_body = body; const_entry_type = Some obl.obl_type; - const_entry_opaque = - (if get_proofs_transparency () then false + const_entry_opaque = + (if get_proofs_transparency () then false else opaque) ; - const_entry_boxed = false} + const_entry_boxed = false} in - let constant = Declare.declare_constant obl.obl_name + let constant = Declare.declare_constant obl.obl_name (DefinitionEntry ce,IsProof Property) in print_message (Subtac_utils.definition_message obl.obl_name); { obl with obl_body = Some (mkConst constant) } - + let red = Reductionops.nf_betaiota Evd.empty let init_prog_info n b t deps fixkind notations obls impls kind hook = - let obls' = + let obls' = Array.mapi (fun i (n, t, l, o, d, tac) -> debug 2 (str "Adding obligation " ++ int i ++ str " with deps : " ++ str (string_of_intset d)); - { obl_name = n ; obl_body = None; + { obl_name = n ; obl_body = None; obl_location = l; obl_type = red t; obl_status = o; obl_deps = d; obl_tac = tac }) obls @@ -330,30 +330,30 @@ let init_prog_info n b t deps fixkind notations obls impls kind hook = { prg_name = n ; prg_body = b; prg_type = red t; prg_obligations = (obls', Array.length obls'); 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 match name with - Some n -> + Some n -> (try ProgMap.find n prg_infos with Not_found -> raise (NoObligations (Some n))) - | None -> + | None -> (let n = map_cardinal prg_infos in - match n with + match n with 0 -> raise (NoObligations None) | 1 -> map_first prg_infos | _ -> error "More than one program with unsolved obligations") -let get_prog_err n = +let get_prog_err n = try get_prog n with NoObligations id -> pperror (explain_no_obligations id) let obligations_solved prg = (snd prg.prg_obligations) = 0 - -type progress = - | Remain of int + +type progress = + | Remain of int | Dependent | Defined of global_reference - + let obligations_message rem = if rem > 0 then if rem = 1 then @@ -363,7 +363,7 @@ let obligations_message rem = else Flags.if_verbose msgnl (str "No more obligations remaining") -let update_obls prg obls rem = +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; @@ -379,12 +379,12 @@ let update_obls prg obls rem = let kn = declare_mutual_definition progs in Defined (ConstRef kn) else Dependent) - + let is_defined obls x = obls.(x).obl_body <> None -let deps_remaining obls deps = +let deps_remaining obls deps = Intset.fold - (fun x acc -> + (fun x acc -> if is_defined obls x then acc else x :: acc) deps [] @@ -392,18 +392,18 @@ let deps_remaining obls deps = let has_dependencies obls n = let res = ref false in Array.iteri - (fun i obl -> + (fun i obl -> if i <> n && Intset.mem n obl.obl_deps then res := true) obls; !res - + let kind_of_opacity o = match o with | Define false | Expand -> Subtac_utils.goal_kind | _ -> Subtac_utils.goal_proof_kind -let not_transp_msg = +let not_transp_msg = str "Obligation should be transparent but was declared opaque." ++ spc () ++ str"Use 'Defined' instead." @@ -415,15 +415,15 @@ let rec solve_obligation prg num = let obls, rem = prg.prg_obligations in let obl = obls.(num) in if obl.obl_body <> None then - pperror (str "Obligation" ++ spc () ++ int user_num ++ str "already" ++ spc() ++ str "solved.") + pperror (str "Obligation" ++ spc () ++ int user_num ++ str "already" ++ spc() ++ str "solved.") else match deps_remaining obls obl.obl_deps with | [] -> let obl = subst_deps_obl obls obl in Command.start_proof obl.obl_name (kind_of_opacity obl.obl_status) obl.obl_type - (fun strength gr -> + (fun strength gr -> let cst = match gr with ConstRef cst -> cst | _ -> assert false in - let obl = + let obl = let transparent = evaluable_constant cst (Global.env ()) in let body = match obl.obl_status with @@ -437,8 +437,8 @@ let rec solve_obligation prg num = in let obls = Array.copy obls in let _ = obls.(num) <- obl in - let res = try update_obls prg obls (pred rem) - with e -> pperror (Cerrors.explain_exn e) + let res = try update_obls prg obls (pred rem) + with e -> pperror (Cerrors.explain_exn e) in match res with | Remain n when n > 0 -> @@ -451,7 +451,7 @@ let rec solve_obligation prg num = 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)) - + and subtac_obligation (user_num, name, typ) = let num = pred user_num in let prg = get_prog_err name in @@ -462,20 +462,20 @@ and subtac_obligation (user_num, name, typ) = None -> solve_obligation prg num | Some r -> error "Obligation already solved" else error (sprintf "Unknown obligation number %i" (succ num)) - - + + and solve_obligation_by_tac prg obls i tac = let obl = obls.(i) in - match obl.obl_body with + match obl.obl_body with | Some _ -> false - | None -> + | None -> try if deps_remaining obls obl.obl_deps = [] then let obl = subst_deps_obl obls obl in - let tac = + let tac = match tac with | Some t -> t - | None -> + | None -> match obl.obl_tac with | Some t -> Tacinterp.interp t | None -> !default_tactic @@ -491,39 +491,39 @@ and solve_obligation_by_tac prg obls i tac = user_err_loc (obl.obl_location, "solve_obligation", Lazy.force s) | e -> false -and solve_prg_obligations prg tac = +and solve_prg_obligations prg tac = let obls, rem = prg.prg_obligations in let rem = ref rem in let obls' = Array.copy obls in - let _ = - Array.iteri (fun i x -> + let _ = + Array.iteri (fun i x -> if solve_obligation_by_tac prg obls' i tac then decr rem) obls' in update_obls prg obls' !rem -and solve_obligations n tac = +and solve_obligations n tac = let prg = get_prog_err n in solve_prg_obligations prg tac -and solve_all_obligations tac = +and solve_all_obligations tac = ProgMap.iter (fun k v -> ignore(solve_prg_obligations v tac)) !from_prg - -and try_solve_obligation n prg tac = - let prg = get_prog prg in + +and try_solve_obligation n prg tac = + let prg = get_prog prg in let obls, rem = prg.prg_obligations in let obls' = Array.copy obls in if solve_obligation_by_tac prg obls' n tac then ignore(update_obls prg obls' (pred rem)); -and try_solve_obligations n tac = +and try_solve_obligations n tac = try ignore (solve_obligations n tac) with NoObligations _ -> () and auto_solve_obligations n tac : progress = Flags.if_verbose msgnl (str "Solving obligations automatically..."); try solve_prg_obligations (get_prog_err n) tac with NoObligations _ -> Dependent - + open Pp let show_obligations ?(msg=true) n = let prg = get_prog_err n in @@ -531,17 +531,17 @@ let show_obligations ?(msg=true) n = let obls, rem = prg.prg_obligations in let showed = ref 5 in if msg then msgnl (int rem ++ str " obligation(s) remaining: "); - Array.iteri (fun i x -> - match x.obl_body with - | None -> + Array.iteri (fun i x -> + match x.obl_body with + | None -> if !showed > 0 then ( decr showed; msgnl (str "Obligation" ++ spc() ++ int (succ i) ++ spc () ++ - str "of" ++ spc() ++ str (string_of_id n) ++ str ":" ++ spc () ++ + str "of" ++ spc() ++ str (string_of_id n) ++ str ":" ++ spc () ++ hov 1 (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 @@ -554,19 +554,19 @@ let add_definition n b t ?(implicits=[]) ?(kind=Global,false,Definition) ?tactic 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 ( - Flags.if_verbose ppnl (str "."); - let cst = declare_definition prg in + 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 _ = Flags.if_verbose ppnl (str ", generating " ++ int len ++ str " obligation(s)") in - from_prg := ProgMap.add n prg !from_prg; + from_prg := ProgMap.add n prg !from_prg; let res = auto_solve_obligations (Some n) tactic in match res with | Remain rem -> Flags.if_verbose (fun () -> show_obligations ~msg:false (Some n)) (); res | _ -> res) - + let add_mutual_definitions l ?tactic ?(kind=Global,false,Definition) ?(hook=fun _ _ -> ()) notations fixkind = let deps = List.map (fun (n, b, t, imps, obls) -> n) l in let upd = List.fold_left @@ -576,23 +576,23 @@ let add_mutual_definitions l ?tactic ?(kind=Global,false,Definition) ?(hook=fun !from_prg l in from_prg := upd; - let _defined = - List.fold_left (fun finished x -> - if finished then finished + let _defined = + List.fold_left (fun finished x -> + if finished then finished else let res = auto_solve_obligations (Some x) tactic in match res with | Defined _ -> (* If one definition is turned into a constant, the whole block is defined. *) true - | _ -> false) + | _ -> false) false deps in () - + let admit_obligations n = let prg = get_prog_err n in let obls, rem = prg.prg_obligations in - Array.iteri (fun i x -> - match x.obl_body with - None -> + Array.iteri (fun i x -> + 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,false), IsAssumption Conjectural) in assumption_message x.obl_name; @@ -603,7 +603,7 @@ let admit_obligations n = exception Found of int -let array_find f arr = +let array_find f arr = try Array.iteri (fun i x -> if f x then raise (Found i)) arr; raise Not_found with Found i -> i @@ -611,9 +611,9 @@ let array_find f arr = let next_obligation n = let prg = get_prog_err n in let obls, rem = prg.prg_obligations in - let i = + let i = try array_find (fun x -> x.obl_body = None && deps_remaining obls x.obl_deps = []) obls with Not_found -> anomaly "Could not find a solvable obligation." in solve_obligation prg i - + let default_tactic () = !default_tactic diff --git a/plugins/subtac/subtac_obligations.mli b/plugins/subtac/subtac_obligations.mli index 2afcb19413..80d5b9465c 100644 --- a/plugins/subtac/subtac_obligations.mli +++ b/plugins/subtac/subtac_obligations.mli @@ -4,8 +4,8 @@ open Libnames open Evd open Proof_type -type obligation_info = - (identifier * Term.types * loc * +type obligation_info = + (identifier * Term.types * loc * obligation_definition_status * Intset.t * Tacexpr.raw_tactic_expr option) array (* ident, type, location, (opaque or transparent, expand or define), dependencies, tactic to solve it *) @@ -14,14 +14,14 @@ 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 -val add_definition : Names.identifier -> Term.constr -> Term.types -> +val add_definition : Names.identifier -> Term.constr -> Term.types -> ?implicits:(Topconstr.explicitation * (bool * bool * bool)) list -> ?kind:Decl_kinds.definition_kind -> ?tactic:Proof_type.tactic -> @@ -29,9 +29,9 @@ val add_definition : Names.identifier -> Term.constr -> Term.types -> type notations = (string * Topconstr.constr_expr * Topconstr.scope_name option) list -val add_mutual_definitions : +val add_mutual_definitions : (Names.identifier * Term.constr * Term.types * - (Topconstr.explicitation * (bool * bool * bool)) list * obligation_info) list -> + (Topconstr.explicitation * (bool * bool * bool)) list * obligation_info) list -> ?tactic:Proof_type.tactic -> ?kind:Decl_kinds.definition_kind -> ?hook:Tacexpr.declaration_hook -> @@ -45,7 +45,7 @@ val next_obligation : Names.identifier option -> unit val solve_obligations : Names.identifier option -> Proof_type.tactic option -> progress (* Number of remaining obligations to be solved for this program *) -val solve_all_obligations : Proof_type.tactic option -> unit +val solve_all_obligations : Proof_type.tactic option -> unit val try_solve_obligation : int -> Names.identifier option -> Proof_type.tactic option -> unit diff --git a/plugins/subtac/subtac_pretyping.ml b/plugins/subtac/subtac_pretyping.ml index 91418e05e7..e705e73c16 100644 --- a/plugins/subtac/subtac_pretyping.ml +++ b/plugins/subtac/subtac_pretyping.ml @@ -23,7 +23,7 @@ open Typeops open Libnames open Classops open List -open Recordops +open Recordops open Evarutil open Pretype_errors open Rawterm @@ -54,7 +54,7 @@ type recursion_info = { f_fulltype: types; (* Type with argument and wf proof product first *) } -let my_print_rec_info env t = +let my_print_rec_info env t = str "Name: " ++ Nameops.pr_name t.arg_name ++ spc () ++ str "Arg type: " ++ my_print_constr env t.arg_type ++ spc () ++ str "Wf relation: " ++ my_print_constr env t.wf_relation ++ spc () ++ @@ -65,10 +65,10 @@ let my_print_rec_info env t = (* str " and tycon "++ my_print_tycon env tycon ++ *) (* str " in environment: " ++ my_print_env env); *) -let merge_evms x y = +let merge_evms x y = Evd.fold (fun ev evi evm -> Evd.add evm ev evi) x y -let interp env isevars c tycon = +let interp env isevars c tycon = let j = pretype tycon env isevars ([],[]) c in let _ = isevars := Evarutil.nf_evar_defs !isevars in let evd,_ = consider_remaining_unif_problems env !isevars in @@ -92,7 +92,7 @@ let coqintern_type evd env : Topconstr.constr_expr -> Rawterm.rawconstr = Constr let env_with_binders env isevars l = let rec aux ((env, rels) as acc) = function - Topconstr.LocalRawDef ((loc, name), def) :: tl -> + Topconstr.LocalRawDef ((loc, name), def) :: tl -> let rawdef = coqintern_constr !isevars env def in let coqdef, deftyp = interp env isevars rawdef empty_tycon in let reldecl = (name, Some coqdef, deftyp) in @@ -100,10 +100,10 @@ let env_with_binders env isevars l = | 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 = - List.fold_left (fun (env, rels) (loc, name) -> + let acc = + List.fold_left (fun (env, rels) (loc, name) -> let reldecl = (name, None, coqtyp) in - (push_rel reldecl env, + (push_rel reldecl env, reldecl :: rels)) (env, rels) bl in aux acc tl @@ -112,15 +112,15 @@ let env_with_binders env isevars l = let subtac_process env isevars id bl c tycon = let c = Command.abstract_constr_expr c bl in - let tycon = + let tycon = match tycon with None -> empty_tycon - | Some t -> + | Some t -> 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 + 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 diff --git a/plugins/subtac/subtac_pretyping_F.ml b/plugins/subtac/subtac_pretyping_F.ml index a1d9603187..f818379e73 100644 --- a/plugins/subtac/subtac_pretyping_F.ml +++ b/plugins/subtac/subtac_pretyping_F.ml @@ -24,7 +24,7 @@ open Libnames open Nameops open Classops open List -open Recordops +open Recordops open Evarutil open Pretype_errors open Rawterm @@ -65,27 +65,27 @@ module SubtacPretyping_F (Coercion : Coercion.S) = struct let (evd',t) = f !evdref x y z in evdref := evd'; t - + let mt_evd = Evd.empty - + (* 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 *) (* et autoriser des ? à rester dans le résultat de l'unification *) - + let evar_type_fixpoint loc env evdref lna lar vdefj = - let lt = Array.length vdefj in - if Array.length lar = lt then - for i = 0 to lt-1 do + let lt = Array.length vdefj in + if Array.length lar = lt then + for i = 0 to lt-1 do if not (e_cumul env evdref (vdefj.(i)).uj_type (lift lt lar.(i))) then error_ill_typed_rec_body_loc loc env ( !evdref) i lna vdefj lar done - let check_branches_message loc env evdref c (explft,lft) = + let check_branches_message loc env evdref c (explft,lft) = for i = 0 to Array.length explft - 1 do - if not (e_cumul env evdref lft.(i) explft.(i)) then + if not (e_cumul env evdref lft.(i) explft.(i)) then let sigma = !evdref in error_ill_formed_branch_loc loc env sigma c i lft.(i) explft.(i) done @@ -137,19 +137,19 @@ module SubtacPretyping_F (Coercion : Coercion.S) = struct if n=0 then p else match kind_of_term p with | Lambda (_,_,c) -> decomp (n-1) c - | _ -> decomp (n-1) (applist (lift 1 p, [mkRel 1])) + | _ -> decomp (n-1) (applist (lift 1 p, [mkRel 1])) in let sign,s = decompose_prod_n n pj.uj_type in let ind = build_dependent_inductive env indf in let s' = mkProd (Anonymous, ind, s) in let ccl = lift 1 (decomp n pj.uj_val) in let ccl' = mkLambda (Anonymous, ind, ccl) in - {uj_val=it_mkLambda ccl' sign; uj_type=it_mkProd s' sign} + {uj_val=it_mkLambda ccl' sign; uj_type=it_mkProd s' sign} (*************************************************************************) (* Main pretyping function *) - let pretype_ref evdref env ref = + let pretype_ref evdref env ref = let c = constr_of_global ref in make_judge c (Retyping.get_type_of env Evd.empty c) @@ -160,7 +160,7 @@ module SubtacPretyping_F (Coercion : Coercion.S) = struct (* [pretype tycon env evdref lvar lmeta cstr] attempts to type [cstr] *) (* in environment [env], with existential variables [( evdref)] and *) (* the type constraint tycon *) - let rec pretype (tycon : type_constraint) env evdref lvar c = + let rec pretype (tycon : type_constraint) env evdref lvar c = (* let _ = try Subtac_utils.trace (str "pretype " ++ Subtac_utils.my_print_rawconstr env c ++ *) (* str " with tycon " ++ Evarutil.pr_tycon env tycon) *) (* with _ -> () *) @@ -187,12 +187,12 @@ module SubtacPretyping_F (Coercion : Coercion.S) = struct let j = (Retyping.get_judgment_of env ( !evdref) c) in inh_conv_coerce_to_tycon loc env evdref j tycon - | RPatVar (loc,(someta,n)) -> + | RPatVar (loc,(someta,n)) -> anomaly "Found a pattern variable in a rawterm to type" - + | RHole (loc,k) -> let ty = - match tycon with + match tycon with | Some (None, ty) -> ty | None | Some _ -> e_new_evar evdref env ~src:(loc,InternalHole) (new_Type ()) in @@ -221,19 +221,19 @@ module SubtacPretyping_F (Coercion : Coercion.S) = struct let nbfix = Array.length lar in let names = Array.map (fun id -> Name id) names in (* Note: bodies are not used by push_rec_types, so [||] is safe *) - let newenv = - let marked_ftys = + let newenv = + let marked_ftys = Array.map (fun ty -> let sort = Retyping.get_type_of env !evdref ty in mkApp (Lazy.force Subtac_utils.fix_proto, [| sort; ty |])) ftys in - push_rec_types (names,marked_ftys,[||]) env + push_rec_types (names,marked_ftys,[||]) env in let fixi = match fixkind with RFix (vn, i) -> i | RCoFix i -> i in let vdefj = - array_map2_i + array_map2_i (fun i ctxt def -> - let fty = + let fty = let ty = ftys.(i) in if i = fixi then ( Option.iter (fun tycon -> @@ -260,19 +260,19 @@ module SubtacPretyping_F (Coercion : Coercion.S) = struct (* 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 + 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 + let possible_indexes = Array.to_list (Array.mapi + (fun i (n,_) -> match n with | Some n -> [n] | None -> list_map_i (fun i _ -> i) 0 ctxtv.(i)) vn) - in - let fixdecls = (names,ftys,fdefs) in - let indexes = search_guard loc env possible_indexes fixdecls in + in + let fixdecls = (names,ftys,fdefs) in + let indexes = search_guard loc env possible_indexes fixdecls in make_judge (mkFix ((indexes,i),fixdecls)) ftys.(i) - | RCoFix i -> + | RCoFix i -> let cofix = (i,(names,ftys,fdefs)) in (try check_cofix env cofix with e -> Stdpp.raise_with_loc loc e); make_judge (mkCoFix cofix) ftys.(i) in @@ -281,10 +281,10 @@ module SubtacPretyping_F (Coercion : Coercion.S) = struct | RSort (loc,s) -> inh_conv_coerce_to_tycon loc env evdref (pretype_sort s) tycon - | RApp (loc,f,args) -> - let length = List.length args in + | RApp (loc,f,args) -> + let length = List.length args in let ftycon = - let ty = + let ty = if length > 0 then match tycon with | None -> None @@ -292,7 +292,7 @@ module SubtacPretyping_F (Coercion : Coercion.S) = struct | Some (Some (init, cur), ty) -> Some (Some (length + init, length + cur), ty) else tycon - in + in match ty with | Some (_, t) when Subtac_coercion.disc_subset t = None -> ty | _ -> None @@ -314,14 +314,14 @@ module SubtacPretyping_F (Coercion : Coercion.S) = struct let hj = pretype (mk_tycon (nf_evar !evdref c1)) env evdref lvar c in let value, typ = applist (j_val resj, [j_val hj]), subst1 hj.uj_val c2 in let typ' = nf_evar !evdref typ in - apply_rec env (n+1) + apply_rec env (n+1) { uj_val = nf_evar !evdref value; uj_type = nf_evar !evdref typ' } (Option.map (fun (abs, c) -> abs, nf_evar !evdref c) tycon) rest | _ -> let hj = pretype empty_tycon env evdref lvar c in - error_cant_apply_not_functional_loc + error_cant_apply_not_functional_loc (join_loc floc argloc) env ( !evdref) resj [hj] in @@ -337,20 +337,20 @@ module SubtacPretyping_F (Coercion : Coercion.S) = struct inh_conv_coerce_to_tycon loc env evdref resj tycon | RLambda(loc,name,k,c1,c2) -> - let tycon' = evd_comb1 - (fun evd tycon -> - match tycon with - | None -> evd, tycon - | Some ty -> + let tycon' = evd_comb1 + (fun evd tycon -> + match tycon with + | None -> evd, tycon + | Some ty -> let evd, ty' = Coercion.inh_coerce_to_prod loc env evd ty in - evd, Some ty') - evdref tycon + evd, Some ty') + evdref tycon in let (name',dom,rng) = evd_comb1 (split_tycon loc env) evdref tycon' in let dom_valcon = valcon_of_tycon dom in let j = pretype_type dom_valcon env evdref lvar c1 in let var = (name,None,j.utj_val) in - let j' = pretype rng (push_rel var env) evdref lvar c2 in + let j' = pretype rng (push_rel var env) evdref lvar c2 in let resj = judge_of_abstraction env name j j' in inh_conv_coerce_to_tycon loc env evdref resj tycon @@ -363,7 +363,7 @@ module SubtacPretyping_F (Coercion : Coercion.S) = struct try judge_of_product env name j j' with TypeError _ as e -> Stdpp.raise_with_loc loc e in inh_conv_coerce_to_tycon loc env evdref resj tycon - + | RLetIn(loc,name,c1,c2) -> let j = pretype empty_tycon env evdref lvar c1 in let t = refresh_universes j.uj_type in @@ -375,11 +375,11 @@ module SubtacPretyping_F (Coercion : Coercion.S) = struct | RLetTuple (loc,nal,(na,po),c,d) -> let cj = pretype empty_tycon env evdref lvar c in - let (IndType (indf,realargs)) = + let (IndType (indf,realargs)) = try find_rectype env ( !evdref) cj.uj_type with Not_found -> let cloc = loc_of_rawconstr c in - error_case_not_inductive_loc cloc env ( !evdref) cj + error_case_not_inductive_loc cloc env ( !evdref) cj in let cstrs = get_constructors env indf in if Array.length cstrs <> 1 then @@ -406,7 +406,7 @@ module SubtacPretyping_F (Coercion : Coercion.S) = struct let ccl = nf_evar ( !evdref) pj.utj_val in let psign = make_arity_signature env true indf in (* with names *) let p = it_mkLambda_or_LetIn ccl psign in - let inst = + let inst = (Array.to_list cs.cs_concl_realargs) @[build_dependent_constructor cs] in let lp = lift cs.cs_nargs p in @@ -416,45 +416,45 @@ module SubtacPretyping_F (Coercion : Coercion.S) = struct let v = let mis,_ = dest_ind_family indf in let ci = make_case_info env mis LetStyle in - mkCase (ci, p, cj.uj_val,[|f|]) in + mkCase (ci, p, cj.uj_val,[|f|]) in { uj_val = v; uj_type = substl (realargs@[cj.uj_val]) ccl } - | None -> + | None -> let tycon = lift_tycon cs.cs_nargs tycon in let fj = pretype tycon env_f evdref lvar d in let f = it_mkLambda_or_LetIn fj.uj_val fsign in let ccl = nf_evar ( !evdref) fj.uj_type in let ccl = if noccur_between 1 cs.cs_nargs ccl then - lift (- cs.cs_nargs) ccl + lift (- cs.cs_nargs) ccl else - error_cant_find_case_type_loc loc env ( !evdref) + error_cant_find_case_type_loc loc env ( !evdref) cj.uj_val in let p = it_mkLambda_or_LetIn (lift (nar+1) ccl) psign in let v = let mis,_ = dest_ind_family indf in let ci = make_case_info env mis LetStyle in - mkCase (ci, p, cj.uj_val,[|f|] ) + mkCase (ci, p, cj.uj_val,[|f|] ) in { uj_val = v; uj_type = ccl }) | RIf (loc,c,(na,po),b1,b2) -> let cj = pretype empty_tycon env evdref lvar c in - let (IndType (indf,realargs)) = + let (IndType (indf,realargs)) = try find_rectype env ( !evdref) cj.uj_type with Not_found -> let cloc = loc_of_rawconstr c in error_case_not_inductive_loc cloc env ( !evdref) cj in - let cstrs = get_constructors env indf in + let cstrs = get_constructors env indf in if Array.length cstrs <> 2 then user_err_loc (loc,"", str "If is only for inductive types with two constructors."); - let arsgn = + let arsgn = let arsgn,_ = get_arity env indf in if not !allow_anonymous_refs then (* Make dependencies from arity signature impossible *) - List.map (fun (_,b,t) -> (Anonymous,b,t)) arsgn + List.map (fun (_,b,t) -> (Anonymous,b,t)) arsgn else arsgn in let nar = List.length arsgn in @@ -467,10 +467,10 @@ module SubtacPretyping_F (Coercion : Coercion.S) = struct let pred = it_mkLambda_or_LetIn ccl psign in let typ = lift (- nar) (beta_applist (pred,[cj.uj_val])) in let jtyp = inh_conv_coerce_to_tycon loc env evdref {uj_val = pred; - uj_type = typ} tycon + uj_type = typ} tycon in jtyp.uj_val, jtyp.uj_type - | None -> + | None -> let p = match tycon with | Some (None, ty) -> ty | None | Some _ -> @@ -484,18 +484,18 @@ module SubtacPretyping_F (Coercion : Coercion.S) = struct let n = rel_context_length cs.cs_args in let pi = lift n pred in (* liftn n 2 pred ? *) let pi = beta_applist (pi, [build_dependent_constructor cs]) in - let csgn = + let csgn = if not !allow_anonymous_refs then - List.map (fun (_,b,t) -> (Anonymous,b,t)) cs.cs_args - else - List.map + List.map (fun (_,b,t) -> (Anonymous,b,t)) cs.cs_args + else + List.map (fun (n, b, t) -> match n with Name _ -> (n, b, t) | Anonymous -> (Name (id_of_string "H"), b, t)) cs.cs_args in - let env_c = push_rels csgn env in + let env_c = push_rels csgn env in (* msgnl (str "Pi is: " ++ Termops.print_constr_env env_c pi); *) let bj = pretype (mk_tycon pi) env_c evdref lvar b in it_mkLambda_or_LetIn bj.uj_val cs.cs_args in @@ -548,7 +548,7 @@ module SubtacPretyping_F (Coercion : Coercion.S) = struct let t = Retyping.get_type_of env sigma v in match kind_of_term (whd_betadeltaiota env sigma t) with | Sort s -> s - | Evar ev when is_Type (existential_type sigma ev) -> + | Evar ev when is_Type (existential_type sigma ev) -> evd_comb1 (define_evar_as_sort) evdref ev | _ -> anomaly "Found a type constraint which is not a type" in @@ -579,7 +579,7 @@ module SubtacPretyping_F (Coercion : Coercion.S) = struct (pretype_type empty_valcon env evdref lvar c).utj_val in evdref := fst (consider_remaining_unif_problems env !evdref); if resolve_classes then - evdref := + evdref := Typeclasses.resolve_typeclasses ~onlyargs:false ~split:true ~fail:fail_evar env !evdref; let c = nf_evar !evdref c' in diff --git a/plugins/subtac/subtac_utils.ml b/plugins/subtac/subtac_utils.ml index 645e3e23ec..288d3854fd 100644 --- a/plugins/subtac/subtac_utils.ml +++ b/plugins/subtac/subtac_utils.ml @@ -40,7 +40,7 @@ let sig_ref = make_ref "Init.Specif.sig" let proj1_sig_ref = make_ref "Init.Specif.proj1_sig" let proj2_sig_ref = make_ref "Init.Specif.proj2_sig" -let build_sig () = +let build_sig () = { proj1 = init_constant ["Init"; "Specif"] "proj1_sig"; proj2 = init_constant ["Init"; "Specif"] "proj2_sig"; elim = init_constant ["Init"; "Specif"] "sig_rec"; @@ -67,13 +67,13 @@ 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 (check_required_library ["Coq";"Logic";"JMeq"]; +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"]; +let jmeq_rec = + lazy (check_required_library ["Coq";"Logic";"JMeq"]; init_constant ["Logic";"JMeq"] "JMeq_rec") -let jmeq_refl = +let jmeq_refl = lazy (check_required_library ["Coq";"Logic";"JMeq"]; init_constant ["Logic";"JMeq"] "JMeq_refl") @@ -88,7 +88,7 @@ let sumboolind = lazy (init_constant ["Init"; "Specif"] "sumbool") let natind = lazy (init_constant ["Init"; "Datatypes"] "nat") let intind = lazy (init_constant ["ZArith"; "binint"] "Z") let existSind = lazy (init_constant ["Init"; "Specif"] "sigS") - + let existS = lazy (build_sigma_type ()) let prod = lazy (build_prod ()) @@ -120,20 +120,20 @@ let debug_level = 2 let debug_on = true -let debug n s = +let debug n s = if debug_on then if !Flags.debug && n >= debug_level then msgnl s else () else () -let debug_msg n s = +let debug_msg n s = if debug_on then if !Flags.debug && n >= debug_level then s else mt () else mt () -let trace s = +let trace s = if debug_on then if !Flags.debug && debug_level > 0 then msgnl s else () @@ -145,28 +145,28 @@ let rec pp_list f = function let wf_relations = Hashtbl.create 10 -let std_relations () = +let std_relations () = let add k v = Hashtbl.add wf_relations k v in add (init_constant ["Init"; "Peano"] "lt") (lazy (init_constant ["Arith"; "Wf_nat"] "lt_wf")) - + let std_relations = Lazy.lazy_from_fun std_relations type binders = Topconstr.local_binder list -let app_opt c e = +let app_opt c e = match c with Some constr -> constr e - | None -> e + | None -> e -let print_args env args = +let print_args env args = Array.fold_right (fun a acc -> my_print_constr env a ++ spc () ++ acc) args (str "") let make_existential loc ?(opaque = Define true) env isevars c = let evar = Evarutil.e_new_evar isevars env ~src:(loc, QuestionMark opaque) c in let (key, args) = destEvar evar in (try trace (str "Constructed evar " ++ int key ++ str " applied to args: " ++ - print_args env args ++ str " for type: "++ + print_args env args ++ str " for type: "++ my_print_constr env c) with _ -> ()); evar @@ -186,29 +186,29 @@ let string_of_hole_kind = function | GoalEvar -> "GoalEvar" | ImpossibleCase -> "ImpossibleCase" -let evars_of_term evc init c = +let evars_of_term evc init c = let rec evrec acc c = match kind_of_term c with | Evar (n, _) when Evd.mem evc n -> Evd.add acc n (Evd.find evc n) | Evar (n, _) -> assert(false) | _ -> fold_constr evrec acc c - in + in evrec init c let non_instanciated_map env evd evm = - List.fold_left - (fun evm (key, evi) -> + List.fold_left + (fun evm (key, evi) -> let (loc,k) = evar_source key !evd in - debug 2 (str "evar " ++ int key ++ str " has kind " ++ + debug 2 (str "evar " ++ int key ++ str " has kind " ++ str (string_of_hole_kind k)); - match k with + match k with | QuestionMark _ -> Evd.add evm key evi | ImplicitArg (_,_,false) -> Evd.add evm key evi | _ -> debug 2 (str " and is an implicit"); 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 let goal_kind = Decl_kinds.Global, Decl_kinds.DefinitionBody Decl_kinds.Definition @@ -222,7 +222,7 @@ open Tactics open Tacticals let id x = x -let filter_map f l = +let filter_map f l = let rec aux acc = function hd :: tl -> (match f hd with Some t -> aux (t :: acc) tl | None -> aux acc tl) @@ -237,36 +237,36 @@ let build_dependent_sum l = (try trace (str " assert: " ++ my_print_constr (Global.env ()) hyptype) with _ -> ()); let tac = assert_tac (Name n) hyptype in - let conttac = - (fun cont -> + let conttac = + (fun cont -> conttac (tclTHENS tac ([intros; - (tclTHENSEQ - [constructor_tac false (Some 1) 1 + (tclTHENSEQ + [constructor_tac false (Some 1) 1 (Rawterm.ImplicitBindings [inj_open (mkVar n)]); cont]); ]))) in - let conttype = - (fun typ -> + let conttype = + (fun typ -> let tex = mkLambda (Name n, t, typ) in conttype (mkApp (Lazy.force ex_ind, [| t; tex |]))) in aux (mkVar n :: names) conttac conttype tl - | (n, t) :: [] -> + | (n, t) :: [] -> (conttac intros, conttype t) | [] -> raise (Invalid_argument "build_dependent_sum") - in aux [] id id (List.rev l) - + in aux [] id id (List.rev l) + open Proof_type open Tacexpr -let mkProj1 a b c = +let mkProj1 a b c = mkApp (Lazy.force proj1, [| a; b; c |]) -let mkProj2 a b c = +let mkProj2 a b c = mkApp (Lazy.force proj2, [| a; b; c |]) let mk_ex_pi1 a b c = @@ -274,8 +274,8 @@ let mk_ex_pi1 a b c = let mk_ex_pi2 a b c = mkApp (Lazy.force ex_pi2, [| a; b; c |]) - -let mkSubset name typ prop = + +let mkSubset name typ prop = mkApp ((Lazy.force sig_).typ, [| typ; mkLambda (name, typ, prop) |]) @@ -300,22 +300,22 @@ let mk_not c = mkApp (notc, [| c |]) let and_tac l hook = - let andc = Coqlib.build_coq_and () in + let andc = Coqlib.build_coq_and () in let rec aux ((accid, goal, tac, extract) as acc) = function | [] -> (* Singleton *) acc - + | (id, x, elgoal, eltac) :: tl -> let tac' = tclTHEN simplest_split (tclTHENLIST [tac; eltac]) in let proj = fun c -> mkProj2 goal elgoal c in let extract = List.map (fun (id, x, y, f) -> (id, x, y, (fun c -> f (mkProj1 goal elgoal c)))) extract in - aux ((string_of_id id) ^ "_" ^ accid, mkApp (andc, [| goal; elgoal |]), tac', + aux ((string_of_id id) ^ "_" ^ accid, mkApp (andc, [| goal; elgoal |]), tac', (id, x, elgoal, proj) :: extract) tl in - let and_proof_id, and_goal, and_tac, and_extract = + let and_proof_id, and_goal, and_tac, and_extract = match l with | [] -> raise (Invalid_argument "and_tac: empty list of goals") - | (hdid, x, hdg, hdt) :: tl -> + | (hdid, x, hdg, hdt) :: tl -> aux (string_of_id hdid, hdg, hdt, [hdid, x, hdg, (fun c -> c)]) tl in let and_proofid = id_of_string (and_proof_id ^ "_and_proof") in @@ -324,20 +324,20 @@ let and_tac l hook = trace (str "Started and proof"); Pfedit.by and_tac; trace (str "Applied and tac") - -let destruct_ex ext ex = - let rec aux c acc = + +let destruct_ex ext ex = + let rec aux c acc = match kind_of_term c with App (f, args) -> (match kind_of_term f with Ind i when i = Term.destInd (Lazy.force ex_ind) && Array.length args = 2 -> - let (dom, rng) = + let (dom, rng) = try (args.(0), args.(1)) with _ -> assert(false) in let pi1 = (mk_ex_pi1 dom rng acc) in - let rng_body = + let rng_body = match kind_of_term rng with Lambda (_, _, t) -> subst1 pi1 t | t -> rng @@ -348,14 +348,14 @@ let destruct_ex ext ex = in aux ex ext open Rawterm - + let id_of_name = function Name n -> n | Anonymous -> raise (Invalid_argument "id_of_name") let definition_message id = Nameops.pr_id id ++ str " is defined" - + let recursive_message v = match Array.length v with | 0 -> error "no recursive definition" @@ -398,7 +398,7 @@ let rec string_of_list sep f = function | x :: [] -> f x | x :: ((y :: _) as tl) -> f x ^ sep ^ string_of_list sep f tl -let string_of_intset d = +let string_of_intset d = string_of_list "," string_of_int (Intset.elements d) (**********************************************************) @@ -416,20 +416,20 @@ let pr_meta_map evd = | _ -> mt() in let pr_meta_binding = function | (mv,Cltyp (na,b)) -> - hov 0 + hov 0 (pr_meta mv ++ pr_name na ++ str " : " ++ print_constr b.rebus ++ fnl ()) | (mv,Clval(na,b,_)) -> - hov 0 + hov 0 (pr_meta mv ++ pr_name na ++ str " := " ++ print_constr (fst b).rebus ++ fnl ()) in - prlist pr_meta_binding ml + prlist pr_meta_binding ml let pr_idl idl = prlist_with_sep pr_spc pr_id idl let pr_evar_info evi = - let phyps = + let phyps = (*pr_idl (List.rev (ids_of_named_context (evar_context evi))) *) Printer.pr_named_context (Global.env()) (evar_context evi) in @@ -442,7 +442,7 @@ let pr_evar_info evi = hov 2 (str"[" ++ phyps ++ spc () ++ str"|- " ++ pty ++ pb ++ str"]") let pr_evar_defs sigma = - h 0 + h 0 (prlist_with_sep pr_fnl (fun (ev,evi) -> h 0 (str(string_of_existential ev)++str"=="++ pr_evar_info evi)) @@ -454,7 +454,7 @@ let pr_constraints pbs = print_constr t1 ++ spc() ++ str (match pbty with | Reduction.CONV -> "==" - | Reduction.CUMUL -> "<=") ++ + | Reduction.CUMUL -> "<=") ++ spc() ++ print_constr t2) pbs) let pr_evar_defs evd = diff --git a/plugins/subtac/subtac_utils.mli b/plugins/subtac/subtac_utils.mli index dff1df8f96..e7ee6c7483 100644 --- a/plugins/subtac/subtac_utils.mli +++ b/plugins/subtac/subtac_utils.mli @@ -85,7 +85,7 @@ val wf_relations : (constr, constr lazy_t) Hashtbl.t type binders = local_binder list val app_opt : ('a -> 'a) option -> 'a -> 'a val print_args : env -> constr array -> std_ppcmds -val make_existential : loc -> ?opaque:obligation_definition_status -> +val make_existential : loc -> ?opaque:obligation_definition_status -> env -> evar_defs ref -> types -> constr val make_existential_expr : loc -> 'a -> 'b -> constr_expr val string_of_hole_kind : hole_kind -> string @@ -111,7 +111,7 @@ val mk_conj : types list -> types val mk_not : types -> types val build_dependent_sum : (identifier * types) list -> Proof_type.tactic * types -val and_tac : (identifier * 'a * constr * Proof_type.tactic) list -> +val and_tac : (identifier * 'a * constr * Proof_type.tactic) list -> ((constr -> (identifier * 'a * constr * constr) list) -> Tacexpr.declaration_hook) -> unit val destruct_ex : constr -> constr -> constr list diff --git a/plugins/subtac/test/ListDep.v b/plugins/subtac/test/ListDep.v index da612c4367..e3dbd127f9 100644 --- a/plugins/subtac/test/ListDep.v +++ b/plugins/subtac/test/ListDep.v @@ -22,7 +22,7 @@ Section Map_DependentRecursor. Variable l : list U. Variable f : { x : U | In x l } -> V. - Obligations Tactic := unfold sub_list in * ; + Obligations Tactic := unfold sub_list in * ; program_simpl ; intuition. Program Fixpoint map_rec ( l' : list U | sub_list l' l ) @@ -32,16 +32,16 @@ Section Map_DependentRecursor. | cons x tl => let tl' := map_rec tl in f x :: tl' end. - + Next Obligation. destruct_call map_rec. simpl in *. subst l'. simpl ; auto with arith. Qed. - + Program Definition map : list V := map_rec l. - + End Map_DependentRecursor. Extraction map. diff --git a/plugins/subtac/test/ListsTest.v b/plugins/subtac/test/ListsTest.v index 05fc0803fc..2cea0841de 100644 --- a/plugins/subtac/test/ListsTest.v +++ b/plugins/subtac/test/ListsTest.v @@ -7,7 +7,7 @@ Set Implicit Arguments. Section Accessors. Variable A : Set. - Program Definition myhd : forall (l : list A | length l <> 0), A := + Program Definition myhd : forall (l : list A | length l <> 0), A := fun l => match l with | nil => ! @@ -34,22 +34,22 @@ Section app. match l with | nil => l' | hd :: tl => hd :: (tl ++ l') - end + end where "x ++ y" := (app x y). Next Obligation. intros. destruct_call app ; program_simpl. Defined. - + Program Lemma app_id_l : forall l : list A, l = nil ++ l. Proof. simpl ; auto. Qed. - + Program Lemma app_id_r : forall l : list A, l = l ++ nil. Proof. - induction l ; simpl in * ; auto. + induction l ; simpl in * ; auto. rewrite <- IHl ; auto. Qed. @@ -61,7 +61,7 @@ Section Nth. Variable A : Set. - Program Fixpoint nth (l : list A) (n : nat | n < length l) { struct l } : A := + Program Fixpoint nth (l : list A) (n : nat | n < length l) { struct l } : A := match n, l with | 0, hd :: _ => hd | S n', _ :: tl => nth tl n' @@ -70,7 +70,7 @@ Section Nth. Next Obligation. Proof. - simpl in *. auto with arith. + simpl in *. auto with arith. Defined. Next Obligation. @@ -78,7 +78,7 @@ Section Nth. inversion H. Qed. - Program Fixpoint nth' (l : list A) (n : nat | n < length l) { struct l } : A := + Program Fixpoint nth' (l : list A) (n : nat | n < length l) { struct l } : A := match l, n with | hd :: _, 0 => hd | _ :: tl, S n' => nth' tl n' @@ -86,7 +86,7 @@ Section Nth. end. Next Obligation. Proof. - simpl in *. auto with arith. + simpl in *. auto with arith. Defined. Next Obligation. diff --git a/plugins/subtac/test/Mutind.v b/plugins/subtac/test/Mutind.v index ac49ca96a4..01e2d75f33 100644 --- a/plugins/subtac/test/Mutind.v +++ b/plugins/subtac/test/Mutind.v @@ -1,11 +1,11 @@ Require Import List. -Program Fixpoint f a : { x : nat | x > 0 } := +Program Fixpoint f a : { x : nat | x > 0 } := match a with | 0 => 1 | S a' => g a a' end -with g a b : { x : nat | x > 0 } := +with g a b : { x : nat | x > 0 } := match b with | 0 => 1 | S b' => f b' diff --git a/plugins/subtac/test/Test1.v b/plugins/subtac/test/Test1.v index 14b8085496..7e0755d571 100644 --- a/plugins/subtac/test/Test1.v +++ b/plugins/subtac/test/Test1.v @@ -1,4 +1,4 @@ -Program Definition test (a b : nat) : { x : nat | x = a + b } := +Program Definition test (a b : nat) : { x : nat | x = a + b } := ((a + b) : { x : nat | x = a + b }). Proof. intros. diff --git a/plugins/subtac/test/euclid.v b/plugins/subtac/test/euclid.v index 501aa79815..97c3d9414d 100644 --- a/plugins/subtac/test/euclid.v +++ b/plugins/subtac/test/euclid.v @@ -1,12 +1,12 @@ 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 + if le_lt_dec b a then let (q', r) := euclid (a - b) b in (S q' & r) else (O & a). diff --git a/plugins/subtac/test/take.v b/plugins/subtac/test/take.v index 2e17959c3e..90ae8bae84 100644 --- a/plugins/subtac/test/take.v +++ b/plugins/subtac/test/take.v @@ -11,7 +11,7 @@ Print cons. 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 => + | S p => match l with | cons hd tl => let rest := take tl p in cons hd rest | nil => ! diff --git a/plugins/subtac/test/wf.v b/plugins/subtac/test/wf.v index 49fec2b80c..5ccc154afd 100644 --- a/plugins/subtac/test/wf.v +++ b/plugins/subtac/test/wf.v @@ -29,7 +29,7 @@ Require Import Wf_nat. Program Fixpoint euclid (a : nat) (b : { b : nat | b <> O }) {wf a lt} : { 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 + if le_lt_dec b a then let (q', r) := euclid (a - b) b in (S q' & r) else (O & a). destruct b ; simpl_subtac. diff --git a/plugins/syntax/ascii_syntax.ml b/plugins/syntax/ascii_syntax.ml index f9ca94ff6c..f60abaf855 100644 --- a/plugins/syntax/ascii_syntax.ml +++ b/plugins/syntax/ascii_syntax.ml @@ -38,7 +38,7 @@ let glob_Ascii = lazy (make_reference "Ascii") open Lazy let interp_ascii dloc p = - let rec aux n p = + let rec aux n p = if n = 0 then [] else let mp = p mod 2 in RRef (dloc,if mp = 0 then glob_false else glob_true) @@ -46,7 +46,7 @@ let interp_ascii dloc p = RApp (dloc,RRef(dloc,force glob_Ascii), aux 8 p) let interp_ascii_string dloc s = - let p = + let p = if String.length s = 1 then int_of_char s.[0] else if String.length s = 3 & is_digit s.[0] & is_digit s.[1] & is_digit s.[2] @@ -62,12 +62,12 @@ let uninterp_ascii r = | RRef (_,k)::l when k = glob_true -> 1+2*(uninterp_bool_list (n-1) l) | RRef (_,k)::l when k = glob_false -> 2*(uninterp_bool_list (n-1) l) | _ -> raise Non_closed_ascii in - try + try let rec aux = function | RApp (_,RRef (_,k),l) when k = force glob_Ascii -> uninterp_bool_list 8 l | _ -> raise Non_closed_ascii in Some (aux r) - with + with Non_closed_ascii -> None let make_ascii_string n = diff --git a/plugins/syntax/nat_syntax.ml b/plugins/syntax/nat_syntax.ml index c62c813778..5d20c2a3c8 100644 --- a/plugins/syntax/nat_syntax.ml +++ b/plugins/syntax/nat_syntax.ml @@ -33,7 +33,7 @@ open Names let nat_of_int dloc n = if is_pos_or_zero n then begin if less_than (of_string "5000") n then - Flags.if_warn msg_warning + Flags.if_warn msg_warning (strbrk "Stack overflow or segmentation fault happens when " ++ strbrk "working with large numbers in nat (observed threshold " ++ strbrk "may vary from 5000 to 70000 depending on your system " ++ @@ -41,11 +41,11 @@ let nat_of_int dloc n = let ref_O = RRef (dloc, glob_O) in let ref_S = RRef (dloc, glob_S) in let rec mk_nat acc n = - if n <> zero then + if n <> zero then mk_nat (RApp (dloc,ref_S, [acc])) (sub_1 n) - else + else acc - in + in mk_nat ref_O n end else @@ -61,9 +61,9 @@ let rec int_of_nat = function | RApp (_,RRef (_,s),[a]) when s = glob_S -> add_1 (int_of_nat a) | RRef (_,z) when z = glob_O -> zero | _ -> raise Non_closed_number - + let uninterp_nat p = - try + try Some (int_of_nat p) with Non_closed_number -> None diff --git a/plugins/syntax/numbers_syntax.ml b/plugins/syntax/numbers_syntax.ml index 94e4c103a9..e58618219b 100644 --- a/plugins/syntax/numbers_syntax.ml +++ b/plugins/syntax/numbers_syntax.ml @@ -22,7 +22,7 @@ let make_dir l = Names.make_dirpath (List.map Names.id_of_string (List.rev l)) let make_path dir id = Libnames.make_path (make_dir dir) (Names.id_of_string id) (* copied on g_zsyntax.ml, where it is said to be a temporary hack*) -(* takes a path an identifier in the form of a string list and a string, +(* takes a path an identifier in the form of a string list and a string, returns a kernel_name *) let make_kn dir id = Libnames.encode_kn (make_dir dir) (Names.id_of_string id) @@ -50,7 +50,7 @@ let zn2z_WW = ConstructRef ((zn2z_id "zn2z",0),2) let bigN_module = ["Coq"; "Numbers"; "Natural"; "BigN"; "BigN" ] let bigN_path = make_path (bigN_module@["BigN"]) "t" (* big ugly hack *) -let bigN_id id = (Obj.magic ((Names.MPdot ((Names.MPfile (make_dir bigN_module)), +let bigN_id id = (Obj.magic ((Names.MPdot ((Names.MPfile (make_dir bigN_module)), Names.mk_label "BigN")), [], Names.id_of_string id) : Names.kernel_name) let bigN_scope = "bigN_scope" @@ -69,7 +69,7 @@ let bigN_constructor = else 2*(to_int quo) in - fun i -> + fun i -> ConstructRef ((bigN_id "t_",0), if less_than i n_inlined then (to_int i)+1 @@ -81,7 +81,7 @@ let bigN_constructor = let bigZ_module = ["Coq"; "Numbers"; "Integer"; "BigZ"; "BigZ" ] let bigZ_path = make_path (bigZ_module@["BigZ"]) "t" (* big ugly hack bis *) -let bigZ_id id = (Obj.magic ((Names.MPdot ((Names.MPfile (make_dir bigZ_module)), +let bigZ_id id = (Obj.magic ((Names.MPdot ((Names.MPfile (make_dir bigZ_module)), Names.mk_label "BigZ")), [], Names.id_of_string id) : Names.kernel_name) let bigZ_scope = "bigZ_scope" @@ -108,7 +108,7 @@ exception Non_closed (* parses a *non-negative* integer (from bigint.ml) into an int31 wraps modulo 2^31 *) -let int31_of_pos_bigint dloc n = +let int31_of_pos_bigint dloc n = let ref_construct = RRef (dloc, int31_construct) in let ref_0 = RRef (dloc, int31_0) in let ref_1 = RRef (dloc, int31_1) in @@ -124,7 +124,7 @@ let int31_of_pos_bigint dloc n = let error_negative dloc = Util.user_err_loc (dloc, "interp_int31", Pp.str "int31 are only non-negative numbers.") -let interp_int31 dloc n = +let interp_int31 dloc n = if is_pos_or_zero n then int31_of_pos_bigint dloc n else @@ -132,20 +132,20 @@ let interp_int31 dloc n = (* Pretty prints an int31 *) -let bigint_of_int31 = - let rec args_parsing args cur = - match args with +let bigint_of_int31 = + let rec args_parsing args cur = + match args with | [] -> cur | (RRef (_,b))::l when b = int31_0 -> args_parsing l (mult_2 cur) | (RRef (_,b))::l when b = int31_1 -> args_parsing l (add_1 (mult_2 cur)) | _ -> raise Non_closed in - function + function | RApp (_, RRef (_, c), args) when c=int31_construct -> args_parsing args zero | _ -> raise Non_closed -let uninterp_int31 i = - try +let uninterp_int31 i = + try Some (bigint_of_int31 i) with Non_closed -> None @@ -169,12 +169,12 @@ let rank n = pow base (pow two n) (* splits a number bi at height n, that is the rest needs 2^n int31 to be stored it is expected to be used only when the quotient would also need 2^n int31 to be stored *) -let split_at n bi = +let split_at n bi = euclid bi (rank (sub_1 n)) (* search the height of the Coq bigint needed to represent the integer bi *) let height bi = - let rec height_aux n = + let rec height_aux n = if less_than bi (rank n) then n else @@ -199,7 +199,7 @@ let word_of_pos_bigint dloc hght n = decomp (sub_1 hgt) l]) in decomp hght n - + let bigN_of_pos_bigint dloc n = let ref_constructor i = RRef (dloc, bigN_constructor i) in let result h word = RApp (dloc, ref_constructor h, if less_than h n_inlined then @@ -210,11 +210,11 @@ let bigN_of_pos_bigint dloc n = in let hght = height n in result hght (word_of_pos_bigint dloc hght n) - + let bigN_error_negative dloc = Util.user_err_loc (dloc, "interp_bigN", Pp.str "bigN are only non-negative numbers.") -let interp_bigN dloc n = +let interp_bigN dloc n = if is_pos_or_zero n then bigN_of_pos_bigint dloc n else @@ -223,13 +223,13 @@ let interp_bigN dloc n = (* Pretty prints a bigN *) -let bigint_of_word = +let bigint_of_word = let rec get_height rc = match rc with - | RApp (_,RRef(_,c), [_;lft;rght]) when c = zn2z_WW -> + | RApp (_,RRef(_,c), [_;lft;rght]) when c = zn2z_WW -> let hleft = get_height lft in let hright = get_height rght in - add_1 + add_1 (if less_than hleft hright then hright else @@ -248,15 +248,15 @@ let bigint_of_word = fun rc -> let hght = get_height rc in transform hght rc - + let bigint_of_bigN rc = match rc with | RApp (_,_,[one_arg]) -> bigint_of_word one_arg | RApp (_,_,[_;second_arg]) -> bigint_of_word second_arg | _ -> raise Non_closed -let uninterp_bigN rc = - try +let uninterp_bigN rc = + try Some (bigint_of_bigN rc) with Non_closed -> None @@ -266,7 +266,7 @@ let uninterp_bigN rc = numeral interpreter *) let bigN_list_of_constructors = - let rec build i = + let rec build i = if less_than i (add_1 n_inlined) then RRef (Util.dummy_loc, bigN_constructor i)::(build (add_1 i)) else @@ -284,7 +284,7 @@ let _ = Notation.declare_numeral_interpreter bigN_scope (*** Parsing for bigZ in digital notation ***) -let interp_bigZ dloc n = +let interp_bigZ dloc n = let ref_pos = RRef (dloc, bigZ_pos) in let ref_neg = RRef (dloc, bigZ_neg) in if is_pos_or_zero n then @@ -295,8 +295,8 @@ let interp_bigZ dloc n = (* pretty printing functions for bigZ *) let bigint_of_bigZ = function | RApp (_, RRef(_,c), [one_arg]) when c = bigZ_pos -> bigint_of_bigN one_arg - | RApp (_, RRef(_,c), [one_arg]) when c = bigZ_neg -> - let opp_val = bigint_of_bigN one_arg in + | RApp (_, RRef(_,c), [one_arg]) when c = bigZ_neg -> + let opp_val = bigint_of_bigN one_arg in if equal opp_val zero then raise Non_closed else @@ -304,8 +304,8 @@ let bigint_of_bigZ = function | _ -> raise Non_closed -let uninterp_bigZ rc = - try +let uninterp_bigZ rc = + try Some (bigint_of_bigZ rc) with Non_closed -> None @@ -320,7 +320,7 @@ let _ = Notation.declare_numeral_interpreter bigZ_scope true) (*** Parsing for bigQ in digital notation ***) -let interp_bigQ dloc n = +let interp_bigQ dloc n = let ref_z = RRef (dloc, bigQ_z) in let ref_pos = RRef (dloc, bigZ_pos) in let ref_neg = RRef (dloc, bigZ_neg) in diff --git a/plugins/syntax/r_syntax.ml b/plugins/syntax/r_syntax.ml index 4a5972cc71..f85309e671 100644 --- a/plugins/syntax/r_syntax.ml +++ b/plugins/syntax/r_syntax.ml @@ -65,7 +65,7 @@ let r_of_posint dloc n = let r_of_int dloc z = if is_strictly_neg z then - RApp (dloc, RRef(dloc,glob_Ropp), [r_of_posint dloc (neg z)]) + RApp (dloc, RRef(dloc,glob_Ropp), [r_of_posint dloc (neg z)]) else r_of_posint dloc z @@ -90,7 +90,7 @@ let rec bignat_of_pos = function mult_2 (bignat_of_pos b) (* 1+(1+1)*b *) | RApp (_,RRef (_,p1), [RRef (_,o); RApp (_,RRef (_,p2),[a;b])]) - when p1 = glob_Rplus & p2 = glob_Rmult & o = glob_R1 -> + when p1 = glob_Rplus & p2 = glob_Rmult & o = glob_R1 -> if bignat_of_pos a <> two then raise Non_closed_number; add_1 (mult_2 (bignat_of_pos b)) | _ -> raise Non_closed_number diff --git a/plugins/syntax/string_syntax.ml b/plugins/syntax/string_syntax.ml index d1c263dc8c..bc02357aea 100644 --- a/plugins/syntax/string_syntax.ml +++ b/plugins/syntax/string_syntax.ml @@ -38,14 +38,14 @@ open Lazy let interp_string dloc s = let le = String.length s in - let rec aux n = + let rec aux n = if n = le then RRef (dloc, force glob_EmptyString) else RApp (dloc,RRef (dloc, force glob_String), [interp_ascii dloc (int_of_char s.[n]); aux (n+1)]) in aux 0 let uninterp_string r = - try + try let b = Buffer.create 16 in let rec aux = function | RApp (_,RRef (_,k),[a;s]) when k = force glob_String -> @@ -57,13 +57,13 @@ let uninterp_string r = | _ -> raise Non_closed_string in aux r - with + with Non_closed_string -> None let _ = Notation.declare_string_interpreter "string_scope" (string_path,["Coq";"Strings";"String"]) interp_string - ([RRef (dummy_loc,static_glob_String); + ([RRef (dummy_loc,static_glob_String); RRef (dummy_loc,static_glob_EmptyString)], uninterp_string, true) diff --git a/plugins/syntax/z_syntax.ml b/plugins/syntax/z_syntax.ml index bfbe54c28c..a10c76013f 100644 --- a/plugins/syntax/z_syntax.ml +++ b/plugins/syntax/z_syntax.ml @@ -33,7 +33,7 @@ let positive_path = make_path positive_module "positive" (* TODO: temporary hack *) let make_kn dir id = Libnames.encode_kn dir id -let positive_kn = +let positive_kn = make_kn (make_dir positive_module) (id_of_string "positive") let glob_positive = IndRef (positive_kn,0) let path_of_xI = ((positive_kn,0),1) @@ -52,10 +52,10 @@ let pos_of_bignat dloc x = | (q,false) -> RApp (dloc, ref_xO,[pos_of q]) | (q,true) when q <> zero -> RApp (dloc,ref_xI,[pos_of q]) | (q,true) -> ref_xH - in + in pos_of x -let error_non_positive dloc = +let error_non_positive dloc = user_err_loc (dloc, "interp_positive", str "Only strictly positive numbers in type \"positive\".") @@ -74,9 +74,9 @@ let rec bignat_of_pos = function | _ -> raise Non_closed_number let uninterp_positive p = - try + try Some (bignat_of_pos p) - with Non_closed_number -> + with Non_closed_number -> None (************************************************************************) @@ -87,7 +87,7 @@ let _ = Notation.declare_numeral_interpreter "positive_scope" (positive_path,positive_module) interp_positive ([RRef (dummy_loc, glob_xI); - RRef (dummy_loc, glob_xO); + RRef (dummy_loc, glob_xO); RRef (dummy_loc, glob_xH)], uninterp_positive, true) @@ -106,10 +106,10 @@ let glob_Npos = ConstructRef path_of_Npos let n_path = make_path binnat_module "N" -let n_of_binnat dloc pos_or_neg n = +let n_of_binnat dloc pos_or_neg n = if n <> zero then RApp(dloc, RRef (dloc,glob_Npos), [pos_of_bignat dloc n]) - else + else RRef (dloc, glob_N0) let error_negative dloc = @@ -138,11 +138,11 @@ let uninterp_n p = let _ = Notation.declare_numeral_interpreter "N_scope" (n_path,binnat_module) n_of_int - ([RRef (dummy_loc, glob_N0); + ([RRef (dummy_loc, glob_N0); RRef (dummy_loc, glob_Npos)], uninterp_n, true) - + (**********************************************************************) (* Parsing Z via scopes *) (**********************************************************************) @@ -158,12 +158,12 @@ let glob_ZERO = ConstructRef path_of_ZERO let glob_POS = ConstructRef path_of_POS let glob_NEG = ConstructRef path_of_NEG -let z_of_int dloc n = +let z_of_int dloc n = if n <> zero then let sgn, n = if is_pos_or_zero n then glob_POS, n else glob_NEG, Bigint.neg n in RApp(dloc, RRef (dloc,sgn), [pos_of_bignat dloc n]) - else + else RRef (dloc, glob_ZERO) (**********************************************************************) @@ -187,8 +187,8 @@ let uninterp_z p = let _ = Notation.declare_numeral_interpreter "Z_scope" (z_path,binint_module) z_of_int - ([RRef (dummy_loc, glob_ZERO); - RRef (dummy_loc, glob_POS); + ([RRef (dummy_loc, glob_ZERO); + RRef (dummy_loc, glob_POS); RRef (dummy_loc, glob_NEG)], uninterp_z, true) diff --git a/plugins/xml/acic.ml b/plugins/xml/acic.ml index 032ddbebe0..40bc61bb80 100644 --- a/plugins/xml/acic.ml +++ b/plugins/xml/acic.ml @@ -56,7 +56,7 @@ type obj = | InductiveDefinition of inductiveType list * (* inductive types , *) params * int (* parameters,n ind. pars*) -and inductiveType = +and inductiveType = identifier * bool * constr * (* typename, inductive, arity *) constructor list (* constructors *) and constructor = @@ -78,9 +78,9 @@ type aconstr = | ACase of id * uri * int * aconstr * aconstr * aconstr list | AFix of id * int * ainductivefun list | ACoFix of id * int * acoinductivefun list -and ainductivefun = +and ainductivefun = id * identifier * int * aconstr * aconstr -and acoinductivefun = +and acoinductivefun = id * identifier * aconstr * aconstr and explicit_named_substitution = id option * (uri * aconstr) list @@ -101,7 +101,7 @@ type aobj = | AInductiveDefinition of id * anninductiveType list * (* inductive types , *) params * int (* parameters,n ind. pars*) -and anninductiveType = +and anninductiveType = id * identifier * bool * aconstr * (* typename, inductive, arity *) annconstructor list (* constructors *) and annconstructor = diff --git a/plugins/xml/acic2Xml.ml4 b/plugins/xml/acic2Xml.ml4 index 64dc8a0503..fb40ed86e8 100644 --- a/plugins/xml/acic2Xml.ml4 +++ b/plugins/xml/acic2Xml.ml4 @@ -44,7 +44,7 @@ let print_term ids_to_inner_sorts = X.xml_empty "VAR" ["uri", uri ; "id",id ; "sort",sort] | A.AEvar (id,n,l) -> let sort = Hashtbl.find ids_to_inner_sorts id in - X.xml_nempty "META" + X.xml_nempty "META" ["no",(export_existential n) ; "id",id ; "sort",sort] (List.fold_left (fun i t -> diff --git a/plugins/xml/cic2Xml.ml b/plugins/xml/cic2Xml.ml index 08d3a85010..981503a663 100644 --- a/plugins/xml/cic2Xml.ml +++ b/plugins/xml/cic2Xml.ml @@ -6,7 +6,7 @@ let print_xml_term ch env sigma cic = let ids_to_inner_types = Hashtbl.create 503 in let seed = ref 0 in let acic = - Cic2acic.acic_of_cic_context' true seed ids_to_terms constr_to_ids + Cic2acic.acic_of_cic_context' true seed ids_to_terms constr_to_ids ids_to_father_ids ids_to_inner_sorts ids_to_inner_types env [] sigma (Unshare.unshare cic) None in let xml = Acic2Xml.print_term ids_to_inner_sorts acic in diff --git a/plugins/xml/cic2acic.ml b/plugins/xml/cic2acic.ml index 1ac022159a..5bb7635b9d 100644 --- a/plugins/xml/cic2acic.ml +++ b/plugins/xml/cic2acic.ml @@ -22,12 +22,12 @@ let get_module_path_of_full_path path = List.filter (function modul -> Libnames.is_dirpath_prefix_of modul dirpath) modules with - [] -> + [] -> Pp.warning ("Modules not supported: reference to "^ Libnames.string_of_path path^" will be wrong"); dirpath | [modul] -> modul - | _ -> + | _ -> raise TwoModulesWhoseDirPathIsOneAPrefixOfTheOther ;; @@ -134,7 +134,7 @@ let token_list_of_kernel_name ~keep_sections kn tag = else let module_path = let f = N.string_of_id (N.id_of_msid self) in - let _,longf = + let _,longf = System.find_file_in_path (Library.get_load_path ()) (f^".v") in let ldir0 = Library.find_logical_path (Filename.dirname longf) in let id = Names.id_of_string (Filename.basename f) in @@ -159,9 +159,9 @@ let token_list_of_kernel_name tag = let module N = Names in let module LN = Libnames in let id,dir = match tag with - | Variable kn -> + | Variable kn -> N.id_of_label (N.label kn), Lib.cwd () - | Constant con -> + | Constant con -> N.id_of_label (N.con_label con), Lib.remove_section_part (LN.ConstRef con) | Inductive kn -> @@ -211,7 +211,7 @@ module CPropRetyping = | T.Prod (na,c1,c2) -> subst_type env sigma (T.subst1 h c2) rest | _ -> Util.anomaly "Non-functional construction" - + let sort_of_atomic_type env sigma ft args = let rec concl_of_arity env ar = match T.kind_of_term (DoubleTypeInference.whd_betadeltaiotacprop env sigma ar) with @@ -219,7 +219,7 @@ module CPropRetyping = | T.Sort s -> Coq_sort (T.family_of_sort s) | _ -> outsort env sigma (subst_type env sigma ft (Array.to_list args)) in concl_of_arity env ft - + let typeur sigma metamap = let rec type_of env cstr= match Term.kind_of_term cstr with @@ -265,7 +265,7 @@ let typeur sigma metamap = | Coq_sort T.InSet -> T.mkSet | Coq_sort T.InType -> T.mkType Univ.type1_univ (* ERROR HERE *) | CProp -> T.mkConst DoubleTypeInference.cprop - + and sort_of env t = match Term.kind_of_term t with | T.Cast (c,_, s) when T.isSort s -> family_of_term s @@ -287,7 +287,7 @@ let typeur sigma metamap = | T.Lambda _ | T.Fix _ | T.Construct _ -> Util.anomaly "sort_of: Not a type (1)" | _ -> outsort env sigma (type_of env t) - + and sort_family_of env t = match T.kind_of_term t with | T.Cast (c,_, s) when T.isSort s -> family_of_term s @@ -299,7 +299,7 @@ let typeur sigma metamap = | T.Lambda _ | T.Fix _ | T.Construct _ -> Util.anomaly "sort_of: Not a type (1)" | _ -> outsort env sigma (type_of env t) - + in type_of, sort_of, sort_family_of let get_type_of env sigma c = let f,_,_ = typeur sigma [] in f env c @@ -484,7 +484,7 @@ print_endline "PASSATO" ; flush stdout ; (* an explicit named substitution of "type" *) (* (variable * argument) list, whose *) (* second element is the list of residual *) - (* arguments and whose third argument is *) + (* arguments and whose third argument is *) (* the list of uninstantiated variables *) let rec get_explicit_subst variables arguments = match variables,arguments with @@ -497,7 +497,7 @@ print_endline "PASSATO" ; flush stdout ; let he1'' = String.concat "/" (List.map Names.string_of_id (List.rev he1')) ^ "/" - ^ (Names.string_of_id he1_id) ^ ".var" + ^ (Names.string_of_id he1_id) ^ ".var" in (he1'',he2)::subst, extra_args, uninst in @@ -528,7 +528,7 @@ print_endline "PASSATO" ; flush stdout ; in (* Now that we have all the auxiliary functions we *) - (* can finally proceed with the main case analysis. *) + (* can finally proceed with the main case analysis. *) match T.kind_of_term tt with T.Rel n -> let id = diff --git a/plugins/xml/doubleTypeInference.ml b/plugins/xml/doubleTypeInference.ml index 17d1d5dab4..f8921aec9e 100644 --- a/plugins/xml/doubleTypeInference.ml +++ b/plugins/xml/doubleTypeInference.ml @@ -69,12 +69,12 @@ let double_type_of env sigma cstr expectedty subterms_to_types = T.Meta n -> Util.error "DoubleTypeInference.double_type_of: found a non-instanciated goal" - + | T.Evar ((n,l) as ev) -> let ty = Unshare.unshare (Evd.existential_type sigma ev) in let jty = execute env sigma ty None in let jty = assumption_of_judgment env sigma jty in - let evar_context = + let evar_context = E.named_context_of_val (Evd.find sigma n).Evd.evar_hyps in let rec iter actual_args evar_context = match actual_args,evar_context with @@ -96,25 +96,25 @@ let double_type_of env sigma cstr expectedty subterms_to_types = (* for side effects only *) iter (List.rev (Array.to_list l)) (List.rev evar_context) ; E.make_judge cstr jty - - | T.Rel n -> + + | T.Rel n -> Typeops.judge_of_relative env n - | T.Var id -> + | T.Var id -> Typeops.judge_of_variable env id - + | T.Const c -> E.make_judge cstr (Typeops.type_of_constant env c) - + | T.Ind ind -> E.make_judge cstr (Inductiveops.type_of_inductive env ind) - - | T.Construct cstruct -> + + | T.Construct cstruct -> E.make_judge cstr (Inductiveops.type_of_constructor env cstruct) - + | T.Case (ci,p,c,lf) -> let expectedtype = - Reduction.whd_betadeltaiota env (Retyping.get_type_of env sigma c) in + Reduction.whd_betadeltaiota env (Retyping.get_type_of env sigma c) in let cj = execute env sigma c (Some expectedtype) in let pj = execute env sigma p None in let (expectedtypes,_,_) = @@ -126,18 +126,18 @@ let double_type_of env sigma cstr expectedty subterms_to_types = (Array.map (function x -> Some x) expectedtypes) in let (j,_) = Typeops.judge_of_case env ci pj cj lfj in j - + | T.Fix ((vn,i as vni),recdef) -> let (_,tys,_ as recdef') = execute_recdef env sigma recdef in let fix = (vni,recdef') in E.make_judge (T.mkFix fix) tys.(i) - + | T.CoFix (i,recdef) -> let (_,tys,_ as recdef') = execute_recdef env sigma recdef in let cofix = (i,recdef') in E.make_judge (T.mkCoFix cofix) tys.(i) - - | T.Sort (T.Prop c) -> + + | T.Sort (T.Prop c) -> Typeops.judge_of_prop_contents c | T.Sort (T.Type u) -> @@ -153,8 +153,8 @@ let double_type_of env sigma cstr expectedty subterms_to_types = ) | T.App (f,args) -> - let expected_head = - Reduction.whd_betadeltaiota env (Retyping.get_type_of env sigma f) in + let expected_head = + Reduction.whd_betadeltaiota env (Retyping.get_type_of env sigma f) in let j = execute env sigma f (Some expected_head) in let expected_args = let rec aux typ = @@ -172,8 +172,8 @@ let double_type_of env sigma cstr expectedty subterms_to_types = let jl = execute_array env sigma args expected_args in let (j,_) = Typeops.judge_of_apply env j jl in j - - | T.Lambda (name,c1,c2) -> + + | T.Lambda (name,c1,c2) -> let j = execute env sigma c1 None in let var = type_judgment env sigma j in let env1 = E.push_rel (name,None,var.E.utj_val) env in @@ -186,9 +186,9 @@ let double_type_of env sigma cstr expectedty subterms_to_types = Some (Reductionops.nf_beta sigma expected_target_type) | _ -> assert false in - let j' = execute env1 sigma c2 expectedc2type in + let j' = execute env1 sigma c2 expectedc2type in Typeops.judge_of_abstraction env1 name var j' - + | T.Prod (name,c1,c2) -> let j = execute env sigma c1 None in let varj = type_judgment env sigma j in @@ -212,7 +212,7 @@ let double_type_of env sigma cstr expectedty subterms_to_types = in let j3 = execute env1 sigma c3 None in Typeops.judge_of_letin env name j1 j2 j3 - + | T.Cast (c,k,t) -> let cj = execute env sigma c (Some (Reductionops.nf_beta sigma t)) in let tj = execute env sigma t None in diff --git a/plugins/xml/doubleTypeInference.mli b/plugins/xml/doubleTypeInference.mli index 2e14b5580b..b604ec4c4c 100644 --- a/plugins/xml/doubleTypeInference.mli +++ b/plugins/xml/doubleTypeInference.mli @@ -12,7 +12,7 @@ (* http://helm.cs.unibo.it *) (************************************************************************) -type types = { synthesized : Term.types; expected : Term.types option; } +type types = { synthesized : Term.types; expected : Term.types option; } val cprop : Names.constant diff --git a/plugins/xml/dumptree.ml4 b/plugins/xml/dumptree.ml4 index 407f86b363..82e90876de 100644 --- a/plugins/xml/dumptree.ml4 +++ b/plugins/xml/dumptree.ml4 @@ -42,7 +42,7 @@ let thin_sign osign sign = ;; let pr_tactic_xml = function - | TacArg (Tacexp t) -> str "<tactic cmd=\"" ++ xmlstream (Pptactic.pr_glob_tactic (Global.env()) t) ++ str "\"/>" + | 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 "\"/>" ;; @@ -68,10 +68,10 @@ let pr_rule_xml pr = function let pr_var_decl_xml env (id,c,typ) = let ptyp = print_constr_env env typ in match c with - | None -> + | None -> (str "<hyp id=\"" ++ xmlstream (pr_id id) ++ str "\" type=\"" ++ xmlstream ptyp ++ str "\"/>") | Some c -> - (* Force evaluation *) + (* 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 "\"/>") @@ -81,7 +81,7 @@ let pr_rel_decl_xml env (na,c,typ) = let pbody = match c with | None -> mt () | Some c -> - (* Force evaluation *) + (* Force evaluation *) let pb = print_constr_env env c in (str" body=\"" ++ xmlstream pb ++ str "\"") in let ptyp = print_constr_env env typ in @@ -108,8 +108,8 @@ let pr_context_xml 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) ++ + 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) @@ -124,7 +124,7 @@ let pr_goal_xml g = (pr_context_xml env)) ++ fnl () ++ str "</goal>") else - (hov 2 (str "<goal type=\"declarative\">" ++ + (hov 2 (str "<goal type=\"declarative\">" ++ (pr_context_xml env)) ++ fnl () ++ str "</goal>") ;; @@ -140,13 +140,13 @@ let rec print_proof_xml sigma osign pf = (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 +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 + [ "Dump" "Tree" ] -> [ print_proof_xml () ] +END diff --git a/plugins/xml/proof2aproof.ml b/plugins/xml/proof2aproof.ml index f7524671fd..1beabf26ca 100644 --- a/plugins/xml/proof2aproof.ml +++ b/plugins/xml/proof2aproof.ml @@ -63,8 +63,8 @@ let nf_evar sigma ~preserve = (* Warning: statuses, goals, prim_rules and tactic_exprs are not unshared! *) let rec unshare_proof_tree = let module PT = Proof_type in - function {PT.open_subgoals = status ; - PT.goal = goal ; + function {PT.open_subgoals = status ; + PT.goal = goal ; PT.ref = ref} -> let unshared_ref = match ref with @@ -78,8 +78,8 @@ let rec unshare_proof_tree = in Some (unshared_rule, List.map unshare_proof_tree pfs) in - {PT.open_subgoals = status ; - PT.goal = goal ; + {PT.open_subgoals = status ; + PT.goal = goal ; PT.ref = unshared_ref} ;; @@ -105,13 +105,13 @@ let extract_open_proof sigma pf = match node with {PT.ref=Some(PT.Prim _,_)} as pf -> L.prim_extractor proof_extractor vl pf - + | {PT.ref=Some(PT.Nested (_,hidden_proof),spfl)} -> let sgl,v = Refiner.frontier hidden_proof in let flat_proof = v spfl in ProofTreeHash.add proof_tree_to_flattened_proof_tree node flat_proof ; proof_extractor vl flat_proof - + | {PT.ref=None;PT.goal=goal} -> let visible_rels = Util.map_succeed @@ -124,14 +124,14 @@ let extract_open_proof sigma pf = (*CSC: it becomes a Rel; otherwise a Var. Then it can be already used *) (*CSC: as the evar_instance. Ordering the instance becomes useless (it *) (*CSC: will already be ordered. *) - (Termops.ids_of_named_context + (Termops.ids_of_named_context (Environ.named_context_of_val goal.Evd.evar_hyps)) in let sorted_rels = Sort.list (fun (n1,_) (n2,_) -> n1 < n2 ) visible_rels in let context = - let l = + let l = List.map - (fun (_,id) -> Sign.lookup_named id + (fun (_,id) -> Sign.lookup_named id (Environ.named_context_of_val goal.Evd.evar_hyps)) sorted_rels in Environ.val_of_named_context l @@ -144,7 +144,7 @@ let extract_open_proof sigma pf = evar_instance in evd := evd' ; evar - + | _ -> Util.anomaly "Bug : a case has been forgotten in proof_extractor" in let unsharedconstr = diff --git a/plugins/xml/proofTree2Xml.ml4 b/plugins/xml/proofTree2Xml.ml4 index 7503d6328a..3f1e0a630b 100644 --- a/plugins/xml/proofTree2Xml.ml4 +++ b/plugins/xml/proofTree2Xml.ml4 @@ -45,7 +45,7 @@ let constr_to_xml obj sigma env = let rel_context = Sign.push_named_to_rel_context named_context' [] in let rel_env = Environ.push_rel_context rel_context - (Environ.reset_with_named_context + (Environ.reset_with_named_context (Environ.val_of_named_context real_named_context) env) in let obj' = Term.subst_vars (List.map (function (i,_,_) -> i) named_context') obj in @@ -149,7 +149,7 @@ Pp.ppnl (Pp.(++) (Pp.str Proof2aproof.ProofTreeHash.find proof_tree_to_flattened_proof_tree node in begin match tactic_expr with - | T.TacArg (T.Tacexp _) -> + | T.TacArg (T.Tacexp _) -> (* We don't need to keep the level of abstraction introduced at *) (* user-level invocation of tactic... (see Tacinterp.hide_interp)*) aux flat_proof old_hyps @@ -189,7 +189,7 @@ Pp.ppnl (Pp.(++) (Pp.str end | {PT.ref=Some((PT.Nested(PT.Proof_instr (_,_),_)|PT.Decl_proof _),nodes)} -> - Util.anomaly "Not Implemented" + Util.anomaly "Not Implemented" | {PT.ref=Some(PT.Daimon,_)} -> X.xml_empty "Hidden_open_goal" of_attribute diff --git a/plugins/xml/xmlcommand.ml b/plugins/xml/xmlcommand.ml index 4a27c3247d..a46500b89c 100644 --- a/plugins/xml/xmlcommand.ml +++ b/plugins/xml/xmlcommand.ml @@ -38,7 +38,7 @@ let print_if_verbose s = if !verbose then print_string s;; (* Next exception is used only inside print_coq_object and tag_of_string_tag *) exception Uninteresting;; -(* NOT USED anymore, we back to the V6 point of view with global parameters +(* NOT USED anymore, we back to the V6 point of view with global parameters (* Internally, for Coq V7, params of inductive types are associated *) (* not to the whole block of mutual inductive (as it was in V6) but to *) @@ -106,7 +106,7 @@ let filter_params pvars hyps = aux (Names.repr_dirpath modulepath) (List.rev pvars) ;; -type variables_type = +type variables_type = Definition of string * Term.constr * Term.types | Assumption of string * Term.constr ;; @@ -246,7 +246,7 @@ let find_hyps t = match T.kind_of_term t with T.Var id when not (List.mem id l) -> let (_,bo,ty) = Global.lookup_named id in - let boids = + let boids = match bo with Some bo' -> aux l bo' | None -> l @@ -393,7 +393,7 @@ let mk_inductive_obj sp mib packs variables nparams hyps finite = (* The current channel for .theory files *) let theory_buffer = Buffer.create 4000;; -let theory_output_string ?(do_not_quote = false) s = +let theory_output_string ?(do_not_quote = false) s = (* prepare for coqdoc post-processing *) let s = if do_not_quote then s else "(** #"^s^"\n#*)\n" in print_if_verbose s; @@ -423,7 +423,7 @@ let kind_of_variable id = | _ -> Util.anomaly "Unsupported variable kind" ;; -let kind_of_constant kn = +let kind_of_constant kn = let module DK = Decl_kinds in match Decls.constant_kind kn with | DK.IsAssumption DK.Definitional -> "AXIOM","Declaration" @@ -432,7 +432,7 @@ let kind_of_constant kn = Pp.warning "Conjecture not supported in dtd (used Declaration instead)"; "AXIOM","Declaration" | DK.IsDefinition DK.Definition -> "DEFINITION","Definition" - | DK.IsDefinition DK.Example -> + | DK.IsDefinition DK.Example -> Pp.warning "Example not supported in dtd (used Definition instead)"; "DEFINITION","Definition" | DK.IsDefinition DK.Coercion -> @@ -461,10 +461,10 @@ let kind_of_constant kn = "DEFINITION","Definition" | DK.IsDefinition DK.Instance -> Pp.warning "Instance not supported in dtd (used Definition instead)"; - "DEFINITION","Definition" + "DEFINITION","Definition" | DK.IsDefinition DK.Method -> Pp.warning "Method not supported in dtd (used Definition instead)"; - "DEFINITION","Definition" + "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 _ -> @@ -476,7 +476,7 @@ let kind_of_global r = let module Ln = Libnames in let module DK = Decl_kinds in match r with - | Ln.IndRef kn | Ln.ConstructRef (kn,_) -> + | Ln.IndRef kn | Ln.ConstructRef (kn,_) -> let isrecord = try let _ = Recordops.lookup_projections kn in true with Not_found -> false in @@ -515,7 +515,7 @@ let print internal glob_ref kind xml_library_root = match glob_ref with Ln.VarRef id -> (* this kn is fake since it is not provided by Coq *) - let kn = + let kn = let (mod_path,dir_path) = Lib.current_prefix () in N.make_kn mod_path dir_path (N.label_of_id id) in @@ -615,13 +615,13 @@ let _ = (function (internal,kn) -> match !proof_to_export with None -> - print internal (Libnames.ConstRef kn) (kind_of_constant kn) + print internal (Libnames.ConstRef kn) (kind_of_constant kn) xml_library_root | Some pftreestate -> (* It is a proof. Let's export it starting from the proof-tree *) (* I saved in the Pfedit.set_xml_cook_proof callback. *) let fn = filename_of_path xml_library_root (Cic2acic.Constant kn) in - show_pftreestate internal fn pftreestate + show_pftreestate internal fn pftreestate (Names.id_of_label (Names.con_label kn)) ; proof_to_export := None) ;; @@ -629,7 +629,7 @@ let _ = let _ = Declare.set_xml_declare_inductive (function (isrecord,(sp,kn)) -> - print false (Libnames.IndRef (kn,0)) (kind_of_inductive isrecord kn) + print false (Libnames.IndRef (kn,0)) (kind_of_inductive isrecord kn) xml_library_root) ;; @@ -664,7 +664,7 @@ let _ = Buffer.output_buffer ch theory_buffer ; close_out ch end ; - Option.iter + Option.iter (fun fn -> let coqdoc = Filename.concat (Envars.coqbin ()) ("coqdoc" ^ Coq_config.exec_extension) in let options = " --html -s --body-only --no-index --latin1 --raw-comments" in @@ -684,7 +684,7 @@ let _ = let _ = Lexer.set_xml_output_comment (theory_output_string ~do_not_quote:true) ;; let uri_of_dirpath dir = - "/" ^ String.concat "/" + "/" ^ String.concat "/" (List.map Names.string_of_id (List.rev (Names.repr_dirpath dir))) ;; @@ -702,7 +702,7 @@ let _ = let _ = Library.set_xml_require - (fun d -> theory_output_string + (fun d -> theory_output_string (Printf.sprintf "<b>Require</b> <a helm:helm_link=\"href\" href=\"theory:%s.theory\">%s</a>.<br/>" (uri_of_dirpath d) (Names.string_of_dirpath d))) ;; |