diff --git a/src/FOLP/simp.ML b/src/FOLP/simp.ML --- a/src/FOLP/simp.ML +++ b/src/FOLP/simp.ML @@ -1,593 +1,593 @@ (* Title: FOLP/simp.ML Author: Tobias Nipkow Copyright 1993 University of Cambridge FOLP version of... Generic simplifier, suitable for most logics. (from Provers) This version allows instantiation of Vars in the subgoal, since the proof term must change. *) signature SIMP_DATA = sig val case_splits : (thm * string) list val dest_red : term -> term * term * term val mk_rew_rules : thm -> thm list val norm_thms : (thm*thm) list (* [(?x>>norm(?x), norm(?x)>>?x), ...] *) val red1 : thm (* ?P>>?Q ==> ?P ==> ?Q *) val red2 : thm (* ?P>>?Q ==> ?Q ==> ?P *) val refl_thms : thm list val subst_thms : thm list (* [ ?a>>?b ==> ?P(?a) ==> ?P(?b), ...] *) val trans_thms : thm list end; infix 4 addcongs delrews delcongs setauto; signature SIMP = sig type simpset val empty_ss : simpset val addcongs : simpset * thm list -> simpset val addrew : Proof.context -> thm -> simpset -> simpset val delcongs : simpset * thm list -> simpset val delrews : simpset * thm list -> simpset val dest_ss : simpset -> thm list * thm list val print_ss : Proof.context -> simpset -> unit val setauto : simpset * (Proof.context -> int -> tactic) -> simpset val ASM_SIMP_CASE_TAC : Proof.context -> simpset -> int -> tactic val ASM_SIMP_TAC : Proof.context -> simpset -> int -> tactic val CASE_TAC : Proof.context -> simpset -> int -> tactic val SIMP_CASE2_TAC : Proof.context -> simpset -> int -> tactic val SIMP_THM : Proof.context -> simpset -> thm -> thm val SIMP_TAC : Proof.context -> simpset -> int -> tactic val SIMP_CASE_TAC : Proof.context -> simpset -> int -> tactic val mk_congs : Proof.context -> string list -> thm list val mk_typed_congs : Proof.context -> (string * string) list -> thm list (* temporarily disabled: val extract_free_congs : unit -> thm list *) val tracing : bool Unsynchronized.ref end; functor SimpFun (Simp_data: SIMP_DATA) : SIMP = struct local open Simp_data in (*For taking apart reductions into left, right hand sides*) val lhs_of = #2 o dest_red; val rhs_of = #3 o dest_red; (*** Indexing and filtering of theorems ***) fun eq_brl ((b1 : bool, th1), (b2, th2)) = b1 = b2 andalso Thm.eq_thm_prop (th1, th2); (*insert a thm in a discrimination net by its lhs*) fun lhs_insert_thm th net = Net.insert_term eq_brl (lhs_of (Thm.concl_of th), (false,th)) net handle Net.INSERT => net; (*match subgoal i against possible theorems in the net. Similar to match_from_nat_tac, but the net does not contain numbers; rewrite rules are not ordered.*) fun net_tac ctxt net = SUBGOAL(fn (prem, i) => resolve_tac ctxt (Net.unify_term net (Logic.strip_assums_concl prem)) i); (*match subgoal i against possible theorems indexed by lhs in the net*) fun lhs_net_tac ctxt net = SUBGOAL(fn (prem,i) => biresolve_tac ctxt (Net.unify_term net (lhs_of (Logic.strip_assums_concl prem))) i); fun nth_subgoal i thm = nth (Thm.prems_of thm) (i - 1); fun goal_concl i thm = Logic.strip_assums_concl (nth_subgoal i thm); fun lhs_of_eq i thm = lhs_of(goal_concl i thm) and rhs_of_eq i thm = rhs_of(goal_concl i thm); fun var_lhs(thm,i) = let fun var(Var _) = true | var(Abs(_,_,t)) = var t | var(f$_) = var f | var _ = false; in var(lhs_of_eq i thm) end; fun contains_op opns = let fun contains(Const(s,_)) = member (op =) opns s | contains(s$t) = contains s orelse contains t | contains(Abs(_,_,t)) = contains t | contains _ = false; in contains end; fun may_match(match_ops,i) = contains_op match_ops o lhs_of_eq i; val (normI_thms,normE_thms) = split_list norm_thms; (*Get the norm constants from norm_thms*) val norms = let fun norm thm = case lhs_of (Thm.concl_of thm) of Const(n,_)$_ => n | _ => error "No constant in lhs of a norm_thm" in map norm normE_thms end; fun lhs_is_NORM(thm,i) = case lhs_of_eq i thm of Const(s,_)$_ => member (op =) norms s | _ => false; fun refl_tac ctxt = resolve_tac ctxt refl_thms; fun find_res thms thm = let fun find [] = error "Check Simp_Data" | find(th::thms) = thm RS th handle THM _ => find thms in find thms end; val mk_trans = find_res trans_thms; fun mk_trans2 thm = let fun mk[] = error"Check transitivity" | mk(t::ts) = (thm RSN (2,t)) handle THM _ => mk ts in mk trans_thms end; (*Applies tactic and returns the first resulting state, FAILS if none!*) fun one_result(tac,thm) = case Seq.pull(tac thm) of SOME(thm',_) => thm' | NONE => raise THM("Simplifier: could not continue", 0, [thm]); fun res1 ctxt (thm,thms,i) = one_result (resolve_tac ctxt thms i,thm); (**** Adding "NORM" tags ****) (*get name of the constant from conclusion of a congruence rule*) fun cong_const cong = case head_of (lhs_of (Thm.concl_of cong)) of Const(c,_) => c | _ => "" (*a placeholder distinct from const names*); (*true if the term is an atomic proposition (no ==> signs) *) val atomic = null o Logic.strip_assums_hyp; (*ccs contains the names of the constants possessing congruence rules*) fun add_hidden_vars ccs = let fun add_hvars tm hvars = case tm of Abs(_,_,body) => Misc_Legacy.add_term_vars(body,hvars) | _$_ => let val (f,args) = strip_comb tm in case f of Const(c,_) => if member (op =) ccs c then fold_rev add_hvars args hvars else Misc_Legacy.add_term_vars (tm, hvars) | _ => Misc_Legacy.add_term_vars (tm, hvars) end | _ => hvars; in add_hvars end; fun add_new_asm_vars new_asms = let fun itf (tm, at) vars = if at then vars else Misc_Legacy.add_term_vars(tm,vars) fun add_list(tm,al,vars) = let val (_,tml) = strip_comb tm in if length(tml)=length(al) then fold_rev itf (tml ~~ al) vars else vars end fun add_vars (tm,vars) = case tm of Abs (_,_,body) => add_vars(body,vars) | r$s => (case head_of tm of Const(c,_) => (case AList.lookup (op =) new_asms c of NONE => add_vars(r,add_vars(s,vars)) | SOME(al) => add_list(tm,al,vars)) | _ => add_vars(r,add_vars(s,vars))) | _ => vars in add_vars end; fun add_norms ctxt (congs,ccs,new_asms) thm = let val thm' = mk_trans2 thm; (* thm': [?z -> l; Prems; r -> ?t] ==> ?z -> ?t *) val nops = Thm.nprems_of thm' val lhs = rhs_of_eq 1 thm' val rhs = lhs_of_eq nops thm' val asms = tl(rev(tl(Thm.prems_of thm'))) val hvars = fold_rev (add_hidden_vars ccs) (lhs::rhs::asms) [] val hvars = add_new_asm_vars new_asms (rhs,hvars) fun it_asms asm hvars = if atomic asm then add_new_asm_vars new_asms (asm,hvars) else Misc_Legacy.add_term_frees(asm,hvars) val hvars = fold_rev it_asms asms hvars val hvs = map (#1 o dest_Var) hvars fun norm_step_tac st = st |> (case head_of(rhs_of_eq 1 st) of Var(ixn,_) => if member (op =) hvs ixn then refl_tac ctxt 1 else resolve_tac ctxt normI_thms 1 ORELSE refl_tac ctxt 1 | Const _ => resolve_tac ctxt normI_thms 1 ORELSE resolve_tac ctxt congs 1 ORELSE refl_tac ctxt 1 | Free _ => resolve_tac ctxt congs 1 ORELSE refl_tac ctxt 1 | _ => refl_tac ctxt 1) val add_norm_tac = DEPTH_FIRST (has_fewer_prems nops) norm_step_tac val SOME(thm'',_) = Seq.pull(add_norm_tac thm') in thm'' end; fun add_norm_tags ctxt congs = let val ccs = map cong_const congs val new_asms = filter (exists not o #2) (ccs ~~ (map (map atomic o Thm.prems_of) congs)); in add_norms ctxt (congs,ccs,new_asms) end; fun normed_rews ctxt congs = let val add_norms = add_norm_tags ctxt congs fun normed thm = let val ctxt' = Variable.declare_thm thm ctxt; in Variable.tradeT (K (map (add_norms o mk_trans) o maps mk_rew_rules)) ctxt [thm] end in normed end; fun NORM ctxt norm_lhs_tac = EVERY' [resolve_tac ctxt [red2], norm_lhs_tac, refl_tac ctxt]; val trans_norms = map mk_trans normE_thms; (* SIMPSET *) datatype simpset = SS of {auto_tac: Proof.context -> int -> tactic, congs: thm list, cong_net: thm Net.net, mk_simps: Proof.context -> thm -> thm list, simps: (thm * thm list) list, simp_net: thm Net.net} val empty_ss = SS{auto_tac= K (K no_tac), congs=[], cong_net=Net.empty, mk_simps = fn ctxt => normed_rews ctxt [], simps=[], simp_net=Net.empty}; (** Insertion of congruences and rewrites **) (*insert a thm in a thm net*) fun insert_thm th net = Net.insert_term Thm.eq_thm_prop (Thm.concl_of th, th) net handle Net.INSERT => net; val insert_thms = fold_rev insert_thm; fun addrew ctxt thm (SS{auto_tac,congs,cong_net,mk_simps,simps,simp_net}) = let val thms = map Thm.trim_context (mk_simps ctxt thm) in SS{auto_tac=auto_tac,congs=congs, cong_net=cong_net, mk_simps=mk_simps, simps = (thm,thms)::simps, simp_net = insert_thms thms simp_net} end; fun op addcongs(SS{auto_tac,congs,cong_net,mk_simps,simps,simp_net}, thms) = let val congs' = map Thm.trim_context thms @ congs; in SS{auto_tac=auto_tac, congs= congs', cong_net= insert_thms (map mk_trans thms) cong_net, mk_simps = fn ctxt => normed_rews ctxt congs', simps=simps, simp_net=simp_net} end; (** Deletion of congruences and rewrites **) (*delete a thm from a thm net*) fun delete_thm th net = Net.delete_term Thm.eq_thm_prop (Thm.concl_of th, th) net handle Net.DELETE => net; val delete_thms = fold_rev delete_thm; fun op delcongs(SS{auto_tac,congs,cong_net,mk_simps,simps,simp_net}, thms) = let val congs' = fold (remove Thm.eq_thm_prop) thms congs in SS{auto_tac=auto_tac, congs= congs', cong_net= delete_thms (map mk_trans thms) cong_net, mk_simps= fn ctxt => normed_rews ctxt congs', simps=simps, simp_net=simp_net} end; fun delrew thm (SS{auto_tac,congs,cong_net,mk_simps,simps,simp_net}) = let fun find((p as (th,ths))::ps',ps) = if Thm.eq_thm_prop(thm,th) then (ths,ps@ps') else find(ps',p::ps) | find([],simps') = ([], simps') val (thms,simps') = find(simps,[]) in SS{auto_tac=auto_tac, congs=congs, cong_net=cong_net, mk_simps=mk_simps, simps = simps', simp_net = delete_thms thms simp_net } end; fun ss delrews thms = fold delrew thms ss; fun op setauto(SS{congs,cong_net,mk_simps,simps,simp_net,...}, auto_tac) = SS{auto_tac=auto_tac, congs=congs, cong_net=cong_net, mk_simps=mk_simps, simps=simps, simp_net=simp_net}; (** Inspection of a simpset **) fun dest_ss(SS{congs,simps,...}) = (congs, map #1 simps); fun print_ss ctxt (SS{congs,simps,...}) = writeln (cat_lines (["Congruences:"] @ map (Thm.string_of_thm ctxt) congs @ ["Rewrite Rules:"] @ map (Thm.string_of_thm ctxt o #1) simps)); (* Rewriting with conditionals *) val (case_thms,case_consts) = split_list case_splits; val case_rews = map mk_trans case_thms; fun if_rewritable ifc i thm = let val tm = goal_concl i thm fun nobound(Abs(_,_,tm),j,k) = nobound(tm,j,k+1) | nobound(s$t,j,k) = nobound(s,j,k) andalso nobound(t,j,k) | nobound(Bound n,j,k) = n < k orelse k+j <= n | nobound(_) = true; fun check_args(al,j) = forall (fn t => nobound(t,j,0)) al fun find_if(Abs(_,_,tm),j) = find_if(tm,j+1) | find_if(tm as s$t,j) = let val (f,al) = strip_comb tm in case f of Const(c,_) => if c=ifc then check_args(al,j) else find_if(s,j) orelse find_if(t,j) | _ => find_if(s,j) orelse find_if(t,j) end | find_if(_) = false; in find_if(tm,0) end; fun IF1_TAC ctxt cong_tac i = let fun seq_try (ifth::ifths,ifc::ifcs) thm = (COND (if_rewritable ifc i) (DETERM(resolve_tac ctxt [ifth] i)) (seq_try(ifths,ifcs))) thm | seq_try([],_) thm = no_tac thm and try_rew thm = (seq_try(case_rews,case_consts) ORELSE one_subt) thm and one_subt thm = let val test = has_fewer_prems (Thm.nprems_of thm + 1) fun loop thm = COND test no_tac ((try_rew THEN DEPTH_FIRST test (refl_tac ctxt i)) ORELSE (refl_tac ctxt i THEN loop)) thm in (cong_tac THEN loop) thm end in COND (may_match(case_consts,i)) try_rew no_tac end; fun CASE_TAC ctxt (SS{cong_net,...}) i = let val cong_tac = net_tac ctxt cong_net i in NORM ctxt (IF1_TAC ctxt cong_tac) i end; (* Rewriting Automaton *) datatype cntrl = STOP | MK_EQ | ASMS of int | SIMP_LHS | REW | REFL | TRUE | PROVE | POP_CS | POP_ARTR | IF; fun simp_refl([],_,ss) = ss | simp_refl(a'::ns,a,ss) = if a'=a then simp_refl(ns,a,SIMP_LHS::REFL::ss) else simp_refl(ns,a,ASMS(a)::SIMP_LHS::REFL::POP_ARTR::ss); (** Tracing **) val tracing = Unsynchronized.ref false; (*Replace parameters by Free variables in P*) fun variants_abs ([],P) = P | variants_abs ((a,T)::aTs, P) = - variants_abs (aTs, #2 (Syntax_Trans.variant_abs(a,T,P))); + variants_abs (aTs, #2 (Term.dest_abs(a,T,P))); (*Select subgoal i from proof state; substitute parameters, for printing*) fun prepare_goal i st = let val subgi = nth_subgoal i st val params = rev (Logic.strip_params subgi) in variants_abs (params, Logic.strip_assums_concl subgi) end; (*print lhs of conclusion of subgoal i*) fun pr_goal_lhs ctxt i st = writeln (Syntax.string_of_term ctxt (lhs_of (prepare_goal i st))); (*print conclusion of subgoal i*) fun pr_goal_concl ctxt i st = writeln (Syntax.string_of_term ctxt (prepare_goal i st)) (*print subgoals i to j (inclusive)*) fun pr_goals ctxt (i,j) st = if i>j then () else (pr_goal_concl ctxt i st; pr_goals ctxt (i+1,j) st); (*Print rewrite for tracing; i=subgoal#, n=number of new subgoals, thm=old state, thm'=new state *) fun pr_rew ctxt (i,n,thm,thm',not_asms) = if !tracing then (if not_asms then () else writeln"Assumption used in"; pr_goal_lhs ctxt i thm; writeln"->"; pr_goal_lhs ctxt (i+n) thm'; if n>0 then (writeln"Conditions:"; pr_goals ctxt (i, i+n-1) thm') else (); writeln"" ) else (); (* Skip the first n hyps of a goal, and return the rest in generalized form *) fun strip_varify(\<^Const_>\Pure.imp for H B\, n, vs) = if n=0 then subst_bounds(vs,H)::strip_varify(B,0,vs) else strip_varify(B,n-1,vs) | strip_varify(\<^Const_>\Pure.all _ for \Abs(_,T,t)\\, n, vs) = strip_varify(t,n,Var(("?",length vs),T)::vs) | strip_varify _ = []; fun execute ctxt (ss,if_fl,auto_tac,cong_tac,net,i,thm) = let fun simp_lhs(thm,ss,anet,ats,cs) = if var_lhs(thm,i) then (ss,thm,anet,ats,cs) else if lhs_is_NORM(thm,i) then (ss, res1 ctxt (thm,trans_norms,i), anet,ats,cs) else case Seq.pull(cong_tac i thm) of SOME(thm',_) => let val ps = Thm.prems_of thm and ps' = Thm.prems_of thm'; val n = length(ps')-length(ps); val a = length(Logic.strip_assums_hyp(nth ps (i - 1))) val l = map (length o Logic.strip_assums_hyp) (take n (drop (i-1) ps')); in (simp_refl(rev(l),a,REW::ss),thm',anet,ats,cs) end | NONE => (REW::ss,thm,anet,ats,cs); (*NB: the "Adding rewrites:" trace will look strange because assumptions are represented by rules, generalized over their parameters*) fun add_asms(ss,thm,a,anet,ats,cs) = let val As = strip_varify(nth_subgoal i thm, a, []); val thms = map (Thm.trivial o Thm.cterm_of ctxt) As; val new_rws = maps mk_rew_rules thms; val rwrls = map mk_trans (maps mk_rew_rules thms); val anet' = fold_rev lhs_insert_thm rwrls anet; in (ss,thm,anet',anet::ats,cs) end; fun rew(seq,thm,ss,anet,ats,cs, more) = case Seq.pull seq of SOME(thm',seq') => let val n = (Thm.nprems_of thm') - (Thm.nprems_of thm) in pr_rew ctxt (i,n,thm,thm',more); if n=0 then (SIMP_LHS::ss, thm', anet, ats, cs) else ((replicate n PROVE) @ (POP_CS::SIMP_LHS::ss), thm', anet, ats, (ss,thm,anet,ats,seq',more)::cs) end | NONE => if more then rew((lhs_net_tac ctxt anet i THEN assume_tac ctxt i) thm, thm,ss,anet,ats,cs,false) else (ss,thm,anet,ats,cs); fun try_true(thm,ss,anet,ats,cs) = case Seq.pull(auto_tac ctxt i thm) of SOME(thm',_) => (ss,thm',anet,ats,cs) | NONE => let val (ss0,thm0,anet0,ats0,seq,more)::cs0 = cs in if !tracing then (writeln"*** Failed to prove precondition. Normal form:"; pr_goal_concl ctxt i thm; writeln"") else (); rew(seq,thm0,ss0,anet0,ats0,cs0,more) end; fun if_exp(thm,ss,anet,ats,cs) = case Seq.pull (IF1_TAC ctxt (cong_tac i) i thm) of SOME(thm',_) => (SIMP_LHS::IF::ss,thm',anet,ats,cs) | NONE => (ss,thm,anet,ats,cs); fun step(s::ss, thm, anet, ats, cs) = case s of MK_EQ => (ss, res1 ctxt (thm,[red2],i), anet, ats, cs) | ASMS(a) => add_asms(ss,thm,a,anet,ats,cs) | SIMP_LHS => simp_lhs(thm,ss,anet,ats,cs) | REW => rew(net_tac ctxt net i thm,thm,ss,anet,ats,cs,true) | REFL => (ss, res1 ctxt (thm,refl_thms,i), anet, ats, cs) | TRUE => try_true(res1 ctxt (thm,refl_thms,i),ss,anet,ats,cs) | PROVE => (if if_fl then MK_EQ::SIMP_LHS::IF::TRUE::ss else MK_EQ::SIMP_LHS::TRUE::ss, thm, anet, ats, cs) | POP_ARTR => (ss,thm,hd ats,tl ats,cs) | POP_CS => (ss,thm,anet,ats,tl cs) | IF => if_exp(thm,ss,anet,ats,cs); fun exec(state as (s::ss, thm, _, _, _)) = if s=STOP then thm else exec(step(state)); in exec(ss, thm, Net.empty, [], []) end; fun EXEC_TAC ctxt (ss,fl) (SS{auto_tac,cong_net,simp_net,...}) = let val cong_tac = net_tac ctxt cong_net in fn i => (fn thm => if i <= 0 orelse Thm.nprems_of thm < i then Seq.empty else Seq.single(execute ctxt (ss,fl,auto_tac,cong_tac,simp_net,i,thm))) THEN TRY(auto_tac ctxt i) end; fun SIMP_TAC ctxt = EXEC_TAC ctxt ([MK_EQ,SIMP_LHS,REFL,STOP],false); fun SIMP_CASE_TAC ctxt = EXEC_TAC ctxt ([MK_EQ,SIMP_LHS,IF,REFL,STOP],false); fun ASM_SIMP_TAC ctxt = EXEC_TAC ctxt ([ASMS(0),MK_EQ,SIMP_LHS,REFL,STOP],false); fun ASM_SIMP_CASE_TAC ctxt = EXEC_TAC ctxt ([ASMS(0),MK_EQ,SIMP_LHS,IF,REFL,STOP],false); fun SIMP_CASE2_TAC ctxt = EXEC_TAC ctxt ([MK_EQ,SIMP_LHS,IF,REFL,STOP],true); fun REWRITE ctxt (ss,fl) (SS{auto_tac,cong_net,simp_net,...}) = let val cong_tac = net_tac ctxt cong_net in fn thm => let val state = thm RSN (2,red1) in execute ctxt (ss,fl,auto_tac,cong_tac,simp_net,1,state) end end; fun SIMP_THM ctxt = REWRITE ctxt ([ASMS(0),SIMP_LHS,IF,REFL,STOP],false); (* Compute Congruence rules for individual constants using the substition rules *) val subst_thms = map Drule.export_without_context subst_thms; fun exp_app(0,t) = t | exp_app(i,t) = exp_app(i-1,t $ Bound (i-1)); fun exp_abs(\<^Type>\fun T1 T2\,t,i) = Abs("x"^string_of_int i,T1,exp_abs(T2,t,i+1)) | exp_abs(T,t,i) = exp_app(i,t); fun eta_Var(ixn,T) = exp_abs(T,Var(ixn,T),0); fun Pinst(f,fT,(eq,eqT),k,i,T,yik,Ts) = let fun xn_list(x,n) = let val ixs = map_range (fn i => (x^(radixstring(26,"a",i)),0)) (n - 1); in ListPair.map eta_Var (ixs, take (n+1) Ts) end val lhs = list_comb(f,xn_list("X",k-1)) val rhs = list_comb(f,xn_list("X",i-1) @ [Bound 0] @ yik) in Abs("", T, Const(eq,[fT,fT]--->eqT) $ lhs $ rhs) end; fun find_subst ctxt T = let fun find (thm::thms) = let val (Const(_,cT), va, vb) = dest_red(hd(Thm.prems_of thm)); val [P] = subtract (op =) [va, vb] (Misc_Legacy.add_term_vars (Thm.concl_of thm, [])); val eqT::_ = binder_types cT in if Sign.typ_instance (Proof_Context.theory_of ctxt) (T,eqT) then SOME(thm,va,vb,P) else find thms end | find [] = NONE in find subst_thms end; fun mk_cong ctxt (f,aTs,rT) (refl,eq) = let val k = length aTs; fun ri((subst,va as Var(a,Ta),vb as Var(b,Tb), Var (P, _)),i,si,T,yik) = let val cx = Thm.cterm_of ctxt (eta_Var(("X"^si,0),T)) val cb = Thm.cterm_of ctxt vb val cy = Thm.cterm_of ctxt (eta_Var(("Y"^si,0),T)) val cp = Thm.cterm_of ctxt (Pinst(f,rT,eq,k,i,T,yik,aTs)) in infer_instantiate ctxt [(a,cx),(b,cy),(P,cp)] subst end; fun mk(c,T::Ts,i,yik) = let val si = radixstring(26,"a",i) in case find_subst ctxt T of NONE => mk(c,Ts,i-1,eta_Var(("X"^si,0),T)::yik) | SOME s => let val c' = c RSN (2,ri(s,i,si,T,yik)) in mk(c',Ts,i-1,eta_Var(("Y"^si,0),T)::yik) end end | mk(c,[],_,_) = c; in mk(refl,rev aTs,k-1,[]) end; fun mk_cong_type ctxt (f,T) = let val (aTs,rT) = strip_type T; fun find_refl(r::rs) = let val (Const(eq,eqT),_,_) = dest_red(Thm.concl_of r) in if Sign.typ_instance (Proof_Context.theory_of ctxt) (rT, hd(binder_types eqT)) then SOME(r,(eq,body_type eqT)) else find_refl rs end | find_refl([]) = NONE; in case find_refl refl_thms of NONE => [] | SOME(refl) => [mk_cong ctxt (f,aTs,rT) refl] end; fun mk_congs' ctxt f = let val T = case Sign.const_type (Proof_Context.theory_of ctxt) f of NONE => error(f^" not declared") | SOME(T) => T; val T' = Logic.incr_tvar 9 T; in mk_cong_type ctxt (Const(f,T'),T') end; val mk_congs = maps o mk_congs'; fun mk_typed_congs ctxt = let fun readfT(f,s) = let val T = Logic.incr_tvar 9 (Syntax.read_typ ctxt s); val t = case Sign.const_type (Proof_Context.theory_of ctxt) f of SOME(_) => Const(f,T) | NONE => Free(f,T) in (t,T) end in maps (mk_cong_type ctxt o readfT) end; end; end; diff --git a/src/HOL/Decision_Procs/Cooper.thy b/src/HOL/Decision_Procs/Cooper.thy --- a/src/HOL/Decision_Procs/Cooper.thy +++ b/src/HOL/Decision_Procs/Cooper.thy @@ -1,2669 +1,2669 @@ (* Title: HOL/Decision_Procs/Cooper.thy Author: Amine Chaieb *) section \Presburger arithmetic based on Cooper's algorithm\ theory Cooper imports Complex_Main "HOL-Library.Code_Target_Numeral" begin subsection \Basic formulae\ datatype (plugins del: size) num = C int | Bound nat | CN nat int num | Neg num | Add num num | Sub num num | Mul int num instantiation num :: size begin primrec size_num :: "num \ nat" where "size_num (C c) = 1" | "size_num (Bound n) = 1" | "size_num (Neg a) = 1 + size_num a" | "size_num (Add a b) = 1 + size_num a + size_num b" | "size_num (Sub a b) = 3 + size_num a + size_num b" | "size_num (CN n c a) = 4 + size_num a" | "size_num (Mul c a) = 1 + size_num a" instance .. end primrec Inum :: "int list \ num \ int" where "Inum bs (C c) = c" | "Inum bs (Bound n) = bs ! n" | "Inum bs (CN n c a) = c * (bs ! n) + Inum bs a" | "Inum bs (Neg a) = - Inum bs a" | "Inum bs (Add a b) = Inum bs a + Inum bs b" | "Inum bs (Sub a b) = Inum bs a - Inum bs b" | "Inum bs (Mul c a) = c * Inum bs a" datatype (plugins del: size) fm = T | F | Lt num | Le num | Gt num | Ge num | Eq num | NEq num | Dvd int num | NDvd int num | Not fm | And fm fm | Or fm fm | Imp fm fm | Iff fm fm | E fm | A fm | Closed nat | NClosed nat instantiation fm :: size begin primrec size_fm :: "fm \ nat" where "size_fm (Not p) = 1 + size_fm p" | "size_fm (And p q) = 1 + size_fm p + size_fm q" | "size_fm (Or p q) = 1 + size_fm p + size_fm q" | "size_fm (Imp p q) = 3 + size_fm p + size_fm q" | "size_fm (Iff p q) = 3 + 2 * (size_fm p + size_fm q)" | "size_fm (E p) = 1 + size_fm p" | "size_fm (A p) = 4 + size_fm p" | "size_fm (Dvd i t) = 2" | "size_fm (NDvd i t) = 2" | "size_fm T = 1" | "size_fm F = 1" | "size_fm (Lt _) = 1" | "size_fm (Le _) = 1" | "size_fm (Gt _) = 1" | "size_fm (Ge _) = 1" | "size_fm (Eq _) = 1" | "size_fm (NEq _) = 1" | "size_fm (Closed _) = 1" | "size_fm (NClosed _) = 1" instance .. end lemma fmsize_pos [simp]: "size p > 0" for p :: fm by (induct p) simp_all primrec Ifm :: "bool list \ int list \ fm \ bool" \ \Semantics of formulae (\fm\)\ where "Ifm bbs bs T \ True" | "Ifm bbs bs F \ False" | "Ifm bbs bs (Lt a) \ Inum bs a < 0" | "Ifm bbs bs (Gt a) \ Inum bs a > 0" | "Ifm bbs bs (Le a) \ Inum bs a \ 0" | "Ifm bbs bs (Ge a) \ Inum bs a \ 0" | "Ifm bbs bs (Eq a) \ Inum bs a = 0" | "Ifm bbs bs (NEq a) \ Inum bs a \ 0" | "Ifm bbs bs (Dvd i b) \ i dvd Inum bs b" | "Ifm bbs bs (NDvd i b) \ \ i dvd Inum bs b" | "Ifm bbs bs (Not p) \ \ Ifm bbs bs p" | "Ifm bbs bs (And p q) \ Ifm bbs bs p \ Ifm bbs bs q" | "Ifm bbs bs (Or p q) \ Ifm bbs bs p \ Ifm bbs bs q" | "Ifm bbs bs (Imp p q) \ (Ifm bbs bs p \ Ifm bbs bs q)" | "Ifm bbs bs (Iff p q) \ Ifm bbs bs p = Ifm bbs bs q" | "Ifm bbs bs (E p) \ (\x. Ifm bbs (x # bs) p)" | "Ifm bbs bs (A p) \ (\x. Ifm bbs (x # bs) p)" | "Ifm bbs bs (Closed n) \ bbs ! n" | "Ifm bbs bs (NClosed n) \ \ bbs ! n" fun prep :: "fm \ fm" where "prep (E T) = T" | "prep (E F) = F" | "prep (E (Or p q)) = Or (prep (E p)) (prep (E q))" | "prep (E (Imp p q)) = Or (prep (E (Not p))) (prep (E q))" | "prep (E (Iff p q)) = Or (prep (E (And p q))) (prep (E (And (Not p) (Not q))))" | "prep (E (Not (And p q))) = Or (prep (E (Not p))) (prep (E(Not q)))" | "prep (E (Not (Imp p q))) = prep (E (And p (Not q)))" | "prep (E (Not (Iff p q))) = Or (prep (E (And p (Not q)))) (prep (E(And (Not p) q)))" | "prep (E p) = E (prep p)" | "prep (A (And p q)) = And (prep (A p)) (prep (A q))" | "prep (A p) = prep (Not (E (Not p)))" | "prep (Not (Not p)) = prep p" | "prep (Not (And p q)) = Or (prep (Not p)) (prep (Not q))" | "prep (Not (A p)) = prep (E (Not p))" | "prep (Not (Or p q)) = And (prep (Not p)) (prep (Not q))" | "prep (Not (Imp p q)) = And (prep p) (prep (Not q))" | "prep (Not (Iff p q)) = Or (prep (And p (Not q))) (prep (And (Not p) q))" | "prep (Not p) = Not (prep p)" | "prep (Or p q) = Or (prep p) (prep q)" | "prep (And p q) = And (prep p) (prep q)" | "prep (Imp p q) = prep (Or (Not p) q)" | "prep (Iff p q) = Or (prep (And p q)) (prep (And (Not p) (Not q)))" | "prep p = p" lemma prep: "Ifm bbs bs (prep p) = Ifm bbs bs p" by (induct p arbitrary: bs rule: prep.induct) auto fun qfree :: "fm \ bool" \ \Quantifier freeness\ where "qfree (E p) \ False" | "qfree (A p) \ False" | "qfree (Not p) \ qfree p" | "qfree (And p q) \ qfree p \ qfree q" | "qfree (Or p q) \ qfree p \ qfree q" | "qfree (Imp p q) \ qfree p \ qfree q" | "qfree (Iff p q) \ qfree p \ qfree q" | "qfree p \ True" subsection \Boundedness and substitution\ primrec numbound0 :: "num \ bool" \ \a \num\ is \<^emph>\independent\ of Bound 0\ where "numbound0 (C c) \ True" | "numbound0 (Bound n) \ n > 0" | "numbound0 (CN n i a) \ n > 0 \ numbound0 a" | "numbound0 (Neg a) \ numbound0 a" | "numbound0 (Add a b) \ numbound0 a \ numbound0 b" | "numbound0 (Sub a b) \ numbound0 a \ numbound0 b" | "numbound0 (Mul i a) \ numbound0 a" lemma numbound0_I: assumes "numbound0 a" shows "Inum (b # bs) a = Inum (b' # bs) a" using assms by (induct a rule: num.induct) (auto simp add: gr0_conv_Suc) primrec bound0 :: "fm \ bool" \ \a formula is independent of Bound 0\ where "bound0 T \ True" | "bound0 F \ True" | "bound0 (Lt a) \ numbound0 a" | "bound0 (Le a) \ numbound0 a" | "bound0 (Gt a) \ numbound0 a" | "bound0 (Ge a) \ numbound0 a" | "bound0 (Eq a) \ numbound0 a" | "bound0 (NEq a) \ numbound0 a" | "bound0 (Dvd i a) \ numbound0 a" | "bound0 (NDvd i a) \ numbound0 a" | "bound0 (Not p) \ bound0 p" | "bound0 (And p q) \ bound0 p \ bound0 q" | "bound0 (Or p q) \ bound0 p \ bound0 q" | "bound0 (Imp p q) \ bound0 p \ bound0 q" | "bound0 (Iff p q) \ bound0 p \ bound0 q" | "bound0 (E p) \ False" | "bound0 (A p) \ False" | "bound0 (Closed P) \ True" | "bound0 (NClosed P) \ True" lemma bound0_I: assumes "bound0 p" shows "Ifm bbs (b # bs) p = Ifm bbs (b' # bs) p" using assms numbound0_I[where b="b" and bs="bs" and b'="b'"] by (induct p rule: fm.induct) (auto simp add: gr0_conv_Suc) fun numsubst0 :: "num \ num \ num" where "numsubst0 t (C c) = (C c)" | "numsubst0 t (Bound n) = (if n = 0 then t else Bound n)" | "numsubst0 t (CN 0 i a) = Add (Mul i t) (numsubst0 t a)" | "numsubst0 t (CN n i a) = CN n i (numsubst0 t a)" | "numsubst0 t (Neg a) = Neg (numsubst0 t a)" | "numsubst0 t (Add a b) = Add (numsubst0 t a) (numsubst0 t b)" | "numsubst0 t (Sub a b) = Sub (numsubst0 t a) (numsubst0 t b)" | "numsubst0 t (Mul i a) = Mul i (numsubst0 t a)" lemma numsubst0_I: "Inum (b # bs) (numsubst0 a t) = Inum ((Inum (b # bs) a) # bs) t" by (induct t rule: numsubst0.induct) (auto simp: nth_Cons') lemma numsubst0_I': "numbound0 a \ Inum (b#bs) (numsubst0 a t) = Inum ((Inum (b'#bs) a)#bs) t" by (induct t rule: numsubst0.induct) (auto simp: nth_Cons' numbound0_I[where b="b" and b'="b'"]) primrec subst0:: "num \ fm \ fm" \ \substitute a \num\ into a formula for Bound 0\ where "subst0 t T = T" | "subst0 t F = F" | "subst0 t (Lt a) = Lt (numsubst0 t a)" | "subst0 t (Le a) = Le (numsubst0 t a)" | "subst0 t (Gt a) = Gt (numsubst0 t a)" | "subst0 t (Ge a) = Ge (numsubst0 t a)" | "subst0 t (Eq a) = Eq (numsubst0 t a)" | "subst0 t (NEq a) = NEq (numsubst0 t a)" | "subst0 t (Dvd i a) = Dvd i (numsubst0 t a)" | "subst0 t (NDvd i a) = NDvd i (numsubst0 t a)" | "subst0 t (Not p) = Not (subst0 t p)" | "subst0 t (And p q) = And (subst0 t p) (subst0 t q)" | "subst0 t (Or p q) = Or (subst0 t p) (subst0 t q)" | "subst0 t (Imp p q) = Imp (subst0 t p) (subst0 t q)" | "subst0 t (Iff p q) = Iff (subst0 t p) (subst0 t q)" | "subst0 t (Closed P) = (Closed P)" | "subst0 t (NClosed P) = (NClosed P)" lemma subst0_I: assumes "qfree p" shows "Ifm bbs (b # bs) (subst0 a p) = Ifm bbs (Inum (b # bs) a # bs) p" using assms numsubst0_I[where b="b" and bs="bs" and a="a"] by (induct p) (simp_all add: gr0_conv_Suc) fun decrnum:: "num \ num" where "decrnum (Bound n) = Bound (n - 1)" | "decrnum (Neg a) = Neg (decrnum a)" | "decrnum (Add a b) = Add (decrnum a) (decrnum b)" | "decrnum (Sub a b) = Sub (decrnum a) (decrnum b)" | "decrnum (Mul c a) = Mul c (decrnum a)" | "decrnum (CN n i a) = (CN (n - 1) i (decrnum a))" | "decrnum a = a" fun decr :: "fm \ fm" where "decr (Lt a) = Lt (decrnum a)" | "decr (Le a) = Le (decrnum a)" | "decr (Gt a) = Gt (decrnum a)" | "decr (Ge a) = Ge (decrnum a)" | "decr (Eq a) = Eq (decrnum a)" | "decr (NEq a) = NEq (decrnum a)" | "decr (Dvd i a) = Dvd i (decrnum a)" | "decr (NDvd i a) = NDvd i (decrnum a)" | "decr (Not p) = Not (decr p)" | "decr (And p q) = And (decr p) (decr q)" | "decr (Or p q) = Or (decr p) (decr q)" | "decr (Imp p q) = Imp (decr p) (decr q)" | "decr (Iff p q) = Iff (decr p) (decr q)" | "decr p = p" lemma decrnum: assumes "numbound0 t" shows "Inum (x # bs) t = Inum bs (decrnum t)" using assms by (induct t rule: decrnum.induct) (auto simp add: gr0_conv_Suc) lemma decr: assumes assms: "bound0 p" shows "Ifm bbs (x # bs) p = Ifm bbs bs (decr p)" using assms by (induct p rule: decr.induct) (simp_all add: gr0_conv_Suc decrnum) lemma decr_qf: "bound0 p \ qfree (decr p)" by (induct p) simp_all fun isatom :: "fm \ bool" \ \test for atomicity\ where "isatom T \ True" | "isatom F \ True" | "isatom (Lt a) \ True" | "isatom (Le a) \ True" | "isatom (Gt a) \ True" | "isatom (Ge a) \ True" | "isatom (Eq a) \ True" | "isatom (NEq a) \ True" | "isatom (Dvd i b) \ True" | "isatom (NDvd i b) \ True" | "isatom (Closed P) \ True" | "isatom (NClosed P) \ True" | "isatom p \ False" lemma numsubst0_numbound0: assumes "numbound0 t" shows "numbound0 (numsubst0 t a)" using assms proof (induct a) case (CN n) then show ?case by (cases n) simp_all qed simp_all lemma subst0_bound0: assumes qf: "qfree p" and nb: "numbound0 t" shows "bound0 (subst0 t p)" using qf numsubst0_numbound0[OF nb] by (induct p) auto lemma bound0_qf: "bound0 p \ qfree p" by (induct p) simp_all definition djf :: "('a \ fm) \ 'a \ fm \ fm" where "djf f p q = (if q = T then T else if q = F then f p else let fp = f p in case fp of T \ T | F \ q | _ \ Or (f p) q)" definition evaldjf :: "('a \ fm) \ 'a list \ fm" where "evaldjf f ps = foldr (djf f) ps F" lemma djf_Or: "Ifm bbs bs (djf f p q) = Ifm bbs bs (Or (f p) q)" by (cases "q=T", simp add: djf_def, cases "q = F", simp add: djf_def) (cases "f p", simp_all add: Let_def djf_def) lemma evaldjf_ex: "Ifm bbs bs (evaldjf f ps) \ (\p \ set ps. Ifm bbs bs (f p))" by (induct ps) (simp_all add: evaldjf_def djf_Or) lemma evaldjf_bound0: assumes nb: "\x\ set xs. bound0 (f x)" shows "bound0 (evaldjf f xs)" using nb by (induct xs) (auto simp add: evaldjf_def djf_def Let_def, case_tac "f a", auto) lemma evaldjf_qf: assumes nb: "\x\ set xs. qfree (f x)" shows "qfree (evaldjf f xs)" using nb by (induct xs) (auto simp add: evaldjf_def djf_def Let_def, case_tac "f a", auto) fun disjuncts :: "fm \ fm list" where "disjuncts (Or p q) = disjuncts p @ disjuncts q" | "disjuncts F = []" | "disjuncts p = [p]" lemma disjuncts: "(\q \ set (disjuncts p). Ifm bbs bs q) \ Ifm bbs bs p" by (induct p rule: disjuncts.induct) auto lemma disjuncts_nb: assumes "bound0 p" shows "\q \ set (disjuncts p). bound0 q" proof - from assms have "list_all bound0 (disjuncts p)" by (induct p rule: disjuncts.induct) auto then show ?thesis by (simp only: list_all_iff) qed lemma disjuncts_qf: assumes "qfree p" shows "\q \ set (disjuncts p). qfree q" proof - from assms have "list_all qfree (disjuncts p)" by (induct p rule: disjuncts.induct) auto then show ?thesis by (simp only: list_all_iff) qed definition DJ :: "(fm \ fm) \ fm \ fm" where "DJ f p = evaldjf f (disjuncts p)" lemma DJ: assumes "\p q. f (Or p q) = Or (f p) (f q)" and "f F = F" shows "Ifm bbs bs (DJ f p) = Ifm bbs bs (f p)" proof - have "Ifm bbs bs (DJ f p) \ (\q \ set (disjuncts p). Ifm bbs bs (f q))" by (simp add: DJ_def evaldjf_ex) also from assms have "\ = Ifm bbs bs (f p)" by (induct p rule: disjuncts.induct) auto finally show ?thesis . qed lemma DJ_qf: assumes "\p. qfree p \ qfree (f p)" shows "\p. qfree p \ qfree (DJ f p) " proof clarify fix p assume qf: "qfree p" have th: "DJ f p = evaldjf f (disjuncts p)" by (simp add: DJ_def) from disjuncts_qf[OF qf] have "\q \ set (disjuncts p). qfree q" . with assms have th': "\q \ set (disjuncts p). qfree (f q)" by blast from evaldjf_qf[OF th'] th show "qfree (DJ f p)" by simp qed lemma DJ_qe: assumes qe: "\bs p. qfree p \ qfree (qe p) \ Ifm bbs bs (qe p) = Ifm bbs bs (E p)" shows "\bs p. qfree p \ qfree (DJ qe p) \ Ifm bbs bs ((DJ qe p)) = Ifm bbs bs (E p)" proof clarify fix p :: fm fix bs assume qf: "qfree p" from qe have qth: "\p. qfree p \ qfree (qe p)" by blast from DJ_qf[OF qth] qf have qfth: "qfree (DJ qe p)" by auto have "Ifm bbs bs (DJ qe p) = (\q\ set (disjuncts p). Ifm bbs bs (qe q))" by (simp add: DJ_def evaldjf_ex) also have "\ \ (\q \ set (disjuncts p). Ifm bbs bs (E q))" using qe disjuncts_qf[OF qf] by auto also have "\ \ Ifm bbs bs (E p)" by (induct p rule: disjuncts.induct) auto finally show "qfree (DJ qe p) \ Ifm bbs bs (DJ qe p) = Ifm bbs bs (E p)" using qfth by blast qed subsection \Simplification\ text \Algebraic simplifications for nums\ fun bnds :: "num \ nat list" where "bnds (Bound n) = [n]" | "bnds (CN n c a) = n # bnds a" | "bnds (Neg a) = bnds a" | "bnds (Add a b) = bnds a @ bnds b" | "bnds (Sub a b) = bnds a @ bnds b" | "bnds (Mul i a) = bnds a" | "bnds a = []" fun lex_ns:: "nat list \ nat list \ bool" where "lex_ns [] ms \ True" | "lex_ns ns [] \ False" | "lex_ns (n # ns) (m # ms) \ n < m \ (n = m \ lex_ns ns ms)" definition lex_bnd :: "num \ num \ bool" where "lex_bnd t s = lex_ns (bnds t) (bnds s)" fun numadd:: "num \ num \ num" where "numadd (CN n1 c1 r1) (CN n2 c2 r2) = (if n1 = n2 then let c = c1 + c2 in if c = 0 then numadd r1 r2 else CN n1 c (numadd r1 r2) else if n1 \ n2 then CN n1 c1 (numadd r1 (Add (Mul c2 (Bound n2)) r2)) else CN n2 c2 (numadd (Add (Mul c1 (Bound n1)) r1) r2))" | "numadd (CN n1 c1 r1) t = CN n1 c1 (numadd r1 t)" | "numadd t (CN n2 c2 r2) = CN n2 c2 (numadd t r2)" | "numadd (C b1) (C b2) = C (b1 + b2)" | "numadd a b = Add a b" lemma numadd: "Inum bs (numadd t s) = Inum bs (Add t s)" by (induct t s rule: numadd.induct) (simp_all add: Let_def algebra_simps add_eq_0_iff) lemma numadd_nb: "numbound0 t \ numbound0 s \ numbound0 (numadd t s)" by (induct t s rule: numadd.induct) (simp_all add: Let_def) fun nummul :: "int \ num \ num" where "nummul i (C j) = C (i * j)" | "nummul i (CN n c t) = CN n (c * i) (nummul i t)" | "nummul i t = Mul i t" lemma nummul: "Inum bs (nummul i t) = Inum bs (Mul i t)" by (induct t arbitrary: i rule: nummul.induct) (simp_all add: algebra_simps) lemma nummul_nb: "numbound0 t \ numbound0 (nummul i t)" by (induct t arbitrary: i rule: nummul.induct) (simp_all add: numadd_nb) definition numneg :: "num \ num" where "numneg t = nummul (- 1) t" definition numsub :: "num \ num \ num" where "numsub s t = (if s = t then C 0 else numadd s (numneg t))" lemma numneg: "Inum bs (numneg t) = Inum bs (Neg t)" using numneg_def nummul by simp lemma numneg_nb: "numbound0 t \ numbound0 (numneg t)" using numneg_def nummul_nb by simp lemma numsub: "Inum bs (numsub a b) = Inum bs (Sub a b)" using numneg numadd numsub_def by simp lemma numsub_nb: "numbound0 t \ numbound0 s \ numbound0 (numsub t s)" using numsub_def numadd_nb numneg_nb by simp fun simpnum :: "num \ num" where "simpnum (C j) = C j" | "simpnum (Bound n) = CN n 1 (C 0)" | "simpnum (Neg t) = numneg (simpnum t)" | "simpnum (Add t s) = numadd (simpnum t) (simpnum s)" | "simpnum (Sub t s) = numsub (simpnum t) (simpnum s)" | "simpnum (Mul i t) = (if i = 0 then C 0 else nummul i (simpnum t))" | "simpnum t = t" lemma simpnum_ci: "Inum bs (simpnum t) = Inum bs t" by (induct t rule: simpnum.induct) (auto simp add: numneg numadd numsub nummul) lemma simpnum_numbound0: "numbound0 t \ numbound0 (simpnum t)" by (induct t rule: simpnum.induct) (auto simp add: numadd_nb numsub_nb nummul_nb numneg_nb) fun not :: "fm \ fm" where "not (Not p) = p" | "not T = F" | "not F = T" | "not p = Not p" lemma not: "Ifm bbs bs (not p) = Ifm bbs bs (Not p)" by (cases p) auto lemma not_qf: "qfree p \ qfree (not p)" by (cases p) auto lemma not_bn: "bound0 p \ bound0 (not p)" by (cases p) auto definition conj :: "fm \ fm \ fm" where "conj p q = (if p = F \ q = F then F else if p = T then q else if q = T then p else And p q)" lemma conj: "Ifm bbs bs (conj p q) = Ifm bbs bs (And p q)" by (cases "p = F \ q = F", simp_all add: conj_def) (cases p, simp_all) lemma conj_qf: "qfree p \ qfree q \ qfree (conj p q)" using conj_def by auto lemma conj_nb: "bound0 p \ bound0 q \ bound0 (conj p q)" using conj_def by auto definition disj :: "fm \ fm \ fm" where "disj p q = (if p = T \ q = T then T else if p = F then q else if q = F then p else Or p q)" lemma disj: "Ifm bbs bs (disj p q) = Ifm bbs bs (Or p q)" by (cases "p = T \ q = T", simp_all add: disj_def) (cases p, simp_all) lemma disj_qf: "qfree p \ qfree q \ qfree (disj p q)" using disj_def by auto lemma disj_nb: "bound0 p \ bound0 q \ bound0 (disj p q)" using disj_def by auto definition imp :: "fm \ fm \ fm" where "imp p q = (if p = F \ q = T then T else if p = T then q else if q = F then not p else Imp p q)" lemma imp: "Ifm bbs bs (imp p q) = Ifm bbs bs (Imp p q)" by (cases "p = F \ q = T", simp_all add: imp_def, cases p) (simp_all add: not) lemma imp_qf: "qfree p \ qfree q \ qfree (imp p q)" using imp_def by (cases "p = F \ q = T", simp_all add: imp_def, cases p) (simp_all add: not_qf) lemma imp_nb: "bound0 p \ bound0 q \ bound0 (imp p q)" using imp_def by (cases "p = F \ q = T", simp_all add: imp_def, cases p) simp_all definition iff :: "fm \ fm \ fm" where "iff p q = (if p = q then T else if p = not q \ not p = q then F else if p = F then not q else if q = F then not p else if p = T then q else if q = T then p else Iff p q)" lemma iff: "Ifm bbs bs (iff p q) = Ifm bbs bs (Iff p q)" by (unfold iff_def, cases "p = q", simp, cases "p = not q", simp add: not) (cases "not p = q", auto simp add: not) lemma iff_qf: "qfree p \ qfree q \ qfree (iff p q)" by (unfold iff_def, cases "p = q", auto simp add: not_qf) lemma iff_nb: "bound0 p \ bound0 q \ bound0 (iff p q)" using iff_def by (unfold iff_def, cases "p = q", auto simp add: not_bn) fun simpfm :: "fm \ fm" where "simpfm (And p q) = conj (simpfm p) (simpfm q)" | "simpfm (Or p q) = disj (simpfm p) (simpfm q)" | "simpfm (Imp p q) = imp (simpfm p) (simpfm q)" | "simpfm (Iff p q) = iff (simpfm p) (simpfm q)" | "simpfm (Not p) = not (simpfm p)" | "simpfm (Lt a) = (let a' = simpnum a in case a' of C v \ if v < 0 then T else F | _ \ Lt a')" | "simpfm (Le a) = (let a' = simpnum a in case a' of C v \ if v \ 0 then T else F | _ \ Le a')" | "simpfm (Gt a) = (let a' = simpnum a in case a' of C v \ if v > 0 then T else F | _ \ Gt a')" | "simpfm (Ge a) = (let a' = simpnum a in case a' of C v \ if v \ 0 then T else F | _ \ Ge a')" | "simpfm (Eq a) = (let a' = simpnum a in case a' of C v \ if v = 0 then T else F | _ \ Eq a')" | "simpfm (NEq a) = (let a' = simpnum a in case a' of C v \ if v \ 0 then T else F | _ \ NEq a')" | "simpfm (Dvd i a) = (if i = 0 then simpfm (Eq a) else if \i\ = 1 then T else let a' = simpnum a in case a' of C v \ if i dvd v then T else F | _ \ Dvd i a')" | "simpfm (NDvd i a) = (if i = 0 then simpfm (NEq a) else if \i\ = 1 then F else let a' = simpnum a in case a' of C v \ if \( i dvd v) then T else F | _ \ NDvd i a')" | "simpfm p = p" lemma simpfm: "Ifm bbs bs (simpfm p) = Ifm bbs bs p" proof (induct p rule: simpfm.induct) case (6 a) let ?sa = "simpnum a" from simpnum_ci have sa: "Inum bs ?sa = Inum bs a" by simp consider v where "?sa = C v" | "\ (\v. ?sa = C v)" by blast then show ?case proof cases case 1 with sa show ?thesis by simp next case 2 with sa show ?thesis by (cases ?sa) (simp_all add: Let_def) qed next case (7 a) let ?sa = "simpnum a" from simpnum_ci have sa: "Inum bs ?sa = Inum bs a" by simp consider v where "?sa = C v" | "\ (\v. ?sa = C v)" by blast then show ?case proof cases case 1 with sa show ?thesis by simp next case 2 with sa show ?thesis by (cases ?sa) (simp_all add: Let_def) qed next case (8 a) let ?sa = "simpnum a" from simpnum_ci have sa: "Inum bs ?sa = Inum bs a" by simp consider v where "?sa = C v" | "\ (\v. ?sa = C v)" by blast then show ?case proof cases case 1 with sa show ?thesis by simp next case 2 with sa show ?thesis by (cases ?sa) (simp_all add: Let_def) qed next case (9 a) let ?sa = "simpnum a" from simpnum_ci have sa: "Inum bs ?sa = Inum bs a" by simp consider v where "?sa = C v" | "\ (\v. ?sa = C v)" by blast then show ?case proof cases case 1 with sa show ?thesis by simp next case 2 with sa show ?thesis by (cases ?sa) (simp_all add: Let_def) qed next case (10 a) let ?sa = "simpnum a" from simpnum_ci have sa: "Inum bs ?sa = Inum bs a" by simp consider v where "?sa = C v" | "\ (\v. ?sa = C v)" by blast then show ?case proof cases case 1 with sa show ?thesis by simp next case 2 with sa show ?thesis by (cases ?sa) (simp_all add: Let_def) qed next case (11 a) let ?sa = "simpnum a" from simpnum_ci have sa: "Inum bs ?sa = Inum bs a" by simp consider v where "?sa = C v" | "\ (\v. ?sa = C v)" by blast then show ?case proof cases case 1 with sa show ?thesis by simp next case 2 with sa show ?thesis by (cases ?sa) (simp_all add: Let_def) qed next case (12 i a) let ?sa = "simpnum a" from simpnum_ci have sa: "Inum bs ?sa = Inum bs a" by simp consider "i = 0" | "\i\ = 1" | "i \ 0" "\i\ \ 1" by blast then show ?case proof cases case 1 then show ?thesis using "12.hyps" by (simp add: dvd_def Let_def) next case 2 with one_dvd[of "Inum bs a"] uminus_dvd_conv[where d="1" and t="Inum bs a"] show ?thesis apply (cases "i = 0") apply (simp_all add: Let_def) apply (cases "i > 0") apply simp_all done next case i: 3 consider v where "?sa = C v" | "\ (\v. ?sa = C v)" by blast then show ?thesis proof cases case 1 with sa[symmetric] i show ?thesis by (cases "\i\ = 1") auto next case 2 then have "simpfm (Dvd i a) = Dvd i ?sa" using i by (cases ?sa) (auto simp add: Let_def) with sa show ?thesis by simp qed qed next case (13 i a) let ?sa = "simpnum a" from simpnum_ci have sa: "Inum bs ?sa = Inum bs a" by simp consider "i = 0" | "\i\ = 1" | "i \ 0" "\i\ \ 1" by blast then show ?case proof cases case 1 then show ?thesis using "13.hyps" by (simp add: dvd_def Let_def) next case 2 with one_dvd[of "Inum bs a"] uminus_dvd_conv[where d="1" and t="Inum bs a"] show ?thesis apply (cases "i = 0") apply (simp_all add: Let_def) apply (cases "i > 0") apply simp_all done next case i: 3 consider v where "?sa = C v" | "\ (\v. ?sa = C v)" by blast then show ?thesis proof cases case 1 with sa[symmetric] i show ?thesis by (cases "\i\ = 1") auto next case 2 then have "simpfm (NDvd i a) = NDvd i ?sa" using i by (cases ?sa) (auto simp add: Let_def) with sa show ?thesis by simp qed qed qed (simp_all add: conj disj imp iff not) lemma simpfm_bound0: "bound0 p \ bound0 (simpfm p)" proof (induct p rule: simpfm.induct) case (6 a) then have nb: "numbound0 a" by simp then have "numbound0 (simpnum a)" by (simp only: simpnum_numbound0[OF nb]) then show ?case by (cases "simpnum a") (auto simp add: Let_def) next case (7 a) then have nb: "numbound0 a" by simp then have "numbound0 (simpnum a)" by (simp only: simpnum_numbound0[OF nb]) then show ?case by (cases "simpnum a") (auto simp add: Let_def) next case (8 a) then have nb: "numbound0 a" by simp then have "numbound0 (simpnum a)" by (simp only: simpnum_numbound0[OF nb]) then show ?case by (cases "simpnum a") (auto simp add: Let_def) next case (9 a) then have nb: "numbound0 a" by simp then have "numbound0 (simpnum a)" by (simp only: simpnum_numbound0[OF nb]) then show ?case by (cases "simpnum a") (auto simp add: Let_def) next case (10 a) then have nb: "numbound0 a" by simp then have "numbound0 (simpnum a)" by (simp only: simpnum_numbound0[OF nb]) then show ?case by (cases "simpnum a") (auto simp add: Let_def) next case (11 a) then have nb: "numbound0 a" by simp then have "numbound0 (simpnum a)" by (simp only: simpnum_numbound0[OF nb]) then show ?case by (cases "simpnum a") (auto simp add: Let_def) next case (12 i a) then have nb: "numbound0 a" by simp then have "numbound0 (simpnum a)" by (simp only: simpnum_numbound0[OF nb]) then show ?case by (cases "simpnum a") (auto simp add: Let_def) next case (13 i a) then have nb: "numbound0 a" by simp then have "numbound0 (simpnum a)" by (simp only: simpnum_numbound0[OF nb]) then show ?case by (cases "simpnum a") (auto simp add: Let_def) qed (auto simp add: disj_def imp_def iff_def conj_def not_bn) lemma simpfm_qf: "qfree p \ qfree (simpfm p)" apply (induct p rule: simpfm.induct) apply (auto simp add: disj_qf imp_qf iff_qf conj_qf not_qf Let_def) apply (case_tac "simpnum a", auto)+ done subsection \Generic quantifier elimination\ fun qelim :: "fm \ (fm \ fm) \ fm" where "qelim (E p) = (\qe. DJ qe (qelim p qe))" | "qelim (A p) = (\qe. not (qe ((qelim (Not p) qe))))" | "qelim (Not p) = (\qe. not (qelim p qe))" | "qelim (And p q) = (\qe. conj (qelim p qe) (qelim q qe))" | "qelim (Or p q) = (\qe. disj (qelim p qe) (qelim q qe))" | "qelim (Imp p q) = (\qe. imp (qelim p qe) (qelim q qe))" | "qelim (Iff p q) = (\qe. iff (qelim p qe) (qelim q qe))" | "qelim p = (\y. simpfm p)" lemma qelim_ci: assumes qe_inv: "\bs p. qfree p \ qfree (qe p) \ Ifm bbs bs (qe p) = Ifm bbs bs (E p)" shows "\bs. qfree (qelim p qe) \ Ifm bbs bs (qelim p qe) = Ifm bbs bs p" using qe_inv DJ_qe[OF qe_inv] by (induct p rule: qelim.induct) (auto simp add: not disj conj iff imp not_qf disj_qf conj_qf imp_qf iff_qf simpfm simpfm_qf simp del: simpfm.simps) text \Linearity for fm where Bound 0 ranges over \\\\ fun zsplit0 :: "num \ int \ num" \ \splits the bounded from the unbounded part\ where "zsplit0 (C c) = (0, C c)" | "zsplit0 (Bound n) = (if n = 0 then (1, C 0) else (0, Bound n))" | "zsplit0 (CN n i a) = (let (i', a') = zsplit0 a in if n = 0 then (i + i', a') else (i', CN n i a'))" | "zsplit0 (Neg a) = (let (i', a') = zsplit0 a in (-i', Neg a'))" | "zsplit0 (Add a b) = (let (ia, a') = zsplit0 a; (ib, b') = zsplit0 b in (ia + ib, Add a' b'))" | "zsplit0 (Sub a b) = (let (ia, a') = zsplit0 a; (ib, b') = zsplit0 b in (ia - ib, Sub a' b'))" | "zsplit0 (Mul i a) = (let (i', a') = zsplit0 a in (i*i', Mul i a'))" lemma zsplit0_I: "\n a. zsplit0 t = (n, a) \ (Inum ((x::int) # bs) (CN 0 n a) = Inum (x # bs) t) \ numbound0 a" (is "\n a. ?S t = (n,a) \ (?I x (CN 0 n a) = ?I x t) \ ?N a") proof (induct t rule: zsplit0.induct) case (1 c n a) then show ?case by auto next case (2 m n a) then show ?case by (cases "m = 0") auto next case (3 m i a n a') let ?j = "fst (zsplit0 a)" let ?b = "snd (zsplit0 a)" have abj: "zsplit0 a = (?j, ?b)" by simp show ?case proof (cases "m = 0") case False with 3(1)[OF abj] 3(2) show ?thesis by (auto simp add: Let_def split_def) next case m: True with abj have th: "a' = ?b \ n = i + ?j" using 3 by (simp add: Let_def split_def) from abj 3 m have th2: "(?I x (CN 0 ?j ?b) = ?I x a) \ ?N ?b" by blast from th have "?I x (CN 0 n a') = ?I x (CN 0 (i + ?j) ?b)" by simp also from th2 have "\ = ?I x (CN 0 i (CN 0 ?j ?b))" by (simp add: distrib_right) finally have "?I x (CN 0 n a') = ?I x (CN 0 i a)" using th2 by simp with th2 th m show ?thesis by blast qed next case (4 t n a) let ?nt = "fst (zsplit0 t)" let ?at = "snd (zsplit0 t)" have abj: "zsplit0 t = (?nt, ?at)" by simp then have th: "a = Neg ?at \ n = - ?nt" using 4 by (simp add: Let_def split_def) from abj 4 have th2: "(?I x (CN 0 ?nt ?at) = ?I x t) \ ?N ?at" by blast from th2[simplified] th[simplified] show ?case by simp next case (5 s t n a) let ?ns = "fst (zsplit0 s)" let ?as = "snd (zsplit0 s)" let ?nt = "fst (zsplit0 t)" let ?at = "snd (zsplit0 t)" have abjs: "zsplit0 s = (?ns, ?as)" by simp moreover have abjt: "zsplit0 t = (?nt, ?at)" by simp ultimately have th: "a = Add ?as ?at \ n = ?ns + ?nt" using 5 by (simp add: Let_def split_def) from abjs[symmetric] have bluddy: "\x y. (x, y) = zsplit0 s" by blast from 5 have "(\x y. (x, y) = zsplit0 s) \ (\xa xb. zsplit0 t = (xa, xb) \ Inum (x # bs) (CN 0 xa xb) = Inum (x # bs) t \ numbound0 xb)" by auto with bluddy abjt have th3: "(?I x (CN 0 ?nt ?at) = ?I x t) \ ?N ?at" by blast from abjs 5 have th2: "(?I x (CN 0 ?ns ?as) = ?I x s) \ ?N ?as" by blast from th3[simplified] th2[simplified] th[simplified] show ?case by (simp add: distrib_right) next case (6 s t n a) let ?ns = "fst (zsplit0 s)" let ?as = "snd (zsplit0 s)" let ?nt = "fst (zsplit0 t)" let ?at = "snd (zsplit0 t)" have abjs: "zsplit0 s = (?ns, ?as)" by simp moreover have abjt: "zsplit0 t = (?nt, ?at)" by simp ultimately have th: "a = Sub ?as ?at \ n = ?ns - ?nt" using 6 by (simp add: Let_def split_def) from abjs[symmetric] have bluddy: "\x y. (x, y) = zsplit0 s" by blast from 6 have "(\x y. (x,y) = zsplit0 s) \ (\xa xb. zsplit0 t = (xa, xb) \ Inum (x # bs) (CN 0 xa xb) = Inum (x # bs) t \ numbound0 xb)" by auto with bluddy abjt have th3: "(?I x (CN 0 ?nt ?at) = ?I x t) \ ?N ?at" by blast from abjs 6 have th2: "(?I x (CN 0 ?ns ?as) = ?I x s) \ ?N ?as" by blast from th3[simplified] th2[simplified] th[simplified] show ?case by (simp add: left_diff_distrib) next case (7 i t n a) let ?nt = "fst (zsplit0 t)" let ?at = "snd (zsplit0 t)" have abj: "zsplit0 t = (?nt,?at)" by simp then have th: "a = Mul i ?at \ n = i * ?nt" using 7 by (simp add: Let_def split_def) from abj 7 have th2: "(?I x (CN 0 ?nt ?at) = ?I x t) \ ?N ?at" by blast then have "?I x (Mul i t) = i * ?I x (CN 0 ?nt ?at)" by simp also have "\ = ?I x (CN 0 (i*?nt) (Mul i ?at))" by (simp add: distrib_left) finally show ?case using th th2 by simp qed fun iszlfm :: "fm \ bool" \ \linearity test for fm\ where "iszlfm (And p q) \ iszlfm p \ iszlfm q" | "iszlfm (Or p q) \ iszlfm p \ iszlfm q" | "iszlfm (Eq (CN 0 c e)) \ c > 0 \ numbound0 e" | "iszlfm (NEq (CN 0 c e)) \ c > 0 \ numbound0 e" | "iszlfm (Lt (CN 0 c e)) \ c > 0 \ numbound0 e" | "iszlfm (Le (CN 0 c e)) \ c > 0 \ numbound0 e" | "iszlfm (Gt (CN 0 c e)) \ c > 0 \ numbound0 e" | "iszlfm (Ge (CN 0 c e)) \ c > 0 \ numbound0 e" | "iszlfm (Dvd i (CN 0 c e)) \ c > 0 \ i > 0 \ numbound0 e" | "iszlfm (NDvd i (CN 0 c e)) \ c > 0 \ i > 0 \ numbound0 e" | "iszlfm p \ isatom p \ bound0 p" lemma zlin_qfree: "iszlfm p \ qfree p" by (induct p rule: iszlfm.induct) auto fun zlfm :: "fm \ fm" \ \linearity transformation for fm\ where "zlfm (And p q) = And (zlfm p) (zlfm q)" | "zlfm (Or p q) = Or (zlfm p) (zlfm q)" | "zlfm (Imp p q) = Or (zlfm (Not p)) (zlfm q)" | "zlfm (Iff p q) = Or (And (zlfm p) (zlfm q)) (And (zlfm (Not p)) (zlfm (Not q)))" | "zlfm (Lt a) = (let (c, r) = zsplit0 a in if c = 0 then Lt r else if c > 0 then (Lt (CN 0 c r)) else Gt (CN 0 (- c) (Neg r)))" | "zlfm (Le a) = (let (c, r) = zsplit0 a in if c = 0 then Le r else if c > 0 then Le (CN 0 c r) else Ge (CN 0 (- c) (Neg r)))" | "zlfm (Gt a) = (let (c, r) = zsplit0 a in if c = 0 then Gt r else if c > 0 then Gt (CN 0 c r) else Lt (CN 0 (- c) (Neg r)))" | "zlfm (Ge a) = (let (c, r) = zsplit0 a in if c = 0 then Ge r else if c > 0 then Ge (CN 0 c r) else Le (CN 0 (- c) (Neg r)))" | "zlfm (Eq a) = (let (c, r) = zsplit0 a in if c = 0 then Eq r else if c > 0 then Eq (CN 0 c r) else Eq (CN 0 (- c) (Neg r)))" | "zlfm (NEq a) = (let (c, r) = zsplit0 a in if c = 0 then NEq r else if c > 0 then NEq (CN 0 c r) else NEq (CN 0 (- c) (Neg r)))" | "zlfm (Dvd i a) = (if i = 0 then zlfm (Eq a) else let (c, r) = zsplit0 a in if c = 0 then Dvd \i\ r else if c > 0 then Dvd \i\ (CN 0 c r) else Dvd \i\ (CN 0 (- c) (Neg r)))" | "zlfm (NDvd i a) = (if i = 0 then zlfm (NEq a) else let (c, r) = zsplit0 a in if c = 0 then NDvd \i\ r else if c > 0 then NDvd \i\ (CN 0 c r) else NDvd \i\ (CN 0 (- c) (Neg r)))" | "zlfm (Not (And p q)) = Or (zlfm (Not p)) (zlfm (Not q))" | "zlfm (Not (Or p q)) = And (zlfm (Not p)) (zlfm (Not q))" | "zlfm (Not (Imp p q)) = And (zlfm p) (zlfm (Not q))" | "zlfm (Not (Iff p q)) = Or (And(zlfm p) (zlfm(Not q))) (And (zlfm(Not p)) (zlfm q))" | "zlfm (Not (Not p)) = zlfm p" | "zlfm (Not T) = F" | "zlfm (Not F) = T" | "zlfm (Not (Lt a)) = zlfm (Ge a)" | "zlfm (Not (Le a)) = zlfm (Gt a)" | "zlfm (Not (Gt a)) = zlfm (Le a)" | "zlfm (Not (Ge a)) = zlfm (Lt a)" | "zlfm (Not (Eq a)) = zlfm (NEq a)" | "zlfm (Not (NEq a)) = zlfm (Eq a)" | "zlfm (Not (Dvd i a)) = zlfm (NDvd i a)" | "zlfm (Not (NDvd i a)) = zlfm (Dvd i a)" | "zlfm (Not (Closed P)) = NClosed P" | "zlfm (Not (NClosed P)) = Closed P" | "zlfm p = p" lemma zlfm_I: assumes qfp: "qfree p" shows "Ifm bbs (i # bs) (zlfm p) = Ifm bbs (i # bs) p \ iszlfm (zlfm p)" (is "?I (?l p) = ?I p \ ?L (?l p)") using qfp proof (induct p rule: zlfm.induct) case (5 a) let ?c = "fst (zsplit0 a)" let ?r = "snd (zsplit0 a)" have spl: "zsplit0 a = (?c, ?r)" by simp from zsplit0_I[OF spl, where x="i" and bs="bs"] have Ia: "Inum (i # bs) a = Inum (i #bs) (CN 0 ?c ?r)" and nb: "numbound0 ?r" by auto let ?N = "\t. Inum (i # bs) t" from 5 Ia nb show ?case apply (auto simp add: Let_def split_def algebra_simps) apply (cases "?r") apply auto subgoal for nat a b by (cases nat) auto done next case (6 a) let ?c = "fst (zsplit0 a)" let ?r = "snd (zsplit0 a)" have spl: "zsplit0 a = (?c, ?r)" by simp from zsplit0_I[OF spl, where x="i" and bs="bs"] have Ia: "Inum (i # bs) a = Inum (i #bs) (CN 0 ?c ?r)" and nb: "numbound0 ?r" by auto let ?N = "\t. Inum (i # bs) t" from 6 Ia nb show ?case apply (auto simp add: Let_def split_def algebra_simps) apply (cases "?r") apply auto subgoal for nat a b by (cases nat) auto done next case (7 a) let ?c = "fst (zsplit0 a)" let ?r = "snd (zsplit0 a)" have spl: "zsplit0 a = (?c, ?r)" by simp from zsplit0_I[OF spl, where x="i" and bs="bs"] have Ia: "Inum (i # bs) a = Inum (i #bs) (CN 0 ?c ?r)" and nb: "numbound0 ?r" by auto let ?N = "\t. Inum (i # bs) t" from 7 Ia nb show ?case apply (auto simp add: Let_def split_def algebra_simps) apply (cases "?r") apply auto subgoal for nat a b by (cases nat) auto done next case (8 a) let ?c = "fst (zsplit0 a)" let ?r = "snd (zsplit0 a)" have spl: "zsplit0 a = (?c, ?r)" by simp from zsplit0_I[OF spl, where x="i" and bs="bs"] have Ia: "Inum (i # bs) a = Inum (i #bs) (CN 0 ?c ?r)" and nb: "numbound0 ?r" by auto let ?N = "\t. Inum (i # bs) t" from 8 Ia nb show ?case apply (auto simp add: Let_def split_def algebra_simps) apply (cases "?r") apply auto subgoal for nat a b by (cases nat) auto done next case (9 a) let ?c = "fst (zsplit0 a)" let ?r = "snd (zsplit0 a)" have spl: "zsplit0 a = (?c, ?r)" by simp from zsplit0_I[OF spl, where x="i" and bs="bs"] have Ia:"Inum (i # bs) a = Inum (i #bs) (CN 0 ?c ?r)" and nb: "numbound0 ?r" by auto let ?N = "\t. Inum (i # bs) t" from 9 Ia nb show ?case apply (auto simp add: Let_def split_def algebra_simps) apply (cases "?r") apply auto subgoal for nat a b by (cases nat) auto done next case (10 a) let ?c = "fst (zsplit0 a)" let ?r = "snd (zsplit0 a)" have spl: "zsplit0 a = (?c, ?r)" by simp from zsplit0_I[OF spl, where x="i" and bs="bs"] have Ia: "Inum (i # bs) a = Inum (i #bs) (CN 0 ?c ?r)" and nb: "numbound0 ?r" by auto let ?N = "\t. Inum (i # bs) t" from 10 Ia nb show ?case apply (auto simp add: Let_def split_def algebra_simps) apply (cases "?r") apply auto subgoal for nat a b by (cases nat) auto done next case (11 j a) let ?c = "fst (zsplit0 a)" let ?r = "snd (zsplit0 a)" have spl: "zsplit0 a = (?c,?r)" by simp from zsplit0_I[OF spl, where x="i" and bs="bs"] have Ia: "Inum (i # bs) a = Inum (i #bs) (CN 0 ?c ?r)" and nb: "numbound0 ?r" by auto let ?N = "\t. Inum (i#bs) t" consider "j = 0" | "j \ 0" "?c = 0" | "j \ 0" "?c > 0" | "j \ 0" "?c < 0" by arith then show ?case proof cases case 1 then have z: "zlfm (Dvd j a) = (zlfm (Eq a))" by (simp add: Let_def) with 11 \j = 0\ show ?thesis by (simp del: zlfm.simps) next case 2 with zsplit0_I[OF spl, where x="i" and bs="bs"] show ?thesis apply (auto simp add: Let_def split_def algebra_simps) apply (cases "?r") apply auto subgoal for nat a b by (cases nat) auto done next case 3 then have l: "?L (?l (Dvd j a))" by (simp add: nb Let_def split_def) with Ia 3 show ?thesis by (simp add: Let_def split_def) next case 4 then have l: "?L (?l (Dvd j a))" by (simp add: nb Let_def split_def) with Ia 4 dvd_minus_iff[of "\j\" "?c*i + ?N ?r"] show ?thesis by (simp add: Let_def split_def) qed next case (12 j a) let ?c = "fst (zsplit0 a)" let ?r = "snd (zsplit0 a)" have spl: "zsplit0 a = (?c, ?r)" by simp from zsplit0_I[OF spl, where x="i" and bs="bs"] have Ia: "Inum (i # bs) a = Inum (i #bs) (CN 0 ?c ?r)" and nb: "numbound0 ?r" by auto let ?N = "\t. Inum (i # bs) t" consider "j = 0" | "j \ 0" "?c = 0" | "j \ 0" "?c > 0" | "j \ 0" "?c < 0" by arith then show ?case proof cases case 1 then have z: "zlfm (NDvd j a) = zlfm (NEq a)" by (simp add: Let_def) with assms 12 \j = 0\ show ?thesis by (simp del: zlfm.simps) next case 2 with zsplit0_I[OF spl, where x="i" and bs="bs"] show ?thesis apply (auto simp add: Let_def split_def algebra_simps) apply (cases "?r") apply auto subgoal for nat a b by (cases nat) auto done next case 3 then have l: "?L (?l (Dvd j a))" by (simp add: nb Let_def split_def) with Ia 3 show ?thesis by (simp add: Let_def split_def) next case 4 then have l: "?L (?l (Dvd j a))" by (simp add: nb Let_def split_def) with Ia 4 dvd_minus_iff[of "\j\" "?c*i + ?N ?r"] show ?thesis by (simp add: Let_def split_def) qed qed auto fun minusinf :: "fm \ fm" \ \virtual substitution of \-\\\ where "minusinf (And p q) = And (minusinf p) (minusinf q)" | "minusinf (Or p q) = Or (minusinf p) (minusinf q)" | "minusinf (Eq (CN 0 c e)) = F" | "minusinf (NEq (CN 0 c e)) = T" | "minusinf (Lt (CN 0 c e)) = T" | "minusinf (Le (CN 0 c e)) = T" | "minusinf (Gt (CN 0 c e)) = F" | "minusinf (Ge (CN 0 c e)) = F" | "minusinf p = p" lemma minusinf_qfree: "qfree p \ qfree (minusinf p)" by (induct p rule: minusinf.induct) auto fun plusinf :: "fm \ fm" \ \virtual substitution of \+\\\ where "plusinf (And p q) = And (plusinf p) (plusinf q)" | "plusinf (Or p q) = Or (plusinf p) (plusinf q)" | "plusinf (Eq (CN 0 c e)) = F" | "plusinf (NEq (CN 0 c e)) = T" | "plusinf (Lt (CN 0 c e)) = F" | "plusinf (Le (CN 0 c e)) = F" | "plusinf (Gt (CN 0 c e)) = T" | "plusinf (Ge (CN 0 c e)) = T" | "plusinf p = p" fun \ :: "fm \ int" \ \compute \lcm {d| N\<^sup>? Dvd c*x+t \ p}\\ where "\ (And p q) = lcm (\ p) (\ q)" | "\ (Or p q) = lcm (\ p) (\ q)" | "\ (Dvd i (CN 0 c e)) = i" | "\ (NDvd i (CN 0 c e)) = i" | "\ p = 1" fun d_\ :: "fm \ int \ bool" \ \check if a given \l\ divides all the \ds\ above\ where "d_\ (And p q) d \ d_\ p d \ d_\ q d" | "d_\ (Or p q) d \ d_\ p d \ d_\ q d" | "d_\ (Dvd i (CN 0 c e)) d \ i dvd d" | "d_\ (NDvd i (CN 0 c e)) d \ i dvd d" | "d_\ p d \ True" lemma delta_mono: assumes lin: "iszlfm p" and d: "d dvd d'" and ad: "d_\ p d" shows "d_\ p d'" using lin ad proof (induct p rule: iszlfm.induct) case (9 i c e) then show ?case using d by (simp add: dvd_trans[of "i" "d" "d'"]) next case (10 i c e) then show ?case using d by (simp add: dvd_trans[of "i" "d" "d'"]) qed simp_all lemma \: assumes lin: "iszlfm p" shows "d_\ p (\ p) \ \ p >0" using lin by (induct p rule: iszlfm.induct) (auto intro: delta_mono simp add: lcm_pos_int) fun a_\ :: "fm \ int \ fm" \ \adjust the coefficients of a formula\ where "a_\ (And p q) k = And (a_\ p k) (a_\ q k)" | "a_\ (Or p q) k = Or (a_\ p k) (a_\ q k)" | "a_\ (Eq (CN 0 c e)) k = Eq (CN 0 1 (Mul (k div c) e))" | "a_\ (NEq (CN 0 c e)) k = NEq (CN 0 1 (Mul (k div c) e))" | "a_\ (Lt (CN 0 c e)) k = Lt (CN 0 1 (Mul (k div c) e))" | "a_\ (Le (CN 0 c e)) k = Le (CN 0 1 (Mul (k div c) e))" | "a_\ (Gt (CN 0 c e)) k = Gt (CN 0 1 (Mul (k div c) e))" | "a_\ (Ge (CN 0 c e)) k = Ge (CN 0 1 (Mul (k div c) e))" | "a_\ (Dvd i (CN 0 c e)) k = Dvd ((k div c)*i) (CN 0 1 (Mul (k div c) e))" | "a_\ (NDvd i (CN 0 c e)) k = NDvd ((k div c)*i) (CN 0 1 (Mul (k div c) e))" | "a_\ p k = p" fun d_\ :: "fm \ int \ bool" \ \test if all coeffs of \c\ divide a given \l\\ where "d_\ (And p q) k \ d_\ p k \ d_\ q k" | "d_\ (Or p q) k \ d_\ p k \ d_\ q k" | "d_\ (Eq (CN 0 c e)) k \ c dvd k" | "d_\ (NEq (CN 0 c e)) k \ c dvd k" | "d_\ (Lt (CN 0 c e)) k \ c dvd k" | "d_\ (Le (CN 0 c e)) k \ c dvd k" | "d_\ (Gt (CN 0 c e)) k \ c dvd k" | "d_\ (Ge (CN 0 c e)) k \ c dvd k" | "d_\ (Dvd i (CN 0 c e)) k \ c dvd k" | "d_\ (NDvd i (CN 0 c e)) k \ c dvd k" | "d_\ p k \ True" fun \ :: "fm \ int" \ \computes the lcm of all coefficients of \x\\ where "\ (And p q) = lcm (\ p) (\ q)" | "\ (Or p q) = lcm (\ p) (\ q)" | "\ (Eq (CN 0 c e)) = c" | "\ (NEq (CN 0 c e)) = c" | "\ (Lt (CN 0 c e)) = c" | "\ (Le (CN 0 c e)) = c" | "\ (Gt (CN 0 c e)) = c" | "\ (Ge (CN 0 c e)) = c" | "\ (Dvd i (CN 0 c e)) = c" | "\ (NDvd i (CN 0 c e))= c" | "\ p = 1" fun \ :: "fm \ num list" where "\ (And p q) = (\ p @ \ q)" | "\ (Or p q) = (\ p @ \ q)" | "\ (Eq (CN 0 c e)) = [Sub (C (- 1)) e]" | "\ (NEq (CN 0 c e)) = [Neg e]" | "\ (Lt (CN 0 c e)) = []" | "\ (Le (CN 0 c e)) = []" | "\ (Gt (CN 0 c e)) = [Neg e]" | "\ (Ge (CN 0 c e)) = [Sub (C (- 1)) e]" | "\ p = []" fun \ :: "fm \ num list" where "\ (And p q) = \ p @ \ q" | "\ (Or p q) = \ p @ \ q" | "\ (Eq (CN 0 c e)) = [Add (C (- 1)) e]" | "\ (NEq (CN 0 c e)) = [e]" | "\ (Lt (CN 0 c e)) = [e]" | "\ (Le (CN 0 c e)) = [Add (C (- 1)) e]" | "\ (Gt (CN 0 c e)) = []" | "\ (Ge (CN 0 c e)) = []" | "\ p = []" fun mirror :: "fm \ fm" where "mirror (And p q) = And (mirror p) (mirror q)" | "mirror (Or p q) = Or (mirror p) (mirror q)" | "mirror (Eq (CN 0 c e)) = Eq (CN 0 c (Neg e))" | "mirror (NEq (CN 0 c e)) = NEq (CN 0 c (Neg e))" | "mirror (Lt (CN 0 c e)) = Gt (CN 0 c (Neg e))" | "mirror (Le (CN 0 c e)) = Ge (CN 0 c (Neg e))" | "mirror (Gt (CN 0 c e)) = Lt (CN 0 c (Neg e))" | "mirror (Ge (CN 0 c e)) = Le (CN 0 c (Neg e))" | "mirror (Dvd i (CN 0 c e)) = Dvd i (CN 0 c (Neg e))" | "mirror (NDvd i (CN 0 c e)) = NDvd i (CN 0 c (Neg e))" | "mirror p = p" text \Lemmas for the correctness of \\_\\\ lemma dvd1_eq1: "x > 0 \ x dvd 1 \ x = 1" for x :: int by simp lemma minusinf_inf: assumes linp: "iszlfm p" and u: "d_\ p 1" shows "\z::int. \x < z. Ifm bbs (x # bs) (minusinf p) = Ifm bbs (x # bs) p" (is "?P p" is "\(z::int). \x < z. ?I x (?M p) = ?I x p") using linp u proof (induct p rule: minusinf.induct) case (1 p q) then show ?case apply auto subgoal for z z' by (rule exI [where x = "min z z'"]) simp done next case (2 p q) then show ?case apply auto subgoal for z z' by (rule exI [where x = "min z z'"]) simp done next case (3 c e) then have c1: "c = 1" and nb: "numbound0 e" by simp_all fix a from 3 have "\x<(- Inum (a # bs) e). c * x + Inum (x # bs) e \ 0" proof clarsimp fix x assume "x < (- Inum (a # bs) e)" and "x + Inum (x # bs) e = 0" with numbound0_I[OF nb, where bs="bs" and b="a" and b'="x"] show False by simp qed then show ?case by auto next case (4 c e) then have c1: "c = 1" and nb: "numbound0 e" by simp_all fix a from 4 have "\x < (- Inum (a # bs) e). c * x + Inum (x # bs) e \ 0" proof clarsimp fix x assume "x < (- Inum (a # bs) e)" and "x + Inum (x # bs) e = 0" with numbound0_I[OF nb, where bs="bs" and b="a" and b'="x"] show "False" by simp qed then show ?case by auto next case (5 c e) then have c1: "c = 1" and nb: "numbound0 e" by simp_all fix a from 5 have "\x<(- Inum (a # bs) e). c * x + Inum (x # bs) e < 0" proof clarsimp fix x assume "x < (- Inum (a # bs) e)" with numbound0_I[OF nb, where bs="bs" and b="a" and b'="x"] show "x + Inum (x # bs) e < 0" by simp qed then show ?case by auto next case (6 c e) then have c1: "c = 1" and nb: "numbound0 e" by simp_all fix a from 6 have "\x<(- Inum (a # bs) e). c * x + Inum (x # bs) e \ 0" proof clarsimp fix x assume "x < (- Inum (a # bs) e)" with numbound0_I[OF nb, where bs="bs" and b="a" and b'="x"] show "x + Inum (x # bs) e \ 0" by simp qed then show ?case by auto next case (7 c e) then have c1: "c = 1" and nb: "numbound0 e" by simp_all fix a from 7 have "\x<(- Inum (a # bs) e). \ (c * x + Inum (x # bs) e > 0)" proof clarsimp fix x assume "x < - Inum (a # bs) e" and "x + Inum (x # bs) e > 0" with numbound0_I[OF nb, where bs="bs" and b="a" and b'="x"] show False by simp qed then show ?case by auto next case (8 c e) then have c1: "c = 1" and nb: "numbound0 e" by simp_all fix a from 8 have "\x<(- Inum (a # bs) e). \ c * x + Inum (x # bs) e \ 0" proof clarsimp fix x assume "x < (- Inum (a # bs) e)" and "x + Inum (x # bs) e \ 0" with numbound0_I[OF nb, where bs="bs" and b="a" and b'="x"] show False by simp qed then show ?case by auto qed auto lemma minusinf_repeats: assumes d: "d_\ p d" and linp: "iszlfm p" shows "Ifm bbs ((x - k * d) # bs) (minusinf p) = Ifm bbs (x # bs) (minusinf p)" using linp d proof (induct p rule: iszlfm.induct) case (9 i c e) then have nbe: "numbound0 e" and id: "i dvd d" by simp_all then have "\k. d = i * k" by (simp add: dvd_def) then obtain "di" where di_def: "d = i * di" by blast show ?case proof (simp add: numbound0_I[OF nbe,where bs="bs" and b="x - k * d" and b'="x"] right_diff_distrib, rule iffI) assume "i dvd c * x - c * (k * d) + Inum (x # bs) e" (is "?ri dvd ?rc * ?rx - ?rc * (?rk * ?rd) + ?I x e" is "?ri dvd ?rt") then have "\l::int. ?rt = i * l" by (simp add: dvd_def) then have "\l::int. c * x + ?I x e = i * l + c * (k * i * di)" by (simp add: algebra_simps di_def) then have "\l::int. c * x + ?I x e = i* (l + c * k * di)" by (simp add: algebra_simps) then have "\l::int. c * x + ?I x e = i * l" by blast then show "i dvd c * x + Inum (x # bs) e" by (simp add: dvd_def) next assume "i dvd c * x + Inum (x # bs) e" (is "?ri dvd ?rc * ?rx + ?e") then have "\l::int. c * x + ?e = i * l" by (simp add: dvd_def) then have "\l::int. c * x - c * (k * d) + ?e = i * l - c * (k * d)" by simp then have "\l::int. c * x - c * (k * d) + ?e = i * l - c * (k * i * di)" by (simp add: di_def) then have "\l::int. c * x - c * (k * d) + ?e = i * (l - c * k * di)" by (simp add: algebra_simps) then have "\l::int. c * x - c * (k * d) + ?e = i * l" by blast then show "i dvd c * x - c * (k * d) + Inum (x # bs) e" by (simp add: dvd_def) qed next case (10 i c e) then have nbe: "numbound0 e" and id: "i dvd d" by simp_all then have "\k. d = i * k" by (simp add: dvd_def) then obtain di where di_def: "d = i * di" by blast show ?case proof (simp add: numbound0_I[OF nbe,where bs="bs" and b="x - k * d" and b'="x"] right_diff_distrib, rule iffI) assume "i dvd c * x - c * (k * d) + Inum (x # bs) e" (is "?ri dvd ?rc * ?rx - ?rc * (?rk * ?rd) + ?I x e" is "?ri dvd ?rt") then have "\l::int. ?rt = i * l" by (simp add: dvd_def) then have "\l::int. c * x + ?I x e = i * l + c * (k * i * di)" by (simp add: algebra_simps di_def) then have "\l::int. c * x+ ?I x e = i * (l + c * k * di)" by (simp add: algebra_simps) then have "\l::int. c * x + ?I x e = i * l" by blast then show "i dvd c * x + Inum (x # bs) e" by (simp add: dvd_def) next assume "i dvd c * x + Inum (x # bs) e" (is "?ri dvd ?rc * ?rx + ?e") then have "\l::int. c * x + ?e = i * l" by (simp add: dvd_def) then have "\l::int. c * x - c * (k * d) + ?e = i * l - c * (k * d)" by simp then have "\l::int. c * x - c * (k * d) + ?e = i * l - c * (k * i * di)" by (simp add: di_def) then have "\l::int. c * x - c * (k * d) + ?e = i * (l - c * k * di)" by (simp add: algebra_simps) then have "\l::int. c * x - c * (k * d) + ?e = i * l" by blast then show "i dvd c * x - c * (k * d) + Inum (x # bs) e" by (simp add: dvd_def) qed qed (auto simp add: gr0_conv_Suc numbound0_I[where bs="bs" and b="x - k*d" and b'="x"]) lemma mirror_\_\: assumes lp: "iszlfm p" shows "Inum (i # bs) ` set (\ p) = Inum (i # bs) ` set (\ (mirror p))" using lp by (induct p rule: mirror.induct) auto lemma mirror: assumes lp: "iszlfm p" shows "Ifm bbs (x # bs) (mirror p) = Ifm bbs ((- x) # bs) p" using lp proof (induct p rule: iszlfm.induct) case (9 j c e) then have nb: "numbound0 e" by simp have "Ifm bbs (x # bs) (mirror (Dvd j (CN 0 c e))) \ j dvd c * x - Inum (x # bs) e" (is "_ = (j dvd c*x - ?e)") by simp also have "\ \ j dvd (- (c * x - ?e))" by (simp only: dvd_minus_iff) also have "\ \ j dvd (c * (- x)) + ?e" by (simp only: minus_mult_right[symmetric] minus_mult_left[symmetric] ac_simps minus_add_distrib) (simp add: algebra_simps) also have "\ = Ifm bbs ((- x) # bs) (Dvd j (CN 0 c e))" using numbound0_I[OF nb, where bs="bs" and b="x" and b'="- x"] by simp finally show ?case . next case (10 j c e) then have nb: "numbound0 e" by simp have "Ifm bbs (x # bs) (mirror (Dvd j (CN 0 c e))) \ j dvd c * x - Inum (x # bs) e" (is "_ = (j dvd c * x - ?e)") by simp also have "\ \ j dvd (- (c * x - ?e))" by (simp only: dvd_minus_iff) also have "\ \ j dvd (c * (- x)) + ?e" by (simp only: minus_mult_right[symmetric] minus_mult_left[symmetric] ac_simps minus_add_distrib) (simp add: algebra_simps) also have "\ \ Ifm bbs ((- x) # bs) (Dvd j (CN 0 c e))" using numbound0_I[OF nb, where bs="bs" and b="x" and b'="- x"] by simp finally show ?case by simp qed (auto simp add: numbound0_I[where bs="bs" and b="x" and b'="- x"] gr0_conv_Suc) lemma mirror_l: "iszlfm p \ d_\ p 1 \ iszlfm (mirror p) \ d_\ (mirror p) 1" by (induct p rule: mirror.induct) auto lemma mirror_\: "iszlfm p \ \ (mirror p) = \ p" by (induct p rule: mirror.induct) auto lemma \_numbound0: assumes lp: "iszlfm p" shows "\b \ set (\ p). numbound0 b" using lp by (induct p rule: \.induct) auto lemma d_\_mono: assumes linp: "iszlfm p" and dr: "d_\ p l" and d: "l dvd l'" shows "d_\ p l'" using dr linp dvd_trans[of _ "l" "l'", simplified d] by (induct p rule: iszlfm.induct) simp_all lemma \_l: assumes "iszlfm p" shows "\b \ set (\ p). numbound0 b" using assms by (induct p rule: \.induct) auto lemma \: assumes "iszlfm p" shows "\ p > 0 \ d_\ p (\ p)" using assms proof (induct p rule: iszlfm.induct) case (1 p q) from 1 have dl1: "\ p dvd lcm (\ p) (\ q)" by simp from 1 have dl2: "\ q dvd lcm (\ p) (\ q)" by simp from 1 d_\_mono[where p = "p" and l="\ p" and l'="lcm (\ p) (\ q)"] d_\_mono[where p = "q" and l="\ q" and l'="lcm (\ p) (\ q)"] dl1 dl2 show ?case by (auto simp add: lcm_pos_int) next case (2 p q) from 2 have dl1: "\ p dvd lcm (\ p) (\ q)" by simp from 2 have dl2: "\ q dvd lcm (\ p) (\ q)" by simp from 2 d_\_mono[where p = "p" and l="\ p" and l'="lcm (\ p) (\ q)"] d_\_mono[where p = "q" and l="\ q" and l'="lcm (\ p) (\ q)"] dl1 dl2 show ?case by (auto simp add: lcm_pos_int) qed (auto simp add: lcm_pos_int) lemma a_\: assumes linp: "iszlfm p" and d: "d_\ p l" and lp: "l > 0" shows "iszlfm (a_\ p l) \ d_\ (a_\ p l) 1 \ Ifm bbs (l * x # bs) (a_\ p l) = Ifm bbs (x # bs) p" using linp d proof (induct p rule: iszlfm.induct) case (5 c e) then have cp: "c > 0" and be: "numbound0 e" and d': "c dvd l" by simp_all from lp cp have clel: "c \ l" by (simp add: zdvd_imp_le [OF d' lp]) from cp have cnz: "c \ 0" by simp have "c div c \ l div c" by (simp add: zdiv_mono1[OF clel cp]) then have ldcp: "0 < l div c" by (simp add: div_self[OF cnz]) have "c * (l div c) = c * (l div c) + l mod c" using d' dvd_eq_mod_eq_0[of "c" "l"] by simp then have cl: "c * (l div c) =l" using mult_div_mod_eq [where a="l" and b="c"] by simp then have "(l * x + (l div c) * Inum (x # bs) e < 0) \ ((c * (l div c)) * x + (l div c) * Inum (x # bs) e < 0)" by simp also have "\ \ (l div c) * (c * x + Inum (x # bs) e) < (l div c) * 0" by (simp add: algebra_simps) also have "\ \ c * x + Inum (x # bs) e < 0" using mult_less_0_iff [where a="(l div c)" and b="c*x + Inum (x # bs) e"] ldcp by simp finally show ?case using numbound0_I[OF be,where b="l*x" and b'="x" and bs="bs"] be by simp next case (6 c e) then have cp: "c > 0" and be: "numbound0 e" and d': "c dvd l" by simp_all from lp cp have clel: "c \ l" by (simp add: zdvd_imp_le [OF d' lp]) from cp have cnz: "c \ 0" by simp have "c div c \ l div c" by (simp add: zdiv_mono1[OF clel cp]) then have ldcp:"0 < l div c" by (simp add: div_self[OF cnz]) have "c * (l div c) = c * (l div c) + l mod c" using d' dvd_eq_mod_eq_0[of "c" "l"] by simp then have cl: "c * (l div c) = l" using mult_div_mod_eq [where a="l" and b="c"] by simp then have "l * x + (l div c) * Inum (x # bs) e \ 0 \ (c * (l div c)) * x + (l div c) * Inum (x # bs) e \ 0" by simp also have "\ \ (l div c) * (c * x + Inum (x # bs) e) \ (l div c) * 0" by (simp add: algebra_simps) also have "\ \ c * x + Inum (x # bs) e \ 0" using mult_le_0_iff [where a="(l div c)" and b="c*x + Inum (x # bs) e"] ldcp by simp finally show ?case using numbound0_I[OF be,where b="l*x" and b'="x" and bs="bs"] be by simp next case (7 c e) then have cp: "c > 0" and be: "numbound0 e" and d': "c dvd l" by simp_all from lp cp have clel: "c \ l" by (simp add: zdvd_imp_le [OF d' lp]) from cp have cnz: "c \ 0" by simp have "c div c \ l div c" by (simp add: zdiv_mono1[OF clel cp]) then have ldcp: "0 < l div c" by (simp add: div_self[OF cnz]) have "c * (l div c) = c * (l div c) + l mod c" using d' dvd_eq_mod_eq_0[of "c" "l"] by simp then have cl: "c * (l div c) = l" using mult_div_mod_eq [where a="l" and b="c"] by simp then have "l * x + (l div c) * Inum (x # bs) e > 0 \ (c * (l div c)) * x + (l div c) * Inum (x # bs) e > 0" by simp also have "\ \ (l div c) * (c * x + Inum (x # bs) e) > (l div c) * 0" by (simp add: algebra_simps) also have "\ \ c * x + Inum (x # bs) e > 0" using zero_less_mult_iff [where a="(l div c)" and b="c * x + Inum (x # bs) e"] ldcp by simp finally show ?case using numbound0_I[OF be,where b="(l * x)" and b'="x" and bs="bs"] be by simp next case (8 c e) then have cp: "c > 0" and be: "numbound0 e" and d': "c dvd l" by simp_all from lp cp have clel: "c \ l" by (simp add: zdvd_imp_le [OF d' lp]) from cp have cnz: "c \ 0" by simp have "c div c \ l div c" by (simp add: zdiv_mono1[OF clel cp]) then have ldcp: "0 < l div c" by (simp add: div_self[OF cnz]) have "c * (l div c) = c * (l div c) + l mod c" using d' dvd_eq_mod_eq_0[of "c" "l"] by simp then have cl: "c * (l div c) =l" using mult_div_mod_eq [where a="l" and b="c"] by simp then have "l * x + (l div c) * Inum (x # bs) e \ 0 \ (c * (l div c)) * x + (l div c) * Inum (x # bs) e \ 0" by simp also have "\ \ (l div c) * (c * x + Inum (x # bs) e) \ (l div c) * 0" by (simp add: algebra_simps) also have "\ \ c * x + Inum (x # bs) e \ 0" using ldcp zero_le_mult_iff [where a="l div c" and b="c*x + Inum (x # bs) e"] by simp finally show ?case using be numbound0_I[OF be,where b="l*x" and b'="x" and bs="bs"] by simp next case (3 c e) then have cp: "c > 0" and be: "numbound0 e" and d': "c dvd l" by simp_all from lp cp have clel: "c \ l" by (simp add: zdvd_imp_le [OF d' lp]) from cp have cnz: "c \ 0" by simp have "c div c \ l div c" by (simp add: zdiv_mono1[OF clel cp]) then have ldcp:"0 < l div c" by (simp add: div_self[OF cnz]) have "c * (l div c) = c * (l div c) + l mod c" using d' dvd_eq_mod_eq_0[of "c" "l"] by simp then have cl:"c * (l div c) =l" using mult_div_mod_eq [where a="l" and b="c"] by simp then have "l * x + (l div c) * Inum (x # bs) e = 0 \ (c * (l div c)) * x + (l div c) * Inum (x # bs) e = 0" by simp also have "\ \ (l div c) * (c * x + Inum (x # bs) e) = ((l div c)) * 0" by (simp add: algebra_simps) also have "\ \ c * x + Inum (x # bs) e = 0" using mult_eq_0_iff [where a="(l div c)" and b="c * x + Inum (x # bs) e"] ldcp by simp finally show ?case using numbound0_I[OF be,where b="(l * x)" and b'="x" and bs="bs"] be by simp next case (4 c e) then have cp: "c > 0" and be: "numbound0 e" and d': "c dvd l" by simp_all from lp cp have clel: "c \ l" by (simp add: zdvd_imp_le [OF d' lp]) from cp have cnz: "c \ 0" by simp have "c div c \ l div c" by (simp add: zdiv_mono1[OF clel cp]) then have ldcp:"0 < l div c" by (simp add: div_self[OF cnz]) have "c * (l div c) = c * (l div c) + l mod c" using d' dvd_eq_mod_eq_0[of "c" "l"] by simp then have cl: "c * (l div c) = l" using mult_div_mod_eq [where a="l" and b="c"] by simp then have "l * x + (l div c) * Inum (x # bs) e \ 0 \ (c * (l div c)) * x + (l div c) * Inum (x # bs) e \ 0" by simp also have "\ \ (l div c) * (c * x + Inum (x # bs) e) \ (l div c) * 0" by (simp add: algebra_simps) also have "\ \ c * x + Inum (x # bs) e \ 0" using zero_le_mult_iff [where a="(l div c)" and b="c * x + Inum (x # bs) e"] ldcp by simp finally show ?case using numbound0_I[OF be,where b="(l * x)" and b'="x" and bs="bs"] be by simp next case (9 j c e) then have cp: "c > 0" and be: "numbound0 e" and jp: "j > 0" and d': "c dvd l" by simp_all from lp cp have clel: "c \ l" by (simp add: zdvd_imp_le [OF d' lp]) from cp have cnz: "c \ 0" by simp have "c div c\ l div c" by (simp add: zdiv_mono1[OF clel cp]) then have ldcp:"0 < l div c" by (simp add: div_self[OF cnz]) have "c * (l div c) = c * (l div c) + l mod c" using d' dvd_eq_mod_eq_0[of "c" "l"] by simp then have cl: "c * (l div c) = l" using mult_div_mod_eq [where a="l" and b="c"] by simp then have "(\k::int. l * x + (l div c) * Inum (x # bs) e = ((l div c) * j) * k) \ (\k::int. (c * (l div c)) * x + (l div c) * Inum (x # bs) e = ((l div c) * j) * k)" by simp also have "\ \ (\k::int. (l div c) * (c * x + Inum (x # bs) e - j * k) = (l div c) * 0)" by (simp add: algebra_simps) also have "\ \ (\k::int. c * x + Inum (x # bs) e - j * k = 0)" using zero_le_mult_iff [where a="(l div c)" and b="c * x + Inum (x # bs) e - j * k" for k] ldcp by simp also have "\ \ (\k::int. c * x + Inum (x # bs) e = j * k)" by simp finally show ?case using numbound0_I[OF be,where b="(l * x)" and b'="x" and bs="bs"] be mult_strict_mono[OF ldcp jp ldcp ] by (simp add: dvd_def) next case (10 j c e) then have cp: "c > 0" and be: "numbound0 e" and jp: "j > 0" and d': "c dvd l" by simp_all from lp cp have clel: "c \ l" by (simp add: zdvd_imp_le [OF d' lp]) from cp have cnz: "c \ 0" by simp have "c div c \ l div c" by (simp add: zdiv_mono1[OF clel cp]) then have ldcp: "0 < l div c" by (simp add: div_self[OF cnz]) have "c * (l div c) = c* (l div c) + l mod c" using d' dvd_eq_mod_eq_0[of "c" "l"] by simp then have cl:"c * (l div c) =l" using mult_div_mod_eq [where a="l" and b="c"] by simp then have "(\k::int. l * x + (l div c) * Inum (x # bs) e = ((l div c) * j) * k) \ (\k::int. (c * (l div c)) * x + (l div c) * Inum (x # bs) e = ((l div c) * j) * k)" by simp also have "\ \ (\k::int. (l div c) * (c * x + Inum (x # bs) e - j * k) = (l div c) * 0)" by (simp add: algebra_simps) also have "\ \ (\k::int. c * x + Inum (x # bs) e - j * k = 0)" using zero_le_mult_iff [where a="(l div c)" and b="c * x + Inum (x # bs) e - j * k" for k] ldcp by simp also have "\ \ (\k::int. c * x + Inum (x # bs) e = j * k)" by simp finally show ?case using numbound0_I[OF be,where b="(l * x)" and b'="x" and bs="bs"] be mult_strict_mono[OF ldcp jp ldcp ] by (simp add: dvd_def) qed (auto simp add: gr0_conv_Suc numbound0_I[where bs="bs" and b="(l * x)" and b'="x"]) lemma a_\_ex: assumes linp: "iszlfm p" and d: "d_\ p l" and lp: "l > 0" shows "(\x. l dvd x \ Ifm bbs (x #bs) (a_\ p l)) \ (\x::int. Ifm bbs (x#bs) p)" (is "(\x. l dvd x \ ?P x) \ (\x. ?P' x)") proof- have "(\x. l dvd x \ ?P x) \ (\x::int. ?P (l * x))" using unity_coeff_ex[where l="l" and P="?P", simplified] by simp also have "\ = (\x::int. ?P' x)" using a_\[OF linp d lp] by simp finally show ?thesis . qed lemma \: assumes "iszlfm p" and "d_\ p 1" and "d_\ p d" and dp: "d > 0" and "\ (\j::int \ {1 .. d}. \b \ Inum (a # bs) ` set (\ p). x = b + j)" and p: "Ifm bbs (x # bs) p" (is "?P x") shows "?P (x - d)" using assms proof (induct p rule: iszlfm.induct) case (5 c e) then have c1: "c = 1" and bn: "numbound0 e" by simp_all with dp p c1 numbound0_I[OF bn,where b = "(x - d)" and b' = "x" and bs = "bs"] 5 show ?case by simp next case (6 c e) then have c1: "c = 1" and bn: "numbound0 e" by simp_all with dp p c1 numbound0_I[OF bn,where b="(x-d)" and b'="x" and bs="bs"] 6 show ?case by simp next case (7 c e) then have p: "Ifm bbs (x # bs) (Gt (CN 0 c e))" and c1: "c=1" and bn: "numbound0 e" by simp_all let ?e = "Inum (x # bs) e" show ?case proof (cases "(x - d) + ?e > 0") case True then show ?thesis using c1 numbound0_I[OF bn,where b="(x-d)" and b'="x" and bs="bs"] by simp next case False let ?v = "Neg e" have vb: "?v \ set (\ (Gt (CN 0 c e)))" by simp from 7(5)[simplified simp_thms Inum.simps \.simps list.set bex_simps numbound0_I[OF bn,where b="a" and b'="x" and bs="bs"]] have nob: "\ (\j\ {1 ..d}. x = - ?e + j)" by auto from False p have "x + ?e > 0 \ x + ?e \ d" by (simp add: c1) then have "x + ?e \ 1 \ x + ?e \ d" by simp then have "\j::int \ {1 .. d}. j = x + ?e" by simp then have "\j::int \ {1 .. d}. x = (- ?e + j)" by (simp add: algebra_simps) with nob show ?thesis by auto qed next case (8 c e) then have p: "Ifm bbs (x # bs) (Ge (CN 0 c e))" and c1: "c = 1" and bn: "numbound0 e" by simp_all let ?e = "Inum (x # bs) e" show ?case proof (cases "(x - d) + ?e \ 0") case True then show ?thesis using c1 numbound0_I[OF bn,where b="(x-d)" and b'="x" and bs="bs"] by simp next case False let ?v = "Sub (C (- 1)) e" have vb: "?v \ set (\ (Ge (CN 0 c e)))" by simp from 8(5)[simplified simp_thms Inum.simps \.simps list.set bex_simps numbound0_I[OF bn,where b="a" and b'="x" and bs="bs"]] have nob: "\ (\j\ {1 ..d}. x = - ?e - 1 + j)" by auto from False p have "x + ?e \ 0 \ x + ?e < d" by (simp add: c1) then have "x + ?e +1 \ 1 \ x + ?e + 1 \ d" by simp then have "\j::int \ {1 .. d}. j = x + ?e + 1" by simp then have "\j::int \ {1 .. d}. x= - ?e - 1 + j" by (simp add: algebra_simps) with nob show ?thesis by simp qed next case (3 c e) then have p: "Ifm bbs (x #bs) (Eq (CN 0 c e))" (is "?p x") and c1: "c = 1" and bn: "numbound0 e" by simp_all let ?e = "Inum (x # bs) e" let ?v="(Sub (C (- 1)) e)" have vb: "?v \ set (\ (Eq (CN 0 c e)))" by simp from p have "x= - ?e" by (simp add: c1) with 3(5) show ?case using dp apply simp apply (erule ballE[where x="1"]) apply (simp_all add:algebra_simps numbound0_I[OF bn,where b="x"and b'="a"and bs="bs"]) done next case (4 c e) then have p: "Ifm bbs (x # bs) (NEq (CN 0 c e))" (is "?p x") and c1: "c = 1" and bn: "numbound0 e" by simp_all let ?e = "Inum (x # bs) e" let ?v="Neg e" have vb: "?v \ set (\ (NEq (CN 0 c e)))" by simp show ?case proof (cases "x - d + Inum ((x - d) # bs) e = 0") case False then show ?thesis by (simp add: c1) next case True then have "x = - Inum ((x - d) # bs) e + d" by simp then have "x = - Inum (a # bs) e + d" by (simp add: numbound0_I[OF bn,where b="x - d"and b'="a"and bs="bs"]) with 4(5) show ?thesis using dp by simp qed next case (9 j c e) then have p: "Ifm bbs (x # bs) (Dvd j (CN 0 c e))" (is "?p x") and c1: "c = 1" and bn: "numbound0 e" by simp_all let ?e = "Inum (x # bs) e" from 9 have id: "j dvd d" by simp from c1 have "?p x \ j dvd (x + ?e)" by simp also have "\ \ j dvd x - d + ?e" using zdvd_period[OF id, where x="x" and c="-1" and t="?e"] by simp finally show ?case using numbound0_I[OF bn,where b="(x-d)" and b'="x" and bs="bs"] c1 p by simp next case (10 j c e) then have p: "Ifm bbs (x # bs) (NDvd j (CN 0 c e))" (is "?p x") and c1: "c = 1" and bn: "numbound0 e" by simp_all let ?e = "Inum (x # bs) e" from 10 have id: "j dvd d" by simp from c1 have "?p x \ \ j dvd (x + ?e)" by simp also have "\ \ \ j dvd x - d + ?e" using zdvd_period[OF id, where x="x" and c="-1" and t="?e"] by simp finally show ?case using numbound0_I[OF bn,where b="(x-d)" and b'="x" and bs="bs"] c1 p by simp qed (auto simp add: numbound0_I[where bs="bs" and b="(x - d)" and b'="x"] gr0_conv_Suc) lemma \': assumes lp: "iszlfm p" and u: "d_\ p 1" and d: "d_\ p d" and dp: "d > 0" shows "\x. \ (\j::int \ {1 .. d}. \b \ set(\ p). Ifm bbs ((Inum (a#bs) b + j) #bs) p) \ Ifm bbs (x # bs) p \ Ifm bbs ((x - d) # bs) p" (is "\x. ?b \ ?P x \ ?P (x - d)") proof clarify fix x assume nb: "?b" and px: "?P x" then have nb2: "\ (\j::int \ {1 .. d}. \b \ Inum (a # bs) ` set (\ p). x = b + j)" by auto show "?P (x - d)" by (rule \[OF lp u d dp nb2 px]) qed lemma cpmi_eq: fixes P P1 :: "int \ bool" assumes "0 < D" and "\z. \x. x < z \ P x = P1 x" and "\x. \ (\j \ {1..D}. \b \ B. P (b + j)) \ P x \ P (x - D)" and "\x k. P1 x = P1 (x - k * D)" shows "(\x. P x) \ (\j \ {1..D}. P1 j) \ (\j \ {1..D}. \b \ B. P (b + j))" apply (insert assms) apply (rule iffI) prefer 2 apply (drule minusinfinity) apply assumption+ apply fastforce apply clarsimp apply (subgoal_tac "\k. 0 \ k \ \x. P x \ P (x - k * D)") apply (frule_tac x = x and z=z in decr_lemma) apply (subgoal_tac "P1 (x - (\x - z\ + 1) * D)") prefer 2 apply (subgoal_tac "0 \ \x - z\ + 1") prefer 2 apply arith apply fastforce apply (drule (1) periodic_finite_ex) apply blast apply (blast dest: decr_mult_lemma) done theorem cp_thm: assumes lp: "iszlfm p" and u: "d_\ p 1" and d: "d_\ p d" and dp: "d > 0" shows "(\x. Ifm bbs (x # bs) p) \ (\j \ {1.. d}. Ifm bbs (j # bs) (minusinf p) \ (\b \ set (\ p). Ifm bbs ((Inum (i # bs) b + j) # bs) p))" (is "(\x. ?P x) \ (\j \ ?D. ?M j \ (\b \ ?B. ?P (?I b + j)))") proof - from minusinf_inf[OF lp u] have th: "\z. \xj\?D. \b \ ?B. ?P (?I b + j)) \ (\j \ ?D. \b \ ?B'. ?P (b + j))" by auto then have th2: "\x. \ (\j \ ?D. \b \ ?B'. ?P (b + j)) \ ?P x \ ?P (x - d)" using \'[OF lp u d dp, where a="i" and bbs = "bbs"] by blast from minusinf_repeats[OF d lp] have th3: "\x k. ?M x = ?M (x-k*d)" by simp from cpmi_eq[OF dp th th2 th3] BB' show ?thesis by blast qed text \Implement the right hand sides of Cooper's theorem and Ferrante and Rackoff.\ lemma mirror_ex: assumes "iszlfm p" shows "(\x. Ifm bbs (x#bs) (mirror p)) \ (\x. Ifm bbs (x#bs) p)" (is "(\x. ?I x ?mp) = (\x. ?I x p)") proof auto fix x assume "?I x ?mp" then have "?I (- x) p" using mirror[OF assms] by blast then show "\x. ?I x p" by blast next fix x assume "?I x p" then have "?I (- x) ?mp" using mirror[OF assms, where x="- x", symmetric] by auto then show "\x. ?I x ?mp" by blast qed lemma cp_thm': assumes "iszlfm p" and "d_\ p 1" and "d_\ p d" and "d > 0" shows "(\x. Ifm bbs (x # bs) p) \ ((\j\ {1 .. d}. Ifm bbs (j#bs) (minusinf p)) \ (\j\ {1.. d}. \b\ (Inum (i#bs)) ` set (\ p). Ifm bbs ((b + j) # bs) p))" using cp_thm[OF assms,where i="i"] by auto definition unit :: "fm \ fm \ num list \ int" where "unit p = (let p' = zlfm p; l = \ p'; q = And (Dvd l (CN 0 1 (C 0))) (a_\ p' l); d = \ q; B = remdups (map simpnum (\ q)); a = remdups (map simpnum (\ q)) in if length B \ length a then (q, B, d) else (mirror q, a, d))" lemma unit: assumes qf: "qfree p" fixes q B d assumes qBd: "unit p = (q, B, d)" shows "((\x. Ifm bbs (x # bs) p) \ (\x. Ifm bbs (x # bs) q)) \ (Inum (i # bs)) ` set B = (Inum (i # bs)) ` set (\ q) \ d_\ q 1 \ d_\ q d \ d > 0 \ iszlfm q \ (\b\ set B. numbound0 b)" proof - let ?I = "\x p. Ifm bbs (x#bs) p" let ?p' = "zlfm p" let ?l = "\ ?p'" let ?q = "And (Dvd ?l (CN 0 1 (C 0))) (a_\ ?p' ?l)" let ?d = "\ ?q" let ?B = "set (\ ?q)" let ?B'= "remdups (map simpnum (\ ?q))" let ?A = "set (\ ?q)" let ?A'= "remdups (map simpnum (\ ?q))" from conjunct1[OF zlfm_I[OF qf, where bs="bs"]] have pp': "\i. ?I i ?p' = ?I i p" by auto from conjunct2[OF zlfm_I[OF qf, where bs="bs" and i="i"]] have lp': "iszlfm ?p'" . from lp' \[where p="?p'"] have lp: "?l >0" and dl: "d_\ ?p' ?l" by auto from a_\_ex[where p="?p'" and l="?l" and bs="bs", OF lp' dl lp] pp' have pq_ex:"(\(x::int). ?I x p) = (\x. ?I x ?q)" by simp from lp' lp a_\[OF lp' dl lp] have lq:"iszlfm ?q" and uq: "d_\ ?q 1" by auto from \[OF lq] have dp:"?d >0" and dd: "d_\ ?q ?d" by blast+ let ?N = "\t. Inum (i#bs) t" have "?N ` set ?B' = ((?N \ simpnum) ` ?B)" by auto also have "\ = ?N ` ?B" using simpnum_ci[where bs="i#bs"] by auto finally have BB': "?N ` set ?B' = ?N ` ?B" . have "?N ` set ?A' = ((?N \ simpnum) ` ?A)" by auto also have "\ = ?N ` ?A" using simpnum_ci[where bs="i#bs"] by auto finally have AA': "?N ` set ?A' = ?N ` ?A" . from \_numbound0[OF lq] have B_nb:"\b\ set ?B'. numbound0 b" by (simp add: simpnum_numbound0) from \_l[OF lq] have A_nb: "\b\ set ?A'. numbound0 b" by (simp add: simpnum_numbound0) show ?thesis proof (cases "length ?B' \ length ?A'") case True then have q: "q = ?q" and "B = ?B'" and d: "d = ?d" using qBd by (auto simp add: Let_def unit_def) with BB' B_nb have b: "?N ` (set B) = ?N ` set (\ q)" and bn: "\b\ set B. numbound0 b" by simp_all with pq_ex dp uq dd lq q d show ?thesis by simp next case False then have q:"q=mirror ?q" and "B = ?A'" and d:"d = ?d" using qBd by (auto simp add: Let_def unit_def) with AA' mirror_\_\[OF lq] A_nb have b:"?N ` (set B) = ?N ` set (\ q)" and bn: "\b\ set B. numbound0 b" by simp_all from mirror_ex[OF lq] pq_ex q have pqm_eq:"(\(x::int). ?I x p) = (\(x::int). ?I x q)" by simp from lq uq q mirror_l[where p="?q"] have lq': "iszlfm q" and uq: "d_\ q 1" by auto from \[OF lq'] mirror_\[OF lq] q d have dq: "d_\ q d" by auto from pqm_eq b bn uq lq' dp dq q dp d show ?thesis by simp qed qed subsection \Cooper's Algorithm\ definition cooper :: "fm \ fm" where "cooper p = (let (q, B, d) = unit p; js = [1..d]; mq = simpfm (minusinf q); md = evaldjf (\j. simpfm (subst0 (C j) mq)) js in if md = T then T else (let qd = evaldjf (\(b, j). simpfm (subst0 (Add b (C j)) q)) [(b, j). b \ B, j \ js] in decr (disj md qd)))" lemma cooper: assumes qf: "qfree p" shows "(\x. Ifm bbs (x#bs) p) = Ifm bbs bs (cooper p) \ qfree (cooper p)" (is "?lhs = ?rhs \ _") proof - let ?I = "\x p. Ifm bbs (x#bs) p" let ?q = "fst (unit p)" let ?B = "fst (snd(unit p))" let ?d = "snd (snd (unit p))" let ?js = "[1..?d]" let ?mq = "minusinf ?q" let ?smq = "simpfm ?mq" let ?md = "evaldjf (\j. simpfm (subst0 (C j) ?smq)) ?js" fix i let ?N = "\t. Inum (i#bs) t" let ?Bjs = "[(b,j). b\?B,j\?js]" let ?qd = "evaldjf (\(b,j). simpfm (subst0 (Add b (C j)) ?q)) ?Bjs" have qbf:"unit p = (?q,?B,?d)" by simp from unit[OF qf qbf] have pq_ex: "(\(x::int). ?I x p) \ (\(x::int). ?I x ?q)" and B: "?N ` set ?B = ?N ` set (\ ?q)" and uq: "d_\ ?q 1" and dd: "d_\ ?q ?d" and dp: "?d > 0" and lq: "iszlfm ?q" and Bn: "\b\ set ?B. numbound0 b" by auto from zlin_qfree[OF lq] have qfq: "qfree ?q" . from simpfm_qf[OF minusinf_qfree[OF qfq]] have qfmq: "qfree ?smq" . have jsnb: "\j \ set ?js. numbound0 (C j)" by simp then have "\j\ set ?js. bound0 (subst0 (C j) ?smq)" by (auto simp only: subst0_bound0[OF qfmq]) then have th: "\j\ set ?js. bound0 (simpfm (subst0 (C j) ?smq))" by (auto simp add: simpfm_bound0) from evaldjf_bound0[OF th] have mdb: "bound0 ?md" by simp from Bn jsnb have "\(b,j) \ set ?Bjs. numbound0 (Add b (C j))" by simp then have "\(b,j) \ set ?Bjs. bound0 (subst0 (Add b (C j)) ?q)" using subst0_bound0[OF qfq] by blast then have "\(b,j) \ set ?Bjs. bound0 (simpfm (subst0 (Add b (C j)) ?q))" using simpfm_bound0 by blast then have th': "\x \ set ?Bjs. bound0 ((\(b,j). simpfm (subst0 (Add b (C j)) ?q)) x)" by auto from evaldjf_bound0 [OF th'] have qdb: "bound0 ?qd" by simp from mdb qdb have mdqdb: "bound0 (disj ?md ?qd)" unfolding disj_def by (cases "?md = T \ ?qd = T") simp_all from trans [OF pq_ex cp_thm'[OF lq uq dd dp,where i="i"]] B have "?lhs \ (\j \ {1.. ?d}. ?I j ?mq \ (\b \ ?N ` set ?B. Ifm bbs ((b + j) # bs) ?q))" by auto also have "\ \ (\j \ {1.. ?d}. ?I j ?mq \ (\b \ set ?B. Ifm bbs ((?N b + j) # bs) ?q))" by simp also have "\ \ (\j \ {1.. ?d}. ?I j ?mq ) \ (\j\ {1.. ?d}. \b \ set ?B. Ifm bbs ((?N (Add b (C j))) # bs) ?q)" by (simp only: Inum.simps) blast also have "\ \ (\j \ {1.. ?d}. ?I j ?smq) \ (\j \ {1.. ?d}. \b \ set ?B. Ifm bbs ((?N (Add b (C j))) # bs) ?q)" by (simp add: simpfm) also have "\ \ (\j\ set ?js. (\j. ?I i (simpfm (subst0 (C j) ?smq))) j) \ (\j\ set ?js. \b\ set ?B. Ifm bbs ((?N (Add b (C j)))#bs) ?q)" by (simp only: simpfm subst0_I[OF qfmq] set_upto) auto also have "\ \ ?I i (evaldjf (\j. simpfm (subst0 (C j) ?smq)) ?js) \ (\j\ set ?js. \b\ set ?B. ?I i (subst0 (Add b (C j)) ?q))" by (simp only: evaldjf_ex subst0_I[OF qfq]) also have "\ \ ?I i ?md \ (\(b,j) \ set ?Bjs. (\(b,j). ?I i (simpfm (subst0 (Add b (C j)) ?q))) (b,j))" by (simp only: simpfm set_concat set_map concat_map_singleton UN_simps) blast also have "\ \ ?I i ?md \ ?I i (evaldjf (\(b,j). simpfm (subst0 (Add b (C j)) ?q)) ?Bjs)" by (simp only: evaldjf_ex[where bs="i#bs" and f="\(b,j). simpfm (subst0 (Add b (C j)) ?q)" and ps="?Bjs"]) (auto simp add: split_def) finally have mdqd: "?lhs \ ?I i ?md \ ?I i ?qd" by simp also have "\ \ ?I i (disj ?md ?qd)" by (simp add: disj) also have "\ \ Ifm bbs bs (decr (disj ?md ?qd))" by (simp only: decr [OF mdqdb]) finally have mdqd2: "?lhs \ Ifm bbs bs (decr (disj ?md ?qd))" . show ?thesis proof (cases "?md = T") case True then have cT: "cooper p = T" by (simp only: cooper_def unit_def split_def Let_def if_True) simp from True have lhs: "?lhs" using mdqd by simp from True have "?rhs" by (simp add: cooper_def unit_def split_def) with lhs cT show ?thesis by simp next case False then have "cooper p = decr (disj ?md ?qd)" by (simp only: cooper_def unit_def split_def Let_def if_False) with mdqd2 decr_qf[OF mdqdb] show ?thesis by simp qed qed definition pa :: "fm \ fm" where "pa p = qelim (prep p) cooper" theorem mirqe: "Ifm bbs bs (pa p) = Ifm bbs bs p \ qfree (pa p)" using qelim_ci cooper prep by (auto simp add: pa_def) subsection \Setup\ oracle linzqe_oracle = \ let fun num_of_term vs (t as Free (xn, xT)) = (case AList.lookup (=) vs t of NONE => error "Variable not found in the list!" | SOME n => @{code Bound} (@{code nat_of_integer} n)) | num_of_term vs \<^term>\0::int\ = @{code C} (@{code int_of_integer} 0) | num_of_term vs \<^term>\1::int\ = @{code C} (@{code int_of_integer} 1) | num_of_term vs \<^term>\- 1::int\ = @{code C} (@{code int_of_integer} (~ 1)) | num_of_term vs \<^Const_>\numeral _ for t\ = @{code C} (@{code int_of_integer} (HOLogic.dest_numeral t)) | num_of_term vs \<^Const_>\uminus \<^Type>\int\ for \<^Const_>\numeral \<^Type>\int\ for t\\ = @{code C} (@{code int_of_integer} (~(HOLogic.dest_numeral t))) | num_of_term vs (Bound i) = @{code Bound} (@{code nat_of_integer} i) | num_of_term vs \<^Const_>\uminus \<^Type>\int\ for t'\ = @{code Neg} (num_of_term vs t') | num_of_term vs \<^Const_>\plus \<^Type>\int\ for t1 t2\ = @{code Add} (num_of_term vs t1, num_of_term vs t2) | num_of_term vs \<^Const_>\minus \<^Type>\int\ for t1 t2\ = @{code Sub} (num_of_term vs t1, num_of_term vs t2) | num_of_term vs \<^Const_>\times \<^Type>\int\ for t1 t2\ = (case try HOLogic.dest_number t1 of SOME (_, i) => @{code Mul} (@{code int_of_integer} i, num_of_term vs t2) | NONE => (case try HOLogic.dest_number t2 of SOME (_, i) => @{code Mul} (@{code int_of_integer} i, num_of_term vs t1) | NONE => error "num_of_term: unsupported multiplication")) | num_of_term vs t = error ("num_of_term: unknown term " ^ Syntax.string_of_term \<^context> t); fun fm_of_term ps vs \<^Const_>\True\ = @{code T} | fm_of_term ps vs \<^Const_>\False\ = @{code F} | fm_of_term ps vs \<^Const_>\less \<^Type>\int\ for t1 t2\ = @{code Lt} (@{code Sub} (num_of_term vs t1, num_of_term vs t2)) | fm_of_term ps vs \<^Const_>\less_eq \<^Type>\int\ for t1 t2\ = @{code Le} (@{code Sub} (num_of_term vs t1, num_of_term vs t2)) | fm_of_term ps vs \<^Const_>\HOL.eq \<^Type>\int\ for t1 t2\ = @{code Eq} (@{code Sub} (num_of_term vs t1, num_of_term vs t2)) | fm_of_term ps vs \<^Const_>\dvd \<^Type>\int\ for t1 t2\ = (case try HOLogic.dest_number t1 of SOME (_, i) => @{code Dvd} (@{code int_of_integer} i, num_of_term vs t2) | NONE => error "num_of_term: unsupported dvd") | fm_of_term ps vs \<^Const_>\HOL.eq \<^Type>\bool\ for t1 t2\ = @{code Iff} (fm_of_term ps vs t1, fm_of_term ps vs t2) | fm_of_term ps vs \<^Const_>\HOL.conj for t1 t2\ = @{code And} (fm_of_term ps vs t1, fm_of_term ps vs t2) | fm_of_term ps vs \<^Const_>\HOL.disj for t1 t2\ = @{code Or} (fm_of_term ps vs t1, fm_of_term ps vs t2) | fm_of_term ps vs \<^Const_>\HOL.implies for t1 t2\ = @{code Imp} (fm_of_term ps vs t1, fm_of_term ps vs t2) | fm_of_term ps vs \<^Const_>\HOL.Not for t'\ = @{code Not} (fm_of_term ps vs t') | fm_of_term ps vs \<^Const_>\Ex _ for \Abs (xn, xT, p)\\ = let - val (xn', p') = Syntax_Trans.variant_abs (xn, xT, p); (* FIXME !? *) + val (xn', p') = Term.dest_abs (xn, xT, p); val vs' = (Free (xn', xT), 0) :: map (fn (v, n) => (v, n + 1)) vs; in @{code E} (fm_of_term ps vs' p) end | fm_of_term ps vs \<^Const_>\All _ for \Abs (xn, xT, p)\\ = let - val (xn', p') = Syntax_Trans.variant_abs (xn, xT, p); (* FIXME !? *) + val (xn', p') = Term.dest_abs (xn, xT, p); val vs' = (Free (xn', xT), 0) :: map (fn (v, n) => (v, n + 1)) vs; in @{code A} (fm_of_term ps vs' p) end | fm_of_term ps vs t = error ("fm_of_term : unknown term " ^ Syntax.string_of_term \<^context> t); fun term_of_num vs (@{code C} i) = HOLogic.mk_number HOLogic.intT (@{code integer_of_int} i) | term_of_num vs (@{code Bound} n) = let val q = @{code integer_of_nat} n in fst (the (find_first (fn (_, m) => q = m) vs)) end | term_of_num vs (@{code Neg} t') = \<^Const>\uminus \<^Type>\int\ for \term_of_num vs t'\\ | term_of_num vs (@{code Add} (t1, t2)) = \<^Const>\plus \<^Type>\int\ for \term_of_num vs t1\ \term_of_num vs t2\\ | term_of_num vs (@{code Sub} (t1, t2)) = \<^Const>\minus \<^Type>\int\ for \term_of_num vs t1\ \term_of_num vs t2\\ | term_of_num vs (@{code Mul} (i, t2)) = \<^Const>\times \<^Type>\int\ for \term_of_num vs (@{code C} i)\ \term_of_num vs t2\\ | term_of_num vs (@{code CN} (n, i, t)) = term_of_num vs (@{code Add} (@{code Mul} (i, @{code Bound} n), t)); fun term_of_fm ps vs @{code T} = \<^Const>\True\ | term_of_fm ps vs @{code F} = \<^Const>\False\ | term_of_fm ps vs (@{code Lt} t) = \<^Const>\less \<^Type>\int\ for \term_of_num vs t\ \<^term>\0::int\\ | term_of_fm ps vs (@{code Le} t) = \<^Const>\less_eq \<^Type>\int\ for \term_of_num vs t\ \<^term>\0::int\\ | term_of_fm ps vs (@{code Gt} t) = \<^Const>\less \<^Type>\int\ for \<^term>\0::int\ \term_of_num vs t\\ | term_of_fm ps vs (@{code Ge} t) = \<^Const>\less_eq \<^Type>\int\ for \<^term>\0::int\ \term_of_num vs t\\ | term_of_fm ps vs (@{code Eq} t) = \<^Const>\HOL.eq \<^Type>\int\ for \term_of_num vs t\ \<^term>\0::int\\ | term_of_fm ps vs (@{code NEq} t) = term_of_fm ps vs (@{code Not} (@{code Eq} t)) | term_of_fm ps vs (@{code Dvd} (i, t)) = \<^Const>\dvd \<^Type>\int\ for \term_of_num vs (@{code C} i)\ \term_of_num vs t\\ | term_of_fm ps vs (@{code NDvd} (i, t)) = term_of_fm ps vs (@{code Not} (@{code Dvd} (i, t))) | term_of_fm ps vs (@{code Not} t') = \<^Const>\HOL.Not for \term_of_fm ps vs t'\\ | term_of_fm ps vs (@{code And} (t1, t2)) = \<^Const>\HOL.conj for \term_of_fm ps vs t1\ \term_of_fm ps vs t2\\ | term_of_fm ps vs (@{code Or} (t1, t2)) = \<^Const>\HOL.disj for \term_of_fm ps vs t1\ \term_of_fm ps vs t2\\ | term_of_fm ps vs (@{code Imp} (t1, t2)) = \<^Const>\HOL.implies for \term_of_fm ps vs t1\ \term_of_fm ps vs t2\\ | term_of_fm ps vs (@{code Iff} (t1, t2)) = \<^Const>\HOL.eq \<^Type>\bool\ for \term_of_fm ps vs t1\ \term_of_fm ps vs t2\\ | term_of_fm ps vs (@{code Closed} n) = let val q = @{code integer_of_nat} n in (fst o the) (find_first (fn (_, m) => m = q) ps) end | term_of_fm ps vs (@{code NClosed} n) = term_of_fm ps vs (@{code Not} (@{code Closed} n)); fun term_bools acc t = let val is_op = member (=) [\<^Const>\HOL.conj\, \<^Const>\HOL.disj\, \<^Const>\HOL.implies\, \<^Const>\HOL.eq \<^Type>\bool\\, \<^Const>\HOL.eq \<^Type>\int\\, \<^Const>\less \<^Type>\int\\, \<^Const>\less_eq \<^Type>\int\\, \<^Const>\HOL.Not\, \<^Const>\All \<^Type>\int\\, \<^Const>\Ex \<^Type>\int\\, \<^Const>\True\, \<^Const>\False\] fun is_ty t = not (fastype_of t = \<^Type>\bool\) in (case t of (l as f $ a) $ b => if is_ty t orelse is_op t then term_bools (term_bools acc l) b else insert (op aconv) t acc | f $ a => if is_ty t orelse is_op t then term_bools (term_bools acc f) a else insert (op aconv) t acc - | Abs p => term_bools acc (snd (Syntax_Trans.variant_abs p)) (* FIXME !? *) + | Abs p => term_bools acc (snd (Term.dest_abs p)) | _ => if is_ty t orelse is_op t then acc else insert (op aconv) t acc) end; in fn (ctxt, t) => let val fs = Misc_Legacy.term_frees t; val bs = term_bools [] t; val vs = map_index swap fs; val ps = map_index swap bs; val t' = term_of_fm ps vs (@{code pa} (fm_of_term ps vs t)); in Thm.cterm_of ctxt (HOLogic.mk_Trueprop (HOLogic.mk_eq (t, t'))) end end \ ML_file \cooper_tac.ML\ method_setup cooper = \ Scan.lift (Args.mode "no_quantify") >> (fn q => fn ctxt => SIMPLE_METHOD' (Cooper_Tac.linz_tac ctxt (not q))) \ "decision procedure for linear integer arithmetic" subsection \Tests\ lemma "\(j::int). \x\j. \a b. x = 3*a+5*b" by cooper lemma "\(x::int) \ 8. \i j. 5*i + 3*j = x" by cooper theorem "(\(y::int). 3 dvd y) \ \(x::int). b < x \ a \ x" by cooper theorem "\(y::int) (z::int) (n::int). 3 dvd z \ 2 dvd (y::int) \ (\(x::int). 2*x = y) \ (\(k::int). 3*k = z)" by cooper theorem "\(y::int) (z::int) n. Suc n < 6 \ 3 dvd z \ 2 dvd (y::int) \ (\(x::int). 2*x = y) \ (\(k::int). 3*k = z)" by cooper theorem "\(x::nat). \(y::nat). (0::nat) \ 5 \ y = 5 + x" by cooper lemma "\(x::int) \ 8. \i j. 5*i + 3*j = x" by cooper lemma "\(y::int) (z::int) (n::int). 3 dvd z \ 2 dvd (y::int) \ (\(x::int). 2*x = y) \ (\(k::int). 3*k = z)" by cooper lemma "\(x::int) y. x < y \ 2 * x + 1 < 2 * y" by cooper lemma "\(x::int) y. 2 * x + 1 \ 2 * y" by cooper lemma "\(x::int) y. 0 < x \ 0 \ y \ 3 * x - 5 * y = 1" by cooper lemma "\ (\(x::int) (y::int) (z::int). 4*x + (-6::int)*y = 1)" by cooper lemma "\(x::int). 2 dvd x \ (\(y::int). x = 2*y)" by cooper lemma "\(x::int). 2 dvd x \ (\(y::int). x = 2*y)" by cooper lemma "\(x::int). 2 dvd x \ (\(y::int). x \ 2*y + 1)" by cooper lemma "\ (\(x::int). (2 dvd x \ (\(y::int). x \ 2*y+1) \ (\(q::int) (u::int) i. 3*i + 2*q - u < 17) \ 0 < x \ (\ 3 dvd x \ x + 8 = 0)))" by cooper lemma "\ (\(i::int). 4 \ i \ (\x y. 0 \ x \ 0 \ y \ 3 * x + 5 * y = i))" by cooper lemma "\j. \(x::int) \ j. \i j. 5*i + 3*j = x" by cooper theorem "(\(y::int). 3 dvd y) \ \(x::int). b < x \ a \ x" by cooper theorem "\(y::int) (z::int) (n::int). 3 dvd z \ 2 dvd (y::int) \ (\(x::int). 2*x = y) \ (\(k::int). 3*k = z)" by cooper theorem "\(y::int) (z::int) n. Suc n < 6 \ 3 dvd z \ 2 dvd (y::int) \ (\(x::int). 2*x = y) \ (\(k::int). 3*k = z)" by cooper theorem "\(x::nat). \(y::nat). (0::nat) \ 5 \ y = 5 + x" by cooper theorem "\(x::nat). \(y::nat). y = 5 + x \ x div 6 + 1 = 2" by cooper theorem "\(x::int). 0 < x" by cooper theorem "\(x::int) y. x < y \ 2 * x + 1 < 2 * y" by cooper theorem "\(x::int) y. 2 * x + 1 \ 2 * y" by cooper theorem "\(x::int) y. 0 < x \ 0 \ y \ 3 * x - 5 * y = 1" by cooper theorem "\ (\(x::int) (y::int) (z::int). 4*x + (-6::int)*y = 1)" by cooper theorem "\ (\(x::int). False)" by cooper theorem "\(x::int). 2 dvd x \ (\(y::int). x = 2*y)" by cooper theorem "\(x::int). 2 dvd x \ (\(y::int). x = 2*y)" by cooper theorem "\(x::int). 2 dvd x \ (\(y::int). x = 2*y)" by cooper theorem "\(x::int). 2 dvd x \ (\(y::int). x \ 2*y + 1)" by cooper theorem "\ (\(x::int). (2 dvd x \ (\(y::int). x \ 2*y+1) \ (\(q::int) (u::int) i. 3*i + 2*q - u < 17) \ 0 < x \ (\ 3 dvd x \ x + 8 = 0)))" by cooper theorem "\ (\(i::int). 4 \ i \ (\x y. 0 \ x \ 0 \ y \ 3 * x + 5 * y = i))" by cooper theorem "\(i::int). 8 \ i \ (\x y. 0 \ x \ 0 \ y \ 3 * x + 5 * y = i)" by cooper theorem "\(j::int). \i. j \ i \ (\x y. 0 \ x \ 0 \ y \ 3 * x + 5 * y = i)" by cooper theorem "\ (\j (i::int). j \ i \ (\x y. 0 \ x \ 0 \ y \ 3 * x + 5 * y = i))" by cooper theorem "(\m::nat. n = 2 * m) \ (n + 1) div 2 = n div 2" by cooper subsection \Variant for HOL-Main\ export_code pa T Bound nat_of_integer integer_of_nat int_of_integer integer_of_int in Eval module_name Cooper_Procedure file_prefix cooper_procedure end diff --git a/src/HOL/Decision_Procs/Parametric_Ferrante_Rackoff.thy b/src/HOL/Decision_Procs/Parametric_Ferrante_Rackoff.thy --- a/src/HOL/Decision_Procs/Parametric_Ferrante_Rackoff.thy +++ b/src/HOL/Decision_Procs/Parametric_Ferrante_Rackoff.thy @@ -1,4150 +1,4148 @@ (* Title: HOL/Decision_Procs/Parametric_Ferrante_Rackoff.thy Author: Amine Chaieb *) section \A formalization of Ferrante and Rackoff's procedure with polynomial parameters, see Paper in CALCULEMUS 2008\ theory Parametric_Ferrante_Rackoff imports Reflected_Multivariate_Polynomial Dense_Linear_Order DP_Library "HOL-Library.Code_Target_Numeral" begin subsection \Terms\ datatype (plugins del: size) tm = CP poly | Bound nat | Add tm tm | Mul poly tm | Neg tm | Sub tm tm | CNP nat poly tm instantiation tm :: size begin primrec size_tm :: "tm \ nat" where "size_tm (CP c) = polysize c" | "size_tm (Bound n) = 1" | "size_tm (Neg a) = 1 + size_tm a" | "size_tm (Add a b) = 1 + size_tm a + size_tm b" | "size_tm (Sub a b) = 3 + size_tm a + size_tm b" | "size_tm (Mul c a) = 1 + polysize c + size_tm a" | "size_tm (CNP n c a) = 3 + polysize c + size_tm a " instance .. end text \Semantics of terms tm.\ primrec Itm :: "'a::field_char_0 list \ 'a list \ tm \ 'a" where "Itm vs bs (CP c) = (Ipoly vs c)" | "Itm vs bs (Bound n) = bs!n" | "Itm vs bs (Neg a) = -(Itm vs bs a)" | "Itm vs bs (Add a b) = Itm vs bs a + Itm vs bs b" | "Itm vs bs (Sub a b) = Itm vs bs a - Itm vs bs b" | "Itm vs bs (Mul c a) = (Ipoly vs c) * Itm vs bs a" | "Itm vs bs (CNP n c t) = (Ipoly vs c)*(bs!n) + Itm vs bs t" fun allpolys :: "(poly \ bool) \ tm \ bool" where "allpolys P (CP c) = P c" | "allpolys P (CNP n c p) = (P c \ allpolys P p)" | "allpolys P (Mul c p) = (P c \ allpolys P p)" | "allpolys P (Neg p) = allpolys P p" | "allpolys P (Add p q) = (allpolys P p \ allpolys P q)" | "allpolys P (Sub p q) = (allpolys P p \ allpolys P q)" | "allpolys P p = True" primrec tmboundslt :: "nat \ tm \ bool" where "tmboundslt n (CP c) = True" | "tmboundslt n (Bound m) = (m < n)" | "tmboundslt n (CNP m c a) = (m < n \ tmboundslt n a)" | "tmboundslt n (Neg a) = tmboundslt n a" | "tmboundslt n (Add a b) = (tmboundslt n a \ tmboundslt n b)" | "tmboundslt n (Sub a b) = (tmboundslt n a \ tmboundslt n b)" | "tmboundslt n (Mul i a) = tmboundslt n a" primrec tmbound0 :: "tm \ bool" \ \a \tm\ is \<^emph>\independent\ of Bound 0\ where "tmbound0 (CP c) = True" | "tmbound0 (Bound n) = (n>0)" | "tmbound0 (CNP n c a) = (n\0 \ tmbound0 a)" | "tmbound0 (Neg a) = tmbound0 a" | "tmbound0 (Add a b) = (tmbound0 a \ tmbound0 b)" | "tmbound0 (Sub a b) = (tmbound0 a \ tmbound0 b)" | "tmbound0 (Mul i a) = tmbound0 a" lemma tmbound0_I: assumes "tmbound0 a" shows "Itm vs (b#bs) a = Itm vs (b'#bs) a" using assms by (induct a rule: tm.induct) auto primrec tmbound :: "nat \ tm \ bool" \ \a \tm\ is \<^emph>\independent\ of Bound n\ where "tmbound n (CP c) = True" | "tmbound n (Bound m) = (n \ m)" | "tmbound n (CNP m c a) = (n\m \ tmbound n a)" | "tmbound n (Neg a) = tmbound n a" | "tmbound n (Add a b) = (tmbound n a \ tmbound n b)" | "tmbound n (Sub a b) = (tmbound n a \ tmbound n b)" | "tmbound n (Mul i a) = tmbound n a" lemma tmbound0_tmbound_iff: "tmbound 0 t = tmbound0 t" by (induct t) auto lemma tmbound_I: assumes bnd: "tmboundslt (length bs) t" and nb: "tmbound n t" and le: "n \ length bs" shows "Itm vs (bs[n:=x]) t = Itm vs bs t" using nb le bnd by (induct t rule: tm.induct) auto fun decrtm0 :: "tm \ tm" where "decrtm0 (Bound n) = Bound (n - 1)" | "decrtm0 (Neg a) = Neg (decrtm0 a)" | "decrtm0 (Add a b) = Add (decrtm0 a) (decrtm0 b)" | "decrtm0 (Sub a b) = Sub (decrtm0 a) (decrtm0 b)" | "decrtm0 (Mul c a) = Mul c (decrtm0 a)" | "decrtm0 (CNP n c a) = CNP (n - 1) c (decrtm0 a)" | "decrtm0 a = a" fun incrtm0 :: "tm \ tm" where "incrtm0 (Bound n) = Bound (n + 1)" | "incrtm0 (Neg a) = Neg (incrtm0 a)" | "incrtm0 (Add a b) = Add (incrtm0 a) (incrtm0 b)" | "incrtm0 (Sub a b) = Sub (incrtm0 a) (incrtm0 b)" | "incrtm0 (Mul c a) = Mul c (incrtm0 a)" | "incrtm0 (CNP n c a) = CNP (n + 1) c (incrtm0 a)" | "incrtm0 a = a" lemma decrtm0: assumes nb: "tmbound0 t" shows "Itm vs (x # bs) t = Itm vs bs (decrtm0 t)" using nb by (induct t rule: decrtm0.induct) simp_all lemma incrtm0: "Itm vs (x#bs) (incrtm0 t) = Itm vs bs t" by (induct t rule: decrtm0.induct) simp_all primrec decrtm :: "nat \ tm \ tm" where "decrtm m (CP c) = (CP c)" | "decrtm m (Bound n) = (if n < m then Bound n else Bound (n - 1))" | "decrtm m (Neg a) = Neg (decrtm m a)" | "decrtm m (Add a b) = Add (decrtm m a) (decrtm m b)" | "decrtm m (Sub a b) = Sub (decrtm m a) (decrtm m b)" | "decrtm m (Mul c a) = Mul c (decrtm m a)" | "decrtm m (CNP n c a) = (if n < m then CNP n c (decrtm m a) else CNP (n - 1) c (decrtm m a))" primrec removen :: "nat \ 'a list \ 'a list" where "removen n [] = []" | "removen n (x#xs) = (if n=0 then xs else (x#(removen (n - 1) xs)))" lemma removen_same: "n \ length xs \ removen n xs = xs" by (induct xs arbitrary: n) auto lemma nth_length_exceeds: "n \ length xs \ xs!n = []!(n - length xs)" by (induct xs arbitrary: n) auto lemma removen_length: "length (removen n xs) = (if n \ length xs then length xs else length xs - 1)" by (induct xs arbitrary: n) auto lemma removen_nth: "(removen n xs)!m = (if n \ length xs then xs!m else if m < n then xs!m else if m \ length xs then xs!(Suc m) else []!(m - (length xs - 1)))" proof (induct xs arbitrary: n m) case Nil then show ?case by simp next case (Cons x xs) let ?l = "length (x # xs)" consider "n \ ?l" | "n < ?l" by arith then show ?case proof cases case 1 with removen_same[OF this] show ?thesis by simp next case nl: 2 consider "m < n" | "m \ n" by arith then show ?thesis proof cases case 1 then show ?thesis using Cons by (cases m) auto next case 2 consider "m \ ?l" | "m > ?l" by arith then show ?thesis proof cases case 1 then show ?thesis using Cons by (cases m) auto next case ml: 2 have th: "length (removen n (x # xs)) = length xs" using removen_length[where n = n and xs= "x # xs"] nl by simp with ml have "m \ length (removen n (x # xs))" by auto from th nth_length_exceeds[OF this] have "(removen n (x # xs))!m = [] ! (m - length xs)" by auto then have "(removen n (x # xs))!m = [] ! (m - (length (x # xs) - 1))" by auto then show ?thesis using ml nl by auto qed qed qed qed lemma decrtm: assumes bnd: "tmboundslt (length bs) t" and nb: "tmbound m t" and nle: "m \ length bs" shows "Itm vs (removen m bs) (decrtm m t) = Itm vs bs t" using bnd nb nle by (induct t rule: tm.induct) (auto simp add: removen_nth) primrec tmsubst0:: "tm \ tm \ tm" where "tmsubst0 t (CP c) = CP c" | "tmsubst0 t (Bound n) = (if n=0 then t else Bound n)" | "tmsubst0 t (CNP n c a) = (if n=0 then Add (Mul c t) (tmsubst0 t a) else CNP n c (tmsubst0 t a))" | "tmsubst0 t (Neg a) = Neg (tmsubst0 t a)" | "tmsubst0 t (Add a b) = Add (tmsubst0 t a) (tmsubst0 t b)" | "tmsubst0 t (Sub a b) = Sub (tmsubst0 t a) (tmsubst0 t b)" | "tmsubst0 t (Mul i a) = Mul i (tmsubst0 t a)" lemma tmsubst0: "Itm vs (x # bs) (tmsubst0 t a) = Itm vs (Itm vs (x # bs) t # bs) a" by (induct a rule: tm.induct) auto lemma tmsubst0_nb: "tmbound0 t \ tmbound0 (tmsubst0 t a)" by (induct a rule: tm.induct) auto primrec tmsubst:: "nat \ tm \ tm \ tm" where "tmsubst n t (CP c) = CP c" | "tmsubst n t (Bound m) = (if n=m then t else Bound m)" | "tmsubst n t (CNP m c a) = (if n = m then Add (Mul c t) (tmsubst n t a) else CNP m c (tmsubst n t a))" | "tmsubst n t (Neg a) = Neg (tmsubst n t a)" | "tmsubst n t (Add a b) = Add (tmsubst n t a) (tmsubst n t b)" | "tmsubst n t (Sub a b) = Sub (tmsubst n t a) (tmsubst n t b)" | "tmsubst n t (Mul i a) = Mul i (tmsubst n t a)" lemma tmsubst: assumes nb: "tmboundslt (length bs) a" and nlt: "n \ length bs" shows "Itm vs bs (tmsubst n t a) = Itm vs (bs[n:= Itm vs bs t]) a" using nb nlt by (induct a rule: tm.induct) auto lemma tmsubst_nb0: assumes tnb: "tmbound0 t" shows "tmbound0 (tmsubst 0 t a)" using tnb by (induct a rule: tm.induct) auto lemma tmsubst_nb: assumes tnb: "tmbound m t" shows "tmbound m (tmsubst m t a)" using tnb by (induct a rule: tm.induct) auto lemma incrtm0_tmbound: "tmbound n t \ tmbound (Suc n) (incrtm0 t)" by (induct t) auto text \Simplification.\ fun tmadd:: "tm \ tm \ tm" where "tmadd (CNP n1 c1 r1) (CNP n2 c2 r2) = (if n1 = n2 then let c = c1 +\<^sub>p c2 in if c = 0\<^sub>p then tmadd r1 r2 else CNP n1 c (tmadd r1 r2) else if n1 \ n2 then (CNP n1 c1 (tmadd r1 (CNP n2 c2 r2))) else (CNP n2 c2 (tmadd (CNP n1 c1 r1) r2)))" | "tmadd (CNP n1 c1 r1) t = CNP n1 c1 (tmadd r1 t)" | "tmadd t (CNP n2 c2 r2) = CNP n2 c2 (tmadd t r2)" | "tmadd (CP b1) (CP b2) = CP (b1 +\<^sub>p b2)" | "tmadd a b = Add a b" lemma tmadd [simp]: "Itm vs bs (tmadd t s) = Itm vs bs (Add t s)" apply (induct t s rule: tmadd.induct) apply (simp_all add: Let_def) apply (case_tac "c1 +\<^sub>p c2 = 0\<^sub>p") apply (case_tac "n1 \ n2") apply simp_all apply (case_tac "n1 = n2") apply (simp_all add: algebra_simps) apply (simp only: distrib_left [symmetric] polyadd [symmetric]) apply simp done lemma tmadd_nb0[simp]: "tmbound0 t \ tmbound0 s \ tmbound0 (tmadd t s)" by (induct t s rule: tmadd.induct) (auto simp add: Let_def) lemma tmadd_nb[simp]: "tmbound n t \ tmbound n s \ tmbound n (tmadd t s)" by (induct t s rule: tmadd.induct) (auto simp add: Let_def) lemma tmadd_blt[simp]: "tmboundslt n t \ tmboundslt n s \ tmboundslt n (tmadd t s)" by (induct t s rule: tmadd.induct) (auto simp add: Let_def) lemma tmadd_allpolys_npoly[simp]: "allpolys isnpoly t \ allpolys isnpoly s \ allpolys isnpoly (tmadd t s)" by (induct t s rule: tmadd.induct) (simp_all add: Let_def polyadd_norm) fun tmmul:: "tm \ poly \ tm" where "tmmul (CP j) = (\i. CP (i *\<^sub>p j))" | "tmmul (CNP n c a) = (\i. CNP n (i *\<^sub>p c) (tmmul a i))" | "tmmul t = (\i. Mul i t)" lemma tmmul[simp]: "Itm vs bs (tmmul t i) = Itm vs bs (Mul i t)" by (induct t arbitrary: i rule: tmmul.induct) (simp_all add: field_simps) lemma tmmul_nb0[simp]: "tmbound0 t \ tmbound0 (tmmul t i)" by (induct t arbitrary: i rule: tmmul.induct) auto lemma tmmul_nb[simp]: "tmbound n t \ tmbound n (tmmul t i)" by (induct t arbitrary: n rule: tmmul.induct) auto lemma tmmul_blt[simp]: "tmboundslt n t \ tmboundslt n (tmmul t i)" by (induct t arbitrary: i rule: tmmul.induct) (auto simp add: Let_def) lemma tmmul_allpolys_npoly[simp]: assumes "SORT_CONSTRAINT('a::field_char_0)" shows "allpolys isnpoly t \ isnpoly c \ allpolys isnpoly (tmmul t c)" by (induct t rule: tmmul.induct) (simp_all add: Let_def polymul_norm) definition tmneg :: "tm \ tm" where "tmneg t \ tmmul t (C (- 1,1))" definition tmsub :: "tm \ tm \ tm" where "tmsub s t \ (if s = t then CP 0\<^sub>p else tmadd s (tmneg t))" lemma tmneg[simp]: "Itm vs bs (tmneg t) = Itm vs bs (Neg t)" using tmneg_def[of t] by simp lemma tmneg_nb0[simp]: "tmbound0 t \ tmbound0 (tmneg t)" using tmneg_def by simp lemma tmneg_nb[simp]: "tmbound n t \ tmbound n (tmneg t)" using tmneg_def by simp lemma tmneg_blt[simp]: "tmboundslt n t \ tmboundslt n (tmneg t)" using tmneg_def by simp lemma [simp]: "isnpoly (C (-1, 1))" by (simp add: isnpoly_def) lemma tmneg_allpolys_npoly[simp]: assumes "SORT_CONSTRAINT('a::field_char_0)" shows "allpolys isnpoly t \ allpolys isnpoly (tmneg t)" by (auto simp: tmneg_def) lemma tmsub[simp]: "Itm vs bs (tmsub a b) = Itm vs bs (Sub a b)" using tmsub_def by simp lemma tmsub_nb0[simp]: "tmbound0 t \ tmbound0 s \ tmbound0 (tmsub t s)" using tmsub_def by simp lemma tmsub_nb[simp]: "tmbound n t \ tmbound n s \ tmbound n (tmsub t s)" using tmsub_def by simp lemma tmsub_blt[simp]: "tmboundslt n t \ tmboundslt n s \ tmboundslt n (tmsub t s)" using tmsub_def by simp lemma tmsub_allpolys_npoly[simp]: assumes "SORT_CONSTRAINT('a::field_char_0)" shows "allpolys isnpoly t \ allpolys isnpoly s \ allpolys isnpoly (tmsub t s)" by (simp add: tmsub_def isnpoly_def) fun simptm :: "tm \ tm" where "simptm (CP j) = CP (polynate j)" | "simptm (Bound n) = CNP n (1)\<^sub>p (CP 0\<^sub>p)" | "simptm (Neg t) = tmneg (simptm t)" | "simptm (Add t s) = tmadd (simptm t) (simptm s)" | "simptm (Sub t s) = tmsub (simptm t) (simptm s)" | "simptm (Mul i t) = (let i' = polynate i in if i' = 0\<^sub>p then CP 0\<^sub>p else tmmul (simptm t) i')" | "simptm (CNP n c t) = (let c' = polynate c in if c' = 0\<^sub>p then simptm t else tmadd (CNP n c' (CP 0\<^sub>p)) (simptm t))" lemma polynate_stupid: assumes "SORT_CONSTRAINT('a::field_char_0)" shows "polynate t = 0\<^sub>p \ Ipoly bs t = (0::'a)" apply (subst polynate[symmetric]) apply simp done lemma simptm_ci[simp]: "Itm vs bs (simptm t) = Itm vs bs t" by (induct t rule: simptm.induct) (auto simp add: Let_def polynate_stupid) lemma simptm_tmbound0[simp]: "tmbound0 t \ tmbound0 (simptm t)" by (induct t rule: simptm.induct) (auto simp add: Let_def) lemma simptm_nb[simp]: "tmbound n t \ tmbound n (simptm t)" by (induct t rule: simptm.induct) (auto simp add: Let_def) lemma simptm_nlt[simp]: "tmboundslt n t \ tmboundslt n (simptm t)" by (induct t rule: simptm.induct) (auto simp add: Let_def) lemma [simp]: "isnpoly 0\<^sub>p" and [simp]: "isnpoly (C (1, 1))" by (simp_all add: isnpoly_def) lemma simptm_allpolys_npoly[simp]: assumes "SORT_CONSTRAINT('a::field_char_0)" shows "allpolys isnpoly (simptm p)" by (induct p rule: simptm.induct) (auto simp add: Let_def) declare let_cong[fundef_cong del] fun split0 :: "tm \ poly \ tm" where "split0 (Bound 0) = ((1)\<^sub>p, CP 0\<^sub>p)" | "split0 (CNP 0 c t) = (let (c', t') = split0 t in (c +\<^sub>p c', t'))" | "split0 (Neg t) = (let (c, t') = split0 t in (~\<^sub>p c, Neg t'))" | "split0 (CNP n c t) = (let (c', t') = split0 t in (c', CNP n c t'))" | "split0 (Add s t) = (let (c1, s') = split0 s; (c2, t') = split0 t in (c1 +\<^sub>p c2, Add s' t'))" | "split0 (Sub s t) = (let (c1, s') = split0 s; (c2, t') = split0 t in (c1 -\<^sub>p c2, Sub s' t'))" | "split0 (Mul c t) = (let (c', t') = split0 t in (c *\<^sub>p c', Mul c t'))" | "split0 t = (0\<^sub>p, t)" declare let_cong[fundef_cong] lemma split0_stupid[simp]: "\x y. (x, y) = split0 p" apply (rule exI[where x="fst (split0 p)"]) apply (rule exI[where x="snd (split0 p)"]) apply simp done lemma split0: "tmbound 0 (snd (split0 t)) \ Itm vs bs (CNP 0 (fst (split0 t)) (snd (split0 t))) = Itm vs bs t" apply (induct t rule: split0.induct) apply simp apply (simp add: Let_def split_def field_simps) apply (simp add: Let_def split_def field_simps) apply (simp add: Let_def split_def field_simps) apply (simp add: Let_def split_def field_simps) apply (simp add: Let_def split_def field_simps) apply (simp add: Let_def split_def mult.assoc distrib_left[symmetric]) apply (simp add: Let_def split_def field_simps) apply (simp add: Let_def split_def field_simps) done lemma split0_ci: "split0 t = (c',t') \ Itm vs bs t = Itm vs bs (CNP 0 c' t')" proof - fix c' t' assume "split0 t = (c', t')" then have "c' = fst (split0 t)" "t' = snd (split0 t)" by auto with split0[where t="t" and bs="bs"] show "Itm vs bs t = Itm vs bs (CNP 0 c' t')" by simp qed lemma split0_nb0: assumes "SORT_CONSTRAINT('a::field_char_0)" shows "split0 t = (c',t') \ tmbound 0 t'" proof - fix c' t' assume "split0 t = (c', t')" then have "c' = fst (split0 t)" "t' = snd (split0 t)" by auto with conjunct1[OF split0[where t="t"]] show "tmbound 0 t'" by simp qed lemma split0_nb0'[simp]: assumes "SORT_CONSTRAINT('a::field_char_0)" shows "tmbound0 (snd (split0 t))" using split0_nb0[of t "fst (split0 t)" "snd (split0 t)"] by (simp add: tmbound0_tmbound_iff) lemma split0_nb: assumes nb: "tmbound n t" shows "tmbound n (snd (split0 t))" using nb by (induct t rule: split0.induct) (auto simp add: Let_def split_def) lemma split0_blt: assumes nb: "tmboundslt n t" shows "tmboundslt n (snd (split0 t))" using nb by (induct t rule: split0.induct) (auto simp add: Let_def split_def) lemma tmbound_split0: "tmbound 0 t \ Ipoly vs (fst (split0 t)) = 0" by (induct t rule: split0.induct) (auto simp add: Let_def split_def) lemma tmboundslt_split0: "tmboundslt n t \ Ipoly vs (fst (split0 t)) = 0 \ n > 0" by (induct t rule: split0.induct) (auto simp add: Let_def split_def) lemma tmboundslt0_split0: "tmboundslt 0 t \ Ipoly vs (fst (split0 t)) = 0" by (induct t rule: split0.induct) (auto simp add: Let_def split_def) lemma allpolys_split0: "allpolys isnpoly p \ allpolys isnpoly (snd (split0 p))" by (induct p rule: split0.induct) (auto simp add: isnpoly_def Let_def split_def) lemma isnpoly_fst_split0: assumes "SORT_CONSTRAINT('a::field_char_0)" shows "allpolys isnpoly p \ isnpoly (fst (split0 p))" by (induct p rule: split0.induct) (auto simp add: polyadd_norm polysub_norm polyneg_norm polymul_norm Let_def split_def) subsection \Formulae\ datatype (plugins del: size) fm = T | F | Le tm | Lt tm | Eq tm | NEq tm | Not fm | And fm fm | Or fm fm | Imp fm fm | Iff fm fm | E fm | A fm instantiation fm :: size begin primrec size_fm :: "fm \ nat" where "size_fm (Not p) = 1 + size_fm p" | "size_fm (And p q) = 1 + size_fm p + size_fm q" | "size_fm (Or p q) = 1 + size_fm p + size_fm q" | "size_fm (Imp p q) = 3 + size_fm p + size_fm q" | "size_fm (Iff p q) = 3 + 2 * (size_fm p + size_fm q)" | "size_fm (E p) = 1 + size_fm p" | "size_fm (A p) = 4 + size_fm p" | "size_fm T = 1" | "size_fm F = 1" | "size_fm (Le _) = 1" | "size_fm (Lt _) = 1" | "size_fm (Eq _) = 1" | "size_fm (NEq _) = 1" instance .. end lemma fmsize_pos [simp]: "size p > 0" for p :: fm by (induct p) simp_all text \Semantics of formulae (fm).\ primrec Ifm ::"'a::linordered_field list \ 'a list \ fm \ bool" where "Ifm vs bs T = True" | "Ifm vs bs F = False" | "Ifm vs bs (Lt a) = (Itm vs bs a < 0)" | "Ifm vs bs (Le a) = (Itm vs bs a \ 0)" | "Ifm vs bs (Eq a) = (Itm vs bs a = 0)" | "Ifm vs bs (NEq a) = (Itm vs bs a \ 0)" | "Ifm vs bs (Not p) = (\ (Ifm vs bs p))" | "Ifm vs bs (And p q) = (Ifm vs bs p \ Ifm vs bs q)" | "Ifm vs bs (Or p q) = (Ifm vs bs p \ Ifm vs bs q)" | "Ifm vs bs (Imp p q) = ((Ifm vs bs p) \ (Ifm vs bs q))" | "Ifm vs bs (Iff p q) = (Ifm vs bs p = Ifm vs bs q)" | "Ifm vs bs (E p) = (\x. Ifm vs (x#bs) p)" | "Ifm vs bs (A p) = (\x. Ifm vs (x#bs) p)" fun not:: "fm \ fm" where "not (Not (Not p)) = not p" | "not (Not p) = p" | "not T = F" | "not F = T" | "not (Lt t) = Le (tmneg t)" | "not (Le t) = Lt (tmneg t)" | "not (Eq t) = NEq t" | "not (NEq t) = Eq t" | "not p = Not p" lemma not[simp]: "Ifm vs bs (not p) = Ifm vs bs (Not p)" by (induct p rule: not.induct) auto definition conj :: "fm \ fm \ fm" where "conj p q \ (if p = F \ q = F then F else if p = T then q else if q = T then p else if p = q then p else And p q)" lemma conj[simp]: "Ifm vs bs (conj p q) = Ifm vs bs (And p q)" by (cases "p=F \ q=F", simp_all add: conj_def) (cases p, simp_all) definition disj :: "fm \ fm \ fm" where "disj p q \ (if (p = T \ q = T) then T else if p = F then q else if q = F then p else if p = q then p else Or p q)" lemma disj[simp]: "Ifm vs bs (disj p q) = Ifm vs bs (Or p q)" by (cases "p = T \ q = T", simp_all add: disj_def) (cases p, simp_all) definition imp :: "fm \ fm \ fm" where "imp p q \ (if p = F \ q = T \ p = q then T else if p = T then q else if q = F then not p else Imp p q)" lemma imp[simp]: "Ifm vs bs (imp p q) = Ifm vs bs (Imp p q)" by (cases "p = F \ q = T") (simp_all add: imp_def) definition iff :: "fm \ fm \ fm" where "iff p q \ (if p = q then T else if p = Not q \ Not p = q then F else if p = F then not q else if q = F then not p else if p = T then q else if q = T then p else Iff p q)" lemma iff[simp]: "Ifm vs bs (iff p q) = Ifm vs bs (Iff p q)" by (unfold iff_def, cases "p = q", simp, cases "p = Not q", simp) (cases "Not p= q", auto) text \Quantifier freeness.\ fun qfree:: "fm \ bool" where "qfree (E p) = False" | "qfree (A p) = False" | "qfree (Not p) = qfree p" | "qfree (And p q) = (qfree p \ qfree q)" | "qfree (Or p q) = (qfree p \ qfree q)" | "qfree (Imp p q) = (qfree p \ qfree q)" | "qfree (Iff p q) = (qfree p \ qfree q)" | "qfree p = True" text \Boundedness and substitution.\ primrec boundslt :: "nat \ fm \ bool" where "boundslt n T = True" | "boundslt n F = True" | "boundslt n (Lt t) = tmboundslt n t" | "boundslt n (Le t) = tmboundslt n t" | "boundslt n (Eq t) = tmboundslt n t" | "boundslt n (NEq t) = tmboundslt n t" | "boundslt n (Not p) = boundslt n p" | "boundslt n (And p q) = (boundslt n p \ boundslt n q)" | "boundslt n (Or p q) = (boundslt n p \ boundslt n q)" | "boundslt n (Imp p q) = ((boundslt n p) \ (boundslt n q))" | "boundslt n (Iff p q) = (boundslt n p \ boundslt n q)" | "boundslt n (E p) = boundslt (Suc n) p" | "boundslt n (A p) = boundslt (Suc n) p" fun bound0:: "fm \ bool" \ \a formula is independent of Bound 0\ where "bound0 T = True" | "bound0 F = True" | "bound0 (Lt a) = tmbound0 a" | "bound0 (Le a) = tmbound0 a" | "bound0 (Eq a) = tmbound0 a" | "bound0 (NEq a) = tmbound0 a" | "bound0 (Not p) = bound0 p" | "bound0 (And p q) = (bound0 p \ bound0 q)" | "bound0 (Or p q) = (bound0 p \ bound0 q)" | "bound0 (Imp p q) = ((bound0 p) \ (bound0 q))" | "bound0 (Iff p q) = (bound0 p \ bound0 q)" | "bound0 p = False" lemma bound0_I: assumes bp: "bound0 p" shows "Ifm vs (b#bs) p = Ifm vs (b'#bs) p" using bp tmbound0_I[where b="b" and bs="bs" and b'="b'"] by (induct p rule: bound0.induct) auto primrec bound:: "nat \ fm \ bool" \ \a formula is independent of Bound n\ where "bound m T = True" | "bound m F = True" | "bound m (Lt t) = tmbound m t" | "bound m (Le t) = tmbound m t" | "bound m (Eq t) = tmbound m t" | "bound m (NEq t) = tmbound m t" | "bound m (Not p) = bound m p" | "bound m (And p q) = (bound m p \ bound m q)" | "bound m (Or p q) = (bound m p \ bound m q)" | "bound m (Imp p q) = ((bound m p) \ (bound m q))" | "bound m (Iff p q) = (bound m p \ bound m q)" | "bound m (E p) = bound (Suc m) p" | "bound m (A p) = bound (Suc m) p" lemma bound_I: assumes bnd: "boundslt (length bs) p" and nb: "bound n p" and le: "n \ length bs" shows "Ifm vs (bs[n:=x]) p = Ifm vs bs p" using bnd nb le tmbound_I[where bs=bs and vs = vs] proof (induct p arbitrary: bs n rule: fm.induct) case (E p bs n) have "Ifm vs ((y#bs)[Suc n:=x]) p = Ifm vs (y#bs) p" for y proof - from E have bnd: "boundslt (length (y#bs)) p" and nb: "bound (Suc n) p" and le: "Suc n \ length (y#bs)" by simp+ from E.hyps[OF bnd nb le tmbound_I] show ?thesis . qed then show ?case by simp next case (A p bs n) have "Ifm vs ((y#bs)[Suc n:=x]) p = Ifm vs (y#bs) p" for y proof - from A have bnd: "boundslt (length (y#bs)) p" and nb: "bound (Suc n) p" and le: "Suc n \ length (y#bs)" by simp_all from A.hyps[OF bnd nb le tmbound_I] show ?thesis . qed then show ?case by simp qed auto fun decr0 :: "fm \ fm" where "decr0 (Lt a) = Lt (decrtm0 a)" | "decr0 (Le a) = Le (decrtm0 a)" | "decr0 (Eq a) = Eq (decrtm0 a)" | "decr0 (NEq a) = NEq (decrtm0 a)" | "decr0 (Not p) = Not (decr0 p)" | "decr0 (And p q) = conj (decr0 p) (decr0 q)" | "decr0 (Or p q) = disj (decr0 p) (decr0 q)" | "decr0 (Imp p q) = imp (decr0 p) (decr0 q)" | "decr0 (Iff p q) = iff (decr0 p) (decr0 q)" | "decr0 p = p" lemma decr0: assumes "bound0 p" shows "Ifm vs (x#bs) p = Ifm vs bs (decr0 p)" using assms by (induct p rule: decr0.induct) (simp_all add: decrtm0) primrec decr :: "nat \ fm \ fm" where "decr m T = T" | "decr m F = F" | "decr m (Lt t) = (Lt (decrtm m t))" | "decr m (Le t) = (Le (decrtm m t))" | "decr m (Eq t) = (Eq (decrtm m t))" | "decr m (NEq t) = (NEq (decrtm m t))" | "decr m (Not p) = Not (decr m p)" | "decr m (And p q) = conj (decr m p) (decr m q)" | "decr m (Or p q) = disj (decr m p) (decr m q)" | "decr m (Imp p q) = imp (decr m p) (decr m q)" | "decr m (Iff p q) = iff (decr m p) (decr m q)" | "decr m (E p) = E (decr (Suc m) p)" | "decr m (A p) = A (decr (Suc m) p)" lemma decr: assumes bnd: "boundslt (length bs) p" and nb: "bound m p" and nle: "m < length bs" shows "Ifm vs (removen m bs) (decr m p) = Ifm vs bs p" using bnd nb nle proof (induct p arbitrary: bs m rule: fm.induct) case (E p bs m) have "Ifm vs (removen (Suc m) (x#bs)) (decr (Suc m) p) = Ifm vs (x#bs) p" for x proof - from E have bnd: "boundslt (length (x#bs)) p" and nb: "bound (Suc m) p" and nle: "Suc m < length (x#bs)" by auto from E(1)[OF bnd nb nle] show ?thesis . qed then show ?case by auto next case (A p bs m) have "Ifm vs (removen (Suc m) (x#bs)) (decr (Suc m) p) = Ifm vs (x#bs) p" for x proof - from A have bnd: "boundslt (length (x#bs)) p" and nb: "bound (Suc m) p" and nle: "Suc m < length (x#bs)" by auto from A(1)[OF bnd nb nle] show ?thesis . qed then show ?case by auto qed (auto simp add: decrtm removen_nth) primrec subst0 :: "tm \ fm \ fm" where "subst0 t T = T" | "subst0 t F = F" | "subst0 t (Lt a) = Lt (tmsubst0 t a)" | "subst0 t (Le a) = Le (tmsubst0 t a)" | "subst0 t (Eq a) = Eq (tmsubst0 t a)" | "subst0 t (NEq a) = NEq (tmsubst0 t a)" | "subst0 t (Not p) = Not (subst0 t p)" | "subst0 t (And p q) = And (subst0 t p) (subst0 t q)" | "subst0 t (Or p q) = Or (subst0 t p) (subst0 t q)" | "subst0 t (Imp p q) = Imp (subst0 t p) (subst0 t q)" | "subst0 t (Iff p q) = Iff (subst0 t p) (subst0 t q)" | "subst0 t (E p) = E p" | "subst0 t (A p) = A p" lemma subst0: assumes qf: "qfree p" shows "Ifm vs (x # bs) (subst0 t p) = Ifm vs ((Itm vs (x # bs) t) # bs) p" using qf tmsubst0[where x="x" and bs="bs" and t="t"] by (induct p rule: fm.induct) auto lemma subst0_nb: assumes bp: "tmbound0 t" and qf: "qfree p" shows "bound0 (subst0 t p)" using qf tmsubst0_nb[OF bp] bp by (induct p rule: fm.induct) auto primrec subst:: "nat \ tm \ fm \ fm" where "subst n t T = T" | "subst n t F = F" | "subst n t (Lt a) = Lt (tmsubst n t a)" | "subst n t (Le a) = Le (tmsubst n t a)" | "subst n t (Eq a) = Eq (tmsubst n t a)" | "subst n t (NEq a) = NEq (tmsubst n t a)" | "subst n t (Not p) = Not (subst n t p)" | "subst n t (And p q) = And (subst n t p) (subst n t q)" | "subst n t (Or p q) = Or (subst n t p) (subst n t q)" | "subst n t (Imp p q) = Imp (subst n t p) (subst n t q)" | "subst n t (Iff p q) = Iff (subst n t p) (subst n t q)" | "subst n t (E p) = E (subst (Suc n) (incrtm0 t) p)" | "subst n t (A p) = A (subst (Suc n) (incrtm0 t) p)" lemma subst: assumes nb: "boundslt (length bs) p" and nlm: "n \ length bs" shows "Ifm vs bs (subst n t p) = Ifm vs (bs[n:= Itm vs bs t]) p" using nb nlm proof (induct p arbitrary: bs n t rule: fm.induct) case (E p bs n) have "Ifm vs (x#bs) (subst (Suc n) (incrtm0 t) p) = Ifm vs (x#bs[n:= Itm vs bs t]) p" for x proof - from E have bn: "boundslt (length (x#bs)) p" by simp from E have nlm: "Suc n \ length (x#bs)" by simp from E(1)[OF bn nlm] have "Ifm vs (x#bs) (subst (Suc n) (incrtm0 t) p) = Ifm vs ((x#bs)[Suc n:= Itm vs (x#bs) (incrtm0 t)]) p" by simp then show ?thesis by (simp add: incrtm0[where x="x" and bs="bs" and t="t"]) qed then show ?case by simp next case (A p bs n) have "Ifm vs (x#bs) (subst (Suc n) (incrtm0 t) p) = Ifm vs (x#bs[n:= Itm vs bs t]) p" for x proof - from A have bn: "boundslt (length (x#bs)) p" by simp from A have nlm: "Suc n \ length (x#bs)" by simp from A(1)[OF bn nlm] have "Ifm vs (x#bs) (subst (Suc n) (incrtm0 t) p) = Ifm vs ((x#bs)[Suc n:= Itm vs (x#bs) (incrtm0 t)]) p" by simp then show ?thesis by (simp add: incrtm0[where x="x" and bs="bs" and t="t"]) qed then show ?case by simp qed (auto simp add: tmsubst) lemma subst_nb: assumes "tmbound m t" shows "bound m (subst m t p)" using assms tmsubst_nb incrtm0_tmbound by (induct p arbitrary: m t rule: fm.induct) auto lemma not_qf[simp]: "qfree p \ qfree (not p)" by (induct p rule: not.induct) auto lemma not_bn0[simp]: "bound0 p \ bound0 (not p)" by (induct p rule: not.induct) auto lemma not_nb[simp]: "bound n p \ bound n (not p)" by (induct p rule: not.induct) auto lemma not_blt[simp]: "boundslt n p \ boundslt n (not p)" by (induct p rule: not.induct) auto lemma conj_qf[simp]: "qfree p \ qfree q \ qfree (conj p q)" using conj_def by auto lemma conj_nb0[simp]: "bound0 p \ bound0 q \ bound0 (conj p q)" using conj_def by auto lemma conj_nb[simp]: "bound n p \ bound n q \ bound n (conj p q)" using conj_def by auto lemma conj_blt[simp]: "boundslt n p \ boundslt n q \ boundslt n (conj p q)" using conj_def by auto lemma disj_qf[simp]: "qfree p \ qfree q \ qfree (disj p q)" using disj_def by auto lemma disj_nb0[simp]: "bound0 p \ bound0 q \ bound0 (disj p q)" using disj_def by auto lemma disj_nb[simp]: "bound n p \ bound n q \ bound n (disj p q)" using disj_def by auto lemma disj_blt[simp]: "boundslt n p \ boundslt n q \ boundslt n (disj p q)" using disj_def by auto lemma imp_qf[simp]: "qfree p \ qfree q \ qfree (imp p q)" using imp_def by (cases "p = F \ q = T") (simp_all add: imp_def) lemma imp_nb0[simp]: "bound0 p \ bound0 q \ bound0 (imp p q)" using imp_def by (cases "p = F \ q = T \ p = q") (simp_all add: imp_def) lemma imp_nb[simp]: "bound n p \ bound n q \ bound n (imp p q)" using imp_def by (cases "p = F \ q = T \ p = q") (simp_all add: imp_def) lemma imp_blt[simp]: "boundslt n p \ boundslt n q \ boundslt n (imp p q)" using imp_def by auto lemma iff_qf[simp]: "qfree p \ qfree q \ qfree (iff p q)" unfolding iff_def by (cases "p = q") auto lemma iff_nb0[simp]: "bound0 p \ bound0 q \ bound0 (iff p q)" using iff_def unfolding iff_def by (cases "p = q") auto lemma iff_nb[simp]: "bound n p \ bound n q \ bound n (iff p q)" using iff_def unfolding iff_def by (cases "p = q") auto lemma iff_blt[simp]: "boundslt n p \ boundslt n q \ boundslt n (iff p q)" using iff_def by auto lemma decr0_qf: "bound0 p \ qfree (decr0 p)" by (induct p) simp_all fun isatom :: "fm \ bool" \ \test for atomicity\ where "isatom T = True" | "isatom F = True" | "isatom (Lt a) = True" | "isatom (Le a) = True" | "isatom (Eq a) = True" | "isatom (NEq a) = True" | "isatom p = False" lemma bound0_qf: "bound0 p \ qfree p" by (induct p) simp_all definition djf :: "('a \ fm) \ 'a \ fm \ fm" where "djf f p q \ (if q = T then T else if q = F then f p else (let fp = f p in case fp of T \ T | F \ q | _ \ Or (f p) q))" definition evaldjf :: "('a \ fm) \ 'a list \ fm" where "evaldjf f ps \ foldr (djf f) ps F" lemma djf_Or: "Ifm vs bs (djf f p q) = Ifm vs bs (Or (f p) q)" apply (cases "q = T") apply (simp add: djf_def) apply (cases "q = F") apply (simp add: djf_def) apply (cases "f p") apply (simp_all add: Let_def djf_def) done lemma evaldjf_ex: "Ifm vs bs (evaldjf f ps) \ (\p \ set ps. Ifm vs bs (f p))" by (induct ps) (simp_all add: evaldjf_def djf_Or) lemma evaldjf_bound0: assumes "\x\ set xs. bound0 (f x)" shows "bound0 (evaldjf f xs)" using assms apply (induct xs) apply (auto simp add: evaldjf_def djf_def Let_def) apply (case_tac "f a") apply auto done lemma evaldjf_qf: assumes "\x\ set xs. qfree (f x)" shows "qfree (evaldjf f xs)" using assms apply (induct xs) apply (auto simp add: evaldjf_def djf_def Let_def) apply (case_tac "f a") apply auto done fun disjuncts :: "fm \ fm list" where "disjuncts (Or p q) = disjuncts p @ disjuncts q" | "disjuncts F = []" | "disjuncts p = [p]" lemma disjuncts: "(\q \ set (disjuncts p). Ifm vs bs q) = Ifm vs bs p" by (induct p rule: disjuncts.induct) auto lemma disjuncts_nb: assumes "bound0 p" shows "\q \ set (disjuncts p). bound0 q" proof - from assms have "list_all bound0 (disjuncts p)" by (induct p rule: disjuncts.induct) auto then show ?thesis by (simp only: list_all_iff) qed lemma disjuncts_qf: assumes "qfree p" shows "\q \ set (disjuncts p). qfree q" proof - from assms have "list_all qfree (disjuncts p)" by (induct p rule: disjuncts.induct) auto then show ?thesis by (simp only: list_all_iff) qed definition DJ :: "(fm \ fm) \ fm \ fm" where "DJ f p \ evaldjf f (disjuncts p)" lemma DJ: assumes fdj: "\p q. Ifm vs bs (f (Or p q)) = Ifm vs bs (Or (f p) (f q))" and fF: "f F = F" shows "Ifm vs bs (DJ f p) = Ifm vs bs (f p)" proof - have "Ifm vs bs (DJ f p) = (\q \ set (disjuncts p). Ifm vs bs (f q))" by (simp add: DJ_def evaldjf_ex) also have "\ = Ifm vs bs (f p)" using fdj fF by (induct p rule: disjuncts.induct) auto finally show ?thesis . qed lemma DJ_qf: assumes fqf: "\p. qfree p \ qfree (f p)" shows "\p. qfree p \ qfree (DJ f p)" proof clarify fix p assume qf: "qfree p" have th: "DJ f p = evaldjf f (disjuncts p)" by (simp add: DJ_def) from disjuncts_qf[OF qf] have "\q\ set (disjuncts p). qfree q" . with fqf have th':"\q\ set (disjuncts p). qfree (f q)" by blast from evaldjf_qf[OF th'] th show "qfree (DJ f p)" by simp qed lemma DJ_qe: assumes qe: "\bs p. qfree p \ qfree (qe p) \ (Ifm vs bs (qe p) = Ifm vs bs (E p))" shows "\bs p. qfree p \ qfree (DJ qe p) \ (Ifm vs bs ((DJ qe p)) = Ifm vs bs (E p))" proof clarify fix p :: fm and bs assume qf: "qfree p" from qe have qth: "\p. qfree p \ qfree (qe p)" by blast from DJ_qf[OF qth] qf have qfth:"qfree (DJ qe p)" by auto have "Ifm vs bs (DJ qe p) \ (\q\ set (disjuncts p). Ifm vs bs (qe q))" by (simp add: DJ_def evaldjf_ex) also have "\ = (\q \ set(disjuncts p). Ifm vs bs (E q))" using qe disjuncts_qf[OF qf] by auto also have "\ = Ifm vs bs (E p)" by (induct p rule: disjuncts.induct) auto finally show "qfree (DJ qe p) \ Ifm vs bs (DJ qe p) = Ifm vs bs (E p)" using qfth by blast qed fun conjuncts :: "fm \ fm list" where "conjuncts (And p q) = conjuncts p @ conjuncts q" | "conjuncts T = []" | "conjuncts p = [p]" definition list_conj :: "fm list \ fm" where "list_conj ps \ foldr conj ps T" definition CJNB :: "(fm \ fm) \ fm \ fm" where "CJNB f p \ (let cjs = conjuncts p; (yes, no) = partition bound0 cjs in conj (decr0 (list_conj yes)) (f (list_conj no)))" lemma conjuncts_qf: "qfree p \ \q \ set (conjuncts p). qfree q" proof - assume qf: "qfree p" then have "list_all qfree (conjuncts p)" by (induct p rule: conjuncts.induct) auto then show ?thesis by (simp only: list_all_iff) qed lemma conjuncts: "(\q\ set (conjuncts p). Ifm vs bs q) = Ifm vs bs p" by (induct p rule: conjuncts.induct) auto lemma conjuncts_nb: assumes "bound0 p" shows "\q \ set (conjuncts p). bound0 q" proof - from assms have "list_all bound0 (conjuncts p)" by (induct p rule:conjuncts.induct) auto then show ?thesis by (simp only: list_all_iff) qed fun islin :: "fm \ bool" where "islin (And p q) = (islin p \ islin q \ p \ T \ p \ F \ q \ T \ q \ F)" | "islin (Or p q) = (islin p \ islin q \ p \ T \ p \ F \ q \ T \ q \ F)" | "islin (Eq (CNP 0 c s)) = (isnpoly c \ c \ 0\<^sub>p \ tmbound0 s \ allpolys isnpoly s)" | "islin (NEq (CNP 0 c s)) = (isnpoly c \ c \ 0\<^sub>p \ tmbound0 s \ allpolys isnpoly s)" | "islin (Lt (CNP 0 c s)) = (isnpoly c \ c \ 0\<^sub>p \ tmbound0 s \ allpolys isnpoly s)" | "islin (Le (CNP 0 c s)) = (isnpoly c \ c \ 0\<^sub>p \ tmbound0 s \ allpolys isnpoly s)" | "islin (Not p) = False" | "islin (Imp p q) = False" | "islin (Iff p q) = False" | "islin p = bound0 p" lemma islin_stupid: assumes nb: "tmbound0 p" shows "islin (Lt p)" and "islin (Le p)" and "islin (Eq p)" and "islin (NEq p)" using nb by (cases p, auto, rename_tac nat a b, case_tac nat, auto)+ definition "lt p = (case p of CP (C c) \ if 0>\<^sub>N c then T else F| _ \ Lt p)" definition "le p = (case p of CP (C c) \ if 0\\<^sub>N c then T else F | _ \ Le p)" definition "eq p = (case p of CP (C c) \ if c = 0\<^sub>N then T else F | _ \ Eq p)" definition "neq p = not (eq p)" lemma lt: "allpolys isnpoly p \ Ifm vs bs (lt p) = Ifm vs bs (Lt p)" apply (simp add: lt_def) apply (cases p) apply simp_all apply (rename_tac poly, case_tac poly) apply (simp_all add: isnpoly_def) done lemma le: "allpolys isnpoly p \ Ifm vs bs (le p) = Ifm vs bs (Le p)" apply (simp add: le_def) apply (cases p) apply simp_all apply (rename_tac poly, case_tac poly) apply (simp_all add: isnpoly_def) done lemma eq: "allpolys isnpoly p \ Ifm vs bs (eq p) = Ifm vs bs (Eq p)" apply (simp add: eq_def) apply (cases p) apply simp_all apply (rename_tac poly, case_tac poly) apply (simp_all add: isnpoly_def) done lemma neq: "allpolys isnpoly p \ Ifm vs bs (neq p) = Ifm vs bs (NEq p)" by (simp add: neq_def eq) lemma lt_lin: "tmbound0 p \ islin (lt p)" apply (simp add: lt_def) apply (cases p) apply simp_all apply (rename_tac poly, case_tac poly) apply simp_all apply (rename_tac nat a b, case_tac nat) apply simp_all done lemma le_lin: "tmbound0 p \ islin (le p)" apply (simp add: le_def) apply (cases p) apply simp_all apply (rename_tac poly, case_tac poly) apply simp_all apply (rename_tac nat a b, case_tac nat) apply simp_all done lemma eq_lin: "tmbound0 p \ islin (eq p)" apply (simp add: eq_def) apply (cases p) apply simp_all apply (rename_tac poly, case_tac poly) apply simp_all apply (rename_tac nat a b, case_tac nat) apply simp_all done lemma neq_lin: "tmbound0 p \ islin (neq p)" apply (simp add: neq_def eq_def) apply (cases p) apply simp_all apply (rename_tac poly, case_tac poly) apply simp_all apply (rename_tac nat a b, case_tac nat) apply simp_all done definition "simplt t = (let (c,s) = split0 (simptm t) in if c= 0\<^sub>p then lt s else Lt (CNP 0 c s))" definition "simple t = (let (c,s) = split0 (simptm t) in if c= 0\<^sub>p then le s else Le (CNP 0 c s))" definition "simpeq t = (let (c,s) = split0 (simptm t) in if c= 0\<^sub>p then eq s else Eq (CNP 0 c s))" definition "simpneq t = (let (c,s) = split0 (simptm t) in if c= 0\<^sub>p then neq s else NEq (CNP 0 c s))" lemma simplt_islin [simp]: assumes "SORT_CONSTRAINT('a::field_char_0)" shows "islin (simplt t)" unfolding simplt_def using split0_nb0' by (auto simp add: lt_lin Let_def split_def isnpoly_fst_split0[OF simptm_allpolys_npoly] islin_stupid allpolys_split0[OF simptm_allpolys_npoly]) lemma simple_islin [simp]: assumes "SORT_CONSTRAINT('a::field_char_0)" shows "islin (simple t)" unfolding simple_def using split0_nb0' by (auto simp add: Let_def split_def isnpoly_fst_split0[OF simptm_allpolys_npoly] islin_stupid allpolys_split0[OF simptm_allpolys_npoly] le_lin) lemma simpeq_islin [simp]: assumes "SORT_CONSTRAINT('a::field_char_0)" shows "islin (simpeq t)" unfolding simpeq_def using split0_nb0' by (auto simp add: Let_def split_def isnpoly_fst_split0[OF simptm_allpolys_npoly] islin_stupid allpolys_split0[OF simptm_allpolys_npoly] eq_lin) lemma simpneq_islin [simp]: assumes "SORT_CONSTRAINT('a::field_char_0)" shows "islin (simpneq t)" unfolding simpneq_def using split0_nb0' by (auto simp add: Let_def split_def isnpoly_fst_split0[OF simptm_allpolys_npoly] islin_stupid allpolys_split0[OF simptm_allpolys_npoly] neq_lin) lemma really_stupid: "\ (\c1 s'. (c1, s') \ split0 s)" by (cases "split0 s") auto lemma split0_npoly: assumes "SORT_CONSTRAINT('a::field_char_0)" and *: "allpolys isnpoly t" shows "isnpoly (fst (split0 t))" and "allpolys isnpoly (snd (split0 t))" using * by (induct t rule: split0.induct) (auto simp add: Let_def split_def polyadd_norm polymul_norm polyneg_norm polysub_norm really_stupid) lemma simplt[simp]: "Ifm vs bs (simplt t) = Ifm vs bs (Lt t)" proof - have *: "allpolys isnpoly (simptm t)" by simp let ?t = "simptm t" show ?thesis proof (cases "fst (split0 ?t) = 0\<^sub>p") case True then show ?thesis using split0[of "simptm t" vs bs] lt[OF split0_npoly(2)[OF *], of vs bs] by (simp add: simplt_def Let_def split_def lt) next case False then show ?thesis using split0[of "simptm t" vs bs] by (simp add: simplt_def Let_def split_def) qed qed lemma simple[simp]: "Ifm vs bs (simple t) = Ifm vs bs (Le t)" proof - have *: "allpolys isnpoly (simptm t)" by simp let ?t = "simptm t" show ?thesis proof (cases "fst (split0 ?t) = 0\<^sub>p") case True then show ?thesis using split0[of "simptm t" vs bs] le[OF split0_npoly(2)[OF *], of vs bs] by (simp add: simple_def Let_def split_def le) next case False then show ?thesis using split0[of "simptm t" vs bs] by (simp add: simple_def Let_def split_def) qed qed lemma simpeq[simp]: "Ifm vs bs (simpeq t) = Ifm vs bs (Eq t)" proof - have n: "allpolys isnpoly (simptm t)" by simp let ?t = "simptm t" show ?thesis proof (cases "fst (split0 ?t) = 0\<^sub>p") case True then show ?thesis using split0[of "simptm t" vs bs] eq[OF split0_npoly(2)[OF n], of vs bs] by (simp add: simpeq_def Let_def split_def) next case False then show ?thesis using split0[of "simptm t" vs bs] by (simp add: simpeq_def Let_def split_def) qed qed lemma simpneq[simp]: "Ifm vs bs (simpneq t) = Ifm vs bs (NEq t)" proof - have n: "allpolys isnpoly (simptm t)" by simp let ?t = "simptm t" show ?thesis proof (cases "fst (split0 ?t) = 0\<^sub>p") case True then show ?thesis using split0[of "simptm t" vs bs] neq[OF split0_npoly(2)[OF n], of vs bs] by (simp add: simpneq_def Let_def split_def) next case False then show ?thesis using split0[of "simptm t" vs bs] by (simp add: simpneq_def Let_def split_def) qed qed lemma lt_nb: "tmbound0 t \ bound0 (lt t)" apply (simp add: lt_def) apply (cases t) apply auto apply (rename_tac poly, case_tac poly) apply auto done lemma le_nb: "tmbound0 t \ bound0 (le t)" apply (simp add: le_def) apply (cases t) apply auto apply (rename_tac poly, case_tac poly) apply auto done lemma eq_nb: "tmbound0 t \ bound0 (eq t)" apply (simp add: eq_def) apply (cases t) apply auto apply (rename_tac poly, case_tac poly) apply auto done lemma neq_nb: "tmbound0 t \ bound0 (neq t)" apply (simp add: neq_def eq_def) apply (cases t) apply auto apply (rename_tac poly, case_tac poly) apply auto done lemma simplt_nb[simp]: assumes "SORT_CONSTRAINT('a::field_char_0)" shows "tmbound0 t \ bound0 (simplt t)" proof (simp add: simplt_def Let_def split_def) assume "tmbound0 t" then have *: "tmbound0 (simptm t)" by simp let ?c = "fst (split0 (simptm t))" from tmbound_split0[OF *[unfolded tmbound0_tmbound_iff[symmetric]]] have th: "\bs. Ipoly bs ?c = Ipoly bs 0\<^sub>p" by auto from isnpoly_fst_split0[OF simptm_allpolys_npoly[of t]] have ths: "isnpolyh ?c 0" "isnpolyh 0\<^sub>p 0" by (simp_all add: isnpoly_def) from iffD1[OF isnpolyh_unique[OF ths] th] have "fst (split0 (simptm t)) = 0\<^sub>p" . then show "(fst (split0 (simptm t)) = 0\<^sub>p \ bound0 (lt (snd (split0 (simptm t))))) \ fst (split0 (simptm t)) = 0\<^sub>p" by (simp add: simplt_def Let_def split_def lt_nb) qed lemma simple_nb[simp]: assumes "SORT_CONSTRAINT('a::field_char_0)" shows "tmbound0 t \ bound0 (simple t)" proof(simp add: simple_def Let_def split_def) assume "tmbound0 t" then have *: "tmbound0 (simptm t)" by simp let ?c = "fst (split0 (simptm t))" from tmbound_split0[OF *[unfolded tmbound0_tmbound_iff[symmetric]]] have th: "\bs. Ipoly bs ?c = Ipoly bs 0\<^sub>p" by auto from isnpoly_fst_split0[OF simptm_allpolys_npoly[of t]] have ths: "isnpolyh ?c 0" "isnpolyh 0\<^sub>p 0" by (simp_all add: isnpoly_def) from iffD1[OF isnpolyh_unique[OF ths] th] have "fst (split0 (simptm t)) = 0\<^sub>p" . then show "(fst (split0 (simptm t)) = 0\<^sub>p \ bound0 (le (snd (split0 (simptm t))))) \ fst (split0 (simptm t)) = 0\<^sub>p" by (simp add: simplt_def Let_def split_def le_nb) qed lemma simpeq_nb[simp]: assumes "SORT_CONSTRAINT('a::field_char_0)" shows "tmbound0 t \ bound0 (simpeq t)" proof (simp add: simpeq_def Let_def split_def) assume "tmbound0 t" then have *: "tmbound0 (simptm t)" by simp let ?c = "fst (split0 (simptm t))" from tmbound_split0[OF *[unfolded tmbound0_tmbound_iff[symmetric]]] have th: "\bs. Ipoly bs ?c = Ipoly bs 0\<^sub>p" by auto from isnpoly_fst_split0[OF simptm_allpolys_npoly[of t]] have ths: "isnpolyh ?c 0" "isnpolyh 0\<^sub>p 0" by (simp_all add: isnpoly_def) from iffD1[OF isnpolyh_unique[OF ths] th] have "fst (split0 (simptm t)) = 0\<^sub>p" . then show "(fst (split0 (simptm t)) = 0\<^sub>p \ bound0 (eq (snd (split0 (simptm t))))) \ fst (split0 (simptm t)) = 0\<^sub>p" by (simp add: simpeq_def Let_def split_def eq_nb) qed lemma simpneq_nb[simp]: assumes "SORT_CONSTRAINT('a::field_char_0)" shows "tmbound0 t \ bound0 (simpneq t)" proof (simp add: simpneq_def Let_def split_def) assume "tmbound0 t" then have *: "tmbound0 (simptm t)" by simp let ?c = "fst (split0 (simptm t))" from tmbound_split0[OF *[unfolded tmbound0_tmbound_iff[symmetric]]] have th: "\bs. Ipoly bs ?c = Ipoly bs 0\<^sub>p" by auto from isnpoly_fst_split0[OF simptm_allpolys_npoly[of t]] have ths: "isnpolyh ?c 0" "isnpolyh 0\<^sub>p 0" by (simp_all add: isnpoly_def) from iffD1[OF isnpolyh_unique[OF ths] th] have "fst (split0 (simptm t)) = 0\<^sub>p" . then show "(fst (split0 (simptm t)) = 0\<^sub>p \ bound0 (neq (snd (split0 (simptm t))))) \ fst (split0 (simptm t)) = 0\<^sub>p" by (simp add: simpneq_def Let_def split_def neq_nb) qed fun conjs :: "fm \ fm list" where "conjs (And p q) = conjs p @ conjs q" | "conjs T = []" | "conjs p = [p]" lemma conjs_ci: "(\q \ set (conjs p). Ifm vs bs q) = Ifm vs bs p" by (induct p rule: conjs.induct) auto definition list_disj :: "fm list \ fm" where "list_disj ps \ foldr disj ps F" lemma list_conj: "Ifm vs bs (list_conj ps) = (\p\ set ps. Ifm vs bs p)" by (induct ps) (auto simp add: list_conj_def) lemma list_conj_qf: " \p\ set ps. qfree p \ qfree (list_conj ps)" by (induct ps) (auto simp add: list_conj_def) lemma list_disj: "Ifm vs bs (list_disj ps) = (\p\ set ps. Ifm vs bs p)" by (induct ps) (auto simp add: list_disj_def) lemma conj_boundslt: "boundslt n p \ boundslt n q \ boundslt n (conj p q)" unfolding conj_def by auto lemma conjs_nb: "bound n p \ \q\ set (conjs p). bound n q" apply (induct p rule: conjs.induct) apply (unfold conjs.simps) apply (unfold set_append) apply (unfold ball_Un) apply (unfold bound.simps) apply auto done lemma conjs_boundslt: "boundslt n p \ \q\ set (conjs p). boundslt n q" apply (induct p rule: conjs.induct) apply (unfold conjs.simps) apply (unfold set_append) apply (unfold ball_Un) apply (unfold boundslt.simps) apply blast apply simp_all done lemma list_conj_boundslt: " \p\ set ps. boundslt n p \ boundslt n (list_conj ps)" by (induct ps) (auto simp: list_conj_def) lemma list_conj_nb: assumes "\p\ set ps. bound n p" shows "bound n (list_conj ps)" using assms by (induct ps) (auto simp: list_conj_def) lemma list_conj_nb': "\p\set ps. bound0 p \ bound0 (list_conj ps)" by (induct ps) (auto simp: list_conj_def) lemma CJNB_qe: assumes qe: "\bs p. qfree p \ qfree (qe p) \ (Ifm vs bs (qe p) = Ifm vs bs (E p))" shows "\bs p. qfree p \ qfree (CJNB qe p) \ (Ifm vs bs ((CJNB qe p)) = Ifm vs bs (E p))" proof clarify fix bs p assume qfp: "qfree p" let ?cjs = "conjuncts p" let ?yes = "fst (partition bound0 ?cjs)" let ?no = "snd (partition bound0 ?cjs)" let ?cno = "list_conj ?no" let ?cyes = "list_conj ?yes" have part: "partition bound0 ?cjs = (?yes,?no)" by simp from partition_P[OF part] have "\q\ set ?yes. bound0 q" by blast then have yes_nb: "bound0 ?cyes" by (simp add: list_conj_nb') then have yes_qf: "qfree (decr0 ?cyes)" by (simp add: decr0_qf) from conjuncts_qf[OF qfp] partition_set[OF part] have " \q\ set ?no. qfree q" by auto then have no_qf: "qfree ?cno" by (simp add: list_conj_qf) with qe have cno_qf:"qfree (qe ?cno)" and noE: "Ifm vs bs (qe ?cno) = Ifm vs bs (E ?cno)" by blast+ from cno_qf yes_qf have qf: "qfree (CJNB qe p)" by (simp add: CJNB_def Let_def split_def) have "Ifm vs bs p = ((Ifm vs bs ?cyes) \ (Ifm vs bs ?cno))" for bs proof - from conjuncts have "Ifm vs bs p = (\q\ set ?cjs. Ifm vs bs q)" by blast also have "\ = ((\q\ set ?yes. Ifm vs bs q) \ (\q\ set ?no. Ifm vs bs q))" using partition_set[OF part] by auto finally show ?thesis using list_conj[of vs bs] by simp qed then have "Ifm vs bs (E p) = (\x. (Ifm vs (x#bs) ?cyes) \ (Ifm vs (x#bs) ?cno))" by simp also fix y have "\ = (\x. (Ifm vs (y#bs) ?cyes) \ (Ifm vs (x#bs) ?cno))" using bound0_I[OF yes_nb, where bs="bs" and b'="y"] by blast also have "\ = (Ifm vs bs (decr0 ?cyes) \ Ifm vs bs (E ?cno))" by (auto simp add: decr0[OF yes_nb] simp del: partition_filter_conv) also have "\ = (Ifm vs bs (conj (decr0 ?cyes) (qe ?cno)))" using qe[rule_format, OF no_qf] by auto finally have "Ifm vs bs (E p) = Ifm vs bs (CJNB qe p)" by (simp add: Let_def CJNB_def split_def) with qf show "qfree (CJNB qe p) \ Ifm vs bs (CJNB qe p) = Ifm vs bs (E p)" by blast qed fun simpfm :: "fm \ fm" where "simpfm (Lt t) = simplt (simptm t)" | "simpfm (Le t) = simple (simptm t)" | "simpfm (Eq t) = simpeq(simptm t)" | "simpfm (NEq t) = simpneq(simptm t)" | "simpfm (And p q) = conj (simpfm p) (simpfm q)" | "simpfm (Or p q) = disj (simpfm p) (simpfm q)" | "simpfm (Imp p q) = disj (simpfm (Not p)) (simpfm q)" | "simpfm (Iff p q) = disj (conj (simpfm p) (simpfm q)) (conj (simpfm (Not p)) (simpfm (Not q)))" | "simpfm (Not (And p q)) = disj (simpfm (Not p)) (simpfm (Not q))" | "simpfm (Not (Or p q)) = conj (simpfm (Not p)) (simpfm (Not q))" | "simpfm (Not (Imp p q)) = conj (simpfm p) (simpfm (Not q))" | "simpfm (Not (Iff p q)) = disj (conj (simpfm p) (simpfm (Not q))) (conj (simpfm (Not p)) (simpfm q))" | "simpfm (Not (Eq t)) = simpneq t" | "simpfm (Not (NEq t)) = simpeq t" | "simpfm (Not (Le t)) = simplt (Neg t)" | "simpfm (Not (Lt t)) = simple (Neg t)" | "simpfm (Not (Not p)) = simpfm p" | "simpfm (Not T) = F" | "simpfm (Not F) = T" | "simpfm p = p" lemma simpfm[simp]: "Ifm vs bs (simpfm p) = Ifm vs bs p" by (induct p arbitrary: bs rule: simpfm.induct) auto lemma simpfm_bound0: assumes "SORT_CONSTRAINT('a::field_char_0)" shows "bound0 p \ bound0 (simpfm p)" by (induct p rule: simpfm.induct) auto lemma lt_qf[simp]: "qfree (lt t)" apply (cases t) apply (auto simp add: lt_def) apply (rename_tac poly, case_tac poly) apply auto done lemma le_qf[simp]: "qfree (le t)" apply (cases t) apply (auto simp add: le_def) apply (rename_tac poly, case_tac poly) apply auto done lemma eq_qf[simp]: "qfree (eq t)" apply (cases t) apply (auto simp add: eq_def) apply (rename_tac poly, case_tac poly) apply auto done lemma neq_qf[simp]: "qfree (neq t)" by (simp add: neq_def) lemma simplt_qf[simp]: "qfree (simplt t)" by (simp add: simplt_def Let_def split_def) lemma simple_qf[simp]: "qfree (simple t)" by (simp add: simple_def Let_def split_def) lemma simpeq_qf[simp]: "qfree (simpeq t)" by (simp add: simpeq_def Let_def split_def) lemma simpneq_qf[simp]: "qfree (simpneq t)" by (simp add: simpneq_def Let_def split_def) lemma simpfm_qf[simp]: "qfree p \ qfree (simpfm p)" by (induct p rule: simpfm.induct) auto lemma disj_lin: "islin p \ islin q \ islin (disj p q)" by (simp add: disj_def) lemma conj_lin: "islin p \ islin q \ islin (conj p q)" by (simp add: conj_def) lemma assumes "SORT_CONSTRAINT('a::field_char_0)" shows "qfree p \ islin (simpfm p)" by (induct p rule: simpfm.induct) (simp_all add: conj_lin disj_lin) fun prep :: "fm \ fm" where "prep (E T) = T" | "prep (E F) = F" | "prep (E (Or p q)) = disj (prep (E p)) (prep (E q))" | "prep (E (Imp p q)) = disj (prep (E (Not p))) (prep (E q))" | "prep (E (Iff p q)) = disj (prep (E (And p q))) (prep (E (And (Not p) (Not q))))" | "prep (E (Not (And p q))) = disj (prep (E (Not p))) (prep (E(Not q)))" | "prep (E (Not (Imp p q))) = prep (E (And p (Not q)))" | "prep (E (Not (Iff p q))) = disj (prep (E (And p (Not q)))) (prep (E(And (Not p) q)))" | "prep (E p) = E (prep p)" | "prep (A (And p q)) = conj (prep (A p)) (prep (A q))" | "prep (A p) = prep (Not (E (Not p)))" | "prep (Not (Not p)) = prep p" | "prep (Not (And p q)) = disj (prep (Not p)) (prep (Not q))" | "prep (Not (A p)) = prep (E (Not p))" | "prep (Not (Or p q)) = conj (prep (Not p)) (prep (Not q))" | "prep (Not (Imp p q)) = conj (prep p) (prep (Not q))" | "prep (Not (Iff p q)) = disj (prep (And p (Not q))) (prep (And (Not p) q))" | "prep (Not p) = not (prep p)" | "prep (Or p q) = disj (prep p) (prep q)" | "prep (And p q) = conj (prep p) (prep q)" | "prep (Imp p q) = prep (Or (Not p) q)" | "prep (Iff p q) = disj (prep (And p q)) (prep (And (Not p) (Not q)))" | "prep p = p" lemma prep: "Ifm vs bs (prep p) = Ifm vs bs p" by (induct p arbitrary: bs rule: prep.induct) auto text \Generic quantifier elimination.\ fun qelim :: "fm \ (fm \ fm) \ fm" where "qelim (E p) = (\qe. DJ (CJNB qe) (qelim p qe))" | "qelim (A p) = (\qe. not (qe ((qelim (Not p) qe))))" | "qelim (Not p) = (\qe. not (qelim p qe))" | "qelim (And p q) = (\qe. conj (qelim p qe) (qelim q qe))" | "qelim (Or p q) = (\qe. disj (qelim p qe) (qelim q qe))" | "qelim (Imp p q) = (\qe. imp (qelim p qe) (qelim q qe))" | "qelim (Iff p q) = (\qe. iff (qelim p qe) (qelim q qe))" | "qelim p = (\y. simpfm p)" lemma qelim: assumes qe_inv: "\bs p. qfree p \ qfree (qe p) \ (Ifm vs bs (qe p) = Ifm vs bs (E p))" shows "\ bs. qfree (qelim p qe) \ (Ifm vs bs (qelim p qe) = Ifm vs bs p)" using qe_inv DJ_qe[OF CJNB_qe[OF qe_inv]] by (induct p rule: qelim.induct) auto subsection \Core Procedure\ fun minusinf:: "fm \ fm" \ \virtual substitution of \-\\\ where "minusinf (And p q) = conj (minusinf p) (minusinf q)" | "minusinf (Or p q) = disj (minusinf p) (minusinf q)" | "minusinf (Eq (CNP 0 c e)) = conj (eq (CP c)) (eq e)" | "minusinf (NEq (CNP 0 c e)) = disj (not (eq e)) (not (eq (CP c)))" | "minusinf (Lt (CNP 0 c e)) = disj (conj (eq (CP c)) (lt e)) (lt (CP (~\<^sub>p c)))" | "minusinf (Le (CNP 0 c e)) = disj (conj (eq (CP c)) (le e)) (lt (CP (~\<^sub>p c)))" | "minusinf p = p" fun plusinf:: "fm \ fm" \ \virtual substitution of \+\\\ where "plusinf (And p q) = conj (plusinf p) (plusinf q)" | "plusinf (Or p q) = disj (plusinf p) (plusinf q)" | "plusinf (Eq (CNP 0 c e)) = conj (eq (CP c)) (eq e)" | "plusinf (NEq (CNP 0 c e)) = disj (not (eq e)) (not (eq (CP c)))" | "plusinf (Lt (CNP 0 c e)) = disj (conj (eq (CP c)) (lt e)) (lt (CP c))" | "plusinf (Le (CNP 0 c e)) = disj (conj (eq (CP c)) (le e)) (lt (CP c))" | "plusinf p = p" lemma minusinf_inf: assumes "islin p" shows "\z. \x < z. Ifm vs (x#bs) (minusinf p) \ Ifm vs (x#bs) p" using assms proof (induct p rule: minusinf.induct) case 1 then show ?case apply auto apply (rule_tac x="min z za" in exI) apply auto done next case 2 then show ?case apply auto apply (rule_tac x="min z za" in exI) apply auto done next case (3 c e) then have nbe: "tmbound0 e" by simp from 3 have nc: "allpolys isnpoly (CP c)" "allpolys isnpoly e" by simp_all note eqs = eq[OF nc(1), where ?'a = 'a] eq[OF nc(2), where ?'a = 'a] let ?c = "Ipoly vs c" fix y let ?e = "Itm vs (y#bs) e" consider "?c = 0" | "?c > 0" | "?c < 0" by arith then show ?case proof cases case 1 then show ?thesis using eq[OF nc(2), of vs] eq[OF nc(1), of vs] by auto next case c: 2 have "Ifm vs (x#bs) (Eq (CNP 0 c e)) = Ifm vs (x#bs) (minusinf (Eq (CNP 0 c e)))" if "x < -?e / ?c" for x proof - from that have "?c * x < - ?e" using pos_less_divide_eq[OF c, where a="x" and b="-?e"] by (simp add: mult.commute) then have "?c * x + ?e < 0" by simp then show ?thesis using eqs tmbound0_I[OF nbe, where b="y" and b'="x" and vs=vs and bs=bs] by auto qed then show ?thesis by auto next case c: 3 have "Ifm vs (x#bs) (Eq (CNP 0 c e)) = Ifm vs (x#bs) (minusinf (Eq (CNP 0 c e)))" if "x < -?e / ?c" for x proof - from that have "?c * x > - ?e" using neg_less_divide_eq[OF c, where a="x" and b="-?e"] by (simp add: mult.commute) then have "?c * x + ?e > 0" by simp then show ?thesis using tmbound0_I[OF nbe, where b="y" and b'="x"] eqs by auto qed then show ?thesis by auto qed next case (4 c e) then have nbe: "tmbound0 e" by simp from 4 have nc: "allpolys isnpoly (CP c)" "allpolys isnpoly e" by simp_all note eqs = eq[OF nc(1), where ?'a = 'a] eq[OF nc(2), where ?'a = 'a] let ?c = "Ipoly vs c" fix y let ?e = "Itm vs (y#bs) e" consider "?c = 0" | "?c > 0" | "?c < 0" by arith then show ?case proof cases case 1 then show ?thesis using eqs by auto next case c: 2 have "Ifm vs (x#bs) (NEq (CNP 0 c e)) = Ifm vs (x#bs) (minusinf (NEq (CNP 0 c e)))" if "x < -?e / ?c" for x proof - from that have "?c * x < - ?e" using pos_less_divide_eq[OF c, where a="x" and b="-?e"] by (simp add: mult.commute) then have "?c * x + ?e < 0" by simp then show ?thesis using eqs tmbound0_I[OF nbe, where b="y" and b'="x"] by auto qed then show ?thesis by auto next case c: 3 have "Ifm vs (x#bs) (NEq (CNP 0 c e)) = Ifm vs (x#bs) (minusinf (NEq (CNP 0 c e)))" if "x < -?e / ?c" for x proof - from that have "?c * x > - ?e" using neg_less_divide_eq[OF c, where a="x" and b="-?e"] by (simp add: mult.commute) then have "?c * x + ?e > 0" by simp then show ?thesis using eqs tmbound0_I[OF nbe, where b="y" and b'="x"] by auto qed then show ?thesis by auto qed next case (5 c e) then have nbe: "tmbound0 e" by simp from 5 have nc: "allpolys isnpoly (CP c)" "allpolys isnpoly e" by simp_all then have nc': "allpolys isnpoly (CP (~\<^sub>p c))" by (simp add: polyneg_norm) note eqs = lt[OF nc', where ?'a = 'a] eq [OF nc(1), where ?'a = 'a] lt[OF nc(2), where ?'a = 'a] let ?c = "Ipoly vs c" fix y let ?e = "Itm vs (y#bs) e" consider "?c = 0" | "?c > 0" | "?c < 0" by arith then show ?case proof cases case 1 then show ?thesis using eqs by auto next case c: 2 have "Ifm vs (x#bs) (Lt (CNP 0 c e)) = Ifm vs (x#bs) (minusinf (Lt (CNP 0 c e)))" if "x < -?e / ?c" for x proof - from that have "?c * x < - ?e" using pos_less_divide_eq[OF c, where a="x" and b="-?e"] by (simp add: mult.commute) then have "?c * x + ?e < 0" by simp then show ?thesis using tmbound0_I[OF nbe, where b="y" and b'="x"] c eqs by auto qed then show ?thesis by auto next case c: 3 have "Ifm vs (x#bs) (Lt (CNP 0 c e)) = Ifm vs (x#bs) (minusinf (Lt (CNP 0 c e)))" if "x < -?e / ?c" for x proof - from that have "?c * x > - ?e" using neg_less_divide_eq[OF c, where a="x" and b="-?e"] by (simp add: mult.commute) then have "?c * x + ?e > 0" by simp then show ?thesis using eqs tmbound0_I[OF nbe, where b="y" and b'="x"] c by auto qed then show ?thesis by auto qed next case (6 c e) then have nbe: "tmbound0 e" by simp from 6 have nc: "allpolys isnpoly (CP c)" "allpolys isnpoly e" by simp_all then have nc': "allpolys isnpoly (CP (~\<^sub>p c))" by (simp add: polyneg_norm) note eqs = lt[OF nc', where ?'a = 'a] eq [OF nc(1), where ?'a = 'a] le[OF nc(2), where ?'a = 'a] let ?c = "Ipoly vs c" fix y let ?e = "Itm vs (y#bs) e" consider "?c = 0" | "?c > 0" | "?c < 0" by arith then show ?case proof cases case 1 then show ?thesis using eqs by auto next case c: 2 have "Ifm vs (x#bs) (Le (CNP 0 c e)) = Ifm vs (x#bs) (minusinf (Le (CNP 0 c e)))" if "x < -?e / ?c" for x proof - from that have "?c * x < - ?e" using pos_less_divide_eq[OF c, where a="x" and b="-?e"] by (simp add: mult.commute) then have "?c * x + ?e < 0" by simp then show ?thesis using tmbound0_I[OF nbe, where b="y" and b'="x"] c eqs by auto qed then show ?thesis by auto next case c: 3 have "Ifm vs (x#bs) (Le (CNP 0 c e)) = Ifm vs (x#bs) (minusinf (Le (CNP 0 c e)))" if "x < -?e / ?c" for x proof - from that have "?c * x > - ?e" using neg_less_divide_eq[OF c, where a="x" and b="-?e"] by (simp add: mult.commute) then have "?c * x + ?e > 0" by simp then show ?thesis using tmbound0_I[OF nbe, where b="y" and b'="x"] c eqs by auto qed then show ?thesis by auto qed qed auto lemma plusinf_inf: assumes "islin p" shows "\z. \x > z. Ifm vs (x#bs) (plusinf p) \ Ifm vs (x#bs) p" using assms proof (induct p rule: plusinf.induct) case 1 then show ?case apply auto apply (rule_tac x="max z za" in exI) apply auto done next case 2 then show ?case apply auto apply (rule_tac x="max z za" in exI) apply auto done next case (3 c e) then have nbe: "tmbound0 e" by simp from 3 have nc: "allpolys isnpoly (CP c)" "allpolys isnpoly e" by simp_all note eqs = eq[OF nc(1), where ?'a = 'a] eq[OF nc(2), where ?'a = 'a] let ?c = "Ipoly vs c" fix y let ?e = "Itm vs (y#bs) e" consider "?c = 0" | "?c > 0" | "?c < 0" by arith then show ?case proof cases case 1 then show ?thesis using eq[OF nc(2), of vs] eq[OF nc(1), of vs] by auto next case c: 2 have "Ifm vs (x#bs) (Eq (CNP 0 c e)) = Ifm vs (x#bs) (plusinf (Eq (CNP 0 c e)))" if "x > -?e / ?c" for x proof - from that have "?c * x > - ?e" using pos_divide_less_eq[OF c, where a="x" and b="-?e"] by (simp add: mult.commute) then have "?c * x + ?e > 0" by simp then show ?thesis using eqs tmbound0_I[OF nbe, where b="y" and b'="x" and vs=vs and bs=bs] by auto qed then show ?thesis by auto next case c: 3 have "Ifm vs (x#bs) (Eq (CNP 0 c e)) = Ifm vs (x#bs) (plusinf (Eq (CNP 0 c e)))" if "x > -?e / ?c" for x proof - from that have "?c * x < - ?e" using neg_divide_less_eq[OF c, where a="x" and b="-?e"] by (simp add: mult.commute) then have "?c * x + ?e < 0" by simp then show ?thesis using tmbound0_I[OF nbe, where b="y" and b'="x"] eqs by auto qed then show ?thesis by auto qed next case (4 c e) then have nbe: "tmbound0 e" by simp from 4 have nc: "allpolys isnpoly (CP c)" "allpolys isnpoly e" by simp_all note eqs = eq[OF nc(1), where ?'a = 'a] eq[OF nc(2), where ?'a = 'a] let ?c = "Ipoly vs c" fix y let ?e = "Itm vs (y#bs) e" consider "?c = 0" | "?c > 0" | "?c < 0" by arith then show ?case proof cases case 1 then show ?thesis using eqs by auto next case c: 2 have "Ifm vs (x#bs) (NEq (CNP 0 c e)) = Ifm vs (x#bs) (plusinf (NEq (CNP 0 c e)))" if "x > -?e / ?c" for x proof - from that have "?c * x > - ?e" using pos_divide_less_eq[OF c, where a="x" and b="-?e"] by (simp add: mult.commute) then have "?c * x + ?e > 0" by simp then show ?thesis using eqs tmbound0_I[OF nbe, where b="y" and b'="x"] by auto qed then show ?thesis by auto next case c: 3 have "Ifm vs (x#bs) (NEq (CNP 0 c e)) = Ifm vs (x#bs) (plusinf (NEq (CNP 0 c e)))" if "x > -?e / ?c" for x proof - from that have "?c * x < - ?e" using neg_divide_less_eq[OF c, where a="x" and b="-?e"] by (simp add: mult.commute) then have "?c * x + ?e < 0" by simp then show ?thesis using eqs tmbound0_I[OF nbe, where b="y" and b'="x"] by auto qed then show ?thesis by auto qed next case (5 c e) then have nbe: "tmbound0 e" by simp from 5 have nc: "allpolys isnpoly (CP c)" "allpolys isnpoly e" by simp_all then have nc': "allpolys isnpoly (CP (~\<^sub>p c))" by (simp add: polyneg_norm) note eqs = lt[OF nc(1), where ?'a = 'a] lt[OF nc', where ?'a = 'a] eq [OF nc(1), where ?'a = 'a] lt[OF nc(2), where ?'a = 'a] let ?c = "Ipoly vs c" fix y let ?e = "Itm vs (y#bs) e" consider "?c = 0" | "?c > 0" | "?c < 0" by arith then show ?case proof cases case 1 then show ?thesis using eqs by auto next case c: 2 have "Ifm vs (x#bs) (Lt (CNP 0 c e)) = Ifm vs (x#bs) (plusinf (Lt (CNP 0 c e)))" if "x > -?e / ?c" for x proof - from that have "?c * x > - ?e" using pos_divide_less_eq[OF c, where a="x" and b="-?e"] by (simp add: mult.commute) then have "?c * x + ?e > 0" by simp then show ?thesis using tmbound0_I[OF nbe, where b="y" and b'="x"] c eqs by auto qed then show ?thesis by auto next case c: 3 have "Ifm vs (x#bs) (Lt (CNP 0 c e)) = Ifm vs (x#bs) (plusinf (Lt (CNP 0 c e)))" if "x > -?e / ?c" for x proof - from that have "?c * x < - ?e" using neg_divide_less_eq[OF c, where a="x" and b="-?e"] by (simp add: mult.commute) then have "?c * x + ?e < 0" by simp then show ?thesis using eqs tmbound0_I[OF nbe, where b="y" and b'="x"] c by auto qed then show ?thesis by auto qed next case (6 c e) then have nbe: "tmbound0 e" by simp from 6 have nc: "allpolys isnpoly (CP c)" "allpolys isnpoly e" by simp_all then have nc': "allpolys isnpoly (CP (~\<^sub>p c))" by (simp add: polyneg_norm) note eqs = lt[OF nc(1), where ?'a = 'a] eq [OF nc(1), where ?'a = 'a] le[OF nc(2), where ?'a = 'a] let ?c = "Ipoly vs c" fix y let ?e = "Itm vs (y#bs) e" consider "?c = 0" | "?c > 0" | "?c < 0" by arith then show ?case proof cases case 1 then show ?thesis using eqs by auto next case c: 2 have "Ifm vs (x#bs) (Le (CNP 0 c e)) = Ifm vs (x#bs) (plusinf (Le (CNP 0 c e)))" if "x > -?e / ?c" for x proof - from that have "?c * x > - ?e" using pos_divide_less_eq[OF c, where a="x" and b="-?e"] by (simp add: mult.commute) then have "?c * x + ?e > 0" by simp then show ?thesis using tmbound0_I[OF nbe, where b="y" and b'="x"] c eqs by auto qed then show ?thesis by auto next case c: 3 have "Ifm vs (x#bs) (Le (CNP 0 c e)) = Ifm vs (x#bs) (plusinf (Le (CNP 0 c e)))" if "x > -?e / ?c" for x proof - from that have "?c * x < - ?e" using neg_divide_less_eq[OF c, where a="x" and b="-?e"] by (simp add: mult.commute) then have "?c * x + ?e < 0" by simp then show ?thesis using tmbound0_I[OF nbe, where b="y" and b'="x"] c eqs by auto qed then show ?thesis by auto qed qed auto lemma minusinf_nb: "islin p \ bound0 (minusinf p)" by (induct p rule: minusinf.induct) (auto simp add: eq_nb lt_nb le_nb) lemma plusinf_nb: "islin p \ bound0 (plusinf p)" by (induct p rule: minusinf.induct) (auto simp add: eq_nb lt_nb le_nb) lemma minusinf_ex: assumes lp: "islin p" and ex: "Ifm vs (x#bs) (minusinf p)" shows "\x. Ifm vs (x#bs) p" proof - from bound0_I [OF minusinf_nb[OF lp], where bs ="bs"] ex have th: "\x. Ifm vs (x#bs) (minusinf p)" by auto from minusinf_inf[OF lp, where bs="bs"] obtain z where z: "\xx. Ifm vs (x#bs) p" proof - from bound0_I [OF plusinf_nb[OF lp], where bs ="bs"] ex have th: "\x. Ifm vs (x#bs) (plusinf p)" by auto from plusinf_inf[OF lp, where bs="bs"] obtain z where z: "\x>z. Ifm vs (x # bs) (plusinf p) = Ifm vs (x # bs) p" by blast from th have "Ifm vs ((z + 1)#bs) (plusinf p)" by simp moreover have "z + 1 > z" by simp ultimately show ?thesis using z by auto qed fun uset :: "fm \ (poly \ tm) list" where "uset (And p q) = uset p @ uset q" | "uset (Or p q) = uset p @ uset q" | "uset (Eq (CNP 0 a e)) = [(a, e)]" | "uset (Le (CNP 0 a e)) = [(a, e)]" | "uset (Lt (CNP 0 a e)) = [(a, e)]" | "uset (NEq (CNP 0 a e)) = [(a, e)]" | "uset p = []" lemma uset_l: assumes lp: "islin p" shows "\(c,s) \ set (uset p). isnpoly c \ c \ 0\<^sub>p \ tmbound0 s \ allpolys isnpoly s" using lp by (induct p rule: uset.induct) auto lemma minusinf_uset0: assumes lp: "islin p" and nmi: "\ (Ifm vs (x#bs) (minusinf p))" and ex: "Ifm vs (x#bs) p" (is "?I x p") shows "\(c, s) \ set (uset p). x \ - Itm vs (x#bs) s / Ipoly vs c" proof - have "\(c, s) \ set (uset p). Ipoly vs c < 0 \ Ipoly vs c * x \ - Itm vs (x#bs) s \ Ipoly vs c > 0 \ Ipoly vs c * x \ - Itm vs (x#bs) s" using lp nmi ex apply (induct p rule: minusinf.induct) apply (auto simp add: eq le lt polyneg_norm) apply (auto simp add: linorder_not_less order_le_less) done then obtain c s where csU: "(c, s) \ set (uset p)" and x: "(Ipoly vs c < 0 \ Ipoly vs c * x \ - Itm vs (x#bs) s) \ (Ipoly vs c > 0 \ Ipoly vs c * x \ - Itm vs (x#bs) s)" by blast then have "x \ (- Itm vs (x#bs) s) / Ipoly vs c" using divide_le_eq[of "- Itm vs (x#bs) s" "Ipoly vs c" x] by (auto simp add: mult.commute) then show ?thesis using csU by auto qed lemma minusinf_uset: assumes lp: "islin p" and nmi: "\ (Ifm vs (a#bs) (minusinf p))" and ex: "Ifm vs (x#bs) p" (is "?I x p") shows "\(c,s) \ set (uset p). x \ - Itm vs (a#bs) s / Ipoly vs c" proof - from nmi have nmi': "\ Ifm vs (x#bs) (minusinf p)" by (simp add: bound0_I[OF minusinf_nb[OF lp], where b=x and b'=a]) from minusinf_uset0[OF lp nmi' ex] obtain c s where csU: "(c,s) \ set (uset p)" and th: "x \ - Itm vs (x#bs) s / Ipoly vs c" by blast from uset_l[OF lp, rule_format, OF csU] have nb: "tmbound0 s" by simp from th tmbound0_I[OF nb, of vs x bs a] csU show ?thesis by auto qed lemma plusinf_uset0: assumes lp: "islin p" and nmi: "\ (Ifm vs (x#bs) (plusinf p))" and ex: "Ifm vs (x#bs) p" (is "?I x p") shows "\(c, s) \ set (uset p). x \ - Itm vs (x#bs) s / Ipoly vs c" proof - have "\(c, s) \ set (uset p). Ipoly vs c < 0 \ Ipoly vs c * x \ - Itm vs (x#bs) s \ Ipoly vs c > 0 \ Ipoly vs c * x \ - Itm vs (x#bs) s" using lp nmi ex apply (induct p rule: minusinf.induct) apply (auto simp add: eq le lt polyneg_norm) apply (auto simp add: linorder_not_less order_le_less) done then obtain c s where c_s: "(c, s) \ set (uset p)" and "Ipoly vs c < 0 \ Ipoly vs c * x \ - Itm vs (x#bs) s \ Ipoly vs c > 0 \ Ipoly vs c * x \ - Itm vs (x#bs) s" by blast then have "x \ (- Itm vs (x#bs) s) / Ipoly vs c" using le_divide_eq[of x "- Itm vs (x#bs) s" "Ipoly vs c"] by (auto simp add: mult.commute) then show ?thesis using c_s by auto qed lemma plusinf_uset: assumes lp: "islin p" and nmi: "\ (Ifm vs (a#bs) (plusinf p))" and ex: "Ifm vs (x#bs) p" (is "?I x p") shows "\(c,s) \ set (uset p). x \ - Itm vs (a#bs) s / Ipoly vs c" proof - from nmi have nmi': "\ (Ifm vs (x#bs) (plusinf p))" by (simp add: bound0_I[OF plusinf_nb[OF lp], where b=x and b'=a]) from plusinf_uset0[OF lp nmi' ex] obtain c s where c_s: "(c,s) \ set (uset p)" and x: "x \ - Itm vs (x#bs) s / Ipoly vs c" by blast from uset_l[OF lp, rule_format, OF c_s] have nb: "tmbound0 s" by simp from x tmbound0_I[OF nb, of vs x bs a] c_s show ?thesis by auto qed lemma lin_dense: assumes lp: "islin p" and noS: "\t. l < t \ t< u \ t \ (\(c,t). - Itm vs (x#bs) t / Ipoly vs c) ` set (uset p)" (is "\t. _ \ _ \ t \ (\(c,t). - ?Nt x t / ?N c) ` ?U p") and lx: "l < x" and xu: "x < u" and px: "Ifm vs (x # bs) p" and ly: "l < y" and yu: "y < u" shows "Ifm vs (y#bs) p" using lp px noS proof (induct p rule: islin.induct) case (5 c s) from "5.prems" have lin: "isnpoly c" "c \ 0\<^sub>p" "tmbound0 s" "allpolys isnpoly s" and px: "Ifm vs (x # bs) (Lt (CNP 0 c s))" and noS: "\t. l < t \ t < u \ t \ - Itm vs (x # bs) s / \c\\<^sub>p\<^bsup>vs\<^esup>" by simp_all from ly yu noS have yne: "y \ - ?Nt x s / \c\\<^sub>p\<^bsup>vs\<^esup>" by simp then have ycs: "y < - ?Nt x s / ?N c \ y > -?Nt x s / ?N c" by auto consider "?N c = 0" | "?N c > 0" | "?N c < 0" by arith then show ?case proof cases case 1 then show ?thesis using px by (simp add: tmbound0_I[OF lin(3), where bs="bs" and b="x" and b'="y"]) next case N: 2 from px pos_less_divide_eq[OF N, where a="x" and b="-?Nt x s"] have px': "x < - ?Nt x s / ?N c" by (auto simp add: not_less field_simps) from ycs show ?thesis proof assume y: "y < - ?Nt x s / ?N c" then have "y * ?N c < - ?Nt x s" by (simp add: pos_less_divide_eq[OF N, where a="y" and b="-?Nt x s", symmetric]) then have "?N c * y + ?Nt x s < 0" by (simp add: field_simps) then show ?thesis using tmbound0_I[OF lin(3), where bs="bs" and b="x" and b'="y"] by simp next assume y: "y > -?Nt x s / ?N c" with yu have eu: "u > - ?Nt x s / ?N c" by auto with noS ly yu have th: "- ?Nt x s / ?N c \ l" by (cases "- ?Nt x s / ?N c > l") auto with lx px' have False by simp then show ?thesis .. qed next case N: 3 from px neg_divide_less_eq[OF N, where a="x" and b="-?Nt x s"] have px': "x > - ?Nt x s / ?N c" by (auto simp add: not_less field_simps) from ycs show ?thesis proof assume y: "y > - ?Nt x s / ?N c" then have "y * ?N c < - ?Nt x s" by (simp add: neg_divide_less_eq[OF N, where a="y" and b="-?Nt x s", symmetric]) then have "?N c * y + ?Nt x s < 0" by (simp add: field_simps) then show ?thesis using tmbound0_I[OF lin(3), where bs="bs" and b="x" and b'="y"] by simp next assume y: "y < -?Nt x s / ?N c" with ly have eu: "l < - ?Nt x s / ?N c" by auto with noS ly yu have th: "- ?Nt x s / ?N c \ u" by (cases "- ?Nt x s / ?N c < u") auto with xu px' have False by simp then show ?thesis .. qed qed next case (6 c s) from "6.prems" have lin: "isnpoly c" "c \ 0\<^sub>p" "tmbound0 s" "allpolys isnpoly s" and px: "Ifm vs (x # bs) (Le (CNP 0 c s))" and noS: "\t. l < t \ t < u \ t \ - Itm vs (x # bs) s / \c\\<^sub>p\<^bsup>vs\<^esup>" by simp_all from ly yu noS have yne: "y \ - ?Nt x s / \c\\<^sub>p\<^bsup>vs\<^esup>" by simp then have ycs: "y < - ?Nt x s / ?N c \ y > -?Nt x s / ?N c" by auto have ccs: "?N c = 0 \ ?N c < 0 \ ?N c > 0" by dlo consider "?N c = 0" | "?N c > 0" | "?N c < 0" by arith then show ?case proof cases case 1 then show ?thesis using px by (simp add: tmbound0_I[OF lin(3), where bs="bs" and b="x" and b'="y"]) next case N: 2 from px pos_le_divide_eq[OF N, where a="x" and b="-?Nt x s"] have px': "x \ - ?Nt x s / ?N c" by (simp add: not_less field_simps) from ycs show ?thesis proof assume y: "y < - ?Nt x s / ?N c" then have "y * ?N c < - ?Nt x s" by (simp add: pos_less_divide_eq[OF N, where a="y" and b="-?Nt x s", symmetric]) then have "?N c * y + ?Nt x s < 0" by (simp add: field_simps) then show ?thesis using tmbound0_I[OF lin(3), where bs="bs" and b="x" and b'="y"] by simp next assume y: "y > -?Nt x s / ?N c" with yu have eu: "u > - ?Nt x s / ?N c" by auto with noS ly yu have th: "- ?Nt x s / ?N c \ l" by (cases "- ?Nt x s / ?N c > l") auto with lx px' have False by simp then show ?thesis .. qed next case N: 3 from px neg_divide_le_eq[OF N, where a="x" and b="-?Nt x s"] have px': "x \ - ?Nt x s / ?N c" by (simp add: field_simps) from ycs show ?thesis proof assume y: "y > - ?Nt x s / ?N c" then have "y * ?N c < - ?Nt x s" by (simp add: neg_divide_less_eq[OF N, where a="y" and b="-?Nt x s", symmetric]) then have "?N c * y + ?Nt x s < 0" by (simp add: field_simps) then show ?thesis using tmbound0_I[OF lin(3), where bs="bs" and b="x" and b'="y"] by simp next assume y: "y < -?Nt x s / ?N c" with ly have eu: "l < - ?Nt x s / ?N c" by auto with noS ly yu have th: "- ?Nt x s / ?N c \ u" by (cases "- ?Nt x s / ?N c < u") auto with xu px' have False by simp then show ?thesis .. qed qed next case (3 c s) from "3.prems" have lin: "isnpoly c" "c \ 0\<^sub>p" "tmbound0 s" "allpolys isnpoly s" and px: "Ifm vs (x # bs) (Eq (CNP 0 c s))" and noS: "\t. l < t \ t < u \ t \ - Itm vs (x # bs) s / \c\\<^sub>p\<^bsup>vs\<^esup>" by simp_all from ly yu noS have yne: "y \ - ?Nt x s / \c\\<^sub>p\<^bsup>vs\<^esup>" by simp then have ycs: "y < - ?Nt x s / ?N c \ y > -?Nt x s / ?N c" by auto consider "?N c = 0" | "?N c < 0" | "?N c > 0" by arith then show ?case proof cases case 1 then show ?thesis using px by (simp add: tmbound0_I[OF lin(3), where bs="bs" and b="x" and b'="y"]) next case 2 then have cnz: "?N c \ 0" by simp from px eq_divide_eq[of "x" "-?Nt x s" "?N c"] cnz have px': "x = - ?Nt x s / ?N c" by (simp add: field_simps) from ycs show ?thesis proof assume y: "y < -?Nt x s / ?N c" with ly have eu: "l < - ?Nt x s / ?N c" by auto with noS ly yu have th: "- ?Nt x s / ?N c \ u" by (cases "- ?Nt x s / ?N c < u") auto with xu px' have False by simp then show ?thesis .. next assume y: "y > -?Nt x s / ?N c" with yu have eu: "u > - ?Nt x s / ?N c" by auto with noS ly yu have th: "- ?Nt x s / ?N c \ l" by (cases "- ?Nt x s / ?N c > l") auto with lx px' have False by simp then show ?thesis .. qed next case 3 then have cnz: "?N c \ 0" by simp from px eq_divide_eq[of "x" "-?Nt x s" "?N c"] cnz have px': "x = - ?Nt x s / ?N c" by (simp add: field_simps) from ycs show ?thesis proof assume y: "y < -?Nt x s / ?N c" with ly have eu: "l < - ?Nt x s / ?N c" by auto with noS ly yu have th: "- ?Nt x s / ?N c \ u" by (cases "- ?Nt x s / ?N c < u") auto with xu px' have False by simp then show ?thesis .. next assume y: "y > -?Nt x s / ?N c" with yu have eu: "u > - ?Nt x s / ?N c" by auto with noS ly yu have th: "- ?Nt x s / ?N c \ l" by (cases "- ?Nt x s / ?N c > l") auto with lx px' have False by simp then show ?thesis .. qed qed next case (4 c s) from "4.prems" have lin: "isnpoly c" "c \ 0\<^sub>p" "tmbound0 s" "allpolys isnpoly s" and px: "Ifm vs (x # bs) (NEq (CNP 0 c s))" and noS: "\t. l < t \ t < u \ t \ - Itm vs (x # bs) s / \c\\<^sub>p\<^bsup>vs\<^esup>" by simp_all from ly yu noS have yne: "y \ - ?Nt x s / \c\\<^sub>p\<^bsup>vs\<^esup>" by simp then have ycs: "y < - ?Nt x s / ?N c \ y > -?Nt x s / ?N c" by auto show ?case proof (cases "?N c = 0") case True then show ?thesis using px by (simp add: tmbound0_I[OF lin(3), where bs="bs" and b="x" and b'="y"]) next case False with yne eq_divide_eq[of "y" "- ?Nt x s" "?N c"] show ?thesis by (simp add: field_simps tmbound0_I[OF lin(3), of vs x bs y] sum_eq[symmetric]) qed qed (auto simp add: tmbound0_I[where vs=vs and bs="bs" and b="y" and b'="x"] bound0_I[where vs=vs and bs="bs" and b="y" and b'="x"]) lemma inf_uset: assumes lp: "islin p" and nmi: "\ (Ifm vs (x#bs) (minusinf p))" (is "\ (Ifm vs (x#bs) (?M p))") and npi: "\ (Ifm vs (x#bs) (plusinf p))" (is "\ (Ifm vs (x#bs) (?P p))") and ex: "\x. Ifm vs (x#bs) p" (is "\x. ?I x p") shows "\(c, t) \ set (uset p). \(d, s) \ set (uset p). ?I ((- Itm vs (x#bs) t / Ipoly vs c + - Itm vs (x#bs) s / Ipoly vs d) / 2) p" proof - let ?Nt = "\x t. Itm vs (x#bs) t" let ?N = "Ipoly vs" let ?U = "set (uset p)" from ex obtain a where pa: "?I a p" by blast from bound0_I[OF minusinf_nb[OF lp], where bs="bs" and b="x" and b'="a"] nmi have nmi': "\ (?I a (?M p))" by simp from bound0_I[OF plusinf_nb[OF lp], where bs="bs" and b="x" and b'="a"] npi have npi': "\ (?I a (?P p))" by simp have "\(c,t) \ set (uset p). \(d,s) \ set (uset p). ?I ((- ?Nt a t/?N c + - ?Nt a s /?N d) / 2) p" proof - let ?M = "(\(c,t). - ?Nt a t / ?N c) ` ?U" have fM: "finite ?M" by auto from minusinf_uset[OF lp nmi pa] plusinf_uset[OF lp npi pa] have "\(c, t) \ set (uset p). \(d, s) \ set (uset p). a \ - ?Nt x t / ?N c \ a \ - ?Nt x s / ?N d" by blast then obtain c t d s where ctU: "(c, t) \ ?U" and dsU: "(d, s) \ ?U" and xs1: "a \ - ?Nt x s / ?N d" and tx1: "a \ - ?Nt x t / ?N c" by blast from uset_l[OF lp] ctU dsU tmbound0_I[where bs="bs" and b="x" and b'="a"] xs1 tx1 have xs: "a \ - ?Nt a s / ?N d" and tx: "a \ - ?Nt a t / ?N c" by auto from ctU have Mne: "?M \ {}" by auto then have Une: "?U \ {}" by simp let ?l = "Min ?M" let ?u = "Max ?M" have linM: "?l \ ?M" using fM Mne by simp have uinM: "?u \ ?M" using fM Mne by simp have ctM: "- ?Nt a t / ?N c \ ?M" using ctU by auto have dsM: "- ?Nt a s / ?N d \ ?M" using dsU by auto have lM: "\t\ ?M. ?l \ t" using Mne fM by auto have Mu: "\t\ ?M. t \ ?u" using Mne fM by auto have "?l \ - ?Nt a t / ?N c" using ctM Mne by simp then have lx: "?l \ a" using tx by simp have "- ?Nt a s / ?N d \ ?u" using dsM Mne by simp then have xu: "a \ ?u" using xs by simp from finite_set_intervals2[where P="\x. ?I x p",OF pa lx xu linM uinM fM lM Mu] consider u where "u \ ?M" "?I u p" | t1 t2 where "t1 \ ?M" "t2\ ?M" "\y. t1 < y \ y < t2 \ y \ ?M" "t1 < a" "a < t2" "?I a p" by blast then show ?thesis proof cases case 1 then have "\(nu,tu) \ ?U. u = - ?Nt a tu / ?N nu" by auto then obtain tu nu where tuU: "(nu, tu) \ ?U" and tuu: "u = - ?Nt a tu / ?N nu" by blast have "?I (((- ?Nt a tu / ?N nu) + (- ?Nt a tu / ?N nu)) / 2) p" using \?I u p\ tuu by simp with tuU show ?thesis by blast next case 2 have "\(t1n, t1u) \ ?U. t1 = - ?Nt a t1u / ?N t1n" using \t1 \ ?M\ by auto then obtain t1u t1n where t1uU: "(t1n, t1u) \ ?U" and t1u: "t1 = - ?Nt a t1u / ?N t1n" by blast have "\(t2n, t2u) \ ?U. t2 = - ?Nt a t2u / ?N t2n" using \t2 \ ?M\ by auto then obtain t2u t2n where t2uU: "(t2n, t2u) \ ?U" and t2u: "t2 = - ?Nt a t2u / ?N t2n" by blast have "t1 < t2" using \t1 < a\ \a < t2\ by simp let ?u = "(t1 + t2) / 2" have "t1 < ?u" using less_half_sum [OF \t1 < t2\] by auto have "?u < t2" using gt_half_sum [OF \t1 < t2\] by auto have "?I ?u p" using lp \\y. t1 < y \ y < t2 \ y \ ?M\ \t1 < a\ \a < t2\ \?I a p\ \t1 < ?u\ \?u < t2\ by (rule lin_dense) with t1uU t2uU t1u t2u show ?thesis by blast qed qed then obtain l n s m where lnU: "(n, l) \ ?U" and smU:"(m,s) \ ?U" and pu: "?I ((- ?Nt a l / ?N n + - ?Nt a s / ?N m) / 2) p" by blast from lnU smU uset_l[OF lp] have nbl: "tmbound0 l" and nbs: "tmbound0 s" by auto from tmbound0_I[OF nbl, where bs="bs" and b="a" and b'="x"] tmbound0_I[OF nbs, where bs="bs" and b="a" and b'="x"] pu have "?I ((- ?Nt x l / ?N n + - ?Nt x s / ?N m) / 2) p" by simp with lnU smU show ?thesis by auto qed section \The Ferrante - Rackoff Theorem\ theorem fr_eq: assumes lp: "islin p" shows "(\x. Ifm vs (x#bs) p) \ (Ifm vs (x#bs) (minusinf p) \ Ifm vs (x#bs) (plusinf p) \ (\(n, t) \ set (uset p). \(m, s) \ set (uset p). Ifm vs (((- Itm vs (x#bs) t / Ipoly vs n + - Itm vs (x#bs) s / Ipoly vs m) / 2)#bs) p))" (is "(\x. ?I x p) \ ?M \ ?P \ ?F" is "?E \ ?D") proof show ?D if ?E proof - consider "?M \ ?P" | "\ ?M" "\ ?P" by blast then show ?thesis proof cases case 1 then show ?thesis by blast next case 2 from inf_uset[OF lp this] have ?F using \?E\ by blast then show ?thesis by blast qed qed show ?E if ?D proof - from that consider ?M | ?P | ?F by blast then show ?thesis proof cases case 1 from minusinf_ex[OF lp this] show ?thesis . next case 2 from plusinf_ex[OF lp this] show ?thesis . next case 3 then show ?thesis by blast qed qed qed section \First implementation : Naive by encoding all case splits locally\ definition "msubsteq c t d s a r = evaldjf (case_prod conj) [(let cd = c *\<^sub>p d in (NEq (CP cd), Eq (Add (Mul (~\<^sub>p a) (Add (Mul d t) (Mul c s))) (Mul ((2)\<^sub>p *\<^sub>p cd) r)))), (conj (Eq (CP c)) (NEq (CP d)), Eq (Add (Mul (~\<^sub>p a) s) (Mul ((2)\<^sub>p *\<^sub>p d) r))), (conj (NEq (CP c)) (Eq (CP d)), Eq (Add (Mul (~\<^sub>p a) t) (Mul ((2)\<^sub>p *\<^sub>p c) r))), (conj (Eq (CP c)) (Eq (CP d)), Eq r)]" lemma msubsteq_nb: assumes lp: "islin (Eq (CNP 0 a r))" and t: "tmbound0 t" and s: "tmbound0 s" shows "bound0 (msubsteq c t d s a r)" proof - have th: "\x \ set [(let cd = c *\<^sub>p d in (NEq (CP cd), Eq (Add (Mul (~\<^sub>p a) (Add (Mul d t) (Mul c s))) (Mul ((2)\<^sub>p *\<^sub>p cd) r)))), (conj (Eq (CP c)) (NEq (CP d)), Eq (Add (Mul (~\<^sub>p a) s) (Mul ((2)\<^sub>p *\<^sub>p d) r))), (conj (NEq (CP c)) (Eq (CP d)), Eq (Add (Mul (~\<^sub>p a) t) (Mul ((2)\<^sub>p *\<^sub>p c) r))), (conj (Eq (CP c)) (Eq (CP d)), Eq r)]. bound0 (case_prod conj x)" using lp by (simp add: Let_def t s) from evaldjf_bound0[OF th] show ?thesis by (simp add: msubsteq_def) qed lemma msubsteq: assumes lp: "islin (Eq (CNP 0 a r))" shows "Ifm vs (x#bs) (msubsteq c t d s a r) = Ifm vs (((- Itm vs (x#bs) t / Ipoly vs c + - Itm vs (x#bs) s / Ipoly vs d) / 2)#bs) (Eq (CNP 0 a r))" (is "?lhs = ?rhs") proof - let ?Nt = "\x t. Itm vs (x#bs) t" let ?N = "\p. Ipoly vs p" let ?c = "?N c" let ?d = "?N d" let ?t = "?Nt x t" let ?s = "?Nt x s" let ?a = "?N a" let ?r = "?Nt x r" from lp have lin:"isnpoly a" "a \ 0\<^sub>p" "tmbound0 r" "allpolys isnpoly r" by simp_all note r = tmbound0_I[OF lin(3), of vs _ bs x] consider "?c = 0" "?d = 0" | "?c = 0" "?d \ 0" | "?c \ 0" "?d = 0" | "?c \ 0" "?d \ 0" by blast then show ?thesis proof cases case 1 then show ?thesis by (simp add: r[of 0] msubsteq_def Let_def evaldjf_ex) next case cd: 2 then have th: "(- ?t / ?c + - ?s / ?d)/2 = -?s / (2*?d)" by simp have "?rhs = Ifm vs (-?s / (2*?d) # bs) (Eq (CNP 0 a r))" by (simp only: th) also have "\ \ ?a * (-?s / (2*?d)) + ?r = 0" by (simp add: r[of "- (Itm vs (x # bs) s / (2 * \d\\<^sub>p\<^bsup>vs\<^esup>))"]) also have "\ \ 2 * ?d * (?a * (-?s / (2*?d)) + ?r) = 0" using cd(2) mult_cancel_left[of "2*?d" "(?a * (-?s / (2*?d)) + ?r)" 0] by simp also have "\ \ (- ?a * ?s) * (2*?d / (2*?d)) + 2 * ?d * ?r= 0" by (simp add: field_simps distrib_left [of "2*?d"]) also have "\ \ - (?a * ?s) + 2*?d*?r = 0" using cd(2) by simp finally show ?thesis using cd by (simp add: r[of "- (Itm vs (x # bs) s / (2 * \d\\<^sub>p\<^bsup>vs\<^esup>))"] msubsteq_def Let_def evaldjf_ex) next case cd: 3 from cd(2) have th: "(- ?t / ?c + - ?s / ?d)/2 = -?t / (2 * ?c)" by simp have "?rhs = Ifm vs (-?t / (2*?c) # bs) (Eq (CNP 0 a r))" by (simp only: th) also have "\ \ ?a * (-?t / (2*?c)) + ?r = 0" by (simp add: r[of "- (?t/ (2 * ?c))"]) also have "\ \ 2 * ?c * (?a * (-?t / (2 * ?c)) + ?r) = 0" using cd(1) mult_cancel_left[of "2 * ?c" "(?a * (-?t / (2 * ?c)) + ?r)" 0] by simp also have "\ \ (?a * -?t)* (2 * ?c) / (2 * ?c) + 2 * ?c * ?r= 0" by (simp add: field_simps distrib_left [of "2 * ?c"]) also have "\ \ - (?a * ?t) + 2 * ?c * ?r = 0" using cd(1) by simp finally show ?thesis using cd by (simp add: r[of "- (?t/ (2 * ?c))"] msubsteq_def Let_def evaldjf_ex) next case cd: 4 then have cd2: "?c * ?d * 2 \ 0" by simp from add_frac_eq[OF cd, of "- ?t" "- ?s"] have th: "(- ?t / ?c + - ?s / ?d)/2 = - (?d * ?t + ?c* ?s )/ (2 * ?c * ?d)" by (simp add: field_simps) have "?rhs \ Ifm vs (- (?d * ?t + ?c* ?s )/ (2*?c*?d) # bs) (Eq (CNP 0 a r))" by (simp only: th) also have "\ \ ?a * (- (?d * ?t + ?c* ?s )/ (2*?c*?d)) + ?r = 0" by (simp add: r [of "(- (?d * ?t) - (?c *?s)) / (2 * ?c * ?d)"]) also have "\ \ (2 * ?c * ?d) * (?a * (- (?d * ?t + ?c* ?s )/ (2*?c*?d)) + ?r) = 0" using cd mult_cancel_left[of "2 * ?c * ?d" "?a * (- (?d * ?t + ?c* ?s)/ (2 * ?c * ?d)) + ?r" 0] by simp also have "\ \ ?a * (- (?d * ?t + ?c* ?s )) + 2 * ?c * ?d * ?r = 0" using nonzero_mult_div_cancel_left [OF cd2] cd by (simp add: algebra_simps diff_divide_distrib del: distrib_right) finally show ?thesis using cd by (simp add: r[of "(- (?d * ?t) + - (?c *?s)) / (2 * ?c * ?d)"] msubsteq_def Let_def evaldjf_ex field_simps) qed qed definition "msubstneq c t d s a r = evaldjf (case_prod conj) [(let cd = c *\<^sub>p d in (NEq (CP cd), NEq (Add (Mul (~\<^sub>p a) (Add (Mul d t) (Mul c s))) (Mul ((2)\<^sub>p *\<^sub>p cd) r)))), (conj (Eq (CP c)) (NEq (CP d)), NEq (Add (Mul (~\<^sub>p a) s) (Mul ((2)\<^sub>p *\<^sub>p d) r))), (conj (NEq (CP c)) (Eq (CP d)), NEq (Add (Mul (~\<^sub>p a) t) (Mul ((2)\<^sub>p *\<^sub>p c) r))), (conj (Eq (CP c)) (Eq (CP d)), NEq r)]" lemma msubstneq_nb: assumes lp: "islin (NEq (CNP 0 a r))" and t: "tmbound0 t" and s: "tmbound0 s" shows "bound0 (msubstneq c t d s a r)" proof - have th: "\x\ set [(let cd = c *\<^sub>p d in (NEq (CP cd), NEq (Add (Mul (~\<^sub>p a) (Add (Mul d t) (Mul c s))) (Mul ((2)\<^sub>p *\<^sub>p cd) r)))), (conj (Eq (CP c)) (NEq (CP d)), NEq (Add (Mul (~\<^sub>p a) s) (Mul ((2)\<^sub>p *\<^sub>p d) r))), (conj (NEq (CP c)) (Eq (CP d)), NEq (Add (Mul (~\<^sub>p a) t) (Mul ((2)\<^sub>p *\<^sub>p c) r))), (conj (Eq (CP c)) (Eq (CP d)), NEq r)]. bound0 (case_prod conj x)" using lp by (simp add: Let_def t s) from evaldjf_bound0[OF th] show ?thesis by (simp add: msubstneq_def) qed lemma msubstneq: assumes lp: "islin (Eq (CNP 0 a r))" shows "Ifm vs (x#bs) (msubstneq c t d s a r) = Ifm vs (((- Itm vs (x#bs) t / Ipoly vs c + - Itm vs (x#bs) s / Ipoly vs d) /2)#bs) (NEq (CNP 0 a r))" (is "?lhs = ?rhs") proof - let ?Nt = "\x t. Itm vs (x#bs) t" let ?N = "\p. Ipoly vs p" let ?c = "?N c" let ?d = "?N d" let ?t = "?Nt x t" let ?s = "?Nt x s" let ?a = "?N a" let ?r = "?Nt x r" from lp have lin:"isnpoly a" "a \ 0\<^sub>p" "tmbound0 r" "allpolys isnpoly r" by simp_all note r = tmbound0_I[OF lin(3), of vs _ bs x] consider "?c = 0" "?d = 0" | "?c = 0" "?d \ 0" | "?c \ 0" "?d = 0" | "?c \ 0" "?d \ 0" by blast then show ?thesis proof cases case 1 then show ?thesis by (simp add: r[of 0] msubstneq_def Let_def evaldjf_ex) next case cd: 2 from cd(1) have th: "(- ?t / ?c + - ?s / ?d)/2 = -?s / (2 * ?d)" by simp have "?rhs = Ifm vs (-?s / (2*?d) # bs) (NEq (CNP 0 a r))" by (simp only: th) also have "\ \ ?a * (-?s / (2*?d)) + ?r \ 0" by (simp add: r[of "- (Itm vs (x # bs) s / (2 * \d\\<^sub>p\<^bsup>vs\<^esup>))"]) also have "\ \ 2*?d * (?a * (-?s / (2*?d)) + ?r) \ 0" using cd(2) mult_cancel_left[of "2*?d" "(?a * (-?s / (2*?d)) + ?r)" 0] by simp also have "\ \ (- ?a * ?s) * (2*?d / (2*?d)) + 2*?d*?r\ 0" by (simp add: field_simps distrib_left[of "2*?d"] del: distrib_left) also have "\ \ - (?a * ?s) + 2*?d*?r \ 0" using cd(2) by simp finally show ?thesis using cd by (simp add: r[of "- (Itm vs (x # bs) s / (2 * \d\\<^sub>p\<^bsup>vs\<^esup>))"] msubstneq_def Let_def evaldjf_ex) next case cd: 3 from cd(2) have th: "(- ?t / ?c + - ?s / ?d)/2 = -?t / (2*?c)" by simp have "?rhs = Ifm vs (-?t / (2*?c) # bs) (NEq (CNP 0 a r))" by (simp only: th) also have "\ \ ?a * (-?t / (2*?c)) + ?r \ 0" by (simp add: r[of "- (?t/ (2 * ?c))"]) also have "\ \ 2*?c * (?a * (-?t / (2*?c)) + ?r) \ 0" using cd(1) mult_cancel_left[of "2*?c" "(?a * (-?t / (2*?c)) + ?r)" 0] by simp also have "\ \ (?a * -?t)* (2*?c) / (2*?c) + 2*?c*?r \ 0" by (simp add: field_simps distrib_left[of "2*?c"] del: distrib_left) also have "\ \ - (?a * ?t) + 2*?c*?r \ 0" using cd(1) by simp finally show ?thesis using cd by (simp add: r[of "- (?t/ (2*?c))"] msubstneq_def Let_def evaldjf_ex) next case cd: 4 then have cd2: "?c * ?d * 2 \ 0" by simp from add_frac_eq[OF cd, of "- ?t" "- ?s"] have th: "(- ?t / ?c + - ?s / ?d)/2 = - (?d * ?t + ?c * ?s )/ (2 * ?c * ?d)" by (simp add: field_simps) have "?rhs \ Ifm vs (- (?d * ?t + ?c* ?s )/ (2*?c*?d) # bs) (NEq (CNP 0 a r))" by (simp only: th) also have "\ \ ?a * (- (?d * ?t + ?c* ?s )/ (2*?c*?d)) + ?r \ 0" by (simp add: r [of "(- (?d * ?t) - (?c *?s)) / (2 * ?c * ?d)"]) also have "\ \ (2 * ?c * ?d) * (?a * (- (?d * ?t + ?c* ?s )/ (2*?c*?d)) + ?r) \ 0" using cd mult_cancel_left[of "2 * ?c * ?d" "?a * (- (?d * ?t + ?c* ?s)/ (2*?c*?d)) + ?r" 0] by simp also have "\ \ ?a * (- (?d * ?t + ?c* ?s )) + 2*?c*?d*?r \ 0" using nonzero_mult_div_cancel_left[OF cd2] cd by (simp add: algebra_simps diff_divide_distrib del: distrib_right) finally show ?thesis using cd by (simp add: r[of "(- (?d * ?t) + - (?c *?s)) / (2 * ?c * ?d)"] msubstneq_def Let_def evaldjf_ex field_simps) qed qed definition "msubstlt c t d s a r = evaldjf (case_prod conj) [(let cd = c *\<^sub>p d in (lt (CP (~\<^sub>p cd)), Lt (Add (Mul (~\<^sub>p a) (Add (Mul d t) (Mul c s))) (Mul ((2)\<^sub>p *\<^sub>p cd) r)))), (let cd = c *\<^sub>p d in (lt (CP cd), Lt (Sub (Mul a (Add (Mul d t) (Mul c s))) (Mul ((2)\<^sub>p *\<^sub>p cd) r)))), (conj (lt (CP (~\<^sub>p c))) (Eq (CP d)), Lt (Add (Mul (~\<^sub>p a) t) (Mul ((2)\<^sub>p *\<^sub>p c) r))), (conj (lt (CP c)) (Eq (CP d)), Lt (Sub (Mul a t) (Mul ((2)\<^sub>p *\<^sub>p c) r))), (conj (lt (CP (~\<^sub>p d))) (Eq (CP c)), Lt (Add (Mul (~\<^sub>p a) s) (Mul ((2)\<^sub>p *\<^sub>p d) r))), (conj (lt (CP d)) (Eq (CP c)), Lt (Sub (Mul a s) (Mul ((2)\<^sub>p *\<^sub>p d) r))), (conj (Eq (CP c)) (Eq (CP d)), Lt r)]" lemma msubstlt_nb: assumes lp: "islin (Lt (CNP 0 a r))" and t: "tmbound0 t" and s: "tmbound0 s" shows "bound0 (msubstlt c t d s a r)" proof - have th: "\x\ set [(let cd = c *\<^sub>p d in (lt (CP (~\<^sub>p cd)), Lt (Add (Mul (~\<^sub>p a) (Add (Mul d t) (Mul c s))) (Mul ((2)\<^sub>p *\<^sub>p cd) r)))), (let cd = c *\<^sub>p d in (lt (CP cd), Lt (Sub (Mul a (Add (Mul d t) (Mul c s))) (Mul ((2)\<^sub>p *\<^sub>p cd) r)))), (conj (lt (CP (~\<^sub>p c))) (Eq (CP d)), Lt (Add (Mul (~\<^sub>p a) t) (Mul ((2)\<^sub>p *\<^sub>p c) r))), (conj (lt (CP c)) (Eq (CP d)), Lt (Sub (Mul a t) (Mul ((2)\<^sub>p *\<^sub>p c) r))), (conj (lt (CP (~\<^sub>p d))) (Eq (CP c)), Lt (Add (Mul (~\<^sub>p a) s) (Mul ((2)\<^sub>p *\<^sub>p d) r))), (conj (lt (CP d)) (Eq (CP c)), Lt (Sub (Mul a s) (Mul ((2)\<^sub>p *\<^sub>p d) r))), (conj (Eq (CP c)) (Eq (CP d)), Lt r)]. bound0 (case_prod conj x)" using lp by (simp add: Let_def t s lt_nb) from evaldjf_bound0[OF th] show ?thesis by (simp add: msubstlt_def) qed lemma msubstlt: assumes nc: "isnpoly c" and nd: "isnpoly d" and lp: "islin (Lt (CNP 0 a r))" shows "Ifm vs (x#bs) (msubstlt c t d s a r) \ Ifm vs (((- Itm vs (x#bs) t / Ipoly vs c + - Itm vs (x#bs) s / Ipoly vs d) /2)#bs) (Lt (CNP 0 a r))" (is "?lhs = ?rhs") proof - let ?Nt = "\x t. Itm vs (x#bs) t" let ?N = "\p. Ipoly vs p" let ?c = "?N c" let ?d = "?N d" let ?t = "?Nt x t" let ?s = "?Nt x s" let ?a = "?N a" let ?r = "?Nt x r" from lp have lin:"isnpoly a" "a \ 0\<^sub>p" "tmbound0 r" "allpolys isnpoly r" by simp_all note r = tmbound0_I[OF lin(3), of vs _ bs x] consider "?c = 0" "?d = 0" | "?c * ?d > 0" | "?c * ?d < 0" | "?c > 0" "?d = 0" | "?c < 0" "?d = 0" | "?c = 0" "?d > 0" | "?c = 0" "?d < 0" by atomize_elim auto then show ?thesis proof cases case 1 then show ?thesis using nc nd by (simp add: polyneg_norm lt r[of 0] msubstlt_def Let_def evaldjf_ex) next case cd: 2 then have cd2: "2 * ?c * ?d > 0" by simp from cd have c: "?c \ 0" and d: "?d \ 0" by auto from cd2 have cd2': "\ 2 * ?c * ?d < 0" by simp from add_frac_eq[OF c d, of "- ?t" "- ?s"] have th: "(- ?t / ?c + - ?s / ?d)/2 = - (?d * ?t + ?c* ?s )/ (2 * ?c * ?d)" by (simp add: field_simps) have "?rhs \ Ifm vs (- (?d * ?t + ?c* ?s )/ (2*?c*?d) # bs) (Lt (CNP 0 a r))" by (simp only: th) also have "\ \ ?a * (- (?d * ?t + ?c* ?s )/ (2*?c*?d)) + ?r < 0" by (simp add: r[of "(- (?d * ?t) - (?c *?s)) / (2 * ?c * ?d)"]) also have "\ \ (2 * ?c * ?d) * (?a * (- (?d * ?t + ?c* ?s )/ (2*?c*?d)) + ?r) < 0" using cd2 cd2' mult_less_cancel_left_disj[of "2 * ?c * ?d" "?a * (- (?d * ?t + ?c* ?s)/ (2*?c*?d)) + ?r" 0] by simp also have "\ \ ?a * (- (?d * ?t + ?c* ?s )) + 2*?c*?d*?r < 0" using nonzero_mult_div_cancel_left[of "2*?c*?d"] c d by (simp add: algebra_simps diff_divide_distrib del: distrib_right) finally show ?thesis using cd c d nc nd cd2' by (simp add: r[of "(- (?d * ?t) + - (?c *?s)) / (2 * ?c * ?d)"] msubstlt_def Let_def evaldjf_ex field_simps lt polyneg_norm polymul_norm) next case cd: 3 then have cd2: "2 * ?c * ?d < 0" by (simp add: mult_less_0_iff field_simps) from cd have c: "?c \ 0" and d: "?d \ 0" by auto from add_frac_eq[OF c d, of "- ?t" "- ?s"] have th: "(- ?t / ?c + - ?s / ?d)/2 = - (?d * ?t + ?c* ?s) / (2 * ?c * ?d)" by (simp add: field_simps) have "?rhs \ Ifm vs (- (?d * ?t + ?c* ?s )/ (2 * ?c * ?d) # bs) (Lt (CNP 0 a r))" by (simp only: th) also have "\ \ ?a * (- (?d * ?t + ?c* ?s )/ (2 * ?c * ?d)) + ?r < 0" by (simp add: r[of "(- (?d * ?t) - (?c *?s)) / (2 * ?c * ?d)"]) also have "\ \ (2 * ?c * ?d) * (?a * (- (?d * ?t + ?c * ?s )/ (2 * ?c * ?d)) + ?r) > 0" using cd2 order_less_not_sym[OF cd2] mult_less_cancel_left_disj[of "2 * ?c * ?d" 0 "?a * (- (?d * ?t + ?c* ?s)/ (2*?c*?d)) + ?r"] by simp also have "\ \ ?a * ((?d * ?t + ?c* ?s )) - 2 * ?c * ?d * ?r < 0" using nonzero_mult_div_cancel_left[of "2 * ?c * ?d"] c d by (simp add: algebra_simps diff_divide_distrib del: distrib_right) finally show ?thesis using cd c d nc nd by (simp add: r[of "(- (?d * ?t) + - (?c *?s)) / (2 * ?c * ?d)"] msubstlt_def Let_def evaldjf_ex field_simps lt polyneg_norm polymul_norm) next case cd: 4 from cd(1) have c'': "2 * ?c > 0" by (simp add: zero_less_mult_iff) from cd(1) have c': "2 * ?c \ 0" by simp from cd(2) have th: "(- ?t / ?c + - ?s / ?d)/2 = - ?t / (2 * ?c)" by (simp add: field_simps) have "?rhs \ Ifm vs (- ?t / (2 * ?c) # bs) (Lt (CNP 0 a r))" by (simp only: th) also have "\ \ ?a * (- ?t / (2 * ?c))+ ?r < 0" by (simp add: r[of "- (?t / (2 * ?c))"]) also have "\ \ 2 * ?c * (?a * (- ?t / (2 * ?c))+ ?r) < 0" using cd(1) mult_less_cancel_left_disj[of "2 * ?c" "?a* (- ?t / (2*?c))+ ?r" 0] c' c'' order_less_not_sym[OF c''] by simp also have "\ \ - ?a * ?t + 2 * ?c * ?r < 0" using nonzero_mult_div_cancel_left[OF c'] \?c > 0\ by (simp add: algebra_simps diff_divide_distrib less_le del: distrib_right) finally show ?thesis using cd nc nd by (simp add: r[of "- (?t / (2*?c))"] msubstlt_def Let_def evaldjf_ex field_simps lt polyneg_norm polymul_norm) next case cd: 5 from cd(1) have c': "2 * ?c \ 0" by simp from cd(1) have c'': "2 * ?c < 0" by (simp add: mult_less_0_iff) from cd(2) have th: "(- ?t / ?c + - ?s / ?d)/2 = - ?t / (2 * ?c)" by (simp add: field_simps) have "?rhs \ Ifm vs (- ?t / (2*?c) # bs) (Lt (CNP 0 a r))" by (simp only: th) also have "\ \ ?a * (- ?t / (2*?c))+ ?r < 0" by (simp add: r[of "- (?t / (2*?c))"]) also have "\ \ 2 * ?c * (?a * (- ?t / (2 * ?c))+ ?r) > 0" using cd(1) order_less_not_sym[OF c''] less_imp_neq[OF c''] c'' mult_less_cancel_left_disj[of "2 * ?c" 0 "?a* (- ?t / (2*?c))+ ?r"] by simp also have "\ \ ?a*?t - 2*?c *?r < 0" using nonzero_mult_div_cancel_left[OF c'] cd(1) order_less_not_sym[OF c''] less_imp_neq[OF c''] c'' by (simp add: algebra_simps diff_divide_distrib del: distrib_right) finally show ?thesis using cd nc nd by (simp add: r[of "- (?t / (2*?c))"] msubstlt_def Let_def evaldjf_ex field_simps lt polyneg_norm polymul_norm) next case cd: 6 from cd(2) have d'': "2 * ?d > 0" by (simp add: zero_less_mult_iff) from cd(2) have d': "2 * ?d \ 0" by simp from cd(1) have th: "(- ?t / ?c + - ?s / ?d)/2 = - ?s / (2 * ?d)" by (simp add: field_simps) have "?rhs \ Ifm vs (- ?s / (2 * ?d) # bs) (Lt (CNP 0 a r))" by (simp only: th) also have "\ \ ?a * (- ?s / (2 * ?d))+ ?r < 0" by (simp add: r[of "- (?s / (2 * ?d))"]) also have "\ \ 2 * ?d * (?a * (- ?s / (2 * ?d))+ ?r) < 0" using cd(2) mult_less_cancel_left_disj[of "2 * ?d" "?a * (- ?s / (2 * ?d))+ ?r" 0] d' d'' order_less_not_sym[OF d''] by simp also have "\ \ - ?a * ?s+ 2 * ?d * ?r < 0" using nonzero_mult_div_cancel_left[OF d'] cd(2) by (simp add: algebra_simps diff_divide_distrib less_le del: distrib_right) finally show ?thesis using cd nc nd by (simp add: r[of "- (?s / (2*?d))"] msubstlt_def Let_def evaldjf_ex field_simps lt polyneg_norm polymul_norm) next case cd: 7 from cd(2) have d': "2 * ?d \ 0" by simp from cd(2) have d'': "2 * ?d < 0" by (simp add: mult_less_0_iff) from cd(1) have th: "(- ?t / ?c + - ?s / ?d)/2 = - ?s / (2*?d)" by (simp add: field_simps) have "?rhs \ Ifm vs (- ?s / (2 * ?d) # bs) (Lt (CNP 0 a r))" by (simp only: th) also have "\ \ ?a * (- ?s / (2 * ?d)) + ?r < 0" by (simp add: r[of "- (?s / (2 * ?d))"]) also have "\ \ 2 * ?d * (?a * (- ?s / (2 * ?d)) + ?r) > 0" using cd(2) order_less_not_sym[OF d''] less_imp_neq[OF d''] d'' mult_less_cancel_left_disj[of "2 * ?d" 0 "?a* (- ?s / (2*?d))+ ?r"] by simp also have "\ \ ?a * ?s - 2 * ?d * ?r < 0" using nonzero_mult_div_cancel_left[OF d'] cd(2) order_less_not_sym[OF d''] less_imp_neq[OF d''] d'' by (simp add: algebra_simps diff_divide_distrib del: distrib_right) finally show ?thesis using cd nc nd by (simp add: r[of "- (?s / (2*?d))"] msubstlt_def Let_def evaldjf_ex field_simps lt polyneg_norm polymul_norm) qed qed definition "msubstle c t d s a r = evaldjf (case_prod conj) [(let cd = c *\<^sub>p d in (lt (CP (~\<^sub>p cd)), Le (Add (Mul (~\<^sub>p a) (Add (Mul d t) (Mul c s))) (Mul ((2)\<^sub>p *\<^sub>p cd) r)))), (let cd = c *\<^sub>p d in (lt (CP cd), Le (Sub (Mul a (Add (Mul d t) (Mul c s))) (Mul ((2)\<^sub>p *\<^sub>p cd) r)))), (conj (lt (CP (~\<^sub>p c))) (Eq (CP d)), Le (Add (Mul (~\<^sub>p a) t) (Mul ((2)\<^sub>p *\<^sub>p c) r))), (conj (lt (CP c)) (Eq (CP d)), Le (Sub (Mul a t) (Mul ((2)\<^sub>p *\<^sub>p c) r))), (conj (lt (CP (~\<^sub>p d))) (Eq (CP c)), Le (Add (Mul (~\<^sub>p a) s) (Mul ((2)\<^sub>p *\<^sub>p d) r))), (conj (lt (CP d)) (Eq (CP c)), Le (Sub (Mul a s) (Mul ((2)\<^sub>p *\<^sub>p d) r))), (conj (Eq (CP c)) (Eq (CP d)), Le r)]" lemma msubstle_nb: assumes lp: "islin (Le (CNP 0 a r))" and t: "tmbound0 t" and s: "tmbound0 s" shows "bound0 (msubstle c t d s a r)" proof - have th: "\x\ set [(let cd = c *\<^sub>p d in (lt (CP (~\<^sub>p cd)), Le (Add (Mul (~\<^sub>p a) (Add (Mul d t) (Mul c s))) (Mul ((2)\<^sub>p *\<^sub>p cd) r)))), (let cd = c *\<^sub>p d in (lt (CP cd), Le (Sub (Mul a (Add (Mul d t) (Mul c s))) (Mul ((2)\<^sub>p *\<^sub>p cd) r)))), (conj (lt (CP (~\<^sub>p c))) (Eq (CP d)) , Le (Add (Mul (~\<^sub>p a) t) (Mul ((2)\<^sub>p *\<^sub>p c) r))), (conj (lt (CP c)) (Eq (CP d)) , Le (Sub (Mul a t) (Mul ((2)\<^sub>p *\<^sub>p c) r))), (conj (lt (CP (~\<^sub>p d))) (Eq (CP c)) , Le (Add (Mul (~\<^sub>p a) s) (Mul ((2)\<^sub>p *\<^sub>p d) r))), (conj (lt (CP d)) (Eq (CP c)) , Le (Sub (Mul a s) (Mul ((2)\<^sub>p *\<^sub>p d) r))), (conj (Eq (CP c)) (Eq (CP d)) , Le r)]. bound0 (case_prod conj x)" using lp by (simp add: Let_def t s lt_nb) from evaldjf_bound0[OF th] show ?thesis by (simp add: msubstle_def) qed lemma msubstle: assumes nc: "isnpoly c" and nd: "isnpoly d" and lp: "islin (Le (CNP 0 a r))" shows "Ifm vs (x#bs) (msubstle c t d s a r) \ Ifm vs (((- Itm vs (x#bs) t / Ipoly vs c + - Itm vs (x#bs) s / Ipoly vs d) /2)#bs) (Le (CNP 0 a r))" (is "?lhs = ?rhs") proof - let ?Nt = "\x t. Itm vs (x#bs) t" let ?N = "\p. Ipoly vs p" let ?c = "?N c" let ?d = "?N d" let ?t = "?Nt x t" let ?s = "?Nt x s" let ?a = "?N a" let ?r = "?Nt x r" from lp have lin:"isnpoly a" "a \ 0\<^sub>p" "tmbound0 r" "allpolys isnpoly r" by simp_all note r = tmbound0_I[OF lin(3), of vs _ bs x] have "?c * ?d < 0 \ ?c * ?d > 0 \ (?c = 0 \ ?d = 0) \ (?c = 0 \ ?d < 0) \ (?c = 0 \ ?d > 0) \ (?c < 0 \ ?d = 0) \ (?c > 0 \ ?d = 0)" by auto then consider "?c = 0" "?d = 0" | "?c * ?d > 0" | "?c * ?d < 0" | "?c > 0" "?d = 0" | "?c < 0" "?d = 0" | "?c = 0" "?d > 0" | "?c = 0" "?d < 0" by blast then show ?thesis proof cases case 1 with nc nd show ?thesis by (simp add: polyneg_norm polymul_norm lt r[of 0] msubstle_def Let_def evaldjf_ex) next case dc: 2 from dc have dc': "2 * ?c * ?d > 0" by simp then have c: "?c \ 0" and d: "?d \ 0" by auto from dc' have dc'': "\ 2 * ?c * ?d < 0" by simp from add_frac_eq[OF c d, of "- ?t" "- ?s"] have th: "(- ?t / ?c + - ?s / ?d)/2 = - (?d * ?t + ?c * ?s )/ (2 * ?c * ?d)" by (simp add: field_simps) have "?rhs \ Ifm vs (- (?d * ?t + ?c* ?s )/ (2*?c*?d) # bs) (Le (CNP 0 a r))" by (simp only: th) also have "\ \ ?a * (- (?d * ?t + ?c* ?s )/ (2*?c*?d)) + ?r \ 0" by (simp add: r[of "(- (?d * ?t) - (?c *?s)) / (2 * ?c * ?d)"]) also have "\ \ (2 * ?c * ?d) * (?a * (- (?d * ?t + ?c* ?s )/ (2*?c*?d)) + ?r) \ 0" using dc' dc'' mult_le_cancel_left[of "2 * ?c * ?d" "?a * (- (?d * ?t + ?c* ?s)/ (2*?c*?d)) + ?r" 0] by simp also have "\ \ ?a * (- (?d * ?t + ?c* ?s )) + 2*?c*?d*?r \ 0" using nonzero_mult_div_cancel_left[of "2*?c*?d"] c d by (simp add: algebra_simps diff_divide_distrib del: distrib_right) finally show ?thesis using dc c d nc nd dc' by (simp add: r[of "(- (?d * ?t) + - (?c *?s)) / (2 * ?c * ?d)"] msubstle_def Let_def evaldjf_ex field_simps lt polyneg_norm polymul_norm) next case dc: 3 from dc have dc': "2 * ?c * ?d < 0" by (simp add: mult_less_0_iff field_simps add_neg_neg add_pos_pos) then have c: "?c \ 0" and d: "?d \ 0" by auto from add_frac_eq[OF c d, of "- ?t" "- ?s"] have th: "(- ?t / ?c + - ?s / ?d)/2 = - (?d * ?t + ?c* ?s )/ (2 * ?c * ?d)" by (simp add: field_simps) have "?rhs \ Ifm vs (- (?d * ?t + ?c* ?s )/ (2*?c*?d) # bs) (Le (CNP 0 a r))" by (simp only: th) also have "\ \ ?a * (- (?d * ?t + ?c* ?s )/ (2*?c*?d)) + ?r \ 0" by (simp add: r[of "(- (?d * ?t) - (?c *?s)) / (2 * ?c * ?d)"]) also have "\ \ (2 * ?c * ?d) * (?a * (- (?d * ?t + ?c* ?s )/ (2*?c*?d)) + ?r) \ 0" using dc' order_less_not_sym[OF dc'] mult_le_cancel_left[of "2 * ?c * ?d" 0 "?a * (- (?d * ?t + ?c* ?s)/ (2*?c*?d)) + ?r"] by simp also have "\ \ ?a * ((?d * ?t + ?c* ?s )) - 2 * ?c * ?d * ?r \ 0" using nonzero_mult_div_cancel_left[of "2 * ?c * ?d"] c d by (simp add: algebra_simps diff_divide_distrib del: distrib_right) finally show ?thesis using dc c d nc nd by (simp add: r[of "(- (?d * ?t) + - (?c *?s)) / (2 * ?c * ?d)"] msubstle_def Let_def evaldjf_ex field_simps lt polyneg_norm polymul_norm) next case 4 have c: "?c > 0" and d: "?d = 0" by fact+ from c have c'': "2 * ?c > 0" by (simp add: zero_less_mult_iff) from c have c': "2 * ?c \ 0" by simp from d have th: "(- ?t / ?c + - ?s / ?d)/2 = - ?t / (2*?c)" by (simp add: field_simps) have "?rhs \ Ifm vs (- ?t / (2 * ?c) # bs) (Le (CNP 0 a r))" by (simp only: th) also have "\ \ ?a * (- ?t / (2 * ?c))+ ?r \ 0" by (simp add: r[of "- (?t / (2 * ?c))"]) also have "\ \ 2 * ?c * (?a * (- ?t / (2 * ?c))+ ?r) \ 0" using c mult_le_cancel_left[of "2 * ?c" "?a* (- ?t / (2*?c))+ ?r" 0] c' c'' order_less_not_sym[OF c''] by simp also have "\ \ - ?a*?t+ 2*?c *?r \ 0" using nonzero_mult_div_cancel_left[OF c'] c by (simp add: algebra_simps diff_divide_distrib less_le del: distrib_right) finally show ?thesis using c d nc nd by (simp add: r[of "- (?t / (2*?c))"] msubstle_def Let_def evaldjf_ex field_simps lt polyneg_norm polymul_norm) next case 5 have c: "?c < 0" and d: "?d = 0" by fact+ then have c': "2 * ?c \ 0" by simp from c have c'': "2 * ?c < 0" by (simp add: mult_less_0_iff) from d have th: "(- ?t / ?c + - ?s / ?d)/2 = - ?t / (2*?c)" by (simp add: field_simps) have "?rhs \ Ifm vs (- ?t / (2 * ?c) # bs) (Le (CNP 0 a r))" by (simp only: th) also have "\ \ ?a * (- ?t / (2*?c))+ ?r \ 0" by (simp add: r[of "- (?t / (2*?c))"]) also have "\ \ 2 * ?c * (?a * (- ?t / (2 * ?c))+ ?r) \ 0" using c order_less_not_sym[OF c''] less_imp_neq[OF c''] c'' mult_le_cancel_left[of "2 * ?c" 0 "?a* (- ?t / (2*?c))+ ?r"] by simp also have "\ \ ?a * ?t - 2 * ?c * ?r \ 0" using nonzero_mult_div_cancel_left[OF c'] c order_less_not_sym[OF c''] less_imp_neq[OF c''] c'' by (simp add: algebra_simps diff_divide_distrib del: distrib_right) finally show ?thesis using c d nc nd by (simp add: r[of "- (?t / (2*?c))"] msubstle_def Let_def evaldjf_ex field_simps lt polyneg_norm polymul_norm) next case 6 have c: "?c = 0" and d: "?d > 0" by fact+ from d have d'': "2 * ?d > 0" by (simp add: zero_less_mult_iff) from d have d': "2 * ?d \ 0" by simp from c have th: "(- ?t / ?c + - ?s / ?d)/2 = - ?s / (2 * ?d)" by (simp add: field_simps) have "?rhs \ Ifm vs (- ?s / (2 * ?d) # bs) (Le (CNP 0 a r))" by (simp only: th) also have "\ \ ?a * (- ?s / (2 * ?d))+ ?r \ 0" by (simp add: r[of "- (?s / (2*?d))"]) also have "\ \ 2 * ?d * (?a * (- ?s / (2 * ?d)) + ?r) \ 0" using d mult_le_cancel_left[of "2 * ?d" "?a* (- ?s / (2*?d))+ ?r" 0] d' d'' order_less_not_sym[OF d''] by simp also have "\ \ - ?a * ?s + 2 * ?d * ?r \ 0" using nonzero_mult_div_cancel_left[OF d'] d by (simp add: algebra_simps diff_divide_distrib less_le del: distrib_right) finally show ?thesis using c d nc nd by (simp add: r[of "- (?s / (2*?d))"] msubstle_def Let_def evaldjf_ex field_simps lt polyneg_norm polymul_norm) next case 7 have c: "?c = 0" and d: "?d < 0" by fact+ then have d': "2 * ?d \ 0" by simp from d have d'': "2 * ?d < 0" by (simp add: mult_less_0_iff) from c have th: "(- ?t / ?c + - ?s / ?d)/2 = - ?s / (2*?d)" by (simp add: field_simps) have "?rhs \ Ifm vs (- ?s / (2*?d) # bs) (Le (CNP 0 a r))" by (simp only: th) also have "\ \ ?a* (- ?s / (2*?d))+ ?r \ 0" by (simp add: r[of "- (?s / (2*?d))"]) also have "\ \ 2*?d * (?a* (- ?s / (2*?d))+ ?r) \ 0" using d order_less_not_sym[OF d''] less_imp_neq[OF d''] d'' mult_le_cancel_left[of "2 * ?d" 0 "?a* (- ?s / (2*?d))+ ?r"] by simp also have "\ \ ?a * ?s - 2 * ?d * ?r \ 0" using nonzero_mult_div_cancel_left[OF d'] d order_less_not_sym[OF d''] less_imp_neq[OF d''] d'' by (simp add: algebra_simps diff_divide_distrib del: distrib_right) finally show ?thesis using c d nc nd by (simp add: r[of "- (?s / (2*?d))"] msubstle_def Let_def evaldjf_ex field_simps lt polyneg_norm polymul_norm) qed qed fun msubst :: "fm \ (poly \ tm) \ (poly \ tm) \ fm" where "msubst (And p q) ((c, t), (d, s)) = conj (msubst p ((c,t),(d,s))) (msubst q ((c, t), (d, s)))" | "msubst (Or p q) ((c, t), (d, s)) = disj (msubst p ((c,t),(d,s))) (msubst q ((c, t), (d, s)))" | "msubst (Eq (CNP 0 a r)) ((c, t), (d, s)) = msubsteq c t d s a r" | "msubst (NEq (CNP 0 a r)) ((c, t), (d, s)) = msubstneq c t d s a r" | "msubst (Lt (CNP 0 a r)) ((c, t), (d, s)) = msubstlt c t d s a r" | "msubst (Le (CNP 0 a r)) ((c, t), (d, s)) = msubstle c t d s a r" | "msubst p ((c, t), (d, s)) = p" lemma msubst_I: assumes lp: "islin p" and nc: "isnpoly c" and nd: "isnpoly d" shows "Ifm vs (x#bs) (msubst p ((c,t),(d,s))) = Ifm vs (((- Itm vs (x#bs) t / Ipoly vs c + - Itm vs (x#bs) s / Ipoly vs d) /2)#bs) p" using lp by (induct p rule: islin.induct) (auto simp add: tmbound0_I [where b = "(- (Itm vs (x # bs) t / \c\\<^sub>p\<^bsup>vs\<^esup>) - (Itm vs (x # bs) s / \d\\<^sub>p\<^bsup>vs\<^esup>)) / 2" and b' = x and bs = bs and vs = vs] msubsteq msubstneq msubstlt [OF nc nd] msubstle [OF nc nd]) lemma msubst_nb: assumes "islin p" and "tmbound0 t" and "tmbound0 s" shows "bound0 (msubst p ((c,t),(d,s)))" using assms by (induct p rule: islin.induct) (auto simp add: msubsteq_nb msubstneq_nb msubstlt_nb msubstle_nb) lemma fr_eq_msubst: assumes lp: "islin p" shows "(\x. Ifm vs (x#bs) p) \ (Ifm vs (x#bs) (minusinf p) \ Ifm vs (x#bs) (plusinf p) \ (\(c, t) \ set (uset p). \(d, s) \ set (uset p). Ifm vs (x#bs) (msubst p ((c, t), (d, s)))))" (is "(\x. ?I x p) = (?M \ ?P \ ?F)" is "?E = ?D") proof - from uset_l[OF lp] have *: "\(c, s)\set (uset p). isnpoly c \ tmbound0 s" by blast { fix c t d s assume ctU: "(c, t) \set (uset p)" and dsU: "(d,s) \set (uset p)" and pts: "Ifm vs ((- Itm vs (x # bs) t / \c\\<^sub>p\<^bsup>vs\<^esup> + - Itm vs (x # bs) s / \d\\<^sub>p\<^bsup>vs\<^esup>) / 2 # bs) p" from *[rule_format, OF ctU] *[rule_format, OF dsU] have norm:"isnpoly c" "isnpoly d" by simp_all from msubst_I[OF lp norm, of vs x bs t s] pts have "Ifm vs (x # bs) (msubst p ((c, t), d, s))" .. } moreover { fix c t d s assume ctU: "(c, t) \ set (uset p)" and dsU: "(d,s) \set (uset p)" and pts: "Ifm vs (x # bs) (msubst p ((c, t), d, s))" from *[rule_format, OF ctU] *[rule_format, OF dsU] have norm:"isnpoly c" "isnpoly d" by simp_all from msubst_I[OF lp norm, of vs x bs t s] pts have "Ifm vs ((- Itm vs (x # bs) t / \c\\<^sub>p\<^bsup>vs\<^esup> + - Itm vs (x # bs) s / \d\\<^sub>p\<^bsup>vs\<^esup>) / 2 # bs) p" .. } ultimately have **: "(\(c, t) \ set (uset p). \(d, s) \ set (uset p). Ifm vs ((- Itm vs (x # bs) t / \c\\<^sub>p\<^bsup>vs\<^esup> + - Itm vs (x # bs) s / \d\\<^sub>p\<^bsup>vs\<^esup>) / 2 # bs) p) \ ?F" by blast from fr_eq[OF lp, of vs bs x, simplified **] show ?thesis . qed lemma simpfm_lin: assumes "SORT_CONSTRAINT('a::field_char_0)" shows "qfree p \ islin (simpfm p)" by (induct p rule: simpfm.induct) (auto simp add: conj_lin disj_lin) definition "ferrack p \ let q = simpfm p; mp = minusinf q; pp = plusinf q in if (mp = T \ pp = T) then T else (let U = alluopairs (remdups (uset q)) in decr0 (disj mp (disj pp (evaldjf (simpfm o (msubst q)) U ))))" lemma ferrack: assumes qf: "qfree p" shows "qfree (ferrack p) \ Ifm vs bs (ferrack p) = Ifm vs bs (E p)" (is "_ \ ?rhs = ?lhs") proof - let ?I = "\x p. Ifm vs (x#bs) p" let ?N = "\t. Ipoly vs t" let ?Nt = "\x t. Itm vs (x#bs) t" let ?q = "simpfm p" let ?U = "remdups(uset ?q)" let ?Up = "alluopairs ?U" let ?mp = "minusinf ?q" let ?pp = "plusinf ?q" fix x let ?I = "\p. Ifm vs (x#bs) p" from simpfm_lin[OF qf] simpfm_qf[OF qf] have lq: "islin ?q" and q_qf: "qfree ?q" . from minusinf_nb[OF lq] plusinf_nb[OF lq] have mp_nb: "bound0 ?mp" and pp_nb: "bound0 ?pp" . from bound0_qf[OF mp_nb] bound0_qf[OF pp_nb] have mp_qf: "qfree ?mp" and pp_qf: "qfree ?pp" . from uset_l[OF lq] have U_l: "\(c, s)\set ?U. isnpoly c \ c \ 0\<^sub>p \ tmbound0 s \ allpolys isnpoly s" by simp { fix c t d s assume ctU: "(c, t) \ set ?U" and dsU: "(d,s) \ set ?U" from U_l ctU dsU have norm: "isnpoly c" "isnpoly d" by auto from msubst_I[OF lq norm, of vs x bs t s] msubst_I[OF lq norm(2,1), of vs x bs s t] have "?I (msubst ?q ((c,t),(d,s))) = ?I (msubst ?q ((d,s),(c,t)))" by (simp add: field_simps) } then have th0: "\x \ set ?U. \y \ set ?U. ?I (msubst ?q (x, y)) \ ?I (msubst ?q (y, x))" by auto { fix x assume xUp: "x \ set ?Up" then obtain c t d s where ctU: "(c, t) \ set ?U" and dsU: "(d,s) \ set ?U" and x: "x = ((c, t),(d, s))" using alluopairs_set1[of ?U] by auto from U_l[rule_format, OF ctU] U_l[rule_format, OF dsU] have nbs: "tmbound0 t" "tmbound0 s" by simp_all from simpfm_bound0[OF msubst_nb[OF lq nbs, of c d]] have "bound0 ((simpfm o (msubst (simpfm p))) x)" using x by simp } with evaldjf_bound0[of ?Up "(simpfm o (msubst (simpfm p)))"] have "bound0 (evaldjf (simpfm o (msubst (simpfm p))) ?Up)" by blast with mp_nb pp_nb have th1: "bound0 (disj ?mp (disj ?pp (evaldjf (simpfm o (msubst ?q)) ?Up )))" by simp from decr0_qf[OF th1] have thqf: "qfree (ferrack p)" by (simp add: ferrack_def Let_def) have "?lhs \ (\x. Ifm vs (x#bs) ?q)" by simp also have "\ \ ?I ?mp \ ?I ?pp \ (\(c, t)\set ?U. \(d, s)\set ?U. ?I (msubst (simpfm p) ((c, t), d, s)))" using fr_eq_msubst[OF lq, of vs bs x] by simp also have "\ \ ?I ?mp \ ?I ?pp \ (\(x, y) \ set ?Up. ?I ((simpfm \ msubst ?q) (x, y)))" using alluopairs_bex[OF th0] by simp also have "\ \ ?I ?mp \ ?I ?pp \ ?I (evaldjf (simpfm \ msubst ?q) ?Up)" by (simp add: evaldjf_ex) also have "\ \ ?I (disj ?mp (disj ?pp (evaldjf (simpfm \ msubst ?q) ?Up)))" by simp also have "\ \ ?rhs" using decr0[OF th1, of vs x bs] apply (simp add: ferrack_def Let_def) apply (cases "?mp = T \ ?pp = T") apply auto done finally show ?thesis using thqf by blast qed definition "frpar p = simpfm (qelim p ferrack)" lemma frpar: "qfree (frpar p) \ (Ifm vs bs (frpar p) \ Ifm vs bs p)" proof - from ferrack have th: "\bs p. qfree p \ qfree (ferrack p) \ Ifm vs bs (ferrack p) = Ifm vs bs (E p)" by blast from qelim[OF th, of p bs] show ?thesis unfolding frpar_def by auto qed section \Second implementation: case splits not local\ lemma fr_eq2: assumes lp: "islin p" shows "(\x. Ifm vs (x#bs) p) \ (Ifm vs (x#bs) (minusinf p) \ Ifm vs (x#bs) (plusinf p) \ Ifm vs (0#bs) p \ (\(n, t) \ set (uset p). Ipoly vs n \ 0 \ Ifm vs ((- Itm vs (x#bs) t / (Ipoly vs n * 2))#bs) p) \ (\(n, t) \ set (uset p). \(m, s) \ set (uset p). Ipoly vs n \ 0 \ Ipoly vs m \ 0 \ Ifm vs (((- Itm vs (x#bs) t / Ipoly vs n + - Itm vs (x#bs) s / Ipoly vs m) /2)#bs) p))" (is "(\x. ?I x p) = (?M \ ?P \ ?Z \ ?U \ ?F)" is "?E = ?D") proof assume px: "\x. ?I x p" consider "?M \ ?P" | "\ ?M" "\ ?P" by blast then show ?D proof cases case 1 then show ?thesis by blast next case 2 have nmi: "\ ?M" and npi: "\ ?P" by fact+ from inf_uset[OF lp nmi npi, OF px] obtain c t d s where ct: "(c, t) \ set (uset p)" "(d, s) \ set (uset p)" "?I ((- Itm vs (x # bs) t / \c\\<^sub>p\<^bsup>vs\<^esup> + - Itm vs (x # bs) s / \d\\<^sub>p\<^bsup>vs\<^esup>) / (1 + 1)) p" by auto let ?c = "\c\\<^sub>p\<^bsup>vs\<^esup>" let ?d = "\d\\<^sub>p\<^bsup>vs\<^esup>" let ?s = "Itm vs (x # bs) s" let ?t = "Itm vs (x # bs) t" have eq2: "\(x::'a). x + x = 2 * x" by (simp add: field_simps) consider "?c = 0" "?d = 0" | "?c = 0" "?d \ 0" | "?c \ 0" "?d = 0" | "?c \ 0" "?d \ 0" by auto then show ?thesis proof cases case 1 with ct show ?thesis by simp next case 2 with ct show ?thesis by auto next case 3 with ct show ?thesis by auto next case z: 4 from z have ?F using ct apply - apply (rule bexI[where x = "(c,t)"]) apply simp_all apply (rule bexI[where x = "(d,s)"]) apply simp_all done then show ?thesis by blast qed qed next assume ?D then consider ?M | ?P | ?Z | ?U | ?F by blast then show ?E proof cases case 1 show ?thesis by (rule minusinf_ex[OF lp \?M\]) next case 2 show ?thesis by (rule plusinf_ex[OF lp \?P\]) qed blast+ qed definition "msubsteq2 c t a b = Eq (Add (Mul a t) (Mul c b))" definition "msubstltpos c t a b = Lt (Add (Mul a t) (Mul c b))" definition "msubstlepos c t a b = Le (Add (Mul a t) (Mul c b))" definition "msubstltneg c t a b = Lt (Neg (Add (Mul a t) (Mul c b)))" definition "msubstleneg c t a b = Le (Neg (Add (Mul a t) (Mul c b)))" lemma msubsteq2: assumes nz: "Ipoly vs c \ 0" and l: "islin (Eq (CNP 0 a b))" shows "Ifm vs (x#bs) (msubsteq2 c t a b) = Ifm vs (((Itm vs (x#bs) t / Ipoly vs c ))#bs) (Eq (CNP 0 a b))" using nz l tmbound0_I[of b vs x bs "Itm vs (x # bs) t / \c\\<^sub>p\<^bsup>vs\<^esup>", symmetric] by (simp add: msubsteq2_def field_simps) lemma msubstltpos: assumes nz: "Ipoly vs c > 0" and l: "islin (Lt (CNP 0 a b))" shows "Ifm vs (x#bs) (msubstltpos c t a b) = Ifm vs (((Itm vs (x#bs) t / Ipoly vs c ))#bs) (Lt (CNP 0 a b))" using nz l tmbound0_I[of b vs x bs "Itm vs (x # bs) t / \c\\<^sub>p\<^bsup>vs\<^esup>", symmetric] by (simp add: msubstltpos_def field_simps) lemma msubstlepos: assumes nz: "Ipoly vs c > 0" and l: "islin (Le (CNP 0 a b))" shows "Ifm vs (x#bs) (msubstlepos c t a b) = Ifm vs (((Itm vs (x#bs) t / Ipoly vs c ))#bs) (Le (CNP 0 a b))" using nz l tmbound0_I[of b vs x bs "Itm vs (x # bs) t / \c\\<^sub>p\<^bsup>vs\<^esup>", symmetric] by (simp add: msubstlepos_def field_simps) lemma msubstltneg: assumes nz: "Ipoly vs c < 0" and l: "islin (Lt (CNP 0 a b))" shows "Ifm vs (x#bs) (msubstltneg c t a b) = Ifm vs (((Itm vs (x#bs) t / Ipoly vs c ))#bs) (Lt (CNP 0 a b))" using nz l tmbound0_I[of b vs x bs "Itm vs (x # bs) t / \c\\<^sub>p\<^bsup>vs\<^esup>", symmetric] by (simp add: msubstltneg_def field_simps del: minus_add_distrib) lemma msubstleneg: assumes nz: "Ipoly vs c < 0" and l: "islin (Le (CNP 0 a b))" shows "Ifm vs (x#bs) (msubstleneg c t a b) = Ifm vs (((Itm vs (x#bs) t / Ipoly vs c ))#bs) (Le (CNP 0 a b))" using nz l tmbound0_I[of b vs x bs "Itm vs (x # bs) t / \c\\<^sub>p\<^bsup>vs\<^esup>", symmetric] by (simp add: msubstleneg_def field_simps del: minus_add_distrib) fun msubstpos :: "fm \ poly \ tm \ fm" where "msubstpos (And p q) c t = And (msubstpos p c t) (msubstpos q c t)" | "msubstpos (Or p q) c t = Or (msubstpos p c t) (msubstpos q c t)" | "msubstpos (Eq (CNP 0 a r)) c t = msubsteq2 c t a r" | "msubstpos (NEq (CNP 0 a r)) c t = Not (msubsteq2 c t a r)" | "msubstpos (Lt (CNP 0 a r)) c t = msubstltpos c t a r" | "msubstpos (Le (CNP 0 a r)) c t = msubstlepos c t a r" | "msubstpos p c t = p" lemma msubstpos_I: assumes lp: "islin p" and pos: "Ipoly vs c > 0" shows "Ifm vs (x#bs) (msubstpos p c t) = Ifm vs (Itm vs (x#bs) t / Ipoly vs c #bs) p" using lp pos by (induct p rule: islin.induct) (auto simp add: msubsteq2 msubstltpos[OF pos] msubstlepos[OF pos] tmbound0_I[of _ vs "Itm vs (x # bs) t / \c\\<^sub>p\<^bsup>vs\<^esup>" bs x] bound0_I[of _ vs "Itm vs (x # bs) t / \c\\<^sub>p\<^bsup>vs\<^esup>" bs x] field_simps) fun msubstneg :: "fm \ poly \ tm \ fm" where "msubstneg (And p q) c t = And (msubstneg p c t) (msubstneg q c t)" | "msubstneg (Or p q) c t = Or (msubstneg p c t) (msubstneg q c t)" | "msubstneg (Eq (CNP 0 a r)) c t = msubsteq2 c t a r" | "msubstneg (NEq (CNP 0 a r)) c t = Not (msubsteq2 c t a r)" | "msubstneg (Lt (CNP 0 a r)) c t = msubstltneg c t a r" | "msubstneg (Le (CNP 0 a r)) c t = msubstleneg c t a r" | "msubstneg p c t = p" lemma msubstneg_I: assumes lp: "islin p" and pos: "Ipoly vs c < 0" shows "Ifm vs (x#bs) (msubstneg p c t) = Ifm vs (Itm vs (x#bs) t / Ipoly vs c #bs) p" using lp pos by (induct p rule: islin.induct) (auto simp add: msubsteq2 msubstltneg[OF pos] msubstleneg[OF pos] tmbound0_I[of _ vs "Itm vs (x # bs) t / \c\\<^sub>p\<^bsup>vs\<^esup>" bs x] bound0_I[of _ vs "Itm vs (x # bs) t / \c\\<^sub>p\<^bsup>vs\<^esup>" bs x] field_simps) definition "msubst2 p c t = disj (conj (lt (CP (polyneg c))) (simpfm (msubstpos p c t))) (conj (lt (CP c)) (simpfm (msubstneg p c t)))" lemma msubst2: assumes lp: "islin p" and nc: "isnpoly c" and nz: "Ipoly vs c \ 0" shows "Ifm vs (x#bs) (msubst2 p c t) = Ifm vs (Itm vs (x#bs) t / Ipoly vs c #bs) p" proof - let ?c = "Ipoly vs c" from nc have anc: "allpolys isnpoly (CP c)" "allpolys isnpoly (CP (~\<^sub>p c))" by (simp_all add: polyneg_norm) from nz consider "?c < 0" | "?c > 0" by arith then show ?thesis proof cases case c: 1 from c msubstneg_I[OF lp c, of x bs t] lt[OF anc(1), of vs "x#bs"] lt[OF anc(2), of vs "x#bs"] show ?thesis by (auto simp add: msubst2_def) next case c: 2 from c msubstpos_I[OF lp c, of x bs t] lt[OF anc(1), of vs "x#bs"] lt[OF anc(2), of vs "x#bs"] show ?thesis by (auto simp add: msubst2_def) qed qed lemma msubsteq2_nb: "tmbound0 t \ islin (Eq (CNP 0 a r)) \ bound0 (msubsteq2 c t a r)" by (simp add: msubsteq2_def) lemma msubstltpos_nb: "tmbound0 t \ islin (Lt (CNP 0 a r)) \ bound0 (msubstltpos c t a r)" by (simp add: msubstltpos_def) lemma msubstltneg_nb: "tmbound0 t \ islin (Lt (CNP 0 a r)) \ bound0 (msubstltneg c t a r)" by (simp add: msubstltneg_def) lemma msubstlepos_nb: "tmbound0 t \ islin (Le (CNP 0 a r)) \ bound0 (msubstlepos c t a r)" by (simp add: msubstlepos_def) lemma msubstleneg_nb: "tmbound0 t \ islin (Le (CNP 0 a r)) \ bound0 (msubstleneg c t a r)" by (simp add: msubstleneg_def) lemma msubstpos_nb: assumes lp: "islin p" and tnb: "tmbound0 t" shows "bound0 (msubstpos p c t)" using lp tnb by (induct p c t rule: msubstpos.induct) (auto simp add: msubsteq2_nb msubstltpos_nb msubstlepos_nb) lemma msubstneg_nb: assumes "SORT_CONSTRAINT('a::field_char_0)" and lp: "islin p" and tnb: "tmbound0 t" shows "bound0 (msubstneg p c t)" using lp tnb by (induct p c t rule: msubstneg.induct) (auto simp add: msubsteq2_nb msubstltneg_nb msubstleneg_nb) lemma msubst2_nb: assumes "SORT_CONSTRAINT('a::field_char_0)" and lp: "islin p" and tnb: "tmbound0 t" shows "bound0 (msubst2 p c t)" using lp tnb by (simp add: msubst2_def msubstneg_nb msubstpos_nb lt_nb simpfm_bound0) lemma mult_minus2_left: "-2 * x = - (2 * x)" for x :: "'a::comm_ring_1" by simp lemma mult_minus2_right: "x * -2 = - (x * 2)" for x :: "'a::comm_ring_1" by simp lemma islin_qf: "islin p \ qfree p" by (induct p rule: islin.induct) (auto simp add: bound0_qf) lemma fr_eq_msubst2: assumes lp: "islin p" shows "(\x. Ifm vs (x#bs) p) \ ((Ifm vs (x#bs) (minusinf p)) \ (Ifm vs (x#bs) (plusinf p)) \ Ifm vs (x#bs) (subst0 (CP 0\<^sub>p) p) \ (\(n, t) \ set (uset p). Ifm vs (x# bs) (msubst2 p (n *\<^sub>p (C (-2,1))) t)) \ (\(c, t) \ set (uset p). \(d, s) \ set (uset p). Ifm vs (x#bs) (msubst2 p (C (-2, 1) *\<^sub>p c*\<^sub>p d) (Add (Mul d t) (Mul c s)))))" (is "(\x. ?I x p) = (?M \ ?P \ ?Pz \ ?PU \ ?F)" is "?E = ?D") proof - from uset_l[OF lp] have *: "\(c, s)\set (uset p). isnpoly c \ tmbound0 s" by blast let ?I = "\p. Ifm vs (x#bs) p" have n2: "isnpoly (C (-2,1))" by (simp add: isnpoly_def) note eq0 = subst0[OF islin_qf[OF lp], of vs x bs "CP 0\<^sub>p", simplified] have eq1: "(\(n, t) \ set (uset p). ?I (msubst2 p (n *\<^sub>p (C (-2,1))) t)) \ (\(n, t) \ set (uset p). \n\\<^sub>p\<^bsup>vs\<^esup> \ 0 \ Ifm vs (- Itm vs (x # bs) t / (\n\\<^sub>p\<^bsup>vs\<^esup> * 2) # bs) p)" proof - { fix n t assume H: "(n, t) \ set (uset p)" "?I(msubst2 p (n *\<^sub>p C (-2, 1)) t)" from H(1) * have "isnpoly n" by blast then have nn: "isnpoly (n *\<^sub>p (C (-2,1)))" by (simp_all add: polymul_norm n2) have nn': "allpolys isnpoly (CP (~\<^sub>p (n *\<^sub>p C (-2, 1))))" by (simp add: polyneg_norm nn) then have nn2: "\n *\<^sub>p(C (-2,1)) \\<^sub>p\<^bsup>vs\<^esup> \ 0" "\n \\<^sub>p\<^bsup>vs\<^esup> \ 0" using H(2) nn' nn by (auto simp add: msubst2_def lt zero_less_mult_iff mult_less_0_iff) from msubst2[OF lp nn nn2(1), of x bs t] have "\n\\<^sub>p\<^bsup>vs\<^esup> \ 0 \ Ifm vs (- Itm vs (x # bs) t / (\n\\<^sub>p\<^bsup>vs\<^esup> * 2) # bs) p" using H(2) nn2 by (simp add: mult_minus2_right) } moreover { fix n t assume H: "(n, t) \ set (uset p)" "\n\\<^sub>p\<^bsup>vs\<^esup> \ 0" "Ifm vs (- Itm vs (x # bs) t / (\n\\<^sub>p\<^bsup>vs\<^esup> * 2) # bs) p" from H(1) * have "isnpoly n" by blast then have nn: "isnpoly (n *\<^sub>p (C (-2,1)))" "\n *\<^sub>p(C (-2,1)) \\<^sub>p\<^bsup>vs\<^esup> \ 0" using H(2) by (simp_all add: polymul_norm n2) from msubst2[OF lp nn, of x bs t] have "?I (msubst2 p (n *\<^sub>p (C (-2,1))) t)" using H(2,3) by (simp add: mult_minus2_right) } ultimately show ?thesis by blast qed have eq2: "(\(c, t) \ set (uset p). \(d, s) \ set (uset p). Ifm vs (x#bs) (msubst2 p (C (-2, 1) *\<^sub>p c*\<^sub>p d) (Add (Mul d t) (Mul c s)))) \ (\(n, t)\set (uset p). \(m, s)\set (uset p). \n\\<^sub>p\<^bsup>vs\<^esup> \ 0 \ \m\\<^sub>p\<^bsup>vs\<^esup> \ 0 \ Ifm vs ((- Itm vs (x # bs) t / \n\\<^sub>p\<^bsup>vs\<^esup> + - Itm vs (x # bs) s / \m\\<^sub>p\<^bsup>vs\<^esup>) / 2 # bs) p)" proof - { fix c t d s assume H: "(c,t) \ set (uset p)" "(d,s) \ set (uset p)" "Ifm vs (x#bs) (msubst2 p (C (-2, 1) *\<^sub>p c*\<^sub>p d) (Add (Mul d t) (Mul c s)))" from H(1,2) * have "isnpoly c" "isnpoly d" by blast+ then have nn: "isnpoly (C (-2, 1) *\<^sub>p c*\<^sub>p d)" by (simp_all add: polymul_norm n2) have stupid: "allpolys isnpoly (CP (~\<^sub>p (C (-2, 1) *\<^sub>p c *\<^sub>p d)))" "allpolys isnpoly (CP ((C (-2, 1) *\<^sub>p c *\<^sub>p d)))" by (simp_all add: polyneg_norm nn) have nn': "\(C (-2, 1) *\<^sub>p c*\<^sub>p d)\\<^sub>p\<^bsup>vs\<^esup> \ 0" "\c\\<^sub>p\<^bsup>vs\<^esup> \ 0" "\d\\<^sub>p\<^bsup>vs\<^esup> \ 0" using H(3) by (auto simp add: msubst2_def lt[OF stupid(1)] lt[OF stupid(2)] zero_less_mult_iff mult_less_0_iff) from msubst2[OF lp nn nn'(1), of x bs ] H(3) nn' have "\c\\<^sub>p\<^bsup>vs\<^esup> \ 0 \ \d\\<^sub>p\<^bsup>vs\<^esup> \ 0 \ Ifm vs ((- Itm vs (x # bs) t / \c\\<^sub>p\<^bsup>vs\<^esup> + - Itm vs (x # bs) s / \d\\<^sub>p\<^bsup>vs\<^esup>) / 2 # bs) p" by (simp add: add_divide_distrib diff_divide_distrib mult_minus2_left mult.commute) } moreover { fix c t d s assume H: "(c, t) \ set (uset p)" "(d, s) \ set (uset p)" "\c\\<^sub>p\<^bsup>vs\<^esup> \ 0" "\d\\<^sub>p\<^bsup>vs\<^esup> \ 0" "Ifm vs ((- Itm vs (x # bs) t / \c\\<^sub>p\<^bsup>vs\<^esup> + - Itm vs (x # bs) s / \d\\<^sub>p\<^bsup>vs\<^esup>) / 2 # bs) p" from H(1,2) * have "isnpoly c" "isnpoly d" by blast+ then have nn: "isnpoly (C (-2, 1) *\<^sub>p c*\<^sub>p d)" "\(C (-2, 1) *\<^sub>p c*\<^sub>p d)\\<^sub>p\<^bsup>vs\<^esup> \ 0" using H(3,4) by (simp_all add: polymul_norm n2) from msubst2[OF lp nn, of x bs ] H(3,4,5) have "Ifm vs (x#bs) (msubst2 p (C (-2, 1) *\<^sub>p c*\<^sub>p d) (Add (Mul d t) (Mul c s)))" by (simp add: diff_divide_distrib add_divide_distrib mult_minus2_left mult.commute) } ultimately show ?thesis by blast qed from fr_eq2[OF lp, of vs bs x] show ?thesis unfolding eq0 eq1 eq2 by blast qed definition "ferrack2 p \ let q = simpfm p; mp = minusinf q; pp = plusinf q in if (mp = T \ pp = T) then T else (let U = remdups (uset q) in decr0 (list_disj [mp, pp, simpfm (subst0 (CP 0\<^sub>p) q), evaldjf (\(c, t). msubst2 q (c *\<^sub>p C (-2, 1)) t) U, evaldjf (\((b, a),(d, c)). msubst2 q (C (-2, 1) *\<^sub>p b*\<^sub>p d) (Add (Mul d a) (Mul b c))) (alluopairs U)]))" definition "frpar2 p = simpfm (qelim (prep p) ferrack2)" lemma ferrack2: assumes qf: "qfree p" shows "qfree (ferrack2 p) \ Ifm vs bs (ferrack2 p) = Ifm vs bs (E p)" (is "_ \ (?rhs = ?lhs)") proof - let ?J = "\x p. Ifm vs (x#bs) p" let ?N = "\t. Ipoly vs t" let ?Nt = "\x t. Itm vs (x#bs) t" let ?q = "simpfm p" let ?qz = "subst0 (CP 0\<^sub>p) ?q" let ?U = "remdups(uset ?q)" let ?Up = "alluopairs ?U" let ?mp = "minusinf ?q" let ?pp = "plusinf ?q" fix x let ?I = "\p. Ifm vs (x#bs) p" from simpfm_lin[OF qf] simpfm_qf[OF qf] have lq: "islin ?q" and q_qf: "qfree ?q" . from minusinf_nb[OF lq] plusinf_nb[OF lq] have mp_nb: "bound0 ?mp" and pp_nb: "bound0 ?pp" . from bound0_qf[OF mp_nb] bound0_qf[OF pp_nb] have mp_qf: "qfree ?mp" and pp_qf: "qfree ?pp" . from uset_l[OF lq] have U_l: "\(c, s)\set ?U. isnpoly c \ c \ 0\<^sub>p \ tmbound0 s \ allpolys isnpoly s" by simp have bnd0: "\x \ set ?U. bound0 ((\(c,t). msubst2 ?q (c *\<^sub>p C (-2, 1)) t) x)" proof - have "bound0 ((\(c,t). msubst2 ?q (c *\<^sub>p C (-2, 1)) t) (c,t))" if "(c, t) \ set ?U" for c t proof - from U_l that have "tmbound0 t" by blast from msubst2_nb[OF lq this] show ?thesis by simp qed then show ?thesis by auto qed have bnd1: "\x \ set ?Up. bound0 ((\((b, a), (d, c)). msubst2 ?q (C (-2, 1) *\<^sub>p b*\<^sub>p d) (Add (Mul d a) (Mul b c))) x)" proof - have "bound0 ((\((b, a),(d, c)). msubst2 ?q (C (-2, 1) *\<^sub>p b*\<^sub>p d) (Add (Mul d a) (Mul b c))) ((b,a),(d,c)))" if "((b,a),(d,c)) \ set ?Up" for b a d c proof - from U_l alluopairs_set1[of ?U] that have this: "tmbound0 (Add (Mul d a) (Mul b c))" by auto from msubst2_nb[OF lq this] show ?thesis by simp qed then show ?thesis by auto qed have stupid: "bound0 F" by simp let ?R = "list_disj [?mp, ?pp, simpfm (subst0 (CP 0\<^sub>p) ?q), evaldjf (\(c,t). msubst2 ?q (c *\<^sub>p C (-2, 1)) t) ?U, evaldjf (\((b,a),(d,c)). msubst2 ?q (C (-2, 1) *\<^sub>p b*\<^sub>p d) (Add (Mul d a) (Mul b c))) (alluopairs ?U)]" from subst0_nb[of "CP 0\<^sub>p" ?q] q_qf evaldjf_bound0[OF bnd1] evaldjf_bound0[OF bnd0] mp_nb pp_nb stupid have nb: "bound0 ?R" by (simp add: list_disj_def simpfm_bound0) let ?s = "\((b, a),(d, c)). msubst2 ?q (C (-2, 1) *\<^sub>p b*\<^sub>p d) (Add (Mul d a) (Mul b c))" { fix b a d c assume baU: "(b,a) \ set ?U" and dcU: "(d,c) \ set ?U" from U_l baU dcU have norm: "isnpoly b" "isnpoly d" "isnpoly (C (-2, 1))" by auto (simp add: isnpoly_def) have norm2: "isnpoly (C (-2, 1) *\<^sub>p b*\<^sub>p d)" "isnpoly (C (-2, 1) *\<^sub>p d*\<^sub>p b)" using norm by (simp_all add: polymul_norm) have stupid: "allpolys isnpoly (CP (C (-2, 1) *\<^sub>p b *\<^sub>p d))" "allpolys isnpoly (CP (C (-2, 1) *\<^sub>p d *\<^sub>p b))" "allpolys isnpoly (CP (~\<^sub>p(C (-2, 1) *\<^sub>p b *\<^sub>p d)))" "allpolys isnpoly (CP (~\<^sub>p(C (-2, 1) *\<^sub>p d*\<^sub>p b)))" by (simp_all add: polyneg_norm norm2) have "?I (msubst2 ?q (C (-2, 1) *\<^sub>p b*\<^sub>p d) (Add (Mul d a) (Mul b c))) = ?I (msubst2 ?q (C (-2, 1) *\<^sub>p d*\<^sub>p b) (Add (Mul b c) (Mul d a)))" (is "?lhs \ ?rhs") proof assume H: ?lhs then have z: "\C (-2, 1) *\<^sub>p b *\<^sub>p d\\<^sub>p\<^bsup>vs\<^esup> \ 0" "\C (-2, 1) *\<^sub>p d *\<^sub>p b\\<^sub>p\<^bsup>vs\<^esup> \ 0" by (auto simp add: msubst2_def lt[OF stupid(3)] lt[OF stupid(1)] mult_less_0_iff zero_less_mult_iff) from msubst2[OF lq norm2(1) z(1), of x bs] msubst2[OF lq norm2(2) z(2), of x bs] H show ?rhs by (simp add: field_simps) next assume H: ?rhs then have z: "\C (-2, 1) *\<^sub>p b *\<^sub>p d\\<^sub>p\<^bsup>vs\<^esup> \ 0" "\C (-2, 1) *\<^sub>p d *\<^sub>p b\\<^sub>p\<^bsup>vs\<^esup> \ 0" by (auto simp add: msubst2_def lt[OF stupid(4)] lt[OF stupid(2)] mult_less_0_iff zero_less_mult_iff) from msubst2[OF lq norm2(1) z(1), of x bs] msubst2[OF lq norm2(2) z(2), of x bs] H show ?lhs by (simp add: field_simps) qed } then have th0: "\x \ set ?U. \y \ set ?U. ?I (?s (x, y)) \ ?I (?s (y, x))" by auto have "?lhs \ (\x. Ifm vs (x#bs) ?q)" by simp also have "\ \ ?I ?mp \ ?I ?pp \ ?I (subst0 (CP 0\<^sub>p) ?q) \ (\(n, t) \ set ?U. ?I (msubst2 ?q (n *\<^sub>p C (-2, 1)) t)) \ (\(b, a) \ set ?U. \(d, c) \ set ?U. ?I (msubst2 ?q (C (-2, 1) *\<^sub>p b*\<^sub>p d) (Add (Mul d a) (Mul b c))))" using fr_eq_msubst2[OF lq, of vs bs x] by simp also have "\ \ ?I ?mp \ ?I ?pp \ ?I (subst0 (CP 0\<^sub>p) ?q) \ (\(n, t) \ set ?U. ?I (msubst2 ?q (n *\<^sub>p C (-2, 1)) t)) \ (\x \ set ?U. \y \set ?U. ?I (?s (x, y)))" by (simp add: split_def) also have "\ \ ?I ?mp \ ?I ?pp \ ?I (subst0 (CP 0\<^sub>p) ?q) \ (\(n, t) \ set ?U. ?I (msubst2 ?q (n *\<^sub>p C (-2, 1)) t)) \ (\(x, y) \ set ?Up. ?I (?s (x, y)))" using alluopairs_bex[OF th0] by simp also have "\ \ ?I ?R" by (simp add: list_disj_def evaldjf_ex split_def) also have "\ \ ?rhs" unfolding ferrack2_def apply (cases "?mp = T") apply (simp add: list_disj_def) apply (cases "?pp = T") apply (simp add: list_disj_def) apply (simp_all add: Let_def decr0[OF nb]) done finally show ?thesis using decr0_qf[OF nb] by (simp add: ferrack2_def Let_def) qed lemma frpar2: "qfree (frpar2 p) \ (Ifm vs bs (frpar2 p) \ Ifm vs bs p)" proof - from ferrack2 have this: "\bs p. qfree p \ qfree (ferrack2 p) \ Ifm vs bs (ferrack2 p) = Ifm vs bs (E p)" by blast from qelim[OF this, of "prep p" bs] show ?thesis unfolding frpar2_def by (auto simp add: prep) qed oracle frpar_oracle = \ let val mk_C = @{code C} o apply2 @{code int_of_integer}; val mk_poly_Bound = @{code poly.Bound} o @{code nat_of_integer}; val mk_Bound = @{code Bound} o @{code nat_of_integer}; val dest_num = snd o HOLogic.dest_number; fun try_dest_num t = SOME ((snd o HOLogic.dest_number) t) handle TERM _ => NONE; fun dest_nat (t as \<^Const_>\Suc\) = HOLogic.dest_nat t (* FIXME !? *) | dest_nat t = dest_num t; fun the_index ts t = let val k = find_index (fn t' => t aconv t') ts; in if k < 0 then raise General.Subscript else k end; fun num_of_term ps \<^Const_>\uminus _ for t\ = @{code poly.Neg} (num_of_term ps t) | num_of_term ps \<^Const_>\plus _ for a b\ = @{code poly.Add} (num_of_term ps a, num_of_term ps b) | num_of_term ps \<^Const_>\minus _ for a b\ = @{code poly.Sub} (num_of_term ps a, num_of_term ps b) | num_of_term ps \<^Const_>\times _ for a b\ = @{code poly.Mul} (num_of_term ps a, num_of_term ps b) | num_of_term ps \<^Const_>\power _ for a n\ = @{code poly.Pw} (num_of_term ps a, @{code nat_of_integer} (dest_nat n)) | num_of_term ps \<^Const_>\divide _ for a b\ = mk_C (dest_num a, dest_num b) | num_of_term ps t = (case try_dest_num t of SOME k => mk_C (k, 1) | NONE => mk_poly_Bound (the_index ps t)); fun tm_of_term fs ps \<^Const_>\uminus _ for t\ = @{code Neg} (tm_of_term fs ps t) | tm_of_term fs ps \<^Const_>\plus _ for a b\ = @{code Add} (tm_of_term fs ps a, tm_of_term fs ps b) | tm_of_term fs ps \<^Const_>\minus _ for a b\ = @{code Sub} (tm_of_term fs ps a, tm_of_term fs ps b) | tm_of_term fs ps \<^Const_>\times _ for a b\ = @{code Mul} (num_of_term ps a, tm_of_term fs ps b) | tm_of_term fs ps t = (@{code CP} (num_of_term ps t) handle TERM _ => mk_Bound (the_index fs t) | General.Subscript => mk_Bound (the_index fs t)); fun fm_of_term fs ps \<^Const_>\True\ = @{code T} | fm_of_term fs ps \<^Const_>\False\ = @{code F} | fm_of_term fs ps \<^Const_>\HOL.Not for p\ = @{code Not} (fm_of_term fs ps p) | fm_of_term fs ps \<^Const_>\HOL.conj for p q\ = @{code And} (fm_of_term fs ps p, fm_of_term fs ps q) | fm_of_term fs ps \<^Const_>\HOL.disj for p q\ = @{code Or} (fm_of_term fs ps p, fm_of_term fs ps q) | fm_of_term fs ps \<^Const_>\HOL.implies for p q\ = @{code Imp} (fm_of_term fs ps p, fm_of_term fs ps q) | fm_of_term fs ps \<^Const_>\HOL.eq \<^Type>\bool\ for p q\ = @{code Iff} (fm_of_term fs ps p, fm_of_term fs ps q) | fm_of_term fs ps \<^Const_>\HOL.eq _ for p q\ = @{code Eq} (@{code Sub} (tm_of_term fs ps p, tm_of_term fs ps q)) | fm_of_term fs ps \<^Const_>\less _ for p q\ = @{code Lt} (@{code Sub} (tm_of_term fs ps p, tm_of_term fs ps q)) | fm_of_term fs ps \<^Const_>\less_eq _ for p q\ = @{code Le} (@{code Sub} (tm_of_term fs ps p, tm_of_term fs ps q)) | fm_of_term fs ps (\<^Const_>\Ex _\ $ Abs (abs as (_, xT, _))) = - let - val (xn', p') = Syntax_Trans.variant_abs abs; (* FIXME !? *) + let val (xn', p') = Term.dest_abs abs in @{code E} (fm_of_term (Free (xn', xT) :: fs) ps p') end | fm_of_term fs ps (\<^Const_>\All _\ $ Abs (abs as (_, xT, _))) = - let - val (xn', p') = Syntax_Trans.variant_abs abs; (* FIXME !? *) + let val (xn', p') = Term.dest_abs abs in @{code A} (fm_of_term (Free (xn', xT) :: fs) ps p') end | fm_of_term fs ps _ = error "fm_of_term"; fun term_of_num T ps (@{code poly.C} (a, b)) = let val (c, d) = apply2 (@{code integer_of_int}) (a, b) in if d = 1 then HOLogic.mk_number T c else if d = 0 then \<^Const>\zero_class.zero T\ else \<^Const>\divide T for \HOLogic.mk_number T c\ \HOLogic.mk_number T d\\ end | term_of_num T ps (@{code poly.Bound} i) = nth ps (@{code integer_of_nat} i) | term_of_num T ps (@{code poly.Add} (a, b)) = \<^Const>\plus T for \term_of_num T ps a\ \term_of_num T ps b\\ | term_of_num T ps (@{code poly.Mul} (a, b)) = \<^Const>\times T for \term_of_num T ps a\ \term_of_num T ps b\\ | term_of_num T ps (@{code poly.Sub} (a, b)) = \<^Const>\minus T for \term_of_num T ps a\ \term_of_num T ps b\\ | term_of_num T ps (@{code poly.Neg} a) = \<^Const>\uminus T for \term_of_num T ps a\\ | term_of_num T ps (@{code poly.Pw} (a, n)) = \<^Const>\power T for \term_of_num T ps a\ \HOLogic.mk_number \<^Type>\nat\ (@{code integer_of_nat} n)\\ | term_of_num T ps (@{code poly.CN} (c, n, p)) = term_of_num T ps (@{code poly.Add} (c, @{code poly.Mul} (@{code poly.Bound} n, p))); fun term_of_tm T fs ps (@{code CP} p) = term_of_num T ps p | term_of_tm T fs ps (@{code Bound} i) = nth fs (@{code integer_of_nat} i) | term_of_tm T fs ps (@{code Add} (a, b)) = \<^Const>\plus T for \term_of_tm T fs ps a\ \term_of_tm T fs ps b\\ | term_of_tm T fs ps (@{code Mul} (a, b)) = \<^Const>\times T for \term_of_num T ps a\ \term_of_tm T fs ps b\\ | term_of_tm T fs ps (@{code Sub} (a, b)) = \<^Const>\minus T for \term_of_tm T fs ps a\ \term_of_tm T fs ps b\\ | term_of_tm T fs ps (@{code Neg} a) = \<^Const>\uminus T for \term_of_tm T fs ps a\\ | term_of_tm T fs ps (@{code CNP} (n, c, p)) = term_of_tm T fs ps (@{code Add} (@{code Mul} (c, @{code Bound} n), p)); fun term_of_fm T fs ps @{code T} = \<^Const>\True\ | term_of_fm T fs ps @{code F} = \<^Const>\False\ | term_of_fm T fs ps (@{code Not} p) = \<^Const>\HOL.Not for \term_of_fm T fs ps p\\ | term_of_fm T fs ps (@{code And} (p, q)) = \<^Const>\HOL.conj for \term_of_fm T fs ps p\ \term_of_fm T fs ps q\\ | term_of_fm T fs ps (@{code Or} (p, q)) = \<^Const>\HOL.disj for \term_of_fm T fs ps p\ \term_of_fm T fs ps q\\ | term_of_fm T fs ps (@{code Imp} (p, q)) = \<^Const>\HOL.implies for \term_of_fm T fs ps p\ \term_of_fm T fs ps q\\ | term_of_fm T fs ps (@{code Iff} (p, q)) = \<^Const>\HOL.eq \<^Type>\bool\ for \term_of_fm T fs ps p\ \term_of_fm T fs ps q\\ | term_of_fm T fs ps (@{code Lt} p) = \<^Const>\less T for \term_of_tm T fs ps p\ \<^Const>\zero_class.zero T\\ | term_of_fm T fs ps (@{code Le} p) = \<^Const>\less_eq T for \term_of_tm T fs ps p\ \<^Const>\zero_class.zero T\\ | term_of_fm T fs ps (@{code Eq} p) = \<^Const>\HOL.eq T for \term_of_tm T fs ps p\ \<^Const>\zero_class.zero T\\ | term_of_fm T fs ps (@{code NEq} p) = \<^Const>\Not for (* FIXME HOL.Not!? *) \<^Const>\HOL.eq T for \term_of_tm T fs ps p\ \<^Const>\zero_class.zero T\\\ | term_of_fm T fs ps _ = error "term_of_fm: quantifiers"; fun frpar_procedure alternative T ps fm = let val frpar = if alternative then @{code frpar2} else @{code frpar}; val fs = subtract (op aconv) (map Free (Term.add_frees fm [])) ps; val eval = term_of_fm T fs ps o frpar o fm_of_term fs ps; val t = HOLogic.dest_Trueprop fm; in HOLogic.mk_Trueprop (HOLogic.mk_eq (t, eval t)) end; in fn (ctxt, alternative, ty, ps, ct) => Thm.cterm_of ctxt (frpar_procedure alternative ty ps (Thm.term_of ct)) end \ ML \ structure Parametric_Ferrante_Rackoff = struct fun tactic ctxt alternative T ps = Object_Logic.full_atomize_tac ctxt THEN' CSUBGOAL (fn (g, i) => let val th = frpar_oracle (ctxt, alternative, T, ps, g); in resolve_tac ctxt [th RS iffD2] i end); fun method alternative = let fun keyword k = Scan.lift (Args.$$$ k -- Args.colon) >> K (); val parsN = "pars"; val typN = "type"; val any_keyword = keyword parsN || keyword typN; val terms = Scan.repeat (Scan.unless any_keyword Args.term); val typ = Scan.unless any_keyword Args.typ; in (keyword typN |-- typ) -- (keyword parsN |-- terms) >> (fn (T, ps) => fn ctxt => SIMPLE_METHOD' (tactic ctxt alternative T ps)) end; end; \ method_setup frpar = \ Parametric_Ferrante_Rackoff.method false \ "parametric QE for linear Arithmetic over fields" method_setup frpar2 = \ Parametric_Ferrante_Rackoff.method true \ "parametric QE for linear Arithmetic over fields, Version 2" lemma "\(x::'a::linordered_field). y \ -1 \ (y + 1) * x < 0" apply (frpar type: 'a pars: y) apply (simp add: field_simps) apply (rule spec[where x=y]) apply (frpar type: 'a pars: "z::'a") apply simp done lemma "\(x::'a::linordered_field). y \ -1 \ (y + 1)*x < 0" apply (frpar2 type: 'a pars: y) apply (simp add: field_simps) apply (rule spec[where x=y]) apply (frpar2 type: 'a pars: "z::'a") apply simp done text \Collins/Jones Problem\ (* lemma "\(r::'a::{linordered_field, number_ring}). 0 < r \ r < 1 \ 0 < (2 - 3*r) *(a^2 + b^2) + (2*a)*r \ (2 - 3*r) *(a^2 + b^2) + 4*a*r - 2*a - r < 0" proof - have "(\(r::'a::{linordered_field, number_ring}). 0 < r \ r < 1 \ 0 < (2 - 3*r) *(a^2 + b^2) + (2*a)*r \ (2 - 3*r) *(a^2 + b^2) + 4*a*r - 2*a - r < 0) \ (\(r::'a::{linordered_field, number_ring}). 0 < r \ r < 1 \ 0 < 2 *(a^2 + b^2) - (3*(a^2 + b^2)) * r + (2*a)*r \ 2*(a^2 + b^2) - (3*(a^2 + b^2) - 4*a + 1)*r - 2*a < 0)" (is "?lhs \ ?rhs") by (simp add: field_simps) have "?rhs" apply (frpar type: "'a::{linordered_field, number_ring}" pars: "a::'a::{linordered_field, number_ring}" "b::'a::{linordered_field, number_ring}") apply (simp add: field_simps) oops *) (* lemma "ALL (x::'a::{linordered_field, number_ring}) y. (1 - t)*x \ (1+t)*y \ (1 - t)*y \ (1+t)*x --> 0 \ y" apply (frpar type: "'a::{linordered_field, number_ring}" pars: "t::'a::{linordered_field, number_ring}") oops *) text \Collins/Jones Problem\ (* lemma "\(r::'a::{linordered_field, number_ring}). 0 < r \ r < 1 \ 0 < (2 - 3*r) *(a^2 + b^2) + (2*a)*r \ (2 - 3*r) *(a^2 + b^2) + 4*a*r - 2*a - r < 0" proof - have "(\(r::'a::{linordered_field, number_ring}). 0 < r \ r < 1 \ 0 < (2 - 3*r) *(a^2 + b^2) + (2*a)*r \ (2 - 3*r) *(a^2 + b^2) + 4*a*r - 2*a - r < 0) \ (\(r::'a::{linordered_field, number_ring}). 0 < r \ r < 1 \ 0 < 2 *(a^2 + b^2) - (3*(a^2 + b^2)) * r + (2*a)*r \ 2*(a^2 + b^2) - (3*(a^2 + b^2) - 4*a + 1)*r - 2*a < 0)" (is "?lhs \ ?rhs") by (simp add: field_simps) have "?rhs" apply (frpar2 type: "'a::{linordered_field, number_ring}" pars: "a::'a::{linordered_field, number_ring}" "b::'a::{linordered_field, number_ring}") apply simp oops *) (* lemma "ALL (x::'a::{linordered_field, number_ring}) y. (1 - t)*x \ (1+t)*y \ (1 - t)*y \ (1+t)*x --> 0 \ y" apply (frpar2 type: "'a::{linordered_field, number_ring}" pars: "t::'a::{linordered_field, number_ring}") apply (simp add: field_simps linorder_neq_iff[symmetric]) apply ferrack oops *) end diff --git a/src/HOL/Tools/Qelim/cooper.ML b/src/HOL/Tools/Qelim/cooper.ML --- a/src/HOL/Tools/Qelim/cooper.ML +++ b/src/HOL/Tools/Qelim/cooper.ML @@ -1,918 +1,917 @@ (* Title: HOL/Tools/Qelim/cooper.ML Author: Amine Chaieb, TU Muenchen Presburger arithmetic by Cooper's algorithm. *) signature COOPER = sig type entry val get: Proof.context -> entry val del: term list -> attribute val add: term list -> attribute exception COOPER of string val conv: Proof.context -> conv val tac: bool -> thm list -> thm list -> Proof.context -> int -> tactic end; structure Cooper: COOPER = struct type entry = simpset * term list; val allowed_consts = [\<^term>\(+) :: int => _\, \<^term>\(+) :: nat => _\, \<^term>\(-) :: int => _\, \<^term>\(-) :: nat => _\, \<^term>\(*) :: int => _\, \<^term>\(*) :: nat => _\, \<^term>\(div) :: int => _\, \<^term>\(div) :: nat => _\, \<^term>\(mod) :: int => _\, \<^term>\(mod) :: nat => _\, \<^term>\HOL.conj\, \<^term>\HOL.disj\, \<^term>\HOL.implies\, \<^term>\(=) :: int => _\, \<^term>\(=) :: nat => _\, \<^term>\(=) :: bool => _\, \<^term>\(<) :: int => _\, \<^term>\(<) :: nat => _\, \<^term>\(<=) :: int => _\, \<^term>\(<=) :: nat => _\, \<^term>\(dvd) :: int => _\, \<^term>\(dvd) :: nat => _\, \<^term>\abs :: int => _\, \<^term>\max :: int => _\, \<^term>\max :: nat => _\, \<^term>\min :: int => _\, \<^term>\min :: nat => _\, \<^term>\uminus :: int => _\, (*@ {term "uminus :: nat => _"},*) \<^term>\Not\, \<^term>\Suc\, \<^term>\Ex :: (int => _) => _\, \<^term>\Ex :: (nat => _) => _\, \<^term>\All :: (int => _) => _\, \<^term>\All :: (nat => _) => _\, \<^term>\nat\, \<^term>\int\, \<^term>\Num.One\, \<^term>\Num.Bit0\, \<^term>\Num.Bit1\, \<^term>\Num.numeral :: num => int\, \<^term>\Num.numeral :: num => nat\, \<^term>\0::int\, \<^term>\1::int\, \<^term>\0::nat\, \<^term>\1::nat\, \<^term>\True\, \<^term>\False\]; structure Data = Generic_Data ( type T = simpset * term list; val empty = (HOL_ss, allowed_consts); val extend = I; fun merge ((ss1, ts1), (ss2, ts2)) = (merge_ss (ss1, ss2), Library.merge (op aconv) (ts1, ts2)); ); val get = Data.get o Context.Proof; fun add ts = Thm.declaration_attribute (fn th => fn context => context |> Data.map (fn (ss, ts') => (simpset_map (Context.proof_of context) (fn ctxt => ctxt addsimps [th]) ss, merge (op aconv) (ts', ts)))) fun del ts = Thm.declaration_attribute (fn th => fn context => context |> Data.map (fn (ss, ts') => (simpset_map (Context.proof_of context) (fn ctxt => ctxt delsimps [th]) ss, subtract (op aconv) ts' ts))) fun simp_thms_conv ctxt = Simplifier.rewrite (put_simpset HOL_basic_ss ctxt addsimps @{thms simp_thms}); val FWD = Drule.implies_elim_list; val true_tm = \<^cterm>\True\; val false_tm = \<^cterm>\False\; val presburger_ss = simpset_of (\<^context> addsimps @{thms zdvd1_eq}); val lin_ss = simpset_of (put_simpset presburger_ss \<^context> addsimps (@{thms dvd_eq_mod_eq_0 add.assoc [where 'a = int] add.commute [where 'a = int] add.left_commute [where 'a = int] mult.assoc [where 'a = int] mult.commute [where 'a = int] mult.left_commute [where 'a = int] })); val iT = HOLogic.intT val bT = HOLogic.boolT; val dest_number = HOLogic.dest_number #> snd; val perhaps_number = try dest_number; val is_number = can dest_number; val [miconj, midisj, mieq, mineq, milt, mile, migt, mige, midvd, mindvd, miP] = map (Thm.instantiate' [SOME \<^ctyp>\int\] []) @{thms "minf"}; val [infDconj, infDdisj, infDdvd,infDndvd,infDP] = map (Thm.instantiate' [SOME \<^ctyp>\int\] []) @{thms "inf_period"}; val [piconj, pidisj, pieq,pineq,pilt,pile,pigt,pige,pidvd,pindvd,piP] = map (Thm.instantiate' [SOME \<^ctyp>\int\] []) @{thms "pinf"}; val [miP, piP] = map (Thm.instantiate' [SOME \<^ctyp>\bool\] []) [miP, piP]; val infDP = Thm.instantiate' (map SOME [\<^ctyp>\int\, \<^ctyp>\bool\]) [] infDP; val [[asetconj, asetdisj, aseteq, asetneq, asetlt, asetle, asetgt, asetge, asetdvd, asetndvd,asetP], [bsetconj, bsetdisj, bseteq, bsetneq, bsetlt, bsetle, bsetgt, bsetge, bsetdvd, bsetndvd,bsetP]] = [@{thms "aset"}, @{thms "bset"}]; val [cpmi, cppi] = [@{thm "cpmi"}, @{thm "cppi"}]; val unity_coeff_ex = Thm.instantiate' [SOME \<^ctyp>\int\] [] @{thm "unity_coeff_ex"}; val [zdvd_mono,simp_from_to,all_not_ex] = [@{thm "zdvd_mono"}, @{thm "simp_from_to"}, @{thm "all_not_ex"}]; val [dvd_uminus, dvd_uminus'] = @{thms "uminus_dvd_conv"}; val eval_ss = simpset_of (put_simpset presburger_ss \<^context> addsimps [simp_from_to] delsimps [insert_iff, bex_triv]); fun eval_conv ctxt = Simplifier.rewrite (put_simpset eval_ss ctxt); (* recognising cterm without moving to terms *) datatype fm = And of cterm*cterm| Or of cterm*cterm| Eq of cterm | NEq of cterm | Lt of cterm | Le of cterm | Gt of cterm | Ge of cterm | Dvd of cterm*cterm | NDvd of cterm*cterm | Nox fun whatis x ct = ( case Thm.term_of ct of Const(\<^const_name>\HOL.conj\,_)$_$_ => And (Thm.dest_binop ct) | Const (\<^const_name>\HOL.disj\,_)$_$_ => Or (Thm.dest_binop ct) | Const (\<^const_name>\HOL.eq\,_)$y$_ => if Thm.term_of x aconv y then Eq (Thm.dest_arg ct) else Nox | Const (\<^const_name>\Not\,_) $ (Const (\<^const_name>\HOL.eq\,_)$y$_) => if Thm.term_of x aconv y then NEq (funpow 2 Thm.dest_arg ct) else Nox | Const (\<^const_name>\Orderings.less\, _) $ y$ z => if Thm.term_of x aconv y then Lt (Thm.dest_arg ct) else if Thm.term_of x aconv z then Gt (Thm.dest_arg1 ct) else Nox | Const (\<^const_name>\Orderings.less_eq\, _) $ y $ z => if Thm.term_of x aconv y then Le (Thm.dest_arg ct) else if Thm.term_of x aconv z then Ge (Thm.dest_arg1 ct) else Nox | Const (\<^const_name>\Rings.dvd\,_)$_$(Const(\<^const_name>\Groups.plus\,_)$y$_) => if Thm.term_of x aconv y then Dvd (Thm.dest_binop ct ||> Thm.dest_arg) else Nox | Const (\<^const_name>\Not\,_) $ (Const (\<^const_name>\Rings.dvd\,_)$_$(Const(\<^const_name>\Groups.plus\,_)$y$_)) => if Thm.term_of x aconv y then NDvd (Thm.dest_binop (Thm.dest_arg ct) ||> Thm.dest_arg) else Nox | _ => Nox) handle CTERM _ => Nox; fun get_pmi_term t = let val (x,eq) = (Thm.dest_abs NONE o Thm.dest_arg o snd o Thm.dest_abs NONE o Thm.dest_arg) (Thm.dest_arg t) in (Thm.lambda x o Thm.dest_arg o Thm.dest_arg) eq end; val get_pmi = get_pmi_term o Thm.cprop_of; val p_v' = (("P'", 0), \<^typ>\int \ bool\); val q_v' = (("Q'", 0), \<^typ>\int \ bool\); val p_v = (("P", 0), \<^typ>\int \ bool\); val q_v = (("Q", 0), \<^typ>\int \ bool\); fun myfwd (th1, th2, th3) p q [(th_1,th_2,th_3), (th_1',th_2',th_3')] = let val (mp', mq') = (get_pmi th_1, get_pmi th_1') val mi_th = FWD (Drule.instantiate_normalize (TVars.empty, Vars.make [(p_v,p),(q_v,q), (p_v',mp'),(q_v',mq')]) th1) [th_1, th_1'] val infD_th = FWD (Drule.instantiate_normalize (TVars.empty, Vars.make [(p_v,mp'), (q_v, mq')]) th3) [th_3,th_3'] val set_th = FWD (Drule.instantiate_normalize (TVars.empty, Vars.make [(p_v,p), (q_v,q)]) th2) [th_2, th_2'] in (mi_th, set_th, infD_th) end; val inst' = fn cts => Thm.instantiate' [] (map SOME cts); val infDTrue = Thm.instantiate' [] [SOME true_tm] infDP; val infDFalse = Thm.instantiate' [] [SOME false_tm] infDP; val cadd = \<^cterm>\(+) :: int => _\ val cmulC = \<^cterm>\(*) :: int => _\ val cminus = \<^cterm>\(-) :: int => _\ val cone = \<^cterm>\1 :: int\ val [addC, mulC, subC] = map Thm.term_of [cadd, cmulC, cminus] val [zero, one] = [\<^term>\0 :: int\, \<^term>\1 :: int\]; fun numeral1 f n = HOLogic.mk_number iT (f (dest_number n)); fun numeral2 f m n = HOLogic.mk_number iT (f (dest_number m) (dest_number n)); val [minus1,plus1] = map (fn c => fn t => Thm.apply (Thm.apply c t) cone) [cminus,cadd]; fun decomp_pinf x dvd inS [aseteq, asetneq, asetlt, asetle, asetgt, asetge,asetdvd,asetndvd,asetP, infDdvd, infDndvd, asetconj, asetdisj, infDconj, infDdisj] cp = case (whatis x cp) of And (p,q) => ([p,q], myfwd (piconj, asetconj, infDconj) (Thm.lambda x p) (Thm.lambda x q)) | Or (p,q) => ([p,q], myfwd (pidisj, asetdisj, infDdisj) (Thm.lambda x p) (Thm.lambda x q)) | Eq t => ([], K (inst' [t] pieq, FWD (inst' [t] aseteq) [inS (plus1 t)], infDFalse)) | NEq t => ([], K (inst' [t] pineq, FWD (inst' [t] asetneq) [inS t], infDTrue)) | Lt t => ([], K (inst' [t] pilt, FWD (inst' [t] asetlt) [inS t], infDFalse)) | Le t => ([], K (inst' [t] pile, FWD (inst' [t] asetle) [inS (plus1 t)], infDFalse)) | Gt t => ([], K (inst' [t] pigt, (inst' [t] asetgt), infDTrue)) | Ge t => ([], K (inst' [t] pige, (inst' [t] asetge), infDTrue)) | Dvd (d,s) => ([],let val dd = dvd d in K (inst' [d,s] pidvd, FWD (inst' [d,s] asetdvd) [dd],FWD (inst' [d,s] infDdvd) [dd]) end) | NDvd(d,s) => ([],let val dd = dvd d in K (inst' [d,s] pindvd, FWD (inst' [d,s] asetndvd) [dd], FWD (inst' [d,s] infDndvd) [dd]) end) | _ => ([], K (inst' [cp] piP, inst' [cp] asetP, inst' [cp] infDP)); fun decomp_minf x dvd inS [bseteq,bsetneq,bsetlt, bsetle, bsetgt, bsetge,bsetdvd,bsetndvd,bsetP, infDdvd, infDndvd, bsetconj, bsetdisj, infDconj, infDdisj] cp = case (whatis x cp) of And (p,q) => ([p,q], myfwd (miconj, bsetconj, infDconj) (Thm.lambda x p) (Thm.lambda x q)) | Or (p,q) => ([p,q], myfwd (midisj, bsetdisj, infDdisj) (Thm.lambda x p) (Thm.lambda x q)) | Eq t => ([], K (inst' [t] mieq, FWD (inst' [t] bseteq) [inS (minus1 t)], infDFalse)) | NEq t => ([], K (inst' [t] mineq, FWD (inst' [t] bsetneq) [inS t], infDTrue)) | Lt t => ([], K (inst' [t] milt, (inst' [t] bsetlt), infDTrue)) | Le t => ([], K (inst' [t] mile, (inst' [t] bsetle), infDTrue)) | Gt t => ([], K (inst' [t] migt, FWD (inst' [t] bsetgt) [inS t], infDFalse)) | Ge t => ([], K (inst' [t] mige,FWD (inst' [t] bsetge) [inS (minus1 t)], infDFalse)) | Dvd (d,s) => ([],let val dd = dvd d in K (inst' [d,s] midvd, FWD (inst' [d,s] bsetdvd) [dd] , FWD (inst' [d,s] infDdvd) [dd]) end) | NDvd (d,s) => ([],let val dd = dvd d in K (inst' [d,s] mindvd, FWD (inst' [d,s] bsetndvd) [dd], FWD (inst' [d,s] infDndvd) [dd]) end) | _ => ([], K (inst' [cp] miP, inst' [cp] bsetP, inst' [cp] infDP)) (* Canonical linear form for terms, formulae etc.. *) fun provelin ctxt t = Goal.prove ctxt [] [] t (fn _ => EVERY [simp_tac (put_simpset lin_ss ctxt) 1, TRY (Lin_Arith.tac ctxt 1)]); fun linear_cmul 0 tm = zero | linear_cmul n tm = case tm of Const (\<^const_name>\Groups.plus\, _) $ a $ b => addC $ linear_cmul n a $ linear_cmul n b | Const (\<^const_name>\Groups.times\, _) $ c $ x => mulC $ numeral1 (fn m => n * m) c $ x | Const (\<^const_name>\Groups.minus\, _) $ a $ b => subC $ linear_cmul n a $ linear_cmul n b | (m as Const (\<^const_name>\Groups.uminus\, _)) $ a => m $ linear_cmul n a | _ => numeral1 (fn m => n * m) tm; fun earlier [] x y = false | earlier (h::t) x y = if h aconv y then false else if h aconv x then true else earlier t x y; fun linear_add vars tm1 tm2 = case (tm1, tm2) of (Const (\<^const_name>\Groups.plus\, _) $ (Const (\<^const_name>\Groups.times\, _) $ c1 $ x1) $ r1, Const (\<^const_name>\Groups.plus\, _) $ (Const (\<^const_name>\Groups.times\, _) $ c2 $ x2) $ r2) => if x1 = x2 then let val c = numeral2 Integer.add c1 c2 in if c = zero then linear_add vars r1 r2 else addC$(mulC$c$x1)$(linear_add vars r1 r2) end else if earlier vars x1 x2 then addC $ (mulC $ c1 $ x1) $ linear_add vars r1 tm2 else addC $ (mulC $ c2 $ x2) $ linear_add vars tm1 r2 | (Const (\<^const_name>\Groups.plus\, _) $ (Const (\<^const_name>\Groups.times\, _) $ c1 $ x1) $ r1, _) => addC $ (mulC $ c1 $ x1) $ linear_add vars r1 tm2 | (_, Const (\<^const_name>\Groups.plus\, _) $ (Const (\<^const_name>\Groups.times\, _) $ c2 $ x2) $ r2) => addC $ (mulC $ c2 $ x2) $ linear_add vars tm1 r2 | (_, _) => numeral2 Integer.add tm1 tm2; fun linear_neg tm = linear_cmul ~1 tm; fun linear_sub vars tm1 tm2 = linear_add vars tm1 (linear_neg tm2); exception COOPER of string; fun lint vars tm = if is_number tm then tm else case tm of Const (\<^const_name>\Groups.uminus\, _) $ t => linear_neg (lint vars t) | Const (\<^const_name>\Groups.plus\, _) $ s $ t => linear_add vars (lint vars s) (lint vars t) | Const (\<^const_name>\Groups.minus\, _) $ s $ t => linear_sub vars (lint vars s) (lint vars t) | Const (\<^const_name>\Groups.times\, _) $ s $ t => let val s' = lint vars s val t' = lint vars t in case perhaps_number s' of SOME n => linear_cmul n t' | NONE => (case perhaps_number t' of SOME n => linear_cmul n s' | NONE => raise COOPER "lint: not linear") end | _ => addC $ (mulC $ one $ tm) $ zero; fun lin (vs as _::_) (Const (\<^const_name>\Not\, _) $ (Const (\<^const_name>\Orderings.less\, T) $ s $ t)) = lin vs (Const (\<^const_name>\Orderings.less_eq\, T) $ t $ s) | lin (vs as _::_) (Const (\<^const_name>\Not\,_) $ (Const(\<^const_name>\Orderings.less_eq\, T) $ s $ t)) = lin vs (Const (\<^const_name>\Orderings.less\, T) $ t $ s) | lin vs (Const (\<^const_name>\Not\,T)$t) = Const (\<^const_name>\Not\,T)$ (lin vs t) | lin (vs as _::_) (Const(\<^const_name>\Rings.dvd\,_)$d$t) = HOLogic.mk_binrel \<^const_name>\Rings.dvd\ (numeral1 abs d, lint vs t) | lin (vs as x::_) ((b as Const(\<^const_name>\HOL.eq\,_))$s$t) = (case lint vs (subC$t$s) of (t as _$(m$c$y)$r) => if x <> y then b$zero$t else if dest_number c < 0 then b$(m$(numeral1 ~ c)$y)$r else b$(m$c$y)$(linear_neg r) | t => b$zero$t) | lin (vs as x::_) (b$s$t) = (case lint vs (subC$t$s) of (t as _$(m$c$y)$r) => if x <> y then b$zero$t else if dest_number c < 0 then b$(m$(numeral1 ~ c)$y)$r else b$(linear_neg r)$(m$c$y) | t => b$zero$t) | lin vs fm = fm; fun lint_conv ctxt vs ct = let val t = Thm.term_of ct in (provelin ctxt ((HOLogic.eq_const iT)$t$(lint vs t) |> HOLogic.mk_Trueprop)) RS eq_reflection end; fun is_intrel_type T = T = \<^typ>\int => int => bool\; fun is_intrel (b$_$_) = is_intrel_type (fastype_of b) | is_intrel (\<^term>\Not\$(b$_$_)) = is_intrel_type (fastype_of b) | is_intrel _ = false; fun linearize_conv ctxt vs ct = case Thm.term_of ct of Const(\<^const_name>\Rings.dvd\,_)$_$_ => let val th = Conv.binop_conv (lint_conv ctxt vs) ct val (d',t') = Thm.dest_binop (Thm.rhs_of th) val (dt',tt') = (Thm.term_of d', Thm.term_of t') in if is_number dt' andalso is_number tt' then Conv.fconv_rule (Conv.arg_conv (Simplifier.rewrite (put_simpset presburger_ss ctxt))) th else let val dth = case perhaps_number (Thm.term_of d') of SOME d => if d < 0 then (Conv.fconv_rule (Conv.arg_conv (Conv.arg1_conv (lint_conv ctxt vs))) (Thm.transitive th (inst' [d',t'] dvd_uminus)) handle TERM _ => th) else th | NONE => raise COOPER "linearize_conv: not linear" val d'' = Thm.rhs_of dth |> Thm.dest_arg1 in case tt' of Const(\<^const_name>\Groups.plus\,_)$(Const(\<^const_name>\Groups.times\,_)$c$_)$_ => let val x = dest_number c in if x < 0 then Conv.fconv_rule (Conv.arg_conv (Conv.arg_conv (lint_conv ctxt vs))) (Thm.transitive dth (inst' [d'',t'] dvd_uminus')) else dth end | _ => dth end end | Const (\<^const_name>\Not\,_)$(Const(\<^const_name>\Rings.dvd\,_)$_$_) => Conv.arg_conv (linearize_conv ctxt vs) ct | t => if is_intrel t then (provelin ctxt ((HOLogic.eq_const bT)$t$(lin vs t) |> HOLogic.mk_Trueprop)) RS eq_reflection else Thm.reflexive ct; val dvdc = \<^cterm>\(dvd) :: int => _\; fun unify ctxt q = let val (e,(cx,p)) = q |> Thm.dest_comb ||> Thm.dest_abs NONE val x = Thm.term_of cx val ins = insert (op = : int * int -> bool) fun h (acc,dacc) t = case Thm.term_of t of Const(s,_)$(Const(\<^const_name>\Groups.times\,_)$c$y)$ _ => if x aconv y andalso member (op =) [\<^const_name>\HOL.eq\, \<^const_name>\Orderings.less\, \<^const_name>\Orderings.less_eq\] s then (ins (dest_number c) acc,dacc) else (acc,dacc) | Const(s,_)$_$(Const(\<^const_name>\Groups.times\,_)$c$y) => if x aconv y andalso member (op =) [\<^const_name>\Orderings.less\, \<^const_name>\Orderings.less_eq\] s then (ins (dest_number c) acc, dacc) else (acc,dacc) | Const(\<^const_name>\Rings.dvd\,_)$_$(Const(\<^const_name>\Groups.plus\,_)$(Const(\<^const_name>\Groups.times\,_)$c$y)$_) => if x aconv y then (acc,ins (dest_number c) dacc) else (acc,dacc) | Const(\<^const_name>\HOL.conj\,_)$_$_ => h (h (acc,dacc) (Thm.dest_arg1 t)) (Thm.dest_arg t) | Const(\<^const_name>\HOL.disj\,_)$_$_ => h (h (acc,dacc) (Thm.dest_arg1 t)) (Thm.dest_arg t) | Const (\<^const_name>\Not\,_)$_ => h (acc,dacc) (Thm.dest_arg t) | _ => (acc, dacc) val (cs,ds) = h ([],[]) p val l = Integer.lcms (union (op =) cs ds) fun cv k ct = let val (tm as b$s$t) = Thm.term_of ct in ((HOLogic.eq_const bT)$tm$(b$(linear_cmul k s)$(linear_cmul k t)) |> HOLogic.mk_Trueprop |> provelin ctxt) RS eq_reflection end fun nzprop x = let val th = Simplifier.rewrite (put_simpset lin_ss ctxt) (Thm.apply \<^cterm>\Trueprop\ (Thm.apply \<^cterm>\Not\ (Thm.apply (Thm.apply \<^cterm>\(=) :: int => _\ (Numeral.mk_cnumber \<^ctyp>\int\ x)) \<^cterm>\0::int\))) in Thm.equal_elim (Thm.symmetric th) TrueI end; val notz = let val tab = fold Inttab.update (ds ~~ (map (fn x => nzprop (l div x)) ds)) Inttab.empty in fn ct => the (Inttab.lookup tab (ct |> Thm.term_of |> dest_number)) handle Option.Option => (writeln ("noz: Theorems-Table contains no entry for " ^ Syntax.string_of_term ctxt (Thm.term_of ct)); raise Option.Option) end fun unit_conv t = case Thm.term_of t of Const(\<^const_name>\HOL.conj\,_)$_$_ => Conv.binop_conv unit_conv t | Const(\<^const_name>\HOL.disj\,_)$_$_ => Conv.binop_conv unit_conv t | Const (\<^const_name>\Not\,_)$_ => Conv.arg_conv unit_conv t | Const(s,_)$(Const(\<^const_name>\Groups.times\,_)$c$y)$ _ => if x=y andalso member (op =) [\<^const_name>\HOL.eq\, \<^const_name>\Orderings.less\, \<^const_name>\Orderings.less_eq\] s then cv (l div dest_number c) t else Thm.reflexive t | Const(s,_)$_$(Const(\<^const_name>\Groups.times\,_)$c$y) => if x=y andalso member (op =) [\<^const_name>\Orderings.less\, \<^const_name>\Orderings.less_eq\] s then cv (l div dest_number c) t else Thm.reflexive t | Const(\<^const_name>\Rings.dvd\,_)$d$(r as (Const(\<^const_name>\Groups.plus\,_)$(Const(\<^const_name>\Groups.times\,_)$c$y)$_)) => if x=y then let val k = l div dest_number c val kt = HOLogic.mk_number iT k val th1 = inst' [Thm.dest_arg1 t, Thm.dest_arg t] ((Thm.dest_arg t |> funpow 2 Thm.dest_arg1 |> notz) RS zdvd_mono) val (d',t') = (mulC$kt$d, mulC$kt$r) val thc = (provelin ctxt ((HOLogic.eq_const iT)$d'$(lint [] d') |> HOLogic.mk_Trueprop)) RS eq_reflection val tht = (provelin ctxt ((HOLogic.eq_const iT)$t'$(linear_cmul k r) |> HOLogic.mk_Trueprop)) RS eq_reflection in Thm.transitive th1 (Thm.combination (Drule.arg_cong_rule dvdc thc) tht) end else Thm.reflexive t | _ => Thm.reflexive t val uth = unit_conv p val clt = Numeral.mk_cnumber \<^ctyp>\int\ l val ltx = Thm.apply (Thm.apply cmulC clt) cx val th = Drule.arg_cong_rule e (Thm.abstract_rule (fst (dest_Free x )) cx uth) val th' = inst' [Thm.lambda ltx (Thm.rhs_of uth), clt] unity_coeff_ex val thf = Thm.transitive th (Thm.transitive (Thm.symmetric (Thm.beta_conversion true (Thm.cprop_of th' |> Thm.dest_arg1))) th') val (lth,rth) = Thm.dest_comb (Thm.cprop_of thf) |>> Thm.dest_arg |>> Thm.beta_conversion true ||> Thm.beta_conversion true |>> Thm.symmetric in Thm.transitive (Thm.transitive lth thf) rth end; val emptyIS = \<^cterm>\{}::int set\; val insert_tm = \<^cterm>\insert :: int => _\; fun mkISet cts = fold_rev (Thm.apply insert_tm #> Thm.apply) cts emptyIS; val eqelem_imp_imp = @{thm eqelem_imp_iff} RS iffD1; val [A_v,B_v] = map (fn th => Thm.cprop_of th |> funpow 2 Thm.dest_arg |> Thm.dest_abs NONE |> snd |> Thm.dest_arg1 |> Thm.dest_arg |> Thm.dest_abs NONE |> snd |> Thm.dest_fun |> Thm.dest_arg |> Thm.term_of |> dest_Var) [asetP, bsetP]; val D_v = (("D", 0), \<^typ>\int\); fun cooperex_conv ctxt vs q = let val uth = unify ctxt q val (x,p) = Thm.dest_abs NONE (Thm.dest_arg (Thm.rhs_of uth)) val ins = insert (op aconvc) fun h t (bacc,aacc,dacc) = case (whatis x t) of And (p,q) => h q (h p (bacc,aacc,dacc)) | Or (p,q) => h q (h p (bacc,aacc,dacc)) | Eq t => (ins (minus1 t) bacc, ins (plus1 t) aacc,dacc) | NEq t => (ins t bacc, ins t aacc, dacc) | Lt t => (bacc, ins t aacc, dacc) | Le t => (bacc, ins (plus1 t) aacc,dacc) | Gt t => (ins t bacc, aacc,dacc) | Ge t => (ins (minus1 t) bacc, aacc,dacc) | Dvd (d,_) => (bacc,aacc,insert (op =) (Thm.term_of d |> dest_number) dacc) | NDvd (d,_) => (bacc,aacc,insert (op =) (Thm.term_of d|> dest_number) dacc) | _ => (bacc, aacc, dacc) val (b0,a0,ds) = h p ([],[],[]) val d = Integer.lcms ds val cd = Numeral.mk_cnumber \<^ctyp>\int\ d fun divprop x = let val th = Simplifier.rewrite (put_simpset lin_ss ctxt) (Thm.apply \<^cterm>\Trueprop\ (Thm.apply (Thm.apply dvdc (Numeral.mk_cnumber \<^ctyp>\int\ x)) cd)) in Thm.equal_elim (Thm.symmetric th) TrueI end; val dvd = let val tab = fold Inttab.update (ds ~~ (map divprop ds)) Inttab.empty in fn ct => the (Inttab.lookup tab (Thm.term_of ct |> dest_number)) handle Option.Option => (writeln ("dvd: Theorems-Table contains no entry for" ^ Syntax.string_of_term ctxt (Thm.term_of ct)); raise Option.Option) end val dp = let val th = Simplifier.rewrite (put_simpset lin_ss ctxt) (Thm.apply \<^cterm>\Trueprop\ (Thm.apply (Thm.apply \<^cterm>\(<) :: int => _\ \<^cterm>\0::int\) cd)) in Thm.equal_elim (Thm.symmetric th) TrueI end; (* A and B set *) local val insI1 = Thm.instantiate' [SOME \<^ctyp>\int\] [] @{thm "insertI1"} val insI2 = Thm.instantiate' [SOME \<^ctyp>\int\] [] @{thm "insertI2"} in fun provein x S = case Thm.term_of S of Const(\<^const_name>\Orderings.bot\, _) => error "Unexpected error in Cooper, please email Amine Chaieb" | Const(\<^const_name>\insert\, _) $ y $ _ => let val (cy,S') = Thm.dest_binop S in if Thm.term_of x aconv y then Thm.instantiate' [] [SOME x, SOME S'] insI1 else Thm.implies_elim (Thm.instantiate' [] [SOME x, SOME S', SOME cy] insI2) (provein x S') end end val al = map (lint vs o Thm.term_of) a0 val bl = map (lint vs o Thm.term_of) b0 val (sl,s0,f,abths,cpth) = if length (distinct (op aconv) bl) <= length (distinct (op aconv) al) then (bl,b0,decomp_minf, fn B => (map (fn th => Thm.implies_elim (Thm.instantiate (TVars.empty, Vars.make [(B_v,B), (D_v,cd)]) th) dp) [bseteq,bsetneq,bsetlt, bsetle, bsetgt,bsetge])@ (map (Thm.instantiate (TVars.empty, Vars.make [(B_v,B), (D_v,cd)])) [bsetdvd,bsetndvd,bsetP,infDdvd, infDndvd,bsetconj, bsetdisj,infDconj, infDdisj]), cpmi) else (al,a0,decomp_pinf,fn A => (map (fn th => Thm.implies_elim (Thm.instantiate (TVars.empty, Vars.make [(A_v,A), (D_v,cd)]) th) dp) [aseteq,asetneq,asetlt, asetle, asetgt,asetge])@ (map (Thm.instantiate (TVars.empty, Vars.make [(A_v,A), (D_v,cd)])) [asetdvd,asetndvd, asetP, infDdvd, infDndvd,asetconj, asetdisj,infDconj, infDdisj]),cppi) val cpth = let val sths = map (fn (tl,t0) => if tl = Thm.term_of t0 then Thm.instantiate' [SOME \<^ctyp>\int\] [SOME t0] refl else provelin ctxt ((HOLogic.eq_const iT)$tl$(Thm.term_of t0) |> HOLogic.mk_Trueprop)) (sl ~~ s0) val csl = distinct (op aconvc) (map (Thm.cprop_of #> Thm.dest_arg #> Thm.dest_arg1) sths) val S = mkISet csl val inStab = fold (fn ct => fn tab => Termtab.update (Thm.term_of ct, provein ct S) tab) csl Termtab.empty val eqelem_th = Thm.instantiate' [SOME \<^ctyp>\int\] [NONE,NONE, SOME S] eqelem_imp_imp val inS = let val tab = fold Termtab.update (map (fn eq => let val (s,t) = Thm.cprop_of eq |> Thm.dest_arg |> Thm.dest_binop val th = if s aconvc t then the (Termtab.lookup inStab (Thm.term_of s)) else FWD (Thm.instantiate' [] [SOME s, SOME t] eqelem_th) [eq, the (Termtab.lookup inStab (Thm.term_of s))] in (Thm.term_of t, th) end) sths) Termtab.empty in fn ct => the (Termtab.lookup tab (Thm.term_of ct)) handle Option.Option => (writeln ("inS: No theorem for " ^ Syntax.string_of_term ctxt (Thm.term_of ct)); raise Option.Option) end val (inf, nb, pd) = divide_and_conquer (f x dvd inS (abths S)) p in [dp, inf, nb, pd] MRS cpth end val cpth' = Thm.transitive uth (cpth RS eq_reflection) in Thm.transitive cpth' ((simp_thms_conv ctxt then_conv eval_conv ctxt) (Thm.rhs_of cpth')) end; fun literals_conv bops uops env cv = let fun h t = case Thm.term_of t of b$_$_ => if member (op aconv) bops b then Conv.binop_conv h t else cv env t | u$_ => if member (op aconv) uops u then Conv.arg_conv h t else cv env t | _ => cv env t in h end; fun integer_nnf_conv ctxt env = nnf_conv ctxt then_conv literals_conv [HOLogic.conj, HOLogic.disj] [] env (linearize_conv ctxt); val conv_ss = simpset_of (put_simpset HOL_basic_ss \<^context> addsimps (@{thms simp_thms} @ take 4 @{thms ex_simps} @ [not_all, all_not_ex, @{thm ex_disj_distrib}])); fun conv ctxt p = Qelim.gen_qelim_conv ctxt (Simplifier.rewrite (put_simpset conv_ss ctxt)) (Simplifier.rewrite (put_simpset presburger_ss ctxt)) (Simplifier.rewrite (put_simpset conv_ss ctxt)) (cons o Thm.term_of) (Misc_Legacy.term_frees (Thm.term_of p)) (linearize_conv ctxt) (integer_nnf_conv ctxt) (cooperex_conv ctxt) p handle CTERM _ => raise COOPER "bad cterm" | THM _ => raise COOPER "bad thm" | TYPE _ => raise COOPER "bad type" fun add_bools t = let val ops = [\<^term>\(=) :: int => _\, \<^term>\(<) :: int => _\, \<^term>\(<=) :: int => _\, \<^term>\HOL.conj\, \<^term>\HOL.disj\, \<^term>\HOL.implies\, \<^term>\(=) :: bool => _\, \<^term>\Not\, \<^term>\All :: (int => _) => _\, \<^term>\Ex :: (int => _) => _\, \<^term>\True\, \<^term>\False\]; val is_op = member (op =) ops; val skip = not (fastype_of t = HOLogic.boolT) in case t of (l as f $ a) $ b => if skip orelse is_op f then add_bools b o add_bools l else insert (op aconv) t | f $ a => if skip orelse is_op f then add_bools a o add_bools f else insert (op aconv) t - | Abs p => add_bools (snd (Syntax_Trans.variant_abs p)) (* FIXME !? *) + | Abs p => add_bools (snd (Term.dest_abs p)) | _ => if skip orelse is_op t then I else insert (op aconv) t end; fun descend vs (abs as (_, xT, _)) = - let - val (xn', p') = Syntax_Trans.variant_abs abs; (* FIXME !? *) + let val (xn', p') = Term.dest_abs abs in ((xn', xT) :: vs, p') end; local structure Proc = Cooper_Procedure in fun num_of_term vs (Free vT) = Proc.Bound (Proc.nat_of_integer (find_index (fn vT' => vT' = vT) vs)) | num_of_term vs (Term.Bound i) = Proc.Bound (Proc.nat_of_integer i) | num_of_term vs \<^term>\0::int\ = Proc.C (Proc.Int_of_integer 0) | num_of_term vs \<^term>\1::int\ = Proc.C (Proc.Int_of_integer 1) | num_of_term vs (t as Const (\<^const_name>\numeral\, _) $ _) = Proc.C (Proc.Int_of_integer (dest_number t)) | num_of_term vs (Const (\<^const_name>\Groups.uminus\, _) $ t') = Proc.Neg (num_of_term vs t') | num_of_term vs (Const (\<^const_name>\Groups.plus\, _) $ t1 $ t2) = Proc.Add (num_of_term vs t1, num_of_term vs t2) | num_of_term vs (Const (\<^const_name>\Groups.minus\, _) $ t1 $ t2) = Proc.Sub (num_of_term vs t1, num_of_term vs t2) | num_of_term vs (Const (\<^const_name>\Groups.times\, _) $ t1 $ t2) = (case perhaps_number t1 of SOME n => Proc.Mul (Proc.Int_of_integer n, num_of_term vs t2) | NONE => (case perhaps_number t2 of SOME n => Proc.Mul (Proc.Int_of_integer n, num_of_term vs t1) | NONE => raise COOPER "reification: unsupported kind of multiplication")) | num_of_term _ _ = raise COOPER "reification: bad term"; fun fm_of_term ps vs (Const (\<^const_name>\True\, _)) = Proc.T | fm_of_term ps vs (Const (\<^const_name>\False\, _)) = Proc.F | fm_of_term ps vs (Const (\<^const_name>\HOL.conj\, _) $ t1 $ t2) = Proc.And (fm_of_term ps vs t1, fm_of_term ps vs t2) | fm_of_term ps vs (Const (\<^const_name>\HOL.disj\, _) $ t1 $ t2) = Proc.Or (fm_of_term ps vs t1, fm_of_term ps vs t2) | fm_of_term ps vs (Const (\<^const_name>\HOL.implies\, _) $ t1 $ t2) = Proc.Imp (fm_of_term ps vs t1, fm_of_term ps vs t2) | fm_of_term ps vs (\<^term>\(=) :: bool => _ \ $ t1 $ t2) = Proc.Iff (fm_of_term ps vs t1, fm_of_term ps vs t2) | fm_of_term ps vs (Const (\<^const_name>\Not\, _) $ t') = Proc.NOT (fm_of_term ps vs t') | fm_of_term ps vs (Const (\<^const_name>\Ex\, _) $ Abs abs) = Proc.E (uncurry (fm_of_term ps) (descend vs abs)) | fm_of_term ps vs (Const (\<^const_name>\All\, _) $ Abs abs) = Proc.A (uncurry (fm_of_term ps) (descend vs abs)) | fm_of_term ps vs (\<^term>\(=) :: int => _\ $ t1 $ t2) = Proc.Eq (Proc.Sub (num_of_term vs t1, num_of_term vs t2)) | fm_of_term ps vs (Const (\<^const_name>\Orderings.less_eq\, _) $ t1 $ t2) = Proc.Le (Proc.Sub (num_of_term vs t1, num_of_term vs t2)) | fm_of_term ps vs (Const (\<^const_name>\Orderings.less\, _) $ t1 $ t2) = Proc.Lt (Proc.Sub (num_of_term vs t1, num_of_term vs t2)) | fm_of_term ps vs (Const (\<^const_name>\Rings.dvd\, _) $ t1 $ t2) = (case perhaps_number t1 of SOME n => Proc.Dvd (Proc.Int_of_integer n, num_of_term vs t2) | NONE => raise COOPER "reification: unsupported dvd") | fm_of_term ps vs t = let val n = find_index (fn t' => t aconv t') ps in if n > 0 then Proc.Closed (Proc.nat_of_integer n) else raise COOPER "reification: unknown term" end; fun term_of_num vs (Proc.C i) = HOLogic.mk_number HOLogic.intT (Proc.integer_of_int i) | term_of_num vs (Proc.Bound n) = Free (nth vs (Proc.integer_of_nat n)) | term_of_num vs (Proc.Neg t') = \<^term>\uminus :: int => _\ $ term_of_num vs t' | term_of_num vs (Proc.Add (t1, t2)) = \<^term>\(+) :: int => _\ $ term_of_num vs t1 $ term_of_num vs t2 | term_of_num vs (Proc.Sub (t1, t2)) = \<^term>\(-) :: int => _\ $ term_of_num vs t1 $ term_of_num vs t2 | term_of_num vs (Proc.Mul (i, t2)) = \<^term>\(*) :: int => _\ $ HOLogic.mk_number HOLogic.intT (Proc.integer_of_int i) $ term_of_num vs t2 | term_of_num vs (Proc.CN (n, i, t')) = term_of_num vs (Proc.Add (Proc.Mul (i, Proc.Bound n), t')); fun term_of_fm ps vs Proc.T = \<^term>\True\ | term_of_fm ps vs Proc.F = \<^term>\False\ | term_of_fm ps vs (Proc.And (t1, t2)) = HOLogic.conj $ term_of_fm ps vs t1 $ term_of_fm ps vs t2 | term_of_fm ps vs (Proc.Or (t1, t2)) = HOLogic.disj $ term_of_fm ps vs t1 $ term_of_fm ps vs t2 | term_of_fm ps vs (Proc.Imp (t1, t2)) = HOLogic.imp $ term_of_fm ps vs t1 $ term_of_fm ps vs t2 | term_of_fm ps vs (Proc.Iff (t1, t2)) = \<^term>\(=) :: bool => _\ $ term_of_fm ps vs t1 $ term_of_fm ps vs t2 | term_of_fm ps vs (Proc.NOT t') = HOLogic.Not $ term_of_fm ps vs t' | term_of_fm ps vs (Proc.Eq t') = \<^term>\(=) :: int => _ \ $ term_of_num vs t'$ \<^term>\0::int\ | term_of_fm ps vs (Proc.NEq t') = term_of_fm ps vs (Proc.NOT (Proc.Eq t')) | term_of_fm ps vs (Proc.Lt t') = \<^term>\(<) :: int => _ \ $ term_of_num vs t' $ \<^term>\0::int\ | term_of_fm ps vs (Proc.Le t') = \<^term>\(<=) :: int => _ \ $ term_of_num vs t' $ \<^term>\0::int\ | term_of_fm ps vs (Proc.Gt t') = \<^term>\(<) :: int => _ \ $ \<^term>\0::int\ $ term_of_num vs t' | term_of_fm ps vs (Proc.Ge t') = \<^term>\(<=) :: int => _ \ $ \<^term>\0::int\ $ term_of_num vs t' | term_of_fm ps vs (Proc.Dvd (i, t')) = \<^term>\(dvd) :: int => _ \ $ HOLogic.mk_number HOLogic.intT (Proc.integer_of_int i) $ term_of_num vs t' | term_of_fm ps vs (Proc.NDvd (i, t')) = term_of_fm ps vs (Proc.NOT (Proc.Dvd (i, t'))) | term_of_fm ps vs (Proc.Closed n) = nth ps (Proc.integer_of_nat n) | term_of_fm ps vs (Proc.NClosed n) = term_of_fm ps vs (Proc.NOT (Proc.Closed n)); fun procedure t = let val vs = Term.add_frees t []; val ps = add_bools t []; in (term_of_fm ps vs o Proc.pa o fm_of_term ps vs) t end; end; val (_, oracle) = Context.>>> (Context.map_theory_result (Thm.add_oracle (\<^binding>\cooper\, (fn (ctxt, t) => (Thm.cterm_of ctxt o Logic.mk_equals o apply2 HOLogic.mk_Trueprop) (t, procedure t))))); val comp_ss = simpset_of (put_simpset HOL_ss \<^context> addsimps @{thms semiring_norm}); fun strip_objimp ct = (case Thm.term_of ct of Const (\<^const_name>\HOL.implies\, _) $ _ $ _ => let val (A, B) = Thm.dest_binop ct in A :: strip_objimp B end | _ => [ct]); fun strip_objall ct = case Thm.term_of ct of Const (\<^const_name>\All\, _) $ Abs (xn,_,_) => let val (a,(v,t')) = (apsnd (Thm.dest_abs (SOME xn)) o Thm.dest_comb) ct in apfst (cons (a,v)) (strip_objall t') end | _ => ([],ct); local val all_maxscope_ss = simpset_of (put_simpset HOL_basic_ss \<^context> addsimps map (fn th => th RS sym) @{thms "all_simps"}) in fun thin_prems_tac ctxt P = simp_tac (put_simpset all_maxscope_ss ctxt) THEN' CSUBGOAL (fn (p', i) => let val (qvs, p) = strip_objall (Thm.dest_arg p') val (ps, c) = split_last (strip_objimp p) val qs = filter P ps val q = if P c then c else \<^cterm>\False\ val ng = fold_rev (fn (a,v) => fn t => Thm.apply a (Thm.lambda v t)) qvs (fold_rev (fn p => fn q => Thm.apply (Thm.apply \<^cterm>\HOL.implies\ p) q) qs q) val g = Thm.apply (Thm.apply \<^cterm>\(==>)\ (Thm.apply \<^cterm>\Trueprop\ ng)) p' val ntac = (case qs of [] => q aconvc \<^cterm>\False\ | _ => false) in if ntac then no_tac else (case \<^try>\Goal.prove_internal ctxt [] g (K (blast_tac (put_claset HOL_cs ctxt) 1))\ of NONE => no_tac | SOME r => resolve_tac ctxt [r] i) end) end; local fun isnum t = case t of Const(\<^const_name>\Groups.zero\,_) => true | Const(\<^const_name>\Groups.one\,_) => true | \<^term>\Suc\$s => isnum s | \<^term>\nat\$s => isnum s | \<^term>\int\$s => isnum s | Const(\<^const_name>\Groups.uminus\,_)$s => isnum s | Const(\<^const_name>\Groups.plus\,_)$l$r => isnum l andalso isnum r | Const(\<^const_name>\Groups.times\,_)$l$r => isnum l andalso isnum r | Const(\<^const_name>\Groups.minus\,_)$l$r => isnum l andalso isnum r | Const(\<^const_name>\Power.power\,_)$l$r => isnum l andalso isnum r | Const(\<^const_name>\Rings.modulo\,_)$l$r => isnum l andalso isnum r | Const(\<^const_name>\Rings.divide\,_)$l$r => isnum l andalso isnum r | _ => is_number t orelse can HOLogic.dest_nat t fun ty cts t = if not (member (op =) [HOLogic.intT, HOLogic.natT, HOLogic.boolT] (Thm.typ_of_cterm t)) then false else case Thm.term_of t of c$l$r => if member (op =) [\<^term>\(*)::int => _\, \<^term>\(*)::nat => _\] c then not (isnum l orelse isnum r) else not (member (op aconv) cts c) | c$_ => not (member (op aconv) cts c) | c => not (member (op aconv) cts c) val term_constants = let fun h acc t = case t of Const _ => insert (op aconv) t acc | a$b => h (h acc a) b | Abs (_,_,t) => h acc t | _ => acc in h [] end; in fun is_relevant ctxt ct = subset (op aconv) (term_constants (Thm.term_of ct), snd (get ctxt)) andalso forall (fn Free (_, T) => member (op =) [\<^typ>\int\, \<^typ>\nat\] T) (Misc_Legacy.term_frees (Thm.term_of ct)) andalso forall (fn Var (_, T) => member (op =) [\<^typ>\int\, \<^typ>\nat\] T) (Misc_Legacy.term_vars (Thm.term_of ct)); fun int_nat_terms ctxt ct = let val cts = snd (get ctxt) fun h acc t = if ty cts t then insert (op aconvc) t acc else case Thm.term_of t of _$_ => h (h acc (Thm.dest_arg t)) (Thm.dest_fun t) | Abs(_,_,_) => Thm.dest_abs NONE t ||> h acc |> uncurry (remove (op aconvc)) | _ => acc in h [] ct end end; fun generalize_tac ctxt f = CSUBGOAL (fn (p, _) => PRIMITIVE (fn st => let fun all x t = Thm.apply (Thm.cterm_of ctxt (Logic.all_const (Thm.typ_of_cterm x))) (Thm.lambda x t) val ts = sort Thm.fast_term_ord (f p) val p' = fold_rev all ts p in Thm.implies_intr p' (Thm.implies_elim st (fold Thm.forall_elim ts (Thm.assume p'))) end)); local val ss1 = simpset_of (put_simpset comp_ss \<^context> addsimps @{thms simp_thms} @ [@{thm "nat_numeral"} RS sym, @{thm int_dvd_int_iff [symmetric]}, @{thm "of_nat_add"}, @{thm "of_nat_mult"}] @ map (fn r => r RS sym) [@{thm "int_int_eq"}, @{thm "zle_int"}, @{thm "of_nat_less_iff" [where ?'a = int]}] |> Splitter.add_split @{thm "zdiff_int_split"}) val ss2 = simpset_of (put_simpset HOL_basic_ss \<^context> addsimps [@{thm "nat_0_le"}, @{thm "of_nat_numeral"}, @{thm "all_nat"}, @{thm "ex_nat"}, @{thm "zero_le_numeral"}, @{thm "le_numeral_extra"(3)}, @{thm "of_nat_0"}, @{thm "of_nat_1"}, @{thm "Suc_eq_plus1"}] |> fold Simplifier.add_cong [@{thm "conj_le_cong"}, @{thm "imp_le_cong"}]) val div_mod_ss = simpset_of (put_simpset HOL_basic_ss \<^context> addsimps @{thms simp_thms mod_eq_0_iff_dvd mod_add_left_eq mod_add_right_eq mod_add_eq div_add1_eq [symmetric] div_add1_eq [symmetric] mod_self mod_by_0 div_by_0 div_0 mod_0 div_by_1 mod_by_1 div_by_Suc_0 mod_by_Suc_0 Suc_eq_plus1 ac_simps} addsimprocs [\<^simproc>\cancel_div_mod_nat\, \<^simproc>\cancel_div_mod_int\]) val splits_ss = simpset_of (put_simpset comp_ss \<^context> addsimps [@{thm minus_div_mult_eq_mod [symmetric]}] |> fold Splitter.add_split [@{thm "split_zdiv"}, @{thm "split_zmod"}, @{thm "split_div'"}, @{thm "split_min"}, @{thm "split_max"}, @{thm "abs_split"}]) in fun nat_to_int_tac ctxt = simp_tac (put_simpset ss1 ctxt) THEN_ALL_NEW simp_tac (put_simpset ss2 ctxt) THEN_ALL_NEW simp_tac (put_simpset comp_ss ctxt); fun div_mod_tac ctxt = simp_tac (put_simpset div_mod_ss ctxt); fun splits_tac ctxt = simp_tac (put_simpset splits_ss ctxt); end; fun core_tac ctxt = CSUBGOAL (fn (p, i) => let val cpth = if Config.get ctxt quick_and_dirty then oracle (ctxt, Envir.beta_norm (Envir.eta_long [] (Thm.term_of (Thm.dest_arg p)))) else Conv.arg_conv (conv ctxt) p val p' = Thm.rhs_of cpth val th = Thm.implies_intr p' (Thm.equal_elim (Thm.symmetric cpth) (Thm.assume p')) in resolve_tac ctxt [th] i end handle COOPER _ => no_tac); fun finish_tac ctxt q = SUBGOAL (fn (_, i) => (if q then I else TRY) (resolve_tac ctxt [TrueI] i)); fun tac elim add_ths del_ths = Subgoal.FOCUS_PARAMS (fn {context = ctxt, ...} => let val simpset_ctxt = put_simpset (fst (get ctxt)) ctxt delsimps del_ths addsimps add_ths in Method.insert_tac ctxt (rev (Named_Theorems.get ctxt \<^named_theorems>\arith\)) THEN_ALL_NEW Object_Logic.full_atomize_tac ctxt THEN_ALL_NEW CONVERSION Thm.eta_long_conversion THEN_ALL_NEW simp_tac simpset_ctxt THEN_ALL_NEW (TRY o generalize_tac ctxt (int_nat_terms ctxt)) THEN_ALL_NEW Object_Logic.full_atomize_tac ctxt THEN_ALL_NEW (thin_prems_tac ctxt (is_relevant ctxt)) THEN_ALL_NEW Object_Logic.full_atomize_tac ctxt THEN_ALL_NEW div_mod_tac ctxt THEN_ALL_NEW splits_tac ctxt THEN_ALL_NEW simp_tac simpset_ctxt THEN_ALL_NEW CONVERSION Thm.eta_long_conversion THEN_ALL_NEW nat_to_int_tac ctxt THEN_ALL_NEW core_tac ctxt THEN_ALL_NEW finish_tac ctxt elim end 1); (* attribute syntax *) local fun keyword k = Scan.lift (Args.$$$ k -- Args.colon) >> K (); val constsN = "consts"; val any_keyword = keyword constsN val thms = Scan.repeats (Scan.unless any_keyword Attrib.multi_thm); val terms = thms >> map (Thm.term_of o Drule.dest_term); fun optional scan = Scan.optional scan []; in val _ = Theory.setup (Attrib.setup \<^binding>\presburger\ ((Scan.lift (Args.$$$ "del") |-- optional (keyword constsN |-- terms)) >> del || optional (keyword constsN |-- terms) >> add) "data for Cooper's algorithm" #> Arith_Data.add_tactic "Presburger arithmetic" (tac true [] [])); end; end; diff --git a/src/HOL/Tools/reification.ML b/src/HOL/Tools/reification.ML --- a/src/HOL/Tools/reification.ML +++ b/src/HOL/Tools/reification.ML @@ -1,299 +1,299 @@ (* Title: HOL/Tools/reification.ML Author: Amine Chaieb, TU Muenchen A trial for automatical reification. *) signature REIFICATION = sig val conv: Proof.context -> thm list -> conv val tac: Proof.context -> thm list -> term option -> int -> tactic val lift_conv: Proof.context -> conv -> term option -> int -> tactic val dereify: Proof.context -> thm list -> conv end; structure Reification : REIFICATION = struct fun dest_listT (Type (\<^type_name>\list\, [T])) = T; val FWD = curry (op OF); fun rewrite_with ctxt eqs = Simplifier.rewrite (put_simpset HOL_basic_ss ctxt addsimps eqs); val pure_subst = @{lemma "x == y ==> PROP P y ==> PROP P x" by simp} fun lift_conv ctxt conv some_t = Subgoal.FOCUS (fn {context = ctxt', concl, ...} => let val ct = (case some_t of NONE => Thm.dest_arg concl | SOME t => Thm.cterm_of ctxt' t) val thm = conv ct; in if Thm.is_reflexive thm then no_tac else ALLGOALS (resolve_tac ctxt [pure_subst OF [thm]]) end) ctxt; (* Make a congruence rule out of a defining equation for the interpretation th is one defining equation of f, i.e. th is "f (Cp ?t1 ... ?tn) = P(f ?t1, .., f ?tn)" Cp is a constructor pattern and P is a pattern The result is: [|?A1 = f ?t1 ; .. ; ?An= f ?tn |] ==> P (?A1, .., ?An) = f (Cp ?t1 .. ?tn) + the a list of names of the A1 .. An, Those are fresh in the ctxt *) fun mk_congeq ctxt fs th = let val Const (fN, _) = th |> Thm.prop_of |> HOLogic.dest_Trueprop |> HOLogic.dest_eq |> fst |> strip_comb |> fst; val ((_, [th']), ctxt') = Variable.import true [th] ctxt; val (lhs, rhs) = HOLogic.dest_eq (HOLogic.dest_Trueprop (Thm.prop_of th')); fun add_fterms (t as t1 $ t2) = if exists (fn f => Term.could_unify (t |> strip_comb |> fst, f)) fs then insert (op aconv) t else add_fterms t1 #> add_fterms t2 | add_fterms (t as Abs _) = if exists_Const (fn (c, _) => c = fN) t then K [t] else K [] | add_fterms _ = I; val fterms = add_fterms rhs []; val (xs, ctxt'') = Variable.variant_fixes (replicate (length fterms) "x") ctxt'; val tys = map fastype_of fterms; val vs = map Free (xs ~~ tys); val env = fterms ~~ vs; (*FIXME*) fun replace_fterms (t as t1 $ t2) = (case AList.lookup (op aconv) env t of SOME v => v | NONE => replace_fterms t1 $ replace_fterms t2) | replace_fterms t = (case AList.lookup (op aconv) env t of SOME v => v | NONE => t); fun mk_def (Abs (x, xT, t), v) = HOLogic.mk_Trueprop (HOLogic.all_const xT $ Abs (x, xT, HOLogic.mk_eq (v $ Bound 0, t))) | mk_def (t, v) = HOLogic.mk_Trueprop (HOLogic.mk_eq (v, t)); fun tryext x = (x RS @{lemma "(\x. f x = g x) \ f = g" by blast} handle THM _ => x); val cong = (Goal.prove ctxt'' [] (map mk_def env) (HOLogic.mk_Trueprop (HOLogic.mk_eq (lhs, replace_fterms rhs))) (fn {context, prems, ...} => Local_Defs.unfold0_tac context (map tryext prems) THEN resolve_tac ctxt'' [th'] 1)) RS sym; val (cong' :: vars') = Variable.export ctxt'' ctxt (cong :: map (Drule.mk_term o Thm.cterm_of ctxt'') vs); val vs' = map (fst o fst o Term.dest_Var o Thm.term_of o Drule.dest_term) vars'; in (vs', cong') end; (* congs is a list of pairs (P,th) where th is a theorem for [| f p1 = A1; ...; f pn = An|] ==> f (C p1 .. pn) = P *) fun rearrange congs = let fun P (_, th) = let val \<^term>\Trueprop\ $ (Const (\<^const_name>\HOL.eq\, _) $ l $ _) = Thm.concl_of th in can dest_Var l end; val (yes, no) = List.partition P congs; in no @ yes end; fun dereify ctxt eqs = rewrite_with ctxt (eqs @ @{thms nth_Cons_0 nth_Cons_Suc}); fun index_of t bds = let val tt = HOLogic.listT (fastype_of t); in (case AList.lookup Type.could_unify bds tt of NONE => error "index_of: type not found in environements!" | SOME (tbs, tats) => let val i = find_index (fn t' => t' = t) tats; val j = find_index (fn t' => t' = t) tbs; in if j = ~1 then if i = ~1 then (length tbs + length tats, AList.update Type.could_unify (tt, (tbs, tats @ [t])) bds) else (i, bds) else (j, bds) end) end; (* Generic decomp for reification : matches the actual term with the rhs of one cong rule. The result of the matching guides the proof synthesis: The matches of the introduced Variables A1 .. An are processed recursively The rest is instantiated in the cong rule,i.e. no reification is needed *) (* da is the decomposition for atoms, ie. it returns ([],g) where g returns the right instance f (AtC n) = t , where AtC is the Atoms constructor and n is the number of the atom corresponding to t *) fun decomp_reify da cgns (ct, ctxt) bds = let val thy = Proof_Context.theory_of ctxt; fun tryabsdecomp (ct, ctxt) bds = (case Thm.term_of ct of Abs (_, xT, ta) => let val ([raw_xn], ctxt') = Variable.variant_fixes ["x"] ctxt; - val (xn, ta) = Syntax_Trans.variant_abs (raw_xn, xT, ta); (* FIXME !? *) + val (xn, ta) = Term.dest_abs (raw_xn, xT, ta); val x = Free (xn, xT); val cx = Thm.cterm_of ctxt' x; val cta = Thm.cterm_of ctxt' ta; val bds = (case AList.lookup Type.could_unify bds (HOLogic.listT xT) of NONE => error "tryabsdecomp: Type not found in the Environement" | SOME (bsT, atsT) => AList.update Type.could_unify (HOLogic.listT xT, (x :: bsT, atsT)) bds); in (([(cta, ctxt')], fn ([th], bds) => (hd (Variable.export ctxt' ctxt [(Thm.forall_intr cx th) COMP allI]), let val (bsT, asT) = the (AList.lookup Type.could_unify bds (HOLogic.listT xT)); in AList.update Type.could_unify (HOLogic.listT xT, (tl bsT, asT)) bds end)), bds) end | _ => da (ct, ctxt) bds) in (case cgns of [] => tryabsdecomp (ct, ctxt) bds | ((vns, cong) :: congs) => (let val (tyenv, tmenv) = Pattern.match thy ((fst o HOLogic.dest_eq o HOLogic.dest_Trueprop) (Thm.concl_of cong), Thm.term_of ct) (Vartab.empty, Vartab.empty); val (fnvs, invs) = List.partition (fn ((vn, _),_) => member (op =) vns vn) (Vartab.dest tmenv); val (fts, its) = (map (snd o snd) fnvs, map (fn ((vn, vi), (tT, t)) => (((vn, vi), tT), Thm.cterm_of ctxt t)) invs); val ctyenv = map (fn ((vn, vi), (s, ty)) => (((vn, vi), s), Thm.ctyp_of ctxt ty)) (Vartab.dest tyenv); in ((map (Thm.cterm_of ctxt) fts ~~ replicate (length fts) ctxt, apfst (FWD (Drule.instantiate_normalize (TVars.make ctyenv, Vars.make its) cong))), bds) end handle Pattern.MATCH => decomp_reify da congs (ct, ctxt) bds)) end; fun get_nths (t as (Const (\<^const_name>\List.nth\, _) $ vs $ n)) = AList.update (op aconv) (t, (vs, n)) | get_nths (t1 $ t2) = get_nths t1 #> get_nths t2 | get_nths (Abs (_, _, t')) = get_nths t' | get_nths _ = I; fun tryeqs [] (ct, ctxt) bds = error "Cannot find the atoms equation" | tryeqs (eq :: eqs) (ct, ctxt) bds = (( let val rhs = eq |> Thm.prop_of |> HOLogic.dest_Trueprop |> HOLogic.dest_eq |> snd; val nths = get_nths rhs []; val (vss, _) = fold_rev (fn (_, (vs, n)) => fn (vss, ns) => (insert (op aconv) vs vss, insert (op aconv) n ns)) nths ([], []); val (vsns, ctxt') = Variable.variant_fixes (replicate (length vss) "vs") ctxt; val (xns, ctxt'') = Variable.variant_fixes (replicate (length nths) "x") ctxt'; val thy = Proof_Context.theory_of ctxt''; val vsns_map = vss ~~ vsns; val xns_map = fst (split_list nths) ~~ xns; val subst = map (fn (nt, xn) => (nt, Var ((xn, 0), fastype_of nt))) xns_map; val rhs_P = subst_free subst rhs; val (tyenv, tmenv) = Pattern.match thy (rhs_P, Thm.term_of ct) (Vartab.empty, Vartab.empty); val sbst = Envir.subst_term (tyenv, tmenv); val sbsT = Envir.subst_type tyenv; val subst_ty = map (fn (n, (s, t)) => ((n, s), Thm.ctyp_of ctxt'' t)) (Vartab.dest tyenv) val tml = Vartab.dest tmenv; val (subst_ns, bds) = fold_map (fn (Const _ $ _ $ n, Var (xn0, _)) => fn bds => let val name = snd (the (AList.lookup (op =) tml xn0)); val (idx, bds) = index_of name bds; in (apply2 (Thm.cterm_of ctxt'') (n, idx |> HOLogic.mk_nat), bds) end) subst bds; val subst_vs = let fun h (Const _ $ (vs as Var (_, lT)) $ _, Var (_, T)) = let val cns = sbst (Const (\<^const_name>\List.Cons\, T --> lT --> lT)); val lT' = sbsT lT; val (bsT, _) = the (AList.lookup Type.could_unify bds lT); val vsn = the (AList.lookup (op =) vsns_map vs); val vs' = fold_rev (fn x => fn xs => cns $ x $xs) bsT (Free (vsn, lT')); in apply2 (Thm.cterm_of ctxt'') (vs, vs') end; in map h subst end; val cts = map (fn ((vn, vi), (tT, t)) => apply2 (Thm.cterm_of ctxt'') (Var ((vn, vi), tT), t)) (fold (AList.delete (fn (((a : string), _), (b, _)) => a = b)) (map (fn n => (n, 0)) xns) tml); val substt = let val ih = Drule.cterm_rule (Thm.instantiate (TVars.make subst_ty, Vars.empty)); in map (apply2 ih) (subst_ns @ subst_vs @ cts) end; val th = (Drule.instantiate_normalize (TVars.make subst_ty, Vars.make (map (apfst (dest_Var o Thm.term_of)) substt)) eq) RS sym; in (hd (Variable.export ctxt'' ctxt [th]), bds) end) handle Pattern.MATCH => tryeqs eqs (ct, ctxt) bds); (* looks for the atoms equation and instantiates it with the right number *) fun mk_decompatom eqs (ct, ctxt) bds = (([], fn (_, bds) => let val tT = fastype_of (Thm.term_of ct); fun isat eq = let val rhs = eq |> Thm.prop_of |> HOLogic.dest_Trueprop |> HOLogic.dest_eq |> snd; in exists_Const (fn (n, ty) => n = \<^const_name>\List.nth\ andalso AList.defined Type.could_unify bds (domain_type ty)) rhs andalso Type.could_unify (fastype_of rhs, tT) end; in tryeqs (filter isat eqs) (ct, ctxt) bds end), bds); (* Generic reification procedure: *) (* creates all needed cong rules and then just uses the theorem synthesis *) fun mk_congs ctxt eqs = let val fs = fold_rev (fn eq => insert (op =) (eq |> Thm.prop_of |> HOLogic.dest_Trueprop |> HOLogic.dest_eq |> fst |> strip_comb |> fst)) eqs []; val tys = fold_rev (fn f => fold (insert (op =)) (f |> fastype_of |> binder_types |> tl)) fs []; val (vs, ctxt') = Variable.variant_fixes (replicate (length tys) "vs") ctxt; val subst = the o AList.lookup (op =) (map2 (fn T => fn v => (T, Thm.cterm_of ctxt' (Free (v, T)))) tys vs); fun prep_eq eq = let val (_, _ :: vs) = eq |> Thm.prop_of |> HOLogic.dest_Trueprop |> HOLogic.dest_eq |> fst |> strip_comb; val subst = map_filter (fn Var v => SOME (v, subst (#2 v)) | _ => NONE) vs; in Thm.instantiate (TVars.empty, Vars.make subst) eq end; val (ps, congs) = map_split (mk_congeq ctxt' fs o prep_eq) eqs; val bds = AList.make (K ([], [])) tys; in (ps ~~ Variable.export ctxt' ctxt congs, bds) end fun conv ctxt eqs ct = let val (congs, bds) = mk_congs ctxt eqs; val congs = rearrange congs; val (th, bds') = apfst mk_eq (divide_and_conquer' (decomp_reify (mk_decompatom eqs) congs) (ct, ctxt) bds); fun is_list_var (Var (_, t)) = can dest_listT t | is_list_var _ = false; val vars = th |> Thm.prop_of |> Logic.dest_equals |> snd |> strip_comb |> snd |> filter is_list_var; val vs = map (fn Var (v as (_, T)) => (v, the (AList.lookup Type.could_unify bds' T) |> snd |> HOLogic.mk_list (dest_listT T))) vars; val th' = Drule.instantiate_normalize (TVars.empty, Vars.make (map (apsnd (Thm.cterm_of ctxt)) vs)) th; val th'' = Thm.symmetric (dereify ctxt [] (Thm.lhs_of th')); in Thm.transitive th'' th' end; fun tac ctxt eqs = lift_conv ctxt (conv ctxt eqs); end; diff --git a/src/Tools/misc_legacy.ML b/src/Tools/misc_legacy.ML --- a/src/Tools/misc_legacy.ML +++ b/src/Tools/misc_legacy.ML @@ -1,256 +1,256 @@ (* Title: Tools/misc_legacy.ML Misc legacy stuff -- to be phased out eventually. *) signature MISC_LEGACY = sig val add_term_names: term * string list -> string list val add_term_tvars: term * (indexname * sort) list -> (indexname * sort) list val add_term_tfrees: term * (string * sort) list -> (string * sort) list val typ_tvars: typ -> (indexname * sort) list val term_tfrees: term -> (string * sort) list val term_tvars: term -> (indexname * sort) list val add_term_vars: term * term list -> term list val term_vars: term -> term list val add_term_frees: term * term list -> term list val term_frees: term -> term list val mk_defpair: term * term -> string * term val get_def: theory -> xstring -> thm val METAHYPS: Proof.context -> (thm list -> tactic) -> int -> tactic val freeze_thaw_robust: Proof.context -> thm -> thm * (int -> thm -> thm) end; structure Misc_Legacy: MISC_LEGACY = struct (*iterate a function over all types in a term*) fun it_term_types f = let fun iter(Const(_,T), a) = f(T,a) | iter(Free(_,T), a) = f(T,a) | iter(Var(_,T), a) = f(T,a) | iter(Abs(_,T,t), a) = iter(t,f(T,a)) | iter(f$u, a) = iter(f, iter(u, a)) | iter(Bound _, a) = a in iter end (*Accumulates the names in the term, suppressing duplicates. Includes Frees and Consts. For choosing unambiguous bound var names.*) fun add_term_names (Const(a,_), bs) = insert (op =) (Long_Name.base_name a) bs | add_term_names (Free(a,_), bs) = insert (op =) a bs | add_term_names (f$u, bs) = add_term_names (f, add_term_names(u, bs)) | add_term_names (Abs(_,_,t), bs) = add_term_names(t,bs) | add_term_names (_, bs) = bs; (*Accumulates the TVars in a type, suppressing duplicates.*) fun add_typ_tvars(Type(_,Ts),vs) = List.foldr add_typ_tvars vs Ts | add_typ_tvars(TFree(_),vs) = vs | add_typ_tvars(TVar(v),vs) = insert (op =) v vs; (*Accumulates the TFrees in a type, suppressing duplicates.*) fun add_typ_tfree_names(Type(_,Ts),fs) = List.foldr add_typ_tfree_names fs Ts | add_typ_tfree_names(TFree(f,_),fs) = insert (op =) f fs | add_typ_tfree_names(TVar(_),fs) = fs; fun add_typ_tfrees(Type(_,Ts),fs) = List.foldr add_typ_tfrees fs Ts | add_typ_tfrees(TFree(f),fs) = insert (op =) f fs | add_typ_tfrees(TVar(_),fs) = fs; (*Accumulates the TVars in a term, suppressing duplicates.*) val add_term_tvars = it_term_types add_typ_tvars; (*Accumulates the TFrees in a term, suppressing duplicates.*) val add_term_tfrees = it_term_types add_typ_tfrees; val add_term_tfree_names = it_term_types add_typ_tfree_names; (*Non-list versions*) fun typ_tfrees T = add_typ_tfrees(T,[]); fun typ_tvars T = add_typ_tvars(T,[]); fun term_tfrees t = add_term_tfrees(t,[]); fun term_tvars t = add_term_tvars(t,[]); (*Accumulates the Vars in the term, suppressing duplicates.*) fun add_term_vars (t, vars: term list) = case t of Var _ => Ord_List.insert Term_Ord.term_ord t vars | Abs (_,_,body) => add_term_vars(body,vars) | f$t => add_term_vars (f, add_term_vars(t, vars)) | _ => vars; fun term_vars t = add_term_vars(t,[]); (*Accumulates the Frees in the term, suppressing duplicates.*) fun add_term_frees (t, frees: term list) = case t of Free _ => Ord_List.insert Term_Ord.term_ord t frees | Abs (_,_,body) => add_term_frees(body,frees) | f$t => add_term_frees (f, add_term_frees(t, frees)) | _ => frees; fun term_frees t = add_term_frees(t,[]); fun mk_defpair (lhs, rhs) = (case Term.head_of lhs of Const (name, _) => (Thm.def_name (Long_Name.base_name name), Logic.mk_equals (lhs, rhs)) | _ => raise TERM ("Malformed definition: head of lhs not a constant", [lhs, rhs])); fun get_def thy = Thm.axiom thy o Name_Space.intern (Theory.axiom_space thy) o Thm.def_name; (**** METAHYPS -- tactical for using hypotheses as meta-level assumptions METAHYPS (fn prems => tac prems) i converts subgoal i, of the form !!x1...xm. [| A1;...;An] ==> A into a new proof state A==>A, supplying A1,...,An as meta-level assumptions (in "prems"). The parameters x1,...,xm become free variables. If the resulting proof state is [| B1;...;Bk] ==> C (possibly assuming A1,...,An) then it is lifted back into the original context, yielding k subgoals. Replaces unknowns in the context by Frees having the prefix METAHYP_ New unknowns in [| B1;...;Bk] ==> C are lifted over x1,...,xm. DOES NOT HANDLE TYPE UNKNOWNS. NOTE: This version does not observe the proof context, and thus cannot work reliably. See also Subgoal.SUBPROOF and Subgoal.FOCUS for properly localized variants of the same idea. ****) local (*Strips assumptions in goal yielding ( [x1,...,xm], [H1,...,Hn], B ) H1,...,Hn are the hypotheses; x1...xm are variants of the parameters. Main difference from strip_assums concerns parameters: it replaces the bound variables by free variables. *) fun strip_context_aux (params, Hs, \<^Const_>\Pure.imp for H B\) = strip_context_aux (params, H :: Hs, B) | strip_context_aux (params, Hs, \<^Const_>\Pure.all _ for \Abs (a, T, t)\\) = - let val (b, u) = Syntax_Trans.variant_abs (a, T, t) + let val (b, u) = Term.dest_abs (a, T, t) in strip_context_aux ((b, T) :: params, Hs, u) end | strip_context_aux (params, Hs, B) = (rev params, rev Hs, B); fun strip_context A = strip_context_aux ([], [], A); (*Left-to-right replacements: ctpairs = [...,(vi,ti),...]. Instantiates distinct free variables by terms of same type.*) fun free_instantiate ctpairs = forall_elim_list (map snd ctpairs) o forall_intr_list (map fst ctpairs); fun free_of s ((a, i), T) = Free (s ^ (case i of 0 => a | _ => a ^ "_" ^ string_of_int i), T) fun mk_inst v = (Var v, free_of "METAHYP1_" v) fun metahyps_split_prem prem = let (*find all vars in the hyps -- should find tvars also!*) val hyps_vars = fold Term.add_vars (Logic.strip_assums_hyp prem) [] val insts = map mk_inst hyps_vars (*replace the hyps_vars by Frees*) val prem' = subst_atomic insts prem val (params,hyps,concl) = strip_context prem' in (insts,params,hyps,concl) end; fun metahyps_aux_tac ctxt tacf (prem,gno) state = let val (insts,params,hyps,concl) = metahyps_split_prem prem val maxidx = Thm.maxidx_of state val chyps = map (Thm.cterm_of ctxt) hyps val hypths = map Thm.assume chyps val subprems = map (Thm.forall_elim_vars 0) hypths val fparams = map Free params val cparams = map (Thm.cterm_of ctxt) fparams fun swap_ctpair (t, u) = apply2 (Thm.cterm_of ctxt) (u, t) (*Subgoal variables: make Free; lift type over params*) fun mk_subgoal_inst concl_vars (v, T) = if member (op =) concl_vars (v, T) then ((v, T), true, free_of "METAHYP2_" (v, T)) else ((v, T), false, free_of "METAHYP2_" (v, map #2 params ---> T)) (*Instantiate subgoal vars by Free applied to params*) fun mk_inst (v, in_concl, u) = if in_concl then (v, Thm.cterm_of ctxt u) else (v, Thm.cterm_of ctxt (list_comb (u, fparams))) (*Restore Vars with higher type and index*) fun mk_subgoal_swap_ctpair (((a, i), T), in_concl, u as Free (_, U)) = if in_concl then apply2 (Thm.cterm_of ctxt) (u, Var ((a, i), T)) else apply2 (Thm.cterm_of ctxt) (u, Var ((a, i + maxidx), U)) (*Embed B in the original context of params and hyps*) fun embed B = fold_rev Logic.all fparams (Logic.list_implies (hyps, B)) (*Strip the context using elimination rules*) fun elim Bhyp = implies_elim_list (forall_elim_list cparams Bhyp) hypths (*A form of lifting that discharges assumptions.*) fun relift st = let val prop = Thm.prop_of st val subgoal_vars = (*Vars introduced in the subgoals*) fold Term.add_vars (Logic.strip_imp_prems prop) [] and concl_vars = Term.add_vars (Logic.strip_imp_concl prop) [] val subgoal_insts = map (mk_subgoal_inst concl_vars) subgoal_vars val st' = Thm.instantiate (TVars.empty, Vars.build (fold (Vars.add o mk_inst) subgoal_insts)) st val emBs = map (Thm.cterm_of ctxt o embed) (Thm.prems_of st') val Cth = implies_elim_list st' (map (elim o Thm.assume) emBs) in (*restore the unknowns to the hypotheses*) free_instantiate (map swap_ctpair insts @ map mk_subgoal_swap_ctpair subgoal_insts) (*discharge assumptions from state in same order*) (implies_intr_list emBs (forall_intr_list cparams (implies_intr_list chyps Cth))) end (*function to replace the current subgoal*) fun next st = Thm.bicompose (SOME ctxt) {flatten = true, match = false, incremented = false} (false, relift st, Thm.nprems_of st) gno state in Seq.maps next (tacf subprems (Thm.trivial (Thm.cterm_of ctxt concl))) end; in fun METAHYPS ctxt tacf n thm = SUBGOAL (metahyps_aux_tac ctxt tacf) n thm handle THM ("assume: variables", _, _) => Seq.empty end; (* generating identifiers -- often fresh *) local (*Maps 0-61 to A-Z, a-z, 0-9; exclude _ or ' to avoid clash with internal/unusual indentifiers*) fun gensym_char i = if i<26 then chr (ord "A" + i) else if i<52 then chr (ord "a" + i - 26) else chr (ord "0" + i - 52); val char_vec = Vector.tabulate (62, gensym_char); fun newid n = implode (map (fn i => Vector.sub (char_vec, i)) (radixpand (62, n))); val gensym_seed = Synchronized.var "gensym_seed" (0: int); in fun gensym pre = Synchronized.change_result gensym_seed (fn i => (pre ^ newid i, i + 1)); end; (*Convert all Vars in a theorem to Frees. Also return a function for reversing that operation. DOES NOT WORK FOR TYPE VARIABLES.*) fun freeze_thaw_robust ctxt th = let val fth = Thm.legacy_freezeT th in case Thm.fold_terms {hyps = false} Term.add_vars fth [] of [] => (fth, fn _ => fn x => x) (*No vars: nothing to do!*) | vars => let fun newName (ix,_) = (ix, gensym (string_of_indexname ix)) val alist = map newName vars fun mk_inst (v,T) = apply2 (Thm.cterm_of ctxt) (Var (v, T), Free (the (AList.lookup (op =) alist v), T)) val insts = map mk_inst vars fun thaw i th' = (*i is non-negative increment for Var indexes*) th' |> forall_intr_list (map #2 insts) |> forall_elim_list (map (Thm.incr_indexes_cterm i o #1) insts) in (Thm.instantiate (TVars.empty, Vars.build (fold (Vars.add o apfst (dest_Var o Thm.term_of)) insts)) fth, thaw) end end; end;